--- a/Admin/isatest/isatest-makeall Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/isatest-makeall Tue Oct 27 14:46:03 2009 +0000
@@ -63,7 +63,7 @@
;;
sunbroy2)
- MFLAGS="-k -j 6"
+ MFLAGS="-k -j 2"
NICE="nice"
;;
--- a/Admin/isatest/isatest-makedist Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/isatest-makedist Tue Oct 27 14:46:03 2009 +0000
@@ -91,7 +91,7 @@
## spawn test runs
-#$SSH sunbroy2 "$MAKEALL $HOME/settings/sun-poly"
+$SSH sunbroy2 "$MAKEALL $HOME/settings/sun-poly"
# give test some time to copy settings and start
sleep 15
$SSH macbroy22 "$MAKEALL $HOME/settings/at-poly"
@@ -110,8 +110,8 @@
sleep 15
$SSH macbroy5 "$MAKEALL $HOME/settings/mac-poly"
sleep 15
-#$SSH macbroy6 "$MAKEALL $HOME/settings/at-mac-poly-5.1-para"
-#sleep 15
+$SSH macbroy6 "sleep 10800; $MAKEALL $HOME/settings/at-mac-poly-5.1-para"
+sleep 15
$SSH atbroy51 "$HOME/admin/isatest/isatest-annomaly"
echo ------------------- spawned tests successfully --- `date` --- $HOSTNAME >> $DISTLOG 2>&1
--- a/Admin/isatest/settings/at-mac-poly-5.1-para Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/at-mac-poly-5.1-para Tue Oct 27 14:46:03 2009 +0000
@@ -23,6 +23,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i false -d false -M 4"
+ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
HOL_USEDIR_OPTIONS="-p 2 -q 0"
--- a/Admin/isatest/settings/mac-poly-M4 Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/mac-poly-M4 Tue Oct 27 14:46:03 2009 +0000
@@ -1,7 +1,7 @@
# -*- shell-script -*- :mode=shellscript:
- POLYML_HOME="/home/polyml/polyml-svn"
- ML_SYSTEM="polyml-experimental"
+ POLYML_HOME="/home/polyml/polyml-5.2.1"
+ ML_SYSTEM="polyml-5.2.1"
ML_PLATFORM="x86-darwin"
ML_HOME="$POLYML_HOME/$ML_PLATFORM"
ML_OPTIONS="--mutable 800 --immutable 2000"
@@ -23,6 +23,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i false -d false -M 4 -t true -q 2"
+ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
HOL_USEDIR_OPTIONS="-p 2 -q 0"
--- a/Admin/isatest/settings/mac-poly-M8 Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/mac-poly-M8 Tue Oct 27 14:46:03 2009 +0000
@@ -1,7 +1,7 @@
# -*- shell-script -*- :mode=shellscript:
- POLYML_HOME="/home/polyml/polyml-svn"
- ML_SYSTEM="polyml-experimental"
+ POLYML_HOME="/home/polyml/polyml-5.2.1"
+ ML_SYSTEM="polyml-5.2.1"
ML_PLATFORM="x86-darwin"
ML_HOME="$POLYML_HOME/$ML_PLATFORM"
ML_OPTIONS="--mutable 800 --immutable 2000"
@@ -23,6 +23,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i false -d false -M 8 -t true -q 2"
+ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
HOL_USEDIR_OPTIONS="-p 2 -q 0"
--- a/Admin/isatest/settings/mac-poly64-M4 Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/mac-poly64-M4 Tue Oct 27 14:46:03 2009 +0000
@@ -23,6 +23,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i false -d false -M 4 -q 2 -t true"
+ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
HOL_USEDIR_OPTIONS="-p 2 -q 2"
--- a/Admin/isatest/settings/mac-poly64-M8 Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/mac-poly64-M8 Tue Oct 27 14:46:03 2009 +0000
@@ -23,6 +23,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i false -d false -M 8 -q 2 -t true"
+ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
HOL_USEDIR_OPTIONS="-p 2 -q 2"
--- a/Admin/isatest/settings/sun-poly Tue Oct 27 12:59:57 2009 +0000
+++ b/Admin/isatest/settings/sun-poly Tue Oct 27 14:46:03 2009 +0000
@@ -23,6 +23,6 @@
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
#ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
-ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true -M 1"
+ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true -M 6 -q 2"
HOL_USEDIR_OPTIONS="-p 0"
--- a/CONTRIBUTORS Tue Oct 27 12:59:57 2009 +0000
+++ b/CONTRIBUTORS Tue Oct 27 14:46:03 2009 +0000
@@ -7,44 +7,48 @@
Contributions to this Isabelle version
--------------------------------------
+* October 2009: Jasmin Blanchette, TUM
+ Nitpick: yet another counterexample generator for Isabelle/HOL
+
* October 2009: Sascha Boehme, TUM
- Extension of SMT method: proof-reconstruction for the SMT solver Z3
+ Extension of SMT method: proof-reconstruction for the SMT solver Z3.
* October 2009: Florian Haftmann, TUM
- Refinement of parts of the HOL datatype package
+ Refinement of parts of the HOL datatype package.
* October 2009: Florian Haftmann, TUM
- Generic term styles for term antiquotations
+ Generic term styles for term antiquotations.
* September 2009: Thomas Sewell, NICTA
- More efficient HOL/record implementation
+ More efficient HOL/record implementation.
* September 2009: Sascha Boehme, TUM
- SMT method using external SMT solvers
+ SMT method using external SMT solvers.
* September 2009: Florian Haftmann, TUM
- Refinement of sets and lattices
+ Refinement of sets and lattices.
* July 2009: Jeremy Avigad and Amine Chaieb
- New number theory
+ New number theory.
* July 2009: Philipp Meyer, TUM
- HOL/Library/Sum_of_Squares: functionality to call a remote csdp prover
+ HOL/Library/Sum_Of_Squares: functionality to call a remote csdp
+ prover.
* July 2009: Florian Haftmann, TUM
- New quickcheck implementation using new code generator
+ New quickcheck implementation using new code generator.
* July 2009: Florian Haftmann, TUM
- HOL/Library/FSet: an explicit type of sets; finite sets ready to use for code generation
-
-* June 2009: Andreas Lochbihler, Uni Karlsruhe
- HOL/Library/Fin_Fun: almost everywhere constant functions
+ HOL/Library/FSet: an explicit type of sets; finite sets ready to use
+ for code generation.
* June 2009: Florian Haftmann, TUM
- HOL/Library/Tree: searchtrees implementing mappings, ready to use for code generation
+ HOL/Library/Tree: searchtrees implementing mappings, ready to use
+ for code generation.
* March 2009: Philipp Meyer, TUM
- minimalization algorithm for results from sledgehammer call
+ Minimalization algorithm for results from sledgehammer call.
+
Contributions to Isabelle2009
-----------------------------
--- a/NEWS Tue Oct 27 12:59:57 2009 +0000
+++ b/NEWS Tue Oct 27 14:46:03 2009 +0000
@@ -50,6 +50,9 @@
this method is proof-producing. Certificates are provided to
avoid calling the external solvers solely for re-checking proofs.
+* New counterexample generator tool "nitpick" based on the Kodkod
+relational model finder.
+
* Reorganization of number theory:
* former session NumberTheory now named Old_Number_Theory
* new session Number_Theory by Jeremy Avigad; if possible, prefer this.
@@ -167,7 +170,8 @@
* New implementation of quickcheck uses generic code generator;
default generators are provided for all suitable HOL types, records
-and datatypes.
+and datatypes. Old quickcheck can be re-activated importing
+theory Library/SML_Quickcheck.
* Renamed theorems:
Suc_eq_add_numeral_1 -> Suc_eq_plus1
--- a/doc-src/Dirs Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/Dirs Tue Oct 27 14:46:03 2009 +0000
@@ -1,1 +1,1 @@
-Intro Ref System Logics HOL ZF Inductive TutorialI IsarOverview IsarRef IsarImplementation Locales LaTeXsugar Classes Codegen Functions Main
+Intro Ref System Logics HOL ZF Inductive TutorialI IsarOverview IsarRef IsarImplementation Locales LaTeXsugar Classes Codegen Functions Nitpick Main
--- a/doc-src/IsarImplementation/Thy/Logic.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/Logic.thy Tue Oct 27 14:46:03 2009 +0000
@@ -322,9 +322,9 @@
@{index_ML fastype_of: "term -> typ"} \\
@{index_ML lambda: "term -> term -> term"} \\
@{index_ML betapply: "term * term -> term"} \\
- @{index_ML Sign.declare_const: "Properties.T -> (binding * typ) * mixfix ->
+ @{index_ML Sign.declare_const: "(binding * typ) * mixfix ->
theory -> term * theory"} \\
- @{index_ML Sign.add_abbrev: "string -> Properties.T -> binding * term ->
+ @{index_ML Sign.add_abbrev: "string -> binding * term ->
theory -> (term * term) * theory"} \\
@{index_ML Sign.const_typargs: "theory -> string * typ -> typ list"} \\
@{index_ML Sign.const_instance: "theory -> string * typ list -> typ"} \\
@@ -370,11 +370,11 @@
"t u"}, with topmost @{text "\<beta>"}-conversion if @{text "t"} is an
abstraction.
- \item @{ML Sign.declare_const}~@{text "properties ((c, \<sigma>), mx)"}
+ \item @{ML Sign.declare_const}~@{text "((c, \<sigma>), mx)"}
declares a new constant @{text "c :: \<sigma>"} with optional mixfix
syntax.
- \item @{ML Sign.add_abbrev}~@{text "print_mode properties (c, t)"}
+ \item @{ML Sign.add_abbrev}~@{text "print_mode (c, t)"}
introduces a new term abbreviation @{text "c \<equiv> t"}.
\item @{ML Sign.const_typargs}~@{text "thy (c, \<tau>)"} and @{ML--- a/doc-src/IsarImplementation/Thy/ML.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/ML.thy Tue Oct 27 14:46:03 2009 +0000
@@ -317,7 +317,7 @@
a theory by constant declararion and primitive definitions:
\smallskip\begin{mldecls}
- @{ML "Sign.declare_const: Properties.T -> (binding * typ) * mixfix
+ @{ML "Sign.declare_const: (binding * typ) * mixfix
-> theory -> term * theory"} \\
@{ML "Thm.add_def: bool -> bool -> binding * term -> theory -> thm * theory"}
\end{mldecls}
@@ -329,7 +329,7 @@
\smallskip\begin{mldecls}
@{ML "(fn (t, thy) => Thm.add_def false false
(Binding.name \"bar_def\", Logic.mk_equals (t, @{term \"%x. x\"})) thy)
- (Sign.declare_const []
+ (Sign.declare_const
((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn) thy)"}
\end{mldecls}
@@ -344,7 +344,7 @@
\smallskip\begin{mldecls}
@{ML "thy
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
|> (fn (t, thy) => thy
|> Thm.add_def false false
(Binding.name \"bar_def\", Logic.mk_equals (t, @{term \"%x. x\"})))"}
@@ -368,7 +368,7 @@
\smallskip\begin{mldecls}
@{ML "thy
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
|-> (fn t => Thm.add_def false false
(Binding.name \"bar_def\", Logic.mk_equals (t, @{term \"%x. x\"})))
"}
@@ -378,7 +378,7 @@
\smallskip\begin{mldecls}
@{ML "thy
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
|>> (fn t => Logic.mk_equals (t, @{term \"%x. x\"}))
|-> (fn def => Thm.add_def false false (Binding.name \"bar_def\", def))
"}
@@ -389,7 +389,7 @@
\smallskip\begin{mldecls}
@{ML "thy
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
||> Sign.add_path \"foobar\"
|-> (fn t => Thm.add_def false false
(Binding.name \"bar_def\", Logic.mk_equals (t, @{term \"%x. x\"})))
@@ -401,8 +401,8 @@
\smallskip\begin{mldecls}
@{ML "thy
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
-||>> Sign.declare_const [] ((Binding.name \"foobar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+||>> Sign.declare_const ((Binding.name \"foobar\", @{typ \"foo => foo\"}), NoSyn)
|-> (fn (t1, t2) => Thm.add_def false false
(Binding.name \"bar_def\", Logic.mk_equals (t1, t2)))
"}
@@ -447,7 +447,7 @@
val consts = [\"foo\", \"bar\"];
in
thy
- |> fold_map (fn const => Sign.declare_const []
+ |> fold_map (fn const => Sign.declare_const
((Binding.name const, @{typ \"foo => foo\"}), NoSyn)) consts
|>> map (fn t => Logic.mk_equals (t, @{term \"%x. x\"}))
|-> (fn defs => fold_map (fn def =>
@@ -486,11 +486,11 @@
\smallskip\begin{mldecls}
@{ML "thy
|> tap (fn _ => writeln \"now adding constant\")
-|> Sign.declare_const [] ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
+|> Sign.declare_const ((Binding.name \"bar\", @{typ \"foo => foo\"}), NoSyn)
||>> `(fn thy => Sign.declared_const thy
(Sign.full_name thy (Binding.name \"foobar\")))
|-> (fn (t, b) => if b then I
- else Sign.declare_const []
+ else Sign.declare_const
((Binding.name \"foobar\", @{typ \"foo => foo\"}), NoSyn) #> snd)
"}
\end{mldecls}--- a/doc-src/IsarImplementation/Thy/Prelim.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/Prelim.thy Tue Oct 27 14:46:03 2009 +0000
@@ -689,19 +689,19 @@
@{index_ML Long_Name.explode: "string -> string list"} \\
\end{mldecls}
\begin{mldecls}
- @{index_ML_type NameSpace.naming} \\
- @{index_ML NameSpace.default_naming: NameSpace.naming} \\
- @{index_ML NameSpace.add_path: "string -> NameSpace.naming -> NameSpace.naming"} \\
- @{index_ML NameSpace.full_name: "NameSpace.naming -> binding -> string"} \\
+ @{index_ML_type Name_Space.naming} \\
+ @{index_ML Name_Space.default_naming: Name_Space.naming} \\
+ @{index_ML Name_Space.add_path: "string -> Name_Space.naming -> Name_Space.naming"} \\
+ @{index_ML Name_Space.full_name: "Name_Space.naming -> binding -> string"} \\
\end{mldecls}
\begin{mldecls}
- @{index_ML_type NameSpace.T} \\
- @{index_ML NameSpace.empty: NameSpace.T} \\
- @{index_ML NameSpace.merge: "NameSpace.T * NameSpace.T -> NameSpace.T"} \\
- @{index_ML NameSpace.declare: "NameSpace.naming -> binding -> NameSpace.T ->
- string * NameSpace.T"} \\
- @{index_ML NameSpace.intern: "NameSpace.T -> string -> string"} \\
- @{index_ML NameSpace.extern: "NameSpace.T -> string -> string"} \\
+ @{index_ML_type Name_Space.T} \\
+ @{index_ML Name_Space.empty: "string -> Name_Space.T"} \\
+ @{index_ML Name_Space.merge: "Name_Space.T * Name_Space.T -> Name_Space.T"} \\
+ @{index_ML Name_Space.declare: "bool -> Name_Space.naming -> binding -> Name_Space.T ->
+ string * Name_Space.T"} \\
+ @{index_ML Name_Space.intern: "Name_Space.T -> string -> string"} \\
+ @{index_ML Name_Space.extern: "Name_Space.T -> string -> string"} \\
\end{mldecls}
\begin{description}
@@ -719,41 +719,43 @@
Long_Name.explode}~@{text "name"} convert between the packed string
representation and the explicit list form of qualified names.
- \item @{ML_type NameSpace.naming} represents the abstract concept of
+ \item @{ML_type Name_Space.naming} represents the abstract concept of
a naming policy.
- \item @{ML NameSpace.default_naming} is the default naming policy.
+ \item @{ML Name_Space.default_naming} is the default naming policy.
In a theory context, this is usually augmented by a path prefix
consisting of the theory name.
- \item @{ML NameSpace.add_path}~@{text "path naming"} augments the
+ \item @{ML Name_Space.add_path}~@{text "path naming"} augments the
naming policy by extending its path component.
- \item @{ML NameSpace.full_name}~@{text "naming binding"} turns a
+ \item @{ML Name_Space.full_name}~@{text "naming binding"} turns a
name binding (usually a basic name) into the fully qualified
internal name, according to the given naming policy.
- \item @{ML_type NameSpace.T} represents name spaces.
+ \item @{ML_type Name_Space.T} represents name spaces.
- \item @{ML NameSpace.empty} and @{ML NameSpace.merge}~@{text
+ \item @{ML Name_Space.empty}~@{text "kind"} and @{ML Name_Space.merge}~@{text
"(space\<^isub>1, space\<^isub>2)"} are the canonical operations for
maintaining name spaces according to theory data management
- (\secref{sec:context-data}).
+ (\secref{sec:context-data}); @{text "kind"} is a formal comment
+ to characterize the purpose of a name space.
- \item @{ML NameSpace.declare}~@{text "naming bindings space"} enters a
- name binding as fully qualified internal name into the name space,
- with external accesses determined by the naming policy.
+ \item @{ML Name_Space.declare}~@{text "strict naming bindings
+ space"} enters a name binding as fully qualified internal name into
+ the name space, with external accesses determined by the naming
+ policy.
- \item @{ML NameSpace.intern}~@{text "space name"} internalizes a
+ \item @{ML Name_Space.intern}~@{text "space name"} internalizes a
(partially qualified) external name.
This operation is mostly for parsing! Note that fully qualified
names stemming from declarations are produced via @{ML
- "NameSpace.full_name"} and @{ML "NameSpace.declare"}
+ "Name_Space.full_name"} and @{ML "Name_Space.declare"}
(or their derivatives for @{ML_type theory} and
@{ML_type Proof.context}).
- \item @{ML NameSpace.extern}~@{text "space name"} externalizes a
+ \item @{ML Name_Space.extern}~@{text "space name"} externalizes a
(fully qualified) internal name.
This operation is mostly for printing! User code should not rely on--- a/doc-src/IsarImplementation/Thy/document/Logic.tex Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/document/Logic.tex Tue Oct 27 14:46:03 2009 +0000
@@ -325,9 +325,9 @@
\indexdef{}{ML}{fastype\_of}\verb|fastype_of: term -> typ| \\
\indexdef{}{ML}{lambda}\verb|lambda: term -> term -> term| \\
\indexdef{}{ML}{betapply}\verb|betapply: term * term -> term| \\
- \indexdef{}{ML}{Sign.declare\_const}\verb|Sign.declare_const: Properties.T -> (binding * typ) * mixfix ->|\isasep\isanewline%
+ \indexdef{}{ML}{Sign.declare\_const}\verb|Sign.declare_const: (binding * typ) * mixfix ->|\isasep\isanewline%
\verb| theory -> term * theory| \\
- \indexdef{}{ML}{Sign.add\_abbrev}\verb|Sign.add_abbrev: string -> Properties.T -> binding * term ->|\isasep\isanewline%
+ \indexdef{}{ML}{Sign.add\_abbrev}\verb|Sign.add_abbrev: string -> binding * term ->|\isasep\isanewline%
\verb| theory -> (term * term) * theory| \\
\indexdef{}{ML}{Sign.const\_typargs}\verb|Sign.const_typargs: theory -> string * typ -> typ list| \\
\indexdef{}{ML}{Sign.const\_instance}\verb|Sign.const_instance: theory -> string * typ list -> typ| \\
@@ -365,11 +365,11 @@
\item \verb|betapply|~\isa{{\isacharparenleft}t{\isacharcomma}\ u{\isacharparenright}} produces an application \isa{t\ u}, with topmost \isa{{\isasymbeta}}-conversion if \isa{t} is an
abstraction.
- \item \verb|Sign.declare_const|~\isa{properties\ {\isacharparenleft}{\isacharparenleft}c{\isacharcomma}\ {\isasymsigma}{\isacharparenright}{\isacharcomma}\ mx{\isacharparenright}}
+ \item \verb|Sign.declare_const|~\isa{{\isacharparenleft}{\isacharparenleft}c{\isacharcomma}\ {\isasymsigma}{\isacharparenright}{\isacharcomma}\ mx{\isacharparenright}}
declares a new constant \isa{c\ {\isacharcolon}{\isacharcolon}\ {\isasymsigma}} with optional mixfix
syntax.
- \item \verb|Sign.add_abbrev|~\isa{print{\isacharunderscore}mode\ properties\ {\isacharparenleft}c{\isacharcomma}\ t{\isacharparenright}}
+ \item \verb|Sign.add_abbrev|~\isa{print{\isacharunderscore}mode\ {\isacharparenleft}c{\isacharcomma}\ t{\isacharparenright}}
introduces a new term abbreviation \isa{c\ {\isasymequiv}\ t}.
\item \verb|Sign.const_typargs|~\isa{thy\ {\isacharparenleft}c{\isacharcomma}\ {\isasymtau}{\isacharparenright}} and \verb|Sign.const_instance|~\isa{thy\ {\isacharparenleft}c{\isacharcomma}\ {\isacharbrackleft}{\isasymtau}\isactrlisub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymtau}\isactrlisub n{\isacharbrackright}{\isacharparenright}}--- a/doc-src/IsarImplementation/Thy/document/ML.tex Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/document/ML.tex Tue Oct 27 14:46:03 2009 +0000
@@ -242,14 +242,14 @@
view being presented to the user.
Occasionally, such global process flags are treated like implicit
- arguments to certain operations, by using the \verb|setmp| combinator
+ arguments to certain operations, by using the \verb|setmp_CRITICAL| combinator
for safe temporary assignment. Its traditional purpose was to
ensure proper recovery of the original value when exceptions are
raised in the body, now the functionality is extended to enter the
\emph{critical section} (with its usual potential of degrading
parallelism).
- Note that recovery of plain value passing semantics via \verb|setmp|~\isa{ref\ value} assumes that this \isa{ref} is
+ Note that recovery of plain value passing semantics via \verb|setmp_CRITICAL|~\isa{ref\ value} assumes that this \isa{ref} is
exclusively manipulated within the critical section. In particular,
any persistent global assignment of \isa{ref\ {\isacharcolon}{\isacharequal}\ value} needs to
be marked critical as well, to prevent intruding another threads
@@ -277,7 +277,7 @@
\begin{mldecls}
\indexdef{}{ML}{NAMED\_CRITICAL}\verb|NAMED_CRITICAL: string -> (unit -> 'a) -> 'a| \\
\indexdef{}{ML}{CRITICAL}\verb|CRITICAL: (unit -> 'a) -> 'a| \\
- \indexdef{}{ML}{setmp}\verb|setmp: 'a Unsynchronized.ref -> 'a -> ('b -> 'c) -> 'b -> 'c| \\
+ \indexdef{}{ML}{setmp\_CRITICAL}\verb|setmp_CRITICAL: 'a Unsynchronized.ref -> 'a -> ('b -> 'c) -> 'b -> 'c| \\
\end{mldecls}
\begin{description}
@@ -291,7 +291,7 @@
\item \verb|CRITICAL| is the same as \verb|NAMED_CRITICAL| with empty
name argument.
- \item \verb|setmp|~\isa{ref\ value\ f\ x} evaluates \isa{f\ x}
+ \item \verb|setmp_CRITICAL|~\isa{ref\ value\ f\ x} evaluates \isa{f\ x}
while staying within the critical section and having \isa{ref\ {\isacharcolon}{\isacharequal}\ value} assigned temporarily. This recovers a value-passing
semantics involving global references, regardless of exceptions or
concurrency.
@@ -366,7 +366,7 @@
a theory by constant declararion and primitive definitions:
\smallskip\begin{mldecls}
- \verb|Sign.declare_const: Properties.T -> (binding * typ) * mixfix|\isasep\isanewline%
+ \verb|Sign.declare_const: (binding * typ) * mixfix|\isasep\isanewline%
\verb| -> theory -> term * theory| \\
\verb|Thm.add_def: bool -> bool -> binding * term -> theory -> thm * theory|
\end{mldecls}
@@ -378,7 +378,7 @@
\smallskip\begin{mldecls}
\verb|(fn (t, thy) => Thm.add_def false false|\isasep\isanewline%
\verb| (Binding.name "bar_def", Logic.mk_equals (t, @{term "%x. x"})) thy)|\isasep\isanewline%
-\verb| (Sign.declare_const []|\isasep\isanewline%
+\verb| (Sign.declare_const|\isasep\isanewline%
\verb| ((Binding.name "bar", @{typ "foo => foo"}), NoSyn) thy)|
\end{mldecls}
@@ -394,7 +394,7 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb|> (fn (t, thy) => thy|\isasep\isanewline%
\verb||\verb,|,\verb|> Thm.add_def false false|\isasep\isanewline%
\verb| (Binding.name "bar_def", Logic.mk_equals (t, @{term "%x. x"})))|
@@ -433,7 +433,7 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb|-> (fn t => Thm.add_def false false|\isasep\isanewline%
\verb| (Binding.name "bar_def", Logic.mk_equals (t, @{term "%x. x"})))|\isasep\isanewline%
@@ -443,7 +443,7 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb|>> (fn t => Logic.mk_equals (t, @{term "%x. x"}))|\isasep\isanewline%
\verb||\verb,|,\verb|-> (fn def => Thm.add_def false false (Binding.name "bar_def", def))|\isasep\isanewline%
@@ -454,7 +454,7 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb||\verb,|,\verb|> Sign.add_path "foobar"|\isasep\isanewline%
\verb||\verb,|,\verb|-> (fn t => Thm.add_def false false|\isasep\isanewline%
\verb| (Binding.name "bar_def", Logic.mk_equals (t, @{term "%x. x"})))|\isasep\isanewline%
@@ -466,8 +466,8 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
-\verb||\verb,|,\verb||\verb,|,\verb|>> Sign.declare_const [] ((Binding.name "foobar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb||\verb,|,\verb|>> Sign.declare_const ((Binding.name "foobar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb|-> (fn (t1, t2) => Thm.add_def false false|\isasep\isanewline%
\verb| (Binding.name "bar_def", Logic.mk_equals (t1, t2)))|\isasep\isanewline%
@@ -527,7 +527,7 @@
\verb| val consts = ["foo", "bar"];|\isasep\isanewline%
\verb|in|\isasep\isanewline%
\verb| thy|\isasep\isanewline%
-\verb| |\verb,|,\verb|> fold_map (fn const => Sign.declare_const []|\isasep\isanewline%
+\verb| |\verb,|,\verb|> fold_map (fn const => Sign.declare_const|\isasep\isanewline%
\verb| ((Binding.name const, @{typ "foo => foo"}), NoSyn)) consts|\isasep\isanewline%
\verb| |\verb,|,\verb|>> map (fn t => Logic.mk_equals (t, @{term "%x. x"}))|\isasep\isanewline%
\verb| |\verb,|,\verb|-> (fn defs => fold_map (fn def =>|\isasep\isanewline%
@@ -596,11 +596,11 @@
\smallskip\begin{mldecls}
\verb|thy|\isasep\isanewline%
\verb||\verb,|,\verb|> tap (fn _ => writeln "now adding constant")|\isasep\isanewline%
-\verb||\verb,|,\verb|> Sign.declare_const [] ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
+\verb||\verb,|,\verb|> Sign.declare_const ((Binding.name "bar", @{typ "foo => foo"}), NoSyn)|\isasep\isanewline%
\verb||\verb,|,\verb||\verb,|,\verb|>> `(fn thy => Sign.declared_const thy|\isasep\isanewline%
\verb| (Sign.full_name thy (Binding.name "foobar")))|\isasep\isanewline%
\verb||\verb,|,\verb|-> (fn (t, b) => if b then I|\isasep\isanewline%
-\verb| else Sign.declare_const []|\isasep\isanewline%
+\verb| else Sign.declare_const|\isasep\isanewline%
\verb| ((Binding.name "foobar", @{typ "foo => foo"}), NoSyn) #> snd)|\isasep\isanewline%
\end{mldecls}%--- a/doc-src/IsarImplementation/Thy/document/Prelim.tex Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/IsarImplementation/Thy/document/Prelim.tex Tue Oct 27 14:46:03 2009 +0000
@@ -798,19 +798,19 @@
\indexdef{}{ML}{Long\_Name.explode}\verb|Long_Name.explode: string -> string list| \\
\end{mldecls}
\begin{mldecls}
- \indexdef{}{ML type}{NameSpace.naming}\verb|type NameSpace.naming| \\
- \indexdef{}{ML}{NameSpace.default\_naming}\verb|NameSpace.default_naming: NameSpace.naming| \\
- \indexdef{}{ML}{NameSpace.add\_path}\verb|NameSpace.add_path: string -> NameSpace.naming -> NameSpace.naming| \\
- \indexdef{}{ML}{NameSpace.full\_name}\verb|NameSpace.full_name: NameSpace.naming -> binding -> string| \\
+ \indexdef{}{ML type}{Name\_Space.naming}\verb|type Name_Space.naming| \\
+ \indexdef{}{ML}{Name\_Space.default\_naming}\verb|Name_Space.default_naming: Name_Space.naming| \\
+ \indexdef{}{ML}{Name\_Space.add\_path}\verb|Name_Space.add_path: string -> Name_Space.naming -> Name_Space.naming| \\
+ \indexdef{}{ML}{Name\_Space.full\_name}\verb|Name_Space.full_name: Name_Space.naming -> binding -> string| \\
\end{mldecls}
\begin{mldecls}
- \indexdef{}{ML type}{NameSpace.T}\verb|type NameSpace.T| \\
- \indexdef{}{ML}{NameSpace.empty}\verb|NameSpace.empty: NameSpace.T| \\
- \indexdef{}{ML}{NameSpace.merge}\verb|NameSpace.merge: NameSpace.T * NameSpace.T -> NameSpace.T| \\
- \indexdef{}{ML}{NameSpace.declare}\verb|NameSpace.declare: NameSpace.naming -> binding -> NameSpace.T ->|\isasep\isanewline%
-\verb| string * NameSpace.T| \\
- \indexdef{}{ML}{NameSpace.intern}\verb|NameSpace.intern: NameSpace.T -> string -> string| \\
- \indexdef{}{ML}{NameSpace.extern}\verb|NameSpace.extern: NameSpace.T -> string -> string| \\
+ \indexdef{}{ML type}{Name\_Space.T}\verb|type Name_Space.T| \\
+ \indexdef{}{ML}{Name\_Space.empty}\verb|Name_Space.empty: string -> Name_Space.T| \\
+ \indexdef{}{ML}{Name\_Space.merge}\verb|Name_Space.merge: Name_Space.T * Name_Space.T -> Name_Space.T| \\
+ \indexdef{}{ML}{Name\_Space.declare}\verb|Name_Space.declare: bool -> Name_Space.naming -> binding -> Name_Space.T ->|\isasep\isanewline%
+\verb| string * Name_Space.T| \\
+ \indexdef{}{ML}{Name\_Space.intern}\verb|Name_Space.intern: Name_Space.T -> string -> string| \\
+ \indexdef{}{ML}{Name\_Space.extern}\verb|Name_Space.extern: Name_Space.T -> string -> string| \\
\end{mldecls}
\begin{description}
@@ -827,39 +827,40 @@
\item \verb|Long_Name.implode|~\isa{names} and \verb|Long_Name.explode|~\isa{name} convert between the packed string
representation and the explicit list form of qualified names.
- \item \verb|NameSpace.naming| represents the abstract concept of
+ \item \verb|Name_Space.naming| represents the abstract concept of
a naming policy.
- \item \verb|NameSpace.default_naming| is the default naming policy.
+ \item \verb|Name_Space.default_naming| is the default naming policy.
In a theory context, this is usually augmented by a path prefix
consisting of the theory name.
- \item \verb|NameSpace.add_path|~\isa{path\ naming} augments the
+ \item \verb|Name_Space.add_path|~\isa{path\ naming} augments the
naming policy by extending its path component.
- \item \verb|NameSpace.full_name|~\isa{naming\ binding} turns a
+ \item \verb|Name_Space.full_name|~\isa{naming\ binding} turns a
name binding (usually a basic name) into the fully qualified
internal name, according to the given naming policy.
- \item \verb|NameSpace.T| represents name spaces.
-
- \item \verb|NameSpace.empty| and \verb|NameSpace.merge|~\isa{{\isacharparenleft}space\isactrlisub {\isadigit{1}}{\isacharcomma}\ space\isactrlisub {\isadigit{2}}{\isacharparenright}} are the canonical operations for
- maintaining name spaces according to theory data management
- (\secref{sec:context-data}).
+ \item \verb|Name_Space.T| represents name spaces.
- \item \verb|NameSpace.declare|~\isa{naming\ bindings\ space} enters a
- name binding as fully qualified internal name into the name space,
- with external accesses determined by the naming policy.
+ \item \verb|Name_Space.empty|~\isa{kind} and \verb|Name_Space.merge|~\isa{{\isacharparenleft}space\isactrlisub {\isadigit{1}}{\isacharcomma}\ space\isactrlisub {\isadigit{2}}{\isacharparenright}} are the canonical operations for
+ maintaining name spaces according to theory data management
+ (\secref{sec:context-data}); \isa{kind} is a formal comment
+ to characterize the purpose of a name space.
- \item \verb|NameSpace.intern|~\isa{space\ name} internalizes a
+ \item \verb|Name_Space.declare|~\isa{strict\ naming\ bindings\ space} enters a name binding as fully qualified internal name into
+ the name space, with external accesses determined by the naming
+ policy.
+
+ \item \verb|Name_Space.intern|~\isa{space\ name} internalizes a
(partially qualified) external name.
This operation is mostly for parsing! Note that fully qualified
- names stemming from declarations are produced via \verb|NameSpace.full_name| and \verb|NameSpace.declare|
+ names stemming from declarations are produced via \verb|Name_Space.full_name| and \verb|Name_Space.declare|
(or their derivatives for \verb|theory| and
\verb|Proof.context|).
- \item \verb|NameSpace.extern|~\isa{space\ name} externalizes a
+ \item \verb|Name_Space.extern|~\isa{space\ name} externalizes a
(fully qualified) internal name.
This operation is mostly for printing! User code should not rely on--- a/doc-src/Makefile.in Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/Makefile.in Tue Oct 27 14:46:03 2009 +0000
@@ -45,6 +45,9 @@
isabelle_zf.eps:
test -r isabelle_zf.eps || ln -s ../gfx/isabelle_zf.eps .
+isabelle_nitpick.eps:
+ test -r isabelle_nitpick.eps || ln -s ../gfx/isabelle_nitpick.eps .
+
isabelle.pdf:
test -r isabelle.pdf || ln -s ../gfx/isabelle.pdf .
@@ -58,6 +61,9 @@
isabelle_zf.pdf:
test -r isabelle_zf.pdf || ln -s ../gfx/isabelle_zf.pdf .
+isabelle_nitpick.pdf:
+ test -r isabelle_nitpick.pdf || ln -s ../gfx/isabelle_nitpick.pdf .
+
typedef.ps:
test -r typedef.ps || ln -s ../gfx/typedef.ps .
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/Nitpick/Makefile Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,36 @@
+#
+# $Id$
+#
+
+## targets
+
+default: dvi
+
+
+## dependencies
+
+include ../Makefile.in
+
+NAME = nitpick
+FILES = nitpick.tex ../iman.sty ../manual.bib
+
+dvi: $(NAME).dvi
+
+$(NAME).dvi: $(FILES) isabelle_nitpick.eps
+ $(LATEX) $(NAME)
+ $(BIBTEX) $(NAME)
+ $(LATEX) $(NAME)
+ $(LATEX) $(NAME)
+ $(SEDINDEX) $(NAME)
+ $(LATEX) $(NAME)
+
+pdf: $(NAME).pdf
+
+$(NAME).pdf: $(FILES) isabelle_nitpick.pdf
+ $(PDFLATEX) $(NAME)
+ $(BIBTEX) $(NAME)
+ $(PDFLATEX) $(NAME)
+ $(PDFLATEX) $(NAME)
+ $(SEDINDEX) $(NAME)
+ $(FIXBOOKMARKS) $(NAME).out
+ $(PDFLATEX) $(NAME)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/Nitpick/nitpick.tex Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,2486 @@
+\documentclass[a4paper,12pt]{article}
+\usepackage[T1]{fontenc}
+\usepackage{amsmath}
+\usepackage{amssymb}
+\usepackage[french,english]{babel}
+\usepackage{color}
+\usepackage{graphicx}
+%\usepackage{mathpazo}
+\usepackage{multicol}
+\usepackage{stmaryrd}
+%\usepackage[scaled=.85]{beramono}
+\usepackage{../iman,../pdfsetup}
+
+%\oddsidemargin=4.6mm
+%\evensidemargin=4.6mm
+%\textwidth=150mm
+%\topmargin=4.6mm
+%\headheight=0mm
+%\headsep=0mm
+%\textheight=234mm
+
+\def\Colon{\mathord{:\mkern-1.5mu:}}
+%\def\lbrakk{\mathopen{\lbrack\mkern-3.25mu\lbrack}}
+%\def\rbrakk{\mathclose{\rbrack\mkern-3.255mu\rbrack}}
+\def\lparr{\mathopen{(\mkern-4mu\mid}}
+\def\rparr{\mathclose{\mid\mkern-4mu)}}
+
+\def\undef{\textit{undefined}}
+\def\unk{{?}}
+%\def\unr{\textit{others}}
+\def\unr{\ldots}
+\def\Abs#1{\hbox{\rm{\flqq}}{\,#1\,}\hbox{\rm{\frqq}}}
+\def\Q{{\smash{\lower.2ex\hbox{$\scriptstyle?$}}}}
+
+\hyphenation{Mini-Sat size-change First-Steps grand-parent nit-pick
+counter-example counter-examples data-type data-types co-data-type
+co-data-types in-duc-tive co-in-duc-tive}
+
+\urlstyle{tt}
+
+\begin{document}
+
+\title{\includegraphics[scale=0.5]{isabelle_nitpick} \\[4ex]
+Picking Nits \\[\smallskipamount]
+\Large A User's Guide to Nitpick for Isabelle/HOL 2010}
+\author{\hbox{} \\
+Jasmin Christian Blanchette \\
+{\normalsize Fakult\"at f\"ur Informatik, Technische Universit\"at M\"unchen} \\
+\hbox{}}
+
+\maketitle
+
+\tableofcontents
+
+\setlength{\parskip}{.7em plus .2em minus .1em}
+\setlength{\parindent}{0pt}
+\setlength{\abovedisplayskip}{\parskip}
+\setlength{\abovedisplayshortskip}{.9\parskip}
+\setlength{\belowdisplayskip}{\parskip}
+\setlength{\belowdisplayshortskip}{.9\parskip}
+
+% General-purpose enum environment with correct spacing
+\newenvironment{enum}%
+ {\begin{list}{}{%
+ \setlength{\topsep}{.1\parskip}%
+ \setlength{\partopsep}{.1\parskip}%
+ \setlength{\itemsep}{\parskip}%
+ \advance\itemsep by-\parsep}}
+ {\end{list}}
+
+\def\pre{\begingroup\vskip0pt plus1ex\advance\leftskip by\leftmargin
+\advance\rightskip by\leftmargin}
+\def\post{\vskip0pt plus1ex\endgroup}
+
+\def\prew{\pre\advance\rightskip by-\leftmargin}
+\def\postw{\post}
+
+\section{Introduction}
+\label{introduction}
+
+Nitpick \cite{blanchette-nipkow-2009} is a counterexample generator for
+Isabelle/HOL \cite{isa-tutorial} that is designed to handle formulas
+combining (co)in\-duc\-tive datatypes, (co)in\-duc\-tively defined predicates, and
+quantifiers. It builds on Kodkod \cite{torlak-jackson-2007}, a highly optimized
+first-order relational model finder developed by the Software Design Group at
+MIT. It is conceptually similar to Refute \cite{weber-2008}, from which it
+borrows many ideas and code fragments, but it benefits from Kodkod's
+optimizations and a new encoding scheme. The name Nitpick is shamelessly
+appropriated from a now retired Alloy precursor.
+
+Nitpick is easy to use---you simply enter \textbf{nitpick} after a putative
+theorem and wait a few seconds. Nonetheless, there are situations where knowing
+how it works under the hood and how it reacts to various options helps
+increase the test coverage. This manual also explains how to install the tool on
+your workstation. Should the motivation fail you, think of the many hours of
+hard work Nitpick will save you. Proving non-theorems is \textsl{hard work}.
+
+Another common use of Nitpick is to find out whether the axioms of a locale are
+satisfiable, while the locale is being developed. To check this, it suffices to
+write
+
+\prew
+\textbf{lemma}~``$\textit{False}$'' \\
+\textbf{nitpick}~[\textit{show\_all}]
+\postw
+
+after the locale's \textbf{begin} keyword. To falsify \textit{False}, Nitpick
+must find a model for the axioms. If it finds no model, we have an indication
+that the axioms might be unsatisfiable.
+
+Nitpick requires the Kodkodi package for Isabelle as well as a Java 1.5 virtual
+machine called \texttt{java}. The examples presented in this manual can be found
+in Isabelle's \texttt{src/HOL/Nitpick\_Examples/Manual\_Nits.thy} theory.
+
+\newbox\boxA
+\setbox\boxA=\hbox{\texttt{nospam}}
+
+The known bugs and limitations at the time of writing are listed in
+\S\ref{known-bugs-and-limitations}. Comments and bug reports concerning Nitpick
+or this manual should be directed to
+\texttt{blan{\color{white}nospam}\kern-\wd\boxA{}chette@\allowbreak
+in.\allowbreak tum.\allowbreak de}.
+
+\vskip2.5\smallskipamount
+
+\textbf{Acknowledgment.} The author would like to thank Mark Summerfield for
+suggesting several textual improvements.
+% and Perry James for reporting a typo.
+
+\section{First Steps}
+\label{first-steps}
+
+This section introduces Nitpick by presenting small examples. If possible, you
+should try out the examples on your workstation. Your theory file should start
+the standard way:
+
+\prew
+\textbf{theory}~\textit{Scratch} \\
+\textbf{imports}~\textit{Main} \\
+\textbf{begin}
+\postw
+
+The results presented here were obtained using the JNI version of MiniSat and
+with multithreading disabled to reduce nondeterminism. This was done by adding
+the line
+
+\prew
+\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSatJNI}, \,\textit{max\_threads}~= 1]
+\postw
+
+after the \textbf{begin} keyword. The JNI version of MiniSat is bundled with
+Kodkodi and is precompiled for the major platforms. Other SAT solvers can also
+be installed, as explained in \S\ref{optimizations}. If you have already
+configured SAT solvers in Isabelle (e.g., for Refute), these will also be
+available to Nitpick.
+
+Throughout this manual, we will explicitly invoke the \textbf{nitpick} command.
+Nitpick also provides an automatic mode that can be enabled by specifying
+
+\prew
+\textbf{nitpick\_params} [\textit{auto}]
+\postw
+
+at the beginning of the theory file. In this mode, Nitpick is run for up to 5
+seconds (by default) on every newly entered theorem, much like Auto Quickcheck.
+
+\subsection{Propositional Logic}
+\label{propositional-logic}
+
+Let's start with a trivial example from propositional logic:
+
+\prew
+\textbf{lemma}~``$P \longleftrightarrow Q$'' \\
+\textbf{nitpick}
+\postw
+
+You should get the following output:
+
+\prew
+\slshape
+Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \textit{True}$ \\
+\hbox{}\qquad\qquad $Q = \textit{False}$
+\postw
+
+Nitpick can also be invoked on individual subgoals, as in the example below:
+
+\prew
+\textbf{apply}~\textit{auto} \\[2\smallskipamount]
+{\slshape goal (2 subgoals): \\
+\ 1. $P\,\Longrightarrow\, Q$ \\
+\ 2. $Q\,\Longrightarrow\, P$} \\[2\smallskipamount]
+\textbf{nitpick}~1 \\[2\smallskipamount]
+{\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \textit{True}$ \\
+\hbox{}\qquad\qquad $Q = \textit{False}$} \\[2\smallskipamount]
+\textbf{nitpick}~2 \\[2\smallskipamount]
+{\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \textit{False}$ \\
+\hbox{}\qquad\qquad $Q = \textit{True}$} \\[2\smallskipamount]
+\textbf{oops}
+\postw
+
+\subsection{Type Variables}
+\label{type-variables}
+
+If you are left unimpressed by the previous example, don't worry. The next
+one is more mind- and computer-boggling:
+
+\prew
+\textbf{lemma} ``$P~x\,\Longrightarrow\, P~(\textrm{THE}~y.\;P~y)$''
+\postw
+\pagebreak[2] %% TYPESETTING
+
+The putative lemma involves the definite description operator, {THE}, presented
+in section 5.10.1 of the Isabelle tutorial \cite{isa-tutorial}. The
+operator is defined by the axiom $(\textrm{THE}~x.\; x = a) = a$. The putative
+lemma is merely asserting the indefinite description operator axiom with {THE}
+substituted for {SOME}.
+
+The free variable $x$ and the bound variable $y$ have type $'a$. For formulas
+containing type variables, Nitpick enumerates the possible domains for each type
+variable, up to a given cardinality (8 by default), looking for a finite
+countermodel:
+
+\prew
+\textbf{nitpick} [\textit{verbose}] \\[2\smallskipamount]
+\slshape
+Trying 8 scopes: \nopagebreak \\
+\hbox{}\qquad \textit{card}~$'a$~= 1; \\
+\hbox{}\qquad \textit{card}~$'a$~= 2; \\
+\hbox{}\qquad $\qquad\vdots$ \\[.5\smallskipamount]
+\hbox{}\qquad \textit{card}~$'a$~= 8. \\[2\smallskipamount]
+Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \{a_2,\, a_3\}$ \\
+\hbox{}\qquad\qquad $x = a_3$ \\[2\smallskipamount]
+Total time: 580 ms.
+\postw
+
+Nitpick found a counterexample in which $'a$ has cardinality 3. (For
+cardinalities 1 and 2, the formula holds.) In the counterexample, the three
+values of type $'a$ are written $a_1$, $a_2$, and $a_3$.
+
+The message ``Trying $n$ scopes: {\ldots}''\ is shown only if the option
+\textit{verbose} is enabled. You can specify \textit{verbose} each time you
+invoke \textbf{nitpick}, or you can set it globally using the command
+
+\prew
+\textbf{nitpick\_params} [\textit{verbose}]
+\postw
+
+This command also displays the current default values for all of the options
+supported by Nitpick. The options are listed in \S\ref{option-reference}.
+
+\subsection{Constants}
+\label{constants}
+
+By just looking at Nitpick's output, it might not be clear why the
+counterexample in \S\ref{type-variables} is genuine. Let's invoke Nitpick again,
+this time telling it to show the values of the constants that occur in the
+formula:
+
+\prew
+\textbf{lemma}~``$P~x\,\Longrightarrow\, P~(\textrm{THE}~y.\;P~y)$'' \\
+\textbf{nitpick}~[\textit{show\_consts}] \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \{a_2,\, a_3\}$ \\
+\hbox{}\qquad\qquad $x = a_3$ \\
+\hbox{}\qquad Constant: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{The}~\textsl{fallback} = a_1$
+\postw
+
+We can see more clearly now. Since the predicate $P$ isn't true for a unique
+value, $\textrm{THE}~y.\;P~y$ can denote any value of type $'a$, even
+$a_1$. Since $P~a_1$ is false, the entire formula is falsified.
+
+As an optimization, Nitpick's preprocessor introduced the special constant
+``\textit{The} fallback'' corresponding to $\textrm{THE}~y.\;P~y$ (i.e.,
+$\mathit{The}~(\lambda y.\;P~y)$) when there doesn't exist a unique $y$
+satisfying $P~y$. We disable this optimization by passing the
+\textit{full\_descrs} option:
+
+\prew
+\textbf{nitpick}~[\textit{full\_descrs},\, \textit{show\_consts}] \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \{a_2,\, a_3\}$ \\
+\hbox{}\qquad\qquad $x = a_3$ \\
+\hbox{}\qquad Constant: \nopagebreak \\
+\hbox{}\qquad\qquad $\hbox{\slshape THE}~y.\;P~y = a_1$
+\postw
+
+As the result of another optimization, Nitpick directly assigned a value to the
+subterm $\textrm{THE}~y.\;P~y$, rather than to the \textit{The} constant. If we
+disable this second optimization by using the command
+
+\prew
+\textbf{nitpick}~[\textit{dont\_specialize},\, \textit{full\_descrs},\,
+\textit{show\_consts}]
+\postw
+
+we finally get \textit{The}:
+
+\prew
+\slshape Constant: \nopagebreak \\
+\hbox{}\qquad $\mathit{The} = \undef{}
+ (\!\begin{aligned}[t]%
+ & \{\} := a_3,\> \{a_3\} := a_3,\> \{a_2\} := a_2, \\[-2pt] %% TYPESETTING
+ & \{a_2, a_3\} := a_1,\> \{a_1\} := a_1,\> \{a_1, a_3\} := a_3, \\[-2pt]
+ & \{a_1, a_2\} := a_3,\> \{a_1, a_2, a_3\} := a_3)\end{aligned}$
+\postw
+
+Notice that $\textit{The}~(\lambda y.\;P~y) = \textit{The}~\{a_2, a_3\} = a_1$,
+just like before.\footnote{The \undef{} symbol's presence is explained as
+follows: In higher-order logic, any function can be built from the undefined
+function using repeated applications of the function update operator $f(x :=
+y)$, just like any list can be built from the empty list using $x \mathbin{\#}
+xs$.}
+
+Our misadventures with THE suggest adding `$\exists!x{.}$' (``there exists a
+unique $x$ such that'') at the front of our putative lemma's assumption:
+
+\prew
+\textbf{lemma}~``$\exists {!}x.\; P~x\,\Longrightarrow\, P~(\textrm{THE}~y.\;P~y)$''
+\postw
+
+The fix appears to work:
+
+\prew
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found no counterexample.
+\postw
+
+We can further increase our confidence in the formula by exhausting all
+cardinalities up to 50:
+
+\prew
+\textbf{nitpick} [\textit{card} $'a$~= 1--50]\footnote{The symbol `--'
+can be entered as \texttt{-} (hyphen) or
+\texttt{\char`\\\char`\<midarrow\char`\>}.} \\[2\smallskipamount]
+\slshape Nitpick found no counterexample.
+\postw
+
+Let's see if Sledgehammer \cite{sledgehammer-2009} can find a proof:
+
+\prew
+\textbf{sledgehammer} \\[2\smallskipamount]
+{\slshape Sledgehammer: external prover ``$e$'' for subgoal 1: \\
+$\exists{!}x.\; P~x\,\Longrightarrow\, P~(\hbox{\slshape THE}~y.\; P~y)$ \\
+Try this command: \textrm{apply}~(\textit{metis~the\_equality})} \\[2\smallskipamount]
+\textbf{apply}~(\textit{metis~the\_equality\/}) \nopagebreak \\[2\smallskipamount]
+{\slshape No subgoals!}% \\[2\smallskipamount]
+%\textbf{done}
+\postw
+
+This must be our lucky day.
+
+\subsection{Skolemization}
+\label{skolemization}
+
+Are all invertible functions onto? Let's find out:
+
+\prew
+\textbf{lemma} ``$\exists g.\; \forall x.~g~(f~x) = x
+ \,\Longrightarrow\, \forall y.\; \exists x.~y = f~x$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 2 and \textit{card} $'b$~=~1: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $f = \undef{}(b_1 := a_1)$ \\
+\hbox{}\qquad Skolem constants: \nopagebreak \\
+\hbox{}\qquad\qquad $g = \undef{}(a_1 := b_1,\> a_2 := b_1)$ \\
+\hbox{}\qquad\qquad $y = a_2$
+\postw
+
+Although $f$ is the only free variable occurring in the formula, Nitpick also
+displays values for the bound variables $g$ and $y$. These values are available
+to Nitpick because it performs skolemization as a preprocessing step.
+
+In the previous example, skolemization only affected the outermost quantifiers.
+This is not always the case, as illustrated below:
+
+\prew
+\textbf{lemma} ``$\exists x.\; \forall f.\; f~x = x$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 2: \\[2\smallskipamount]
+\hbox{}\qquad Skolem constant: \nopagebreak \\
+\hbox{}\qquad\qquad $\lambda x.\; f =
+ \undef{}(\!\begin{aligned}[t]
+ & a_1 := \undef{}(a_1 := a_2,\> a_2 := a_1), \\[-2pt]
+ & a_2 := \undef{}(a_1 := a_1,\> a_2 := a_1))\end{aligned}$
+\postw
+
+The variable $f$ is bound within the scope of $x$; therefore, $f$ depends on
+$x$, as suggested by the notation $\lambda x.\,f$. If $x = a_1$, then $f$ is the
+function that maps $a_1$ to $a_2$ and vice versa; otherwise, $x = a_2$ and $f$
+maps both $a_1$ and $a_2$ to $a_1$. In both cases, $f~x \not= x$.
+
+The source of the Skolem constants is sometimes more obscure:
+
+\prew
+\textbf{lemma} ``$\mathit{refl}~r\,\Longrightarrow\, \mathit{sym}~r$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 2: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $r = \{(a_1, a_1),\, (a_2, a_1),\, (a_2, a_2)\}$ \\
+\hbox{}\qquad Skolem constants: \nopagebreak \\
+\hbox{}\qquad\qquad $\mathit{sym}.x = a_2$ \\
+\hbox{}\qquad\qquad $\mathit{sym}.y = a_1$
+\postw
+
+What happened here is that Nitpick expanded the \textit{sym} constant to its
+definition:
+
+\prew
+$\mathit{sym}~r \,\equiv\,
+ \forall x\> y.\,\> (x, y) \in r \longrightarrow (y, x) \in r.$
+\postw
+
+As their names suggest, the Skolem constants $\mathit{sym}.x$ and
+$\mathit{sym}.y$ are simply the bound variables $x$ and $y$
+from \textit{sym}'s definition.
+
+Although skolemization is a useful optimization, you can disable it by invoking
+Nitpick with \textit{dont\_skolemize}. See \S\ref{optimizations} for details.
+
+\subsection{Natural Numbers and Integers}
+\label{natural-numbers-and-integers}
+
+Because of the axiom of infinity, the type \textit{nat} does not admit any
+finite models. To deal with this, Nitpick considers prefixes $\{0,\, 1,\,
+\ldots,\, K - 1\}$ of \textit{nat} (where $K = \textit{card}~\textit{nat}$) and
+maps all other numbers to the undefined value ($\unk$). The type \textit{int} is
+handled in a similar way: If $K = \textit{card}~\textit{int}$, the subset of
+\textit{int} known to Nitpick is $\{-\lceil K/2 \rceil + 1,\, \ldots,\, +\lfloor
+K/2 \rfloor\}$. Undefined values lead to a three-valued logic.
+
+Here is an example involving \textit{int}:
+
+\prew
+\textbf{lemma} ``$\lbrakk i \le j;\> n \le (m{\Colon}\mathit{int})\rbrakk \,\Longrightarrow\, i * n + j * m \le i * m + j * n$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $i = 0$ \\
+\hbox{}\qquad\qquad $j = 1$ \\
+\hbox{}\qquad\qquad $m = 1$ \\
+\hbox{}\qquad\qquad $n = 0$
+\postw
+
+With infinite types, we don't always have the luxury of a genuine counterexample
+and must often content ourselves with a potential one. The tedious task of
+finding out whether the potential counterexample is in fact genuine can be
+outsourced to \textit{auto} by passing the option \textit{check\_potential}. For
+example:
+
+\prew
+\textbf{lemma} ``$\forall n.\; \textit{Suc}~n \mathbin{\not=} n \,\Longrightarrow\, P$'' \\
+\textbf{nitpick} [\textit{card~nat}~= 100,\, \textit{check\_potential}] \\[2\smallskipamount]
+\slshape Nitpick found a potential counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \textit{False}$ \\[2\smallskipamount]
+Confirmation by ``\textit{auto}'': The above counterexample is genuine.
+\postw
+
+You might wonder why the counterexample is first reported as potential. The root
+of the problem is that the bound variable in $\forall n.\; \textit{Suc}~n
+\mathbin{\not=} n$ ranges over an infinite type. If Nitpick finds an $n$ such
+that $\textit{Suc}~n \mathbin{=} n$, it evaluates the assumption to
+\textit{False}; but otherwise, it does not know anything about values of $n \ge
+\textit{card~nat}$ and must therefore evaluate the assumption to $\unk$, not
+\textit{True}. Since the assumption can never be satisfied, the putative lemma
+can never be falsified.
+
+Incidentally, if you distrust the so-called genuine counterexamples, you can
+enable \textit{check\_\allowbreak genuine} to verify them as well. However, be
+aware that \textit{auto} will often fail to prove that the counterexample is
+genuine or spurious.
+
+Some conjectures involving elementary number theory make Nitpick look like a
+giant with feet of clay:
+
+\prew
+\textbf{lemma} ``$P~\textit{Suc}$'' \\
+\textbf{nitpick} [\textit{card} = 1--6] \\[2\smallskipamount]
+\slshape
+Nitpick found no counterexample.
+\postw
+
+For any cardinality $k$, \textit{Suc} is the partial function $\{0 \mapsto 1,\,
+1 \mapsto 2,\, \ldots,\, k - 1 \mapsto \unk\}$, which evaluates to $\unk$ when
+it is passed as argument to $P$. As a result, $P~\textit{Suc}$ is always $\unk$.
+The next example is similar:
+
+\prew
+\textbf{lemma} ``$P~(\textit{op}~{+}\Colon
+\textit{nat}\mathbin{\Rightarrow}\textit{nat}\mathbin{\Rightarrow}\textit{nat})$'' \\
+\textbf{nitpick} [\textit{card nat} = 1] \\[2\smallskipamount]
+{\slshape Nitpick found a counterexample:} \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \{\}$ \\[2\smallskipamount]
+\textbf{nitpick} [\textit{card nat} = 2] \\[2\smallskipamount]
+{\slshape Nitpick found no counterexample.}
+\postw
+
+The problem here is that \textit{op}~+ is total when \textit{nat} is taken to be
+$\{0\}$ but becomes partial as soon as we add $1$, because $1 + 1 \notin \{0,
+1\}$.
+
+Because numbers are infinite and are approximated using a three-valued logic,
+there is usually no need to systematically enumerate domain sizes. If Nitpick
+cannot find a genuine counterexample for \textit{card~nat}~= $k$, it is very
+unlikely that one could be found for smaller domains. (The $P~(\textit{op}~{+})$
+example above is an exception to this principle.) Nitpick nonetheless enumerates
+all cardinalities from 1 to 8 for \textit{nat}, mainly because smaller
+cardinalities are fast to handle and give rise to simpler counterexamples. This
+is explained in more detail in \S\ref{scope-monotonicity}.
+
+\subsection{Inductive Datatypes}
+\label{inductive-datatypes}
+
+Like natural numbers and integers, inductive datatypes with recursive
+constructors admit no finite models and must be approximated by a subterm-closed
+subset. For example, using a cardinality of 10 for ${'}a~\textit{list}$,
+Nitpick looks for all counterexamples that can be built using at most 10
+different lists.
+
+Let's see with an example involving \textit{hd} (which returns the first element
+of a list) and $@$ (which concatenates two lists):
+
+\prew
+\textbf{lemma} ``$\textit{hd}~(\textit{xs} \mathbin{@} [y, y]) = \textit{hd}~\textit{xs}$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{xs} = []$ \\
+\hbox{}\qquad\qquad $\textit{y} = a_3$
+\postw
+
+To see why the counterexample is genuine, we enable \textit{show\_consts}
+and \textit{show\_\allowbreak datatypes}:
+
+\prew
+{\slshape Datatype:} \\
+\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_3, a_3],\, [a_3],\, \unr\}$ \\
+{\slshape Constants:} \\
+\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_3, a_3],\> [a_3, a_3] := \unk,\> [a_3] := \unk)$ \\
+\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_3, a_3] := a_3,\> [a_3] := a_3)$
+\postw
+
+Since $\mathit{hd}~[]$ is undefined in the logic, it may be given any value,
+including $a_2$.
+
+The second constant, $\lambda x_1.\; x_1 \mathbin{@} [y, y]$, is simply the
+append operator whose second argument is fixed to be $[y, y]$. Appending $[a_3,
+a_3]$ to $[a_3]$ would normally give $[a_3, a_3, a_3]$, but this value is not
+representable in the subset of $'a$~\textit{list} considered by Nitpick, which
+is shown under the ``Datatype'' heading; hence the result is $\unk$. Similarly,
+appending $[a_3, a_3]$ to itself gives $\unk$.
+
+Given \textit{card}~$'a = 3$ and \textit{card}~$'a~\textit{list} = 3$, Nitpick
+considers the following subsets:
+
+\kern-.5\smallskipamount %% TYPESETTING
+
+\prew
+\begin{multicols}{3}
+$\{[],\, [a_1],\, [a_2]\}$; \\
+$\{[],\, [a_1],\, [a_3]\}$; \\
+$\{[],\, [a_2],\, [a_3]\}$; \\
+$\{[],\, [a_1],\, [a_1, a_1]\}$; \\
+$\{[],\, [a_1],\, [a_2, a_1]\}$; \\
+$\{[],\, [a_1],\, [a_3, a_1]\}$; \\
+$\{[],\, [a_2],\, [a_1, a_2]\}$; \\
+$\{[],\, [a_2],\, [a_2, a_2]\}$; \\
+$\{[],\, [a_2],\, [a_3, a_2]\}$; \\
+$\{[],\, [a_3],\, [a_1, a_3]\}$; \\
+$\{[],\, [a_3],\, [a_2, a_3]\}$; \\
+$\{[],\, [a_3],\, [a_3, a_3]\}$.
+\end{multicols}
+\postw
+
+\kern-2\smallskipamount %% TYPESETTING
+
+All subterm-closed subsets of $'a~\textit{list}$ consisting of three values
+are listed and only those. As an example of a non-subterm-closed subset,
+consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_3]\}$, and observe
+that $[a_1, a_3]$ (i.e., $a_1 \mathbin{\#} [a_3]$) has $[a_3] \notin
+\mathcal{S}$ as a subterm.
+
+Here's another m\"ochtegern-lemma that Nitpick can refute without a blink:
+
+\prew
+\textbf{lemma} ``$\lbrakk \textit{length}~\textit{xs} = 1;\> \textit{length}~\textit{ys} = 1
+\rbrakk \,\Longrightarrow\, \textit{xs} = \textit{ys}$''
+\\
+\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{xs} = [a_2]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [a_3]$ \\
+\hbox{}\qquad Datatypes: \\
+\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
+\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_3],\, [a_2],\, \unr\}$
+\postw
+
+Because datatypes are approximated using a three-valued logic, there is usually
+no need to systematically enumerate cardinalities: If Nitpick cannot find a
+genuine counterexample for \textit{card}~$'a~\textit{list}$~= 10, it is very
+unlikely that one could be found for smaller cardinalities.
+
+\subsection{Typedefs, Records, Rationals, and Reals}
+\label{typedefs-records-rationals-and-reals}
+
+Nitpick generally treats types declared using \textbf{typedef} as datatypes
+whose single constructor is the corresponding \textit{Abs\_\kern.1ex} function.
+For example:
+
+\prew
+\textbf{typedef}~\textit{three} = ``$\{0\Colon\textit{nat},\, 1,\, 2\}$'' \\
+\textbf{by}~\textit{blast} \\[2\smallskipamount]
+\textbf{definition}~$A \mathbin{\Colon} \textit{three}$ \textbf{where} ``\kern-.1em$A \,\equiv\, \textit{Abs\_\allowbreak three}~0$'' \\
+\textbf{definition}~$B \mathbin{\Colon} \textit{three}$ \textbf{where} ``$B \,\equiv\, \textit{Abs\_three}~1$'' \\
+\textbf{definition}~$C \mathbin{\Colon} \textit{three}$ \textbf{where} ``$C \,\equiv\, \textit{Abs\_three}~2$'' \\[2\smallskipamount]
+\textbf{lemma} ``$\lbrakk P~A;\> P~B\rbrakk \,\Longrightarrow\, P~x$'' \\
+\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $P = \{\Abs{1},\, \Abs{0}\}$ \\
+\hbox{}\qquad\qquad $x = \Abs{2}$ \\
+\hbox{}\qquad Datatypes: \\
+\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{three} = \{\Abs{2},\, \Abs{1},\, \Abs{0},\, \unr\}$
+\postw
+
+%% MARK
+In the output above, $\Abs{n}$ abbreviates $\textit{Abs\_three}~n$.
+
+%% MARK
+Records, which are implemented as \textbf{typedef}s behind the scenes, are
+handled in much the same way:
+
+\prew
+\textbf{record} \textit{point} = \\
+\hbox{}\quad $\textit{Xcoord} \mathbin{\Colon} \textit{int}$ \\
+\hbox{}\quad $\textit{Ycoord} \mathbin{\Colon} \textit{int}$ \\[2\smallskipamount]
+\textbf{lemma} ``$\textit{Xcoord}~(p\Colon\textit{point}) = \textit{Xcoord}~(q\Colon\textit{point})$'' \\
+\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $p = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr$ \\
+\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
+\hbox{}\qquad Datatypes: \\
+\hbox{}\qquad\qquad $\textit{int} = \{0,\, 1,\, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{point} = \{\lparr\textit{Xcoord} = 1,\>
+\textit{Ycoord} = 1\rparr,\> \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr,\, \unr\}$\kern-1pt %% QUIET
+\postw
+
+Finally, Nitpick provides rudimentary support for rationals and reals using a
+similar approach:
+
+\prew
+\textbf{lemma} ``$4 * x + 3 * (y\Colon\textit{real}) \not= 1/2$'' \\
+\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $x = 1/2$ \\
+\hbox{}\qquad\qquad $y = -1/2$ \\
+\hbox{}\qquad Datatypes: \\
+\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, 3,\, 4,\, 5,\, 6,\, 7,\, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{int} = \{0,\, 1,\, 2,\, 3,\, 4,\, -3,\, -2,\, -1,\, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{real} = \{1,\, 0,\, 4,\, -3/2,\, 3,\, 2,\, 1/2,\, -1/2,\, \unr\}$
+\postw
+
+\subsection{Inductive and Coinductive Predicates}
+\label{inductive-and-coinductive-predicates}
+
+Inductively defined predicates (and sets) are particularly problematic for
+counterexample generators. They can make Quickcheck~\cite{berghofer-nipkow-2004}
+loop forever and Refute~\cite{weber-2008} run out of resources. The crux of
+the problem is that they are defined using a least fixed point construction.
+
+Nitpick's philosophy is that not all inductive predicates are equal. Consider
+the \textit{even} predicate below:
+
+\prew
+\textbf{inductive}~\textit{even}~\textbf{where} \\
+``\textit{even}~0'' $\,\mid$ \\
+``\textit{even}~$n\,\Longrightarrow\, \textit{even}~(\textit{Suc}~(\textit{Suc}~n))$''
+\postw
+
+This predicate enjoys the desirable property of being well-founded, which means
+that the introduction rules don't give rise to infinite chains of the form
+
+\prew
+$\cdots\,\Longrightarrow\, \textit{even}~k''
+ \,\Longrightarrow\, \textit{even}~k'
+ \,\Longrightarrow\, \textit{even}~k.$
+\postw
+
+For \textit{even}, this is obvious: Any chain ending at $k$ will be of length
+$k/2 + 1$:
+
+\prew
+$\textit{even}~0\,\Longrightarrow\, \textit{even}~2\,\Longrightarrow\, \cdots
+ \,\Longrightarrow\, \textit{even}~(k - 2)
+ \,\Longrightarrow\, \textit{even}~k.$
+\postw
+
+Wellfoundedness is desirable because it enables Nitpick to use a very efficient
+fixed point computation.%
+\footnote{If an inductive predicate is
+well-founded, then it has exactly one fixed point, which is simultaneously the
+least and the greatest fixed point. In these circumstances, the computation of
+the least fixed point amounts to the computation of an arbitrary fixed point,
+which can be performed using a straightforward recursive equation.}
+Moreover, Nitpick can prove wellfoundedness of most well-founded predicates,
+just as Isabelle's \textbf{function} package usually discharges termination
+proof obligations automatically.
+
+Let's try an example:
+
+\prew
+\textbf{lemma} ``$\exists n.\; \textit{even}~n \mathrel{\land} \textit{even}~(\textit{Suc}~n)$'' \\
+\textbf{nitpick}~[\textit{card nat}~= 100,\, \textit{verbose}] \\[2\smallskipamount]
+\slshape The inductive predicate ``\textit{even}'' was proved well-founded.
+Nitpick can compute it efficiently. \\[2\smallskipamount]
+Trying 1 scope: \\
+\hbox{}\qquad \textit{card nat}~= 100. \\[2\smallskipamount]
+Nitpick found a potential counterexample for \textit{card nat}~= 100: \\[2\smallskipamount]
+\hbox{}\qquad Empty assignment \\[2\smallskipamount]
+Nitpick could not find a better counterexample. \\[2\smallskipamount]
+Total time: 2274 ms.
+\postw
+
+No genuine counterexample is possible because Nitpick cannot rule out the
+existence of a natural number $n \ge 100$ such that both $\textit{even}~n$ and
+$\textit{even}~(\textit{Suc}~n)$ are true. To help Nitpick, we can bound the
+existential quantifier:
+
+\prew
+\textbf{lemma} ``$\exists n \mathbin{\le} 99.\; \textit{even}~n \mathrel{\land} \textit{even}~(\textit{Suc}~n)$'' \\
+\textbf{nitpick}~[\textit{card nat}~= 100] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Empty assignment
+\postw
+
+So far we were blessed by the wellfoundedness of \textit{even}. What happens if
+we use the following definition instead?
+
+\prew
+\textbf{inductive} $\textit{even}'$ \textbf{where} \\
+``$\textit{even}'~(0{\Colon}\textit{nat})$'' $\,\mid$ \\
+``$\textit{even}'~2$'' $\,\mid$ \\
+``$\lbrakk\textit{even}'~m;\> \textit{even}'~n\rbrakk \,\Longrightarrow\, \textit{even}'~(m + n)$''
+\postw
+
+This definition is not well-founded: From $\textit{even}'~0$ and
+$\textit{even}'~0$, we can derive that $\textit{even}'~0$. Nonetheless, the
+predicates $\textit{even}$ and $\textit{even}'$ are equivalent.
+
+Let's check a property involving $\textit{even}'$. To make up for the
+foreseeable computational hurdles entailed by non-wellfoundedness, we decrease
+\textit{nat}'s cardinality to a mere 10:
+
+\prew
+\textbf{lemma}~``$\exists n \in \{0, 2, 4, 6, 8\}.\;
+\lnot\;\textit{even}'~n$'' \\
+\textbf{nitpick}~[\textit{card nat}~= 10,\, \textit{verbose},\, \textit{show\_consts}] \\[2\smallskipamount]
+\slshape
+The inductive predicate ``$\textit{even}'\!$'' could not be proved well-founded.
+Nitpick might need to unroll it. \\[2\smallskipamount]
+Trying 6 scopes: \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 0; \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 1; \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 2; \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 4; \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 8; \\
+\hbox{}\qquad \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 9. \\[2\smallskipamount]
+Nitpick found a counterexample for \textit{card nat}~= 10 and \textit{iter} $\textit{even}'$~= 2: \\[2\smallskipamount]
+\hbox{}\qquad Constant: \nopagebreak \\
+\hbox{}\qquad\qquad $\lambda i.\; \textit{even}'$ = $\undef(\!\begin{aligned}[t]
+& 2 := \{0, 2, 4, 6, 8, 1^\Q, 3^\Q, 5^\Q, 7^\Q, 9^\Q\}, \\[-2pt]
+& 1 := \{0, 2, 4, 1^\Q, 3^\Q, 5^\Q, 6^\Q, 7^\Q, 8^\Q, 9^\Q\}, \\[-2pt]
+& 0 := \{0, 2, 1^\Q, 3^\Q, 4^\Q, 5^\Q, 6^\Q, 7^\Q, 8^\Q, 9^\Q\})\end{aligned}$ \\[2\smallskipamount]
+Total time: 1140 ms.
+\postw
+
+Nitpick's output is very instructive. First, it tells us that the predicate is
+unrolled, meaning that it is computed iteratively from the empty set. Then it
+lists six scopes specifying different bounds on the numbers of iterations:\ 0,
+1, 2, 4, 8, and~9.
+
+The output also shows how each iteration contributes to $\textit{even}'$. The
+notation $\lambda i.\; \textit{even}'$ indicates that the value of the
+predicate depends on an iteration counter. Iteration 0 provides the basis
+elements, $0$ and $2$. Iteration 1 contributes $4$ ($= 2 + 2$). Iteration 2
+throws $6$ ($= 2 + 4 = 4 + 2$) and $8$ ($= 4 + 4$) into the mix. Further
+iterations would not contribute any new elements.
+
+Some values are marked with superscripted question
+marks~(`\lower.2ex\hbox{$^\Q$}'). These are the elements for which the
+predicate evaluates to $\unk$. Thus, $\textit{even}'$ evaluates to either
+\textit{True} or $\unk$, never \textit{False}.
+
+When unrolling a predicate, Nitpick tries 0, 1, 2, 4, 8, 12, 16, and 24
+iterations. However, these numbers are bounded by the cardinality of the
+predicate's domain. With \textit{card~nat}~= 10, no more than 9 iterations are
+ever needed to compute the value of a \textit{nat} predicate. You can specify
+the number of iterations using the \textit{iter} option, as explained in
+\S\ref{scope-of-search}.
+
+In the next formula, $\textit{even}'$ occurs both positively and negatively:
+
+\prew
+\textbf{lemma} ``$\textit{even}'~(n - 2) \,\Longrightarrow\, \textit{even}'~n$'' \\
+\textbf{nitpick} [\textit{card nat} = 10,\, \textit{show\_consts}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $n = 1$ \\
+\hbox{}\qquad Constants: \nopagebreak \\
+\hbox{}\qquad\qquad $\lambda i.\; \textit{even}'$ = $\undef(\!\begin{aligned}[t]
+& 0 := \{0, 2, 1^\Q, 3^\Q, 4^\Q, 5^\Q, 6^\Q, 7^\Q, 8^\Q, 9^\Q\})\end{aligned}$ \\
+\hbox{}\qquad\qquad $\textit{even}' \subseteq \{0, 2, 4, 6, 8, \unr\}$
+\postw
+
+Notice the special constraint $\textit{even}' \subseteq \{0,\, 2,\, 4,\, 6,\,
+8,\, \unr\}$ in the output, whose right-hand side represents an arbitrary
+fixed point (not necessarily the least one). It is used to falsify
+$\textit{even}'~n$. In contrast, the unrolled predicate is used to satisfy
+$\textit{even}'~(n - 2)$.
+
+Coinductive predicates are handled dually. For example:
+
+\prew
+\textbf{coinductive} \textit{nats} \textbf{where} \\
+``$\textit{nats}~(x\Colon\textit{nat}) \,\Longrightarrow\, \textit{nats}~x$'' \\[2\smallskipamount]
+\textbf{lemma} ``$\textit{nats} = \{0, 1, 2, 3, 4\}$'' \\
+\textbf{nitpick}~[\textit{card nat} = 10,\, \textit{show\_consts}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample:
+\\[2\smallskipamount]
+\hbox{}\qquad Constants: \nopagebreak \\
+\hbox{}\qquad\qquad $\lambda i.\; \textit{nats} = \undef(0 := \{\!\begin{aligned}[t]
+& 0^\Q, 1^\Q, 2^\Q, 3^\Q, 4^\Q, 5^\Q, 6^\Q, 7^\Q, 8^\Q, 9^\Q, \\[-2pt]
+& \unr\})\end{aligned}$ \\
+\hbox{}\qquad\qquad $nats \supseteq \{9, 5^\Q, 6^\Q, 7^\Q, 8^\Q, \unr\}$
+\postw
+
+As a special case, Nitpick uses Kodkod's transitive closure operator to encode
+negative occurrences of non-well-founded ``linear inductive predicates,'' i.e.,
+inductive predicates for which each the predicate occurs in at most one
+assumption of each introduction rule. For example:
+
+\prew
+\textbf{inductive} \textit{odd} \textbf{where} \\
+``$\textit{odd}~1$'' $\,\mid$ \\
+``$\lbrakk \textit{odd}~m;\>\, \textit{even}~n\rbrakk \,\Longrightarrow\, \textit{odd}~(m + n)$'' \\[2\smallskipamount]
+\textbf{lemma}~``$\textit{odd}~n \,\Longrightarrow\, \textit{odd}~(n - 2)$'' \\
+\textbf{nitpick}~[\textit{card nat} = 10,\, \textit{show\_consts}] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample:
+\\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $n = 1$ \\
+\hbox{}\qquad Constants: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{even} = \{0, 2, 4, 6, 8, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{odd}_{\textsl{base}} = \{1, \unr\}$ \\
+\hbox{}\qquad\qquad $\textit{odd}_{\textsl{step}} = \!
+\!\begin{aligned}[t]
+ & \{(0, 0), (0, 2), (0, 4), (0, 6), (0, 8), (1, 1), (1, 3), (1, 5), \\[-2pt]
+ & \phantom{\{} (1, 7), (1, 9), (2, 2), (2, 4), (2, 6), (2, 8), (3, 3),
+ (3, 5), \\[-2pt]
+ & \phantom{\{} (3, 7), (3, 9), (4, 4), (4, 6), (4, 8), (5, 5), (5, 7), (5, 9), \\[-2pt]
+ & \phantom{\{} (6, 6), (6, 8), (7, 7), (7, 9), (8, 8), (9, 9), \unr\}\end{aligned}$ \\
+\hbox{}\qquad\qquad $\textit{odd} \subseteq \{1, 3, 5, 7, 9, 8^\Q, \unr\}$
+\postw
+
+\noindent
+In the output, $\textit{odd}_{\textrm{base}}$ represents the base elements and
+$\textit{odd}_{\textrm{step}}$ is a transition relation that computes new
+elements from known ones. The set $\textit{odd}$ consists of all the values
+reachable through the reflexive transitive closure of
+$\textit{odd}_{\textrm{step}}$ starting with any element from
+$\textit{odd}_{\textrm{base}}$, namely 1, 3, 5, 7, and 9. Using Kodkod's
+transitive closure to encode linear predicates is normally either more thorough
+or more efficient than unrolling (depending on the value of \textit{iter}), but
+for those cases where it isn't you can disable it by passing the
+\textit{dont\_star\_linear\_preds} option.
+
+\subsection{Coinductive Datatypes}
+\label{coinductive-datatypes}
+
+While Isabelle regrettably lacks a high-level mechanism for defining coinductive
+datatypes, the \textit{Coinductive\_List} theory provides a coinductive ``lazy
+list'' datatype, $'a~\textit{llist}$, defined the hard way. Nitpick supports
+these lazy lists seamlessly and provides a hook, described in
+\S\ref{registration-of-coinductive-datatypes}, to register custom coinductive
+datatypes.
+
+(Co)intuitively, a coinductive datatype is similar to an inductive datatype but
+allows infinite objects. Thus, the infinite lists $\textit{ps}$ $=$ $[a, a, a,
+\ldots]$, $\textit{qs}$ $=$ $[a, b, a, b, \ldots]$, and $\textit{rs}$ $=$ $[0,
+1, 2, 3, \ldots]$ can be defined as lazy lists using the
+$\textit{LNil}\mathbin{\Colon}{'}a~\textit{llist}$ and
+$\textit{LCons}\mathbin{\Colon}{'}a \mathbin{\Rightarrow} {'}a~\textit{llist}
+\mathbin{\Rightarrow} {'}a~\textit{llist}$ constructors.
+
+Although it is otherwise no friend of infinity, Nitpick can find counterexamples
+involving cyclic lists such as \textit{ps} and \textit{qs} above as well as
+finite lists:
+
+\prew
+\textbf{lemma} ``$\textit{xs} \not= \textit{LCons}~a~\textit{xs}$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample for {\itshape card}~$'a$ = 1: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{a} = a_1$ \\
+\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$
+\postw
+
+The notation $\textrm{THE}~\omega.\; \omega = t(\omega)$ stands
+for the infinite term $t(t(t(\ldots)))$. Hence, \textit{xs} is simply the
+infinite list $[a_1, a_1, a_1, \ldots]$.
+
+The next example is more interesting:
+
+\prew
+\textbf{lemma}~``$\lbrakk\textit{xs} = \textit{LCons}~a~\textit{xs};\>\,
+\textit{ys} = \textit{iterates}~(\lambda b.\> a)~b\rbrakk \,\Longrightarrow\, \textit{xs} = \textit{ys}$'' \\
+\textbf{nitpick} [\textit{verbose}] \\[2\smallskipamount]
+\slshape The type ``\kern1pt$'a$'' passed the monotonicity test. Nitpick might be able to skip
+some scopes. \\[2\smallskipamount]
+Trying 8 scopes: \\
+\hbox{}\qquad \textit{card} $'a$~= 1, \textit{card} ``\kern1pt$'a~\textit{list}$''~= 1,
+and \textit{bisim\_depth}~= 0. \\
+\hbox{}\qquad $\qquad\vdots$ \\[.5\smallskipamount]
+\hbox{}\qquad \textit{card} $'a$~= 8, \textit{card} ``\kern1pt$'a~\textit{list}$''~= 8,
+and \textit{bisim\_depth}~= 7. \\[2\smallskipamount]
+Nitpick found a counterexample for {\itshape card}~$'a$ = 2,
+\textit{card}~``\kern1pt$'a~\textit{list}$''~= 2, and \textit{bisim\_\allowbreak
+depth}~= 1:
+\\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{a} = a_2$ \\
+\hbox{}\qquad\qquad $\textit{b} = a_1$ \\
+\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_1~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega)$ \\[2\smallskipamount]
+Total time: 726 ms.
+\postw
+
+The lazy list $\textit{xs}$ is simply $[a_2, a_2, a_2, \ldots]$, whereas
+$\textit{ys}$ is $[a_1, a_2, a_2, a_2, \ldots]$, i.e., a lasso-shaped list with
+$[a_1]$ as its stem and $[a_2]$ as its cycle. In general, the list segment
+within the scope of the {THE} binder corresponds to the lasso's cycle, whereas
+the segment leading to the binder is the stem.
+
+A salient property of coinductive datatypes is that two objects are considered
+equal if and only if they lead to the same observations. For example, the lazy
+lists $\textrm{THE}~\omega.\; \omega =
+\textit{LCons}~a~(\textit{LCons}~b~\omega)$ and
+$\textit{LCons}~a~(\textrm{THE}~\omega.\; \omega =
+\textit{LCons}~b~(\textit{LCons}~a~\omega))$ are identical, because both lead
+to the sequence of observations $a$, $b$, $a$, $b$, \hbox{\ldots} (or,
+equivalently, both encode the infinite list $[a, b, a, b, \ldots]$). This
+concept of equality for coinductive datatypes is called bisimulation and is
+defined coinductively.
+
+Internally, Nitpick encodes the coinductive bisimilarity predicate as part of
+the Kodkod problem to ensure that distinct objects lead to different
+observations. This precaution is somewhat expensive and often unnecessary, so it
+can be disabled by setting the \textit{bisim\_depth} option to $-1$. The
+bisimilarity check is then performed \textsl{after} the counterexample has been
+found to ensure correctness. If this after-the-fact check fails, the
+counterexample is tagged as ``likely genuine'' and Nitpick recommends to try
+again with \textit{bisim\_depth} set to a nonnegative integer. Disabling the
+check for the previous example saves approximately 150~milli\-seconds; the speed
+gains can be more significant for larger scopes.
+
+The next formula illustrates the need for bisimilarity (either as a Kodkod
+predicate or as an after-the-fact check) to prevent spurious counterexamples:
+
+\prew
+\textbf{lemma} ``$\lbrakk xs = \textit{LCons}~a~\textit{xs};\>\, \textit{ys} = \textit{LCons}~a~\textit{ys}\rbrakk
+\,\Longrightarrow\, \textit{xs} = \textit{ys}$'' \\
+\textbf{nitpick} [\textit{bisim\_depth} = $-1$,\, \textit{show\_datatypes}] \\[2\smallskipamount]
+\slshape Nitpick found a likely genuine counterexample for $\textit{card}~'a$ = 2: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $a = a_2$ \\
+\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega =
+\textit{LCons}~a_2~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
+\hbox{}\qquad Codatatype:\strut \nopagebreak \\
+\hbox{}\qquad\qquad $'a~\textit{llist} =
+\{\!\begin{aligned}[t]
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega, \\[-2pt]
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega,\> \unr\}\end{aligned}$
+\\[2\smallskipamount]
+Try again with ``\textit{bisim\_depth}'' set to a nonnegative value to confirm
+that the counterexample is genuine. \\[2\smallskipamount]
+{\upshape\textbf{nitpick}} \\[2\smallskipamount]
+\slshape Nitpick found no counterexample.
+\postw
+
+In the first \textbf{nitpick} invocation, the after-the-fact check discovered
+that the two known elements of type $'a~\textit{llist}$ are bisimilar.
+
+A compromise between leaving out the bisimilarity predicate from the Kodkod
+problem and performing the after-the-fact check is to specify a lower
+nonnegative \textit{bisim\_depth} value than the default one provided by
+Nitpick. In general, a value of $K$ means that Nitpick will require all lists to
+be distinguished from each other by their prefixes of length $K$. Be aware that
+setting $K$ to a too low value can overconstrain Nitpick, preventing it from
+finding any counterexamples.
+
+\subsection{Boxing}
+\label{boxing}
+
+Nitpick normally maps function and product types directly to the corresponding
+Kodkod concepts. As a consequence, if $'a$ has cardinality 3 and $'b$ has
+cardinality 4, then $'a \times {'}b$ has cardinality 12 ($= 4 \times 3$) and $'a
+\Rightarrow {'}b$ has cardinality 64 ($= 4^3$). In some circumstances, it pays
+off to treat these types in the same way as plain datatypes, by approximating
+them by a subset of a given cardinality. This technique is called ``boxing'' and
+is particularly useful for functions passed as arguments to other functions, for
+high-arity functions, and for large tuples. Under the hood, boxing involves
+wrapping occurrences of the types $'a \times {'}b$ and $'a \Rightarrow {'}b$ in
+isomorphic datatypes, as can be seen by enabling the \textit{debug} option.
+
+To illustrate boxing, we consider a formalization of $\lambda$-terms represented
+using de Bruijn's notation:
+
+\prew
+\textbf{datatype} \textit{tm} = \textit{Var}~\textit{nat}~$\mid$~\textit{Lam}~\textit{tm} $\mid$ \textit{App~tm~tm}
+\postw
+
+The $\textit{lift}~t~k$ function increments all variables with indices greater
+than or equal to $k$ by one:
+
+\prew
+\textbf{primrec} \textit{lift} \textbf{where} \\
+``$\textit{lift}~(\textit{Var}~j)~k = \textit{Var}~(\textrm{if}~j < k~\textrm{then}~j~\textrm{else}~j + 1)$'' $\mid$ \\
+``$\textit{lift}~(\textit{Lam}~t)~k = \textit{Lam}~(\textit{lift}~t~(k + 1))$'' $\mid$ \\
+``$\textit{lift}~(\textit{App}~t~u)~k = \textit{App}~(\textit{lift}~t~k)~(\textit{lift}~u~k)$''
+\postw
+
+The $\textit{loose}~t~k$ predicate returns \textit{True} if and only if
+term $t$ has a loose variable with index $k$ or more:
+
+\prew
+\textbf{primrec}~\textit{loose} \textbf{where} \\
+``$\textit{loose}~(\textit{Var}~j)~k = (j \ge k)$'' $\mid$ \\
+``$\textit{loose}~(\textit{Lam}~t)~k = \textit{loose}~t~(\textit{Suc}~k)$'' $\mid$ \\
+``$\textit{loose}~(\textit{App}~t~u)~k = (\textit{loose}~t~k \mathrel{\lor} \textit{loose}~u~k)$''
+\postw
+
+Next, the $\textit{subst}~\sigma~t$ function applies the substitution $\sigma$
+on $t$:
+
+\prew
+\textbf{primrec}~\textit{subst} \textbf{where} \\
+``$\textit{subst}~\sigma~(\textit{Var}~j) = \sigma~j$'' $\mid$ \\
+``$\textit{subst}~\sigma~(\textit{Lam}~t) = {}$\phantom{''} \\
+\phantom{``}$\textit{Lam}~(\textit{subst}~(\lambda n.\> \textrm{case}~n~\textrm{of}~0 \Rightarrow \textit{Var}~0 \mid \textit{Suc}~m \Rightarrow \textit{lift}~(\sigma~m)~1)~t)$'' $\mid$ \\
+``$\textit{subst}~\sigma~(\textit{App}~t~u) = \textit{App}~(\textit{subst}~\sigma~t)~(\textit{subst}~\sigma~u)$''
+\postw
+
+A substitution is a function that maps variable indices to terms. Observe that
+$\sigma$ is a function passed as argument and that Nitpick can't optimize it
+away, because the recursive call for the \textit{Lam} case involves an altered
+version. Also notice the \textit{lift} call, which increments the variable
+indices when moving under a \textit{Lam}.
+
+A reasonable property to expect of substitution is that it should leave closed
+terms unchanged. Alas, even this simple property does not hold:
+
+\pre
+\textbf{lemma}~``$\lnot\,\textit{loose}~t~0 \,\Longrightarrow\, \textit{subst}~\sigma~t = t$'' \\
+\textbf{nitpick} [\textit{verbose}] \\[2\smallskipamount]
+\slshape
+Trying 8 scopes: \nopagebreak \\
+\hbox{}\qquad \textit{card~nat}~= 1, \textit{card tm}~= 1, and \textit{card} ``$\textit{nat} \Rightarrow \textit{tm}$'' = 1; \\
+\hbox{}\qquad \textit{card~nat}~= 2, \textit{card tm}~= 2, and \textit{card} ``$\textit{nat} \Rightarrow \textit{tm}$'' = 2; \\
+\hbox{}\qquad $\qquad\vdots$ \\[.5\smallskipamount]
+\hbox{}\qquad \textit{card~nat}~= 8, \textit{card tm}~= 8, and \textit{card} ``$\textit{nat} \Rightarrow \textit{tm}$'' = 8. \\[2\smallskipamount]
+Nitpick found a counterexample for \textit{card~nat}~= 6, \textit{card~tm}~= 6,
+and \textit{card}~``$\textit{nat} \Rightarrow \textit{tm}$''~= 6: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\sigma = \undef(\!\begin{aligned}[t]
+& 0 := \textit{Var}~0,\>
+ 1 := \textit{Var}~0,\>
+ 2 := \textit{Var}~0, \\[-2pt]
+& 3 := \textit{Var}~0,\>
+ 4 := \textit{Var}~0,\>
+ 5 := \textit{Var}~0)\end{aligned}$ \\
+\hbox{}\qquad\qquad $t = \textit{Lam}~(\textit{Lam}~(\textit{Var}~1))$ \\[2\smallskipamount]
+Total time: $4679$ ms.
+\postw
+
+Using \textit{eval}, we find out that $\textit{subst}~\sigma~t =
+\textit{Lam}~(\textit{Lam}~(\textit{Var}~0))$. Using the traditional
+$\lambda$-term notation, $t$~is
+$\lambda x\, y.\> x$ whereas $\textit{subst}~\sigma~t$ is $\lambda x\, y.\> y$.
+The bug is in \textit{subst}: The $\textit{lift}~(\sigma~m)~1$ call should be
+replaced with $\textit{lift}~(\sigma~m)~0$.
+
+An interesting aspect of Nitpick's verbose output is that it assigned inceasing
+cardinalities from 1 to 8 to the type $\textit{nat} \Rightarrow \textit{tm}$.
+For the formula of interest, knowing 6 values of that type was enough to find
+the counterexample. Without boxing, $46\,656$ ($= 6^6$) values must be
+considered, a hopeless undertaking:
+
+\prew
+\textbf{nitpick} [\textit{dont\_box}] \\[2\smallskipamount]
+{\slshape Nitpick ran out of time after checking 4 of 8 scopes.}
+\postw
+
+{\looseness=-1
+Boxing can be enabled or disabled globally or on a per-type basis using the
+\textit{box} option. Moreover, setting the cardinality of a function or
+product type implicitly enables boxing for that type. Nitpick usually performs
+reasonable choices about which types should be boxed, but option tweaking
+sometimes helps.
+
+}
+
+\subsection{Scope Monotonicity}
+\label{scope-monotonicity}
+
+The \textit{card} option (together with \textit{iter}, \textit{bisim\_depth},
+and \textit{max}) controls which scopes are actually tested. In general, to
+exhaust all models below a certain cardinality bound, the number of scopes that
+Nitpick must consider increases exponentially with the number of type variables
+(and \textbf{typedecl}'d types) occurring in the formula. Given the default
+cardinality specification of 1--8, no fewer than $8^4 = 4096$ scopes must be
+considered for a formula involving $'a$, $'b$, $'c$, and $'d$.
+
+Fortunately, many formulas exhibit a property called \textsl{scope
+monotonicity}, meaning that if the formula is falsifiable for a given scope,
+it is also falsifiable for all larger scopes \cite[p.~165]{jackson-2006}.
+
+Consider the formula
+
+\prew
+\textbf{lemma}~``$\textit{length~xs} = \textit{length~ys} \,\Longrightarrow\, \textit{rev}~(\textit{zip~xs~ys}) = \textit{zip~xs}~(\textit{rev~ys})$''
+\postw
+
+where \textit{xs} is of type $'a~\textit{list}$ and \textit{ys} is of type
+$'b~\textit{list}$. A priori, Nitpick would need to consider 512 scopes to
+exhaust the specification \textit{card}~= 1--8. However, our intuition tells us
+that any counterexample found with a small scope would still be a counterexample
+in a larger scope---by simply ignoring the fresh $'a$ and $'b$ values provided
+by the larger scope. Nitpick comes to the same conclusion after a careful
+inspection of the formula and the relevant definitions:
+
+\prew
+\textbf{nitpick}~[\textit{verbose}] \\[2\smallskipamount]
+\slshape
+The types ``\kern1pt$'a$'' and ``\kern1pt$'b$'' passed the monotonicity test.
+Nitpick might be able to skip some scopes.
+ \\[2\smallskipamount]
+Trying 8 scopes: \\
+\hbox{}\qquad \textit{card} $'a$~= 1, \textit{card} $'b$~= 1,
+\textit{card} \textit{nat}~= 1, \textit{card} ``$('a \times {'}b)$
+\textit{list}''~= 1, \\
+\hbox{}\qquad\quad \textit{card} ``\kern1pt$'a$ \textit{list}''~= 1, and
+\textit{card} ``\kern1pt$'b$ \textit{list}''~= 1. \\
+\hbox{}\qquad \textit{card} $'a$~= 2, \textit{card} $'b$~= 2,
+\textit{card} \textit{nat}~= 2, \textit{card} ``$('a \times {'}b)$
+\textit{list}''~= 2, \\
+\hbox{}\qquad\quad \textit{card} ``\kern1pt$'a$ \textit{list}''~= 2, and
+\textit{card} ``\kern1pt$'b$ \textit{list}''~= 2. \\
+\hbox{}\qquad $\qquad\vdots$ \\[.5\smallskipamount]
+\hbox{}\qquad \textit{card} $'a$~= 8, \textit{card} $'b$~= 8,
+\textit{card} \textit{nat}~= 8, \textit{card} ``$('a \times {'}b)$
+\textit{list}''~= 8, \\
+\hbox{}\qquad\quad \textit{card} ``\kern1pt$'a$ \textit{list}''~= 8, and
+\textit{card} ``\kern1pt$'b$ \textit{list}''~= 8.
+\\[2\smallskipamount]
+Nitpick found a counterexample for
+\textit{card} $'a$~= 5, \textit{card} $'b$~= 5,
+\textit{card} \textit{nat}~= 5, \textit{card} ``$('a \times {'}b)$
+\textit{list}''~= 5, \textit{card} ``\kern1pt$'a$ \textit{list}''~= 5, and
+\textit{card} ``\kern1pt$'b$ \textit{list}''~= 5:
+\\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $\textit{xs} = [a_4, a_5]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [b_3, b_3]$ \\[2\smallskipamount]
+Total time: 1636 ms.
+\postw
+
+In theory, it should be sufficient to test a single scope:
+
+\prew
+\textbf{nitpick}~[\textit{card}~= 8]
+\postw
+
+However, this is often less efficient in practice and may lead to overly complex
+counterexamples.
+
+If the monotonicity check fails but we believe that the formula is monotonic (or
+we don't mind missing some counterexamples), we can pass the
+\textit{mono} option. To convince yourself that this option is risky,
+simply consider this example from \S\ref{skolemization}:
+
+\prew
+\textbf{lemma} ``$\exists g.\; \forall x\Colon 'b.~g~(f~x) = x
+ \,\Longrightarrow\, \forall y\Colon {'}a.\; \exists x.~y = f~x$'' \\
+\textbf{nitpick} [\textit{mono}] \\[2\smallskipamount]
+{\slshape Nitpick found no counterexample.} \\[2\smallskipamount]
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape
+Nitpick found a counterexample for \textit{card} $'a$~= 2 and \textit{card} $'b$~=~1: \\
+\hbox{}\qquad $\vdots$
+\postw
+
+(It turns out the formula holds if and only if $\textit{card}~'a \le
+\textit{card}~'b$.) Although this is rarely advisable, the automatic
+monotonicity checks can be disabled by passing \textit{non\_mono}
+(\S\ref{optimizations}).
+
+As insinuated in \S\ref{natural-numbers-and-integers} and
+\S\ref{inductive-datatypes}, \textit{nat}, \textit{int}, and inductive datatypes
+are normally monotonic and treated as such. The same is true for record types,
+\textit{rat}, \textit{real}, and some \textbf{typedef}'d types. Thus, given the
+cardinality specification 1--8, a formula involving \textit{nat}, \textit{int},
+\textit{int~list}, \textit{rat}, and \textit{rat~list} will lead Nitpick to
+consider only 8~scopes instead of $32\,768$.
+
+\section{Case Studies}
+\label{case-studies}
+
+As a didactic device, the previous section focused mostly on toy formulas whose
+validity can easily be assessed just by looking at the formula. We will now
+review two somewhat more realistic case studies that are within Nitpick's
+reach:\ a context-free grammar modeled by mutually inductive sets and a
+functional implementation of AA trees. The results presented in this
+section were produced with the following settings:
+
+\prew
+\textbf{nitpick\_params} [\textit{max\_potential}~= 0,\, \textit{max\_threads} = 2]
+\postw
+
+\subsection{A Context-Free Grammar}
+\label{a-context-free-grammar}
+
+Our first case study is taken from section 7.4 in the Isabelle tutorial
+\cite{isa-tutorial}. The following grammar, originally due to Hopcroft and
+Ullman, produces all strings with an equal number of $a$'s and $b$'s:
+
+\prew
+\begin{tabular}{@{}r@{$\;\,$}c@{$\;\,$}l@{}}
+$S$ & $::=$ & $\epsilon \mid bA \mid aB$ \\
+$A$ & $::=$ & $aS \mid bAA$ \\
+$B$ & $::=$ & $bS \mid aBB$
+\end{tabular}
+\postw
+
+The intuition behind the grammar is that $A$ generates all string with one more
+$a$ than $b$'s and $B$ generates all strings with one more $b$ than $a$'s.
+
+The alphabet consists exclusively of $a$'s and $b$'s:
+
+\prew
+\textbf{datatype} \textit{alphabet}~= $a$ $\mid$ $b$
+\postw
+
+Strings over the alphabet are represented by \textit{alphabet list}s.
+Nonterminals in the grammar become sets of strings. The production rules
+presented above can be expressed as a mutually inductive definition:
+
+\prew
+\textbf{inductive\_set} $S$ \textbf{and} $A$ \textbf{and} $B$ \textbf{where} \\
+\textit{R1}:\kern.4em ``$[] \in S$'' $\,\mid$ \\
+\textit{R2}:\kern.4em ``$w \in A\,\Longrightarrow\, b \mathbin{\#} w \in S$'' $\,\mid$ \\
+\textit{R3}:\kern.4em ``$w \in B\,\Longrightarrow\, a \mathbin{\#} w \in S$'' $\,\mid$ \\
+\textit{R4}:\kern.4em ``$w \in S\,\Longrightarrow\, a \mathbin{\#} w \in A$'' $\,\mid$ \\
+\textit{R5}:\kern.4em ``$w \in S\,\Longrightarrow\, b \mathbin{\#} w \in S$'' $\,\mid$ \\
+\textit{R6}:\kern.4em ``$\lbrakk v \in B;\> v \in B\rbrakk \,\Longrightarrow\, a \mathbin{\#} v \mathbin{@} w \in B$''
+\postw
+
+The conversion of the grammar into the inductive definition was done manually by
+Joe Blow, an underpaid undergraduate student. As a result, some errors might
+have sneaked in.
+
+Debugging faulty specifications is at the heart of Nitpick's \textsl{raison
+d'\^etre}. A good approach is to state desirable properties of the specification
+(here, that $S$ is exactly the set of strings over $\{a, b\}$ with as many $a$'s
+as $b$'s) and check them with Nitpick. If the properties are correctly stated,
+counterexamples will point to bugs in the specification. For our grammar
+example, we will proceed in two steps, separating the soundness and the
+completeness of the set $S$. First, soundness:
+
+\prew
+\textbf{theorem}~\textit{S\_sound}: \\
+``$w \in S \longrightarrow \textit{length}~[x\mathbin{\leftarrow} w.\; x = a] =
+ \textit{length}~[x\mathbin{\leftarrow} w.\; x = b]$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $w = [b]$
+\postw
+
+It would seem that $[b] \in S$. How could this be? An inspection of the
+introduction rules reveals that the only rule with a right-hand side of the form
+$b \mathbin{\#} {\ldots} \in S$ that could have introduced $[b]$ into $S$ is
+\textit{R5}:
+
+\prew
+``$w \in S\,\Longrightarrow\, b \mathbin{\#} w \in S$''
+\postw
+
+On closer inspection, we can see that this rule is wrong. To match the
+production $B ::= bS$, the second $S$ should be a $B$. We fix the typo and try
+again:
+
+\prew
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $w = [a, a, b]$
+\postw
+
+Some detective work is necessary to find out what went wrong here. To get $[a,
+a, b] \in S$, we need $[a, b] \in B$ by \textit{R3}, which in turn can only come
+from \textit{R6}:
+
+\prew
+``$\lbrakk v \in B;\> v \in B\rbrakk \,\Longrightarrow\, a \mathbin{\#} v \mathbin{@} w \in B$''
+\postw
+
+Now, this formula must be wrong: The same assumption occurs twice, and the
+variable $w$ is unconstrained. Clearly, one of the two occurrences of $v$ in
+the assumptions should have been a $w$.
+
+With the correction made, we don't get any counterexample from Nitpick. Let's
+move on and check completeness:
+
+\prew
+\textbf{theorem}~\textit{S\_complete}: \\
+``$\textit{length}~[x\mathbin{\leftarrow} w.\; x = a] =
+ \textit{length}~[x\mathbin{\leftarrow} w.\; x = b]
+ \longrightarrow w \in S$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variable: \nopagebreak \\
+\hbox{}\qquad\qquad $w = [b, b, a, a]$
+\postw
+
+Apparently, $[b, b, a, a] \notin S$, even though it has the same numbers of
+$a$'s and $b$'s. But since our inductive definition passed the soundness check,
+the introduction rules we have are probably correct. Perhaps we simply lack an
+introduction rule. Comparing the grammar with the inductive definition, our
+suspicion is confirmed: Joe Blow simply forgot the production $A ::= bAA$,
+without which the grammar cannot generate two or more $b$'s in a row. So we add
+the rule
+
+\prew
+``$\lbrakk v \in A;\> w \in A\rbrakk \,\Longrightarrow\, b \mathbin{\#} v \mathbin{@} w \in A$''
+\postw
+
+With this last change, we don't get any counterexamples from Nitpick for either
+soundness or completeness. We can even generalize our result to cover $A$ and
+$B$ as well:
+
+\prew
+\textbf{theorem} \textit{S\_A\_B\_sound\_and\_complete}: \\
+``$w \in S \longleftrightarrow \textit{length}~[x \mathbin{\leftarrow} w.\; x = a] = \textit{length}~[x \mathbin{\leftarrow} w.\; x = b]$'' \\
+``$w \in A \longleftrightarrow \textit{length}~[x \mathbin{\leftarrow} w.\; x = a] = \textit{length}~[x \mathbin{\leftarrow} w.\; x = b] + 1$'' \\
+``$w \in B \longleftrightarrow \textit{length}~[x \mathbin{\leftarrow} w.\; x = b] = \textit{length}~[x \mathbin{\leftarrow} w.\; x = a] + 1$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found no counterexample.
+\postw
+
+\subsection{AA Trees}
+\label{aa-trees}
+
+AA trees are a kind of balanced trees discovered by Arne Andersson that provide
+similar performance to red-black trees, but with a simpler implementation
+\cite{andersson-1993}. They can be used to store sets of elements equipped with
+a total order $<$. We start by defining the datatype and some basic extractor
+functions:
+
+\prew
+\textbf{datatype} $'a$~\textit{tree} = $\Lambda$ $\mid$ $N$ ``\kern1pt$'a\Colon \textit{linorder}$'' \textit{nat} ``\kern1pt$'a$ \textit{tree}'' ``\kern1pt$'a$ \textit{tree}'' \\[2\smallskipamount]
+\textbf{primrec} \textit{data} \textbf{where} \\
+``$\textit{data}~\Lambda = \undef$'' $\,\mid$ \\
+``$\textit{data}~(N~x~\_~\_~\_) = x$'' \\[2\smallskipamount]
+\textbf{primrec} \textit{dataset} \textbf{where} \\
+``$\textit{dataset}~\Lambda = \{\}$'' $\,\mid$ \\
+``$\textit{dataset}~(N~x~\_~t~u) = \{x\} \cup \textit{dataset}~t \mathrel{\cup} \textit{dataset}~u$'' \\[2\smallskipamount]
+\textbf{primrec} \textit{level} \textbf{where} \\
+``$\textit{level}~\Lambda = 0$'' $\,\mid$ \\
+``$\textit{level}~(N~\_~k~\_~\_) = k$'' \\[2\smallskipamount]
+\textbf{primrec} \textit{left} \textbf{where} \\
+``$\textit{left}~\Lambda = \Lambda$'' $\,\mid$ \\
+``$\textit{left}~(N~\_~\_~t~\_) = t$'' \\[2\smallskipamount]
+\textbf{primrec} \textit{right} \textbf{where} \\
+``$\textit{right}~\Lambda = \Lambda$'' $\,\mid$ \\
+``$\textit{right}~(N~\_~\_~\_~u) = u$''
+\postw
+
+The wellformedness criterion for AA trees is fairly complex. Wikipedia states it
+as follows \cite{wikipedia-2009-aa-trees}:
+
+\kern.2\parskip %% TYPESETTING
+
+\pre
+Each node has a level field, and the following invariants must remain true for
+the tree to be valid:
+
+\raggedright
+
+\kern-.4\parskip %% TYPESETTING
+
+\begin{enum}
+\item[]
+\begin{enum}
+\item[1.] The level of a leaf node is one.
+\item[2.] The level of a left child is strictly less than that of its parent.
+\item[3.] The level of a right child is less than or equal to that of its parent.
+\item[4.] The level of a right grandchild is strictly less than that of its grandparent.
+\item[5.] Every node of level greater than one must have two children.
+\end{enum}
+\end{enum}
+\post
+
+\kern.4\parskip %% TYPESETTING
+
+The \textit{wf} predicate formalizes this description:
+
+\prew
+\textbf{primrec} \textit{wf} \textbf{where} \\
+``$\textit{wf}~\Lambda = \textit{True}$'' $\,\mid$ \\
+``$\textit{wf}~(N~\_~k~t~u) =$ \\
+\phantom{``}$(\textrm{if}~t = \Lambda~\textrm{then}$ \\
+\phantom{``$(\quad$}$k = 1 \mathrel{\land} (u = \Lambda \mathrel{\lor} (\textit{level}~u = 1 \mathrel{\land} \textit{left}~u = \Lambda \mathrel{\land} \textit{right}~u = \Lambda))$ \\
+\phantom{``$($}$\textrm{else}$ \\
+\hbox{}\phantom{``$(\quad$}$\textit{wf}~t \mathrel{\land} \textit{wf}~u
+\mathrel{\land} u \not= \Lambda \mathrel{\land} \textit{level}~t < k
+\mathrel{\land} \textit{level}~u \le k$ \\
+\hbox{}\phantom{``$(\quad$}${\land}\; \textit{level}~(\textit{right}~u) < k)$''
+\postw
+
+Rebalancing the tree upon insertion and removal of elements is performed by two
+auxiliary functions called \textit{skew} and \textit{split}, defined below:
+
+\prew
+\textbf{primrec} \textit{skew} \textbf{where} \\
+``$\textit{skew}~\Lambda = \Lambda$'' $\,\mid$ \\
+``$\textit{skew}~(N~x~k~t~u) = {}$ \\
+\phantom{``}$(\textrm{if}~t \not= \Lambda \mathrel{\land} k =
+\textit{level}~t~\textrm{then}$ \\
+\phantom{``(\quad}$N~(\textit{data}~t)~k~(\textit{left}~t)~(N~x~k~
+(\textit{right}~t)~u)$ \\
+\phantom{``(}$\textrm{else}$ \\
+\phantom{``(\quad}$N~x~k~t~u)$''
+\postw
+
+\prew
+\textbf{primrec} \textit{split} \textbf{where} \\
+``$\textit{split}~\Lambda = \Lambda$'' $\,\mid$ \\
+``$\textit{split}~(N~x~k~t~u) = {}$ \\
+\phantom{``}$(\textrm{if}~u \not= \Lambda \mathrel{\land} k =
+\textit{level}~(\textit{right}~u)~\textrm{then}$ \\
+\phantom{``(\quad}$N~(\textit{data}~u)~(\textit{Suc}~k)~
+(N~x~k~t~(\textit{left}~u))~(\textit{right}~u)$ \\
+\phantom{``(}$\textrm{else}$ \\
+\phantom{``(\quad}$N~x~k~t~u)$''
+\postw
+
+Performing a \textit{skew} or a \textit{split} should have no impact on the set
+of elements stored in the tree:
+
+\prew
+\textbf{theorem}~\textit{dataset\_skew\_split}:\\
+``$\textit{dataset}~(\textit{skew}~t) = \textit{dataset}~t$'' \\
+``$\textit{dataset}~(\textit{split}~t) = \textit{dataset}~t$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
+\postw
+
+Furthermore, applying \textit{skew} or \textit{split} to a well-formed tree
+should not alter the tree:
+
+\prew
+\textbf{theorem}~\textit{wf\_skew\_split}:\\
+``$\textit{wf}~t\,\Longrightarrow\, \textit{skew}~t = t$'' \\
+``$\textit{wf}~t\,\Longrightarrow\, \textit{split}~t = t$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+{\slshape Nitpick found no counterexample.}
+\postw
+
+Insertion is implemented recursively. It preserves the sort order:
+
+\prew
+\textbf{primrec}~\textit{insort} \textbf{where} \\
+``$\textit{insort}~\Lambda~x = N~x~1~\Lambda~\Lambda$'' $\,\mid$ \\
+``$\textit{insort}~(N~y~k~t~u)~x =$ \\
+\phantom{``}$({*}~(\textit{split} \circ \textit{skew})~{*})~(N~y~k~(\textrm{if}~x < y~\textrm{then}~\textit{insort}~t~x~\textrm{else}~t)$ \\
+\phantom{``$({*}~(\textit{split} \circ \textit{skew})~{*})~(N~y~k~$}$(\textrm{if}~x > y~\textrm{then}~\textit{insort}~u~x~\textrm{else}~u))$''
+\postw
+
+Notice that we deliberately commented out the application of \textit{skew} and
+\textit{split}. Let's see if this causes any problems:
+
+\prew
+\textbf{theorem}~\textit{wf\_insort}:\kern.4em ``$\textit{wf}~t\,\Longrightarrow\, \textit{wf}~(\textit{insort}~t~x)$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\slshape Nitpick found a counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $t = N~a_3~1~\Lambda~\Lambda$ \\
+\hbox{}\qquad\qquad $x = a_4$ \\[2\smallskipamount]
+Hint: Maybe you forgot a type constraint?
+\postw
+
+It's hard to see why this is a counterexample. The hint is of no help here. To
+improve readability, we will restrict the theorem to \textit{nat}, so that we
+don't need to look up the value of the $\textit{op}~{<}$ constant to find out
+which element is smaller than the other. In addition, we will tell Nitpick to
+display the value of $\textit{insort}~t~x$ using the \textit{eval} option. This
+gives
+
+\prew
+\textbf{theorem} \textit{wf\_insort\_nat}:\kern.4em ``$\textit{wf}~t\,\Longrightarrow\, \textit{wf}~(\textit{insort}~t~(x\Colon\textit{nat}))$'' \\
+\textbf{nitpick} [\textit{eval} = ``$\textit{insort}~t~x$''] \\[2\smallskipamount]
+\slshape Nitpick found a counterexample: \\[2\smallskipamount]
+\hbox{}\qquad Free variables: \nopagebreak \\
+\hbox{}\qquad\qquad $t = N~1~1~\Lambda~\Lambda$ \\
+\hbox{}\qquad\qquad $x = 0$ \\
+\hbox{}\qquad Evaluated term: \\
+\hbox{}\qquad\qquad $\textit{insort}~t~x = N~1~1~(N~0~1~\Lambda~\Lambda)~\Lambda$
+\postw
+
+Nitpick's output reveals that the element $0$ was added as a left child of $1$,
+where both have a level of 1. This violates the second AA tree invariant, which
+states that a left child's level must be less than its parent's. This shouldn't
+come as a surprise, considering that we commented out the tree rebalancing code.
+Reintroducing the code seems to solve the problem:
+
+\prew
+\textbf{theorem}~\textit{wf\_insort}:\kern.4em ``$\textit{wf}~t\,\Longrightarrow\, \textit{wf}~(\textit{insort}~t~x)$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+{\slshape Nitpick ran out of time after checking 6 of 8 scopes.}
+\postw
+
+Insertion should transform the set of elements represented by the tree in the
+obvious way:
+
+\prew
+\textbf{theorem} \textit{dataset\_insort}:\kern.4em
+``$\textit{dataset}~(\textit{insort}~t~x) = \{x\} \cup \textit{dataset}~t$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+{\slshape Nitpick ran out of time after checking 5 of 8 scopes.}
+\postw
+
+We could continue like this and sketch a complete theory of AA trees without
+performing a single proof. Once the definitions and main theorems are in place
+and have been thoroughly tested using Nitpick, we could start working on the
+proofs. Developing theories this way usually saves time, because faulty theorems
+and definitions are discovered much earlier in the process.
+
+\section{Option Reference}
+\label{option-reference}
+
+\def\flushitem#1{\item[]\noindent\kern-\leftmargin \textbf{#1}}
+\def\qty#1{$\left<\textit{#1}\right>$}
+\def\qtybf#1{$\mathbf{\left<\textbf{\textit{#1}}\right>}$}
+\def\optrue#1#2{\flushitem{\textit{#1} $\bigl[$= \qtybf{bool}$\bigr]$\quad [\textit{true}]\hfill (neg.: \textit{#2})}\nopagebreak\\[\parskip]}
+\def\opfalse#1#2{\flushitem{\textit{#1} $\bigl[$= \qtybf{bool}$\bigr]$\quad [\textit{false}]\hfill (neg.: \textit{#2})}\nopagebreak\\[\parskip]}
+\def\opsmart#1#2{\flushitem{\textit{#1} $\bigl[$= \qtybf{bool\_or\_smart}$\bigr]$\quad [\textit{smart}]\hfill (neg.: \textit{#2})}\nopagebreak\\[\parskip]}
+\def\ops#1#2{\flushitem{\textit{#1} = \qtybf{#2}} \nopagebreak\\[\parskip]}
+\def\opt#1#2#3{\flushitem{\textit{#1} = \qtybf{#2}\quad [\textit{#3}]} \nopagebreak\\[\parskip]}
+\def\opu#1#2#3{\flushitem{\textit{#1} \qtybf{#2} = \qtybf{#3}} \nopagebreak\\[\parskip]}
+\def\opusmart#1#2#3{\flushitem{\textit{#1} \qtybf{#2} $\bigl[$= \qtybf{bool\_or\_smart}$\bigr]$\hfill (neg.: \textit{#3})}\nopagebreak\\[\parskip]}
+
+Nitpick's behavior can be influenced by various options, which can be specified
+in brackets after the \textbf{nitpick} command. Default values can be set
+using \textbf{nitpick\_\allowbreak params}. For example:
+
+\prew
+\textbf{nitpick\_params} [\textit{verbose}, \,\textit{timeout} = 60$\,s$]
+\postw
+
+The options are categorized as follows:\ mode of operation
+(\S\ref{mode-of-operation}), scope of search (\S\ref{scope-of-search}), output
+format (\S\ref{output-format}), automatic counterexample checks
+(\S\ref{authentication}), optimizations
+(\S\ref{optimizations}), and timeouts (\S\ref{timeouts}).
+
+The number of options can be overwhelming at first glance. Do not let that worry
+you: Nitpick's defaults have been chosen so that it almost always does the right
+thing, and the most important options have been covered in context in
+\S\ref{first-steps}.
+
+The descriptions below refer to the following syntactic quantities:
+
+\begin{enum}
+\item[$\bullet$] \qtybf{string}: A string.
+\item[$\bullet$] \qtybf{bool}: \textit{true} or \textit{false}.
+\item[$\bullet$] \qtybf{bool\_or\_smart}: \textit{true}, \textit{false}, or \textit{smart}.
+\item[$\bullet$] \qtybf{int}: An integer. Negative integers are prefixed with a hyphen.
+\item[$\bullet$] \qtybf{int\_or\_smart}: An integer or \textit{smart}.
+\item[$\bullet$] \qtybf{int\_range}: An integer (e.g., 3) or a range
+of nonnegative integers (e.g., $1$--$4$). The range symbol `--' can be entered as \texttt{-} (hyphen) or \texttt{\char`\\\char`\<midarrow\char`\>}.
+
+\item[$\bullet$] \qtybf{int\_seq}: A comma-separated sequence of ranges of integers (e.g.,~1{,}3{,}\allowbreak6--8).
+\item[$\bullet$] \qtybf{time}: An integer followed by $\textit{min}$ (minutes), $s$ (seconds), or \textit{ms}
+(milliseconds), or the keyword \textit{none} ($\infty$ years).
+\item[$\bullet$] \qtybf{const}: The name of a HOL constant.
+\item[$\bullet$] \qtybf{term}: A HOL term (e.g., ``$f~x$'').
+\item[$\bullet$] \qtybf{term\_list}: A space-separated list of HOL terms (e.g.,
+``$f~x$''~``$g~y$'').
+\item[$\bullet$] \qtybf{type}: A HOL type.
+\end{enum}
+
+Default values are indicated in square brackets. Boolean options have a negated
+counterpart (e.g., \textit{auto} vs.\ \textit{no\_auto}). When setting Boolean
+options, ``= \textit{true}'' may be omitted.
+
+\subsection{Mode of Operation}
+\label{mode-of-operation}
+
+\begin{enum}
+\opfalse{auto}{no\_auto}
+Specifies whether Nitpick should be run automatically on newly entered theorems.
+For automatic runs, \textit{user\_axioms} (\S\ref{mode-of-operation}) and
+\textit{assms} (\S\ref{mode-of-operation}) are implicitly enabled,
+\textit{blocking} (\S\ref{mode-of-operation}), \textit{verbose}
+(\S\ref{output-format}), and \textit{debug} (\S\ref{output-format}) are
+disabled, \textit{max\_potential} (\S\ref{output-format}) is taken to be 0, and
+\textit{auto\_timeout} (\S\ref{timeouts}) is used as the time limit instead of
+\textit{timeout} (\S\ref{timeouts}). The output is also more concise.
+
+\nopagebreak
+{\small See also \textit{auto\_timeout} (\S\ref{timeouts}).}
+
+\optrue{blocking}{non\_blocking}
+Specifies whether the \textbf{nitpick} command should operate synchronously.
+The asynchronous (non-blocking) mode lets the user start proving the putative
+theorem while Nitpick looks for a counterexample, but it can also be more
+confusing. For technical reasons, automatic runs currently always block.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}).}
+
+\optrue{falsify}{satisfy}
+Specifies whether Nitpick should look for falsifying examples (countermodels) or
+satisfying examples (models). This manual assumes throughout that
+\textit{falsify} is enabled.
+
+\opsmart{user\_axioms}{no\_user\_axioms}
+Specifies whether the user-defined axioms (specified using
+\textbf{axiomatization} and \textbf{axioms}) should be considered. If the option
+is set to \textit{smart}, Nitpick performs an ad hoc axiom selection based on
+the constants that occur in the formula to falsify. The option is implicitly set
+to \textit{true} for automatic runs.
+
+\textbf{Warning:} If the option is set to \textit{true}, Nitpick might
+nonetheless ignore some polymorphic axioms. Counterexamples generated under
+these conditions are tagged as ``likely genuine.'' The \textit{debug}
+(\S\ref{output-format}) option can be used to find out which axioms were
+considered.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}), \textit{assms}
+(\S\ref{mode-of-operation}), and \textit{debug} (\S\ref{output-format}).}
+
+\optrue{assms}{no\_assms}
+Specifies whether the relevant assumptions in structured proof should be
+considered. The option is implicitly enabled for automatic runs.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation})
+and \textit{user\_axioms} (\S\ref{mode-of-operation}).}
+
+\opfalse{overlord}{no\_overlord}
+Specifies whether Nitpick should put its temporary files in
+\texttt{\$ISABELLE\_\allowbreak HOME\_\allowbreak USER}, which is useful for
+debugging Nitpick but also unsafe if several instances of the tool are run
+simultaneously.
+
+\nopagebreak
+{\small See also \textit{debug} (\S\ref{output-format}).}
+\end{enum}
+
+\subsection{Scope of Search}
+\label{scope-of-search}
+
+\begin{enum}
+\opu{card}{type}{int\_seq}
+Specifies the sequence of cardinalities to use for a given type. For
+\textit{nat} and \textit{int}, the cardinality fully specifies the subset used
+to approximate the type. For example:
+%
+$$\hbox{\begin{tabular}{@{}rll@{}}%
+\textit{card nat} = 4 & induces & $\{0,\, 1,\, 2,\, 3\}$ \\
+\textit{card int} = 4 & induces & $\{-1,\, 0,\, +1,\, +2\}$ \\
+\textit{card int} = 5 & induces & $\{-2,\, -1,\, 0,\, +1,\, +2\}.$%
+\end{tabular}}$$
+%
+In general:
+%
+$$\hbox{\begin{tabular}{@{}rll@{}}%
+\textit{card nat} = $K$ & induces & $\{0,\, \ldots,\, K - 1\}$ \\
+\textit{card int} = $K$ & induces & $\{-\lceil K/2 \rceil + 1,\, \ldots,\, +\lfloor K/2 \rfloor\}.$%
+\end{tabular}}$$
+%
+For free types, and often also for \textbf{typedecl}'d types, it usually makes
+sense to specify cardinalities as a range of the form \textit{$1$--$n$}.
+Although function and product types are normally mapped directly to the
+corresponding Kodkod concepts, setting
+the cardinality of such types is also allowed and implicitly enables ``boxing''
+for them, as explained in the description of the \textit{box}~\qty{type}
+and \textit{box} (\S\ref{scope-of-search}) options.
+
+\nopagebreak
+{\small See also \textit{mono} (\S\ref{scope-of-search}).}
+
+\opt{card}{int\_seq}{$\mathbf{1}$--$\mathbf{8}$}
+Specifies the default sequence of cardinalities to use. This can be overridden
+on a per-type basis using the \textit{card}~\qty{type} option described above.
+
+\opu{max}{const}{int\_seq}
+Specifies the sequence of maximum multiplicities to use for a given
+(co)in\-duc\-tive datatype constructor. A constructor's multiplicity is the
+number of distinct values that it can construct. Nonsensical values (e.g.,
+\textit{max}~[]~$=$~2) are silently repaired. This option is only available for
+datatypes equipped with several constructors.
+
+\ops{max}{int\_seq}
+Specifies the default sequence of maximum multiplicities to use for
+(co)in\-duc\-tive datatype constructors. This can be overridden on a per-constructor
+basis using the \textit{max}~\qty{const} option described above.
+
+\opusmart{wf}{const}{non\_wf}
+Specifies whether the specified (co)in\-duc\-tively defined predicate is
+well-founded. The option can take the following values:
+
+\begin{enum}
+\item[$\bullet$] \textbf{\textit{true}}: Tentatively treat the (co)in\-duc\-tive
+predicate as if it were well-founded. Since this is generally not sound when the
+predicate is not well-founded, the counterexamples are tagged as ``likely
+genuine.''
+
+\item[$\bullet$] \textbf{\textit{false}}: Treat the (co)in\-duc\-tive predicate
+as if it were not well-founded. The predicate is then unrolled as prescribed by
+the \textit{star\_linear\_preds}, \textit{iter}~\qty{const}, and \textit{iter}
+options.
+
+\item[$\bullet$] \textbf{\textit{smart}}: Try to prove that the inductive
+predicate is well-founded using Isabelle's \textit{lexicographic\_order} and
+\textit{sizechange} tactics. If this succeeds (or the predicate occurs with an
+appropriate polarity in the formula to falsify), use an efficient fixed point
+equation as specification of the predicate; otherwise, unroll the predicates
+according to the \textit{iter}~\qty{const} and \textit{iter} options.
+\end{enum}
+
+\nopagebreak
+{\small See also \textit{iter} (\S\ref{scope-of-search}),
+\textit{star\_linear\_preds} (\S\ref{optimizations}), and \textit{tac\_timeout}
+(\S\ref{timeouts}).}
+
+\opsmart{wf}{non\_wf}
+Specifies the default wellfoundedness setting to use. This can be overridden on
+a per-predicate basis using the \textit{wf}~\qty{const} option above.
+
+\opu{iter}{const}{int\_seq}
+Specifies the sequence of iteration counts to use when unrolling a given
+(co)in\-duc\-tive predicate. By default, unrolling is applied for inductive
+predicates that occur negatively and coinductive predicates that occur
+positively in the formula to falsify and that cannot be proved to be
+well-founded, but this behavior is influenced by the \textit{wf} option. The
+iteration counts are automatically bounded by the cardinality of the predicate's
+domain.
+
+{\small See also \textit{wf} (\S\ref{scope-of-search}) and
+\textit{star\_linear\_preds} (\S\ref{optimizations}).}
+
+\opt{iter}{int\_seq}{$\mathbf{1{,}2{,}4{,}8{,}12{,}16{,}24{,}32}$}
+Specifies the sequence of iteration counts to use when unrolling (co)in\-duc\-tive
+predicates. This can be overridden on a per-predicate basis using the
+\textit{iter} \qty{const} option above.
+
+\opt{bisim\_depth}{int\_seq}{$\mathbf{7}$}
+Specifies the sequence of iteration counts to use when unrolling the
+bisimilarity predicate generated by Nitpick for coinductive datatypes. A value
+of $-1$ means that no predicate is generated, in which case Nitpick performs an
+after-the-fact check to see if the known coinductive datatype values are
+bidissimilar. If two values are found to be bisimilar, the counterexample is
+tagged as ``likely genuine.'' The iteration counts are automatically bounded by
+the sum of the cardinalities of the coinductive datatypes occurring in the
+formula to falsify.
+
+\opusmart{box}{type}{dont\_box}
+Specifies whether Nitpick should attempt to wrap (``box'') a given function or
+product type in an isomorphic datatype internally. Boxing is an effective mean
+to reduce the search space and speed up Nitpick, because the isomorphic datatype
+is approximated by a subset of the possible function or pair values;
+like other drastic optimizations, it can also prevent the discovery of
+counterexamples. The option can take the following values:
+
+\begin{enum}
+\item[$\bullet$] \textbf{\textit{true}}: Box the specified type whenever
+practicable.
+\item[$\bullet$] \textbf{\textit{false}}: Never box the type.
+\item[$\bullet$] \textbf{\textit{smart}}: Box the type only in contexts where it
+is likely to help. For example, $n$-tuples where $n > 2$ and arguments to
+higher-order functions are good candidates for boxing.
+\end{enum}
+
+Setting the \textit{card}~\qty{type} option for a function or product type
+implicitly enables boxing for that type.
+
+\nopagebreak
+{\small See also \textit{verbose} (\S\ref{output-format})
+and \textit{debug} (\S\ref{output-format}).}
+
+\opsmart{box}{dont\_box}
+Specifies the default boxing setting to use. This can be overridden on a
+per-type basis using the \textit{box}~\qty{type} option described above.
+
+\opusmart{mono}{type}{non\_mono}
+Specifies whether the specified type should be considered monotonic when
+enumerating scopes. If the option is set to \textit{smart}, Nitpick performs a
+monotonicity check on the type. Setting this option to \textit{true} can reduce
+the number of scopes tried, but it also diminishes the theoretical chance of
+finding a counterexample, as demonstrated in \S\ref{scope-monotonicity}.
+
+\nopagebreak
+{\small See also \textit{card} (\S\ref{scope-of-search}),
+\textit{coalesce\_type\_vars} (\S\ref{scope-of-search}), and \textit{verbose}
+(\S\ref{output-format}).}
+
+\opsmart{mono}{non\_box}
+Specifies the default monotonicity setting to use. This can be overridden on a
+per-type basis using the \textit{mono}~\qty{type} option described above.
+
+\opfalse{coalesce\_type\_vars}{dont\_coalesce\_type\_vars}
+Specifies whether type variables with the same sort constraints should be
+merged. Setting this option to \textit{true} can reduce the number of scopes
+tried and the size of the generated Kodkod formulas, but it also diminishes the
+theoretical chance of finding a counterexample.
+
+{\small See also \textit{mono} (\S\ref{scope-of-search}).}
+\end{enum}
+
+\subsection{Output Format}
+\label{output-format}
+
+\begin{enum}
+\opfalse{verbose}{quiet}
+Specifies whether the \textbf{nitpick} command should explain what it does. This
+option is useful to determine which scopes are tried or which SAT solver is
+used. This option is implicitly disabled for automatic runs.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}).}
+
+\opfalse{debug}{no\_debug}
+Specifies whether Nitpick should display additional debugging information beyond
+what \textit{verbose} already displays. Enabling \textit{debug} also enables
+\textit{verbose} and \textit{show\_all} behind the scenes. The \textit{debug}
+option is implicitly disabled for automatic runs.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}), \textit{overlord}
+(\S\ref{mode-of-operation}), and \textit{batch\_size} (\S\ref{optimizations}).}
+
+\optrue{show\_skolems}{hide\_skolem}
+Specifies whether the values of Skolem constants should be displayed as part of
+counterexamples. Skolem constants correspond to bound variables in the original
+formula and usually help us to understand why the counterexample falsifies the
+formula.
+
+\nopagebreak
+{\small See also \textit{skolemize} (\S\ref{optimizations}).}
+
+\opfalse{show\_datatypes}{hide\_datatypes}
+Specifies whether the subsets used to approximate (co)in\-duc\-tive datatypes should
+be displayed as part of counterexamples. Such subsets are sometimes helpful when
+investigating whether a potential counterexample is genuine or spurious, but
+their potential for clutter is real.
+
+\opfalse{show\_consts}{hide\_consts}
+Specifies whether the values of constants occurring in the formula (including
+its axioms) should be displayed along with any counterexample. These values are
+sometimes helpful when investigating why a counterexample is
+genuine, but they can clutter the output.
+
+\opfalse{show\_all}{dont\_show\_all}
+Enabling this option effectively enables \textit{show\_skolems},
+\textit{show\_datatypes}, and \textit{show\_consts}.
+
+\opt{max\_potential}{int}{$\mathbf{1}$}
+Specifies the maximum number of potential counterexamples to display. Setting
+this option to 0 speeds up the search for a genuine counterexample. This option
+is implicitly set to 0 for automatic runs. If you set this option to a value
+greater than 1, you will need an incremental SAT solver: For efficiency, it is
+recommended to install the JNI version of MiniSat and set \textit{sat\_solver} =
+\textit{MiniSatJNI}. Also be aware that many of the counterexamples may look
+identical, unless the \textit{show\_all} (\S\ref{output-format}) option is
+enabled.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}),
+\textit{check\_potential} (\S\ref{authentication}), and
+\textit{sat\_solver} (\S\ref{optimizations}).}
+
+\opt{max\_genuine}{int}{$\mathbf{1}$}
+Specifies the maximum number of genuine counterexamples to display. If you set
+this option to a value greater than 1, you will need an incremental SAT solver:
+For efficiency, it is recommended to install the JNI version of MiniSat and set
+\textit{sat\_solver} = \textit{MiniSatJNI}. Also be aware that many of the
+counterexamples may look identical, unless the \textit{show\_all}
+(\S\ref{output-format}) option is enabled.
+
+\nopagebreak
+{\small See also \textit{check\_genuine} (\S\ref{authentication}) and
+\textit{sat\_solver} (\S\ref{optimizations}).}
+
+\ops{eval}{term\_list}
+Specifies the list of terms whose values should be displayed along with
+counterexamples. This option suffers from an ``observer effect'': Nitpick might
+find different counterexamples for different values of this option.
+
+\opu{format}{term}{int\_seq}
+Specifies how to uncurry the value displayed for a variable or constant.
+Uncurrying sometimes increases the readability of the output for high-arity
+functions. For example, given the variable $y \mathbin{\Colon} {'a}\Rightarrow
+{'b}\Rightarrow {'c}\Rightarrow {'d}\Rightarrow {'e}\Rightarrow {'f}\Rightarrow
+{'g}$, setting \textit{format}~$y$ = 3 tells Nitpick to group the last three
+arguments, as if the type had been ${'a}\Rightarrow {'b}\Rightarrow
+{'c}\Rightarrow {'d}\times {'e}\times {'f}\Rightarrow {'g}$. In general, a list
+of values $n_1,\ldots,n_k$ tells Nitpick to show the last $n_k$ arguments as an
+$n_k$-tuple, the previous $n_{k-1}$ arguments as an $n_{k-1}$-tuple, and so on;
+arguments that are not accounted for are left alone, as if the specification had
+been $1,\ldots,1,n_1,\ldots,n_k$.
+
+\nopagebreak
+{\small See also \textit{uncurry} (\S\ref{optimizations}).}
+
+\opt{format}{int\_seq}{$\mathbf{1}$}
+Specifies the default format to use. Irrespective of the default format, the
+extra arguments to a Skolem constant corresponding to the outer bound variables
+are kept separated from the remaining arguments, the \textbf{for} arguments of
+an inductive definitions are kept separated from the remaining arguments, and
+the iteration counter of an unrolled inductive definition is shown alone. The
+default format can be overridden on a per-variable or per-constant basis using
+the \textit{format}~\qty{term} option described above.
+\end{enum}
+
+%% MARK: Authentication
+\subsection{Authentication}
+\label{authentication}
+
+\begin{enum}
+\opfalse{check\_potential}{trust\_potential}
+Specifies whether potential counterexamples should be given to Isabelle's
+\textit{auto} tactic to assess their validity. If a potential counterexample is
+shown to be genuine, Nitpick displays a message to this effect and terminates.
+
+\nopagebreak
+{\small See also \textit{max\_potential} (\S\ref{output-format}) and
+\textit{auto\_timeout} (\S\ref{timeouts}).}
+
+\opfalse{check\_genuine}{trust\_genuine}
+Specifies whether genuine and likely genuine counterexamples should be given to
+Isabelle's \textit{auto} tactic to assess their validity. If a ``genuine''
+counterexample is shown to be spurious, the user is kindly asked to send a bug
+report to the author at
+\texttt{blan{\color{white}nospam}\kern-\wd\boxA{}chette@in.tum.de}.
+
+\nopagebreak
+{\small See also \textit{max\_genuine} (\S\ref{output-format}) and
+\textit{auto\_timeout} (\S\ref{timeouts}).}
+
+\ops{expect}{string}
+Specifies the expected outcome, which must be one of the following:
+
+\begin{enum}
+\item[$\bullet$] \textbf{\textit{genuine}}: Nitpick found a genuine counterexample.
+\item[$\bullet$] \textbf{\textit{likely\_genuine}}: Nitpick found a ``likely
+genuine'' counterexample (i.e., a counterexample that is genuine unless
+it contradicts a missing axiom or a dangerous option was used inappropriately).
+\item[$\bullet$] \textbf{\textit{potential}}: Nitpick found a potential counterexample.
+\item[$\bullet$] \textbf{\textit{none}}: Nitpick found no counterexample.
+\item[$\bullet$] \textbf{\textit{unknown}}: Nitpick encountered some problem (e.g.,
+Kodkod ran out of memory).
+\end{enum}
+
+Nitpick emits an error if the actual outcome differs from the expected outcome.
+This option is useful for regression testing.
+\end{enum}
+
+\subsection{Optimizations}
+\label{optimizations}
+
+\def\cpp{C\nobreak\raisebox{.1ex}{+}\nobreak\raisebox{.1ex}{+}}
+
+\sloppy
+
+\begin{enum}
+\opt{sat\_solver}{string}{smart}
+Specifies which SAT solver to use. SAT solvers implemented in C or \cpp{} tend
+to be faster than their Java counterparts, but they can be more difficult to
+install. Also, if you set the \textit{max\_potential} (\S\ref{output-format}) or
+\textit{max\_genuine} (\S\ref{output-format}) option to a value greater than 1,
+you will need an incremental SAT solver, such as \textit{MiniSatJNI}
+(recommended) or \textit{SAT4J}.
+
+The supported solvers are listed below:
+
+\begin{enum}
+
+\item[$\bullet$] \textbf{\textit{MiniSat}}: MiniSat is an efficient solver
+written in \cpp{}. To use MiniSat, set the environment variable
+\texttt{MINISAT\_HOME} to the directory that contains the \texttt{minisat}
+executable. The \cpp{} sources and executables for MiniSat are available at
+\url{http://minisat.se/MiniSat.html}. Nitpick has been tested with versions 1.14
+and 2.0 beta (2007-07-21).
+
+\item[$\bullet$] \textbf{\textit{MiniSatJNI}}: The JNI (Java Native Interface)
+version of MiniSat is bundled in \texttt{nativesolver.\allowbreak tgz}, which
+you will find on Kodkod's web site \cite{kodkod-2009}. Unlike the standard
+version of MiniSat, the JNI version can be used incrementally.
+
+\item[$\bullet$] \textbf{\textit{PicoSAT}}: PicoSAT is an efficient solver
+written in C. It is bundled with Kodkodi and requires no further installation or
+configuration steps. Alternatively, you can install a standard version of
+PicoSAT and set the environment variable \texttt{PICOSAT\_HOME} to the directory
+that contains the \texttt{picosat} executable. The C sources for PicoSAT are
+available at \url{http://fmv.jku.at/picosat/} and are also bundled with Kodkodi.
+Nitpick has been tested with version 913.
+
+\item[$\bullet$] \textbf{\textit{zChaff}}: zChaff is an efficient solver written
+in \cpp{}. To use zChaff, set the environment variable \texttt{ZCHAFF\_HOME} to
+the directory that contains the \texttt{zchaff} executable. The \cpp{} sources
+and executables for zChaff are available at
+\url{http://www.princeton.edu/~chaff/zchaff.html}. Nitpick has been tested with
+versions 2004-05-13, 2004-11-15, and 2007-03-12.
+
+\item[$\bullet$] \textbf{\textit{zChaffJNI}}: The JNI version of zChaff is
+bundled in \texttt{native\-solver.\allowbreak tgz}, which you will find on
+Kodkod's web site \cite{kodkod-2009}.
+
+\item[$\bullet$] \textbf{\textit{RSat}}: RSat is an efficient solver written in
+\cpp{}. To use RSat, set the environment variable \texttt{RSAT\_HOME} to the
+directory that contains the \texttt{rsat} executable. The \cpp{} sources for
+RSat are available at \url{http://reasoning.cs.ucla.edu/rsat/}. Nitpick has been
+tested with version 2.01.
+
+\item[$\bullet$] \textbf{\textit{BerkMin}}: BerkMin561 is an efficient solver
+written in C. To use BerkMin, set the environment variable
+\texttt{BERKMIN\_HOME} to the directory that contains the \texttt{BerkMin561}
+executable. The BerkMin executables are available at
+\url{http://eigold.tripod.com/BerkMin.html}.
+
+\item[$\bullet$] \textbf{\textit{BerkMinAlloy}}: Variant of BerkMin that is
+included with Alloy 4 and calls itself ``sat56'' in its banner text. To use this
+version of BerkMin, set the environment variable
+\texttt{BERKMINALLOY\_HOME} to the directory that contains the \texttt{berkmin}
+executable.
+
+\item[$\bullet$] \textbf{\textit{Jerusat}}: Jerusat 1.3 is an efficient solver
+written in C. To use Jerusat, set the environment variable
+\texttt{JERUSAT\_HOME} to the directory that contains the \texttt{Jerusat1.3}
+executable. The C sources for Jerusat are available at
+\url{http://www.cs.tau.ac.il/~ale1/Jerusat1.3.tgz}.
+
+\item[$\bullet$] \textbf{\textit{SAT4J}}: SAT4J is a reasonably efficient solver
+written in Java that can be used incrementally. It is bundled with Kodkodi and
+requires no further installation or configuration steps. Do not attempt to
+install the official SAT4J packages, because their API is incompatible with
+Kodkod.
+
+\item[$\bullet$] \textbf{\textit{SAT4JLight}}: Variant of SAT4J that is
+optimized for small problems. It can also be used incrementally.
+
+\item[$\bullet$] \textbf{\textit{HaifaSat}}: HaifaSat 1.0 beta is an
+experimental solver written in \cpp. To use HaifaSat, set the environment
+variable \texttt{HAIFASAT\_\allowbreak HOME} to the directory that contains the
+\texttt{HaifaSat} executable. The \cpp{} sources for HaifaSat are available at
+\url{http://cs.technion.ac.il/~gershman/HaifaSat.htm}.
+
+\item[$\bullet$] \textbf{\textit{smart}}: If \textit{sat\_solver} is set to
+\textit{smart}, Nitpick selects the first solver among MiniSat, PicoSAT, zChaff,
+RSat, BerkMin, BerkMinAlloy, and Jerusat that is recognized by Isabelle. If none
+is found, it falls back on SAT4J, which should always be available. If
+\textit{verbose} is enabled, Nitpick displays which SAT solver was chosen.
+
+\end{enum}
+\fussy
+
+\opt{batch\_size}{int\_or\_smart}{smart}
+Specifies the maximum number of Kodkod problems that should be lumped together
+when invoking Kodkodi. Each problem corresponds to one scope. Lumping problems
+together ensures that Kodkodi is launched less often, but it makes the verbose
+output less readable and is sometimes detrimental to performance. If
+\textit{batch\_size} is set to \textit{smart}, the actual value used is 1 if
+\textit{debug} (\S\ref{output-format}) is set and 64 otherwise.
+
+\optrue{destroy\_constrs}{dont\_destroy\_constrs}
+Specifies whether formulas involving (co)in\-duc\-tive datatype constructors should
+be rewritten to use (automatically generated) discriminators and destructors.
+This optimization can drastically reduce the size of the Boolean formulas given
+to the SAT solver.
+
+\nopagebreak
+{\small See also \textit{debug} (\S\ref{output-format}).}
+
+\optrue{specialize}{dont\_specialize}
+Specifies whether functions invoked with static arguments should be specialized.
+This optimization can drastically reduce the search space, especially for
+higher-order functions.
+
+\nopagebreak
+{\small See also \textit{debug} (\S\ref{output-format}) and
+\textit{show\_consts} (\S\ref{output-format}).}
+
+\optrue{skolemize}{dont\_skolemize}
+Specifies whether the formula should be skolemized. For performance reasons,
+(positive) $\forall$-quanti\-fiers that occur in the scope of a higher-order
+(positive) $\exists$-quanti\-fier are left unchanged.
+
+\nopagebreak
+{\small See also \textit{debug} (\S\ref{output-format}) and
+\textit{show\_skolems} (\S\ref{output-format}).}
+
+\optrue{star\_linear\_preds}{dont\_star\_linear\_preds}
+Specifies whether Nitpick should use Kodkod's transitive closure operator to
+encode non-well-founded ``linear inductive predicates,'' i.e., inductive
+predicates for which each the predicate occurs in at most one assumption of each
+introduction rule. Using the reflexive transitive closure is in principle
+equivalent to setting \textit{iter} to the cardinality of the predicate's
+domain, but it is usually more efficient.
+
+{\small See also \textit{wf} (\S\ref{scope-of-search}), \textit{debug}
+(\S\ref{output-format}), and \textit{iter} (\S\ref{scope-of-search}).}
+
+\optrue{uncurry}{dont\_uncurry}
+Specifies whether Nitpick should uncurry functions. Uncurrying has on its own no
+tangible effect on efficiency, but it creates opportunities for the boxing
+optimization.
+
+\nopagebreak
+{\small See also \textit{box} (\S\ref{scope-of-search}), \textit{debug}
+(\S\ref{output-format}), and \textit{format} (\S\ref{output-format}).}
+
+\optrue{fast\_descrs}{full\_descrs}
+Specifies whether Nitpick should optimize the definite and indefinite
+description operators (THE and SOME). The optimized versions usually help
+Nitpick generate more counterexamples or at least find them faster, but only the
+unoptimized versions are complete when all types occurring in the formula are
+finite.
+
+{\small See also \textit{debug} (\S\ref{output-format}).}
+
+\optrue{peephole\_optim}{no\_peephole\_optim}
+Specifies whether Nitpick should simplify the generated Kodkod formulas using a
+peephole optimizer. These optimizations can make a significant difference.
+Unless you are tracking down a bug in Nitpick or distrust the peephole
+optimizer, you should leave this option enabled.
+
+\opt{sym\_break}{int}{20}
+Specifies an upper bound on the number of relations for which Kodkod generates
+symmetry breaking predicates. According to the Kodkod documentation
+\cite{kodkod-2009-options}, ``in general, the higher this value, the more
+symmetries will be broken, and the faster the formula will be solved. But,
+setting the value too high may have the opposite effect and slow down the
+solving.''
+
+\opt{sharing\_depth}{int}{3}
+Specifies the depth to which Kodkod should check circuits for equivalence during
+the translation to SAT. The default of 3 is the same as in Alloy. The minimum
+allowed depth is 1. Increasing the sharing may result in a smaller SAT problem,
+but can also slow down Kodkod.
+
+\opfalse{flatten\_props}{dont\_flatten\_props}
+Specifies whether Kodkod should try to eliminate intermediate Boolean variables.
+Although this might sound like a good idea, in practice it can drastically slow
+down Kodkod.
+
+\opt{max\_threads}{int}{0}
+Specifies the maximum number of threads to use in Kodkod. If this option is set
+to 0, Kodkod will compute an appropriate value based on the number of processor
+cores available.
+
+\nopagebreak
+{\small See also \textit{batch\_size} (\S\ref{optimizations}) and
+\textit{timeout} (\S\ref{timeouts}).}
+\end{enum}
+
+\subsection{Timeouts}
+\label{timeouts}
+
+\begin{enum}
+\opt{timeout}{time}{$\mathbf{30}$ s}
+Specifies the maximum amount of time that the \textbf{nitpick} command should
+spend looking for a counterexample. Nitpick tries to honor this constraint as
+well as it can but offers no guarantees. For automatic runs,
+\textit{auto\_timeout} is used instead.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation})
+and \textit{max\_threads} (\S\ref{optimizations}).}
+
+\opt{auto\_timeout}{time}{$\mathbf{5}$ s}
+Specifies the maximum amount of time that Nitpick should use to find a
+counterexample when running automatically. Nitpick tries to honor this
+constraint as well as it can but offers no guarantees.
+
+\nopagebreak
+{\small See also \textit{auto} (\S\ref{mode-of-operation}).}
+
+\opt{tac\_timeout}{time}{$\mathbf{500}$ ms}
+Specifies the maximum amount of time that the \textit{auto} tactic should use
+when checking a counterexample, and similarly that \textit{lexicographic\_order}
+and \textit{sizechange} should use when checking whether a (co)in\-duc\-tive
+predicate is well-founded. Nitpick tries to honor this constraint as well as it
+can but offers no guarantees.
+
+\nopagebreak
+{\small See also \textit{wf} (\S\ref{scope-of-search}),
+\textit{check\_potential} (\S\ref{authentication}),
+and \textit{check\_genuine} (\S\ref{authentication}).}
+\end{enum}
+
+\section{Attribute Reference}
+\label{attribute-reference}
+
+Nitpick needs to consider the definitions of all constants occurring in a
+formula in order to falsify it. For constants introduced using the
+\textbf{definition} command, the definition is simply the associated
+\textit{\_def} axiom. In contrast, instead of using the internal representation
+of functions synthesized by Isabelle's \textbf{primrec}, \textbf{function}, and
+\textbf{nominal\_primrec} packages, Nitpick relies on the more natural
+equational specification entered by the user.
+
+Behind the scenes, Isabelle's built-in packages and theories rely on the
+following attributes to affect Nitpick's behavior:
+
+\begin{itemize}
+\flushitem{\textit{nitpick\_def}}
+
+\nopagebreak
+This attribute specifies an alternative definition of a constant. The
+alternative definition should be logically equivalent to the constant's actual
+axiomatic definition and should be of the form
+
+\qquad $c~{?}x_1~\ldots~{?}x_n \,\equiv\, t$,
+
+where ${?}x_1, \ldots, {?}x_n$ are distinct variables and $c$ does not occur in
+$t$.
+
+\flushitem{\textit{nitpick\_simp}}
+
+\nopagebreak
+This attribute specifies the equations that constitute the specification of a
+constant. For functions defined using the \textbf{primrec}, \textbf{function},
+and \textbf{nominal\_\allowbreak primrec} packages, this corresponds to the
+\textit{simps} rules. The equations must be of the form
+
+\qquad $c~t_1~\ldots\ t_n \,=\, u.$
+
+\flushitem{\textit{nitpick\_psimp}}
+
+\nopagebreak
+This attribute specifies the equations that constitute the partial specification
+of a constant. For functions defined using the \textbf{function} package, this
+corresponds to the \textit{psimps} rules. The conditional equations must be of
+the form
+
+\qquad $\lbrakk P_1;\> \ldots;\> P_m\rbrakk \,\Longrightarrow\, c\ t_1\ \ldots\ t_n \,=\, u$.
+
+\flushitem{\textit{nitpick\_intro}}
+
+\nopagebreak
+This attribute specifies the introduction rules of a (co)in\-duc\-tive predicate.
+For predicates defined using the \textbf{inductive} or \textbf{coinductive}
+command, this corresponds to the \textit{intros} rules. The introduction rules
+must be of the form
+
+\qquad $\lbrakk P_1;\> \ldots;\> P_m;\> M~(c\ t_{11}\ \ldots\ t_{1n});\>
+\ldots;\> M~(c\ t_{k1}\ \ldots\ t_{kn})\rbrakk \,\Longrightarrow\, c\ u_1\
+\ldots\ u_n$,
+
+where the $P_i$'s are side conditions that do not involve $c$ and $M$ is an
+optional monotonic operator. The order of the assumptions is irrelevant.
+
+\end{itemize}
+
+When faced with a constant, Nitpick proceeds as follows:
+
+\begin{enum}
+\item[1.] If the \textit{nitpick\_simp} set associated with the constant
+is not empty, Nitpick uses these rules as the specification of the constant.
+
+\item[2.] Otherwise, if the \textit{nitpick\_psimp} set associated with
+the constant is not empty, it uses these rules as the specification of the
+constant.
+
+\item[3.] Otherwise, it looks up the definition of the constant:
+
+\begin{enum}
+\item[1.] If the \textit{nitpick\_def} set associated with the constant
+is not empty, it uses the latest rule added to the set as the definition of the
+constant; otherwise it uses the actual definition axiom.
+\item[2.] If the definition is of the form
+
+\qquad $c~{?}x_1~\ldots~{?}x_m \,\equiv\, \lambda y_1~\ldots~y_n.\; \textit{lfp}~(\lambda f.\; t)$,
+
+then Nitpick assumes that the definition was made using an inductive package and
+based on the introduction rules marked with \textit{nitpick\_\allowbreak
+ind\_\allowbreak intros} tries to determine whether the definition is
+well-founded.
+\end{enum}
+\end{enum}
+
+As an illustration, consider the inductive definition
+
+\prew
+\textbf{inductive}~\textit{odd}~\textbf{where} \\
+``\textit{odd}~1'' $\,\mid$ \\
+``\textit{odd}~$n\,\Longrightarrow\, \textit{odd}~(\textit{Suc}~(\textit{Suc}~n))$''
+\postw
+
+Isabelle automatically attaches the \textit{nitpick\_intro} attribute to
+the above rules. Nitpick then uses the \textit{lfp}-based definition in
+conjunction with these rules. To override this, we can specify an alternative
+definition as follows:
+
+\prew
+\textbf{lemma} $\mathit{odd\_def}'$ [\textit{nitpick\_def}]: ``$\textit{odd}~n \,\equiv\, n~\textrm{mod}~2 = 1$''
+\postw
+
+Nitpick then expands all occurrences of $\mathit{odd}~n$ to $n~\textrm{mod}~2
+= 1$. Alternatively, we can specify an equational specification of the constant:
+
+\prew
+\textbf{lemma} $\mathit{odd\_simp}'$ [\textit{nitpick\_simp}]: ``$\textit{odd}~n = (n~\textrm{mod}~2 = 1)$''
+\postw
+
+Such tweaks should be done with great care, because Nitpick will assume that the
+constant is completely defined by its equational specification. For example, if
+you make ``$\textit{odd}~(2 * k + 1)$'' a \textit{nitpick\_simp} rule and neglect to provide rules to handle the $2 * k$ case, Nitpick will define
+$\textit{odd}~n$ arbitrarily for even values of $n$. The \textit{debug}
+(\S\ref{output-format}) option is extremely useful to understand what is going
+on when experimenting with \textit{nitpick\_} attributes.
+
+\section{Standard ML Interface}
+\label{standard-ml-interface}
+
+Nitpick provides a rich Standard ML interface used mainly for internal purposes
+and debugging. Among the most interesting functions exported by Nitpick are
+those that let you invoke the tool programmatically and those that let you
+register and unregister custom coinductive datatypes.
+
+\subsection{Invocation of Nitpick}
+\label{invocation-of-nitpick}
+
+The \textit{Nitpick} structure offers the following functions for invoking your
+favorite counterexample generator:
+
+\prew
+$\textbf{val}\,~\textit{pick\_nits\_in\_term} : \\
+\hbox{}\quad\textit{Proof.state} \rightarrow \textit{params} \rightarrow \textit{bool} \rightarrow \textit{term~list} \rightarrow \textit{term} \\
+\hbox{}\quad{\rightarrow}\; \textit{string} * \textit{Proof.state}$ \\
+$\textbf{val}\,~\textit{pick\_nits\_in\_subgoal} : \\
+\hbox{}\quad\textit{Proof.state} \rightarrow \textit{params} \rightarrow \textit{bool} \rightarrow \textit{int} \rightarrow \textit{string} * \textit{Proof.state}$
+\postw
+
+The return value is a new proof state paired with an outcome string
+(``genuine'', ``likely\_genuine'', ``potential'', ``none'', or ``unknown''). The
+\textit{params} type is a large record that lets you set Nitpick's options. The
+current default options can be retrieved by calling the following function
+defined in the \textit{NitpickIsar} structure:
+
+\prew
+$\textbf{val}\,~\textit{default\_params} :\,
+\textit{theory} \rightarrow (\textit{string} * \textit{string})~\textit{list} \rightarrow \textit{params}$
+\postw
+
+The second argument lets you override option values before they are parsed and
+put into a \textit{params} record. Here is an example:
+
+\prew
+$\textbf{val}\,~\textit{params} = \textit{NitpickIsar.default\_params}~\textit{thy}~[(\textrm{``}\textrm{timeout}\textrm{''},\, \textrm{``}\textrm{none}\textrm{''})]$ \\
+$\textbf{val}\,~(\textit{outcome},\, \textit{state}') = \textit{Nitpick.pick\_nits\_in\_subgoal}~\begin{aligned}[t]
+& \textit{state}~\textit{params}~\textit{false} \\[-2pt]
+& \textit{subgoal}\end{aligned}$
+\postw
+
+\subsection{Registration of Coinductive Datatypes}
+\label{registration-of-coinductive-datatypes}
+
+\let\antiq=\textrm
+
+If you have defined a custom coinductive datatype, you can tell Nitpick about
+it, so that it can use an efficient Kodkod axiomatization similar to the one it
+uses for lazy lists. The interface for registering and unregistering coinductive
+datatypes consists of the following pair of functions defined in the
+\textit{Nitpick} structure:
+
+\prew
+$\textbf{val}\,~\textit{register\_codatatype} :\,
+\textit{typ} \rightarrow \textit{string} \rightarrow \textit{styp~list} \rightarrow \textit{theory} \rightarrow \textit{theory}$ \\
+$\textbf{val}\,~\textit{unregister\_codatatype} :\,
+\textit{typ} \rightarrow \textit{theory} \rightarrow \textit{theory}$
+\postw
+
+The type $'a~\textit{llist}$ of lazy lists is already registered; had it
+not been, you could have told Nitpick about it by adding the following line
+to your theory file:
+
+\prew
+$\textbf{setup}~\,\{{*}\,~\!\begin{aligned}[t]
+& \textit{Nitpick.register\_codatatype} \\[-2pt]
+& \qquad @\{\antiq{typ}~``\kern1pt'a~\textit{llist}\textrm{''}\}~@\{\antiq{const\_name}~ \textit{llist\_case}\} \\[-2pt] %% TYPESETTING
+& \qquad (\textit{map}~\textit{dest\_Const}~[@\{\antiq{term}~\textit{LNil}\},\, @\{\antiq{term}~\textit{LCons}\}])\,\ {*}\}\end{aligned}$
+\postw
+
+The \textit{register\_codatatype} function takes a coinductive type, its case
+function, and the list of its constructors. The case function must take its
+arguments in the order that the constructors are listed. If no case function
+with the correct signature is available, simply pass the empty string.
+
+On the other hand, if your goal is to cripple Nitpick, add the following line to
+your theory file and try to check a few conjectures about lazy lists:
+
+\prew
+$\textbf{setup}~\,\{{*}\,~\textit{Nitpick.unregister\_codatatype}~@\{\antiq{typ}~``
+\kern1pt'a~\textit{list}\textrm{''}\}\ \,{*}\}$
+\postw
+
+\section{Known Bugs and Limitations}
+\label{known-bugs-and-limitations}
+
+Here are the known bugs and limitations in Nitpick at the time of writing:
+
+\begin{enum}
+\item[$\bullet$] Underspecified functions defined using the \textbf{primrec},
+\textbf{function}, or \textbf{nominal\_\allowbreak primrec} packages can lead
+Nitpick to generate spurious counterexamples for theorems that refer to values
+for which the function is not defined. For example:
+
+\prew
+\textbf{primrec} \textit{prec} \textbf{where} \\
+``$\textit{prec}~(\textit{Suc}~n) = n$'' \\[2\smallskipamount]
+\textbf{lemma} ``$\textit{prec}~0 = \undef$'' \\
+\textbf{nitpick} \\[2\smallskipamount]
+\quad{\slshape Nitpick found a counterexample for \textit{card nat}~= 2:
+\nopagebreak
+\\[2\smallskipamount]
+\hbox{}\qquad Empty assignment} \nopagebreak\\[2\smallskipamount]
+\textbf{by}~(\textit{auto simp}: \textit{prec\_def})
+\postw
+
+Such theorems are considered bad style because they rely on the internal
+representation of functions synthesized by Isabelle, which is an implementation
+detail.
+
+\item[$\bullet$] Nitpick produces spurious counterexamples when invoked after a
+\textbf{guess} command in a structured proof.
+
+\item[$\bullet$] The \textit{nitpick\_} attributes and the
+\textit{Nitpick.register\_} functions can cause havoc if used improperly.
+
+\item[$\bullet$] Local definitions are not supported and result in an error.
+
+\item[$\bullet$] All constants and types whose names start with
+\textit{Nitpick}{.} are reserved for internal use.
+\end{enum}
+
+\let\em=\sl
+\bibliography{../manual}{}
+\bibliographystyle{abbrv}
+
+\end{document}--- a/doc-src/TutorialI/Misc/Itrev.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/TutorialI/Misc/Itrev.thy Tue Oct 27 14:46:03 2009 +0000
@@ -2,7 +2,7 @@
theory Itrev
imports Main
begin
-ML"Unsynchronized.reset NameSpace.unique_names"
+ML"Unsynchronized.reset unique_names"
(*>*)
section{*Induction Heuristics*}
@@ -141,6 +141,6 @@
\index{induction heuristics|)}
*}
(*<*)
-ML"Unsynchronized.set NameSpace.unique_names"
+ML"Unsynchronized.set unique_names"
end
(*>*)--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/gfx/isabelle_nitpick.eps Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,6488 @@
+%!PS-Adobe-2.0 EPSF-1.2
+%%Title: isabelle_any
+%%Creator: FreeHand 5.5
+%%CreationDate: 24.09.1998 21:04 Uhr
+%%BoundingBox: 0 0 202 178
+%%FHPathName:MacSystem:Home:Markus:TUM:Isabelle Logo:export:isabelle_any
+%ALDOriginalFile:MacSystem:Home:Markus:TUM:Isabelle Logo:export:isabelle_any
+%ALDBoundingBox: -153 -386 442 456
+%%FHPageNum:1
+%%DocumentSuppliedResources: procset Altsys_header 4 0
+%%ColorUsage: Color
+%%DocumentProcessColors: Cyan Magenta Yellow Black
+%%DocumentNeededResources: font Symbol
+%%+ font ZapfHumanist601BT-Bold
+%%DocumentFonts: Symbol
+%%+ ZapfHumanist601BT-Bold
+%%DocumentNeededFonts: Symbol
+%%+ ZapfHumanist601BT-Bold
+%%EndComments
+%!PS-AdobeFont-1.0: ZapfHumanist601BT-Bold 003.001
+%%CreationDate: Mon Jun 22 16:09:28 1992
+%%VMusage: 35200 38400
+% Bitstream Type 1 Font Program
+% Copyright 1990-1992 as an unpublished work by Bitstream Inc., Cambridge, MA.
+% All rights reserved.
+% Confidential and proprietary to Bitstream Inc.
+% U.S. GOVERNMENT RESTRICTED RIGHTS
+% This software typeface product is provided with RESTRICTED RIGHTS. Use,
+% duplication or disclosure by the Government is subject to restrictions
+% as set forth in the license agreement and in FAR 52.227-19 (c) (2) (May, 1987),
+% when applicable, or the applicable provisions of the DOD FAR supplement
+% 252.227-7013 subdivision (a) (15) (April, 1988) or subdivision (a) (17)
+% (April, 1988). Contractor/manufacturer is Bitstream Inc.,
+% 215 First Street, Cambridge, MA 02142.
+% Bitstream is a registered trademark of Bitstream Inc.
+11 dict begin
+/FontInfo 9 dict dup begin
+ /version (003.001) readonly def
+ /Notice (Copyright 1990-1992 as an unpublished work by Bitstream Inc. All rights reserved. Confidential.) readonly def
+ /FullName (Zapf Humanist 601 Bold) readonly def
+ /FamilyName (Zapf Humanist 601) readonly def
+ /Weight (Bold) readonly def
+ /ItalicAngle 0 def
+ /isFixedPitch false def
+ /UnderlinePosition -136 def
+ /UnderlineThickness 85 def
+end readonly def
+/FontName /ZapfHumanist601BT-Bold def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding StandardEncoding def
+/FontBBox {-167 -275 1170 962} readonly def
+/UniqueID 15530396 def
+currentdict end
+currentfile eexec
+a2951840838a4133839ca9d22e2b99f2b61c767cd675080aacfcb24e19cd
+1336739bb64994c56737090b4cec92c9945ff0745ef7ffc61bb0a9a3b849
+e7e98740e56c0b5af787559cc6956ab31e33cf8553d55c0b0e818ef5ec6b
+f48162eac42e7380ca921dae1c82b38fd6bcf2001abb5d001a56157094cf
+e27d8f4eac9693e88372d20358b47e0c3876558ebf757a1fbc5c1cddf62b
+3c57bf727ef1c4879422c142a084d1c7462ac293e097fabe3a3ecfcd8271
+f259833bac7912707218ec9a3063bf7385e02d8c1058ac06df00b33b8c01
+8768b278010eb4dd58c7ba59321899741cb7215d8a55bee8d3398c887f02
+e1f4869387f89141de693fcb429c7884c22dcdeddcaa62b7f5060249dfab
+cfc351201f7d188b6ed68a228abda4d33b3d269ac09cde172bc045e67449
+c0f25d224efbe8c9f9d2968a01edbfb039123c365ed0db58ad38aabe015b
+8881191dd23092f6d53d5c1cd68ebd038e098d32cb24b433b7d5d89c28ee
+05ea0b6070bb785a2974b5a160ee4cf8b6d8c73445d36720af0530441cd9
+61bc0c367f1af1ec1c5ab7255ddda153c1868aba58cd5b44835535d85326
+5d7fed5ff7118adb5d5b76cc3b72e5ff27e21eb857261b3afb7688fca12d
+1663b0d8bdc1dd47a84b65b47d3e76d3b8fa8b319f17e1bb22b45a7482fd
+f9ad1b6129e09ae47f15cd2447484cd2d64f59ab0f2f876c81e7d87ccdf9
+005aa8fc093d02db51a075d571e925f2d309a1c535a1e59d34215c6cd33e
+3c38997b4956461f376399901a8d0943dca6a335baac93fc8482c0659f04
+329c6f040b35828ea6dd1bd1858f2a9be4ef77731b5b75a1c536c6bc9479
+0821e5d88f6e2981835dbfd65ec254ebcf2cf49c917d121cd3bbb476a12b
+69c15f17d9c17bb15ad1e7d31d2afcf58c8f0ad526d68615a0f1ac3b1d1c
+d3beafeea3cf56c8f8a66367c70df9159f0b1b3157ccfd010045c4718e0e
+625c0891e85790c9b97b85517c74c9d55eaca31a01cddc64898bf0eeadf3
+53391a185e507dcb0a6f52661a56357ac818dfc740a540aadf02f4e7a79d
+8008a77cd30abde337025b01217d6a68c306abe145b7260c3478fa5f366f
+b2d37259ead8a8ec2db2f09ae0eb3a682d27b0d73a60935f80254c24426a
+003a87a29a4370cbf1b2ef1e19ad8466ec725fd5b463d06011a5e0da2258
+ff6c1483c4532bc21f2ed9b99b929b2800ddefc1a98d12ba085adc210bac
+e0274b69e24d16af015a51ca73edf779a7534a887aa780337ad966839881
+edc22ba72038aa1a96a6deba24ad676795da711b92f8cf5f54cb4322ec04
+40ef9e15b11e3005f3ff69376ecb29bb66e8fc1b685f2b05fb162fcb35aa
+d7eb2a8ec39b97ab1ff05ef02f8dbbc12085a5cd252cc4010fab7f63dfd5
+7fa1be86f724d37db5faef17ae8e8e537444e8e9db917b270344183473af
+7f47d5703a160d8ef1e772438620d3336b2fbcf6433612e4b5e64fae0329
+8a3c4010c17d93f13ba66d549c69dd58c7d26ddc90285fed831918563a16
+2a7ac2511e2f18c9eb3df905a9dcba65a31cc1c39f07458abb11b4c60346
+aea19070e126982f1dde336e79be0ecd69a8afbe2493d064d4d2ff38788b
+b3038125961302db9761403c3b8019ec641e107425002205a77ae2ae0f4f
+7550d623dd03f0ec0199f42a9a8b89514e2e21baca9b3c8c96ca48cbf9dc
+ee6d6241d713e014b49e83ad85e62a6b2f70b58e4cc72d41ea6fcbdd3b5c
+890c8af0d24200658773b1628c6cc9aaaabb08865ee4c7ff2c513ad7aa23
+155a321213fa94731683a3e282a0e60aa3c87aade3da231465bdd9097f2c
+89a1af8e5b9649143f2d9482546501ea97e8bea2f5d5eea97d4f19bb6835
+3138d3babb2461c08d537491aaede1f23d734c6f099eb5bef6e2ffaaf138
+e5ab71b8b41599091037e440127a4eaedf208c20c8a2fc62eadab191d1ab
+4d5531f826aa6b9fff2797a7f54673e0a3fae09a93a0dfafb8b11d60dc69
+5acf9b7e1a47c31d0b5a0b85b7b50cddff5ac831651d9c7469c2139c7a89
+7d2f868f36c65156921803eccfdbdd1618595ab6d2a9230ef523a1b5ee51
+f2a0d200fc0e94aff7f546593ff2a3eb865d129895af01b8ab6e4616fe20
+9123b6e2b7e0817adc3cdb78ae8b0b1d75f2986ebd8fb24c4de92ac9e8c3
+6afa520636bcad2e6a03d11c268d97fa578561f6e7523e042c4cc73a0eac
+7a841907450e83d8e7a8de4db5085f6e8b25dc85b59e018380f4b9523a7f
+02cbeec989f0221b7681ec427519062b429dcd8fc2e4f81173519f88e2e4
+3798b90a84060920f6ae789afd6a9182e7fec87cd2d4235d37a65c3f3bcc
+c742c89cbe5f3e2ba6c4f40ebba162e12569d20684cc167685285a087e7a
+0a995fe1939bf25c09553512ba2cf77ef21d2ef8da1c73ba6e5826f4099e
+27d8bc7b3545fc592b75228e70127c15a382774357457cd4586d80dc0bd6
+065aee32acfd5c0523303cece85a3dbf46853b917618c0330146f527c15b
+dbb9f6526964368b2b8593eed1551dad75659565d54c6a0a52da7a8e366f
+dd009ef853491c0fb995e19933cba1dbdc8902721c3ea6017ffdd5851cb8
+3c8bada46075ac121afe13a70e87529e40693157adcc999ed4657e017adf
+f7dbac4bc0d204f204c6f47b769aaf714f9ec1d25226f24d0a1b53e28ac5
+374ab99755852c1431b2486df5fd637e2005a25303345a1c95a15a1189ba
+f6f6883de1ad46d48427b137c2003d210ab2b2f5680f2633939f289d7553
+eb943adf8127f1c3ee7d6453b5566393700ad74ab86eb9a89f8b0380af55
+6b62f51b7dbd0c5dcc9a9fb658944d7ad5845d58dedc2d38200d0ef7cb0f
+76041dc104ef3ab89c1dc2f6a75635d48051c8a7dd9f5e60253a53957ec8
+9d1266566d7ed20d79dfc2807b397d7cf056bdaccdb72528a88aa4987682
+c909b2fe1e35a71c2f29e89a2bf32173967e79610367ce4574ba6a1cc031
+cfb176fc0313f74f91a866ef9954b95b29caf917a6b919586f54d23cb7ce
+23305886ae7760ebd6263df0d3c511ac7afc361df78bc2621f66d3268b99
+078fa59124f0eb9476496c938eb4584e87455dc6f2faa999e938460b31c6
+28021c652acfa12d4556aa4302bbcd043e60389480b796c3fc0b2e51b81e
+c2afa4a34335318a1c5a842dcaa120df414acba2e79ab5cc61c99e98108c
+5cb907a96b30d731131782f9df79aabfc16a20ace8852d047497982e11c8
+26321addf679de8a96a2d18743f6f2c3b2bc397370b10ad273fcfb76b48b
+9dad27cf89ca2c370149cd48ab956e9bbce01cbf8e1f0c661b99cf19b36e
+87b6165dd85ae3f3674525e17d85971093e110520d17f2d6253611e35ec9
+e17000e48e2926454c1e8eb4098e0115b49536f2c33505eb5e574f7a414b
+e176398c5ddf6d846ea5ddf2a5e94c0422e0115c57a8c9e56bf8ba962c82
+698c96bd6138baaca7347e44352cc62df4eeba364954ad921a5a43280980
+264df4a7fb29d005423179f7bd1d98b4280d62ce23c927551f1ffc2b8f17
+0a9c23656c0c91b640cdcfdbd88089ffb28d3ac68bad25dbbed82c083696
+1f9f86a6183cc1061ffdb32279796569d05b31c946955402d0be1fb9f2bf
+304d1ad8e1e357be49e6e2ee67f7f1e7bc699d46a5f7853fe659ba2e1930
+0d3e3ea658b9862701dcab08fdd23bf1d751777f25efbe9e02d12b5612b3
+c3fc2275190346b94ec4024e4ade08e54d75c0b4c48f4956b9182e8ce997
+74b54da4a9318c099d89f1ce3b6803a95f48b9fb8b845372be25e54478e8
+49e4707ea03a36e134efa661e4e6250d89649ae074cfd9d6b9e2071c1099
+3b8a5a5ebc3e1cb228c97565aef7f254e3f90af8a3dd281c83792755719d
+c6a5b3bab4aa6be5afe9624050eee8dfb13b018f4088c932cd48ace38dfe
+b1b4218dba8f7fada6628076acf1b54db0c95d4fb12232f1fa9d1ba848f9
+fe80c65b75d6946c00fe78839142c5302707d9269b24565dbcc551aca060
+b4d0f99b961dd3cc795a982063ac42e9fc81fc98add42744a9f92e74b00d
+637ee4606ea2099b6c763493c3159f8e52a90dafca682010c0e92bc9038a
+10abb066c75c8d97f7ad6fb1a37136e52cf2093c4fa485fe12adad10e4d0
+83b78b023628ddc5326cbf8392516027a9f3de4945f93488e4a1997efd2a
+22c2c136dbac1bdb829e082beac48cdd06dcb17bacf09451c7b636bd49a8
+fc60cb1d2292250bea78e1dd276725ab4c526b66ddabf4e1b2bf0a2571df
+2490df70735f5da321fac74fe4fab54444e53dace9832cff38a70c58104a
+4f0c0545dcf7a1a9ecb54e0e32d6d8195d30b2c98a567741fcf325a4ddeb
+244a1a35676e246ddc835fac13b569f35f22ec93191eca3efbe17ff9a950
+d08f863710b2bbecec969068c498eb2338b68f3fc3f5447449fe4de2b065
+e068ecd9255d369b2bb6c4b0b7423774bed69294758aca2bdb1a8d5bf618
+d3fa09462f7838e8a79b7a53bebe6dacb0a1561eaa074bc6f069f6a06fb2
+c4a5cb13e2172bce9be659a82665da5cded73da84322bb16aa6e19ac1958
+7515cb5d2b65e65e803f76700ce5efd3df7fe4ed431fae0e8e286b1d5056
+a0d18df926b2be7a93c503ab903abd4788680a6201fdc299f2cb5d6a9b6e
+2048109c8d1fb633a54128938594b2cce86a7e0185e7d59e6536584039ec
+9e30ff7be6ddba9fdba82de7415fdc47de84d97afb1aa3ba495bd91dee9d
+f3b21ee1164987dd8510925087cd0919f1085cba6e4dd3c7384d26667f94
+ad7f736a60d8bd76dfaa4b53c23536fc309ff2317c48ee0107ff2ca4d1b3
+f78c5a27b901c931128bdb636094ef0cd543a5b62b7dbe10ed83aed5780c
+a16067a4a7e8b7c5bf8a8e822149bc1b5bcdabe13a7f6aa6eaeff24a42f4
+a58a2b70f545103540169137fda9abb589f734b6776cb50402d6123ce802
+10dce05e3697a98c9411cf60a02c278c91e03d540b936cd00c668960e357
+1aeaf4d94cfb496b259ec0d8fdba9199fb46634ff177bc8d310ea1314eef
+d46c927a981c58e88743ed4e07d80fe841edee812e3053412bf2e710146c
+b25dec8ea70c38bb1f6e4db3c2e8ba521963c1584eeb60ea1e9555058f13
+e98307c13cbd15c26b611f543149b1ddf88dd6296ae703f58daeb67f1b03
+ab5b24c72d5770cb9d8ed242c4faaad1dd940ada00e98ff3a61799d13355
+aba916910aa9a6e5ee8af438d0ba8235346fcd139b9d2cb7db7bd3f298a3
+94ff0aff3b9042f32a004e042c346a5ea35917f229848a9c5a32909b0090
+4aa715640277a6ada99f8b2927fda22899ff1347f42bac73e2bd4bbf3945
+55fd7dd30d5c6dadf5c259fdb2455d8c607de1c5da588e20159f18e4e8da
+b714e532d888a0386c52c2b85964251af003ac9d10c0c8b9b3465e1dde48
+2e74a29e17a7cf6c9a43b5af1646f0b8508f98e9a1279ec3908073d89dcb
+aa093e8dd1004c1ecccce0803095b0069d4be7a1eb14b02efc37d137dfe3
+f0190bc9628069abc257f45d0e050e60c7f5281277937dd986fcd5b94a2b
+845a1a75addd74a142800f18ef408c08a2c2ad16a93298f148c0ae7d2990
+ded147f92f053809a60d4f992a227167aad5b5eb2bbe8a4a77dc77a08b72
+6acb34422e2532eec7e274e4a42d71ee584f5f3df5a3a5b379974ede73ab
+5f1b0a2dbfcc8cfac4747ca26eb6030dc2f85a104b754432977850c093b9
+97ed90af711b544ff682e7b1eac82b2b7b44014b09c17ecf084c994a095d
+9eeef5391305caf093b62ac9916f982a436d521fcf4d75c5b8e4d92266fd
+e99a58aa39d7693ecd1796b8851761d64bbca39a6d5a0b4533ae47123327
+f98d0ad0e8b36625cc3647b55459552906d8a1d5766845ffac101980efcf
+79657e365510be5db557cefef21193ca3cf3dad175ee2e7ae91d174fdc06
+2ff5c51ffe2f021122e96df042019d3a1883e662537ec1b69c11fbb6e750
+0132eabf5803c816153ecbff60ca3b3b39708c26cb1751afb2e65d8e5f4a
+c4397a88fb1f112672fcdd24e4ba545c5b2a7968c17b62f8e2530a8acbff
+cfca82c64b7abcab84e2c4a0a7ced67b15669301fe9ff2c756e70ff7ce33
+497be6acc4ac5617e1f043bd8a87416299a39bf17fc31c02d72d75fdc2a1
+e60669fa4d5e4a49d9afea2f53f4626680e9c0dfca223529efa415c4343a
+b6067aa800c484457ea050eaaa5d3fafeedd0eec72f327e02c6b3912b5a8
+c404de4839c9c4a99da42681cde43316606a34c7d2f02269de1aab776857
+e668f35946af4d618d36d444bdc02b1f63ea25b6260b4fb606ac8575b5c9
+782a5de4037350d5753b1537537ccb008c454eeb264e6cd4727c999e240e
+0ac89e95a896b67d54910a3531345f64198ad394b5ceb52881f1dd9e6beb
+95862dc188d45b3e46aacb5fe40097947dab9bc3c1ee46bfc9b1b3ed6167
+efd0d65ceb043d7b24c1456676e4baa47b1209a315f199bb3a91f4374cd9
+cc0b40d3f09f19f8dd8a46915eee55eeeeb3c7b8f437106ee491ef0f4ff9
+2c5c6f779e0fbe7bd5293964bb645ca362b106abeb773571d9ae83b786a3
+d5a4ea3ea970daadc46cc5e6037f76fd20e0fffc47cf4e7af9522b91f96b
+3297720fd45d9bc2200622ad2ca9445556c8a8202b1991bc63da360d021d
+55be2528e043f803e08da99b91ab9cfc5e65b2655d78206b4aecd445a7b0
+1caa0d06b0a55e8f04b70b60b04a860c8e1ab439f4910051e3f7441b47c7
+8aa3ab8519f181a9e833f3242fa58d02ed76bf0031f71f9def8484ecced8
+b6e41aca56176b6b32a2443d12492c8a0f5ba8a3e227219dfd1dd23fcb48
+fcfd255dbbf3e198874e607399db8d8498e719f00e9ed8bdd96c88817606
+357a0063c23854e64ad4e59ddd5060845b2c4cddd00c40081458f8ee02c7
+303c11747bd104440046bf2d09794fca2c4beb23ed1b66d9ccb9a4dd57ad
+a24943461ecc00704c916bdc621bfddb17913dfb0f3513b65f3ab015786a
+caa51ee9546bc8ddf87e2e104137e35ddf8f8d23724e9a53824169bc7cfa
+99562656e6f1c888d4dbff0b269c5d1e733e5f212d91297610201eb43249
+35e336dd0052738db2d64f3e89429903bb5c1810009cf766e9a06223dd2f
+219b706394a121dc029af55c6ada9052af59682ef7c51e121cf16f0319ac
+0aa9512ef900c548d673fe361da19052808797e958209072e145d46ec8cc
+a89fafd76630eff30ae979973bdf0f8c9e469d8edd3b1c93731c72f976b7
+d81142bc15c376403f967affaa5f482efd57c6f91970729d16db851f0ed3
+ea7d82f409307b5b436886c1beda94a1fa3ab1b60686f6574c844fb2c0b3
+a07174dc4f27b4fed2f8bd4d5436be4b343e5efdf0400d235bd910255341
+a20770804a26f8437e9bce6da8e9f8258a343c7aee291f1510be306ae67a
+ab1d7696453530c02fd153bbe49dbf62baad6146029cbd1656cdb76c952c
+b93edfee76fe33832930be59636bb947e8ad285f20f663cccf484fba97d6
+7446c7b6c6f5857428bb1737d9ae801df75d9cb4d7bd59ef7a4cbadde928
+38f15d232005585d2e40483d2d3e08cc8f398bb43afedb84343c3ba3835d
+0ba82a86dce859cf655f85e63e41365e0dbefcf511b9a27a2b6e66b2ad3a
+c657902842287a317e46ceaa93b5088f09d53a65815b44538af90ad3b06b
+4e5e2dc509f02e30a01e05201c67d4d39582bbe64e20b669f5fd787909a3
+30fc50a95b31426bbb57a4fbf9feacdc31f98bcf50da7e50c2bfc169c6fd
+ccf213cdb878653bcea372968ea6e31fd30dd55434cc91c0af22179ce669
+a05493f195e12432c6173ae2ac3c94fb83f38210014a9f969ea2b44e99f5
+e5a7317e848d429ad62167a4fc5001149676c0c28cdf59b8d1c5a582f516
+3eee855312777fee6dacbf993f5c058f355dbde6552dc960d336eee445dd
+11d53fd21b745d1e5ec317efbbef25e070d0a36797a6081c356ac2328e64
+e5c55fbc81dc75d9c1575548ece74b8307eef485aa8e28859a2e0435c831
+23a600efb323c362fe9f02407a5411c41a69566cd50add324b63ab939980
+b9d7a929ae4887163cfa7acbfc9fabaab8987a1f6906b9881491cd055b94
+485c968479dbb05b34ed0cd6844729a692978c6928c3392e33e8324ded88
+814cacdac8128e1425c0091a13558100d7cdbed5992795d94d39c32f32dc
+621ab6f3b75187a66741f61d6a9c91d791b1cfc3d0e94d4a76302e0c3f2e
+cbdc51f14f3251aa5c8bb989f0e13ee500b7b7f2f1e52ca970ad8a7b4b99
+57e93126254297380d67179deb8ff1e99d5cdf7a35c5bb9fa7b402e63234
+78640344e1f10c378ad23c5cd1aa18e1e0b308db70d3a624a455f8e291a2
+ee102ad10776208c2d546cb76d89ca8103a8b95f8acc2d2bdc9791324915
+6c9e05429091071f0c5b76d82c8d1c8a69d840fd460922cd2090624bc218
+0c9391005926a25042a55e322060807363462e1cdeab309033124ba3a884
+1db13f39edae04ec52cde9dbde64ddda1ad805141d4230ec76bd81fd98d7
+0d90fa1aaa26ea551bf687ddd6cdcf3de5a446b266c68434f07d9c0b382d
+5816c4e22f22cc03ff78064c6dffb12315c6bcbbf5dc510f5aaabf23471a
+234efceeb4aa2f9af9ea787c014c5587ef162fc5b35e8f4c23b168c6e247
+41d33dcc11d2a56d3ba9d8eed6e79aebf9f0faf1a3aeb89d792d69041f0b
+b8fadfc0aa090effc6ae5e2f13cdbf54b5bed69b039eef2627769613b6f1
+aefe9b66747fe8feaf7455796740f411a770d4a1764f0483719584880f45
+430e38d3af184145892a08b2add234a3f3ee4ccfc9f6995c02392adafccd
+722f366d748cfe9373fbf5f878ed47e9d221fd156bb28369df9e7d2b79da
+76120d135ebaf36cff93beb7e313c2b2de7477176fc19609a1b906c995cd
+defef08899265b6b8aefb44da1aadefd1c523dce5ca1b84c0c652b3009fd
+057789892d4d31764f181754b2e0a62c465587585509989a219711a5e4e2
+5b3b340ca8fdd3f04fef204b1b722b2f6c2ccb00c3cf1a94ba9bdfbfeda9
+e2a062c6f1ced3b8aae5dae32ade1fca1001f98d0ad0e8b36625cc3647b5
+5459552906d8a788eb8bc734ccb65fe9582c71df94fd95d22c5323de235c
+28220fb9a2ccb37362174d8cd5922c9e5a87b51d0668555100a33e33750e
+f1f795cbed962494a994be7ce8cf71fc58ff4204551b1615ed27cf088171
+fd000b72462b67935961e7c6c3a05bfd67b9ba094ea2c16fdf486da912e1
+e97bfd1c17934535e551cede20c001b5d2adb2be4cbad7d6ba0bdeae4b1a
+a739f90293e67ecbdeea4d35825e092697fb05b215083e3f3d6be260790e
+2a175fd44eb1c4c16759504827a6eb58a838c4d65fec6eef108495577019
+15740cac164111892e8d1cc447cd208e243a89ab847d8ebf4fb98bff49e7
+a3453facf3b0e8cb67590f390173ddba68324531d2e426aed152e12301d7
+538c1f3c0048a9cc00c009a1a9138460082123209c1e007266fbf236eb72
+21f87d4ca38a0b699e84ca230ffb5095f90a6528bf2a9118f95ac9ab8d2d
+ed9eed9b8b27be894b717469758c8d94fa89acc64f530f432d0e5f16c922
+36d6a63410f099c9e909450fd731d698ef658d8ffc1de14817b850814f68
+1a4a9be5cc7a71c381974c249f0b209bfdc2e97f9540c96f57bb4d283622
+00969b82011315289e6a025b137030a0af3b4b42b00fed7cec49df43c59e
+3b2495a036dd1b17a8e6adae63bfbbd48807c44b5bbf71813355e1b0e58e
+22b6fb88005fc55565be49c17244901b73ef02fc4eb7669be5af22d89c0d
+dff0fc6821d810d13e5821d48d4a71d7e463d5b60bc279d0dcf5f8da3a95
+905b56d6f2be95e6d4243b1048e3b662e62401ffaa3bc3f5f90b0854b8a3
+8c38039f61fcb359b06bbb7d59e3b39a295dccd6db9a8b83a6f64ef8dc94
+a77123dd164cfd1c46f1ee51aa19c3d6e7db92a298d10159f2b5eff2caf9
+dc93a6d267fb65bd900d6adf0c6be598050b6d3a9b3a322ab3c9e880d774
+1f58016ff97e5f606b5dbd72ba99252c669209bb556dd5be84fdd7c1ce92
+8a3b3d3aab8d37e6b740227563bb4d60f6bb04052356e1a48d2079feca44
+7ea17fd06f208426d045dee660d1d6460455f8d20dbc5ae64550bbdf60d7
+27d96cc9afef842a8c8c78ea2257e6c6d0d207c80cfe399e8874c693274e
+d2c2022d303ca50a70624b07434fb85040a76a823f446c7454dab4f9c05f
+10274eb5ba164aa3649d1bc90694316ba5cb3e7df4442e777124cff7ebef
+53df2320a0c441ab61666493cb43da46d5711c21699de85bc74359444da2
+e3e397d4c16234f81531505b621aa242a6698886f82b447104b1f1062f60
+b5c87cea9151bb3c627bfa4532b06fd147c556ed8d61ae30a8719dfb8705
+f8a6c74368381403640cc57026d3790c49e2bbd1c0e48285ec6ba44de678
+e3a1394d659c412f09644b83ee1a333a1f51ad8deb4e6d77b3b226ac2c4f
+fe653411a7976ae7c4a3cb7df309788da6b483f8a7bab4a6990db74362f5
+bc41d545a320389b2599fd726e426ed9fa2916ece67b058f6a269544e517
+128bda38d117f402409d0d8f8c88ed509aa2ba882e0c579b45af4be80770
+22d7269684eaf0f9afc3054316da6611e3fd260d67fb6fe52c9ade5dda24
+a0050a819ed21342aac9d25194778beb3145f56a66980f620998923521ea
+3f957b6ed0c5470734af9f416a16427dd03eff9a0e023452097d4ef936d5
+49a90823cef6de340a1ee02a52851b310cbcf41ae274947a62f9d1d8702a
+669023e3caf967204a340694b45fecbda4bf9552f6bdc62d43b3b2c3d571
+9983c182453e22ee34241ab908e667115f7988174684cd70084aefc55caa
+f5352a88e9dac45d1ea0e032af61fe9a9118a3931b2050fc6db66ab96a39
+74353b597f34dfd9f72150de23285eda5e555a607d198c291965a7233715
+3f4946a57af0b440ff8567b01a6f46c6d32fea5f8bf57d89dccbab7da882
+ee6c9260e89443b1d7db099477492bd0468850df3db668d741123e7ebe3d
+c21748ab4c5cbeb5de33b8963aecafe76bba0c4f6ed8e8263a116ed85e58
+fb71ec4ab0071301be7c7d3afd5fa6ad46c0232807bb7fe129e44bfd16e9
+fd0c8bb5e7cdd86a78b5fb0669093c22eda9151d85b6f58a9c8ead3727c0
+09850bd31a8b4a873d0a506240bb2aeccb8dcb6369532f21d9b967aa8443
+fd6d77cb2d65c4678a5fad188db85940f0a187aa1031dcf5b8e0d0cbfb6d
+b3b96fedec5b249b7a69de9b42dfa605bd622de7a220cce9b66e9f3394d6
+13487dc5e82c1e619079cd057b1e19ac05ebdfd7c8bf01c6c66fab49e0b6
+613df9e42beae2f7b9407a2bff8896d8035cea0fd5c11bc5889cb3d90876
+61766138d2625f42d0244adca65d1bc73989328c0eea0b97c7c766285ab3
+351ce2b183f774488a8806c33178090a3808f0ce5e339b87cf7add933301
+ca486742831ca751f0626864ce13172829a8419af5c78794a0eaa17b5bcd
+fcb684f7d4bb7af15deb432e44dc7dedf56eb8bea08b46f1e8123a49a349
+a7cbccf833a528f5e22d2d463040e09b91e543a2f33077b3e7b9ecc64f14
+306186cdae1fc317a6ced7e9b4d51a10bbbcf2fadff876b4d9082e3f4aef
+dfef230e4232572f4fa33a6e065f6895aa2ea96c5659cb579b023179f0fe
+de7ba64bbd9362a7b2b8c4eaec254915629e81d01c839096339b99bc9e25
+84536955feaa52fa20666f65bafd9b2e69c3e8c15d24fa407e7d881679b1
+789a0e2a695d13553c92c0214c9b7562cd6a9a3d77c8b0c2196cef76dc51
+d855c1dac37f96eae4cc7bf07e17dc7c08333d7af33c8b2965ea1f23446b
+3c96c52b30ea628ad572694d145b58a606f90b278290297aa372cff56b6f
+56f4aad6612eb7c7bd07db4f7d1a70d8044d16d0b5c1605ee02a852ffdb4
+450147b3f9b87d72dc431b34fcdc899462dcc1b6bb6ab1758b6a589e91e5
+8f5196251d00133b43749b7a11fb67a22664c5e38e336dbdeb5509c2d9d6
+2642c07275949df0e2db59314ae0fb34641fc171d3fe1289f919136d853c
+d9048ee9db50c699c49e27a8df199590bbc65b23b55bb387eed0c73f2db5
+1cb091f8c22af83103f214199e371f7de1df23f757817200be30610004df
+81fe8ed6eba79e856fca21a126ca326ad2f313c16e15754663ad6a065e08
+4050ff005fc899d6e233691b918a093b5f1ffda8839ab23ae66b1bb7b953
+0a7f896ec55de6fb9faf1b49656ff2e57488cd7f1c44114c75f9d571461f
+767a6040ffa14e9fb43096f164d60ca530d7cca76d526d1999ac1b52a793
+28651112a65db1f2564ecf90ea6bf2c9ecf515640719c3fb5e36cfc58591
+e227793f39b9d3a9025cb10f324a95c29c488724aa74812366ff0b118fc7
+19f9fd0f202a040be47ec99b46b4dfc3d2a17902a5779c8d52b27231a1bb
+5cd794c838daddc3e6824ca8297ba669a818c239b389400faf17aa04b802
+f763029edb9784dfdc42f223e6496a938e613463bf9bbbd59d63300a9ad7
+4e71865cac4b4e81a5864388c3886e70799c8989188341f7d17cb514cd99
+3b211883f171ec6402cc361885f4f4b110757bb3e52941a94bfaebb2faa0
+3e32eb72e25e31abdde82c2a9015478afa0f434ae3f8b97a4bef598d6eda
+44ffe1915c26ee0e8339d2d45a6a080550f538ded5542c8b96ca2f596979
+8bb6223e460e857516ab5a3323136ee8fc4b0556a7c39d0cf7acb45e48be
+4ae9db325e4750b73289e36a61b301795bdb2ca2a8b933be1c09fd0cd2cb
+8677df171d36ef1519a2269b21e4103b2ee151c513df3e10b2a216d6fb22
+18bf2005fa7e0f0563ad96661a7f55e1b5b991f8ca285651b2683c6a7c9d
+2d1941374989b06f2e9b42a6af60193dc758dd8e9fcfc7c1aa06eab47e81
+bd79660666defac0c6b9e484df9c17a61ce7a61ef73150e8cd406af6da17
+4d9c2392cc420eddda40f975ffbeacad8ce1b4e14bee29ba8552ff03376f
+c034784b38dc1d0ab7bc53943d2545b03d39797af8d58d6dffce56a353d9
+bebc833f04db321ca8642bbb7fcc63ed2349ffa08a33a5d0d78f4fd2c5ea
+4258e4671e362036f1f67fcef9d878ae2c203fd9c05200c59cc98633e65a
+99d912ec51d6f74500d5358b70e799a6817f59adfc43365d7bba1fd6766c
+5c8e76248daf3f01e7a8950fe875d657397797a45e7f99a92887300b6806
+b86db61e03c4c09d6cf507800aeead874a94e6f665746752937214302045
+0b19cfa8db69230517183a03a16e5503882ea1e419c333d3e3b73cef6762
+873ac06bec34c3f736494483442619f5bbadd86f128a5a40b854051893ea
+8d31dd6656777ad4ac2572d17c6fb21385b053495d1270e65d78334a4115
+2787ea89b86f97e72718905a11e9c5664837701a3c1c65ccaf26aebe8dab
+c1207d5da2079c37883d9235708f370203b3b2a8ec3a5bb35fab93dae115
+aef626dc44b67ca56fac18caf1c22e6fbab93564829a75776630b9c42513
+721ca0fbb0b402f4d1db8f701d2b29fa60162feaa8a167eb3113c6f57036
+e8361357913eb24dd38dc6d3bf4c3176a07ffc75cecf8e5940a310f79a8e
+f590844383d631796ade04a91144d073a9413cff34fb454f1fd75cfbe5e6
+525c3bd36ddab80138f6c19aad7417d47df1f1e0fc958fb190a8205b5321
+7c43a4dcb0599be404473d6faebe7240dc402a0e0caa21b56a601b154524
+f44988e5074c71ae8e1948bb2a2ce72fc24cf3b1813cf7408a6b097aff22
+f9d285134d09b7053464259531eb7b270cd5f39f81bbf41a36420f61e5f6
+b429036bbf20e27af1a437becd74c5bbc25ee2519402454fc94d430636e1
+736fe65a643d9b9d21c9a54eac5a8fed51ff60a47b85a0e9423e330e00cf
+220c23e056d20aec2fca3e6bc7a61a8366eb940c9bc99fb90e8704e27655
+20335a983eccc7e20b13745c4b4f30a842f1ba64745718c152697c688c73
+6cffcf5cc8eb5756201560413117a45ad3d264291cd51404f98448d31474
+d47d17d201def12867ba679f0e2605de8f3e8135ed0234890cffa68848f0
+6de427741b34c2ea654251ae8450a152538eb806ace3ecfe86d8c4a137ec
+c98c6d6cbdc191a5f8f5b5972c70b4896960037b6d4c7c63586a52d5eb59
+47af8c192eb980d0801fa670bb1d08740819f9da1dd9e153010bf9580a1d
+0925d8327ea1b88db8d934f40266ddf93e5ea137f267847d826cd7999b33
+c795d0ac05abe2ec1770dd98eea67912f1939118defc9b379e237d6477bc
+91ad08e0046b0836fafa1272b0213dce990c90815f5b30d0eb103ac9539c
+2f7bd2280264cd95b4be84cbc5139a7628ed211905dcb92cbc3180ac9e6b
+b9ecc3cb08608b2395827d5729781dea49d328ba0c1b4cf2cec9f6bbc822
+1f2bbbb9d88f9e7682b9ecc06b9705faa8a90a51678183db1e24cc2c4307
+e16b3c20f08f179ec69df7a8c4261427f5886f9179c493bf2d0ef36640d7
+79925585724aba69df6d1b4f0bd2a356eedfd74a88bea667b102420c2300
+ec420e99b9ce8be1472b617e1255a7f43a0b52f11657f1a4dbb624a24886
+9604fe2062b98f5787d010723e520a4f42a0c3943e151ee627f3d5db90e0
+7747e1a88a53c4784c8d2b042b9c23c9e436d7d88343171161a364cd8961
+37a19582a00d774ef01c7c3fc9e9c7be5074c858d2bacd707a6a4f322027
+137d6ca0421ed9f9c7e7229e867678e5272cfc7156a419e893404ad7dabf
+a5d8b6fd0787cb4fe1a901c34dd931f1b64f0c470ff807005fb66350d0ea
+eb84ebef2c2399cd14a4454ea5004bddd99988b39c4134b92121ec77faee
+55cc716eecc58b594b39c41dcab308efa4458ed71943ec5805dcd0194ddc
+1ba04a5d3d42d07ac62a907ea25cd2a7e77aba470324d41dc1a3fe088388
+787b3312f472cb4f23a414fa5f7c7a0cc5d121d7642b5b3f0cf7ca2173af
+3f878f374938251feb3ce5ddd2d7703fc79a130978ac516daf70ae903799
+28bea3a4296f48725d578d2e8fb0f932e398404fa8a242024bc011c0ae81
+7b92bb104712253a5d89c543a744332069e33ca08bd133211d233ef799f2
+fed6a20a9073021e505def8b79e1279dacc062cfd4dddc2e8e0a7fda5dd6
+bb5a745f99cccb7ec1df532308da3da0f236c74639c280ea649b2f7ec27d
+24221470b642567f3b2e1cd0b3ffa65c5ac986b557aa9b444bf470380435
+abae9b51c6da7ff753810ca7938d8a1c47d2b41fafd236cb5998f3ef365e
+1f700bb257679ba3a82e235a3e97a667a6ad94412839c96dcd49dd86ccbb
+6df8ad01756b311e9fd57ccd2eb2f19f035e214804e2b77769319a5389c2
+35f3ca2a73c616c9ef0984abcba167d7d652b330c68f4f6378aba69628b4
+2d59eaa2a7e4c782f6eb96f6758d17d35650b15cb5de9bf973b3b6f67c1d
+f3285be8322fc2b44359640a3ba5d6d7b96142583a00a9a0ef84fbf14046
+09ad55b2aefe8c5c8f58ed21623bf765f81dbb6cca6d2a51fb7730a14839
+392cad6b47f5e03448350ab36a37d9ff2b9dab69be5196511072b10cc91f
+2e6b5160b2b1bd112e6c02d14063a9bb46977b0d4bc79b921fd942f916c9
+c5708e0d133c8309de2f6ee0b1afc996c889c36de20fbbbfd32878f477cd
+7735c7c3fa59e9c46e654ea20b4381d9f6c6431082e6918d532bcd539284
+af0333a783c9e7fd4fa1e4da5ce8fea2ea4037644a24532d65fa5c1ee982
+89e4b9abaf71a35d308a9b8c337f70babc5fc8dbb0327143707ca5b675c5
+2d3cf09f7a4f667fcda03d8c82d157e661517787ce6bfb35ea772de13c66
+2bd24b74ff9ab0fbcf6635d8e06b54b5b3125d17ae13d175cb7922338ec8
+9d1159fea2110995ce48f7d2b094f06d11d59b3a64a44a83d48c78855e47
+21243e82d9858401b094a236fa0a90d61863931c30d13b9bf33a35ac0d11
+a999f2b4dfba6fc187f8c235a5217d777a5a97112e7db6a8a4b06b07d9c9
+f41820e233c8b58b9e47ac56ad1ddcc0b35dd03976bc776c6ac3692ec0ca
+f8c75ea7825bc84156468ca7b269d890ec9d4a365b0b31d2f6530185d5e0
+2acc3ce14eea55ebb5667067825a8682e135d23c78863d32065ddcf1a755
+e0de6dea7220d1a28416b96db40b1e9f159aeb070c9a9515f301f162b0cf
+e32c6c89287de6e2b40458e3393826189a10af8517ff5a10c41c9d05d999
+aa9305a2ee8e7fe46076bc9c5722ee0a140a144ae383e84a8abe70af5d29
+96a0a896cd499caa0ed7867e7c3aac563763216e7769d12218b584d853ec
+01db93ca22d0c8d6b286b20b6b26d6ef19f2cebe7030ecaa68d069fac7a0
+09d61770b5e8f83024a99142f59d88297cb8d093992c3c6c11b043b151e8
+20df640407d8bc829bfc196bf2901e63c6f16102d03ffb7c54a7a560f5f9
+5cf8379f4a2eccdcb604bd553e6157b4381940d1b3c768dbfbf2618812f5
+7fbe744b3d8ad680dd9223d8bf2412ecbb614d05b485e3b4669d22b417f5
+02cce2d705c208b15fa83b5be77ccfc1c840f385a58ae49fbe6ab4e53912
+473630e0cfecefab95ebc632a2b10a2103bfe801ca0302542080cfb4cf4d
+4c241b1a6c8d28114516e3f1bf39dc02db73e6d9a797279acfd79b02a71b
+ae34860dd0e11b18954129f8dd57c039bb7063a4c92f0f6a1e25f4ae59d6
+6c1cc6b73a79d6a56f7f2a8a64d571caa8a760f4f485d770d000ddf393ba
+784bb27b781c47678dd78ae9b5d5e8b57d163c42c7a55e4aae22061686bf
+aebcede728ff2f65e75955585208c176d100912836b5200a79062d4f09b1
+ba9465b0e937e289160ec543a4cedbbe0cdb5ecfbb4838138ee9e1ac757d
+3c5f04fb6b510b389e2f521759e403bfc8ec6bd79e2d40bdd81901c10dd7
+4620acaac9108940daf03af23f09d3c8b785db562b05e597056406557857
+e96fc8bea53c2c2ccd0ea6572abb0acacfe29e737173d665ab6dc2995f60
+807aaa4073a183aed23c26c67eb137c937999fafc63b66a021125e4ee5c1
+a745ad1fff2bd828dcef392052965ce0e9af7a2c88d730fef69da91083fd
+83d9fe9f73d42a8dbdcaba85b0fa93b210dbf49cdcbf5d4b69e07375fab1
+a39038cc51f66f0b10eebe0cc61f697f7025d9755830b2d65f1ad0db91ef
+ebbfb578053de329935bb28d6ed6c12f748a2f70458990f04d56c35557e3
+8bc5d2e5de7f52bcf00c3bcce091aaa8852d53ac686f8f407baf3f7c8968
+69f3b62f44a5e2291aff9d30d7b5c663658a41add74562dbb0f1062f564a
+9b907846291700151de04c1a55cb945eaa2e7a709218ec56d1becce1c0b7
+dc41d5f016ae8080c3b07311590a0def35337fc3c844c0ccd04926be9fec
+509b1255ef12f368d20601b1ac8c68b0a935f987a21de0f8191604e921ea
+0c04b00dc188fd73499852dbcccd4119ef799472b353be7f7dcc904ddfdb
+920839f3d4a13bb1796f2dc886f31217845f8d7a543aabbc720311fd0e6d
+a31ad3daa06d5e7e6270a34304f35ef170a7abe733428e96b0522fddbb5d
+eb35aacec147067fe066c9ef145246fa3d444d176c274b91fddb8a7bd7ff
+7cc7693c25895bf931eb321dc9d79f662a17691f9bd1662fecbcecf6d1f9
+cd8ddcda56d19811f05fa48bcb492feb355b0ec7c04d6046549c56f7799c
+2cd0d9dade8809de7d510702e525ad9cc82c41b4fb36218e3d72e905c507
+159076a9c0e4a008ccca17bd594c69f5eee656426f865fc1988d677b72ce
+b710b29a0aa8f8337552ae30e93bf7c6e5d013555872dba4737dc5f08c0f
+efd428c66fc8da675373f13f89102688977e18e14dedd7f3b676256b0263
+b66b013617d9a026794b0d6040c23c5506a98530249633a6beec46117c96
+ec036eaf6439e25b8e57754af5ebaaf9b57880ad4fc93f002fb03e9fda21
+df4acb78296b0c49a5a852c134c3b10755177a0dbd6c54ea7a2b9bdac62b
+5d7f3da649df856478e4baf97899e0f891a96536c283f5c81200c51c6ab6
+77285450c7f7e96836b6da5660f6cb76782ddfc64b6fc348ebc3ba4a46f7
+19176296d8c5a31132b3fa7d935a5d777c1dc84d669d564cb4fd689a38ce
+680d0b3b130caea0be43864826d0d154019fd0d865f1c389cd367cb5248e
+24640eb6f66603e50581f6fb5aca6cfec1d6dbf4196da10a5e1ebb14e4ca
+0251c4c8412cc1673d6e7a9666b04b090567efa0b830d2362fd384cb0303
+8a40290597bdaffe429bb89fb66b9dfcfa92f39d92a8baba7266d144ac04
+f069093ebb3fcea961ba4497d3628ad207e0c8c4fac0e5f3f2a663a8d05d
+b6dc33b890ae13d84dce64b495d24cc749b121659373ca31cee09bff2e9e
+e5b62e89d5faa4482a75f341dd172500a54b98fc108a69a3ea94db696513
+d4c7691e0095ed3900cd4489ab008b5460b34ae8dedf3721c60de7086605
+6c391137cf23255c565bf11403bdeecf8bf39ad5e4317a4bb37003b2e7c1
+400c3b8ed7f63719bddf07908dc2decdb0f68e8ef722851c4420303f6de1
+b5efc9b2598732fd1f2cbe45a504bd7fbfdafeade3add7274a1e875aba3c
+4e0abfc6444944b79f95b5009560818f7a0599e5bab4405378fadfe084f1
+653e5a0166714047e8bd4e4cb116596d8089bae9147ec1d62cd94491af75
+a1743d58bafa11b63b447c954a8d7fe11d39d969feac8fa93c614f97807d
+ac62cb7a84a974a0fa555a2e3f0ef662706efcb828ef72e2ea83b29e212d
+f89ffecabcb08dbb7119203c4c5db823bf4e8b698b763fbd4d21e57940d9
+1754959d21f3f649d856ac6615eac692ebcbac555f772eb6ba3cece5ebfb
+cfcc2f3d8dcad7edc697df93aef762cd47cc3ba9e2cdd10940be676efe7a
+a3749170edb47b7562805e3f8bd978b18057c9110ff8d19b466ea238af32
+993e2d3021745b238021f824d887d2e01a7ff12fc6f084b35292f4864579
+406c0f61d0ac7cdf7e4770b424e2ccc22353e6c82bf8ff172973df267ded
+bdaabc2a742beea02e35b9b253f98de9ca131f802deee2905ca1a6dc4608
+19a59b4a4265c723007d0215fc8ac2a91ec5f86cd6aac1e370a297103c3a
+3cff58c7ae201cbaaa8a12c93e95e73974f9abcd678451b1db02ebb2e10c
+c5abfa573a2ea4219fd1851765649318bb556b728d432ec05a86e9894aad
+9cdca63d08642655801bb37f28b6e11b958e8e800c8d521ca4aa045fe9ab
+ac02dc015d18b1901d519181ef60227170a07f3328a6d5fe4c5aedb35fc1
+3dbe86564a9b1dd4c7ec648880360cdd1742ed4ac409450f1d9681cb5e46
+5edd1de2a2c7f8ed63436f98e849504ae71bb872683ae107ad5df3ca0b47
+a5b79513e02d7c540257d465ae4521cb3449d79c931e2ce8c5b0a0a4ac88
+cef7b9e5f92bf721ad51682d6b6f6c14747f78eaac1891fe29aed4eaf177
+e3d2fc655ae889c0c30a3575a76c52e95db2f6a4d8ffee9518391954b92d
+39dae4e97c4022031f8ab390b66ada6dc9ab2de4d1dddf26ac4032981a69
+08f73d34b4849ae28832cddc0dcd116a47d9262b0f93c24fbfdf8a78e6ae
+ae3357f3fb89530854257a9db773a1acf5271fc4ca04a06b46dbe661ca11
+9f45e0080cd129e1a7c23a33f1c48af960761b117d9d91fa5a0ed3e47865
+b774a322f7dddfda2960b91fa7ba20c8f9eb213251299ae328b28ef54b0f
+55fd54f8047c555e4045cbd70964e1c953e471408e4f25fe8ca7009bfe44
+0244b1e30dff518ea7ce5078027baba4e07ecf0ebecb497b4bd88f1ff72e
+b261f6dffec0ed895e237b5608d31ef479e8c9ae9003039a5fe67252ee39
+774e1501100c0fcf154f5c5c81c70539e03118ab91f4ce247f6132d46346
+bbbb126c09d7459c1977e6e367a0c83d14edf7dea081e5f795a7c831fd1b
+325b33674ec9c2b68029a0e600746329ea2e1b9bdd5cb2b140468e53c108
+8e8f2567425443f8146ec37101fa4dfccb0e032fff6cdfd76382463551b1
+ae8ca6cbff0e34a3f75ad400a9573217f8cbb00a6d59ff46e48421e97091
+cb17f53f20ebeb89609ea55ed6ba4101f2f3ceccbc7ade21202439ef91d8
+a9a783c22de7e6601b50c4342e094d0eff223494489fa92150425da1b432
+908423fb3f41e0b115ec1ba592a4f920d15610b9fb33f9912aba67912d05
+1ee00a13282c1909a3a56c4ed06f2f4d1739dc296b7492aad0446f87a416
+c6db4d42b504dec3a6756f3d0845ab2d2e151aa5fde12b31a9c3b5ae1cc9
+d97192bc048f00dead66940004281c4d5a92c20b1f77795cb4f98b8eaa7c
+be16f9b9d4a34a1a53e0a0deadb4fb4b20d9e8064d3412ea8d2ebd259b8f
+2f04bf4bf11a5ab7883c99943d762549c3d5866bb6ed85a0e862eafbcfc7
+03bf4b77cecc0d65bce4df33e0d65456397f231f8cbf66672457cf539817
+6aa5292fae24695009e55904a04588659a3a23fa11989b925705ab45f954
+6f862b0e176fddf75b70d9ef7389f750becbffae25d58a1252cc04a79e13
+fbb6a666fd87cec5562c3e14fd78ad05be28ff3871d6fceff5aa8965bb65
+67ec76d105a6348e915b27767f5010011e80e0e2f9c34742a4eeba369e66
+8faf086a45ac9bcdd76c758db01a78602412a4244c759ece0b963d9ea58b
+0efbf4376bf115288803a54cfcf78584c8af80da2a3324096463e3898285
+57de6c6354444b12a74d5e66053f6907c48522cae9e93bccdb4632131add
+52eb374213888125de71994c31dba481b70b2e4c1f10b865d58ef09fc9dd
+2ca7f69bd2855895256caa5dd6bf7d4d8b341d677c56ca08fd7ba37485b1
+444af8be0dcdb233a512088936ab4d7fc8c03139df396b7408747b142782
+d9406db0dcd31368d2f23ddef61b0da3c0704e9049ccf7f904548c3ca963
+76eadf1ccf77f94c157f5b84f74b0c43466134876a90c5fdc2c53af70c3f
+f5c2d13cb665fed9016454bac1a629361c8ea62f4b2399233e8587db6e75
+a9cde3530f20a68ec155d275a4aa6f63aa5cd115244643b54911c954feca
+d57be2a6c40f1bac38e393969617b066f7d94e8b18dd80fccd0168d4a385
+f2f1489d1dd41b68d47e5ec66ec568333d1f584e3dca90f1367a990630d0
+14355be7dc45378aa111c319838edd441f15e125f928e044640f25ffdcc5
+c116c3f6ce0d4d3195187b22200808366eca9b508ec45e664e562186efec
+a97b22835d384758849605a01973cd9ffc1657b124950c9d9fa3e18b1a20
+7156c4f96f08b87824373c2865845d17a0dda71b1d69f5331c5676d0648b
+ca80a7958a2aa034d7e1e9fafead9248e6e64f9ec327c60ae4f724e1fb95
+8a71e82ac3842768b27b506b5982311557432dc3f270ae6eab23a42fef70
+dd0d407a02cbadeb7b8b74a2523cf46a5f61e52b053c2007f75ae053a96d
+e00646662d027d93f950e516cddff40501c76cd0d7cf76c66b7bcd1998d2
+7a19f52635c8e27511324aabbb641dd524d11d48a946937b7fa0d89a5dbc
+4b582d921811b3fd84c2a432dacb67d684a77ac08845e078e2417c7d9e08
+bd555c5265024aeb55fef4579b46f8c5e79770432c5349d5a65a47ce9338
+e1b599328bb1dff2a838f732852f3debf4bb9b828f9274d03d7cf813b123
+687c5e78a26310d87870bfcb0a76bf32aa20e46f6b2826912e562f503aed
+11e427b7765cd2a68da2ec0609259ff14f57c07963d075e96f8bd2eab9a0
+dc32714dd8905f2627c6d6f33563436bda2d7fa9a976f88947b84c72f454
+bf0b66ca84470375d2ff252b4a2df52ab613d0c8ef0465ff1d809ca82025
+c2122a8f44c56ebfa25690bf6a05675ebb8634ddfd24c3734fe8cb32d6d6
+c69c72a4951cb959175770b4286d383e7a3f158450945c8a2ccf7e54fb19
+aa8d2d98a07f0c55f834f2728d89f82a598269750115a02287c4d415cdaa
+14e1d9e7032684002f90603c0108dd26b40fb569bb21cc63d0da7e9e1873
+9df0a9c85bc340d2b0940860d95571dc244628c59bab449f057e409e58ca
+cc3369f4baa8e53c6765a55620e78341dae06e5cdf2fa5e5ba58634b29ee
+ddfee7f78672e55f18a7debbc30862f278f83f4cc123ab591371f548fbf9
+bd24b3453b9b57051c2e67edff2104f3a05a9f0cb7efd81c1b1b0a2bbe95
+21854902526e5d4fa1b3be270811b972e8726623410cec7911c07f871428
+1caaead97c503714eaadb14ae5923f020093722df1b9d9c055d7d5f95af2
+a9fbc5ab6f6c2bd655f685534d7dc5fbb5ebded6ccdcf369bd83c644dc62
+84c2810495888e9d8f464a42228cdc231d5b561c6b210bc493fc1e7bfd66
+5a6c4055a6a629f571f4f05c15cb2104b4f9d0bd1b1f0ab8252da384eeae
+f5fd5c663ad7a2c29f65a48a30ed8de196f9eb8ea314c6e86989298146a5
+589f76f12664c8d008228b33144679d16ff564453b5e4e9f813191b6c99e
+2680e20a410949ac30691b1428a255b6185b7e3802e8511192e73c376f3d
+eb807ad2727fbb4b27538b3213da0746231b1c1b595a958466155835c537
+e0df4a0ef272d4c3f7f2ef011daed38bc58bb0fd7458e48060db98971bd4
+b24bc7bd0de92573a1c7a80a5fa2b34fbe50271dabeb83aaa4235cb7f63d
+6a6b399360df8b1235e4e9ab59698930044a98d5e083b5f5a5772309b390
+9e1ff2a252734b32fee3940f0e1ba61f54dd1d3f6ff0d57c9ae75a302d14
+b9dd9034279aaca80b6bd05c74bf3d968305a5046910871223a3ef8c77d8
+25d7e6d3d2809e76064c473d1cd7c05666040b6eba647e34588f49fd70a0
+3c937933a2272c938d2fd3aa8149f215bb48f3bb45090bcb9a6ace393a44
+f1a9bda2ad09a5f566b2e8887880afa45a603a63ffe7c188e3eae926a903
+4f1803368e773f42c7391dff1b9ce8599161515c549aca46aebae7db23ec
+8f09db0e0f590aab75e8eb890df354b37cd886bdc230369783a4f22ab51e
+0f623738681b0d3f0099c925b93bbb56411205d63f6c05647b3e460ab354
+1bf98c59f7f6c2ea8f29d8fe08df254d8a16aab686baf6856c4fed3ec96b
+0328738183dbc1eebb2a3d301b0390ed8bd128bd8e7801c89941485c3c86
+22b5f223cb07dca74f0e8643240044e8c376abbd8c82ff98c6dba9b6d244
+5b6cf4189d63c6acd6e45f07485a0fa55eff370da7e71c26469740a68627
+a3c297d2bf215121fb67815b7b9403aecca10d21e59fabcbe38f5ca66e7b
+551b22e28f2d1fd7303d15a42c45bf54b40ef7fc93060ae5164e54f91c55
+20bd303a98d0667a02a900813b260c0343021ac01872fd62cb6abebc7ad3
+a4456805159839ca4a3e35db586221169ded66f852e8974e3815d4d7659f
+6a9bb93585aaf264f06cb6da6a26e51683945224158ea69719b8e4e36eb1
+01333aac974db8f84b051724cf245fe7a4c86582b5dbb9a5d9318180e33b
+8d92c22c44b0d18f8ca34dfa4ee9693c1a26fedece01635fc5eac1fefa81
+32458254ad46dfdfd2be12a1e7f32f3728f286f1d5d4394424a073696b65
+e3c459aee9310752231fa703faf35e11796c4eeef698f4109ca8c46ee322
+5dc2e3e04fa787188e583321f8410b68b9624ff60679d3f25c13e5ea7506
+a3ce8d0bebb99d9a959ad92d8cf909988d9250b310629903d6bfcad4581a
+504b91b2c91889987f36d6fd0be1d0ee5aac00aa0cb48d78a1f7a64a777f
+089573ba79452efcc31c8258fb317369feb0d7ccd48cf13da6d1ccb59a4a
+48ea0b398e590c1169113fed81639e13e96aa268d99cfdb7aee977fbe85f
+f784853a06642b5521ae0a7f610c9739af31ba7a5157ebbbad999e23794a
+d2cf25af987dc85dfa29639957cf28e7f2b7671188045130a6e2785f8d8e
+30e91f0f68c1cc9f2de902952730003e816e4f5703db7a97b4c566f80547
+42fa77be563ef681a4513b9a68b2b0956551c74545cc9883428dfa72fd5c
+4eee93256b26bc86ea34f7427cb0c0cc22c0cc343f739c6c0c46d0923675
+5e04d70587426ef875f8c89ff8492ea23e4e4d763b84a6437a440e69eb70
+65ab6d8cf5f8444a844e6ef3d158b451d121daea2d0e2b423eea24254226
+7eff1b4224c4e80af2a7becac1649e4bbef09f39415e9b1e3750d7ac47a1
+068a4f5ce30840b00574eb4e683e3ec25f6e690feeb0d354568efbc354ba
+813ca1400734a67693af127b0f636d58b83e91548f98e3d87da7fd7cdebf
+f3ecb4b9272d1c83d4980170378d32f1d98b87c440881af9ec052510982a
+0c02ba6743bdc7691a44bae5e044c25304c1a2525cf2c0694494a2e9aa34
+f36af43ab288807ffa4bd418ad51d98c75f2b2f01abfd834d3305682b6b8
+62ef69d05962aac485bb4f560583a5dbb74e967eaf6d299160753ec32249
+bb1d9851d5441cb0c624208e69dc876cd8841a66976b5d7f9c99be68363b
+8112d33d971f2c4f2a1feca88ba1a794ddb725c5e2e2c248082231059aef
+729bb5fee5006ab8809f63e162fc0743c047c7984a9e6333b433fa143d73
+72d4a74fe37314508e04f54dc7a1445e2d6178ec9c041d0cd4fda5cae830
+4b16feb21f3222261c293a8b058dc708405c1a97ff34eee4ca69ff4e1ee2
+a03380d52297574e3aa50c8afb826fc94a14e8caa9ba89d6e92913be9e07
+bf7ae011e6bd142d8952d9c2304735e875d1ddcf82fa9fc0c6449df2acf0
+d5f6cff6d21ef6b2d29022ed79c4226c97f163284f2311cf34d5b0524a1a
+a446645b9d05554f8b49075075f0734b3d1ea31410759c174fcc7305d2c1
+d7128781043cba326251a3375784a506cf32d6a11a4876f85ffa2606fbdf
+27dd16d64b2108d808e33c409dd33f6e0c6079e47e7196016f261e824fba
+b0e4f91a189747053e648ad2d942ece8f582f052668b63a23a2fae4c75a5
+180db7811aac654270ec6e341126e3561429f1d41fe7ba3f1de9f8bbb8d9
+fc5cebdef869376a2e42dcaa578c0807835e58d75c39f91a83d5c1eb86a1
+b0f7aab991f65eef030f212d38d10b1913bff71717c06c78d9a1be136f21
+4be157ba11ba309326c55c23ae8512646751fb82ae200c06bd2e644bed38
+c7cee826cb587ee8ff378b7fdc00ec316bd4a9c24e2c250cb3d64f8ecbb8
+7f4d81626d7f1e4491908bf17c48c84bb1736693eb4d0fe634484cdd590f
+a40ae94d44f348ba683a43004b487f047745fcdfdee2e913328a11a99530
+9bd117e0e5be4fb25d176d59dc2b1842418141190ed9ae1f33e5354cacfd
+a5e4bc186119e1461bcd98517e675276ddf0296d3b3cef617dfa36b4759c
+944fd721e1bf63d45cea90b5817a40d153a2f779e03487cad3c1375425ac
+8cbabf7f754d16cabe45c65f1be4441908e0969d5a5111c931e724537dea
+7cd3fbfec9b2f7d3efa747bf586e9218c3106c49276b89fa28f770fa0644
+fe1f3fe3adf07f59c755a5b39a2ac1d6f23c256a293bf3b31b6b9cf4c622
+b188d6e7401c038657c78bfde9ba09f508f1bbe3ed79793772cfc928c4da
+519f7dbf3ff7074284437d2de8d7b7c78829642d924abacf353119e9088d
+14739935a23667c432806085c3af71ffb7c5fe6b4412b9b1044c1e62ee0a
+a5ce7e0322bc65a8c7d874270d84136526e52d0c7f9f93199c6bb7301216
+a19bebcef3c5633f21d012b448d367157ad928e21f8e471e46982bc46a7f
+df1bf816a86dc62657c4ebf286134b327ce363ab6a66634eaa2a42e99034
+069fe1302febf06959eab8e7304da4d94a83ac1650a02c38c1c4b7e65c43
+e3a6fb0213e57ac49e58721a4f36996069caedefeb48f1a59303459d5873
+f3bedcdb9d00c1cf31130c27b60928f210e1aa5e1c8e04b86d2049f31265
+9198fa646c53afa9058eb8ceb41bda65f415c79ac92af5790b176de1d300
+f1c06b782d584f458dbd07d32c427d894f84215a8e7819e295ee98d976d5
+644f11920ff2f49cb1075c3bb42b9fe4b561362902f11a75669b7e7c4475
+b65f1ae48834cd67816eb63b58cda2f50bc22eeb0cc965569b476bedded1
+2701668f609393659b266bb0e37bb27afc90bca271366e34754383363592
+0f9a3b508aabfe8deef585b07a992460c592a150b325b1e50e4214a2f483
+e9dfc826c54b488493a96eaa37276f5a9666f0a5388fe388263d2c0cf614
+c6cd01571da4389f01fcdbd0ade1c435d64c5921b5bf7dbebd5268100a03
+1e1abb8cbd83873089a9e08cf80276c7e30d2bb40280278c29fa818eb079
+87623b1cfe13e0b01e27be0a8320b69b5afee820f4705202158b7f3059b3
+655bc28a754d088fde23d43d6a9389da8bc1cf3e8ea1a6f4328c196e655e
+42184444d8c0614c7167c91a492c24c8357794c61f5e47cdaf4b38004a5c
+8fceaa8151e929328bce1b8f67b22034f3f75e4d105283337c3d460e7d99
+89920c43f5e1449c74ad6ab5ea029cc6e497ea60068451c4ef2132fb87ae
+049077a156c868b768df4a4c475a532e2a22d999931c64f8bcc18f51d25f
+0f94fbd3e9e6c094f78da062f80c4aa2b86fa572cc469e629deb4ba0c553
+55e8422b562ed2f694d0e8e5540144e30841d7593b255edd4a61dd345d5a
+00e411d2c50d64782a3ebedf945fc31c00d2fe4ca800f5aeeaf12ab399db
+956362e979bd7ef0787188e43835e5389ac444d13204af6bf1875622f175
+09f32015c28729cfa3b3cca90308eefaf260e3fd9df10f3e76786b8bc0eb
+a30e8cd33689aabc55e3ce387cdb89a30573495852a48009cb58a0fd34bd
+da911159ccacc94698ffb94c5f45f15ecc9e82365174cefbe746f95eee44
+7a33b4d823487e203478eeb2d8c4bc7b743427778249c56e48fe17d0a501
+7b693509ddfe1f42bdef97aedcc26ceffa9357dd985cdf2c70bbfc987354
+6f0aa7df227ec42f9ca2482f58809e3f9650444568c54d3520bd0a7301ef
+48bfebef1fc4332b5ca851fd786c1ece136fe9e575b69393b5aec2611903
+fae6e7a5046e2ff350becb8700f209b1131044afd32fed1bc1297b6a2f29
+6ec3b87f170e92aabacc8867360e4dbce9ea29f0c1df981f6cecc8986767
+0ccfb4c9faeaad7ca9029b8ff0129fec4a040f80ead041b3bc8af7526675
+ed9e13204e64d76440a097d77c535d34165bfe9ffcade530abcc75ae224e
+890d5c110004e218bd827a02ac7340e18bf3684c43e664e0a37d5fd4fd1c
+4d4489d25a99d542c16e06685652cfa3567da4eb0cb517be1482939da0cd
+d0ea3519ad1e51bd9dc7b9077375a8cd3b5de9888697e853bacddbbdd1a3
+0e442e1d6f2d652046821813d0cc0e8f16c97cdd32daf239f5b2b65ef620
+46f6e9821b2e2ec539302747795fa746318514d38bdf0d0e490c00e114d5
+03e7fc9a8fb83b14337a5bb4d640b52630f5450bb3bfcf7cecfbb1ef5192
+ae401265450db197bcfa07315ff95a809bc5fb4249e3a728a817f2580ae3
+50d8d6577f79c883ab4a3119d9ab98219aed0d1e826023a66da814396058
+d95e52d9af8bdbcb0454721f27855b686d13bdb473f650c9865f3e04f08d
+b10f5256a3e59bcf16b12a84bb7ef3b370647cdad5929b722a05f5b3669e
+14c232bb82fcb9c1dd8155ff4515f4e83c895cafb86754e896f38e5f3beb
+5d29f1bd99cb8a09c5e50f412f6d8a773b79021ab2c4831aa663c5defc4d
+553616874dd5bd8b75c7a2af7d029aab5a72528fbc4b5ee3d30d523412c9
+60b432434017c4cd68b2062d28f307fc287e11663511d1a6b52143afac0d
+ce0f7ba3f326fb707fb8d2c985dd60090e6664f2344e098a7a1a6448026a
+2ee651e8141cd7786b6543f512e4c31d25dcaf6652b1eb52706300b771cc
+0c49295067befc044ea46341927123ad4b7d094784bda7fa7b568853d0b6
+1e4cc39e1abcc9479f91a2501009ae34ef7d5ff56205cf5288503591cc55
+c48abcc78daa4804549562afc713a4c11152e6e4331619b2e474a25ffb62
+7c46112fa4259f07871f8d6882e9a7ec62d20a86a0c502815d0a8f3f5ce7
+cb4a6a74b6db8e17d54bc919b82c7c729cc05b98855b9d8a0fabd8a9bdfd
+4333f395607631f57c0473be0fb290c4f40a7aa6ac49208570ffa1d0f849
+d4871ebcf9ef6f5106301cf54ff8cc9918d6de74d519fccba58bb1c21543
+f3bca9f43c211b2e5c233ff6dff2c9b56d3f656f6070d13dfd0be04653e4
+98c670770e01c07b731ca0e2eb56e608828fedaf1a31087f2d43cb4c0074
+e576769b0830577c86ad5de48ee216df02d7c4e4ec231afd8e76c608fc9d
+06cc86f38cf4d839e0a0829902f56cf2f86f08b975a6bdd0642d6b4c78e2
+57cf9a4f52646a952f6a220c36c91db7f44c7f44bddf33328ea8cc01827b
+5f2d79e3ee6c514a4f8597a847ef5f32c6400736e6ade28faa7bc6e9c6ba
+e4bbff236fa6dd2b0ed23fc77f92649feba149f82488260b0bea2a4fe1f4
+65d96d8c51719e5e10d4c17d1b67e700aac36b1ed55c93b4b2604e72f51e
+b30fbf5b64c6fcaaef764639ebd789f82ed354712c7f9fcd1df257e14c0e
+8fd59a0eddab684bb1b4176d79b22ad2605bf534e4b8fac2272fbdeaf210
+0424a2c5cc65f8dd5faa13313dd926128ed466046ee94bd3eb41f3ea5505
+5a70603a2ae1981bfae8e77d850fc5a5bf1bacb3df9b7cbce68ce7979fad
+a73c2900526b68236c6d37197b0c521c5b1cf5cbbc89238586eceb99818e
+aa47ca94ff615233575fe83d0d50d734351e0363030a12300f7b20450946
+17bb209c346ac1d35402b617d6260fce04ce8b3231ab5c05af30b0f3ccb3
+3616d3df334c8d963279537563222dfbb705c3e14616ad01927f952e6364
+4c4b7fa44ac97616c1521facd066aa33b2296dc03682eb6a3b9dd8e5bf62
+53f10667ecb07bbd50553f1b211067f5cf098b64b84d94ba9ad8b146dc9e
+8e9be06bc14cfe0945e22fd819856d6996e857c0bb5f292defeb493589f4
+515700753885d61eee1b8c19e6e94fe2302c07933f949d6bf119d207fb04
+dae7bcff7578bf33d77e29611c7cf03b2df12c242827ec4c4e5b5343ca3e
+4f7f38ed337583e30dedd78a082f41d60cbad55d59dbba11af1bd296ed6f
+e31d2e10d3a8b5ea698e656ff97755a47ddd862d23309e2e6ed3e3e111c0
+2c3a713d782fe301dbaff0a4225f932576622d1cbae40d20f46958298d01
+783851c894f2712bfc4736d3802e548a704878e2d139348671fb96d0ddbb
+f56d9349172caef0dfed4b84d867116d91063dcdf9ec401dfe8abb269ee6
+0d646bd12e0752313e2ddc272d9f4aeb9d940987596ab623f9198765cec4
+62f7b6c540c9a70c9a872bd28ea62e056560b61ec51fc68eafe008f20760
+246e06374ae5a6bd2577217700507978811ec29985ab644e474e41e8a105
+295fa67ae05e0739e8c7fbc51104522934942f53e1e1df1ec2a66f0a74b5
+9885cf2c2fad1cab3e2b609f126ac8b7350d5408a7df9ed5c27a10ef6505
+6f0d877cd7bb902977ba93e6e8520d2d018560ec8143876ad0dcb95b173d
+af72c0d413bbb5541f14faa57eedb3ac2430e36911d2f486d9ebf9cb6745
+2ccc763e1e46e7a4b8373e06082176a6c66d045e18f90b4b2ad15802f6ef
+cf2130cdc627601ecc19887784b6de7fb6a193bc3d057ace29f74199acae
+69526ba6f7a2c669593f9d0849f12e37201c32c88384e4548a6718cbb2ab
+714ccc917d93b865ac7d7d4dbd13979843f4f5c1f8b937ef12fcdc9aff50
+f09d2625f4367ee70a98772a273d8919952102aa03297e3cbcd876da5abd
+2ceb162b8fe1d9a22ff694495528c09a8819fbfb6946ab205d4b2424f6d5
+6fa1c704065cb64fb2aa0fdf291fd5e7daa38667e6d8e889be7f4c453da0
+59c492cd25fcf4a03a6995897145273a66cd6ba999138bc8e2aa7d080f9d
+231497ed28a9a27b6b0d4785bfaee46fee71b26d6839f2549a14e7ab7347
+0b6cf368d2d49e74c78d93477828e4582589cb447d795181d3f13dd8ad52
+3c750df8f19b3260c17a6598b406472a7204dd26c5988911ce9884de9a1d
+ce33d834becb1dc80efb07f32d3ed6c2a484c5d53746071576c3f67f25ff
+1558986fe2dc2265b4fff79c07e3f4c6c0ce8319e04c14728ed722cf214f
+65066148bc817753dfdcc0950bf80dc515002e1a92e7d8936e9b3aa9635a
+a6d512c68aebc79a62a6bd17a411bba7684e1f06be9bc3d1aca25d50c8bd
+1d75597194cf87c9ffe04ff28bea91b5b9521fd356ed9e036466137586ee
+f0a8795486438d0d9707cb2854f12963929edac394c562235ca71376d938
+e4e1518668180b857d75318bc22e9f0683749047e7649f9e20b35204b6ee
+60c0d47bebf53179a083f0b4cad5b3327a3faf2cf03753e3e46c05773629
+7e9bb305f603369cbb568350b2b5c6d23a35c551e0ab28b082e321ef4ed0
+e2704d35c75b4750af782160c2f2e9aab0e14e541e95b64ebedd66db2c12
+a8935a60177cab634e20a8871a3a72f4b21c3a34d9dac37176a321c2ce3e
+e828d140c8445117e7fe4738000c30ffae8e2a48bd618cc8813e38fa0f86
+92ca634d1e56010987483aa0f08980d91528df3d370ac724acb238e141ab
+595dcb3da7a769de170edd5763078d1084e2ebefadf8a50a816b50722617
+c9539dbd68d9062b015639708dd900aecf4f15adb36339c05a9aec7403ed
+771f9f28c60e52bda3ba6902e06334036c1dfd66d35ed00e3fc0bebf55da
+416093b5cf512217c47f905ccc91fad879d63dd1380519a02025ddf15d70
+eaa1bd8cb6be67608fbc5c94796bd09ba35933f64c5e72a26db1ae40ef49
+af5e972fa44660588292b67ac670bf046cb1f5a7a0d73ffd6df862744786
+4a56393b0f1b4cfcfa362c74634713093161b29c94a2526b7138aa92fdde
+b37a8c1f30a6b3837d9500b340515f0412e681f5bf36e7869fa157df18e5
+c79df3e6aca924d7b7dd2e0d5b87682d7ea6913b26397ac180fb75fabc1b
+8e156ed542b9d8c83079bccd141c187f90d72694de4f6d08520d11cd454b
+bd3c2e6d259694fda0c8decc724bdd650163b7f6ce1181590c06de4c0dd8
+536aba318cabf54782c919e07c2ffa1034143175d05deddfcd7dce6c86a9
+ec9bf6a4437da474aac2dbce2c91aedc20043f179d5c9120f3dfb1cf6906
+c27f2ec68cd75035c283e1672ea90d953a23a1515c420b81c3270fa06573
+4d003eca1bb71a2dacdab67e44f47c266c2ea1776648b62bc110671e6eca
+4546d3c72c8acd956e10452c32532ed51bf3d0518467fa829efd9c896e8e
+1e5c7ff6da0b51e872e403470affc95f25e1d2b9b59ddb0472705e14fdc8
+fc2af16527188508be10d098372cd7eb7d62a85c8d8dd1d0f55ae3ccd0a6
+5dd6bf776dc187bf4de409d5db3fcc5a6d852848a251f4fb4e01dac5e9b9
+587fa8c46ce03689709008b34dfb3dc105def80a1b515abcbe06e73fdf7e
+7136e40cc922fe9a9da1726747e84427f288d934747b6c587490734906b8
+a91144ac82a57957cffab561714e1ff5148a39499dfc8cc96bf5d87ced17
+825e8f80cd943d9a73945fb8bc51cf1f9cb39c605491c1bb8f1c4139974a
+59471ead310d041b1ca1ecd5e9f92007cd8243cb3fb1ec5256444699a9fc
+ed6cb31eaf0912c16fa480a1cb4a8f4a9cb6a4d9a9903d1e2f674286032b
+489b8a23ac4719fe435a9fa2d79abdbaba740e69d5ed611421b1aefcd06a
+362ddbb7b79aac41e3e90657afc0b87a6e8c57ceef70a628efe19f568634
+50f47b5c6d95870039caa3d07a54e58df064bb5f59dbe9b9a2c7c84d7e0f
+32386309560a0efa2cbfa27f861b208b2df4a062ffe2c59c057296aaf5c2
+0f48ffc9ff0692f8cfbd6fc6ed1f3a14537ba40d7267e6b5f69c997a949b
+26577a9a99db3f53167355c4967dabd522292ddaca3c537bcf303ce76add
+eb99f6664227a94d6a698dd5a5d40008349376067d057e28e55972264502
+e035b1f5e33d7b3aeae016f9be50f2aa09aa138d15d7af3c1ccb805f2d5b
+cd4e9b2b5c288b2af4a25abf0a9093749377c9e8232ba1af17962f85064a
+23b0a13f11acbb471cc700f9f1b588f72cb63d3d1a95a93502ef74ed212a
+c452f1a84619bbdf61a1dc79c0d9ba29c7f19b400f682cf66f7705849314
+f5c8bbf973f2c53bdb060932156bf2c9cd8d36cf6271075500b0e3e6ad49
+958af46a9dc950f4c29f1ab5dc0a85924f7ffef259f778459c80118b1eb1
+ed29208d1145b21b19d62f755de4972c57a09b3decb0a8096ab025fe6b9d
+be49ae35394f0ea40d3693980f97f712b27f0e28d8a549acbf1da63518d0
+374941effacf63ac3de0523cfac0dcaeb690de5836741fe58917c7ecffc1
+95e7b560a3e763aa70fc883751bd60ea0a0f893d8e9fe75a66c67e202c24
+84f66708ae74413c0101fe0b5003be20881345d917203b582a247e6c74a8
+1d0479f317aba7b9dbbc0a92e91c51fbe8775a44c57699acc9da84ad60fb
+9629929d1edabbd70b4ef9887ce4ec2469f154fada42de54240cf3302364
+7c492ba17e6936a4d85e0751df0945463368a803fb40d8ded22abe118250
+86cfff1878abe5b100bc08b991cda6fdfd579332360f0c3374842edce6ed
+e43649d6702f34668a29bf387e647f96d78f33395e8d4b3521cb4fb0956d
+12c924c16eee798cde68e319a358cc3524c753177d976d4e14a2e0cb72a4
+80cd87bfb842060b1266568af298bbec58a717c577be73ad808e004348f1
+6aead32a3d57457376ab57197534d6e469ed24474a83618f3ce21df515a1
+22918f4b62c642de0c8a62315ebe02bcfc529c5b8f7c127085c2d819e29a
+f44be20fa077ee01a8d427bbe3d97a9d2bafd77f17835279bf135900aee5
+9bc49582b18d468bf93e47ce0bdd627775264ebe9e4172839a444f928580
+8c95895b7e23592b2dcd41ee82e966c26aa2143e3057161511796e980998
+1f2e4ef5868b3bf4576e3546e6407e35cdf14654bcefa7557d09407545a2
+38173080b4771ea52054736677a8d9749a2b22b46b24fbff93c55aa2274b
+8c7ddbd751bcaf1df00ccbe1f24a80622aff192fd6db2238db941ec44ae0
+dd73f6b2f80d89bd0aa30c038583deba14913d38a7b61b54522755e251b2
+aeca62033a39ec1143b2b960f9cb87f748428bec3243b8164f07d5ff72eb
+f2ef69347bb933241c2401a96ba5ffa3f9ad060c41f4e6bf7280af65293a
+bbae49d723dbc4be61d7e13f7a5931a697e7f2c6582dff416341ccf5a24e
+9a53686a1e13bbe0bb480c19a4e72a5e477bd29f39dce1a17f63f1e8c696
+d5f8855cefdbf7ce681c7d6ac46798ca9bbdc01f9ad78ce26011ee4b0a55
+786bb41995e509058610650d4858836fcedfe72b42e1d8ba4d607e7ddbbe
+3b0222919c85de3cd428fed182f37f0d38e254378c56358e258f8e336126
+9b1f1acd7f387686e8022326a6bbc1511ed3684e2d2fc9b4e53e83e127e7
+84da13550e593bbad1c87493f27b60240852e7fa24392fbf3f478f411047
+3f00a8fdb6dcb8aae629dc7f055d85341d119f7f6951ae612ffa7df82111
+d1ca48306a57a922cf4c3106f0b5e87efba6815f6de4294c7a0394087067
+677889d22a3fd86b0796200300d2716445078027fe0c0b05c86ac80d2095
+ae874324ee6ea3553bcb92fc1522a6d1524f6fa22b71598fbce784a10b5b
+61e50307ef4409ffb7b38f27800f2185140ed08fc4ab396050b068025a9d
+e4bddcad201e72ed9b41c4ffd4cee743c9c2345b95c5071442defc8ba5fa
+9c63c56e209df41d10d93135a8080f7cccacf67e0b0ddb3e0a31df32b83f
+290b3c536e9949973cdc80aa5c8a4feee20290a95f68e59f54050192de42
+f27464ee374e4d2451ee8708933b970402c90ca3070843a449d7c3146347
+1efa666a60fd5cbf55a47e4a3c5c318fc1af944d58d32690a2c7eeef09b2
+d94721896e1e3e76e44a8efd524ed5d6f5eb9da093d277441546c6828745
+ad71b6c13f653dd631bc6fc55d0eb4648b7bd9c0eddb13222542f2b6e8d8
+b80bfab4365f4199a41ac690979285d917de79359a183e6fc254b63e6408
+6d33e3c029f472f40742a99f92999f302f79994ffd615f1a848194cb56c7
+12146850f5e400303bf5bcd4e5fdccd1fe2edf5352d525cb15d8327f45a2
+6e3ac276dc8780c65724d28dc6bf9c7c985840070c35e32859168890d599
+a884dc2a90194cc2e9cc6a20c6c0ee11b20adf3aff01db48eb8dba7b0c81
+7fc10cf5a66e8171a2823a4cd22f0e80c82011ae56dd895ae2d3ebe84ff3
+d521c31453e0909cb9b1cf0b030eb6b7059ec38038cae12d0e1cc4b5b3bf
+e6c821faac9b8792441e2612aa1ee9318b71f9966d7d3a64abe349be68b1
+744de7b212f6be73a0e1eb2fa30850acc3d9562f989cb2d4fbfbcd5d3ef7
+ba55717da1cabf197b06ee4d8650e968518b6103fbe68fcd5aab70bdd21d
+66f09f96208db67c1b345672486657295a39a7fd689b2c9216c6b46a29dd
+1283bdba295dfa839a45b86c14f553ff903a6f7a962f035ce90c241f7cde
+13bab01d8b94d89abdf5288288a5b32879f0532148c188d42233613b7a1a
+7f68e98e63b44af842b924167da2ab0cab8c470a1696a92a19e190a8e84b
+1d307b824506e72e68377107166c9c6b6dc0eed258e71e2c6c7d3e63d921
+39690865d3f347c95070cd9691a025825421be84bd571802c85e2c83ba53
+841223435a9ced5dead103b470a4c6ae9efcc8b53331c61d0e1e6d3246cd
+aa1b0da347685121196a07e97d21b10ad34e7031d95c1bafa37b4141bf33
+a6be401129dcd64086885f4b5f1b25bce75a4cc8be60af35479509e64044
+d49c8a0c286e4158a5f346ef5fe93a6d4b0a9372233c7434a7a6f9e7ea21
+30c0b4b9f62e3a74cc5d2916ebdaa51a1ef81fceb6cf221e70002a8a3106
+bfbccc2d1809dde18e9607fcaac008fabb72e8c50244507f4013c5a268a3
+6135ead9cc25362c37aa9511589f18d812e6039490f9c599f44e88754ac1
+4f6c1841d570efde27958c7f1b2c68772584e1d12fea252e3a6ec3b051a7
+6faebbf6f5101978e24a9ca927c02065e8e49150a55c64dd30757e8a33d5
+2a788437a9181efb47414dbc22fdeda203d4122137bd045611f68314e12d
+1d6a5ec270c8919562c03e3af7b0e0deceeddbdaf3eab8fb5632e44dc1e8
+d46e2396b0236a46659164e33709415e7b347f7f7b87a9224a189ddf5178
+2cf66c9d385470a51efc88696176f6d3ac3b7b95fa074c981194e22981f5
+1d925f980393b7102f1f836b12855149ef1a20d2949371ddba037b53a389
+7617c257bbdfcd74bc51c2b40f8addfe1b5f8bc45aa4d953c0d1d5f4091c
+6af796af6513c820499969593bfd22f8c6dcde1d2ee2c0ceebb5bd6a1ce4
+5fa61094e932b380cee381f4485e39b4b1797f2a7d8d90bcbf89b9cb1006
+2d50fff083743bf318157caac1c0179c87c03a2857fc002979e7cc97feda
+966b09ceb761d3f55cf07637256c6aa8b8e5cb6aa9739452a330afbe7082
+975ee39fad5e8106e8ee05771157e92d99003533d922ccc37add065b6236
+7613d039741f99edc77c230fe8d1baba720a185186662376b947bbe1a686
+4b42c61ebe1abd40d890751ab8945c629de3b6d2a49809dc693f9e397097
+cf1e568c258081242460af2de0ca44b7ba2734573967b3bdec0e5e64598c
+cbf41e630d821491504f414d9b54a3100dd5105a141cf61bd3ec41b67368
+c8cd366c543754ee800ffee3d19c9cd0d408cc772da10e4d8134964b0a61
+232e2dfbeacd0fdee12792504bb327a2e1fc44127f8577ca51d380a760b3
+740e6be46455cbf3917b90f0dfeadaa25d5d9f66cda43ebf9f75e0191a06
+25ba29666bbe8678822a453d4e876bad4a6b0d4b6cf98feb60339c9eba2a
+dce4ef7faba428422c503d0210dcf8d884ca9f5094aab9f3b1a2238b569f
+444748902907cb0d9d7ca33fccdd0cd29bc68e44f7bca5092be6272bc949
+baae5af92c302bb21f91b6ea8463265680f7c16f45d8ff35392a10eab87e
+296f3af4478032b5b021db8510deb617941130d45c46fb3647d94b162fe2
+2738766fb6d76a06ab6803818b27c5ff4205ba668f95b5ec5ce4ce6da545
+c13ff56f417a4e0b3b8554a1e2a985a167e168adc8c4db28a601a80ab451
+91bf32acfd8d25c39c2f17fb3bca1296d3d160f25b43b4d6b94f20ffe012
+b779339b12860dfc897b366e3d400e756f4f9f4d2c86fb9d94c11ebd1450
+eaf720056e2c39529331bdcb104d113b42c94af2c6a5035750b7ae7fdcba
+b6116d74bc07a11d4357ecf73d99221dad5cba4a7136425c2a3ac0e092fd
+606a4ab722195e3b7fdfb5a5e3ccbb85fc701c42bec43b54e964dff3fa04
+193043eead7681cedae9cce6919949ea60ef5630c4b9263c8f98b4bc74a1
+63ccf3d0a0bc1deff39b800ac90bd734dda7ecdc73169ad77e129887db80
+7a253f8807a422eda8a16c9ee9bb8fc0942634bfe035dac9f7e36d09844e
+39477c043399db4d07b3617da9d6eee76d0fde9201da98b906050748b68d
+8c944ace3c96e90a3c2b63eae27b9152cb7274fa336866d71b65a57f1bc2
+bb1f482a67f3993dcb3ff24abb0223f9a026c81b2b33127a1dad8929dec7
+5d46bdd790eb1addd771c5c3965a2f514d3a128117a44560cc10a729bade
+4e6c86de7c09a39602235c803902e34f5c176b18e127d71a011dd9a3a61e
+ebfaa4a4e2a5651be6f4067e5e09bb4f3514d67c2129e4d3ea9568661138
+1e45af07bd84f883c70577a986416747f3bd8d1bf86d3d7b07e8a350899d
+3c2dae237bd5ece45faba7a0ba30fcda7b7eec9fbeaa5a94620686d1e403
+1cd2512e8d89451c7bd8eb432c8862023d66f3f9fcec0d47598e2df59525
+d673a5ff493d458748cd6341f161a0a3e8996ca5b496508578fe4f653924
+2ae28bf4b7397c02b726fd5f9d8b898938bb668a546be6e42865f4f030d9
+5faa289eb24f7b8e249b224a95a2245605d67417a489626df7417855b8d3
+1c0043cadd2b461d32e1b39ccf409757c37b68f84e752bde6b5bbb847bf1
+57ea3434802def983d6ce5ceb3e9fbc4911b5484e99bb94dc3f383e50672
+0e85a91ed378e352838cf02921ee0ea94be01b5a60f9b1f58fcc1b4f527e
+43725de9b9dadc3ef462fa279bd7138095d4cff2a0563039f71e383430dc
+f628dc9611b2e3db08fb2da1d5383dc1a3c784e1e64541fde1d9d7f42505
+de96d3d0a401099fc2879af0293b0eeb143b78cc221f670c0479bc150047
+0cacb9a282e334e428b527acdfbfc56e6aec8d4d60745c1dc000011b6248
+d9ab4a17dca7cc74e17d33c0641710b02cb1edb0addc6be214b17e9f845b
+2d9c8bf03c19e131e00f91f2a393b5f2ae7c3d4ae9021c4d7891d84d5067
+377ce92836e42eacd7e540824f7ac95360ce116d41d17a50748748971c82
+27f089a22ee0d21940de854f737547b73c7517addd9bdaab425a6c2908f6
+87dd990d6cba4d84308bdd4c4435a6480ecfa1a14daabd4d8e2398178e48
+de28b84f7ce4b61d2e6e64fe043c29a941f6de7621ee6f6d8b506221df05
+db238b8fe4323cb5f259d4d3d9c94d4ae1ca37d6c34345489c0284171346
+e9830e2e3c6c167238a7ffe0989d3eac870cd44102cae139469b9d909b5a
+9c34792f693ac94ecd35d2277080e30a2d24b50391b6f2a3d3b6c81f7ed1
+a7b218903e7fed7a63269e27d793a2e0b40320ebf447c71f36d40dee002d
+7257f43c8add31edf2c571123e46fdb413e007cc89e99b6f98d77ab38bff
+cf140f787e45ffb2c7cc4ddbb59a4e32dfc36e2875f204ac851d757c1236
+12deb31324ea4c201d27fdab46e9f3988ad2bcfb8e9cfa8c487831a9b0c6
+60b20fb66b4c77f52359ac96f3b3d189aa0571c1c53db06ddb10f08882db
+0b1e93e9478d4c75626c5fbdbc6044c4d82684b310ab2af144d12bf36f1a
+c0bf6249d1da9ab319453594cb19d0e93c4e047fb49229c0cce76d0cece4
+2e76fabd2425382afe707db032cf617b046a59a2fc1bb3838d98fd5c8053
+ecb918bc14762e4ca45027623988f434ff4cb08bc9bff5d7de21940e3e03
+1ee042d9c30662aa76f96213fb5a92047af60f320e4660eadd1ec19d0086
+072f2202af5f219725f81882f10d1e065a8035a9946d0ca0e48a5e7dcf61
+0283b834eda01e7d94b3453830daade2aa6c947989b290c02ade0d7b2620
+813ad177ed82813b6a985d5c0a2d42419bda763d409da085936e33c817ae
+68e5467eddc30be172de855a0f7f5c527555b3f4d942401b450f08273b1e
+c5b5352fdb8562a71f276284cf7c27537e628f94bcbffe8d669ea2645752
+60830f1e65e83a2204cec393f6d92d4f61f317471b4b93039d298ca2cc94
+eeada0140823a2bcd1573e732e7b4bde7368f2ecca5961ad547f554ae989
+98d87b7e5d07a85c382bcea1693a697224f41eb8b406bc6a0c3eddfe8b5c
+f25b11c3e4bd91ea7d6274cd6b3ee7b8f18cc3fd502a324c645568dce9e0
+d43caa61f7306fd5488fcfc439d85f8160ebf0ac90fc541f9c74d35d7833
+09309807a639477bb038200738342e50136dc64baa7cc1b879c61f7e1b90
+e1f2bd4f6e54c4dc97b8e4adeb102979203a31fe26a7f58c609915a95abc
+4acc263179423f8ab16b04272d5592fc536f29a45cbcdbe15890f119ca9f
+c7a52eef41dfa5c4fed087eef8e698ba738e300bd58f2a1a10da1198c1f9
+b60e2032f8384a86aa84027df21cb87977528e3bb9bea1e3a6879c56402e
+a29063afc6ac0194f4944433f9a5872cf0a2a741382d7f3c0ca7817d5d7c
+4b8bf53af0f18b1eb54480519cebb61d983157e039b13025e7980eb36f54
+3451bbb84e470ffd0f98eba80c74f238729dd6278294388a2e06de68a719
+47b6d478c85f124d14aaa835620e49b7f5a4f21347302c0f0864f7ebaeec
+d0831c36187cbe9c848736764a31056d2cef27c07cca00033dcddca9a2f3
+b9ebf28e67257b69cd38bc23c711b6a2f6e4dda9bf5a19da275e6a8d683c
+723bfbb95a90a344a6f421f0b67ae84c74652288b0597e4c86c28f73808a
+77455f2948e8df634c2d14f221626b019033f9230c9167982cca9ae6dc37
+aecbcb49fd9fc1dbf2d11bba7187888721bc42a7f47c23e07d2fc5a7a91c
+0dfe255a7f9d17e69af1618502a6b90b1dd748c7eaca1e1ebe8b861b04ff
+e5f628f47eb4e7e65311037d7a5713d7cc3552dc85f452ba74c4f12aecd0
+d72892c940c3325640d62fe3bbbc71361dce6d54766e1fb99dedcb2d19d2
+fa6fa21f9116e03952ebbef659816a62db51a9b5b3916ff818518774ccd6
+79d44100d7236f211f36fa80a4cbafb3db76ba1e7e7f12082b0140eed2cb
+5e793e24501715c6c170ad4f856a4bf16bb10210025156e635264d3cf18b
+1fc1e8cd2fcfdc2ab1a24af9087975bfcf6fb703fb36e288e58d0d2ffc98
+bb4318001d931ad6161dcdf8984e6690e0f6bb07af81bf07445f8f57b355
+6b960d24e7cd152708489e4d953ab6a155a757e002ead97585e6c5333d7e
+5aaab2731f047f3490432e0ebf3d0d628eefa8c1f665b9c86aabb0706639
+5bc372e16378f0d9b439c98e7bf87be73e934995d58e4e70d3ae9a5b54c8
+87a19f2826a772c39d41805c642354d9bec75b065f148f7c1e435dabbeaf
+e4a5744e3f2894a928121ab069bffa3218a106a9dbb83971353a7c7a5616
+d9da66fbb908173f9b07aadcbd4d112cc353e7b70476046ce5a92e86eaff
+4eec40acc840005f51f55c9f5874216851e9cf3fa431d95d3032e779e356
+4bdce33966a3a798b170a06c4cc9f73700224c858c36bbf2d0326c337ce9
+46f69c19a84187fa50afc5b36010f9a7612e3a25e846d49bb907af9505e7
+d8c78748d7dcb501bbb3d6603e829deee3784f2f3ca583d3738d6d2ecfb8
+eaa887103606211a3c1b5cd74a3e0e96fb57da91baebaecd3669661e7b1d
+579ba41928a40a7028acff6cd409e601d23ff66ff2c8acb12e535360d727
+60d2e988d801930e0e9443d60dcb9f378fa75d58d73e6a3b6e5b26407c82
+67d50ad97787f8a9b91765e41552283cb67e43e59bf71cf08b9755c8ce47
+0cf374832c72d1e9702b55bcfc8b5a4e966d5072fb2a72a2108574c58601
+03082ac8c4bba3e7eeb34d6b13181365a0fbd4e0aa25ffded22008d76f67
+d44c3e29741961dbe7cbaae1622a9d2c8bca23056d2a609581d5b5e3d697
+08d7e369b48b08fa69660e0ce3157c24f8d6e59bf2f564ce495d0fca4741
+c3a58ec9f924986399480ee547ad1853288e994940bd1d0a2d2519797bf2
+8f345e1bb9cbf6997dae764e69c64534e7f9dd98f86b5710ff8b500e1c4d
+f509da50c64e213ebdf91978553a5d90908eb554f09b8fc2748c9c405903
+e7bfbf0ea7e84254fb6735f09bf865244238e5fed85336c995bc3a3b9948
+947a6eb95db4cd1b64c0fccf82d247a2202e9e7eef5a550557625a0192bc
+8bcc9e461e52833f6b8729ccd957d5c4b6e07016e864fc02b792c7400ace
+d0a8f43c755f87bba6e5c6e1022416e5454cb34a19865d951f7aea527760
+53658cbf306ead832244f3062c39a0a121a1157a8e47008163c5bfc88197
+be16e9a1ba26a035a16dd38cc28dffb666dd4ba7356c66b7bced9e26e905
+4ce25f6d36607d8f5dda1e21ac96a815bb2989f01130ba1aca9aade554fe
+effdfef5d6b0d2a01aad92f599f6a12e121010ae6acc6f150f19e7305271
+97da761b07530ca19b84b119e5edca1fad18462143b8913d6b3f6864b713
+7a93bb9e1bc29c09d660704e8d8292c61072ebfe35c354a2342b2458a353
+31d043874380d439388e46688a53bcfe01bc190ef1a6b5dec9d40aafe822
+261b28bf3e2d76f3dc4302506ce3387b4aa2a51cd4ba1faa2ed1fd7df664
+6772fe9f83d253451eeb0448b444b8ca80cc7cb653c2d1eaa0de6f2b1c72
+47e6d24ae72e620e200aff83a557a1aa7a0ce0a9cfbbeae03c31d8cbf1d8
+20b53b688ed2ffbd83418d743ee31e3d62216ac7be6c12bc1917548cf670
+d69fd2e78d9f7786ada0ea30a6f6d9fbd1f1406337151ffa1d3d40afbe03
+728fd1aa2fa8a4f075796b9de9586b71218b4356fb52daa01d3c18cb75ae
+d4d33fc809dcb6e3dcf7aee408a0cef21353d76ed480bf522fdfe86e0e0a
+b7d097defcb793057f0ce98ea4989a9b6787b14029a4bf10315a2557149a
+fe9c91e7d825f7518b343fb556f0177a8f6ca08fbda9913d52997511590e
+b9942c9813b4cf4d4aae4919401f2fc11fef0620eb5c40532cdb22d5fad6
+919a3a710de6c40d54993b5386636499c866938e33bc703a99c73adc228d
+95cac73ff4f4a275c04d0d787b62c6a184dacc4024d23f593e7721be232e
+9882fb738160e52ab905f0ce2c76ae6ff2c8bbe118a1acdb3b464178cf01
+94bc6a50df1090e9221be11e49f254b06c3236a31569b947ad041d1c6b55
+bfdec3c18c791ace0fe2a59504eef64a4eec4b5c8dd38b092745e0d5ad29
+276bf02c419c546627672a5764a4904635bff86fd0781d36fbdf13485229
+71f355de2b0ad250052f50ad70f61afc870ac7a816561d3232b73360d4ab
+2727b2fd045f254c782bb3f1f49d94c6d625047071b7e32da5c6d21a86de
+9283fd632074430772bfbd85e0c9ccab1dec16bbc049c3e223bec1b65c8a
+9e98cf58b30a74f74f1a842dc91e30c023498e280ac55edd58f4cc731d81
+e443d9b9efdf5fea63c9f357320e01b8740eedaeef2495cd02eb2f338b3e
+674fb074cc497d7b1937b188da857c2c230e9a931cbc00c85a7a36fa80b4
+56588e1bbabbe4ef429a6aef9bd4eb89c5752421bd049aa13f4dcf9b51ce
+2503e90bc118fac78a25d187353d6f5d496cd6130b337666f49619cea985
+dfbeb7e49c67c1e0f0f8e9ec8ba14624ed0982dcbb69415e4b3c8ddba140
+397eb1fc1ddd36c94c374f018873ba41109e45afa51f0e691157d5958c06
+26fbc0903ae25e47ee372389cf65472a3e4d9769550bdc42c0b72f9a297c
+d5d3c16ec67e06036e740ab664abc9f10b9499269b73ad3678daf4474329
+c2c7252c1f0df1e3b5e8f198dfef8325cb1e7e8057897a3d7fb5bb5858e0
+cfc0c115bbd7362d8e8ee41862af6eeda681cabbb06f72ebd2ae0b0be45b
+a9e1be83f1da30687a655e5d148fcc17d9f53b760810a565f6d2f4cd5da3
+5434116edef756adb4d3df544a1de593be988f2bb8d36c34deaac7d9dc15
+cba49764f1e03aa09fe21fcd7c74e3d6487ebe219569e019f10dd163046b
+c1a3cb2bcbaa8558197cb2c18709a998b4efa8ab8c9a71d2ccf942c17662
+1b88dee6b424165d6ce10ac48375e760983818e0085276b1674dd41042e1
+a01a8de111c903f74834199b3230bd475d92c6226ef74eb1daaec3475a6a
+fcb47644a17c7e390ee3b16bef1c1ca6c55eddc44fbefbdde525921b3047
+0d76817bd8ac724739a8e743eb09cf78e88adad527d4f115b8a32ed4898f
+45bab3eb802b8168aec061e3ecdb026c056fb9efe7e2df48bd516ccb12ce
+00de08ed8be4ee0c41f40f4c8f64483e0ade90a78d6d4fe9203fe0b97c60
+3b2f8882bc15a212453c691c52d00fae8a3a26934ff8acf68d4352eef75a
+0b10d938e55b7333dda2db0296a69e9775bf82b1aa6d684fd9080fc1c11f
+ab4369c7a95a9504063db900a6e345bf6dd99be041230b2e60cc86b8c345
+1d84a9c2cb4ab6d74d63dd43dc26eb6b384f5222796d4083dcc3e1651548
+d9469f09a33b213a33ac52a6a2e23802d8f8a75c01a607940daab0051410
+73a88130bc192f303616adb113c0051b65e12086cb319c0a5323fa7def40
+402f5f87a3b2c2cf0e92789985f6775ac2743e1ffe2d0668291059740d45
+43bae7a2897e5e658592bf5a72966097742e0702deecb0cb12499eab701d
+34ba37a08346217a415e44297a181bbf3744f0a49230ad6f030e11462be9
+afc2ae14e0587bc02311b48b8e2122c28cdf14414f3680fa52dbbb63b17f
+6ebe4a1204f3c5d6150cbf89a8023890383153838d4dde77d4c8b1b78823
+8918c564d3babfe58eeb154307dd1997f5ab7105426e35c279008b2677e4
+695c60f956b348799c04b734338018fc27f7de7ad9d73468fdbc5283bd14
+c066ddad9a3562f16baae15d72d7bfcb409e1c874e9db1a8cde233b282b9
+6e76e9c08d85ddfbd3cce7e64104d0b0e95291bd91f405ff82f41601ee20
+8471e613fbbee67f269e4e954c36d1d18ca9880b7cc2b08fc990978efdc5
+1d157deefedaa765c1e26ee125d4a2514a41a3b95e9151a824532d7d6486
+35ad622718fe71219a697e94c2e64f26424cbb767acdef5cda70e179cd29
+b7e318d1c6d3ad26fd5fdcbf2fc221301cc1f10f5ed86b40a1a6bcc01c90
+eafd65183e75609610637b99fea57885efe76437df02a2ffc21223d039b5
+74955d9a54ff41980eddaa8768c5ad883a0c9150877392b990d63c6805db
+7b8d6ab1358cbedaedb6feadb0ee4fb8f9c1ca03a3e755a74227a8930bb7
+2ea0a00b48fc626fa14d7d48624aedc31c556f44e982f3ccbde7ee735f73
+629ab1b65bcbcf0a3586a920477e8c960219802fcb1bc3a179032b324f8d
+c424899b38275886cb5bc771f26a0880767d49cc23426a40a4b6ff8fe48f
+d747565fc537565f6d7fd08706accc60f5fbcb45bc785f45ee9b0812366f
+ae71b23ec43f3549c8224d78baf18719f05108d5741e681457ead8abc050
+462481771a8dc6cfeb98956e163981a98c59ab44d90e9c3a946c453b5071
+db0c769f7fb5144c7ab0c9ef1a6db1addcde1d4ae1daee1b4035af256a04
+df53926c7a2dcdb94caaf12f986e20929ba4e396f3aa7c93a7abaef1294f
+5f13a0dd3c3aaa8fb38da3e15daa32163b7437af683b4f5e64cb14aebbde
+8c69ed2e8cdbfb213fc8129af29ca2c06c8f85a5038d688d1fa5d1b54ebe
+4dea81a49ce24131f8e6702e7aa4e2cba078d5dd373f894ccb275f49c690
+1dc772e1d2f5fb3fe15dbfffac62c87110162074eb72ae4e5e446bf7e650
+a554178d0d64d3c07f330f0d99e99f2239cb1597f2e5f443854cdb0f5fab
+b28fe62f22e7f3419d017980f325351bb04f8f3c3dc57fee03cc029bd29b
+202308d5a800ed2d500d41ace8e54e2557bf25b627883beb8118d800eb94
+f4253f855168f7fc8a2d29c5fcb76bb90a6c4e345722b8991a854047f46e
+4e97336be85470b6be2b9ba573dbc4967ddcdbfc3b6fc35b0c7f3f2f570c
+55dc3fee6d80bc6f46cc7e4d86a0b86f6fa61d062e213d9e442db63fbf11
+d03165b44572096995ed342893bb672f6bb55ff8fed944667995f0f89a48
+a904c47420f32afd14129c6e2bedffce1f07ea69d550b6909bb5beb4aa08
+b0b44f35e018ba5206fdb4df0228462c1fdbb95a429e53eb27bb1b0490db
+f07202c3608d0f4ce08570e3d6aa3d4581c569b57bd8c1ea0e4ed3fc5497
+e316ecec06e6be582d9170d426f6d22d8c7287b8219945c124941ca8812b
+e97efd9105eb6999edc0665016633b3b48820df736125b7c76c9f3a67d93
+8a2a0a6b743fd42aebc46a0249be459f16811ac9eba7b63bad7c2e88f175
+0eff8da5faaab5659824f9d19b3225aad2ac17c52c523414d3031d08a926
+30abf474fe02a32b44d3b7d9fe0c19aec16ca6d018b71d9d395ffaea0788
+0d4501d7cdf0f7077a2d63303d09083080d67f1f714a1b271dab9fc9866e
+4b0571a171eec8a4e351ba2d02438cd108a33b1106acaad0ccdb051061ea
+7f40543748115f29debfb4be4b42cae8762d62114ec6f8ef68c478a8e05d
+ecfa18b0368428efec9eafb2353f95e3d71e1636b9d9f94a77e692843255
+698576dce13b2b858d2d15ee47cdba3ed08d64b77ab46dd29bba6aac2106
+ab847de378cccdaf35c64e50840248915f4fc110992c493cb1b9cd0b483f
+0f1abf5e9b018210b477fea28234ffbe5e0bbe01338e0842a89f1e00a0ca
+7cdde0b2d7c324d5e17d8d3415ccad703507497ac95360ce660b656e5f66
+72a2f50761f3d02ccdc1d5692d7797699b8e2147cfd4817c81a432ff6a5f
+39cc54927fa146cbed56a55f85f123c0a94b7553a8819b329d9dd122c502
+94e3f6314d5117db89ae7597c4691b6c542979a1ca3d26a8e23d3eb698c7
+1841651e08ec771cfb974d6613f2143872c739b62796bd0a45172530793c
+28d93a65b59f79c245248d2c09428657a35b0c0e367bf7a4a4f0425b3f4b
+485d9f402e164328a4b963f456829a39035c00283d2e4fcb71a42da6d42a
+d46cb751287de34e6519c60bb3f1a6ba91f7bfa21dca96ee712af5681701
+18ece8a0535d9ba1dd4bd835e004a2f38c5ba43c9b30d17045e5649fbbac
+188922e442182d4bdafaefb39e00106a5a7765f3d67850471e3629e526af
+8691f935b57bd38465665204a214fef1006ea37dc0781073ced5fc042781
+93650393c3cadfddedcc5550ed483bb6355f54600e9758e647f9c9711f1b
+e7df05d0e50a698615307c18f6d4886f50188011ba499d03831185915f3f
+77c4b9ce708d78423b110776aaaf90396be0381616d1e9b0c1dcf68b6396
+82399da2a7323bf42ae5347599ef4ae9e5c135522c5ecb87e201853eb899
+db60d24acad17d6b7c2c7ea4dc221f3cb6d6caacd1ac0822ea3242ad9b4d
+d15116c3874e3012fad26074a23b3cc7e25d67ef349811dbc6b87b53377f
+0cf972040a037ecb91e3406a9bac68c9cab9be9a6bb28e93e3275b177cd5
+0b66935cbe8dd3d6a8365625db936b2cfc87d4d6e7322df3dbe6ccda2421
+a5e5372566f626a5e9d8bc66959e443286f8eb4bcfdeb6c49a799f1efa69
+63260d0ea2d51260baba9207fb246da927fc4c89e9c4dd5848fd4ef6f81a
+cd836f5f06ff0fe135cafd7ab512af55a57727dd05a5fe1f7c3c7bbe8ea7
+e6680fcb3bbbee1cf2e2c0bba20185f00e2dc3afd42f22de472cdb3eaa5a
+ddf8c6fb3682eea5548c51ddca25ca615221127b4438ea535ab3089c9ed9
+b971f35245cf831d9461a5da9d57bc4e5606d26535a7414cef6aee2a7b95
+bf2276044818ee0f3b0a16532934b8b745d8137b42ec2b28fae7d55fc02c
+9ccfa4e0055f8a4be96e1e235c01b8b6ad509b832a3e90161e0a449934e7
+4be973c939b31cbc19dad4c58e9be89d242f0ce200548cdd4fa2081ab3f8
+e01f358d5db24b7a50eb2096d833378921f561f132cd7988708ee10cffb6
+2256201801c667e176b1dfaecde9756d725bef093457805e16f550e8a7de
+87ecd46e5b09646b73ee74f890a36867636911e4cda2c46a40e7d57cf297
+9696046614c85b1a47ba55c60544ebd3ad7d750d003bda56dd7eed8c4702
+f8b319aaeef9d3cdc59b3e63ee93c6e1e857af273eb90909ecf36ef4c276
+895c78aa762e5376c5c542f854fba864ebce56e4b0207091139f053c2c08
+3b7ddcd0a9909b52100002bc3f8c47bcb19e7a9cb58b1ac03fee95e81195
+072d3aa7c8079632725f63425a3550a947834d29ac9a26d0774e90248e18
+996731fd9aa53ab62b40ce557d98e874b763d9d629a173f0c7babfc00ae7
+82daef5f00cf3608ebeef403dbbc19e16a1d160b889f4a10359d9eacc19d
+7b5f126b31720dce7fc35ec861dfa56ea23fa18423ff4e8fe6e53fc6ba16
+b95a2b5dec00f614e4f835281ee0b4bf549e7e882689e0b445dd46fc40c9
+090e5575fa2c34b02a51ad0bccf6a7bb83ca3b929285e5e9fd054b72c47b
+733a66c5abda526b18b2e49d0746e067e63b948a45eab2f4221c5b62ae21
+a5d9d7cd8aa9eeb49588891d22c56b14b55ceb6488f02b73ab3b7f6c5555
+b75452594658255e4cd58ac4815f2e1bc3888c6777f62aac2f0a57d416c3
+765c991f0f9a33d888aeb2d527b482c042ee23783a04a73ad13dfc590a52
+f3116f8296cacc7ab29b7d87e7864561a5d0a12bde2d36ee697064f41d1b
+ca6ef2f801caab5295d19bf4c02b10c19f73b44635ba48a0806b967d7dfc
+ce9a4850171a78532cb30020c0d66b3b1e7c75eaa7894904c181a022e8bc
+9b2b8ef1202f3c7d36bcab4742d4a4761bb55b64da0d99685d319f5da8fa
+132be6c0483f50e2657ae8af1e28f969440d6ed43eb00e95fd9e1cd490a4
+8646f6d008598751f7a41b43fbec7770fe591012b6b0c4ae18775ccc7db5
+de0ded2dd53e82c89648d46f0d0cc5d3ac5aa104239608d512a4353b9547
+04fe6eb7e73d718323cf9d748b8ec5da01ec9358267de12cc22b05ef0312
+e4b6ac5dbb6d06d7f2d911f20d527f504d62547aef136834b3695df8044c
+383b6145e824d3931a602f081d9d656f84987a1ef121772f1f5b37a116bb
+d2e77d4ccda01411545d24e15ce595db4cd62ee876b8754df0b85b44e011
+b82d76ce45795e6c2c58be8690b734a8880a074f303a70da4a1b086a6de6
+56c02cc7a4c25258eff18cb0fd868214bb46f972e26509f868d065b3cb14
+1c316898cf22293391bd7051ac3a6927aada952a8fd0658ce63357c07f34
+acbf8c99a5537da0023e901f0eb5547e1b466b7d982c8c539798b76ee2a2
+252437a81a37c3b63f625172d682eeed0b795860b2755f020ef52a138353
+003c61be2052cdd7d73b2cdcd26b127660a7b22fc51a6a2f6034f37e3e46
+c1d7f83f8b28c7c965993abba1d358362833580d9c63fa85d4cb949f97de
+579fb6807b95a58b78f596db50055947dd0d0e597d9687083e9bc0266e86
+90b884b27f4094d8fb82ffdbaac4d580340a9ef8aa242be87e54b601af19
+87a48d267c04e371ae77163ebd0de3f5297b1060442ecdeac38334844e38
+0f294d4be73935fd8a38de7fba6d082c3d9156d7e88f2cfff0459377cbb6
+041f37a7e05010753b98e0b67d5827aa312129bb3c3bd883c12323756406
+d555720da8a0bb30edcfa760c01ecc2ba3b15fecccf5a10e9f358822e0ff
+b64178fce2ea6a1105bfb72df0e4bc499b207ae26b8ea960de48e7ee7010
+b4e671dff795e4cdc5b43e81b1604d224f0616ae311f1208859c502c1a10
+940e7b9cd11be728bd3a0c8005ae23aea32c1b642812198a6f1aed32cb75
+97152b1340dd35ada1b81051e393d38f3740fa9523df6a83b8ca7dbceb33
+6e299b54cd998d4dfef804733c76156585e42b7284cbcc4047ba6b290efc
+aa60953e98cd2b4bc2893857fa6a339f820142a52ccab0df09a2709df550
+f22e5921cbca408e7998cc1cccb8adf6d8f8b71e6685ae59d290fa33f5cd
+664d73e434237424060f634262f04e9a71a977556e93b692ddc3aad26d92
+97dde71e4def64932151ad572af6e681082e9944ddbec6e7a8bdfd534233
+9ca3106ca1ccc80eab14f1655978b137fad8f399df7cbfa2d7d3d9675e0e
+9afec37369a8ede2c93145ab3f42a375926946680c215fa16bf7416fc892
+bacd806cd424b9f85b47802c4336918f7486af2a03bf0d39b10169d35494
+419cb1ab7b8f407897f70c18303e91563b497d70b7181ede6aa0c3efe089
+ca6135b34dd1019b298e3677f8da61f864a67023c31eaa716c40cf3d397f
+9a1209564c9ec759c37028079661d2a56374203c78b023ec61340bce5d96
+e477a4f77e5c0db7c0d1257b4bbbc6f889b17e6eaab045b8adef6f931e4d
+0795583d60a6b7002cf61639c6f930671f3b8ac05a1c4e002f4bfc50d8b2
+3029fc4dce1b602cc3a5533336271bccc226559ffb127e3a562f92f89824
+552b9a70466d5a3c74ae515a222b109d490f26e8fc2d9d72bc8af6d1dcc7
+80463c7af81993bac2ce4aece9d95ab736b1dc73e32d1237bc8ec2b52513
+36dbabb4ecc7ceb5d18b02043281eb9a3bfdf19bc4853c9b1722ef1cdcf4
+fcec534923db2e2653dc48545a9850c0ac2e4594abc9f7d18a0bcf2fadfb
+bf085d465a4d10528312f5d790eb9511ca01061c0d94136b99a043bcf278
+c18223b1e0f1cc062b32b79e28dec2dc59a0aaa4b5f3506923c83e6a87fa
+08a1d941bb644c994491cf7f3b0e2ccf6c8a8ba89376f76dfdb592374f93
+528e78e31e0b18719346b9f1486f652638e3120687774030444674cb0778
+96385c41f6566819652d825dd58f9a4308ff79b45d7828dcbfebc406e40a
+c46e866cb0e3e97d6ce7fcac19a9d0fe39bbde66c5f0cf775eb3b1e6d7e1
+1f67e7edb3d5c4facc85c916bf13322b56a0414ca27d145cb740fa2c37cd
+8c142d9301f1ac3704cf6a8e93973a07fde5a331cf0cbb370c7ba555de61
+18a6cea0ecb2c0e37152390cc57e2e4fb3791ddbc383ee26b6f4006d0d68
+4880888011020f856a9de47f45440f127cf27ccaea7d40a3869d39ec7dec
+ebc06382d294717644b6118354e15544fd4c6d88df9245c9a83b30e6ce09
+e2498dd1df488a019b179cb859889e6ad2838f749e3b038b280ebc8d5c3a
+b03e8f15751214691edf0f86281e612d7ec0773c8a5d2b433266402df62f
+fcc06879ca196aaf1fc73a5f01ac46b44d6cbe7743ae9a862c20445ae2be
+1544f413d010280cc2941900bf3c42ec088cb21b44a915bb810e7666b545
+5324465c5943eedcef0c09128a995f431382e2062f5e39f4338c8eba1bca
+e553cb60bb8f3e5038ac8073398c49f06dc734b18afa7921ea0d455e6e73
+db8ad9f77fb5ba6c28af6b4f18cbe46cf842c82d6c960be1520a5fd929df
+ac7e00ede976fb2be0a07f659079a421fca693de89ce9b8fcb42b0176d9d
+f3ddd58f921e13e216933d27b49d175b423751c451be7618eaab054d3b8c
+23e8dd6fd60182d61e9b5c86b3b764a29a62f913ee7524d8cb33737d7224
+d95dc4bb8c2ad6397604a0ffecc8865adcb540e5da1cd769077838515118
+ebc9f0b988545c1881dd2e7a8fd73e11bd7ae9085fb4d45526b23a346b0f
+e4281ee3d588106db5f7c386c488d8f2f4dd02d4c08e74c1034f987a44e5
+d39fd07538de57a42987ce290fb2f6557e8b5cbcaec168f5780927226415
+1e11e3667d33b36a793aa53e9e2d1102c9eb30cb3ba0ebac953e0227fe4a
+3d3c0eb57e4390c3d35db0c41946e45be2830a1ae33fa25cf2c7c9cb4550
+ce9ff6c6e3d628fc7284daa6241604c90dde6339b7f7e7df3733416cdac8
+e5291357e4983d74d3582a490438a7fdb0af97001a31990b1de68e6adb48
+917daa387e647f9f13312db57310c7dedc2a2ea80800b4f4bbaa99c6b7b2
+7ac8345cb659489307e2565ebfd17774642c9ae5d3c18068dc35170c7d58
+4cf4173f1baf98137fa249c81f3347e1dadd6b1ba0f50c3b64c1eab183a0
+937b0f7278eff101e5267fa6480da7d602844416490c2c2c7eb0d44ac8f4
+75cfd611db5ec268db07c0b3608825c3e12834a2b2efaf5e2723c5199c42
+6011cf22e64e4c0d31d563f321097935ea0c6fcbf5acd3748d90079f6ab8
+687288dc55df29fe7958f566b27b73e2ea30747247f7a2b2add0602c7d64
+d23f52e7c96748e6a54ee8c4629b2aab8882169653f0ba7f05236bf14364
+244720f3259cbed73a318b29e4a9305deb65a2c9dec8a9d0f9a9f6fae541
+83e0f4b9a9a567057a1794945168dc23cec25d1c02ea9242c9fb6d8fc11e
+e8874bd80a5226373ae87cea91853d0625c777ceb1f5a6f3debcf2f75a61
+460c7b4067f568ecd01f62901ade8bf8fbc5db9c6720420496f0cb48a002
+99870773c2e7b12e83987a5d0290d9bbf589ac889bf7d4334a5147187a7f
+71008f216ce917ca4cfba5347078f354897fd87ac48af6a6c62711d2eb3a
+5882bf3b32c0f1bfda976f850c9dcb97170e78c229a27fd5e292d161ece9
+a8c47a223cbdc28e24f79f6429c72b5752a08f917feda941582c36d9acb5
+748c86072858d053170fdbf708971a0bd5a8d8034ec769cb72ea88eb5cd7
+49f35be6ee5e9b5df6021926cae9dac3f5ec2b33680b12e95fd4ecbf28eb
+a0503c10c6f2be6c7c47e9d66a0fae6038441c50e6447892f4aaf0a25ccd
+952c2e8b201bb479099f16fc4903993ac18d4667c84c124685ae7648a826
+6bc1701cc600964fdcc01258a72104a0e5e9996b34c2691a66fa20f48d7c
+2522333dfdabf3785f37dd9b021e8ee29fa10f76f43d5f935996cbf9d98d
+92d0a84ce65613f7c4a5052f4c408bf10679fc28a4a9ff848d9e0c4976bb
+dfdfb78bb934cd72434db596cb49e199f386a0bda69449ce2e11e3a4f53d
+be134c6d7fe452a0927cf6a9a15b2406f8bd354adcde0ce136378baa565f
+b9c51a03b1fbe1e166a1f92af26bd9f072250aaa6596a236ba2d5a200c90
+a760ca050421abc78223b2e8b2eea958ab23084fa1947574e846e48aeb12
+26cebb8b5a92089e9ea771557599e2fff44d75bcf600e76ae7289ba98cf3
+98208c5104562834f568ebd62801b988b0a9fdf132b6564566103b3d2d8e
+6a099b7fbad8a13b8cd7f6729bb6651fc1019e66c4bd6ff27410bd5cdae7
+4010bd68b066bffdb4fd5e3dd9cf7e1a1353f7a4c5157e3ad508f4ca0259
+9761b7cdd6a81b3560b8765be3b0432fe4c25dcb4001b00c7fa62874f681
+ed22127dc3974605a05be8d8fcf9701f859ffce4dc598091891ab7596ac3
+4cd851ecfd2dbbaa2f99dac376f7bb40703fd0700d7499a7c24726bdc9bb
+3b88c6a82e52686c1ee945d8825092bc81848a08722ac5a1d24353f95ec8
+18f3fa487d9600318091b0ae9874b42bb3cb683a2518b18cc1bd86c6e5e8
+3d37c14ef4fe0c77b03a3314995b1e7c1066b98c4375bd1fc5fadee1b024
+7ece4f95a0f59978d543910deb2e5761632c74c508269c4e4b9e315bda02
+975dc771fc30c8164b9df9172a4e571d8ca578cd2aaeaa0dd083e74cdc2e
+d938b984b96d76a64b8c5fd12e63220bbac41e5bcd5ccb6b84bdbf6a02d5
+934ac50c654c0853209a6758bcdf560e53566d78987484bb6672ebe93f22
+dcba14e3acc132a2d9ae837adde04d8b16
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%BeginResource: procset Altsys_header 4 0
+userdict begin /AltsysDict 245 dict def end
+AltsysDict begin
+/bdf{bind def}bind def
+/xdf{exch def}bdf
+/defed{where{pop true}{false}ifelse}bdf
+/ndf{1 index where{pop pop pop}{dup xcheck{bind}if def}ifelse}bdf
+/d{setdash}bdf
+/h{closepath}bdf
+/H{}bdf
+/J{setlinecap}bdf
+/j{setlinejoin}bdf
+/M{setmiterlimit}bdf
+/n{newpath}bdf
+/N{newpath}bdf
+/q{gsave}bdf
+/Q{grestore}bdf
+/w{setlinewidth}bdf
+/sepdef{
+ dup where not
+ {
+AltsysSepDict
+ }
+ if
+ 3 1 roll exch put
+}bdf
+/st{settransfer}bdf
+/colorimage defed /_rci xdf
+/_NXLevel2 defed {
+ _NXLevel2 not {
+/colorimage where {
+userdict eq {
+/_rci false def
+} if
+} if
+ } if
+} if
+/md defed{
+ md type /dicttype eq {
+/colorimage where {
+md eq {
+/_rci false def
+}if
+}if
+/settransfer where {
+md eq {
+/st systemdict /settransfer get def
+}if
+}if
+ }if
+}if
+/setstrokeadjust defed
+{
+ true setstrokeadjust
+ /C{curveto}bdf
+ /L{lineto}bdf
+ /m{moveto}bdf
+}
+{
+ /dr{transform .25 sub round .25 add
+exch .25 sub round .25 add exch itransform}bdf
+ /C{dr curveto}bdf
+ /L{dr lineto}bdf
+ /m{dr moveto}bdf
+ /setstrokeadjust{pop}bdf
+}ifelse
+/rectstroke defed /xt xdf
+xt {/yt save def} if
+/privrectpath {
+ 4 -2 roll m
+ dtransform round exch round exch idtransform
+ 2 copy 0 lt exch 0 lt xor
+ {dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto}
+ {exch dup 0 rlineto exch 0 exch rlineto neg 0 rlineto}
+ ifelse
+ closepath
+}bdf
+/rectclip{newpath privrectpath clip newpath}def
+/rectfill{gsave newpath privrectpath fill grestore}def
+/rectstroke{gsave newpath privrectpath stroke grestore}def
+xt {yt restore} if
+/_fonthacksave false def
+/currentpacking defed
+{
+ /_bfh {/_fonthacksave currentpacking def false setpacking} bdf
+ /_efh {_fonthacksave setpacking} bdf
+}
+{
+ /_bfh {} bdf
+ /_efh {} bdf
+}ifelse
+/packedarray{array astore readonly}ndf
+/`
+{
+ false setoverprint
+
+
+ /-save0- save def
+ 5 index concat
+ pop
+ storerect left bottom width height rectclip
+ pop
+
+ /dict_count countdictstack def
+ /op_count count 1 sub def
+ userdict begin
+
+ /showpage {} def
+
+ 0 setgray 0 setlinecap 1 setlinewidth
+ 0 setlinejoin 10 setmiterlimit [] 0 setdash newpath
+
+} bdf
+/currentpacking defed{true setpacking}if
+/min{2 copy gt{exch}if pop}bdf
+/max{2 copy lt{exch}if pop}bdf
+/xformfont { currentfont exch makefont setfont } bdf
+/fhnumcolors 1
+ statusdict begin
+/processcolors defed
+{
+pop processcolors
+}
+{
+/deviceinfo defed {
+deviceinfo /Colors known {
+pop deviceinfo /Colors get
+} if
+} if
+} ifelse
+ end
+def
+/printerRes
+ gsave
+ matrix defaultmatrix setmatrix
+ 72 72 dtransform
+ abs exch abs
+ max
+ grestore
+ def
+/graycalcs
+[
+ {Angle Frequency}
+ {GrayAngle GrayFrequency}
+ {0 Width Height matrix defaultmatrix idtransform
+dup mul exch dup mul add sqrt 72 exch div}
+ {0 GrayWidth GrayHeight matrix defaultmatrix idtransform
+dup mul exch dup mul add sqrt 72 exch div}
+] def
+/calcgraysteps {
+ forcemaxsteps
+ {
+maxsteps
+ }
+ {
+/currenthalftone defed
+{currenthalftone /dicttype eq}{false}ifelse
+{
+currenthalftone begin
+HalftoneType 4 le
+{graycalcs HalftoneType 1 sub get exec}
+{
+HalftoneType 5 eq
+{
+Default begin
+{graycalcs HalftoneType 1 sub get exec}
+end
+}
+{0 60}
+ifelse
+}
+ifelse
+end
+}
+{
+currentscreen pop exch
+}
+ifelse
+
+printerRes 300 max exch div exch
+2 copy
+sin mul round dup mul
+3 1 roll
+cos mul round dup mul
+add 1 add
+dup maxsteps gt {pop maxsteps} if
+ }
+ ifelse
+} bdf
+/nextrelease defed {
+ /languagelevel defed not {
+/framebuffer defed {
+0 40 string framebuffer 9 1 roll 8 {pop} repeat
+dup 516 eq exch 520 eq or
+{
+/fhnumcolors 3 def
+/currentscreen {60 0 {pop pop 1}}bdf
+/calcgraysteps {maxsteps} bdf
+}if
+}if
+ }if
+}if
+fhnumcolors 1 ne {
+ /calcgraysteps {maxsteps} bdf
+} if
+/currentpagedevice defed {
+
+
+ currentpagedevice /PreRenderingEnhance known
+ {
+currentpagedevice /PreRenderingEnhance get
+{
+/calcgraysteps
+{
+forcemaxsteps
+{maxsteps}
+{256 maxsteps min}
+ifelse
+} def
+} if
+ } if
+} if
+/gradfrequency 144 def
+printerRes 1000 lt {
+ /gradfrequency 72 def
+} if
+/adjnumsteps {
+
+ dup dtransform abs exch abs max
+
+ printerRes div
+
+ gradfrequency mul
+ round
+ 5 max
+ min
+}bdf
+/goodsep {
+ spots exch get 4 get dup sepname eq exch (_vc_Registration) eq or
+}bdf
+/BeginGradation defed
+{/bb{BeginGradation}bdf}
+{/bb{}bdf}
+ifelse
+/EndGradation defed
+{/eb{EndGradation}bdf}
+{/eb{}bdf}
+ifelse
+/bottom -0 def
+/delta -0 def
+/frac -0 def
+/height -0 def
+/left -0 def
+/numsteps1 -0 def
+/radius -0 def
+/right -0 def
+/top -0 def
+/width -0 def
+/xt -0 def
+/yt -0 def
+/df currentflat def
+/tempstr 1 string def
+/clipflatness currentflat def
+/inverted?
+ 0 currenttransfer exec .5 ge def
+/tc1 [0 0 0 1] def
+/tc2 [0 0 0 1] def
+/storerect{/top xdf /right xdf /bottom xdf /left xdf
+/width right left sub def /height top bottom sub def}bdf
+/concatprocs{
+ systemdict /packedarray known
+ {dup type /packedarraytype eq 2 index type /packedarraytype eq or}{false}ifelse
+ {
+/proc2 exch cvlit def /proc1 exch cvlit def
+proc1 aload pop proc2 aload pop
+proc1 length proc2 length add packedarray cvx
+ }
+ {
+/proc2 exch cvlit def /proc1 exch cvlit def
+/newproc proc1 length proc2 length add array def
+newproc 0 proc1 putinterval newproc proc1 length proc2 putinterval
+newproc cvx
+ }ifelse
+}bdf
+/i{dup 0 eq
+ {pop df dup}
+ {dup} ifelse
+ /clipflatness xdf setflat
+}bdf
+version cvr 38.0 le
+{/setrgbcolor{
+currenttransfer exec 3 1 roll
+currenttransfer exec 3 1 roll
+currenttransfer exec 3 1 roll
+setrgbcolor}bdf}if
+/vms {/vmsv save def} bdf
+/vmr {vmsv restore} bdf
+/vmrs{vmsv restore /vmsv save def}bdf
+/eomode{
+ {/filler /eofill load def /clipper /eoclip load def}
+ {/filler /fill load def /clipper /clip load def}
+ ifelse
+}bdf
+/normtaper{}bdf
+/logtaper{9 mul 1 add log}bdf
+/CD{
+ /NF exch def
+ {
+exch dup
+/FID ne 1 index/UniqueID ne and
+{exch NF 3 1 roll put}
+{pop pop}
+ifelse
+ }forall
+ NF
+}bdf
+/MN{
+ 1 index length
+ /Len exch def
+ dup length Len add
+ string dup
+ Len
+ 4 -1 roll
+ putinterval
+ dup
+ 0
+ 4 -1 roll
+ putinterval
+}bdf
+/RC{4 -1 roll /ourvec xdf 256 string cvs(|______)anchorsearch
+ {1 index MN cvn/NewN exch def cvn
+ findfont dup maxlength dict CD dup/FontName NewN put dup
+ /Encoding ourvec put NewN exch definefont pop}{pop}ifelse}bdf
+/RF{
+ dup
+ FontDirectory exch
+ known
+ {pop 3 -1 roll pop}
+ {RC}
+ ifelse
+}bdf
+/FF{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known
+ {exch pop findfont 3 -1 roll pop}
+ {pop dup findfont dup maxlength dict CD dup dup
+ /Encoding exch /Encoding get 256 array copy 7 -1 roll
+ {3 -1 roll dup 4 -2 roll put}forall put definefont}
+ ifelse}bdf
+/RFJ{
+ dup
+ FontDirectory exch
+ known
+ {pop 3 -1 roll pop
+ FontDirectory /Ryumin-Light-83pv-RKSJ-H known
+ {pop pop /Ryumin-Light-83pv-RKSJ-H dup}if
+ }
+ {RC}
+ ifelse
+}bdf
+/FFJ{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known
+ {exch pop findfont 3 -1 roll pop}
+ {pop
+dup FontDirectory exch known not
+ {FontDirectory /Ryumin-Light-83pv-RKSJ-H known
+{pop /Ryumin-Light-83pv-RKSJ-H}if
+ }if
+ dup findfont dup maxlength dict CD dup dup
+ /Encoding exch /Encoding get 256 array copy 7 -1 roll
+ {3 -1 roll dup 4 -2 roll put}forall put definefont}
+ ifelse}bdf
+/fps{
+ currentflat
+ exch
+ dup 0 le{pop 1}if
+ {
+dup setflat 3 index stopped
+{1.3 mul dup 3 index gt{pop setflat pop pop stop}if}
+{exit}
+ifelse
+ }loop
+ pop setflat pop pop
+}bdf
+/fp{100 currentflat fps}bdf
+/clipper{clip}bdf
+/W{/clipper load 100 clipflatness dup setflat fps}bdf
+userdict begin /BDFontDict 29 dict def end
+BDFontDict begin
+/bu{}def
+/bn{}def
+/setTxMode{av 70 ge{pop}if pop}def
+/gm{m}def
+/show{pop}def
+/gr{pop}def
+/fnt{pop pop pop}def
+/fs{pop}def
+/fz{pop}def
+/lin{pop pop}def
+/:M {pop pop} def
+/sf {pop} def
+/S {pop} def
+/@b {pop pop pop pop pop pop pop pop} def
+/_bdsave /save load def
+/_bdrestore /restore load def
+/save { dup /fontsave eq {null} {_bdsave} ifelse } def
+/restore { dup null eq { pop } { _bdrestore } ifelse } def
+/fontsave null def
+end
+/MacVec 256 array def
+MacVec 0 /Helvetica findfont
+/Encoding get 0 128 getinterval putinterval
+MacVec 127 /DEL put MacVec 16#27 /quotesingle put MacVec 16#60 /grave put
+/NUL/SOH/STX/ETX/EOT/ENQ/ACK/BEL/BS/HT/LF/VT/FF/CR/SO/SI
+/DLE/DC1/DC2/DC3/DC4/NAK/SYN/ETB/CAN/EM/SUB/ESC/FS/GS/RS/US
+MacVec 0 32 getinterval astore pop
+/Adieresis/Aring/Ccedilla/Eacute/Ntilde/Odieresis/Udieresis/aacute
+/agrave/acircumflex/adieresis/atilde/aring/ccedilla/eacute/egrave
+/ecircumflex/edieresis/iacute/igrave/icircumflex/idieresis/ntilde/oacute
+/ograve/ocircumflex/odieresis/otilde/uacute/ugrave/ucircumflex/udieresis
+/dagger/degree/cent/sterling/section/bullet/paragraph/germandbls
+/registered/copyright/trademark/acute/dieresis/notequal/AE/Oslash
+/infinity/plusminus/lessequal/greaterequal/yen/mu/partialdiff/summation
+/product/pi/integral/ordfeminine/ordmasculine/Omega/ae/oslash
+/questiondown/exclamdown/logicalnot/radical/florin/approxequal/Delta/guillemotleft
+/guillemotright/ellipsis/nbspace/Agrave/Atilde/Otilde/OE/oe
+/endash/emdash/quotedblleft/quotedblright/quoteleft/quoteright/divide/lozenge
+/ydieresis/Ydieresis/fraction/currency/guilsinglleft/guilsinglright/fi/fl
+/daggerdbl/periodcentered/quotesinglbase/quotedblbase
+/perthousand/Acircumflex/Ecircumflex/Aacute
+/Edieresis/Egrave/Iacute/Icircumflex/Idieresis/Igrave/Oacute/Ocircumflex
+/apple/Ograve/Uacute/Ucircumflex/Ugrave/dotlessi/circumflex/tilde
+/macron/breve/dotaccent/ring/cedilla/hungarumlaut/ogonek/caron
+MacVec 128 128 getinterval astore pop
+end %. AltsysDict
+%%EndResource
+%%EndProlog
+%%BeginSetup
+AltsysDict begin
+_bfh
+%%IncludeResource: font Symbol
+_efh
+0 dict dup begin
+end
+/f0 /Symbol FF def
+_bfh
+%%IncludeResource: font ZapfHumanist601BT-Bold
+_efh
+0 dict dup begin
+end
+/f1 /ZapfHumanist601BT-Bold FF def
+end %. AltsysDict
+%%EndSetup
+AltsysDict begin
+/onlyk4{false}ndf
+/ccmyk{dup 5 -1 roll sub 0 max exch}ndf
+/cmyk2gray{
+ 4 -1 roll 0.3 mul 4 -1 roll 0.59 mul 4 -1 roll 0.11 mul
+ add add add 1 min neg 1 add
+}bdf
+/setcmykcolor{1 exch sub ccmyk ccmyk ccmyk pop setrgbcolor}ndf
+/maxcolor {
+ max max max
+} ndf
+/maxspot {
+ pop
+} ndf
+/setcmykcoloroverprint{4{dup -1 eq{pop 0}if 4 1 roll}repeat setcmykcolor}ndf
+/findcmykcustomcolor{5 packedarray}ndf
+/setcustomcolor{exch aload pop pop 4{4 index mul 4 1 roll}repeat setcmykcolor pop}ndf
+/setseparationgray{setgray}ndf
+/setoverprint{pop}ndf
+/currentoverprint false ndf
+/cmykbufs2gray{
+ 0 1 2 index length 1 sub
+ {
+4 index 1 index get 0.3 mul
+4 index 2 index get 0.59 mul
+4 index 3 index get 0.11 mul
+4 index 4 index get
+add add add cvi 255 min
+255 exch sub
+2 index 3 1 roll put
+ }for
+ 4 1 roll pop pop pop
+}bdf
+/colorimage{
+ pop pop
+ [
+5 -1 roll/exec cvx
+6 -1 roll/exec cvx
+7 -1 roll/exec cvx
+8 -1 roll/exec cvx
+/cmykbufs2gray cvx
+ ]cvx
+ image
+}
+%. version 47.1 on Linotronic of Postscript defines colorimage incorrectly (rgb model only)
+version cvr 47.1 le
+statusdict /product get (Lino) anchorsearch{pop pop true}{pop false}ifelse
+and{userdict begin bdf end}{ndf}ifelse
+fhnumcolors 1 ne {/yt save def} if
+/customcolorimage{
+ aload pop
+ (_vc_Registration) eq
+ {
+pop pop pop pop separationimage
+ }
+ {
+/ik xdf /iy xdf /im xdf /ic xdf
+ic im iy ik cmyk2gray /xt xdf
+currenttransfer
+{dup 1.0 exch sub xt mul add}concatprocs
+st
+image
+ }
+ ifelse
+}ndf
+fhnumcolors 1 ne {yt restore} if
+fhnumcolors 3 ne {/yt save def} if
+/customcolorimage{
+ aload pop
+ (_vc_Registration) eq
+ {
+pop pop pop pop separationimage
+ }
+ {
+/ik xdf /iy xdf /im xdf /ic xdf
+1.0 dup ic ik add min sub
+1.0 dup im ik add min sub
+1.0 dup iy ik add min sub
+/ic xdf /iy xdf /im xdf
+currentcolortransfer
+4 1 roll
+{dup 1.0 exch sub ic mul add}concatprocs 4 1 roll
+{dup 1.0 exch sub iy mul add}concatprocs 4 1 roll
+{dup 1.0 exch sub im mul add}concatprocs 4 1 roll
+setcolortransfer
+{/dummy xdf dummy}concatprocs{dummy}{dummy}true 3 colorimage
+ }
+ ifelse
+}ndf
+fhnumcolors 3 ne {yt restore} if
+fhnumcolors 4 ne {/yt save def} if
+/customcolorimage{
+ aload pop
+ (_vc_Registration) eq
+ {
+pop pop pop pop separationimage
+ }
+ {
+/ik xdf /iy xdf /im xdf /ic xdf
+currentcolortransfer
+{1.0 exch sub ik mul ik sub 1 add}concatprocs 4 1 roll
+{1.0 exch sub iy mul iy sub 1 add}concatprocs 4 1 roll
+{1.0 exch sub im mul im sub 1 add}concatprocs 4 1 roll
+{1.0 exch sub ic mul ic sub 1 add}concatprocs 4 1 roll
+setcolortransfer
+{/dummy xdf dummy}concatprocs{dummy}{dummy}{dummy}
+true 4 colorimage
+ }
+ ifelse
+}ndf
+fhnumcolors 4 ne {yt restore} if
+/separationimage{image}ndf
+/newcmykcustomcolor{6 packedarray}ndf
+/inkoverprint false ndf
+/setinkoverprint{pop}ndf
+/setspotcolor {
+ spots exch get
+ dup 4 get (_vc_Registration) eq
+ {pop 1 exch sub setseparationgray}
+ {0 5 getinterval exch setcustomcolor}
+ ifelse
+}ndf
+/currentcolortransfer{currenttransfer dup dup dup}ndf
+/setcolortransfer{st pop pop pop}ndf
+/fas{}ndf
+/sas{}ndf
+/fhsetspreadsize{pop}ndf
+/filler{fill}bdf
+/F{gsave {filler}fp grestore}bdf
+/f{closepath F}bdf
+/S{gsave {stroke}fp grestore}bdf
+/s{closepath S}bdf
+/bc4 [0 0 0 0] def
+/_lfp4 {
+ /iosv inkoverprint def
+ /cosv currentoverprint def
+ /yt xdf
+ /xt xdf
+ /ang xdf
+ storerect
+ /taperfcn xdf
+ /k2 xdf /y2 xdf /m2 xdf /c2 xdf
+ /k1 xdf /y1 xdf /m1 xdf /c1 xdf
+ c1 c2 sub abs
+ m1 m2 sub abs
+ y1 y2 sub abs
+ k1 k2 sub abs
+ maxcolor
+ calcgraysteps mul abs round
+ height abs adjnumsteps
+ dup 2 lt {pop 1} if
+ 1 sub /numsteps1 xdf
+ currentflat mark
+ currentflat clipflatness
+ /delta top bottom sub numsteps1 1 add div def
+ /right right left sub def
+ /botsv top delta sub def
+ {
+{
+W
+xt yt translate
+ang rotate
+xt neg yt neg translate
+dup setflat
+/bottom botsv def
+0 1 numsteps1
+{
+numsteps1 dup 0 eq {pop 0.5 } { div } ifelse
+taperfcn /frac xdf
+bc4 0 c2 c1 sub frac mul c1 add put
+bc4 1 m2 m1 sub frac mul m1 add put
+bc4 2 y2 y1 sub frac mul y1 add put
+bc4 3 k2 k1 sub frac mul k1 add put
+bc4 vc
+1 index setflat
+{
+mark {newpath left bottom right delta rectfill}stopped
+{cleartomark exch 1.3 mul dup setflat exch 2 copy gt{stop}if}
+{cleartomark exit}ifelse
+}loop
+/bottom bottom delta sub def
+}for
+}
+gsave stopped grestore
+{exch pop 2 index exch 1.3 mul dup 100 gt{cleartomark setflat stop}if}
+{exit}ifelse
+ }loop
+ cleartomark setflat
+ iosv setinkoverprint
+ cosv setoverprint
+}bdf
+/bcs [0 0] def
+/_lfs4 {
+ /iosv inkoverprint def
+ /cosv currentoverprint def
+ /yt xdf
+ /xt xdf
+ /ang xdf
+ storerect
+ /taperfcn xdf
+ /tint2 xdf
+ /tint1 xdf
+ bcs exch 1 exch put
+ tint1 tint2 sub abs
+ bcs 1 get maxspot
+ calcgraysteps mul abs round
+ height abs adjnumsteps
+ dup 2 lt {pop 2} if
+ 1 sub /numsteps1 xdf
+ currentflat mark
+ currentflat clipflatness
+ /delta top bottom sub numsteps1 1 add div def
+ /right right left sub def
+ /botsv top delta sub def
+ {
+{
+W
+xt yt translate
+ang rotate
+xt neg yt neg translate
+dup setflat
+/bottom botsv def
+0 1 numsteps1
+{
+numsteps1 div taperfcn /frac xdf
+bcs 0
+1.0 tint2 tint1 sub frac mul tint1 add sub
+put bcs vc
+1 index setflat
+{
+mark {newpath left bottom right delta rectfill}stopped
+{cleartomark exch 1.3 mul dup setflat exch 2 copy gt{stop}if}
+{cleartomark exit}ifelse
+}loop
+/bottom bottom delta sub def
+}for
+}
+gsave stopped grestore
+{exch pop 2 index exch 1.3 mul dup 100 gt{cleartomark setflat stop}if}
+{exit}ifelse
+ }loop
+ cleartomark setflat
+ iosv setinkoverprint
+ cosv setoverprint
+}bdf
+/_rfs4 {
+ /iosv inkoverprint def
+ /cosv currentoverprint def
+ /tint2 xdf
+ /tint1 xdf
+ bcs exch 1 exch put
+ /radius xdf
+ /yt xdf
+ /xt xdf
+ tint1 tint2 sub abs
+ bcs 1 get maxspot
+ calcgraysteps mul abs round
+ radius abs adjnumsteps
+ dup 2 lt {pop 2} if
+ 1 sub /numsteps1 xdf
+ radius numsteps1 div 2 div /halfstep xdf
+ currentflat mark
+ currentflat clipflatness
+ {
+{
+dup setflat
+W
+0 1 numsteps1
+{
+dup /radindex xdf
+numsteps1 div /frac xdf
+bcs 0
+tint2 tint1 sub frac mul tint1 add
+put bcs vc
+1 index setflat
+{
+newpath mark xt yt radius 1 frac sub mul halfstep add 0 360
+{ arc
+radindex numsteps1 ne
+{
+xt yt
+radindex 1 add numsteps1
+div 1 exch sub
+radius mul halfstep add
+dup xt add yt moveto
+360 0 arcn
+} if
+fill
+}stopped
+{cleartomark exch 1.3 mul dup setflat exch 2 copy gt{stop}if}
+{cleartomark exit}ifelse
+}loop
+}for
+}
+gsave stopped grestore
+{exch pop 2 index exch 1.3 mul dup 100 gt{cleartomark setflat stop}if}
+{exit}ifelse
+ }loop
+ cleartomark setflat
+ iosv setinkoverprint
+ cosv setoverprint
+}bdf
+/_rfp4 {
+ /iosv inkoverprint def
+ /cosv currentoverprint def
+ /k2 xdf /y2 xdf /m2 xdf /c2 xdf
+ /k1 xdf /y1 xdf /m1 xdf /c1 xdf
+ /radius xdf
+ /yt xdf
+ /xt xdf
+ c1 c2 sub abs
+ m1 m2 sub abs
+ y1 y2 sub abs
+ k1 k2 sub abs
+ maxcolor
+ calcgraysteps mul abs round
+ radius abs adjnumsteps
+ dup 2 lt {pop 1} if
+ 1 sub /numsteps1 xdf
+ radius numsteps1 dup 0 eq {pop} {div} ifelse
+ 2 div /halfstep xdf
+ currentflat mark
+ currentflat clipflatness
+ {
+{
+dup setflat
+W
+0 1 numsteps1
+{
+dup /radindex xdf
+numsteps1 dup 0 eq {pop 0.5 } { div } ifelse
+/frac xdf
+bc4 0 c2 c1 sub frac mul c1 add put
+bc4 1 m2 m1 sub frac mul m1 add put
+bc4 2 y2 y1 sub frac mul y1 add put
+bc4 3 k2 k1 sub frac mul k1 add put
+bc4 vc
+1 index setflat
+{
+newpath mark xt yt radius 1 frac sub mul halfstep add 0 360
+{ arc
+radindex numsteps1 ne
+{
+xt yt
+radindex 1 add
+numsteps1 dup 0 eq {pop} {div} ifelse
+1 exch sub
+radius mul halfstep add
+dup xt add yt moveto
+360 0 arcn
+} if
+fill
+}stopped
+{cleartomark exch 1.3 mul dup setflat exch 2 copy gt{stop}if}
+{cleartomark exit}ifelse
+}loop
+}for
+}
+gsave stopped grestore
+{exch pop 2 index exch 1.3 mul dup 100 gt{cleartomark setflat stop}if}
+{exit}ifelse
+ }loop
+ cleartomark setflat
+ iosv setinkoverprint
+ cosv setoverprint
+}bdf
+/lfp4{_lfp4}ndf
+/lfs4{_lfs4}ndf
+/rfs4{_rfs4}ndf
+/rfp4{_rfp4}ndf
+/cvc [0 0 0 1] def
+/vc{
+ AltsysDict /cvc 2 index put
+ aload length 4 eq
+ {setcmykcolor}
+ {setspotcolor}
+ ifelse
+}bdf
+/origmtx matrix currentmatrix def
+/ImMatrix matrix currentmatrix def
+0 setseparationgray
+/imgr {1692 1570.1102 2287.2756 2412 } def
+/bleed 0 def
+/clpr {1692 1570.1102 2287.2756 2412 } def
+/xs 1 def
+/ys 1 def
+/botx 0 def
+/overlap 0 def
+/wdist 18 def
+0 2 mul fhsetspreadsize
+0 0 ne {/df 0 def /clipflatness 0 def} if
+/maxsteps 256 def
+/forcemaxsteps false def
+vms
+-1845 -1956 translate
+/currentpacking defed{false setpacking}if
+/spots[
+1 0 0 0 (Process Cyan) false newcmykcustomcolor
+0 1 0 0 (Process Magenta) false newcmykcustomcolor
+0 0 1 0 (Process Yellow) false newcmykcustomcolor
+0 0 0 1 (Process Black) false newcmykcustomcolor
+]def
+/textopf false def
+/curtextmtx{}def
+/otw .25 def
+/msf{dup/curtextmtx xdf makefont setfont}bdf
+/makesetfont/msf load def
+/curtextheight{.707104 .707104 curtextmtx dtransform
+ dup mul exch dup mul add sqrt}bdf
+/ta2{
+tempstr 2 index gsave exec grestore
+cwidth cheight rmoveto
+4 index eq{5 index 5 index rmoveto}if
+2 index 2 index rmoveto
+}bdf
+/ta{exch systemdict/cshow known
+{{/cheight xdf/cwidth xdf tempstr 0 2 index put ta2}exch cshow}
+{{tempstr 0 2 index put tempstr stringwidth/cheight xdf/cwidth xdf ta2}forall}
+ifelse 6{pop}repeat}bdf
+/sts{/textopf currentoverprint def vc setoverprint
+/ts{awidthshow}def exec textopf setoverprint}bdf
+/stol{/xt currentlinewidth def
+ setlinewidth vc newpath
+ /ts{{false charpath stroke}ta}def exec
+ xt setlinewidth}bdf
+
+/strk{/textopf currentoverprint def vc setoverprint
+ /ts{{false charpath stroke}ta}def exec
+ textopf setoverprint
+ }bdf
+n
+[] 0 d
+3.863708 M
+1 w
+0 j
+0 J
+false setoverprint
+0 i
+false eomode
+[0 0 0 1] vc
+vms
+%white border -- disabled
+%1845.2293 2127.8588 m
+%2045.9437 2127.8588 L
+%2045.9437 1956.1412 L
+%1845.2293 1956.1412 L
+%1845.2293 2127.8588 L
+%0.1417 w
+%2 J
+%2 M
+%[0 0 0 0] vc
+%s
+n
+1950.8 2097.2 m
+1958.8 2092.5 1967.3 2089 1975.5 2084.9 C
+1976.7 2083.5 1976.1 2081.5 1976.7 2079.9 C
+1979.6 2081.1 1981.6 2086.8 1985.3 2084 C
+1993.4 2079.3 2001.8 2075.8 2010 2071.7 C
+2010.5 2071.5 2010.5 2071.1 2010.8 2070.8 C
+2011.2 2064.3 2010.9 2057.5 2011 2050.8 C
+2015.8 2046.9 2022.2 2046.2 2026.6 2041.7 C
+2026.5 2032.5 2026.8 2022.9 2026.4 2014.1 C
+2020.4 2008.3 2015 2002.4 2008.8 1997.1 C
+2003.8 1996.8 2000.7 2001.2 1996.1 2002.1 C
+1995.2 1996.4 1996.9 1990.5 1995.6 1984.8 C
+1989.9 1979 1984.5 1973.9 1978.8 1967.8 C
+1977.7 1968.6 1976 1967.6 1974.5 1968.3 C
+1967.4 1972.5 1960.1 1976.1 1952.7 1979.3 C
+1946.8 1976.3 1943.4 1970.7 1938.5 1966.1 C
+1933.9 1966.5 1929.4 1968.8 1925.1 1970.7 C
+1917.2 1978.2 1906 1977.9 1897.2 1983.4 C
+1893.2 1985.6 1889.4 1988.6 1885 1990.1 C
+1884.6 1990.6 1883.9 1991 1883.8 1991.6 C
+1883.7 2000.4 1884 2009.9 1883.6 2018.9 C
+1887.7 2024 1893.2 2028.8 1898 2033.8 C
+1899.1 2035.5 1900.9 2036.8 1902.5 2037.9 C
+1903.9 2037.3 1905.2 2036.6 1906.4 2035.5 C
+1906.3 2039.7 1906.5 2044.6 1906.1 2048.9 C
+1906.3 2049.6 1906.7 2050.2 1907.1 2050.8 C
+1913.4 2056 1918.5 2062.7 1924.8 2068.1 C
+1926.6 2067.9 1928 2066.9 1929.4 2066 C
+1930.2 2071 1927.7 2077.1 1930.6 2081.6 C
+1936.6 2086.9 1941.5 2092.9 1947.9 2097.9 C
+1949 2098.1 1949.9 2097.5 1950.8 2097.2 C
+[0 0 0 0.18] vc
+f
+0.4 w
+S
+n
+1975.2 2084.7 m
+1976.6 2083.4 1975.7 2081.1 1976 2079.4 C
+1979.3 2079.5 1980.9 2086.2 1984.8 2084 C
+1992.9 2078.9 2001.7 2075.6 2010 2071.2 C
+2011 2064.6 2010.2 2057.3 2010.8 2050.6 C
+2015.4 2046.9 2021.1 2045.9 2025.9 2042.4 C
+2026.5 2033.2 2026.8 2022.9 2025.6 2013.9 C
+2020.5 2008.1 2014.5 2003.1 2009.3 1997.6 C
+2004.1 1996.7 2000.7 2001.6 1995.9 2002.6 C
+1995.2 1996.7 1996.3 1990.2 1994.9 1984.6 C
+1989.8 1978.7 1983.6 1973.7 1978.4 1968 C
+1977.3 1969.3 1976 1967.6 1974.8 1968.5 C
+1967.7 1972.7 1960.4 1976.3 1952.9 1979.6 C
+1946.5 1976.9 1943.1 1970.5 1937.8 1966.1 C
+1928.3 1968.2 1920.6 1974.8 1911.6 1978.4 C
+1901.9 1979.7 1893.9 1986.6 1885 1990.6 C
+1884.3 1991 1884.3 1991.7 1884 1992.3 C
+1884.5 2001 1884.2 2011 1884.3 2019.9 C
+1890.9 2025.3 1895.9 2031.9 1902.3 2037.4 C
+1904.2 2037.9 1905.6 2034.2 1906.8 2035.7 C
+1907.4 2040.9 1905.7 2046.1 1907.3 2050.8 C
+1913.6 2056.2 1919.2 2062.6 1925.1 2067.9 C
+1926.9 2067.8 1928 2066.3 1929.6 2065.7 C
+1929.9 2070.5 1929.2 2076 1930.1 2080.8 C
+1936.5 2086.1 1941.6 2092.8 1948.4 2097.6 C
+1957.3 2093.3 1966.2 2088.8 1975.2 2084.7 C
+[0 0 0 0] vc
+f
+S
+n
+1954.8 2093.8 m
+1961.6 2090.5 1968.2 2087 1975 2084 C
+1975 2082.8 1975.6 2080.9 1974.8 2080.6 C
+1974.3 2075.2 1974.6 2069.6 1974.5 2064 C
+1977.5 2059.7 1984.5 2060 1988.9 2056.4 C
+1989.5 2055.5 1990.5 2055.3 1990.8 2054.4 C
+1991.1 2045.7 1991.4 2036.1 1990.6 2027.8 C
+1990.7 2026.6 1992 2027.3 1992.8 2027.1 C
+1997 2032.4 2002.6 2037.8 2007.6 2042.2 C
+2008.7 2042.3 2007.8 2040.6 2007.4 2040 C
+2002.3 2035.6 1997.5 2030 1992.8 2025.2 C
+1991.6 2024.7 1990.8 2024.9 1990.1 2025.4 C
+1989.4 2024.9 1988.1 2025.2 1987.2 2024.4 C
+1987.1 2025.8 1988.3 2026.5 1989.4 2026.8 C
+1989.4 2026.6 1989.3 2026.2 1989.6 2026.1 C
+1989.9 2026.2 1989.9 2026.6 1989.9 2026.8 C
+1989.8 2026.6 1990 2026.5 1990.1 2026.4 C
+1990.2 2027 1991.1 2028.3 1990.1 2028 C
+1989.9 2037.9 1990.5 2044.1 1989.6 2054.2 C
+1985.9 2058 1979.7 2057.4 1976 2061.2 C
+1974.5 2061.6 1975.2 2059.9 1974.5 2059.5 C
+1973.9 2058 1975.6 2057.8 1975 2056.6 C
+1974.5 2057.1 1974.6 2055.3 1973.6 2055.9 C
+1971.9 2059.3 1974.7 2062.1 1973.1 2065.5 C
+1973.1 2071.2 1972.9 2077 1973.3 2082.5 C
+1967.7 2085.6 1962 2088 1956.3 2090.7 C
+1953.9 2092.4 1951 2093 1948.6 2094.8 C
+1943.7 2089.9 1937.9 2084.3 1933 2079.6 C
+1931.3 2076.1 1933.2 2071.3 1932.3 2067.2 C
+1931.3 2062.9 1933.3 2060.6 1932 2057.6 C
+1932.7 2056.5 1930.9 2053.3 1933.2 2051.8 C
+1936.8 2050.1 1940.1 2046.9 1944 2046.8 C
+1946.3 2049.7 1949.3 2051.9 1952 2054.4 C
+1954.5 2054.2 1956.4 2052.3 1958.7 2051.3 C
+1960.8 2050 1963.2 2049 1965.6 2048.4 C
+1968.3 2050.8 1970.7 2054.3 1973.6 2055.4 C
+1973 2052.2 1969.7 2050.4 1967.6 2048.2 C
+1967.1 2046.7 1968.8 2046.6 1969.5 2045.8 C
+1972.8 2043.3 1980.6 2043.4 1979.3 2038.4 C
+1979.4 2038.6 1979.2 2038.7 1979.1 2038.8 C
+1978.7 2038.6 1978.9 2038.1 1978.8 2037.6 C
+1978.9 2037.9 1978.7 2038 1978.6 2038.1 C
+1978.2 2032.7 1978.4 2027.1 1978.4 2021.6 C
+1979.3 2021.1 1980 2020.2 1981.5 2020.1 C
+1983.5 2020.5 1984 2021.8 1985.1 2023.5 C
+1985.7 2024 1987.4 2023.7 1986 2022.8 C
+1984.7 2021.7 1983.3 2020.8 1983.9 2018.7 C
+1987.2 2015.9 1993 2015.4 1994.9 2011.5 C
+1992.2 2004.9 1999.3 2005.2 2002.1 2002.4 C
+2005.9 2002.7 2004.8 1997.4 2009.1 1999 C
+2011 1999.3 2010 2002.9 2012.7 2002.4 C
+2010.2 2000.7 2009.4 1996.1 2005.5 1998.5 C
+2002.1 2000.3 1999 2002.5 1995.4 2003.8 C
+1995.2 2003.6 1994.9 2003.3 1994.7 2003.1 C
+1994.3 1997 1995.6 1991.1 1994.4 1985.3 C
+1994.3 1986 1993.8 1985 1994 1985.6 C
+1993.8 1995.4 1994.4 2001.6 1993.5 2011.7 C
+1989.7 2015.5 1983.6 2014.9 1979.8 2018.7 C
+1978.3 2019.1 1979.1 2017.4 1978.4 2017 C
+1977.8 2015.5 1979.4 2015.3 1978.8 2014.1 C
+1978.4 2014.6 1978.5 2012.8 1977.4 2013.4 C
+1975.8 2016.8 1978.5 2019.6 1976.9 2023 C
+1977 2028.7 1976.7 2034.5 1977.2 2040 C
+1971.6 2043.1 1965.8 2045.6 1960.1 2048.2 C
+1957.7 2049.9 1954.8 2050.5 1952.4 2052.3 C
+1947.6 2047.4 1941.8 2041.8 1936.8 2037.2 C
+1935.2 2033.6 1937.1 2028.8 1936.1 2024.7 C
+1935.1 2020.4 1937.1 2018.1 1935.9 2015.1 C
+1936.5 2014.1 1934.7 2010.8 1937.1 2009.3 C
+1944.4 2004.8 1952 2000.9 1959.9 1997.8 C
+1963.9 1997 1963.9 2001.9 1966.8 2003.3 C
+1970.3 2006.9 1973.7 2009.9 1976.9 2012.9 C
+1977.9 2013 1977.1 2011.4 1976.7 2010.8 C
+1971.6 2006.3 1966.8 2000.7 1962 1995.9 C
+1960 1995.2 1960.1 1996.6 1958.2 1995.6 C
+1957 1997 1955.1 1998.8 1953.2 1998 C
+1951.7 1994.5 1954.1 1993.4 1952.9 1991.1 C
+1952.1 1990.5 1953.3 1990.2 1953.2 1989.6 C
+1954.2 1986.8 1950.9 1981.4 1954.4 1981.2 C
+1954.7 1981.6 1954.7 1981.7 1955.1 1982 C
+1961.9 1979.1 1967.6 1975 1974.3 1971.6 C
+1974.7 1969.8 1976.7 1969.5 1978.4 1969.7 C
+1980.3 1970 1979.3 1973.6 1982 1973.1 C
+1975.8 1962.2 1968 1975.8 1960.8 1976.7 C
+1956.9 1977.4 1953.3 1982.4 1949.1 1978.8 C
+1946 1975.8 1941.2 1971 1939.5 1969.2 C
+1938.5 1968.6 1938.9 1967.4 1937.8 1966.8 C
+1928.7 1969.4 1920.6 1974.5 1912.4 1979.1 C
+1904 1980 1896.6 1985 1889.3 1989.4 C
+1887.9 1990.4 1885.1 1990.3 1885 1992.5 C
+1885.4 2000.6 1885.2 2012.9 1885.2 2019.9 C
+1886.1 2022 1889.7 2019.5 1888.4 2022.8 C
+1889 2023.3 1889.8 2024.4 1890.3 2024 C
+1891.2 2023.5 1891.8 2028.2 1893.4 2026.6 C
+1894.2 2026.3 1893.9 2027.3 1894.4 2027.6 C
+1893.4 2027.6 1894.7 2028.3 1894.1 2028.5 C
+1894.4 2029.6 1896 2030 1896 2029.2 C
+1896.2 2029 1896.3 2029 1896.5 2029.2 C
+1896.8 2029.8 1897.3 2030 1897 2030.7 C
+1896.5 2030.7 1896.9 2031.5 1897.2 2031.6 C
+1898.3 2034 1899.5 2030.6 1899.6 2033.3 C
+1898.5 2033 1899.6 2034.4 1900.1 2034.8 C
+1901.3 2035.8 1903.2 2034.6 1902.5 2036.7 C
+1904.4 2036.9 1906.1 2032.2 1907.6 2035.5 C
+1907.5 2040.1 1907.7 2044.9 1907.3 2049.4 C
+1908 2050.2 1908.3 2051.4 1909.5 2051.6 C
+1910.1 2051.1 1911.6 2051.1 1911.4 2052.3 C
+1909.7 2052.8 1912.4 2054 1912.6 2054.7 C
+1913.4 2055.2 1913 2053.7 1913.6 2054.4 C
+1913.6 2054.5 1913.6 2055.3 1913.6 2054.7 C
+1913.7 2054.4 1913.9 2054.4 1914 2054.7 C
+1914 2054.9 1914.1 2055.3 1913.8 2055.4 C
+1913.7 2056 1915.2 2057.6 1916 2057.6 C
+1915.9 2057.3 1916.1 2057.2 1916.2 2057.1 C
+1917 2056.8 1916.7 2057.7 1917.2 2058 C
+1917 2058.3 1916.7 2058.3 1916.4 2058.3 C
+1917.1 2059 1917.3 2060.1 1918.4 2060.4 C
+1918.1 2059.2 1919.1 2060.6 1919.1 2059.5 C
+1919 2060.6 1920.6 2060.1 1919.8 2061.2 C
+1919.6 2061.2 1919.3 2061.2 1919.1 2061.2 C
+1919.6 2061.9 1921.4 2064.2 1921.5 2062.6 C
+1922.4 2062.1 1921.6 2063.9 1922.2 2064.3 C
+1922.9 2067.3 1926.1 2064.3 1925.6 2067.2 C
+1927.2 2066.8 1928.4 2064.6 1930.1 2065.2 C
+1931.8 2067.8 1931 2071.8 1930.8 2074.8 C
+1930.6 2076.4 1930.1 2078.6 1930.6 2080.4 C
+1936.6 2085.4 1941.8 2091.6 1948.1 2096.9 C
+1950.7 2096.7 1952.6 2094.8 1954.8 2093.8 C
+[0 0.33 0.33 0.99] vc
+f
+S
+n
+1989.4 2080.6 m
+1996.1 2077.3 2002.7 2073.8 2009.6 2070.8 C
+2009.6 2069.6 2010.2 2067.7 2009.3 2067.4 C
+2008.9 2062 2009.1 2056.4 2009.1 2050.8 C
+2012.3 2046.6 2019 2046.6 2023.5 2043.2 C
+2024 2042.3 2025.1 2042.1 2025.4 2041.2 C
+2025.3 2032.7 2025.6 2023.1 2025.2 2014.6 C
+2025 2015.3 2024.6 2014.2 2024.7 2014.8 C
+2024.5 2024.7 2025.1 2030.9 2024.2 2041 C
+2020.4 2044.8 2014.3 2044.2 2010.5 2048 C
+2009 2048.4 2009.8 2046.7 2009.1 2046.3 C
+2008.5 2044.8 2010.2 2044.6 2009.6 2043.4 C
+2009.1 2043.9 2009.2 2042.1 2008.1 2042.7 C
+2006.5 2046.1 2009.3 2048.9 2007.6 2052.3 C
+2007.7 2058 2007.5 2063.8 2007.9 2069.3 C
+2002.3 2072.4 1996.5 2074.8 1990.8 2077.5 C
+1988.4 2079.2 1985.6 2079.8 1983.2 2081.6 C
+1980.5 2079 1977.9 2076.5 1975.5 2074.1 C
+1975.5 2075.1 1975.5 2076.2 1975.5 2077.2 C
+1977.8 2079.3 1980.3 2081.6 1982.7 2083.7 C
+1985.3 2083.5 1987.1 2081.6 1989.4 2080.6 C
+f
+S
+n
+1930.1 2079.9 m
+1931.1 2075.6 1929.2 2071.1 1930.8 2067.2 C
+1930.3 2066.3 1930.1 2064.6 1928.7 2065.5 C
+1927.7 2066.4 1926.5 2067 1925.3 2067.4 C
+1924.5 2066.9 1925.6 2065.7 1924.4 2066 C
+1924.2 2067.2 1923.6 2065.5 1923.2 2065.7 C
+1922.3 2063.6 1917.8 2062.1 1919.6 2060.4 C
+1919.3 2060.5 1919.2 2060.3 1919.1 2060.2 C
+1919.7 2060.9 1918.2 2061 1917.6 2060.2 C
+1917 2059.6 1916.1 2058.8 1916.4 2058 C
+1915.5 2058 1917.4 2057.1 1915.7 2057.8 C
+1914.8 2057.1 1913.4 2056.2 1913.3 2054.9 C
+1913.1 2055.4 1911.3 2054.3 1910.9 2053.2 C
+1910.7 2052.9 1910.2 2052.5 1910.7 2052.3 C
+1911.1 2052.5 1910.9 2052 1910.9 2051.8 C
+1910.5 2051.2 1909.9 2052.6 1909.2 2051.8 C
+1908.2 2051.4 1907.8 2050.2 1907.1 2049.4 C
+1907.5 2044.8 1907.3 2040 1907.3 2035.2 C
+1905.3 2033 1902.8 2039.3 1902.3 2035.7 C
+1899.6 2036 1898.4 2032.5 1896.3 2030.7 C
+1895.7 2030.1 1897.5 2030 1896.3 2029.7 C
+1896.3 2030.6 1895 2029.7 1894.4 2029.2 C
+1892.9 2028.1 1894.2 2027.4 1893.6 2027.1 C
+1892.1 2027.9 1891.7 2025.6 1890.8 2024.9 C
+1891.1 2024.6 1889.1 2024.3 1888.4 2023 C
+1887.5 2022.6 1888.2 2021.9 1888.1 2021.3 C
+1886.7 2022 1885.2 2020.4 1884.8 2019.2 C
+1884.8 2010 1884.6 2000.2 1885 1991.8 C
+1886.9 1989.6 1889.9 1989.3 1892.2 1987.5 C
+1898.3 1982.7 1905.6 1980.1 1912.8 1978.6 C
+1921 1974.2 1928.8 1968.9 1937.8 1966.6 C
+1939.8 1968.3 1938.8 1968.3 1940.4 1970 C
+1945.4 1972.5 1947.6 1981.5 1954.6 1979.3 C
+1952.3 1981 1950.4 1978.4 1948.6 1977.9 C
+1945.1 1973.9 1941.1 1970.6 1938 1966.6 C
+1928.4 1968.5 1920.6 1974.8 1911.9 1978.8 C
+1907.1 1979.2 1902.6 1981.7 1898.2 1983.6 C
+1893.9 1986 1889.9 1989 1885.5 1990.8 C
+1884.9 1991.2 1884.8 1991.8 1884.5 1992.3 C
+1884.9 2001.3 1884.7 2011.1 1884.8 2019.6 C
+1890.6 2025 1896.5 2031.2 1902.3 2036.9 C
+1904.6 2037.6 1905 2033 1907.3 2035.5 C
+1907.2 2040.2 1907 2044.8 1907.1 2049.6 C
+1913.6 2055.3 1918.4 2061.5 1925.1 2067.4 C
+1927.3 2068.2 1929.6 2062.5 1930.6 2066.9 C
+1929.7 2070.7 1930.3 2076 1930.1 2080.1 C
+1935.6 2085.7 1941.9 2090.7 1947.2 2096.7 C
+1942.2 2091.1 1935.5 2085.2 1930.1 2079.9 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1930.8 2061.9 m
+1930.3 2057.8 1931.8 2053.4 1931.1 2050.4 C
+1931.3 2050.3 1931.7 2050.5 1931.6 2050.1 C
+1933 2051.1 1934.4 2049.5 1935.9 2048.7 C
+1937 2046.5 1939.5 2047.1 1941.2 2045.1 C
+1939.7 2042.6 1937.3 2041.2 1935.4 2039.3 C
+1934 2039.7 1934.5 2038.1 1933.7 2037.6 C
+1934 2033.3 1933.1 2027.9 1934.4 2024.4 C
+1934.3 2023.8 1933.9 2022.8 1933 2022.8 C
+1931.6 2023.1 1930.5 2024.4 1929.2 2024.9 C
+1928.4 2024.5 1929.8 2023.5 1928.7 2023.5 C
+1927.7 2024.1 1926.2 2022.6 1925.6 2021.6 C
+1926.9 2021.6 1924.8 2020.6 1925.6 2020.4 C
+1924.7 2021.7 1923.9 2019.6 1923.2 2019.2 C
+1923.3 2018.3 1923.8 2018.1 1923.2 2018 C
+1922.9 2017.8 1922.9 2017.5 1922.9 2017.2 C
+1922.8 2018.3 1921.3 2017.3 1920.3 2018 C
+1916.6 2019.7 1913 2022.1 1910 2024.7 C
+1910 2032.9 1910 2041.2 1910 2049.4 C
+1915.4 2055.2 1920 2058.7 1925.3 2064.8 C
+1927.2 2064 1929 2061.4 1930.8 2061.9 C
+[0 0 0 0] vc
+f
+S
+n
+1907.6 2030.4 m
+1907.5 2027.1 1906.4 2021.7 1908.5 2019.9 C
+1908.8 2020.1 1908.9 2019 1909.2 2019.6 C
+1910 2019.6 1912 2019.2 1913.1 2018.2 C
+1913.7 2016.5 1920.2 2015.7 1917.4 2012.7 C
+1918.2 2011.2 1917 2013.8 1917.2 2012 C
+1916.9 2012.3 1916 2012.4 1915.2 2012 C
+1912.5 2010.5 1916.6 2008.8 1913.6 2009.6 C
+1912.6 2009.2 1911.1 2009 1910.9 2007.6 C
+1911 1999.2 1911.8 1989.8 1911.2 1982.2 C
+1910.1 1981.1 1908.8 1982.2 1907.6 1982.2 C
+1900.8 1986.5 1893.2 1988.8 1887.2 1994.2 C
+1887.2 2002.4 1887.2 2010.7 1887.2 2018.9 C
+1892.6 2024.7 1897.2 2028.2 1902.5 2034.3 C
+1904.3 2033.3 1906.2 2032.1 1907.6 2030.4 C
+f
+S
+n
+1910.7 2025.4 m
+1912.7 2022.4 1916.7 2020.8 1919.8 2018.9 C
+1920.2 2018.7 1920.6 2018.6 1921 2018.4 C
+1925 2020 1927.4 2028.5 1932 2024.2 C
+1932.3 2025 1932.5 2023.7 1932.8 2024.4 C
+1932.8 2028 1932.8 2031.5 1932.8 2035 C
+1931.9 2033.9 1932.5 2036.3 1932.3 2036.9 C
+1933.2 2036.4 1932.5 2038.5 1933 2038.4 C
+1933.1 2040.5 1935.6 2042.2 1936.6 2043.2 C
+1936.2 2042.4 1935.1 2040.8 1933.7 2040.3 C
+1932.2 2034.4 1933.8 2029.8 1933 2023.2 C
+1931.1 2024.9 1928.4 2026.4 1926.5 2023.5 C
+1925.1 2021.6 1923 2019.8 1921.5 2018.2 C
+1917.8 2018.9 1915.2 2022.5 1911.6 2023.5 C
+1910.8 2023.8 1911.2 2024.7 1910.4 2025.2 C
+1910.9 2031.8 1910.6 2039.1 1910.7 2045.6 C
+1910.1 2048 1910.7 2045.9 1911.2 2044.8 C
+1910.6 2038.5 1911.2 2031.8 1910.7 2025.4 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1910.7 2048.9 m
+1910.3 2047.4 1911.3 2046.5 1911.6 2045.3 C
+1912.9 2045.3 1913.9 2047.1 1915.2 2045.8 C
+1915.2 2044.9 1916.6 2043.3 1917.2 2042.9 C
+1918.7 2042.9 1919.4 2044.4 1920.5 2043.2 C
+1921.2 2042.2 1921.4 2040.9 1922.4 2040.3 C
+1924.5 2040.3 1925.7 2040.9 1926.8 2039.6 C
+1927.1 2037.9 1926.8 2038.1 1927.7 2037.6 C
+1929 2037.5 1930.4 2037 1931.6 2037.2 C
+1932.3 2038.2 1933.1 2038.7 1932.8 2040.3 C
+1935 2041.8 1935.9 2043.8 1938.5 2044.8 C
+1938.6 2045 1938.3 2045.5 1938.8 2045.3 C
+1939.1 2042.9 1935.4 2044.2 1935.4 2042.2 C
+1932.1 2040.8 1932.8 2037.2 1932 2034.8 C
+1932.3 2034 1932.7 2035.4 1932.5 2034.8 C
+1931.3 2031.8 1935.5 2020.1 1928.9 2025.9 C
+1924.6 2024.7 1922.6 2014.5 1917.4 2020.4 C
+1915.5 2022.8 1912 2022.6 1910.9 2025.4 C
+1911.5 2031.9 1910.9 2038.8 1911.4 2045.3 C
+1911.1 2046.5 1910 2047.4 1910.4 2048.9 C
+1915.1 2054.4 1920.4 2058.3 1925.1 2063.8 C
+1920.8 2058.6 1914.9 2054.3 1910.7 2048.9 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1934.7 2031.9 m
+1934.6 2030.7 1934.9 2029.5 1934.4 2028.5 C
+1934 2029.5 1934.3 2031.2 1934.2 2032.6 C
+1933.8 2031.7 1934.9 2031.6 1934.7 2031.9 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+vmrs
+1934.7 2019.4 m
+1934.1 2015.3 1935.6 2010.9 1934.9 2007.9 C
+1935.1 2007.8 1935.6 2008.1 1935.4 2007.6 C
+1936.8 2008.6 1938.2 2007 1939.7 2006.2 C
+1940.1 2004.3 1942.7 2005 1943.6 2003.8 C
+1945.1 2000.3 1954 2000.8 1950 1996.6 C
+1952.1 1993.3 1948.2 1989.2 1951.2 1985.6 C
+1953 1981.4 1948.4 1982.3 1947.9 1979.8 C
+1945.4 1979.6 1945.1 1975.5 1942.4 1975 C
+1942.4 1972.3 1938 1973.6 1938.5 1970.4 C
+1937.4 1969 1935.6 1970.1 1934.2 1970.2 C
+1927.5 1974.5 1919.8 1976.8 1913.8 1982.2 C
+1913.8 1990.4 1913.8 1998.7 1913.8 2006.9 C
+1919.3 2012.7 1923.8 2016.2 1929.2 2022.3 C
+1931.1 2021.6 1932.8 2018.9 1934.7 2019.4 C
+[0 0 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+2024.2 2038.1 m
+2024.1 2029.3 2024.4 2021.7 2024.7 2014.4 C
+2024.4 2013.6 2020.6 2013.4 2021.3 2011.2 C
+2020.5 2010.3 2018.4 2010.6 2018.9 2008.6 C
+2019 2008.8 2018.8 2009 2018.7 2009.1 C
+2018.2 2006.7 2015.2 2007.9 2015.3 2005.5 C
+2014.7 2004.8 2012.4 2005.1 2013.2 2003.6 C
+2012.3 2004.2 2012.8 2002.4 2012.7 2002.6 C
+2009.4 2003.3 2011.2 1998.6 2008.4 1999.2 C
+2007 1999.1 2006.1 1999.4 2005.7 2000.4 C
+2006.9 1998.5 2007.7 2000.5 2009.3 2000.2 C
+2009.2 2003.7 2012.4 2002.1 2012.9 2005.2 C
+2015.9 2005.6 2015.2 2008.6 2017.7 2008.8 C
+2018.4 2009.6 2018.3 2011.4 2019.6 2011 C
+2021.1 2011.7 2021.4 2014.8 2023.7 2015.1 C
+2023.7 2023.5 2023.9 2031.6 2023.5 2040.5 C
+2021.8 2041.7 2020.7 2043.6 2018.4 2043.9 C
+2020.8 2042.7 2025.5 2041.8 2024.2 2038.1 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+2023.5 2040 m
+2023.5 2031.1 2023.5 2023.4 2023.5 2015.1 C
+2020.2 2015 2021.8 2010.3 2018.4 2011 C
+2018.6 2007.5 2014.7 2009.3 2014.8 2006.4 C
+2011.8 2006.3 2012.2 2002.3 2009.8 2002.4 C
+2009.7 2001.5 2009.2 2000.1 2008.4 2000.2 C
+2008.7 2000.9 2009.7 2001.2 2009.3 2002.4 C
+2008.4 2004.2 2007.5 2003.1 2007.9 2005.5 C
+2007.9 2010.8 2007.7 2018.7 2008.1 2023.2 C
+2009 2024.3 2007.3 2023.4 2007.9 2024 C
+2007.7 2024.6 2007.3 2026.3 2008.6 2027.1 C
+2009.7 2026.8 2010 2027.6 2010.5 2028 C
+2010.5 2028.2 2010.5 2029.1 2010.5 2028.5 C
+2011.5 2028 2010.5 2030 2011.5 2030 C
+2014.2 2029.7 2012.9 2032.2 2014.8 2032.6 C
+2015.1 2033.6 2015.3 2033 2016 2033.3 C
+2017 2033.9 2016.6 2035.4 2017.2 2036.2 C
+2018.7 2036.4 2019.2 2039 2021.3 2038.4 C
+2021.6 2035.4 2019.7 2029.5 2021.1 2027.3 C
+2020.9 2023.5 2021.5 2018.5 2020.6 2016 C
+2020.9 2013.9 2021.5 2015.4 2022.3 2014.4 C
+2022.2 2015.1 2023.3 2014.8 2023.2 2015.6 C
+2022.7 2019.8 2023.3 2024.3 2022.8 2028.5 C
+2022.3 2028.2 2022.6 2027.6 2022.5 2027.1 C
+2022.5 2027.8 2022.5 2029.2 2022.5 2029.2 C
+2022.6 2029.2 2022.7 2029.1 2022.8 2029 C
+2023.9 2032.8 2022.6 2037 2023 2040.8 C
+2022.3 2041.2 2021.6 2041.5 2021.1 2042.2 C
+2022 2041.2 2022.9 2041.4 2023.5 2040 C
+[0 1 1 0.23] vc
+f
+S
+n
+2009.1 1997.8 m
+2003.8 1997.7 2000.1 2002.4 1995.4 2003.1 C
+1995 1999.5 1995.2 1995 1995.2 1992 C
+1995.2 1995.8 1995 1999.7 1995.4 2003.3 C
+2000.3 2002.2 2003.8 1997.9 2009.1 1997.8 C
+2012.3 2001.2 2015.6 2004.8 2018.7 2008.1 C
+2021.6 2011.2 2027.5 2013.9 2025.9 2019.9 C
+2026.1 2017.9 2025.6 2016.2 2025.4 2014.4 C
+2020.2 2008.4 2014 2003.6 2009.1 1997.8 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+2009.3 1997.8 m
+2008.7 1997.4 2007.9 1997.6 2007.2 1997.6 C
+2007.9 1997.6 2008.9 1997.4 2009.6 1997.8 C
+2014.7 2003.6 2020.8 2008.8 2025.9 2014.8 C
+2025.8 2017.7 2026.1 2014.8 2025.6 2014.1 C
+2020.4 2008.8 2014.8 2003.3 2009.3 1997.8 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+2009.6 1997.6 m
+2009 1997.1 2008.1 1997.4 2007.4 1997.3 C
+2008.1 1997.4 2009 1997.1 2009.6 1997.6 C
+2014.8 2003.7 2021.1 2008.3 2025.9 2014.4 C
+2021.1 2008.3 2014.7 2003.5 2009.6 1997.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+2021.8 2011.5 m
+2021.9 2012.2 2022.3 2013.5 2023.7 2013.6 C
+2023.4 2012.7 2022.8 2011.8 2021.8 2011.5 C
+[0 0.33 0.33 0.99] vc
+f
+S
+n
+2021.1 2042 m
+2022.1 2041.1 2020.9 2040.2 2020.6 2039.6 C
+2018.4 2039.5 2018.1 2036.9 2016.3 2036.4 C
+2015.8 2035.5 2015.3 2033.8 2014.8 2033.6 C
+2012.4 2033.8 2013 2030.4 2010.5 2030.2 C
+2009.6 2028.9 2009.6 2028.3 2008.4 2028 C
+2006.9 2026.7 2007.5 2024.3 2006 2023.2 C
+2006.6 2023.2 2005.7 2023.3 2005.7 2023 C
+2006.4 2022.5 2006.3 2021.1 2006.7 2020.6 C
+2006.6 2015 2006.9 2009 2006.4 2003.8 C
+2006.9 2002.5 2007.6 2001.1 2006.9 2000.7 C
+2004.6 2003.6 2003 2002.9 2000.2 2004.3 C
+1999.3 2005.8 1997.9 2006.3 1996.1 2006.7 C
+1995.7 2008.9 1996 2011.1 1995.9 2012.9 C
+1993.4 2015.1 1990.5 2016.2 1987.7 2017.7 C
+1987.1 2019.3 1991.1 2019.4 1990.4 2021.3 C
+1990.5 2021.5 1991.9 2022.3 1992 2023 C
+1994.8 2024.4 1996.2 2027.5 1998.5 2030 C
+2002.4 2033 2005.2 2037.2 2008.8 2041 C
+2010.2 2041.3 2011.6 2042 2011 2043.9 C
+2011.2 2044.8 2010.1 2045.3 2010.5 2046.3 C
+2013.8 2044.8 2017.5 2043.4 2021.1 2042 C
+[0 0.5 0.5 0.2] vc
+f
+S
+n
+2019.4 2008.8 m
+2018.9 2009.2 2019.3 2009.9 2019.6 2010.3 C
+2022.2 2011.5 2020.3 2009.1 2019.4 2008.8 C
+[0 0.33 0.33 0.99] vc
+f
+S
+n
+2018 2007.4 m
+2015.7 2006.7 2015.3 2003.6 2012.9 2002.8 C
+2013.5 2003.7 2013.5 2005.1 2015.6 2005.2 C
+2016.4 2006.1 2015.7 2007.7 2018 2007.4 C
+f
+S
+n
+vmrs
+1993.5 2008.8 m
+1993.4 2000 1993.7 1992.5 1994 1985.1 C
+1993.7 1984.3 1989.9 1984.1 1990.6 1982 C
+1989.8 1981.1 1987.7 1981.4 1988.2 1979.3 C
+1988.3 1979.6 1988.1 1979.7 1988 1979.8 C
+1987.5 1977.5 1984.5 1978.6 1984.6 1976.2 C
+1983.9 1975.5 1981.7 1975.8 1982.4 1974.3 C
+1981.6 1974.9 1982.1 1973.1 1982 1973.3 C
+1979 1973.7 1980 1968.8 1976.9 1969.7 C
+1975.9 1969.8 1975.3 1970.3 1975 1971.2 C
+1976.2 1969.2 1977 1971.2 1978.6 1970.9 C
+1978.5 1974.4 1981.7 1972.8 1982.2 1976 C
+1985.2 1976.3 1984.5 1979.3 1987 1979.6 C
+1987.7 1980.3 1987.5 1982.1 1988.9 1981.7 C
+1990.4 1982.4 1990.7 1985.5 1993 1985.8 C
+1992.9 1994.3 1993.2 2002.3 1992.8 2011.2 C
+1991.1 2012.4 1990 2014.4 1987.7 2014.6 C
+1990.1 2013.4 1994.7 2012.6 1993.5 2008.8 C
+[0 0.87 0.91 0.83] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1992.8 2010.8 m
+1992.8 2001.8 1992.8 1994.1 1992.8 1985.8 C
+1989.5 1985.7 1991.1 1981.1 1987.7 1981.7 C
+1987.9 1978.2 1983.9 1980 1984.1 1977.2 C
+1981.1 1977 1981.5 1973 1979.1 1973.1 C
+1979 1972.2 1978.5 1970.9 1977.6 1970.9 C
+1977.9 1971.6 1979 1971.9 1978.6 1973.1 C
+1977.6 1974.9 1976.8 1973.9 1977.2 1976.2 C
+1977.2 1981.5 1977 1989.4 1977.4 1994 C
+1978.3 1995 1976.6 1994.1 1977.2 1994.7 C
+1977 1995.3 1976.6 1997 1977.9 1997.8 C
+1979 1997.5 1979.3 1998.3 1979.8 1998.8 C
+1979.8 1998.9 1979.8 1999.8 1979.8 1999.2 C
+1980.8 1998.7 1979.7 2000.7 1980.8 2000.7 C
+1983.5 2000.4 1982.1 2003 1984.1 2003.3 C
+1984.4 2004.3 1984.5 2003.7 1985.3 2004 C
+1986.3 2004.6 1985.9 2006.1 1986.5 2006.9 C
+1988 2007.1 1988.4 2009.7 1990.6 2009.1 C
+1990.9 2006.1 1989 2000.2 1990.4 1998 C
+1990.2 1994.3 1990.8 1989.2 1989.9 1986.8 C
+1990.2 1984.7 1990.8 1986.2 1991.6 1985.1 C
+1991.5 1985.9 1992.6 1985.5 1992.5 1986.3 C
+1992 1990.5 1992.6 1995 1992 1999.2 C
+1991.6 1998.9 1991.9 1998.3 1991.8 1997.8 C
+1991.8 1998.5 1991.8 2000 1991.8 2000 C
+1991.9 1999.9 1992 1999.8 1992 1999.7 C
+1993.2 2003.5 1991.9 2007.7 1992.3 2011.5 C
+1991.6 2012 1990.9 2012.2 1990.4 2012.9 C
+1991.3 2011.9 1992.2 2012.1 1992.8 2010.8 C
+[0 1 1 0.23] vc
+f
+S
+n
+1978.4 1968.5 m
+1977 1969.2 1975.8 1968.2 1974.5 1969 C
+1968.3 1973 1961.6 1976 1955.1 1979.1 C
+1962 1975.9 1968.8 1972.5 1975.5 1968.8 C
+1976.5 1968.8 1977.6 1968.8 1978.6 1968.8 C
+1981.7 1972.1 1984.8 1975.7 1988 1978.8 C
+1990.9 1981.9 1996.8 1984.6 1995.2 1990.6 C
+1995.3 1988.6 1994.9 1986.9 1994.7 1985.1 C
+1989.5 1979.1 1983.3 1974.3 1978.4 1968.5 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1978.4 1968.3 m
+1977.9 1968.7 1977.1 1968.5 1976.4 1968.5 C
+1977.3 1968.8 1978.1 1967.9 1978.8 1968.5 C
+1984 1974.3 1990.1 1979.5 1995.2 1985.6 C
+1995.1 1988.4 1995.3 1985.6 1994.9 1984.8 C
+1989.5 1979.4 1983.9 1973.8 1978.4 1968.3 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1978.6 1968 m
+1977.9 1968 1977.4 1968.6 1978.4 1968 C
+1983.9 1973.9 1990.1 1979.1 1995.2 1985.1 C
+1990.2 1979 1983.8 1974.1 1978.6 1968 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1991.1 1982.2 m
+1991.2 1982.9 1991.6 1984.2 1993 1984.4 C
+1992.6 1983.5 1992.1 1982.5 1991.1 1982.2 C
+[0 0.33 0.33 0.99] vc
+f
+S
+n
+1990.4 2012.7 m
+1991.4 2011.8 1990.2 2010.9 1989.9 2010.3 C
+1987.7 2010.2 1987.4 2007.6 1985.6 2007.2 C
+1985.1 2006.2 1984.6 2004.5 1984.1 2004.3 C
+1981.7 2004.5 1982.3 2001.2 1979.8 2000.9 C
+1978.8 1999.6 1978.8 1999.1 1977.6 1998.8 C
+1976.1 1997.4 1976.7 1995 1975.2 1994 C
+1975.8 1994 1975 1994 1975 1993.7 C
+1975.7 1993.2 1975.6 1991.8 1976 1991.3 C
+1975.9 1985.7 1976.1 1979.7 1975.7 1974.5 C
+1976.2 1973.3 1976.9 1971.8 1976.2 1971.4 C
+1973.9 1974.3 1972.2 1973.6 1969.5 1975 C
+1967.9 1977.5 1963.8 1977.1 1961.8 1980 C
+1959 1980 1957.6 1983 1954.8 1982.9 C
+1953.8 1984.2 1954.8 1985.7 1955.1 1987.2 C
+1956.2 1989.5 1959.7 1990.1 1959.9 1991.8 C
+1965.9 1998 1971.8 2005.2 1978.1 2011.7 C
+1979.5 2012 1980.9 2012.7 1980.3 2014.6 C
+1980.5 2015.6 1979.4 2016 1979.8 2017 C
+1983 2015.6 1986.8 2014.1 1990.4 2012.7 C
+[0 0.5 0.5 0.2] vc
+f
+S
+n
+1988.7 1979.6 m
+1988.2 1979.9 1988.6 1980.6 1988.9 1981 C
+1991.4 1982.2 1989.6 1979.9 1988.7 1979.6 C
+[0 0.33 0.33 0.99] vc
+f
+S
+n
+1987.2 1978.1 m
+1985 1977.5 1984.6 1974.3 1982.2 1973.6 C
+1982.7 1974.5 1982.8 1975.8 1984.8 1976 C
+1985.7 1976.9 1985 1978.4 1987.2 1978.1 C
+f
+S
+n
+1975.5 2084 m
+1975.5 2082 1975.3 2080 1975.7 2078.2 C
+1978.8 2079 1980.9 2085.5 1984.8 2083.5 C
+1993 2078.7 2001.6 2075 2010 2070.8 C
+2010.1 2064 2009.9 2057.2 2010.3 2050.6 C
+2014.8 2046.2 2020.9 2045.7 2025.6 2042 C
+2026.1 2035.1 2025.8 2028 2025.9 2021.1 C
+2025.8 2027.8 2026.1 2034.6 2025.6 2041.2 C
+2022.2 2044.9 2017.6 2046.8 2012.9 2048 C
+2012.5 2049.5 2010.4 2049.4 2009.8 2051.1 C
+2009.9 2057.6 2009.6 2064.2 2010 2070.5 C
+2001.2 2075.4 1992 2079.1 1983.2 2084 C
+1980.3 2082.3 1977.8 2079.2 1975.2 2077.5 C
+1974.9 2079.9 1977.2 2084.6 1973.3 2085.2 C
+1964.7 2088.6 1956.8 2093.7 1948.1 2097.2 C
+1949 2097.3 1949.6 2096.9 1950.3 2096.7 C
+1958.4 2091.9 1967.1 2088.2 1975.5 2084 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+vmrs
+1948.6 2094.5 m
+1950.2 2093.7 1951.8 2092.9 1953.4 2092.1 C
+1951.8 2092.9 1950.2 2093.7 1948.6 2094.5 C
+[0 0.87 0.91 0.83] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1971.6 2082.3 m
+1971.6 2081.9 1970.7 2081.1 1970.9 2081.3 C
+1970.7 2081.6 1970.6 2081.6 1970.4 2081.3 C
+1970.8 2080.1 1968.7 2081.7 1968.3 2080.8 C
+1966.6 2080.9 1966.7 2078 1964.2 2078.2 C
+1964.8 2075 1960.1 2075.8 1960.1 2072.9 C
+1958 2072.3 1957.5 2069.3 1955.3 2069.3 C
+1953.9 2070.9 1948.8 2067.8 1950 2072 C
+1949 2074 1943.2 2070.6 1944 2074.8 C
+1942.2 2076.6 1937.6 2073.9 1938 2078.2 C
+1936.7 2078.6 1935 2078.6 1933.7 2078.2 C
+1933.5 2080 1936.8 2080.7 1937.3 2082.8 C
+1939.9 2083.5 1940.6 2086.4 1942.6 2088 C
+1945.2 2089.2 1946 2091.3 1948.4 2093.6 C
+1956 2089.5 1963.9 2086.1 1971.6 2082.3 C
+[0 0.01 1 0] vc
+f
+S
+n
+1958.2 2089.7 m
+1956.4 2090 1955.6 2091.3 1953.9 2091.9 C
+1955.6 2091.9 1956.5 2089.7 1958.2 2089.7 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1929.9 2080.4 m
+1929.5 2077.3 1929.7 2073.9 1929.6 2070.8 C
+1929.8 2074.1 1929.2 2077.8 1930.1 2080.8 C
+1935.8 2085.9 1941.4 2091.3 1946.9 2096.9 C
+1941.2 2091 1935.7 2086 1929.9 2080.4 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1930.1 2080.4 m
+1935.8 2086 1941.5 2090.7 1946.9 2096.7 C
+1941.5 2090.9 1935.7 2085.8 1930.1 2080.4 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1940.9 2087.1 m
+1941.7 2088 1944.8 2090.6 1943.6 2089.2 C
+1942.5 2089 1941.6 2087.7 1940.9 2087.1 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1972.8 2082.8 m
+1973 2075.3 1972.4 2066.9 1973.3 2059.5 C
+1972.5 2058.9 1972.8 2057.3 1973.1 2056.4 C
+1974.8 2055.2 1973.4 2055.5 1972.4 2055.4 C
+1970.1 2053.2 1967.9 2050.9 1965.6 2048.7 C
+1960.9 2049.9 1956.9 2052.7 1952.4 2054.7 C
+1949.3 2052.5 1946.3 2049.5 1943.6 2046.8 C
+1939.9 2047.7 1936.8 2050.1 1933.5 2051.8 C
+1930.9 2054.9 1933.5 2056.2 1932.3 2059.7 C
+1933.2 2059.7 1932.2 2060.5 1932.5 2060.2 C
+1933.2 2062.5 1931.6 2064.6 1932.5 2067.4 C
+1932.9 2069.7 1932.7 2072.2 1932.8 2074.6 C
+1933.6 2070.6 1932.2 2066.3 1933 2062.6 C
+1934.4 2058.2 1929.8 2053.5 1935.2 2051.1 C
+1937.7 2049.7 1940.2 2048 1942.8 2046.8 C
+1945.9 2049.2 1948.8 2052 1951.7 2054.7 C
+1952.7 2054.7 1953.6 2054.6 1954.4 2054.2 C
+1958.1 2052.5 1961.7 2049.3 1965.9 2049.2 C
+1968.2 2052.8 1975.2 2055 1972.6 2060.9 C
+1973.3 2062.4 1972.2 2065.2 1972.6 2067.6 C
+1972.7 2072.6 1972.4 2077.7 1972.8 2082.5 C
+1968.1 2084.9 1963.5 2087.5 1958.7 2089.5 C
+1963.5 2087.4 1968.2 2085 1972.8 2082.8 C
+f
+S
+n
+1935.2 2081.1 m
+1936.8 2083.4 1938.6 2084.6 1940.4 2086.6 C
+1938.8 2084.4 1936.7 2083.4 1935.2 2081.1 C
+f
+S
+n
+1983.2 2081.3 m
+1984.8 2080.5 1986.3 2079.7 1988 2078.9 C
+1986.3 2079.7 1984.8 2080.5 1983.2 2081.3 C
+f
+S
+n
+2006.2 2069.1 m
+2006.2 2068.7 2005.2 2067.9 2005.5 2068.1 C
+2005.3 2068.4 2005.2 2068.4 2005 2068.1 C
+2005.4 2066.9 2003.3 2068.5 2002.8 2067.6 C
+2001.2 2067.7 2001.2 2064.8 1998.8 2065 C
+1999.4 2061.8 1994.7 2062.6 1994.7 2059.7 C
+1992.4 2059.5 1992.4 2055.8 1990.1 2056.8 C
+1985.9 2059.5 1981.1 2061 1976.9 2063.8 C
+1977.2 2067.6 1974.9 2074.2 1978.8 2075.8 C
+1979.6 2077.8 1981.7 2078.4 1982.9 2080.4 C
+1990.6 2076.3 1998.5 2072.9 2006.2 2069.1 C
+[0 0.01 1 0] vc
+f
+S
+n
+vmrs
+1992.8 2076.5 m
+1991 2076.8 1990.2 2078.1 1988.4 2078.7 C
+1990.2 2078.7 1991 2076.5 1992.8 2076.5 C
+[0 0.87 0.91 0.83] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1975.5 2073.4 m
+1976.1 2069.7 1973.9 2064.6 1977.4 2062.4 C
+1973.9 2064.5 1976.1 2069.9 1975.5 2073.6 C
+1976 2074.8 1979.3 2077.4 1978.1 2076 C
+1977 2075.7 1975.8 2074.5 1975.5 2073.4 C
+f
+S
+n
+2007.4 2069.6 m
+2007.6 2062.1 2007 2053.7 2007.9 2046.3 C
+2007.1 2045.7 2007.3 2044.1 2007.6 2043.2 C
+2009.4 2042 2007.9 2042.3 2006.9 2042.2 C
+2002.2 2037.4 1996.7 2032.4 1992.5 2027.3 C
+1992 2027.3 1991.6 2027.3 1991.1 2027.3 C
+1991.4 2035.6 1991.4 2045.6 1991.1 2054.4 C
+1990.5 2055.5 1988.4 2056.6 1990.6 2055.4 C
+1991.6 2055.4 1991.6 2054.1 1991.6 2053.2 C
+1990.8 2044.7 1991.9 2035.4 1991.6 2027.6 C
+1991.8 2027.6 1992 2027.6 1992.3 2027.6 C
+1997 2032.8 2002.5 2037.7 2007.2 2042.9 C
+2007.3 2044.8 2006.7 2047.4 2007.6 2048.4 C
+2006.9 2055.1 2007.1 2062.5 2007.4 2069.3 C
+2002.7 2071.7 1998.1 2074.3 1993.2 2076.3 C
+1998 2074.2 2002.7 2071.8 2007.4 2069.6 C
+f
+S
+n
+2006.7 2069.1 m
+2006.3 2068.6 2005.9 2067.7 2005.7 2066.9 C
+2005.7 2059.7 2005.9 2051.4 2005.5 2045.1 C
+2004.9 2045.3 2004.7 2044.5 2004.3 2045.3 C
+2005.1 2045.3 2004.2 2045.8 2004.8 2046 C
+2004.8 2052.2 2004.8 2059.2 2004.8 2064.5 C
+2005.7 2065.7 2005.1 2065.7 2005 2066.7 C
+2003.8 2067 2002.7 2067.2 2001.9 2066.4 C
+2001.3 2064.6 1998 2063.1 1998 2061.9 C
+1996.1 2062.3 1996.6 2058.3 1994.2 2058.8 C
+1992.6 2057.7 1992.7 2054.8 1989.9 2056.6 C
+1985.6 2059.3 1980.9 2060.8 1976.7 2063.6 C
+1976 2066.9 1976 2071.2 1976.7 2074.6 C
+1977.6 2070.8 1973.1 2062.1 1980.5 2061.2 C
+1984.3 2060.3 1987.5 2058.2 1990.8 2056.4 C
+1991.7 2056.8 1992.9 2057.2 1993.5 2059.2 C
+1994.3 2058.6 1994.4 2060.6 1994.7 2059.2 C
+1995.3 2062.7 1999.2 2061.4 1998.8 2064.8 C
+2001.8 2065.4 2002.5 2068.4 2005.2 2067.4 C
+2004.9 2067.9 2006 2068 2006.4 2069.1 C
+2001.8 2071.1 1997.4 2073.9 1992.8 2075.8 C
+1997.5 2073.8 2002 2071.2 2006.7 2069.1 C
+[0 0.2 1 0] vc
+f
+S
+n
+1988.7 2056.6 m
+1985.1 2058.7 1981.1 2060.1 1977.6 2061.9 C
+1981.3 2060.5 1985.6 2058.1 1988.7 2056.6 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1977.9 2059.5 m
+1975.7 2064.5 1973.7 2054.7 1975.2 2060.9 C
+1976 2060.6 1977.6 2059.7 1977.9 2059.5 C
+f
+S
+n
+1989.6 2051.3 m
+1990.1 2042.3 1989.8 2036.6 1989.9 2028 C
+1989.8 2027 1990.8 2028.3 1990.1 2027.3 C
+1988.9 2026.7 1986.7 2026.9 1986.8 2024.7 C
+1987.4 2023 1985.9 2024.6 1985.1 2023.7 C
+1984.1 2021.4 1982.5 2020.5 1980.3 2020.6 C
+1979.9 2020.8 1979.5 2021.1 1979.3 2021.6 C
+1979.7 2025.8 1978.4 2033 1979.6 2038.1 C
+1983.7 2042.9 1968.8 2044.6 1978.8 2042.7 C
+1979.3 2042.3 1979.6 2041.9 1980 2041.5 C
+1980 2034.8 1980 2027 1980 2021.6 C
+1981.3 2020.5 1981.7 2021.5 1982.9 2021.8 C
+1983.6 2024.7 1986.1 2023.8 1986.8 2026.4 C
+1987.1 2027.7 1988.6 2027.1 1989.2 2028.3 C
+1989.1 2036.7 1989.3 2044.8 1988.9 2053.7 C
+1987.2 2054.9 1986.2 2056.8 1983.9 2057.1 C
+1986.3 2055.9 1990.9 2055 1989.6 2051.3 C
+f
+S
+n
+1971.6 2078.9 m
+1971.4 2070.5 1972.1 2062.2 1971.6 2055.9 C
+1969.9 2053.7 1967.6 2051.7 1965.6 2049.6 C
+1961.4 2050.4 1957.6 2053.6 1953.4 2055.2 C
+1949.8 2055.6 1948.2 2051.2 1945.5 2049.6 C
+1945.1 2048.8 1944.5 2047.9 1943.6 2047.5 C
+1940.1 2047.8 1937.3 2051 1934 2052.3 C
+1933.7 2052.6 1933.7 2053 1933.2 2053.2 C
+1933.7 2060.8 1933.4 2067.2 1933.5 2074.6 C
+1933.8 2068.1 1934 2060.9 1933.2 2054 C
+1935.3 2050.9 1939.3 2049.6 1942.4 2047.5 C
+1942.8 2047.5 1943.4 2047.4 1943.8 2047.7 C
+1947.1 2050.2 1950.3 2057.9 1955.3 2054.4 C
+1955.4 2054.4 1955.5 2054.3 1955.6 2054.2 C
+1955.9 2057.6 1956.1 2061.8 1955.3 2064.8 C
+1955.4 2064.3 1955.1 2063.8 1955.6 2063.6 C
+1956 2066.6 1955.3 2068.7 1958.7 2069.8 C
+1959.2 2071.7 1961.4 2071.7 1962 2074.1 C
+1964.4 2074.2 1964 2077.7 1967.3 2078.4 C
+1967 2079.7 1968.1 2079.9 1969 2080.1 C
+1971.1 2079.9 1970 2079.2 1970.4 2078 C
+1969.5 2077.2 1970.3 2075.9 1969.7 2075.1 C
+1970.1 2069.8 1970.1 2063.6 1969.7 2058.8 C
+1969.2 2058.5 1970 2058.1 1970.2 2057.8 C
+1970.4 2058.3 1971.2 2057.7 1971.4 2058.3 C
+1971.5 2065.3 1971.2 2073.6 1971.6 2081.1 C
+1974.1 2081.4 1969.8 2084.3 1972.4 2082.5 C
+1971.9 2081.4 1971.6 2080.2 1971.6 2078.9 C
+[0 0.4 1 0] vc
+f
+S
+n
+1952.4 2052 m
+1954.1 2051.3 1955.6 2050.4 1957.2 2049.6 C
+1955.6 2050.4 1954.1 2051.3 1952.4 2052 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1975.5 2039.8 m
+1975.5 2039.4 1974.5 2038.7 1974.8 2038.8 C
+1974.6 2039.1 1974.5 2039.1 1974.3 2038.8 C
+1974.6 2037.6 1972.5 2039.3 1972.1 2038.4 C
+1970.4 2038.4 1970.5 2035.5 1968 2035.7 C
+1968.6 2032.5 1964 2033.3 1964 2030.4 C
+1961.9 2029.8 1961.4 2026.8 1959.2 2026.8 C
+1957.7 2028.5 1952.6 2025.3 1953.9 2029.5 C
+1952.9 2031.5 1947 2028.2 1947.9 2032.4 C
+1946 2034.2 1941.5 2031.5 1941.9 2035.7 C
+1940.6 2036.1 1938.9 2036.1 1937.6 2035.7 C
+1937.3 2037.5 1940.7 2038.2 1941.2 2040.3 C
+1943.7 2041.1 1944.4 2043.9 1946.4 2045.6 C
+1949.1 2046.7 1949.9 2048.8 1952.2 2051.1 C
+1959.9 2047.1 1967.7 2043.6 1975.5 2039.8 C
+[0 0.01 1 0] vc
+f
+S
+n
+vmrs
+1962 2047.2 m
+1960.2 2047.5 1959.5 2048.9 1957.7 2049.4 C
+1959.5 2049.5 1960.3 2047.2 1962 2047.2 C
+[0 0.87 0.91 0.83] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+2012.4 2046.3 m
+2010.3 2051.3 2008.3 2041.5 2009.8 2047.7 C
+2010.5 2047.4 2012.2 2046.5 2012.4 2046.3 C
+f
+S
+n
+1944.8 2044.6 m
+1945.5 2045.6 1948.6 2048.1 1947.4 2046.8 C
+1946.3 2046.5 1945.5 2045.2 1944.8 2044.6 C
+f
+S
+n
+1987.2 2054.9 m
+1983.7 2057.3 1979.6 2058 1976 2060.2 C
+1974.7 2058.2 1977.2 2055.8 1974.3 2054.9 C
+1973.1 2052 1970.4 2050.2 1968 2048 C
+1968 2047.7 1968 2047.4 1968.3 2047.2 C
+1969.5 2046.1 1983 2040.8 1972.4 2044.8 C
+1971.2 2046.6 1967.9 2046 1968 2048.2 C
+1970.5 2050.7 1973.8 2052.6 1974.3 2055.6 C
+1975.1 2055 1975.7 2056.7 1975.7 2057.1 C
+1975.7 2058.2 1974.8 2059.3 1975.5 2060.4 C
+1979.3 2058.2 1983.9 2057.7 1987.2 2054.9 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1967.8 2047.5 m
+1968.5 2047 1969.1 2046.5 1969.7 2046 C
+1969.1 2046.5 1968.5 2047 1967.8 2047.5 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1976.7 2040.3 m
+1976.9 2032.8 1976.3 2024.4 1977.2 2017 C
+1976.4 2016.5 1976.6 2014.8 1976.9 2013.9 C
+1978.7 2012.7 1977.2 2013 1976.2 2012.9 C
+1971.5 2008.1 1965.9 2003.1 1961.8 1998 C
+1960.9 1998 1960.1 1998 1959.2 1998 C
+1951.5 2001.1 1944.3 2005.5 1937.1 2009.6 C
+1935 2012.9 1937 2013.6 1936.1 2017.2 C
+1937.1 2017.2 1936 2018 1936.4 2017.7 C
+1937 2020.1 1935.5 2022.1 1936.4 2024.9 C
+1936.8 2027.2 1936.5 2029.7 1936.6 2032.1 C
+1937.4 2028.2 1936 2023.8 1936.8 2020.1 C
+1938.3 2015.7 1933.6 2011 1939 2008.6 C
+1945.9 2004.5 1953.1 2000.3 1960.6 1998.3 C
+1960.9 1998.3 1961.3 1998.3 1961.6 1998.3 C
+1966.2 2003.5 1971.8 2008.4 1976.4 2013.6 C
+1976.6 2015.5 1976 2018.1 1976.9 2019.2 C
+1976.1 2025.8 1976.4 2033.2 1976.7 2040 C
+1971.9 2042.4 1967.4 2045 1962.5 2047 C
+1967.3 2044.9 1972 2042.6 1976.7 2040.3 C
+f
+S
+n
+1939 2038.6 m
+1940.6 2040.9 1942.5 2042.1 1944.3 2044.1 C
+1942.7 2041.9 1940.6 2040.9 1939 2038.6 C
+f
+S
+n
+2006.2 2065.7 m
+2006 2057.3 2006.7 2049 2006.2 2042.7 C
+2002.1 2038.4 1997.7 2033.4 1993 2030 C
+1992.9 2029.3 1992.5 2028.6 1992 2028.3 C
+1992.1 2036.6 1991.9 2046.2 1992.3 2054.9 C
+1990.8 2056.2 1989 2056.7 1987.5 2058 C
+1988.7 2057.7 1990.7 2054.4 1993 2056.4 C
+1993.4 2058.8 1996 2058.2 1996.6 2060.9 C
+1999 2061 1998.5 2064.5 2001.9 2065.2 C
+2001.5 2066.5 2002.7 2066.7 2003.6 2066.9 C
+2005.7 2066.7 2004.6 2066 2005 2064.8 C
+2004 2064 2004.8 2062.7 2004.3 2061.9 C
+2004.6 2056.6 2004.6 2050.4 2004.3 2045.6 C
+2003.7 2045.3 2004.6 2044.9 2004.8 2044.6 C
+2005 2045.1 2005.7 2044.5 2006 2045.1 C
+2006 2052.1 2005.8 2060.4 2006.2 2067.9 C
+2008.7 2068.2 2004.4 2071.1 2006.9 2069.3 C
+2006.4 2068.2 2006.2 2067 2006.2 2065.7 C
+[0 0.4 1 0] vc
+f
+S
+n
+2021.8 2041.7 m
+2018.3 2044.1 2014.1 2044.8 2010.5 2047 C
+2009.3 2045 2011.7 2042.6 2008.8 2041.7 C
+2004.3 2035.1 1997.6 2030.9 1993 2024.4 C
+1992.1 2024 1991.5 2024.3 1990.8 2024 C
+1993.2 2023.9 1995.3 2027.1 1996.8 2029 C
+2000.4 2032.6 2004.9 2036.9 2008.4 2040.8 C
+2008.2 2043.1 2011.4 2042.8 2009.8 2045.8 C
+2009.8 2046.3 2009.7 2046.9 2010 2047.2 C
+2013.8 2045 2018.5 2044.5 2021.8 2041.7 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+2001.6 2034 m
+2000.7 2033.1 1999.9 2032.3 1999 2031.4 C
+1999.9 2032.3 2000.7 2033.1 2001.6 2034 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+vmrs
+1989.4 2024.4 m
+1989.5 2025.4 1988.6 2024.3 1988.9 2024.7 C
+1990.5 2025.8 1990.7 2024.2 1992.8 2024.9 C
+1993.8 2025.9 1995 2027.1 1995.9 2028 C
+1994.3 2026 1991.9 2023.4 1989.4 2024.4 C
+[0 0.87 0.91 0.83] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1984.8 2019.9 m
+1984.6 2018.6 1986.3 2017.2 1987.7 2016.8 C
+1987.2 2017.5 1982.9 2017.9 1984.4 2020.6 C
+1984.1 2019.9 1984.9 2020 1984.8 2019.9 C
+f
+S
+n
+1981.7 2017 m
+1979.6 2022 1977.6 2012.3 1979.1 2018.4 C
+1979.8 2018.1 1981.5 2017.2 1981.7 2017 C
+f
+S
+n
+1884.3 2019.2 m
+1884.7 2010.5 1884.5 2000.6 1884.5 1991.8 C
+1886.6 1989.3 1889.9 1988.9 1892.4 1987 C
+1890.8 1988.7 1886 1989.1 1884.3 1992.3 C
+1884.7 2001 1884.5 2011.3 1884.5 2019.9 C
+1891 2025.1 1895.7 2031.5 1902 2036.9 C
+1896.1 2031 1890 2024.9 1884.3 2019.2 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1884 2019.4 m
+1884.5 2010.6 1884.2 2000.4 1884.3 1991.8 C
+1884.8 1990.4 1887.8 1989 1884.8 1990.8 C
+1884.3 1991.3 1884.3 1992 1884 1992.5 C
+1884.5 2001.2 1884.2 2011.1 1884.3 2019.9 C
+1887.9 2023.1 1891.1 2026.4 1894.4 2030 C
+1891.7 2026.1 1887.1 2022.9 1884 2019.4 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1885 2011.7 m
+1885 2006.9 1885 2001.9 1885 1997.1 C
+1885 2001.9 1885 2006.9 1885 2011.7 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1975.5 2036.4 m
+1975.2 2028 1976 2019.7 1975.5 2013.4 C
+1971.1 2008.5 1965.6 2003.6 1961.6 1999 C
+1958.8 1998 1956 2000 1953.6 2001.2 C
+1948.2 2004.7 1941.9 2006.5 1937.1 2010.8 C
+1937.5 2018.3 1937.3 2024.7 1937.3 2032.1 C
+1937.6 2025.6 1937.9 2018.4 1937.1 2011.5 C
+1937.3 2011 1937.6 2010.5 1937.8 2010 C
+1944.6 2005.7 1951.9 2002.3 1959.2 1999 C
+1960.1 1998.5 1960.1 1999.8 1960.4 2000.4 C
+1959.7 2006.9 1959.7 2014.2 1959.4 2021.1 C
+1959 2021.1 1959.2 2021.9 1959.2 2022.3 C
+1959.2 2021.9 1959 2021.3 1959.4 2021.1 C
+1959.8 2024.1 1959.2 2026.2 1962.5 2027.3 C
+1963 2029.2 1965.3 2029.2 1965.9 2031.6 C
+1968.3 2031.8 1967.8 2035.2 1971.2 2036 C
+1970.8 2037.2 1971.9 2037.5 1972.8 2037.6 C
+1974.9 2037.4 1973.9 2036.7 1974.3 2035.5 C
+1973.3 2034.7 1974.1 2033.4 1973.6 2032.6 C
+1973.9 2027.3 1973.9 2021.1 1973.6 2016.3 C
+1973 2016 1973.9 2015.6 1974 2015.3 C
+1974.3 2015.9 1975 2015.3 1975.2 2015.8 C
+1975.3 2022.8 1975.1 2031.2 1975.5 2038.6 C
+1977.9 2039 1973.7 2041.8 1976.2 2040 C
+1975.7 2039 1975.5 2037.8 1975.5 2036.4 C
+[0 0.4 1 0] vc
+f
+S
+n
+1991.1 2012.4 m
+1987.5 2014.8 1983.4 2015.6 1979.8 2017.7 C
+1978.5 2015.7 1981 2013.3 1978.1 2012.4 C
+1973.6 2005.8 1966.8 2001.6 1962.3 1995.2 C
+1961.4 1994.7 1960.8 1995 1960.1 1994.7 C
+1962.5 1994.6 1964.6 1997.8 1966.1 1999.7 C
+1969.7 2003.3 1974.2 2007.6 1977.6 2011.5 C
+1977.5 2013.8 1980.6 2013.5 1979.1 2016.5 C
+1979.1 2017 1979 2017.6 1979.3 2018 C
+1983.1 2015.7 1987.8 2015.2 1991.1 2012.4 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1970.9 2004.8 m
+1970 2003.9 1969.2 2003 1968.3 2002.1 C
+1969.2 2003 1970 2003.9 1970.9 2004.8 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1887.9 1994.9 m
+1888.5 1992.3 1891.4 1992.2 1893.2 1990.8 C
+1898.4 1987.5 1904 1984.8 1909.5 1982.2 C
+1909.7 1982.7 1910.3 1982.1 1910.4 1982.7 C
+1909.5 1990.5 1910.1 1996.4 1910 2004.5 C
+1909.1 2003.4 1909.7 2005.8 1909.5 2006.4 C
+1910.4 2006 1909.7 2008 1910.2 2007.9 C
+1911.3 2010.6 1912.5 2012.6 1915.7 2013.4 C
+1915.8 2013.7 1915.5 2014.4 1916 2014.4 C
+1916.3 2015 1915.4 2016 1915.2 2016 C
+1916.1 2015.5 1916.5 2014.5 1916 2013.6 C
+1913.4 2013.3 1913.1 2010.5 1910.9 2009.8 C
+1910.7 2008.8 1910.4 2007.9 1910.2 2006.9 C
+1911.1 1998.8 1909.4 1990.7 1910.7 1982.4 C
+1910 1982.1 1908.9 1982.1 1908.3 1982.4 C
+1901.9 1986.1 1895 1988.7 1888.8 1993 C
+1888 1993.4 1888.4 1994.3 1887.6 1994.7 C
+1888.1 2001.3 1887.8 2008.6 1887.9 2015.1 C
+1887.3 2017.5 1887.9 2015.4 1888.4 2014.4 C
+1887.8 2008 1888.4 2001.3 1887.9 1994.9 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+vmrs
+1887.9 2018.4 m
+1887.5 2016.9 1888.5 2016 1888.8 2014.8 C
+1890.1 2014.8 1891.1 2016.6 1892.4 2015.3 C
+1892.4 2014.4 1893.8 2012.9 1894.4 2012.4 C
+1895.9 2012.4 1896.6 2013.9 1897.7 2012.7 C
+1898.4 2011.7 1898.6 2010.4 1899.6 2009.8 C
+1901.7 2009.9 1902.9 2010.4 1904 2009.1 C
+1904.3 2007.4 1904 2007.6 1904.9 2007.2 C
+1906.2 2007 1907.6 2006.5 1908.8 2006.7 C
+1910.6 2008.2 1909.8 2011.5 1912.6 2012 C
+1912.4 2013 1913.8 2012.7 1914 2013.2 C
+1911.5 2011.1 1909.1 2007.9 1909.2 2004.3 C
+1909.5 2003.5 1909.9 2004.9 1909.7 2004.3 C
+1909.9 1996.2 1909.3 1990.5 1910.2 1982.7 C
+1909.5 1982.6 1909.5 1982.6 1908.8 1982.7 C
+1903.1 1985.7 1897 1987.9 1891.7 1992 C
+1890.5 1993 1888.2 1992.9 1888.1 1994.9 C
+1888.7 2001.4 1888.1 2008.4 1888.6 2014.8 C
+1888.3 2016 1887.2 2016.9 1887.6 2018.4 C
+1892.3 2023.9 1897.6 2027.9 1902.3 2033.3 C
+1898 2028.2 1892.1 2023.8 1887.9 2018.4 C
+[0.4 0.4 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1910.9 1995.2 m
+1910.4 1999.8 1911 2003.3 1910.9 2008.1 C
+1910.9 2003.8 1910.9 1999.2 1910.9 1995.2 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1911.2 2004.3 m
+1911.2 2001.9 1911.2 1999.7 1911.2 1997.3 C
+1911.2 1999.7 1911.2 2001.9 1911.2 2004.3 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1958.7 1995.2 m
+1959 1995.6 1956.2 1995 1956.5 1996.8 C
+1955.8 1997.6 1954.2 1998.5 1953.6 1997.3 C
+1953.6 1990.8 1954.9 1989.6 1953.4 1983.9 C
+1953.4 1983.3 1953.3 1982.1 1954.4 1982 C
+1955.5 1982.6 1956.5 1981.3 1957.5 1981 C
+1956.3 1981.8 1954.7 1982.6 1953.9 1981.5 C
+1951.4 1983 1954.7 1988.8 1952.9 1990.6 C
+1953.8 1990.6 1953.2 1992.7 1953.4 1993.7 C
+1953.8 1994.5 1952.3 1996.1 1953.2 1997.8 C
+1956.3 1999.4 1957.5 1994 1959.9 1995.6 C
+1962 1994.4 1963.7 1997.7 1965.2 1998.8 C
+1963.5 1996.7 1961.2 1994.1 1958.7 1995.2 C
+f
+S
+n
+1945 2000.7 m
+1945.4 1998.7 1945.4 1997.9 1945 1995.9 C
+1944.5 1995.3 1944.2 1992.6 1945.7 1993.2 C
+1946 1992.2 1948.7 1992.5 1948.4 1990.6 C
+1947.5 1990.3 1948.1 1988.7 1947.9 1988.2 C
+1948.9 1987.8 1950.5 1986.8 1950.5 1984.6 C
+1951.5 1980.9 1946.7 1983 1947.2 1979.8 C
+1944.5 1979.9 1945.2 1976.6 1943.1 1976.7 C
+1941.8 1975.7 1942.1 1972.7 1939.2 1973.8 C
+1938.2 1974.6 1939.3 1971.6 1938.3 1970.9 C
+1938.8 1969.2 1933.4 1970.3 1937.3 1970 C
+1939.4 1971.2 1937.2 1973 1937.6 1974.3 C
+1937.2 1976.3 1937.1 1981.2 1937.8 1984.1 C
+1938.8 1982.3 1937.9 1976.6 1938.5 1973.1 C
+1938.9 1975 1938.5 1976.4 1939.7 1977.2 C
+1939.5 1983.5 1938.9 1991.3 1940.2 1997.3 C
+1939.4 1999.1 1938.6 1997.1 1937.8 1997.1 C
+1937.4 1996.7 1937.6 1996.1 1937.6 1995.6 C
+1936.5 1998.5 1940.1 1998.4 1940.9 2000.7 C
+1942.1 2000.4 1943.2 2001.3 1943.1 2002.4 C
+1943.6 2003.1 1941.1 2004.6 1942.8 2003.8 C
+1943.9 2002.5 1942.6 2000.6 1945 2000.7 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1914.5 2006.4 m
+1914.1 2004.9 1915.2 2004 1915.5 2002.8 C
+1916.7 2002.8 1917.8 2004.6 1919.1 2003.3 C
+1919 2002.4 1920.4 2000.9 1921 2000.4 C
+1922.5 2000.4 1923.2 2001.9 1924.4 2000.7 C
+1925 1999.7 1925.3 1998.4 1926.3 1997.8 C
+1928.4 1997.9 1929.5 1998.4 1930.6 1997.1 C
+1930.9 1995.4 1930.7 1995.6 1931.6 1995.2 C
+1932.8 1995 1934.3 1994.5 1935.4 1994.7 C
+1936.1 1995.8 1936.9 1996.2 1936.6 1997.8 C
+1938.9 1999.4 1939.7 2001.3 1942.4 2002.4 C
+1942.4 2002.5 1942.2 2003 1942.6 2002.8 C
+1942.9 2000.4 1939.2 2001.8 1939.2 1999.7 C
+1936.2 1998.6 1937 1995.3 1935.9 1993.5 C
+1937.1 1986.5 1935.2 1977.9 1937.6 1971.2 C
+1937.6 1970.3 1936.6 1971 1936.4 1970.4 C
+1930.2 1973.4 1924 1976 1918.4 1980 C
+1917.2 1981 1914.9 1980.9 1914.8 1982.9 C
+1915.3 1989.4 1914.7 1996.4 1915.2 2002.8 C
+1914.9 2004 1913.9 2004.9 1914.3 2006.4 C
+1919 2011.9 1924.2 2015.9 1928.9 2021.3 C
+1924.6 2016.2 1918.7 2011.8 1914.5 2006.4 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1914.5 1982.9 m
+1915.1 1980.3 1918 1980.2 1919.8 1978.8 C
+1925 1975.5 1930.6 1972.8 1936.1 1970.2 C
+1939.4 1970.6 1936.1 1974.2 1936.6 1976.4 C
+1936.5 1981.9 1936.8 1987.5 1936.4 1992.8 C
+1935.9 1992.8 1936.2 1993.5 1936.1 1994 C
+1937.1 1993.6 1936.2 1995.9 1936.8 1995.9 C
+1937 1998 1939.5 1999.7 1940.4 2000.7 C
+1940.1 1998.6 1935 1997.2 1937.6 1993.7 C
+1938.3 1985.7 1935.9 1976.8 1937.8 1970.7 C
+1936.9 1969.8 1935.4 1970.3 1934.4 1970.7 C
+1928.3 1974.4 1921.4 1976.7 1915.5 1981 C
+1914.6 1981.4 1915.1 1982.3 1914.3 1982.7 C
+1914.7 1989.3 1914.5 1996.6 1914.5 2003.1 C
+1913.9 2005.5 1914.5 2003.4 1915 2002.4 C
+1914.5 1996 1915.1 1989.3 1914.5 1982.9 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1939.2 1994.9 m
+1939.3 1995 1939.4 1995.1 1939.5 1995.2 C
+1939.1 1989 1939.3 1981.6 1939 1976.7 C
+1938.6 1976.3 1938.6 1974.6 1938.5 1973.3 C
+1938.7 1976.1 1938.1 1979.4 1939 1981.7 C
+1937.3 1986 1937.7 1991.6 1938 1996.4 C
+1937.3 1994.3 1939.6 1996.2 1939.2 1994.9 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1938.3 1988.4 m
+1938.5 1990.5 1937.9 1994.1 1938.8 1994.7 C
+1937.9 1992.6 1939 1990.6 1938.3 1988.4 C
+[0 0.87 0.91 0.83] vc
+f
+S
+n
+1938.8 1985.8 m
+1938.5 1985.9 1938.4 1985.7 1938.3 1985.6 C
+1938.4 1986.2 1938 1989.5 1938.8 1987.2 C
+1938.8 1986.8 1938.8 1986.3 1938.8 1985.8 C
+f
+S
+n
+vmrs
+1972.8 2062.1 m
+1971.9 2061 1972.5 2059.4 1972.4 2058 C
+1972.2 2063.8 1971.9 2073.7 1972.4 2081.3 C
+1972.5 2074.9 1971.9 2067.9 1972.8 2062.1 C
+[0 1 1 0.36] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1940.2 2071.7 m
+1941.3 2072 1943.1 2072.3 1944 2071.5 C
+1943.6 2069.9 1945.2 2069.1 1946 2068.8 C
+1950 2071.1 1948.7 2065.9 1951.7 2066.2 C
+1953.5 2063.9 1956.9 2069.4 1955.6 2063.8 C
+1955.5 2064.2 1955.7 2064.8 1955.3 2065 C
+1954.3 2063.7 1956.2 2063.6 1955.6 2062.1 C
+1954.5 2060 1958.3 2050.3 1952.2 2055.6 C
+1949.1 2053.8 1946 2051 1943.8 2048 C
+1940.3 2048 1937.5 2051.3 1934.2 2052.5 C
+1933.1 2054.6 1934.4 2057.3 1934 2060 C
+1934 2065.1 1934 2069.7 1934 2074.6 C
+1934.4 2069 1934.1 2061.5 1934.2 2054.9 C
+1934.6 2054.5 1935.3 2054.7 1935.9 2054.7 C
+1937 2055.3 1935.9 2056.1 1935.9 2056.8 C
+1936.5 2063 1935.6 2070.5 1935.9 2074.6 C
+1936.7 2074.4 1937.3 2075.2 1938 2074.6 C
+1937.9 2073.6 1939.1 2072.1 1940.2 2071.7 C
+[0 0.2 1 0] vc
+f
+S
+n
+1933.2 2074.1 m
+1933.2 2071.5 1933.2 2069 1933.2 2066.4 C
+1933.2 2069 1933.2 2071.5 1933.2 2074.1 C
+[0 1 1 0.36] vc
+f
+S
+n
+2007.4 2048.9 m
+2006.5 2047.8 2007.1 2046.2 2006.9 2044.8 C
+2006.7 2050.6 2006.5 2060.5 2006.9 2068.1 C
+2007.1 2061.7 2006.5 2054.7 2007.4 2048.9 C
+f
+S
+n
+1927.2 2062.4 m
+1925.8 2060.1 1928.1 2058.2 1927 2056.4 C
+1927.3 2055.5 1926.5 2053.5 1926.8 2051.8 C
+1926.8 2052.8 1926 2052.5 1925.3 2052.5 C
+1924.1 2052.8 1925 2050.5 1924.4 2050.1 C
+1925.3 2050.2 1925.4 2048.8 1926.3 2049.4 C
+1926.5 2052.3 1928.4 2047.2 1928.4 2051.1 C
+1928.9 2050.5 1929 2051.4 1928.9 2051.8 C
+1928.9 2052 1928.9 2052.3 1928.9 2052.5 C
+1929.4 2051.4 1928.9 2049 1930.1 2048.2 C
+1928.9 2047.1 1930.5 2047.1 1930.4 2046.5 C
+1931.9 2046.2 1933.1 2046.1 1934.7 2046.5 C
+1934.6 2046.9 1935.2 2047.9 1934.4 2048.4 C
+1936.9 2048.1 1933.6 2043.8 1935.9 2043.9 C
+1935.7 2043.9 1934.8 2041.3 1933.2 2041.7 C
+1932.5 2041.6 1932.4 2039.6 1932.3 2041 C
+1930.8 2042.6 1929 2040.6 1927.7 2042 C
+1927.5 2041.4 1927.1 2040.9 1927.2 2040.3 C
+1927.8 2040.6 1927.4 2039.1 1928.2 2038.6 C
+1929.4 2038 1930.5 2038.8 1931.3 2037.9 C
+1931.7 2039 1932.5 2038.6 1931.8 2037.6 C
+1930.9 2037 1928.7 2037.8 1928.2 2037.9 C
+1926.7 2037.8 1928 2039 1927 2038.8 C
+1927.4 2040.4 1925.6 2040.8 1925.1 2041 C
+1924.3 2040.4 1923.2 2040.5 1922.2 2040.5 C
+1921.4 2041.7 1921 2043.9 1919.3 2043.9 C
+1918.8 2043.4 1917.2 2043.3 1916.4 2043.4 C
+1915.9 2044.4 1915.7 2046 1914.3 2046.5 C
+1913.1 2046.6 1912 2044.5 1911.4 2046.3 C
+1912.8 2046.5 1913.8 2047.4 1915.7 2047 C
+1916.9 2047.7 1915.6 2048.8 1916 2049.4 C
+1915.4 2049.3 1913.9 2050.3 1913.3 2051.1 C
+1913.9 2054.1 1916 2050.2 1916.7 2053 C
+1916.9 2053.8 1915.5 2054.1 1916.7 2054.4 C
+1917 2054.7 1920.2 2054.3 1919.3 2056.6 C
+1918.8 2056.1 1920.2 2058.6 1920.3 2057.6 C
+1921.2 2057.9 1922.1 2057.5 1922.4 2059 C
+1922.3 2059.1 1922.2 2059.3 1922 2059.2 C
+1922.1 2059.7 1922.4 2060.3 1922.9 2060.7 C
+1923.2 2060.1 1923.8 2060.4 1924.6 2060.7 C
+1925.9 2062.6 1923.2 2062 1925.6 2063.6 C
+1926.1 2063.1 1927.3 2062.5 1927.2 2062.4 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1933.2 2063.3 m
+1933.2 2060.7 1933.2 2058.2 1933.2 2055.6 C
+1933.2 2058.2 1933.2 2060.7 1933.2 2063.3 C
+[0 1 1 0.36] vc
+f
+S
+n
+1965.2 2049.2 m
+1967.1 2050.1 1969.9 2053.7 1972.1 2056.4 C
+1970.5 2054 1967.6 2051.3 1965.2 2049.2 C
+f
+S
+n
+1991.8 2034.8 m
+1991.7 2041.5 1992 2048.5 1991.6 2055.2 C
+1990.5 2056.4 1991.9 2054.9 1991.8 2054.4 C
+1991.8 2047.9 1991.8 2041.3 1991.8 2034.8 C
+f
+S
+n
+1988.9 2053.2 m
+1988.9 2044.3 1988.9 2036.6 1988.9 2028.3 C
+1985.7 2028.2 1987.2 2023.5 1983.9 2024.2 C
+1983.9 2022.4 1982 2021.6 1981 2021.3 C
+1980.6 2021.1 1980.6 2021.7 1980.3 2021.6 C
+1980.3 2027 1980.3 2034.8 1980.3 2041.5 C
+1979.3 2043.2 1977.6 2043 1976.2 2043.6 C
+1977.1 2043.8 1978.5 2043.2 1978.8 2044.1 C
+1978.5 2045.3 1979.9 2045.3 1980.3 2045.8 C
+1980.5 2046.8 1980.7 2046.2 1981.5 2046.5 C
+1982.4 2047.1 1982 2048.6 1982.7 2049.4 C
+1984.2 2049.6 1984.6 2052.2 1986.8 2051.6 C
+1987.1 2048.6 1985.1 2042.7 1986.5 2040.5 C
+1986.3 2036.7 1986.9 2031.7 1986 2029.2 C
+1986.3 2027.1 1986.9 2028.6 1987.7 2027.6 C
+1987.7 2028.3 1988.7 2028 1988.7 2028.8 C
+1988.1 2033 1988.7 2037.5 1988.2 2041.7 C
+1987.8 2041.4 1988 2040.8 1988 2040.3 C
+1988 2041 1988 2042.4 1988 2042.4 C
+1988 2042.4 1988.1 2042.3 1988.2 2042.2 C
+1989.3 2046 1988 2050.2 1988.4 2054 C
+1987.8 2054.4 1987.1 2054.7 1986.5 2055.4 C
+1987.4 2054.4 1988.4 2054.6 1988.9 2053.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1950.8 2054.4 m
+1949.7 2053.4 1948.7 2052.3 1947.6 2051.3 C
+1948.7 2052.3 1949.7 2053.4 1950.8 2054.4 C
+[0 1 1 0.36] vc
+f
+S
+n
+vmrs
+2006.7 2043.2 m
+2004.5 2040.8 2002.4 2038.4 2000.2 2036 C
+2002.4 2038.4 2004.5 2040.8 2006.7 2043.2 C
+[0 1 1 0.36] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1976.7 2019.6 m
+1975.8 2018.6 1976.4 2016.9 1976.2 2015.6 C
+1976 2021.3 1975.8 2031.2 1976.2 2038.8 C
+1976.4 2032.4 1975.8 2025.5 1976.7 2019.6 C
+f
+S
+n
+1988.4 2053.5 m
+1988.6 2049.2 1988.1 2042.8 1988 2040 C
+1988.4 2040.4 1988.1 2041 1988.2 2041.5 C
+1988.3 2037.2 1988 2032.7 1988.4 2028.5 C
+1987.6 2027.1 1987.2 2028.6 1986.8 2028 C
+1985.9 2028.5 1986.5 2029.7 1986.3 2030.4 C
+1986.9 2029.8 1986.6 2031 1987 2031.2 C
+1987.4 2039.6 1985 2043 1987.2 2050.4 C
+1987.2 2051.6 1985.9 2052.3 1984.6 2051.3 C
+1981.9 2049.7 1982.9 2047 1980.3 2046.5 C
+1980.3 2045.2 1978.1 2046.2 1978.6 2043.9 C
+1975.6 2043.3 1979.3 2045.6 1979.6 2046.5 C
+1980.8 2046.6 1981.5 2048.5 1982.2 2049.9 C
+1983.7 2050.8 1984.8 2052.8 1986.5 2053 C
+1986.7 2053.5 1987.5 2054.1 1987 2054.7 C
+1987.4 2053.9 1988.3 2054.3 1988.4 2053.5 C
+[0 1 1 0.23] vc
+f
+S
+n
+1988 2038.1 m
+1988 2036.7 1988 2035.4 1988 2034 C
+1988 2035.4 1988 2036.7 1988 2038.1 C
+[0 1 1 0.36] vc
+f
+S
+n
+1999.7 2035.7 m
+1997.6 2033.5 1995.4 2031.2 1993.2 2029 C
+1995.4 2031.2 1997.6 2033.5 1999.7 2035.7 C
+f
+S
+n
+1944 2029.2 m
+1945.2 2029.5 1946.9 2029.8 1947.9 2029 C
+1947.4 2027.4 1949 2026.7 1949.8 2026.4 C
+1953.9 2028.6 1952.6 2023.4 1955.6 2023.7 C
+1957.4 2021.4 1960.7 2027 1959.4 2021.3 C
+1959.3 2021.7 1959.6 2022.3 1959.2 2022.5 C
+1958.1 2021.2 1960.1 2021.1 1959.4 2019.6 C
+1959.1 2012.7 1959.9 2005.1 1959.6 1999.2 C
+1955.3 2000.1 1951.3 2003.1 1947.2 2005 C
+1943.9 2006 1941.2 2008.7 1938 2010 C
+1936.9 2012.1 1938.2 2014.8 1937.8 2017.5 C
+1937.8 2022.6 1937.8 2027.3 1937.8 2032.1 C
+1938.2 2026.5 1938 2019 1938 2012.4 C
+1938.5 2012 1939.2 2012.3 1939.7 2012.2 C
+1940.8 2012.8 1939.7 2013.6 1939.7 2014.4 C
+1940.4 2020.5 1939.4 2028 1939.7 2032.1 C
+1940.6 2031.9 1941.2 2032.7 1941.9 2032.1 C
+1941.7 2031.2 1943 2029.7 1944 2029.2 C
+[0 0.2 1 0] vc
+f
+S
+n
+1937.1 2031.6 m
+1937.1 2029.1 1937.1 2026.5 1937.1 2024 C
+1937.1 2026.5 1937.1 2029.1 1937.1 2031.6 C
+[0 1 1 0.36] vc
+f
+S
+n
+1991.8 2028 m
+1992.5 2027.8 1993.2 2029.9 1994 2030.2 C
+1992.9 2029.6 1993.1 2028.1 1991.8 2028 C
+[0 1 1 0.23] vc
+f
+S
+n
+1991.8 2027.8 m
+1992.4 2027.6 1992.6 2028.3 1993 2028.5 C
+1992.6 2028.2 1992.2 2027.6 1991.6 2027.8 C
+1991.6 2028.5 1991.6 2029.1 1991.6 2029.7 C
+1991.6 2029.1 1991.4 2028.3 1991.8 2027.8 C
+[0 1 1 0.36] vc
+f
+S
+n
+1985.8 2025.4 m
+1985.3 2025.2 1984.8 2024.7 1984.1 2024.9 C
+1983.3 2025.3 1983.6 2027.3 1983.9 2027.6 C
+1985 2028 1986.9 2026.9 1985.8 2025.4 C
+[0 1 1 0.23] vc
+f
+S
+n
+vmrs
+1993.5 2024.4 m
+1992.4 2023.7 1991.3 2022.9 1990.1 2023.2 C
+1990.7 2023.7 1989.8 2023.8 1989.4 2023.7 C
+1989.1 2023.7 1988.6 2023.9 1988.4 2023.5 C
+1988.5 2023.2 1988.3 2022.7 1988.7 2022.5 C
+1989 2022.6 1988.9 2023 1988.9 2023.2 C
+1989.1 2022.8 1990.4 2022.3 1990.6 2021.3 C
+1990.4 2021.8 1990 2021.3 1990.1 2021.1 C
+1990.1 2020.9 1990.1 2020.1 1990.1 2020.6 C
+1989.9 2021.1 1989.5 2020.6 1989.6 2020.4 C
+1989.6 2019.8 1988.7 2019.6 1988.2 2019.2 C
+1987.5 2018.7 1987.7 2020.2 1987 2019.4 C
+1987.5 2020.4 1986 2021.1 1987.5 2021.8 C
+1986.8 2023.1 1986.6 2021.1 1986 2021.1 C
+1986.1 2020.1 1985.9 2019 1986.3 2018.2 C
+1986.7 2018.4 1986.5 2019 1986.5 2019.4 C
+1986.5 2018.7 1986.4 2017.8 1987.2 2017.7 C
+1986.5 2017.2 1985.5 2019.3 1985.3 2020.4 C
+1986.2 2022 1987.3 2023.5 1989.2 2024.2 C
+1990.8 2024.3 1991.6 2022.9 1993.2 2024.4 C
+1993.8 2025.4 1995 2026.6 1995.9 2027.1 C
+1995 2026.5 1994.1 2025.5 1993.5 2024.4 C
+[0 1 1 0.36] vc
+f
+0.4 w
+2 J
+2 M
+[0 0.5 0.5 0.2] vc
+S
+n
+2023 2040.3 m
+2023.2 2036 2022.7 2029.6 2022.5 2026.8 C
+2022.9 2027.2 2022.7 2027.8 2022.8 2028.3 C
+2022.8 2024 2022.6 2019.5 2023 2015.3 C
+2022.2 2013.9 2021.7 2015.4 2021.3 2014.8 C
+2020.4 2015.3 2021 2016.5 2020.8 2017.2 C
+2021.4 2016.6 2021.1 2017.8 2021.6 2018 C
+2022 2026.4 2019.6 2029.8 2021.8 2037.2 C
+2021.7 2038.4 2020.5 2039.1 2019.2 2038.1 C
+2016.5 2036.5 2017.5 2033.8 2014.8 2033.3 C
+2014.9 2032 2012.6 2033 2013.2 2030.7 C
+2011.9 2030.8 2011.2 2030.1 2010.8 2029.2 C
+2010.8 2029.1 2010.8 2028.2 2010.8 2028.8 C
+2010 2028.8 2010.4 2026.5 2008.6 2027.3 C
+2007.9 2026.6 2007.3 2025.9 2007.9 2027.1 C
+2009.7 2028 2010 2030.1 2012.2 2030.9 C
+2012.9 2032.1 2013.7 2033.6 2015.1 2033.6 C
+2015.7 2035.1 2016.9 2036.7 2018.4 2038.4 C
+2019.8 2039.3 2022 2039.4 2021.6 2041.5 C
+2021.9 2040.7 2022.9 2041.1 2023 2040.3 C
+[0 1 1 0.23] vc
+f
+S
+n
+2022.5 2024.9 m
+2022.5 2023.5 2022.5 2022.2 2022.5 2020.8 C
+2022.5 2022.2 2022.5 2023.5 2022.5 2024.9 C
+[0 1 1 0.36] vc
+f
+S
+n
+1983.2 2022.8 m
+1982.4 2022.5 1982.1 2021.6 1981.2 2022.3 C
+1981.1 2022.9 1980.5 2024 1981 2024.2 C
+1981.8 2024.6 1982.9 2024.4 1983.2 2022.8 C
+[0 1 1 0.23] vc
+f
+S
+n
+1931.1 2019.9 m
+1929.6 2017.7 1932 2015.7 1930.8 2013.9 C
+1931.1 2013 1930.3 2011 1930.6 2009.3 C
+1930.6 2010.3 1929.8 2010 1929.2 2010 C
+1928 2010.3 1928.8 2008.1 1928.2 2007.6 C
+1929.1 2007.8 1929.3 2006.3 1930.1 2006.9 C
+1930.3 2009.8 1932.2 2004.8 1932.3 2008.6 C
+1932.7 2008 1932.8 2009 1932.8 2009.3 C
+1932.8 2009.6 1932.8 2009.8 1932.8 2010 C
+1933.2 2009 1932.7 2006.6 1934 2005.7 C
+1932.7 2004.6 1934.3 2004.6 1934.2 2004 C
+1935.8 2003.7 1937 2003.6 1938.5 2004 C
+1938.5 2004.5 1939.1 2005.4 1938.3 2006 C
+1940.7 2005.7 1937.4 2001.3 1939.7 2001.4 C
+1939.5 2001.4 1938.6 1998.8 1937.1 1999.2 C
+1936.3 1999.1 1936.2 1997.1 1936.1 1998.5 C
+1934.7 2000.1 1932.9 1998.2 1931.6 1999.5 C
+1931.3 1998.9 1930.9 1998.5 1931.1 1997.8 C
+1931.6 1998.2 1931.3 1996.6 1932 1996.1 C
+1933.2 1995.5 1934.3 1996.4 1935.2 1995.4 C
+1935.5 1996.5 1936.3 1996.1 1935.6 1995.2 C
+1934.7 1994.5 1932.5 1995.3 1932 1995.4 C
+1930.5 1995.3 1931.9 1996.5 1930.8 1996.4 C
+1931.2 1997.9 1929.5 1998.3 1928.9 1998.5 C
+1928.1 1997.9 1927.1 1998 1926 1998 C
+1925.3 1999.2 1924.8 2001.4 1923.2 2001.4 C
+1922.6 2000.9 1921 2000.9 1920.3 2000.9 C
+1919.7 2001.9 1919.6 2003.5 1918.1 2004 C
+1916.9 2004.1 1915.8 2002 1915.2 2003.8 C
+1916.7 2004 1917.6 2004.9 1919.6 2004.5 C
+1920.7 2005.2 1919.4 2006.3 1919.8 2006.9 C
+1919.2 2006.9 1917.7 2007.8 1917.2 2008.6 C
+1917.8 2011.6 1919.8 2007.8 1920.5 2010.5 C
+1920.8 2011.3 1919.3 2011.6 1920.5 2012 C
+1920.8 2012.3 1924 2011.8 1923.2 2014.1 C
+1922.6 2013.6 1924.1 2016.1 1924.1 2015.1 C
+1925.1 2015.4 1925.9 2015 1926.3 2016.5 C
+1926.2 2016.6 1926 2016.8 1925.8 2016.8 C
+1925.9 2017.2 1926.2 2017.8 1926.8 2018.2 C
+1927.1 2017.6 1927.7 2018 1928.4 2018.2 C
+1929.7 2020.1 1927.1 2019.5 1929.4 2021.1 C
+1929.9 2020.7 1931.1 2020 1931.1 2019.9 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1937.1 2020.8 m
+1937.1 2018.3 1937.1 2015.7 1937.1 2013.2 C
+1937.1 2015.7 1937.1 2018.3 1937.1 2020.8 C
+[0 1 1 0.36] vc
+f
+S
+n
+2020.4 2012.2 m
+2019.8 2012 2019.3 2011.5 2018.7 2011.7 C
+2017.9 2012.1 2018.1 2014.1 2018.4 2014.4 C
+2019.6 2014.8 2021.4 2013.7 2020.4 2012.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1976 2013.9 m
+1973.8 2011.5 1971.6 2009.1 1969.5 2006.7 C
+1971.6 2009.1 1973.8 2011.5 1976 2013.9 C
+[0 1 1 0.36] vc
+f
+S
+n
+1995.4 2012.7 m
+1996.1 2010.3 1993.8 2006.2 1997.3 2005.7 C
+1998.9 2005.4 2000 2003.7 2001.4 2003.1 C
+2003.9 2003.1 2005.3 2001.3 2006.9 1999.7 C
+2004.5 2003.5 2000 2002.2 1997.6 2005.7 C
+1996.5 2005.9 1994.8 2006.1 1995.2 2007.6 C
+1995.7 2009.4 1995.2 2011.6 1994.7 2012.9 C
+1992 2015.8 1987.8 2015.7 1985.3 2018.7 C
+1988.3 2016.3 1992.3 2015.3 1995.4 2012.7 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1995.6 2012.4 m
+1995.6 2011.2 1995.6 2010 1995.6 2008.8 C
+1995.6 2010 1995.6 2011.2 1995.6 2012.4 C
+[0 1 1 0.36] vc
+f
+S
+n
+vmrs
+2017.7 2009.6 m
+2016.9 2009.3 2016.7 2008.4 2015.8 2009.1 C
+2014.2 2010.6 2016 2010.6 2016.5 2011.5 C
+2017.2 2010.9 2018.1 2010.8 2017.7 2009.6 C
+[0 1 1 0.23] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+2014.4 2006.4 m
+2013.5 2006.8 2012.1 2005.6 2012 2006.7 C
+2013 2007.3 2011.9 2009.2 2012.9 2008.4 C
+2014.2 2008.3 2014.6 2007.8 2014.4 2006.4 C
+f
+S
+n
+1969 2006.4 m
+1966.5 2003.8 1964 2001.2 1961.6 1998.5 C
+1964 2001.2 1966.5 2003.8 1969 2006.4 C
+[0 1 1 0.36] vc
+f
+S
+n
+2012 2005.2 m
+2012.2 2004.2 2011.4 2003.3 2010.3 2003.3 C
+2009 2003.6 2010 2004.7 2009.6 2004.8 C
+2009.3 2005.7 2011.4 2006.7 2012 2005.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1962.8 1995.2 m
+1961.7 1994.4 1960.6 1993.7 1959.4 1994 C
+1959.5 1994.9 1957.5 1994.1 1956.8 1994.7 C
+1955.9 1995.5 1956.7 1997 1955.1 1997.3 C
+1956.9 1996.7 1956.8 1994 1959.2 1994.7 C
+1961.1 1991 1968.9 2003.2 1962.8 1995.2 C
+[0 1 1 0.36] vc
+f
+S
+n
+1954.6 1995.6 m
+1955.9 1994.7 1955.1 1989.8 1955.3 1988 C
+1954.5 1988.3 1954.9 1986.6 1954.4 1986 C
+1955.7 1989.2 1953.9 1991.1 1954.8 1994.2 C
+1954.5 1995.9 1953.5 1995.3 1953.9 1997.3 C
+1955.3 1998.3 1953.2 1995.5 1954.6 1995.6 C
+f
+S
+n
+1992.3 2011 m
+1992.5 2006.7 1992 2000.3 1991.8 1997.6 C
+1992.2 1997.9 1992 1998.5 1992 1999 C
+1992.1 1994.7 1991.9 1990.2 1992.3 1986 C
+1991.4 1984.6 1991 1986.1 1990.6 1985.6 C
+1989.7 1986 1990.3 1987.2 1990.1 1988 C
+1990.7 1987.4 1990.4 1988.5 1990.8 1988.7 C
+1991.3 1997.1 1988.9 2000.6 1991.1 2007.9 C
+1991 2009.1 1989.8 2009.9 1988.4 2008.8 C
+1985.7 2007.2 1986.8 2004.5 1984.1 2004 C
+1984.2 2002.7 1981.9 2003.7 1982.4 2001.4 C
+1981.2 2001.5 1980.5 2000.8 1980 2000 C
+1980 1999.8 1980 1998.9 1980 1999.5 C
+1979.3 1999.5 1979.7 1997.2 1977.9 1998 C
+1977.2 1997.3 1976.6 1996.7 1977.2 1997.8 C
+1979 1998.7 1979.3 2000.8 1981.5 2001.6 C
+1982.2 2002.8 1983 2004.3 1984.4 2004.3 C
+1985 2005.8 1986.2 2007.5 1987.7 2009.1 C
+1989 2010 1991.3 2010.2 1990.8 2012.2 C
+1991.2 2011.4 1992.2 2011.8 1992.3 2011 C
+[0 1 1 0.23] vc
+f
+S
+n
+1991.8 1995.6 m
+1991.8 1994.3 1991.8 1992.9 1991.8 1991.6 C
+1991.8 1992.9 1991.8 1994.3 1991.8 1995.6 C
+[0 1 1 0.36] vc
+f
+S
+n
+1959.2 1994.2 m
+1958.8 1993.3 1960.7 1993.9 1961.1 1993.7 C
+1961.5 1993.9 1961.2 1994.4 1961.8 1994.2 C
+1960.9 1994 1960.8 1992.9 1959.9 1992.5 C
+1959.6 1993.5 1958.3 1993.5 1958.2 1994.2 C
+1958.1 1994.1 1958 1994 1958 1994 C
+1957.2 1994.9 1958 1993.4 1956.8 1993 C
+1955.6 1992.5 1956 1991 1956.3 1989.9 C
+1956.5 1989.8 1956.6 1990 1956.8 1990.1 C
+1957.1 1989 1956 1989.1 1955.8 1988.2 C
+1955.1 1990.4 1956.2 1995 1954.8 1995.9 C
+1954.1 1995.5 1954.5 1996.5 1954.4 1997.1 C
+1955 1996.8 1954.8 1997.4 1955.6 1996.8 C
+1956 1996 1956.3 1993.2 1958.7 1994.2 C
+1958.9 1994.2 1959.7 1994.2 1959.2 1994.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1958.2 1994 m
+1958.4 1993.5 1959.7 1993.1 1959.9 1992 C
+1959.7 1992.5 1959.3 1992 1959.4 1991.8 C
+1959.4 1991.6 1959.4 1990.8 1959.4 1991.3 C
+1959.2 1991.8 1958.8 1991.3 1958.9 1991.1 C
+1958.9 1990.5 1958 1990.3 1957.5 1989.9 C
+1956.8 1989.5 1956.9 1991 1956.3 1990.1 C
+1956.7 1991 1955.4 1992.1 1956.5 1992.3 C
+1956.8 1993.5 1958.3 1992.9 1957.2 1994 C
+1957.8 1994.3 1958.1 1992.4 1958.2 1994 C
+[0 0.5 0.5 0.2] vc
+f
+S
+n
+vmrs
+1954.4 1982.7 m
+1956.1 1982.7 1954.1 1982.5 1953.9 1982.9 C
+1953.9 1983.7 1953.7 1984.7 1954.1 1985.3 C
+1954.4 1984.2 1953.6 1983.6 1954.4 1982.7 C
+[0 1 1 0.36] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1989.6 1982.9 m
+1989.1 1982.7 1988.6 1982.3 1988 1982.4 C
+1987.2 1982.8 1987.4 1984.8 1987.7 1985.1 C
+1988.9 1985.6 1990.7 1984.4 1989.6 1982.9 C
+[0 1 1 0.23] vc
+f
+S
+n
+1987 1980.3 m
+1986.2 1980 1986 1979.1 1985.1 1979.8 C
+1983.5 1981.4 1985.3 1981.4 1985.8 1982.2 C
+1986.5 1981.7 1987.4 1981.5 1987 1980.3 C
+f
+S
+n
+1983.6 1977.2 m
+1982.7 1977.5 1981.4 1976.3 1981.2 1977.4 C
+1982.3 1978 1981.2 1979.9 1982.2 1979.1 C
+1983.5 1979 1983.9 1978.5 1983.6 1977.2 C
+f
+S
+n
+1981.2 1976 m
+1981.5 1974.9 1980.6 1974 1979.6 1974 C
+1978.3 1974.3 1979.3 1975.4 1978.8 1975.5 C
+1978.6 1976.4 1980.7 1977.4 1981.2 1976 C
+f
+S
+n
+1972.1 2082.3 m
+1971.8 2081.8 1971.3 2080.9 1971.2 2080.1 C
+1971.1 2072.9 1971.3 2064.6 1970.9 2058.3 C
+1970.3 2058.5 1970.1 2057.7 1969.7 2058.5 C
+1970.6 2058.5 1969.7 2059 1970.2 2059.2 C
+1970.2 2065.4 1970.2 2072.4 1970.2 2077.7 C
+1971.1 2078.9 1970.6 2078.9 1970.4 2079.9 C
+1969.2 2080.2 1968.2 2080.4 1967.3 2079.6 C
+1966.8 2077.8 1963.4 2076.3 1963.5 2075.1 C
+1961.5 2075.5 1962 2071.5 1959.6 2072 C
+1959.2 2070 1956.5 2069.3 1955.8 2067.6 C
+1956 2068.4 1955.3 2069.7 1956.5 2069.8 C
+1958.6 2068.9 1958.1 2073.5 1960.1 2072.4 C
+1960.7 2075.9 1964.7 2074.6 1964.2 2078 C
+1967.2 2078.6 1967.9 2081.6 1970.7 2080.6 C
+1970.3 2081.1 1971.5 2081.2 1971.9 2082.3 C
+1967.2 2084.3 1962.9 2087.1 1958.2 2089 C
+1962.9 2087 1967.4 2084.4 1972.1 2082.3 C
+[0 0.2 1 0] vc
+f
+S
+n
+1971.9 2080.1 m
+1971.9 2075.1 1971.9 2070 1971.9 2065 C
+1971.9 2070 1971.9 2075.1 1971.9 2080.1 C
+[0 1 1 0.23] vc
+f
+S
+n
+2010.8 2050.6 m
+2013.2 2049 2010.5 2050.1 2010.5 2051.3 C
+2010.5 2057.7 2010.5 2064.1 2010.5 2070.5 C
+2008.7 2072.4 2006 2073.3 2003.6 2074.4 C
+2016.4 2073.7 2008 2058.4 2010.8 2050.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+2006.4 2066.9 m
+2006.4 2061.9 2006.4 2056.8 2006.4 2051.8 C
+2006.4 2056.8 2006.4 2061.9 2006.4 2066.9 C
+[0 1 1 0.23] vc
+f
+S
+n
+1971.9 2060.7 m
+1972.2 2060.3 1971.4 2068.2 1972.4 2061.9 C
+1971.8 2061.6 1972.4 2060.9 1971.9 2060.7 C
+f
+S
+n
+vmrs
+1986.5 2055.2 m
+1987.5 2054.3 1986.3 2053.4 1986 2052.8 C
+1983.8 2052.7 1983.6 2050.1 1981.7 2049.6 C
+1981.2 2048.7 1980.8 2047 1980.3 2046.8 C
+1978.5 2047 1978 2044.6 1976.7 2043.9 C
+1974 2044.4 1972 2046.6 1969.2 2047 C
+1969 2047.2 1968.8 2047.5 1968.5 2047.7 C
+1970.6 2049.6 1973.1 2051.3 1974.3 2054.2 C
+1975.7 2054.5 1977 2055.2 1976.4 2057.1 C
+1976.7 2058 1975.5 2058.5 1976 2059.5 C
+1979.2 2058 1983 2056.6 1986.5 2055.2 C
+[0 0.5 0.5 0.2] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1970.2 2054.2 m
+1971.5 2055.3 1972.5 2056.8 1972.1 2058.3 C
+1972.8 2056.5 1971.6 2055.6 1970.2 2054.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1992 2052.5 m
+1992 2053.4 1992.2 2054.4 1991.8 2055.2 C
+1992.2 2054.4 1992 2053.4 1992 2052.5 C
+f
+S
+n
+1957.2 2053 m
+1958.1 2052.6 1959 2052.2 1959.9 2051.8 C
+1959 2052.2 1958.1 2052.6 1957.2 2053 C
+f
+S
+n
+2006.4 2047.5 m
+2006.8 2047.1 2006 2055 2006.9 2048.7 C
+2006.4 2048.4 2007 2047.7 2006.4 2047.5 C
+f
+S
+n
+2004.8 2041 m
+2006.1 2042.1 2007.1 2043.6 2006.7 2045.1 C
+2007.3 2043.3 2006.2 2042.4 2004.8 2041 C
+f
+S
+n
+1976 2039.8 m
+1975.6 2039.3 1975.2 2038.4 1975 2037.6 C
+1974.9 2030.4 1975.2 2022.1 1974.8 2015.8 C
+1974.2 2016 1974 2015.3 1973.6 2016 C
+1974.4 2016 1973.5 2016.5 1974 2016.8 C
+1974 2022.9 1974 2030 1974 2035.2 C
+1974.9 2036.4 1974.4 2036.4 1974.3 2037.4 C
+1973.1 2037.7 1972 2037.9 1971.2 2037.2 C
+1970.6 2035.3 1967.3 2033.9 1967.3 2032.6 C
+1965.3 2033 1965.9 2029.1 1963.5 2029.5 C
+1963 2027.6 1960.4 2026.8 1959.6 2025.2 C
+1959.8 2025.9 1959.2 2027.2 1960.4 2027.3 C
+1962.5 2026.4 1961.9 2031 1964 2030 C
+1964.6 2033.4 1968.5 2032.1 1968 2035.5 C
+1971 2036.1 1971.8 2039.1 1974.5 2038.1 C
+1974.2 2038.7 1975.3 2038.7 1975.7 2039.8 C
+1971 2041.8 1966.7 2044.6 1962 2046.5 C
+1966.8 2044.5 1971.3 2041.9 1976 2039.8 C
+[0 0.2 1 0] vc
+f
+S
+n
+1975.7 2037.6 m
+1975.7 2032.6 1975.7 2027.6 1975.7 2022.5 C
+1975.7 2027.6 1975.7 2032.6 1975.7 2037.6 C
+[0 1 1 0.23] vc
+f
+S
+n
+1992 2035.5 m
+1992 2034.2 1992 2032.9 1992 2031.6 C
+1992 2032.9 1992 2034.2 1992 2035.5 C
+f
+S
+n
+2015.3 2036 m
+2015.4 2034.1 2013.3 2034 2012.9 2033.3 C
+2011.5 2031 2009.3 2029.4 2007.4 2028 C
+2006.9 2027.1 2006.6 2023.8 2005 2024.9 C
+2004 2024.9 2002.9 2024.9 2001.9 2024.9 C
+2001.4 2026.5 2001 2028.4 2003.8 2028.3 C
+2006.6 2030.4 2008.9 2033.7 2011.2 2036.2 C
+2011.8 2036.4 2012.9 2035.8 2012.9 2036.7 C
+2013 2035.5 2015.3 2037.4 2015.3 2036 C
+[0 0 0 0] vc
+f
+S
+n
+vmrs
+2009.1 2030.4 m
+2009.1 2029 2007.5 2029.4 2006.9 2028.3 C
+2007.2 2027.1 2006.5 2025.5 2005.7 2024.7 C
+2004.6 2025.1 2003.1 2024.9 2001.9 2024.9 C
+2001.8 2026.2 2000.9 2027 2002.4 2028 C
+2004.5 2027.3 2004.9 2029.4 2006.9 2029 C
+2007 2030.2 2007.6 2030.7 2008.4 2031.4 C
+2008.8 2031.5 2009.1 2031.1 2009.1 2030.4 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+2003.8 2029.5 m
+2003 2029.4 2001.9 2029.1 2002.4 2030.4 C
+2003.1 2031.3 2005.2 2030.3 2003.8 2029.5 C
+[0 1 1 0.23] vc
+f
+S
+n
+1999.2 2025.2 m
+1999.1 2025.6 1998 2025.7 1998.8 2026.6 C
+2000.9 2028.5 1999.5 2023.4 1999.2 2025.2 C
+f
+S
+n
+2007.6 2024.2 m
+2007.6 2022.9 2008.4 2024.2 2007.6 2022.8 C
+2007.6 2017.5 2007.8 2009.1 2007.4 2003.8 C
+2007.9 2003.7 2008.7 2002.8 2009.1 2002.1 C
+2009.6 2000.8 2008.3 2000.8 2007.9 2000.2 C
+2004.9 2000 2008.9 2001.3 2007.2 2002.1 C
+2006.7 2007.7 2007 2015.1 2006.9 2021.1 C
+2006.7 2022.1 2005.4 2022.8 2006.2 2023.5 C
+2006.6 2023.1 2008 2025.9 2007.6 2024.2 C
+f
+S
+n
+1989.9 2023.5 m
+1989.5 2022.6 1991.4 2023.2 1991.8 2023 C
+1992.2 2023.2 1991.9 2023.7 1992.5 2023.5 C
+1991.6 2023.2 1991.6 2022.2 1990.6 2021.8 C
+1990.4 2022.8 1989 2022.8 1988.9 2023.5 C
+1988.5 2023 1988.7 2022.6 1988.7 2023.5 C
+1989.1 2023.5 1990.2 2023.5 1989.9 2023.5 C
+f
+[0 0.5 0.5 0.2] vc
+S
+n
+2003.3 2023.5 m
+2003.1 2023.3 2003.1 2023.2 2003.3 2023 C
+2003.7 2023.1 2003.9 2022.9 2003.8 2022.5 C
+2003.4 2022.2 2001.2 2022.3 2002.4 2023 C
+2002.6 2022.9 2002.7 2023.1 2002.8 2023.2 C
+2000.7 2023.7 2003.9 2023.4 2003.3 2023.5 C
+[0 1 1 0.23] vc
+f
+S
+n
+1986.8 2019.4 m
+1987.8 2019.8 1987.5 2018.6 1987.2 2018 C
+1986.2 2017.8 1987.3 2020.5 1986.3 2019.2 C
+1986.3 2017.7 1986.3 2020.6 1986.3 2021.3 C
+1988.5 2023.1 1985.6 2020.3 1986.8 2019.4 C
+f
+S
+n
+1975.7 2018.2 m
+1976.1 2017.8 1975.2 2025.7 1976.2 2019.4 C
+1975.7 2019.2 1976.3 2018.4 1975.7 2018.2 C
+f
+S
+n
+1974 2011.7 m
+1975.4 2012.8 1976.4 2014.3 1976 2015.8 C
+1976.6 2014 1975.5 2013.1 1974 2011.7 C
+f
+S
+n
+1984.6 2006.7 m
+1984.7 2004.8 1982.6 2004.8 1982.2 2004 C
+1980.8 2001.7 1978.6 2000.1 1976.7 1998.8 C
+1976.1 1997.8 1975.8 1994.5 1974.3 1995.6 C
+1973.3 1995.6 1972.2 1995.6 1971.2 1995.6 C
+1970.7 1997.2 1970.3 1999.1 1973.1 1999 C
+1975.8 2001.2 1978.2 2004.4 1980.5 2006.9 C
+1981.1 2007.1 1982.1 2006.5 1982.2 2007.4 C
+1982.3 2006.2 1984.5 2008.1 1984.6 2006.7 C
+[0 0 0 0] vc
+f
+S
+n
+vmrs
+1978.4 2001.2 m
+1978.4 1999.7 1976.8 2000.1 1976.2 1999 C
+1976.5 1997.8 1975.8 1996.2 1975 1995.4 C
+1973.9 1995.8 1972.4 1995.6 1971.2 1995.6 C
+1971 1997 1970.2 1997.7 1971.6 1998.8 C
+1973.8 1998 1974.2 2000.1 1976.2 1999.7 C
+1976.3 2000.9 1976.9 2001.4 1977.6 2002.1 C
+1978.1 2002.2 1978.4 2001.8 1978.4 2001.2 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1973.1 2000.2 m
+1972.3 2000.1 1971.2 1999.8 1971.6 2001.2 C
+1972.4 2002 1974.5 2001 1973.1 2000.2 C
+[0 1 1 0.23] vc
+f
+S
+n
+1960.8 1998.5 m
+1961.6 1998.2 1962.6 2000.3 1963.2 2000.9 C
+1962.3 2000.1 1962.2 1998.7 1960.8 1998.5 C
+f
+S
+n
+1968.5 1995.9 m
+1968.4 1996.4 1967.3 1996.4 1968 1997.3 C
+1970.1 1999.2 1968.8 1994.1 1968.5 1995.9 C
+f
+S
+n
+1976.9 1994.9 m
+1976.9 1993.7 1977.6 1994.9 1976.9 1993.5 C
+1976.9 1988.2 1977.1 1979.8 1976.7 1974.5 C
+1977.2 1974.5 1978 1973.5 1978.4 1972.8 C
+1978.8 1971.5 1977.6 1971.5 1977.2 1970.9 C
+1974.2 1970.7 1978.2 1972 1976.4 1972.8 C
+1976 1978.4 1976.3 1985.8 1976.2 1991.8 C
+1976 1992.8 1974.6 1993.5 1975.5 1994.2 C
+1975.9 1993.8 1977.3 1996.6 1976.9 1994.9 C
+f
+S
+n
+1972.6 1994.2 m
+1972.4 1994 1972.4 1993.9 1972.6 1993.7 C
+1973 1993.8 1973.1 1993.7 1973.1 1993.2 C
+1972.7 1992.9 1970.5 1993.1 1971.6 1993.7 C
+1971.9 1993.7 1972 1993.8 1972.1 1994 C
+1970 1994.4 1973.1 1994.1 1972.6 1994.2 C
+f
+S
+n
+1948.1 2093.8 m
+1947 2092.7 1945.9 2091.6 1944.8 2090.4 C
+1945.9 2091.6 1947 2092.7 1948.1 2093.8 C
+[0 0.4 1 0] vc
+f
+S
+n
+1953.4 2091.4 m
+1954.8 2090.7 1956.3 2090 1957.7 2089.2 C
+1956.3 2090 1954.8 2090.7 1953.4 2091.4 C
+[0 0.2 1 0] vc
+f
+S
+n
+1954.1 2091.4 m
+1956.6 2089.6 1957.2 2089.6 1954.1 2091.4 C
+[0 0.4 1 0] vc
+f
+S
+n
+1962.3 2087.3 m
+1963.7 2086.6 1965.2 2085.9 1966.6 2085.2 C
+1965.2 2085.9 1963.7 2086.6 1962.3 2087.3 C
+f
+S
+n
+vmrs
+1967.1 2084.9 m
+1968.3 2084.4 1969.7 2083.8 1970.9 2083.2 C
+1969.7 2083.8 1968.3 2084.4 1967.1 2084.9 C
+[0 0.4 1 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1982.7 2080.6 m
+1981.5 2079.5 1980.5 2078.4 1979.3 2077.2 C
+1980.5 2078.4 1981.5 2079.5 1982.7 2080.6 C
+f
+S
+n
+1988 2078.2 m
+1989.4 2077.5 1990.8 2076.8 1992.3 2076 C
+1990.8 2076.8 1989.4 2077.5 1988 2078.2 C
+[0 0.2 1 0] vc
+f
+S
+n
+1988.7 2078.2 m
+1991.1 2076.4 1991.8 2076.4 1988.7 2078.2 C
+[0 0.4 1 0] vc
+f
+S
+n
+1976.2 2063.8 m
+1978.6 2062.2 1976 2063.3 1976 2064.5 C
+1976.1 2067.8 1975.5 2071.4 1976.4 2074.4 C
+1975.7 2071.1 1975.9 2067.2 1976.2 2063.8 C
+f
+S
+n
+1996.8 2074.1 m
+1998.3 2073.4 1999.7 2072.7 2001.2 2072 C
+1999.7 2072.7 1998.3 2073.4 1996.8 2074.1 C
+f
+S
+n
+2001.6 2071.7 m
+2002.9 2071.2 2004.2 2070.6 2005.5 2070 C
+2004.2 2070.6 2002.9 2071.2 2001.6 2071.7 C
+f
+S
+n
+1981.5 2060.7 m
+1980.2 2061.2 1978.9 2061.5 1977.9 2062.6 C
+1978.9 2061.5 1980.2 2061.2 1981.5 2060.7 C
+f
+S
+n
+1982 2060.4 m
+1982.7 2060.1 1983.6 2059.8 1984.4 2059.5 C
+1983.6 2059.8 1982.7 2060.1 1982 2060.4 C
+f
+S
+n
+1952 2051.3 m
+1950.8 2050.2 1949.7 2049.1 1948.6 2048 C
+1949.7 2049.1 1950.8 2050.2 1952 2051.3 C
+f
+S
+n
+vmrs
+1977.4 2047.7 m
+1975.8 2047.8 1974.8 2046.1 1974.5 2045.3 C
+1974.9 2044.4 1976 2044.5 1976.7 2044.8 C
+1977.9 2045 1977 2048.4 1979.3 2047.5 C
+1979.9 2047.5 1980.8 2048.6 1979.8 2049.2 C
+1978.2 2050.4 1980.8 2049.5 1980.3 2049.4 C
+1981.4 2049.8 1980.3 2048.4 1980.3 2048 C
+1979.8 2047.5 1979 2046.6 1978.4 2046.5 C
+1977.3 2045.9 1977.2 2043.3 1975.2 2044.6 C
+1974.7 2045.3 1973.6 2045 1973.3 2045.8 C
+1975 2046.3 1975.8 2049.8 1978.1 2049.4 C
+1978.4 2050.9 1978.7 2048.5 1977.9 2049.2 C
+1977.7 2048.7 1977.2 2047.8 1977.4 2047.7 C
+[0 0.5 0.5 0.2] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1957.2 2048.9 m
+1958.7 2048.2 1960.1 2047.5 1961.6 2046.8 C
+1960.1 2047.5 1958.7 2048.2 1957.2 2048.9 C
+[0 0.2 1 0] vc
+f
+S
+n
+1958 2048.9 m
+1960.4 2047.1 1961.1 2047.1 1958 2048.9 C
+[0 0.4 1 0] vc
+f
+S
+n
+1966.1 2044.8 m
+1967.6 2044.1 1969 2043.4 1970.4 2042.7 C
+1969 2043.4 1967.6 2044.1 1966.1 2044.8 C
+f
+S
+n
+1970.9 2042.4 m
+1972.2 2041.9 1973.5 2041.3 1974.8 2040.8 C
+1973.5 2041.3 1972.2 2041.9 1970.9 2042.4 C
+f
+S
+n
+2012 2034.5 m
+2010.4 2034.6 2009.3 2032.9 2009.1 2032.1 C
+2009.4 2031 2010.3 2031.3 2011.2 2031.6 C
+2012.5 2031.8 2011.6 2035.2 2013.9 2034.3 C
+2014.4 2034.3 2015.4 2035.4 2014.4 2036 C
+2012.7 2037.2 2015.3 2036.3 2014.8 2036.2 C
+2015.9 2036.6 2014.8 2035.2 2014.8 2034.8 C
+2014.4 2034.3 2013.6 2033.4 2012.9 2033.3 C
+2011.5 2031 2009.3 2029.4 2007.4 2028 C
+2007.5 2026.5 2007.3 2027.9 2007.2 2028.3 C
+2007.9 2028.8 2008.7 2029.1 2009.3 2030 C
+2009.6 2030.7 2009 2031.9 2008.4 2031.6 C
+2006.7 2031 2007.7 2028 2005 2028.8 C
+2004.8 2028.6 2004.3 2028.2 2003.8 2028.3 C
+2006.6 2030.4 2008.9 2033.7 2011.2 2036.2 C
+2011.8 2036.4 2012.9 2035.8 2012.9 2036.7 C
+2012.7 2036.1 2011.8 2035 2012 2034.5 C
+[0 0.5 0.5 0.2] vc
+f
+S
+n
+1981.2 2005.2 m
+1979.7 2005.3 1978.6 2003.6 1978.4 2002.8 C
+1978.7 2001.8 1979.6 2002.1 1980.5 2002.4 C
+1981.8 2002.5 1980.9 2005.9 1983.2 2005 C
+1983.7 2005.1 1984.7 2006.1 1983.6 2006.7 C
+1982 2007.9 1984.6 2007 1984.1 2006.9 C
+1985.2 2007.3 1984.1 2006 1984.1 2005.5 C
+1983.6 2005 1982.9 2004.1 1982.2 2004 C
+1980.8 2001.7 1978.6 2000.1 1976.7 1998.8 C
+1976.7 1997.2 1976.6 1998.6 1976.4 1999 C
+1977.2 1999.5 1978 1999.8 1978.6 2000.7 C
+1978.8 2001.5 1978.3 2002.7 1977.6 2002.4 C
+1976 2001.8 1977 1998.7 1974.3 1999.5 C
+1974.1 1999.3 1973.6 1998.9 1973.1 1999 C
+1975.8 2001.2 1978.2 2004.4 1980.5 2006.9 C
+1981.1 2007.1 1982.1 2006.5 1982.2 2007.4 C
+1982 2006.8 1981.1 2005.7 1981.2 2005.2 C
+f
+S
+n
+1966.8 1976.4 m
+1969.4 1973 1974.4 1974.6 1976.2 1970.4 C
+1972.7 1974 1968 1975.1 1964 1977.4 C
+1960.9 1979.9 1957.1 1981.8 1953.9 1982.7 C
+1958.4 1981.1 1962.6 1978.8 1966.8 1976.4 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1948.4 2093.8 m
+1949.8 2093.1 1951.2 2092.5 1952.7 2091.9 C
+1951.2 2092.5 1949.8 2093.1 1948.4 2093.8 C
+[0 0.2 1 0] vc
+f
+S
+n
+1948.1 2093.6 m
+1947.3 2092.8 1946.5 2091.9 1945.7 2091.2 C
+1946.5 2091.9 1947.3 2092.8 1948.1 2093.6 C
+f
+S
+n
+vmrs
+1942.1 2087.8 m
+1943.5 2088.4 1944.3 2089.5 1945.2 2090.7 C
+1944.8 2089.3 1943.3 2088.3 1942.1 2087.8 C
+[0 0.2 1 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1933.5 2078.4 m
+1933.5 2078 1933.2 2079 1933.7 2079.4 C
+1935 2080.4 1936.2 2081.3 1937.1 2082.8 C
+1936.7 2080.7 1933.7 2080.7 1933.5 2078.4 C
+f
+S
+n
+1982.9 2080.6 m
+1984.4 2079.9 1985.8 2079.3 1987.2 2078.7 C
+1985.8 2079.3 1984.4 2079.9 1982.9 2080.6 C
+f
+S
+n
+1982.7 2080.4 m
+1981.9 2079.6 1981.1 2078.7 1980.3 2078 C
+1981.1 2078.7 1981.9 2079.6 1982.7 2080.4 C
+f
+S
+n
+1977.4 2075.1 m
+1977.9 2075.3 1979.1 2076.4 1979.8 2077.5 C
+1979 2076.8 1978.7 2075.1 1977.4 2075.1 C
+f
+S
+n
+1952.2 2051.3 m
+1953.6 2050.7 1955.1 2050.1 1956.5 2049.4 C
+1955.1 2050.1 1953.6 2050.7 1952.2 2051.3 C
+f
+S
+n
+1952 2051.1 m
+1951.2 2050.3 1950.3 2049.5 1949.6 2048.7 C
+1950.3 2049.5 1951.2 2050.3 1952 2051.1 C
+f
+S
+n
+1946 2045.3 m
+1947.3 2045.9 1948.1 2047 1949.1 2048.2 C
+1948.6 2046.8 1947.1 2045.8 1946 2045.3 C
+f
+S
+n
+1937.3 2036 m
+1937.4 2035.5 1937 2036.5 1937.6 2036.9 C
+1938.8 2037.9 1940.1 2038.8 1940.9 2040.3 C
+1940.6 2038.2 1937.6 2038.2 1937.3 2036 C
+f
+S
+n
+1935.2 2073.2 m
+1936.4 2069.9 1935.8 2061.8 1935.6 2056.4 C
+1935.8 2055.9 1936.3 2055.7 1936.1 2055.2 C
+1935.7 2054.7 1935 2055 1934.4 2054.9 C
+1934.4 2061.5 1934.4 2068.7 1934.4 2074.6 C
+1935.7 2075.1 1936 2073.7 1935.2 2073.2 C
+[0 0.01 1 0] vc
+f
+S
+n
+vmrs
+1939 2030.7 m
+1940.3 2027.4 1939.7 2019.3 1939.5 2013.9 C
+1939.7 2013.5 1940.1 2013.2 1940 2012.7 C
+1939.5 2012.3 1938.8 2012.5 1938.3 2012.4 C
+1938.3 2019 1938.3 2026.2 1938.3 2032.1 C
+1939.5 2032.7 1939.8 2031.2 1939 2030.7 C
+[0 0.01 1 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1975.2 2077.2 m
+1975.3 2077.3 1975.4 2077.4 1975.5 2077.5 C
+1974.7 2073.2 1974.9 2067.5 1975.2 2063.6 C
+1975.4 2064 1974.6 2063.9 1974.8 2064.3 C
+1974.9 2069.9 1974.3 2076.5 1975.2 2081.1 C
+1974.9 2079.9 1974.9 2078.4 1975.2 2077.2 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1930.8 2067.4 m
+1931.5 2070.1 1929.6 2072.1 1930.6 2074.6 C
+1931 2072.6 1930.8 2069.8 1930.8 2067.4 C
+f
+S
+n
+2010 2050.1 m
+2009.8 2050.5 2009.5 2050.9 2009.3 2051.1 C
+2009.5 2056.7 2008.9 2063.3 2009.8 2067.9 C
+2009.5 2062.1 2009.3 2054.7 2010 2050.1 C
+f
+S
+n
+1930.1 2060.9 m
+1929.3 2057.1 1930.7 2054.8 1929.9 2051.3 C
+1930.2 2050.2 1931.1 2049.6 1931.8 2049.2 C
+1931.4 2049.6 1930.4 2049.5 1930.1 2050.1 C
+1928.4 2054.8 1933.4 2063.5 1925.3 2064.3 C
+1927.2 2063.9 1928.5 2062.1 1930.1 2060.9 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1929.6 2061.2 m
+1929.6 2057.6 1929.6 2054.1 1929.6 2050.6 C
+1930 2049.9 1930.5 2049.4 1931.1 2049.2 C
+1930 2048.6 1930.5 2050.2 1929.4 2049.6 C
+1928 2054.4 1932.8 2063 1925.3 2064 C
+1926.9 2063.3 1928.3 2062.4 1929.6 2061.2 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1930.8 2061.6 m
+1930.5 2058 1931.6 2054 1930.8 2051.3 C
+1930.3 2054.5 1930.9 2058.5 1930.4 2061.9 C
+1930.5 2061.2 1931 2062.2 1930.8 2061.6 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1941.2 2045.1 m
+1939.7 2042.6 1937.3 2041.2 1935.4 2039.3 C
+1934.2 2040 1933.7 2036.4 1934 2039.3 C
+1934.9 2040.1 1936.1 2039.9 1936.8 2040.8 C
+1935.3 2044.2 1942.3 2041.7 1939.5 2046 C
+1937.1 2048.5 1940.5 2045.6 1941.2 2045.1 C
+f
+S
+n
+1910 2045.8 m
+1910 2039.4 1910 2033 1910 2026.6 C
+1910 2033 1910 2039.4 1910 2045.8 C
+f
+S
+n
+1978.8 2022.3 m
+1979.1 2021.7 1979.4 2020.4 1978.6 2021.6 C
+1978.6 2026.9 1978.6 2033 1978.6 2037.6 C
+1979.2 2037 1979.1 2038.2 1979.1 2038.6 C
+1978.7 2033.6 1978.9 2026.8 1978.8 2022.3 C
+f
+S
+n
+vmrs
+2026.1 2041.2 m
+2026.1 2034.8 2026.1 2028.3 2026.1 2021.8 C
+2026.1 2028.5 2026.3 2035.4 2025.9 2042 C
+2024.4 2042.9 2022.9 2044.1 2021.3 2044.8 C
+2023.1 2044 2025.1 2042.8 2026.1 2041.2 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+2026.4 2021.8 m
+2026.3 2028.5 2026.5 2035.4 2026.1 2042 C
+2025.6 2042.8 2024.7 2042.7 2024.2 2043.4 C
+2024.7 2042.7 2025.5 2042.7 2026.1 2042.2 C
+2026.5 2035.5 2026.3 2027.9 2026.4 2021.8 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+2025.6 2038.4 m
+2025.6 2033 2025.6 2027.6 2025.6 2022.3 C
+2025.6 2027.6 2025.6 2033 2025.6 2038.4 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1934 2023.5 m
+1934 2024.7 1933.8 2026 1934.2 2027.1 C
+1934 2025.5 1934.7 2024.6 1934 2023.5 C
+f
+S
+n
+1928.2 2023.5 m
+1928 2024.6 1927.4 2023.1 1926.8 2023.2 C
+1926.2 2021 1921.4 2019.3 1923.2 2018 C
+1922.7 2016.5 1923.2 2019.3 1922.2 2018.2 C
+1924.4 2020.4 1926.2 2023.3 1928.9 2024.9 C
+1927.9 2024.2 1929.8 2023.5 1928.2 2023.5 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1934 2019.2 m
+1932 2019.6 1930.8 2022.6 1928.7 2021.8 C
+1924.5 2016.5 1918.2 2011.8 1914 2006.7 C
+1914 2005.7 1914 2004.6 1914 2003.6 C
+1913.6 2004.3 1913.9 2005.8 1913.8 2006.9 C
+1919 2012.4 1924.1 2016.5 1929.2 2022.3 C
+1931 2021.7 1932.2 2019.8 1934 2019.2 C
+f
+S
+n
+1928.7 2024.9 m
+1926.3 2022.7 1924.1 2020.4 1921.7 2018.2 C
+1924.1 2020.4 1926.3 2022.7 1928.7 2024.9 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1914.3 2006.7 m
+1918.7 2011.8 1924.5 2016.4 1928.9 2021.6 C
+1924.2 2016.1 1919 2012.1 1914.3 2006.7 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1924.8 2020.8 m
+1921.2 2016.9 1925.6 2022.5 1926 2021.1 C
+1924.2 2021 1926.7 2019.6 1924.8 2020.8 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1934 2018.4 m
+1933.2 2014.7 1934.5 2012.3 1933.7 2008.8 C
+1934 2007.8 1935 2007.2 1935.6 2006.7 C
+1935.3 2007.1 1934.3 2007 1934 2007.6 C
+1932.2 2012.3 1937.2 2021 1929.2 2021.8 C
+1931.1 2021.4 1932.3 2019.6 1934 2018.4 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+vmrs
+1933.5 2018.7 m
+1933.5 2015.1 1933.5 2011.7 1933.5 2008.1 C
+1933.8 2007.4 1934.3 2006.9 1934.9 2006.7 C
+1933.8 2006.1 1934.3 2007.7 1933.2 2007.2 C
+1931.9 2012 1936.7 2020.5 1929.2 2021.6 C
+1930.7 2020.8 1932.2 2019.9 1933.5 2018.7 C
+[0.4 0.4 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1934.7 2019.2 m
+1934.3 2015.6 1935.4 2011.5 1934.7 2008.8 C
+1934.1 2012 1934.7 2016 1934.2 2019.4 C
+1934.4 2018.7 1934.8 2019.8 1934.7 2019.2 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1917.6 2013.6 m
+1917.8 2011.1 1916.8 2014.2 1917.2 2012.2 C
+1916.3 2012.9 1914.8 2011.8 1914.3 2010.8 C
+1914.2 2010.5 1914.4 2010.4 1914.5 2010.3 C
+1913.9 2008.8 1913.9 2011.9 1914.3 2012 C
+1916.3 2012 1917.6 2013.6 1916.7 2015.6 C
+1913.7 2017.4 1919.6 2014.8 1917.6 2013.6 C
+f
+S
+n
+1887.2 2015.3 m
+1887.2 2008.9 1887.2 2002.5 1887.2 1996.1 C
+1887.2 2002.5 1887.2 2008.9 1887.2 2015.3 C
+f
+S
+n
+1916.7 2014.4 m
+1917 2012.1 1913 2013 1913.8 2010.8 C
+1912.1 2009.8 1910.9 2009.4 1910.7 2007.9 C
+1910.4 2010.6 1913.4 2010.4 1914 2012.4 C
+1914.9 2012.8 1916.6 2012.9 1916.4 2014.4 C
+1916.9 2015.1 1914.5 2016.6 1916.2 2015.8 C
+1916.4 2015.3 1916.7 2015 1916.7 2014.4 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1914 2009.3 m
+1912.8 2010.9 1909.6 2005.3 1911.9 2009.8 C
+1912.3 2009.6 1913.6 2010.2 1914 2009.3 C
+[0.92 0.92 0 0.67] vc
+f
+S
+n
+1951.2 1998.8 m
+1949 1996.4 1951.5 1994 1950.3 1991.8 C
+1949.1 1989.1 1954 1982.7 1948.8 1981.2 C
+1949.2 1981.5 1951 1982.4 1950.8 1983.6 C
+1951.9 1988.6 1947.1 1986.5 1948.1 1990.4 C
+1948.5 1990.3 1948.7 1990.7 1948.6 1991.1 C
+1949 1992.5 1947.3 1991.9 1948.1 1992.5 C
+1947.1 1992.7 1945.7 1993.5 1945.2 1994.7 C
+1944.5 1996.8 1947.7 2000.5 1943.8 2001.4 C
+1943.4 2002 1943.7 2004 1942.4 2004.5 C
+1945.2 2002.2 1948.9 2000.9 1951.2 1998.8 C
+f
+S
+n
+1994.9 1993 m
+1995.1 1996.5 1994.5 2000.3 1995.4 2003.6 C
+1994.5 2000.3 1995.1 1996.5 1994.9 1993 C
+f
+S
+n
+1913.8 2003.3 m
+1913.8 1996.9 1913.8 1990.5 1913.8 1984.1 C
+1913.8 1990.5 1913.8 1996.9 1913.8 2003.3 C
+f
+S
+n
+1941.9 1998 m
+1940.5 1997.3 1940.7 1999.4 1940.7 2000 C
+1942.8 2001.3 1942.6 1998.8 1941.9 1998 C
+[0 0 0 0] vc
+f
+S
+n
+vmrs
+1942.1 1999.2 m
+1942.2 1998.9 1941.8 1998.8 1941.6 1998.5 C
+1940.4 1998 1940.7 1999.7 1940.7 2000 C
+1941.6 2000.3 1942.6 2000.4 1942.1 1999.2 C
+[0.92 0.92 0 0.67] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1940 1997.1 m
+1939.8 1996 1939.7 1995.9 1939.2 1995.2 C
+1939.1 1995.3 1938.5 1997.9 1937.8 1996.4 C
+1938 1997.3 1939.4 1998.6 1940 1997.1 C
+f
+S
+n
+1911.2 1995.9 m
+1911.2 1991.6 1911.3 1987.2 1911.4 1982.9 C
+1911.3 1987.2 1911.2 1991.6 1911.2 1995.9 C
+f
+S
+n
+1947.2 1979.1 m
+1945.1 1978.8 1944.6 1975.7 1942.4 1975 C
+1940.5 1972.6 1942.2 1973.7 1942.4 1975.7 C
+1945.8 1975.5 1944.2 1979.8 1947.6 1979.6 C
+1948.3 1982.3 1948.5 1980 1947.2 1979.1 C
+f
+S
+n
+1939.5 1973.3 m
+1940.1 1972.6 1939.8 1974.2 1940.2 1973.1 C
+1939.1 1972.8 1938.8 1968.5 1935.9 1969.7 C
+1937.4 1969.2 1938.5 1970.6 1939 1971.4 C
+1939.2 1972.7 1938.6 1973.9 1939.5 1973.3 C
+f
+S
+n
+1975.2 2073.2 m
+1975.2 2070.2 1975.2 2067.2 1975.2 2064.3 C
+1975.2 2067.2 1975.2 2070.2 1975.2 2073.2 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1929.9 2065.7 m
+1928.1 2065.6 1926 2068.8 1924.1 2066.9 C
+1918.1 2060.9 1912.9 2055.7 1907.1 2049.9 C
+1906.7 2047.1 1906.9 2043.9 1906.8 2041 C
+1906.8 2043.9 1906.8 2046.8 1906.8 2049.6 C
+1913.2 2055.5 1918.7 2061.9 1925.1 2067.6 C
+1927.1 2067.9 1928.6 2064.4 1930.1 2066.2 C
+1929.7 2070.3 1929.9 2074.7 1929.9 2078.9 C
+1929.6 2074.4 1930.5 2070.1 1929.9 2065.7 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1930.1 2061.6 m
+1928.1 2062.1 1927 2065.1 1924.8 2064.3 C
+1920.7 2058.9 1914.4 2054.3 1910.2 2049.2 C
+1910.2 2048.1 1910.2 2047.1 1910.2 2046 C
+1909.8 2046.8 1910 2048.3 1910 2049.4 C
+1915.1 2054.9 1920.3 2059 1925.3 2064.8 C
+1927.1 2064.2 1928.4 2062.3 1930.1 2061.6 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1932 2049.9 m
+1932.3 2050.3 1932 2050.4 1932.8 2050.4 C
+1932 2050.4 1932.2 2049.2 1931.3 2049.6 C
+1931.4 2050.5 1930.3 2050.4 1930.4 2051.3 C
+1931.1 2051.1 1930.7 2049.4 1932 2049.9 C
+f
+S
+n
+1938.3 2046 m
+1936.3 2046.8 1935.2 2047.2 1934.2 2048.9 C
+1935.3 2047.7 1936.8 2046.2 1938.3 2046 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+vmrs
+1938.3 2047 m
+1937.9 2046.9 1936.6 2047.1 1936.1 2048 C
+1936.5 2047.5 1937.3 2046.7 1938.3 2047 C
+[0.18 0.18 0 0.78] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1910.2 2043.2 m
+1910.1 2037.5 1910 2031.8 1910 2026.1 C
+1910 2031.8 1910.1 2037.5 1910.2 2043.2 C
+f
+S
+n
+1933.5 2032.1 m
+1933.7 2035.2 1932.8 2035.8 1933.7 2038.6 C
+1933.3 2036.6 1934.6 2018 1933.5 2032.1 C
+f
+S
+n
+1907.3 2021.8 m
+1906.6 2025.9 1909.4 2032.6 1903.2 2034 C
+1902.8 2034.1 1902.4 2033.9 1902 2033.8 C
+1897.9 2028.5 1891.6 2023.8 1887.4 2018.7 C
+1887.4 2017.7 1887.4 2016.6 1887.4 2015.6 C
+1887 2016.3 1887.2 2017.8 1887.2 2018.9 C
+1892.3 2024.4 1897.5 2028.5 1902.5 2034.3 C
+1904.3 2033.6 1905.7 2032 1907.3 2030.9 C
+1907.3 2027.9 1907.3 2024.9 1907.3 2021.8 C
+f
+S
+n
+1933.7 2023.2 m
+1932 2021.7 1931.1 2024.9 1929.4 2024.9 C
+1931.2 2024.7 1932.4 2021.5 1933.7 2023.2 C
+f
+S
+n
+1989.2 2024.4 m
+1987.4 2023.7 1985.8 2022.2 1985.1 2020.4 C
+1984.6 2020.1 1986 2018.9 1985.1 2019.2 C
+1985.6 2020.8 1984.1 2019.4 1984.6 2021.1 C
+1986.3 2022.3 1988.1 2025.3 1989.2 2024.4 C
+f
+S
+n
+1904.4 2031.9 m
+1903 2029.7 1905.3 2027.7 1904.2 2025.9 C
+1904.5 2025 1903.7 2023 1904 2021.3 C
+1904 2022.3 1903.2 2022 1902.5 2022 C
+1901.3 2022.3 1902.2 2020.1 1901.6 2019.6 C
+1902.5 2019.8 1902.6 2018.3 1903.5 2018.9 C
+1903.7 2021.8 1905.6 2016.8 1905.6 2020.6 C
+1905.9 2020 1906.3 2020.8 1906.1 2021.1 C
+1905.8 2022.7 1906.7 2020.4 1906.4 2019.9 C
+1906.4 2018.5 1908.2 2017.8 1906.8 2016.5 C
+1906.9 2015.7 1907.7 2017.1 1907.1 2016.3 C
+1908.5 2015.8 1910.3 2015.1 1911.6 2016 C
+1912.2 2016.2 1911.9 2018 1911.6 2018 C
+1914.5 2017.1 1910.4 2013.6 1913.3 2013.4 C
+1912.4 2011.3 1910.5 2011.8 1909.5 2010 C
+1910 2010.5 1909 2010.8 1908.8 2011.2 C
+1907.5 2009.9 1906.1 2011.7 1904.9 2011.5 C
+1904.7 2010.9 1904.3 2010.5 1904.4 2009.8 C
+1905 2010.2 1904.6 2008.6 1905.4 2008.1 C
+1906.6 2007.5 1907.7 2008.4 1908.5 2007.4 C
+1908.9 2008.5 1909.7 2008.1 1909 2007.2 C
+1908.1 2006.5 1905.9 2007.3 1905.4 2007.4 C
+1903.9 2007.3 1905.2 2008.5 1904.2 2008.4 C
+1904.6 2009.9 1902.8 2010.3 1902.3 2010.5 C
+1901.5 2009.9 1900.4 2010 1899.4 2010 C
+1898.6 2011.2 1898.2 2013.4 1896.5 2013.4 C
+1896 2012.9 1894.4 2012.9 1893.6 2012.9 C
+1893.1 2013.9 1892.9 2015.5 1891.5 2016 C
+1890.3 2016.1 1889.2 2014 1888.6 2015.8 C
+1890 2016 1891 2016.9 1892.9 2016.5 C
+1894.1 2017.2 1892.8 2018.3 1893.2 2018.9 C
+1892.6 2018.9 1891.1 2019.8 1890.5 2020.6 C
+1891.1 2023.6 1893.2 2019.8 1893.9 2022.5 C
+1894.1 2023.3 1892.7 2023.6 1893.9 2024 C
+1894.2 2024.3 1897.4 2023.8 1896.5 2026.1 C
+1896 2025.6 1897.4 2028.1 1897.5 2027.1 C
+1898.4 2027.4 1899.3 2027 1899.6 2028.5 C
+1899.5 2028.6 1899.4 2028.8 1899.2 2028.8 C
+1899.3 2029.2 1899.6 2029.8 1900.1 2030.2 C
+1900.4 2029.6 1901 2030 1901.8 2030.2 C
+1903.1 2032.1 1900.4 2031.5 1902.8 2033.1 C
+1903.3 2032.7 1904.5 2032 1904.4 2031.9 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1909.2 2019.4 m
+1908.8 2020.3 1910.2 2019.8 1909.2 2019.2 C
+1908.3 2019.3 1907.6 2020.2 1907.6 2021.3 C
+1908.5 2021 1907.6 2019 1909.2 2019.4 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1915.5 2015.6 m
+1913.5 2016.3 1912.4 2016.8 1911.4 2018.4 C
+1912.5 2017.2 1914 2015.7 1915.5 2015.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1915.5 2016.5 m
+1915.1 2016.4 1913.8 2016.6 1913.3 2017.5 C
+1913.7 2017 1914.5 2016.2 1915.5 2016.5 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+vmrs
+1887.4 2012.7 m
+1887.3 2007 1887.2 2001.3 1887.2 1995.6 C
+1887.2 2001.3 1887.3 2007 1887.4 2012.7 C
+[0.18 0.18 0 0.78] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1935.9 2007.4 m
+1936.2 2007.8 1935.8 2007.9 1936.6 2007.9 C
+1935.9 2007.9 1936.1 2006.7 1935.2 2007.2 C
+1935.2 2008.1 1934.1 2007.9 1934.2 2008.8 C
+1935 2008.7 1934.6 2006.9 1935.9 2007.4 C
+f
+S
+n
+1942.1 2003.6 m
+1940.1 2004.3 1939.1 2004.8 1938 2006.4 C
+1939.1 2005.2 1940.6 2003.7 1942.1 2003.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1942.1 2004.5 m
+1941.8 2004.4 1940.4 2004.6 1940 2005.5 C
+1940.4 2005 1941.2 2004.2 1942.1 2004.5 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+1914 2000.7 m
+1914 1995 1913.9 1989.3 1913.8 1983.6 C
+1913.9 1989.3 1914 1995 1914 2000.7 C
+f
+S
+n
+1941.6 1998.3 m
+1943.4 2001.9 1942.4 1996 1940.9 1998.3 C
+1941.2 1998.3 1941.4 1998.3 1941.6 1998.3 C
+f
+S
+n
+1954.8 1989.9 m
+1953.9 1989.6 1954.7 1991.6 1953.9 1991.1 C
+1954.5 1993.1 1953.6 1998 1954.6 1993.2 C
+1954 1992.2 1954.7 1990.7 1954.8 1989.9 C
+f
+S
+n
+1947.6 1992.5 m
+1946.2 1993.5 1944.9 1993 1944.8 1994.7 C
+1945.5 1994 1947 1992.2 1947.6 1992.5 C
+f
+S
+n
+1910.7 1982.2 m
+1910.3 1981.8 1909.7 1982 1909.2 1982 C
+1909.7 1982 1910.3 1981.9 1910.7 1982.2 C
+1911 1987.1 1910 1992.6 1910.7 1997.3 C
+1910.7 1992.3 1910.7 1987.2 1910.7 1982.2 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1910.9 1992.8 m
+1910.9 1991.3 1910.9 1989.7 1910.9 1988.2 C
+1910.9 1989.7 1910.9 1991.3 1910.9 1992.8 C
+[0.18 0.18 0 0.78] vc
+f
+S
+n
+vmrs
+1953.6 1983.6 m
+1954.1 1985.3 1953.2 1988.6 1954.8 1989.4 C
+1954.1 1987.9 1954.4 1985.4 1953.6 1983.6 C
+[0.18 0.18 0 0.78] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1910.7 1982 m
+1911.6 1982.9 1911 1984.4 1911.2 1985.6 C
+1911 1984.4 1911.6 1982.9 1910.7 1982 C
+f
+S
+n
+1947.2 1979.6 m
+1947.5 1980.6 1948.3 1980.6 1947.4 1979.6 C
+1946.2 1979.4 1945.7 1978.8 1947.2 1979.6 C
+f
+S
+n
+1930.4 2061.4 m
+1930.4 2058 1930.4 2053.5 1930.4 2051.1 C
+1930.7 2054.6 1929.8 2057.4 1930.1 2061.2 C
+1929.5 2061.9 1929.7 2061.2 1930.4 2061.4 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1939.5 2044.8 m
+1940 2041.5 1935.2 2044.3 1936.4 2040.8 C
+1934.9 2040.9 1934.1 2039.7 1933.5 2038.6 C
+1933.3 2035.4 1933.2 2040 1934 2040.3 C
+1936.2 2040.6 1936.3 2043.6 1938.5 2043.4 C
+1939.7 2044.2 1939.4 2045.6 1938.3 2046.5 C
+1939.1 2046.6 1939.6 2045.6 1939.5 2044.8 C
+f
+S
+n
+1910.4 2045.3 m
+1910.4 2039.5 1910.4 2033.6 1910.4 2027.8 C
+1910.4 2033.6 1910.4 2039.5 1910.4 2045.3 C
+f
+S
+n
+1906.8 2030.9 m
+1907.6 2026.8 1905 2020.8 1909 2018.7 C
+1906.5 2018.9 1906.8 2022.4 1906.8 2024.7 C
+1906.4 2028.2 1907.9 2032 1903 2033.8 C
+1902.2 2034 1903.8 2033.4 1904.2 2033.1 C
+1905.1 2032.4 1905.9 2031.5 1906.8 2030.9 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1907.1 2030.7 m
+1907.1 2028.8 1907.1 2027 1907.1 2025.2 C
+1907.1 2027 1907.1 2028.8 1907.1 2030.7 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1932 2023.2 m
+1932.2 2023.6 1931.7 2023.7 1931.6 2024 C
+1932 2023.7 1932.3 2022.8 1933 2023 C
+1933.9 2024.3 1933.3 2026.2 1933.5 2027.8 C
+1933.5 2026.4 1934.9 2022.2 1932 2023.2 C
+f
+S
+n
+2026.1 2021.6 m
+2026.1 2020.8 2026.1 2019.9 2026.1 2019.2 C
+2026.1 2019.9 2026.1 2020.8 2026.1 2021.6 C
+f
+S
+n
+vmrs
+1934.2 2018.9 m
+1934.2 2015.5 1934.2 2011 1934.2 2008.6 C
+1934.5 2012.1 1933.7 2014.9 1934 2018.7 C
+1933.4 2019.5 1933.5 2018.7 1934.2 2018.9 C
+[0.65 0.65 0 0.42] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1887.6 2014.8 m
+1887.6 2009 1887.6 2003.1 1887.6 1997.3 C
+1887.6 2003.1 1887.6 2009 1887.6 2014.8 C
+f
+S
+n
+1914.3 2002.8 m
+1914.3 1997 1914.3 1991.1 1914.3 1985.3 C
+1914.3 1991.1 1914.3 1997 1914.3 2002.8 C
+f
+S
+n
+1995.4 1992.3 m
+1995.4 1991.5 1995.4 1990.7 1995.4 1989.9 C
+1995.4 1990.7 1995.4 1991.5 1995.4 1992.3 C
+f
+S
+n
+1896 1988.4 m
+1896.9 1988 1897.8 1987.7 1898.7 1987.2 C
+1897.8 1987.7 1896.9 1988 1896 1988.4 C
+f
+S
+n
+1899.4 1986.8 m
+1900.4 1986.3 1901.3 1985.8 1902.3 1985.3 C
+1901.3 1985.8 1900.4 1986.3 1899.4 1986.8 C
+f
+S
+n
+1902.8 1985.1 m
+1905.2 1984 1905.2 1984 1902.8 1985.1 C
+f
+S
+n
+1949.1 1983.4 m
+1950.2 1984.4 1947.8 1984.6 1949.3 1985.1 C
+1949.5 1984.4 1949.6 1984.1 1949.1 1983.4 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1906.1 1983.4 m
+1908.6 1982 1908.6 1982 1906.1 1983.4 C
+[0.65 0.65 0 0.42] vc
+f
+S
+n
+1922.7 1976.4 m
+1923.6 1976 1924.4 1975.7 1925.3 1975.2 C
+1924.4 1975.7 1923.6 1976 1922.7 1976.4 C
+f
+S
+n
+vmrs
+1926 1974.8 m
+1927 1974.3 1928 1973.8 1928.9 1973.3 C
+1928 1973.8 1927 1974.3 1926 1974.8 C
+[0.65 0.65 0 0.42] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1929.4 1973.1 m
+1931.9 1972 1931.9 1972 1929.4 1973.1 C
+f
+S
+n
+1932.8 1971.4 m
+1935.3 1970 1935.3 1970 1932.8 1971.4 C
+f
+S
+n
+1949.6 2097.2 m
+1951.1 2096.4 1952.6 2095.5 1954.1 2094.8 C
+1952.6 2095.5 1951.1 2096.4 1949.6 2097.2 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1955.1 2094.3 m
+1956.7 2093.5 1958.3 2092.7 1959.9 2091.9 C
+1958.3 2092.7 1956.7 2093.5 1955.1 2094.3 C
+f
+S
+n
+1960.4 2091.6 m
+1961.3 2091.2 1962.1 2090.9 1963 2090.4 C
+1962.1 2090.9 1961.3 2091.2 1960.4 2091.6 C
+f
+S
+n
+1963.5 2090.2 m
+1964.4 2089.7 1965.2 2089.2 1966.1 2088.8 C
+1965.2 2089.2 1964.4 2089.7 1963.5 2090.2 C
+f
+S
+n
+1966.6 2088.5 m
+1969.5 2087.1 1972.4 2085.8 1975.2 2084.4 C
+1972.4 2085.8 1969.5 2087.1 1966.6 2088.5 C
+f
+S
+n
+1965.2 2086.1 m
+1965.9 2085.7 1966.8 2085.3 1967.6 2084.9 C
+1966.8 2085.3 1965.9 2085.7 1965.2 2086.1 C
+f
+S
+n
+1968.3 2084.7 m
+1969.2 2084.3 1970 2083.9 1970.9 2083.5 C
+1970 2083.9 1969.2 2084.3 1968.3 2084.7 C
+f
+S
+n
+vmrs
+1984.1 2084 m
+1985.6 2083.2 1987.2 2082.3 1988.7 2081.6 C
+1987.2 2082.3 1985.6 2083.2 1984.1 2084 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1976 2078.7 m
+1978.1 2080.1 1980 2082 1982 2083.7 C
+1980 2081.9 1977.9 2080.3 1976 2078.2 C
+1975.5 2079.9 1975.8 2081.9 1975.7 2083.7 C
+1975.8 2082 1975.5 2080.2 1976 2078.7 C
+f
+S
+n
+1989.6 2081.1 m
+1991.3 2080.3 1992.8 2079.5 1994.4 2078.7 C
+1992.8 2079.5 1991.3 2080.3 1989.6 2081.1 C
+f
+S
+n
+1933.2 2074.6 m
+1932.4 2076.2 1932.8 2077.5 1933 2078.7 C
+1933 2077.6 1932.9 2074.8 1933.2 2074.6 C
+f
+S
+n
+1994.9 2078.4 m
+1995.8 2078 1996.7 2077.7 1997.6 2077.2 C
+1996.7 2077.7 1995.8 2078 1994.9 2078.4 C
+f
+S
+n
+1998 2077 m
+1998.9 2076.5 1999.8 2076 2000.7 2075.6 C
+1999.8 2076 1998.9 2076.5 1998 2077 C
+f
+S
+n
+2001.2 2075.3 m
+2004 2073.9 2006.9 2072.6 2009.8 2071.2 C
+2006.9 2072.6 2004 2073.9 2001.2 2075.3 C
+f
+S
+n
+1980.5 2060.7 m
+1979.9 2060.7 1976.7 2062.8 1975.7 2064.5 C
+1975.7 2067.5 1975.7 2070.5 1975.7 2073.4 C
+1976.3 2068.7 1973.9 2061.6 1980.5 2060.7 C
+f
+S
+n
+1999.7 2072.9 m
+2000.5 2072.5 2001.3 2072.1 2002.1 2071.7 C
+2001.3 2072.1 2000.5 2072.5 1999.7 2072.9 C
+f
+S
+n
+2002.8 2071.5 m
+2003.7 2071.1 2004.6 2070.7 2005.5 2070.3 C
+2004.6 2070.7 2003.7 2071.1 2002.8 2071.5 C
+f
+S
+n
+vmrs
+2015.1 2047.5 m
+2014.4 2047.5 2011.2 2049.6 2010.3 2051.3 C
+2010.3 2057.7 2010.3 2064.1 2010.3 2070.5 C
+2010.3 2063.9 2010.1 2057.1 2010.5 2050.6 C
+2012 2049.3 2013.5 2048.3 2015.1 2047.5 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1910.4 2049.2 m
+1914.8 2054.3 1920.7 2058.9 1925.1 2064 C
+1920.4 2058.6 1915.1 2054.6 1910.4 2049.2 C
+f
+S
+n
+1988.2 2057.3 m
+1989.1 2056.8 1989.9 2056.2 1990.8 2055.6 C
+1989.9 2056.2 1989.1 2056.8 1988.2 2057.3 C
+f
+S
+n
+1991.6 2051.3 m
+1991.6 2046.3 1991.6 2041.2 1991.6 2036.2 C
+1991.6 2041.2 1991.6 2046.3 1991.6 2051.3 C
+f
+S
+n
+1935.6 2047.5 m
+1932.9 2051.7 1939.7 2043.8 1935.6 2047.5 C
+f
+S
+n
+1938.8 2043.9 m
+1938.1 2043.3 1938.2 2043.7 1937.3 2043.4 C
+1938.7 2043 1938.2 2044.9 1939 2045.3 C
+1938.2 2045.3 1938.7 2046.6 1937.8 2046.5 C
+1939.1 2046.2 1939.1 2044.5 1938.8 2043.9 C
+f
+S
+n
+1972.4 2045.6 m
+1973.4 2045 1974.5 2044.4 1975.5 2043.9 C
+1974.5 2044.4 1973.4 2045 1972.4 2045.6 C
+f
+S
+n
+1969 2043.6 m
+1969.8 2043.2 1970.6 2042.9 1971.4 2042.4 C
+1970.6 2042.9 1969.8 2043.2 1969 2043.6 C
+f
+S
+n
+1972.1 2042.2 m
+1973 2041.8 1973.9 2041.4 1974.8 2041 C
+1973.9 2041.4 1973 2041.8 1972.1 2042.2 C
+f
+S
+n
+1906.6 2035 m
+1905 2034.7 1904.8 2036.6 1903.5 2036.9 C
+1904.9 2037 1905.8 2033.4 1907.1 2035.7 C
+1907.1 2037.2 1907.1 2038.6 1907.1 2040 C
+1906.9 2038.4 1907.5 2036.4 1906.6 2035 C
+f
+S
+n
+vmrs
+1937.1 2032.1 m
+1936.2 2033.7 1936.6 2035 1936.8 2036.2 C
+1936.8 2035.1 1936.8 2032.4 1937.1 2032.1 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1887.6 2018.7 m
+1892 2023.8 1897.9 2028.4 1902.3 2033.6 C
+1897.6 2028.1 1892.3 2024.1 1887.6 2018.7 C
+f
+S
+n
+1999.7 2031.4 m
+1998.7 2030.3 1997.6 2029.2 1996.6 2028 C
+1997.6 2029.2 1998.7 2030.3 1999.7 2031.4 C
+f
+S
+n
+1912.8 2017 m
+1910.6 2021.1 1913.6 2015.3 1914.5 2016 C
+1914 2016.3 1913.4 2016.7 1912.8 2017 C
+f
+S
+n
+1939.5 2005 m
+1936.7 2009.2 1943.6 2001.3 1939.5 2005 C
+f
+S
+n
+1942.6 2001.4 m
+1941.9 2000.8 1942 2001.2 1941.2 2000.9 C
+1942.5 2000.6 1942.1 2002.4 1942.8 2002.8 C
+1942 2002.8 1942.5 2004.1 1941.6 2004 C
+1943 2003.7 1942.9 2002.1 1942.6 2001.4 C
+f
+S
+n
+2006.2 2000.7 m
+2005.4 2001.5 2004 2002.8 2004 2002.8 C
+2004.5 2002.4 2005.5 2001.4 2006.2 2000.7 C
+f
+S
+n
+1998.5 2001.6 m
+1997.7 2002 1996.8 2002.4 1995.9 2002.6 C
+1995.5 1999.3 1995.7 1995.7 1995.6 1992.3 C
+1995.6 1995.7 1995.6 1999.2 1995.6 2002.6 C
+1996.6 2002.4 1997.7 2002.2 1998.5 2001.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1996.1 2002.8 m
+1995.9 2002.8 1995.8 2002.8 1995.6 2002.8 C
+1995.2 1999.5 1995.5 1995.9 1995.4 1992.5 C
+1995.4 1995.9 1995.4 1999.4 1995.4 2002.8 C
+1996.4 2003.1 1998.2 2001.6 1996.1 2002.8 C
+[0.07 0.06 0 0.58] vc
+f
+S
+n
+1969 2002.1 m
+1968 2001 1966.9 1999.9 1965.9 1998.8 C
+1966.9 1999.9 1968 2001 1969 2002.1 C
+f
+S
+n
+vmrs
+2000 2001.2 m
+2002.1 2000 2004.1 1998.9 2006.2 1997.8 C
+2004.1 1998.9 2002.1 2000 2000 2001.2 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1895.8 1984.8 m
+1898.3 1983.6 1900.8 1982.3 1903.2 1981 C
+1900.8 1982.3 1898.3 1983.6 1895.8 1984.8 C
+f
+S
+n
+1905.2 1980.3 m
+1906.4 1979.9 1907.6 1979.5 1908.8 1979.1 C
+1907.6 1979.5 1906.4 1979.9 1905.2 1980.3 C
+f
+S
+n
+1964.7 1977.4 m
+1963.8 1977.5 1962.5 1980.2 1960.8 1980 C
+1962.5 1980.2 1963.3 1978 1964.7 1977.4 C
+f
+S
+n
+1952 1979.6 m
+1955.2 1979.2 1955.2 1979.2 1952 1979.6 C
+f
+S
+n
+1937.8 1966.4 m
+1941.2 1969.5 1946.1 1976.4 1951.5 1979.3 C
+1946.1 1976.7 1942.8 1970.4 1937.8 1966.4 C
+f
+S
+n
+1911.9 1978.6 m
+1914.3 1977.4 1916.7 1976.2 1919.1 1975 C
+1916.7 1976.2 1914.3 1977.4 1911.9 1978.6 C
+f
+S
+n
+1975.5 1971.4 m
+1974.6 1972.2 1973.3 1973.6 1973.3 1973.6 C
+1973.7 1973.1 1974.8 1972.1 1975.5 1971.4 C
+f
+S
+n
+1922.4 1972.8 m
+1924.9 1971.6 1927.4 1970.3 1929.9 1969 C
+1927.4 1970.3 1924.9 1971.6 1922.4 1972.8 C
+f
+S
+n
+1969.2 1971.9 m
+1971.1 1970.9 1972.9 1969.8 1974.8 1968.8 C
+1972.9 1969.8 1971.1 1970.9 1969.2 1971.9 C
+f
+S
+n
+vmrs
+1931.8 1968.3 m
+1933 1967.9 1934.2 1967.5 1935.4 1967.1 C
+1934.2 1967.5 1933 1967.9 1931.8 1968.3 C
+[0.07 0.06 0 0.58] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1940.7 2072.4 m
+1941.5 2072.4 1942.3 2072.3 1943.1 2072.2 C
+1942.3 2072.3 1941.5 2072.4 1940.7 2072.4 C
+[0 0 0 0.18] vc
+f
+S
+n
+1948.6 2069.3 m
+1947 2069.5 1945.7 2068.9 1944.8 2069.8 C
+1945.9 2068.5 1948.4 2070.2 1948.6 2069.3 C
+f
+S
+n
+1954.6 2066.4 m
+1954.7 2067.9 1955.6 2067.3 1955.6 2068.8 C
+1955.4 2067.8 1956 2066.6 1954.6 2066.4 C
+f
+S
+n
+1929.2 2061.2 m
+1927.8 2062.1 1926.3 2064.1 1924.8 2063.3 C
+1926.3 2064.6 1928 2062 1929.2 2061.2 C
+f
+S
+n
+1924.4 2067.4 m
+1918.5 2061.6 1912.7 2055.9 1906.8 2050.1 C
+1912.7 2055.9 1918.5 2061.6 1924.4 2067.4 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1924.6 2062.8 m
+1923.9 2062.1 1923.2 2061.2 1922.4 2060.4 C
+1923.2 2061.2 1923.9 2062.1 1924.6 2062.8 C
+[0 0 0 0.18] vc
+f
+S
+n
+1919.3 2057.3 m
+1917.5 2055.6 1915.7 2053.8 1913.8 2052 C
+1915.7 2053.8 1917.5 2055.6 1919.3 2057.3 C
+f
+S
+n
+1929.2 2055.2 m
+1929.2 2054.2 1929.2 2053.2 1929.2 2052.3 C
+1929.2 2053.2 1929.2 2054.2 1929.2 2055.2 C
+f
+S
+n
+1926.3 2049.6 m
+1925.4 2049 1925.4 2050.5 1924.4 2050.4 C
+1925.3 2051.3 1924.5 2051.9 1925.6 2052.5 C
+1926.9 2052.6 1926 2050.6 1926.3 2049.6 C
+f
+S
+n
+vmrs
+1911.2 2046.8 m
+1910.1 2048.9 1911.9 2050.1 1913.1 2051.3 C
+1912.1 2049.9 1910.6 2048.8 1911.2 2046.8 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1934 2048.7 m
+1932.6 2048.7 1930.1 2047.7 1929.6 2049.4 C
+1930.9 2048.6 1933.3 2049 1934 2048.7 C
+f
+S
+n
+1980 2048.4 m
+1979.5 2046.8 1976.3 2047.9 1977.2 2045.6 C
+1976.8 2045.1 1976.1 2044.7 1975.2 2044.8 C
+1973.7 2046 1976.3 2046.4 1976.7 2047.5 C
+1977.8 2047.2 1978.2 2050 1979.6 2049.2 C
+1980 2049 1979.6 2048.6 1980 2048.4 C
+f
+S
+n
+1938.3 2045.6 m
+1938.2 2044.4 1936.8 2043.8 1935.9 2043.4 C
+1936.4 2044.4 1939.1 2044.3 1937.6 2045.8 C
+1937 2046.1 1935.9 2046.1 1935.9 2046.8 C
+1936.7 2046.3 1937.8 2046.2 1938.3 2045.6 C
+f
+S
+n
+1932.5 2040 m
+1932.8 2038.1 1932 2038.9 1932.3 2040.3 C
+1933.1 2040.3 1932.7 2041.7 1933.7 2041.5 C
+1933.1 2041 1932.9 2040.5 1932.5 2040 C
+f
+S
+n
+2014.6 2035.2 m
+2014.1 2033.6 2010.9 2034.7 2011.7 2032.4 C
+2011.3 2031.9 2009.4 2030.7 2009.3 2032.1 C
+2009.5 2033.7 2012.9 2033.8 2012.4 2035.7 C
+2013 2036.4 2014.2 2036.5 2014.6 2035.2 C
+f
+S
+n
+1906.4 2030.7 m
+1905 2031.6 1903.5 2033.6 1902 2032.8 C
+1903.4 2034 1905.6 2031.4 1906.4 2030.7 C
+f
+S
+n
+1901.8 2037.2 m
+1899.5 2034.8 1897.2 2032.5 1894.8 2030.2 C
+1897.2 2032.5 1899.5 2034.8 1901.8 2037.2 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1901.8 2032.4 m
+1901.1 2031.6 1900.4 2030.7 1899.6 2030 C
+1900.4 2030.7 1901.1 2031.6 1901.8 2032.4 C
+[0 0 0 0.18] vc
+f
+S
+n
+1944.5 2030 m
+1945.3 2029.9 1946.1 2029.8 1946.9 2029.7 C
+1946.1 2029.8 1945.3 2029.9 1944.5 2030 C
+f
+S
+n
+vmrs
+1997.8 2027.8 m
+1997.7 2027.9 1997.6 2028.1 1997.3 2028 C
+1997.4 2029.1 1998.5 2029.5 1999.2 2030 C
+2000.1 2029.5 1998.9 2028 1997.8 2027.8 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1906.4 2029.2 m
+1906.4 2026.6 1906.4 2024 1906.4 2021.3 C
+1906.4 2024 1906.4 2026.6 1906.4 2029.2 C
+f
+S
+n
+2006.2 2025.9 m
+2006 2025.9 2005.8 2025.8 2005.7 2025.6 C
+2005.7 2025.5 2005.7 2025.3 2005.7 2025.2 C
+2004.6 2025.8 2002.7 2024.7 2001.9 2026.1 C
+2001.9 2027.9 2007.8 2029.2 2006.2 2025.9 C
+[0 0 0 0] vc
+f
+S
+n
+1952.4 2026.8 m
+1950.9 2027 1949.6 2026.4 1948.6 2027.3 C
+1949.7 2026.1 1952.2 2027.7 1952.4 2026.8 C
+[0 0 0 0.18] vc
+f
+S
+n
+1896.5 2026.8 m
+1894.7 2025.1 1892.9 2023.3 1891 2021.6 C
+1892.9 2023.3 1894.7 2025.1 1896.5 2026.8 C
+f
+S
+n
+1958.4 2024 m
+1958.5 2025.5 1959.4 2024.8 1959.4 2026.4 C
+1959.3 2025.3 1959.8 2024.1 1958.4 2024 C
+f
+S
+n
+1903.5 2019.2 m
+1902.6 2018.6 1902.6 2020 1901.6 2019.9 C
+1902.5 2020.8 1901.7 2021.4 1902.8 2022 C
+1904.1 2022.2 1903.2 2020.1 1903.5 2019.2 C
+f
+S
+n
+1933 2018.7 m
+1931.7 2019.6 1930.1 2021.6 1928.7 2020.8 C
+1930.1 2022.1 1931.8 2019.5 1933 2018.7 C
+f
+S
+n
+1888.4 2016.3 m
+1887.3 2018.4 1889.1 2019.6 1890.3 2020.8 C
+1889.3 2019.5 1887.8 2018.3 1888.4 2016.3 C
+f
+S
+n
+1928.4 2020.4 m
+1927.7 2019.6 1927 2018.7 1926.3 2018 C
+1927 2018.7 1927.7 2019.6 1928.4 2020.4 C
+f
+S
+n
+vmrs
+1911.2 2018.2 m
+1909.8 2018.3 1907.3 2017.2 1906.8 2018.9 C
+1908.1 2018.1 1910.5 2018.6 1911.2 2018.2 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1915.5 2015.1 m
+1915.4 2013.9 1914 2013.3 1913.1 2012.9 C
+1913.6 2013.9 1916.3 2013.8 1914.8 2015.3 C
+1914.2 2015.6 1913.1 2015.6 1913.1 2016.3 C
+1913.9 2015.9 1915 2015.7 1915.5 2015.1 C
+f
+S
+n
+1923.2 2014.8 m
+1921.3 2013.1 1919.5 2011.3 1917.6 2009.6 C
+1919.5 2011.3 1921.3 2013.1 1923.2 2014.8 C
+f
+S
+n
+1933 2012.7 m
+1933 2011.7 1933 2010.8 1933 2009.8 C
+1933 2010.8 1933 2011.7 1933 2012.7 C
+f
+S
+n
+1909.7 2008.1 m
+1908.9 2009.2 1910.1 2009.9 1910.4 2011 C
+1911.1 2010.7 1908.9 2009.7 1909.7 2008.1 C
+f
+S
+n
+1930.1 2007.2 m
+1929.2 2006.6 1929.2 2008 1928.2 2007.9 C
+1929.1 2008.8 1928.4 2009.4 1929.4 2010 C
+1930.7 2010.2 1929.9 2008.1 1930.1 2007.2 C
+f
+S
+n
+1915 2004.3 m
+1914 2006.4 1915.7 2007.6 1916.9 2008.8 C
+1915.9 2007.5 1914.4 2006.3 1915 2004.3 C
+f
+S
+n
+1937.8 2006.2 m
+1936.4 2006.3 1934 2005.2 1933.5 2006.9 C
+1934.7 2006.1 1937.1 2006.6 1937.8 2006.2 C
+f
+S
+n
+1983.9 2006 m
+1983.3 2004.3 1980.2 2005.4 1981 2003.1 C
+1980.6 2002.7 1978.7 2001.5 1978.6 2002.8 C
+1978.8 2004.4 1982.1 2004.5 1981.7 2006.4 C
+1982.3 2007.2 1983.5 2007.2 1983.9 2006 C
+f
+S
+n
+1942.1 2003.1 m
+1942 2001.9 1940.6 2001.3 1939.7 2000.9 C
+1940.2 2001.9 1943 2001.8 1941.4 2003.3 C
+1940.9 2003.6 1939.7 2003.6 1939.7 2004.3 C
+1940.5 2003.9 1941.6 2003.7 1942.1 2003.1 C
+f
+S
+n
+vmrs
+1967.1 1998.5 m
+1967 1998.6 1966.8 1998.8 1966.6 1998.8 C
+1966.7 1999.8 1967.8 2000.2 1968.5 2000.7 C
+1969.4 2000.2 1968.2 1998.8 1967.1 1998.5 C
+[0 0 0 0.18] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1936.4 1997.6 m
+1936.7 1995.6 1935.8 1996.4 1936.1 1997.8 C
+1936.9 1997.9 1936.5 1999.2 1937.6 1999 C
+1937 1998.5 1936.8 1998 1936.4 1997.6 C
+f
+S
+n
+1975.5 1996.6 m
+1975.2 1996.7 1975.1 1996.5 1975 1996.4 C
+1975 1996.2 1975 1996.1 1975 1995.9 C
+1973.9 1996.5 1972 1995.5 1971.2 1996.8 C
+1971.2 1998.6 1977 1999.9 1975.5 1996.6 C
+[0 0 0 0] vc
+f
+S
+n
+1949.3 2097.4 m
+1950.3 2096.9 1951.2 2096.4 1952.2 2096 C
+1951.2 2096.4 1950.3 2096.9 1949.3 2097.4 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1960.8 2091.6 m
+1961.7 2091.2 1962.6 2090.9 1963.5 2090.4 C
+1962.6 2090.9 1961.7 2091.2 1960.8 2091.6 C
+f
+S
+n
+1964.4 2090 m
+1965.7 2089.2 1967 2088.5 1968.3 2087.8 C
+1967 2088.5 1965.7 2089.2 1964.4 2090 C
+f
+S
+n
+1976 2083.7 m
+1976.3 2082.3 1975.2 2079.1 1976.9 2079.4 C
+1978.8 2080.7 1980.3 2082.9 1982.2 2084.2 C
+1980.6 2083.1 1978.2 2080.2 1976 2078.9 C
+1975.6 2081.2 1977 2084.9 1973.8 2085.4 C
+1972.2 2086.1 1970.7 2087 1969 2087.6 C
+1971.4 2086.5 1974.1 2085.6 1976 2083.7 C
+f
+S
+n
+1983.9 2084.2 m
+1984.8 2083.7 1985.8 2083.2 1986.8 2082.8 C
+1985.8 2083.2 1984.8 2083.7 1983.9 2084.2 C
+f
+S
+n
+1995.4 2078.4 m
+1996.3 2078 1997.1 2077.7 1998 2077.2 C
+1997.1 2077.7 1996.3 2078 1995.4 2078.4 C
+f
+S
+n
+1999 2076.8 m
+2000.3 2076 2001.6 2075.3 2002.8 2074.6 C
+2001.6 2075.3 2000.3 2076 1999 2076.8 C
+f
+S
+n
+vmrs
+1929.6 2065.7 m
+1930.1 2065.6 1929.8 2068.6 1929.9 2070 C
+1929.8 2068.6 1930.1 2067 1929.6 2065.7 C
+[0.4 0.4 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1906.6 2049.4 m
+1906.6 2046.7 1906.6 2043.9 1906.6 2041.2 C
+1906.6 2043.9 1906.6 2046.7 1906.6 2049.4 C
+f
+S
+n
+2016 2047.5 m
+2014.8 2048 2013.5 2048.3 2012.4 2049.4 C
+2013.5 2048.3 2014.8 2048 2016 2047.5 C
+f
+S
+n
+2016.5 2047.2 m
+2017.3 2046.9 2018.1 2046.6 2018.9 2046.3 C
+2018.1 2046.6 2017.3 2046.9 2016.5 2047.2 C
+f
+S
+n
+1912.4 2028.5 m
+1911.8 2032.4 1912.4 2037.2 1911.9 2041.2 C
+1911.5 2037.2 1911.7 2032.9 1911.6 2028.8 C
+1911.6 2033.5 1911.6 2038.9 1911.6 2042.9 C
+1912.5 2042.2 1911.6 2043.9 1912.6 2043.6 C
+1912.9 2039.3 1913.1 2033.3 1912.4 2028.5 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1906.8 2040.8 m
+1906.8 2039 1906.8 2037.2 1906.8 2035.5 C
+1906.8 2037.2 1906.8 2039 1906.8 2040.8 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1905.9 2035.2 m
+1904.9 2036.4 1903.7 2037.2 1902.3 2037.4 C
+1903.7 2037.2 1904.9 2036.4 1905.9 2035.2 C
+f
+S
+n
+1906.1 2031.2 m
+1907 2031.1 1906.4 2028 1906.6 2030.7 C
+1905.5 2032.1 1904 2032.8 1902.5 2033.6 C
+1903.9 2033.2 1905 2032.1 1906.1 2031.2 C
+f
+S
+n
+1908.3 2018.7 m
+1905.2 2018.6 1907.1 2023.2 1906.6 2025.4 C
+1906.8 2023 1905.9 2019.5 1908.3 2018.7 C
+f
+S
+n
+1889.6 1998 m
+1889 2001.9 1889.6 2006.7 1889.1 2010.8 C
+1888.7 2006.7 1888.9 2002.4 1888.8 1998.3 C
+1888.8 2003 1888.8 2008.4 1888.8 2012.4 C
+1889.7 2011.7 1888.8 2013.4 1889.8 2013.2 C
+1890.1 2008.8 1890.3 2002.8 1889.6 1998 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+vmrs
+1999 2001.4 m
+2001 2000.3 2003 1999.2 2005 1998 C
+2003 1999.2 2001 2000.3 1999 2001.4 C
+[0.4 0.4 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1916.2 1986 m
+1915.7 1989.9 1916.3 1994.7 1915.7 1998.8 C
+1915.3 1994.7 1915.5 1990.4 1915.5 1986.3 C
+1915.5 1991 1915.5 1996.4 1915.5 2000.4 C
+1916.3 1999.7 1915.5 2001.4 1916.4 2001.2 C
+1916.7 1996.8 1917 1990.8 1916.2 1986 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1886.9 1989.6 m
+1887.8 1989.2 1888.7 1988.9 1889.6 1988.4 C
+1888.7 1988.9 1887.8 1989.2 1886.9 1989.6 C
+[0.4 0.4 0 0] vc
+f
+S
+n
+1892.4 1986.8 m
+1895.1 1985.1 1897.9 1983.6 1900.6 1982 C
+1897.9 1983.6 1895.1 1985.1 1892.4 1986.8 C
+f
+S
+n
+1907.3 1979.3 m
+1908.5 1978.9 1909.7 1978.5 1910.9 1978.1 C
+1909.7 1978.5 1908.5 1978.9 1907.3 1979.3 C
+f
+S
+n
+1938.5 1966.6 m
+1942.6 1970.1 1945.9 1976.4 1951.7 1979.1 C
+1946.2 1976.1 1943.1 1970.9 1938.5 1966.6 C
+f
+S
+n
+1955.1 1978.6 m
+1955.9 1978.2 1956.7 1977.8 1957.5 1977.4 C
+1956.7 1977.8 1955.9 1978.2 1955.1 1978.6 C
+f
+S
+n
+1913.6 1977.6 m
+1914.5 1977.2 1915.3 1976.9 1916.2 1976.4 C
+1915.3 1976.9 1914.5 1977.2 1913.6 1977.6 C
+f
+S
+n
+1919.1 1974.8 m
+1921.8 1973.1 1924.5 1971.6 1927.2 1970 C
+1924.5 1971.6 1921.8 1973.1 1919.1 1974.8 C
+f
+S
+n
+1963.5 1974.5 m
+1964.5 1974 1965.6 1973.4 1966.6 1972.8 C
+1965.6 1973.4 1964.5 1974 1963.5 1974.5 C
+f
+S
+n
+vmrs
+1967.8 1972.4 m
+1970 1971.2 1972.1 1970 1974.3 1968.8 C
+1972.1 1970 1970 1971.2 1967.8 1972.4 C
+[0.4 0.4 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1934 1967.3 m
+1935.2 1966.9 1936.4 1966.5 1937.6 1966.1 C
+1936.4 1966.5 1935.2 1966.9 1934 1967.3 C
+f
+S
+n
+1928.9 2061.2 m
+1928.9 2059.2 1928.9 2057.3 1928.9 2055.4 C
+1928.9 2057.3 1928.9 2059.2 1928.9 2061.2 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1917.2 2047 m
+1917.8 2046.5 1919.6 2046.8 1920 2047.2 C
+1920 2046.5 1920.9 2046.8 1921 2046.3 C
+1921.9 2047.3 1921.3 2044.1 1921.5 2044.1 C
+1919.7 2044.8 1915.7 2043.5 1916.2 2046 C
+1916.2 2048.3 1917 2045.9 1917.2 2047 C
+[0 0 0 0] vc
+f
+S
+n
+1922 2044.1 m
+1923.5 2043.2 1927 2045.4 1927.5 2042.9 C
+1927.1 2042.6 1927.3 2040.9 1927.2 2041.5 C
+1924.9 2042.3 1920.9 2040.6 1922 2044.1 C
+f
+S
+n
+1934.9 2043.9 m
+1935.2 2043.4 1934.4 2042.7 1934 2042.2 C
+1933.2 2041.8 1932.4 2042.8 1932.8 2043.2 C
+1932.9 2044 1934.3 2043.3 1934.9 2043.9 C
+f
+S
+n
+1906.1 2030.7 m
+1906.1 2028.8 1906.1 2027 1906.1 2025.2 C
+1906.1 2027 1906.1 2028.8 1906.1 2030.7 C
+[0.21 0.21 0 0] vc
+f
+S
+n
+1932.8 2018.7 m
+1932.8 2016.8 1932.8 2014.8 1932.8 2012.9 C
+1932.8 2014.8 1932.8 2016.8 1932.8 2018.7 C
+f
+S
+n
+1894.4 2016.5 m
+1895 2016 1896.8 2016.3 1897.2 2016.8 C
+1897.2 2016 1898.1 2016.3 1898.2 2015.8 C
+1899.1 2016.8 1898.5 2013.6 1898.7 2013.6 C
+1896.9 2014.4 1892.9 2013 1893.4 2015.6 C
+1893.4 2017.8 1894.2 2015.4 1894.4 2016.5 C
+[0 0 0 0] vc
+f
+S
+n
+1899.2 2013.6 m
+1900.7 2012.7 1904.2 2014.9 1904.7 2012.4 C
+1904.3 2012.1 1904.5 2010.5 1904.4 2011 C
+1902.1 2011.8 1898.1 2010.1 1899.2 2013.6 C
+f
+S
+n
+vmrs
+1912.1 2013.4 m
+1912.4 2012.9 1911.6 2012.3 1911.2 2011.7 C
+1910.4 2011.4 1909.6 2012.3 1910 2012.7 C
+1910.1 2013.5 1911.5 2012.9 1912.1 2013.4 C
+[0 0 0 0] vc
+f
+0.4 w
+2 J
+2 M
+S
+n
+1921 2004.5 m
+1921.6 2004 1923.4 2004.3 1923.9 2004.8 C
+1923.8 2004 1924.8 2004.3 1924.8 2003.8 C
+1925.7 2004.8 1925.1 2001.6 1925.3 2001.6 C
+1923.6 2002.4 1919.6 2001 1920 2003.6 C
+1920 2005.8 1920.8 2003.4 1921 2004.5 C
+f
+S
+n
+1925.8 2001.6 m
+1927.3 2000.7 1930.8 2002.9 1931.3 2000.4 C
+1930.9 2000.1 1931.1 1998.5 1931.1 1999 C
+1928.7 1999.8 1924.8 1998.1 1925.8 2001.6 C
+f
+S
+n
+1938.8 2001.4 m
+1939 2000.9 1938.2 2000.3 1937.8 1999.7 C
+1937.1 1999.4 1936.2 2000.3 1936.6 2000.7 C
+1936.7 2001.5 1938.1 2000.9 1938.8 2001.4 C
+f
+S
+n
+1908.6691 2008.1348 m
+1897.82 2010.0477 L
+1894.1735 1989.3671 L
+1905.0226 1987.4542 L
+1908.6691 2008.1348 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [19.696045 -3.4729 3.4729 19.696045 0 0] makesetfont
+1895.041763 1994.291153 m
+0 0 32 0 0 (l) ts
+}
+true
+[0 0 0 1]sts
+Q
+1979.2185 1991.7809 m
+1960.6353 1998.5452 L
+1953.4532 1978.8124 L
+1972.0363 1972.0481 L
+1979.2185 1991.7809 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [18.793335 -6.84082 6.84021 18.793335 0 0] makesetfont
+1955.163254 1983.510773 m
+0 0 32 0 0 (\256) ts
+}
+true
+[0 0 0 1]sts
+Q
+1952.1544 2066.5423 m
+1938.0739 2069.025 L
+1934.4274 2048.3444 L
+1948.5079 2045.8617 L
+1952.1544 2066.5423 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [19.696045 -3.4729 3.4729 19.696045 0 0] makesetfont
+1935.29567 2053.268433 m
+0 0 32 0 0 (") ts
+}
+true
+[0 0 0 1]sts
+Q
+1931.7231 2043.621 m
+1919.3084 2048.14 L
+1910.6898 2024.4607 L
+1923.1046 2019.9417 L
+1931.7231 2043.621 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [22.552002 -8.208984 8.208252 22.552002 0 0] makesetfont
+1912.741867 2030.098648 m
+0 0 32 0 0 (=) ts
+}
+true
+[0 0 0 1]sts
+Q
+1944 2024.5 m
+1944 2014 L
+0.8504 w
+0 J
+3.863693 M
+[0 0 0 1] vc
+false setoverprint
+S
+n
+1944.25 2019.1673 m
+1952.5 2015.9173 L
+S
+n
+1931.0787 2124.423 m
+1855.5505 2043.4285 L
+1871.0419 2013.0337 L
+1946.5701 2094.0282 L
+1931.0787 2124.423 L
+n
+q
+_bfh
+%%IncludeResource: font ZapfHumanist601BT-Bold
+_efh
+{
+f1 [22.155762 23.759277 -14.753906 28.947754 0 0] makesetfont
+1867.35347 2020.27063 m
+0 0 32 0 0 (Isabelle) ts
+}
+true
+[0 0 0 1]sts
+Q
+1933.5503 1996.9547 m
+1922.7012 1998.8677 L
+1919.0547 1978.1871 L
+1929.9038 1976.2741 L
+1933.5503 1996.9547 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [19.696045 -3.4729 3.4729 19.696045 0 0] makesetfont
+1919.922913 1983.111069 m
+0 0 32 0 0 (b) ts
+}
+true
+[0 0 0 1]sts
+Q
+2006.3221 2025.7184 m
+1993.8573 2027.9162 L
+1990.2108 2007.2356 L
+2002.6756 2005.0378 L
+2006.3221 2025.7184 L
+n
+q
+_bfh
+%%IncludeResource: font Symbol
+_efh
+{
+f0 [19.696045 -3.4729 3.4729 19.696045 0 0] makesetfont
+1991.07901 2012.159653 m
+0 0 32 0 0 (a) ts
+}
+true
+[0 0 0 1]sts
+Q
+vmrs
+2030.0624 2094.056 m
+1956.3187 2120.904 L
+1956.321 2095.3175 L
+2030.0647 2068.4695 L
+2030.0624 2094.056 L
+n
+q
+_bfh
+%%IncludeResource: font ZapfHumanist601BT-Bold
+_efh
+{
+f1 [22.898804 -8.336792 -0.002197 24.368408 0 0] makesetfont
+1956.320496 2101.409561 m
+0 0 32 0 0 (Nitpick) ts
+}
+true
+[0 0 0 1]sts
+Q
+vmr
+vmr
+end
+%%Trailer
+%%DocumentNeededResources: font Symbol
+%%+ font ZapfHumanist601BT-Bold
+%%DocumentFonts: Symbol
+%%+ ZapfHumanist601BT-Bold
+%%DocumentNeededFonts: Symbol
+%%+ ZapfHumanist601BT-BoldBinary file doc-src/gfx/isabelle_nitpick.pdf has changed
--- a/doc-src/manual.bib Tue Oct 27 12:59:57 2009 +0000
+++ b/doc-src/manual.bib Tue Oct 27 14:46:03 2009 +0000
@@ -49,7 +49,7 @@
@Unpublished{abrial93,
author = {J. R. Abrial and G. Laffitte},
- title = {Towards the Mechanization of the Proofs of some Classical
+ title = {Towards the Mechanization of the Proofs of Some Classical
Theorems of Set Theory},
note = {preprint},
year = 1993,
@@ -73,6 +73,17 @@
crossref = {types93},
pages = {213-237}}
+@inproceedings{andersson-1993,
+ author = "Arne Andersson",
+ title = "Balanced Search Trees Made Simple",
+ editor = "F. K. H. A. Dehne and N. Santoro and S. Whitesides",
+ booktitle = "WADS 1993",
+ series = LNCS,
+ volume = {709},
+ pages = "61--70",
+ year = 1993,
+ publisher = Springer}
+
@book{andrews86,
author = "Peter Andrews",
title = "An Introduction to Mathematical Logic and Type Theory: to Truth
@@ -167,6 +178,15 @@
author = "Stefan Berghofer and Tobias Nipkow",
pages = "38--52"}
+@inproceedings{berghofer-nipkow-2004,
+ author = {Stefan Berghofer and Tobias Nipkow},
+ title = {Random Testing in {I}sabelle/{HOL}},
+ pages = {230--239},
+ editor = "J. Cuellar and Z. Liu",
+ booktitle = {{SEFM} 2004},
+ publisher = IEEE,
+ year = 2004}
+
@InProceedings{Berghofer-Nipkow:2002,
author = {Stefan Berghofer and Tobias Nipkow},
title = {Executing Higher Order Logic},
@@ -200,6 +220,14 @@
title="Introduction to Functional Programming using Haskell",
publisher=PH,year=1998}
+@inproceedings{blanchette-nipkow-2009,
+ title = "Nitpick: A Counterexample Generator for Higher-Order Logic Based on a Relational Model Finder (Extended Abstract)",
+ author = "Jasmin Christian Blanchette and Tobias Nipkow",
+ booktitle = "{TAP} 2009: Short Papers",
+ editor = "Catherine Dubois",
+ publisher = "ETH Technical Report 630",
+ year = 2009}
+
@Article{boyer86,
author = {Robert Boyer and Ewing Lusk and William McCune and Ross
Overbeek and Mark Stickel and Lawrence Wos},
@@ -241,7 +269,7 @@
}
@InProceedings{bulwahn-et-al:2008:imperative,
- author = {Lukas Bulwahn and Alexander Krauss and Florian Haftmann and Levent Erk�k and John Matthews},
+ author = {Lukas Bulwahn and Alexander Krauss and Florian Haftmann and Levent Erkök and John Matthews},
title = {Imperative Functional Programming with {Isabelle/HOL}},
crossref = {tphols2008},
}
@@ -597,6 +625,12 @@
year = 2003,
note = {\url{http://www.haskell.org/definition/}}}
+@book{jackson-2006,
+ author = "Daniel Jackson",
+ title = "Software Abstractions: Logic, Language, and Analysis",
+ publisher = MIT,
+ year = 2006}
+
%K
@InProceedings{kammueller-locales,
@@ -878,10 +912,11 @@
@Book{isa-tutorial,
author = {Tobias Nipkow and Lawrence C. Paulson and Markus Wenzel},
- title = {Isabelle/HOL: A Proof Assistant for Higher-Order Logic},
- publisher = {Springer},
+ title = {Isabelle/{HOL}: A Proof Assistant for Higher-Order Logic},
+ publisher = Springer,
year = 2002,
- note = {LNCS Tutorial 2283}}
+ series = LNCS,
+ volume = 2283}
@Article{noel,
author = {Philippe No{\"e}l},
@@ -1021,7 +1056,7 @@
Essays in Honor of {Robin Milner}},
booktitle = {Proof, Language, and Interaction:
Essays in Honor of {Robin Milner}},
- publisher = {MIT Press},
+ publisher = MIT,
year = 2000,
editor = {Gordon Plotkin and Colin Stirling and Mads Tofte}}
@@ -1236,6 +1271,12 @@
number = 4
}
+@misc{sledgehammer-2009,
+ key = "Sledgehammer",
+ title = "The {S}ledgehammer: Let Automatic Theorem Provers
+Write Your {I}s\-a\-belle Scripts",
+ note = "\url{http://www.cl.cam.ac.uk/research/hvg/Isabelle/sledgehammer.html}"}
+
@inproceedings{slind-tfl,
author = {Konrad Slind},
title = {Function Definition in Higher Order Logic},
@@ -1295,6 +1336,27 @@
title={Haskell: The Craft of Functional Programming},
publisher={Addison-Wesley},year=1999}
+@misc{kodkod-2009,
+ author = "Emina Torlak",
+ title = {Kodkod: Constraint Solver for Relational Logic},
+ note = "\url{http://alloy.mit.edu/kodkod/}"}
+
+@misc{kodkod-2009-options,
+ author = "Emina Torlak",
+ title = "Kodkod {API}: Class {Options}",
+ note = "\url{http://alloy.mit.edu/kodkod/docs/kodkod/engine/config/Options.html}"}
+
+@inproceedings{torlak-jackson-2007,
+ title = "Kodkod: A Relational Model Finder",
+ author = "Emina Torlak and Daniel Jackson",
+ editor = "Orna Grumberg and Michael Huth",
+ booktitle = "TACAS 2007",
+ series = LNCS,
+ volume = {4424},
+ pages = "632--647",
+ year = 2007,
+ publisher = Springer}
+
@Unpublished{Trybulec:1993:MizarFeatures,
author = {A. Trybulec},
title = {Some Features of the {Mizar} Language},
@@ -1320,6 +1382,13 @@
year = 1989
}
+@phdthesis{weber-2008,
+ author = "Tjark Weber",
+ title = "SAT-Based Finite Model Generation for Higher-Order Logic",
+ school = {Dept.\ of Informatics, T.U. M\"unchen},
+ type = "{Ph.D.}\ thesis",
+ year = 2008}
+
@Misc{x-symbol,
author = {Christoph Wedler},
title = {Emacs package ``{X-Symbol}''},
@@ -1570,7 +1639,7 @@
Essays in Honor of {Larry Wos}},
booktitle = {Automated Reasoning and its Applications:
Essays in Honor of {Larry Wos}},
- publisher = {MIT Press},
+ publisher = MIT,
year = 1997,
editor = {Robert Veroff}}
@@ -1669,3 +1738,8 @@
title = {{ML} Modules and {Haskell} Type Classes: A Constructive Comparison},
author = {Stefan Wehr et. al.}
}
+
+@misc{wikipedia-2009-aa-trees,
+ key = "Wikipedia",
+ title = "Wikipedia: {AA} Tree",
+ note = "\url{http://en.wikipedia.org/wiki/AA_tree}"}--- a/doc/Contents Tue Oct 27 12:59:57 2009 +0000
+++ b/doc/Contents Tue Oct 27 14:46:03 2009 +0000
@@ -6,6 +6,7 @@
classes Tutorial on Type Classes
functions Tutorial on Function Definitions
codegen Tutorial on Code Generation
+ nitpick User's Guide to Nitpick in Isabelle/HOL
sugar LaTeX Sugar for Isabelle documents
Reference Manuals
--- a/etc/isar-keywords-ZF.el Tue Oct 27 12:59:57 2009 +0000
+++ b/etc/isar-keywords-ZF.el Tue Oct 27 14:46:03 2009 +0000
@@ -9,12 +9,9 @@
"\\.\\."
"Isabelle\\.command"
"Isar\\.begin_document"
- "Isar\\.command"
"Isar\\.define_command"
"Isar\\.edit_document"
"Isar\\.end_document"
- "Isar\\.insert"
- "Isar\\.remove"
"ML"
"ML_command"
"ML_prf"
@@ -252,12 +249,9 @@
(defconst isar-keywords-control
'("Isabelle\\.command"
"Isar\\.begin_document"
- "Isar\\.command"
"Isar\\.define_command"
"Isar\\.edit_document"
"Isar\\.end_document"
- "Isar\\.insert"
- "Isar\\.remove"
"ProofGeneral\\.inform_file_processed"
"ProofGeneral\\.inform_file_retracted"
"ProofGeneral\\.kill_proof"--- a/etc/isar-keywords.el Tue Oct 27 12:59:57 2009 +0000
+++ b/etc/isar-keywords.el Tue Oct 27 14:46:03 2009 +0000
@@ -9,12 +9,9 @@
"\\.\\."
"Isabelle\\.command"
"Isar\\.begin_document"
- "Isar\\.command"
"Isar\\.define_command"
"Isar\\.edit_document"
"Isar\\.end_document"
- "Isar\\.insert"
- "Isar\\.remove"
"ML"
"ML_command"
"ML_prf"
@@ -135,6 +132,8 @@
"method_setup"
"moreover"
"next"
+ "nitpick"
+ "nitpick_params"
"no_notation"
"no_syntax"
"no_translations"
@@ -317,12 +316,9 @@
(defconst isar-keywords-control
'("Isabelle\\.command"
"Isar\\.begin_document"
- "Isar\\.command"
"Isar\\.define_command"
"Isar\\.edit_document"
"Isar\\.end_document"
- "Isar\\.insert"
- "Isar\\.remove"
"ProofGeneral\\.inform_file_processed"
"ProofGeneral\\.inform_file_retracted"
"ProofGeneral\\.kill_proof"
@@ -360,6 +356,7 @@
"header"
"help"
"kill_thy"
+ "nitpick"
"normal_form"
"pr"
"pretty_setmargin"
@@ -482,6 +479,7 @@
"local_setup"
"locale"
"method_setup"
+ "nitpick_params"
"no_notation"
"no_syntax"
"no_translations"--- a/lib/jedit/isabelle.xml Tue Oct 27 12:59:57 2009 +0000
+++ b/lib/jedit/isabelle.xml Tue Oct 27 14:46:03 2009 +0000
@@ -36,12 +36,9 @@
<OPERATOR>..</OPERATOR>
<INVALID>Isabelle.command</INVALID>
<INVALID>Isar.begin_document</INVALID>
- <INVALID>Isar.command</INVALID>
<INVALID>Isar.define_command</INVALID>
<INVALID>Isar.edit_document</INVALID>
<INVALID>Isar.end_document</INVALID>
- <INVALID>Isar.insert</INVALID>
- <INVALID>Isar.remove</INVALID>
<OPERATOR>ML</OPERATOR>
<LABEL>ML_command</LABEL>
<OPERATOR>ML_prf</OPERATOR>
@@ -196,6 +193,8 @@
<OPERATOR>moreover</OPERATOR>
<KEYWORD4>morphisms</KEYWORD4>
<OPERATOR>next</OPERATOR>
+ <LABEL>nitpick</LABEL>
+ <OPERATOR>nitpick_params</OPERATOR>
<OPERATOR>no_notation</OPERATOR>
<OPERATOR>no_syntax</OPERATOR>
<OPERATOR>no_translations</OPERATOR>
@@ -246,6 +245,7 @@
<LABEL>print_drafts</LABEL>
<LABEL>print_facts</LABEL>
<LABEL>print_induct_rules</LABEL>
+ <LABEL>print_interps</LABEL>
<LABEL>print_locale</LABEL>
<LABEL>print_locales</LABEL>
<LABEL>print_methods</LABEL>--- a/src/HOL/Decision_Procs/Decision_Procs.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Decision_Procs/Decision_Procs.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1,7 +1,7 @@
header {* Various decision procedures. typically involving reflection *}
theory Decision_Procs
-imports Cooper Ferrack MIR Approximation Dense_Linear_Order "ex/Approximation_Ex" "ex/Dense_Linear_Order_Ex"
+imports Cooper Ferrack MIR Approximation Dense_Linear_Order "ex/Approximation_Ex" "ex/Dense_Linear_Order_Ex" Parametric_Ferrante_Rackoff
begin
end
\ No newline at end of file--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,3227 @@
+(* Title: HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy
+ Author: Amine Chaieb
+*)
+
+header{* A formalization of Ferrante and Rackoff's procedure with polynomial parameters, see Paper in CALCULEMUS 2008 *}
+
+theory Parametric_Ferrante_Rackoff
+imports Reflected_Multivariate_Polynomial
+ "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+begin
+
+
+subsection {* Terms *}
+
+datatype tm = CP poly | Bound nat | Add tm tm | Mul poly tm
+ | Neg tm | Sub tm tm | CNP nat poly tm
+ (* A size for poly to make inductive proofs simpler*)
+
+consts tmsize :: "tm \<Rightarrow> nat"
+primrec
+ "tmsize (CP c) = polysize c"
+ "tmsize (Bound n) = 1"
+ "tmsize (Neg a) = 1 + tmsize a"
+ "tmsize (Add a b) = 1 + tmsize a + tmsize b"
+ "tmsize (Sub a b) = 3 + tmsize a + tmsize b"
+ "tmsize (Mul c a) = 1 + polysize c + tmsize a"
+ "tmsize (CNP n c a) = 3 + polysize c + tmsize a "
+
+ (* Semantics of terms tm *)
+consts Itm :: "'a::{ring_char_0,division_by_zero,field} list \<Rightarrow> 'a list \<Rightarrow> tm \<Rightarrow> 'a"
+primrec
+ "Itm vs bs (CP c) = (Ipoly vs c)"
+ "Itm vs bs (Bound n) = bs!n"
+ "Itm vs bs (Neg a) = -(Itm vs bs a)"
+ "Itm vs bs (Add a b) = Itm vs bs a + Itm vs bs b"
+ "Itm vs bs (Sub a b) = Itm vs bs a - Itm vs bs b"
+ "Itm vs bs (Mul c a) = (Ipoly vs c) * Itm vs bs a"
+ "Itm vs bs (CNP n c t) = (Ipoly vs c)*(bs!n) + Itm vs bs t"
+
+
+fun allpolys:: "(poly \<Rightarrow> bool) \<Rightarrow> tm \<Rightarrow> bool" where
+ "allpolys P (CP c) = P c"
+| "allpolys P (CNP n c p) = (P c \<and> allpolys P p)"
+| "allpolys P (Mul c p) = (P c \<and> allpolys P p)"
+| "allpolys P (Neg p) = allpolys P p"
+| "allpolys P (Add p q) = (allpolys P p \<and> allpolys P q)"
+| "allpolys P (Sub p q) = (allpolys P p \<and> allpolys P q)"
+| "allpolys P p = True"
+
+consts
+ tmboundslt:: "nat \<Rightarrow> tm \<Rightarrow> bool"
+ tmbound0:: "tm \<Rightarrow> bool" (* a tm is INDEPENDENT of Bound 0 *)
+ tmbound:: "nat \<Rightarrow> tm \<Rightarrow> bool" (* a tm is INDEPENDENT of Bound n *)
+ incrtm0:: "tm \<Rightarrow> tm"
+ incrtm:: "nat \<Rightarrow> tm \<Rightarrow> tm"
+ decrtm0:: "tm \<Rightarrow> tm"
+ decrtm:: "nat \<Rightarrow> tm \<Rightarrow> tm"
+primrec
+ "tmboundslt n (CP c) = True"
+ "tmboundslt n (Bound m) = (m < n)"
+ "tmboundslt n (CNP m c a) = (m < n \<and> tmboundslt n a)"
+ "tmboundslt n (Neg a) = tmboundslt n a"
+ "tmboundslt n (Add a b) = (tmboundslt n a \<and> tmboundslt n b)"
+ "tmboundslt n (Sub a b) = (tmboundslt n a \<and> tmboundslt n b)"
+ "tmboundslt n (Mul i a) = tmboundslt n a"
+primrec
+ "tmbound0 (CP c) = True"
+ "tmbound0 (Bound n) = (n>0)"
+ "tmbound0 (CNP n c a) = (n\<noteq>0 \<and> tmbound0 a)"
+ "tmbound0 (Neg a) = tmbound0 a"
+ "tmbound0 (Add a b) = (tmbound0 a \<and> tmbound0 b)"
+ "tmbound0 (Sub a b) = (tmbound0 a \<and> tmbound0 b)"
+ "tmbound0 (Mul i a) = tmbound0 a"
+lemma tmbound0_I:
+ assumes nb: "tmbound0 a"
+ shows "Itm vs (b#bs) a = Itm vs (b'#bs) a"
+using nb
+by (induct a rule: tmbound0.induct,auto simp add: nth_pos2)
+
+primrec
+ "tmbound n (CP c) = True"
+ "tmbound n (Bound m) = (n \<noteq> m)"
+ "tmbound n (CNP m c a) = (n\<noteq>m \<and> tmbound n a)"
+ "tmbound n (Neg a) = tmbound n a"
+ "tmbound n (Add a b) = (tmbound n a \<and> tmbound n b)"
+ "tmbound n (Sub a b) = (tmbound n a \<and> tmbound n b)"
+ "tmbound n (Mul i a) = tmbound n a"
+lemma tmbound0_tmbound_iff: "tmbound 0 t = tmbound0 t" by (induct t, auto)
+
+lemma tmbound_I:
+ assumes bnd: "tmboundslt (length bs) t" and nb: "tmbound n t" and le: "n \<le> length bs"
+ shows "Itm vs (bs[n:=x]) t = Itm vs bs t"
+ using nb le bnd
+ by (induct t rule: tmbound.induct , auto)
+
+recdef decrtm0 "measure size"
+ "decrtm0 (Bound n) = Bound (n - 1)"
+ "decrtm0 (Neg a) = Neg (decrtm0 a)"
+ "decrtm0 (Add a b) = Add (decrtm0 a) (decrtm0 b)"
+ "decrtm0 (Sub a b) = Sub (decrtm0 a) (decrtm0 b)"
+ "decrtm0 (Mul c a) = Mul c (decrtm0 a)"
+ "decrtm0 (CNP n c a) = CNP (n - 1) c (decrtm0 a)"
+ "decrtm0 a = a"
+recdef incrtm0 "measure size"
+ "incrtm0 (Bound n) = Bound (n + 1)"
+ "incrtm0 (Neg a) = Neg (incrtm0 a)"
+ "incrtm0 (Add a b) = Add (incrtm0 a) (incrtm0 b)"
+ "incrtm0 (Sub a b) = Sub (incrtm0 a) (incrtm0 b)"
+ "incrtm0 (Mul c a) = Mul c (incrtm0 a)"
+ "incrtm0 (CNP n c a) = CNP (n + 1) c (incrtm0 a)"
+ "incrtm0 a = a"
+lemma decrtm0: assumes nb: "tmbound0 t"
+ shows "Itm vs (x#bs) t = Itm vs bs (decrtm0 t)"
+ using nb by (induct t rule: decrtm0.induct, simp_all add: nth_pos2)
+lemma incrtm0: "Itm vs (x#bs) (incrtm0 t) = Itm vs bs t"
+ by (induct t rule: decrtm0.induct, simp_all add: nth_pos2)
+
+primrec
+ "decrtm m (CP c) = (CP c)"
+ "decrtm m (Bound n) = (if n < m then Bound n else Bound (n - 1))"
+ "decrtm m (Neg a) = Neg (decrtm m a)"
+ "decrtm m (Add a b) = Add (decrtm m a) (decrtm m b)"
+ "decrtm m (Sub a b) = Sub (decrtm m a) (decrtm m b)"
+ "decrtm m (Mul c a) = Mul c (decrtm m a)"
+ "decrtm m (CNP n c a) = (if n < m then CNP n c (decrtm m a) else CNP (n - 1) c (decrtm m a))"
+
+consts removen:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
+primrec
+ "removen n [] = []"
+ "removen n (x#xs) = (if n=0 then xs else (x#(removen (n - 1) xs)))"
+
+lemma removen_same: "n \<ge> length xs \<Longrightarrow> removen n xs = xs"
+ by (induct xs arbitrary: n, auto)
+
+lemma nth_length_exceeds: "n \<ge> length xs \<Longrightarrow> xs!n = []!(n - length xs)"
+ by (induct xs arbitrary: n, auto)
+
+lemma removen_length: "length (removen n xs) = (if n \<ge> length xs then length xs else length xs - 1)"
+ by (induct xs arbitrary: n, auto)
+lemma removen_nth: "(removen n xs)!m = (if n \<ge> length xs then xs!m
+ else if m < n then xs!m else if m \<le> length xs then xs!(Suc m) else []!(m - (length xs - 1)))"
+proof(induct xs arbitrary: n m)
+ case Nil thus ?case by simp
+next
+ case (Cons x xs n m)
+ {assume nxs: "n \<ge> length (x#xs)" hence ?case using removen_same[OF nxs] by simp}
+ moreover
+ {assume nxs: "\<not> (n \<ge> length (x#xs))"
+ {assume mln: "m < n" hence ?case using prems by (cases m, auto)}
+ moreover
+ {assume mln: "\<not> (m < n)"
+
+ {assume mxs: "m \<le> length (x#xs)" hence ?case using prems by (cases m, auto)}
+ moreover
+ {assume mxs: "\<not> (m \<le> length (x#xs))"
+ have th: "length (removen n (x#xs)) = length xs"
+ using removen_length[where n="n" and xs="x#xs"] nxs by simp
+ with mxs have mxs':"m \<ge> length (removen n (x#xs))" by auto
+ hence "(removen n (x#xs))!m = [] ! (m - length xs)"
+ using th nth_length_exceeds[OF mxs'] by auto
+ hence th: "(removen n (x#xs))!m = [] ! (m - (length (x#xs) - 1))"
+ by auto
+ hence ?case using nxs mln mxs by auto }
+ ultimately have ?case by blast
+ }
+ ultimately have ?case by blast
+
+ } ultimately show ?case by blast
+qed
+
+lemma decrtm: assumes bnd: "tmboundslt (length bs) t" and nb: "tmbound m t"
+ and nle: "m \<le> length bs"
+ shows "Itm vs (removen m bs) (decrtm m t) = Itm vs bs t"
+ using bnd nb nle
+ by (induct t rule: decrtm.induct, auto simp add: removen_nth)
+
+consts tmsubst0:: "tm \<Rightarrow> tm \<Rightarrow> tm"
+primrec
+ "tmsubst0 t (CP c) = CP c"
+ "tmsubst0 t (Bound n) = (if n=0 then t else Bound n)"
+ "tmsubst0 t (CNP n c a) = (if n=0 then Add (Mul c t) (tmsubst0 t a) else CNP n c (tmsubst0 t a))"
+ "tmsubst0 t (Neg a) = Neg (tmsubst0 t a)"
+ "tmsubst0 t (Add a b) = Add (tmsubst0 t a) (tmsubst0 t b)"
+ "tmsubst0 t (Sub a b) = Sub (tmsubst0 t a) (tmsubst0 t b)"
+ "tmsubst0 t (Mul i a) = Mul i (tmsubst0 t a)"
+lemma tmsubst0:
+ shows "Itm vs (x#bs) (tmsubst0 t a) = Itm vs ((Itm vs (x#bs) t)#bs) a"
+by (induct a rule: tmsubst0.induct,auto simp add: nth_pos2)
+
+lemma tmsubst0_nb: "tmbound0 t \<Longrightarrow> tmbound0 (tmsubst0 t a)"
+by (induct a rule: tmsubst0.induct,auto simp add: nth_pos2)
+
+consts tmsubst:: "nat \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm"
+
+primrec
+ "tmsubst n t (CP c) = CP c"
+ "tmsubst n t (Bound m) = (if n=m then t else Bound m)"
+ "tmsubst n t (CNP m c a) = (if n=m then Add (Mul c t) (tmsubst n t a)
+ else CNP m c (tmsubst n t a))"
+ "tmsubst n t (Neg a) = Neg (tmsubst n t a)"
+ "tmsubst n t (Add a b) = Add (tmsubst n t a) (tmsubst n t b)"
+ "tmsubst n t (Sub a b) = Sub (tmsubst n t a) (tmsubst n t b)"
+ "tmsubst n t (Mul i a) = Mul i (tmsubst n t a)"
+
+lemma tmsubst: assumes nb: "tmboundslt (length bs) a" and nlt: "n \<le> length bs"
+ shows "Itm vs bs (tmsubst n t a) = Itm vs (bs[n:= Itm vs bs t]) a"
+using nb nlt
+by (induct a rule: tmsubst0.induct,auto simp add: nth_pos2)
+
+lemma tmsubst_nb0: assumes tnb: "tmbound0 t"
+shows "tmbound0 (tmsubst 0 t a)"
+using tnb
+by (induct a rule: tmsubst.induct, auto)
+
+lemma tmsubst_nb: assumes tnb: "tmbound m t"
+shows "tmbound m (tmsubst m t a)"
+using tnb
+by (induct a rule: tmsubst.induct, auto)
+lemma incrtm0_tmbound: "tmbound n t \<Longrightarrow> tmbound (Suc n) (incrtm0 t)"
+ by (induct t, auto)
+ (* Simplification *)
+
+consts
+ simptm:: "tm \<Rightarrow> tm"
+ tmadd:: "tm \<times> tm \<Rightarrow> tm"
+ tmmul:: "tm \<Rightarrow> poly \<Rightarrow> tm"
+recdef tmadd "measure (\<lambda> (t,s). size t + size s)"
+ "tmadd (CNP n1 c1 r1,CNP n2 c2 r2) =
+ (if n1=n2 then
+ (let c = c1 +\<^sub>p c2
+ in if c = 0\<^sub>p then tmadd(r1,r2) else CNP n1 c (tmadd (r1,r2)))
+ else if n1 \<le> n2 then (CNP n1 c1 (tmadd (r1,CNP n2 c2 r2)))
+ else (CNP n2 c2 (tmadd (CNP n1 c1 r1,r2))))"
+ "tmadd (CNP n1 c1 r1,t) = CNP n1 c1 (tmadd (r1, t))"
+ "tmadd (t,CNP n2 c2 r2) = CNP n2 c2 (tmadd (t,r2))"
+ "tmadd (CP b1, CP b2) = CP (b1 +\<^sub>p b2)"
+ "tmadd (a,b) = Add a b"
+
+lemma tmadd[simp]: "Itm vs bs (tmadd (t,s)) = Itm vs bs (Add t s)"
+apply (induct t s rule: tmadd.induct, simp_all add: Let_def)
+apply (case_tac "c1 +\<^sub>p c2 = 0\<^sub>p",case_tac "n1 \<le> n2", simp_all)
+apply (case_tac "n1 = n2", simp_all add: ring_simps)
+apply (simp only: right_distrib[symmetric])
+by (auto simp del: polyadd simp add: polyadd[symmetric])
+
+lemma tmadd_nb0[simp]: "\<lbrakk> tmbound0 t ; tmbound0 s\<rbrakk> \<Longrightarrow> tmbound0 (tmadd (t,s))"
+by (induct t s rule: tmadd.induct, auto simp add: Let_def)
+
+lemma tmadd_nb[simp]: "\<lbrakk> tmbound n t ; tmbound n s\<rbrakk> \<Longrightarrow> tmbound n (tmadd (t,s))"
+by (induct t s rule: tmadd.induct, auto simp add: Let_def)
+lemma tmadd_blt[simp]: "\<lbrakk>tmboundslt n t ; tmboundslt n s\<rbrakk> \<Longrightarrow> tmboundslt n (tmadd (t,s))"
+by (induct t s rule: tmadd.induct, auto simp add: Let_def)
+
+lemma tmadd_allpolys_npoly[simp]: "allpolys isnpoly t \<Longrightarrow> allpolys isnpoly s \<Longrightarrow> allpolys isnpoly (tmadd(t,s))" by (induct t s rule: tmadd.induct, simp_all add: Let_def polyadd_norm)
+
+recdef tmmul "measure size"
+ "tmmul (CP j) = (\<lambda> i. CP (i *\<^sub>p j))"
+ "tmmul (CNP n c a) = (\<lambda> i. CNP n (i *\<^sub>p c) (tmmul a i))"
+ "tmmul t = (\<lambda> i. Mul i t)"
+
+lemma tmmul[simp]: "Itm vs bs (tmmul t i) = Itm vs bs (Mul i t)"
+by (induct t arbitrary: i rule: tmmul.induct, simp_all add: ring_simps)
+
+lemma tmmul_nb0[simp]: "tmbound0 t \<Longrightarrow> tmbound0 (tmmul t i)"
+by (induct t arbitrary: i rule: tmmul.induct, auto )
+
+lemma tmmul_nb[simp]: "tmbound n t \<Longrightarrow> tmbound n (tmmul t i)"
+by (induct t arbitrary: n rule: tmmul.induct, auto )
+lemma tmmul_blt[simp]: "tmboundslt n t \<Longrightarrow> tmboundslt n (tmmul t i)"
+by (induct t arbitrary: i rule: tmmul.induct, auto simp add: Let_def)
+
+lemma tmmul_allpolys_npoly[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "allpolys isnpoly t \<Longrightarrow> isnpoly c \<Longrightarrow> allpolys isnpoly (tmmul t c)" by (induct t rule: tmmul.induct, simp_all add: Let_def polymul_norm)
+
+constdefs tmneg :: "tm \<Rightarrow> tm"
+ "tmneg t \<equiv> tmmul t (C (- 1,1))"
+
+constdefs tmsub :: "tm \<Rightarrow> tm \<Rightarrow> tm"
+ "tmsub s t \<equiv> (if s = t then CP 0\<^sub>p else tmadd (s,tmneg t))"
+
+lemma tmneg[simp]: "Itm vs bs (tmneg t) = Itm vs bs (Neg t)"
+using tmneg_def[of t]
+apply simp
+apply (subst number_of_Min)
+apply (simp only: of_int_minus)
+apply simp
+done
+
+lemma tmneg_nb0[simp]: "tmbound0 t \<Longrightarrow> tmbound0 (tmneg t)"
+using tmneg_def by simp
+
+lemma tmneg_nb[simp]: "tmbound n t \<Longrightarrow> tmbound n (tmneg t)"
+using tmneg_def by simp
+lemma tmneg_blt[simp]: "tmboundslt n t \<Longrightarrow> tmboundslt n (tmneg t)"
+using tmneg_def by simp
+lemma [simp]: "isnpoly (C (-1,1))" unfolding isnpoly_def by simp
+lemma tmneg_allpolys_npoly[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "allpolys isnpoly t \<Longrightarrow> allpolys isnpoly (tmneg t)"
+ unfolding tmneg_def by auto
+
+lemma tmsub[simp]: "Itm vs bs (tmsub a b) = Itm vs bs (Sub a b)"
+using tmsub_def by simp
+
+lemma tmsub_nb0[simp]: "\<lbrakk> tmbound0 t ; tmbound0 s\<rbrakk> \<Longrightarrow> tmbound0 (tmsub t s)"
+using tmsub_def by simp
+lemma tmsub_nb[simp]: "\<lbrakk> tmbound n t ; tmbound n s\<rbrakk> \<Longrightarrow> tmbound n (tmsub t s)"
+using tmsub_def by simp
+lemma tmsub_blt[simp]: "\<lbrakk>tmboundslt n t ; tmboundslt n s\<rbrakk> \<Longrightarrow> tmboundslt n (tmsub t s )"
+using tmsub_def by simp
+lemma tmsub_allpolys_npoly[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "allpolys isnpoly t \<Longrightarrow> allpolys isnpoly s \<Longrightarrow> allpolys isnpoly (tmsub t s)"
+ unfolding tmsub_def by (simp add: isnpoly_def)
+
+recdef simptm "measure size"
+ "simptm (CP j) = CP (polynate j)"
+ "simptm (Bound n) = CNP n 1\<^sub>p (CP 0\<^sub>p)"
+ "simptm (Neg t) = tmneg (simptm t)"
+ "simptm (Add t s) = tmadd (simptm t,simptm s)"
+ "simptm (Sub t s) = tmsub (simptm t) (simptm s)"
+ "simptm (Mul i t) = (let i' = polynate i in if i' = 0\<^sub>p then CP 0\<^sub>p else tmmul (simptm t) i')"
+ "simptm (CNP n c t) = (let c' = polynate c in if c' = 0\<^sub>p then simptm t else tmadd (CNP n c' (CP 0\<^sub>p ), simptm t))"
+
+lemma polynate_stupid:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "polynate t = 0\<^sub>p \<Longrightarrow> Ipoly bs t = (0::'a::{ring_char_0,division_by_zero, field})"
+apply (subst polynate[symmetric])
+apply simp
+done
+
+lemma simptm_ci[simp]: "Itm vs bs (simptm t) = Itm vs bs t"
+by (induct t rule: simptm.induct, auto simp add: tmneg tmadd tmsub tmmul Let_def polynate_stupid)
+
+lemma simptm_tmbound0[simp]:
+ "tmbound0 t \<Longrightarrow> tmbound0 (simptm t)"
+by (induct t rule: simptm.induct, auto simp add: Let_def)
+
+lemma simptm_nb[simp]: "tmbound n t \<Longrightarrow> tmbound n (simptm t)"
+by (induct t rule: simptm.induct, auto simp add: Let_def)
+lemma simptm_nlt[simp]: "tmboundslt n t \<Longrightarrow> tmboundslt n (simptm t)"
+by (induct t rule: simptm.induct, auto simp add: Let_def)
+
+lemma [simp]: "isnpoly 0\<^sub>p" and [simp]: "isnpoly (C(1,1))"
+ by (simp_all add: isnpoly_def)
+lemma simptm_allpolys_npoly[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "allpolys isnpoly (simptm p)"
+ by (induct p rule: simptm.induct, auto simp add: Let_def)
+
+consts split0 :: "tm \<Rightarrow> (poly \<times> tm)"
+recdef split0 "measure tmsize"
+ "split0 (Bound 0) = (1\<^sub>p, CP 0\<^sub>p)"
+ "split0 (CNP 0 c t) = (let (c',t') = split0 t in (c +\<^sub>p c',t'))"
+ "split0 (Neg t) = (let (c,t') = split0 t in (~\<^sub>p c,Neg t'))"
+ "split0 (CNP n c t) = (let (c',t') = split0 t in (c',CNP n c t'))"
+ "split0 (Add s t) = (let (c1,s') = split0 s ; (c2,t') = split0 t in (c1 +\<^sub>p c2, Add s' t'))"
+ "split0 (Sub s t) = (let (c1,s') = split0 s ; (c2,t') = split0 t in (c1 -\<^sub>p c2, Sub s' t'))"
+ "split0 (Mul c t) = (let (c',t') = split0 t in (c *\<^sub>p c', Mul c t'))"
+ "split0 t = (0\<^sub>p, t)"
+
+lemma split0_stupid[simp]: "\<exists>x y. (x,y) = split0 p"
+ apply (rule exI[where x="fst (split0 p)"])
+ apply (rule exI[where x="snd (split0 p)"])
+ by simp
+
+lemma split0:
+ "tmbound 0 (snd (split0 t)) \<and> (Itm vs bs (CNP 0 (fst (split0 t)) (snd (split0 t))) = Itm vs bs t)"
+ apply (induct t rule: split0.induct)
+ apply simp
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def mult_assoc right_distrib[symmetric])
+ apply (simp add: Let_def split_def ring_simps)
+ apply (simp add: Let_def split_def ring_simps)
+ done
+
+lemma split0_ci: "split0 t = (c',t') \<Longrightarrow> Itm vs bs t = Itm vs bs (CNP 0 c' t')"
+proof-
+ fix c' t'
+ assume "split0 t = (c', t')" hence "c' = fst (split0 t)" and "t' = snd (split0 t)" by auto
+ with split0[where t="t" and bs="bs"] show "Itm vs bs t = Itm vs bs (CNP 0 c' t')" by simp
+qed
+
+lemma split0_nb0:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "split0 t = (c',t') \<Longrightarrow> tmbound 0 t'"
+proof-
+ fix c' t'
+ assume "split0 t = (c', t')" hence "c' = fst (split0 t)" and "t' = snd (split0 t)" by auto
+ with conjunct1[OF split0[where t="t"]] show "tmbound 0 t'" by simp
+qed
+
+lemma split0_nb0'[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows "tmbound0 (snd (split0 t))"
+ using split0_nb0[of t "fst (split0 t)" "snd (split0 t)"] by (simp add: tmbound0_tmbound_iff)
+
+
+lemma split0_nb: assumes nb:"tmbound n t" shows "tmbound n (snd (split0 t))"
+ using nb by (induct t rule: split0.induct, auto simp add: Let_def split_def split0_stupid)
+
+lemma split0_blt: assumes nb:"tmboundslt n t" shows "tmboundslt n (snd (split0 t))"
+ using nb by (induct t rule: split0.induct, auto simp add: Let_def split_def split0_stupid)
+
+lemma tmbound_split0: "tmbound 0 t \<Longrightarrow> Ipoly vs (fst(split0 t)) = 0"
+ by (induct t rule: split0.induct, auto simp add: Let_def split_def split0_stupid)
+
+lemma tmboundslt_split0: "tmboundslt n t \<Longrightarrow> Ipoly vs (fst(split0 t)) = 0 \<or> n > 0"
+by (induct t rule: split0.induct, auto simp add: Let_def split_def split0_stupid)
+
+lemma tmboundslt0_split0: "tmboundslt 0 t \<Longrightarrow> Ipoly vs (fst(split0 t)) = 0"
+ by (induct t rule: split0.induct, auto simp add: Let_def split_def split0_stupid)
+
+lemma allpolys_split0: "allpolys isnpoly p \<Longrightarrow> allpolys isnpoly (snd (split0 p))"
+by (induct p rule: split0.induct, auto simp add: isnpoly_def Let_def split_def split0_stupid)
+
+lemma isnpoly_fst_split0: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero, field})"
+ shows
+ "allpolys isnpoly p \<Longrightarrow> isnpoly (fst (split0 p))"
+ by (induct p rule: split0.induct,
+ auto simp add: polyadd_norm polysub_norm polyneg_norm polymul_norm
+ Let_def split_def split0_stupid)
+
+subsection{* Formulae *}
+
+datatype fm = T| F| Le tm | Lt tm | Eq tm | NEq tm|
+ NOT fm| And fm fm| Or fm fm| Imp fm fm| Iff fm fm| E fm| A fm
+
+
+ (* A size for fm *)
+consts fmsize :: "fm \<Rightarrow> nat"
+recdef fmsize "measure size"
+ "fmsize (NOT p) = 1 + fmsize p"
+ "fmsize (And p q) = 1 + fmsize p + fmsize q"
+ "fmsize (Or p q) = 1 + fmsize p + fmsize q"
+ "fmsize (Imp p q) = 3 + fmsize p + fmsize q"
+ "fmsize (Iff p q) = 3 + 2*(fmsize p + fmsize q)"
+ "fmsize (E p) = 1 + fmsize p"
+ "fmsize (A p) = 4+ fmsize p"
+ "fmsize p = 1"
+ (* several lemmas about fmsize *)
+lemma fmsize_pos: "fmsize p > 0"
+by (induct p rule: fmsize.induct) simp_all
+
+ (* Semantics of formulae (fm) *)
+consts Ifm ::"'a::{division_by_zero,ordered_field} list \<Rightarrow> 'a list \<Rightarrow> fm \<Rightarrow> bool"
+primrec
+ "Ifm vs bs T = True"
+ "Ifm vs bs F = False"
+ "Ifm vs bs (Lt a) = (Itm vs bs a < 0)"
+ "Ifm vs bs (Le a) = (Itm vs bs a \<le> 0)"
+ "Ifm vs bs (Eq a) = (Itm vs bs a = 0)"
+ "Ifm vs bs (NEq a) = (Itm vs bs a \<noteq> 0)"
+ "Ifm vs bs (NOT p) = (\<not> (Ifm vs bs p))"
+ "Ifm vs bs (And p q) = (Ifm vs bs p \<and> Ifm vs bs q)"
+ "Ifm vs bs (Or p q) = (Ifm vs bs p \<or> Ifm vs bs q)"
+ "Ifm vs bs (Imp p q) = ((Ifm vs bs p) \<longrightarrow> (Ifm vs bs q))"
+ "Ifm vs bs (Iff p q) = (Ifm vs bs p = Ifm vs bs q)"
+ "Ifm vs bs (E p) = (\<exists> x. Ifm vs (x#bs) p)"
+ "Ifm vs bs (A p) = (\<forall> x. Ifm vs (x#bs) p)"
+
+consts not:: "fm \<Rightarrow> fm"
+recdef not "measure size"
+ "not (NOT (NOT p)) = not p"
+ "not (NOT p) = p"
+ "not T = F"
+ "not F = T"
+ "not (Lt t) = Le (tmneg t)"
+ "not (Le t) = Lt (tmneg t)"
+ "not (Eq t) = NEq t"
+ "not (NEq t) = Eq t"
+ "not p = NOT p"
+lemma not[simp]: "Ifm vs bs (not p) = Ifm vs bs (NOT p)"
+by (induct p rule: not.induct) auto
+
+constdefs conj :: "fm \<Rightarrow> fm \<Rightarrow> fm"
+ "conj p q \<equiv> (if (p = F \<or> q=F) then F else if p=T then q else if q=T then p else
+ if p = q then p else And p q)"
+lemma conj[simp]: "Ifm vs bs (conj p q) = Ifm vs bs (And p q)"
+by (cases "p=F \<or> q=F",simp_all add: conj_def) (cases p,simp_all)
+
+constdefs disj :: "fm \<Rightarrow> fm \<Rightarrow> fm"
+ "disj p q \<equiv> (if (p = T \<or> q=T) then T else if p=F then q else if q=F then p
+ else if p=q then p else Or p q)"
+
+lemma disj[simp]: "Ifm vs bs (disj p q) = Ifm vs bs (Or p q)"
+by (cases "p=T \<or> q=T",simp_all add: disj_def) (cases p,simp_all)
+
+constdefs imp :: "fm \<Rightarrow> fm \<Rightarrow> fm"
+ "imp p q \<equiv> (if (p = F \<or> q=T \<or> p=q) then T else if p=T then q else if q=F then not p
+ else Imp p q)"
+lemma imp[simp]: "Ifm vs bs (imp p q) = Ifm vs bs (Imp p q)"
+by (cases "p=F \<or> q=T",simp_all add: imp_def)
+
+constdefs iff :: "fm \<Rightarrow> fm \<Rightarrow> fm"
+ "iff p q \<equiv> (if (p = q) then T else if (p = NOT q \<or> NOT p = q) then F else
+ if p=F then not q else if q=F then not p else if p=T then q else if q=T then p else
+ Iff p q)"
+lemma iff[simp]: "Ifm vs bs (iff p q) = Ifm vs bs (Iff p q)"
+ by (unfold iff_def,cases "p=q", simp,cases "p=NOT q", simp) (cases "NOT p= q", auto)
+ (* Quantifier freeness *)
+consts qfree:: "fm \<Rightarrow> bool"
+recdef qfree "measure size"
+ "qfree (E p) = False"
+ "qfree (A p) = False"
+ "qfree (NOT p) = qfree p"
+ "qfree (And p q) = (qfree p \<and> qfree q)"
+ "qfree (Or p q) = (qfree p \<and> qfree q)"
+ "qfree (Imp p q) = (qfree p \<and> qfree q)"
+ "qfree (Iff p q) = (qfree p \<and> qfree q)"
+ "qfree p = True"
+
+ (* Boundedness and substitution *)
+
+consts boundslt :: "nat \<Rightarrow> fm \<Rightarrow> bool"
+primrec
+ "boundslt n T = True"
+ "boundslt n F = True"
+ "boundslt n (Lt t) = (tmboundslt n t)"
+ "boundslt n (Le t) = (tmboundslt n t)"
+ "boundslt n (Eq t) = (tmboundslt n t)"
+ "boundslt n (NEq t) = (tmboundslt n t)"
+ "boundslt n (NOT p) = boundslt n p"
+ "boundslt n (And p q) = (boundslt n p \<and> boundslt n q)"
+ "boundslt n (Or p q) = (boundslt n p \<and> boundslt n q)"
+ "boundslt n (Imp p q) = ((boundslt n p) \<and> (boundslt n q))"
+ "boundslt n (Iff p q) = (boundslt n p \<and> boundslt n q)"
+ "boundslt n (E p) = boundslt (Suc n) p"
+ "boundslt n (A p) = boundslt (Suc n) p"
+
+consts
+ bound0:: "fm \<Rightarrow> bool" (* A Formula is independent of Bound 0 *)
+ bound:: "nat \<Rightarrow> fm \<Rightarrow> bool" (* A Formula is independent of Bound n *)
+ decr0 :: "fm \<Rightarrow> fm"
+ decr :: "nat \<Rightarrow> fm \<Rightarrow> fm"
+recdef bound0 "measure size"
+ "bound0 T = True"
+ "bound0 F = True"
+ "bound0 (Lt a) = tmbound0 a"
+ "bound0 (Le a) = tmbound0 a"
+ "bound0 (Eq a) = tmbound0 a"
+ "bound0 (NEq a) = tmbound0 a"
+ "bound0 (NOT p) = bound0 p"
+ "bound0 (And p q) = (bound0 p \<and> bound0 q)"
+ "bound0 (Or p q) = (bound0 p \<and> bound0 q)"
+ "bound0 (Imp p q) = ((bound0 p) \<and> (bound0 q))"
+ "bound0 (Iff p q) = (bound0 p \<and> bound0 q)"
+ "bound0 p = False"
+lemma bound0_I:
+ assumes bp: "bound0 p"
+ shows "Ifm vs (b#bs) p = Ifm vs (b'#bs) p"
+using bp tmbound0_I[where b="b" and bs="bs" and b'="b'"]
+by (induct p rule: bound0.induct,auto simp add: nth_pos2)
+
+primrec
+ "bound m T = True"
+ "bound m F = True"
+ "bound m (Lt t) = tmbound m t"
+ "bound m (Le t) = tmbound m t"
+ "bound m (Eq t) = tmbound m t"
+ "bound m (NEq t) = tmbound m t"
+ "bound m (NOT p) = bound m p"
+ "bound m (And p q) = (bound m p \<and> bound m q)"
+ "bound m (Or p q) = (bound m p \<and> bound m q)"
+ "bound m (Imp p q) = ((bound m p) \<and> (bound m q))"
+ "bound m (Iff p q) = (bound m p \<and> bound m q)"
+ "bound m (E p) = bound (Suc m) p"
+ "bound m (A p) = bound (Suc m) p"
+
+lemma bound_I:
+ assumes bnd: "boundslt (length bs) p" and nb: "bound n p" and le: "n \<le> length bs"
+ shows "Ifm vs (bs[n:=x]) p = Ifm vs bs p"
+ using bnd nb le tmbound_I[where bs=bs and vs = vs]
+proof(induct p arbitrary: bs n rule: bound.induct)
+ case (E p bs n)
+ {fix y
+ from prems have bnd: "boundslt (length (y#bs)) p"
+ and nb: "bound (Suc n) p" and le: "Suc n \<le> length (y#bs)" by simp+
+ from E.hyps[OF bnd nb le tmbound_I] have "Ifm vs ((y#bs)[Suc n:=x]) p = Ifm vs (y#bs) p" . }
+ thus ?case by simp
+next
+ case (A p bs n) {fix y
+ from prems have bnd: "boundslt (length (y#bs)) p"
+ and nb: "bound (Suc n) p" and le: "Suc n \<le> length (y#bs)" by simp+
+ from A.hyps[OF bnd nb le tmbound_I] have "Ifm vs ((y#bs)[Suc n:=x]) p = Ifm vs (y#bs) p" . }
+ thus ?case by simp
+qed auto
+
+recdef decr0 "measure size"
+ "decr0 (Lt a) = Lt (decrtm0 a)"
+ "decr0 (Le a) = Le (decrtm0 a)"
+ "decr0 (Eq a) = Eq (decrtm0 a)"
+ "decr0 (NEq a) = NEq (decrtm0 a)"
+ "decr0 (NOT p) = NOT (decr0 p)"
+ "decr0 (And p q) = conj (decr0 p) (decr0 q)"
+ "decr0 (Or p q) = disj (decr0 p) (decr0 q)"
+ "decr0 (Imp p q) = imp (decr0 p) (decr0 q)"
+ "decr0 (Iff p q) = iff (decr0 p) (decr0 q)"
+ "decr0 p = p"
+
+lemma decr0: assumes nb: "bound0 p"
+ shows "Ifm vs (x#bs) p = Ifm vs bs (decr0 p)"
+ using nb
+ by (induct p rule: decr0.induct, simp_all add: decrtm0)
+
+primrec
+ "decr m T = T"
+ "decr m F = F"
+ "decr m (Lt t) = (Lt (decrtm m t))"
+ "decr m (Le t) = (Le (decrtm m t))"
+ "decr m (Eq t) = (Eq (decrtm m t))"
+ "decr m (NEq t) = (NEq (decrtm m t))"
+ "decr m (NOT p) = NOT (decr m p)"
+ "decr m (And p q) = conj (decr m p) (decr m q)"
+ "decr m (Or p q) = disj (decr m p) (decr m q)"
+ "decr m (Imp p q) = imp (decr m p) (decr m q)"
+ "decr m (Iff p q) = iff (decr m p) (decr m q)"
+ "decr m (E p) = E (decr (Suc m) p)"
+ "decr m (A p) = A (decr (Suc m) p)"
+
+lemma decr: assumes bnd: "boundslt (length bs) p" and nb: "bound m p"
+ and nle: "m < length bs"
+ shows "Ifm vs (removen m bs) (decr m p) = Ifm vs bs p"
+ using bnd nb nle
+proof(induct p arbitrary: bs m rule: decr.induct)
+ case (E p bs m)
+ {fix x
+ from prems have bnd: "boundslt (length (x#bs)) p" and nb: "bound (Suc m) p"
+ and nle: "Suc m < length (x#bs)" by auto
+ from prems(4)[OF bnd nb nle] have "Ifm vs (removen (Suc m) (x#bs)) (decr (Suc m) p) = Ifm vs (x#bs) p".
+ } thus ?case by auto
+next
+ case (A p bs m)
+ {fix x
+ from prems have bnd: "boundslt (length (x#bs)) p" and nb: "bound (Suc m) p"
+ and nle: "Suc m < length (x#bs)" by auto
+ from prems(4)[OF bnd nb nle] have "Ifm vs (removen (Suc m) (x#bs)) (decr (Suc m) p) = Ifm vs (x#bs) p".
+ } thus ?case by auto
+qed (auto simp add: decrtm removen_nth)
+
+consts
+ subst0:: "tm \<Rightarrow> fm \<Rightarrow> fm"
+
+primrec
+ "subst0 t T = T"
+ "subst0 t F = F"
+ "subst0 t (Lt a) = Lt (tmsubst0 t a)"
+ "subst0 t (Le a) = Le (tmsubst0 t a)"
+ "subst0 t (Eq a) = Eq (tmsubst0 t a)"
+ "subst0 t (NEq a) = NEq (tmsubst0 t a)"
+ "subst0 t (NOT p) = NOT (subst0 t p)"
+ "subst0 t (And p q) = And (subst0 t p) (subst0 t q)"
+ "subst0 t (Or p q) = Or (subst0 t p) (subst0 t q)"
+ "subst0 t (Imp p q) = Imp (subst0 t p) (subst0 t q)"
+ "subst0 t (Iff p q) = Iff (subst0 t p) (subst0 t q)"
+ "subst0 t (E p) = E p"
+ "subst0 t (A p) = A p"
+
+lemma subst0: assumes qf: "qfree p"
+ shows "Ifm vs (x#bs) (subst0 t p) = Ifm vs ((Itm vs (x#bs) t)#bs) p"
+using qf tmsubst0[where x="x" and bs="bs" and t="t"]
+by (induct p rule: subst0.induct, auto)
+
+lemma subst0_nb:
+ assumes bp: "tmbound0 t" and qf: "qfree p"
+ shows "bound0 (subst0 t p)"
+using qf tmsubst0_nb[OF bp] bp
+by (induct p rule: subst0.induct, auto)
+
+consts subst:: "nat \<Rightarrow> tm \<Rightarrow> fm \<Rightarrow> fm"
+primrec
+ "subst n t T = T"
+ "subst n t F = F"
+ "subst n t (Lt a) = Lt (tmsubst n t a)"
+ "subst n t (Le a) = Le (tmsubst n t a)"
+ "subst n t (Eq a) = Eq (tmsubst n t a)"
+ "subst n t (NEq a) = NEq (tmsubst n t a)"
+ "subst n t (NOT p) = NOT (subst n t p)"
+ "subst n t (And p q) = And (subst n t p) (subst n t q)"
+ "subst n t (Or p q) = Or (subst n t p) (subst n t q)"
+ "subst n t (Imp p q) = Imp (subst n t p) (subst n t q)"
+ "subst n t (Iff p q) = Iff (subst n t p) (subst n t q)"
+ "subst n t (E p) = E (subst (Suc n) (incrtm0 t) p)"
+ "subst n t (A p) = A (subst (Suc n) (incrtm0 t) p)"
+
+lemma subst: assumes nb: "boundslt (length bs) p" and nlm: "n \<le> length bs"
+ shows "Ifm vs bs (subst n t p) = Ifm vs (bs[n:= Itm vs bs t]) p"
+ using nb nlm
+proof (induct p arbitrary: bs n t rule: subst0.induct)
+ case (E p bs n)
+ {fix x
+ from prems have bn: "boundslt (length (x#bs)) p" by simp
+ from prems have nlm: "Suc n \<le> length (x#bs)" by simp
+ from prems(3)[OF bn nlm] have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs ((x#bs)[Suc n:= Itm vs (x#bs) (incrtm0 t)]) p" by simp
+ hence "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs (x#bs[n:= Itm vs bs t]) p"
+ by (simp add: incrtm0[where x="x" and bs="bs" and t="t"]) }
+thus ?case by simp
+next
+ case (A p bs n)
+ {fix x
+ from prems have bn: "boundslt (length (x#bs)) p" by simp
+ from prems have nlm: "Suc n \<le> length (x#bs)" by simp
+ from prems(3)[OF bn nlm] have "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs ((x#bs)[Suc n:= Itm vs (x#bs) (incrtm0 t)]) p" by simp
+ hence "Ifm vs (x#bs) (subst (Suc n) (incrtm0 t) p) = Ifm vs (x#bs[n:= Itm vs bs t]) p"
+ by (simp add: incrtm0[where x="x" and bs="bs" and t="t"]) }
+thus ?case by simp
+qed(auto simp add: tmsubst)
+
+lemma subst_nb: assumes tnb: "tmbound m t"
+shows "bound m (subst m t p)"
+using tnb tmsubst_nb incrtm0_tmbound
+by (induct p arbitrary: m t rule: subst.induct, auto)
+
+lemma not_qf[simp]: "qfree p \<Longrightarrow> qfree (not p)"
+by (induct p rule: not.induct, auto)
+lemma not_bn0[simp]: "bound0 p \<Longrightarrow> bound0 (not p)"
+by (induct p rule: not.induct, auto)
+lemma not_nb[simp]: "bound n p \<Longrightarrow> bound n (not p)"
+by (induct p rule: not.induct, auto)
+lemma not_blt[simp]: "boundslt n p \<Longrightarrow> boundslt n (not p)"
+ by (induct p rule: not.induct, auto)
+
+lemma conj_qf[simp]: "\<lbrakk>qfree p ; qfree q\<rbrakk> \<Longrightarrow> qfree (conj p q)"
+using conj_def by auto
+lemma conj_nb0[simp]: "\<lbrakk>bound0 p ; bound0 q\<rbrakk> \<Longrightarrow> bound0 (conj p q)"
+using conj_def by auto
+lemma conj_nb[simp]: "\<lbrakk>bound n p ; bound n q\<rbrakk> \<Longrightarrow> bound n (conj p q)"
+using conj_def by auto
+lemma conj_blt[simp]: "boundslt n p \<Longrightarrow> boundslt n q \<Longrightarrow> boundslt n (conj p q)"
+using conj_def by auto
+
+lemma disj_qf[simp]: "\<lbrakk>qfree p ; qfree q\<rbrakk> \<Longrightarrow> qfree (disj p q)"
+using disj_def by auto
+lemma disj_nb0[simp]: "\<lbrakk>bound0 p ; bound0 q\<rbrakk> \<Longrightarrow> bound0 (disj p q)"
+using disj_def by auto
+lemma disj_nb[simp]: "\<lbrakk>bound n p ; bound n q\<rbrakk> \<Longrightarrow> bound n (disj p q)"
+using disj_def by auto
+lemma disj_blt[simp]: "boundslt n p \<Longrightarrow> boundslt n q \<Longrightarrow> boundslt n (disj p q)"
+using disj_def by auto
+
+lemma imp_qf[simp]: "\<lbrakk>qfree p ; qfree q\<rbrakk> \<Longrightarrow> qfree (imp p q)"
+using imp_def by (cases "p=F \<or> q=T",simp_all add: imp_def)
+lemma imp_nb0[simp]: "\<lbrakk>bound0 p ; bound0 q\<rbrakk> \<Longrightarrow> bound0 (imp p q)"
+using imp_def by (cases "p=F \<or> q=T \<or> p=q",simp_all add: imp_def)
+lemma imp_nb[simp]: "\<lbrakk>bound n p ; bound n q\<rbrakk> \<Longrightarrow> bound n (imp p q)"
+using imp_def by (cases "p=F \<or> q=T \<or> p=q",simp_all add: imp_def)
+lemma imp_blt[simp]: "boundslt n p \<Longrightarrow> boundslt n q \<Longrightarrow> boundslt n (imp p q)"
+using imp_def by auto
+
+lemma iff_qf[simp]: "\<lbrakk>qfree p ; qfree q\<rbrakk> \<Longrightarrow> qfree (iff p q)"
+ by (unfold iff_def,cases "p=q", auto)
+lemma iff_nb0[simp]: "\<lbrakk>bound0 p ; bound0 q\<rbrakk> \<Longrightarrow> bound0 (iff p q)"
+using iff_def by (unfold iff_def,cases "p=q", auto)
+lemma iff_nb[simp]: "\<lbrakk>bound n p ; bound n q\<rbrakk> \<Longrightarrow> bound n (iff p q)"
+using iff_def by (unfold iff_def,cases "p=q", auto)
+lemma iff_blt[simp]: "boundslt n p \<Longrightarrow> boundslt n q \<Longrightarrow> boundslt n (iff p q)"
+using iff_def by auto
+lemma decr0_qf: "bound0 p \<Longrightarrow> qfree (decr0 p)"
+by (induct p, simp_all)
+
+consts
+ isatom :: "fm \<Rightarrow> bool" (* test for atomicity *)
+recdef isatom "measure size"
+ "isatom T = True"
+ "isatom F = True"
+ "isatom (Lt a) = True"
+ "isatom (Le a) = True"
+ "isatom (Eq a) = True"
+ "isatom (NEq a) = True"
+ "isatom p = False"
+
+lemma bound0_qf: "bound0 p \<Longrightarrow> qfree p"
+by (induct p, simp_all)
+
+constdefs djf:: "('a \<Rightarrow> fm) \<Rightarrow> 'a \<Rightarrow> fm \<Rightarrow> fm"
+ "djf f p q \<equiv> (if q=T then T else if q=F then f p else
+ (let fp = f p in case fp of T \<Rightarrow> T | F \<Rightarrow> q | _ \<Rightarrow> Or (f p) q))"
+constdefs evaldjf:: "('a \<Rightarrow> fm) \<Rightarrow> 'a list \<Rightarrow> fm"
+ "evaldjf f ps \<equiv> foldr (djf f) ps F"
+
+lemma djf_Or: "Ifm vs bs (djf f p q) = Ifm vs bs (Or (f p) q)"
+by (cases "q=T", simp add: djf_def,cases "q=F",simp add: djf_def)
+(cases "f p", simp_all add: Let_def djf_def)
+
+lemma evaldjf_ex: "Ifm vs bs (evaldjf f ps) = (\<exists> p \<in> set ps. Ifm vs bs (f p))"
+ by(induct ps, simp_all add: evaldjf_def djf_Or)
+
+lemma evaldjf_bound0:
+ assumes nb: "\<forall> x\<in> set xs. bound0 (f x)"
+ shows "bound0 (evaldjf f xs)"
+ using nb by (induct xs, auto simp add: evaldjf_def djf_def Let_def) (case_tac "f a", auto)
+
+lemma evaldjf_qf:
+ assumes nb: "\<forall> x\<in> set xs. qfree (f x)"
+ shows "qfree (evaldjf f xs)"
+ using nb by (induct xs, auto simp add: evaldjf_def djf_def Let_def) (case_tac "f a", auto)
+
+consts disjuncts :: "fm \<Rightarrow> fm list"
+recdef disjuncts "measure size"
+ "disjuncts (Or p q) = (disjuncts p) @ (disjuncts q)"
+ "disjuncts F = []"
+ "disjuncts p = [p]"
+
+lemma disjuncts: "(\<exists> q\<in> set (disjuncts p). Ifm vs bs q) = Ifm vs bs p"
+by(induct p rule: disjuncts.induct, auto)
+
+lemma disjuncts_nb: "bound0 p \<Longrightarrow> \<forall> q\<in> set (disjuncts p). bound0 q"
+proof-
+ assume nb: "bound0 p"
+ hence "list_all bound0 (disjuncts p)" by (induct p rule:disjuncts.induct,auto)
+ thus ?thesis by (simp only: list_all_iff)
+qed
+
+lemma disjuncts_qf: "qfree p \<Longrightarrow> \<forall> q\<in> set (disjuncts p). qfree q"
+proof-
+ assume qf: "qfree p"
+ hence "list_all qfree (disjuncts p)"
+ by (induct p rule: disjuncts.induct, auto)
+ thus ?thesis by (simp only: list_all_iff)
+qed
+
+constdefs DJ :: "(fm \<Rightarrow> fm) \<Rightarrow> fm \<Rightarrow> fm"
+ "DJ f p \<equiv> evaldjf f (disjuncts p)"
+
+lemma DJ: assumes fdj: "\<forall> p q. Ifm vs bs (f (Or p q)) = Ifm vs bs (Or (f p) (f q))"
+ and fF: "f F = F"
+ shows "Ifm vs bs (DJ f p) = Ifm vs bs (f p)"
+proof-
+ have "Ifm vs bs (DJ f p) = (\<exists> q \<in> set (disjuncts p). Ifm vs bs (f q))"
+ by (simp add: DJ_def evaldjf_ex)
+ also have "\<dots> = Ifm vs bs (f p)" using fdj fF by (induct p rule: disjuncts.induct, auto)
+ finally show ?thesis .
+qed
+
+lemma DJ_qf: assumes
+ fqf: "\<forall> p. qfree p \<longrightarrow> qfree (f p)"
+ shows "\<forall>p. qfree p \<longrightarrow> qfree (DJ f p) "
+proof(clarify)
+ fix p assume qf: "qfree p"
+ have th: "DJ f p = evaldjf f (disjuncts p)" by (simp add: DJ_def)
+ from disjuncts_qf[OF qf] have "\<forall> q\<in> set (disjuncts p). qfree q" .
+ with fqf have th':"\<forall> q\<in> set (disjuncts p). qfree (f q)" by blast
+
+ from evaldjf_qf[OF th'] th show "qfree (DJ f p)" by simp
+qed
+
+lemma DJ_qe: assumes qe: "\<forall> bs p. qfree p \<longrightarrow> qfree (qe p) \<and> (Ifm vs bs (qe p) = Ifm vs bs (E p))"
+ shows "\<forall> bs p. qfree p \<longrightarrow> qfree (DJ qe p) \<and> (Ifm vs bs ((DJ qe p)) = Ifm vs bs (E p))"
+proof(clarify)
+ fix p::fm and bs
+ assume qf: "qfree p"
+ from qe have qth: "\<forall> p. qfree p \<longrightarrow> qfree (qe p)" by blast
+ from DJ_qf[OF qth] qf have qfth:"qfree (DJ qe p)" by auto
+ have "Ifm vs bs (DJ qe p) = (\<exists> q\<in> set (disjuncts p). Ifm vs bs (qe q))"
+ by (simp add: DJ_def evaldjf_ex)
+ also have "\<dots> = (\<exists> q \<in> set(disjuncts p). Ifm vs bs (E q))" using qe disjuncts_qf[OF qf] by auto
+ also have "\<dots> = Ifm vs bs (E p)" by (induct p rule: disjuncts.induct, auto)
+ finally show "qfree (DJ qe p) \<and> Ifm vs bs (DJ qe p) = Ifm vs bs (E p)" using qfth by blast
+qed
+
+consts conjuncts :: "fm \<Rightarrow> fm list"
+
+recdef conjuncts "measure size"
+ "conjuncts (And p q) = (conjuncts p) @ (conjuncts q)"
+ "conjuncts T = []"
+ "conjuncts p = [p]"
+
+constdefs list_conj :: "fm list \<Rightarrow> fm"
+ "list_conj ps \<equiv> foldr conj ps T"
+
+constdefs CJNB:: "(fm \<Rightarrow> fm) \<Rightarrow> fm \<Rightarrow> fm"
+ "CJNB f p \<equiv> (let cjs = conjuncts p ; (yes,no) = partition bound0 cjs
+ in conj (decr0 (list_conj yes)) (f (list_conj no)))"
+
+lemma conjuncts_qf: "qfree p \<Longrightarrow> \<forall> q\<in> set (conjuncts p). qfree q"
+proof-
+ assume qf: "qfree p"
+ hence "list_all qfree (conjuncts p)"
+ by (induct p rule: conjuncts.induct, auto)
+ thus ?thesis by (simp only: list_all_iff)
+qed
+
+lemma conjuncts: "(\<forall> q\<in> set (conjuncts p). Ifm vs bs q) = Ifm vs bs p"
+by(induct p rule: conjuncts.induct, auto)
+
+lemma conjuncts_nb: "bound0 p \<Longrightarrow> \<forall> q\<in> set (conjuncts p). bound0 q"
+proof-
+ assume nb: "bound0 p"
+ hence "list_all bound0 (conjuncts p)" by (induct p rule:conjuncts.induct,auto)
+ thus ?thesis by (simp only: list_all_iff)
+qed
+
+fun islin :: "fm \<Rightarrow> bool" where
+ "islin (And p q) = (islin p \<and> islin q \<and> p \<noteq> T \<and> p \<noteq> F \<and> q \<noteq> T \<and> q \<noteq> F)"
+| "islin (Or p q) = (islin p \<and> islin q \<and> p \<noteq> T \<and> p \<noteq> F \<and> q \<noteq> T \<and> q \<noteq> F)"
+| "islin (Eq (CNP 0 c s)) = (isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s)"
+| "islin (NEq (CNP 0 c s)) = (isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s)"
+| "islin (Lt (CNP 0 c s)) = (isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s)"
+| "islin (Le (CNP 0 c s)) = (isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s)"
+| "islin (NOT p) = False"
+| "islin (Imp p q) = False"
+| "islin (Iff p q) = False"
+| "islin p = bound0 p"
+
+lemma islin_stupid: assumes nb: "tmbound0 p"
+ shows "islin (Lt p)" and "islin (Le p)" and "islin (Eq p)" and "islin (NEq p)"
+ using nb by (cases p, auto, case_tac nat, auto)+
+
+definition "lt p = (case p of CP (C c) \<Rightarrow> if 0>\<^sub>N c then T else F| _ \<Rightarrow> Lt p)"
+definition "le p = (case p of CP (C c) \<Rightarrow> if 0\<ge>\<^sub>N c then T else F | _ \<Rightarrow> Le p)"
+definition "eq p = (case p of CP (C c) \<Rightarrow> if c = 0\<^sub>N then T else F | _ \<Rightarrow> Eq p)"
+definition "neq p = not (eq p)"
+
+lemma lt: "allpolys isnpoly p \<Longrightarrow> Ifm vs bs (lt p) = Ifm vs bs (Lt p)"
+ apply(simp add: lt_def)
+ apply(cases p, simp_all)
+ apply (case_tac poly, simp_all add: isnpoly_def)
+ done
+
+lemma le: "allpolys isnpoly p \<Longrightarrow> Ifm vs bs (le p) = Ifm vs bs (Le p)"
+ apply(simp add: le_def)
+ apply(cases p, simp_all)
+ apply (case_tac poly, simp_all add: isnpoly_def)
+ done
+
+lemma eq: "allpolys isnpoly p \<Longrightarrow> Ifm vs bs (eq p) = Ifm vs bs (Eq p)"
+ apply(simp add: eq_def)
+ apply(cases p, simp_all)
+ apply (case_tac poly, simp_all add: isnpoly_def)
+ done
+
+lemma neq: "allpolys isnpoly p \<Longrightarrow> Ifm vs bs (neq p) = Ifm vs bs (NEq p)"
+ by(simp add: neq_def eq)
+
+lemma lt_lin: "tmbound0 p \<Longrightarrow> islin (lt p)"
+ apply (simp add: lt_def)
+ apply (cases p, simp_all)
+ apply (case_tac poly, simp_all)
+ apply (case_tac nat, simp_all)
+ done
+
+lemma le_lin: "tmbound0 p \<Longrightarrow> islin (le p)"
+ apply (simp add: le_def)
+ apply (cases p, simp_all)
+ apply (case_tac poly, simp_all)
+ apply (case_tac nat, simp_all)
+ done
+
+lemma eq_lin: "tmbound0 p \<Longrightarrow> islin (eq p)"
+ apply (simp add: eq_def)
+ apply (cases p, simp_all)
+ apply (case_tac poly, simp_all)
+ apply (case_tac nat, simp_all)
+ done
+
+lemma neq_lin: "tmbound0 p \<Longrightarrow> islin (neq p)"
+ apply (simp add: neq_def eq_def)
+ apply (cases p, simp_all)
+ apply (case_tac poly, simp_all)
+ apply (case_tac nat, simp_all)
+ done
+
+definition "simplt t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then lt s else Lt (CNP 0 c s))"
+definition "simple t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then le s else Le (CNP 0 c s))"
+definition "simpeq t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then eq s else Eq (CNP 0 c s))"
+definition "simpneq t = (let (c,s) = split0 (simptm t) in if c= 0\<^sub>p then neq s else NEq (CNP 0 c s))"
+
+lemma simplt_islin[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "islin (simplt t)"
+ unfolding simplt_def
+ using split0_nb0'
+by (auto simp add: lt_lin Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly])
+
+lemma simple_islin[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "islin (simple t)"
+ unfolding simple_def
+ using split0_nb0'
+by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] le_lin)
+lemma simpeq_islin[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "islin (simpeq t)"
+ unfolding simpeq_def
+ using split0_nb0'
+by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] eq_lin)
+
+lemma simpneq_islin[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "islin (simpneq t)"
+ unfolding simpneq_def
+ using split0_nb0'
+by (auto simp add: Let_def split_def isnpoly_fst_split0[OF simptm_allpolys_npoly] islin_stupid allpolys_split0[OF simptm_allpolys_npoly] neq_lin)
+
+lemma really_stupid: "\<not> (\<forall>c1 s'. (c1, s') \<noteq> split0 s)"
+ by (cases "split0 s", auto)
+lemma split0_npoly: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and n: "allpolys isnpoly t"
+ shows "isnpoly (fst (split0 t))" and "allpolys isnpoly (snd (split0 t))"
+ using n
+ by (induct t rule: split0.induct, auto simp add: Let_def split_def polyadd_norm polymul_norm polyneg_norm polysub_norm really_stupid)
+lemma simplt[simp]:
+ shows "Ifm vs bs (simplt t) = Ifm vs bs (Lt t)"
+proof-
+ have n: "allpolys isnpoly (simptm t)" by simp
+ let ?t = "simptm t"
+ {assume "fst (split0 ?t) = 0\<^sub>p" hence ?thesis
+ using split0[of "simptm t" vs bs] lt[OF split0_npoly(2)[OF n], of vs bs]
+ by (simp add: simplt_def Let_def split_def lt)}
+ moreover
+ {assume "fst (split0 ?t) \<noteq> 0\<^sub>p"
+ hence ?thesis using split0[of "simptm t" vs bs] by (simp add: simplt_def Let_def split_def)
+ }
+ ultimately show ?thesis by blast
+qed
+
+lemma simple[simp]:
+ shows "Ifm vs bs (simple t) = Ifm vs bs (Le t)"
+proof-
+ have n: "allpolys isnpoly (simptm t)" by simp
+ let ?t = "simptm t"
+ {assume "fst (split0 ?t) = 0\<^sub>p" hence ?thesis
+ using split0[of "simptm t" vs bs] le[OF split0_npoly(2)[OF n], of vs bs]
+ by (simp add: simple_def Let_def split_def le)}
+ moreover
+ {assume "fst (split0 ?t) \<noteq> 0\<^sub>p"
+ hence ?thesis using split0[of "simptm t" vs bs] by (simp add: simple_def Let_def split_def)
+ }
+ ultimately show ?thesis by blast
+qed
+
+lemma simpeq[simp]:
+ shows "Ifm vs bs (simpeq t) = Ifm vs bs (Eq t)"
+proof-
+ have n: "allpolys isnpoly (simptm t)" by simp
+ let ?t = "simptm t"
+ {assume "fst (split0 ?t) = 0\<^sub>p" hence ?thesis
+ using split0[of "simptm t" vs bs] eq[OF split0_npoly(2)[OF n], of vs bs]
+ by (simp add: simpeq_def Let_def split_def)}
+ moreover
+ {assume "fst (split0 ?t) \<noteq> 0\<^sub>p"
+ hence ?thesis using split0[of "simptm t" vs bs] by (simp add: simpeq_def Let_def split_def)
+ }
+ ultimately show ?thesis by blast
+qed
+
+lemma simpneq[simp]:
+ shows "Ifm vs bs (simpneq t) = Ifm vs bs (NEq t)"
+proof-
+ have n: "allpolys isnpoly (simptm t)" by simp
+ let ?t = "simptm t"
+ {assume "fst (split0 ?t) = 0\<^sub>p" hence ?thesis
+ using split0[of "simptm t" vs bs] neq[OF split0_npoly(2)[OF n], of vs bs]
+ by (simp add: simpneq_def Let_def split_def )}
+ moreover
+ {assume "fst (split0 ?t) \<noteq> 0\<^sub>p"
+ hence ?thesis using split0[of "simptm t" vs bs] by (simp add: simpneq_def Let_def split_def)
+ }
+ ultimately show ?thesis by blast
+qed
+
+lemma lt_nb: "tmbound0 t \<Longrightarrow> bound0 (lt t)"
+ apply (simp add: lt_def)
+ apply (cases t, auto)
+ apply (case_tac poly, auto)
+ done
+
+lemma le_nb: "tmbound0 t \<Longrightarrow> bound0 (le t)"
+ apply (simp add: le_def)
+ apply (cases t, auto)
+ apply (case_tac poly, auto)
+ done
+
+lemma eq_nb: "tmbound0 t \<Longrightarrow> bound0 (eq t)"
+ apply (simp add: eq_def)
+ apply (cases t, auto)
+ apply (case_tac poly, auto)
+ done
+
+lemma neq_nb: "tmbound0 t \<Longrightarrow> bound0 (neq t)"
+ apply (simp add: neq_def eq_def)
+ apply (cases t, auto)
+ apply (case_tac poly, auto)
+ done
+
+lemma simplt_nb[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "tmbound0 t \<Longrightarrow> bound0 (simplt t)"
+ using split0 [of "simptm t" vs bs]
+proof(simp add: simplt_def Let_def split_def)
+ assume nb: "tmbound0 t"
+ hence nb': "tmbound0 (simptm t)" by simp
+ let ?c = "fst (split0 (simptm t))"
+ from tmbound_split0[OF nb'[unfolded tmbound0_tmbound_iff[symmetric]]]
+ have th: "\<forall>bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto
+ from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]]
+ have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def)
+ from iffD1[OF isnpolyh_unique[OF ths] th]
+ have "fst (split0 (simptm t)) = 0\<^sub>p" .
+ thus "(fst (split0 (simptm t)) = 0\<^sub>p \<longrightarrow> bound0 (lt (snd (split0 (simptm t))))) \<and>
+ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simplt_def Let_def split_def lt_nb)
+qed
+
+lemma simple_nb[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "tmbound0 t \<Longrightarrow> bound0 (simple t)"
+ using split0 [of "simptm t" vs bs]
+proof(simp add: simple_def Let_def split_def)
+ assume nb: "tmbound0 t"
+ hence nb': "tmbound0 (simptm t)" by simp
+ let ?c = "fst (split0 (simptm t))"
+ from tmbound_split0[OF nb'[unfolded tmbound0_tmbound_iff[symmetric]]]
+ have th: "\<forall>bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto
+ from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]]
+ have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def)
+ from iffD1[OF isnpolyh_unique[OF ths] th]
+ have "fst (split0 (simptm t)) = 0\<^sub>p" .
+ thus "(fst (split0 (simptm t)) = 0\<^sub>p \<longrightarrow> bound0 (le (snd (split0 (simptm t))))) \<and>
+ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simplt_def Let_def split_def le_nb)
+qed
+
+lemma simpeq_nb[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "tmbound0 t \<Longrightarrow> bound0 (simpeq t)"
+ using split0 [of "simptm t" vs bs]
+proof(simp add: simpeq_def Let_def split_def)
+ assume nb: "tmbound0 t"
+ hence nb': "tmbound0 (simptm t)" by simp
+ let ?c = "fst (split0 (simptm t))"
+ from tmbound_split0[OF nb'[unfolded tmbound0_tmbound_iff[symmetric]]]
+ have th: "\<forall>bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto
+ from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]]
+ have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def)
+ from iffD1[OF isnpolyh_unique[OF ths] th]
+ have "fst (split0 (simptm t)) = 0\<^sub>p" .
+ thus "(fst (split0 (simptm t)) = 0\<^sub>p \<longrightarrow> bound0 (eq (snd (split0 (simptm t))))) \<and>
+ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simpeq_def Let_def split_def eq_nb)
+qed
+
+lemma simpneq_nb[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "tmbound0 t \<Longrightarrow> bound0 (simpneq t)"
+ using split0 [of "simptm t" vs bs]
+proof(simp add: simpneq_def Let_def split_def)
+ assume nb: "tmbound0 t"
+ hence nb': "tmbound0 (simptm t)" by simp
+ let ?c = "fst (split0 (simptm t))"
+ from tmbound_split0[OF nb'[unfolded tmbound0_tmbound_iff[symmetric]]]
+ have th: "\<forall>bs. Ipoly bs ?c = Ipoly bs 0\<^sub>p" by auto
+ from isnpoly_fst_split0[OF simptm_allpolys_npoly[of t]]
+ have ths: "isnpolyh ?c 0" "isnpolyh 0\<^sub>p 0" by (simp_all add: isnpoly_def)
+ from iffD1[OF isnpolyh_unique[OF ths] th]
+ have "fst (split0 (simptm t)) = 0\<^sub>p" .
+ thus "(fst (split0 (simptm t)) = 0\<^sub>p \<longrightarrow> bound0 (neq (snd (split0 (simptm t))))) \<and>
+ fst (split0 (simptm t)) = 0\<^sub>p" by (simp add: simpneq_def Let_def split_def neq_nb)
+qed
+
+consts conjs :: "fm \<Rightarrow> fm list"
+recdef conjs "measure size"
+ "conjs (And p q) = (conjs p)@(conjs q)"
+ "conjs T = []"
+ "conjs p = [p]"
+lemma conjs_ci: "(\<forall> q \<in> set (conjs p). Ifm vs bs q) = Ifm vs bs p"
+by (induct p rule: conjs.induct, auto)
+constdefs list_disj :: "fm list \<Rightarrow> fm"
+ "list_disj ps \<equiv> foldr disj ps F"
+
+lemma list_conj: "Ifm vs bs (list_conj ps) = (\<forall>p\<in> set ps. Ifm vs bs p)"
+ by (induct ps, auto simp add: list_conj_def)
+lemma list_conj_qf: " \<forall>p\<in> set ps. qfree p \<Longrightarrow> qfree (list_conj ps)"
+ by (induct ps, auto simp add: list_conj_def conj_qf)
+lemma list_disj: "Ifm vs bs (list_disj ps) = (\<exists>p\<in> set ps. Ifm vs bs p)"
+ by (induct ps, auto simp add: list_disj_def)
+
+lemma conj_boundslt: "boundslt n p \<Longrightarrow> boundslt n q \<Longrightarrow> boundslt n (conj p q)"
+ unfolding conj_def by auto
+
+lemma conjs_nb: "bound n p \<Longrightarrow> \<forall>q\<in> set (conjs p). bound n q"
+ apply (induct p rule: conjs.induct)
+ apply (unfold conjs.simps)
+ apply (unfold set_append)
+ apply (unfold ball_Un)
+ apply (unfold bound.simps)
+ apply auto
+ done
+
+lemma conjs_boundslt: "boundslt n p \<Longrightarrow> \<forall>q\<in> set (conjs p). boundslt n q"
+ apply (induct p rule: conjs.induct)
+ apply (unfold conjs.simps)
+ apply (unfold set_append)
+ apply (unfold ball_Un)
+ apply (unfold boundslt.simps)
+ apply blast
+by simp_all
+
+lemma list_conj_boundslt: " \<forall>p\<in> set ps. boundslt n p \<Longrightarrow> boundslt n (list_conj ps)"
+ unfolding list_conj_def
+ by (induct ps, auto simp add: conj_boundslt)
+
+lemma list_conj_nb: assumes bnd: "\<forall>p\<in> set ps. bound n p"
+ shows "bound n (list_conj ps)"
+ using bnd
+ unfolding list_conj_def
+ by (induct ps, auto simp add: conj_nb)
+
+lemma list_conj_nb': "\<forall>p\<in>set ps. bound0 p \<Longrightarrow> bound0 (list_conj ps)"
+unfolding list_conj_def by (induct ps , auto)
+
+lemma CJNB_qe:
+ assumes qe: "\<forall> bs p. qfree p \<longrightarrow> qfree (qe p) \<and> (Ifm vs bs (qe p) = Ifm vs bs (E p))"
+ shows "\<forall> bs p. qfree p \<longrightarrow> qfree (CJNB qe p) \<and> (Ifm vs bs ((CJNB qe p)) = Ifm vs bs (E p))"
+proof(clarify)
+ fix bs p
+ assume qfp: "qfree p"
+ let ?cjs = "conjuncts p"
+ let ?yes = "fst (partition bound0 ?cjs)"
+ let ?no = "snd (partition bound0 ?cjs)"
+ let ?cno = "list_conj ?no"
+ let ?cyes = "list_conj ?yes"
+ have part: "partition bound0 ?cjs = (?yes,?no)" by simp
+ from partition_P[OF part] have "\<forall> q\<in> set ?yes. bound0 q" by blast
+ hence yes_nb: "bound0 ?cyes" by (simp add: list_conj_nb')
+ hence yes_qf: "qfree (decr0 ?cyes )" by (simp add: decr0_qf)
+ from conjuncts_qf[OF qfp] partition_set[OF part]
+ have " \<forall>q\<in> set ?no. qfree q" by auto
+ hence no_qf: "qfree ?cno"by (simp add: list_conj_qf)
+ with qe have cno_qf:"qfree (qe ?cno )"
+ and noE: "Ifm vs bs (qe ?cno) = Ifm vs bs (E ?cno)" by blast+
+ from cno_qf yes_qf have qf: "qfree (CJNB qe p)"
+ by (simp add: CJNB_def Let_def conj_qf split_def)
+ {fix bs
+ from conjuncts have "Ifm vs bs p = (\<forall>q\<in> set ?cjs. Ifm vs bs q)" by blast
+ also have "\<dots> = ((\<forall>q\<in> set ?yes. Ifm vs bs q) \<and> (\<forall>q\<in> set ?no. Ifm vs bs q))"
+ using partition_set[OF part] by auto
+ finally have "Ifm vs bs p = ((Ifm vs bs ?cyes) \<and> (Ifm vs bs ?cno))" using list_conj[of vs bs] by simp}
+ hence "Ifm vs bs (E p) = (\<exists>x. (Ifm vs (x#bs) ?cyes) \<and> (Ifm vs (x#bs) ?cno))" by simp
+ also have "\<dots> = (\<exists>x. (Ifm vs (y#bs) ?cyes) \<and> (Ifm vs (x#bs) ?cno))"
+ using bound0_I[OF yes_nb, where bs="bs" and b'="y"] by blast
+ also have "\<dots> = (Ifm vs bs (decr0 ?cyes) \<and> Ifm vs bs (E ?cno))"
+ by (auto simp add: decr0[OF yes_nb])
+ also have "\<dots> = (Ifm vs bs (conj (decr0 ?cyes) (qe ?cno)))"
+ using qe[rule_format, OF no_qf] by auto
+ finally have "Ifm vs bs (E p) = Ifm vs bs (CJNB qe p)"
+ by (simp add: Let_def CJNB_def split_def)
+ with qf show "qfree (CJNB qe p) \<and> Ifm vs bs (CJNB qe p) = Ifm vs bs (E p)" by blast
+qed
+
+consts simpfm :: "fm \<Rightarrow> fm"
+recdef simpfm "measure fmsize"
+ "simpfm (Lt t) = simplt (simptm t)"
+ "simpfm (Le t) = simple (simptm t)"
+ "simpfm (Eq t) = simpeq(simptm t)"
+ "simpfm (NEq t) = simpneq(simptm t)"
+ "simpfm (And p q) = conj (simpfm p) (simpfm q)"
+ "simpfm (Or p q) = disj (simpfm p) (simpfm q)"
+ "simpfm (Imp p q) = disj (simpfm (NOT p)) (simpfm q)"
+ "simpfm (Iff p q) = disj (conj (simpfm p) (simpfm q)) (conj (simpfm (NOT p)) (simpfm (NOT q)))"
+ "simpfm (NOT (And p q)) = disj (simpfm (NOT p)) (simpfm (NOT q))"
+ "simpfm (NOT (Or p q)) = conj (simpfm (NOT p)) (simpfm (NOT q))"
+ "simpfm (NOT (Imp p q)) = conj (simpfm p) (simpfm (NOT q))"
+ "simpfm (NOT (Iff p q)) = disj (conj (simpfm p) (simpfm (NOT q))) (conj (simpfm (NOT p)) (simpfm q))"
+ "simpfm (NOT (Eq t)) = simpneq t"
+ "simpfm (NOT (NEq t)) = simpeq t"
+ "simpfm (NOT (Le t)) = simplt (Neg t)"
+ "simpfm (NOT (Lt t)) = simple (Neg t)"
+ "simpfm (NOT (NOT p)) = simpfm p"
+ "simpfm (NOT T) = F"
+ "simpfm (NOT F) = T"
+ "simpfm p = p"
+
+lemma simpfm[simp]: "Ifm vs bs (simpfm p) = Ifm vs bs p"
+by(induct p arbitrary: bs rule: simpfm.induct, auto)
+
+lemma simpfm_bound0: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "bound0 p \<Longrightarrow> bound0 (simpfm p)"
+by (induct p rule: simpfm.induct, auto)
+
+lemma lt_qf[simp]: "qfree (lt t)"
+ apply (cases t, auto simp add: lt_def)
+ by (case_tac poly, auto)
+
+lemma le_qf[simp]: "qfree (le t)"
+ apply (cases t, auto simp add: le_def)
+ by (case_tac poly, auto)
+
+lemma eq_qf[simp]: "qfree (eq t)"
+ apply (cases t, auto simp add: eq_def)
+ by (case_tac poly, auto)
+
+lemma neq_qf[simp]: "qfree (neq t)" by (simp add: neq_def)
+
+lemma simplt_qf[simp]: "qfree (simplt t)" by (simp add: simplt_def Let_def split_def)
+lemma simple_qf[simp]: "qfree (simple t)" by (simp add: simple_def Let_def split_def)
+lemma simpeq_qf[simp]: "qfree (simpeq t)" by (simp add: simpeq_def Let_def split_def)
+lemma simpneq_qf[simp]: "qfree (simpneq t)" by (simp add: simpneq_def Let_def split_def)
+
+lemma simpfm_qf[simp]: "qfree p \<Longrightarrow> qfree (simpfm p)"
+by (induct p rule: simpfm.induct, auto simp add: disj_qf imp_qf iff_qf conj_qf not_qf Let_def)
+
+lemma disj_lin: "islin p \<Longrightarrow> islin q \<Longrightarrow> islin (disj p q)" by (simp add: disj_def)
+lemma conj_lin: "islin p \<Longrightarrow> islin q \<Longrightarrow> islin (conj p q)" by (simp add: conj_def)
+
+lemma assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "qfree p \<Longrightarrow> islin (simpfm p)"
+ apply (induct p rule: simpfm.induct)
+ apply (simp_all add: conj_lin disj_lin)
+ done
+
+consts prep :: "fm \<Rightarrow> fm"
+recdef prep "measure fmsize"
+ "prep (E T) = T"
+ "prep (E F) = F"
+ "prep (E (Or p q)) = disj (prep (E p)) (prep (E q))"
+ "prep (E (Imp p q)) = disj (prep (E (NOT p))) (prep (E q))"
+ "prep (E (Iff p q)) = disj (prep (E (And p q))) (prep (E (And (NOT p) (NOT q))))"
+ "prep (E (NOT (And p q))) = disj (prep (E (NOT p))) (prep (E(NOT q)))"
+ "prep (E (NOT (Imp p q))) = prep (E (And p (NOT q)))"
+ "prep (E (NOT (Iff p q))) = disj (prep (E (And p (NOT q)))) (prep (E(And (NOT p) q)))"
+ "prep (E p) = E (prep p)"
+ "prep (A (And p q)) = conj (prep (A p)) (prep (A q))"
+ "prep (A p) = prep (NOT (E (NOT p)))"
+ "prep (NOT (NOT p)) = prep p"
+ "prep (NOT (And p q)) = disj (prep (NOT p)) (prep (NOT q))"
+ "prep (NOT (A p)) = prep (E (NOT p))"
+ "prep (NOT (Or p q)) = conj (prep (NOT p)) (prep (NOT q))"
+ "prep (NOT (Imp p q)) = conj (prep p) (prep (NOT q))"
+ "prep (NOT (Iff p q)) = disj (prep (And p (NOT q))) (prep (And (NOT p) q))"
+ "prep (NOT p) = not (prep p)"
+ "prep (Or p q) = disj (prep p) (prep q)"
+ "prep (And p q) = conj (prep p) (prep q)"
+ "prep (Imp p q) = prep (Or (NOT p) q)"
+ "prep (Iff p q) = disj (prep (And p q)) (prep (And (NOT p) (NOT q)))"
+ "prep p = p"
+(hints simp add: fmsize_pos)
+lemma prep: "Ifm vs bs (prep p) = Ifm vs bs p"
+by (induct p arbitrary: bs rule: prep.induct, auto)
+
+
+
+ (* Generic quantifier elimination *)
+consts qelim :: "fm \<Rightarrow> (fm \<Rightarrow> fm) \<Rightarrow> fm"
+recdef qelim "measure fmsize"
+ "qelim (E p) = (\<lambda> qe. DJ (CJNB qe) (qelim p qe))"
+ "qelim (A p) = (\<lambda> qe. not (qe ((qelim (NOT p) qe))))"
+ "qelim (NOT p) = (\<lambda> qe. not (qelim p qe))"
+ "qelim (And p q) = (\<lambda> qe. conj (qelim p qe) (qelim q qe))"
+ "qelim (Or p q) = (\<lambda> qe. disj (qelim p qe) (qelim q qe))"
+ "qelim (Imp p q) = (\<lambda> qe. imp (qelim p qe) (qelim q qe))"
+ "qelim (Iff p q) = (\<lambda> qe. iff (qelim p qe) (qelim q qe))"
+ "qelim p = (\<lambda> y. simpfm p)"
+
+
+lemma qelim:
+ assumes qe_inv: "\<forall> bs p. qfree p \<longrightarrow> qfree (qe p) \<and> (Ifm vs bs (qe p) = Ifm vs bs (E p))"
+ shows "\<And> bs. qfree (qelim p qe) \<and> (Ifm vs bs (qelim p qe) = Ifm vs bs p)"
+using qe_inv DJ_qe[OF CJNB_qe[OF qe_inv]]
+by (induct p rule: qelim.induct) auto
+
+subsection{* Core Procedure *}
+
+consts
+ plusinf:: "fm \<Rightarrow> fm" (* Virtual substitution of +\<infinity>*)
+ minusinf:: "fm \<Rightarrow> fm" (* Virtual substitution of -\<infinity>*)
+recdef minusinf "measure size"
+ "minusinf (And p q) = conj (minusinf p) (minusinf q)"
+ "minusinf (Or p q) = disj (minusinf p) (minusinf q)"
+ "minusinf (Eq (CNP 0 c e)) = conj (eq (CP c)) (eq e)"
+ "minusinf (NEq (CNP 0 c e)) = disj (not (eq e)) (not (eq (CP c)))"
+ "minusinf (Lt (CNP 0 c e)) = disj (conj (eq (CP c)) (lt e)) (lt (CP (~\<^sub>p c)))"
+ "minusinf (Le (CNP 0 c e)) = disj (conj (eq (CP c)) (le e)) (lt (CP (~\<^sub>p c)))"
+ "minusinf p = p"
+
+recdef plusinf "measure size"
+ "plusinf (And p q) = conj (plusinf p) (plusinf q)"
+ "plusinf (Or p q) = disj (plusinf p) (plusinf q)"
+ "plusinf (Eq (CNP 0 c e)) = conj (eq (CP c)) (eq e)"
+ "plusinf (NEq (CNP 0 c e)) = disj (not (eq e)) (not (eq (CP c)))"
+ "plusinf (Lt (CNP 0 c e)) = disj (conj (eq (CP c)) (lt e)) (lt (CP c))"
+ "plusinf (Le (CNP 0 c e)) = disj (conj (eq (CP c)) (le e)) (lt (CP c))"
+ "plusinf p = p"
+
+lemma minusinf_inf: assumes lp:"islin p"
+ shows "\<exists>z. \<forall>x < z. Ifm vs (x#bs) (minusinf p) \<longleftrightarrow> Ifm vs (x#bs) p"
+ using lp
+proof (induct p rule: minusinf.induct)
+ case 1 thus ?case by (auto,rule_tac x="min z za" in exI, auto)
+next
+ case 2 thus ?case by (auto,rule_tac x="min z za" in exI, auto)
+next
+ case (3 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case
+ using eq[OF nc(2), of vs] eq[OF nc(1), of vs] by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x < - ?e"
+ using pos_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Eq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x" and vs=vs and bs=bs] by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x > - ?e"
+ using neg_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Eq (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] eqs by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (4 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x < - ?e"
+ using pos_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (NEq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x > - ?e"
+ using neg_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (NEq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (5 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ hence nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm)
+ note eqs = lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] lt[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x < - ?e"
+ using pos_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Lt (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x > - ?e"
+ using neg_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Lt (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] cp by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (6 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ hence nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm)
+ note eqs = lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] le[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x < - ?e"
+ using pos_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Le (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x < -?e / ?c" hence "?c * x > - ?e"
+ using neg_less_divide_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (minusinf (Le (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ ultimately show ?case by blast
+qed (auto)
+
+lemma plusinf_inf: assumes lp:"islin p"
+ shows "\<exists>z. \<forall>x > z. Ifm vs (x#bs) (plusinf p) \<longleftrightarrow> Ifm vs (x#bs) p"
+ using lp
+proof (induct p rule: plusinf.induct)
+ case 1 thus ?case by (auto,rule_tac x="max z za" in exI, auto)
+next
+ case 2 thus ?case by (auto,rule_tac x="max z za" in exI, auto)
+next
+ case (3 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case
+ using eq[OF nc(2), of vs] eq[OF nc(1), of vs] by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x > - ?e"
+ using pos_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Eq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x" and vs=vs and bs=bs] by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x < - ?e"
+ using neg_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Eq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Eq (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] eqs by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (4 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ note eqs = eq[OF nc(1), where ?'a = 'a] eq[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x > - ?e"
+ using pos_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (NEq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x < - ?e"
+ using neg_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (NEq (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (NEq (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (5 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ hence nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm)
+ note eqs = lt[OF nc(1), where ?'a = 'a] lt[OF nc', where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] lt[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x > - ?e"
+ using pos_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Lt (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x < - ?e"
+ using neg_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Lt (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Lt (CNP 0 c e)))"
+ using eqs tmbound0_I[OF nbe, where b="y" and b'="x"] cp by auto} hence ?case by auto}
+ ultimately show ?case by blast
+next
+ case (6 c e) hence nbe: "tmbound0 e" by simp
+ from prems have nc: "allpolys isnpoly (CP c)" "allpolys isnpoly e" by simp_all
+ hence nc': "allpolys isnpoly (CP (~\<^sub>p c))" by (simp add: polyneg_norm)
+ note eqs = lt[OF nc(1), where ?'a = 'a] eq [OF nc(1), where ?'a = 'a] le[OF nc(2), where ?'a = 'a]
+ let ?c = "Ipoly vs c"
+ let ?e = "Itm vs (y#bs) e"
+ have "?c=0 \<or> ?c > 0 \<or> ?c < 0" by arith
+ moreover {assume "?c = 0" hence ?case using eqs by auto}
+ moreover {assume cp: "?c > 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x > - ?e"
+ using pos_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e > 0" by simp
+ hence "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Le (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ moreover {assume cp: "?c < 0"
+ {fix x assume xz: "x > -?e / ?c" hence "?c * x < - ?e"
+ using neg_divide_less_eq[OF cp, where a="x" and b="-?e"] by (simp add: mult_commute)
+ hence "?c * x + ?e < 0" by simp
+ hence "Ifm vs (x#bs) (Le (CNP 0 c e)) = Ifm vs (x#bs) (plusinf (Le (CNP 0 c e)))"
+ using tmbound0_I[OF nbe, where b="y" and b'="x"] cp eqs by auto} hence ?case by auto}
+ ultimately show ?case by blast
+qed (auto)
+
+lemma minusinf_nb: "islin p \<Longrightarrow> bound0 (minusinf p)"
+ by (induct p rule: minusinf.induct, auto simp add: eq_nb lt_nb le_nb)
+lemma plusinf_nb: "islin p \<Longrightarrow> bound0 (plusinf p)"
+ by (induct p rule: minusinf.induct, auto simp add: eq_nb lt_nb le_nb)
+
+lemma minusinf_ex: assumes lp: "islin p" and ex: "Ifm vs (x#bs) (minusinf p)"
+ shows "\<exists>x. Ifm vs (x#bs) p"
+proof-
+ from bound0_I [OF minusinf_nb[OF lp], where b="a" and bs ="bs"] ex
+ have th: "\<forall> x. Ifm vs (x#bs) (minusinf p)" by auto
+ from minusinf_inf[OF lp, where bs="bs"]
+ obtain z where z_def: "\<forall>x<z. Ifm vs (x # bs) (minusinf p) = Ifm vs (x # bs) p" by blast
+ from th have "Ifm vs ((z - 1)#bs) (minusinf p)" by simp
+ moreover have "z - 1 < z" by simp
+ ultimately show ?thesis using z_def by auto
+qed
+
+lemma plusinf_ex: assumes lp: "islin p" and ex: "Ifm vs (x#bs) (plusinf p)"
+ shows "\<exists>x. Ifm vs (x#bs) p"
+proof-
+ from bound0_I [OF plusinf_nb[OF lp], where b="a" and bs ="bs"] ex
+ have th: "\<forall> x. Ifm vs (x#bs) (plusinf p)" by auto
+ from plusinf_inf[OF lp, where bs="bs"]
+ obtain z where z_def: "\<forall>x>z. Ifm vs (x # bs) (plusinf p) = Ifm vs (x # bs) p" by blast
+ from th have "Ifm vs ((z + 1)#bs) (plusinf p)" by simp
+ moreover have "z + 1 > z" by simp
+ ultimately show ?thesis using z_def by auto
+qed
+
+fun uset :: "fm \<Rightarrow> (poly \<times> tm) list" where
+ "uset (And p q) = uset p @ uset q"
+| "uset (Or p q) = uset p @ uset q"
+| "uset (Eq (CNP 0 a e)) = [(a,e)]"
+| "uset (Le (CNP 0 a e)) = [(a,e)]"
+| "uset (Lt (CNP 0 a e)) = [(a,e)]"
+| "uset (NEq (CNP 0 a e)) = [(a,e)]"
+| "uset p = []"
+
+lemma uset_l:
+ assumes lp: "islin p"
+ shows "\<forall> (c,s) \<in> set (uset p). isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s"
+using lp by(induct p rule: uset.induct,auto)
+
+lemma minusinf_uset0:
+ assumes lp: "islin p"
+ and nmi: "\<not> (Ifm vs (x#bs) (minusinf p))"
+ and ex: "Ifm vs (x#bs) p" (is "?I x p")
+ shows "\<exists> (c,s) \<in> set (uset p). x \<ge> - Itm vs (x#bs) s / Ipoly vs c"
+proof-
+ have "\<exists> (c,s) \<in> set (uset p). (Ipoly vs c < 0 \<and> Ipoly vs c * x \<le> - Itm vs (x#bs) s) \<or> (Ipoly vs c > 0 \<and> Ipoly vs c * x \<ge> - Itm vs (x#bs) s)"
+ using lp nmi ex
+ apply (induct p rule: minusinf.induct, auto simp add: eq le lt nth_pos2 polyneg_norm)
+ apply (auto simp add: linorder_not_less order_le_less)
+ done
+ then obtain c s where csU: "(c,s) \<in> set (uset p)" and x: "(Ipoly vs c < 0 \<and> Ipoly vs c * x \<le> - Itm vs (x#bs) s) \<or> (Ipoly vs c > 0 \<and> Ipoly vs c * x \<ge> - Itm vs (x#bs) s)" by blast
+ hence "x \<ge> (- Itm vs (x#bs) s) / Ipoly vs c"
+ using divide_le_eq[of "- Itm vs (x#bs) s" "Ipoly vs c" x]
+ by (auto simp add: mult_commute del: divide_minus_left)
+ thus ?thesis using csU by auto
+qed
+
+lemma minusinf_uset:
+ assumes lp: "islin p"
+ and nmi: "\<not> (Ifm vs (a#bs) (minusinf p))"
+ and ex: "Ifm vs (x#bs) p" (is "?I x p")
+ shows "\<exists> (c,s) \<in> set (uset p). x \<ge> - Itm vs (a#bs) s / Ipoly vs c"
+proof-
+ from nmi have nmi': "\<not> (Ifm vs (x#bs) (minusinf p))"
+ by (simp add: bound0_I[OF minusinf_nb[OF lp], where b=x and b'=a])
+ from minusinf_uset0[OF lp nmi' ex]
+ obtain c s where csU: "(c,s) \<in> set (uset p)" and th: "x \<ge> - Itm vs (x#bs) s / Ipoly vs c" by blast
+ from uset_l[OF lp, rule_format, OF csU] have nb: "tmbound0 s" by simp
+ from th tmbound0_I[OF nb, of vs x bs a] csU show ?thesis by auto
+qed
+
+
+lemma plusinf_uset0:
+ assumes lp: "islin p"
+ and nmi: "\<not> (Ifm vs (x#bs) (plusinf p))"
+ and ex: "Ifm vs (x#bs) p" (is "?I x p")
+ shows "\<exists> (c,s) \<in> set (uset p). x \<le> - Itm vs (x#bs) s / Ipoly vs c"
+proof-
+ have "\<exists> (c,s) \<in> set (uset p). (Ipoly vs c < 0 \<and> Ipoly vs c * x \<ge> - Itm vs (x#bs) s) \<or> (Ipoly vs c > 0 \<and> Ipoly vs c * x \<le> - Itm vs (x#bs) s)"
+ using lp nmi ex
+ apply (induct p rule: minusinf.induct, auto simp add: eq le lt nth_pos2 polyneg_norm)
+ apply (auto simp add: linorder_not_less order_le_less)
+ done
+ then obtain c s where csU: "(c,s) \<in> set (uset p)" and x: "(Ipoly vs c < 0 \<and> Ipoly vs c * x \<ge> - Itm vs (x#bs) s) \<or> (Ipoly vs c > 0 \<and> Ipoly vs c * x \<le> - Itm vs (x#bs) s)" by blast
+ hence "x \<le> (- Itm vs (x#bs) s) / Ipoly vs c"
+ using le_divide_eq[of x "- Itm vs (x#bs) s" "Ipoly vs c"]
+ by (auto simp add: mult_commute del: divide_minus_left)
+ thus ?thesis using csU by auto
+qed
+
+lemma plusinf_uset:
+ assumes lp: "islin p"
+ and nmi: "\<not> (Ifm vs (a#bs) (plusinf p))"
+ and ex: "Ifm vs (x#bs) p" (is "?I x p")
+ shows "\<exists> (c,s) \<in> set (uset p). x \<le> - Itm vs (a#bs) s / Ipoly vs c"
+proof-
+ from nmi have nmi': "\<not> (Ifm vs (x#bs) (plusinf p))"
+ by (simp add: bound0_I[OF plusinf_nb[OF lp], where b=x and b'=a])
+ from plusinf_uset0[OF lp nmi' ex]
+ obtain c s where csU: "(c,s) \<in> set (uset p)" and th: "x \<le> - Itm vs (x#bs) s / Ipoly vs c" by blast
+ from uset_l[OF lp, rule_format, OF csU] have nb: "tmbound0 s" by simp
+ from th tmbound0_I[OF nb, of vs x bs a] csU show ?thesis by auto
+qed
+
+lemma lin_dense:
+ assumes lp: "islin p"
+ and noS: "\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> (\<lambda> (c,t). - Itm vs (x#bs) t / Ipoly vs c) ` set (uset p)"
+ (is "\<forall> t. _ \<and> _ \<longrightarrow> t \<notin> (\<lambda> (c,t). - ?Nt x t / ?N c) ` ?U p")
+ and lx: "l < x" and xu:"x < u" and px:" Ifm vs (x#bs) p"
+ and ly: "l < y" and yu: "y < u"
+ shows "Ifm vs (y#bs) p"
+using lp px noS
+proof (induct p rule: islin.induct)
+ case (5 c s)
+ from "5.prems"
+ have lin: "isnpoly c" "c \<noteq> 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s"
+ and px: "Ifm vs (x # bs) (Lt (CNP 0 c s))"
+ and noS: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<noteq> - Itm vs (x # bs) s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp_all
+ from ly yu noS have yne: "y \<noteq> - ?Nt x s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp
+ hence ycs: "y < - ?Nt x s / ?N c \<or> y > -?Nt x s / ?N c" by auto
+ have ccs: "?N c = 0 \<or> ?N c < 0 \<or> ?N c > 0" by dlo
+ moreover
+ {assume "?N c = 0" hence ?case using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"])}
+ moreover
+ {assume c: "?N c > 0"
+ from px pos_less_divide_eq[OF c, where a="x" and b="-?Nt x s"]
+ have px': "x < - ?Nt x s / ?N c"
+ by (auto simp add: not_less ring_simps)
+ {assume y: "y < - ?Nt x s / ?N c"
+ hence "y * ?N c < - ?Nt x s"
+ by (simp add: pos_less_divide_eq[OF c, where a="y" and b="-?Nt x s", symmetric])
+ hence "?N c * y + ?Nt x s < 0" by (simp add: ring_simps)
+ hence ?case using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp}
+ moreover
+ {assume y: "y > -?Nt x s / ?N c"
+ with yu have eu: "u > - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<le> l" by (cases "- ?Nt x s / ?N c > l", auto)
+ with lx px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ moreover
+ {assume c: "?N c < 0"
+ from px neg_divide_less_eq[OF c, where a="x" and b="-?Nt x s"]
+ have px': "x > - ?Nt x s / ?N c"
+ by (auto simp add: not_less ring_simps)
+ {assume y: "y > - ?Nt x s / ?N c"
+ hence "y * ?N c < - ?Nt x s"
+ by (simp add: neg_divide_less_eq[OF c, where a="y" and b="-?Nt x s", symmetric])
+ hence "?N c * y + ?Nt x s < 0" by (simp add: ring_simps)
+ hence ?case using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp}
+ moreover
+ {assume y: "y < -?Nt x s / ?N c"
+ with ly have eu: "l < - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<ge> u" by (cases "- ?Nt x s / ?N c < u", auto)
+ with xu px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ ultimately show ?case by blast
+next
+ case (6 c s)
+ from "6.prems"
+ have lin: "isnpoly c" "c \<noteq> 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s"
+ and px: "Ifm vs (x # bs) (Le (CNP 0 c s))"
+ and noS: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<noteq> - Itm vs (x # bs) s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp_all
+ from ly yu noS have yne: "y \<noteq> - ?Nt x s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp
+ hence ycs: "y < - ?Nt x s / ?N c \<or> y > -?Nt x s / ?N c" by auto
+ have ccs: "?N c = 0 \<or> ?N c < 0 \<or> ?N c > 0" by dlo
+ moreover
+ {assume "?N c = 0" hence ?case using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"])}
+ moreover
+ {assume c: "?N c > 0"
+ from px pos_le_divide_eq[OF c, where a="x" and b="-?Nt x s"]
+ have px': "x <= - ?Nt x s / ?N c" by (simp add: not_less ring_simps)
+ {assume y: "y < - ?Nt x s / ?N c"
+ hence "y * ?N c < - ?Nt x s"
+ by (simp add: pos_less_divide_eq[OF c, where a="y" and b="-?Nt x s", symmetric])
+ hence "?N c * y + ?Nt x s < 0" by (simp add: ring_simps)
+ hence ?case using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp}
+ moreover
+ {assume y: "y > -?Nt x s / ?N c"
+ with yu have eu: "u > - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<le> l" by (cases "- ?Nt x s / ?N c > l", auto)
+ with lx px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ moreover
+ {assume c: "?N c < 0"
+ from px neg_divide_le_eq[OF c, where a="x" and b="-?Nt x s"]
+ have px': "x >= - ?Nt x s / ?N c" by (simp add: ring_simps)
+ {assume y: "y > - ?Nt x s / ?N c"
+ hence "y * ?N c < - ?Nt x s"
+ by (simp add: neg_divide_less_eq[OF c, where a="y" and b="-?Nt x s", symmetric])
+ hence "?N c * y + ?Nt x s < 0" by (simp add: ring_simps)
+ hence ?case using tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"] by simp}
+ moreover
+ {assume y: "y < -?Nt x s / ?N c"
+ with ly have eu: "l < - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<ge> u" by (cases "- ?Nt x s / ?N c < u", auto)
+ with xu px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ ultimately show ?case by blast
+next
+ case (3 c s)
+ from "3.prems"
+ have lin: "isnpoly c" "c \<noteq> 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s"
+ and px: "Ifm vs (x # bs) (Eq (CNP 0 c s))"
+ and noS: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<noteq> - Itm vs (x # bs) s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp_all
+ from ly yu noS have yne: "y \<noteq> - ?Nt x s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp
+ hence ycs: "y < - ?Nt x s / ?N c \<or> y > -?Nt x s / ?N c" by auto
+ have ccs: "?N c = 0 \<or> ?N c < 0 \<or> ?N c > 0" by dlo
+ moreover
+ {assume "?N c = 0" hence ?case using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"])}
+ moreover
+ {assume c: "?N c > 0" hence cnz: "?N c \<noteq> 0" by simp
+ from px eq_divide_eq[of "x" "-?Nt x s" "?N c"] cnz
+ have px': "x = - ?Nt x s / ?N c" by (simp add: ring_simps)
+ {assume y: "y < -?Nt x s / ?N c"
+ with ly have eu: "l < - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<ge> u" by (cases "- ?Nt x s / ?N c < u", auto)
+ with xu px' have "False" by simp hence ?case by simp }
+ moreover
+ {assume y: "y > -?Nt x s / ?N c"
+ with yu have eu: "u > - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<le> l" by (cases "- ?Nt x s / ?N c > l", auto)
+ with lx px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ moreover
+ {assume c: "?N c < 0" hence cnz: "?N c \<noteq> 0" by simp
+ from px eq_divide_eq[of "x" "-?Nt x s" "?N c"] cnz
+ have px': "x = - ?Nt x s / ?N c" by (simp add: ring_simps)
+ {assume y: "y < -?Nt x s / ?N c"
+ with ly have eu: "l < - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<ge> u" by (cases "- ?Nt x s / ?N c < u", auto)
+ with xu px' have "False" by simp hence ?case by simp }
+ moreover
+ {assume y: "y > -?Nt x s / ?N c"
+ with yu have eu: "u > - ?Nt x s / ?N c" by auto
+ with noS ly yu have th: "- ?Nt x s / ?N c \<le> l" by (cases "- ?Nt x s / ?N c > l", auto)
+ with lx px' have "False" by simp hence ?case by simp }
+ ultimately have ?case using ycs by blast
+ }
+ ultimately show ?case by blast
+next
+ case (4 c s)
+ from "4.prems"
+ have lin: "isnpoly c" "c \<noteq> 0\<^sub>p" "tmbound0 s" "allpolys isnpoly s"
+ and px: "Ifm vs (x # bs) (NEq (CNP 0 c s))"
+ and noS: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<noteq> - Itm vs (x # bs) s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp_all
+ from ly yu noS have yne: "y \<noteq> - ?Nt x s / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" by simp
+ hence ycs: "y < - ?Nt x s / ?N c \<or> y > -?Nt x s / ?N c" by auto
+ have ccs: "?N c = 0 \<or> ?N c \<noteq> 0" by dlo
+ moreover
+ {assume "?N c = 0" hence ?case using px by (simp add: tmbound0_I[OF lin(3), where bs="bs" and b="x" and b'="y"])}
+ moreover
+ {assume c: "?N c \<noteq> 0"
+ from yne c eq_divide_eq[of "y" "- ?Nt x s" "?N c"] have ?case
+ by (simp add: ring_simps tmbound0_I[OF lin(3), of vs x bs y] sum_eq[symmetric]) }
+ ultimately show ?case by blast
+qed (auto simp add: nth_pos2 tmbound0_I[where vs=vs and bs="bs" and b="y" and b'="x"] bound0_I[where vs=vs and bs="bs" and b="y" and b'="x"])
+
+lemma one_plus_one_pos[simp]: "(1::'a::{ordered_field}) + 1 > 0"
+proof-
+ have op: "(1::'a) > 0" by simp
+ from add_pos_pos[OF op op] show ?thesis .
+qed
+
+lemma one_plus_one_nonzero[simp]: "(1::'a::{ordered_field}) + 1 \<noteq> 0"
+ using one_plus_one_pos[where ?'a = 'a] by (simp add: less_le)
+
+lemma half_sum_eq: "(u + u) / (1+1) = (u::'a::{ordered_field})"
+proof-
+ have "(u + u) = (1 + 1) * u" by (simp add: ring_simps)
+ hence "(u + u) / (1+1) = (1 + 1)*u / (1 + 1)" by simp
+ with nonzero_mult_divide_cancel_left[OF one_plus_one_nonzero, of u] show ?thesis by simp
+qed
+
+lemma inf_uset:
+ assumes lp: "islin p"
+ and nmi: "\<not> (Ifm vs (x#bs) (minusinf p))" (is "\<not> (Ifm vs (x#bs) (?M p))")
+ and npi: "\<not> (Ifm vs (x#bs) (plusinf p))" (is "\<not> (Ifm vs (x#bs) (?P p))")
+ and ex: "\<exists> x. Ifm vs (x#bs) p" (is "\<exists> x. ?I x p")
+ shows "\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). ?I ((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) / (1 + 1)) p"
+proof-
+ let ?Nt = "\<lambda> x t. Itm vs (x#bs) t"
+ let ?N = "Ipoly vs"
+ let ?U = "set (uset p)"
+ from ex obtain a where pa: "?I a p" by blast
+ from bound0_I[OF minusinf_nb[OF lp], where bs="bs" and b="x" and b'="a"] nmi
+ have nmi': "\<not> (?I a (?M p))" by simp
+ from bound0_I[OF plusinf_nb[OF lp], where bs="bs" and b="x" and b'="a"] npi
+ have npi': "\<not> (?I a (?P p))" by simp
+ have "\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). ?I ((- ?Nt a t/?N c + - ?Nt a s /?N d) / (1 + 1)) p"
+ proof-
+ let ?M = "(\<lambda> (c,t). - ?Nt a t / ?N c) ` ?U"
+ have fM: "finite ?M" by auto
+ from minusinf_uset[OF lp nmi pa] plusinf_uset[OF lp npi pa]
+ have "\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). a \<le> - ?Nt x t / ?N c \<and> a \<ge> - ?Nt x s / ?N d" by blast
+ then obtain "c" "t" "d" "s" where
+ ctU: "(c,t) \<in> ?U" and dsU: "(d,s) \<in> ?U"
+ and xs1: "a \<le> - ?Nt x s / ?N d" and tx1: "a \<ge> - ?Nt x t / ?N c" by blast
+ from uset_l[OF lp] ctU dsU tmbound0_I[where bs="bs" and b="x" and b'="a"] xs1 tx1
+ have xs: "a \<le> - ?Nt a s / ?N d" and tx: "a \<ge> - ?Nt a t / ?N c" by auto
+ from ctU have Mne: "?M \<noteq> {}" by auto
+ hence Une: "?U \<noteq> {}" by simp
+ let ?l = "Min ?M"
+ let ?u = "Max ?M"
+ have linM: "?l \<in> ?M" using fM Mne by simp
+ have uinM: "?u \<in> ?M" using fM Mne by simp
+ have ctM: "- ?Nt a t / ?N c \<in> ?M" using ctU by auto
+ have dsM: "- ?Nt a s / ?N d \<in> ?M" using dsU by auto
+ have lM: "\<forall> t\<in> ?M. ?l \<le> t" using Mne fM by auto
+ have Mu: "\<forall> t\<in> ?M. t \<le> ?u" using Mne fM by auto
+ have "?l \<le> - ?Nt a t / ?N c" using ctM Mne by simp hence lx: "?l \<le> a" using tx by simp
+ have "- ?Nt a s / ?N d \<le> ?u" using dsM Mne by simp hence xu: "a \<le> ?u" using xs by simp
+ from finite_set_intervals2[where P="\<lambda> x. ?I x p",OF pa lx xu linM uinM fM lM Mu]
+ have "(\<exists> s\<in> ?M. ?I s p) \<or>
+ (\<exists> t1\<in> ?M. \<exists> t2 \<in> ?M. (\<forall> y. t1 < y \<and> y < t2 \<longrightarrow> y \<notin> ?M) \<and> t1 < a \<and> a < t2 \<and> ?I a p)" .
+ moreover {fix u assume um: "u\<in> ?M" and pu: "?I u p"
+ hence "\<exists> (nu,tu) \<in> ?U. u = - ?Nt a tu / ?N nu" by auto
+ then obtain "tu" "nu" where tuU: "(nu,tu) \<in> ?U" and tuu:"u= - ?Nt a tu / ?N nu" by blast
+ from half_sum_eq[of u] pu tuu
+ have "?I (((- ?Nt a tu / ?N nu) + (- ?Nt a tu / ?N nu)) / (1 + 1)) p" by simp
+ with tuU have ?thesis by blast}
+ moreover{
+ assume "\<exists> t1\<in> ?M. \<exists> t2 \<in> ?M. (\<forall> y. t1 < y \<and> y < t2 \<longrightarrow> y \<notin> ?M) \<and> t1 < a \<and> a < t2 \<and> ?I a p"
+ then obtain t1 and t2 where t1M: "t1 \<in> ?M" and t2M: "t2\<in> ?M"
+ and noM: "\<forall> y. t1 < y \<and> y < t2 \<longrightarrow> y \<notin> ?M" and t1x: "t1 < a" and xt2: "a < t2" and px: "?I a p"
+ by blast
+ from t1M have "\<exists> (t1n,t1u) \<in> ?U. t1 = - ?Nt a t1u / ?N t1n" by auto
+ then obtain "t1u" "t1n" where t1uU: "(t1n,t1u) \<in> ?U" and t1u: "t1 = - ?Nt a t1u / ?N t1n" by blast
+ from t2M have "\<exists> (t2n,t2u) \<in> ?U. t2 = - ?Nt a t2u / ?N t2n" by auto
+ then obtain "t2u" "t2n" where t2uU: "(t2n,t2u) \<in> ?U" and t2u: "t2 = - ?Nt a t2u / ?N t2n" by blast
+ from t1x xt2 have t1t2: "t1 < t2" by simp
+ let ?u = "(t1 + t2) / (1 + 1)"
+ from less_half_sum[OF t1t2] gt_half_sum[OF t1t2] have t1lu: "t1 < ?u" and ut2: "?u < t2" by auto
+ from lin_dense[OF lp noM t1x xt2 px t1lu ut2] have "?I ?u p" .
+ with t1uU t2uU t1u t2u have ?thesis by blast}
+ ultimately show ?thesis by blast
+ qed
+ then obtain "l" "n" "s" "m" where lnU: "(n,l) \<in> ?U" and smU:"(m,s) \<in> ?U"
+ and pu: "?I ((- ?Nt a l / ?N n + - ?Nt a s / ?N m) / (1 + 1)) p" by blast
+ from lnU smU uset_l[OF lp] have nbl: "tmbound0 l" and nbs: "tmbound0 s" by auto
+ from tmbound0_I[OF nbl, where bs="bs" and b="a" and b'="x"]
+ tmbound0_I[OF nbs, where bs="bs" and b="a" and b'="x"] pu
+ have "?I ((- ?Nt x l / ?N n + - ?Nt x s / ?N m) / (1 + 1)) p" by simp
+ with lnU smU
+ show ?thesis by auto
+qed
+
+ (* The Ferrante - Rackoff Theorem *)
+
+theorem fr_eq:
+ assumes lp: "islin p"
+ shows "(\<exists> x. Ifm vs (x#bs) p) = ((Ifm vs (x#bs) (minusinf p)) \<or> (Ifm vs (x#bs) (plusinf p)) \<or> (\<exists> (n,t) \<in> set (uset p). \<exists> (m,s) \<in> set (uset p). Ifm vs (((- Itm vs (x#bs) t / Ipoly vs n + - Itm vs (x#bs) s / Ipoly vs m) /(1 + 1))#bs) p))"
+ (is "(\<exists> x. ?I x p) = (?M \<or> ?P \<or> ?F)" is "?E = ?D")
+proof
+ assume px: "\<exists> x. ?I x p"
+ have "?M \<or> ?P \<or> (\<not> ?M \<and> \<not> ?P)" by blast
+ moreover {assume "?M \<or> ?P" hence "?D" by blast}
+ moreover {assume nmi: "\<not> ?M" and npi: "\<not> ?P"
+ from inf_uset[OF lp nmi npi] have "?F" using px by blast hence "?D" by blast}
+ ultimately show "?D" by blast
+next
+ assume "?D"
+ moreover {assume m:"?M" from minusinf_ex[OF lp m] have "?E" .}
+ moreover {assume p: "?P" from plusinf_ex[OF lp p] have "?E" . }
+ moreover {assume f:"?F" hence "?E" by blast}
+ ultimately show "?E" by blast
+qed
+
+section{* First implementation : Naive by encoding all case splits locally *}
+definition "msubsteq c t d s a r =
+ evaldjf (split conj)
+ [(let cd = c *\<^sub>p d in (NEq (CP cd), Eq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (Eq (CP c)) (NEq (CP d)) , Eq (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (NEq (CP c)) (Eq (CP d)) , Eq (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Eq r)]"
+
+lemma msubsteq_nb: assumes lp: "islin (Eq (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s"
+ shows "bound0 (msubsteq c t d s a r)"
+proof-
+ have th: "\<forall>x\<in> set [(let cd = c *\<^sub>p d in (NEq (CP cd), Eq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (Eq (CP c)) (NEq (CP d)) , Eq (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (NEq (CP c)) (Eq (CP d)) , Eq (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Eq r)]. bound0 (split conj x)"
+ using lp by (simp add: Let_def t s )
+ from evaldjf_bound0[OF th] show ?thesis by (simp add: msubsteq_def)
+qed
+
+lemma msubsteq: assumes lp: "islin (Eq (CNP 0 a r))"
+ shows "Ifm vs (x#bs) (msubsteq c t d s a r) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /(1 + 1))#bs) (Eq (CNP 0 a r))" (is "?lhs = ?rhs")
+proof-
+ let ?Nt = "\<lambda>(x::'a) t. Itm vs (x#bs) t"
+ let ?N = "\<lambda>p. Ipoly vs p"
+ let ?c = "?N c"
+ let ?d = "?N d"
+ let ?t = "?Nt x t"
+ let ?s = "?Nt x s"
+ let ?a = "?N a"
+ let ?r = "?Nt x r"
+ from lp have lin:"isnpoly a" "a \<noteq> 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all
+ note r= tmbound0_I[OF lin(3), of vs _ bs x]
+ have cd_cs: "?c * ?d \<noteq> 0 \<or> (?c = 0 \<and> ?d = 0) \<or> (?c = 0 \<and> ?d \<noteq> 0) \<or> (?c \<noteq> 0 \<and> ?d = 0)" by auto
+ moreover
+ {assume c: "?c = 0" and d: "?d=0"
+ hence ?thesis by (simp add: r[of 0] msubsteq_def Let_def evaldjf_ex)}
+ moreover
+ {assume c: "?c = 0" and d: "?d\<noteq>0"
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = -?s / ((1 + 1)*?d)" by simp
+ have "?rhs = Ifm vs (-?s / ((1 + 1)*?d) # bs) (Eq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (-?s / ((1 + 1)*?d)) + ?r = 0" by (simp add: r[of "- (Itm vs (x # bs) s / ((1 + 1) * \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a * (-?s / ((1 + 1)*?d)) + ?r) = 0"
+ using d mult_cancel_left[of "(1 + 1)*?d" "(?a * (-?s / ((1 + 1)*?d)) + ?r)" 0] by simp
+ also have "\<dots> \<longleftrightarrow> (- ?a * ?s) * ((1 + 1)*?d / ((1 + 1)*?d)) + (1 + 1)*?d*?r= 0"
+ by (simp add: ring_simps right_distrib[of "(1 + 1)*?d"] del: right_distrib)
+
+ also have "\<dots> \<longleftrightarrow> - (?a * ?s) + (1 + 1)*?d*?r = 0" using d by simp
+ finally have ?thesis using c d
+ apply (simp add: r[of "- (Itm vs (x # bs) s / ((1 + 1) * \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>))"] msubsteq_def Let_def evaldjf_ex del: one_add_one_is_two)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply simp
+ done}
+ moreover
+ {assume c: "?c \<noteq> 0" and d: "?d=0"
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = -?t / ((1 + 1)*?c)" by simp
+ have "?rhs = Ifm vs (-?t / ((1 + 1)*?c) # bs) (Eq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (-?t / ((1 + 1)*?c)) + ?r = 0" by (simp add: r[of "- (?t/ ((1 + 1)* ?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a * (-?t / ((1 + 1)*?c)) + ?r) = 0"
+ using c mult_cancel_left[of "(1 + 1)*?c" "(?a * (-?t / ((1 + 1)*?c)) + ?r)" 0] by simp
+ also have "\<dots> \<longleftrightarrow> (?a * -?t)* ((1 + 1)*?c) / ((1 + 1)*?c) + (1 + 1)*?c*?r= 0"
+ by (simp add: ring_simps right_distrib[of "(1 + 1)*?c"] del: right_distrib)
+ also have "\<dots> \<longleftrightarrow> - (?a * ?t) + (1 + 1)*?c*?r = 0" using c by simp
+ finally have ?thesis using c d
+ apply (simp add: r[of "- (?t/ ((1 + 1)*?c))"] msubsteq_def Let_def evaldjf_ex del: one_add_one_is_two)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply simp
+ done }
+ moreover
+ {assume c: "?c \<noteq> 0" and d: "?d\<noteq>0" hence dc: "?c * ?d *(1 + 1) \<noteq> 0" by simp
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (Eq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r = 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) =0 "
+ using c d mult_cancel_left[of "(1 + 1) * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r" 0] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + (1 + 1)*?c*?d*?r =0"
+ using nonzero_mult_divide_cancel_left[OF dc] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubsteq_def Let_def evaldjf_ex ring_simps)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply (simp add: ring_simps)
+ done }
+ ultimately show ?thesis by blast
+qed
+
+
+definition "msubstneq c t d s a r =
+ evaldjf (split conj)
+ [(let cd = c *\<^sub>p d in (NEq (CP cd), NEq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (Eq (CP c)) (NEq (CP d)) , NEq (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (NEq (CP c)) (Eq (CP d)) , NEq (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , NEq r)]"
+
+lemma msubstneq_nb: assumes lp: "islin (NEq (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s"
+ shows "bound0 (msubstneq c t d s a r)"
+proof-
+ have th: "\<forall>x\<in> set [(let cd = c *\<^sub>p d in (NEq (CP cd), NEq (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (Eq (CP c)) (NEq (CP d)) , NEq (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (NEq (CP c)) (Eq (CP d)) , NEq (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , NEq r)]. bound0 (split conj x)"
+ using lp by (simp add: Let_def t s )
+ from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstneq_def)
+qed
+
+lemma msubstneq: assumes lp: "islin (Eq (CNP 0 a r))"
+ shows "Ifm vs (x#bs) (msubstneq c t d s a r) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /(1 + 1))#bs) (NEq (CNP 0 a r))" (is "?lhs = ?rhs")
+proof-
+ let ?Nt = "\<lambda>(x::'a) t. Itm vs (x#bs) t"
+ let ?N = "\<lambda>p. Ipoly vs p"
+ let ?c = "?N c"
+ let ?d = "?N d"
+ let ?t = "?Nt x t"
+ let ?s = "?Nt x s"
+ let ?a = "?N a"
+ let ?r = "?Nt x r"
+ from lp have lin:"isnpoly a" "a \<noteq> 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all
+ note r= tmbound0_I[OF lin(3), of vs _ bs x]
+ have cd_cs: "?c * ?d \<noteq> 0 \<or> (?c = 0 \<and> ?d = 0) \<or> (?c = 0 \<and> ?d \<noteq> 0) \<or> (?c \<noteq> 0 \<and> ?d = 0)" by auto
+ moreover
+ {assume c: "?c = 0" and d: "?d=0"
+ hence ?thesis by (simp add: r[of 0] msubstneq_def Let_def evaldjf_ex)}
+ moreover
+ {assume c: "?c = 0" and d: "?d\<noteq>0"
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = -?s / ((1 + 1)*?d)" by simp
+ have "?rhs = Ifm vs (-?s / ((1 + 1)*?d) # bs) (NEq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (-?s / ((1 + 1)*?d)) + ?r \<noteq> 0" by (simp add: r[of "- (Itm vs (x # bs) s / ((1 + 1) * \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a * (-?s / ((1 + 1)*?d)) + ?r) \<noteq> 0"
+ using d mult_cancel_left[of "(1 + 1)*?d" "(?a * (-?s / ((1 + 1)*?d)) + ?r)" 0] by simp
+ also have "\<dots> \<longleftrightarrow> (- ?a * ?s) * ((1 + 1)*?d / ((1 + 1)*?d)) + (1 + 1)*?d*?r\<noteq> 0"
+ by (simp add: ring_simps right_distrib[of "(1 + 1)*?d"] del: right_distrib)
+
+ also have "\<dots> \<longleftrightarrow> - (?a * ?s) + (1 + 1)*?d*?r \<noteq> 0" using d by simp
+ finally have ?thesis using c d
+ apply (simp add: r[of "- (Itm vs (x # bs) s / ((1 + 1) * \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>))"] msubstneq_def Let_def evaldjf_ex del: one_add_one_is_two)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply simp
+ done}
+ moreover
+ {assume c: "?c \<noteq> 0" and d: "?d=0"
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = -?t / ((1 + 1)*?c)" by simp
+ have "?rhs = Ifm vs (-?t / ((1 + 1)*?c) # bs) (NEq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (-?t / ((1 + 1)*?c)) + ?r \<noteq> 0" by (simp add: r[of "- (?t/ ((1 + 1)* ?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a * (-?t / ((1 + 1)*?c)) + ?r) \<noteq> 0"
+ using c mult_cancel_left[of "(1 + 1)*?c" "(?a * (-?t / ((1 + 1)*?c)) + ?r)" 0] by simp
+ also have "\<dots> \<longleftrightarrow> (?a * -?t)* ((1 + 1)*?c) / ((1 + 1)*?c) + (1 + 1)*?c*?r \<noteq> 0"
+ by (simp add: ring_simps right_distrib[of "(1 + 1)*?c"] del: right_distrib)
+ also have "\<dots> \<longleftrightarrow> - (?a * ?t) + (1 + 1)*?c*?r \<noteq> 0" using c by simp
+ finally have ?thesis using c d
+ apply (simp add: r[of "- (?t/ ((1 + 1)*?c))"] msubstneq_def Let_def evaldjf_ex del: one_add_one_is_two)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply simp
+ done }
+ moreover
+ {assume c: "?c \<noteq> 0" and d: "?d\<noteq>0" hence dc: "?c * ?d *(1 + 1) \<noteq> 0" by simp
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (NEq (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r \<noteq> 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) \<noteq> 0 "
+ using c d mult_cancel_left[of "(1 + 1) * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r" 0] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + (1 + 1)*?c*?d*?r \<noteq> 0"
+ using nonzero_mult_divide_cancel_left[OF dc] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubstneq_def Let_def evaldjf_ex ring_simps)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ apply (simp add: ring_simps)
+ done }
+ ultimately show ?thesis by blast
+qed
+
+definition "msubstlt c t d s a r =
+ evaldjf (split conj)
+ [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Lt (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (let cd = c *\<^sub>p d in (lt (CP cd), Lt (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)) , Lt (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP c)) (Eq (CP d)) , Lt (Sub (Mul a t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)) , Lt (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (lt (CP d)) (Eq (CP c)) , Lt (Sub (Mul a s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Lt r)]"
+
+lemma msubstlt_nb: assumes lp: "islin (Lt (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s"
+ shows "bound0 (msubstlt c t d s a r)"
+proof-
+ have th: "\<forall>x\<in> set [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Lt (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (let cd = c *\<^sub>p d in (lt (CP cd), Lt (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)) , Lt (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP c)) (Eq (CP d)) , Lt (Sub (Mul a t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)) , Lt (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (lt (CP d)) (Eq (CP c)) , Lt (Sub (Mul a s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Lt r)]. bound0 (split conj x)"
+ using lp by (simp add: Let_def t s lt_nb )
+ from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstlt_def)
+qed
+
+
+lemma msubstlt: assumes nc: "isnpoly c" and nd: "isnpoly d" and lp: "islin (Lt (CNP 0 a r))"
+ shows "Ifm vs (x#bs) (msubstlt c t d s a r) \<longleftrightarrow>
+ Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /(1 + 1))#bs) (Lt (CNP 0 a r))" (is "?lhs = ?rhs")
+proof-
+ let ?Nt = "\<lambda>x t. Itm vs (x#bs) t"
+ let ?N = "\<lambda>p. Ipoly vs p"
+ let ?c = "?N c"
+ let ?d = "?N d"
+ let ?t = "?Nt x t"
+ let ?s = "?Nt x s"
+ let ?a = "?N a"
+ let ?r = "?Nt x r"
+ from lp have lin:"isnpoly a" "a \<noteq> 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all
+ note r= tmbound0_I[OF lin(3), of vs _ bs x]
+ have cd_cs: "?c * ?d < 0 \<or> ?c * ?d > 0 \<or> (?c = 0 \<and> ?d = 0) \<or> (?c = 0 \<and> ?d < 0) \<or> (?c = 0 \<and> ?d > 0) \<or> (?c < 0 \<and> ?d = 0) \<or> (?c > 0 \<and> ?d = 0)" by auto
+ moreover
+ {assume c: "?c=0" and d: "?d=0"
+ hence ?thesis using nc nd by (simp add: polyneg_norm lt r[of 0] msubstlt_def Let_def evaldjf_ex)}
+ moreover
+ {assume dc: "?c*?d > 0"
+ from mult_pos_pos[OF one_plus_one_pos dc] have dc': "(1 + 1)*?c *?d > 0" by simp
+ hence c:"?c \<noteq> 0" and d: "?d\<noteq> 0" by auto
+ from dc' have dc'': "\<not> (1 + 1)*?c *?d < 0" by simp
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r < 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) < 0"
+
+ using dc' dc'' mult_less_cancel_left_disj[of "(1 + 1) * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r" 0] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + (1 + 1)*?c*?d*?r < 0"
+ using nonzero_mult_divide_cancel_left[of "(1 + 1)*?c*?d"] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using dc c d nc nd dc'
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ by (simp add: ring_simps order_less_not_sym[OF dc])}
+ moreover
+ {assume dc: "?c*?d < 0"
+
+ from dc one_plus_one_pos[where ?'a='a] have dc': "(1 + 1)*?c *?d < 0"
+ apply (simp add: mult_less_0_iff field_simps)
+ apply (rule add_neg_neg)
+ apply (simp_all add: mult_less_0_iff)
+ done
+ hence c:"?c \<noteq> 0" and d: "?d\<noteq> 0" by auto
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r < 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) > 0"
+
+ using dc' order_less_not_sym[OF dc'] mult_less_cancel_left_disj[of "(1 + 1) * ?c * ?d" 0 "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * ((?d * ?t + ?c* ?s )) - (1 + 1)*?c*?d*?r < 0"
+ using nonzero_mult_divide_cancel_left[of "(1 + 1)*?c*?d"] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using dc c d nc nd
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ by (simp add: ring_simps order_less_not_sym[OF dc]) }
+ moreover
+ {assume c: "?c > 0" and d: "?d=0"
+ from c have c'': "(1 + 1)*?c > 0" by (simp add: zero_less_mult_iff)
+ from c have c': "(1 + 1)*?c \<noteq> 0" by simp
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?t / ((1 + 1)*?c)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?t / ((1 + 1)*?c) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?t / ((1 + 1)*?c))+ ?r < 0" by (simp add: r[of "- (?t / ((1 + 1)*?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a* (- ?t / ((1 + 1)*?c))+ ?r) < 0"
+ using c mult_less_cancel_left_disj[of "(1 + 1) * ?c" "?a* (- ?t / ((1 + 1)*?c))+ ?r" 0] c' c'' order_less_not_sym[OF c''] by simp
+ also have "\<dots> \<longleftrightarrow> - ?a*?t+ (1 + 1)*?c *?r < 0"
+ using nonzero_mult_divide_cancel_left[OF c'] c
+ by (simp add: ring_simps diff_divide_distrib less_le del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?t / ((1 + 1)*?c))"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using c order_less_not_sym[OF c] less_imp_neq[OF c]
+ by (simp add: ring_simps ) }
+ moreover
+ {assume c: "?c < 0" and d: "?d=0" hence c': "(1 + 1)*?c \<noteq> 0" by simp
+ from c have c'': "(1 + 1)*?c < 0" by (simp add: mult_less_0_iff)
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?t / ((1 + 1)*?c)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?t / ((1 + 1)*?c) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?t / ((1 + 1)*?c))+ ?r < 0" by (simp add: r[of "- (?t / ((1 + 1)*?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a* (- ?t / ((1 + 1)*?c))+ ?r) > 0"
+ using c order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' mult_less_cancel_left_disj[of "(1 + 1) * ?c" 0 "?a* (- ?t / ((1 + 1)*?c))+ ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a*?t - (1 + 1)*?c *?r < 0"
+ using nonzero_mult_divide_cancel_left[OF c'] c order_less_not_sym[OF c''] less_imp_neq[OF c''] c''
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?t / ((1 + 1)*?c))"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using c order_less_not_sym[OF c] less_imp_neq[OF c]
+ by (simp add: ring_simps ) }
+ moreover
+ moreover
+ {assume c: "?c = 0" and d: "?d>0"
+ from d have d'': "(1 + 1)*?d > 0" by (simp add: zero_less_mult_iff)
+ from d have d': "(1 + 1)*?d \<noteq> 0" by simp
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?s / ((1 + 1)*?d)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?s / ((1 + 1)*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?s / ((1 + 1)*?d))+ ?r < 0" by (simp add: r[of "- (?s / ((1 + 1)*?d))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a* (- ?s / ((1 + 1)*?d))+ ?r) < 0"
+ using d mult_less_cancel_left_disj[of "(1 + 1) * ?d" "?a* (- ?s / ((1 + 1)*?d))+ ?r" 0] d' d'' order_less_not_sym[OF d''] by simp
+ also have "\<dots> \<longleftrightarrow> - ?a*?s+ (1 + 1)*?d *?r < 0"
+ using nonzero_mult_divide_cancel_left[OF d'] d
+ by (simp add: ring_simps diff_divide_distrib less_le del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?s / ((1 + 1)*?d))"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using d order_less_not_sym[OF d] less_imp_neq[OF d]
+ by (simp add: ring_simps ) }
+ moreover
+ {assume c: "?c = 0" and d: "?d<0" hence d': "(1 + 1)*?d \<noteq> 0" by simp
+ from d have d'': "(1 + 1)*?d < 0" by (simp add: mult_less_0_iff)
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?s / ((1 + 1)*?d)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?s / ((1 + 1)*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?s / ((1 + 1)*?d))+ ?r < 0" by (simp add: r[of "- (?s / ((1 + 1)*?d))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a* (- ?s / ((1 + 1)*?d))+ ?r) > 0"
+ using d order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' mult_less_cancel_left_disj[of "(1 + 1) * ?d" 0 "?a* (- ?s / ((1 + 1)*?d))+ ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a*?s - (1 + 1)*?d *?r < 0"
+ using nonzero_mult_divide_cancel_left[OF d'] d order_less_not_sym[OF d''] less_imp_neq[OF d''] d''
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?s / ((1 + 1)*?d))"] msubstlt_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using d order_less_not_sym[OF d] less_imp_neq[OF d]
+ by (simp add: ring_simps ) }
+ultimately show ?thesis by blast
+qed
+
+definition "msubstle c t d s a r =
+ evaldjf (split conj)
+ [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Le (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (let cd = c *\<^sub>p d in (lt (CP cd), Le (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)) , Le (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP c)) (Eq (CP d)) , Le (Sub (Mul a t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)) , Le (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (lt (CP d)) (Eq (CP c)) , Le (Sub (Mul a s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Le r)]"
+
+lemma msubstle_nb: assumes lp: "islin (Le (CNP 0 a r))" and t: "tmbound0 t" and s: "tmbound0 s"
+ shows "bound0 (msubstle c t d s a r)"
+proof-
+ have th: "\<forall>x\<in> set [(let cd = c *\<^sub>p d in (lt (CP (~\<^sub>p cd)), Le (Add (Mul (~\<^sub>p a) (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (let cd = c *\<^sub>p d in (lt (CP cd), Le (Sub (Mul a (Add (Mul d t) (Mul c s))) (Mul (2\<^sub>p *\<^sub>p cd) r)))),
+ (conj (lt (CP (~\<^sub>p c))) (Eq (CP d)) , Le (Add (Mul (~\<^sub>p a) t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP c)) (Eq (CP d)) , Le (Sub (Mul a t) (Mul (2\<^sub>p *\<^sub>p c) r))),
+ (conj (lt (CP (~\<^sub>p d))) (Eq (CP c)) , Le (Add (Mul (~\<^sub>p a) s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (lt (CP d)) (Eq (CP c)) , Le (Sub (Mul a s) (Mul (2\<^sub>p *\<^sub>p d) r))),
+ (conj (Eq (CP c)) (Eq (CP d)) , Le r)]. bound0 (split conj x)"
+ using lp by (simp add: Let_def t s lt_nb )
+ from evaldjf_bound0[OF th] show ?thesis by (simp add: msubstle_def)
+qed
+
+lemma msubstle: assumes nc: "isnpoly c" and nd: "isnpoly d" and lp: "islin (Le (CNP 0 a r))"
+ shows "Ifm vs (x#bs) (msubstle c t d s a r) \<longleftrightarrow>
+ Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /(1 + 1))#bs) (Le (CNP 0 a r))" (is "?lhs = ?rhs")
+proof-
+ let ?Nt = "\<lambda>x t. Itm vs (x#bs) t"
+ let ?N = "\<lambda>p. Ipoly vs p"
+ let ?c = "?N c"
+ let ?d = "?N d"
+ let ?t = "?Nt x t"
+ let ?s = "?Nt x s"
+ let ?a = "?N a"
+ let ?r = "?Nt x r"
+ from lp have lin:"isnpoly a" "a \<noteq> 0\<^sub>p" "tmbound0 r" "allpolys isnpoly r" by simp_all
+ note r= tmbound0_I[OF lin(3), of vs _ bs x]
+ have cd_cs: "?c * ?d < 0 \<or> ?c * ?d > 0 \<or> (?c = 0 \<and> ?d = 0) \<or> (?c = 0 \<and> ?d < 0) \<or> (?c = 0 \<and> ?d > 0) \<or> (?c < 0 \<and> ?d = 0) \<or> (?c > 0 \<and> ?d = 0)" by auto
+ moreover
+ {assume c: "?c=0" and d: "?d=0"
+ hence ?thesis using nc nd by (simp add: polyneg_norm polymul_norm lt r[of 0] msubstle_def Let_def evaldjf_ex)}
+ moreover
+ {assume dc: "?c*?d > 0"
+ from mult_pos_pos[OF one_plus_one_pos dc] have dc': "(1 + 1)*?c *?d > 0" by simp
+ hence c:"?c \<noteq> 0" and d: "?d\<noteq> 0" by auto
+ from dc' have dc'': "\<not> (1 + 1)*?c *?d < 0" by simp
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r <= 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) <= 0"
+
+ using dc' dc'' mult_le_cancel_left[of "(1 + 1) * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r" 0] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + (1 + 1)*?c*?d*?r <= 0"
+ using nonzero_mult_divide_cancel_left[of "(1 + 1)*?c*?d"] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using dc c d nc nd dc'
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ by (simp add: ring_simps order_less_not_sym[OF dc])}
+ moreover
+ {assume dc: "?c*?d < 0"
+
+ from dc one_plus_one_pos[where ?'a='a] have dc': "(1 + 1)*?c *?d < 0"
+ by (simp add: mult_less_0_iff field_simps add_neg_neg add_pos_pos)
+ hence c:"?c \<noteq> 0" and d: "?d\<noteq> 0" by auto
+ from add_frac_eq[OF c d, of "- ?t" "- ?s"]
+ have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)"
+ by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r <= 0"
+ by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"])
+
+ also have "\<dots> \<longleftrightarrow> ((1 + 1) * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ ((1 + 1)*?c*?d)) + ?r) >= 0"
+
+ using dc' order_less_not_sym[OF dc'] mult_le_cancel_left[of "(1 + 1) * ?c * ?d" 0 "?a * (- (?d * ?t + ?c* ?s)/ ((1 + 1)*?c*?d)) + ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a * ((?d * ?t + ?c* ?s )) - (1 + 1)*?c*?d*?r <= 0"
+ using nonzero_mult_divide_cancel_left[of "(1 + 1)*?c*?d"] c d
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using dc c d nc nd
+ apply (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / ((1 + 1) * ?c * ?d)"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ by (simp add: ring_simps order_less_not_sym[OF dc]) }
+ moreover
+ {assume c: "?c > 0" and d: "?d=0"
+ from c have c'': "(1 + 1)*?c > 0" by (simp add: zero_less_mult_iff)
+ from c have c': "(1 + 1)*?c \<noteq> 0" by simp
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?t / ((1 + 1)*?c)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?t / ((1 + 1)*?c) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?t / ((1 + 1)*?c))+ ?r <= 0" by (simp add: r[of "- (?t / ((1 + 1)*?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a* (- ?t / ((1 + 1)*?c))+ ?r) <= 0"
+ using c mult_le_cancel_left[of "(1 + 1) * ?c" "?a* (- ?t / ((1 + 1)*?c))+ ?r" 0] c' c'' order_less_not_sym[OF c''] by simp
+ also have "\<dots> \<longleftrightarrow> - ?a*?t+ (1 + 1)*?c *?r <= 0"
+ using nonzero_mult_divide_cancel_left[OF c'] c
+ by (simp add: ring_simps diff_divide_distrib less_le del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?t / ((1 + 1)*?c))"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using c order_less_not_sym[OF c] less_imp_neq[OF c]
+ by (simp add: ring_simps ) }
+ moreover
+ {assume c: "?c < 0" and d: "?d=0" hence c': "(1 + 1)*?c \<noteq> 0" by simp
+ from c have c'': "(1 + 1)*?c < 0" by (simp add: mult_less_0_iff)
+ from d have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?t / ((1 + 1)*?c)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?t / ((1 + 1)*?c) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?t / ((1 + 1)*?c))+ ?r <= 0" by (simp add: r[of "- (?t / ((1 + 1)*?c))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?c * (?a* (- ?t / ((1 + 1)*?c))+ ?r) >= 0"
+ using c order_less_not_sym[OF c''] less_imp_neq[OF c''] c'' mult_le_cancel_left[of "(1 + 1) * ?c" 0 "?a* (- ?t / ((1 + 1)*?c))+ ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a*?t - (1 + 1)*?c *?r <= 0"
+ using nonzero_mult_divide_cancel_left[OF c'] c order_less_not_sym[OF c''] less_imp_neq[OF c''] c''
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?t / ((1 + 1)*?c))"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using c order_less_not_sym[OF c] less_imp_neq[OF c]
+ by (simp add: ring_simps ) }
+ moreover
+ moreover
+ {assume c: "?c = 0" and d: "?d>0"
+ from d have d'': "(1 + 1)*?d > 0" by (simp add: zero_less_mult_iff)
+ from d have d': "(1 + 1)*?d \<noteq> 0" by simp
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?s / ((1 + 1)*?d)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?s / ((1 + 1)*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?s / ((1 + 1)*?d))+ ?r <= 0" by (simp add: r[of "- (?s / ((1 + 1)*?d))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a* (- ?s / ((1 + 1)*?d))+ ?r) <= 0"
+ using d mult_le_cancel_left[of "(1 + 1) * ?d" "?a* (- ?s / ((1 + 1)*?d))+ ?r" 0] d' d'' order_less_not_sym[OF d''] by simp
+ also have "\<dots> \<longleftrightarrow> - ?a*?s+ (1 + 1)*?d *?r <= 0"
+ using nonzero_mult_divide_cancel_left[OF d'] d
+ by (simp add: ring_simps diff_divide_distrib less_le del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?s / ((1 + 1)*?d))"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using d order_less_not_sym[OF d] less_imp_neq[OF d]
+ by (simp add: ring_simps ) }
+ moreover
+ {assume c: "?c = 0" and d: "?d<0" hence d': "(1 + 1)*?d \<noteq> 0" by simp
+ from d have d'': "(1 + 1)*?d < 0" by (simp add: mult_less_0_iff)
+ from c have th: "(- ?t / ?c + - ?s / ?d)/(1 + 1) = - ?s / ((1 + 1)*?d)" by (simp add: ring_simps)
+ have "?rhs \<longleftrightarrow> Ifm vs (- ?s / ((1 + 1)*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
+ also have "\<dots> \<longleftrightarrow> ?a* (- ?s / ((1 + 1)*?d))+ ?r <= 0" by (simp add: r[of "- (?s / ((1 + 1)*?d))"])
+ also have "\<dots> \<longleftrightarrow> (1 + 1)*?d * (?a* (- ?s / ((1 + 1)*?d))+ ?r) >= 0"
+ using d order_less_not_sym[OF d''] less_imp_neq[OF d''] d'' mult_le_cancel_left[of "(1 + 1) * ?d" 0 "?a* (- ?s / ((1 + 1)*?d))+ ?r"] by simp
+ also have "\<dots> \<longleftrightarrow> ?a*?s - (1 + 1)*?d *?r <= 0"
+ using nonzero_mult_divide_cancel_left[OF d'] d order_less_not_sym[OF d''] less_imp_neq[OF d''] d''
+ by (simp add: ring_simps diff_divide_distrib del: left_distrib)
+ finally have ?thesis using c d nc nd
+ apply(simp add: r[of "- (?s / ((1 + 1)*?d))"] msubstle_def Let_def evaldjf_ex ring_simps lt polyneg_norm polymul_norm)
+ apply (simp only: one_add_one_is_two[symmetric] of_int_add)
+ using d order_less_not_sym[OF d] less_imp_neq[OF d]
+ by (simp add: ring_simps ) }
+ultimately show ?thesis by blast
+qed
+
+
+fun msubst :: "fm \<Rightarrow> (poly \<times> tm) \<times> (poly \<times> tm) \<Rightarrow> fm" where
+ "msubst (And p q) ((c,t), (d,s)) = conj (msubst p ((c,t),(d,s))) (msubst q ((c,t),(d,s)))"
+| "msubst (Or p q) ((c,t), (d,s)) = disj (msubst p ((c,t),(d,s))) (msubst q ((c,t), (d,s)))"
+| "msubst (Eq (CNP 0 a r)) ((c,t),(d,s)) = msubsteq c t d s a r"
+| "msubst (NEq (CNP 0 a r)) ((c,t),(d,s)) = msubstneq c t d s a r"
+| "msubst (Lt (CNP 0 a r)) ((c,t),(d,s)) = msubstlt c t d s a r"
+| "msubst (Le (CNP 0 a r)) ((c,t),(d,s)) = msubstle c t d s a r"
+| "msubst p ((c,t),(d,s)) = p"
+
+lemma msubst_I: assumes lp: "islin p" and nc: "isnpoly c" and nd: "isnpoly d"
+ shows "Ifm vs (x#bs) (msubst p ((c,t),(d,s))) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /(1 + 1))#bs) p"
+ using lp
+by (induct p rule: islin.induct, auto simp add: tmbound0_I[where b="(- (Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>) + - (Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>)) /(1 + 1)" and b'=x and bs = bs and vs=vs] bound0_I[where b="(- (Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>) + - (Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>)) /(1 + 1)" and b'=x and bs = bs and vs=vs] msubsteq msubstneq msubstlt[OF nc nd] msubstle[OF nc nd])
+
+lemma msubst_nb: assumes lp: "islin p" and t: "tmbound0 t" and s: "tmbound0 s"
+ shows "bound0 (msubst p ((c,t),(d,s)))"
+ using lp t s
+ by (induct p rule: islin.induct, auto simp add: msubsteq_nb msubstneq_nb msubstlt_nb msubstle_nb)
+
+lemma fr_eq_msubst:
+ assumes lp: "islin p"
+ shows "(\<exists> x. Ifm vs (x#bs) p) = ((Ifm vs (x#bs) (minusinf p)) \<or> (Ifm vs (x#bs) (plusinf p)) \<or> (\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). Ifm vs (x#bs) (msubst p ((c,t),(d,s)))))"
+ (is "(\<exists> x. ?I x p) = (?M \<or> ?P \<or> ?F)" is "?E = ?D")
+proof-
+from uset_l[OF lp] have th: "\<forall>(c, s)\<in>set (uset p). isnpoly c \<and> tmbound0 s" by blast
+{fix c t d s assume ctU: "(c,t) \<in>set (uset p)" and dsU: "(d,s) \<in>set (uset p)"
+ and pts: "Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1+1) # bs) p"
+ from th[rule_format, OF ctU] th[rule_format, OF dsU] have norm:"isnpoly c" "isnpoly d" by simp_all
+ from msubst_I[OF lp norm, of vs x bs t s] pts
+ have "Ifm vs (x # bs) (msubst p ((c, t), d, s))" ..}
+moreover
+{fix c t d s assume ctU: "(c,t) \<in>set (uset p)" and dsU: "(d,s) \<in>set (uset p)"
+ and pts: "Ifm vs (x # bs) (msubst p ((c, t), d, s))"
+ from th[rule_format, OF ctU] th[rule_format, OF dsU] have norm:"isnpoly c" "isnpoly d" by simp_all
+ from msubst_I[OF lp norm, of vs x bs t s] pts
+ have "Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1+1) # bs) p" ..}
+ultimately have th': "(\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1+1) # bs) p) \<longleftrightarrow> ?F" by blast
+from fr_eq[OF lp, of vs bs x, simplified th'] show ?thesis .
+qed
+
+text {* Rest of the implementation *}
+
+consts alluopairs:: "'a list \<Rightarrow> ('a \<times> 'a) list"
+primrec
+ "alluopairs [] = []"
+ "alluopairs (x#xs) = (map (Pair x) (x#xs))@(alluopairs xs)"
+
+lemma alluopairs_set1: "set (alluopairs xs) \<le> {(x,y). x\<in> set xs \<and> y\<in> set xs}"
+by (induct xs, auto)
+
+lemma alluopairs_set:
+ "\<lbrakk>x\<in> set xs ; y \<in> set xs\<rbrakk> \<Longrightarrow> (x,y) \<in> set (alluopairs xs) \<or> (y,x) \<in> set (alluopairs xs) "
+by (induct xs, auto)
+
+lemma alluopairs_ex:
+ assumes Pc: "\<forall> x \<in> set xs. \<forall>y\<in> set xs. P x y = P y x"
+ shows "(\<exists> x \<in> set xs. \<exists> y \<in> set xs. P x y) = (\<exists> (x,y) \<in> set (alluopairs xs). P x y)"
+proof
+ assume "\<exists>x\<in>set xs. \<exists>y\<in>set xs. P x y"
+ then obtain x y where x: "x \<in> set xs" and y:"y \<in> set xs" and P: "P x y" by blast
+ from alluopairs_set[OF x y] P Pc x y show"\<exists>(x, y)\<in>set (alluopairs xs). P x y"
+ by auto
+next
+ assume "\<exists>(x, y)\<in>set (alluopairs xs). P x y"
+ then obtain "x" and "y" where xy:"(x,y) \<in> set (alluopairs xs)" and P: "P x y" by blast+
+ from xy have "x \<in> set xs \<and> y\<in> set xs" using alluopairs_set1 by blast
+ with P show "\<exists>x\<in>set xs. \<exists>y\<in>set xs. P x y" by blast
+qed
+
+lemma nth_pos2: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"
+using Nat.gr0_conv_Suc
+by clarsimp
+
+lemma filter_length: "length (List.filter P xs) < Suc (length xs)"
+ apply (induct xs, auto) done
+
+consts remdps:: "'a list \<Rightarrow> 'a list"
+
+recdef remdps "measure size"
+ "remdps [] = []"
+ "remdps (x#xs) = (x#(remdps (List.filter (\<lambda> y. y \<noteq> x) xs)))"
+(hints simp add: filter_length[rule_format])
+
+lemma remdps_set[simp]: "set (remdps xs) = set xs"
+ by (induct xs rule: remdps.induct, auto)
+
+lemma simpfm_lin: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "qfree p \<Longrightarrow> islin (simpfm p)"
+ by (induct p rule: simpfm.induct, auto simp add: conj_lin disj_lin)
+
+definition
+ "ferrack p \<equiv> let q = simpfm p ; mp = minusinf q ; pp = plusinf q
+ in if (mp = T \<or> pp = T) then T
+ else (let U = alluopairs (remdps (uset q))
+ in decr0 (disj mp (disj pp (evaldjf (simpfm o (msubst q)) U ))))"
+
+lemma ferrack:
+ assumes qf: "qfree p"
+ shows "qfree (ferrack p) \<and> ((Ifm vs bs (ferrack p)) = (Ifm vs bs (E p)))"
+ (is "_ \<and> (?rhs = ?lhs)")
+proof-
+ let ?I = "\<lambda> x p. Ifm vs (x#bs) p"
+ let ?N = "\<lambda> t. Ipoly vs t"
+ let ?Nt = "\<lambda>x t. Itm vs (x#bs) t"
+ let ?q = "simpfm p"
+ let ?U = "remdps(uset ?q)"
+ let ?Up = "alluopairs ?U"
+ let ?mp = "minusinf ?q"
+ let ?pp = "plusinf ?q"
+ let ?I = "\<lambda>p. Ifm vs (x#bs) p"
+ from simpfm_lin[OF qf] simpfm_qf[OF qf] have lq: "islin ?q" and q_qf: "qfree ?q" .
+ from minusinf_nb[OF lq] plusinf_nb[OF lq] have mp_nb: "bound0 ?mp" and pp_nb: "bound0 ?pp" .
+ from bound0_qf[OF mp_nb] bound0_qf[OF pp_nb] have mp_qf: "qfree ?mp" and pp_qf: "qfree ?pp" .
+ from uset_l[OF lq] have U_l: "\<forall>(c, s)\<in>set ?U. isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s"
+ by simp
+ {fix c t d s assume ctU: "(c,t) \<in> set ?U" and dsU: "(d,s) \<in> set ?U"
+ from U_l ctU dsU have norm: "isnpoly c" "isnpoly d" by auto
+ from msubst_I[OF lq norm, of vs x bs t s] msubst_I[OF lq norm(2,1), of vs x bs s t]
+ have "?I (msubst ?q ((c,t),(d,s))) = ?I (msubst ?q ((d,s),(c,t)))" by (simp add: ring_simps)}
+ hence th0: "\<forall>x \<in> set ?U. \<forall>y \<in> set ?U. ?I (msubst ?q (x, y)) \<longleftrightarrow> ?I (msubst ?q (y, x))" by clarsimp
+ {fix x assume xUp: "x \<in> set ?Up"
+ then obtain c t d s where ctU: "(c,t) \<in> set ?U" and dsU: "(d,s) \<in> set ?U"
+ and x: "x = ((c,t),(d,s))" using alluopairs_set1[of ?U] by auto
+ from U_l[rule_format, OF ctU] U_l[rule_format, OF dsU]
+ have nbs: "tmbound0 t" "tmbound0 s" by simp_all
+ from simpfm_bound0[OF msubst_nb[OF lq nbs, of c d]]
+ have "bound0 ((simpfm o (msubst (simpfm p))) x)" using x by simp}
+ with evaldjf_bound0[of ?Up "(simpfm o (msubst (simpfm p)))"]
+ have "bound0 (evaldjf (simpfm o (msubst (simpfm p))) ?Up)" by blast
+ with mp_nb pp_nb
+ have th1: "bound0 (disj ?mp (disj ?pp (evaldjf (simpfm o (msubst ?q)) ?Up )))" by (simp add: disj_nb)
+ from decr0_qf[OF th1] have thqf: "qfree (ferrack p)" by (simp add: ferrack_def Let_def)
+ have "?lhs \<longleftrightarrow> (\<exists>x. Ifm vs (x#bs) ?q)" by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> (\<exists>(c, t)\<in>set ?U. \<exists>(d, s)\<in>set ?U. ?I (msubst (simpfm p) ((c, t), d, s)))" using fr_eq_msubst[OF lq, of vs bs x] by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> (\<exists> (x,y) \<in> set ?Up. ?I ((simpfm o (msubst ?q)) (x,y)))" using alluopairs_ex[OF th0] by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> ?I (evaldjf (simpfm o (msubst ?q)) ?Up)"
+ by (simp add: evaldjf_ex)
+ also have "\<dots> \<longleftrightarrow> ?I (disj ?mp (disj ?pp (evaldjf (simpfm o (msubst ?q)) ?Up)))" by simp
+ also have "\<dots> \<longleftrightarrow> ?rhs" using decr0[OF th1, of vs x bs]
+ apply (simp add: ferrack_def Let_def)
+ by (cases "?mp = T \<or> ?pp = T", auto)
+ finally show ?thesis using thqf by blast
+qed
+
+definition "frpar p = simpfm (qelim p ferrack)"
+lemma frpar: "qfree (frpar p) \<and> (Ifm vs bs (frpar p) \<longleftrightarrow> Ifm vs bs p)"
+proof-
+ from ferrack have th: "\<forall>bs p. qfree p \<longrightarrow> qfree (ferrack p) \<and> Ifm vs bs (ferrack p) = Ifm vs bs (E p)" by blast
+ from qelim[OF th, of p bs] show ?thesis unfolding frpar_def by auto
+qed
+
+declare polyadd.simps[code]
+lemma [simp,code]: "polyadd (CN c n p, CN c' n' p') =
+ (if n < n' then CN (polyadd(c,CN c' n' p')) n p
+ else if n'<n then CN (polyadd(CN c n p, c')) n' p'
+ else (let cc' = polyadd (c,c') ;
+ pp' = polyadd (p,p')
+ in (if pp' = 0\<^sub>p then cc' else CN cc' n pp')))"
+ by (simp add: Let_def stupid)
+
+
+
+(*
+lemmas [code func] = polysub_def
+lemmas [code func del] = Zero_nat_def
+code_gen "frpar" in SML to FRParTest
+*)
+
+section{* Second implemenation: Case splits not local *}
+
+lemma fr_eq2: assumes lp: "islin p"
+ shows "(\<exists> x. Ifm vs (x#bs) p) \<longleftrightarrow>
+ ((Ifm vs (x#bs) (minusinf p)) \<or> (Ifm vs (x#bs) (plusinf p)) \<or>
+ (Ifm vs (0#bs) p) \<or>
+ (\<exists> (n,t) \<in> set (uset p). Ipoly vs n \<noteq> 0 \<and> Ifm vs ((- Itm vs (x#bs) t / (Ipoly vs n * (1 + 1)))#bs) p) \<or>
+ (\<exists> (n,t) \<in> set (uset p). \<exists> (m,s) \<in> set (uset p). Ipoly vs n \<noteq> 0 \<and> Ipoly vs m \<noteq> 0 \<and> Ifm vs (((- Itm vs (x#bs) t / Ipoly vs n + - Itm vs (x#bs) s / Ipoly vs m) /(1 + 1))#bs) p))"
+ (is "(\<exists> x. ?I x p) = (?M \<or> ?P \<or> ?Z \<or> ?U \<or> ?F)" is "?E = ?D")
+proof
+ assume px: "\<exists> x. ?I x p"
+ have "?M \<or> ?P \<or> (\<not> ?M \<and> \<not> ?P)" by blast
+ moreover {assume "?M \<or> ?P" hence "?D" by blast}
+ moreover {assume nmi: "\<not> ?M" and npi: "\<not> ?P"
+ from inf_uset[OF lp nmi npi, OF px]
+ obtain c t d s where ct: "(c,t) \<in> set (uset p)" "(d,s) \<in> set (uset p)" "?I ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / ((1\<Colon>'a) + (1\<Colon>'a))) p"
+ by auto
+ let ?c = "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>"
+ let ?d = "\<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>"
+ let ?s = "Itm vs (x # bs) s"
+ let ?t = "Itm vs (x # bs) t"
+ have eq2: "\<And>(x::'a). x + x = (1 + 1) * x"
+ by (simp add: ring_simps)
+ {assume "?c = 0 \<and> ?d = 0"
+ with ct have ?D by simp}
+ moreover
+ {assume z: "?c = 0" "?d \<noteq> 0"
+ from z have ?D using ct by auto}
+ moreover
+ {assume z: "?c \<noteq> 0" "?d = 0"
+ with ct have ?D by auto }
+ moreover
+ {assume z: "?c \<noteq> 0" "?d \<noteq> 0"
+ from z have ?F using ct
+ apply - apply (rule bexI[where x = "(c,t)"], simp_all)
+ by (rule bexI[where x = "(d,s)"], simp_all)
+ hence ?D by blast}
+ ultimately have ?D by auto}
+ ultimately show "?D" by blast
+next
+ assume "?D"
+ moreover {assume m:"?M" from minusinf_ex[OF lp m] have "?E" .}
+ moreover {assume p: "?P" from plusinf_ex[OF lp p] have "?E" . }
+ moreover {assume f:"?F" hence "?E" by blast}
+ ultimately show "?E" by blast
+qed
+
+definition "msubsteq2 c t a b = Eq (Add (Mul a t) (Mul c b))"
+definition "msubstltpos c t a b = Lt (Add (Mul a t) (Mul c b))"
+definition "msubstlepos c t a b = Le (Add (Mul a t) (Mul c b))"
+definition "msubstltneg c t a b = Lt (Neg (Add (Mul a t) (Mul c b)))"
+definition "msubstleneg c t a b = Le (Neg (Add (Mul a t) (Mul c b)))"
+
+lemma msubsteq2:
+ assumes nz: "Ipoly vs c \<noteq> 0" and l: "islin (Eq (CNP 0 a b))"
+ shows "Ifm vs (x#bs) (msubsteq2 c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Eq (CNP 0 a b))" (is "?lhs = ?rhs")
+ using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" , symmetric]
+ by (simp add: msubsteq2_def field_simps)
+
+lemma msubstltpos:
+ assumes nz: "Ipoly vs c > 0" and l: "islin (Lt (CNP 0 a b))"
+ shows "Ifm vs (x#bs) (msubstltpos c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Lt (CNP 0 a b))" (is "?lhs = ?rhs")
+ using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" , symmetric]
+ by (simp add: msubstltpos_def field_simps)
+
+lemma msubstlepos:
+ assumes nz: "Ipoly vs c > 0" and l: "islin (Le (CNP 0 a b))"
+ shows "Ifm vs (x#bs) (msubstlepos c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Le (CNP 0 a b))" (is "?lhs = ?rhs")
+ using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" , symmetric]
+ by (simp add: msubstlepos_def field_simps)
+
+lemma msubstltneg:
+ assumes nz: "Ipoly vs c < 0" and l: "islin (Lt (CNP 0 a b))"
+ shows "Ifm vs (x#bs) (msubstltneg c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Lt (CNP 0 a b))" (is "?lhs = ?rhs")
+ using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" , symmetric]
+ by (simp add: msubstltneg_def field_simps del: minus_add_distrib)
+
+lemma msubstleneg:
+ assumes nz: "Ipoly vs c < 0" and l: "islin (Le (CNP 0 a b))"
+ shows "Ifm vs (x#bs) (msubstleneg c t a b) = Ifm vs (((Itm vs (x#bs) t / Ipoly vs c ))#bs) (Le (CNP 0 a b))" (is "?lhs = ?rhs")
+ using nz l tmbound0_I[of b vs x bs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" , symmetric]
+ by (simp add: msubstleneg_def field_simps del: minus_add_distrib)
+
+fun msubstpos :: "fm \<Rightarrow> poly \<Rightarrow> tm \<Rightarrow> fm" where
+ "msubstpos (And p q) c t = And (msubstpos p c t) (msubstpos q c t)"
+| "msubstpos (Or p q) c t = Or (msubstpos p c t) (msubstpos q c t)"
+| "msubstpos (Eq (CNP 0 a r)) c t = msubsteq2 c t a r"
+| "msubstpos (NEq (CNP 0 a r)) c t = NOT (msubsteq2 c t a r)"
+| "msubstpos (Lt (CNP 0 a r)) c t = msubstltpos c t a r"
+| "msubstpos (Le (CNP 0 a r)) c t = msubstlepos c t a r"
+| "msubstpos p c t = p"
+
+lemma msubstpos_I:
+ assumes lp: "islin p" and pos: "Ipoly vs c > 0"
+ shows "Ifm vs (x#bs) (msubstpos p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p"
+ using lp pos
+ by (induct p rule: islin.induct, auto simp add: msubsteq2 msubstltpos[OF pos] msubstlepos[OF pos] tmbound0_I[of _ vs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" bs x] bound0_I[of _ vs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" bs x] field_simps)
+
+fun msubstneg :: "fm \<Rightarrow> poly \<Rightarrow> tm \<Rightarrow> fm" where
+ "msubstneg (And p q) c t = And (msubstneg p c t) (msubstneg q c t)"
+| "msubstneg (Or p q) c t = Or (msubstneg p c t) (msubstneg q c t)"
+| "msubstneg (Eq (CNP 0 a r)) c t = msubsteq2 c t a r"
+| "msubstneg (NEq (CNP 0 a r)) c t = NOT (msubsteq2 c t a r)"
+| "msubstneg (Lt (CNP 0 a r)) c t = msubstltneg c t a r"
+| "msubstneg (Le (CNP 0 a r)) c t = msubstleneg c t a r"
+| "msubstneg p c t = p"
+
+lemma msubstneg_I:
+ assumes lp: "islin p" and pos: "Ipoly vs c < 0"
+ shows "Ifm vs (x#bs) (msubstneg p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p"
+ using lp pos
+ by (induct p rule: islin.induct, auto simp add: msubsteq2 msubstltneg[OF pos] msubstleneg[OF pos] tmbound0_I[of _ vs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" bs x] bound0_I[of _ vs "Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>" bs x] field_simps)
+
+
+definition "msubst2 p c t = disj (conj (lt (CP (polyneg c))) (simpfm (msubstpos p c t))) (conj (lt (CP c)) (simpfm (msubstneg p c t)))"
+
+lemma msubst2: assumes lp: "islin p" and nc: "isnpoly c" and nz: "Ipoly vs c \<noteq> 0"
+ shows "Ifm vs (x#bs) (msubst2 p c t) = Ifm vs (Itm vs (x#bs) t / Ipoly vs c #bs) p"
+proof-
+ let ?c = "Ipoly vs c"
+ from nc have anc: "allpolys isnpoly (CP c)" "allpolys isnpoly (CP (~\<^sub>p c))"
+ by (simp_all add: polyneg_norm)
+ from nz have "?c > 0 \<or> ?c < 0" by arith
+ moreover
+ {assume c: "?c < 0"
+ from c msubstneg_I[OF lp c, of x bs t] lt[OF anc(1), of vs "x#bs"] lt[OF anc(2), of vs "x#bs"]
+ have ?thesis by (auto simp add: msubst2_def)}
+ moreover
+ {assume c: "?c > 0"
+ from c msubstpos_I[OF lp c, of x bs t] lt[OF anc(1), of vs "x#bs"] lt[OF anc(2), of vs "x#bs"]
+ have ?thesis by (auto simp add: msubst2_def)}
+ ultimately show ?thesis by blast
+qed
+
+term msubsteq2
+lemma msubsteq2_nb: "tmbound0 t \<Longrightarrow> islin (Eq (CNP 0 a r)) \<Longrightarrow> bound0 (msubsteq2 c t a r)"
+ by (simp add: msubsteq2_def)
+
+lemma msubstltpos_nb: "tmbound0 t \<Longrightarrow> islin (Lt (CNP 0 a r)) \<Longrightarrow> bound0 (msubstltpos c t a r)"
+ by (simp add: msubstltpos_def)
+lemma msubstltneg_nb: "tmbound0 t \<Longrightarrow> islin (Lt (CNP 0 a r)) \<Longrightarrow> bound0 (msubstltneg c t a r)"
+ by (simp add: msubstltneg_def)
+
+lemma msubstlepos_nb: "tmbound0 t \<Longrightarrow> islin (Le (CNP 0 a r)) \<Longrightarrow> bound0 (msubstlepos c t a r)"
+ by (simp add: msubstlepos_def)
+lemma msubstleneg_nb: "tmbound0 t \<Longrightarrow> islin (Le (CNP 0 a r)) \<Longrightarrow> bound0 (msubstleneg c t a r)"
+ by (simp add: msubstleneg_def)
+
+lemma msubstpos_nb: assumes lp: "islin p" and tnb: "tmbound0 t"
+ shows "bound0 (msubstpos p c t)"
+using lp tnb
+by (induct p c t rule: msubstpos.induct, auto simp add: msubsteq2_nb msubstltpos_nb msubstlepos_nb)
+
+lemma msubstneg_nb: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})" and lp: "islin p" and tnb: "tmbound0 t"
+ shows "bound0 (msubstneg p c t)"
+using lp tnb
+by (induct p c t rule: msubstneg.induct, auto simp add: msubsteq2_nb msubstltneg_nb msubstleneg_nb)
+
+lemma msubst2_nb: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})" and lp: "islin p" and tnb: "tmbound0 t"
+ shows "bound0 (msubst2 p c t)"
+using lp tnb
+by (simp add: msubst2_def msubstneg_nb msubstpos_nb conj_nb disj_nb lt_nb simpfm_bound0)
+
+lemma of_int2: "of_int 2 = 1 + 1"
+proof-
+ have "(2::int) = 1 + 1" by simp
+ hence "of_int 2 = of_int (1 + 1)" by simp
+ thus ?thesis unfolding of_int_add by simp
+qed
+
+lemma of_int_minus2: "of_int (-2) = - (1 + 1)"
+proof-
+ have th: "(-2::int) = - 2" by simp
+ show ?thesis unfolding th by (simp only: of_int_minus of_int2)
+qed
+
+
+lemma islin_qf: "islin p \<Longrightarrow> qfree p"
+ by (induct p rule: islin.induct, auto simp add: bound0_qf)
+lemma fr_eq_msubst2:
+ assumes lp: "islin p"
+ shows "(\<exists> x. Ifm vs (x#bs) p) \<longleftrightarrow> ((Ifm vs (x#bs) (minusinf p)) \<or> (Ifm vs (x#bs) (plusinf p)) \<or> Ifm vs (x#bs) (subst0 (CP 0\<^sub>p) p) \<or> (\<exists>(n, t)\<in>set (uset p). Ifm vs (x# bs) (msubst2 p (n *\<^sub>p (C (-2,1))) t)) \<or> (\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))))"
+ (is "(\<exists> x. ?I x p) = (?M \<or> ?P \<or> ?Pz \<or> ?PU \<or> ?F)" is "?E = ?D")
+proof-
+ from uset_l[OF lp] have th: "\<forall>(c, s)\<in>set (uset p). isnpoly c \<and> tmbound0 s" by blast
+ let ?I = "\<lambda>p. Ifm vs (x#bs) p"
+ have n2: "isnpoly (C (-2,1))" by (simp add: isnpoly_def)
+ note eq0 = subst0[OF islin_qf[OF lp], of vs x bs "CP 0\<^sub>p", simplified]
+
+ have eq1: "(\<exists>(n, t)\<in>set (uset p). ?I (msubst2 p (n *\<^sub>p (C (-2,1))) t)) \<longleftrightarrow> (\<exists>(n, t)\<in>set (uset p). \<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> Ifm vs (- Itm vs (x # bs) t / (\<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> * (1 + 1)) # bs) p)"
+ proof-
+ {fix n t assume H: "(n, t)\<in>set (uset p)" "?I(msubst2 p (n *\<^sub>p C (-2, 1)) t)"
+ from H(1) th have "isnpoly n" by blast
+ hence nn: "isnpoly (n *\<^sub>p (C (-2,1)))" by (simp_all add: polymul_norm n2)
+ have nn': "allpolys isnpoly (CP (~\<^sub>p (n *\<^sub>p C (-2, 1))))"
+ by (simp add: polyneg_norm nn)
+ hence nn2: "\<lparr>n *\<^sub>p(C (-2,1)) \<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>n \<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" using H(2) nn' nn
+ by (auto simp add: msubst2_def lt zero_less_mult_iff mult_less_0_iff)
+ from msubst2[OF lp nn nn2(1), of x bs t]
+ have "\<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> Ifm vs (- Itm vs (x # bs) t / (\<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> * (1 + 1)) # bs) p"
+ using H(2) nn2 by (simp add: of_int_minus2 del: minus_add_distrib)}
+ moreover
+ {fix n t assume H: "(n, t)\<in>set (uset p)" "\<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "Ifm vs (- Itm vs (x # bs) t / (\<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> * (1 + 1)) # bs) p"
+ from H(1) th have "isnpoly n" by blast
+ hence nn: "isnpoly (n *\<^sub>p (C (-2,1)))" "\<lparr>n *\<^sub>p(C (-2,1)) \<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
+ using H(2) by (simp_all add: polymul_norm n2)
+ from msubst2[OF lp nn, of x bs t] have "?I (msubst2 p (n *\<^sub>p (C (-2,1))) t)" using H(2,3) by (simp add: of_int_minus2 del: minus_add_distrib)}
+ ultimately show ?thesis by blast
+ qed
+ have eq2: "(\<exists> (c,t) \<in> set (uset p). \<exists> (d,s) \<in> set (uset p). Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))) \<longleftrightarrow> (\<exists>(n, t)\<in>set (uset p).
+ \<exists>(m, s)\<in>set (uset p). \<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> \<lparr>m\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> Ifm vs ((- Itm vs (x # bs) t / \<lparr>n\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>m\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1 + 1) # bs) p)"
+ proof-
+ {fix c t d s assume H: "(c,t) \<in> set (uset p)" "(d,s) \<in> set (uset p)"
+ "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))"
+ from H(1,2) th have "isnpoly c" "isnpoly d" by blast+
+ hence nn: "isnpoly (C (-2, 1) *\<^sub>p c*\<^sub>p d)"
+ by (simp_all add: polymul_norm n2)
+ have stupid: "allpolys isnpoly (CP (~\<^sub>p (C (-2, 1) *\<^sub>p c *\<^sub>p d)))" "allpolys isnpoly (CP ((C (-2, 1) *\<^sub>p c *\<^sub>p d)))"
+ by (simp_all add: polyneg_norm nn)
+ have nn': "\<lparr>(C (-2, 1) *\<^sub>p c*\<^sub>p d)\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
+ using H(3) by (auto simp add: msubst2_def lt[OF stupid(1)] lt[OF stupid(2)] zero_less_mult_iff mult_less_0_iff)
+ from msubst2[OF lp nn nn'(1), of x bs ] H(3) nn'
+ have "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1 + 1) # bs) p"
+ apply (simp add: add_divide_distrib of_int_minus2 del: minus_add_distrib)
+ by (simp add: mult_commute)}
+ moreover
+ {fix c t d s assume H: "(c,t) \<in> set (uset p)" "(d,s) \<in> set (uset p)"
+ "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / (1 + 1) # bs) p"
+ from H(1,2) th have "isnpoly c" "isnpoly d" by blast+
+ hence nn: "isnpoly (C (-2, 1) *\<^sub>p c*\<^sub>p d)" "\<lparr>(C (-2, 1) *\<^sub>p c*\<^sub>p d)\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
+ using H(3,4) by (simp_all add: polymul_norm n2)
+ from msubst2[OF lp nn, of x bs ] H(3,4,5)
+ have "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))" apply (simp add: add_divide_distrib of_int_minus2 del: minus_add_distrib)by (simp add: mult_commute)}
+ ultimately show ?thesis by blast
+ qed
+ from fr_eq2[OF lp, of vs bs x] show ?thesis
+ unfolding eq0 eq1 eq2 by blast
+qed
+
+definition
+"ferrack2 p \<equiv> let q = simpfm p ; mp = minusinf q ; pp = plusinf q
+ in if (mp = T \<or> pp = T) then T
+ else (let U = remdps (uset q)
+ in decr0 (list_disj [mp, pp, simpfm (subst0 (CP 0\<^sub>p) q), evaldjf (\<lambda>(c,t). msubst2 q (c *\<^sub>p C (-2, 1)) t) U,
+ evaldjf (\<lambda>((b,a),(d,c)). msubst2 q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) (alluopairs U)]))"
+
+definition "frpar2 p = simpfm (qelim (prep p) ferrack2)"
+
+lemma ferrack2: assumes qf: "qfree p"
+ shows "qfree (ferrack2 p) \<and> ((Ifm vs bs (ferrack2 p)) = (Ifm vs bs (E p)))"
+ (is "_ \<and> (?rhs = ?lhs)")
+proof-
+ let ?J = "\<lambda> x p. Ifm vs (x#bs) p"
+ let ?N = "\<lambda> t. Ipoly vs t"
+ let ?Nt = "\<lambda>x t. Itm vs (x#bs) t"
+ let ?q = "simpfm p"
+ let ?qz = "subst0 (CP 0\<^sub>p) ?q"
+ let ?U = "remdps(uset ?q)"
+ let ?Up = "alluopairs ?U"
+ let ?mp = "minusinf ?q"
+ let ?pp = "plusinf ?q"
+ let ?I = "\<lambda>p. Ifm vs (x#bs) p"
+ from simpfm_lin[OF qf] simpfm_qf[OF qf] have lq: "islin ?q" and q_qf: "qfree ?q" .
+ from minusinf_nb[OF lq] plusinf_nb[OF lq] have mp_nb: "bound0 ?mp" and pp_nb: "bound0 ?pp" .
+ from bound0_qf[OF mp_nb] bound0_qf[OF pp_nb] have mp_qf: "qfree ?mp" and pp_qf: "qfree ?pp" .
+ from uset_l[OF lq] have U_l: "\<forall>(c, s)\<in>set ?U. isnpoly c \<and> c \<noteq> 0\<^sub>p \<and> tmbound0 s \<and> allpolys isnpoly s"
+ by simp
+ have bnd0: "\<forall>x \<in> set ?U. bound0 ((\<lambda>(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) x)"
+ proof-
+ {fix c t assume ct: "(c,t) \<in> set ?U"
+ hence tnb: "tmbound0 t" using U_l by blast
+ from msubst2_nb[OF lq tnb]
+ have "bound0 ((\<lambda>(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) (c,t))" by simp}
+ thus ?thesis by auto
+ qed
+ have bnd1: "\<forall>x \<in> set ?Up. bound0 ((\<lambda>((b,a),(d,c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) x)"
+ proof-
+ {fix b a d c assume badc: "((b,a),(d,c)) \<in> set ?Up"
+ from badc U_l alluopairs_set1[of ?U]
+ have nb: "tmbound0 (Add (Mul d a) (Mul b c))" by auto
+ from msubst2_nb[OF lq nb] have "bound0 ((\<lambda>((b,a),(d,c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) ((b,a),(d,c)))" by simp}
+ thus ?thesis by auto
+ qed
+ have stupid: "bound0 F" by simp
+ let ?R = "list_disj [?mp, ?pp, simpfm (subst0 (CP 0\<^sub>p) ?q), evaldjf (\<lambda>(c,t). msubst2 ?q (c *\<^sub>p C (-2, 1)) t) ?U,
+ evaldjf (\<lambda>((b,a),(d,c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) (alluopairs ?U)]"
+ from subst0_nb[of "CP 0\<^sub>p" ?q] q_qf evaldjf_bound0[OF bnd1] evaldjf_bound0[OF bnd0] mp_nb pp_nb stupid
+ have nb: "bound0 ?R "
+ by (simp add: list_disj_def disj_nb0 simpfm_bound0)
+ let ?s = "\<lambda>((b,a),(d,c)). msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))"
+
+ {fix b a d c assume baU: "(b,a) \<in> set ?U" and dcU: "(d,c) \<in> set ?U"
+ from U_l baU dcU have norm: "isnpoly b" "isnpoly d" "isnpoly (C (-2, 1))"
+ by auto (simp add: isnpoly_def)
+ have norm2: "isnpoly (C (-2, 1) *\<^sub>p b*\<^sub>p d)" "isnpoly (C (-2, 1) *\<^sub>p d*\<^sub>p b)"
+ using norm by (simp_all add: polymul_norm)
+ have stupid: "allpolys isnpoly (CP (C (-2, 1) *\<^sub>p b*\<^sub>p d))" "allpolys isnpoly (CP (C (-2, 1) *\<^sub>p d*\<^sub>p b))" "allpolys isnpoly (CP (~\<^sub>p(C (-2, 1) *\<^sub>p b*\<^sub>p d)))" "allpolys isnpoly (CP (~\<^sub>p(C (-2, 1) *\<^sub>p d*\<^sub>p b)))"
+ by (simp_all add: polyneg_norm norm2)
+ have "?I (msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))) = ?I (msubst2 ?q (C (-2, 1) *\<^sub>p d*\<^sub>p b) (Add (Mul b c) (Mul d a)))" (is "?lhs \<longleftrightarrow> ?rhs")
+ proof
+ assume H: ?lhs
+ hence z: "\<lparr>C (-2, 1) *\<^sub>p b *\<^sub>p d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>C (-2, 1) *\<^sub>p d *\<^sub>p b\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
+ by (auto simp add: msubst2_def lt[OF stupid(3)] lt[OF stupid(1)] mult_less_0_iff zero_less_mult_iff)
+ from msubst2[OF lq norm2(1) z(1), of x bs]
+ msubst2[OF lq norm2(2) z(2), of x bs] H
+ show ?rhs by (simp add: ring_simps)
+ next
+ assume H: ?rhs
+ hence z: "\<lparr>C (-2, 1) *\<^sub>p b *\<^sub>p d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>C (-2, 1) *\<^sub>p d *\<^sub>p b\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
+ by (auto simp add: msubst2_def lt[OF stupid(4)] lt[OF stupid(2)] mult_less_0_iff zero_less_mult_iff)
+ from msubst2[OF lq norm2(1) z(1), of x bs]
+ msubst2[OF lq norm2(2) z(2), of x bs] H
+ show ?lhs by (simp add: ring_simps)
+ qed}
+ hence th0: "\<forall>x \<in> set ?U. \<forall>y \<in> set ?U. ?I (?s (x, y)) \<longleftrightarrow> ?I (?s (y, x))"
+ by clarsimp
+
+ have "?lhs \<longleftrightarrow> (\<exists>x. Ifm vs (x#bs) ?q)" by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> ?I (subst0 (CP 0\<^sub>p) ?q) \<or> (\<exists>(n,t) \<in> set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \<or> (\<exists>(b, a)\<in>set ?U. \<exists>(d, c)\<in>set ?U. ?I (msubst2 ?q (C (-2, 1) *\<^sub>p b*\<^sub>p d) (Add (Mul d a) (Mul b c))))"
+ using fr_eq_msubst2[OF lq, of vs bs x] by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> ?I (subst0 (CP 0\<^sub>p) ?q) \<or> (\<exists>(n,t) \<in> set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \<or> (\<exists> x\<in>set ?U. \<exists> y \<in>set ?U. ?I (?s (x,y)))"
+ by (simp add: split_def)
+ also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> ?I (subst0 (CP 0\<^sub>p) ?q) \<or> (\<exists>(n,t) \<in> set ?U. ?I (msubst2 ?q (n *\<^sub>p C (-2, 1)) t)) \<or> (\<exists> (x,y) \<in> set ?Up. ?I (?s (x,y)))"
+ using alluopairs_ex[OF th0] by simp
+ also have "\<dots> \<longleftrightarrow> ?I ?R"
+ by (simp add: list_disj_def evaldjf_ex split_def)
+ also have "\<dots> \<longleftrightarrow> ?rhs"
+ unfolding ferrack2_def
+ apply (cases "?mp = T")
+ apply (simp add: list_disj_def)
+ apply (cases "?pp = T")
+ apply (simp add: list_disj_def)
+ by (simp_all add: Let_def decr0[OF nb])
+ finally show ?thesis using decr0_qf[OF nb]
+ by (simp add: ferrack2_def Let_def)
+qed
+
+lemma frpar2: "qfree (frpar2 p) \<and> (Ifm vs bs (frpar2 p) \<longleftrightarrow> Ifm vs bs p)"
+proof-
+ from ferrack2 have th: "\<forall>bs p. qfree p \<longrightarrow> qfree (ferrack2 p) \<and> Ifm vs bs (ferrack2 p) = Ifm vs bs (E p)" by blast
+ from qelim[OF th, of "prep p" bs]
+show ?thesis unfolding frpar2_def by (auto simp add: prep)
+qed
+
+code_module FRPar
+ contains
+ frpar = "frpar"
+ frpar2 = "frpar2"
+ test = "%x . frpar (E(Lt (Mul 1\<^sub>p (Bound 0))))"
+
+ML{*
+
+structure ReflectedFRPar =
+struct
+
+val bT = HOLogic.boolT;
+fun num rT x = HOLogic.mk_number rT x;
+fun rrelT rT = [rT,rT] ---> rT;
+fun rrT rT = [rT, rT] ---> bT;
+fun divt rT = Const(@{const_name "HOL.divide"},rrelT rT);
+fun timest rT = Const(@{const_name "HOL.times"},rrelT rT);
+fun plust rT = Const(@{const_name "HOL.plus"},rrelT rT);
+fun minust rT = Const(@{const_name "HOL.minus"},rrelT rT);
+fun uminust rT = Const(@{const_name "HOL.uminus"}, rT --> rT);
+fun powt rT = Const(@{const_name "power"}, [rT,@{typ "nat"}] ---> rT);
+val brT = [bT, bT] ---> bT;
+val nott = @{term "Not"};
+val conjt = @{term "op &"};
+val disjt = @{term "op |"};
+val impt = @{term "op -->"};
+val ifft = @{term "op = :: bool => _"}
+fun llt rT = Const(@{const_name "HOL.less"},rrT rT);
+fun lle rT = Const(@{const_name "HOL.less"},rrT rT);
+fun eqt rT = Const("op =",rrT rT);
+fun rz rT = Const(@{const_name "HOL.zero"},rT);
+
+fun dest_nat t = case t of
+ Const ("Suc",_)$t' => 1 + dest_nat t'
+| _ => (snd o HOLogic.dest_number) t;
+
+fun num_of_term m t =
+ case t of
+ Const(@{const_name "uminus"},_)$t => FRPar.Neg (num_of_term m t)
+ | Const(@{const_name "HOL.plus"},_)$a$b => FRPar.Add (num_of_term m a, num_of_term m b)
+ | Const(@{const_name "HOL.minus"},_)$a$b => FRPar.Sub (num_of_term m a, num_of_term m b)
+ | Const(@{const_name "HOL.times"},_)$a$b => FRPar.Mul (num_of_term m a, num_of_term m b)
+ | Const(@{const_name "power"},_)$a$n => FRPar.Pw (num_of_term m a, dest_nat n)
+ | Const(@{const_name "HOL.divide"},_)$a$b => FRPar.C (HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
+ | _ => (FRPar.C (HOLogic.dest_number t |> snd,1)
+ handle TERM _ => FRPar.Bound (AList.lookup (op aconv) m t |> the));
+
+fun tm_of_term m m' t =
+ case t of
+ Const(@{const_name "uminus"},_)$t => FRPar.tm_Neg (tm_of_term m m' t)
+ | Const(@{const_name "HOL.plus"},_)$a$b => FRPar.tm_Add (tm_of_term m m' a, tm_of_term m m' b)
+ | Const(@{const_name "HOL.minus"},_)$a$b => FRPar.tm_Sub (tm_of_term m m' a, tm_of_term m m' b)
+ | Const(@{const_name "HOL.times"},_)$a$b => FRPar.tm_Mul (num_of_term m' a, tm_of_term m m' b)
+ | _ => (FRPar.CP (num_of_term m' t)
+ handle TERM _ => FRPar.tm_Bound (AList.lookup (op aconv) m t |> the)
+ | Option => FRPar.tm_Bound (AList.lookup (op aconv) m t |> the));
+
+fun term_of_num T m t =
+ case t of
+ FRPar.C (a,b) => (if b = 1 then num T a else if b=0 then (rz T)
+ else (divt T) $ num T a $ num T b)
+| FRPar.Bound i => AList.lookup (op = : int*int -> bool) m i |> the
+| FRPar.Add(a,b) => (plust T)$(term_of_num T m a)$(term_of_num T m b)
+| FRPar.Mul(a,b) => (timest T)$(term_of_num T m a)$(term_of_num T m b)
+| FRPar.Sub(a,b) => (minust T)$(term_of_num T m a)$(term_of_num T m b)
+| FRPar.Neg a => (uminust T)$(term_of_num T m a)
+| FRPar.Pw(a,n) => (powt T)$(term_of_num T m t)$(HOLogic.mk_number HOLogic.natT n)
+| FRPar.CN(c,n,p) => term_of_num T m (FRPar.Add(c,FRPar.Mul(FRPar.Bound n, p)))
+| _ => error "term_of_num: Unknown term";
+
+fun term_of_tm T m m' t =
+ case t of
+ FRPar.CP p => term_of_num T m' p
+| FRPar.tm_Bound i => AList.lookup (op = : int*int -> bool) m i |> the
+| FRPar.tm_Add(a,b) => (plust T)$(term_of_tm T m m' a)$(term_of_tm T m m' b)
+| FRPar.tm_Mul(a,b) => (timest T)$(term_of_num T m' a)$(term_of_tm T m m' b)
+| FRPar.tm_Sub(a,b) => (minust T)$(term_of_tm T m m' a)$(term_of_tm T m m' b)
+| FRPar.tm_Neg a => (uminust T)$(term_of_tm T m m' a)
+| FRPar.CNP(n,c,p) => term_of_tm T m m' (FRPar.tm_Add(FRPar.tm_Mul(c, FRPar.tm_Bound n), p))
+| _ => error "term_of_tm: Unknown term";
+
+fun fm_of_term m m' fm =
+ case fm of
+ Const("True",_) => FRPar.T
+ | Const("False",_) => FRPar.F
+ | Const("Not",_)$p => FRPar.NOT (fm_of_term m m' p)
+ | Const("op &",_)$p$q => FRPar.And(fm_of_term m m' p, fm_of_term m m' q)
+ | Const("op |",_)$p$q => FRPar.Or(fm_of_term m m' p, fm_of_term m m' q)
+ | Const("op -->",_)$p$q => FRPar.Imp(fm_of_term m m' p, fm_of_term m m' q)
+ | Const("op =",ty)$p$q =>
+ if domain_type ty = bT then FRPar.Iff(fm_of_term m m' p, fm_of_term m m' q)
+ else FRPar.Eq (FRPar.tm_Sub(tm_of_term m m' p, tm_of_term m m' q))
+ | Const(@{const_name "HOL.less"},_)$p$q =>
+ FRPar.Lt (FRPar.tm_Sub(tm_of_term m m' p, tm_of_term m m' q))
+ | Const(@{const_name "HOL.less_eq"},_)$p$q =>
+ FRPar.Le (FRPar.tm_Sub(tm_of_term m m' p, tm_of_term m m' q))
+ | Const("Ex",_)$Abs(xn,xT,p) =>
+ let val (xn', p') = variant_abs (xn,xT,p)
+ val x = Free(xn',xT)
+ fun incr i = i + 1
+ val m0 = (x,0):: (map (apsnd incr) m)
+ in FRPar.E (fm_of_term m0 m' p') end
+ | Const("All",_)$Abs(xn,xT,p) =>
+ let val (xn', p') = variant_abs (xn,xT,p)
+ val x = Free(xn',xT)
+ fun incr i = i + 1
+ val m0 = (x,0):: (map (apsnd incr) m)
+ in FRPar.A (fm_of_term m0 m' p') end
+ | _ => error "fm_of_term";
+
+
+fun term_of_fm T m m' t =
+ case t of
+ FRPar.T => Const("True",bT)
+ | FRPar.F => Const("False",bT)
+ | FRPar.NOT p => nott $ (term_of_fm T m m' p)
+ | FRPar.And (p,q) => conjt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | FRPar.Or (p,q) => disjt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | FRPar.Imp (p,q) => impt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | FRPar.Iff (p,q) => ifft $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | FRPar.Lt p => (llt T) $ (term_of_tm T m m' p) $ (rz T)
+ | FRPar.Le p => (lle T) $ (term_of_tm T m m' p) $ (rz T)
+ | FRPar.Eq p => (eqt T) $ (term_of_tm T m m' p) $ (rz T)
+ | FRPar.NEq p => nott $ ((eqt T) $ (term_of_tm T m m' p) $ (rz T))
+ | _ => error "term_of_fm: quantifiers!!!!???";
+
+fun frpar_oracle (T,m, m', fm) =
+ let
+ val t = HOLogic.dest_Trueprop fm
+ val im = 0 upto (length m - 1)
+ val im' = 0 upto (length m' - 1)
+ in HOLogic.mk_Trueprop (HOLogic.mk_eq(t, term_of_fm T (im ~~ m) (im' ~~ m')
+ (FRPar.frpar (fm_of_term (m ~~ im) (m' ~~ im') t))))
+ end;
+
+fun frpar_oracle2 (T,m, m', fm) =
+ let
+ val t = HOLogic.dest_Trueprop fm
+ val im = 0 upto (length m - 1)
+ val im' = 0 upto (length m' - 1)
+ in HOLogic.mk_Trueprop (HOLogic.mk_eq(t, term_of_fm T (im ~~ m) (im' ~~ m')
+ (FRPar.frpar2 (fm_of_term (m ~~ im) (m' ~~ im') t))))
+ end;
+
+end;
+
+
+*}
+
+oracle frpar_oracle = {* fn (ty, ts, ts', ct) =>
+ let
+ val thy = Thm.theory_of_cterm ct
+ in cterm_of thy (ReflectedFRPar.frpar_oracle (ty,ts, ts', term_of ct))
+ end *}
+
+oracle frpar_oracle2 = {* fn (ty, ts, ts', ct) =>
+ let
+ val thy = Thm.theory_of_cterm ct
+ in cterm_of thy (ReflectedFRPar.frpar_oracle2 (ty,ts, ts', term_of ct))
+ end *}
+
+ML{*
+structure FRParTac =
+struct
+
+fun frpar_tac T ps ctxt i =
+ (ObjectLogic.full_atomize_tac i)
+ THEN (fn st =>
+ let
+ val g = List.nth (cprems_of st, i - 1)
+ val thy = ProofContext.theory_of ctxt
+ val fs = subtract (op aconv) (map Free (Term.add_frees (term_of g) [])) ps
+ val th = frpar_oracle (T, fs,ps, (* Pattern.eta_long [] *)g)
+ in rtac (th RS iffD2) i st end);
+
+fun frpar2_tac T ps ctxt i =
+ (ObjectLogic.full_atomize_tac i)
+ THEN (fn st =>
+ let
+ val g = List.nth (cprems_of st, i - 1)
+ val thy = ProofContext.theory_of ctxt
+ val fs = subtract (op aconv) (map Free (Term.add_frees (term_of g) [])) ps
+ val th = frpar_oracle2 (T, fs,ps, (* Pattern.eta_long [] *)g)
+ in rtac (th RS iffD2) i st end);
+
+end;
+
+*}
+
+method_setup frpar = {*
+let
+ fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
+ fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
+ val parsN = "pars"
+ val typN = "type"
+ val any_keyword = keyword parsN || keyword typN
+ val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat
+ val cterms = thms >> map Drule.dest_term;
+ val terms = Scan.repeat (Scan.unless any_keyword Args.term)
+ val typ = Scan.unless any_keyword Args.typ
+in
+ (keyword typN |-- typ) -- (keyword parsN |-- terms) >>
+ (fn (T,ps) => fn ctxt => SIMPLE_METHOD' (FRParTac.frpar_tac T ps ctxt))
+end
+*} "Parametric QE for linear Arithmetic over fields, Version 1"
+
+method_setup frpar2 = {*
+let
+ fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
+ fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
+ val parsN = "pars"
+ val typN = "type"
+ val any_keyword = keyword parsN || keyword typN
+ val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat
+ val cterms = thms >> map Drule.dest_term;
+ val terms = Scan.repeat (Scan.unless any_keyword Args.term)
+ val typ = Scan.unless any_keyword Args.typ
+in
+ (keyword typN |-- typ) -- (keyword parsN |-- terms) >>
+ (fn (T,ps) => fn ctxt => SIMPLE_METHOD' (FRParTac.frpar2_tac T ps ctxt))
+end
+*} "Parametric QE for linear Arithmetic over fields, Version 2"
+
+
+lemma "\<exists>(x::'a::{division_by_zero,ordered_field,number_ring}). y \<noteq> -1 \<longrightarrow> (y + 1)*x < 0"
+ apply (frpar type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "y::'a::{division_by_zero,ordered_field,number_ring}")
+ apply (simp add: ring_simps)
+ apply (rule spec[where x=y])
+ apply (frpar type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "z::'a::{division_by_zero,ordered_field,number_ring}")
+ by simp
+
+text{* Collins/Jones Problem *}
+(*
+lemma "\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \<and> (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0"
+proof-
+ have "(\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \<and> (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0) \<longleftrightarrow> (\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < 2 *(a^2 + b^2) - (3*(a^2 + b^2)) * r + (2*a)*r \<and> 2*(a^2 + b^2) - (3*(a^2 + b^2) - 4*a + 1)*r - 2*a < 0)" (is "?lhs \<longleftrightarrow> ?rhs")
+by (simp add: ring_simps)
+have "?rhs"
+
+ apply (frpar type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "a::'a::{division_by_zero,ordered_field,number_ring}" "b::'a::{division_by_zero,ordered_field,number_ring}")
+ apply (simp add: ring_simps)
+oops
+*)
+(*
+lemma "ALL (x::'a::{division_by_zero,ordered_field,number_ring}) y. (1 - t)*x \<le> (1+t)*y \<and> (1 - t)*y \<le> (1+t)*x --> 0 \<le> y"
+apply (frpar type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "t::'a::{division_by_zero,ordered_field,number_ring}")
+oops
+*)
+
+lemma "\<exists>(x::'a::{division_by_zero,ordered_field,number_ring}). y \<noteq> -1 \<longrightarrow> (y + 1)*x < 0"
+ apply (frpar2 type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "y::'a::{division_by_zero,ordered_field,number_ring}")
+ apply (simp add: ring_simps)
+ apply (rule spec[where x=y])
+ apply (frpar2 type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "z::'a::{division_by_zero,ordered_field,number_ring}")
+ by simp
+
+text{* Collins/Jones Problem *}
+
+(*
+lemma "\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \<and> (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0"
+proof-
+ have "(\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < (2 - 3*r) *(a^2 + b^2) + (2*a)*r \<and> (2 - 3*r) *(a^2 + b^2) + 4*a*r - 2*a - r < 0) \<longleftrightarrow> (\<exists>(r::'a::{division_by_zero,ordered_field,number_ring}). 0 < r \<and> r < 1 \<and> 0 < 2 *(a^2 + b^2) - (3*(a^2 + b^2)) * r + (2*a)*r \<and> 2*(a^2 + b^2) - (3*(a^2 + b^2) - 4*a + 1)*r - 2*a < 0)" (is "?lhs \<longleftrightarrow> ?rhs")
+by (simp add: ring_simps)
+have "?rhs"
+ apply (frpar2 type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "a::'a::{division_by_zero,ordered_field,number_ring}" "b::'a::{division_by_zero,ordered_field,number_ring}")
+ apply simp
+oops
+*)
+
+(*
+lemma "ALL (x::'a::{division_by_zero,ordered_field,number_ring}) y. (1 - t)*x \<le> (1+t)*y \<and> (1 - t)*y \<le> (1+t)*x --> 0 \<le> y"
+apply (frpar2 type: "'a::{division_by_zero,ordered_field,number_ring}" pars: "t::'a::{division_by_zero,ordered_field,number_ring}")
+apply (simp add: field_simps linorder_neq_iff[symmetric])
+apply ferrack
+oops
+*)
+end
\ No newline at end of file--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Decision_Procs/Polynomial_List.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,783 @@
+(* Title: HOL/Decision_Procs/Polynomial_List.thy
+ Author: Amine Chaieb
+*)
+
+header{*Univariate Polynomials as Lists *}
+
+theory Polynomial_List
+imports Main
+begin
+
+text{* Application of polynomial as a real function. *}
+
+consts poly :: "'a list => 'a => ('a::{comm_ring})"
+primrec
+ poly_Nil: "poly [] x = 0"
+ poly_Cons: "poly (h#t) x = h + x * poly t x"
+
+
+subsection{*Arithmetic Operations on Polynomials*}
+
+text{*addition*}
+consts padd :: "['a list, 'a list] => ('a::comm_ring_1) list" (infixl "+++" 65)
+primrec
+ padd_Nil: "[] +++ l2 = l2"
+ padd_Cons: "(h#t) +++ l2 = (if l2 = [] then h#t
+ else (h + hd l2)#(t +++ tl l2))"
+
+text{*Multiplication by a constant*}
+consts cmult :: "['a :: comm_ring_1, 'a list] => 'a list" (infixl "%*" 70)
+primrec
+ cmult_Nil: "c %* [] = []"
+ cmult_Cons: "c %* (h#t) = (c * h)#(c %* t)"
+
+text{*Multiplication by a polynomial*}
+consts pmult :: "['a list, 'a list] => ('a::comm_ring_1) list" (infixl "***" 70)
+primrec
+ pmult_Nil: "[] *** l2 = []"
+ pmult_Cons: "(h#t) *** l2 = (if t = [] then h %* l2
+ else (h %* l2) +++ ((0) # (t *** l2)))"
+
+text{*Repeated multiplication by a polynomial*}
+consts mulexp :: "[nat, 'a list, 'a list] => ('a ::comm_ring_1) list"
+primrec
+ mulexp_zero: "mulexp 0 p q = q"
+ mulexp_Suc: "mulexp (Suc n) p q = p *** mulexp n p q"
+
+text{*Exponential*}
+consts pexp :: "['a list, nat] => ('a::comm_ring_1) list" (infixl "%^" 80)
+primrec
+ pexp_0: "p %^ 0 = [1]"
+ pexp_Suc: "p %^ (Suc n) = p *** (p %^ n)"
+
+text{*Quotient related value of dividing a polynomial by x + a*}
+(* Useful for divisor properties in inductive proofs *)
+consts "pquot" :: "['a list, 'a::field] => 'a list"
+primrec
+ pquot_Nil: "pquot [] a= []"
+ pquot_Cons: "pquot (h#t) a = (if t = [] then [h]
+ else (inverse(a) * (h - hd( pquot t a)))#(pquot t a))"
+
+
+text{*normalization of polynomials (remove extra 0 coeff)*}
+consts pnormalize :: "('a::comm_ring_1) list => 'a list"
+primrec
+ pnormalize_Nil: "pnormalize [] = []"
+ pnormalize_Cons: "pnormalize (h#p) = (if ( (pnormalize p) = [])
+ then (if (h = 0) then [] else [h])
+ else (h#(pnormalize p)))"
+
+definition "pnormal p = ((pnormalize p = p) \<and> p \<noteq> [])"
+definition "nonconstant p = (pnormal p \<and> (\<forall>x. p \<noteq> [x]))"
+text{*Other definitions*}
+
+definition
+ poly_minus :: "'a list => ('a :: comm_ring_1) list" ("-- _" [80] 80) where
+ "-- p = (- 1) %* p"
+
+definition
+ divides :: "[('a::comm_ring_1) list, 'a list] => bool" (infixl "divides" 70) where
+ "p1 divides p2 = (\<exists>q. poly p2 = poly(p1 *** q))"
+
+definition
+ order :: "('a::comm_ring_1) => 'a list => nat" where
+ --{*order of a polynomial*}
+ "order a p = (SOME n. ([-a, 1] %^ n) divides p &
+ ~ (([-a, 1] %^ (Suc n)) divides p))"
+
+definition
+ degree :: "('a::comm_ring_1) list => nat" where
+ --{*degree of a polynomial*}
+ "degree p = length (pnormalize p) - 1"
+
+definition
+ rsquarefree :: "('a::comm_ring_1) list => bool" where
+ --{*squarefree polynomials --- NB with respect to real roots only.*}
+ "rsquarefree p = (poly p \<noteq> poly [] &
+ (\<forall>a. (order a p = 0) | (order a p = 1)))"
+
+lemma padd_Nil2: "p +++ [] = p"
+by (induct p) auto
+declare padd_Nil2 [simp]
+
+lemma padd_Cons_Cons: "(h1 # p1) +++ (h2 # p2) = (h1 + h2) # (p1 +++ p2)"
+by auto
+
+lemma pminus_Nil: "-- [] = []"
+by (simp add: poly_minus_def)
+declare pminus_Nil [simp]
+
+lemma pmult_singleton: "[h1] *** p1 = h1 %* p1"
+by simp
+
+lemma poly_ident_mult: "1 %* t = t"
+by (induct "t", auto)
+declare poly_ident_mult [simp]
+
+lemma poly_simple_add_Cons: "[a] +++ ((0)#t) = (a#t)"
+by simp
+declare poly_simple_add_Cons [simp]
+
+text{*Handy general properties*}
+
+lemma padd_commut: "b +++ a = a +++ b"
+apply (subgoal_tac "\<forall>a. b +++ a = a +++ b")
+apply (induct_tac [2] "b", auto)
+apply (rule padd_Cons [THEN ssubst])
+apply (case_tac "aa", auto)
+done
+
+lemma padd_assoc [rule_format]: "\<forall>b c. (a +++ b) +++ c = a +++ (b +++ c)"
+apply (induct "a", simp, clarify)
+apply (case_tac b, simp_all)
+done
+
+lemma poly_cmult_distr [rule_format]:
+ "\<forall>q. a %* ( p +++ q) = (a %* p +++ a %* q)"
+apply (induct "p", simp, clarify)
+apply (case_tac "q")
+apply (simp_all add: right_distrib)
+done
+
+lemma pmult_by_x[simp]: "[0, 1] *** t = ((0)#t)"
+apply (induct "t", simp)
+by (auto simp add: mult_zero_left poly_ident_mult padd_commut)
+
+
+text{*properties of evaluation of polynomials.*}
+
+lemma poly_add: "poly (p1 +++ p2) x = poly p1 x + poly p2 x"
+apply (subgoal_tac "\<forall>p2. poly (p1 +++ p2) x = poly (p1) x + poly (p2) x")
+apply (induct_tac [2] "p1", auto)
+apply (case_tac "p2")
+apply (auto simp add: right_distrib)
+done
+
+lemma poly_cmult: "poly (c %* p) x = c * poly p x"
+apply (induct "p")
+apply (case_tac [2] "x=0")
+apply (auto simp add: right_distrib mult_ac)
+done
+
+lemma poly_minus: "poly (-- p) x = - (poly p x)"
+apply (simp add: poly_minus_def)
+apply (auto simp add: poly_cmult)
+done
+
+lemma poly_mult: "poly (p1 *** p2) x = poly p1 x * poly p2 x"
+apply (subgoal_tac "\<forall>p2. poly (p1 *** p2) x = poly p1 x * poly p2 x")
+apply (simp (no_asm_simp))
+apply (induct "p1")
+apply (auto simp add: poly_cmult)
+apply (case_tac p1)
+apply (auto simp add: poly_cmult poly_add left_distrib right_distrib mult_ac)
+done
+
+lemma poly_exp: "poly (p %^ n) (x::'a::comm_ring_1) = (poly p x) ^ n"
+apply (induct "n")
+apply (auto simp add: poly_cmult poly_mult power_Suc)
+done
+
+text{*More Polynomial Evaluation Lemmas*}
+
+lemma poly_add_rzero: "poly (a +++ []) x = poly a x"
+by simp
+declare poly_add_rzero [simp]
+
+lemma poly_mult_assoc: "poly ((a *** b) *** c) x = poly (a *** (b *** c)) x"
+ by (simp add: poly_mult mult_assoc)
+
+lemma poly_mult_Nil2: "poly (p *** []) x = 0"
+by (induct "p", auto)
+declare poly_mult_Nil2 [simp]
+
+lemma poly_exp_add: "poly (p %^ (n + d)) x = poly( p %^ n *** p %^ d) x"
+apply (induct "n")
+apply (auto simp add: poly_mult mult_assoc)
+done
+
+subsection{*Key Property: if @{term "f(a) = 0"} then @{term "(x - a)"} divides
+ @{term "p(x)"} *}
+
+lemma lemma_poly_linear_rem: "\<forall>h. \<exists>q r. h#t = [r] +++ [-a, 1] *** q"
+apply (induct "t", safe)
+apply (rule_tac x = "[]" in exI)
+apply (rule_tac x = h in exI, simp)
+apply (drule_tac x = aa in spec, safe)
+apply (rule_tac x = "r#q" in exI)
+apply (rule_tac x = "a*r + h" in exI)
+apply (case_tac "q", auto)
+done
+
+lemma poly_linear_rem: "\<exists>q r. h#t = [r] +++ [-a, 1] *** q"
+by (cut_tac t = t and a = a in lemma_poly_linear_rem, auto)
+
+
+lemma poly_linear_divides: "(poly p a = 0) = ((p = []) | (\<exists>q. p = [-a, 1] *** q))"
+apply (auto simp add: poly_add poly_cmult right_distrib)
+apply (case_tac "p", simp)
+apply (cut_tac h = aa and t = list and a = a in poly_linear_rem, safe)
+apply (case_tac "q", auto)
+apply (drule_tac x = "[]" in spec, simp)
+apply (auto simp add: poly_add poly_cmult add_assoc)
+apply (drule_tac x = "aa#lista" in spec, auto)
+done
+
+lemma lemma_poly_length_mult: "\<forall>h k a. length (k %* p +++ (h # (a %* p))) = Suc (length p)"
+by (induct "p", auto)
+declare lemma_poly_length_mult [simp]
+
+lemma lemma_poly_length_mult2: "\<forall>h k. length (k %* p +++ (h # p)) = Suc (length p)"
+by (induct "p", auto)
+declare lemma_poly_length_mult2 [simp]
+
+lemma poly_length_mult: "length([-a,1] *** q) = Suc (length q)"
+by auto
+declare poly_length_mult [simp]
+
+
+subsection{*Polynomial length*}
+
+lemma poly_cmult_length: "length (a %* p) = length p"
+by (induct "p", auto)
+declare poly_cmult_length [simp]
+
+lemma poly_add_length [rule_format]:
+ "\<forall>p2. length (p1 +++ p2) =
+ (if (length p1 < length p2) then length p2 else length p1)"
+apply (induct "p1", simp_all)
+apply arith
+done
+
+lemma poly_root_mult_length: "length([a,b] *** p) = Suc (length p)"
+by (simp add: poly_cmult_length poly_add_length)
+declare poly_root_mult_length [simp]
+
+lemma poly_mult_not_eq_poly_Nil: "(poly (p *** q) x \<noteq> poly [] x) =
+ (poly p x \<noteq> poly [] x & poly q x \<noteq> poly [] (x::'a::idom))"
+apply (auto simp add: poly_mult)
+done
+declare poly_mult_not_eq_poly_Nil [simp]
+
+lemma poly_mult_eq_zero_disj: "(poly (p *** q) (x::'a::idom) = 0) = (poly p x = 0 | poly q x = 0)"
+by (auto simp add: poly_mult)
+
+text{*Normalisation Properties*}
+
+lemma poly_normalized_nil: "(pnormalize p = []) --> (poly p x = 0)"
+by (induct "p", auto)
+
+text{*A nontrivial polynomial of degree n has no more than n roots*}
+
+lemma poly_roots_index_lemma0 [rule_format]:
+ "\<forall>p x. poly p x \<noteq> poly [] x & length p = n
+ --> (\<exists>i. \<forall>x. (poly p x = (0::'a::idom)) --> (\<exists>m. (m \<le> n & x = i m)))"
+apply (induct "n", safe)
+apply (rule ccontr)
+apply (subgoal_tac "\<exists>a. poly p a = 0", safe)
+apply (drule poly_linear_divides [THEN iffD1], safe)
+apply (drule_tac x = q in spec)
+apply (drule_tac x = x in spec)
+apply (simp del: poly_Nil pmult_Cons)
+apply (erule exE)
+apply (drule_tac x = "%m. if m = Suc n then a else i m" in spec, safe)
+apply (drule poly_mult_eq_zero_disj [THEN iffD1], safe)
+apply (drule_tac x = "Suc (length q)" in spec)
+apply (auto simp add: ring_simps)
+apply (drule_tac x = xa in spec)
+apply (clarsimp simp add: ring_simps)
+apply (drule_tac x = m in spec)
+apply (auto simp add:ring_simps)
+done
+lemmas poly_roots_index_lemma1 = conjI [THEN poly_roots_index_lemma0, standard]
+
+lemma poly_roots_index_length0: "poly p (x::'a::idom) \<noteq> poly [] x ==>
+ \<exists>i. \<forall>x. (poly p x = 0) --> (\<exists>n. n \<le> length p & x = i n)"
+by (blast intro: poly_roots_index_lemma1)
+
+lemma poly_roots_finite_lemma: "poly p (x::'a::idom) \<noteq> poly [] x ==>
+ \<exists>N i. \<forall>x. (poly p x = 0) --> (\<exists>n. (n::nat) < N & x = i n)"
+apply (drule poly_roots_index_length0, safe)
+apply (rule_tac x = "Suc (length p)" in exI)
+apply (rule_tac x = i in exI)
+apply (simp add: less_Suc_eq_le)
+done
+
+
+lemma real_finite_lemma:
+ assumes P: "\<forall>x. P x --> (\<exists>n. n < length j & x = j!n)"
+ shows "finite {(x::'a::idom). P x}"
+proof-
+ let ?M = "{x. P x}"
+ let ?N = "set j"
+ have "?M \<subseteq> ?N" using P by auto
+ thus ?thesis using finite_subset by auto
+qed
+
+lemma poly_roots_index_lemma [rule_format]:
+ "\<forall>p x. poly p x \<noteq> poly [] x & length p = n
+ --> (\<exists>i. \<forall>x. (poly p x = (0::'a::{idom})) --> x \<in> set i)"
+apply (induct "n", safe)
+apply (rule ccontr)
+apply (subgoal_tac "\<exists>a. poly p a = 0", safe)
+apply (drule poly_linear_divides [THEN iffD1], safe)
+apply (drule_tac x = q in spec)
+apply (drule_tac x = x in spec)
+apply (auto simp del: poly_Nil pmult_Cons)
+apply (drule_tac x = "a#i" in spec)
+apply (auto simp only: poly_mult List.list.size)
+apply (drule_tac x = xa in spec)
+apply (clarsimp simp add: ring_simps)
+done
+
+lemmas poly_roots_index_lemma2 = conjI [THEN poly_roots_index_lemma, standard]
+
+lemma poly_roots_index_length: "poly p (x::'a::idom) \<noteq> poly [] x ==>
+ \<exists>i. \<forall>x. (poly p x = 0) --> x \<in> set i"
+by (blast intro: poly_roots_index_lemma2)
+
+lemma poly_roots_finite_lemma': "poly p (x::'a::idom) \<noteq> poly [] x ==>
+ \<exists>i. \<forall>x. (poly p x = 0) --> x \<in> set i"
+by (drule poly_roots_index_length, safe)
+
+lemma UNIV_nat_infinite: "\<not> finite (UNIV :: nat set)"
+ unfolding finite_conv_nat_seg_image
+proof(auto simp add: expand_set_eq image_iff)
+ fix n::nat and f:: "nat \<Rightarrow> nat"
+ let ?N = "{i. i < n}"
+ let ?fN = "f ` ?N"
+ let ?y = "Max ?fN + 1"
+ from nat_seg_image_imp_finite[of "?fN" "f" n]
+ have thfN: "finite ?fN" by simp
+ {assume "n =0" hence "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by auto}
+ moreover
+ {assume nz: "n \<noteq> 0"
+ hence thne: "?fN \<noteq> {}" by (auto simp add: neq0_conv)
+ have "\<forall>x\<in> ?fN. Max ?fN \<ge> x" using nz Max_ge_iff[OF thfN thne] by auto
+ hence "\<forall>x\<in> ?fN. ?y > x" by (auto simp add: less_Suc_eq_le)
+ hence "?y \<notin> ?fN" by auto
+ hence "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by auto }
+ ultimately show "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by blast
+qed
+
+lemma UNIV_ring_char_0_infinte: "\<not> finite (UNIV:: ('a::ring_char_0) set)"
+proof
+ assume F: "finite (UNIV :: 'a set)"
+ have th0: "of_nat ` UNIV \<subseteq> (UNIV:: 'a set)" by simp
+ from finite_subset[OF th0 F] have th: "finite (of_nat ` UNIV :: 'a set)" .
+ have th': "inj_on (of_nat::nat \<Rightarrow> 'a) (UNIV)"
+ unfolding inj_on_def by auto
+ from finite_imageD[OF th th'] UNIV_nat_infinite
+ show False by blast
+qed
+
+lemma poly_roots_finite: "(poly p \<noteq> poly []) =
+ finite {x. poly p x = (0::'a::{idom, ring_char_0})}"
+proof
+ assume H: "poly p \<noteq> poly []"
+ show "finite {x. poly p x = (0::'a)}"
+ using H
+ apply -
+ apply (erule contrapos_np, rule ext)
+ apply (rule ccontr)
+ apply (clarify dest!: poly_roots_finite_lemma')
+ using finite_subset
+ proof-
+ fix x i
+ assume F: "\<not> finite {x. poly p x = (0\<Colon>'a)}"
+ and P: "\<forall>x. poly p x = (0\<Colon>'a) \<longrightarrow> x \<in> set i"
+ let ?M= "{x. poly p x = (0\<Colon>'a)}"
+ from P have "?M \<subseteq> set i" by auto
+ with finite_subset F show False by auto
+ qed
+next
+ assume F: "finite {x. poly p x = (0\<Colon>'a)}"
+ show "poly p \<noteq> poly []" using F UNIV_ring_char_0_infinte by auto
+qed
+
+text{*Entirety and Cancellation for polynomials*}
+
+lemma poly_entire_lemma: "[| poly (p:: ('a::{idom,ring_char_0}) list) \<noteq> poly [] ; poly q \<noteq> poly [] |]
+ ==> poly (p *** q) \<noteq> poly []"
+by (auto simp add: poly_roots_finite poly_mult Collect_disj_eq)
+
+lemma poly_entire: "(poly (p *** q) = poly ([]::('a::{idom,ring_char_0}) list)) = ((poly p = poly []) | (poly q = poly []))"
+apply (auto intro: ext dest: fun_cong simp add: poly_entire_lemma poly_mult)
+apply (blast intro: ccontr dest: poly_entire_lemma poly_mult [THEN subst])
+done
+
+lemma poly_entire_neg: "(poly (p *** q) \<noteq> poly ([]::('a::{idom,ring_char_0}) list)) = ((poly p \<noteq> poly []) & (poly q \<noteq> poly []))"
+by (simp add: poly_entire)
+
+lemma fun_eq: " (f = g) = (\<forall>x. f x = g x)"
+by (auto intro!: ext)
+
+lemma poly_add_minus_zero_iff: "(poly (p +++ -- q) = poly []) = (poly p = poly q)"
+by (auto simp add: ring_simps poly_add poly_minus_def fun_eq poly_cmult)
+
+lemma poly_add_minus_mult_eq: "poly (p *** q +++ --(p *** r)) = poly (p *** (q +++ -- r))"
+by (auto simp add: poly_add poly_minus_def fun_eq poly_mult poly_cmult right_distrib)
+
+lemma poly_mult_left_cancel: "(poly (p *** q) = poly (p *** r)) = (poly p = poly ([]::('a::{idom, ring_char_0}) list) | poly q = poly r)"
+apply (rule_tac p1 = "p *** q" in poly_add_minus_zero_iff [THEN subst])
+apply (auto intro: ext simp add: poly_add_minus_mult_eq poly_entire poly_add_minus_zero_iff)
+done
+
+lemma poly_exp_eq_zero:
+ "(poly (p %^ n) = poly ([]::('a::idom) list)) = (poly p = poly [] & n \<noteq> 0)"
+apply (simp only: fun_eq add: all_simps [symmetric])
+apply (rule arg_cong [where f = All])
+apply (rule ext)
+apply (induct_tac "n")
+apply (auto simp add: poly_mult)
+done
+declare poly_exp_eq_zero [simp]
+
+lemma poly_prime_eq_zero: "poly [a,(1::'a::comm_ring_1)] \<noteq> poly []"
+apply (simp add: fun_eq)
+apply (rule_tac x = "1 - a" in exI, simp)
+done
+declare poly_prime_eq_zero [simp]
+
+lemma poly_exp_prime_eq_zero: "(poly ([a, (1::'a::idom)] %^ n) \<noteq> poly [])"
+by auto
+declare poly_exp_prime_eq_zero [simp]
+
+text{*A more constructive notion of polynomials being trivial*}
+
+lemma poly_zero_lemma': "poly (h # t) = poly [] ==> h = (0::'a::{idom,ring_char_0}) & poly t = poly []"
+apply(simp add: fun_eq)
+apply (case_tac "h = 0")
+apply (drule_tac [2] x = 0 in spec, auto)
+apply (case_tac "poly t = poly []", simp)
+proof-
+ fix x
+ assume H: "\<forall>x. x = (0\<Colon>'a) \<or> poly t x = (0\<Colon>'a)" and pnz: "poly t \<noteq> poly []"
+ let ?S = "{x. poly t x = 0}"
+ from H have "\<forall>x. x \<noteq>0 \<longrightarrow> poly t x = 0" by blast
+ hence th: "?S \<supseteq> UNIV - {0}" by auto
+ from poly_roots_finite pnz have th': "finite ?S" by blast
+ from finite_subset[OF th th'] UNIV_ring_char_0_infinte[where ?'a = 'a]
+ show "poly t x = (0\<Colon>'a)" by simp
+ qed
+
+lemma poly_zero: "(poly p = poly []) = list_all (%c. c = (0::'a::{idom,ring_char_0})) p"
+apply (induct "p", simp)
+apply (rule iffI)
+apply (drule poly_zero_lemma', auto)
+done
+
+
+
+text{*Basics of divisibility.*}
+
+lemma poly_primes: "([a, (1::'a::idom)] divides (p *** q)) = ([a, 1] divides p | [a, 1] divides q)"
+apply (auto simp add: divides_def fun_eq poly_mult poly_add poly_cmult left_distrib [symmetric])
+apply (drule_tac x = "-a" in spec)
+apply (auto simp add: poly_linear_divides poly_add poly_cmult left_distrib [symmetric])
+apply (rule_tac x = "qa *** q" in exI)
+apply (rule_tac [2] x = "p *** qa" in exI)
+apply (auto simp add: poly_add poly_mult poly_cmult mult_ac)
+done
+
+lemma poly_divides_refl: "p divides p"
+apply (simp add: divides_def)
+apply (rule_tac x = "[1]" in exI)
+apply (auto simp add: poly_mult fun_eq)
+done
+declare poly_divides_refl [simp]
+
+lemma poly_divides_trans: "[| p divides q; q divides r |] ==> p divides r"
+apply (simp add: divides_def, safe)
+apply (rule_tac x = "qa *** qaa" in exI)
+apply (auto simp add: poly_mult fun_eq mult_assoc)
+done
+
+lemma poly_divides_exp: "m \<le> n ==> (p %^ m) divides (p %^ n)"
+apply (auto simp add: le_iff_add)
+apply (induct_tac k)
+apply (rule_tac [2] poly_divides_trans)
+apply (auto simp add: divides_def)
+apply (rule_tac x = p in exI)
+apply (auto simp add: poly_mult fun_eq mult_ac)
+done
+
+lemma poly_exp_divides: "[| (p %^ n) divides q; m\<le>n |] ==> (p %^ m) divides q"
+by (blast intro: poly_divides_exp poly_divides_trans)
+
+lemma poly_divides_add:
+ "[| p divides q; p divides r |] ==> p divides (q +++ r)"
+apply (simp add: divides_def, auto)
+apply (rule_tac x = "qa +++ qaa" in exI)
+apply (auto simp add: poly_add fun_eq poly_mult right_distrib)
+done
+
+lemma poly_divides_diff:
+ "[| p divides q; p divides (q +++ r) |] ==> p divides r"
+apply (simp add: divides_def, auto)
+apply (rule_tac x = "qaa +++ -- qa" in exI)
+apply (auto simp add: poly_add fun_eq poly_mult poly_minus right_diff_distrib algebra_simps)
+done
+
+lemma poly_divides_diff2: "[| p divides r; p divides (q +++ r) |] ==> p divides q"
+apply (erule poly_divides_diff)
+apply (auto simp add: poly_add fun_eq poly_mult divides_def add_ac)
+done
+
+lemma poly_divides_zero: "poly p = poly [] ==> q divides p"
+apply (simp add: divides_def)
+apply (rule exI[where x="[]"])
+apply (auto simp add: fun_eq poly_mult)
+done
+
+lemma poly_divides_zero2: "q divides []"
+apply (simp add: divides_def)
+apply (rule_tac x = "[]" in exI)
+apply (auto simp add: fun_eq)
+done
+declare poly_divides_zero2 [simp]
+
+text{*At last, we can consider the order of a root.*}
+
+
+lemma poly_order_exists_lemma [rule_format]:
+ "\<forall>p. length p = d --> poly p \<noteq> poly []
+ --> (\<exists>n q. p = mulexp n [-a, (1::'a::{idom,ring_char_0})] q & poly q a \<noteq> 0)"
+apply (induct "d")
+apply (simp add: fun_eq, safe)
+apply (case_tac "poly p a = 0")
+apply (drule_tac poly_linear_divides [THEN iffD1], safe)
+apply (drule_tac x = q in spec)
+apply (drule_tac poly_entire_neg [THEN iffD1], safe, force)
+apply (rule_tac x = "Suc n" in exI)
+apply (rule_tac x = qa in exI)
+apply (simp del: pmult_Cons)
+apply (rule_tac x = 0 in exI, force)
+done
+
+(* FIXME: Tidy up *)
+lemma poly_order_exists:
+ "[| length p = d; poly p \<noteq> poly [] |]
+ ==> \<exists>n. ([-a, 1] %^ n) divides p &
+ ~(([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p)"
+apply (drule poly_order_exists_lemma [where a=a], assumption, clarify)
+apply (rule_tac x = n in exI, safe)
+apply (unfold divides_def)
+apply (rule_tac x = q in exI)
+apply (induct_tac "n", simp)
+apply (simp (no_asm_simp) add: poly_add poly_cmult poly_mult right_distrib mult_ac)
+apply safe
+apply (subgoal_tac "poly (mulexp n [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc n *** qa)")
+apply simp
+apply (induct_tac "n")
+apply (simp del: pmult_Cons pexp_Suc)
+apply (erule_tac Q = "poly q a = 0" in contrapos_np)
+apply (simp add: poly_add poly_cmult)
+apply (rule pexp_Suc [THEN ssubst])
+apply (rule ccontr)
+apply (simp add: poly_mult_left_cancel poly_mult_assoc del: pmult_Cons pexp_Suc)
+done
+
+lemma poly_one_divides: "[1] divides p"
+by (simp add: divides_def, auto)
+declare poly_one_divides [simp]
+
+lemma poly_order: "poly p \<noteq> poly []
+ ==> EX! n. ([-a, (1::'a::{idom,ring_char_0})] %^ n) divides p &
+ ~(([-a, 1] %^ (Suc n)) divides p)"
+apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
+apply (cut_tac x = y and y = n in less_linear)
+apply (drule_tac m = n in poly_exp_divides)
+apply (auto dest: Suc_le_eq [THEN iffD2, THEN [2] poly_exp_divides]
+ simp del: pmult_Cons pexp_Suc)
+done
+
+text{*Order*}
+
+lemma some1_equalityD: "[| n = (@n. P n); EX! n. P n |] ==> P n"
+by (blast intro: someI2)
+
+lemma order:
+ "(([-a, (1::'a::{idom,ring_char_0})] %^ n) divides p &
+ ~(([-a, 1] %^ (Suc n)) divides p)) =
+ ((n = order a p) & ~(poly p = poly []))"
+apply (unfold order_def)
+apply (rule iffI)
+apply (blast dest: poly_divides_zero intro!: some1_equality [symmetric] poly_order)
+apply (blast intro!: poly_order [THEN [2] some1_equalityD])
+done
+
+lemma order2: "[| poly p \<noteq> poly [] |]
+ ==> ([-a, (1::'a::{idom,ring_char_0})] %^ (order a p)) divides p &
+ ~(([-a, 1] %^ (Suc(order a p))) divides p)"
+by (simp add: order del: pexp_Suc)
+
+lemma order_unique: "[| poly p \<noteq> poly []; ([-a, 1] %^ n) divides p;
+ ~(([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p)
+ |] ==> (n = order a p)"
+by (insert order [of a n p], auto)
+
+lemma order_unique_lemma: "(poly p \<noteq> poly [] & ([-a, 1] %^ n) divides p &
+ ~(([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p))
+ ==> (n = order a p)"
+by (blast intro: order_unique)
+
+lemma order_poly: "poly p = poly q ==> order a p = order a q"
+by (auto simp add: fun_eq divides_def poly_mult order_def)
+
+lemma pexp_one: "p %^ (Suc 0) = p"
+apply (induct "p")
+apply (auto simp add: numeral_1_eq_1)
+done
+declare pexp_one [simp]
+
+lemma lemma_order_root [rule_format]:
+ "\<forall>p a. 0 < n & [- a, 1] %^ n divides p & ~ [- a, 1] %^ (Suc n) divides p
+ --> poly p a = 0"
+apply (induct "n", blast)
+apply (auto simp add: divides_def poly_mult simp del: pmult_Cons)
+done
+
+lemma order_root: "(poly p a = (0::'a::{idom,ring_char_0})) = ((poly p = poly []) | order a p \<noteq> 0)"
+apply (case_tac "poly p = poly []", auto)
+apply (simp add: poly_linear_divides del: pmult_Cons, safe)
+apply (drule_tac [!] a = a in order2)
+apply (rule ccontr)
+apply (simp add: divides_def poly_mult fun_eq del: pmult_Cons, blast)
+using neq0_conv
+apply (blast intro: lemma_order_root)
+done
+
+lemma order_divides: "(([-a, 1::'a::{idom,ring_char_0}] %^ n) divides p) = ((poly p = poly []) | n \<le> order a p)"
+apply (case_tac "poly p = poly []", auto)
+apply (simp add: divides_def fun_eq poly_mult)
+apply (rule_tac x = "[]" in exI)
+apply (auto dest!: order2 [where a=a]
+ intro: poly_exp_divides simp del: pexp_Suc)
+done
+
+lemma order_decomp:
+ "poly p \<noteq> poly []
+ ==> \<exists>q. (poly p = poly (([-a, 1] %^ (order a p)) *** q)) &
+ ~([-a, 1::'a::{idom,ring_char_0}] divides q)"
+apply (unfold divides_def)
+apply (drule order2 [where a = a])
+apply (simp add: divides_def del: pexp_Suc pmult_Cons, safe)
+apply (rule_tac x = q in exI, safe)
+apply (drule_tac x = qa in spec)
+apply (auto simp add: poly_mult fun_eq poly_exp mult_ac simp del: pmult_Cons)
+done
+
+text{*Important composition properties of orders.*}
+
+lemma order_mult: "poly (p *** q) \<noteq> poly []
+ ==> order a (p *** q) = order a p + order (a::'a::{idom,ring_char_0}) q"
+apply (cut_tac a = a and p = "p***q" and n = "order a p + order a q" in order)
+apply (auto simp add: poly_entire simp del: pmult_Cons)
+apply (drule_tac a = a in order2)+
+apply safe
+apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons, safe)
+apply (rule_tac x = "qa *** qaa" in exI)
+apply (simp add: poly_mult mult_ac del: pmult_Cons)
+apply (drule_tac a = a in order_decomp)+
+apply safe
+apply (subgoal_tac "[-a,1] divides (qa *** qaa) ")
+apply (simp add: poly_primes del: pmult_Cons)
+apply (auto simp add: divides_def simp del: pmult_Cons)
+apply (rule_tac x = qb in exI)
+apply (subgoal_tac "poly ([-a, 1] %^ (order a p) *** (qa *** qaa)) = poly ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))")
+apply (drule poly_mult_left_cancel [THEN iffD1], force)
+apply (subgoal_tac "poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** (qa *** qaa))) = poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))) ")
+apply (drule poly_mult_left_cancel [THEN iffD1], force)
+apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
+done
+
+
+
+lemma order_root2: "poly p \<noteq> poly [] ==> (poly p a = 0) = (order (a::'a::{idom,ring_char_0}) p \<noteq> 0)"
+by (rule order_root [THEN ssubst], auto)
+
+
+lemma pmult_one: "[1] *** p = p"
+by auto
+declare pmult_one [simp]
+
+lemma poly_Nil_zero: "poly [] = poly [0]"
+by (simp add: fun_eq)
+
+lemma rsquarefree_decomp:
+ "[| rsquarefree p; poly p a = (0::'a::{idom,ring_char_0}) |]
+ ==> \<exists>q. (poly p = poly ([-a, 1] *** q)) & poly q a \<noteq> 0"
+apply (simp add: rsquarefree_def, safe)
+apply (frule_tac a = a in order_decomp)
+apply (drule_tac x = a in spec)
+apply (drule_tac a = a in order_root2 [symmetric])
+apply (auto simp del: pmult_Cons)
+apply (rule_tac x = q in exI, safe)
+apply (simp add: poly_mult fun_eq)
+apply (drule_tac p1 = q in poly_linear_divides [THEN iffD1])
+apply (simp add: divides_def del: pmult_Cons, safe)
+apply (drule_tac x = "[]" in spec)
+apply (auto simp add: fun_eq)
+done
+
+
+text{*Normalization of a polynomial.*}
+
+lemma poly_normalize: "poly (pnormalize p) = poly p"
+apply (induct "p")
+apply (auto simp add: fun_eq)
+done
+declare poly_normalize [simp]
+
+
+text{*The degree of a polynomial.*}
+
+lemma lemma_degree_zero:
+ "list_all (%c. c = 0) p \<longleftrightarrow> pnormalize p = []"
+by (induct "p", auto)
+
+lemma degree_zero: "(poly p = poly ([]:: (('a::{idom,ring_char_0}) list))) \<Longrightarrow> (degree p = 0)"
+apply (simp add: degree_def)
+apply (case_tac "pnormalize p = []")
+apply (auto simp add: poly_zero lemma_degree_zero )
+done
+
+lemma pnormalize_sing: "(pnormalize [x] = [x]) \<longleftrightarrow> x \<noteq> 0" by simp
+lemma pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> (pnormalize [x, y] = [x, y])" by simp
+lemma pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c#p)"
+ unfolding pnormal_def by simp
+lemma pnormal_tail: "p\<noteq>[] \<Longrightarrow> pnormal (c#p) \<Longrightarrow> pnormal p"
+ unfolding pnormal_def
+ apply (cases "pnormalize p = []", auto)
+ by (cases "c = 0", auto)
+lemma pnormal_last_nonzero: "pnormal p ==> last p \<noteq> 0"
+ apply (induct p, auto simp add: pnormal_def)
+ apply (case_tac "pnormalize p = []", auto)
+ by (case_tac "a=0", auto)
+lemma pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
+ unfolding pnormal_def length_greater_0_conv by blast
+lemma pnormal_last_length: "\<lbrakk>0 < length p ; last p \<noteq> 0\<rbrakk> \<Longrightarrow> pnormal p"
+ apply (induct p, auto)
+ apply (case_tac "p = []", auto)
+ apply (simp add: pnormal_def)
+ by (rule pnormal_cons, auto)
+lemma pnormal_id: "pnormal p \<longleftrightarrow> (0 < length p \<and> last p \<noteq> 0)"
+ using pnormal_last_length pnormal_length pnormal_last_nonzero by blast
+
+text{*Tidier versions of finiteness of roots.*}
+
+lemma poly_roots_finite_set: "poly p \<noteq> poly [] ==> finite {x::'a::{idom,ring_char_0}. poly p x = 0}"
+unfolding poly_roots_finite .
+
+text{*bound for polynomial.*}
+
+lemma poly_mono: "abs(x) \<le> k ==> abs(poly p (x::'a::{ordered_idom})) \<le> poly (map abs p) k"
+apply (induct "p", auto)
+apply (rule_tac y = "abs a + abs (x * poly p x)" in order_trans)
+apply (rule abs_triangle_ineq)
+apply (auto intro!: mult_mono simp add: abs_mult)
+done
+
+lemma poly_Sing: "poly [c] x = c" by simp
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1743 @@
+(* Title: HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy
+ Author: Amine Chaieb
+*)
+
+header {* Implementation and verification of mutivariate polynomials Library *}
+
+
+theory Reflected_Multivariate_Polynomial
+imports Parity Abstract_Rat Efficient_Nat List Polynomial_List
+begin
+
+ (* Impelementation *)
+
+subsection{* Datatype of polynomial expressions *}
+
+datatype poly = C Num| Bound nat| Add poly poly|Sub poly poly
+ | Mul poly poly| Neg poly| Pw poly nat| CN poly nat poly
+
+ML{* @{term "Add"}*}
+syntax "_poly0" :: "poly" ("0\<^sub>p")
+translations "0\<^sub>p" \<rightleftharpoons> "C (0\<^sub>N)"
+syntax "_poly" :: "int \<Rightarrow> poly" ("_\<^sub>p")
+translations "i\<^sub>p" \<rightleftharpoons> "C (i\<^sub>N)"
+
+subsection{* Boundedness, substitution and all that *}
+consts polysize:: "poly \<Rightarrow> nat"
+primrec
+ "polysize (C c) = 1"
+ "polysize (Bound n) = 1"
+ "polysize (Neg p) = 1 + polysize p"
+ "polysize (Add p q) = 1 + polysize p + polysize q"
+ "polysize (Sub p q) = 1 + polysize p + polysize q"
+ "polysize (Mul p q) = 1 + polysize p + polysize q"
+ "polysize (Pw p n) = 1 + polysize p"
+ "polysize (CN c n p) = 4 + polysize c + polysize p"
+
+consts
+ polybound0:: "poly \<Rightarrow> bool" (* a poly is INDEPENDENT of Bound 0 *)
+ polysubst0:: "poly \<Rightarrow> poly \<Rightarrow> poly" (* substitute a poly into a poly for Bound 0 *)
+primrec
+ "polybound0 (C c) = True"
+ "polybound0 (Bound n) = (n>0)"
+ "polybound0 (Neg a) = polybound0 a"
+ "polybound0 (Add a b) = (polybound0 a \<and> polybound0 b)"
+ "polybound0 (Sub a b) = (polybound0 a \<and> polybound0 b)"
+ "polybound0 (Mul a b) = (polybound0 a \<and> polybound0 b)"
+ "polybound0 (Pw p n) = (polybound0 p)"
+ "polybound0 (CN c n p) = (n \<noteq> 0 \<and> polybound0 c \<and> polybound0 p)"
+primrec
+ "polysubst0 t (C c) = (C c)"
+ "polysubst0 t (Bound n) = (if n=0 then t else Bound n)"
+ "polysubst0 t (Neg a) = Neg (polysubst0 t a)"
+ "polysubst0 t (Add a b) = Add (polysubst0 t a) (polysubst0 t b)"
+ "polysubst0 t (Sub a b) = Sub (polysubst0 t a) (polysubst0 t b)"
+ "polysubst0 t (Mul a b) = Mul (polysubst0 t a) (polysubst0 t b)"
+ "polysubst0 t (Pw p n) = Pw (polysubst0 t p) n"
+ "polysubst0 t (CN c n p) = (if n=0 then Add (polysubst0 t c) (Mul t (polysubst0 t p))
+ else CN (polysubst0 t c) n (polysubst0 t p))"
+
+consts
+ decrpoly:: "poly \<Rightarrow> poly"
+recdef decrpoly "measure polysize"
+ "decrpoly (Bound n) = Bound (n - 1)"
+ "decrpoly (Neg a) = Neg (decrpoly a)"
+ "decrpoly (Add a b) = Add (decrpoly a) (decrpoly b)"
+ "decrpoly (Sub a b) = Sub (decrpoly a) (decrpoly b)"
+ "decrpoly (Mul a b) = Mul (decrpoly a) (decrpoly b)"
+ "decrpoly (Pw p n) = Pw (decrpoly p) n"
+ "decrpoly (CN c n p) = CN (decrpoly c) (n - 1) (decrpoly p)"
+ "decrpoly a = a"
+
+subsection{* Degrees and heads and coefficients *}
+
+consts degree:: "poly \<Rightarrow> nat"
+recdef degree "measure size"
+ "degree (CN c 0 p) = 1 + degree p"
+ "degree p = 0"
+consts head:: "poly \<Rightarrow> poly"
+
+recdef head "measure size"
+ "head (CN c 0 p) = head p"
+ "head p = p"
+ (* More general notions of degree and head *)
+consts degreen:: "poly \<Rightarrow> nat \<Rightarrow> nat"
+recdef degreen "measure size"
+ "degreen (CN c n p) = (\<lambda>m. if n=m then 1 + degreen p n else 0)"
+ "degreen p = (\<lambda>m. 0)"
+
+consts headn:: "poly \<Rightarrow> nat \<Rightarrow> poly"
+recdef headn "measure size"
+ "headn (CN c n p) = (\<lambda>m. if n \<le> m then headn p m else CN c n p)"
+ "headn p = (\<lambda>m. p)"
+
+consts coefficients:: "poly \<Rightarrow> poly list"
+recdef coefficients "measure size"
+ "coefficients (CN c 0 p) = c#(coefficients p)"
+ "coefficients p = [p]"
+
+consts isconstant:: "poly \<Rightarrow> bool"
+recdef isconstant "measure size"
+ "isconstant (CN c 0 p) = False"
+ "isconstant p = True"
+
+consts behead:: "poly \<Rightarrow> poly"
+recdef behead "measure size"
+ "behead (CN c 0 p) = (let p' = behead p in if p' = 0\<^sub>p then c else CN c 0 p')"
+ "behead p = 0\<^sub>p"
+
+consts headconst:: "poly \<Rightarrow> Num"
+recdef headconst "measure size"
+ "headconst (CN c n p) = headconst p"
+ "headconst (C n) = n"
+
+subsection{* Operations for normalization *}
+consts
+ polyadd :: "poly\<times>poly \<Rightarrow> poly"
+ polyneg :: "poly \<Rightarrow> poly" ("~\<^sub>p")
+ polysub :: "poly\<times>poly \<Rightarrow> poly"
+ polymul :: "poly\<times>poly \<Rightarrow> poly"
+ polypow :: "nat \<Rightarrow> poly \<Rightarrow> poly"
+syntax "_polyadd" :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "+\<^sub>p" 60)
+translations "a +\<^sub>p b" \<rightleftharpoons> "polyadd (a,b)"
+syntax "_polymul" :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "*\<^sub>p" 60)
+translations "a *\<^sub>p b" \<rightleftharpoons> "polymul (a,b)"
+syntax "_polysub" :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "-\<^sub>p" 60)
+translations "a -\<^sub>p b" \<rightleftharpoons> "polysub (a,b)"
+syntax "_polypow" :: "nat \<Rightarrow> poly \<Rightarrow> poly" (infixl "^\<^sub>p" 60)
+translations "a ^\<^sub>p k" \<rightleftharpoons> "polypow k a"
+
+recdef polyadd "measure (\<lambda> (a,b). polysize a + polysize b)"
+ "polyadd (C c, C c') = C (c+\<^sub>Nc')"
+ "polyadd (C c, CN c' n' p') = CN (polyadd (C c, c')) n' p'"
+ "polyadd (CN c n p, C c') = CN (polyadd (c, C c')) n p"
+stupid: "polyadd (CN c n p, CN c' n' p') =
+ (if n < n' then CN (polyadd(c,CN c' n' p')) n p
+ else if n'<n then CN (polyadd(CN c n p, c')) n' p'
+ else (let cc' = polyadd (c,c') ;
+ pp' = polyadd (p,p')
+ in (if pp' = 0\<^sub>p then cc' else CN cc' n pp')))"
+ "polyadd (a, b) = Add a b"
+(hints recdef_simp add: Let_def measure_def split_def inv_image_def)
+
+(*
+declare stupid [simp del, code del]
+
+lemma [simp,code]: "polyadd (CN c n p, CN c' n' p') =
+ (if n < n' then CN (polyadd(c,CN c' n' p')) n p
+ else if n'<n then CN (polyadd(CN c n p, c')) n' p'
+ else (let cc' = polyadd (c,c') ;
+ pp' = polyadd (p,p')
+ in (if pp' = 0\<^sub>p then cc' else CN cc' n pp')))"
+ by (simp add: Let_def stupid)
+*)
+
+recdef polyneg "measure size"
+ "polyneg (C c) = C (~\<^sub>N c)"
+ "polyneg (CN c n p) = CN (polyneg c) n (polyneg p)"
+ "polyneg a = Neg a"
+
+defs polysub_def[code]: "polysub \<equiv> \<lambda> (p,q). polyadd (p,polyneg q)"
+
+recdef polymul "measure (\<lambda>(a,b). size a + size b)"
+ "polymul(C c, C c') = C (c*\<^sub>Nc')"
+ "polymul(C c, CN c' n' p') =
+ (if c = 0\<^sub>N then 0\<^sub>p else CN (polymul(C c,c')) n' (polymul(C c, p')))"
+ "polymul(CN c n p, C c') =
+ (if c' = 0\<^sub>N then 0\<^sub>p else CN (polymul(c,C c')) n (polymul(p, C c')))"
+ "polymul(CN c n p, CN c' n' p') =
+ (if n<n' then CN (polymul(c,CN c' n' p')) n (polymul(p,CN c' n' p'))
+ else if n' < n
+ then CN (polymul(CN c n p,c')) n' (polymul(CN c n p,p'))
+ else polyadd(polymul(CN c n p, c'),CN 0\<^sub>p n' (polymul(CN c n p, p'))))"
+ "polymul (a,b) = Mul a b"
+recdef polypow "measure id"
+ "polypow 0 = (\<lambda>p. 1\<^sub>p)"
+ "polypow n = (\<lambda>p. let q = polypow (n div 2) p ; d = polymul(q,q) in
+ if even n then d else polymul(p,d))"
+
+consts polynate :: "poly \<Rightarrow> poly"
+recdef polynate "measure polysize"
+ "polynate (Bound n) = CN 0\<^sub>p n 1\<^sub>p"
+ "polynate (Add p q) = (polynate p +\<^sub>p polynate q)"
+ "polynate (Sub p q) = (polynate p -\<^sub>p polynate q)"
+ "polynate (Mul p q) = (polynate p *\<^sub>p polynate q)"
+ "polynate (Neg p) = (~\<^sub>p (polynate p))"
+ "polynate (Pw p n) = ((polynate p) ^\<^sub>p n)"
+ "polynate (CN c n p) = polynate (Add c (Mul (Bound n) p))"
+ "polynate (C c) = C (normNum c)"
+
+fun poly_cmul :: "Num \<Rightarrow> poly \<Rightarrow> poly" where
+ "poly_cmul y (C x) = C (y *\<^sub>N x)"
+| "poly_cmul y (CN c n p) = CN (poly_cmul y c) n (poly_cmul y p)"
+| "poly_cmul y p = C y *\<^sub>p p"
+
+constdefs monic:: "poly \<Rightarrow> (poly \<times> bool)"
+ "monic p \<equiv> (let h = headconst p in if h = 0\<^sub>N then (p,False) else ((C (Ninv h)) *\<^sub>p p, 0>\<^sub>N h))"
+
+subsection{* Pseudo-division *}
+
+constdefs shift1:: "poly \<Rightarrow> poly"
+ "shift1 p \<equiv> CN 0\<^sub>p 0 p"
+consts funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
+
+primrec
+ "funpow 0 f x = x"
+ "funpow (Suc n) f x = funpow n f (f x)"
+function (tailrec) polydivide_aux :: "(poly \<times> nat \<times> poly \<times> nat \<times> poly) \<Rightarrow> (nat \<times> poly)"
+ where
+ "polydivide_aux (a,n,p,k,s) =
+ (if s = 0\<^sub>p then (k,s)
+ else (let b = head s; m = degree s in
+ (if m < n then (k,s) else
+ (let p'= funpow (m - n) shift1 p in
+ (if a = b then polydivide_aux (a,n,p,k,s -\<^sub>p p')
+ else polydivide_aux (a,n,p,Suc k, (a *\<^sub>p s) -\<^sub>p (b *\<^sub>p p')))))))"
+ by pat_completeness auto
+
+
+constdefs polydivide:: "poly \<Rightarrow> poly \<Rightarrow> (nat \<times> poly)"
+ "polydivide s p \<equiv> polydivide_aux (head p,degree p,p,0, s)"
+
+fun poly_deriv_aux :: "nat \<Rightarrow> poly \<Rightarrow> poly" where
+ "poly_deriv_aux n (CN c 0 p) = CN (poly_cmul ((int n)\<^sub>N) c) 0 (poly_deriv_aux (n + 1) p)"
+| "poly_deriv_aux n p = poly_cmul ((int n)\<^sub>N) p"
+
+fun poly_deriv :: "poly \<Rightarrow> poly" where
+ "poly_deriv (CN c 0 p) = poly_deriv_aux 1 p"
+| "poly_deriv p = 0\<^sub>p"
+
+ (* Verification *)
+lemma nth_pos2[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"
+using Nat.gr0_conv_Suc
+by clarsimp
+
+subsection{* Semantics of the polynomial representation *}
+
+consts Ipoly :: "'a list \<Rightarrow> poly \<Rightarrow> 'a::{ring_char_0,power,division_by_zero,field}"
+primrec
+ "Ipoly bs (C c) = INum c"
+ "Ipoly bs (Bound n) = bs!n"
+ "Ipoly bs (Neg a) = - Ipoly bs a"
+ "Ipoly bs (Add a b) = Ipoly bs a + Ipoly bs b"
+ "Ipoly bs (Sub a b) = Ipoly bs a - Ipoly bs b"
+ "Ipoly bs (Mul a b) = Ipoly bs a * Ipoly bs b"
+ "Ipoly bs (Pw t n) = (Ipoly bs t) ^ n"
+ "Ipoly bs (CN c n p) = (Ipoly bs c) + (bs!n)*(Ipoly bs p)"
+syntax "_Ipoly" :: "poly \<Rightarrow> 'a list \<Rightarrow>'a::{ring_char_0,power,division_by_zero,field}" ("\<lparr>_\<rparr>\<^sub>p\<^bsup>_\<^esup>")
+translations "\<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup>" \<rightleftharpoons> "Ipoly bs p"
+
+lemma Ipoly_CInt: "Ipoly bs (C (i,1)) = of_int i"
+ by (simp add: INum_def)
+lemma Ipoly_CRat: "Ipoly bs (C (i, j)) = of_int i / of_int j"
+ by (simp add: INum_def)
+
+lemmas RIpoly_eqs = Ipoly.simps(2-7) Ipoly_CInt Ipoly_CRat
+
+subsection {* Normal form and normalization *}
+
+consts isnpolyh:: "poly \<Rightarrow> nat \<Rightarrow> bool"
+recdef isnpolyh "measure size"
+ "isnpolyh (C c) = (\<lambda>k. isnormNum c)"
+ "isnpolyh (CN c n p) = (\<lambda>k. n\<ge> k \<and> (isnpolyh c (Suc n)) \<and> (isnpolyh p n) \<and> (p \<noteq> 0\<^sub>p))"
+ "isnpolyh p = (\<lambda>k. False)"
+
+lemma isnpolyh_mono: "\<lbrakk>n' \<le> n ; isnpolyh p n\<rbrakk> \<Longrightarrow> isnpolyh p n'"
+by (induct p rule: isnpolyh.induct, auto)
+
+constdefs isnpoly:: "poly \<Rightarrow> bool"
+ "isnpoly p \<equiv> isnpolyh p 0"
+
+text{* polyadd preserves normal forms *}
+
+lemma polyadd_normh: "\<lbrakk>isnpolyh p n0 ; isnpolyh q n1\<rbrakk>
+ \<Longrightarrow> isnpolyh (polyadd(p,q)) (min n0 n1)"
+proof(induct p q arbitrary: n0 n1 rule: polyadd.induct)
+ case (2 a b c' n' p' n0 n1)
+ from prems have th1: "isnpolyh (C (a,b)) (Suc n')" by simp
+ from prems(3) have th2: "isnpolyh c' (Suc n')" and nplen1: "n' \<ge> n1" by simp_all
+ with isnpolyh_mono have cp: "isnpolyh c' (Suc n')" by simp
+ with prems(1)[OF th1 th2] have th3:"isnpolyh (C (a,b) +\<^sub>p c') (Suc n')" by simp
+ from nplen1 have n01len1: "min n0 n1 \<le> n'" by simp
+ thus ?case using prems th3 by simp
+next
+ case (3 c' n' p' a b n1 n0)
+ from prems have th1: "isnpolyh (C (a,b)) (Suc n')" by simp
+ from prems(2) have th2: "isnpolyh c' (Suc n')" and nplen1: "n' \<ge> n1" by simp_all
+ with isnpolyh_mono have cp: "isnpolyh c' (Suc n')" by simp
+ with prems(1)[OF th2 th1] have th3:"isnpolyh (c' +\<^sub>p C (a,b)) (Suc n')" by simp
+ from nplen1 have n01len1: "min n0 n1 \<le> n'" by simp
+ thus ?case using prems th3 by simp
+next
+ case (4 c n p c' n' p' n0 n1)
+ hence nc: "isnpolyh c (Suc n)" and np: "isnpolyh p n" by simp_all
+ from prems have nc': "isnpolyh c' (Suc n')" and np': "isnpolyh p' n'" by simp_all
+ from prems have ngen0: "n \<ge> n0" by simp
+ from prems have n'gen1: "n' \<ge> n1" by simp
+ have "n < n' \<or> n' < n \<or> n = n'" by auto
+ moreover {assume eq: "n = n'" hence eq': "\<not> n' < n \<and> \<not> n < n'" by simp
+ with prems(2)[rule_format, OF eq' nc nc']
+ have ncc':"isnpolyh (c +\<^sub>p c') (Suc n)" by auto
+ hence ncc'n01: "isnpolyh (c +\<^sub>p c') (min n0 n1)"
+ using isnpolyh_mono[where n'="min n0 n1" and n="Suc n"] ngen0 n'gen1 by auto
+ from eq prems(1)[rule_format, OF eq' np np'] have npp': "isnpolyh (p +\<^sub>p p') n" by simp
+ have minle: "min n0 n1 \<le> n'" using ngen0 n'gen1 eq by simp
+ from minle npp' ncc'n01 prems ngen0 n'gen1 ncc' have ?case by (simp add: Let_def)}
+ moreover {assume lt: "n < n'"
+ have "min n0 n1 \<le> n0" by simp
+ with prems have th1:"min n0 n1 \<le> n" by auto
+ from prems have th21: "isnpolyh c (Suc n)" by simp
+ from prems have th22: "isnpolyh (CN c' n' p') n'" by simp
+ from lt have th23: "min (Suc n) n' = Suc n" by arith
+ from prems(4)[rule_format, OF lt th21 th22]
+ have "isnpolyh (polyadd (c, CN c' n' p')) (Suc n)" using th23 by simp
+ with prems th1 have ?case by simp }
+ moreover {assume gt: "n' < n" hence gt': "n' < n \<and> \<not> n < n'" by simp
+ have "min n0 n1 \<le> n1" by simp
+ with prems have th1:"min n0 n1 \<le> n'" by auto
+ from prems have th21: "isnpolyh c' (Suc n')" by simp_all
+ from prems have th22: "isnpolyh (CN c n p) n" by simp
+ from gt have th23: "min n (Suc n') = Suc n'" by arith
+ from prems(3)[rule_format, OF gt' th22 th21]
+ have "isnpolyh (polyadd (CN c n p,c')) (Suc n')" using th23 by simp
+ with prems th1 have ?case by simp}
+ ultimately show ?case by blast
+qed auto
+
+lemma polyadd[simp]: "Ipoly bs (polyadd (p,q)) = (Ipoly bs p) + (Ipoly bs q)"
+by (induct p q rule: polyadd.induct, auto simp add: Let_def ring_simps right_distrib[symmetric] simp del: right_distrib)
+
+lemma polyadd_norm: "\<lbrakk> isnpoly p ; isnpoly q\<rbrakk> \<Longrightarrow> isnpoly (polyadd(p,q))"
+ using polyadd_normh[of "p" "0" "q" "0"] isnpoly_def by simp
+
+text{* The degree of addition and other general lemmas needed for the normal form of polymul*}
+
+lemma polyadd_different_degreen:
+ "\<lbrakk>isnpolyh p n0 ; isnpolyh q n1; degreen p m \<noteq> degreen q m ; m \<le> min n0 n1\<rbrakk> \<Longrightarrow>
+ degreen (polyadd(p,q)) m = max (degreen p m) (degreen q m)"
+proof (induct p q arbitrary: m n0 n1 rule: polyadd.induct)
+ case (4 c n p c' n' p' m n0 n1)
+ thus ?case
+ apply (cases "n' < n", simp_all add: Let_def)
+ apply (cases "n = n'", simp_all)
+ apply (cases "n' = m", simp_all add: Let_def)
+ by (erule allE[where x="m"], erule allE[where x="Suc m"],
+ erule allE[where x="m"], erule allE[where x="Suc m"],
+ clarsimp,erule allE[where x="m"],erule allE[where x="Suc m"], simp)
+qed simp_all
+
+lemma headnz[simp]: "\<lbrakk>isnpolyh p n ; p \<noteq> 0\<^sub>p\<rbrakk> \<Longrightarrow> headn p m \<noteq> 0\<^sub>p"
+ by (induct p arbitrary: n rule: headn.induct, auto)
+lemma degree_isnpolyh_Suc[simp]: "isnpolyh p (Suc n) \<Longrightarrow> degree p = 0"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+lemma degreen_0[simp]: "isnpolyh p n \<Longrightarrow> m < n \<Longrightarrow> degreen p m = 0"
+ by (induct p arbitrary: n rule: degreen.induct, auto)
+
+lemma degree_isnpolyh_Suc': "n > 0 \<Longrightarrow> isnpolyh p n \<Longrightarrow> degree p = 0"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+
+lemma degree_npolyhCN[simp]: "isnpolyh (CN c n p) n0 \<Longrightarrow> degree c = 0"
+ using degree_isnpolyh_Suc by auto
+lemma degreen_npolyhCN[simp]: "isnpolyh (CN c n p) n0 \<Longrightarrow> degreen c n = 0"
+ using degreen_0 by auto
+
+
+lemma degreen_polyadd:
+ assumes np: "isnpolyh p n0" and nq: "isnpolyh q n1" and m: "m \<le> max n0 n1"
+ shows "degreen (p +\<^sub>p q) m \<le> max (degreen p m) (degreen q m)"
+ using np nq m
+proof (induct p q arbitrary: n0 n1 m rule: polyadd.induct)
+ case (2 c c' n' p' n0 n1) thus ?case by (cases n', simp_all)
+next
+ case (3 c n p c' n0 n1) thus ?case by (cases n, auto)
+next
+ case (4 c n p c' n' p' n0 n1 m)
+ thus ?case
+ apply (cases "n < n'", simp_all add: Let_def)
+ apply (cases "n' < n", simp_all)
+ apply (erule allE[where x="n"],erule allE[where x="Suc n"],clarify)
+ apply (erule allE[where x="n'"],erule allE[where x="Suc n'"],clarify)
+ by (erule allE[where x="m"],erule allE[where x="m"], auto)
+qed auto
+
+
+lemma polyadd_eq_const_degreen: "\<lbrakk> isnpolyh p n0 ; isnpolyh q n1 ; polyadd (p,q) = C c\<rbrakk>
+ \<Longrightarrow> degreen p m = degreen q m"
+proof (induct p q arbitrary: m n0 n1 c rule: polyadd.induct)
+ case (4 c n p c' n' p' m n0 n1 x)
+ hence z: "CN c n p +\<^sub>p CN c' n' p' = C x" by simp
+ {assume nn': "n' < n" hence ?case using prems by simp}
+ moreover
+ {assume nn':"\<not> n' < n" hence "n < n' \<or> n = n'" by arith
+ moreover {assume "n < n'" with prems have ?case by simp }
+ moreover {assume eq: "n = n'" hence ?case using prems
+ by (cases "p +\<^sub>p p' = 0\<^sub>p", auto simp add: Let_def) }
+ ultimately have ?case by blast}
+ ultimately show ?case by blast
+qed simp_all
+
+lemma polymul_properties:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and nq: "isnpolyh q n1" and m: "m \<le> min n0 n1"
+ shows "isnpolyh (p *\<^sub>p q) (min n0 n1)"
+ and "(p *\<^sub>p q = 0\<^sub>p) = (p = 0\<^sub>p \<or> q = 0\<^sub>p)"
+ and "degreen (p *\<^sub>p q) m = (if (p = 0\<^sub>p \<or> q = 0\<^sub>p) then 0
+ else degreen p m + degreen q m)"
+ using np nq m
+proof(induct p q arbitrary: n0 n1 m rule: polymul.induct)
+ case (2 a b c' n' p')
+ let ?c = "(a,b)"
+ { case (1 n0 n1)
+ hence n: "isnpolyh (C ?c) n'" "isnpolyh c' (Suc n')" "isnpolyh p' n'" "isnormNum ?c"
+ "isnpolyh (CN c' n' p') n1"
+ by simp_all
+ {assume "?c = 0\<^sub>N" hence ?case by auto}
+ moreover {assume cnz: "?c \<noteq> 0\<^sub>N"
+ from "2.hyps"(1)[rule_format,where xb="n'", OF cnz n(1) n(3)]
+ "2.hyps"(2)[rule_format, where x="Suc n'"
+ and xa="Suc n'" and xb = "n'", OF cnz ] cnz n have ?case
+ by (auto simp add: min_def)}
+ ultimately show ?case by blast
+ next
+ case (2 n0 n1) thus ?case by auto
+ next
+ case (3 n0 n1) thus ?case using "2.hyps" by auto }
+next
+ case (3 c n p a b){
+ let ?c' = "(a,b)"
+ case (1 n0 n1)
+ hence n: "isnpolyh (C ?c') n" "isnpolyh c (Suc n)" "isnpolyh p n" "isnormNum ?c'"
+ "isnpolyh (CN c n p) n0"
+ by simp_all
+ {assume "?c' = 0\<^sub>N" hence ?case by auto}
+ moreover {assume cnz: "?c' \<noteq> 0\<^sub>N"
+ from "3.hyps"(1)[rule_format,where xb="n", OF cnz n(3) n(1)]
+ "3.hyps"(2)[rule_format, where x="Suc n"
+ and xa="Suc n" and xb = "n", OF cnz ] cnz n have ?case
+ by (auto simp add: min_def)}
+ ultimately show ?case by blast
+ next
+ case (2 n0 n1) thus ?case apply auto done
+ next
+ case (3 n0 n1) thus ?case using "3.hyps" by auto }
+next
+ case (4 c n p c' n' p')
+ let ?cnp = "CN c n p" let ?cnp' = "CN c' n' p'"
+ {fix n0 n1
+ assume "isnpolyh ?cnp n0" and "isnpolyh ?cnp' n1"
+ hence cnp: "isnpolyh ?cnp n" and cnp': "isnpolyh ?cnp' n'"
+ and np: "isnpolyh p n" and nc: "isnpolyh c (Suc n)"
+ and np': "isnpolyh p' n'" and nc': "isnpolyh c' (Suc n')"
+ and nn0: "n \<ge> n0" and nn1:"n' \<ge> n1"
+ by simp_all
+ have "n < n' \<or> n' < n \<or> n' = n" by auto
+ moreover
+ {assume nn': "n < n'"
+ with "4.hyps"(5)[rule_format, OF nn' np cnp', where xb ="n"]
+ "4.hyps"(6)[rule_format, OF nn' nc cnp', where xb="n"] nn' nn0 nn1 cnp
+ have "isnpolyh (?cnp *\<^sub>p ?cnp') (min n0 n1)"
+ by (simp add: min_def) }
+ moreover
+
+ {assume nn': "n > n'" hence stupid: "n' < n \<and> \<not> n < n'" by arith
+ with "4.hyps"(3)[rule_format, OF stupid cnp np', where xb="n'"]
+ "4.hyps"(4)[rule_format, OF stupid cnp nc', where xb="Suc n'"]
+ nn' nn0 nn1 cnp'
+ have "isnpolyh (?cnp *\<^sub>p ?cnp') (min n0 n1)"
+ by (cases "Suc n' = n", simp_all add: min_def)}
+ moreover
+ {assume nn': "n' = n" hence stupid: "\<not> n' < n \<and> \<not> n < n'" by arith
+ from "4.hyps"(1)[rule_format, OF stupid cnp np', where xb="n"]
+ "4.hyps"(2)[rule_format, OF stupid cnp nc', where xb="n"] nn' cnp cnp' nn1
+
+ have "isnpolyh (?cnp *\<^sub>p ?cnp') (min n0 n1)"
+ by simp (rule polyadd_normh,simp_all add: min_def isnpolyh_mono[OF nn0]) }
+ ultimately show "isnpolyh (?cnp *\<^sub>p ?cnp') (min n0 n1)" by blast }
+ note th = this
+ {fix n0 n1 m
+ assume np: "isnpolyh ?cnp n0" and np':"isnpolyh ?cnp' n1"
+ and m: "m \<le> min n0 n1"
+ let ?d = "degreen (?cnp *\<^sub>p ?cnp') m"
+ let ?d1 = "degreen ?cnp m"
+ let ?d2 = "degreen ?cnp' m"
+ let ?eq = "?d = (if ?cnp = 0\<^sub>p \<or> ?cnp' = 0\<^sub>p then 0 else ?d1 + ?d2)"
+ have "n'<n \<or> n < n' \<or> n' = n" by auto
+ moreover
+ {assume "n' < n \<or> n < n'"
+ with "4.hyps" np np' m
+ have ?eq apply (cases "n' < n", simp_all)
+ apply (erule allE[where x="n"],erule allE[where x="n"],auto)
+ done }
+ moreover
+ {assume nn': "n' = n" hence nn:"\<not> n' < n \<and> \<not> n < n'" by arith
+ from "4.hyps"(1)[rule_format, OF nn, where x="n" and xa ="n'" and xb="n"]
+ "4.hyps"(2)[rule_format, OF nn, where x="n" and xa ="Suc n'" and xb="n"]
+ np np' nn'
+ have norm: "isnpolyh ?cnp n" "isnpolyh c' (Suc n)" "isnpolyh (?cnp *\<^sub>p c') n"
+ "isnpolyh p' n" "isnpolyh (?cnp *\<^sub>p p') n" "isnpolyh (CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n"
+ "(?cnp *\<^sub>p c' = 0\<^sub>p) = (c' = 0\<^sub>p)"
+ "?cnp *\<^sub>p p' \<noteq> 0\<^sub>p" by (auto simp add: min_def)
+ {assume mn: "m = n"
+ from "4.hyps"(1)[rule_format, OF nn norm(1,4), where xb="n"]
+ "4.hyps"(2)[rule_format, OF nn norm(1,2), where xb="n"] norm nn' mn
+ have degs: "degreen (?cnp *\<^sub>p c') n =
+ (if c'=0\<^sub>p then 0 else ?d1 + degreen c' n)"
+ "degreen (?cnp *\<^sub>p p') n = ?d1 + degreen p' n" by (simp_all add: min_def)
+ from degs norm
+ have th1: "degreen(?cnp *\<^sub>p c') n < degreen (CN 0\<^sub>p n (?cnp *\<^sub>p p')) n" by simp
+ hence neq: "degreen (?cnp *\<^sub>p c') n \<noteq> degreen (CN 0\<^sub>p n (?cnp *\<^sub>p p')) n"
+ by simp
+ have nmin: "n \<le> min n n" by (simp add: min_def)
+ from polyadd_different_degreen[OF norm(3,6) neq nmin] th1
+ have deg: "degreen (CN c n p *\<^sub>p c' +\<^sub>p CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n = degreen (CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n" by simp
+ from "4.hyps"(1)[rule_format, OF nn norm(1,4), where xb="n"]
+ "4.hyps"(2)[rule_format, OF nn norm(1,2), where xb="n"]
+ mn norm m nn' deg
+ have ?eq by simp}
+ moreover
+ {assume mn: "m \<noteq> n" hence mn': "m < n" using m np by auto
+ from nn' m np have max1: "m \<le> max n n" by simp
+ hence min1: "m \<le> min n n" by simp
+ hence min2: "m \<le> min n (Suc n)" by simp
+ {assume "c' = 0\<^sub>p"
+ from `c' = 0\<^sub>p` have ?eq
+ using "4.hyps"(1)[rule_format, OF nn norm(1,4) min1]
+ "4.hyps"(2)[rule_format, OF nn norm(1,2) min2] mn nn'
+ apply simp
+ done}
+ moreover
+ {assume cnz: "c' \<noteq> 0\<^sub>p"
+ from "4.hyps"(1)[rule_format, OF nn norm(1,4) min1]
+ "4.hyps"(2)[rule_format, OF nn norm(1,2) min2]
+ degreen_polyadd[OF norm(3,6) max1]
+
+ have "degreen (?cnp *\<^sub>p c' +\<^sub>p CN 0\<^sub>p n (?cnp *\<^sub>p p')) m
+ \<le> max (degreen (?cnp *\<^sub>p c') m) (degreen (CN 0\<^sub>p n (?cnp *\<^sub>p p')) m)"
+ using mn nn' cnz np np' by simp
+ with "4.hyps"(1)[rule_format, OF nn norm(1,4) min1]
+ "4.hyps"(2)[rule_format, OF nn norm(1,2) min2]
+ degreen_0[OF norm(3) mn'] have ?eq using nn' mn cnz np np' by clarsimp}
+ ultimately have ?eq by blast }
+ ultimately have ?eq by blast}
+ ultimately show ?eq by blast}
+ note degth = this
+ { case (2 n0 n1)
+ hence np: "isnpolyh ?cnp n0" and np': "isnpolyh ?cnp' n1"
+ and m: "m \<le> min n0 n1" by simp_all
+ hence mn: "m \<le> n" by simp
+ let ?c0p = "CN 0\<^sub>p n (?cnp *\<^sub>p p')"
+ {assume C: "?cnp *\<^sub>p c' +\<^sub>p ?c0p = 0\<^sub>p" "n' = n"
+ hence nn: "\<not>n' < n \<and> \<not> n<n'" by simp
+ from "4.hyps"(1) [rule_format, OF nn, where x="n" and xa = "n" and xb="n"]
+ "4.hyps"(2) [rule_format, OF nn, where x="n" and xa = "Suc n" and xb="n"]
+ np np' C(2) mn
+ have norm: "isnpolyh ?cnp n" "isnpolyh c' (Suc n)" "isnpolyh (?cnp *\<^sub>p c') n"
+ "isnpolyh p' n" "isnpolyh (?cnp *\<^sub>p p') n" "isnpolyh (CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n"
+ "(?cnp *\<^sub>p c' = 0\<^sub>p) = (c' = 0\<^sub>p)"
+ "?cnp *\<^sub>p p' \<noteq> 0\<^sub>p"
+ "degreen (?cnp *\<^sub>p c') n = (if c'=0\<^sub>p then 0 else degreen ?cnp n + degreen c' n)"
+ "degreen (?cnp *\<^sub>p p') n = degreen ?cnp n + degreen p' n"
+ by (simp_all add: min_def)
+
+ from norm have cn: "isnpolyh (CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n" by simp
+ have degneq: "degreen (?cnp *\<^sub>p c') n < degreen (CN 0\<^sub>p n (?cnp *\<^sub>p p')) n"
+ using norm by simp
+ from polyadd_eq_const_degreen[OF norm(3) cn C(1), where m="n"] degneq
+ have "False" by simp }
+ thus ?case using "4.hyps" by clarsimp}
+qed auto
+
+lemma polymul[simp]: "Ipoly bs (p *\<^sub>p q) = (Ipoly bs p) * (Ipoly bs q)"
+by(induct p q rule: polymul.induct, auto simp add: ring_simps)
+
+lemma polymul_normh:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk>isnpolyh p n0 ; isnpolyh q n1\<rbrakk> \<Longrightarrow> isnpolyh (p *\<^sub>p q) (min n0 n1)"
+ using polymul_properties(1) by blast
+lemma polymul_eq0_iff:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk> isnpolyh p n0 ; isnpolyh q n1\<rbrakk> \<Longrightarrow> (p *\<^sub>p q = 0\<^sub>p) = (p = 0\<^sub>p \<or> q = 0\<^sub>p) "
+ using polymul_properties(2) by blast
+lemma polymul_degreen:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk> isnpolyh p n0 ; isnpolyh q n1 ; m \<le> min n0 n1\<rbrakk> \<Longrightarrow> degreen (p *\<^sub>p q) m = (if (p = 0\<^sub>p \<or> q = 0\<^sub>p) then 0 else degreen p m + degreen q m)"
+ using polymul_properties(3) by blast
+lemma polymul_norm:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk> isnpoly p; isnpoly q\<rbrakk> \<Longrightarrow> isnpoly (polymul (p,q))"
+ using polymul_normh[of "p" "0" "q" "0"] isnpoly_def by simp
+
+lemma headconst_zero: "isnpolyh p n0 \<Longrightarrow> headconst p = 0\<^sub>N \<longleftrightarrow> p = 0\<^sub>p"
+ by (induct p arbitrary: n0 rule: headconst.induct, auto)
+
+lemma headconst_isnormNum: "isnpolyh p n0 \<Longrightarrow> isnormNum (headconst p)"
+ by (induct p arbitrary: n0, auto)
+
+lemma monic_eqI: assumes np: "isnpolyh p n0"
+ shows "INum (headconst p) * Ipoly bs (fst (monic p)) = (Ipoly bs p ::'a::{ring_char_0,power,division_by_zero,field})"
+ unfolding monic_def Let_def
+proof(cases "headconst p = 0\<^sub>N", simp_all add: headconst_zero[OF np])
+ let ?h = "headconst p"
+ assume pz: "p \<noteq> 0\<^sub>p"
+ {assume hz: "INum ?h = (0::'a)"
+ from headconst_isnormNum[OF np] have norm: "isnormNum ?h" "isnormNum 0\<^sub>N" by simp_all
+ from isnormNum_unique[where ?'a = 'a, OF norm] hz have "?h = 0\<^sub>N" by simp
+ with headconst_zero[OF np] have "p =0\<^sub>p" by blast with pz have "False" by blast}
+ thus "INum (headconst p) = (0::'a) \<longrightarrow> \<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> = 0" by blast
+qed
+
+
+
+
+text{* polyneg is a negation and preserves normal form *}
+lemma polyneg[simp]: "Ipoly bs (polyneg p) = - Ipoly bs p"
+by (induct p rule: polyneg.induct, auto)
+
+lemma polyneg0: "isnpolyh p n \<Longrightarrow> ((~\<^sub>p p) = 0\<^sub>p) = (p = 0\<^sub>p)"
+ by (induct p arbitrary: n rule: polyneg.induct, auto simp add: Nneg_def)
+lemma polyneg_polyneg: "isnpolyh p n0 \<Longrightarrow> ~\<^sub>p (~\<^sub>p p) = p"
+ by (induct p arbitrary: n0 rule: polyneg.induct, auto)
+lemma polyneg_normh: "\<And>n. isnpolyh p n \<Longrightarrow> isnpolyh (polyneg p) n "
+by (induct p rule: polyneg.induct, auto simp add: polyneg0)
+
+lemma polyneg_norm: "isnpoly p \<Longrightarrow> isnpoly (polyneg p)"
+ using isnpoly_def polyneg_normh by simp
+
+
+text{* polysub is a substraction and preserves normalform *}
+lemma polysub[simp]: "Ipoly bs (polysub (p,q)) = (Ipoly bs p) - (Ipoly bs q)"
+by (simp add: polysub_def polyneg polyadd)
+lemma polysub_normh: "\<And> n0 n1. \<lbrakk> isnpolyh p n0 ; isnpolyh q n1\<rbrakk> \<Longrightarrow> isnpolyh (polysub(p,q)) (min n0 n1)"
+by (simp add: polysub_def polyneg_normh polyadd_normh)
+
+lemma polysub_norm: "\<lbrakk> isnpoly p; isnpoly q\<rbrakk> \<Longrightarrow> isnpoly (polysub(p,q))"
+ using polyadd_norm polyneg_norm by (simp add: polysub_def)
+lemma polysub_same_0[simp]: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "isnpolyh p n0 \<Longrightarrow> polysub (p, p) = 0\<^sub>p"
+unfolding polysub_def split_def fst_conv snd_conv
+by (induct p arbitrary: n0,auto simp add: Let_def Nsub0[simplified Nsub_def])
+
+lemma polysub_0:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk> isnpolyh p n0 ; isnpolyh q n1\<rbrakk> \<Longrightarrow> (p -\<^sub>p q = 0\<^sub>p) = (p = q)"
+ unfolding polysub_def split_def fst_conv snd_conv
+ apply (induct p q arbitrary: n0 n1 rule:polyadd.induct, simp_all add: Nsub0[simplified Nsub_def])
+ apply (clarsimp simp add: Let_def)
+ apply (case_tac "n < n'", simp_all)
+ apply (case_tac "n' < n", simp_all)
+ apply (erule impE)+
+ apply (rule_tac x="Suc n" in exI, simp)
+ apply (rule_tac x="n" in exI, simp)
+ apply (erule impE)+
+ apply (rule_tac x="n" in exI, simp)
+ apply (rule_tac x="Suc n" in exI, simp)
+ apply (erule impE)+
+ apply (rule_tac x="Suc n" in exI, simp)
+ apply (rule_tac x="n" in exI, simp)
+ apply (erule impE)+
+ apply (rule_tac x="Suc n" in exI, simp)
+ apply clarsimp
+ done
+
+text{* polypow is a power function and preserves normal forms *}
+lemma polypow[simp]: "Ipoly bs (polypow n p) = ((Ipoly bs p :: 'a::{ring_char_0,division_by_zero,field})) ^ n"
+proof(induct n rule: polypow.induct)
+ case 1 thus ?case by simp
+next
+ case (2 n)
+ let ?q = "polypow ((Suc n) div 2) p"
+ let ?d = "polymul(?q,?q)"
+ have "odd (Suc n) \<or> even (Suc n)" by simp
+ moreover
+ {assume odd: "odd (Suc n)"
+ have th: "(Suc (Suc (Suc (0\<Colon>nat)) * (Suc n div Suc (Suc (0\<Colon>nat))))) = Suc n div 2 + Suc n div 2 + 1" by arith
+ from odd have "Ipoly bs (p ^\<^sub>p Suc n) = Ipoly bs (polymul(p, ?d))" by (simp add: Let_def)
+ also have "\<dots> = (Ipoly bs p) * (Ipoly bs p)^(Suc n div 2)*(Ipoly bs p)^(Suc n div 2)"
+ using "2.hyps" by simp
+ also have "\<dots> = (Ipoly bs p) ^ (Suc n div 2 + Suc n div 2 + 1)"
+ apply (simp only: power_add power_one_right) by simp
+ also have "\<dots> = (Ipoly bs p) ^ (Suc (Suc (Suc (0\<Colon>nat)) * (Suc n div Suc (Suc (0\<Colon>nat)))))"
+ by (simp only: th)
+ finally have ?case
+ using odd_nat_div_two_times_two_plus_one[OF odd, symmetric] by simp }
+ moreover
+ {assume even: "even (Suc n)"
+ have th: "(Suc (Suc (0\<Colon>nat))) * (Suc n div Suc (Suc (0\<Colon>nat))) = Suc n div 2 + Suc n div 2" by arith
+ from even have "Ipoly bs (p ^\<^sub>p Suc n) = Ipoly bs ?d" by (simp add: Let_def)
+ also have "\<dots> = (Ipoly bs p) ^ (Suc n div 2 + Suc n div 2)"
+ using "2.hyps" apply (simp only: power_add) by simp
+ finally have ?case using even_nat_div_two_times_two[OF even] by (simp only: th)}
+ ultimately show ?case by blast
+qed
+
+lemma polypow_normh:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "isnpolyh p n \<Longrightarrow> isnpolyh (polypow k p) n"
+proof (induct k arbitrary: n rule: polypow.induct)
+ case (2 k n)
+ let ?q = "polypow (Suc k div 2) p"
+ let ?d = "polymul (?q,?q)"
+ from prems have th1:"isnpolyh ?q n" and th2: "isnpolyh p n" by blast+
+ from polymul_normh[OF th1 th1] have dn: "isnpolyh ?d n" by simp
+ from polymul_normh[OF th2 dn] have on: "isnpolyh (polymul(p,?d)) n" by simp
+ from dn on show ?case by (simp add: Let_def)
+qed auto
+
+lemma polypow_norm:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "isnpoly p \<Longrightarrow> isnpoly (polypow k p)"
+ by (simp add: polypow_normh isnpoly_def)
+
+text{* Finally the whole normalization*}
+
+lemma polynate[simp]: "Ipoly bs (polynate p) = (Ipoly bs p :: 'a ::{ring_char_0,division_by_zero,field})"
+by (induct p rule:polynate.induct, auto)
+
+lemma polynate_norm[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "isnpoly (polynate p)"
+ by (induct p rule: polynate.induct, simp_all add: polyadd_norm polymul_norm polysub_norm polyneg_norm polypow_norm) (simp_all add: isnpoly_def)
+
+text{* shift1 *}
+
+
+lemma shift1: "Ipoly bs (shift1 p) = Ipoly bs (Mul (Bound 0) p)"
+by (simp add: shift1_def polymul)
+
+lemma shift1_isnpoly:
+ assumes pn: "isnpoly p" and pnz: "p \<noteq> 0\<^sub>p" shows "isnpoly (shift1 p) "
+ using pn pnz by (simp add: shift1_def isnpoly_def )
+
+lemma shift1_nz[simp]:"shift1 p \<noteq> 0\<^sub>p"
+ by (simp add: shift1_def)
+lemma funpow_shift1_isnpoly:
+ "\<lbrakk> isnpoly p ; p \<noteq> 0\<^sub>p\<rbrakk> \<Longrightarrow> isnpoly (funpow n shift1 p)"
+ by (induct n arbitrary: p, auto simp add: shift1_isnpoly)
+
+lemma funpow_isnpolyh:
+ assumes f: "\<And> p. isnpolyh p n \<Longrightarrow> isnpolyh (f p) n "and np: "isnpolyh p n"
+ shows "isnpolyh (funpow k f p) n"
+ using f np by (induct k arbitrary: p, auto)
+
+lemma funpow_shift1: "(Ipoly bs (funpow n shift1 p) :: 'a :: {ring_char_0,division_by_zero,field}) = Ipoly bs (Mul (Pw (Bound 0) n) p)"
+ by (induct n arbitrary: p, simp_all add: shift1_isnpoly shift1 power_Suc )
+
+lemma shift1_isnpolyh: "isnpolyh p n0 \<Longrightarrow> p\<noteq> 0\<^sub>p \<Longrightarrow> isnpolyh (shift1 p) 0"
+ using isnpolyh_mono[where n="n0" and n'="0" and p="p"] by (simp add: shift1_def)
+
+lemma funpow_shift1_1:
+ "(Ipoly bs (funpow n shift1 p) :: 'a :: {ring_char_0,division_by_zero,field}) = Ipoly bs (funpow n shift1 1\<^sub>p *\<^sub>p p)"
+ by (simp add: funpow_shift1)
+
+lemma poly_cmul[simp]: "Ipoly bs (poly_cmul c p) = Ipoly bs (Mul (C c) p)"
+by (induct p arbitrary: n0 rule: poly_cmul.induct, auto simp add: ring_simps)
+
+lemma behead:
+ assumes np: "isnpolyh p n"
+ shows "Ipoly bs (Add (Mul (head p) (Pw (Bound 0) (degree p))) (behead p)) = (Ipoly bs p :: 'a :: {ring_char_0,division_by_zero,field})"
+ using np
+proof (induct p arbitrary: n rule: behead.induct)
+ case (1 c p n) hence pn: "isnpolyh p n" by simp
+ from prems(2)[OF pn]
+ have th:"Ipoly bs (Add (Mul (head p) (Pw (Bound 0) (degree p))) (behead p)) = Ipoly bs p" .
+ then show ?case using "1.hyps" apply (simp add: Let_def,cases "behead p = 0\<^sub>p")
+ by (simp_all add: th[symmetric] ring_simps power_Suc)
+qed (auto simp add: Let_def)
+
+lemma behead_isnpolyh:
+ assumes np: "isnpolyh p n" shows "isnpolyh (behead p) n"
+ using np by (induct p rule: behead.induct, auto simp add: Let_def isnpolyh_mono)
+
+subsection{* Miscilanious lemmas about indexes, decrementation, substitution etc ... *}
+lemma isnpolyh_polybound0: "isnpolyh p (Suc n) \<Longrightarrow> polybound0 p"
+proof(induct p arbitrary: n rule: polybound0.induct, auto)
+ case (goal1 c n p n')
+ hence "n = Suc (n - 1)" by simp
+ hence "isnpolyh p (Suc (n - 1))" using `isnpolyh p n` by simp
+ with prems(2) show ?case by simp
+qed
+
+lemma isconstant_polybound0: "isnpolyh p n0 \<Longrightarrow> isconstant p \<longleftrightarrow> polybound0 p"
+by (induct p arbitrary: n0 rule: isconstant.induct, auto simp add: isnpolyh_polybound0)
+
+lemma decrpoly_zero[simp]: "decrpoly p = 0\<^sub>p \<longleftrightarrow> p = 0\<^sub>p" by (induct p, auto)
+
+lemma decrpoly_normh: "isnpolyh p n0 \<Longrightarrow> polybound0 p \<Longrightarrow> isnpolyh (decrpoly p) (n0 - 1)"
+ apply (induct p arbitrary: n0, auto)
+ apply (atomize)
+ apply (erule_tac x = "Suc nat" in allE)
+ apply auto
+ done
+
+lemma head_polybound0: "isnpolyh p n0 \<Longrightarrow> polybound0 (head p)"
+ by (induct p arbitrary: n0 rule: head.induct, auto intro: isnpolyh_polybound0)
+
+lemma polybound0_I:
+ assumes nb: "polybound0 a"
+ shows "Ipoly (b#bs) a = Ipoly (b'#bs) a"
+using nb
+by (induct a rule: polybound0.induct) auto
+lemma polysubst0_I:
+ shows "Ipoly (b#bs) (polysubst0 a t) = Ipoly ((Ipoly (b#bs) a)#bs) t"
+ by (induct t) simp_all
+
+lemma polysubst0_I':
+ assumes nb: "polybound0 a"
+ shows "Ipoly (b#bs) (polysubst0 a t) = Ipoly ((Ipoly (b'#bs) a)#bs) t"
+ by (induct t) (simp_all add: polybound0_I[OF nb, where b="b" and b'="b'"])
+
+lemma decrpoly: assumes nb: "polybound0 t"
+ shows "Ipoly (x#bs) t = Ipoly bs (decrpoly t)"
+ using nb by (induct t rule: decrpoly.induct, simp_all)
+
+lemma polysubst0_polybound0: assumes nb: "polybound0 t"
+ shows "polybound0 (polysubst0 t a)"
+using nb by (induct a rule: polysubst0.induct, auto)
+
+lemma degree0_polybound0: "isnpolyh p n \<Longrightarrow> degree p = 0 \<Longrightarrow> polybound0 p"
+ by (induct p arbitrary: n rule: degree.induct, auto simp add: isnpolyh_polybound0)
+
+fun maxindex :: "poly \<Rightarrow> nat" where
+ "maxindex (Bound n) = n + 1"
+| "maxindex (CN c n p) = max (n + 1) (max (maxindex c) (maxindex p))"
+| "maxindex (Add p q) = max (maxindex p) (maxindex q)"
+| "maxindex (Sub p q) = max (maxindex p) (maxindex q)"
+| "maxindex (Mul p q) = max (maxindex p) (maxindex q)"
+| "maxindex (Neg p) = maxindex p"
+| "maxindex (Pw p n) = maxindex p"
+| "maxindex (C x) = 0"
+
+definition wf_bs :: "'a list \<Rightarrow> poly \<Rightarrow> bool" where
+ "wf_bs bs p = (length bs \<ge> maxindex p)"
+
+lemma wf_bs_coefficients: "wf_bs bs p \<Longrightarrow> \<forall> c \<in> set (coefficients p). wf_bs bs c"
+proof(induct p rule: coefficients.induct)
+ case (1 c p)
+ show ?case
+ proof
+ fix x assume xc: "x \<in> set (coefficients (CN c 0 p))"
+ hence "x = c \<or> x \<in> set (coefficients p)" by simp
+ moreover
+ {assume "x = c" hence "wf_bs bs x" using "1.prems" unfolding wf_bs_def by simp}
+ moreover
+ {assume H: "x \<in> set (coefficients p)"
+ from "1.prems" have "wf_bs bs p" unfolding wf_bs_def by simp
+ with "1.hyps" H have "wf_bs bs x" by blast }
+ ultimately show "wf_bs bs x" by blast
+ qed
+qed simp_all
+
+lemma maxindex_coefficients: " \<forall>c\<in> set (coefficients p). maxindex c \<le> maxindex p"
+by (induct p rule: coefficients.induct, auto)
+
+lemma length_exists: "\<exists>xs. length xs = n" by (rule exI[where x="replicate n x"], simp)
+
+lemma wf_bs_I: "wf_bs bs p ==> Ipoly (bs@bs') p = Ipoly bs p"
+ unfolding wf_bs_def by (induct p, auto simp add: nth_append)
+
+lemma take_maxindex_wf: assumes wf: "wf_bs bs p"
+ shows "Ipoly (take (maxindex p) bs) p = Ipoly bs p"
+proof-
+ let ?ip = "maxindex p"
+ let ?tbs = "take ?ip bs"
+ from wf have "length ?tbs = ?ip" unfolding wf_bs_def by simp
+ hence wf': "wf_bs ?tbs p" unfolding wf_bs_def by simp
+ have eq: "bs = ?tbs @ (drop ?ip bs)" by simp
+ from wf_bs_I[OF wf', of "drop ?ip bs"] show ?thesis using eq by simp
+qed
+
+lemma decr_maxindex: "polybound0 p \<Longrightarrow> maxindex (decrpoly p) = maxindex p - 1"
+ by (induct p, auto)
+
+lemma wf_bs_insensitive: "length bs = length bs' \<Longrightarrow> wf_bs bs p = wf_bs bs' p"
+ unfolding wf_bs_def by simp
+
+lemma wf_bs_insensitive': "wf_bs (x#bs) p = wf_bs (y#bs) p"
+ unfolding wf_bs_def by simp
+
+
+
+lemma wf_bs_coefficients': "\<forall>c \<in> set (coefficients p). wf_bs bs c \<Longrightarrow> wf_bs (x#bs) p"
+by(induct p rule: coefficients.induct, auto simp add: wf_bs_def)
+lemma coefficients_Nil[simp]: "coefficients p \<noteq> []"
+ by (induct p rule: coefficients.induct, simp_all)
+
+
+lemma coefficients_head: "last (coefficients p) = head p"
+ by (induct p rule: coefficients.induct, auto)
+
+lemma wf_bs_decrpoly: "wf_bs bs (decrpoly p) \<Longrightarrow> wf_bs (x#bs) p"
+ unfolding wf_bs_def by (induct p rule: decrpoly.induct, auto)
+
+lemma length_le_list_ex: "length xs \<le> n \<Longrightarrow> \<exists> ys. length (xs @ ys) = n"
+ apply (rule exI[where x="replicate (n - length xs) z"])
+ by simp
+lemma isnpolyh_Suc_const:"isnpolyh p (Suc n) \<Longrightarrow> isconstant p"
+by (cases p, auto) (case_tac "nat", simp_all)
+
+lemma wf_bs_polyadd: "wf_bs bs p \<and> wf_bs bs q \<longrightarrow> wf_bs bs (p +\<^sub>p q)"
+ unfolding wf_bs_def
+ apply (induct p q rule: polyadd.induct)
+ apply (auto simp add: Let_def)
+ done
+
+lemma wf_bs_polyul: "wf_bs bs p \<Longrightarrow> wf_bs bs q \<Longrightarrow> wf_bs bs (p *\<^sub>p q)"
+
+ unfolding wf_bs_def
+ apply (induct p q arbitrary: bs rule: polymul.induct)
+ apply (simp_all add: wf_bs_polyadd)
+ apply clarsimp
+ apply (rule wf_bs_polyadd[unfolded wf_bs_def, rule_format])
+ apply auto
+ done
+
+lemma wf_bs_polyneg: "wf_bs bs p \<Longrightarrow> wf_bs bs (~\<^sub>p p)"
+ unfolding wf_bs_def by (induct p rule: polyneg.induct, auto)
+
+lemma wf_bs_polysub: "wf_bs bs p \<Longrightarrow> wf_bs bs q \<Longrightarrow> wf_bs bs (p -\<^sub>p q)"
+ unfolding polysub_def split_def fst_conv snd_conv using wf_bs_polyadd wf_bs_polyneg by blast
+
+subsection{* Canonicity of polynomial representation, see lemma isnpolyh_unique*}
+
+definition "polypoly bs p = map (Ipoly bs) (coefficients p)"
+definition "polypoly' bs p = map ((Ipoly bs o decrpoly)) (coefficients p)"
+definition "poly_nate bs p = map ((Ipoly bs o decrpoly)) (coefficients (polynate p))"
+
+lemma coefficients_normh: "isnpolyh p n0 \<Longrightarrow> \<forall> q \<in> set (coefficients p). isnpolyh q n0"
+proof (induct p arbitrary: n0 rule: coefficients.induct)
+ case (1 c p n0)
+ have cp: "isnpolyh (CN c 0 p) n0" by fact
+ hence norm: "isnpolyh c 0" "isnpolyh p 0" "p \<noteq> 0\<^sub>p" "n0 = 0"
+ by (auto simp add: isnpolyh_mono[where n'=0])
+ from "1.hyps"[OF norm(2)] norm(1) norm(4) show ?case by simp
+qed auto
+
+lemma coefficients_isconst:
+ "isnpolyh p n \<Longrightarrow> \<forall>q\<in>set (coefficients p). isconstant q"
+ by (induct p arbitrary: n rule: coefficients.induct,
+ auto simp add: isnpolyh_Suc_const)
+
+lemma polypoly_polypoly':
+ assumes np: "isnpolyh p n0"
+ shows "polypoly (x#bs) p = polypoly' bs p"
+proof-
+ let ?cf = "set (coefficients p)"
+ from coefficients_normh[OF np] have cn_norm: "\<forall> q\<in> ?cf. isnpolyh q n0" .
+ {fix q assume q: "q \<in> ?cf"
+ from q cn_norm have th: "isnpolyh q n0" by blast
+ from coefficients_isconst[OF np] q have "isconstant q" by blast
+ with isconstant_polybound0[OF th] have "polybound0 q" by blast}
+ hence "\<forall>q \<in> ?cf. polybound0 q" ..
+ hence "\<forall>q \<in> ?cf. Ipoly (x#bs) q = Ipoly bs (decrpoly q)"
+ using polybound0_I[where b=x and bs=bs and b'=y] decrpoly[where x=x and bs=bs]
+ by auto
+
+ thus ?thesis unfolding polypoly_def polypoly'_def by simp
+qed
+
+lemma polypoly_poly:
+ assumes np: "isnpolyh p n0" shows "Ipoly (x#bs) p = poly (polypoly (x#bs) p) x"
+ using np
+by (induct p arbitrary: n0 bs rule: coefficients.induct, auto simp add: polypoly_def)
+
+lemma polypoly'_poly:
+ assumes np: "isnpolyh p n0" shows "\<lparr>p\<rparr>\<^sub>p\<^bsup>x # bs\<^esup> = poly (polypoly' bs p) x"
+ using polypoly_poly[OF np, simplified polypoly_polypoly'[OF np]] .
+
+
+lemma polypoly_poly_polybound0:
+ assumes np: "isnpolyh p n0" and nb: "polybound0 p"
+ shows "polypoly bs p = [Ipoly bs p]"
+ using np nb unfolding polypoly_def
+ by (cases p, auto, case_tac nat, auto)
+
+lemma head_isnpolyh: "isnpolyh p n0 \<Longrightarrow> isnpolyh (head p) n0"
+ by (induct p rule: head.induct, auto)
+
+lemma headn_nz[simp]: "isnpolyh p n0 \<Longrightarrow> (headn p m = 0\<^sub>p) = (p = 0\<^sub>p)"
+ by (cases p,auto)
+
+lemma head_eq_headn0: "head p = headn p 0"
+ by (induct p rule: head.induct, simp_all)
+
+lemma head_nz[simp]: "isnpolyh p n0 \<Longrightarrow> (head p = 0\<^sub>p) = (p = 0\<^sub>p)"
+ by (simp add: head_eq_headn0)
+
+lemma isnpolyh_zero_iff:
+ assumes nq: "isnpolyh p n0" and eq :"\<forall>bs. wf_bs bs p \<longrightarrow> \<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (0::'a::{ring_char_0,power,division_by_zero,field})"
+ shows "p = 0\<^sub>p"
+using nq eq
+proof (induct n\<equiv>"maxindex p" arbitrary: p n0 rule: nat_less_induct)
+ fix n p n0
+ assume H: "\<forall>m<n. \<forall>p n0. isnpolyh p n0 \<longrightarrow>
+ (\<forall>bs. wf_bs bs p \<longrightarrow> \<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (0::'a)) \<longrightarrow> m = maxindex p \<longrightarrow> p = 0\<^sub>p"
+ and np: "isnpolyh p n0" and zp: "\<forall>bs. wf_bs bs p \<longrightarrow> \<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (0::'a)" and n: "n = maxindex p"
+ {assume nz: "n = 0"
+ then obtain c where "p = C c" using n np by (cases p, auto)
+ with zp np have "p = 0\<^sub>p" unfolding wf_bs_def by simp}
+ moreover
+ {assume nz: "n \<noteq> 0"
+ let ?h = "head p"
+ let ?hd = "decrpoly ?h"
+ let ?ihd = "maxindex ?hd"
+ from head_isnpolyh[OF np] head_polybound0[OF np] have h:"isnpolyh ?h n0" "polybound0 ?h"
+ by simp_all
+ hence nhd: "isnpolyh ?hd (n0 - 1)" using decrpoly_normh by blast
+
+ from maxindex_coefficients[of p] coefficients_head[of p, symmetric]
+ have mihn: "maxindex ?h \<le> n" unfolding n by auto
+ with decr_maxindex[OF h(2)] nz have ihd_lt_n: "?ihd < n" by auto
+ {fix bs:: "'a list" assume bs: "wf_bs bs ?hd"
+ let ?ts = "take ?ihd bs"
+ let ?rs = "drop ?ihd bs"
+ have ts: "wf_bs ?ts ?hd" using bs unfolding wf_bs_def by simp
+ have bs_ts_eq: "?ts@ ?rs = bs" by simp
+ from wf_bs_decrpoly[OF ts] have tsh: " \<forall>x. wf_bs (x#?ts) ?h" by simp
+ from ihd_lt_n have "ALL x. length (x#?ts) \<le> n" by simp
+ with length_le_list_ex obtain xs where xs:"length ((x#?ts) @ xs) = n" by blast
+ hence "\<forall> x. wf_bs ((x#?ts) @ xs) p" using n unfolding wf_bs_def by simp
+ with zp have "\<forall> x. Ipoly ((x#?ts) @ xs) p = 0" by blast
+ hence "\<forall> x. Ipoly (x#(?ts @ xs)) p = 0" by simp
+ with polypoly_poly[OF np, where ?'a = 'a] polypoly_polypoly'[OF np, where ?'a = 'a]
+ have "\<forall>x. poly (polypoly' (?ts @ xs) p) x = poly [] x" by simp
+ hence "poly (polypoly' (?ts @ xs) p) = poly []" by (auto intro: ext)
+ hence "\<forall> c \<in> set (coefficients p). Ipoly (?ts @ xs) (decrpoly c) = 0"
+ thm poly_zero
+ using poly_zero[where ?'a='a] by (simp add: polypoly'_def list_all_iff)
+ with coefficients_head[of p, symmetric]
+ have th0: "Ipoly (?ts @ xs) ?hd = 0" by simp
+ from bs have wf'': "wf_bs ?ts ?hd" unfolding wf_bs_def by simp
+ with th0 wf_bs_I[of ?ts ?hd xs] have "Ipoly ?ts ?hd = 0" by simp
+ with wf'' wf_bs_I[of ?ts ?hd ?rs] bs_ts_eq have "\<lparr>?hd\<rparr>\<^sub>p\<^bsup>bs\<^esup> = 0" by simp }
+ then have hdz: "\<forall>bs. wf_bs bs ?hd \<longrightarrow> \<lparr>?hd\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (0::'a)" by blast
+
+ from H[rule_format, OF ihd_lt_n nhd] hdz have "?hd = 0\<^sub>p" by blast
+ hence "?h = 0\<^sub>p" by simp
+ with head_nz[OF np] have "p = 0\<^sub>p" by simp}
+ ultimately show "p = 0\<^sub>p" by blast
+qed
+
+lemma isnpolyh_unique:
+ assumes np:"isnpolyh p n0" and nq: "isnpolyh q n1"
+ shows "(\<forall>bs. \<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (\<lparr>q\<rparr>\<^sub>p\<^bsup>bs\<^esup> :: 'a::{ring_char_0,power,division_by_zero,field})) \<longleftrightarrow> p = q"
+proof(auto)
+ assume H: "\<forall>bs. (\<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> ::'a)= \<lparr>q\<rparr>\<^sub>p\<^bsup>bs\<^esup>"
+ hence "\<forall>bs.\<lparr>p -\<^sub>p q\<rparr>\<^sub>p\<^bsup>bs\<^esup>= (0::'a)" by simp
+ hence "\<forall>bs. wf_bs bs (p -\<^sub>p q) \<longrightarrow> \<lparr>p -\<^sub>p q\<rparr>\<^sub>p\<^bsup>bs\<^esup> = (0::'a)"
+ using wf_bs_polysub[where p=p and q=q] by auto
+ with isnpolyh_zero_iff[OF polysub_normh[OF np nq]] polysub_0[OF np nq]
+ show "p = q" by blast
+qed
+
+
+text{* consequenses of unicity on the algorithms for polynomial normalization *}
+
+lemma polyadd_commute: assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and nq: "isnpolyh q n1" shows "p +\<^sub>p q = q +\<^sub>p p"
+ using isnpolyh_unique[OF polyadd_normh[OF np nq] polyadd_normh[OF nq np]] by simp
+
+lemma zero_normh: "isnpolyh 0\<^sub>p n" by simp
+lemma one_normh: "isnpolyh 1\<^sub>p n" by simp
+lemma polyadd_0[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" shows "p +\<^sub>p 0\<^sub>p = p" and "0\<^sub>p +\<^sub>p p = p"
+ using isnpolyh_unique[OF polyadd_normh[OF np zero_normh] np]
+ isnpolyh_unique[OF polyadd_normh[OF zero_normh np] np] by simp_all
+
+lemma polymul_1[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" shows "p *\<^sub>p 1\<^sub>p = p" and "1\<^sub>p *\<^sub>p p = p"
+ using isnpolyh_unique[OF polymul_normh[OF np one_normh] np]
+ isnpolyh_unique[OF polymul_normh[OF one_normh np] np] by simp_all
+lemma polymul_0[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" shows "p *\<^sub>p 0\<^sub>p = 0\<^sub>p" and "0\<^sub>p *\<^sub>p p = 0\<^sub>p"
+ using isnpolyh_unique[OF polymul_normh[OF np zero_normh] zero_normh]
+ isnpolyh_unique[OF polymul_normh[OF zero_normh np] zero_normh] by simp_all
+
+lemma polymul_commute:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np:"isnpolyh p n0" and nq: "isnpolyh q n1"
+ shows "p *\<^sub>p q = q *\<^sub>p p"
+using isnpolyh_unique[OF polymul_normh[OF np nq] polymul_normh[OF nq np], where ?'a = "'a\<Colon>{ring_char_0,power,division_by_zero,field}"] by simp
+
+declare polyneg_polyneg[simp]
+
+lemma isnpolyh_polynate_id[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np:"isnpolyh p n0" shows "polynate p = p"
+ using isnpolyh_unique[where ?'a= "'a::{ring_char_0,division_by_zero,field}", OF polynate_norm[of p, unfolded isnpoly_def] np] polynate[where ?'a = "'a::{ring_char_0,division_by_zero,field}"] by simp
+
+lemma polynate_idempotent[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "polynate (polynate p) = polynate p"
+ using isnpolyh_polynate_id[OF polynate_norm[of p, unfolded isnpoly_def]] .
+
+lemma poly_nate_polypoly': "poly_nate bs p = polypoly' bs (polynate p)"
+ unfolding poly_nate_def polypoly'_def ..
+lemma poly_nate_poly: shows "poly (poly_nate bs p) = (\<lambda>x:: 'a ::{ring_char_0,division_by_zero,field}. \<lparr>p\<rparr>\<^sub>p\<^bsup>x # bs\<^esup>)"
+ using polypoly'_poly[OF polynate_norm[unfolded isnpoly_def], symmetric, of bs p]
+ unfolding poly_nate_polypoly' by (auto intro: ext)
+
+subsection{* heads, degrees and all that *}
+lemma degree_eq_degreen0: "degree p = degreen p 0"
+ by (induct p rule: degree.induct, simp_all)
+
+lemma degree_polyneg: assumes n: "isnpolyh p n"
+ shows "degree (polyneg p) = degree p"
+ using n
+ by (induct p arbitrary: n rule: polyneg.induct, simp_all) (case_tac na, auto)
+
+lemma degree_polyadd:
+ assumes np: "isnpolyh p n0" and nq: "isnpolyh q n1"
+ shows "degree (p +\<^sub>p q) \<le> max (degree p) (degree q)"
+using degreen_polyadd[OF np nq, where m= "0"] degree_eq_degreen0 by simp
+
+
+lemma degree_polysub: assumes np: "isnpolyh p n0" and nq: "isnpolyh q n1"
+ shows "degree (p -\<^sub>p q) \<le> max (degree p) (degree q)"
+proof-
+ from nq have nq': "isnpolyh (~\<^sub>p q) n1" using polyneg_normh by simp
+ from degree_polyadd[OF np nq'] show ?thesis by (simp add: polysub_def degree_polyneg[OF nq])
+qed
+
+lemma degree_polysub_samehead:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and nq: "isnpolyh q n1" and h: "head p = head q"
+ and d: "degree p = degree q"
+ shows "degree (p -\<^sub>p q) < degree p \<or> (p -\<^sub>p q = 0\<^sub>p)"
+unfolding polysub_def split_def fst_conv snd_conv
+using np nq h d
+proof(induct p q rule:polyadd.induct)
+ case (1 a b a' b') thus ?case by (simp add: Nsub_def Nsub0[simplified Nsub_def])
+next
+ case (2 a b c' n' p')
+ let ?c = "(a,b)"
+ from prems have "degree (C ?c) = degree (CN c' n' p')" by simp
+ hence nz:"n' > 0" by (cases n', auto)
+ hence "head (CN c' n' p') = CN c' n' p'" by (cases n', auto)
+ with prems show ?case by simp
+next
+ case (3 c n p a' b')
+ let ?c' = "(a',b')"
+ from prems have "degree (C ?c') = degree (CN c n p)" by simp
+ hence nz:"n > 0" by (cases n, auto)
+ hence "head (CN c n p) = CN c n p" by (cases n, auto)
+ with prems show ?case by simp
+next
+ case (4 c n p c' n' p')
+ hence H: "isnpolyh (CN c n p) n0" "isnpolyh (CN c' n' p') n1"
+ "head (CN c n p) = head (CN c' n' p')" "degree (CN c n p) = degree (CN c' n' p')" by simp+
+ hence degc: "degree c = 0" and degc': "degree c' = 0" by simp_all
+ hence degnc: "degree (~\<^sub>p c) = 0" and degnc': "degree (~\<^sub>p c') = 0"
+ using H(1-2) degree_polyneg by auto
+ from H have cnh: "isnpolyh c (Suc n)" and c'nh: "isnpolyh c' (Suc n')" by simp+
+ from degree_polysub[OF cnh c'nh, simplified polysub_def] degc degc' have degcmc': "degree (c +\<^sub>p ~\<^sub>pc') = 0" by simp
+ from H have pnh: "isnpolyh p n" and p'nh: "isnpolyh p' n'" by auto
+ have "n = n' \<or> n < n' \<or> n > n'" by arith
+ moreover
+ {assume nn': "n = n'"
+ have "n = 0 \<or> n >0" by arith
+ moreover {assume nz: "n = 0" hence ?case using prems by (auto simp add: Let_def degcmc')}
+ moreover {assume nz: "n > 0"
+ with nn' H(3) have cc':"c = c'" and pp': "p = p'" by (cases n, auto)+
+ hence ?case using polysub_same_0[OF p'nh, simplified polysub_def split_def fst_conv snd_conv] polysub_same_0[OF c'nh, simplified polysub_def split_def fst_conv snd_conv] using nn' prems by (simp add: Let_def)}
+ ultimately have ?case by blast}
+ moreover
+ {assume nn': "n < n'" hence n'p: "n' > 0" by simp
+ hence headcnp':"head (CN c' n' p') = CN c' n' p'" by (cases n', simp_all)
+ have degcnp': "degree (CN c' n' p') = 0" and degcnpeq: "degree (CN c n p) = degree (CN c' n' p')" using prems by (cases n', simp_all)
+ hence "n > 0" by (cases n, simp_all)
+ hence headcnp: "head (CN c n p) = CN c n p" by (cases n, auto)
+ from H(3) headcnp headcnp' nn' have ?case by auto}
+ moreover
+ {assume nn': "n > n'" hence np: "n > 0" by simp
+ hence headcnp:"head (CN c n p) = CN c n p" by (cases n, simp_all)
+ from prems have degcnpeq: "degree (CN c' n' p') = degree (CN c n p)" by simp
+ from np have degcnp: "degree (CN c n p) = 0" by (cases n, simp_all)
+ with degcnpeq have "n' > 0" by (cases n', simp_all)
+ hence headcnp': "head (CN c' n' p') = CN c' n' p'" by (cases n', auto)
+ from H(3) headcnp headcnp' nn' have ?case by auto}
+ ultimately show ?case by blast
+qed auto
+
+lemma shift1_head : "isnpolyh p n0 \<Longrightarrow> head (shift1 p) = head p"
+by (induct p arbitrary: n0 rule: head.induct, simp_all add: shift1_def)
+
+lemma funpow_shift1_head: "isnpolyh p n0 \<Longrightarrow> p\<noteq> 0\<^sub>p \<Longrightarrow> head (funpow k shift1 p) = head p"
+proof(induct k arbitrary: n0 p)
+ case (Suc k n0 p) hence "isnpolyh (shift1 p) 0" by (simp add: shift1_isnpolyh)
+ with prems have "head (funpow k shift1 (shift1 p)) = head (shift1 p)"
+ and "head (shift1 p) = head p" by (simp_all add: shift1_head)
+ thus ?case by simp
+qed auto
+
+lemma shift1_degree: "degree (shift1 p) = 1 + degree p"
+ by (simp add: shift1_def)
+lemma funpow_shift1_degree: "degree (funpow k shift1 p) = k + degree p "
+ by (induct k arbitrary: p, auto simp add: shift1_degree)
+
+lemma funpow_shift1_nz: "p \<noteq> 0\<^sub>p \<Longrightarrow> funpow n shift1 p \<noteq> 0\<^sub>p"
+ by (induct n arbitrary: p, simp_all add: funpow_def)
+
+lemma head_isnpolyh_Suc[simp]: "isnpolyh p (Suc n) \<Longrightarrow> head p = p"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+lemma headn_0[simp]: "isnpolyh p n \<Longrightarrow> m < n \<Longrightarrow> headn p m = p"
+ by (induct p arbitrary: n rule: degreen.induct, auto)
+lemma head_isnpolyh_Suc': "n > 0 \<Longrightarrow> isnpolyh p n \<Longrightarrow> head p = p"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+lemma head_head[simp]: "isnpolyh p n0 \<Longrightarrow> head (head p) = head p"
+ by (induct p rule: head.induct, auto)
+
+lemma polyadd_eq_const_degree:
+ "\<lbrakk> isnpolyh p n0 ; isnpolyh q n1 ; polyadd (p,q) = C c\<rbrakk> \<Longrightarrow> degree p = degree q"
+ using polyadd_eq_const_degreen degree_eq_degreen0 by simp
+
+lemma polyadd_head: assumes np: "isnpolyh p n0" and nq: "isnpolyh q n1"
+ and deg: "degree p \<noteq> degree q"
+ shows "head (p +\<^sub>p q) = (if degree p < degree q then head q else head p)"
+using np nq deg
+apply(induct p q arbitrary: n0 n1 rule: polyadd.induct,simp_all)
+apply (case_tac n', simp, simp)
+apply (case_tac n, simp, simp)
+apply (case_tac n, case_tac n', simp add: Let_def)
+apply (case_tac "pa +\<^sub>p p' = 0\<^sub>p")
+apply (clarsimp simp add: polyadd_eq_const_degree)
+apply clarsimp
+apply (erule_tac impE,blast)
+apply (erule_tac impE,blast)
+apply clarsimp
+apply simp
+apply (case_tac n', simp_all)
+done
+
+lemma polymul_head_polyeq:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "\<lbrakk>isnpolyh p n0; isnpolyh q n1 ; p \<noteq> 0\<^sub>p ; q \<noteq> 0\<^sub>p \<rbrakk> \<Longrightarrow> head (p *\<^sub>p q) = head p *\<^sub>p head q"
+proof (induct p q arbitrary: n0 n1 rule: polymul.induct)
+ case (2 a b c' n' p' n0 n1)
+ hence "isnpolyh (head (CN c' n' p')) n1" "isnormNum (a,b)" by (simp_all add: head_isnpolyh)
+ thus ?case using prems by (cases n', auto)
+next
+ case (3 c n p a' b' n0 n1)
+ hence "isnpolyh (head (CN c n p)) n0" "isnormNum (a',b')" by (simp_all add: head_isnpolyh)
+ thus ?case using prems by (cases n, auto)
+next
+ case (4 c n p c' n' p' n0 n1)
+ hence norm: "isnpolyh p n" "isnpolyh c (Suc n)" "isnpolyh p' n'" "isnpolyh c' (Suc n')"
+ "isnpolyh (CN c n p) n" "isnpolyh (CN c' n' p') n'"
+ by simp_all
+ have "n < n' \<or> n' < n \<or> n = n'" by arith
+ moreover
+ {assume nn': "n < n'" hence ?case
+ thm prems
+ using norm
+ prems(6)[rule_format, OF nn' norm(1,6)]
+ prems(7)[rule_format, OF nn' norm(2,6)] by (simp, cases n, simp,cases n', simp_all)}
+ moreover {assume nn': "n'< n"
+ hence stupid: "n' < n \<and> \<not> n < n'" by simp
+ hence ?case using norm prems(4) [rule_format, OF stupid norm(5,3)]
+ prems(5)[rule_format, OF stupid norm(5,4)]
+ by (simp,cases n',simp,cases n,auto)}
+ moreover {assume nn': "n' = n"
+ hence stupid: "\<not> n' < n \<and> \<not> n < n'" by simp
+ from nn' polymul_normh[OF norm(5,4)]
+ have ncnpc':"isnpolyh (CN c n p *\<^sub>p c') n" by (simp add: min_def)
+ from nn' polymul_normh[OF norm(5,3)] norm
+ have ncnpp':"isnpolyh (CN c n p *\<^sub>p p') n" by simp
+ from nn' ncnpp' polymul_eq0_iff[OF norm(5,3)] norm(6)
+ have ncnpp0':"isnpolyh (CN 0\<^sub>p n (CN c n p *\<^sub>p p')) n" by simp
+ from polyadd_normh[OF ncnpc' ncnpp0']
+ have nth: "isnpolyh ((CN c n p *\<^sub>p c') +\<^sub>p (CN 0\<^sub>p n (CN c n p *\<^sub>p p'))) n"
+ by (simp add: min_def)
+ {assume np: "n > 0"
+ with nn' head_isnpolyh_Suc'[OF np nth]
+ head_isnpolyh_Suc'[OF np norm(5)] head_isnpolyh_Suc'[OF np norm(6)[simplified nn']]
+ have ?case by simp}
+ moreover
+ {moreover assume nz: "n = 0"
+ from polymul_degreen[OF norm(5,4), where m="0"]
+ polymul_degreen[OF norm(5,3), where m="0"] nn' nz degree_eq_degreen0
+ norm(5,6) degree_npolyhCN[OF norm(6)]
+ have dth:"degree (CN c 0 p *\<^sub>p c') < degree (CN 0\<^sub>p 0 (CN c 0 p *\<^sub>p p'))" by simp
+ hence dth':"degree (CN c 0 p *\<^sub>p c') \<noteq> degree (CN 0\<^sub>p 0 (CN c 0 p *\<^sub>p p'))" by simp
+ from polyadd_head[OF ncnpc'[simplified nz] ncnpp0'[simplified nz] dth'] dth
+ have ?case using norm prems(2)[rule_format, OF stupid norm(5,3)]
+ prems(3)[rule_format, OF stupid norm(5,4)] nn' nz by simp }
+ ultimately have ?case by (cases n) auto}
+ ultimately show ?case by blast
+qed simp_all
+
+lemma degree_coefficients: "degree p = length (coefficients p) - 1"
+ by(induct p rule: degree.induct, auto)
+
+lemma degree_head[simp]: "degree (head p) = 0"
+ by (induct p rule: head.induct, auto)
+
+lemma degree_CN: "isnpolyh p n \<Longrightarrow> degree (CN c n p) \<le> 1+ degree p"
+ by (cases n, simp_all)
+lemma degree_CN': "isnpolyh p n \<Longrightarrow> degree (CN c n p) \<ge> degree p"
+ by (cases n, simp_all)
+
+lemma polyadd_different_degree: "\<lbrakk>isnpolyh p n0 ; isnpolyh q n1; degree p \<noteq> degree q\<rbrakk> \<Longrightarrow> degree (polyadd(p,q)) = max (degree p) (degree q)"
+ using polyadd_different_degreen degree_eq_degreen0 by simp
+
+lemma degreen_polyneg: "isnpolyh p n0 \<Longrightarrow> degreen (~\<^sub>p p) m = degreen p m"
+ by (induct p arbitrary: n0 rule: polyneg.induct, auto)
+
+lemma degree_polymul:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and nq: "isnpolyh q n1"
+ shows "degree (p *\<^sub>p q) \<le> degree p + degree q"
+ using polymul_degreen[OF np nq, where m="0"] degree_eq_degreen0 by simp
+
+lemma polyneg_degree: "isnpolyh p n \<Longrightarrow> degree (polyneg p) = degree p"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+
+lemma polyneg_head: "isnpolyh p n \<Longrightarrow> head(polyneg p) = polyneg (head p)"
+ by (induct p arbitrary: n rule: degree.induct, auto)
+
+subsection {* Correctness of polynomial pseudo division *}
+
+lemma polydivide_aux_real_domintros:
+ assumes call1: "\<lbrakk>s \<noteq> 0\<^sub>p; \<not> degree s < n; a = head s\<rbrakk>
+ \<Longrightarrow> polydivide_aux_dom (a, n, p, k, s -\<^sub>p funpow (degree s - n) shift1 p)"
+ and call2 : "\<lbrakk>s \<noteq> 0\<^sub>p; \<not> degree s < n; a \<noteq> head s\<rbrakk>
+ \<Longrightarrow> polydivide_aux_dom(a, n, p,Suc k, a *\<^sub>p s -\<^sub>p (head s *\<^sub>p funpow (degree s - n) shift1 p))"
+ shows "polydivide_aux_dom (a, n, p, k, s)"
+proof (rule accpI, erule polydivide_aux_rel.cases)
+ fix y aa ka na pa sa x xa xb
+ assume eqs: "y = (aa, na, pa, ka, sa -\<^sub>p xb)" "(a, n, p, k, s) = (aa, na, pa, ka, sa)"
+ and \<Gamma>1': "sa \<noteq> 0\<^sub>p" "x = head sa" "xa = degree sa" "\<not> xa < na"
+ "xb = funpow (xa - na) shift1 pa" "aa = x"
+
+ hence \<Gamma>1: "s \<noteq> 0\<^sub>p" "a = head s" "xa = degree s" "\<not> degree s < n" "\<not> xa < na"
+ "xb = funpow (xa - na) shift1 pa" "aa = x" by auto
+
+ with call1 have "polydivide_aux_dom (a, n, p, k, s -\<^sub>p funpow (degree s - n) shift1 p)"
+ by auto
+ with eqs \<Gamma>1 show "polydivide_aux_dom y" by auto
+next
+ fix y aa ka na pa sa x xa xb
+ assume eqs: "y = (aa, na, pa, Suc ka, aa *\<^sub>p sa -\<^sub>p (x *\<^sub>p xb))"
+ "(a, n, p, k, s) =(aa, na, pa, ka, sa)"
+ and \<Gamma>2': "sa \<noteq> 0\<^sub>p" "x = head sa" "xa = degree sa" "\<not> xa < na"
+ "xb = funpow (xa - na) shift1 pa" "aa \<noteq> x"
+ hence \<Gamma>2: "s \<noteq> 0\<^sub>p" "a \<noteq> head s" "xa = degree s" "\<not> degree s < n"
+ "xb = funpow (xa - na) shift1 pa" "aa \<noteq> x" by auto
+ with call2 have "polydivide_aux_dom (a, n, p, Suc k, a *\<^sub>p s -\<^sub>p (head s *\<^sub>p funpow (degree s - n) shift1 p))" by auto
+ with eqs \<Gamma>2' show "polydivide_aux_dom y" by auto
+qed
+
+lemma polydivide_aux_properties:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and ns: "isnpolyh s n1"
+ and ap: "head p = a" and ndp: "degree p = n" and pnz: "p \<noteq> 0\<^sub>p"
+ shows "polydivide_aux_dom (a,n,p,k,s) \<and>
+ (polydivide_aux (a,n,p,k,s) = (k',r) \<longrightarrow> (k' \<ge> k) \<and> (degree r = 0 \<or> degree r < degree p)
+ \<and> (\<exists>nr. isnpolyh r nr) \<and> (\<exists>q n1. isnpolyh q n1 \<and> ((polypow (k' - k) a) *\<^sub>p s = p *\<^sub>p q +\<^sub>p r)))"
+ using ns
+proof(induct d\<equiv>"degree s" arbitrary: s k k' r n1 rule: nat_less_induct)
+ fix d s k k' r n1
+ let ?D = "polydivide_aux_dom"
+ let ?dths = "?D (a, n, p, k, s)"
+ let ?qths = "\<exists>q n1. isnpolyh q n1 \<and> (a ^\<^sub>p (k' - k) *\<^sub>p s = p *\<^sub>p q +\<^sub>p r)"
+ let ?qrths = "polydivide_aux (a, n, p, k, s) = (k', r) \<longrightarrow> k \<le> k' \<and> (degree r = 0 \<or> degree r < degree p)
+ \<and> (\<exists>nr. isnpolyh r nr) \<and> ?qths"
+ let ?ths = "?dths \<and> ?qrths"
+ let ?b = "head s"
+ let ?p' = "funpow (d - n) shift1 p"
+ let ?xdn = "funpow (d - n) shift1 1\<^sub>p"
+ let ?akk' = "a ^\<^sub>p (k' - k)"
+ assume H: "\<forall>m<d. \<forall>x xa xb xc xd.
+ isnpolyh x xd \<longrightarrow>
+ m = degree x \<longrightarrow> ?D (a, n, p, xa, x) \<and>
+ (polydivide_aux (a, n, p, xa, x) = (xb, xc) \<longrightarrow>
+ xa \<le> xb \<and> (degree xc = 0 \<or> degree xc < degree p) \<and>
+ (\<exists> nr. isnpolyh xc nr) \<and>
+ (\<exists>q n1. isnpolyh q n1 \<and> a ^\<^sub>p xb - xa *\<^sub>p x = p *\<^sub>p q +\<^sub>p xc))"
+ and ns: "isnpolyh s n1" and ds: "d = degree s"
+ from np have np0: "isnpolyh p 0"
+ using isnpolyh_mono[where n="n0" and n'="0" and p="p"] by simp
+ have np': "isnpolyh ?p' 0" using funpow_shift1_isnpoly[OF np0[simplified isnpoly_def[symmetric]] pnz, where n="d -n"] isnpoly_def by simp
+ have headp': "head ?p' = head p" using funpow_shift1_head[OF np pnz] by simp
+ from funpow_shift1_isnpoly[where p="1\<^sub>p"] have nxdn: "isnpolyh ?xdn 0" by (simp add: isnpoly_def)
+ from polypow_normh [OF head_isnpolyh[OF np0], where k="k' - k"] ap
+ have nakk':"isnpolyh ?akk' 0" by blast
+ {assume sz: "s = 0\<^sub>p"
+ hence dom: ?dths apply - apply (rule polydivide_aux_real_domintros) apply simp_all done
+ from polydivide_aux.psimps[OF dom] sz
+ have ?qrths using np apply clarsimp by (rule exI[where x="0\<^sub>p"], simp)
+ hence ?ths using dom by blast}
+ moreover
+ {assume sz: "s \<noteq> 0\<^sub>p"
+ {assume dn: "d < n"
+ with sz ds have dom:"?dths" by - (rule polydivide_aux_real_domintros,simp_all)
+ from polydivide_aux.psimps[OF dom] sz dn ds
+ have "?qrths" using ns ndp np by auto (rule exI[where x="0\<^sub>p"],simp)
+ with dom have ?ths by blast}
+ moreover
+ {assume dn': "\<not> d < n" hence dn: "d \<ge> n" by arith
+ have degsp': "degree s = degree ?p'"
+ using ds dn ndp funpow_shift1_degree[where k = "d - n" and p="p"] by simp
+ {assume ba: "?b = a"
+ hence headsp': "head s = head ?p'" using ap headp' by simp
+ have nr: "isnpolyh (s -\<^sub>p ?p') 0" using polysub_normh[OF ns np'] by simp
+ from ds degree_polysub_samehead[OF ns np' headsp' degsp']
+ have "degree (s -\<^sub>p ?p') < d \<or> s -\<^sub>p ?p' = 0\<^sub>p" by simp
+ moreover
+ {assume deglt:"degree (s -\<^sub>p ?p') < d"
+ from H[rule_format, OF deglt nr,simplified]
+ have domsp: "?D (a, n, p, k, s -\<^sub>p ?p')" by blast
+ have dom: ?dths apply (rule polydivide_aux_real_domintros)
+ using ba ds dn' domsp by simp_all
+ from polydivide_aux.psimps[OF dom] sz dn' ba ds
+ have eq: "polydivide_aux (a,n,p,k,s) = polydivide_aux (a,n,p,k, s -\<^sub>p ?p')"
+ by (simp add: Let_def)
+ {assume h1: "polydivide_aux (a, n, p, k, s) = (k', r)"
+ from H[rule_format, OF deglt nr, where xa = "k" and xb="k'" and xc="r", simplified]
+ trans[OF eq[symmetric] h1]
+ have kk': "k \<le> k'" and nr:"\<exists>nr. isnpolyh r nr" and dr: "degree r = 0 \<or> degree r < degree p"
+ and q1:"\<exists>q nq. isnpolyh q nq \<and> (a ^\<^sub>p k' - k *\<^sub>p (s -\<^sub>p ?p') = p *\<^sub>p q +\<^sub>p r)" by auto
+ from q1 obtain q n1 where nq: "isnpolyh q n1"
+ and asp:"a^\<^sub>p (k' - k) *\<^sub>p (s -\<^sub>p ?p') = p *\<^sub>p q +\<^sub>p r" by blast
+ from nr obtain nr where nr': "isnpolyh r nr" by blast
+ from polymul_normh[OF nakk' ns] have nakks': "isnpolyh (a ^\<^sub>p (k' - k) *\<^sub>p s) 0" by simp
+ from polyadd_normh[OF polymul_normh[OF nakk' nxdn] nq]
+ have nq': "isnpolyh (?akk' *\<^sub>p ?xdn +\<^sub>p q) 0" by simp
+ from polyadd_normh[OF polymul_normh[OF np
+ polyadd_normh[OF polymul_normh[OF nakk' nxdn] nq]] nr']
+ have nqr': "isnpolyh (p *\<^sub>p (?akk' *\<^sub>p ?xdn +\<^sub>p q) +\<^sub>p r) 0" by simp
+ from asp have "\<forall> (bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a^\<^sub>p (k' - k) *\<^sub>p (s -\<^sub>p ?p')) =
+ Ipoly bs (p *\<^sub>p q +\<^sub>p r)" by simp
+ hence " \<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a^\<^sub>p (k' - k)*\<^sub>p s) =
+ Ipoly bs (a^\<^sub>p (k' - k)) * Ipoly bs ?p' + Ipoly bs p * Ipoly bs q + Ipoly bs r"
+ by (simp add: ring_simps)
+ hence " \<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a ^\<^sub>p (k' - k) *\<^sub>p s) =
+ Ipoly bs (a^\<^sub>p (k' - k)) * Ipoly bs (funpow (d - n) shift1 1\<^sub>p *\<^sub>p p)
+ + Ipoly bs p * Ipoly bs q + Ipoly bs r"
+ by (auto simp only: funpow_shift1_1)
+ hence "\<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a ^\<^sub>p (k' - k) *\<^sub>p s) =
+ Ipoly bs p * (Ipoly bs (a^\<^sub>p (k' - k)) * Ipoly bs (funpow (d - n) shift1 1\<^sub>p)
+ + Ipoly bs q) + Ipoly bs r" by (simp add: ring_simps)
+ hence "\<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a ^\<^sub>p (k' - k) *\<^sub>p s) =
+ Ipoly bs (p *\<^sub>p ((a^\<^sub>p (k' - k)) *\<^sub>p (funpow (d - n) shift1 1\<^sub>p) +\<^sub>p q) +\<^sub>p r)" by simp
+ with isnpolyh_unique[OF nakks' nqr']
+ have "a ^\<^sub>p (k' - k) *\<^sub>p s =
+ p *\<^sub>p ((a^\<^sub>p (k' - k)) *\<^sub>p (funpow (d - n) shift1 1\<^sub>p) +\<^sub>p q) +\<^sub>p r" by blast
+ hence ?qths using nq'
+ apply (rule_tac x="(a^\<^sub>p (k' - k)) *\<^sub>p (funpow (d - n) shift1 1\<^sub>p) +\<^sub>p q" in exI)
+ apply (rule_tac x="0" in exI) by simp
+ with kk' nr dr have "k \<le> k' \<and> (degree r = 0 \<or> degree r < degree p) \<and> (\<exists>nr. isnpolyh r nr) \<and> ?qths"
+ by blast } hence ?qrths by blast
+ with dom have ?ths by blast}
+ moreover
+ {assume spz:"s -\<^sub>p ?p' = 0\<^sub>p"
+ hence domsp: "?D (a, n, p, k, s -\<^sub>p ?p')"
+ apply (simp) by (rule polydivide_aux_real_domintros, simp_all)
+ have dom: ?dths apply (rule polydivide_aux_real_domintros)
+ using ba ds dn' domsp by simp_all
+ from spz isnpolyh_unique[OF polysub_normh[OF ns np'], where q="0\<^sub>p", symmetric, where ?'a = "'a::{ring_char_0,division_by_zero,field}"]
+ have " \<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs s = Ipoly bs ?p'" by simp
+ hence "\<forall>(bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs s = Ipoly bs (?xdn *\<^sub>p p)" using np nxdn apply simp
+ by (simp only: funpow_shift1_1) simp
+ hence sp': "s = ?xdn *\<^sub>p p" using isnpolyh_unique[OF ns polymul_normh[OF nxdn np]] by blast
+ {assume h1: "polydivide_aux (a,n,p,k,s) = (k',r)"
+ from polydivide_aux.psimps[OF dom] sz dn' ba ds
+ have eq: "polydivide_aux (a,n,p,k,s) = polydivide_aux (a,n,p,k, s -\<^sub>p ?p')"
+ by (simp add: Let_def)
+ also have "\<dots> = (k,0\<^sub>p)" using polydivide_aux.psimps[OF domsp] spz by simp
+ finally have "(k',r) = (k,0\<^sub>p)" using h1 by simp
+ with sp' ns np nxdn polyadd_0(1)[OF polymul_normh[OF np nxdn]]
+ polyadd_0(2)[OF polymul_normh[OF np nxdn]] have ?qrths
+ apply auto
+ apply (rule exI[where x="?xdn"])
+ apply auto
+ apply (rule polymul_commute)
+ apply simp_all
+ done}
+ with dom have ?ths by blast}
+ ultimately have ?ths by blast }
+ moreover
+ {assume ba: "?b \<noteq> a"
+ from polysub_normh[OF polymul_normh[OF head_isnpolyh[OF np0, simplified ap] ns]
+ polymul_normh[OF head_isnpolyh[OF ns] np']]
+ have nth: "isnpolyh ((a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p')) 0" by(simp add: min_def)
+ have nzths: "a *\<^sub>p s \<noteq> 0\<^sub>p" "?b *\<^sub>p ?p' \<noteq> 0\<^sub>p"
+ using polymul_eq0_iff[OF head_isnpolyh[OF np0, simplified ap] ns]
+ polymul_eq0_iff[OF head_isnpolyh[OF ns] np']head_nz[OF np0] ap pnz sz head_nz[OF ns]
+ funpow_shift1_nz[OF pnz] by simp_all
+ from polymul_head_polyeq[OF head_isnpolyh[OF np] ns] head_nz[OF np] sz ap head_head[OF np] pnz
+ polymul_head_polyeq[OF head_isnpolyh[OF ns] np'] head_nz [OF ns] sz funpow_shift1_nz[OF pnz, where n="d - n"]
+ have hdth: "head (a *\<^sub>p s) = head (?b *\<^sub>p ?p')"
+ using head_head[OF ns] funpow_shift1_head[OF np pnz]
+ polymul_commute[OF head_isnpolyh[OF np] head_isnpolyh[OF ns]]
+ by (simp add: ap)
+ from polymul_degreen[OF head_isnpolyh[OF np] ns, where m="0"]
+ head_nz[OF np] pnz sz ap[symmetric]
+ funpow_shift1_nz[OF pnz, where n="d - n"]
+ polymul_degreen[OF head_isnpolyh[OF ns] np', where m="0"] head_nz[OF ns]
+ ndp ds[symmetric] dn
+ have degth: "degree (a *\<^sub>p s) = degree (?b *\<^sub>p ?p') "
+ by (simp add: degree_eq_degreen0[symmetric] funpow_shift1_degree)
+ {assume dth: "degree ((a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p')) < d"
+ have th: "?D (a, n, p, Suc k, (a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p'))"
+ using H[rule_format, OF dth nth, simplified] by blast
+ have dom: ?dths
+ using ba ds dn' th apply simp apply (rule polydivide_aux_real_domintros)
+ using ba ds dn' by simp_all
+ from polysub_normh[OF polymul_normh[OF head_isnpolyh[OF np] ns] polymul_normh[OF head_isnpolyh[OF ns]np']]
+ ap have nasbp': "isnpolyh ((a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p')) 0" by simp
+ {assume h1:"polydivide_aux (a,n,p,k,s) = (k', r)"
+ from h1 polydivide_aux.psimps[OF dom] sz dn' ba ds
+ have eq:"polydivide_aux (a,n,p,Suc k,(a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p')) = (k',r)"
+ by (simp add: Let_def)
+ with H[rule_format, OF dth nasbp', simplified, where xa="Suc k" and xb="k'" and xc="r"]
+ obtain q nq nr where kk': "Suc k \<le> k'" and nr: "isnpolyh r nr" and nq: "isnpolyh q nq"
+ and dr: "degree r = 0 \<or> degree r < degree p"
+ and qr: "a ^\<^sub>p (k' - Suc k) *\<^sub>p ((a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p')) = p *\<^sub>p q +\<^sub>p r" by auto
+ from kk' have kk'':"Suc (k' - Suc k) = k' - k" by arith
+ {fix bs:: "'a::{ring_char_0,division_by_zero,field} list"
+
+ from qr isnpolyh_unique[OF polypow_normh[OF head_isnpolyh[OF np], where k="k' - Suc k", simplified ap] nasbp', symmetric]
+ have "Ipoly bs (a ^\<^sub>p (k' - Suc k) *\<^sub>p ((a *\<^sub>p s) -\<^sub>p (?b *\<^sub>p ?p'))) = Ipoly bs (p *\<^sub>p q +\<^sub>p r)" by simp
+ hence "Ipoly bs a ^ (Suc (k' - Suc k)) * Ipoly bs s = Ipoly bs p * Ipoly bs q + Ipoly bs a ^ (k' - Suc k) * Ipoly bs ?b * Ipoly bs ?p' + Ipoly bs r"
+ by (simp add: ring_simps power_Suc)
+ hence "Ipoly bs a ^ (k' - k) * Ipoly bs s = Ipoly bs p * Ipoly bs q + Ipoly bs a ^ (k' - Suc k) * Ipoly bs ?b * Ipoly bs ?xdn * Ipoly bs p + Ipoly bs r"
+ by (simp add:kk'' funpow_shift1_1[where n="d - n" and p="p"])
+ hence "Ipoly bs (a ^\<^sub>p (k' - k) *\<^sub>p s) = Ipoly bs p * (Ipoly bs q + Ipoly bs a ^ (k' - Suc k) * Ipoly bs ?b * Ipoly bs ?xdn) + Ipoly bs r"
+ by (simp add: ring_simps)}
+ hence ieq:"\<forall>(bs :: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a ^\<^sub>p (k' - k) *\<^sub>p s) =
+ Ipoly bs (p *\<^sub>p (q +\<^sub>p (a ^\<^sub>p (k' - Suc k) *\<^sub>p ?b *\<^sub>p ?xdn)) +\<^sub>p r)" by auto
+ let ?q = "q +\<^sub>p (a ^\<^sub>p (k' - Suc k) *\<^sub>p ?b *\<^sub>p ?xdn)"
+ from polyadd_normh[OF nq polymul_normh[OF polymul_normh[OF polypow_normh[OF head_isnpolyh[OF np], where k="k' - Suc k"] head_isnpolyh[OF ns], simplified ap ] nxdn]]
+ have nqw: "isnpolyh ?q 0" by simp
+ from ieq isnpolyh_unique[OF polymul_normh[OF polypow_normh[OF head_isnpolyh[OF np], where k="k' - k"] ns, simplified ap] polyadd_normh[OF polymul_normh[OF np nqw] nr]]
+ have asth: "(a ^\<^sub>p (k' - k) *\<^sub>p s) = p *\<^sub>p (q +\<^sub>p (a ^\<^sub>p (k' - Suc k) *\<^sub>p ?b *\<^sub>p ?xdn)) +\<^sub>p r" by blast
+ from dr kk' nr h1 asth nqw have ?qrths apply simp
+ apply (rule conjI)
+ apply (rule exI[where x="nr"], simp)
+ apply (rule exI[where x="(q +\<^sub>p (a ^\<^sub>p (k' - Suc k) *\<^sub>p ?b *\<^sub>p ?xdn))"], simp)
+ apply (rule exI[where x="0"], simp)
+ done}
+ hence ?qrths by blast
+ with dom have ?ths by blast}
+ moreover
+ {assume spz: "a *\<^sub>p s -\<^sub>p (?b *\<^sub>p ?p') = 0\<^sub>p"
+ hence domsp: "?D (a, n, p, Suc k, a *\<^sub>p s -\<^sub>p (?b *\<^sub>p ?p'))"
+ apply (simp) by (rule polydivide_aux_real_domintros, simp_all)
+ have dom: ?dths using sz ba dn' ds domsp
+ by - (rule polydivide_aux_real_domintros, simp_all)
+ {fix bs :: "'a::{ring_char_0,division_by_zero,field} list"
+ from isnpolyh_unique[OF nth, where ?'a="'a" and q="0\<^sub>p",simplified,symmetric] spz
+ have "Ipoly bs (a*\<^sub>p s) = Ipoly bs ?b * Ipoly bs ?p'" by simp
+ hence "Ipoly bs (a*\<^sub>p s) = Ipoly bs (?b *\<^sub>p ?xdn) * Ipoly bs p"
+ by (simp add: funpow_shift1_1[where n="d - n" and p="p"])
+ hence "Ipoly bs (a*\<^sub>p s) = Ipoly bs (p *\<^sub>p (?b *\<^sub>p ?xdn))" by simp
+ }
+ hence hth: "\<forall> (bs:: 'a::{ring_char_0,division_by_zero,field} list). Ipoly bs (a*\<^sub>p s) = Ipoly bs (p *\<^sub>p (?b *\<^sub>p ?xdn))" ..
+ from hth
+ have asq: "a *\<^sub>p s = p *\<^sub>p (?b *\<^sub>p ?xdn)"
+ using isnpolyh_unique[where ?'a = "'a::{ring_char_0,division_by_zero,field}", OF polymul_normh[OF head_isnpolyh[OF np] ns]
+ polymul_normh[OF np polymul_normh[OF head_isnpolyh[OF ns] nxdn]],
+ simplified ap] by simp
+ {assume h1: "polydivide_aux (a,n,p,k,s) = (k', r)"
+ from h1 sz ds ba dn' spz polydivide_aux.psimps[OF dom] polydivide_aux.psimps[OF domsp]
+ have "(k',r) = (Suc k, 0\<^sub>p)" by (simp add: Let_def)
+ with h1 np head_isnpolyh[OF np, simplified ap] ns polymul_normh[OF head_isnpolyh[OF ns] nxdn]
+ polymul_normh[OF np polymul_normh[OF head_isnpolyh[OF ns] nxdn]] asq
+ have ?qrths apply (clarsimp simp add: Let_def)
+ apply (rule exI[where x="?b *\<^sub>p ?xdn"]) apply simp
+ apply (rule exI[where x="0"], simp)
+ done}
+ hence ?qrths by blast
+ with dom have ?ths by blast}
+ ultimately have ?ths using degree_polysub_samehead[OF polymul_normh[OF head_isnpolyh[OF np0, simplified ap] ns] polymul_normh[OF head_isnpolyh[OF ns] np'] hdth degth] polymul_degreen[OF head_isnpolyh[OF np] ns, where m="0"]
+ head_nz[OF np] pnz sz ap[symmetric] ds[symmetric]
+ by (simp add: degree_eq_degreen0[symmetric]) blast }
+ ultimately have ?ths by blast
+ }
+ ultimately have ?ths by blast}
+ ultimately show ?ths by blast
+qed
+
+lemma polydivide_properties:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ and np: "isnpolyh p n0" and ns: "isnpolyh s n1" and pnz: "p \<noteq> 0\<^sub>p"
+ shows "(\<exists> k r. polydivide s p = (k,r) \<and> (\<exists>nr. isnpolyh r nr) \<and> (degree r = 0 \<or> degree r < degree p)
+ \<and> (\<exists>q n1. isnpolyh q n1 \<and> ((polypow k (head p)) *\<^sub>p s = p *\<^sub>p q +\<^sub>p r)))"
+proof-
+ have trv: "head p = head p" "degree p = degree p" by simp_all
+ from polydivide_aux_properties[OF np ns trv pnz, where k="0"]
+ have d: "polydivide_aux_dom (head p, degree p, p, 0, s)" by blast
+ from polydivide_def[where s="s" and p="p"] polydivide_aux.psimps[OF d]
+ have ex: "\<exists> k r. polydivide s p = (k,r)" by auto
+ then obtain k r where kr: "polydivide s p = (k,r)" by blast
+ from trans[OF meta_eq_to_obj_eq[OF polydivide_def[where s="s" and p="p"], symmetric] kr]
+ polydivide_aux_properties[OF np ns trv pnz, where k="0" and k'="k" and r="r"]
+ have "(degree r = 0 \<or> degree r < degree p) \<and>
+ (\<exists>nr. isnpolyh r nr) \<and> (\<exists>q n1. isnpolyh q n1 \<and> head p ^\<^sub>p k - 0 *\<^sub>p s = p *\<^sub>p q +\<^sub>p r)" by blast
+ with kr show ?thesis
+ apply -
+ apply (rule exI[where x="k"])
+ apply (rule exI[where x="r"])
+ apply simp
+ done
+qed
+
+subsection{* More about polypoly and pnormal etc *}
+
+definition "isnonconstant p = (\<not> isconstant p)"
+
+lemma last_map: "xs \<noteq> [] ==> last (map f xs) = f (last xs)" by (induct xs, auto)
+
+lemma isnonconstant_pnormal_iff: assumes nc: "isnonconstant p"
+ shows "pnormal (polypoly bs p) \<longleftrightarrow> Ipoly bs (head p) \<noteq> 0"
+proof
+ let ?p = "polypoly bs p"
+ assume H: "pnormal ?p"
+ have csz: "coefficients p \<noteq> []" using nc by (cases p, auto)
+
+ from coefficients_head[of p] last_map[OF csz, of "Ipoly bs"]
+ pnormal_last_nonzero[OF H]
+ show "Ipoly bs (head p) \<noteq> 0" by (simp add: polypoly_def)
+next
+ assume h: "\<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0"
+ let ?p = "polypoly bs p"
+ have csz: "coefficients p \<noteq> []" using nc by (cases p, auto)
+ hence pz: "?p \<noteq> []" by (simp add: polypoly_def)
+ hence lg: "length ?p > 0" by simp
+ from h coefficients_head[of p] last_map[OF csz, of "Ipoly bs"]
+ have lz: "last ?p \<noteq> 0" by (simp add: polypoly_def)
+ from pnormal_last_length[OF lg lz] show "pnormal ?p" .
+qed
+
+lemma isnonconstant_coefficients_length: "isnonconstant p \<Longrightarrow> length (coefficients p) > 1"
+ unfolding isnonconstant_def
+ apply (cases p, simp_all)
+ apply (case_tac nat, auto)
+ done
+lemma isnonconstant_nonconstant: assumes inc: "isnonconstant p"
+ shows "nonconstant (polypoly bs p) \<longleftrightarrow> Ipoly bs (head p) \<noteq> 0"
+proof
+ let ?p = "polypoly bs p"
+ assume nc: "nonconstant ?p"
+ from isnonconstant_pnormal_iff[OF inc, of bs] nc
+ show "\<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0" unfolding nonconstant_def by blast
+next
+ let ?p = "polypoly bs p"
+ assume h: "\<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0"
+ from isnonconstant_pnormal_iff[OF inc, of bs] h
+ have pn: "pnormal ?p" by blast
+ {fix x assume H: "?p = [x]"
+ from H have "length (coefficients p) = 1" unfolding polypoly_def by auto
+ with isnonconstant_coefficients_length[OF inc] have False by arith}
+ thus "nonconstant ?p" using pn unfolding nonconstant_def by blast
+qed
+
+lemma pnormal_length: "p\<noteq>[] \<Longrightarrow> pnormal p \<longleftrightarrow> length (pnormalize p) = length p"
+ unfolding pnormal_def
+ apply (induct p rule: pnormalize.induct, simp_all)
+ apply (case_tac "p=[]", simp_all)
+ done
+
+lemma degree_degree: assumes inc: "isnonconstant p"
+ shows "degree p = Polynomial_List.degree (polypoly bs p) \<longleftrightarrow> \<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0"
+proof
+ let ?p = "polypoly bs p"
+ assume H: "degree p = Polynomial_List.degree ?p"
+ from isnonconstant_coefficients_length[OF inc] have pz: "?p \<noteq> []"
+ unfolding polypoly_def by auto
+ from H degree_coefficients[of p] isnonconstant_coefficients_length[OF inc]
+ have lg:"length (pnormalize ?p) = length ?p"
+ unfolding Polynomial_List.degree_def polypoly_def by simp
+ hence "pnormal ?p" using pnormal_length[OF pz] by blast
+ with isnonconstant_pnormal_iff[OF inc]
+ show "\<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0" by blast
+next
+ let ?p = "polypoly bs p"
+ assume H: "\<lparr>head p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<noteq> 0"
+ with isnonconstant_pnormal_iff[OF inc] have "pnormal ?p" by blast
+ with degree_coefficients[of p] isnonconstant_coefficients_length[OF inc]
+ show "degree p = Polynomial_List.degree ?p"
+ unfolding polypoly_def pnormal_def Polynomial_List.degree_def by auto
+qed
+
+section{* Swaps ; Division by a certain variable *}
+consts swap:: "nat \<Rightarrow> nat \<Rightarrow> poly \<Rightarrow> poly"
+primrec
+ "swap n m (C x) = C x"
+ "swap n m (Bound k) = Bound (if k = n then m else if k=m then n else k)"
+ "swap n m (Neg t) = Neg (swap n m t)"
+ "swap n m (Add s t) = Add (swap n m s) (swap n m t)"
+ "swap n m (Sub s t) = Sub (swap n m s) (swap n m t)"
+ "swap n m (Mul s t) = Mul (swap n m s) (swap n m t)"
+ "swap n m (Pw t k) = Pw (swap n m t) k"
+ "swap n m (CN c k p) = CN (swap n m c) (if k = n then m else if k=m then n else k)
+ (swap n m p)"
+
+lemma swap: assumes nbs: "n < length bs" and mbs: "m < length bs"
+ shows "Ipoly bs (swap n m t) = Ipoly ((bs[n:= bs!m])[m:= bs!n]) t"
+proof (induct t)
+ case (Bound k) thus ?case using nbs mbs by simp
+next
+ case (CN c k p) thus ?case using nbs mbs by simp
+qed simp_all
+lemma swap_swap_id[simp]: "swap n m (swap m n t) = t"
+ by (induct t,simp_all)
+
+lemma swap_commute: "swap n m p = swap m n p" by (induct p, simp_all)
+
+lemma swap_same_id[simp]: "swap n n t = t"
+ by (induct t, simp_all)
+
+definition "swapnorm n m t = polynate (swap n m t)"
+
+lemma swapnorm: assumes nbs: "n < length bs" and mbs: "m < length bs"
+ shows "((Ipoly bs (swapnorm n m t) :: 'a\<Colon>{ring_char_0,division_by_zero,field})) = Ipoly ((bs[n:= bs!m])[m:= bs!n]) t"
+ using swap[OF prems] swapnorm_def by simp
+
+lemma swapnorm_isnpoly[simp]:
+ assumes "SORT_CONSTRAINT('a::{ring_char_0,division_by_zero,field})"
+ shows "isnpoly (swapnorm n m p)"
+ unfolding swapnorm_def by simp
+
+definition "polydivideby n s p =
+ (let ss = swapnorm 0 n s ; sp = swapnorm 0 n p ; h = head sp; (k,r) = polydivide ss sp
+ in (k,swapnorm 0 n h,swapnorm 0 n r))"
+
+lemma swap_nz [simp]: " (swap n m p = 0\<^sub>p) = (p = 0\<^sub>p)" by (induct p, simp_all)
+
+consts isweaknpoly :: "poly \<Rightarrow> bool"
+recdef isweaknpoly "measure size"
+ "isweaknpoly (C c) = True"
+ "isweaknpoly (CN c n p) \<longleftrightarrow> isweaknpoly c \<and> isweaknpoly p"
+ "isweaknpoly p = False"
+
+lemma isnpolyh_isweaknpoly: "isnpolyh p n0 \<Longrightarrow> isweaknpoly p"
+ by (induct p arbitrary: n0, auto)
+
+lemma swap_isweanpoly: "isweaknpoly p \<Longrightarrow> isweaknpoly (swap n m p)"
+ by (induct p, auto)
+
+end
\ No newline at end of file--- a/src/HOL/FunDef.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/FunDef.thy Tue Oct 27 14:46:03 2009 +0000
@@ -9,20 +9,20 @@
uses
"Tools/prop_logic.ML"
"Tools/sat_solver.ML"
- ("Tools/Function/fundef_lib.ML")
- ("Tools/Function/fundef_common.ML")
+ ("Tools/Function/function_lib.ML")
+ ("Tools/Function/function_common.ML")
("Tools/Function/inductive_wrap.ML")
("Tools/Function/context_tree.ML")
- ("Tools/Function/fundef_core.ML")
+ ("Tools/Function/function_core.ML")
("Tools/Function/sum_tree.ML")
("Tools/Function/mutual.ML")
("Tools/Function/pattern_split.ML")
- ("Tools/Function/fundef.ML")
- ("Tools/Function/auto_term.ML")
+ ("Tools/Function/function.ML")
+ ("Tools/Function/relation.ML")
("Tools/Function/measure_functions.ML")
("Tools/Function/lexicographic_order.ML")
("Tools/Function/pat_completeness.ML")
- ("Tools/Function/fundef_datatype.ML")
+ ("Tools/Function/fun.ML")
("Tools/Function/induction_scheme.ML")
("Tools/Function/termination.ML")
("Tools/Function/decompose.ML")
@@ -104,25 +104,25 @@
"wf R \<Longrightarrow> wfP (in_rel R)"
by (simp add: wfP_def)
-use "Tools/Function/fundef_lib.ML"
-use "Tools/Function/fundef_common.ML"
+use "Tools/Function/function_lib.ML"
+use "Tools/Function/function_common.ML"
use "Tools/Function/inductive_wrap.ML"
use "Tools/Function/context_tree.ML"
-use "Tools/Function/fundef_core.ML"
+use "Tools/Function/function_core.ML"
use "Tools/Function/sum_tree.ML"
use "Tools/Function/mutual.ML"
use "Tools/Function/pattern_split.ML"
-use "Tools/Function/auto_term.ML"
-use "Tools/Function/fundef.ML"
+use "Tools/Function/relation.ML"
+use "Tools/Function/function.ML"
use "Tools/Function/pat_completeness.ML"
-use "Tools/Function/fundef_datatype.ML"
+use "Tools/Function/fun.ML"
use "Tools/Function/induction_scheme.ML"
setup {*
- Fundef.setup
+ Function.setup
#> Pat_Completeness.setup
- #> FundefDatatype.setup
- #> InductionScheme.setup
+ #> Function_Fun.setup
+ #> Induction_Scheme.setup
*}
subsection {* Measure Functions *}
@@ -142,7 +142,7 @@
by (rule is_measure_trivial)
use "Tools/Function/lexicographic_order.ML"
-setup LexicographicOrder.setup
+setup Lexicographic_Order.setup
subsection {* Congruence Rules *}
@@ -320,7 +320,7 @@
ML_val -- "setup inactive"
{*
- Context.theory_map (FundefCommon.set_termination_prover (ScnpReconstruct.decomp_scnp
+ Context.theory_map (Function_Common.set_termination_prover (ScnpReconstruct.decomp_scnp
[ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS]))
*}
--- a/src/HOL/GCD.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/GCD.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1702,4 +1702,12 @@
show ?thesis by(simp add: Gcd_def fold_set gcd_commute_int)
qed
+lemma gcd_eq_nitpick_gcd [nitpick_def]: "gcd x y \<equiv> Nitpick.nat_gcd x y"
+apply (rule eq_reflection)
+apply (induct x y rule: nat_gcd.induct)
+by (simp add: gcd_nat.simps Nitpick.nat_gcd.simps)
+
+lemma lcm_eq_nitpick_lcm [nitpick_def]: "lcm x y \<equiv> Nitpick.nat_lcm x y"
+by (simp only: lcm_nat_def Nitpick.nat_lcm_def gcd_eq_nitpick_gcd)
+
end
--- a/src/HOL/HOL.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/HOL.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1827,24 +1827,28 @@
text {* Code equations *}
lemma [code]:
- shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
- and "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
- and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
- and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
+ shows "(False \<Longrightarrow> P) \<equiv> Trueprop True"
+ and "(True \<Longrightarrow> PROP Q) \<equiv> PROP Q"
+ and "(P \<Longrightarrow> False) \<equiv> Trueprop (\<not> P)"
+ and "(PROP Q \<Longrightarrow> True) \<equiv> Trueprop True" by (auto intro!: equal_intr_rule)
lemma [code]:
- shows "False \<and> x \<longleftrightarrow> False"
- and "True \<and> x \<longleftrightarrow> x"
- and "x \<and> False \<longleftrightarrow> False"
- and "x \<and> True \<longleftrightarrow> x" by simp_all
+ shows "False \<and> P \<longleftrightarrow> False"
+ and "True \<and> P \<longleftrightarrow> P"
+ and "P \<and> False \<longleftrightarrow> False"
+ and "P \<and> True \<longleftrightarrow> P" by simp_all
lemma [code]:
- shows "False \<or> x \<longleftrightarrow> x"
- and "True \<or> x \<longleftrightarrow> True"
- and "x \<or> False \<longleftrightarrow> x"
- and "x \<or> True \<longleftrightarrow> True" by simp_all
+ shows "False \<or> P \<longleftrightarrow> P"
+ and "True \<or> P \<longleftrightarrow> True"
+ and "P \<or> False \<longleftrightarrow> P"
+ and "P \<or> True \<longleftrightarrow> True" by simp_all
-declare imp_conv_disj [code, code_unfold_post]
+lemma [code]:
+ shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
+ and "(True \<longrightarrow> P) \<longleftrightarrow> P"
+ and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
+ and "(P \<longrightarrow> True) \<longleftrightarrow> True" by simp_all
instantiation itself :: (type) eq
begin
@@ -2002,8 +2006,12 @@
*} "solve goal by normalization"
+subsection {* Counterexample Search Units *}
+
subsubsection {* Quickcheck *}
+quickcheck_params [size = 5, iterations = 50]
+
ML {*
structure Quickcheck_RecFun_Simps = Named_Thms
(
@@ -2014,37 +2022,8 @@
setup Quickcheck_RecFun_Simps.setup
-setup {*
- Quickcheck.add_generator ("SML", Codegen.test_term)
-*}
-quickcheck_params [size = 5, iterations = 50]
-
-subsection {* Preprocessing for the predicate compiler *}
-
-ML {*
-structure Predicate_Compile_Alternative_Defs = Named_Thms
-(
- val name = "code_pred_def"
- val description = "alternative definitions of constants for the Predicate Compiler"
-)
-*}
-
-ML {*
-structure Predicate_Compile_Inline_Defs = Named_Thms
-(
- val name = "code_pred_inline"
- val description = "inlining definitions for the Predicate Compiler"
-)
-*}
-
-setup {*
- Predicate_Compile_Alternative_Defs.setup
- #> Predicate_Compile_Inline_Defs.setup
- #> Predicate_Compile_Preproc_Const_Defs.setup
-*}
-
-subsection {* Nitpick setup *}
+subsubsection {* Nitpick setup *}
text {* This will be relocated once Nitpick is moved to HOL. *}
@@ -2079,6 +2058,31 @@
*}
+subsection {* Preprocessing for the predicate compiler *}
+
+ML {*
+structure Predicate_Compile_Alternative_Defs = Named_Thms
+(
+ val name = "code_pred_def"
+ val description = "alternative definitions of constants for the Predicate Compiler"
+)
+*}
+
+ML {*
+structure Predicate_Compile_Inline_Defs = Named_Thms
+(
+ val name = "code_pred_inline"
+ val description = "inlining definitions for the Predicate Compiler"
+)
+*}
+
+setup {*
+ Predicate_Compile_Alternative_Defs.setup
+ #> Predicate_Compile_Inline_Defs.setup
+ #> Predicate_Compile_Preproc_Const_Defs.setup
+*}
+
+
subsection {* Legacy tactics and ML bindings *}
ML {*--- a/src/HOL/Induct/LList.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Induct/LList.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Induct/LList.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Shares NIL, CONS, List_case with List.thy
@@ -905,4 +904,9 @@
lemma lappend_assoc': "lappend (lappend l1 l2) l3 = lappend l1 (lappend l2 l3)"
by (rule_tac l = l1 in llist_fun_equalityI, auto)
+setup {*
+ Nitpick.register_codatatype @{typ "'a llist"} @{const_name llist_case}
+ (map dest_Const [@{term LNil}, @{term LCons}])
+*}
+
end--- a/src/HOL/IsaMakefile Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/IsaMakefile Tue Oct 27 14:46:03 2009 +0000
@@ -6,7 +6,20 @@
default: HOL
generate: HOL-Generate-HOL HOL-Generate-HOLLight
-images: HOL HOL-Base HOL-Plain HOL-Main HOL-Algebra HOL-Nominal HOL-NSA HOL-SMT HOL-Word TLA HOL4
+
+images: \
+ HOL \
+ HOL-Algebra \
+ HOL-Base \
+ HOL-Main \
+ HOL-Multivariate_Analysis \
+ HOL-NSA \
+ HOL-Nominal \
+ HOL-Plain \
+ HOL-SMT \
+ HOL-Word \
+ HOL4 \
+ TLA
#Note: keep targets sorted (except for HOL-Library and HOL-ex)
test: \
@@ -19,11 +32,11 @@
HOL-Hahn_Banach \
HOL-Hoare \
HOL-Hoare_Parallel \
- HOL-Import \
HOL-IMP \
HOL-IMPP \
HOL-IOA \
HOL-Imperative_HOL \
+ HOL-Import \
HOL-Induct \
HOL-Isar_Examples \
HOL-Lambda \
@@ -34,13 +47,14 @@
HOL-Mirabelle \
HOL-Modelcheck \
HOL-NanoJava \
+ HOL-Nitpick_Examples \
HOL-Nominal-Examples \
HOL-Number_Theory \
HOL-Old_Number_Theory \
HOL-Prolog \
HOL-SET_Protocol \
+ HOL-SMT-Examples \
HOL-SizeChange \
- HOL-SMT-Examples \
HOL-Statespace \
HOL-Subst \
TLA-Buffer \
@@ -131,6 +145,7 @@
Inductive.thy \
Lattices.thy \
Nat.thy \
+ Nitpick.thy \
Option.thy \
OrderedGroup.thy \
Orderings.thy \
@@ -156,15 +171,14 @@
Tools/Datatype/datatype_realizer.ML \
Tools/Datatype/datatype_rep_proofs.ML \
Tools/dseq.ML \
- Tools/Function/auto_term.ML \
Tools/Function/context_tree.ML \
Tools/Function/decompose.ML \
Tools/Function/descent.ML \
- Tools/Function/fundef_common.ML \
- Tools/Function/fundef_core.ML \
- Tools/Function/fundef_datatype.ML \
- Tools/Function/fundef_lib.ML \
- Tools/Function/fundef.ML \
+ Tools/Function/function_common.ML \
+ Tools/Function/function_core.ML \
+ Tools/Function/function_lib.ML \
+ Tools/Function/function.ML \
+ Tools/Function/fun.ML \
Tools/Function/induction_scheme.ML \
Tools/Function/inductive_wrap.ML \
Tools/Function/lexicographic_order.ML \
@@ -172,11 +186,27 @@
Tools/Function/mutual.ML \
Tools/Function/pat_completeness.ML \
Tools/Function/pattern_split.ML \
+ Tools/Function/relation.ML \
Tools/Function/scnp_reconstruct.ML \
Tools/Function/scnp_solve.ML \
Tools/Function/size.ML \
Tools/Function/sum_tree.ML \
Tools/Function/termination.ML \
+ Tools/Nitpick/kodkod.ML \
+ Tools/Nitpick/kodkod_sat.ML \
+ Tools/Nitpick/minipick.ML \
+ Tools/Nitpick/nitpick.ML \
+ Tools/Nitpick/nitpick_hol.ML \
+ Tools/Nitpick/nitpick_isar.ML \
+ Tools/Nitpick/nitpick_kodkod.ML \
+ Tools/Nitpick/nitpick_model.ML \
+ Tools/Nitpick/nitpick_mono.ML \
+ Tools/Nitpick/nitpick_nut.ML \
+ Tools/Nitpick/nitpick_peephole.ML \
+ Tools/Nitpick/nitpick_rep.ML \
+ Tools/Nitpick/nitpick_scope.ML \
+ Tools/Nitpick/nitpick_tests.ML \
+ Tools/Nitpick/nitpick_util.ML \
Tools/inductive_codegen.ML \
Tools/inductive.ML \
Tools/inductive_realizer.ML \
@@ -324,21 +354,17 @@
$(LOG)/HOL-Library.gz: $(OUT)/HOL Library/SetsAndFunctions.thy \
Library/Abstract_Rat.thy Library/BigO.thy Library/ContNotDenum.thy \
- Library/Efficient_Nat.thy Library/Euclidean_Space.thy \
- Library/Sum_Of_Squares.thy Library/Sum_Of_Squares/sos_wrapper.ML \
+ Library/Efficient_Nat.thy Library/Sum_Of_Squares.thy \
+ Library/Sum_Of_Squares/sos_wrapper.ML \
Library/Sum_Of_Squares/sum_of_squares.ML Library/Fset.thy \
- Library/Convex_Euclidean_Space.thy Library/Glbs.thy \
- Library/normarith.ML Library/Executable_Set.thy \
+ Library/Glbs.thy Library/normarith.ML Library/Executable_Set.thy \
Library/Infinite_Set.thy Library/FuncSet.thy \
- Library/Permutations.thy Library/Determinants.thy Library/Bit.thy \
- Library/Topology_Euclidean_Space.thy \
- Library/Finite_Cartesian_Product.thy Library/FrechetDeriv.thy \
+ Library/Permutations.thy Library/Bit.thy Library/FrechetDeriv.thy \
Library/Fraction_Field.thy Library/Fundamental_Theorem_Algebra.thy \
Library/Inner_Product.thy Library/Kleene_Algebra.thy \
- Library/Lattice_Syntax.thy \
- Library/Library.thy Library/List_Prefix.thy Library/List_Set.thy \
- Library/State_Monad.thy Library/Nat_Int_Bij.thy Library/Multiset.thy \
- Library/Permutation.thy \
+ Library/Lattice_Syntax.thy Library/Library.thy \
+ Library/List_Prefix.thy Library/List_Set.thy Library/State_Monad.thy \
+ Library/Nat_Int_Bij.thy Library/Multiset.thy Library/Permutation.thy \
Library/Quotient.thy Library/Quicksort.thy Library/Nat_Infinity.thy \
Library/Word.thy Library/README.html Library/Continuity.thy \
Library/Order_Relation.thy Library/Nested_Environment.thy \
@@ -360,7 +386,7 @@
Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML \
$(SRC)/HOL/Tools/float_arith.ML Library/positivstellensatz.ML \
Library/reify_data.ML Library/reflection.ML Library/LaTeXsugar.thy \
- Library/OptionalSugar.thy
+ Library/OptionalSugar.thy Library/SML_Quickcheck.thy
@cd Library; $(ISABELLE_TOOL) usedir $(OUT)/HOL Library
@@ -570,6 +596,21 @@
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Metis_Examples
+## HOL-Nitpick_Examples
+
+HOL-Nitpick_Examples: HOL $(LOG)/HOL-Nitpick_Examples.gz
+
+$(LOG)/HOL-Nitpick_Examples.gz: $(OUT)/HOL Nitpick_Examples/ROOT.ML \
+ Nitpick_Examples/Core_Nits.thy Nitpick_Examples/Datatype_Nits.thy \
+ Nitpick_Examples/Induct_Nits.thy Nitpick_Examples/Manual_Nits.thy \
+ Nitpick_Examples/Mini_Nits.thy Nitpick_Examples/Mono_Nits.thy \
+ Nitpick_Examples/Nitpick_Examples.thy Nitpick_Examples/Pattern_Nits.thy \
+ Nitpick_Examples/Record_Nits.thy Nitpick_Examples/Refute_Nits.thy \
+ Nitpick_Examples/Special_Nits.thy Nitpick_Examples/Tests_Nits.thy \
+ Nitpick_Examples/Typedef_Nits.thy
+ @$(ISABELLE_TOOL) usedir $(OUT)/HOL Nitpick_Examples
+
+
## HOL-Algebra
HOL-Algebra: HOL $(LOG)/HOL-Algebra.gz
@@ -1006,6 +1047,19 @@
@cd TLA; $(ISABELLE_TOOL) usedir $(OUT)/TLA Memory
+## HOL-Multivariate_Analysis
+
+HOL-Multivariate_Analysis: HOL $(OUT)/HOL-Multivariate_Analysis
+
+$(OUT)/HOL-Multivariate_Analysis: $(OUT)/HOL Multivariate_Analysis/ROOT.ML \
+ Multivariate_Analysis/Multivariate_Analysis.thy \
+ Multivariate_Analysis/Determinants.thy \
+ Multivariate_Analysis/Finite_Cartesian_Product.thy \
+ Multivariate_Analysis/Euclidean_Space.thy \
+ Multivariate_Analysis/Topology_Euclidean_Space.thy \
+ Multivariate_Analysis/Convex_Euclidean_Space.thy
+ @cd Multivariate_Analysis; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL HOL-Multivariate_Analysis
+
## HOL-Nominal
HOL-Nominal: HOL $(OUT)/HOL-Nominal
@@ -1043,6 +1097,7 @@
Nominal/Examples/Lam_Funs.thy \
Nominal/Examples/Lambda_mu.thy \
Nominal/Examples/LocalWeakening.thy \
+ Nominal/Examples/Pattern.thy \
Nominal/Examples/ROOT.ML \
Nominal/Examples/SN.thy \
Nominal/Examples/SOS.thy \
@@ -1315,6 +1370,7 @@
$(LOG)/HOL-UNITY.gz $(LOG)/HOL-Modelcheck.gz \
$(LOG)/HOL-Lambda.gz $(LOG)/HOL-Bali.gz \
$(LOG)/HOL-MicroJava.gz $(LOG)/HOL-NanoJava.gz \
+ $(OUT)/HOL-Multivariate_Analysis \
$(LOG)/HOL-Nominal-Examples.gz $(LOG)/HOL-IOA.gz \
$(LOG)/HOL-Lattice $(LOG)/HOL-Matrix \
$(LOG)/HOL-Hahn_Banach.gz $(LOG)/HOL-SET_Protocol.gz \
@@ -1322,7 +1378,7 @@
$(LOG)/TLA-Memory.gz $(LOG)/HOL-Library.gz \
$(LOG)/HOL-Unix.gz $(OUT)/HOL-Word $(LOG)/HOL-Word.gz \
$(LOG)/HOL-Word-Examples.gz $(OUT)/HOL-NSA \
- $(LOG)/HOL-NSA.gz $(LOG)/HOL-NSA-Examples.gz \
- $(LOG)/HOL-Mirabelle.gz $(LOG)/HOL-SMT.gz \
- $(LOG)/HOL-SMT-Examples.gz
+ $(LOG)/HOL-NSA.gz $(LOG)/HOL-NSA-Examples.gz \
+ $(LOG)/HOL-Mirabelle.gz $(OUT)/HOL-SMT \
+ $(LOG)/HOL-SMT.gz $(LOG)/HOL-SMT-Examples.gz
--- a/src/HOL/Library/Coinductive_List.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Library/Coinductive_List.thy Tue Oct 27 14:46:03 2009 +0000
@@ -200,6 +200,7 @@
[code del]: "llist_case c d l =
List_case c (\<lambda>x y. d (inv Datatype.Leaf x) (Abs_llist y)) (Rep_llist l)"
+
syntax (* FIXME? *)
LNil :: logic
LCons :: logic
@@ -848,4 +849,9 @@
qed
qed
+setup {*
+ Nitpick.register_codatatype @{typ "'a llist"} @{const_name llist_case}
+ (map dest_Const [@{term LNil}, @{term LCons}])
+*}
+
end--- a/src/HOL/Library/Convex_Euclidean_Space.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3384 +0,0 @@
-(* Title: HOL/Library/Convex_Euclidean_Space.thy
- Author: Robert Himmelmann, TU Muenchen
-*)
-
-header {* Convex sets, functions and related things. *}
-
-theory Convex_Euclidean_Space
-imports Topology_Euclidean_Space
-begin
-
-
-(* ------------------------------------------------------------------------- *)
-(* To be moved elsewhere *)
-(* ------------------------------------------------------------------------- *)
-
-declare vector_add_ldistrib[simp] vector_ssub_ldistrib[simp] vector_smult_assoc[simp] vector_smult_rneg[simp]
-declare vector_sadd_rdistrib[simp] vector_sub_rdistrib[simp]
-declare dot_ladd[simp] dot_radd[simp] dot_lsub[simp] dot_rsub[simp]
-declare dot_lmult[simp] dot_rmult[simp] dot_lneg[simp] dot_rneg[simp]
-declare UNIV_1[simp]
-
-term "(x::real^'n \<Rightarrow> real) 0"
-
-lemma dim1in[intro]:"Suc 0 \<in> {1::nat .. CARD(1)}" by auto
-
-lemmas vector_component_simps = vector_minus_component vector_smult_component vector_add_component vector_less_eq_def Cart_lambda_beta dest_vec1_def basis_component vector_uminus_component
-
-lemmas continuous_intros = continuous_add continuous_vmul continuous_cmul continuous_const continuous_sub continuous_at_id continuous_within_id
-
-lemmas continuous_on_intros = continuous_on_add continuous_on_const continuous_on_id continuous_on_compose continuous_on_cmul continuous_on_neg continuous_on_sub
- uniformly_continuous_on_add uniformly_continuous_on_const uniformly_continuous_on_id uniformly_continuous_on_compose uniformly_continuous_on_cmul uniformly_continuous_on_neg uniformly_continuous_on_sub
-
-lemma dest_vec1_simps[simp]: fixes a::"real^1"
- shows "a$1 = 0 \<longleftrightarrow> a = 0" (*"a \<le> 1 \<longleftrightarrow> dest_vec1 a \<le> 1" "0 \<le> a \<longleftrightarrow> 0 \<le> dest_vec1 a"*)
- "a \<le> b \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 b" "dest_vec1 (1::real^1) = 1"
- by(auto simp add:vector_component_simps all_1 Cart_eq)
-
-lemma nequals0I:"x\<in>A \<Longrightarrow> A \<noteq> {}" by auto
-
-lemma norm_not_0:"(x::real^'n::finite)\<noteq>0 \<Longrightarrow> norm x \<noteq> 0" by auto
-
-lemma setsum_delta_notmem: assumes "x\<notin>s"
- shows "setsum (\<lambda>y. if (y = x) then P x else Q y) s = setsum Q s"
- "setsum (\<lambda>y. if (x = y) then P x else Q y) s = setsum Q s"
- "setsum (\<lambda>y. if (y = x) then P y else Q y) s = setsum Q s"
- "setsum (\<lambda>y. if (x = y) then P y else Q y) s = setsum Q s"
- apply(rule_tac [!] setsum_cong2) using assms by auto
-
-lemma setsum_delta'':
- fixes s::"'a::real_vector set" assumes "finite s"
- shows "(\<Sum>x\<in>s. (if y = x then f x else 0) *\<^sub>R x) = (if y\<in>s then (f y) *\<^sub>R y else 0)"
-proof-
- have *:"\<And>x y. (if y = x then f x else (0::real)) *\<^sub>R x = (if x=y then (f x) *\<^sub>R x else 0)" by auto
- show ?thesis unfolding * using setsum_delta[OF assms, of y "\<lambda>x. f x *\<^sub>R x"] by auto
-qed
-
-lemma not_disjointI:"x\<in>A \<Longrightarrow> x\<in>B \<Longrightarrow> A \<inter> B \<noteq> {}" by blast
-
-lemma if_smult:"(if P then x else (y::real)) *\<^sub>R v = (if P then x *\<^sub>R v else y *\<^sub>R v)" by auto
-
-lemma mem_interval_1: fixes x :: "real^1" shows
- "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b)"
- "(x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
-by(simp_all add: Cart_eq vector_less_def vector_less_eq_def dest_vec1_def all_1)
-
-lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::real^'n::finite)) ` {a..b} =
- (if {a..b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a..m *\<^sub>R b} else {m *\<^sub>R b..m *\<^sub>R a})"
- using image_affinity_interval[of m 0 a b] by auto
-
-lemma dest_vec1_inverval:
- "dest_vec1 ` {a .. b} = {dest_vec1 a .. dest_vec1 b}"
- "dest_vec1 ` {a<.. b} = {dest_vec1 a<.. dest_vec1 b}"
- "dest_vec1 ` {a ..<b} = {dest_vec1 a ..<dest_vec1 b}"
- "dest_vec1 ` {a<..<b} = {dest_vec1 a<..<dest_vec1 b}"
- apply(rule_tac [!] equalityI)
- unfolding subset_eq Ball_def Bex_def mem_interval_1 image_iff
- apply(rule_tac [!] allI)apply(rule_tac [!] impI)
- apply(rule_tac[2] x="vec1 x" in exI)apply(rule_tac[4] x="vec1 x" in exI)
- apply(rule_tac[6] x="vec1 x" in exI)apply(rule_tac[8] x="vec1 x" in exI)
- by (auto simp add: vector_less_def vector_less_eq_def all_1 dest_vec1_def
- vec1_dest_vec1[unfolded dest_vec1_def One_nat_def])
-
-lemma dest_vec1_setsum: assumes "finite S"
- shows " dest_vec1 (setsum f S) = setsum (\<lambda>x. dest_vec1 (f x)) S"
- using dest_vec1_sum[OF assms] by auto
-
-lemma dist_triangle_eq:
- fixes x y z :: "real ^ _"
- shows "dist x z = dist x y + dist y z \<longleftrightarrow> norm (x - y) *\<^sub>R (y - z) = norm (y - z) *\<^sub>R (x - y)"
-proof- have *:"x - y + (y - z) = x - z" by auto
- show ?thesis unfolding dist_norm norm_triangle_eq[of "x - y" "y - z", unfolded smult_conv_scaleR *]
- by(auto simp add:norm_minus_commute) qed
-
-lemma norm_eqI:"x = y \<Longrightarrow> norm x = norm y" by auto
-lemma norm_minus_eqI:"(x::real^'n::finite) = - y \<Longrightarrow> norm x = norm y" by auto
-
-lemma Min_grI: assumes "finite A" "A \<noteq> {}" "\<forall>a\<in>A. x < a" shows "x < Min A"
- unfolding Min_gr_iff[OF assms(1,2)] using assms(3) by auto
-
-lemma dimindex_ge_1:"CARD(_::finite) \<ge> 1"
- using one_le_card_finite by auto
-
-lemma real_dimindex_ge_1:"real (CARD('n::finite)) \<ge> 1"
- by(metis dimindex_ge_1 linorder_not_less real_eq_of_nat real_le_trans real_of_nat_1 real_of_nat_le_iff)
-
-lemma real_dimindex_gt_0:"real (CARD('n::finite)) > 0" apply(rule less_le_trans[OF _ real_dimindex_ge_1]) by auto
-
-subsection {* Affine set and affine hull.*}
-
-definition
- affine :: "'a::real_vector set \<Rightarrow> bool" where
- "affine s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s)"
-
-lemma affine_alt: "affine s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u::real. (1 - u) *\<^sub>R x + u *\<^sub>R y \<in> s)"
-proof- have *:"\<And>u v ::real. u + v = 1 \<longleftrightarrow> v = 1 - u" by auto
- { fix x y assume "x\<in>s" "y\<in>s"
- hence "(\<forall>u v::real. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s) \<longleftrightarrow> (\<forall>u::real. (1 - u) *\<^sub>R x + u *\<^sub>R y \<in> s)" apply auto
- apply(erule_tac[!] x="1 - u" in allE) unfolding * by auto }
- thus ?thesis unfolding affine_def by auto qed
-
-lemma affine_empty[intro]: "affine {}"
- unfolding affine_def by auto
-
-lemma affine_sing[intro]: "affine {x}"
- unfolding affine_alt by (auto simp add: scaleR_left_distrib [symmetric])
-
-lemma affine_UNIV[intro]: "affine UNIV"
- unfolding affine_def by auto
-
-lemma affine_Inter: "(\<forall>s\<in>f. affine s) \<Longrightarrow> affine (\<Inter> f)"
- unfolding affine_def by auto
-
-lemma affine_Int: "affine s \<Longrightarrow> affine t \<Longrightarrow> affine (s \<inter> t)"
- unfolding affine_def by auto
-
-lemma affine_affine_hull: "affine(affine hull s)"
- unfolding hull_def using affine_Inter[of "{t \<in> affine. s \<subseteq> t}"]
- unfolding mem_def by auto
-
-lemma affine_hull_eq[simp]: "(affine hull s = s) \<longleftrightarrow> affine s"
-proof-
- { fix f assume "f \<subseteq> affine"
- hence "affine (\<Inter>f)" using affine_Inter[of f] unfolding subset_eq mem_def by auto }
- thus ?thesis using hull_eq[unfolded mem_def, of affine s] by auto
-qed
-
-lemma setsum_restrict_set'': assumes "finite A"
- shows "setsum f {x \<in> A. P x} = (\<Sum>x\<in>A. if P x then f x else 0)"
- unfolding mem_def[of _ P, symmetric] unfolding setsum_restrict_set'[OF assms] ..
-
-subsection {* Some explicit formulations (from Lars Schewe). *}
-
-lemma affine: fixes V::"'a::real_vector set"
- shows "affine V \<longleftrightarrow> (\<forall>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> V \<and> setsum u s = 1 \<longrightarrow> (setsum (\<lambda>x. (u x) *\<^sub>R x)) s \<in> V)"
-unfolding affine_def apply rule apply(rule, rule, rule) apply(erule conjE)+
-defer apply(rule, rule, rule, rule, rule) proof-
- fix x y u v assume as:"x \<in> V" "y \<in> V" "u + v = (1::real)"
- "\<forall>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> V \<and> setsum u s = 1 \<longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V"
- thus "u *\<^sub>R x + v *\<^sub>R y \<in> V" apply(cases "x=y")
- using as(4)[THEN spec[where x="{x,y}"], THEN spec[where x="\<lambda>w. if w = x then u else v"]] and as(1-3)
- by(auto simp add: scaleR_left_distrib[THEN sym])
-next
- fix s u assume as:"\<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V"
- "finite s" "s \<noteq> {}" "s \<subseteq> V" "setsum u s = (1::real)"
- def n \<equiv> "card s"
- have "card s = 0 \<or> card s = 1 \<or> card s = 2 \<or> card s > 2" by auto
- thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" proof(auto simp only: disjE)
- assume "card s = 2" hence "card s = Suc (Suc 0)" by auto
- then obtain a b where "s = {a, b}" unfolding card_Suc_eq by auto
- thus ?thesis using as(1)[THEN bspec[where x=a], THEN bspec[where x=b]] using as(4,5)
- by(auto simp add: setsum_clauses(2))
- next assume "card s > 2" thus ?thesis using as and n_def proof(induct n arbitrary: u s)
- case (Suc n) fix s::"'a set" and u::"'a \<Rightarrow> real"
- assume IA:"\<And>u s. \<lbrakk>2 < card s; \<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V; finite s;
- s \<noteq> {}; s \<subseteq> V; setsum u s = 1; n \<equiv> card s \<rbrakk> \<Longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" and
- as:"Suc n \<equiv> card s" "2 < card s" "\<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V"
- "finite s" "s \<noteq> {}" "s \<subseteq> V" "setsum u s = 1"
- have "\<exists>x\<in>s. u x \<noteq> 1" proof(rule_tac ccontr)
- assume " \<not> (\<exists>x\<in>s. u x \<noteq> 1)" hence "setsum u s = real_of_nat (card s)" unfolding card_eq_setsum by auto
- thus False using as(7) and `card s > 2` by (metis Numeral1_eq1_nat less_0_number_of less_int_code(15)
- less_nat_number_of not_less_iff_gr_or_eq of_nat_1 of_nat_eq_iff pos2 rel_simps(4)) qed
- then obtain x where x:"x\<in>s" "u x \<noteq> 1" by auto
-
- have c:"card (s - {x}) = card s - 1" apply(rule card_Diff_singleton) using `x\<in>s` as(4) by auto
- have *:"s = insert x (s - {x})" "finite (s - {x})" using `x\<in>s` and as(4) by auto
- have **:"setsum u (s - {x}) = 1 - u x"
- using setsum_clauses(2)[OF *(2), of u x, unfolded *(1)[THEN sym] as(7)] by auto
- have ***:"inverse (1 - u x) * setsum u (s - {x}) = 1" unfolding ** using `u x \<noteq> 1` by auto
- have "(\<Sum>xa\<in>s - {x}. (inverse (1 - u x) * u xa) *\<^sub>R xa) \<in> V" proof(cases "card (s - {x}) > 2")
- case True hence "s - {x} \<noteq> {}" "card (s - {x}) = n" unfolding c and as(1)[symmetric] proof(rule_tac ccontr)
- assume "\<not> s - {x} \<noteq> {}" hence "card (s - {x}) = 0" unfolding card_0_eq[OF *(2)] by simp
- thus False using True by auto qed auto
- thus ?thesis apply(rule_tac IA[of "s - {x}" "\<lambda>y. (inverse (1 - u x) * u y)"])
- unfolding setsum_right_distrib[THEN sym] using as and *** and True by auto
- next case False hence "card (s - {x}) = Suc (Suc 0)" using as(2) and c by auto
- then obtain a b where "(s - {x}) = {a, b}" "a\<noteq>b" unfolding card_Suc_eq by auto
- thus ?thesis using as(3)[THEN bspec[where x=a], THEN bspec[where x=b]]
- using *** *(2) and `s \<subseteq> V` unfolding setsum_right_distrib by(auto simp add: setsum_clauses(2)) qed
- thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" unfolding scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric]
- apply(subst *) unfolding setsum_clauses(2)[OF *(2)]
- using as(3)[THEN bspec[where x=x], THEN bspec[where x="(inverse (1 - u x)) *\<^sub>R (\<Sum>xa\<in>s - {x}. u xa *\<^sub>R xa)"],
- THEN spec[where x="u x"], THEN spec[where x="1 - u x"]] and rev_subsetD[OF `x\<in>s` `s\<subseteq>V`] and `u x \<noteq> 1` by auto
- qed auto
- next assume "card s = 1" then obtain a where "s={a}" by(auto simp add: card_Suc_eq)
- thus ?thesis using as(4,5) by simp
- qed(insert `s\<noteq>{}` `finite s`, auto)
-qed
-
-lemma affine_hull_explicit:
- "affine hull p = {y. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> setsum (\<lambda>v. (u v) *\<^sub>R v) s = y}"
- apply(rule hull_unique) apply(subst subset_eq) prefer 3 apply rule unfolding mem_Collect_eq and mem_def[of _ affine]
- apply (erule exE)+ apply(erule conjE)+ prefer 2 apply rule proof-
- fix x assume "x\<in>p" thus "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- apply(rule_tac x="{x}" in exI, rule_tac x="\<lambda>x. 1" in exI) by auto
-next
- fix t x s u assume as:"p \<subseteq> t" "affine t" "finite s" "s \<noteq> {}" "s \<subseteq> p" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- thus "x \<in> t" using as(2)[unfolded affine, THEN spec[where x=s], THEN spec[where x=u]] by auto
-next
- show "affine {y. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y}" unfolding affine_def
- apply(rule,rule,rule,rule,rule) unfolding mem_Collect_eq proof-
- fix u v ::real assume uv:"u + v = 1"
- fix x assume "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- then obtain sx ux where x:"finite sx" "sx \<noteq> {}" "sx \<subseteq> p" "setsum ux sx = 1" "(\<Sum>v\<in>sx. ux v *\<^sub>R v) = x" by auto
- fix y assume "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
- then obtain sy uy where y:"finite sy" "sy \<noteq> {}" "sy \<subseteq> p" "setsum uy sy = 1" "(\<Sum>v\<in>sy. uy v *\<^sub>R v) = y" by auto
- have xy:"finite (sx \<union> sy)" using x(1) y(1) by auto
- have **:"(sx \<union> sy) \<inter> sx = sx" "(sx \<union> sy) \<inter> sy = sy" by auto
- show "\<exists>s ua. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum ua s = 1 \<and> (\<Sum>v\<in>s. ua v *\<^sub>R v) = u *\<^sub>R x + v *\<^sub>R y"
- apply(rule_tac x="sx \<union> sy" in exI)
- apply(rule_tac x="\<lambda>a. (if a\<in>sx then u * ux a else 0) + (if a\<in>sy then v * uy a else 0)" in exI)
- unfolding scaleR_left_distrib setsum_addf if_smult scaleR_zero_left ** setsum_restrict_set[OF xy, THEN sym]
- unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and setsum_right_distrib[THEN sym]
- unfolding x y using x(1-3) y(1-3) uv by simp qed qed
-
-lemma affine_hull_finite:
- assumes "finite s"
- shows "affine hull s = {y. \<exists>u. setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}"
- unfolding affine_hull_explicit and expand_set_eq and mem_Collect_eq apply (rule,rule)
- apply(erule exE)+ apply(erule conjE)+ defer apply(erule exE) apply(erule conjE) proof-
- fix x u assume "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- thus "\<exists>sa u. finite sa \<and> \<not> (\<forall>x. (x \<in> sa) = (x \<in> {})) \<and> sa \<subseteq> s \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = x"
- apply(rule_tac x=s in exI, rule_tac x=u in exI) using assms by auto
-next
- fix x t u assume "t \<subseteq> s" hence *:"s \<inter> t = t" by auto
- assume "finite t" "\<not> (\<forall>x. (x \<in> t) = (x \<in> {}))" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = x"
- thus "\<exists>u. setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x" apply(rule_tac x="\<lambda>x. if x\<in>t then u x else 0" in exI)
- unfolding if_smult scaleR_zero_left and setsum_restrict_set[OF assms, THEN sym] and * by auto qed
-
-subsection {* Stepping theorems and hence small special cases. *}
-
-lemma affine_hull_empty[simp]: "affine hull {} = {}"
- apply(rule hull_unique) unfolding mem_def by auto
-
-lemma affine_hull_finite_step:
- fixes y :: "'a::real_vector"
- shows "(\<exists>u. setsum u {} = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) {} = y) \<longleftrightarrow> w = 0 \<and> y = 0" (is ?th1)
- "finite s \<Longrightarrow> (\<exists>u. setsum u (insert a s) = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) (insert a s) = y) \<longleftrightarrow>
- (\<exists>v u. setsum u s = w - v \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y - v *\<^sub>R a)" (is "?as \<Longrightarrow> (?lhs = ?rhs)")
-proof-
- show ?th1 by simp
- assume ?as
- { assume ?lhs
- then obtain u where u:"setsum u (insert a s) = w \<and> (\<Sum>x\<in>insert a s. u x *\<^sub>R x) = y" by auto
- have ?rhs proof(cases "a\<in>s")
- case True hence *:"insert a s = s" by auto
- show ?thesis using u[unfolded *] apply(rule_tac x=0 in exI) by auto
- next
- case False thus ?thesis apply(rule_tac x="u a" in exI) using u and `?as` by auto
- qed } moreover
- { assume ?rhs
- then obtain v u where vu:"setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
- have *:"\<And>x M. (if x = a then v else M) *\<^sub>R x = (if x = a then v *\<^sub>R x else M *\<^sub>R x)" by auto
- have ?lhs proof(cases "a\<in>s")
- case True thus ?thesis
- apply(rule_tac x="\<lambda>x. (if x=a then v else 0) + u x" in exI)
- unfolding setsum_clauses(2)[OF `?as`] apply simp
- unfolding scaleR_left_distrib and setsum_addf
- unfolding vu and * and scaleR_zero_left
- by (auto simp add: setsum_delta[OF `?as`])
- next
- case False
- hence **:"\<And>x. x \<in> s \<Longrightarrow> u x = (if x = a then v else u x)"
- "\<And>x. x \<in> s \<Longrightarrow> u x *\<^sub>R x = (if x = a then v *\<^sub>R x else u x *\<^sub>R x)" by auto
- from False show ?thesis
- apply(rule_tac x="\<lambda>x. if x=a then v else u x" in exI)
- unfolding setsum_clauses(2)[OF `?as`] and * using vu
- using setsum_cong2[of s "\<lambda>x. u x *\<^sub>R x" "\<lambda>x. if x = a then v *\<^sub>R x else u x *\<^sub>R x", OF **(2)]
- using setsum_cong2[of s u "\<lambda>x. if x = a then v else u x", OF **(1)] by auto
- qed }
- ultimately show "?lhs = ?rhs" by blast
-qed
-
-lemma affine_hull_2:
- fixes a b :: "'a::real_vector"
- shows "affine hull {a,b} = {u *\<^sub>R a + v *\<^sub>R b| u v. (u + v = 1)}" (is "?lhs = ?rhs")
-proof-
- have *:"\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::real)"
- "\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::'a)" by auto
- have "?lhs = {y. \<exists>u. setsum u {a, b} = 1 \<and> (\<Sum>v\<in>{a, b}. u v *\<^sub>R v) = y}"
- using affine_hull_finite[of "{a,b}"] by auto
- also have "\<dots> = {y. \<exists>v u. u b = 1 - v \<and> u b *\<^sub>R b = y - v *\<^sub>R a}"
- by(simp add: affine_hull_finite_step(2)[of "{b}" a])
- also have "\<dots> = ?rhs" unfolding * by auto
- finally show ?thesis by auto
-qed
-
-lemma affine_hull_3:
- fixes a b c :: "'a::real_vector"
- shows "affine hull {a,b,c} = { u *\<^sub>R a + v *\<^sub>R b + w *\<^sub>R c| u v w. u + v + w = 1}" (is "?lhs = ?rhs")
-proof-
- have *:"\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::real)"
- "\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::'a)" by auto
- show ?thesis apply(simp add: affine_hull_finite affine_hull_finite_step)
- unfolding * apply auto
- apply(rule_tac x=v in exI) apply(rule_tac x=va in exI) apply auto
- apply(rule_tac x=u in exI) by(auto intro!: exI)
-qed
-
-subsection {* Some relations between affine hull and subspaces. *}
-
-lemma affine_hull_insert_subset_span:
- fixes a :: "real ^ _"
- shows "affine hull (insert a s) \<subseteq> {a + v| v . v \<in> span {x - a | x . x \<in> s}}"
- unfolding subset_eq Ball_def unfolding affine_hull_explicit span_explicit mem_Collect_eq smult_conv_scaleR
- apply(rule,rule) apply(erule exE)+ apply(erule conjE)+ proof-
- fix x t u assume as:"finite t" "t \<noteq> {}" "t \<subseteq> insert a s" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = x"
- have "(\<lambda>x. x - a) ` (t - {a}) \<subseteq> {x - a |x. x \<in> s}" using as(3) by auto
- thus "\<exists>v. x = a + v \<and> (\<exists>S u. finite S \<and> S \<subseteq> {x - a |x. x \<in> s} \<and> (\<Sum>v\<in>S. u v *\<^sub>R v) = v)"
- apply(rule_tac x="x - a" in exI)
- apply (rule conjI, simp)
- apply(rule_tac x="(\<lambda>x. x - a) ` (t - {a})" in exI)
- apply(rule_tac x="\<lambda>x. u (x + a)" in exI)
- apply (rule conjI) using as(1) apply simp
- apply (erule conjI)
- using as(1)
- apply (simp add: setsum_reindex[unfolded inj_on_def] scaleR_right_diff_distrib setsum_subtractf scaleR_left.setsum[THEN sym] setsum_diff1 scaleR_left_diff_distrib)
- unfolding as by simp qed
-
-lemma affine_hull_insert_span:
- fixes a :: "real ^ _"
- assumes "a \<notin> s"
- shows "affine hull (insert a s) =
- {a + v | v . v \<in> span {x - a | x. x \<in> s}}"
- apply(rule, rule affine_hull_insert_subset_span) unfolding subset_eq Ball_def
- unfolding affine_hull_explicit and mem_Collect_eq proof(rule,rule,erule exE,erule conjE)
- fix y v assume "y = a + v" "v \<in> span {x - a |x. x \<in> s}"
- then obtain t u where obt:"finite t" "t \<subseteq> {x - a |x. x \<in> s}" "a + (\<Sum>v\<in>t. u v *\<^sub>R v) = y" unfolding span_explicit smult_conv_scaleR by auto
- def f \<equiv> "(\<lambda>x. x + a) ` t"
- have f:"finite f" "f \<subseteq> s" "(\<Sum>v\<in>f. u (v - a) *\<^sub>R (v - a)) = y - a" unfolding f_def using obt
- by(auto simp add: setsum_reindex[unfolded inj_on_def])
- have *:"f \<inter> {a} = {}" "f \<inter> - {a} = f" using f(2) assms by auto
- show "\<exists>sa u. finite sa \<and> sa \<noteq> {} \<and> sa \<subseteq> insert a s \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y"
- apply(rule_tac x="insert a f" in exI)
- apply(rule_tac x="\<lambda>x. if x=a then 1 - setsum (\<lambda>x. u (x - a)) f else u (x - a)" in exI)
- using assms and f unfolding setsum_clauses(2)[OF f(1)] and if_smult
- unfolding setsum_cases[OF f(1), of "{a}", unfolded singleton_iff] and *
- by (auto simp add: setsum_subtractf scaleR_left.setsum algebra_simps) qed
-
-lemma affine_hull_span:
- fixes a :: "real ^ _"
- assumes "a \<in> s"
- shows "affine hull s = {a + v | v. v \<in> span {x - a | x. x \<in> s - {a}}}"
- using affine_hull_insert_span[of a "s - {a}", unfolded insert_Diff[OF assms]] by auto
-
-subsection {* Convexity. *}
-
-definition
- convex :: "'a::real_vector set \<Rightarrow> bool" where
- "convex s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s)"
-
-lemma convex_alt: "convex s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u. 0 \<le> u \<and> u \<le> 1 \<longrightarrow> ((1 - u) *\<^sub>R x + u *\<^sub>R y) \<in> s)"
-proof- have *:"\<And>u v::real. u + v = 1 \<longleftrightarrow> u = 1 - v" by auto
- show ?thesis unfolding convex_def apply auto
- apply(erule_tac x=x in ballE) apply(erule_tac x=y in ballE) apply(erule_tac x="1 - u" in allE)
- by (auto simp add: *) qed
-
-lemma mem_convex:
- assumes "convex s" "a \<in> s" "b \<in> s" "0 \<le> u" "u \<le> 1"
- shows "((1 - u) *\<^sub>R a + u *\<^sub>R b) \<in> s"
- using assms unfolding convex_alt by auto
-
-lemma convex_empty[intro]: "convex {}"
- unfolding convex_def by simp
-
-lemma convex_singleton[intro]: "convex {a}"
- unfolding convex_def by (auto simp add:scaleR_left_distrib[THEN sym])
-
-lemma convex_UNIV[intro]: "convex UNIV"
- unfolding convex_def by auto
-
-lemma convex_Inter: "(\<forall>s\<in>f. convex s) ==> convex(\<Inter> f)"
- unfolding convex_def by auto
-
-lemma convex_Int: "convex s \<Longrightarrow> convex t \<Longrightarrow> convex (s \<inter> t)"
- unfolding convex_def by auto
-
-lemma convex_halfspace_le: "convex {x. inner a x \<le> b}"
- unfolding convex_def apply auto
- unfolding inner_add inner_scaleR
- by (metis real_convex_bound_le)
-
-lemma convex_halfspace_ge: "convex {x. inner a x \<ge> b}"
-proof- have *:"{x. inner a x \<ge> b} = {x. inner (-a) x \<le> -b}" by auto
- show ?thesis apply(unfold *) using convex_halfspace_le[of "-a" "-b"] by auto qed
-
-lemma convex_hyperplane: "convex {x. inner a x = b}"
-proof-
- have *:"{x. inner a x = b} = {x. inner a x \<le> b} \<inter> {x. inner a x \<ge> b}" by auto
- show ?thesis unfolding * apply(rule convex_Int)
- using convex_halfspace_le convex_halfspace_ge by auto
-qed
-
-lemma convex_halfspace_lt: "convex {x. inner a x < b}"
- unfolding convex_def
- by(auto simp add: real_convex_bound_lt inner_add)
-
-lemma convex_halfspace_gt: "convex {x. inner a x > b}"
- using convex_halfspace_lt[of "-a" "-b"] by auto
-
-lemma convex_positive_orthant: "convex {x::real^'n::finite. (\<forall>i. 0 \<le> x$i)}"
- unfolding convex_def apply auto apply(erule_tac x=i in allE)+
- apply(rule add_nonneg_nonneg) by(auto simp add: mult_nonneg_nonneg)
-
-subsection {* Explicit expressions for convexity in terms of arbitrary sums. *}
-
-lemma convex: "convex s \<longleftrightarrow>
- (\<forall>(k::nat) u x. (\<forall>i. 1\<le>i \<and> i\<le>k \<longrightarrow> 0 \<le> u i \<and> x i \<in>s) \<and> (setsum u {1..k} = 1)
- \<longrightarrow> setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} \<in> s)"
- unfolding convex_def apply rule apply(rule allI)+ defer apply(rule ballI)+ apply(rule allI)+ proof(rule,rule,rule,rule)
- fix x y u v assume as:"\<forall>(k::nat) u x. (\<forall>i. 1 \<le> i \<and> i \<le> k \<longrightarrow> 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow> (\<Sum>i = 1..k. u i *\<^sub>R x i) \<in> s"
- "x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
- show "u *\<^sub>R x + v *\<^sub>R y \<in> s" using as(1)[THEN spec[where x=2], THEN spec[where x="\<lambda>n. if n=1 then u else v"], THEN spec[where x="\<lambda>n. if n=1 then x else y"]] and as(2-)
- by (auto simp add: setsum_head_Suc)
-next
- fix k u x assume as:"\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s"
- show "(\<forall>i::nat. 1 \<le> i \<and> i \<le> k \<longrightarrow> 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow> (\<Sum>i = 1..k. u i *\<^sub>R x i) \<in> s" apply(rule,erule conjE) proof(induct k arbitrary: u)
- case (Suc k) show ?case proof(cases "u (Suc k) = 1")
- case True hence "(\<Sum>i = Suc 0..k. u i *\<^sub>R x i) = 0" apply(rule_tac setsum_0') apply(rule ccontr) unfolding ball_simps apply(erule bexE) proof-
- fix i assume i:"i \<in> {Suc 0..k}" "u i *\<^sub>R x i \<noteq> 0"
- hence ui:"u i \<noteq> 0" by auto
- hence "setsum (\<lambda>k. if k=i then u i else 0) {1 .. k} \<le> setsum u {1 .. k}" apply(rule_tac setsum_mono) using Suc(2) by auto
- hence "setsum u {1 .. k} \<ge> u i" using i(1) by(auto simp add: setsum_delta)
- hence "setsum u {1 .. k} > 0" using ui apply(rule_tac less_le_trans[of _ "u i"]) using Suc(2)[THEN spec[where x=i]] and i(1) by auto
- thus False using Suc(3) unfolding setsum_cl_ivl_Suc and True by simp qed
- thus ?thesis unfolding setsum_cl_ivl_Suc using True and Suc(2) by auto
- next
- have *:"setsum u {1..k} = 1 - u (Suc k)" using Suc(3)[unfolded setsum_cl_ivl_Suc] by auto
- have **:"u (Suc k) \<le> 1" apply(rule ccontr) unfolding not_le using Suc(3) using setsum_nonneg[of "{1..k}" u] using Suc(2) by auto
- have ***:"\<And>i k. (u i / (1 - u (Suc k))) *\<^sub>R x i = (inverse (1 - u (Suc k))) *\<^sub>R (u i *\<^sub>R x i)" unfolding real_divide_def by (auto simp add: algebra_simps)
- case False hence nn:"1 - u (Suc k) \<noteq> 0" by auto
- have "(\<Sum>i = 1..k. (u i / (1 - u (Suc k))) *\<^sub>R x i) \<in> s" apply(rule Suc(1)) unfolding setsum_divide_distrib[THEN sym] and *
- apply(rule_tac allI) apply(rule,rule) apply(rule divide_nonneg_pos) using nn Suc(2) ** by auto
- hence "(1 - u (Suc k)) *\<^sub>R (\<Sum>i = 1..k. (u i / (1 - u (Suc k))) *\<^sub>R x i) + u (Suc k) *\<^sub>R x (Suc k) \<in> s"
- apply(rule as[THEN bspec, THEN bspec, THEN spec, THEN mp, THEN spec, THEN mp, THEN mp]) using Suc(2)[THEN spec[where x="Suc k"]] and ** by auto
- thus ?thesis unfolding setsum_cl_ivl_Suc and *** and scaleR_right.setsum [symmetric] using nn by auto qed qed auto qed
-
-
-lemma convex_explicit:
- fixes s :: "'a::real_vector set"
- shows "convex s \<longleftrightarrow>
- (\<forall>t u. finite t \<and> t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> setsum (\<lambda>x. u x *\<^sub>R x) t \<in> s)"
- unfolding convex_def apply(rule,rule,rule) apply(subst imp_conjL,rule) defer apply(rule,rule,rule,rule,rule,rule,rule) proof-
- fix x y u v assume as:"\<forall>t u. finite t \<and> t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" "x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
- show "u *\<^sub>R x + v *\<^sub>R y \<in> s" proof(cases "x=y")
- case True show ?thesis unfolding True and scaleR_left_distrib[THEN sym] using as(3,6) by auto next
- case False thus ?thesis using as(1)[THEN spec[where x="{x,y}"], THEN spec[where x="\<lambda>z. if z=x then u else v"]] and as(2-) by auto qed
-next
- fix t u assume asm:"\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s" "finite (t::'a set)"
- (*"finite t" "t \<subseteq> s" "\<forall>x\<in>t. (0::real) \<le> u x" "setsum u t = 1"*)
- from this(2) have "\<forall>u. t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" apply(induct_tac t rule:finite_induct)
- prefer 3 apply (rule,rule) apply(erule conjE)+ proof-
- fix x f u assume ind:"\<forall>u. f \<subseteq> s \<and> (\<forall>x\<in>f. 0 \<le> u x) \<and> setsum u f = 1 \<longrightarrow> (\<Sum>x\<in>f. u x *\<^sub>R x) \<in> s"
- assume as:"finite f" "x \<notin> f" "insert x f \<subseteq> s" "\<forall>x\<in>insert x f. 0 \<le> u x" "setsum u (insert x f) = (1::real)"
- show "(\<Sum>x\<in>insert x f. u x *\<^sub>R x) \<in> s" proof(cases "u x = 1")
- case True hence "setsum (\<lambda>x. u x *\<^sub>R x) f = 0" apply(rule_tac setsum_0') apply(rule ccontr) unfolding ball_simps apply(erule bexE) proof-
- fix y assume y:"y \<in> f" "u y *\<^sub>R y \<noteq> 0"
- hence uy:"u y \<noteq> 0" by auto
- hence "setsum (\<lambda>k. if k=y then u y else 0) f \<le> setsum u f" apply(rule_tac setsum_mono) using as(4) by auto
- hence "setsum u f \<ge> u y" using y(1) and as(1) by(auto simp add: setsum_delta)
- hence "setsum u f > 0" using uy apply(rule_tac less_le_trans[of _ "u y"]) using as(4) and y(1) by auto
- thus False using as(2,5) unfolding setsum_clauses(2)[OF as(1)] and True by auto qed
- thus ?thesis unfolding setsum_clauses(2)[OF as(1)] using as(2,3) unfolding True by auto
- next
- have *:"setsum u f = setsum u (insert x f) - u x" using as(2) unfolding setsum_clauses(2)[OF as(1)] by auto
- have **:"u x \<le> 1" apply(rule ccontr) unfolding not_le using as(5)[unfolded setsum_clauses(2)[OF as(1)]] and as(2)
- using setsum_nonneg[of f u] and as(4) by auto
- case False hence "inverse (1 - u x) *\<^sub>R (\<Sum>x\<in>f. u x *\<^sub>R x) \<in> s" unfolding scaleR_right.setsum and scaleR_scaleR
- apply(rule_tac ind[THEN spec, THEN mp]) apply rule defer apply rule apply rule apply(rule mult_nonneg_nonneg)
- unfolding setsum_right_distrib[THEN sym] and * using as and ** by auto
- hence "u x *\<^sub>R x + (1 - u x) *\<^sub>R ((inverse (1 - u x)) *\<^sub>R setsum (\<lambda>x. u x *\<^sub>R x) f) \<in>s"
- apply(rule_tac asm(1)[THEN bspec, THEN bspec, THEN spec, THEN mp, THEN spec, THEN mp, THEN mp]) using as and ** False by auto
- thus ?thesis unfolding setsum_clauses(2)[OF as(1)] using as(2) and False by auto qed
- qed auto thus "t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" by auto
-qed
-
-lemma convex_finite: assumes "finite s"
- shows "convex s \<longleftrightarrow> (\<forall>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1
- \<longrightarrow> setsum (\<lambda>x. u x *\<^sub>R x) s \<in> s)"
- unfolding convex_explicit apply(rule, rule, rule) defer apply(rule,rule,rule)apply(erule conjE)+ proof-
- fix t u assume as:"\<forall>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> s" " finite t" "t \<subseteq> s" "\<forall>x\<in>t. 0 \<le> u x" "setsum u t = (1::real)"
- have *:"s \<inter> t = t" using as(3) by auto
- show "(\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" using as(1)[THEN spec[where x="\<lambda>x. if x\<in>t then u x else 0"]]
- unfolding if_smult and setsum_cases[OF assms] and * using as(2-) by auto
-qed (erule_tac x=s in allE, erule_tac x=u in allE, auto)
-
-subsection {* Cones. *}
-
-definition
- cone :: "'a::real_vector set \<Rightarrow> bool" where
- "cone s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>c\<ge>0. (c *\<^sub>R x) \<in> s)"
-
-lemma cone_empty[intro, simp]: "cone {}"
- unfolding cone_def by auto
-
-lemma cone_univ[intro, simp]: "cone UNIV"
- unfolding cone_def by auto
-
-lemma cone_Inter[intro]: "(\<forall>s\<in>f. cone s) \<Longrightarrow> cone(\<Inter> f)"
- unfolding cone_def by auto
-
-subsection {* Conic hull. *}
-
-lemma cone_cone_hull: "cone (cone hull s)"
- unfolding hull_def using cone_Inter[of "{t \<in> conic. s \<subseteq> t}"]
- by (auto simp add: mem_def)
-
-lemma cone_hull_eq: "(cone hull s = s) \<longleftrightarrow> cone s"
- apply(rule hull_eq[unfolded mem_def])
- using cone_Inter unfolding subset_eq by (auto simp add: mem_def)
-
-subsection {* Affine dependence and consequential theorems (from Lars Schewe). *}
-
-definition
- affine_dependent :: "'a::real_vector set \<Rightarrow> bool" where
- "affine_dependent s \<longleftrightarrow> (\<exists>x\<in>s. x \<in> (affine hull (s - {x})))"
-
-lemma affine_dependent_explicit:
- "affine_dependent p \<longleftrightarrow>
- (\<exists>s u. finite s \<and> s \<subseteq> p \<and> setsum u s = 0 \<and>
- (\<exists>v\<in>s. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = 0)"
- unfolding affine_dependent_def affine_hull_explicit mem_Collect_eq apply(rule)
- apply(erule bexE,erule exE,erule exE) apply(erule conjE)+ defer apply(erule exE,erule exE) apply(erule conjE)+ apply(erule bexE)
-proof-
- fix x s u assume as:"x \<in> p" "finite s" "s \<noteq> {}" "s \<subseteq> p - {x}" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- have "x\<notin>s" using as(1,4) by auto
- show "\<exists>s u. finite s \<and> s \<subseteq> p \<and> setsum u s = 0 \<and> (\<exists>v\<in>s. u v \<noteq> 0) \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = 0"
- apply(rule_tac x="insert x s" in exI, rule_tac x="\<lambda>v. if v = x then - 1 else u v" in exI)
- unfolding if_smult and setsum_clauses(2)[OF as(2)] and setsum_delta_notmem[OF `x\<notin>s`] and as using as by auto
-next
- fix s u v assume as:"finite s" "s \<subseteq> p" "setsum u s = 0" "(\<Sum>v\<in>s. u v *\<^sub>R v) = 0" "v \<in> s" "u v \<noteq> 0"
- have "s \<noteq> {v}" using as(3,6) by auto
- thus "\<exists>x\<in>p. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p - {x} \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- apply(rule_tac x=v in bexI, rule_tac x="s - {v}" in exI, rule_tac x="\<lambda>x. - (1 / u v) * u x" in exI)
- unfolding scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric] unfolding setsum_right_distrib[THEN sym] and setsum_diff1[OF as(1)] using as by auto
-qed
-
-lemma affine_dependent_explicit_finite:
- fixes s :: "'a::real_vector set" assumes "finite s"
- shows "affine_dependent s \<longleftrightarrow> (\<exists>u. setsum u s = 0 \<and> (\<exists>v\<in>s. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = 0)"
- (is "?lhs = ?rhs")
-proof
- have *:"\<And>vt u v. (if vt then u v else 0) *\<^sub>R v = (if vt then (u v) *\<^sub>R v else (0::'a))" by auto
- assume ?lhs
- then obtain t u v where "finite t" "t \<subseteq> s" "setsum u t = 0" "v\<in>t" "u v \<noteq> 0" "(\<Sum>v\<in>t. u v *\<^sub>R v) = 0"
- unfolding affine_dependent_explicit by auto
- thus ?rhs apply(rule_tac x="\<lambda>x. if x\<in>t then u x else 0" in exI)
- apply auto unfolding * and setsum_restrict_set[OF assms, THEN sym]
- unfolding Int_absorb1[OF `t\<subseteq>s`] by auto
-next
- assume ?rhs
- then obtain u v where "setsum u s = 0" "v\<in>s" "u v \<noteq> 0" "(\<Sum>v\<in>s. u v *\<^sub>R v) = 0" by auto
- thus ?lhs unfolding affine_dependent_explicit using assms by auto
-qed
-
-subsection {* A general lemma. *}
-
-lemma convex_connected:
- fixes s :: "'a::real_normed_vector set"
- assumes "convex s" shows "connected s"
-proof-
- { fix e1 e2 assume as:"open e1" "open e2" "e1 \<inter> e2 \<inter> s = {}" "s \<subseteq> e1 \<union> e2"
- assume "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
- then obtain x1 x2 where x1:"x1\<in>e1" "x1\<in>s" and x2:"x2\<in>e2" "x2\<in>s" by auto
- hence n:"norm (x1 - x2) > 0" unfolding zero_less_norm_iff using as(3) by auto
-
- { fix x e::real assume as:"0 \<le> x" "x \<le> 1" "0 < e"
- { fix y have *:"(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2) = (y - x) *\<^sub>R x1 - (y - x) *\<^sub>R x2"
- by (simp add: algebra_simps)
- assume "\<bar>y - x\<bar> < e / norm (x1 - x2)"
- hence "norm ((1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2)) < e"
- unfolding * and scaleR_right_diff_distrib[THEN sym]
- unfolding less_divide_eq using n by auto }
- hence "\<exists>d>0. \<forall>y. \<bar>y - x\<bar> < d \<longrightarrow> norm ((1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2)) < e"
- apply(rule_tac x="e / norm (x1 - x2)" in exI) using as
- apply auto unfolding zero_less_divide_iff using n by simp } note * = this
-
- have "\<exists>x\<ge>0. x \<le> 1 \<and> (1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e1 \<and> (1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e2"
- apply(rule connected_real_lemma) apply (simp add: `x1\<in>e1` `x2\<in>e2` dist_commute)+
- using * apply(simp add: dist_norm)
- using as(1,2)[unfolded open_dist] apply simp
- using as(1,2)[unfolded open_dist] apply simp
- using assms[unfolded convex_alt, THEN bspec[where x=x1], THEN bspec[where x=x2]] using x1 x2
- using as(3) by auto
- then obtain x where "x\<ge>0" "x\<le>1" "(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e1" "(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e2" by auto
- hence False using as(4)
- using assms[unfolded convex_alt, THEN bspec[where x=x1], THEN bspec[where x=x2]]
- using x1(2) x2(2) by auto }
- thus ?thesis unfolding connected_def by auto
-qed
-
-subsection {* One rather trivial consequence. *}
-
-lemma connected_UNIV: "connected (UNIV :: 'a::real_normed_vector set)"
- by(simp add: convex_connected convex_UNIV)
-
-subsection {* Convex functions into the reals. *}
-
-definition
- convex_on :: "'a::real_vector set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" where
- "convex_on s f \<longleftrightarrow>
- (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y)"
-
-lemma convex_on_subset: "convex_on t f \<Longrightarrow> s \<subseteq> t \<Longrightarrow> convex_on s f"
- unfolding convex_on_def by auto
-
-lemma convex_add:
- assumes "convex_on s f" "convex_on s g"
- shows "convex_on s (\<lambda>x. f x + g x)"
-proof-
- { fix x y assume "x\<in>s" "y\<in>s" moreover
- fix u v ::real assume "0 \<le> u" "0 \<le> v" "u + v = 1"
- ultimately have "f (u *\<^sub>R x + v *\<^sub>R y) + g (u *\<^sub>R x + v *\<^sub>R y) \<le> (u * f x + v * f y) + (u * g x + v * g y)"
- using assms(1)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
- using assms(2)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
- apply - apply(rule add_mono) by auto
- hence "f (u *\<^sub>R x + v *\<^sub>R y) + g (u *\<^sub>R x + v *\<^sub>R y) \<le> u * (f x + g x) + v * (f y + g y)" by (simp add: ring_simps) }
- thus ?thesis unfolding convex_on_def by auto
-qed
-
-lemma convex_cmul:
- assumes "0 \<le> (c::real)" "convex_on s f"
- shows "convex_on s (\<lambda>x. c * f x)"
-proof-
- have *:"\<And>u c fx v fy ::real. u * (c * fx) + v * (c * fy) = c * (u * fx + v * fy)" by (simp add: ring_simps)
- show ?thesis using assms(2) and mult_mono1[OF _ assms(1)] unfolding convex_on_def and * by auto
-qed
-
-lemma convex_lower:
- assumes "convex_on s f" "x\<in>s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = 1"
- shows "f (u *\<^sub>R x + v *\<^sub>R y) \<le> max (f x) (f y)"
-proof-
- let ?m = "max (f x) (f y)"
- have "u * f x + v * f y \<le> u * max (f x) (f y) + v * max (f x) (f y)" apply(rule add_mono)
- using assms(4,5) by(auto simp add: mult_mono1)
- also have "\<dots> = max (f x) (f y)" using assms(6) unfolding distrib[THEN sym] by auto
- finally show ?thesis using assms(1)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
- using assms(2-6) by auto
-qed
-
-lemma convex_local_global_minimum:
- fixes s :: "'a::real_normed_vector set"
- assumes "0<e" "convex_on s f" "ball x e \<subseteq> s" "\<forall>y\<in>ball x e. f x \<le> f y"
- shows "\<forall>y\<in>s. f x \<le> f y"
-proof(rule ccontr)
- have "x\<in>s" using assms(1,3) by auto
- assume "\<not> (\<forall>y\<in>s. f x \<le> f y)"
- then obtain y where "y\<in>s" and y:"f x > f y" by auto
- hence xy:"0 < dist x y" by (auto simp add: dist_nz[THEN sym])
-
- then obtain u where "0 < u" "u \<le> 1" and u:"u < e / dist x y"
- using real_lbound_gt_zero[of 1 "e / dist x y"] using xy `e>0` and divide_pos_pos[of e "dist x y"] by auto
- hence "f ((1-u) *\<^sub>R x + u *\<^sub>R y) \<le> (1-u) * f x + u * f y" using `x\<in>s` `y\<in>s`
- using assms(2)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x="1-u"]] by auto
- moreover
- have *:"x - ((1 - u) *\<^sub>R x + u *\<^sub>R y) = u *\<^sub>R (x - y)" by (simp add: algebra_simps)
- have "(1 - u) *\<^sub>R x + u *\<^sub>R y \<in> ball x e" unfolding mem_ball dist_norm unfolding * and norm_scaleR and abs_of_pos[OF `0<u`] unfolding dist_norm[THEN sym]
- using u unfolding pos_less_divide_eq[OF xy] by auto
- hence "f x \<le> f ((1 - u) *\<^sub>R x + u *\<^sub>R y)" using assms(4) by auto
- ultimately show False using mult_strict_left_mono[OF y `u>0`] unfolding left_diff_distrib by auto
-qed
-
-lemma convex_distance:
- fixes s :: "'a::real_normed_vector set"
- shows "convex_on s (\<lambda>x. dist a x)"
-proof(auto simp add: convex_on_def dist_norm)
- fix x y assume "x\<in>s" "y\<in>s"
- fix u v ::real assume "0 \<le> u" "0 \<le> v" "u + v = 1"
- have "a = u *\<^sub>R a + v *\<^sub>R a" unfolding scaleR_left_distrib[THEN sym] and `u+v=1` by simp
- hence *:"a - (u *\<^sub>R x + v *\<^sub>R y) = (u *\<^sub>R (a - x)) + (v *\<^sub>R (a - y))"
- by (auto simp add: algebra_simps)
- show "norm (a - (u *\<^sub>R x + v *\<^sub>R y)) \<le> u * norm (a - x) + v * norm (a - y)"
- unfolding * using norm_triangle_ineq[of "u *\<^sub>R (a - x)" "v *\<^sub>R (a - y)"]
- using `0 \<le> u` `0 \<le> v` by auto
-qed
-
-subsection {* Arithmetic operations on sets preserve convexity. *}
-
-lemma convex_scaling: "convex s \<Longrightarrow> convex ((\<lambda>x. c *\<^sub>R x) ` s)"
- unfolding convex_def and image_iff apply auto
- apply (rule_tac x="u *\<^sub>R x+v *\<^sub>R y" in bexI) by (auto simp add: algebra_simps)
-
-lemma convex_negations: "convex s \<Longrightarrow> convex ((\<lambda>x. -x)` s)"
- unfolding convex_def and image_iff apply auto
- apply (rule_tac x="u *\<^sub>R x+v *\<^sub>R y" in bexI) by auto
-
-lemma convex_sums:
- assumes "convex s" "convex t"
- shows "convex {x + y| x y. x \<in> s \<and> y \<in> t}"
-proof(auto simp add: convex_def image_iff scaleR_right_distrib)
- fix xa xb ya yb assume xy:"xa\<in>s" "xb\<in>s" "ya\<in>t" "yb\<in>t"
- fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
- show "\<exists>x y. u *\<^sub>R xa + u *\<^sub>R ya + (v *\<^sub>R xb + v *\<^sub>R yb) = x + y \<and> x \<in> s \<and> y \<in> t"
- apply(rule_tac x="u *\<^sub>R xa + v *\<^sub>R xb" in exI) apply(rule_tac x="u *\<^sub>R ya + v *\<^sub>R yb" in exI)
- using assms(1)[unfolded convex_def, THEN bspec[where x=xa], THEN bspec[where x=xb]]
- using assms(2)[unfolded convex_def, THEN bspec[where x=ya], THEN bspec[where x=yb]]
- using uv xy by auto
-qed
-
-lemma convex_differences:
- assumes "convex s" "convex t"
- shows "convex {x - y| x y. x \<in> s \<and> y \<in> t}"
-proof-
- have "{x - y| x y. x \<in> s \<and> y \<in> t} = {x + y |x y. x \<in> s \<and> y \<in> uminus ` t}" unfolding image_iff apply auto
- apply(rule_tac x=xa in exI) apply(rule_tac x="-y" in exI) apply simp
- apply(rule_tac x=xa in exI) apply(rule_tac x=xb in exI) by simp
- thus ?thesis using convex_sums[OF assms(1) convex_negations[OF assms(2)]] by auto
-qed
-
-lemma convex_translation: assumes "convex s" shows "convex ((\<lambda>x. a + x) ` s)"
-proof- have "{a + y |y. y \<in> s} = (\<lambda>x. a + x) ` s" by auto
- thus ?thesis using convex_sums[OF convex_singleton[of a] assms] by auto qed
-
-lemma convex_affinity: assumes "convex s" shows "convex ((\<lambda>x. a + c *\<^sub>R x) ` s)"
-proof- have "(\<lambda>x. a + c *\<^sub>R x) ` s = op + a ` op *\<^sub>R c ` s" by auto
- thus ?thesis using convex_translation[OF convex_scaling[OF assms], of a c] by auto qed
-
-lemma convex_linear_image:
- assumes c:"convex s" and l:"bounded_linear f"
- shows "convex(f ` s)"
-proof(auto simp add: convex_def)
- interpret f: bounded_linear f by fact
- fix x y assume xy:"x \<in> s" "y \<in> s"
- fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
- show "u *\<^sub>R f x + v *\<^sub>R f y \<in> f ` s" unfolding image_iff
- apply(rule_tac x="u *\<^sub>R x + v *\<^sub>R y" in bexI)
- unfolding f.add f.scaleR
- using c[unfolded convex_def] xy uv by auto
-qed
-
-subsection {* Balls, being convex, are connected. *}
-
-lemma convex_ball:
- fixes x :: "'a::real_normed_vector"
- shows "convex (ball x e)"
-proof(auto simp add: convex_def)
- fix y z assume yz:"dist x y < e" "dist x z < e"
- fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
- have "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> u * dist x y + v * dist x z" using uv yz
- using convex_distance[of "ball x e" x, unfolded convex_on_def, THEN bspec[where x=y], THEN bspec[where x=z]] by auto
- thus "dist x (u *\<^sub>R y + v *\<^sub>R z) < e" using real_convex_bound_lt[OF yz uv] by auto
-qed
-
-lemma convex_cball:
- fixes x :: "'a::real_normed_vector"
- shows "convex(cball x e)"
-proof(auto simp add: convex_def Ball_def mem_cball)
- fix y z assume yz:"dist x y \<le> e" "dist x z \<le> e"
- fix u v ::real assume uv:" 0 \<le> u" "0 \<le> v" "u + v = 1"
- have "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> u * dist x y + v * dist x z" using uv yz
- using convex_distance[of "cball x e" x, unfolded convex_on_def, THEN bspec[where x=y], THEN bspec[where x=z]] by auto
- thus "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> e" using real_convex_bound_le[OF yz uv] by auto
-qed
-
-lemma connected_ball:
- fixes x :: "'a::real_normed_vector"
- shows "connected (ball x e)"
- using convex_connected convex_ball by auto
-
-lemma connected_cball:
- fixes x :: "'a::real_normed_vector"
- shows "connected(cball x e)"
- using convex_connected convex_cball by auto
-
-subsection {* Convex hull. *}
-
-lemma convex_convex_hull: "convex(convex hull s)"
- unfolding hull_def using convex_Inter[of "{t\<in>convex. s\<subseteq>t}"]
- unfolding mem_def by auto
-
-lemma convex_hull_eq: "(convex hull s = s) \<longleftrightarrow> convex s" apply(rule hull_eq[unfolded mem_def])
- using convex_Inter[unfolded Ball_def mem_def] by auto
-
-lemma bounded_convex_hull:
- fixes s :: "'a::real_normed_vector set"
- assumes "bounded s" shows "bounded(convex hull s)"
-proof- from assms obtain B where B:"\<forall>x\<in>s. norm x \<le> B" unfolding bounded_iff by auto
- show ?thesis apply(rule bounded_subset[OF bounded_cball, of _ 0 B])
- unfolding subset_hull[unfolded mem_def, of convex, OF convex_cball]
- unfolding subset_eq mem_cball dist_norm using B by auto qed
-
-lemma finite_imp_bounded_convex_hull:
- fixes s :: "'a::real_normed_vector set"
- shows "finite s \<Longrightarrow> bounded(convex hull s)"
- using bounded_convex_hull finite_imp_bounded by auto
-
-subsection {* Stepping theorems for convex hulls of finite sets. *}
-
-lemma convex_hull_empty[simp]: "convex hull {} = {}"
- apply(rule hull_unique) unfolding mem_def by auto
-
-lemma convex_hull_singleton[simp]: "convex hull {a} = {a}"
- apply(rule hull_unique) unfolding mem_def by auto
-
-lemma convex_hull_insert:
- fixes s :: "'a::real_vector set"
- assumes "s \<noteq> {}"
- shows "convex hull (insert a s) = {x. \<exists>u\<ge>0. \<exists>v\<ge>0. \<exists>b. (u + v = 1) \<and>
- b \<in> (convex hull s) \<and> (x = u *\<^sub>R a + v *\<^sub>R b)}" (is "?xyz = ?hull")
- apply(rule,rule hull_minimal,rule) unfolding mem_def[of _ convex] and insert_iff prefer 3 apply rule proof-
- fix x assume x:"x = a \<or> x \<in> s"
- thus "x\<in>?hull" apply rule unfolding mem_Collect_eq apply(rule_tac x=1 in exI) defer
- apply(rule_tac x=0 in exI) using assms hull_subset[of s convex] by auto
-next
- fix x assume "x\<in>?hull"
- then obtain u v b where obt:"u\<ge>0" "v\<ge>0" "u + v = 1" "b \<in> convex hull s" "x = u *\<^sub>R a + v *\<^sub>R b" by auto
- have "a\<in>convex hull insert a s" "b\<in>convex hull insert a s"
- using hull_mono[of s "insert a s" convex] hull_mono[of "{a}" "insert a s" convex] and obt(4) by auto
- thus "x\<in> convex hull insert a s" unfolding obt(5) using convex_convex_hull[of "insert a s", unfolded convex_def]
- apply(erule_tac x=a in ballE) apply(erule_tac x=b in ballE) apply(erule_tac x=u in allE) using obt by auto
-next
- show "convex ?hull" unfolding convex_def apply(rule,rule,rule,rule,rule,rule,rule) proof-
- fix x y u v assume as:"(0::real) \<le> u" "0 \<le> v" "u + v = 1" "x\<in>?hull" "y\<in>?hull"
- from as(4) obtain u1 v1 b1 where obt1:"u1\<ge>0" "v1\<ge>0" "u1 + v1 = 1" "b1 \<in> convex hull s" "x = u1 *\<^sub>R a + v1 *\<^sub>R b1" by auto
- from as(5) obtain u2 v2 b2 where obt2:"u2\<ge>0" "v2\<ge>0" "u2 + v2 = 1" "b2 \<in> convex hull s" "y = u2 *\<^sub>R a + v2 *\<^sub>R b2" by auto
- have *:"\<And>(x::'a) s1 s2. x - s1 *\<^sub>R x - s2 *\<^sub>R x = ((1::real) - (s1 + s2)) *\<^sub>R x" by (auto simp add: algebra_simps)
- have "\<exists>b \<in> convex hull s. u *\<^sub>R x + v *\<^sub>R y = (u * u1) *\<^sub>R a + (v * u2) *\<^sub>R a + (b - (u * u1) *\<^sub>R b - (v * u2) *\<^sub>R b)"
- proof(cases "u * v1 + v * v2 = 0")
- have *:"\<And>(x::'a) s1 s2. x - s1 *\<^sub>R x - s2 *\<^sub>R x = ((1::real) - (s1 + s2)) *\<^sub>R x" by (auto simp add: algebra_simps)
- case True hence **:"u * v1 = 0" "v * v2 = 0" apply- apply(rule_tac [!] ccontr)
- using mult_nonneg_nonneg[OF `u\<ge>0` `v1\<ge>0`] mult_nonneg_nonneg[OF `v\<ge>0` `v2\<ge>0`] by auto
- hence "u * u1 + v * u2 = 1" using as(3) obt1(3) obt2(3) by auto
- thus ?thesis unfolding obt1(5) obt2(5) * using assms hull_subset[of s convex] by(auto simp add: ** scaleR_right_distrib)
- next
- have "1 - (u * u1 + v * u2) = (u + v) - (u * u1 + v * u2)" using as(3) obt1(3) obt2(3) by (auto simp add: field_simps)
- also have "\<dots> = u * (v1 + u1 - u1) + v * (v2 + u2 - u2)" using as(3) obt1(3) obt2(3) by (auto simp add: field_simps)
- also have "\<dots> = u * v1 + v * v2" by simp finally have **:"1 - (u * u1 + v * u2) = u * v1 + v * v2" by auto
- case False have "0 \<le> u * v1 + v * v2" "0 \<le> u * v1" "0 \<le> u * v1 + v * v2" "0 \<le> v * v2" apply -
- apply(rule add_nonneg_nonneg) prefer 4 apply(rule add_nonneg_nonneg) apply(rule_tac [!] mult_nonneg_nonneg)
- using as(1,2) obt1(1,2) obt2(1,2) by auto
- thus ?thesis unfolding obt1(5) obt2(5) unfolding * and ** using False
- apply(rule_tac x="((u * v1) / (u * v1 + v * v2)) *\<^sub>R b1 + ((v * v2) / (u * v1 + v * v2)) *\<^sub>R b2" in bexI) defer
- apply(rule convex_convex_hull[of s, unfolded convex_def, rule_format]) using obt1(4) obt2(4)
- unfolding add_divide_distrib[THEN sym] and real_0_le_divide_iff
- by (auto simp add: scaleR_left_distrib scaleR_right_distrib)
- qed note * = this
- have u1:"u1 \<le> 1" apply(rule ccontr) unfolding obt1(3)[THEN sym] and not_le using obt1(2) by auto
- have u2:"u2 \<le> 1" apply(rule ccontr) unfolding obt2(3)[THEN sym] and not_le using obt2(2) by auto
- have "u1 * u + u2 * v \<le> (max u1 u2) * u + (max u1 u2) * v" apply(rule add_mono)
- apply(rule_tac [!] mult_right_mono) using as(1,2) obt1(1,2) obt2(1,2) by auto
- also have "\<dots> \<le> 1" unfolding mult.add_right[THEN sym] and as(3) using u1 u2 by auto
- finally
- show "u *\<^sub>R x + v *\<^sub>R y \<in> ?hull" unfolding mem_Collect_eq apply(rule_tac x="u * u1 + v * u2" in exI)
- apply(rule conjI) defer apply(rule_tac x="1 - u * u1 - v * u2" in exI) unfolding Bex_def
- using as(1,2) obt1(1,2) obt2(1,2) * by(auto intro!: mult_nonneg_nonneg add_nonneg_nonneg simp add: algebra_simps)
- qed
-qed
-
-
-subsection {* Explicit expression for convex hull. *}
-
-lemma convex_hull_indexed:
- fixes s :: "'a::real_vector set"
- shows "convex hull s = {y. \<exists>k u x. (\<forall>i\<in>{1::nat .. k}. 0 \<le> u i \<and> x i \<in> s) \<and>
- (setsum u {1..k} = 1) \<and>
- (setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} = y)}" (is "?xyz = ?hull")
- apply(rule hull_unique) unfolding mem_def[of _ convex] apply(rule) defer
- apply(subst convex_def) apply(rule,rule,rule,rule,rule,rule,rule)
-proof-
- fix x assume "x\<in>s"
- thus "x \<in> ?hull" unfolding mem_Collect_eq apply(rule_tac x=1 in exI, rule_tac x="\<lambda>x. 1" in exI) by auto
-next
- fix t assume as:"s \<subseteq> t" "convex t"
- show "?hull \<subseteq> t" apply(rule) unfolding mem_Collect_eq apply(erule exE | erule conjE)+ proof-
- fix x k u y assume assm:"\<forall>i\<in>{1::nat..k}. 0 \<le> u i \<and> y i \<in> s" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R y i) = x"
- show "x\<in>t" unfolding assm(3)[THEN sym] apply(rule as(2)[unfolded convex, rule_format])
- using assm(1,2) as(1) by auto qed
-next
- fix x y u v assume uv:"0\<le>u" "0\<le>v" "u+v=(1::real)" and xy:"x\<in>?hull" "y\<in>?hull"
- from xy obtain k1 u1 x1 where x:"\<forall>i\<in>{1::nat..k1}. 0\<le>u1 i \<and> x1 i \<in> s" "setsum u1 {Suc 0..k1} = 1" "(\<Sum>i = Suc 0..k1. u1 i *\<^sub>R x1 i) = x" by auto
- from xy obtain k2 u2 x2 where y:"\<forall>i\<in>{1::nat..k2}. 0\<le>u2 i \<and> x2 i \<in> s" "setsum u2 {Suc 0..k2} = 1" "(\<Sum>i = Suc 0..k2. u2 i *\<^sub>R x2 i) = y" by auto
- have *:"\<And>P (x1::'a) x2 s1 s2 i.(if P i then s1 else s2) *\<^sub>R (if P i then x1 else x2) = (if P i then s1 *\<^sub>R x1 else s2 *\<^sub>R x2)"
- "{1..k1 + k2} \<inter> {1..k1} = {1..k1}" "{1..k1 + k2} \<inter> - {1..k1} = (\<lambda>i. i + k1) ` {1..k2}"
- prefer 3 apply(rule,rule) unfolding image_iff apply(rule_tac x="x - k1" in bexI) by(auto simp add: not_le)
- have inj:"inj_on (\<lambda>i. i + k1) {1..k2}" unfolding inj_on_def by auto
- show "u *\<^sub>R x + v *\<^sub>R y \<in> ?hull" apply(rule)
- apply(rule_tac x="k1 + k2" in exI, rule_tac x="\<lambda>i. if i \<in> {1..k1} then u * u1 i else v * u2 (i - k1)" in exI)
- apply(rule_tac x="\<lambda>i. if i \<in> {1..k1} then x1 i else x2 (i - k1)" in exI) apply(rule,rule) defer apply(rule)
- unfolding * and setsum_cases[OF finite_atLeastAtMost[of 1 "k1 + k2"]] and setsum_reindex[OF inj] and o_def
- unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] setsum_right_distrib[THEN sym] proof-
- fix i assume i:"i \<in> {1..k1+k2}"
- show "0 \<le> (if i \<in> {1..k1} then u * u1 i else v * u2 (i - k1)) \<and> (if i \<in> {1..k1} then x1 i else x2 (i - k1)) \<in> s"
- proof(cases "i\<in>{1..k1}")
- case True thus ?thesis using mult_nonneg_nonneg[of u "u1 i"] and uv(1) x(1)[THEN bspec[where x=i]] by auto
- next def j \<equiv> "i - k1"
- case False with i have "j \<in> {1..k2}" unfolding j_def by auto
- thus ?thesis unfolding j_def[symmetric] using False
- using mult_nonneg_nonneg[of v "u2 j"] and uv(2) y(1)[THEN bspec[where x=j]] by auto qed
- qed(auto simp add: not_le x(2,3) y(2,3) uv(3))
-qed
-
-lemma convex_hull_finite:
- fixes s :: "'a::real_vector set"
- assumes "finite s"
- shows "convex hull s = {y. \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and>
- setsum u s = 1 \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y}" (is "?HULL = ?set")
-proof(rule hull_unique, auto simp add: mem_def[of _ convex] convex_def[of ?set])
- fix x assume "x\<in>s" thus " \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>x\<in>s. u x *\<^sub>R x) = x"
- apply(rule_tac x="\<lambda>y. if x=y then 1 else 0" in exI) apply auto
- unfolding setsum_delta'[OF assms] and setsum_delta''[OF assms] by auto
-next
- fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
- fix ux assume ux:"\<forall>x\<in>s. 0 \<le> ux x" "setsum ux s = (1::real)"
- fix uy assume uy:"\<forall>x\<in>s. 0 \<le> uy x" "setsum uy s = (1::real)"
- { fix x assume "x\<in>s"
- hence "0 \<le> u * ux x + v * uy x" using ux(1)[THEN bspec[where x=x]] uy(1)[THEN bspec[where x=x]] and uv(1,2)
- by (auto, metis add_nonneg_nonneg mult_nonneg_nonneg uv(1) uv(2)) }
- moreover have "(\<Sum>x\<in>s. u * ux x + v * uy x) = 1"
- unfolding setsum_addf and setsum_right_distrib[THEN sym] and ux(2) uy(2) using uv(3) by auto
- moreover have "(\<Sum>x\<in>s. (u * ux x + v * uy x) *\<^sub>R x) = u *\<^sub>R (\<Sum>x\<in>s. ux x *\<^sub>R x) + v *\<^sub>R (\<Sum>x\<in>s. uy x *\<^sub>R x)"
- unfolding scaleR_left_distrib and setsum_addf and scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric] by auto
- ultimately show "\<exists>uc. (\<forall>x\<in>s. 0 \<le> uc x) \<and> setsum uc s = 1 \<and> (\<Sum>x\<in>s. uc x *\<^sub>R x) = u *\<^sub>R (\<Sum>x\<in>s. ux x *\<^sub>R x) + v *\<^sub>R (\<Sum>x\<in>s. uy x *\<^sub>R x)"
- apply(rule_tac x="\<lambda>x. u * ux x + v * uy x" in exI) by auto
-next
- fix t assume t:"s \<subseteq> t" "convex t"
- fix u assume u:"\<forall>x\<in>s. 0 \<le> u x" "setsum u s = (1::real)"
- thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> t" using t(2)[unfolded convex_explicit, THEN spec[where x=s], THEN spec[where x=u]]
- using assms and t(1) by auto
-qed
-
-subsection {* Another formulation from Lars Schewe. *}
-
-lemma setsum_constant_scaleR:
- fixes y :: "'a::real_vector"
- shows "(\<Sum>x\<in>A. y) = of_nat (card A) *\<^sub>R y"
-apply (cases "finite A")
-apply (induct set: finite)
-apply (simp_all add: algebra_simps)
-done
-
-lemma convex_hull_explicit:
- fixes p :: "'a::real_vector set"
- shows "convex hull p = {y. \<exists>s u. finite s \<and> s \<subseteq> p \<and>
- (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}" (is "?lhs = ?rhs")
-proof-
- { fix x assume "x\<in>?lhs"
- then obtain k u y where obt:"\<forall>i\<in>{1::nat..k}. 0 \<le> u i \<and> y i \<in> p" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R y i) = x"
- unfolding convex_hull_indexed by auto
-
- have fin:"finite {1..k}" by auto
- have fin':"\<And>v. finite {i \<in> {1..k}. y i = v}" by auto
- { fix j assume "j\<in>{1..k}"
- hence "y j \<in> p" "0 \<le> setsum u {i. Suc 0 \<le> i \<and> i \<le> k \<and> y i = y j}"
- using obt(1)[THEN bspec[where x=j]] and obt(2) apply simp
- apply(rule setsum_nonneg) using obt(1) by auto }
- moreover
- have "(\<Sum>v\<in>y ` {1..k}. setsum u {i \<in> {1..k}. y i = v}) = 1"
- unfolding setsum_image_gen[OF fin, THEN sym] using obt(2) by auto
- moreover have "(\<Sum>v\<in>y ` {1..k}. setsum u {i \<in> {1..k}. y i = v} *\<^sub>R v) = x"
- using setsum_image_gen[OF fin, of "\<lambda>i. u i *\<^sub>R y i" y, THEN sym]
- unfolding scaleR_left.setsum using obt(3) by auto
- ultimately have "\<exists>s u. finite s \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
- apply(rule_tac x="y ` {1..k}" in exI)
- apply(rule_tac x="\<lambda>v. setsum u {i\<in>{1..k}. y i = v}" in exI) by auto
- hence "x\<in>?rhs" by auto }
- moreover
- { fix y assume "y\<in>?rhs"
- then obtain s u where obt:"finite s" "s \<subseteq> p" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = y" by auto
-
- obtain f where f:"inj_on f {1..card s}" "f ` {1..card s} = s" using ex_bij_betw_nat_finite_1[OF obt(1)] unfolding bij_betw_def by auto
-
- { fix i::nat assume "i\<in>{1..card s}"
- hence "f i \<in> s" apply(subst f(2)[THEN sym]) by auto
- hence "0 \<le> u (f i)" "f i \<in> p" using obt(2,3) by auto }
- moreover have *:"finite {1..card s}" by auto
- { fix y assume "y\<in>s"
- then obtain i where "i\<in>{1..card s}" "f i = y" using f using image_iff[of y f "{1..card s}"] by auto
- hence "{x. Suc 0 \<le> x \<and> x \<le> card s \<and> f x = y} = {i}" apply auto using f(1)[unfolded inj_on_def] apply(erule_tac x=x in ballE) by auto
- hence "card {x. Suc 0 \<le> x \<and> x \<le> card s \<and> f x = y} = 1" by auto
- hence "(\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x)) = u y"
- "(\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x) *\<^sub>R f x) = u y *\<^sub>R y"
- by (auto simp add: setsum_constant_scaleR) }
-
- hence "(\<Sum>x = 1..card s. u (f x)) = 1" "(\<Sum>i = 1..card s. u (f i) *\<^sub>R f i) = y"
- unfolding setsum_image_gen[OF *(1), of "\<lambda>x. u (f x) *\<^sub>R f x" f] and setsum_image_gen[OF *(1), of "\<lambda>x. u (f x)" f]
- unfolding f using setsum_cong2[of s "\<lambda>y. (\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x) *\<^sub>R f x)" "\<lambda>v. u v *\<^sub>R v"]
- using setsum_cong2 [of s "\<lambda>y. (\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x))" u] unfolding obt(4,5) by auto
-
- ultimately have "\<exists>k u x. (\<forall>i\<in>{1..k}. 0 \<le> u i \<and> x i \<in> p) \<and> setsum u {1..k} = 1 \<and> (\<Sum>i::nat = 1..k. u i *\<^sub>R x i) = y"
- apply(rule_tac x="card s" in exI) apply(rule_tac x="u \<circ> f" in exI) apply(rule_tac x=f in exI) by fastsimp
- hence "y \<in> ?lhs" unfolding convex_hull_indexed by auto }
- ultimately show ?thesis unfolding expand_set_eq by blast
-qed
-
-subsection {* A stepping theorem for that expansion. *}
-
-lemma convex_hull_finite_step:
- fixes s :: "'a::real_vector set" assumes "finite s"
- shows "(\<exists>u. (\<forall>x\<in>insert a s. 0 \<le> u x) \<and> setsum u (insert a s) = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) (insert a s) = y)
- \<longleftrightarrow> (\<exists>v\<ge>0. \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = w - v \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y - v *\<^sub>R a)" (is "?lhs = ?rhs")
-proof(rule, case_tac[!] "a\<in>s")
- assume "a\<in>s" hence *:"insert a s = s" by auto
- assume ?lhs thus ?rhs unfolding * apply(rule_tac x=0 in exI) by auto
-next
- assume ?lhs then obtain u where u:"\<forall>x\<in>insert a s. 0 \<le> u x" "setsum u (insert a s) = w" "(\<Sum>x\<in>insert a s. u x *\<^sub>R x) = y" by auto
- assume "a\<notin>s" thus ?rhs apply(rule_tac x="u a" in exI) using u(1)[THEN bspec[where x=a]] apply simp
- apply(rule_tac x=u in exI) using u[unfolded setsum_clauses(2)[OF assms]] and `a\<notin>s` by auto
-next
- assume "a\<in>s" hence *:"insert a s = s" by auto
- have fin:"finite (insert a s)" using assms by auto
- assume ?rhs then obtain v u where uv:"v\<ge>0" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
- show ?lhs apply(rule_tac x="\<lambda>x. (if a = x then v else 0) + u x" in exI) unfolding scaleR_left_distrib and setsum_addf and setsum_delta''[OF fin] and setsum_delta'[OF fin]
- unfolding setsum_clauses(2)[OF assms] using uv and uv(2)[THEN bspec[where x=a]] and `a\<in>s` by auto
-next
- assume ?rhs then obtain v u where uv:"v\<ge>0" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
- moreover assume "a\<notin>s" moreover have "(\<Sum>x\<in>s. if a = x then v else u x) = setsum u s" "(\<Sum>x\<in>s. (if a = x then v else u x) *\<^sub>R x) = (\<Sum>x\<in>s. u x *\<^sub>R x)"
- apply(rule_tac setsum_cong2) defer apply(rule_tac setsum_cong2) using `a\<notin>s` by auto
- ultimately show ?lhs apply(rule_tac x="\<lambda>x. if a = x then v else u x" in exI) unfolding setsum_clauses(2)[OF assms] by auto
-qed
-
-subsection {* Hence some special cases. *}
-
-lemma convex_hull_2:
- "convex hull {a,b} = {u *\<^sub>R a + v *\<^sub>R b | u v. 0 \<le> u \<and> 0 \<le> v \<and> u + v = 1}"
-proof- have *:"\<And>u. (\<forall>x\<in>{a, b}. 0 \<le> u x) \<longleftrightarrow> 0 \<le> u a \<and> 0 \<le> u b" by auto have **:"finite {b}" by auto
-show ?thesis apply(simp add: convex_hull_finite) unfolding convex_hull_finite_step[OF **, of a 1, unfolded * conj_assoc]
- apply auto apply(rule_tac x=v in exI) apply(rule_tac x="1 - v" in exI) apply simp
- apply(rule_tac x=u in exI) apply simp apply(rule_tac x="\<lambda>x. v" in exI) by simp qed
-
-lemma convex_hull_2_alt: "convex hull {a,b} = {a + u *\<^sub>R (b - a) | u. 0 \<le> u \<and> u \<le> 1}"
- unfolding convex_hull_2 unfolding Collect_def
-proof(rule ext) have *:"\<And>x y ::real. x + y = 1 \<longleftrightarrow> x = 1 - y" by auto
- fix x show "(\<exists>v u. x = v *\<^sub>R a + u *\<^sub>R b \<and> 0 \<le> v \<and> 0 \<le> u \<and> v + u = 1) = (\<exists>u. x = a + u *\<^sub>R (b - a) \<and> 0 \<le> u \<and> u \<le> 1)"
- unfolding * apply auto apply(rule_tac[!] x=u in exI) by (auto simp add: algebra_simps) qed
-
-lemma convex_hull_3:
- "convex hull {a,b,c} = { u *\<^sub>R a + v *\<^sub>R b + w *\<^sub>R c | u v w. 0 \<le> u \<and> 0 \<le> v \<and> 0 \<le> w \<and> u + v + w = 1}"
-proof-
- have fin:"finite {a,b,c}" "finite {b,c}" "finite {c}" by auto
- have *:"\<And>x y z ::real. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z"
- "\<And>x y z ::real^'n. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z" by (auto simp add: ring_simps)
- show ?thesis unfolding convex_hull_finite[OF fin(1)] and Collect_def and convex_hull_finite_step[OF fin(2)] and *
- unfolding convex_hull_finite_step[OF fin(3)] apply(rule ext) apply simp apply auto
- apply(rule_tac x=va in exI) apply (rule_tac x="u c" in exI) apply simp
- apply(rule_tac x="1 - v - w" in exI) apply simp apply(rule_tac x=v in exI) apply simp apply(rule_tac x="\<lambda>x. w" in exI) by simp qed
-
-lemma convex_hull_3_alt:
- "convex hull {a,b,c} = {a + u *\<^sub>R (b - a) + v *\<^sub>R (c - a) | u v. 0 \<le> u \<and> 0 \<le> v \<and> u + v \<le> 1}"
-proof- have *:"\<And>x y z ::real. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z" by auto
- show ?thesis unfolding convex_hull_3 apply (auto simp add: *) apply(rule_tac x=v in exI) apply(rule_tac x=w in exI) apply (simp add: algebra_simps)
- apply(rule_tac x=u in exI) apply(rule_tac x=v in exI) by (simp add: algebra_simps) qed
-
-subsection {* Relations among closure notions and corresponding hulls. *}
-
-text {* TODO: Generalize linear algebra concepts defined in @{text
-Euclidean_Space.thy} so that we can generalize these lemmas. *}
-
-lemma subspace_imp_affine:
- fixes s :: "(real ^ _) set" shows "subspace s \<Longrightarrow> affine s"
- unfolding subspace_def affine_def smult_conv_scaleR by auto
-
-lemma affine_imp_convex: "affine s \<Longrightarrow> convex s"
- unfolding affine_def convex_def by auto
-
-lemma subspace_imp_convex:
- fixes s :: "(real ^ _) set" shows "subspace s \<Longrightarrow> convex s"
- using subspace_imp_affine affine_imp_convex by auto
-
-lemma affine_hull_subset_span:
- fixes s :: "(real ^ _) set" shows "(affine hull s) \<subseteq> (span s)"
- unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
- using subspace_imp_affine by auto
-
-lemma convex_hull_subset_span:
- fixes s :: "(real ^ _) set" shows "(convex hull s) \<subseteq> (span s)"
- unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
- using subspace_imp_convex by auto
-
-lemma convex_hull_subset_affine_hull: "(convex hull s) \<subseteq> (affine hull s)"
- unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
- using affine_imp_convex by auto
-
-lemma affine_dependent_imp_dependent:
- fixes s :: "(real ^ _) set" shows "affine_dependent s \<Longrightarrow> dependent s"
- unfolding affine_dependent_def dependent_def
- using affine_hull_subset_span by auto
-
-lemma dependent_imp_affine_dependent:
- fixes s :: "(real ^ _) set"
- assumes "dependent {x - a| x . x \<in> s}" "a \<notin> s"
- shows "affine_dependent (insert a s)"
-proof-
- from assms(1)[unfolded dependent_explicit smult_conv_scaleR] obtain S u v
- where obt:"finite S" "S \<subseteq> {x - a |x. x \<in> s}" "v\<in>S" "u v \<noteq> 0" "(\<Sum>v\<in>S. u v *\<^sub>R v) = 0" by auto
- def t \<equiv> "(\<lambda>x. x + a) ` S"
-
- have inj:"inj_on (\<lambda>x. x + a) S" unfolding inj_on_def by auto
- have "0\<notin>S" using obt(2) assms(2) unfolding subset_eq by auto
- have fin:"finite t" and "t\<subseteq>s" unfolding t_def using obt(1,2) by auto
-
- hence "finite (insert a t)" and "insert a t \<subseteq> insert a s" by auto
- moreover have *:"\<And>P Q. (\<Sum>x\<in>t. (if x = a then P x else Q x)) = (\<Sum>x\<in>t. Q x)"
- apply(rule setsum_cong2) using `a\<notin>s` `t\<subseteq>s` by auto
- have "(\<Sum>x\<in>insert a t. if x = a then - (\<Sum>x\<in>t. u (x - a)) else u (x - a)) = 0"
- unfolding setsum_clauses(2)[OF fin] using `a\<notin>s` `t\<subseteq>s` apply auto unfolding * by auto
- moreover have "\<exists>v\<in>insert a t. (if v = a then - (\<Sum>x\<in>t. u (x - a)) else u (v - a)) \<noteq> 0"
- apply(rule_tac x="v + a" in bexI) using obt(3,4) and `0\<notin>S` unfolding t_def by auto
- moreover have *:"\<And>P Q. (\<Sum>x\<in>t. (if x = a then P x else Q x) *\<^sub>R x) = (\<Sum>x\<in>t. Q x *\<^sub>R x)"
- apply(rule setsum_cong2) using `a\<notin>s` `t\<subseteq>s` by auto
- have "(\<Sum>x\<in>t. u (x - a)) *\<^sub>R a = (\<Sum>v\<in>t. u (v - a) *\<^sub>R v)"
- unfolding scaleR_left.setsum unfolding t_def and setsum_reindex[OF inj] and o_def
- using obt(5) by (auto simp add: setsum_addf scaleR_right_distrib)
- hence "(\<Sum>v\<in>insert a t. (if v = a then - (\<Sum>x\<in>t. u (x - a)) else u (v - a)) *\<^sub>R v) = 0"
- unfolding setsum_clauses(2)[OF fin] using `a\<notin>s` `t\<subseteq>s` by (auto simp add: * vector_smult_lneg)
- ultimately show ?thesis unfolding affine_dependent_explicit
- apply(rule_tac x="insert a t" in exI) by auto
-qed
-
-lemma convex_cone:
- "convex s \<and> cone s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. (x + y) \<in> s) \<and> (\<forall>x\<in>s. \<forall>c\<ge>0. (c *\<^sub>R x) \<in> s)" (is "?lhs = ?rhs")
-proof-
- { fix x y assume "x\<in>s" "y\<in>s" and ?lhs
- hence "2 *\<^sub>R x \<in>s" "2 *\<^sub>R y \<in> s" unfolding cone_def by auto
- hence "x + y \<in> s" using `?lhs`[unfolded convex_def, THEN conjunct1]
- apply(erule_tac x="2*\<^sub>R x" in ballE) apply(erule_tac x="2*\<^sub>R y" in ballE)
- apply(erule_tac x="1/2" in allE) apply simp apply(erule_tac x="1/2" in allE) by auto }
- thus ?thesis unfolding convex_def cone_def by auto
-qed
-
-lemma affine_dependent_biggerset: fixes s::"(real^'n::finite) set"
- assumes "finite s" "card s \<ge> CARD('n) + 2"
- shows "affine_dependent s"
-proof-
- have "s\<noteq>{}" using assms by auto then obtain a where "a\<in>s" by auto
- have *:"{x - a |x. x \<in> s - {a}} = (\<lambda>x. x - a) ` (s - {a})" by auto
- have "card {x - a |x. x \<in> s - {a}} = card (s - {a})" unfolding *
- apply(rule card_image) unfolding inj_on_def by auto
- also have "\<dots> > CARD('n)" using assms(2)
- unfolding card_Diff_singleton[OF assms(1) `a\<in>s`] by auto
- finally show ?thesis apply(subst insert_Diff[OF `a\<in>s`, THEN sym])
- apply(rule dependent_imp_affine_dependent)
- apply(rule dependent_biggerset) by auto qed
-
-lemma affine_dependent_biggerset_general:
- assumes "finite (s::(real^'n::finite) set)" "card s \<ge> dim s + 2"
- shows "affine_dependent s"
-proof-
- from assms(2) have "s \<noteq> {}" by auto
- then obtain a where "a\<in>s" by auto
- have *:"{x - a |x. x \<in> s - {a}} = (\<lambda>x. x - a) ` (s - {a})" by auto
- have **:"card {x - a |x. x \<in> s - {a}} = card (s - {a})" unfolding *
- apply(rule card_image) unfolding inj_on_def by auto
- have "dim {x - a |x. x \<in> s - {a}} \<le> dim s"
- apply(rule subset_le_dim) unfolding subset_eq
- using `a\<in>s` by (auto simp add:span_superset span_sub)
- also have "\<dots> < dim s + 1" by auto
- also have "\<dots> \<le> card (s - {a})" using assms
- using card_Diff_singleton[OF assms(1) `a\<in>s`] by auto
- finally show ?thesis apply(subst insert_Diff[OF `a\<in>s`, THEN sym])
- apply(rule dependent_imp_affine_dependent) apply(rule dependent_biggerset_general) unfolding ** by auto qed
-
-subsection {* Caratheodory's theorem. *}
-
-lemma convex_hull_caratheodory: fixes p::"(real^'n::finite) set"
- shows "convex hull p = {y. \<exists>s u. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and>
- (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}"
- unfolding convex_hull_explicit expand_set_eq mem_Collect_eq
-proof(rule,rule)
- fix y let ?P = "\<lambda>n. \<exists>s u. finite s \<and> card s = n \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
- assume "\<exists>s u. finite s \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
- then obtain N where "?P N" by auto
- hence "\<exists>n\<le>N. (\<forall>k<n. \<not> ?P k) \<and> ?P n" apply(rule_tac ex_least_nat_le) by auto
- then obtain n where "?P n" and smallest:"\<forall>k<n. \<not> ?P k" by blast
- then obtain s u where obt:"finite s" "card s = n" "s\<subseteq>p" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = y" by auto
-
- have "card s \<le> CARD('n) + 1" proof(rule ccontr, simp only: not_le)
- assume "CARD('n) + 1 < card s"
- hence "affine_dependent s" using affine_dependent_biggerset[OF obt(1)] by auto
- then obtain w v where wv:"setsum w s = 0" "v\<in>s" "w v \<noteq> 0" "(\<Sum>v\<in>s. w v *\<^sub>R v) = 0"
- using affine_dependent_explicit_finite[OF obt(1)] by auto
- def i \<equiv> "(\<lambda>v. (u v) / (- w v)) ` {v\<in>s. w v < 0}" def t \<equiv> "Min i"
- have "\<exists>x\<in>s. w x < 0" proof(rule ccontr, simp add: not_less)
- assume as:"\<forall>x\<in>s. 0 \<le> w x"
- hence "setsum w (s - {v}) \<ge> 0" apply(rule_tac setsum_nonneg) by auto
- hence "setsum w s > 0" unfolding setsum_diff1'[OF obt(1) `v\<in>s`]
- using as[THEN bspec[where x=v]] and `v\<in>s` using `w v \<noteq> 0` by auto
- thus False using wv(1) by auto
- qed hence "i\<noteq>{}" unfolding i_def by auto
-
- hence "t \<ge> 0" using Min_ge_iff[of i 0 ] and obt(1) unfolding t_def i_def
- using obt(4)[unfolded le_less] apply auto unfolding divide_le_0_iff by auto
- have t:"\<forall>v\<in>s. u v + t * w v \<ge> 0" proof
- fix v assume "v\<in>s" hence v:"0\<le>u v" using obt(4)[THEN bspec[where x=v]] by auto
- show"0 \<le> u v + t * w v" proof(cases "w v < 0")
- case False thus ?thesis apply(rule_tac add_nonneg_nonneg)
- using v apply simp apply(rule mult_nonneg_nonneg) using `t\<ge>0` by auto next
- case True hence "t \<le> u v / (- w v)" using `v\<in>s`
- unfolding t_def i_def apply(rule_tac Min_le) using obt(1) by auto
- thus ?thesis unfolding real_0_le_add_iff
- using pos_le_divide_eq[OF True[unfolded neg_0_less_iff_less[THEN sym]]] by auto
- qed qed
-
- obtain a where "a\<in>s" and "t = (\<lambda>v. (u v) / (- w v)) a" and "w a < 0"
- using Min_in[OF _ `i\<noteq>{}`] and obt(1) unfolding i_def t_def by auto
- hence a:"a\<in>s" "u a + t * w a = 0" by auto
- have *:"\<And>f. setsum f (s - {a}) = setsum f s - ((f a)::'a::ring)" unfolding setsum_diff1'[OF obt(1) `a\<in>s`] by auto
- have "(\<Sum>v\<in>s. u v + t * w v) = 1"
- unfolding setsum_addf wv(1) setsum_right_distrib[THEN sym] obt(5) by auto
- moreover have "(\<Sum>v\<in>s. u v *\<^sub>R v + (t * w v) *\<^sub>R v) - (u a *\<^sub>R a + (t * w a) *\<^sub>R a) = y"
- unfolding setsum_addf obt(6) scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] wv(4)
- using a(2) [THEN eq_neg_iff_add_eq_0 [THEN iffD2]]
- by (simp add: vector_smult_lneg)
- ultimately have "?P (n - 1)" apply(rule_tac x="(s - {a})" in exI)
- apply(rule_tac x="\<lambda>v. u v + t * w v" in exI) using obt(1-3) and t and a by (auto simp add: * scaleR_left_distrib)
- thus False using smallest[THEN spec[where x="n - 1"]] by auto qed
- thus "\<exists>s u. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1
- \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y" using obt by auto
-qed auto
-
-lemma caratheodory:
- "convex hull p = {x::real^'n::finite. \<exists>s. finite s \<and> s \<subseteq> p \<and>
- card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s}"
- unfolding expand_set_eq apply(rule, rule) unfolding mem_Collect_eq proof-
- fix x assume "x \<in> convex hull p"
- then obtain s u where "finite s" "s \<subseteq> p" "card s \<le> CARD('n) + 1"
- "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"unfolding convex_hull_caratheodory by auto
- thus "\<exists>s. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s"
- apply(rule_tac x=s in exI) using hull_subset[of s convex]
- using convex_convex_hull[unfolded convex_explicit, of s, THEN spec[where x=s], THEN spec[where x=u]] by auto
-next
- fix x assume "\<exists>s. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s"
- then obtain s where "finite s" "s \<subseteq> p" "card s \<le> CARD('n) + 1" "x \<in> convex hull s" by auto
- thus "x \<in> convex hull p" using hull_mono[OF `s\<subseteq>p`] by auto
-qed
-
-subsection {* Openness and compactness are preserved by convex hull operation. *}
-
-lemma open_convex_hull:
- fixes s :: "'a::real_normed_vector set"
- assumes "open s"
- shows "open(convex hull s)"
- unfolding open_contains_cball convex_hull_explicit unfolding mem_Collect_eq ball_simps(10)
-proof(rule, rule) fix a
- assume "\<exists>sa u. finite sa \<and> sa \<subseteq> s \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = a"
- then obtain t u where obt:"finite t" "t\<subseteq>s" "\<forall>x\<in>t. 0 \<le> u x" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = a" by auto
-
- from assms[unfolded open_contains_cball] obtain b where b:"\<forall>x\<in>s. 0 < b x \<and> cball x (b x) \<subseteq> s"
- using bchoice[of s "\<lambda>x e. e>0 \<and> cball x e \<subseteq> s"] by auto
- have "b ` t\<noteq>{}" unfolding i_def using obt by auto def i \<equiv> "b ` t"
-
- show "\<exists>e>0. cball a e \<subseteq> {y. \<exists>sa u. finite sa \<and> sa \<subseteq> s \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y}"
- apply(rule_tac x="Min i" in exI) unfolding subset_eq apply rule defer apply rule unfolding mem_Collect_eq
- proof-
- show "0 < Min i" unfolding i_def and Min_gr_iff[OF finite_imageI[OF obt(1)] `b \` t\<noteq>{}`]
- using b apply simp apply rule apply(erule_tac x=x in ballE) using `t\<subseteq>s` by auto
- next fix y assume "y \<in> cball a (Min i)"
- hence y:"norm (a - y) \<le> Min i" unfolding dist_norm[THEN sym] by auto
- { fix x assume "x\<in>t"
- hence "Min i \<le> b x" unfolding i_def apply(rule_tac Min_le) using obt(1) by auto
- hence "x + (y - a) \<in> cball x (b x)" using y unfolding mem_cball dist_norm by auto
- moreover from `x\<in>t` have "x\<in>s" using obt(2) by auto
- ultimately have "x + (y - a) \<in> s" using y and b[THEN bspec[where x=x]] unfolding subset_eq by auto }
- moreover
- have *:"inj_on (\<lambda>v. v + (y - a)) t" unfolding inj_on_def by auto
- have "(\<Sum>v\<in>(\<lambda>v. v + (y - a)) ` t. u (v - (y - a))) = 1"
- unfolding setsum_reindex[OF *] o_def using obt(4) by auto
- moreover have "(\<Sum>v\<in>(\<lambda>v. v + (y - a)) ` t. u (v - (y - a)) *\<^sub>R v) = y"
- unfolding setsum_reindex[OF *] o_def using obt(4,5)
- by (simp add: setsum_addf setsum_subtractf scaleR_left.setsum[THEN sym] scaleR_right_distrib)
- ultimately show "\<exists>sa u. finite sa \<and> (\<forall>x\<in>sa. x \<in> s) \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y"
- apply(rule_tac x="(\<lambda>v. v + (y - a)) ` t" in exI) apply(rule_tac x="\<lambda>v. u (v - (y - a))" in exI)
- using obt(1, 3) by auto
- qed
-qed
-
-lemma open_dest_vec1_vimage: "open S \<Longrightarrow> open (dest_vec1 -` S)"
-unfolding open_vector_def all_1
-by (auto simp add: dest_vec1_def)
-
-lemma tendsto_dest_vec1 [tendsto_intros]:
- "(f ---> l) net \<Longrightarrow> ((\<lambda>x. dest_vec1 (f x)) ---> dest_vec1 l) net"
- unfolding tendsto_def
- apply clarify
- apply (drule_tac x="dest_vec1 -` S" in spec)
- apply (simp add: open_dest_vec1_vimage)
- done
-
-lemma continuous_dest_vec1: "continuous net f \<Longrightarrow> continuous net (\<lambda>x. dest_vec1 (f x))"
- unfolding continuous_def by (rule tendsto_dest_vec1)
-
-(* TODO: move *)
-lemma compact_real_interval:
- fixes a b :: real shows "compact {a..b}"
-proof -
- have "continuous_on {vec1 a .. vec1 b} dest_vec1"
- unfolding continuous_on
- by (simp add: tendsto_dest_vec1 Lim_at_within Lim_ident_at)
- moreover have "compact {vec1 a .. vec1 b}" by (rule compact_interval)
- ultimately have "compact (dest_vec1 ` {vec1 a .. vec1 b})"
- by (rule compact_continuous_image)
- also have "dest_vec1 ` {vec1 a .. vec1 b} = {a..b}"
- by (auto simp add: image_def Bex_def exists_vec1)
- finally show ?thesis .
-qed
-
-lemma compact_convex_combinations:
- fixes s t :: "'a::real_normed_vector set"
- assumes "compact s" "compact t"
- shows "compact { (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u. 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> t}"
-proof-
- let ?X = "{0..1} \<times> s \<times> t"
- let ?h = "(\<lambda>z. (1 - fst z) *\<^sub>R fst (snd z) + fst z *\<^sub>R snd (snd z))"
- have *:"{ (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u. 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> t} = ?h ` ?X"
- apply(rule set_ext) unfolding image_iff mem_Collect_eq
- apply rule apply auto
- apply (rule_tac x=u in rev_bexI, simp)
- apply (erule rev_bexI, erule rev_bexI, simp)
- by auto
- have "continuous_on ({0..1} \<times> s \<times> t)
- (\<lambda>z. (1 - fst z) *\<^sub>R fst (snd z) + fst z *\<^sub>R snd (snd z))"
- unfolding continuous_on by (rule ballI) (intro tendsto_intros)
- thus ?thesis unfolding *
- apply (rule compact_continuous_image)
- apply (intro compact_Times compact_real_interval assms)
- done
-qed
-
-lemma compact_convex_hull: fixes s::"(real^'n::finite) set"
- assumes "compact s" shows "compact(convex hull s)"
-proof(cases "s={}")
- case True thus ?thesis using compact_empty by simp
-next
- case False then obtain w where "w\<in>s" by auto
- show ?thesis unfolding caratheodory[of s]
- proof(induct "CARD('n) + 1")
- have *:"{x.\<exists>sa. finite sa \<and> sa \<subseteq> s \<and> card sa \<le> 0 \<and> x \<in> convex hull sa} = {}"
- using compact_empty by (auto simp add: convex_hull_empty)
- case 0 thus ?case unfolding * by simp
- next
- case (Suc n)
- show ?case proof(cases "n=0")
- case True have "{x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t} = s"
- unfolding expand_set_eq and mem_Collect_eq proof(rule, rule)
- fix x assume "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
- then obtain t where t:"finite t" "t \<subseteq> s" "card t \<le> Suc n" "x \<in> convex hull t" by auto
- show "x\<in>s" proof(cases "card t = 0")
- case True thus ?thesis using t(4) unfolding card_0_eq[OF t(1)] by(simp add: convex_hull_empty)
- next
- case False hence "card t = Suc 0" using t(3) `n=0` by auto
- then obtain a where "t = {a}" unfolding card_Suc_eq by auto
- thus ?thesis using t(2,4) by (simp add: convex_hull_singleton)
- qed
- next
- fix x assume "x\<in>s"
- thus "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
- apply(rule_tac x="{x}" in exI) unfolding convex_hull_singleton by auto
- qed thus ?thesis using assms by simp
- next
- case False have "{x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t} =
- { (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u.
- 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> {x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> x \<in> convex hull t}}"
- unfolding expand_set_eq and mem_Collect_eq proof(rule,rule)
- fix x assume "\<exists>u v c. x = (1 - c) *\<^sub>R u + c *\<^sub>R v \<and>
- 0 \<le> c \<and> c \<le> 1 \<and> u \<in> s \<and> (\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> v \<in> convex hull t)"
- then obtain u v c t where obt:"x = (1 - c) *\<^sub>R u + c *\<^sub>R v"
- "0 \<le> c \<and> c \<le> 1" "u \<in> s" "finite t" "t \<subseteq> s" "card t \<le> n" "v \<in> convex hull t" by auto
- moreover have "(1 - c) *\<^sub>R u + c *\<^sub>R v \<in> convex hull insert u t"
- apply(rule mem_convex) using obt(2) and convex_convex_hull and hull_subset[of "insert u t" convex]
- using obt(7) and hull_mono[of t "insert u t"] by auto
- ultimately show "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
- apply(rule_tac x="insert u t" in exI) by (auto simp add: card_insert_if)
- next
- fix x assume "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
- then obtain t where t:"finite t" "t \<subseteq> s" "card t \<le> Suc n" "x \<in> convex hull t" by auto
- let ?P = "\<exists>u v c. x = (1 - c) *\<^sub>R u + c *\<^sub>R v \<and>
- 0 \<le> c \<and> c \<le> 1 \<and> u \<in> s \<and> (\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> v \<in> convex hull t)"
- show ?P proof(cases "card t = Suc n")
- case False hence "card t \<le> n" using t(3) by auto
- thus ?P apply(rule_tac x=w in exI, rule_tac x=x in exI, rule_tac x=1 in exI) using `w\<in>s` and t
- by(auto intro!: exI[where x=t])
- next
- case True then obtain a u where au:"t = insert a u" "a\<notin>u" apply(drule_tac card_eq_SucD) by auto
- show ?P proof(cases "u={}")
- case True hence "x=a" using t(4)[unfolded au] by auto
- show ?P unfolding `x=a` apply(rule_tac x=a in exI, rule_tac x=a in exI, rule_tac x=1 in exI)
- using t and `n\<noteq>0` unfolding au by(auto intro!: exI[where x="{a}"] simp add: convex_hull_singleton)
- next
- case False obtain ux vx b where obt:"ux\<ge>0" "vx\<ge>0" "ux + vx = 1" "b \<in> convex hull u" "x = ux *\<^sub>R a + vx *\<^sub>R b"
- using t(4)[unfolded au convex_hull_insert[OF False]] by auto
- have *:"1 - vx = ux" using obt(3) by auto
- show ?P apply(rule_tac x=a in exI, rule_tac x=b in exI, rule_tac x=vx in exI)
- using obt and t(1-3) unfolding au and * using card_insert_disjoint[OF _ au(2)]
- by(auto intro!: exI[where x=u])
- qed
- qed
- qed
- thus ?thesis using compact_convex_combinations[OF assms Suc] by simp
- qed
- qed
-qed
-
-lemma finite_imp_compact_convex_hull:
- fixes s :: "(real ^ _) set"
- shows "finite s \<Longrightarrow> compact(convex hull s)"
- apply(drule finite_imp_compact, drule compact_convex_hull) by assumption
-
-subsection {* Extremal points of a simplex are some vertices. *}
-
-lemma dist_increases_online:
- fixes a b d :: "'a::real_inner"
- assumes "d \<noteq> 0"
- shows "dist a (b + d) > dist a b \<or> dist a (b - d) > dist a b"
-proof(cases "inner a d - inner b d > 0")
- case True hence "0 < inner d d + (inner a d * 2 - inner b d * 2)"
- apply(rule_tac add_pos_pos) using assms by auto
- thus ?thesis apply(rule_tac disjI2) unfolding dist_norm and norm_eq_sqrt_inner and real_sqrt_less_iff
- by (simp add: algebra_simps inner_commute)
-next
- case False hence "0 < inner d d + (inner b d * 2 - inner a d * 2)"
- apply(rule_tac add_pos_nonneg) using assms by auto
- thus ?thesis apply(rule_tac disjI1) unfolding dist_norm and norm_eq_sqrt_inner and real_sqrt_less_iff
- by (simp add: algebra_simps inner_commute)
-qed
-
-lemma norm_increases_online:
- fixes d :: "'a::real_inner"
- shows "d \<noteq> 0 \<Longrightarrow> norm(a + d) > norm a \<or> norm(a - d) > norm a"
- using dist_increases_online[of d a 0] unfolding dist_norm by auto
-
-lemma simplex_furthest_lt:
- fixes s::"'a::real_inner set" assumes "finite s"
- shows "\<forall>x \<in> (convex hull s). x \<notin> s \<longrightarrow> (\<exists>y\<in>(convex hull s). norm(x - a) < norm(y - a))"
-proof(induct_tac rule: finite_induct[of s])
- fix x s assume as:"finite s" "x\<notin>s" "\<forall>x\<in>convex hull s. x \<notin> s \<longrightarrow> (\<exists>y\<in>convex hull s. norm (x - a) < norm (y - a))"
- show "\<forall>xa\<in>convex hull insert x s. xa \<notin> insert x s \<longrightarrow> (\<exists>y\<in>convex hull insert x s. norm (xa - a) < norm (y - a))"
- proof(rule,rule,cases "s = {}")
- case False fix y assume y:"y \<in> convex hull insert x s" "y \<notin> insert x s"
- obtain u v b where obt:"u\<ge>0" "v\<ge>0" "u + v = 1" "b \<in> convex hull s" "y = u *\<^sub>R x + v *\<^sub>R b"
- using y(1)[unfolded convex_hull_insert[OF False]] by auto
- show "\<exists>z\<in>convex hull insert x s. norm (y - a) < norm (z - a)"
- proof(cases "y\<in>convex hull s")
- case True then obtain z where "z\<in>convex hull s" "norm (y - a) < norm (z - a)"
- using as(3)[THEN bspec[where x=y]] and y(2) by auto
- thus ?thesis apply(rule_tac x=z in bexI) unfolding convex_hull_insert[OF False] by auto
- next
- case False show ?thesis using obt(3) proof(cases "u=0", case_tac[!] "v=0")
- assume "u=0" "v\<noteq>0" hence "y = b" using obt by auto
- thus ?thesis using False and obt(4) by auto
- next
- assume "u\<noteq>0" "v=0" hence "y = x" using obt by auto
- thus ?thesis using y(2) by auto
- next
- assume "u\<noteq>0" "v\<noteq>0"
- then obtain w where w:"w>0" "w<u" "w<v" using real_lbound_gt_zero[of u v] and obt(1,2) by auto
- have "x\<noteq>b" proof(rule ccontr)
- assume "\<not> x\<noteq>b" hence "y=b" unfolding obt(5)
- using obt(3) by(auto simp add: scaleR_left_distrib[THEN sym])
- thus False using obt(4) and False by simp qed
- hence *:"w *\<^sub>R (x - b) \<noteq> 0" using w(1) by auto
- show ?thesis using dist_increases_online[OF *, of a y]
- proof(erule_tac disjE)
- assume "dist a y < dist a (y + w *\<^sub>R (x - b))"
- hence "norm (y - a) < norm ((u + w) *\<^sub>R x + (v - w) *\<^sub>R b - a)"
- unfolding dist_commute[of a] unfolding dist_norm obt(5) by (simp add: algebra_simps)
- moreover have "(u + w) *\<^sub>R x + (v - w) *\<^sub>R b \<in> convex hull insert x s"
- unfolding convex_hull_insert[OF `s\<noteq>{}`] and mem_Collect_eq
- apply(rule_tac x="u + w" in exI) apply rule defer
- apply(rule_tac x="v - w" in exI) using `u\<ge>0` and w and obt(3,4) by auto
- ultimately show ?thesis by auto
- next
- assume "dist a y < dist a (y - w *\<^sub>R (x - b))"
- hence "norm (y - a) < norm ((u - w) *\<^sub>R x + (v + w) *\<^sub>R b - a)"
- unfolding dist_commute[of a] unfolding dist_norm obt(5) by (simp add: algebra_simps)
- moreover have "(u - w) *\<^sub>R x + (v + w) *\<^sub>R b \<in> convex hull insert x s"
- unfolding convex_hull_insert[OF `s\<noteq>{}`] and mem_Collect_eq
- apply(rule_tac x="u - w" in exI) apply rule defer
- apply(rule_tac x="v + w" in exI) using `u\<ge>0` and w and obt(3,4) by auto
- ultimately show ?thesis by auto
- qed
- qed auto
- qed
- qed auto
-qed (auto simp add: assms)
-
-lemma simplex_furthest_le:
- fixes s :: "(real ^ _) set"
- assumes "finite s" "s \<noteq> {}"
- shows "\<exists>y\<in>s. \<forall>x\<in>(convex hull s). norm(x - a) \<le> norm(y - a)"
-proof-
- have "convex hull s \<noteq> {}" using hull_subset[of s convex] and assms(2) by auto
- then obtain x where x:"x\<in>convex hull s" "\<forall>y\<in>convex hull s. norm (y - a) \<le> norm (x - a)"
- using distance_attains_sup[OF finite_imp_compact_convex_hull[OF assms(1)], of a]
- unfolding dist_commute[of a] unfolding dist_norm by auto
- thus ?thesis proof(cases "x\<in>s")
- case False then obtain y where "y\<in>convex hull s" "norm (x - a) < norm (y - a)"
- using simplex_furthest_lt[OF assms(1), THEN bspec[where x=x]] and x(1) by auto
- thus ?thesis using x(2)[THEN bspec[where x=y]] by auto
- qed auto
-qed
-
-lemma simplex_furthest_le_exists:
- fixes s :: "(real ^ _) set"
- shows "finite s \<Longrightarrow> (\<forall>x\<in>(convex hull s). \<exists>y\<in>s. norm(x - a) \<le> norm(y - a))"
- using simplex_furthest_le[of s] by (cases "s={}")auto
-
-lemma simplex_extremal_le:
- fixes s :: "(real ^ _) set"
- assumes "finite s" "s \<noteq> {}"
- shows "\<exists>u\<in>s. \<exists>v\<in>s. \<forall>x\<in>convex hull s. \<forall>y \<in> convex hull s. norm(x - y) \<le> norm(u - v)"
-proof-
- have "convex hull s \<noteq> {}" using hull_subset[of s convex] and assms(2) by auto
- then obtain u v where obt:"u\<in>convex hull s" "v\<in>convex hull s"
- "\<forall>x\<in>convex hull s. \<forall>y\<in>convex hull s. norm (x - y) \<le> norm (u - v)"
- using compact_sup_maxdistance[OF finite_imp_compact_convex_hull[OF assms(1)]] by auto
- thus ?thesis proof(cases "u\<notin>s \<or> v\<notin>s", erule_tac disjE)
- assume "u\<notin>s" then obtain y where "y\<in>convex hull s" "norm (u - v) < norm (y - v)"
- using simplex_furthest_lt[OF assms(1), THEN bspec[where x=u]] and obt(1) by auto
- thus ?thesis using obt(3)[THEN bspec[where x=y], THEN bspec[where x=v]] and obt(2) by auto
- next
- assume "v\<notin>s" then obtain y where "y\<in>convex hull s" "norm (v - u) < norm (y - u)"
- using simplex_furthest_lt[OF assms(1), THEN bspec[where x=v]] and obt(2) by auto
- thus ?thesis using obt(3)[THEN bspec[where x=u], THEN bspec[where x=y]] and obt(1)
- by (auto simp add: norm_minus_commute)
- qed auto
-qed
-
-lemma simplex_extremal_le_exists:
- fixes s :: "(real ^ _) set"
- shows "finite s \<Longrightarrow> x \<in> convex hull s \<Longrightarrow> y \<in> convex hull s
- \<Longrightarrow> (\<exists>u\<in>s. \<exists>v\<in>s. norm(x - y) \<le> norm(u - v))"
- using convex_hull_empty simplex_extremal_le[of s] by(cases "s={}")auto
-
-subsection {* Closest point of a convex set is unique, with a continuous projection. *}
-
-definition
- closest_point :: "(real ^ 'n::finite) set \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 'n" where
- "closest_point s a = (SOME x. x \<in> s \<and> (\<forall>y\<in>s. dist a x \<le> dist a y))"
-
-lemma closest_point_exists:
- assumes "closed s" "s \<noteq> {}"
- shows "closest_point s a \<in> s" "\<forall>y\<in>s. dist a (closest_point s a) \<le> dist a y"
- unfolding closest_point_def apply(rule_tac[!] someI2_ex)
- using distance_attains_inf[OF assms(1,2), of a] by auto
-
-lemma closest_point_in_set:
- "closed s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> (closest_point s a) \<in> s"
- by(meson closest_point_exists)
-
-lemma closest_point_le:
- "closed s \<Longrightarrow> x \<in> s \<Longrightarrow> dist a (closest_point s a) \<le> dist a x"
- using closest_point_exists[of s] by auto
-
-lemma closest_point_self:
- assumes "x \<in> s" shows "closest_point s x = x"
- unfolding closest_point_def apply(rule some1_equality, rule ex1I[of _ x])
- using assms by auto
-
-lemma closest_point_refl:
- "closed s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> (closest_point s x = x \<longleftrightarrow> x \<in> s)"
- using closest_point_in_set[of s x] closest_point_self[of x s] by auto
-
-(* TODO: move *)
-lemma norm_lt: "norm x < norm y \<longleftrightarrow> inner x x < inner y y"
- unfolding norm_eq_sqrt_inner by simp
-
-(* TODO: move *)
-lemma norm_le: "norm x \<le> norm y \<longleftrightarrow> inner x x \<le> inner y y"
- unfolding norm_eq_sqrt_inner by simp
-
-lemma closer_points_lemma: fixes y::"real^'n::finite"
- assumes "inner y z > 0"
- shows "\<exists>u>0. \<forall>v>0. v \<le> u \<longrightarrow> norm(v *\<^sub>R z - y) < norm y"
-proof- have z:"inner z z > 0" unfolding inner_gt_zero_iff using assms by auto
- thus ?thesis using assms apply(rule_tac x="inner y z / inner z z" in exI) apply(rule) defer proof(rule+)
- fix v assume "0<v" "v \<le> inner y z / inner z z"
- thus "norm (v *\<^sub>R z - y) < norm y" unfolding norm_lt using z and assms
- by (simp add: field_simps inner_diff inner_commute mult_strict_left_mono[OF _ `0<v`])
- qed(rule divide_pos_pos, auto) qed
-
-lemma closer_point_lemma:
- fixes x y z :: "real ^ 'n::finite"
- assumes "inner (y - x) (z - x) > 0"
- shows "\<exists>u>0. u \<le> 1 \<and> dist (x + u *\<^sub>R (z - x)) y < dist x y"
-proof- obtain u where "u>0" and u:"\<forall>v>0. v \<le> u \<longrightarrow> norm (v *\<^sub>R (z - x) - (y - x)) < norm (y - x)"
- using closer_points_lemma[OF assms] by auto
- show ?thesis apply(rule_tac x="min u 1" in exI) using u[THEN spec[where x="min u 1"]] and `u>0`
- unfolding dist_norm by(auto simp add: norm_minus_commute field_simps) qed
-
-lemma any_closest_point_dot:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "closed s" "x \<in> s" "y \<in> s" "\<forall>z\<in>s. dist a x \<le> dist a z"
- shows "inner (a - x) (y - x) \<le> 0"
-proof(rule ccontr) assume "\<not> inner (a - x) (y - x) \<le> 0"
- then obtain u where u:"u>0" "u\<le>1" "dist (x + u *\<^sub>R (y - x)) a < dist x a" using closer_point_lemma[of a x y] by auto
- let ?z = "(1 - u) *\<^sub>R x + u *\<^sub>R y" have "?z \<in> s" using mem_convex[OF assms(1,3,4), of u] using u by auto
- thus False using assms(5)[THEN bspec[where x="?z"]] and u(3) by (auto simp add: dist_commute algebra_simps) qed
-
-(* TODO: move *)
-lemma norm_le_square: "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> inner x x \<le> a\<twosuperior>"
-proof -
- have "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> norm x \<le> a"
- using norm_ge_zero [of x] by arith
- also have "\<dots> \<longleftrightarrow> 0 \<le> a \<and> (norm x)\<twosuperior> \<le> a\<twosuperior>"
- by (auto intro: power_mono dest: power2_le_imp_le)
- also have "\<dots> \<longleftrightarrow> 0 \<le> a \<and> inner x x \<le> a\<twosuperior>"
- unfolding power2_norm_eq_inner ..
- finally show ?thesis .
-qed
-
-lemma any_closest_point_unique:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "closed s" "x \<in> s" "y \<in> s"
- "\<forall>z\<in>s. dist a x \<le> dist a z" "\<forall>z\<in>s. dist a y \<le> dist a z"
- shows "x = y" using any_closest_point_dot[OF assms(1-4,5)] and any_closest_point_dot[OF assms(1-2,4,3,6)]
- unfolding norm_pths(1) and norm_le_square
- by (auto simp add: algebra_simps)
-
-lemma closest_point_unique:
- assumes "convex s" "closed s" "x \<in> s" "\<forall>z\<in>s. dist a x \<le> dist a z"
- shows "x = closest_point s a"
- using any_closest_point_unique[OF assms(1-3) _ assms(4), of "closest_point s a"]
- using closest_point_exists[OF assms(2)] and assms(3) by auto
-
-lemma closest_point_dot:
- assumes "convex s" "closed s" "x \<in> s"
- shows "inner (a - closest_point s a) (x - closest_point s a) \<le> 0"
- apply(rule any_closest_point_dot[OF assms(1,2) _ assms(3)])
- using closest_point_exists[OF assms(2)] and assms(3) by auto
-
-lemma closest_point_lt:
- assumes "convex s" "closed s" "x \<in> s" "x \<noteq> closest_point s a"
- shows "dist a (closest_point s a) < dist a x"
- apply(rule ccontr) apply(rule_tac notE[OF assms(4)])
- apply(rule closest_point_unique[OF assms(1-3), of a])
- using closest_point_le[OF assms(2), of _ a] by fastsimp
-
-lemma closest_point_lipschitz:
- assumes "convex s" "closed s" "s \<noteq> {}"
- shows "dist (closest_point s x) (closest_point s y) \<le> dist x y"
-proof-
- have "inner (x - closest_point s x) (closest_point s y - closest_point s x) \<le> 0"
- "inner (y - closest_point s y) (closest_point s x - closest_point s y) \<le> 0"
- apply(rule_tac[!] any_closest_point_dot[OF assms(1-2)])
- using closest_point_exists[OF assms(2-3)] by auto
- thus ?thesis unfolding dist_norm and norm_le
- using inner_ge_zero[of "(x - closest_point s x) - (y - closest_point s y)"]
- by (simp add: inner_add inner_diff inner_commute) qed
-
-lemma continuous_at_closest_point:
- assumes "convex s" "closed s" "s \<noteq> {}"
- shows "continuous (at x) (closest_point s)"
- unfolding continuous_at_eps_delta
- using le_less_trans[OF closest_point_lipschitz[OF assms]] by auto
-
-lemma continuous_on_closest_point:
- assumes "convex s" "closed s" "s \<noteq> {}"
- shows "continuous_on t (closest_point s)"
- apply(rule continuous_at_imp_continuous_on) using continuous_at_closest_point[OF assms] by auto
-
-subsection {* Various point-to-set separating/supporting hyperplane theorems. *}
-
-lemma supporting_hyperplane_closed_point:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "closed s" "s \<noteq> {}" "z \<notin> s"
- shows "\<exists>a b. \<exists>y\<in>s. inner a z < b \<and> (inner a y = b) \<and> (\<forall>x\<in>s. inner a x \<ge> b)"
-proof-
- from distance_attains_inf[OF assms(2-3)] obtain y where "y\<in>s" and y:"\<forall>x\<in>s. dist z y \<le> dist z x" by auto
- show ?thesis apply(rule_tac x="y - z" in exI, rule_tac x="inner (y - z) y" in exI, rule_tac x=y in bexI)
- apply rule defer apply rule defer apply(rule, rule ccontr) using `y\<in>s` proof-
- show "inner (y - z) z < inner (y - z) y" apply(subst diff_less_iff(1)[THEN sym])
- unfolding inner_diff_right[THEN sym] and inner_gt_zero_iff using `y\<in>s` `z\<notin>s` by auto
- next
- fix x assume "x\<in>s" have *:"\<forall>u. 0 \<le> u \<and> u \<le> 1 \<longrightarrow> dist z y \<le> dist z ((1 - u) *\<^sub>R y + u *\<^sub>R x)"
- using assms(1)[unfolded convex_alt] and y and `x\<in>s` and `y\<in>s` by auto
- assume "\<not> inner (y - z) y \<le> inner (y - z) x" then obtain v where
- "v>0" "v\<le>1" "dist (y + v *\<^sub>R (x - y)) z < dist y z" using closer_point_lemma[of z y x] apply - by (auto simp add: inner_diff)
- thus False using *[THEN spec[where x=v]] by(auto simp add: dist_commute algebra_simps)
- qed auto
-qed
-
-lemma separating_hyperplane_closed_point:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "closed s" "z \<notin> s"
- shows "\<exists>a b. inner a z < b \<and> (\<forall>x\<in>s. inner a x > b)"
-proof(cases "s={}")
- case True thus ?thesis apply(rule_tac x="-z" in exI, rule_tac x=1 in exI)
- using less_le_trans[OF _ inner_ge_zero[of z]] by auto
-next
- case False obtain y where "y\<in>s" and y:"\<forall>x\<in>s. dist z y \<le> dist z x"
- using distance_attains_inf[OF assms(2) False] by auto
- show ?thesis apply(rule_tac x="y - z" in exI, rule_tac x="inner (y - z) z + (norm(y - z))\<twosuperior> / 2" in exI)
- apply rule defer apply rule proof-
- fix x assume "x\<in>s"
- have "\<not> 0 < inner (z - y) (x - y)" apply(rule_tac notI) proof(drule closer_point_lemma)
- assume "\<exists>u>0. u \<le> 1 \<and> dist (y + u *\<^sub>R (x - y)) z < dist y z"
- then obtain u where "u>0" "u\<le>1" "dist (y + u *\<^sub>R (x - y)) z < dist y z" by auto
- thus False using y[THEN bspec[where x="y + u *\<^sub>R (x - y)"]]
- using assms(1)[unfolded convex_alt, THEN bspec[where x=y]]
- using `x\<in>s` `y\<in>s` by (auto simp add: dist_commute algebra_simps) qed
- moreover have "0 < norm (y - z) ^ 2" using `y\<in>s` `z\<notin>s` by auto
- hence "0 < inner (y - z) (y - z)" unfolding power2_norm_eq_inner by simp
- ultimately show "inner (y - z) z + (norm (y - z))\<twosuperior> / 2 < inner (y - z) x"
- unfolding power2_norm_eq_inner and not_less by (auto simp add: field_simps inner_commute inner_diff)
- qed(insert `y\<in>s` `z\<notin>s`, auto)
-qed
-
-lemma separating_hyperplane_closed_0:
- assumes "convex (s::(real^'n::finite) set)" "closed s" "0 \<notin> s"
- shows "\<exists>a b. a \<noteq> 0 \<and> 0 < b \<and> (\<forall>x\<in>s. inner a x > b)"
- proof(cases "s={}") guess a using UNIV_witness[where 'a='n] ..
- case True have "norm ((basis a)::real^'n::finite) = 1"
- using norm_basis and dimindex_ge_1 by auto
- thus ?thesis apply(rule_tac x="basis a" in exI, rule_tac x=1 in exI) using True by auto
-next case False thus ?thesis using False using separating_hyperplane_closed_point[OF assms]
- apply - apply(erule exE)+ unfolding dot_rzero apply(rule_tac x=a in exI, rule_tac x=b in exI) by auto qed
-
-subsection {* Now set-to-set for closed/compact sets. *}
-
-lemma separating_hyperplane_closed_compact:
- assumes "convex (s::(real^'n::finite) set)" "closed s" "convex t" "compact t" "t \<noteq> {}" "s \<inter> t = {}"
- shows "\<exists>a b. (\<forall>x\<in>s. inner a x < b) \<and> (\<forall>x\<in>t. inner a x > b)"
-proof(cases "s={}")
- case True
- obtain b where b:"b>0" "\<forall>x\<in>t. norm x \<le> b" using compact_imp_bounded[OF assms(4)] unfolding bounded_pos by auto
- obtain z::"real^'n" where z:"norm z = b + 1" using vector_choose_size[of "b + 1"] and b(1) by auto
- hence "z\<notin>t" using b(2)[THEN bspec[where x=z]] by auto
- then obtain a b where ab:"inner a z < b" "\<forall>x\<in>t. b < inner a x"
- using separating_hyperplane_closed_point[OF assms(3) compact_imp_closed[OF assms(4)], of z] by auto
- thus ?thesis using True by auto
-next
- case False then obtain y where "y\<in>s" by auto
- obtain a b where "0 < b" "\<forall>x\<in>{x - y |x y. x \<in> s \<and> y \<in> t}. b < inner a x"
- using separating_hyperplane_closed_point[OF convex_differences[OF assms(1,3)], of 0]
- using closed_compact_differences[OF assms(2,4)] using assms(6) by(auto, blast)
- hence ab:"\<forall>x\<in>s. \<forall>y\<in>t. b + inner a y < inner a x" apply- apply(rule,rule) apply(erule_tac x="x - y" in ballE) by (auto simp add: inner_diff)
- def k \<equiv> "Sup ((\<lambda>x. inner a x) ` t)"
- show ?thesis apply(rule_tac x="-a" in exI, rule_tac x="-(k + b / 2)" in exI)
- apply(rule,rule) defer apply(rule) unfolding inner_minus_left and neg_less_iff_less proof-
- from ab have "((\<lambda>x. inner a x) ` t) *<= (inner a y - b)"
- apply(erule_tac x=y in ballE) apply(rule setleI) using `y\<in>s` by auto
- hence k:"isLub UNIV ((\<lambda>x. inner a x) ` t) k" unfolding k_def apply(rule_tac Sup) using assms(5) by auto
- fix x assume "x\<in>t" thus "inner a x < (k + b / 2)" using `0<b` and isLubD2[OF k, of "inner a x"] by auto
- next
- fix x assume "x\<in>s"
- hence "k \<le> inner a x - b" unfolding k_def apply(rule_tac Sup_least) using assms(5)
- using ab[THEN bspec[where x=x]] by auto
- thus "k + b / 2 < inner a x" using `0 < b` by auto
- qed
-qed
-
-lemma separating_hyperplane_compact_closed:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "compact s" "s \<noteq> {}" "convex t" "closed t" "s \<inter> t = {}"
- shows "\<exists>a b. (\<forall>x\<in>s. inner a x < b) \<and> (\<forall>x\<in>t. inner a x > b)"
-proof- obtain a b where "(\<forall>x\<in>t. inner a x < b) \<and> (\<forall>x\<in>s. b < inner a x)"
- using separating_hyperplane_closed_compact[OF assms(4-5,1-2,3)] and assms(6) by auto
- thus ?thesis apply(rule_tac x="-a" in exI, rule_tac x="-b" in exI) by auto qed
-
-subsection {* General case without assuming closure and getting non-strict separation. *}
-
-lemma separating_hyperplane_set_0:
- assumes "convex s" "(0::real^'n::finite) \<notin> s"
- shows "\<exists>a. a \<noteq> 0 \<and> (\<forall>x\<in>s. 0 \<le> inner a x)"
-proof- let ?k = "\<lambda>c. {x::real^'n. 0 \<le> inner c x}"
- have "frontier (cball 0 1) \<inter> (\<Inter> (?k ` s)) \<noteq> {}"
- apply(rule compact_imp_fip) apply(rule compact_frontier[OF compact_cball])
- defer apply(rule,rule,erule conjE) proof-
- fix f assume as:"f \<subseteq> ?k ` s" "finite f"
- obtain c where c:"f = ?k ` c" "c\<subseteq>s" "finite c" using finite_subset_image[OF as(2,1)] by auto
- then obtain a b where ab:"a \<noteq> 0" "0 < b" "\<forall>x\<in>convex hull c. b < inner a x"
- using separating_hyperplane_closed_0[OF convex_convex_hull, of c]
- using finite_imp_compact_convex_hull[OF c(3), THEN compact_imp_closed] and assms(2)
- using subset_hull[unfolded mem_def, of convex, OF assms(1), THEN sym, of c] by auto
- hence "\<exists>x. norm x = 1 \<and> (\<forall>y\<in>c. 0 \<le> inner y x)" apply(rule_tac x="inverse(norm a) *\<^sub>R a" in exI)
- using hull_subset[of c convex] unfolding subset_eq and inner_scaleR
- apply- apply rule defer apply rule apply(rule mult_nonneg_nonneg)
- by(auto simp add: inner_commute elim!: ballE)
- thus "frontier (cball 0 1) \<inter> \<Inter>f \<noteq> {}" unfolding c(1) frontier_cball dist_norm by auto
- qed(insert closed_halfspace_ge, auto)
- then obtain x where "norm x = 1" "\<forall>y\<in>s. x\<in>?k y" unfolding frontier_cball dist_norm by auto
- thus ?thesis apply(rule_tac x=x in exI) by(auto simp add: inner_commute) qed
-
-lemma separating_hyperplane_sets:
- assumes "convex s" "convex (t::(real^'n::finite) set)" "s \<noteq> {}" "t \<noteq> {}" "s \<inter> t = {}"
- shows "\<exists>a b. a \<noteq> 0 \<and> (\<forall>x\<in>s. inner a x \<le> b) \<and> (\<forall>x\<in>t. inner a x \<ge> b)"
-proof- from separating_hyperplane_set_0[OF convex_differences[OF assms(2,1)]]
- obtain a where "a\<noteq>0" "\<forall>x\<in>{x - y |x y. x \<in> t \<and> y \<in> s}. 0 \<le> inner a x"
- using assms(3-5) by auto
- hence "\<forall>x\<in>t. \<forall>y\<in>s. inner a y \<le> inner a x"
- by (force simp add: inner_diff)
- thus ?thesis
- apply(rule_tac x=a in exI, rule_tac x="Sup ((\<lambda>x. inner a x) ` s)" in exI) using `a\<noteq>0`
- apply auto
- apply (rule Sup[THEN isLubD2])
- prefer 4
- apply (rule Sup_least)
- using assms(3-5) apply (auto simp add: setle_def)
- apply (metis COMBC_def Collect_def Collect_mem_eq)
- done
-qed
-
-subsection {* More convexity generalities. *}
-
-lemma convex_closure:
- fixes s :: "'a::real_normed_vector set"
- assumes "convex s" shows "convex(closure s)"
- unfolding convex_def Ball_def closure_sequential
- apply(rule,rule,rule,rule,rule,rule,rule,rule,rule) apply(erule_tac exE)+
- apply(rule_tac x="\<lambda>n. u *\<^sub>R xb n + v *\<^sub>R xc n" in exI) apply(rule,rule)
- apply(rule assms[unfolded convex_def, rule_format]) prefer 6
- apply(rule Lim_add) apply(rule_tac [1-2] Lim_cmul) by auto
-
-lemma convex_interior:
- fixes s :: "'a::real_normed_vector set"
- assumes "convex s" shows "convex(interior s)"
- unfolding convex_alt Ball_def mem_interior apply(rule,rule,rule,rule,rule,rule) apply(erule exE | erule conjE)+ proof-
- fix x y u assume u:"0 \<le> u" "u \<le> (1::real)"
- fix e d assume ed:"ball x e \<subseteq> s" "ball y d \<subseteq> s" "0<d" "0<e"
- show "\<exists>e>0. ball ((1 - u) *\<^sub>R x + u *\<^sub>R y) e \<subseteq> s" apply(rule_tac x="min d e" in exI)
- apply rule unfolding subset_eq defer apply rule proof-
- fix z assume "z \<in> ball ((1 - u) *\<^sub>R x + u *\<^sub>R y) (min d e)"
- hence "(1- u) *\<^sub>R (z - u *\<^sub>R (y - x)) + u *\<^sub>R (z + (1 - u) *\<^sub>R (y - x)) \<in> s"
- apply(rule_tac assms[unfolded convex_alt, rule_format])
- using ed(1,2) and u unfolding subset_eq mem_ball Ball_def dist_norm by(auto simp add: algebra_simps)
- thus "z \<in> s" using u by (auto simp add: algebra_simps) qed(insert u ed(3-4), auto) qed
-
-lemma convex_hull_eq_empty: "convex hull s = {} \<longleftrightarrow> s = {}"
- using hull_subset[of s convex] convex_hull_empty by auto
-
-subsection {* Moving and scaling convex hulls. *}
-
-lemma convex_hull_translation_lemma:
- "convex hull ((\<lambda>x. a + x) ` s) \<subseteq> (\<lambda>x. a + x) ` (convex hull s)"
- apply(rule hull_minimal, rule image_mono, rule hull_subset) unfolding mem_def
- using convex_translation[OF convex_convex_hull, of a s] by assumption
-
-lemma convex_hull_bilemma: fixes neg
- assumes "(\<forall>s a. (convex hull (up a s)) \<subseteq> up a (convex hull s))"
- shows "(\<forall>s. up a (up (neg a) s) = s) \<and> (\<forall>s. up (neg a) (up a s) = s) \<and> (\<forall>s t a. s \<subseteq> t \<longrightarrow> up a s \<subseteq> up a t)
- \<Longrightarrow> \<forall>s. (convex hull (up a s)) = up a (convex hull s)"
- using assms by(metis subset_antisym)
-
-lemma convex_hull_translation:
- "convex hull ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (convex hull s)"
- apply(rule convex_hull_bilemma[rule_format, of _ _ "\<lambda>a. -a"], rule convex_hull_translation_lemma) unfolding image_image by auto
-
-lemma convex_hull_scaling_lemma:
- "(convex hull ((\<lambda>x. c *\<^sub>R x) ` s)) \<subseteq> (\<lambda>x. c *\<^sub>R x) ` (convex hull s)"
- apply(rule hull_minimal, rule image_mono, rule hull_subset)
- unfolding mem_def by(rule convex_scaling, rule convex_convex_hull)
-
-lemma convex_hull_scaling:
- "convex hull ((\<lambda>x. c *\<^sub>R x) ` s) = (\<lambda>x. c *\<^sub>R x) ` (convex hull s)"
- apply(cases "c=0") defer apply(rule convex_hull_bilemma[rule_format, of _ _ inverse]) apply(rule convex_hull_scaling_lemma)
- unfolding image_image scaleR_scaleR by(auto simp add:image_constant_conv convex_hull_eq_empty)
-
-lemma convex_hull_affinity:
- "convex hull ((\<lambda>x. a + c *\<^sub>R x) ` s) = (\<lambda>x. a + c *\<^sub>R x) ` (convex hull s)"
- unfolding image_image[THEN sym] convex_hull_scaling convex_hull_translation ..
-
-subsection {* Convex set as intersection of halfspaces. *}
-
-lemma convex_halfspace_intersection:
- fixes s :: "(real ^ _) set"
- assumes "closed s" "convex s"
- shows "s = \<Inter> {h. s \<subseteq> h \<and> (\<exists>a b. h = {x. inner a x \<le> b})}"
- apply(rule set_ext, rule) unfolding Inter_iff Ball_def mem_Collect_eq apply(rule,rule,erule conjE) proof-
- fix x assume "\<forall>xa. s \<subseteq> xa \<and> (\<exists>a b. xa = {x. inner a x \<le> b}) \<longrightarrow> x \<in> xa"
- hence "\<forall>a b. s \<subseteq> {x. inner a x \<le> b} \<longrightarrow> x \<in> {x. inner a x \<le> b}" by blast
- thus "x\<in>s" apply(rule_tac ccontr) apply(drule separating_hyperplane_closed_point[OF assms(2,1)])
- apply(erule exE)+ apply(erule_tac x="-a" in allE, erule_tac x="-b" in allE) by auto
-qed auto
-
-subsection {* Radon's theorem (from Lars Schewe). *}
-
-lemma radon_ex_lemma:
- assumes "finite c" "affine_dependent c"
- shows "\<exists>u. setsum u c = 0 \<and> (\<exists>v\<in>c. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) c = 0"
-proof- from assms(2)[unfolded affine_dependent_explicit] guess s .. then guess u ..
- thus ?thesis apply(rule_tac x="\<lambda>v. if v\<in>s then u v else 0" in exI) unfolding if_smult scaleR_zero_left
- and setsum_restrict_set[OF assms(1), THEN sym] by(auto simp add: Int_absorb1) qed
-
-lemma radon_s_lemma:
- assumes "finite s" "setsum f s = (0::real)"
- shows "setsum f {x\<in>s. 0 < f x} = - setsum f {x\<in>s. f x < 0}"
-proof- have *:"\<And>x. (if f x < 0 then f x else 0) + (if 0 < f x then f x else 0) = f x" by auto
- show ?thesis unfolding real_add_eq_0_iff[THEN sym] and setsum_restrict_set''[OF assms(1)] and setsum_addf[THEN sym] and *
- using assms(2) by assumption qed
-
-lemma radon_v_lemma:
- assumes "finite s" "setsum f s = 0" "\<forall>x. g x = (0::real) \<longrightarrow> f x = (0::real^'n)"
- shows "(setsum f {x\<in>s. 0 < g x}) = - setsum f {x\<in>s. g x < 0}"
-proof-
- have *:"\<And>x. (if 0 < g x then f x else 0) + (if g x < 0 then f x else 0) = f x" using assms(3) by auto
- show ?thesis unfolding eq_neg_iff_add_eq_0 and setsum_restrict_set''[OF assms(1)] and setsum_addf[THEN sym] and *
- using assms(2) by assumption qed
-
-lemma radon_partition:
- assumes "finite c" "affine_dependent c"
- shows "\<exists>m p. m \<inter> p = {} \<and> m \<union> p = c \<and> (convex hull m) \<inter> (convex hull p) \<noteq> {}" proof-
- obtain u v where uv:"setsum u c = 0" "v\<in>c" "u v \<noteq> 0" "(\<Sum>v\<in>c. u v *\<^sub>R v) = 0" using radon_ex_lemma[OF assms] by auto
- have fin:"finite {x \<in> c. 0 < u x}" "finite {x \<in> c. 0 > u x}" using assms(1) by auto
- def z \<equiv> "(inverse (setsum u {x\<in>c. u x > 0})) *\<^sub>R setsum (\<lambda>x. u x *\<^sub>R x) {x\<in>c. u x > 0}"
- have "setsum u {x \<in> c. 0 < u x} \<noteq> 0" proof(cases "u v \<ge> 0")
- case False hence "u v < 0" by auto
- thus ?thesis proof(cases "\<exists>w\<in>{x \<in> c. 0 < u x}. u w > 0")
- case True thus ?thesis using setsum_nonneg_eq_0_iff[of _ u, OF fin(1)] by auto
- next
- case False hence "setsum u c \<le> setsum (\<lambda>x. if x=v then u v else 0) c" apply(rule_tac setsum_mono) by auto
- thus ?thesis unfolding setsum_delta[OF assms(1)] using uv(2) and `u v < 0` and uv(1) by auto qed
- qed (insert setsum_nonneg_eq_0_iff[of _ u, OF fin(1)] uv(2-3), auto)
-
- hence *:"setsum u {x\<in>c. u x > 0} > 0" unfolding real_less_def apply(rule_tac conjI, rule_tac setsum_nonneg) by auto
- moreover have "setsum u ({x \<in> c. 0 < u x} \<union> {x \<in> c. u x < 0}) = setsum u c"
- "(\<Sum>x\<in>{x \<in> c. 0 < u x} \<union> {x \<in> c. u x < 0}. u x *\<^sub>R x) = (\<Sum>x\<in>c. u x *\<^sub>R x)"
- using assms(1) apply(rule_tac[!] setsum_mono_zero_left) by auto
- hence "setsum u {x \<in> c. 0 < u x} = - setsum u {x \<in> c. 0 > u x}"
- "(\<Sum>x\<in>{x \<in> c. 0 < u x}. u x *\<^sub>R x) = - (\<Sum>x\<in>{x \<in> c. 0 > u x}. u x *\<^sub>R x)"
- unfolding eq_neg_iff_add_eq_0 using uv(1,4) by (auto simp add: setsum_Un_zero[OF fin, THEN sym])
- moreover have "\<forall>x\<in>{v \<in> c. u v < 0}. 0 \<le> inverse (setsum u {x \<in> c. 0 < u x}) * - u x"
- apply (rule) apply (rule mult_nonneg_nonneg) using * by auto
-
- ultimately have "z \<in> convex hull {v \<in> c. u v \<le> 0}" unfolding convex_hull_explicit mem_Collect_eq
- apply(rule_tac x="{v \<in> c. u v < 0}" in exI, rule_tac x="\<lambda>y. inverse (setsum u {x\<in>c. u x > 0}) * - u y" in exI)
- using assms(1) unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and z_def
- by(auto simp add: setsum_negf vector_smult_lneg mult_right.setsum[THEN sym])
- moreover have "\<forall>x\<in>{v \<in> c. 0 < u v}. 0 \<le> inverse (setsum u {x \<in> c. 0 < u x}) * u x"
- apply (rule) apply (rule mult_nonneg_nonneg) using * by auto
- hence "z \<in> convex hull {v \<in> c. u v > 0}" unfolding convex_hull_explicit mem_Collect_eq
- apply(rule_tac x="{v \<in> c. 0 < u v}" in exI, rule_tac x="\<lambda>y. inverse (setsum u {x\<in>c. u x > 0}) * u y" in exI)
- using assms(1) unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and z_def using *
- by(auto simp add: setsum_negf vector_smult_lneg mult_right.setsum[THEN sym])
- ultimately show ?thesis apply(rule_tac x="{v\<in>c. u v \<le> 0}" in exI, rule_tac x="{v\<in>c. u v > 0}" in exI) by auto
-qed
-
-lemma radon: assumes "affine_dependent c"
- obtains m p where "m\<subseteq>c" "p\<subseteq>c" "m \<inter> p = {}" "(convex hull m) \<inter> (convex hull p) \<noteq> {}"
-proof- from assms[unfolded affine_dependent_explicit] guess s .. then guess u ..
- hence *:"finite s" "affine_dependent s" and s:"s \<subseteq> c" unfolding affine_dependent_explicit by auto
- from radon_partition[OF *] guess m .. then guess p ..
- thus ?thesis apply(rule_tac that[of p m]) using s by auto qed
-
-subsection {* Helly's theorem. *}
-
-lemma helly_induct: fixes f::"(real^'n::finite) set set"
- assumes "f hassize n" "n \<ge> CARD('n) + 1"
- "\<forall>s\<in>f. convex s" "\<forall>t\<subseteq>f. card t = CARD('n) + 1 \<longrightarrow> \<Inter> t \<noteq> {}"
- shows "\<Inter> f \<noteq> {}"
- using assms unfolding hassize_def apply(erule_tac conjE) proof(induct n arbitrary: f)
-case (Suc n)
-show "\<Inter> f \<noteq> {}" apply(cases "n = CARD('n)") apply(rule Suc(4)[rule_format])
- unfolding card_Diff_singleton_if[OF Suc(5)] and Suc(6) proof-
- assume ng:"n \<noteq> CARD('n)" hence "\<exists>X. \<forall>s\<in>f. X s \<in> \<Inter>(f - {s})" apply(rule_tac bchoice) unfolding ex_in_conv
- apply(rule, rule Suc(1)[rule_format]) unfolding card_Diff_singleton_if[OF Suc(5)] and Suc(6)
- defer apply(rule Suc(3)[rule_format]) defer apply(rule Suc(4)[rule_format]) using Suc(2,5) by auto
- then obtain X where X:"\<forall>s\<in>f. X s \<in> \<Inter>(f - {s})" by auto
- show ?thesis proof(cases "inj_on X f")
- case False then obtain s t where st:"s\<noteq>t" "s\<in>f" "t\<in>f" "X s = X t" unfolding inj_on_def by auto
- hence *:"\<Inter> f = \<Inter> (f - {s}) \<inter> \<Inter> (f - {t})" by auto
- show ?thesis unfolding * unfolding ex_in_conv[THEN sym] apply(rule_tac x="X s" in exI)
- apply(rule, rule X[rule_format]) using X st by auto
- next case True then obtain m p where mp:"m \<inter> p = {}" "m \<union> p = X ` f" "convex hull m \<inter> convex hull p \<noteq> {}"
- using radon_partition[of "X ` f"] and affine_dependent_biggerset[of "X ` f"]
- unfolding card_image[OF True] and Suc(6) using Suc(2,5) and ng by auto
- have "m \<subseteq> X ` f" "p \<subseteq> X ` f" using mp(2) by auto
- then obtain g h where gh:"m = X ` g" "p = X ` h" "g \<subseteq> f" "h \<subseteq> f" unfolding subset_image_iff by auto
- hence "f \<union> (g \<union> h) = f" by auto
- hence f:"f = g \<union> h" using inj_on_Un_image_eq_iff[of X f "g \<union> h"] and True
- unfolding mp(2)[unfolded image_Un[THEN sym] gh] by auto
- have *:"g \<inter> h = {}" using mp(1) unfolding gh using inj_on_image_Int[OF True gh(3,4)] by auto
- have "convex hull (X ` h) \<subseteq> \<Inter> g" "convex hull (X ` g) \<subseteq> \<Inter> h"
- apply(rule_tac [!] hull_minimal) using Suc(3) gh(3-4) unfolding mem_def unfolding subset_eq
- apply(rule_tac [2] convex_Inter, rule_tac [4] convex_Inter) apply rule prefer 3 apply rule proof-
- fix x assume "x\<in>X ` g" then guess y unfolding image_iff ..
- thus "x\<in>\<Inter>h" using X[THEN bspec[where x=y]] using * f by auto next
- fix x assume "x\<in>X ` h" then guess y unfolding image_iff ..
- thus "x\<in>\<Inter>g" using X[THEN bspec[where x=y]] using * f by auto
- qed(auto)
- thus ?thesis unfolding f using mp(3)[unfolded gh] by blast qed
-qed(insert dimindex_ge_1, auto) qed(auto)
-
-lemma helly: fixes f::"(real^'n::finite) set set"
- assumes "finite f" "card f \<ge> CARD('n) + 1" "\<forall>s\<in>f. convex s"
- "\<forall>t\<subseteq>f. card t = CARD('n) + 1 \<longrightarrow> \<Inter> t \<noteq> {}"
- shows "\<Inter> f \<noteq>{}"
- apply(rule helly_induct) unfolding hassize_def using assms by auto
-
-subsection {* Convex hull is "preserved" by a linear function. *}
-
-lemma convex_hull_linear_image:
- assumes "bounded_linear f"
- shows "f ` (convex hull s) = convex hull (f ` s)"
- apply rule unfolding subset_eq ball_simps apply(rule_tac[!] hull_induct, rule hull_inc) prefer 3
- apply(erule imageE)apply(rule_tac x=xa in image_eqI) apply assumption
- apply(rule hull_subset[unfolded subset_eq, rule_format]) apply assumption
-proof-
- interpret f: bounded_linear f by fact
- show "convex {x. f x \<in> convex hull f ` s}"
- unfolding convex_def by(auto simp add: f.scaleR f.add convex_convex_hull[unfolded convex_def, rule_format]) next
- interpret f: bounded_linear f by fact
- show "convex {x. x \<in> f ` (convex hull s)}" using convex_convex_hull[unfolded convex_def, of s]
- unfolding convex_def by (auto simp add: f.scaleR [symmetric] f.add [symmetric])
-qed auto
-
-lemma in_convex_hull_linear_image:
- assumes "bounded_linear f" "x \<in> convex hull s"
- shows "(f x) \<in> convex hull (f ` s)"
-using convex_hull_linear_image[OF assms(1)] assms(2) by auto
-
-subsection {* Homeomorphism of all convex compact sets with nonempty interior. *}
-
-lemma compact_frontier_line_lemma:
- fixes s :: "(real ^ _) set"
- assumes "compact s" "0 \<in> s" "x \<noteq> 0"
- obtains u where "0 \<le> u" "(u *\<^sub>R x) \<in> frontier s" "\<forall>v>u. (v *\<^sub>R x) \<notin> s"
-proof-
- obtain b where b:"b>0" "\<forall>x\<in>s. norm x \<le> b" using compact_imp_bounded[OF assms(1), unfolded bounded_pos] by auto
- let ?A = "{y. \<exists>u. 0 \<le> u \<and> u \<le> b / norm(x) \<and> (y = u *\<^sub>R x)}"
- have A:"?A = (\<lambda>u. dest_vec1 u *\<^sub>R x) ` {0 .. vec1 (b / norm x)}"
- unfolding image_image[of "\<lambda>u. u *\<^sub>R x" "\<lambda>x. dest_vec1 x", THEN sym]
- unfolding dest_vec1_inverval vec1_dest_vec1 by auto
- have "compact ?A" unfolding A apply(rule compact_continuous_image, rule continuous_at_imp_continuous_on)
- apply(rule, rule continuous_vmul)
- apply (rule continuous_dest_vec1)
- apply(rule continuous_at_id) by(rule compact_interval)
- moreover have "{y. \<exists>u\<ge>0. u \<le> b / norm x \<and> y = u *\<^sub>R x} \<inter> s \<noteq> {}" apply(rule not_disjointI[OF _ assms(2)])
- unfolding mem_Collect_eq using `b>0` assms(3) by(auto intro!: divide_nonneg_pos)
- ultimately obtain u y where obt: "u\<ge>0" "u \<le> b / norm x" "y = u *\<^sub>R x"
- "y\<in>?A" "y\<in>s" "\<forall>z\<in>?A \<inter> s. dist 0 z \<le> dist 0 y" using distance_attains_sup[OF compact_inter[OF _ assms(1), of ?A], of 0] by auto
-
- have "norm x > 0" using assms(3)[unfolded zero_less_norm_iff[THEN sym]] by auto
- { fix v assume as:"v > u" "v *\<^sub>R x \<in> s"
- hence "v \<le> b / norm x" using b(2)[rule_format, OF as(2)]
- using `u\<ge>0` unfolding pos_le_divide_eq[OF `norm x > 0`] by auto
- hence "norm (v *\<^sub>R x) \<le> norm y" apply(rule_tac obt(6)[rule_format, unfolded dist_0_norm]) apply(rule IntI) defer
- apply(rule as(2)) unfolding mem_Collect_eq apply(rule_tac x=v in exI)
- using as(1) `u\<ge>0` by(auto simp add:field_simps)
- hence False unfolding obt(3) using `u\<ge>0` `norm x > 0` `v>u` by(auto simp add:field_simps)
- } note u_max = this
-
- have "u *\<^sub>R x \<in> frontier s" unfolding frontier_straddle apply(rule,rule,rule) apply(rule_tac x="u *\<^sub>R x" in bexI) unfolding obt(3)[THEN sym]
- prefer 3 apply(rule_tac x="(u + (e / 2) / norm x) *\<^sub>R x" in exI) apply(rule, rule) proof-
- fix e assume "0 < e" and as:"(u + e / 2 / norm x) *\<^sub>R x \<in> s"
- hence "u + e / 2 / norm x > u" using`norm x > 0` by(auto simp del:zero_less_norm_iff intro!: divide_pos_pos)
- thus False using u_max[OF _ as] by auto
- qed(insert `y\<in>s`, auto simp add: dist_norm scaleR_left_distrib obt(3))
- thus ?thesis apply(rule_tac that[of u]) apply(rule obt(1), assumption)
- apply(rule,rule,rule ccontr) apply(rule u_max) by auto qed
-
-lemma starlike_compact_projective:
- assumes "compact s" "cball (0::real^'n::finite) 1 \<subseteq> s "
- "\<forall>x\<in>s. \<forall>u. 0 \<le> u \<and> u < 1 \<longrightarrow> (u *\<^sub>R x) \<in> (s - frontier s )"
- shows "s homeomorphic (cball (0::real^'n::finite) 1)"
-proof-
- have fs:"frontier s \<subseteq> s" apply(rule frontier_subset_closed) using compact_imp_closed[OF assms(1)] by simp
- def pi \<equiv> "\<lambda>x::real^'n. inverse (norm x) *\<^sub>R x"
- have "0 \<notin> frontier s" unfolding frontier_straddle apply(rule ccontr) unfolding not_not apply(erule_tac x=1 in allE)
- using assms(2)[unfolded subset_eq Ball_def mem_cball] by auto
- have injpi:"\<And>x y. pi x = pi y \<and> norm x = norm y \<longleftrightarrow> x = y" unfolding pi_def by auto
-
- have contpi:"continuous_on (UNIV - {0}) pi" apply(rule continuous_at_imp_continuous_on)
- apply rule unfolding pi_def
- apply (rule continuous_mul)
- apply (rule continuous_at_inv[unfolded o_def])
- apply (rule continuous_at_norm)
- apply simp
- apply (rule continuous_at_id)
- done
- def sphere \<equiv> "{x::real^'n. norm x = 1}"
- have pi:"\<And>x. x \<noteq> 0 \<Longrightarrow> pi x \<in> sphere" "\<And>x u. u>0 \<Longrightarrow> pi (u *\<^sub>R x) = pi x" unfolding pi_def sphere_def by auto
-
- have "0\<in>s" using assms(2) and centre_in_cball[of 0 1] by auto
- have front_smul:"\<forall>x\<in>frontier s. \<forall>u\<ge>0. u *\<^sub>R x \<in> s \<longleftrightarrow> u \<le> 1" proof(rule,rule,rule)
- fix x u assume x:"x\<in>frontier s" and "(0::real)\<le>u"
- hence "x\<noteq>0" using `0\<notin>frontier s` by auto
- obtain v where v:"0 \<le> v" "v *\<^sub>R x \<in> frontier s" "\<forall>w>v. w *\<^sub>R x \<notin> s"
- using compact_frontier_line_lemma[OF assms(1) `0\<in>s` `x\<noteq>0`] by auto
- have "v=1" apply(rule ccontr) unfolding neq_iff apply(erule disjE) proof-
- assume "v<1" thus False using v(3)[THEN spec[where x=1]] using x and fs by auto next
- assume "v>1" thus False using assms(3)[THEN bspec[where x="v *\<^sub>R x"], THEN spec[where x="inverse v"]]
- using v and x and fs unfolding inverse_less_1_iff by auto qed
- show "u *\<^sub>R x \<in> s \<longleftrightarrow> u \<le> 1" apply rule using v(3)[unfolded `v=1`, THEN spec[where x=u]] proof-
- assume "u\<le>1" thus "u *\<^sub>R x \<in> s" apply(cases "u=1")
- using assms(3)[THEN bspec[where x=x], THEN spec[where x=u]] using `0\<le>u` and x and fs by auto qed auto qed
-
- have "\<exists>surf. homeomorphism (frontier s) sphere pi surf"
- apply(rule homeomorphism_compact) apply(rule compact_frontier[OF assms(1)])
- apply(rule continuous_on_subset[OF contpi]) defer apply(rule set_ext,rule)
- unfolding inj_on_def prefer 3 apply(rule,rule,rule)
- proof- fix x assume "x\<in>pi ` frontier s" then obtain y where "y\<in>frontier s" "x = pi y" by auto
- thus "x \<in> sphere" using pi(1)[of y] and `0 \<notin> frontier s` by auto
- next fix x assume "x\<in>sphere" hence "norm x = 1" "x\<noteq>0" unfolding sphere_def by auto
- then obtain u where "0 \<le> u" "u *\<^sub>R x \<in> frontier s" "\<forall>v>u. v *\<^sub>R x \<notin> s"
- using compact_frontier_line_lemma[OF assms(1) `0\<in>s`, of x] by auto
- thus "x \<in> pi ` frontier s" unfolding image_iff le_less pi_def apply(rule_tac x="u *\<^sub>R x" in bexI) using `norm x = 1` `0\<notin>frontier s` by auto
- next fix x y assume as:"x \<in> frontier s" "y \<in> frontier s" "pi x = pi y"
- hence xys:"x\<in>s" "y\<in>s" using fs by auto
- from as(1,2) have nor:"norm x \<noteq> 0" "norm y \<noteq> 0" using `0\<notin>frontier s` by auto
- from nor have x:"x = norm x *\<^sub>R ((inverse (norm y)) *\<^sub>R y)" unfolding as(3)[unfolded pi_def, THEN sym] by auto
- from nor have y:"y = norm y *\<^sub>R ((inverse (norm x)) *\<^sub>R x)" unfolding as(3)[unfolded pi_def] by auto
- have "0 \<le> norm y * inverse (norm x)" "0 \<le> norm x * inverse (norm y)"
- unfolding divide_inverse[THEN sym] apply(rule_tac[!] divide_nonneg_pos) using nor by auto
- hence "norm x = norm y" apply(rule_tac ccontr) unfolding neq_iff
- using x y and front_smul[THEN bspec, OF as(1), THEN spec[where x="norm y * (inverse (norm x))"]]
- using front_smul[THEN bspec, OF as(2), THEN spec[where x="norm x * (inverse (norm y))"]]
- using xys nor by(auto simp add:field_simps divide_le_eq_1 divide_inverse[THEN sym])
- thus "x = y" apply(subst injpi[THEN sym]) using as(3) by auto
- qed(insert `0 \<notin> frontier s`, auto)
- then obtain surf where surf:"\<forall>x\<in>frontier s. surf (pi x) = x" "pi ` frontier s = sphere" "continuous_on (frontier s) pi"
- "\<forall>y\<in>sphere. pi (surf y) = y" "surf ` sphere = frontier s" "continuous_on sphere surf" unfolding homeomorphism_def by auto
-
- have cont_surfpi:"continuous_on (UNIV - {0}) (surf \<circ> pi)" apply(rule continuous_on_compose, rule contpi)
- apply(rule continuous_on_subset[of sphere], rule surf(6)) using pi(1) by auto
-
- { fix x assume as:"x \<in> cball (0::real^'n) 1"
- have "norm x *\<^sub>R surf (pi x) \<in> s" proof(cases "x=0 \<or> norm x = 1")
- case False hence "pi x \<in> sphere" "norm x < 1" using pi(1)[of x] as by(auto simp add: dist_norm)
- thus ?thesis apply(rule_tac assms(3)[rule_format, THEN DiffD1])
- apply(rule_tac fs[unfolded subset_eq, rule_format])
- unfolding surf(5)[THEN sym] by auto
- next case True thus ?thesis apply rule defer unfolding pi_def apply(rule fs[unfolded subset_eq, rule_format])
- unfolding surf(5)[unfolded sphere_def, THEN sym] using `0\<in>s` by auto qed } note hom = this
-
- { fix x assume "x\<in>s"
- hence "x \<in> (\<lambda>x. norm x *\<^sub>R surf (pi x)) ` cball 0 1" proof(cases "x=0")
- case True show ?thesis unfolding image_iff True apply(rule_tac x=0 in bexI) by auto
- next let ?a = "inverse (norm (surf (pi x)))"
- case False hence invn:"inverse (norm x) \<noteq> 0" by auto
- from False have pix:"pi x\<in>sphere" using pi(1) by auto
- hence "pi (surf (pi x)) = pi x" apply(rule_tac surf(4)[rule_format]) by assumption
- hence **:"norm x *\<^sub>R (?a *\<^sub>R surf (pi x)) = x" apply(rule_tac scaleR_left_imp_eq[OF invn]) unfolding pi_def using invn by auto
- hence *:"?a * norm x > 0" and"?a > 0" "?a \<noteq> 0" using surf(5) `0\<notin>frontier s` apply -
- apply(rule_tac mult_pos_pos) using False[unfolded zero_less_norm_iff[THEN sym]] by auto
- have "norm (surf (pi x)) \<noteq> 0" using ** False by auto
- hence "norm x = norm ((?a * norm x) *\<^sub>R surf (pi x))"
- unfolding norm_scaleR abs_mult abs_norm_cancel abs_of_pos[OF `?a > 0`] by auto
- moreover have "pi x = pi ((inverse (norm (surf (pi x))) * norm x) *\<^sub>R surf (pi x))"
- unfolding pi(2)[OF *] surf(4)[rule_format, OF pix] ..
- moreover have "surf (pi x) \<in> frontier s" using surf(5) pix by auto
- hence "dist 0 (inverse (norm (surf (pi x))) *\<^sub>R x) \<le> 1" unfolding dist_norm
- using ** and * using front_smul[THEN bspec[where x="surf (pi x)"], THEN spec[where x="norm x * ?a"]]
- using False `x\<in>s` by(auto simp add:field_simps)
- ultimately show ?thesis unfolding image_iff apply(rule_tac x="inverse (norm (surf(pi x))) *\<^sub>R x" in bexI)
- apply(subst injpi[THEN sym]) unfolding abs_mult abs_norm_cancel abs_of_pos[OF `?a > 0`]
- unfolding pi(2)[OF `?a > 0`] by auto
- qed } note hom2 = this
-
- show ?thesis apply(subst homeomorphic_sym) apply(rule homeomorphic_compact[where f="\<lambda>x. norm x *\<^sub>R surf (pi x)"])
- apply(rule compact_cball) defer apply(rule set_ext, rule, erule imageE, drule hom)
- prefer 4 apply(rule continuous_at_imp_continuous_on, rule) apply(rule_tac [3] hom2) proof-
- fix x::"real^'n" assume as:"x \<in> cball 0 1"
- thus "continuous (at x) (\<lambda>x. norm x *\<^sub>R surf (pi x))" proof(cases "x=0")
- case False thus ?thesis apply(rule_tac continuous_mul, rule_tac continuous_at_norm)
- using cont_surfpi unfolding continuous_on_eq_continuous_at[OF open_delete[OF open_UNIV]] o_def by auto
- next guess a using UNIV_witness[where 'a = 'n] ..
- obtain B where B:"\<forall>x\<in>s. norm x \<le> B" using compact_imp_bounded[OF assms(1)] unfolding bounded_iff by auto
- hence "B > 0" using assms(2) unfolding subset_eq apply(erule_tac x="basis a" in ballE) defer apply(erule_tac x="basis a" in ballE)
- unfolding Ball_def mem_cball dist_norm by (auto simp add: norm_basis[unfolded One_nat_def])
- case True show ?thesis unfolding True continuous_at Lim_at apply(rule,rule) apply(rule_tac x="e / B" in exI)
- apply(rule) apply(rule divide_pos_pos) prefer 3 apply(rule,rule,erule conjE)
- unfolding norm_0 scaleR_zero_left dist_norm diff_0_right norm_scaleR abs_norm_cancel proof-
- fix e and x::"real^'n" assume as:"norm x < e / B" "0 < norm x" "0<e"
- hence "surf (pi x) \<in> frontier s" using pi(1)[of x] unfolding surf(5)[THEN sym] by auto
- hence "norm (surf (pi x)) \<le> B" using B fs by auto
- hence "norm x * norm (surf (pi x)) \<le> norm x * B" using as(2) by auto
- also have "\<dots> < e / B * B" apply(rule mult_strict_right_mono) using as(1) `B>0` by auto
- also have "\<dots> = e" using `B>0` by auto
- finally show "norm x * norm (surf (pi x)) < e" by assumption
- qed(insert `B>0`, auto) qed
- next { fix x assume as:"surf (pi x) = 0"
- have "x = 0" proof(rule ccontr)
- assume "x\<noteq>0" hence "pi x \<in> sphere" using pi(1) by auto
- hence "surf (pi x) \<in> frontier s" using surf(5) by auto
- thus False using `0\<notin>frontier s` unfolding as by simp qed
- } note surf_0 = this
- show "inj_on (\<lambda>x. norm x *\<^sub>R surf (pi x)) (cball 0 1)" unfolding inj_on_def proof(rule,rule,rule)
- fix x y assume as:"x \<in> cball 0 1" "y \<in> cball 0 1" "norm x *\<^sub>R surf (pi x) = norm y *\<^sub>R surf (pi y)"
- thus "x=y" proof(cases "x=0 \<or> y=0")
- case True thus ?thesis using as by(auto elim: surf_0) next
- case False
- hence "pi (surf (pi x)) = pi (surf (pi y))" using as(3)
- using pi(2)[of "norm x" "surf (pi x)"] pi(2)[of "norm y" "surf (pi y)"] by auto
- moreover have "pi x \<in> sphere" "pi y \<in> sphere" using pi(1) False by auto
- ultimately have *:"pi x = pi y" using surf(4)[THEN bspec[where x="pi x"]] surf(4)[THEN bspec[where x="pi y"]] by auto
- moreover have "norm x = norm y" using as(3)[unfolded *] using False by(auto dest:surf_0)
- ultimately show ?thesis using injpi by auto qed qed
- qed auto qed
-
-lemma homeomorphic_convex_compact_lemma: fixes s::"(real^'n::finite) set"
- assumes "convex s" "compact s" "cball 0 1 \<subseteq> s"
- shows "s homeomorphic (cball (0::real^'n) 1)"
- apply(rule starlike_compact_projective[OF assms(2-3)]) proof(rule,rule,rule,erule conjE)
- fix x u assume as:"x \<in> s" "0 \<le> u" "u < (1::real)"
- hence "u *\<^sub>R x \<in> interior s" unfolding interior_def mem_Collect_eq
- apply(rule_tac x="ball (u *\<^sub>R x) (1 - u)" in exI) apply(rule, rule open_ball)
- unfolding centre_in_ball apply rule defer apply(rule) unfolding mem_ball proof-
- fix y assume "dist (u *\<^sub>R x) y < 1 - u"
- hence "inverse (1 - u) *\<^sub>R (y - u *\<^sub>R x) \<in> s"
- using assms(3) apply(erule_tac subsetD) unfolding mem_cball dist_commute dist_norm
- unfolding group_add_class.diff_0 group_add_class.diff_0_right norm_minus_cancel norm_scaleR
- apply (rule mult_left_le_imp_le[of "1 - u"])
- unfolding class_semiring.mul_a using `u<1` by auto
- thus "y \<in> s" using assms(1)[unfolded convex_def, rule_format, of "inverse(1 - u) *\<^sub>R (y - u *\<^sub>R x)" x "1 - u" u]
- using as unfolding scaleR_scaleR by auto qed auto
- thus "u *\<^sub>R x \<in> s - frontier s" using frontier_def and interior_subset by auto qed
-
-lemma homeomorphic_convex_compact_cball: fixes e::real and s::"(real^'n::finite) set"
- assumes "convex s" "compact s" "interior s \<noteq> {}" "0 < e"
- shows "s homeomorphic (cball (b::real^'n::finite) e)"
-proof- obtain a where "a\<in>interior s" using assms(3) by auto
- then obtain d where "d>0" and d:"cball a d \<subseteq> s" unfolding mem_interior_cball by auto
- let ?d = "inverse d" and ?n = "0::real^'n"
- have "cball ?n 1 \<subseteq> (\<lambda>x. inverse d *\<^sub>R (x - a)) ` s"
- apply(rule, rule_tac x="d *\<^sub>R x + a" in image_eqI) defer
- apply(rule d[unfolded subset_eq, rule_format]) using `d>0` unfolding mem_cball dist_norm
- by(auto simp add: mult_right_le_one_le)
- hence "(\<lambda>x. inverse d *\<^sub>R (x - a)) ` s homeomorphic cball ?n 1"
- using homeomorphic_convex_compact_lemma[of "(\<lambda>x. ?d *\<^sub>R -a + ?d *\<^sub>R x) ` s", OF convex_affinity compact_affinity]
- using assms(1,2) by(auto simp add: uminus_add_conv_diff scaleR_right_diff_distrib)
- thus ?thesis apply(rule_tac homeomorphic_trans[OF _ homeomorphic_balls(2)[of 1 _ ?n]])
- apply(rule homeomorphic_trans[OF homeomorphic_affinity[of "?d" s "?d *\<^sub>R -a"]])
- using `d>0` `e>0` by(auto simp add: uminus_add_conv_diff scaleR_right_diff_distrib) qed
-
-lemma homeomorphic_convex_compact: fixes s::"(real^'n::finite) set" and t::"(real^'n) set"
- assumes "convex s" "compact s" "interior s \<noteq> {}"
- "convex t" "compact t" "interior t \<noteq> {}"
- shows "s homeomorphic t"
- using assms by(meson zero_less_one homeomorphic_trans homeomorphic_convex_compact_cball homeomorphic_sym)
-
-subsection {* Epigraphs of convex functions. *}
-
-definition "epigraph s (f::real^'n \<Rightarrow> real) = {xy. fstcart xy \<in> s \<and> f(fstcart xy) \<le> dest_vec1 (sndcart xy)}"
-
-lemma mem_epigraph: "(pastecart x (vec1 y)) \<in> epigraph s f \<longleftrightarrow> x \<in> s \<and> f x \<le> y" unfolding epigraph_def by auto
-
-lemma convex_epigraph:
- "convex(epigraph s f) \<longleftrightarrow> convex_on s f \<and> convex s"
- unfolding convex_def convex_on_def unfolding Ball_def forall_pastecart epigraph_def
- unfolding mem_Collect_eq fstcart_pastecart sndcart_pastecart sndcart_add sndcart_cmul [where 'a=real, unfolded smult_conv_scaleR] fstcart_add fstcart_cmul [where 'a=real, unfolded smult_conv_scaleR]
- unfolding Ball_def[symmetric] unfolding dest_vec1_add dest_vec1_cmul [where 'a=real, unfolded smult_conv_scaleR]
- apply(subst forall_dest_vec1[THEN sym])+ by(meson real_le_refl real_le_trans add_mono mult_left_mono)
-
-lemma convex_epigraphI: assumes "convex_on s f" "convex s"
- shows "convex(epigraph s f)" using assms unfolding convex_epigraph by auto
-
-lemma convex_epigraph_convex: "convex s \<Longrightarrow> (convex_on s f \<longleftrightarrow> convex(epigraph s f))"
- using convex_epigraph by auto
-
-subsection {* Use this to derive general bound property of convex function. *}
-
-lemma forall_of_pastecart:
- "(\<forall>p. P (\<lambda>x. fstcart (p x)) (\<lambda>x. sndcart (p x))) \<longleftrightarrow> (\<forall>x y. P x y)" apply meson
- apply(erule_tac x="\<lambda>a. pastecart (x a) (y a)" in allE) unfolding o_def by auto
-
-lemma forall_of_pastecart':
- "(\<forall>p. P (fstcart p) (sndcart p)) \<longleftrightarrow> (\<forall>x y. P x y)" apply meson
- apply(erule_tac x="pastecart x y" in allE) unfolding o_def by auto
-
-lemma forall_of_dest_vec1: "(\<forall>v. P (\<lambda>x. dest_vec1 (v x))) \<longleftrightarrow> (\<forall>x. P x)"
- apply rule apply rule apply(erule_tac x="(vec1 \<circ> x)" in allE) unfolding o_def vec1_dest_vec1 by auto
-
-lemma forall_of_dest_vec1': "(\<forall>v. P (dest_vec1 v)) \<longleftrightarrow> (\<forall>x. P x)"
- apply rule apply rule apply(erule_tac x="(vec1 x)" in allE) defer apply rule
- apply(erule_tac x="dest_vec1 v" in allE) unfolding o_def vec1_dest_vec1 by auto
-
-lemma convex_on:
- fixes s :: "(real ^ _) set"
- assumes "convex s"
- shows "convex_on s f \<longleftrightarrow> (\<forall>k u x. (\<forall>i\<in>{1..k::nat}. 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow>
- f (setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} ) \<le> setsum (\<lambda>i. u i * f(x i)) {1..k} ) "
- unfolding convex_epigraph_convex[OF assms] convex epigraph_def Ball_def mem_Collect_eq
- unfolding sndcart_setsum[OF finite_atLeastAtMost] fstcart_setsum[OF finite_atLeastAtMost] dest_vec1_setsum[OF finite_atLeastAtMost]
- unfolding fstcart_pastecart sndcart_pastecart sndcart_add sndcart_cmul [where 'a=real, unfolded smult_conv_scaleR] fstcart_add fstcart_cmul [where 'a=real, unfolded smult_conv_scaleR]
- unfolding dest_vec1_add dest_vec1_cmul [where 'a=real, unfolded smult_conv_scaleR] apply(subst forall_of_pastecart)+ apply(subst forall_of_dest_vec1)+ apply rule
- using assms[unfolded convex] apply simp apply(rule,rule,rule)
- apply(erule_tac x=k in allE, erule_tac x=u in allE, erule_tac x=x in allE) apply rule apply rule apply rule defer
- apply(rule_tac j="\<Sum>i = 1..k. u i * f (x i)" in real_le_trans)
- defer apply(rule setsum_mono) apply(erule conjE)+ apply(erule_tac x=i in allE)apply(rule mult_left_mono)
- using assms[unfolded convex] by auto
-
-subsection {* Convexity of general and special intervals. *}
-
-lemma is_interval_convex:
- fixes s :: "(real ^ _) set"
- assumes "is_interval s" shows "convex s"
- unfolding convex_def apply(rule,rule,rule,rule,rule,rule,rule) proof-
- fix x y u v assume as:"x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
- hence *:"u = 1 - v" "1 - v \<ge> 0" and **:"v = 1 - u" "1 - u \<ge> 0" by auto
- { fix a b assume "\<not> b \<le> u * a + v * b"
- hence "u * a < (1 - v) * b" unfolding not_le using as(4) by(auto simp add: field_simps)
- hence "a < b" unfolding * using as(4) *(2) apply(rule_tac mult_left_less_imp_less[of "1 - v"]) by(auto simp add: field_simps)
- hence "a \<le> u * a + v * b" unfolding * using as(4) by (auto simp add: field_simps intro!:mult_right_mono)
- } moreover
- { fix a b assume "\<not> u * a + v * b \<le> a"
- hence "v * b > (1 - u) * a" unfolding not_le using as(4) by(auto simp add: field_simps)
- hence "a < b" unfolding * using as(4) apply(rule_tac mult_left_less_imp_less) by(auto simp add: ring_simps)
- hence "u * a + v * b \<le> b" unfolding ** using **(2) as(3) by(auto simp add: field_simps intro!:mult_right_mono) }
- ultimately show "u *\<^sub>R x + v *\<^sub>R y \<in> s" apply- apply(rule assms[unfolded is_interval_def, rule_format, OF as(1,2)])
- using as(3-) dimindex_ge_1 apply- by(auto simp add: vector_component) qed
-
-lemma is_interval_connected:
- fixes s :: "(real ^ _) set"
- shows "is_interval s \<Longrightarrow> connected s"
- using is_interval_convex convex_connected by auto
-
-lemma convex_interval: "convex {a .. b}" "convex {a<..<b::real^'n::finite}"
- apply(rule_tac[!] is_interval_convex) using is_interval_interval by auto
-
-subsection {* On @{text "real^1"}, @{text "is_interval"}, @{text "convex"} and @{text "connected"} are all equivalent. *}
-
-lemma is_interval_1:
- "is_interval s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. \<forall> x. dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b \<longrightarrow> x \<in> s)"
- unfolding is_interval_def dest_vec1_def forall_1 by auto
-
-lemma is_interval_connected_1: "is_interval s \<longleftrightarrow> connected (s::(real^1) set)"
- apply(rule, rule is_interval_connected, assumption) unfolding is_interval_1
- apply(rule,rule,rule,rule,erule conjE,rule ccontr) proof-
- fix a b x assume as:"connected s" "a \<in> s" "b \<in> s" "dest_vec1 a \<le> dest_vec1 x" "dest_vec1 x \<le> dest_vec1 b" "x\<notin>s"
- hence *:"dest_vec1 a < dest_vec1 x" "dest_vec1 x < dest_vec1 b" apply(rule_tac [!] ccontr) unfolding not_less by auto
- let ?halfl = "{z. inner (basis 1) z < dest_vec1 x} " and ?halfr = "{z. inner (basis 1) z > dest_vec1 x} "
- { fix y assume "y \<in> s" have "y \<in> ?halfr \<union> ?halfl" apply(rule ccontr)
- using as(6) `y\<in>s` by (auto simp add: inner_vector_def dest_vec1_eq [unfolded dest_vec1_def] dest_vec1_def) }
- moreover have "a\<in>?halfl" "b\<in>?halfr" using * by (auto simp add: inner_vector_def dest_vec1_def)
- hence "?halfl \<inter> s \<noteq> {}" "?halfr \<inter> s \<noteq> {}" using as(2-3) by auto
- ultimately show False apply(rule_tac notE[OF as(1)[unfolded connected_def]])
- apply(rule_tac x="?halfl" in exI, rule_tac x="?halfr" in exI)
- apply(rule, rule open_halfspace_lt, rule, rule open_halfspace_gt) apply(rule, rule, rule ccontr)
- by(auto simp add: basis_component field_simps) qed
-
-lemma is_interval_convex_1:
- "is_interval s \<longleftrightarrow> convex (s::(real^1) set)"
- using is_interval_convex convex_connected is_interval_connected_1 by auto
-
-lemma convex_connected_1:
- "connected s \<longleftrightarrow> convex (s::(real^1) set)"
- using is_interval_convex convex_connected is_interval_connected_1 by auto
-
-subsection {* Another intermediate value theorem formulation. *}
-
-lemma ivt_increasing_component_on_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
- assumes "dest_vec1 a \<le> dest_vec1 b" "continuous_on {a .. b} f" "(f a)$k \<le> y" "y \<le> (f b)$k"
- shows "\<exists>x\<in>{a..b}. (f x)$k = y"
-proof- have "f a \<in> f ` {a..b}" "f b \<in> f ` {a..b}" apply(rule_tac[!] imageI)
- using assms(1) by(auto simp add: vector_less_eq_def dest_vec1_def)
- thus ?thesis using connected_ivt_component[of "f ` {a..b}" "f a" "f b" k y]
- using connected_continuous_image[OF assms(2) convex_connected[OF convex_interval(1)]]
- using assms by(auto intro!: imageI) qed
-
-lemma ivt_increasing_component_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
- assumes "dest_vec1 a \<le> dest_vec1 b"
- "\<forall>x\<in>{a .. b}. continuous (at x) f" "f a$k \<le> y" "y \<le> f b$k"
- shows "\<exists>x\<in>{a..b}. (f x)$k = y"
- apply(rule ivt_increasing_component_on_1) using assms using continuous_at_imp_continuous_on by auto
-
-lemma ivt_decreasing_component_on_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
- assumes "dest_vec1 a \<le> dest_vec1 b" "continuous_on {a .. b} f" "(f b)$k \<le> y" "y \<le> (f a)$k"
- shows "\<exists>x\<in>{a..b}. (f x)$k = y"
- apply(subst neg_equal_iff_equal[THEN sym]) unfolding vector_uminus_component[THEN sym]
- apply(rule ivt_increasing_component_on_1) using assms using continuous_on_neg
- by(auto simp add:vector_uminus_component)
-
-lemma ivt_decreasing_component_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
- assumes "dest_vec1 a \<le> dest_vec1 b" "\<forall>x\<in>{a .. b}. continuous (at x) f" "f b$k \<le> y" "y \<le> f a$k"
- shows "\<exists>x\<in>{a..b}. (f x)$k = y"
- apply(rule ivt_decreasing_component_on_1) using assms using continuous_at_imp_continuous_on by auto
-
-subsection {* A bound within a convex hull, and so an interval. *}
-
-lemma convex_on_convex_hull_bound:
- fixes s :: "(real ^ _) set"
- assumes "convex_on (convex hull s) f" "\<forall>x\<in>s. f x \<le> b"
- shows "\<forall>x\<in> convex hull s. f x \<le> b" proof
- fix x assume "x\<in>convex hull s"
- then obtain k u v where obt:"\<forall>i\<in>{1..k::nat}. 0 \<le> u i \<and> v i \<in> s" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R v i) = x"
- unfolding convex_hull_indexed mem_Collect_eq by auto
- have "(\<Sum>i = 1..k. u i * f (v i)) \<le> b" using setsum_mono[of "{1..k}" "\<lambda>i. u i * f (v i)" "\<lambda>i. u i * b"]
- unfolding setsum_left_distrib[THEN sym] obt(2) mult_1 apply(drule_tac meta_mp) apply(rule mult_left_mono)
- using assms(2) obt(1) by auto
- thus "f x \<le> b" using assms(1)[unfolded convex_on[OF convex_convex_hull], rule_format, of k u v]
- unfolding obt(2-3) using obt(1) and hull_subset[unfolded subset_eq, rule_format, of _ s] by auto qed
-
-lemma unit_interval_convex_hull:
- "{0::real^'n::finite .. 1} = convex hull {x. \<forall>i. (x$i = 0) \<or> (x$i = 1)}" (is "?int = convex hull ?points")
-proof- have 01:"{0,1} \<subseteq> convex hull ?points" apply rule apply(rule_tac hull_subset[unfolded subset_eq, rule_format]) by auto
- { fix n x assume "x\<in>{0::real^'n .. 1}" "n \<le> CARD('n)" "card {i. x$i \<noteq> 0} \<le> n"
- hence "x\<in>convex hull ?points" proof(induct n arbitrary: x)
- case 0 hence "x = 0" apply(subst Cart_eq) apply rule by auto
- thus "x\<in>convex hull ?points" using 01 by auto
- next
- case (Suc n) show "x\<in>convex hull ?points" proof(cases "{i. x$i \<noteq> 0} = {}")
- case True hence "x = 0" unfolding Cart_eq by auto
- thus "x\<in>convex hull ?points" using 01 by auto
- next
- case False def xi \<equiv> "Min ((\<lambda>i. x$i) ` {i. x$i \<noteq> 0})"
- have "xi \<in> (\<lambda>i. x$i) ` {i. x$i \<noteq> 0}" unfolding xi_def apply(rule Min_in) using False by auto
- then obtain i where i':"x$i = xi" "x$i \<noteq> 0" by auto
- have i:"\<And>j. x$j > 0 \<Longrightarrow> x$i \<le> x$j"
- unfolding i'(1) xi_def apply(rule_tac Min_le) unfolding image_iff
- defer apply(rule_tac x=j in bexI) using i' by auto
- have i01:"x$i \<le> 1" "x$i > 0" using Suc(2)[unfolded mem_interval,rule_format,of i] using i'(2) `x$i \<noteq> 0`
- by(auto simp add: Cart_lambda_beta)
- show ?thesis proof(cases "x$i=1")
- case True have "\<forall>j\<in>{i. x$i \<noteq> 0}. x$j = 1" apply(rule, rule ccontr) unfolding mem_Collect_eq proof-
- fix j assume "x $ j \<noteq> 0" "x $ j \<noteq> 1"
- hence j:"x$j \<in> {0<..<1}" using Suc(2) by(auto simp add: vector_less_eq_def elim!:allE[where x=j])
- hence "x$j \<in> op $ x ` {i. x $ i \<noteq> 0}" by auto
- hence "x$j \<ge> x$i" unfolding i'(1) xi_def apply(rule_tac Min_le) by auto
- thus False using True Suc(2) j by(auto simp add: vector_less_eq_def elim!:ballE[where x=j]) qed
- thus "x\<in>convex hull ?points" apply(rule_tac hull_subset[unfolded subset_eq, rule_format])
- by(auto simp add: Cart_lambda_beta)
- next let ?y = "\<lambda>j. if x$j = 0 then 0 else (x$j - x$i) / (1 - x$i)"
- case False hence *:"x = x$i *\<^sub>R (\<chi> j. if x$j = 0 then 0 else 1) + (1 - x$i) *\<^sub>R (\<chi> j. ?y j)" unfolding Cart_eq
- by(auto simp add: Cart_lambda_beta vector_add_component vector_smult_component vector_minus_component field_simps)
- { fix j have "x$j \<noteq> 0 \<Longrightarrow> 0 \<le> (x $ j - x $ i) / (1 - x $ i)" "(x $ j - x $ i) / (1 - x $ i) \<le> 1"
- apply(rule_tac divide_nonneg_pos) using i(1)[of j] using False i01
- using Suc(2)[unfolded mem_interval, rule_format, of j] by(auto simp add:field_simps Cart_lambda_beta)
- hence "0 \<le> ?y j \<and> ?y j \<le> 1" by auto }
- moreover have "i\<in>{j. x$j \<noteq> 0} - {j. ((\<chi> j. ?y j)::real^'n) $ j \<noteq> 0}" using i01 by(auto simp add: Cart_lambda_beta)
- hence "{j. x$j \<noteq> 0} \<noteq> {j. ((\<chi> j. ?y j)::real^'n::finite) $ j \<noteq> 0}" by auto
- hence **:"{j. ((\<chi> j. ?y j)::real^'n::finite) $ j \<noteq> 0} \<subset> {j. x$j \<noteq> 0}" apply - apply rule by(auto simp add: Cart_lambda_beta)
- have "card {j. ((\<chi> j. ?y j)::real^'n) $ j \<noteq> 0} \<le> n" using less_le_trans[OF psubset_card_mono[OF _ **] Suc(4)] by auto
- ultimately show ?thesis apply(subst *) apply(rule convex_convex_hull[unfolded convex_def, rule_format])
- apply(rule_tac hull_subset[unfolded subset_eq, rule_format]) defer apply(rule Suc(1))
- unfolding mem_interval using i01 Suc(3) by (auto simp add: Cart_lambda_beta)
- qed qed qed } note * = this
- show ?thesis apply rule defer apply(rule hull_minimal) unfolding subset_eq prefer 3 apply rule
- apply(rule_tac n2="CARD('n)" in *) prefer 3 apply(rule card_mono) using 01 and convex_interval(1) prefer 5 apply - apply rule
- unfolding mem_interval apply rule unfolding mem_Collect_eq apply(erule_tac x=i in allE)
- by(auto simp add: vector_less_eq_def mem_def[of _ convex]) qed
-
-subsection {* And this is a finite set of vertices. *}
-
-lemma unit_cube_convex_hull: obtains s where "finite s" "{0 .. 1::real^'n::finite} = convex hull s"
- apply(rule that[of "{x::real^'n::finite. \<forall>i. x$i=0 \<or> x$i=1}"])
- apply(rule finite_subset[of _ "(\<lambda>s. (\<chi> i. if i\<in>s then 1::real else 0)::real^'n::finite) ` UNIV"])
- prefer 3 apply(rule unit_interval_convex_hull) apply rule unfolding mem_Collect_eq proof-
- fix x::"real^'n" assume as:"\<forall>i. x $ i = 0 \<or> x $ i = 1"
- show "x \<in> (\<lambda>s. \<chi> i. if i \<in> s then 1 else 0) ` UNIV" apply(rule image_eqI[where x="{i. x$i = 1}"])
- unfolding Cart_eq using as by(auto simp add:Cart_lambda_beta) qed auto
-
-subsection {* Hence any cube (could do any nonempty interval). *}
-
-lemma cube_convex_hull:
- assumes "0 < d" obtains s::"(real^'n::finite) set" where "finite s" "{x - (\<chi> i. d) .. x + (\<chi> i. d)} = convex hull s" proof-
- let ?d = "(\<chi> i. d)::real^'n"
- have *:"{x - ?d .. x + ?d} = (\<lambda>y. x - ?d + (2 * d) *\<^sub>R y) ` {0 .. 1}" apply(rule set_ext, rule)
- unfolding image_iff defer apply(erule bexE) proof-
- fix y assume as:"y\<in>{x - ?d .. x + ?d}"
- { fix i::'n have "x $ i \<le> d + y $ i" "y $ i \<le> d + x $ i" using as[unfolded mem_interval, THEN spec[where x=i]]
- by(auto simp add: vector_component)
- hence "1 \<ge> inverse d * (x $ i - y $ i)" "1 \<ge> inverse d * (y $ i - x $ i)"
- apply(rule_tac[!] mult_left_le_imp_le[OF _ assms]) unfolding mult_assoc[THEN sym]
- using assms by(auto simp add: field_simps right_inverse)
- hence "inverse d * (x $ i * 2) \<le> 2 + inverse d * (y $ i * 2)"
- "inverse d * (y $ i * 2) \<le> 2 + inverse d * (x $ i * 2)" by(auto simp add:field_simps) }
- hence "inverse (2 * d) *\<^sub>R (y - (x - ?d)) \<in> {0..1}" unfolding mem_interval using assms
- by(auto simp add: Cart_eq vector_component_simps field_simps)
- thus "\<exists>z\<in>{0..1}. y = x - ?d + (2 * d) *\<^sub>R z" apply- apply(rule_tac x="inverse (2 * d) *\<^sub>R (y - (x - ?d))" in bexI)
- using assms by(auto simp add: Cart_eq vector_less_eq_def Cart_lambda_beta)
- next
- fix y z assume as:"z\<in>{0..1}" "y = x - ?d + (2*d) *\<^sub>R z"
- have "\<And>i. 0 \<le> d * z $ i \<and> d * z $ i \<le> d" using assms as(1)[unfolded mem_interval] apply(erule_tac x=i in allE)
- apply rule apply(rule mult_nonneg_nonneg) prefer 3 apply(rule mult_right_le_one_le)
- using assms by(auto simp add: vector_component_simps Cart_eq)
- thus "y \<in> {x - ?d..x + ?d}" unfolding as(2) mem_interval apply- apply rule using as(1)[unfolded mem_interval]
- apply(erule_tac x=i in allE) using assms by(auto simp add: vector_component_simps Cart_eq) qed
- obtain s where "finite s" "{0..1::real^'n} = convex hull s" using unit_cube_convex_hull by auto
- thus ?thesis apply(rule_tac that[of "(\<lambda>y. x - ?d + (2 * d) *\<^sub>R y)` s"]) unfolding * and convex_hull_affinity by auto qed
-
-subsection {* Bounded convex function on open set is continuous. *}
-
-lemma convex_on_bounded_continuous:
- fixes s :: "(real ^ _) set"
- assumes "open s" "convex_on s f" "\<forall>x\<in>s. abs(f x) \<le> b"
- shows "continuous_on s f"
- apply(rule continuous_at_imp_continuous_on) unfolding continuous_at_real_range proof(rule,rule,rule)
- fix x e assume "x\<in>s" "(0::real) < e"
- def B \<equiv> "abs b + 1"
- have B:"0 < B" "\<And>x. x\<in>s \<Longrightarrow> abs (f x) \<le> B"
- unfolding B_def defer apply(drule assms(3)[rule_format]) by auto
- obtain k where "k>0"and k:"cball x k \<subseteq> s" using assms(1)[unfolded open_contains_cball, THEN bspec[where x=x]] using `x\<in>s` by auto
- show "\<exists>d>0. \<forall>x'. norm (x' - x) < d \<longrightarrow> \<bar>f x' - f x\<bar> < e"
- apply(rule_tac x="min (k / 2) (e / (2 * B) * k)" in exI) apply rule defer proof(rule,rule)
- fix y assume as:"norm (y - x) < min (k / 2) (e / (2 * B) * k)"
- show "\<bar>f y - f x\<bar> < e" proof(cases "y=x")
- case False def t \<equiv> "k / norm (y - x)"
- have "2 < t" "0<t" unfolding t_def using as False and `k>0` by(auto simp add:field_simps)
- have "y\<in>s" apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
- apply(rule order_trans[of _ "2 * norm (x - y)"]) using as by(auto simp add: field_simps norm_minus_commute)
- { def w \<equiv> "x + t *\<^sub>R (y - x)"
- have "w\<in>s" unfolding w_def apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
- unfolding t_def using `k>0` by auto
- have "(1 / t) *\<^sub>R x + - x + ((t - 1) / t) *\<^sub>R x = (1 / t - 1 + (t - 1) / t) *\<^sub>R x" by (auto simp add: algebra_simps)
- also have "\<dots> = 0" using `t>0` by(auto simp add:field_simps)
- finally have w:"(1 / t) *\<^sub>R w + ((t - 1) / t) *\<^sub>R x = y" unfolding w_def using False and `t>0` by (auto simp add: algebra_simps)
- have "2 * B < e * t" unfolding t_def using `0<e` `0<k` `B>0` and as and False by (auto simp add:field_simps)
- hence "(f w - f x) / t < e"
- using B(2)[OF `w\<in>s`] and B(2)[OF `x\<in>s`] using `t>0` by(auto simp add:field_simps)
- hence th1:"f y - f x < e" apply- apply(rule le_less_trans) defer apply assumption
- using assms(2)[unfolded convex_on_def,rule_format,of w x "1/t" "(t - 1)/t", unfolded w]
- using `0<t` `2<t` and `x\<in>s` `w\<in>s` by(auto simp add:field_simps) }
- moreover
- { def w \<equiv> "x - t *\<^sub>R (y - x)"
- have "w\<in>s" unfolding w_def apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
- unfolding t_def using `k>0` by auto
- have "(1 / (1 + t)) *\<^sub>R x + (t / (1 + t)) *\<^sub>R x = (1 / (1 + t) + t / (1 + t)) *\<^sub>R x" by (auto simp add: algebra_simps)
- also have "\<dots>=x" using `t>0` by (auto simp add:field_simps)
- finally have w:"(1 / (1+t)) *\<^sub>R w + (t / (1 + t)) *\<^sub>R y = x" unfolding w_def using False and `t>0` by (auto simp add: algebra_simps)
- have "2 * B < e * t" unfolding t_def using `0<e` `0<k` `B>0` and as and False by (auto simp add:field_simps)
- hence *:"(f w - f y) / t < e" using B(2)[OF `w\<in>s`] and B(2)[OF `y\<in>s`] using `t>0` by(auto simp add:field_simps)
- have "f x \<le> 1 / (1 + t) * f w + (t / (1 + t)) * f y"
- using assms(2)[unfolded convex_on_def,rule_format,of w y "1/(1+t)" "t / (1+t)",unfolded w]
- using `0<t` `2<t` and `y\<in>s` `w\<in>s` by (auto simp add:field_simps)
- also have "\<dots> = (f w + t * f y) / (1 + t)" using `t>0` unfolding real_divide_def by (auto simp add:field_simps)
- also have "\<dots> < e + f y" using `t>0` * `e>0` by(auto simp add:field_simps)
- finally have "f x - f y < e" by auto }
- ultimately show ?thesis by auto
- qed(insert `0<e`, auto)
- qed(insert `0<e` `0<k` `0<B`, auto simp add:field_simps intro!:mult_pos_pos) qed
-
-subsection {* Upper bound on a ball implies upper and lower bounds. *}
-
-lemma convex_bounds_lemma:
- fixes x :: "real ^ _"
- assumes "convex_on (cball x e) f" "\<forall>y \<in> cball x e. f y \<le> b"
- shows "\<forall>y \<in> cball x e. abs(f y) \<le> b + 2 * abs(f x)"
- apply(rule) proof(cases "0 \<le> e") case True
- fix y assume y:"y\<in>cball x e" def z \<equiv> "2 *\<^sub>R x - y"
- have *:"x - (2 *\<^sub>R x - y) = y - x" by vector
- have z:"z\<in>cball x e" using y unfolding z_def mem_cball dist_norm * by(auto simp add: norm_minus_commute)
- have "(1 / 2) *\<^sub>R y + (1 / 2) *\<^sub>R z = x" unfolding z_def by (auto simp add: algebra_simps)
- thus "\<bar>f y\<bar> \<le> b + 2 * \<bar>f x\<bar>" using assms(1)[unfolded convex_on_def,rule_format, OF y z, of "1/2" "1/2"]
- using assms(2)[rule_format,OF y] assms(2)[rule_format,OF z] by(auto simp add:field_simps)
-next case False fix y assume "y\<in>cball x e"
- hence "dist x y < 0" using False unfolding mem_cball not_le by (auto simp del: dist_not_less_zero)
- thus "\<bar>f y\<bar> \<le> b + 2 * \<bar>f x\<bar>" using zero_le_dist[of x y] by auto qed
-
-subsection {* Hence a convex function on an open set is continuous. *}
-
-lemma convex_on_continuous:
- assumes "open (s::(real^'n::finite) set)" "convex_on s f"
- shows "continuous_on s f"
- unfolding continuous_on_eq_continuous_at[OF assms(1)] proof
- note dimge1 = dimindex_ge_1[where 'a='n]
- fix x assume "x\<in>s"
- then obtain e where e:"cball x e \<subseteq> s" "e>0" using assms(1) unfolding open_contains_cball by auto
- def d \<equiv> "e / real CARD('n)"
- have "0 < d" unfolding d_def using `e>0` dimge1 by(rule_tac divide_pos_pos, auto)
- let ?d = "(\<chi> i. d)::real^'n"
- obtain c where c:"finite c" "{x - ?d..x + ?d} = convex hull c" using cube_convex_hull[OF `d>0`, of x] by auto
- have "x\<in>{x - ?d..x + ?d}" using `d>0` unfolding mem_interval by(auto simp add:vector_component_simps)
- hence "c\<noteq>{}" apply(rule_tac ccontr) using c by(auto simp add:convex_hull_empty)
- def k \<equiv> "Max (f ` c)"
- have "convex_on {x - ?d..x + ?d} f" apply(rule convex_on_subset[OF assms(2)])
- apply(rule subset_trans[OF _ e(1)]) unfolding subset_eq mem_cball proof
- fix z assume z:"z\<in>{x - ?d..x + ?d}"
- have e:"e = setsum (\<lambda>i. d) (UNIV::'n set)" unfolding setsum_constant d_def using dimge1
- by (metis card_enum field_simps d_def not_one_le_zero of_nat_le_iff real_eq_of_nat real_of_nat_1)
- show "dist x z \<le> e" unfolding dist_norm e apply(rule_tac order_trans[OF norm_le_l1], rule setsum_mono)
- using z[unfolded mem_interval] apply(erule_tac x=i in allE) by(auto simp add:field_simps vector_component_simps) qed
- hence k:"\<forall>y\<in>{x - ?d..x + ?d}. f y \<le> k" unfolding c(2) apply(rule_tac convex_on_convex_hull_bound) apply assumption
- unfolding k_def apply(rule, rule Max_ge) using c(1) by auto
- have "d \<le> e" unfolding d_def apply(rule mult_imp_div_pos_le) using `e>0` dimge1 unfolding mult_le_cancel_left1 using real_dimindex_ge_1 by auto
- hence dsube:"cball x d \<subseteq> cball x e" unfolding subset_eq Ball_def mem_cball by auto
- have conv:"convex_on (cball x d) f" apply(rule convex_on_subset, rule convex_on_subset[OF assms(2)]) apply(rule e(1)) using dsube by auto
- hence "\<forall>y\<in>cball x d. abs (f y) \<le> k + 2 * abs (f x)" apply(rule_tac convex_bounds_lemma) apply assumption proof
- fix y assume y:"y\<in>cball x d"
- { fix i::'n have "x $ i - d \<le> y $ i" "y $ i \<le> x $ i + d"
- using order_trans[OF component_le_norm y[unfolded mem_cball dist_norm], of i] by(auto simp add: vector_component) }
- thus "f y \<le> k" apply(rule_tac k[rule_format]) unfolding mem_cball mem_interval dist_norm
- by(auto simp add: vector_component_simps) qed
- hence "continuous_on (ball x d) f" apply(rule_tac convex_on_bounded_continuous)
- apply(rule open_ball, rule convex_on_subset[OF conv], rule ball_subset_cball)
- apply force
- done
- thus "continuous (at x) f" unfolding continuous_on_eq_continuous_at[OF open_ball]
- using `d>0` by auto
-qed
-
-subsection {* Line segments, Starlike Sets, etc.*}
-
-(* Use the same overloading tricks as for intervals, so that
- segment[a,b] is closed and segment(a,b) is open relative to affine hull. *)
-
-definition
- midpoint :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 'n" where
- "midpoint a b = (inverse (2::real)) *\<^sub>R (a + b)"
-
-definition
- open_segment :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> (real ^ 'n) set" where
- "open_segment a b = {(1 - u) *\<^sub>R a + u *\<^sub>R b | u::real. 0 < u \<and> u < 1}"
-
-definition
- closed_segment :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> (real ^ 'n) set" where
- "closed_segment a b = {(1 - u) *\<^sub>R a + u *\<^sub>R b | u::real. 0 \<le> u \<and> u \<le> 1}"
-
-definition "between = (\<lambda> (a,b). closed_segment a b)"
-
-lemmas segment = open_segment_def closed_segment_def
-
-definition "starlike s \<longleftrightarrow> (\<exists>a\<in>s. \<forall>x\<in>s. closed_segment a x \<subseteq> s)"
-
-lemma midpoint_refl: "midpoint x x = x"
- unfolding midpoint_def unfolding scaleR_right_distrib unfolding scaleR_left_distrib[THEN sym] by auto
-
-lemma midpoint_sym: "midpoint a b = midpoint b a" unfolding midpoint_def by (auto simp add: scaleR_right_distrib)
-
-lemma dist_midpoint:
- "dist a (midpoint a b) = (dist a b) / 2" (is ?t1)
- "dist b (midpoint a b) = (dist a b) / 2" (is ?t2)
- "dist (midpoint a b) a = (dist a b) / 2" (is ?t3)
- "dist (midpoint a b) b = (dist a b) / 2" (is ?t4)
-proof-
- have *: "\<And>x y::real^'n::finite. 2 *\<^sub>R x = - y \<Longrightarrow> norm x = (norm y) / 2" unfolding equation_minus_iff by auto
- have **:"\<And>x y::real^'n::finite. 2 *\<^sub>R x = y \<Longrightarrow> norm x = (norm y) / 2" by auto
- note scaleR_right_distrib [simp]
- show ?t1 unfolding midpoint_def dist_norm apply (rule **) by(auto,vector)
- show ?t2 unfolding midpoint_def dist_norm apply (rule *) by(auto,vector)
- show ?t3 unfolding midpoint_def dist_norm apply (rule *) by(auto,vector)
- show ?t4 unfolding midpoint_def dist_norm apply (rule **) by(auto,vector) qed
-
-lemma midpoint_eq_endpoint:
- "midpoint a b = a \<longleftrightarrow> a = (b::real^'n::finite)"
- "midpoint a b = b \<longleftrightarrow> a = b"
- unfolding dist_eq_0_iff[where 'a="real^'n", THEN sym] dist_midpoint by auto
-
-lemma convex_contains_segment:
- "convex s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. closed_segment a b \<subseteq> s)"
- unfolding convex_alt closed_segment_def by auto
-
-lemma convex_imp_starlike:
- "convex s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> starlike s"
- unfolding convex_contains_segment starlike_def by auto
-
-lemma segment_convex_hull:
- "closed_segment a b = convex hull {a,b}" proof-
- have *:"\<And>x. {x} \<noteq> {}" by auto
- have **:"\<And>u v. u + v = 1 \<longleftrightarrow> u = 1 - (v::real)" by auto
- show ?thesis unfolding segment convex_hull_insert[OF *] convex_hull_singleton apply(rule set_ext)
- unfolding mem_Collect_eq apply(rule,erule exE)
- apply(rule_tac x="1 - u" in exI) apply rule defer apply(rule_tac x=u in exI) defer
- apply(erule exE, (erule conjE)?)+ apply(rule_tac x="1 - u" in exI) unfolding ** by auto qed
-
-lemma convex_segment: "convex (closed_segment a b)"
- unfolding segment_convex_hull by(rule convex_convex_hull)
-
-lemma ends_in_segment: "a \<in> closed_segment a b" "b \<in> closed_segment a b"
- unfolding segment_convex_hull apply(rule_tac[!] hull_subset[unfolded subset_eq, rule_format]) by auto
-
-lemma segment_furthest_le:
- assumes "x \<in> closed_segment a b" shows "norm(y - x) \<le> norm(y - a) \<or> norm(y - x) \<le> norm(y - b)" proof-
- obtain z where "z\<in>{a, b}" "norm (x - y) \<le> norm (z - y)" using simplex_furthest_le[of "{a, b}" y]
- using assms[unfolded segment_convex_hull] by auto
- thus ?thesis by(auto simp add:norm_minus_commute) qed
-
-lemma segment_bound:
- assumes "x \<in> closed_segment a b"
- shows "norm(x - a) \<le> norm(b - a)" "norm(x - b) \<le> norm(b - a)"
- using segment_furthest_le[OF assms, of a]
- using segment_furthest_le[OF assms, of b]
- by (auto simp add:norm_minus_commute)
-
-lemma segment_refl:"closed_segment a a = {a}" unfolding segment by (auto simp add: algebra_simps)
-
-lemma between_mem_segment: "between (a,b) x \<longleftrightarrow> x \<in> closed_segment a b"
- unfolding between_def mem_def by auto
-
-lemma between:"between (a,b) (x::real^'n::finite) \<longleftrightarrow> dist a b = (dist a x) + (dist x b)"
-proof(cases "a = b")
- case True thus ?thesis unfolding between_def split_conv mem_def[of x, symmetric]
- by(auto simp add:segment_refl dist_commute) next
- case False hence Fal:"norm (a - b) \<noteq> 0" and Fal2: "norm (a - b) > 0" by auto
- have *:"\<And>u. a - ((1 - u) *\<^sub>R a + u *\<^sub>R b) = u *\<^sub>R (a - b)" by (auto simp add: algebra_simps)
- show ?thesis unfolding between_def split_conv mem_def[of x, symmetric] closed_segment_def mem_Collect_eq
- apply rule apply(erule exE, (erule conjE)+) apply(subst dist_triangle_eq) proof-
- fix u assume as:"x = (1 - u) *\<^sub>R a + u *\<^sub>R b" "0 \<le> u" "u \<le> 1"
- hence *:"a - x = u *\<^sub>R (a - b)" "x - b = (1 - u) *\<^sub>R (a - b)"
- unfolding as(1) by(auto simp add:algebra_simps)
- show "norm (a - x) *\<^sub>R (x - b) = norm (x - b) *\<^sub>R (a - x)"
- unfolding norm_minus_commute[of x a] * Cart_eq using as(2,3)
- by(auto simp add: vector_component_simps field_simps)
- next assume as:"dist a b = dist a x + dist x b"
- have "norm (a - x) / norm (a - b) \<le> 1" unfolding divide_le_eq_1_pos[OF Fal2] unfolding as[unfolded dist_norm] norm_ge_zero by auto
- thus "\<exists>u. x = (1 - u) *\<^sub>R a + u *\<^sub>R b \<and> 0 \<le> u \<and> u \<le> 1" apply(rule_tac x="dist a x / dist a b" in exI)
- unfolding dist_norm Cart_eq apply- apply rule defer apply(rule, rule divide_nonneg_pos) prefer 4 proof rule
- fix i::'n have "((1 - norm (a - x) / norm (a - b)) *\<^sub>R a + (norm (a - x) / norm (a - b)) *\<^sub>R b) $ i =
- ((norm (a - b) - norm (a - x)) * (a $ i) + norm (a - x) * (b $ i)) / norm (a - b)"
- using Fal by(auto simp add:vector_component_simps field_simps)
- also have "\<dots> = x$i" apply(rule divide_eq_imp[OF Fal])
- unfolding as[unfolded dist_norm] using as[unfolded dist_triangle_eq Cart_eq,rule_format, of i]
- by(auto simp add:field_simps vector_component_simps)
- finally show "x $ i = ((1 - norm (a - x) / norm (a - b)) *\<^sub>R a + (norm (a - x) / norm (a - b)) *\<^sub>R b) $ i" by auto
- qed(insert Fal2, auto) qed qed
-
-lemma between_midpoint: fixes a::"real^'n::finite" shows
- "between (a,b) (midpoint a b)" (is ?t1)
- "between (b,a) (midpoint a b)" (is ?t2)
-proof- have *:"\<And>x y z. x = (1/2::real) *\<^sub>R z \<Longrightarrow> y = (1/2) *\<^sub>R z \<Longrightarrow> norm z = norm x + norm y" by auto
- show ?t1 ?t2 unfolding between midpoint_def dist_norm apply(rule_tac[!] *)
- by(auto simp add:field_simps Cart_eq vector_component_simps) qed
-
-lemma between_mem_convex_hull:
- "between (a,b) x \<longleftrightarrow> x \<in> convex hull {a,b}"
- unfolding between_mem_segment segment_convex_hull ..
-
-subsection {* Shrinking towards the interior of a convex set. *}
-
-lemma mem_interior_convex_shrink:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "c \<in> interior s" "x \<in> s" "0 < e" "e \<le> 1"
- shows "x - e *\<^sub>R (x - c) \<in> interior s"
-proof- obtain d where "d>0" and d:"ball c d \<subseteq> s" using assms(2) unfolding mem_interior by auto
- show ?thesis unfolding mem_interior apply(rule_tac x="e*d" in exI)
- apply(rule) defer unfolding subset_eq Ball_def mem_ball proof(rule,rule)
- fix y assume as:"dist (x - e *\<^sub>R (x - c)) y < e * d"
- have *:"y = (1 - (1 - e)) *\<^sub>R ((1 / e) *\<^sub>R y - ((1 - e) / e) *\<^sub>R x) + (1 - e) *\<^sub>R x" using `e>0` by (auto simp add: scaleR_left_diff_distrib scaleR_right_diff_distrib)
- have "dist c ((1 / e) *\<^sub>R y - ((1 - e) / e) *\<^sub>R x) = abs(1/e) * norm (e *\<^sub>R c - y + (1 - e) *\<^sub>R x)"
- unfolding dist_norm unfolding norm_scaleR[THEN sym] apply(rule norm_eqI) using `e>0`
- by(auto simp add:vector_component_simps Cart_eq field_simps)
- also have "\<dots> = abs(1/e) * norm (x - e *\<^sub>R (x - c) - y)" by(auto intro!:norm_eqI simp add: algebra_simps)
- also have "\<dots> < d" using as[unfolded dist_norm] and `e>0`
- by(auto simp add:pos_divide_less_eq[OF `e>0`] real_mult_commute)
- finally show "y \<in> s" apply(subst *) apply(rule assms(1)[unfolded convex_alt,rule_format])
- apply(rule d[unfolded subset_eq,rule_format]) unfolding mem_ball using assms(3-5) by auto
- qed(rule mult_pos_pos, insert `e>0` `d>0`, auto) qed
-
-lemma mem_interior_closure_convex_shrink:
- fixes s :: "(real ^ _) set"
- assumes "convex s" "c \<in> interior s" "x \<in> closure s" "0 < e" "e \<le> 1"
- shows "x - e *\<^sub>R (x - c) \<in> interior s"
-proof- obtain d where "d>0" and d:"ball c d \<subseteq> s" using assms(2) unfolding mem_interior by auto
- have "\<exists>y\<in>s. norm (y - x) * (1 - e) < e * d" proof(cases "x\<in>s")
- case True thus ?thesis using `e>0` `d>0` by(rule_tac bexI[where x=x], auto intro!: mult_pos_pos) next
- case False hence x:"x islimpt s" using assms(3)[unfolded closure_def] by auto
- show ?thesis proof(cases "e=1")
- case True obtain y where "y\<in>s" "y \<noteq> x" "dist y x < 1"
- using x[unfolded islimpt_approachable,THEN spec[where x=1]] by auto
- thus ?thesis apply(rule_tac x=y in bexI) unfolding True using `d>0` by auto next
- case False hence "0 < e * d / (1 - e)" and *:"1 - e > 0"
- using `e\<le>1` `e>0` `d>0` by(auto intro!:mult_pos_pos divide_pos_pos)
- then obtain y where "y\<in>s" "y \<noteq> x" "dist y x < e * d / (1 - e)"
- using x[unfolded islimpt_approachable,THEN spec[where x="e*d / (1 - e)"]] by auto
- thus ?thesis apply(rule_tac x=y in bexI) unfolding dist_norm using pos_less_divide_eq[OF *] by auto qed qed
- then obtain y where "y\<in>s" and y:"norm (y - x) * (1 - e) < e * d" by auto
- def z \<equiv> "c + ((1 - e) / e) *\<^sub>R (x - y)"
- have *:"x - e *\<^sub>R (x - c) = y - e *\<^sub>R (y - z)" unfolding z_def using `e>0` by (auto simp add: scaleR_right_diff_distrib scaleR_right_distrib scaleR_left_diff_distrib)
- have "z\<in>interior s" apply(rule subset_interior[OF d,unfolded subset_eq,rule_format])
- unfolding interior_open[OF open_ball] mem_ball z_def dist_norm using y and assms(4,5)
- by(auto simp add:field_simps norm_minus_commute)
- thus ?thesis unfolding * apply - apply(rule mem_interior_convex_shrink)
- using assms(1,4-5) `y\<in>s` by auto qed
-
-subsection {* Some obvious but surprisingly hard simplex lemmas. *}
-
-lemma simplex:
- assumes "finite s" "0 \<notin> s"
- shows "convex hull (insert 0 s) = { y. (\<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s \<le> 1 \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y)}"
- unfolding convex_hull_finite[OF finite.insertI[OF assms(1)]] apply(rule set_ext, rule) unfolding mem_Collect_eq
- apply(erule_tac[!] exE) apply(erule_tac[!] conjE)+ unfolding setsum_clauses(2)[OF assms(1)]
- apply(rule_tac x=u in exI) defer apply(rule_tac x="\<lambda>x. if x = 0 then 1 - setsum u s else u x" in exI) using assms(2)
- unfolding if_smult and setsum_delta_notmem[OF assms(2)] by auto
-
-lemma std_simplex:
- "convex hull (insert 0 { basis i | i. i\<in>UNIV}) =
- {x::real^'n::finite . (\<forall>i. 0 \<le> x$i) \<and> setsum (\<lambda>i. x$i) UNIV \<le> 1 }" (is "convex hull (insert 0 ?p) = ?s")
-proof- let ?D = "UNIV::'n set"
- have "0\<notin>?p" by(auto simp add: basis_nonzero)
- have "{(basis i)::real^'n |i. i \<in> ?D} = basis ` ?D" by auto
- note sumbas = this setsum_reindex[OF basis_inj, unfolded o_def]
- show ?thesis unfolding simplex[OF finite_stdbasis `0\<notin>?p`] apply(rule set_ext) unfolding mem_Collect_eq apply rule
- apply(erule exE, (erule conjE)+) apply(erule_tac[2] conjE)+ proof-
- fix x::"real^'n" and u assume as: "\<forall>x\<in>{basis i |i. i \<in>?D}. 0 \<le> u x" "setsum u {basis i |i. i \<in> ?D} \<le> 1" "(\<Sum>x\<in>{basis i |i. i \<in>?D}. u x *\<^sub>R x) = x"
- have *:"\<forall>i. u (basis i) = x$i" using as(3) unfolding sumbas and basis_expansion_unique [where 'a=real, unfolded smult_conv_scaleR] by auto
- hence **:"setsum u {basis i |i. i \<in> ?D} = setsum (op $ x) ?D" unfolding sumbas by(rule_tac setsum_cong, auto)
- show " (\<forall>i. 0 \<le> x $ i) \<and> setsum (op $ x) ?D \<le> 1" apply - proof(rule,rule)
- fix i::'n show "0 \<le> x$i" unfolding *[rule_format,of i,THEN sym] apply(rule_tac as(1)[rule_format]) by auto
- qed(insert as(2)[unfolded **], auto)
- next fix x::"real^'n" assume as:"\<forall>i. 0 \<le> x $ i" "setsum (op $ x) ?D \<le> 1"
- show "\<exists>u. (\<forall>x\<in>{basis i |i. i \<in> ?D}. 0 \<le> u x) \<and> setsum u {basis i |i. i \<in> ?D} \<le> 1 \<and> (\<Sum>x\<in>{basis i |i. i \<in> ?D}. u x *\<^sub>R x) = x"
- apply(rule_tac x="\<lambda>y. inner y x" in exI) apply(rule,rule) unfolding mem_Collect_eq apply(erule exE) using as(1) apply(erule_tac x=i in allE)
- unfolding sumbas using as(2) and basis_expansion_unique [where 'a=real, unfolded smult_conv_scaleR] by(auto simp add:inner_basis) qed qed
-
-lemma interior_std_simplex:
- "interior (convex hull (insert 0 { basis i| i. i\<in>UNIV})) =
- {x::real^'n::finite. (\<forall>i. 0 < x$i) \<and> setsum (\<lambda>i. x$i) UNIV < 1 }"
- apply(rule set_ext) unfolding mem_interior std_simplex unfolding subset_eq mem_Collect_eq Ball_def mem_ball
- unfolding Ball_def[symmetric] apply rule apply(erule exE, (erule conjE)+) defer apply(erule conjE) proof-
- fix x::"real^'n" and e assume "0<e" and as:"\<forall>xa. dist x xa < e \<longrightarrow> (\<forall>x. 0 \<le> xa $ x) \<and> setsum (op $ xa) UNIV \<le> 1"
- show "(\<forall>xa. 0 < x $ xa) \<and> setsum (op $ x) UNIV < 1" apply(rule,rule) proof-
- fix i::'n show "0 < x $ i" using as[THEN spec[where x="x - (e / 2) *\<^sub>R basis i"]] and `e>0`
- unfolding dist_norm by(auto simp add: norm_basis vector_component_simps basis_component elim:allE[where x=i])
- next guess a using UNIV_witness[where 'a='n] ..
- have **:"dist x (x + (e / 2) *\<^sub>R basis a) < e" using `e>0` and norm_basis[of a]
- unfolding dist_norm by(auto simp add: vector_component_simps basis_component intro!: mult_strict_left_mono_comm)
- have "\<And>i. (x + (e / 2) *\<^sub>R basis a) $ i = x$i + (if i = a then e/2 else 0)" by(auto simp add:vector_component_simps)
- hence *:"setsum (op $ (x + (e / 2) *\<^sub>R basis a)) UNIV = setsum (\<lambda>i. x$i + (if a = i then e/2 else 0)) UNIV" by(rule_tac setsum_cong, auto)
- have "setsum (op $ x) UNIV < setsum (op $ (x + (e / 2) *\<^sub>R basis a)) UNIV" unfolding * setsum_addf
- using `0<e` dimindex_ge_1 by(auto simp add: setsum_delta')
- also have "\<dots> \<le> 1" using ** apply(drule_tac as[rule_format]) by auto
- finally show "setsum (op $ x) UNIV < 1" by auto qed
-next
- fix x::"real^'n::finite" assume as:"\<forall>i. 0 < x $ i" "setsum (op $ x) UNIV < 1"
- guess a using UNIV_witness[where 'a='b] ..
- let ?d = "(1 - setsum (op $ x) UNIV) / real (CARD('n))"
- have "Min ((op $ x) ` UNIV) > 0" apply(rule Min_grI) using as(1) dimindex_ge_1 by auto
- moreover have"?d > 0" apply(rule divide_pos_pos) using as(2) using dimindex_ge_1 by(auto simp add: Suc_le_eq)
- ultimately show "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> (\<forall>i. 0 \<le> y $ i) \<and> setsum (op $ y) UNIV \<le> 1"
- apply(rule_tac x="min (Min ((op $ x) ` UNIV)) ?D" in exI) apply rule defer apply(rule,rule) proof-
- fix y assume y:"dist x y < min (Min (op $ x ` UNIV)) ?d"
- have "setsum (op $ y) UNIV \<le> setsum (\<lambda>i. x$i + ?d) UNIV" proof(rule setsum_mono)
- fix i::'n have "abs (y$i - x$i) < ?d" apply(rule le_less_trans) using component_le_norm[of "y - x" i]
- using y[unfolded min_less_iff_conj dist_norm, THEN conjunct2] by(auto simp add:vector_component_simps norm_minus_commute)
- thus "y $ i \<le> x $ i + ?d" by auto qed
- also have "\<dots> \<le> 1" unfolding setsum_addf setsum_constant card_enum real_eq_of_nat using dimindex_ge_1 by(auto simp add: Suc_le_eq)
- finally show "(\<forall>i. 0 \<le> y $ i) \<and> setsum (op $ y) UNIV \<le> 1" apply- proof(rule,rule)
- fix i::'n have "norm (x - y) < x$i" using y[unfolded min_less_iff_conj dist_norm, THEN conjunct1]
- using Min_gr_iff[of "op $ x ` dimset x"] dimindex_ge_1 by auto
- thus "0 \<le> y$i" using component_le_norm[of "x - y" i] and as(1)[rule_format, of i] by(auto simp add: vector_component_simps)
- qed auto qed auto qed
-
-lemma interior_std_simplex_nonempty: obtains a::"real^'n::finite" where
- "a \<in> interior(convex hull (insert 0 {basis i | i . i \<in> UNIV}))" proof-
- let ?D = "UNIV::'n set" let ?a = "setsum (\<lambda>b::real^'n. inverse (2 * real CARD('n)) *\<^sub>R b) {(basis i) | i. i \<in> ?D}"
- have *:"{basis i :: real ^ 'n | i. i \<in> ?D} = basis ` ?D" by auto
- { fix i have "?a $ i = inverse (2 * real CARD('n))"
- unfolding setsum_component vector_smult_component and * and setsum_reindex[OF basis_inj] and o_def
- apply(rule trans[of _ "setsum (\<lambda>j. if i = j then inverse (2 * real CARD('n)) else 0) ?D"]) apply(rule setsum_cong2)
- unfolding setsum_delta'[OF finite_UNIV[where 'a='n]] and real_dimindex_ge_1[where 'n='n] by(auto simp add: basis_component[of i]) }
- note ** = this
- show ?thesis apply(rule that[of ?a]) unfolding interior_std_simplex mem_Collect_eq proof(rule,rule)
- fix i::'n show "0 < ?a $ i" unfolding ** using dimindex_ge_1 by(auto simp add: Suc_le_eq) next
- have "setsum (op $ ?a) ?D = setsum (\<lambda>i. inverse (2 * real CARD('n))) ?D" by(rule setsum_cong2, rule **)
- also have "\<dots> < 1" unfolding setsum_constant card_enum real_eq_of_nat real_divide_def[THEN sym] by (auto simp add:field_simps)
- finally show "setsum (op $ ?a) ?D < 1" by auto qed qed
-
-subsection {* Paths. *}
-
-definition "path (g::real^1 \<Rightarrow> real^'n::finite) \<longleftrightarrow> continuous_on {0 .. 1} g"
-
-definition "pathstart (g::real^1 \<Rightarrow> real^'n) = g 0"
-
-definition "pathfinish (g::real^1 \<Rightarrow> real^'n) = g 1"
-
-definition "path_image (g::real^1 \<Rightarrow> real^'n) = g ` {0 .. 1}"
-
-definition "reversepath (g::real^1 \<Rightarrow> real^'n) = (\<lambda>x. g(1 - x))"
-
-definition joinpaths:: "(real^1 \<Rightarrow> real^'n) \<Rightarrow> (real^1 \<Rightarrow> real^'n) \<Rightarrow> (real^1 \<Rightarrow> real^'n)" (infixr "+++" 75)
- where "joinpaths g1 g2 = (\<lambda>x. if dest_vec1 x \<le> ((1 / 2)::real) then g1 (2 *\<^sub>R x) else g2(2 *\<^sub>R x - 1))"
-definition "simple_path (g::real^1 \<Rightarrow> real^'n) \<longleftrightarrow>
- (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0)"
-
-definition "injective_path (g::real^1 \<Rightarrow> real^'n) \<longleftrightarrow>
- (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y)"
-
-subsection {* Some lemmas about these concepts. *}
-
-lemma injective_imp_simple_path:
- "injective_path g \<Longrightarrow> simple_path g"
- unfolding injective_path_def simple_path_def by auto
-
-lemma path_image_nonempty: "path_image g \<noteq> {}"
- unfolding path_image_def image_is_empty interval_eq_empty by auto
-
-lemma pathstart_in_path_image[intro]: "(pathstart g) \<in> path_image g"
- unfolding pathstart_def path_image_def apply(rule imageI)
- unfolding mem_interval_1 vec_1[THEN sym] dest_vec1_vec by auto
-
-lemma pathfinish_in_path_image[intro]: "(pathfinish g) \<in> path_image g"
- unfolding pathfinish_def path_image_def apply(rule imageI)
- unfolding mem_interval_1 vec_1[THEN sym] dest_vec1_vec by auto
-
-lemma connected_path_image[intro]: "path g \<Longrightarrow> connected(path_image g)"
- unfolding path_def path_image_def apply(rule connected_continuous_image, assumption)
- by(rule convex_connected, rule convex_interval)
-
-lemma compact_path_image[intro]: "path g \<Longrightarrow> compact(path_image g)"
- unfolding path_def path_image_def apply(rule compact_continuous_image, assumption)
- by(rule compact_interval)
-
-lemma reversepath_reversepath[simp]: "reversepath(reversepath g) = g"
- unfolding reversepath_def by auto
-
-lemma pathstart_reversepath[simp]: "pathstart(reversepath g) = pathfinish g"
- unfolding pathstart_def reversepath_def pathfinish_def by auto
-
-lemma pathfinish_reversepath[simp]: "pathfinish(reversepath g) = pathstart g"
- unfolding pathstart_def reversepath_def pathfinish_def by auto
-
-lemma pathstart_join[simp]: "pathstart(g1 +++ g2) = pathstart g1"
- unfolding pathstart_def joinpaths_def pathfinish_def by auto
-
-lemma pathfinish_join[simp]:"pathfinish(g1 +++ g2) = pathfinish g2" proof-
- have "2 *\<^sub>R 1 - 1 = (1::real^1)" unfolding Cart_eq by(auto simp add:vector_component_simps)
- thus ?thesis unfolding pathstart_def joinpaths_def pathfinish_def
- unfolding vec_1[THEN sym] dest_vec1_vec by auto qed
-
-lemma path_image_reversepath[simp]: "path_image(reversepath g) = path_image g" proof-
- have *:"\<And>g. path_image(reversepath g) \<subseteq> path_image g"
- unfolding path_image_def subset_eq reversepath_def Ball_def image_iff apply(rule,rule,erule bexE)
- apply(rule_tac x="1 - xa" in bexI) by(auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
- show ?thesis using *[of g] *[of "reversepath g"] unfolding reversepath_reversepath by auto qed
-
-lemma path_reversepath[simp]: "path(reversepath g) \<longleftrightarrow> path g" proof-
- have *:"\<And>g. path g \<Longrightarrow> path(reversepath g)" unfolding path_def reversepath_def
- apply(rule continuous_on_compose[unfolded o_def, of _ "\<lambda>x. 1 - x"])
- apply(rule continuous_on_sub, rule continuous_on_const, rule continuous_on_id)
- apply(rule continuous_on_subset[of "{0..1}"], assumption)
- by (auto, auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
- show ?thesis using *[of g] *[of "reversepath g"] unfolding reversepath_reversepath by auto qed
-
-lemmas reversepath_simps = path_reversepath path_image_reversepath pathstart_reversepath pathfinish_reversepath
-
-lemma path_join[simp]: assumes "pathfinish g1 = pathstart g2" shows "path (g1 +++ g2) \<longleftrightarrow> path g1 \<and> path g2"
- unfolding path_def pathfinish_def pathstart_def apply rule defer apply(erule conjE) proof-
- assume as:"continuous_on {0..1} (g1 +++ g2)"
- have *:"g1 = (\<lambda>x. g1 (2 *\<^sub>R x)) \<circ> (\<lambda>x. (1/2) *\<^sub>R x)"
- "g2 = (\<lambda>x. g2 (2 *\<^sub>R x - 1)) \<circ> (\<lambda>x. (1/2) *\<^sub>R (x + 1))" unfolding o_def by auto
- have "op *\<^sub>R (1 / 2) ` {0::real^1..1} \<subseteq> {0..1}" "(\<lambda>x. (1 / 2) *\<^sub>R (x + 1)) ` {(0::real^1)..1} \<subseteq> {0..1}"
- unfolding image_smult_interval by (auto, auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
- thus "continuous_on {0..1} g1 \<and> continuous_on {0..1} g2" apply -apply rule
- apply(subst *) defer apply(subst *) apply (rule_tac[!] continuous_on_compose)
- apply (rule continuous_on_cmul, rule continuous_on_add, rule continuous_on_id, rule continuous_on_const) defer
- apply (rule continuous_on_cmul, rule continuous_on_id) apply(rule_tac[!] continuous_on_eq[of _ "g1 +++ g2"]) defer prefer 3
- apply(rule_tac[1-2] continuous_on_subset[of "{0 .. 1}"]) apply(rule as, assumption, rule as, assumption)
- apply(rule) defer apply rule proof-
- fix x assume "x \<in> op *\<^sub>R (1 / 2) ` {0::real^1..1}"
- hence "dest_vec1 x \<le> 1 / 2" unfolding image_iff by(auto simp add: vector_component_simps)
- thus "(g1 +++ g2) x = g1 (2 *\<^sub>R x)" unfolding joinpaths_def by auto next
- fix x assume "x \<in> (\<lambda>x. (1 / 2) *\<^sub>R (x + 1)) ` {0::real^1..1}"
- hence "dest_vec1 x \<ge> 1 / 2" unfolding image_iff by(auto simp add: vector_component_simps)
- thus "(g1 +++ g2) x = g2 (2 *\<^sub>R x - 1)" proof(cases "dest_vec1 x = 1 / 2")
- case True hence "x = (1/2) *\<^sub>R 1" unfolding Cart_eq by(auto simp add: forall_1 vector_component_simps)
- thus ?thesis unfolding joinpaths_def using assms[unfolded pathstart_def pathfinish_def] by auto
- qed (auto simp add:le_less joinpaths_def) qed
-next assume as:"continuous_on {0..1} g1" "continuous_on {0..1} g2"
- have *:"{0 .. 1::real^1} = {0.. (1/2)*\<^sub>R 1} \<union> {(1/2) *\<^sub>R 1 .. 1}" by(auto simp add: vector_component_simps)
- have **:"op *\<^sub>R 2 ` {0..(1 / 2) *\<^sub>R 1} = {0..1::real^1}" apply(rule set_ext, rule) unfolding image_iff
- defer apply(rule_tac x="(1/2)*\<^sub>R x" in bexI) by(auto simp add: vector_component_simps)
- have ***:"(\<lambda>x. 2 *\<^sub>R x - 1) ` {(1 / 2) *\<^sub>R 1..1} = {0..1::real^1}"
- unfolding image_affinity_interval[of _ "- 1", unfolded diff_def[symmetric]] and interval_eq_empty_1
- by(auto simp add: vector_component_simps)
- have ****:"\<And>x::real^1. x $ 1 * 2 = 1 \<longleftrightarrow> x = (1/2) *\<^sub>R 1" unfolding Cart_eq by(auto simp add: forall_1 vector_component_simps)
- show "continuous_on {0..1} (g1 +++ g2)" unfolding * apply(rule continuous_on_union) apply(rule closed_interval)+ proof-
- show "continuous_on {0..(1 / 2) *\<^sub>R 1} (g1 +++ g2)" apply(rule continuous_on_eq[of _ "\<lambda>x. g1 (2 *\<^sub>R x)"]) defer
- unfolding o_def[THEN sym] apply(rule continuous_on_compose) apply(rule continuous_on_cmul, rule continuous_on_id)
- unfolding ** apply(rule as(1)) unfolding joinpaths_def by(auto simp add: vector_component_simps) next
- show "continuous_on {(1/2)*\<^sub>R1..1} (g1 +++ g2)" apply(rule continuous_on_eq[of _ "g2 \<circ> (\<lambda>x. 2 *\<^sub>R x - 1)"]) defer
- apply(rule continuous_on_compose) apply(rule continuous_on_sub, rule continuous_on_cmul, rule continuous_on_id, rule continuous_on_const)
- unfolding *** o_def joinpaths_def apply(rule as(2)) using assms[unfolded pathstart_def pathfinish_def]
- by(auto simp add: vector_component_simps ****) qed qed
-
-lemma path_image_join_subset: "path_image(g1 +++ g2) \<subseteq> (path_image g1 \<union> path_image g2)" proof
- fix x assume "x \<in> path_image (g1 +++ g2)"
- then obtain y where y:"y\<in>{0..1}" "x = (if dest_vec1 y \<le> 1 / 2 then g1 (2 *\<^sub>R y) else g2 (2 *\<^sub>R y - 1))"
- unfolding path_image_def image_iff joinpaths_def by auto
- thus "x \<in> path_image g1 \<union> path_image g2" apply(cases "dest_vec1 y \<le> 1/2")
- apply(rule_tac UnI1) defer apply(rule_tac UnI2) unfolding y(2) path_image_def using y(1)
- by(auto intro!: imageI simp add: vector_component_simps) qed
-
-lemma subset_path_image_join:
- assumes "path_image g1 \<subseteq> s" "path_image g2 \<subseteq> s" shows "path_image(g1 +++ g2) \<subseteq> s"
- using path_image_join_subset[of g1 g2] and assms by auto
-
-lemma path_image_join:
- assumes "path g1" "path g2" "pathfinish g1 = pathstart g2"
- shows "path_image(g1 +++ g2) = (path_image g1) \<union> (path_image g2)"
-apply(rule, rule path_image_join_subset, rule) unfolding Un_iff proof(erule disjE)
- fix x assume "x \<in> path_image g1"
- then obtain y where y:"y\<in>{0..1}" "x = g1 y" unfolding path_image_def image_iff by auto
- thus "x \<in> path_image (g1 +++ g2)" unfolding joinpaths_def path_image_def image_iff
- apply(rule_tac x="(1/2) *\<^sub>R y" in bexI) by(auto simp add: vector_component_simps) next
- fix x assume "x \<in> path_image g2"
- then obtain y where y:"y\<in>{0..1}" "x = g2 y" unfolding path_image_def image_iff by auto
- moreover have *:"y $ 1 = 0 \<Longrightarrow> y = 0" unfolding Cart_eq by auto
- ultimately show "x \<in> path_image (g1 +++ g2)" unfolding joinpaths_def path_image_def image_iff
- apply(rule_tac x="(1/2) *\<^sub>R (y + 1)" in bexI) using assms(3)[unfolded pathfinish_def pathstart_def]
- by(auto simp add: vector_component_simps) qed
-
-lemma not_in_path_image_join:
- assumes "x \<notin> path_image g1" "x \<notin> path_image g2" shows "x \<notin> path_image(g1 +++ g2)"
- using assms and path_image_join_subset[of g1 g2] by auto
-
-lemma simple_path_reversepath: assumes "simple_path g" shows "simple_path (reversepath g)"
- using assms unfolding simple_path_def reversepath_def apply- apply(rule ballI)+
- apply(erule_tac x="1-x" in ballE, erule_tac x="1-y" in ballE)
- unfolding mem_interval_1 by(auto simp add:vector_component_simps)
-
-lemma dest_vec1_scaleR [simp]:
- "dest_vec1 (scaleR a x) = scaleR a (dest_vec1 x)"
-unfolding dest_vec1_def by simp
-
-lemma simple_path_join_loop:
- assumes "injective_path g1" "injective_path g2" "pathfinish g2 = pathstart g1"
- "(path_image g1 \<inter> path_image g2) \<subseteq> {pathstart g1,pathstart g2}"
- shows "simple_path(g1 +++ g2)"
-unfolding simple_path_def proof((rule ballI)+, rule impI) let ?g = "g1 +++ g2"
- note inj = assms(1,2)[unfolded injective_path_def, rule_format]
- fix x y::"real^1" assume xy:"x \<in> {0..1}" "y \<in> {0..1}" "?g x = ?g y"
- show "x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0" proof(case_tac "x$1 \<le> 1/2",case_tac[!] "y$1 \<le> 1/2", unfold not_le)
- assume as:"x $ 1 \<le> 1 / 2" "y $ 1 \<le> 1 / 2"
- hence "g1 (2 *\<^sub>R x) = g1 (2 *\<^sub>R y)" using xy(3) unfolding joinpaths_def dest_vec1_def by auto
- moreover have "2 *\<^sub>R x \<in> {0..1}" "2 *\<^sub>R y \<in> {0..1}" using xy(1,2) as
- unfolding mem_interval_1 dest_vec1_def by(auto simp add:vector_component_simps)
- ultimately show ?thesis using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"] by auto
- next assume as:"x $ 1 > 1 / 2" "y $ 1 > 1 / 2"
- hence "g2 (2 *\<^sub>R x - 1) = g2 (2 *\<^sub>R y - 1)" using xy(3) unfolding joinpaths_def dest_vec1_def by auto
- moreover have "2 *\<^sub>R x - 1 \<in> {0..1}" "2 *\<^sub>R y - 1 \<in> {0..1}" using xy(1,2) as
- unfolding mem_interval_1 dest_vec1_def by(auto simp add:vector_component_simps)
- ultimately show ?thesis using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] by auto
- next assume as:"x $ 1 \<le> 1 / 2" "y $ 1 > 1 / 2"
- hence "?g x \<in> path_image g1" "?g y \<in> path_image g2" unfolding path_image_def joinpaths_def
- using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
- moreover have "?g y \<noteq> pathstart g2" using as(2) unfolding pathstart_def joinpaths_def
- using inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(2)[unfolded mem_interval_1]
- apply(rule_tac ccontr) by(auto simp add:vector_component_simps field_simps Cart_eq)
- ultimately have *:"?g x = pathstart g1" using assms(4) unfolding xy(3) by auto
- hence "x = 0" unfolding pathstart_def joinpaths_def using as(1) and xy(1)[unfolded mem_interval_1]
- using inj(1)[of "2 *\<^sub>R x" 0] by(auto simp add:vector_component_simps)
- moreover have "y = 1" using * unfolding xy(3) assms(3)[THEN sym]
- unfolding joinpaths_def pathfinish_def using as(2) and xy(2)[unfolded mem_interval_1]
- using inj(2)[of "2 *\<^sub>R y - 1" 1] by (auto simp add:vector_component_simps Cart_eq)
- ultimately show ?thesis by auto
- next assume as:"x $ 1 > 1 / 2" "y $ 1 \<le> 1 / 2"
- hence "?g x \<in> path_image g2" "?g y \<in> path_image g1" unfolding path_image_def joinpaths_def
- using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
- moreover have "?g x \<noteq> pathstart g2" using as(1) unfolding pathstart_def joinpaths_def
- using inj(2)[of "2 *\<^sub>R x - 1" 0] and xy(1)[unfolded mem_interval_1]
- apply(rule_tac ccontr) by(auto simp add:vector_component_simps field_simps Cart_eq)
- ultimately have *:"?g y = pathstart g1" using assms(4) unfolding xy(3) by auto
- hence "y = 0" unfolding pathstart_def joinpaths_def using as(2) and xy(2)[unfolded mem_interval_1]
- using inj(1)[of "2 *\<^sub>R y" 0] by(auto simp add:vector_component_simps)
- moreover have "x = 1" using * unfolding xy(3)[THEN sym] assms(3)[THEN sym]
- unfolding joinpaths_def pathfinish_def using as(1) and xy(1)[unfolded mem_interval_1]
- using inj(2)[of "2 *\<^sub>R x - 1" 1] by(auto simp add:vector_component_simps Cart_eq)
- ultimately show ?thesis by auto qed qed
-
-lemma injective_path_join:
- assumes "injective_path g1" "injective_path g2" "pathfinish g1 = pathstart g2"
- "(path_image g1 \<inter> path_image g2) \<subseteq> {pathstart g2}"
- shows "injective_path(g1 +++ g2)"
- unfolding injective_path_def proof(rule,rule,rule) let ?g = "g1 +++ g2"
- note inj = assms(1,2)[unfolded injective_path_def, rule_format]
- fix x y assume xy:"x \<in> {0..1}" "y \<in> {0..1}" "(g1 +++ g2) x = (g1 +++ g2) y"
- show "x = y" proof(cases "x$1 \<le> 1/2", case_tac[!] "y$1 \<le> 1/2", unfold not_le)
- assume "x $ 1 \<le> 1 / 2" "y $ 1 \<le> 1 / 2" thus ?thesis using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"] and xy
- unfolding mem_interval_1 joinpaths_def by(auto simp add:vector_component_simps)
- next assume "x $ 1 > 1 / 2" "y $ 1 > 1 / 2" thus ?thesis using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] and xy
- unfolding mem_interval_1 joinpaths_def by(auto simp add:vector_component_simps)
- next assume as:"x $ 1 \<le> 1 / 2" "y $ 1 > 1 / 2"
- hence "?g x \<in> path_image g1" "?g y \<in> path_image g2" unfolding path_image_def joinpaths_def
- using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
- hence "?g x = pathfinish g1" "?g y = pathstart g2" using assms(4) unfolding assms(3) xy(3) by auto
- thus ?thesis using as and inj(1)[of "2 *\<^sub>R x" 1] inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(1,2)
- unfolding pathstart_def pathfinish_def joinpaths_def mem_interval_1
- by(auto simp add:vector_component_simps Cart_eq forall_1)
- next assume as:"x $ 1 > 1 / 2" "y $ 1 \<le> 1 / 2"
- hence "?g x \<in> path_image g2" "?g y \<in> path_image g1" unfolding path_image_def joinpaths_def
- using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
- hence "?g x = pathstart g2" "?g y = pathfinish g1" using assms(4) unfolding assms(3) xy(3) by auto
- thus ?thesis using as and inj(2)[of "2 *\<^sub>R x - 1" 0] inj(1)[of "2 *\<^sub>R y" 1] and xy(1,2)
- unfolding pathstart_def pathfinish_def joinpaths_def mem_interval_1
- by(auto simp add:vector_component_simps forall_1 Cart_eq) qed qed
-
-lemmas join_paths_simps = path_join path_image_join pathstart_join pathfinish_join
-
-subsection {* Reparametrizing a closed curve to start at some chosen point. *}
-
-definition "shiftpath a (f::real^1 \<Rightarrow> real^'n) =
- (\<lambda>x. if dest_vec1 (a + x) \<le> 1 then f(a + x) else f(a + x - 1))"
-
-lemma pathstart_shiftpath: "a \<le> 1 \<Longrightarrow> pathstart(shiftpath a g) = g a"
- unfolding pathstart_def shiftpath_def by auto
-
-(** move this **)
-declare forall_1[simp] ex_1[simp]
-
-lemma pathfinish_shiftpath: assumes "0 \<le> a" "pathfinish g = pathstart g"
- shows "pathfinish(shiftpath a g) = g a"
- using assms unfolding pathstart_def pathfinish_def shiftpath_def
- by(auto simp add: vector_component_simps)
-
-lemma endpoints_shiftpath:
- assumes "pathfinish g = pathstart g" "a \<in> {0 .. 1}"
- shows "pathfinish(shiftpath a g) = g a" "pathstart(shiftpath a g) = g a"
- using assms by(auto intro!:pathfinish_shiftpath pathstart_shiftpath)
-
-lemma closed_shiftpath:
- assumes "pathfinish g = pathstart g" "a \<in> {0..1}"
- shows "pathfinish(shiftpath a g) = pathstart(shiftpath a g)"
- using endpoints_shiftpath[OF assms] by auto
-
-lemma path_shiftpath:
- assumes "path g" "pathfinish g = pathstart g" "a \<in> {0..1}"
- shows "path(shiftpath a g)" proof-
- have *:"{0 .. 1} = {0 .. 1-a} \<union> {1-a .. 1}" using assms(3) by(auto simp add: vector_component_simps)
- have **:"\<And>x. x + a = 1 \<Longrightarrow> g (x + a - 1) = g (x + a)"
- using assms(2)[unfolded pathfinish_def pathstart_def] by auto
- show ?thesis unfolding path_def shiftpath_def * apply(rule continuous_on_union)
- apply(rule closed_interval)+ apply(rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a + x)"]) prefer 3
- apply(rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a - 1 + x)"]) defer prefer 3
- apply(rule continuous_on_intros)+ prefer 2 apply(rule continuous_on_intros)+
- apply(rule_tac[1-2] continuous_on_subset[OF assms(1)[unfolded path_def]])
- using assms(3) and ** by(auto simp add:vector_component_simps field_simps Cart_eq) qed
-
-lemma shiftpath_shiftpath: assumes "pathfinish g = pathstart g" "a \<in> {0..1}" "x \<in> {0..1}"
- shows "shiftpath (1 - a) (shiftpath a g) x = g x"
- using assms unfolding pathfinish_def pathstart_def shiftpath_def
- by(auto simp add: vector_component_simps)
-
-lemma path_image_shiftpath:
- assumes "a \<in> {0..1}" "pathfinish g = pathstart g"
- shows "path_image(shiftpath a g) = path_image g" proof-
- { fix x assume as:"g 1 = g 0" "x \<in> {0..1::real^1}" " \<forall>y\<in>{0..1} \<inter> {x. \<not> a $ 1 + x $ 1 \<le> 1}. g x \<noteq> g (a + y - 1)"
- hence "\<exists>y\<in>{0..1} \<inter> {x. a $ 1 + x $ 1 \<le> 1}. g x = g (a + y)" proof(cases "a \<le> x")
- case False thus ?thesis apply(rule_tac x="1 + x - a" in bexI)
- using as(1,2) and as(3)[THEN bspec[where x="1 + x - a"]] and assms(1)
- by(auto simp add:vector_component_simps field_simps atomize_not) next
- case True thus ?thesis using as(1-2) and assms(1) apply(rule_tac x="x - a" in bexI)
- by(auto simp add:vector_component_simps field_simps) qed }
- thus ?thesis using assms unfolding shiftpath_def path_image_def pathfinish_def pathstart_def
- by(auto simp add:vector_component_simps image_iff) qed
-
-subsection {* Special case of straight-line paths. *}
-
-definition
- linepath :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 1 \<Rightarrow> real ^ 'n" where
- "linepath a b = (\<lambda>x. (1 - dest_vec1 x) *\<^sub>R a + dest_vec1 x *\<^sub>R b)"
-
-lemma pathstart_linepath[simp]: "pathstart(linepath a b) = a"
- unfolding pathstart_def linepath_def by auto
-
-lemma pathfinish_linepath[simp]: "pathfinish(linepath a b) = b"
- unfolding pathfinish_def linepath_def by auto
-
-lemma continuous_linepath_at[intro]: "continuous (at x) (linepath a b)"
- unfolding linepath_def
- by (intro continuous_intros continuous_dest_vec1)
-
-lemma continuous_on_linepath[intro]: "continuous_on s (linepath a b)"
- using continuous_linepath_at by(auto intro!: continuous_at_imp_continuous_on)
-
-lemma path_linepath[intro]: "path(linepath a b)"
- unfolding path_def by(rule continuous_on_linepath)
-
-lemma path_image_linepath[simp]: "path_image(linepath a b) = (closed_segment a b)"
- unfolding path_image_def segment linepath_def apply (rule set_ext, rule) defer
- unfolding mem_Collect_eq image_iff apply(erule exE) apply(rule_tac x="u *\<^sub>R 1" in bexI)
- by(auto simp add:vector_component_simps)
-
-lemma reversepath_linepath[simp]: "reversepath(linepath a b) = linepath b a"
- unfolding reversepath_def linepath_def by(rule ext, auto simp add:vector_component_simps)
-
-lemma injective_path_linepath: assumes "a \<noteq> b" shows "injective_path(linepath a b)" proof-
- { obtain i where i:"a$i \<noteq> b$i" using assms[unfolded Cart_eq] by auto
- fix x y::"real^1" assume "x $ 1 *\<^sub>R b + y $ 1 *\<^sub>R a = x $ 1 *\<^sub>R a + y $ 1 *\<^sub>R b"
- hence "x$1 * (b$i - a$i) = y$1 * (b$i - a$i)" unfolding Cart_eq by(auto simp add:field_simps vector_component_simps)
- hence "x = y" unfolding mult_cancel_right Cart_eq using i(1) by(auto simp add:field_simps) }
- thus ?thesis unfolding injective_path_def linepath_def by(auto simp add:vector_component_simps algebra_simps) qed
-
-lemma simple_path_linepath[intro]: "a \<noteq> b \<Longrightarrow> simple_path(linepath a b)" by(auto intro!: injective_imp_simple_path injective_path_linepath)
-
-subsection {* Bounding a point away from a path. *}
-
-lemma not_on_path_ball: assumes "path g" "z \<notin> path_image g"
- shows "\<exists>e>0. ball z e \<inter> (path_image g) = {}" proof-
- obtain a where "a\<in>path_image g" "\<forall>y\<in>path_image g. dist z a \<le> dist z y"
- using distance_attains_inf[OF _ path_image_nonempty, of g z]
- using compact_path_image[THEN compact_imp_closed, OF assms(1)] by auto
- thus ?thesis apply(rule_tac x="dist z a" in exI) using assms(2) by(auto intro!: dist_pos_lt) qed
-
-lemma not_on_path_cball: assumes "path g" "z \<notin> path_image g"
- shows "\<exists>e>0. cball z e \<inter> (path_image g) = {}" proof-
- obtain e where "ball z e \<inter> path_image g = {}" "e>0" using not_on_path_ball[OF assms] by auto
- moreover have "cball z (e/2) \<subseteq> ball z e" using `e>0` by auto
- ultimately show ?thesis apply(rule_tac x="e/2" in exI) by auto qed
-
-subsection {* Path component, considered as a "joinability" relation (from Tom Hales). *}
-
-definition "path_component s x y \<longleftrightarrow> (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"
-
-lemmas path_defs = path_def pathstart_def pathfinish_def path_image_def path_component_def
-
-lemma path_component_mem: assumes "path_component s x y" shows "x \<in> s" "y \<in> s"
- using assms unfolding path_defs by auto
-
-lemma path_component_refl: assumes "x \<in> s" shows "path_component s x x"
- unfolding path_defs apply(rule_tac x="\<lambda>u. x" in exI) using assms
- by(auto intro!:continuous_on_intros)
-
-lemma path_component_refl_eq: "path_component s x x \<longleftrightarrow> x \<in> s"
- by(auto intro!: path_component_mem path_component_refl)
-
-lemma path_component_sym: "path_component s x y \<Longrightarrow> path_component s y x"
- using assms unfolding path_component_def apply(erule exE) apply(rule_tac x="reversepath g" in exI)
- by(auto simp add: reversepath_simps)
-
-lemma path_component_trans: assumes "path_component s x y" "path_component s y z" shows "path_component s x z"
- using assms unfolding path_component_def apply- apply(erule exE)+ apply(rule_tac x="g +++ ga" in exI) by(auto simp add: path_image_join)
-
-lemma path_component_of_subset: "s \<subseteq> t \<Longrightarrow> path_component s x y \<Longrightarrow> path_component t x y"
- unfolding path_component_def by auto
-
-subsection {* Can also consider it as a set, as the name suggests. *}
-
-lemma path_component_set: "path_component s x = { y. (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y )}"
- apply(rule set_ext) unfolding mem_Collect_eq unfolding mem_def path_component_def by auto
-
-lemma mem_path_component_set:"x \<in> path_component s y \<longleftrightarrow> path_component s y x" unfolding mem_def by auto
-
-lemma path_component_subset: "(path_component s x) \<subseteq> s"
- apply(rule, rule path_component_mem(2)) by(auto simp add:mem_def)
-
-lemma path_component_eq_empty: "path_component s x = {} \<longleftrightarrow> x \<notin> s"
- apply rule apply(drule equals0D[of _ x]) defer apply(rule equals0I) unfolding mem_path_component_set
- apply(drule path_component_mem(1)) using path_component_refl by auto
-
-subsection {* Path connectedness of a space. *}
-
-definition "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<exists>g. path g \<and> (path_image g) \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"
-
-lemma path_connected_component: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. path_component s x y)"
- unfolding path_connected_def path_component_def by auto
-
-lemma path_connected_component_set: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. path_component s x = s)"
- unfolding path_connected_component apply(rule, rule, rule, rule path_component_subset)
- unfolding subset_eq mem_path_component_set Ball_def mem_def by auto
-
-subsection {* Some useful lemmas about path-connectedness. *}
-
-lemma convex_imp_path_connected: assumes "convex s" shows "path_connected s"
- unfolding path_connected_def apply(rule,rule,rule_tac x="linepath x y" in exI)
- unfolding path_image_linepath using assms[unfolded convex_contains_segment] by auto
-
-lemma path_connected_imp_connected: assumes "path_connected s" shows "connected s"
- unfolding connected_def not_ex apply(rule,rule,rule ccontr) unfolding not_not apply(erule conjE)+ proof-
- fix e1 e2 assume as:"open e1" "open e2" "s \<subseteq> e1 \<union> e2" "e1 \<inter> e2 \<inter> s = {}" "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
- then obtain x1 x2 where obt:"x1\<in>e1\<inter>s" "x2\<in>e2\<inter>s" by auto
- then obtain g where g:"path g" "path_image g \<subseteq> s" "pathstart g = x1" "pathfinish g = x2"
- using assms[unfolded path_connected_def,rule_format,of x1 x2] by auto
- have *:"connected {0..1::real^1}" by(auto intro!: convex_connected convex_interval)
- have "{0..1} \<subseteq> {x \<in> {0..1}. g x \<in> e1} \<union> {x \<in> {0..1}. g x \<in> e2}" using as(3) g(2)[unfolded path_defs] by blast
- moreover have "{x \<in> {0..1}. g x \<in> e1} \<inter> {x \<in> {0..1}. g x \<in> e2} = {}" using as(4) g(2)[unfolded path_defs] unfolding subset_eq by auto
- moreover have "{x \<in> {0..1}. g x \<in> e1} \<noteq> {} \<and> {x \<in> {0..1}. g x \<in> e2} \<noteq> {}" using g(3,4)[unfolded path_defs] using obt by(auto intro!: exI)
- ultimately show False using *[unfolded connected_local not_ex,rule_format, of "{x\<in>{0..1}. g x \<in> e1}" "{x\<in>{0..1}. g x \<in> e2}"]
- using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(1)]
- using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(2)] by auto qed
-
-lemma open_path_component: assumes "open s" shows "open(path_component s x)"
- unfolding open_contains_ball proof
- fix y assume as:"y \<in> path_component s x"
- hence "y\<in>s" apply- apply(rule path_component_mem(2)) unfolding mem_def by auto
- then obtain e where e:"e>0" "ball y e \<subseteq> s" using assms[unfolded open_contains_ball] by auto
- show "\<exists>e>0. ball y e \<subseteq> path_component s x" apply(rule_tac x=e in exI) apply(rule,rule `e>0`,rule) unfolding mem_ball mem_path_component_set proof-
- fix z assume "dist y z < e" thus "path_component s x z" apply(rule_tac path_component_trans[of _ _ y]) defer
- apply(rule path_component_of_subset[OF e(2)]) apply(rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format]) using `e>0`
- using as[unfolded mem_def] by auto qed qed
-
-lemma open_non_path_component: assumes "open s" shows "open(s - path_component s x)" unfolding open_contains_ball proof
- fix y assume as:"y\<in>s - path_component s x"
- then obtain e where e:"e>0" "ball y e \<subseteq> s" using assms[unfolded open_contains_ball] by auto
- show "\<exists>e>0. ball y e \<subseteq> s - path_component s x" apply(rule_tac x=e in exI) apply(rule,rule `e>0`,rule,rule) defer proof(rule ccontr)
- fix z assume "z\<in>ball y e" "\<not> z \<notin> path_component s x"
- hence "y \<in> path_component s x" unfolding not_not mem_path_component_set using `e>0`
- apply- apply(rule path_component_trans,assumption) apply(rule path_component_of_subset[OF e(2)])
- apply(rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format]) by auto
- thus False using as by auto qed(insert e(2), auto) qed
-
-lemma connected_open_path_connected: assumes "open s" "connected s" shows "path_connected s"
- unfolding path_connected_component_set proof(rule,rule,rule path_component_subset, rule)
- fix x y assume "x \<in> s" "y \<in> s" show "y \<in> path_component s x" proof(rule ccontr)
- assume "y \<notin> path_component s x" moreover
- have "path_component s x \<inter> s \<noteq> {}" using `x\<in>s` path_component_eq_empty path_component_subset[of s x] by auto
- ultimately show False using `y\<in>s` open_non_path_component[OF assms(1)] open_path_component[OF assms(1)]
- using assms(2)[unfolded connected_def not_ex, rule_format, of"path_component s x" "s - path_component s x"] by auto
-qed qed
-
-lemma path_connected_continuous_image:
- assumes "continuous_on s f" "path_connected s" shows "path_connected (f ` s)"
- unfolding path_connected_def proof(rule,rule)
- fix x' y' assume "x' \<in> f ` s" "y' \<in> f ` s"
- then obtain x y where xy:"x\<in>s" "y\<in>s" "x' = f x" "y' = f y" by auto
- guess g using assms(2)[unfolded path_connected_def,rule_format,OF xy(1,2)] ..
- thus "\<exists>g. path g \<and> path_image g \<subseteq> f ` s \<and> pathstart g = x' \<and> pathfinish g = y'"
- unfolding xy apply(rule_tac x="f \<circ> g" in exI) unfolding path_defs
- using assms(1) by(auto intro!: continuous_on_compose continuous_on_subset[of _ _ "g ` {0..1}"]) qed
-
-lemma homeomorphic_path_connectedness:
- "s homeomorphic t \<Longrightarrow> (path_connected s \<longleftrightarrow> path_connected t)"
- unfolding homeomorphic_def homeomorphism_def apply(erule exE|erule conjE)+ apply rule
- apply(drule_tac f=f in path_connected_continuous_image) prefer 3
- apply(drule_tac f=g in path_connected_continuous_image) by auto
-
-lemma path_connected_empty: "path_connected {}"
- unfolding path_connected_def by auto
-
-lemma path_connected_singleton: "path_connected {a}"
- unfolding path_connected_def apply(rule,rule)
- apply(rule_tac x="linepath a a" in exI) by(auto simp add:segment scaleR_left_diff_distrib)
-
-lemma path_connected_Un: assumes "path_connected s" "path_connected t" "s \<inter> t \<noteq> {}"
- shows "path_connected (s \<union> t)" unfolding path_connected_component proof(rule,rule)
- fix x y assume as:"x \<in> s \<union> t" "y \<in> s \<union> t"
- from assms(3) obtain z where "z \<in> s \<inter> t" by auto
- thus "path_component (s \<union> t) x y" using as using assms(1-2)[unfolded path_connected_component] apply-
- apply(erule_tac[!] UnE)+ apply(rule_tac[2-3] path_component_trans[of _ _ z])
- by(auto simp add:path_component_of_subset [OF Un_upper1] path_component_of_subset[OF Un_upper2]) qed
-
-subsection {* sphere is path-connected. *}
-
-lemma path_connected_punctured_universe:
- assumes "2 \<le> CARD('n::finite)" shows "path_connected((UNIV::(real^'n::finite) set) - {a})" proof-
- obtain \<psi> where \<psi>:"bij_betw \<psi> {1..CARD('n)} (UNIV::'n set)" using ex_bij_betw_nat_finite_1[OF finite_UNIV] by auto
- let ?U = "UNIV::(real^'n) set" let ?u = "?U - {0}"
- let ?basis = "\<lambda>k. basis (\<psi> k)"
- let ?A = "\<lambda>k. {x::real^'n. \<exists>i\<in>{1..k}. inner (basis (\<psi> i)) x \<noteq> 0}"
- have "\<forall>k\<in>{2..CARD('n)}. path_connected (?A k)" proof
- have *:"\<And>k. ?A (Suc k) = {x. inner (?basis (Suc k)) x < 0} \<union> {x. inner (?basis (Suc k)) x > 0} \<union> ?A k" apply(rule set_ext,rule) defer
- apply(erule UnE)+ unfolding mem_Collect_eq apply(rule_tac[1-2] x="Suc k" in bexI)
- by(auto elim!: ballE simp add: not_less le_Suc_eq)
- fix k assume "k \<in> {2..CARD('n)}" thus "path_connected (?A k)" proof(induct k)
- case (Suc k) show ?case proof(cases "k = 1")
- case False from Suc have d:"k \<in> {1..CARD('n)}" "Suc k \<in> {1..CARD('n)}" by auto
- hence "\<psi> k \<noteq> \<psi> (Suc k)" using \<psi>[unfolded bij_betw_def inj_on_def, THEN conjunct1, THEN bspec[where x=k]] by auto
- hence **:"?basis k + ?basis (Suc k) \<in> {x. 0 < inner (?basis (Suc k)) x} \<inter> (?A k)"
- "?basis k - ?basis (Suc k) \<in> {x. 0 > inner (?basis (Suc k)) x} \<inter> ({x. 0 < inner (?basis (Suc k)) x} \<union> (?A k))" using d
- by(auto simp add: inner_basis vector_component_simps intro!:bexI[where x=k])
- show ?thesis unfolding * Un_assoc apply(rule path_connected_Un) defer apply(rule path_connected_Un)
- prefer 5 apply(rule_tac[1-2] convex_imp_path_connected, rule convex_halfspace_lt, rule convex_halfspace_gt)
- apply(rule Suc(1)) apply(rule_tac[2-3] ccontr) using d ** False by auto
- next case True hence d:"1\<in>{1..CARD('n)}" "2\<in>{1..CARD('n)}" using Suc(2) by auto
- have ***:"Suc 1 = 2" by auto
- have **:"\<And>s t P Q. s \<union> t \<union> {x. P x \<or> Q x} = (s \<union> {x. P x}) \<union> (t \<union> {x. Q x})" by auto
- have "\<psi> 2 \<noteq> \<psi> (Suc 0)" apply(rule ccontr) using \<psi>[unfolded bij_betw_def inj_on_def, THEN conjunct1, THEN bspec[where x=2]] using assms by auto
- thus ?thesis unfolding * True unfolding ** neq_iff bex_disj_distrib apply -
- apply(rule path_connected_Un, rule_tac[1-2] path_connected_Un) defer 3 apply(rule_tac[1-4] convex_imp_path_connected)
- apply(rule_tac[5] x=" ?basis 1 + ?basis 2" in nequals0I)
- apply(rule_tac[6] x="-?basis 1 + ?basis 2" in nequals0I)
- apply(rule_tac[7] x="-?basis 1 - ?basis 2" in nequals0I)
- using d unfolding *** by(auto intro!: convex_halfspace_gt convex_halfspace_lt, auto simp add:vector_component_simps inner_basis)
- qed qed auto qed note lem = this
-
- have ***:"\<And>x::real^'n. (\<exists>i\<in>{1..CARD('n)}. inner (basis (\<psi> i)) x \<noteq> 0) \<longleftrightarrow> (\<exists>i. inner (basis i) x \<noteq> 0)"
- apply rule apply(erule bexE) apply(rule_tac x="\<psi> i" in exI) defer apply(erule exE) proof-
- fix x::"real^'n" and i assume as:"inner (basis i) x \<noteq> 0"
- have "i\<in>\<psi> ` {1..CARD('n)}" using \<psi>[unfolded bij_betw_def, THEN conjunct2] by auto
- then obtain j where "j\<in>{1..CARD('n)}" "\<psi> j = i" by auto
- thus "\<exists>i\<in>{1..CARD('n)}. inner (basis (\<psi> i)) x \<noteq> 0" apply(rule_tac x=j in bexI) using as by auto qed auto
- have *:"?U - {a} = (\<lambda>x. x + a) ` {x. x \<noteq> 0}" apply(rule set_ext) unfolding image_iff
- apply rule apply(rule_tac x="x - a" in bexI) by auto
- have **:"\<And>x::real^'n. x\<noteq>0 \<longleftrightarrow> (\<exists>i. inner (basis i) x \<noteq> 0)" unfolding Cart_eq by(auto simp add: inner_basis)
- show ?thesis unfolding * apply(rule path_connected_continuous_image) apply(rule continuous_on_intros)+
- unfolding ** apply(rule lem[THEN bspec[where x="CARD('n)"], unfolded ***]) using assms by auto qed
-
-lemma path_connected_sphere: assumes "2 \<le> CARD('n::finite)" shows "path_connected {x::real^'n::finite. norm(x - a) = r}" proof(cases "r\<le>0")
- case True thus ?thesis proof(cases "r=0")
- case False hence "{x::real^'n. norm(x - a) = r} = {}" using True by auto
- thus ?thesis using path_connected_empty by auto
- qed(auto intro!:path_connected_singleton) next
- case False hence *:"{x::real^'n. norm(x - a) = r} = (\<lambda>x. a + r *\<^sub>R x) ` {x. norm x = 1}" unfolding not_le apply -apply(rule set_ext,rule)
- unfolding image_iff apply(rule_tac x="(1/r) *\<^sub>R (x - a)" in bexI) unfolding mem_Collect_eq norm_scaleR by (auto simp add: scaleR_right_diff_distrib)
- have **:"{x::real^'n. norm x = 1} = (\<lambda>x. (1/norm x) *\<^sub>R x) ` (UNIV - {0})" apply(rule set_ext,rule)
- unfolding image_iff apply(rule_tac x=x in bexI) unfolding mem_Collect_eq by(auto split:split_if_asm)
- have "continuous_on (UNIV - {0}) (\<lambda>x::real^'n. 1 / norm x)" unfolding o_def continuous_on_eq_continuous_within
- apply(rule, rule continuous_at_within_inv[unfolded o_def inverse_eq_divide]) apply(rule continuous_at_within)
- apply(rule continuous_at_norm[unfolded o_def]) by auto
- thus ?thesis unfolding * ** using path_connected_punctured_universe[OF assms]
- by(auto intro!: path_connected_continuous_image continuous_on_intros continuous_on_mul) qed
-
-lemma connected_sphere: "2 \<le> CARD('n) \<Longrightarrow> connected {x::real^'n::finite. norm(x - a) = r}"
- using path_connected_sphere path_connected_imp_connected by auto
-
-(** In continuous_at_vec1_norm : Use \<And> instead of \<forall>. **)
-
-end--- a/src/HOL/Library/Determinants.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1087 +0,0 @@
-(* Title: Determinants
- Author: Amine Chaieb, University of Cambridge
-*)
-
-header {* Traces, Determinant of square matrices and some properties *}
-
-theory Determinants
-imports Euclidean_Space Permutations
-begin
-
-subsection{* First some facts about products*}
-lemma setprod_insert_eq: "finite A \<Longrightarrow> setprod f (insert a A) = (if a \<in> A then setprod f A else f a * setprod f A)"
-apply clarsimp
-by(subgoal_tac "insert a A = A", auto)
-
-lemma setprod_add_split:
- assumes mn: "(m::nat) <= n + 1"
- shows "setprod f {m.. n+p} = setprod f {m .. n} * setprod f {n+1..n+p}"
-proof-
- let ?A = "{m .. n+p}"
- let ?B = "{m .. n}"
- let ?C = "{n+1..n+p}"
- from mn have un: "?B \<union> ?C = ?A" by auto
- from mn have dj: "?B \<inter> ?C = {}" by auto
- have f: "finite ?B" "finite ?C" by simp_all
- from setprod_Un_disjoint[OF f dj, of f, unfolded un] show ?thesis .
-qed
-
-
-lemma setprod_offset: "setprod f {(m::nat) + p .. n + p} = setprod (\<lambda>i. f (i + p)) {m..n}"
-apply (rule setprod_reindex_cong[where f="op + p"])
-apply (auto simp add: image_iff Bex_def inj_on_def)
-apply arith
-apply (rule ext)
-apply (simp add: add_commute)
-done
-
-lemma setprod_singleton: "setprod f {x} = f x" by simp
-
-lemma setprod_singleton_nat_seg: "setprod f {n..n} = f (n::'a::order)" by simp
-
-lemma setprod_numseg: "setprod f {m..0} = (if m=0 then f 0 else 1)"
- "setprod f {m .. Suc n} = (if m \<le> Suc n then f (Suc n) * setprod f {m..n}
- else setprod f {m..n})"
- by (auto simp add: atLeastAtMostSuc_conv)
-
-lemma setprod_le: assumes fS: "finite S" and fg: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (g x :: 'a::ordered_idom)"
- shows "setprod f S \<le> setprod g S"
-using fS fg
-apply(induct S)
-apply simp
-apply auto
-apply (rule mult_mono)
-apply (auto intro: setprod_nonneg)
-done
-
- (* FIXME: In Finite_Set there is a useless further assumption *)
-lemma setprod_inversef: "finite A ==> setprod (inverse \<circ> f) A = (inverse (setprod f A) :: 'a:: {division_by_zero, field})"
- apply (erule finite_induct)
- apply (simp)
- apply simp
- done
-
-lemma setprod_le_1: assumes fS: "finite S" and f: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (1::'a::ordered_idom)"
- shows "setprod f S \<le> 1"
-using setprod_le[OF fS f] unfolding setprod_1 .
-
-subsection{* Trace *}
-
-definition trace :: "'a::semiring_1^'n^'n \<Rightarrow> 'a" where
- "trace A = setsum (\<lambda>i. ((A$i)$i)) (UNIV::'n set)"
-
-lemma trace_0: "trace(mat 0) = 0"
- by (simp add: trace_def mat_def)
-
-lemma trace_I: "trace(mat 1 :: 'a::semiring_1^'n^'n) = of_nat(CARD('n))"
- by (simp add: trace_def mat_def)
-
-lemma trace_add: "trace ((A::'a::comm_semiring_1^'n^'n) + B) = trace A + trace B"
- by (simp add: trace_def setsum_addf)
-
-lemma trace_sub: "trace ((A::'a::comm_ring_1^'n^'n) - B) = trace A - trace B"
- by (simp add: trace_def setsum_subtractf)
-
-lemma trace_mul_sym:"trace ((A::'a::comm_semiring_1^'n^'n) ** B) = trace (B**A)"
- apply (simp add: trace_def matrix_matrix_mult_def)
- apply (subst setsum_commute)
- by (simp add: mult_commute)
-
-(* ------------------------------------------------------------------------- *)
-(* Definition of determinant. *)
-(* ------------------------------------------------------------------------- *)
-
-definition det:: "'a::comm_ring_1^'n^'n \<Rightarrow> 'a" where
- "det A = setsum (\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)) {p. p permutes (UNIV :: 'n set)}"
-
-(* ------------------------------------------------------------------------- *)
-(* A few general lemmas we need below. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma setprod_permute:
- assumes p: "p permutes S"
- shows "setprod f S = setprod (f o p) S"
-proof-
- {assume "\<not> finite S" hence ?thesis by simp}
- moreover
- {assume fS: "finite S"
- then have ?thesis
- apply (simp add: setprod_def cong del:strong_setprod_cong)
- apply (rule ab_semigroup_mult.fold_image_permute)
- apply (auto simp add: p)
- apply unfold_locales
- done}
- ultimately show ?thesis by blast
-qed
-
-lemma setproduct_permute_nat_interval: "p permutes {m::nat .. n} ==> setprod f {m..n} = setprod (f o p) {m..n}"
- by (blast intro!: setprod_permute)
-
-(* ------------------------------------------------------------------------- *)
-(* Basic determinant properties. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma det_transp: "det (transp A) = det (A::'a::comm_ring_1 ^'n^'n::finite)"
-proof-
- let ?di = "\<lambda>A i j. A$i$j"
- let ?U = "(UNIV :: 'n set)"
- have fU: "finite ?U" by simp
- {fix p assume p: "p \<in> {p. p permutes ?U}"
- from p have pU: "p permutes ?U" by blast
- have sth: "sign (inv p) = sign p"
- by (metis sign_inverse fU p mem_def Collect_def permutation_permutes)
- from permutes_inj[OF pU]
- have pi: "inj_on p ?U" by (blast intro: subset_inj_on)
- from permutes_image[OF pU]
- have "setprod (\<lambda>i. ?di (transp A) i (inv p i)) ?U = setprod (\<lambda>i. ?di (transp A) i (inv p i)) (p ` ?U)" by simp
- also have "\<dots> = setprod ((\<lambda>i. ?di (transp A) i (inv p i)) o p) ?U"
- unfolding setprod_reindex[OF pi] ..
- also have "\<dots> = setprod (\<lambda>i. ?di A i (p i)) ?U"
- proof-
- {fix i assume i: "i \<in> ?U"
- from i permutes_inv_o[OF pU] permutes_in_image[OF pU]
- have "((\<lambda>i. ?di (transp A) i (inv p i)) o p) i = ?di A i (p i)"
- unfolding transp_def by (simp add: expand_fun_eq)}
- then show "setprod ((\<lambda>i. ?di (transp A) i (inv p i)) o p) ?U = setprod (\<lambda>i. ?di A i (p i)) ?U" by (auto intro: setprod_cong)
- qed
- finally have "of_int (sign (inv p)) * (setprod (\<lambda>i. ?di (transp A) i (inv p i)) ?U) = of_int (sign p) * (setprod (\<lambda>i. ?di A i (p i)) ?U)" using sth
- by simp}
- then show ?thesis unfolding det_def apply (subst setsum_permutations_inverse)
- apply (rule setsum_cong2) by blast
-qed
-
-lemma det_lowerdiagonal:
- fixes A :: "'a::comm_ring_1^'n^'n::{finite,wellorder}"
- assumes ld: "\<And>i j. i < j \<Longrightarrow> A$i$j = 0"
- shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
-proof-
- let ?U = "UNIV:: 'n set"
- let ?PU = "{p. p permutes ?U}"
- let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
- have fU: "finite ?U" by simp
- from finite_permutations[OF fU] have fPU: "finite ?PU" .
- have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
- {fix p assume p: "p \<in> ?PU -{id}"
- from p have pU: "p permutes ?U" and pid: "p \<noteq> id" by blast+
- from permutes_natset_le[OF pU] pid obtain i where
- i: "p i > i" by (metis not_le)
- from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
- from setprod_zero[OF fU ex] have "?pp p = 0" by simp}
- then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0" by blast
- from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
- unfolding det_def by (simp add: sign_id)
-qed
-
-lemma det_upperdiagonal:
- fixes A :: "'a::comm_ring_1^'n^'n::{finite,wellorder}"
- assumes ld: "\<And>i j. i > j \<Longrightarrow> A$i$j = 0"
- shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
-proof-
- let ?U = "UNIV:: 'n set"
- let ?PU = "{p. p permutes ?U}"
- let ?pp = "(\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set))"
- have fU: "finite ?U" by simp
- from finite_permutations[OF fU] have fPU: "finite ?PU" .
- have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
- {fix p assume p: "p \<in> ?PU -{id}"
- from p have pU: "p permutes ?U" and pid: "p \<noteq> id" by blast+
- from permutes_natset_ge[OF pU] pid obtain i where
- i: "p i < i" by (metis not_le)
- from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
- from setprod_zero[OF fU ex] have "?pp p = 0" by simp}
- then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0" by blast
- from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
- unfolding det_def by (simp add: sign_id)
-qed
-
-lemma det_diagonal:
- fixes A :: "'a::comm_ring_1^'n^'n::finite"
- assumes ld: "\<And>i j. i \<noteq> j \<Longrightarrow> A$i$j = 0"
- shows "det A = setprod (\<lambda>i. A$i$i) (UNIV::'n set)"
-proof-
- let ?U = "UNIV:: 'n set"
- let ?PU = "{p. p permutes ?U}"
- let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
- have fU: "finite ?U" by simp
- from finite_permutations[OF fU] have fPU: "finite ?PU" .
- have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
- {fix p assume p: "p \<in> ?PU - {id}"
- then have "p \<noteq> id" by simp
- then obtain i where i: "p i \<noteq> i" unfolding expand_fun_eq by auto
- from ld [OF i [symmetric]] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
- from setprod_zero [OF fU ex] have "?pp p = 0" by simp}
- then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0" by blast
- from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
- unfolding det_def by (simp add: sign_id)
-qed
-
-lemma det_I: "det (mat 1 :: 'a::comm_ring_1^'n^'n::finite) = 1"
-proof-
- let ?A = "mat 1 :: 'a::comm_ring_1^'n^'n"
- let ?U = "UNIV :: 'n set"
- let ?f = "\<lambda>i j. ?A$i$j"
- {fix i assume i: "i \<in> ?U"
- have "?f i i = 1" using i by (vector mat_def)}
- hence th: "setprod (\<lambda>i. ?f i i) ?U = setprod (\<lambda>x. 1) ?U"
- by (auto intro: setprod_cong)
- {fix i j assume i: "i \<in> ?U" and j: "j \<in> ?U" and ij: "i \<noteq> j"
- have "?f i j = 0" using i j ij by (vector mat_def) }
- then have "det ?A = setprod (\<lambda>i. ?f i i) ?U" using det_diagonal
- by blast
- also have "\<dots> = 1" unfolding th setprod_1 ..
- finally show ?thesis .
-qed
-
-lemma det_0: "det (mat 0 :: 'a::comm_ring_1^'n^'n::finite) = 0"
- by (simp add: det_def setprod_zero)
-
-lemma det_permute_rows:
- fixes A :: "'a::comm_ring_1^'n^'n::finite"
- assumes p: "p permutes (UNIV :: 'n::finite set)"
- shows "det(\<chi> i. A$p i :: 'a^'n^'n) = of_int (sign p) * det A"
- apply (simp add: det_def setsum_right_distrib mult_assoc[symmetric])
- apply (subst sum_permutations_compose_right[OF p])
-proof(rule setsum_cong2)
- let ?U = "UNIV :: 'n set"
- let ?PU = "{p. p permutes ?U}"
- fix q assume qPU: "q \<in> ?PU"
- have fU: "finite ?U" by simp
- from qPU have q: "q permutes ?U" by blast
- from p q have pp: "permutation p" and qp: "permutation q"
- by (metis fU permutation_permutes)+
- from permutes_inv[OF p] have ip: "inv p permutes ?U" .
- have "setprod (\<lambda>i. A$p i$ (q o p) i) ?U = setprod ((\<lambda>i. A$p i$(q o p) i) o inv p) ?U"
- by (simp only: setprod_permute[OF ip, symmetric])
- also have "\<dots> = setprod (\<lambda>i. A $ (p o inv p) i $ (q o (p o inv p)) i) ?U"
- by (simp only: o_def)
- also have "\<dots> = setprod (\<lambda>i. A$i$q i) ?U" by (simp only: o_def permutes_inverses[OF p])
- finally have thp: "setprod (\<lambda>i. A$p i$ (q o p) i) ?U = setprod (\<lambda>i. A$i$q i) ?U"
- by blast
- show "of_int (sign (q o p)) * setprod (\<lambda>i. A$ p i$ (q o p) i) ?U = of_int (sign p) * of_int (sign q) * setprod (\<lambda>i. A$i$q i) ?U"
- by (simp only: thp sign_compose[OF qp pp] mult_commute of_int_mult)
-qed
-
-lemma det_permute_columns:
- fixes A :: "'a::comm_ring_1^'n^'n::finite"
- assumes p: "p permutes (UNIV :: 'n set)"
- shows "det(\<chi> i j. A$i$ p j :: 'a^'n^'n) = of_int (sign p) * det A"
-proof-
- let ?Ap = "\<chi> i j. A$i$ p j :: 'a^'n^'n"
- let ?At = "transp A"
- have "of_int (sign p) * det A = det (transp (\<chi> i. transp A $ p i))"
- unfolding det_permute_rows[OF p, of ?At] det_transp ..
- moreover
- have "?Ap = transp (\<chi> i. transp A $ p i)"
- by (simp add: transp_def Cart_eq)
- ultimately show ?thesis by simp
-qed
-
-lemma det_identical_rows:
- fixes A :: "'a::ordered_idom^'n^'n::finite"
- assumes ij: "i \<noteq> j"
- and r: "row i A = row j A"
- shows "det A = 0"
-proof-
- have tha: "\<And>(a::'a) b. a = b ==> b = - a ==> a = 0"
- by simp
- have th1: "of_int (-1) = - 1" by (metis of_int_1 of_int_minus number_of_Min)
- let ?p = "Fun.swap i j id"
- let ?A = "\<chi> i. A $ ?p i"
- from r have "A = ?A" by (simp add: Cart_eq row_def swap_def)
- hence "det A = det ?A" by simp
- moreover have "det A = - det ?A"
- by (simp add: det_permute_rows[OF permutes_swap_id] sign_swap_id ij th1)
- ultimately show "det A = 0" by (metis tha)
-qed
-
-lemma det_identical_columns:
- fixes A :: "'a::ordered_idom^'n^'n::finite"
- assumes ij: "i \<noteq> j"
- and r: "column i A = column j A"
- shows "det A = 0"
-apply (subst det_transp[symmetric])
-apply (rule det_identical_rows[OF ij])
-by (metis row_transp r)
-
-lemma det_zero_row:
- fixes A :: "'a::{idom, ring_char_0}^'n^'n::finite"
- assumes r: "row i A = 0"
- shows "det A = 0"
-using r
-apply (simp add: row_def det_def Cart_eq)
-apply (rule setsum_0')
-apply (auto simp: sign_nz)
-done
-
-lemma det_zero_column:
- fixes A :: "'a::{idom,ring_char_0}^'n^'n::finite"
- assumes r: "column i A = 0"
- shows "det A = 0"
- apply (subst det_transp[symmetric])
- apply (rule det_zero_row [of i])
- by (metis row_transp r)
-
-lemma det_row_add:
- fixes a b c :: "'n::finite \<Rightarrow> _ ^ 'n"
- shows "det((\<chi> i. if i = k then a i + b i else c i)::'a::comm_ring_1^'n^'n) =
- det((\<chi> i. if i = k then a i else c i)::'a::comm_ring_1^'n^'n) +
- det((\<chi> i. if i = k then b i else c i)::'a::comm_ring_1^'n^'n)"
-unfolding det_def Cart_lambda_beta setsum_addf[symmetric]
-proof (rule setsum_cong2)
- let ?U = "UNIV :: 'n set"
- let ?pU = "{p. p permutes ?U}"
- let ?f = "(\<lambda>i. if i = k then a i + b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
- let ?g = "(\<lambda> i. if i = k then a i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
- let ?h = "(\<lambda> i. if i = k then b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
- fix p assume p: "p \<in> ?pU"
- let ?Uk = "?U - {k}"
- from p have pU: "p permutes ?U" by blast
- have kU: "?U = insert k ?Uk" by blast
- {fix j assume j: "j \<in> ?Uk"
- from j have "?f j $ p j = ?g j $ p j" and "?f j $ p j= ?h j $ p j"
- by simp_all}
- then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
- and th2: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?h i $ p i) ?Uk"
- apply -
- apply (rule setprod_cong, simp_all)+
- done
- have th3: "finite ?Uk" "k \<notin> ?Uk" by auto
- have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
- unfolding kU[symmetric] ..
- also have "\<dots> = ?f k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
- apply (rule setprod_insert)
- apply simp
- by blast
- also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk)" by (simp add: ring_simps)
- also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?h i $ p i) ?Uk)" by (metis th1 th2)
- also have "\<dots> = setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk) + setprod (\<lambda>i. ?h i $ p i) (insert k ?Uk)"
- unfolding setprod_insert[OF th3] by simp
- finally have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?g i $ p i) ?U + setprod (\<lambda>i. ?h i $ p i) ?U" unfolding kU[symmetric] .
- then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U = of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U + of_int (sign p) * setprod (\<lambda>i. ?h i $ p i) ?U"
- by (simp add: ring_simps)
-qed
-
-lemma det_row_mul:
- fixes a b :: "'n::finite \<Rightarrow> _ ^ 'n"
- shows "det((\<chi> i. if i = k then c *s a i else b i)::'a::comm_ring_1^'n^'n) =
- c* det((\<chi> i. if i = k then a i else b i)::'a::comm_ring_1^'n^'n)"
-
-unfolding det_def Cart_lambda_beta setsum_right_distrib
-proof (rule setsum_cong2)
- let ?U = "UNIV :: 'n set"
- let ?pU = "{p. p permutes ?U}"
- let ?f = "(\<lambda>i. if i = k then c*s a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
- let ?g = "(\<lambda> i. if i = k then a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
- fix p assume p: "p \<in> ?pU"
- let ?Uk = "?U - {k}"
- from p have pU: "p permutes ?U" by blast
- have kU: "?U = insert k ?Uk" by blast
- {fix j assume j: "j \<in> ?Uk"
- from j have "?f j $ p j = ?g j $ p j" by simp}
- then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
- apply -
- apply (rule setprod_cong, simp_all)
- done
- have th3: "finite ?Uk" "k \<notin> ?Uk" by auto
- have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
- unfolding kU[symmetric] ..
- also have "\<dots> = ?f k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
- apply (rule setprod_insert)
- apply simp
- by blast
- also have "\<dots> = (c*s a k) $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk" by (simp add: ring_simps)
- also have "\<dots> = c* (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk)"
- unfolding th1 by (simp add: mult_ac)
- also have "\<dots> = c* (setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk))"
- unfolding setprod_insert[OF th3] by simp
- finally have "setprod (\<lambda>i. ?f i $ p i) ?U = c* (setprod (\<lambda>i. ?g i $ p i) ?U)" unfolding kU[symmetric] .
- then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U = c * (of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U)"
- by (simp add: ring_simps)
-qed
-
-lemma det_row_0:
- fixes b :: "'n::finite \<Rightarrow> _ ^ 'n"
- shows "det((\<chi> i. if i = k then 0 else b i)::'a::comm_ring_1^'n^'n) = 0"
-using det_row_mul[of k 0 "\<lambda>i. 1" b]
-apply (simp)
- unfolding vector_smult_lzero .
-
-lemma det_row_operation:
- fixes A :: "'a::ordered_idom^'n^'n::finite"
- assumes ij: "i \<noteq> j"
- shows "det (\<chi> k. if k = i then row i A + c *s row j A else row k A) = det A"
-proof-
- let ?Z = "(\<chi> k. if k = i then row j A else row k A) :: 'a ^'n^'n"
- have th: "row i ?Z = row j ?Z" by (vector row_def)
- have th2: "((\<chi> k. if k = i then row i A else row k A) :: 'a^'n^'n) = A"
- by (vector row_def)
- show ?thesis
- unfolding det_row_add [of i] det_row_mul[of i] det_identical_rows[OF ij th] th2
- by simp
-qed
-
-lemma det_row_span:
- fixes A :: "'a:: ordered_idom^'n^'n::finite"
- assumes x: "x \<in> span {row j A |j. j \<noteq> i}"
- shows "det (\<chi> k. if k = i then row i A + x else row k A) = det A"
-proof-
- let ?U = "UNIV :: 'n set"
- let ?S = "{row j A |j. j \<noteq> i}"
- let ?d = "\<lambda>x. det (\<chi> k. if k = i then x else row k A)"
- let ?P = "\<lambda>x. ?d (row i A + x) = det A"
- {fix k
-
- have "(if k = i then row i A + 0 else row k A) = row k A" by simp}
- then have P0: "?P 0"
- apply -
- apply (rule cong[of det, OF refl])
- by (vector row_def)
- moreover
- {fix c z y assume zS: "z \<in> ?S" and Py: "?P y"
- from zS obtain j where j: "z = row j A" "i \<noteq> j" by blast
- let ?w = "row i A + y"
- have th0: "row i A + (c*s z + y) = ?w + c*s z" by vector
- have thz: "?d z = 0"
- apply (rule det_identical_rows[OF j(2)])
- using j by (vector row_def)
- have "?d (row i A + (c*s z + y)) = ?d (?w + c*s z)" unfolding th0 ..
- then have "?P (c*s z + y)" unfolding thz Py det_row_mul[of i] det_row_add[of i]
- by simp }
-
- ultimately show ?thesis
- apply -
- apply (rule span_induct_alt[of ?P ?S, OF P0])
- apply blast
- apply (rule x)
- done
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* May as well do this, though it's a bit unsatisfactory since it ignores *)
-(* exact duplicates by considering the rows/columns as a set. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma det_dependent_rows:
- fixes A:: "'a::ordered_idom^'n^'n::finite"
- assumes d: "dependent (rows A)"
- shows "det A = 0"
-proof-
- let ?U = "UNIV :: 'n set"
- from d obtain i where i: "row i A \<in> span (rows A - {row i A})"
- unfolding dependent_def rows_def by blast
- {fix j k assume jk: "j \<noteq> k"
- and c: "row j A = row k A"
- from det_identical_rows[OF jk c] have ?thesis .}
- moreover
- {assume H: "\<And> i j. i \<noteq> j \<Longrightarrow> row i A \<noteq> row j A"
- have th0: "- row i A \<in> span {row j A|j. j \<noteq> i}"
- apply (rule span_neg)
- apply (rule set_rev_mp)
- apply (rule i)
- apply (rule span_mono)
- using H i by (auto simp add: rows_def)
- from det_row_span[OF th0]
- have "det A = det (\<chi> k. if k = i then 0 *s 1 else row k A)"
- unfolding right_minus vector_smult_lzero ..
- with det_row_mul[of i "0::'a" "\<lambda>i. 1"]
- have "det A = 0" by simp}
- ultimately show ?thesis by blast
-qed
-
-lemma det_dependent_columns: assumes d: "dependent(columns (A::'a::ordered_idom^'n^'n::finite))" shows "det A = 0"
-by (metis d det_dependent_rows rows_transp det_transp)
-
-(* ------------------------------------------------------------------------- *)
-(* Multilinearity and the multiplication formula. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma Cart_lambda_cong: "(\<And>x. f x = g x) \<Longrightarrow> (Cart_lambda f::'a^'n) = (Cart_lambda g :: 'a^'n)"
- apply (rule iffD1[OF Cart_lambda_unique]) by vector
-
-lemma det_linear_row_setsum:
- assumes fS: "finite S"
- shows "det ((\<chi> i. if i = k then setsum (a i) S else c i)::'a::comm_ring_1^'n^'n::finite) = setsum (\<lambda>j. det ((\<chi> i. if i = k then a i j else c i)::'a^'n^'n)) S"
-proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case apply simp unfolding setsum_empty det_row_0[of k] ..
-next
- case (2 x F)
- then show ?case by (simp add: det_row_add cong del: if_weak_cong)
-qed
-
-lemma finite_bounded_functions:
- assumes fS: "finite S"
- shows "finite {f. (\<forall>i \<in> {1.. (k::nat)}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1 .. k} \<longrightarrow> f i = i)}"
-proof(induct k)
- case 0
- have th: "{f. \<forall>i. f i = i} = {id}" by (auto intro: ext)
- show ?case by (auto simp add: th)
-next
- case (Suc k)
- let ?f = "\<lambda>(y::nat,g) i. if i = Suc k then y else g i"
- let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>{1..k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1..k} \<longrightarrow> f i = i)})"
- have "?S = {f. (\<forall>i\<in>{1.. Suc k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1.. Suc k} \<longrightarrow> f i = i)}"
- apply (auto simp add: image_iff)
- apply (rule_tac x="x (Suc k)" in bexI)
- apply (rule_tac x = "\<lambda>i. if i = Suc k then i else x i" in exI)
- apply (auto intro: ext)
- done
- with finite_imageI[OF finite_cartesian_product[OF fS Suc.hyps(1)], of ?f]
- show ?case by metis
-qed
-
-
-lemma eq_id_iff[simp]: "(\<forall>x. f x = x) = (f = id)" by (auto intro: ext)
-
-lemma det_linear_rows_setsum_lemma:
- assumes fS: "finite S" and fT: "finite T"
- shows "det((\<chi> i. if i \<in> T then setsum (a i) S else c i):: 'a::comm_ring_1^'n^'n::finite) =
- setsum (\<lambda>f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n))
- {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
-using fT
-proof(induct T arbitrary: a c set: finite)
- case empty
- have th0: "\<And>x y. (\<chi> i. if i \<in> {} then x i else y i) = (\<chi> i. y i)" by vector
- from "empty.prems" show ?case unfolding th0 by simp
-next
- case (insert z T a c)
- let ?F = "\<lambda>T. {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
- let ?h = "\<lambda>(y,g) i. if i = z then y else g i"
- let ?k = "\<lambda>h. (h(z),(\<lambda>i. if i = z then i else h i))"
- let ?s = "\<lambda> k a c f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n)"
- let ?c = "\<lambda>i. if i = z then a i j else c i"
- have thif: "\<And>a b c d. (if a \<or> b then c else d) = (if a then c else if b then c else d)" by simp
- have thif2: "\<And>a b c d e. (if a then b else if c then d else e) =
- (if c then (if a then b else d) else (if a then b else e))" by simp
- from `z \<notin> T` have nz: "\<And>i. i \<in> T \<Longrightarrow> i = z \<longleftrightarrow> False" by auto
- have "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
- det (\<chi> i. if i = z then setsum (a i) S
- else if i \<in> T then setsum (a i) S else c i)"
- unfolding insert_iff thif ..
- also have "\<dots> = (\<Sum>j\<in>S. det (\<chi> i. if i \<in> T then setsum (a i) S
- else if i = z then a i j else c i))"
- unfolding det_linear_row_setsum[OF fS]
- apply (subst thif2)
- using nz by (simp cong del: if_weak_cong cong add: if_cong)
- finally have tha:
- "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
- (\<Sum>(j, f)\<in>S \<times> ?F T. det (\<chi> i. if i \<in> T then a i (f i)
- else if i = z then a i j
- else c i))"
- unfolding insert.hyps unfolding setsum_cartesian_product by blast
- show ?case unfolding tha
- apply(rule setsum_eq_general_reverses[where h= "?h" and k= "?k"],
- blast intro: finite_cartesian_product fS finite,
- blast intro: finite_cartesian_product fS finite)
- using `z \<notin> T`
- apply (auto intro: ext)
- apply (rule cong[OF refl[of det]])
- by vector
-qed
-
-lemma det_linear_rows_setsum:
- assumes fS: "finite (S::'n::finite set)"
- shows "det (\<chi> i. setsum (a i) S) = setsum (\<lambda>f. det (\<chi> i. a i (f i) :: 'a::comm_ring_1 ^ 'n^'n::finite)) {f. \<forall>i. f i \<in> S}"
-proof-
- have th0: "\<And>x y. ((\<chi> i. if i \<in> (UNIV:: 'n set) then x i else y i) :: 'a^'n^'n) = (\<chi> i. x i)" by vector
-
- from det_linear_rows_setsum_lemma[OF fS, of "UNIV :: 'n set" a, unfolded th0, OF finite] show ?thesis by simp
-qed
-
-lemma matrix_mul_setsum_alt:
- fixes A B :: "'a::comm_ring_1^'n^'n::finite"
- shows "A ** B = (\<chi> i. setsum (\<lambda>k. A$i$k *s B $ k) (UNIV :: 'n set))"
- by (vector matrix_matrix_mult_def setsum_component)
-
-lemma det_rows_mul:
- "det((\<chi> i. c i *s a i)::'a::comm_ring_1^'n^'n::finite) =
- setprod (\<lambda>i. c i) (UNIV:: 'n set) * det((\<chi> i. a i)::'a^'n^'n)"
-proof (simp add: det_def setsum_right_distrib cong add: setprod_cong, rule setsum_cong2)
- let ?U = "UNIV :: 'n set"
- let ?PU = "{p. p permutes ?U}"
- fix p assume pU: "p \<in> ?PU"
- let ?s = "of_int (sign p)"
- from pU have p: "p permutes ?U" by blast
- have "setprod (\<lambda>i. c i * a i $ p i) ?U = setprod c ?U * setprod (\<lambda>i. a i $ p i) ?U"
- unfolding setprod_timesf ..
- then show "?s * (\<Prod>xa\<in>?U. c xa * a xa $ p xa) =
- setprod c ?U * (?s* (\<Prod>xa\<in>?U. a xa $ p xa))" by (simp add: ring_simps)
-qed
-
-lemma det_mul:
- fixes A B :: "'a::ordered_idom^'n^'n::finite"
- shows "det (A ** B) = det A * det B"
-proof-
- let ?U = "UNIV :: 'n set"
- let ?F = "{f. (\<forall>i\<in> ?U. f i \<in> ?U) \<and> (\<forall>i. i \<notin> ?U \<longrightarrow> f i = i)}"
- let ?PU = "{p. p permutes ?U}"
- have fU: "finite ?U" by simp
- have fF: "finite ?F" by (rule finite)
- {fix p assume p: "p permutes ?U"
-
- have "p \<in> ?F" unfolding mem_Collect_eq permutes_in_image[OF p]
- using p[unfolded permutes_def] by simp}
- then have PUF: "?PU \<subseteq> ?F" by blast
- {fix f assume fPU: "f \<in> ?F - ?PU"
- have fUU: "f ` ?U \<subseteq> ?U" using fPU by auto
- from fPU have f: "\<forall>i \<in> ?U. f i \<in> ?U"
- "\<forall>i. i \<notin> ?U \<longrightarrow> f i = i" "\<not>(\<forall>y. \<exists>!x. f x = y)" unfolding permutes_def
- by auto
-
- let ?A = "(\<chi> i. A$i$f i *s B$f i) :: 'a^'n^'n"
- let ?B = "(\<chi> i. B$f i) :: 'a^'n^'n"
- {assume fni: "\<not> inj_on f ?U"
- then obtain i j where ij: "f i = f j" "i \<noteq> j"
- unfolding inj_on_def by blast
- from ij
- have rth: "row i ?B = row j ?B" by (vector row_def)
- from det_identical_rows[OF ij(2) rth]
- have "det (\<chi> i. A$i$f i *s B$f i) = 0"
- unfolding det_rows_mul by simp}
- moreover
- {assume fi: "inj_on f ?U"
- from f fi have fith: "\<And>i j. f i = f j \<Longrightarrow> i = j"
- unfolding inj_on_def by metis
- note fs = fi[unfolded surjective_iff_injective_gen[OF fU fU refl fUU, symmetric]]
-
- {fix y
- from fs f have "\<exists>x. f x = y" by blast
- then obtain x where x: "f x = y" by blast
- {fix z assume z: "f z = y" from fith x z have "z = x" by metis}
- with x have "\<exists>!x. f x = y" by blast}
- with f(3) have "det (\<chi> i. A$i$f i *s B$f i) = 0" by blast}
- ultimately have "det (\<chi> i. A$i$f i *s B$f i) = 0" by blast}
- hence zth: "\<forall> f\<in> ?F - ?PU. det (\<chi> i. A$i$f i *s B$f i) = 0" by simp
- {fix p assume pU: "p \<in> ?PU"
- from pU have p: "p permutes ?U" by blast
- let ?s = "\<lambda>p. of_int (sign p)"
- let ?f = "\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) *
- (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))"
- have "(setsum (\<lambda>q. ?s q *
- (\<Prod>i\<in> ?U. (\<chi> i. A $ i $ p i *s B $ p i :: 'a^'n^'n) $ i $ q i)) ?PU) =
- (setsum (\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) *
- (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))) ?PU)"
- unfolding sum_permutations_compose_right[OF permutes_inv[OF p], of ?f]
- proof(rule setsum_cong2)
- fix q assume qU: "q \<in> ?PU"
- hence q: "q permutes ?U" by blast
- from p q have pp: "permutation p" and pq: "permutation q"
- unfolding permutation_permutes by auto
- have th00: "of_int (sign p) * of_int (sign p) = (1::'a)"
- "\<And>a. of_int (sign p) * (of_int (sign p) * a) = a"
- unfolding mult_assoc[symmetric] unfolding of_int_mult[symmetric]
- by (simp_all add: sign_idempotent)
- have ths: "?s q = ?s p * ?s (q o inv p)"
- using pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
- by (simp add: th00 mult_ac sign_idempotent sign_compose)
- have th001: "setprod (\<lambda>i. B$i$ q (inv p i)) ?U = setprod ((\<lambda>i. B$i$ q (inv p i)) o p) ?U"
- by (rule setprod_permute[OF p])
- have thp: "setprod (\<lambda>i. (\<chi> i. A$i$p i *s B$p i :: 'a^'n^'n) $i $ q i) ?U = setprod (\<lambda>i. A$i$p i) ?U * setprod (\<lambda>i. B$i$ q (inv p i)) ?U"
- unfolding th001 setprod_timesf[symmetric] o_def permutes_inverses[OF p]
- apply (rule setprod_cong[OF refl])
- using permutes_in_image[OF q] by vector
- show "?s q * setprod (\<lambda>i. (((\<chi> i. A$i$p i *s B$p i) :: 'a^'n^'n)$i$q i)) ?U = ?s p * (setprod (\<lambda>i. A$i$p i) ?U) * (?s (q o inv p) * setprod (\<lambda>i. B$i$(q o inv p) i) ?U)"
- using ths thp pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
- by (simp add: sign_nz th00 ring_simps sign_idempotent sign_compose)
- qed
- }
- then have th2: "setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU = det A * det B"
- unfolding det_def setsum_product
- by (rule setsum_cong2)
- have "det (A**B) = setsum (\<lambda>f. det (\<chi> i. A $ i $ f i *s B $ f i)) ?F"
- unfolding matrix_mul_setsum_alt det_linear_rows_setsum[OF fU] by simp
- also have "\<dots> = setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU"
- using setsum_mono_zero_cong_left[OF fF PUF zth, symmetric]
- unfolding det_rows_mul by auto
- finally show ?thesis unfolding th2 .
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Relation to invertibility. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma invertible_left_inverse:
- fixes A :: "real^'n^'n::finite"
- shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). B** A = mat 1)"
- by (metis invertible_def matrix_left_right_inverse)
-
-lemma invertible_righ_inverse:
- fixes A :: "real^'n^'n::finite"
- shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). A** B = mat 1)"
- by (metis invertible_def matrix_left_right_inverse)
-
-lemma invertible_det_nz:
- fixes A::"real ^'n^'n::finite"
- shows "invertible A \<longleftrightarrow> det A \<noteq> 0"
-proof-
- {assume "invertible A"
- then obtain B :: "real ^'n^'n" where B: "A ** B = mat 1"
- unfolding invertible_righ_inverse by blast
- hence "det (A ** B) = det (mat 1 :: real ^'n^'n)" by simp
- hence "det A \<noteq> 0"
- apply (simp add: det_mul det_I) by algebra }
- moreover
- {assume H: "\<not> invertible A"
- let ?U = "UNIV :: 'n set"
- have fU: "finite ?U" by simp
- from H obtain c i where c: "setsum (\<lambda>i. c i *s row i A) ?U = 0"
- and iU: "i \<in> ?U" and ci: "c i \<noteq> 0"
- unfolding invertible_righ_inverse
- unfolding matrix_right_invertible_independent_rows by blast
- have stupid: "\<And>(a::real^'n) b. a + b = 0 \<Longrightarrow> -a = b"
- apply (drule_tac f="op + (- a)" in cong[OF refl])
- apply (simp only: ab_left_minus add_assoc[symmetric])
- apply simp
- done
- from c ci
- have thr0: "- row i A = setsum (\<lambda>j. (1/ c i) *s (c j *s row j A)) (?U - {i})"
- unfolding setsum_diff1'[OF fU iU] setsum_cmul
- apply -
- apply (rule vector_mul_lcancel_imp[OF ci])
- apply (auto simp add: vector_smult_assoc vector_smult_rneg field_simps)
- unfolding stupid ..
- have thr: "- row i A \<in> span {row j A| j. j \<noteq> i}"
- unfolding thr0
- apply (rule span_setsum)
- apply simp
- apply (rule ballI)
- apply (rule span_mul)+
- apply (rule span_superset)
- apply auto
- done
- let ?B = "(\<chi> k. if k = i then 0 else row k A) :: real ^'n^'n"
- have thrb: "row i ?B = 0" using iU by (vector row_def)
- have "det A = 0"
- unfolding det_row_span[OF thr, symmetric] right_minus
- unfolding det_zero_row[OF thrb] ..}
- ultimately show ?thesis by blast
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Cramer's rule. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma cramer_lemma_transp:
- fixes A:: "'a::ordered_idom^'n^'n::finite" and x :: "'a ^'n::finite"
- shows "det ((\<chi> i. if i = k then setsum (\<lambda>i. x$i *s row i A) (UNIV::'n set)
- else row i A)::'a^'n^'n) = x$k * det A"
- (is "?lhs = ?rhs")
-proof-
- let ?U = "UNIV :: 'n set"
- let ?Uk = "?U - {k}"
- have U: "?U = insert k ?Uk" by blast
- have fUk: "finite ?Uk" by simp
- have kUk: "k \<notin> ?Uk" by simp
- have th00: "\<And>k s. x$k *s row k A + s = (x$k - 1) *s row k A + row k A + s"
- by (vector ring_simps)
- have th001: "\<And>f k . (\<lambda>x. if x = k then f k else f x) = f" by (auto intro: ext)
- have "(\<chi> i. row i A) = A" by (vector row_def)
- then have thd1: "det (\<chi> i. row i A) = det A" by simp
- have thd0: "det (\<chi> i. if i = k then row k A + (\<Sum>i \<in> ?Uk. x $ i *s row i A) else row i A) = det A"
- apply (rule det_row_span)
- apply (rule span_setsum[OF fUk])
- apply (rule ballI)
- apply (rule span_mul)
- apply (rule span_superset)
- apply auto
- done
- show "?lhs = x$k * det A"
- apply (subst U)
- unfolding setsum_insert[OF fUk kUk]
- apply (subst th00)
- unfolding add_assoc
- apply (subst det_row_add)
- unfolding thd0
- unfolding det_row_mul
- unfolding th001[of k "\<lambda>i. row i A"]
- unfolding thd1 by (simp add: ring_simps)
-qed
-
-lemma cramer_lemma:
- fixes A :: "'a::ordered_idom ^'n^'n::finite"
- shows "det((\<chi> i j. if j = k then (A *v x)$i else A$i$j):: 'a^'n^'n) = x$k * det A"
-proof-
- let ?U = "UNIV :: 'n set"
- have stupid: "\<And>c. setsum (\<lambda>i. c i *s row i (transp A)) ?U = setsum (\<lambda>i. c i *s column i A) ?U"
- by (auto simp add: row_transp intro: setsum_cong2)
- show ?thesis unfolding matrix_mult_vsum
- unfolding cramer_lemma_transp[of k x "transp A", unfolded det_transp, symmetric]
- unfolding stupid[of "\<lambda>i. x$i"]
- apply (subst det_transp[symmetric])
- apply (rule cong[OF refl[of det]]) by (vector transp_def column_def row_def)
-qed
-
-lemma cramer:
- fixes A ::"real^'n^'n::finite"
- assumes d0: "det A \<noteq> 0"
- shows "A *v x = b \<longleftrightarrow> x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j :: real^'n^'n) / det A)"
-proof-
- from d0 obtain B where B: "A ** B = mat 1" "B ** A = mat 1"
- unfolding invertible_det_nz[symmetric] invertible_def by blast
- have "(A ** B) *v b = b" by (simp add: B matrix_vector_mul_lid)
- hence "A *v (B *v b) = b" by (simp add: matrix_vector_mul_assoc)
- then have xe: "\<exists>x. A*v x = b" by blast
- {fix x assume x: "A *v x = b"
- have "x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j :: real^'n^'n) / det A)"
- unfolding x[symmetric]
- using d0 by (simp add: Cart_eq cramer_lemma field_simps)}
- with xe show ?thesis by auto
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Orthogonality of a transformation and matrix. *)
-(* ------------------------------------------------------------------------- *)
-
-definition "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>v w. f v \<bullet> f w = v \<bullet> w)"
-
-lemma orthogonal_transformation: "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>(v::real ^_). norm (f v) = norm v)"
- unfolding orthogonal_transformation_def
- apply auto
- apply (erule_tac x=v in allE)+
- apply (simp add: real_vector_norm_def)
- by (simp add: dot_norm linear_add[symmetric])
-
-definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow> transp Q ** Q = mat 1 \<and> Q ** transp Q = mat 1"
-
-lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n::finite) \<longleftrightarrow> transp Q ** Q = mat 1"
- by (metis matrix_left_right_inverse orthogonal_matrix_def)
-
-lemma orthogonal_matrix_id: "orthogonal_matrix (mat 1 :: _^'n^'n::finite)"
- by (simp add: orthogonal_matrix_def transp_mat matrix_mul_lid)
-
-lemma orthogonal_matrix_mul:
- fixes A :: "real ^'n^'n::finite"
- assumes oA : "orthogonal_matrix A"
- and oB: "orthogonal_matrix B"
- shows "orthogonal_matrix(A ** B)"
- using oA oB
- unfolding orthogonal_matrix matrix_transp_mul
- apply (subst matrix_mul_assoc)
- apply (subst matrix_mul_assoc[symmetric])
- by (simp add: matrix_mul_rid)
-
-lemma orthogonal_transformation_matrix:
- fixes f:: "real^'n \<Rightarrow> real^'n::finite"
- shows "orthogonal_transformation f \<longleftrightarrow> linear f \<and> orthogonal_matrix(matrix f)"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- let ?mf = "matrix f"
- let ?ot = "orthogonal_transformation f"
- let ?U = "UNIV :: 'n set"
- have fU: "finite ?U" by simp
- let ?m1 = "mat 1 :: real ^'n^'n"
- {assume ot: ?ot
- from ot have lf: "linear f" and fd: "\<forall>v w. f v \<bullet> f w = v \<bullet> w"
- unfolding orthogonal_transformation_def orthogonal_matrix by blast+
- {fix i j
- let ?A = "transp ?mf ** ?mf"
- have th0: "\<And>b (x::'a::comm_ring_1). (if b then 1 else 0)*x = (if b then x else 0)"
- "\<And>b (x::'a::comm_ring_1). x*(if b then 1 else 0) = (if b then x else 0)"
- by simp_all
- from fd[rule_format, of "basis i" "basis j", unfolded matrix_works[OF lf, symmetric] dot_matrix_vector_mul]
- have "?A$i$j = ?m1 $ i $ j"
- by (simp add: dot_def matrix_matrix_mult_def columnvector_def rowvector_def basis_def th0 setsum_delta[OF fU] mat_def)}
- hence "orthogonal_matrix ?mf" unfolding orthogonal_matrix by vector
- with lf have ?rhs by blast}
- moreover
- {assume lf: "linear f" and om: "orthogonal_matrix ?mf"
- from lf om have ?lhs
- unfolding orthogonal_matrix_def norm_eq orthogonal_transformation
- unfolding matrix_works[OF lf, symmetric]
- apply (subst dot_matrix_vector_mul)
- by (simp add: dot_matrix_product matrix_mul_lid)}
- ultimately show ?thesis by blast
-qed
-
-lemma det_orthogonal_matrix:
- fixes Q:: "'a::ordered_idom^'n^'n::finite"
- assumes oQ: "orthogonal_matrix Q"
- shows "det Q = 1 \<or> det Q = - 1"
-proof-
-
- have th: "\<And>x::'a. x = 1 \<or> x = - 1 \<longleftrightarrow> x*x = 1" (is "\<And>x::'a. ?ths x")
- proof-
- fix x:: 'a
- have th0: "x*x - 1 = (x - 1)*(x + 1)" by (simp add: ring_simps)
- have th1: "\<And>(x::'a) y. x = - y \<longleftrightarrow> x + y = 0"
- apply (subst eq_iff_diff_eq_0) by simp
- have "x*x = 1 \<longleftrightarrow> x*x - 1 = 0" by simp
- also have "\<dots> \<longleftrightarrow> x = 1 \<or> x = - 1" unfolding th0 th1 by simp
- finally show "?ths x" ..
- qed
- from oQ have "Q ** transp Q = mat 1" by (metis orthogonal_matrix_def)
- hence "det (Q ** transp Q) = det (mat 1:: 'a^'n^'n)" by simp
- hence "det Q * det Q = 1" by (simp add: det_mul det_I det_transp)
- then show ?thesis unfolding th .
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Linearity of scaling, and hence isometry, that preserves origin. *)
-(* ------------------------------------------------------------------------- *)
-lemma scaling_linear:
- fixes f :: "real ^'n \<Rightarrow> real ^'n::finite"
- assumes f0: "f 0 = 0" and fd: "\<forall>x y. dist (f x) (f y) = c * dist x y"
- shows "linear f"
-proof-
- {fix v w
- {fix x note fd[rule_format, of x 0, unfolded dist_norm f0 diff_0_right] }
- note th0 = this
- have "f v \<bullet> f w = c^2 * (v \<bullet> w)"
- unfolding dot_norm_neg dist_norm[symmetric]
- unfolding th0 fd[rule_format] by (simp add: power2_eq_square field_simps)}
- note fc = this
- show ?thesis unfolding linear_def vector_eq
- by (simp add: dot_lmult dot_ladd dot_rmult dot_radd fc ring_simps)
-qed
-
-lemma isometry_linear:
- "f (0:: real^'n) = (0:: real^'n::finite) \<Longrightarrow> \<forall>x y. dist(f x) (f y) = dist x y
- \<Longrightarrow> linear f"
-by (rule scaling_linear[where c=1]) simp_all
-
-(* ------------------------------------------------------------------------- *)
-(* Hence another formulation of orthogonal transformation. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma orthogonal_transformation_isometry:
- "orthogonal_transformation f \<longleftrightarrow> f(0::real^'n) = (0::real^'n::finite) \<and> (\<forall>x y. dist(f x) (f y) = dist x y)"
- unfolding orthogonal_transformation
- apply (rule iffI)
- apply clarify
- apply (clarsimp simp add: linear_0 linear_sub[symmetric] dist_norm)
- apply (rule conjI)
- apply (rule isometry_linear)
- apply simp
- apply simp
- apply clarify
- apply (erule_tac x=v in allE)
- apply (erule_tac x=0 in allE)
- by (simp add: dist_norm)
-
-(* ------------------------------------------------------------------------- *)
-(* Can extend an isometry from unit sphere. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma isometry_sphere_extend:
- fixes f:: "real ^'n \<Rightarrow> real ^'n::finite"
- assumes f1: "\<forall>x. norm x = 1 \<longrightarrow> norm (f x) = 1"
- and fd1: "\<forall> x y. norm x = 1 \<longrightarrow> norm y = 1 \<longrightarrow> dist (f x) (f y) = dist x y"
- shows "\<exists>g. orthogonal_transformation g \<and> (\<forall>x. norm x = 1 \<longrightarrow> g x = f x)"
-proof-
- {fix x y x' y' x0 y0 x0' y0' :: "real ^'n"
- assume H: "x = norm x *s x0" "y = norm y *s y0"
- "x' = norm x *s x0'" "y' = norm y *s y0'"
- "norm x0 = 1" "norm x0' = 1" "norm y0 = 1" "norm y0' = 1"
- "norm(x0' - y0') = norm(x0 - y0)"
-
- have "norm(x' - y') = norm(x - y)"
- apply (subst H(1))
- apply (subst H(2))
- apply (subst H(3))
- apply (subst H(4))
- using H(5-9)
- apply (simp add: norm_eq norm_eq_1)
- apply (simp add: dot_lsub dot_rsub dot_lmult dot_rmult)
- apply (simp add: ring_simps)
- by (simp only: right_distrib[symmetric])}
- note th0 = this
- let ?g = "\<lambda>x. if x = 0 then 0 else norm x *s f (inverse (norm x) *s x)"
- {fix x:: "real ^'n" assume nx: "norm x = 1"
- have "?g x = f x" using nx by auto}
- hence thfg: "\<forall>x. norm x = 1 \<longrightarrow> ?g x = f x" by blast
- have g0: "?g 0 = 0" by simp
- {fix x y :: "real ^'n"
- {assume "x = 0" "y = 0"
- then have "dist (?g x) (?g y) = dist x y" by simp }
- moreover
- {assume "x = 0" "y \<noteq> 0"
- then have "dist (?g x) (?g y) = dist x y"
- apply (simp add: dist_norm norm_mul)
- apply (rule f1[rule_format])
- by(simp add: norm_mul field_simps)}
- moreover
- {assume "x \<noteq> 0" "y = 0"
- then have "dist (?g x) (?g y) = dist x y"
- apply (simp add: dist_norm norm_mul)
- apply (rule f1[rule_format])
- by(simp add: norm_mul field_simps)}
- moreover
- {assume z: "x \<noteq> 0" "y \<noteq> 0"
- have th00: "x = norm x *s (inverse (norm x) *s x)" "y = norm y *s (inverse (norm y) *s y)" "norm x *s f ((inverse (norm x) *s x)) = norm x *s f (inverse (norm x) *s x)"
- "norm y *s f (inverse (norm y) *s y) = norm y *s f (inverse (norm y) *s y)"
- "norm (inverse (norm x) *s x) = 1"
- "norm (f (inverse (norm x) *s x)) = 1"
- "norm (inverse (norm y) *s y) = 1"
- "norm (f (inverse (norm y) *s y)) = 1"
- "norm (f (inverse (norm x) *s x) - f (inverse (norm y) *s y)) =
- norm (inverse (norm x) *s x - inverse (norm y) *s y)"
- using z
- by (auto simp add: vector_smult_assoc field_simps norm_mul intro: f1[rule_format] fd1[rule_format, unfolded dist_norm])
- from z th0[OF th00] have "dist (?g x) (?g y) = dist x y"
- by (simp add: dist_norm)}
- ultimately have "dist (?g x) (?g y) = dist x y" by blast}
- note thd = this
- show ?thesis
- apply (rule exI[where x= ?g])
- unfolding orthogonal_transformation_isometry
- using g0 thfg thd by metis
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Rotation, reflection, rotoinversion. *)
-(* ------------------------------------------------------------------------- *)
-
-definition "rotation_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = 1"
-definition "rotoinversion_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = - 1"
-
-lemma orthogonal_rotation_or_rotoinversion:
- fixes Q :: "'a::ordered_idom^'n^'n::finite"
- shows " orthogonal_matrix Q \<longleftrightarrow> rotation_matrix Q \<or> rotoinversion_matrix Q"
- by (metis rotoinversion_matrix_def rotation_matrix_def det_orthogonal_matrix)
-(* ------------------------------------------------------------------------- *)
-(* Explicit formulas for low dimensions. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma setprod_1: "setprod f {(1::nat)..1} = f 1" by simp
-
-lemma setprod_2: "setprod f {(1::nat)..2} = f 1 * f 2"
- by (simp add: nat_number setprod_numseg mult_commute)
-lemma setprod_3: "setprod f {(1::nat)..3} = f 1 * f 2 * f 3"
- by (simp add: nat_number setprod_numseg mult_commute)
-
-lemma det_1: "det (A::'a::comm_ring_1^1^1) = A$1$1"
- by (simp add: det_def permutes_sing sign_id UNIV_1)
-
-lemma det_2: "det (A::'a::comm_ring_1^2^2) = A$1$1 * A$2$2 - A$1$2 * A$2$1"
-proof-
- have f12: "finite {2::2}" "1 \<notin> {2::2}" by auto
- show ?thesis
- unfolding det_def UNIV_2
- unfolding setsum_over_permutations_insert[OF f12]
- unfolding permutes_sing
- apply (simp add: sign_swap_id sign_id swap_id_eq)
- by (simp add: arith_simps(31)[symmetric] of_int_minus of_int_1 del: arith_simps(31))
-qed
-
-lemma det_3: "det (A::'a::comm_ring_1^3^3) =
- A$1$1 * A$2$2 * A$3$3 +
- A$1$2 * A$2$3 * A$3$1 +
- A$1$3 * A$2$1 * A$3$2 -
- A$1$1 * A$2$3 * A$3$2 -
- A$1$2 * A$2$1 * A$3$3 -
- A$1$3 * A$2$2 * A$3$1"
-proof-
- have f123: "finite {2::3, 3}" "1 \<notin> {2::3, 3}" by auto
- have f23: "finite {3::3}" "2 \<notin> {3::3}" by auto
-
- show ?thesis
- unfolding det_def UNIV_3
- unfolding setsum_over_permutations_insert[OF f123]
- unfolding setsum_over_permutations_insert[OF f23]
-
- unfolding permutes_sing
- apply (simp add: sign_swap_id permutation_swap_id sign_compose sign_id swap_id_eq)
- apply (simp add: arith_simps(31)[symmetric] of_int_minus of_int_1 del: arith_simps(31))
- by (simp add: ring_simps)
-qed
-
-end--- a/src/HOL/Library/Euclidean_Space.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,5115 +0,0 @@
-(* Title: Library/Euclidean_Space
- Author: Amine Chaieb, University of Cambridge
-*)
-
-header {* (Real) Vectors in Euclidean space, and elementary linear algebra.*}
-
-theory Euclidean_Space
-imports
- Complex_Main "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
- Finite_Cartesian_Product Glbs Infinite_Set Numeral_Type
- Inner_Product
-uses "positivstellensatz.ML" ("normarith.ML")
-begin
-
-text{* Some common special cases.*}
-
-lemma forall_1: "(\<forall>i::1. P i) \<longleftrightarrow> P 1"
- by (metis num1_eq_iff)
-
-lemma exhaust_2:
- fixes x :: 2 shows "x = 1 \<or> x = 2"
-proof (induct x)
- case (of_int z)
- then have "0 <= z" and "z < 2" by simp_all
- then have "z = 0 | z = 1" by arith
- then show ?case by auto
-qed
-
-lemma forall_2: "(\<forall>i::2. P i) \<longleftrightarrow> P 1 \<and> P 2"
- by (metis exhaust_2)
-
-lemma exhaust_3:
- fixes x :: 3 shows "x = 1 \<or> x = 2 \<or> x = 3"
-proof (induct x)
- case (of_int z)
- then have "0 <= z" and "z < 3" by simp_all
- then have "z = 0 \<or> z = 1 \<or> z = 2" by arith
- then show ?case by auto
-qed
-
-lemma forall_3: "(\<forall>i::3. P i) \<longleftrightarrow> P 1 \<and> P 2 \<and> P 3"
- by (metis exhaust_3)
-
-lemma UNIV_1: "UNIV = {1::1}"
- by (auto simp add: num1_eq_iff)
-
-lemma UNIV_2: "UNIV = {1::2, 2::2}"
- using exhaust_2 by auto
-
-lemma UNIV_3: "UNIV = {1::3, 2::3, 3::3}"
- using exhaust_3 by auto
-
-lemma setsum_1: "setsum f (UNIV::1 set) = f 1"
- unfolding UNIV_1 by simp
-
-lemma setsum_2: "setsum f (UNIV::2 set) = f 1 + f 2"
- unfolding UNIV_2 by simp
-
-lemma setsum_3: "setsum f (UNIV::3 set) = f 1 + f 2 + f 3"
- unfolding UNIV_3 by (simp add: add_ac)
-
-subsection{* Basic componentwise operations on vectors. *}
-
-instantiation "^" :: (plus,type) plus
-begin
-definition vector_add_def : "op + \<equiv> (\<lambda> x y. (\<chi> i. (x$i) + (y$i)))"
-instance ..
-end
-
-instantiation "^" :: (times,type) times
-begin
- definition vector_mult_def : "op * \<equiv> (\<lambda> x y. (\<chi> i. (x$i) * (y$i)))"
- instance ..
-end
-
-instantiation "^" :: (minus,type) minus begin
- definition vector_minus_def : "op - \<equiv> (\<lambda> x y. (\<chi> i. (x$i) - (y$i)))"
-instance ..
-end
-
-instantiation "^" :: (uminus,type) uminus begin
- definition vector_uminus_def : "uminus \<equiv> (\<lambda> x. (\<chi> i. - (x$i)))"
-instance ..
-end
-instantiation "^" :: (zero,type) zero begin
- definition vector_zero_def : "0 \<equiv> (\<chi> i. 0)"
-instance ..
-end
-
-instantiation "^" :: (one,type) one begin
- definition vector_one_def : "1 \<equiv> (\<chi> i. 1)"
-instance ..
-end
-
-instantiation "^" :: (ord,type) ord
- begin
-definition vector_less_eq_def:
- "less_eq (x :: 'a ^'b) y = (ALL i. x$i <= y$i)"
-definition vector_less_def: "less (x :: 'a ^'b) y = (ALL i. x$i < y$i)"
-
-instance by (intro_classes)
-end
-
-instantiation "^" :: (scaleR, type) scaleR
-begin
-definition vector_scaleR_def: "scaleR = (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"
-instance ..
-end
-
-text{* Also the scalar-vector multiplication. *}
-
-definition vector_scalar_mult:: "'a::times \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'n" (infixl "*s" 70)
- where "c *s x = (\<chi> i. c * (x$i))"
-
-text{* Constant Vectors *}
-
-definition "vec x = (\<chi> i. x)"
-
-text{* Dot products. *}
-
-definition dot :: "'a::{comm_monoid_add, times} ^ 'n \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a" (infix "\<bullet>" 70) where
- "x \<bullet> y = setsum (\<lambda>i. x$i * y$i) UNIV"
-
-lemma dot_1[simp]: "(x::'a::{comm_monoid_add, times}^1) \<bullet> y = (x$1) * (y$1)"
- by (simp add: dot_def setsum_1)
-
-lemma dot_2[simp]: "(x::'a::{comm_monoid_add, times}^2) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2)"
- by (simp add: dot_def setsum_2)
-
-lemma dot_3[simp]: "(x::'a::{comm_monoid_add, times}^3) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2) + (x$3) * (y$3)"
- by (simp add: dot_def setsum_3)
-
-subsection {* A naive proof procedure to lift really trivial arithmetic stuff from the basis of the vector space. *}
-
-method_setup vector = {*
-let
- val ss1 = HOL_basic_ss addsimps [@{thm dot_def}, @{thm setsum_addf} RS sym,
- @{thm setsum_subtractf} RS sym, @{thm setsum_right_distrib},
- @{thm setsum_left_distrib}, @{thm setsum_negf} RS sym]
- val ss2 = @{simpset} addsimps
- [@{thm vector_add_def}, @{thm vector_mult_def},
- @{thm vector_minus_def}, @{thm vector_uminus_def},
- @{thm vector_one_def}, @{thm vector_zero_def}, @{thm vec_def},
- @{thm vector_scaleR_def},
- @{thm Cart_lambda_beta}, @{thm vector_scalar_mult_def}]
- fun vector_arith_tac ths =
- simp_tac ss1
- THEN' (fn i => rtac @{thm setsum_cong2} i
- ORELSE rtac @{thm setsum_0'} i
- ORELSE simp_tac (HOL_basic_ss addsimps [@{thm "Cart_eq"}]) i)
- (* THEN' TRY o clarify_tac HOL_cs THEN' (TRY o rtac @{thm iffI}) *)
- THEN' asm_full_simp_tac (ss2 addsimps ths)
- in
- Attrib.thms >> (fn ths => K (SIMPLE_METHOD' (vector_arith_tac ths)))
- end
-*} "Lifts trivial vector statements to real arith statements"
-
-lemma vec_0[simp]: "vec 0 = 0" by (vector vector_zero_def)
-lemma vec_1[simp]: "vec 1 = 1" by (vector vector_one_def)
-
-
-
-text{* Obvious "component-pushing". *}
-
-lemma vec_component [simp]: "(vec x :: 'a ^ 'n)$i = x"
- by (vector vec_def)
-
-lemma vector_add_component [simp]:
- fixes x y :: "'a::{plus} ^ 'n"
- shows "(x + y)$i = x$i + y$i"
- by vector
-
-lemma vector_minus_component [simp]:
- fixes x y :: "'a::{minus} ^ 'n"
- shows "(x - y)$i = x$i - y$i"
- by vector
-
-lemma vector_mult_component [simp]:
- fixes x y :: "'a::{times} ^ 'n"
- shows "(x * y)$i = x$i * y$i"
- by vector
-
-lemma vector_smult_component [simp]:
- fixes y :: "'a::{times} ^ 'n"
- shows "(c *s y)$i = c * (y$i)"
- by vector
-
-lemma vector_uminus_component [simp]:
- fixes x :: "'a::{uminus} ^ 'n"
- shows "(- x)$i = - (x$i)"
- by vector
-
-lemma vector_scaleR_component [simp]:
- fixes x :: "'a::scaleR ^ 'n"
- shows "(scaleR r x)$i = scaleR r (x$i)"
- by vector
-
-lemma cond_component: "(if b then x else y)$i = (if b then x$i else y$i)" by vector
-
-lemmas vector_component =
- vec_component vector_add_component vector_mult_component
- vector_smult_component vector_minus_component vector_uminus_component
- vector_scaleR_component cond_component
-
-subsection {* Some frequently useful arithmetic lemmas over vectors. *}
-
-instance "^" :: (semigroup_add,type) semigroup_add
- apply (intro_classes) by (vector add_assoc)
-
-
-instance "^" :: (monoid_add,type) monoid_add
- apply (intro_classes) by vector+
-
-instance "^" :: (group_add,type) group_add
- apply (intro_classes) by (vector algebra_simps)+
-
-instance "^" :: (ab_semigroup_add,type) ab_semigroup_add
- apply (intro_classes) by (vector add_commute)
-
-instance "^" :: (comm_monoid_add,type) comm_monoid_add
- apply (intro_classes) by vector
-
-instance "^" :: (ab_group_add,type) ab_group_add
- apply (intro_classes) by vector+
-
-instance "^" :: (cancel_semigroup_add,type) cancel_semigroup_add
- apply (intro_classes)
- by (vector Cart_eq)+
-
-instance "^" :: (cancel_ab_semigroup_add,type) cancel_ab_semigroup_add
- apply (intro_classes)
- by (vector Cart_eq)
-
-instance "^" :: (real_vector, type) real_vector
- by default (vector scaleR_left_distrib scaleR_right_distrib)+
-
-instance "^" :: (semigroup_mult,type) semigroup_mult
- apply (intro_classes) by (vector mult_assoc)
-
-instance "^" :: (monoid_mult,type) monoid_mult
- apply (intro_classes) by vector+
-
-instance "^" :: (ab_semigroup_mult,type) ab_semigroup_mult
- apply (intro_classes) by (vector mult_commute)
-
-instance "^" :: (ab_semigroup_idem_mult,type) ab_semigroup_idem_mult
- apply (intro_classes) by (vector mult_idem)
-
-instance "^" :: (comm_monoid_mult,type) comm_monoid_mult
- apply (intro_classes) by vector
-
-fun vector_power :: "('a::{one,times} ^'n) \<Rightarrow> nat \<Rightarrow> 'a^'n" where
- "vector_power x 0 = 1"
- | "vector_power x (Suc n) = x * vector_power x n"
-
-instance "^" :: (semiring,type) semiring
- apply (intro_classes) by (vector ring_simps)+
-
-instance "^" :: (semiring_0,type) semiring_0
- apply (intro_classes) by (vector ring_simps)+
-instance "^" :: (semiring_1,type) semiring_1
- apply (intro_classes) by vector
-instance "^" :: (comm_semiring,type) comm_semiring
- apply (intro_classes) by (vector ring_simps)+
-
-instance "^" :: (comm_semiring_0,type) comm_semiring_0 by (intro_classes)
-instance "^" :: (cancel_comm_monoid_add, type) cancel_comm_monoid_add ..
-instance "^" :: (semiring_0_cancel,type) semiring_0_cancel by (intro_classes)
-instance "^" :: (comm_semiring_0_cancel,type) comm_semiring_0_cancel by (intro_classes)
-instance "^" :: (ring,type) ring by (intro_classes)
-instance "^" :: (semiring_1_cancel,type) semiring_1_cancel by (intro_classes)
-instance "^" :: (comm_semiring_1,type) comm_semiring_1 by (intro_classes)
-
-instance "^" :: (ring_1,type) ring_1 ..
-
-instance "^" :: (real_algebra,type) real_algebra
- apply intro_classes
- apply (simp_all add: vector_scaleR_def ring_simps)
- apply vector
- apply vector
- done
-
-instance "^" :: (real_algebra_1,type) real_algebra_1 ..
-
-lemma of_nat_index:
- "(of_nat n :: 'a::semiring_1 ^'n)$i = of_nat n"
- apply (induct n)
- apply vector
- apply vector
- done
-lemma zero_index[simp]:
- "(0 :: 'a::zero ^'n)$i = 0" by vector
-
-lemma one_index[simp]:
- "(1 :: 'a::one ^'n)$i = 1" by vector
-
-lemma one_plus_of_nat_neq_0: "(1::'a::semiring_char_0) + of_nat n \<noteq> 0"
-proof-
- have "(1::'a) + of_nat n = 0 \<longleftrightarrow> of_nat 1 + of_nat n = (of_nat 0 :: 'a)" by simp
- also have "\<dots> \<longleftrightarrow> 1 + n = 0" by (simp only: of_nat_add[symmetric] of_nat_eq_iff)
- finally show ?thesis by simp
-qed
-
-instance "^" :: (semiring_char_0,type) semiring_char_0
-proof (intro_classes)
- fix m n ::nat
- show "(of_nat m :: 'a^'b) = of_nat n \<longleftrightarrow> m = n"
- by (simp add: Cart_eq of_nat_index)
-qed
-
-instance "^" :: (comm_ring_1,type) comm_ring_1 by intro_classes
-instance "^" :: (ring_char_0,type) ring_char_0 by intro_classes
-
-lemma vector_smult_assoc: "a *s (b *s x) = ((a::'a::semigroup_mult) * b) *s x"
- by (vector mult_assoc)
-lemma vector_sadd_rdistrib: "((a::'a::semiring) + b) *s x = a *s x + b *s x"
- by (vector ring_simps)
-lemma vector_add_ldistrib: "(c::'a::semiring) *s (x + y) = c *s x + c *s y"
- by (vector ring_simps)
-lemma vector_smult_lzero[simp]: "(0::'a::mult_zero) *s x = 0" by vector
-lemma vector_smult_lid[simp]: "(1::'a::monoid_mult) *s x = x" by vector
-lemma vector_ssub_ldistrib: "(c::'a::ring) *s (x - y) = c *s x - c *s y"
- by (vector ring_simps)
-lemma vector_smult_rneg: "(c::'a::ring) *s -x = -(c *s x)" by vector
-lemma vector_smult_lneg: "- (c::'a::ring) *s x = -(c *s x)" by vector
-lemma vector_sneg_minus1: "-x = (- (1::'a::ring_1)) *s x" by vector
-lemma vector_smult_rzero[simp]: "c *s 0 = (0::'a::mult_zero ^ 'n)" by vector
-lemma vector_sub_rdistrib: "((a::'a::ring) - b) *s x = a *s x - b *s x"
- by (vector ring_simps)
-
-lemma vec_eq[simp]: "(vec m = vec n) \<longleftrightarrow> (m = n)"
- by (simp add: Cart_eq)
-
-subsection {* Topological space *}
-
-instantiation "^" :: (topological_space, finite) topological_space
-begin
-
-definition open_vector_def:
- "open (S :: ('a ^ 'b) set) \<longleftrightarrow>
- (\<forall>x\<in>S. \<exists>A. (\<forall>i. open (A i) \<and> x$i \<in> A i) \<and>
- (\<forall>y. (\<forall>i. y$i \<in> A i) \<longrightarrow> y \<in> S))"
-
-instance proof
- show "open (UNIV :: ('a ^ 'b) set)"
- unfolding open_vector_def by auto
-next
- fix S T :: "('a ^ 'b) set"
- assume "open S" "open T" thus "open (S \<inter> T)"
- unfolding open_vector_def
- apply clarify
- apply (drule (1) bspec)+
- apply (clarify, rename_tac Sa Ta)
- apply (rule_tac x="\<lambda>i. Sa i \<inter> Ta i" in exI)
- apply (simp add: open_Int)
- done
-next
- fix K :: "('a ^ 'b) set set"
- assume "\<forall>S\<in>K. open S" thus "open (\<Union>K)"
- unfolding open_vector_def
- apply clarify
- apply (drule (1) bspec)
- apply (drule (1) bspec)
- apply clarify
- apply (rule_tac x=A in exI)
- apply fast
- done
-qed
-
-end
-
-lemma open_vector_box: "\<forall>i. open (S i) \<Longrightarrow> open {x. \<forall>i. x $ i \<in> S i}"
-unfolding open_vector_def by auto
-
-lemma open_vimage_Cart_nth: "open S \<Longrightarrow> open ((\<lambda>x. x $ i) -` S)"
-unfolding open_vector_def
-apply clarify
-apply (rule_tac x="\<lambda>k. if k = i then S else UNIV" in exI, simp)
-done
-
-lemma closed_vimage_Cart_nth: "closed S \<Longrightarrow> closed ((\<lambda>x. x $ i) -` S)"
-unfolding closed_open vimage_Compl [symmetric]
-by (rule open_vimage_Cart_nth)
-
-lemma closed_vector_box: "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
-proof -
- have "{x. \<forall>i. x $ i \<in> S i} = (\<Inter>i. (\<lambda>x. x $ i) -` S i)" by auto
- thus "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
- by (simp add: closed_INT closed_vimage_Cart_nth)
-qed
-
-lemma tendsto_Cart_nth [tendsto_intros]:
- assumes "((\<lambda>x. f x) ---> a) net"
- shows "((\<lambda>x. f x $ i) ---> a $ i) net"
-proof (rule topological_tendstoI)
- fix S assume "open S" "a $ i \<in> S"
- then have "open ((\<lambda>y. y $ i) -` S)" "a \<in> ((\<lambda>y. y $ i) -` S)"
- by (simp_all add: open_vimage_Cart_nth)
- with assms have "eventually (\<lambda>x. f x \<in> (\<lambda>y. y $ i) -` S) net"
- by (rule topological_tendstoD)
- then show "eventually (\<lambda>x. f x $ i \<in> S) net"
- by simp
-qed
-
-subsection {* Square root of sum of squares *}
-
-definition
- "setL2 f A = sqrt (\<Sum>i\<in>A. (f i)\<twosuperior>)"
-
-lemma setL2_cong:
- "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
- unfolding setL2_def by simp
-
-lemma strong_setL2_cong:
- "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
- unfolding setL2_def simp_implies_def by simp
-
-lemma setL2_infinite [simp]: "\<not> finite A \<Longrightarrow> setL2 f A = 0"
- unfolding setL2_def by simp
-
-lemma setL2_empty [simp]: "setL2 f {} = 0"
- unfolding setL2_def by simp
-
-lemma setL2_insert [simp]:
- "\<lbrakk>finite F; a \<notin> F\<rbrakk> \<Longrightarrow>
- setL2 f (insert a F) = sqrt ((f a)\<twosuperior> + (setL2 f F)\<twosuperior>)"
- unfolding setL2_def by (simp add: setsum_nonneg)
-
-lemma setL2_nonneg [simp]: "0 \<le> setL2 f A"
- unfolding setL2_def by (simp add: setsum_nonneg)
-
-lemma setL2_0': "\<forall>a\<in>A. f a = 0 \<Longrightarrow> setL2 f A = 0"
- unfolding setL2_def by simp
-
-lemma setL2_constant: "setL2 (\<lambda>x. y) A = sqrt (of_nat (card A)) * \<bar>y\<bar>"
- unfolding setL2_def by (simp add: real_sqrt_mult)
-
-lemma setL2_mono:
- assumes "\<And>i. i \<in> K \<Longrightarrow> f i \<le> g i"
- assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
- shows "setL2 f K \<le> setL2 g K"
- unfolding setL2_def
- by (simp add: setsum_nonneg setsum_mono power_mono prems)
-
-lemma setL2_strict_mono:
- assumes "finite K" and "K \<noteq> {}"
- assumes "\<And>i. i \<in> K \<Longrightarrow> f i < g i"
- assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
- shows "setL2 f K < setL2 g K"
- unfolding setL2_def
- by (simp add: setsum_strict_mono power_strict_mono assms)
-
-lemma setL2_right_distrib:
- "0 \<le> r \<Longrightarrow> r * setL2 f A = setL2 (\<lambda>x. r * f x) A"
- unfolding setL2_def
- apply (simp add: power_mult_distrib)
- apply (simp add: setsum_right_distrib [symmetric])
- apply (simp add: real_sqrt_mult setsum_nonneg)
- done
-
-lemma setL2_left_distrib:
- "0 \<le> r \<Longrightarrow> setL2 f A * r = setL2 (\<lambda>x. f x * r) A"
- unfolding setL2_def
- apply (simp add: power_mult_distrib)
- apply (simp add: setsum_left_distrib [symmetric])
- apply (simp add: real_sqrt_mult setsum_nonneg)
- done
-
-lemma setsum_nonneg_eq_0_iff:
- fixes f :: "'a \<Rightarrow> 'b::pordered_ab_group_add"
- shows "\<lbrakk>finite A; \<forall>x\<in>A. 0 \<le> f x\<rbrakk> \<Longrightarrow> setsum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
- apply (induct set: finite, simp)
- apply (simp add: add_nonneg_eq_0_iff setsum_nonneg)
- done
-
-lemma setL2_eq_0_iff: "finite A \<Longrightarrow> setL2 f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
- unfolding setL2_def
- by (simp add: setsum_nonneg setsum_nonneg_eq_0_iff)
-
-lemma setL2_triangle_ineq:
- shows "setL2 (\<lambda>i. f i + g i) A \<le> setL2 f A + setL2 g A"
-proof (cases "finite A")
- case False
- thus ?thesis by simp
-next
- case True
- thus ?thesis
- proof (induct set: finite)
- case empty
- show ?case by simp
- next
- case (insert x F)
- hence "sqrt ((f x + g x)\<twosuperior> + (setL2 (\<lambda>i. f i + g i) F)\<twosuperior>) \<le>
- sqrt ((f x + g x)\<twosuperior> + (setL2 f F + setL2 g F)\<twosuperior>)"
- by (intro real_sqrt_le_mono add_left_mono power_mono insert
- setL2_nonneg add_increasing zero_le_power2)
- also have
- "\<dots> \<le> sqrt ((f x)\<twosuperior> + (setL2 f F)\<twosuperior>) + sqrt ((g x)\<twosuperior> + (setL2 g F)\<twosuperior>)"
- by (rule real_sqrt_sum_squares_triangle_ineq)
- finally show ?case
- using insert by simp
- qed
-qed
-
-lemma sqrt_sum_squares_le_sum:
- "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> sqrt (x\<twosuperior> + y\<twosuperior>) \<le> x + y"
- apply (rule power2_le_imp_le)
- apply (simp add: power2_sum)
- apply (simp add: mult_nonneg_nonneg)
- apply (simp add: add_nonneg_nonneg)
- done
-
-lemma setL2_le_setsum [rule_format]:
- "(\<forall>i\<in>A. 0 \<le> f i) \<longrightarrow> setL2 f A \<le> setsum f A"
- apply (cases "finite A")
- apply (induct set: finite)
- apply simp
- apply clarsimp
- apply (erule order_trans [OF sqrt_sum_squares_le_sum])
- apply simp
- apply simp
- apply simp
- done
-
-lemma sqrt_sum_squares_le_sum_abs: "sqrt (x\<twosuperior> + y\<twosuperior>) \<le> \<bar>x\<bar> + \<bar>y\<bar>"
- apply (rule power2_le_imp_le)
- apply (simp add: power2_sum)
- apply (simp add: mult_nonneg_nonneg)
- apply (simp add: add_nonneg_nonneg)
- done
-
-lemma setL2_le_setsum_abs: "setL2 f A \<le> (\<Sum>i\<in>A. \<bar>f i\<bar>)"
- apply (cases "finite A")
- apply (induct set: finite)
- apply simp
- apply simp
- apply (rule order_trans [OF sqrt_sum_squares_le_sum_abs])
- apply simp
- apply simp
- done
-
-lemma setL2_mult_ineq_lemma:
- fixes a b c d :: real
- shows "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
-proof -
- have "0 \<le> (a * d - b * c)\<twosuperior>" by simp
- also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * d) * (b * c)"
- by (simp only: power2_diff power_mult_distrib)
- also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * c) * (b * d)"
- by simp
- finally show "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
- by simp
-qed
-
-lemma setL2_mult_ineq: "(\<Sum>i\<in>A. \<bar>f i\<bar> * \<bar>g i\<bar>) \<le> setL2 f A * setL2 g A"
- apply (cases "finite A")
- apply (induct set: finite)
- apply simp
- apply (rule power2_le_imp_le, simp)
- apply (rule order_trans)
- apply (rule power_mono)
- apply (erule add_left_mono)
- apply (simp add: add_nonneg_nonneg mult_nonneg_nonneg setsum_nonneg)
- apply (simp add: power2_sum)
- apply (simp add: power_mult_distrib)
- apply (simp add: right_distrib left_distrib)
- apply (rule ord_le_eq_trans)
- apply (rule setL2_mult_ineq_lemma)
- apply simp
- apply (intro mult_nonneg_nonneg setL2_nonneg)
- apply simp
- done
-
-lemma member_le_setL2: "\<lbrakk>finite A; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le> setL2 f A"
- apply (rule_tac s="insert i (A - {i})" and t="A" in subst)
- apply fast
- apply (subst setL2_insert)
- apply simp
- apply simp
- apply simp
- done
-
-subsection {* Metric *}
-
-(* TODO: move somewhere else *)
-lemma finite_choice: "finite A \<Longrightarrow> \<forall>x\<in>A. \<exists>y. P x y \<Longrightarrow> \<exists>f. \<forall>x\<in>A. P x (f x)"
-apply (induct set: finite, simp_all)
-apply (clarify, rename_tac y)
-apply (rule_tac x="f(x:=y)" in exI, simp)
-done
-
-instantiation "^" :: (metric_space, finite) metric_space
-begin
-
-definition dist_vector_def:
- "dist (x::'a^'b) (y::'a^'b) = setL2 (\<lambda>i. dist (x$i) (y$i)) UNIV"
-
-lemma dist_nth_le: "dist (x $ i) (y $ i) \<le> dist x y"
-unfolding dist_vector_def
-by (rule member_le_setL2) simp_all
-
-instance proof
- fix x y :: "'a ^ 'b"
- show "dist x y = 0 \<longleftrightarrow> x = y"
- unfolding dist_vector_def
- by (simp add: setL2_eq_0_iff Cart_eq)
-next
- fix x y z :: "'a ^ 'b"
- show "dist x y \<le> dist x z + dist y z"
- unfolding dist_vector_def
- apply (rule order_trans [OF _ setL2_triangle_ineq])
- apply (simp add: setL2_mono dist_triangle2)
- done
-next
- (* FIXME: long proof! *)
- fix S :: "('a ^ 'b) set"
- show "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
- unfolding open_vector_def open_dist
- apply safe
- apply (drule (1) bspec)
- apply clarify
- apply (subgoal_tac "\<exists>e>0. \<forall>i y. dist y (x$i) < e \<longrightarrow> y \<in> A i")
- apply clarify
- apply (rule_tac x=e in exI, clarify)
- apply (drule spec, erule mp, clarify)
- apply (drule spec, drule spec, erule mp)
- apply (erule le_less_trans [OF dist_nth_le])
- apply (subgoal_tac "\<forall>i\<in>UNIV. \<exists>e>0. \<forall>y. dist y (x$i) < e \<longrightarrow> y \<in> A i")
- apply (drule finite_choice [OF finite], clarify)
- apply (rule_tac x="Min (range f)" in exI, simp)
- apply clarify
- apply (drule_tac x=i in spec, clarify)
- apply (erule (1) bspec)
- apply (drule (1) bspec, clarify)
- apply (subgoal_tac "\<exists>r. (\<forall>i::'b. 0 < r i) \<and> e = setL2 r UNIV")
- apply clarify
- apply (rule_tac x="\<lambda>i. {y. dist y (x$i) < r i}" in exI)
- apply (rule conjI)
- apply clarify
- apply (rule conjI)
- apply (clarify, rename_tac y)
- apply (rule_tac x="r i - dist y (x$i)" in exI, rule conjI, simp)
- apply clarify
- apply (simp only: less_diff_eq)
- apply (erule le_less_trans [OF dist_triangle])
- apply simp
- apply clarify
- apply (drule spec, erule mp)
- apply (simp add: dist_vector_def setL2_strict_mono)
- apply (rule_tac x="\<lambda>i. e / sqrt (of_nat CARD('b))" in exI)
- apply (simp add: divide_pos_pos setL2_constant)
- done
-qed
-
-end
-
-lemma LIMSEQ_Cart_nth:
- "(X ----> a) \<Longrightarrow> (\<lambda>n. X n $ i) ----> a $ i"
-unfolding LIMSEQ_conv_tendsto by (rule tendsto_Cart_nth)
-
-lemma LIM_Cart_nth:
- "(f -- x --> y) \<Longrightarrow> (\<lambda>x. f x $ i) -- x --> y $ i"
-unfolding LIM_conv_tendsto by (rule tendsto_Cart_nth)
-
-lemma Cauchy_Cart_nth:
- "Cauchy (\<lambda>n. X n) \<Longrightarrow> Cauchy (\<lambda>n. X n $ i)"
-unfolding Cauchy_def by (fast intro: le_less_trans [OF dist_nth_le])
-
-lemma LIMSEQ_vector:
- fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n::finite"
- assumes X: "\<And>i. (\<lambda>n. X n $ i) ----> (a $ i)"
- shows "X ----> a"
-proof (rule metric_LIMSEQ_I)
- fix r :: real assume "0 < r"
- then have "0 < r / of_nat CARD('n)" (is "0 < ?s")
- by (simp add: divide_pos_pos)
- def N \<equiv> "\<lambda>i. LEAST N. \<forall>n\<ge>N. dist (X n $ i) (a $ i) < ?s"
- def M \<equiv> "Max (range N)"
- have "\<And>i. \<exists>N. \<forall>n\<ge>N. dist (X n $ i) (a $ i) < ?s"
- using X `0 < ?s` by (rule metric_LIMSEQ_D)
- hence "\<And>i. \<forall>n\<ge>N i. dist (X n $ i) (a $ i) < ?s"
- unfolding N_def by (rule LeastI_ex)
- hence M: "\<And>i. \<forall>n\<ge>M. dist (X n $ i) (a $ i) < ?s"
- unfolding M_def by simp
- {
- fix n :: nat assume "M \<le> n"
- have "dist (X n) a = setL2 (\<lambda>i. dist (X n $ i) (a $ i)) UNIV"
- unfolding dist_vector_def ..
- also have "\<dots> \<le> setsum (\<lambda>i. dist (X n $ i) (a $ i)) UNIV"
- by (rule setL2_le_setsum [OF zero_le_dist])
- also have "\<dots> < setsum (\<lambda>i::'n. ?s) UNIV"
- by (rule setsum_strict_mono, simp_all add: M `M \<le> n`)
- also have "\<dots> = r"
- by simp
- finally have "dist (X n) a < r" .
- }
- hence "\<forall>n\<ge>M. dist (X n) a < r"
- by simp
- then show "\<exists>M. \<forall>n\<ge>M. dist (X n) a < r" ..
-qed
-
-lemma Cauchy_vector:
- fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n::finite"
- assumes X: "\<And>i. Cauchy (\<lambda>n. X n $ i)"
- shows "Cauchy (\<lambda>n. X n)"
-proof (rule metric_CauchyI)
- fix r :: real assume "0 < r"
- then have "0 < r / of_nat CARD('n)" (is "0 < ?s")
- by (simp add: divide_pos_pos)
- def N \<equiv> "\<lambda>i. LEAST N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
- def M \<equiv> "Max (range N)"
- have "\<And>i. \<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
- using X `0 < ?s` by (rule metric_CauchyD)
- hence "\<And>i. \<forall>m\<ge>N i. \<forall>n\<ge>N i. dist (X m $ i) (X n $ i) < ?s"
- unfolding N_def by (rule LeastI_ex)
- hence M: "\<And>i. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m $ i) (X n $ i) < ?s"
- unfolding M_def by simp
- {
- fix m n :: nat
- assume "M \<le> m" "M \<le> n"
- have "dist (X m) (X n) = setL2 (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
- unfolding dist_vector_def ..
- also have "\<dots> \<le> setsum (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
- by (rule setL2_le_setsum [OF zero_le_dist])
- also have "\<dots> < setsum (\<lambda>i::'n. ?s) UNIV"
- by (rule setsum_strict_mono, simp_all add: M `M \<le> m` `M \<le> n`)
- also have "\<dots> = r"
- by simp
- finally have "dist (X m) (X n) < r" .
- }
- hence "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r"
- by simp
- then show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r" ..
-qed
-
-instance "^" :: (complete_space, finite) complete_space
-proof
- fix X :: "nat \<Rightarrow> 'a ^ 'b" assume "Cauchy X"
- have "\<And>i. (\<lambda>n. X n $ i) ----> lim (\<lambda>n. X n $ i)"
- using Cauchy_Cart_nth [OF `Cauchy X`]
- by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
- hence "X ----> Cart_lambda (\<lambda>i. lim (\<lambda>n. X n $ i))"
- by (simp add: LIMSEQ_vector)
- then show "convergent X"
- by (rule convergentI)
-qed
-
-subsection {* Norms *}
-
-instantiation "^" :: (real_normed_vector, finite) real_normed_vector
-begin
-
-definition norm_vector_def:
- "norm (x::'a^'b) = setL2 (\<lambda>i. norm (x$i)) UNIV"
-
-definition vector_sgn_def:
- "sgn (x::'a^'b) = scaleR (inverse (norm x)) x"
-
-instance proof
- fix a :: real and x y :: "'a ^ 'b"
- show "0 \<le> norm x"
- unfolding norm_vector_def
- by (rule setL2_nonneg)
- show "norm x = 0 \<longleftrightarrow> x = 0"
- unfolding norm_vector_def
- by (simp add: setL2_eq_0_iff Cart_eq)
- show "norm (x + y) \<le> norm x + norm y"
- unfolding norm_vector_def
- apply (rule order_trans [OF _ setL2_triangle_ineq])
- apply (simp add: setL2_mono norm_triangle_ineq)
- done
- show "norm (scaleR a x) = \<bar>a\<bar> * norm x"
- unfolding norm_vector_def
- by (simp add: setL2_right_distrib)
- show "sgn x = scaleR (inverse (norm x)) x"
- by (rule vector_sgn_def)
- show "dist x y = norm (x - y)"
- unfolding dist_vector_def norm_vector_def
- by (simp add: dist_norm)
-qed
-
-end
-
-lemma norm_nth_le: "norm (x $ i) \<le> norm x"
-unfolding norm_vector_def
-by (rule member_le_setL2) simp_all
-
-interpretation Cart_nth: bounded_linear "\<lambda>x. x $ i"
-apply default
-apply (rule vector_add_component)
-apply (rule vector_scaleR_component)
-apply (rule_tac x="1" in exI, simp add: norm_nth_le)
-done
-
-instance "^" :: (banach, finite) banach ..
-
-subsection {* Inner products *}
-
-instantiation "^" :: (real_inner, finite) real_inner
-begin
-
-definition inner_vector_def:
- "inner x y = setsum (\<lambda>i. inner (x$i) (y$i)) UNIV"
-
-instance proof
- fix r :: real and x y z :: "'a ^ 'b"
- show "inner x y = inner y x"
- unfolding inner_vector_def
- by (simp add: inner_commute)
- show "inner (x + y) z = inner x z + inner y z"
- unfolding inner_vector_def
- by (simp add: inner_add_left setsum_addf)
- show "inner (scaleR r x) y = r * inner x y"
- unfolding inner_vector_def
- by (simp add: setsum_right_distrib)
- show "0 \<le> inner x x"
- unfolding inner_vector_def
- by (simp add: setsum_nonneg)
- show "inner x x = 0 \<longleftrightarrow> x = 0"
- unfolding inner_vector_def
- by (simp add: Cart_eq setsum_nonneg_eq_0_iff)
- show "norm x = sqrt (inner x x)"
- unfolding inner_vector_def norm_vector_def setL2_def
- by (simp add: power2_norm_eq_inner)
-qed
-
-end
-
-subsection{* Properties of the dot product. *}
-
-lemma dot_sym: "(x::'a:: {comm_monoid_add, ab_semigroup_mult} ^ 'n) \<bullet> y = y \<bullet> x"
- by (vector mult_commute)
-lemma dot_ladd: "((x::'a::ring ^ 'n) + y) \<bullet> z = (x \<bullet> z) + (y \<bullet> z)"
- by (vector ring_simps)
-lemma dot_radd: "x \<bullet> (y + (z::'a::ring ^ 'n)) = (x \<bullet> y) + (x \<bullet> z)"
- by (vector ring_simps)
-lemma dot_lsub: "((x::'a::ring ^ 'n) - y) \<bullet> z = (x \<bullet> z) - (y \<bullet> z)"
- by (vector ring_simps)
-lemma dot_rsub: "(x::'a::ring ^ 'n) \<bullet> (y - z) = (x \<bullet> y) - (x \<bullet> z)"
- by (vector ring_simps)
-lemma dot_lmult: "(c *s x) \<bullet> y = (c::'a::ring) * (x \<bullet> y)" by (vector ring_simps)
-lemma dot_rmult: "x \<bullet> (c *s y) = (c::'a::comm_ring) * (x \<bullet> y)" by (vector ring_simps)
-lemma dot_lneg: "(-x) \<bullet> (y::'a::ring ^ 'n) = -(x \<bullet> y)" by vector
-lemma dot_rneg: "(x::'a::ring ^ 'n) \<bullet> (-y) = -(x \<bullet> y)" by vector
-lemma dot_lzero[simp]: "0 \<bullet> x = (0::'a::{comm_monoid_add, mult_zero})" by vector
-lemma dot_rzero[simp]: "x \<bullet> 0 = (0::'a::{comm_monoid_add, mult_zero})" by vector
-lemma dot_pos_le[simp]: "(0::'a\<Colon>ordered_ring_strict) <= x \<bullet> x"
- by (simp add: dot_def setsum_nonneg)
-
-lemma setsum_squares_eq_0_iff: assumes fS: "finite F" and fp: "\<forall>x \<in> F. f x \<ge> (0 ::'a::pordered_ab_group_add)" shows "setsum f F = 0 \<longleftrightarrow> (ALL x:F. f x = 0)"
-using fS fp setsum_nonneg[OF fp]
-proof (induct set: finite)
- case empty thus ?case by simp
-next
- case (insert x F)
- from insert.prems have Fx: "f x \<ge> 0" and Fp: "\<forall> a \<in> F. f a \<ge> 0" by simp_all
- from insert.hyps Fp setsum_nonneg[OF Fp]
- have h: "setsum f F = 0 \<longleftrightarrow> (\<forall>a \<in>F. f a = 0)" by metis
- from add_nonneg_eq_0_iff[OF Fx setsum_nonneg[OF Fp]] insert.hyps(1,2)
- show ?case by (simp add: h)
-qed
-
-lemma dot_eq_0: "x \<bullet> x = 0 \<longleftrightarrow> (x::'a::{ordered_ring_strict,ring_no_zero_divisors} ^ 'n::finite) = 0"
- by (simp add: dot_def setsum_squares_eq_0_iff Cart_eq)
-
-lemma dot_pos_lt[simp]: "(0 < x \<bullet> x) \<longleftrightarrow> (x::'a::{ordered_ring_strict,ring_no_zero_divisors} ^ 'n::finite) \<noteq> 0" using dot_eq_0[of x] dot_pos_le[of x]
- by (auto simp add: le_less)
-
-subsection{* The collapse of the general concepts to dimension one. *}
-
-lemma vector_one: "(x::'a ^1) = (\<chi> i. (x$1))"
- by (simp add: Cart_eq forall_1)
-
-lemma forall_one: "(\<forall>(x::'a ^1). P x) \<longleftrightarrow> (\<forall>x. P(\<chi> i. x))"
- apply auto
- apply (erule_tac x= "x$1" in allE)
- apply (simp only: vector_one[symmetric])
- done
-
-lemma norm_vector_1: "norm (x :: _^1) = norm (x$1)"
- by (simp add: norm_vector_def UNIV_1)
-
-lemma norm_real: "norm(x::real ^ 1) = abs(x$1)"
- by (simp add: norm_vector_1)
-
-lemma dist_real: "dist(x::real ^ 1) y = abs((x$1) - (y$1))"
- by (auto simp add: norm_real dist_norm)
-
-subsection {* A connectedness or intermediate value lemma with several applications. *}
-
-lemma connected_real_lemma:
- fixes f :: "real \<Rightarrow> 'a::metric_space"
- assumes ab: "a \<le> b" and fa: "f a \<in> e1" and fb: "f b \<in> e2"
- and dst: "\<And>e x. a <= x \<Longrightarrow> x <= b \<Longrightarrow> 0 < e ==> \<exists>d > 0. \<forall>y. abs(y - x) < d \<longrightarrow> dist(f y) (f x) < e"
- and e1: "\<forall>y \<in> e1. \<exists>e > 0. \<forall>y'. dist y' y < e \<longrightarrow> y' \<in> e1"
- and e2: "\<forall>y \<in> e2. \<exists>e > 0. \<forall>y'. dist y' y < e \<longrightarrow> y' \<in> e2"
- and e12: "~(\<exists>x \<ge> a. x <= b \<and> f x \<in> e1 \<and> f x \<in> e2)"
- shows "\<exists>x \<ge> a. x <= b \<and> f x \<notin> e1 \<and> f x \<notin> e2" (is "\<exists> x. ?P x")
-proof-
- let ?S = "{c. \<forall>x \<ge> a. x <= c \<longrightarrow> f x \<in> e1}"
- have Se: " \<exists>x. x \<in> ?S" apply (rule exI[where x=a]) by (auto simp add: fa)
- have Sub: "\<exists>y. isUb UNIV ?S y"
- apply (rule exI[where x= b])
- using ab fb e12 by (auto simp add: isUb_def setle_def)
- from reals_complete[OF Se Sub] obtain l where
- l: "isLub UNIV ?S l"by blast
- have alb: "a \<le> l" "l \<le> b" using l ab fa fb e12
- apply (auto simp add: isLub_def leastP_def isUb_def setle_def setge_def)
- by (metis linorder_linear)
- have ale1: "\<forall>z \<ge> a. z < l \<longrightarrow> f z \<in> e1" using l
- apply (auto simp add: isLub_def leastP_def isUb_def setle_def setge_def)
- by (metis linorder_linear not_le)
- have th1: "\<And>z x e d :: real. z <= x + e \<Longrightarrow> e < d ==> z < x \<or> abs(z - x) < d" by arith
- have th2: "\<And>e x:: real. 0 < e ==> ~(x + e <= x)" by arith
- have th3: "\<And>d::real. d > 0 \<Longrightarrow> \<exists>e > 0. e < d" by dlo
- {assume le2: "f l \<in> e2"
- from le2 fa fb e12 alb have la: "l \<noteq> a" by metis
- hence lap: "l - a > 0" using alb by arith
- from e2[rule_format, OF le2] obtain e where
- e: "e > 0" "\<forall>y. dist y (f l) < e \<longrightarrow> y \<in> e2" by metis
- from dst[OF alb e(1)] obtain d where
- d: "d > 0" "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> dist (f y) (f l) < e" by metis
- have "\<exists>d'. d' < d \<and> d' >0 \<and> l - d' > a" using lap d(1)
- apply ferrack by arith
- then obtain d' where d': "d' > 0" "d' < d" "l - d' > a" by metis
- from d e have th0: "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> f y \<in> e2" by metis
- from th0[rule_format, of "l - d'"] d' have "f (l - d') \<in> e2" by auto
- moreover
- have "f (l - d') \<in> e1" using ale1[rule_format, of "l -d'"] d' by auto
- ultimately have False using e12 alb d' by auto}
- moreover
- {assume le1: "f l \<in> e1"
- from le1 fa fb e12 alb have lb: "l \<noteq> b" by metis
- hence blp: "b - l > 0" using alb by arith
- from e1[rule_format, OF le1] obtain e where
- e: "e > 0" "\<forall>y. dist y (f l) < e \<longrightarrow> y \<in> e1" by metis
- from dst[OF alb e(1)] obtain d where
- d: "d > 0" "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> dist (f y) (f l) < e" by metis
- have "\<exists>d'. d' < d \<and> d' >0" using d(1) by dlo
- then obtain d' where d': "d' > 0" "d' < d" by metis
- from d e have th0: "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> f y \<in> e1" by auto
- hence "\<forall>y. l \<le> y \<and> y \<le> l + d' \<longrightarrow> f y \<in> e1" using d' by auto
- with ale1 have "\<forall>y. a \<le> y \<and> y \<le> l + d' \<longrightarrow> f y \<in> e1" by auto
- with l d' have False
- by (auto simp add: isLub_def isUb_def setle_def setge_def leastP_def) }
- ultimately show ?thesis using alb by metis
-qed
-
-text{* One immediately useful corollary is the existence of square roots! --- Should help to get rid of all the development of square-root for reals as a special case @{typ "real^1"} *}
-
-lemma square_bound_lemma: "(x::real) < (1 + x) * (1 + x)"
-proof-
- have "(x + 1/2)^2 + 3/4 > 0" using zero_le_power2[of "x+1/2"] by arith
- thus ?thesis by (simp add: ring_simps power2_eq_square)
-qed
-
-lemma square_continuous: "0 < (e::real) ==> \<exists>d. 0 < d \<and> (\<forall>y. abs(y - x) < d \<longrightarrow> abs(y * y - x * x) < e)"
- using isCont_power[OF isCont_ident, of 2, unfolded isCont_def LIM_eq, rule_format, of e x] apply (auto simp add: power2_eq_square)
- apply (rule_tac x="s" in exI)
- apply auto
- apply (erule_tac x=y in allE)
- apply auto
- done
-
-lemma real_le_lsqrt: "0 <= x \<Longrightarrow> 0 <= y \<Longrightarrow> x <= y^2 ==> sqrt x <= y"
- using real_sqrt_le_iff[of x "y^2"] by simp
-
-lemma real_le_rsqrt: "x^2 \<le> y \<Longrightarrow> x \<le> sqrt y"
- using real_sqrt_le_mono[of "x^2" y] by simp
-
-lemma real_less_rsqrt: "x^2 < y \<Longrightarrow> x < sqrt y"
- using real_sqrt_less_mono[of "x^2" y] by simp
-
-lemma sqrt_even_pow2: assumes n: "even n"
- shows "sqrt(2 ^ n) = 2 ^ (n div 2)"
-proof-
- from n obtain m where m: "n = 2*m" unfolding even_nat_equiv_def2
- by (auto simp add: nat_number)
- from m have "sqrt(2 ^ n) = sqrt ((2 ^ m) ^ 2)"
- by (simp only: power_mult[symmetric] mult_commute)
- then show ?thesis using m by simp
-qed
-
-lemma real_div_sqrt: "0 <= x ==> x / sqrt(x) = sqrt(x)"
- apply (cases "x = 0", simp_all)
- using sqrt_divide_self_eq[of x]
- apply (simp add: inverse_eq_divide real_sqrt_ge_0_iff field_simps)
- done
-
-text{* Hence derive more interesting properties of the norm. *}
-
-text {*
- This type-specific version is only here
- to make @{text normarith.ML} happy.
-*}
-lemma norm_0: "norm (0::real ^ _) = 0"
- by (rule norm_zero)
-
-lemma norm_mul[simp]: "norm(a *s x) = abs(a) * norm x"
- by (simp add: norm_vector_def vector_component setL2_right_distrib
- abs_mult cong: strong_setL2_cong)
-lemma norm_eq_0_dot: "(norm x = 0) \<longleftrightarrow> (x \<bullet> x = (0::real))"
- by (simp add: norm_vector_def dot_def setL2_def power2_eq_square)
-lemma real_vector_norm_def: "norm x = sqrt (x \<bullet> x)"
- by (simp add: norm_vector_def setL2_def dot_def power2_eq_square)
-lemma norm_pow_2: "norm x ^ 2 = x \<bullet> x"
- by (simp add: real_vector_norm_def)
-lemma norm_eq_0_imp: "norm x = 0 ==> x = (0::real ^'n::finite)" by (metis norm_eq_zero)
-lemma vector_mul_eq_0[simp]: "(a *s x = 0) \<longleftrightarrow> a = (0::'a::idom) \<or> x = 0"
- by vector
-lemma vector_mul_lcancel[simp]: "a *s x = a *s y \<longleftrightarrow> a = (0::real) \<or> x = y"
- by (metis eq_iff_diff_eq_0 vector_mul_eq_0 vector_ssub_ldistrib)
-lemma vector_mul_rcancel[simp]: "a *s x = b *s x \<longleftrightarrow> (a::real) = b \<or> x = 0"
- by (metis eq_iff_diff_eq_0 vector_mul_eq_0 vector_sub_rdistrib)
-lemma vector_mul_lcancel_imp: "a \<noteq> (0::real) ==> a *s x = a *s y ==> (x = y)"
- by (metis vector_mul_lcancel)
-lemma vector_mul_rcancel_imp: "x \<noteq> 0 \<Longrightarrow> (a::real) *s x = b *s x ==> a = b"
- by (metis vector_mul_rcancel)
-lemma norm_cauchy_schwarz:
- fixes x y :: "real ^ 'n::finite"
- shows "x \<bullet> y <= norm x * norm y"
-proof-
- {assume "norm x = 0"
- hence ?thesis by (simp add: dot_lzero dot_rzero)}
- moreover
- {assume "norm y = 0"
- hence ?thesis by (simp add: dot_lzero dot_rzero)}
- moreover
- {assume h: "norm x \<noteq> 0" "norm y \<noteq> 0"
- let ?z = "norm y *s x - norm x *s y"
- from h have p: "norm x * norm y > 0" by (metis norm_ge_zero le_less zero_compare_simps)
- from dot_pos_le[of ?z]
- have "(norm x * norm y) * (x \<bullet> y) \<le> norm x ^2 * norm y ^2"
- apply (simp add: dot_rsub dot_lsub dot_lmult dot_rmult ring_simps)
- by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym)
- hence "x\<bullet>y \<le> (norm x ^2 * norm y ^2) / (norm x * norm y)" using p
- by (simp add: field_simps)
- hence ?thesis using h by (simp add: power2_eq_square)}
- ultimately show ?thesis by metis
-qed
-
-lemma norm_cauchy_schwarz_abs:
- fixes x y :: "real ^ 'n::finite"
- shows "\<bar>x \<bullet> y\<bar> \<le> norm x * norm y"
- using norm_cauchy_schwarz[of x y] norm_cauchy_schwarz[of x "-y"]
- by (simp add: real_abs_def dot_rneg)
-
-lemma norm_triangle_sub:
- fixes x y :: "'a::real_normed_vector"
- shows "norm x \<le> norm y + norm (x - y)"
- using norm_triangle_ineq[of "y" "x - y"] by (simp add: ring_simps)
-
-lemma norm_triangle_le: "norm(x::real ^'n::finite) + norm y <= e ==> norm(x + y) <= e"
- by (metis order_trans norm_triangle_ineq)
-lemma norm_triangle_lt: "norm(x::real ^'n::finite) + norm(y) < e ==> norm(x + y) < e"
- by (metis basic_trans_rules(21) norm_triangle_ineq)
-
-lemma component_le_norm: "\<bar>x$i\<bar> <= norm (x::real ^ 'n::finite)"
- apply (simp add: norm_vector_def)
- apply (rule member_le_setL2, simp_all)
- done
-
-lemma norm_bound_component_le: "norm(x::real ^ 'n::finite) <= e
- ==> \<bar>x$i\<bar> <= e"
- by (metis component_le_norm order_trans)
-
-lemma norm_bound_component_lt: "norm(x::real ^ 'n::finite) < e
- ==> \<bar>x$i\<bar> < e"
- by (metis component_le_norm basic_trans_rules(21))
-
-lemma norm_le_l1: "norm (x:: real ^'n::finite) <= setsum(\<lambda>i. \<bar>x$i\<bar>) UNIV"
- by (simp add: norm_vector_def setL2_le_setsum)
-
-lemma real_abs_norm: "\<bar>norm x\<bar> = norm (x :: real ^ _)"
- by (rule abs_norm_cancel)
-lemma real_abs_sub_norm: "\<bar>norm(x::real ^'n::finite) - norm y\<bar> <= norm(x - y)"
- by (rule norm_triangle_ineq3)
-lemma norm_le: "norm(x::real ^ _) <= norm(y) \<longleftrightarrow> x \<bullet> x <= y \<bullet> y"
- by (simp add: real_vector_norm_def)
-lemma norm_lt: "norm(x::real ^ _) < norm(y) \<longleftrightarrow> x \<bullet> x < y \<bullet> y"
- by (simp add: real_vector_norm_def)
-lemma norm_eq: "norm (x::real ^ _) = norm y \<longleftrightarrow> x \<bullet> x = y \<bullet> y"
- by (simp add: order_eq_iff norm_le)
-lemma norm_eq_1: "norm(x::real ^ _) = 1 \<longleftrightarrow> x \<bullet> x = 1"
- by (simp add: real_vector_norm_def)
-
-text{* Squaring equations and inequalities involving norms. *}
-
-lemma dot_square_norm: "x \<bullet> x = norm(x)^2"
- by (simp add: real_vector_norm_def)
-
-lemma norm_eq_square: "norm(x) = a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x = a^2"
- by (auto simp add: real_vector_norm_def)
-
-lemma real_abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> (x::real)^2 \<le> y^2"
-proof-
- have "x^2 \<le> y^2 \<longleftrightarrow> (x -y) * (y + x) \<le> 0" by (simp add: ring_simps power2_eq_square)
- also have "\<dots> \<longleftrightarrow> \<bar>x\<bar> \<le> \<bar>y\<bar>" apply (simp add: zero_compare_simps real_abs_def not_less) by arith
-finally show ?thesis ..
-qed
-
-lemma norm_le_square: "norm(x) <= a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x <= a^2"
- apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
- using norm_ge_zero[of x]
- apply arith
- done
-
-lemma norm_ge_square: "norm(x) >= a \<longleftrightarrow> a <= 0 \<or> x \<bullet> x >= a ^ 2"
- apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
- using norm_ge_zero[of x]
- apply arith
- done
-
-lemma norm_lt_square: "norm(x) < a \<longleftrightarrow> 0 < a \<and> x \<bullet> x < a^2"
- by (metis not_le norm_ge_square)
-lemma norm_gt_square: "norm(x) > a \<longleftrightarrow> a < 0 \<or> x \<bullet> x > a^2"
- by (metis norm_le_square not_less)
-
-text{* Dot product in terms of the norm rather than conversely. *}
-
-lemma dot_norm: "x \<bullet> y = (norm(x + y) ^2 - norm x ^ 2 - norm y ^ 2) / 2"
- by (simp add: norm_pow_2 dot_ladd dot_radd dot_sym)
-
-lemma dot_norm_neg: "x \<bullet> y = ((norm x ^ 2 + norm y ^ 2) - norm(x - y) ^ 2) / 2"
- by (simp add: norm_pow_2 dot_ladd dot_radd dot_lsub dot_rsub dot_sym)
-
-
-text{* Equality of vectors in terms of @{term "op \<bullet>"} products. *}
-
-lemma vector_eq: "(x:: real ^ 'n::finite) = y \<longleftrightarrow> x \<bullet> x = x \<bullet> y\<and> y \<bullet> y = x \<bullet> x" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume "?lhs" then show ?rhs by simp
-next
- assume ?rhs
- then have "x \<bullet> x - x \<bullet> y = 0 \<and> x \<bullet> y - y\<bullet> y = 0" by simp
- hence "x \<bullet> (x - y) = 0 \<and> y \<bullet> (x - y) = 0"
- by (simp add: dot_rsub dot_lsub dot_sym)
- then have "(x - y) \<bullet> (x - y) = 0" by (simp add: ring_simps dot_lsub dot_rsub)
- then show "x = y" by (simp add: dot_eq_0)
-qed
-
-
-subsection{* General linear decision procedure for normed spaces. *}
-
-lemma norm_cmul_rule_thm:
- fixes x :: "'a::real_normed_vector"
- shows "b >= norm(x) ==> \<bar>c\<bar> * b >= norm(scaleR c x)"
- unfolding norm_scaleR
- apply (erule mult_mono1)
- apply simp
- done
-
- (* FIXME: Move all these theorems into the ML code using lemma antiquotation *)
-lemma norm_add_rule_thm:
- fixes x1 x2 :: "'a::real_normed_vector"
- shows "norm x1 \<le> b1 \<Longrightarrow> norm x2 \<le> b2 \<Longrightarrow> norm (x1 + x2) \<le> b1 + b2"
- by (rule order_trans [OF norm_triangle_ineq add_mono])
-
-lemma ge_iff_diff_ge_0: "(a::'a::ordered_ring) \<ge> b == a - b \<ge> 0"
- by (simp add: ring_simps)
-
-lemma pth_1:
- fixes x :: "'a::real_normed_vector"
- shows "x == scaleR 1 x" by simp
-
-lemma pth_2:
- fixes x :: "'a::real_normed_vector"
- shows "x - y == x + -y" by (atomize (full)) simp
-
-lemma pth_3:
- fixes x :: "'a::real_normed_vector"
- shows "- x == scaleR (-1) x" by simp
-
-lemma pth_4:
- fixes x :: "'a::real_normed_vector"
- shows "scaleR 0 x == 0" and "scaleR c 0 = (0::'a)" by simp_all
-
-lemma pth_5:
- fixes x :: "'a::real_normed_vector"
- shows "scaleR c (scaleR d x) == scaleR (c * d) x" by simp
-
-lemma pth_6:
- fixes x :: "'a::real_normed_vector"
- shows "scaleR c (x + y) == scaleR c x + scaleR c y"
- by (simp add: scaleR_right_distrib)
-
-lemma pth_7:
- fixes x :: "'a::real_normed_vector"
- shows "0 + x == x" and "x + 0 == x" by simp_all
-
-lemma pth_8:
- fixes x :: "'a::real_normed_vector"
- shows "scaleR c x + scaleR d x == scaleR (c + d) x"
- by (simp add: scaleR_left_distrib)
-
-lemma pth_9:
- fixes x :: "'a::real_normed_vector" shows
- "(scaleR c x + z) + scaleR d x == scaleR (c + d) x + z"
- "scaleR c x + (scaleR d x + z) == scaleR (c + d) x + z"
- "(scaleR c x + w) + (scaleR d x + z) == scaleR (c + d) x + (w + z)"
- by (simp_all add: algebra_simps)
-
-lemma pth_a:
- fixes x :: "'a::real_normed_vector"
- shows "scaleR 0 x + y == y" by simp
-
-lemma pth_b:
- fixes x :: "'a::real_normed_vector" shows
- "scaleR c x + scaleR d y == scaleR c x + scaleR d y"
- "(scaleR c x + z) + scaleR d y == scaleR c x + (z + scaleR d y)"
- "scaleR c x + (scaleR d y + z) == scaleR c x + (scaleR d y + z)"
- "(scaleR c x + w) + (scaleR d y + z) == scaleR c x + (w + (scaleR d y + z))"
- by (simp_all add: algebra_simps)
-
-lemma pth_c:
- fixes x :: "'a::real_normed_vector" shows
- "scaleR c x + scaleR d y == scaleR d y + scaleR c x"
- "(scaleR c x + z) + scaleR d y == scaleR d y + (scaleR c x + z)"
- "scaleR c x + (scaleR d y + z) == scaleR d y + (scaleR c x + z)"
- "(scaleR c x + w) + (scaleR d y + z) == scaleR d y + ((scaleR c x + w) + z)"
- by (simp_all add: algebra_simps)
-
-lemma pth_d:
- fixes x :: "'a::real_normed_vector"
- shows "x + 0 == x" by simp
-
-lemma norm_imp_pos_and_ge:
- fixes x :: "'a::real_normed_vector"
- shows "norm x == n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
- by atomize auto
-
-lemma real_eq_0_iff_le_ge_0: "(x::real) = 0 == x \<ge> 0 \<and> -x \<ge> 0" by arith
-
-lemma norm_pths:
- fixes x :: "'a::real_normed_vector" shows
- "x = y \<longleftrightarrow> norm (x - y) \<le> 0"
- "x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
- using norm_ge_zero[of "x - y"] by auto
-
-lemma vector_dist_norm:
- fixes x :: "'a::real_normed_vector"
- shows "dist x y = norm (x - y)"
- by (rule dist_norm)
-
-use "normarith.ML"
-
-method_setup norm = {* Scan.succeed (SIMPLE_METHOD' o NormArith.norm_arith_tac)
-*} "Proves simple linear statements about vector norms"
-
-
-text{* Hence more metric properties. *}
-
-lemma dist_triangle_alt:
- fixes x y z :: "'a::metric_space"
- shows "dist y z <= dist x y + dist x z"
-using dist_triangle [of y z x] by (simp add: dist_commute)
-
-lemma dist_pos_lt:
- fixes x y :: "'a::metric_space"
- shows "x \<noteq> y ==> 0 < dist x y"
-by (simp add: zero_less_dist_iff)
-
-lemma dist_nz:
- fixes x y :: "'a::metric_space"
- shows "x \<noteq> y \<longleftrightarrow> 0 < dist x y"
-by (simp add: zero_less_dist_iff)
-
-lemma dist_triangle_le:
- fixes x y z :: "'a::metric_space"
- shows "dist x z + dist y z <= e \<Longrightarrow> dist x y <= e"
-by (rule order_trans [OF dist_triangle2])
-
-lemma dist_triangle_lt:
- fixes x y z :: "'a::metric_space"
- shows "dist x z + dist y z < e ==> dist x y < e"
-by (rule le_less_trans [OF dist_triangle2])
-
-lemma dist_triangle_half_l:
- fixes x1 x2 y :: "'a::metric_space"
- shows "dist x1 y < e / 2 \<Longrightarrow> dist x2 y < e / 2 \<Longrightarrow> dist x1 x2 < e"
-by (rule dist_triangle_lt [where z=y], simp)
-
-lemma dist_triangle_half_r:
- fixes x1 x2 y :: "'a::metric_space"
- shows "dist y x1 < e / 2 \<Longrightarrow> dist y x2 < e / 2 \<Longrightarrow> dist x1 x2 < e"
-by (rule dist_triangle_half_l, simp_all add: dist_commute)
-
-lemma dist_triangle_add:
- fixes x y x' y' :: "'a::real_normed_vector"
- shows "dist (x + y) (x' + y') <= dist x x' + dist y y'"
- by norm
-
-lemma dist_mul[simp]: "dist (c *s x) (c *s y) = \<bar>c\<bar> * dist x y"
- unfolding dist_norm vector_ssub_ldistrib[symmetric] norm_mul ..
-
-lemma dist_triangle_add_half:
- fixes x x' y y' :: "'a::real_normed_vector"
- shows "dist x x' < e / 2 \<Longrightarrow> dist y y' < e / 2 \<Longrightarrow> dist(x + y) (x' + y') < e"
- by norm
-
-lemma setsum_component [simp]:
- fixes f:: " 'a \<Rightarrow> ('b::comm_monoid_add) ^'n"
- shows "(setsum f S)$i = setsum (\<lambda>x. (f x)$i) S"
- by (cases "finite S", induct S set: finite, simp_all)
-
-lemma setsum_eq: "setsum f S = (\<chi> i. setsum (\<lambda>x. (f x)$i ) S)"
- by (simp add: Cart_eq)
-
-lemma setsum_clauses:
- shows "setsum f {} = 0"
- and "finite S \<Longrightarrow> setsum f (insert x S) =
- (if x \<in> S then setsum f S else f x + setsum f S)"
- by (auto simp add: insert_absorb)
-
-lemma setsum_cmul:
- fixes f:: "'c \<Rightarrow> ('a::semiring_1)^'n"
- shows "setsum (\<lambda>x. c *s f x) S = c *s setsum f S"
- by (simp add: Cart_eq setsum_right_distrib)
-
-lemma setsum_norm:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes fS: "finite S"
- shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
-proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case by simp
-next
- case (2 x S)
- from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
- also have "\<dots> \<le> norm (f x) + setsum (\<lambda>x. norm(f x)) S"
- using "2.hyps" by simp
- finally show ?case using "2.hyps" by simp
-qed
-
-lemma real_setsum_norm:
- fixes f :: "'a \<Rightarrow> real ^'n::finite"
- assumes fS: "finite S"
- shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
-proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case by simp
-next
- case (2 x S)
- from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
- also have "\<dots> \<le> norm (f x) + setsum (\<lambda>x. norm(f x)) S"
- using "2.hyps" by simp
- finally show ?case using "2.hyps" by simp
-qed
-
-lemma setsum_norm_le:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes fS: "finite S"
- and fg: "\<forall>x \<in> S. norm (f x) \<le> g x"
- shows "norm (setsum f S) \<le> setsum g S"
-proof-
- from fg have "setsum (\<lambda>x. norm(f x)) S <= setsum g S"
- by - (rule setsum_mono, simp)
- then show ?thesis using setsum_norm[OF fS, of f] fg
- by arith
-qed
-
-lemma real_setsum_norm_le:
- fixes f :: "'a \<Rightarrow> real ^ 'n::finite"
- assumes fS: "finite S"
- and fg: "\<forall>x \<in> S. norm (f x) \<le> g x"
- shows "norm (setsum f S) \<le> setsum g S"
-proof-
- from fg have "setsum (\<lambda>x. norm(f x)) S <= setsum g S"
- by - (rule setsum_mono, simp)
- then show ?thesis using real_setsum_norm[OF fS, of f] fg
- by arith
-qed
-
-lemma setsum_norm_bound:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes fS: "finite S"
- and K: "\<forall>x \<in> S. norm (f x) \<le> K"
- shows "norm (setsum f S) \<le> of_nat (card S) * K"
- using setsum_norm_le[OF fS K] setsum_constant[symmetric]
- by simp
-
-lemma real_setsum_norm_bound:
- fixes f :: "'a \<Rightarrow> real ^ 'n::finite"
- assumes fS: "finite S"
- and K: "\<forall>x \<in> S. norm (f x) \<le> K"
- shows "norm (setsum f S) \<le> of_nat (card S) * K"
- using real_setsum_norm_le[OF fS K] setsum_constant[symmetric]
- by simp
-
-lemma setsum_vmul:
- fixes f :: "'a \<Rightarrow> 'b::{real_normed_vector,semiring, mult_zero}"
- assumes fS: "finite S"
- shows "setsum f S *s v = setsum (\<lambda>x. f x *s v) S"
-proof(induct rule: finite_induct[OF fS])
- case 1 then show ?case by (simp add: vector_smult_lzero)
-next
- case (2 x F)
- from "2.hyps" have "setsum f (insert x F) *s v = (f x + setsum f F) *s v"
- by simp
- also have "\<dots> = f x *s v + setsum f F *s v"
- by (simp add: vector_sadd_rdistrib)
- also have "\<dots> = setsum (\<lambda>x. f x *s v) (insert x F)" using "2.hyps" by simp
- finally show ?case .
-qed
-
-(* FIXME : Problem thm setsum_vmul[of _ "f:: 'a \<Rightarrow> real ^'n"] ---
- Get rid of *s and use real_vector instead! Also prove that ^ creates a real_vector !! *)
-
- (* FIXME: Here too need stupid finiteness assumption on T!!! *)
-lemma setsum_group:
- assumes fS: "finite S" and fT: "finite T" and fST: "f ` S \<subseteq> T"
- shows "setsum (\<lambda>y. setsum g {x. x\<in> S \<and> f x = y}) T = setsum g S"
-
-apply (subst setsum_image_gen[OF fS, of g f])
-apply (rule setsum_mono_zero_right[OF fT fST])
-by (auto intro: setsum_0')
-
-lemma vsum_norm_allsubsets_bound:
- fixes f:: "'a \<Rightarrow> real ^'n::finite"
- assumes fP: "finite P" and fPs: "\<And>Q. Q \<subseteq> P \<Longrightarrow> norm (setsum f Q) \<le> e"
- shows "setsum (\<lambda>x. norm (f x)) P \<le> 2 * real CARD('n) * e"
-proof-
- let ?d = "real CARD('n)"
- let ?nf = "\<lambda>x. norm (f x)"
- let ?U = "UNIV :: 'n set"
- have th0: "setsum (\<lambda>x. setsum (\<lambda>i. \<bar>f x $ i\<bar>) ?U) P = setsum (\<lambda>i. setsum (\<lambda>x. \<bar>f x $ i\<bar>) P) ?U"
- by (rule setsum_commute)
- have th1: "2 * ?d * e = of_nat (card ?U) * (2 * e)" by (simp add: real_of_nat_def)
- have "setsum ?nf P \<le> setsum (\<lambda>x. setsum (\<lambda>i. \<bar>f x $ i\<bar>) ?U) P"
- apply (rule setsum_mono)
- by (rule norm_le_l1)
- also have "\<dots> \<le> 2 * ?d * e"
- unfolding th0 th1
- proof(rule setsum_bounded)
- fix i assume i: "i \<in> ?U"
- let ?Pp = "{x. x\<in> P \<and> f x $ i \<ge> 0}"
- let ?Pn = "{x. x \<in> P \<and> f x $ i < 0}"
- have thp: "P = ?Pp \<union> ?Pn" by auto
- have thp0: "?Pp \<inter> ?Pn ={}" by auto
- have PpP: "?Pp \<subseteq> P" and PnP: "?Pn \<subseteq> P" by blast+
- have Ppe:"setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pp \<le> e"
- using component_le_norm[of "setsum (\<lambda>x. f x) ?Pp" i] fPs[OF PpP]
- by (auto intro: abs_le_D1)
- have Pne: "setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn \<le> e"
- using component_le_norm[of "setsum (\<lambda>x. - f x) ?Pn" i] fPs[OF PnP]
- by (auto simp add: setsum_negf intro: abs_le_D1)
- have "setsum (\<lambda>x. \<bar>f x $ i\<bar>) P = setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pp + setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn"
- apply (subst thp)
- apply (rule setsum_Un_zero)
- using fP thp0 by auto
- also have "\<dots> \<le> 2*e" using Pne Ppe by arith
- finally show "setsum (\<lambda>x. \<bar>f x $ i\<bar>) P \<le> 2*e" .
- qed
- finally show ?thesis .
-qed
-
-lemma dot_lsum: "finite S \<Longrightarrow> setsum f S \<bullet> (y::'a::{comm_ring}^'n) = setsum (\<lambda>x. f x \<bullet> y) S "
- by (induct rule: finite_induct, auto simp add: dot_lzero dot_ladd dot_radd)
-
-lemma dot_rsum: "finite S \<Longrightarrow> (y::'a::{comm_ring}^'n) \<bullet> setsum f S = setsum (\<lambda>x. y \<bullet> f x) S "
- by (induct rule: finite_induct, auto simp add: dot_rzero dot_radd)
-
-subsection{* Basis vectors in coordinate directions. *}
-
-
-definition "basis k = (\<chi> i. if i = k then 1 else 0)"
-
-lemma basis_component [simp]: "basis k $ i = (if k=i then 1 else 0)"
- unfolding basis_def by simp
-
-lemma delta_mult_idempotent:
- "(if k=a then 1 else (0::'a::semiring_1)) * (if k=a then 1 else 0) = (if k=a then 1 else 0)" by (cases "k=a", auto)
-
-lemma norm_basis:
- shows "norm (basis k :: real ^'n::finite) = 1"
- apply (simp add: basis_def real_vector_norm_def dot_def)
- apply (vector delta_mult_idempotent)
- using setsum_delta[of "UNIV :: 'n set" "k" "\<lambda>k. 1::real"]
- apply auto
- done
-
-lemma norm_basis_1: "norm(basis 1 :: real ^'n::{finite,one}) = 1"
- by (rule norm_basis)
-
-lemma vector_choose_size: "0 <= c ==> \<exists>(x::real^'n::finite). norm x = c"
- apply (rule exI[where x="c *s basis arbitrary"])
- by (simp only: norm_mul norm_basis)
-
-lemma vector_choose_dist: assumes e: "0 <= e"
- shows "\<exists>(y::real^'n::finite). dist x y = e"
-proof-
- from vector_choose_size[OF e] obtain c:: "real ^'n" where "norm c = e"
- by blast
- then have "dist x (x - c) = e" by (simp add: dist_norm)
- then show ?thesis by blast
-qed
-
-lemma basis_inj: "inj (basis :: 'n \<Rightarrow> real ^'n::finite)"
- by (simp add: inj_on_def Cart_eq)
-
-lemma cond_value_iff: "f (if b then x else y) = (if b then f x else f y)"
- by auto
-
-lemma basis_expansion:
- "setsum (\<lambda>i. (x$i) *s basis i) UNIV = (x::('a::ring_1) ^'n::finite)" (is "?lhs = ?rhs" is "setsum ?f ?S = _")
- by (auto simp add: Cart_eq cond_value_iff setsum_delta[of "?S", where ?'b = "'a", simplified] cong del: if_weak_cong)
-
-lemma basis_expansion_unique:
- "setsum (\<lambda>i. f i *s basis i) UNIV = (x::('a::comm_ring_1) ^'n::finite) \<longleftrightarrow> (\<forall>i. f i = x$i)"
- by (simp add: Cart_eq setsum_delta cond_value_iff cong del: if_weak_cong)
-
-lemma cond_application_beta: "(if b then f else g) x = (if b then f x else g x)"
- by auto
-
-lemma dot_basis:
- shows "basis i \<bullet> x = x$i" "x \<bullet> (basis i :: 'a^'n::finite) = (x$i :: 'a::semiring_1)"
- by (auto simp add: dot_def basis_def cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
-
-lemma inner_basis:
- fixes x :: "'a::{real_inner, real_algebra_1} ^ 'n::finite"
- shows "inner (basis i) x = inner 1 (x $ i)"
- and "inner x (basis i) = inner (x $ i) 1"
- unfolding inner_vector_def basis_def
- by (auto simp add: cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
-
-lemma basis_eq_0: "basis i = (0::'a::semiring_1^'n) \<longleftrightarrow> False"
- by (auto simp add: Cart_eq)
-
-lemma basis_nonzero:
- shows "basis k \<noteq> (0:: 'a::semiring_1 ^'n)"
- by (simp add: basis_eq_0)
-
-lemma vector_eq_ldot: "(\<forall>x. x \<bullet> y = x \<bullet> z) \<longleftrightarrow> y = (z::'a::semiring_1^'n::finite)"
- apply (auto simp add: Cart_eq dot_basis)
- apply (erule_tac x="basis i" in allE)
- apply (simp add: dot_basis)
- apply (subgoal_tac "y = z")
- apply simp
- apply (simp add: Cart_eq)
- done
-
-lemma vector_eq_rdot: "(\<forall>z. x \<bullet> z = y \<bullet> z) \<longleftrightarrow> x = (y::'a::semiring_1^'n::finite)"
- apply (auto simp add: Cart_eq dot_basis)
- apply (erule_tac x="basis i" in allE)
- apply (simp add: dot_basis)
- apply (subgoal_tac "x = y")
- apply simp
- apply (simp add: Cart_eq)
- done
-
-subsection{* Orthogonality. *}
-
-definition "orthogonal x y \<longleftrightarrow> (x \<bullet> y = 0)"
-
-lemma orthogonal_basis:
- shows "orthogonal (basis i :: 'a^'n::finite) x \<longleftrightarrow> x$i = (0::'a::ring_1)"
- by (auto simp add: orthogonal_def dot_def basis_def cond_value_iff cond_application_beta setsum_delta cong del: if_weak_cong)
-
-lemma orthogonal_basis_basis:
- shows "orthogonal (basis i :: 'a::ring_1^'n::finite) (basis j) \<longleftrightarrow> i \<noteq> j"
- unfolding orthogonal_basis[of i] basis_component[of j] by simp
-
- (* FIXME : Maybe some of these require less than comm_ring, but not all*)
-lemma orthogonal_clauses:
- "orthogonal a (0::'a::comm_ring ^'n)"
- "orthogonal a x ==> orthogonal a (c *s x)"
- "orthogonal a x ==> orthogonal a (-x)"
- "orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x + y)"
- "orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x - y)"
- "orthogonal 0 a"
- "orthogonal x a ==> orthogonal (c *s x) a"
- "orthogonal x a ==> orthogonal (-x) a"
- "orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x + y) a"
- "orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x - y) a"
- unfolding orthogonal_def dot_rneg dot_rmult dot_radd dot_rsub
- dot_lzero dot_rzero dot_lneg dot_lmult dot_ladd dot_lsub
- by simp_all
-
-lemma orthogonal_commute: "orthogonal (x::'a::{ab_semigroup_mult,comm_monoid_add} ^'n)y \<longleftrightarrow> orthogonal y x"
- by (simp add: orthogonal_def dot_sym)
-
-subsection{* Explicit vector construction from lists. *}
-
-primrec from_nat :: "nat \<Rightarrow> 'a::{monoid_add,one}"
-where "from_nat 0 = 0" | "from_nat (Suc n) = 1 + from_nat n"
-
-lemma from_nat [simp]: "from_nat = of_nat"
-by (rule ext, induct_tac x, simp_all)
-
-primrec
- list_fun :: "nat \<Rightarrow> _ list \<Rightarrow> _ \<Rightarrow> _"
-where
- "list_fun n [] = (\<lambda>x. 0)"
-| "list_fun n (x # xs) = fun_upd (list_fun (Suc n) xs) (from_nat n) x"
-
-definition "vector l = (\<chi> i. list_fun 1 l i)"
-(*definition "vector l = (\<chi> i. if i <= length l then l ! (i - 1) else 0)"*)
-
-lemma vector_1: "(vector[x]) $1 = x"
- unfolding vector_def by simp
-
-lemma vector_2:
- "(vector[x,y]) $1 = x"
- "(vector[x,y] :: 'a^2)$2 = (y::'a::zero)"
- unfolding vector_def by simp_all
-
-lemma vector_3:
- "(vector [x,y,z] ::('a::zero)^3)$1 = x"
- "(vector [x,y,z] ::('a::zero)^3)$2 = y"
- "(vector [x,y,z] ::('a::zero)^3)$3 = z"
- unfolding vector_def by simp_all
-
-lemma forall_vector_1: "(\<forall>v::'a::zero^1. P v) \<longleftrightarrow> (\<forall>x. P(vector[x]))"
- apply auto
- apply (erule_tac x="v$1" in allE)
- apply (subgoal_tac "vector [v$1] = v")
- apply simp
- apply (vector vector_def)
- apply (simp add: forall_1)
- done
-
-lemma forall_vector_2: "(\<forall>v::'a::zero^2. P v) \<longleftrightarrow> (\<forall>x y. P(vector[x, y]))"
- apply auto
- apply (erule_tac x="v$1" in allE)
- apply (erule_tac x="v$2" in allE)
- apply (subgoal_tac "vector [v$1, v$2] = v")
- apply simp
- apply (vector vector_def)
- apply (simp add: forall_2)
- done
-
-lemma forall_vector_3: "(\<forall>v::'a::zero^3. P v) \<longleftrightarrow> (\<forall>x y z. P(vector[x, y, z]))"
- apply auto
- apply (erule_tac x="v$1" in allE)
- apply (erule_tac x="v$2" in allE)
- apply (erule_tac x="v$3" in allE)
- apply (subgoal_tac "vector [v$1, v$2, v$3] = v")
- apply simp
- apply (vector vector_def)
- apply (simp add: forall_3)
- done
-
-subsection{* Linear functions. *}
-
-definition "linear f \<longleftrightarrow> (\<forall>x y. f(x + y) = f x + f y) \<and> (\<forall>c x. f(c *s x) = c *s f x)"
-
-lemma linear_compose_cmul: "linear f ==> linear (\<lambda>x. (c::'a::comm_semiring) *s f x)"
- by (vector linear_def Cart_eq ring_simps)
-
-lemma linear_compose_neg: "linear (f :: 'a ^'n \<Rightarrow> 'a::comm_ring ^'m) ==> linear (\<lambda>x. -(f(x)))" by (vector linear_def Cart_eq)
-
-lemma linear_compose_add: "linear (f :: 'a ^'n \<Rightarrow> 'a::semiring_1 ^'m) \<Longrightarrow> linear g ==> linear (\<lambda>x. f(x) + g(x))"
- by (vector linear_def Cart_eq ring_simps)
-
-lemma linear_compose_sub: "linear (f :: 'a ^'n \<Rightarrow> 'a::ring_1 ^'m) \<Longrightarrow> linear g ==> linear (\<lambda>x. f x - g x)"
- by (vector linear_def Cart_eq ring_simps)
-
-lemma linear_compose: "linear f \<Longrightarrow> linear g ==> linear (g o f)"
- by (simp add: linear_def)
-
-lemma linear_id: "linear id" by (simp add: linear_def id_def)
-
-lemma linear_zero: "linear (\<lambda>x. 0::'a::semiring_1 ^ 'n)" by (simp add: linear_def)
-
-lemma linear_compose_setsum:
- assumes fS: "finite S" and lS: "\<forall>a \<in> S. linear (f a :: 'a::semiring_1 ^ 'n \<Rightarrow> 'a ^ 'm)"
- shows "linear(\<lambda>x. setsum (\<lambda>a. f a x :: 'a::semiring_1 ^'m) S)"
- using lS
- apply (induct rule: finite_induct[OF fS])
- by (auto simp add: linear_zero intro: linear_compose_add)
-
-lemma linear_vmul_component:
- fixes f:: "'a::semiring_1^'m \<Rightarrow> 'a^'n"
- assumes lf: "linear f"
- shows "linear (\<lambda>x. f x $ k *s v)"
- using lf
- apply (auto simp add: linear_def )
- by (vector ring_simps)+
-
-lemma linear_0: "linear f ==> f 0 = (0::'a::semiring_1 ^'n)"
- unfolding linear_def
- apply clarsimp
- apply (erule allE[where x="0::'a"])
- apply simp
- done
-
-lemma linear_cmul: "linear f ==> f(c*s x) = c *s f x" by (simp add: linear_def)
-
-lemma linear_neg: "linear (f :: 'a::ring_1 ^'n \<Rightarrow> _) ==> f (-x) = - f x"
- unfolding vector_sneg_minus1
- using linear_cmul[of f] by auto
-
-lemma linear_add: "linear f ==> f(x + y) = f x + f y" by (metis linear_def)
-
-lemma linear_sub: "linear (f::'a::ring_1 ^'n \<Rightarrow> _) ==> f(x - y) = f x - f y"
- by (simp add: diff_def linear_add linear_neg)
-
-lemma linear_setsum:
- fixes f:: "'a::semiring_1^'n \<Rightarrow> _"
- assumes lf: "linear f" and fS: "finite S"
- shows "f (setsum g S) = setsum (f o g) S"
-proof (induct rule: finite_induct[OF fS])
- case 1 thus ?case by (simp add: linear_0[OF lf])
-next
- case (2 x F)
- have "f (setsum g (insert x F)) = f (g x + setsum g F)" using "2.hyps"
- by simp
- also have "\<dots> = f (g x) + f (setsum g F)" using linear_add[OF lf] by simp
- also have "\<dots> = setsum (f o g) (insert x F)" using "2.hyps" by simp
- finally show ?case .
-qed
-
-lemma linear_setsum_mul:
- fixes f:: "'a ^'n \<Rightarrow> 'a::semiring_1^'m"
- assumes lf: "linear f" and fS: "finite S"
- shows "f (setsum (\<lambda>i. c i *s v i) S) = setsum (\<lambda>i. c i *s f (v i)) S"
- using linear_setsum[OF lf fS, of "\<lambda>i. c i *s v i" , unfolded o_def]
- linear_cmul[OF lf] by simp
-
-lemma linear_injective_0:
- assumes lf: "linear (f:: 'a::ring_1 ^ 'n \<Rightarrow> _)"
- shows "inj f \<longleftrightarrow> (\<forall>x. f x = 0 \<longrightarrow> x = 0)"
-proof-
- have "inj f \<longleftrightarrow> (\<forall> x y. f x = f y \<longrightarrow> x = y)" by (simp add: inj_on_def)
- also have "\<dots> \<longleftrightarrow> (\<forall> x y. f x - f y = 0 \<longrightarrow> x - y = 0)" by simp
- also have "\<dots> \<longleftrightarrow> (\<forall> x y. f (x - y) = 0 \<longrightarrow> x - y = 0)"
- by (simp add: linear_sub[OF lf])
- also have "\<dots> \<longleftrightarrow> (\<forall> x. f x = 0 \<longrightarrow> x = 0)" by auto
- finally show ?thesis .
-qed
-
-lemma linear_bounded:
- fixes f:: "real ^'m::finite \<Rightarrow> real ^'n::finite"
- assumes lf: "linear f"
- shows "\<exists>B. \<forall>x. norm (f x) \<le> B * norm x"
-proof-
- let ?S = "UNIV:: 'm set"
- let ?B = "setsum (\<lambda>i. norm(f(basis i))) ?S"
- have fS: "finite ?S" by simp
- {fix x:: "real ^ 'm"
- let ?g = "(\<lambda>i. (x$i) *s (basis i) :: real ^ 'm)"
- have "norm (f x) = norm (f (setsum (\<lambda>i. (x$i) *s (basis i)) ?S))"
- by (simp only: basis_expansion)
- also have "\<dots> = norm (setsum (\<lambda>i. (x$i) *s f (basis i))?S)"
- using linear_setsum[OF lf fS, of ?g, unfolded o_def] linear_cmul[OF lf]
- by auto
- finally have th0: "norm (f x) = norm (setsum (\<lambda>i. (x$i) *s f (basis i))?S)" .
- {fix i assume i: "i \<in> ?S"
- from component_le_norm[of x i]
- have "norm ((x$i) *s f (basis i :: real ^'m)) \<le> norm (f (basis i)) * norm x"
- unfolding norm_mul
- apply (simp only: mult_commute)
- apply (rule mult_mono)
- by (auto simp add: ring_simps norm_ge_zero) }
- then have th: "\<forall>i\<in> ?S. norm ((x$i) *s f (basis i :: real ^'m)) \<le> norm (f (basis i)) * norm x" by metis
- from real_setsum_norm_le[OF fS, of "\<lambda>i. (x$i) *s (f (basis i))", OF th]
- have "norm (f x) \<le> ?B * norm x" unfolding th0 setsum_left_distrib by metis}
- then show ?thesis by blast
-qed
-
-lemma linear_bounded_pos:
- fixes f:: "real ^'n::finite \<Rightarrow> real ^ 'm::finite"
- assumes lf: "linear f"
- shows "\<exists>B > 0. \<forall>x. norm (f x) \<le> B * norm x"
-proof-
- from linear_bounded[OF lf] obtain B where
- B: "\<forall>x. norm (f x) \<le> B * norm x" by blast
- let ?K = "\<bar>B\<bar> + 1"
- have Kp: "?K > 0" by arith
- {assume C: "B < 0"
- have "norm (1::real ^ 'n) > 0" by (simp add: zero_less_norm_iff)
- with C have "B * norm (1:: real ^ 'n) < 0"
- by (simp add: zero_compare_simps)
- with B[rule_format, of 1] norm_ge_zero[of "f 1"] have False by simp
- }
- then have Bp: "B \<ge> 0" by ferrack
- {fix x::"real ^ 'n"
- have "norm (f x) \<le> ?K * norm x"
- using B[rule_format, of x] norm_ge_zero[of x] norm_ge_zero[of "f x"] Bp
- apply (auto simp add: ring_simps split add: abs_split)
- apply (erule order_trans, simp)
- done
- }
- then show ?thesis using Kp by blast
-qed
-
-lemma smult_conv_scaleR: "c *s x = scaleR c x"
- unfolding vector_scalar_mult_def vector_scaleR_def by simp
-
-lemma linear_conv_bounded_linear:
- fixes f :: "real ^ _ \<Rightarrow> real ^ _"
- shows "linear f \<longleftrightarrow> bounded_linear f"
-proof
- assume "linear f"
- show "bounded_linear f"
- proof
- fix x y show "f (x + y) = f x + f y"
- using `linear f` unfolding linear_def by simp
- next
- fix r x show "f (scaleR r x) = scaleR r (f x)"
- using `linear f` unfolding linear_def
- by (simp add: smult_conv_scaleR)
- next
- have "\<exists>B. \<forall>x. norm (f x) \<le> B * norm x"
- using `linear f` by (rule linear_bounded)
- thus "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
- by (simp add: mult_commute)
- qed
-next
- assume "bounded_linear f"
- then interpret f: bounded_linear f .
- show "linear f"
- unfolding linear_def smult_conv_scaleR
- by (simp add: f.add f.scaleR)
-qed
-
-subsection{* Bilinear functions. *}
-
-definition "bilinear f \<longleftrightarrow> (\<forall>x. linear(\<lambda>y. f x y)) \<and> (\<forall>y. linear(\<lambda>x. f x y))"
-
-lemma bilinear_ladd: "bilinear h ==> h (x + y) z = (h x z) + (h y z)"
- by (simp add: bilinear_def linear_def)
-lemma bilinear_radd: "bilinear h ==> h x (y + z) = (h x y) + (h x z)"
- by (simp add: bilinear_def linear_def)
-
-lemma bilinear_lmul: "bilinear h ==> h (c *s x) y = c *s (h x y)"
- by (simp add: bilinear_def linear_def)
-
-lemma bilinear_rmul: "bilinear h ==> h x (c *s y) = c *s (h x y)"
- by (simp add: bilinear_def linear_def)
-
-lemma bilinear_lneg: "bilinear h ==> h (- (x:: 'a::ring_1 ^ 'n)) y = -(h x y)"
- by (simp only: vector_sneg_minus1 bilinear_lmul)
-
-lemma bilinear_rneg: "bilinear h ==> h x (- (y:: 'a::ring_1 ^ 'n)) = - h x y"
- by (simp only: vector_sneg_minus1 bilinear_rmul)
-
-lemma (in ab_group_add) eq_add_iff: "x = x + y \<longleftrightarrow> y = 0"
- using add_imp_eq[of x y 0] by auto
-
-lemma bilinear_lzero:
- fixes h :: "'a::ring^'n \<Rightarrow> _" assumes bh: "bilinear h" shows "h 0 x = 0"
- using bilinear_ladd[OF bh, of 0 0 x]
- by (simp add: eq_add_iff ring_simps)
-
-lemma bilinear_rzero:
- fixes h :: "'a::ring^'n \<Rightarrow> _" assumes bh: "bilinear h" shows "h x 0 = 0"
- using bilinear_radd[OF bh, of x 0 0 ]
- by (simp add: eq_add_iff ring_simps)
-
-lemma bilinear_lsub: "bilinear h ==> h (x - (y:: 'a::ring_1 ^ 'n)) z = h x z - h y z"
- by (simp add: diff_def bilinear_ladd bilinear_lneg)
-
-lemma bilinear_rsub: "bilinear h ==> h z (x - (y:: 'a::ring_1 ^ 'n)) = h z x - h z y"
- by (simp add: diff_def bilinear_radd bilinear_rneg)
-
-lemma bilinear_setsum:
- fixes h:: "'a ^'n \<Rightarrow> 'a::semiring_1^'m \<Rightarrow> 'a ^ 'k"
- assumes bh: "bilinear h" and fS: "finite S" and fT: "finite T"
- shows "h (setsum f S) (setsum g T) = setsum (\<lambda>(i,j). h (f i) (g j)) (S \<times> T) "
-proof-
- have "h (setsum f S) (setsum g T) = setsum (\<lambda>x. h (f x) (setsum g T)) S"
- apply (rule linear_setsum[unfolded o_def])
- using bh fS by (auto simp add: bilinear_def)
- also have "\<dots> = setsum (\<lambda>x. setsum (\<lambda>y. h (f x) (g y)) T) S"
- apply (rule setsum_cong, simp)
- apply (rule linear_setsum[unfolded o_def])
- using bh fT by (auto simp add: bilinear_def)
- finally show ?thesis unfolding setsum_cartesian_product .
-qed
-
-lemma bilinear_bounded:
- fixes h:: "real ^'m::finite \<Rightarrow> real^'n::finite \<Rightarrow> real ^ 'k::finite"
- assumes bh: "bilinear h"
- shows "\<exists>B. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
-proof-
- let ?M = "UNIV :: 'm set"
- let ?N = "UNIV :: 'n set"
- let ?B = "setsum (\<lambda>(i,j). norm (h (basis i) (basis j))) (?M \<times> ?N)"
- have fM: "finite ?M" and fN: "finite ?N" by simp_all
- {fix x:: "real ^ 'm" and y :: "real^'n"
- have "norm (h x y) = norm (h (setsum (\<lambda>i. (x$i) *s basis i) ?M) (setsum (\<lambda>i. (y$i) *s basis i) ?N))" unfolding basis_expansion ..
- also have "\<dots> = norm (setsum (\<lambda> (i,j). h ((x$i) *s basis i) ((y$j) *s basis j)) (?M \<times> ?N))" unfolding bilinear_setsum[OF bh fM fN] ..
- finally have th: "norm (h x y) = \<dots>" .
- have "norm (h x y) \<le> ?B * norm x * norm y"
- apply (simp add: setsum_left_distrib th)
- apply (rule real_setsum_norm_le)
- using fN fM
- apply simp
- apply (auto simp add: bilinear_rmul[OF bh] bilinear_lmul[OF bh] norm_mul ring_simps)
- apply (rule mult_mono)
- apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
- apply (rule mult_mono)
- apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
- done}
- then show ?thesis by metis
-qed
-
-lemma bilinear_bounded_pos:
- fixes h:: "real ^'m::finite \<Rightarrow> real^'n::finite \<Rightarrow> real ^ 'k::finite"
- assumes bh: "bilinear h"
- shows "\<exists>B > 0. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
-proof-
- from bilinear_bounded[OF bh] obtain B where
- B: "\<forall>x y. norm (h x y) \<le> B * norm x * norm y" by blast
- let ?K = "\<bar>B\<bar> + 1"
- have Kp: "?K > 0" by arith
- have KB: "B < ?K" by arith
- {fix x::"real ^'m" and y :: "real ^'n"
- from KB Kp
- have "B * norm x * norm y \<le> ?K * norm x * norm y"
- apply -
- apply (rule mult_right_mono, rule mult_right_mono)
- by (auto simp add: norm_ge_zero)
- then have "norm (h x y) \<le> ?K * norm x * norm y"
- using B[rule_format, of x y] by simp}
- with Kp show ?thesis by blast
-qed
-
-lemma bilinear_conv_bounded_bilinear:
- fixes h :: "real ^ _ \<Rightarrow> real ^ _ \<Rightarrow> real ^ _"
- shows "bilinear h \<longleftrightarrow> bounded_bilinear h"
-proof
- assume "bilinear h"
- show "bounded_bilinear h"
- proof
- fix x y z show "h (x + y) z = h x z + h y z"
- using `bilinear h` unfolding bilinear_def linear_def by simp
- next
- fix x y z show "h x (y + z) = h x y + h x z"
- using `bilinear h` unfolding bilinear_def linear_def by simp
- next
- fix r x y show "h (scaleR r x) y = scaleR r (h x y)"
- using `bilinear h` unfolding bilinear_def linear_def
- by (simp add: smult_conv_scaleR)
- next
- fix r x y show "h x (scaleR r y) = scaleR r (h x y)"
- using `bilinear h` unfolding bilinear_def linear_def
- by (simp add: smult_conv_scaleR)
- next
- have "\<exists>B. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
- using `bilinear h` by (rule bilinear_bounded)
- thus "\<exists>K. \<forall>x y. norm (h x y) \<le> norm x * norm y * K"
- by (simp add: mult_ac)
- qed
-next
- assume "bounded_bilinear h"
- then interpret h: bounded_bilinear h .
- show "bilinear h"
- unfolding bilinear_def linear_conv_bounded_linear
- using h.bounded_linear_left h.bounded_linear_right
- by simp
-qed
-
-subsection{* Adjoints. *}
-
-definition "adjoint f = (SOME f'. \<forall>x y. f x \<bullet> y = x \<bullet> f' y)"
-
-lemma choice_iff: "(\<forall>x. \<exists>y. P x y) \<longleftrightarrow> (\<exists>f. \<forall>x. P x (f x))" by metis
-
-lemma adjoint_works_lemma:
- fixes f:: "'a::ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f"
- shows "\<forall>x y. f x \<bullet> y = x \<bullet> adjoint f y"
-proof-
- let ?N = "UNIV :: 'n set"
- let ?M = "UNIV :: 'm set"
- have fN: "finite ?N" by simp
- have fM: "finite ?M" by simp
- {fix y:: "'a ^ 'm"
- let ?w = "(\<chi> i. (f (basis i) \<bullet> y)) :: 'a ^ 'n"
- {fix x
- have "f x \<bullet> y = f (setsum (\<lambda>i. (x$i) *s basis i) ?N) \<bullet> y"
- by (simp only: basis_expansion)
- also have "\<dots> = (setsum (\<lambda>i. (x$i) *s f (basis i)) ?N) \<bullet> y"
- unfolding linear_setsum[OF lf fN]
- by (simp add: linear_cmul[OF lf])
- finally have "f x \<bullet> y = x \<bullet> ?w"
- apply (simp only: )
- apply (simp add: dot_def setsum_left_distrib setsum_right_distrib setsum_commute[of _ ?M ?N] ring_simps)
- done}
- }
- then show ?thesis unfolding adjoint_def
- some_eq_ex[of "\<lambda>f'. \<forall>x y. f x \<bullet> y = x \<bullet> f' y"]
- using choice_iff[of "\<lambda>a b. \<forall>x. f x \<bullet> a = x \<bullet> b "]
- by metis
-qed
-
-lemma adjoint_works:
- fixes f:: "'a::ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f"
- shows "x \<bullet> adjoint f y = f x \<bullet> y"
- using adjoint_works_lemma[OF lf] by metis
-
-
-lemma adjoint_linear:
- fixes f :: "'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f"
- shows "linear (adjoint f)"
- by (simp add: linear_def vector_eq_ldot[symmetric] dot_radd dot_rmult adjoint_works[OF lf])
-
-lemma adjoint_clauses:
- fixes f:: "'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f"
- shows "x \<bullet> adjoint f y = f x \<bullet> y"
- and "adjoint f y \<bullet> x = y \<bullet> f x"
- by (simp_all add: adjoint_works[OF lf] dot_sym )
-
-lemma adjoint_adjoint:
- fixes f:: "'a::comm_ring_1 ^ 'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f"
- shows "adjoint (adjoint f) = f"
- apply (rule ext)
- by (simp add: vector_eq_ldot[symmetric] adjoint_clauses[OF adjoint_linear[OF lf]] adjoint_clauses[OF lf])
-
-lemma adjoint_unique:
- fixes f:: "'a::comm_ring_1 ^ 'n::finite \<Rightarrow> 'a ^ 'm::finite"
- assumes lf: "linear f" and u: "\<forall>x y. f' x \<bullet> y = x \<bullet> f y"
- shows "f' = adjoint f"
- apply (rule ext)
- using u
- by (simp add: vector_eq_rdot[symmetric] adjoint_clauses[OF lf])
-
-text{* Matrix notation. NB: an MxN matrix is of type @{typ "'a^'n^'m"}, not @{typ "'a^'m^'n"} *}
-
-consts generic_mult :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr "\<star>" 75)
-
-defs (overloaded)
-matrix_matrix_mult_def: "(m:: ('a::semiring_1) ^'n^'m) \<star> (m' :: 'a ^'p^'n) \<equiv> (\<chi> i j. setsum (\<lambda>k. ((m$i)$k) * ((m'$k)$j)) (UNIV :: 'n set)) ::'a ^ 'p ^'m"
-
-abbreviation
- matrix_matrix_mult' :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'p^'n \<Rightarrow> 'a ^ 'p ^'m" (infixl "**" 70)
- where "m ** m' == m\<star> m'"
-
-defs (overloaded)
- matrix_vector_mult_def: "(m::('a::semiring_1) ^'n^'m) \<star> (x::'a ^'n) \<equiv> (\<chi> i. setsum (\<lambda>j. ((m$i)$j) * (x$j)) (UNIV ::'n set)) :: 'a^'m"
-
-abbreviation
- matrix_vector_mult' :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'm" (infixl "*v" 70)
- where
- "m *v v == m \<star> v"
-
-defs (overloaded)
- vector_matrix_mult_def: "(x::'a^'m) \<star> (m::('a::semiring_1) ^'n^'m) \<equiv> (\<chi> j. setsum (\<lambda>i. ((m$i)$j) * (x$i)) (UNIV :: 'm set)) :: 'a^'n"
-
-abbreviation
- vactor_matrix_mult' :: "'a ^ 'm \<Rightarrow> ('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n " (infixl "v*" 70)
- where
- "v v* m == v \<star> m"
-
-definition "(mat::'a::zero => 'a ^'n^'n) k = (\<chi> i j. if i = j then k else 0)"
-definition "(transp::'a^'n^'m \<Rightarrow> 'a^'m^'n) A = (\<chi> i j. ((A$j)$i))"
-definition "(row::'m => 'a ^'n^'m \<Rightarrow> 'a ^'n) i A = (\<chi> j. ((A$i)$j))"
-definition "(column::'n =>'a^'n^'m =>'a^'m) j A = (\<chi> i. ((A$i)$j))"
-definition "rows(A::'a^'n^'m) = { row i A | i. i \<in> (UNIV :: 'm set)}"
-definition "columns(A::'a^'n^'m) = { column i A | i. i \<in> (UNIV :: 'n set)}"
-
-lemma mat_0[simp]: "mat 0 = 0" by (vector mat_def)
-lemma matrix_add_ldistrib: "(A ** (B + C)) = (A \<star> B) + (A \<star> C)"
- by (vector matrix_matrix_mult_def setsum_addf[symmetric] ring_simps)
-
-lemma matrix_mul_lid:
- fixes A :: "'a::semiring_1 ^ 'm ^ 'n::finite"
- shows "mat 1 ** A = A"
- apply (simp add: matrix_matrix_mult_def mat_def)
- apply vector
- by (auto simp only: cond_value_iff cond_application_beta setsum_delta'[OF finite] mult_1_left mult_zero_left if_True UNIV_I)
-
-
-lemma matrix_mul_rid:
- fixes A :: "'a::semiring_1 ^ 'm::finite ^ 'n"
- shows "A ** mat 1 = A"
- apply (simp add: matrix_matrix_mult_def mat_def)
- apply vector
- by (auto simp only: cond_value_iff cond_application_beta setsum_delta[OF finite] mult_1_right mult_zero_right if_True UNIV_I cong: if_cong)
-
-lemma matrix_mul_assoc: "A ** (B ** C) = (A ** B) ** C"
- apply (vector matrix_matrix_mult_def setsum_right_distrib setsum_left_distrib mult_assoc)
- apply (subst setsum_commute)
- apply simp
- done
-
-lemma matrix_vector_mul_assoc: "A *v (B *v x) = (A ** B) *v x"
- apply (vector matrix_matrix_mult_def matrix_vector_mult_def setsum_right_distrib setsum_left_distrib mult_assoc)
- apply (subst setsum_commute)
- apply simp
- done
-
-lemma matrix_vector_mul_lid: "mat 1 *v x = (x::'a::semiring_1 ^ 'n::finite)"
- apply (vector matrix_vector_mult_def mat_def)
- by (simp add: cond_value_iff cond_application_beta
- setsum_delta' cong del: if_weak_cong)
-
-lemma matrix_transp_mul: "transp(A ** B) = transp B ** transp (A::'a::comm_semiring_1^'m^'n)"
- by (simp add: matrix_matrix_mult_def transp_def Cart_eq mult_commute)
-
-lemma matrix_eq:
- fixes A B :: "'a::semiring_1 ^ 'n::finite ^ 'm"
- shows "A = B \<longleftrightarrow> (\<forall>x. A *v x = B *v x)" (is "?lhs \<longleftrightarrow> ?rhs")
- apply auto
- apply (subst Cart_eq)
- apply clarify
- apply (clarsimp simp add: matrix_vector_mult_def basis_def cond_value_iff cond_application_beta Cart_eq cong del: if_weak_cong)
- apply (erule_tac x="basis ia" in allE)
- apply (erule_tac x="i" in allE)
- by (auto simp add: basis_def cond_value_iff cond_application_beta setsum_delta[OF finite] cong del: if_weak_cong)
-
-lemma matrix_vector_mul_component:
- shows "((A::'a::semiring_1^'n'^'m) *v x)$k = (A$k) \<bullet> x"
- by (simp add: matrix_vector_mult_def dot_def)
-
-lemma dot_lmul_matrix: "((x::'a::comm_semiring_1 ^'n) v* A) \<bullet> y = x \<bullet> (A *v y)"
- apply (simp add: dot_def matrix_vector_mult_def vector_matrix_mult_def setsum_left_distrib setsum_right_distrib mult_ac)
- apply (subst setsum_commute)
- by simp
-
-lemma transp_mat: "transp (mat n) = mat n"
- by (vector transp_def mat_def)
-
-lemma transp_transp: "transp(transp A) = A"
- by (vector transp_def)
-
-lemma row_transp:
- fixes A:: "'a::semiring_1^'n^'m"
- shows "row i (transp A) = column i A"
- by (simp add: row_def column_def transp_def Cart_eq)
-
-lemma column_transp:
- fixes A:: "'a::semiring_1^'n^'m"
- shows "column i (transp A) = row i A"
- by (simp add: row_def column_def transp_def Cart_eq)
-
-lemma rows_transp: "rows(transp (A::'a::semiring_1^'n^'m)) = columns A"
-by (auto simp add: rows_def columns_def row_transp intro: set_ext)
-
-lemma columns_transp: "columns(transp (A::'a::semiring_1^'n^'m)) = rows A" by (metis transp_transp rows_transp)
-
-text{* Two sometimes fruitful ways of looking at matrix-vector multiplication. *}
-
-lemma matrix_mult_dot: "A *v x = (\<chi> i. A$i \<bullet> x)"
- by (simp add: matrix_vector_mult_def dot_def)
-
-lemma matrix_mult_vsum: "(A::'a::comm_semiring_1^'n^'m) *v x = setsum (\<lambda>i. (x$i) *s column i A) (UNIV:: 'n set)"
- by (simp add: matrix_vector_mult_def Cart_eq column_def mult_commute)
-
-lemma vector_componentwise:
- "(x::'a::ring_1^'n::finite) = (\<chi> j. setsum (\<lambda>i. (x$i) * (basis i :: 'a^'n)$j) (UNIV :: 'n set))"
- apply (subst basis_expansion[symmetric])
- by (vector Cart_eq setsum_component)
-
-lemma linear_componentwise:
- fixes f:: "'a::ring_1 ^ 'm::finite \<Rightarrow> 'a ^ 'n"
- assumes lf: "linear f"
- shows "(f x)$j = setsum (\<lambda>i. (x$i) * (f (basis i)$j)) (UNIV :: 'm set)" (is "?lhs = ?rhs")
-proof-
- let ?M = "(UNIV :: 'm set)"
- let ?N = "(UNIV :: 'n set)"
- have fM: "finite ?M" by simp
- have "?rhs = (setsum (\<lambda>i.(x$i) *s f (basis i) ) ?M)$j"
- unfolding vector_smult_component[symmetric]
- unfolding setsum_component[of "(\<lambda>i.(x$i) *s f (basis i :: 'a^'m))" ?M]
- ..
- then show ?thesis unfolding linear_setsum_mul[OF lf fM, symmetric] basis_expansion ..
-qed
-
-text{* Inverse matrices (not necessarily square) *}
-
-definition "invertible(A::'a::semiring_1^'n^'m) \<longleftrightarrow> (\<exists>A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"
-
-definition "matrix_inv(A:: 'a::semiring_1^'n^'m) =
- (SOME A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"
-
-text{* Correspondence between matrices and linear operators. *}
-
-definition matrix:: "('a::{plus,times, one, zero}^'m \<Rightarrow> 'a ^ 'n) \<Rightarrow> 'a^'m^'n"
-where "matrix f = (\<chi> i j. (f(basis j))$i)"
-
-lemma matrix_vector_mul_linear: "linear(\<lambda>x. A *v (x::'a::comm_semiring_1 ^ 'n))"
- by (simp add: linear_def matrix_vector_mult_def Cart_eq ring_simps setsum_right_distrib setsum_addf)
-
-lemma matrix_works: assumes lf: "linear f" shows "matrix f *v x = f (x::'a::comm_ring_1 ^ 'n::finite)"
-apply (simp add: matrix_def matrix_vector_mult_def Cart_eq mult_commute)
-apply clarify
-apply (rule linear_componentwise[OF lf, symmetric])
-done
-
-lemma matrix_vector_mul: "linear f ==> f = (\<lambda>x. matrix f *v (x::'a::comm_ring_1 ^ 'n::finite))" by (simp add: ext matrix_works)
-
-lemma matrix_of_matrix_vector_mul: "matrix(\<lambda>x. A *v (x :: 'a:: comm_ring_1 ^ 'n::finite)) = A"
- by (simp add: matrix_eq matrix_vector_mul_linear matrix_works)
-
-lemma matrix_compose:
- assumes lf: "linear (f::'a::comm_ring_1^'n::finite \<Rightarrow> 'a^'m::finite)"
- and lg: "linear (g::'a::comm_ring_1^'m::finite \<Rightarrow> 'a^'k)"
- shows "matrix (g o f) = matrix g ** matrix f"
- using lf lg linear_compose[OF lf lg] matrix_works[OF linear_compose[OF lf lg]]
- by (simp add: matrix_eq matrix_works matrix_vector_mul_assoc[symmetric] o_def)
-
-lemma matrix_vector_column:"(A::'a::comm_semiring_1^'n^'m) *v x = setsum (\<lambda>i. (x$i) *s ((transp A)$i)) (UNIV:: 'n set)"
- by (simp add: matrix_vector_mult_def transp_def Cart_eq mult_commute)
-
-lemma adjoint_matrix: "adjoint(\<lambda>x. (A::'a::comm_ring_1^'n::finite^'m::finite) *v x) = (\<lambda>x. transp A *v x)"
- apply (rule adjoint_unique[symmetric])
- apply (rule matrix_vector_mul_linear)
- apply (simp add: transp_def dot_def matrix_vector_mult_def setsum_left_distrib setsum_right_distrib)
- apply (subst setsum_commute)
- apply (auto simp add: mult_ac)
- done
-
-lemma matrix_adjoint: assumes lf: "linear (f :: 'a::comm_ring_1^'n::finite \<Rightarrow> 'a ^ 'm::finite)"
- shows "matrix(adjoint f) = transp(matrix f)"
- apply (subst matrix_vector_mul[OF lf])
- unfolding adjoint_matrix matrix_of_matrix_vector_mul ..
-
-subsection{* Interlude: Some properties of real sets *}
-
-lemma seq_mono_lemma: assumes "\<forall>(n::nat) \<ge> m. (d n :: real) < e n" and "\<forall>n \<ge> m. e n <= e m"
- shows "\<forall>n \<ge> m. d n < e m"
- using prems apply auto
- apply (erule_tac x="n" in allE)
- apply (erule_tac x="n" in allE)
- apply auto
- done
-
-
-lemma real_convex_bound_lt:
- assumes xa: "(x::real) < a" and ya: "y < a" and u: "0 <= u" and v: "0 <= v"
- and uv: "u + v = 1"
- shows "u * x + v * y < a"
-proof-
- have uv': "u = 0 \<longrightarrow> v \<noteq> 0" using u v uv by arith
- have "a = a * (u + v)" unfolding uv by simp
- hence th: "u * a + v * a = a" by (simp add: ring_simps)
- from xa u have "u \<noteq> 0 \<Longrightarrow> u*x < u*a" by (simp add: mult_compare_simps)
- from ya v have "v \<noteq> 0 \<Longrightarrow> v * y < v * a" by (simp add: mult_compare_simps)
- from xa ya u v have "u * x + v * y < u * a + v * a"
- apply (cases "u = 0", simp_all add: uv')
- apply(rule mult_strict_left_mono)
- using uv' apply simp_all
-
- apply (rule add_less_le_mono)
- apply(rule mult_strict_left_mono)
- apply simp_all
- apply (rule mult_left_mono)
- apply simp_all
- done
- thus ?thesis unfolding th .
-qed
-
-lemma real_convex_bound_le:
- assumes xa: "(x::real) \<le> a" and ya: "y \<le> a" and u: "0 <= u" and v: "0 <= v"
- and uv: "u + v = 1"
- shows "u * x + v * y \<le> a"
-proof-
- from xa ya u v have "u * x + v * y \<le> u * a + v * a" by (simp add: add_mono mult_left_mono)
- also have "\<dots> \<le> (u + v) * a" by (simp add: ring_simps)
- finally show ?thesis unfolding uv by simp
-qed
-
-lemma infinite_enumerate: assumes fS: "infinite S"
- shows "\<exists>r. subseq r \<and> (\<forall>n. r n \<in> S)"
-unfolding subseq_def
-using enumerate_in_set[OF fS] enumerate_mono[of _ _ S] fS by auto
-
-lemma approachable_lt_le: "(\<exists>(d::real)>0. \<forall>x. f x < d \<longrightarrow> P x) \<longleftrightarrow> (\<exists>d>0. \<forall>x. f x \<le> d \<longrightarrow> P x)"
-apply auto
-apply (rule_tac x="d/2" in exI)
-apply auto
-done
-
-
-lemma triangle_lemma:
- assumes x: "0 <= (x::real)" and y:"0 <= y" and z: "0 <= z" and xy: "x^2 <= y^2 + z^2"
- shows "x <= y + z"
-proof-
- have "y^2 + z^2 \<le> y^2 + 2*y*z + z^2" using z y by (simp add: zero_compare_simps)
- with xy have th: "x ^2 \<le> (y+z)^2" by (simp add: power2_eq_square ring_simps)
- from y z have yz: "y + z \<ge> 0" by arith
- from power2_le_imp_le[OF th yz] show ?thesis .
-qed
-
-
-lemma lambda_skolem: "(\<forall>i. \<exists>x. P i x) \<longleftrightarrow>
- (\<exists>x::'a ^ 'n. \<forall>i. P i (x$i))" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- let ?S = "(UNIV :: 'n set)"
- {assume H: "?rhs"
- then have ?lhs by auto}
- moreover
- {assume H: "?lhs"
- then obtain f where f:"\<forall>i. P i (f i)" unfolding choice_iff by metis
- let ?x = "(\<chi> i. (f i)) :: 'a ^ 'n"
- {fix i
- from f have "P i (f i)" by metis
- then have "P i (?x$i)" by auto
- }
- hence "\<forall>i. P i (?x$i)" by metis
- hence ?rhs by metis }
- ultimately show ?thesis by metis
-qed
-
-subsection{* Operator norm. *}
-
-definition "onorm f = Sup {norm (f x)| x. norm x = 1}"
-
-lemma norm_bound_generalize:
- fixes f:: "real ^'n::finite \<Rightarrow> real^'m::finite"
- assumes lf: "linear f"
- shows "(\<forall>x. norm x = 1 \<longrightarrow> norm (f x) \<le> b) \<longleftrightarrow> (\<forall>x. norm (f x) \<le> b * norm x)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume H: ?rhs
- {fix x :: "real^'n" assume x: "norm x = 1"
- from H[rule_format, of x] x have "norm (f x) \<le> b" by simp}
- then have ?lhs by blast }
-
- moreover
- {assume H: ?lhs
- from H[rule_format, of "basis arbitrary"]
- have bp: "b \<ge> 0" using norm_ge_zero[of "f (basis arbitrary)"]
- by (auto simp add: norm_basis elim: order_trans [OF norm_ge_zero])
- {fix x :: "real ^'n"
- {assume "x = 0"
- then have "norm (f x) \<le> b * norm x" by (simp add: linear_0[OF lf] bp)}
- moreover
- {assume x0: "x \<noteq> 0"
- hence n0: "norm x \<noteq> 0" by (metis norm_eq_zero)
- let ?c = "1/ norm x"
- have "norm (?c*s x) = 1" using x0 by (simp add: n0 norm_mul)
- with H have "norm (f(?c*s x)) \<le> b" by blast
- hence "?c * norm (f x) \<le> b"
- by (simp add: linear_cmul[OF lf] norm_mul)
- hence "norm (f x) \<le> b * norm x"
- using n0 norm_ge_zero[of x] by (auto simp add: field_simps)}
- ultimately have "norm (f x) \<le> b * norm x" by blast}
- then have ?rhs by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma onorm:
- fixes f:: "real ^'n::finite \<Rightarrow> real ^'m::finite"
- assumes lf: "linear f"
- shows "norm (f x) <= onorm f * norm x"
- and "\<forall>x. norm (f x) <= b * norm x \<Longrightarrow> onorm f <= b"
-proof-
- {
- let ?S = "{norm (f x) |x. norm x = 1}"
- have Se: "?S \<noteq> {}" using norm_basis by auto
- from linear_bounded[OF lf] have b: "\<exists> b. ?S *<= b"
- unfolding norm_bound_generalize[OF lf, symmetric] by (auto simp add: setle_def)
- {from Sup[OF Se b, unfolded onorm_def[symmetric]]
- show "norm (f x) <= onorm f * norm x"
- apply -
- apply (rule spec[where x = x])
- unfolding norm_bound_generalize[OF lf, symmetric]
- by (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)}
- {
- show "\<forall>x. norm (f x) <= b * norm x \<Longrightarrow> onorm f <= b"
- using Sup[OF Se b, unfolded onorm_def[symmetric]]
- unfolding norm_bound_generalize[OF lf, symmetric]
- by (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)}
- }
-qed
-
-lemma onorm_pos_le: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" shows "0 <= onorm f"
- using order_trans[OF norm_ge_zero onorm(1)[OF lf, of "basis arbitrary"], unfolded norm_basis] by simp
-
-lemma onorm_eq_0: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)"
- shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
- using onorm[OF lf]
- apply (auto simp add: onorm_pos_le)
- apply atomize
- apply (erule allE[where x="0::real"])
- using onorm_pos_le[OF lf]
- apply arith
- done
-
-lemma onorm_const: "onorm(\<lambda>x::real^'n::finite. (y::real ^ 'm::finite)) = norm y"
-proof-
- let ?f = "\<lambda>x::real^'n. (y::real ^ 'm)"
- have th: "{norm (?f x)| x. norm x = 1} = {norm y}"
- by(auto intro: vector_choose_size set_ext)
- show ?thesis
- unfolding onorm_def th
- apply (rule Sup_unique) by (simp_all add: setle_def)
-qed
-
-lemma onorm_pos_lt: assumes lf: "linear (f::real ^ 'n::finite \<Rightarrow> real ^'m::finite)"
- shows "0 < onorm f \<longleftrightarrow> ~(\<forall>x. f x = 0)"
- unfolding onorm_eq_0[OF lf, symmetric]
- using onorm_pos_le[OF lf] by arith
-
-lemma onorm_compose:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)"
- and lg: "linear (g::real^'k::finite \<Rightarrow> real^'n::finite)"
- shows "onorm (f o g) <= onorm f * onorm g"
- apply (rule onorm(2)[OF linear_compose[OF lg lf], rule_format])
- unfolding o_def
- apply (subst mult_assoc)
- apply (rule order_trans)
- apply (rule onorm(1)[OF lf])
- apply (rule mult_mono1)
- apply (rule onorm(1)[OF lg])
- apply (rule onorm_pos_le[OF lf])
- done
-
-lemma onorm_neg_lemma: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real^'m::finite)"
- shows "onorm (\<lambda>x. - f x) \<le> onorm f"
- using onorm[OF linear_compose_neg[OF lf]] onorm[OF lf]
- unfolding norm_minus_cancel by metis
-
-lemma onorm_neg: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real^'m::finite)"
- shows "onorm (\<lambda>x. - f x) = onorm f"
- using onorm_neg_lemma[OF lf] onorm_neg_lemma[OF linear_compose_neg[OF lf]]
- by simp
-
-lemma onorm_triangle:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" and lg: "linear g"
- shows "onorm (\<lambda>x. f x + g x) <= onorm f + onorm g"
- apply(rule onorm(2)[OF linear_compose_add[OF lf lg], rule_format])
- apply (rule order_trans)
- apply (rule norm_triangle_ineq)
- apply (simp add: distrib)
- apply (rule add_mono)
- apply (rule onorm(1)[OF lf])
- apply (rule onorm(1)[OF lg])
- done
-
-lemma onorm_triangle_le: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite) \<Longrightarrow> linear g \<Longrightarrow> onorm(f) + onorm(g) <= e
- \<Longrightarrow> onorm(\<lambda>x. f x + g x) <= e"
- apply (rule order_trans)
- apply (rule onorm_triangle)
- apply assumption+
- done
-
-lemma onorm_triangle_lt: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite) \<Longrightarrow> linear g \<Longrightarrow> onorm(f) + onorm(g) < e
- ==> onorm(\<lambda>x. f x + g x) < e"
- apply (rule order_le_less_trans)
- apply (rule onorm_triangle)
- by assumption+
-
-(* "lift" from 'a to 'a^1 and "drop" from 'a^1 to 'a -- FIXME: potential use of transfer *)
-
-definition vec1:: "'a \<Rightarrow> 'a ^ 1" where "vec1 x = (\<chi> i. x)"
-
-definition dest_vec1:: "'a ^1 \<Rightarrow> 'a"
- where "dest_vec1 x = (x$1)"
-
-lemma vec1_component[simp]: "(vec1 x)$1 = x"
- by (simp add: vec1_def)
-
-lemma vec1_dest_vec1[simp]: "vec1(dest_vec1 x) = x" "dest_vec1(vec1 y) = y"
- by (simp_all add: vec1_def dest_vec1_def Cart_eq forall_1)
-
-lemma forall_vec1: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P (vec1 x))" by (metis vec1_dest_vec1)
-
-lemma exists_vec1: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. P(vec1 x))" by (metis vec1_dest_vec1)
-
-lemma forall_dest_vec1: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P(dest_vec1 x))" by (metis vec1_dest_vec1)
-
-lemma exists_dest_vec1: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. P(dest_vec1 x))"by (metis vec1_dest_vec1)
-
-lemma vec1_eq[simp]: "vec1 x = vec1 y \<longleftrightarrow> x = y" by (metis vec1_dest_vec1)
-
-lemma dest_vec1_eq[simp]: "dest_vec1 x = dest_vec1 y \<longleftrightarrow> x = y" by (metis vec1_dest_vec1)
-
-lemma vec1_in_image_vec1: "vec1 x \<in> (vec1 ` S) \<longleftrightarrow> x \<in> S" by auto
-
-lemma vec1_vec: "vec1 x = vec x" by (vector vec1_def)
-
-lemma vec1_add: "vec1(x + y) = vec1 x + vec1 y" by (vector vec1_def)
-lemma vec1_sub: "vec1(x - y) = vec1 x - vec1 y" by (vector vec1_def)
-lemma vec1_cmul: "vec1(c* x) = c *s vec1 x " by (vector vec1_def)
-lemma vec1_neg: "vec1(- x) = - vec1 x " by (vector vec1_def)
-
-lemma vec1_setsum: assumes fS: "finite S"
- shows "vec1(setsum f S) = setsum (vec1 o f) S"
- apply (induct rule: finite_induct[OF fS])
- apply (simp add: vec1_vec)
- apply (auto simp add: vec1_add)
- done
-
-lemma dest_vec1_lambda: "dest_vec1(\<chi> i. x i) = x 1"
- by (simp add: dest_vec1_def)
-
-lemma dest_vec1_vec: "dest_vec1(vec x) = x"
- by (simp add: vec1_vec[symmetric])
-
-lemma dest_vec1_add: "dest_vec1(x + y) = dest_vec1 x + dest_vec1 y"
- by (metis vec1_dest_vec1 vec1_add)
-
-lemma dest_vec1_sub: "dest_vec1(x - y) = dest_vec1 x - dest_vec1 y"
- by (metis vec1_dest_vec1 vec1_sub)
-
-lemma dest_vec1_cmul: "dest_vec1(c*sx) = c * dest_vec1 x"
- by (metis vec1_dest_vec1 vec1_cmul)
-
-lemma dest_vec1_neg: "dest_vec1(- x) = - dest_vec1 x"
- by (metis vec1_dest_vec1 vec1_neg)
-
-lemma dest_vec1_0[simp]: "dest_vec1 0 = 0" by (metis vec_0 dest_vec1_vec)
-
-lemma dest_vec1_sum: assumes fS: "finite S"
- shows "dest_vec1(setsum f S) = setsum (dest_vec1 o f) S"
- apply (induct rule: finite_induct[OF fS])
- apply (simp add: dest_vec1_vec)
- apply (auto simp add: dest_vec1_add)
- done
-
-lemma norm_vec1: "norm(vec1 x) = abs(x)"
- by (simp add: vec1_def norm_real)
-
-lemma dist_vec1: "dist(vec1 x) (vec1 y) = abs(x - y)"
- by (simp only: dist_real vec1_component)
-lemma abs_dest_vec1: "norm x = \<bar>dest_vec1 x\<bar>"
- by (metis vec1_dest_vec1 norm_vec1)
-
-lemma linear_vmul_dest_vec1:
- fixes f:: "'a::semiring_1^'n \<Rightarrow> 'a^1"
- shows "linear f \<Longrightarrow> linear (\<lambda>x. dest_vec1(f x) *s v)"
- unfolding dest_vec1_def
- apply (rule linear_vmul_component)
- by auto
-
-lemma linear_from_scalars:
- assumes lf: "linear (f::'a::comm_ring_1 ^1 \<Rightarrow> 'a^'n)"
- shows "f = (\<lambda>x. dest_vec1 x *s column 1 (matrix f))"
- apply (rule ext)
- apply (subst matrix_works[OF lf, symmetric])
- apply (auto simp add: Cart_eq matrix_vector_mult_def dest_vec1_def column_def mult_commute UNIV_1)
- done
-
-lemma linear_to_scalars: assumes lf: "linear (f::'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a^1)"
- shows "f = (\<lambda>x. vec1(row 1 (matrix f) \<bullet> x))"
- apply (rule ext)
- apply (subst matrix_works[OF lf, symmetric])
- apply (simp add: Cart_eq matrix_vector_mult_def vec1_def row_def dot_def mult_commute forall_1)
- done
-
-lemma dest_vec1_eq_0: "dest_vec1 x = 0 \<longleftrightarrow> x = 0"
- by (simp add: dest_vec1_eq[symmetric])
-
-lemma setsum_scalars: assumes fS: "finite S"
- shows "setsum f S = vec1 (setsum (dest_vec1 o f) S)"
- unfolding vec1_setsum[OF fS] by simp
-
-lemma dest_vec1_wlog_le: "(\<And>(x::'a::linorder ^ 1) y. P x y \<longleftrightarrow> P y x) \<Longrightarrow> (\<And>x y. dest_vec1 x <= dest_vec1 y ==> P x y) \<Longrightarrow> P x y"
- apply (cases "dest_vec1 x \<le> dest_vec1 y")
- apply simp
- apply (subgoal_tac "dest_vec1 y \<le> dest_vec1 x")
- apply (auto)
- done
-
-text{* Pasting vectors. *}
-
-lemma linear_fstcart: "linear fstcart"
- by (auto simp add: linear_def Cart_eq)
-
-lemma linear_sndcart: "linear sndcart"
- by (auto simp add: linear_def Cart_eq)
-
-lemma fstcart_vec[simp]: "fstcart(vec x) = vec x"
- by (simp add: Cart_eq)
-
-lemma fstcart_add[simp]:"fstcart(x + y) = fstcart (x::'a::{plus,times}^('b + 'c)) + fstcart y"
- by (simp add: Cart_eq)
-
-lemma fstcart_cmul[simp]:"fstcart(c*s x) = c*s fstcart (x::'a::{plus,times}^('b + 'c))"
- by (simp add: Cart_eq)
-
-lemma fstcart_neg[simp]:"fstcart(- x) = - fstcart (x::'a::ring_1^('b + 'c))"
- by (simp add: Cart_eq)
-
-lemma fstcart_sub[simp]:"fstcart(x - y) = fstcart (x::'a::ring_1^('b + 'c)) - fstcart y"
- by (simp add: Cart_eq)
-
-lemma fstcart_setsum:
- fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
- assumes fS: "finite S"
- shows "fstcart (setsum f S) = setsum (\<lambda>i. fstcart (f i)) S"
- by (induct rule: finite_induct[OF fS], simp_all add: vec_0[symmetric] del: vec_0)
-
-lemma sndcart_vec[simp]: "sndcart(vec x) = vec x"
- by (simp add: Cart_eq)
-
-lemma sndcart_add[simp]:"sndcart(x + y) = sndcart (x::'a::{plus,times}^('b + 'c)) + sndcart y"
- by (simp add: Cart_eq)
-
-lemma sndcart_cmul[simp]:"sndcart(c*s x) = c*s sndcart (x::'a::{plus,times}^('b + 'c))"
- by (simp add: Cart_eq)
-
-lemma sndcart_neg[simp]:"sndcart(- x) = - sndcart (x::'a::ring_1^('b + 'c))"
- by (simp add: Cart_eq)
-
-lemma sndcart_sub[simp]:"sndcart(x - y) = sndcart (x::'a::ring_1^('b + 'c)) - sndcart y"
- by (simp add: Cart_eq)
-
-lemma sndcart_setsum:
- fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
- assumes fS: "finite S"
- shows "sndcart (setsum f S) = setsum (\<lambda>i. sndcart (f i)) S"
- by (induct rule: finite_induct[OF fS], simp_all add: vec_0[symmetric] del: vec_0)
-
-lemma pastecart_vec[simp]: "pastecart (vec x) (vec x) = vec x"
- by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
-
-lemma pastecart_add[simp]:"pastecart (x1::'a::{plus,times}^_) y1 + pastecart x2 y2 = pastecart (x1 + x2) (y1 + y2)"
- by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
-
-lemma pastecart_cmul[simp]: "pastecart (c *s (x1::'a::{plus,times}^_)) (c *s y1) = c *s pastecart x1 y1"
- by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
-
-lemma pastecart_neg[simp]: "pastecart (- (x::'a::ring_1^_)) (- y) = - pastecart x y"
- unfolding vector_sneg_minus1 pastecart_cmul ..
-
-lemma pastecart_sub: "pastecart (x1::'a::ring_1^_) y1 - pastecart x2 y2 = pastecart (x1 - x2) (y1 - y2)"
- by (simp add: diff_def pastecart_neg[symmetric] del: pastecart_neg)
-
-lemma pastecart_setsum:
- fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
- assumes fS: "finite S"
- shows "pastecart (setsum f S) (setsum g S) = setsum (\<lambda>i. pastecart (f i) (g i)) S"
- by (simp add: pastecart_eq fstcart_setsum[OF fS] sndcart_setsum[OF fS] fstcart_pastecart sndcart_pastecart)
-
-lemma setsum_Plus:
- "\<lbrakk>finite A; finite B\<rbrakk> \<Longrightarrow>
- (\<Sum>x\<in>A <+> B. g x) = (\<Sum>x\<in>A. g (Inl x)) + (\<Sum>x\<in>B. g (Inr x))"
- unfolding Plus_def
- by (subst setsum_Un_disjoint, auto simp add: setsum_reindex)
-
-lemma setsum_UNIV_sum:
- fixes g :: "'a::finite + 'b::finite \<Rightarrow> _"
- shows "(\<Sum>x\<in>UNIV. g x) = (\<Sum>x\<in>UNIV. g (Inl x)) + (\<Sum>x\<in>UNIV. g (Inr x))"
- apply (subst UNIV_Plus_UNIV [symmetric])
- apply (rule setsum_Plus [OF finite finite])
- done
-
-lemma norm_fstcart: "norm(fstcart x) <= norm (x::real ^('n::finite + 'm::finite))"
-proof-
- have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
- by (simp add: pastecart_fst_snd)
- have th1: "fstcart x \<bullet> fstcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
- then show ?thesis
- unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff id_def
- by (simp add: dot_def)
-qed
-
-lemma dist_fstcart: "dist(fstcart (x::real^_)) (fstcart y) <= dist x y"
- unfolding dist_norm by (metis fstcart_sub[symmetric] norm_fstcart)
-
-lemma norm_sndcart: "norm(sndcart x) <= norm (x::real ^('n::finite + 'm::finite))"
-proof-
- have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
- by (simp add: pastecart_fst_snd)
- have th1: "sndcart x \<bullet> sndcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
- then show ?thesis
- unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff id_def
- by (simp add: dot_def)
-qed
-
-lemma dist_sndcart: "dist(sndcart (x::real^_)) (sndcart y) <= dist x y"
- unfolding dist_norm by (metis sndcart_sub[symmetric] norm_sndcart)
-
-lemma dot_pastecart: "(pastecart (x1::'a::{times,comm_monoid_add}^'n::finite) (x2::'a::{times,comm_monoid_add}^'m::finite)) \<bullet> (pastecart y1 y2) = x1 \<bullet> y1 + x2 \<bullet> y2"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def)
-
-text {* TODO: move to NthRoot *}
-lemma sqrt_add_le_add_sqrt:
- assumes x: "0 \<le> x" and y: "0 \<le> y"
- shows "sqrt (x + y) \<le> sqrt x + sqrt y"
-apply (rule power2_le_imp_le)
-apply (simp add: real_sum_squared_expand add_nonneg_nonneg x y)
-apply (simp add: mult_nonneg_nonneg x y)
-apply (simp add: add_nonneg_nonneg x y)
-done
-
-lemma norm_pastecart: "norm (pastecart x y) <= norm x + norm y"
- unfolding norm_vector_def setL2_def setsum_UNIV_sum
- by (simp add: sqrt_add_le_add_sqrt setsum_nonneg)
-
-subsection {* A generic notion of "hull" (convex, affine, conic hull and closure). *}
-
-definition hull :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "hull" 75) where
- "S hull s = Inter {t. t \<in> S \<and> s \<subseteq> t}"
-
-lemma hull_same: "s \<in> S \<Longrightarrow> S hull s = s"
- unfolding hull_def by auto
-
-lemma hull_in: "(\<And>T. T \<subseteq> S ==> Inter T \<in> S) ==> (S hull s) \<in> S"
-unfolding hull_def subset_iff by auto
-
-lemma hull_eq: "(\<And>T. T \<subseteq> S ==> Inter T \<in> S) ==> (S hull s) = s \<longleftrightarrow> s \<in> S"
-using hull_same[of s S] hull_in[of S s] by metis
-
-
-lemma hull_hull: "S hull (S hull s) = S hull s"
- unfolding hull_def by blast
-
-lemma hull_subset: "s \<subseteq> (S hull s)"
- unfolding hull_def by blast
-
-lemma hull_mono: " s \<subseteq> t ==> (S hull s) \<subseteq> (S hull t)"
- unfolding hull_def by blast
-
-lemma hull_antimono: "S \<subseteq> T ==> (T hull s) \<subseteq> (S hull s)"
- unfolding hull_def by blast
-
-lemma hull_minimal: "s \<subseteq> t \<Longrightarrow> t \<in> S ==> (S hull s) \<subseteq> t"
- unfolding hull_def by blast
-
-lemma subset_hull: "t \<in> S ==> S hull s \<subseteq> t \<longleftrightarrow> s \<subseteq> t"
- unfolding hull_def by blast
-
-lemma hull_unique: "s \<subseteq> t \<Longrightarrow> t \<in> S \<Longrightarrow> (\<And>t'. s \<subseteq> t' \<Longrightarrow> t' \<in> S ==> t \<subseteq> t')
- ==> (S hull s = t)"
-unfolding hull_def by auto
-
-lemma hull_induct: "(\<And>x. x\<in> S \<Longrightarrow> P x) \<Longrightarrow> Q {x. P x} \<Longrightarrow> \<forall>x\<in> Q hull S. P x"
- using hull_minimal[of S "{x. P x}" Q]
- by (auto simp add: subset_eq Collect_def mem_def)
-
-lemma hull_inc: "x \<in> S \<Longrightarrow> x \<in> P hull S" by (metis hull_subset subset_eq)
-
-lemma hull_union_subset: "(S hull s) \<union> (S hull t) \<subseteq> (S hull (s \<union> t))"
-unfolding Un_subset_iff by (metis hull_mono Un_upper1 Un_upper2)
-
-lemma hull_union: assumes T: "\<And>T. T \<subseteq> S ==> Inter T \<in> S"
- shows "S hull (s \<union> t) = S hull (S hull s \<union> S hull t)"
-apply rule
-apply (rule hull_mono)
-unfolding Un_subset_iff
-apply (metis hull_subset Un_upper1 Un_upper2 subset_trans)
-apply (rule hull_minimal)
-apply (metis hull_union_subset)
-apply (metis hull_in T)
-done
-
-lemma hull_redundant_eq: "a \<in> (S hull s) \<longleftrightarrow> (S hull (insert a s) = S hull s)"
- unfolding hull_def by blast
-
-lemma hull_redundant: "a \<in> (S hull s) ==> (S hull (insert a s) = S hull s)"
-by (metis hull_redundant_eq)
-
-text{* Archimedian properties and useful consequences. *}
-
-lemma real_arch_simple: "\<exists>n. x <= real (n::nat)"
- using reals_Archimedean2[of x] apply auto by (rule_tac x="Suc n" in exI, auto)
-lemmas real_arch_lt = reals_Archimedean2
-
-lemmas real_arch = reals_Archimedean3
-
-lemma real_arch_inv: "0 < e \<longleftrightarrow> (\<exists>n::nat. n \<noteq> 0 \<and> 0 < inverse (real n) \<and> inverse (real n) < e)"
- using reals_Archimedean
- apply (auto simp add: field_simps inverse_positive_iff_positive)
- apply (subgoal_tac "inverse (real n) > 0")
- apply arith
- apply simp
- done
-
-lemma real_pow_lbound: "0 <= x ==> 1 + real n * x <= (1 + x) ^ n"
-proof(induct n)
- case 0 thus ?case by simp
-next
- case (Suc n)
- hence h: "1 + real n * x \<le> (1 + x) ^ n" by simp
- from h have p: "1 \<le> (1 + x) ^ n" using Suc.prems by simp
- from h have "1 + real n * x + x \<le> (1 + x) ^ n + x" by simp
- also have "\<dots> \<le> (1 + x) ^ Suc n" apply (subst diff_le_0_iff_le[symmetric])
- apply (simp add: ring_simps)
- using mult_left_mono[OF p Suc.prems] by simp
- finally show ?case by (simp add: real_of_nat_Suc ring_simps)
-qed
-
-lemma real_arch_pow: assumes x: "1 < (x::real)" shows "\<exists>n. y < x^n"
-proof-
- from x have x0: "x - 1 > 0" by arith
- from real_arch[OF x0, rule_format, of y]
- obtain n::nat where n:"y < real n * (x - 1)" by metis
- from x0 have x00: "x- 1 \<ge> 0" by arith
- from real_pow_lbound[OF x00, of n] n
- have "y < x^n" by auto
- then show ?thesis by metis
-qed
-
-lemma real_arch_pow2: "\<exists>n. (x::real) < 2^ n"
- using real_arch_pow[of 2 x] by simp
-
-lemma real_arch_pow_inv: assumes y: "(y::real) > 0" and x1: "x < 1"
- shows "\<exists>n. x^n < y"
-proof-
- {assume x0: "x > 0"
- from x0 x1 have ix: "1 < 1/x" by (simp add: field_simps)
- from real_arch_pow[OF ix, of "1/y"]
- obtain n where n: "1/y < (1/x)^n" by blast
- then
- have ?thesis using y x0 by (auto simp add: field_simps power_divide) }
- moreover
- {assume "\<not> x > 0" with y x1 have ?thesis apply auto by (rule exI[where x=1], auto)}
- ultimately show ?thesis by metis
-qed
-
-lemma forall_pos_mono: "(\<And>d e::real. d < e \<Longrightarrow> P d ==> P e) \<Longrightarrow> (\<And>n::nat. n \<noteq> 0 ==> P(inverse(real n))) \<Longrightarrow> (\<And>e. 0 < e ==> P e)"
- by (metis real_arch_inv)
-
-lemma forall_pos_mono_1: "(\<And>d e::real. d < e \<Longrightarrow> P d ==> P e) \<Longrightarrow> (\<And>n. P(inverse(real (Suc n)))) ==> 0 < e ==> P e"
- apply (rule forall_pos_mono)
- apply auto
- apply (atomize)
- apply (erule_tac x="n - 1" in allE)
- apply auto
- done
-
-lemma real_archimedian_rdiv_eq_0: assumes x0: "x \<ge> 0" and c: "c \<ge> 0" and xc: "\<forall>(m::nat)>0. real m * x \<le> c"
- shows "x = 0"
-proof-
- {assume "x \<noteq> 0" with x0 have xp: "x > 0" by arith
- from real_arch[OF xp, rule_format, of c] obtain n::nat where n: "c < real n * x" by blast
- with xc[rule_format, of n] have "n = 0" by arith
- with n c have False by simp}
- then show ?thesis by blast
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Geometric progression. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma sum_gp_basic: "((1::'a::{field}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
- (is "?lhs = ?rhs")
-proof-
- {assume x1: "x = 1" hence ?thesis by simp}
- moreover
- {assume x1: "x\<noteq>1"
- hence x1': "x - 1 \<noteq> 0" "1 - x \<noteq> 0" "x - 1 = - (1 - x)" "- (1 - x) \<noteq> 0" by auto
- from geometric_sum[OF x1, of "Suc n", unfolded x1']
- have "(- (1 - x)) * setsum (\<lambda>i. x^i) {0 .. n} = - (1 - x^(Suc n))"
- unfolding atLeastLessThanSuc_atLeastAtMost
- using x1' apply (auto simp only: field_simps)
- apply (simp add: ring_simps)
- done
- then have ?thesis by (simp add: ring_simps) }
- ultimately show ?thesis by metis
-qed
-
-lemma sum_gp_multiplied: assumes mn: "m <= n"
- shows "((1::'a::{field}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
- (is "?lhs = ?rhs")
-proof-
- let ?S = "{0..(n - m)}"
- from mn have mn': "n - m \<ge> 0" by arith
- let ?f = "op + m"
- have i: "inj_on ?f ?S" unfolding inj_on_def by auto
- have f: "?f ` ?S = {m..n}"
- using mn apply (auto simp add: image_iff Bex_def) by arith
- have th: "op ^ x o op + m = (\<lambda>i. x^m * x^i)"
- by (rule ext, simp add: power_add power_mult)
- from setsum_reindex[OF i, of "op ^ x", unfolded f th setsum_right_distrib[symmetric]]
- have "?lhs = x^m * ((1 - x) * setsum (op ^ x) {0..n - m})" by simp
- then show ?thesis unfolding sum_gp_basic using mn
- by (simp add: ring_simps power_add[symmetric])
-qed
-
-lemma sum_gp: "setsum (op ^ (x::'a::{field})) {m .. n} =
- (if n < m then 0 else if x = 1 then of_nat ((n + 1) - m)
- else (x^ m - x^ (Suc n)) / (1 - x))"
-proof-
- {assume nm: "n < m" hence ?thesis by simp}
- moreover
- {assume "\<not> n < m" hence nm: "m \<le> n" by arith
- {assume x: "x = 1" hence ?thesis by simp}
- moreover
- {assume x: "x \<noteq> 1" hence nz: "1 - x \<noteq> 0" by simp
- from sum_gp_multiplied[OF nm, of x] nz have ?thesis by (simp add: field_simps)}
- ultimately have ?thesis by metis
- }
- ultimately show ?thesis by metis
-qed
-
-lemma sum_gp_offset: "setsum (op ^ (x::'a::{field})) {m .. m+n} =
- (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
- unfolding sum_gp[of x m "m + n"] power_Suc
- by (simp add: ring_simps power_add)
-
-
-subsection{* A bit of linear algebra. *}
-
-definition "subspace S \<longleftrightarrow> 0 \<in> S \<and> (\<forall>x\<in> S. \<forall>y \<in>S. x + y \<in> S) \<and> (\<forall>c. \<forall>x \<in>S. c *s x \<in>S )"
-definition "span S = (subspace hull S)"
-definition "dependent S \<longleftrightarrow> (\<exists>a \<in> S. a \<in> span(S - {a}))"
-abbreviation "independent s == ~(dependent s)"
-
-(* Closure properties of subspaces. *)
-
-lemma subspace_UNIV[simp]: "subspace(UNIV)" by (simp add: subspace_def)
-
-lemma subspace_0: "subspace S ==> 0 \<in> S" by (metis subspace_def)
-
-lemma subspace_add: "subspace S \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S ==> x + y \<in> S"
- by (metis subspace_def)
-
-lemma subspace_mul: "subspace S \<Longrightarrow> x \<in> S \<Longrightarrow> c *s x \<in> S"
- by (metis subspace_def)
-
-lemma subspace_neg: "subspace S \<Longrightarrow> (x::'a::ring_1^'n) \<in> S \<Longrightarrow> - x \<in> S"
- by (metis vector_sneg_minus1 subspace_mul)
-
-lemma subspace_sub: "subspace S \<Longrightarrow> (x::'a::ring_1^'n) \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x - y \<in> S"
- by (metis diff_def subspace_add subspace_neg)
-
-lemma subspace_setsum:
- assumes sA: "subspace A" and fB: "finite B"
- and f: "\<forall>x\<in> B. f x \<in> A"
- shows "setsum f B \<in> A"
- using fB f sA
- apply(induct rule: finite_induct[OF fB])
- by (simp add: subspace_def sA, auto simp add: sA subspace_add)
-
-lemma subspace_linear_image:
- assumes lf: "linear (f::'a::semiring_1^'n \<Rightarrow> _)" and sS: "subspace S"
- shows "subspace(f ` S)"
- using lf sS linear_0[OF lf]
- unfolding linear_def subspace_def
- apply (auto simp add: image_iff)
- apply (rule_tac x="x + y" in bexI, auto)
- apply (rule_tac x="c*s x" in bexI, auto)
- done
-
-lemma subspace_linear_preimage: "linear (f::'a::semiring_1^'n \<Rightarrow> _) ==> subspace S ==> subspace {x. f x \<in> S}"
- by (auto simp add: subspace_def linear_def linear_0[of f])
-
-lemma subspace_trivial: "subspace {0::'a::semiring_1 ^_}"
- by (simp add: subspace_def)
-
-lemma subspace_inter: "subspace A \<Longrightarrow> subspace B ==> subspace (A \<inter> B)"
- by (simp add: subspace_def)
-
-
-lemma span_mono: "A \<subseteq> B ==> span A \<subseteq> span B"
- by (metis span_def hull_mono)
-
-lemma subspace_span: "subspace(span S)"
- unfolding span_def
- apply (rule hull_in[unfolded mem_def])
- apply (simp only: subspace_def Inter_iff Int_iff subset_eq)
- apply auto
- apply (erule_tac x="X" in ballE)
- apply (simp add: mem_def)
- apply blast
- apply (erule_tac x="X" in ballE)
- apply (erule_tac x="X" in ballE)
- apply (erule_tac x="X" in ballE)
- apply (clarsimp simp add: mem_def)
- apply simp
- apply simp
- apply simp
- apply (erule_tac x="X" in ballE)
- apply (erule_tac x="X" in ballE)
- apply (simp add: mem_def)
- apply simp
- apply simp
- done
-
-lemma span_clauses:
- "a \<in> S ==> a \<in> span S"
- "0 \<in> span S"
- "x\<in> span S \<Longrightarrow> y \<in> span S ==> x + y \<in> span S"
- "x \<in> span S \<Longrightarrow> c *s x \<in> span S"
- by (metis span_def hull_subset subset_eq subspace_span subspace_def)+
-
-lemma span_induct: assumes SP: "\<And>x. x \<in> S ==> P x"
- and P: "subspace P" and x: "x \<in> span S" shows "P x"
-proof-
- from SP have SP': "S \<subseteq> P" by (simp add: mem_def subset_eq)
- from P have P': "P \<in> subspace" by (simp add: mem_def)
- from x hull_minimal[OF SP' P', unfolded span_def[symmetric]]
- show "P x" by (metis mem_def subset_eq)
-qed
-
-lemma span_empty: "span {} = {(0::'a::semiring_0 ^ 'n)}"
- apply (simp add: span_def)
- apply (rule hull_unique)
- apply (auto simp add: mem_def subspace_def)
- unfolding mem_def[of "0::'a^'n", symmetric]
- apply simp
- done
-
-lemma independent_empty: "independent {}"
- by (simp add: dependent_def)
-
-lemma independent_mono: "independent A \<Longrightarrow> B \<subseteq> A ==> independent B"
- apply (clarsimp simp add: dependent_def span_mono)
- apply (subgoal_tac "span (B - {a}) \<le> span (A - {a})")
- apply force
- apply (rule span_mono)
- apply auto
- done
-
-lemma span_subspace: "A \<subseteq> B \<Longrightarrow> B \<le> span A \<Longrightarrow> subspace B \<Longrightarrow> span A = B"
- by (metis order_antisym span_def hull_minimal mem_def)
-
-lemma span_induct': assumes SP: "\<forall>x \<in> S. P x"
- and P: "subspace P" shows "\<forall>x \<in> span S. P x"
- using span_induct SP P by blast
-
-inductive span_induct_alt_help for S:: "'a::semiring_1^'n \<Rightarrow> bool"
- where
- span_induct_alt_help_0: "span_induct_alt_help S 0"
- | span_induct_alt_help_S: "x \<in> S \<Longrightarrow> span_induct_alt_help S z \<Longrightarrow> span_induct_alt_help S (c *s x + z)"
-
-lemma span_induct_alt':
- assumes h0: "h (0::'a::semiring_1^'n)" and hS: "\<And>c x y. x \<in> S \<Longrightarrow> h y \<Longrightarrow> h (c*s x + y)" shows "\<forall>x \<in> span S. h x"
-proof-
- {fix x:: "'a^'n" assume x: "span_induct_alt_help S x"
- have "h x"
- apply (rule span_induct_alt_help.induct[OF x])
- apply (rule h0)
- apply (rule hS, assumption, assumption)
- done}
- note th0 = this
- {fix x assume x: "x \<in> span S"
-
- have "span_induct_alt_help S x"
- proof(rule span_induct[where x=x and S=S])
- show "x \<in> span S" using x .
- next
- fix x assume xS : "x \<in> S"
- from span_induct_alt_help_S[OF xS span_induct_alt_help_0, of 1]
- show "span_induct_alt_help S x" by simp
- next
- have "span_induct_alt_help S 0" by (rule span_induct_alt_help_0)
- moreover
- {fix x y assume h: "span_induct_alt_help S x" "span_induct_alt_help S y"
- from h
- have "span_induct_alt_help S (x + y)"
- apply (induct rule: span_induct_alt_help.induct)
- apply simp
- unfolding add_assoc
- apply (rule span_induct_alt_help_S)
- apply assumption
- apply simp
- done}
- moreover
- {fix c x assume xt: "span_induct_alt_help S x"
- then have "span_induct_alt_help S (c*s x)"
- apply (induct rule: span_induct_alt_help.induct)
- apply (simp add: span_induct_alt_help_0)
- apply (simp add: vector_smult_assoc vector_add_ldistrib)
- apply (rule span_induct_alt_help_S)
- apply assumption
- apply simp
- done
- }
- ultimately show "subspace (span_induct_alt_help S)"
- unfolding subspace_def mem_def Ball_def by blast
- qed}
- with th0 show ?thesis by blast
-qed
-
-lemma span_induct_alt:
- assumes h0: "h (0::'a::semiring_1^'n)" and hS: "\<And>c x y. x \<in> S \<Longrightarrow> h y \<Longrightarrow> h (c*s x + y)" and x: "x \<in> span S"
- shows "h x"
-using span_induct_alt'[of h S] h0 hS x by blast
-
-(* Individual closure properties. *)
-
-lemma span_superset: "x \<in> S ==> x \<in> span S" by (metis span_clauses)
-
-lemma span_0: "0 \<in> span S" by (metis subspace_span subspace_0)
-
-lemma span_add: "x \<in> span S \<Longrightarrow> y \<in> span S ==> x + y \<in> span S"
- by (metis subspace_add subspace_span)
-
-lemma span_mul: "x \<in> span S ==> (c *s x) \<in> span S"
- by (metis subspace_span subspace_mul)
-
-lemma span_neg: "x \<in> span S ==> - (x::'a::ring_1^'n) \<in> span S"
- by (metis subspace_neg subspace_span)
-
-lemma span_sub: "(x::'a::ring_1^'n) \<in> span S \<Longrightarrow> y \<in> span S ==> x - y \<in> span S"
- by (metis subspace_span subspace_sub)
-
-lemma span_setsum: "finite A \<Longrightarrow> \<forall>x \<in> A. f x \<in> span S ==> setsum f A \<in> span S"
- apply (rule subspace_setsum)
- by (metis subspace_span subspace_setsum)+
-
-lemma span_add_eq: "(x::'a::ring_1^'n) \<in> span S \<Longrightarrow> x + y \<in> span S \<longleftrightarrow> y \<in> span S"
- apply (auto simp only: span_add span_sub)
- apply (subgoal_tac "(x + y) - x \<in> span S", simp)
- by (simp only: span_add span_sub)
-
-(* Mapping under linear image. *)
-
-lemma span_linear_image: assumes lf: "linear (f::'a::semiring_1 ^ 'n => _)"
- shows "span (f ` S) = f ` (span S)"
-proof-
- {fix x
- assume x: "x \<in> span (f ` S)"
- have "x \<in> f ` span S"
- apply (rule span_induct[where x=x and S = "f ` S"])
- apply (clarsimp simp add: image_iff)
- apply (frule span_superset)
- apply blast
- apply (simp only: mem_def)
- apply (rule subspace_linear_image[OF lf])
- apply (rule subspace_span)
- apply (rule x)
- done}
- moreover
- {fix x assume x: "x \<in> span S"
- have th0:"(\<lambda>a. f a \<in> span (f ` S)) = {x. f x \<in> span (f ` S)}" apply (rule set_ext)
- unfolding mem_def Collect_def ..
- have "f x \<in> span (f ` S)"
- apply (rule span_induct[where S=S])
- apply (rule span_superset)
- apply simp
- apply (subst th0)
- apply (rule subspace_linear_preimage[OF lf subspace_span, of "f ` S"])
- apply (rule x)
- done}
- ultimately show ?thesis by blast
-qed
-
-(* The key breakdown property. *)
-
-lemma span_breakdown:
- assumes bS: "(b::'a::ring_1 ^ 'n) \<in> S" and aS: "a \<in> span S"
- shows "\<exists>k. a - k*s b \<in> span (S - {b})" (is "?P a")
-proof-
- {fix x assume xS: "x \<in> S"
- {assume ab: "x = b"
- then have "?P x"
- apply simp
- apply (rule exI[where x="1"], simp)
- by (rule span_0)}
- moreover
- {assume ab: "x \<noteq> b"
- then have "?P x" using xS
- apply -
- apply (rule exI[where x=0])
- apply (rule span_superset)
- by simp}
- ultimately have "?P x" by blast}
- moreover have "subspace ?P"
- unfolding subspace_def
- apply auto
- apply (simp add: mem_def)
- apply (rule exI[where x=0])
- using span_0[of "S - {b}"]
- apply (simp add: mem_def)
- apply (clarsimp simp add: mem_def)
- apply (rule_tac x="k + ka" in exI)
- apply (subgoal_tac "x + y - (k + ka) *s b = (x - k*s b) + (y - ka *s b)")
- apply (simp only: )
- apply (rule span_add[unfolded mem_def])
- apply assumption+
- apply (vector ring_simps)
- apply (clarsimp simp add: mem_def)
- apply (rule_tac x= "c*k" in exI)
- apply (subgoal_tac "c *s x - (c * k) *s b = c*s (x - k*s b)")
- apply (simp only: )
- apply (rule span_mul[unfolded mem_def])
- apply assumption
- by (vector ring_simps)
- ultimately show "?P a" using aS span_induct[where S=S and P= "?P"] by metis
-qed
-
-lemma span_breakdown_eq:
- "(x::'a::ring_1^'n) \<in> span (insert a S) \<longleftrightarrow> (\<exists>k. (x - k *s a) \<in> span S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume x: "x \<in> span (insert a S)"
- from x span_breakdown[of "a" "insert a S" "x"]
- have ?rhs apply clarsimp
- apply (rule_tac x= "k" in exI)
- apply (rule set_rev_mp[of _ "span (S - {a})" _])
- apply assumption
- apply (rule span_mono)
- apply blast
- done}
- moreover
- { fix k assume k: "x - k *s a \<in> span S"
- have eq: "x = (x - k *s a) + k *s a" by vector
- have "(x - k *s a) + k *s a \<in> span (insert a S)"
- apply (rule span_add)
- apply (rule set_rev_mp[of _ "span S" _])
- apply (rule k)
- apply (rule span_mono)
- apply blast
- apply (rule span_mul)
- apply (rule span_superset)
- apply blast
- done
- then have ?lhs using eq by metis}
- ultimately show ?thesis by blast
-qed
-
-(* Hence some "reversal" results.*)
-
-lemma in_span_insert:
- assumes a: "(a::'a::field^'n) \<in> span (insert b S)" and na: "a \<notin> span S"
- shows "b \<in> span (insert a S)"
-proof-
- from span_breakdown[of b "insert b S" a, OF insertI1 a]
- obtain k where k: "a - k*s b \<in> span (S - {b})" by auto
- {assume k0: "k = 0"
- with k have "a \<in> span S"
- apply (simp)
- apply (rule set_rev_mp)
- apply assumption
- apply (rule span_mono)
- apply blast
- done
- with na have ?thesis by blast}
- moreover
- {assume k0: "k \<noteq> 0"
- have eq: "b = (1/k) *s a - ((1/k) *s a - b)" by vector
- from k0 have eq': "(1/k) *s (a - k*s b) = (1/k) *s a - b"
- by (vector field_simps)
- from k have "(1/k) *s (a - k*s b) \<in> span (S - {b})"
- by (rule span_mul)
- hence th: "(1/k) *s a - b \<in> span (S - {b})"
- unfolding eq' .
-
- from k
- have ?thesis
- apply (subst eq)
- apply (rule span_sub)
- apply (rule span_mul)
- apply (rule span_superset)
- apply blast
- apply (rule set_rev_mp)
- apply (rule th)
- apply (rule span_mono)
- using na by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma in_span_delete:
- assumes a: "(a::'a::field^'n) \<in> span S"
- and na: "a \<notin> span (S-{b})"
- shows "b \<in> span (insert a (S - {b}))"
- apply (rule in_span_insert)
- apply (rule set_rev_mp)
- apply (rule a)
- apply (rule span_mono)
- apply blast
- apply (rule na)
- done
-
-(* Transitivity property. *)
-
-lemma span_trans:
- assumes x: "(x::'a::ring_1^'n) \<in> span S" and y: "y \<in> span (insert x S)"
- shows "y \<in> span S"
-proof-
- from span_breakdown[of x "insert x S" y, OF insertI1 y]
- obtain k where k: "y -k*s x \<in> span (S - {x})" by auto
- have eq: "y = (y - k *s x) + k *s x" by vector
- show ?thesis
- apply (subst eq)
- apply (rule span_add)
- apply (rule set_rev_mp)
- apply (rule k)
- apply (rule span_mono)
- apply blast
- apply (rule span_mul)
- by (rule x)
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* An explicit expansion is sometimes needed. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma span_explicit:
- "span P = {y::'a::semiring_1^'n. \<exists>S u. finite S \<and> S \<subseteq> P \<and> setsum (\<lambda>v. u v *s v) S = y}"
- (is "_ = ?E" is "_ = {y. ?h y}" is "_ = {y. \<exists>S u. ?Q S u y}")
-proof-
- {fix x assume x: "x \<in> ?E"
- then obtain S u where fS: "finite S" and SP: "S\<subseteq>P" and u: "setsum (\<lambda>v. u v *s v) S = x"
- by blast
- have "x \<in> span P"
- unfolding u[symmetric]
- apply (rule span_setsum[OF fS])
- using span_mono[OF SP]
- by (auto intro: span_superset span_mul)}
- moreover
- have "\<forall>x \<in> span P. x \<in> ?E"
- unfolding mem_def Collect_def
- proof(rule span_induct_alt')
- show "?h 0"
- apply (rule exI[where x="{}"]) by simp
- next
- fix c x y
- assume x: "x \<in> P" and hy: "?h y"
- from hy obtain S u where fS: "finite S" and SP: "S\<subseteq>P"
- and u: "setsum (\<lambda>v. u v *s v) S = y" by blast
- let ?S = "insert x S"
- let ?u = "\<lambda>y. if y = x then (if x \<in> S then u y + c else c)
- else u y"
- from fS SP x have th0: "finite (insert x S)" "insert x S \<subseteq> P" by blast+
- {assume xS: "x \<in> S"
- have S1: "S = (S - {x}) \<union> {x}"
- and Sss:"finite (S - {x})" "finite {x}" "(S -{x}) \<inter> {x} = {}" using xS fS by auto
- have "setsum (\<lambda>v. ?u v *s v) ?S =(\<Sum>v\<in>S - {x}. u v *s v) + (u x + c) *s x"
- using xS
- by (simp add: setsum_Un_disjoint[OF Sss, unfolded S1[symmetric]]
- setsum_clauses(2)[OF fS] cong del: if_weak_cong)
- also have "\<dots> = (\<Sum>v\<in>S. u v *s v) + c *s x"
- apply (simp add: setsum_Un_disjoint[OF Sss, unfolded S1[symmetric]])
- by (vector ring_simps)
- also have "\<dots> = c*s x + y"
- by (simp add: add_commute u)
- finally have "setsum (\<lambda>v. ?u v *s v) ?S = c*s x + y" .
- then have "?Q ?S ?u (c*s x + y)" using th0 by blast}
- moreover
- {assume xS: "x \<notin> S"
- have th00: "(\<Sum>v\<in>S. (if v = x then c else u v) *s v) = y"
- unfolding u[symmetric]
- apply (rule setsum_cong2)
- using xS by auto
- have "?Q ?S ?u (c*s x + y)" using fS xS th0
- by (simp add: th00 setsum_clauses add_commute cong del: if_weak_cong)}
- ultimately have "?Q ?S ?u (c*s x + y)"
- by (cases "x \<in> S", simp, simp)
- then show "?h (c*s x + y)"
- apply -
- apply (rule exI[where x="?S"])
- apply (rule exI[where x="?u"]) by metis
- qed
- ultimately show ?thesis by blast
-qed
-
-lemma dependent_explicit:
- "dependent P \<longleftrightarrow> (\<exists>S u. finite S \<and> S \<subseteq> P \<and> (\<exists>(v::'a::{idom,field}^'n) \<in>S. u v \<noteq> 0 \<and> setsum (\<lambda>v. u v *s v) S = 0))" (is "?lhs = ?rhs")
-proof-
- {assume dP: "dependent P"
- then obtain a S u where aP: "a \<in> P" and fS: "finite S"
- and SP: "S \<subseteq> P - {a}" and ua: "setsum (\<lambda>v. u v *s v) S = a"
- unfolding dependent_def span_explicit by blast
- let ?S = "insert a S"
- let ?u = "\<lambda>y. if y = a then - 1 else u y"
- let ?v = a
- from aP SP have aS: "a \<notin> S" by blast
- from fS SP aP have th0: "finite ?S" "?S \<subseteq> P" "?v \<in> ?S" "?u ?v \<noteq> 0" by auto
- have s0: "setsum (\<lambda>v. ?u v *s v) ?S = 0"
- using fS aS
- apply (simp add: vector_smult_lneg vector_smult_lid setsum_clauses ring_simps )
- apply (subst (2) ua[symmetric])
- apply (rule setsum_cong2)
- by auto
- with th0 have ?rhs
- apply -
- apply (rule exI[where x= "?S"])
- apply (rule exI[where x= "?u"])
- by clarsimp}
- moreover
- {fix S u v assume fS: "finite S"
- and SP: "S \<subseteq> P" and vS: "v \<in> S" and uv: "u v \<noteq> 0"
- and u: "setsum (\<lambda>v. u v *s v) S = 0"
- let ?a = v
- let ?S = "S - {v}"
- let ?u = "\<lambda>i. (- u i) / u v"
- have th0: "?a \<in> P" "finite ?S" "?S \<subseteq> P" using fS SP vS by auto
- have "setsum (\<lambda>v. ?u v *s v) ?S = setsum (\<lambda>v. (- (inverse (u ?a))) *s (u v *s v)) S - ?u v *s v"
- using fS vS uv
- by (simp add: setsum_diff1 vector_smult_lneg divide_inverse
- vector_smult_assoc field_simps)
- also have "\<dots> = ?a"
- unfolding setsum_cmul u
- using uv by (simp add: vector_smult_lneg)
- finally have "setsum (\<lambda>v. ?u v *s v) ?S = ?a" .
- with th0 have ?lhs
- unfolding dependent_def span_explicit
- apply -
- apply (rule bexI[where x= "?a"])
- apply simp_all
- apply (rule exI[where x= "?S"])
- by auto}
- ultimately show ?thesis by blast
-qed
-
-
-lemma span_finite:
- assumes fS: "finite S"
- shows "span S = {(y::'a::semiring_1^'n). \<exists>u. setsum (\<lambda>v. u v *s v) S = y}"
- (is "_ = ?rhs")
-proof-
- {fix y assume y: "y \<in> span S"
- from y obtain S' u where fS': "finite S'" and SS': "S' \<subseteq> S" and
- u: "setsum (\<lambda>v. u v *s v) S' = y" unfolding span_explicit by blast
- let ?u = "\<lambda>x. if x \<in> S' then u x else 0"
- from setsum_restrict_set[OF fS, of "\<lambda>v. u v *s v" S', symmetric] SS'
- have "setsum (\<lambda>v. ?u v *s v) S = setsum (\<lambda>v. u v *s v) S'"
- unfolding cond_value_iff cond_application_beta
- by (simp add: cond_value_iff inf_absorb2 cong del: if_weak_cong)
- hence "setsum (\<lambda>v. ?u v *s v) S = y" by (metis u)
- hence "y \<in> ?rhs" by auto}
- moreover
- {fix y u assume u: "setsum (\<lambda>v. u v *s v) S = y"
- then have "y \<in> span S" using fS unfolding span_explicit by auto}
- ultimately show ?thesis by blast
-qed
-
-
-(* Standard bases are a spanning set, and obviously finite. *)
-
-lemma span_stdbasis:"span {basis i :: 'a::ring_1^'n::finite | i. i \<in> (UNIV :: 'n set)} = UNIV"
-apply (rule set_ext)
-apply auto
-apply (subst basis_expansion[symmetric])
-apply (rule span_setsum)
-apply simp
-apply auto
-apply (rule span_mul)
-apply (rule span_superset)
-apply (auto simp add: Collect_def mem_def)
-done
-
-lemma has_size_stdbasis: "{basis i ::real ^'n::finite | i. i \<in> (UNIV :: 'n set)} hassize CARD('n)" (is "?S hassize ?n")
-proof-
- have eq: "?S = basis ` UNIV" by blast
- show ?thesis unfolding eq
- apply (rule hassize_image_inj[OF basis_inj])
- by (simp add: hassize_def)
-qed
-
-lemma finite_stdbasis: "finite {basis i ::real^'n::finite |i. i\<in> (UNIV:: 'n set)}"
- using has_size_stdbasis[unfolded hassize_def]
- ..
-
-lemma card_stdbasis: "card {basis i ::real^'n::finite |i. i\<in> (UNIV :: 'n set)} = CARD('n)"
- using has_size_stdbasis[unfolded hassize_def]
- ..
-
-lemma independent_stdbasis_lemma:
- assumes x: "(x::'a::semiring_1 ^ 'n) \<in> span (basis ` S)"
- and iS: "i \<notin> S"
- shows "(x$i) = 0"
-proof-
- let ?U = "UNIV :: 'n set"
- let ?B = "basis ` S"
- let ?P = "\<lambda>(x::'a^'n). \<forall>i\<in> ?U. i \<notin> S \<longrightarrow> x$i =0"
- {fix x::"'a^'n" assume xS: "x\<in> ?B"
- from xS have "?P x" by auto}
- moreover
- have "subspace ?P"
- by (auto simp add: subspace_def Collect_def mem_def)
- ultimately show ?thesis
- using x span_induct[of ?B ?P x] iS by blast
-qed
-
-lemma independent_stdbasis: "independent {basis i ::real^'n::finite |i. i\<in> (UNIV :: 'n set)}"
-proof-
- let ?I = "UNIV :: 'n set"
- let ?b = "basis :: _ \<Rightarrow> real ^'n"
- let ?B = "?b ` ?I"
- have eq: "{?b i|i. i \<in> ?I} = ?B"
- by auto
- {assume d: "dependent ?B"
- then obtain k where k: "k \<in> ?I" "?b k \<in> span (?B - {?b k})"
- unfolding dependent_def by auto
- have eq1: "?B - {?b k} = ?B - ?b ` {k}" by simp
- have eq2: "?B - {?b k} = ?b ` (?I - {k})"
- unfolding eq1
- apply (rule inj_on_image_set_diff[symmetric])
- apply (rule basis_inj) using k(1) by auto
- from k(2) have th0: "?b k \<in> span (?b ` (?I - {k}))" unfolding eq2 .
- from independent_stdbasis_lemma[OF th0, of k, simplified]
- have False by simp}
- then show ?thesis unfolding eq dependent_def ..
-qed
-
-(* This is useful for building a basis step-by-step. *)
-
-lemma independent_insert:
- "independent(insert (a::'a::field ^'n) S) \<longleftrightarrow>
- (if a \<in> S then independent S
- else independent S \<and> a \<notin> span S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume aS: "a \<in> S"
- hence ?thesis using insert_absorb[OF aS] by simp}
- moreover
- {assume aS: "a \<notin> S"
- {assume i: ?lhs
- then have ?rhs using aS
- apply simp
- apply (rule conjI)
- apply (rule independent_mono)
- apply assumption
- apply blast
- by (simp add: dependent_def)}
- moreover
- {assume i: ?rhs
- have ?lhs using i aS
- apply simp
- apply (auto simp add: dependent_def)
- apply (case_tac "aa = a", auto)
- apply (subgoal_tac "insert a S - {aa} = insert a (S - {aa})")
- apply simp
- apply (subgoal_tac "a \<in> span (insert aa (S - {aa}))")
- apply (subgoal_tac "insert aa (S - {aa}) = S")
- apply simp
- apply blast
- apply (rule in_span_insert)
- apply assumption
- apply blast
- apply blast
- done}
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-(* The degenerate case of the Exchange Lemma. *)
-
-lemma mem_delete: "x \<in> (A - {a}) \<longleftrightarrow> x \<noteq> a \<and> x \<in> A"
- by blast
-
-lemma span_span: "span (span A) = span A"
- unfolding span_def hull_hull ..
-
-lemma span_inc: "S \<subseteq> span S"
- by (metis subset_eq span_superset)
-
-lemma spanning_subset_independent:
- assumes BA: "B \<subseteq> A" and iA: "independent (A::('a::field ^'n) set)"
- and AsB: "A \<subseteq> span B"
- shows "A = B"
-proof
- from BA show "B \<subseteq> A" .
-next
- from span_mono[OF BA] span_mono[OF AsB]
- have sAB: "span A = span B" unfolding span_span by blast
-
- {fix x assume x: "x \<in> A"
- from iA have th0: "x \<notin> span (A - {x})"
- unfolding dependent_def using x by blast
- from x have xsA: "x \<in> span A" by (blast intro: span_superset)
- have "A - {x} \<subseteq> A" by blast
- hence th1:"span (A - {x}) \<subseteq> span A" by (metis span_mono)
- {assume xB: "x \<notin> B"
- from xB BA have "B \<subseteq> A -{x}" by blast
- hence "span B \<subseteq> span (A - {x})" by (metis span_mono)
- with th1 th0 sAB have "x \<notin> span A" by blast
- with x have False by (metis span_superset)}
- then have "x \<in> B" by blast}
- then show "A \<subseteq> B" by blast
-qed
-
-(* The general case of the Exchange Lemma, the key to what follows. *)
-
-lemma exchange_lemma:
- assumes f:"finite (t:: ('a::field^'n) set)" and i: "independent s"
- and sp:"s \<subseteq> span t"
- shows "\<exists>t'. (t' hassize card t) \<and> s \<subseteq> t' \<and> t' \<subseteq> s \<union> t \<and> s \<subseteq> span t'"
-using f i sp
-proof(induct c\<equiv>"card(t - s)" arbitrary: s t rule: nat_less_induct)
- fix n:: nat and s t :: "('a ^'n) set"
- assume H: " \<forall>m<n. \<forall>(x:: ('a ^'n) set) xa.
- finite xa \<longrightarrow>
- independent x \<longrightarrow>
- x \<subseteq> span xa \<longrightarrow>
- m = card (xa - x) \<longrightarrow>
- (\<exists>t'. (t' hassize card xa) \<and>
- x \<subseteq> t' \<and> t' \<subseteq> x \<union> xa \<and> x \<subseteq> span t')"
- and ft: "finite t" and s: "independent s" and sp: "s \<subseteq> span t"
- and n: "n = card (t - s)"
- let ?P = "\<lambda>t'. (t' hassize card t) \<and> s \<subseteq> t' \<and> t' \<subseteq> s \<union> t \<and> s \<subseteq> span t'"
- let ?ths = "\<exists>t'. ?P t'"
- {assume st: "s \<subseteq> t"
- from st ft span_mono[OF st] have ?ths apply - apply (rule exI[where x=t])
- by (auto simp add: hassize_def intro: span_superset)}
- moreover
- {assume st: "t \<subseteq> s"
-
- from spanning_subset_independent[OF st s sp]
- st ft span_mono[OF st] have ?ths apply - apply (rule exI[where x=t])
- by (auto simp add: hassize_def intro: span_superset)}
- moreover
- {assume st: "\<not> s \<subseteq> t" "\<not> t \<subseteq> s"
- from st(2) obtain b where b: "b \<in> t" "b \<notin> s" by blast
- from b have "t - {b} - s \<subset> t - s" by blast
- then have cardlt: "card (t - {b} - s) < n" using n ft
- by (auto intro: psubset_card_mono)
- from b ft have ct0: "card t \<noteq> 0" by auto
- {assume stb: "s \<subseteq> span(t -{b})"
- from ft have ftb: "finite (t -{b})" by auto
- from H[rule_format, OF cardlt ftb s stb]
- obtain u where u: "u hassize card (t-{b})" "s \<subseteq> u" "u \<subseteq> s \<union> (t - {b})" "s \<subseteq> span u" by blast
- let ?w = "insert b u"
- have th0: "s \<subseteq> insert b u" using u by blast
- from u(3) b have "u \<subseteq> s \<union> t" by blast
- then have th1: "insert b u \<subseteq> s \<union> t" using u b by blast
- have bu: "b \<notin> u" using b u by blast
- from u(1) have fu: "finite u" by (simp add: hassize_def)
- from u(1) ft b have "u hassize (card t - 1)" by auto
- then
- have th2: "insert b u hassize card t"
- using card_insert_disjoint[OF fu bu] ct0 by (auto simp add: hassize_def)
- from u(4) have "s \<subseteq> span u" .
- also have "\<dots> \<subseteq> span (insert b u)" apply (rule span_mono) by blast
- finally have th3: "s \<subseteq> span (insert b u)" . from th0 th1 th2 th3 have th: "?P ?w" by blast
- from th have ?ths by blast}
- moreover
- {assume stb: "\<not> s \<subseteq> span(t -{b})"
- from stb obtain a where a: "a \<in> s" "a \<notin> span (t - {b})" by blast
- have ab: "a \<noteq> b" using a b by blast
- have at: "a \<notin> t" using a ab span_superset[of a "t- {b}"] by auto
- have mlt: "card ((insert a (t - {b})) - s) < n"
- using cardlt ft n a b by auto
- have ft': "finite (insert a (t - {b}))" using ft by auto
- {fix x assume xs: "x \<in> s"
- have t: "t \<subseteq> (insert b (insert a (t -{b})))" using b by auto
- from b(1) have "b \<in> span t" by (simp add: span_superset)
- have bs: "b \<in> span (insert a (t - {b}))"
- by (metis in_span_delete a sp mem_def subset_eq)
- from xs sp have "x \<in> span t" by blast
- with span_mono[OF t]
- have x: "x \<in> span (insert b (insert a (t - {b})))" ..
- from span_trans[OF bs x] have "x \<in> span (insert a (t - {b}))" .}
- then have sp': "s \<subseteq> span (insert a (t - {b}))" by blast
-
- from H[rule_format, OF mlt ft' s sp' refl] obtain u where
- u: "u hassize card (insert a (t -{b}))" "s \<subseteq> u" "u \<subseteq> s \<union> insert a (t -{b})"
- "s \<subseteq> span u" by blast
- from u a b ft at ct0 have "?P u" by (auto simp add: hassize_def)
- then have ?ths by blast }
- ultimately have ?ths by blast
- }
- ultimately
- show ?ths by blast
-qed
-
-(* This implies corresponding size bounds. *)
-
-lemma independent_span_bound:
- assumes f: "finite t" and i: "independent (s::('a::field^'n) set)" and sp:"s \<subseteq> span t"
- shows "finite s \<and> card s \<le> card t"
- by (metis exchange_lemma[OF f i sp] hassize_def finite_subset card_mono)
-
-
-lemma finite_Atleast_Atmost_nat[simp]: "finite {f x |x. x\<in> (UNIV::'a::finite set)}"
-proof-
- have eq: "{f x |x. x\<in> UNIV} = f ` UNIV" by auto
- show ?thesis unfolding eq
- apply (rule finite_imageI)
- apply (rule finite)
- done
-qed
-
-
-lemma independent_bound:
- fixes S:: "(real^'n::finite) set"
- shows "independent S \<Longrightarrow> finite S \<and> card S <= CARD('n)"
- apply (subst card_stdbasis[symmetric])
- apply (rule independent_span_bound)
- apply (rule finite_Atleast_Atmost_nat)
- apply assumption
- unfolding span_stdbasis
- apply (rule subset_UNIV)
- done
-
-lemma dependent_biggerset: "(finite (S::(real ^'n::finite) set) ==> card S > CARD('n)) ==> dependent S"
- by (metis independent_bound not_less)
-
-(* Hence we can create a maximal independent subset. *)
-
-lemma maximal_independent_subset_extend:
- assumes sv: "(S::(real^'n::finite) set) \<subseteq> V" and iS: "independent S"
- shows "\<exists>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
- using sv iS
-proof(induct d\<equiv> "CARD('n) - card S" arbitrary: S rule: nat_less_induct)
- fix n and S:: "(real^'n) set"
- assume H: "\<forall>m<n. \<forall>S \<subseteq> V. independent S \<longrightarrow> m = CARD('n) - card S \<longrightarrow>
- (\<exists>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B)"
- and sv: "S \<subseteq> V" and i: "independent S" and n: "n = CARD('n) - card S"
- let ?P = "\<lambda>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
- let ?ths = "\<exists>x. ?P x"
- let ?d = "CARD('n)"
- {assume "V \<subseteq> span S"
- then have ?ths using sv i by blast }
- moreover
- {assume VS: "\<not> V \<subseteq> span S"
- from VS obtain a where a: "a \<in> V" "a \<notin> span S" by blast
- from a have aS: "a \<notin> S" by (auto simp add: span_superset)
- have th0: "insert a S \<subseteq> V" using a sv by blast
- from independent_insert[of a S] i a
- have th1: "independent (insert a S)" by auto
- have mlt: "?d - card (insert a S) < n"
- using aS a n independent_bound[OF th1]
- by auto
-
- from H[rule_format, OF mlt th0 th1 refl]
- obtain B where B: "insert a S \<subseteq> B" "B \<subseteq> V" "independent B" " V \<subseteq> span B"
- by blast
- from B have "?P B" by auto
- then have ?ths by blast}
- ultimately show ?ths by blast
-qed
-
-lemma maximal_independent_subset:
- "\<exists>(B:: (real ^'n::finite) set). B\<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
- by (metis maximal_independent_subset_extend[of "{}:: (real ^'n) set"] empty_subsetI independent_empty)
-
-(* Notion of dimension. *)
-
-definition "dim V = (SOME n. \<exists>B. B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize n))"
-
-lemma basis_exists: "\<exists>B. (B :: (real ^'n::finite) set) \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize dim V)"
-unfolding dim_def some_eq_ex[of "\<lambda>n. \<exists>B. B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize n)"]
-unfolding hassize_def
-using maximal_independent_subset[of V] independent_bound
-by auto
-
-(* Consequences of independence or spanning for cardinality. *)
-
-lemma independent_card_le_dim: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> independent B \<Longrightarrow> finite B \<and> card B \<le> dim V"
-by (metis basis_exists[of V] independent_span_bound[where ?'a=real] hassize_def subset_trans)
-
-lemma span_card_ge_dim: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> finite B \<Longrightarrow> dim V \<le> card B"
- by (metis basis_exists[of V] independent_span_bound hassize_def subset_trans)
-
-lemma basis_card_eq_dim:
- "B \<subseteq> (V:: (real ^'n::finite) set) \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> independent B \<Longrightarrow> finite B \<and> card B = dim V"
- by (metis order_eq_iff independent_card_le_dim span_card_ge_dim independent_mono)
-
-lemma dim_unique: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> independent B \<Longrightarrow> B hassize n \<Longrightarrow> dim V = n"
- by (metis basis_card_eq_dim hassize_def)
-
-(* More lemmas about dimension. *)
-
-lemma dim_univ: "dim (UNIV :: (real^'n::finite) set) = CARD('n)"
- apply (rule dim_unique[of "{basis i |i. i\<in> (UNIV :: 'n set)}"])
- by (auto simp only: span_stdbasis has_size_stdbasis independent_stdbasis)
-
-lemma dim_subset:
- "(S:: (real ^'n::finite) set) \<subseteq> T \<Longrightarrow> dim S \<le> dim T"
- using basis_exists[of T] basis_exists[of S]
- by (metis independent_span_bound[where ?'a = real and ?'n = 'n] subset_eq hassize_def)
-
-lemma dim_subset_univ: "dim (S:: (real^'n::finite) set) \<le> CARD('n)"
- by (metis dim_subset subset_UNIV dim_univ)
-
-(* Converses to those. *)
-
-lemma card_ge_dim_independent:
- assumes BV:"(B::(real ^'n::finite) set) \<subseteq> V" and iB:"independent B" and dVB:"dim V \<le> card B"
- shows "V \<subseteq> span B"
-proof-
- {fix a assume aV: "a \<in> V"
- {assume aB: "a \<notin> span B"
- then have iaB: "independent (insert a B)" using iB aV BV by (simp add: independent_insert)
- from aV BV have th0: "insert a B \<subseteq> V" by blast
- from aB have "a \<notin>B" by (auto simp add: span_superset)
- with independent_card_le_dim[OF th0 iaB] dVB have False by auto}
- then have "a \<in> span B" by blast}
- then show ?thesis by blast
-qed
-
-lemma card_le_dim_spanning:
- assumes BV: "(B:: (real ^'n::finite) set) \<subseteq> V" and VB: "V \<subseteq> span B"
- and fB: "finite B" and dVB: "dim V \<ge> card B"
- shows "independent B"
-proof-
- {fix a assume a: "a \<in> B" "a \<in> span (B -{a})"
- from a fB have c0: "card B \<noteq> 0" by auto
- from a fB have cb: "card (B -{a}) = card B - 1" by auto
- from BV a have th0: "B -{a} \<subseteq> V" by blast
- {fix x assume x: "x \<in> V"
- from a have eq: "insert a (B -{a}) = B" by blast
- from x VB have x': "x \<in> span B" by blast
- from span_trans[OF a(2), unfolded eq, OF x']
- have "x \<in> span (B -{a})" . }
- then have th1: "V \<subseteq> span (B -{a})" by blast
- have th2: "finite (B -{a})" using fB by auto
- from span_card_ge_dim[OF th0 th1 th2]
- have c: "dim V \<le> card (B -{a})" .
- from c c0 dVB cb have False by simp}
- then show ?thesis unfolding dependent_def by blast
-qed
-
-lemma card_eq_dim: "(B:: (real ^'n::finite) set) \<subseteq> V \<Longrightarrow> B hassize dim V \<Longrightarrow> independent B \<longleftrightarrow> V \<subseteq> span B"
- by (metis hassize_def order_eq_iff card_le_dim_spanning
- card_ge_dim_independent)
-
-(* ------------------------------------------------------------------------- *)
-(* More general size bound lemmas. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma independent_bound_general:
- "independent (S:: (real^'n::finite) set) \<Longrightarrow> finite S \<and> card S \<le> dim S"
- by (metis independent_card_le_dim independent_bound subset_refl)
-
-lemma dependent_biggerset_general: "(finite (S:: (real^'n::finite) set) \<Longrightarrow> card S > dim S) \<Longrightarrow> dependent S"
- using independent_bound_general[of S] by (metis linorder_not_le)
-
-lemma dim_span: "dim (span (S:: (real ^'n::finite) set)) = dim S"
-proof-
- have th0: "dim S \<le> dim (span S)"
- by (auto simp add: subset_eq intro: dim_subset span_superset)
- from basis_exists[of S]
- obtain B where B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
- from B have fB: "finite B" "card B = dim S" unfolding hassize_def by blast+
- have bSS: "B \<subseteq> span S" using B(1) by (metis subset_eq span_inc)
- have sssB: "span S \<subseteq> span B" using span_mono[OF B(3)] by (simp add: span_span)
- from span_card_ge_dim[OF bSS sssB fB(1)] th0 show ?thesis
- using fB(2) by arith
-qed
-
-lemma subset_le_dim: "(S:: (real ^'n::finite) set) \<subseteq> span T \<Longrightarrow> dim S \<le> dim T"
- by (metis dim_span dim_subset)
-
-lemma span_eq_dim: "span (S:: (real ^'n::finite) set) = span T ==> dim S = dim T"
- by (metis dim_span)
-
-lemma spans_image:
- assumes lf: "linear (f::'a::semiring_1^'n \<Rightarrow> _)" and VB: "V \<subseteq> span B"
- shows "f ` V \<subseteq> span (f ` B)"
- unfolding span_linear_image[OF lf]
- by (metis VB image_mono)
-
-lemma dim_image_le:
- fixes f :: "real^'n::finite \<Rightarrow> real^'m::finite"
- assumes lf: "linear f" shows "dim (f ` S) \<le> dim (S:: (real ^'n::finite) set)"
-proof-
- from basis_exists[of S] obtain B where
- B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
- from B have fB: "finite B" "card B = dim S" unfolding hassize_def by blast+
- have "dim (f ` S) \<le> card (f ` B)"
- apply (rule span_card_ge_dim)
- using lf B fB by (auto simp add: span_linear_image spans_image subset_image_iff)
- also have "\<dots> \<le> dim S" using card_image_le[OF fB(1)] fB by simp
- finally show ?thesis .
-qed
-
-(* Relation between bases and injectivity/surjectivity of map. *)
-
-lemma spanning_surjective_image:
- assumes us: "UNIV \<subseteq> span (S:: ('a::semiring_1 ^'n) set)"
- and lf: "linear f" and sf: "surj f"
- shows "UNIV \<subseteq> span (f ` S)"
-proof-
- have "UNIV \<subseteq> f ` UNIV" using sf by (auto simp add: surj_def)
- also have " \<dots> \<subseteq> span (f ` S)" using spans_image[OF lf us] .
-finally show ?thesis .
-qed
-
-lemma independent_injective_image:
- assumes iS: "independent (S::('a::semiring_1^'n) set)" and lf: "linear f" and fi: "inj f"
- shows "independent (f ` S)"
-proof-
- {fix a assume a: "a \<in> S" "f a \<in> span (f ` S - {f a})"
- have eq: "f ` S - {f a} = f ` (S - {a})" using fi
- by (auto simp add: inj_on_def)
- from a have "f a \<in> f ` span (S -{a})"
- unfolding eq span_linear_image[OF lf, of "S - {a}"] by blast
- hence "a \<in> span (S -{a})" using fi by (auto simp add: inj_on_def)
- with a(1) iS have False by (simp add: dependent_def) }
- then show ?thesis unfolding dependent_def by blast
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Picking an orthogonal replacement for a spanning set. *)
-(* ------------------------------------------------------------------------- *)
- (* FIXME : Move to some general theory ?*)
-definition "pairwise R S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y\<in> S. x\<noteq>y \<longrightarrow> R x y)"
-
-lemma vector_sub_project_orthogonal: "(b::'a::ordered_field^'n::finite) \<bullet> (x - ((b \<bullet> x) / (b\<bullet>b)) *s b) = 0"
- apply (cases "b = 0", simp)
- apply (simp add: dot_rsub dot_rmult)
- unfolding times_divide_eq_right[symmetric]
- by (simp add: field_simps dot_eq_0)
-
-lemma basis_orthogonal:
- fixes B :: "(real ^'n::finite) set"
- assumes fB: "finite B"
- shows "\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C"
- (is " \<exists>C. ?P B C")
-proof(induct rule: finite_induct[OF fB])
- case 1 thus ?case apply (rule exI[where x="{}"]) by (auto simp add: pairwise_def)
-next
- case (2 a B)
- note fB = `finite B` and aB = `a \<notin> B`
- from `\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C`
- obtain C where C: "finite C" "card C \<le> card B"
- "span C = span B" "pairwise orthogonal C" by blast
- let ?a = "a - setsum (\<lambda>x. (x\<bullet>a / (x\<bullet>x)) *s x) C"
- let ?C = "insert ?a C"
- from C(1) have fC: "finite ?C" by simp
- from fB aB C(1,2) have cC: "card ?C \<le> card (insert a B)" by (simp add: card_insert_if)
- {fix x k
- have th0: "\<And>(a::'b::comm_ring) b c. a - (b - c) = c + (a - b)" by (simp add: ring_simps)
- have "x - k *s (a - (\<Sum>x\<in>C. (x \<bullet> a / (x \<bullet> x)) *s x)) \<in> span C \<longleftrightarrow> x - k *s a \<in> span C"
- apply (simp only: vector_ssub_ldistrib th0)
- apply (rule span_add_eq)
- apply (rule span_mul)
- apply (rule span_setsum[OF C(1)])
- apply clarify
- apply (rule span_mul)
- by (rule span_superset)}
- then have SC: "span ?C = span (insert a B)"
- unfolding expand_set_eq span_breakdown_eq C(3)[symmetric] by auto
- thm pairwise_def
- {fix x y assume xC: "x \<in> ?C" and yC: "y \<in> ?C" and xy: "x \<noteq> y"
- {assume xa: "x = ?a" and ya: "y = ?a"
- have "orthogonal x y" using xa ya xy by blast}
- moreover
- {assume xa: "x = ?a" and ya: "y \<noteq> ?a" "y \<in> C"
- from ya have Cy: "C = insert y (C - {y})" by blast
- have fth: "finite (C - {y})" using C by simp
- have "orthogonal x y"
- using xa ya
- unfolding orthogonal_def xa dot_lsub dot_rsub diff_eq_0_iff_eq
- apply simp
- apply (subst Cy)
- using C(1) fth
- apply (simp only: setsum_clauses)
- thm dot_ladd
- apply (auto simp add: dot_ladd dot_radd dot_lmult dot_rmult dot_eq_0 dot_sym[of y a] dot_lsum[OF fth])
- apply (rule setsum_0')
- apply clarsimp
- apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
- by auto}
- moreover
- {assume xa: "x \<noteq> ?a" "x \<in> C" and ya: "y = ?a"
- from xa have Cx: "C = insert x (C - {x})" by blast
- have fth: "finite (C - {x})" using C by simp
- have "orthogonal x y"
- using xa ya
- unfolding orthogonal_def ya dot_rsub dot_lsub diff_eq_0_iff_eq
- apply simp
- apply (subst Cx)
- using C(1) fth
- apply (simp only: setsum_clauses)
- apply (subst dot_sym[of x])
- apply (auto simp add: dot_radd dot_rmult dot_eq_0 dot_sym[of x a] dot_rsum[OF fth])
- apply (rule setsum_0')
- apply clarsimp
- apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
- by auto}
- moreover
- {assume xa: "x \<in> C" and ya: "y \<in> C"
- have "orthogonal x y" using xa ya xy C(4) unfolding pairwise_def by blast}
- ultimately have "orthogonal x y" using xC yC by blast}
- then have CPO: "pairwise orthogonal ?C" unfolding pairwise_def by blast
- from fC cC SC CPO have "?P (insert a B) ?C" by blast
- then show ?case by blast
-qed
-
-lemma orthogonal_basis_exists:
- fixes V :: "(real ^'n::finite) set"
- shows "\<exists>B. independent B \<and> B \<subseteq> span V \<and> V \<subseteq> span B \<and> (B hassize dim V) \<and> pairwise orthogonal B"
-proof-
- from basis_exists[of V] obtain B where B: "B \<subseteq> V" "independent B" "V \<subseteq> span B" "B hassize dim V" by blast
- from B have fB: "finite B" "card B = dim V" by (simp_all add: hassize_def)
- from basis_orthogonal[OF fB(1)] obtain C where
- C: "finite C" "card C \<le> card B" "span C = span B" "pairwise orthogonal C" by blast
- from C B
- have CSV: "C \<subseteq> span V" by (metis span_inc span_mono subset_trans)
- from span_mono[OF B(3)] C have SVC: "span V \<subseteq> span C" by (simp add: span_span)
- from card_le_dim_spanning[OF CSV SVC C(1)] C(2,3) fB
- have iC: "independent C" by (simp add: dim_span)
- from C fB have "card C \<le> dim V" by simp
- moreover have "dim V \<le> card C" using span_card_ge_dim[OF CSV SVC C(1)]
- by (simp add: dim_span)
- ultimately have CdV: "C hassize dim V" unfolding hassize_def using C(1) by simp
- from C B CSV CdV iC show ?thesis by auto
-qed
-
-lemma span_eq: "span S = span T \<longleftrightarrow> S \<subseteq> span T \<and> T \<subseteq> span S"
- by (metis set_eq_subset span_mono span_span span_inc) (* FIXME: slow *)
-
-(* ------------------------------------------------------------------------- *)
-(* Low-dimensional subset is in a hyperplane (weak orthogonal complement). *)
-(* ------------------------------------------------------------------------- *)
-
-lemma span_not_univ_orthogonal:
- assumes sU: "span S \<noteq> UNIV"
- shows "\<exists>(a:: real ^'n::finite). a \<noteq>0 \<and> (\<forall>x \<in> span S. a \<bullet> x = 0)"
-proof-
- from sU obtain a where a: "a \<notin> span S" by blast
- from orthogonal_basis_exists obtain B where
- B: "independent B" "B \<subseteq> span S" "S \<subseteq> span B" "B hassize dim S" "pairwise orthogonal B"
- by blast
- from B have fB: "finite B" "card B = dim S" by (simp_all add: hassize_def)
- from span_mono[OF B(2)] span_mono[OF B(3)]
- have sSB: "span S = span B" by (simp add: span_span)
- let ?a = "a - setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B"
- have "setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B \<in> span S"
- unfolding sSB
- apply (rule span_setsum[OF fB(1)])
- apply clarsimp
- apply (rule span_mul)
- by (rule span_superset)
- with a have a0:"?a \<noteq> 0" by auto
- have "\<forall>x\<in>span B. ?a \<bullet> x = 0"
- proof(rule span_induct')
- show "subspace (\<lambda>x. ?a \<bullet> x = 0)"
- by (auto simp add: subspace_def mem_def dot_radd dot_rmult)
- next
- {fix x assume x: "x \<in> B"
- from x have B': "B = insert x (B - {x})" by blast
- have fth: "finite (B - {x})" using fB by simp
- have "?a \<bullet> x = 0"
- apply (subst B') using fB fth
- unfolding setsum_clauses(2)[OF fth]
- apply simp
- apply (clarsimp simp add: dot_lsub dot_ladd dot_lmult dot_lsum dot_eq_0)
- apply (rule setsum_0', rule ballI)
- unfolding dot_sym
- by (auto simp add: x field_simps dot_eq_0 intro: B(5)[unfolded pairwise_def orthogonal_def, rule_format])}
- then show "\<forall>x \<in> B. ?a \<bullet> x = 0" by blast
- qed
- with a0 show ?thesis unfolding sSB by (auto intro: exI[where x="?a"])
-qed
-
-lemma span_not_univ_subset_hyperplane:
- assumes SU: "span S \<noteq> (UNIV ::(real^'n::finite) set)"
- shows "\<exists> a. a \<noteq>0 \<and> span S \<subseteq> {x. a \<bullet> x = 0}"
- using span_not_univ_orthogonal[OF SU] by auto
-
-lemma lowdim_subset_hyperplane:
- assumes d: "dim S < CARD('n::finite)"
- shows "\<exists>(a::real ^'n::finite). a \<noteq> 0 \<and> span S \<subseteq> {x. a \<bullet> x = 0}"
-proof-
- {assume "span S = UNIV"
- hence "dim (span S) = dim (UNIV :: (real ^'n) set)" by simp
- hence "dim S = CARD('n)" by (simp add: dim_span dim_univ)
- with d have False by arith}
- hence th: "span S \<noteq> UNIV" by blast
- from span_not_univ_subset_hyperplane[OF th] show ?thesis .
-qed
-
-(* We can extend a linear basis-basis injection to the whole set. *)
-
-lemma linear_indep_image_lemma:
- assumes lf: "linear f" and fB: "finite B"
- and ifB: "independent (f ` B)"
- and fi: "inj_on f B" and xsB: "x \<in> span B"
- and fx: "f (x::'a::field^'n) = 0"
- shows "x = 0"
- using fB ifB fi xsB fx
-proof(induct arbitrary: x rule: finite_induct[OF fB])
- case 1 thus ?case by (auto simp add: span_empty)
-next
- case (2 a b x)
- have fb: "finite b" using "2.prems" by simp
- have th0: "f ` b \<subseteq> f ` (insert a b)"
- apply (rule image_mono) by blast
- from independent_mono[ OF "2.prems"(2) th0]
- have ifb: "independent (f ` b)" .
- have fib: "inj_on f b"
- apply (rule subset_inj_on [OF "2.prems"(3)])
- by blast
- from span_breakdown[of a "insert a b", simplified, OF "2.prems"(4)]
- obtain k where k: "x - k*s a \<in> span (b -{a})" by blast
- have "f (x - k*s a) \<in> span (f ` b)"
- unfolding span_linear_image[OF lf]
- apply (rule imageI)
- using k span_mono[of "b-{a}" b] by blast
- hence "f x - k*s f a \<in> span (f ` b)"
- by (simp add: linear_sub[OF lf] linear_cmul[OF lf])
- hence th: "-k *s f a \<in> span (f ` b)"
- using "2.prems"(5) by (simp add: vector_smult_lneg)
- {assume k0: "k = 0"
- from k0 k have "x \<in> span (b -{a})" by simp
- then have "x \<in> span b" using span_mono[of "b-{a}" b]
- by blast}
- moreover
- {assume k0: "k \<noteq> 0"
- from span_mul[OF th, of "- 1/ k"] k0
- have th1: "f a \<in> span (f ` b)"
- by (auto simp add: vector_smult_assoc)
- from inj_on_image_set_diff[OF "2.prems"(3), of "insert a b " "{a}", symmetric]
- have tha: "f ` insert a b - f ` {a} = f ` (insert a b - {a})" by blast
- from "2.prems"(2)[unfolded dependent_def bex_simps(10), rule_format, of "f a"]
- have "f a \<notin> span (f ` b)" using tha
- using "2.hyps"(2)
- "2.prems"(3) by auto
- with th1 have False by blast
- then have "x \<in> span b" by blast}
- ultimately have xsb: "x \<in> span b" by blast
- from "2.hyps"(3)[OF fb ifb fib xsb "2.prems"(5)]
- show "x = 0" .
-qed
-
-(* We can extend a linear mapping from basis. *)
-
-lemma linear_independent_extend_lemma:
- assumes fi: "finite B" and ib: "independent B"
- shows "\<exists>g. (\<forall>x\<in> span B. \<forall>y\<in> span B. g ((x::'a::field^'n) + y) = g x + g y)
- \<and> (\<forall>x\<in> span B. \<forall>c. g (c*s x) = c *s g x)
- \<and> (\<forall>x\<in> B. g x = f x)"
-using ib fi
-proof(induct rule: finite_induct[OF fi])
- case 1 thus ?case by (auto simp add: span_empty)
-next
- case (2 a b)
- from "2.prems" "2.hyps" have ibf: "independent b" "finite b"
- by (simp_all add: independent_insert)
- from "2.hyps"(3)[OF ibf] obtain g where
- g: "\<forall>x\<in>span b. \<forall>y\<in>span b. g (x + y) = g x + g y"
- "\<forall>x\<in>span b. \<forall>c. g (c *s x) = c *s g x" "\<forall>x\<in>b. g x = f x" by blast
- let ?h = "\<lambda>z. SOME k. (z - k *s a) \<in> span b"
- {fix z assume z: "z \<in> span (insert a b)"
- have th0: "z - ?h z *s a \<in> span b"
- apply (rule someI_ex)
- unfolding span_breakdown_eq[symmetric]
- using z .
- {fix k assume k: "z - k *s a \<in> span b"
- have eq: "z - ?h z *s a - (z - k*s a) = (k - ?h z) *s a"
- by (simp add: ring_simps vector_sadd_rdistrib[symmetric])
- from span_sub[OF th0 k]
- have khz: "(k - ?h z) *s a \<in> span b" by (simp add: eq)
- {assume "k \<noteq> ?h z" hence k0: "k - ?h z \<noteq> 0" by simp
- from k0 span_mul[OF khz, of "1 /(k - ?h z)"]
- have "a \<in> span b" by (simp add: vector_smult_assoc)
- with "2.prems"(1) "2.hyps"(2) have False
- by (auto simp add: dependent_def)}
- then have "k = ?h z" by blast}
- with th0 have "z - ?h z *s a \<in> span b \<and> (\<forall>k. z - k *s a \<in> span b \<longrightarrow> k = ?h z)" by blast}
- note h = this
- let ?g = "\<lambda>z. ?h z *s f a + g (z - ?h z *s a)"
- {fix x y assume x: "x \<in> span (insert a b)" and y: "y \<in> span (insert a b)"
- have tha: "\<And>(x::'a^'n) y a k l. (x + y) - (k + l) *s a = (x - k *s a) + (y - l *s a)"
- by (vector ring_simps)
- have addh: "?h (x + y) = ?h x + ?h y"
- apply (rule conjunct2[OF h, rule_format, symmetric])
- apply (rule span_add[OF x y])
- unfolding tha
- by (metis span_add x y conjunct1[OF h, rule_format])
- have "?g (x + y) = ?g x + ?g y"
- unfolding addh tha
- g(1)[rule_format,OF conjunct1[OF h, OF x] conjunct1[OF h, OF y]]
- by (simp add: vector_sadd_rdistrib)}
- moreover
- {fix x:: "'a^'n" and c:: 'a assume x: "x \<in> span (insert a b)"
- have tha: "\<And>(x::'a^'n) c k a. c *s x - (c * k) *s a = c *s (x - k *s a)"
- by (vector ring_simps)
- have hc: "?h (c *s x) = c * ?h x"
- apply (rule conjunct2[OF h, rule_format, symmetric])
- apply (metis span_mul x)
- by (metis tha span_mul x conjunct1[OF h])
- have "?g (c *s x) = c*s ?g x"
- unfolding hc tha g(2)[rule_format, OF conjunct1[OF h, OF x]]
- by (vector ring_simps)}
- moreover
- {fix x assume x: "x \<in> (insert a b)"
- {assume xa: "x = a"
- have ha1: "1 = ?h a"
- apply (rule conjunct2[OF h, rule_format])
- apply (metis span_superset insertI1)
- using conjunct1[OF h, OF span_superset, OF insertI1]
- by (auto simp add: span_0)
-
- from xa ha1[symmetric] have "?g x = f x"
- apply simp
- using g(2)[rule_format, OF span_0, of 0]
- by simp}
- moreover
- {assume xb: "x \<in> b"
- have h0: "0 = ?h x"
- apply (rule conjunct2[OF h, rule_format])
- apply (metis span_superset insertI1 xb x)
- apply simp
- apply (metis span_superset xb)
- done
- have "?g x = f x"
- by (simp add: h0[symmetric] g(3)[rule_format, OF xb])}
- ultimately have "?g x = f x" using x by blast }
- ultimately show ?case apply - apply (rule exI[where x="?g"]) by blast
-qed
-
-lemma linear_independent_extend:
- assumes iB: "independent (B:: (real ^'n::finite) set)"
- shows "\<exists>g. linear g \<and> (\<forall>x\<in>B. g x = f x)"
-proof-
- from maximal_independent_subset_extend[of B UNIV] iB
- obtain C where C: "B \<subseteq> C" "independent C" "\<And>x. x \<in> span C" by auto
-
- from C(2) independent_bound[of C] linear_independent_extend_lemma[of C f]
- obtain g where g: "(\<forall>x\<in> span C. \<forall>y\<in> span C. g (x + y) = g x + g y)
- \<and> (\<forall>x\<in> span C. \<forall>c. g (c*s x) = c *s g x)
- \<and> (\<forall>x\<in> C. g x = f x)" by blast
- from g show ?thesis unfolding linear_def using C
- apply clarsimp by blast
-qed
-
-(* Can construct an isomorphism between spaces of same dimension. *)
-
-lemma card_le_inj: assumes fA: "finite A" and fB: "finite B"
- and c: "card A \<le> card B" shows "(\<exists>f. f ` A \<subseteq> B \<and> inj_on f A)"
-using fB c
-proof(induct arbitrary: B rule: finite_induct[OF fA])
- case 1 thus ?case by simp
-next
- case (2 x s t)
- thus ?case
- proof(induct rule: finite_induct[OF "2.prems"(1)])
- case 1 then show ?case by simp
- next
- case (2 y t)
- from "2.prems"(1,2,5) "2.hyps"(1,2) have cst:"card s \<le> card t" by simp
- from "2.prems"(3) [OF "2.hyps"(1) cst] obtain f where
- f: "f ` s \<subseteq> t \<and> inj_on f s" by blast
- from f "2.prems"(2) "2.hyps"(2) show ?case
- apply -
- apply (rule exI[where x = "\<lambda>z. if z = x then y else f z"])
- by (auto simp add: inj_on_def)
- qed
-qed
-
-lemma card_subset_eq: assumes fB: "finite B" and AB: "A \<subseteq> B" and
- c: "card A = card B"
- shows "A = B"
-proof-
- from fB AB have fA: "finite A" by (auto intro: finite_subset)
- from fA fB have fBA: "finite (B - A)" by auto
- have e: "A \<inter> (B - A) = {}" by blast
- have eq: "A \<union> (B - A) = B" using AB by blast
- from card_Un_disjoint[OF fA fBA e, unfolded eq c]
- have "card (B - A) = 0" by arith
- hence "B - A = {}" unfolding card_eq_0_iff using fA fB by simp
- with AB show "A = B" by blast
-qed
-
-lemma subspace_isomorphism:
- assumes s: "subspace (S:: (real ^'n::finite) set)"
- and t: "subspace (T :: (real ^ 'm::finite) set)"
- and d: "dim S = dim T"
- shows "\<exists>f. linear f \<and> f ` S = T \<and> inj_on f S"
-proof-
- from basis_exists[of S] obtain B where
- B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
- from basis_exists[of T] obtain C where
- C: "C \<subseteq> T" "independent C" "T \<subseteq> span C" "C hassize dim T" by blast
- from B(4) C(4) card_le_inj[of B C] d obtain f where
- f: "f ` B \<subseteq> C" "inj_on f B" unfolding hassize_def by auto
- from linear_independent_extend[OF B(2)] obtain g where
- g: "linear g" "\<forall>x\<in> B. g x = f x" by blast
- from B(4) have fB: "finite B" by (simp add: hassize_def)
- from C(4) have fC: "finite C" by (simp add: hassize_def)
- from inj_on_iff_eq_card[OF fB, of f] f(2)
- have "card (f ` B) = card B" by simp
- with B(4) C(4) have ceq: "card (f ` B) = card C" using d
- by (simp add: hassize_def)
- have "g ` B = f ` B" using g(2)
- by (auto simp add: image_iff)
- also have "\<dots> = C" using card_subset_eq[OF fC f(1) ceq] .
- finally have gBC: "g ` B = C" .
- have gi: "inj_on g B" using f(2) g(2)
- by (auto simp add: inj_on_def)
- note g0 = linear_indep_image_lemma[OF g(1) fB, unfolded gBC, OF C(2) gi]
- {fix x y assume x: "x \<in> S" and y: "y \<in> S" and gxy:"g x = g y"
- from B(3) x y have x': "x \<in> span B" and y': "y \<in> span B" by blast+
- from gxy have th0: "g (x - y) = 0" by (simp add: linear_sub[OF g(1)])
- have th1: "x - y \<in> span B" using x' y' by (metis span_sub)
- have "x=y" using g0[OF th1 th0] by simp }
- then have giS: "inj_on g S"
- unfolding inj_on_def by blast
- from span_subspace[OF B(1,3) s]
- have "g ` S = span (g ` B)" by (simp add: span_linear_image[OF g(1)])
- also have "\<dots> = span C" unfolding gBC ..
- also have "\<dots> = T" using span_subspace[OF C(1,3) t] .
- finally have gS: "g ` S = T" .
- from g(1) gS giS show ?thesis by blast
-qed
-
-(* linear functions are equal on a subspace if they are on a spanning set. *)
-
-lemma subspace_kernel:
- assumes lf: "linear (f::'a::semiring_1 ^'n \<Rightarrow> _)"
- shows "subspace {x. f x = 0}"
-apply (simp add: subspace_def)
-by (simp add: linear_add[OF lf] linear_cmul[OF lf] linear_0[OF lf])
-
-lemma linear_eq_0_span:
- assumes lf: "linear f" and f0: "\<forall>x\<in>B. f x = 0"
- shows "\<forall>x \<in> span B. f x = (0::'a::semiring_1 ^'n)"
-proof
- fix x assume x: "x \<in> span B"
- let ?P = "\<lambda>x. f x = 0"
- from subspace_kernel[OF lf] have "subspace ?P" unfolding Collect_def .
- with x f0 span_induct[of B "?P" x] show "f x = 0" by blast
-qed
-
-lemma linear_eq_0:
- assumes lf: "linear f" and SB: "S \<subseteq> span B" and f0: "\<forall>x\<in>B. f x = 0"
- shows "\<forall>x \<in> S. f x = (0::'a::semiring_1^'n)"
- by (metis linear_eq_0_span[OF lf] subset_eq SB f0)
-
-lemma linear_eq:
- assumes lf: "linear (f::'a::ring_1^'n \<Rightarrow> _)" and lg: "linear g" and S: "S \<subseteq> span B"
- and fg: "\<forall> x\<in> B. f x = g x"
- shows "\<forall>x\<in> S. f x = g x"
-proof-
- let ?h = "\<lambda>x. f x - g x"
- from fg have fg': "\<forall>x\<in> B. ?h x = 0" by simp
- from linear_eq_0[OF linear_compose_sub[OF lf lg] S fg']
- show ?thesis by simp
-qed
-
-lemma linear_eq_stdbasis:
- assumes lf: "linear (f::'a::ring_1^'m::finite \<Rightarrow> 'a^'n::finite)" and lg: "linear g"
- and fg: "\<forall>i. f (basis i) = g(basis i)"
- shows "f = g"
-proof-
- let ?U = "UNIV :: 'm set"
- let ?I = "{basis i:: 'a^'m|i. i \<in> ?U}"
- {fix x assume x: "x \<in> (UNIV :: ('a^'m) set)"
- from equalityD2[OF span_stdbasis]
- have IU: " (UNIV :: ('a^'m) set) \<subseteq> span ?I" by blast
- from linear_eq[OF lf lg IU] fg x
- have "f x = g x" unfolding Collect_def Ball_def mem_def by metis}
- then show ?thesis by (auto intro: ext)
-qed
-
-(* Similar results for bilinear functions. *)
-
-lemma bilinear_eq:
- assumes bf: "bilinear (f:: 'a::ring^'m \<Rightarrow> 'a^'n \<Rightarrow> 'a^'p)"
- and bg: "bilinear g"
- and SB: "S \<subseteq> span B" and TC: "T \<subseteq> span C"
- and fg: "\<forall>x\<in> B. \<forall>y\<in> C. f x y = g x y"
- shows "\<forall>x\<in>S. \<forall>y\<in>T. f x y = g x y "
-proof-
- let ?P = "\<lambda>x. \<forall>y\<in> span C. f x y = g x y"
- from bf bg have sp: "subspace ?P"
- unfolding bilinear_def linear_def subspace_def bf bg
- by(auto simp add: span_0 mem_def bilinear_lzero[OF bf] bilinear_lzero[OF bg] span_add Ball_def intro: bilinear_ladd[OF bf])
-
- have "\<forall>x \<in> span B. \<forall>y\<in> span C. f x y = g x y"
- apply -
- apply (rule ballI)
- apply (rule span_induct[of B ?P])
- defer
- apply (rule sp)
- apply assumption
- apply (clarsimp simp add: Ball_def)
- apply (rule_tac P="\<lambda>y. f xa y = g xa y" and S=C in span_induct)
- using fg
- apply (auto simp add: subspace_def)
- using bf bg unfolding bilinear_def linear_def
- by(auto simp add: span_0 mem_def bilinear_rzero[OF bf] bilinear_rzero[OF bg] span_add Ball_def intro: bilinear_ladd[OF bf])
- then show ?thesis using SB TC by (auto intro: ext)
-qed
-
-lemma bilinear_eq_stdbasis:
- assumes bf: "bilinear (f:: 'a::ring_1^'m::finite \<Rightarrow> 'a^'n::finite \<Rightarrow> 'a^'p)"
- and bg: "bilinear g"
- and fg: "\<forall>i j. f (basis i) (basis j) = g (basis i) (basis j)"
- shows "f = g"
-proof-
- from fg have th: "\<forall>x \<in> {basis i| i. i\<in> (UNIV :: 'm set)}. \<forall>y\<in> {basis j |j. j \<in> (UNIV :: 'n set)}. f x y = g x y" by blast
- from bilinear_eq[OF bf bg equalityD2[OF span_stdbasis] equalityD2[OF span_stdbasis] th] show ?thesis by (blast intro: ext)
-qed
-
-(* Detailed theorems about left and right invertibility in general case. *)
-
-lemma left_invertible_transp:
- "(\<exists>(B::'a^'n^'m). B ** transp (A::'a^'n^'m) = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B::'a^'m^'n). A ** B = mat 1)"
- by (metis matrix_transp_mul transp_mat transp_transp)
-
-lemma right_invertible_transp:
- "(\<exists>(B::'a^'n^'m). transp (A::'a^'n^'m) ** B = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B::'a^'m^'n). B ** A = mat 1)"
- by (metis matrix_transp_mul transp_mat transp_transp)
-
-lemma linear_injective_left_inverse:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" and fi: "inj f"
- shows "\<exists>g. linear g \<and> g o f = id"
-proof-
- from linear_independent_extend[OF independent_injective_image, OF independent_stdbasis, OF lf fi]
- obtain h:: "real ^'m \<Rightarrow> real ^'n" where h: "linear h" " \<forall>x \<in> f ` {basis i|i. i \<in> (UNIV::'n set)}. h x = inv f x" by blast
- from h(2)
- have th: "\<forall>i. (h \<circ> f) (basis i) = id (basis i)"
- using inv_o_cancel[OF fi, unfolded stupid_ext[symmetric] id_def o_def]
- by auto
-
- from linear_eq_stdbasis[OF linear_compose[OF lf h(1)] linear_id th]
- have "h o f = id" .
- then show ?thesis using h(1) by blast
-qed
-
-lemma linear_surjective_right_inverse:
- assumes lf: "linear (f:: real ^'m::finite \<Rightarrow> real ^'n::finite)" and sf: "surj f"
- shows "\<exists>g. linear g \<and> f o g = id"
-proof-
- from linear_independent_extend[OF independent_stdbasis]
- obtain h:: "real ^'n \<Rightarrow> real ^'m" where
- h: "linear h" "\<forall> x\<in> {basis i| i. i\<in> (UNIV :: 'n set)}. h x = inv f x" by blast
- from h(2)
- have th: "\<forall>i. (f o h) (basis i) = id (basis i)"
- using sf
- apply (auto simp add: surj_iff o_def stupid_ext[symmetric])
- apply (erule_tac x="basis i" in allE)
- by auto
-
- from linear_eq_stdbasis[OF linear_compose[OF h(1) lf] linear_id th]
- have "f o h = id" .
- then show ?thesis using h(1) by blast
-qed
-
-lemma matrix_left_invertible_injective:
-"(\<exists>B. (B::real^'m^'n) ** (A::real^'n::finite^'m::finite) = mat 1) \<longleftrightarrow> (\<forall>x y. A *v x = A *v y \<longrightarrow> x = y)"
-proof-
- {fix B:: "real^'m^'n" and x y assume B: "B ** A = mat 1" and xy: "A *v x = A*v y"
- from xy have "B*v (A *v x) = B *v (A*v y)" by simp
- hence "x = y"
- unfolding matrix_vector_mul_assoc B matrix_vector_mul_lid .}
- moreover
- {assume A: "\<forall>x y. A *v x = A *v y \<longrightarrow> x = y"
- hence i: "inj (op *v A)" unfolding inj_on_def by auto
- from linear_injective_left_inverse[OF matrix_vector_mul_linear i]
- obtain g where g: "linear g" "g o op *v A = id" by blast
- have "matrix g ** A = mat 1"
- unfolding matrix_eq matrix_vector_mul_lid matrix_vector_mul_assoc[symmetric] matrix_works[OF g(1)]
- using g(2) by (simp add: o_def id_def stupid_ext)
- then have "\<exists>B. (B::real ^'m^'n) ** A = mat 1" by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma matrix_left_invertible_ker:
- "(\<exists>B. (B::real ^'m::finite^'n::finite) ** (A::real^'n^'m) = mat 1) \<longleftrightarrow> (\<forall>x. A *v x = 0 \<longrightarrow> x = 0)"
- unfolding matrix_left_invertible_injective
- using linear_injective_0[OF matrix_vector_mul_linear, of A]
- by (simp add: inj_on_def)
-
-lemma matrix_right_invertible_surjective:
-"(\<exists>B. (A::real^'n::finite^'m::finite) ** (B::real^'m^'n) = mat 1) \<longleftrightarrow> surj (\<lambda>x. A *v x)"
-proof-
- {fix B :: "real ^'m^'n" assume AB: "A ** B = mat 1"
- {fix x :: "real ^ 'm"
- have "A *v (B *v x) = x"
- by (simp add: matrix_vector_mul_lid matrix_vector_mul_assoc AB)}
- hence "surj (op *v A)" unfolding surj_def by metis }
- moreover
- {assume sf: "surj (op *v A)"
- from linear_surjective_right_inverse[OF matrix_vector_mul_linear sf]
- obtain g:: "real ^'m \<Rightarrow> real ^'n" where g: "linear g" "op *v A o g = id"
- by blast
-
- have "A ** (matrix g) = mat 1"
- unfolding matrix_eq matrix_vector_mul_lid
- matrix_vector_mul_assoc[symmetric] matrix_works[OF g(1)]
- using g(2) unfolding o_def stupid_ext[symmetric] id_def
- .
- hence "\<exists>B. A ** (B::real^'m^'n) = mat 1" by blast
- }
- ultimately show ?thesis unfolding surj_def by blast
-qed
-
-lemma matrix_left_invertible_independent_columns:
- fixes A :: "real^'n::finite^'m::finite"
- shows "(\<exists>(B::real ^'m^'n). B ** A = mat 1) \<longleftrightarrow> (\<forall>c. setsum (\<lambda>i. c i *s column i A) (UNIV :: 'n set) = 0 \<longrightarrow> (\<forall>i. c i = 0))"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- let ?U = "UNIV :: 'n set"
- {assume k: "\<forall>x. A *v x = 0 \<longrightarrow> x = 0"
- {fix c i assume c: "setsum (\<lambda>i. c i *s column i A) ?U = 0"
- and i: "i \<in> ?U"
- let ?x = "\<chi> i. c i"
- have th0:"A *v ?x = 0"
- using c
- unfolding matrix_mult_vsum Cart_eq
- by auto
- from k[rule_format, OF th0] i
- have "c i = 0" by (vector Cart_eq)}
- hence ?rhs by blast}
- moreover
- {assume H: ?rhs
- {fix x assume x: "A *v x = 0"
- let ?c = "\<lambda>i. ((x$i ):: real)"
- from H[rule_format, of ?c, unfolded matrix_mult_vsum[symmetric], OF x]
- have "x = 0" by vector}}
- ultimately show ?thesis unfolding matrix_left_invertible_ker by blast
-qed
-
-lemma matrix_right_invertible_independent_rows:
- fixes A :: "real^'n::finite^'m::finite"
- shows "(\<exists>(B::real^'m^'n). A ** B = mat 1) \<longleftrightarrow> (\<forall>c. setsum (\<lambda>i. c i *s row i A) (UNIV :: 'm set) = 0 \<longrightarrow> (\<forall>i. c i = 0))"
- unfolding left_invertible_transp[symmetric]
- matrix_left_invertible_independent_columns
- by (simp add: column_transp)
-
-lemma matrix_right_invertible_span_columns:
- "(\<exists>(B::real ^'n::finite^'m::finite). (A::real ^'m^'n) ** B = mat 1) \<longleftrightarrow> span (columns A) = UNIV" (is "?lhs = ?rhs")
-proof-
- let ?U = "UNIV :: 'm set"
- have fU: "finite ?U" by simp
- have lhseq: "?lhs \<longleftrightarrow> (\<forall>y. \<exists>(x::real^'m). setsum (\<lambda>i. (x$i) *s column i A) ?U = y)"
- unfolding matrix_right_invertible_surjective matrix_mult_vsum surj_def
- apply (subst eq_commute) ..
- have rhseq: "?rhs \<longleftrightarrow> (\<forall>x. x \<in> span (columns A))" by blast
- {assume h: ?lhs
- {fix x:: "real ^'n"
- from h[unfolded lhseq, rule_format, of x] obtain y:: "real ^'m"
- where y: "setsum (\<lambda>i. (y$i) *s column i A) ?U = x" by blast
- have "x \<in> span (columns A)"
- unfolding y[symmetric]
- apply (rule span_setsum[OF fU])
- apply clarify
- apply (rule span_mul)
- apply (rule span_superset)
- unfolding columns_def
- by blast}
- then have ?rhs unfolding rhseq by blast}
- moreover
- {assume h:?rhs
- let ?P = "\<lambda>(y::real ^'n). \<exists>(x::real^'m). setsum (\<lambda>i. (x$i) *s column i A) ?U = y"
- {fix y have "?P y"
- proof(rule span_induct_alt[of ?P "columns A"])
- show "\<exists>x\<Colon>real ^ 'm. setsum (\<lambda>i. (x$i) *s column i A) ?U = 0"
- apply (rule exI[where x=0])
- by (simp add: zero_index vector_smult_lzero)
- next
- fix c y1 y2 assume y1: "y1 \<in> columns A" and y2: "?P y2"
- from y1 obtain i where i: "i \<in> ?U" "y1 = column i A"
- unfolding columns_def by blast
- from y2 obtain x:: "real ^'m" where
- x: "setsum (\<lambda>i. (x$i) *s column i A) ?U = y2" by blast
- let ?x = "(\<chi> j. if j = i then c + (x$i) else (x$j))::real^'m"
- show "?P (c*s y1 + y2)"
- proof(rule exI[where x= "?x"], vector, auto simp add: i x[symmetric] cond_value_iff right_distrib cond_application_beta cong del: if_weak_cong)
- fix j
- have th: "\<forall>xa \<in> ?U. (if xa = i then (c + (x$i)) * ((column xa A)$j)
- else (x$xa) * ((column xa A$j))) = (if xa = i then c * ((column i A)$j) else 0) + ((x$xa) * ((column xa A)$j))" using i(1)
- by (simp add: ring_simps)
- have "setsum (\<lambda>xa. if xa = i then (c + (x$i)) * ((column xa A)$j)
- else (x$xa) * ((column xa A$j))) ?U = setsum (\<lambda>xa. (if xa = i then c * ((column i A)$j) else 0) + ((x$xa) * ((column xa A)$j))) ?U"
- apply (rule setsum_cong[OF refl])
- using th by blast
- also have "\<dots> = setsum (\<lambda>xa. if xa = i then c * ((column i A)$j) else 0) ?U + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U"
- by (simp add: setsum_addf)
- also have "\<dots> = c * ((column i A)$j) + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U"
- unfolding setsum_delta[OF fU]
- using i(1) by simp
- finally show "setsum (\<lambda>xa. if xa = i then (c + (x$i)) * ((column xa A)$j)
- else (x$xa) * ((column xa A$j))) ?U = c * ((column i A)$j) + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U" .
- qed
- next
- show "y \<in> span (columns A)" unfolding h by blast
- qed}
- then have ?lhs unfolding lhseq ..}
- ultimately show ?thesis by blast
-qed
-
-lemma matrix_left_invertible_span_rows:
- "(\<exists>(B::real^'m::finite^'n::finite). B ** (A::real^'n^'m) = mat 1) \<longleftrightarrow> span (rows A) = UNIV"
- unfolding right_invertible_transp[symmetric]
- unfolding columns_transp[symmetric]
- unfolding matrix_right_invertible_span_columns
- ..
-
-(* An injective map real^'n->real^'n is also surjective. *)
-
-lemma linear_injective_imp_surjective:
- assumes lf: "linear (f:: real ^'n::finite \<Rightarrow> real ^'n)" and fi: "inj f"
- shows "surj f"
-proof-
- let ?U = "UNIV :: (real ^'n) set"
- from basis_exists[of ?U] obtain B
- where B: "B \<subseteq> ?U" "independent B" "?U \<subseteq> span B" "B hassize dim ?U"
- by blast
- from B(4) have d: "dim ?U = card B" by (simp add: hassize_def)
- have th: "?U \<subseteq> span (f ` B)"
- apply (rule card_ge_dim_independent)
- apply blast
- apply (rule independent_injective_image[OF B(2) lf fi])
- apply (rule order_eq_refl)
- apply (rule sym)
- unfolding d
- apply (rule card_image)
- apply (rule subset_inj_on[OF fi])
- by blast
- from th show ?thesis
- unfolding span_linear_image[OF lf] surj_def
- using B(3) by blast
-qed
-
-(* And vice versa. *)
-
-lemma surjective_iff_injective_gen:
- assumes fS: "finite S" and fT: "finite T" and c: "card S = card T"
- and ST: "f ` S \<subseteq> T"
- shows "(\<forall>y \<in> T. \<exists>x \<in> S. f x = y) \<longleftrightarrow> inj_on f S" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume h: "?lhs"
- {fix x y assume x: "x \<in> S" and y: "y \<in> S" and f: "f x = f y"
- from x fS have S0: "card S \<noteq> 0" by auto
- {assume xy: "x \<noteq> y"
- have th: "card S \<le> card (f ` (S - {y}))"
- unfolding c
- apply (rule card_mono)
- apply (rule finite_imageI)
- using fS apply simp
- using h xy x y f unfolding subset_eq image_iff
- apply auto
- apply (case_tac "xa = f x")
- apply (rule bexI[where x=x])
- apply auto
- done
- also have " \<dots> \<le> card (S -{y})"
- apply (rule card_image_le)
- using fS by simp
- also have "\<dots> \<le> card S - 1" using y fS by simp
- finally have False using S0 by arith }
- then have "x = y" by blast}
- then have ?rhs unfolding inj_on_def by blast}
- moreover
- {assume h: ?rhs
- have "f ` S = T"
- apply (rule card_subset_eq[OF fT ST])
- unfolding card_image[OF h] using c .
- then have ?lhs by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma linear_surjective_imp_injective:
- assumes lf: "linear (f::real ^'n::finite => real ^'n)" and sf: "surj f"
- shows "inj f"
-proof-
- let ?U = "UNIV :: (real ^'n) set"
- from basis_exists[of ?U] obtain B
- where B: "B \<subseteq> ?U" "independent B" "?U \<subseteq> span B" "B hassize dim ?U"
- by blast
- {fix x assume x: "x \<in> span B" and fx: "f x = 0"
- from B(4) have fB: "finite B" by (simp add: hassize_def)
- from B(4) have d: "dim ?U = card B" by (simp add: hassize_def)
- have fBi: "independent (f ` B)"
- apply (rule card_le_dim_spanning[of "f ` B" ?U])
- apply blast
- using sf B(3)
- unfolding span_linear_image[OF lf] surj_def subset_eq image_iff
- apply blast
- using fB apply (blast intro: finite_imageI)
- unfolding d
- apply (rule card_image_le)
- apply (rule fB)
- done
- have th0: "dim ?U \<le> card (f ` B)"
- apply (rule span_card_ge_dim)
- apply blast
- unfolding span_linear_image[OF lf]
- apply (rule subset_trans[where B = "f ` UNIV"])
- using sf unfolding surj_def apply blast
- apply (rule image_mono)
- apply (rule B(3))
- apply (metis finite_imageI fB)
- done
-
- moreover have "card (f ` B) \<le> card B"
- by (rule card_image_le, rule fB)
- ultimately have th1: "card B = card (f ` B)" unfolding d by arith
- have fiB: "inj_on f B"
- unfolding surjective_iff_injective_gen[OF fB finite_imageI[OF fB] th1 subset_refl, symmetric] by blast
- from linear_indep_image_lemma[OF lf fB fBi fiB x] fx
- have "x = 0" by blast}
- note th = this
- from th show ?thesis unfolding linear_injective_0[OF lf]
- using B(3) by blast
-qed
-
-(* Hence either is enough for isomorphism. *)
-
-lemma left_right_inverse_eq:
- assumes fg: "f o g = id" and gh: "g o h = id"
- shows "f = h"
-proof-
- have "f = f o (g o h)" unfolding gh by simp
- also have "\<dots> = (f o g) o h" by (simp add: o_assoc)
- finally show "f = h" unfolding fg by simp
-qed
-
-lemma isomorphism_expand:
- "f o g = id \<and> g o f = id \<longleftrightarrow> (\<forall>x. f(g x) = x) \<and> (\<forall>x. g(f x) = x)"
- by (simp add: expand_fun_eq o_def id_def)
-
-lemma linear_injective_isomorphism:
- assumes lf: "linear (f :: real^'n::finite \<Rightarrow> real ^'n)" and fi: "inj f"
- shows "\<exists>f'. linear f' \<and> (\<forall>x. f' (f x) = x) \<and> (\<forall>x. f (f' x) = x)"
-unfolding isomorphism_expand[symmetric]
-using linear_surjective_right_inverse[OF lf linear_injective_imp_surjective[OF lf fi]] linear_injective_left_inverse[OF lf fi]
-by (metis left_right_inverse_eq)
-
-lemma linear_surjective_isomorphism:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and sf: "surj f"
- shows "\<exists>f'. linear f' \<and> (\<forall>x. f' (f x) = x) \<and> (\<forall>x. f (f' x) = x)"
-unfolding isomorphism_expand[symmetric]
-using linear_surjective_right_inverse[OF lf sf] linear_injective_left_inverse[OF lf linear_surjective_imp_injective[OF lf sf]]
-by (metis left_right_inverse_eq)
-
-(* Left and right inverses are the same for R^N->R^N. *)
-
-lemma linear_inverse_left:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and lf': "linear f'"
- shows "f o f' = id \<longleftrightarrow> f' o f = id"
-proof-
- {fix f f':: "real ^'n \<Rightarrow> real ^'n"
- assume lf: "linear f" "linear f'" and f: "f o f' = id"
- from f have sf: "surj f"
-
- apply (auto simp add: o_def stupid_ext[symmetric] id_def surj_def)
- by metis
- from linear_surjective_isomorphism[OF lf(1) sf] lf f
- have "f' o f = id" unfolding stupid_ext[symmetric] o_def id_def
- by metis}
- then show ?thesis using lf lf' by metis
-qed
-
-(* Moreover, a one-sided inverse is automatically linear. *)
-
-lemma left_inverse_linear:
- assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and gf: "g o f = id"
- shows "linear g"
-proof-
- from gf have fi: "inj f" apply (auto simp add: inj_on_def o_def id_def stupid_ext[symmetric])
- by metis
- from linear_injective_isomorphism[OF lf fi]
- obtain h:: "real ^'n \<Rightarrow> real ^'n" where
- h: "linear h" "\<forall>x. h (f x) = x" "\<forall>x. f (h x) = x" by blast
- have "h = g" apply (rule ext) using gf h(2,3)
- apply (simp add: o_def id_def stupid_ext[symmetric])
- by metis
- with h(1) show ?thesis by blast
-qed
-
-lemma right_inverse_linear:
- assumes lf: "linear (f:: real ^'n::finite \<Rightarrow> real ^'n)" and gf: "f o g = id"
- shows "linear g"
-proof-
- from gf have fi: "surj f" apply (auto simp add: surj_def o_def id_def stupid_ext[symmetric])
- by metis
- from linear_surjective_isomorphism[OF lf fi]
- obtain h:: "real ^'n \<Rightarrow> real ^'n" where
- h: "linear h" "\<forall>x. h (f x) = x" "\<forall>x. f (h x) = x" by blast
- have "h = g" apply (rule ext) using gf h(2,3)
- apply (simp add: o_def id_def stupid_ext[symmetric])
- by metis
- with h(1) show ?thesis by blast
-qed
-
-(* The same result in terms of square matrices. *)
-
-lemma matrix_left_right_inverse:
- fixes A A' :: "real ^'n::finite^'n"
- shows "A ** A' = mat 1 \<longleftrightarrow> A' ** A = mat 1"
-proof-
- {fix A A' :: "real ^'n^'n" assume AA': "A ** A' = mat 1"
- have sA: "surj (op *v A)"
- unfolding surj_def
- apply clarify
- apply (rule_tac x="(A' *v y)" in exI)
- by (simp add: matrix_vector_mul_assoc AA' matrix_vector_mul_lid)
- from linear_surjective_isomorphism[OF matrix_vector_mul_linear sA]
- obtain f' :: "real ^'n \<Rightarrow> real ^'n"
- where f': "linear f'" "\<forall>x. f' (A *v x) = x" "\<forall>x. A *v f' x = x" by blast
- have th: "matrix f' ** A = mat 1"
- by (simp add: matrix_eq matrix_works[OF f'(1)] matrix_vector_mul_assoc[symmetric] matrix_vector_mul_lid f'(2)[rule_format])
- hence "(matrix f' ** A) ** A' = mat 1 ** A'" by simp
- hence "matrix f' = A'" by (simp add: matrix_mul_assoc[symmetric] AA' matrix_mul_rid matrix_mul_lid)
- hence "matrix f' ** A = A' ** A" by simp
- hence "A' ** A = mat 1" by (simp add: th)}
- then show ?thesis by blast
-qed
-
-(* Considering an n-element vector as an n-by-1 or 1-by-n matrix. *)
-
-definition "rowvector v = (\<chi> i j. (v$j))"
-
-definition "columnvector v = (\<chi> i j. (v$i))"
-
-lemma transp_columnvector:
- "transp(columnvector v) = rowvector v"
- by (simp add: transp_def rowvector_def columnvector_def Cart_eq)
-
-lemma transp_rowvector: "transp(rowvector v) = columnvector v"
- by (simp add: transp_def columnvector_def rowvector_def Cart_eq)
-
-lemma dot_rowvector_columnvector:
- "columnvector (A *v v) = A ** columnvector v"
- by (vector columnvector_def matrix_matrix_mult_def matrix_vector_mult_def)
-
-lemma dot_matrix_product: "(x::'a::semiring_1^'n::finite) \<bullet> y = (((rowvector x ::'a^'n^1) ** (columnvector y :: 'a^1^'n))$1)$1"
- by (vector matrix_matrix_mult_def rowvector_def columnvector_def dot_def)
-
-lemma dot_matrix_vector_mul:
- fixes A B :: "real ^'n::finite ^'n" and x y :: "real ^'n"
- shows "(A *v x) \<bullet> (B *v y) =
- (((rowvector x :: real^'n^1) ** ((transp A ** B) ** (columnvector y :: real ^1^'n)))$1)$1"
-unfolding dot_matrix_product transp_columnvector[symmetric]
- dot_rowvector_columnvector matrix_transp_mul matrix_mul_assoc ..
-
-(* Infinity norm. *)
-
-definition "infnorm (x::real^'n::finite) = Sup {abs(x$i) |i. i\<in> (UNIV :: 'n set)}"
-
-lemma numseg_dimindex_nonempty: "\<exists>i. i \<in> (UNIV :: 'n set)"
- by auto
-
-lemma infnorm_set_image:
- "{abs(x$i) |i. i\<in> (UNIV :: 'n set)} =
- (\<lambda>i. abs(x$i)) ` (UNIV :: 'n set)" by blast
-
-lemma infnorm_set_lemma:
- shows "finite {abs((x::'a::abs ^'n::finite)$i) |i. i\<in> (UNIV :: 'n set)}"
- and "{abs(x$i) |i. i\<in> (UNIV :: 'n::finite set)} \<noteq> {}"
- unfolding infnorm_set_image
- by (auto intro: finite_imageI)
-
-lemma infnorm_pos_le: "0 \<le> infnorm (x::real^'n::finite)"
- unfolding infnorm_def
- unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
- unfolding infnorm_set_image
- by auto
-
-lemma infnorm_triangle: "infnorm ((x::real^'n::finite) + y) \<le> infnorm x + infnorm y"
-proof-
- have th: "\<And>x y (z::real). x - y <= z \<longleftrightarrow> x - z <= y" by arith
- have th1: "\<And>S f. f ` S = { f i| i. i \<in> S}" by blast
- have th2: "\<And>x (y::real). abs(x + y) - abs(x) <= abs(y)" by arith
- show ?thesis
- unfolding infnorm_def
- unfolding Sup_finite_le_iff[ OF infnorm_set_lemma]
- apply (subst diff_le_eq[symmetric])
- unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
- unfolding infnorm_set_image bex_simps
- apply (subst th)
- unfolding th1
- unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
-
- unfolding infnorm_set_image ball_simps bex_simps
- apply simp
- apply (metis th2)
- done
-qed
-
-lemma infnorm_eq_0: "infnorm x = 0 \<longleftrightarrow> (x::real ^'n::finite) = 0"
-proof-
- have "infnorm x <= 0 \<longleftrightarrow> x = 0"
- unfolding infnorm_def
- unfolding Sup_finite_le_iff[OF infnorm_set_lemma]
- unfolding infnorm_set_image ball_simps
- by vector
- then show ?thesis using infnorm_pos_le[of x] by simp
-qed
-
-lemma infnorm_0: "infnorm 0 = 0"
- by (simp add: infnorm_eq_0)
-
-lemma infnorm_neg: "infnorm (- x) = infnorm x"
- unfolding infnorm_def
- apply (rule cong[of "Sup" "Sup"])
- apply blast
- apply (rule set_ext)
- apply auto
- done
-
-lemma infnorm_sub: "infnorm (x - y) = infnorm (y - x)"
-proof-
- have "y - x = - (x - y)" by simp
- then show ?thesis by (metis infnorm_neg)
-qed
-
-lemma real_abs_sub_infnorm: "\<bar> infnorm x - infnorm y\<bar> \<le> infnorm (x - y)"
-proof-
- have th: "\<And>(nx::real) n ny. nx <= n + ny \<Longrightarrow> ny <= n + nx ==> \<bar>nx - ny\<bar> <= n"
- by arith
- from infnorm_triangle[of "x - y" " y"] infnorm_triangle[of "x - y" "-x"]
- have ths: "infnorm x \<le> infnorm (x - y) + infnorm y"
- "infnorm y \<le> infnorm (x - y) + infnorm x"
- by (simp_all add: ring_simps infnorm_neg diff_def[symmetric])
- from th[OF ths] show ?thesis .
-qed
-
-lemma real_abs_infnorm: " \<bar>infnorm x\<bar> = infnorm x"
- using infnorm_pos_le[of x] by arith
-
-lemma component_le_infnorm:
- shows "\<bar>x$i\<bar> \<le> infnorm (x::real^'n::finite)"
-proof-
- let ?U = "UNIV :: 'n set"
- let ?S = "{\<bar>x$i\<bar> |i. i\<in> ?U}"
- have fS: "finite ?S" unfolding image_Collect[symmetric]
- apply (rule finite_imageI) unfolding Collect_def mem_def by simp
- have S0: "?S \<noteq> {}" by blast
- have th1: "\<And>S f. f ` S = { f i| i. i \<in> S}" by blast
- from Sup_finite_in[OF fS S0]
- show ?thesis unfolding infnorm_def infnorm_set_image
- by (metis Sup_finite_ge_iff finite finite_imageI UNIV_not_empty image_is_empty
- rangeI real_le_refl)
-qed
-
-lemma infnorm_mul_lemma: "infnorm(a *s x) <= \<bar>a\<bar> * infnorm x"
- apply (subst infnorm_def)
- unfolding Sup_finite_le_iff[OF infnorm_set_lemma]
- unfolding infnorm_set_image ball_simps
- apply (simp add: abs_mult)
- apply (rule allI)
- apply (cut_tac component_le_infnorm[of x])
- apply (rule mult_mono)
- apply auto
- done
-
-lemma infnorm_mul: "infnorm(a *s x) = abs a * infnorm x"
-proof-
- {assume a0: "a = 0" hence ?thesis by (simp add: infnorm_0) }
- moreover
- {assume a0: "a \<noteq> 0"
- from a0 have th: "(1/a) *s (a *s x) = x"
- by (simp add: vector_smult_assoc)
- from a0 have ap: "\<bar>a\<bar> > 0" by arith
- from infnorm_mul_lemma[of "1/a" "a *s x"]
- have "infnorm x \<le> 1/\<bar>a\<bar> * infnorm (a*s x)"
- unfolding th by simp
- with ap have "\<bar>a\<bar> * infnorm x \<le> \<bar>a\<bar> * (1/\<bar>a\<bar> * infnorm (a *s x))" by (simp add: field_simps)
- then have "\<bar>a\<bar> * infnorm x \<le> infnorm (a*s x)"
- using ap by (simp add: field_simps)
- with infnorm_mul_lemma[of a x] have ?thesis by arith }
- ultimately show ?thesis by blast
-qed
-
-lemma infnorm_pos_lt: "infnorm x > 0 \<longleftrightarrow> x \<noteq> 0"
- using infnorm_pos_le[of x] infnorm_eq_0[of x] by arith
-
-(* Prove that it differs only up to a bound from Euclidean norm. *)
-
-lemma infnorm_le_norm: "infnorm x \<le> norm x"
- unfolding infnorm_def Sup_finite_le_iff[OF infnorm_set_lemma]
- unfolding infnorm_set_image ball_simps
- by (metis component_le_norm)
-lemma card_enum: "card {1 .. n} = n" by auto
-lemma norm_le_infnorm: "norm(x) <= sqrt(real CARD('n)) * infnorm(x::real ^'n::finite)"
-proof-
- let ?d = "CARD('n)"
- have "real ?d \<ge> 0" by simp
- hence d2: "(sqrt (real ?d))^2 = real ?d"
- by (auto intro: real_sqrt_pow2)
- have th: "sqrt (real ?d) * infnorm x \<ge> 0"
- by (simp add: zero_le_mult_iff real_sqrt_ge_0_iff infnorm_pos_le)
- have th1: "x\<bullet>x \<le> (sqrt (real ?d) * infnorm x)^2"
- unfolding power_mult_distrib d2
- apply (subst power2_abs[symmetric])
- unfolding real_of_nat_def dot_def power2_eq_square[symmetric]
- apply (subst power2_abs[symmetric])
- apply (rule setsum_bounded)
- apply (rule power_mono)
- unfolding abs_of_nonneg[OF infnorm_pos_le]
- unfolding infnorm_def Sup_finite_ge_iff[OF infnorm_set_lemma]
- unfolding infnorm_set_image bex_simps
- apply blast
- by (rule abs_ge_zero)
- from real_le_lsqrt[OF dot_pos_le th th1]
- show ?thesis unfolding real_vector_norm_def id_def .
-qed
-
-(* Equality in Cauchy-Schwarz and triangle inequalities. *)
-
-lemma norm_cauchy_schwarz_eq: "(x::real ^'n::finite) \<bullet> y = norm x * norm y \<longleftrightarrow> norm x *s y = norm y *s x" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume h: "x = 0"
- hence ?thesis by simp}
- moreover
- {assume h: "y = 0"
- hence ?thesis by simp}
- moreover
- {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
- from dot_eq_0[of "norm y *s x - norm x *s y"]
- have "?rhs \<longleftrightarrow> (norm y * (norm y * norm x * norm x - norm x * (x \<bullet> y)) - norm x * (norm y * (y \<bullet> x) - norm x * norm y * norm y) = 0)"
- using x y
- unfolding dot_rsub dot_lsub dot_lmult dot_rmult
- unfolding norm_pow_2[symmetric] power2_eq_square diff_eq_0_iff_eq apply (simp add: dot_sym)
- apply (simp add: ring_simps)
- apply metis
- done
- also have "\<dots> \<longleftrightarrow> (2 * norm x * norm y * (norm x * norm y - x \<bullet> y) = 0)" using x y
- by (simp add: ring_simps dot_sym)
- also have "\<dots> \<longleftrightarrow> ?lhs" using x y
- apply simp
- by metis
- finally have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma norm_cauchy_schwarz_abs_eq:
- fixes x y :: "real ^ 'n::finite"
- shows "abs(x \<bullet> y) = norm x * norm y \<longleftrightarrow>
- norm x *s y = norm y *s x \<or> norm(x) *s y = - norm y *s x" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- have th: "\<And>(x::real) a. a \<ge> 0 \<Longrightarrow> abs x = a \<longleftrightarrow> x = a \<or> x = - a" by arith
- have "?rhs \<longleftrightarrow> norm x *s y = norm y *s x \<or> norm (- x) *s y = norm y *s (- x)"
- apply simp by vector
- also have "\<dots> \<longleftrightarrow>(x \<bullet> y = norm x * norm y \<or>
- (-x) \<bullet> y = norm x * norm y)"
- unfolding norm_cauchy_schwarz_eq[symmetric]
- unfolding norm_minus_cancel
- norm_mul by blast
- also have "\<dots> \<longleftrightarrow> ?lhs"
- unfolding th[OF mult_nonneg_nonneg, OF norm_ge_zero[of x] norm_ge_zero[of y]] dot_lneg
- by arith
- finally show ?thesis ..
-qed
-
-lemma norm_triangle_eq:
- fixes x y :: "real ^ 'n::finite"
- shows "norm(x + y) = norm x + norm y \<longleftrightarrow> norm x *s y = norm y *s x"
-proof-
- {assume x: "x =0 \<or> y =0"
- hence ?thesis by (cases "x=0", simp_all)}
- moreover
- {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
- hence "norm x \<noteq> 0" "norm y \<noteq> 0"
- by simp_all
- hence n: "norm x > 0" "norm y > 0"
- using norm_ge_zero[of x] norm_ge_zero[of y]
- by arith+
- have th: "\<And>(a::real) b c. a + b + c \<noteq> 0 ==> (a = b + c \<longleftrightarrow> a^2 = (b + c)^2)" by algebra
- have "norm(x + y) = norm x + norm y \<longleftrightarrow> norm(x + y)^ 2 = (norm x + norm y) ^2"
- apply (rule th) using n norm_ge_zero[of "x + y"]
- by arith
- also have "\<dots> \<longleftrightarrow> norm x *s y = norm y *s x"
- unfolding norm_cauchy_schwarz_eq[symmetric]
- unfolding norm_pow_2 dot_ladd dot_radd
- by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym ring_simps)
- finally have ?thesis .}
- ultimately show ?thesis by blast
-qed
-
-(* Collinearity.*)
-
-definition "collinear S \<longleftrightarrow> (\<exists>u. \<forall>x \<in> S. \<forall> y \<in> S. \<exists>c. x - y = c *s u)"
-
-lemma collinear_empty: "collinear {}" by (simp add: collinear_def)
-
-lemma collinear_sing: "collinear {(x::'a::ring_1^'n)}"
- apply (simp add: collinear_def)
- apply (rule exI[where x=0])
- by simp
-
-lemma collinear_2: "collinear {(x::'a::ring_1^'n),y}"
- apply (simp add: collinear_def)
- apply (rule exI[where x="x - y"])
- apply auto
- apply (rule exI[where x=0], simp)
- apply (rule exI[where x=1], simp)
- apply (rule exI[where x="- 1"], simp add: vector_sneg_minus1[symmetric])
- apply (rule exI[where x=0], simp)
- done
-
-lemma collinear_lemma: "collinear {(0::real^'n),x,y} \<longleftrightarrow> x = 0 \<or> y = 0 \<or> (\<exists>c. y = c *s x)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume "x=0 \<or> y = 0" hence ?thesis
- by (cases "x = 0", simp_all add: collinear_2 insert_commute)}
- moreover
- {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
- {assume h: "?lhs"
- then obtain u where u: "\<forall> x\<in> {0,x,y}. \<forall>y\<in> {0,x,y}. \<exists>c. x - y = c *s u" unfolding collinear_def by blast
- from u[rule_format, of x 0] u[rule_format, of y 0]
- obtain cx and cy where
- cx: "x = cx*s u" and cy: "y = cy*s u"
- by auto
- from cx x have cx0: "cx \<noteq> 0" by auto
- from cy y have cy0: "cy \<noteq> 0" by auto
- let ?d = "cy / cx"
- from cx cy cx0 have "y = ?d *s x"
- by (simp add: vector_smult_assoc)
- hence ?rhs using x y by blast}
- moreover
- {assume h: "?rhs"
- then obtain c where c: "y = c*s x" using x y by blast
- have ?lhs unfolding collinear_def c
- apply (rule exI[where x=x])
- apply auto
- apply (rule exI[where x="- 1"], simp only: vector_smult_lneg vector_smult_lid)
- apply (rule exI[where x= "-c"], simp only: vector_smult_lneg)
- apply (rule exI[where x=1], simp)
- apply (rule exI[where x="1 - c"], simp add: vector_smult_lneg vector_sub_rdistrib)
- apply (rule exI[where x="c - 1"], simp add: vector_smult_lneg vector_sub_rdistrib)
- done}
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma norm_cauchy_schwarz_equal:
- fixes x y :: "real ^ 'n::finite"
- shows "abs(x \<bullet> y) = norm x * norm y \<longleftrightarrow> collinear {(0::real^'n),x,y}"
-unfolding norm_cauchy_schwarz_abs_eq
-apply (cases "x=0", simp_all add: collinear_2)
-apply (cases "y=0", simp_all add: collinear_2 insert_commute)
-unfolding collinear_lemma
-apply simp
-apply (subgoal_tac "norm x \<noteq> 0")
-apply (subgoal_tac "norm y \<noteq> 0")
-apply (rule iffI)
-apply (cases "norm x *s y = norm y *s x")
-apply (rule exI[where x="(1/norm x) * norm y"])
-apply (drule sym)
-unfolding vector_smult_assoc[symmetric]
-apply (simp add: vector_smult_assoc field_simps)
-apply (rule exI[where x="(1/norm x) * - norm y"])
-apply clarify
-apply (drule sym)
-unfolding vector_smult_assoc[symmetric]
-apply (simp add: vector_smult_assoc field_simps)
-apply (erule exE)
-apply (erule ssubst)
-unfolding vector_smult_assoc
-unfolding norm_mul
-apply (subgoal_tac "norm x * c = \<bar>c\<bar> * norm x \<or> norm x * c = - \<bar>c\<bar> * norm x")
-apply (case_tac "c <= 0", simp add: ring_simps)
-apply (simp add: ring_simps)
-apply (case_tac "c <= 0", simp add: ring_simps)
-apply (simp add: ring_simps)
-apply simp
-apply simp
-done
-
-end--- a/src/HOL/Library/Executable_Set.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Library/Executable_Set.thy Tue Oct 27 14:46:03 2009 +0000
@@ -5,7 +5,7 @@
header {* Implementation of finite sets by lists *}
theory Executable_Set
-imports Main Fset
+imports Main Fset SML_Quickcheck
begin
subsection {* Preprocessor setup *}--- a/src/HOL/Library/Fin_Fun.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1599 +0,0 @@
-
-(* Author: Andreas Lochbihler, Uni Karlsruhe *)
-
-header {* Almost everywhere constant functions *}
-
-theory Fin_Fun
-imports Main Infinite_Set Enum
-begin
-
-text {*
- This theory defines functions which are constant except for finitely
- many points (FinFun) and introduces a type finfin along with a
- number of operators for them. The code generator is set up such that
- such functions can be represented as data in the generated code and
- all operators are executable.
-
- For details, see Formalising FinFuns - Generating Code for Functions as Data by A. Lochbihler in TPHOLs 2009.
-*}
-
-
-subsection {* The @{text "map_default"} operation *}
-
-definition map_default :: "'b \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
-where "map_default b f a \<equiv> case f a of None \<Rightarrow> b | Some b' \<Rightarrow> b'"
-
-lemma map_default_delete [simp]:
- "map_default b (f(a := None)) = (map_default b f)(a := b)"
-by(simp add: map_default_def expand_fun_eq)
-
-lemma map_default_insert:
- "map_default b (f(a \<mapsto> b')) = (map_default b f)(a := b')"
-by(simp add: map_default_def expand_fun_eq)
-
-lemma map_default_empty [simp]: "map_default b empty = (\<lambda>a. b)"
-by(simp add: expand_fun_eq map_default_def)
-
-lemma map_default_inject:
- fixes g g' :: "'a \<rightharpoonup> 'b"
- assumes infin_eq: "\<not> finite (UNIV :: 'a set) \<or> b = b'"
- and fin: "finite (dom g)" and b: "b \<notin> ran g"
- and fin': "finite (dom g')" and b': "b' \<notin> ran g'"
- and eq': "map_default b g = map_default b' g'"
- shows "b = b'" "g = g'"
-proof -
- from infin_eq show bb': "b = b'"
- proof
- assume infin: "\<not> finite (UNIV :: 'a set)"
- from fin fin' have "finite (dom g \<union> dom g')" by auto
- with infin have "UNIV - (dom g \<union> dom g') \<noteq> {}" by(auto dest: finite_subset)
- then obtain a where a: "a \<notin> dom g \<union> dom g'" by auto
- hence "map_default b g a = b" "map_default b' g' a = b'" by(auto simp add: map_default_def)
- with eq' show "b = b'" by simp
- qed
-
- show "g = g'"
- proof
- fix x
- show "g x = g' x"
- proof(cases "g x")
- case None
- hence "map_default b g x = b" by(simp add: map_default_def)
- with bb' eq' have "map_default b' g' x = b'" by simp
- with b' have "g' x = None" by(simp add: map_default_def ran_def split: option.split_asm)
- with None show ?thesis by simp
- next
- case (Some c)
- with b have cb: "c \<noteq> b" by(auto simp add: ran_def)
- moreover from Some have "map_default b g x = c" by(simp add: map_default_def)
- with eq' have "map_default b' g' x = c" by simp
- ultimately have "g' x = Some c" using b' bb' by(auto simp add: map_default_def split: option.splits)
- with Some show ?thesis by simp
- qed
- qed
-qed
-
-subsection {* The finfun type *}
-
-typedef ('a,'b) finfun = "{f::'a\<Rightarrow>'b. \<exists>b. finite {a. f a \<noteq> b}}"
-proof -
- have "\<exists>f. finite {x. f x \<noteq> undefined}"
- proof
- show "finite {x. (\<lambda>y. undefined) x \<noteq> undefined}" by auto
- qed
- then show ?thesis by auto
-qed
-
-syntax
- "finfun" :: "type \<Rightarrow> type \<Rightarrow> type" ("(_ \<Rightarrow>\<^isub>f /_)" [22, 21] 21)
-
-lemma fun_upd_finfun: "y(a := b) \<in> finfun \<longleftrightarrow> y \<in> finfun"
-proof -
- { fix b'
- have "finite {a'. (y(a := b)) a' \<noteq> b'} = finite {a'. y a' \<noteq> b'}"
- proof(cases "b = b'")
- case True
- hence "{a'. (y(a := b)) a' \<noteq> b'} = {a'. y a' \<noteq> b'} - {a}" by auto
- thus ?thesis by simp
- next
- case False
- hence "{a'. (y(a := b)) a' \<noteq> b'} = insert a {a'. y a' \<noteq> b'}" by auto
- thus ?thesis by simp
- qed }
- thus ?thesis unfolding finfun_def by blast
-qed
-
-lemma const_finfun: "(\<lambda>x. a) \<in> finfun"
-by(auto simp add: finfun_def)
-
-lemma finfun_left_compose:
- assumes "y \<in> finfun"
- shows "g \<circ> y \<in> finfun"
-proof -
- from assms obtain b where "finite {a. y a \<noteq> b}"
- unfolding finfun_def by blast
- hence "finite {c. g (y c) \<noteq> g b}"
- proof(induct x\<equiv>"{a. y a \<noteq> b}" arbitrary: y)
- case empty
- hence "y = (\<lambda>a. b)" by(auto intro: ext)
- thus ?case by(simp)
- next
- case (insert x F)
- note IH = `\<And>y. F = {a. y a \<noteq> b} \<Longrightarrow> finite {c. g (y c) \<noteq> g b}`
- from `insert x F = {a. y a \<noteq> b}` `x \<notin> F`
- have F: "F = {a. (y(x := b)) a \<noteq> b}" by(auto)
- show ?case
- proof(cases "g (y x) = g b")
- case True
- hence "{c. g ((y(x := b)) c) \<noteq> g b} = {c. g (y c) \<noteq> g b}" by auto
- with IH[OF F] show ?thesis by simp
- next
- case False
- hence "{c. g (y c) \<noteq> g b} = insert x {c. g ((y(x := b)) c) \<noteq> g b}" by auto
- with IH[OF F] show ?thesis by(simp)
- qed
- qed
- thus ?thesis unfolding finfun_def by auto
-qed
-
-lemma assumes "y \<in> finfun"
- shows fst_finfun: "fst \<circ> y \<in> finfun"
- and snd_finfun: "snd \<circ> y \<in> finfun"
-proof -
- from assms obtain b c where bc: "finite {a. y a \<noteq> (b, c)}"
- unfolding finfun_def by auto
- have "{a. fst (y a) \<noteq> b} \<subseteq> {a. y a \<noteq> (b, c)}"
- and "{a. snd (y a) \<noteq> c} \<subseteq> {a. y a \<noteq> (b, c)}" by auto
- hence "finite {a. fst (y a) \<noteq> b}"
- and "finite {a. snd (y a) \<noteq> c}" using bc by(auto intro: finite_subset)
- thus "fst \<circ> y \<in> finfun" "snd \<circ> y \<in> finfun"
- unfolding finfun_def by auto
-qed
-
-lemma map_of_finfun: "map_of xs \<in> finfun"
-unfolding finfun_def
-by(induct xs)(auto simp add: Collect_neg_eq Collect_conj_eq Collect_imp_eq intro: finite_subset)
-
-lemma Diag_finfun: "(\<lambda>x. (f x, g x)) \<in> finfun \<longleftrightarrow> f \<in> finfun \<and> g \<in> finfun"
-by(auto intro: finite_subset simp add: Collect_neg_eq Collect_imp_eq Collect_conj_eq finfun_def)
-
-lemma finfun_right_compose:
- assumes g: "g \<in> finfun" and inj: "inj f"
- shows "g o f \<in> finfun"
-proof -
- from g obtain b where b: "finite {a. g a \<noteq> b}" unfolding finfun_def by blast
- moreover have "f ` {a. g (f a) \<noteq> b} \<subseteq> {a. g a \<noteq> b}" by auto
- moreover from inj have "inj_on f {a. g (f a) \<noteq> b}" by(rule subset_inj_on) blast
- ultimately have "finite {a. g (f a) \<noteq> b}"
- by(blast intro: finite_imageD[where f=f] finite_subset)
- thus ?thesis unfolding finfun_def by auto
-qed
-
-lemma finfun_curry:
- assumes fin: "f \<in> finfun"
- shows "curry f \<in> finfun" "curry f a \<in> finfun"
-proof -
- from fin obtain c where c: "finite {ab. f ab \<noteq> c}" unfolding finfun_def by blast
- moreover have "{a. \<exists>b. f (a, b) \<noteq> c} = fst ` {ab. f ab \<noteq> c}" by(force)
- hence "{a. curry f a \<noteq> (\<lambda>b. c)} = fst ` {ab. f ab \<noteq> c}"
- by(auto simp add: curry_def expand_fun_eq)
- ultimately have "finite {a. curry f a \<noteq> (\<lambda>b. c)}" by simp
- thus "curry f \<in> finfun" unfolding finfun_def by blast
-
- have "snd ` {ab. f ab \<noteq> c} = {b. \<exists>a. f (a, b) \<noteq> c}" by(force)
- hence "{b. f (a, b) \<noteq> c} \<subseteq> snd ` {ab. f ab \<noteq> c}" by auto
- hence "finite {b. f (a, b) \<noteq> c}" by(rule finite_subset)(rule finite_imageI[OF c])
- thus "curry f a \<in> finfun" unfolding finfun_def by auto
-qed
-
-lemmas finfun_simp =
- fst_finfun snd_finfun Abs_finfun_inverse Rep_finfun_inverse Abs_finfun_inject Rep_finfun_inject Diag_finfun finfun_curry
-lemmas finfun_iff = const_finfun fun_upd_finfun Rep_finfun map_of_finfun
-lemmas finfun_intro = finfun_left_compose fst_finfun snd_finfun
-
-lemma Abs_finfun_inject_finite:
- fixes x y :: "'a \<Rightarrow> 'b"
- assumes fin: "finite (UNIV :: 'a set)"
- shows "Abs_finfun x = Abs_finfun y \<longleftrightarrow> x = y"
-proof
- assume "Abs_finfun x = Abs_finfun y"
- moreover have "x \<in> finfun" "y \<in> finfun" unfolding finfun_def
- by(auto intro: finite_subset[OF _ fin])
- ultimately show "x = y" by(simp add: Abs_finfun_inject)
-qed simp
-
-lemma Abs_finfun_inject_finite_class:
- fixes x y :: "('a :: finite) \<Rightarrow> 'b"
- shows "Abs_finfun x = Abs_finfun y \<longleftrightarrow> x = y"
-using finite_UNIV
-by(simp add: Abs_finfun_inject_finite)
-
-lemma Abs_finfun_inj_finite:
- assumes fin: "finite (UNIV :: 'a set)"
- shows "inj (Abs_finfun :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b)"
-proof(rule inj_onI)
- fix x y :: "'a \<Rightarrow> 'b"
- assume "Abs_finfun x = Abs_finfun y"
- moreover have "x \<in> finfun" "y \<in> finfun" unfolding finfun_def
- by(auto intro: finite_subset[OF _ fin])
- ultimately show "x = y" by(simp add: Abs_finfun_inject)
-qed
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma Abs_finfun_inverse_finite:
- fixes x :: "'a \<Rightarrow> 'b"
- assumes fin: "finite (UNIV :: 'a set)"
- shows "Rep_finfun (Abs_finfun x) = x"
-proof -
- from fin have "x \<in> finfun"
- by(auto simp add: finfun_def intro: finite_subset)
- thus ?thesis by simp
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma Abs_finfun_inverse_finite_class:
- fixes x :: "('a :: finite) \<Rightarrow> 'b"
- shows "Rep_finfun (Abs_finfun x) = x"
-using finite_UNIV by(simp add: Abs_finfun_inverse_finite)
-
-lemma finfun_eq_finite_UNIV: "finite (UNIV :: 'a set) \<Longrightarrow> (finfun :: ('a \<Rightarrow> 'b) set) = UNIV"
-unfolding finfun_def by(auto intro: finite_subset)
-
-lemma finfun_finite_UNIV_class: "finfun = (UNIV :: ('a :: finite \<Rightarrow> 'b) set)"
-by(simp add: finfun_eq_finite_UNIV)
-
-lemma map_default_in_finfun:
- assumes fin: "finite (dom f)"
- shows "map_default b f \<in> finfun"
-unfolding finfun_def
-proof(intro CollectI exI)
- from fin show "finite {a. map_default b f a \<noteq> b}"
- by(auto simp add: map_default_def dom_def Collect_conj_eq split: option.splits)
-qed
-
-lemma finfun_cases_map_default:
- obtains b g where "f = Abs_finfun (map_default b g)" "finite (dom g)" "b \<notin> ran g"
-proof -
- obtain y where f: "f = Abs_finfun y" and y: "y \<in> finfun" by(cases f)
- from y obtain b where b: "finite {a. y a \<noteq> b}" unfolding finfun_def by auto
- let ?g = "(\<lambda>a. if y a = b then None else Some (y a))"
- have "map_default b ?g = y" by(simp add: expand_fun_eq map_default_def)
- with f have "f = Abs_finfun (map_default b ?g)" by simp
- moreover from b have "finite (dom ?g)" by(auto simp add: dom_def)
- moreover have "b \<notin> ran ?g" by(auto simp add: ran_def)
- ultimately show ?thesis by(rule that)
-qed
-
-
-subsection {* Kernel functions for type @{typ "'a \<Rightarrow>\<^isub>f 'b"} *}
-
-definition finfun_const :: "'b \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b" ("\<lambda>\<^isup>f/ _" [0] 1)
-where [code del]: "(\<lambda>\<^isup>f b) = Abs_finfun (\<lambda>x. b)"
-
-definition finfun_update :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b" ("_'(\<^sup>f/ _ := _')" [1000,0,0] 1000)
-where [code del]: "f(\<^sup>fa := b) = Abs_finfun ((Rep_finfun f)(a := b))"
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_update_twist: "a \<noteq> a' \<Longrightarrow> f(\<^sup>f a := b)(\<^sup>f a' := b') = f(\<^sup>f a' := b')(\<^sup>f a := b)"
-by(simp add: finfun_update_def fun_upd_twist)
-
-lemma finfun_update_twice [simp]:
- "finfun_update (finfun_update f a b) a b' = finfun_update f a b'"
-by(simp add: finfun_update_def)
-
-lemma finfun_update_const_same: "(\<lambda>\<^isup>f b)(\<^sup>f a := b) = (\<lambda>\<^isup>f b)"
-by(simp add: finfun_update_def finfun_const_def expand_fun_eq)
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-subsection {* Code generator setup *}
-
-definition finfun_update_code :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b" ("_'(\<^sup>f\<^sup>c/ _ := _')" [1000,0,0] 1000)
-where [simp, code del]: "finfun_update_code = finfun_update"
-
-code_datatype finfun_const finfun_update_code
-
-lemma finfun_update_const_code [code]:
- "(\<lambda>\<^isup>f b)(\<^sup>f a := b') = (if b = b' then (\<lambda>\<^isup>f b) else finfun_update_code (\<lambda>\<^isup>f b) a b')"
-by(simp add: finfun_update_const_same)
-
-lemma finfun_update_update_code [code]:
- "(finfun_update_code f a b)(\<^sup>f a' := b') = (if a = a' then f(\<^sup>f a := b') else finfun_update_code (f(\<^sup>f a' := b')) a b)"
-by(simp add: finfun_update_twist)
-
-
-subsection {* Setup for quickcheck *}
-
-notation fcomp (infixl "o>" 60)
-notation scomp (infixl "o\<rightarrow>" 60)
-
-definition (in term_syntax) valtermify_finfun_const ::
- "'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a\<Colon>typerep \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
- "valtermify_finfun_const y = Code_Evaluation.valtermify finfun_const {\<cdot>} y"
-
-definition (in term_syntax) valtermify_finfun_update_code ::
- "'a\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> 'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
- "valtermify_finfun_update_code x y f = Code_Evaluation.valtermify finfun_update_code {\<cdot>} f {\<cdot>} x {\<cdot>} y"
-
-instantiation finfun :: (random, random) random
-begin
-
-primrec random_finfun_aux :: "code_numeral \<Rightarrow> code_numeral \<Rightarrow> Random.seed \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed" where
- "random_finfun_aux 0 j = Quickcheck.collapse (Random.select_weight
- [(1, Quickcheck.random j o\<rightarrow> (\<lambda>y. Pair (valtermify_finfun_const y)))])"
- | "random_finfun_aux (Suc_code_numeral i) j = Quickcheck.collapse (Random.select_weight
- [(Suc_code_numeral i, Quickcheck.random j o\<rightarrow> (\<lambda>x. Quickcheck.random j o\<rightarrow> (\<lambda>y. random_finfun_aux i j o\<rightarrow> (\<lambda>f. Pair (valtermify_finfun_update_code x y f))))),
- (1, Quickcheck.random j o\<rightarrow> (\<lambda>y. Pair (valtermify_finfun_const y)))])"
-
-definition
- "Quickcheck.random i = random_finfun_aux i i"
-
-instance ..
-
-end
-
-lemma random_finfun_aux_code [code]:
- "random_finfun_aux i j = Quickcheck.collapse (Random.select_weight
- [(i, Quickcheck.random j o\<rightarrow> (\<lambda>x. Quickcheck.random j o\<rightarrow> (\<lambda>y. random_finfun_aux (i - 1) j o\<rightarrow> (\<lambda>f. Pair (valtermify_finfun_update_code x y f))))),
- (1, Quickcheck.random j o\<rightarrow> (\<lambda>y. Pair (valtermify_finfun_const y)))])"
- apply (cases i rule: code_numeral.exhaust)
- apply (simp_all only: random_finfun_aux.simps code_numeral_zero_minus_one Suc_code_numeral_minus_one)
- apply (subst select_weight_cons_zero) apply (simp only:)
- done
-
-no_notation fcomp (infixl "o>" 60)
-no_notation scomp (infixl "o\<rightarrow>" 60)
-
-
-subsection {* @{text "finfun_update"} as instance of @{text "fun_left_comm"} *}
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-interpretation finfun_update: fun_left_comm "\<lambda>a f. f(\<^sup>f a :: 'a := b')"
-proof
- fix a' a :: 'a
- fix b
- have "(Rep_finfun b)(a := b', a' := b') = (Rep_finfun b)(a' := b', a := b')"
- by(cases "a = a'")(auto simp add: fun_upd_twist)
- thus "b(\<^sup>f a := b')(\<^sup>f a' := b') = b(\<^sup>f a' := b')(\<^sup>f a := b')"
- by(auto simp add: finfun_update_def fun_upd_twist)
-qed
-
-lemma fold_finfun_update_finite_univ:
- assumes fin: "finite (UNIV :: 'a set)"
- shows "fold (\<lambda>a f. f(\<^sup>f a := b')) (\<lambda>\<^isup>f b) (UNIV :: 'a set) = (\<lambda>\<^isup>f b')"
-proof -
- { fix A :: "'a set"
- from fin have "finite A" by(auto intro: finite_subset)
- hence "fold (\<lambda>a f. f(\<^sup>f a := b')) (\<lambda>\<^isup>f b) A = Abs_finfun (\<lambda>a. if a \<in> A then b' else b)"
- proof(induct)
- case (insert x F)
- have "(\<lambda>a. if a = x then b' else (if a \<in> F then b' else b)) = (\<lambda>a. if a = x \<or> a \<in> F then b' else b)"
- by(auto intro: ext)
- with insert show ?case
- by(simp add: finfun_const_def fun_upd_def)(simp add: finfun_update_def Abs_finfun_inverse_finite[OF fin] fun_upd_def)
- qed(simp add: finfun_const_def) }
- thus ?thesis by(simp add: finfun_const_def)
-qed
-
-
-subsection {* Default value for FinFuns *}
-
-definition finfun_default_aux :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"
-where [code del]: "finfun_default_aux f = (if finite (UNIV :: 'a set) then undefined else THE b. finite {a. f a \<noteq> b})"
-
-lemma finfun_default_aux_infinite:
- fixes f :: "'a \<Rightarrow> 'b"
- assumes infin: "infinite (UNIV :: 'a set)"
- and fin: "finite {a. f a \<noteq> b}"
- shows "finfun_default_aux f = b"
-proof -
- let ?B = "{a. f a \<noteq> b}"
- from fin have "(THE b. finite {a. f a \<noteq> b}) = b"
- proof(rule the_equality)
- fix b'
- assume "finite {a. f a \<noteq> b'}" (is "finite ?B'")
- with infin fin have "UNIV - (?B' \<union> ?B) \<noteq> {}" by(auto dest: finite_subset)
- then obtain a where a: "a \<notin> ?B' \<union> ?B" by auto
- thus "b' = b" by auto
- qed
- thus ?thesis using infin by(simp add: finfun_default_aux_def)
-qed
-
-
-lemma finite_finfun_default_aux:
- fixes f :: "'a \<Rightarrow> 'b"
- assumes fin: "f \<in> finfun"
- shows "finite {a. f a \<noteq> finfun_default_aux f}"
-proof(cases "finite (UNIV :: 'a set)")
- case True thus ?thesis using fin
- by(auto simp add: finfun_def finfun_default_aux_def intro: finite_subset)
-next
- case False
- from fin obtain b where b: "finite {a. f a \<noteq> b}" (is "finite ?B")
- unfolding finfun_def by blast
- with False show ?thesis by(simp add: finfun_default_aux_infinite)
-qed
-
-lemma finfun_default_aux_update_const:
- fixes f :: "'a \<Rightarrow> 'b"
- assumes fin: "f \<in> finfun"
- shows "finfun_default_aux (f(a := b)) = finfun_default_aux f"
-proof(cases "finite (UNIV :: 'a set)")
- case False
- from fin obtain b' where b': "finite {a. f a \<noteq> b'}" unfolding finfun_def by blast
- hence "finite {a'. (f(a := b)) a' \<noteq> b'}"
- proof(cases "b = b' \<and> f a \<noteq> b'")
- case True
- hence "{a. f a \<noteq> b'} = insert a {a'. (f(a := b)) a' \<noteq> b'}" by auto
- thus ?thesis using b' by simp
- next
- case False
- moreover
- { assume "b \<noteq> b'"
- hence "{a'. (f(a := b)) a' \<noteq> b'} = insert a {a. f a \<noteq> b'}" by auto
- hence ?thesis using b' by simp }
- moreover
- { assume "b = b'" "f a = b'"
- hence "{a'. (f(a := b)) a' \<noteq> b'} = {a. f a \<noteq> b'}" by auto
- hence ?thesis using b' by simp }
- ultimately show ?thesis by blast
- qed
- with False b' show ?thesis by(auto simp del: fun_upd_apply simp add: finfun_default_aux_infinite)
-next
- case True thus ?thesis by(simp add: finfun_default_aux_def)
-qed
-
-definition finfun_default :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'b"
- where [code del]: "finfun_default f = finfun_default_aux (Rep_finfun f)"
-
-lemma finite_finfun_default: "finite {a. Rep_finfun f a \<noteq> finfun_default f}"
-unfolding finfun_default_def by(simp add: finite_finfun_default_aux)
-
-lemma finfun_default_const: "finfun_default ((\<lambda>\<^isup>f b) :: 'a \<Rightarrow>\<^isub>f 'b) = (if finite (UNIV :: 'a set) then undefined else b)"
-apply(auto simp add: finfun_default_def finfun_const_def finfun_default_aux_infinite)
-apply(simp add: finfun_default_aux_def)
-done
-
-lemma finfun_default_update_const:
- "finfun_default (f(\<^sup>f a := b)) = finfun_default f"
-unfolding finfun_default_def finfun_update_def
-by(simp add: finfun_default_aux_update_const)
-
-subsection {* Recursion combinator and well-formedness conditions *}
-
-definition finfun_rec :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<Rightarrow> 'c"
-where [code del]:
- "finfun_rec cnst upd f \<equiv>
- let b = finfun_default f;
- g = THE g. f = Abs_finfun (map_default b g) \<and> finite (dom g) \<and> b \<notin> ran g
- in fold (\<lambda>a. upd a (map_default b g a)) (cnst b) (dom g)"
-
-locale finfun_rec_wf_aux =
- fixes cnst :: "'b \<Rightarrow> 'c"
- and upd :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c"
- assumes upd_const_same: "upd a b (cnst b) = cnst b"
- and upd_commute: "a \<noteq> a' \<Longrightarrow> upd a b (upd a' b' c) = upd a' b' (upd a b c)"
- and upd_idemp: "b \<noteq> b' \<Longrightarrow> upd a b'' (upd a b' (cnst b)) = upd a b'' (cnst b)"
-begin
-
-
-lemma upd_left_comm: "fun_left_comm (\<lambda>a. upd a (f a))"
-by(unfold_locales)(auto intro: upd_commute)
-
-lemma upd_upd_twice: "upd a b'' (upd a b' (cnst b)) = upd a b'' (cnst b)"
-by(cases "b \<noteq> b'")(auto simp add: fun_upd_def upd_const_same upd_idemp)
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma map_default_update_const:
- assumes fin: "finite (dom f)"
- and anf: "a \<notin> dom f"
- and fg: "f \<subseteq>\<^sub>m g"
- shows "upd a d (fold (\<lambda>a. upd a (map_default d g a)) (cnst d) (dom f)) =
- fold (\<lambda>a. upd a (map_default d g a)) (cnst d) (dom f)"
-proof -
- let ?upd = "\<lambda>a. upd a (map_default d g a)"
- let ?fr = "\<lambda>A. fold ?upd (cnst d) A"
- interpret gwf: fun_left_comm "?upd" by(rule upd_left_comm)
-
- from fin anf fg show ?thesis
- proof(induct A\<equiv>"dom f" arbitrary: f)
- case empty
- from `{} = dom f` have "f = empty" by(auto simp add: dom_def intro: ext)
- thus ?case by(simp add: finfun_const_def upd_const_same)
- next
- case (insert a' A)
- note IH = `\<And>f. \<lbrakk> a \<notin> dom f; f \<subseteq>\<^sub>m g; A = dom f\<rbrakk> \<Longrightarrow> upd a d (?fr (dom f)) = ?fr (dom f)`
- note fin = `finite A` note anf = `a \<notin> dom f` note a'nA = `a' \<notin> A`
- note domf = `insert a' A = dom f` note fg = `f \<subseteq>\<^sub>m g`
-
- from domf obtain b where b: "f a' = Some b" by auto
- let ?f' = "f(a' := None)"
- have "upd a d (?fr (insert a' A)) = upd a d (upd a' (map_default d g a') (?fr A))"
- by(subst gwf.fold_insert[OF fin a'nA]) rule
- also from b fg have "g a' = f a'" by(auto simp add: map_le_def intro: domI dest: bspec)
- hence ga': "map_default d g a' = map_default d f a'" by(simp add: map_default_def)
- also from anf domf have "a \<noteq> a'" by auto note upd_commute[OF this]
- also from domf a'nA anf fg have "a \<notin> dom ?f'" "?f' \<subseteq>\<^sub>m g" and A: "A = dom ?f'" by(auto simp add: ran_def map_le_def)
- note A also note IH[OF `a \<notin> dom ?f'` `?f' \<subseteq>\<^sub>m g` A]
- also have "upd a' (map_default d f a') (?fr (dom (f(a' := None)))) = ?fr (dom f)"
- unfolding domf[symmetric] gwf.fold_insert[OF fin a'nA] ga' unfolding A ..
- also have "insert a' (dom ?f') = dom f" using domf by auto
- finally show ?case .
- qed
-qed
-
-lemma map_default_update_twice:
- assumes fin: "finite (dom f)"
- and anf: "a \<notin> dom f"
- and fg: "f \<subseteq>\<^sub>m g"
- shows "upd a d'' (upd a d' (fold (\<lambda>a. upd a (map_default d g a)) (cnst d) (dom f))) =
- upd a d'' (fold (\<lambda>a. upd a (map_default d g a)) (cnst d) (dom f))"
-proof -
- let ?upd = "\<lambda>a. upd a (map_default d g a)"
- let ?fr = "\<lambda>A. fold ?upd (cnst d) A"
- interpret gwf: fun_left_comm "?upd" by(rule upd_left_comm)
-
- from fin anf fg show ?thesis
- proof(induct A\<equiv>"dom f" arbitrary: f)
- case empty
- from `{} = dom f` have "f = empty" by(auto simp add: dom_def intro: ext)
- thus ?case by(auto simp add: finfun_const_def finfun_update_def upd_upd_twice)
- next
- case (insert a' A)
- note IH = `\<And>f. \<lbrakk>a \<notin> dom f; f \<subseteq>\<^sub>m g; A = dom f\<rbrakk> \<Longrightarrow> upd a d'' (upd a d' (?fr (dom f))) = upd a d'' (?fr (dom f))`
- note fin = `finite A` note anf = `a \<notin> dom f` note a'nA = `a' \<notin> A`
- note domf = `insert a' A = dom f` note fg = `f \<subseteq>\<^sub>m g`
-
- from domf obtain b where b: "f a' = Some b" by auto
- let ?f' = "f(a' := None)"
- let ?b' = "case f a' of None \<Rightarrow> d | Some b \<Rightarrow> b"
- from domf have "upd a d'' (upd a d' (?fr (dom f))) = upd a d'' (upd a d' (?fr (insert a' A)))" by simp
- also note gwf.fold_insert[OF fin a'nA]
- also from b fg have "g a' = f a'" by(auto simp add: map_le_def intro: domI dest: bspec)
- hence ga': "map_default d g a' = map_default d f a'" by(simp add: map_default_def)
- also from anf domf have ana': "a \<noteq> a'" by auto note upd_commute[OF this]
- also note upd_commute[OF ana']
- also from domf a'nA anf fg have "a \<notin> dom ?f'" "?f' \<subseteq>\<^sub>m g" and A: "A = dom ?f'" by(auto simp add: ran_def map_le_def)
- note A also note IH[OF `a \<notin> dom ?f'` `?f' \<subseteq>\<^sub>m g` A]
- also note upd_commute[OF ana'[symmetric]] also note ga'[symmetric] also note A[symmetric]
- also note gwf.fold_insert[symmetric, OF fin a'nA] also note domf
- finally show ?case .
- qed
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma map_default_eq_id [simp]: "map_default d ((\<lambda>a. Some (f a)) |` {a. f a \<noteq> d}) = f"
-by(auto simp add: map_default_def restrict_map_def intro: ext)
-
-lemma finite_rec_cong1:
- assumes f: "fun_left_comm f" and g: "fun_left_comm g"
- and fin: "finite A"
- and eq: "\<And>a. a \<in> A \<Longrightarrow> f a = g a"
- shows "fold f z A = fold g z A"
-proof -
- interpret f: fun_left_comm f by(rule f)
- interpret g: fun_left_comm g by(rule g)
- { fix B
- assume BsubA: "B \<subseteq> A"
- with fin have "finite B" by(blast intro: finite_subset)
- hence "B \<subseteq> A \<Longrightarrow> fold f z B = fold g z B"
- proof(induct)
- case empty thus ?case by simp
- next
- case (insert a B)
- note finB = `finite B` note anB = `a \<notin> B` note sub = `insert a B \<subseteq> A`
- note IH = `B \<subseteq> A \<Longrightarrow> fold f z B = fold g z B`
- from sub anB have BpsubA: "B \<subset> A" and BsubA: "B \<subseteq> A" and aA: "a \<in> A" by auto
- from IH[OF BsubA] eq[OF aA] finB anB
- show ?case by(auto)
- qed
- with BsubA have "fold f z B = fold g z B" by blast }
- thus ?thesis by blast
-qed
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_rec_upd [simp]:
- "finfun_rec cnst upd (f(\<^sup>f a' := b')) = upd a' b' (finfun_rec cnst upd f)"
-proof -
- obtain b where b: "b = finfun_default f" by auto
- let ?the = "\<lambda>f g. f = Abs_finfun (map_default b g) \<and> finite (dom g) \<and> b \<notin> ran g"
- obtain g where g: "g = The (?the f)" by blast
- obtain y where f: "f = Abs_finfun y" and y: "y \<in> finfun" by (cases f)
- from f y b have bfin: "finite {a. y a \<noteq> b}" by(simp add: finfun_default_def finite_finfun_default_aux)
-
- let ?g = "(\<lambda>a. Some (y a)) |` {a. y a \<noteq> b}"
- from bfin have fing: "finite (dom ?g)" by auto
- have bran: "b \<notin> ran ?g" by(auto simp add: ran_def restrict_map_def)
- have yg: "y = map_default b ?g" by simp
- have gg: "g = ?g" unfolding g
- proof(rule the_equality)
- from f y bfin show "?the f ?g"
- by(auto)(simp add: restrict_map_def ran_def split: split_if_asm)
- next
- fix g'
- assume "?the f g'"
- hence fin': "finite (dom g')" and ran': "b \<notin> ran g'"
- and eq: "Abs_finfun (map_default b ?g) = Abs_finfun (map_default b g')" using f yg by auto
- from fin' fing have "map_default b ?g \<in> finfun" "map_default b g' \<in> finfun" by(blast intro: map_default_in_finfun)+
- with eq have "map_default b ?g = map_default b g'" by simp
- with fing bran fin' ran' show "g' = ?g" by(rule map_default_inject[OF disjI2[OF refl], THEN sym])
- qed
-
- show ?thesis
- proof(cases "b' = b")
- case True
- note b'b = True
-
- let ?g' = "(\<lambda>a. Some ((y(a' := b)) a)) |` {a. (y(a' := b)) a \<noteq> b}"
- from bfin b'b have fing': "finite (dom ?g')"
- by(auto simp add: Collect_conj_eq Collect_imp_eq intro: finite_subset)
- have brang': "b \<notin> ran ?g'" by(auto simp add: ran_def restrict_map_def)
-
- let ?b' = "\<lambda>a. case ?g' a of None \<Rightarrow> b | Some b \<Rightarrow> b"
- let ?b = "map_default b ?g"
- from upd_left_comm upd_left_comm fing'
- have "fold (\<lambda>a. upd a (?b' a)) (cnst b) (dom ?g') = fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g')"
- by(rule finite_rec_cong1)(auto simp add: restrict_map_def b'b b map_default_def)
- also interpret gwf: fun_left_comm "\<lambda>a. upd a (?b a)" by(rule upd_left_comm)
- have "fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g') = upd a' b' (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g))"
- proof(cases "y a' = b")
- case True
- with b'b have g': "?g' = ?g" by(auto simp add: restrict_map_def intro: ext)
- from True have a'ndomg: "a' \<notin> dom ?g" by auto
- from f b'b b show ?thesis unfolding g'
- by(subst map_default_update_const[OF fing a'ndomg map_le_refl, symmetric]) simp
- next
- case False
- hence domg: "dom ?g = insert a' (dom ?g')" by auto
- from False b'b have a'ndomg': "a' \<notin> dom ?g'" by auto
- have "fold (\<lambda>a. upd a (?b a)) (cnst b) (insert a' (dom ?g')) =
- upd a' (?b a') (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g'))"
- using fing' a'ndomg' unfolding b'b by(rule gwf.fold_insert)
- hence "upd a' b (fold (\<lambda>a. upd a (?b a)) (cnst b) (insert a' (dom ?g'))) =
- upd a' b (upd a' (?b a') (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g')))" by simp
- also from b'b have g'leg: "?g' \<subseteq>\<^sub>m ?g" by(auto simp add: restrict_map_def map_le_def)
- note map_default_update_twice[OF fing' a'ndomg' this, of b "?b a'" b]
- also note map_default_update_const[OF fing' a'ndomg' g'leg, of b]
- finally show ?thesis unfolding b'b domg[unfolded b'b] by(rule sym)
- qed
- also have "The (?the (f(\<^sup>f a' := b'))) = ?g'"
- proof(rule the_equality)
- from f y b b'b brang' fing' show "?the (f(\<^sup>f a' := b')) ?g'"
- by(auto simp del: fun_upd_apply simp add: finfun_update_def)
- next
- fix g'
- assume "?the (f(\<^sup>f a' := b')) g'"
- hence fin': "finite (dom g')" and ran': "b \<notin> ran g'"
- and eq: "f(\<^sup>f a' := b') = Abs_finfun (map_default b g')"
- by(auto simp del: fun_upd_apply)
- from fin' fing' have "map_default b g' \<in> finfun" "map_default b ?g' \<in> finfun"
- by(blast intro: map_default_in_finfun)+
- with eq f b'b b have "map_default b ?g' = map_default b g'"
- by(simp del: fun_upd_apply add: finfun_update_def)
- with fing' brang' fin' ran' show "g' = ?g'"
- by(rule map_default_inject[OF disjI2[OF refl], THEN sym])
- qed
- ultimately show ?thesis unfolding finfun_rec_def Let_def b gg[unfolded g b] using bfin b'b b
- by(simp only: finfun_default_update_const map_default_def)
- next
- case False
- note b'b = this
- let ?g' = "?g(a' \<mapsto> b')"
- let ?b' = "map_default b ?g'"
- let ?b = "map_default b ?g"
- from fing have fing': "finite (dom ?g')" by auto
- from bran b'b have bnrang': "b \<notin> ran ?g'" by(auto simp add: ran_def)
- have ffmg': "map_default b ?g' = y(a' := b')" by(auto intro: ext simp add: map_default_def restrict_map_def)
- with f y have f_Abs: "f(\<^sup>f a' := b') = Abs_finfun (map_default b ?g')" by(auto simp add: finfun_update_def)
- have g': "The (?the (f(\<^sup>f a' := b'))) = ?g'"
- proof
- from fing' bnrang' f_Abs show "?the (f(\<^sup>f a' := b')) ?g'" by(auto simp add: finfun_update_def restrict_map_def)
- next
- fix g' assume "?the (f(\<^sup>f a' := b')) g'"
- hence f': "f(\<^sup>f a' := b') = Abs_finfun (map_default b g')"
- and fin': "finite (dom g')" and brang': "b \<notin> ran g'" by auto
- from fing' fin' have "map_default b ?g' \<in> finfun" "map_default b g' \<in> finfun"
- by(auto intro: map_default_in_finfun)
- with f' f_Abs have "map_default b g' = map_default b ?g'" by simp
- with fin' brang' fing' bnrang' show "g' = ?g'"
- by(rule map_default_inject[OF disjI2[OF refl]])
- qed
- have dom: "dom (((\<lambda>a. Some (y a)) |` {a. y a \<noteq> b})(a' \<mapsto> b')) = insert a' (dom ((\<lambda>a. Some (y a)) |` {a. y a \<noteq> b}))"
- by auto
- show ?thesis
- proof(cases "y a' = b")
- case True
- hence a'ndomg: "a' \<notin> dom ?g" by auto
- from f y b'b True have yff: "y = map_default b (?g' |` dom ?g)"
- by(auto simp add: restrict_map_def map_default_def intro!: ext)
- hence f': "f = Abs_finfun (map_default b (?g' |` dom ?g))" using f by simp
- interpret g'wf: fun_left_comm "\<lambda>a. upd a (?b' a)" by(rule upd_left_comm)
- from upd_left_comm upd_left_comm fing
- have "fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g) = fold (\<lambda>a. upd a (?b' a)) (cnst b) (dom ?g)"
- by(rule finite_rec_cong1)(auto simp add: restrict_map_def b'b True map_default_def)
- thus ?thesis unfolding finfun_rec_def Let_def finfun_default_update_const b[symmetric]
- unfolding g' g[symmetric] gg g'wf.fold_insert[OF fing a'ndomg, of "cnst b", folded dom]
- by -(rule arg_cong2[where f="upd a'"], simp_all add: map_default_def)
- next
- case False
- hence "insert a' (dom ?g) = dom ?g" by auto
- moreover {
- let ?g'' = "?g(a' := None)"
- let ?b'' = "map_default b ?g''"
- from False have domg: "dom ?g = insert a' (dom ?g'')" by auto
- from False have a'ndomg'': "a' \<notin> dom ?g''" by auto
- have fing'': "finite (dom ?g'')" by(rule finite_subset[OF _ fing]) auto
- have bnrang'': "b \<notin> ran ?g''" by(auto simp add: ran_def restrict_map_def)
- interpret gwf: fun_left_comm "\<lambda>a. upd a (?b a)" by(rule upd_left_comm)
- interpret g'wf: fun_left_comm "\<lambda>a. upd a (?b' a)" by(rule upd_left_comm)
- have "upd a' b' (fold (\<lambda>a. upd a (?b a)) (cnst b) (insert a' (dom ?g''))) =
- upd a' b' (upd a' (?b a') (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g'')))"
- unfolding gwf.fold_insert[OF fing'' a'ndomg''] f ..
- also have g''leg: "?g |` dom ?g'' \<subseteq>\<^sub>m ?g" by(auto simp add: map_le_def)
- have "dom (?g |` dom ?g'') = dom ?g''" by auto
- note map_default_update_twice[where d=b and f = "?g |` dom ?g''" and a=a' and d'="?b a'" and d''=b' and g="?g",
- unfolded this, OF fing'' a'ndomg'' g''leg]
- also have b': "b' = ?b' a'" by(auto simp add: map_default_def)
- from upd_left_comm upd_left_comm fing''
- have "fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g'') = fold (\<lambda>a. upd a (?b' a)) (cnst b) (dom ?g'')"
- by(rule finite_rec_cong1)(auto simp add: restrict_map_def b'b map_default_def)
- with b' have "upd a' b' (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g'')) =
- upd a' (?b' a') (fold (\<lambda>a. upd a (?b' a)) (cnst b) (dom ?g''))" by simp
- also note g'wf.fold_insert[OF fing'' a'ndomg'', symmetric]
- finally have "upd a' b' (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g)) =
- fold (\<lambda>a. upd a (?b' a)) (cnst b) (dom ?g)"
- unfolding domg . }
- ultimately have "fold (\<lambda>a. upd a (?b' a)) (cnst b) (insert a' (dom ?g)) =
- upd a' b' (fold (\<lambda>a. upd a (?b a)) (cnst b) (dom ?g))" by simp
- thus ?thesis unfolding finfun_rec_def Let_def finfun_default_update_const b[symmetric] g[symmetric] g' dom[symmetric]
- using b'b gg by(simp add: map_default_insert)
- qed
- qed
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-end
-
-locale finfun_rec_wf = finfun_rec_wf_aux +
- assumes const_update_all:
- "finite (UNIV :: 'a set) \<Longrightarrow> fold (\<lambda>a. upd a b') (cnst b) (UNIV :: 'a set) = cnst b'"
-begin
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_rec_const [simp]:
- "finfun_rec cnst upd (\<lambda>\<^isup>f c) = cnst c"
-proof(cases "finite (UNIV :: 'a set)")
- case False
- hence "finfun_default ((\<lambda>\<^isup>f c) :: 'a \<Rightarrow>\<^isub>f 'b) = c" by(simp add: finfun_default_const)
- moreover have "(THE g :: 'a \<rightharpoonup> 'b. (\<lambda>\<^isup>f c) = Abs_finfun (map_default c g) \<and> finite (dom g) \<and> c \<notin> ran g) = empty"
- proof
- show "(\<lambda>\<^isup>f c) = Abs_finfun (map_default c empty) \<and> finite (dom empty) \<and> c \<notin> ran empty"
- by(auto simp add: finfun_const_def)
- next
- fix g :: "'a \<rightharpoonup> 'b"
- assume "(\<lambda>\<^isup>f c) = Abs_finfun (map_default c g) \<and> finite (dom g) \<and> c \<notin> ran g"
- hence g: "(\<lambda>\<^isup>f c) = Abs_finfun (map_default c g)" and fin: "finite (dom g)" and ran: "c \<notin> ran g" by blast+
- from g map_default_in_finfun[OF fin, of c] have "map_default c g = (\<lambda>a. c)"
- by(simp add: finfun_const_def)
- moreover have "map_default c empty = (\<lambda>a. c)" by simp
- ultimately show "g = empty" by-(rule map_default_inject[OF disjI2[OF refl] fin ran], auto)
- qed
- ultimately show ?thesis by(simp add: finfun_rec_def)
-next
- case True
- hence default: "finfun_default ((\<lambda>\<^isup>f c) :: 'a \<Rightarrow>\<^isub>f 'b) = undefined" by(simp add: finfun_default_const)
- let ?the = "\<lambda>g :: 'a \<rightharpoonup> 'b. (\<lambda>\<^isup>f c) = Abs_finfun (map_default undefined g) \<and> finite (dom g) \<and> undefined \<notin> ran g"
- show ?thesis
- proof(cases "c = undefined")
- case True
- have the: "The ?the = empty"
- proof
- from True show "?the empty" by(auto simp add: finfun_const_def)
- next
- fix g'
- assume "?the g'"
- hence fg: "(\<lambda>\<^isup>f c) = Abs_finfun (map_default undefined g')"
- and fin: "finite (dom g')" and g: "undefined \<notin> ran g'" by simp_all
- from fin have "map_default undefined g' \<in> finfun" by(rule map_default_in_finfun)
- with fg have "map_default undefined g' = (\<lambda>a. c)"
- by(auto simp add: finfun_const_def intro: Abs_finfun_inject[THEN iffD1])
- with True show "g' = empty"
- by -(rule map_default_inject(2)[OF _ fin g], auto)
- qed
- show ?thesis unfolding finfun_rec_def using `finite UNIV` True
- unfolding Let_def the default by(simp)
- next
- case False
- have the: "The ?the = (\<lambda>a :: 'a. Some c)"
- proof
- from False True show "?the (\<lambda>a :: 'a. Some c)"
- by(auto simp add: map_default_def_raw finfun_const_def dom_def ran_def)
- next
- fix g' :: "'a \<rightharpoonup> 'b"
- assume "?the g'"
- hence fg: "(\<lambda>\<^isup>f c) = Abs_finfun (map_default undefined g')"
- and fin: "finite (dom g')" and g: "undefined \<notin> ran g'" by simp_all
- from fin have "map_default undefined g' \<in> finfun" by(rule map_default_in_finfun)
- with fg have "map_default undefined g' = (\<lambda>a. c)"
- by(auto simp add: finfun_const_def intro: Abs_finfun_inject[THEN iffD1])
- with True False show "g' = (\<lambda>a::'a. Some c)"
- by -(rule map_default_inject(2)[OF _ fin g], auto simp add: dom_def ran_def map_default_def_raw)
- qed
- show ?thesis unfolding finfun_rec_def using True False
- unfolding Let_def the default by(simp add: dom_def map_default_def const_update_all)
- qed
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-end
-
-subsection {* Weak induction rule and case analysis for FinFuns *}
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_weak_induct [consumes 0, case_names const update]:
- assumes const: "\<And>b. P (\<lambda>\<^isup>f b)"
- and update: "\<And>f a b. P f \<Longrightarrow> P (f(\<^sup>f a := b))"
- shows "P x"
-proof(induct x rule: Abs_finfun_induct)
- case (Abs_finfun y)
- then obtain b where "finite {a. y a \<noteq> b}" unfolding finfun_def by blast
- thus ?case using `y \<in> finfun`
- proof(induct x\<equiv>"{a. y a \<noteq> b}" arbitrary: y rule: finite_induct)
- case empty
- hence "\<And>a. y a = b" by blast
- hence "y = (\<lambda>a. b)" by(auto intro: ext)
- hence "Abs_finfun y = finfun_const b" unfolding finfun_const_def by simp
- thus ?case by(simp add: const)
- next
- case (insert a A)
- note IH = `\<And>y. \<lbrakk> y \<in> finfun; A = {a. y a \<noteq> b} \<rbrakk> \<Longrightarrow> P (Abs_finfun y)`
- note y = `y \<in> finfun`
- with `insert a A = {a. y a \<noteq> b}` `a \<notin> A`
- have "y(a := b) \<in> finfun" "A = {a'. (y(a := b)) a' \<noteq> b}" by auto
- from IH[OF this] have "P (finfun_update (Abs_finfun (y(a := b))) a (y a))" by(rule update)
- thus ?case using y unfolding finfun_update_def by simp
- qed
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma finfun_exhaust_disj: "(\<exists>b. x = finfun_const b) \<or> (\<exists>f a b. x = finfun_update f a b)"
-by(induct x rule: finfun_weak_induct) blast+
-
-lemma finfun_exhaust:
- obtains b where "x = (\<lambda>\<^isup>f b)"
- | f a b where "x = f(\<^sup>f a := b)"
-by(atomize_elim)(rule finfun_exhaust_disj)
-
-lemma finfun_rec_unique:
- fixes f :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'c"
- assumes c: "\<And>c. f (\<lambda>\<^isup>f c) = cnst c"
- and u: "\<And>g a b. f (g(\<^sup>f a := b)) = upd g a b (f g)"
- and c': "\<And>c. f' (\<lambda>\<^isup>f c) = cnst c"
- and u': "\<And>g a b. f' (g(\<^sup>f a := b)) = upd g a b (f' g)"
- shows "f = f'"
-proof
- fix g :: "'a \<Rightarrow>\<^isub>f 'b"
- show "f g = f' g"
- by(induct g rule: finfun_weak_induct)(auto simp add: c u c' u')
-qed
-
-
-subsection {* Function application *}
-
-definition finfun_apply :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'a \<Rightarrow> 'b" ("_\<^sub>f" [1000] 1000)
-where [code del]: "finfun_apply = (\<lambda>f a. finfun_rec (\<lambda>b. b) (\<lambda>a' b c. if (a = a') then b else c) f)"
-
-interpretation finfun_apply_aux: finfun_rec_wf_aux "\<lambda>b. b" "\<lambda>a' b c. if (a = a') then b else c"
-by(unfold_locales) auto
-
-interpretation finfun_apply: finfun_rec_wf "\<lambda>b. b" "\<lambda>a' b c. if (a = a') then b else c"
-proof(unfold_locales)
- fix b' b :: 'a
- assume fin: "finite (UNIV :: 'b set)"
- { fix A :: "'b set"
- interpret fun_left_comm "\<lambda>a'. If (a = a') b'" by(rule finfun_apply_aux.upd_left_comm)
- from fin have "finite A" by(auto intro: finite_subset)
- hence "fold (\<lambda>a'. If (a = a') b') b A = (if a \<in> A then b' else b)"
- by induct auto }
- from this[of UNIV] show "fold (\<lambda>a'. If (a = a') b') b UNIV = b'" by simp
-qed
-
-lemma finfun_const_apply [simp, code]: "(\<lambda>\<^isup>f b)\<^sub>f a = b"
-by(simp add: finfun_apply_def)
-
-lemma finfun_upd_apply: "f(\<^sup>fa := b)\<^sub>f a' = (if a = a' then b else f\<^sub>f a')"
- and finfun_upd_apply_code [code]: "(finfun_update_code f a b)\<^sub>f a' = (if a = a' then b else f\<^sub>f a')"
-by(simp_all add: finfun_apply_def)
-
-lemma finfun_upd_apply_same [simp]:
- "f(\<^sup>fa := b)\<^sub>f a = b"
-by(simp add: finfun_upd_apply)
-
-lemma finfun_upd_apply_other [simp]:
- "a \<noteq> a' \<Longrightarrow> f(\<^sup>fa := b)\<^sub>f a' = f\<^sub>f a'"
-by(simp add: finfun_upd_apply)
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_apply_Rep_finfun:
- "finfun_apply = Rep_finfun"
-proof(rule finfun_rec_unique)
- fix c show "Rep_finfun (\<lambda>\<^isup>f c) = (\<lambda>a. c)" by(auto simp add: finfun_const_def)
-next
- fix g a b show "Rep_finfun g(\<^sup>f a := b) = (\<lambda>c. if c = a then b else Rep_finfun g c)"
- by(auto simp add: finfun_update_def fun_upd_finfun Abs_finfun_inverse Rep_finfun intro: ext)
-qed(auto intro: ext)
-
-lemma finfun_ext: "(\<And>a. f\<^sub>f a = g\<^sub>f a) \<Longrightarrow> f = g"
-by(auto simp add: finfun_apply_Rep_finfun Rep_finfun_inject[symmetric] simp del: Rep_finfun_inject intro: ext)
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma expand_finfun_eq: "(f = g) = (f\<^sub>f = g\<^sub>f)"
-by(auto intro: finfun_ext)
-
-lemma finfun_const_inject [simp]: "(\<lambda>\<^isup>f b) = (\<lambda>\<^isup>f b') \<equiv> b = b'"
-by(simp add: expand_finfun_eq expand_fun_eq)
-
-lemma finfun_const_eq_update:
- "((\<lambda>\<^isup>f b) = f(\<^sup>f a := b')) = (b = b' \<and> (\<forall>a'. a \<noteq> a' \<longrightarrow> f\<^sub>f a' = b))"
-by(auto simp add: expand_finfun_eq expand_fun_eq finfun_upd_apply)
-
-subsection {* Function composition *}
-
-definition finfun_comp :: "('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow>\<^isub>f 'a \<Rightarrow> 'c \<Rightarrow>\<^isub>f 'b" (infixr "\<circ>\<^isub>f" 55)
-where [code del]: "g \<circ>\<^isub>f f = finfun_rec (\<lambda>b. (\<lambda>\<^isup>f g b)) (\<lambda>a b c. c(\<^sup>f a := g b)) f"
-
-interpretation finfun_comp_aux: finfun_rec_wf_aux "(\<lambda>b. (\<lambda>\<^isup>f g b))" "(\<lambda>a b c. c(\<^sup>f a := g b))"
-by(unfold_locales)(auto simp add: finfun_upd_apply intro: finfun_ext)
-
-interpretation finfun_comp: finfun_rec_wf "(\<lambda>b. (\<lambda>\<^isup>f g b))" "(\<lambda>a b c. c(\<^sup>f a := g b))"
-proof
- fix b' b :: 'a
- assume fin: "finite (UNIV :: 'c set)"
- { fix A :: "'c set"
- from fin have "finite A" by(auto intro: finite_subset)
- hence "fold (\<lambda>(a :: 'c) c. c(\<^sup>f a := g b')) (\<lambda>\<^isup>f g b) A =
- Abs_finfun (\<lambda>a. if a \<in> A then g b' else g b)"
- by induct (simp_all add: finfun_const_def, auto simp add: finfun_update_def Abs_finfun_inverse_finite fun_upd_def Abs_finfun_inject_finite expand_fun_eq fin) }
- from this[of UNIV] show "fold (\<lambda>(a :: 'c) c. c(\<^sup>f a := g b')) (\<lambda>\<^isup>f g b) UNIV = (\<lambda>\<^isup>f g b')"
- by(simp add: finfun_const_def)
-qed
-
-lemma finfun_comp_const [simp, code]:
- "g \<circ>\<^isub>f (\<lambda>\<^isup>f c) = (\<lambda>\<^isup>f g c)"
-by(simp add: finfun_comp_def)
-
-lemma finfun_comp_update [simp]: "g \<circ>\<^isub>f (f(\<^sup>f a := b)) = (g \<circ>\<^isub>f f)(\<^sup>f a := g b)"
- and finfun_comp_update_code [code]: "g \<circ>\<^isub>f (finfun_update_code f a b) = finfun_update_code (g \<circ>\<^isub>f f) a (g b)"
-by(simp_all add: finfun_comp_def)
-
-lemma finfun_comp_apply [simp]:
- "(g \<circ>\<^isub>f f)\<^sub>f = g \<circ> f\<^sub>f"
-by(induct f rule: finfun_weak_induct)(auto simp add: finfun_upd_apply intro: ext)
-
-lemma finfun_comp_comp_collapse [simp]: "f \<circ>\<^isub>f g \<circ>\<^isub>f h = (f o g) \<circ>\<^isub>f h"
-by(induct h rule: finfun_weak_induct) simp_all
-
-lemma finfun_comp_const1 [simp]: "(\<lambda>x. c) \<circ>\<^isub>f f = (\<lambda>\<^isup>f c)"
-by(induct f rule: finfun_weak_induct)(auto intro: finfun_ext simp add: finfun_upd_apply)
-
-lemma finfun_comp_id1 [simp]: "(\<lambda>x. x) \<circ>\<^isub>f f = f" "id \<circ>\<^isub>f f = f"
-by(induct f rule: finfun_weak_induct) auto
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_comp_conv_comp: "g \<circ>\<^isub>f f = Abs_finfun (g \<circ> finfun_apply f)"
-proof -
- have "(\<lambda>f. g \<circ>\<^isub>f f) = (\<lambda>f. Abs_finfun (g \<circ> finfun_apply f))"
- proof(rule finfun_rec_unique)
- { fix c show "Abs_finfun (g \<circ> (\<lambda>\<^isup>f c)\<^sub>f) = (\<lambda>\<^isup>f g c)"
- by(simp add: finfun_comp_def o_def)(simp add: finfun_const_def) }
- { fix g' a b show "Abs_finfun (g \<circ> g'(\<^sup>f a := b)\<^sub>f) = (Abs_finfun (g \<circ> g'\<^sub>f))(\<^sup>f a := g b)"
- proof -
- obtain y where y: "y \<in> finfun" and g': "g' = Abs_finfun y" by(cases g')
- moreover hence "(g \<circ> g'\<^sub>f) \<in> finfun" by(simp add: finfun_apply_Rep_finfun finfun_left_compose)
- moreover have "g \<circ> y(a := b) = (g \<circ> y)(a := g b)" by(auto intro: ext)
- ultimately show ?thesis by(simp add: finfun_comp_def finfun_update_def finfun_apply_Rep_finfun)
- qed }
- qed auto
- thus ?thesis by(auto simp add: expand_fun_eq)
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-
-
-definition finfun_comp2 :: "'b \<Rightarrow>\<^isub>f 'c \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'c" (infixr "\<^sub>f\<circ>" 55)
-where [code del]: "finfun_comp2 g f = Abs_finfun (Rep_finfun g \<circ> f)"
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_comp2_const [code, simp]: "finfun_comp2 (\<lambda>\<^isup>f c) f = (\<lambda>\<^isup>f c)"
-by(simp add: finfun_comp2_def finfun_const_def comp_def)
-
-lemma finfun_comp2_update:
- assumes inj: "inj f"
- shows "finfun_comp2 (g(\<^sup>f b := c)) f = (if b \<in> range f then (finfun_comp2 g f)(\<^sup>f inv f b := c) else finfun_comp2 g f)"
-proof(cases "b \<in> range f")
- case True
- from inj have "\<And>x. (Rep_finfun g)(f x := c) \<circ> f = (Rep_finfun g \<circ> f)(x := c)" by(auto intro!: ext dest: injD)
- with inj True show ?thesis by(auto simp add: finfun_comp2_def finfun_update_def finfun_right_compose)
-next
- case False
- hence "(Rep_finfun g)(b := c) \<circ> f = Rep_finfun g \<circ> f" by(auto simp add: expand_fun_eq)
- with False show ?thesis by(auto simp add: finfun_comp2_def finfun_update_def)
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-subsection {* A type class for computing the cardinality of a type's universe *}
-
-class card_UNIV =
- fixes card_UNIV :: "'a itself \<Rightarrow> nat"
- assumes card_UNIV: "card_UNIV x = card (UNIV :: 'a set)"
-begin
-
-lemma card_UNIV_neq_0_finite_UNIV:
- "card_UNIV x \<noteq> 0 \<longleftrightarrow> finite (UNIV :: 'a set)"
-by(simp add: card_UNIV card_eq_0_iff)
-
-lemma card_UNIV_ge_0_finite_UNIV:
- "card_UNIV x > 0 \<longleftrightarrow> finite (UNIV :: 'a set)"
-by(auto simp add: card_UNIV intro: card_ge_0_finite finite_UNIV_card_ge_0)
-
-lemma card_UNIV_eq_0_infinite_UNIV:
- "card_UNIV x = 0 \<longleftrightarrow> infinite (UNIV :: 'a set)"
-by(simp add: card_UNIV card_eq_0_iff)
-
-definition is_list_UNIV :: "'a list \<Rightarrow> bool"
-where "is_list_UNIV xs = (let c = card_UNIV (TYPE('a)) in if c = 0 then False else size (remdups xs) = c)"
-
-lemma is_list_UNIV_iff:
- fixes xs :: "'a list"
- shows "is_list_UNIV xs \<longleftrightarrow> set xs = UNIV"
-proof
- assume "is_list_UNIV xs"
- hence c: "card_UNIV (TYPE('a)) > 0" and xs: "size (remdups xs) = card_UNIV (TYPE('a))"
- unfolding is_list_UNIV_def by(simp_all add: Let_def split: split_if_asm)
- from c have fin: "finite (UNIV :: 'a set)" by(auto simp add: card_UNIV_ge_0_finite_UNIV)
- have "card (set (remdups xs)) = size (remdups xs)" by(subst distinct_card) auto
- also note set_remdups
- finally show "set xs = UNIV" using fin unfolding xs card_UNIV by-(rule card_eq_UNIV_imp_eq_UNIV)
-next
- assume xs: "set xs = UNIV"
- from finite_set[of xs] have fin: "finite (UNIV :: 'a set)" unfolding xs .
- hence "card_UNIV (TYPE ('a)) \<noteq> 0" unfolding card_UNIV_neq_0_finite_UNIV .
- moreover have "size (remdups xs) = card (set (remdups xs))"
- by(subst distinct_card) auto
- ultimately show "is_list_UNIV xs" using xs by(simp add: is_list_UNIV_def Let_def card_UNIV)
-qed
-
-lemma card_UNIV_eq_0_is_list_UNIV_False:
- assumes cU0: "card_UNIV x = 0"
- shows "is_list_UNIV = (\<lambda>xs. False)"
-proof(rule ext)
- fix xs :: "'a list"
- from cU0 have "infinite (UNIV :: 'a set)"
- by(auto simp only: card_UNIV_eq_0_infinite_UNIV)
- moreover have "finite (set xs)" by(rule finite_set)
- ultimately have "(UNIV :: 'a set) \<noteq> set xs" by(auto simp del: finite_set)
- thus "is_list_UNIV xs = False" unfolding is_list_UNIV_iff by simp
-qed
-
-end
-
-subsection {* Instantiations for @{text "card_UNIV"} *}
-
-subsubsection {* @{typ "nat"} *}
-
-instantiation nat :: card_UNIV begin
-
-definition card_UNIV_nat_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: nat itself. 0)"
-
-instance proof
- fix x :: "nat itself"
- show "card_UNIV x = card (UNIV :: nat set)"
- unfolding card_UNIV_nat_def by simp
-qed
-
-end
-
-subsubsection {* @{typ "int"} *}
-
-instantiation int :: card_UNIV begin
-
-definition card_UNIV_int_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: int itself. 0)"
-
-instance proof
- fix x :: "int itself"
- show "card_UNIV x = card (UNIV :: int set)"
- unfolding card_UNIV_int_def by simp
-qed
-
-end
-
-subsubsection {* @{typ "'a list"} *}
-
-instantiation list :: (type) card_UNIV begin
-
-definition card_UNIV_list_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: 'a list itself. 0)"
-
-instance proof
- fix x :: "'a list itself"
- show "card_UNIV x = card (UNIV :: 'a list set)"
- unfolding card_UNIV_list_def by(simp add: infinite_UNIV_listI)
-qed
-
-end
-
-subsubsection {* @{typ "unit"} *}
-
-lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
- unfolding UNIV_unit by simp
-
-instantiation unit :: card_UNIV begin
-
-definition card_UNIV_unit_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: unit itself. 1)"
-
-instance proof
- fix x :: "unit itself"
- show "card_UNIV x = card (UNIV :: unit set)"
- by(simp add: card_UNIV_unit_def card_UNIV_unit)
-qed
-
-end
-
-subsubsection {* @{typ "bool"} *}
-
-lemma card_UNIV_bool: "card (UNIV :: bool set) = 2"
- unfolding UNIV_bool by simp
-
-instantiation bool :: card_UNIV begin
-
-definition card_UNIV_bool_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: bool itself. 2)"
-
-instance proof
- fix x :: "bool itself"
- show "card_UNIV x = card (UNIV :: bool set)"
- by(simp add: card_UNIV_bool_def card_UNIV_bool)
-qed
-
-end
-
-subsubsection {* @{typ "char"} *}
-
-lemma card_UNIV_char: "card (UNIV :: char set) = 256"
-proof -
- from enum_distinct
- have "card (set (enum :: char list)) = length (enum :: char list)"
- by - (rule distinct_card)
- also have "set enum = (UNIV :: char set)" by auto
- also note enum_chars
- finally show ?thesis by (simp add: chars_def)
-qed
-
-instantiation char :: card_UNIV begin
-
-definition card_UNIV_char_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: char itself. 256)"
-
-instance proof
- fix x :: "char itself"
- show "card_UNIV x = card (UNIV :: char set)"
- by(simp add: card_UNIV_char_def card_UNIV_char)
-qed
-
-end
-
-subsubsection {* @{typ "'a \<times> 'b"} *}
-
-instantiation * :: (card_UNIV, card_UNIV) card_UNIV begin
-
-definition card_UNIV_product_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a \<times> 'b) itself. card_UNIV (TYPE('a)) * card_UNIV (TYPE('b)))"
-
-instance proof
- fix x :: "('a \<times> 'b) itself"
- show "card_UNIV x = card (UNIV :: ('a \<times> 'b) set)"
- by(simp add: card_UNIV_product_def card_UNIV UNIV_Times_UNIV[symmetric] card_cartesian_product del: UNIV_Times_UNIV)
-qed
-
-end
-
-subsubsection {* @{typ "'a + 'b"} *}
-
-instantiation "+" :: (card_UNIV, card_UNIV) card_UNIV begin
-
-definition card_UNIV_sum_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a + 'b) itself. let ca = card_UNIV (TYPE('a)); cb = card_UNIV (TYPE('b))
- in if ca \<noteq> 0 \<and> cb \<noteq> 0 then ca + cb else 0)"
-
-instance proof
- fix x :: "('a + 'b) itself"
- show "card_UNIV x = card (UNIV :: ('a + 'b) set)"
- by (auto simp add: card_UNIV_sum_def card_UNIV card_eq_0_iff UNIV_Plus_UNIV[symmetric] finite_Plus_iff Let_def card_Plus simp del: UNIV_Plus_UNIV dest!: card_ge_0_finite)
-qed
-
-end
-
-subsubsection {* @{typ "'a \<Rightarrow> 'b"} *}
-
-instantiation "fun" :: (card_UNIV, card_UNIV) card_UNIV begin
-
-definition card_UNIV_fun_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: ('a \<Rightarrow> 'b) itself. let ca = card_UNIV (TYPE('a)); cb = card_UNIV (TYPE('b))
- in if ca \<noteq> 0 \<and> cb \<noteq> 0 \<or> cb = 1 then cb ^ ca else 0)"
-
-instance proof
- fix x :: "('a \<Rightarrow> 'b) itself"
-
- { assume "0 < card (UNIV :: 'a set)"
- and "0 < card (UNIV :: 'b set)"
- hence fina: "finite (UNIV :: 'a set)" and finb: "finite (UNIV :: 'b set)"
- by(simp_all only: card_ge_0_finite)
- from finite_distinct_list[OF finb] obtain bs
- where bs: "set bs = (UNIV :: 'b set)" and distb: "distinct bs" by blast
- from finite_distinct_list[OF fina] obtain as
- where as: "set as = (UNIV :: 'a set)" and dista: "distinct as" by blast
- have cb: "card (UNIV :: 'b set) = length bs"
- unfolding bs[symmetric] distinct_card[OF distb] ..
- have ca: "card (UNIV :: 'a set) = length as"
- unfolding as[symmetric] distinct_card[OF dista] ..
- let ?xs = "map (\<lambda>ys. the o map_of (zip as ys)) (n_lists (length as) bs)"
- have "UNIV = set ?xs"
- proof(rule UNIV_eq_I)
- fix f :: "'a \<Rightarrow> 'b"
- from as have "f = the \<circ> map_of (zip as (map f as))"
- by(auto simp add: map_of_zip_map intro: ext)
- thus "f \<in> set ?xs" using bs by(auto simp add: set_n_lists)
- qed
- moreover have "distinct ?xs" unfolding distinct_map
- proof(intro conjI distinct_n_lists distb inj_onI)
- fix xs ys :: "'b list"
- assume xs: "xs \<in> set (n_lists (length as) bs)"
- and ys: "ys \<in> set (n_lists (length as) bs)"
- and eq: "the \<circ> map_of (zip as xs) = the \<circ> map_of (zip as ys)"
- from xs ys have [simp]: "length xs = length as" "length ys = length as"
- by(simp_all add: length_n_lists_elem)
- have "map_of (zip as xs) = map_of (zip as ys)"
- proof
- fix x
- from as bs have "\<exists>y. map_of (zip as xs) x = Some y" "\<exists>y. map_of (zip as ys) x = Some y"
- by(simp_all add: map_of_zip_is_Some[symmetric])
- with eq show "map_of (zip as xs) x = map_of (zip as ys) x"
- by(auto dest: fun_cong[where x=x])
- qed
- with dista show "xs = ys" by(simp add: map_of_zip_inject)
- qed
- hence "card (set ?xs) = length ?xs" by(simp only: distinct_card)
- moreover have "length ?xs = length bs ^ length as" by(simp add: length_n_lists)
- ultimately have "card (UNIV :: ('a \<Rightarrow> 'b) set) = card (UNIV :: 'b set) ^ card (UNIV :: 'a set)"
- using cb ca by simp }
- moreover {
- assume cb: "card (UNIV :: 'b set) = Suc 0"
- then obtain b where b: "UNIV = {b :: 'b}" by(auto simp add: card_Suc_eq)
- have eq: "UNIV = {\<lambda>x :: 'a. b ::'b}"
- proof(rule UNIV_eq_I)
- fix x :: "'a \<Rightarrow> 'b"
- { fix y
- have "x y \<in> UNIV" ..
- hence "x y = b" unfolding b by simp }
- thus "x \<in> {\<lambda>x. b}" by(auto intro: ext)
- qed
- have "card (UNIV :: ('a \<Rightarrow> 'b) set) = Suc 0" unfolding eq by simp }
- ultimately show "card_UNIV x = card (UNIV :: ('a \<Rightarrow> 'b) set)"
- unfolding card_UNIV_fun_def card_UNIV Let_def
- by(auto simp del: One_nat_def)(auto simp add: card_eq_0_iff dest: finite_fun_UNIVD2 finite_fun_UNIVD1)
-qed
-
-end
-
-subsubsection {* @{typ "'a option"} *}
-
-instantiation option :: (card_UNIV) card_UNIV
-begin
-
-definition card_UNIV_option_def:
- "card_UNIV_class.card_UNIV = (\<lambda>a :: 'a option itself. let c = card_UNIV (TYPE('a))
- in if c \<noteq> 0 then Suc c else 0)"
-
-instance proof
- fix x :: "'a option itself"
- show "card_UNIV x = card (UNIV :: 'a option set)"
- unfolding UNIV_option_conv
- by(auto simp add: card_UNIV_option_def card_UNIV card_eq_0_iff Let_def intro: inj_Some dest: finite_imageD)
- (subst card_insert_disjoint, auto simp add: card_eq_0_iff card_image inj_Some intro: finite_imageI card_ge_0_finite)
-qed
-
-end
-
-
-subsection {* Universal quantification *}
-
-definition finfun_All_except :: "'a list \<Rightarrow> 'a \<Rightarrow>\<^isub>f bool \<Rightarrow> bool"
-where [code del]: "finfun_All_except A P \<equiv> \<forall>a. a \<in> set A \<or> P\<^sub>f a"
-
-lemma finfun_All_except_const: "finfun_All_except A (\<lambda>\<^isup>f b) \<longleftrightarrow> b \<or> set A = UNIV"
-by(auto simp add: finfun_All_except_def)
-
-lemma finfun_All_except_const_finfun_UNIV_code [code]:
- "finfun_All_except A (\<lambda>\<^isup>f b) = (b \<or> is_list_UNIV A)"
-by(simp add: finfun_All_except_const is_list_UNIV_iff)
-
-lemma finfun_All_except_update:
- "finfun_All_except A f(\<^sup>f a := b) = ((a \<in> set A \<or> b) \<and> finfun_All_except (a # A) f)"
-by(fastsimp simp add: finfun_All_except_def finfun_upd_apply)
-
-lemma finfun_All_except_update_code [code]:
- fixes a :: "'a :: card_UNIV"
- shows "finfun_All_except A (finfun_update_code f a b) = ((a \<in> set A \<or> b) \<and> finfun_All_except (a # A) f)"
-by(simp add: finfun_All_except_update)
-
-definition finfun_All :: "'a \<Rightarrow>\<^isub>f bool \<Rightarrow> bool"
-where "finfun_All = finfun_All_except []"
-
-lemma finfun_All_const [simp]: "finfun_All (\<lambda>\<^isup>f b) = b"
-by(simp add: finfun_All_def finfun_All_except_def)
-
-lemma finfun_All_update: "finfun_All f(\<^sup>f a := b) = (b \<and> finfun_All_except [a] f)"
-by(simp add: finfun_All_def finfun_All_except_update)
-
-lemma finfun_All_All: "finfun_All P = All P\<^sub>f"
-by(simp add: finfun_All_def finfun_All_except_def)
-
-
-definition finfun_Ex :: "'a \<Rightarrow>\<^isub>f bool \<Rightarrow> bool"
-where "finfun_Ex P = Not (finfun_All (Not \<circ>\<^isub>f P))"
-
-lemma finfun_Ex_Ex: "finfun_Ex P = Ex P\<^sub>f"
-unfolding finfun_Ex_def finfun_All_All by simp
-
-lemma finfun_Ex_const [simp]: "finfun_Ex (\<lambda>\<^isup>f b) = b"
-by(simp add: finfun_Ex_def)
-
-
-subsection {* A diagonal operator for FinFuns *}
-
-definition finfun_Diag :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'c \<Rightarrow> 'a \<Rightarrow>\<^isub>f ('b \<times> 'c)" ("(1'(_,/ _')\<^sup>f)" [0, 0] 1000)
-where [code del]: "finfun_Diag f g = finfun_rec (\<lambda>b. Pair b \<circ>\<^isub>f g) (\<lambda>a b c. c(\<^sup>f a := (b, g\<^sub>f a))) f"
-
-interpretation finfun_Diag_aux: finfun_rec_wf_aux "\<lambda>b. Pair b \<circ>\<^isub>f g" "\<lambda>a b c. c(\<^sup>f a := (b, g\<^sub>f a))"
-by(unfold_locales)(simp_all add: expand_finfun_eq expand_fun_eq finfun_upd_apply)
-
-interpretation finfun_Diag: finfun_rec_wf "\<lambda>b. Pair b \<circ>\<^isub>f g" "\<lambda>a b c. c(\<^sup>f a := (b, g\<^sub>f a))"
-proof
- fix b' b :: 'a
- assume fin: "finite (UNIV :: 'c set)"
- { fix A :: "'c set"
- interpret fun_left_comm "\<lambda>a c. c(\<^sup>f a := (b', g\<^sub>f a))" by(rule finfun_Diag_aux.upd_left_comm)
- from fin have "finite A" by(auto intro: finite_subset)
- hence "fold (\<lambda>a c. c(\<^sup>f a := (b', g\<^sub>f a))) (Pair b \<circ>\<^isub>f g) A =
- Abs_finfun (\<lambda>a. (if a \<in> A then b' else b, g\<^sub>f a))"
- by(induct)(simp_all add: finfun_const_def finfun_comp_conv_comp o_def,
- auto simp add: finfun_update_def Abs_finfun_inverse_finite fun_upd_def Abs_finfun_inject_finite expand_fun_eq fin) }
- from this[of UNIV] show "fold (\<lambda>a c. c(\<^sup>f a := (b', g\<^sub>f a))) (Pair b \<circ>\<^isub>f g) UNIV = Pair b' \<circ>\<^isub>f g"
- by(simp add: finfun_const_def finfun_comp_conv_comp o_def)
-qed
-
-lemma finfun_Diag_const1: "(\<lambda>\<^isup>f b, g)\<^sup>f = Pair b \<circ>\<^isub>f g"
-by(simp add: finfun_Diag_def)
-
-text {*
- Do not use @{thm finfun_Diag_const1} for the code generator because @{term "Pair b"} is injective, i.e. if @{term g} is free of redundant updates, there is no need to check for redundant updates as is done for @{text "\<circ>\<^isub>f"}.
-*}
-
-lemma finfun_Diag_const_code [code]:
- "(\<lambda>\<^isup>f b, \<lambda>\<^isup>f c)\<^sup>f = (\<lambda>\<^isup>f (b, c))"
- "(\<lambda>\<^isup>f b, g(\<^sup>f\<^sup>c a := c))\<^sup>f = (\<lambda>\<^isup>f b, g)\<^sup>f(\<^sup>f\<^sup>c a := (b, c))"
-by(simp_all add: finfun_Diag_const1)
-
-lemma finfun_Diag_update1: "(f(\<^sup>f a := b), g)\<^sup>f = (f, g)\<^sup>f(\<^sup>f a := (b, g\<^sub>f a))"
- and finfun_Diag_update1_code [code]: "(finfun_update_code f a b, g)\<^sup>f = (f, g)\<^sup>f(\<^sup>f a := (b, g\<^sub>f a))"
-by(simp_all add: finfun_Diag_def)
-
-lemma finfun_Diag_const2: "(f, \<lambda>\<^isup>f c)\<^sup>f = (\<lambda>b. (b, c)) \<circ>\<^isub>f f"
-by(induct f rule: finfun_weak_induct)(auto intro!: finfun_ext simp add: finfun_upd_apply finfun_Diag_const1 finfun_Diag_update1)
-
-lemma finfun_Diag_update2: "(f, g(\<^sup>f a := c))\<^sup>f = (f, g)\<^sup>f(\<^sup>f a := (f\<^sub>f a, c))"
-by(induct f rule: finfun_weak_induct)(auto intro!: finfun_ext simp add: finfun_upd_apply finfun_Diag_const1 finfun_Diag_update1)
-
-lemma finfun_Diag_const_const [simp]: "(\<lambda>\<^isup>f b, \<lambda>\<^isup>f c)\<^sup>f = (\<lambda>\<^isup>f (b, c))"
-by(simp add: finfun_Diag_const1)
-
-lemma finfun_Diag_const_update:
- "(\<lambda>\<^isup>f b, g(\<^sup>f a := c))\<^sup>f = (\<lambda>\<^isup>f b, g)\<^sup>f(\<^sup>f a := (b, c))"
-by(simp add: finfun_Diag_const1)
-
-lemma finfun_Diag_update_const:
- "(f(\<^sup>f a := b), \<lambda>\<^isup>f c)\<^sup>f = (f, \<lambda>\<^isup>f c)\<^sup>f(\<^sup>f a := (b, c))"
-by(simp add: finfun_Diag_def)
-
-lemma finfun_Diag_update_update:
- "(f(\<^sup>f a := b), g(\<^sup>f a' := c))\<^sup>f = (if a = a' then (f, g)\<^sup>f(\<^sup>f a := (b, c)) else (f, g)\<^sup>f(\<^sup>f a := (b, g\<^sub>f a))(\<^sup>f a' := (f\<^sub>f a', c)))"
-by(auto simp add: finfun_Diag_update1 finfun_Diag_update2)
-
-lemma finfun_Diag_apply [simp]: "(f, g)\<^sup>f\<^sub>f = (\<lambda>x. (f\<^sub>f x, g\<^sub>f x))"
-by(induct f rule: finfun_weak_induct)(auto simp add: finfun_Diag_const1 finfun_Diag_update1 finfun_upd_apply intro: ext)
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_Diag_conv_Abs_finfun:
- "(f, g)\<^sup>f = Abs_finfun ((\<lambda>x. (Rep_finfun f x, Rep_finfun g x)))"
-proof -
- have "(\<lambda>f :: 'a \<Rightarrow>\<^isub>f 'b. (f, g)\<^sup>f) = (\<lambda>f. Abs_finfun ((\<lambda>x. (Rep_finfun f x, Rep_finfun g x))))"
- proof(rule finfun_rec_unique)
- { fix c show "Abs_finfun (\<lambda>x. (Rep_finfun (\<lambda>\<^isup>f c) x, Rep_finfun g x)) = Pair c \<circ>\<^isub>f g"
- by(simp add: finfun_comp_conv_comp finfun_apply_Rep_finfun o_def finfun_const_def) }
- { fix g' a b
- show "Abs_finfun (\<lambda>x. (Rep_finfun g'(\<^sup>f a := b) x, Rep_finfun g x)) =
- (Abs_finfun (\<lambda>x. (Rep_finfun g' x, Rep_finfun g x)))(\<^sup>f a := (b, g\<^sub>f a))"
- by(auto simp add: finfun_update_def expand_fun_eq finfun_apply_Rep_finfun simp del: fun_upd_apply) simp }
- qed(simp_all add: finfun_Diag_const1 finfun_Diag_update1)
- thus ?thesis by(auto simp add: expand_fun_eq)
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma finfun_Diag_eq: "(f, g)\<^sup>f = (f', g')\<^sup>f \<longleftrightarrow> f = f' \<and> g = g'"
-by(auto simp add: expand_finfun_eq expand_fun_eq)
-
-definition finfun_fst :: "'a \<Rightarrow>\<^isub>f ('b \<times> 'c) \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b"
-where [code]: "finfun_fst f = fst \<circ>\<^isub>f f"
-
-lemma finfun_fst_const: "finfun_fst (\<lambda>\<^isup>f bc) = (\<lambda>\<^isup>f fst bc)"
-by(simp add: finfun_fst_def)
-
-lemma finfun_fst_update: "finfun_fst (f(\<^sup>f a := bc)) = (finfun_fst f)(\<^sup>f a := fst bc)"
- and finfun_fst_update_code: "finfun_fst (finfun_update_code f a bc) = (finfun_fst f)(\<^sup>f a := fst bc)"
-by(simp_all add: finfun_fst_def)
-
-lemma finfun_fst_comp_conv: "finfun_fst (f \<circ>\<^isub>f g) = (fst \<circ> f) \<circ>\<^isub>f g"
-by(simp add: finfun_fst_def)
-
-lemma finfun_fst_conv [simp]: "finfun_fst (f, g)\<^sup>f = f"
-by(induct f rule: finfun_weak_induct)(simp_all add: finfun_Diag_const1 finfun_fst_comp_conv o_def finfun_Diag_update1 finfun_fst_update)
-
-lemma finfun_fst_conv_Abs_finfun: "finfun_fst = (\<lambda>f. Abs_finfun (fst o Rep_finfun f))"
-by(simp add: finfun_fst_def_raw finfun_comp_conv_comp finfun_apply_Rep_finfun)
-
-
-definition finfun_snd :: "'a \<Rightarrow>\<^isub>f ('b \<times> 'c) \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'c"
-where [code]: "finfun_snd f = snd \<circ>\<^isub>f f"
-
-lemma finfun_snd_const: "finfun_snd (\<lambda>\<^isup>f bc) = (\<lambda>\<^isup>f snd bc)"
-by(simp add: finfun_snd_def)
-
-lemma finfun_snd_update: "finfun_snd (f(\<^sup>f a := bc)) = (finfun_snd f)(\<^sup>f a := snd bc)"
- and finfun_snd_update_code [code]: "finfun_snd (finfun_update_code f a bc) = (finfun_snd f)(\<^sup>f a := snd bc)"
-by(simp_all add: finfun_snd_def)
-
-lemma finfun_snd_comp_conv: "finfun_snd (f \<circ>\<^isub>f g) = (snd \<circ> f) \<circ>\<^isub>f g"
-by(simp add: finfun_snd_def)
-
-lemma finfun_snd_conv [simp]: "finfun_snd (f, g)\<^sup>f = g"
-apply(induct f rule: finfun_weak_induct)
-apply(auto simp add: finfun_Diag_const1 finfun_snd_comp_conv o_def finfun_Diag_update1 finfun_snd_update finfun_upd_apply intro: finfun_ext)
-done
-
-lemma finfun_snd_conv_Abs_finfun: "finfun_snd = (\<lambda>f. Abs_finfun (snd o Rep_finfun f))"
-by(simp add: finfun_snd_def_raw finfun_comp_conv_comp finfun_apply_Rep_finfun)
-
-lemma finfun_Diag_collapse [simp]: "(finfun_fst f, finfun_snd f)\<^sup>f = f"
-by(induct f rule: finfun_weak_induct)(simp_all add: finfun_fst_const finfun_snd_const finfun_fst_update finfun_snd_update finfun_Diag_update_update)
-
-subsection {* Currying for FinFuns *}
-
-definition finfun_curry :: "('a \<times> 'b) \<Rightarrow>\<^isub>f 'c \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b \<Rightarrow>\<^isub>f 'c"
-where [code del]: "finfun_curry = finfun_rec (finfun_const \<circ> finfun_const) (\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c)))"
-
-interpretation finfun_curry_aux: finfun_rec_wf_aux "finfun_const \<circ> finfun_const" "\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c))"
-apply(unfold_locales)
-apply(auto simp add: split_def finfun_update_twist finfun_upd_apply split_paired_all finfun_update_const_same)
-done
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-interpretation finfun_curry: finfun_rec_wf "finfun_const \<circ> finfun_const" "\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c))"
-proof(unfold_locales)
- fix b' b :: 'b
- assume fin: "finite (UNIV :: ('c \<times> 'a) set)"
- hence fin1: "finite (UNIV :: 'c set)" and fin2: "finite (UNIV :: 'a set)"
- unfolding UNIV_Times_UNIV[symmetric]
- by(fastsimp dest: finite_cartesian_productD1 finite_cartesian_productD2)+
- note [simp] = Abs_finfun_inverse_finite[OF fin] Abs_finfun_inverse_finite[OF fin1] Abs_finfun_inverse_finite[OF fin2]
- { fix A :: "('c \<times> 'a) set"
- interpret fun_left_comm "\<lambda>a :: 'c \<times> 'a. (\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c))) a b'"
- by(rule finfun_curry_aux.upd_left_comm)
- from fin have "finite A" by(auto intro: finite_subset)
- hence "fold (\<lambda>a :: 'c \<times> 'a. (\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c))) a b') ((finfun_const \<circ> finfun_const) b) A = Abs_finfun (\<lambda>a. Abs_finfun (\<lambda>b''. if (a, b'') \<in> A then b' else b))"
- by induct (simp_all, auto simp add: finfun_update_def finfun_const_def split_def finfun_apply_Rep_finfun intro!: arg_cong[where f="Abs_finfun"] ext) }
- from this[of UNIV]
- show "fold (\<lambda>a :: 'c \<times> 'a. (\<lambda>(a, b) c f. f(\<^sup>f a := (f\<^sub>f a)(\<^sup>f b := c))) a b') ((finfun_const \<circ> finfun_const) b) UNIV = (finfun_const \<circ> finfun_const) b'"
- by(simp add: finfun_const_def)
-qed
-
-declare finfun_simp [simp del] finfun_iff [iff del] finfun_intro [rule del]
-
-lemma finfun_curry_const [simp, code]: "finfun_curry (\<lambda>\<^isup>f c) = (\<lambda>\<^isup>f \<lambda>\<^isup>f c)"
-by(simp add: finfun_curry_def)
-
-lemma finfun_curry_update [simp]:
- "finfun_curry (f(\<^sup>f (a, b) := c)) = (finfun_curry f)(\<^sup>f a := ((finfun_curry f)\<^sub>f a)(\<^sup>f b := c))"
- and finfun_curry_update_code [code]:
- "finfun_curry (f(\<^sup>f\<^sup>c (a, b) := c)) = (finfun_curry f)(\<^sup>f a := ((finfun_curry f)\<^sub>f a)(\<^sup>f b := c))"
-by(simp_all add: finfun_curry_def)
-
-declare finfun_simp [simp] finfun_iff [iff] finfun_intro [intro]
-
-lemma finfun_Abs_finfun_curry: assumes fin: "f \<in> finfun"
- shows "(\<lambda>a. Abs_finfun (curry f a)) \<in> finfun"
-proof -
- from fin obtain c where c: "finite {ab. f ab \<noteq> c}" unfolding finfun_def by blast
- have "{a. \<exists>b. f (a, b) \<noteq> c} = fst ` {ab. f ab \<noteq> c}" by(force)
- hence "{a. curry f a \<noteq> (\<lambda>x. c)} = fst ` {ab. f ab \<noteq> c}"
- by(auto simp add: curry_def expand_fun_eq)
- with fin c have "finite {a. Abs_finfun (curry f a) \<noteq> (\<lambda>\<^isup>f c)}"
- by(simp add: finfun_const_def finfun_curry)
- thus ?thesis unfolding finfun_def by auto
-qed
-
-lemma finfun_curry_conv_curry:
- fixes f :: "('a \<times> 'b) \<Rightarrow>\<^isub>f 'c"
- shows "finfun_curry f = Abs_finfun (\<lambda>a. Abs_finfun (curry (Rep_finfun f) a))"
-proof -
- have "finfun_curry = (\<lambda>f :: ('a \<times> 'b) \<Rightarrow>\<^isub>f 'c. Abs_finfun (\<lambda>a. Abs_finfun (curry (Rep_finfun f) a)))"
- proof(rule finfun_rec_unique)
- { fix c show "finfun_curry (\<lambda>\<^isup>f c) = (\<lambda>\<^isup>f \<lambda>\<^isup>f c)" by simp }
- { fix f a c show "finfun_curry (f(\<^sup>f a := c)) = (finfun_curry f)(\<^sup>f fst a := ((finfun_curry f)\<^sub>f (fst a))(\<^sup>f snd a := c))"
- by(cases a) simp }
- { fix c show "Abs_finfun (\<lambda>a. Abs_finfun (curry (Rep_finfun (\<lambda>\<^isup>f c)) a)) = (\<lambda>\<^isup>f \<lambda>\<^isup>f c)"
- by(simp add: finfun_curry_def finfun_const_def curry_def) }
- { fix g a b
- show "Abs_finfun (\<lambda>aa. Abs_finfun (curry (Rep_finfun g(\<^sup>f a := b)) aa)) =
- (Abs_finfun (\<lambda>a. Abs_finfun (curry (Rep_finfun g) a)))(\<^sup>f
- fst a := ((Abs_finfun (\<lambda>a. Abs_finfun (curry (Rep_finfun g) a)))\<^sub>f (fst a))(\<^sup>f snd a := b))"
- by(cases a)(auto intro!: ext arg_cong[where f=Abs_finfun] simp add: finfun_curry_def finfun_update_def finfun_apply_Rep_finfun finfun_curry finfun_Abs_finfun_curry) }
- qed
- thus ?thesis by(auto simp add: expand_fun_eq)
-qed
-
-subsection {* Executable equality for FinFuns *}
-
-lemma eq_finfun_All_ext: "(f = g) \<longleftrightarrow> finfun_All ((\<lambda>(x, y). x = y) \<circ>\<^isub>f (f, g)\<^sup>f)"
-by(simp add: expand_finfun_eq expand_fun_eq finfun_All_All o_def)
-
-instantiation finfun :: ("{card_UNIV,eq}",eq) eq begin
-definition eq_finfun_def: "eq_class.eq f g \<longleftrightarrow> finfun_All ((\<lambda>(x, y). x = y) \<circ>\<^isub>f (f, g)\<^sup>f)"
-instance by(intro_classes)(simp add: eq_finfun_All_ext eq_finfun_def)
-end
-
-subsection {* Operator that explicitly removes all redundant updates in the generated representations *}
-
-definition finfun_clearjunk :: "'a \<Rightarrow>\<^isub>f 'b \<Rightarrow> 'a \<Rightarrow>\<^isub>f 'b"
-where [simp, code del]: "finfun_clearjunk = id"
-
-lemma finfun_clearjunk_const [code]: "finfun_clearjunk (\<lambda>\<^isup>f b) = (\<lambda>\<^isup>f b)"
-by simp
-
-lemma finfun_clearjunk_update [code]: "finfun_clearjunk (finfun_update_code f a b) = f(\<^sup>f a := b)"
-by simp
-
-end
\ No newline at end of file--- a/src/HOL/Library/Finite_Cartesian_Product.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,95 +0,0 @@
-(* Title: HOL/Library/Finite_Cartesian_Product
- Author: Amine Chaieb, University of Cambridge
-*)
-
-header {* Definition of finite Cartesian product types. *}
-
-theory Finite_Cartesian_Product
-imports Main (*FIXME: ATP_Linkup is only needed for metis at a few places. We could dispense of that by changing the proofs.*)
-begin
-
-definition hassize (infixr "hassize" 12) where
- "(S hassize n) = (finite S \<and> card S = n)"
-
-lemma hassize_image_inj: assumes f: "inj_on f S" and S: "S hassize n"
- shows "f ` S hassize n"
- using f S card_image[OF f]
- by (simp add: hassize_def inj_on_def)
-
-
-subsection {* Finite Cartesian products, with indexing and lambdas. *}
-
-typedef (open Cart)
- ('a, 'b) "^" (infixl "^" 15)
- = "UNIV :: ('b \<Rightarrow> 'a) set"
- morphisms Cart_nth Cart_lambda ..
-
-notation Cart_nth (infixl "$" 90)
-
-notation (xsymbols) Cart_lambda (binder "\<chi>" 10)
-
-lemma stupid_ext: "(\<forall>x. f x = g x) \<longleftrightarrow> (f = g)"
- apply auto
- apply (rule ext)
- apply auto
- done
-
-lemma Cart_eq: "((x:: 'a ^ 'b) = y) \<longleftrightarrow> (\<forall>i. x$i = y$i)"
- by (simp add: Cart_nth_inject [symmetric] expand_fun_eq)
-
-lemma Cart_lambda_beta [simp]: "Cart_lambda g $ i = g i"
- by (simp add: Cart_lambda_inverse)
-
-lemma Cart_lambda_unique:
- fixes f :: "'a ^ 'b"
- shows "(\<forall>i. f$i = g i) \<longleftrightarrow> Cart_lambda g = f"
- by (auto simp add: Cart_eq)
-
-lemma Cart_lambda_eta: "(\<chi> i. (g$i)) = g"
- by (simp add: Cart_eq)
-
-text{* A non-standard sum to "paste" Cartesian products. *}
-
-definition pastecart :: "'a ^ 'm \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a ^ ('m + 'n)" where
- "pastecart f g = (\<chi> i. case i of Inl a \<Rightarrow> f$a | Inr b \<Rightarrow> g$b)"
-
-definition fstcart:: "'a ^('m + 'n) \<Rightarrow> 'a ^ 'm" where
- "fstcart f = (\<chi> i. (f$(Inl i)))"
-
-definition sndcart:: "'a ^('m + 'n) \<Rightarrow> 'a ^ 'n" where
- "sndcart f = (\<chi> i. (f$(Inr i)))"
-
-lemma nth_pastecart_Inl [simp]: "pastecart f g $ Inl a = f$a"
- unfolding pastecart_def by simp
-
-lemma nth_pastecart_Inr [simp]: "pastecart f g $ Inr b = g$b"
- unfolding pastecart_def by simp
-
-lemma nth_fstcart [simp]: "fstcart f $ i = f $ Inl i"
- unfolding fstcart_def by simp
-
-lemma nth_sndtcart [simp]: "sndcart f $ i = f $ Inr i"
- unfolding sndcart_def by simp
-
-lemma finite_sum_image: "(UNIV::('a + 'b) set) = range Inl \<union> range Inr"
-by (auto, case_tac x, auto)
-
-lemma fstcart_pastecart: "fstcart (pastecart (x::'a ^'m ) (y:: 'a ^ 'n)) = x"
- by (simp add: Cart_eq)
-
-lemma sndcart_pastecart: "sndcart (pastecart (x::'a ^'m ) (y:: 'a ^ 'n)) = y"
- by (simp add: Cart_eq)
-
-lemma pastecart_fst_snd: "pastecart (fstcart z) (sndcart z) = z"
- by (simp add: Cart_eq pastecart_def fstcart_def sndcart_def split: sum.split)
-
-lemma pastecart_eq: "(x = y) \<longleftrightarrow> (fstcart x = fstcart y) \<and> (sndcart x = sndcart y)"
- using pastecart_fst_snd[of x] pastecart_fst_snd[of y] by metis
-
-lemma forall_pastecart: "(\<forall>p. P p) \<longleftrightarrow> (\<forall>x y. P (pastecart x y))"
- by (metis pastecart_fst_snd fstcart_pastecart sndcart_pastecart)
-
-lemma exists_pastecart: "(\<exists>p. P p) \<longleftrightarrow> (\<exists>x y. P (pastecart x y))"
- by (metis pastecart_fst_snd fstcart_pastecart sndcart_pastecart)
-
-end--- a/src/HOL/Library/Library.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Library/Library.thy Tue Oct 27 14:46:03 2009 +0000
@@ -14,15 +14,12 @@
Commutative_Ring
Continuity
ContNotDenum
- Convex_Euclidean_Space
Countable
- Determinants
Diagonalize
Efficient_Nat
Enum
Eval_Witness
Executable_Set
- Fin_Fun
Float
Formal_Power_Series
Fraction_Field
@@ -52,9 +49,9 @@
Ramsey
Reflection
RBT
+ SML_Quickcheck
State_Monad
Sum_Of_Squares
- Topology_Euclidean_Space
Univ_Poly
While_Combinator
Word
--- a/src/HOL/Library/Multiset.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Library/Multiset.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1607,7 +1607,7 @@
rtac @{thm nonempty_plus} ORELSE' rtac @{thm nonempty_single}
val regroup_munion_conv =
- FundefLib.regroup_conv @{const_name Multiset.Mempty} @{const_name plus}
+ Function_Lib.regroup_conv @{const_name Multiset.Mempty} @{const_name plus}
(map (fn t => t RS eq_reflection) (@{thms union_ac} @ @{thms empty_idemp}))
fun unfold_pwleq_tac i =--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/SML_Quickcheck.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,12 @@
+
+header {* Install quickcheck of SML code generator *}
+
+theory SML_Quickcheck
+imports Main
+begin
+
+setup {*
+ Quickcheck.add_generator ("SML", Codegen.test_term)
+*}
+
+end--- a/src/HOL/Library/Topology_Euclidean_Space.thy Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,6015 +0,0 @@
-(* Title: HOL/Library/Topology_Euclidian_Space.thy
- Author: Amine Chaieb, University of Cambridge
- Author: Robert Himmelmann, TU Muenchen
-*)
-
-header {* Elementary topology in Euclidean space. *}
-
-theory Topology_Euclidean_Space
-imports SEQ Euclidean_Space Product_Vector
-begin
-
-declare fstcart_pastecart[simp] sndcart_pastecart[simp]
-
-subsection{* General notion of a topology *}
-
-definition "istopology L \<longleftrightarrow> {} \<in> L \<and> (\<forall>S \<in>L. \<forall>T \<in>L. S \<inter> T \<in> L) \<and> (\<forall>K. K \<subseteq>L \<longrightarrow> \<Union> K \<in> L)"
-typedef (open) 'a topology = "{L::('a set) set. istopology L}"
- morphisms "openin" "topology"
- unfolding istopology_def by blast
-
-lemma istopology_open_in[intro]: "istopology(openin U)"
- using openin[of U] by blast
-
-lemma topology_inverse': "istopology U \<Longrightarrow> openin (topology U) = U"
- using topology_inverse[unfolded mem_def Collect_def] .
-
-lemma topology_inverse_iff: "istopology U \<longleftrightarrow> openin (topology U) = U"
- using topology_inverse[of U] istopology_open_in[of "topology U"] by auto
-
-lemma topology_eq: "T1 = T2 \<longleftrightarrow> (\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S)"
-proof-
- {assume "T1=T2" hence "\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S" by simp}
- moreover
- {assume H: "\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S"
- hence "openin T1 = openin T2" by (metis mem_def set_ext)
- hence "topology (openin T1) = topology (openin T2)" by simp
- hence "T1 = T2" unfolding openin_inverse .}
- ultimately show ?thesis by blast
-qed
-
-text{* Infer the "universe" from union of all sets in the topology. *}
-
-definition "topspace T = \<Union>{S. openin T S}"
-
-subsection{* Main properties of open sets *}
-
-lemma openin_clauses:
- fixes U :: "'a topology"
- shows "openin U {}"
- "\<And>S T. openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S\<inter>T)"
- "\<And>K. (\<forall>S \<in> K. openin U S) \<Longrightarrow> openin U (\<Union>K)"
- using openin[of U] unfolding istopology_def Collect_def mem_def
- by (metis mem_def subset_eq)+
-
-lemma openin_subset[intro]: "openin U S \<Longrightarrow> S \<subseteq> topspace U"
- unfolding topspace_def by blast
-lemma openin_empty[simp]: "openin U {}" by (simp add: openin_clauses)
-
-lemma openin_Int[intro]: "openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S \<inter> T)"
- by (simp add: openin_clauses)
-
-lemma openin_Union[intro]: "(\<forall>S \<in>K. openin U S) \<Longrightarrow> openin U (\<Union> K)" by (simp add: openin_clauses)
-
-lemma openin_Un[intro]: "openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S \<union> T)"
- using openin_Union[of "{S,T}" U] by auto
-
-lemma openin_topspace[intro, simp]: "openin U (topspace U)" by (simp add: openin_Union topspace_def)
-
-lemma openin_subopen: "openin U S \<longleftrightarrow> (\<forall>x \<in> S. \<exists>T. openin U T \<and> x \<in> T \<and> T \<subseteq> S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume ?lhs then have ?rhs by auto }
- moreover
- {assume H: ?rhs
- then obtain t where t: "\<forall>x\<in>S. openin U (t x) \<and> x \<in> t x \<and> t x \<subseteq> S"
- unfolding Ball_def ex_simps(6)[symmetric] choice_iff by blast
- from t have th0: "\<forall>x\<in> t`S. openin U x" by auto
- have "\<Union> t`S = S" using t by auto
- with openin_Union[OF th0] have "openin U S" by simp }
- ultimately show ?thesis by blast
-qed
-
-subsection{* Closed sets *}
-
-definition "closedin U S \<longleftrightarrow> S \<subseteq> topspace U \<and> openin U (topspace U - S)"
-
-lemma closedin_subset: "closedin U S \<Longrightarrow> S \<subseteq> topspace U" by (metis closedin_def)
-lemma closedin_empty[simp]: "closedin U {}" by (simp add: closedin_def)
-lemma closedin_topspace[intro,simp]:
- "closedin U (topspace U)" by (simp add: closedin_def)
-lemma closedin_Un[intro]: "closedin U S \<Longrightarrow> closedin U T \<Longrightarrow> closedin U (S \<union> T)"
- by (auto simp add: Diff_Un closedin_def)
-
-lemma Diff_Inter[intro]: "A - \<Inter>S = \<Union> {A - s|s. s\<in>S}" by auto
-lemma closedin_Inter[intro]: assumes Ke: "K \<noteq> {}" and Kc: "\<forall>S \<in>K. closedin U S"
- shows "closedin U (\<Inter> K)" using Ke Kc unfolding closedin_def Diff_Inter by auto
-
-lemma closedin_Int[intro]: "closedin U S \<Longrightarrow> closedin U T \<Longrightarrow> closedin U (S \<inter> T)"
- using closedin_Inter[of "{S,T}" U] by auto
-
-lemma Diff_Diff_Int: "A - (A - B) = A \<inter> B" by blast
-lemma openin_closedin_eq: "openin U S \<longleftrightarrow> S \<subseteq> topspace U \<and> closedin U (topspace U - S)"
- apply (auto simp add: closedin_def Diff_Diff_Int inf_absorb2)
- apply (metis openin_subset subset_eq)
- done
-
-lemma openin_closedin: "S \<subseteq> topspace U \<Longrightarrow> (openin U S \<longleftrightarrow> closedin U (topspace U - S))"
- by (simp add: openin_closedin_eq)
-
-lemma openin_diff[intro]: assumes oS: "openin U S" and cT: "closedin U T" shows "openin U (S - T)"
-proof-
- have "S - T = S \<inter> (topspace U - T)" using openin_subset[of U S] oS cT
- by (auto simp add: topspace_def openin_subset)
- then show ?thesis using oS cT by (auto simp add: closedin_def)
-qed
-
-lemma closedin_diff[intro]: assumes oS: "closedin U S" and cT: "openin U T" shows "closedin U (S - T)"
-proof-
- have "S - T = S \<inter> (topspace U - T)" using closedin_subset[of U S] oS cT
- by (auto simp add: topspace_def )
- then show ?thesis using oS cT by (auto simp add: openin_closedin_eq)
-qed
-
-subsection{* Subspace topology. *}
-
-definition "subtopology U V = topology {S \<inter> V |S. openin U S}"
-
-lemma istopology_subtopology: "istopology {S \<inter> V |S. openin U S}" (is "istopology ?L")
-proof-
- have "{} \<in> ?L" by blast
- {fix A B assume A: "A \<in> ?L" and B: "B \<in> ?L"
- from A B obtain Sa and Sb where Sa: "openin U Sa" "A = Sa \<inter> V" and Sb: "openin U Sb" "B = Sb \<inter> V" by blast
- have "A\<inter>B = (Sa \<inter> Sb) \<inter> V" "openin U (Sa \<inter> Sb)" using Sa Sb by blast+
- then have "A \<inter> B \<in> ?L" by blast}
- moreover
- {fix K assume K: "K \<subseteq> ?L"
- have th0: "?L = (\<lambda>S. S \<inter> V) ` openin U "
- apply (rule set_ext)
- apply (simp add: Ball_def image_iff)
- by (metis mem_def)
- from K[unfolded th0 subset_image_iff]
- obtain Sk where Sk: "Sk \<subseteq> openin U" "K = (\<lambda>S. S \<inter> V) ` Sk" by blast
- have "\<Union>K = (\<Union>Sk) \<inter> V" using Sk by auto
- moreover have "openin U (\<Union> Sk)" using Sk by (auto simp add: subset_eq mem_def)
- ultimately have "\<Union>K \<in> ?L" by blast}
- ultimately show ?thesis unfolding istopology_def by blast
-qed
-
-lemma openin_subtopology:
- "openin (subtopology U V) S \<longleftrightarrow> (\<exists> T. (openin U T) \<and> (S = T \<inter> V))"
- unfolding subtopology_def topology_inverse'[OF istopology_subtopology]
- by (auto simp add: Collect_def)
-
-lemma topspace_subtopology: "topspace(subtopology U V) = topspace U \<inter> V"
- by (auto simp add: topspace_def openin_subtopology)
-
-lemma closedin_subtopology:
- "closedin (subtopology U V) S \<longleftrightarrow> (\<exists>T. closedin U T \<and> S = T \<inter> V)"
- unfolding closedin_def topspace_subtopology
- apply (simp add: openin_subtopology)
- apply (rule iffI)
- apply clarify
- apply (rule_tac x="topspace U - T" in exI)
- by auto
-
-lemma openin_subtopology_refl: "openin (subtopology U V) V \<longleftrightarrow> V \<subseteq> topspace U"
- unfolding openin_subtopology
- apply (rule iffI, clarify)
- apply (frule openin_subset[of U]) apply blast
- apply (rule exI[where x="topspace U"])
- by auto
-
-lemma subtopology_superset: assumes UV: "topspace U \<subseteq> V"
- shows "subtopology U V = U"
-proof-
- {fix S
- {fix T assume T: "openin U T" "S = T \<inter> V"
- from T openin_subset[OF T(1)] UV have eq: "S = T" by blast
- have "openin U S" unfolding eq using T by blast}
- moreover
- {assume S: "openin U S"
- hence "\<exists>T. openin U T \<and> S = T \<inter> V"
- using openin_subset[OF S] UV by auto}
- ultimately have "(\<exists>T. openin U T \<and> S = T \<inter> V) \<longleftrightarrow> openin U S" by blast}
- then show ?thesis unfolding topology_eq openin_subtopology by blast
-qed
-
-
-lemma subtopology_topspace[simp]: "subtopology U (topspace U) = U"
- by (simp add: subtopology_superset)
-
-lemma subtopology_UNIV[simp]: "subtopology U UNIV = U"
- by (simp add: subtopology_superset)
-
-subsection{* The universal Euclidean versions are what we use most of the time *}
-
-definition
- euclidean :: "'a::topological_space topology" where
- "euclidean = topology open"
-
-lemma open_openin: "open S \<longleftrightarrow> openin euclidean S"
- unfolding euclidean_def
- apply (rule cong[where x=S and y=S])
- apply (rule topology_inverse[symmetric])
- apply (auto simp add: istopology_def)
- by (auto simp add: mem_def subset_eq)
-
-lemma topspace_euclidean: "topspace euclidean = UNIV"
- apply (simp add: topspace_def)
- apply (rule set_ext)
- by (auto simp add: open_openin[symmetric])
-
-lemma topspace_euclidean_subtopology[simp]: "topspace (subtopology euclidean S) = S"
- by (simp add: topspace_euclidean topspace_subtopology)
-
-lemma closed_closedin: "closed S \<longleftrightarrow> closedin euclidean S"
- by (simp add: closed_def closedin_def topspace_euclidean open_openin Compl_eq_Diff_UNIV)
-
-lemma open_subopen: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S)"
- by (simp add: open_openin openin_subopen[symmetric])
-
-subsection{* Open and closed balls. *}
-
-definition
- ball :: "'a::metric_space \<Rightarrow> real \<Rightarrow> 'a set" where
- "ball x e = {y. dist x y < e}"
-
-definition
- cball :: "'a::metric_space \<Rightarrow> real \<Rightarrow> 'a set" where
- "cball x e = {y. dist x y \<le> e}"
-
-lemma mem_ball[simp]: "y \<in> ball x e \<longleftrightarrow> dist x y < e" by (simp add: ball_def)
-lemma mem_cball[simp]: "y \<in> cball x e \<longleftrightarrow> dist x y \<le> e" by (simp add: cball_def)
-
-lemma mem_ball_0 [simp]:
- fixes x :: "'a::real_normed_vector"
- shows "x \<in> ball 0 e \<longleftrightarrow> norm x < e"
- by (simp add: dist_norm)
-
-lemma mem_cball_0 [simp]:
- fixes x :: "'a::real_normed_vector"
- shows "x \<in> cball 0 e \<longleftrightarrow> norm x \<le> e"
- by (simp add: dist_norm)
-
-lemma centre_in_cball[simp]: "x \<in> cball x e \<longleftrightarrow> 0\<le> e" by simp
-lemma ball_subset_cball[simp,intro]: "ball x e \<subseteq> cball x e" by (simp add: subset_eq)
-lemma subset_ball[intro]: "d <= e ==> ball x d \<subseteq> ball x e" by (simp add: subset_eq)
-lemma subset_cball[intro]: "d <= e ==> cball x d \<subseteq> cball x e" by (simp add: subset_eq)
-lemma ball_max_Un: "ball a (max r s) = ball a r \<union> ball a s"
- by (simp add: expand_set_eq) arith
-
-lemma ball_min_Int: "ball a (min r s) = ball a r \<inter> ball a s"
- by (simp add: expand_set_eq)
-
-subsection{* Topological properties of open balls *}
-
-lemma diff_less_iff: "(a::real) - b > 0 \<longleftrightarrow> a > b"
- "(a::real) - b < 0 \<longleftrightarrow> a < b"
- "a - b < c \<longleftrightarrow> a < c +b" "a - b > c \<longleftrightarrow> a > c +b" by arith+
-lemma diff_le_iff: "(a::real) - b \<ge> 0 \<longleftrightarrow> a \<ge> b" "(a::real) - b \<le> 0 \<longleftrightarrow> a \<le> b"
- "a - b \<le> c \<longleftrightarrow> a \<le> c +b" "a - b \<ge> c \<longleftrightarrow> a \<ge> c +b" by arith+
-
-lemma open_ball[intro, simp]: "open (ball x e)"
- unfolding open_dist ball_def Collect_def Ball_def mem_def
- unfolding dist_commute
- apply clarify
- apply (rule_tac x="e - dist xa x" in exI)
- using dist_triangle_alt[where z=x]
- apply (clarsimp simp add: diff_less_iff)
- apply atomize
- apply (erule_tac x="y" in allE)
- apply (erule_tac x="xa" in allE)
- by arith
-
-lemma centre_in_ball[simp]: "x \<in> ball x e \<longleftrightarrow> e > 0" by (metis mem_ball dist_self)
-lemma open_contains_ball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. ball x e \<subseteq> S)"
- unfolding open_dist subset_eq mem_ball Ball_def dist_commute ..
-
-lemma open_contains_ball_eq: "open S \<Longrightarrow> \<forall>x. x\<in>S \<longleftrightarrow> (\<exists>e>0. ball x e \<subseteq> S)"
- by (metis open_contains_ball subset_eq centre_in_ball)
-
-lemma ball_eq_empty[simp]: "ball x e = {} \<longleftrightarrow> e \<le> 0"
- unfolding mem_ball expand_set_eq
- apply (simp add: not_less)
- by (metis zero_le_dist order_trans dist_self)
-
-lemma ball_empty[intro]: "e \<le> 0 ==> ball x e = {}" by simp
-
-subsection{* Basic "localization" results are handy for connectedness. *}
-
-lemma openin_open: "openin (subtopology euclidean U) S \<longleftrightarrow> (\<exists>T. open T \<and> (S = U \<inter> T))"
- by (auto simp add: openin_subtopology open_openin[symmetric])
-
-lemma openin_open_Int[intro]: "open S \<Longrightarrow> openin (subtopology euclidean U) (U \<inter> S)"
- by (auto simp add: openin_open)
-
-lemma open_openin_trans[trans]:
- "open S \<Longrightarrow> open T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> openin (subtopology euclidean S) T"
- by (metis Int_absorb1 openin_open_Int)
-
-lemma open_subset: "S \<subseteq> T \<Longrightarrow> open S \<Longrightarrow> openin (subtopology euclidean T) S"
- by (auto simp add: openin_open)
-
-lemma closedin_closed: "closedin (subtopology euclidean U) S \<longleftrightarrow> (\<exists>T. closed T \<and> S = U \<inter> T)"
- by (simp add: closedin_subtopology closed_closedin Int_ac)
-
-lemma closedin_closed_Int: "closed S ==> closedin (subtopology euclidean U) (U \<inter> S)"
- by (metis closedin_closed)
-
-lemma closed_closedin_trans: "closed S \<Longrightarrow> closed T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> closedin (subtopology euclidean S) T"
- apply (subgoal_tac "S \<inter> T = T" )
- apply auto
- apply (frule closedin_closed_Int[of T S])
- by simp
-
-lemma closed_subset: "S \<subseteq> T \<Longrightarrow> closed S \<Longrightarrow> closedin (subtopology euclidean T) S"
- by (auto simp add: closedin_closed)
-
-lemma openin_euclidean_subtopology_iff:
- fixes S U :: "'a::metric_space set"
- shows "openin (subtopology euclidean U) S
- \<longleftrightarrow> S \<subseteq> U \<and> (\<forall>x\<in>S. \<exists>e>0. \<forall>x'\<in>U. dist x' x < e \<longrightarrow> x'\<in> S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume ?lhs hence ?rhs unfolding openin_subtopology open_openin[symmetric]
- by (simp add: open_dist) blast}
- moreover
- {assume SU: "S \<subseteq> U" and H: "\<And>x. x \<in> S \<Longrightarrow> \<exists>e>0. \<forall>x'\<in>U. dist x' x < e \<longrightarrow> x' \<in> S"
- from H obtain d where d: "\<And>x . x\<in> S \<Longrightarrow> d x > 0 \<and> (\<forall>x' \<in> U. dist x' x < d x \<longrightarrow> x' \<in> S)"
- by metis
- let ?T = "\<Union>{B. \<exists>x\<in>S. B = ball x (d x)}"
- have oT: "open ?T" by auto
- { fix x assume "x\<in>S"
- hence "x \<in> \<Union>{B. \<exists>x\<in>S. B = ball x (d x)}"
- apply simp apply(rule_tac x="ball x(d x)" in exI) apply auto
- by (rule d [THEN conjunct1])
- hence "x\<in> ?T \<inter> U" using SU and `x\<in>S` by auto }
- moreover
- { fix y assume "y\<in>?T"
- then obtain B where "y\<in>B" "B\<in>{B. \<exists>x\<in>S. B = ball x (d x)}" by auto
- then obtain x where "x\<in>S" and x:"y \<in> ball x (d x)" by auto
- assume "y\<in>U"
- hence "y\<in>S" using d[OF `x\<in>S`] and x by(auto simp add: dist_commute) }
- ultimately have "S = ?T \<inter> U" by blast
- with oT have ?lhs unfolding openin_subtopology open_openin[symmetric] by blast}
- ultimately show ?thesis by blast
-qed
-
-text{* These "transitivity" results are handy too. *}
-
-lemma openin_trans[trans]: "openin (subtopology euclidean T) S \<Longrightarrow> openin (subtopology euclidean U) T
- \<Longrightarrow> openin (subtopology euclidean U) S"
- unfolding open_openin openin_open by blast
-
-lemma openin_open_trans: "openin (subtopology euclidean T) S \<Longrightarrow> open T \<Longrightarrow> open S"
- by (auto simp add: openin_open intro: openin_trans)
-
-lemma closedin_trans[trans]:
- "closedin (subtopology euclidean T) S \<Longrightarrow>
- closedin (subtopology euclidean U) T
- ==> closedin (subtopology euclidean U) S"
- by (auto simp add: closedin_closed closed_closedin closed_Inter Int_assoc)
-
-lemma closedin_closed_trans: "closedin (subtopology euclidean T) S \<Longrightarrow> closed T \<Longrightarrow> closed S"
- by (auto simp add: closedin_closed intro: closedin_trans)
-
-subsection{* Connectedness *}
-
-definition "connected S \<longleftrightarrow>
- ~(\<exists>e1 e2. open e1 \<and> open e2 \<and> S \<subseteq> (e1 \<union> e2) \<and> (e1 \<inter> e2 \<inter> S = {})
- \<and> ~(e1 \<inter> S = {}) \<and> ~(e2 \<inter> S = {}))"
-
-lemma connected_local:
- "connected S \<longleftrightarrow> ~(\<exists>e1 e2.
- openin (subtopology euclidean S) e1 \<and>
- openin (subtopology euclidean S) e2 \<and>
- S \<subseteq> e1 \<union> e2 \<and>
- e1 \<inter> e2 = {} \<and>
- ~(e1 = {}) \<and>
- ~(e2 = {}))"
-unfolding connected_def openin_open by (safe, blast+)
-
-lemma exists_diff: "(\<exists>S. P(UNIV - S)) \<longleftrightarrow> (\<exists>S. P S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
-
- {assume "?lhs" hence ?rhs by blast }
- moreover
- {fix S assume H: "P S"
- have "S = UNIV - (UNIV - S)" by auto
- with H have "P (UNIV - (UNIV - S))" by metis }
- ultimately show ?thesis by metis
-qed
-
-lemma connected_clopen: "connected S \<longleftrightarrow>
- (\<forall>T. openin (subtopology euclidean S) T \<and>
- closedin (subtopology euclidean S) T \<longrightarrow> T = {} \<or> T = S)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- have " \<not> connected S \<longleftrightarrow> (\<exists>e1 e2. open e1 \<and> open (UNIV - e2) \<and> S \<subseteq> e1 \<union> (UNIV - e2) \<and> e1 \<inter> (UNIV - e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (UNIV - e2) \<inter> S \<noteq> {})"
- unfolding connected_def openin_open closedin_closed
- apply (subst exists_diff) by blast
- hence th0: "connected S \<longleftrightarrow> \<not> (\<exists>e2 e1. closed e2 \<and> open e1 \<and> S \<subseteq> e1 \<union> (UNIV - e2) \<and> e1 \<inter> (UNIV - e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (UNIV - e2) \<inter> S \<noteq> {})"
- (is " _ \<longleftrightarrow> \<not> (\<exists>e2 e1. ?P e2 e1)") apply (simp add: closed_def Compl_eq_Diff_UNIV) by metis
-
- have th1: "?rhs \<longleftrightarrow> \<not> (\<exists>t' t. closed t'\<and>t = S\<inter>t' \<and> t\<noteq>{} \<and> t\<noteq>S \<and> (\<exists>t'. open t' \<and> t = S \<inter> t'))"
- (is "_ \<longleftrightarrow> \<not> (\<exists>t' t. ?Q t' t)")
- unfolding connected_def openin_open closedin_closed by auto
- {fix e2
- {fix e1 have "?P e2 e1 \<longleftrightarrow> (\<exists>t. closed e2 \<and> t = S\<inter>e2 \<and> open e1 \<and> t = S\<inter>e1 \<and> t\<noteq>{} \<and> t\<noteq>S)"
- by auto}
- then have "(\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)" by metis}
- then have "\<forall>e2. (\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)" by blast
- then show ?thesis unfolding th0 th1 by simp
-qed
-
-lemma connected_empty[simp, intro]: "connected {}"
- by (simp add: connected_def)
-
-subsection{* Hausdorff and other separation properties *}
-
-class t0_space =
- assumes t0_space: "x \<noteq> y \<Longrightarrow> \<exists>U. open U \<and> \<not> (x \<in> U \<longleftrightarrow> y \<in> U)"
-
-class t1_space =
- assumes t1_space: "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<notin> U \<and> x \<notin> V \<and> y \<in> V"
-begin
-
-subclass t0_space
-proof
-qed (fast dest: t1_space)
-
-end
-
-text {* T2 spaces are also known as Hausdorff spaces. *}
-
-class t2_space =
- assumes hausdorff: "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
-begin
-
-subclass t1_space
-proof
-qed (fast dest: hausdorff)
-
-end
-
-instance metric_space \<subseteq> t2_space
-proof
- fix x y :: "'a::metric_space"
- assume xy: "x \<noteq> y"
- let ?U = "ball x (dist x y / 2)"
- let ?V = "ball y (dist x y / 2)"
- have th0: "\<And>d x y z. (d x z :: real) <= d x y + d y z \<Longrightarrow> d y z = d z y
- ==> ~(d x y * 2 < d x z \<and> d z y * 2 < d x z)" by arith
- have "open ?U \<and> open ?V \<and> x \<in> ?U \<and> y \<in> ?V \<and> ?U \<inter> ?V = {}"
- using dist_pos_lt[OF xy] th0[of dist,OF dist_triangle dist_commute]
- by (auto simp add: expand_set_eq)
- then show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
- by blast
-qed
-
-lemma separation_t2:
- fixes x y :: "'a::t2_space"
- shows "x \<noteq> y \<longleftrightarrow> (\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {})"
- using hausdorff[of x y] by blast
-
-lemma separation_t1:
- fixes x y :: "'a::t1_space"
- shows "x \<noteq> y \<longleftrightarrow> (\<exists>U V. open U \<and> open V \<and> x \<in>U \<and> y\<notin> U \<and> x\<notin>V \<and> y\<in>V)"
- using t1_space[of x y] by blast
-
-lemma separation_t0:
- fixes x y :: "'a::t0_space"
- shows "x \<noteq> y \<longleftrightarrow> (\<exists>U. open U \<and> ~(x\<in>U \<longleftrightarrow> y\<in>U))"
- using t0_space[of x y] by blast
-
-subsection{* Limit points *}
-
-definition
- islimpt:: "'a::topological_space \<Rightarrow> 'a set \<Rightarrow> bool"
- (infixr "islimpt" 60) where
- "x islimpt S \<longleftrightarrow> (\<forall>T. x\<in>T \<longrightarrow> open T \<longrightarrow> (\<exists>y\<in>S. y\<in>T \<and> y\<noteq>x))"
-
-lemma islimptI:
- assumes "\<And>T. x \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>y\<in>S. y \<in> T \<and> y \<noteq> x"
- shows "x islimpt S"
- using assms unfolding islimpt_def by auto
-
-lemma islimptE:
- assumes "x islimpt S" and "x \<in> T" and "open T"
- obtains y where "y \<in> S" and "y \<in> T" and "y \<noteq> x"
- using assms unfolding islimpt_def by auto
-
-lemma islimpt_subset: "x islimpt S \<Longrightarrow> S \<subseteq> T ==> x islimpt T" by (auto simp add: islimpt_def)
-
-lemma islimpt_approachable:
- fixes x :: "'a::metric_space"
- shows "x islimpt S \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e)"
- unfolding islimpt_def
- apply auto
- apply(erule_tac x="ball x e" in allE)
- apply auto
- apply(rule_tac x=y in bexI)
- apply (auto simp add: dist_commute)
- apply (simp add: open_dist, drule (1) bspec)
- apply (clarify, drule spec, drule (1) mp, auto)
- done
-
-lemma islimpt_approachable_le:
- fixes x :: "'a::metric_space"
- shows "x islimpt S \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in> S. x' \<noteq> x \<and> dist x' x <= e)"
- unfolding islimpt_approachable
- using approachable_lt_le[where f="\<lambda>x'. dist x' x" and P="\<lambda>x'. \<not> (x'\<in>S \<and> x'\<noteq>x)"]
- by metis (* FIXME: VERY slow! *)
-
-class perfect_space =
- (* FIXME: perfect_space should inherit from topological_space *)
- assumes islimpt_UNIV [simp, intro]: "(x::'a::metric_space) islimpt UNIV"
-
-lemma perfect_choose_dist:
- fixes x :: "'a::perfect_space"
- shows "0 < r \<Longrightarrow> \<exists>a. a \<noteq> x \<and> dist a x < r"
-using islimpt_UNIV [of x]
-by (simp add: islimpt_approachable)
-
-instance real :: perfect_space
-apply default
-apply (rule islimpt_approachable [THEN iffD2])
-apply (clarify, rule_tac x="x + e/2" in bexI)
-apply (auto simp add: dist_norm)
-done
-
-instance "^" :: (perfect_space, finite) perfect_space
-proof
- fix x :: "'a ^ 'b"
- {
- fix e :: real assume "0 < e"
- def a \<equiv> "x $ undefined"
- have "a islimpt UNIV" by (rule islimpt_UNIV)
- with `0 < e` obtain b where "b \<noteq> a" and "dist b a < e"
- unfolding islimpt_approachable by auto
- def y \<equiv> "Cart_lambda ((Cart_nth x)(undefined := b))"
- from `b \<noteq> a` have "y \<noteq> x"
- unfolding a_def y_def by (simp add: Cart_eq)
- from `dist b a < e` have "dist y x < e"
- unfolding dist_vector_def a_def y_def
- apply simp
- apply (rule le_less_trans [OF setL2_le_setsum [OF zero_le_dist]])
- apply (subst setsum_diff1' [where a=undefined], simp, simp, simp)
- done
- from `y \<noteq> x` and `dist y x < e`
- have "\<exists>y\<in>UNIV. y \<noteq> x \<and> dist y x < e" by auto
- }
- then show "x islimpt UNIV" unfolding islimpt_approachable by blast
-qed
-
-lemma closed_limpt: "closed S \<longleftrightarrow> (\<forall>x. x islimpt S \<longrightarrow> x \<in> S)"
- unfolding closed_def
- apply (subst open_subopen)
- apply (simp add: islimpt_def subset_eq Compl_eq_Diff_UNIV)
- by (metis DiffE DiffI UNIV_I insertCI insert_absorb mem_def)
-
-lemma islimpt_EMPTY[simp]: "\<not> x islimpt {}"
- unfolding islimpt_def by auto
-
-lemma closed_positive_orthant: "closed {x::real^'n::finite. \<forall>i. 0 \<le>x$i}"
-proof-
- let ?U = "UNIV :: 'n set"
- let ?O = "{x::real^'n. \<forall>i. x$i\<ge>0}"
- {fix x:: "real^'n" and i::'n assume H: "\<forall>e>0. \<exists>x'\<in>?O. x' \<noteq> x \<and> dist x' x < e"
- and xi: "x$i < 0"
- from xi have th0: "-x$i > 0" by arith
- from H[rule_format, OF th0] obtain x' where x': "x' \<in>?O" "x' \<noteq> x" "dist x' x < -x $ i" by blast
- have th:" \<And>b a (x::real). abs x <= b \<Longrightarrow> b <= a ==> ~(a + x < 0)" by arith
- have th': "\<And>x (y::real). x < 0 \<Longrightarrow> 0 <= y ==> abs x <= abs (y - x)" by arith
- have th1: "\<bar>x$i\<bar> \<le> \<bar>(x' - x)$i\<bar>" using x'(1) xi
- apply (simp only: vector_component)
- by (rule th') auto
- have th2: "\<bar>dist x x'\<bar> \<ge> \<bar>(x' - x)$i\<bar>" using component_le_norm[of "x'-x" i]
- apply (simp add: dist_norm) by norm
- from th[OF th1 th2] x'(3) have False by (simp add: dist_commute) }
- then show ?thesis unfolding closed_limpt islimpt_approachable
- unfolding not_le[symmetric] by blast
-qed
-
-lemma finite_set_avoid:
- fixes a :: "'a::metric_space"
- assumes fS: "finite S" shows "\<exists>d>0. \<forall>x\<in>S. x \<noteq> a \<longrightarrow> d <= dist a x"
-proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case apply auto by ferrack
-next
- case (2 x F)
- from 2 obtain d where d: "d >0" "\<forall>x\<in>F. x\<noteq>a \<longrightarrow> d \<le> dist a x" by blast
- {assume "x = a" hence ?case using d by auto }
- moreover
- {assume xa: "x\<noteq>a"
- let ?d = "min d (dist a x)"
- have dp: "?d > 0" using xa d(1) using dist_nz by auto
- from d have d': "\<forall>x\<in>F. x\<noteq>a \<longrightarrow> ?d \<le> dist a x" by auto
- with dp xa have ?case by(auto intro!: exI[where x="?d"]) }
- ultimately show ?case by blast
-qed
-
-lemma islimpt_finite:
- fixes S :: "'a::metric_space set"
- assumes fS: "finite S" shows "\<not> a islimpt S"
- unfolding islimpt_approachable
- using finite_set_avoid[OF fS, of a] by (metis dist_commute not_le)
-
-lemma islimpt_Un: "x islimpt (S \<union> T) \<longleftrightarrow> x islimpt S \<or> x islimpt T"
- apply (rule iffI)
- defer
- apply (metis Un_upper1 Un_upper2 islimpt_subset)
- unfolding islimpt_def
- apply (rule ccontr, clarsimp, rename_tac A B)
- apply (drule_tac x="A \<inter> B" in spec)
- apply (auto simp add: open_Int)
- done
-
-lemma discrete_imp_closed:
- fixes S :: "'a::metric_space set"
- assumes e: "0 < e" and d: "\<forall>x \<in> S. \<forall>y \<in> S. dist y x < e \<longrightarrow> y = x"
- shows "closed S"
-proof-
- {fix x assume C: "\<forall>e>0. \<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e"
- from e have e2: "e/2 > 0" by arith
- from C[rule_format, OF e2] obtain y where y: "y \<in> S" "y\<noteq>x" "dist y x < e/2" by blast
- let ?m = "min (e/2) (dist x y) "
- from e2 y(2) have mp: "?m > 0" by (simp add: dist_nz[THEN sym])
- from C[rule_format, OF mp] obtain z where z: "z \<in> S" "z\<noteq>x" "dist z x < ?m" by blast
- have th: "dist z y < e" using z y
- by (intro dist_triangle_lt [where z=x], simp)
- from d[rule_format, OF y(1) z(1) th] y z
- have False by (auto simp add: dist_commute)}
- then show ?thesis by (metis islimpt_approachable closed_limpt [where 'a='a])
-qed
-
-subsection{* Interior of a Set *}
-definition "interior S = {x. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S}"
-
-lemma interior_eq: "interior S = S \<longleftrightarrow> open S"
- apply (simp add: expand_set_eq interior_def)
- apply (subst (2) open_subopen) by (safe, blast+)
-
-lemma interior_open: "open S ==> (interior S = S)" by (metis interior_eq)
-
-lemma interior_empty[simp]: "interior {} = {}" by (simp add: interior_def)
-
-lemma open_interior[simp, intro]: "open(interior S)"
- apply (simp add: interior_def)
- apply (subst open_subopen) by blast
-
-lemma interior_interior[simp]: "interior(interior S) = interior S" by (metis interior_eq open_interior)
-lemma interior_subset: "interior S \<subseteq> S" by (auto simp add: interior_def)
-lemma subset_interior: "S \<subseteq> T ==> (interior S) \<subseteq> (interior T)" by (auto simp add: interior_def)
-lemma interior_maximal: "T \<subseteq> S \<Longrightarrow> open T ==> T \<subseteq> (interior S)" by (auto simp add: interior_def)
-lemma interior_unique: "T \<subseteq> S \<Longrightarrow> open T \<Longrightarrow> (\<forall>T'. T' \<subseteq> S \<and> open T' \<longrightarrow> T' \<subseteq> T) \<Longrightarrow> interior S = T"
- by (metis equalityI interior_maximal interior_subset open_interior)
-lemma mem_interior: "x \<in> interior S \<longleftrightarrow> (\<exists>e. 0 < e \<and> ball x e \<subseteq> S)"
- apply (simp add: interior_def)
- by (metis open_contains_ball centre_in_ball open_ball subset_trans)
-
-lemma open_subset_interior: "open S ==> S \<subseteq> interior T \<longleftrightarrow> S \<subseteq> T"
- by (metis interior_maximal interior_subset subset_trans)
-
-lemma interior_inter[simp]: "interior(S \<inter> T) = interior S \<inter> interior T"
- apply (rule equalityI, simp)
- apply (metis Int_lower1 Int_lower2 subset_interior)
- by (metis Int_mono interior_subset open_Int open_interior open_subset_interior)
-
-lemma interior_limit_point [intro]:
- fixes x :: "'a::perfect_space"
- assumes x: "x \<in> interior S" shows "x islimpt S"
-proof-
- from x obtain e where e: "e>0" "\<forall>x'. dist x x' < e \<longrightarrow> x' \<in> S"
- unfolding mem_interior subset_eq Ball_def mem_ball by blast
- {
- fix d::real assume d: "d>0"
- let ?m = "min d e"
- have mde2: "0 < ?m" using e(1) d(1) by simp
- from perfect_choose_dist [OF mde2, of x]
- obtain y where "y \<noteq> x" and "dist y x < ?m" by blast
- then have "dist y x < e" "dist y x < d" by simp_all
- from `dist y x < e` e(2) have "y \<in> S" by (simp add: dist_commute)
- have "\<exists>x'\<in>S. x'\<noteq> x \<and> dist x' x < d"
- using `y \<in> S` `y \<noteq> x` `dist y x < d` by fast
- }
- then show ?thesis unfolding islimpt_approachable by blast
-qed
-
-lemma interior_closed_Un_empty_interior:
- assumes cS: "closed S" and iT: "interior T = {}"
- shows "interior(S \<union> T) = interior S"
-proof
- show "interior S \<subseteq> interior (S\<union>T)"
- by (rule subset_interior, blast)
-next
- show "interior (S \<union> T) \<subseteq> interior S"
- proof
- fix x assume "x \<in> interior (S \<union> T)"
- then obtain R where "open R" "x \<in> R" "R \<subseteq> S \<union> T"
- unfolding interior_def by fast
- show "x \<in> interior S"
- proof (rule ccontr)
- assume "x \<notin> interior S"
- with `x \<in> R` `open R` obtain y where "y \<in> R - S"
- unfolding interior_def expand_set_eq by fast
- from `open R` `closed S` have "open (R - S)" by (rule open_Diff)
- from `R \<subseteq> S \<union> T` have "R - S \<subseteq> T" by fast
- from `y \<in> R - S` `open (R - S)` `R - S \<subseteq> T` `interior T = {}`
- show "False" unfolding interior_def by fast
- qed
- qed
-qed
-
-
-subsection{* Closure of a Set *}
-
-definition "closure S = S \<union> {x | x. x islimpt S}"
-
-lemma closure_interior: "closure S = UNIV - interior (UNIV - S)"
-proof-
- { fix x
- have "x\<in>UNIV - interior (UNIV - S) \<longleftrightarrow> x \<in> closure S" (is "?lhs = ?rhs")
- proof
- let ?exT = "\<lambda> y. (\<exists>T. open T \<and> y \<in> T \<and> T \<subseteq> UNIV - S)"
- assume "?lhs"
- hence *:"\<not> ?exT x"
- unfolding interior_def
- by simp
- { assume "\<not> ?rhs"
- hence False using *
- unfolding closure_def islimpt_def
- by blast
- }
- thus "?rhs"
- by blast
- next
- assume "?rhs" thus "?lhs"
- unfolding closure_def interior_def islimpt_def
- by blast
- qed
- }
- thus ?thesis
- by blast
-qed
-
-lemma interior_closure: "interior S = UNIV - (closure (UNIV - S))"
-proof-
- { fix x
- have "x \<in> interior S \<longleftrightarrow> x \<in> UNIV - (closure (UNIV - S))"
- unfolding interior_def closure_def islimpt_def
- by blast (* FIXME: VERY slow! *)
- }
- thus ?thesis
- by blast
-qed
-
-lemma closed_closure[simp, intro]: "closed (closure S)"
-proof-
- have "closed (UNIV - interior (UNIV -S))" by blast
- thus ?thesis using closure_interior[of S] by simp
-qed
-
-lemma closure_hull: "closure S = closed hull S"
-proof-
- have "S \<subseteq> closure S"
- unfolding closure_def
- by blast
- moreover
- have "closed (closure S)"
- using closed_closure[of S]
- by assumption
- moreover
- { fix t
- assume *:"S \<subseteq> t" "closed t"
- { fix x
- assume "x islimpt S"
- hence "x islimpt t" using *(1)
- using islimpt_subset[of x, of S, of t]
- by blast
- }
- with * have "closure S \<subseteq> t"
- unfolding closure_def
- using closed_limpt[of t]
- by auto
- }
- ultimately show ?thesis
- using hull_unique[of S, of "closure S", of closed]
- unfolding mem_def
- by simp
-qed
-
-lemma closure_eq: "closure S = S \<longleftrightarrow> closed S"
- unfolding closure_hull
- using hull_eq[of closed, unfolded mem_def, OF closed_Inter, of S]
- by (metis mem_def subset_eq)
-
-lemma closure_closed[simp]: "closed S \<Longrightarrow> closure S = S"
- using closure_eq[of S]
- by simp
-
-lemma closure_closure[simp]: "closure (closure S) = closure S"
- unfolding closure_hull
- using hull_hull[of closed S]
- by assumption
-
-lemma closure_subset: "S \<subseteq> closure S"
- unfolding closure_hull
- using hull_subset[of S closed]
- by assumption
-
-lemma subset_closure: "S \<subseteq> T \<Longrightarrow> closure S \<subseteq> closure T"
- unfolding closure_hull
- using hull_mono[of S T closed]
- by assumption
-
-lemma closure_minimal: "S \<subseteq> T \<Longrightarrow> closed T \<Longrightarrow> closure S \<subseteq> T"
- using hull_minimal[of S T closed]
- unfolding closure_hull mem_def
- by simp
-
-lemma closure_unique: "S \<subseteq> T \<and> closed T \<and> (\<forall> T'. S \<subseteq> T' \<and> closed T' \<longrightarrow> T \<subseteq> T') \<Longrightarrow> closure S = T"
- using hull_unique[of S T closed]
- unfolding closure_hull mem_def
- by simp
-
-lemma closure_empty[simp]: "closure {} = {}"
- using closed_empty closure_closed[of "{}"]
- by simp
-
-lemma closure_univ[simp]: "closure UNIV = UNIV"
- using closure_closed[of UNIV]
- by simp
-
-lemma closure_eq_empty: "closure S = {} \<longleftrightarrow> S = {}"
- using closure_empty closure_subset[of S]
- by blast
-
-lemma closure_subset_eq: "closure S \<subseteq> S \<longleftrightarrow> closed S"
- using closure_eq[of S] closure_subset[of S]
- by simp
-
-lemma open_inter_closure_eq_empty:
- "open S \<Longrightarrow> (S \<inter> closure T) = {} \<longleftrightarrow> S \<inter> T = {}"
- using open_subset_interior[of S "UNIV - T"]
- using interior_subset[of "UNIV - T"]
- unfolding closure_interior
- by auto
-
-lemma open_inter_closure_subset:
- "open S \<Longrightarrow> (S \<inter> (closure T)) \<subseteq> closure(S \<inter> T)"
-proof
- fix x
- assume as: "open S" "x \<in> S \<inter> closure T"
- { assume *:"x islimpt T"
- have "x islimpt (S \<inter> T)"
- proof (rule islimptI)
- fix A
- assume "x \<in> A" "open A"
- with as have "x \<in> A \<inter> S" "open (A \<inter> S)"
- by (simp_all add: open_Int)
- with * obtain y where "y \<in> T" "y \<in> A \<inter> S" "y \<noteq> x"
- by (rule islimptE)
- hence "y \<in> S \<inter> T" "y \<in> A \<and> y \<noteq> x"
- by simp_all
- thus "\<exists>y\<in>(S \<inter> T). y \<in> A \<and> y \<noteq> x" ..
- qed
- }
- then show "x \<in> closure (S \<inter> T)" using as
- unfolding closure_def
- by blast
-qed
-
-lemma closure_complement: "closure(UNIV - S) = UNIV - interior(S)"
-proof-
- have "S = UNIV - (UNIV - S)"
- by auto
- thus ?thesis
- unfolding closure_interior
- by auto
-qed
-
-lemma interior_complement: "interior(UNIV - S) = UNIV - closure(S)"
- unfolding closure_interior
- by blast
-
-subsection{* Frontier (aka boundary) *}
-
-definition "frontier S = closure S - interior S"
-
-lemma frontier_closed: "closed(frontier S)"
- by (simp add: frontier_def closed_Diff)
-
-lemma frontier_closures: "frontier S = (closure S) \<inter> (closure(UNIV - S))"
- by (auto simp add: frontier_def interior_closure)
-
-lemma frontier_straddle:
- fixes a :: "'a::metric_space"
- shows "a \<in> frontier S \<longleftrightarrow> (\<forall>e>0. (\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e))" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume "?lhs"
- { fix e::real
- assume "e > 0"
- let ?rhse = "(\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e)"
- { assume "a\<in>S"
- have "\<exists>x\<in>S. dist a x < e" using `e>0` `a\<in>S` by(rule_tac x=a in bexI) auto
- moreover have "\<exists>x. x \<notin> S \<and> dist a x < e" using `?lhs` `a\<in>S`
- unfolding frontier_closures closure_def islimpt_def using `e>0`
- by (auto, erule_tac x="ball a e" in allE, auto)
- ultimately have ?rhse by auto
- }
- moreover
- { assume "a\<notin>S"
- hence ?rhse using `?lhs`
- unfolding frontier_closures closure_def islimpt_def
- using open_ball[of a e] `e > 0`
- by (auto, erule_tac x = "ball a e" in allE, auto) (* FIXME: VERY slow! *)
- }
- ultimately have ?rhse by auto
- }
- thus ?rhs by auto
-next
- assume ?rhs
- moreover
- { fix T assume "a\<notin>S" and
- as:"\<forall>e>0. (\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e)" "a \<notin> S" "a \<in> T" "open T"
- from `open T` `a \<in> T` have "\<exists>e>0. ball a e \<subseteq> T" unfolding open_contains_ball[of T] by auto
- then obtain e where "e>0" "ball a e \<subseteq> T" by auto
- then obtain y where y:"y\<in>S" "dist a y < e" using as(1) by auto
- have "\<exists>y\<in>S. y \<in> T \<and> y \<noteq> a"
- using `dist a y < e` `ball a e \<subseteq> T` unfolding ball_def using `y\<in>S` `a\<notin>S` by auto
- }
- hence "a \<in> closure S" unfolding closure_def islimpt_def using `?rhs` by auto
- moreover
- { fix T assume "a \<in> T" "open T" "a\<in>S"
- then obtain e where "e>0" and balle: "ball a e \<subseteq> T" unfolding open_contains_ball using `?rhs` by auto
- obtain x where "x \<notin> S" "dist a x < e" using `?rhs` using `e>0` by auto
- hence "\<exists>y\<in>UNIV - S. y \<in> T \<and> y \<noteq> a" using balle `a\<in>S` unfolding ball_def by (rule_tac x=x in bexI)auto
- }
- hence "a islimpt (UNIV - S) \<or> a\<notin>S" unfolding islimpt_def by auto
- ultimately show ?lhs unfolding frontier_closures using closure_def[of "UNIV - S"] by auto
-qed
-
-lemma frontier_subset_closed: "closed S \<Longrightarrow> frontier S \<subseteq> S"
- by (metis frontier_def closure_closed Diff_subset)
-
-lemma frontier_empty: "frontier {} = {}"
- by (simp add: frontier_def closure_empty)
-
-lemma frontier_subset_eq: "frontier S \<subseteq> S \<longleftrightarrow> closed S"
-proof-
- { assume "frontier S \<subseteq> S"
- hence "closure S \<subseteq> S" using interior_subset unfolding frontier_def by auto
- hence "closed S" using closure_subset_eq by auto
- }
- thus ?thesis using frontier_subset_closed[of S] by auto
-qed
-
-lemma frontier_complement: "frontier(UNIV - S) = frontier S"
- by (auto simp add: frontier_def closure_complement interior_complement)
-
-lemma frontier_disjoint_eq: "frontier S \<inter> S = {} \<longleftrightarrow> open S"
- using frontier_complement frontier_subset_eq[of "UNIV - S"]
- unfolding open_closed Compl_eq_Diff_UNIV by auto
-
-subsection{* Common nets and The "within" modifier for nets. *}
-
-definition
- at_infinity :: "'a::real_normed_vector net" where
- "at_infinity = Abs_net (range (\<lambda>r. {x. r \<le> norm x}))"
-
-definition
- indirection :: "'a::real_normed_vector \<Rightarrow> 'a \<Rightarrow> 'a net" (infixr "indirection" 70) where
- "a indirection v = (at a) within {b. \<exists>c\<ge>0. b - a = scaleR c v}"
-
-text{* Prove That They are all nets. *}
-
-lemma Rep_net_at_infinity:
- "Rep_net at_infinity = range (\<lambda>r. {x. r \<le> norm x})"
-unfolding at_infinity_def
-apply (rule Abs_net_inverse')
-apply (rule image_nonempty, simp)
-apply (clarsimp, rename_tac r s)
-apply (rule_tac x="max r s" in exI, auto)
-done
-
-lemma within_UNIV: "net within UNIV = net"
- by (simp add: Rep_net_inject [symmetric] Rep_net_within)
-
-subsection{* Identify Trivial limits, where we can't approach arbitrarily closely. *}
-
-definition
- trivial_limit :: "'a net \<Rightarrow> bool" where
- "trivial_limit net \<longleftrightarrow> {} \<in> Rep_net net"
-
-lemma trivial_limit_within:
- shows "trivial_limit (at a within S) \<longleftrightarrow> \<not> a islimpt S"
-proof
- assume "trivial_limit (at a within S)"
- thus "\<not> a islimpt S"
- unfolding trivial_limit_def
- unfolding Rep_net_within Rep_net_at
- unfolding islimpt_def
- apply (clarsimp simp add: expand_set_eq)
- apply (rename_tac T, rule_tac x=T in exI)
- apply (clarsimp, drule_tac x=y in spec, simp)
- done
-next
- assume "\<not> a islimpt S"
- thus "trivial_limit (at a within S)"
- unfolding trivial_limit_def
- unfolding Rep_net_within Rep_net_at
- unfolding islimpt_def
- apply (clarsimp simp add: image_image)
- apply (rule_tac x=T in image_eqI)
- apply (auto simp add: expand_set_eq)
- done
-qed
-
-lemma trivial_limit_at_iff: "trivial_limit (at a) \<longleftrightarrow> \<not> a islimpt UNIV"
- using trivial_limit_within [of a UNIV]
- by (simp add: within_UNIV)
-
-lemma trivial_limit_at:
- fixes a :: "'a::perfect_space"
- shows "\<not> trivial_limit (at a)"
- by (simp add: trivial_limit_at_iff)
-
-lemma trivial_limit_at_infinity:
- "\<not> trivial_limit (at_infinity :: ('a::{real_normed_vector,zero_neq_one}) net)"
- (* FIXME: find a more appropriate type class *)
- unfolding trivial_limit_def Rep_net_at_infinity
- apply (clarsimp simp add: expand_set_eq)
- apply (drule_tac x="scaleR r (sgn 1)" in spec)
- apply (simp add: norm_sgn)
- done
-
-lemma trivial_limit_sequentially: "\<not> trivial_limit sequentially"
- by (auto simp add: trivial_limit_def Rep_net_sequentially)
-
-subsection{* Some property holds "sufficiently close" to the limit point. *}
-
-lemma eventually_at: (* FIXME: this replaces Limits.eventually_at *)
- "eventually P (at a) \<longleftrightarrow> (\<exists>d>0. \<forall>x. 0 < dist x a \<and> dist x a < d \<longrightarrow> P x)"
-unfolding eventually_at dist_nz by auto
-
-lemma eventually_at_infinity:
- "eventually P at_infinity \<longleftrightarrow> (\<exists>b. \<forall>x. norm x >= b \<longrightarrow> P x)"
-unfolding eventually_def Rep_net_at_infinity by auto
-
-lemma eventually_within: "eventually P (at a within S) \<longleftrightarrow>
- (\<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a < d \<longrightarrow> P x)"
-unfolding eventually_within eventually_at dist_nz by auto
-
-lemma eventually_within_le: "eventually P (at a within S) \<longleftrightarrow>
- (\<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a <= d \<longrightarrow> P x)" (is "?lhs = ?rhs")
-unfolding eventually_within
-apply safe
-apply (rule_tac x="d/2" in exI, simp)
-apply (rule_tac x="d" in exI, simp)
-done
-
-lemma eventually_happens: "eventually P net ==> trivial_limit net \<or> (\<exists>x. P x)"
- unfolding eventually_def trivial_limit_def
- using Rep_net_nonempty [of net] by auto
-
-lemma always_eventually: "(\<forall>x. P x) ==> eventually P net"
- unfolding eventually_def trivial_limit_def
- using Rep_net_nonempty [of net] by auto
-
-lemma trivial_limit_eventually: "trivial_limit net \<Longrightarrow> eventually P net"
- unfolding trivial_limit_def eventually_def by auto
-
-lemma eventually_False: "eventually (\<lambda>x. False) net \<longleftrightarrow> trivial_limit net"
- unfolding trivial_limit_def eventually_def by auto
-
-lemma trivial_limit_eq: "trivial_limit net \<longleftrightarrow> (\<forall>P. eventually P net)"
- apply (safe elim!: trivial_limit_eventually)
- apply (simp add: eventually_False [symmetric])
- done
-
-text{* Combining theorems for "eventually" *}
-
-lemma eventually_conjI:
- "\<lbrakk>eventually (\<lambda>x. P x) net; eventually (\<lambda>x. Q x) net\<rbrakk>
- \<Longrightarrow> eventually (\<lambda>x. P x \<and> Q x) net"
-by (rule eventually_conj)
-
-lemma eventually_rev_mono:
- "eventually P net \<Longrightarrow> (\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> eventually Q net"
-using eventually_mono [of P Q] by fast
-
-lemma eventually_and: " eventually (\<lambda>x. P x \<and> Q x) net \<longleftrightarrow> eventually P net \<and> eventually Q net"
- by (auto intro!: eventually_conjI elim: eventually_rev_mono)
-
-lemma eventually_false: "eventually (\<lambda>x. False) net \<longleftrightarrow> trivial_limit net"
- by (auto simp add: eventually_False)
-
-lemma not_eventually: "(\<forall>x. \<not> P x ) \<Longrightarrow> ~(trivial_limit net) ==> ~(eventually (\<lambda>x. P x) net)"
- by (simp add: eventually_False)
-
-subsection{* Limits, defined as vacuously true when the limit is trivial. *}
-
- text{* Notation Lim to avoid collition with lim defined in analysis *}
-definition
- Lim :: "'a net \<Rightarrow> ('a \<Rightarrow> 'b::t2_space) \<Rightarrow> 'b" where
- "Lim net f = (THE l. (f ---> l) net)"
-
-lemma Lim:
- "(f ---> l) net \<longleftrightarrow>
- trivial_limit net \<or>
- (\<forall>e>0. eventually (\<lambda>x. dist (f x) l < e) net)"
- unfolding tendsto_iff trivial_limit_eq by auto
-
-
-text{* Show that they yield usual definitions in the various cases. *}
-
-lemma Lim_within_le: "(f ---> l)(at a within S) \<longleftrightarrow>
- (\<forall>e>0. \<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a <= d \<longrightarrow> dist (f x) l < e)"
- by (auto simp add: tendsto_iff eventually_within_le)
-
-lemma Lim_within: "(f ---> l) (at a within S) \<longleftrightarrow>
- (\<forall>e >0. \<exists>d>0. \<forall>x \<in> S. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) l < e)"
- by (auto simp add: tendsto_iff eventually_within)
-
-lemma Lim_at: "(f ---> l) (at a) \<longleftrightarrow>
- (\<forall>e >0. \<exists>d>0. \<forall>x. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) l < e)"
- by (auto simp add: tendsto_iff eventually_at)
-
-lemma Lim_at_iff_LIM: "(f ---> l) (at a) \<longleftrightarrow> f -- a --> l"
- unfolding Lim_at LIM_def by (simp only: zero_less_dist_iff)
-
-lemma Lim_at_infinity:
- "(f ---> l) at_infinity \<longleftrightarrow> (\<forall>e>0. \<exists>b. \<forall>x. norm x >= b \<longrightarrow> dist (f x) l < e)"
- by (auto simp add: tendsto_iff eventually_at_infinity)
-
-lemma Lim_sequentially:
- "(S ---> l) sequentially \<longleftrightarrow>
- (\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (S n) l < e)"
- by (auto simp add: tendsto_iff eventually_sequentially)
-
-lemma Lim_sequentially_iff_LIMSEQ: "(S ---> l) sequentially \<longleftrightarrow> S ----> l"
- unfolding Lim_sequentially LIMSEQ_def ..
-
-lemma Lim_eventually: "eventually (\<lambda>x. f x = l) net \<Longrightarrow> (f ---> l) net"
- by (rule topological_tendstoI, auto elim: eventually_rev_mono)
-
-text{* The expected monotonicity property. *}
-
-lemma Lim_within_empty: "(f ---> l) (net within {})"
- unfolding tendsto_def Limits.eventually_within by simp
-
-lemma Lim_within_subset: "(f ---> l) (net within S) \<Longrightarrow> T \<subseteq> S \<Longrightarrow> (f ---> l) (net within T)"
- unfolding tendsto_def Limits.eventually_within
- by (auto elim!: eventually_elim1)
-
-lemma Lim_Un: assumes "(f ---> l) (net within S)" "(f ---> l) (net within T)"
- shows "(f ---> l) (net within (S \<union> T))"
- using assms unfolding tendsto_def Limits.eventually_within
- apply clarify
- apply (drule spec, drule (1) mp, drule (1) mp)
- apply (drule spec, drule (1) mp, drule (1) mp)
- apply (auto elim: eventually_elim2)
- done
-
-lemma Lim_Un_univ:
- "(f ---> l) (net within S) \<Longrightarrow> (f ---> l) (net within T) \<Longrightarrow> S \<union> T = UNIV
- ==> (f ---> l) net"
- by (metis Lim_Un within_UNIV)
-
-text{* Interrelations between restricted and unrestricted limits. *}
-
-lemma Lim_at_within: "(f ---> l) net ==> (f ---> l)(net within S)"
- (* FIXME: rename *)
- unfolding tendsto_def Limits.eventually_within
- apply (clarify, drule spec, drule (1) mp, drule (1) mp)
- by (auto elim!: eventually_elim1)
-
-lemma Lim_within_open:
- fixes f :: "'a::topological_space \<Rightarrow> 'b::topological_space"
- assumes"a \<in> S" "open S"
- shows "(f ---> l)(at a within S) \<longleftrightarrow> (f ---> l)(at a)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume ?lhs
- { fix A assume "open A" "l \<in> A"
- with `?lhs` have "eventually (\<lambda>x. f x \<in> A) (at a within S)"
- by (rule topological_tendstoD)
- hence "eventually (\<lambda>x. x \<in> S \<longrightarrow> f x \<in> A) (at a)"
- unfolding Limits.eventually_within .
- then obtain T where "open T" "a \<in> T" "\<forall>x\<in>T. x \<noteq> a \<longrightarrow> x \<in> S \<longrightarrow> f x \<in> A"
- unfolding eventually_at_topological by fast
- hence "open (T \<inter> S)" "a \<in> T \<inter> S" "\<forall>x\<in>(T \<inter> S). x \<noteq> a \<longrightarrow> f x \<in> A"
- using assms by auto
- hence "\<exists>T. open T \<and> a \<in> T \<and> (\<forall>x\<in>T. x \<noteq> a \<longrightarrow> f x \<in> A)"
- by fast
- hence "eventually (\<lambda>x. f x \<in> A) (at a)"
- unfolding eventually_at_topological .
- }
- thus ?rhs by (rule topological_tendstoI)
-next
- assume ?rhs
- thus ?lhs by (rule Lim_at_within)
-qed
-
-text{* Another limit point characterization. *}
-
-lemma islimpt_sequential:
- fixes x :: "'a::metric_space" (* FIXME: generalize to topological_space *)
- shows "x islimpt S \<longleftrightarrow> (\<exists>f. (\<forall>n::nat. f n \<in> S -{x}) \<and> (f ---> x) sequentially)"
- (is "?lhs = ?rhs")
-proof
- assume ?lhs
- then obtain f where f:"\<forall>y. y>0 \<longrightarrow> f y \<in> S \<and> f y \<noteq> x \<and> dist (f y) x < y"
- unfolding islimpt_approachable using choice[of "\<lambda>e y. e>0 \<longrightarrow> y\<in>S \<and> y\<noteq>x \<and> dist y x < e"] by auto
- { fix n::nat
- have "f (inverse (real n + 1)) \<in> S - {x}" using f by auto
- }
- moreover
- { fix e::real assume "e>0"
- hence "\<exists>N::nat. inverse (real (N + 1)) < e" using real_arch_inv[of e] apply (auto simp add: Suc_pred') apply(rule_tac x="n - 1" in exI) by auto
- then obtain N::nat where "inverse (real (N + 1)) < e" by auto
- hence "\<forall>n\<ge>N. inverse (real n + 1) < e" by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
- moreover have "\<forall>n\<ge>N. dist (f (inverse (real n + 1))) x < (inverse (real n + 1))" using f `e>0` by auto
- ultimately have "\<exists>N::nat. \<forall>n\<ge>N. dist (f (inverse (real n + 1))) x < e" apply(rule_tac x=N in exI) apply auto apply(erule_tac x=n in allE)+ by auto
- }
- hence " ((\<lambda>n. f (inverse (real n + 1))) ---> x) sequentially"
- unfolding Lim_sequentially using f by auto
- ultimately show ?rhs apply (rule_tac x="(\<lambda>n::nat. f (inverse (real n + 1)))" in exI) by auto
-next
- assume ?rhs
- then obtain f::"nat\<Rightarrow>'a" where f:"(\<forall>n. f n \<in> S - {x})" "(\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (f n) x < e)" unfolding Lim_sequentially by auto
- { fix e::real assume "e>0"
- then obtain N where "dist (f N) x < e" using f(2) by auto
- moreover have "f N\<in>S" "f N \<noteq> x" using f(1) by auto
- ultimately have "\<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e" by auto
- }
- thus ?lhs unfolding islimpt_approachable by auto
-qed
-
-text{* Basic arithmetical combining theorems for limits. *}
-
-lemma Lim_linear:
- assumes "(f ---> l) net" "bounded_linear h"
- shows "((\<lambda>x. h (f x)) ---> h l) net"
-using `bounded_linear h` `(f ---> l) net`
-by (rule bounded_linear.tendsto)
-
-lemma Lim_ident_at: "((\<lambda>x. x) ---> a) (at a)"
- unfolding tendsto_def Limits.eventually_at_topological by fast
-
-lemma Lim_const: "((\<lambda>x. a) ---> a) net"
- by (rule tendsto_const)
-
-lemma Lim_cmul:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- shows "(f ---> l) net ==> ((\<lambda>x. c *\<^sub>R f x) ---> c *\<^sub>R l) net"
- by (intro tendsto_intros)
-
-lemma Lim_neg:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- shows "(f ---> l) net ==> ((\<lambda>x. -(f x)) ---> -l) net"
- by (rule tendsto_minus)
-
-lemma Lim_add: fixes f :: "'a \<Rightarrow> 'b::real_normed_vector" shows
- "(f ---> l) net \<Longrightarrow> (g ---> m) net \<Longrightarrow> ((\<lambda>x. f(x) + g(x)) ---> l + m) net"
- by (rule tendsto_add)
-
-lemma Lim_sub:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- shows "(f ---> l) net \<Longrightarrow> (g ---> m) net \<Longrightarrow> ((\<lambda>x. f(x) - g(x)) ---> l - m) net"
- by (rule tendsto_diff)
-
-lemma Lim_null:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- shows "(f ---> l) net \<longleftrightarrow> ((\<lambda>x. f(x) - l) ---> 0) net" by (simp add: Lim dist_norm)
-
-lemma Lim_null_norm:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- shows "(f ---> 0) net \<longleftrightarrow> ((\<lambda>x. norm(f x)) ---> 0) net"
- by (simp add: Lim dist_norm)
-
-lemma Lim_null_comparison:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes "eventually (\<lambda>x. norm (f x) \<le> g x) net" "(g ---> 0) net"
- shows "(f ---> 0) net"
-proof(simp add: tendsto_iff, rule+)
- fix e::real assume "0<e"
- { fix x
- assume "norm (f x) \<le> g x" "dist (g x) 0 < e"
- hence "dist (f x) 0 < e" by (simp add: dist_norm)
- }
- thus "eventually (\<lambda>x. dist (f x) 0 < e) net"
- using eventually_and[of "\<lambda>x. norm(f x) <= g x" "\<lambda>x. dist (g x) 0 < e" net]
- using eventually_mono[of "(\<lambda>x. norm (f x) \<le> g x \<and> dist (g x) 0 < e)" "(\<lambda>x. dist (f x) 0 < e)" net]
- using assms `e>0` unfolding tendsto_iff by auto
-qed
-
-lemma Lim_component:
- fixes f :: "'a \<Rightarrow> 'b::metric_space ^ 'n::finite"
- shows "(f ---> l) net \<Longrightarrow> ((\<lambda>a. f a $i) ---> l$i) net"
- unfolding tendsto_iff
- apply (clarify)
- apply (drule spec, drule (1) mp)
- apply (erule eventually_elim1)
- apply (erule le_less_trans [OF dist_nth_le])
- done
-
-lemma Lim_transform_bound:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- fixes g :: "'a \<Rightarrow> 'c::real_normed_vector"
- assumes "eventually (\<lambda>n. norm(f n) <= norm(g n)) net" "(g ---> 0) net"
- shows "(f ---> 0) net"
-proof (rule tendstoI)
- fix e::real assume "e>0"
- { fix x
- assume "norm (f x) \<le> norm (g x)" "dist (g x) 0 < e"
- hence "dist (f x) 0 < e" by (simp add: dist_norm)}
- thus "eventually (\<lambda>x. dist (f x) 0 < e) net"
- using eventually_and[of "\<lambda>x. norm (f x) \<le> norm (g x)" "\<lambda>x. dist (g x) 0 < e" net]
- using eventually_mono[of "\<lambda>x. norm (f x) \<le> norm (g x) \<and> dist (g x) 0 < e" "\<lambda>x. dist (f x) 0 < e" net]
- using assms `e>0` unfolding tendsto_iff by blast
-qed
-
-text{* Deducing things about the limit from the elements. *}
-
-lemma Lim_in_closed_set:
- assumes "closed S" "eventually (\<lambda>x. f(x) \<in> S) net" "\<not>(trivial_limit net)" "(f ---> l) net"
- shows "l \<in> S"
-proof (rule ccontr)
- assume "l \<notin> S"
- with `closed S` have "open (- S)" "l \<in> - S"
- by (simp_all add: open_Compl)
- with assms(4) have "eventually (\<lambda>x. f x \<in> - S) net"
- by (rule topological_tendstoD)
- with assms(2) have "eventually (\<lambda>x. False) net"
- by (rule eventually_elim2) simp
- with assms(3) show "False"
- by (simp add: eventually_False)
-qed
-
-text{* Need to prove closed(cball(x,e)) before deducing this as a corollary. *}
-
-lemma Lim_dist_ubound:
- assumes "\<not>(trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. dist a (f x) <= e) net"
- shows "dist a l <= e"
-proof (rule ccontr)
- assume "\<not> dist a l \<le> e"
- then have "0 < dist a l - e" by simp
- with assms(2) have "eventually (\<lambda>x. dist (f x) l < dist a l - e) net"
- by (rule tendstoD)
- with assms(3) have "eventually (\<lambda>x. dist a (f x) \<le> e \<and> dist (f x) l < dist a l - e) net"
- by (rule eventually_conjI)
- then obtain w where "dist a (f w) \<le> e" "dist (f w) l < dist a l - e"
- using assms(1) eventually_happens by auto
- hence "dist a (f w) + dist (f w) l < e + (dist a l - e)"
- by (rule add_le_less_mono)
- hence "dist a (f w) + dist (f w) l < dist a l"
- by simp
- also have "\<dots> \<le> dist a (f w) + dist (f w) l"
- by (rule dist_triangle)
- finally show False by simp
-qed
-
-lemma Lim_norm_ubound:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes "\<not>(trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. norm(f x) <= e) net"
- shows "norm(l) <= e"
-proof (rule ccontr)
- assume "\<not> norm l \<le> e"
- then have "0 < norm l - e" by simp
- with assms(2) have "eventually (\<lambda>x. dist (f x) l < norm l - e) net"
- by (rule tendstoD)
- with assms(3) have "eventually (\<lambda>x. norm (f x) \<le> e \<and> dist (f x) l < norm l - e) net"
- by (rule eventually_conjI)
- then obtain w where "norm (f w) \<le> e" "dist (f w) l < norm l - e"
- using assms(1) eventually_happens by auto
- hence "norm (f w - l) < norm l - e" "norm (f w) \<le> e" by (simp_all add: dist_norm)
- hence "norm (f w - l) + norm (f w) < norm l" by simp
- hence "norm (f w - l - f w) < norm l" by (rule le_less_trans [OF norm_triangle_ineq4])
- thus False using `\<not> norm l \<le> e` by simp
-qed
-
-lemma Lim_norm_lbound:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes "\<not> (trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. e <= norm(f x)) net"
- shows "e \<le> norm l"
-proof (rule ccontr)
- assume "\<not> e \<le> norm l"
- then have "0 < e - norm l" by simp
- with assms(2) have "eventually (\<lambda>x. dist (f x) l < e - norm l) net"
- by (rule tendstoD)
- with assms(3) have "eventually (\<lambda>x. e \<le> norm (f x) \<and> dist (f x) l < e - norm l) net"
- by (rule eventually_conjI)
- then obtain w where "e \<le> norm (f w)" "dist (f w) l < e - norm l"
- using assms(1) eventually_happens by auto
- hence "norm (f w - l) + norm l < e" "e \<le> norm (f w)" by (simp_all add: dist_norm)
- hence "norm (f w - l) + norm l < norm (f w)" by (rule less_le_trans)
- hence "norm (f w - l + l) < norm (f w)" by (rule le_less_trans [OF norm_triangle_ineq])
- thus False by simp
-qed
-
-text{* Uniqueness of the limit, when nontrivial. *}
-
-lemma Lim_unique:
- fixes f :: "'a \<Rightarrow> 'b::t2_space"
- assumes "\<not> trivial_limit net" "(f ---> l) net" "(f ---> l') net"
- shows "l = l'"
-proof (rule ccontr)
- assume "l \<noteq> l'"
- obtain U V where "open U" "open V" "l \<in> U" "l' \<in> V" "U \<inter> V = {}"
- using hausdorff [OF `l \<noteq> l'`] by fast
- have "eventually (\<lambda>x. f x \<in> U) net"
- using `(f ---> l) net` `open U` `l \<in> U` by (rule topological_tendstoD)
- moreover
- have "eventually (\<lambda>x. f x \<in> V) net"
- using `(f ---> l') net` `open V` `l' \<in> V` by (rule topological_tendstoD)
- ultimately
- have "eventually (\<lambda>x. False) net"
- proof (rule eventually_elim2)
- fix x
- assume "f x \<in> U" "f x \<in> V"
- hence "f x \<in> U \<inter> V" by simp
- with `U \<inter> V = {}` show "False" by simp
- qed
- with `\<not> trivial_limit net` show "False"
- by (simp add: eventually_False)
-qed
-
-lemma tendsto_Lim:
- fixes f :: "'a \<Rightarrow> 'b::t2_space"
- shows "~(trivial_limit net) \<Longrightarrow> (f ---> l) net ==> Lim net f = l"
- unfolding Lim_def using Lim_unique[of net f] by auto
-
-text{* Limit under bilinear function *}
-
-lemma Lim_bilinear:
- assumes "(f ---> l) net" and "(g ---> m) net" and "bounded_bilinear h"
- shows "((\<lambda>x. h (f x) (g x)) ---> (h l m)) net"
-using `bounded_bilinear h` `(f ---> l) net` `(g ---> m) net`
-by (rule bounded_bilinear.tendsto)
-
-text{* These are special for limits out of the same vector space. *}
-
-lemma Lim_within_id: "(id ---> a) (at a within s)"
- unfolding tendsto_def Limits.eventually_within eventually_at_topological
- by auto
-
-lemma Lim_at_id: "(id ---> a) (at a)"
-apply (subst within_UNIV[symmetric]) by (simp add: Lim_within_id)
-
-lemma Lim_at_zero:
- fixes a :: "'a::real_normed_vector"
- fixes l :: "'b::topological_space"
- shows "(f ---> l) (at a) \<longleftrightarrow> ((\<lambda>x. f(a + x)) ---> l) (at 0)" (is "?lhs = ?rhs")
-proof
- assume "?lhs"
- { fix S assume "open S" "l \<in> S"
- with `?lhs` have "eventually (\<lambda>x. f x \<in> S) (at a)"
- by (rule topological_tendstoD)
- then obtain d where d: "d>0" "\<forall>x. x \<noteq> a \<and> dist x a < d \<longrightarrow> f x \<in> S"
- unfolding Limits.eventually_at by fast
- { fix x::"'a" assume "x \<noteq> 0 \<and> dist x 0 < d"
- hence "f (a + x) \<in> S" using d
- apply(erule_tac x="x+a" in allE)
- by(auto simp add: comm_monoid_add.mult_commute dist_norm dist_commute)
- }
- hence "\<exists>d>0. \<forall>x. x \<noteq> 0 \<and> dist x 0 < d \<longrightarrow> f (a + x) \<in> S"
- using d(1) by auto
- hence "eventually (\<lambda>x. f (a + x) \<in> S) (at 0)"
- unfolding Limits.eventually_at .
- }
- thus "?rhs" by (rule topological_tendstoI)
-next
- assume "?rhs"
- { fix S assume "open S" "l \<in> S"
- with `?rhs` have "eventually (\<lambda>x. f (a + x) \<in> S) (at 0)"
- by (rule topological_tendstoD)
- then obtain d where d: "d>0" "\<forall>x. x \<noteq> 0 \<and> dist x 0 < d \<longrightarrow> f (a + x) \<in> S"
- unfolding Limits.eventually_at by fast
- { fix x::"'a" assume "x \<noteq> a \<and> dist x a < d"
- hence "f x \<in> S" using d apply(erule_tac x="x-a" in allE)
- by(auto simp add: comm_monoid_add.mult_commute dist_norm dist_commute)
- }
- hence "\<exists>d>0. \<forall>x. x \<noteq> a \<and> dist x a < d \<longrightarrow> f x \<in> S" using d(1) by auto
- hence "eventually (\<lambda>x. f x \<in> S) (at a)" unfolding Limits.eventually_at .
- }
- thus "?lhs" by (rule topological_tendstoI)
-qed
-
-text{* It's also sometimes useful to extract the limit point from the net. *}
-
-definition
- netlimit :: "'a::t2_space net \<Rightarrow> 'a" where
- "netlimit net = (SOME a. ((\<lambda>x. x) ---> a) net)"
-
-lemma netlimit_within:
- assumes "\<not> trivial_limit (at a within S)"
- shows "netlimit (at a within S) = a"
-unfolding netlimit_def
-apply (rule some_equality)
-apply (rule Lim_at_within)
-apply (rule Lim_ident_at)
-apply (erule Lim_unique [OF assms])
-apply (rule Lim_at_within)
-apply (rule Lim_ident_at)
-done
-
-lemma netlimit_at:
- fixes a :: "'a::perfect_space"
- shows "netlimit (at a) = a"
- apply (subst within_UNIV[symmetric])
- using netlimit_within[of a UNIV]
- by (simp add: trivial_limit_at within_UNIV)
-
-text{* Transformation of limit. *}
-
-lemma Lim_transform:
- fixes f g :: "'a::type \<Rightarrow> 'b::real_normed_vector"
- assumes "((\<lambda>x. f x - g x) ---> 0) net" "(f ---> l) net"
- shows "(g ---> l) net"
-proof-
- from assms have "((\<lambda>x. f x - g x - f x) ---> 0 - l) net" using Lim_sub[of "\<lambda>x. f x - g x" 0 net f l] by auto
- thus "?thesis" using Lim_neg [of "\<lambda> x. - g x" "-l" net] by auto
-qed
-
-lemma Lim_transform_eventually:
- "eventually (\<lambda>x. f x = g x) net \<Longrightarrow> (f ---> l) net ==> (g ---> l) net"
- apply (rule topological_tendstoI)
- apply (drule (2) topological_tendstoD)
- apply (erule (1) eventually_elim2, simp)
- done
-
-lemma Lim_transform_within:
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- assumes "0 < d" "(\<forall>x'\<in>S. 0 < dist x' x \<and> dist x' x < d \<longrightarrow> f x' = g x')"
- "(f ---> l) (at x within S)"
- shows "(g ---> l) (at x within S)"
- using assms(1,3) unfolding Lim_within
- apply -
- apply (clarify, rename_tac e)
- apply (drule_tac x=e in spec, clarsimp, rename_tac r)
- apply (rule_tac x="min d r" in exI, clarsimp, rename_tac y)
- apply (drule_tac x=y in bspec, assumption, clarsimp)
- apply (simp add: assms(2))
- done
-
-lemma Lim_transform_at:
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- shows "0 < d \<Longrightarrow> (\<forall>x'. 0 < dist x' x \<and> dist x' x < d \<longrightarrow> f x' = g x') \<Longrightarrow>
- (f ---> l) (at x) ==> (g ---> l) (at x)"
- apply (subst within_UNIV[symmetric])
- using Lim_transform_within[of d UNIV x f g l]
- by (auto simp add: within_UNIV)
-
-text{* Common case assuming being away from some crucial point like 0. *}
-
-lemma Lim_transform_away_within:
- fixes a b :: "'a::metric_space"
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- assumes "a\<noteq>b" "\<forall>x\<in> S. x \<noteq> a \<and> x \<noteq> b \<longrightarrow> f x = g x"
- and "(f ---> l) (at a within S)"
- shows "(g ---> l) (at a within S)"
-proof-
- have "\<forall>x'\<in>S. 0 < dist x' a \<and> dist x' a < dist a b \<longrightarrow> f x' = g x'" using assms(2)
- apply auto apply(erule_tac x=x' in ballE) by (auto simp add: dist_commute)
- thus ?thesis using Lim_transform_within[of "dist a b" S a f g l] using assms(1,3) unfolding dist_nz by auto
-qed
-
-lemma Lim_transform_away_at:
- fixes a b :: "'a::metric_space"
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- assumes ab: "a\<noteq>b" and fg: "\<forall>x. x \<noteq> a \<and> x \<noteq> b \<longrightarrow> f x = g x"
- and fl: "(f ---> l) (at a)"
- shows "(g ---> l) (at a)"
- using Lim_transform_away_within[OF ab, of UNIV f g l] fg fl
- by (auto simp add: within_UNIV)
-
-text{* Alternatively, within an open set. *}
-
-lemma Lim_transform_within_open:
- fixes a :: "'a::metric_space"
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- assumes "open S" "a \<in> S" "\<forall>x\<in>S. x \<noteq> a \<longrightarrow> f x = g x" "(f ---> l) (at a)"
- shows "(g ---> l) (at a)"
-proof-
- from assms(1,2) obtain e::real where "e>0" and e:"ball a e \<subseteq> S" unfolding open_contains_ball by auto
- hence "\<forall>x'. 0 < dist x' a \<and> dist x' a < e \<longrightarrow> f x' = g x'" using assms(3)
- unfolding ball_def subset_eq apply auto apply(erule_tac x=x' in allE) apply(erule_tac x=x' in ballE) by(auto simp add: dist_commute)
- thus ?thesis using Lim_transform_at[of e a f g l] `e>0` assms(4) by auto
-qed
-
-text{* A congruence rule allowing us to transform limits assuming not at point. *}
-
-(* FIXME: Only one congruence rule for tendsto can be used at a time! *)
-
-lemma Lim_cong_within[cong add]:
- fixes a :: "'a::metric_space"
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- shows "(\<And>x. x \<noteq> a \<Longrightarrow> f x = g x) ==> ((\<lambda>x. f x) ---> l) (at a within S) \<longleftrightarrow> ((g ---> l) (at a within S))"
- by (simp add: Lim_within dist_nz[symmetric])
-
-lemma Lim_cong_at[cong add]:
- fixes a :: "'a::metric_space"
- fixes l :: "'b::metric_space" (* TODO: generalize *)
- shows "(\<And>x. x \<noteq> a ==> f x = g x) ==> (((\<lambda>x. f x) ---> l) (at a) \<longleftrightarrow> ((g ---> l) (at a)))"
- by (simp add: Lim_at dist_nz[symmetric])
-
-text{* Useful lemmas on closure and set of possible sequential limits.*}
-
-lemma closure_sequential:
- fixes l :: "'a::metric_space" (* TODO: generalize *)
- shows "l \<in> closure S \<longleftrightarrow> (\<exists>x. (\<forall>n. x n \<in> S) \<and> (x ---> l) sequentially)" (is "?lhs = ?rhs")
-proof
- assume "?lhs" moreover
- { assume "l \<in> S"
- hence "?rhs" using Lim_const[of l sequentially] by auto
- } moreover
- { assume "l islimpt S"
- hence "?rhs" unfolding islimpt_sequential by auto
- } ultimately
- show "?rhs" unfolding closure_def by auto
-next
- assume "?rhs"
- thus "?lhs" unfolding closure_def unfolding islimpt_sequential by auto
-qed
-
-lemma closed_sequential_limits:
- fixes S :: "'a::metric_space set"
- shows "closed S \<longleftrightarrow> (\<forall>x l. (\<forall>n. x n \<in> S) \<and> (x ---> l) sequentially \<longrightarrow> l \<in> S)"
- unfolding closed_limpt
- using closure_sequential [where 'a='a] closure_closed [where 'a='a] closed_limpt [where 'a='a] islimpt_sequential [where 'a='a] mem_delete [where 'a='a]
- by metis
-
-lemma closure_approachable:
- fixes S :: "'a::metric_space set"
- shows "x \<in> closure S \<longleftrightarrow> (\<forall>e>0. \<exists>y\<in>S. dist y x < e)"
- apply (auto simp add: closure_def islimpt_approachable)
- by (metis dist_self)
-
-lemma closed_approachable:
- fixes S :: "'a::metric_space set"
- shows "closed S ==> (\<forall>e>0. \<exists>y\<in>S. dist y x < e) \<longleftrightarrow> x \<in> S"
- by (metis closure_closed closure_approachable)
-
-text{* Some other lemmas about sequences. *}
-
-lemma seq_offset:
- fixes l :: "'a::metric_space" (* TODO: generalize *)
- shows "(f ---> l) sequentially ==> ((\<lambda>i. f( i + k)) ---> l) sequentially"
- apply (auto simp add: Lim_sequentially)
- by (metis trans_le_add1 )
-
-lemma seq_offset_neg:
- "(f ---> l) sequentially ==> ((\<lambda>i. f(i - k)) ---> l) sequentially"
- apply (rule topological_tendstoI)
- apply (drule (2) topological_tendstoD)
- apply (simp only: eventually_sequentially)
- apply (subgoal_tac "\<And>N k (n::nat). N + k <= n ==> N <= n - k")
- apply metis
- by arith
-
-lemma seq_offset_rev:
- "((\<lambda>i. f(i + k)) ---> l) sequentially ==> (f ---> l) sequentially"
- apply (rule topological_tendstoI)
- apply (drule (2) topological_tendstoD)
- apply (simp only: eventually_sequentially)
- apply (subgoal_tac "\<And>N k (n::nat). N + k <= n ==> N <= n - k \<and> (n - k) + k = n")
- by metis arith
-
-lemma seq_harmonic: "((\<lambda>n. inverse (real n)) ---> 0) sequentially"
-proof-
- { fix e::real assume "e>0"
- hence "\<exists>N::nat. \<forall>n::nat\<ge>N. inverse (real n) < e"
- using real_arch_inv[of e] apply auto apply(rule_tac x=n in exI)
- by (metis not_le le_imp_inverse_le not_less real_of_nat_gt_zero_cancel_iff real_of_nat_less_iff xt1(7))
- }
- thus ?thesis unfolding Lim_sequentially dist_norm by simp
-qed
-
-text{* More properties of closed balls. *}
-
-lemma closed_cball: "closed (cball x e)"
-unfolding cball_def closed_def
-unfolding Collect_neg_eq [symmetric] not_le
-apply (clarsimp simp add: open_dist, rename_tac y)
-apply (rule_tac x="dist x y - e" in exI, clarsimp)
-apply (rename_tac x')
-apply (cut_tac x=x and y=x' and z=y in dist_triangle)
-apply simp
-done
-
-lemma open_contains_cball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. cball x e \<subseteq> S)"
-proof-
- { fix x and e::real assume "x\<in>S" "e>0" "ball x e \<subseteq> S"
- hence "\<exists>d>0. cball x d \<subseteq> S" unfolding subset_eq by (rule_tac x="e/2" in exI, auto)
- } moreover
- { fix x and e::real assume "x\<in>S" "e>0" "cball x e \<subseteq> S"
- hence "\<exists>d>0. ball x d \<subseteq> S" unfolding subset_eq apply(rule_tac x="e/2" in exI) by auto
- } ultimately
- show ?thesis unfolding open_contains_ball by auto
-qed
-
-lemma open_contains_cball_eq: "open S ==> (\<forall>x. x \<in> S \<longleftrightarrow> (\<exists>e>0. cball x e \<subseteq> S))"
- by (metis open_contains_cball subset_eq order_less_imp_le centre_in_cball mem_def)
-
-lemma mem_interior_cball: "x \<in> interior S \<longleftrightarrow> (\<exists>e>0. cball x e \<subseteq> S)"
- apply (simp add: interior_def, safe)
- apply (force simp add: open_contains_cball)
- apply (rule_tac x="ball x e" in exI)
- apply (simp add: open_ball centre_in_ball subset_trans [OF ball_subset_cball])
- done
-
-lemma islimpt_ball:
- fixes x y :: "'a::{real_normed_vector,perfect_space}"
- shows "y islimpt ball x e \<longleftrightarrow> 0 < e \<and> y \<in> cball x e" (is "?lhs = ?rhs")
-proof
- assume "?lhs"
- { assume "e \<le> 0"
- hence *:"ball x e = {}" using ball_eq_empty[of x e] by auto
- have False using `?lhs` unfolding * using islimpt_EMPTY[of y] by auto
- }
- hence "e > 0" by (metis not_less)
- moreover
- have "y \<in> cball x e" using closed_cball[of x e] islimpt_subset[of y "ball x e" "cball x e"] ball_subset_cball[of x e] `?lhs` unfolding closed_limpt by auto
- ultimately show "?rhs" by auto
-next
- assume "?rhs" hence "e>0" by auto
- { fix d::real assume "d>0"
- have "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
- proof(cases "d \<le> dist x y")
- case True thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
- proof(cases "x=y")
- case True hence False using `d \<le> dist x y` `d>0` by auto
- thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d" by auto
- next
- case False
-
- have "dist x (y - (d / (2 * dist y x)) *\<^sub>R (y - x))
- = norm (x - y + (d / (2 * norm (y - x))) *\<^sub>R (y - x))"
- unfolding mem_cball mem_ball dist_norm diff_diff_eq2 diff_add_eq[THEN sym] by auto
- also have "\<dots> = \<bar>- 1 + d / (2 * norm (x - y))\<bar> * norm (x - y)"
- using scaleR_left_distrib[of "- 1" "d / (2 * norm (y - x))", THEN sym, of "y - x"]
- unfolding scaleR_minus_left scaleR_one
- by (auto simp add: norm_minus_commute)
- also have "\<dots> = \<bar>- norm (x - y) + d / 2\<bar>"
- unfolding abs_mult_pos[of "norm (x - y)", OF norm_ge_zero[of "x - y"]]
- unfolding real_add_mult_distrib using `x\<noteq>y`[unfolded dist_nz, unfolded dist_norm] by auto
- also have "\<dots> \<le> e - d/2" using `d \<le> dist x y` and `d>0` and `?rhs` by(auto simp add: dist_norm)
- finally have "y - (d / (2 * dist y x)) *\<^sub>R (y - x) \<in> ball x e" using `d>0` by auto
-
- moreover
-
- have "(d / (2*dist y x)) *\<^sub>R (y - x) \<noteq> 0"
- using `x\<noteq>y`[unfolded dist_nz] `d>0` unfolding scaleR_eq_0_iff by (auto simp add: dist_commute)
- moreover
- have "dist (y - (d / (2 * dist y x)) *\<^sub>R (y - x)) y < d" unfolding dist_norm apply simp unfolding norm_minus_cancel
- using `d>0` `x\<noteq>y`[unfolded dist_nz] dist_commute[of x y]
- unfolding dist_norm by auto
- ultimately show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d" by (rule_tac x="y - (d / (2*dist y x)) *\<^sub>R (y - x)" in bexI) auto
- qed
- next
- case False hence "d > dist x y" by auto
- show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
- proof(cases "x=y")
- case True
- obtain z where **: "z \<noteq> y" "dist z y < min e d"
- using perfect_choose_dist[of "min e d" y]
- using `d > 0` `e>0` by auto
- show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
- unfolding `x = y`
- using `z \<noteq> y` **
- by (rule_tac x=z in bexI, auto simp add: dist_commute)
- next
- case False thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
- using `d>0` `d > dist x y` `?rhs` by(rule_tac x=x in bexI, auto)
- qed
- qed }
- thus "?lhs" unfolding mem_cball islimpt_approachable mem_ball by auto
-qed
-
-lemma closure_ball_lemma:
- fixes x y :: "'a::real_normed_vector"
- assumes "x \<noteq> y" shows "y islimpt ball x (dist x y)"
-proof (rule islimptI)
- fix T assume "y \<in> T" "open T"
- then obtain r where "0 < r" "\<forall>z. dist z y < r \<longrightarrow> z \<in> T"
- unfolding open_dist by fast
- (* choose point between x and y, within distance r of y. *)
- def k \<equiv> "min 1 (r / (2 * dist x y))"
- def z \<equiv> "y + scaleR k (x - y)"
- have z_def2: "z = x + scaleR (1 - k) (y - x)"
- unfolding z_def by (simp add: algebra_simps)
- have "dist z y < r"
- unfolding z_def k_def using `0 < r`
- by (simp add: dist_norm min_def)
- hence "z \<in> T" using `\<forall>z. dist z y < r \<longrightarrow> z \<in> T` by simp
- have "dist x z < dist x y"
- unfolding z_def2 dist_norm
- apply (simp add: norm_minus_commute)
- apply (simp only: dist_norm [symmetric])
- apply (subgoal_tac "\<bar>1 - k\<bar> * dist x y < 1 * dist x y", simp)
- apply (rule mult_strict_right_mono)
- apply (simp add: k_def divide_pos_pos zero_less_dist_iff `0 < r` `x \<noteq> y`)
- apply (simp add: zero_less_dist_iff `x \<noteq> y`)
- done
- hence "z \<in> ball x (dist x y)" by simp
- have "z \<noteq> y"
- unfolding z_def k_def using `x \<noteq> y` `0 < r`
- by (simp add: min_def)
- show "\<exists>z\<in>ball x (dist x y). z \<in> T \<and> z \<noteq> y"
- using `z \<in> ball x (dist x y)` `z \<in> T` `z \<noteq> y`
- by fast
-qed
-
-lemma closure_ball:
- fixes x :: "'a::real_normed_vector"
- shows "0 < e \<Longrightarrow> closure (ball x e) = cball x e"
-apply (rule equalityI)
-apply (rule closure_minimal)
-apply (rule ball_subset_cball)
-apply (rule closed_cball)
-apply (rule subsetI, rename_tac y)
-apply (simp add: le_less [where 'a=real])
-apply (erule disjE)
-apply (rule subsetD [OF closure_subset], simp)
-apply (simp add: closure_def)
-apply clarify
-apply (rule closure_ball_lemma)
-apply (simp add: zero_less_dist_iff)
-done
-
-(* In a trivial vector space, this fails for e = 0. *)
-lemma interior_cball:
- fixes x :: "'a::{real_normed_vector, perfect_space}"
- shows "interior (cball x e) = ball x e"
-proof(cases "e\<ge>0")
- case False note cs = this
- from cs have "ball x e = {}" using ball_empty[of e x] by auto moreover
- { fix y assume "y \<in> cball x e"
- hence False unfolding mem_cball using dist_nz[of x y] cs by auto }
- hence "cball x e = {}" by auto
- hence "interior (cball x e) = {}" using interior_empty by auto
- ultimately show ?thesis by blast
-next
- case True note cs = this
- have "ball x e \<subseteq> cball x e" using ball_subset_cball by auto moreover
- { fix S y assume as: "S \<subseteq> cball x e" "open S" "y\<in>S"
- then obtain d where "d>0" and d:"\<forall>x'. dist x' y < d \<longrightarrow> x' \<in> S" unfolding open_dist by blast
-
- then obtain xa where xa_y: "xa \<noteq> y" and xa: "dist xa y < d"
- using perfect_choose_dist [of d] by auto
- have "xa\<in>S" using d[THEN spec[where x=xa]] using xa by(auto simp add: dist_commute)
- hence xa_cball:"xa \<in> cball x e" using as(1) by auto
-
- hence "y \<in> ball x e" proof(cases "x = y")
- case True
- hence "e>0" using xa_y[unfolded dist_nz] xa_cball[unfolded mem_cball] by (auto simp add: dist_commute)
- thus "y \<in> ball x e" using `x = y ` by simp
- next
- case False
- have "dist (y + (d / 2 / dist y x) *\<^sub>R (y - x)) y < d" unfolding dist_norm
- using `d>0` norm_ge_zero[of "y - x"] `x \<noteq> y` by auto
- hence *:"y + (d / 2 / dist y x) *\<^sub>R (y - x) \<in> cball x e" using d as(1)[unfolded subset_eq] by blast
- have "y - x \<noteq> 0" using `x \<noteq> y` by auto
- hence **:"d / (2 * norm (y - x)) > 0" unfolding zero_less_norm_iff[THEN sym]
- using `d>0` divide_pos_pos[of d "2*norm (y - x)"] by auto
-
- have "dist (y + (d / 2 / dist y x) *\<^sub>R (y - x)) x = norm (y + (d / (2 * norm (y - x))) *\<^sub>R y - (d / (2 * norm (y - x))) *\<^sub>R x - x)"
- by (auto simp add: dist_norm algebra_simps)
- also have "\<dots> = norm ((1 + d / (2 * norm (y - x))) *\<^sub>R (y - x))"
- by (auto simp add: algebra_simps)
- also have "\<dots> = \<bar>1 + d / (2 * norm (y - x))\<bar> * norm (y - x)"
- using ** by auto
- also have "\<dots> = (dist y x) + d/2"using ** by (auto simp add: left_distrib dist_norm)
- finally have "e \<ge> dist x y +d/2" using *[unfolded mem_cball] by (auto simp add: dist_commute)
- thus "y \<in> ball x e" unfolding mem_ball using `d>0` by auto
- qed }
- hence "\<forall>S \<subseteq> cball x e. open S \<longrightarrow> S \<subseteq> ball x e" by auto
- ultimately show ?thesis using interior_unique[of "ball x e" "cball x e"] using open_ball[of x e] by auto
-qed
-
-lemma frontier_ball:
- fixes a :: "'a::real_normed_vector"
- shows "0 < e ==> frontier(ball a e) = {x. dist a x = e}"
- apply (simp add: frontier_def closure_ball interior_open open_ball order_less_imp_le)
- apply (simp add: expand_set_eq)
- by arith
-
-lemma frontier_cball:
- fixes a :: "'a::{real_normed_vector, perfect_space}"
- shows "frontier(cball a e) = {x. dist a x = e}"
- apply (simp add: frontier_def interior_cball closed_cball closure_closed order_less_imp_le)
- apply (simp add: expand_set_eq)
- by arith
-
-lemma cball_eq_empty: "(cball x e = {}) \<longleftrightarrow> e < 0"
- apply (simp add: expand_set_eq not_le)
- by (metis zero_le_dist dist_self order_less_le_trans)
-lemma cball_empty: "e < 0 ==> cball x e = {}" by (simp add: cball_eq_empty)
-
-lemma cball_eq_sing:
- fixes x :: "'a::perfect_space"
- shows "(cball x e = {x}) \<longleftrightarrow> e = 0"
-proof (rule linorder_cases)
- assume e: "0 < e"
- obtain a where "a \<noteq> x" "dist a x < e"
- using perfect_choose_dist [OF e] by auto
- hence "a \<noteq> x" "dist x a \<le> e" by (auto simp add: dist_commute)
- with e show ?thesis by (auto simp add: expand_set_eq)
-qed auto
-
-lemma cball_sing:
- fixes x :: "'a::metric_space"
- shows "e = 0 ==> cball x e = {x}"
- by (auto simp add: expand_set_eq)
-
-text{* For points in the interior, localization of limits makes no difference. *}
-
-lemma eventually_within_interior:
- assumes "x \<in> interior S"
- shows "eventually P (at x within S) \<longleftrightarrow> eventually P (at x)" (is "?lhs = ?rhs")
-proof-
- from assms obtain T where T: "open T" "x \<in> T" "T \<subseteq> S"
- unfolding interior_def by fast
- { assume "?lhs"
- then obtain A where "open A" "x \<in> A" "\<forall>y\<in>A. y \<noteq> x \<longrightarrow> y \<in> S \<longrightarrow> P y"
- unfolding Limits.eventually_within Limits.eventually_at_topological
- by auto
- with T have "open (A \<inter> T)" "x \<in> A \<inter> T" "\<forall>y\<in>(A \<inter> T). y \<noteq> x \<longrightarrow> P y"
- by auto
- then have "?rhs"
- unfolding Limits.eventually_at_topological by auto
- } moreover
- { assume "?rhs" hence "?lhs"
- unfolding Limits.eventually_within
- by (auto elim: eventually_elim1)
- } ultimately
- show "?thesis" ..
-qed
-
-lemma lim_within_interior:
- "x \<in> interior S \<Longrightarrow> (f ---> l) (at x within S) \<longleftrightarrow> (f ---> l) (at x)"
- unfolding tendsto_def by (simp add: eventually_within_interior)
-
-lemma netlimit_within_interior:
- fixes x :: "'a::{perfect_space, real_normed_vector}"
- (* FIXME: generalize to perfect_space *)
- assumes "x \<in> interior S"
- shows "netlimit(at x within S) = x" (is "?lhs = ?rhs")
-proof-
- from assms obtain e::real where e:"e>0" "ball x e \<subseteq> S" using open_interior[of S] unfolding open_contains_ball using interior_subset[of S] by auto
- hence "\<not> trivial_limit (at x within S)" using islimpt_subset[of x "ball x e" S] unfolding trivial_limit_within islimpt_ball centre_in_cball by auto
- thus ?thesis using netlimit_within by auto
-qed
-
-subsection{* Boundedness. *}
-
- (* FIXME: This has to be unified with BSEQ!! *)
-definition
- bounded :: "'a::metric_space set \<Rightarrow> bool" where
- "bounded S \<longleftrightarrow> (\<exists>x e. \<forall>y\<in>S. dist x y \<le> e)"
-
-lemma bounded_any_center: "bounded S \<longleftrightarrow> (\<exists>e. \<forall>y\<in>S. dist a y \<le> e)"
-unfolding bounded_def
-apply safe
-apply (rule_tac x="dist a x + e" in exI, clarify)
-apply (drule (1) bspec)
-apply (erule order_trans [OF dist_triangle add_left_mono])
-apply auto
-done
-
-lemma bounded_iff: "bounded S \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. norm x \<le> a)"
-unfolding bounded_any_center [where a=0]
-by (simp add: dist_norm)
-
-lemma bounded_empty[simp]: "bounded {}" by (simp add: bounded_def)
-lemma bounded_subset: "bounded T \<Longrightarrow> S \<subseteq> T ==> bounded S"
- by (metis bounded_def subset_eq)
-
-lemma bounded_interior[intro]: "bounded S ==> bounded(interior S)"
- by (metis bounded_subset interior_subset)
-
-lemma bounded_closure[intro]: assumes "bounded S" shows "bounded(closure S)"
-proof-
- from assms obtain x and a where a: "\<forall>y\<in>S. dist x y \<le> a" unfolding bounded_def by auto
- { fix y assume "y \<in> closure S"
- then obtain f where f: "\<forall>n. f n \<in> S" "(f ---> y) sequentially"
- unfolding closure_sequential by auto
- have "\<forall>n. f n \<in> S \<longrightarrow> dist x (f n) \<le> a" using a by simp
- hence "eventually (\<lambda>n. dist x (f n) \<le> a) sequentially"
- by (rule eventually_mono, simp add: f(1))
- have "dist x y \<le> a"
- apply (rule Lim_dist_ubound [of sequentially f])
- apply (rule trivial_limit_sequentially)
- apply (rule f(2))
- apply fact
- done
- }
- thus ?thesis unfolding bounded_def by auto
-qed
-
-lemma bounded_cball[simp,intro]: "bounded (cball x e)"
- apply (simp add: bounded_def)
- apply (rule_tac x=x in exI)
- apply (rule_tac x=e in exI)
- apply auto
- done
-
-lemma bounded_ball[simp,intro]: "bounded(ball x e)"
- by (metis ball_subset_cball bounded_cball bounded_subset)
-
-lemma finite_imp_bounded[intro]: assumes "finite S" shows "bounded S"
-proof-
- { fix a F assume as:"bounded F"
- then obtain x e where "\<forall>y\<in>F. dist x y \<le> e" unfolding bounded_def by auto
- hence "\<forall>y\<in>(insert a F). dist x y \<le> max e (dist x a)" by auto
- hence "bounded (insert a F)" unfolding bounded_def by (intro exI)
- }
- thus ?thesis using finite_induct[of S bounded] using bounded_empty assms by auto
-qed
-
-lemma bounded_Un[simp]: "bounded (S \<union> T) \<longleftrightarrow> bounded S \<and> bounded T"
- apply (auto simp add: bounded_def)
- apply (rename_tac x y r s)
- apply (rule_tac x=x in exI)
- apply (rule_tac x="max r (dist x y + s)" in exI)
- apply (rule ballI, rename_tac z, safe)
- apply (drule (1) bspec, simp)
- apply (drule (1) bspec)
- apply (rule min_max.le_supI2)
- apply (erule order_trans [OF dist_triangle add_left_mono])
- done
-
-lemma bounded_Union[intro]: "finite F \<Longrightarrow> (\<forall>S\<in>F. bounded S) \<Longrightarrow> bounded(\<Union>F)"
- by (induct rule: finite_induct[of F], auto)
-
-lemma bounded_pos: "bounded S \<longleftrightarrow> (\<exists>b>0. \<forall>x\<in> S. norm x <= b)"
- apply (simp add: bounded_iff)
- apply (subgoal_tac "\<And>x (y::real). 0 < 1 + abs y \<and> (x <= y \<longrightarrow> x <= 1 + abs y)")
- by metis arith
-
-lemma bounded_Int[intro]: "bounded S \<or> bounded T \<Longrightarrow> bounded (S \<inter> T)"
- by (metis Int_lower1 Int_lower2 bounded_subset)
-
-lemma bounded_diff[intro]: "bounded S ==> bounded (S - T)"
-apply (metis Diff_subset bounded_subset)
-done
-
-lemma bounded_insert[intro]:"bounded(insert x S) \<longleftrightarrow> bounded S"
- by (metis Diff_cancel Un_empty_right Un_insert_right bounded_Un bounded_subset finite.emptyI finite_imp_bounded infinite_remove subset_insertI)
-
-lemma not_bounded_UNIV[simp, intro]:
- "\<not> bounded (UNIV :: 'a::{real_normed_vector, perfect_space} set)"
-proof(auto simp add: bounded_pos not_le)
- obtain x :: 'a where "x \<noteq> 0"
- using perfect_choose_dist [OF zero_less_one] by fast
- fix b::real assume b: "b >0"
- have b1: "b +1 \<ge> 0" using b by simp
- with `x \<noteq> 0` have "b < norm (scaleR (b + 1) (sgn x))"
- by (simp add: norm_sgn)
- then show "\<exists>x::'a. b < norm x" ..
-qed
-
-lemma bounded_linear_image:
- assumes "bounded S" "bounded_linear f"
- shows "bounded(f ` S)"
-proof-
- from assms(1) obtain b where b:"b>0" "\<forall>x\<in>S. norm x \<le> b" unfolding bounded_pos by auto
- from assms(2) obtain B where B:"B>0" "\<forall>x. norm (f x) \<le> B * norm x" using bounded_linear.pos_bounded by (auto simp add: mult_ac)
- { fix x assume "x\<in>S"
- hence "norm x \<le> b" using b by auto
- hence "norm (f x) \<le> B * b" using B(2) apply(erule_tac x=x in allE)
- by (metis B(1) B(2) real_le_trans real_mult_le_cancel_iff2)
- }
- thus ?thesis unfolding bounded_pos apply(rule_tac x="b*B" in exI)
- using b B real_mult_order[of b B] by (auto simp add: real_mult_commute)
-qed
-
-lemma bounded_scaling:
- fixes S :: "'a::real_normed_vector set"
- shows "bounded S \<Longrightarrow> bounded ((\<lambda>x. c *\<^sub>R x) ` S)"
- apply (rule bounded_linear_image, assumption)
- apply (rule scaleR.bounded_linear_right)
- done
-
-lemma bounded_translation:
- fixes S :: "'a::real_normed_vector set"
- assumes "bounded S" shows "bounded ((\<lambda>x. a + x) ` S)"
-proof-
- from assms obtain b where b:"b>0" "\<forall>x\<in>S. norm x \<le> b" unfolding bounded_pos by auto
- { fix x assume "x\<in>S"
- hence "norm (a + x) \<le> b + norm a" using norm_triangle_ineq[of a x] b by auto
- }
- thus ?thesis unfolding bounded_pos using norm_ge_zero[of a] b(1) using add_strict_increasing[of b 0 "norm a"]
- by (auto intro!: add exI[of _ "b + norm a"])
-qed
-
-
-text{* Some theorems on sups and infs using the notion "bounded". *}
-
-lemma bounded_real:
- fixes S :: "real set"
- shows "bounded S \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. abs x <= a)"
- by (simp add: bounded_iff)
-
-lemma bounded_has_Sup:
- fixes S :: "real set"
- assumes "bounded S" "S \<noteq> {}"
- shows "\<forall>x\<in>S. x <= Sup S" and "\<forall>b. (\<forall>x\<in>S. x <= b) \<longrightarrow> Sup S <= b"
-proof
- fix x assume "x\<in>S"
- thus "x \<le> Sup S"
- by (metis SupInf.Sup_upper abs_le_D1 assms(1) bounded_real)
-next
- show "\<forall>b. (\<forall>x\<in>S. x \<le> b) \<longrightarrow> Sup S \<le> b" using assms
- by (metis SupInf.Sup_least)
-qed
-
-lemma Sup_insert:
- fixes S :: "real set"
- shows "bounded S ==> Sup(insert x S) = (if S = {} then x else max x (Sup S))"
-by auto (metis Int_absorb Sup_insert_nonempty assms bounded_has_Sup(1) disjoint_iff_not_equal)
-
-lemma Sup_insert_finite:
- fixes S :: "real set"
- shows "finite S \<Longrightarrow> Sup(insert x S) = (if S = {} then x else max x (Sup S))"
- apply (rule Sup_insert)
- apply (rule finite_imp_bounded)
- by simp
-
-lemma bounded_has_Inf:
- fixes S :: "real set"
- assumes "bounded S" "S \<noteq> {}"
- shows "\<forall>x\<in>S. x >= Inf S" and "\<forall>b. (\<forall>x\<in>S. x >= b) \<longrightarrow> Inf S >= b"
-proof
- fix x assume "x\<in>S"
- from assms(1) obtain a where a:"\<forall>x\<in>S. \<bar>x\<bar> \<le> a" unfolding bounded_real by auto
- thus "x \<ge> Inf S" using `x\<in>S`
- by (metis Inf_lower_EX abs_le_D2 minus_le_iff)
-next
- show "\<forall>b. (\<forall>x\<in>S. x >= b) \<longrightarrow> Inf S \<ge> b" using assms
- by (metis SupInf.Inf_greatest)
-qed
-
-lemma Inf_insert:
- fixes S :: "real set"
- shows "bounded S ==> Inf(insert x S) = (if S = {} then x else min x (Inf S))"
-by auto (metis Int_absorb Inf_insert_nonempty bounded_has_Inf(1) disjoint_iff_not_equal)
-lemma Inf_insert_finite:
- fixes S :: "real set"
- shows "finite S ==> Inf(insert x S) = (if S = {} then x else min x (Inf S))"
- by (rule Inf_insert, rule finite_imp_bounded, simp)
-
-
-(* TODO: Move this to RComplete.thy -- would need to include Glb into RComplete *)
-lemma real_isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::real)"
- apply (frule isGlb_isLb)
- apply (frule_tac x = y in isGlb_isLb)
- apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
- done
-
-subsection{* Compactness (the definition is the one based on convegent subsequences). *}
-
-definition
- compact :: "'a::metric_space set \<Rightarrow> bool" where (* TODO: generalize *)
- "compact S \<longleftrightarrow>
- (\<forall>f. (\<forall>n. f n \<in> S) \<longrightarrow>
- (\<exists>l\<in>S. \<exists>r. subseq r \<and> ((f o r) ---> l) sequentially))"
-
-text {*
- A metric space (or topological vector space) is said to have the
- Heine-Borel property if every closed and bounded subset is compact.
-*}
-
-class heine_borel =
- assumes bounded_imp_convergent_subsequence:
- "bounded s \<Longrightarrow> \<forall>n. f n \<in> s
- \<Longrightarrow> \<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
-
-lemma bounded_closed_imp_compact:
- fixes s::"'a::heine_borel set"
- assumes "bounded s" and "closed s" shows "compact s"
-proof (unfold compact_def, clarify)
- fix f :: "nat \<Rightarrow> 'a" assume f: "\<forall>n. f n \<in> s"
- obtain l r where r: "subseq r" and l: "((f \<circ> r) ---> l) sequentially"
- using bounded_imp_convergent_subsequence [OF `bounded s` `\<forall>n. f n \<in> s`] by auto
- from f have fr: "\<forall>n. (f \<circ> r) n \<in> s" by simp
- have "l \<in> s" using `closed s` fr l
- unfolding closed_sequential_limits by blast
- show "\<exists>l\<in>s. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
- using `l \<in> s` r l by blast
-qed
-
-lemma subseq_bigger: assumes "subseq r" shows "n \<le> r n"
-proof(induct n)
- show "0 \<le> r 0" by auto
-next
- fix n assume "n \<le> r n"
- moreover have "r n < r (Suc n)"
- using assms [unfolded subseq_def] by auto
- ultimately show "Suc n \<le> r (Suc n)" by auto
-qed
-
-lemma eventually_subseq:
- assumes r: "subseq r"
- shows "eventually P sequentially \<Longrightarrow> eventually (\<lambda>n. P (r n)) sequentially"
-unfolding eventually_sequentially
-by (metis subseq_bigger [OF r] le_trans)
-
-lemma lim_subseq:
- "subseq r \<Longrightarrow> (s ---> l) sequentially \<Longrightarrow> ((s o r) ---> l) sequentially"
-unfolding tendsto_def eventually_sequentially o_def
-by (metis subseq_bigger le_trans)
-
-lemma num_Axiom: "EX! g. g 0 = e \<and> (\<forall>n. g (Suc n) = f n (g n))"
- unfolding Ex1_def
- apply (rule_tac x="nat_rec e f" in exI)
- apply (rule conjI)+
-apply (rule def_nat_rec_0, simp)
-apply (rule allI, rule def_nat_rec_Suc, simp)
-apply (rule allI, rule impI, rule ext)
-apply (erule conjE)
-apply (induct_tac x)
-apply (simp add: nat_rec_0)
-apply (erule_tac x="n" in allE)
-apply (simp)
-done
-
-lemma convergent_bounded_increasing: fixes s ::"nat\<Rightarrow>real"
- assumes "incseq s" and "\<forall>n. abs(s n) \<le> b"
- shows "\<exists> l. \<forall>e::real>0. \<exists> N. \<forall>n \<ge> N. abs(s n - l) < e"
-proof-
- have "isUb UNIV (range s) b" using assms(2) and abs_le_D1 unfolding isUb_def and setle_def by auto
- then obtain t where t:"isLub UNIV (range s) t" using reals_complete[of "range s" ] by auto
- { fix e::real assume "e>0" and as:"\<forall>N. \<exists>n\<ge>N. \<not> \<bar>s n - t\<bar> < e"
- { fix n::nat
- obtain N where "N\<ge>n" and n:"\<bar>s N - t\<bar> \<ge> e" using as[THEN spec[where x=n]] by auto
- have "t \<ge> s N" using isLub_isUb[OF t, unfolded isUb_def setle_def] by auto
- with n have "s N \<le> t - e" using `e>0` by auto
- hence "s n \<le> t - e" using assms(1)[unfolded incseq_def, THEN spec[where x=n], THEN spec[where x=N]] using `n\<le>N` by auto }
- hence "isUb UNIV (range s) (t - e)" unfolding isUb_def and setle_def by auto
- hence False using isLub_le_isUb[OF t, of "t - e"] and `e>0` by auto }
- thus ?thesis by blast
-qed
-
-lemma convergent_bounded_monotone: fixes s::"nat \<Rightarrow> real"
- assumes "\<forall>n. abs(s n) \<le> b" and "monoseq s"
- shows "\<exists>l. \<forall>e::real>0. \<exists>N. \<forall>n\<ge>N. abs(s n - l) < e"
- using convergent_bounded_increasing[of s b] assms using convergent_bounded_increasing[of "\<lambda>n. - s n" b]
- unfolding monoseq_def incseq_def
- apply auto unfolding minus_add_distrib[THEN sym, unfolded diff_minus[THEN sym]]
- unfolding abs_minus_cancel by(rule_tac x="-l" in exI)auto
-
-lemma compact_real_lemma:
- assumes "\<forall>n::nat. abs(s n) \<le> b"
- shows "\<exists>(l::real) r. subseq r \<and> ((s \<circ> r) ---> l) sequentially"
-proof-
- obtain r where r:"subseq r" "monoseq (\<lambda>n. s (r n))"
- using seq_monosub[of s] by auto
- thus ?thesis using convergent_bounded_monotone[of "\<lambda>n. s (r n)" b] and assms
- unfolding tendsto_iff dist_norm eventually_sequentially by auto
-qed
-
-instance real :: heine_borel
-proof
- fix s :: "real set" and f :: "nat \<Rightarrow> real"
- assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
- then obtain b where b: "\<forall>n. abs (f n) \<le> b"
- unfolding bounded_iff by auto
- obtain l :: real and r :: "nat \<Rightarrow> nat" where
- r: "subseq r" and l: "((f \<circ> r) ---> l) sequentially"
- using compact_real_lemma [OF b] by auto
- thus "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
- by auto
-qed
-
-lemma bounded_component: "bounded s \<Longrightarrow> bounded ((\<lambda>x. x $ i) ` s)"
-unfolding bounded_def
-apply clarify
-apply (rule_tac x="x $ i" in exI)
-apply (rule_tac x="e" in exI)
-apply clarify
-apply (rule order_trans [OF dist_nth_le], simp)
-done
-
-lemma compact_lemma:
- fixes f :: "nat \<Rightarrow> 'a::heine_borel ^ 'n::finite"
- assumes "bounded s" and "\<forall>n. f n \<in> s"
- shows "\<forall>d.
- \<exists>l r. subseq r \<and>
- (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) $ i) (l $ i) < e) sequentially)"
-proof
- fix d::"'n set" have "finite d" by simp
- thus "\<exists>l::'a ^ 'n. \<exists>r. subseq r \<and>
- (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) $ i) (l $ i) < e) sequentially)"
- proof(induct d) case empty thus ?case unfolding subseq_def by auto
- next case (insert k d)
- have s': "bounded ((\<lambda>x. x $ k) ` s)" using `bounded s` by (rule bounded_component)
- obtain l1::"'a^'n" and r1 where r1:"subseq r1" and lr1:"\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 n) $ i) (l1 $ i) < e) sequentially"
- using insert(3) by auto
- have f': "\<forall>n. f (r1 n) $ k \<in> (\<lambda>x. x $ k) ` s" using `\<forall>n. f n \<in> s` by simp
- obtain l2 r2 where r2:"subseq r2" and lr2:"((\<lambda>i. f (r1 (r2 i)) $ k) ---> l2) sequentially"
- using bounded_imp_convergent_subsequence[OF s' f'] unfolding o_def by auto
- def r \<equiv> "r1 \<circ> r2" have r:"subseq r"
- using r1 and r2 unfolding r_def o_def subseq_def by auto
- moreover
- def l \<equiv> "(\<chi> i. if i = k then l2 else l1$i)::'a^'n"
- { fix e::real assume "e>0"
- from lr1 `e>0` have N1:"eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 n) $ i) (l1 $ i) < e) sequentially" by blast
- from lr2 `e>0` have N2:"eventually (\<lambda>n. dist (f (r1 (r2 n)) $ k) l2 < e) sequentially" by (rule tendstoD)
- from r2 N1 have N1': "eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 (r2 n)) $ i) (l1 $ i) < e) sequentially"
- by (rule eventually_subseq)
- have "eventually (\<lambda>n. \<forall>i\<in>(insert k d). dist (f (r n) $ i) (l $ i) < e) sequentially"
- using N1' N2 by (rule eventually_elim2, simp add: l_def r_def)
- }
- ultimately show ?case by auto
- qed
-qed
-
-instance "^" :: (heine_borel, finite) heine_borel
-proof
- fix s :: "('a ^ 'b) set" and f :: "nat \<Rightarrow> 'a ^ 'b"
- assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
- then obtain l r where r: "subseq r"
- and l: "\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>UNIV. dist (f (r n) $ i) (l $ i) < e) sequentially"
- using compact_lemma [OF s f] by blast
- let ?d = "UNIV::'b set"
- { fix e::real assume "e>0"
- hence "0 < e / (real_of_nat (card ?d))"
- using zero_less_card_finite using divide_pos_pos[of e, of "real_of_nat (card ?d)"] by auto
- with l have "eventually (\<lambda>n. \<forall>i. dist (f (r n) $ i) (l $ i) < e / (real_of_nat (card ?d))) sequentially"
- by simp
- moreover
- { fix n assume n: "\<forall>i. dist (f (r n) $ i) (l $ i) < e / (real_of_nat (card ?d))"
- have "dist (f (r n)) l \<le> (\<Sum>i\<in>?d. dist (f (r n) $ i) (l $ i))"
- unfolding dist_vector_def using zero_le_dist by (rule setL2_le_setsum)
- also have "\<dots> < (\<Sum>i\<in>?d. e / (real_of_nat (card ?d)))"
- by (rule setsum_strict_mono) (simp_all add: n)
- finally have "dist (f (r n)) l < e" by simp
- }
- ultimately have "eventually (\<lambda>n. dist (f (r n)) l < e) sequentially"
- by (rule eventually_elim1)
- }
- hence *:"((f \<circ> r) ---> l) sequentially" unfolding o_def tendsto_iff by simp
- with r show "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially" by auto
-qed
-
-lemma bounded_fst: "bounded s \<Longrightarrow> bounded (fst ` s)"
-unfolding bounded_def
-apply clarify
-apply (rule_tac x="a" in exI)
-apply (rule_tac x="e" in exI)
-apply clarsimp
-apply (drule (1) bspec)
-apply (simp add: dist_Pair_Pair)
-apply (erule order_trans [OF real_sqrt_sum_squares_ge1])
-done
-
-lemma bounded_snd: "bounded s \<Longrightarrow> bounded (snd ` s)"
-unfolding bounded_def
-apply clarify
-apply (rule_tac x="b" in exI)
-apply (rule_tac x="e" in exI)
-apply clarsimp
-apply (drule (1) bspec)
-apply (simp add: dist_Pair_Pair)
-apply (erule order_trans [OF real_sqrt_sum_squares_ge2])
-done
-
-instance "*" :: (heine_borel, heine_borel) heine_borel
-proof
- fix s :: "('a * 'b) set" and f :: "nat \<Rightarrow> 'a * 'b"
- assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
- from s have s1: "bounded (fst ` s)" by (rule bounded_fst)
- from f have f1: "\<forall>n. fst (f n) \<in> fst ` s" by simp
- obtain l1 r1 where r1: "subseq r1"
- and l1: "((\<lambda>n. fst (f (r1 n))) ---> l1) sequentially"
- using bounded_imp_convergent_subsequence [OF s1 f1]
- unfolding o_def by fast
- from s have s2: "bounded (snd ` s)" by (rule bounded_snd)
- from f have f2: "\<forall>n. snd (f (r1 n)) \<in> snd ` s" by simp
- obtain l2 r2 where r2: "subseq r2"
- and l2: "((\<lambda>n. snd (f (r1 (r2 n)))) ---> l2) sequentially"
- using bounded_imp_convergent_subsequence [OF s2 f2]
- unfolding o_def by fast
- have l1': "((\<lambda>n. fst (f (r1 (r2 n)))) ---> l1) sequentially"
- using lim_subseq [OF r2 l1] unfolding o_def .
- have l: "((f \<circ> (r1 \<circ> r2)) ---> (l1, l2)) sequentially"
- using tendsto_Pair [OF l1' l2] unfolding o_def by simp
- have r: "subseq (r1 \<circ> r2)"
- using r1 r2 unfolding subseq_def by simp
- show "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
- using l r by fast
-qed
-
-subsection{* Completeness. *}
-
-lemma cauchy_def:
- "Cauchy s \<longleftrightarrow> (\<forall>e>0. \<exists>N. \<forall>m n. m \<ge> N \<and> n \<ge> N --> dist(s m)(s n) < e)"
-unfolding Cauchy_def by blast
-
-definition
- complete :: "'a::metric_space set \<Rightarrow> bool" where
- "complete s \<longleftrightarrow> (\<forall>f. (\<forall>n. f n \<in> s) \<and> Cauchy f
- --> (\<exists>l \<in> s. (f ---> l) sequentially))"
-
-lemma cauchy: "Cauchy s \<longleftrightarrow> (\<forall>e>0.\<exists> N::nat. \<forall>n\<ge>N. dist(s n)(s N) < e)" (is "?lhs = ?rhs")
-proof-
- { assume ?rhs
- { fix e::real
- assume "e>0"
- with `?rhs` obtain N where N:"\<forall>n\<ge>N. dist (s n) (s N) < e/2"
- by (erule_tac x="e/2" in allE) auto
- { fix n m
- assume nm:"N \<le> m \<and> N \<le> n"
- hence "dist (s m) (s n) < e" using N
- using dist_triangle_half_l[of "s m" "s N" "e" "s n"]
- by blast
- }
- hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < e"
- by blast
- }
- hence ?lhs
- unfolding cauchy_def
- by blast
- }
- thus ?thesis
- unfolding cauchy_def
- using dist_triangle_half_l
- by blast
-qed
-
-lemma convergent_imp_cauchy:
- "(s ---> l) sequentially ==> Cauchy s"
-proof(simp only: cauchy_def, rule, rule)
- fix e::real assume "e>0" "(s ---> l) sequentially"
- then obtain N::nat where N:"\<forall>n\<ge>N. dist (s n) l < e/2" unfolding Lim_sequentially by(erule_tac x="e/2" in allE) auto
- thus "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < e" using dist_triangle_half_l[of _ l e _] by (rule_tac x=N in exI) auto
-qed
-
-lemma cauchy_imp_bounded: assumes "Cauchy s" shows "bounded {y. (\<exists>n::nat. y = s n)}"
-proof-
- from assms obtain N::nat where "\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < 1" unfolding cauchy_def apply(erule_tac x= 1 in allE) by auto
- hence N:"\<forall>n. N \<le> n \<longrightarrow> dist (s N) (s n) < 1" by auto
- moreover
- have "bounded (s ` {0..N})" using finite_imp_bounded[of "s ` {1..N}"] by auto
- then obtain a where a:"\<forall>x\<in>s ` {0..N}. dist (s N) x \<le> a"
- unfolding bounded_any_center [where a="s N"] by auto
- ultimately show "?thesis"
- unfolding bounded_any_center [where a="s N"]
- apply(rule_tac x="max a 1" in exI) apply auto
- apply(erule_tac x=n in allE) apply(erule_tac x=n in ballE) by auto
-qed
-
-lemma compact_imp_complete: assumes "compact s" shows "complete s"
-proof-
- { fix f assume as: "(\<forall>n::nat. f n \<in> s)" "Cauchy f"
- from as(1) obtain l r where lr: "l\<in>s" "subseq r" "((f \<circ> r) ---> l) sequentially" using assms unfolding compact_def by blast
-
- note lr' = subseq_bigger [OF lr(2)]
-
- { fix e::real assume "e>0"
- from as(2) obtain N where N:"\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (f m) (f n) < e/2" unfolding cauchy_def using `e>0` apply (erule_tac x="e/2" in allE) by auto
- from lr(3)[unfolded Lim_sequentially, THEN spec[where x="e/2"]] obtain M where M:"\<forall>n\<ge>M. dist ((f \<circ> r) n) l < e/2" using `e>0` by auto
- { fix n::nat assume n:"n \<ge> max N M"
- have "dist ((f \<circ> r) n) l < e/2" using n M by auto
- moreover have "r n \<ge> N" using lr'[of n] n by auto
- hence "dist (f n) ((f \<circ> r) n) < e / 2" using N using n by auto
- ultimately have "dist (f n) l < e" using dist_triangle_half_r[of "f (r n)" "f n" e l] by (auto simp add: dist_commute) }
- hence "\<exists>N. \<forall>n\<ge>N. dist (f n) l < e" by blast }
- hence "\<exists>l\<in>s. (f ---> l) sequentially" using `l\<in>s` unfolding Lim_sequentially by auto }
- thus ?thesis unfolding complete_def by auto
-qed
-
-instance heine_borel < complete_space
-proof
- fix f :: "nat \<Rightarrow> 'a" assume "Cauchy f"
- hence "bounded (range f)" unfolding image_def
- using cauchy_imp_bounded [of f] by auto
- hence "compact (closure (range f))"
- using bounded_closed_imp_compact [of "closure (range f)"] by auto
- hence "complete (closure (range f))"
- using compact_imp_complete by auto
- moreover have "\<forall>n. f n \<in> closure (range f)"
- using closure_subset [of "range f"] by auto
- ultimately have "\<exists>l\<in>closure (range f). (f ---> l) sequentially"
- using `Cauchy f` unfolding complete_def by auto
- then show "convergent f"
- unfolding convergent_def LIMSEQ_conv_tendsto [symmetric] by auto
-qed
-
-lemma complete_univ: "complete (UNIV :: 'a::complete_space set)"
-proof(simp add: complete_def, rule, rule)
- fix f :: "nat \<Rightarrow> 'a" assume "Cauchy f"
- hence "convergent f" by (rule Cauchy_convergent)
- hence "\<exists>l. f ----> l" unfolding convergent_def .
- thus "\<exists>l. (f ---> l) sequentially" unfolding LIMSEQ_conv_tendsto .
-qed
-
-lemma complete_imp_closed: assumes "complete s" shows "closed s"
-proof -
- { fix x assume "x islimpt s"
- then obtain f where f: "\<forall>n. f n \<in> s - {x}" "(f ---> x) sequentially"
- unfolding islimpt_sequential by auto
- then obtain l where l: "l\<in>s" "(f ---> l) sequentially"
- using `complete s`[unfolded complete_def] using convergent_imp_cauchy[of f x] by auto
- hence "x \<in> s" using Lim_unique[of sequentially f l x] trivial_limit_sequentially f(2) by auto
- }
- thus "closed s" unfolding closed_limpt by auto
-qed
-
-lemma complete_eq_closed:
- fixes s :: "'a::complete_space set"
- shows "complete s \<longleftrightarrow> closed s" (is "?lhs = ?rhs")
-proof
- assume ?lhs thus ?rhs by (rule complete_imp_closed)
-next
- assume ?rhs
- { fix f assume as:"\<forall>n::nat. f n \<in> s" "Cauchy f"
- then obtain l where "(f ---> l) sequentially" using complete_univ[unfolded complete_def, THEN spec[where x=f]] by auto
- hence "\<exists>l\<in>s. (f ---> l) sequentially" using `?rhs`[unfolded closed_sequential_limits, THEN spec[where x=f], THEN spec[where x=l]] using as(1) by auto }
- thus ?lhs unfolding complete_def by auto
-qed
-
-lemma convergent_eq_cauchy:
- fixes s :: "nat \<Rightarrow> 'a::complete_space"
- shows "(\<exists>l. (s ---> l) sequentially) \<longleftrightarrow> Cauchy s" (is "?lhs = ?rhs")
-proof
- assume ?lhs then obtain l where "(s ---> l) sequentially" by auto
- thus ?rhs using convergent_imp_cauchy by auto
-next
- assume ?rhs thus ?lhs using complete_univ[unfolded complete_def, THEN spec[where x=s]] by auto
-qed
-
-lemma convergent_imp_bounded:
- fixes s :: "nat \<Rightarrow> 'a::metric_space"
- shows "(s ---> l) sequentially ==> bounded (s ` (UNIV::(nat set)))"
- using convergent_imp_cauchy[of s]
- using cauchy_imp_bounded[of s]
- unfolding image_def
- by auto
-
-subsection{* Total boundedness. *}
-
-fun helper_1::"('a::metric_space set) \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> 'a" where
- "helper_1 s e n = (SOME y::'a. y \<in> s \<and> (\<forall>m<n. \<not> (dist (helper_1 s e m) y < e)))"
-declare helper_1.simps[simp del]
-
-lemma compact_imp_totally_bounded:
- assumes "compact s"
- shows "\<forall>e>0. \<exists>k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> (\<Union>((\<lambda>x. ball x e) ` k))"
-proof(rule, rule, rule ccontr)
- fix e::real assume "e>0" and assm:"\<not> (\<exists>k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k)"
- def x \<equiv> "helper_1 s e"
- { fix n
- have "x n \<in> s \<and> (\<forall>m<n. \<not> dist (x m) (x n) < e)"
- proof(induct_tac rule:nat_less_induct)
- fix n def Q \<equiv> "(\<lambda>y. y \<in> s \<and> (\<forall>m<n. \<not> dist (x m) y < e))"
- assume as:"\<forall>m<n. x m \<in> s \<and> (\<forall>ma<m. \<not> dist (x ma) (x m) < e)"
- have "\<not> s \<subseteq> (\<Union>x\<in>x ` {0..<n}. ball x e)" using assm apply simp apply(erule_tac x="x ` {0 ..< n}" in allE) using as by auto
- then obtain z where z:"z\<in>s" "z \<notin> (\<Union>x\<in>x ` {0..<n}. ball x e)" unfolding subset_eq by auto
- have "Q (x n)" unfolding x_def and helper_1.simps[of s e n]
- apply(rule someI2[where a=z]) unfolding x_def[symmetric] and Q_def using z by auto
- thus "x n \<in> s \<and> (\<forall>m<n. \<not> dist (x m) (x n) < e)" unfolding Q_def by auto
- qed }
- hence "\<forall>n::nat. x n \<in> s" and x:"\<forall>n. \<forall>m < n. \<not> (dist (x m) (x n) < e)" by blast+
- then obtain l r where "l\<in>s" and r:"subseq r" and "((x \<circ> r) ---> l) sequentially" using assms(1)[unfolded compact_def, THEN spec[where x=x]] by auto
- from this(3) have "Cauchy (x \<circ> r)" using convergent_imp_cauchy by auto
- then obtain N::nat where N:"\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist ((x \<circ> r) m) ((x \<circ> r) n) < e" unfolding cauchy_def using `e>0` by auto
- show False
- using N[THEN spec[where x=N], THEN spec[where x="N+1"]]
- using r[unfolded subseq_def, THEN spec[where x=N], THEN spec[where x="N+1"]]
- using x[THEN spec[where x="r (N+1)"], THEN spec[where x="r (N)"]] by auto
-qed
-
-subsection{* Heine-Borel theorem (following Burkill \& Burkill vol. 2) *}
-
-lemma heine_borel_lemma: fixes s::"'a::metric_space set"
- assumes "compact s" "s \<subseteq> (\<Union> t)" "\<forall>b \<in> t. open b"
- shows "\<exists>e>0. \<forall>x \<in> s. \<exists>b \<in> t. ball x e \<subseteq> b"
-proof(rule ccontr)
- assume "\<not> (\<exists>e>0. \<forall>x\<in>s. \<exists>b\<in>t. ball x e \<subseteq> b)"
- hence cont:"\<forall>e>0. \<exists>x\<in>s. \<forall>xa\<in>t. \<not> (ball x e \<subseteq> xa)" by auto
- { fix n::nat
- have "1 / real (n + 1) > 0" by auto
- hence "\<exists>x. x\<in>s \<and> (\<forall>xa\<in>t. \<not> (ball x (inverse (real (n+1))) \<subseteq> xa))" using cont unfolding Bex_def by auto }
- hence "\<forall>n::nat. \<exists>x. x \<in> s \<and> (\<forall>xa\<in>t. \<not> ball x (inverse (real (n + 1))) \<subseteq> xa)" by auto
- then obtain f where f:"\<forall>n::nat. f n \<in> s \<and> (\<forall>xa\<in>t. \<not> ball (f n) (inverse (real (n + 1))) \<subseteq> xa)"
- using choice[of "\<lambda>n::nat. \<lambda>x. x\<in>s \<and> (\<forall>xa\<in>t. \<not> ball x (inverse (real (n + 1))) \<subseteq> xa)"] by auto
-
- then obtain l r where l:"l\<in>s" and r:"subseq r" and lr:"((f \<circ> r) ---> l) sequentially"
- using assms(1)[unfolded compact_def, THEN spec[where x=f]] by auto
-
- obtain b where "l\<in>b" "b\<in>t" using assms(2) and l by auto
- then obtain e where "e>0" and e:"\<forall>z. dist z l < e \<longrightarrow> z\<in>b"
- using assms(3)[THEN bspec[where x=b]] unfolding open_dist by auto
-
- then obtain N1 where N1:"\<forall>n\<ge>N1. dist ((f \<circ> r) n) l < e / 2"
- using lr[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
-
- obtain N2::nat where N2:"N2>0" "inverse (real N2) < e /2" using real_arch_inv[of "e/2"] and `e>0` by auto
- have N2':"inverse (real (r (N1 + N2) +1 )) < e/2"
- apply(rule order_less_trans) apply(rule less_imp_inverse_less) using N2
- using subseq_bigger[OF r, of "N1 + N2"] by auto
-
- def x \<equiv> "(f (r (N1 + N2)))"
- have x:"\<not> ball x (inverse (real (r (N1 + N2) + 1))) \<subseteq> b" unfolding x_def
- using f[THEN spec[where x="r (N1 + N2)"]] using `b\<in>t` by auto
- have "\<exists>y\<in>ball x (inverse (real (r (N1 + N2) + 1))). y\<notin>b" apply(rule ccontr) using x by auto
- then obtain y where y:"y \<in> ball x (inverse (real (r (N1 + N2) + 1)))" "y \<notin> b" by auto
-
- have "dist x l < e/2" using N1 unfolding x_def o_def by auto
- hence "dist y l < e" using y N2' using dist_triangle[of y l x]by (auto simp add:dist_commute)
-
- thus False using e and `y\<notin>b` by auto
-qed
-
-lemma compact_imp_heine_borel: "compact s ==> (\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f)
- \<longrightarrow> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f')))"
-proof clarify
- fix f assume "compact s" " \<forall>t\<in>f. open t" "s \<subseteq> \<Union>f"
- then obtain e::real where "e>0" and "\<forall>x\<in>s. \<exists>b\<in>f. ball x e \<subseteq> b" using heine_borel_lemma[of s f] by auto
- hence "\<forall>x\<in>s. \<exists>b. b\<in>f \<and> ball x e \<subseteq> b" by auto
- hence "\<exists>bb. \<forall>x\<in>s. bb x \<in>f \<and> ball x e \<subseteq> bb x" using bchoice[of s "\<lambda>x b. b\<in>f \<and> ball x e \<subseteq> b"] by auto
- then obtain bb where bb:"\<forall>x\<in>s. (bb x) \<in> f \<and> ball x e \<subseteq> (bb x)" by blast
-
- from `compact s` have "\<exists> k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k" using compact_imp_totally_bounded[of s] `e>0` by auto
- then obtain k where k:"finite k" "k \<subseteq> s" "s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k" by auto
-
- have "finite (bb ` k)" using k(1) by auto
- moreover
- { fix x assume "x\<in>s"
- hence "x\<in>\<Union>(\<lambda>x. ball x e) ` k" using k(3) unfolding subset_eq by auto
- hence "\<exists>X\<in>bb ` k. x \<in> X" using bb k(2) by blast
- hence "x \<in> \<Union>(bb ` k)" using Union_iff[of x "bb ` k"] by auto
- }
- ultimately show "\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f'" using bb k(2) by (rule_tac x="bb ` k" in exI) auto
-qed
-
-subsection{* Bolzano-Weierstrass property. *}
-
-lemma heine_borel_imp_bolzano_weierstrass:
- assumes "\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f) --> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f'))"
- "infinite t" "t \<subseteq> s"
- shows "\<exists>x \<in> s. x islimpt t"
-proof(rule ccontr)
- assume "\<not> (\<exists>x \<in> s. x islimpt t)"
- then obtain f where f:"\<forall>x\<in>s. x \<in> f x \<and> open (f x) \<and> (\<forall>y\<in>t. y \<in> f x \<longrightarrow> y = x)" unfolding islimpt_def
- using bchoice[of s "\<lambda> x T. x \<in> T \<and> open T \<and> (\<forall>y\<in>t. y \<in> T \<longrightarrow> y = x)"] by auto
- obtain g where g:"g\<subseteq>{t. \<exists>x. x \<in> s \<and> t = f x}" "finite g" "s \<subseteq> \<Union>g"
- using assms(1)[THEN spec[where x="{t. \<exists>x. x\<in>s \<and> t = f x}"]] using f by auto
- from g(1,3) have g':"\<forall>x\<in>g. \<exists>xa \<in> s. x = f xa" by auto
- { fix x y assume "x\<in>t" "y\<in>t" "f x = f y"
- hence "x \<in> f x" "y \<in> f x \<longrightarrow> y = x" using f[THEN bspec[where x=x]] and `t\<subseteq>s` by auto
- hence "x = y" using `f x = f y` and f[THEN bspec[where x=y]] and `y\<in>t` and `t\<subseteq>s` by auto }
- hence "infinite (f ` t)" using assms(2) using finite_imageD[unfolded inj_on_def, of f t] by auto
- moreover
- { fix x assume "x\<in>t" "f x \<notin> g"
- from g(3) assms(3) `x\<in>t` obtain h where "h\<in>g" and "x\<in>h" by auto
- then obtain y where "y\<in>s" "h = f y" using g'[THEN bspec[where x=h]] by auto
- hence "y = x" using f[THEN bspec[where x=y]] and `x\<in>t` and `x\<in>h`[unfolded `h = f y`] by auto
- hence False using `f x \<notin> g` `h\<in>g` unfolding `h = f y` by auto }
- hence "f ` t \<subseteq> g" by auto
- ultimately show False using g(2) using finite_subset by auto
-qed
-
-subsection{* Complete the chain of compactness variants. *}
-
-primrec helper_2::"(real \<Rightarrow> 'a::metric_space) \<Rightarrow> nat \<Rightarrow> 'a" where
- "helper_2 beyond 0 = beyond 0" |
- "helper_2 beyond (Suc n) = beyond (dist undefined (helper_2 beyond n) + 1 )"
-
-lemma bolzano_weierstrass_imp_bounded: fixes s::"'a::metric_space set"
- assumes "\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t)"
- shows "bounded s"
-proof(rule ccontr)
- assume "\<not> bounded s"
- then obtain beyond where "\<forall>a. beyond a \<in>s \<and> \<not> dist undefined (beyond a) \<le> a"
- unfolding bounded_any_center [where a=undefined]
- apply simp using choice[of "\<lambda>a x. x\<in>s \<and> \<not> dist undefined x \<le> a"] by auto
- hence beyond:"\<And>a. beyond a \<in>s" "\<And>a. dist undefined (beyond a) > a"
- unfolding linorder_not_le by auto
- def x \<equiv> "helper_2 beyond"
-
- { fix m n ::nat assume "m<n"
- hence "dist undefined (x m) + 1 < dist undefined (x n)"
- proof(induct n)
- case 0 thus ?case by auto
- next
- case (Suc n)
- have *:"dist undefined (x n) + 1 < dist undefined (x (Suc n))"
- unfolding x_def and helper_2.simps
- using beyond(2)[of "dist undefined (helper_2 beyond n) + 1"] by auto
- thus ?case proof(cases "m < n")
- case True thus ?thesis using Suc and * by auto
- next
- case False hence "m = n" using Suc(2) by auto
- thus ?thesis using * by auto
- qed
- qed } note * = this
- { fix m n ::nat assume "m\<noteq>n"
- have "1 < dist (x m) (x n)"
- proof(cases "m<n")
- case True
- hence "1 < dist undefined (x n) - dist undefined (x m)" using *[of m n] by auto
- thus ?thesis using dist_triangle [of undefined "x n" "x m"] by arith
- next
- case False hence "n<m" using `m\<noteq>n` by auto
- hence "1 < dist undefined (x m) - dist undefined (x n)" using *[of n m] by auto
- thus ?thesis using dist_triangle2 [of undefined "x m" "x n"] by arith
- qed } note ** = this
- { fix a b assume "x a = x b" "a \<noteq> b"
- hence False using **[of a b] by auto }
- hence "inj x" unfolding inj_on_def by auto
- moreover
- { fix n::nat
- have "x n \<in> s"
- proof(cases "n = 0")
- case True thus ?thesis unfolding x_def using beyond by auto
- next
- case False then obtain z where "n = Suc z" using not0_implies_Suc by auto
- thus ?thesis unfolding x_def using beyond by auto
- qed }
- ultimately have "infinite (range x) \<and> range x \<subseteq> s" unfolding x_def using range_inj_infinite[of "helper_2 beyond"] using beyond(1) by auto
-
- then obtain l where "l\<in>s" and l:"l islimpt range x" using assms[THEN spec[where x="range x"]] by auto
- then obtain y where "x y \<noteq> l" and y:"dist (x y) l < 1/2" unfolding islimpt_approachable apply(erule_tac x="1/2" in allE) by auto
- then obtain z where "x z \<noteq> l" and z:"dist (x z) l < dist (x y) l" using l[unfolded islimpt_approachable, THEN spec[where x="dist (x y) l"]]
- unfolding dist_nz by auto
- show False using y and z and dist_triangle_half_l[of "x y" l 1 "x z"] and **[of y z] by auto
-qed
-
-lemma sequence_infinite_lemma:
- fixes l :: "'a::metric_space" (* TODO: generalize *)
- assumes "\<forall>n::nat. (f n \<noteq> l)" "(f ---> l) sequentially"
- shows "infinite {y. (\<exists> n. y = f n)}"
-proof(rule ccontr)
- let ?A = "(\<lambda>x. dist x l) ` {y. \<exists>n. y = f n}"
- assume "\<not> infinite {y. \<exists>n. y = f n}"
- hence **:"finite ?A" "?A \<noteq> {}" by auto
- obtain k where k:"dist (f k) l = Min ?A" using Min_in[OF **] by auto
- have "0 < Min ?A" using assms(1) unfolding dist_nz unfolding Min_gr_iff[OF **] by auto
- then obtain N where "dist (f N) l < Min ?A" using assms(2)[unfolded Lim_sequentially, THEN spec[where x="Min ?A"]] by auto
- moreover have "dist (f N) l \<in> ?A" by auto
- ultimately show False using Min_le[OF **(1), of "dist (f N) l"] by auto
-qed
-
-lemma sequence_unique_limpt:
- fixes l :: "'a::metric_space" (* TODO: generalize *)
- assumes "\<forall>n::nat. (f n \<noteq> l)" "(f ---> l) sequentially" "l' islimpt {y. (\<exists>n. y = f n)}"
- shows "l' = l"
-proof(rule ccontr)
- def e \<equiv> "dist l' l"
- assume "l' \<noteq> l" hence "e>0" unfolding dist_nz e_def by auto
- then obtain N::nat where N:"\<forall>n\<ge>N. dist (f n) l < e / 2"
- using assms(2)[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
- def d \<equiv> "Min (insert (e/2) ((\<lambda>n. if dist (f n) l' = 0 then e/2 else dist (f n) l') ` {0 .. N}))"
- have "d>0" using `e>0` unfolding d_def e_def using zero_le_dist[of _ l', unfolded order_le_less] by auto
- obtain k where k:"f k \<noteq> l'" "dist (f k) l' < d" using `d>0` and assms(3)[unfolded islimpt_approachable, THEN spec[where x="d"]] by auto
- have "k\<ge>N" using k(1)[unfolded dist_nz] using k(2)[unfolded d_def]
- by force
- hence "dist l' l < e" using N[THEN spec[where x=k]] using k(2)[unfolded d_def] and dist_triangle_half_r[of "f k" l' e l] by auto
- thus False unfolding e_def by auto
-qed
-
-lemma bolzano_weierstrass_imp_closed:
- fixes s :: "'a::metric_space set" (* TODO: can this be generalized? *)
- assumes "\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t)"
- shows "closed s"
-proof-
- { fix x l assume as: "\<forall>n::nat. x n \<in> s" "(x ---> l) sequentially"
- hence "l \<in> s"
- proof(cases "\<forall>n. x n \<noteq> l")
- case False thus "l\<in>s" using as(1) by auto
- next
- case True note cas = this
- with as(2) have "infinite {y. \<exists>n. y = x n}" using sequence_infinite_lemma[of x l] by auto
- then obtain l' where "l'\<in>s" "l' islimpt {y. \<exists>n. y = x n}" using assms[THEN spec[where x="{y. \<exists>n. y = x n}"]] as(1) by auto
- thus "l\<in>s" using sequence_unique_limpt[of x l l'] using as cas by auto
- qed }
- thus ?thesis unfolding closed_sequential_limits by fast
-qed
-
-text{* Hence express everything as an equivalence. *}
-
-lemma compact_eq_heine_borel:
- fixes s :: "'a::heine_borel set"
- shows "compact s \<longleftrightarrow>
- (\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f)
- --> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f')))" (is "?lhs = ?rhs")
-proof
- assume ?lhs thus ?rhs using compact_imp_heine_borel[of s] by blast
-next
- assume ?rhs
- hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x\<in>s. x islimpt t)"
- by (blast intro: heine_borel_imp_bolzano_weierstrass[of s])
- thus ?lhs using bolzano_weierstrass_imp_bounded[of s] bolzano_weierstrass_imp_closed[of s] bounded_closed_imp_compact[of s] by blast
-qed
-
-lemma compact_eq_bolzano_weierstrass:
- fixes s :: "'a::heine_borel set"
- shows "compact s \<longleftrightarrow> (\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t))" (is "?lhs = ?rhs")
-proof
- assume ?lhs thus ?rhs unfolding compact_eq_heine_borel using heine_borel_imp_bolzano_weierstrass[of s] by auto
-next
- assume ?rhs thus ?lhs using bolzano_weierstrass_imp_bounded bolzano_weierstrass_imp_closed bounded_closed_imp_compact by auto
-qed
-
-lemma compact_eq_bounded_closed:
- fixes s :: "'a::heine_borel set"
- shows "compact s \<longleftrightarrow> bounded s \<and> closed s" (is "?lhs = ?rhs")
-proof
- assume ?lhs thus ?rhs unfolding compact_eq_bolzano_weierstrass using bolzano_weierstrass_imp_bounded bolzano_weierstrass_imp_closed by auto
-next
- assume ?rhs thus ?lhs using bounded_closed_imp_compact by auto
-qed
-
-lemma compact_imp_bounded:
- fixes s :: "'a::metric_space set"
- shows "compact s ==> bounded s"
-proof -
- assume "compact s"
- hence "\<forall>f. (\<forall>t\<in>f. open t) \<and> s \<subseteq> \<Union>f \<longrightarrow> (\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f')"
- by (rule compact_imp_heine_borel)
- hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x \<in> s. x islimpt t)"
- using heine_borel_imp_bolzano_weierstrass[of s] by auto
- thus "bounded s"
- by (rule bolzano_weierstrass_imp_bounded)
-qed
-
-lemma compact_imp_closed:
- fixes s :: "'a::metric_space set"
- shows "compact s ==> closed s"
-proof -
- assume "compact s"
- hence "\<forall>f. (\<forall>t\<in>f. open t) \<and> s \<subseteq> \<Union>f \<longrightarrow> (\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f')"
- by (rule compact_imp_heine_borel)
- hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x \<in> s. x islimpt t)"
- using heine_borel_imp_bolzano_weierstrass[of s] by auto
- thus "closed s"
- by (rule bolzano_weierstrass_imp_closed)
-qed
-
-text{* In particular, some common special cases. *}
-
-lemma compact_empty[simp]:
- "compact {}"
- unfolding compact_def
- by simp
-
-(* TODO: can any of the next 3 lemmas be generalized to metric spaces? *)
-
- (* FIXME : Rename *)
-lemma compact_union[intro]:
- fixes s t :: "'a::heine_borel set"
- shows "compact s \<Longrightarrow> compact t ==> compact (s \<union> t)"
- unfolding compact_eq_bounded_closed
- using bounded_Un[of s t]
- using closed_Un[of s t]
- by simp
-
-lemma compact_inter[intro]:
- fixes s t :: "'a::heine_borel set"
- shows "compact s \<Longrightarrow> compact t ==> compact (s \<inter> t)"
- unfolding compact_eq_bounded_closed
- using bounded_Int[of s t]
- using closed_Int[of s t]
- by simp
-
-lemma compact_inter_closed[intro]:
- fixes s t :: "'a::heine_borel set"
- shows "compact s \<Longrightarrow> closed t ==> compact (s \<inter> t)"
- unfolding compact_eq_bounded_closed
- using closed_Int[of s t]
- using bounded_subset[of "s \<inter> t" s]
- by blast
-
-lemma closed_inter_compact[intro]:
- fixes s t :: "'a::heine_borel set"
- shows "closed s \<Longrightarrow> compact t ==> compact (s \<inter> t)"
-proof-
- assume "closed s" "compact t"
- moreover
- have "s \<inter> t = t \<inter> s" by auto ultimately
- show ?thesis
- using compact_inter_closed[of t s]
- by auto
-qed
-
-lemma closed_sing [simp]:
- fixes a :: "'a::metric_space"
- shows "closed {a}"
- apply (clarsimp simp add: closed_def open_dist)
- apply (rule ccontr)
- apply (drule_tac x="dist x a" in spec)
- apply (simp add: dist_nz dist_commute)
- done
-
-lemma finite_imp_closed:
- fixes s :: "'a::metric_space set"
- shows "finite s ==> closed s"
-proof (induct set: finite)
- case empty show "closed {}" by simp
-next
- case (insert x F)
- hence "closed ({x} \<union> F)" by (simp only: closed_Un closed_sing)
- thus "closed (insert x F)" by simp
-qed
-
-lemma finite_imp_compact:
- fixes s :: "'a::heine_borel set"
- shows "finite s ==> compact s"
- unfolding compact_eq_bounded_closed
- using finite_imp_closed finite_imp_bounded
- by blast
-
-lemma compact_sing [simp]: "compact {a}"
- unfolding compact_def o_def subseq_def
- by (auto simp add: tendsto_const)
-
-lemma compact_cball[simp]:
- fixes x :: "'a::heine_borel"
- shows "compact(cball x e)"
- using compact_eq_bounded_closed bounded_cball closed_cball
- by blast
-
-lemma compact_frontier_bounded[intro]:
- fixes s :: "'a::heine_borel set"
- shows "bounded s ==> compact(frontier s)"
- unfolding frontier_def
- using compact_eq_bounded_closed
- by blast
-
-lemma compact_frontier[intro]:
- fixes s :: "'a::heine_borel set"
- shows "compact s ==> compact (frontier s)"
- using compact_eq_bounded_closed compact_frontier_bounded
- by blast
-
-lemma frontier_subset_compact:
- fixes s :: "'a::heine_borel set"
- shows "compact s ==> frontier s \<subseteq> s"
- using frontier_subset_closed compact_eq_bounded_closed
- by blast
-
-lemma open_delete:
- fixes s :: "'a::metric_space set"
- shows "open s ==> open(s - {x})"
- using open_Diff[of s "{x}"] closed_sing
- by blast
-
-text{* Finite intersection property. I could make it an equivalence in fact. *}
-
-lemma compact_imp_fip:
- fixes s :: "'a::heine_borel set"
- assumes "compact s" "\<forall>t \<in> f. closed t"
- "\<forall>f'. finite f' \<and> f' \<subseteq> f --> (s \<inter> (\<Inter> f') \<noteq> {})"
- shows "s \<inter> (\<Inter> f) \<noteq> {}"
-proof
- assume as:"s \<inter> (\<Inter> f) = {}"
- hence "s \<subseteq> \<Union>op - UNIV ` f" by auto
- moreover have "Ball (op - UNIV ` f) open" using open_Diff closed_Diff using assms(2) by auto
- ultimately obtain f' where f':"f' \<subseteq> op - UNIV ` f" "finite f'" "s \<subseteq> \<Union>f'" using assms(1)[unfolded compact_eq_heine_borel, THEN spec[where x="(\<lambda>t. UNIV - t) ` f"]] by auto
- hence "finite (op - UNIV ` f') \<and> op - UNIV ` f' \<subseteq> f" by(auto simp add: Diff_Diff_Int)
- hence "s \<inter> \<Inter>op - UNIV ` f' \<noteq> {}" using assms(3)[THEN spec[where x="op - UNIV ` f'"]] by auto
- thus False using f'(3) unfolding subset_eq and Union_iff by blast
-qed
-
-subsection{* Bounded closed nest property (proof does not use Heine-Borel). *}
-
-lemma bounded_closed_nest:
- assumes "\<forall>n. closed(s n)" "\<forall>n. (s n \<noteq> {})"
- "(\<forall>m n. m \<le> n --> s n \<subseteq> s m)" "bounded(s 0)"
- shows "\<exists>a::'a::heine_borel. \<forall>n::nat. a \<in> s(n)"
-proof-
- from assms(2) obtain x where x:"\<forall>n::nat. x n \<in> s n" using choice[of "\<lambda>n x. x\<in> s n"] by auto
- from assms(4,1) have *:"compact (s 0)" using bounded_closed_imp_compact[of "s 0"] by auto
-
- then obtain l r where lr:"l\<in>s 0" "subseq r" "((x \<circ> r) ---> l) sequentially"
- unfolding compact_def apply(erule_tac x=x in allE) using x using assms(3) by blast
-
- { fix n::nat
- { fix e::real assume "e>0"
- with lr(3) obtain N where N:"\<forall>m\<ge>N. dist ((x \<circ> r) m) l < e" unfolding Lim_sequentially by auto
- hence "dist ((x \<circ> r) (max N n)) l < e" by auto
- moreover
- have "r (max N n) \<ge> n" using lr(2) using subseq_bigger[of r "max N n"] by auto
- hence "(x \<circ> r) (max N n) \<in> s n"
- using x apply(erule_tac x=n in allE)
- using x apply(erule_tac x="r (max N n)" in allE)
- using assms(3) apply(erule_tac x=n in allE)apply( erule_tac x="r (max N n)" in allE) by auto
- ultimately have "\<exists>y\<in>s n. dist y l < e" by auto
- }
- hence "l \<in> s n" using closed_approachable[of "s n" l] assms(1) by blast
- }
- thus ?thesis by auto
-qed
-
-text{* Decreasing case does not even need compactness, just completeness. *}
-
-lemma decreasing_closed_nest:
- assumes "\<forall>n. closed(s n)"
- "\<forall>n. (s n \<noteq> {})"
- "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
- "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y \<in> (s n). dist x y < e"
- shows "\<exists>a::'a::heine_borel. \<forall>n::nat. a \<in> s n"
-proof-
- have "\<forall>n. \<exists> x. x\<in>s n" using assms(2) by auto
- hence "\<exists>t. \<forall>n. t n \<in> s n" using choice[of "\<lambda> n x. x \<in> s n"] by auto
- then obtain t where t: "\<forall>n. t n \<in> s n" by auto
- { fix e::real assume "e>0"
- then obtain N where N:"\<forall>x\<in>s N. \<forall>y\<in>s N. dist x y < e" using assms(4) by auto
- { fix m n ::nat assume "N \<le> m \<and> N \<le> n"
- hence "t m \<in> s N" "t n \<in> s N" using assms(3) t unfolding subset_eq t by blast+
- hence "dist (t m) (t n) < e" using N by auto
- }
- hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (t m) (t n) < e" by auto
- }
- hence "Cauchy t" unfolding cauchy_def by auto
- then obtain l where l:"(t ---> l) sequentially" using complete_univ unfolding complete_def by auto
- { fix n::nat
- { fix e::real assume "e>0"
- then obtain N::nat where N:"\<forall>n\<ge>N. dist (t n) l < e" using l[unfolded Lim_sequentially] by auto
- have "t (max n N) \<in> s n" using assms(3) unfolding subset_eq apply(erule_tac x=n in allE) apply (erule_tac x="max n N" in allE) using t by auto
- hence "\<exists>y\<in>s n. dist y l < e" apply(rule_tac x="t (max n N)" in bexI) using N by auto
- }
- hence "l \<in> s n" using closed_approachable[of "s n" l] assms(1) by auto
- }
- then show ?thesis by auto
-qed
-
-text{* Strengthen it to the intersection actually being a singleton. *}
-
-lemma decreasing_closed_nest_sing:
- assumes "\<forall>n. closed(s n)"
- "\<forall>n. s n \<noteq> {}"
- "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
- "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y\<in>(s n). dist x y < e"
- shows "\<exists>a::'a::heine_borel. \<Inter> {t. (\<exists>n::nat. t = s n)} = {a}"
-proof-
- obtain a where a:"\<forall>n. a \<in> s n" using decreasing_closed_nest[of s] using assms by auto
- { fix b assume b:"b \<in> \<Inter>{t. \<exists>n. t = s n}"
- { fix e::real assume "e>0"
- hence "dist a b < e" using assms(4 )using b using a by blast
- }
- hence "dist a b = 0" by (metis dist_eq_0_iff dist_nz real_less_def)
- }
- with a have "\<Inter>{t. \<exists>n. t = s n} = {a}" by auto
- thus ?thesis by auto
-qed
-
-text{* Cauchy-type criteria for uniform convergence. *}
-
-lemma uniformly_convergent_eq_cauchy: fixes s::"nat \<Rightarrow> 'b \<Rightarrow> 'a::heine_borel" shows
- "(\<exists>l. \<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x --> dist(s n x)(l x) < e) \<longleftrightarrow>
- (\<forall>e>0. \<exists>N. \<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x --> dist (s m x) (s n x) < e)" (is "?lhs = ?rhs")
-proof(rule)
- assume ?lhs
- then obtain l where l:"\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l x) < e" by auto
- { fix e::real assume "e>0"
- then obtain N::nat where N:"\<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l x) < e / 2" using l[THEN spec[where x="e/2"]] by auto
- { fix n m::nat and x::"'b" assume "N \<le> m \<and> N \<le> n \<and> P x"
- hence "dist (s m x) (s n x) < e"
- using N[THEN spec[where x=m], THEN spec[where x=x]]
- using N[THEN spec[where x=n], THEN spec[where x=x]]
- using dist_triangle_half_l[of "s m x" "l x" e "s n x"] by auto }
- hence "\<exists>N. \<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x --> dist (s m x) (s n x) < e" by auto }
- thus ?rhs by auto
-next
- assume ?rhs
- hence "\<forall>x. P x \<longrightarrow> Cauchy (\<lambda>n. s n x)" unfolding cauchy_def apply auto by (erule_tac x=e in allE)auto
- then obtain l where l:"\<forall>x. P x \<longrightarrow> ((\<lambda>n. s n x) ---> l x) sequentially" unfolding convergent_eq_cauchy[THEN sym]
- using choice[of "\<lambda>x l. P x \<longrightarrow> ((\<lambda>n. s n x) ---> l) sequentially"] by auto
- { fix e::real assume "e>0"
- then obtain N where N:"\<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x \<longrightarrow> dist (s m x) (s n x) < e/2"
- using `?rhs`[THEN spec[where x="e/2"]] by auto
- { fix x assume "P x"
- then obtain M where M:"\<forall>n\<ge>M. dist (s n x) (l x) < e/2"
- using l[THEN spec[where x=x], unfolded Lim_sequentially] using `e>0` by(auto elim!: allE[where x="e/2"])
- fix n::nat assume "n\<ge>N"
- hence "dist(s n x)(l x) < e" using `P x`and N[THEN spec[where x=n], THEN spec[where x="N+M"], THEN spec[where x=x]]
- using M[THEN spec[where x="N+M"]] and dist_triangle_half_l[of "s n x" "s (N+M) x" e "l x"] by (auto simp add: dist_commute) }
- hence "\<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist(s n x)(l x) < e" by auto }
- thus ?lhs by auto
-qed
-
-lemma uniformly_cauchy_imp_uniformly_convergent:
- fixes s :: "nat \<Rightarrow> 'a \<Rightarrow> 'b::heine_borel"
- assumes "\<forall>e>0.\<exists>N. \<forall>m (n::nat) x. N \<le> m \<and> N \<le> n \<and> P x --> dist(s m x)(s n x) < e"
- "\<forall>x. P x --> (\<forall>e>0. \<exists>N. \<forall>n. N \<le> n --> dist(s n x)(l x) < e)"
- shows "\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x --> dist(s n x)(l x) < e"
-proof-
- obtain l' where l:"\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l' x) < e"
- using assms(1) unfolding uniformly_convergent_eq_cauchy[THEN sym] by auto
- moreover
- { fix x assume "P x"
- hence "l x = l' x" using Lim_unique[OF trivial_limit_sequentially, of "\<lambda>n. s n x" "l x" "l' x"]
- using l and assms(2) unfolding Lim_sequentially by blast }
- ultimately show ?thesis by auto
-qed
-
-subsection{* Define continuity over a net to take in restrictions of the set. *}
-
-definition
- continuous :: "'a::t2_space net \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) \<Rightarrow> bool" where
- "continuous net f \<longleftrightarrow> (f ---> f(netlimit net)) net"
-
-lemma continuous_trivial_limit:
- "trivial_limit net ==> continuous net f"
- unfolding continuous_def tendsto_def trivial_limit_eq by auto
-
-lemma continuous_within: "continuous (at x within s) f \<longleftrightarrow> (f ---> f(x)) (at x within s)"
- unfolding continuous_def
- unfolding tendsto_def
- using netlimit_within[of x s]
- by (cases "trivial_limit (at x within s)") (auto simp add: trivial_limit_eventually)
-
-lemma continuous_at: "continuous (at x) f \<longleftrightarrow> (f ---> f(x)) (at x)"
- using continuous_within [of x UNIV f] by (simp add: within_UNIV)
-
-lemma continuous_at_within:
- assumes "continuous (at x) f" shows "continuous (at x within s) f"
- using assms unfolding continuous_at continuous_within
- by (rule Lim_at_within)
-
-text{* Derive the epsilon-delta forms, which we often use as "definitions" *}
-
-lemma continuous_within_eps_delta:
- "continuous (at x within s) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0. \<forall>x'\<in> s. dist x' x < d --> dist (f x') (f x) < e)"
- unfolding continuous_within and Lim_within
- apply auto unfolding dist_nz[THEN sym] apply(auto elim!:allE) apply(rule_tac x=d in exI) by auto
-
-lemma continuous_at_eps_delta: "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
- \<forall>x'. dist x' x < d --> dist(f x')(f x) < e)"
- using continuous_within_eps_delta[of x UNIV f]
- unfolding within_UNIV by blast
-
-text{* Versions in terms of open balls. *}
-
-lemma continuous_within_ball:
- "continuous (at x within s) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
- f ` (ball x d \<inter> s) \<subseteq> ball (f x) e)" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix e::real assume "e>0"
- then obtain d where d: "d>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e"
- using `?lhs`[unfolded continuous_within Lim_within] by auto
- { fix y assume "y\<in>f ` (ball x d \<inter> s)"
- hence "y \<in> ball (f x) e" using d(2) unfolding dist_nz[THEN sym]
- apply (auto simp add: dist_commute mem_ball) apply(erule_tac x=xa in ballE) apply auto using `e>0` by auto
- }
- hence "\<exists>d>0. f ` (ball x d \<inter> s) \<subseteq> ball (f x) e" using `d>0` unfolding subset_eq ball_def by (auto simp add: dist_commute) }
- thus ?rhs by auto
-next
- assume ?rhs thus ?lhs unfolding continuous_within Lim_within ball_def subset_eq
- apply (auto simp add: dist_commute) apply(erule_tac x=e in allE) by auto
-qed
-
-lemma continuous_at_ball:
- "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0. f ` (ball x d) \<subseteq> ball (f x) e)" (is "?lhs = ?rhs")
-proof
- assume ?lhs thus ?rhs unfolding continuous_at Lim_at subset_eq Ball_def Bex_def image_iff mem_ball
- apply auto apply(erule_tac x=e in allE) apply auto apply(rule_tac x=d in exI) apply auto apply(erule_tac x=xa in allE) apply (auto simp add: dist_commute dist_nz)
- unfolding dist_nz[THEN sym] by auto
-next
- assume ?rhs thus ?lhs unfolding continuous_at Lim_at subset_eq Ball_def Bex_def image_iff mem_ball
- apply auto apply(erule_tac x=e in allE) apply auto apply(rule_tac x=d in exI) apply auto apply(erule_tac x="f xa" in allE) by (auto simp add: dist_commute dist_nz)
-qed
-
-text{* For setwise continuity, just start from the epsilon-delta definitions. *}
-
-definition
- continuous_on :: "'a::metric_space set \<Rightarrow> ('a \<Rightarrow> 'b::metric_space) \<Rightarrow> bool" where
- "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. \<forall>e>0. \<exists>d::real>0. \<forall>x' \<in> s. dist x' x < d --> dist (f x') (f x) < e)"
-
-
-definition
- uniformly_continuous_on ::
- "'a::metric_space set \<Rightarrow> ('a \<Rightarrow> 'b::metric_space) \<Rightarrow> bool" where
- "uniformly_continuous_on s f \<longleftrightarrow>
- (\<forall>e>0. \<exists>d>0. \<forall>x\<in>s. \<forall> x'\<in>s. dist x' x < d
- --> dist (f x') (f x) < e)"
-
-text{* Some simple consequential lemmas. *}
-
-lemma uniformly_continuous_imp_continuous:
- " uniformly_continuous_on s f ==> continuous_on s f"
- unfolding uniformly_continuous_on_def continuous_on_def by blast
-
-lemma continuous_at_imp_continuous_within:
- "continuous (at x) f ==> continuous (at x within s) f"
- unfolding continuous_within continuous_at using Lim_at_within by auto
-
-lemma continuous_at_imp_continuous_on: assumes "(\<forall>x \<in> s. continuous (at x) f)"
- shows "continuous_on s f"
-proof(simp add: continuous_at continuous_on_def, rule, rule, rule)
- fix x and e::real assume "x\<in>s" "e>0"
- hence "eventually (\<lambda>xa. dist (f xa) (f x) < e) (at x)" using assms unfolding continuous_at tendsto_iff by auto
- then obtain d where d:"d>0" "\<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" unfolding eventually_at by auto
- { fix x' assume "\<not> 0 < dist x' x"
- hence "x=x'"
- using dist_nz[of x' x] by auto
- hence "dist (f x') (f x) < e" using `e>0` by auto
- }
- thus "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using d by auto
-qed
-
-lemma continuous_on_eq_continuous_within:
- "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. continuous (at x within s) f)" (is "?lhs = ?rhs")
-proof
- assume ?rhs
- { fix x assume "x\<in>s"
- fix e::real assume "e>0"
- assume "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e"
- then obtain d where "d>0" and d:"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" by auto
- { fix x' assume as:"x'\<in>s" "dist x' x < d"
- hence "dist (f x') (f x) < e" using `e>0` d `x'\<in>s` dist_eq_0_iff[of x' x] zero_le_dist[of x' x] as(2) by (metis dist_eq_0_iff dist_nz) }
- hence "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using `d>0` by auto
- }
- thus ?lhs using `?rhs` unfolding continuous_on_def continuous_within Lim_within by auto
-next
- assume ?lhs
- thus ?rhs unfolding continuous_on_def continuous_within Lim_within by blast
-qed
-
-lemma continuous_on:
- "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. (f ---> f(x)) (at x within s))"
- by (auto simp add: continuous_on_eq_continuous_within continuous_within)
-
-lemma continuous_on_eq_continuous_at:
- "open s ==> (continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. continuous (at x) f))"
- by (auto simp add: continuous_on continuous_at Lim_within_open)
-
-lemma continuous_within_subset:
- "continuous (at x within s) f \<Longrightarrow> t \<subseteq> s
- ==> continuous (at x within t) f"
- unfolding continuous_within by(metis Lim_within_subset)
-
-lemma continuous_on_subset:
- "continuous_on s f \<Longrightarrow> t \<subseteq> s ==> continuous_on t f"
- unfolding continuous_on by (metis subset_eq Lim_within_subset)
-
-lemma continuous_on_interior:
- "continuous_on s f \<Longrightarrow> x \<in> interior s ==> continuous (at x) f"
-unfolding interior_def
-apply simp
-by (meson continuous_on_eq_continuous_at continuous_on_subset)
-
-lemma continuous_on_eq:
- "(\<forall>x \<in> s. f x = g x) \<Longrightarrow> continuous_on s f
- ==> continuous_on s g"
- by (simp add: continuous_on_def)
-
-text{* Characterization of various kinds of continuity in terms of sequences. *}
-
-(* \<longrightarrow> could be generalized, but \<longleftarrow> requires metric space *)
-lemma continuous_within_sequentially:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space"
- shows "continuous (at a within s) f \<longleftrightarrow>
- (\<forall>x. (\<forall>n::nat. x n \<in> s) \<and> (x ---> a) sequentially
- --> ((f o x) ---> f a) sequentially)" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix x::"nat \<Rightarrow> 'a" assume x:"\<forall>n. x n \<in> s" "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (x n) a < e"
- fix e::real assume "e>0"
- from `?lhs` obtain d where "d>0" and d:"\<forall>x\<in>s. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) (f a) < e" unfolding continuous_within Lim_within using `e>0` by auto
- from x(2) `d>0` obtain N where N:"\<forall>n\<ge>N. dist (x n) a < d" by auto
- hence "\<exists>N. \<forall>n\<ge>N. dist ((f \<circ> x) n) (f a) < e"
- apply(rule_tac x=N in exI) using N d apply auto using x(1)
- apply(erule_tac x=n in allE) apply(erule_tac x=n in allE)
- apply(erule_tac x="x n" in ballE) apply auto unfolding dist_nz[THEN sym] apply auto using `e>0` by auto
- }
- thus ?rhs unfolding continuous_within unfolding Lim_sequentially by simp
-next
- assume ?rhs
- { fix e::real assume "e>0"
- assume "\<not> (\<exists>d>0. \<forall>x\<in>s. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) (f a) < e)"
- hence "\<forall>d. \<exists>x. d>0 \<longrightarrow> x\<in>s \<and> (0 < dist x a \<and> dist x a < d \<and> \<not> dist (f x) (f a) < e)" by blast
- then obtain x where x:"\<forall>d>0. x d \<in> s \<and> (0 < dist (x d) a \<and> dist (x d) a < d \<and> \<not> dist (f (x d)) (f a) < e)"
- using choice[of "\<lambda>d x.0<d \<longrightarrow> x\<in>s \<and> (0 < dist x a \<and> dist x a < d \<and> \<not> dist (f x) (f a) < e)"] by auto
- { fix d::real assume "d>0"
- hence "\<exists>N::nat. inverse (real (N + 1)) < d" using real_arch_inv[of d] by (auto, rule_tac x="n - 1" in exI)auto
- then obtain N::nat where N:"inverse (real (N + 1)) < d" by auto
- { fix n::nat assume n:"n\<ge>N"
- hence "dist (x (inverse (real (n + 1)))) a < inverse (real (n + 1))" using x[THEN spec[where x="inverse (real (n + 1))"]] by auto
- moreover have "inverse (real (n + 1)) < d" using N n by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
- ultimately have "dist (x (inverse (real (n + 1)))) a < d" by auto
- }
- hence "\<exists>N::nat. \<forall>n\<ge>N. dist (x (inverse (real (n + 1)))) a < d" by auto
- }
- hence "(\<forall>n::nat. x (inverse (real (n + 1))) \<in> s) \<and> (\<forall>e>0. \<exists>N::nat. \<forall>n\<ge>N. dist (x (inverse (real (n + 1)))) a < e)" using x by auto
- hence "\<forall>e>0. \<exists>N::nat. \<forall>n\<ge>N. dist (f (x (inverse (real (n + 1))))) (f a) < e" using `?rhs`[THEN spec[where x="\<lambda>n::nat. x (inverse (real (n+1)))"], unfolded Lim_sequentially] by auto
- hence "False" apply(erule_tac x=e in allE) using `e>0` using x by auto
- }
- thus ?lhs unfolding continuous_within unfolding Lim_within unfolding Lim_sequentially by blast
-qed
-
-lemma continuous_at_sequentially:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space"
- shows "continuous (at a) f \<longleftrightarrow> (\<forall>x. (x ---> a) sequentially
- --> ((f o x) ---> f a) sequentially)"
- using continuous_within_sequentially[of a UNIV f] unfolding within_UNIV by auto
-
-lemma continuous_on_sequentially:
- "continuous_on s f \<longleftrightarrow> (\<forall>x. \<forall>a \<in> s. (\<forall>n. x(n) \<in> s) \<and> (x ---> a) sequentially
- --> ((f o x) ---> f(a)) sequentially)" (is "?lhs = ?rhs")
-proof
- assume ?rhs thus ?lhs using continuous_within_sequentially[of _ s f] unfolding continuous_on_eq_continuous_within by auto
-next
- assume ?lhs thus ?rhs unfolding continuous_on_eq_continuous_within using continuous_within_sequentially[of _ s f] by auto
-qed
-
-lemma uniformly_continuous_on_sequentially:
- fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
- shows "uniformly_continuous_on s f \<longleftrightarrow> (\<forall>x y. (\<forall>n. x n \<in> s) \<and> (\<forall>n. y n \<in> s) \<and>
- ((\<lambda>n. x n - y n) ---> 0) sequentially
- \<longrightarrow> ((\<lambda>n. f(x n) - f(y n)) ---> 0) sequentially)" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix x y assume x:"\<forall>n. x n \<in> s" and y:"\<forall>n. y n \<in> s" and xy:"((\<lambda>n. x n - y n) ---> 0) sequentially"
- { fix e::real assume "e>0"
- then obtain d where "d>0" and d:"\<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e"
- using `?lhs`[unfolded uniformly_continuous_on_def, THEN spec[where x=e]] by auto
- obtain N where N:"\<forall>n\<ge>N. norm (x n - y n - 0) < d" using xy[unfolded Lim_sequentially dist_norm] and `d>0` by auto
- { fix n assume "n\<ge>N"
- hence "norm (f (x n) - f (y n) - 0) < e"
- using N[THEN spec[where x=n]] using d[THEN bspec[where x="x n"], THEN bspec[where x="y n"]] using x and y
- unfolding dist_commute and dist_norm by simp }
- hence "\<exists>N. \<forall>n\<ge>N. norm (f (x n) - f (y n) - 0) < e" by auto }
- hence "((\<lambda>n. f(x n) - f(y n)) ---> 0) sequentially" unfolding Lim_sequentially and dist_norm by auto }
- thus ?rhs by auto
-next
- assume ?rhs
- { assume "\<not> ?lhs"
- then obtain e where "e>0" "\<forall>d>0. \<exists>x\<in>s. \<exists>x'\<in>s. dist x' x < d \<and> \<not> dist (f x') (f x) < e" unfolding uniformly_continuous_on_def by auto
- then obtain fa where fa:"\<forall>x. 0 < x \<longrightarrow> fst (fa x) \<in> s \<and> snd (fa x) \<in> s \<and> dist (fst (fa x)) (snd (fa x)) < x \<and> \<not> dist (f (fst (fa x))) (f (snd (fa x))) < e"
- using choice[of "\<lambda>d x. d>0 \<longrightarrow> fst x \<in> s \<and> snd x \<in> s \<and> dist (snd x) (fst x) < d \<and> \<not> dist (f (snd x)) (f (fst x)) < e"] unfolding Bex_def
- by (auto simp add: dist_commute)
- def x \<equiv> "\<lambda>n::nat. fst (fa (inverse (real n + 1)))"
- def y \<equiv> "\<lambda>n::nat. snd (fa (inverse (real n + 1)))"
- have xyn:"\<forall>n. x n \<in> s \<and> y n \<in> s" and xy0:"\<forall>n. dist (x n) (y n) < inverse (real n + 1)" and fxy:"\<forall>n. \<not> dist (f (x n)) (f (y n)) < e"
- unfolding x_def and y_def using fa by auto
- have 1:"\<And>(x::'a) y. dist (x - y) 0 = dist x y" unfolding dist_norm by auto
- have 2:"\<And>(x::'b) y. dist (x - y) 0 = dist x y" unfolding dist_norm by auto
- { fix e::real assume "e>0"
- then obtain N::nat where "N \<noteq> 0" and N:"0 < inverse (real N) \<and> inverse (real N) < e" unfolding real_arch_inv[of e] by auto
- { fix n::nat assume "n\<ge>N"
- hence "inverse (real n + 1) < inverse (real N)" using real_of_nat_ge_zero and `N\<noteq>0` by auto
- also have "\<dots> < e" using N by auto
- finally have "inverse (real n + 1) < e" by auto
- hence "dist (x n - y n) 0 < e" unfolding 1 using xy0[THEN spec[where x=n]] by auto }
- hence "\<exists>N. \<forall>n\<ge>N. dist (x n - y n) 0 < e" by auto }
- hence "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (f (x n) - f (y n)) 0 < e" using `?rhs`[THEN spec[where x=x], THEN spec[where x=y]] and xyn unfolding Lim_sequentially by auto
- hence False unfolding 2 using fxy and `e>0` by auto }
- thus ?lhs unfolding uniformly_continuous_on_def by blast
-qed
-
-text{* The usual transformation theorems. *}
-
-lemma continuous_transform_within:
- fixes f g :: "'a::metric_space \<Rightarrow> 'b::metric_space"
- assumes "0 < d" "x \<in> s" "\<forall>x' \<in> s. dist x' x < d --> f x' = g x'"
- "continuous (at x within s) f"
- shows "continuous (at x within s) g"
-proof-
- { fix e::real assume "e>0"
- then obtain d' where d':"d'>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < e" using assms(4) unfolding continuous_within Lim_within by auto
- { fix x' assume "x'\<in>s" "0 < dist x' x" "dist x' x < (min d d')"
- hence "dist (f x') (g x) < e" using assms(2,3) apply(erule_tac x=x in ballE) using d' by auto }
- hence "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < (min d d') \<longrightarrow> dist (f xa) (g x) < e" by blast
- hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (g x) < e" using `d>0` `d'>0` by(rule_tac x="min d d'" in exI)auto }
- hence "(f ---> g x) (at x within s)" unfolding Lim_within using assms(1) by auto
- thus ?thesis unfolding continuous_within using Lim_transform_within[of d s x f g "g x"] using assms by blast
-qed
-
-lemma continuous_transform_at:
- fixes f g :: "'a::metric_space \<Rightarrow> 'b::metric_space"
- assumes "0 < d" "\<forall>x'. dist x' x < d --> f x' = g x'"
- "continuous (at x) f"
- shows "continuous (at x) g"
-proof-
- { fix e::real assume "e>0"
- then obtain d' where d':"d'>0" "\<forall>xa. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < e" using assms(3) unfolding continuous_at Lim_at by auto
- { fix x' assume "0 < dist x' x" "dist x' x < (min d d')"
- hence "dist (f x') (g x) < e" using assms(2) apply(erule_tac x=x in allE) using d' by auto
- }
- hence "\<forall>xa. 0 < dist xa x \<and> dist xa x < (min d d') \<longrightarrow> dist (f xa) (g x) < e" by blast
- hence "\<exists>d>0. \<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (g x) < e" using `d>0` `d'>0` by(rule_tac x="min d d'" in exI)auto
- }
- hence "(f ---> g x) (at x)" unfolding Lim_at using assms(1) by auto
- thus ?thesis unfolding continuous_at using Lim_transform_at[of d x f g "g x"] using assms by blast
-qed
-
-text{* Combination results for pointwise continuity. *}
-
-lemma continuous_const: "continuous net (\<lambda>x. c)"
- by (auto simp add: continuous_def Lim_const)
-
-lemma continuous_cmul:
- fixes f :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous net f ==> continuous net (\<lambda>x. c *\<^sub>R f x)"
- by (auto simp add: continuous_def Lim_cmul)
-
-lemma continuous_neg:
- fixes f :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous net f ==> continuous net (\<lambda>x. -(f x))"
- by (auto simp add: continuous_def Lim_neg)
-
-lemma continuous_add:
- fixes f g :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous net f \<Longrightarrow> continuous net g \<Longrightarrow> continuous net (\<lambda>x. f x + g x)"
- by (auto simp add: continuous_def Lim_add)
-
-lemma continuous_sub:
- fixes f g :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous net f \<Longrightarrow> continuous net g \<Longrightarrow> continuous net (\<lambda>x. f x - g x)"
- by (auto simp add: continuous_def Lim_sub)
-
-text{* Same thing for setwise continuity. *}
-
-lemma continuous_on_const:
- "continuous_on s (\<lambda>x. c)"
- unfolding continuous_on_eq_continuous_within using continuous_const by blast
-
-lemma continuous_on_cmul:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous_on s f ==> continuous_on s (\<lambda>x. c *\<^sub>R (f x))"
- unfolding continuous_on_eq_continuous_within using continuous_cmul by blast
-
-lemma continuous_on_neg:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. - f x)"
- unfolding continuous_on_eq_continuous_within using continuous_neg by blast
-
-lemma continuous_on_add:
- fixes f g :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous_on s f \<Longrightarrow> continuous_on s g
- \<Longrightarrow> continuous_on s (\<lambda>x. f x + g x)"
- unfolding continuous_on_eq_continuous_within using continuous_add by blast
-
-lemma continuous_on_sub:
- fixes f g :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous_on s f \<Longrightarrow> continuous_on s g
- \<Longrightarrow> continuous_on s (\<lambda>x. f x - g x)"
- unfolding continuous_on_eq_continuous_within using continuous_sub by blast
-
-text{* Same thing for uniform continuity, using sequential formulations. *}
-
-lemma uniformly_continuous_on_const:
- "uniformly_continuous_on s (\<lambda>x. c)"
- unfolding uniformly_continuous_on_def by simp
-
-lemma uniformly_continuous_on_cmul:
- fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
- (* FIXME: generalize 'a to metric_space *)
- assumes "uniformly_continuous_on s f"
- shows "uniformly_continuous_on s (\<lambda>x. c *\<^sub>R f(x))"
-proof-
- { fix x y assume "((\<lambda>n. f (x n) - f (y n)) ---> 0) sequentially"
- hence "((\<lambda>n. c *\<^sub>R f (x n) - c *\<^sub>R f (y n)) ---> 0) sequentially"
- using Lim_cmul[of "(\<lambda>n. f (x n) - f (y n))" 0 sequentially c]
- unfolding scaleR_zero_right scaleR_right_diff_distrib by auto
- }
- thus ?thesis using assms unfolding uniformly_continuous_on_sequentially by auto
-qed
-
-lemma dist_minus:
- fixes x y :: "'a::real_normed_vector"
- shows "dist (- x) (- y) = dist x y"
- unfolding dist_norm minus_diff_minus norm_minus_cancel ..
-
-lemma uniformly_continuous_on_neg:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "uniformly_continuous_on s f
- ==> uniformly_continuous_on s (\<lambda>x. -(f x))"
- unfolding uniformly_continuous_on_def dist_minus .
-
-lemma uniformly_continuous_on_add:
- fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" (* FIXME: generalize 'a *)
- assumes "uniformly_continuous_on s f" "uniformly_continuous_on s g"
- shows "uniformly_continuous_on s (\<lambda>x. f x + g x)"
-proof-
- { fix x y assume "((\<lambda>n. f (x n) - f (y n)) ---> 0) sequentially"
- "((\<lambda>n. g (x n) - g (y n)) ---> 0) sequentially"
- hence "((\<lambda>xa. f (x xa) - f (y xa) + (g (x xa) - g (y xa))) ---> 0 + 0) sequentially"
- using Lim_add[of "\<lambda> n. f (x n) - f (y n)" 0 sequentially "\<lambda> n. g (x n) - g (y n)" 0] by auto
- hence "((\<lambda>n. f (x n) + g (x n) - (f (y n) + g (y n))) ---> 0) sequentially" unfolding Lim_sequentially and add_diff_add [symmetric] by auto }
- thus ?thesis using assms unfolding uniformly_continuous_on_sequentially by auto
-qed
-
-lemma uniformly_continuous_on_sub:
- fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" (* FIXME: generalize 'a *)
- shows "uniformly_continuous_on s f \<Longrightarrow> uniformly_continuous_on s g
- ==> uniformly_continuous_on s (\<lambda>x. f x - g x)"
- unfolding ab_diff_minus
- using uniformly_continuous_on_add[of s f "\<lambda>x. - g x"]
- using uniformly_continuous_on_neg[of s g] by auto
-
-text{* Identity function is continuous in every sense. *}
-
-lemma continuous_within_id:
- "continuous (at a within s) (\<lambda>x. x)"
- unfolding continuous_within by (rule Lim_at_within [OF Lim_ident_at])
-
-lemma continuous_at_id:
- "continuous (at a) (\<lambda>x. x)"
- unfolding continuous_at by (rule Lim_ident_at)
-
-lemma continuous_on_id:
- "continuous_on s (\<lambda>x. x)"
- unfolding continuous_on Lim_within by auto
-
-lemma uniformly_continuous_on_id:
- "uniformly_continuous_on s (\<lambda>x. x)"
- unfolding uniformly_continuous_on_def by auto
-
-text{* Continuity of all kinds is preserved under composition. *}
-
-lemma continuous_within_compose:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- fixes g :: "'b::metric_space \<Rightarrow> 'c::metric_space"
- assumes "continuous (at x within s) f" "continuous (at (f x) within f ` s) g"
- shows "continuous (at x within s) (g o f)"
-proof-
- { fix e::real assume "e>0"
- with assms(2)[unfolded continuous_within Lim_within] obtain d where "d>0" and d:"\<forall>xa\<in>f ` s. 0 < dist xa (f x) \<and> dist xa (f x) < d \<longrightarrow> dist (g xa) (g (f x)) < e" by auto
- from assms(1)[unfolded continuous_within Lim_within] obtain d' where "d'>0" and d':"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < d" using `d>0` by auto
- { fix y assume as:"y\<in>s" "0 < dist y x" "dist y x < d'"
- hence "dist (f y) (f x) < d" using d'[THEN bspec[where x=y]] by (auto simp add:dist_commute)
- hence "dist (g (f y)) (g (f x)) < e" using as(1) d[THEN bspec[where x="f y"]] unfolding dist_nz[THEN sym] using `e>0` by auto }
- hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (g (f xa)) (g (f x)) < e" using `d'>0` by auto }
- thus ?thesis unfolding continuous_within Lim_within by auto
-qed
-
-lemma continuous_at_compose:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- fixes g :: "'b::metric_space \<Rightarrow> 'c::metric_space"
- assumes "continuous (at x) f" "continuous (at (f x)) g"
- shows "continuous (at x) (g o f)"
-proof-
- have " continuous (at (f x) within range f) g" using assms(2) using continuous_within_subset[of "f x" UNIV g "range f", unfolded within_UNIV] by auto
- thus ?thesis using assms(1) using continuous_within_compose[of x UNIV f g, unfolded within_UNIV] by auto
-qed
-
-lemma continuous_on_compose:
- "continuous_on s f \<Longrightarrow> continuous_on (f ` s) g \<Longrightarrow> continuous_on s (g o f)"
- unfolding continuous_on_eq_continuous_within using continuous_within_compose[of _ s f g] by auto
-
-lemma uniformly_continuous_on_compose:
- assumes "uniformly_continuous_on s f" "uniformly_continuous_on (f ` s) g"
- shows "uniformly_continuous_on s (g o f)"
-proof-
- { fix e::real assume "e>0"
- then obtain d where "d>0" and d:"\<forall>x\<in>f ` s. \<forall>x'\<in>f ` s. dist x' x < d \<longrightarrow> dist (g x') (g x) < e" using assms(2) unfolding uniformly_continuous_on_def by auto
- obtain d' where "d'>0" "\<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d' \<longrightarrow> dist (f x') (f x) < d" using `d>0` using assms(1) unfolding uniformly_continuous_on_def by auto
- hence "\<exists>d>0. \<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist ((g \<circ> f) x') ((g \<circ> f) x) < e" using `d>0` using d by auto }
- thus ?thesis using assms unfolding uniformly_continuous_on_def by auto
-qed
-
-text{* Continuity in terms of open preimages. *}
-
-lemma continuous_at_open:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- shows "continuous (at x) f \<longleftrightarrow> (\<forall>t. open t \<and> f x \<in> t --> (\<exists>s. open s \<and> x \<in> s \<and> (\<forall>x' \<in> s. (f x') \<in> t)))" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix t assume as: "open t" "f x \<in> t"
- then obtain e where "e>0" and e:"ball (f x) e \<subseteq> t" unfolding open_contains_ball by auto
-
- obtain d where "d>0" and d:"\<forall>y. 0 < dist y x \<and> dist y x < d \<longrightarrow> dist (f y) (f x) < e" using `e>0` using `?lhs`[unfolded continuous_at Lim_at open_dist] by auto
-
- have "open (ball x d)" using open_ball by auto
- moreover have "x \<in> ball x d" unfolding centre_in_ball using `d>0` by simp
- moreover
- { fix x' assume "x'\<in>ball x d" hence "f x' \<in> t"
- using e[unfolded subset_eq Ball_def mem_ball, THEN spec[where x="f x'"]] d[THEN spec[where x=x']]
- unfolding mem_ball apply (auto simp add: dist_commute)
- unfolding dist_nz[THEN sym] using as(2) by auto }
- hence "\<forall>x'\<in>ball x d. f x' \<in> t" by auto
- ultimately have "\<exists>s. open s \<and> x \<in> s \<and> (\<forall>x'\<in>s. f x' \<in> t)"
- apply(rule_tac x="ball x d" in exI) by simp }
- thus ?rhs by auto
-next
- assume ?rhs
- { fix e::real assume "e>0"
- then obtain s where s: "open s" "x \<in> s" "\<forall>x'\<in>s. f x' \<in> ball (f x) e" using `?rhs`[unfolded continuous_at Lim_at, THEN spec[where x="ball (f x) e"]]
- unfolding centre_in_ball[of "f x" e, THEN sym] by auto
- then obtain d where "d>0" and d:"ball x d \<subseteq> s" unfolding open_contains_ball by auto
- { fix y assume "0 < dist y x \<and> dist y x < d"
- hence "dist (f y) (f x) < e" using d[unfolded subset_eq Ball_def mem_ball, THEN spec[where x=y]]
- using s(3)[THEN bspec[where x=y], unfolded mem_ball] by (auto simp add: dist_commute) }
- hence "\<exists>d>0. \<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" using `d>0` by auto }
- thus ?lhs unfolding continuous_at Lim_at by auto
-qed
-
-lemma continuous_on_open:
- "continuous_on s f \<longleftrightarrow>
- (\<forall>t. openin (subtopology euclidean (f ` s)) t
- --> openin (subtopology euclidean s) {x \<in> s. f x \<in> t})" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix t assume as:"openin (subtopology euclidean (f ` s)) t"
- have "{x \<in> s. f x \<in> t} \<subseteq> s" using as[unfolded openin_euclidean_subtopology_iff] by auto
- moreover
- { fix x assume as':"x\<in>{x \<in> s. f x \<in> t}"
- then obtain e where e: "e>0" "\<forall>x'\<in>f ` s. dist x' (f x) < e \<longrightarrow> x' \<in> t" using as[unfolded openin_euclidean_subtopology_iff, THEN conjunct2, THEN bspec[where x="f x"]] by auto
- from this(1) obtain d where d: "d>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" using `?lhs`[unfolded continuous_on Lim_within, THEN bspec[where x=x]] using as' by auto
- have "\<exists>e>0. \<forall>x'\<in>s. dist x' x < e \<longrightarrow> x' \<in> {x \<in> s. f x \<in> t}" using d e unfolding dist_nz[THEN sym] by (rule_tac x=d in exI, auto) }
- ultimately have "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}" unfolding openin_euclidean_subtopology_iff by auto }
- thus ?rhs unfolding continuous_on Lim_within using openin by auto
-next
- assume ?rhs
- { fix e::real and x assume "x\<in>s" "e>0"
- { fix xa x' assume "dist (f xa) (f x) < e" "xa \<in> s" "x' \<in> s" "dist (f xa) (f x') < e - dist (f xa) (f x)"
- hence "dist (f x') (f x) < e" using dist_triangle[of "f x'" "f x" "f xa"]
- by (auto simp add: dist_commute) }
- hence "ball (f x) e \<inter> f ` s \<subseteq> f ` s \<and> (\<forall>xa\<in>ball (f x) e \<inter> f ` s. \<exists>ea>0. \<forall>x'\<in>f ` s. dist x' xa < ea \<longrightarrow> x' \<in> ball (f x) e \<inter> f ` s)" apply auto
- apply(rule_tac x="e - dist (f xa) (f x)" in exI) using `e>0` by (auto simp add: dist_commute)
- hence "\<forall>xa\<in>{xa \<in> s. f xa \<in> ball (f x) e \<inter> f ` s}. \<exists>ea>0. \<forall>x'\<in>s. dist x' xa < ea \<longrightarrow> x' \<in> {xa \<in> s. f xa \<in> ball (f x) e \<inter> f ` s}"
- using `?rhs`[unfolded openin_euclidean_subtopology_iff, THEN spec[where x="ball (f x) e \<inter> f ` s"]] by auto
- hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" apply(erule_tac x=x in ballE) apply auto using `e>0` `x\<in>s` by (auto simp add: dist_commute) }
- thus ?lhs unfolding continuous_on Lim_within by auto
-qed
-
-(* ------------------------------------------------------------------------- *)
-(* Similarly in terms of closed sets. *)
-(* ------------------------------------------------------------------------- *)
-
-lemma continuous_on_closed:
- "continuous_on s f \<longleftrightarrow> (\<forall>t. closedin (subtopology euclidean (f ` s)) t --> closedin (subtopology euclidean s) {x \<in> s. f x \<in> t})" (is "?lhs = ?rhs")
-proof
- assume ?lhs
- { fix t
- have *:"s - {x \<in> s. f x \<in> f ` s - t} = {x \<in> s. f x \<in> t}" by auto
- have **:"f ` s - (f ` s - (f ` s - t)) = f ` s - t" by auto
- assume as:"closedin (subtopology euclidean (f ` s)) t"
- hence "closedin (subtopology euclidean (f ` s)) (f ` s - (f ` s - t))" unfolding closedin_def topspace_euclidean_subtopology unfolding ** by auto
- hence "closedin (subtopology euclidean s) {x \<in> s. f x \<in> t}" using `?lhs`[unfolded continuous_on_open, THEN spec[where x="(f ` s) - t"]]
- unfolding openin_closedin_eq topspace_euclidean_subtopology unfolding * by auto }
- thus ?rhs by auto
-next
- assume ?rhs
- { fix t
- have *:"s - {x \<in> s. f x \<in> f ` s - t} = {x \<in> s. f x \<in> t}" by auto
- assume as:"openin (subtopology euclidean (f ` s)) t"
- hence "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}" using `?rhs`[THEN spec[where x="(f ` s) - t"]]
- unfolding openin_closedin_eq topspace_euclidean_subtopology *[THEN sym] closedin_subtopology by auto }
- thus ?lhs unfolding continuous_on_open by auto
-qed
-
-text{* Half-global and completely global cases. *}
-
-lemma continuous_open_in_preimage:
- assumes "continuous_on s f" "open t"
- shows "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}"
-proof-
- have *:"\<forall>x. x \<in> s \<and> f x \<in> t \<longleftrightarrow> x \<in> s \<and> f x \<in> (t \<inter> f ` s)" by auto
- have "openin (subtopology euclidean (f ` s)) (t \<inter> f ` s)"
- using openin_open_Int[of t "f ` s", OF assms(2)] unfolding openin_open by auto
- thus ?thesis using assms(1)[unfolded continuous_on_open, THEN spec[where x="t \<inter> f ` s"]] using * by auto
-qed
-
-lemma continuous_closed_in_preimage:
- assumes "continuous_on s f" "closed t"
- shows "closedin (subtopology euclidean s) {x \<in> s. f x \<in> t}"
-proof-
- have *:"\<forall>x. x \<in> s \<and> f x \<in> t \<longleftrightarrow> x \<in> s \<and> f x \<in> (t \<inter> f ` s)" by auto
- have "closedin (subtopology euclidean (f ` s)) (t \<inter> f ` s)"
- using closedin_closed_Int[of t "f ` s", OF assms(2)] unfolding Int_commute by auto
- thus ?thesis
- using assms(1)[unfolded continuous_on_closed, THEN spec[where x="t \<inter> f ` s"]] using * by auto
-qed
-
-lemma continuous_open_preimage:
- assumes "continuous_on s f" "open s" "open t"
- shows "open {x \<in> s. f x \<in> t}"
-proof-
- obtain T where T: "open T" "{x \<in> s. f x \<in> t} = s \<inter> T"
- using continuous_open_in_preimage[OF assms(1,3)] unfolding openin_open by auto
- thus ?thesis using open_Int[of s T, OF assms(2)] by auto
-qed
-
-lemma continuous_closed_preimage:
- assumes "continuous_on s f" "closed s" "closed t"
- shows "closed {x \<in> s. f x \<in> t}"
-proof-
- obtain T where T: "closed T" "{x \<in> s. f x \<in> t} = s \<inter> T"
- using continuous_closed_in_preimage[OF assms(1,3)] unfolding closedin_closed by auto
- thus ?thesis using closed_Int[of s T, OF assms(2)] by auto
-qed
-
-lemma continuous_open_preimage_univ:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- shows "\<forall>x. continuous (at x) f \<Longrightarrow> open s \<Longrightarrow> open {x. f x \<in> s}"
- using continuous_open_preimage[of UNIV f s] open_UNIV continuous_at_imp_continuous_on by auto
-
-lemma continuous_closed_preimage_univ:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- shows "(\<forall>x. continuous (at x) f) \<Longrightarrow> closed s ==> closed {x. f x \<in> s}"
- using continuous_closed_preimage[of UNIV f s] closed_UNIV continuous_at_imp_continuous_on by auto
-
-lemma continuous_open_vimage:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- shows "\<forall>x. continuous (at x) f \<Longrightarrow> open s \<Longrightarrow> open (f -` s)"
- unfolding vimage_def by (rule continuous_open_preimage_univ)
-
-lemma continuous_closed_vimage:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- shows "\<forall>x. continuous (at x) f \<Longrightarrow> closed s \<Longrightarrow> closed (f -` s)"
- unfolding vimage_def by (rule continuous_closed_preimage_univ)
-
-text{* Equality of continuous functions on closure and related results. *}
-
-lemma continuous_closed_in_preimage_constant:
- "continuous_on s f ==> closedin (subtopology euclidean s) {x \<in> s. f x = a}"
- using continuous_closed_in_preimage[of s f "{a}"] closed_sing by auto
-
-lemma continuous_closed_preimage_constant:
- "continuous_on s f \<Longrightarrow> closed s ==> closed {x \<in> s. f x = a}"
- using continuous_closed_preimage[of s f "{a}"] closed_sing by auto
-
-lemma continuous_constant_on_closure:
- assumes "continuous_on (closure s) f"
- "\<forall>x \<in> s. f x = a"
- shows "\<forall>x \<in> (closure s). f x = a"
- using continuous_closed_preimage_constant[of "closure s" f a]
- assms closure_minimal[of s "{x \<in> closure s. f x = a}"] closure_subset unfolding subset_eq by auto
-
-lemma image_closure_subset:
- assumes "continuous_on (closure s) f" "closed t" "(f ` s) \<subseteq> t"
- shows "f ` (closure s) \<subseteq> t"
-proof-
- have "s \<subseteq> {x \<in> closure s. f x \<in> t}" using assms(3) closure_subset by auto
- moreover have "closed {x \<in> closure s. f x \<in> t}"
- using continuous_closed_preimage[OF assms(1)] and assms(2) by auto
- ultimately have "closure s = {x \<in> closure s . f x \<in> t}"
- using closure_minimal[of s "{x \<in> closure s. f x \<in> t}"] by auto
- thus ?thesis by auto
-qed
-
-lemma continuous_on_closure_norm_le:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- assumes "continuous_on (closure s) f" "\<forall>y \<in> s. norm(f y) \<le> b" "x \<in> (closure s)"
- shows "norm(f x) \<le> b"
-proof-
- have *:"f ` s \<subseteq> cball 0 b" using assms(2)[unfolded mem_cball_0[THEN sym]] by auto
- show ?thesis
- using image_closure_subset[OF assms(1) closed_cball[of 0 b] *] assms(3)
- unfolding subset_eq apply(erule_tac x="f x" in ballE) by (auto simp add: dist_norm)
-qed
-
-text{* Making a continuous function avoid some value in a neighbourhood. *}
-
-lemma continuous_within_avoid:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- assumes "continuous (at x within s) f" "x \<in> s" "f x \<noteq> a"
- shows "\<exists>e>0. \<forall>y \<in> s. dist x y < e --> f y \<noteq> a"
-proof-
- obtain d where "d>0" and d:"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < dist (f x) a"
- using assms(1)[unfolded continuous_within Lim_within, THEN spec[where x="dist (f x) a"]] assms(3)[unfolded dist_nz] by auto
- { fix y assume " y\<in>s" "dist x y < d"
- hence "f y \<noteq> a" using d[THEN bspec[where x=y]] assms(3)[unfolded dist_nz]
- apply auto unfolding dist_nz[THEN sym] by (auto simp add: dist_commute) }
- thus ?thesis using `d>0` by auto
-qed
-
-lemma continuous_at_avoid:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
- assumes "continuous (at x) f" "f x \<noteq> a"
- shows "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> f y \<noteq> a"
-using assms using continuous_within_avoid[of x UNIV f a, unfolded within_UNIV] by auto
-
-lemma continuous_on_avoid:
- assumes "continuous_on s f" "x \<in> s" "f x \<noteq> a"
- shows "\<exists>e>0. \<forall>y \<in> s. dist x y < e \<longrightarrow> f y \<noteq> a"
-using assms(1)[unfolded continuous_on_eq_continuous_within, THEN bspec[where x=x], OF assms(2)] continuous_within_avoid[of x s f a] assms(2,3) by auto
-
-lemma continuous_on_open_avoid:
- assumes "continuous_on s f" "open s" "x \<in> s" "f x \<noteq> a"
- shows "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> f y \<noteq> a"
-using assms(1)[unfolded continuous_on_eq_continuous_at[OF assms(2)], THEN bspec[where x=x], OF assms(3)] continuous_at_avoid[of x f a] assms(3,4) by auto
-
-text{* Proving a function is constant by proving open-ness of level set. *}
-
-lemma continuous_levelset_open_in_cases:
- "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
- openin (subtopology euclidean s) {x \<in> s. f x = a}
- ==> (\<forall>x \<in> s. f x \<noteq> a) \<or> (\<forall>x \<in> s. f x = a)"
-unfolding connected_clopen using continuous_closed_in_preimage_constant by auto
-
-lemma continuous_levelset_open_in:
- "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
- openin (subtopology euclidean s) {x \<in> s. f x = a} \<Longrightarrow>
- (\<exists>x \<in> s. f x = a) ==> (\<forall>x \<in> s. f x = a)"
-using continuous_levelset_open_in_cases[of s f ]
-by meson
-
-lemma continuous_levelset_open:
- assumes "connected s" "continuous_on s f" "open {x \<in> s. f x = a}" "\<exists>x \<in> s. f x = a"
- shows "\<forall>x \<in> s. f x = a"
-using continuous_levelset_open_in[OF assms(1,2), of a, unfolded openin_open] using assms (3,4) by auto
-
-text{* Some arithmetical combinations (more to prove). *}
-
-lemma open_scaling[intro]:
- fixes s :: "'a::real_normed_vector set"
- assumes "c \<noteq> 0" "open s"
- shows "open((\<lambda>x. c *\<^sub>R x) ` s)"
-proof-
- { fix x assume "x \<in> s"
- then obtain e where "e>0" and e:"\<forall>x'. dist x' x < e \<longrightarrow> x' \<in> s" using assms(2)[unfolded open_dist, THEN bspec[where x=x]] by auto
- have "e * abs c > 0" using assms(1)[unfolded zero_less_abs_iff[THEN sym]] using real_mult_order[OF `e>0`] by auto
- moreover
- { fix y assume "dist y (c *\<^sub>R x) < e * \<bar>c\<bar>"
- hence "norm ((1 / c) *\<^sub>R y - x) < e" unfolding dist_norm
- using norm_scaleR[of c "(1 / c) *\<^sub>R y - x", unfolded scaleR_right_diff_distrib, unfolded scaleR_scaleR] assms(1)
- assms(1)[unfolded zero_less_abs_iff[THEN sym]] by (simp del:zero_less_abs_iff)
- hence "y \<in> op *\<^sub>R c ` s" using rev_image_eqI[of "(1 / c) *\<^sub>R y" s y "op *\<^sub>R c"] e[THEN spec[where x="(1 / c) *\<^sub>R y"]] assms(1) unfolding dist_norm scaleR_scaleR by auto }
- ultimately have "\<exists>e>0. \<forall>x'. dist x' (c *\<^sub>R x) < e \<longrightarrow> x' \<in> op *\<^sub>R c ` s" apply(rule_tac x="e * abs c" in exI) by auto }
- thus ?thesis unfolding open_dist by auto
-qed
-
-lemma minus_image_eq_vimage:
- fixes A :: "'a::ab_group_add set"
- shows "(\<lambda>x. - x) ` A = (\<lambda>x. - x) -` A"
- by (auto intro!: image_eqI [where f="\<lambda>x. - x"])
-
-lemma open_negations:
- fixes s :: "'a::real_normed_vector set"
- shows "open s ==> open ((\<lambda> x. -x) ` s)"
- unfolding scaleR_minus1_left [symmetric]
- by (rule open_scaling, auto)
-
-lemma open_translation:
- fixes s :: "'a::real_normed_vector set"
- assumes "open s" shows "open((\<lambda>x. a + x) ` s)"
-proof-
- { fix x have "continuous (at x) (\<lambda>x. x - a)" using continuous_sub[of "at x" "\<lambda>x. x" "\<lambda>x. a"] continuous_at_id[of x] continuous_const[of "at x" a] by auto }
- moreover have "{x. x - a \<in> s} = op + a ` s" apply auto unfolding image_iff apply(rule_tac x="x - a" in bexI) by auto
- ultimately show ?thesis using continuous_open_preimage_univ[of "\<lambda>x. x - a" s] using assms by auto
-qed
-
-lemma open_affinity:
- fixes s :: "'a::real_normed_vector set"
- assumes "open s" "c \<noteq> 0"
- shows "open ((\<lambda>x. a + c *\<^sub>R x) ` s)"
-proof-
- have *:"(\<lambda>x. a + c *\<^sub>R x) = (\<lambda>x. a + x) \<circ> (\<lambda>x. c *\<^sub>R x)" unfolding o_def ..
- have "op + a ` op *\<^sub>R c ` s = (op + a \<circ> op *\<^sub>R c) ` s" by auto
- thus ?thesis using assms open_translation[of "op *\<^sub>R c ` s" a] unfolding * by auto
-qed
-
-lemma interior_translation:
- fixes s :: "'a::real_normed_vector set"
- shows "interior ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (interior s)"
-proof (rule set_ext, rule)
- fix x assume "x \<in> interior (op + a ` s)"
- then obtain e where "e>0" and e:"ball x e \<subseteq> op + a ` s" unfolding mem_interior by auto
- hence "ball (x - a) e \<subseteq> s" unfolding subset_eq Ball_def mem_ball dist_norm apply auto apply(erule_tac x="a + xa" in allE) unfolding ab_group_add_class.diff_diff_eq[THEN sym] by auto
- thus "x \<in> op + a ` interior s" unfolding image_iff apply(rule_tac x="x - a" in bexI) unfolding mem_interior using `e > 0` by auto
-next
- fix x assume "x \<in> op + a ` interior s"
- then obtain y e where "e>0" and e:"ball y e \<subseteq> s" and y:"x = a + y" unfolding image_iff Bex_def mem_interior by auto
- { fix z have *:"a + y - z = y + a - z" by auto
- assume "z\<in>ball x e"
- hence "z - a \<in> s" using e[unfolded subset_eq, THEN bspec[where x="z - a"]] unfolding mem_ball dist_norm y ab_group_add_class.diff_diff_eq2 * by auto
- hence "z \<in> op + a ` s" unfolding image_iff by(auto intro!: bexI[where x="z - a"]) }
- hence "ball x e \<subseteq> op + a ` s" unfolding subset_eq by auto
- thus "x \<in> interior (op + a ` s)" unfolding mem_interior using `e>0` by auto
-qed
-
-subsection {* Preservation of compactness and connectedness under continuous function. *}
-
-lemma compact_continuous_image:
- assumes "continuous_on s f" "compact s"
- shows "compact(f ` s)"
-proof-
- { fix x assume x:"\<forall>n::nat. x n \<in> f ` s"
- then obtain y where y:"\<forall>n. y n \<in> s \<and> x n = f (y n)" unfolding image_iff Bex_def using choice[of "\<lambda>n xa. xa \<in> s \<and> x n = f xa"] by auto
- then obtain l r where "l\<in>s" and r:"subseq r" and lr:"((y \<circ> r) ---> l) sequentially" using assms(2)[unfolded compact_def, THEN spec[where x=y]] by auto
- { fix e::real assume "e>0"
- then obtain d where "d>0" and d:"\<forall>x'\<in>s. dist x' l < d \<longrightarrow> dist (f x') (f l) < e" using assms(1)[unfolded continuous_on_def, THEN bspec[where x=l], OF `l\<in>s`] by auto
- then obtain N::nat where N:"\<forall>n\<ge>N. dist ((y \<circ> r) n) l < d" using lr[unfolded Lim_sequentially, THEN spec[where x=d]] by auto
- { fix n::nat assume "n\<ge>N" hence "dist ((x \<circ> r) n) (f l) < e" using N[THEN spec[where x=n]] d[THEN bspec[where x="y (r n)"]] y[THEN spec[where x="r n"]] by auto }
- hence "\<exists>N. \<forall>n\<ge>N. dist ((x \<circ> r) n) (f l) < e" by auto }
- hence "\<exists>l\<in>f ` s. \<exists>r. subseq r \<and> ((x \<circ> r) ---> l) sequentially" unfolding Lim_sequentially using r lr `l\<in>s` by auto }
- thus ?thesis unfolding compact_def by auto
-qed
-
-lemma connected_continuous_image:
- assumes "continuous_on s f" "connected s"
- shows "connected(f ` s)"
-proof-
- { fix T assume as: "T \<noteq> {}" "T \<noteq> f ` s" "openin (subtopology euclidean (f ` s)) T" "closedin (subtopology euclidean (f ` s)) T"
- have "{x \<in> s. f x \<in> T} = {} \<or> {x \<in> s. f x \<in> T} = s"
- using assms(1)[unfolded continuous_on_open, THEN spec[where x=T]]
- using assms(1)[unfolded continuous_on_closed, THEN spec[where x=T]]
- using assms(2)[unfolded connected_clopen, THEN spec[where x="{x \<in> s. f x \<in> T}"]] as(3,4) by auto
- hence False using as(1,2)
- using as(4)[unfolded closedin_def topspace_euclidean_subtopology] by auto }
- thus ?thesis unfolding connected_clopen by auto
-qed
-
-text{* Continuity implies uniform continuity on a compact domain. *}
-
-lemma compact_uniformly_continuous:
- assumes "continuous_on s f" "compact s"
- shows "uniformly_continuous_on s f"
-proof-
- { fix x assume x:"x\<in>s"
- hence "\<forall>xa. \<exists>y. 0 < xa \<longrightarrow> (y > 0 \<and> (\<forall>x'\<in>s. dist x' x < y \<longrightarrow> dist (f x') (f x) < xa))" using assms(1)[unfolded continuous_on_def, THEN bspec[where x=x]] by auto
- hence "\<exists>fa. \<forall>xa>0. \<forall>x'\<in>s. fa xa > 0 \<and> (dist x' x < fa xa \<longrightarrow> dist (f x') (f x) < xa)" using choice[of "\<lambda>e d. e>0 \<longrightarrow> d>0 \<and>(\<forall>x'\<in>s. (dist x' x < d \<longrightarrow> dist (f x') (f x) < e))"] by auto }
- then have "\<forall>x\<in>s. \<exists>y. \<forall>xa. 0 < xa \<longrightarrow> (\<forall>x'\<in>s. y xa > 0 \<and> (dist x' x < y xa \<longrightarrow> dist (f x') (f x) < xa))" by auto
- then obtain d where d:"\<forall>e>0. \<forall>x\<in>s. \<forall>x'\<in>s. d x e > 0 \<and> (dist x' x < d x e \<longrightarrow> dist (f x') (f x) < e)"
- using bchoice[of s "\<lambda>x fa. \<forall>xa>0. \<forall>x'\<in>s. fa xa > 0 \<and> (dist x' x < fa xa \<longrightarrow> dist (f x') (f x) < xa)"] by blast
-
- { fix e::real assume "e>0"
-
- { fix x assume "x\<in>s" hence "x \<in> ball x (d x (e / 2))" unfolding centre_in_ball using d[THEN spec[where x="e/2"]] using `e>0` by auto }
- hence "s \<subseteq> \<Union>{ball x (d x (e / 2)) |x. x \<in> s}" unfolding subset_eq by auto
- moreover
- { fix b assume "b\<in>{ball x (d x (e / 2)) |x. x \<in> s}" hence "open b" by auto }
- ultimately obtain ea where "ea>0" and ea:"\<forall>x\<in>s. \<exists>b\<in>{ball x (d x (e / 2)) |x. x \<in> s}. ball x ea \<subseteq> b" using heine_borel_lemma[OF assms(2), of "{ball x (d x (e / 2)) | x. x\<in>s }"] by auto
-
- { fix x y assume "x\<in>s" "y\<in>s" and as:"dist y x < ea"
- obtain z where "z\<in>s" and z:"ball x ea \<subseteq> ball z (d z (e / 2))" using ea[THEN bspec[where x=x]] and `x\<in>s` by auto
- hence "x\<in>ball z (d z (e / 2))" using `ea>0` unfolding subset_eq by auto
- hence "dist (f z) (f x) < e / 2" using d[THEN spec[where x="e/2"]] and `e>0` and `x\<in>s` and `z\<in>s`
- by (auto simp add: dist_commute)
- moreover have "y\<in>ball z (d z (e / 2))" using as and `ea>0` and z[unfolded subset_eq]
- by (auto simp add: dist_commute)
- hence "dist (f z) (f y) < e / 2" using d[THEN spec[where x="e/2"]] and `e>0` and `y\<in>s` and `z\<in>s`
- by (auto simp add: dist_commute)
- ultimately have "dist (f y) (f x) < e" using dist_triangle_half_r[of "f z" "f x" e "f y"]
- by (auto simp add: dist_commute) }
- then have "\<exists>d>0. \<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using `ea>0` by auto }
- thus ?thesis unfolding uniformly_continuous_on_def by auto
-qed
-
-text{* Continuity of inverse function on compact domain. *}
-
-lemma continuous_on_inverse:
- fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
- (* TODO: can this be generalized more? *)
- assumes "continuous_on s f" "compact s" "\<forall>x \<in> s. g (f x) = x"
- shows "continuous_on (f ` s) g"
-proof-
- have *:"g ` f ` s = s" using assms(3) by (auto simp add: image_iff)
- { fix t assume t:"closedin (subtopology euclidean (g ` f ` s)) t"
- then obtain T where T: "closed T" "t = s \<inter> T" unfolding closedin_closed unfolding * by auto
- have "continuous_on (s \<inter> T) f" using continuous_on_subset[OF assms(1), of "s \<inter> t"]
- unfolding T(2) and Int_left_absorb by auto
- moreover have "compact (s \<inter> T)"
- using assms(2) unfolding compact_eq_bounded_closed
- using bounded_subset[of s "s \<inter> T"] and T(1) by auto
- ultimately have "closed (f ` t)" using T(1) unfolding T(2)
- using compact_continuous_image [of "s \<inter> T" f] unfolding compact_eq_bounded_closed by auto
- moreover have "{x \<in> f ` s. g x \<in> t} = f ` s \<inter> f ` t" using assms(3) unfolding T(2) by auto
- ultimately have "closedin (subtopology euclidean (f ` s)) {x \<in> f ` s. g x \<in> t}"
- unfolding closedin_closed by auto }
- thus ?thesis unfolding continuous_on_closed by auto
-qed
-
-subsection{* A uniformly convergent limit of continuous functions is continuous. *}
-
-lemma norm_triangle_lt:
- fixes x y :: "'a::real_normed_vector"
- shows "norm x + norm y < e \<Longrightarrow> norm (x + y) < e"
-by (rule le_less_trans [OF norm_triangle_ineq])
-
-lemma continuous_uniform_limit:
- fixes f :: "'a \<Rightarrow> 'b::metric_space \<Rightarrow> 'c::real_normed_vector"
- assumes "\<not> (trivial_limit net)" "eventually (\<lambda>n. continuous_on s (f n)) net"
- "\<forall>e>0. eventually (\<lambda>n. \<forall>x \<in> s. norm(f n x - g x) < e) net"
- shows "continuous_on s g"
-proof-
- { fix x and e::real assume "x\<in>s" "e>0"
- have "eventually (\<lambda>n. \<forall>x\<in>s. norm (f n x - g x) < e / 3) net" using `e>0` assms(3)[THEN spec[where x="e/3"]] by auto
- then obtain n where n:"\<forall>xa\<in>s. norm (f n xa - g xa) < e / 3" "continuous_on s (f n)"
- using eventually_and[of "(\<lambda>n. \<forall>x\<in>s. norm (f n x - g x) < e / 3)" "(\<lambda>n. continuous_on s (f n))" net] assms(1,2) eventually_happens by blast
- have "e / 3 > 0" using `e>0` by auto
- then obtain d where "d>0" and d:"\<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f n x') (f n x) < e / 3"
- using n(2)[unfolded continuous_on_def, THEN bspec[where x=x], OF `x\<in>s`, THEN spec[where x="e/3"]] by blast
- { fix y assume "y\<in>s" "dist y x < d"
- hence "dist (f n y) (f n x) < e / 3" using d[THEN bspec[where x=y]] by auto
- hence "norm (f n y - g x) < 2 * e / 3" using norm_triangle_lt[of "f n y - f n x" "f n x - g x" "2*e/3"]
- using n(1)[THEN bspec[where x=x], OF `x\<in>s`] unfolding dist_norm unfolding ab_group_add_class.ab_diff_minus by auto
- hence "dist (g y) (g x) < e" unfolding dist_norm using n(1)[THEN bspec[where x=y], OF `y\<in>s`]
- unfolding norm_minus_cancel[of "f n y - g y", THEN sym] using norm_triangle_lt[of "f n y - g x" "g y - f n y" e] by (auto simp add: uminus_add_conv_diff) }
- hence "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (g x') (g x) < e" using `d>0` by auto }
- thus ?thesis unfolding continuous_on_def by auto
-qed
-
-subsection{* Topological properties of linear functions. *}
-
-lemma linear_lim_0:
- assumes "bounded_linear f" shows "(f ---> 0) (at (0))"
-proof-
- interpret f: bounded_linear f by fact
- have "(f ---> f 0) (at 0)"
- using tendsto_ident_at by (rule f.tendsto)
- thus ?thesis unfolding f.zero .
-qed
-
-lemma linear_continuous_at:
- assumes "bounded_linear f" shows "continuous (at a) f"
- unfolding continuous_at using assms
- apply (rule bounded_linear.tendsto)
- apply (rule tendsto_ident_at)
- done
-
-lemma linear_continuous_within:
- shows "bounded_linear f ==> continuous (at x within s) f"
- using continuous_at_imp_continuous_within[of x f s] using linear_continuous_at[of f] by auto
-
-lemma linear_continuous_on:
- shows "bounded_linear f ==> continuous_on s f"
- using continuous_at_imp_continuous_on[of s f] using linear_continuous_at[of f] by auto
-
-text{* Also bilinear functions, in composition form. *}
-
-lemma bilinear_continuous_at_compose:
- shows "continuous (at x) f \<Longrightarrow> continuous (at x) g \<Longrightarrow> bounded_bilinear h
- ==> continuous (at x) (\<lambda>x. h (f x) (g x))"
- unfolding continuous_at using Lim_bilinear[of f "f x" "(at x)" g "g x" h] by auto
-
-lemma bilinear_continuous_within_compose:
- shows "continuous (at x within s) f \<Longrightarrow> continuous (at x within s) g \<Longrightarrow> bounded_bilinear h
- ==> continuous (at x within s) (\<lambda>x. h (f x) (g x))"
- unfolding continuous_within using Lim_bilinear[of f "f x"] by auto
-
-lemma bilinear_continuous_on_compose:
- shows "continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> bounded_bilinear h
- ==> continuous_on s (\<lambda>x. h (f x) (g x))"
- unfolding continuous_on_eq_continuous_within apply auto apply(erule_tac x=x in ballE) apply auto apply(erule_tac x=x in ballE) apply auto
- using bilinear_continuous_within_compose[of _ s f g h] by auto
-
-subsection{* Topological stuff lifted from and dropped to R *}
-
-
-lemma open_real:
- fixes s :: "real set" shows
- "open s \<longleftrightarrow>
- (\<forall>x \<in> s. \<exists>e>0. \<forall>x'. abs(x' - x) < e --> x' \<in> s)" (is "?lhs = ?rhs")
- unfolding open_dist dist_norm by simp
-
-lemma islimpt_approachable_real:
- fixes s :: "real set"
- shows "x islimpt s \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in> s. x' \<noteq> x \<and> abs(x' - x) < e)"
- unfolding islimpt_approachable dist_norm by simp
-
-lemma closed_real:
- fixes s :: "real set"
- shows "closed s \<longleftrightarrow>
- (\<forall>x. (\<forall>e>0. \<exists>x' \<in> s. x' \<noteq> x \<and> abs(x' - x) < e)
- --> x \<in> s)"
- unfolding closed_limpt islimpt_approachable dist_norm by simp
-
-lemma continuous_at_real_range:
- fixes f :: "'a::real_normed_vector \<Rightarrow> real"
- shows "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
- \<forall>x'. norm(x' - x) < d --> abs(f x' - f x) < e)"
- unfolding continuous_at unfolding Lim_at
- unfolding dist_nz[THEN sym] unfolding dist_norm apply auto
- apply(erule_tac x=e in allE) apply auto apply (rule_tac x=d in exI) apply auto apply (erule_tac x=x' in allE) apply auto
- apply(erule_tac x=e in allE) by auto
-
-lemma continuous_on_real_range:
- fixes f :: "'a::real_normed_vector \<Rightarrow> real"
- shows "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. \<forall>e>0. \<exists>d>0. (\<forall>x' \<in> s. norm(x' - x) < d --> abs(f x' - f x) < e))"
- unfolding continuous_on_def dist_norm by simp
-
-lemma continuous_at_norm: "continuous (at x) norm"
- unfolding continuous_at by (intro tendsto_intros)
-
-lemma continuous_on_norm: "continuous_on s norm"
-unfolding continuous_on by (intro ballI tendsto_intros)
-
-lemma continuous_at_component: "continuous (at a) (\<lambda>x. x $ i)"
-unfolding continuous_at by (intro tendsto_intros)
-
-lemma continuous_on_component: "continuous_on s (\<lambda>x. x $ i)"
-unfolding continuous_on by (intro ballI tendsto_intros)
-
-lemma continuous_at_infnorm: "continuous (at x) infnorm"
- unfolding continuous_at Lim_at o_def unfolding dist_norm
- apply auto apply (rule_tac x=e in exI) apply auto
- using order_trans[OF real_abs_sub_infnorm infnorm_le_norm, of _ x] by (metis xt1(7))
-
-text{* Hence some handy theorems on distance, diameter etc. of/from a set. *}
-
-lemma compact_attains_sup:
- fixes s :: "real set"
- assumes "compact s" "s \<noteq> {}"
- shows "\<exists>x \<in> s. \<forall>y \<in> s. y \<le> x"
-proof-
- from assms(1) have a:"bounded s" "closed s" unfolding compact_eq_bounded_closed by auto
- { fix e::real assume as: "\<forall>x\<in>s. x \<le> Sup s" "Sup s \<notin> s" "0 < e" "\<forall>x'\<in>s. x' = Sup s \<or> \<not> Sup s - x' < e"
- have "isLub UNIV s (Sup s)" using Sup[OF assms(2)] unfolding setle_def using as(1) by auto
- moreover have "isUb UNIV s (Sup s - e)" unfolding isUb_def unfolding setle_def using as(4,2) by auto
- ultimately have False using isLub_le_isUb[of UNIV s "Sup s" "Sup s - e"] using `e>0` by auto }
- thus ?thesis using bounded_has_Sup(1)[OF a(1) assms(2)] using a(2)[unfolded closed_real, THEN spec[where x="Sup s"]]
- apply(rule_tac x="Sup s" in bexI) by auto
-qed
-
-lemma Inf:
- fixes S :: "real set"
- shows "S \<noteq> {} ==> (\<exists>b. b <=* S) ==> isGlb UNIV S (Inf S)"
-by (auto simp add: isLb_def setle_def setge_def isGlb_def greatestP_def)
-
-lemma compact_attains_inf:
- fixes s :: "real set"
- assumes "compact s" "s \<noteq> {}" shows "\<exists>x \<in> s. \<forall>y \<in> s. x \<le> y"
-proof-
- from assms(1) have a:"bounded s" "closed s" unfolding compact_eq_bounded_closed by auto
- { fix e::real assume as: "\<forall>x\<in>s. x \<ge> Inf s" "Inf s \<notin> s" "0 < e"
- "\<forall>x'\<in>s. x' = Inf s \<or> \<not> abs (x' - Inf s) < e"
- have "isGlb UNIV s (Inf s)" using Inf[OF assms(2)] unfolding setge_def using as(1) by auto
- moreover
- { fix x assume "x \<in> s"
- hence *:"abs (x - Inf s) = x - Inf s" using as(1)[THEN bspec[where x=x]] by auto
- have "Inf s + e \<le> x" using as(4)[THEN bspec[where x=x]] using as(2) `x\<in>s` unfolding * by auto }
- hence "isLb UNIV s (Inf s + e)" unfolding isLb_def and setge_def by auto
- ultimately have False using isGlb_le_isLb[of UNIV s "Inf s" "Inf s + e"] using `e>0` by auto }
- thus ?thesis using bounded_has_Inf(1)[OF a(1) assms(2)] using a(2)[unfolded closed_real, THEN spec[where x="Inf s"]]
- apply(rule_tac x="Inf s" in bexI) by auto
-qed
-
-lemma continuous_attains_sup:
- fixes f :: "'a::metric_space \<Rightarrow> real"
- shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f
- ==> (\<exists>x \<in> s. \<forall>y \<in> s. f y \<le> f x)"
- using compact_attains_sup[of "f ` s"]
- using compact_continuous_image[of s f] by auto
-
-lemma continuous_attains_inf:
- fixes f :: "'a::metric_space \<Rightarrow> real"
- shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f
- \<Longrightarrow> (\<exists>x \<in> s. \<forall>y \<in> s. f x \<le> f y)"
- using compact_attains_inf[of "f ` s"]
- using compact_continuous_image[of s f] by auto
-
-lemma distance_attains_sup:
- assumes "compact s" "s \<noteq> {}"
- shows "\<exists>x \<in> s. \<forall>y \<in> s. dist a y \<le> dist a x"
-proof (rule continuous_attains_sup [OF assms])
- { fix x assume "x\<in>s"
- have "(dist a ---> dist a x) (at x within s)"
- by (intro tendsto_dist tendsto_const Lim_at_within Lim_ident_at)
- }
- thus "continuous_on s (dist a)"
- unfolding continuous_on ..
-qed
-
-text{* For *minimal* distance, we only need closure, not compactness. *}
-
-lemma distance_attains_inf:
- fixes a :: "'a::heine_borel"
- assumes "closed s" "s \<noteq> {}"
- shows "\<exists>x \<in> s. \<forall>y \<in> s. dist a x \<le> dist a y"
-proof-
- from assms(2) obtain b where "b\<in>s" by auto
- let ?B = "cball a (dist b a) \<inter> s"
- have "b \<in> ?B" using `b\<in>s` by (simp add: dist_commute)
- hence "?B \<noteq> {}" by auto
- moreover
- { fix x assume "x\<in>?B"
- fix e::real assume "e>0"
- { fix x' assume "x'\<in>?B" and as:"dist x' x < e"
- from as have "\<bar>dist a x' - dist a x\<bar> < e"
- unfolding abs_less_iff minus_diff_eq
- using dist_triangle2 [of a x' x]
- using dist_triangle [of a x x']
- by arith
- }
- hence "\<exists>d>0. \<forall>x'\<in>?B. dist x' x < d \<longrightarrow> \<bar>dist a x' - dist a x\<bar> < e"
- using `e>0` by auto
- }
- hence "continuous_on (cball a (dist b a) \<inter> s) (dist a)"
- unfolding continuous_on Lim_within dist_norm real_norm_def
- by fast
- moreover have "compact ?B"
- using compact_cball[of a "dist b a"]
- unfolding compact_eq_bounded_closed
- using bounded_Int and closed_Int and assms(1) by auto
- ultimately obtain x where "x\<in>cball a (dist b a) \<inter> s" "\<forall>y\<in>cball a (dist b a) \<inter> s. dist a x \<le> dist a y"
- using continuous_attains_inf[of ?B "dist a"] by fastsimp
- thus ?thesis by fastsimp
-qed
-
-subsection{* We can now extend limit compositions to consider the scalar multiplier. *}
-
-lemma Lim_mul:
- fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
- assumes "(c ---> d) net" "(f ---> l) net"
- shows "((\<lambda>x. c(x) *\<^sub>R f x) ---> (d *\<^sub>R l)) net"
- using assms by (rule scaleR.tendsto)
-
-lemma Lim_vmul:
- fixes c :: "'a \<Rightarrow> real" and v :: "'b::real_normed_vector"
- shows "(c ---> d) net ==> ((\<lambda>x. c(x) *\<^sub>R v) ---> d *\<^sub>R v) net"
- by (intro tendsto_intros)
-
-lemma continuous_vmul:
- fixes c :: "'a::metric_space \<Rightarrow> real" and v :: "'b::real_normed_vector"
- shows "continuous net c ==> continuous net (\<lambda>x. c(x) *\<^sub>R v)"
- unfolding continuous_def using Lim_vmul[of c] by auto
-
-lemma continuous_mul:
- fixes c :: "'a::metric_space \<Rightarrow> real"
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous net c \<Longrightarrow> continuous net f
- ==> continuous net (\<lambda>x. c(x) *\<^sub>R f x) "
- unfolding continuous_def by (intro tendsto_intros)
-
-lemma continuous_on_vmul:
- fixes c :: "'a::metric_space \<Rightarrow> real" and v :: "'b::real_normed_vector"
- shows "continuous_on s c ==> continuous_on s (\<lambda>x. c(x) *\<^sub>R v)"
- unfolding continuous_on_eq_continuous_within using continuous_vmul[of _ c] by auto
-
-lemma continuous_on_mul:
- fixes c :: "'a::metric_space \<Rightarrow> real"
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
- shows "continuous_on s c \<Longrightarrow> continuous_on s f
- ==> continuous_on s (\<lambda>x. c(x) *\<^sub>R f x)"
- unfolding continuous_on_eq_continuous_within using continuous_mul[of _ c] by auto
-
-text{* And so we have continuity of inverse. *}
-
-lemma Lim_inv:
- fixes f :: "'a \<Rightarrow> real"
- assumes "(f ---> l) (net::'a net)" "l \<noteq> 0"
- shows "((inverse o f) ---> inverse l) net"
- unfolding o_def using assms by (rule tendsto_inverse)
-
-lemma continuous_inv:
- fixes f :: "'a::metric_space \<Rightarrow> real"
- shows "continuous net f \<Longrightarrow> f(netlimit net) \<noteq> 0
- ==> continuous net (inverse o f)"
- unfolding continuous_def using Lim_inv by auto
-
-lemma continuous_at_within_inv:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_field"
- assumes "continuous (at a within s) f" "f a \<noteq> 0"
- shows "continuous (at a within s) (inverse o f)"
- using assms unfolding continuous_within o_def
- by (intro tendsto_intros)
-
-lemma continuous_at_inv:
- fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_field"
- shows "continuous (at a) f \<Longrightarrow> f a \<noteq> 0
- ==> continuous (at a) (inverse o f) "
- using within_UNIV[THEN sym, of "at a"] using continuous_at_within_inv[of a UNIV] by auto
-
-subsection{* Preservation properties for pasted sets. *}
-
-lemma bounded_pastecart:
- fixes s :: "('a::real_normed_vector ^ _) set" (* FIXME: generalize to metric_space *)
- assumes "bounded s" "bounded t"
- shows "bounded { pastecart x y | x y . (x \<in> s \<and> y \<in> t)}"
-proof-
- obtain a b where ab:"\<forall>x\<in>s. norm x \<le> a" "\<forall>x\<in>t. norm x \<le> b" using assms[unfolded bounded_iff] by auto
- { fix x y assume "x\<in>s" "y\<in>t"
- hence "norm x \<le> a" "norm y \<le> b" using ab by auto
- hence "norm (pastecart x y) \<le> a + b" using norm_pastecart[of x y] by auto }
- thus ?thesis unfolding bounded_iff by auto
-qed
-
-lemma bounded_Times:
- assumes "bounded s" "bounded t" shows "bounded (s \<times> t)"
-proof-
- obtain x y a b where "\<forall>z\<in>s. dist x z \<le> a" "\<forall>z\<in>t. dist y z \<le> b"
- using assms [unfolded bounded_def] by auto
- then have "\<forall>z\<in>s \<times> t. dist (x, y) z \<le> sqrt (a\<twosuperior> + b\<twosuperior>)"
- by (auto simp add: dist_Pair_Pair real_sqrt_le_mono add_mono power_mono)
- thus ?thesis unfolding bounded_any_center [where a="(x, y)"] by auto
-qed
-
-lemma closed_pastecart:
- fixes s :: "(real ^ 'a::finite) set" (* FIXME: generalize *)
- assumes "closed s" "closed t"
- shows "closed {pastecart x y | x y . x \<in> s \<and> y \<in> t}"
-proof-
- { fix x l assume as:"\<forall>n::nat. x n \<in> {pastecart x y |x y. x \<in> s \<and> y \<in> t}" "(x ---> l) sequentially"
- { fix n::nat have "fstcart (x n) \<in> s" "sndcart (x n) \<in> t" using as(1)[THEN spec[where x=n]] by auto } note * = this
- moreover
- { fix e::real assume "e>0"
- then obtain N::nat where N:"\<forall>n\<ge>N. dist (x n) l < e" using as(2)[unfolded Lim_sequentially, THEN spec[where x=e]] by auto
- { fix n::nat assume "n\<ge>N"
- hence "dist (fstcart (x n)) (fstcart l) < e" "dist (sndcart (x n)) (sndcart l) < e"
- using N[THEN spec[where x=n]] dist_fstcart[of "x n" l] dist_sndcart[of "x n" l] by auto }
- hence "\<exists>N. \<forall>n\<ge>N. dist (fstcart (x n)) (fstcart l) < e" "\<exists>N. \<forall>n\<ge>N. dist (sndcart (x n)) (sndcart l) < e" by auto }
- ultimately have "fstcart l \<in> s" "sndcart l \<in> t"
- using assms(1)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. fstcart (x n)"], THEN spec[where x="fstcart l"]]
- using assms(2)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. sndcart (x n)"], THEN spec[where x="sndcart l"]]
- unfolding Lim_sequentially by auto
- hence "l \<in> {pastecart x y |x y. x \<in> s \<and> y \<in> t}" using pastecart_fst_snd[THEN sym, of l] by auto }
- thus ?thesis unfolding closed_sequential_limits by auto
-qed
-
-lemma compact_pastecart:
- fixes s t :: "(real ^ _) set"
- shows "compact s \<Longrightarrow> compact t ==> compact {pastecart x y | x y . x \<in> s \<and> y \<in> t}"
- unfolding compact_eq_bounded_closed using bounded_pastecart[of s t] closed_pastecart[of s t] by auto
-
-lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
-by (induct x) simp
-
-lemma compact_Times: "compact s \<Longrightarrow> compact t \<Longrightarrow> compact (s \<times> t)"
-unfolding compact_def
-apply clarify
-apply (drule_tac x="fst \<circ> f" in spec)
-apply (drule mp, simp add: mem_Times_iff)
-apply (clarify, rename_tac l1 r1)
-apply (drule_tac x="snd \<circ> f \<circ> r1" in spec)
-apply (drule mp, simp add: mem_Times_iff)
-apply (clarify, rename_tac l2 r2)
-apply (rule_tac x="(l1, l2)" in rev_bexI, simp)
-apply (rule_tac x="r1 \<circ> r2" in exI)
-apply (rule conjI, simp add: subseq_def)
-apply (drule_tac r=r2 in lim_subseq [COMP swap_prems_rl], assumption)
-apply (drule (1) tendsto_Pair) back
-apply (simp add: o_def)
-done
-
-text{* Hence some useful properties follow quite easily. *}
-
-lemma compact_scaling:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" shows "compact ((\<lambda>x. c *\<^sub>R x) ` s)"
-proof-
- let ?f = "\<lambda>x. scaleR c x"
- have *:"bounded_linear ?f" by (rule scaleR.bounded_linear_right)
- show ?thesis using compact_continuous_image[of s ?f] continuous_at_imp_continuous_on[of s ?f]
- using linear_continuous_at[OF *] assms by auto
-qed
-
-lemma compact_negations:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" shows "compact ((\<lambda>x. -x) ` s)"
- using compact_scaling [OF assms, of "- 1"] by auto
-
-lemma compact_sums:
- fixes s t :: "'a::real_normed_vector set"
- assumes "compact s" "compact t" shows "compact {x + y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- have *:"{x + y | x y. x \<in> s \<and> y \<in> t} = (\<lambda>z. fst z + snd z) ` (s \<times> t)"
- apply auto unfolding image_iff apply(rule_tac x="(xa, y)" in bexI) by auto
- have "continuous_on (s \<times> t) (\<lambda>z. fst z + snd z)"
- unfolding continuous_on by (rule ballI) (intro tendsto_intros)
- thus ?thesis unfolding * using compact_continuous_image compact_Times [OF assms] by auto
-qed
-
-lemma compact_differences:
- fixes s t :: "'a::real_normed_vector set"
- assumes "compact s" "compact t" shows "compact {x - y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- have "{x - y | x y. x\<in>s \<and> y \<in> t} = {x + y | x y. x \<in> s \<and> y \<in> (uminus ` t)}"
- apply auto apply(rule_tac x= xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
- thus ?thesis using compact_sums[OF assms(1) compact_negations[OF assms(2)]] by auto
-qed
-
-lemma compact_translation:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" shows "compact ((\<lambda>x. a + x) ` s)"
-proof-
- have "{x + y |x y. x \<in> s \<and> y \<in> {a}} = (\<lambda>x. a + x) ` s" by auto
- thus ?thesis using compact_sums[OF assms compact_sing[of a]] by auto
-qed
-
-lemma compact_affinity:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" shows "compact ((\<lambda>x. a + c *\<^sub>R x) ` s)"
-proof-
- have "op + a ` op *\<^sub>R c ` s = (\<lambda>x. a + c *\<^sub>R x) ` s" by auto
- thus ?thesis using compact_translation[OF compact_scaling[OF assms], of a c] by auto
-qed
-
-text{* Hence we get the following. *}
-
-lemma compact_sup_maxdistance:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" "s \<noteq> {}"
- shows "\<exists>x\<in>s. \<exists>y\<in>s. \<forall>u\<in>s. \<forall>v\<in>s. norm(u - v) \<le> norm(x - y)"
-proof-
- have "{x - y | x y . x\<in>s \<and> y\<in>s} \<noteq> {}" using `s \<noteq> {}` by auto
- then obtain x where x:"x\<in>{x - y |x y. x \<in> s \<and> y \<in> s}" "\<forall>y\<in>{x - y |x y. x \<in> s \<and> y \<in> s}. norm y \<le> norm x"
- using compact_differences[OF assms(1) assms(1)]
- using distance_attains_sup[where 'a="'a", unfolded dist_norm, of "{x - y | x y . x\<in>s \<and> y\<in>s}" 0] by(auto simp add: norm_minus_cancel)
- from x(1) obtain a b where "a\<in>s" "b\<in>s" "x = a - b" by auto
- thus ?thesis using x(2)[unfolded `x = a - b`] by blast
-qed
-
-text{* We can state this in terms of diameter of a set. *}
-
-definition "diameter s = (if s = {} then 0::real else Sup {norm(x - y) | x y. x \<in> s \<and> y \<in> s})"
- (* TODO: generalize to class metric_space *)
-
-lemma diameter_bounded:
- assumes "bounded s"
- shows "\<forall>x\<in>s. \<forall>y\<in>s. norm(x - y) \<le> diameter s"
- "\<forall>d>0. d < diameter s --> (\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d)"
-proof-
- let ?D = "{norm (x - y) |x y. x \<in> s \<and> y \<in> s}"
- obtain a where a:"\<forall>x\<in>s. norm x \<le> a" using assms[unfolded bounded_iff] by auto
- { fix x y assume "x \<in> s" "y \<in> s"
- hence "norm (x - y) \<le> 2 * a" using norm_triangle_ineq[of x "-y", unfolded norm_minus_cancel] a[THEN bspec[where x=x]] a[THEN bspec[where x=y]] by (auto simp add: ring_simps) }
- note * = this
- { fix x y assume "x\<in>s" "y\<in>s" hence "s \<noteq> {}" by auto
- have lub:"isLub UNIV ?D (Sup ?D)" using * Sup[of ?D] using `s\<noteq>{}` unfolding setle_def
- apply auto (*FIXME: something horrible has happened here!*)
- apply atomize
- apply safe
- apply metis +
- done
- have "norm(x - y) \<le> diameter s" unfolding diameter_def using `s\<noteq>{}` *[OF `x\<in>s` `y\<in>s`] `x\<in>s` `y\<in>s` isLubD1[OF lub] unfolding setle_def by auto }
- moreover
- { fix d::real assume "d>0" "d < diameter s"
- hence "s\<noteq>{}" unfolding diameter_def by auto
- hence lub:"isLub UNIV ?D (Sup ?D)" using * Sup[of ?D] unfolding setle_def
- apply auto (*FIXME: something horrible has happened here!*)
- apply atomize
- apply safe
- apply metis +
- done
- have "\<exists>d' \<in> ?D. d' > d"
- proof(rule ccontr)
- assume "\<not> (\<exists>d'\<in>{norm (x - y) |x y. x \<in> s \<and> y \<in> s}. d < d')"
- hence as:"\<forall>d'\<in>?D. d' \<le> d" apply auto apply(erule_tac x="norm (x - y)" in allE) by auto
- hence "isUb UNIV ?D d" unfolding isUb_def unfolding setle_def by auto
- thus False using `d < diameter s` `s\<noteq>{}` isLub_le_isUb[OF lub, of d] unfolding diameter_def by auto
- qed
- hence "\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d" by auto }
- ultimately show "\<forall>x\<in>s. \<forall>y\<in>s. norm(x - y) \<le> diameter s"
- "\<forall>d>0. d < diameter s --> (\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d)" by auto
-qed
-
-lemma diameter_bounded_bound:
- "bounded s \<Longrightarrow> x \<in> s \<Longrightarrow> y \<in> s ==> norm(x - y) \<le> diameter s"
- using diameter_bounded by blast
-atp_minimize [atp=remote_vampire] Collect_def Max_ge add_increasing2 add_le_cancel_left diameter_def_raw equation_minus_iff finite finite_imageI norm_imp_pos_and_ge rangeI
-
-lemma diameter_compact_attained:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" "s \<noteq> {}"
- shows "\<exists>x\<in>s. \<exists>y\<in>s. (norm(x - y) = diameter s)"
-proof-
- have b:"bounded s" using assms(1) by (rule compact_imp_bounded)
- then obtain x y where xys:"x\<in>s" "y\<in>s" and xy:"\<forall>u\<in>s. \<forall>v\<in>s. norm (u - v) \<le> norm (x - y)" using compact_sup_maxdistance[OF assms] by auto
- hence "diameter s \<le> norm (x - y)"
- by (force simp add: diameter_def intro!: Sup_least)
- thus ?thesis using diameter_bounded(1)[OF b, THEN bspec[where x=x], THEN bspec[where x=y], OF xys] and xys by auto
-qed
-
-text{* Related results with closure as the conclusion. *}
-
-lemma closed_scaling:
- fixes s :: "'a::real_normed_vector set"
- assumes "closed s" shows "closed ((\<lambda>x. c *\<^sub>R x) ` s)"
-proof(cases "s={}")
- case True thus ?thesis by auto
-next
- case False
- show ?thesis
- proof(cases "c=0")
- have *:"(\<lambda>x. 0) ` s = {0}" using `s\<noteq>{}` by auto
- case True thus ?thesis apply auto unfolding * using closed_sing by auto
- next
- case False
- { fix x l assume as:"\<forall>n::nat. x n \<in> scaleR c ` s" "(x ---> l) sequentially"
- { fix n::nat have "scaleR (1 / c) (x n) \<in> s"
- using as(1)[THEN spec[where x=n]]
- using `c\<noteq>0` by (auto simp add: vector_smult_assoc)
- }
- moreover
- { fix e::real assume "e>0"
- hence "0 < e *\<bar>c\<bar>" using `c\<noteq>0` mult_pos_pos[of e "abs c"] by auto
- then obtain N where "\<forall>n\<ge>N. dist (x n) l < e * \<bar>c\<bar>"
- using as(2)[unfolded Lim_sequentially, THEN spec[where x="e * abs c"]] by auto
- hence "\<exists>N. \<forall>n\<ge>N. dist (scaleR (1 / c) (x n)) (scaleR (1 / c) l) < e"
- unfolding dist_norm unfolding scaleR_right_diff_distrib[THEN sym]
- using mult_imp_div_pos_less[of "abs c" _ e] `c\<noteq>0` by auto }
- hence "((\<lambda>n. scaleR (1 / c) (x n)) ---> scaleR (1 / c) l) sequentially" unfolding Lim_sequentially by auto
- ultimately have "l \<in> scaleR c ` s"
- using assms[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. scaleR (1/c) (x n)"], THEN spec[where x="scaleR (1/c) l"]]
- unfolding image_iff using `c\<noteq>0` apply(rule_tac x="scaleR (1 / c) l" in bexI) by auto }
- thus ?thesis unfolding closed_sequential_limits by fast
- qed
-qed
-
-lemma closed_negations:
- fixes s :: "'a::real_normed_vector set"
- assumes "closed s" shows "closed ((\<lambda>x. -x) ` s)"
- using closed_scaling[OF assms, of "- 1"] by simp
-
-lemma compact_closed_sums:
- fixes s :: "'a::real_normed_vector set"
- assumes "compact s" "closed t" shows "closed {x + y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- let ?S = "{x + y |x y. x \<in> s \<and> y \<in> t}"
- { fix x l assume as:"\<forall>n. x n \<in> ?S" "(x ---> l) sequentially"
- from as(1) obtain f where f:"\<forall>n. x n = fst (f n) + snd (f n)" "\<forall>n. fst (f n) \<in> s" "\<forall>n. snd (f n) \<in> t"
- using choice[of "\<lambda>n y. x n = (fst y) + (snd y) \<and> fst y \<in> s \<and> snd y \<in> t"] by auto
- obtain l' r where "l'\<in>s" and r:"subseq r" and lr:"(((\<lambda>n. fst (f n)) \<circ> r) ---> l') sequentially"
- using assms(1)[unfolded compact_def, THEN spec[where x="\<lambda> n. fst (f n)"]] using f(2) by auto
- have "((\<lambda>n. snd (f (r n))) ---> l - l') sequentially"
- using Lim_sub[OF lim_subseq[OF r as(2)] lr] and f(1) unfolding o_def by auto
- hence "l - l' \<in> t"
- using assms(2)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda> n. snd (f (r n))"], THEN spec[where x="l - l'"]]
- using f(3) by auto
- hence "l \<in> ?S" using `l' \<in> s` apply auto apply(rule_tac x=l' in exI) apply(rule_tac x="l - l'" in exI) by auto
- }
- thus ?thesis unfolding closed_sequential_limits by fast
-qed
-
-lemma closed_compact_sums:
- fixes s t :: "'a::real_normed_vector set"
- assumes "closed s" "compact t"
- shows "closed {x + y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- have "{x + y |x y. x \<in> t \<and> y \<in> s} = {x + y |x y. x \<in> s \<and> y \<in> t}" apply auto
- apply(rule_tac x=y in exI) apply auto apply(rule_tac x=y in exI) by auto
- thus ?thesis using compact_closed_sums[OF assms(2,1)] by simp
-qed
-
-lemma compact_closed_differences:
- fixes s t :: "'a::real_normed_vector set"
- assumes "compact s" "closed t"
- shows "closed {x - y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- have "{x + y |x y. x \<in> s \<and> y \<in> uminus ` t} = {x - y |x y. x \<in> s \<and> y \<in> t}"
- apply auto apply(rule_tac x=xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
- thus ?thesis using compact_closed_sums[OF assms(1) closed_negations[OF assms(2)]] by auto
-qed
-
-lemma closed_compact_differences:
- fixes s t :: "'a::real_normed_vector set"
- assumes "closed s" "compact t"
- shows "closed {x - y | x y. x \<in> s \<and> y \<in> t}"
-proof-
- have "{x + y |x y. x \<in> s \<and> y \<in> uminus ` t} = {x - y |x y. x \<in> s \<and> y \<in> t}"
- apply auto apply(rule_tac x=xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
- thus ?thesis using closed_compact_sums[OF assms(1) compact_negations[OF assms(2)]] by simp
-qed
-
-lemma closed_translation:
- fixes a :: "'a::real_normed_vector"
- assumes "closed s" shows "closed ((\<lambda>x. a + x) ` s)"
-proof-
- have "{a + y |y. y \<in> s} = (op + a ` s)" by auto
- thus ?thesis using compact_closed_sums[OF compact_sing[of a] assms] by auto
-qed
-
-lemma translation_UNIV:
- fixes a :: "'a::ab_group_add" shows "range (\<lambda>x. a + x) = UNIV"
- apply (auto simp add: image_iff) apply(rule_tac x="x - a" in exI) by auto
-
-lemma translation_diff:
- fixes a :: "'a::ab_group_add"
- shows "(\<lambda>x. a + x) ` (s - t) = ((\<lambda>x. a + x) ` s) - ((\<lambda>x. a + x) ` t)"
- by auto
-
-lemma closure_translation:
- fixes a :: "'a::real_normed_vector"
- shows "closure ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (closure s)"
-proof-
- have *:"op + a ` (UNIV - s) = UNIV - op + a ` s"
- apply auto unfolding image_iff apply(rule_tac x="x - a" in bexI) by auto
- show ?thesis unfolding closure_interior translation_diff translation_UNIV
- using interior_translation[of a "UNIV - s"] unfolding * by auto
-qed
-
-lemma frontier_translation:
- fixes a :: "'a::real_normed_vector"
- shows "frontier((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (frontier s)"
- unfolding frontier_def translation_diff interior_translation closure_translation by auto
-
-subsection{* Separation between points and sets. *}
-
-lemma separate_point_closed:
- fixes s :: "'a::heine_borel set"
- shows "closed s \<Longrightarrow> a \<notin> s ==> (\<exists>d>0. \<forall>x\<in>s. d \<le> dist a x)"
-proof(cases "s = {}")
- case True
- thus ?thesis by(auto intro!: exI[where x=1])
-next
- case False
- assume "closed s" "a \<notin> s"
- then obtain x where "x\<in>s" "\<forall>y\<in>s. dist a x \<le> dist a y" using `s \<noteq> {}` distance_attains_inf [of s a] by blast
- with `x\<in>s` show ?thesis using dist_pos_lt[of a x] and`a \<notin> s` by blast
-qed
-
-lemma separate_compact_closed:
- fixes s t :: "'a::{heine_borel, real_normed_vector} set"
- (* TODO: does this generalize to heine_borel? *)
- assumes "compact s" and "closed t" and "s \<inter> t = {}"
- shows "\<exists>d>0. \<forall>x\<in>s. \<forall>y\<in>t. d \<le> dist x y"
-proof-
- have "0 \<notin> {x - y |x y. x \<in> s \<and> y \<in> t}" using assms(3) by auto
- then obtain d where "d>0" and d:"\<forall>x\<in>{x - y |x y. x \<in> s \<and> y \<in> t}. d \<le> dist 0 x"
- using separate_point_closed[OF compact_closed_differences[OF assms(1,2)], of 0] by auto
- { fix x y assume "x\<in>s" "y\<in>t"
- hence "x - y \<in> {x - y |x y. x \<in> s \<and> y \<in> t}" by auto
- hence "d \<le> dist (x - y) 0" using d[THEN bspec[where x="x - y"]] using dist_commute
- by (auto simp add: dist_commute)
- hence "d \<le> dist x y" unfolding dist_norm by auto }
- thus ?thesis using `d>0` by auto
-qed
-
-lemma separate_closed_compact:
- fixes s t :: "'a::{heine_borel, real_normed_vector} set"
- assumes "closed s" and "compact t" and "s \<inter> t = {}"
- shows "\<exists>d>0. \<forall>x\<in>s. \<forall>y\<in>t. d \<le> dist x y"
-proof-
- have *:"t \<inter> s = {}" using assms(3) by auto
- show ?thesis using separate_compact_closed[OF assms(2,1) *]
- apply auto apply(rule_tac x=d in exI) apply auto apply (erule_tac x=y in ballE)
- by (auto simp add: dist_commute)
-qed
-
-(* A cute way of denoting open and closed intervals using overloading. *)
-
-lemma interval: fixes a :: "'a::ord^'n::finite" shows
- "{a <..< b} = {x::'a^'n. \<forall>i. a$i < x$i \<and> x$i < b$i}" and
- "{a .. b} = {x::'a^'n. \<forall>i. a$i \<le> x$i \<and> x$i \<le> b$i}"
- by (auto simp add: expand_set_eq vector_less_def vector_less_eq_def)
-
-lemma mem_interval: fixes a :: "'a::ord^'n::finite" shows
- "x \<in> {a<..<b} \<longleftrightarrow> (\<forall>i. a$i < x$i \<and> x$i < b$i)"
- "x \<in> {a .. b} \<longleftrightarrow> (\<forall>i. a$i \<le> x$i \<and> x$i \<le> b$i)"
- using interval[of a b] by(auto simp add: expand_set_eq vector_less_def vector_less_eq_def)
-
-lemma mem_interval_1: fixes x :: "real^1" shows
- "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b)"
- "(x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
-by(simp_all add: Cart_eq vector_less_def vector_less_eq_def dest_vec1_def forall_1)
-
-lemma interval_eq_empty: fixes a :: "real^'n::finite" shows
- "({a <..< b} = {} \<longleftrightarrow> (\<exists>i. b$i \<le> a$i))" (is ?th1) and
- "({a .. b} = {} \<longleftrightarrow> (\<exists>i. b$i < a$i))" (is ?th2)
-proof-
- { fix i x assume as:"b$i \<le> a$i" and x:"x\<in>{a <..< b}"
- hence "a $ i < x $ i \<and> x $ i < b $ i" unfolding mem_interval by auto
- hence "a$i < b$i" by auto
- hence False using as by auto }
- moreover
- { assume as:"\<forall>i. \<not> (b$i \<le> a$i)"
- let ?x = "(1/2) *\<^sub>R (a + b)"
- { fix i
- have "a$i < b$i" using as[THEN spec[where x=i]] by auto
- hence "a$i < ((1/2) *\<^sub>R (a+b)) $ i" "((1/2) *\<^sub>R (a+b)) $ i < b$i"
- unfolding vector_smult_component and vector_add_component
- by (auto simp add: less_divide_eq_number_of1) }
- hence "{a <..< b} \<noteq> {}" using mem_interval(1)[of "?x" a b] by auto }
- ultimately show ?th1 by blast
-
- { fix i x assume as:"b$i < a$i" and x:"x\<in>{a .. b}"
- hence "a $ i \<le> x $ i \<and> x $ i \<le> b $ i" unfolding mem_interval by auto
- hence "a$i \<le> b$i" by auto
- hence False using as by auto }
- moreover
- { assume as:"\<forall>i. \<not> (b$i < a$i)"
- let ?x = "(1/2) *\<^sub>R (a + b)"
- { fix i
- have "a$i \<le> b$i" using as[THEN spec[where x=i]] by auto
- hence "a$i \<le> ((1/2) *\<^sub>R (a+b)) $ i" "((1/2) *\<^sub>R (a+b)) $ i \<le> b$i"
- unfolding vector_smult_component and vector_add_component
- by (auto simp add: less_divide_eq_number_of1) }
- hence "{a .. b} \<noteq> {}" using mem_interval(2)[of "?x" a b] by auto }
- ultimately show ?th2 by blast
-qed
-
-lemma interval_ne_empty: fixes a :: "real^'n::finite" shows
- "{a .. b} \<noteq> {} \<longleftrightarrow> (\<forall>i. a$i \<le> b$i)" and
- "{a <..< b} \<noteq> {} \<longleftrightarrow> (\<forall>i. a$i < b$i)"
- unfolding interval_eq_empty[of a b] by (auto simp add: not_less not_le) (* BH: Why doesn't just "auto" work here? *)
-
-lemma subset_interval_imp: fixes a :: "real^'n::finite" shows
- "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c .. d} \<subseteq> {a .. b}" and
- "(\<forall>i. a$i < c$i \<and> d$i < b$i) \<Longrightarrow> {c .. d} \<subseteq> {a<..<b}" and
- "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c<..<d} \<subseteq> {a .. b}" and
- "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c<..<d} \<subseteq> {a<..<b}"
- unfolding subset_eq[unfolded Ball_def] unfolding mem_interval
- by (auto intro: order_trans less_le_trans le_less_trans less_imp_le) (* BH: Why doesn't just "auto" work here? *)
-
-lemma interval_sing: fixes a :: "'a::linorder^'n::finite" shows
- "{a .. a} = {a} \<and> {a<..<a} = {}"
-apply(auto simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
-apply (simp add: order_eq_iff)
-apply (auto simp add: not_less less_imp_le)
-done
-
-lemma interval_open_subset_closed: fixes a :: "'a::preorder^'n::finite" shows
- "{a<..<b} \<subseteq> {a .. b}"
-proof(simp add: subset_eq, rule)
- fix x
- assume x:"x \<in>{a<..<b}"
- { fix i
- have "a $ i \<le> x $ i"
- using x order_less_imp_le[of "a$i" "x$i"]
- by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
- }
- moreover
- { fix i
- have "x $ i \<le> b $ i"
- using x order_less_imp_le[of "x$i" "b$i"]
- by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
- }
- ultimately
- show "a \<le> x \<and> x \<le> b"
- by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
-qed
-
-lemma subset_interval: fixes a :: "real^'n::finite" shows
- "{c .. d} \<subseteq> {a .. b} \<longleftrightarrow> (\<forall>i. c$i \<le> d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th1) and
- "{c .. d} \<subseteq> {a<..<b} \<longleftrightarrow> (\<forall>i. c$i \<le> d$i) --> (\<forall>i. a$i < c$i \<and> d$i < b$i)" (is ?th2) and
- "{c<..<d} \<subseteq> {a .. b} \<longleftrightarrow> (\<forall>i. c$i < d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th3) and
- "{c<..<d} \<subseteq> {a<..<b} \<longleftrightarrow> (\<forall>i. c$i < d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th4)
-proof-
- show ?th1 unfolding subset_eq and Ball_def and mem_interval by (auto intro: order_trans)
- show ?th2 unfolding subset_eq and Ball_def and mem_interval by (auto intro: le_less_trans less_le_trans order_trans less_imp_le)
- { assume as: "{c<..<d} \<subseteq> {a .. b}" "\<forall>i. c$i < d$i"
- hence "{c<..<d} \<noteq> {}" unfolding interval_eq_empty by (auto, drule_tac x=i in spec, simp) (* BH: Why doesn't just "auto" work? *)
- fix i
- (** TODO combine the following two parts as done in the HOL_light version. **)
- { let ?x = "(\<chi> j. (if j=i then ((min (a$j) (d$j))+c$j)/2 else (c$j+d$j)/2))::real^'n"
- assume as2: "a$i > c$i"
- { fix j
- have "c $ j < ?x $ j \<and> ?x $ j < d $ j" unfolding Cart_lambda_beta
- apply(cases "j=i") using as(2)[THEN spec[where x=j]]
- by (auto simp add: less_divide_eq_number_of1 as2) }
- hence "?x\<in>{c<..<d}" unfolding mem_interval by auto
- moreover
- have "?x\<notin>{a .. b}"
- unfolding mem_interval apply auto apply(rule_tac x=i in exI)
- using as(2)[THEN spec[where x=i]] and as2
- by (auto simp add: less_divide_eq_number_of1)
- ultimately have False using as by auto }
- hence "a$i \<le> c$i" by(rule ccontr)auto
- moreover
- { let ?x = "(\<chi> j. (if j=i then ((max (b$j) (c$j))+d$j)/2 else (c$j+d$j)/2))::real^'n"
- assume as2: "b$i < d$i"
- { fix j
- have "d $ j > ?x $ j \<and> ?x $ j > c $ j" unfolding Cart_lambda_beta
- apply(cases "j=i") using as(2)[THEN spec[where x=j]]
- by (auto simp add: less_divide_eq_number_of1 as2) }
- hence "?x\<in>{c<..<d}" unfolding mem_interval by auto
- moreover
- have "?x\<notin>{a .. b}"
- unfolding mem_interval apply auto apply(rule_tac x=i in exI)
- using as(2)[THEN spec[where x=i]] and as2
- by (auto simp add: less_divide_eq_number_of1)
- ultimately have False using as by auto }
- hence "b$i \<ge> d$i" by(rule ccontr)auto
- ultimately
- have "a$i \<le> c$i \<and> d$i \<le> b$i" by auto
- } note part1 = this
- thus ?th3 unfolding subset_eq and Ball_def and mem_interval apply auto apply (erule_tac x=ia in allE, simp)+ by (erule_tac x=i in allE, erule_tac x=i in allE, simp)+
- { assume as:"{c<..<d} \<subseteq> {a<..<b}" "\<forall>i. c$i < d$i"
- fix i
- from as(1) have "{c<..<d} \<subseteq> {a..b}" using interval_open_subset_closed[of a b] by auto
- hence "a$i \<le> c$i \<and> d$i \<le> b$i" using part1 and as(2) by auto } note * = this
- thus ?th4 unfolding subset_eq and Ball_def and mem_interval apply auto apply (erule_tac x=ia in allE, simp)+ by (erule_tac x=i in allE, erule_tac x=i in allE, simp)+
-qed
-
-lemma disjoint_interval: fixes a::"real^'n::finite" shows
- "{a .. b} \<inter> {c .. d} = {} \<longleftrightarrow> (\<exists>i. (b$i < a$i \<or> d$i < c$i \<or> b$i < c$i \<or> d$i < a$i))" (is ?th1) and
- "{a .. b} \<inter> {c<..<d} = {} \<longleftrightarrow> (\<exists>i. (b$i < a$i \<or> d$i \<le> c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th2) and
- "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> (\<exists>i. (b$i \<le> a$i \<or> d$i < c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th3) and
- "{a<..<b} \<inter> {c<..<d} = {} \<longleftrightarrow> (\<exists>i. (b$i \<le> a$i \<or> d$i \<le> c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th4)
-proof-
- let ?z = "(\<chi> i. ((max (a$i) (c$i)) + (min (b$i) (d$i))) / 2)::real^'n"
- show ?th1 ?th2 ?th3 ?th4
- unfolding expand_set_eq and Int_iff and empty_iff and mem_interval and all_conj_distrib[THEN sym] and eq_False
- apply (auto elim!: allE[where x="?z"])
- apply ((rule_tac x=x in exI, force) | (rule_tac x=i in exI, force))+
- done
-qed
-
-lemma inter_interval: fixes a :: "'a::linorder^'n::finite" shows
- "{a .. b} \<inter> {c .. d} = {(\<chi> i. max (a$i) (c$i)) .. (\<chi> i. min (b$i) (d$i))}"
- unfolding expand_set_eq and Int_iff and mem_interval
- by (auto simp add: less_divide_eq_number_of1 intro!: bexI)
-
-(* Moved interval_open_subset_closed a bit upwards *)
-
-lemma open_interval_lemma: fixes x :: "real" shows
- "a < x \<Longrightarrow> x < b ==> (\<exists>d>0. \<forall>x'. abs(x' - x) < d --> a < x' \<and> x' < b)"
- by(rule_tac x="min (x - a) (b - x)" in exI, auto)
-
-lemma open_interval: fixes a :: "real^'n::finite" shows "open {a<..<b}"
-proof-
- { fix x assume x:"x\<in>{a<..<b}"
- { fix i
- have "\<exists>d>0. \<forall>x'. abs (x' - (x$i)) < d \<longrightarrow> a$i < x' \<and> x' < b$i"
- using x[unfolded mem_interval, THEN spec[where x=i]]
- using open_interval_lemma[of "a$i" "x$i" "b$i"] by auto }
-
- hence "\<forall>i. \<exists>d>0. \<forall>x'. abs (x' - (x$i)) < d \<longrightarrow> a$i < x' \<and> x' < b$i" by auto
- then obtain d where d:"\<forall>i. 0 < d i \<and> (\<forall>x'. \<bar>x' - x $ i\<bar> < d i \<longrightarrow> a $ i < x' \<and> x' < b $ i)"
- using bchoice[of "UNIV" "\<lambda>i d. d>0 \<and> (\<forall>x'. \<bar>x' - x $ i\<bar> < d \<longrightarrow> a $ i < x' \<and> x' < b $ i)"] by auto
-
- let ?d = "Min (range d)"
- have **:"finite (range d)" "range d \<noteq> {}" by auto
- have "?d>0" unfolding Min_gr_iff[OF **] using d by auto
- moreover
- { fix x' assume as:"dist x' x < ?d"
- { fix i
- have "\<bar>x'$i - x $ i\<bar> < d i"
- using norm_bound_component_lt[OF as[unfolded dist_norm], of i]
- unfolding vector_minus_component and Min_gr_iff[OF **] by auto
- hence "a $ i < x' $ i" "x' $ i < b $ i" using d[THEN spec[where x=i]] by auto }
- hence "a < x' \<and> x' < b" unfolding vector_less_def by auto }
- ultimately have "\<exists>e>0. \<forall>x'. dist x' x < e \<longrightarrow> x' \<in> {a<..<b}" by (auto, rule_tac x="?d" in exI, simp)
- }
- thus ?thesis unfolding open_dist using open_interval_lemma by auto
-qed
-
-lemma closed_interval: fixes a :: "real^'n::finite" shows "closed {a .. b}"
-proof-
- { fix x i assume as:"\<forall>e>0. \<exists>x'\<in>{a..b}. x' \<noteq> x \<and> dist x' x < e"(* and xab:"a$i > x$i \<or> b$i < x$i"*)
- { assume xa:"a$i > x$i"
- with as obtain y where y:"y\<in>{a..b}" "y \<noteq> x" "dist y x < a$i - x$i" by(erule_tac x="a$i - x$i" in allE)auto
- hence False unfolding mem_interval and dist_norm
- using component_le_norm[of "y-x" i, unfolded vector_minus_component] and xa by(auto elim!: allE[where x=i])
- } hence "a$i \<le> x$i" by(rule ccontr)auto
- moreover
- { assume xb:"b$i < x$i"
- with as obtain y where y:"y\<in>{a..b}" "y \<noteq> x" "dist y x < x$i - b$i" by(erule_tac x="x$i - b$i" in allE)auto
- hence False unfolding mem_interval and dist_norm
- using component_le_norm[of "y-x" i, unfolded vector_minus_component] and xb by(auto elim!: allE[where x=i])
- } hence "x$i \<le> b$i" by(rule ccontr)auto
- ultimately
- have "a $ i \<le> x $ i \<and> x $ i \<le> b $ i" by auto }
- thus ?thesis unfolding closed_limpt islimpt_approachable mem_interval by auto
-qed
-
-lemma interior_closed_interval: fixes a :: "real^'n::finite" shows
- "interior {a .. b} = {a<..<b}" (is "?L = ?R")
-proof(rule subset_antisym)
- show "?R \<subseteq> ?L" using interior_maximal[OF interval_open_subset_closed open_interval] by auto
-next
- { fix x assume "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> {a..b}"
- then obtain s where s:"open s" "x \<in> s" "s \<subseteq> {a..b}" by auto
- then obtain e where "e>0" and e:"\<forall>x'. dist x' x < e \<longrightarrow> x' \<in> {a..b}" unfolding open_dist and subset_eq by auto
- { fix i
- have "dist (x - (e / 2) *\<^sub>R basis i) x < e"
- "dist (x + (e / 2) *\<^sub>R basis i) x < e"
- unfolding dist_norm apply auto
- unfolding norm_minus_cancel using norm_basis[of i] and `e>0` by auto
- hence "a $ i \<le> (x - (e / 2) *\<^sub>R basis i) $ i"
- "(x + (e / 2) *\<^sub>R basis i) $ i \<le> b $ i"
- using e[THEN spec[where x="x - (e/2) *\<^sub>R basis i"]]
- and e[THEN spec[where x="x + (e/2) *\<^sub>R basis i"]]
- unfolding mem_interval by (auto elim!: allE[where x=i])
- hence "a $ i < x $ i" and "x $ i < b $ i"
- unfolding vector_minus_component and vector_add_component
- unfolding vector_smult_component and basis_component using `e>0` by auto }
- hence "x \<in> {a<..<b}" unfolding mem_interval by auto }
- thus "?L \<subseteq> ?R" unfolding interior_def and subset_eq by auto
-qed
-
-lemma bounded_closed_interval: fixes a :: "real^'n::finite" shows
- "bounded {a .. b}"
-proof-
- let ?b = "\<Sum>i\<in>UNIV. \<bar>a$i\<bar> + \<bar>b$i\<bar>"
- { fix x::"real^'n" assume x:"\<forall>i. a $ i \<le> x $ i \<and> x $ i \<le> b $ i"
- { fix i
- have "\<bar>x$i\<bar> \<le> \<bar>a$i\<bar> + \<bar>b$i\<bar>" using x[THEN spec[where x=i]] by auto }
- hence "(\<Sum>i\<in>UNIV. \<bar>x $ i\<bar>) \<le> ?b" by(rule setsum_mono)
- hence "norm x \<le> ?b" using norm_le_l1[of x] by auto }
- thus ?thesis unfolding interval and bounded_iff by auto
-qed
-
-lemma bounded_interval: fixes a :: "real^'n::finite" shows
- "bounded {a .. b} \<and> bounded {a<..<b}"
- using bounded_closed_interval[of a b]
- using interval_open_subset_closed[of a b]
- using bounded_subset[of "{a..b}" "{a<..<b}"]
- by simp
-
-lemma not_interval_univ: fixes a :: "real^'n::finite" shows
- "({a .. b} \<noteq> UNIV) \<and> ({a<..<b} \<noteq> UNIV)"
- using bounded_interval[of a b]
- by auto
-
-lemma compact_interval: fixes a :: "real^'n::finite" shows
- "compact {a .. b}"
- using bounded_closed_imp_compact using bounded_interval[of a b] using closed_interval[of a b] by auto
-
-lemma open_interval_midpoint: fixes a :: "real^'n::finite"
- assumes "{a<..<b} \<noteq> {}" shows "((1/2) *\<^sub>R (a + b)) \<in> {a<..<b}"
-proof-
- { fix i
- have "a $ i < ((1 / 2) *\<^sub>R (a + b)) $ i \<and> ((1 / 2) *\<^sub>R (a + b)) $ i < b $ i"
- using assms[unfolded interval_ne_empty, THEN spec[where x=i]]
- unfolding vector_smult_component and vector_add_component
- by(auto simp add: less_divide_eq_number_of1) }
- thus ?thesis unfolding mem_interval by auto
-qed
-
-lemma open_closed_interval_convex: fixes x :: "real^'n::finite"
- assumes x:"x \<in> {a<..<b}" and y:"y \<in> {a .. b}" and e:"0 < e" "e \<le> 1"
- shows "(e *\<^sub>R x + (1 - e) *\<^sub>R y) \<in> {a<..<b}"
-proof-
- { fix i
- have "a $ i = e * a$i + (1 - e) * a$i" unfolding left_diff_distrib by simp
- also have "\<dots> < e * x $ i + (1 - e) * y $ i" apply(rule add_less_le_mono)
- using e unfolding mult_less_cancel_left and mult_le_cancel_left apply simp_all
- using x unfolding mem_interval apply simp
- using y unfolding mem_interval apply simp
- done
- finally have "a $ i < (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i" by auto
- moreover {
- have "b $ i = e * b$i + (1 - e) * b$i" unfolding left_diff_distrib by simp
- also have "\<dots> > e * x $ i + (1 - e) * y $ i" apply(rule add_less_le_mono)
- using e unfolding mult_less_cancel_left and mult_le_cancel_left apply simp_all
- using x unfolding mem_interval apply simp
- using y unfolding mem_interval apply simp
- done
- finally have "(e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i < b $ i" by auto
- } ultimately have "a $ i < (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i \<and> (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i < b $ i" by auto }
- thus ?thesis unfolding mem_interval by auto
-qed
-
-lemma closure_open_interval: fixes a :: "real^'n::finite"
- assumes "{a<..<b} \<noteq> {}"
- shows "closure {a<..<b} = {a .. b}"
-proof-
- have ab:"a < b" using assms[unfolded interval_ne_empty] unfolding vector_less_def by auto
- let ?c = "(1 / 2) *\<^sub>R (a + b)"
- { fix x assume as:"x \<in> {a .. b}"
- def f == "\<lambda>n::nat. x + (inverse (real n + 1)) *\<^sub>R (?c - x)"
- { fix n assume fn:"f n < b \<longrightarrow> a < f n \<longrightarrow> f n = x" and xc:"x \<noteq> ?c"
- have *:"0 < inverse (real n + 1)" "inverse (real n + 1) \<le> 1" unfolding inverse_le_1_iff by auto
- have "(inverse (real n + 1)) *\<^sub>R ((1 / 2) *\<^sub>R (a + b)) + (1 - inverse (real n + 1)) *\<^sub>R x =
- x + (inverse (real n + 1)) *\<^sub>R (((1 / 2) *\<^sub>R (a + b)) - x)"
- by (auto simp add: algebra_simps)
- hence "f n < b" and "a < f n" using open_closed_interval_convex[OF open_interval_midpoint[OF assms] as *] unfolding f_def by auto
- hence False using fn unfolding f_def using xc by(auto simp add: vector_mul_lcancel vector_ssub_ldistrib) }
- moreover
- { assume "\<not> (f ---> x) sequentially"
- { fix e::real assume "e>0"
- hence "\<exists>N::nat. inverse (real (N + 1)) < e" using real_arch_inv[of e] apply (auto simp add: Suc_pred') apply(rule_tac x="n - 1" in exI) by auto
- then obtain N::nat where "inverse (real (N + 1)) < e" by auto
- hence "\<forall>n\<ge>N. inverse (real n + 1) < e" by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
- hence "\<exists>N::nat. \<forall>n\<ge>N. inverse (real n + 1) < e" by auto }
- hence "((\<lambda>n. inverse (real n + 1)) ---> 0) sequentially"
- unfolding Lim_sequentially by(auto simp add: dist_norm)
- hence "(f ---> x) sequentially" unfolding f_def
- using Lim_add[OF Lim_const, of "\<lambda>n::nat. (inverse (real n + 1)) *\<^sub>R ((1 / 2) *\<^sub>R (a + b) - x)" 0 sequentially x]
- using Lim_vmul[of "\<lambda>n::nat. inverse (real n + 1)" 0 sequentially "((1 / 2) *\<^sub>R (a + b) - x)"] by auto }
- ultimately have "x \<in> closure {a<..<b}"
- using as and open_interval_midpoint[OF assms] unfolding closure_def unfolding islimpt_sequential by(cases "x=?c")auto }
- thus ?thesis using closure_minimal[OF interval_open_subset_closed closed_interval, of a b] by blast
-qed
-
-lemma bounded_subset_open_interval_symmetric: fixes s::"(real^'n::finite) set"
- assumes "bounded s" shows "\<exists>a. s \<subseteq> {-a<..<a}"
-proof-
- obtain b where "b>0" and b:"\<forall>x\<in>s. norm x \<le> b" using assms[unfolded bounded_pos] by auto
- def a \<equiv> "(\<chi> i. b+1)::real^'n"
- { fix x assume "x\<in>s"
- fix i
- have "(-a)$i < x$i" and "x$i < a$i" using b[THEN bspec[where x=x], OF `x\<in>s`] and component_le_norm[of x i]
- unfolding vector_uminus_component and a_def and Cart_lambda_beta by auto
- }
- thus ?thesis by(auto intro: exI[where x=a] simp add: vector_less_def)
-qed
-
-lemma bounded_subset_open_interval:
- fixes s :: "(real ^ 'n::finite) set"
- shows "bounded s ==> (\<exists>a b. s \<subseteq> {a<..<b})"
- by (auto dest!: bounded_subset_open_interval_symmetric)
-
-lemma bounded_subset_closed_interval_symmetric:
- fixes s :: "(real ^ 'n::finite) set"
- assumes "bounded s" shows "\<exists>a. s \<subseteq> {-a .. a}"
-proof-
- obtain a where "s \<subseteq> {- a<..<a}" using bounded_subset_open_interval_symmetric[OF assms] by auto
- thus ?thesis using interval_open_subset_closed[of "-a" a] by auto
-qed
-
-lemma bounded_subset_closed_interval:
- fixes s :: "(real ^ 'n::finite) set"
- shows "bounded s ==> (\<exists>a b. s \<subseteq> {a .. b})"
- using bounded_subset_closed_interval_symmetric[of s] by auto
-
-lemma frontier_closed_interval:
- fixes a b :: "real ^ _"
- shows "frontier {a .. b} = {a .. b} - {a<..<b}"
- unfolding frontier_def unfolding interior_closed_interval and closure_closed[OF closed_interval] ..
-
-lemma frontier_open_interval:
- fixes a b :: "real ^ _"
- shows "frontier {a<..<b} = (if {a<..<b} = {} then {} else {a .. b} - {a<..<b})"
-proof(cases "{a<..<b} = {}")
- case True thus ?thesis using frontier_empty by auto
-next
- case False thus ?thesis unfolding frontier_def and closure_open_interval[OF False] and interior_open[OF open_interval] by auto
-qed
-
-lemma inter_interval_mixed_eq_empty: fixes a :: "real^'n::finite"
- assumes "{c<..<d} \<noteq> {}" shows "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> {a<..<b} \<inter> {c<..<d} = {}"
- unfolding closure_open_interval[OF assms, THEN sym] unfolding open_inter_closure_eq_empty[OF open_interval] ..
-
-
-(* Some special cases for intervals in R^1. *)
-
-lemma all_1: "(\<forall>x::1. P x) \<longleftrightarrow> P 1"
- by (metis num1_eq_iff)
-
-lemma ex_1: "(\<exists>x::1. P x) \<longleftrightarrow> P 1"
- by auto (metis num1_eq_iff)
-
-lemma interval_cases_1: fixes x :: "real^1" shows
- "x \<in> {a .. b} ==> x \<in> {a<..<b} \<or> (x = a) \<or> (x = b)"
- by(simp add: Cart_eq vector_less_def vector_less_eq_def all_1, auto)
-
-lemma in_interval_1: fixes x :: "real^1" shows
- "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b) \<and>
- (x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
-by(simp add: Cart_eq vector_less_def vector_less_eq_def all_1 dest_vec1_def)
-
-lemma interval_eq_empty_1: fixes a :: "real^1" shows
- "{a .. b} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a"
- "{a<..<b} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a"
- unfolding interval_eq_empty and ex_1 and dest_vec1_def by auto
-
-lemma subset_interval_1: fixes a :: "real^1" shows
- "({a .. b} \<subseteq> {c .. d} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or>
- dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a \<le> dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
- "({a .. b} \<subseteq> {c<..<d} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or>
- dest_vec1 c < dest_vec1 a \<and> dest_vec1 a \<le> dest_vec1 b \<and> dest_vec1 b < dest_vec1 d)"
- "({a<..<b} \<subseteq> {c .. d} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or>
- dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a < dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
- "({a<..<b} \<subseteq> {c<..<d} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or>
- dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a < dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
- unfolding subset_interval[of a b c d] unfolding all_1 and dest_vec1_def by auto
-
-lemma eq_interval_1: fixes a :: "real^1" shows
- "{a .. b} = {c .. d} \<longleftrightarrow>
- dest_vec1 b < dest_vec1 a \<and> dest_vec1 d < dest_vec1 c \<or>
- dest_vec1 a = dest_vec1 c \<and> dest_vec1 b = dest_vec1 d"
-using set_eq_subset[of "{a .. b}" "{c .. d}"]
-using subset_interval_1(1)[of a b c d]
-using subset_interval_1(1)[of c d a b]
-by auto (* FIXME: slow *)
-
-lemma disjoint_interval_1: fixes a :: "real^1" shows
- "{a .. b} \<inter> {c .. d} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or> dest_vec1 d < dest_vec1 c \<or> dest_vec1 b < dest_vec1 c \<or> dest_vec1 d < dest_vec1 a"
- "{a .. b} \<inter> {c<..<d} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or> dest_vec1 d \<le> dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
- "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or> dest_vec1 d < dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
- "{a<..<b} \<inter> {c<..<d} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or> dest_vec1 d \<le> dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
- unfolding disjoint_interval and dest_vec1_def ex_1 by auto
-
-lemma open_closed_interval_1: fixes a :: "real^1" shows
- "{a<..<b} = {a .. b} - {a, b}"
- unfolding expand_set_eq apply simp unfolding vector_less_def and vector_less_eq_def and all_1 and dest_vec1_eq[THEN sym] and dest_vec1_def by auto
-
-lemma closed_open_interval_1: "dest_vec1 (a::real^1) \<le> dest_vec1 b ==> {a .. b} = {a<..<b} \<union> {a,b}"
- unfolding expand_set_eq apply simp unfolding vector_less_def and vector_less_eq_def and all_1 and dest_vec1_eq[THEN sym] and dest_vec1_def by auto
-
-(* Some stuff for half-infinite intervals too; FIXME: notation? *)
-
-lemma closed_interval_left: fixes b::"real^'n::finite"
- shows "closed {x::real^'n. \<forall>i. x$i \<le> b$i}"
-proof-
- { fix i
- fix x::"real^'n" assume x:"\<forall>e>0. \<exists>x'\<in>{x. \<forall>i. x $ i \<le> b $ i}. x' \<noteq> x \<and> dist x' x < e"
- { assume "x$i > b$i"
- then obtain y where "y $ i \<le> b $ i" "y \<noteq> x" "dist y x < x$i - b$i" using x[THEN spec[where x="x$i - b$i"]] by auto
- hence False using component_le_norm[of "y - x" i] unfolding dist_norm and vector_minus_component by auto }
- hence "x$i \<le> b$i" by(rule ccontr)auto }
- thus ?thesis unfolding closed_limpt unfolding islimpt_approachable by blast
-qed
-
-lemma closed_interval_right: fixes a::"real^'n::finite"
- shows "closed {x::real^'n. \<forall>i. a$i \<le> x$i}"
-proof-
- { fix i
- fix x::"real^'n" assume x:"\<forall>e>0. \<exists>x'\<in>{x. \<forall>i. a $ i \<le> x $ i}. x' \<noteq> x \<and> dist x' x < e"
- { assume "a$i > x$i"
- then obtain y where "a $ i \<le> y $ i" "y \<noteq> x" "dist y x < a$i - x$i" using x[THEN spec[where x="a$i - x$i"]] by auto
- hence False using component_le_norm[of "y - x" i] unfolding dist_norm and vector_minus_component by auto }
- hence "a$i \<le> x$i" by(rule ccontr)auto }
- thus ?thesis unfolding closed_limpt unfolding islimpt_approachable by blast
-qed
-
-subsection{* Intervals in general, including infinite and mixtures of open and closed. *}
-
-definition "is_interval s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. \<forall>x. (\<forall>i. ((a$i \<le> x$i \<and> x$i \<le> b$i) \<or> (b$i \<le> x$i \<and> x$i \<le> a$i))) \<longrightarrow> x \<in> s)"
-
-lemma is_interval_interval: "is_interval {a .. b::real^'n::finite}" (is ?th1) "is_interval {a<..<b}" (is ?th2) proof -
- have *:"\<And>x y z::real. x < y \<Longrightarrow> y < z \<Longrightarrow> x < z" by auto
- show ?th1 ?th2 unfolding is_interval_def mem_interval Ball_def atLeastAtMost_iff
- by(meson real_le_trans le_less_trans less_le_trans *)+ qed
-
-lemma is_interval_empty:
- "is_interval {}"
- unfolding is_interval_def
- by simp
-
-lemma is_interval_univ:
- "is_interval UNIV"
- unfolding is_interval_def
- by simp
-
-subsection{* Closure of halfspaces and hyperplanes. *}
-
-lemma Lim_inner:
- assumes "(f ---> l) net" shows "((\<lambda>y. inner a (f y)) ---> inner a l) net"
- by (intro tendsto_intros assms)
-
-lemma continuous_at_inner: "continuous (at x) (inner a)"
- unfolding continuous_at by (intro tendsto_intros)
-
-lemma continuous_on_inner:
- fixes s :: "'a::real_inner set"
- shows "continuous_on s (inner a)"
- unfolding continuous_on by (rule ballI) (intro tendsto_intros)
-
-lemma closed_halfspace_le: "closed {x. inner a x \<le> b}"
-proof-
- have "\<forall>x. continuous (at x) (inner a)"
- unfolding continuous_at by (rule allI) (intro tendsto_intros)
- hence "closed (inner a -` {..b})"
- using closed_real_atMost by (rule continuous_closed_vimage)
- moreover have "{x. inner a x \<le> b} = inner a -` {..b}" by auto
- ultimately show ?thesis by simp
-qed
-
-lemma closed_halfspace_ge: "closed {x. inner a x \<ge> b}"
- using closed_halfspace_le[of "-a" "-b"] unfolding inner_minus_left by auto
-
-lemma closed_hyperplane: "closed {x. inner a x = b}"
-proof-
- have "{x. inner a x = b} = {x. inner a x \<ge> b} \<inter> {x. inner a x \<le> b}" by auto
- thus ?thesis using closed_halfspace_le[of a b] and closed_halfspace_ge[of b a] using closed_Int by auto
-qed
-
-lemma closed_halfspace_component_le:
- shows "closed {x::real^'n::finite. x$i \<le> a}"
- using closed_halfspace_le[of "(basis i)::real^'n" a] unfolding inner_basis[OF assms] by auto
-
-lemma closed_halfspace_component_ge:
- shows "closed {x::real^'n::finite. x$i \<ge> a}"
- using closed_halfspace_ge[of a "(basis i)::real^'n"] unfolding inner_basis[OF assms] by auto
-
-text{* Openness of halfspaces. *}
-
-lemma open_halfspace_lt: "open {x. inner a x < b}"
-proof-
- have "UNIV - {x. b \<le> inner a x} = {x. inner a x < b}" by auto
- thus ?thesis using closed_halfspace_ge[unfolded closed_def Compl_eq_Diff_UNIV, of b a] by auto
-qed
-
-lemma open_halfspace_gt: "open {x. inner a x > b}"
-proof-
- have "UNIV - {x. b \<ge> inner a x} = {x. inner a x > b}" by auto
- thus ?thesis using closed_halfspace_le[unfolded closed_def Compl_eq_Diff_UNIV, of a b] by auto
-qed
-
-lemma open_halfspace_component_lt:
- shows "open {x::real^'n::finite. x$i < a}"
- using open_halfspace_lt[of "(basis i)::real^'n" a] unfolding inner_basis[OF assms] by auto
-
-lemma open_halfspace_component_gt:
- shows "open {x::real^'n::finite. x$i > a}"
- using open_halfspace_gt[of a "(basis i)::real^'n"] unfolding inner_basis[OF assms] by auto
-
-text{* This gives a simple derivation of limit component bounds. *}
-
-lemma Lim_component_le: fixes f :: "'a \<Rightarrow> real^'n::finite"
- assumes "(f ---> l) net" "\<not> (trivial_limit net)" "eventually (\<lambda>x. f(x)$i \<le> b) net"
- shows "l$i \<le> b"
-proof-
- { fix x have "x \<in> {x::real^'n. inner (basis i) x \<le> b} \<longleftrightarrow> x$i \<le> b" unfolding inner_basis by auto } note * = this
- show ?thesis using Lim_in_closed_set[of "{x. inner (basis i) x \<le> b}" f net l] unfolding *
- using closed_halfspace_le[of "(basis i)::real^'n" b] and assms(1,2,3) by auto
-qed
-
-lemma Lim_component_ge: fixes f :: "'a \<Rightarrow> real^'n::finite"
- assumes "(f ---> l) net" "\<not> (trivial_limit net)" "eventually (\<lambda>x. b \<le> (f x)$i) net"
- shows "b \<le> l$i"
-proof-
- { fix x have "x \<in> {x::real^'n. inner (basis i) x \<ge> b} \<longleftrightarrow> x$i \<ge> b" unfolding inner_basis by auto } note * = this
- show ?thesis using Lim_in_closed_set[of "{x. inner (basis i) x \<ge> b}" f net l] unfolding *
- using closed_halfspace_ge[of b "(basis i)::real^'n"] and assms(1,2,3) by auto
-qed
-
-lemma Lim_component_eq: fixes f :: "'a \<Rightarrow> real^'n::finite"
- assumes net:"(f ---> l) net" "~(trivial_limit net)" and ev:"eventually (\<lambda>x. f(x)$i = b) net"
- shows "l$i = b"
- using ev[unfolded order_eq_iff eventually_and] using Lim_component_ge[OF net, of b i] and Lim_component_le[OF net, of i b] by auto
-
-lemma Lim_drop_le: fixes f :: "'a \<Rightarrow> real^1" shows
- "(f ---> l) net \<Longrightarrow> ~(trivial_limit net) \<Longrightarrow> eventually (\<lambda>x. dest_vec1 (f x) \<le> b) net ==> dest_vec1 l \<le> b"
- using Lim_component_le[of f l net 1 b] unfolding dest_vec1_def by auto
-
-lemma Lim_drop_ge: fixes f :: "'a \<Rightarrow> real^1" shows
- "(f ---> l) net \<Longrightarrow> ~(trivial_limit net) \<Longrightarrow> eventually (\<lambda>x. b \<le> dest_vec1 (f x)) net ==> b \<le> dest_vec1 l"
- using Lim_component_ge[of f l net b 1] unfolding dest_vec1_def by auto
-
-text{* Limits relative to a union. *}
-
-lemma eventually_within_Un:
- "eventually P (net within (s \<union> t)) \<longleftrightarrow>
- eventually P (net within s) \<and> eventually P (net within t)"
- unfolding Limits.eventually_within
- by (auto elim!: eventually_rev_mp)
-
-lemma Lim_within_union:
- "(f ---> l) (net within (s \<union> t)) \<longleftrightarrow>
- (f ---> l) (net within s) \<and> (f ---> l) (net within t)"
- unfolding tendsto_def
- by (auto simp add: eventually_within_Un)
-
-lemma continuous_on_union:
- assumes "closed s" "closed t" "continuous_on s f" "continuous_on t f"
- shows "continuous_on (s \<union> t) f"
- using assms unfolding continuous_on unfolding Lim_within_union
- unfolding Lim unfolding trivial_limit_within unfolding closed_limpt by auto
-
-lemma continuous_on_cases:
- assumes "closed s" "closed t" "continuous_on s f" "continuous_on t g"
- "\<forall>x. (x\<in>s \<and> \<not> P x) \<or> (x \<in> t \<and> P x) \<longrightarrow> f x = g x"
- shows "continuous_on (s \<union> t) (\<lambda>x. if P x then f x else g x)"
-proof-
- let ?h = "(\<lambda>x. if P x then f x else g x)"
- have "\<forall>x\<in>s. f x = (if P x then f x else g x)" using assms(5) by auto
- hence "continuous_on s ?h" using continuous_on_eq[of s f ?h] using assms(3) by auto
- moreover
- have "\<forall>x\<in>t. g x = (if P x then f x else g x)" using assms(5) by auto
- hence "continuous_on t ?h" using continuous_on_eq[of t g ?h] using assms(4) by auto
- ultimately show ?thesis using continuous_on_union[OF assms(1,2), of ?h] by auto
-qed
-
-
-text{* Some more convenient intermediate-value theorem formulations. *}
-
-lemma connected_ivt_hyperplane:
- assumes "connected s" "x \<in> s" "y \<in> s" "inner a x \<le> b" "b \<le> inner a y"
- shows "\<exists>z \<in> s. inner a z = b"
-proof(rule ccontr)
- assume as:"\<not> (\<exists>z\<in>s. inner a z = b)"
- let ?A = "{x. inner a x < b}"
- let ?B = "{x. inner a x > b}"
- have "open ?A" "open ?B" using open_halfspace_lt and open_halfspace_gt by auto
- moreover have "?A \<inter> ?B = {}" by auto
- moreover have "s \<subseteq> ?A \<union> ?B" using as by auto
- ultimately show False using assms(1)[unfolded connected_def not_ex, THEN spec[where x="?A"], THEN spec[where x="?B"]] and assms(2-5) by auto
-qed
-
-lemma connected_ivt_component: fixes x::"real^'n::finite" shows
- "connected s \<Longrightarrow> x \<in> s \<Longrightarrow> y \<in> s \<Longrightarrow> x$k \<le> a \<Longrightarrow> a \<le> y$k \<Longrightarrow> (\<exists>z\<in>s. z$k = a)"
- using connected_ivt_hyperplane[of s x y "(basis k)::real^'n" a] by (auto simp add: inner_basis)
-
-text{* Also more convenient formulations of monotone convergence. *}
-
-lemma bounded_increasing_convergent: fixes s::"nat \<Rightarrow> real^1"
- assumes "bounded {s n| n::nat. True}" "\<forall>n. dest_vec1(s n) \<le> dest_vec1(s(Suc n))"
- shows "\<exists>l. (s ---> l) sequentially"
-proof-
- obtain a where a:"\<forall>n. \<bar>dest_vec1 (s n)\<bar> \<le> a" using assms(1)[unfolded bounded_iff abs_dest_vec1] by auto
- { fix m::nat
- have "\<And> n. n\<ge>m \<longrightarrow> dest_vec1 (s m) \<le> dest_vec1 (s n)"
- apply(induct_tac n) apply simp using assms(2) apply(erule_tac x="na" in allE) by(auto simp add: not_less_eq_eq) }
- hence "\<forall>m n. m \<le> n \<longrightarrow> dest_vec1 (s m) \<le> dest_vec1 (s n)" by auto
- then obtain l where "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. \<bar>dest_vec1 (s n) - l\<bar> < e" using convergent_bounded_monotone[OF a] unfolding monoseq_def by auto
- thus ?thesis unfolding Lim_sequentially apply(rule_tac x="vec1 l" in exI)
- unfolding dist_norm unfolding abs_dest_vec1 and dest_vec1_sub by auto
-qed
-
-subsection{* Basic homeomorphism definitions. *}
-
-definition "homeomorphism s t f g \<equiv>
- (\<forall>x\<in>s. (g(f x) = x)) \<and> (f ` s = t) \<and> continuous_on s f \<and>
- (\<forall>y\<in>t. (f(g y) = y)) \<and> (g ` t = s) \<and> continuous_on t g"
-
-definition
- homeomorphic :: "'a::metric_space set \<Rightarrow> 'b::metric_space set \<Rightarrow> bool"
- (infixr "homeomorphic" 60) where
- homeomorphic_def: "s homeomorphic t \<equiv> (\<exists>f g. homeomorphism s t f g)"
-
-lemma homeomorphic_refl: "s homeomorphic s"
- unfolding homeomorphic_def
- unfolding homeomorphism_def
- using continuous_on_id
- apply(rule_tac x = "(\<lambda>x. x)" in exI)
- apply(rule_tac x = "(\<lambda>x. x)" in exI)
- by blast
-
-lemma homeomorphic_sym:
- "s homeomorphic t \<longleftrightarrow> t homeomorphic s"
-unfolding homeomorphic_def
-unfolding homeomorphism_def
-by blast (* FIXME: slow *)
-
-lemma homeomorphic_trans:
- assumes "s homeomorphic t" "t homeomorphic u" shows "s homeomorphic u"
-proof-
- obtain f1 g1 where fg1:"\<forall>x\<in>s. g1 (f1 x) = x" "f1 ` s = t" "continuous_on s f1" "\<forall>y\<in>t. f1 (g1 y) = y" "g1 ` t = s" "continuous_on t g1"
- using assms(1) unfolding homeomorphic_def homeomorphism_def by auto
- obtain f2 g2 where fg2:"\<forall>x\<in>t. g2 (f2 x) = x" "f2 ` t = u" "continuous_on t f2" "\<forall>y\<in>u. f2 (g2 y) = y" "g2 ` u = t" "continuous_on u g2"
- using assms(2) unfolding homeomorphic_def homeomorphism_def by auto
-
- { fix x assume "x\<in>s" hence "(g1 \<circ> g2) ((f2 \<circ> f1) x) = x" using fg1(1)[THEN bspec[where x=x]] and fg2(1)[THEN bspec[where x="f1 x"]] and fg1(2) by auto }
- moreover have "(f2 \<circ> f1) ` s = u" using fg1(2) fg2(2) by auto
- moreover have "continuous_on s (f2 \<circ> f1)" using continuous_on_compose[OF fg1(3)] and fg2(3) unfolding fg1(2) by auto
- moreover { fix y assume "y\<in>u" hence "(f2 \<circ> f1) ((g1 \<circ> g2) y) = y" using fg2(4)[THEN bspec[where x=y]] and fg1(4)[THEN bspec[where x="g2 y"]] and fg2(5) by auto }
- moreover have "(g1 \<circ> g2) ` u = s" using fg1(5) fg2(5) by auto
- moreover have "continuous_on u (g1 \<circ> g2)" using continuous_on_compose[OF fg2(6)] and fg1(6) unfolding fg2(5) by auto
- ultimately show ?thesis unfolding homeomorphic_def homeomorphism_def apply(rule_tac x="f2 \<circ> f1" in exI) apply(rule_tac x="g1 \<circ> g2" in exI) by auto
-qed
-
-lemma homeomorphic_minimal:
- "s homeomorphic t \<longleftrightarrow>
- (\<exists>f g. (\<forall>x\<in>s. f(x) \<in> t \<and> (g(f(x)) = x)) \<and>
- (\<forall>y\<in>t. g(y) \<in> s \<and> (f(g(y)) = y)) \<and>
- continuous_on s f \<and> continuous_on t g)"
-unfolding homeomorphic_def homeomorphism_def
-apply auto apply (rule_tac x=f in exI) apply (rule_tac x=g in exI)
-apply auto apply (rule_tac x=f in exI) apply (rule_tac x=g in exI) apply auto
-unfolding image_iff
-apply(erule_tac x="g x" in ballE) apply(erule_tac x="x" in ballE)
-apply auto apply(rule_tac x="g x" in bexI) apply auto
-apply(erule_tac x="f x" in ballE) apply(erule_tac x="x" in ballE)
-apply auto apply(rule_tac x="f x" in bexI) by auto
-
-subsection{* Relatively weak hypotheses if a set is compact. *}
-
-definition "inv_on f s = (\<lambda>x. SOME y. y\<in>s \<and> f y = x)"
-
-lemma assumes "inj_on f s" "x\<in>s"
- shows "inv_on f s (f x) = x"
- using assms unfolding inj_on_def inv_on_def by auto
-
-lemma homeomorphism_compact:
- fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
- (* class constraint due to continuous_on_inverse *)
- assumes "compact s" "continuous_on s f" "f ` s = t" "inj_on f s"
- shows "\<exists>g. homeomorphism s t f g"
-proof-
- def g \<equiv> "\<lambda>x. SOME y. y\<in>s \<and> f y = x"
- have g:"\<forall>x\<in>s. g (f x) = x" using assms(3) assms(4)[unfolded inj_on_def] unfolding g_def by auto
- { fix y assume "y\<in>t"
- then obtain x where x:"f x = y" "x\<in>s" using assms(3) by auto
- hence "g (f x) = x" using g by auto
- hence "f (g y) = y" unfolding x(1)[THEN sym] by auto }
- hence g':"\<forall>x\<in>t. f (g x) = x" by auto
- moreover
- { fix x
- have "x\<in>s \<Longrightarrow> x \<in> g ` t" using g[THEN bspec[where x=x]] unfolding image_iff using assms(3) by(auto intro!: bexI[where x="f x"])
- moreover
- { assume "x\<in>g ` t"
- then obtain y where y:"y\<in>t" "g y = x" by auto
- then obtain x' where x':"x'\<in>s" "f x' = y" using assms(3) by auto
- hence "x \<in> s" unfolding g_def using someI2[of "\<lambda>b. b\<in>s \<and> f b = y" x' "\<lambda>x. x\<in>s"] unfolding y(2)[THEN sym] and g_def by auto }
- ultimately have "x\<in>s \<longleftrightarrow> x \<in> g ` t" by auto }
- hence "g ` t = s" by auto
- ultimately
- show ?thesis unfolding homeomorphism_def homeomorphic_def
- apply(rule_tac x=g in exI) using g and assms(3) and continuous_on_inverse[OF assms(2,1), of g, unfolded assms(3)] and assms(2) by auto
-qed
-
-lemma homeomorphic_compact:
- fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
- (* class constraint due to continuous_on_inverse *)
- shows "compact s \<Longrightarrow> continuous_on s f \<Longrightarrow> (f ` s = t) \<Longrightarrow> inj_on f s
- \<Longrightarrow> s homeomorphic t"
- unfolding homeomorphic_def by(metis homeomorphism_compact)
-
-text{* Preservation of topological properties. *}
-
-lemma homeomorphic_compactness:
- "s homeomorphic t ==> (compact s \<longleftrightarrow> compact t)"
-unfolding homeomorphic_def homeomorphism_def
-by (metis compact_continuous_image)
-
-text{* Results on translation, scaling etc. *}
-
-lemma homeomorphic_scaling:
- fixes s :: "'a::real_normed_vector set"
- assumes "c \<noteq> 0" shows "s homeomorphic ((\<lambda>x. c *\<^sub>R x) ` s)"
- unfolding homeomorphic_minimal
- apply(rule_tac x="\<lambda>x. c *\<^sub>R x" in exI)
- apply(rule_tac x="\<lambda>x. (1 / c) *\<^sub>R x" in exI)
- using assms apply auto
- using continuous_on_cmul[OF continuous_on_id] by auto
-
-lemma homeomorphic_translation:
- fixes s :: "'a::real_normed_vector set"
- shows "s homeomorphic ((\<lambda>x. a + x) ` s)"
- unfolding homeomorphic_minimal
- apply(rule_tac x="\<lambda>x. a + x" in exI)
- apply(rule_tac x="\<lambda>x. -a + x" in exI)
- using continuous_on_add[OF continuous_on_const continuous_on_id] by auto
-
-lemma homeomorphic_affinity:
- fixes s :: "'a::real_normed_vector set"
- assumes "c \<noteq> 0" shows "s homeomorphic ((\<lambda>x. a + c *\<^sub>R x) ` s)"
-proof-
- have *:"op + a ` op *\<^sub>R c ` s = (\<lambda>x. a + c *\<^sub>R x) ` s" by auto
- show ?thesis
- using homeomorphic_trans
- using homeomorphic_scaling[OF assms, of s]
- using homeomorphic_translation[of "(\<lambda>x. c *\<^sub>R x) ` s" a] unfolding * by auto
-qed
-
-lemma homeomorphic_balls:
- fixes a b ::"'a::real_normed_vector" (* FIXME: generalize to metric_space *)
- assumes "0 < d" "0 < e"
- shows "(ball a d) homeomorphic (ball b e)" (is ?th)
- "(cball a d) homeomorphic (cball b e)" (is ?cth)
-proof-
- have *:"\<bar>e / d\<bar> > 0" "\<bar>d / e\<bar> >0" using assms using divide_pos_pos by auto
- show ?th unfolding homeomorphic_minimal
- apply(rule_tac x="\<lambda>x. b + (e/d) *\<^sub>R (x - a)" in exI)
- apply(rule_tac x="\<lambda>x. a + (d/e) *\<^sub>R (x - b)" in exI)
- using assms apply (auto simp add: dist_commute)
- unfolding dist_norm
- apply (auto simp add: pos_divide_less_eq mult_strict_left_mono)
- unfolding continuous_on
- by (intro ballI tendsto_intros, simp, assumption)+
-next
- have *:"\<bar>e / d\<bar> > 0" "\<bar>d / e\<bar> >0" using assms using divide_pos_pos by auto
- show ?cth unfolding homeomorphic_minimal
- apply(rule_tac x="\<lambda>x. b + (e/d) *\<^sub>R (x - a)" in exI)
- apply(rule_tac x="\<lambda>x. a + (d/e) *\<^sub>R (x - b)" in exI)
- using assms apply (auto simp add: dist_commute)
- unfolding dist_norm
- apply (auto simp add: pos_divide_le_eq)
- unfolding continuous_on
- by (intro ballI tendsto_intros, simp, assumption)+
-qed
-
-text{* "Isometry" (up to constant bounds) of injective linear map etc. *}
-
-lemma cauchy_isometric:
- fixes x :: "nat \<Rightarrow> real ^ 'n::finite"
- assumes e:"0 < e" and s:"subspace s" and f:"bounded_linear f" and normf:"\<forall>x\<in>s. norm(f x) \<ge> e * norm(x)" and xs:"\<forall>n::nat. x n \<in> s" and cf:"Cauchy(f o x)"
- shows "Cauchy x"
-proof-
- interpret f: bounded_linear f by fact
- { fix d::real assume "d>0"
- then obtain N where N:"\<forall>n\<ge>N. norm (f (x n) - f (x N)) < e * d"
- using cf[unfolded cauchy o_def dist_norm, THEN spec[where x="e*d"]] and e and mult_pos_pos[of e d] by auto
- { fix n assume "n\<ge>N"
- hence "norm (f (x n - x N)) < e * d" using N[THEN spec[where x=n]] unfolding f.diff[THEN sym] by auto
- moreover have "e * norm (x n - x N) \<le> norm (f (x n - x N))"
- using subspace_sub[OF s, of "x n" "x N"] using xs[THEN spec[where x=N]] and xs[THEN spec[where x=n]]
- using normf[THEN bspec[where x="x n - x N"]] by auto
- ultimately have "norm (x n - x N) < d" using `e>0`
- using mult_left_less_imp_less[of e "norm (x n - x N)" d] by auto }
- hence "\<exists>N. \<forall>n\<ge>N. norm (x n - x N) < d" by auto }
- thus ?thesis unfolding cauchy and dist_norm by auto
-qed
-
-lemma complete_isometric_image:
- fixes f :: "real ^ _ \<Rightarrow> real ^ _"
- assumes "0 < e" and s:"subspace s" and f:"bounded_linear f" and normf:"\<forall>x\<in>s. norm(f x) \<ge> e * norm(x)" and cs:"complete s"
- shows "complete(f ` s)"
-proof-
- { fix g assume as:"\<forall>n::nat. g n \<in> f ` s" and cfg:"Cauchy g"
- then obtain x where "\<forall>n. x n \<in> s \<and> g n = f (x n)" unfolding image_iff and Bex_def
- using choice[of "\<lambda> n xa. xa \<in> s \<and> g n = f xa"] by auto
- hence x:"\<forall>n. x n \<in> s" "\<forall>n. g n = f (x n)" by auto
- hence "f \<circ> x = g" unfolding expand_fun_eq by auto
- then obtain l where "l\<in>s" and l:"(x ---> l) sequentially"
- using cs[unfolded complete_def, THEN spec[where x="x"]]
- using cauchy_isometric[OF `0<e` s f normf] and cfg and x(1) by auto
- hence "\<exists>l\<in>f ` s. (g ---> l) sequentially"
- using linear_continuous_at[OF f, unfolded continuous_at_sequentially, THEN spec[where x=x], of l]
- unfolding `f \<circ> x = g` by auto }
- thus ?thesis unfolding complete_def by auto
-qed
-
-lemma dist_0_norm:
- fixes x :: "'a::real_normed_vector"
- shows "dist 0 x = norm x"
-unfolding dist_norm by simp
-
-lemma injective_imp_isometric: fixes f::"real^'m::finite \<Rightarrow> real^'n::finite"
- assumes s:"closed s" "subspace s" and f:"bounded_linear f" "\<forall>x\<in>s. (f x = 0) \<longrightarrow> (x = 0)"
- shows "\<exists>e>0. \<forall>x\<in>s. norm (f x) \<ge> e * norm(x)"
-proof(cases "s \<subseteq> {0::real^'m}")
- case True
- { fix x assume "x \<in> s"
- hence "x = 0" using True by auto
- hence "norm x \<le> norm (f x)" by auto }
- thus ?thesis by(auto intro!: exI[where x=1])
-next
- interpret f: bounded_linear f by fact
- case False
- then obtain a where a:"a\<noteq>0" "a\<in>s" by auto
- from False have "s \<noteq> {}" by auto
- let ?S = "{f x| x. (x \<in> s \<and> norm x = norm a)}"
- let ?S' = "{x::real^'m. x\<in>s \<and> norm x = norm a}"
- let ?S'' = "{x::real^'m. norm x = norm a}"
-
- have "?S'' = frontier(cball 0 (norm a))" unfolding frontier_cball and dist_norm by (auto simp add: norm_minus_cancel)
- hence "compact ?S''" using compact_frontier[OF compact_cball, of 0 "norm a"] by auto
- moreover have "?S' = s \<inter> ?S''" by auto
- ultimately have "compact ?S'" using closed_inter_compact[of s ?S''] using s(1) by auto
- moreover have *:"f ` ?S' = ?S" by auto
- ultimately have "compact ?S" using compact_continuous_image[OF linear_continuous_on[OF f(1)], of ?S'] by auto
- hence "closed ?S" using compact_imp_closed by auto
- moreover have "?S \<noteq> {}" using a by auto
- ultimately obtain b' where "b'\<in>?S" "\<forall>y\<in>?S. norm b' \<le> norm y" using distance_attains_inf[of ?S 0] unfolding dist_0_norm by auto
- then obtain b where "b\<in>s" and ba:"norm b = norm a" and b:"\<forall>x\<in>{x \<in> s. norm x = norm a}. norm (f b) \<le> norm (f x)" unfolding *[THEN sym] unfolding image_iff by auto
-
- let ?e = "norm (f b) / norm b"
- have "norm b > 0" using ba and a and norm_ge_zero by auto
- moreover have "norm (f b) > 0" using f(2)[THEN bspec[where x=b], OF `b\<in>s`] using `norm b >0` unfolding zero_less_norm_iff by auto
- ultimately have "0 < norm (f b) / norm b" by(simp only: divide_pos_pos)
- moreover
- { fix x assume "x\<in>s"
- hence "norm (f b) / norm b * norm x \<le> norm (f x)"
- proof(cases "x=0")
- case True thus "norm (f b) / norm b * norm x \<le> norm (f x)" by auto
- next
- case False
- hence *:"0 < norm a / norm x" using `a\<noteq>0` unfolding zero_less_norm_iff[THEN sym] by(simp only: divide_pos_pos)
- have "\<forall>c. \<forall>x\<in>s. c *\<^sub>R x \<in> s" using s[unfolded subspace_def smult_conv_scaleR] by auto
- hence "(norm a / norm x) *\<^sub>R x \<in> {x \<in> s. norm x = norm a}" using `x\<in>s` and `x\<noteq>0` by auto
- thus "norm (f b) / norm b * norm x \<le> norm (f x)" using b[THEN bspec[where x="(norm a / norm x) *\<^sub>R x"]]
- unfolding f.scaleR and ba using `x\<noteq>0` `a\<noteq>0`
- by (auto simp add: real_mult_commute pos_le_divide_eq pos_divide_le_eq)
- qed }
- ultimately
- show ?thesis by auto
-qed
-
-lemma closed_injective_image_subspace:
- fixes f :: "real ^ _ \<Rightarrow> real ^ _"
- assumes "subspace s" "bounded_linear f" "\<forall>x\<in>s. f x = 0 --> x = 0" "closed s"
- shows "closed(f ` s)"
-proof-
- obtain e where "e>0" and e:"\<forall>x\<in>s. e * norm x \<le> norm (f x)" using injective_imp_isometric[OF assms(4,1,2,3)] by auto
- show ?thesis using complete_isometric_image[OF `e>0` assms(1,2) e] and assms(4)
- unfolding complete_eq_closed[THEN sym] by auto
-qed
-
-subsection{* Some properties of a canonical subspace. *}
-
-lemma subspace_substandard:
- "subspace {x::real^'n. (\<forall>i. P i \<longrightarrow> x$i = 0)}"
- unfolding subspace_def by(auto simp add: vector_add_component vector_smult_component elim!: ballE)
-
-lemma closed_substandard:
- "closed {x::real^'n::finite. \<forall>i. P i --> x$i = 0}" (is "closed ?A")
-proof-
- let ?D = "{i. P i}"
- let ?Bs = "{{x::real^'n. inner (basis i) x = 0}| i. i \<in> ?D}"
- { fix x
- { assume "x\<in>?A"
- hence x:"\<forall>i\<in>?D. x $ i = 0" by auto
- hence "x\<in> \<Inter> ?Bs" by(auto simp add: inner_basis x) }
- moreover
- { assume x:"x\<in>\<Inter>?Bs"
- { fix i assume i:"i \<in> ?D"
- then obtain B where BB:"B \<in> ?Bs" and B:"B = {x::real^'n. inner (basis i) x = 0}" by auto
- hence "x $ i = 0" unfolding B using x unfolding inner_basis by auto }
- hence "x\<in>?A" by auto }
- ultimately have "x\<in>?A \<longleftrightarrow> x\<in> \<Inter>?Bs" by auto }
- hence "?A = \<Inter> ?Bs" by auto
- thus ?thesis by(auto simp add: closed_Inter closed_hyperplane)
-qed
-
-lemma dim_substandard:
- shows "dim {x::real^'n::finite. \<forall>i. i \<notin> d \<longrightarrow> x$i = 0} = card d" (is "dim ?A = _")
-proof-
- let ?D = "UNIV::'n set"
- let ?B = "(basis::'n\<Rightarrow>real^'n) ` d"
-
- let ?bas = "basis::'n \<Rightarrow> real^'n"
-
- have "?B \<subseteq> ?A" by auto
-
- moreover
- { fix x::"real^'n" assume "x\<in>?A"
- with finite[of d]
- have "x\<in> span ?B"
- proof(induct d arbitrary: x)
- case empty hence "x=0" unfolding Cart_eq by auto
- thus ?case using subspace_0[OF subspace_span[of "{}"]] by auto
- next
- case (insert k F)
- hence *:"\<forall>i. i \<notin> insert k F \<longrightarrow> x $ i = 0" by auto
- have **:"F \<subseteq> insert k F" by auto
- def y \<equiv> "x - x$k *\<^sub>R basis k"
- have y:"x = y + (x$k) *\<^sub>R basis k" unfolding y_def by auto
- { fix i assume i':"i \<notin> F"
- hence "y $ i = 0" unfolding y_def unfolding vector_minus_component
- and vector_smult_component and basis_component
- using *[THEN spec[where x=i]] by auto }
- hence "y \<in> span (basis ` (insert k F))" using insert(3)
- using span_mono[of "?bas ` F" "?bas ` (insert k F)"]
- using image_mono[OF **, of basis] by auto
- moreover
- have "basis k \<in> span (?bas ` (insert k F))" by(rule span_superset, auto)
- hence "x$k *\<^sub>R basis k \<in> span (?bas ` (insert k F))"
- using span_mul [where 'a=real, unfolded smult_conv_scaleR] by auto
- ultimately
- have "y + x$k *\<^sub>R basis k \<in> span (?bas ` (insert k F))"
- using span_add by auto
- thus ?case using y by auto
- qed
- }
- hence "?A \<subseteq> span ?B" by auto
-
- moreover
- { fix x assume "x \<in> ?B"
- hence "x\<in>{(basis i)::real^'n |i. i \<in> ?D}" using assms by auto }
- hence "independent ?B" using independent_mono[OF independent_stdbasis, of ?B] and assms by auto
-
- moreover
- have "d \<subseteq> ?D" unfolding subset_eq using assms by auto
- hence *:"inj_on (basis::'n\<Rightarrow>real^'n) d" using subset_inj_on[OF basis_inj, of "d"] by auto
- have "?B hassize (card d)" unfolding hassize_def and card_image[OF *] by auto
-
- ultimately show ?thesis using dim_unique[of "basis ` d" ?A] by auto
-qed
-
-text{* Hence closure and completeness of all subspaces. *}
-
-lemma closed_subspace_lemma: "n \<le> card (UNIV::'n::finite set) \<Longrightarrow> \<exists>A::'n set. card A = n"
-apply (induct n)
-apply (rule_tac x="{}" in exI, simp)
-apply clarsimp
-apply (subgoal_tac "\<exists>x. x \<notin> A")
-apply (erule exE)
-apply (rule_tac x="insert x A" in exI, simp)
-apply (subgoal_tac "A \<noteq> UNIV", auto)
-done
-
-lemma closed_subspace: fixes s::"(real^'n::finite) set"
- assumes "subspace s" shows "closed s"
-proof-
- have "dim s \<le> card (UNIV :: 'n set)" using dim_subset_univ by auto
- then obtain d::"'n set" where t: "card d = dim s"
- using closed_subspace_lemma by auto
- let ?t = "{x::real^'n. \<forall>i. i \<notin> d \<longrightarrow> x$i = 0}"
- obtain f where f:"bounded_linear f" "f ` ?t = s" "inj_on f ?t"
- using subspace_isomorphism[unfolded linear_conv_bounded_linear, OF subspace_substandard[of "\<lambda>i. i \<notin> d"] assms]
- using dim_substandard[of d] and t by auto
- interpret f: bounded_linear f by fact
- have "\<forall>x\<in>?t. f x = 0 \<longrightarrow> x = 0" using f.zero using f(3)[unfolded inj_on_def]
- by(erule_tac x=0 in ballE) auto
- moreover have "closed ?t" using closed_substandard .
- moreover have "subspace ?t" using subspace_substandard .
- ultimately show ?thesis using closed_injective_image_subspace[of ?t f]
- unfolding f(2) using f(1) by auto
-qed
-
-lemma complete_subspace:
- fixes s :: "(real ^ _) set" shows "subspace s ==> complete s"
- using complete_eq_closed closed_subspace
- by auto
-
-lemma dim_closure:
- fixes s :: "(real ^ _) set"
- shows "dim(closure s) = dim s" (is "?dc = ?d")
-proof-
- have "?dc \<le> ?d" using closure_minimal[OF span_inc, of s]
- using closed_subspace[OF subspace_span, of s]
- using dim_subset[of "closure s" "span s"] unfolding dim_span by auto
- thus ?thesis using dim_subset[OF closure_subset, of s] by auto
-qed
-
-text{* Affine transformations of intervals. *}
-
-lemma affinity_inverses:
- assumes m0: "m \<noteq> (0::'a::field)"
- shows "(\<lambda>x. m *s x + c) o (\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) = id"
- "(\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) o (\<lambda>x. m *s x + c) = id"
- using m0
-apply (auto simp add: expand_fun_eq vector_add_ldistrib vector_smult_assoc)
-by (simp add: vector_smult_lneg[symmetric] vector_smult_assoc vector_sneg_minus1[symmetric])
-
-lemma real_affinity_le:
- "0 < (m::'a::ordered_field) ==> (m * x + c \<le> y \<longleftrightarrow> x \<le> inverse(m) * y + -(c / m))"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma real_le_affinity:
- "0 < (m::'a::ordered_field) ==> (y \<le> m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) \<le> x)"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma real_affinity_lt:
- "0 < (m::'a::ordered_field) ==> (m * x + c < y \<longleftrightarrow> x < inverse(m) * y + -(c / m))"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma real_lt_affinity:
- "0 < (m::'a::ordered_field) ==> (y < m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) < x)"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma real_affinity_eq:
- "(m::'a::ordered_field) \<noteq> 0 ==> (m * x + c = y \<longleftrightarrow> x = inverse(m) * y + -(c / m))"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma real_eq_affinity:
- "(m::'a::ordered_field) \<noteq> 0 ==> (y = m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) = x)"
- by (simp add: field_simps inverse_eq_divide)
-
-lemma vector_affinity_eq:
- assumes m0: "(m::'a::field) \<noteq> 0"
- shows "m *s x + c = y \<longleftrightarrow> x = inverse m *s y + -(inverse m *s c)"
-proof
- assume h: "m *s x + c = y"
- hence "m *s x = y - c" by (simp add: ring_simps)
- hence "inverse m *s (m *s x) = inverse m *s (y - c)" by simp
- then show "x = inverse m *s y + - (inverse m *s c)"
- using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
-next
- assume h: "x = inverse m *s y + - (inverse m *s c)"
- show "m *s x + c = y" unfolding h diff_minus[symmetric]
- using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
-qed
-
-lemma vector_eq_affinity:
- "(m::'a::field) \<noteq> 0 ==> (y = m *s x + c \<longleftrightarrow> inverse(m) *s y + -(inverse(m) *s c) = x)"
- using vector_affinity_eq[where m=m and x=x and y=y and c=c]
- by metis
-
-lemma image_affinity_interval: fixes m::real
- fixes a b c :: "real^'n::finite"
- shows "(\<lambda>x. m *\<^sub>R x + c) ` {a .. b} =
- (if {a .. b} = {} then {}
- else (if 0 \<le> m then {m *\<^sub>R a + c .. m *\<^sub>R b + c}
- else {m *\<^sub>R b + c .. m *\<^sub>R a + c}))"
-proof(cases "m=0")
- { fix x assume "x \<le> c" "c \<le> x"
- hence "x=c" unfolding vector_less_eq_def and Cart_eq by (auto intro: order_antisym) }
- moreover case True
- moreover have "c \<in> {m *\<^sub>R a + c..m *\<^sub>R b + c}" unfolding True by(auto simp add: vector_less_eq_def)
- ultimately show ?thesis by auto
-next
- case False
- { fix y assume "a \<le> y" "y \<le> b" "m > 0"
- hence "m *\<^sub>R a + c \<le> m *\<^sub>R y + c" "m *\<^sub>R y + c \<le> m *\<^sub>R b + c"
- unfolding vector_less_eq_def by(auto simp add: vector_smult_component vector_add_component)
- } moreover
- { fix y assume "a \<le> y" "y \<le> b" "m < 0"
- hence "m *\<^sub>R b + c \<le> m *\<^sub>R y + c" "m *\<^sub>R y + c \<le> m *\<^sub>R a + c"
- unfolding vector_less_eq_def by(auto simp add: vector_smult_component vector_add_component mult_left_mono_neg elim!:ballE)
- } moreover
- { fix y assume "m > 0" "m *\<^sub>R a + c \<le> y" "y \<le> m *\<^sub>R b + c"
- hence "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
- unfolding image_iff Bex_def mem_interval vector_less_eq_def
- apply(auto simp add: vector_smult_component vector_add_component vector_minus_component vector_smult_assoc pth_3[symmetric]
- intro!: exI[where x="(1 / m) *\<^sub>R (y - c)"])
- by(auto simp add: pos_le_divide_eq pos_divide_le_eq real_mult_commute diff_le_iff)
- } moreover
- { fix y assume "m *\<^sub>R b + c \<le> y" "y \<le> m *\<^sub>R a + c" "m < 0"
- hence "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
- unfolding image_iff Bex_def mem_interval vector_less_eq_def
- apply(auto simp add: vector_smult_component vector_add_component vector_minus_component vector_smult_assoc pth_3[symmetric]
- intro!: exI[where x="(1 / m) *\<^sub>R (y - c)"])
- by(auto simp add: neg_le_divide_eq neg_divide_le_eq real_mult_commute diff_le_iff)
- }
- ultimately show ?thesis using False by auto
-qed
-
-lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::real^'n::finite)) ` {a..b} =
- (if {a..b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a..m *\<^sub>R b} else {m *\<^sub>R b..m *\<^sub>R a})"
- using image_affinity_interval[of m 0 a b] by auto
-
-subsection{* Banach fixed point theorem (not really topological...) *}
-
-lemma banach_fix:
- assumes s:"complete s" "s \<noteq> {}" and c:"0 \<le> c" "c < 1" and f:"(f ` s) \<subseteq> s" and
- lipschitz:"\<forall>x\<in>s. \<forall>y\<in>s. dist (f x) (f y) \<le> c * dist x y"
- shows "\<exists>! x\<in>s. (f x = x)"
-proof-
- have "1 - c > 0" using c by auto
-
- from s(2) obtain z0 where "z0 \<in> s" by auto
- def z \<equiv> "\<lambda>n. (f ^^ n) z0"
- { fix n::nat
- have "z n \<in> s" unfolding z_def
- proof(induct n) case 0 thus ?case using `z0 \<in>s` by auto
- next case Suc thus ?case using f by auto qed }
- note z_in_s = this
-
- def d \<equiv> "dist (z 0) (z 1)"
-
- have fzn:"\<And>n. f (z n) = z (Suc n)" unfolding z_def by auto
- { fix n::nat
- have "dist (z n) (z (Suc n)) \<le> (c ^ n) * d"
- proof(induct n)
- case 0 thus ?case unfolding d_def by auto
- next
- case (Suc m)
- hence "c * dist (z m) (z (Suc m)) \<le> c ^ Suc m * d"
- using `0 \<le> c` using mult_mono1_class.mult_mono1[of "dist (z m) (z (Suc m))" "c ^ m * d" c] by auto
- thus ?case using lipschitz[THEN bspec[where x="z m"], OF z_in_s, THEN bspec[where x="z (Suc m)"], OF z_in_s]
- unfolding fzn and mult_le_cancel_left by auto
- qed
- } note cf_z = this
-
- { fix n m::nat
- have "(1 - c) * dist (z m) (z (m+n)) \<le> (c ^ m) * d * (1 - c ^ n)"
- proof(induct n)
- case 0 show ?case by auto
- next
- case (Suc k)
- have "(1 - c) * dist (z m) (z (m + Suc k)) \<le> (1 - c) * (dist (z m) (z (m + k)) + dist (z (m + k)) (z (Suc (m + k))))"
- using dist_triangle and c by(auto simp add: dist_triangle)
- also have "\<dots> \<le> (1 - c) * (dist (z m) (z (m + k)) + c ^ (m + k) * d)"
- using cf_z[of "m + k"] and c by auto
- also have "\<dots> \<le> c ^ m * d * (1 - c ^ k) + (1 - c) * c ^ (m + k) * d"
- using Suc by (auto simp add: ring_simps)
- also have "\<dots> = (c ^ m) * (d * (1 - c ^ k) + (1 - c) * c ^ k * d)"
- unfolding power_add by (auto simp add: ring_simps)
- also have "\<dots> \<le> (c ^ m) * d * (1 - c ^ Suc k)"
- using c by (auto simp add: ring_simps)
- finally show ?case by auto
- qed
- } note cf_z2 = this
- { fix e::real assume "e>0"
- hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (z m) (z n) < e"
- proof(cases "d = 0")
- case True
- hence "\<And>n. z n = z0" using cf_z2[of 0] and c unfolding z_def by (auto simp add: pos_prod_le[OF `1 - c > 0`])
- thus ?thesis using `e>0` by auto
- next
- case False hence "d>0" unfolding d_def using zero_le_dist[of "z 0" "z 1"]
- by (metis False d_def real_less_def)
- hence "0 < e * (1 - c) / d" using `e>0` and `1-c>0`
- using divide_pos_pos[of "e * (1 - c)" d] and mult_pos_pos[of e "1 - c"] by auto
- then obtain N where N:"c ^ N < e * (1 - c) / d" using real_arch_pow_inv[of "e * (1 - c) / d" c] and c by auto
- { fix m n::nat assume "m>n" and as:"m\<ge>N" "n\<ge>N"
- have *:"c ^ n \<le> c ^ N" using `n\<ge>N` and c using power_decreasing[OF `n\<ge>N`, of c] by auto
- have "1 - c ^ (m - n) > 0" using c and power_strict_mono[of c 1 "m - n"] using `m>n` by auto
- hence **:"d * (1 - c ^ (m - n)) / (1 - c) > 0"
- using real_mult_order[OF `d>0`, of "1 - c ^ (m - n)"]
- using divide_pos_pos[of "d * (1 - c ^ (m - n))" "1 - c"]
- using `0 < 1 - c` by auto
-
- have "dist (z m) (z n) \<le> c ^ n * d * (1 - c ^ (m - n)) / (1 - c)"
- using cf_z2[of n "m - n"] and `m>n` unfolding pos_le_divide_eq[OF `1-c>0`]
- by (auto simp add: real_mult_commute dist_commute)
- also have "\<dots> \<le> c ^ N * d * (1 - c ^ (m - n)) / (1 - c)"
- using mult_right_mono[OF * order_less_imp_le[OF **]]
- unfolding real_mult_assoc by auto
- also have "\<dots> < (e * (1 - c) / d) * d * (1 - c ^ (m - n)) / (1 - c)"
- using mult_strict_right_mono[OF N **] unfolding real_mult_assoc by auto
- also have "\<dots> = e * (1 - c ^ (m - n))" using c and `d>0` and `1 - c > 0` by auto
- also have "\<dots> \<le> e" using c and `1 - c ^ (m - n) > 0` and `e>0` using mult_right_le_one_le[of e "1 - c ^ (m - n)"] by auto
- finally have "dist (z m) (z n) < e" by auto
- } note * = this
- { fix m n::nat assume as:"N\<le>m" "N\<le>n"
- hence "dist (z n) (z m) < e"
- proof(cases "n = m")
- case True thus ?thesis using `e>0` by auto
- next
- case False thus ?thesis using as and *[of n m] *[of m n] unfolding nat_neq_iff by (auto simp add: dist_commute)
- qed }
- thus ?thesis by auto
- qed
- }
- hence "Cauchy z" unfolding cauchy_def by auto
- then obtain x where "x\<in>s" and x:"(z ---> x) sequentially" using s(1)[unfolded compact_def complete_def, THEN spec[where x=z]] and z_in_s by auto
-
- def e \<equiv> "dist (f x) x"
- have "e = 0" proof(rule ccontr)
- assume "e \<noteq> 0" hence "e>0" unfolding e_def using zero_le_dist[of "f x" x]
- by (metis dist_eq_0_iff dist_nz e_def)
- then obtain N where N:"\<forall>n\<ge>N. dist (z n) x < e / 2"
- using x[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
- hence N':"dist (z N) x < e / 2" by auto
-
- have *:"c * dist (z N) x \<le> dist (z N) x" unfolding mult_le_cancel_right2
- using zero_le_dist[of "z N" x] and c
- by (metis dist_eq_0_iff dist_nz order_less_asym real_less_def)
- have "dist (f (z N)) (f x) \<le> c * dist (z N) x" using lipschitz[THEN bspec[where x="z N"], THEN bspec[where x=x]]
- using z_in_s[of N] `x\<in>s` using c by auto
- also have "\<dots> < e / 2" using N' and c using * by auto
- finally show False unfolding fzn
- using N[THEN spec[where x="Suc N"]] and dist_triangle_half_r[of "z (Suc N)" "f x" e x]
- unfolding e_def by auto
- qed
- hence "f x = x" unfolding e_def by auto
- moreover
- { fix y assume "f y = y" "y\<in>s"
- hence "dist x y \<le> c * dist x y" using lipschitz[THEN bspec[where x=x], THEN bspec[where x=y]]
- using `x\<in>s` and `f x = x` by auto
- hence "dist x y = 0" unfolding mult_le_cancel_right1
- using c and zero_le_dist[of x y] by auto
- hence "y = x" by auto
- }
- ultimately show ?thesis unfolding Bex1_def using `x\<in>s` by blast+
-qed
-
-subsection{* Edelstein fixed point theorem. *}
-
-lemma edelstein_fix:
- fixes s :: "'a::real_normed_vector set"
- assumes s:"compact s" "s \<noteq> {}" and gs:"(g ` s) \<subseteq> s"
- and dist:"\<forall>x\<in>s. \<forall>y\<in>s. x \<noteq> y \<longrightarrow> dist (g x) (g y) < dist x y"
- shows "\<exists>! x\<in>s. g x = x"
-proof(cases "\<exists>x\<in>s. g x \<noteq> x")
- obtain x where "x\<in>s" using s(2) by auto
- case False hence g:"\<forall>x\<in>s. g x = x" by auto
- { fix y assume "y\<in>s"
- hence "x = y" using `x\<in>s` and dist[THEN bspec[where x=x], THEN bspec[where x=y]]
- unfolding g[THEN bspec[where x=x], OF `x\<in>s`]
- unfolding g[THEN bspec[where x=y], OF `y\<in>s`] by auto }
- thus ?thesis unfolding Bex1_def using `x\<in>s` and g by blast+
-next
- case True
- then obtain x where [simp]:"x\<in>s" and "g x \<noteq> x" by auto
- { fix x y assume "x \<in> s" "y \<in> s"
- hence "dist (g x) (g y) \<le> dist x y"
- using dist[THEN bspec[where x=x], THEN bspec[where x=y]] by auto } note dist' = this
- def y \<equiv> "g x"
- have [simp]:"y\<in>s" unfolding y_def using gs[unfolded image_subset_iff] and `x\<in>s` by blast
- def f \<equiv> "\<lambda>n. g ^^ n"
- have [simp]:"\<And>n z. g (f n z) = f (Suc n) z" unfolding f_def by auto
- have [simp]:"\<And>z. f 0 z = z" unfolding f_def by auto
- { fix n::nat and z assume "z\<in>s"
- have "f n z \<in> s" unfolding f_def
- proof(induct n)
- case 0 thus ?case using `z\<in>s` by simp
- next
- case (Suc n) thus ?case using gs[unfolded image_subset_iff] by auto
- qed } note fs = this
- { fix m n ::nat assume "m\<le>n"
- fix w z assume "w\<in>s" "z\<in>s"
- have "dist (f n w) (f n z) \<le> dist (f m w) (f m z)" using `m\<le>n`
- proof(induct n)
- case 0 thus ?case by auto
- next
- case (Suc n)
- thus ?case proof(cases "m\<le>n")
- case True thus ?thesis using Suc(1)
- using dist'[OF fs fs, OF `w\<in>s` `z\<in>s`, of n n] by auto
- next
- case False hence mn:"m = Suc n" using Suc(2) by simp
- show ?thesis unfolding mn by auto
- qed
- qed } note distf = this
-
- def h \<equiv> "\<lambda>n. (f n x, f n y)"
- let ?s2 = "s \<times> s"
- obtain l r where "l\<in>?s2" and r:"subseq r" and lr:"((h \<circ> r) ---> l) sequentially"
- using compact_Times [OF s(1) s(1), unfolded compact_def, THEN spec[where x=h]] unfolding h_def
- using fs[OF `x\<in>s`] and fs[OF `y\<in>s`] by blast
- def a \<equiv> "fst l" def b \<equiv> "snd l"
- have lab:"l = (a, b)" unfolding a_def b_def by simp
- have [simp]:"a\<in>s" "b\<in>s" unfolding a_def b_def using `l\<in>?s2` by auto
-
- have lima:"((fst \<circ> (h \<circ> r)) ---> a) sequentially"
- and limb:"((snd \<circ> (h \<circ> r)) ---> b) sequentially"
- using lr
- unfolding o_def a_def b_def by (simp_all add: tendsto_intros)
-
- { fix n::nat
- have *:"\<And>fx fy (x::'a) y. dist fx fy \<le> dist x y \<Longrightarrow> \<not> (dist (fx - fy) (a - b) < dist a b - dist x y)" unfolding dist_norm by norm
- { fix x y :: 'a
- have "dist (-x) (-y) = dist x y" unfolding dist_norm
- using norm_minus_cancel[of "x - y"] by (auto simp add: uminus_add_conv_diff) } note ** = this
-
- { assume as:"dist a b > dist (f n x) (f n y)"
- then obtain Na Nb where "\<forall>m\<ge>Na. dist (f (r m) x) a < (dist a b - dist (f n x) (f n y)) / 2"
- and "\<forall>m\<ge>Nb. dist (f (r m) y) b < (dist a b - dist (f n x) (f n y)) / 2"
- using lima limb unfolding h_def Lim_sequentially by (fastsimp simp del: less_divide_eq_number_of1)
- hence "dist (f (r (Na + Nb + n)) x - f (r (Na + Nb + n)) y) (a - b) < dist a b - dist (f n x) (f n y)"
- apply(erule_tac x="Na+Nb+n" in allE)
- apply(erule_tac x="Na+Nb+n" in allE) apply simp
- using dist_triangle_add_half[of a "f (r (Na + Nb + n)) x" "dist a b - dist (f n x) (f n y)"
- "-b" "- f (r (Na + Nb + n)) y"]
- unfolding ** unfolding group_simps(12) by (auto simp add: dist_commute)
- moreover
- have "dist (f (r (Na + Nb + n)) x - f (r (Na + Nb + n)) y) (a - b) \<ge> dist a b - dist (f n x) (f n y)"
- using distf[of n "r (Na+Nb+n)", OF _ `x\<in>s` `y\<in>s`]
- using subseq_bigger[OF r, of "Na+Nb+n"]
- using *[of "f (r (Na + Nb + n)) x" "f (r (Na + Nb + n)) y" "f n x" "f n y"] by auto
- ultimately have False by simp
- }
- hence "dist a b \<le> dist (f n x) (f n y)" by(rule ccontr)auto }
- note ab_fn = this
-
- have [simp]:"a = b" proof(rule ccontr)
- def e \<equiv> "dist a b - dist (g a) (g b)"
- assume "a\<noteq>b" hence "e > 0" unfolding e_def using dist by fastsimp
- hence "\<exists>n. dist (f n x) a < e/2 \<and> dist (f n y) b < e/2"
- using lima limb unfolding Lim_sequentially
- apply (auto elim!: allE[where x="e/2"]) apply(rule_tac x="r (max N Na)" in exI) unfolding h_def by fastsimp
- then obtain n where n:"dist (f n x) a < e/2 \<and> dist (f n y) b < e/2" by auto
- have "dist (f (Suc n) x) (g a) \<le> dist (f n x) a"
- using dist[THEN bspec[where x="f n x"], THEN bspec[where x="a"]] and fs by auto
- moreover have "dist (f (Suc n) y) (g b) \<le> dist (f n y) b"
- using dist[THEN bspec[where x="f n y"], THEN bspec[where x="b"]] and fs by auto
- ultimately have "dist (f (Suc n) x) (g a) + dist (f (Suc n) y) (g b) < e" using n by auto
- thus False unfolding e_def using ab_fn[of "Suc n"] by norm
- qed
-
- have [simp]:"\<And>n. f (Suc n) x = f n y" unfolding f_def y_def by(induct_tac n)auto
- { fix x y assume "x\<in>s" "y\<in>s" moreover
- fix e::real assume "e>0" ultimately
- have "dist y x < e \<longrightarrow> dist (g y) (g x) < e" using dist by fastsimp }
- hence "continuous_on s g" unfolding continuous_on_def by auto
-
- hence "((snd \<circ> h \<circ> r) ---> g a) sequentially" unfolding continuous_on_sequentially
- apply (rule allE[where x="\<lambda>n. (fst \<circ> h \<circ> r) n"]) apply (erule ballE[where x=a])
- using lima unfolding h_def o_def using fs[OF `x\<in>s`] by (auto simp add: y_def)
- hence "g a = a" using Lim_unique[OF trivial_limit_sequentially limb, of "g a"]
- unfolding `a=b` and o_assoc by auto
- moreover
- { fix x assume "x\<in>s" "g x = x" "x\<noteq>a"
- hence "False" using dist[THEN bspec[where x=a], THEN bspec[where x=x]]
- using `g a = a` and `a\<in>s` by auto }
- ultimately show "\<exists>!x\<in>s. g x = x" unfolding Bex1_def using `a\<in>s` by blast
-qed
-
-end--- a/src/HOL/Main.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Main.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1,7 +1,7 @@
header {* Main HOL *}
theory Main
-imports Plain Quickcheck Map Recdef SAT
+imports Plain Nitpick Quickcheck Recdef
begin
text {*--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Convex_Euclidean_Space.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,3384 @@
+(* Title: HOL/Library/Convex_Euclidean_Space.thy
+ Author: Robert Himmelmann, TU Muenchen
+*)
+
+header {* Convex sets, functions and related things. *}
+
+theory Convex_Euclidean_Space
+imports Topology_Euclidean_Space
+begin
+
+
+(* ------------------------------------------------------------------------- *)
+(* To be moved elsewhere *)
+(* ------------------------------------------------------------------------- *)
+
+declare vector_add_ldistrib[simp] vector_ssub_ldistrib[simp] vector_smult_assoc[simp] vector_smult_rneg[simp]
+declare vector_sadd_rdistrib[simp] vector_sub_rdistrib[simp]
+declare dot_ladd[simp] dot_radd[simp] dot_lsub[simp] dot_rsub[simp]
+declare dot_lmult[simp] dot_rmult[simp] dot_lneg[simp] dot_rneg[simp]
+declare UNIV_1[simp]
+
+term "(x::real^'n \<Rightarrow> real) 0"
+
+lemma dim1in[intro]:"Suc 0 \<in> {1::nat .. CARD(1)}" by auto
+
+lemmas vector_component_simps = vector_minus_component vector_smult_component vector_add_component vector_less_eq_def Cart_lambda_beta dest_vec1_def basis_component vector_uminus_component
+
+lemmas continuous_intros = continuous_add continuous_vmul continuous_cmul continuous_const continuous_sub continuous_at_id continuous_within_id
+
+lemmas continuous_on_intros = continuous_on_add continuous_on_const continuous_on_id continuous_on_compose continuous_on_cmul continuous_on_neg continuous_on_sub
+ uniformly_continuous_on_add uniformly_continuous_on_const uniformly_continuous_on_id uniformly_continuous_on_compose uniformly_continuous_on_cmul uniformly_continuous_on_neg uniformly_continuous_on_sub
+
+lemma dest_vec1_simps[simp]: fixes a::"real^1"
+ shows "a$1 = 0 \<longleftrightarrow> a = 0" (*"a \<le> 1 \<longleftrightarrow> dest_vec1 a \<le> 1" "0 \<le> a \<longleftrightarrow> 0 \<le> dest_vec1 a"*)
+ "a \<le> b \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 b" "dest_vec1 (1::real^1) = 1"
+ by(auto simp add:vector_component_simps all_1 Cart_eq)
+
+lemma nequals0I:"x\<in>A \<Longrightarrow> A \<noteq> {}" by auto
+
+lemma norm_not_0:"(x::real^'n::finite)\<noteq>0 \<Longrightarrow> norm x \<noteq> 0" by auto
+
+lemma setsum_delta_notmem: assumes "x\<notin>s"
+ shows "setsum (\<lambda>y. if (y = x) then P x else Q y) s = setsum Q s"
+ "setsum (\<lambda>y. if (x = y) then P x else Q y) s = setsum Q s"
+ "setsum (\<lambda>y. if (y = x) then P y else Q y) s = setsum Q s"
+ "setsum (\<lambda>y. if (x = y) then P y else Q y) s = setsum Q s"
+ apply(rule_tac [!] setsum_cong2) using assms by auto
+
+lemma setsum_delta'':
+ fixes s::"'a::real_vector set" assumes "finite s"
+ shows "(\<Sum>x\<in>s. (if y = x then f x else 0) *\<^sub>R x) = (if y\<in>s then (f y) *\<^sub>R y else 0)"
+proof-
+ have *:"\<And>x y. (if y = x then f x else (0::real)) *\<^sub>R x = (if x=y then (f x) *\<^sub>R x else 0)" by auto
+ show ?thesis unfolding * using setsum_delta[OF assms, of y "\<lambda>x. f x *\<^sub>R x"] by auto
+qed
+
+lemma not_disjointI:"x\<in>A \<Longrightarrow> x\<in>B \<Longrightarrow> A \<inter> B \<noteq> {}" by blast
+
+lemma if_smult:"(if P then x else (y::real)) *\<^sub>R v = (if P then x *\<^sub>R v else y *\<^sub>R v)" by auto
+
+lemma mem_interval_1: fixes x :: "real^1" shows
+ "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b)"
+ "(x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
+by(simp_all add: Cart_eq vector_less_def vector_less_eq_def dest_vec1_def all_1)
+
+lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::real^'n::finite)) ` {a..b} =
+ (if {a..b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a..m *\<^sub>R b} else {m *\<^sub>R b..m *\<^sub>R a})"
+ using image_affinity_interval[of m 0 a b] by auto
+
+lemma dest_vec1_inverval:
+ "dest_vec1 ` {a .. b} = {dest_vec1 a .. dest_vec1 b}"
+ "dest_vec1 ` {a<.. b} = {dest_vec1 a<.. dest_vec1 b}"
+ "dest_vec1 ` {a ..<b} = {dest_vec1 a ..<dest_vec1 b}"
+ "dest_vec1 ` {a<..<b} = {dest_vec1 a<..<dest_vec1 b}"
+ apply(rule_tac [!] equalityI)
+ unfolding subset_eq Ball_def Bex_def mem_interval_1 image_iff
+ apply(rule_tac [!] allI)apply(rule_tac [!] impI)
+ apply(rule_tac[2] x="vec1 x" in exI)apply(rule_tac[4] x="vec1 x" in exI)
+ apply(rule_tac[6] x="vec1 x" in exI)apply(rule_tac[8] x="vec1 x" in exI)
+ by (auto simp add: vector_less_def vector_less_eq_def all_1 dest_vec1_def
+ vec1_dest_vec1[unfolded dest_vec1_def One_nat_def])
+
+lemma dest_vec1_setsum: assumes "finite S"
+ shows " dest_vec1 (setsum f S) = setsum (\<lambda>x. dest_vec1 (f x)) S"
+ using dest_vec1_sum[OF assms] by auto
+
+lemma dist_triangle_eq:
+ fixes x y z :: "real ^ _"
+ shows "dist x z = dist x y + dist y z \<longleftrightarrow> norm (x - y) *\<^sub>R (y - z) = norm (y - z) *\<^sub>R (x - y)"
+proof- have *:"x - y + (y - z) = x - z" by auto
+ show ?thesis unfolding dist_norm norm_triangle_eq[of "x - y" "y - z", unfolded smult_conv_scaleR *]
+ by(auto simp add:norm_minus_commute) qed
+
+lemma norm_eqI:"x = y \<Longrightarrow> norm x = norm y" by auto
+lemma norm_minus_eqI:"(x::real^'n::finite) = - y \<Longrightarrow> norm x = norm y" by auto
+
+lemma Min_grI: assumes "finite A" "A \<noteq> {}" "\<forall>a\<in>A. x < a" shows "x < Min A"
+ unfolding Min_gr_iff[OF assms(1,2)] using assms(3) by auto
+
+lemma dimindex_ge_1:"CARD(_::finite) \<ge> 1"
+ using one_le_card_finite by auto
+
+lemma real_dimindex_ge_1:"real (CARD('n::finite)) \<ge> 1"
+ by(metis dimindex_ge_1 linorder_not_less real_eq_of_nat real_le_trans real_of_nat_1 real_of_nat_le_iff)
+
+lemma real_dimindex_gt_0:"real (CARD('n::finite)) > 0" apply(rule less_le_trans[OF _ real_dimindex_ge_1]) by auto
+
+subsection {* Affine set and affine hull.*}
+
+definition
+ affine :: "'a::real_vector set \<Rightarrow> bool" where
+ "affine s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s)"
+
+lemma affine_alt: "affine s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u::real. (1 - u) *\<^sub>R x + u *\<^sub>R y \<in> s)"
+proof- have *:"\<And>u v ::real. u + v = 1 \<longleftrightarrow> v = 1 - u" by auto
+ { fix x y assume "x\<in>s" "y\<in>s"
+ hence "(\<forall>u v::real. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s) \<longleftrightarrow> (\<forall>u::real. (1 - u) *\<^sub>R x + u *\<^sub>R y \<in> s)" apply auto
+ apply(erule_tac[!] x="1 - u" in allE) unfolding * by auto }
+ thus ?thesis unfolding affine_def by auto qed
+
+lemma affine_empty[intro]: "affine {}"
+ unfolding affine_def by auto
+
+lemma affine_sing[intro]: "affine {x}"
+ unfolding affine_alt by (auto simp add: scaleR_left_distrib [symmetric])
+
+lemma affine_UNIV[intro]: "affine UNIV"
+ unfolding affine_def by auto
+
+lemma affine_Inter: "(\<forall>s\<in>f. affine s) \<Longrightarrow> affine (\<Inter> f)"
+ unfolding affine_def by auto
+
+lemma affine_Int: "affine s \<Longrightarrow> affine t \<Longrightarrow> affine (s \<inter> t)"
+ unfolding affine_def by auto
+
+lemma affine_affine_hull: "affine(affine hull s)"
+ unfolding hull_def using affine_Inter[of "{t \<in> affine. s \<subseteq> t}"]
+ unfolding mem_def by auto
+
+lemma affine_hull_eq[simp]: "(affine hull s = s) \<longleftrightarrow> affine s"
+proof-
+ { fix f assume "f \<subseteq> affine"
+ hence "affine (\<Inter>f)" using affine_Inter[of f] unfolding subset_eq mem_def by auto }
+ thus ?thesis using hull_eq[unfolded mem_def, of affine s] by auto
+qed
+
+lemma setsum_restrict_set'': assumes "finite A"
+ shows "setsum f {x \<in> A. P x} = (\<Sum>x\<in>A. if P x then f x else 0)"
+ unfolding mem_def[of _ P, symmetric] unfolding setsum_restrict_set'[OF assms] ..
+
+subsection {* Some explicit formulations (from Lars Schewe). *}
+
+lemma affine: fixes V::"'a::real_vector set"
+ shows "affine V \<longleftrightarrow> (\<forall>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> V \<and> setsum u s = 1 \<longrightarrow> (setsum (\<lambda>x. (u x) *\<^sub>R x)) s \<in> V)"
+unfolding affine_def apply rule apply(rule, rule, rule) apply(erule conjE)+
+defer apply(rule, rule, rule, rule, rule) proof-
+ fix x y u v assume as:"x \<in> V" "y \<in> V" "u + v = (1::real)"
+ "\<forall>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> V \<and> setsum u s = 1 \<longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V"
+ thus "u *\<^sub>R x + v *\<^sub>R y \<in> V" apply(cases "x=y")
+ using as(4)[THEN spec[where x="{x,y}"], THEN spec[where x="\<lambda>w. if w = x then u else v"]] and as(1-3)
+ by(auto simp add: scaleR_left_distrib[THEN sym])
+next
+ fix s u assume as:"\<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V"
+ "finite s" "s \<noteq> {}" "s \<subseteq> V" "setsum u s = (1::real)"
+ def n \<equiv> "card s"
+ have "card s = 0 \<or> card s = 1 \<or> card s = 2 \<or> card s > 2" by auto
+ thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" proof(auto simp only: disjE)
+ assume "card s = 2" hence "card s = Suc (Suc 0)" by auto
+ then obtain a b where "s = {a, b}" unfolding card_Suc_eq by auto
+ thus ?thesis using as(1)[THEN bspec[where x=a], THEN bspec[where x=b]] using as(4,5)
+ by(auto simp add: setsum_clauses(2))
+ next assume "card s > 2" thus ?thesis using as and n_def proof(induct n arbitrary: u s)
+ case (Suc n) fix s::"'a set" and u::"'a \<Rightarrow> real"
+ assume IA:"\<And>u s. \<lbrakk>2 < card s; \<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V; finite s;
+ s \<noteq> {}; s \<subseteq> V; setsum u s = 1; n \<equiv> card s \<rbrakk> \<Longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" and
+ as:"Suc n \<equiv> card s" "2 < card s" "\<forall>x\<in>V. \<forall>y\<in>V. \<forall>u v. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> V"
+ "finite s" "s \<noteq> {}" "s \<subseteq> V" "setsum u s = 1"
+ have "\<exists>x\<in>s. u x \<noteq> 1" proof(rule_tac ccontr)
+ assume " \<not> (\<exists>x\<in>s. u x \<noteq> 1)" hence "setsum u s = real_of_nat (card s)" unfolding card_eq_setsum by auto
+ thus False using as(7) and `card s > 2` by (metis Numeral1_eq1_nat less_0_number_of less_int_code(15)
+ less_nat_number_of not_less_iff_gr_or_eq of_nat_1 of_nat_eq_iff pos2 rel_simps(4)) qed
+ then obtain x where x:"x\<in>s" "u x \<noteq> 1" by auto
+
+ have c:"card (s - {x}) = card s - 1" apply(rule card_Diff_singleton) using `x\<in>s` as(4) by auto
+ have *:"s = insert x (s - {x})" "finite (s - {x})" using `x\<in>s` and as(4) by auto
+ have **:"setsum u (s - {x}) = 1 - u x"
+ using setsum_clauses(2)[OF *(2), of u x, unfolded *(1)[THEN sym] as(7)] by auto
+ have ***:"inverse (1 - u x) * setsum u (s - {x}) = 1" unfolding ** using `u x \<noteq> 1` by auto
+ have "(\<Sum>xa\<in>s - {x}. (inverse (1 - u x) * u xa) *\<^sub>R xa) \<in> V" proof(cases "card (s - {x}) > 2")
+ case True hence "s - {x} \<noteq> {}" "card (s - {x}) = n" unfolding c and as(1)[symmetric] proof(rule_tac ccontr)
+ assume "\<not> s - {x} \<noteq> {}" hence "card (s - {x}) = 0" unfolding card_0_eq[OF *(2)] by simp
+ thus False using True by auto qed auto
+ thus ?thesis apply(rule_tac IA[of "s - {x}" "\<lambda>y. (inverse (1 - u x) * u y)"])
+ unfolding setsum_right_distrib[THEN sym] using as and *** and True by auto
+ next case False hence "card (s - {x}) = Suc (Suc 0)" using as(2) and c by auto
+ then obtain a b where "(s - {x}) = {a, b}" "a\<noteq>b" unfolding card_Suc_eq by auto
+ thus ?thesis using as(3)[THEN bspec[where x=a], THEN bspec[where x=b]]
+ using *** *(2) and `s \<subseteq> V` unfolding setsum_right_distrib by(auto simp add: setsum_clauses(2)) qed
+ thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> V" unfolding scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric]
+ apply(subst *) unfolding setsum_clauses(2)[OF *(2)]
+ using as(3)[THEN bspec[where x=x], THEN bspec[where x="(inverse (1 - u x)) *\<^sub>R (\<Sum>xa\<in>s - {x}. u xa *\<^sub>R xa)"],
+ THEN spec[where x="u x"], THEN spec[where x="1 - u x"]] and rev_subsetD[OF `x\<in>s` `s\<subseteq>V`] and `u x \<noteq> 1` by auto
+ qed auto
+ next assume "card s = 1" then obtain a where "s={a}" by(auto simp add: card_Suc_eq)
+ thus ?thesis using as(4,5) by simp
+ qed(insert `s\<noteq>{}` `finite s`, auto)
+qed
+
+lemma affine_hull_explicit:
+ "affine hull p = {y. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> setsum (\<lambda>v. (u v) *\<^sub>R v) s = y}"
+ apply(rule hull_unique) apply(subst subset_eq) prefer 3 apply rule unfolding mem_Collect_eq and mem_def[of _ affine]
+ apply (erule exE)+ apply(erule conjE)+ prefer 2 apply rule proof-
+ fix x assume "x\<in>p" thus "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ apply(rule_tac x="{x}" in exI, rule_tac x="\<lambda>x. 1" in exI) by auto
+next
+ fix t x s u assume as:"p \<subseteq> t" "affine t" "finite s" "s \<noteq> {}" "s \<subseteq> p" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ thus "x \<in> t" using as(2)[unfolded affine, THEN spec[where x=s], THEN spec[where x=u]] by auto
+next
+ show "affine {y. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y}" unfolding affine_def
+ apply(rule,rule,rule,rule,rule) unfolding mem_Collect_eq proof-
+ fix u v ::real assume uv:"u + v = 1"
+ fix x assume "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ then obtain sx ux where x:"finite sx" "sx \<noteq> {}" "sx \<subseteq> p" "setsum ux sx = 1" "(\<Sum>v\<in>sx. ux v *\<^sub>R v) = x" by auto
+ fix y assume "\<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
+ then obtain sy uy where y:"finite sy" "sy \<noteq> {}" "sy \<subseteq> p" "setsum uy sy = 1" "(\<Sum>v\<in>sy. uy v *\<^sub>R v) = y" by auto
+ have xy:"finite (sx \<union> sy)" using x(1) y(1) by auto
+ have **:"(sx \<union> sy) \<inter> sx = sx" "(sx \<union> sy) \<inter> sy = sy" by auto
+ show "\<exists>s ua. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p \<and> setsum ua s = 1 \<and> (\<Sum>v\<in>s. ua v *\<^sub>R v) = u *\<^sub>R x + v *\<^sub>R y"
+ apply(rule_tac x="sx \<union> sy" in exI)
+ apply(rule_tac x="\<lambda>a. (if a\<in>sx then u * ux a else 0) + (if a\<in>sy then v * uy a else 0)" in exI)
+ unfolding scaleR_left_distrib setsum_addf if_smult scaleR_zero_left ** setsum_restrict_set[OF xy, THEN sym]
+ unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and setsum_right_distrib[THEN sym]
+ unfolding x y using x(1-3) y(1-3) uv by simp qed qed
+
+lemma affine_hull_finite:
+ assumes "finite s"
+ shows "affine hull s = {y. \<exists>u. setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}"
+ unfolding affine_hull_explicit and expand_set_eq and mem_Collect_eq apply (rule,rule)
+ apply(erule exE)+ apply(erule conjE)+ defer apply(erule exE) apply(erule conjE) proof-
+ fix x u assume "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ thus "\<exists>sa u. finite sa \<and> \<not> (\<forall>x. (x \<in> sa) = (x \<in> {})) \<and> sa \<subseteq> s \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = x"
+ apply(rule_tac x=s in exI, rule_tac x=u in exI) using assms by auto
+next
+ fix x t u assume "t \<subseteq> s" hence *:"s \<inter> t = t" by auto
+ assume "finite t" "\<not> (\<forall>x. (x \<in> t) = (x \<in> {}))" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = x"
+ thus "\<exists>u. setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x" apply(rule_tac x="\<lambda>x. if x\<in>t then u x else 0" in exI)
+ unfolding if_smult scaleR_zero_left and setsum_restrict_set[OF assms, THEN sym] and * by auto qed
+
+subsection {* Stepping theorems and hence small special cases. *}
+
+lemma affine_hull_empty[simp]: "affine hull {} = {}"
+ apply(rule hull_unique) unfolding mem_def by auto
+
+lemma affine_hull_finite_step:
+ fixes y :: "'a::real_vector"
+ shows "(\<exists>u. setsum u {} = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) {} = y) \<longleftrightarrow> w = 0 \<and> y = 0" (is ?th1)
+ "finite s \<Longrightarrow> (\<exists>u. setsum u (insert a s) = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) (insert a s) = y) \<longleftrightarrow>
+ (\<exists>v u. setsum u s = w - v \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y - v *\<^sub>R a)" (is "?as \<Longrightarrow> (?lhs = ?rhs)")
+proof-
+ show ?th1 by simp
+ assume ?as
+ { assume ?lhs
+ then obtain u where u:"setsum u (insert a s) = w \<and> (\<Sum>x\<in>insert a s. u x *\<^sub>R x) = y" by auto
+ have ?rhs proof(cases "a\<in>s")
+ case True hence *:"insert a s = s" by auto
+ show ?thesis using u[unfolded *] apply(rule_tac x=0 in exI) by auto
+ next
+ case False thus ?thesis apply(rule_tac x="u a" in exI) using u and `?as` by auto
+ qed } moreover
+ { assume ?rhs
+ then obtain v u where vu:"setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
+ have *:"\<And>x M. (if x = a then v else M) *\<^sub>R x = (if x = a then v *\<^sub>R x else M *\<^sub>R x)" by auto
+ have ?lhs proof(cases "a\<in>s")
+ case True thus ?thesis
+ apply(rule_tac x="\<lambda>x. (if x=a then v else 0) + u x" in exI)
+ unfolding setsum_clauses(2)[OF `?as`] apply simp
+ unfolding scaleR_left_distrib and setsum_addf
+ unfolding vu and * and scaleR_zero_left
+ by (auto simp add: setsum_delta[OF `?as`])
+ next
+ case False
+ hence **:"\<And>x. x \<in> s \<Longrightarrow> u x = (if x = a then v else u x)"
+ "\<And>x. x \<in> s \<Longrightarrow> u x *\<^sub>R x = (if x = a then v *\<^sub>R x else u x *\<^sub>R x)" by auto
+ from False show ?thesis
+ apply(rule_tac x="\<lambda>x. if x=a then v else u x" in exI)
+ unfolding setsum_clauses(2)[OF `?as`] and * using vu
+ using setsum_cong2[of s "\<lambda>x. u x *\<^sub>R x" "\<lambda>x. if x = a then v *\<^sub>R x else u x *\<^sub>R x", OF **(2)]
+ using setsum_cong2[of s u "\<lambda>x. if x = a then v else u x", OF **(1)] by auto
+ qed }
+ ultimately show "?lhs = ?rhs" by blast
+qed
+
+lemma affine_hull_2:
+ fixes a b :: "'a::real_vector"
+ shows "affine hull {a,b} = {u *\<^sub>R a + v *\<^sub>R b| u v. (u + v = 1)}" (is "?lhs = ?rhs")
+proof-
+ have *:"\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::real)"
+ "\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::'a)" by auto
+ have "?lhs = {y. \<exists>u. setsum u {a, b} = 1 \<and> (\<Sum>v\<in>{a, b}. u v *\<^sub>R v) = y}"
+ using affine_hull_finite[of "{a,b}"] by auto
+ also have "\<dots> = {y. \<exists>v u. u b = 1 - v \<and> u b *\<^sub>R b = y - v *\<^sub>R a}"
+ by(simp add: affine_hull_finite_step(2)[of "{b}" a])
+ also have "\<dots> = ?rhs" unfolding * by auto
+ finally show ?thesis by auto
+qed
+
+lemma affine_hull_3:
+ fixes a b c :: "'a::real_vector"
+ shows "affine hull {a,b,c} = { u *\<^sub>R a + v *\<^sub>R b + w *\<^sub>R c| u v w. u + v + w = 1}" (is "?lhs = ?rhs")
+proof-
+ have *:"\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::real)"
+ "\<And>x y z. z = x - y \<longleftrightarrow> y + z = (x::'a)" by auto
+ show ?thesis apply(simp add: affine_hull_finite affine_hull_finite_step)
+ unfolding * apply auto
+ apply(rule_tac x=v in exI) apply(rule_tac x=va in exI) apply auto
+ apply(rule_tac x=u in exI) by(auto intro!: exI)
+qed
+
+subsection {* Some relations between affine hull and subspaces. *}
+
+lemma affine_hull_insert_subset_span:
+ fixes a :: "real ^ _"
+ shows "affine hull (insert a s) \<subseteq> {a + v| v . v \<in> span {x - a | x . x \<in> s}}"
+ unfolding subset_eq Ball_def unfolding affine_hull_explicit span_explicit mem_Collect_eq smult_conv_scaleR
+ apply(rule,rule) apply(erule exE)+ apply(erule conjE)+ proof-
+ fix x t u assume as:"finite t" "t \<noteq> {}" "t \<subseteq> insert a s" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = x"
+ have "(\<lambda>x. x - a) ` (t - {a}) \<subseteq> {x - a |x. x \<in> s}" using as(3) by auto
+ thus "\<exists>v. x = a + v \<and> (\<exists>S u. finite S \<and> S \<subseteq> {x - a |x. x \<in> s} \<and> (\<Sum>v\<in>S. u v *\<^sub>R v) = v)"
+ apply(rule_tac x="x - a" in exI)
+ apply (rule conjI, simp)
+ apply(rule_tac x="(\<lambda>x. x - a) ` (t - {a})" in exI)
+ apply(rule_tac x="\<lambda>x. u (x + a)" in exI)
+ apply (rule conjI) using as(1) apply simp
+ apply (erule conjI)
+ using as(1)
+ apply (simp add: setsum_reindex[unfolded inj_on_def] scaleR_right_diff_distrib setsum_subtractf scaleR_left.setsum[THEN sym] setsum_diff1 scaleR_left_diff_distrib)
+ unfolding as by simp qed
+
+lemma affine_hull_insert_span:
+ fixes a :: "real ^ _"
+ assumes "a \<notin> s"
+ shows "affine hull (insert a s) =
+ {a + v | v . v \<in> span {x - a | x. x \<in> s}}"
+ apply(rule, rule affine_hull_insert_subset_span) unfolding subset_eq Ball_def
+ unfolding affine_hull_explicit and mem_Collect_eq proof(rule,rule,erule exE,erule conjE)
+ fix y v assume "y = a + v" "v \<in> span {x - a |x. x \<in> s}"
+ then obtain t u where obt:"finite t" "t \<subseteq> {x - a |x. x \<in> s}" "a + (\<Sum>v\<in>t. u v *\<^sub>R v) = y" unfolding span_explicit smult_conv_scaleR by auto
+ def f \<equiv> "(\<lambda>x. x + a) ` t"
+ have f:"finite f" "f \<subseteq> s" "(\<Sum>v\<in>f. u (v - a) *\<^sub>R (v - a)) = y - a" unfolding f_def using obt
+ by(auto simp add: setsum_reindex[unfolded inj_on_def])
+ have *:"f \<inter> {a} = {}" "f \<inter> - {a} = f" using f(2) assms by auto
+ show "\<exists>sa u. finite sa \<and> sa \<noteq> {} \<and> sa \<subseteq> insert a s \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y"
+ apply(rule_tac x="insert a f" in exI)
+ apply(rule_tac x="\<lambda>x. if x=a then 1 - setsum (\<lambda>x. u (x - a)) f else u (x - a)" in exI)
+ using assms and f unfolding setsum_clauses(2)[OF f(1)] and if_smult
+ unfolding setsum_cases[OF f(1), of "{a}", unfolded singleton_iff] and *
+ by (auto simp add: setsum_subtractf scaleR_left.setsum algebra_simps) qed
+
+lemma affine_hull_span:
+ fixes a :: "real ^ _"
+ assumes "a \<in> s"
+ shows "affine hull s = {a + v | v. v \<in> span {x - a | x. x \<in> s - {a}}}"
+ using affine_hull_insert_span[of a "s - {a}", unfolded insert_Diff[OF assms]] by auto
+
+subsection {* Convexity. *}
+
+definition
+ convex :: "'a::real_vector set \<Rightarrow> bool" where
+ "convex s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s)"
+
+lemma convex_alt: "convex s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u. 0 \<le> u \<and> u \<le> 1 \<longrightarrow> ((1 - u) *\<^sub>R x + u *\<^sub>R y) \<in> s)"
+proof- have *:"\<And>u v::real. u + v = 1 \<longleftrightarrow> u = 1 - v" by auto
+ show ?thesis unfolding convex_def apply auto
+ apply(erule_tac x=x in ballE) apply(erule_tac x=y in ballE) apply(erule_tac x="1 - u" in allE)
+ by (auto simp add: *) qed
+
+lemma mem_convex:
+ assumes "convex s" "a \<in> s" "b \<in> s" "0 \<le> u" "u \<le> 1"
+ shows "((1 - u) *\<^sub>R a + u *\<^sub>R b) \<in> s"
+ using assms unfolding convex_alt by auto
+
+lemma convex_empty[intro]: "convex {}"
+ unfolding convex_def by simp
+
+lemma convex_singleton[intro]: "convex {a}"
+ unfolding convex_def by (auto simp add:scaleR_left_distrib[THEN sym])
+
+lemma convex_UNIV[intro]: "convex UNIV"
+ unfolding convex_def by auto
+
+lemma convex_Inter: "(\<forall>s\<in>f. convex s) ==> convex(\<Inter> f)"
+ unfolding convex_def by auto
+
+lemma convex_Int: "convex s \<Longrightarrow> convex t \<Longrightarrow> convex (s \<inter> t)"
+ unfolding convex_def by auto
+
+lemma convex_halfspace_le: "convex {x. inner a x \<le> b}"
+ unfolding convex_def apply auto
+ unfolding inner_add inner_scaleR
+ by (metis real_convex_bound_le)
+
+lemma convex_halfspace_ge: "convex {x. inner a x \<ge> b}"
+proof- have *:"{x. inner a x \<ge> b} = {x. inner (-a) x \<le> -b}" by auto
+ show ?thesis apply(unfold *) using convex_halfspace_le[of "-a" "-b"] by auto qed
+
+lemma convex_hyperplane: "convex {x. inner a x = b}"
+proof-
+ have *:"{x. inner a x = b} = {x. inner a x \<le> b} \<inter> {x. inner a x \<ge> b}" by auto
+ show ?thesis unfolding * apply(rule convex_Int)
+ using convex_halfspace_le convex_halfspace_ge by auto
+qed
+
+lemma convex_halfspace_lt: "convex {x. inner a x < b}"
+ unfolding convex_def
+ by(auto simp add: real_convex_bound_lt inner_add)
+
+lemma convex_halfspace_gt: "convex {x. inner a x > b}"
+ using convex_halfspace_lt[of "-a" "-b"] by auto
+
+lemma convex_positive_orthant: "convex {x::real^'n::finite. (\<forall>i. 0 \<le> x$i)}"
+ unfolding convex_def apply auto apply(erule_tac x=i in allE)+
+ apply(rule add_nonneg_nonneg) by(auto simp add: mult_nonneg_nonneg)
+
+subsection {* Explicit expressions for convexity in terms of arbitrary sums. *}
+
+lemma convex: "convex s \<longleftrightarrow>
+ (\<forall>(k::nat) u x. (\<forall>i. 1\<le>i \<and> i\<le>k \<longrightarrow> 0 \<le> u i \<and> x i \<in>s) \<and> (setsum u {1..k} = 1)
+ \<longrightarrow> setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} \<in> s)"
+ unfolding convex_def apply rule apply(rule allI)+ defer apply(rule ballI)+ apply(rule allI)+ proof(rule,rule,rule,rule)
+ fix x y u v assume as:"\<forall>(k::nat) u x. (\<forall>i. 1 \<le> i \<and> i \<le> k \<longrightarrow> 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow> (\<Sum>i = 1..k. u i *\<^sub>R x i) \<in> s"
+ "x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
+ show "u *\<^sub>R x + v *\<^sub>R y \<in> s" using as(1)[THEN spec[where x=2], THEN spec[where x="\<lambda>n. if n=1 then u else v"], THEN spec[where x="\<lambda>n. if n=1 then x else y"]] and as(2-)
+ by (auto simp add: setsum_head_Suc)
+next
+ fix k u x assume as:"\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s"
+ show "(\<forall>i::nat. 1 \<le> i \<and> i \<le> k \<longrightarrow> 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow> (\<Sum>i = 1..k. u i *\<^sub>R x i) \<in> s" apply(rule,erule conjE) proof(induct k arbitrary: u)
+ case (Suc k) show ?case proof(cases "u (Suc k) = 1")
+ case True hence "(\<Sum>i = Suc 0..k. u i *\<^sub>R x i) = 0" apply(rule_tac setsum_0') apply(rule ccontr) unfolding ball_simps apply(erule bexE) proof-
+ fix i assume i:"i \<in> {Suc 0..k}" "u i *\<^sub>R x i \<noteq> 0"
+ hence ui:"u i \<noteq> 0" by auto
+ hence "setsum (\<lambda>k. if k=i then u i else 0) {1 .. k} \<le> setsum u {1 .. k}" apply(rule_tac setsum_mono) using Suc(2) by auto
+ hence "setsum u {1 .. k} \<ge> u i" using i(1) by(auto simp add: setsum_delta)
+ hence "setsum u {1 .. k} > 0" using ui apply(rule_tac less_le_trans[of _ "u i"]) using Suc(2)[THEN spec[where x=i]] and i(1) by auto
+ thus False using Suc(3) unfolding setsum_cl_ivl_Suc and True by simp qed
+ thus ?thesis unfolding setsum_cl_ivl_Suc using True and Suc(2) by auto
+ next
+ have *:"setsum u {1..k} = 1 - u (Suc k)" using Suc(3)[unfolded setsum_cl_ivl_Suc] by auto
+ have **:"u (Suc k) \<le> 1" apply(rule ccontr) unfolding not_le using Suc(3) using setsum_nonneg[of "{1..k}" u] using Suc(2) by auto
+ have ***:"\<And>i k. (u i / (1 - u (Suc k))) *\<^sub>R x i = (inverse (1 - u (Suc k))) *\<^sub>R (u i *\<^sub>R x i)" unfolding real_divide_def by (auto simp add: algebra_simps)
+ case False hence nn:"1 - u (Suc k) \<noteq> 0" by auto
+ have "(\<Sum>i = 1..k. (u i / (1 - u (Suc k))) *\<^sub>R x i) \<in> s" apply(rule Suc(1)) unfolding setsum_divide_distrib[THEN sym] and *
+ apply(rule_tac allI) apply(rule,rule) apply(rule divide_nonneg_pos) using nn Suc(2) ** by auto
+ hence "(1 - u (Suc k)) *\<^sub>R (\<Sum>i = 1..k. (u i / (1 - u (Suc k))) *\<^sub>R x i) + u (Suc k) *\<^sub>R x (Suc k) \<in> s"
+ apply(rule as[THEN bspec, THEN bspec, THEN spec, THEN mp, THEN spec, THEN mp, THEN mp]) using Suc(2)[THEN spec[where x="Suc k"]] and ** by auto
+ thus ?thesis unfolding setsum_cl_ivl_Suc and *** and scaleR_right.setsum [symmetric] using nn by auto qed qed auto qed
+
+
+lemma convex_explicit:
+ fixes s :: "'a::real_vector set"
+ shows "convex s \<longleftrightarrow>
+ (\<forall>t u. finite t \<and> t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> setsum (\<lambda>x. u x *\<^sub>R x) t \<in> s)"
+ unfolding convex_def apply(rule,rule,rule) apply(subst imp_conjL,rule) defer apply(rule,rule,rule,rule,rule,rule,rule) proof-
+ fix x y u v assume as:"\<forall>t u. finite t \<and> t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" "x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
+ show "u *\<^sub>R x + v *\<^sub>R y \<in> s" proof(cases "x=y")
+ case True show ?thesis unfolding True and scaleR_left_distrib[THEN sym] using as(3,6) by auto next
+ case False thus ?thesis using as(1)[THEN spec[where x="{x,y}"], THEN spec[where x="\<lambda>z. if z=x then u else v"]] and as(2-) by auto qed
+next
+ fix t u assume asm:"\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in> s" "finite (t::'a set)"
+ (*"finite t" "t \<subseteq> s" "\<forall>x\<in>t. (0::real) \<le> u x" "setsum u t = 1"*)
+ from this(2) have "\<forall>u. t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" apply(induct_tac t rule:finite_induct)
+ prefer 3 apply (rule,rule) apply(erule conjE)+ proof-
+ fix x f u assume ind:"\<forall>u. f \<subseteq> s \<and> (\<forall>x\<in>f. 0 \<le> u x) \<and> setsum u f = 1 \<longrightarrow> (\<Sum>x\<in>f. u x *\<^sub>R x) \<in> s"
+ assume as:"finite f" "x \<notin> f" "insert x f \<subseteq> s" "\<forall>x\<in>insert x f. 0 \<le> u x" "setsum u (insert x f) = (1::real)"
+ show "(\<Sum>x\<in>insert x f. u x *\<^sub>R x) \<in> s" proof(cases "u x = 1")
+ case True hence "setsum (\<lambda>x. u x *\<^sub>R x) f = 0" apply(rule_tac setsum_0') apply(rule ccontr) unfolding ball_simps apply(erule bexE) proof-
+ fix y assume y:"y \<in> f" "u y *\<^sub>R y \<noteq> 0"
+ hence uy:"u y \<noteq> 0" by auto
+ hence "setsum (\<lambda>k. if k=y then u y else 0) f \<le> setsum u f" apply(rule_tac setsum_mono) using as(4) by auto
+ hence "setsum u f \<ge> u y" using y(1) and as(1) by(auto simp add: setsum_delta)
+ hence "setsum u f > 0" using uy apply(rule_tac less_le_trans[of _ "u y"]) using as(4) and y(1) by auto
+ thus False using as(2,5) unfolding setsum_clauses(2)[OF as(1)] and True by auto qed
+ thus ?thesis unfolding setsum_clauses(2)[OF as(1)] using as(2,3) unfolding True by auto
+ next
+ have *:"setsum u f = setsum u (insert x f) - u x" using as(2) unfolding setsum_clauses(2)[OF as(1)] by auto
+ have **:"u x \<le> 1" apply(rule ccontr) unfolding not_le using as(5)[unfolded setsum_clauses(2)[OF as(1)]] and as(2)
+ using setsum_nonneg[of f u] and as(4) by auto
+ case False hence "inverse (1 - u x) *\<^sub>R (\<Sum>x\<in>f. u x *\<^sub>R x) \<in> s" unfolding scaleR_right.setsum and scaleR_scaleR
+ apply(rule_tac ind[THEN spec, THEN mp]) apply rule defer apply rule apply rule apply(rule mult_nonneg_nonneg)
+ unfolding setsum_right_distrib[THEN sym] and * using as and ** by auto
+ hence "u x *\<^sub>R x + (1 - u x) *\<^sub>R ((inverse (1 - u x)) *\<^sub>R setsum (\<lambda>x. u x *\<^sub>R x) f) \<in>s"
+ apply(rule_tac asm(1)[THEN bspec, THEN bspec, THEN spec, THEN mp, THEN spec, THEN mp, THEN mp]) using as and ** False by auto
+ thus ?thesis unfolding setsum_clauses(2)[OF as(1)] using as(2) and False by auto qed
+ qed auto thus "t \<subseteq> s \<and> (\<forall>x\<in>t. 0 \<le> u x) \<and> setsum u t = 1 \<longrightarrow> (\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" by auto
+qed
+
+lemma convex_finite: assumes "finite s"
+ shows "convex s \<longleftrightarrow> (\<forall>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1
+ \<longrightarrow> setsum (\<lambda>x. u x *\<^sub>R x) s \<in> s)"
+ unfolding convex_explicit apply(rule, rule, rule) defer apply(rule,rule,rule)apply(erule conjE)+ proof-
+ fix t u assume as:"\<forall>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<longrightarrow> (\<Sum>x\<in>s. u x *\<^sub>R x) \<in> s" " finite t" "t \<subseteq> s" "\<forall>x\<in>t. 0 \<le> u x" "setsum u t = (1::real)"
+ have *:"s \<inter> t = t" using as(3) by auto
+ show "(\<Sum>x\<in>t. u x *\<^sub>R x) \<in> s" using as(1)[THEN spec[where x="\<lambda>x. if x\<in>t then u x else 0"]]
+ unfolding if_smult and setsum_cases[OF assms] and * using as(2-) by auto
+qed (erule_tac x=s in allE, erule_tac x=u in allE, auto)
+
+subsection {* Cones. *}
+
+definition
+ cone :: "'a::real_vector set \<Rightarrow> bool" where
+ "cone s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>c\<ge>0. (c *\<^sub>R x) \<in> s)"
+
+lemma cone_empty[intro, simp]: "cone {}"
+ unfolding cone_def by auto
+
+lemma cone_univ[intro, simp]: "cone UNIV"
+ unfolding cone_def by auto
+
+lemma cone_Inter[intro]: "(\<forall>s\<in>f. cone s) \<Longrightarrow> cone(\<Inter> f)"
+ unfolding cone_def by auto
+
+subsection {* Conic hull. *}
+
+lemma cone_cone_hull: "cone (cone hull s)"
+ unfolding hull_def using cone_Inter[of "{t \<in> conic. s \<subseteq> t}"]
+ by (auto simp add: mem_def)
+
+lemma cone_hull_eq: "(cone hull s = s) \<longleftrightarrow> cone s"
+ apply(rule hull_eq[unfolded mem_def])
+ using cone_Inter unfolding subset_eq by (auto simp add: mem_def)
+
+subsection {* Affine dependence and consequential theorems (from Lars Schewe). *}
+
+definition
+ affine_dependent :: "'a::real_vector set \<Rightarrow> bool" where
+ "affine_dependent s \<longleftrightarrow> (\<exists>x\<in>s. x \<in> (affine hull (s - {x})))"
+
+lemma affine_dependent_explicit:
+ "affine_dependent p \<longleftrightarrow>
+ (\<exists>s u. finite s \<and> s \<subseteq> p \<and> setsum u s = 0 \<and>
+ (\<exists>v\<in>s. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = 0)"
+ unfolding affine_dependent_def affine_hull_explicit mem_Collect_eq apply(rule)
+ apply(erule bexE,erule exE,erule exE) apply(erule conjE)+ defer apply(erule exE,erule exE) apply(erule conjE)+ apply(erule bexE)
+proof-
+ fix x s u assume as:"x \<in> p" "finite s" "s \<noteq> {}" "s \<subseteq> p - {x}" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ have "x\<notin>s" using as(1,4) by auto
+ show "\<exists>s u. finite s \<and> s \<subseteq> p \<and> setsum u s = 0 \<and> (\<exists>v\<in>s. u v \<noteq> 0) \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = 0"
+ apply(rule_tac x="insert x s" in exI, rule_tac x="\<lambda>v. if v = x then - 1 else u v" in exI)
+ unfolding if_smult and setsum_clauses(2)[OF as(2)] and setsum_delta_notmem[OF `x\<notin>s`] and as using as by auto
+next
+ fix s u v assume as:"finite s" "s \<subseteq> p" "setsum u s = 0" "(\<Sum>v\<in>s. u v *\<^sub>R v) = 0" "v \<in> s" "u v \<noteq> 0"
+ have "s \<noteq> {v}" using as(3,6) by auto
+ thus "\<exists>x\<in>p. \<exists>s u. finite s \<and> s \<noteq> {} \<and> s \<subseteq> p - {x} \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ apply(rule_tac x=v in bexI, rule_tac x="s - {v}" in exI, rule_tac x="\<lambda>x. - (1 / u v) * u x" in exI)
+ unfolding scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric] unfolding setsum_right_distrib[THEN sym] and setsum_diff1[OF as(1)] using as by auto
+qed
+
+lemma affine_dependent_explicit_finite:
+ fixes s :: "'a::real_vector set" assumes "finite s"
+ shows "affine_dependent s \<longleftrightarrow> (\<exists>u. setsum u s = 0 \<and> (\<exists>v\<in>s. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = 0)"
+ (is "?lhs = ?rhs")
+proof
+ have *:"\<And>vt u v. (if vt then u v else 0) *\<^sub>R v = (if vt then (u v) *\<^sub>R v else (0::'a))" by auto
+ assume ?lhs
+ then obtain t u v where "finite t" "t \<subseteq> s" "setsum u t = 0" "v\<in>t" "u v \<noteq> 0" "(\<Sum>v\<in>t. u v *\<^sub>R v) = 0"
+ unfolding affine_dependent_explicit by auto
+ thus ?rhs apply(rule_tac x="\<lambda>x. if x\<in>t then u x else 0" in exI)
+ apply auto unfolding * and setsum_restrict_set[OF assms, THEN sym]
+ unfolding Int_absorb1[OF `t\<subseteq>s`] by auto
+next
+ assume ?rhs
+ then obtain u v where "setsum u s = 0" "v\<in>s" "u v \<noteq> 0" "(\<Sum>v\<in>s. u v *\<^sub>R v) = 0" by auto
+ thus ?lhs unfolding affine_dependent_explicit using assms by auto
+qed
+
+subsection {* A general lemma. *}
+
+lemma convex_connected:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "convex s" shows "connected s"
+proof-
+ { fix e1 e2 assume as:"open e1" "open e2" "e1 \<inter> e2 \<inter> s = {}" "s \<subseteq> e1 \<union> e2"
+ assume "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
+ then obtain x1 x2 where x1:"x1\<in>e1" "x1\<in>s" and x2:"x2\<in>e2" "x2\<in>s" by auto
+ hence n:"norm (x1 - x2) > 0" unfolding zero_less_norm_iff using as(3) by auto
+
+ { fix x e::real assume as:"0 \<le> x" "x \<le> 1" "0 < e"
+ { fix y have *:"(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2) = (y - x) *\<^sub>R x1 - (y - x) *\<^sub>R x2"
+ by (simp add: algebra_simps)
+ assume "\<bar>y - x\<bar> < e / norm (x1 - x2)"
+ hence "norm ((1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2)) < e"
+ unfolding * and scaleR_right_diff_distrib[THEN sym]
+ unfolding less_divide_eq using n by auto }
+ hence "\<exists>d>0. \<forall>y. \<bar>y - x\<bar> < d \<longrightarrow> norm ((1 - x) *\<^sub>R x1 + x *\<^sub>R x2 - ((1 - y) *\<^sub>R x1 + y *\<^sub>R x2)) < e"
+ apply(rule_tac x="e / norm (x1 - x2)" in exI) using as
+ apply auto unfolding zero_less_divide_iff using n by simp } note * = this
+
+ have "\<exists>x\<ge>0. x \<le> 1 \<and> (1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e1 \<and> (1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e2"
+ apply(rule connected_real_lemma) apply (simp add: `x1\<in>e1` `x2\<in>e2` dist_commute)+
+ using * apply(simp add: dist_norm)
+ using as(1,2)[unfolded open_dist] apply simp
+ using as(1,2)[unfolded open_dist] apply simp
+ using assms[unfolded convex_alt, THEN bspec[where x=x1], THEN bspec[where x=x2]] using x1 x2
+ using as(3) by auto
+ then obtain x where "x\<ge>0" "x\<le>1" "(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e1" "(1 - x) *\<^sub>R x1 + x *\<^sub>R x2 \<notin> e2" by auto
+ hence False using as(4)
+ using assms[unfolded convex_alt, THEN bspec[where x=x1], THEN bspec[where x=x2]]
+ using x1(2) x2(2) by auto }
+ thus ?thesis unfolding connected_def by auto
+qed
+
+subsection {* One rather trivial consequence. *}
+
+lemma connected_UNIV: "connected (UNIV :: 'a::real_normed_vector set)"
+ by(simp add: convex_connected convex_UNIV)
+
+subsection {* Convex functions into the reals. *}
+
+definition
+ convex_on :: "'a::real_vector set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" where
+ "convex_on s f \<longleftrightarrow>
+ (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y)"
+
+lemma convex_on_subset: "convex_on t f \<Longrightarrow> s \<subseteq> t \<Longrightarrow> convex_on s f"
+ unfolding convex_on_def by auto
+
+lemma convex_add:
+ assumes "convex_on s f" "convex_on s g"
+ shows "convex_on s (\<lambda>x. f x + g x)"
+proof-
+ { fix x y assume "x\<in>s" "y\<in>s" moreover
+ fix u v ::real assume "0 \<le> u" "0 \<le> v" "u + v = 1"
+ ultimately have "f (u *\<^sub>R x + v *\<^sub>R y) + g (u *\<^sub>R x + v *\<^sub>R y) \<le> (u * f x + v * f y) + (u * g x + v * g y)"
+ using assms(1)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
+ using assms(2)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
+ apply - apply(rule add_mono) by auto
+ hence "f (u *\<^sub>R x + v *\<^sub>R y) + g (u *\<^sub>R x + v *\<^sub>R y) \<le> u * (f x + g x) + v * (f y + g y)" by (simp add: ring_simps) }
+ thus ?thesis unfolding convex_on_def by auto
+qed
+
+lemma convex_cmul:
+ assumes "0 \<le> (c::real)" "convex_on s f"
+ shows "convex_on s (\<lambda>x. c * f x)"
+proof-
+ have *:"\<And>u c fx v fy ::real. u * (c * fx) + v * (c * fy) = c * (u * fx + v * fy)" by (simp add: ring_simps)
+ show ?thesis using assms(2) and mult_mono1[OF _ assms(1)] unfolding convex_on_def and * by auto
+qed
+
+lemma convex_lower:
+ assumes "convex_on s f" "x\<in>s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = 1"
+ shows "f (u *\<^sub>R x + v *\<^sub>R y) \<le> max (f x) (f y)"
+proof-
+ let ?m = "max (f x) (f y)"
+ have "u * f x + v * f y \<le> u * max (f x) (f y) + v * max (f x) (f y)" apply(rule add_mono)
+ using assms(4,5) by(auto simp add: mult_mono1)
+ also have "\<dots> = max (f x) (f y)" using assms(6) unfolding distrib[THEN sym] by auto
+ finally show ?thesis using assms(1)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x=u]]
+ using assms(2-6) by auto
+qed
+
+lemma convex_local_global_minimum:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "0<e" "convex_on s f" "ball x e \<subseteq> s" "\<forall>y\<in>ball x e. f x \<le> f y"
+ shows "\<forall>y\<in>s. f x \<le> f y"
+proof(rule ccontr)
+ have "x\<in>s" using assms(1,3) by auto
+ assume "\<not> (\<forall>y\<in>s. f x \<le> f y)"
+ then obtain y where "y\<in>s" and y:"f x > f y" by auto
+ hence xy:"0 < dist x y" by (auto simp add: dist_nz[THEN sym])
+
+ then obtain u where "0 < u" "u \<le> 1" and u:"u < e / dist x y"
+ using real_lbound_gt_zero[of 1 "e / dist x y"] using xy `e>0` and divide_pos_pos[of e "dist x y"] by auto
+ hence "f ((1-u) *\<^sub>R x + u *\<^sub>R y) \<le> (1-u) * f x + u * f y" using `x\<in>s` `y\<in>s`
+ using assms(2)[unfolded convex_on_def, THEN bspec[where x=x], THEN bspec[where x=y], THEN spec[where x="1-u"]] by auto
+ moreover
+ have *:"x - ((1 - u) *\<^sub>R x + u *\<^sub>R y) = u *\<^sub>R (x - y)" by (simp add: algebra_simps)
+ have "(1 - u) *\<^sub>R x + u *\<^sub>R y \<in> ball x e" unfolding mem_ball dist_norm unfolding * and norm_scaleR and abs_of_pos[OF `0<u`] unfolding dist_norm[THEN sym]
+ using u unfolding pos_less_divide_eq[OF xy] by auto
+ hence "f x \<le> f ((1 - u) *\<^sub>R x + u *\<^sub>R y)" using assms(4) by auto
+ ultimately show False using mult_strict_left_mono[OF y `u>0`] unfolding left_diff_distrib by auto
+qed
+
+lemma convex_distance:
+ fixes s :: "'a::real_normed_vector set"
+ shows "convex_on s (\<lambda>x. dist a x)"
+proof(auto simp add: convex_on_def dist_norm)
+ fix x y assume "x\<in>s" "y\<in>s"
+ fix u v ::real assume "0 \<le> u" "0 \<le> v" "u + v = 1"
+ have "a = u *\<^sub>R a + v *\<^sub>R a" unfolding scaleR_left_distrib[THEN sym] and `u+v=1` by simp
+ hence *:"a - (u *\<^sub>R x + v *\<^sub>R y) = (u *\<^sub>R (a - x)) + (v *\<^sub>R (a - y))"
+ by (auto simp add: algebra_simps)
+ show "norm (a - (u *\<^sub>R x + v *\<^sub>R y)) \<le> u * norm (a - x) + v * norm (a - y)"
+ unfolding * using norm_triangle_ineq[of "u *\<^sub>R (a - x)" "v *\<^sub>R (a - y)"]
+ using `0 \<le> u` `0 \<le> v` by auto
+qed
+
+subsection {* Arithmetic operations on sets preserve convexity. *}
+
+lemma convex_scaling: "convex s \<Longrightarrow> convex ((\<lambda>x. c *\<^sub>R x) ` s)"
+ unfolding convex_def and image_iff apply auto
+ apply (rule_tac x="u *\<^sub>R x+v *\<^sub>R y" in bexI) by (auto simp add: algebra_simps)
+
+lemma convex_negations: "convex s \<Longrightarrow> convex ((\<lambda>x. -x)` s)"
+ unfolding convex_def and image_iff apply auto
+ apply (rule_tac x="u *\<^sub>R x+v *\<^sub>R y" in bexI) by auto
+
+lemma convex_sums:
+ assumes "convex s" "convex t"
+ shows "convex {x + y| x y. x \<in> s \<and> y \<in> t}"
+proof(auto simp add: convex_def image_iff scaleR_right_distrib)
+ fix xa xb ya yb assume xy:"xa\<in>s" "xb\<in>s" "ya\<in>t" "yb\<in>t"
+ fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
+ show "\<exists>x y. u *\<^sub>R xa + u *\<^sub>R ya + (v *\<^sub>R xb + v *\<^sub>R yb) = x + y \<and> x \<in> s \<and> y \<in> t"
+ apply(rule_tac x="u *\<^sub>R xa + v *\<^sub>R xb" in exI) apply(rule_tac x="u *\<^sub>R ya + v *\<^sub>R yb" in exI)
+ using assms(1)[unfolded convex_def, THEN bspec[where x=xa], THEN bspec[where x=xb]]
+ using assms(2)[unfolded convex_def, THEN bspec[where x=ya], THEN bspec[where x=yb]]
+ using uv xy by auto
+qed
+
+lemma convex_differences:
+ assumes "convex s" "convex t"
+ shows "convex {x - y| x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have "{x - y| x y. x \<in> s \<and> y \<in> t} = {x + y |x y. x \<in> s \<and> y \<in> uminus ` t}" unfolding image_iff apply auto
+ apply(rule_tac x=xa in exI) apply(rule_tac x="-y" in exI) apply simp
+ apply(rule_tac x=xa in exI) apply(rule_tac x=xb in exI) by simp
+ thus ?thesis using convex_sums[OF assms(1) convex_negations[OF assms(2)]] by auto
+qed
+
+lemma convex_translation: assumes "convex s" shows "convex ((\<lambda>x. a + x) ` s)"
+proof- have "{a + y |y. y \<in> s} = (\<lambda>x. a + x) ` s" by auto
+ thus ?thesis using convex_sums[OF convex_singleton[of a] assms] by auto qed
+
+lemma convex_affinity: assumes "convex s" shows "convex ((\<lambda>x. a + c *\<^sub>R x) ` s)"
+proof- have "(\<lambda>x. a + c *\<^sub>R x) ` s = op + a ` op *\<^sub>R c ` s" by auto
+ thus ?thesis using convex_translation[OF convex_scaling[OF assms], of a c] by auto qed
+
+lemma convex_linear_image:
+ assumes c:"convex s" and l:"bounded_linear f"
+ shows "convex(f ` s)"
+proof(auto simp add: convex_def)
+ interpret f: bounded_linear f by fact
+ fix x y assume xy:"x \<in> s" "y \<in> s"
+ fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
+ show "u *\<^sub>R f x + v *\<^sub>R f y \<in> f ` s" unfolding image_iff
+ apply(rule_tac x="u *\<^sub>R x + v *\<^sub>R y" in bexI)
+ unfolding f.add f.scaleR
+ using c[unfolded convex_def] xy uv by auto
+qed
+
+subsection {* Balls, being convex, are connected. *}
+
+lemma convex_ball:
+ fixes x :: "'a::real_normed_vector"
+ shows "convex (ball x e)"
+proof(auto simp add: convex_def)
+ fix y z assume yz:"dist x y < e" "dist x z < e"
+ fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
+ have "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> u * dist x y + v * dist x z" using uv yz
+ using convex_distance[of "ball x e" x, unfolded convex_on_def, THEN bspec[where x=y], THEN bspec[where x=z]] by auto
+ thus "dist x (u *\<^sub>R y + v *\<^sub>R z) < e" using real_convex_bound_lt[OF yz uv] by auto
+qed
+
+lemma convex_cball:
+ fixes x :: "'a::real_normed_vector"
+ shows "convex(cball x e)"
+proof(auto simp add: convex_def Ball_def mem_cball)
+ fix y z assume yz:"dist x y \<le> e" "dist x z \<le> e"
+ fix u v ::real assume uv:" 0 \<le> u" "0 \<le> v" "u + v = 1"
+ have "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> u * dist x y + v * dist x z" using uv yz
+ using convex_distance[of "cball x e" x, unfolded convex_on_def, THEN bspec[where x=y], THEN bspec[where x=z]] by auto
+ thus "dist x (u *\<^sub>R y + v *\<^sub>R z) \<le> e" using real_convex_bound_le[OF yz uv] by auto
+qed
+
+lemma connected_ball:
+ fixes x :: "'a::real_normed_vector"
+ shows "connected (ball x e)"
+ using convex_connected convex_ball by auto
+
+lemma connected_cball:
+ fixes x :: "'a::real_normed_vector"
+ shows "connected(cball x e)"
+ using convex_connected convex_cball by auto
+
+subsection {* Convex hull. *}
+
+lemma convex_convex_hull: "convex(convex hull s)"
+ unfolding hull_def using convex_Inter[of "{t\<in>convex. s\<subseteq>t}"]
+ unfolding mem_def by auto
+
+lemma convex_hull_eq: "(convex hull s = s) \<longleftrightarrow> convex s" apply(rule hull_eq[unfolded mem_def])
+ using convex_Inter[unfolded Ball_def mem_def] by auto
+
+lemma bounded_convex_hull:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "bounded s" shows "bounded(convex hull s)"
+proof- from assms obtain B where B:"\<forall>x\<in>s. norm x \<le> B" unfolding bounded_iff by auto
+ show ?thesis apply(rule bounded_subset[OF bounded_cball, of _ 0 B])
+ unfolding subset_hull[unfolded mem_def, of convex, OF convex_cball]
+ unfolding subset_eq mem_cball dist_norm using B by auto qed
+
+lemma finite_imp_bounded_convex_hull:
+ fixes s :: "'a::real_normed_vector set"
+ shows "finite s \<Longrightarrow> bounded(convex hull s)"
+ using bounded_convex_hull finite_imp_bounded by auto
+
+subsection {* Stepping theorems for convex hulls of finite sets. *}
+
+lemma convex_hull_empty[simp]: "convex hull {} = {}"
+ apply(rule hull_unique) unfolding mem_def by auto
+
+lemma convex_hull_singleton[simp]: "convex hull {a} = {a}"
+ apply(rule hull_unique) unfolding mem_def by auto
+
+lemma convex_hull_insert:
+ fixes s :: "'a::real_vector set"
+ assumes "s \<noteq> {}"
+ shows "convex hull (insert a s) = {x. \<exists>u\<ge>0. \<exists>v\<ge>0. \<exists>b. (u + v = 1) \<and>
+ b \<in> (convex hull s) \<and> (x = u *\<^sub>R a + v *\<^sub>R b)}" (is "?xyz = ?hull")
+ apply(rule,rule hull_minimal,rule) unfolding mem_def[of _ convex] and insert_iff prefer 3 apply rule proof-
+ fix x assume x:"x = a \<or> x \<in> s"
+ thus "x\<in>?hull" apply rule unfolding mem_Collect_eq apply(rule_tac x=1 in exI) defer
+ apply(rule_tac x=0 in exI) using assms hull_subset[of s convex] by auto
+next
+ fix x assume "x\<in>?hull"
+ then obtain u v b where obt:"u\<ge>0" "v\<ge>0" "u + v = 1" "b \<in> convex hull s" "x = u *\<^sub>R a + v *\<^sub>R b" by auto
+ have "a\<in>convex hull insert a s" "b\<in>convex hull insert a s"
+ using hull_mono[of s "insert a s" convex] hull_mono[of "{a}" "insert a s" convex] and obt(4) by auto
+ thus "x\<in> convex hull insert a s" unfolding obt(5) using convex_convex_hull[of "insert a s", unfolded convex_def]
+ apply(erule_tac x=a in ballE) apply(erule_tac x=b in ballE) apply(erule_tac x=u in allE) using obt by auto
+next
+ show "convex ?hull" unfolding convex_def apply(rule,rule,rule,rule,rule,rule,rule) proof-
+ fix x y u v assume as:"(0::real) \<le> u" "0 \<le> v" "u + v = 1" "x\<in>?hull" "y\<in>?hull"
+ from as(4) obtain u1 v1 b1 where obt1:"u1\<ge>0" "v1\<ge>0" "u1 + v1 = 1" "b1 \<in> convex hull s" "x = u1 *\<^sub>R a + v1 *\<^sub>R b1" by auto
+ from as(5) obtain u2 v2 b2 where obt2:"u2\<ge>0" "v2\<ge>0" "u2 + v2 = 1" "b2 \<in> convex hull s" "y = u2 *\<^sub>R a + v2 *\<^sub>R b2" by auto
+ have *:"\<And>(x::'a) s1 s2. x - s1 *\<^sub>R x - s2 *\<^sub>R x = ((1::real) - (s1 + s2)) *\<^sub>R x" by (auto simp add: algebra_simps)
+ have "\<exists>b \<in> convex hull s. u *\<^sub>R x + v *\<^sub>R y = (u * u1) *\<^sub>R a + (v * u2) *\<^sub>R a + (b - (u * u1) *\<^sub>R b - (v * u2) *\<^sub>R b)"
+ proof(cases "u * v1 + v * v2 = 0")
+ have *:"\<And>(x::'a) s1 s2. x - s1 *\<^sub>R x - s2 *\<^sub>R x = ((1::real) - (s1 + s2)) *\<^sub>R x" by (auto simp add: algebra_simps)
+ case True hence **:"u * v1 = 0" "v * v2 = 0" apply- apply(rule_tac [!] ccontr)
+ using mult_nonneg_nonneg[OF `u\<ge>0` `v1\<ge>0`] mult_nonneg_nonneg[OF `v\<ge>0` `v2\<ge>0`] by auto
+ hence "u * u1 + v * u2 = 1" using as(3) obt1(3) obt2(3) by auto
+ thus ?thesis unfolding obt1(5) obt2(5) * using assms hull_subset[of s convex] by(auto simp add: ** scaleR_right_distrib)
+ next
+ have "1 - (u * u1 + v * u2) = (u + v) - (u * u1 + v * u2)" using as(3) obt1(3) obt2(3) by (auto simp add: field_simps)
+ also have "\<dots> = u * (v1 + u1 - u1) + v * (v2 + u2 - u2)" using as(3) obt1(3) obt2(3) by (auto simp add: field_simps)
+ also have "\<dots> = u * v1 + v * v2" by simp finally have **:"1 - (u * u1 + v * u2) = u * v1 + v * v2" by auto
+ case False have "0 \<le> u * v1 + v * v2" "0 \<le> u * v1" "0 \<le> u * v1 + v * v2" "0 \<le> v * v2" apply -
+ apply(rule add_nonneg_nonneg) prefer 4 apply(rule add_nonneg_nonneg) apply(rule_tac [!] mult_nonneg_nonneg)
+ using as(1,2) obt1(1,2) obt2(1,2) by auto
+ thus ?thesis unfolding obt1(5) obt2(5) unfolding * and ** using False
+ apply(rule_tac x="((u * v1) / (u * v1 + v * v2)) *\<^sub>R b1 + ((v * v2) / (u * v1 + v * v2)) *\<^sub>R b2" in bexI) defer
+ apply(rule convex_convex_hull[of s, unfolded convex_def, rule_format]) using obt1(4) obt2(4)
+ unfolding add_divide_distrib[THEN sym] and real_0_le_divide_iff
+ by (auto simp add: scaleR_left_distrib scaleR_right_distrib)
+ qed note * = this
+ have u1:"u1 \<le> 1" apply(rule ccontr) unfolding obt1(3)[THEN sym] and not_le using obt1(2) by auto
+ have u2:"u2 \<le> 1" apply(rule ccontr) unfolding obt2(3)[THEN sym] and not_le using obt2(2) by auto
+ have "u1 * u + u2 * v \<le> (max u1 u2) * u + (max u1 u2) * v" apply(rule add_mono)
+ apply(rule_tac [!] mult_right_mono) using as(1,2) obt1(1,2) obt2(1,2) by auto
+ also have "\<dots> \<le> 1" unfolding mult.add_right[THEN sym] and as(3) using u1 u2 by auto
+ finally
+ show "u *\<^sub>R x + v *\<^sub>R y \<in> ?hull" unfolding mem_Collect_eq apply(rule_tac x="u * u1 + v * u2" in exI)
+ apply(rule conjI) defer apply(rule_tac x="1 - u * u1 - v * u2" in exI) unfolding Bex_def
+ using as(1,2) obt1(1,2) obt2(1,2) * by(auto intro!: mult_nonneg_nonneg add_nonneg_nonneg simp add: algebra_simps)
+ qed
+qed
+
+
+subsection {* Explicit expression for convex hull. *}
+
+lemma convex_hull_indexed:
+ fixes s :: "'a::real_vector set"
+ shows "convex hull s = {y. \<exists>k u x. (\<forall>i\<in>{1::nat .. k}. 0 \<le> u i \<and> x i \<in> s) \<and>
+ (setsum u {1..k} = 1) \<and>
+ (setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} = y)}" (is "?xyz = ?hull")
+ apply(rule hull_unique) unfolding mem_def[of _ convex] apply(rule) defer
+ apply(subst convex_def) apply(rule,rule,rule,rule,rule,rule,rule)
+proof-
+ fix x assume "x\<in>s"
+ thus "x \<in> ?hull" unfolding mem_Collect_eq apply(rule_tac x=1 in exI, rule_tac x="\<lambda>x. 1" in exI) by auto
+next
+ fix t assume as:"s \<subseteq> t" "convex t"
+ show "?hull \<subseteq> t" apply(rule) unfolding mem_Collect_eq apply(erule exE | erule conjE)+ proof-
+ fix x k u y assume assm:"\<forall>i\<in>{1::nat..k}. 0 \<le> u i \<and> y i \<in> s" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R y i) = x"
+ show "x\<in>t" unfolding assm(3)[THEN sym] apply(rule as(2)[unfolded convex, rule_format])
+ using assm(1,2) as(1) by auto qed
+next
+ fix x y u v assume uv:"0\<le>u" "0\<le>v" "u+v=(1::real)" and xy:"x\<in>?hull" "y\<in>?hull"
+ from xy obtain k1 u1 x1 where x:"\<forall>i\<in>{1::nat..k1}. 0\<le>u1 i \<and> x1 i \<in> s" "setsum u1 {Suc 0..k1} = 1" "(\<Sum>i = Suc 0..k1. u1 i *\<^sub>R x1 i) = x" by auto
+ from xy obtain k2 u2 x2 where y:"\<forall>i\<in>{1::nat..k2}. 0\<le>u2 i \<and> x2 i \<in> s" "setsum u2 {Suc 0..k2} = 1" "(\<Sum>i = Suc 0..k2. u2 i *\<^sub>R x2 i) = y" by auto
+ have *:"\<And>P (x1::'a) x2 s1 s2 i.(if P i then s1 else s2) *\<^sub>R (if P i then x1 else x2) = (if P i then s1 *\<^sub>R x1 else s2 *\<^sub>R x2)"
+ "{1..k1 + k2} \<inter> {1..k1} = {1..k1}" "{1..k1 + k2} \<inter> - {1..k1} = (\<lambda>i. i + k1) ` {1..k2}"
+ prefer 3 apply(rule,rule) unfolding image_iff apply(rule_tac x="x - k1" in bexI) by(auto simp add: not_le)
+ have inj:"inj_on (\<lambda>i. i + k1) {1..k2}" unfolding inj_on_def by auto
+ show "u *\<^sub>R x + v *\<^sub>R y \<in> ?hull" apply(rule)
+ apply(rule_tac x="k1 + k2" in exI, rule_tac x="\<lambda>i. if i \<in> {1..k1} then u * u1 i else v * u2 (i - k1)" in exI)
+ apply(rule_tac x="\<lambda>i. if i \<in> {1..k1} then x1 i else x2 (i - k1)" in exI) apply(rule,rule) defer apply(rule)
+ unfolding * and setsum_cases[OF finite_atLeastAtMost[of 1 "k1 + k2"]] and setsum_reindex[OF inj] and o_def
+ unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] setsum_right_distrib[THEN sym] proof-
+ fix i assume i:"i \<in> {1..k1+k2}"
+ show "0 \<le> (if i \<in> {1..k1} then u * u1 i else v * u2 (i - k1)) \<and> (if i \<in> {1..k1} then x1 i else x2 (i - k1)) \<in> s"
+ proof(cases "i\<in>{1..k1}")
+ case True thus ?thesis using mult_nonneg_nonneg[of u "u1 i"] and uv(1) x(1)[THEN bspec[where x=i]] by auto
+ next def j \<equiv> "i - k1"
+ case False with i have "j \<in> {1..k2}" unfolding j_def by auto
+ thus ?thesis unfolding j_def[symmetric] using False
+ using mult_nonneg_nonneg[of v "u2 j"] and uv(2) y(1)[THEN bspec[where x=j]] by auto qed
+ qed(auto simp add: not_le x(2,3) y(2,3) uv(3))
+qed
+
+lemma convex_hull_finite:
+ fixes s :: "'a::real_vector set"
+ assumes "finite s"
+ shows "convex hull s = {y. \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and>
+ setsum u s = 1 \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y}" (is "?HULL = ?set")
+proof(rule hull_unique, auto simp add: mem_def[of _ convex] convex_def[of ?set])
+ fix x assume "x\<in>s" thus " \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>x\<in>s. u x *\<^sub>R x) = x"
+ apply(rule_tac x="\<lambda>y. if x=y then 1 else 0" in exI) apply auto
+ unfolding setsum_delta'[OF assms] and setsum_delta''[OF assms] by auto
+next
+ fix u v ::real assume uv:"0 \<le> u" "0 \<le> v" "u + v = 1"
+ fix ux assume ux:"\<forall>x\<in>s. 0 \<le> ux x" "setsum ux s = (1::real)"
+ fix uy assume uy:"\<forall>x\<in>s. 0 \<le> uy x" "setsum uy s = (1::real)"
+ { fix x assume "x\<in>s"
+ hence "0 \<le> u * ux x + v * uy x" using ux(1)[THEN bspec[where x=x]] uy(1)[THEN bspec[where x=x]] and uv(1,2)
+ by (auto, metis add_nonneg_nonneg mult_nonneg_nonneg uv(1) uv(2)) }
+ moreover have "(\<Sum>x\<in>s. u * ux x + v * uy x) = 1"
+ unfolding setsum_addf and setsum_right_distrib[THEN sym] and ux(2) uy(2) using uv(3) by auto
+ moreover have "(\<Sum>x\<in>s. (u * ux x + v * uy x) *\<^sub>R x) = u *\<^sub>R (\<Sum>x\<in>s. ux x *\<^sub>R x) + v *\<^sub>R (\<Sum>x\<in>s. uy x *\<^sub>R x)"
+ unfolding scaleR_left_distrib and setsum_addf and scaleR_scaleR[THEN sym] and scaleR_right.setsum [symmetric] by auto
+ ultimately show "\<exists>uc. (\<forall>x\<in>s. 0 \<le> uc x) \<and> setsum uc s = 1 \<and> (\<Sum>x\<in>s. uc x *\<^sub>R x) = u *\<^sub>R (\<Sum>x\<in>s. ux x *\<^sub>R x) + v *\<^sub>R (\<Sum>x\<in>s. uy x *\<^sub>R x)"
+ apply(rule_tac x="\<lambda>x. u * ux x + v * uy x" in exI) by auto
+next
+ fix t assume t:"s \<subseteq> t" "convex t"
+ fix u assume u:"\<forall>x\<in>s. 0 \<le> u x" "setsum u s = (1::real)"
+ thus "(\<Sum>x\<in>s. u x *\<^sub>R x) \<in> t" using t(2)[unfolded convex_explicit, THEN spec[where x=s], THEN spec[where x=u]]
+ using assms and t(1) by auto
+qed
+
+subsection {* Another formulation from Lars Schewe. *}
+
+lemma setsum_constant_scaleR:
+ fixes y :: "'a::real_vector"
+ shows "(\<Sum>x\<in>A. y) = of_nat (card A) *\<^sub>R y"
+apply (cases "finite A")
+apply (induct set: finite)
+apply (simp_all add: algebra_simps)
+done
+
+lemma convex_hull_explicit:
+ fixes p :: "'a::real_vector set"
+ shows "convex hull p = {y. \<exists>s u. finite s \<and> s \<subseteq> p \<and>
+ (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}" (is "?lhs = ?rhs")
+proof-
+ { fix x assume "x\<in>?lhs"
+ then obtain k u y where obt:"\<forall>i\<in>{1::nat..k}. 0 \<le> u i \<and> y i \<in> p" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R y i) = x"
+ unfolding convex_hull_indexed by auto
+
+ have fin:"finite {1..k}" by auto
+ have fin':"\<And>v. finite {i \<in> {1..k}. y i = v}" by auto
+ { fix j assume "j\<in>{1..k}"
+ hence "y j \<in> p" "0 \<le> setsum u {i. Suc 0 \<le> i \<and> i \<le> k \<and> y i = y j}"
+ using obt(1)[THEN bspec[where x=j]] and obt(2) apply simp
+ apply(rule setsum_nonneg) using obt(1) by auto }
+ moreover
+ have "(\<Sum>v\<in>y ` {1..k}. setsum u {i \<in> {1..k}. y i = v}) = 1"
+ unfolding setsum_image_gen[OF fin, THEN sym] using obt(2) by auto
+ moreover have "(\<Sum>v\<in>y ` {1..k}. setsum u {i \<in> {1..k}. y i = v} *\<^sub>R v) = x"
+ using setsum_image_gen[OF fin, of "\<lambda>i. u i *\<^sub>R y i" y, THEN sym]
+ unfolding scaleR_left.setsum using obt(3) by auto
+ ultimately have "\<exists>s u. finite s \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = x"
+ apply(rule_tac x="y ` {1..k}" in exI)
+ apply(rule_tac x="\<lambda>v. setsum u {i\<in>{1..k}. y i = v}" in exI) by auto
+ hence "x\<in>?rhs" by auto }
+ moreover
+ { fix y assume "y\<in>?rhs"
+ then obtain s u where obt:"finite s" "s \<subseteq> p" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = y" by auto
+
+ obtain f where f:"inj_on f {1..card s}" "f ` {1..card s} = s" using ex_bij_betw_nat_finite_1[OF obt(1)] unfolding bij_betw_def by auto
+
+ { fix i::nat assume "i\<in>{1..card s}"
+ hence "f i \<in> s" apply(subst f(2)[THEN sym]) by auto
+ hence "0 \<le> u (f i)" "f i \<in> p" using obt(2,3) by auto }
+ moreover have *:"finite {1..card s}" by auto
+ { fix y assume "y\<in>s"
+ then obtain i where "i\<in>{1..card s}" "f i = y" using f using image_iff[of y f "{1..card s}"] by auto
+ hence "{x. Suc 0 \<le> x \<and> x \<le> card s \<and> f x = y} = {i}" apply auto using f(1)[unfolded inj_on_def] apply(erule_tac x=x in ballE) by auto
+ hence "card {x. Suc 0 \<le> x \<and> x \<le> card s \<and> f x = y} = 1" by auto
+ hence "(\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x)) = u y"
+ "(\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x) *\<^sub>R f x) = u y *\<^sub>R y"
+ by (auto simp add: setsum_constant_scaleR) }
+
+ hence "(\<Sum>x = 1..card s. u (f x)) = 1" "(\<Sum>i = 1..card s. u (f i) *\<^sub>R f i) = y"
+ unfolding setsum_image_gen[OF *(1), of "\<lambda>x. u (f x) *\<^sub>R f x" f] and setsum_image_gen[OF *(1), of "\<lambda>x. u (f x)" f]
+ unfolding f using setsum_cong2[of s "\<lambda>y. (\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x) *\<^sub>R f x)" "\<lambda>v. u v *\<^sub>R v"]
+ using setsum_cong2 [of s "\<lambda>y. (\<Sum>x\<in>{x \<in> {1..card s}. f x = y}. u (f x))" u] unfolding obt(4,5) by auto
+
+ ultimately have "\<exists>k u x. (\<forall>i\<in>{1..k}. 0 \<le> u i \<and> x i \<in> p) \<and> setsum u {1..k} = 1 \<and> (\<Sum>i::nat = 1..k. u i *\<^sub>R x i) = y"
+ apply(rule_tac x="card s" in exI) apply(rule_tac x="u \<circ> f" in exI) apply(rule_tac x=f in exI) by fastsimp
+ hence "y \<in> ?lhs" unfolding convex_hull_indexed by auto }
+ ultimately show ?thesis unfolding expand_set_eq by blast
+qed
+
+subsection {* A stepping theorem for that expansion. *}
+
+lemma convex_hull_finite_step:
+ fixes s :: "'a::real_vector set" assumes "finite s"
+ shows "(\<exists>u. (\<forall>x\<in>insert a s. 0 \<le> u x) \<and> setsum u (insert a s) = w \<and> setsum (\<lambda>x. u x *\<^sub>R x) (insert a s) = y)
+ \<longleftrightarrow> (\<exists>v\<ge>0. \<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = w - v \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y - v *\<^sub>R a)" (is "?lhs = ?rhs")
+proof(rule, case_tac[!] "a\<in>s")
+ assume "a\<in>s" hence *:"insert a s = s" by auto
+ assume ?lhs thus ?rhs unfolding * apply(rule_tac x=0 in exI) by auto
+next
+ assume ?lhs then obtain u where u:"\<forall>x\<in>insert a s. 0 \<le> u x" "setsum u (insert a s) = w" "(\<Sum>x\<in>insert a s. u x *\<^sub>R x) = y" by auto
+ assume "a\<notin>s" thus ?rhs apply(rule_tac x="u a" in exI) using u(1)[THEN bspec[where x=a]] apply simp
+ apply(rule_tac x=u in exI) using u[unfolded setsum_clauses(2)[OF assms]] and `a\<notin>s` by auto
+next
+ assume "a\<in>s" hence *:"insert a s = s" by auto
+ have fin:"finite (insert a s)" using assms by auto
+ assume ?rhs then obtain v u where uv:"v\<ge>0" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
+ show ?lhs apply(rule_tac x="\<lambda>x. (if a = x then v else 0) + u x" in exI) unfolding scaleR_left_distrib and setsum_addf and setsum_delta''[OF fin] and setsum_delta'[OF fin]
+ unfolding setsum_clauses(2)[OF assms] using uv and uv(2)[THEN bspec[where x=a]] and `a\<in>s` by auto
+next
+ assume ?rhs then obtain v u where uv:"v\<ge>0" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = w - v" "(\<Sum>x\<in>s. u x *\<^sub>R x) = y - v *\<^sub>R a" by auto
+ moreover assume "a\<notin>s" moreover have "(\<Sum>x\<in>s. if a = x then v else u x) = setsum u s" "(\<Sum>x\<in>s. (if a = x then v else u x) *\<^sub>R x) = (\<Sum>x\<in>s. u x *\<^sub>R x)"
+ apply(rule_tac setsum_cong2) defer apply(rule_tac setsum_cong2) using `a\<notin>s` by auto
+ ultimately show ?lhs apply(rule_tac x="\<lambda>x. if a = x then v else u x" in exI) unfolding setsum_clauses(2)[OF assms] by auto
+qed
+
+subsection {* Hence some special cases. *}
+
+lemma convex_hull_2:
+ "convex hull {a,b} = {u *\<^sub>R a + v *\<^sub>R b | u v. 0 \<le> u \<and> 0 \<le> v \<and> u + v = 1}"
+proof- have *:"\<And>u. (\<forall>x\<in>{a, b}. 0 \<le> u x) \<longleftrightarrow> 0 \<le> u a \<and> 0 \<le> u b" by auto have **:"finite {b}" by auto
+show ?thesis apply(simp add: convex_hull_finite) unfolding convex_hull_finite_step[OF **, of a 1, unfolded * conj_assoc]
+ apply auto apply(rule_tac x=v in exI) apply(rule_tac x="1 - v" in exI) apply simp
+ apply(rule_tac x=u in exI) apply simp apply(rule_tac x="\<lambda>x. v" in exI) by simp qed
+
+lemma convex_hull_2_alt: "convex hull {a,b} = {a + u *\<^sub>R (b - a) | u. 0 \<le> u \<and> u \<le> 1}"
+ unfolding convex_hull_2 unfolding Collect_def
+proof(rule ext) have *:"\<And>x y ::real. x + y = 1 \<longleftrightarrow> x = 1 - y" by auto
+ fix x show "(\<exists>v u. x = v *\<^sub>R a + u *\<^sub>R b \<and> 0 \<le> v \<and> 0 \<le> u \<and> v + u = 1) = (\<exists>u. x = a + u *\<^sub>R (b - a) \<and> 0 \<le> u \<and> u \<le> 1)"
+ unfolding * apply auto apply(rule_tac[!] x=u in exI) by (auto simp add: algebra_simps) qed
+
+lemma convex_hull_3:
+ "convex hull {a,b,c} = { u *\<^sub>R a + v *\<^sub>R b + w *\<^sub>R c | u v w. 0 \<le> u \<and> 0 \<le> v \<and> 0 \<le> w \<and> u + v + w = 1}"
+proof-
+ have fin:"finite {a,b,c}" "finite {b,c}" "finite {c}" by auto
+ have *:"\<And>x y z ::real. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z"
+ "\<And>x y z ::real^'n. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z" by (auto simp add: ring_simps)
+ show ?thesis unfolding convex_hull_finite[OF fin(1)] and Collect_def and convex_hull_finite_step[OF fin(2)] and *
+ unfolding convex_hull_finite_step[OF fin(3)] apply(rule ext) apply simp apply auto
+ apply(rule_tac x=va in exI) apply (rule_tac x="u c" in exI) apply simp
+ apply(rule_tac x="1 - v - w" in exI) apply simp apply(rule_tac x=v in exI) apply simp apply(rule_tac x="\<lambda>x. w" in exI) by simp qed
+
+lemma convex_hull_3_alt:
+ "convex hull {a,b,c} = {a + u *\<^sub>R (b - a) + v *\<^sub>R (c - a) | u v. 0 \<le> u \<and> 0 \<le> v \<and> u + v \<le> 1}"
+proof- have *:"\<And>x y z ::real. x + y + z = 1 \<longleftrightarrow> x = 1 - y - z" by auto
+ show ?thesis unfolding convex_hull_3 apply (auto simp add: *) apply(rule_tac x=v in exI) apply(rule_tac x=w in exI) apply (simp add: algebra_simps)
+ apply(rule_tac x=u in exI) apply(rule_tac x=v in exI) by (simp add: algebra_simps) qed
+
+subsection {* Relations among closure notions and corresponding hulls. *}
+
+text {* TODO: Generalize linear algebra concepts defined in @{text
+Euclidean_Space.thy} so that we can generalize these lemmas. *}
+
+lemma subspace_imp_affine:
+ fixes s :: "(real ^ _) set" shows "subspace s \<Longrightarrow> affine s"
+ unfolding subspace_def affine_def smult_conv_scaleR by auto
+
+lemma affine_imp_convex: "affine s \<Longrightarrow> convex s"
+ unfolding affine_def convex_def by auto
+
+lemma subspace_imp_convex:
+ fixes s :: "(real ^ _) set" shows "subspace s \<Longrightarrow> convex s"
+ using subspace_imp_affine affine_imp_convex by auto
+
+lemma affine_hull_subset_span:
+ fixes s :: "(real ^ _) set" shows "(affine hull s) \<subseteq> (span s)"
+ unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
+ using subspace_imp_affine by auto
+
+lemma convex_hull_subset_span:
+ fixes s :: "(real ^ _) set" shows "(convex hull s) \<subseteq> (span s)"
+ unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
+ using subspace_imp_convex by auto
+
+lemma convex_hull_subset_affine_hull: "(convex hull s) \<subseteq> (affine hull s)"
+ unfolding span_def apply(rule hull_antimono) unfolding subset_eq Ball_def mem_def
+ using affine_imp_convex by auto
+
+lemma affine_dependent_imp_dependent:
+ fixes s :: "(real ^ _) set" shows "affine_dependent s \<Longrightarrow> dependent s"
+ unfolding affine_dependent_def dependent_def
+ using affine_hull_subset_span by auto
+
+lemma dependent_imp_affine_dependent:
+ fixes s :: "(real ^ _) set"
+ assumes "dependent {x - a| x . x \<in> s}" "a \<notin> s"
+ shows "affine_dependent (insert a s)"
+proof-
+ from assms(1)[unfolded dependent_explicit smult_conv_scaleR] obtain S u v
+ where obt:"finite S" "S \<subseteq> {x - a |x. x \<in> s}" "v\<in>S" "u v \<noteq> 0" "(\<Sum>v\<in>S. u v *\<^sub>R v) = 0" by auto
+ def t \<equiv> "(\<lambda>x. x + a) ` S"
+
+ have inj:"inj_on (\<lambda>x. x + a) S" unfolding inj_on_def by auto
+ have "0\<notin>S" using obt(2) assms(2) unfolding subset_eq by auto
+ have fin:"finite t" and "t\<subseteq>s" unfolding t_def using obt(1,2) by auto
+
+ hence "finite (insert a t)" and "insert a t \<subseteq> insert a s" by auto
+ moreover have *:"\<And>P Q. (\<Sum>x\<in>t. (if x = a then P x else Q x)) = (\<Sum>x\<in>t. Q x)"
+ apply(rule setsum_cong2) using `a\<notin>s` `t\<subseteq>s` by auto
+ have "(\<Sum>x\<in>insert a t. if x = a then - (\<Sum>x\<in>t. u (x - a)) else u (x - a)) = 0"
+ unfolding setsum_clauses(2)[OF fin] using `a\<notin>s` `t\<subseteq>s` apply auto unfolding * by auto
+ moreover have "\<exists>v\<in>insert a t. (if v = a then - (\<Sum>x\<in>t. u (x - a)) else u (v - a)) \<noteq> 0"
+ apply(rule_tac x="v + a" in bexI) using obt(3,4) and `0\<notin>S` unfolding t_def by auto
+ moreover have *:"\<And>P Q. (\<Sum>x\<in>t. (if x = a then P x else Q x) *\<^sub>R x) = (\<Sum>x\<in>t. Q x *\<^sub>R x)"
+ apply(rule setsum_cong2) using `a\<notin>s` `t\<subseteq>s` by auto
+ have "(\<Sum>x\<in>t. u (x - a)) *\<^sub>R a = (\<Sum>v\<in>t. u (v - a) *\<^sub>R v)"
+ unfolding scaleR_left.setsum unfolding t_def and setsum_reindex[OF inj] and o_def
+ using obt(5) by (auto simp add: setsum_addf scaleR_right_distrib)
+ hence "(\<Sum>v\<in>insert a t. (if v = a then - (\<Sum>x\<in>t. u (x - a)) else u (v - a)) *\<^sub>R v) = 0"
+ unfolding setsum_clauses(2)[OF fin] using `a\<notin>s` `t\<subseteq>s` by (auto simp add: * vector_smult_lneg)
+ ultimately show ?thesis unfolding affine_dependent_explicit
+ apply(rule_tac x="insert a t" in exI) by auto
+qed
+
+lemma convex_cone:
+ "convex s \<and> cone s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. (x + y) \<in> s) \<and> (\<forall>x\<in>s. \<forall>c\<ge>0. (c *\<^sub>R x) \<in> s)" (is "?lhs = ?rhs")
+proof-
+ { fix x y assume "x\<in>s" "y\<in>s" and ?lhs
+ hence "2 *\<^sub>R x \<in>s" "2 *\<^sub>R y \<in> s" unfolding cone_def by auto
+ hence "x + y \<in> s" using `?lhs`[unfolded convex_def, THEN conjunct1]
+ apply(erule_tac x="2*\<^sub>R x" in ballE) apply(erule_tac x="2*\<^sub>R y" in ballE)
+ apply(erule_tac x="1/2" in allE) apply simp apply(erule_tac x="1/2" in allE) by auto }
+ thus ?thesis unfolding convex_def cone_def by auto
+qed
+
+lemma affine_dependent_biggerset: fixes s::"(real^'n::finite) set"
+ assumes "finite s" "card s \<ge> CARD('n) + 2"
+ shows "affine_dependent s"
+proof-
+ have "s\<noteq>{}" using assms by auto then obtain a where "a\<in>s" by auto
+ have *:"{x - a |x. x \<in> s - {a}} = (\<lambda>x. x - a) ` (s - {a})" by auto
+ have "card {x - a |x. x \<in> s - {a}} = card (s - {a})" unfolding *
+ apply(rule card_image) unfolding inj_on_def by auto
+ also have "\<dots> > CARD('n)" using assms(2)
+ unfolding card_Diff_singleton[OF assms(1) `a\<in>s`] by auto
+ finally show ?thesis apply(subst insert_Diff[OF `a\<in>s`, THEN sym])
+ apply(rule dependent_imp_affine_dependent)
+ apply(rule dependent_biggerset) by auto qed
+
+lemma affine_dependent_biggerset_general:
+ assumes "finite (s::(real^'n::finite) set)" "card s \<ge> dim s + 2"
+ shows "affine_dependent s"
+proof-
+ from assms(2) have "s \<noteq> {}" by auto
+ then obtain a where "a\<in>s" by auto
+ have *:"{x - a |x. x \<in> s - {a}} = (\<lambda>x. x - a) ` (s - {a})" by auto
+ have **:"card {x - a |x. x \<in> s - {a}} = card (s - {a})" unfolding *
+ apply(rule card_image) unfolding inj_on_def by auto
+ have "dim {x - a |x. x \<in> s - {a}} \<le> dim s"
+ apply(rule subset_le_dim) unfolding subset_eq
+ using `a\<in>s` by (auto simp add:span_superset span_sub)
+ also have "\<dots> < dim s + 1" by auto
+ also have "\<dots> \<le> card (s - {a})" using assms
+ using card_Diff_singleton[OF assms(1) `a\<in>s`] by auto
+ finally show ?thesis apply(subst insert_Diff[OF `a\<in>s`, THEN sym])
+ apply(rule dependent_imp_affine_dependent) apply(rule dependent_biggerset_general) unfolding ** by auto qed
+
+subsection {* Caratheodory's theorem. *}
+
+lemma convex_hull_caratheodory: fixes p::"(real^'n::finite) set"
+ shows "convex hull p = {y. \<exists>s u. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and>
+ (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> setsum (\<lambda>v. u v *\<^sub>R v) s = y}"
+ unfolding convex_hull_explicit expand_set_eq mem_Collect_eq
+proof(rule,rule)
+ fix y let ?P = "\<lambda>n. \<exists>s u. finite s \<and> card s = n \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
+ assume "\<exists>s u. finite s \<and> s \<subseteq> p \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y"
+ then obtain N where "?P N" by auto
+ hence "\<exists>n\<le>N. (\<forall>k<n. \<not> ?P k) \<and> ?P n" apply(rule_tac ex_least_nat_le) by auto
+ then obtain n where "?P n" and smallest:"\<forall>k<n. \<not> ?P k" by blast
+ then obtain s u where obt:"finite s" "card s = n" "s\<subseteq>p" "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = y" by auto
+
+ have "card s \<le> CARD('n) + 1" proof(rule ccontr, simp only: not_le)
+ assume "CARD('n) + 1 < card s"
+ hence "affine_dependent s" using affine_dependent_biggerset[OF obt(1)] by auto
+ then obtain w v where wv:"setsum w s = 0" "v\<in>s" "w v \<noteq> 0" "(\<Sum>v\<in>s. w v *\<^sub>R v) = 0"
+ using affine_dependent_explicit_finite[OF obt(1)] by auto
+ def i \<equiv> "(\<lambda>v. (u v) / (- w v)) ` {v\<in>s. w v < 0}" def t \<equiv> "Min i"
+ have "\<exists>x\<in>s. w x < 0" proof(rule ccontr, simp add: not_less)
+ assume as:"\<forall>x\<in>s. 0 \<le> w x"
+ hence "setsum w (s - {v}) \<ge> 0" apply(rule_tac setsum_nonneg) by auto
+ hence "setsum w s > 0" unfolding setsum_diff1'[OF obt(1) `v\<in>s`]
+ using as[THEN bspec[where x=v]] and `v\<in>s` using `w v \<noteq> 0` by auto
+ thus False using wv(1) by auto
+ qed hence "i\<noteq>{}" unfolding i_def by auto
+
+ hence "t \<ge> 0" using Min_ge_iff[of i 0 ] and obt(1) unfolding t_def i_def
+ using obt(4)[unfolded le_less] apply auto unfolding divide_le_0_iff by auto
+ have t:"\<forall>v\<in>s. u v + t * w v \<ge> 0" proof
+ fix v assume "v\<in>s" hence v:"0\<le>u v" using obt(4)[THEN bspec[where x=v]] by auto
+ show"0 \<le> u v + t * w v" proof(cases "w v < 0")
+ case False thus ?thesis apply(rule_tac add_nonneg_nonneg)
+ using v apply simp apply(rule mult_nonneg_nonneg) using `t\<ge>0` by auto next
+ case True hence "t \<le> u v / (- w v)" using `v\<in>s`
+ unfolding t_def i_def apply(rule_tac Min_le) using obt(1) by auto
+ thus ?thesis unfolding real_0_le_add_iff
+ using pos_le_divide_eq[OF True[unfolded neg_0_less_iff_less[THEN sym]]] by auto
+ qed qed
+
+ obtain a where "a\<in>s" and "t = (\<lambda>v. (u v) / (- w v)) a" and "w a < 0"
+ using Min_in[OF _ `i\<noteq>{}`] and obt(1) unfolding i_def t_def by auto
+ hence a:"a\<in>s" "u a + t * w a = 0" by auto
+ have *:"\<And>f. setsum f (s - {a}) = setsum f s - ((f a)::'a::ring)" unfolding setsum_diff1'[OF obt(1) `a\<in>s`] by auto
+ have "(\<Sum>v\<in>s. u v + t * w v) = 1"
+ unfolding setsum_addf wv(1) setsum_right_distrib[THEN sym] obt(5) by auto
+ moreover have "(\<Sum>v\<in>s. u v *\<^sub>R v + (t * w v) *\<^sub>R v) - (u a *\<^sub>R a + (t * w a) *\<^sub>R a) = y"
+ unfolding setsum_addf obt(6) scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] wv(4)
+ using a(2) [THEN eq_neg_iff_add_eq_0 [THEN iffD2]]
+ by (simp add: vector_smult_lneg)
+ ultimately have "?P (n - 1)" apply(rule_tac x="(s - {a})" in exI)
+ apply(rule_tac x="\<lambda>v. u v + t * w v" in exI) using obt(1-3) and t and a by (auto simp add: * scaleR_left_distrib)
+ thus False using smallest[THEN spec[where x="n - 1"]] by auto qed
+ thus "\<exists>s u. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1
+ \<and> (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = y" using obt by auto
+qed auto
+
+lemma caratheodory:
+ "convex hull p = {x::real^'n::finite. \<exists>s. finite s \<and> s \<subseteq> p \<and>
+ card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s}"
+ unfolding expand_set_eq apply(rule, rule) unfolding mem_Collect_eq proof-
+ fix x assume "x \<in> convex hull p"
+ then obtain s u where "finite s" "s \<subseteq> p" "card s \<le> CARD('n) + 1"
+ "\<forall>x\<in>s. 0 \<le> u x" "setsum u s = 1" "(\<Sum>v\<in>s. u v *\<^sub>R v) = x"unfolding convex_hull_caratheodory by auto
+ thus "\<exists>s. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s"
+ apply(rule_tac x=s in exI) using hull_subset[of s convex]
+ using convex_convex_hull[unfolded convex_explicit, of s, THEN spec[where x=s], THEN spec[where x=u]] by auto
+next
+ fix x assume "\<exists>s. finite s \<and> s \<subseteq> p \<and> card s \<le> CARD('n) + 1 \<and> x \<in> convex hull s"
+ then obtain s where "finite s" "s \<subseteq> p" "card s \<le> CARD('n) + 1" "x \<in> convex hull s" by auto
+ thus "x \<in> convex hull p" using hull_mono[OF `s\<subseteq>p`] by auto
+qed
+
+subsection {* Openness and compactness are preserved by convex hull operation. *}
+
+lemma open_convex_hull:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "open s"
+ shows "open(convex hull s)"
+ unfolding open_contains_cball convex_hull_explicit unfolding mem_Collect_eq ball_simps(10)
+proof(rule, rule) fix a
+ assume "\<exists>sa u. finite sa \<and> sa \<subseteq> s \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = a"
+ then obtain t u where obt:"finite t" "t\<subseteq>s" "\<forall>x\<in>t. 0 \<le> u x" "setsum u t = 1" "(\<Sum>v\<in>t. u v *\<^sub>R v) = a" by auto
+
+ from assms[unfolded open_contains_cball] obtain b where b:"\<forall>x\<in>s. 0 < b x \<and> cball x (b x) \<subseteq> s"
+ using bchoice[of s "\<lambda>x e. e>0 \<and> cball x e \<subseteq> s"] by auto
+ have "b ` t\<noteq>{}" unfolding i_def using obt by auto def i \<equiv> "b ` t"
+
+ show "\<exists>e>0. cball a e \<subseteq> {y. \<exists>sa u. finite sa \<and> sa \<subseteq> s \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y}"
+ apply(rule_tac x="Min i" in exI) unfolding subset_eq apply rule defer apply rule unfolding mem_Collect_eq
+ proof-
+ show "0 < Min i" unfolding i_def and Min_gr_iff[OF finite_imageI[OF obt(1)] `b \` t\<noteq>{}`]
+ using b apply simp apply rule apply(erule_tac x=x in ballE) using `t\<subseteq>s` by auto
+ next fix y assume "y \<in> cball a (Min i)"
+ hence y:"norm (a - y) \<le> Min i" unfolding dist_norm[THEN sym] by auto
+ { fix x assume "x\<in>t"
+ hence "Min i \<le> b x" unfolding i_def apply(rule_tac Min_le) using obt(1) by auto
+ hence "x + (y - a) \<in> cball x (b x)" using y unfolding mem_cball dist_norm by auto
+ moreover from `x\<in>t` have "x\<in>s" using obt(2) by auto
+ ultimately have "x + (y - a) \<in> s" using y and b[THEN bspec[where x=x]] unfolding subset_eq by auto }
+ moreover
+ have *:"inj_on (\<lambda>v. v + (y - a)) t" unfolding inj_on_def by auto
+ have "(\<Sum>v\<in>(\<lambda>v. v + (y - a)) ` t. u (v - (y - a))) = 1"
+ unfolding setsum_reindex[OF *] o_def using obt(4) by auto
+ moreover have "(\<Sum>v\<in>(\<lambda>v. v + (y - a)) ` t. u (v - (y - a)) *\<^sub>R v) = y"
+ unfolding setsum_reindex[OF *] o_def using obt(4,5)
+ by (simp add: setsum_addf setsum_subtractf scaleR_left.setsum[THEN sym] scaleR_right_distrib)
+ ultimately show "\<exists>sa u. finite sa \<and> (\<forall>x\<in>sa. x \<in> s) \<and> (\<forall>x\<in>sa. 0 \<le> u x) \<and> setsum u sa = 1 \<and> (\<Sum>v\<in>sa. u v *\<^sub>R v) = y"
+ apply(rule_tac x="(\<lambda>v. v + (y - a)) ` t" in exI) apply(rule_tac x="\<lambda>v. u (v - (y - a))" in exI)
+ using obt(1, 3) by auto
+ qed
+qed
+
+lemma open_dest_vec1_vimage: "open S \<Longrightarrow> open (dest_vec1 -` S)"
+unfolding open_vector_def all_1
+by (auto simp add: dest_vec1_def)
+
+lemma tendsto_dest_vec1 [tendsto_intros]:
+ "(f ---> l) net \<Longrightarrow> ((\<lambda>x. dest_vec1 (f x)) ---> dest_vec1 l) net"
+ unfolding tendsto_def
+ apply clarify
+ apply (drule_tac x="dest_vec1 -` S" in spec)
+ apply (simp add: open_dest_vec1_vimage)
+ done
+
+lemma continuous_dest_vec1: "continuous net f \<Longrightarrow> continuous net (\<lambda>x. dest_vec1 (f x))"
+ unfolding continuous_def by (rule tendsto_dest_vec1)
+
+(* TODO: move *)
+lemma compact_real_interval:
+ fixes a b :: real shows "compact {a..b}"
+proof -
+ have "continuous_on {vec1 a .. vec1 b} dest_vec1"
+ unfolding continuous_on
+ by (simp add: tendsto_dest_vec1 Lim_at_within Lim_ident_at)
+ moreover have "compact {vec1 a .. vec1 b}" by (rule compact_interval)
+ ultimately have "compact (dest_vec1 ` {vec1 a .. vec1 b})"
+ by (rule compact_continuous_image)
+ also have "dest_vec1 ` {vec1 a .. vec1 b} = {a..b}"
+ by (auto simp add: image_def Bex_def exists_vec1)
+ finally show ?thesis .
+qed
+
+lemma compact_convex_combinations:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "compact s" "compact t"
+ shows "compact { (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u. 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> t}"
+proof-
+ let ?X = "{0..1} \<times> s \<times> t"
+ let ?h = "(\<lambda>z. (1 - fst z) *\<^sub>R fst (snd z) + fst z *\<^sub>R snd (snd z))"
+ have *:"{ (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u. 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> t} = ?h ` ?X"
+ apply(rule set_ext) unfolding image_iff mem_Collect_eq
+ apply rule apply auto
+ apply (rule_tac x=u in rev_bexI, simp)
+ apply (erule rev_bexI, erule rev_bexI, simp)
+ by auto
+ have "continuous_on ({0..1} \<times> s \<times> t)
+ (\<lambda>z. (1 - fst z) *\<^sub>R fst (snd z) + fst z *\<^sub>R snd (snd z))"
+ unfolding continuous_on by (rule ballI) (intro tendsto_intros)
+ thus ?thesis unfolding *
+ apply (rule compact_continuous_image)
+ apply (intro compact_Times compact_real_interval assms)
+ done
+qed
+
+lemma compact_convex_hull: fixes s::"(real^'n::finite) set"
+ assumes "compact s" shows "compact(convex hull s)"
+proof(cases "s={}")
+ case True thus ?thesis using compact_empty by simp
+next
+ case False then obtain w where "w\<in>s" by auto
+ show ?thesis unfolding caratheodory[of s]
+ proof(induct "CARD('n) + 1")
+ have *:"{x.\<exists>sa. finite sa \<and> sa \<subseteq> s \<and> card sa \<le> 0 \<and> x \<in> convex hull sa} = {}"
+ using compact_empty by (auto simp add: convex_hull_empty)
+ case 0 thus ?case unfolding * by simp
+ next
+ case (Suc n)
+ show ?case proof(cases "n=0")
+ case True have "{x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t} = s"
+ unfolding expand_set_eq and mem_Collect_eq proof(rule, rule)
+ fix x assume "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
+ then obtain t where t:"finite t" "t \<subseteq> s" "card t \<le> Suc n" "x \<in> convex hull t" by auto
+ show "x\<in>s" proof(cases "card t = 0")
+ case True thus ?thesis using t(4) unfolding card_0_eq[OF t(1)] by(simp add: convex_hull_empty)
+ next
+ case False hence "card t = Suc 0" using t(3) `n=0` by auto
+ then obtain a where "t = {a}" unfolding card_Suc_eq by auto
+ thus ?thesis using t(2,4) by (simp add: convex_hull_singleton)
+ qed
+ next
+ fix x assume "x\<in>s"
+ thus "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
+ apply(rule_tac x="{x}" in exI) unfolding convex_hull_singleton by auto
+ qed thus ?thesis using assms by simp
+ next
+ case False have "{x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t} =
+ { (1 - u) *\<^sub>R x + u *\<^sub>R y | x y u.
+ 0 \<le> u \<and> u \<le> 1 \<and> x \<in> s \<and> y \<in> {x. \<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> x \<in> convex hull t}}"
+ unfolding expand_set_eq and mem_Collect_eq proof(rule,rule)
+ fix x assume "\<exists>u v c. x = (1 - c) *\<^sub>R u + c *\<^sub>R v \<and>
+ 0 \<le> c \<and> c \<le> 1 \<and> u \<in> s \<and> (\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> v \<in> convex hull t)"
+ then obtain u v c t where obt:"x = (1 - c) *\<^sub>R u + c *\<^sub>R v"
+ "0 \<le> c \<and> c \<le> 1" "u \<in> s" "finite t" "t \<subseteq> s" "card t \<le> n" "v \<in> convex hull t" by auto
+ moreover have "(1 - c) *\<^sub>R u + c *\<^sub>R v \<in> convex hull insert u t"
+ apply(rule mem_convex) using obt(2) and convex_convex_hull and hull_subset[of "insert u t" convex]
+ using obt(7) and hull_mono[of t "insert u t"] by auto
+ ultimately show "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
+ apply(rule_tac x="insert u t" in exI) by (auto simp add: card_insert_if)
+ next
+ fix x assume "\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> Suc n \<and> x \<in> convex hull t"
+ then obtain t where t:"finite t" "t \<subseteq> s" "card t \<le> Suc n" "x \<in> convex hull t" by auto
+ let ?P = "\<exists>u v c. x = (1 - c) *\<^sub>R u + c *\<^sub>R v \<and>
+ 0 \<le> c \<and> c \<le> 1 \<and> u \<in> s \<and> (\<exists>t. finite t \<and> t \<subseteq> s \<and> card t \<le> n \<and> v \<in> convex hull t)"
+ show ?P proof(cases "card t = Suc n")
+ case False hence "card t \<le> n" using t(3) by auto
+ thus ?P apply(rule_tac x=w in exI, rule_tac x=x in exI, rule_tac x=1 in exI) using `w\<in>s` and t
+ by(auto intro!: exI[where x=t])
+ next
+ case True then obtain a u where au:"t = insert a u" "a\<notin>u" apply(drule_tac card_eq_SucD) by auto
+ show ?P proof(cases "u={}")
+ case True hence "x=a" using t(4)[unfolded au] by auto
+ show ?P unfolding `x=a` apply(rule_tac x=a in exI, rule_tac x=a in exI, rule_tac x=1 in exI)
+ using t and `n\<noteq>0` unfolding au by(auto intro!: exI[where x="{a}"] simp add: convex_hull_singleton)
+ next
+ case False obtain ux vx b where obt:"ux\<ge>0" "vx\<ge>0" "ux + vx = 1" "b \<in> convex hull u" "x = ux *\<^sub>R a + vx *\<^sub>R b"
+ using t(4)[unfolded au convex_hull_insert[OF False]] by auto
+ have *:"1 - vx = ux" using obt(3) by auto
+ show ?P apply(rule_tac x=a in exI, rule_tac x=b in exI, rule_tac x=vx in exI)
+ using obt and t(1-3) unfolding au and * using card_insert_disjoint[OF _ au(2)]
+ by(auto intro!: exI[where x=u])
+ qed
+ qed
+ qed
+ thus ?thesis using compact_convex_combinations[OF assms Suc] by simp
+ qed
+ qed
+qed
+
+lemma finite_imp_compact_convex_hull:
+ fixes s :: "(real ^ _) set"
+ shows "finite s \<Longrightarrow> compact(convex hull s)"
+ apply(drule finite_imp_compact, drule compact_convex_hull) by assumption
+
+subsection {* Extremal points of a simplex are some vertices. *}
+
+lemma dist_increases_online:
+ fixes a b d :: "'a::real_inner"
+ assumes "d \<noteq> 0"
+ shows "dist a (b + d) > dist a b \<or> dist a (b - d) > dist a b"
+proof(cases "inner a d - inner b d > 0")
+ case True hence "0 < inner d d + (inner a d * 2 - inner b d * 2)"
+ apply(rule_tac add_pos_pos) using assms by auto
+ thus ?thesis apply(rule_tac disjI2) unfolding dist_norm and norm_eq_sqrt_inner and real_sqrt_less_iff
+ by (simp add: algebra_simps inner_commute)
+next
+ case False hence "0 < inner d d + (inner b d * 2 - inner a d * 2)"
+ apply(rule_tac add_pos_nonneg) using assms by auto
+ thus ?thesis apply(rule_tac disjI1) unfolding dist_norm and norm_eq_sqrt_inner and real_sqrt_less_iff
+ by (simp add: algebra_simps inner_commute)
+qed
+
+lemma norm_increases_online:
+ fixes d :: "'a::real_inner"
+ shows "d \<noteq> 0 \<Longrightarrow> norm(a + d) > norm a \<or> norm(a - d) > norm a"
+ using dist_increases_online[of d a 0] unfolding dist_norm by auto
+
+lemma simplex_furthest_lt:
+ fixes s::"'a::real_inner set" assumes "finite s"
+ shows "\<forall>x \<in> (convex hull s). x \<notin> s \<longrightarrow> (\<exists>y\<in>(convex hull s). norm(x - a) < norm(y - a))"
+proof(induct_tac rule: finite_induct[of s])
+ fix x s assume as:"finite s" "x\<notin>s" "\<forall>x\<in>convex hull s. x \<notin> s \<longrightarrow> (\<exists>y\<in>convex hull s. norm (x - a) < norm (y - a))"
+ show "\<forall>xa\<in>convex hull insert x s. xa \<notin> insert x s \<longrightarrow> (\<exists>y\<in>convex hull insert x s. norm (xa - a) < norm (y - a))"
+ proof(rule,rule,cases "s = {}")
+ case False fix y assume y:"y \<in> convex hull insert x s" "y \<notin> insert x s"
+ obtain u v b where obt:"u\<ge>0" "v\<ge>0" "u + v = 1" "b \<in> convex hull s" "y = u *\<^sub>R x + v *\<^sub>R b"
+ using y(1)[unfolded convex_hull_insert[OF False]] by auto
+ show "\<exists>z\<in>convex hull insert x s. norm (y - a) < norm (z - a)"
+ proof(cases "y\<in>convex hull s")
+ case True then obtain z where "z\<in>convex hull s" "norm (y - a) < norm (z - a)"
+ using as(3)[THEN bspec[where x=y]] and y(2) by auto
+ thus ?thesis apply(rule_tac x=z in bexI) unfolding convex_hull_insert[OF False] by auto
+ next
+ case False show ?thesis using obt(3) proof(cases "u=0", case_tac[!] "v=0")
+ assume "u=0" "v\<noteq>0" hence "y = b" using obt by auto
+ thus ?thesis using False and obt(4) by auto
+ next
+ assume "u\<noteq>0" "v=0" hence "y = x" using obt by auto
+ thus ?thesis using y(2) by auto
+ next
+ assume "u\<noteq>0" "v\<noteq>0"
+ then obtain w where w:"w>0" "w<u" "w<v" using real_lbound_gt_zero[of u v] and obt(1,2) by auto
+ have "x\<noteq>b" proof(rule ccontr)
+ assume "\<not> x\<noteq>b" hence "y=b" unfolding obt(5)
+ using obt(3) by(auto simp add: scaleR_left_distrib[THEN sym])
+ thus False using obt(4) and False by simp qed
+ hence *:"w *\<^sub>R (x - b) \<noteq> 0" using w(1) by auto
+ show ?thesis using dist_increases_online[OF *, of a y]
+ proof(erule_tac disjE)
+ assume "dist a y < dist a (y + w *\<^sub>R (x - b))"
+ hence "norm (y - a) < norm ((u + w) *\<^sub>R x + (v - w) *\<^sub>R b - a)"
+ unfolding dist_commute[of a] unfolding dist_norm obt(5) by (simp add: algebra_simps)
+ moreover have "(u + w) *\<^sub>R x + (v - w) *\<^sub>R b \<in> convex hull insert x s"
+ unfolding convex_hull_insert[OF `s\<noteq>{}`] and mem_Collect_eq
+ apply(rule_tac x="u + w" in exI) apply rule defer
+ apply(rule_tac x="v - w" in exI) using `u\<ge>0` and w and obt(3,4) by auto
+ ultimately show ?thesis by auto
+ next
+ assume "dist a y < dist a (y - w *\<^sub>R (x - b))"
+ hence "norm (y - a) < norm ((u - w) *\<^sub>R x + (v + w) *\<^sub>R b - a)"
+ unfolding dist_commute[of a] unfolding dist_norm obt(5) by (simp add: algebra_simps)
+ moreover have "(u - w) *\<^sub>R x + (v + w) *\<^sub>R b \<in> convex hull insert x s"
+ unfolding convex_hull_insert[OF `s\<noteq>{}`] and mem_Collect_eq
+ apply(rule_tac x="u - w" in exI) apply rule defer
+ apply(rule_tac x="v + w" in exI) using `u\<ge>0` and w and obt(3,4) by auto
+ ultimately show ?thesis by auto
+ qed
+ qed auto
+ qed
+ qed auto
+qed (auto simp add: assms)
+
+lemma simplex_furthest_le:
+ fixes s :: "(real ^ _) set"
+ assumes "finite s" "s \<noteq> {}"
+ shows "\<exists>y\<in>s. \<forall>x\<in>(convex hull s). norm(x - a) \<le> norm(y - a)"
+proof-
+ have "convex hull s \<noteq> {}" using hull_subset[of s convex] and assms(2) by auto
+ then obtain x where x:"x\<in>convex hull s" "\<forall>y\<in>convex hull s. norm (y - a) \<le> norm (x - a)"
+ using distance_attains_sup[OF finite_imp_compact_convex_hull[OF assms(1)], of a]
+ unfolding dist_commute[of a] unfolding dist_norm by auto
+ thus ?thesis proof(cases "x\<in>s")
+ case False then obtain y where "y\<in>convex hull s" "norm (x - a) < norm (y - a)"
+ using simplex_furthest_lt[OF assms(1), THEN bspec[where x=x]] and x(1) by auto
+ thus ?thesis using x(2)[THEN bspec[where x=y]] by auto
+ qed auto
+qed
+
+lemma simplex_furthest_le_exists:
+ fixes s :: "(real ^ _) set"
+ shows "finite s \<Longrightarrow> (\<forall>x\<in>(convex hull s). \<exists>y\<in>s. norm(x - a) \<le> norm(y - a))"
+ using simplex_furthest_le[of s] by (cases "s={}")auto
+
+lemma simplex_extremal_le:
+ fixes s :: "(real ^ _) set"
+ assumes "finite s" "s \<noteq> {}"
+ shows "\<exists>u\<in>s. \<exists>v\<in>s. \<forall>x\<in>convex hull s. \<forall>y \<in> convex hull s. norm(x - y) \<le> norm(u - v)"
+proof-
+ have "convex hull s \<noteq> {}" using hull_subset[of s convex] and assms(2) by auto
+ then obtain u v where obt:"u\<in>convex hull s" "v\<in>convex hull s"
+ "\<forall>x\<in>convex hull s. \<forall>y\<in>convex hull s. norm (x - y) \<le> norm (u - v)"
+ using compact_sup_maxdistance[OF finite_imp_compact_convex_hull[OF assms(1)]] by auto
+ thus ?thesis proof(cases "u\<notin>s \<or> v\<notin>s", erule_tac disjE)
+ assume "u\<notin>s" then obtain y where "y\<in>convex hull s" "norm (u - v) < norm (y - v)"
+ using simplex_furthest_lt[OF assms(1), THEN bspec[where x=u]] and obt(1) by auto
+ thus ?thesis using obt(3)[THEN bspec[where x=y], THEN bspec[where x=v]] and obt(2) by auto
+ next
+ assume "v\<notin>s" then obtain y where "y\<in>convex hull s" "norm (v - u) < norm (y - u)"
+ using simplex_furthest_lt[OF assms(1), THEN bspec[where x=v]] and obt(2) by auto
+ thus ?thesis using obt(3)[THEN bspec[where x=u], THEN bspec[where x=y]] and obt(1)
+ by (auto simp add: norm_minus_commute)
+ qed auto
+qed
+
+lemma simplex_extremal_le_exists:
+ fixes s :: "(real ^ _) set"
+ shows "finite s \<Longrightarrow> x \<in> convex hull s \<Longrightarrow> y \<in> convex hull s
+ \<Longrightarrow> (\<exists>u\<in>s. \<exists>v\<in>s. norm(x - y) \<le> norm(u - v))"
+ using convex_hull_empty simplex_extremal_le[of s] by(cases "s={}")auto
+
+subsection {* Closest point of a convex set is unique, with a continuous projection. *}
+
+definition
+ closest_point :: "(real ^ 'n::finite) set \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 'n" where
+ "closest_point s a = (SOME x. x \<in> s \<and> (\<forall>y\<in>s. dist a x \<le> dist a y))"
+
+lemma closest_point_exists:
+ assumes "closed s" "s \<noteq> {}"
+ shows "closest_point s a \<in> s" "\<forall>y\<in>s. dist a (closest_point s a) \<le> dist a y"
+ unfolding closest_point_def apply(rule_tac[!] someI2_ex)
+ using distance_attains_inf[OF assms(1,2), of a] by auto
+
+lemma closest_point_in_set:
+ "closed s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> (closest_point s a) \<in> s"
+ by(meson closest_point_exists)
+
+lemma closest_point_le:
+ "closed s \<Longrightarrow> x \<in> s \<Longrightarrow> dist a (closest_point s a) \<le> dist a x"
+ using closest_point_exists[of s] by auto
+
+lemma closest_point_self:
+ assumes "x \<in> s" shows "closest_point s x = x"
+ unfolding closest_point_def apply(rule some1_equality, rule ex1I[of _ x])
+ using assms by auto
+
+lemma closest_point_refl:
+ "closed s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> (closest_point s x = x \<longleftrightarrow> x \<in> s)"
+ using closest_point_in_set[of s x] closest_point_self[of x s] by auto
+
+(* TODO: move *)
+lemma norm_lt: "norm x < norm y \<longleftrightarrow> inner x x < inner y y"
+ unfolding norm_eq_sqrt_inner by simp
+
+(* TODO: move *)
+lemma norm_le: "norm x \<le> norm y \<longleftrightarrow> inner x x \<le> inner y y"
+ unfolding norm_eq_sqrt_inner by simp
+
+lemma closer_points_lemma: fixes y::"real^'n::finite"
+ assumes "inner y z > 0"
+ shows "\<exists>u>0. \<forall>v>0. v \<le> u \<longrightarrow> norm(v *\<^sub>R z - y) < norm y"
+proof- have z:"inner z z > 0" unfolding inner_gt_zero_iff using assms by auto
+ thus ?thesis using assms apply(rule_tac x="inner y z / inner z z" in exI) apply(rule) defer proof(rule+)
+ fix v assume "0<v" "v \<le> inner y z / inner z z"
+ thus "norm (v *\<^sub>R z - y) < norm y" unfolding norm_lt using z and assms
+ by (simp add: field_simps inner_diff inner_commute mult_strict_left_mono[OF _ `0<v`])
+ qed(rule divide_pos_pos, auto) qed
+
+lemma closer_point_lemma:
+ fixes x y z :: "real ^ 'n::finite"
+ assumes "inner (y - x) (z - x) > 0"
+ shows "\<exists>u>0. u \<le> 1 \<and> dist (x + u *\<^sub>R (z - x)) y < dist x y"
+proof- obtain u where "u>0" and u:"\<forall>v>0. v \<le> u \<longrightarrow> norm (v *\<^sub>R (z - x) - (y - x)) < norm (y - x)"
+ using closer_points_lemma[OF assms] by auto
+ show ?thesis apply(rule_tac x="min u 1" in exI) using u[THEN spec[where x="min u 1"]] and `u>0`
+ unfolding dist_norm by(auto simp add: norm_minus_commute field_simps) qed
+
+lemma any_closest_point_dot:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "closed s" "x \<in> s" "y \<in> s" "\<forall>z\<in>s. dist a x \<le> dist a z"
+ shows "inner (a - x) (y - x) \<le> 0"
+proof(rule ccontr) assume "\<not> inner (a - x) (y - x) \<le> 0"
+ then obtain u where u:"u>0" "u\<le>1" "dist (x + u *\<^sub>R (y - x)) a < dist x a" using closer_point_lemma[of a x y] by auto
+ let ?z = "(1 - u) *\<^sub>R x + u *\<^sub>R y" have "?z \<in> s" using mem_convex[OF assms(1,3,4), of u] using u by auto
+ thus False using assms(5)[THEN bspec[where x="?z"]] and u(3) by (auto simp add: dist_commute algebra_simps) qed
+
+(* TODO: move *)
+lemma norm_le_square: "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> inner x x \<le> a\<twosuperior>"
+proof -
+ have "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> norm x \<le> a"
+ using norm_ge_zero [of x] by arith
+ also have "\<dots> \<longleftrightarrow> 0 \<le> a \<and> (norm x)\<twosuperior> \<le> a\<twosuperior>"
+ by (auto intro: power_mono dest: power2_le_imp_le)
+ also have "\<dots> \<longleftrightarrow> 0 \<le> a \<and> inner x x \<le> a\<twosuperior>"
+ unfolding power2_norm_eq_inner ..
+ finally show ?thesis .
+qed
+
+lemma any_closest_point_unique:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "closed s" "x \<in> s" "y \<in> s"
+ "\<forall>z\<in>s. dist a x \<le> dist a z" "\<forall>z\<in>s. dist a y \<le> dist a z"
+ shows "x = y" using any_closest_point_dot[OF assms(1-4,5)] and any_closest_point_dot[OF assms(1-2,4,3,6)]
+ unfolding norm_pths(1) and norm_le_square
+ by (auto simp add: algebra_simps)
+
+lemma closest_point_unique:
+ assumes "convex s" "closed s" "x \<in> s" "\<forall>z\<in>s. dist a x \<le> dist a z"
+ shows "x = closest_point s a"
+ using any_closest_point_unique[OF assms(1-3) _ assms(4), of "closest_point s a"]
+ using closest_point_exists[OF assms(2)] and assms(3) by auto
+
+lemma closest_point_dot:
+ assumes "convex s" "closed s" "x \<in> s"
+ shows "inner (a - closest_point s a) (x - closest_point s a) \<le> 0"
+ apply(rule any_closest_point_dot[OF assms(1,2) _ assms(3)])
+ using closest_point_exists[OF assms(2)] and assms(3) by auto
+
+lemma closest_point_lt:
+ assumes "convex s" "closed s" "x \<in> s" "x \<noteq> closest_point s a"
+ shows "dist a (closest_point s a) < dist a x"
+ apply(rule ccontr) apply(rule_tac notE[OF assms(4)])
+ apply(rule closest_point_unique[OF assms(1-3), of a])
+ using closest_point_le[OF assms(2), of _ a] by fastsimp
+
+lemma closest_point_lipschitz:
+ assumes "convex s" "closed s" "s \<noteq> {}"
+ shows "dist (closest_point s x) (closest_point s y) \<le> dist x y"
+proof-
+ have "inner (x - closest_point s x) (closest_point s y - closest_point s x) \<le> 0"
+ "inner (y - closest_point s y) (closest_point s x - closest_point s y) \<le> 0"
+ apply(rule_tac[!] any_closest_point_dot[OF assms(1-2)])
+ using closest_point_exists[OF assms(2-3)] by auto
+ thus ?thesis unfolding dist_norm and norm_le
+ using inner_ge_zero[of "(x - closest_point s x) - (y - closest_point s y)"]
+ by (simp add: inner_add inner_diff inner_commute) qed
+
+lemma continuous_at_closest_point:
+ assumes "convex s" "closed s" "s \<noteq> {}"
+ shows "continuous (at x) (closest_point s)"
+ unfolding continuous_at_eps_delta
+ using le_less_trans[OF closest_point_lipschitz[OF assms]] by auto
+
+lemma continuous_on_closest_point:
+ assumes "convex s" "closed s" "s \<noteq> {}"
+ shows "continuous_on t (closest_point s)"
+ apply(rule continuous_at_imp_continuous_on) using continuous_at_closest_point[OF assms] by auto
+
+subsection {* Various point-to-set separating/supporting hyperplane theorems. *}
+
+lemma supporting_hyperplane_closed_point:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "closed s" "s \<noteq> {}" "z \<notin> s"
+ shows "\<exists>a b. \<exists>y\<in>s. inner a z < b \<and> (inner a y = b) \<and> (\<forall>x\<in>s. inner a x \<ge> b)"
+proof-
+ from distance_attains_inf[OF assms(2-3)] obtain y where "y\<in>s" and y:"\<forall>x\<in>s. dist z y \<le> dist z x" by auto
+ show ?thesis apply(rule_tac x="y - z" in exI, rule_tac x="inner (y - z) y" in exI, rule_tac x=y in bexI)
+ apply rule defer apply rule defer apply(rule, rule ccontr) using `y\<in>s` proof-
+ show "inner (y - z) z < inner (y - z) y" apply(subst diff_less_iff(1)[THEN sym])
+ unfolding inner_diff_right[THEN sym] and inner_gt_zero_iff using `y\<in>s` `z\<notin>s` by auto
+ next
+ fix x assume "x\<in>s" have *:"\<forall>u. 0 \<le> u \<and> u \<le> 1 \<longrightarrow> dist z y \<le> dist z ((1 - u) *\<^sub>R y + u *\<^sub>R x)"
+ using assms(1)[unfolded convex_alt] and y and `x\<in>s` and `y\<in>s` by auto
+ assume "\<not> inner (y - z) y \<le> inner (y - z) x" then obtain v where
+ "v>0" "v\<le>1" "dist (y + v *\<^sub>R (x - y)) z < dist y z" using closer_point_lemma[of z y x] apply - by (auto simp add: inner_diff)
+ thus False using *[THEN spec[where x=v]] by(auto simp add: dist_commute algebra_simps)
+ qed auto
+qed
+
+lemma separating_hyperplane_closed_point:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "closed s" "z \<notin> s"
+ shows "\<exists>a b. inner a z < b \<and> (\<forall>x\<in>s. inner a x > b)"
+proof(cases "s={}")
+ case True thus ?thesis apply(rule_tac x="-z" in exI, rule_tac x=1 in exI)
+ using less_le_trans[OF _ inner_ge_zero[of z]] by auto
+next
+ case False obtain y where "y\<in>s" and y:"\<forall>x\<in>s. dist z y \<le> dist z x"
+ using distance_attains_inf[OF assms(2) False] by auto
+ show ?thesis apply(rule_tac x="y - z" in exI, rule_tac x="inner (y - z) z + (norm(y - z))\<twosuperior> / 2" in exI)
+ apply rule defer apply rule proof-
+ fix x assume "x\<in>s"
+ have "\<not> 0 < inner (z - y) (x - y)" apply(rule_tac notI) proof(drule closer_point_lemma)
+ assume "\<exists>u>0. u \<le> 1 \<and> dist (y + u *\<^sub>R (x - y)) z < dist y z"
+ then obtain u where "u>0" "u\<le>1" "dist (y + u *\<^sub>R (x - y)) z < dist y z" by auto
+ thus False using y[THEN bspec[where x="y + u *\<^sub>R (x - y)"]]
+ using assms(1)[unfolded convex_alt, THEN bspec[where x=y]]
+ using `x\<in>s` `y\<in>s` by (auto simp add: dist_commute algebra_simps) qed
+ moreover have "0 < norm (y - z) ^ 2" using `y\<in>s` `z\<notin>s` by auto
+ hence "0 < inner (y - z) (y - z)" unfolding power2_norm_eq_inner by simp
+ ultimately show "inner (y - z) z + (norm (y - z))\<twosuperior> / 2 < inner (y - z) x"
+ unfolding power2_norm_eq_inner and not_less by (auto simp add: field_simps inner_commute inner_diff)
+ qed(insert `y\<in>s` `z\<notin>s`, auto)
+qed
+
+lemma separating_hyperplane_closed_0:
+ assumes "convex (s::(real^'n::finite) set)" "closed s" "0 \<notin> s"
+ shows "\<exists>a b. a \<noteq> 0 \<and> 0 < b \<and> (\<forall>x\<in>s. inner a x > b)"
+ proof(cases "s={}") guess a using UNIV_witness[where 'a='n] ..
+ case True have "norm ((basis a)::real^'n::finite) = 1"
+ using norm_basis and dimindex_ge_1 by auto
+ thus ?thesis apply(rule_tac x="basis a" in exI, rule_tac x=1 in exI) using True by auto
+next case False thus ?thesis using False using separating_hyperplane_closed_point[OF assms]
+ apply - apply(erule exE)+ unfolding dot_rzero apply(rule_tac x=a in exI, rule_tac x=b in exI) by auto qed
+
+subsection {* Now set-to-set for closed/compact sets. *}
+
+lemma separating_hyperplane_closed_compact:
+ assumes "convex (s::(real^'n::finite) set)" "closed s" "convex t" "compact t" "t \<noteq> {}" "s \<inter> t = {}"
+ shows "\<exists>a b. (\<forall>x\<in>s. inner a x < b) \<and> (\<forall>x\<in>t. inner a x > b)"
+proof(cases "s={}")
+ case True
+ obtain b where b:"b>0" "\<forall>x\<in>t. norm x \<le> b" using compact_imp_bounded[OF assms(4)] unfolding bounded_pos by auto
+ obtain z::"real^'n" where z:"norm z = b + 1" using vector_choose_size[of "b + 1"] and b(1) by auto
+ hence "z\<notin>t" using b(2)[THEN bspec[where x=z]] by auto
+ then obtain a b where ab:"inner a z < b" "\<forall>x\<in>t. b < inner a x"
+ using separating_hyperplane_closed_point[OF assms(3) compact_imp_closed[OF assms(4)], of z] by auto
+ thus ?thesis using True by auto
+next
+ case False then obtain y where "y\<in>s" by auto
+ obtain a b where "0 < b" "\<forall>x\<in>{x - y |x y. x \<in> s \<and> y \<in> t}. b < inner a x"
+ using separating_hyperplane_closed_point[OF convex_differences[OF assms(1,3)], of 0]
+ using closed_compact_differences[OF assms(2,4)] using assms(6) by(auto, blast)
+ hence ab:"\<forall>x\<in>s. \<forall>y\<in>t. b + inner a y < inner a x" apply- apply(rule,rule) apply(erule_tac x="x - y" in ballE) by (auto simp add: inner_diff)
+ def k \<equiv> "Sup ((\<lambda>x. inner a x) ` t)"
+ show ?thesis apply(rule_tac x="-a" in exI, rule_tac x="-(k + b / 2)" in exI)
+ apply(rule,rule) defer apply(rule) unfolding inner_minus_left and neg_less_iff_less proof-
+ from ab have "((\<lambda>x. inner a x) ` t) *<= (inner a y - b)"
+ apply(erule_tac x=y in ballE) apply(rule setleI) using `y\<in>s` by auto
+ hence k:"isLub UNIV ((\<lambda>x. inner a x) ` t) k" unfolding k_def apply(rule_tac Sup) using assms(5) by auto
+ fix x assume "x\<in>t" thus "inner a x < (k + b / 2)" using `0<b` and isLubD2[OF k, of "inner a x"] by auto
+ next
+ fix x assume "x\<in>s"
+ hence "k \<le> inner a x - b" unfolding k_def apply(rule_tac Sup_least) using assms(5)
+ using ab[THEN bspec[where x=x]] by auto
+ thus "k + b / 2 < inner a x" using `0 < b` by auto
+ qed
+qed
+
+lemma separating_hyperplane_compact_closed:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "compact s" "s \<noteq> {}" "convex t" "closed t" "s \<inter> t = {}"
+ shows "\<exists>a b. (\<forall>x\<in>s. inner a x < b) \<and> (\<forall>x\<in>t. inner a x > b)"
+proof- obtain a b where "(\<forall>x\<in>t. inner a x < b) \<and> (\<forall>x\<in>s. b < inner a x)"
+ using separating_hyperplane_closed_compact[OF assms(4-5,1-2,3)] and assms(6) by auto
+ thus ?thesis apply(rule_tac x="-a" in exI, rule_tac x="-b" in exI) by auto qed
+
+subsection {* General case without assuming closure and getting non-strict separation. *}
+
+lemma separating_hyperplane_set_0:
+ assumes "convex s" "(0::real^'n::finite) \<notin> s"
+ shows "\<exists>a. a \<noteq> 0 \<and> (\<forall>x\<in>s. 0 \<le> inner a x)"
+proof- let ?k = "\<lambda>c. {x::real^'n. 0 \<le> inner c x}"
+ have "frontier (cball 0 1) \<inter> (\<Inter> (?k ` s)) \<noteq> {}"
+ apply(rule compact_imp_fip) apply(rule compact_frontier[OF compact_cball])
+ defer apply(rule,rule,erule conjE) proof-
+ fix f assume as:"f \<subseteq> ?k ` s" "finite f"
+ obtain c where c:"f = ?k ` c" "c\<subseteq>s" "finite c" using finite_subset_image[OF as(2,1)] by auto
+ then obtain a b where ab:"a \<noteq> 0" "0 < b" "\<forall>x\<in>convex hull c. b < inner a x"
+ using separating_hyperplane_closed_0[OF convex_convex_hull, of c]
+ using finite_imp_compact_convex_hull[OF c(3), THEN compact_imp_closed] and assms(2)
+ using subset_hull[unfolded mem_def, of convex, OF assms(1), THEN sym, of c] by auto
+ hence "\<exists>x. norm x = 1 \<and> (\<forall>y\<in>c. 0 \<le> inner y x)" apply(rule_tac x="inverse(norm a) *\<^sub>R a" in exI)
+ using hull_subset[of c convex] unfolding subset_eq and inner_scaleR
+ apply- apply rule defer apply rule apply(rule mult_nonneg_nonneg)
+ by(auto simp add: inner_commute elim!: ballE)
+ thus "frontier (cball 0 1) \<inter> \<Inter>f \<noteq> {}" unfolding c(1) frontier_cball dist_norm by auto
+ qed(insert closed_halfspace_ge, auto)
+ then obtain x where "norm x = 1" "\<forall>y\<in>s. x\<in>?k y" unfolding frontier_cball dist_norm by auto
+ thus ?thesis apply(rule_tac x=x in exI) by(auto simp add: inner_commute) qed
+
+lemma separating_hyperplane_sets:
+ assumes "convex s" "convex (t::(real^'n::finite) set)" "s \<noteq> {}" "t \<noteq> {}" "s \<inter> t = {}"
+ shows "\<exists>a b. a \<noteq> 0 \<and> (\<forall>x\<in>s. inner a x \<le> b) \<and> (\<forall>x\<in>t. inner a x \<ge> b)"
+proof- from separating_hyperplane_set_0[OF convex_differences[OF assms(2,1)]]
+ obtain a where "a\<noteq>0" "\<forall>x\<in>{x - y |x y. x \<in> t \<and> y \<in> s}. 0 \<le> inner a x"
+ using assms(3-5) by auto
+ hence "\<forall>x\<in>t. \<forall>y\<in>s. inner a y \<le> inner a x"
+ by (force simp add: inner_diff)
+ thus ?thesis
+ apply(rule_tac x=a in exI, rule_tac x="Sup ((\<lambda>x. inner a x) ` s)" in exI) using `a\<noteq>0`
+ apply auto
+ apply (rule Sup[THEN isLubD2])
+ prefer 4
+ apply (rule Sup_least)
+ using assms(3-5) apply (auto simp add: setle_def)
+ apply (metis COMBC_def Collect_def Collect_mem_eq)
+ done
+qed
+
+subsection {* More convexity generalities. *}
+
+lemma convex_closure:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "convex s" shows "convex(closure s)"
+ unfolding convex_def Ball_def closure_sequential
+ apply(rule,rule,rule,rule,rule,rule,rule,rule,rule) apply(erule_tac exE)+
+ apply(rule_tac x="\<lambda>n. u *\<^sub>R xb n + v *\<^sub>R xc n" in exI) apply(rule,rule)
+ apply(rule assms[unfolded convex_def, rule_format]) prefer 6
+ apply(rule Lim_add) apply(rule_tac [1-2] Lim_cmul) by auto
+
+lemma convex_interior:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "convex s" shows "convex(interior s)"
+ unfolding convex_alt Ball_def mem_interior apply(rule,rule,rule,rule,rule,rule) apply(erule exE | erule conjE)+ proof-
+ fix x y u assume u:"0 \<le> u" "u \<le> (1::real)"
+ fix e d assume ed:"ball x e \<subseteq> s" "ball y d \<subseteq> s" "0<d" "0<e"
+ show "\<exists>e>0. ball ((1 - u) *\<^sub>R x + u *\<^sub>R y) e \<subseteq> s" apply(rule_tac x="min d e" in exI)
+ apply rule unfolding subset_eq defer apply rule proof-
+ fix z assume "z \<in> ball ((1 - u) *\<^sub>R x + u *\<^sub>R y) (min d e)"
+ hence "(1- u) *\<^sub>R (z - u *\<^sub>R (y - x)) + u *\<^sub>R (z + (1 - u) *\<^sub>R (y - x)) \<in> s"
+ apply(rule_tac assms[unfolded convex_alt, rule_format])
+ using ed(1,2) and u unfolding subset_eq mem_ball Ball_def dist_norm by(auto simp add: algebra_simps)
+ thus "z \<in> s" using u by (auto simp add: algebra_simps) qed(insert u ed(3-4), auto) qed
+
+lemma convex_hull_eq_empty: "convex hull s = {} \<longleftrightarrow> s = {}"
+ using hull_subset[of s convex] convex_hull_empty by auto
+
+subsection {* Moving and scaling convex hulls. *}
+
+lemma convex_hull_translation_lemma:
+ "convex hull ((\<lambda>x. a + x) ` s) \<subseteq> (\<lambda>x. a + x) ` (convex hull s)"
+ apply(rule hull_minimal, rule image_mono, rule hull_subset) unfolding mem_def
+ using convex_translation[OF convex_convex_hull, of a s] by assumption
+
+lemma convex_hull_bilemma: fixes neg
+ assumes "(\<forall>s a. (convex hull (up a s)) \<subseteq> up a (convex hull s))"
+ shows "(\<forall>s. up a (up (neg a) s) = s) \<and> (\<forall>s. up (neg a) (up a s) = s) \<and> (\<forall>s t a. s \<subseteq> t \<longrightarrow> up a s \<subseteq> up a t)
+ \<Longrightarrow> \<forall>s. (convex hull (up a s)) = up a (convex hull s)"
+ using assms by(metis subset_antisym)
+
+lemma convex_hull_translation:
+ "convex hull ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (convex hull s)"
+ apply(rule convex_hull_bilemma[rule_format, of _ _ "\<lambda>a. -a"], rule convex_hull_translation_lemma) unfolding image_image by auto
+
+lemma convex_hull_scaling_lemma:
+ "(convex hull ((\<lambda>x. c *\<^sub>R x) ` s)) \<subseteq> (\<lambda>x. c *\<^sub>R x) ` (convex hull s)"
+ apply(rule hull_minimal, rule image_mono, rule hull_subset)
+ unfolding mem_def by(rule convex_scaling, rule convex_convex_hull)
+
+lemma convex_hull_scaling:
+ "convex hull ((\<lambda>x. c *\<^sub>R x) ` s) = (\<lambda>x. c *\<^sub>R x) ` (convex hull s)"
+ apply(cases "c=0") defer apply(rule convex_hull_bilemma[rule_format, of _ _ inverse]) apply(rule convex_hull_scaling_lemma)
+ unfolding image_image scaleR_scaleR by(auto simp add:image_constant_conv convex_hull_eq_empty)
+
+lemma convex_hull_affinity:
+ "convex hull ((\<lambda>x. a + c *\<^sub>R x) ` s) = (\<lambda>x. a + c *\<^sub>R x) ` (convex hull s)"
+ unfolding image_image[THEN sym] convex_hull_scaling convex_hull_translation ..
+
+subsection {* Convex set as intersection of halfspaces. *}
+
+lemma convex_halfspace_intersection:
+ fixes s :: "(real ^ _) set"
+ assumes "closed s" "convex s"
+ shows "s = \<Inter> {h. s \<subseteq> h \<and> (\<exists>a b. h = {x. inner a x \<le> b})}"
+ apply(rule set_ext, rule) unfolding Inter_iff Ball_def mem_Collect_eq apply(rule,rule,erule conjE) proof-
+ fix x assume "\<forall>xa. s \<subseteq> xa \<and> (\<exists>a b. xa = {x. inner a x \<le> b}) \<longrightarrow> x \<in> xa"
+ hence "\<forall>a b. s \<subseteq> {x. inner a x \<le> b} \<longrightarrow> x \<in> {x. inner a x \<le> b}" by blast
+ thus "x\<in>s" apply(rule_tac ccontr) apply(drule separating_hyperplane_closed_point[OF assms(2,1)])
+ apply(erule exE)+ apply(erule_tac x="-a" in allE, erule_tac x="-b" in allE) by auto
+qed auto
+
+subsection {* Radon's theorem (from Lars Schewe). *}
+
+lemma radon_ex_lemma:
+ assumes "finite c" "affine_dependent c"
+ shows "\<exists>u. setsum u c = 0 \<and> (\<exists>v\<in>c. u v \<noteq> 0) \<and> setsum (\<lambda>v. u v *\<^sub>R v) c = 0"
+proof- from assms(2)[unfolded affine_dependent_explicit] guess s .. then guess u ..
+ thus ?thesis apply(rule_tac x="\<lambda>v. if v\<in>s then u v else 0" in exI) unfolding if_smult scaleR_zero_left
+ and setsum_restrict_set[OF assms(1), THEN sym] by(auto simp add: Int_absorb1) qed
+
+lemma radon_s_lemma:
+ assumes "finite s" "setsum f s = (0::real)"
+ shows "setsum f {x\<in>s. 0 < f x} = - setsum f {x\<in>s. f x < 0}"
+proof- have *:"\<And>x. (if f x < 0 then f x else 0) + (if 0 < f x then f x else 0) = f x" by auto
+ show ?thesis unfolding real_add_eq_0_iff[THEN sym] and setsum_restrict_set''[OF assms(1)] and setsum_addf[THEN sym] and *
+ using assms(2) by assumption qed
+
+lemma radon_v_lemma:
+ assumes "finite s" "setsum f s = 0" "\<forall>x. g x = (0::real) \<longrightarrow> f x = (0::real^'n)"
+ shows "(setsum f {x\<in>s. 0 < g x}) = - setsum f {x\<in>s. g x < 0}"
+proof-
+ have *:"\<And>x. (if 0 < g x then f x else 0) + (if g x < 0 then f x else 0) = f x" using assms(3) by auto
+ show ?thesis unfolding eq_neg_iff_add_eq_0 and setsum_restrict_set''[OF assms(1)] and setsum_addf[THEN sym] and *
+ using assms(2) by assumption qed
+
+lemma radon_partition:
+ assumes "finite c" "affine_dependent c"
+ shows "\<exists>m p. m \<inter> p = {} \<and> m \<union> p = c \<and> (convex hull m) \<inter> (convex hull p) \<noteq> {}" proof-
+ obtain u v where uv:"setsum u c = 0" "v\<in>c" "u v \<noteq> 0" "(\<Sum>v\<in>c. u v *\<^sub>R v) = 0" using radon_ex_lemma[OF assms] by auto
+ have fin:"finite {x \<in> c. 0 < u x}" "finite {x \<in> c. 0 > u x}" using assms(1) by auto
+ def z \<equiv> "(inverse (setsum u {x\<in>c. u x > 0})) *\<^sub>R setsum (\<lambda>x. u x *\<^sub>R x) {x\<in>c. u x > 0}"
+ have "setsum u {x \<in> c. 0 < u x} \<noteq> 0" proof(cases "u v \<ge> 0")
+ case False hence "u v < 0" by auto
+ thus ?thesis proof(cases "\<exists>w\<in>{x \<in> c. 0 < u x}. u w > 0")
+ case True thus ?thesis using setsum_nonneg_eq_0_iff[of _ u, OF fin(1)] by auto
+ next
+ case False hence "setsum u c \<le> setsum (\<lambda>x. if x=v then u v else 0) c" apply(rule_tac setsum_mono) by auto
+ thus ?thesis unfolding setsum_delta[OF assms(1)] using uv(2) and `u v < 0` and uv(1) by auto qed
+ qed (insert setsum_nonneg_eq_0_iff[of _ u, OF fin(1)] uv(2-3), auto)
+
+ hence *:"setsum u {x\<in>c. u x > 0} > 0" unfolding real_less_def apply(rule_tac conjI, rule_tac setsum_nonneg) by auto
+ moreover have "setsum u ({x \<in> c. 0 < u x} \<union> {x \<in> c. u x < 0}) = setsum u c"
+ "(\<Sum>x\<in>{x \<in> c. 0 < u x} \<union> {x \<in> c. u x < 0}. u x *\<^sub>R x) = (\<Sum>x\<in>c. u x *\<^sub>R x)"
+ using assms(1) apply(rule_tac[!] setsum_mono_zero_left) by auto
+ hence "setsum u {x \<in> c. 0 < u x} = - setsum u {x \<in> c. 0 > u x}"
+ "(\<Sum>x\<in>{x \<in> c. 0 < u x}. u x *\<^sub>R x) = - (\<Sum>x\<in>{x \<in> c. 0 > u x}. u x *\<^sub>R x)"
+ unfolding eq_neg_iff_add_eq_0 using uv(1,4) by (auto simp add: setsum_Un_zero[OF fin, THEN sym])
+ moreover have "\<forall>x\<in>{v \<in> c. u v < 0}. 0 \<le> inverse (setsum u {x \<in> c. 0 < u x}) * - u x"
+ apply (rule) apply (rule mult_nonneg_nonneg) using * by auto
+
+ ultimately have "z \<in> convex hull {v \<in> c. u v \<le> 0}" unfolding convex_hull_explicit mem_Collect_eq
+ apply(rule_tac x="{v \<in> c. u v < 0}" in exI, rule_tac x="\<lambda>y. inverse (setsum u {x\<in>c. u x > 0}) * - u y" in exI)
+ using assms(1) unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and z_def
+ by(auto simp add: setsum_negf vector_smult_lneg mult_right.setsum[THEN sym])
+ moreover have "\<forall>x\<in>{v \<in> c. 0 < u v}. 0 \<le> inverse (setsum u {x \<in> c. 0 < u x}) * u x"
+ apply (rule) apply (rule mult_nonneg_nonneg) using * by auto
+ hence "z \<in> convex hull {v \<in> c. u v > 0}" unfolding convex_hull_explicit mem_Collect_eq
+ apply(rule_tac x="{v \<in> c. 0 < u v}" in exI, rule_tac x="\<lambda>y. inverse (setsum u {x\<in>c. u x > 0}) * u y" in exI)
+ using assms(1) unfolding scaleR_scaleR[THEN sym] scaleR_right.setsum [symmetric] and z_def using *
+ by(auto simp add: setsum_negf vector_smult_lneg mult_right.setsum[THEN sym])
+ ultimately show ?thesis apply(rule_tac x="{v\<in>c. u v \<le> 0}" in exI, rule_tac x="{v\<in>c. u v > 0}" in exI) by auto
+qed
+
+lemma radon: assumes "affine_dependent c"
+ obtains m p where "m\<subseteq>c" "p\<subseteq>c" "m \<inter> p = {}" "(convex hull m) \<inter> (convex hull p) \<noteq> {}"
+proof- from assms[unfolded affine_dependent_explicit] guess s .. then guess u ..
+ hence *:"finite s" "affine_dependent s" and s:"s \<subseteq> c" unfolding affine_dependent_explicit by auto
+ from radon_partition[OF *] guess m .. then guess p ..
+ thus ?thesis apply(rule_tac that[of p m]) using s by auto qed
+
+subsection {* Helly's theorem. *}
+
+lemma helly_induct: fixes f::"(real^'n::finite) set set"
+ assumes "f hassize n" "n \<ge> CARD('n) + 1"
+ "\<forall>s\<in>f. convex s" "\<forall>t\<subseteq>f. card t = CARD('n) + 1 \<longrightarrow> \<Inter> t \<noteq> {}"
+ shows "\<Inter> f \<noteq> {}"
+ using assms unfolding hassize_def apply(erule_tac conjE) proof(induct n arbitrary: f)
+case (Suc n)
+show "\<Inter> f \<noteq> {}" apply(cases "n = CARD('n)") apply(rule Suc(4)[rule_format])
+ unfolding card_Diff_singleton_if[OF Suc(5)] and Suc(6) proof-
+ assume ng:"n \<noteq> CARD('n)" hence "\<exists>X. \<forall>s\<in>f. X s \<in> \<Inter>(f - {s})" apply(rule_tac bchoice) unfolding ex_in_conv
+ apply(rule, rule Suc(1)[rule_format]) unfolding card_Diff_singleton_if[OF Suc(5)] and Suc(6)
+ defer apply(rule Suc(3)[rule_format]) defer apply(rule Suc(4)[rule_format]) using Suc(2,5) by auto
+ then obtain X where X:"\<forall>s\<in>f. X s \<in> \<Inter>(f - {s})" by auto
+ show ?thesis proof(cases "inj_on X f")
+ case False then obtain s t where st:"s\<noteq>t" "s\<in>f" "t\<in>f" "X s = X t" unfolding inj_on_def by auto
+ hence *:"\<Inter> f = \<Inter> (f - {s}) \<inter> \<Inter> (f - {t})" by auto
+ show ?thesis unfolding * unfolding ex_in_conv[THEN sym] apply(rule_tac x="X s" in exI)
+ apply(rule, rule X[rule_format]) using X st by auto
+ next case True then obtain m p where mp:"m \<inter> p = {}" "m \<union> p = X ` f" "convex hull m \<inter> convex hull p \<noteq> {}"
+ using radon_partition[of "X ` f"] and affine_dependent_biggerset[of "X ` f"]
+ unfolding card_image[OF True] and Suc(6) using Suc(2,5) and ng by auto
+ have "m \<subseteq> X ` f" "p \<subseteq> X ` f" using mp(2) by auto
+ then obtain g h where gh:"m = X ` g" "p = X ` h" "g \<subseteq> f" "h \<subseteq> f" unfolding subset_image_iff by auto
+ hence "f \<union> (g \<union> h) = f" by auto
+ hence f:"f = g \<union> h" using inj_on_Un_image_eq_iff[of X f "g \<union> h"] and True
+ unfolding mp(2)[unfolded image_Un[THEN sym] gh] by auto
+ have *:"g \<inter> h = {}" using mp(1) unfolding gh using inj_on_image_Int[OF True gh(3,4)] by auto
+ have "convex hull (X ` h) \<subseteq> \<Inter> g" "convex hull (X ` g) \<subseteq> \<Inter> h"
+ apply(rule_tac [!] hull_minimal) using Suc(3) gh(3-4) unfolding mem_def unfolding subset_eq
+ apply(rule_tac [2] convex_Inter, rule_tac [4] convex_Inter) apply rule prefer 3 apply rule proof-
+ fix x assume "x\<in>X ` g" then guess y unfolding image_iff ..
+ thus "x\<in>\<Inter>h" using X[THEN bspec[where x=y]] using * f by auto next
+ fix x assume "x\<in>X ` h" then guess y unfolding image_iff ..
+ thus "x\<in>\<Inter>g" using X[THEN bspec[where x=y]] using * f by auto
+ qed(auto)
+ thus ?thesis unfolding f using mp(3)[unfolded gh] by blast qed
+qed(insert dimindex_ge_1, auto) qed(auto)
+
+lemma helly: fixes f::"(real^'n::finite) set set"
+ assumes "finite f" "card f \<ge> CARD('n) + 1" "\<forall>s\<in>f. convex s"
+ "\<forall>t\<subseteq>f. card t = CARD('n) + 1 \<longrightarrow> \<Inter> t \<noteq> {}"
+ shows "\<Inter> f \<noteq>{}"
+ apply(rule helly_induct) unfolding hassize_def using assms by auto
+
+subsection {* Convex hull is "preserved" by a linear function. *}
+
+lemma convex_hull_linear_image:
+ assumes "bounded_linear f"
+ shows "f ` (convex hull s) = convex hull (f ` s)"
+ apply rule unfolding subset_eq ball_simps apply(rule_tac[!] hull_induct, rule hull_inc) prefer 3
+ apply(erule imageE)apply(rule_tac x=xa in image_eqI) apply assumption
+ apply(rule hull_subset[unfolded subset_eq, rule_format]) apply assumption
+proof-
+ interpret f: bounded_linear f by fact
+ show "convex {x. f x \<in> convex hull f ` s}"
+ unfolding convex_def by(auto simp add: f.scaleR f.add convex_convex_hull[unfolded convex_def, rule_format]) next
+ interpret f: bounded_linear f by fact
+ show "convex {x. x \<in> f ` (convex hull s)}" using convex_convex_hull[unfolded convex_def, of s]
+ unfolding convex_def by (auto simp add: f.scaleR [symmetric] f.add [symmetric])
+qed auto
+
+lemma in_convex_hull_linear_image:
+ assumes "bounded_linear f" "x \<in> convex hull s"
+ shows "(f x) \<in> convex hull (f ` s)"
+using convex_hull_linear_image[OF assms(1)] assms(2) by auto
+
+subsection {* Homeomorphism of all convex compact sets with nonempty interior. *}
+
+lemma compact_frontier_line_lemma:
+ fixes s :: "(real ^ _) set"
+ assumes "compact s" "0 \<in> s" "x \<noteq> 0"
+ obtains u where "0 \<le> u" "(u *\<^sub>R x) \<in> frontier s" "\<forall>v>u. (v *\<^sub>R x) \<notin> s"
+proof-
+ obtain b where b:"b>0" "\<forall>x\<in>s. norm x \<le> b" using compact_imp_bounded[OF assms(1), unfolded bounded_pos] by auto
+ let ?A = "{y. \<exists>u. 0 \<le> u \<and> u \<le> b / norm(x) \<and> (y = u *\<^sub>R x)}"
+ have A:"?A = (\<lambda>u. dest_vec1 u *\<^sub>R x) ` {0 .. vec1 (b / norm x)}"
+ unfolding image_image[of "\<lambda>u. u *\<^sub>R x" "\<lambda>x. dest_vec1 x", THEN sym]
+ unfolding dest_vec1_inverval vec1_dest_vec1 by auto
+ have "compact ?A" unfolding A apply(rule compact_continuous_image, rule continuous_at_imp_continuous_on)
+ apply(rule, rule continuous_vmul)
+ apply (rule continuous_dest_vec1)
+ apply(rule continuous_at_id) by(rule compact_interval)
+ moreover have "{y. \<exists>u\<ge>0. u \<le> b / norm x \<and> y = u *\<^sub>R x} \<inter> s \<noteq> {}" apply(rule not_disjointI[OF _ assms(2)])
+ unfolding mem_Collect_eq using `b>0` assms(3) by(auto intro!: divide_nonneg_pos)
+ ultimately obtain u y where obt: "u\<ge>0" "u \<le> b / norm x" "y = u *\<^sub>R x"
+ "y\<in>?A" "y\<in>s" "\<forall>z\<in>?A \<inter> s. dist 0 z \<le> dist 0 y" using distance_attains_sup[OF compact_inter[OF _ assms(1), of ?A], of 0] by auto
+
+ have "norm x > 0" using assms(3)[unfolded zero_less_norm_iff[THEN sym]] by auto
+ { fix v assume as:"v > u" "v *\<^sub>R x \<in> s"
+ hence "v \<le> b / norm x" using b(2)[rule_format, OF as(2)]
+ using `u\<ge>0` unfolding pos_le_divide_eq[OF `norm x > 0`] by auto
+ hence "norm (v *\<^sub>R x) \<le> norm y" apply(rule_tac obt(6)[rule_format, unfolded dist_0_norm]) apply(rule IntI) defer
+ apply(rule as(2)) unfolding mem_Collect_eq apply(rule_tac x=v in exI)
+ using as(1) `u\<ge>0` by(auto simp add:field_simps)
+ hence False unfolding obt(3) using `u\<ge>0` `norm x > 0` `v>u` by(auto simp add:field_simps)
+ } note u_max = this
+
+ have "u *\<^sub>R x \<in> frontier s" unfolding frontier_straddle apply(rule,rule,rule) apply(rule_tac x="u *\<^sub>R x" in bexI) unfolding obt(3)[THEN sym]
+ prefer 3 apply(rule_tac x="(u + (e / 2) / norm x) *\<^sub>R x" in exI) apply(rule, rule) proof-
+ fix e assume "0 < e" and as:"(u + e / 2 / norm x) *\<^sub>R x \<in> s"
+ hence "u + e / 2 / norm x > u" using`norm x > 0` by(auto simp del:zero_less_norm_iff intro!: divide_pos_pos)
+ thus False using u_max[OF _ as] by auto
+ qed(insert `y\<in>s`, auto simp add: dist_norm scaleR_left_distrib obt(3))
+ thus ?thesis apply(rule_tac that[of u]) apply(rule obt(1), assumption)
+ apply(rule,rule,rule ccontr) apply(rule u_max) by auto qed
+
+lemma starlike_compact_projective:
+ assumes "compact s" "cball (0::real^'n::finite) 1 \<subseteq> s "
+ "\<forall>x\<in>s. \<forall>u. 0 \<le> u \<and> u < 1 \<longrightarrow> (u *\<^sub>R x) \<in> (s - frontier s )"
+ shows "s homeomorphic (cball (0::real^'n::finite) 1)"
+proof-
+ have fs:"frontier s \<subseteq> s" apply(rule frontier_subset_closed) using compact_imp_closed[OF assms(1)] by simp
+ def pi \<equiv> "\<lambda>x::real^'n. inverse (norm x) *\<^sub>R x"
+ have "0 \<notin> frontier s" unfolding frontier_straddle apply(rule ccontr) unfolding not_not apply(erule_tac x=1 in allE)
+ using assms(2)[unfolded subset_eq Ball_def mem_cball] by auto
+ have injpi:"\<And>x y. pi x = pi y \<and> norm x = norm y \<longleftrightarrow> x = y" unfolding pi_def by auto
+
+ have contpi:"continuous_on (UNIV - {0}) pi" apply(rule continuous_at_imp_continuous_on)
+ apply rule unfolding pi_def
+ apply (rule continuous_mul)
+ apply (rule continuous_at_inv[unfolded o_def])
+ apply (rule continuous_at_norm)
+ apply simp
+ apply (rule continuous_at_id)
+ done
+ def sphere \<equiv> "{x::real^'n. norm x = 1}"
+ have pi:"\<And>x. x \<noteq> 0 \<Longrightarrow> pi x \<in> sphere" "\<And>x u. u>0 \<Longrightarrow> pi (u *\<^sub>R x) = pi x" unfolding pi_def sphere_def by auto
+
+ have "0\<in>s" using assms(2) and centre_in_cball[of 0 1] by auto
+ have front_smul:"\<forall>x\<in>frontier s. \<forall>u\<ge>0. u *\<^sub>R x \<in> s \<longleftrightarrow> u \<le> 1" proof(rule,rule,rule)
+ fix x u assume x:"x\<in>frontier s" and "(0::real)\<le>u"
+ hence "x\<noteq>0" using `0\<notin>frontier s` by auto
+ obtain v where v:"0 \<le> v" "v *\<^sub>R x \<in> frontier s" "\<forall>w>v. w *\<^sub>R x \<notin> s"
+ using compact_frontier_line_lemma[OF assms(1) `0\<in>s` `x\<noteq>0`] by auto
+ have "v=1" apply(rule ccontr) unfolding neq_iff apply(erule disjE) proof-
+ assume "v<1" thus False using v(3)[THEN spec[where x=1]] using x and fs by auto next
+ assume "v>1" thus False using assms(3)[THEN bspec[where x="v *\<^sub>R x"], THEN spec[where x="inverse v"]]
+ using v and x and fs unfolding inverse_less_1_iff by auto qed
+ show "u *\<^sub>R x \<in> s \<longleftrightarrow> u \<le> 1" apply rule using v(3)[unfolded `v=1`, THEN spec[where x=u]] proof-
+ assume "u\<le>1" thus "u *\<^sub>R x \<in> s" apply(cases "u=1")
+ using assms(3)[THEN bspec[where x=x], THEN spec[where x=u]] using `0\<le>u` and x and fs by auto qed auto qed
+
+ have "\<exists>surf. homeomorphism (frontier s) sphere pi surf"
+ apply(rule homeomorphism_compact) apply(rule compact_frontier[OF assms(1)])
+ apply(rule continuous_on_subset[OF contpi]) defer apply(rule set_ext,rule)
+ unfolding inj_on_def prefer 3 apply(rule,rule,rule)
+ proof- fix x assume "x\<in>pi ` frontier s" then obtain y where "y\<in>frontier s" "x = pi y" by auto
+ thus "x \<in> sphere" using pi(1)[of y] and `0 \<notin> frontier s` by auto
+ next fix x assume "x\<in>sphere" hence "norm x = 1" "x\<noteq>0" unfolding sphere_def by auto
+ then obtain u where "0 \<le> u" "u *\<^sub>R x \<in> frontier s" "\<forall>v>u. v *\<^sub>R x \<notin> s"
+ using compact_frontier_line_lemma[OF assms(1) `0\<in>s`, of x] by auto
+ thus "x \<in> pi ` frontier s" unfolding image_iff le_less pi_def apply(rule_tac x="u *\<^sub>R x" in bexI) using `norm x = 1` `0\<notin>frontier s` by auto
+ next fix x y assume as:"x \<in> frontier s" "y \<in> frontier s" "pi x = pi y"
+ hence xys:"x\<in>s" "y\<in>s" using fs by auto
+ from as(1,2) have nor:"norm x \<noteq> 0" "norm y \<noteq> 0" using `0\<notin>frontier s` by auto
+ from nor have x:"x = norm x *\<^sub>R ((inverse (norm y)) *\<^sub>R y)" unfolding as(3)[unfolded pi_def, THEN sym] by auto
+ from nor have y:"y = norm y *\<^sub>R ((inverse (norm x)) *\<^sub>R x)" unfolding as(3)[unfolded pi_def] by auto
+ have "0 \<le> norm y * inverse (norm x)" "0 \<le> norm x * inverse (norm y)"
+ unfolding divide_inverse[THEN sym] apply(rule_tac[!] divide_nonneg_pos) using nor by auto
+ hence "norm x = norm y" apply(rule_tac ccontr) unfolding neq_iff
+ using x y and front_smul[THEN bspec, OF as(1), THEN spec[where x="norm y * (inverse (norm x))"]]
+ using front_smul[THEN bspec, OF as(2), THEN spec[where x="norm x * (inverse (norm y))"]]
+ using xys nor by(auto simp add:field_simps divide_le_eq_1 divide_inverse[THEN sym])
+ thus "x = y" apply(subst injpi[THEN sym]) using as(3) by auto
+ qed(insert `0 \<notin> frontier s`, auto)
+ then obtain surf where surf:"\<forall>x\<in>frontier s. surf (pi x) = x" "pi ` frontier s = sphere" "continuous_on (frontier s) pi"
+ "\<forall>y\<in>sphere. pi (surf y) = y" "surf ` sphere = frontier s" "continuous_on sphere surf" unfolding homeomorphism_def by auto
+
+ have cont_surfpi:"continuous_on (UNIV - {0}) (surf \<circ> pi)" apply(rule continuous_on_compose, rule contpi)
+ apply(rule continuous_on_subset[of sphere], rule surf(6)) using pi(1) by auto
+
+ { fix x assume as:"x \<in> cball (0::real^'n) 1"
+ have "norm x *\<^sub>R surf (pi x) \<in> s" proof(cases "x=0 \<or> norm x = 1")
+ case False hence "pi x \<in> sphere" "norm x < 1" using pi(1)[of x] as by(auto simp add: dist_norm)
+ thus ?thesis apply(rule_tac assms(3)[rule_format, THEN DiffD1])
+ apply(rule_tac fs[unfolded subset_eq, rule_format])
+ unfolding surf(5)[THEN sym] by auto
+ next case True thus ?thesis apply rule defer unfolding pi_def apply(rule fs[unfolded subset_eq, rule_format])
+ unfolding surf(5)[unfolded sphere_def, THEN sym] using `0\<in>s` by auto qed } note hom = this
+
+ { fix x assume "x\<in>s"
+ hence "x \<in> (\<lambda>x. norm x *\<^sub>R surf (pi x)) ` cball 0 1" proof(cases "x=0")
+ case True show ?thesis unfolding image_iff True apply(rule_tac x=0 in bexI) by auto
+ next let ?a = "inverse (norm (surf (pi x)))"
+ case False hence invn:"inverse (norm x) \<noteq> 0" by auto
+ from False have pix:"pi x\<in>sphere" using pi(1) by auto
+ hence "pi (surf (pi x)) = pi x" apply(rule_tac surf(4)[rule_format]) by assumption
+ hence **:"norm x *\<^sub>R (?a *\<^sub>R surf (pi x)) = x" apply(rule_tac scaleR_left_imp_eq[OF invn]) unfolding pi_def using invn by auto
+ hence *:"?a * norm x > 0" and"?a > 0" "?a \<noteq> 0" using surf(5) `0\<notin>frontier s` apply -
+ apply(rule_tac mult_pos_pos) using False[unfolded zero_less_norm_iff[THEN sym]] by auto
+ have "norm (surf (pi x)) \<noteq> 0" using ** False by auto
+ hence "norm x = norm ((?a * norm x) *\<^sub>R surf (pi x))"
+ unfolding norm_scaleR abs_mult abs_norm_cancel abs_of_pos[OF `?a > 0`] by auto
+ moreover have "pi x = pi ((inverse (norm (surf (pi x))) * norm x) *\<^sub>R surf (pi x))"
+ unfolding pi(2)[OF *] surf(4)[rule_format, OF pix] ..
+ moreover have "surf (pi x) \<in> frontier s" using surf(5) pix by auto
+ hence "dist 0 (inverse (norm (surf (pi x))) *\<^sub>R x) \<le> 1" unfolding dist_norm
+ using ** and * using front_smul[THEN bspec[where x="surf (pi x)"], THEN spec[where x="norm x * ?a"]]
+ using False `x\<in>s` by(auto simp add:field_simps)
+ ultimately show ?thesis unfolding image_iff apply(rule_tac x="inverse (norm (surf(pi x))) *\<^sub>R x" in bexI)
+ apply(subst injpi[THEN sym]) unfolding abs_mult abs_norm_cancel abs_of_pos[OF `?a > 0`]
+ unfolding pi(2)[OF `?a > 0`] by auto
+ qed } note hom2 = this
+
+ show ?thesis apply(subst homeomorphic_sym) apply(rule homeomorphic_compact[where f="\<lambda>x. norm x *\<^sub>R surf (pi x)"])
+ apply(rule compact_cball) defer apply(rule set_ext, rule, erule imageE, drule hom)
+ prefer 4 apply(rule continuous_at_imp_continuous_on, rule) apply(rule_tac [3] hom2) proof-
+ fix x::"real^'n" assume as:"x \<in> cball 0 1"
+ thus "continuous (at x) (\<lambda>x. norm x *\<^sub>R surf (pi x))" proof(cases "x=0")
+ case False thus ?thesis apply(rule_tac continuous_mul, rule_tac continuous_at_norm)
+ using cont_surfpi unfolding continuous_on_eq_continuous_at[OF open_delete[OF open_UNIV]] o_def by auto
+ next guess a using UNIV_witness[where 'a = 'n] ..
+ obtain B where B:"\<forall>x\<in>s. norm x \<le> B" using compact_imp_bounded[OF assms(1)] unfolding bounded_iff by auto
+ hence "B > 0" using assms(2) unfolding subset_eq apply(erule_tac x="basis a" in ballE) defer apply(erule_tac x="basis a" in ballE)
+ unfolding Ball_def mem_cball dist_norm by (auto simp add: norm_basis[unfolded One_nat_def])
+ case True show ?thesis unfolding True continuous_at Lim_at apply(rule,rule) apply(rule_tac x="e / B" in exI)
+ apply(rule) apply(rule divide_pos_pos) prefer 3 apply(rule,rule,erule conjE)
+ unfolding norm_0 scaleR_zero_left dist_norm diff_0_right norm_scaleR abs_norm_cancel proof-
+ fix e and x::"real^'n" assume as:"norm x < e / B" "0 < norm x" "0<e"
+ hence "surf (pi x) \<in> frontier s" using pi(1)[of x] unfolding surf(5)[THEN sym] by auto
+ hence "norm (surf (pi x)) \<le> B" using B fs by auto
+ hence "norm x * norm (surf (pi x)) \<le> norm x * B" using as(2) by auto
+ also have "\<dots> < e / B * B" apply(rule mult_strict_right_mono) using as(1) `B>0` by auto
+ also have "\<dots> = e" using `B>0` by auto
+ finally show "norm x * norm (surf (pi x)) < e" by assumption
+ qed(insert `B>0`, auto) qed
+ next { fix x assume as:"surf (pi x) = 0"
+ have "x = 0" proof(rule ccontr)
+ assume "x\<noteq>0" hence "pi x \<in> sphere" using pi(1) by auto
+ hence "surf (pi x) \<in> frontier s" using surf(5) by auto
+ thus False using `0\<notin>frontier s` unfolding as by simp qed
+ } note surf_0 = this
+ show "inj_on (\<lambda>x. norm x *\<^sub>R surf (pi x)) (cball 0 1)" unfolding inj_on_def proof(rule,rule,rule)
+ fix x y assume as:"x \<in> cball 0 1" "y \<in> cball 0 1" "norm x *\<^sub>R surf (pi x) = norm y *\<^sub>R surf (pi y)"
+ thus "x=y" proof(cases "x=0 \<or> y=0")
+ case True thus ?thesis using as by(auto elim: surf_0) next
+ case False
+ hence "pi (surf (pi x)) = pi (surf (pi y))" using as(3)
+ using pi(2)[of "norm x" "surf (pi x)"] pi(2)[of "norm y" "surf (pi y)"] by auto
+ moreover have "pi x \<in> sphere" "pi y \<in> sphere" using pi(1) False by auto
+ ultimately have *:"pi x = pi y" using surf(4)[THEN bspec[where x="pi x"]] surf(4)[THEN bspec[where x="pi y"]] by auto
+ moreover have "norm x = norm y" using as(3)[unfolded *] using False by(auto dest:surf_0)
+ ultimately show ?thesis using injpi by auto qed qed
+ qed auto qed
+
+lemma homeomorphic_convex_compact_lemma: fixes s::"(real^'n::finite) set"
+ assumes "convex s" "compact s" "cball 0 1 \<subseteq> s"
+ shows "s homeomorphic (cball (0::real^'n) 1)"
+ apply(rule starlike_compact_projective[OF assms(2-3)]) proof(rule,rule,rule,erule conjE)
+ fix x u assume as:"x \<in> s" "0 \<le> u" "u < (1::real)"
+ hence "u *\<^sub>R x \<in> interior s" unfolding interior_def mem_Collect_eq
+ apply(rule_tac x="ball (u *\<^sub>R x) (1 - u)" in exI) apply(rule, rule open_ball)
+ unfolding centre_in_ball apply rule defer apply(rule) unfolding mem_ball proof-
+ fix y assume "dist (u *\<^sub>R x) y < 1 - u"
+ hence "inverse (1 - u) *\<^sub>R (y - u *\<^sub>R x) \<in> s"
+ using assms(3) apply(erule_tac subsetD) unfolding mem_cball dist_commute dist_norm
+ unfolding group_add_class.diff_0 group_add_class.diff_0_right norm_minus_cancel norm_scaleR
+ apply (rule mult_left_le_imp_le[of "1 - u"])
+ unfolding class_semiring.mul_a using `u<1` by auto
+ thus "y \<in> s" using assms(1)[unfolded convex_def, rule_format, of "inverse(1 - u) *\<^sub>R (y - u *\<^sub>R x)" x "1 - u" u]
+ using as unfolding scaleR_scaleR by auto qed auto
+ thus "u *\<^sub>R x \<in> s - frontier s" using frontier_def and interior_subset by auto qed
+
+lemma homeomorphic_convex_compact_cball: fixes e::real and s::"(real^'n::finite) set"
+ assumes "convex s" "compact s" "interior s \<noteq> {}" "0 < e"
+ shows "s homeomorphic (cball (b::real^'n::finite) e)"
+proof- obtain a where "a\<in>interior s" using assms(3) by auto
+ then obtain d where "d>0" and d:"cball a d \<subseteq> s" unfolding mem_interior_cball by auto
+ let ?d = "inverse d" and ?n = "0::real^'n"
+ have "cball ?n 1 \<subseteq> (\<lambda>x. inverse d *\<^sub>R (x - a)) ` s"
+ apply(rule, rule_tac x="d *\<^sub>R x + a" in image_eqI) defer
+ apply(rule d[unfolded subset_eq, rule_format]) using `d>0` unfolding mem_cball dist_norm
+ by(auto simp add: mult_right_le_one_le)
+ hence "(\<lambda>x. inverse d *\<^sub>R (x - a)) ` s homeomorphic cball ?n 1"
+ using homeomorphic_convex_compact_lemma[of "(\<lambda>x. ?d *\<^sub>R -a + ?d *\<^sub>R x) ` s", OF convex_affinity compact_affinity]
+ using assms(1,2) by(auto simp add: uminus_add_conv_diff scaleR_right_diff_distrib)
+ thus ?thesis apply(rule_tac homeomorphic_trans[OF _ homeomorphic_balls(2)[of 1 _ ?n]])
+ apply(rule homeomorphic_trans[OF homeomorphic_affinity[of "?d" s "?d *\<^sub>R -a"]])
+ using `d>0` `e>0` by(auto simp add: uminus_add_conv_diff scaleR_right_diff_distrib) qed
+
+lemma homeomorphic_convex_compact: fixes s::"(real^'n::finite) set" and t::"(real^'n) set"
+ assumes "convex s" "compact s" "interior s \<noteq> {}"
+ "convex t" "compact t" "interior t \<noteq> {}"
+ shows "s homeomorphic t"
+ using assms by(meson zero_less_one homeomorphic_trans homeomorphic_convex_compact_cball homeomorphic_sym)
+
+subsection {* Epigraphs of convex functions. *}
+
+definition "epigraph s (f::real^'n \<Rightarrow> real) = {xy. fstcart xy \<in> s \<and> f(fstcart xy) \<le> dest_vec1 (sndcart xy)}"
+
+lemma mem_epigraph: "(pastecart x (vec1 y)) \<in> epigraph s f \<longleftrightarrow> x \<in> s \<and> f x \<le> y" unfolding epigraph_def by auto
+
+lemma convex_epigraph:
+ "convex(epigraph s f) \<longleftrightarrow> convex_on s f \<and> convex s"
+ unfolding convex_def convex_on_def unfolding Ball_def forall_pastecart epigraph_def
+ unfolding mem_Collect_eq fstcart_pastecart sndcart_pastecart sndcart_add sndcart_cmul [where 'a=real, unfolded smult_conv_scaleR] fstcart_add fstcart_cmul [where 'a=real, unfolded smult_conv_scaleR]
+ unfolding Ball_def[symmetric] unfolding dest_vec1_add dest_vec1_cmul [where 'a=real, unfolded smult_conv_scaleR]
+ apply(subst forall_dest_vec1[THEN sym])+ by(meson real_le_refl real_le_trans add_mono mult_left_mono)
+
+lemma convex_epigraphI: assumes "convex_on s f" "convex s"
+ shows "convex(epigraph s f)" using assms unfolding convex_epigraph by auto
+
+lemma convex_epigraph_convex: "convex s \<Longrightarrow> (convex_on s f \<longleftrightarrow> convex(epigraph s f))"
+ using convex_epigraph by auto
+
+subsection {* Use this to derive general bound property of convex function. *}
+
+lemma forall_of_pastecart:
+ "(\<forall>p. P (\<lambda>x. fstcart (p x)) (\<lambda>x. sndcart (p x))) \<longleftrightarrow> (\<forall>x y. P x y)" apply meson
+ apply(erule_tac x="\<lambda>a. pastecart (x a) (y a)" in allE) unfolding o_def by auto
+
+lemma forall_of_pastecart':
+ "(\<forall>p. P (fstcart p) (sndcart p)) \<longleftrightarrow> (\<forall>x y. P x y)" apply meson
+ apply(erule_tac x="pastecart x y" in allE) unfolding o_def by auto
+
+lemma forall_of_dest_vec1: "(\<forall>v. P (\<lambda>x. dest_vec1 (v x))) \<longleftrightarrow> (\<forall>x. P x)"
+ apply rule apply rule apply(erule_tac x="(vec1 \<circ> x)" in allE) unfolding o_def vec1_dest_vec1 by auto
+
+lemma forall_of_dest_vec1': "(\<forall>v. P (dest_vec1 v)) \<longleftrightarrow> (\<forall>x. P x)"
+ apply rule apply rule apply(erule_tac x="(vec1 x)" in allE) defer apply rule
+ apply(erule_tac x="dest_vec1 v" in allE) unfolding o_def vec1_dest_vec1 by auto
+
+lemma convex_on:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s"
+ shows "convex_on s f \<longleftrightarrow> (\<forall>k u x. (\<forall>i\<in>{1..k::nat}. 0 \<le> u i \<and> x i \<in> s) \<and> setsum u {1..k} = 1 \<longrightarrow>
+ f (setsum (\<lambda>i. u i *\<^sub>R x i) {1..k} ) \<le> setsum (\<lambda>i. u i * f(x i)) {1..k} ) "
+ unfolding convex_epigraph_convex[OF assms] convex epigraph_def Ball_def mem_Collect_eq
+ unfolding sndcart_setsum[OF finite_atLeastAtMost] fstcart_setsum[OF finite_atLeastAtMost] dest_vec1_setsum[OF finite_atLeastAtMost]
+ unfolding fstcart_pastecart sndcart_pastecart sndcart_add sndcart_cmul [where 'a=real, unfolded smult_conv_scaleR] fstcart_add fstcart_cmul [where 'a=real, unfolded smult_conv_scaleR]
+ unfolding dest_vec1_add dest_vec1_cmul [where 'a=real, unfolded smult_conv_scaleR] apply(subst forall_of_pastecart)+ apply(subst forall_of_dest_vec1)+ apply rule
+ using assms[unfolded convex] apply simp apply(rule,rule,rule)
+ apply(erule_tac x=k in allE, erule_tac x=u in allE, erule_tac x=x in allE) apply rule apply rule apply rule defer
+ apply(rule_tac j="\<Sum>i = 1..k. u i * f (x i)" in real_le_trans)
+ defer apply(rule setsum_mono) apply(erule conjE)+ apply(erule_tac x=i in allE)apply(rule mult_left_mono)
+ using assms[unfolded convex] by auto
+
+subsection {* Convexity of general and special intervals. *}
+
+lemma is_interval_convex:
+ fixes s :: "(real ^ _) set"
+ assumes "is_interval s" shows "convex s"
+ unfolding convex_def apply(rule,rule,rule,rule,rule,rule,rule) proof-
+ fix x y u v assume as:"x \<in> s" "y \<in> s" "0 \<le> u" "0 \<le> v" "u + v = (1::real)"
+ hence *:"u = 1 - v" "1 - v \<ge> 0" and **:"v = 1 - u" "1 - u \<ge> 0" by auto
+ { fix a b assume "\<not> b \<le> u * a + v * b"
+ hence "u * a < (1 - v) * b" unfolding not_le using as(4) by(auto simp add: field_simps)
+ hence "a < b" unfolding * using as(4) *(2) apply(rule_tac mult_left_less_imp_less[of "1 - v"]) by(auto simp add: field_simps)
+ hence "a \<le> u * a + v * b" unfolding * using as(4) by (auto simp add: field_simps intro!:mult_right_mono)
+ } moreover
+ { fix a b assume "\<not> u * a + v * b \<le> a"
+ hence "v * b > (1 - u) * a" unfolding not_le using as(4) by(auto simp add: field_simps)
+ hence "a < b" unfolding * using as(4) apply(rule_tac mult_left_less_imp_less) by(auto simp add: ring_simps)
+ hence "u * a + v * b \<le> b" unfolding ** using **(2) as(3) by(auto simp add: field_simps intro!:mult_right_mono) }
+ ultimately show "u *\<^sub>R x + v *\<^sub>R y \<in> s" apply- apply(rule assms[unfolded is_interval_def, rule_format, OF as(1,2)])
+ using as(3-) dimindex_ge_1 apply- by(auto simp add: vector_component) qed
+
+lemma is_interval_connected:
+ fixes s :: "(real ^ _) set"
+ shows "is_interval s \<Longrightarrow> connected s"
+ using is_interval_convex convex_connected by auto
+
+lemma convex_interval: "convex {a .. b}" "convex {a<..<b::real^'n::finite}"
+ apply(rule_tac[!] is_interval_convex) using is_interval_interval by auto
+
+subsection {* On @{text "real^1"}, @{text "is_interval"}, @{text "convex"} and @{text "connected"} are all equivalent. *}
+
+lemma is_interval_1:
+ "is_interval s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. \<forall> x. dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b \<longrightarrow> x \<in> s)"
+ unfolding is_interval_def dest_vec1_def forall_1 by auto
+
+lemma is_interval_connected_1: "is_interval s \<longleftrightarrow> connected (s::(real^1) set)"
+ apply(rule, rule is_interval_connected, assumption) unfolding is_interval_1
+ apply(rule,rule,rule,rule,erule conjE,rule ccontr) proof-
+ fix a b x assume as:"connected s" "a \<in> s" "b \<in> s" "dest_vec1 a \<le> dest_vec1 x" "dest_vec1 x \<le> dest_vec1 b" "x\<notin>s"
+ hence *:"dest_vec1 a < dest_vec1 x" "dest_vec1 x < dest_vec1 b" apply(rule_tac [!] ccontr) unfolding not_less by auto
+ let ?halfl = "{z. inner (basis 1) z < dest_vec1 x} " and ?halfr = "{z. inner (basis 1) z > dest_vec1 x} "
+ { fix y assume "y \<in> s" have "y \<in> ?halfr \<union> ?halfl" apply(rule ccontr)
+ using as(6) `y\<in>s` by (auto simp add: inner_vector_def dest_vec1_eq [unfolded dest_vec1_def] dest_vec1_def) }
+ moreover have "a\<in>?halfl" "b\<in>?halfr" using * by (auto simp add: inner_vector_def dest_vec1_def)
+ hence "?halfl \<inter> s \<noteq> {}" "?halfr \<inter> s \<noteq> {}" using as(2-3) by auto
+ ultimately show False apply(rule_tac notE[OF as(1)[unfolded connected_def]])
+ apply(rule_tac x="?halfl" in exI, rule_tac x="?halfr" in exI)
+ apply(rule, rule open_halfspace_lt, rule, rule open_halfspace_gt) apply(rule, rule, rule ccontr)
+ by(auto simp add: basis_component field_simps) qed
+
+lemma is_interval_convex_1:
+ "is_interval s \<longleftrightarrow> convex (s::(real^1) set)"
+ using is_interval_convex convex_connected is_interval_connected_1 by auto
+
+lemma convex_connected_1:
+ "connected s \<longleftrightarrow> convex (s::(real^1) set)"
+ using is_interval_convex convex_connected is_interval_connected_1 by auto
+
+subsection {* Another intermediate value theorem formulation. *}
+
+lemma ivt_increasing_component_on_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
+ assumes "dest_vec1 a \<le> dest_vec1 b" "continuous_on {a .. b} f" "(f a)$k \<le> y" "y \<le> (f b)$k"
+ shows "\<exists>x\<in>{a..b}. (f x)$k = y"
+proof- have "f a \<in> f ` {a..b}" "f b \<in> f ` {a..b}" apply(rule_tac[!] imageI)
+ using assms(1) by(auto simp add: vector_less_eq_def dest_vec1_def)
+ thus ?thesis using connected_ivt_component[of "f ` {a..b}" "f a" "f b" k y]
+ using connected_continuous_image[OF assms(2) convex_connected[OF convex_interval(1)]]
+ using assms by(auto intro!: imageI) qed
+
+lemma ivt_increasing_component_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
+ assumes "dest_vec1 a \<le> dest_vec1 b"
+ "\<forall>x\<in>{a .. b}. continuous (at x) f" "f a$k \<le> y" "y \<le> f b$k"
+ shows "\<exists>x\<in>{a..b}. (f x)$k = y"
+ apply(rule ivt_increasing_component_on_1) using assms using continuous_at_imp_continuous_on by auto
+
+lemma ivt_decreasing_component_on_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
+ assumes "dest_vec1 a \<le> dest_vec1 b" "continuous_on {a .. b} f" "(f b)$k \<le> y" "y \<le> (f a)$k"
+ shows "\<exists>x\<in>{a..b}. (f x)$k = y"
+ apply(subst neg_equal_iff_equal[THEN sym]) unfolding vector_uminus_component[THEN sym]
+ apply(rule ivt_increasing_component_on_1) using assms using continuous_on_neg
+ by(auto simp add:vector_uminus_component)
+
+lemma ivt_decreasing_component_1: fixes f::"real^1 \<Rightarrow> real^'n::finite"
+ assumes "dest_vec1 a \<le> dest_vec1 b" "\<forall>x\<in>{a .. b}. continuous (at x) f" "f b$k \<le> y" "y \<le> f a$k"
+ shows "\<exists>x\<in>{a..b}. (f x)$k = y"
+ apply(rule ivt_decreasing_component_on_1) using assms using continuous_at_imp_continuous_on by auto
+
+subsection {* A bound within a convex hull, and so an interval. *}
+
+lemma convex_on_convex_hull_bound:
+ fixes s :: "(real ^ _) set"
+ assumes "convex_on (convex hull s) f" "\<forall>x\<in>s. f x \<le> b"
+ shows "\<forall>x\<in> convex hull s. f x \<le> b" proof
+ fix x assume "x\<in>convex hull s"
+ then obtain k u v where obt:"\<forall>i\<in>{1..k::nat}. 0 \<le> u i \<and> v i \<in> s" "setsum u {1..k} = 1" "(\<Sum>i = 1..k. u i *\<^sub>R v i) = x"
+ unfolding convex_hull_indexed mem_Collect_eq by auto
+ have "(\<Sum>i = 1..k. u i * f (v i)) \<le> b" using setsum_mono[of "{1..k}" "\<lambda>i. u i * f (v i)" "\<lambda>i. u i * b"]
+ unfolding setsum_left_distrib[THEN sym] obt(2) mult_1 apply(drule_tac meta_mp) apply(rule mult_left_mono)
+ using assms(2) obt(1) by auto
+ thus "f x \<le> b" using assms(1)[unfolded convex_on[OF convex_convex_hull], rule_format, of k u v]
+ unfolding obt(2-3) using obt(1) and hull_subset[unfolded subset_eq, rule_format, of _ s] by auto qed
+
+lemma unit_interval_convex_hull:
+ "{0::real^'n::finite .. 1} = convex hull {x. \<forall>i. (x$i = 0) \<or> (x$i = 1)}" (is "?int = convex hull ?points")
+proof- have 01:"{0,1} \<subseteq> convex hull ?points" apply rule apply(rule_tac hull_subset[unfolded subset_eq, rule_format]) by auto
+ { fix n x assume "x\<in>{0::real^'n .. 1}" "n \<le> CARD('n)" "card {i. x$i \<noteq> 0} \<le> n"
+ hence "x\<in>convex hull ?points" proof(induct n arbitrary: x)
+ case 0 hence "x = 0" apply(subst Cart_eq) apply rule by auto
+ thus "x\<in>convex hull ?points" using 01 by auto
+ next
+ case (Suc n) show "x\<in>convex hull ?points" proof(cases "{i. x$i \<noteq> 0} = {}")
+ case True hence "x = 0" unfolding Cart_eq by auto
+ thus "x\<in>convex hull ?points" using 01 by auto
+ next
+ case False def xi \<equiv> "Min ((\<lambda>i. x$i) ` {i. x$i \<noteq> 0})"
+ have "xi \<in> (\<lambda>i. x$i) ` {i. x$i \<noteq> 0}" unfolding xi_def apply(rule Min_in) using False by auto
+ then obtain i where i':"x$i = xi" "x$i \<noteq> 0" by auto
+ have i:"\<And>j. x$j > 0 \<Longrightarrow> x$i \<le> x$j"
+ unfolding i'(1) xi_def apply(rule_tac Min_le) unfolding image_iff
+ defer apply(rule_tac x=j in bexI) using i' by auto
+ have i01:"x$i \<le> 1" "x$i > 0" using Suc(2)[unfolded mem_interval,rule_format,of i] using i'(2) `x$i \<noteq> 0`
+ by(auto simp add: Cart_lambda_beta)
+ show ?thesis proof(cases "x$i=1")
+ case True have "\<forall>j\<in>{i. x$i \<noteq> 0}. x$j = 1" apply(rule, rule ccontr) unfolding mem_Collect_eq proof-
+ fix j assume "x $ j \<noteq> 0" "x $ j \<noteq> 1"
+ hence j:"x$j \<in> {0<..<1}" using Suc(2) by(auto simp add: vector_less_eq_def elim!:allE[where x=j])
+ hence "x$j \<in> op $ x ` {i. x $ i \<noteq> 0}" by auto
+ hence "x$j \<ge> x$i" unfolding i'(1) xi_def apply(rule_tac Min_le) by auto
+ thus False using True Suc(2) j by(auto simp add: vector_less_eq_def elim!:ballE[where x=j]) qed
+ thus "x\<in>convex hull ?points" apply(rule_tac hull_subset[unfolded subset_eq, rule_format])
+ by(auto simp add: Cart_lambda_beta)
+ next let ?y = "\<lambda>j. if x$j = 0 then 0 else (x$j - x$i) / (1 - x$i)"
+ case False hence *:"x = x$i *\<^sub>R (\<chi> j. if x$j = 0 then 0 else 1) + (1 - x$i) *\<^sub>R (\<chi> j. ?y j)" unfolding Cart_eq
+ by(auto simp add: Cart_lambda_beta vector_add_component vector_smult_component vector_minus_component field_simps)
+ { fix j have "x$j \<noteq> 0 \<Longrightarrow> 0 \<le> (x $ j - x $ i) / (1 - x $ i)" "(x $ j - x $ i) / (1 - x $ i) \<le> 1"
+ apply(rule_tac divide_nonneg_pos) using i(1)[of j] using False i01
+ using Suc(2)[unfolded mem_interval, rule_format, of j] by(auto simp add:field_simps Cart_lambda_beta)
+ hence "0 \<le> ?y j \<and> ?y j \<le> 1" by auto }
+ moreover have "i\<in>{j. x$j \<noteq> 0} - {j. ((\<chi> j. ?y j)::real^'n) $ j \<noteq> 0}" using i01 by(auto simp add: Cart_lambda_beta)
+ hence "{j. x$j \<noteq> 0} \<noteq> {j. ((\<chi> j. ?y j)::real^'n::finite) $ j \<noteq> 0}" by auto
+ hence **:"{j. ((\<chi> j. ?y j)::real^'n::finite) $ j \<noteq> 0} \<subset> {j. x$j \<noteq> 0}" apply - apply rule by(auto simp add: Cart_lambda_beta)
+ have "card {j. ((\<chi> j. ?y j)::real^'n) $ j \<noteq> 0} \<le> n" using less_le_trans[OF psubset_card_mono[OF _ **] Suc(4)] by auto
+ ultimately show ?thesis apply(subst *) apply(rule convex_convex_hull[unfolded convex_def, rule_format])
+ apply(rule_tac hull_subset[unfolded subset_eq, rule_format]) defer apply(rule Suc(1))
+ unfolding mem_interval using i01 Suc(3) by (auto simp add: Cart_lambda_beta)
+ qed qed qed } note * = this
+ show ?thesis apply rule defer apply(rule hull_minimal) unfolding subset_eq prefer 3 apply rule
+ apply(rule_tac n2="CARD('n)" in *) prefer 3 apply(rule card_mono) using 01 and convex_interval(1) prefer 5 apply - apply rule
+ unfolding mem_interval apply rule unfolding mem_Collect_eq apply(erule_tac x=i in allE)
+ by(auto simp add: vector_less_eq_def mem_def[of _ convex]) qed
+
+subsection {* And this is a finite set of vertices. *}
+
+lemma unit_cube_convex_hull: obtains s where "finite s" "{0 .. 1::real^'n::finite} = convex hull s"
+ apply(rule that[of "{x::real^'n::finite. \<forall>i. x$i=0 \<or> x$i=1}"])
+ apply(rule finite_subset[of _ "(\<lambda>s. (\<chi> i. if i\<in>s then 1::real else 0)::real^'n::finite) ` UNIV"])
+ prefer 3 apply(rule unit_interval_convex_hull) apply rule unfolding mem_Collect_eq proof-
+ fix x::"real^'n" assume as:"\<forall>i. x $ i = 0 \<or> x $ i = 1"
+ show "x \<in> (\<lambda>s. \<chi> i. if i \<in> s then 1 else 0) ` UNIV" apply(rule image_eqI[where x="{i. x$i = 1}"])
+ unfolding Cart_eq using as by(auto simp add:Cart_lambda_beta) qed auto
+
+subsection {* Hence any cube (could do any nonempty interval). *}
+
+lemma cube_convex_hull:
+ assumes "0 < d" obtains s::"(real^'n::finite) set" where "finite s" "{x - (\<chi> i. d) .. x + (\<chi> i. d)} = convex hull s" proof-
+ let ?d = "(\<chi> i. d)::real^'n"
+ have *:"{x - ?d .. x + ?d} = (\<lambda>y. x - ?d + (2 * d) *\<^sub>R y) ` {0 .. 1}" apply(rule set_ext, rule)
+ unfolding image_iff defer apply(erule bexE) proof-
+ fix y assume as:"y\<in>{x - ?d .. x + ?d}"
+ { fix i::'n have "x $ i \<le> d + y $ i" "y $ i \<le> d + x $ i" using as[unfolded mem_interval, THEN spec[where x=i]]
+ by(auto simp add: vector_component)
+ hence "1 \<ge> inverse d * (x $ i - y $ i)" "1 \<ge> inverse d * (y $ i - x $ i)"
+ apply(rule_tac[!] mult_left_le_imp_le[OF _ assms]) unfolding mult_assoc[THEN sym]
+ using assms by(auto simp add: field_simps right_inverse)
+ hence "inverse d * (x $ i * 2) \<le> 2 + inverse d * (y $ i * 2)"
+ "inverse d * (y $ i * 2) \<le> 2 + inverse d * (x $ i * 2)" by(auto simp add:field_simps) }
+ hence "inverse (2 * d) *\<^sub>R (y - (x - ?d)) \<in> {0..1}" unfolding mem_interval using assms
+ by(auto simp add: Cart_eq vector_component_simps field_simps)
+ thus "\<exists>z\<in>{0..1}. y = x - ?d + (2 * d) *\<^sub>R z" apply- apply(rule_tac x="inverse (2 * d) *\<^sub>R (y - (x - ?d))" in bexI)
+ using assms by(auto simp add: Cart_eq vector_less_eq_def Cart_lambda_beta)
+ next
+ fix y z assume as:"z\<in>{0..1}" "y = x - ?d + (2*d) *\<^sub>R z"
+ have "\<And>i. 0 \<le> d * z $ i \<and> d * z $ i \<le> d" using assms as(1)[unfolded mem_interval] apply(erule_tac x=i in allE)
+ apply rule apply(rule mult_nonneg_nonneg) prefer 3 apply(rule mult_right_le_one_le)
+ using assms by(auto simp add: vector_component_simps Cart_eq)
+ thus "y \<in> {x - ?d..x + ?d}" unfolding as(2) mem_interval apply- apply rule using as(1)[unfolded mem_interval]
+ apply(erule_tac x=i in allE) using assms by(auto simp add: vector_component_simps Cart_eq) qed
+ obtain s where "finite s" "{0..1::real^'n} = convex hull s" using unit_cube_convex_hull by auto
+ thus ?thesis apply(rule_tac that[of "(\<lambda>y. x - ?d + (2 * d) *\<^sub>R y)` s"]) unfolding * and convex_hull_affinity by auto qed
+
+subsection {* Bounded convex function on open set is continuous. *}
+
+lemma convex_on_bounded_continuous:
+ fixes s :: "(real ^ _) set"
+ assumes "open s" "convex_on s f" "\<forall>x\<in>s. abs(f x) \<le> b"
+ shows "continuous_on s f"
+ apply(rule continuous_at_imp_continuous_on) unfolding continuous_at_real_range proof(rule,rule,rule)
+ fix x e assume "x\<in>s" "(0::real) < e"
+ def B \<equiv> "abs b + 1"
+ have B:"0 < B" "\<And>x. x\<in>s \<Longrightarrow> abs (f x) \<le> B"
+ unfolding B_def defer apply(drule assms(3)[rule_format]) by auto
+ obtain k where "k>0"and k:"cball x k \<subseteq> s" using assms(1)[unfolded open_contains_cball, THEN bspec[where x=x]] using `x\<in>s` by auto
+ show "\<exists>d>0. \<forall>x'. norm (x' - x) < d \<longrightarrow> \<bar>f x' - f x\<bar> < e"
+ apply(rule_tac x="min (k / 2) (e / (2 * B) * k)" in exI) apply rule defer proof(rule,rule)
+ fix y assume as:"norm (y - x) < min (k / 2) (e / (2 * B) * k)"
+ show "\<bar>f y - f x\<bar> < e" proof(cases "y=x")
+ case False def t \<equiv> "k / norm (y - x)"
+ have "2 < t" "0<t" unfolding t_def using as False and `k>0` by(auto simp add:field_simps)
+ have "y\<in>s" apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
+ apply(rule order_trans[of _ "2 * norm (x - y)"]) using as by(auto simp add: field_simps norm_minus_commute)
+ { def w \<equiv> "x + t *\<^sub>R (y - x)"
+ have "w\<in>s" unfolding w_def apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
+ unfolding t_def using `k>0` by auto
+ have "(1 / t) *\<^sub>R x + - x + ((t - 1) / t) *\<^sub>R x = (1 / t - 1 + (t - 1) / t) *\<^sub>R x" by (auto simp add: algebra_simps)
+ also have "\<dots> = 0" using `t>0` by(auto simp add:field_simps)
+ finally have w:"(1 / t) *\<^sub>R w + ((t - 1) / t) *\<^sub>R x = y" unfolding w_def using False and `t>0` by (auto simp add: algebra_simps)
+ have "2 * B < e * t" unfolding t_def using `0<e` `0<k` `B>0` and as and False by (auto simp add:field_simps)
+ hence "(f w - f x) / t < e"
+ using B(2)[OF `w\<in>s`] and B(2)[OF `x\<in>s`] using `t>0` by(auto simp add:field_simps)
+ hence th1:"f y - f x < e" apply- apply(rule le_less_trans) defer apply assumption
+ using assms(2)[unfolded convex_on_def,rule_format,of w x "1/t" "(t - 1)/t", unfolded w]
+ using `0<t` `2<t` and `x\<in>s` `w\<in>s` by(auto simp add:field_simps) }
+ moreover
+ { def w \<equiv> "x - t *\<^sub>R (y - x)"
+ have "w\<in>s" unfolding w_def apply(rule k[unfolded subset_eq,rule_format]) unfolding mem_cball dist_norm
+ unfolding t_def using `k>0` by auto
+ have "(1 / (1 + t)) *\<^sub>R x + (t / (1 + t)) *\<^sub>R x = (1 / (1 + t) + t / (1 + t)) *\<^sub>R x" by (auto simp add: algebra_simps)
+ also have "\<dots>=x" using `t>0` by (auto simp add:field_simps)
+ finally have w:"(1 / (1+t)) *\<^sub>R w + (t / (1 + t)) *\<^sub>R y = x" unfolding w_def using False and `t>0` by (auto simp add: algebra_simps)
+ have "2 * B < e * t" unfolding t_def using `0<e` `0<k` `B>0` and as and False by (auto simp add:field_simps)
+ hence *:"(f w - f y) / t < e" using B(2)[OF `w\<in>s`] and B(2)[OF `y\<in>s`] using `t>0` by(auto simp add:field_simps)
+ have "f x \<le> 1 / (1 + t) * f w + (t / (1 + t)) * f y"
+ using assms(2)[unfolded convex_on_def,rule_format,of w y "1/(1+t)" "t / (1+t)",unfolded w]
+ using `0<t` `2<t` and `y\<in>s` `w\<in>s` by (auto simp add:field_simps)
+ also have "\<dots> = (f w + t * f y) / (1 + t)" using `t>0` unfolding real_divide_def by (auto simp add:field_simps)
+ also have "\<dots> < e + f y" using `t>0` * `e>0` by(auto simp add:field_simps)
+ finally have "f x - f y < e" by auto }
+ ultimately show ?thesis by auto
+ qed(insert `0<e`, auto)
+ qed(insert `0<e` `0<k` `0<B`, auto simp add:field_simps intro!:mult_pos_pos) qed
+
+subsection {* Upper bound on a ball implies upper and lower bounds. *}
+
+lemma convex_bounds_lemma:
+ fixes x :: "real ^ _"
+ assumes "convex_on (cball x e) f" "\<forall>y \<in> cball x e. f y \<le> b"
+ shows "\<forall>y \<in> cball x e. abs(f y) \<le> b + 2 * abs(f x)"
+ apply(rule) proof(cases "0 \<le> e") case True
+ fix y assume y:"y\<in>cball x e" def z \<equiv> "2 *\<^sub>R x - y"
+ have *:"x - (2 *\<^sub>R x - y) = y - x" by vector
+ have z:"z\<in>cball x e" using y unfolding z_def mem_cball dist_norm * by(auto simp add: norm_minus_commute)
+ have "(1 / 2) *\<^sub>R y + (1 / 2) *\<^sub>R z = x" unfolding z_def by (auto simp add: algebra_simps)
+ thus "\<bar>f y\<bar> \<le> b + 2 * \<bar>f x\<bar>" using assms(1)[unfolded convex_on_def,rule_format, OF y z, of "1/2" "1/2"]
+ using assms(2)[rule_format,OF y] assms(2)[rule_format,OF z] by(auto simp add:field_simps)
+next case False fix y assume "y\<in>cball x e"
+ hence "dist x y < 0" using False unfolding mem_cball not_le by (auto simp del: dist_not_less_zero)
+ thus "\<bar>f y\<bar> \<le> b + 2 * \<bar>f x\<bar>" using zero_le_dist[of x y] by auto qed
+
+subsection {* Hence a convex function on an open set is continuous. *}
+
+lemma convex_on_continuous:
+ assumes "open (s::(real^'n::finite) set)" "convex_on s f"
+ shows "continuous_on s f"
+ unfolding continuous_on_eq_continuous_at[OF assms(1)] proof
+ note dimge1 = dimindex_ge_1[where 'a='n]
+ fix x assume "x\<in>s"
+ then obtain e where e:"cball x e \<subseteq> s" "e>0" using assms(1) unfolding open_contains_cball by auto
+ def d \<equiv> "e / real CARD('n)"
+ have "0 < d" unfolding d_def using `e>0` dimge1 by(rule_tac divide_pos_pos, auto)
+ let ?d = "(\<chi> i. d)::real^'n"
+ obtain c where c:"finite c" "{x - ?d..x + ?d} = convex hull c" using cube_convex_hull[OF `d>0`, of x] by auto
+ have "x\<in>{x - ?d..x + ?d}" using `d>0` unfolding mem_interval by(auto simp add:vector_component_simps)
+ hence "c\<noteq>{}" apply(rule_tac ccontr) using c by(auto simp add:convex_hull_empty)
+ def k \<equiv> "Max (f ` c)"
+ have "convex_on {x - ?d..x + ?d} f" apply(rule convex_on_subset[OF assms(2)])
+ apply(rule subset_trans[OF _ e(1)]) unfolding subset_eq mem_cball proof
+ fix z assume z:"z\<in>{x - ?d..x + ?d}"
+ have e:"e = setsum (\<lambda>i. d) (UNIV::'n set)" unfolding setsum_constant d_def using dimge1
+ by (metis card_enum field_simps d_def not_one_le_zero of_nat_le_iff real_eq_of_nat real_of_nat_1)
+ show "dist x z \<le> e" unfolding dist_norm e apply(rule_tac order_trans[OF norm_le_l1], rule setsum_mono)
+ using z[unfolded mem_interval] apply(erule_tac x=i in allE) by(auto simp add:field_simps vector_component_simps) qed
+ hence k:"\<forall>y\<in>{x - ?d..x + ?d}. f y \<le> k" unfolding c(2) apply(rule_tac convex_on_convex_hull_bound) apply assumption
+ unfolding k_def apply(rule, rule Max_ge) using c(1) by auto
+ have "d \<le> e" unfolding d_def apply(rule mult_imp_div_pos_le) using `e>0` dimge1 unfolding mult_le_cancel_left1 using real_dimindex_ge_1 by auto
+ hence dsube:"cball x d \<subseteq> cball x e" unfolding subset_eq Ball_def mem_cball by auto
+ have conv:"convex_on (cball x d) f" apply(rule convex_on_subset, rule convex_on_subset[OF assms(2)]) apply(rule e(1)) using dsube by auto
+ hence "\<forall>y\<in>cball x d. abs (f y) \<le> k + 2 * abs (f x)" apply(rule_tac convex_bounds_lemma) apply assumption proof
+ fix y assume y:"y\<in>cball x d"
+ { fix i::'n have "x $ i - d \<le> y $ i" "y $ i \<le> x $ i + d"
+ using order_trans[OF component_le_norm y[unfolded mem_cball dist_norm], of i] by(auto simp add: vector_component) }
+ thus "f y \<le> k" apply(rule_tac k[rule_format]) unfolding mem_cball mem_interval dist_norm
+ by(auto simp add: vector_component_simps) qed
+ hence "continuous_on (ball x d) f" apply(rule_tac convex_on_bounded_continuous)
+ apply(rule open_ball, rule convex_on_subset[OF conv], rule ball_subset_cball)
+ apply force
+ done
+ thus "continuous (at x) f" unfolding continuous_on_eq_continuous_at[OF open_ball]
+ using `d>0` by auto
+qed
+
+subsection {* Line segments, Starlike Sets, etc.*}
+
+(* Use the same overloading tricks as for intervals, so that
+ segment[a,b] is closed and segment(a,b) is open relative to affine hull. *)
+
+definition
+ midpoint :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 'n" where
+ "midpoint a b = (inverse (2::real)) *\<^sub>R (a + b)"
+
+definition
+ open_segment :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> (real ^ 'n) set" where
+ "open_segment a b = {(1 - u) *\<^sub>R a + u *\<^sub>R b | u::real. 0 < u \<and> u < 1}"
+
+definition
+ closed_segment :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> (real ^ 'n) set" where
+ "closed_segment a b = {(1 - u) *\<^sub>R a + u *\<^sub>R b | u::real. 0 \<le> u \<and> u \<le> 1}"
+
+definition "between = (\<lambda> (a,b). closed_segment a b)"
+
+lemmas segment = open_segment_def closed_segment_def
+
+definition "starlike s \<longleftrightarrow> (\<exists>a\<in>s. \<forall>x\<in>s. closed_segment a x \<subseteq> s)"
+
+lemma midpoint_refl: "midpoint x x = x"
+ unfolding midpoint_def unfolding scaleR_right_distrib unfolding scaleR_left_distrib[THEN sym] by auto
+
+lemma midpoint_sym: "midpoint a b = midpoint b a" unfolding midpoint_def by (auto simp add: scaleR_right_distrib)
+
+lemma dist_midpoint:
+ "dist a (midpoint a b) = (dist a b) / 2" (is ?t1)
+ "dist b (midpoint a b) = (dist a b) / 2" (is ?t2)
+ "dist (midpoint a b) a = (dist a b) / 2" (is ?t3)
+ "dist (midpoint a b) b = (dist a b) / 2" (is ?t4)
+proof-
+ have *: "\<And>x y::real^'n::finite. 2 *\<^sub>R x = - y \<Longrightarrow> norm x = (norm y) / 2" unfolding equation_minus_iff by auto
+ have **:"\<And>x y::real^'n::finite. 2 *\<^sub>R x = y \<Longrightarrow> norm x = (norm y) / 2" by auto
+ note scaleR_right_distrib [simp]
+ show ?t1 unfolding midpoint_def dist_norm apply (rule **) by(auto,vector)
+ show ?t2 unfolding midpoint_def dist_norm apply (rule *) by(auto,vector)
+ show ?t3 unfolding midpoint_def dist_norm apply (rule *) by(auto,vector)
+ show ?t4 unfolding midpoint_def dist_norm apply (rule **) by(auto,vector) qed
+
+lemma midpoint_eq_endpoint:
+ "midpoint a b = a \<longleftrightarrow> a = (b::real^'n::finite)"
+ "midpoint a b = b \<longleftrightarrow> a = b"
+ unfolding dist_eq_0_iff[where 'a="real^'n", THEN sym] dist_midpoint by auto
+
+lemma convex_contains_segment:
+ "convex s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. closed_segment a b \<subseteq> s)"
+ unfolding convex_alt closed_segment_def by auto
+
+lemma convex_imp_starlike:
+ "convex s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> starlike s"
+ unfolding convex_contains_segment starlike_def by auto
+
+lemma segment_convex_hull:
+ "closed_segment a b = convex hull {a,b}" proof-
+ have *:"\<And>x. {x} \<noteq> {}" by auto
+ have **:"\<And>u v. u + v = 1 \<longleftrightarrow> u = 1 - (v::real)" by auto
+ show ?thesis unfolding segment convex_hull_insert[OF *] convex_hull_singleton apply(rule set_ext)
+ unfolding mem_Collect_eq apply(rule,erule exE)
+ apply(rule_tac x="1 - u" in exI) apply rule defer apply(rule_tac x=u in exI) defer
+ apply(erule exE, (erule conjE)?)+ apply(rule_tac x="1 - u" in exI) unfolding ** by auto qed
+
+lemma convex_segment: "convex (closed_segment a b)"
+ unfolding segment_convex_hull by(rule convex_convex_hull)
+
+lemma ends_in_segment: "a \<in> closed_segment a b" "b \<in> closed_segment a b"
+ unfolding segment_convex_hull apply(rule_tac[!] hull_subset[unfolded subset_eq, rule_format]) by auto
+
+lemma segment_furthest_le:
+ assumes "x \<in> closed_segment a b" shows "norm(y - x) \<le> norm(y - a) \<or> norm(y - x) \<le> norm(y - b)" proof-
+ obtain z where "z\<in>{a, b}" "norm (x - y) \<le> norm (z - y)" using simplex_furthest_le[of "{a, b}" y]
+ using assms[unfolded segment_convex_hull] by auto
+ thus ?thesis by(auto simp add:norm_minus_commute) qed
+
+lemma segment_bound:
+ assumes "x \<in> closed_segment a b"
+ shows "norm(x - a) \<le> norm(b - a)" "norm(x - b) \<le> norm(b - a)"
+ using segment_furthest_le[OF assms, of a]
+ using segment_furthest_le[OF assms, of b]
+ by (auto simp add:norm_minus_commute)
+
+lemma segment_refl:"closed_segment a a = {a}" unfolding segment by (auto simp add: algebra_simps)
+
+lemma between_mem_segment: "between (a,b) x \<longleftrightarrow> x \<in> closed_segment a b"
+ unfolding between_def mem_def by auto
+
+lemma between:"between (a,b) (x::real^'n::finite) \<longleftrightarrow> dist a b = (dist a x) + (dist x b)"
+proof(cases "a = b")
+ case True thus ?thesis unfolding between_def split_conv mem_def[of x, symmetric]
+ by(auto simp add:segment_refl dist_commute) next
+ case False hence Fal:"norm (a - b) \<noteq> 0" and Fal2: "norm (a - b) > 0" by auto
+ have *:"\<And>u. a - ((1 - u) *\<^sub>R a + u *\<^sub>R b) = u *\<^sub>R (a - b)" by (auto simp add: algebra_simps)
+ show ?thesis unfolding between_def split_conv mem_def[of x, symmetric] closed_segment_def mem_Collect_eq
+ apply rule apply(erule exE, (erule conjE)+) apply(subst dist_triangle_eq) proof-
+ fix u assume as:"x = (1 - u) *\<^sub>R a + u *\<^sub>R b" "0 \<le> u" "u \<le> 1"
+ hence *:"a - x = u *\<^sub>R (a - b)" "x - b = (1 - u) *\<^sub>R (a - b)"
+ unfolding as(1) by(auto simp add:algebra_simps)
+ show "norm (a - x) *\<^sub>R (x - b) = norm (x - b) *\<^sub>R (a - x)"
+ unfolding norm_minus_commute[of x a] * Cart_eq using as(2,3)
+ by(auto simp add: vector_component_simps field_simps)
+ next assume as:"dist a b = dist a x + dist x b"
+ have "norm (a - x) / norm (a - b) \<le> 1" unfolding divide_le_eq_1_pos[OF Fal2] unfolding as[unfolded dist_norm] norm_ge_zero by auto
+ thus "\<exists>u. x = (1 - u) *\<^sub>R a + u *\<^sub>R b \<and> 0 \<le> u \<and> u \<le> 1" apply(rule_tac x="dist a x / dist a b" in exI)
+ unfolding dist_norm Cart_eq apply- apply rule defer apply(rule, rule divide_nonneg_pos) prefer 4 proof rule
+ fix i::'n have "((1 - norm (a - x) / norm (a - b)) *\<^sub>R a + (norm (a - x) / norm (a - b)) *\<^sub>R b) $ i =
+ ((norm (a - b) - norm (a - x)) * (a $ i) + norm (a - x) * (b $ i)) / norm (a - b)"
+ using Fal by(auto simp add:vector_component_simps field_simps)
+ also have "\<dots> = x$i" apply(rule divide_eq_imp[OF Fal])
+ unfolding as[unfolded dist_norm] using as[unfolded dist_triangle_eq Cart_eq,rule_format, of i]
+ by(auto simp add:field_simps vector_component_simps)
+ finally show "x $ i = ((1 - norm (a - x) / norm (a - b)) *\<^sub>R a + (norm (a - x) / norm (a - b)) *\<^sub>R b) $ i" by auto
+ qed(insert Fal2, auto) qed qed
+
+lemma between_midpoint: fixes a::"real^'n::finite" shows
+ "between (a,b) (midpoint a b)" (is ?t1)
+ "between (b,a) (midpoint a b)" (is ?t2)
+proof- have *:"\<And>x y z. x = (1/2::real) *\<^sub>R z \<Longrightarrow> y = (1/2) *\<^sub>R z \<Longrightarrow> norm z = norm x + norm y" by auto
+ show ?t1 ?t2 unfolding between midpoint_def dist_norm apply(rule_tac[!] *)
+ by(auto simp add:field_simps Cart_eq vector_component_simps) qed
+
+lemma between_mem_convex_hull:
+ "between (a,b) x \<longleftrightarrow> x \<in> convex hull {a,b}"
+ unfolding between_mem_segment segment_convex_hull ..
+
+subsection {* Shrinking towards the interior of a convex set. *}
+
+lemma mem_interior_convex_shrink:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "c \<in> interior s" "x \<in> s" "0 < e" "e \<le> 1"
+ shows "x - e *\<^sub>R (x - c) \<in> interior s"
+proof- obtain d where "d>0" and d:"ball c d \<subseteq> s" using assms(2) unfolding mem_interior by auto
+ show ?thesis unfolding mem_interior apply(rule_tac x="e*d" in exI)
+ apply(rule) defer unfolding subset_eq Ball_def mem_ball proof(rule,rule)
+ fix y assume as:"dist (x - e *\<^sub>R (x - c)) y < e * d"
+ have *:"y = (1 - (1 - e)) *\<^sub>R ((1 / e) *\<^sub>R y - ((1 - e) / e) *\<^sub>R x) + (1 - e) *\<^sub>R x" using `e>0` by (auto simp add: scaleR_left_diff_distrib scaleR_right_diff_distrib)
+ have "dist c ((1 / e) *\<^sub>R y - ((1 - e) / e) *\<^sub>R x) = abs(1/e) * norm (e *\<^sub>R c - y + (1 - e) *\<^sub>R x)"
+ unfolding dist_norm unfolding norm_scaleR[THEN sym] apply(rule norm_eqI) using `e>0`
+ by(auto simp add:vector_component_simps Cart_eq field_simps)
+ also have "\<dots> = abs(1/e) * norm (x - e *\<^sub>R (x - c) - y)" by(auto intro!:norm_eqI simp add: algebra_simps)
+ also have "\<dots> < d" using as[unfolded dist_norm] and `e>0`
+ by(auto simp add:pos_divide_less_eq[OF `e>0`] real_mult_commute)
+ finally show "y \<in> s" apply(subst *) apply(rule assms(1)[unfolded convex_alt,rule_format])
+ apply(rule d[unfolded subset_eq,rule_format]) unfolding mem_ball using assms(3-5) by auto
+ qed(rule mult_pos_pos, insert `e>0` `d>0`, auto) qed
+
+lemma mem_interior_closure_convex_shrink:
+ fixes s :: "(real ^ _) set"
+ assumes "convex s" "c \<in> interior s" "x \<in> closure s" "0 < e" "e \<le> 1"
+ shows "x - e *\<^sub>R (x - c) \<in> interior s"
+proof- obtain d where "d>0" and d:"ball c d \<subseteq> s" using assms(2) unfolding mem_interior by auto
+ have "\<exists>y\<in>s. norm (y - x) * (1 - e) < e * d" proof(cases "x\<in>s")
+ case True thus ?thesis using `e>0` `d>0` by(rule_tac bexI[where x=x], auto intro!: mult_pos_pos) next
+ case False hence x:"x islimpt s" using assms(3)[unfolded closure_def] by auto
+ show ?thesis proof(cases "e=1")
+ case True obtain y where "y\<in>s" "y \<noteq> x" "dist y x < 1"
+ using x[unfolded islimpt_approachable,THEN spec[where x=1]] by auto
+ thus ?thesis apply(rule_tac x=y in bexI) unfolding True using `d>0` by auto next
+ case False hence "0 < e * d / (1 - e)" and *:"1 - e > 0"
+ using `e\<le>1` `e>0` `d>0` by(auto intro!:mult_pos_pos divide_pos_pos)
+ then obtain y where "y\<in>s" "y \<noteq> x" "dist y x < e * d / (1 - e)"
+ using x[unfolded islimpt_approachable,THEN spec[where x="e*d / (1 - e)"]] by auto
+ thus ?thesis apply(rule_tac x=y in bexI) unfolding dist_norm using pos_less_divide_eq[OF *] by auto qed qed
+ then obtain y where "y\<in>s" and y:"norm (y - x) * (1 - e) < e * d" by auto
+ def z \<equiv> "c + ((1 - e) / e) *\<^sub>R (x - y)"
+ have *:"x - e *\<^sub>R (x - c) = y - e *\<^sub>R (y - z)" unfolding z_def using `e>0` by (auto simp add: scaleR_right_diff_distrib scaleR_right_distrib scaleR_left_diff_distrib)
+ have "z\<in>interior s" apply(rule subset_interior[OF d,unfolded subset_eq,rule_format])
+ unfolding interior_open[OF open_ball] mem_ball z_def dist_norm using y and assms(4,5)
+ by(auto simp add:field_simps norm_minus_commute)
+ thus ?thesis unfolding * apply - apply(rule mem_interior_convex_shrink)
+ using assms(1,4-5) `y\<in>s` by auto qed
+
+subsection {* Some obvious but surprisingly hard simplex lemmas. *}
+
+lemma simplex:
+ assumes "finite s" "0 \<notin> s"
+ shows "convex hull (insert 0 s) = { y. (\<exists>u. (\<forall>x\<in>s. 0 \<le> u x) \<and> setsum u s \<le> 1 \<and> setsum (\<lambda>x. u x *\<^sub>R x) s = y)}"
+ unfolding convex_hull_finite[OF finite.insertI[OF assms(1)]] apply(rule set_ext, rule) unfolding mem_Collect_eq
+ apply(erule_tac[!] exE) apply(erule_tac[!] conjE)+ unfolding setsum_clauses(2)[OF assms(1)]
+ apply(rule_tac x=u in exI) defer apply(rule_tac x="\<lambda>x. if x = 0 then 1 - setsum u s else u x" in exI) using assms(2)
+ unfolding if_smult and setsum_delta_notmem[OF assms(2)] by auto
+
+lemma std_simplex:
+ "convex hull (insert 0 { basis i | i. i\<in>UNIV}) =
+ {x::real^'n::finite . (\<forall>i. 0 \<le> x$i) \<and> setsum (\<lambda>i. x$i) UNIV \<le> 1 }" (is "convex hull (insert 0 ?p) = ?s")
+proof- let ?D = "UNIV::'n set"
+ have "0\<notin>?p" by(auto simp add: basis_nonzero)
+ have "{(basis i)::real^'n |i. i \<in> ?D} = basis ` ?D" by auto
+ note sumbas = this setsum_reindex[OF basis_inj, unfolded o_def]
+ show ?thesis unfolding simplex[OF finite_stdbasis `0\<notin>?p`] apply(rule set_ext) unfolding mem_Collect_eq apply rule
+ apply(erule exE, (erule conjE)+) apply(erule_tac[2] conjE)+ proof-
+ fix x::"real^'n" and u assume as: "\<forall>x\<in>{basis i |i. i \<in>?D}. 0 \<le> u x" "setsum u {basis i |i. i \<in> ?D} \<le> 1" "(\<Sum>x\<in>{basis i |i. i \<in>?D}. u x *\<^sub>R x) = x"
+ have *:"\<forall>i. u (basis i) = x$i" using as(3) unfolding sumbas and basis_expansion_unique [where 'a=real, unfolded smult_conv_scaleR] by auto
+ hence **:"setsum u {basis i |i. i \<in> ?D} = setsum (op $ x) ?D" unfolding sumbas by(rule_tac setsum_cong, auto)
+ show " (\<forall>i. 0 \<le> x $ i) \<and> setsum (op $ x) ?D \<le> 1" apply - proof(rule,rule)
+ fix i::'n show "0 \<le> x$i" unfolding *[rule_format,of i,THEN sym] apply(rule_tac as(1)[rule_format]) by auto
+ qed(insert as(2)[unfolded **], auto)
+ next fix x::"real^'n" assume as:"\<forall>i. 0 \<le> x $ i" "setsum (op $ x) ?D \<le> 1"
+ show "\<exists>u. (\<forall>x\<in>{basis i |i. i \<in> ?D}. 0 \<le> u x) \<and> setsum u {basis i |i. i \<in> ?D} \<le> 1 \<and> (\<Sum>x\<in>{basis i |i. i \<in> ?D}. u x *\<^sub>R x) = x"
+ apply(rule_tac x="\<lambda>y. inner y x" in exI) apply(rule,rule) unfolding mem_Collect_eq apply(erule exE) using as(1) apply(erule_tac x=i in allE)
+ unfolding sumbas using as(2) and basis_expansion_unique [where 'a=real, unfolded smult_conv_scaleR] by(auto simp add:inner_basis) qed qed
+
+lemma interior_std_simplex:
+ "interior (convex hull (insert 0 { basis i| i. i\<in>UNIV})) =
+ {x::real^'n::finite. (\<forall>i. 0 < x$i) \<and> setsum (\<lambda>i. x$i) UNIV < 1 }"
+ apply(rule set_ext) unfolding mem_interior std_simplex unfolding subset_eq mem_Collect_eq Ball_def mem_ball
+ unfolding Ball_def[symmetric] apply rule apply(erule exE, (erule conjE)+) defer apply(erule conjE) proof-
+ fix x::"real^'n" and e assume "0<e" and as:"\<forall>xa. dist x xa < e \<longrightarrow> (\<forall>x. 0 \<le> xa $ x) \<and> setsum (op $ xa) UNIV \<le> 1"
+ show "(\<forall>xa. 0 < x $ xa) \<and> setsum (op $ x) UNIV < 1" apply(rule,rule) proof-
+ fix i::'n show "0 < x $ i" using as[THEN spec[where x="x - (e / 2) *\<^sub>R basis i"]] and `e>0`
+ unfolding dist_norm by(auto simp add: norm_basis vector_component_simps basis_component elim:allE[where x=i])
+ next guess a using UNIV_witness[where 'a='n] ..
+ have **:"dist x (x + (e / 2) *\<^sub>R basis a) < e" using `e>0` and norm_basis[of a]
+ unfolding dist_norm by(auto simp add: vector_component_simps basis_component intro!: mult_strict_left_mono_comm)
+ have "\<And>i. (x + (e / 2) *\<^sub>R basis a) $ i = x$i + (if i = a then e/2 else 0)" by(auto simp add:vector_component_simps)
+ hence *:"setsum (op $ (x + (e / 2) *\<^sub>R basis a)) UNIV = setsum (\<lambda>i. x$i + (if a = i then e/2 else 0)) UNIV" by(rule_tac setsum_cong, auto)
+ have "setsum (op $ x) UNIV < setsum (op $ (x + (e / 2) *\<^sub>R basis a)) UNIV" unfolding * setsum_addf
+ using `0<e` dimindex_ge_1 by(auto simp add: setsum_delta')
+ also have "\<dots> \<le> 1" using ** apply(drule_tac as[rule_format]) by auto
+ finally show "setsum (op $ x) UNIV < 1" by auto qed
+next
+ fix x::"real^'n::finite" assume as:"\<forall>i. 0 < x $ i" "setsum (op $ x) UNIV < 1"
+ guess a using UNIV_witness[where 'a='b] ..
+ let ?d = "(1 - setsum (op $ x) UNIV) / real (CARD('n))"
+ have "Min ((op $ x) ` UNIV) > 0" apply(rule Min_grI) using as(1) dimindex_ge_1 by auto
+ moreover have"?d > 0" apply(rule divide_pos_pos) using as(2) using dimindex_ge_1 by(auto simp add: Suc_le_eq)
+ ultimately show "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> (\<forall>i. 0 \<le> y $ i) \<and> setsum (op $ y) UNIV \<le> 1"
+ apply(rule_tac x="min (Min ((op $ x) ` UNIV)) ?D" in exI) apply rule defer apply(rule,rule) proof-
+ fix y assume y:"dist x y < min (Min (op $ x ` UNIV)) ?d"
+ have "setsum (op $ y) UNIV \<le> setsum (\<lambda>i. x$i + ?d) UNIV" proof(rule setsum_mono)
+ fix i::'n have "abs (y$i - x$i) < ?d" apply(rule le_less_trans) using component_le_norm[of "y - x" i]
+ using y[unfolded min_less_iff_conj dist_norm, THEN conjunct2] by(auto simp add:vector_component_simps norm_minus_commute)
+ thus "y $ i \<le> x $ i + ?d" by auto qed
+ also have "\<dots> \<le> 1" unfolding setsum_addf setsum_constant card_enum real_eq_of_nat using dimindex_ge_1 by(auto simp add: Suc_le_eq)
+ finally show "(\<forall>i. 0 \<le> y $ i) \<and> setsum (op $ y) UNIV \<le> 1" apply- proof(rule,rule)
+ fix i::'n have "norm (x - y) < x$i" using y[unfolded min_less_iff_conj dist_norm, THEN conjunct1]
+ using Min_gr_iff[of "op $ x ` dimset x"] dimindex_ge_1 by auto
+ thus "0 \<le> y$i" using component_le_norm[of "x - y" i] and as(1)[rule_format, of i] by(auto simp add: vector_component_simps)
+ qed auto qed auto qed
+
+lemma interior_std_simplex_nonempty: obtains a::"real^'n::finite" where
+ "a \<in> interior(convex hull (insert 0 {basis i | i . i \<in> UNIV}))" proof-
+ let ?D = "UNIV::'n set" let ?a = "setsum (\<lambda>b::real^'n. inverse (2 * real CARD('n)) *\<^sub>R b) {(basis i) | i. i \<in> ?D}"
+ have *:"{basis i :: real ^ 'n | i. i \<in> ?D} = basis ` ?D" by auto
+ { fix i have "?a $ i = inverse (2 * real CARD('n))"
+ unfolding setsum_component vector_smult_component and * and setsum_reindex[OF basis_inj] and o_def
+ apply(rule trans[of _ "setsum (\<lambda>j. if i = j then inverse (2 * real CARD('n)) else 0) ?D"]) apply(rule setsum_cong2)
+ unfolding setsum_delta'[OF finite_UNIV[where 'a='n]] and real_dimindex_ge_1[where 'n='n] by(auto simp add: basis_component[of i]) }
+ note ** = this
+ show ?thesis apply(rule that[of ?a]) unfolding interior_std_simplex mem_Collect_eq proof(rule,rule)
+ fix i::'n show "0 < ?a $ i" unfolding ** using dimindex_ge_1 by(auto simp add: Suc_le_eq) next
+ have "setsum (op $ ?a) ?D = setsum (\<lambda>i. inverse (2 * real CARD('n))) ?D" by(rule setsum_cong2, rule **)
+ also have "\<dots> < 1" unfolding setsum_constant card_enum real_eq_of_nat real_divide_def[THEN sym] by (auto simp add:field_simps)
+ finally show "setsum (op $ ?a) ?D < 1" by auto qed qed
+
+subsection {* Paths. *}
+
+definition "path (g::real^1 \<Rightarrow> real^'n::finite) \<longleftrightarrow> continuous_on {0 .. 1} g"
+
+definition "pathstart (g::real^1 \<Rightarrow> real^'n) = g 0"
+
+definition "pathfinish (g::real^1 \<Rightarrow> real^'n) = g 1"
+
+definition "path_image (g::real^1 \<Rightarrow> real^'n) = g ` {0 .. 1}"
+
+definition "reversepath (g::real^1 \<Rightarrow> real^'n) = (\<lambda>x. g(1 - x))"
+
+definition joinpaths:: "(real^1 \<Rightarrow> real^'n) \<Rightarrow> (real^1 \<Rightarrow> real^'n) \<Rightarrow> (real^1 \<Rightarrow> real^'n)" (infixr "+++" 75)
+ where "joinpaths g1 g2 = (\<lambda>x. if dest_vec1 x \<le> ((1 / 2)::real) then g1 (2 *\<^sub>R x) else g2(2 *\<^sub>R x - 1))"
+definition "simple_path (g::real^1 \<Rightarrow> real^'n) \<longleftrightarrow>
+ (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0)"
+
+definition "injective_path (g::real^1 \<Rightarrow> real^'n) \<longleftrightarrow>
+ (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y)"
+
+subsection {* Some lemmas about these concepts. *}
+
+lemma injective_imp_simple_path:
+ "injective_path g \<Longrightarrow> simple_path g"
+ unfolding injective_path_def simple_path_def by auto
+
+lemma path_image_nonempty: "path_image g \<noteq> {}"
+ unfolding path_image_def image_is_empty interval_eq_empty by auto
+
+lemma pathstart_in_path_image[intro]: "(pathstart g) \<in> path_image g"
+ unfolding pathstart_def path_image_def apply(rule imageI)
+ unfolding mem_interval_1 vec_1[THEN sym] dest_vec1_vec by auto
+
+lemma pathfinish_in_path_image[intro]: "(pathfinish g) \<in> path_image g"
+ unfolding pathfinish_def path_image_def apply(rule imageI)
+ unfolding mem_interval_1 vec_1[THEN sym] dest_vec1_vec by auto
+
+lemma connected_path_image[intro]: "path g \<Longrightarrow> connected(path_image g)"
+ unfolding path_def path_image_def apply(rule connected_continuous_image, assumption)
+ by(rule convex_connected, rule convex_interval)
+
+lemma compact_path_image[intro]: "path g \<Longrightarrow> compact(path_image g)"
+ unfolding path_def path_image_def apply(rule compact_continuous_image, assumption)
+ by(rule compact_interval)
+
+lemma reversepath_reversepath[simp]: "reversepath(reversepath g) = g"
+ unfolding reversepath_def by auto
+
+lemma pathstart_reversepath[simp]: "pathstart(reversepath g) = pathfinish g"
+ unfolding pathstart_def reversepath_def pathfinish_def by auto
+
+lemma pathfinish_reversepath[simp]: "pathfinish(reversepath g) = pathstart g"
+ unfolding pathstart_def reversepath_def pathfinish_def by auto
+
+lemma pathstart_join[simp]: "pathstart(g1 +++ g2) = pathstart g1"
+ unfolding pathstart_def joinpaths_def pathfinish_def by auto
+
+lemma pathfinish_join[simp]:"pathfinish(g1 +++ g2) = pathfinish g2" proof-
+ have "2 *\<^sub>R 1 - 1 = (1::real^1)" unfolding Cart_eq by(auto simp add:vector_component_simps)
+ thus ?thesis unfolding pathstart_def joinpaths_def pathfinish_def
+ unfolding vec_1[THEN sym] dest_vec1_vec by auto qed
+
+lemma path_image_reversepath[simp]: "path_image(reversepath g) = path_image g" proof-
+ have *:"\<And>g. path_image(reversepath g) \<subseteq> path_image g"
+ unfolding path_image_def subset_eq reversepath_def Ball_def image_iff apply(rule,rule,erule bexE)
+ apply(rule_tac x="1 - xa" in bexI) by(auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
+ show ?thesis using *[of g] *[of "reversepath g"] unfolding reversepath_reversepath by auto qed
+
+lemma path_reversepath[simp]: "path(reversepath g) \<longleftrightarrow> path g" proof-
+ have *:"\<And>g. path g \<Longrightarrow> path(reversepath g)" unfolding path_def reversepath_def
+ apply(rule continuous_on_compose[unfolded o_def, of _ "\<lambda>x. 1 - x"])
+ apply(rule continuous_on_sub, rule continuous_on_const, rule continuous_on_id)
+ apply(rule continuous_on_subset[of "{0..1}"], assumption)
+ by (auto, auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
+ show ?thesis using *[of g] *[of "reversepath g"] unfolding reversepath_reversepath by auto qed
+
+lemmas reversepath_simps = path_reversepath path_image_reversepath pathstart_reversepath pathfinish_reversepath
+
+lemma path_join[simp]: assumes "pathfinish g1 = pathstart g2" shows "path (g1 +++ g2) \<longleftrightarrow> path g1 \<and> path g2"
+ unfolding path_def pathfinish_def pathstart_def apply rule defer apply(erule conjE) proof-
+ assume as:"continuous_on {0..1} (g1 +++ g2)"
+ have *:"g1 = (\<lambda>x. g1 (2 *\<^sub>R x)) \<circ> (\<lambda>x. (1/2) *\<^sub>R x)"
+ "g2 = (\<lambda>x. g2 (2 *\<^sub>R x - 1)) \<circ> (\<lambda>x. (1/2) *\<^sub>R (x + 1))" unfolding o_def by auto
+ have "op *\<^sub>R (1 / 2) ` {0::real^1..1} \<subseteq> {0..1}" "(\<lambda>x. (1 / 2) *\<^sub>R (x + 1)) ` {(0::real^1)..1} \<subseteq> {0..1}"
+ unfolding image_smult_interval by (auto, auto simp add:vector_less_eq_def vector_component_simps elim!:ballE)
+ thus "continuous_on {0..1} g1 \<and> continuous_on {0..1} g2" apply -apply rule
+ apply(subst *) defer apply(subst *) apply (rule_tac[!] continuous_on_compose)
+ apply (rule continuous_on_cmul, rule continuous_on_add, rule continuous_on_id, rule continuous_on_const) defer
+ apply (rule continuous_on_cmul, rule continuous_on_id) apply(rule_tac[!] continuous_on_eq[of _ "g1 +++ g2"]) defer prefer 3
+ apply(rule_tac[1-2] continuous_on_subset[of "{0 .. 1}"]) apply(rule as, assumption, rule as, assumption)
+ apply(rule) defer apply rule proof-
+ fix x assume "x \<in> op *\<^sub>R (1 / 2) ` {0::real^1..1}"
+ hence "dest_vec1 x \<le> 1 / 2" unfolding image_iff by(auto simp add: vector_component_simps)
+ thus "(g1 +++ g2) x = g1 (2 *\<^sub>R x)" unfolding joinpaths_def by auto next
+ fix x assume "x \<in> (\<lambda>x. (1 / 2) *\<^sub>R (x + 1)) ` {0::real^1..1}"
+ hence "dest_vec1 x \<ge> 1 / 2" unfolding image_iff by(auto simp add: vector_component_simps)
+ thus "(g1 +++ g2) x = g2 (2 *\<^sub>R x - 1)" proof(cases "dest_vec1 x = 1 / 2")
+ case True hence "x = (1/2) *\<^sub>R 1" unfolding Cart_eq by(auto simp add: forall_1 vector_component_simps)
+ thus ?thesis unfolding joinpaths_def using assms[unfolded pathstart_def pathfinish_def] by auto
+ qed (auto simp add:le_less joinpaths_def) qed
+next assume as:"continuous_on {0..1} g1" "continuous_on {0..1} g2"
+ have *:"{0 .. 1::real^1} = {0.. (1/2)*\<^sub>R 1} \<union> {(1/2) *\<^sub>R 1 .. 1}" by(auto simp add: vector_component_simps)
+ have **:"op *\<^sub>R 2 ` {0..(1 / 2) *\<^sub>R 1} = {0..1::real^1}" apply(rule set_ext, rule) unfolding image_iff
+ defer apply(rule_tac x="(1/2)*\<^sub>R x" in bexI) by(auto simp add: vector_component_simps)
+ have ***:"(\<lambda>x. 2 *\<^sub>R x - 1) ` {(1 / 2) *\<^sub>R 1..1} = {0..1::real^1}"
+ unfolding image_affinity_interval[of _ "- 1", unfolded diff_def[symmetric]] and interval_eq_empty_1
+ by(auto simp add: vector_component_simps)
+ have ****:"\<And>x::real^1. x $ 1 * 2 = 1 \<longleftrightarrow> x = (1/2) *\<^sub>R 1" unfolding Cart_eq by(auto simp add: forall_1 vector_component_simps)
+ show "continuous_on {0..1} (g1 +++ g2)" unfolding * apply(rule continuous_on_union) apply(rule closed_interval)+ proof-
+ show "continuous_on {0..(1 / 2) *\<^sub>R 1} (g1 +++ g2)" apply(rule continuous_on_eq[of _ "\<lambda>x. g1 (2 *\<^sub>R x)"]) defer
+ unfolding o_def[THEN sym] apply(rule continuous_on_compose) apply(rule continuous_on_cmul, rule continuous_on_id)
+ unfolding ** apply(rule as(1)) unfolding joinpaths_def by(auto simp add: vector_component_simps) next
+ show "continuous_on {(1/2)*\<^sub>R1..1} (g1 +++ g2)" apply(rule continuous_on_eq[of _ "g2 \<circ> (\<lambda>x. 2 *\<^sub>R x - 1)"]) defer
+ apply(rule continuous_on_compose) apply(rule continuous_on_sub, rule continuous_on_cmul, rule continuous_on_id, rule continuous_on_const)
+ unfolding *** o_def joinpaths_def apply(rule as(2)) using assms[unfolded pathstart_def pathfinish_def]
+ by(auto simp add: vector_component_simps ****) qed qed
+
+lemma path_image_join_subset: "path_image(g1 +++ g2) \<subseteq> (path_image g1 \<union> path_image g2)" proof
+ fix x assume "x \<in> path_image (g1 +++ g2)"
+ then obtain y where y:"y\<in>{0..1}" "x = (if dest_vec1 y \<le> 1 / 2 then g1 (2 *\<^sub>R y) else g2 (2 *\<^sub>R y - 1))"
+ unfolding path_image_def image_iff joinpaths_def by auto
+ thus "x \<in> path_image g1 \<union> path_image g2" apply(cases "dest_vec1 y \<le> 1/2")
+ apply(rule_tac UnI1) defer apply(rule_tac UnI2) unfolding y(2) path_image_def using y(1)
+ by(auto intro!: imageI simp add: vector_component_simps) qed
+
+lemma subset_path_image_join:
+ assumes "path_image g1 \<subseteq> s" "path_image g2 \<subseteq> s" shows "path_image(g1 +++ g2) \<subseteq> s"
+ using path_image_join_subset[of g1 g2] and assms by auto
+
+lemma path_image_join:
+ assumes "path g1" "path g2" "pathfinish g1 = pathstart g2"
+ shows "path_image(g1 +++ g2) = (path_image g1) \<union> (path_image g2)"
+apply(rule, rule path_image_join_subset, rule) unfolding Un_iff proof(erule disjE)
+ fix x assume "x \<in> path_image g1"
+ then obtain y where y:"y\<in>{0..1}" "x = g1 y" unfolding path_image_def image_iff by auto
+ thus "x \<in> path_image (g1 +++ g2)" unfolding joinpaths_def path_image_def image_iff
+ apply(rule_tac x="(1/2) *\<^sub>R y" in bexI) by(auto simp add: vector_component_simps) next
+ fix x assume "x \<in> path_image g2"
+ then obtain y where y:"y\<in>{0..1}" "x = g2 y" unfolding path_image_def image_iff by auto
+ moreover have *:"y $ 1 = 0 \<Longrightarrow> y = 0" unfolding Cart_eq by auto
+ ultimately show "x \<in> path_image (g1 +++ g2)" unfolding joinpaths_def path_image_def image_iff
+ apply(rule_tac x="(1/2) *\<^sub>R (y + 1)" in bexI) using assms(3)[unfolded pathfinish_def pathstart_def]
+ by(auto simp add: vector_component_simps) qed
+
+lemma not_in_path_image_join:
+ assumes "x \<notin> path_image g1" "x \<notin> path_image g2" shows "x \<notin> path_image(g1 +++ g2)"
+ using assms and path_image_join_subset[of g1 g2] by auto
+
+lemma simple_path_reversepath: assumes "simple_path g" shows "simple_path (reversepath g)"
+ using assms unfolding simple_path_def reversepath_def apply- apply(rule ballI)+
+ apply(erule_tac x="1-x" in ballE, erule_tac x="1-y" in ballE)
+ unfolding mem_interval_1 by(auto simp add:vector_component_simps)
+
+lemma dest_vec1_scaleR [simp]:
+ "dest_vec1 (scaleR a x) = scaleR a (dest_vec1 x)"
+unfolding dest_vec1_def by simp
+
+lemma simple_path_join_loop:
+ assumes "injective_path g1" "injective_path g2" "pathfinish g2 = pathstart g1"
+ "(path_image g1 \<inter> path_image g2) \<subseteq> {pathstart g1,pathstart g2}"
+ shows "simple_path(g1 +++ g2)"
+unfolding simple_path_def proof((rule ballI)+, rule impI) let ?g = "g1 +++ g2"
+ note inj = assms(1,2)[unfolded injective_path_def, rule_format]
+ fix x y::"real^1" assume xy:"x \<in> {0..1}" "y \<in> {0..1}" "?g x = ?g y"
+ show "x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0" proof(case_tac "x$1 \<le> 1/2",case_tac[!] "y$1 \<le> 1/2", unfold not_le)
+ assume as:"x $ 1 \<le> 1 / 2" "y $ 1 \<le> 1 / 2"
+ hence "g1 (2 *\<^sub>R x) = g1 (2 *\<^sub>R y)" using xy(3) unfolding joinpaths_def dest_vec1_def by auto
+ moreover have "2 *\<^sub>R x \<in> {0..1}" "2 *\<^sub>R y \<in> {0..1}" using xy(1,2) as
+ unfolding mem_interval_1 dest_vec1_def by(auto simp add:vector_component_simps)
+ ultimately show ?thesis using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"] by auto
+ next assume as:"x $ 1 > 1 / 2" "y $ 1 > 1 / 2"
+ hence "g2 (2 *\<^sub>R x - 1) = g2 (2 *\<^sub>R y - 1)" using xy(3) unfolding joinpaths_def dest_vec1_def by auto
+ moreover have "2 *\<^sub>R x - 1 \<in> {0..1}" "2 *\<^sub>R y - 1 \<in> {0..1}" using xy(1,2) as
+ unfolding mem_interval_1 dest_vec1_def by(auto simp add:vector_component_simps)
+ ultimately show ?thesis using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] by auto
+ next assume as:"x $ 1 \<le> 1 / 2" "y $ 1 > 1 / 2"
+ hence "?g x \<in> path_image g1" "?g y \<in> path_image g2" unfolding path_image_def joinpaths_def
+ using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
+ moreover have "?g y \<noteq> pathstart g2" using as(2) unfolding pathstart_def joinpaths_def
+ using inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(2)[unfolded mem_interval_1]
+ apply(rule_tac ccontr) by(auto simp add:vector_component_simps field_simps Cart_eq)
+ ultimately have *:"?g x = pathstart g1" using assms(4) unfolding xy(3) by auto
+ hence "x = 0" unfolding pathstart_def joinpaths_def using as(1) and xy(1)[unfolded mem_interval_1]
+ using inj(1)[of "2 *\<^sub>R x" 0] by(auto simp add:vector_component_simps)
+ moreover have "y = 1" using * unfolding xy(3) assms(3)[THEN sym]
+ unfolding joinpaths_def pathfinish_def using as(2) and xy(2)[unfolded mem_interval_1]
+ using inj(2)[of "2 *\<^sub>R y - 1" 1] by (auto simp add:vector_component_simps Cart_eq)
+ ultimately show ?thesis by auto
+ next assume as:"x $ 1 > 1 / 2" "y $ 1 \<le> 1 / 2"
+ hence "?g x \<in> path_image g2" "?g y \<in> path_image g1" unfolding path_image_def joinpaths_def
+ using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
+ moreover have "?g x \<noteq> pathstart g2" using as(1) unfolding pathstart_def joinpaths_def
+ using inj(2)[of "2 *\<^sub>R x - 1" 0] and xy(1)[unfolded mem_interval_1]
+ apply(rule_tac ccontr) by(auto simp add:vector_component_simps field_simps Cart_eq)
+ ultimately have *:"?g y = pathstart g1" using assms(4) unfolding xy(3) by auto
+ hence "y = 0" unfolding pathstart_def joinpaths_def using as(2) and xy(2)[unfolded mem_interval_1]
+ using inj(1)[of "2 *\<^sub>R y" 0] by(auto simp add:vector_component_simps)
+ moreover have "x = 1" using * unfolding xy(3)[THEN sym] assms(3)[THEN sym]
+ unfolding joinpaths_def pathfinish_def using as(1) and xy(1)[unfolded mem_interval_1]
+ using inj(2)[of "2 *\<^sub>R x - 1" 1] by(auto simp add:vector_component_simps Cart_eq)
+ ultimately show ?thesis by auto qed qed
+
+lemma injective_path_join:
+ assumes "injective_path g1" "injective_path g2" "pathfinish g1 = pathstart g2"
+ "(path_image g1 \<inter> path_image g2) \<subseteq> {pathstart g2}"
+ shows "injective_path(g1 +++ g2)"
+ unfolding injective_path_def proof(rule,rule,rule) let ?g = "g1 +++ g2"
+ note inj = assms(1,2)[unfolded injective_path_def, rule_format]
+ fix x y assume xy:"x \<in> {0..1}" "y \<in> {0..1}" "(g1 +++ g2) x = (g1 +++ g2) y"
+ show "x = y" proof(cases "x$1 \<le> 1/2", case_tac[!] "y$1 \<le> 1/2", unfold not_le)
+ assume "x $ 1 \<le> 1 / 2" "y $ 1 \<le> 1 / 2" thus ?thesis using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"] and xy
+ unfolding mem_interval_1 joinpaths_def by(auto simp add:vector_component_simps)
+ next assume "x $ 1 > 1 / 2" "y $ 1 > 1 / 2" thus ?thesis using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] and xy
+ unfolding mem_interval_1 joinpaths_def by(auto simp add:vector_component_simps)
+ next assume as:"x $ 1 \<le> 1 / 2" "y $ 1 > 1 / 2"
+ hence "?g x \<in> path_image g1" "?g y \<in> path_image g2" unfolding path_image_def joinpaths_def
+ using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
+ hence "?g x = pathfinish g1" "?g y = pathstart g2" using assms(4) unfolding assms(3) xy(3) by auto
+ thus ?thesis using as and inj(1)[of "2 *\<^sub>R x" 1] inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(1,2)
+ unfolding pathstart_def pathfinish_def joinpaths_def mem_interval_1
+ by(auto simp add:vector_component_simps Cart_eq forall_1)
+ next assume as:"x $ 1 > 1 / 2" "y $ 1 \<le> 1 / 2"
+ hence "?g x \<in> path_image g2" "?g y \<in> path_image g1" unfolding path_image_def joinpaths_def
+ using xy(1,2)[unfolded mem_interval_1] by(auto simp add:vector_component_simps intro!: imageI)
+ hence "?g x = pathstart g2" "?g y = pathfinish g1" using assms(4) unfolding assms(3) xy(3) by auto
+ thus ?thesis using as and inj(2)[of "2 *\<^sub>R x - 1" 0] inj(1)[of "2 *\<^sub>R y" 1] and xy(1,2)
+ unfolding pathstart_def pathfinish_def joinpaths_def mem_interval_1
+ by(auto simp add:vector_component_simps forall_1 Cart_eq) qed qed
+
+lemmas join_paths_simps = path_join path_image_join pathstart_join pathfinish_join
+
+subsection {* Reparametrizing a closed curve to start at some chosen point. *}
+
+definition "shiftpath a (f::real^1 \<Rightarrow> real^'n) =
+ (\<lambda>x. if dest_vec1 (a + x) \<le> 1 then f(a + x) else f(a + x - 1))"
+
+lemma pathstart_shiftpath: "a \<le> 1 \<Longrightarrow> pathstart(shiftpath a g) = g a"
+ unfolding pathstart_def shiftpath_def by auto
+
+(** move this **)
+declare forall_1[simp] ex_1[simp]
+
+lemma pathfinish_shiftpath: assumes "0 \<le> a" "pathfinish g = pathstart g"
+ shows "pathfinish(shiftpath a g) = g a"
+ using assms unfolding pathstart_def pathfinish_def shiftpath_def
+ by(auto simp add: vector_component_simps)
+
+lemma endpoints_shiftpath:
+ assumes "pathfinish g = pathstart g" "a \<in> {0 .. 1}"
+ shows "pathfinish(shiftpath a g) = g a" "pathstart(shiftpath a g) = g a"
+ using assms by(auto intro!:pathfinish_shiftpath pathstart_shiftpath)
+
+lemma closed_shiftpath:
+ assumes "pathfinish g = pathstart g" "a \<in> {0..1}"
+ shows "pathfinish(shiftpath a g) = pathstart(shiftpath a g)"
+ using endpoints_shiftpath[OF assms] by auto
+
+lemma path_shiftpath:
+ assumes "path g" "pathfinish g = pathstart g" "a \<in> {0..1}"
+ shows "path(shiftpath a g)" proof-
+ have *:"{0 .. 1} = {0 .. 1-a} \<union> {1-a .. 1}" using assms(3) by(auto simp add: vector_component_simps)
+ have **:"\<And>x. x + a = 1 \<Longrightarrow> g (x + a - 1) = g (x + a)"
+ using assms(2)[unfolded pathfinish_def pathstart_def] by auto
+ show ?thesis unfolding path_def shiftpath_def * apply(rule continuous_on_union)
+ apply(rule closed_interval)+ apply(rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a + x)"]) prefer 3
+ apply(rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a - 1 + x)"]) defer prefer 3
+ apply(rule continuous_on_intros)+ prefer 2 apply(rule continuous_on_intros)+
+ apply(rule_tac[1-2] continuous_on_subset[OF assms(1)[unfolded path_def]])
+ using assms(3) and ** by(auto simp add:vector_component_simps field_simps Cart_eq) qed
+
+lemma shiftpath_shiftpath: assumes "pathfinish g = pathstart g" "a \<in> {0..1}" "x \<in> {0..1}"
+ shows "shiftpath (1 - a) (shiftpath a g) x = g x"
+ using assms unfolding pathfinish_def pathstart_def shiftpath_def
+ by(auto simp add: vector_component_simps)
+
+lemma path_image_shiftpath:
+ assumes "a \<in> {0..1}" "pathfinish g = pathstart g"
+ shows "path_image(shiftpath a g) = path_image g" proof-
+ { fix x assume as:"g 1 = g 0" "x \<in> {0..1::real^1}" " \<forall>y\<in>{0..1} \<inter> {x. \<not> a $ 1 + x $ 1 \<le> 1}. g x \<noteq> g (a + y - 1)"
+ hence "\<exists>y\<in>{0..1} \<inter> {x. a $ 1 + x $ 1 \<le> 1}. g x = g (a + y)" proof(cases "a \<le> x")
+ case False thus ?thesis apply(rule_tac x="1 + x - a" in bexI)
+ using as(1,2) and as(3)[THEN bspec[where x="1 + x - a"]] and assms(1)
+ by(auto simp add:vector_component_simps field_simps atomize_not) next
+ case True thus ?thesis using as(1-2) and assms(1) apply(rule_tac x="x - a" in bexI)
+ by(auto simp add:vector_component_simps field_simps) qed }
+ thus ?thesis using assms unfolding shiftpath_def path_image_def pathfinish_def pathstart_def
+ by(auto simp add:vector_component_simps image_iff) qed
+
+subsection {* Special case of straight-line paths. *}
+
+definition
+ linepath :: "real ^ 'n::finite \<Rightarrow> real ^ 'n \<Rightarrow> real ^ 1 \<Rightarrow> real ^ 'n" where
+ "linepath a b = (\<lambda>x. (1 - dest_vec1 x) *\<^sub>R a + dest_vec1 x *\<^sub>R b)"
+
+lemma pathstart_linepath[simp]: "pathstart(linepath a b) = a"
+ unfolding pathstart_def linepath_def by auto
+
+lemma pathfinish_linepath[simp]: "pathfinish(linepath a b) = b"
+ unfolding pathfinish_def linepath_def by auto
+
+lemma continuous_linepath_at[intro]: "continuous (at x) (linepath a b)"
+ unfolding linepath_def
+ by (intro continuous_intros continuous_dest_vec1)
+
+lemma continuous_on_linepath[intro]: "continuous_on s (linepath a b)"
+ using continuous_linepath_at by(auto intro!: continuous_at_imp_continuous_on)
+
+lemma path_linepath[intro]: "path(linepath a b)"
+ unfolding path_def by(rule continuous_on_linepath)
+
+lemma path_image_linepath[simp]: "path_image(linepath a b) = (closed_segment a b)"
+ unfolding path_image_def segment linepath_def apply (rule set_ext, rule) defer
+ unfolding mem_Collect_eq image_iff apply(erule exE) apply(rule_tac x="u *\<^sub>R 1" in bexI)
+ by(auto simp add:vector_component_simps)
+
+lemma reversepath_linepath[simp]: "reversepath(linepath a b) = linepath b a"
+ unfolding reversepath_def linepath_def by(rule ext, auto simp add:vector_component_simps)
+
+lemma injective_path_linepath: assumes "a \<noteq> b" shows "injective_path(linepath a b)" proof-
+ { obtain i where i:"a$i \<noteq> b$i" using assms[unfolded Cart_eq] by auto
+ fix x y::"real^1" assume "x $ 1 *\<^sub>R b + y $ 1 *\<^sub>R a = x $ 1 *\<^sub>R a + y $ 1 *\<^sub>R b"
+ hence "x$1 * (b$i - a$i) = y$1 * (b$i - a$i)" unfolding Cart_eq by(auto simp add:field_simps vector_component_simps)
+ hence "x = y" unfolding mult_cancel_right Cart_eq using i(1) by(auto simp add:field_simps) }
+ thus ?thesis unfolding injective_path_def linepath_def by(auto simp add:vector_component_simps algebra_simps) qed
+
+lemma simple_path_linepath[intro]: "a \<noteq> b \<Longrightarrow> simple_path(linepath a b)" by(auto intro!: injective_imp_simple_path injective_path_linepath)
+
+subsection {* Bounding a point away from a path. *}
+
+lemma not_on_path_ball: assumes "path g" "z \<notin> path_image g"
+ shows "\<exists>e>0. ball z e \<inter> (path_image g) = {}" proof-
+ obtain a where "a\<in>path_image g" "\<forall>y\<in>path_image g. dist z a \<le> dist z y"
+ using distance_attains_inf[OF _ path_image_nonempty, of g z]
+ using compact_path_image[THEN compact_imp_closed, OF assms(1)] by auto
+ thus ?thesis apply(rule_tac x="dist z a" in exI) using assms(2) by(auto intro!: dist_pos_lt) qed
+
+lemma not_on_path_cball: assumes "path g" "z \<notin> path_image g"
+ shows "\<exists>e>0. cball z e \<inter> (path_image g) = {}" proof-
+ obtain e where "ball z e \<inter> path_image g = {}" "e>0" using not_on_path_ball[OF assms] by auto
+ moreover have "cball z (e/2) \<subseteq> ball z e" using `e>0` by auto
+ ultimately show ?thesis apply(rule_tac x="e/2" in exI) by auto qed
+
+subsection {* Path component, considered as a "joinability" relation (from Tom Hales). *}
+
+definition "path_component s x y \<longleftrightarrow> (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"
+
+lemmas path_defs = path_def pathstart_def pathfinish_def path_image_def path_component_def
+
+lemma path_component_mem: assumes "path_component s x y" shows "x \<in> s" "y \<in> s"
+ using assms unfolding path_defs by auto
+
+lemma path_component_refl: assumes "x \<in> s" shows "path_component s x x"
+ unfolding path_defs apply(rule_tac x="\<lambda>u. x" in exI) using assms
+ by(auto intro!:continuous_on_intros)
+
+lemma path_component_refl_eq: "path_component s x x \<longleftrightarrow> x \<in> s"
+ by(auto intro!: path_component_mem path_component_refl)
+
+lemma path_component_sym: "path_component s x y \<Longrightarrow> path_component s y x"
+ using assms unfolding path_component_def apply(erule exE) apply(rule_tac x="reversepath g" in exI)
+ by(auto simp add: reversepath_simps)
+
+lemma path_component_trans: assumes "path_component s x y" "path_component s y z" shows "path_component s x z"
+ using assms unfolding path_component_def apply- apply(erule exE)+ apply(rule_tac x="g +++ ga" in exI) by(auto simp add: path_image_join)
+
+lemma path_component_of_subset: "s \<subseteq> t \<Longrightarrow> path_component s x y \<Longrightarrow> path_component t x y"
+ unfolding path_component_def by auto
+
+subsection {* Can also consider it as a set, as the name suggests. *}
+
+lemma path_component_set: "path_component s x = { y. (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y )}"
+ apply(rule set_ext) unfolding mem_Collect_eq unfolding mem_def path_component_def by auto
+
+lemma mem_path_component_set:"x \<in> path_component s y \<longleftrightarrow> path_component s y x" unfolding mem_def by auto
+
+lemma path_component_subset: "(path_component s x) \<subseteq> s"
+ apply(rule, rule path_component_mem(2)) by(auto simp add:mem_def)
+
+lemma path_component_eq_empty: "path_component s x = {} \<longleftrightarrow> x \<notin> s"
+ apply rule apply(drule equals0D[of _ x]) defer apply(rule equals0I) unfolding mem_path_component_set
+ apply(drule path_component_mem(1)) using path_component_refl by auto
+
+subsection {* Path connectedness of a space. *}
+
+definition "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. \<exists>g. path g \<and> (path_image g) \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"
+
+lemma path_connected_component: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. path_component s x y)"
+ unfolding path_connected_def path_component_def by auto
+
+lemma path_connected_component_set: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. path_component s x = s)"
+ unfolding path_connected_component apply(rule, rule, rule, rule path_component_subset)
+ unfolding subset_eq mem_path_component_set Ball_def mem_def by auto
+
+subsection {* Some useful lemmas about path-connectedness. *}
+
+lemma convex_imp_path_connected: assumes "convex s" shows "path_connected s"
+ unfolding path_connected_def apply(rule,rule,rule_tac x="linepath x y" in exI)
+ unfolding path_image_linepath using assms[unfolded convex_contains_segment] by auto
+
+lemma path_connected_imp_connected: assumes "path_connected s" shows "connected s"
+ unfolding connected_def not_ex apply(rule,rule,rule ccontr) unfolding not_not apply(erule conjE)+ proof-
+ fix e1 e2 assume as:"open e1" "open e2" "s \<subseteq> e1 \<union> e2" "e1 \<inter> e2 \<inter> s = {}" "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
+ then obtain x1 x2 where obt:"x1\<in>e1\<inter>s" "x2\<in>e2\<inter>s" by auto
+ then obtain g where g:"path g" "path_image g \<subseteq> s" "pathstart g = x1" "pathfinish g = x2"
+ using assms[unfolded path_connected_def,rule_format,of x1 x2] by auto
+ have *:"connected {0..1::real^1}" by(auto intro!: convex_connected convex_interval)
+ have "{0..1} \<subseteq> {x \<in> {0..1}. g x \<in> e1} \<union> {x \<in> {0..1}. g x \<in> e2}" using as(3) g(2)[unfolded path_defs] by blast
+ moreover have "{x \<in> {0..1}. g x \<in> e1} \<inter> {x \<in> {0..1}. g x \<in> e2} = {}" using as(4) g(2)[unfolded path_defs] unfolding subset_eq by auto
+ moreover have "{x \<in> {0..1}. g x \<in> e1} \<noteq> {} \<and> {x \<in> {0..1}. g x \<in> e2} \<noteq> {}" using g(3,4)[unfolded path_defs] using obt by(auto intro!: exI)
+ ultimately show False using *[unfolded connected_local not_ex,rule_format, of "{x\<in>{0..1}. g x \<in> e1}" "{x\<in>{0..1}. g x \<in> e2}"]
+ using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(1)]
+ using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(2)] by auto qed
+
+lemma open_path_component: assumes "open s" shows "open(path_component s x)"
+ unfolding open_contains_ball proof
+ fix y assume as:"y \<in> path_component s x"
+ hence "y\<in>s" apply- apply(rule path_component_mem(2)) unfolding mem_def by auto
+ then obtain e where e:"e>0" "ball y e \<subseteq> s" using assms[unfolded open_contains_ball] by auto
+ show "\<exists>e>0. ball y e \<subseteq> path_component s x" apply(rule_tac x=e in exI) apply(rule,rule `e>0`,rule) unfolding mem_ball mem_path_component_set proof-
+ fix z assume "dist y z < e" thus "path_component s x z" apply(rule_tac path_component_trans[of _ _ y]) defer
+ apply(rule path_component_of_subset[OF e(2)]) apply(rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format]) using `e>0`
+ using as[unfolded mem_def] by auto qed qed
+
+lemma open_non_path_component: assumes "open s" shows "open(s - path_component s x)" unfolding open_contains_ball proof
+ fix y assume as:"y\<in>s - path_component s x"
+ then obtain e where e:"e>0" "ball y e \<subseteq> s" using assms[unfolded open_contains_ball] by auto
+ show "\<exists>e>0. ball y e \<subseteq> s - path_component s x" apply(rule_tac x=e in exI) apply(rule,rule `e>0`,rule,rule) defer proof(rule ccontr)
+ fix z assume "z\<in>ball y e" "\<not> z \<notin> path_component s x"
+ hence "y \<in> path_component s x" unfolding not_not mem_path_component_set using `e>0`
+ apply- apply(rule path_component_trans,assumption) apply(rule path_component_of_subset[OF e(2)])
+ apply(rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format]) by auto
+ thus False using as by auto qed(insert e(2), auto) qed
+
+lemma connected_open_path_connected: assumes "open s" "connected s" shows "path_connected s"
+ unfolding path_connected_component_set proof(rule,rule,rule path_component_subset, rule)
+ fix x y assume "x \<in> s" "y \<in> s" show "y \<in> path_component s x" proof(rule ccontr)
+ assume "y \<notin> path_component s x" moreover
+ have "path_component s x \<inter> s \<noteq> {}" using `x\<in>s` path_component_eq_empty path_component_subset[of s x] by auto
+ ultimately show False using `y\<in>s` open_non_path_component[OF assms(1)] open_path_component[OF assms(1)]
+ using assms(2)[unfolded connected_def not_ex, rule_format, of"path_component s x" "s - path_component s x"] by auto
+qed qed
+
+lemma path_connected_continuous_image:
+ assumes "continuous_on s f" "path_connected s" shows "path_connected (f ` s)"
+ unfolding path_connected_def proof(rule,rule)
+ fix x' y' assume "x' \<in> f ` s" "y' \<in> f ` s"
+ then obtain x y where xy:"x\<in>s" "y\<in>s" "x' = f x" "y' = f y" by auto
+ guess g using assms(2)[unfolded path_connected_def,rule_format,OF xy(1,2)] ..
+ thus "\<exists>g. path g \<and> path_image g \<subseteq> f ` s \<and> pathstart g = x' \<and> pathfinish g = y'"
+ unfolding xy apply(rule_tac x="f \<circ> g" in exI) unfolding path_defs
+ using assms(1) by(auto intro!: continuous_on_compose continuous_on_subset[of _ _ "g ` {0..1}"]) qed
+
+lemma homeomorphic_path_connectedness:
+ "s homeomorphic t \<Longrightarrow> (path_connected s \<longleftrightarrow> path_connected t)"
+ unfolding homeomorphic_def homeomorphism_def apply(erule exE|erule conjE)+ apply rule
+ apply(drule_tac f=f in path_connected_continuous_image) prefer 3
+ apply(drule_tac f=g in path_connected_continuous_image) by auto
+
+lemma path_connected_empty: "path_connected {}"
+ unfolding path_connected_def by auto
+
+lemma path_connected_singleton: "path_connected {a}"
+ unfolding path_connected_def apply(rule,rule)
+ apply(rule_tac x="linepath a a" in exI) by(auto simp add:segment scaleR_left_diff_distrib)
+
+lemma path_connected_Un: assumes "path_connected s" "path_connected t" "s \<inter> t \<noteq> {}"
+ shows "path_connected (s \<union> t)" unfolding path_connected_component proof(rule,rule)
+ fix x y assume as:"x \<in> s \<union> t" "y \<in> s \<union> t"
+ from assms(3) obtain z where "z \<in> s \<inter> t" by auto
+ thus "path_component (s \<union> t) x y" using as using assms(1-2)[unfolded path_connected_component] apply-
+ apply(erule_tac[!] UnE)+ apply(rule_tac[2-3] path_component_trans[of _ _ z])
+ by(auto simp add:path_component_of_subset [OF Un_upper1] path_component_of_subset[OF Un_upper2]) qed
+
+subsection {* sphere is path-connected. *}
+
+lemma path_connected_punctured_universe:
+ assumes "2 \<le> CARD('n::finite)" shows "path_connected((UNIV::(real^'n::finite) set) - {a})" proof-
+ obtain \<psi> where \<psi>:"bij_betw \<psi> {1..CARD('n)} (UNIV::'n set)" using ex_bij_betw_nat_finite_1[OF finite_UNIV] by auto
+ let ?U = "UNIV::(real^'n) set" let ?u = "?U - {0}"
+ let ?basis = "\<lambda>k. basis (\<psi> k)"
+ let ?A = "\<lambda>k. {x::real^'n. \<exists>i\<in>{1..k}. inner (basis (\<psi> i)) x \<noteq> 0}"
+ have "\<forall>k\<in>{2..CARD('n)}. path_connected (?A k)" proof
+ have *:"\<And>k. ?A (Suc k) = {x. inner (?basis (Suc k)) x < 0} \<union> {x. inner (?basis (Suc k)) x > 0} \<union> ?A k" apply(rule set_ext,rule) defer
+ apply(erule UnE)+ unfolding mem_Collect_eq apply(rule_tac[1-2] x="Suc k" in bexI)
+ by(auto elim!: ballE simp add: not_less le_Suc_eq)
+ fix k assume "k \<in> {2..CARD('n)}" thus "path_connected (?A k)" proof(induct k)
+ case (Suc k) show ?case proof(cases "k = 1")
+ case False from Suc have d:"k \<in> {1..CARD('n)}" "Suc k \<in> {1..CARD('n)}" by auto
+ hence "\<psi> k \<noteq> \<psi> (Suc k)" using \<psi>[unfolded bij_betw_def inj_on_def, THEN conjunct1, THEN bspec[where x=k]] by auto
+ hence **:"?basis k + ?basis (Suc k) \<in> {x. 0 < inner (?basis (Suc k)) x} \<inter> (?A k)"
+ "?basis k - ?basis (Suc k) \<in> {x. 0 > inner (?basis (Suc k)) x} \<inter> ({x. 0 < inner (?basis (Suc k)) x} \<union> (?A k))" using d
+ by(auto simp add: inner_basis vector_component_simps intro!:bexI[where x=k])
+ show ?thesis unfolding * Un_assoc apply(rule path_connected_Un) defer apply(rule path_connected_Un)
+ prefer 5 apply(rule_tac[1-2] convex_imp_path_connected, rule convex_halfspace_lt, rule convex_halfspace_gt)
+ apply(rule Suc(1)) apply(rule_tac[2-3] ccontr) using d ** False by auto
+ next case True hence d:"1\<in>{1..CARD('n)}" "2\<in>{1..CARD('n)}" using Suc(2) by auto
+ have ***:"Suc 1 = 2" by auto
+ have **:"\<And>s t P Q. s \<union> t \<union> {x. P x \<or> Q x} = (s \<union> {x. P x}) \<union> (t \<union> {x. Q x})" by auto
+ have "\<psi> 2 \<noteq> \<psi> (Suc 0)" apply(rule ccontr) using \<psi>[unfolded bij_betw_def inj_on_def, THEN conjunct1, THEN bspec[where x=2]] using assms by auto
+ thus ?thesis unfolding * True unfolding ** neq_iff bex_disj_distrib apply -
+ apply(rule path_connected_Un, rule_tac[1-2] path_connected_Un) defer 3 apply(rule_tac[1-4] convex_imp_path_connected)
+ apply(rule_tac[5] x=" ?basis 1 + ?basis 2" in nequals0I)
+ apply(rule_tac[6] x="-?basis 1 + ?basis 2" in nequals0I)
+ apply(rule_tac[7] x="-?basis 1 - ?basis 2" in nequals0I)
+ using d unfolding *** by(auto intro!: convex_halfspace_gt convex_halfspace_lt, auto simp add:vector_component_simps inner_basis)
+ qed qed auto qed note lem = this
+
+ have ***:"\<And>x::real^'n. (\<exists>i\<in>{1..CARD('n)}. inner (basis (\<psi> i)) x \<noteq> 0) \<longleftrightarrow> (\<exists>i. inner (basis i) x \<noteq> 0)"
+ apply rule apply(erule bexE) apply(rule_tac x="\<psi> i" in exI) defer apply(erule exE) proof-
+ fix x::"real^'n" and i assume as:"inner (basis i) x \<noteq> 0"
+ have "i\<in>\<psi> ` {1..CARD('n)}" using \<psi>[unfolded bij_betw_def, THEN conjunct2] by auto
+ then obtain j where "j\<in>{1..CARD('n)}" "\<psi> j = i" by auto
+ thus "\<exists>i\<in>{1..CARD('n)}. inner (basis (\<psi> i)) x \<noteq> 0" apply(rule_tac x=j in bexI) using as by auto qed auto
+ have *:"?U - {a} = (\<lambda>x. x + a) ` {x. x \<noteq> 0}" apply(rule set_ext) unfolding image_iff
+ apply rule apply(rule_tac x="x - a" in bexI) by auto
+ have **:"\<And>x::real^'n. x\<noteq>0 \<longleftrightarrow> (\<exists>i. inner (basis i) x \<noteq> 0)" unfolding Cart_eq by(auto simp add: inner_basis)
+ show ?thesis unfolding * apply(rule path_connected_continuous_image) apply(rule continuous_on_intros)+
+ unfolding ** apply(rule lem[THEN bspec[where x="CARD('n)"], unfolded ***]) using assms by auto qed
+
+lemma path_connected_sphere: assumes "2 \<le> CARD('n::finite)" shows "path_connected {x::real^'n::finite. norm(x - a) = r}" proof(cases "r\<le>0")
+ case True thus ?thesis proof(cases "r=0")
+ case False hence "{x::real^'n. norm(x - a) = r} = {}" using True by auto
+ thus ?thesis using path_connected_empty by auto
+ qed(auto intro!:path_connected_singleton) next
+ case False hence *:"{x::real^'n. norm(x - a) = r} = (\<lambda>x. a + r *\<^sub>R x) ` {x. norm x = 1}" unfolding not_le apply -apply(rule set_ext,rule)
+ unfolding image_iff apply(rule_tac x="(1/r) *\<^sub>R (x - a)" in bexI) unfolding mem_Collect_eq norm_scaleR by (auto simp add: scaleR_right_diff_distrib)
+ have **:"{x::real^'n. norm x = 1} = (\<lambda>x. (1/norm x) *\<^sub>R x) ` (UNIV - {0})" apply(rule set_ext,rule)
+ unfolding image_iff apply(rule_tac x=x in bexI) unfolding mem_Collect_eq by(auto split:split_if_asm)
+ have "continuous_on (UNIV - {0}) (\<lambda>x::real^'n. 1 / norm x)" unfolding o_def continuous_on_eq_continuous_within
+ apply(rule, rule continuous_at_within_inv[unfolded o_def inverse_eq_divide]) apply(rule continuous_at_within)
+ apply(rule continuous_at_norm[unfolded o_def]) by auto
+ thus ?thesis unfolding * ** using path_connected_punctured_universe[OF assms]
+ by(auto intro!: path_connected_continuous_image continuous_on_intros continuous_on_mul) qed
+
+lemma connected_sphere: "2 \<le> CARD('n) \<Longrightarrow> connected {x::real^'n::finite. norm(x - a) = r}"
+ using path_connected_sphere path_connected_imp_connected by auto
+
+(** In continuous_at_vec1_norm : Use \<And> instead of \<forall>. **)
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Determinants.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1087 @@
+(* Title: Determinants
+ Author: Amine Chaieb, University of Cambridge
+*)
+
+header {* Traces, Determinant of square matrices and some properties *}
+
+theory Determinants
+imports Euclidean_Space Permutations
+begin
+
+subsection{* First some facts about products*}
+lemma setprod_insert_eq: "finite A \<Longrightarrow> setprod f (insert a A) = (if a \<in> A then setprod f A else f a * setprod f A)"
+apply clarsimp
+by(subgoal_tac "insert a A = A", auto)
+
+lemma setprod_add_split:
+ assumes mn: "(m::nat) <= n + 1"
+ shows "setprod f {m.. n+p} = setprod f {m .. n} * setprod f {n+1..n+p}"
+proof-
+ let ?A = "{m .. n+p}"
+ let ?B = "{m .. n}"
+ let ?C = "{n+1..n+p}"
+ from mn have un: "?B \<union> ?C = ?A" by auto
+ from mn have dj: "?B \<inter> ?C = {}" by auto
+ have f: "finite ?B" "finite ?C" by simp_all
+ from setprod_Un_disjoint[OF f dj, of f, unfolded un] show ?thesis .
+qed
+
+
+lemma setprod_offset: "setprod f {(m::nat) + p .. n + p} = setprod (\<lambda>i. f (i + p)) {m..n}"
+apply (rule setprod_reindex_cong[where f="op + p"])
+apply (auto simp add: image_iff Bex_def inj_on_def)
+apply arith
+apply (rule ext)
+apply (simp add: add_commute)
+done
+
+lemma setprod_singleton: "setprod f {x} = f x" by simp
+
+lemma setprod_singleton_nat_seg: "setprod f {n..n} = f (n::'a::order)" by simp
+
+lemma setprod_numseg: "setprod f {m..0} = (if m=0 then f 0 else 1)"
+ "setprod f {m .. Suc n} = (if m \<le> Suc n then f (Suc n) * setprod f {m..n}
+ else setprod f {m..n})"
+ by (auto simp add: atLeastAtMostSuc_conv)
+
+lemma setprod_le: assumes fS: "finite S" and fg: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (g x :: 'a::ordered_idom)"
+ shows "setprod f S \<le> setprod g S"
+using fS fg
+apply(induct S)
+apply simp
+apply auto
+apply (rule mult_mono)
+apply (auto intro: setprod_nonneg)
+done
+
+ (* FIXME: In Finite_Set there is a useless further assumption *)
+lemma setprod_inversef: "finite A ==> setprod (inverse \<circ> f) A = (inverse (setprod f A) :: 'a:: {division_by_zero, field})"
+ apply (erule finite_induct)
+ apply (simp)
+ apply simp
+ done
+
+lemma setprod_le_1: assumes fS: "finite S" and f: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (1::'a::ordered_idom)"
+ shows "setprod f S \<le> 1"
+using setprod_le[OF fS f] unfolding setprod_1 .
+
+subsection{* Trace *}
+
+definition trace :: "'a::semiring_1^'n^'n \<Rightarrow> 'a" where
+ "trace A = setsum (\<lambda>i. ((A$i)$i)) (UNIV::'n set)"
+
+lemma trace_0: "trace(mat 0) = 0"
+ by (simp add: trace_def mat_def)
+
+lemma trace_I: "trace(mat 1 :: 'a::semiring_1^'n^'n) = of_nat(CARD('n))"
+ by (simp add: trace_def mat_def)
+
+lemma trace_add: "trace ((A::'a::comm_semiring_1^'n^'n) + B) = trace A + trace B"
+ by (simp add: trace_def setsum_addf)
+
+lemma trace_sub: "trace ((A::'a::comm_ring_1^'n^'n) - B) = trace A - trace B"
+ by (simp add: trace_def setsum_subtractf)
+
+lemma trace_mul_sym:"trace ((A::'a::comm_semiring_1^'n^'n) ** B) = trace (B**A)"
+ apply (simp add: trace_def matrix_matrix_mult_def)
+ apply (subst setsum_commute)
+ by (simp add: mult_commute)
+
+(* ------------------------------------------------------------------------- *)
+(* Definition of determinant. *)
+(* ------------------------------------------------------------------------- *)
+
+definition det:: "'a::comm_ring_1^'n^'n \<Rightarrow> 'a" where
+ "det A = setsum (\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)) {p. p permutes (UNIV :: 'n set)}"
+
+(* ------------------------------------------------------------------------- *)
+(* A few general lemmas we need below. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma setprod_permute:
+ assumes p: "p permutes S"
+ shows "setprod f S = setprod (f o p) S"
+proof-
+ {assume "\<not> finite S" hence ?thesis by simp}
+ moreover
+ {assume fS: "finite S"
+ then have ?thesis
+ apply (simp add: setprod_def cong del:strong_setprod_cong)
+ apply (rule ab_semigroup_mult.fold_image_permute)
+ apply (auto simp add: p)
+ apply unfold_locales
+ done}
+ ultimately show ?thesis by blast
+qed
+
+lemma setproduct_permute_nat_interval: "p permutes {m::nat .. n} ==> setprod f {m..n} = setprod (f o p) {m..n}"
+ by (blast intro!: setprod_permute)
+
+(* ------------------------------------------------------------------------- *)
+(* Basic determinant properties. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma det_transp: "det (transp A) = det (A::'a::comm_ring_1 ^'n^'n::finite)"
+proof-
+ let ?di = "\<lambda>A i j. A$i$j"
+ let ?U = "(UNIV :: 'n set)"
+ have fU: "finite ?U" by simp
+ {fix p assume p: "p \<in> {p. p permutes ?U}"
+ from p have pU: "p permutes ?U" by blast
+ have sth: "sign (inv p) = sign p"
+ by (metis sign_inverse fU p mem_def Collect_def permutation_permutes)
+ from permutes_inj[OF pU]
+ have pi: "inj_on p ?U" by (blast intro: subset_inj_on)
+ from permutes_image[OF pU]
+ have "setprod (\<lambda>i. ?di (transp A) i (inv p i)) ?U = setprod (\<lambda>i. ?di (transp A) i (inv p i)) (p ` ?U)" by simp
+ also have "\<dots> = setprod ((\<lambda>i. ?di (transp A) i (inv p i)) o p) ?U"
+ unfolding setprod_reindex[OF pi] ..
+ also have "\<dots> = setprod (\<lambda>i. ?di A i (p i)) ?U"
+ proof-
+ {fix i assume i: "i \<in> ?U"
+ from i permutes_inv_o[OF pU] permutes_in_image[OF pU]
+ have "((\<lambda>i. ?di (transp A) i (inv p i)) o p) i = ?di A i (p i)"
+ unfolding transp_def by (simp add: expand_fun_eq)}
+ then show "setprod ((\<lambda>i. ?di (transp A) i (inv p i)) o p) ?U = setprod (\<lambda>i. ?di A i (p i)) ?U" by (auto intro: setprod_cong)
+ qed
+ finally have "of_int (sign (inv p)) * (setprod (\<lambda>i. ?di (transp A) i (inv p i)) ?U) = of_int (sign p) * (setprod (\<lambda>i. ?di A i (p i)) ?U)" using sth
+ by simp}
+ then show ?thesis unfolding det_def apply (subst setsum_permutations_inverse)
+ apply (rule setsum_cong2) by blast
+qed
+
+lemma det_lowerdiagonal:
+ fixes A :: "'a::comm_ring_1^'n^'n::{finite,wellorder}"
+ assumes ld: "\<And>i j. i < j \<Longrightarrow> A$i$j = 0"
+ shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
+proof-
+ let ?U = "UNIV:: 'n set"
+ let ?PU = "{p. p permutes ?U}"
+ let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
+ have fU: "finite ?U" by simp
+ from finite_permutations[OF fU] have fPU: "finite ?PU" .
+ have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
+ {fix p assume p: "p \<in> ?PU -{id}"
+ from p have pU: "p permutes ?U" and pid: "p \<noteq> id" by blast+
+ from permutes_natset_le[OF pU] pid obtain i where
+ i: "p i > i" by (metis not_le)
+ from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
+ from setprod_zero[OF fU ex] have "?pp p = 0" by simp}
+ then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0" by blast
+ from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
+ unfolding det_def by (simp add: sign_id)
+qed
+
+lemma det_upperdiagonal:
+ fixes A :: "'a::comm_ring_1^'n^'n::{finite,wellorder}"
+ assumes ld: "\<And>i j. i > j \<Longrightarrow> A$i$j = 0"
+ shows "det A = setprod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
+proof-
+ let ?U = "UNIV:: 'n set"
+ let ?PU = "{p. p permutes ?U}"
+ let ?pp = "(\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set))"
+ have fU: "finite ?U" by simp
+ from finite_permutations[OF fU] have fPU: "finite ?PU" .
+ have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
+ {fix p assume p: "p \<in> ?PU -{id}"
+ from p have pU: "p permutes ?U" and pid: "p \<noteq> id" by blast+
+ from permutes_natset_ge[OF pU] pid obtain i where
+ i: "p i < i" by (metis not_le)
+ from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
+ from setprod_zero[OF fU ex] have "?pp p = 0" by simp}
+ then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0" by blast
+ from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
+ unfolding det_def by (simp add: sign_id)
+qed
+
+lemma det_diagonal:
+ fixes A :: "'a::comm_ring_1^'n^'n::finite"
+ assumes ld: "\<And>i j. i \<noteq> j \<Longrightarrow> A$i$j = 0"
+ shows "det A = setprod (\<lambda>i. A$i$i) (UNIV::'n set)"
+proof-
+ let ?U = "UNIV:: 'n set"
+ let ?PU = "{p. p permutes ?U}"
+ let ?pp = "\<lambda>p. of_int (sign p) * setprod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
+ have fU: "finite ?U" by simp
+ from finite_permutations[OF fU] have fPU: "finite ?PU" .
+ have id0: "{id} \<subseteq> ?PU" by (auto simp add: permutes_id)
+ {fix p assume p: "p \<in> ?PU - {id}"
+ then have "p \<noteq> id" by simp
+ then obtain i where i: "p i \<noteq> i" unfolding expand_fun_eq by auto
+ from ld [OF i [symmetric]] have ex:"\<exists>i \<in> ?U. A$i$p i = 0" by blast
+ from setprod_zero [OF fU ex] have "?pp p = 0" by simp}
+ then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0" by blast
+ from setsum_mono_zero_cong_left[OF fPU id0 p0] show ?thesis
+ unfolding det_def by (simp add: sign_id)
+qed
+
+lemma det_I: "det (mat 1 :: 'a::comm_ring_1^'n^'n::finite) = 1"
+proof-
+ let ?A = "mat 1 :: 'a::comm_ring_1^'n^'n"
+ let ?U = "UNIV :: 'n set"
+ let ?f = "\<lambda>i j. ?A$i$j"
+ {fix i assume i: "i \<in> ?U"
+ have "?f i i = 1" using i by (vector mat_def)}
+ hence th: "setprod (\<lambda>i. ?f i i) ?U = setprod (\<lambda>x. 1) ?U"
+ by (auto intro: setprod_cong)
+ {fix i j assume i: "i \<in> ?U" and j: "j \<in> ?U" and ij: "i \<noteq> j"
+ have "?f i j = 0" using i j ij by (vector mat_def) }
+ then have "det ?A = setprod (\<lambda>i. ?f i i) ?U" using det_diagonal
+ by blast
+ also have "\<dots> = 1" unfolding th setprod_1 ..
+ finally show ?thesis .
+qed
+
+lemma det_0: "det (mat 0 :: 'a::comm_ring_1^'n^'n::finite) = 0"
+ by (simp add: det_def setprod_zero)
+
+lemma det_permute_rows:
+ fixes A :: "'a::comm_ring_1^'n^'n::finite"
+ assumes p: "p permutes (UNIV :: 'n::finite set)"
+ shows "det(\<chi> i. A$p i :: 'a^'n^'n) = of_int (sign p) * det A"
+ apply (simp add: det_def setsum_right_distrib mult_assoc[symmetric])
+ apply (subst sum_permutations_compose_right[OF p])
+proof(rule setsum_cong2)
+ let ?U = "UNIV :: 'n set"
+ let ?PU = "{p. p permutes ?U}"
+ fix q assume qPU: "q \<in> ?PU"
+ have fU: "finite ?U" by simp
+ from qPU have q: "q permutes ?U" by blast
+ from p q have pp: "permutation p" and qp: "permutation q"
+ by (metis fU permutation_permutes)+
+ from permutes_inv[OF p] have ip: "inv p permutes ?U" .
+ have "setprod (\<lambda>i. A$p i$ (q o p) i) ?U = setprod ((\<lambda>i. A$p i$(q o p) i) o inv p) ?U"
+ by (simp only: setprod_permute[OF ip, symmetric])
+ also have "\<dots> = setprod (\<lambda>i. A $ (p o inv p) i $ (q o (p o inv p)) i) ?U"
+ by (simp only: o_def)
+ also have "\<dots> = setprod (\<lambda>i. A$i$q i) ?U" by (simp only: o_def permutes_inverses[OF p])
+ finally have thp: "setprod (\<lambda>i. A$p i$ (q o p) i) ?U = setprod (\<lambda>i. A$i$q i) ?U"
+ by blast
+ show "of_int (sign (q o p)) * setprod (\<lambda>i. A$ p i$ (q o p) i) ?U = of_int (sign p) * of_int (sign q) * setprod (\<lambda>i. A$i$q i) ?U"
+ by (simp only: thp sign_compose[OF qp pp] mult_commute of_int_mult)
+qed
+
+lemma det_permute_columns:
+ fixes A :: "'a::comm_ring_1^'n^'n::finite"
+ assumes p: "p permutes (UNIV :: 'n set)"
+ shows "det(\<chi> i j. A$i$ p j :: 'a^'n^'n) = of_int (sign p) * det A"
+proof-
+ let ?Ap = "\<chi> i j. A$i$ p j :: 'a^'n^'n"
+ let ?At = "transp A"
+ have "of_int (sign p) * det A = det (transp (\<chi> i. transp A $ p i))"
+ unfolding det_permute_rows[OF p, of ?At] det_transp ..
+ moreover
+ have "?Ap = transp (\<chi> i. transp A $ p i)"
+ by (simp add: transp_def Cart_eq)
+ ultimately show ?thesis by simp
+qed
+
+lemma det_identical_rows:
+ fixes A :: "'a::ordered_idom^'n^'n::finite"
+ assumes ij: "i \<noteq> j"
+ and r: "row i A = row j A"
+ shows "det A = 0"
+proof-
+ have tha: "\<And>(a::'a) b. a = b ==> b = - a ==> a = 0"
+ by simp
+ have th1: "of_int (-1) = - 1" by (metis of_int_1 of_int_minus number_of_Min)
+ let ?p = "Fun.swap i j id"
+ let ?A = "\<chi> i. A $ ?p i"
+ from r have "A = ?A" by (simp add: Cart_eq row_def swap_def)
+ hence "det A = det ?A" by simp
+ moreover have "det A = - det ?A"
+ by (simp add: det_permute_rows[OF permutes_swap_id] sign_swap_id ij th1)
+ ultimately show "det A = 0" by (metis tha)
+qed
+
+lemma det_identical_columns:
+ fixes A :: "'a::ordered_idom^'n^'n::finite"
+ assumes ij: "i \<noteq> j"
+ and r: "column i A = column j A"
+ shows "det A = 0"
+apply (subst det_transp[symmetric])
+apply (rule det_identical_rows[OF ij])
+by (metis row_transp r)
+
+lemma det_zero_row:
+ fixes A :: "'a::{idom, ring_char_0}^'n^'n::finite"
+ assumes r: "row i A = 0"
+ shows "det A = 0"
+using r
+apply (simp add: row_def det_def Cart_eq)
+apply (rule setsum_0')
+apply (auto simp: sign_nz)
+done
+
+lemma det_zero_column:
+ fixes A :: "'a::{idom,ring_char_0}^'n^'n::finite"
+ assumes r: "column i A = 0"
+ shows "det A = 0"
+ apply (subst det_transp[symmetric])
+ apply (rule det_zero_row [of i])
+ by (metis row_transp r)
+
+lemma det_row_add:
+ fixes a b c :: "'n::finite \<Rightarrow> _ ^ 'n"
+ shows "det((\<chi> i. if i = k then a i + b i else c i)::'a::comm_ring_1^'n^'n) =
+ det((\<chi> i. if i = k then a i else c i)::'a::comm_ring_1^'n^'n) +
+ det((\<chi> i. if i = k then b i else c i)::'a::comm_ring_1^'n^'n)"
+unfolding det_def Cart_lambda_beta setsum_addf[symmetric]
+proof (rule setsum_cong2)
+ let ?U = "UNIV :: 'n set"
+ let ?pU = "{p. p permutes ?U}"
+ let ?f = "(\<lambda>i. if i = k then a i + b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
+ let ?g = "(\<lambda> i. if i = k then a i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
+ let ?h = "(\<lambda> i. if i = k then b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
+ fix p assume p: "p \<in> ?pU"
+ let ?Uk = "?U - {k}"
+ from p have pU: "p permutes ?U" by blast
+ have kU: "?U = insert k ?Uk" by blast
+ {fix j assume j: "j \<in> ?Uk"
+ from j have "?f j $ p j = ?g j $ p j" and "?f j $ p j= ?h j $ p j"
+ by simp_all}
+ then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
+ and th2: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?h i $ p i) ?Uk"
+ apply -
+ apply (rule setprod_cong, simp_all)+
+ done
+ have th3: "finite ?Uk" "k \<notin> ?Uk" by auto
+ have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
+ unfolding kU[symmetric] ..
+ also have "\<dots> = ?f k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
+ apply (rule setprod_insert)
+ apply simp
+ by blast
+ also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk)" by (simp add: ring_simps)
+ also have "\<dots> = (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk) + (b k$ p k * setprod (\<lambda>i. ?h i $ p i) ?Uk)" by (metis th1 th2)
+ also have "\<dots> = setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk) + setprod (\<lambda>i. ?h i $ p i) (insert k ?Uk)"
+ unfolding setprod_insert[OF th3] by simp
+ finally have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?g i $ p i) ?U + setprod (\<lambda>i. ?h i $ p i) ?U" unfolding kU[symmetric] .
+ then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U = of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U + of_int (sign p) * setprod (\<lambda>i. ?h i $ p i) ?U"
+ by (simp add: ring_simps)
+qed
+
+lemma det_row_mul:
+ fixes a b :: "'n::finite \<Rightarrow> _ ^ 'n"
+ shows "det((\<chi> i. if i = k then c *s a i else b i)::'a::comm_ring_1^'n^'n) =
+ c* det((\<chi> i. if i = k then a i else b i)::'a::comm_ring_1^'n^'n)"
+
+unfolding det_def Cart_lambda_beta setsum_right_distrib
+proof (rule setsum_cong2)
+ let ?U = "UNIV :: 'n set"
+ let ?pU = "{p. p permutes ?U}"
+ let ?f = "(\<lambda>i. if i = k then c*s a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
+ let ?g = "(\<lambda> i. if i = k then a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
+ fix p assume p: "p \<in> ?pU"
+ let ?Uk = "?U - {k}"
+ from p have pU: "p permutes ?U" by blast
+ have kU: "?U = insert k ?Uk" by blast
+ {fix j assume j: "j \<in> ?Uk"
+ from j have "?f j $ p j = ?g j $ p j" by simp}
+ then have th1: "setprod (\<lambda>i. ?f i $ p i) ?Uk = setprod (\<lambda>i. ?g i $ p i) ?Uk"
+ apply -
+ apply (rule setprod_cong, simp_all)
+ done
+ have th3: "finite ?Uk" "k \<notin> ?Uk" by auto
+ have "setprod (\<lambda>i. ?f i $ p i) ?U = setprod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
+ unfolding kU[symmetric] ..
+ also have "\<dots> = ?f k $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk"
+ apply (rule setprod_insert)
+ apply simp
+ by blast
+ also have "\<dots> = (c*s a k) $ p k * setprod (\<lambda>i. ?f i $ p i) ?Uk" by (simp add: ring_simps)
+ also have "\<dots> = c* (a k $ p k * setprod (\<lambda>i. ?g i $ p i) ?Uk)"
+ unfolding th1 by (simp add: mult_ac)
+ also have "\<dots> = c* (setprod (\<lambda>i. ?g i $ p i) (insert k ?Uk))"
+ unfolding setprod_insert[OF th3] by simp
+ finally have "setprod (\<lambda>i. ?f i $ p i) ?U = c* (setprod (\<lambda>i. ?g i $ p i) ?U)" unfolding kU[symmetric] .
+ then show "of_int (sign p) * setprod (\<lambda>i. ?f i $ p i) ?U = c * (of_int (sign p) * setprod (\<lambda>i. ?g i $ p i) ?U)"
+ by (simp add: ring_simps)
+qed
+
+lemma det_row_0:
+ fixes b :: "'n::finite \<Rightarrow> _ ^ 'n"
+ shows "det((\<chi> i. if i = k then 0 else b i)::'a::comm_ring_1^'n^'n) = 0"
+using det_row_mul[of k 0 "\<lambda>i. 1" b]
+apply (simp)
+ unfolding vector_smult_lzero .
+
+lemma det_row_operation:
+ fixes A :: "'a::ordered_idom^'n^'n::finite"
+ assumes ij: "i \<noteq> j"
+ shows "det (\<chi> k. if k = i then row i A + c *s row j A else row k A) = det A"
+proof-
+ let ?Z = "(\<chi> k. if k = i then row j A else row k A) :: 'a ^'n^'n"
+ have th: "row i ?Z = row j ?Z" by (vector row_def)
+ have th2: "((\<chi> k. if k = i then row i A else row k A) :: 'a^'n^'n) = A"
+ by (vector row_def)
+ show ?thesis
+ unfolding det_row_add [of i] det_row_mul[of i] det_identical_rows[OF ij th] th2
+ by simp
+qed
+
+lemma det_row_span:
+ fixes A :: "'a:: ordered_idom^'n^'n::finite"
+ assumes x: "x \<in> span {row j A |j. j \<noteq> i}"
+ shows "det (\<chi> k. if k = i then row i A + x else row k A) = det A"
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?S = "{row j A |j. j \<noteq> i}"
+ let ?d = "\<lambda>x. det (\<chi> k. if k = i then x else row k A)"
+ let ?P = "\<lambda>x. ?d (row i A + x) = det A"
+ {fix k
+
+ have "(if k = i then row i A + 0 else row k A) = row k A" by simp}
+ then have P0: "?P 0"
+ apply -
+ apply (rule cong[of det, OF refl])
+ by (vector row_def)
+ moreover
+ {fix c z y assume zS: "z \<in> ?S" and Py: "?P y"
+ from zS obtain j where j: "z = row j A" "i \<noteq> j" by blast
+ let ?w = "row i A + y"
+ have th0: "row i A + (c*s z + y) = ?w + c*s z" by vector
+ have thz: "?d z = 0"
+ apply (rule det_identical_rows[OF j(2)])
+ using j by (vector row_def)
+ have "?d (row i A + (c*s z + y)) = ?d (?w + c*s z)" unfolding th0 ..
+ then have "?P (c*s z + y)" unfolding thz Py det_row_mul[of i] det_row_add[of i]
+ by simp }
+
+ ultimately show ?thesis
+ apply -
+ apply (rule span_induct_alt[of ?P ?S, OF P0])
+ apply blast
+ apply (rule x)
+ done
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* May as well do this, though it's a bit unsatisfactory since it ignores *)
+(* exact duplicates by considering the rows/columns as a set. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma det_dependent_rows:
+ fixes A:: "'a::ordered_idom^'n^'n::finite"
+ assumes d: "dependent (rows A)"
+ shows "det A = 0"
+proof-
+ let ?U = "UNIV :: 'n set"
+ from d obtain i where i: "row i A \<in> span (rows A - {row i A})"
+ unfolding dependent_def rows_def by blast
+ {fix j k assume jk: "j \<noteq> k"
+ and c: "row j A = row k A"
+ from det_identical_rows[OF jk c] have ?thesis .}
+ moreover
+ {assume H: "\<And> i j. i \<noteq> j \<Longrightarrow> row i A \<noteq> row j A"
+ have th0: "- row i A \<in> span {row j A|j. j \<noteq> i}"
+ apply (rule span_neg)
+ apply (rule set_rev_mp)
+ apply (rule i)
+ apply (rule span_mono)
+ using H i by (auto simp add: rows_def)
+ from det_row_span[OF th0]
+ have "det A = det (\<chi> k. if k = i then 0 *s 1 else row k A)"
+ unfolding right_minus vector_smult_lzero ..
+ with det_row_mul[of i "0::'a" "\<lambda>i. 1"]
+ have "det A = 0" by simp}
+ ultimately show ?thesis by blast
+qed
+
+lemma det_dependent_columns: assumes d: "dependent(columns (A::'a::ordered_idom^'n^'n::finite))" shows "det A = 0"
+by (metis d det_dependent_rows rows_transp det_transp)
+
+(* ------------------------------------------------------------------------- *)
+(* Multilinearity and the multiplication formula. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma Cart_lambda_cong: "(\<And>x. f x = g x) \<Longrightarrow> (Cart_lambda f::'a^'n) = (Cart_lambda g :: 'a^'n)"
+ apply (rule iffD1[OF Cart_lambda_unique]) by vector
+
+lemma det_linear_row_setsum:
+ assumes fS: "finite S"
+ shows "det ((\<chi> i. if i = k then setsum (a i) S else c i)::'a::comm_ring_1^'n^'n::finite) = setsum (\<lambda>j. det ((\<chi> i. if i = k then a i j else c i)::'a^'n^'n)) S"
+proof(induct rule: finite_induct[OF fS])
+ case 1 thus ?case apply simp unfolding setsum_empty det_row_0[of k] ..
+next
+ case (2 x F)
+ then show ?case by (simp add: det_row_add cong del: if_weak_cong)
+qed
+
+lemma finite_bounded_functions:
+ assumes fS: "finite S"
+ shows "finite {f. (\<forall>i \<in> {1.. (k::nat)}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1 .. k} \<longrightarrow> f i = i)}"
+proof(induct k)
+ case 0
+ have th: "{f. \<forall>i. f i = i} = {id}" by (auto intro: ext)
+ show ?case by (auto simp add: th)
+next
+ case (Suc k)
+ let ?f = "\<lambda>(y::nat,g) i. if i = Suc k then y else g i"
+ let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>{1..k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1..k} \<longrightarrow> f i = i)})"
+ have "?S = {f. (\<forall>i\<in>{1.. Suc k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1.. Suc k} \<longrightarrow> f i = i)}"
+ apply (auto simp add: image_iff)
+ apply (rule_tac x="x (Suc k)" in bexI)
+ apply (rule_tac x = "\<lambda>i. if i = Suc k then i else x i" in exI)
+ apply (auto intro: ext)
+ done
+ with finite_imageI[OF finite_cartesian_product[OF fS Suc.hyps(1)], of ?f]
+ show ?case by metis
+qed
+
+
+lemma eq_id_iff[simp]: "(\<forall>x. f x = x) = (f = id)" by (auto intro: ext)
+
+lemma det_linear_rows_setsum_lemma:
+ assumes fS: "finite S" and fT: "finite T"
+ shows "det((\<chi> i. if i \<in> T then setsum (a i) S else c i):: 'a::comm_ring_1^'n^'n::finite) =
+ setsum (\<lambda>f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n))
+ {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
+using fT
+proof(induct T arbitrary: a c set: finite)
+ case empty
+ have th0: "\<And>x y. (\<chi> i. if i \<in> {} then x i else y i) = (\<chi> i. y i)" by vector
+ from "empty.prems" show ?case unfolding th0 by simp
+next
+ case (insert z T a c)
+ let ?F = "\<lambda>T. {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
+ let ?h = "\<lambda>(y,g) i. if i = z then y else g i"
+ let ?k = "\<lambda>h. (h(z),(\<lambda>i. if i = z then i else h i))"
+ let ?s = "\<lambda> k a c f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n)"
+ let ?c = "\<lambda>i. if i = z then a i j else c i"
+ have thif: "\<And>a b c d. (if a \<or> b then c else d) = (if a then c else if b then c else d)" by simp
+ have thif2: "\<And>a b c d e. (if a then b else if c then d else e) =
+ (if c then (if a then b else d) else (if a then b else e))" by simp
+ from `z \<notin> T` have nz: "\<And>i. i \<in> T \<Longrightarrow> i = z \<longleftrightarrow> False" by auto
+ have "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
+ det (\<chi> i. if i = z then setsum (a i) S
+ else if i \<in> T then setsum (a i) S else c i)"
+ unfolding insert_iff thif ..
+ also have "\<dots> = (\<Sum>j\<in>S. det (\<chi> i. if i \<in> T then setsum (a i) S
+ else if i = z then a i j else c i))"
+ unfolding det_linear_row_setsum[OF fS]
+ apply (subst thif2)
+ using nz by (simp cong del: if_weak_cong cong add: if_cong)
+ finally have tha:
+ "det (\<chi> i. if i \<in> insert z T then setsum (a i) S else c i) =
+ (\<Sum>(j, f)\<in>S \<times> ?F T. det (\<chi> i. if i \<in> T then a i (f i)
+ else if i = z then a i j
+ else c i))"
+ unfolding insert.hyps unfolding setsum_cartesian_product by blast
+ show ?case unfolding tha
+ apply(rule setsum_eq_general_reverses[where h= "?h" and k= "?k"],
+ blast intro: finite_cartesian_product fS finite,
+ blast intro: finite_cartesian_product fS finite)
+ using `z \<notin> T`
+ apply (auto intro: ext)
+ apply (rule cong[OF refl[of det]])
+ by vector
+qed
+
+lemma det_linear_rows_setsum:
+ assumes fS: "finite (S::'n::finite set)"
+ shows "det (\<chi> i. setsum (a i) S) = setsum (\<lambda>f. det (\<chi> i. a i (f i) :: 'a::comm_ring_1 ^ 'n^'n::finite)) {f. \<forall>i. f i \<in> S}"
+proof-
+ have th0: "\<And>x y. ((\<chi> i. if i \<in> (UNIV:: 'n set) then x i else y i) :: 'a^'n^'n) = (\<chi> i. x i)" by vector
+
+ from det_linear_rows_setsum_lemma[OF fS, of "UNIV :: 'n set" a, unfolded th0, OF finite] show ?thesis by simp
+qed
+
+lemma matrix_mul_setsum_alt:
+ fixes A B :: "'a::comm_ring_1^'n^'n::finite"
+ shows "A ** B = (\<chi> i. setsum (\<lambda>k. A$i$k *s B $ k) (UNIV :: 'n set))"
+ by (vector matrix_matrix_mult_def setsum_component)
+
+lemma det_rows_mul:
+ "det((\<chi> i. c i *s a i)::'a::comm_ring_1^'n^'n::finite) =
+ setprod (\<lambda>i. c i) (UNIV:: 'n set) * det((\<chi> i. a i)::'a^'n^'n)"
+proof (simp add: det_def setsum_right_distrib cong add: setprod_cong, rule setsum_cong2)
+ let ?U = "UNIV :: 'n set"
+ let ?PU = "{p. p permutes ?U}"
+ fix p assume pU: "p \<in> ?PU"
+ let ?s = "of_int (sign p)"
+ from pU have p: "p permutes ?U" by blast
+ have "setprod (\<lambda>i. c i * a i $ p i) ?U = setprod c ?U * setprod (\<lambda>i. a i $ p i) ?U"
+ unfolding setprod_timesf ..
+ then show "?s * (\<Prod>xa\<in>?U. c xa * a xa $ p xa) =
+ setprod c ?U * (?s* (\<Prod>xa\<in>?U. a xa $ p xa))" by (simp add: ring_simps)
+qed
+
+lemma det_mul:
+ fixes A B :: "'a::ordered_idom^'n^'n::finite"
+ shows "det (A ** B) = det A * det B"
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?F = "{f. (\<forall>i\<in> ?U. f i \<in> ?U) \<and> (\<forall>i. i \<notin> ?U \<longrightarrow> f i = i)}"
+ let ?PU = "{p. p permutes ?U}"
+ have fU: "finite ?U" by simp
+ have fF: "finite ?F" by (rule finite)
+ {fix p assume p: "p permutes ?U"
+
+ have "p \<in> ?F" unfolding mem_Collect_eq permutes_in_image[OF p]
+ using p[unfolded permutes_def] by simp}
+ then have PUF: "?PU \<subseteq> ?F" by blast
+ {fix f assume fPU: "f \<in> ?F - ?PU"
+ have fUU: "f ` ?U \<subseteq> ?U" using fPU by auto
+ from fPU have f: "\<forall>i \<in> ?U. f i \<in> ?U"
+ "\<forall>i. i \<notin> ?U \<longrightarrow> f i = i" "\<not>(\<forall>y. \<exists>!x. f x = y)" unfolding permutes_def
+ by auto
+
+ let ?A = "(\<chi> i. A$i$f i *s B$f i) :: 'a^'n^'n"
+ let ?B = "(\<chi> i. B$f i) :: 'a^'n^'n"
+ {assume fni: "\<not> inj_on f ?U"
+ then obtain i j where ij: "f i = f j" "i \<noteq> j"
+ unfolding inj_on_def by blast
+ from ij
+ have rth: "row i ?B = row j ?B" by (vector row_def)
+ from det_identical_rows[OF ij(2) rth]
+ have "det (\<chi> i. A$i$f i *s B$f i) = 0"
+ unfolding det_rows_mul by simp}
+ moreover
+ {assume fi: "inj_on f ?U"
+ from f fi have fith: "\<And>i j. f i = f j \<Longrightarrow> i = j"
+ unfolding inj_on_def by metis
+ note fs = fi[unfolded surjective_iff_injective_gen[OF fU fU refl fUU, symmetric]]
+
+ {fix y
+ from fs f have "\<exists>x. f x = y" by blast
+ then obtain x where x: "f x = y" by blast
+ {fix z assume z: "f z = y" from fith x z have "z = x" by metis}
+ with x have "\<exists>!x. f x = y" by blast}
+ with f(3) have "det (\<chi> i. A$i$f i *s B$f i) = 0" by blast}
+ ultimately have "det (\<chi> i. A$i$f i *s B$f i) = 0" by blast}
+ hence zth: "\<forall> f\<in> ?F - ?PU. det (\<chi> i. A$i$f i *s B$f i) = 0" by simp
+ {fix p assume pU: "p \<in> ?PU"
+ from pU have p: "p permutes ?U" by blast
+ let ?s = "\<lambda>p. of_int (sign p)"
+ let ?f = "\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) *
+ (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))"
+ have "(setsum (\<lambda>q. ?s q *
+ (\<Prod>i\<in> ?U. (\<chi> i. A $ i $ p i *s B $ p i :: 'a^'n^'n) $ i $ q i)) ?PU) =
+ (setsum (\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) *
+ (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))) ?PU)"
+ unfolding sum_permutations_compose_right[OF permutes_inv[OF p], of ?f]
+ proof(rule setsum_cong2)
+ fix q assume qU: "q \<in> ?PU"
+ hence q: "q permutes ?U" by blast
+ from p q have pp: "permutation p" and pq: "permutation q"
+ unfolding permutation_permutes by auto
+ have th00: "of_int (sign p) * of_int (sign p) = (1::'a)"
+ "\<And>a. of_int (sign p) * (of_int (sign p) * a) = a"
+ unfolding mult_assoc[symmetric] unfolding of_int_mult[symmetric]
+ by (simp_all add: sign_idempotent)
+ have ths: "?s q = ?s p * ?s (q o inv p)"
+ using pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
+ by (simp add: th00 mult_ac sign_idempotent sign_compose)
+ have th001: "setprod (\<lambda>i. B$i$ q (inv p i)) ?U = setprod ((\<lambda>i. B$i$ q (inv p i)) o p) ?U"
+ by (rule setprod_permute[OF p])
+ have thp: "setprod (\<lambda>i. (\<chi> i. A$i$p i *s B$p i :: 'a^'n^'n) $i $ q i) ?U = setprod (\<lambda>i. A$i$p i) ?U * setprod (\<lambda>i. B$i$ q (inv p i)) ?U"
+ unfolding th001 setprod_timesf[symmetric] o_def permutes_inverses[OF p]
+ apply (rule setprod_cong[OF refl])
+ using permutes_in_image[OF q] by vector
+ show "?s q * setprod (\<lambda>i. (((\<chi> i. A$i$p i *s B$p i) :: 'a^'n^'n)$i$q i)) ?U = ?s p * (setprod (\<lambda>i. A$i$p i) ?U) * (?s (q o inv p) * setprod (\<lambda>i. B$i$(q o inv p) i) ?U)"
+ using ths thp pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
+ by (simp add: sign_nz th00 ring_simps sign_idempotent sign_compose)
+ qed
+ }
+ then have th2: "setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU = det A * det B"
+ unfolding det_def setsum_product
+ by (rule setsum_cong2)
+ have "det (A**B) = setsum (\<lambda>f. det (\<chi> i. A $ i $ f i *s B $ f i)) ?F"
+ unfolding matrix_mul_setsum_alt det_linear_rows_setsum[OF fU] by simp
+ also have "\<dots> = setsum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU"
+ using setsum_mono_zero_cong_left[OF fF PUF zth, symmetric]
+ unfolding det_rows_mul by auto
+ finally show ?thesis unfolding th2 .
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Relation to invertibility. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma invertible_left_inverse:
+ fixes A :: "real^'n^'n::finite"
+ shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). B** A = mat 1)"
+ by (metis invertible_def matrix_left_right_inverse)
+
+lemma invertible_righ_inverse:
+ fixes A :: "real^'n^'n::finite"
+ shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). A** B = mat 1)"
+ by (metis invertible_def matrix_left_right_inverse)
+
+lemma invertible_det_nz:
+ fixes A::"real ^'n^'n::finite"
+ shows "invertible A \<longleftrightarrow> det A \<noteq> 0"
+proof-
+ {assume "invertible A"
+ then obtain B :: "real ^'n^'n" where B: "A ** B = mat 1"
+ unfolding invertible_righ_inverse by blast
+ hence "det (A ** B) = det (mat 1 :: real ^'n^'n)" by simp
+ hence "det A \<noteq> 0"
+ apply (simp add: det_mul det_I) by algebra }
+ moreover
+ {assume H: "\<not> invertible A"
+ let ?U = "UNIV :: 'n set"
+ have fU: "finite ?U" by simp
+ from H obtain c i where c: "setsum (\<lambda>i. c i *s row i A) ?U = 0"
+ and iU: "i \<in> ?U" and ci: "c i \<noteq> 0"
+ unfolding invertible_righ_inverse
+ unfolding matrix_right_invertible_independent_rows by blast
+ have stupid: "\<And>(a::real^'n) b. a + b = 0 \<Longrightarrow> -a = b"
+ apply (drule_tac f="op + (- a)" in cong[OF refl])
+ apply (simp only: ab_left_minus add_assoc[symmetric])
+ apply simp
+ done
+ from c ci
+ have thr0: "- row i A = setsum (\<lambda>j. (1/ c i) *s (c j *s row j A)) (?U - {i})"
+ unfolding setsum_diff1'[OF fU iU] setsum_cmul
+ apply -
+ apply (rule vector_mul_lcancel_imp[OF ci])
+ apply (auto simp add: vector_smult_assoc vector_smult_rneg field_simps)
+ unfolding stupid ..
+ have thr: "- row i A \<in> span {row j A| j. j \<noteq> i}"
+ unfolding thr0
+ apply (rule span_setsum)
+ apply simp
+ apply (rule ballI)
+ apply (rule span_mul)+
+ apply (rule span_superset)
+ apply auto
+ done
+ let ?B = "(\<chi> k. if k = i then 0 else row k A) :: real ^'n^'n"
+ have thrb: "row i ?B = 0" using iU by (vector row_def)
+ have "det A = 0"
+ unfolding det_row_span[OF thr, symmetric] right_minus
+ unfolding det_zero_row[OF thrb] ..}
+ ultimately show ?thesis by blast
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Cramer's rule. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma cramer_lemma_transp:
+ fixes A:: "'a::ordered_idom^'n^'n::finite" and x :: "'a ^'n::finite"
+ shows "det ((\<chi> i. if i = k then setsum (\<lambda>i. x$i *s row i A) (UNIV::'n set)
+ else row i A)::'a^'n^'n) = x$k * det A"
+ (is "?lhs = ?rhs")
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?Uk = "?U - {k}"
+ have U: "?U = insert k ?Uk" by blast
+ have fUk: "finite ?Uk" by simp
+ have kUk: "k \<notin> ?Uk" by simp
+ have th00: "\<And>k s. x$k *s row k A + s = (x$k - 1) *s row k A + row k A + s"
+ by (vector ring_simps)
+ have th001: "\<And>f k . (\<lambda>x. if x = k then f k else f x) = f" by (auto intro: ext)
+ have "(\<chi> i. row i A) = A" by (vector row_def)
+ then have thd1: "det (\<chi> i. row i A) = det A" by simp
+ have thd0: "det (\<chi> i. if i = k then row k A + (\<Sum>i \<in> ?Uk. x $ i *s row i A) else row i A) = det A"
+ apply (rule det_row_span)
+ apply (rule span_setsum[OF fUk])
+ apply (rule ballI)
+ apply (rule span_mul)
+ apply (rule span_superset)
+ apply auto
+ done
+ show "?lhs = x$k * det A"
+ apply (subst U)
+ unfolding setsum_insert[OF fUk kUk]
+ apply (subst th00)
+ unfolding add_assoc
+ apply (subst det_row_add)
+ unfolding thd0
+ unfolding det_row_mul
+ unfolding th001[of k "\<lambda>i. row i A"]
+ unfolding thd1 by (simp add: ring_simps)
+qed
+
+lemma cramer_lemma:
+ fixes A :: "'a::ordered_idom ^'n^'n::finite"
+ shows "det((\<chi> i j. if j = k then (A *v x)$i else A$i$j):: 'a^'n^'n) = x$k * det A"
+proof-
+ let ?U = "UNIV :: 'n set"
+ have stupid: "\<And>c. setsum (\<lambda>i. c i *s row i (transp A)) ?U = setsum (\<lambda>i. c i *s column i A) ?U"
+ by (auto simp add: row_transp intro: setsum_cong2)
+ show ?thesis unfolding matrix_mult_vsum
+ unfolding cramer_lemma_transp[of k x "transp A", unfolded det_transp, symmetric]
+ unfolding stupid[of "\<lambda>i. x$i"]
+ apply (subst det_transp[symmetric])
+ apply (rule cong[OF refl[of det]]) by (vector transp_def column_def row_def)
+qed
+
+lemma cramer:
+ fixes A ::"real^'n^'n::finite"
+ assumes d0: "det A \<noteq> 0"
+ shows "A *v x = b \<longleftrightarrow> x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j :: real^'n^'n) / det A)"
+proof-
+ from d0 obtain B where B: "A ** B = mat 1" "B ** A = mat 1"
+ unfolding invertible_det_nz[symmetric] invertible_def by blast
+ have "(A ** B) *v b = b" by (simp add: B matrix_vector_mul_lid)
+ hence "A *v (B *v b) = b" by (simp add: matrix_vector_mul_assoc)
+ then have xe: "\<exists>x. A*v x = b" by blast
+ {fix x assume x: "A *v x = b"
+ have "x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j :: real^'n^'n) / det A)"
+ unfolding x[symmetric]
+ using d0 by (simp add: Cart_eq cramer_lemma field_simps)}
+ with xe show ?thesis by auto
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Orthogonality of a transformation and matrix. *)
+(* ------------------------------------------------------------------------- *)
+
+definition "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>v w. f v \<bullet> f w = v \<bullet> w)"
+
+lemma orthogonal_transformation: "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>(v::real ^_). norm (f v) = norm v)"
+ unfolding orthogonal_transformation_def
+ apply auto
+ apply (erule_tac x=v in allE)+
+ apply (simp add: real_vector_norm_def)
+ by (simp add: dot_norm linear_add[symmetric])
+
+definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow> transp Q ** Q = mat 1 \<and> Q ** transp Q = mat 1"
+
+lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n::finite) \<longleftrightarrow> transp Q ** Q = mat 1"
+ by (metis matrix_left_right_inverse orthogonal_matrix_def)
+
+lemma orthogonal_matrix_id: "orthogonal_matrix (mat 1 :: _^'n^'n::finite)"
+ by (simp add: orthogonal_matrix_def transp_mat matrix_mul_lid)
+
+lemma orthogonal_matrix_mul:
+ fixes A :: "real ^'n^'n::finite"
+ assumes oA : "orthogonal_matrix A"
+ and oB: "orthogonal_matrix B"
+ shows "orthogonal_matrix(A ** B)"
+ using oA oB
+ unfolding orthogonal_matrix matrix_transp_mul
+ apply (subst matrix_mul_assoc)
+ apply (subst matrix_mul_assoc[symmetric])
+ by (simp add: matrix_mul_rid)
+
+lemma orthogonal_transformation_matrix:
+ fixes f:: "real^'n \<Rightarrow> real^'n::finite"
+ shows "orthogonal_transformation f \<longleftrightarrow> linear f \<and> orthogonal_matrix(matrix f)"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ let ?mf = "matrix f"
+ let ?ot = "orthogonal_transformation f"
+ let ?U = "UNIV :: 'n set"
+ have fU: "finite ?U" by simp
+ let ?m1 = "mat 1 :: real ^'n^'n"
+ {assume ot: ?ot
+ from ot have lf: "linear f" and fd: "\<forall>v w. f v \<bullet> f w = v \<bullet> w"
+ unfolding orthogonal_transformation_def orthogonal_matrix by blast+
+ {fix i j
+ let ?A = "transp ?mf ** ?mf"
+ have th0: "\<And>b (x::'a::comm_ring_1). (if b then 1 else 0)*x = (if b then x else 0)"
+ "\<And>b (x::'a::comm_ring_1). x*(if b then 1 else 0) = (if b then x else 0)"
+ by simp_all
+ from fd[rule_format, of "basis i" "basis j", unfolded matrix_works[OF lf, symmetric] dot_matrix_vector_mul]
+ have "?A$i$j = ?m1 $ i $ j"
+ by (simp add: dot_def matrix_matrix_mult_def columnvector_def rowvector_def basis_def th0 setsum_delta[OF fU] mat_def)}
+ hence "orthogonal_matrix ?mf" unfolding orthogonal_matrix by vector
+ with lf have ?rhs by blast}
+ moreover
+ {assume lf: "linear f" and om: "orthogonal_matrix ?mf"
+ from lf om have ?lhs
+ unfolding orthogonal_matrix_def norm_eq orthogonal_transformation
+ unfolding matrix_works[OF lf, symmetric]
+ apply (subst dot_matrix_vector_mul)
+ by (simp add: dot_matrix_product matrix_mul_lid)}
+ ultimately show ?thesis by blast
+qed
+
+lemma det_orthogonal_matrix:
+ fixes Q:: "'a::ordered_idom^'n^'n::finite"
+ assumes oQ: "orthogonal_matrix Q"
+ shows "det Q = 1 \<or> det Q = - 1"
+proof-
+
+ have th: "\<And>x::'a. x = 1 \<or> x = - 1 \<longleftrightarrow> x*x = 1" (is "\<And>x::'a. ?ths x")
+ proof-
+ fix x:: 'a
+ have th0: "x*x - 1 = (x - 1)*(x + 1)" by (simp add: ring_simps)
+ have th1: "\<And>(x::'a) y. x = - y \<longleftrightarrow> x + y = 0"
+ apply (subst eq_iff_diff_eq_0) by simp
+ have "x*x = 1 \<longleftrightarrow> x*x - 1 = 0" by simp
+ also have "\<dots> \<longleftrightarrow> x = 1 \<or> x = - 1" unfolding th0 th1 by simp
+ finally show "?ths x" ..
+ qed
+ from oQ have "Q ** transp Q = mat 1" by (metis orthogonal_matrix_def)
+ hence "det (Q ** transp Q) = det (mat 1:: 'a^'n^'n)" by simp
+ hence "det Q * det Q = 1" by (simp add: det_mul det_I det_transp)
+ then show ?thesis unfolding th .
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Linearity of scaling, and hence isometry, that preserves origin. *)
+(* ------------------------------------------------------------------------- *)
+lemma scaling_linear:
+ fixes f :: "real ^'n \<Rightarrow> real ^'n::finite"
+ assumes f0: "f 0 = 0" and fd: "\<forall>x y. dist (f x) (f y) = c * dist x y"
+ shows "linear f"
+proof-
+ {fix v w
+ {fix x note fd[rule_format, of x 0, unfolded dist_norm f0 diff_0_right] }
+ note th0 = this
+ have "f v \<bullet> f w = c^2 * (v \<bullet> w)"
+ unfolding dot_norm_neg dist_norm[symmetric]
+ unfolding th0 fd[rule_format] by (simp add: power2_eq_square field_simps)}
+ note fc = this
+ show ?thesis unfolding linear_def vector_eq
+ by (simp add: dot_lmult dot_ladd dot_rmult dot_radd fc ring_simps)
+qed
+
+lemma isometry_linear:
+ "f (0:: real^'n) = (0:: real^'n::finite) \<Longrightarrow> \<forall>x y. dist(f x) (f y) = dist x y
+ \<Longrightarrow> linear f"
+by (rule scaling_linear[where c=1]) simp_all
+
+(* ------------------------------------------------------------------------- *)
+(* Hence another formulation of orthogonal transformation. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma orthogonal_transformation_isometry:
+ "orthogonal_transformation f \<longleftrightarrow> f(0::real^'n) = (0::real^'n::finite) \<and> (\<forall>x y. dist(f x) (f y) = dist x y)"
+ unfolding orthogonal_transformation
+ apply (rule iffI)
+ apply clarify
+ apply (clarsimp simp add: linear_0 linear_sub[symmetric] dist_norm)
+ apply (rule conjI)
+ apply (rule isometry_linear)
+ apply simp
+ apply simp
+ apply clarify
+ apply (erule_tac x=v in allE)
+ apply (erule_tac x=0 in allE)
+ by (simp add: dist_norm)
+
+(* ------------------------------------------------------------------------- *)
+(* Can extend an isometry from unit sphere. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma isometry_sphere_extend:
+ fixes f:: "real ^'n \<Rightarrow> real ^'n::finite"
+ assumes f1: "\<forall>x. norm x = 1 \<longrightarrow> norm (f x) = 1"
+ and fd1: "\<forall> x y. norm x = 1 \<longrightarrow> norm y = 1 \<longrightarrow> dist (f x) (f y) = dist x y"
+ shows "\<exists>g. orthogonal_transformation g \<and> (\<forall>x. norm x = 1 \<longrightarrow> g x = f x)"
+proof-
+ {fix x y x' y' x0 y0 x0' y0' :: "real ^'n"
+ assume H: "x = norm x *s x0" "y = norm y *s y0"
+ "x' = norm x *s x0'" "y' = norm y *s y0'"
+ "norm x0 = 1" "norm x0' = 1" "norm y0 = 1" "norm y0' = 1"
+ "norm(x0' - y0') = norm(x0 - y0)"
+
+ have "norm(x' - y') = norm(x - y)"
+ apply (subst H(1))
+ apply (subst H(2))
+ apply (subst H(3))
+ apply (subst H(4))
+ using H(5-9)
+ apply (simp add: norm_eq norm_eq_1)
+ apply (simp add: dot_lsub dot_rsub dot_lmult dot_rmult)
+ apply (simp add: ring_simps)
+ by (simp only: right_distrib[symmetric])}
+ note th0 = this
+ let ?g = "\<lambda>x. if x = 0 then 0 else norm x *s f (inverse (norm x) *s x)"
+ {fix x:: "real ^'n" assume nx: "norm x = 1"
+ have "?g x = f x" using nx by auto}
+ hence thfg: "\<forall>x. norm x = 1 \<longrightarrow> ?g x = f x" by blast
+ have g0: "?g 0 = 0" by simp
+ {fix x y :: "real ^'n"
+ {assume "x = 0" "y = 0"
+ then have "dist (?g x) (?g y) = dist x y" by simp }
+ moreover
+ {assume "x = 0" "y \<noteq> 0"
+ then have "dist (?g x) (?g y) = dist x y"
+ apply (simp add: dist_norm norm_mul)
+ apply (rule f1[rule_format])
+ by(simp add: norm_mul field_simps)}
+ moreover
+ {assume "x \<noteq> 0" "y = 0"
+ then have "dist (?g x) (?g y) = dist x y"
+ apply (simp add: dist_norm norm_mul)
+ apply (rule f1[rule_format])
+ by(simp add: norm_mul field_simps)}
+ moreover
+ {assume z: "x \<noteq> 0" "y \<noteq> 0"
+ have th00: "x = norm x *s (inverse (norm x) *s x)" "y = norm y *s (inverse (norm y) *s y)" "norm x *s f ((inverse (norm x) *s x)) = norm x *s f (inverse (norm x) *s x)"
+ "norm y *s f (inverse (norm y) *s y) = norm y *s f (inverse (norm y) *s y)"
+ "norm (inverse (norm x) *s x) = 1"
+ "norm (f (inverse (norm x) *s x)) = 1"
+ "norm (inverse (norm y) *s y) = 1"
+ "norm (f (inverse (norm y) *s y)) = 1"
+ "norm (f (inverse (norm x) *s x) - f (inverse (norm y) *s y)) =
+ norm (inverse (norm x) *s x - inverse (norm y) *s y)"
+ using z
+ by (auto simp add: vector_smult_assoc field_simps norm_mul intro: f1[rule_format] fd1[rule_format, unfolded dist_norm])
+ from z th0[OF th00] have "dist (?g x) (?g y) = dist x y"
+ by (simp add: dist_norm)}
+ ultimately have "dist (?g x) (?g y) = dist x y" by blast}
+ note thd = this
+ show ?thesis
+ apply (rule exI[where x= ?g])
+ unfolding orthogonal_transformation_isometry
+ using g0 thfg thd by metis
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Rotation, reflection, rotoinversion. *)
+(* ------------------------------------------------------------------------- *)
+
+definition "rotation_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = 1"
+definition "rotoinversion_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = - 1"
+
+lemma orthogonal_rotation_or_rotoinversion:
+ fixes Q :: "'a::ordered_idom^'n^'n::finite"
+ shows " orthogonal_matrix Q \<longleftrightarrow> rotation_matrix Q \<or> rotoinversion_matrix Q"
+ by (metis rotoinversion_matrix_def rotation_matrix_def det_orthogonal_matrix)
+(* ------------------------------------------------------------------------- *)
+(* Explicit formulas for low dimensions. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma setprod_1: "setprod f {(1::nat)..1} = f 1" by simp
+
+lemma setprod_2: "setprod f {(1::nat)..2} = f 1 * f 2"
+ by (simp add: nat_number setprod_numseg mult_commute)
+lemma setprod_3: "setprod f {(1::nat)..3} = f 1 * f 2 * f 3"
+ by (simp add: nat_number setprod_numseg mult_commute)
+
+lemma det_1: "det (A::'a::comm_ring_1^1^1) = A$1$1"
+ by (simp add: det_def permutes_sing sign_id UNIV_1)
+
+lemma det_2: "det (A::'a::comm_ring_1^2^2) = A$1$1 * A$2$2 - A$1$2 * A$2$1"
+proof-
+ have f12: "finite {2::2}" "1 \<notin> {2::2}" by auto
+ show ?thesis
+ unfolding det_def UNIV_2
+ unfolding setsum_over_permutations_insert[OF f12]
+ unfolding permutes_sing
+ apply (simp add: sign_swap_id sign_id swap_id_eq)
+ by (simp add: arith_simps(31)[symmetric] of_int_minus of_int_1 del: arith_simps(31))
+qed
+
+lemma det_3: "det (A::'a::comm_ring_1^3^3) =
+ A$1$1 * A$2$2 * A$3$3 +
+ A$1$2 * A$2$3 * A$3$1 +
+ A$1$3 * A$2$1 * A$3$2 -
+ A$1$1 * A$2$3 * A$3$2 -
+ A$1$2 * A$2$1 * A$3$3 -
+ A$1$3 * A$2$2 * A$3$1"
+proof-
+ have f123: "finite {2::3, 3}" "1 \<notin> {2::3, 3}" by auto
+ have f23: "finite {3::3}" "2 \<notin> {3::3}" by auto
+
+ show ?thesis
+ unfolding det_def UNIV_3
+ unfolding setsum_over_permutations_insert[OF f123]
+ unfolding setsum_over_permutations_insert[OF f23]
+
+ unfolding permutes_sing
+ apply (simp add: sign_swap_id permutation_swap_id sign_compose sign_id swap_id_eq)
+ apply (simp add: arith_simps(31)[symmetric] of_int_minus of_int_1 del: arith_simps(31))
+ by (simp add: ring_simps)
+qed
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,5115 @@
+(* Title: Library/Euclidean_Space
+ Author: Amine Chaieb, University of Cambridge
+*)
+
+header {* (Real) Vectors in Euclidean space, and elementary linear algebra.*}
+
+theory Euclidean_Space
+imports
+ Complex_Main "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+ Finite_Cartesian_Product Glbs Infinite_Set Numeral_Type
+ Inner_Product
+uses "positivstellensatz.ML" ("normarith.ML")
+begin
+
+text{* Some common special cases.*}
+
+lemma forall_1: "(\<forall>i::1. P i) \<longleftrightarrow> P 1"
+ by (metis num1_eq_iff)
+
+lemma exhaust_2:
+ fixes x :: 2 shows "x = 1 \<or> x = 2"
+proof (induct x)
+ case (of_int z)
+ then have "0 <= z" and "z < 2" by simp_all
+ then have "z = 0 | z = 1" by arith
+ then show ?case by auto
+qed
+
+lemma forall_2: "(\<forall>i::2. P i) \<longleftrightarrow> P 1 \<and> P 2"
+ by (metis exhaust_2)
+
+lemma exhaust_3:
+ fixes x :: 3 shows "x = 1 \<or> x = 2 \<or> x = 3"
+proof (induct x)
+ case (of_int z)
+ then have "0 <= z" and "z < 3" by simp_all
+ then have "z = 0 \<or> z = 1 \<or> z = 2" by arith
+ then show ?case by auto
+qed
+
+lemma forall_3: "(\<forall>i::3. P i) \<longleftrightarrow> P 1 \<and> P 2 \<and> P 3"
+ by (metis exhaust_3)
+
+lemma UNIV_1: "UNIV = {1::1}"
+ by (auto simp add: num1_eq_iff)
+
+lemma UNIV_2: "UNIV = {1::2, 2::2}"
+ using exhaust_2 by auto
+
+lemma UNIV_3: "UNIV = {1::3, 2::3, 3::3}"
+ using exhaust_3 by auto
+
+lemma setsum_1: "setsum f (UNIV::1 set) = f 1"
+ unfolding UNIV_1 by simp
+
+lemma setsum_2: "setsum f (UNIV::2 set) = f 1 + f 2"
+ unfolding UNIV_2 by simp
+
+lemma setsum_3: "setsum f (UNIV::3 set) = f 1 + f 2 + f 3"
+ unfolding UNIV_3 by (simp add: add_ac)
+
+subsection{* Basic componentwise operations on vectors. *}
+
+instantiation "^" :: (plus,type) plus
+begin
+definition vector_add_def : "op + \<equiv> (\<lambda> x y. (\<chi> i. (x$i) + (y$i)))"
+instance ..
+end
+
+instantiation "^" :: (times,type) times
+begin
+ definition vector_mult_def : "op * \<equiv> (\<lambda> x y. (\<chi> i. (x$i) * (y$i)))"
+ instance ..
+end
+
+instantiation "^" :: (minus,type) minus begin
+ definition vector_minus_def : "op - \<equiv> (\<lambda> x y. (\<chi> i. (x$i) - (y$i)))"
+instance ..
+end
+
+instantiation "^" :: (uminus,type) uminus begin
+ definition vector_uminus_def : "uminus \<equiv> (\<lambda> x. (\<chi> i. - (x$i)))"
+instance ..
+end
+instantiation "^" :: (zero,type) zero begin
+ definition vector_zero_def : "0 \<equiv> (\<chi> i. 0)"
+instance ..
+end
+
+instantiation "^" :: (one,type) one begin
+ definition vector_one_def : "1 \<equiv> (\<chi> i. 1)"
+instance ..
+end
+
+instantiation "^" :: (ord,type) ord
+ begin
+definition vector_less_eq_def:
+ "less_eq (x :: 'a ^'b) y = (ALL i. x$i <= y$i)"
+definition vector_less_def: "less (x :: 'a ^'b) y = (ALL i. x$i < y$i)"
+
+instance by (intro_classes)
+end
+
+instantiation "^" :: (scaleR, type) scaleR
+begin
+definition vector_scaleR_def: "scaleR = (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"
+instance ..
+end
+
+text{* Also the scalar-vector multiplication. *}
+
+definition vector_scalar_mult:: "'a::times \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'n" (infixl "*s" 70)
+ where "c *s x = (\<chi> i. c * (x$i))"
+
+text{* Constant Vectors *}
+
+definition "vec x = (\<chi> i. x)"
+
+text{* Dot products. *}
+
+definition dot :: "'a::{comm_monoid_add, times} ^ 'n \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a" (infix "\<bullet>" 70) where
+ "x \<bullet> y = setsum (\<lambda>i. x$i * y$i) UNIV"
+
+lemma dot_1[simp]: "(x::'a::{comm_monoid_add, times}^1) \<bullet> y = (x$1) * (y$1)"
+ by (simp add: dot_def setsum_1)
+
+lemma dot_2[simp]: "(x::'a::{comm_monoid_add, times}^2) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2)"
+ by (simp add: dot_def setsum_2)
+
+lemma dot_3[simp]: "(x::'a::{comm_monoid_add, times}^3) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2) + (x$3) * (y$3)"
+ by (simp add: dot_def setsum_3)
+
+subsection {* A naive proof procedure to lift really trivial arithmetic stuff from the basis of the vector space. *}
+
+method_setup vector = {*
+let
+ val ss1 = HOL_basic_ss addsimps [@{thm dot_def}, @{thm setsum_addf} RS sym,
+ @{thm setsum_subtractf} RS sym, @{thm setsum_right_distrib},
+ @{thm setsum_left_distrib}, @{thm setsum_negf} RS sym]
+ val ss2 = @{simpset} addsimps
+ [@{thm vector_add_def}, @{thm vector_mult_def},
+ @{thm vector_minus_def}, @{thm vector_uminus_def},
+ @{thm vector_one_def}, @{thm vector_zero_def}, @{thm vec_def},
+ @{thm vector_scaleR_def},
+ @{thm Cart_lambda_beta}, @{thm vector_scalar_mult_def}]
+ fun vector_arith_tac ths =
+ simp_tac ss1
+ THEN' (fn i => rtac @{thm setsum_cong2} i
+ ORELSE rtac @{thm setsum_0'} i
+ ORELSE simp_tac (HOL_basic_ss addsimps [@{thm "Cart_eq"}]) i)
+ (* THEN' TRY o clarify_tac HOL_cs THEN' (TRY o rtac @{thm iffI}) *)
+ THEN' asm_full_simp_tac (ss2 addsimps ths)
+ in
+ Attrib.thms >> (fn ths => K (SIMPLE_METHOD' (vector_arith_tac ths)))
+ end
+*} "Lifts trivial vector statements to real arith statements"
+
+lemma vec_0[simp]: "vec 0 = 0" by (vector vector_zero_def)
+lemma vec_1[simp]: "vec 1 = 1" by (vector vector_one_def)
+
+
+
+text{* Obvious "component-pushing". *}
+
+lemma vec_component [simp]: "(vec x :: 'a ^ 'n)$i = x"
+ by (vector vec_def)
+
+lemma vector_add_component [simp]:
+ fixes x y :: "'a::{plus} ^ 'n"
+ shows "(x + y)$i = x$i + y$i"
+ by vector
+
+lemma vector_minus_component [simp]:
+ fixes x y :: "'a::{minus} ^ 'n"
+ shows "(x - y)$i = x$i - y$i"
+ by vector
+
+lemma vector_mult_component [simp]:
+ fixes x y :: "'a::{times} ^ 'n"
+ shows "(x * y)$i = x$i * y$i"
+ by vector
+
+lemma vector_smult_component [simp]:
+ fixes y :: "'a::{times} ^ 'n"
+ shows "(c *s y)$i = c * (y$i)"
+ by vector
+
+lemma vector_uminus_component [simp]:
+ fixes x :: "'a::{uminus} ^ 'n"
+ shows "(- x)$i = - (x$i)"
+ by vector
+
+lemma vector_scaleR_component [simp]:
+ fixes x :: "'a::scaleR ^ 'n"
+ shows "(scaleR r x)$i = scaleR r (x$i)"
+ by vector
+
+lemma cond_component: "(if b then x else y)$i = (if b then x$i else y$i)" by vector
+
+lemmas vector_component =
+ vec_component vector_add_component vector_mult_component
+ vector_smult_component vector_minus_component vector_uminus_component
+ vector_scaleR_component cond_component
+
+subsection {* Some frequently useful arithmetic lemmas over vectors. *}
+
+instance "^" :: (semigroup_add,type) semigroup_add
+ apply (intro_classes) by (vector add_assoc)
+
+
+instance "^" :: (monoid_add,type) monoid_add
+ apply (intro_classes) by vector+
+
+instance "^" :: (group_add,type) group_add
+ apply (intro_classes) by (vector algebra_simps)+
+
+instance "^" :: (ab_semigroup_add,type) ab_semigroup_add
+ apply (intro_classes) by (vector add_commute)
+
+instance "^" :: (comm_monoid_add,type) comm_monoid_add
+ apply (intro_classes) by vector
+
+instance "^" :: (ab_group_add,type) ab_group_add
+ apply (intro_classes) by vector+
+
+instance "^" :: (cancel_semigroup_add,type) cancel_semigroup_add
+ apply (intro_classes)
+ by (vector Cart_eq)+
+
+instance "^" :: (cancel_ab_semigroup_add,type) cancel_ab_semigroup_add
+ apply (intro_classes)
+ by (vector Cart_eq)
+
+instance "^" :: (real_vector, type) real_vector
+ by default (vector scaleR_left_distrib scaleR_right_distrib)+
+
+instance "^" :: (semigroup_mult,type) semigroup_mult
+ apply (intro_classes) by (vector mult_assoc)
+
+instance "^" :: (monoid_mult,type) monoid_mult
+ apply (intro_classes) by vector+
+
+instance "^" :: (ab_semigroup_mult,type) ab_semigroup_mult
+ apply (intro_classes) by (vector mult_commute)
+
+instance "^" :: (ab_semigroup_idem_mult,type) ab_semigroup_idem_mult
+ apply (intro_classes) by (vector mult_idem)
+
+instance "^" :: (comm_monoid_mult,type) comm_monoid_mult
+ apply (intro_classes) by vector
+
+fun vector_power :: "('a::{one,times} ^'n) \<Rightarrow> nat \<Rightarrow> 'a^'n" where
+ "vector_power x 0 = 1"
+ | "vector_power x (Suc n) = x * vector_power x n"
+
+instance "^" :: (semiring,type) semiring
+ apply (intro_classes) by (vector ring_simps)+
+
+instance "^" :: (semiring_0,type) semiring_0
+ apply (intro_classes) by (vector ring_simps)+
+instance "^" :: (semiring_1,type) semiring_1
+ apply (intro_classes) by vector
+instance "^" :: (comm_semiring,type) comm_semiring
+ apply (intro_classes) by (vector ring_simps)+
+
+instance "^" :: (comm_semiring_0,type) comm_semiring_0 by (intro_classes)
+instance "^" :: (cancel_comm_monoid_add, type) cancel_comm_monoid_add ..
+instance "^" :: (semiring_0_cancel,type) semiring_0_cancel by (intro_classes)
+instance "^" :: (comm_semiring_0_cancel,type) comm_semiring_0_cancel by (intro_classes)
+instance "^" :: (ring,type) ring by (intro_classes)
+instance "^" :: (semiring_1_cancel,type) semiring_1_cancel by (intro_classes)
+instance "^" :: (comm_semiring_1,type) comm_semiring_1 by (intro_classes)
+
+instance "^" :: (ring_1,type) ring_1 ..
+
+instance "^" :: (real_algebra,type) real_algebra
+ apply intro_classes
+ apply (simp_all add: vector_scaleR_def ring_simps)
+ apply vector
+ apply vector
+ done
+
+instance "^" :: (real_algebra_1,type) real_algebra_1 ..
+
+lemma of_nat_index:
+ "(of_nat n :: 'a::semiring_1 ^'n)$i = of_nat n"
+ apply (induct n)
+ apply vector
+ apply vector
+ done
+lemma zero_index[simp]:
+ "(0 :: 'a::zero ^'n)$i = 0" by vector
+
+lemma one_index[simp]:
+ "(1 :: 'a::one ^'n)$i = 1" by vector
+
+lemma one_plus_of_nat_neq_0: "(1::'a::semiring_char_0) + of_nat n \<noteq> 0"
+proof-
+ have "(1::'a) + of_nat n = 0 \<longleftrightarrow> of_nat 1 + of_nat n = (of_nat 0 :: 'a)" by simp
+ also have "\<dots> \<longleftrightarrow> 1 + n = 0" by (simp only: of_nat_add[symmetric] of_nat_eq_iff)
+ finally show ?thesis by simp
+qed
+
+instance "^" :: (semiring_char_0,type) semiring_char_0
+proof (intro_classes)
+ fix m n ::nat
+ show "(of_nat m :: 'a^'b) = of_nat n \<longleftrightarrow> m = n"
+ by (simp add: Cart_eq of_nat_index)
+qed
+
+instance "^" :: (comm_ring_1,type) comm_ring_1 by intro_classes
+instance "^" :: (ring_char_0,type) ring_char_0 by intro_classes
+
+lemma vector_smult_assoc: "a *s (b *s x) = ((a::'a::semigroup_mult) * b) *s x"
+ by (vector mult_assoc)
+lemma vector_sadd_rdistrib: "((a::'a::semiring) + b) *s x = a *s x + b *s x"
+ by (vector ring_simps)
+lemma vector_add_ldistrib: "(c::'a::semiring) *s (x + y) = c *s x + c *s y"
+ by (vector ring_simps)
+lemma vector_smult_lzero[simp]: "(0::'a::mult_zero) *s x = 0" by vector
+lemma vector_smult_lid[simp]: "(1::'a::monoid_mult) *s x = x" by vector
+lemma vector_ssub_ldistrib: "(c::'a::ring) *s (x - y) = c *s x - c *s y"
+ by (vector ring_simps)
+lemma vector_smult_rneg: "(c::'a::ring) *s -x = -(c *s x)" by vector
+lemma vector_smult_lneg: "- (c::'a::ring) *s x = -(c *s x)" by vector
+lemma vector_sneg_minus1: "-x = (- (1::'a::ring_1)) *s x" by vector
+lemma vector_smult_rzero[simp]: "c *s 0 = (0::'a::mult_zero ^ 'n)" by vector
+lemma vector_sub_rdistrib: "((a::'a::ring) - b) *s x = a *s x - b *s x"
+ by (vector ring_simps)
+
+lemma vec_eq[simp]: "(vec m = vec n) \<longleftrightarrow> (m = n)"
+ by (simp add: Cart_eq)
+
+subsection {* Topological space *}
+
+instantiation "^" :: (topological_space, finite) topological_space
+begin
+
+definition open_vector_def:
+ "open (S :: ('a ^ 'b) set) \<longleftrightarrow>
+ (\<forall>x\<in>S. \<exists>A. (\<forall>i. open (A i) \<and> x$i \<in> A i) \<and>
+ (\<forall>y. (\<forall>i. y$i \<in> A i) \<longrightarrow> y \<in> S))"
+
+instance proof
+ show "open (UNIV :: ('a ^ 'b) set)"
+ unfolding open_vector_def by auto
+next
+ fix S T :: "('a ^ 'b) set"
+ assume "open S" "open T" thus "open (S \<inter> T)"
+ unfolding open_vector_def
+ apply clarify
+ apply (drule (1) bspec)+
+ apply (clarify, rename_tac Sa Ta)
+ apply (rule_tac x="\<lambda>i. Sa i \<inter> Ta i" in exI)
+ apply (simp add: open_Int)
+ done
+next
+ fix K :: "('a ^ 'b) set set"
+ assume "\<forall>S\<in>K. open S" thus "open (\<Union>K)"
+ unfolding open_vector_def
+ apply clarify
+ apply (drule (1) bspec)
+ apply (drule (1) bspec)
+ apply clarify
+ apply (rule_tac x=A in exI)
+ apply fast
+ done
+qed
+
+end
+
+lemma open_vector_box: "\<forall>i. open (S i) \<Longrightarrow> open {x. \<forall>i. x $ i \<in> S i}"
+unfolding open_vector_def by auto
+
+lemma open_vimage_Cart_nth: "open S \<Longrightarrow> open ((\<lambda>x. x $ i) -` S)"
+unfolding open_vector_def
+apply clarify
+apply (rule_tac x="\<lambda>k. if k = i then S else UNIV" in exI, simp)
+done
+
+lemma closed_vimage_Cart_nth: "closed S \<Longrightarrow> closed ((\<lambda>x. x $ i) -` S)"
+unfolding closed_open vimage_Compl [symmetric]
+by (rule open_vimage_Cart_nth)
+
+lemma closed_vector_box: "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
+proof -
+ have "{x. \<forall>i. x $ i \<in> S i} = (\<Inter>i. (\<lambda>x. x $ i) -` S i)" by auto
+ thus "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
+ by (simp add: closed_INT closed_vimage_Cart_nth)
+qed
+
+lemma tendsto_Cart_nth [tendsto_intros]:
+ assumes "((\<lambda>x. f x) ---> a) net"
+ shows "((\<lambda>x. f x $ i) ---> a $ i) net"
+proof (rule topological_tendstoI)
+ fix S assume "open S" "a $ i \<in> S"
+ then have "open ((\<lambda>y. y $ i) -` S)" "a \<in> ((\<lambda>y. y $ i) -` S)"
+ by (simp_all add: open_vimage_Cart_nth)
+ with assms have "eventually (\<lambda>x. f x \<in> (\<lambda>y. y $ i) -` S) net"
+ by (rule topological_tendstoD)
+ then show "eventually (\<lambda>x. f x $ i \<in> S) net"
+ by simp
+qed
+
+subsection {* Square root of sum of squares *}
+
+definition
+ "setL2 f A = sqrt (\<Sum>i\<in>A. (f i)\<twosuperior>)"
+
+lemma setL2_cong:
+ "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
+ unfolding setL2_def by simp
+
+lemma strong_setL2_cong:
+ "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
+ unfolding setL2_def simp_implies_def by simp
+
+lemma setL2_infinite [simp]: "\<not> finite A \<Longrightarrow> setL2 f A = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_empty [simp]: "setL2 f {} = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_insert [simp]:
+ "\<lbrakk>finite F; a \<notin> F\<rbrakk> \<Longrightarrow>
+ setL2 f (insert a F) = sqrt ((f a)\<twosuperior> + (setL2 f F)\<twosuperior>)"
+ unfolding setL2_def by (simp add: setsum_nonneg)
+
+lemma setL2_nonneg [simp]: "0 \<le> setL2 f A"
+ unfolding setL2_def by (simp add: setsum_nonneg)
+
+lemma setL2_0': "\<forall>a\<in>A. f a = 0 \<Longrightarrow> setL2 f A = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_constant: "setL2 (\<lambda>x. y) A = sqrt (of_nat (card A)) * \<bar>y\<bar>"
+ unfolding setL2_def by (simp add: real_sqrt_mult)
+
+lemma setL2_mono:
+ assumes "\<And>i. i \<in> K \<Longrightarrow> f i \<le> g i"
+ assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
+ shows "setL2 f K \<le> setL2 g K"
+ unfolding setL2_def
+ by (simp add: setsum_nonneg setsum_mono power_mono prems)
+
+lemma setL2_strict_mono:
+ assumes "finite K" and "K \<noteq> {}"
+ assumes "\<And>i. i \<in> K \<Longrightarrow> f i < g i"
+ assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
+ shows "setL2 f K < setL2 g K"
+ unfolding setL2_def
+ by (simp add: setsum_strict_mono power_strict_mono assms)
+
+lemma setL2_right_distrib:
+ "0 \<le> r \<Longrightarrow> r * setL2 f A = setL2 (\<lambda>x. r * f x) A"
+ unfolding setL2_def
+ apply (simp add: power_mult_distrib)
+ apply (simp add: setsum_right_distrib [symmetric])
+ apply (simp add: real_sqrt_mult setsum_nonneg)
+ done
+
+lemma setL2_left_distrib:
+ "0 \<le> r \<Longrightarrow> setL2 f A * r = setL2 (\<lambda>x. f x * r) A"
+ unfolding setL2_def
+ apply (simp add: power_mult_distrib)
+ apply (simp add: setsum_left_distrib [symmetric])
+ apply (simp add: real_sqrt_mult setsum_nonneg)
+ done
+
+lemma setsum_nonneg_eq_0_iff:
+ fixes f :: "'a \<Rightarrow> 'b::pordered_ab_group_add"
+ shows "\<lbrakk>finite A; \<forall>x\<in>A. 0 \<le> f x\<rbrakk> \<Longrightarrow> setsum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
+ apply (induct set: finite, simp)
+ apply (simp add: add_nonneg_eq_0_iff setsum_nonneg)
+ done
+
+lemma setL2_eq_0_iff: "finite A \<Longrightarrow> setL2 f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
+ unfolding setL2_def
+ by (simp add: setsum_nonneg setsum_nonneg_eq_0_iff)
+
+lemma setL2_triangle_ineq:
+ shows "setL2 (\<lambda>i. f i + g i) A \<le> setL2 f A + setL2 g A"
+proof (cases "finite A")
+ case False
+ thus ?thesis by simp
+next
+ case True
+ thus ?thesis
+ proof (induct set: finite)
+ case empty
+ show ?case by simp
+ next
+ case (insert x F)
+ hence "sqrt ((f x + g x)\<twosuperior> + (setL2 (\<lambda>i. f i + g i) F)\<twosuperior>) \<le>
+ sqrt ((f x + g x)\<twosuperior> + (setL2 f F + setL2 g F)\<twosuperior>)"
+ by (intro real_sqrt_le_mono add_left_mono power_mono insert
+ setL2_nonneg add_increasing zero_le_power2)
+ also have
+ "\<dots> \<le> sqrt ((f x)\<twosuperior> + (setL2 f F)\<twosuperior>) + sqrt ((g x)\<twosuperior> + (setL2 g F)\<twosuperior>)"
+ by (rule real_sqrt_sum_squares_triangle_ineq)
+ finally show ?case
+ using insert by simp
+ qed
+qed
+
+lemma sqrt_sum_squares_le_sum:
+ "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> sqrt (x\<twosuperior> + y\<twosuperior>) \<le> x + y"
+ apply (rule power2_le_imp_le)
+ apply (simp add: power2_sum)
+ apply (simp add: mult_nonneg_nonneg)
+ apply (simp add: add_nonneg_nonneg)
+ done
+
+lemma setL2_le_setsum [rule_format]:
+ "(\<forall>i\<in>A. 0 \<le> f i) \<longrightarrow> setL2 f A \<le> setsum f A"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply clarsimp
+ apply (erule order_trans [OF sqrt_sum_squares_le_sum])
+ apply simp
+ apply simp
+ apply simp
+ done
+
+lemma sqrt_sum_squares_le_sum_abs: "sqrt (x\<twosuperior> + y\<twosuperior>) \<le> \<bar>x\<bar> + \<bar>y\<bar>"
+ apply (rule power2_le_imp_le)
+ apply (simp add: power2_sum)
+ apply (simp add: mult_nonneg_nonneg)
+ apply (simp add: add_nonneg_nonneg)
+ done
+
+lemma setL2_le_setsum_abs: "setL2 f A \<le> (\<Sum>i\<in>A. \<bar>f i\<bar>)"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply simp
+ apply (rule order_trans [OF sqrt_sum_squares_le_sum_abs])
+ apply simp
+ apply simp
+ done
+
+lemma setL2_mult_ineq_lemma:
+ fixes a b c d :: real
+ shows "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
+proof -
+ have "0 \<le> (a * d - b * c)\<twosuperior>" by simp
+ also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * d) * (b * c)"
+ by (simp only: power2_diff power_mult_distrib)
+ also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * c) * (b * d)"
+ by simp
+ finally show "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
+ by simp
+qed
+
+lemma setL2_mult_ineq: "(\<Sum>i\<in>A. \<bar>f i\<bar> * \<bar>g i\<bar>) \<le> setL2 f A * setL2 g A"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply (rule power2_le_imp_le, simp)
+ apply (rule order_trans)
+ apply (rule power_mono)
+ apply (erule add_left_mono)
+ apply (simp add: add_nonneg_nonneg mult_nonneg_nonneg setsum_nonneg)
+ apply (simp add: power2_sum)
+ apply (simp add: power_mult_distrib)
+ apply (simp add: right_distrib left_distrib)
+ apply (rule ord_le_eq_trans)
+ apply (rule setL2_mult_ineq_lemma)
+ apply simp
+ apply (intro mult_nonneg_nonneg setL2_nonneg)
+ apply simp
+ done
+
+lemma member_le_setL2: "\<lbrakk>finite A; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le> setL2 f A"
+ apply (rule_tac s="insert i (A - {i})" and t="A" in subst)
+ apply fast
+ apply (subst setL2_insert)
+ apply simp
+ apply simp
+ apply simp
+ done
+
+subsection {* Metric *}
+
+(* TODO: move somewhere else *)
+lemma finite_choice: "finite A \<Longrightarrow> \<forall>x\<in>A. \<exists>y. P x y \<Longrightarrow> \<exists>f. \<forall>x\<in>A. P x (f x)"
+apply (induct set: finite, simp_all)
+apply (clarify, rename_tac y)
+apply (rule_tac x="f(x:=y)" in exI, simp)
+done
+
+instantiation "^" :: (metric_space, finite) metric_space
+begin
+
+definition dist_vector_def:
+ "dist (x::'a^'b) (y::'a^'b) = setL2 (\<lambda>i. dist (x$i) (y$i)) UNIV"
+
+lemma dist_nth_le: "dist (x $ i) (y $ i) \<le> dist x y"
+unfolding dist_vector_def
+by (rule member_le_setL2) simp_all
+
+instance proof
+ fix x y :: "'a ^ 'b"
+ show "dist x y = 0 \<longleftrightarrow> x = y"
+ unfolding dist_vector_def
+ by (simp add: setL2_eq_0_iff Cart_eq)
+next
+ fix x y z :: "'a ^ 'b"
+ show "dist x y \<le> dist x z + dist y z"
+ unfolding dist_vector_def
+ apply (rule order_trans [OF _ setL2_triangle_ineq])
+ apply (simp add: setL2_mono dist_triangle2)
+ done
+next
+ (* FIXME: long proof! *)
+ fix S :: "('a ^ 'b) set"
+ show "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
+ unfolding open_vector_def open_dist
+ apply safe
+ apply (drule (1) bspec)
+ apply clarify
+ apply (subgoal_tac "\<exists>e>0. \<forall>i y. dist y (x$i) < e \<longrightarrow> y \<in> A i")
+ apply clarify
+ apply (rule_tac x=e in exI, clarify)
+ apply (drule spec, erule mp, clarify)
+ apply (drule spec, drule spec, erule mp)
+ apply (erule le_less_trans [OF dist_nth_le])
+ apply (subgoal_tac "\<forall>i\<in>UNIV. \<exists>e>0. \<forall>y. dist y (x$i) < e \<longrightarrow> y \<in> A i")
+ apply (drule finite_choice [OF finite], clarify)
+ apply (rule_tac x="Min (range f)" in exI, simp)
+ apply clarify
+ apply (drule_tac x=i in spec, clarify)
+ apply (erule (1) bspec)
+ apply (drule (1) bspec, clarify)
+ apply (subgoal_tac "\<exists>r. (\<forall>i::'b. 0 < r i) \<and> e = setL2 r UNIV")
+ apply clarify
+ apply (rule_tac x="\<lambda>i. {y. dist y (x$i) < r i}" in exI)
+ apply (rule conjI)
+ apply clarify
+ apply (rule conjI)
+ apply (clarify, rename_tac y)
+ apply (rule_tac x="r i - dist y (x$i)" in exI, rule conjI, simp)
+ apply clarify
+ apply (simp only: less_diff_eq)
+ apply (erule le_less_trans [OF dist_triangle])
+ apply simp
+ apply clarify
+ apply (drule spec, erule mp)
+ apply (simp add: dist_vector_def setL2_strict_mono)
+ apply (rule_tac x="\<lambda>i. e / sqrt (of_nat CARD('b))" in exI)
+ apply (simp add: divide_pos_pos setL2_constant)
+ done
+qed
+
+end
+
+lemma LIMSEQ_Cart_nth:
+ "(X ----> a) \<Longrightarrow> (\<lambda>n. X n $ i) ----> a $ i"
+unfolding LIMSEQ_conv_tendsto by (rule tendsto_Cart_nth)
+
+lemma LIM_Cart_nth:
+ "(f -- x --> y) \<Longrightarrow> (\<lambda>x. f x $ i) -- x --> y $ i"
+unfolding LIM_conv_tendsto by (rule tendsto_Cart_nth)
+
+lemma Cauchy_Cart_nth:
+ "Cauchy (\<lambda>n. X n) \<Longrightarrow> Cauchy (\<lambda>n. X n $ i)"
+unfolding Cauchy_def by (fast intro: le_less_trans [OF dist_nth_le])
+
+lemma LIMSEQ_vector:
+ fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n::finite"
+ assumes X: "\<And>i. (\<lambda>n. X n $ i) ----> (a $ i)"
+ shows "X ----> a"
+proof (rule metric_LIMSEQ_I)
+ fix r :: real assume "0 < r"
+ then have "0 < r / of_nat CARD('n)" (is "0 < ?s")
+ by (simp add: divide_pos_pos)
+ def N \<equiv> "\<lambda>i. LEAST N. \<forall>n\<ge>N. dist (X n $ i) (a $ i) < ?s"
+ def M \<equiv> "Max (range N)"
+ have "\<And>i. \<exists>N. \<forall>n\<ge>N. dist (X n $ i) (a $ i) < ?s"
+ using X `0 < ?s` by (rule metric_LIMSEQ_D)
+ hence "\<And>i. \<forall>n\<ge>N i. dist (X n $ i) (a $ i) < ?s"
+ unfolding N_def by (rule LeastI_ex)
+ hence M: "\<And>i. \<forall>n\<ge>M. dist (X n $ i) (a $ i) < ?s"
+ unfolding M_def by simp
+ {
+ fix n :: nat assume "M \<le> n"
+ have "dist (X n) a = setL2 (\<lambda>i. dist (X n $ i) (a $ i)) UNIV"
+ unfolding dist_vector_def ..
+ also have "\<dots> \<le> setsum (\<lambda>i. dist (X n $ i) (a $ i)) UNIV"
+ by (rule setL2_le_setsum [OF zero_le_dist])
+ also have "\<dots> < setsum (\<lambda>i::'n. ?s) UNIV"
+ by (rule setsum_strict_mono, simp_all add: M `M \<le> n`)
+ also have "\<dots> = r"
+ by simp
+ finally have "dist (X n) a < r" .
+ }
+ hence "\<forall>n\<ge>M. dist (X n) a < r"
+ by simp
+ then show "\<exists>M. \<forall>n\<ge>M. dist (X n) a < r" ..
+qed
+
+lemma Cauchy_vector:
+ fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n::finite"
+ assumes X: "\<And>i. Cauchy (\<lambda>n. X n $ i)"
+ shows "Cauchy (\<lambda>n. X n)"
+proof (rule metric_CauchyI)
+ fix r :: real assume "0 < r"
+ then have "0 < r / of_nat CARD('n)" (is "0 < ?s")
+ by (simp add: divide_pos_pos)
+ def N \<equiv> "\<lambda>i. LEAST N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
+ def M \<equiv> "Max (range N)"
+ have "\<And>i. \<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
+ using X `0 < ?s` by (rule metric_CauchyD)
+ hence "\<And>i. \<forall>m\<ge>N i. \<forall>n\<ge>N i. dist (X m $ i) (X n $ i) < ?s"
+ unfolding N_def by (rule LeastI_ex)
+ hence M: "\<And>i. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m $ i) (X n $ i) < ?s"
+ unfolding M_def by simp
+ {
+ fix m n :: nat
+ assume "M \<le> m" "M \<le> n"
+ have "dist (X m) (X n) = setL2 (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
+ unfolding dist_vector_def ..
+ also have "\<dots> \<le> setsum (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
+ by (rule setL2_le_setsum [OF zero_le_dist])
+ also have "\<dots> < setsum (\<lambda>i::'n. ?s) UNIV"
+ by (rule setsum_strict_mono, simp_all add: M `M \<le> m` `M \<le> n`)
+ also have "\<dots> = r"
+ by simp
+ finally have "dist (X m) (X n) < r" .
+ }
+ hence "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r"
+ by simp
+ then show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r" ..
+qed
+
+instance "^" :: (complete_space, finite) complete_space
+proof
+ fix X :: "nat \<Rightarrow> 'a ^ 'b" assume "Cauchy X"
+ have "\<And>i. (\<lambda>n. X n $ i) ----> lim (\<lambda>n. X n $ i)"
+ using Cauchy_Cart_nth [OF `Cauchy X`]
+ by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
+ hence "X ----> Cart_lambda (\<lambda>i. lim (\<lambda>n. X n $ i))"
+ by (simp add: LIMSEQ_vector)
+ then show "convergent X"
+ by (rule convergentI)
+qed
+
+subsection {* Norms *}
+
+instantiation "^" :: (real_normed_vector, finite) real_normed_vector
+begin
+
+definition norm_vector_def:
+ "norm (x::'a^'b) = setL2 (\<lambda>i. norm (x$i)) UNIV"
+
+definition vector_sgn_def:
+ "sgn (x::'a^'b) = scaleR (inverse (norm x)) x"
+
+instance proof
+ fix a :: real and x y :: "'a ^ 'b"
+ show "0 \<le> norm x"
+ unfolding norm_vector_def
+ by (rule setL2_nonneg)
+ show "norm x = 0 \<longleftrightarrow> x = 0"
+ unfolding norm_vector_def
+ by (simp add: setL2_eq_0_iff Cart_eq)
+ show "norm (x + y) \<le> norm x + norm y"
+ unfolding norm_vector_def
+ apply (rule order_trans [OF _ setL2_triangle_ineq])
+ apply (simp add: setL2_mono norm_triangle_ineq)
+ done
+ show "norm (scaleR a x) = \<bar>a\<bar> * norm x"
+ unfolding norm_vector_def
+ by (simp add: setL2_right_distrib)
+ show "sgn x = scaleR (inverse (norm x)) x"
+ by (rule vector_sgn_def)
+ show "dist x y = norm (x - y)"
+ unfolding dist_vector_def norm_vector_def
+ by (simp add: dist_norm)
+qed
+
+end
+
+lemma norm_nth_le: "norm (x $ i) \<le> norm x"
+unfolding norm_vector_def
+by (rule member_le_setL2) simp_all
+
+interpretation Cart_nth: bounded_linear "\<lambda>x. x $ i"
+apply default
+apply (rule vector_add_component)
+apply (rule vector_scaleR_component)
+apply (rule_tac x="1" in exI, simp add: norm_nth_le)
+done
+
+instance "^" :: (banach, finite) banach ..
+
+subsection {* Inner products *}
+
+instantiation "^" :: (real_inner, finite) real_inner
+begin
+
+definition inner_vector_def:
+ "inner x y = setsum (\<lambda>i. inner (x$i) (y$i)) UNIV"
+
+instance proof
+ fix r :: real and x y z :: "'a ^ 'b"
+ show "inner x y = inner y x"
+ unfolding inner_vector_def
+ by (simp add: inner_commute)
+ show "inner (x + y) z = inner x z + inner y z"
+ unfolding inner_vector_def
+ by (simp add: inner_add_left setsum_addf)
+ show "inner (scaleR r x) y = r * inner x y"
+ unfolding inner_vector_def
+ by (simp add: setsum_right_distrib)
+ show "0 \<le> inner x x"
+ unfolding inner_vector_def
+ by (simp add: setsum_nonneg)
+ show "inner x x = 0 \<longleftrightarrow> x = 0"
+ unfolding inner_vector_def
+ by (simp add: Cart_eq setsum_nonneg_eq_0_iff)
+ show "norm x = sqrt (inner x x)"
+ unfolding inner_vector_def norm_vector_def setL2_def
+ by (simp add: power2_norm_eq_inner)
+qed
+
+end
+
+subsection{* Properties of the dot product. *}
+
+lemma dot_sym: "(x::'a:: {comm_monoid_add, ab_semigroup_mult} ^ 'n) \<bullet> y = y \<bullet> x"
+ by (vector mult_commute)
+lemma dot_ladd: "((x::'a::ring ^ 'n) + y) \<bullet> z = (x \<bullet> z) + (y \<bullet> z)"
+ by (vector ring_simps)
+lemma dot_radd: "x \<bullet> (y + (z::'a::ring ^ 'n)) = (x \<bullet> y) + (x \<bullet> z)"
+ by (vector ring_simps)
+lemma dot_lsub: "((x::'a::ring ^ 'n) - y) \<bullet> z = (x \<bullet> z) - (y \<bullet> z)"
+ by (vector ring_simps)
+lemma dot_rsub: "(x::'a::ring ^ 'n) \<bullet> (y - z) = (x \<bullet> y) - (x \<bullet> z)"
+ by (vector ring_simps)
+lemma dot_lmult: "(c *s x) \<bullet> y = (c::'a::ring) * (x \<bullet> y)" by (vector ring_simps)
+lemma dot_rmult: "x \<bullet> (c *s y) = (c::'a::comm_ring) * (x \<bullet> y)" by (vector ring_simps)
+lemma dot_lneg: "(-x) \<bullet> (y::'a::ring ^ 'n) = -(x \<bullet> y)" by vector
+lemma dot_rneg: "(x::'a::ring ^ 'n) \<bullet> (-y) = -(x \<bullet> y)" by vector
+lemma dot_lzero[simp]: "0 \<bullet> x = (0::'a::{comm_monoid_add, mult_zero})" by vector
+lemma dot_rzero[simp]: "x \<bullet> 0 = (0::'a::{comm_monoid_add, mult_zero})" by vector
+lemma dot_pos_le[simp]: "(0::'a\<Colon>ordered_ring_strict) <= x \<bullet> x"
+ by (simp add: dot_def setsum_nonneg)
+
+lemma setsum_squares_eq_0_iff: assumes fS: "finite F" and fp: "\<forall>x \<in> F. f x \<ge> (0 ::'a::pordered_ab_group_add)" shows "setsum f F = 0 \<longleftrightarrow> (ALL x:F. f x = 0)"
+using fS fp setsum_nonneg[OF fp]
+proof (induct set: finite)
+ case empty thus ?case by simp
+next
+ case (insert x F)
+ from insert.prems have Fx: "f x \<ge> 0" and Fp: "\<forall> a \<in> F. f a \<ge> 0" by simp_all
+ from insert.hyps Fp setsum_nonneg[OF Fp]
+ have h: "setsum f F = 0 \<longleftrightarrow> (\<forall>a \<in>F. f a = 0)" by metis
+ from add_nonneg_eq_0_iff[OF Fx setsum_nonneg[OF Fp]] insert.hyps(1,2)
+ show ?case by (simp add: h)
+qed
+
+lemma dot_eq_0: "x \<bullet> x = 0 \<longleftrightarrow> (x::'a::{ordered_ring_strict,ring_no_zero_divisors} ^ 'n::finite) = 0"
+ by (simp add: dot_def setsum_squares_eq_0_iff Cart_eq)
+
+lemma dot_pos_lt[simp]: "(0 < x \<bullet> x) \<longleftrightarrow> (x::'a::{ordered_ring_strict,ring_no_zero_divisors} ^ 'n::finite) \<noteq> 0" using dot_eq_0[of x] dot_pos_le[of x]
+ by (auto simp add: le_less)
+
+subsection{* The collapse of the general concepts to dimension one. *}
+
+lemma vector_one: "(x::'a ^1) = (\<chi> i. (x$1))"
+ by (simp add: Cart_eq forall_1)
+
+lemma forall_one: "(\<forall>(x::'a ^1). P x) \<longleftrightarrow> (\<forall>x. P(\<chi> i. x))"
+ apply auto
+ apply (erule_tac x= "x$1" in allE)
+ apply (simp only: vector_one[symmetric])
+ done
+
+lemma norm_vector_1: "norm (x :: _^1) = norm (x$1)"
+ by (simp add: norm_vector_def UNIV_1)
+
+lemma norm_real: "norm(x::real ^ 1) = abs(x$1)"
+ by (simp add: norm_vector_1)
+
+lemma dist_real: "dist(x::real ^ 1) y = abs((x$1) - (y$1))"
+ by (auto simp add: norm_real dist_norm)
+
+subsection {* A connectedness or intermediate value lemma with several applications. *}
+
+lemma connected_real_lemma:
+ fixes f :: "real \<Rightarrow> 'a::metric_space"
+ assumes ab: "a \<le> b" and fa: "f a \<in> e1" and fb: "f b \<in> e2"
+ and dst: "\<And>e x. a <= x \<Longrightarrow> x <= b \<Longrightarrow> 0 < e ==> \<exists>d > 0. \<forall>y. abs(y - x) < d \<longrightarrow> dist(f y) (f x) < e"
+ and e1: "\<forall>y \<in> e1. \<exists>e > 0. \<forall>y'. dist y' y < e \<longrightarrow> y' \<in> e1"
+ and e2: "\<forall>y \<in> e2. \<exists>e > 0. \<forall>y'. dist y' y < e \<longrightarrow> y' \<in> e2"
+ and e12: "~(\<exists>x \<ge> a. x <= b \<and> f x \<in> e1 \<and> f x \<in> e2)"
+ shows "\<exists>x \<ge> a. x <= b \<and> f x \<notin> e1 \<and> f x \<notin> e2" (is "\<exists> x. ?P x")
+proof-
+ let ?S = "{c. \<forall>x \<ge> a. x <= c \<longrightarrow> f x \<in> e1}"
+ have Se: " \<exists>x. x \<in> ?S" apply (rule exI[where x=a]) by (auto simp add: fa)
+ have Sub: "\<exists>y. isUb UNIV ?S y"
+ apply (rule exI[where x= b])
+ using ab fb e12 by (auto simp add: isUb_def setle_def)
+ from reals_complete[OF Se Sub] obtain l where
+ l: "isLub UNIV ?S l"by blast
+ have alb: "a \<le> l" "l \<le> b" using l ab fa fb e12
+ apply (auto simp add: isLub_def leastP_def isUb_def setle_def setge_def)
+ by (metis linorder_linear)
+ have ale1: "\<forall>z \<ge> a. z < l \<longrightarrow> f z \<in> e1" using l
+ apply (auto simp add: isLub_def leastP_def isUb_def setle_def setge_def)
+ by (metis linorder_linear not_le)
+ have th1: "\<And>z x e d :: real. z <= x + e \<Longrightarrow> e < d ==> z < x \<or> abs(z - x) < d" by arith
+ have th2: "\<And>e x:: real. 0 < e ==> ~(x + e <= x)" by arith
+ have th3: "\<And>d::real. d > 0 \<Longrightarrow> \<exists>e > 0. e < d" by dlo
+ {assume le2: "f l \<in> e2"
+ from le2 fa fb e12 alb have la: "l \<noteq> a" by metis
+ hence lap: "l - a > 0" using alb by arith
+ from e2[rule_format, OF le2] obtain e where
+ e: "e > 0" "\<forall>y. dist y (f l) < e \<longrightarrow> y \<in> e2" by metis
+ from dst[OF alb e(1)] obtain d where
+ d: "d > 0" "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> dist (f y) (f l) < e" by metis
+ have "\<exists>d'. d' < d \<and> d' >0 \<and> l - d' > a" using lap d(1)
+ apply ferrack by arith
+ then obtain d' where d': "d' > 0" "d' < d" "l - d' > a" by metis
+ from d e have th0: "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> f y \<in> e2" by metis
+ from th0[rule_format, of "l - d'"] d' have "f (l - d') \<in> e2" by auto
+ moreover
+ have "f (l - d') \<in> e1" using ale1[rule_format, of "l -d'"] d' by auto
+ ultimately have False using e12 alb d' by auto}
+ moreover
+ {assume le1: "f l \<in> e1"
+ from le1 fa fb e12 alb have lb: "l \<noteq> b" by metis
+ hence blp: "b - l > 0" using alb by arith
+ from e1[rule_format, OF le1] obtain e where
+ e: "e > 0" "\<forall>y. dist y (f l) < e \<longrightarrow> y \<in> e1" by metis
+ from dst[OF alb e(1)] obtain d where
+ d: "d > 0" "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> dist (f y) (f l) < e" by metis
+ have "\<exists>d'. d' < d \<and> d' >0" using d(1) by dlo
+ then obtain d' where d': "d' > 0" "d' < d" by metis
+ from d e have th0: "\<forall>y. \<bar>y - l\<bar> < d \<longrightarrow> f y \<in> e1" by auto
+ hence "\<forall>y. l \<le> y \<and> y \<le> l + d' \<longrightarrow> f y \<in> e1" using d' by auto
+ with ale1 have "\<forall>y. a \<le> y \<and> y \<le> l + d' \<longrightarrow> f y \<in> e1" by auto
+ with l d' have False
+ by (auto simp add: isLub_def isUb_def setle_def setge_def leastP_def) }
+ ultimately show ?thesis using alb by metis
+qed
+
+text{* One immediately useful corollary is the existence of square roots! --- Should help to get rid of all the development of square-root for reals as a special case @{typ "real^1"} *}
+
+lemma square_bound_lemma: "(x::real) < (1 + x) * (1 + x)"
+proof-
+ have "(x + 1/2)^2 + 3/4 > 0" using zero_le_power2[of "x+1/2"] by arith
+ thus ?thesis by (simp add: ring_simps power2_eq_square)
+qed
+
+lemma square_continuous: "0 < (e::real) ==> \<exists>d. 0 < d \<and> (\<forall>y. abs(y - x) < d \<longrightarrow> abs(y * y - x * x) < e)"
+ using isCont_power[OF isCont_ident, of 2, unfolded isCont_def LIM_eq, rule_format, of e x] apply (auto simp add: power2_eq_square)
+ apply (rule_tac x="s" in exI)
+ apply auto
+ apply (erule_tac x=y in allE)
+ apply auto
+ done
+
+lemma real_le_lsqrt: "0 <= x \<Longrightarrow> 0 <= y \<Longrightarrow> x <= y^2 ==> sqrt x <= y"
+ using real_sqrt_le_iff[of x "y^2"] by simp
+
+lemma real_le_rsqrt: "x^2 \<le> y \<Longrightarrow> x \<le> sqrt y"
+ using real_sqrt_le_mono[of "x^2" y] by simp
+
+lemma real_less_rsqrt: "x^2 < y \<Longrightarrow> x < sqrt y"
+ using real_sqrt_less_mono[of "x^2" y] by simp
+
+lemma sqrt_even_pow2: assumes n: "even n"
+ shows "sqrt(2 ^ n) = 2 ^ (n div 2)"
+proof-
+ from n obtain m where m: "n = 2*m" unfolding even_nat_equiv_def2
+ by (auto simp add: nat_number)
+ from m have "sqrt(2 ^ n) = sqrt ((2 ^ m) ^ 2)"
+ by (simp only: power_mult[symmetric] mult_commute)
+ then show ?thesis using m by simp
+qed
+
+lemma real_div_sqrt: "0 <= x ==> x / sqrt(x) = sqrt(x)"
+ apply (cases "x = 0", simp_all)
+ using sqrt_divide_self_eq[of x]
+ apply (simp add: inverse_eq_divide real_sqrt_ge_0_iff field_simps)
+ done
+
+text{* Hence derive more interesting properties of the norm. *}
+
+text {*
+ This type-specific version is only here
+ to make @{text normarith.ML} happy.
+*}
+lemma norm_0: "norm (0::real ^ _) = 0"
+ by (rule norm_zero)
+
+lemma norm_mul[simp]: "norm(a *s x) = abs(a) * norm x"
+ by (simp add: norm_vector_def vector_component setL2_right_distrib
+ abs_mult cong: strong_setL2_cong)
+lemma norm_eq_0_dot: "(norm x = 0) \<longleftrightarrow> (x \<bullet> x = (0::real))"
+ by (simp add: norm_vector_def dot_def setL2_def power2_eq_square)
+lemma real_vector_norm_def: "norm x = sqrt (x \<bullet> x)"
+ by (simp add: norm_vector_def setL2_def dot_def power2_eq_square)
+lemma norm_pow_2: "norm x ^ 2 = x \<bullet> x"
+ by (simp add: real_vector_norm_def)
+lemma norm_eq_0_imp: "norm x = 0 ==> x = (0::real ^'n::finite)" by (metis norm_eq_zero)
+lemma vector_mul_eq_0[simp]: "(a *s x = 0) \<longleftrightarrow> a = (0::'a::idom) \<or> x = 0"
+ by vector
+lemma vector_mul_lcancel[simp]: "a *s x = a *s y \<longleftrightarrow> a = (0::real) \<or> x = y"
+ by (metis eq_iff_diff_eq_0 vector_mul_eq_0 vector_ssub_ldistrib)
+lemma vector_mul_rcancel[simp]: "a *s x = b *s x \<longleftrightarrow> (a::real) = b \<or> x = 0"
+ by (metis eq_iff_diff_eq_0 vector_mul_eq_0 vector_sub_rdistrib)
+lemma vector_mul_lcancel_imp: "a \<noteq> (0::real) ==> a *s x = a *s y ==> (x = y)"
+ by (metis vector_mul_lcancel)
+lemma vector_mul_rcancel_imp: "x \<noteq> 0 \<Longrightarrow> (a::real) *s x = b *s x ==> a = b"
+ by (metis vector_mul_rcancel)
+lemma norm_cauchy_schwarz:
+ fixes x y :: "real ^ 'n::finite"
+ shows "x \<bullet> y <= norm x * norm y"
+proof-
+ {assume "norm x = 0"
+ hence ?thesis by (simp add: dot_lzero dot_rzero)}
+ moreover
+ {assume "norm y = 0"
+ hence ?thesis by (simp add: dot_lzero dot_rzero)}
+ moreover
+ {assume h: "norm x \<noteq> 0" "norm y \<noteq> 0"
+ let ?z = "norm y *s x - norm x *s y"
+ from h have p: "norm x * norm y > 0" by (metis norm_ge_zero le_less zero_compare_simps)
+ from dot_pos_le[of ?z]
+ have "(norm x * norm y) * (x \<bullet> y) \<le> norm x ^2 * norm y ^2"
+ apply (simp add: dot_rsub dot_lsub dot_lmult dot_rmult ring_simps)
+ by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym)
+ hence "x\<bullet>y \<le> (norm x ^2 * norm y ^2) / (norm x * norm y)" using p
+ by (simp add: field_simps)
+ hence ?thesis using h by (simp add: power2_eq_square)}
+ ultimately show ?thesis by metis
+qed
+
+lemma norm_cauchy_schwarz_abs:
+ fixes x y :: "real ^ 'n::finite"
+ shows "\<bar>x \<bullet> y\<bar> \<le> norm x * norm y"
+ using norm_cauchy_schwarz[of x y] norm_cauchy_schwarz[of x "-y"]
+ by (simp add: real_abs_def dot_rneg)
+
+lemma norm_triangle_sub:
+ fixes x y :: "'a::real_normed_vector"
+ shows "norm x \<le> norm y + norm (x - y)"
+ using norm_triangle_ineq[of "y" "x - y"] by (simp add: ring_simps)
+
+lemma norm_triangle_le: "norm(x::real ^'n::finite) + norm y <= e ==> norm(x + y) <= e"
+ by (metis order_trans norm_triangle_ineq)
+lemma norm_triangle_lt: "norm(x::real ^'n::finite) + norm(y) < e ==> norm(x + y) < e"
+ by (metis basic_trans_rules(21) norm_triangle_ineq)
+
+lemma component_le_norm: "\<bar>x$i\<bar> <= norm (x::real ^ 'n::finite)"
+ apply (simp add: norm_vector_def)
+ apply (rule member_le_setL2, simp_all)
+ done
+
+lemma norm_bound_component_le: "norm(x::real ^ 'n::finite) <= e
+ ==> \<bar>x$i\<bar> <= e"
+ by (metis component_le_norm order_trans)
+
+lemma norm_bound_component_lt: "norm(x::real ^ 'n::finite) < e
+ ==> \<bar>x$i\<bar> < e"
+ by (metis component_le_norm basic_trans_rules(21))
+
+lemma norm_le_l1: "norm (x:: real ^'n::finite) <= setsum(\<lambda>i. \<bar>x$i\<bar>) UNIV"
+ by (simp add: norm_vector_def setL2_le_setsum)
+
+lemma real_abs_norm: "\<bar>norm x\<bar> = norm (x :: real ^ _)"
+ by (rule abs_norm_cancel)
+lemma real_abs_sub_norm: "\<bar>norm(x::real ^'n::finite) - norm y\<bar> <= norm(x - y)"
+ by (rule norm_triangle_ineq3)
+lemma norm_le: "norm(x::real ^ _) <= norm(y) \<longleftrightarrow> x \<bullet> x <= y \<bullet> y"
+ by (simp add: real_vector_norm_def)
+lemma norm_lt: "norm(x::real ^ _) < norm(y) \<longleftrightarrow> x \<bullet> x < y \<bullet> y"
+ by (simp add: real_vector_norm_def)
+lemma norm_eq: "norm (x::real ^ _) = norm y \<longleftrightarrow> x \<bullet> x = y \<bullet> y"
+ by (simp add: order_eq_iff norm_le)
+lemma norm_eq_1: "norm(x::real ^ _) = 1 \<longleftrightarrow> x \<bullet> x = 1"
+ by (simp add: real_vector_norm_def)
+
+text{* Squaring equations and inequalities involving norms. *}
+
+lemma dot_square_norm: "x \<bullet> x = norm(x)^2"
+ by (simp add: real_vector_norm_def)
+
+lemma norm_eq_square: "norm(x) = a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x = a^2"
+ by (auto simp add: real_vector_norm_def)
+
+lemma real_abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> (x::real)^2 \<le> y^2"
+proof-
+ have "x^2 \<le> y^2 \<longleftrightarrow> (x -y) * (y + x) \<le> 0" by (simp add: ring_simps power2_eq_square)
+ also have "\<dots> \<longleftrightarrow> \<bar>x\<bar> \<le> \<bar>y\<bar>" apply (simp add: zero_compare_simps real_abs_def not_less) by arith
+finally show ?thesis ..
+qed
+
+lemma norm_le_square: "norm(x) <= a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x <= a^2"
+ apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
+ using norm_ge_zero[of x]
+ apply arith
+ done
+
+lemma norm_ge_square: "norm(x) >= a \<longleftrightarrow> a <= 0 \<or> x \<bullet> x >= a ^ 2"
+ apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
+ using norm_ge_zero[of x]
+ apply arith
+ done
+
+lemma norm_lt_square: "norm(x) < a \<longleftrightarrow> 0 < a \<and> x \<bullet> x < a^2"
+ by (metis not_le norm_ge_square)
+lemma norm_gt_square: "norm(x) > a \<longleftrightarrow> a < 0 \<or> x \<bullet> x > a^2"
+ by (metis norm_le_square not_less)
+
+text{* Dot product in terms of the norm rather than conversely. *}
+
+lemma dot_norm: "x \<bullet> y = (norm(x + y) ^2 - norm x ^ 2 - norm y ^ 2) / 2"
+ by (simp add: norm_pow_2 dot_ladd dot_radd dot_sym)
+
+lemma dot_norm_neg: "x \<bullet> y = ((norm x ^ 2 + norm y ^ 2) - norm(x - y) ^ 2) / 2"
+ by (simp add: norm_pow_2 dot_ladd dot_radd dot_lsub dot_rsub dot_sym)
+
+
+text{* Equality of vectors in terms of @{term "op \<bullet>"} products. *}
+
+lemma vector_eq: "(x:: real ^ 'n::finite) = y \<longleftrightarrow> x \<bullet> x = x \<bullet> y\<and> y \<bullet> y = x \<bullet> x" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume "?lhs" then show ?rhs by simp
+next
+ assume ?rhs
+ then have "x \<bullet> x - x \<bullet> y = 0 \<and> x \<bullet> y - y\<bullet> y = 0" by simp
+ hence "x \<bullet> (x - y) = 0 \<and> y \<bullet> (x - y) = 0"
+ by (simp add: dot_rsub dot_lsub dot_sym)
+ then have "(x - y) \<bullet> (x - y) = 0" by (simp add: ring_simps dot_lsub dot_rsub)
+ then show "x = y" by (simp add: dot_eq_0)
+qed
+
+
+subsection{* General linear decision procedure for normed spaces. *}
+
+lemma norm_cmul_rule_thm:
+ fixes x :: "'a::real_normed_vector"
+ shows "b >= norm(x) ==> \<bar>c\<bar> * b >= norm(scaleR c x)"
+ unfolding norm_scaleR
+ apply (erule mult_mono1)
+ apply simp
+ done
+
+ (* FIXME: Move all these theorems into the ML code using lemma antiquotation *)
+lemma norm_add_rule_thm:
+ fixes x1 x2 :: "'a::real_normed_vector"
+ shows "norm x1 \<le> b1 \<Longrightarrow> norm x2 \<le> b2 \<Longrightarrow> norm (x1 + x2) \<le> b1 + b2"
+ by (rule order_trans [OF norm_triangle_ineq add_mono])
+
+lemma ge_iff_diff_ge_0: "(a::'a::ordered_ring) \<ge> b == a - b \<ge> 0"
+ by (simp add: ring_simps)
+
+lemma pth_1:
+ fixes x :: "'a::real_normed_vector"
+ shows "x == scaleR 1 x" by simp
+
+lemma pth_2:
+ fixes x :: "'a::real_normed_vector"
+ shows "x - y == x + -y" by (atomize (full)) simp
+
+lemma pth_3:
+ fixes x :: "'a::real_normed_vector"
+ shows "- x == scaleR (-1) x" by simp
+
+lemma pth_4:
+ fixes x :: "'a::real_normed_vector"
+ shows "scaleR 0 x == 0" and "scaleR c 0 = (0::'a)" by simp_all
+
+lemma pth_5:
+ fixes x :: "'a::real_normed_vector"
+ shows "scaleR c (scaleR d x) == scaleR (c * d) x" by simp
+
+lemma pth_6:
+ fixes x :: "'a::real_normed_vector"
+ shows "scaleR c (x + y) == scaleR c x + scaleR c y"
+ by (simp add: scaleR_right_distrib)
+
+lemma pth_7:
+ fixes x :: "'a::real_normed_vector"
+ shows "0 + x == x" and "x + 0 == x" by simp_all
+
+lemma pth_8:
+ fixes x :: "'a::real_normed_vector"
+ shows "scaleR c x + scaleR d x == scaleR (c + d) x"
+ by (simp add: scaleR_left_distrib)
+
+lemma pth_9:
+ fixes x :: "'a::real_normed_vector" shows
+ "(scaleR c x + z) + scaleR d x == scaleR (c + d) x + z"
+ "scaleR c x + (scaleR d x + z) == scaleR (c + d) x + z"
+ "(scaleR c x + w) + (scaleR d x + z) == scaleR (c + d) x + (w + z)"
+ by (simp_all add: algebra_simps)
+
+lemma pth_a:
+ fixes x :: "'a::real_normed_vector"
+ shows "scaleR 0 x + y == y" by simp
+
+lemma pth_b:
+ fixes x :: "'a::real_normed_vector" shows
+ "scaleR c x + scaleR d y == scaleR c x + scaleR d y"
+ "(scaleR c x + z) + scaleR d y == scaleR c x + (z + scaleR d y)"
+ "scaleR c x + (scaleR d y + z) == scaleR c x + (scaleR d y + z)"
+ "(scaleR c x + w) + (scaleR d y + z) == scaleR c x + (w + (scaleR d y + z))"
+ by (simp_all add: algebra_simps)
+
+lemma pth_c:
+ fixes x :: "'a::real_normed_vector" shows
+ "scaleR c x + scaleR d y == scaleR d y + scaleR c x"
+ "(scaleR c x + z) + scaleR d y == scaleR d y + (scaleR c x + z)"
+ "scaleR c x + (scaleR d y + z) == scaleR d y + (scaleR c x + z)"
+ "(scaleR c x + w) + (scaleR d y + z) == scaleR d y + ((scaleR c x + w) + z)"
+ by (simp_all add: algebra_simps)
+
+lemma pth_d:
+ fixes x :: "'a::real_normed_vector"
+ shows "x + 0 == x" by simp
+
+lemma norm_imp_pos_and_ge:
+ fixes x :: "'a::real_normed_vector"
+ shows "norm x == n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
+ by atomize auto
+
+lemma real_eq_0_iff_le_ge_0: "(x::real) = 0 == x \<ge> 0 \<and> -x \<ge> 0" by arith
+
+lemma norm_pths:
+ fixes x :: "'a::real_normed_vector" shows
+ "x = y \<longleftrightarrow> norm (x - y) \<le> 0"
+ "x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
+ using norm_ge_zero[of "x - y"] by auto
+
+lemma vector_dist_norm:
+ fixes x :: "'a::real_normed_vector"
+ shows "dist x y = norm (x - y)"
+ by (rule dist_norm)
+
+use "normarith.ML"
+
+method_setup norm = {* Scan.succeed (SIMPLE_METHOD' o NormArith.norm_arith_tac)
+*} "Proves simple linear statements about vector norms"
+
+
+text{* Hence more metric properties. *}
+
+lemma dist_triangle_alt:
+ fixes x y z :: "'a::metric_space"
+ shows "dist y z <= dist x y + dist x z"
+using dist_triangle [of y z x] by (simp add: dist_commute)
+
+lemma dist_pos_lt:
+ fixes x y :: "'a::metric_space"
+ shows "x \<noteq> y ==> 0 < dist x y"
+by (simp add: zero_less_dist_iff)
+
+lemma dist_nz:
+ fixes x y :: "'a::metric_space"
+ shows "x \<noteq> y \<longleftrightarrow> 0 < dist x y"
+by (simp add: zero_less_dist_iff)
+
+lemma dist_triangle_le:
+ fixes x y z :: "'a::metric_space"
+ shows "dist x z + dist y z <= e \<Longrightarrow> dist x y <= e"
+by (rule order_trans [OF dist_triangle2])
+
+lemma dist_triangle_lt:
+ fixes x y z :: "'a::metric_space"
+ shows "dist x z + dist y z < e ==> dist x y < e"
+by (rule le_less_trans [OF dist_triangle2])
+
+lemma dist_triangle_half_l:
+ fixes x1 x2 y :: "'a::metric_space"
+ shows "dist x1 y < e / 2 \<Longrightarrow> dist x2 y < e / 2 \<Longrightarrow> dist x1 x2 < e"
+by (rule dist_triangle_lt [where z=y], simp)
+
+lemma dist_triangle_half_r:
+ fixes x1 x2 y :: "'a::metric_space"
+ shows "dist y x1 < e / 2 \<Longrightarrow> dist y x2 < e / 2 \<Longrightarrow> dist x1 x2 < e"
+by (rule dist_triangle_half_l, simp_all add: dist_commute)
+
+lemma dist_triangle_add:
+ fixes x y x' y' :: "'a::real_normed_vector"
+ shows "dist (x + y) (x' + y') <= dist x x' + dist y y'"
+ by norm
+
+lemma dist_mul[simp]: "dist (c *s x) (c *s y) = \<bar>c\<bar> * dist x y"
+ unfolding dist_norm vector_ssub_ldistrib[symmetric] norm_mul ..
+
+lemma dist_triangle_add_half:
+ fixes x x' y y' :: "'a::real_normed_vector"
+ shows "dist x x' < e / 2 \<Longrightarrow> dist y y' < e / 2 \<Longrightarrow> dist(x + y) (x' + y') < e"
+ by norm
+
+lemma setsum_component [simp]:
+ fixes f:: " 'a \<Rightarrow> ('b::comm_monoid_add) ^'n"
+ shows "(setsum f S)$i = setsum (\<lambda>x. (f x)$i) S"
+ by (cases "finite S", induct S set: finite, simp_all)
+
+lemma setsum_eq: "setsum f S = (\<chi> i. setsum (\<lambda>x. (f x)$i ) S)"
+ by (simp add: Cart_eq)
+
+lemma setsum_clauses:
+ shows "setsum f {} = 0"
+ and "finite S \<Longrightarrow> setsum f (insert x S) =
+ (if x \<in> S then setsum f S else f x + setsum f S)"
+ by (auto simp add: insert_absorb)
+
+lemma setsum_cmul:
+ fixes f:: "'c \<Rightarrow> ('a::semiring_1)^'n"
+ shows "setsum (\<lambda>x. c *s f x) S = c *s setsum f S"
+ by (simp add: Cart_eq setsum_right_distrib)
+
+lemma setsum_norm:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes fS: "finite S"
+ shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
+proof(induct rule: finite_induct[OF fS])
+ case 1 thus ?case by simp
+next
+ case (2 x S)
+ from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
+ also have "\<dots> \<le> norm (f x) + setsum (\<lambda>x. norm(f x)) S"
+ using "2.hyps" by simp
+ finally show ?case using "2.hyps" by simp
+qed
+
+lemma real_setsum_norm:
+ fixes f :: "'a \<Rightarrow> real ^'n::finite"
+ assumes fS: "finite S"
+ shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
+proof(induct rule: finite_induct[OF fS])
+ case 1 thus ?case by simp
+next
+ case (2 x S)
+ from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
+ also have "\<dots> \<le> norm (f x) + setsum (\<lambda>x. norm(f x)) S"
+ using "2.hyps" by simp
+ finally show ?case using "2.hyps" by simp
+qed
+
+lemma setsum_norm_le:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes fS: "finite S"
+ and fg: "\<forall>x \<in> S. norm (f x) \<le> g x"
+ shows "norm (setsum f S) \<le> setsum g S"
+proof-
+ from fg have "setsum (\<lambda>x. norm(f x)) S <= setsum g S"
+ by - (rule setsum_mono, simp)
+ then show ?thesis using setsum_norm[OF fS, of f] fg
+ by arith
+qed
+
+lemma real_setsum_norm_le:
+ fixes f :: "'a \<Rightarrow> real ^ 'n::finite"
+ assumes fS: "finite S"
+ and fg: "\<forall>x \<in> S. norm (f x) \<le> g x"
+ shows "norm (setsum f S) \<le> setsum g S"
+proof-
+ from fg have "setsum (\<lambda>x. norm(f x)) S <= setsum g S"
+ by - (rule setsum_mono, simp)
+ then show ?thesis using real_setsum_norm[OF fS, of f] fg
+ by arith
+qed
+
+lemma setsum_norm_bound:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes fS: "finite S"
+ and K: "\<forall>x \<in> S. norm (f x) \<le> K"
+ shows "norm (setsum f S) \<le> of_nat (card S) * K"
+ using setsum_norm_le[OF fS K] setsum_constant[symmetric]
+ by simp
+
+lemma real_setsum_norm_bound:
+ fixes f :: "'a \<Rightarrow> real ^ 'n::finite"
+ assumes fS: "finite S"
+ and K: "\<forall>x \<in> S. norm (f x) \<le> K"
+ shows "norm (setsum f S) \<le> of_nat (card S) * K"
+ using real_setsum_norm_le[OF fS K] setsum_constant[symmetric]
+ by simp
+
+lemma setsum_vmul:
+ fixes f :: "'a \<Rightarrow> 'b::{real_normed_vector,semiring, mult_zero}"
+ assumes fS: "finite S"
+ shows "setsum f S *s v = setsum (\<lambda>x. f x *s v) S"
+proof(induct rule: finite_induct[OF fS])
+ case 1 then show ?case by (simp add: vector_smult_lzero)
+next
+ case (2 x F)
+ from "2.hyps" have "setsum f (insert x F) *s v = (f x + setsum f F) *s v"
+ by simp
+ also have "\<dots> = f x *s v + setsum f F *s v"
+ by (simp add: vector_sadd_rdistrib)
+ also have "\<dots> = setsum (\<lambda>x. f x *s v) (insert x F)" using "2.hyps" by simp
+ finally show ?case .
+qed
+
+(* FIXME : Problem thm setsum_vmul[of _ "f:: 'a \<Rightarrow> real ^'n"] ---
+ Get rid of *s and use real_vector instead! Also prove that ^ creates a real_vector !! *)
+
+ (* FIXME: Here too need stupid finiteness assumption on T!!! *)
+lemma setsum_group:
+ assumes fS: "finite S" and fT: "finite T" and fST: "f ` S \<subseteq> T"
+ shows "setsum (\<lambda>y. setsum g {x. x\<in> S \<and> f x = y}) T = setsum g S"
+
+apply (subst setsum_image_gen[OF fS, of g f])
+apply (rule setsum_mono_zero_right[OF fT fST])
+by (auto intro: setsum_0')
+
+lemma vsum_norm_allsubsets_bound:
+ fixes f:: "'a \<Rightarrow> real ^'n::finite"
+ assumes fP: "finite P" and fPs: "\<And>Q. Q \<subseteq> P \<Longrightarrow> norm (setsum f Q) \<le> e"
+ shows "setsum (\<lambda>x. norm (f x)) P \<le> 2 * real CARD('n) * e"
+proof-
+ let ?d = "real CARD('n)"
+ let ?nf = "\<lambda>x. norm (f x)"
+ let ?U = "UNIV :: 'n set"
+ have th0: "setsum (\<lambda>x. setsum (\<lambda>i. \<bar>f x $ i\<bar>) ?U) P = setsum (\<lambda>i. setsum (\<lambda>x. \<bar>f x $ i\<bar>) P) ?U"
+ by (rule setsum_commute)
+ have th1: "2 * ?d * e = of_nat (card ?U) * (2 * e)" by (simp add: real_of_nat_def)
+ have "setsum ?nf P \<le> setsum (\<lambda>x. setsum (\<lambda>i. \<bar>f x $ i\<bar>) ?U) P"
+ apply (rule setsum_mono)
+ by (rule norm_le_l1)
+ also have "\<dots> \<le> 2 * ?d * e"
+ unfolding th0 th1
+ proof(rule setsum_bounded)
+ fix i assume i: "i \<in> ?U"
+ let ?Pp = "{x. x\<in> P \<and> f x $ i \<ge> 0}"
+ let ?Pn = "{x. x \<in> P \<and> f x $ i < 0}"
+ have thp: "P = ?Pp \<union> ?Pn" by auto
+ have thp0: "?Pp \<inter> ?Pn ={}" by auto
+ have PpP: "?Pp \<subseteq> P" and PnP: "?Pn \<subseteq> P" by blast+
+ have Ppe:"setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pp \<le> e"
+ using component_le_norm[of "setsum (\<lambda>x. f x) ?Pp" i] fPs[OF PpP]
+ by (auto intro: abs_le_D1)
+ have Pne: "setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn \<le> e"
+ using component_le_norm[of "setsum (\<lambda>x. - f x) ?Pn" i] fPs[OF PnP]
+ by (auto simp add: setsum_negf intro: abs_le_D1)
+ have "setsum (\<lambda>x. \<bar>f x $ i\<bar>) P = setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pp + setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn"
+ apply (subst thp)
+ apply (rule setsum_Un_zero)
+ using fP thp0 by auto
+ also have "\<dots> \<le> 2*e" using Pne Ppe by arith
+ finally show "setsum (\<lambda>x. \<bar>f x $ i\<bar>) P \<le> 2*e" .
+ qed
+ finally show ?thesis .
+qed
+
+lemma dot_lsum: "finite S \<Longrightarrow> setsum f S \<bullet> (y::'a::{comm_ring}^'n) = setsum (\<lambda>x. f x \<bullet> y) S "
+ by (induct rule: finite_induct, auto simp add: dot_lzero dot_ladd dot_radd)
+
+lemma dot_rsum: "finite S \<Longrightarrow> (y::'a::{comm_ring}^'n) \<bullet> setsum f S = setsum (\<lambda>x. y \<bullet> f x) S "
+ by (induct rule: finite_induct, auto simp add: dot_rzero dot_radd)
+
+subsection{* Basis vectors in coordinate directions. *}
+
+
+definition "basis k = (\<chi> i. if i = k then 1 else 0)"
+
+lemma basis_component [simp]: "basis k $ i = (if k=i then 1 else 0)"
+ unfolding basis_def by simp
+
+lemma delta_mult_idempotent:
+ "(if k=a then 1 else (0::'a::semiring_1)) * (if k=a then 1 else 0) = (if k=a then 1 else 0)" by (cases "k=a", auto)
+
+lemma norm_basis:
+ shows "norm (basis k :: real ^'n::finite) = 1"
+ apply (simp add: basis_def real_vector_norm_def dot_def)
+ apply (vector delta_mult_idempotent)
+ using setsum_delta[of "UNIV :: 'n set" "k" "\<lambda>k. 1::real"]
+ apply auto
+ done
+
+lemma norm_basis_1: "norm(basis 1 :: real ^'n::{finite,one}) = 1"
+ by (rule norm_basis)
+
+lemma vector_choose_size: "0 <= c ==> \<exists>(x::real^'n::finite). norm x = c"
+ apply (rule exI[where x="c *s basis arbitrary"])
+ by (simp only: norm_mul norm_basis)
+
+lemma vector_choose_dist: assumes e: "0 <= e"
+ shows "\<exists>(y::real^'n::finite). dist x y = e"
+proof-
+ from vector_choose_size[OF e] obtain c:: "real ^'n" where "norm c = e"
+ by blast
+ then have "dist x (x - c) = e" by (simp add: dist_norm)
+ then show ?thesis by blast
+qed
+
+lemma basis_inj: "inj (basis :: 'n \<Rightarrow> real ^'n::finite)"
+ by (simp add: inj_on_def Cart_eq)
+
+lemma cond_value_iff: "f (if b then x else y) = (if b then f x else f y)"
+ by auto
+
+lemma basis_expansion:
+ "setsum (\<lambda>i. (x$i) *s basis i) UNIV = (x::('a::ring_1) ^'n::finite)" (is "?lhs = ?rhs" is "setsum ?f ?S = _")
+ by (auto simp add: Cart_eq cond_value_iff setsum_delta[of "?S", where ?'b = "'a", simplified] cong del: if_weak_cong)
+
+lemma basis_expansion_unique:
+ "setsum (\<lambda>i. f i *s basis i) UNIV = (x::('a::comm_ring_1) ^'n::finite) \<longleftrightarrow> (\<forall>i. f i = x$i)"
+ by (simp add: Cart_eq setsum_delta cond_value_iff cong del: if_weak_cong)
+
+lemma cond_application_beta: "(if b then f else g) x = (if b then f x else g x)"
+ by auto
+
+lemma dot_basis:
+ shows "basis i \<bullet> x = x$i" "x \<bullet> (basis i :: 'a^'n::finite) = (x$i :: 'a::semiring_1)"
+ by (auto simp add: dot_def basis_def cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
+
+lemma inner_basis:
+ fixes x :: "'a::{real_inner, real_algebra_1} ^ 'n::finite"
+ shows "inner (basis i) x = inner 1 (x $ i)"
+ and "inner x (basis i) = inner (x $ i) 1"
+ unfolding inner_vector_def basis_def
+ by (auto simp add: cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
+
+lemma basis_eq_0: "basis i = (0::'a::semiring_1^'n) \<longleftrightarrow> False"
+ by (auto simp add: Cart_eq)
+
+lemma basis_nonzero:
+ shows "basis k \<noteq> (0:: 'a::semiring_1 ^'n)"
+ by (simp add: basis_eq_0)
+
+lemma vector_eq_ldot: "(\<forall>x. x \<bullet> y = x \<bullet> z) \<longleftrightarrow> y = (z::'a::semiring_1^'n::finite)"
+ apply (auto simp add: Cart_eq dot_basis)
+ apply (erule_tac x="basis i" in allE)
+ apply (simp add: dot_basis)
+ apply (subgoal_tac "y = z")
+ apply simp
+ apply (simp add: Cart_eq)
+ done
+
+lemma vector_eq_rdot: "(\<forall>z. x \<bullet> z = y \<bullet> z) \<longleftrightarrow> x = (y::'a::semiring_1^'n::finite)"
+ apply (auto simp add: Cart_eq dot_basis)
+ apply (erule_tac x="basis i" in allE)
+ apply (simp add: dot_basis)
+ apply (subgoal_tac "x = y")
+ apply simp
+ apply (simp add: Cart_eq)
+ done
+
+subsection{* Orthogonality. *}
+
+definition "orthogonal x y \<longleftrightarrow> (x \<bullet> y = 0)"
+
+lemma orthogonal_basis:
+ shows "orthogonal (basis i :: 'a^'n::finite) x \<longleftrightarrow> x$i = (0::'a::ring_1)"
+ by (auto simp add: orthogonal_def dot_def basis_def cond_value_iff cond_application_beta setsum_delta cong del: if_weak_cong)
+
+lemma orthogonal_basis_basis:
+ shows "orthogonal (basis i :: 'a::ring_1^'n::finite) (basis j) \<longleftrightarrow> i \<noteq> j"
+ unfolding orthogonal_basis[of i] basis_component[of j] by simp
+
+ (* FIXME : Maybe some of these require less than comm_ring, but not all*)
+lemma orthogonal_clauses:
+ "orthogonal a (0::'a::comm_ring ^'n)"
+ "orthogonal a x ==> orthogonal a (c *s x)"
+ "orthogonal a x ==> orthogonal a (-x)"
+ "orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x + y)"
+ "orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x - y)"
+ "orthogonal 0 a"
+ "orthogonal x a ==> orthogonal (c *s x) a"
+ "orthogonal x a ==> orthogonal (-x) a"
+ "orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x + y) a"
+ "orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x - y) a"
+ unfolding orthogonal_def dot_rneg dot_rmult dot_radd dot_rsub
+ dot_lzero dot_rzero dot_lneg dot_lmult dot_ladd dot_lsub
+ by simp_all
+
+lemma orthogonal_commute: "orthogonal (x::'a::{ab_semigroup_mult,comm_monoid_add} ^'n)y \<longleftrightarrow> orthogonal y x"
+ by (simp add: orthogonal_def dot_sym)
+
+subsection{* Explicit vector construction from lists. *}
+
+primrec from_nat :: "nat \<Rightarrow> 'a::{monoid_add,one}"
+where "from_nat 0 = 0" | "from_nat (Suc n) = 1 + from_nat n"
+
+lemma from_nat [simp]: "from_nat = of_nat"
+by (rule ext, induct_tac x, simp_all)
+
+primrec
+ list_fun :: "nat \<Rightarrow> _ list \<Rightarrow> _ \<Rightarrow> _"
+where
+ "list_fun n [] = (\<lambda>x. 0)"
+| "list_fun n (x # xs) = fun_upd (list_fun (Suc n) xs) (from_nat n) x"
+
+definition "vector l = (\<chi> i. list_fun 1 l i)"
+(*definition "vector l = (\<chi> i. if i <= length l then l ! (i - 1) else 0)"*)
+
+lemma vector_1: "(vector[x]) $1 = x"
+ unfolding vector_def by simp
+
+lemma vector_2:
+ "(vector[x,y]) $1 = x"
+ "(vector[x,y] :: 'a^2)$2 = (y::'a::zero)"
+ unfolding vector_def by simp_all
+
+lemma vector_3:
+ "(vector [x,y,z] ::('a::zero)^3)$1 = x"
+ "(vector [x,y,z] ::('a::zero)^3)$2 = y"
+ "(vector [x,y,z] ::('a::zero)^3)$3 = z"
+ unfolding vector_def by simp_all
+
+lemma forall_vector_1: "(\<forall>v::'a::zero^1. P v) \<longleftrightarrow> (\<forall>x. P(vector[x]))"
+ apply auto
+ apply (erule_tac x="v$1" in allE)
+ apply (subgoal_tac "vector [v$1] = v")
+ apply simp
+ apply (vector vector_def)
+ apply (simp add: forall_1)
+ done
+
+lemma forall_vector_2: "(\<forall>v::'a::zero^2. P v) \<longleftrightarrow> (\<forall>x y. P(vector[x, y]))"
+ apply auto
+ apply (erule_tac x="v$1" in allE)
+ apply (erule_tac x="v$2" in allE)
+ apply (subgoal_tac "vector [v$1, v$2] = v")
+ apply simp
+ apply (vector vector_def)
+ apply (simp add: forall_2)
+ done
+
+lemma forall_vector_3: "(\<forall>v::'a::zero^3. P v) \<longleftrightarrow> (\<forall>x y z. P(vector[x, y, z]))"
+ apply auto
+ apply (erule_tac x="v$1" in allE)
+ apply (erule_tac x="v$2" in allE)
+ apply (erule_tac x="v$3" in allE)
+ apply (subgoal_tac "vector [v$1, v$2, v$3] = v")
+ apply simp
+ apply (vector vector_def)
+ apply (simp add: forall_3)
+ done
+
+subsection{* Linear functions. *}
+
+definition "linear f \<longleftrightarrow> (\<forall>x y. f(x + y) = f x + f y) \<and> (\<forall>c x. f(c *s x) = c *s f x)"
+
+lemma linear_compose_cmul: "linear f ==> linear (\<lambda>x. (c::'a::comm_semiring) *s f x)"
+ by (vector linear_def Cart_eq ring_simps)
+
+lemma linear_compose_neg: "linear (f :: 'a ^'n \<Rightarrow> 'a::comm_ring ^'m) ==> linear (\<lambda>x. -(f(x)))" by (vector linear_def Cart_eq)
+
+lemma linear_compose_add: "linear (f :: 'a ^'n \<Rightarrow> 'a::semiring_1 ^'m) \<Longrightarrow> linear g ==> linear (\<lambda>x. f(x) + g(x))"
+ by (vector linear_def Cart_eq ring_simps)
+
+lemma linear_compose_sub: "linear (f :: 'a ^'n \<Rightarrow> 'a::ring_1 ^'m) \<Longrightarrow> linear g ==> linear (\<lambda>x. f x - g x)"
+ by (vector linear_def Cart_eq ring_simps)
+
+lemma linear_compose: "linear f \<Longrightarrow> linear g ==> linear (g o f)"
+ by (simp add: linear_def)
+
+lemma linear_id: "linear id" by (simp add: linear_def id_def)
+
+lemma linear_zero: "linear (\<lambda>x. 0::'a::semiring_1 ^ 'n)" by (simp add: linear_def)
+
+lemma linear_compose_setsum:
+ assumes fS: "finite S" and lS: "\<forall>a \<in> S. linear (f a :: 'a::semiring_1 ^ 'n \<Rightarrow> 'a ^ 'm)"
+ shows "linear(\<lambda>x. setsum (\<lambda>a. f a x :: 'a::semiring_1 ^'m) S)"
+ using lS
+ apply (induct rule: finite_induct[OF fS])
+ by (auto simp add: linear_zero intro: linear_compose_add)
+
+lemma linear_vmul_component:
+ fixes f:: "'a::semiring_1^'m \<Rightarrow> 'a^'n"
+ assumes lf: "linear f"
+ shows "linear (\<lambda>x. f x $ k *s v)"
+ using lf
+ apply (auto simp add: linear_def )
+ by (vector ring_simps)+
+
+lemma linear_0: "linear f ==> f 0 = (0::'a::semiring_1 ^'n)"
+ unfolding linear_def
+ apply clarsimp
+ apply (erule allE[where x="0::'a"])
+ apply simp
+ done
+
+lemma linear_cmul: "linear f ==> f(c*s x) = c *s f x" by (simp add: linear_def)
+
+lemma linear_neg: "linear (f :: 'a::ring_1 ^'n \<Rightarrow> _) ==> f (-x) = - f x"
+ unfolding vector_sneg_minus1
+ using linear_cmul[of f] by auto
+
+lemma linear_add: "linear f ==> f(x + y) = f x + f y" by (metis linear_def)
+
+lemma linear_sub: "linear (f::'a::ring_1 ^'n \<Rightarrow> _) ==> f(x - y) = f x - f y"
+ by (simp add: diff_def linear_add linear_neg)
+
+lemma linear_setsum:
+ fixes f:: "'a::semiring_1^'n \<Rightarrow> _"
+ assumes lf: "linear f" and fS: "finite S"
+ shows "f (setsum g S) = setsum (f o g) S"
+proof (induct rule: finite_induct[OF fS])
+ case 1 thus ?case by (simp add: linear_0[OF lf])
+next
+ case (2 x F)
+ have "f (setsum g (insert x F)) = f (g x + setsum g F)" using "2.hyps"
+ by simp
+ also have "\<dots> = f (g x) + f (setsum g F)" using linear_add[OF lf] by simp
+ also have "\<dots> = setsum (f o g) (insert x F)" using "2.hyps" by simp
+ finally show ?case .
+qed
+
+lemma linear_setsum_mul:
+ fixes f:: "'a ^'n \<Rightarrow> 'a::semiring_1^'m"
+ assumes lf: "linear f" and fS: "finite S"
+ shows "f (setsum (\<lambda>i. c i *s v i) S) = setsum (\<lambda>i. c i *s f (v i)) S"
+ using linear_setsum[OF lf fS, of "\<lambda>i. c i *s v i" , unfolded o_def]
+ linear_cmul[OF lf] by simp
+
+lemma linear_injective_0:
+ assumes lf: "linear (f:: 'a::ring_1 ^ 'n \<Rightarrow> _)"
+ shows "inj f \<longleftrightarrow> (\<forall>x. f x = 0 \<longrightarrow> x = 0)"
+proof-
+ have "inj f \<longleftrightarrow> (\<forall> x y. f x = f y \<longrightarrow> x = y)" by (simp add: inj_on_def)
+ also have "\<dots> \<longleftrightarrow> (\<forall> x y. f x - f y = 0 \<longrightarrow> x - y = 0)" by simp
+ also have "\<dots> \<longleftrightarrow> (\<forall> x y. f (x - y) = 0 \<longrightarrow> x - y = 0)"
+ by (simp add: linear_sub[OF lf])
+ also have "\<dots> \<longleftrightarrow> (\<forall> x. f x = 0 \<longrightarrow> x = 0)" by auto
+ finally show ?thesis .
+qed
+
+lemma linear_bounded:
+ fixes f:: "real ^'m::finite \<Rightarrow> real ^'n::finite"
+ assumes lf: "linear f"
+ shows "\<exists>B. \<forall>x. norm (f x) \<le> B * norm x"
+proof-
+ let ?S = "UNIV:: 'm set"
+ let ?B = "setsum (\<lambda>i. norm(f(basis i))) ?S"
+ have fS: "finite ?S" by simp
+ {fix x:: "real ^ 'm"
+ let ?g = "(\<lambda>i. (x$i) *s (basis i) :: real ^ 'm)"
+ have "norm (f x) = norm (f (setsum (\<lambda>i. (x$i) *s (basis i)) ?S))"
+ by (simp only: basis_expansion)
+ also have "\<dots> = norm (setsum (\<lambda>i. (x$i) *s f (basis i))?S)"
+ using linear_setsum[OF lf fS, of ?g, unfolded o_def] linear_cmul[OF lf]
+ by auto
+ finally have th0: "norm (f x) = norm (setsum (\<lambda>i. (x$i) *s f (basis i))?S)" .
+ {fix i assume i: "i \<in> ?S"
+ from component_le_norm[of x i]
+ have "norm ((x$i) *s f (basis i :: real ^'m)) \<le> norm (f (basis i)) * norm x"
+ unfolding norm_mul
+ apply (simp only: mult_commute)
+ apply (rule mult_mono)
+ by (auto simp add: ring_simps norm_ge_zero) }
+ then have th: "\<forall>i\<in> ?S. norm ((x$i) *s f (basis i :: real ^'m)) \<le> norm (f (basis i)) * norm x" by metis
+ from real_setsum_norm_le[OF fS, of "\<lambda>i. (x$i) *s (f (basis i))", OF th]
+ have "norm (f x) \<le> ?B * norm x" unfolding th0 setsum_left_distrib by metis}
+ then show ?thesis by blast
+qed
+
+lemma linear_bounded_pos:
+ fixes f:: "real ^'n::finite \<Rightarrow> real ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "\<exists>B > 0. \<forall>x. norm (f x) \<le> B * norm x"
+proof-
+ from linear_bounded[OF lf] obtain B where
+ B: "\<forall>x. norm (f x) \<le> B * norm x" by blast
+ let ?K = "\<bar>B\<bar> + 1"
+ have Kp: "?K > 0" by arith
+ {assume C: "B < 0"
+ have "norm (1::real ^ 'n) > 0" by (simp add: zero_less_norm_iff)
+ with C have "B * norm (1:: real ^ 'n) < 0"
+ by (simp add: zero_compare_simps)
+ with B[rule_format, of 1] norm_ge_zero[of "f 1"] have False by simp
+ }
+ then have Bp: "B \<ge> 0" by ferrack
+ {fix x::"real ^ 'n"
+ have "norm (f x) \<le> ?K * norm x"
+ using B[rule_format, of x] norm_ge_zero[of x] norm_ge_zero[of "f x"] Bp
+ apply (auto simp add: ring_simps split add: abs_split)
+ apply (erule order_trans, simp)
+ done
+ }
+ then show ?thesis using Kp by blast
+qed
+
+lemma smult_conv_scaleR: "c *s x = scaleR c x"
+ unfolding vector_scalar_mult_def vector_scaleR_def by simp
+
+lemma linear_conv_bounded_linear:
+ fixes f :: "real ^ _ \<Rightarrow> real ^ _"
+ shows "linear f \<longleftrightarrow> bounded_linear f"
+proof
+ assume "linear f"
+ show "bounded_linear f"
+ proof
+ fix x y show "f (x + y) = f x + f y"
+ using `linear f` unfolding linear_def by simp
+ next
+ fix r x show "f (scaleR r x) = scaleR r (f x)"
+ using `linear f` unfolding linear_def
+ by (simp add: smult_conv_scaleR)
+ next
+ have "\<exists>B. \<forall>x. norm (f x) \<le> B * norm x"
+ using `linear f` by (rule linear_bounded)
+ thus "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
+ by (simp add: mult_commute)
+ qed
+next
+ assume "bounded_linear f"
+ then interpret f: bounded_linear f .
+ show "linear f"
+ unfolding linear_def smult_conv_scaleR
+ by (simp add: f.add f.scaleR)
+qed
+
+subsection{* Bilinear functions. *}
+
+definition "bilinear f \<longleftrightarrow> (\<forall>x. linear(\<lambda>y. f x y)) \<and> (\<forall>y. linear(\<lambda>x. f x y))"
+
+lemma bilinear_ladd: "bilinear h ==> h (x + y) z = (h x z) + (h y z)"
+ by (simp add: bilinear_def linear_def)
+lemma bilinear_radd: "bilinear h ==> h x (y + z) = (h x y) + (h x z)"
+ by (simp add: bilinear_def linear_def)
+
+lemma bilinear_lmul: "bilinear h ==> h (c *s x) y = c *s (h x y)"
+ by (simp add: bilinear_def linear_def)
+
+lemma bilinear_rmul: "bilinear h ==> h x (c *s y) = c *s (h x y)"
+ by (simp add: bilinear_def linear_def)
+
+lemma bilinear_lneg: "bilinear h ==> h (- (x:: 'a::ring_1 ^ 'n)) y = -(h x y)"
+ by (simp only: vector_sneg_minus1 bilinear_lmul)
+
+lemma bilinear_rneg: "bilinear h ==> h x (- (y:: 'a::ring_1 ^ 'n)) = - h x y"
+ by (simp only: vector_sneg_minus1 bilinear_rmul)
+
+lemma (in ab_group_add) eq_add_iff: "x = x + y \<longleftrightarrow> y = 0"
+ using add_imp_eq[of x y 0] by auto
+
+lemma bilinear_lzero:
+ fixes h :: "'a::ring^'n \<Rightarrow> _" assumes bh: "bilinear h" shows "h 0 x = 0"
+ using bilinear_ladd[OF bh, of 0 0 x]
+ by (simp add: eq_add_iff ring_simps)
+
+lemma bilinear_rzero:
+ fixes h :: "'a::ring^'n \<Rightarrow> _" assumes bh: "bilinear h" shows "h x 0 = 0"
+ using bilinear_radd[OF bh, of x 0 0 ]
+ by (simp add: eq_add_iff ring_simps)
+
+lemma bilinear_lsub: "bilinear h ==> h (x - (y:: 'a::ring_1 ^ 'n)) z = h x z - h y z"
+ by (simp add: diff_def bilinear_ladd bilinear_lneg)
+
+lemma bilinear_rsub: "bilinear h ==> h z (x - (y:: 'a::ring_1 ^ 'n)) = h z x - h z y"
+ by (simp add: diff_def bilinear_radd bilinear_rneg)
+
+lemma bilinear_setsum:
+ fixes h:: "'a ^'n \<Rightarrow> 'a::semiring_1^'m \<Rightarrow> 'a ^ 'k"
+ assumes bh: "bilinear h" and fS: "finite S" and fT: "finite T"
+ shows "h (setsum f S) (setsum g T) = setsum (\<lambda>(i,j). h (f i) (g j)) (S \<times> T) "
+proof-
+ have "h (setsum f S) (setsum g T) = setsum (\<lambda>x. h (f x) (setsum g T)) S"
+ apply (rule linear_setsum[unfolded o_def])
+ using bh fS by (auto simp add: bilinear_def)
+ also have "\<dots> = setsum (\<lambda>x. setsum (\<lambda>y. h (f x) (g y)) T) S"
+ apply (rule setsum_cong, simp)
+ apply (rule linear_setsum[unfolded o_def])
+ using bh fT by (auto simp add: bilinear_def)
+ finally show ?thesis unfolding setsum_cartesian_product .
+qed
+
+lemma bilinear_bounded:
+ fixes h:: "real ^'m::finite \<Rightarrow> real^'n::finite \<Rightarrow> real ^ 'k::finite"
+ assumes bh: "bilinear h"
+ shows "\<exists>B. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
+proof-
+ let ?M = "UNIV :: 'm set"
+ let ?N = "UNIV :: 'n set"
+ let ?B = "setsum (\<lambda>(i,j). norm (h (basis i) (basis j))) (?M \<times> ?N)"
+ have fM: "finite ?M" and fN: "finite ?N" by simp_all
+ {fix x:: "real ^ 'm" and y :: "real^'n"
+ have "norm (h x y) = norm (h (setsum (\<lambda>i. (x$i) *s basis i) ?M) (setsum (\<lambda>i. (y$i) *s basis i) ?N))" unfolding basis_expansion ..
+ also have "\<dots> = norm (setsum (\<lambda> (i,j). h ((x$i) *s basis i) ((y$j) *s basis j)) (?M \<times> ?N))" unfolding bilinear_setsum[OF bh fM fN] ..
+ finally have th: "norm (h x y) = \<dots>" .
+ have "norm (h x y) \<le> ?B * norm x * norm y"
+ apply (simp add: setsum_left_distrib th)
+ apply (rule real_setsum_norm_le)
+ using fN fM
+ apply simp
+ apply (auto simp add: bilinear_rmul[OF bh] bilinear_lmul[OF bh] norm_mul ring_simps)
+ apply (rule mult_mono)
+ apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
+ apply (rule mult_mono)
+ apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
+ done}
+ then show ?thesis by metis
+qed
+
+lemma bilinear_bounded_pos:
+ fixes h:: "real ^'m::finite \<Rightarrow> real^'n::finite \<Rightarrow> real ^ 'k::finite"
+ assumes bh: "bilinear h"
+ shows "\<exists>B > 0. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
+proof-
+ from bilinear_bounded[OF bh] obtain B where
+ B: "\<forall>x y. norm (h x y) \<le> B * norm x * norm y" by blast
+ let ?K = "\<bar>B\<bar> + 1"
+ have Kp: "?K > 0" by arith
+ have KB: "B < ?K" by arith
+ {fix x::"real ^'m" and y :: "real ^'n"
+ from KB Kp
+ have "B * norm x * norm y \<le> ?K * norm x * norm y"
+ apply -
+ apply (rule mult_right_mono, rule mult_right_mono)
+ by (auto simp add: norm_ge_zero)
+ then have "norm (h x y) \<le> ?K * norm x * norm y"
+ using B[rule_format, of x y] by simp}
+ with Kp show ?thesis by blast
+qed
+
+lemma bilinear_conv_bounded_bilinear:
+ fixes h :: "real ^ _ \<Rightarrow> real ^ _ \<Rightarrow> real ^ _"
+ shows "bilinear h \<longleftrightarrow> bounded_bilinear h"
+proof
+ assume "bilinear h"
+ show "bounded_bilinear h"
+ proof
+ fix x y z show "h (x + y) z = h x z + h y z"
+ using `bilinear h` unfolding bilinear_def linear_def by simp
+ next
+ fix x y z show "h x (y + z) = h x y + h x z"
+ using `bilinear h` unfolding bilinear_def linear_def by simp
+ next
+ fix r x y show "h (scaleR r x) y = scaleR r (h x y)"
+ using `bilinear h` unfolding bilinear_def linear_def
+ by (simp add: smult_conv_scaleR)
+ next
+ fix r x y show "h x (scaleR r y) = scaleR r (h x y)"
+ using `bilinear h` unfolding bilinear_def linear_def
+ by (simp add: smult_conv_scaleR)
+ next
+ have "\<exists>B. \<forall>x y. norm (h x y) \<le> B * norm x * norm y"
+ using `bilinear h` by (rule bilinear_bounded)
+ thus "\<exists>K. \<forall>x y. norm (h x y) \<le> norm x * norm y * K"
+ by (simp add: mult_ac)
+ qed
+next
+ assume "bounded_bilinear h"
+ then interpret h: bounded_bilinear h .
+ show "bilinear h"
+ unfolding bilinear_def linear_conv_bounded_linear
+ using h.bounded_linear_left h.bounded_linear_right
+ by simp
+qed
+
+subsection{* Adjoints. *}
+
+definition "adjoint f = (SOME f'. \<forall>x y. f x \<bullet> y = x \<bullet> f' y)"
+
+lemma choice_iff: "(\<forall>x. \<exists>y. P x y) \<longleftrightarrow> (\<exists>f. \<forall>x. P x (f x))" by metis
+
+lemma adjoint_works_lemma:
+ fixes f:: "'a::ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "\<forall>x y. f x \<bullet> y = x \<bullet> adjoint f y"
+proof-
+ let ?N = "UNIV :: 'n set"
+ let ?M = "UNIV :: 'm set"
+ have fN: "finite ?N" by simp
+ have fM: "finite ?M" by simp
+ {fix y:: "'a ^ 'm"
+ let ?w = "(\<chi> i. (f (basis i) \<bullet> y)) :: 'a ^ 'n"
+ {fix x
+ have "f x \<bullet> y = f (setsum (\<lambda>i. (x$i) *s basis i) ?N) \<bullet> y"
+ by (simp only: basis_expansion)
+ also have "\<dots> = (setsum (\<lambda>i. (x$i) *s f (basis i)) ?N) \<bullet> y"
+ unfolding linear_setsum[OF lf fN]
+ by (simp add: linear_cmul[OF lf])
+ finally have "f x \<bullet> y = x \<bullet> ?w"
+ apply (simp only: )
+ apply (simp add: dot_def setsum_left_distrib setsum_right_distrib setsum_commute[of _ ?M ?N] ring_simps)
+ done}
+ }
+ then show ?thesis unfolding adjoint_def
+ some_eq_ex[of "\<lambda>f'. \<forall>x y. f x \<bullet> y = x \<bullet> f' y"]
+ using choice_iff[of "\<lambda>a b. \<forall>x. f x \<bullet> a = x \<bullet> b "]
+ by metis
+qed
+
+lemma adjoint_works:
+ fixes f:: "'a::ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "x \<bullet> adjoint f y = f x \<bullet> y"
+ using adjoint_works_lemma[OF lf] by metis
+
+
+lemma adjoint_linear:
+ fixes f :: "'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "linear (adjoint f)"
+ by (simp add: linear_def vector_eq_ldot[symmetric] dot_radd dot_rmult adjoint_works[OF lf])
+
+lemma adjoint_clauses:
+ fixes f:: "'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "x \<bullet> adjoint f y = f x \<bullet> y"
+ and "adjoint f y \<bullet> x = y \<bullet> f x"
+ by (simp_all add: adjoint_works[OF lf] dot_sym )
+
+lemma adjoint_adjoint:
+ fixes f:: "'a::comm_ring_1 ^ 'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f"
+ shows "adjoint (adjoint f) = f"
+ apply (rule ext)
+ by (simp add: vector_eq_ldot[symmetric] adjoint_clauses[OF adjoint_linear[OF lf]] adjoint_clauses[OF lf])
+
+lemma adjoint_unique:
+ fixes f:: "'a::comm_ring_1 ^ 'n::finite \<Rightarrow> 'a ^ 'm::finite"
+ assumes lf: "linear f" and u: "\<forall>x y. f' x \<bullet> y = x \<bullet> f y"
+ shows "f' = adjoint f"
+ apply (rule ext)
+ using u
+ by (simp add: vector_eq_rdot[symmetric] adjoint_clauses[OF lf])
+
+text{* Matrix notation. NB: an MxN matrix is of type @{typ "'a^'n^'m"}, not @{typ "'a^'m^'n"} *}
+
+consts generic_mult :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr "\<star>" 75)
+
+defs (overloaded)
+matrix_matrix_mult_def: "(m:: ('a::semiring_1) ^'n^'m) \<star> (m' :: 'a ^'p^'n) \<equiv> (\<chi> i j. setsum (\<lambda>k. ((m$i)$k) * ((m'$k)$j)) (UNIV :: 'n set)) ::'a ^ 'p ^'m"
+
+abbreviation
+ matrix_matrix_mult' :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'p^'n \<Rightarrow> 'a ^ 'p ^'m" (infixl "**" 70)
+ where "m ** m' == m\<star> m'"
+
+defs (overloaded)
+ matrix_vector_mult_def: "(m::('a::semiring_1) ^'n^'m) \<star> (x::'a ^'n) \<equiv> (\<chi> i. setsum (\<lambda>j. ((m$i)$j) * (x$j)) (UNIV ::'n set)) :: 'a^'m"
+
+abbreviation
+ matrix_vector_mult' :: "('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'm" (infixl "*v" 70)
+ where
+ "m *v v == m \<star> v"
+
+defs (overloaded)
+ vector_matrix_mult_def: "(x::'a^'m) \<star> (m::('a::semiring_1) ^'n^'m) \<equiv> (\<chi> j. setsum (\<lambda>i. ((m$i)$j) * (x$i)) (UNIV :: 'm set)) :: 'a^'n"
+
+abbreviation
+ vactor_matrix_mult' :: "'a ^ 'm \<Rightarrow> ('a::semiring_1) ^'n^'m \<Rightarrow> 'a ^'n " (infixl "v*" 70)
+ where
+ "v v* m == v \<star> m"
+
+definition "(mat::'a::zero => 'a ^'n^'n) k = (\<chi> i j. if i = j then k else 0)"
+definition "(transp::'a^'n^'m \<Rightarrow> 'a^'m^'n) A = (\<chi> i j. ((A$j)$i))"
+definition "(row::'m => 'a ^'n^'m \<Rightarrow> 'a ^'n) i A = (\<chi> j. ((A$i)$j))"
+definition "(column::'n =>'a^'n^'m =>'a^'m) j A = (\<chi> i. ((A$i)$j))"
+definition "rows(A::'a^'n^'m) = { row i A | i. i \<in> (UNIV :: 'm set)}"
+definition "columns(A::'a^'n^'m) = { column i A | i. i \<in> (UNIV :: 'n set)}"
+
+lemma mat_0[simp]: "mat 0 = 0" by (vector mat_def)
+lemma matrix_add_ldistrib: "(A ** (B + C)) = (A \<star> B) + (A \<star> C)"
+ by (vector matrix_matrix_mult_def setsum_addf[symmetric] ring_simps)
+
+lemma matrix_mul_lid:
+ fixes A :: "'a::semiring_1 ^ 'm ^ 'n::finite"
+ shows "mat 1 ** A = A"
+ apply (simp add: matrix_matrix_mult_def mat_def)
+ apply vector
+ by (auto simp only: cond_value_iff cond_application_beta setsum_delta'[OF finite] mult_1_left mult_zero_left if_True UNIV_I)
+
+
+lemma matrix_mul_rid:
+ fixes A :: "'a::semiring_1 ^ 'm::finite ^ 'n"
+ shows "A ** mat 1 = A"
+ apply (simp add: matrix_matrix_mult_def mat_def)
+ apply vector
+ by (auto simp only: cond_value_iff cond_application_beta setsum_delta[OF finite] mult_1_right mult_zero_right if_True UNIV_I cong: if_cong)
+
+lemma matrix_mul_assoc: "A ** (B ** C) = (A ** B) ** C"
+ apply (vector matrix_matrix_mult_def setsum_right_distrib setsum_left_distrib mult_assoc)
+ apply (subst setsum_commute)
+ apply simp
+ done
+
+lemma matrix_vector_mul_assoc: "A *v (B *v x) = (A ** B) *v x"
+ apply (vector matrix_matrix_mult_def matrix_vector_mult_def setsum_right_distrib setsum_left_distrib mult_assoc)
+ apply (subst setsum_commute)
+ apply simp
+ done
+
+lemma matrix_vector_mul_lid: "mat 1 *v x = (x::'a::semiring_1 ^ 'n::finite)"
+ apply (vector matrix_vector_mult_def mat_def)
+ by (simp add: cond_value_iff cond_application_beta
+ setsum_delta' cong del: if_weak_cong)
+
+lemma matrix_transp_mul: "transp(A ** B) = transp B ** transp (A::'a::comm_semiring_1^'m^'n)"
+ by (simp add: matrix_matrix_mult_def transp_def Cart_eq mult_commute)
+
+lemma matrix_eq:
+ fixes A B :: "'a::semiring_1 ^ 'n::finite ^ 'm"
+ shows "A = B \<longleftrightarrow> (\<forall>x. A *v x = B *v x)" (is "?lhs \<longleftrightarrow> ?rhs")
+ apply auto
+ apply (subst Cart_eq)
+ apply clarify
+ apply (clarsimp simp add: matrix_vector_mult_def basis_def cond_value_iff cond_application_beta Cart_eq cong del: if_weak_cong)
+ apply (erule_tac x="basis ia" in allE)
+ apply (erule_tac x="i" in allE)
+ by (auto simp add: basis_def cond_value_iff cond_application_beta setsum_delta[OF finite] cong del: if_weak_cong)
+
+lemma matrix_vector_mul_component:
+ shows "((A::'a::semiring_1^'n'^'m) *v x)$k = (A$k) \<bullet> x"
+ by (simp add: matrix_vector_mult_def dot_def)
+
+lemma dot_lmul_matrix: "((x::'a::comm_semiring_1 ^'n) v* A) \<bullet> y = x \<bullet> (A *v y)"
+ apply (simp add: dot_def matrix_vector_mult_def vector_matrix_mult_def setsum_left_distrib setsum_right_distrib mult_ac)
+ apply (subst setsum_commute)
+ by simp
+
+lemma transp_mat: "transp (mat n) = mat n"
+ by (vector transp_def mat_def)
+
+lemma transp_transp: "transp(transp A) = A"
+ by (vector transp_def)
+
+lemma row_transp:
+ fixes A:: "'a::semiring_1^'n^'m"
+ shows "row i (transp A) = column i A"
+ by (simp add: row_def column_def transp_def Cart_eq)
+
+lemma column_transp:
+ fixes A:: "'a::semiring_1^'n^'m"
+ shows "column i (transp A) = row i A"
+ by (simp add: row_def column_def transp_def Cart_eq)
+
+lemma rows_transp: "rows(transp (A::'a::semiring_1^'n^'m)) = columns A"
+by (auto simp add: rows_def columns_def row_transp intro: set_ext)
+
+lemma columns_transp: "columns(transp (A::'a::semiring_1^'n^'m)) = rows A" by (metis transp_transp rows_transp)
+
+text{* Two sometimes fruitful ways of looking at matrix-vector multiplication. *}
+
+lemma matrix_mult_dot: "A *v x = (\<chi> i. A$i \<bullet> x)"
+ by (simp add: matrix_vector_mult_def dot_def)
+
+lemma matrix_mult_vsum: "(A::'a::comm_semiring_1^'n^'m) *v x = setsum (\<lambda>i. (x$i) *s column i A) (UNIV:: 'n set)"
+ by (simp add: matrix_vector_mult_def Cart_eq column_def mult_commute)
+
+lemma vector_componentwise:
+ "(x::'a::ring_1^'n::finite) = (\<chi> j. setsum (\<lambda>i. (x$i) * (basis i :: 'a^'n)$j) (UNIV :: 'n set))"
+ apply (subst basis_expansion[symmetric])
+ by (vector Cart_eq setsum_component)
+
+lemma linear_componentwise:
+ fixes f:: "'a::ring_1 ^ 'm::finite \<Rightarrow> 'a ^ 'n"
+ assumes lf: "linear f"
+ shows "(f x)$j = setsum (\<lambda>i. (x$i) * (f (basis i)$j)) (UNIV :: 'm set)" (is "?lhs = ?rhs")
+proof-
+ let ?M = "(UNIV :: 'm set)"
+ let ?N = "(UNIV :: 'n set)"
+ have fM: "finite ?M" by simp
+ have "?rhs = (setsum (\<lambda>i.(x$i) *s f (basis i) ) ?M)$j"
+ unfolding vector_smult_component[symmetric]
+ unfolding setsum_component[of "(\<lambda>i.(x$i) *s f (basis i :: 'a^'m))" ?M]
+ ..
+ then show ?thesis unfolding linear_setsum_mul[OF lf fM, symmetric] basis_expansion ..
+qed
+
+text{* Inverse matrices (not necessarily square) *}
+
+definition "invertible(A::'a::semiring_1^'n^'m) \<longleftrightarrow> (\<exists>A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"
+
+definition "matrix_inv(A:: 'a::semiring_1^'n^'m) =
+ (SOME A'::'a^'m^'n. A ** A' = mat 1 \<and> A' ** A = mat 1)"
+
+text{* Correspondence between matrices and linear operators. *}
+
+definition matrix:: "('a::{plus,times, one, zero}^'m \<Rightarrow> 'a ^ 'n) \<Rightarrow> 'a^'m^'n"
+where "matrix f = (\<chi> i j. (f(basis j))$i)"
+
+lemma matrix_vector_mul_linear: "linear(\<lambda>x. A *v (x::'a::comm_semiring_1 ^ 'n))"
+ by (simp add: linear_def matrix_vector_mult_def Cart_eq ring_simps setsum_right_distrib setsum_addf)
+
+lemma matrix_works: assumes lf: "linear f" shows "matrix f *v x = f (x::'a::comm_ring_1 ^ 'n::finite)"
+apply (simp add: matrix_def matrix_vector_mult_def Cart_eq mult_commute)
+apply clarify
+apply (rule linear_componentwise[OF lf, symmetric])
+done
+
+lemma matrix_vector_mul: "linear f ==> f = (\<lambda>x. matrix f *v (x::'a::comm_ring_1 ^ 'n::finite))" by (simp add: ext matrix_works)
+
+lemma matrix_of_matrix_vector_mul: "matrix(\<lambda>x. A *v (x :: 'a:: comm_ring_1 ^ 'n::finite)) = A"
+ by (simp add: matrix_eq matrix_vector_mul_linear matrix_works)
+
+lemma matrix_compose:
+ assumes lf: "linear (f::'a::comm_ring_1^'n::finite \<Rightarrow> 'a^'m::finite)"
+ and lg: "linear (g::'a::comm_ring_1^'m::finite \<Rightarrow> 'a^'k)"
+ shows "matrix (g o f) = matrix g ** matrix f"
+ using lf lg linear_compose[OF lf lg] matrix_works[OF linear_compose[OF lf lg]]
+ by (simp add: matrix_eq matrix_works matrix_vector_mul_assoc[symmetric] o_def)
+
+lemma matrix_vector_column:"(A::'a::comm_semiring_1^'n^'m) *v x = setsum (\<lambda>i. (x$i) *s ((transp A)$i)) (UNIV:: 'n set)"
+ by (simp add: matrix_vector_mult_def transp_def Cart_eq mult_commute)
+
+lemma adjoint_matrix: "adjoint(\<lambda>x. (A::'a::comm_ring_1^'n::finite^'m::finite) *v x) = (\<lambda>x. transp A *v x)"
+ apply (rule adjoint_unique[symmetric])
+ apply (rule matrix_vector_mul_linear)
+ apply (simp add: transp_def dot_def matrix_vector_mult_def setsum_left_distrib setsum_right_distrib)
+ apply (subst setsum_commute)
+ apply (auto simp add: mult_ac)
+ done
+
+lemma matrix_adjoint: assumes lf: "linear (f :: 'a::comm_ring_1^'n::finite \<Rightarrow> 'a ^ 'm::finite)"
+ shows "matrix(adjoint f) = transp(matrix f)"
+ apply (subst matrix_vector_mul[OF lf])
+ unfolding adjoint_matrix matrix_of_matrix_vector_mul ..
+
+subsection{* Interlude: Some properties of real sets *}
+
+lemma seq_mono_lemma: assumes "\<forall>(n::nat) \<ge> m. (d n :: real) < e n" and "\<forall>n \<ge> m. e n <= e m"
+ shows "\<forall>n \<ge> m. d n < e m"
+ using prems apply auto
+ apply (erule_tac x="n" in allE)
+ apply (erule_tac x="n" in allE)
+ apply auto
+ done
+
+
+lemma real_convex_bound_lt:
+ assumes xa: "(x::real) < a" and ya: "y < a" and u: "0 <= u" and v: "0 <= v"
+ and uv: "u + v = 1"
+ shows "u * x + v * y < a"
+proof-
+ have uv': "u = 0 \<longrightarrow> v \<noteq> 0" using u v uv by arith
+ have "a = a * (u + v)" unfolding uv by simp
+ hence th: "u * a + v * a = a" by (simp add: ring_simps)
+ from xa u have "u \<noteq> 0 \<Longrightarrow> u*x < u*a" by (simp add: mult_compare_simps)
+ from ya v have "v \<noteq> 0 \<Longrightarrow> v * y < v * a" by (simp add: mult_compare_simps)
+ from xa ya u v have "u * x + v * y < u * a + v * a"
+ apply (cases "u = 0", simp_all add: uv')
+ apply(rule mult_strict_left_mono)
+ using uv' apply simp_all
+
+ apply (rule add_less_le_mono)
+ apply(rule mult_strict_left_mono)
+ apply simp_all
+ apply (rule mult_left_mono)
+ apply simp_all
+ done
+ thus ?thesis unfolding th .
+qed
+
+lemma real_convex_bound_le:
+ assumes xa: "(x::real) \<le> a" and ya: "y \<le> a" and u: "0 <= u" and v: "0 <= v"
+ and uv: "u + v = 1"
+ shows "u * x + v * y \<le> a"
+proof-
+ from xa ya u v have "u * x + v * y \<le> u * a + v * a" by (simp add: add_mono mult_left_mono)
+ also have "\<dots> \<le> (u + v) * a" by (simp add: ring_simps)
+ finally show ?thesis unfolding uv by simp
+qed
+
+lemma infinite_enumerate: assumes fS: "infinite S"
+ shows "\<exists>r. subseq r \<and> (\<forall>n. r n \<in> S)"
+unfolding subseq_def
+using enumerate_in_set[OF fS] enumerate_mono[of _ _ S] fS by auto
+
+lemma approachable_lt_le: "(\<exists>(d::real)>0. \<forall>x. f x < d \<longrightarrow> P x) \<longleftrightarrow> (\<exists>d>0. \<forall>x. f x \<le> d \<longrightarrow> P x)"
+apply auto
+apply (rule_tac x="d/2" in exI)
+apply auto
+done
+
+
+lemma triangle_lemma:
+ assumes x: "0 <= (x::real)" and y:"0 <= y" and z: "0 <= z" and xy: "x^2 <= y^2 + z^2"
+ shows "x <= y + z"
+proof-
+ have "y^2 + z^2 \<le> y^2 + 2*y*z + z^2" using z y by (simp add: zero_compare_simps)
+ with xy have th: "x ^2 \<le> (y+z)^2" by (simp add: power2_eq_square ring_simps)
+ from y z have yz: "y + z \<ge> 0" by arith
+ from power2_le_imp_le[OF th yz] show ?thesis .
+qed
+
+
+lemma lambda_skolem: "(\<forall>i. \<exists>x. P i x) \<longleftrightarrow>
+ (\<exists>x::'a ^ 'n. \<forall>i. P i (x$i))" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ let ?S = "(UNIV :: 'n set)"
+ {assume H: "?rhs"
+ then have ?lhs by auto}
+ moreover
+ {assume H: "?lhs"
+ then obtain f where f:"\<forall>i. P i (f i)" unfolding choice_iff by metis
+ let ?x = "(\<chi> i. (f i)) :: 'a ^ 'n"
+ {fix i
+ from f have "P i (f i)" by metis
+ then have "P i (?x$i)" by auto
+ }
+ hence "\<forall>i. P i (?x$i)" by metis
+ hence ?rhs by metis }
+ ultimately show ?thesis by metis
+qed
+
+subsection{* Operator norm. *}
+
+definition "onorm f = Sup {norm (f x)| x. norm x = 1}"
+
+lemma norm_bound_generalize:
+ fixes f:: "real ^'n::finite \<Rightarrow> real^'m::finite"
+ assumes lf: "linear f"
+ shows "(\<forall>x. norm x = 1 \<longrightarrow> norm (f x) \<le> b) \<longleftrightarrow> (\<forall>x. norm (f x) \<le> b * norm x)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume H: ?rhs
+ {fix x :: "real^'n" assume x: "norm x = 1"
+ from H[rule_format, of x] x have "norm (f x) \<le> b" by simp}
+ then have ?lhs by blast }
+
+ moreover
+ {assume H: ?lhs
+ from H[rule_format, of "basis arbitrary"]
+ have bp: "b \<ge> 0" using norm_ge_zero[of "f (basis arbitrary)"]
+ by (auto simp add: norm_basis elim: order_trans [OF norm_ge_zero])
+ {fix x :: "real ^'n"
+ {assume "x = 0"
+ then have "norm (f x) \<le> b * norm x" by (simp add: linear_0[OF lf] bp)}
+ moreover
+ {assume x0: "x \<noteq> 0"
+ hence n0: "norm x \<noteq> 0" by (metis norm_eq_zero)
+ let ?c = "1/ norm x"
+ have "norm (?c*s x) = 1" using x0 by (simp add: n0 norm_mul)
+ with H have "norm (f(?c*s x)) \<le> b" by blast
+ hence "?c * norm (f x) \<le> b"
+ by (simp add: linear_cmul[OF lf] norm_mul)
+ hence "norm (f x) \<le> b * norm x"
+ using n0 norm_ge_zero[of x] by (auto simp add: field_simps)}
+ ultimately have "norm (f x) \<le> b * norm x" by blast}
+ then have ?rhs by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma onorm:
+ fixes f:: "real ^'n::finite \<Rightarrow> real ^'m::finite"
+ assumes lf: "linear f"
+ shows "norm (f x) <= onorm f * norm x"
+ and "\<forall>x. norm (f x) <= b * norm x \<Longrightarrow> onorm f <= b"
+proof-
+ {
+ let ?S = "{norm (f x) |x. norm x = 1}"
+ have Se: "?S \<noteq> {}" using norm_basis by auto
+ from linear_bounded[OF lf] have b: "\<exists> b. ?S *<= b"
+ unfolding norm_bound_generalize[OF lf, symmetric] by (auto simp add: setle_def)
+ {from Sup[OF Se b, unfolded onorm_def[symmetric]]
+ show "norm (f x) <= onorm f * norm x"
+ apply -
+ apply (rule spec[where x = x])
+ unfolding norm_bound_generalize[OF lf, symmetric]
+ by (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)}
+ {
+ show "\<forall>x. norm (f x) <= b * norm x \<Longrightarrow> onorm f <= b"
+ using Sup[OF Se b, unfolded onorm_def[symmetric]]
+ unfolding norm_bound_generalize[OF lf, symmetric]
+ by (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)}
+ }
+qed
+
+lemma onorm_pos_le: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" shows "0 <= onorm f"
+ using order_trans[OF norm_ge_zero onorm(1)[OF lf, of "basis arbitrary"], unfolded norm_basis] by simp
+
+lemma onorm_eq_0: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)"
+ shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
+ using onorm[OF lf]
+ apply (auto simp add: onorm_pos_le)
+ apply atomize
+ apply (erule allE[where x="0::real"])
+ using onorm_pos_le[OF lf]
+ apply arith
+ done
+
+lemma onorm_const: "onorm(\<lambda>x::real^'n::finite. (y::real ^ 'm::finite)) = norm y"
+proof-
+ let ?f = "\<lambda>x::real^'n. (y::real ^ 'm)"
+ have th: "{norm (?f x)| x. norm x = 1} = {norm y}"
+ by(auto intro: vector_choose_size set_ext)
+ show ?thesis
+ unfolding onorm_def th
+ apply (rule Sup_unique) by (simp_all add: setle_def)
+qed
+
+lemma onorm_pos_lt: assumes lf: "linear (f::real ^ 'n::finite \<Rightarrow> real ^'m::finite)"
+ shows "0 < onorm f \<longleftrightarrow> ~(\<forall>x. f x = 0)"
+ unfolding onorm_eq_0[OF lf, symmetric]
+ using onorm_pos_le[OF lf] by arith
+
+lemma onorm_compose:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)"
+ and lg: "linear (g::real^'k::finite \<Rightarrow> real^'n::finite)"
+ shows "onorm (f o g) <= onorm f * onorm g"
+ apply (rule onorm(2)[OF linear_compose[OF lg lf], rule_format])
+ unfolding o_def
+ apply (subst mult_assoc)
+ apply (rule order_trans)
+ apply (rule onorm(1)[OF lf])
+ apply (rule mult_mono1)
+ apply (rule onorm(1)[OF lg])
+ apply (rule onorm_pos_le[OF lf])
+ done
+
+lemma onorm_neg_lemma: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real^'m::finite)"
+ shows "onorm (\<lambda>x. - f x) \<le> onorm f"
+ using onorm[OF linear_compose_neg[OF lf]] onorm[OF lf]
+ unfolding norm_minus_cancel by metis
+
+lemma onorm_neg: assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real^'m::finite)"
+ shows "onorm (\<lambda>x. - f x) = onorm f"
+ using onorm_neg_lemma[OF lf] onorm_neg_lemma[OF linear_compose_neg[OF lf]]
+ by simp
+
+lemma onorm_triangle:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" and lg: "linear g"
+ shows "onorm (\<lambda>x. f x + g x) <= onorm f + onorm g"
+ apply(rule onorm(2)[OF linear_compose_add[OF lf lg], rule_format])
+ apply (rule order_trans)
+ apply (rule norm_triangle_ineq)
+ apply (simp add: distrib)
+ apply (rule add_mono)
+ apply (rule onorm(1)[OF lf])
+ apply (rule onorm(1)[OF lg])
+ done
+
+lemma onorm_triangle_le: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite) \<Longrightarrow> linear g \<Longrightarrow> onorm(f) + onorm(g) <= e
+ \<Longrightarrow> onorm(\<lambda>x. f x + g x) <= e"
+ apply (rule order_trans)
+ apply (rule onorm_triangle)
+ apply assumption+
+ done
+
+lemma onorm_triangle_lt: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite) \<Longrightarrow> linear g \<Longrightarrow> onorm(f) + onorm(g) < e
+ ==> onorm(\<lambda>x. f x + g x) < e"
+ apply (rule order_le_less_trans)
+ apply (rule onorm_triangle)
+ by assumption+
+
+(* "lift" from 'a to 'a^1 and "drop" from 'a^1 to 'a -- FIXME: potential use of transfer *)
+
+definition vec1:: "'a \<Rightarrow> 'a ^ 1" where "vec1 x = (\<chi> i. x)"
+
+definition dest_vec1:: "'a ^1 \<Rightarrow> 'a"
+ where "dest_vec1 x = (x$1)"
+
+lemma vec1_component[simp]: "(vec1 x)$1 = x"
+ by (simp add: vec1_def)
+
+lemma vec1_dest_vec1[simp]: "vec1(dest_vec1 x) = x" "dest_vec1(vec1 y) = y"
+ by (simp_all add: vec1_def dest_vec1_def Cart_eq forall_1)
+
+lemma forall_vec1: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P (vec1 x))" by (metis vec1_dest_vec1)
+
+lemma exists_vec1: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. P(vec1 x))" by (metis vec1_dest_vec1)
+
+lemma forall_dest_vec1: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P(dest_vec1 x))" by (metis vec1_dest_vec1)
+
+lemma exists_dest_vec1: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. P(dest_vec1 x))"by (metis vec1_dest_vec1)
+
+lemma vec1_eq[simp]: "vec1 x = vec1 y \<longleftrightarrow> x = y" by (metis vec1_dest_vec1)
+
+lemma dest_vec1_eq[simp]: "dest_vec1 x = dest_vec1 y \<longleftrightarrow> x = y" by (metis vec1_dest_vec1)
+
+lemma vec1_in_image_vec1: "vec1 x \<in> (vec1 ` S) \<longleftrightarrow> x \<in> S" by auto
+
+lemma vec1_vec: "vec1 x = vec x" by (vector vec1_def)
+
+lemma vec1_add: "vec1(x + y) = vec1 x + vec1 y" by (vector vec1_def)
+lemma vec1_sub: "vec1(x - y) = vec1 x - vec1 y" by (vector vec1_def)
+lemma vec1_cmul: "vec1(c* x) = c *s vec1 x " by (vector vec1_def)
+lemma vec1_neg: "vec1(- x) = - vec1 x " by (vector vec1_def)
+
+lemma vec1_setsum: assumes fS: "finite S"
+ shows "vec1(setsum f S) = setsum (vec1 o f) S"
+ apply (induct rule: finite_induct[OF fS])
+ apply (simp add: vec1_vec)
+ apply (auto simp add: vec1_add)
+ done
+
+lemma dest_vec1_lambda: "dest_vec1(\<chi> i. x i) = x 1"
+ by (simp add: dest_vec1_def)
+
+lemma dest_vec1_vec: "dest_vec1(vec x) = x"
+ by (simp add: vec1_vec[symmetric])
+
+lemma dest_vec1_add: "dest_vec1(x + y) = dest_vec1 x + dest_vec1 y"
+ by (metis vec1_dest_vec1 vec1_add)
+
+lemma dest_vec1_sub: "dest_vec1(x - y) = dest_vec1 x - dest_vec1 y"
+ by (metis vec1_dest_vec1 vec1_sub)
+
+lemma dest_vec1_cmul: "dest_vec1(c*sx) = c * dest_vec1 x"
+ by (metis vec1_dest_vec1 vec1_cmul)
+
+lemma dest_vec1_neg: "dest_vec1(- x) = - dest_vec1 x"
+ by (metis vec1_dest_vec1 vec1_neg)
+
+lemma dest_vec1_0[simp]: "dest_vec1 0 = 0" by (metis vec_0 dest_vec1_vec)
+
+lemma dest_vec1_sum: assumes fS: "finite S"
+ shows "dest_vec1(setsum f S) = setsum (dest_vec1 o f) S"
+ apply (induct rule: finite_induct[OF fS])
+ apply (simp add: dest_vec1_vec)
+ apply (auto simp add: dest_vec1_add)
+ done
+
+lemma norm_vec1: "norm(vec1 x) = abs(x)"
+ by (simp add: vec1_def norm_real)
+
+lemma dist_vec1: "dist(vec1 x) (vec1 y) = abs(x - y)"
+ by (simp only: dist_real vec1_component)
+lemma abs_dest_vec1: "norm x = \<bar>dest_vec1 x\<bar>"
+ by (metis vec1_dest_vec1 norm_vec1)
+
+lemma linear_vmul_dest_vec1:
+ fixes f:: "'a::semiring_1^'n \<Rightarrow> 'a^1"
+ shows "linear f \<Longrightarrow> linear (\<lambda>x. dest_vec1(f x) *s v)"
+ unfolding dest_vec1_def
+ apply (rule linear_vmul_component)
+ by auto
+
+lemma linear_from_scalars:
+ assumes lf: "linear (f::'a::comm_ring_1 ^1 \<Rightarrow> 'a^'n)"
+ shows "f = (\<lambda>x. dest_vec1 x *s column 1 (matrix f))"
+ apply (rule ext)
+ apply (subst matrix_works[OF lf, symmetric])
+ apply (auto simp add: Cart_eq matrix_vector_mult_def dest_vec1_def column_def mult_commute UNIV_1)
+ done
+
+lemma linear_to_scalars: assumes lf: "linear (f::'a::comm_ring_1 ^'n::finite \<Rightarrow> 'a^1)"
+ shows "f = (\<lambda>x. vec1(row 1 (matrix f) \<bullet> x))"
+ apply (rule ext)
+ apply (subst matrix_works[OF lf, symmetric])
+ apply (simp add: Cart_eq matrix_vector_mult_def vec1_def row_def dot_def mult_commute forall_1)
+ done
+
+lemma dest_vec1_eq_0: "dest_vec1 x = 0 \<longleftrightarrow> x = 0"
+ by (simp add: dest_vec1_eq[symmetric])
+
+lemma setsum_scalars: assumes fS: "finite S"
+ shows "setsum f S = vec1 (setsum (dest_vec1 o f) S)"
+ unfolding vec1_setsum[OF fS] by simp
+
+lemma dest_vec1_wlog_le: "(\<And>(x::'a::linorder ^ 1) y. P x y \<longleftrightarrow> P y x) \<Longrightarrow> (\<And>x y. dest_vec1 x <= dest_vec1 y ==> P x y) \<Longrightarrow> P x y"
+ apply (cases "dest_vec1 x \<le> dest_vec1 y")
+ apply simp
+ apply (subgoal_tac "dest_vec1 y \<le> dest_vec1 x")
+ apply (auto)
+ done
+
+text{* Pasting vectors. *}
+
+lemma linear_fstcart: "linear fstcart"
+ by (auto simp add: linear_def Cart_eq)
+
+lemma linear_sndcart: "linear sndcart"
+ by (auto simp add: linear_def Cart_eq)
+
+lemma fstcart_vec[simp]: "fstcart(vec x) = vec x"
+ by (simp add: Cart_eq)
+
+lemma fstcart_add[simp]:"fstcart(x + y) = fstcart (x::'a::{plus,times}^('b + 'c)) + fstcart y"
+ by (simp add: Cart_eq)
+
+lemma fstcart_cmul[simp]:"fstcart(c*s x) = c*s fstcart (x::'a::{plus,times}^('b + 'c))"
+ by (simp add: Cart_eq)
+
+lemma fstcart_neg[simp]:"fstcart(- x) = - fstcart (x::'a::ring_1^('b + 'c))"
+ by (simp add: Cart_eq)
+
+lemma fstcart_sub[simp]:"fstcart(x - y) = fstcart (x::'a::ring_1^('b + 'c)) - fstcart y"
+ by (simp add: Cart_eq)
+
+lemma fstcart_setsum:
+ fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
+ assumes fS: "finite S"
+ shows "fstcart (setsum f S) = setsum (\<lambda>i. fstcart (f i)) S"
+ by (induct rule: finite_induct[OF fS], simp_all add: vec_0[symmetric] del: vec_0)
+
+lemma sndcart_vec[simp]: "sndcart(vec x) = vec x"
+ by (simp add: Cart_eq)
+
+lemma sndcart_add[simp]:"sndcart(x + y) = sndcart (x::'a::{plus,times}^('b + 'c)) + sndcart y"
+ by (simp add: Cart_eq)
+
+lemma sndcart_cmul[simp]:"sndcart(c*s x) = c*s sndcart (x::'a::{plus,times}^('b + 'c))"
+ by (simp add: Cart_eq)
+
+lemma sndcart_neg[simp]:"sndcart(- x) = - sndcart (x::'a::ring_1^('b + 'c))"
+ by (simp add: Cart_eq)
+
+lemma sndcart_sub[simp]:"sndcart(x - y) = sndcart (x::'a::ring_1^('b + 'c)) - sndcart y"
+ by (simp add: Cart_eq)
+
+lemma sndcart_setsum:
+ fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
+ assumes fS: "finite S"
+ shows "sndcart (setsum f S) = setsum (\<lambda>i. sndcart (f i)) S"
+ by (induct rule: finite_induct[OF fS], simp_all add: vec_0[symmetric] del: vec_0)
+
+lemma pastecart_vec[simp]: "pastecart (vec x) (vec x) = vec x"
+ by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
+
+lemma pastecart_add[simp]:"pastecart (x1::'a::{plus,times}^_) y1 + pastecart x2 y2 = pastecart (x1 + x2) (y1 + y2)"
+ by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
+
+lemma pastecart_cmul[simp]: "pastecart (c *s (x1::'a::{plus,times}^_)) (c *s y1) = c *s pastecart x1 y1"
+ by (simp add: pastecart_eq fstcart_pastecart sndcart_pastecart)
+
+lemma pastecart_neg[simp]: "pastecart (- (x::'a::ring_1^_)) (- y) = - pastecart x y"
+ unfolding vector_sneg_minus1 pastecart_cmul ..
+
+lemma pastecart_sub: "pastecart (x1::'a::ring_1^_) y1 - pastecart x2 y2 = pastecart (x1 - x2) (y1 - y2)"
+ by (simp add: diff_def pastecart_neg[symmetric] del: pastecart_neg)
+
+lemma pastecart_setsum:
+ fixes f:: "'d \<Rightarrow> 'a::semiring_1^_"
+ assumes fS: "finite S"
+ shows "pastecart (setsum f S) (setsum g S) = setsum (\<lambda>i. pastecart (f i) (g i)) S"
+ by (simp add: pastecart_eq fstcart_setsum[OF fS] sndcart_setsum[OF fS] fstcart_pastecart sndcart_pastecart)
+
+lemma setsum_Plus:
+ "\<lbrakk>finite A; finite B\<rbrakk> \<Longrightarrow>
+ (\<Sum>x\<in>A <+> B. g x) = (\<Sum>x\<in>A. g (Inl x)) + (\<Sum>x\<in>B. g (Inr x))"
+ unfolding Plus_def
+ by (subst setsum_Un_disjoint, auto simp add: setsum_reindex)
+
+lemma setsum_UNIV_sum:
+ fixes g :: "'a::finite + 'b::finite \<Rightarrow> _"
+ shows "(\<Sum>x\<in>UNIV. g x) = (\<Sum>x\<in>UNIV. g (Inl x)) + (\<Sum>x\<in>UNIV. g (Inr x))"
+ apply (subst UNIV_Plus_UNIV [symmetric])
+ apply (rule setsum_Plus [OF finite finite])
+ done
+
+lemma norm_fstcart: "norm(fstcart x) <= norm (x::real ^('n::finite + 'm::finite))"
+proof-
+ have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
+ by (simp add: pastecart_fst_snd)
+ have th1: "fstcart x \<bullet> fstcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
+ by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
+ then show ?thesis
+ unfolding th0
+ unfolding real_vector_norm_def real_sqrt_le_iff id_def
+ by (simp add: dot_def)
+qed
+
+lemma dist_fstcart: "dist(fstcart (x::real^_)) (fstcart y) <= dist x y"
+ unfolding dist_norm by (metis fstcart_sub[symmetric] norm_fstcart)
+
+lemma norm_sndcart: "norm(sndcart x) <= norm (x::real ^('n::finite + 'm::finite))"
+proof-
+ have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
+ by (simp add: pastecart_fst_snd)
+ have th1: "sndcart x \<bullet> sndcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
+ by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
+ then show ?thesis
+ unfolding th0
+ unfolding real_vector_norm_def real_sqrt_le_iff id_def
+ by (simp add: dot_def)
+qed
+
+lemma dist_sndcart: "dist(sndcart (x::real^_)) (sndcart y) <= dist x y"
+ unfolding dist_norm by (metis sndcart_sub[symmetric] norm_sndcart)
+
+lemma dot_pastecart: "(pastecart (x1::'a::{times,comm_monoid_add}^'n::finite) (x2::'a::{times,comm_monoid_add}^'m::finite)) \<bullet> (pastecart y1 y2) = x1 \<bullet> y1 + x2 \<bullet> y2"
+ by (simp add: dot_def setsum_UNIV_sum pastecart_def)
+
+text {* TODO: move to NthRoot *}
+lemma sqrt_add_le_add_sqrt:
+ assumes x: "0 \<le> x" and y: "0 \<le> y"
+ shows "sqrt (x + y) \<le> sqrt x + sqrt y"
+apply (rule power2_le_imp_le)
+apply (simp add: real_sum_squared_expand add_nonneg_nonneg x y)
+apply (simp add: mult_nonneg_nonneg x y)
+apply (simp add: add_nonneg_nonneg x y)
+done
+
+lemma norm_pastecart: "norm (pastecart x y) <= norm x + norm y"
+ unfolding norm_vector_def setL2_def setsum_UNIV_sum
+ by (simp add: sqrt_add_le_add_sqrt setsum_nonneg)
+
+subsection {* A generic notion of "hull" (convex, affine, conic hull and closure). *}
+
+definition hull :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "hull" 75) where
+ "S hull s = Inter {t. t \<in> S \<and> s \<subseteq> t}"
+
+lemma hull_same: "s \<in> S \<Longrightarrow> S hull s = s"
+ unfolding hull_def by auto
+
+lemma hull_in: "(\<And>T. T \<subseteq> S ==> Inter T \<in> S) ==> (S hull s) \<in> S"
+unfolding hull_def subset_iff by auto
+
+lemma hull_eq: "(\<And>T. T \<subseteq> S ==> Inter T \<in> S) ==> (S hull s) = s \<longleftrightarrow> s \<in> S"
+using hull_same[of s S] hull_in[of S s] by metis
+
+
+lemma hull_hull: "S hull (S hull s) = S hull s"
+ unfolding hull_def by blast
+
+lemma hull_subset: "s \<subseteq> (S hull s)"
+ unfolding hull_def by blast
+
+lemma hull_mono: " s \<subseteq> t ==> (S hull s) \<subseteq> (S hull t)"
+ unfolding hull_def by blast
+
+lemma hull_antimono: "S \<subseteq> T ==> (T hull s) \<subseteq> (S hull s)"
+ unfolding hull_def by blast
+
+lemma hull_minimal: "s \<subseteq> t \<Longrightarrow> t \<in> S ==> (S hull s) \<subseteq> t"
+ unfolding hull_def by blast
+
+lemma subset_hull: "t \<in> S ==> S hull s \<subseteq> t \<longleftrightarrow> s \<subseteq> t"
+ unfolding hull_def by blast
+
+lemma hull_unique: "s \<subseteq> t \<Longrightarrow> t \<in> S \<Longrightarrow> (\<And>t'. s \<subseteq> t' \<Longrightarrow> t' \<in> S ==> t \<subseteq> t')
+ ==> (S hull s = t)"
+unfolding hull_def by auto
+
+lemma hull_induct: "(\<And>x. x\<in> S \<Longrightarrow> P x) \<Longrightarrow> Q {x. P x} \<Longrightarrow> \<forall>x\<in> Q hull S. P x"
+ using hull_minimal[of S "{x. P x}" Q]
+ by (auto simp add: subset_eq Collect_def mem_def)
+
+lemma hull_inc: "x \<in> S \<Longrightarrow> x \<in> P hull S" by (metis hull_subset subset_eq)
+
+lemma hull_union_subset: "(S hull s) \<union> (S hull t) \<subseteq> (S hull (s \<union> t))"
+unfolding Un_subset_iff by (metis hull_mono Un_upper1 Un_upper2)
+
+lemma hull_union: assumes T: "\<And>T. T \<subseteq> S ==> Inter T \<in> S"
+ shows "S hull (s \<union> t) = S hull (S hull s \<union> S hull t)"
+apply rule
+apply (rule hull_mono)
+unfolding Un_subset_iff
+apply (metis hull_subset Un_upper1 Un_upper2 subset_trans)
+apply (rule hull_minimal)
+apply (metis hull_union_subset)
+apply (metis hull_in T)
+done
+
+lemma hull_redundant_eq: "a \<in> (S hull s) \<longleftrightarrow> (S hull (insert a s) = S hull s)"
+ unfolding hull_def by blast
+
+lemma hull_redundant: "a \<in> (S hull s) ==> (S hull (insert a s) = S hull s)"
+by (metis hull_redundant_eq)
+
+text{* Archimedian properties and useful consequences. *}
+
+lemma real_arch_simple: "\<exists>n. x <= real (n::nat)"
+ using reals_Archimedean2[of x] apply auto by (rule_tac x="Suc n" in exI, auto)
+lemmas real_arch_lt = reals_Archimedean2
+
+lemmas real_arch = reals_Archimedean3
+
+lemma real_arch_inv: "0 < e \<longleftrightarrow> (\<exists>n::nat. n \<noteq> 0 \<and> 0 < inverse (real n) \<and> inverse (real n) < e)"
+ using reals_Archimedean
+ apply (auto simp add: field_simps inverse_positive_iff_positive)
+ apply (subgoal_tac "inverse (real n) > 0")
+ apply arith
+ apply simp
+ done
+
+lemma real_pow_lbound: "0 <= x ==> 1 + real n * x <= (1 + x) ^ n"
+proof(induct n)
+ case 0 thus ?case by simp
+next
+ case (Suc n)
+ hence h: "1 + real n * x \<le> (1 + x) ^ n" by simp
+ from h have p: "1 \<le> (1 + x) ^ n" using Suc.prems by simp
+ from h have "1 + real n * x + x \<le> (1 + x) ^ n + x" by simp
+ also have "\<dots> \<le> (1 + x) ^ Suc n" apply (subst diff_le_0_iff_le[symmetric])
+ apply (simp add: ring_simps)
+ using mult_left_mono[OF p Suc.prems] by simp
+ finally show ?case by (simp add: real_of_nat_Suc ring_simps)
+qed
+
+lemma real_arch_pow: assumes x: "1 < (x::real)" shows "\<exists>n. y < x^n"
+proof-
+ from x have x0: "x - 1 > 0" by arith
+ from real_arch[OF x0, rule_format, of y]
+ obtain n::nat where n:"y < real n * (x - 1)" by metis
+ from x0 have x00: "x- 1 \<ge> 0" by arith
+ from real_pow_lbound[OF x00, of n] n
+ have "y < x^n" by auto
+ then show ?thesis by metis
+qed
+
+lemma real_arch_pow2: "\<exists>n. (x::real) < 2^ n"
+ using real_arch_pow[of 2 x] by simp
+
+lemma real_arch_pow_inv: assumes y: "(y::real) > 0" and x1: "x < 1"
+ shows "\<exists>n. x^n < y"
+proof-
+ {assume x0: "x > 0"
+ from x0 x1 have ix: "1 < 1/x" by (simp add: field_simps)
+ from real_arch_pow[OF ix, of "1/y"]
+ obtain n where n: "1/y < (1/x)^n" by blast
+ then
+ have ?thesis using y x0 by (auto simp add: field_simps power_divide) }
+ moreover
+ {assume "\<not> x > 0" with y x1 have ?thesis apply auto by (rule exI[where x=1], auto)}
+ ultimately show ?thesis by metis
+qed
+
+lemma forall_pos_mono: "(\<And>d e::real. d < e \<Longrightarrow> P d ==> P e) \<Longrightarrow> (\<And>n::nat. n \<noteq> 0 ==> P(inverse(real n))) \<Longrightarrow> (\<And>e. 0 < e ==> P e)"
+ by (metis real_arch_inv)
+
+lemma forall_pos_mono_1: "(\<And>d e::real. d < e \<Longrightarrow> P d ==> P e) \<Longrightarrow> (\<And>n. P(inverse(real (Suc n)))) ==> 0 < e ==> P e"
+ apply (rule forall_pos_mono)
+ apply auto
+ apply (atomize)
+ apply (erule_tac x="n - 1" in allE)
+ apply auto
+ done
+
+lemma real_archimedian_rdiv_eq_0: assumes x0: "x \<ge> 0" and c: "c \<ge> 0" and xc: "\<forall>(m::nat)>0. real m * x \<le> c"
+ shows "x = 0"
+proof-
+ {assume "x \<noteq> 0" with x0 have xp: "x > 0" by arith
+ from real_arch[OF xp, rule_format, of c] obtain n::nat where n: "c < real n * x" by blast
+ with xc[rule_format, of n] have "n = 0" by arith
+ with n c have False by simp}
+ then show ?thesis by blast
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Geometric progression. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma sum_gp_basic: "((1::'a::{field}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
+ (is "?lhs = ?rhs")
+proof-
+ {assume x1: "x = 1" hence ?thesis by simp}
+ moreover
+ {assume x1: "x\<noteq>1"
+ hence x1': "x - 1 \<noteq> 0" "1 - x \<noteq> 0" "x - 1 = - (1 - x)" "- (1 - x) \<noteq> 0" by auto
+ from geometric_sum[OF x1, of "Suc n", unfolded x1']
+ have "(- (1 - x)) * setsum (\<lambda>i. x^i) {0 .. n} = - (1 - x^(Suc n))"
+ unfolding atLeastLessThanSuc_atLeastAtMost
+ using x1' apply (auto simp only: field_simps)
+ apply (simp add: ring_simps)
+ done
+ then have ?thesis by (simp add: ring_simps) }
+ ultimately show ?thesis by metis
+qed
+
+lemma sum_gp_multiplied: assumes mn: "m <= n"
+ shows "((1::'a::{field}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
+ (is "?lhs = ?rhs")
+proof-
+ let ?S = "{0..(n - m)}"
+ from mn have mn': "n - m \<ge> 0" by arith
+ let ?f = "op + m"
+ have i: "inj_on ?f ?S" unfolding inj_on_def by auto
+ have f: "?f ` ?S = {m..n}"
+ using mn apply (auto simp add: image_iff Bex_def) by arith
+ have th: "op ^ x o op + m = (\<lambda>i. x^m * x^i)"
+ by (rule ext, simp add: power_add power_mult)
+ from setsum_reindex[OF i, of "op ^ x", unfolded f th setsum_right_distrib[symmetric]]
+ have "?lhs = x^m * ((1 - x) * setsum (op ^ x) {0..n - m})" by simp
+ then show ?thesis unfolding sum_gp_basic using mn
+ by (simp add: ring_simps power_add[symmetric])
+qed
+
+lemma sum_gp: "setsum (op ^ (x::'a::{field})) {m .. n} =
+ (if n < m then 0 else if x = 1 then of_nat ((n + 1) - m)
+ else (x^ m - x^ (Suc n)) / (1 - x))"
+proof-
+ {assume nm: "n < m" hence ?thesis by simp}
+ moreover
+ {assume "\<not> n < m" hence nm: "m \<le> n" by arith
+ {assume x: "x = 1" hence ?thesis by simp}
+ moreover
+ {assume x: "x \<noteq> 1" hence nz: "1 - x \<noteq> 0" by simp
+ from sum_gp_multiplied[OF nm, of x] nz have ?thesis by (simp add: field_simps)}
+ ultimately have ?thesis by metis
+ }
+ ultimately show ?thesis by metis
+qed
+
+lemma sum_gp_offset: "setsum (op ^ (x::'a::{field})) {m .. m+n} =
+ (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
+ unfolding sum_gp[of x m "m + n"] power_Suc
+ by (simp add: ring_simps power_add)
+
+
+subsection{* A bit of linear algebra. *}
+
+definition "subspace S \<longleftrightarrow> 0 \<in> S \<and> (\<forall>x\<in> S. \<forall>y \<in>S. x + y \<in> S) \<and> (\<forall>c. \<forall>x \<in>S. c *s x \<in>S )"
+definition "span S = (subspace hull S)"
+definition "dependent S \<longleftrightarrow> (\<exists>a \<in> S. a \<in> span(S - {a}))"
+abbreviation "independent s == ~(dependent s)"
+
+(* Closure properties of subspaces. *)
+
+lemma subspace_UNIV[simp]: "subspace(UNIV)" by (simp add: subspace_def)
+
+lemma subspace_0: "subspace S ==> 0 \<in> S" by (metis subspace_def)
+
+lemma subspace_add: "subspace S \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S ==> x + y \<in> S"
+ by (metis subspace_def)
+
+lemma subspace_mul: "subspace S \<Longrightarrow> x \<in> S \<Longrightarrow> c *s x \<in> S"
+ by (metis subspace_def)
+
+lemma subspace_neg: "subspace S \<Longrightarrow> (x::'a::ring_1^'n) \<in> S \<Longrightarrow> - x \<in> S"
+ by (metis vector_sneg_minus1 subspace_mul)
+
+lemma subspace_sub: "subspace S \<Longrightarrow> (x::'a::ring_1^'n) \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x - y \<in> S"
+ by (metis diff_def subspace_add subspace_neg)
+
+lemma subspace_setsum:
+ assumes sA: "subspace A" and fB: "finite B"
+ and f: "\<forall>x\<in> B. f x \<in> A"
+ shows "setsum f B \<in> A"
+ using fB f sA
+ apply(induct rule: finite_induct[OF fB])
+ by (simp add: subspace_def sA, auto simp add: sA subspace_add)
+
+lemma subspace_linear_image:
+ assumes lf: "linear (f::'a::semiring_1^'n \<Rightarrow> _)" and sS: "subspace S"
+ shows "subspace(f ` S)"
+ using lf sS linear_0[OF lf]
+ unfolding linear_def subspace_def
+ apply (auto simp add: image_iff)
+ apply (rule_tac x="x + y" in bexI, auto)
+ apply (rule_tac x="c*s x" in bexI, auto)
+ done
+
+lemma subspace_linear_preimage: "linear (f::'a::semiring_1^'n \<Rightarrow> _) ==> subspace S ==> subspace {x. f x \<in> S}"
+ by (auto simp add: subspace_def linear_def linear_0[of f])
+
+lemma subspace_trivial: "subspace {0::'a::semiring_1 ^_}"
+ by (simp add: subspace_def)
+
+lemma subspace_inter: "subspace A \<Longrightarrow> subspace B ==> subspace (A \<inter> B)"
+ by (simp add: subspace_def)
+
+
+lemma span_mono: "A \<subseteq> B ==> span A \<subseteq> span B"
+ by (metis span_def hull_mono)
+
+lemma subspace_span: "subspace(span S)"
+ unfolding span_def
+ apply (rule hull_in[unfolded mem_def])
+ apply (simp only: subspace_def Inter_iff Int_iff subset_eq)
+ apply auto
+ apply (erule_tac x="X" in ballE)
+ apply (simp add: mem_def)
+ apply blast
+ apply (erule_tac x="X" in ballE)
+ apply (erule_tac x="X" in ballE)
+ apply (erule_tac x="X" in ballE)
+ apply (clarsimp simp add: mem_def)
+ apply simp
+ apply simp
+ apply simp
+ apply (erule_tac x="X" in ballE)
+ apply (erule_tac x="X" in ballE)
+ apply (simp add: mem_def)
+ apply simp
+ apply simp
+ done
+
+lemma span_clauses:
+ "a \<in> S ==> a \<in> span S"
+ "0 \<in> span S"
+ "x\<in> span S \<Longrightarrow> y \<in> span S ==> x + y \<in> span S"
+ "x \<in> span S \<Longrightarrow> c *s x \<in> span S"
+ by (metis span_def hull_subset subset_eq subspace_span subspace_def)+
+
+lemma span_induct: assumes SP: "\<And>x. x \<in> S ==> P x"
+ and P: "subspace P" and x: "x \<in> span S" shows "P x"
+proof-
+ from SP have SP': "S \<subseteq> P" by (simp add: mem_def subset_eq)
+ from P have P': "P \<in> subspace" by (simp add: mem_def)
+ from x hull_minimal[OF SP' P', unfolded span_def[symmetric]]
+ show "P x" by (metis mem_def subset_eq)
+qed
+
+lemma span_empty: "span {} = {(0::'a::semiring_0 ^ 'n)}"
+ apply (simp add: span_def)
+ apply (rule hull_unique)
+ apply (auto simp add: mem_def subspace_def)
+ unfolding mem_def[of "0::'a^'n", symmetric]
+ apply simp
+ done
+
+lemma independent_empty: "independent {}"
+ by (simp add: dependent_def)
+
+lemma independent_mono: "independent A \<Longrightarrow> B \<subseteq> A ==> independent B"
+ apply (clarsimp simp add: dependent_def span_mono)
+ apply (subgoal_tac "span (B - {a}) \<le> span (A - {a})")
+ apply force
+ apply (rule span_mono)
+ apply auto
+ done
+
+lemma span_subspace: "A \<subseteq> B \<Longrightarrow> B \<le> span A \<Longrightarrow> subspace B \<Longrightarrow> span A = B"
+ by (metis order_antisym span_def hull_minimal mem_def)
+
+lemma span_induct': assumes SP: "\<forall>x \<in> S. P x"
+ and P: "subspace P" shows "\<forall>x \<in> span S. P x"
+ using span_induct SP P by blast
+
+inductive span_induct_alt_help for S:: "'a::semiring_1^'n \<Rightarrow> bool"
+ where
+ span_induct_alt_help_0: "span_induct_alt_help S 0"
+ | span_induct_alt_help_S: "x \<in> S \<Longrightarrow> span_induct_alt_help S z \<Longrightarrow> span_induct_alt_help S (c *s x + z)"
+
+lemma span_induct_alt':
+ assumes h0: "h (0::'a::semiring_1^'n)" and hS: "\<And>c x y. x \<in> S \<Longrightarrow> h y \<Longrightarrow> h (c*s x + y)" shows "\<forall>x \<in> span S. h x"
+proof-
+ {fix x:: "'a^'n" assume x: "span_induct_alt_help S x"
+ have "h x"
+ apply (rule span_induct_alt_help.induct[OF x])
+ apply (rule h0)
+ apply (rule hS, assumption, assumption)
+ done}
+ note th0 = this
+ {fix x assume x: "x \<in> span S"
+
+ have "span_induct_alt_help S x"
+ proof(rule span_induct[where x=x and S=S])
+ show "x \<in> span S" using x .
+ next
+ fix x assume xS : "x \<in> S"
+ from span_induct_alt_help_S[OF xS span_induct_alt_help_0, of 1]
+ show "span_induct_alt_help S x" by simp
+ next
+ have "span_induct_alt_help S 0" by (rule span_induct_alt_help_0)
+ moreover
+ {fix x y assume h: "span_induct_alt_help S x" "span_induct_alt_help S y"
+ from h
+ have "span_induct_alt_help S (x + y)"
+ apply (induct rule: span_induct_alt_help.induct)
+ apply simp
+ unfolding add_assoc
+ apply (rule span_induct_alt_help_S)
+ apply assumption
+ apply simp
+ done}
+ moreover
+ {fix c x assume xt: "span_induct_alt_help S x"
+ then have "span_induct_alt_help S (c*s x)"
+ apply (induct rule: span_induct_alt_help.induct)
+ apply (simp add: span_induct_alt_help_0)
+ apply (simp add: vector_smult_assoc vector_add_ldistrib)
+ apply (rule span_induct_alt_help_S)
+ apply assumption
+ apply simp
+ done
+ }
+ ultimately show "subspace (span_induct_alt_help S)"
+ unfolding subspace_def mem_def Ball_def by blast
+ qed}
+ with th0 show ?thesis by blast
+qed
+
+lemma span_induct_alt:
+ assumes h0: "h (0::'a::semiring_1^'n)" and hS: "\<And>c x y. x \<in> S \<Longrightarrow> h y \<Longrightarrow> h (c*s x + y)" and x: "x \<in> span S"
+ shows "h x"
+using span_induct_alt'[of h S] h0 hS x by blast
+
+(* Individual closure properties. *)
+
+lemma span_superset: "x \<in> S ==> x \<in> span S" by (metis span_clauses)
+
+lemma span_0: "0 \<in> span S" by (metis subspace_span subspace_0)
+
+lemma span_add: "x \<in> span S \<Longrightarrow> y \<in> span S ==> x + y \<in> span S"
+ by (metis subspace_add subspace_span)
+
+lemma span_mul: "x \<in> span S ==> (c *s x) \<in> span S"
+ by (metis subspace_span subspace_mul)
+
+lemma span_neg: "x \<in> span S ==> - (x::'a::ring_1^'n) \<in> span S"
+ by (metis subspace_neg subspace_span)
+
+lemma span_sub: "(x::'a::ring_1^'n) \<in> span S \<Longrightarrow> y \<in> span S ==> x - y \<in> span S"
+ by (metis subspace_span subspace_sub)
+
+lemma span_setsum: "finite A \<Longrightarrow> \<forall>x \<in> A. f x \<in> span S ==> setsum f A \<in> span S"
+ apply (rule subspace_setsum)
+ by (metis subspace_span subspace_setsum)+
+
+lemma span_add_eq: "(x::'a::ring_1^'n) \<in> span S \<Longrightarrow> x + y \<in> span S \<longleftrightarrow> y \<in> span S"
+ apply (auto simp only: span_add span_sub)
+ apply (subgoal_tac "(x + y) - x \<in> span S", simp)
+ by (simp only: span_add span_sub)
+
+(* Mapping under linear image. *)
+
+lemma span_linear_image: assumes lf: "linear (f::'a::semiring_1 ^ 'n => _)"
+ shows "span (f ` S) = f ` (span S)"
+proof-
+ {fix x
+ assume x: "x \<in> span (f ` S)"
+ have "x \<in> f ` span S"
+ apply (rule span_induct[where x=x and S = "f ` S"])
+ apply (clarsimp simp add: image_iff)
+ apply (frule span_superset)
+ apply blast
+ apply (simp only: mem_def)
+ apply (rule subspace_linear_image[OF lf])
+ apply (rule subspace_span)
+ apply (rule x)
+ done}
+ moreover
+ {fix x assume x: "x \<in> span S"
+ have th0:"(\<lambda>a. f a \<in> span (f ` S)) = {x. f x \<in> span (f ` S)}" apply (rule set_ext)
+ unfolding mem_def Collect_def ..
+ have "f x \<in> span (f ` S)"
+ apply (rule span_induct[where S=S])
+ apply (rule span_superset)
+ apply simp
+ apply (subst th0)
+ apply (rule subspace_linear_preimage[OF lf subspace_span, of "f ` S"])
+ apply (rule x)
+ done}
+ ultimately show ?thesis by blast
+qed
+
+(* The key breakdown property. *)
+
+lemma span_breakdown:
+ assumes bS: "(b::'a::ring_1 ^ 'n) \<in> S" and aS: "a \<in> span S"
+ shows "\<exists>k. a - k*s b \<in> span (S - {b})" (is "?P a")
+proof-
+ {fix x assume xS: "x \<in> S"
+ {assume ab: "x = b"
+ then have "?P x"
+ apply simp
+ apply (rule exI[where x="1"], simp)
+ by (rule span_0)}
+ moreover
+ {assume ab: "x \<noteq> b"
+ then have "?P x" using xS
+ apply -
+ apply (rule exI[where x=0])
+ apply (rule span_superset)
+ by simp}
+ ultimately have "?P x" by blast}
+ moreover have "subspace ?P"
+ unfolding subspace_def
+ apply auto
+ apply (simp add: mem_def)
+ apply (rule exI[where x=0])
+ using span_0[of "S - {b}"]
+ apply (simp add: mem_def)
+ apply (clarsimp simp add: mem_def)
+ apply (rule_tac x="k + ka" in exI)
+ apply (subgoal_tac "x + y - (k + ka) *s b = (x - k*s b) + (y - ka *s b)")
+ apply (simp only: )
+ apply (rule span_add[unfolded mem_def])
+ apply assumption+
+ apply (vector ring_simps)
+ apply (clarsimp simp add: mem_def)
+ apply (rule_tac x= "c*k" in exI)
+ apply (subgoal_tac "c *s x - (c * k) *s b = c*s (x - k*s b)")
+ apply (simp only: )
+ apply (rule span_mul[unfolded mem_def])
+ apply assumption
+ by (vector ring_simps)
+ ultimately show "?P a" using aS span_induct[where S=S and P= "?P"] by metis
+qed
+
+lemma span_breakdown_eq:
+ "(x::'a::ring_1^'n) \<in> span (insert a S) \<longleftrightarrow> (\<exists>k. (x - k *s a) \<in> span S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume x: "x \<in> span (insert a S)"
+ from x span_breakdown[of "a" "insert a S" "x"]
+ have ?rhs apply clarsimp
+ apply (rule_tac x= "k" in exI)
+ apply (rule set_rev_mp[of _ "span (S - {a})" _])
+ apply assumption
+ apply (rule span_mono)
+ apply blast
+ done}
+ moreover
+ { fix k assume k: "x - k *s a \<in> span S"
+ have eq: "x = (x - k *s a) + k *s a" by vector
+ have "(x - k *s a) + k *s a \<in> span (insert a S)"
+ apply (rule span_add)
+ apply (rule set_rev_mp[of _ "span S" _])
+ apply (rule k)
+ apply (rule span_mono)
+ apply blast
+ apply (rule span_mul)
+ apply (rule span_superset)
+ apply blast
+ done
+ then have ?lhs using eq by metis}
+ ultimately show ?thesis by blast
+qed
+
+(* Hence some "reversal" results.*)
+
+lemma in_span_insert:
+ assumes a: "(a::'a::field^'n) \<in> span (insert b S)" and na: "a \<notin> span S"
+ shows "b \<in> span (insert a S)"
+proof-
+ from span_breakdown[of b "insert b S" a, OF insertI1 a]
+ obtain k where k: "a - k*s b \<in> span (S - {b})" by auto
+ {assume k0: "k = 0"
+ with k have "a \<in> span S"
+ apply (simp)
+ apply (rule set_rev_mp)
+ apply assumption
+ apply (rule span_mono)
+ apply blast
+ done
+ with na have ?thesis by blast}
+ moreover
+ {assume k0: "k \<noteq> 0"
+ have eq: "b = (1/k) *s a - ((1/k) *s a - b)" by vector
+ from k0 have eq': "(1/k) *s (a - k*s b) = (1/k) *s a - b"
+ by (vector field_simps)
+ from k have "(1/k) *s (a - k*s b) \<in> span (S - {b})"
+ by (rule span_mul)
+ hence th: "(1/k) *s a - b \<in> span (S - {b})"
+ unfolding eq' .
+
+ from k
+ have ?thesis
+ apply (subst eq)
+ apply (rule span_sub)
+ apply (rule span_mul)
+ apply (rule span_superset)
+ apply blast
+ apply (rule set_rev_mp)
+ apply (rule th)
+ apply (rule span_mono)
+ using na by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma in_span_delete:
+ assumes a: "(a::'a::field^'n) \<in> span S"
+ and na: "a \<notin> span (S-{b})"
+ shows "b \<in> span (insert a (S - {b}))"
+ apply (rule in_span_insert)
+ apply (rule set_rev_mp)
+ apply (rule a)
+ apply (rule span_mono)
+ apply blast
+ apply (rule na)
+ done
+
+(* Transitivity property. *)
+
+lemma span_trans:
+ assumes x: "(x::'a::ring_1^'n) \<in> span S" and y: "y \<in> span (insert x S)"
+ shows "y \<in> span S"
+proof-
+ from span_breakdown[of x "insert x S" y, OF insertI1 y]
+ obtain k where k: "y -k*s x \<in> span (S - {x})" by auto
+ have eq: "y = (y - k *s x) + k *s x" by vector
+ show ?thesis
+ apply (subst eq)
+ apply (rule span_add)
+ apply (rule set_rev_mp)
+ apply (rule k)
+ apply (rule span_mono)
+ apply blast
+ apply (rule span_mul)
+ by (rule x)
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* An explicit expansion is sometimes needed. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma span_explicit:
+ "span P = {y::'a::semiring_1^'n. \<exists>S u. finite S \<and> S \<subseteq> P \<and> setsum (\<lambda>v. u v *s v) S = y}"
+ (is "_ = ?E" is "_ = {y. ?h y}" is "_ = {y. \<exists>S u. ?Q S u y}")
+proof-
+ {fix x assume x: "x \<in> ?E"
+ then obtain S u where fS: "finite S" and SP: "S\<subseteq>P" and u: "setsum (\<lambda>v. u v *s v) S = x"
+ by blast
+ have "x \<in> span P"
+ unfolding u[symmetric]
+ apply (rule span_setsum[OF fS])
+ using span_mono[OF SP]
+ by (auto intro: span_superset span_mul)}
+ moreover
+ have "\<forall>x \<in> span P. x \<in> ?E"
+ unfolding mem_def Collect_def
+ proof(rule span_induct_alt')
+ show "?h 0"
+ apply (rule exI[where x="{}"]) by simp
+ next
+ fix c x y
+ assume x: "x \<in> P" and hy: "?h y"
+ from hy obtain S u where fS: "finite S" and SP: "S\<subseteq>P"
+ and u: "setsum (\<lambda>v. u v *s v) S = y" by blast
+ let ?S = "insert x S"
+ let ?u = "\<lambda>y. if y = x then (if x \<in> S then u y + c else c)
+ else u y"
+ from fS SP x have th0: "finite (insert x S)" "insert x S \<subseteq> P" by blast+
+ {assume xS: "x \<in> S"
+ have S1: "S = (S - {x}) \<union> {x}"
+ and Sss:"finite (S - {x})" "finite {x}" "(S -{x}) \<inter> {x} = {}" using xS fS by auto
+ have "setsum (\<lambda>v. ?u v *s v) ?S =(\<Sum>v\<in>S - {x}. u v *s v) + (u x + c) *s x"
+ using xS
+ by (simp add: setsum_Un_disjoint[OF Sss, unfolded S1[symmetric]]
+ setsum_clauses(2)[OF fS] cong del: if_weak_cong)
+ also have "\<dots> = (\<Sum>v\<in>S. u v *s v) + c *s x"
+ apply (simp add: setsum_Un_disjoint[OF Sss, unfolded S1[symmetric]])
+ by (vector ring_simps)
+ also have "\<dots> = c*s x + y"
+ by (simp add: add_commute u)
+ finally have "setsum (\<lambda>v. ?u v *s v) ?S = c*s x + y" .
+ then have "?Q ?S ?u (c*s x + y)" using th0 by blast}
+ moreover
+ {assume xS: "x \<notin> S"
+ have th00: "(\<Sum>v\<in>S. (if v = x then c else u v) *s v) = y"
+ unfolding u[symmetric]
+ apply (rule setsum_cong2)
+ using xS by auto
+ have "?Q ?S ?u (c*s x + y)" using fS xS th0
+ by (simp add: th00 setsum_clauses add_commute cong del: if_weak_cong)}
+ ultimately have "?Q ?S ?u (c*s x + y)"
+ by (cases "x \<in> S", simp, simp)
+ then show "?h (c*s x + y)"
+ apply -
+ apply (rule exI[where x="?S"])
+ apply (rule exI[where x="?u"]) by metis
+ qed
+ ultimately show ?thesis by blast
+qed
+
+lemma dependent_explicit:
+ "dependent P \<longleftrightarrow> (\<exists>S u. finite S \<and> S \<subseteq> P \<and> (\<exists>(v::'a::{idom,field}^'n) \<in>S. u v \<noteq> 0 \<and> setsum (\<lambda>v. u v *s v) S = 0))" (is "?lhs = ?rhs")
+proof-
+ {assume dP: "dependent P"
+ then obtain a S u where aP: "a \<in> P" and fS: "finite S"
+ and SP: "S \<subseteq> P - {a}" and ua: "setsum (\<lambda>v. u v *s v) S = a"
+ unfolding dependent_def span_explicit by blast
+ let ?S = "insert a S"
+ let ?u = "\<lambda>y. if y = a then - 1 else u y"
+ let ?v = a
+ from aP SP have aS: "a \<notin> S" by blast
+ from fS SP aP have th0: "finite ?S" "?S \<subseteq> P" "?v \<in> ?S" "?u ?v \<noteq> 0" by auto
+ have s0: "setsum (\<lambda>v. ?u v *s v) ?S = 0"
+ using fS aS
+ apply (simp add: vector_smult_lneg vector_smult_lid setsum_clauses ring_simps )
+ apply (subst (2) ua[symmetric])
+ apply (rule setsum_cong2)
+ by auto
+ with th0 have ?rhs
+ apply -
+ apply (rule exI[where x= "?S"])
+ apply (rule exI[where x= "?u"])
+ by clarsimp}
+ moreover
+ {fix S u v assume fS: "finite S"
+ and SP: "S \<subseteq> P" and vS: "v \<in> S" and uv: "u v \<noteq> 0"
+ and u: "setsum (\<lambda>v. u v *s v) S = 0"
+ let ?a = v
+ let ?S = "S - {v}"
+ let ?u = "\<lambda>i. (- u i) / u v"
+ have th0: "?a \<in> P" "finite ?S" "?S \<subseteq> P" using fS SP vS by auto
+ have "setsum (\<lambda>v. ?u v *s v) ?S = setsum (\<lambda>v. (- (inverse (u ?a))) *s (u v *s v)) S - ?u v *s v"
+ using fS vS uv
+ by (simp add: setsum_diff1 vector_smult_lneg divide_inverse
+ vector_smult_assoc field_simps)
+ also have "\<dots> = ?a"
+ unfolding setsum_cmul u
+ using uv by (simp add: vector_smult_lneg)
+ finally have "setsum (\<lambda>v. ?u v *s v) ?S = ?a" .
+ with th0 have ?lhs
+ unfolding dependent_def span_explicit
+ apply -
+ apply (rule bexI[where x= "?a"])
+ apply simp_all
+ apply (rule exI[where x= "?S"])
+ by auto}
+ ultimately show ?thesis by blast
+qed
+
+
+lemma span_finite:
+ assumes fS: "finite S"
+ shows "span S = {(y::'a::semiring_1^'n). \<exists>u. setsum (\<lambda>v. u v *s v) S = y}"
+ (is "_ = ?rhs")
+proof-
+ {fix y assume y: "y \<in> span S"
+ from y obtain S' u where fS': "finite S'" and SS': "S' \<subseteq> S" and
+ u: "setsum (\<lambda>v. u v *s v) S' = y" unfolding span_explicit by blast
+ let ?u = "\<lambda>x. if x \<in> S' then u x else 0"
+ from setsum_restrict_set[OF fS, of "\<lambda>v. u v *s v" S', symmetric] SS'
+ have "setsum (\<lambda>v. ?u v *s v) S = setsum (\<lambda>v. u v *s v) S'"
+ unfolding cond_value_iff cond_application_beta
+ by (simp add: cond_value_iff inf_absorb2 cong del: if_weak_cong)
+ hence "setsum (\<lambda>v. ?u v *s v) S = y" by (metis u)
+ hence "y \<in> ?rhs" by auto}
+ moreover
+ {fix y u assume u: "setsum (\<lambda>v. u v *s v) S = y"
+ then have "y \<in> span S" using fS unfolding span_explicit by auto}
+ ultimately show ?thesis by blast
+qed
+
+
+(* Standard bases are a spanning set, and obviously finite. *)
+
+lemma span_stdbasis:"span {basis i :: 'a::ring_1^'n::finite | i. i \<in> (UNIV :: 'n set)} = UNIV"
+apply (rule set_ext)
+apply auto
+apply (subst basis_expansion[symmetric])
+apply (rule span_setsum)
+apply simp
+apply auto
+apply (rule span_mul)
+apply (rule span_superset)
+apply (auto simp add: Collect_def mem_def)
+done
+
+lemma has_size_stdbasis: "{basis i ::real ^'n::finite | i. i \<in> (UNIV :: 'n set)} hassize CARD('n)" (is "?S hassize ?n")
+proof-
+ have eq: "?S = basis ` UNIV" by blast
+ show ?thesis unfolding eq
+ apply (rule hassize_image_inj[OF basis_inj])
+ by (simp add: hassize_def)
+qed
+
+lemma finite_stdbasis: "finite {basis i ::real^'n::finite |i. i\<in> (UNIV:: 'n set)}"
+ using has_size_stdbasis[unfolded hassize_def]
+ ..
+
+lemma card_stdbasis: "card {basis i ::real^'n::finite |i. i\<in> (UNIV :: 'n set)} = CARD('n)"
+ using has_size_stdbasis[unfolded hassize_def]
+ ..
+
+lemma independent_stdbasis_lemma:
+ assumes x: "(x::'a::semiring_1 ^ 'n) \<in> span (basis ` S)"
+ and iS: "i \<notin> S"
+ shows "(x$i) = 0"
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?B = "basis ` S"
+ let ?P = "\<lambda>(x::'a^'n). \<forall>i\<in> ?U. i \<notin> S \<longrightarrow> x$i =0"
+ {fix x::"'a^'n" assume xS: "x\<in> ?B"
+ from xS have "?P x" by auto}
+ moreover
+ have "subspace ?P"
+ by (auto simp add: subspace_def Collect_def mem_def)
+ ultimately show ?thesis
+ using x span_induct[of ?B ?P x] iS by blast
+qed
+
+lemma independent_stdbasis: "independent {basis i ::real^'n::finite |i. i\<in> (UNIV :: 'n set)}"
+proof-
+ let ?I = "UNIV :: 'n set"
+ let ?b = "basis :: _ \<Rightarrow> real ^'n"
+ let ?B = "?b ` ?I"
+ have eq: "{?b i|i. i \<in> ?I} = ?B"
+ by auto
+ {assume d: "dependent ?B"
+ then obtain k where k: "k \<in> ?I" "?b k \<in> span (?B - {?b k})"
+ unfolding dependent_def by auto
+ have eq1: "?B - {?b k} = ?B - ?b ` {k}" by simp
+ have eq2: "?B - {?b k} = ?b ` (?I - {k})"
+ unfolding eq1
+ apply (rule inj_on_image_set_diff[symmetric])
+ apply (rule basis_inj) using k(1) by auto
+ from k(2) have th0: "?b k \<in> span (?b ` (?I - {k}))" unfolding eq2 .
+ from independent_stdbasis_lemma[OF th0, of k, simplified]
+ have False by simp}
+ then show ?thesis unfolding eq dependent_def ..
+qed
+
+(* This is useful for building a basis step-by-step. *)
+
+lemma independent_insert:
+ "independent(insert (a::'a::field ^'n) S) \<longleftrightarrow>
+ (if a \<in> S then independent S
+ else independent S \<and> a \<notin> span S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume aS: "a \<in> S"
+ hence ?thesis using insert_absorb[OF aS] by simp}
+ moreover
+ {assume aS: "a \<notin> S"
+ {assume i: ?lhs
+ then have ?rhs using aS
+ apply simp
+ apply (rule conjI)
+ apply (rule independent_mono)
+ apply assumption
+ apply blast
+ by (simp add: dependent_def)}
+ moreover
+ {assume i: ?rhs
+ have ?lhs using i aS
+ apply simp
+ apply (auto simp add: dependent_def)
+ apply (case_tac "aa = a", auto)
+ apply (subgoal_tac "insert a S - {aa} = insert a (S - {aa})")
+ apply simp
+ apply (subgoal_tac "a \<in> span (insert aa (S - {aa}))")
+ apply (subgoal_tac "insert aa (S - {aa}) = S")
+ apply simp
+ apply blast
+ apply (rule in_span_insert)
+ apply assumption
+ apply blast
+ apply blast
+ done}
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+(* The degenerate case of the Exchange Lemma. *)
+
+lemma mem_delete: "x \<in> (A - {a}) \<longleftrightarrow> x \<noteq> a \<and> x \<in> A"
+ by blast
+
+lemma span_span: "span (span A) = span A"
+ unfolding span_def hull_hull ..
+
+lemma span_inc: "S \<subseteq> span S"
+ by (metis subset_eq span_superset)
+
+lemma spanning_subset_independent:
+ assumes BA: "B \<subseteq> A" and iA: "independent (A::('a::field ^'n) set)"
+ and AsB: "A \<subseteq> span B"
+ shows "A = B"
+proof
+ from BA show "B \<subseteq> A" .
+next
+ from span_mono[OF BA] span_mono[OF AsB]
+ have sAB: "span A = span B" unfolding span_span by blast
+
+ {fix x assume x: "x \<in> A"
+ from iA have th0: "x \<notin> span (A - {x})"
+ unfolding dependent_def using x by blast
+ from x have xsA: "x \<in> span A" by (blast intro: span_superset)
+ have "A - {x} \<subseteq> A" by blast
+ hence th1:"span (A - {x}) \<subseteq> span A" by (metis span_mono)
+ {assume xB: "x \<notin> B"
+ from xB BA have "B \<subseteq> A -{x}" by blast
+ hence "span B \<subseteq> span (A - {x})" by (metis span_mono)
+ with th1 th0 sAB have "x \<notin> span A" by blast
+ with x have False by (metis span_superset)}
+ then have "x \<in> B" by blast}
+ then show "A \<subseteq> B" by blast
+qed
+
+(* The general case of the Exchange Lemma, the key to what follows. *)
+
+lemma exchange_lemma:
+ assumes f:"finite (t:: ('a::field^'n) set)" and i: "independent s"
+ and sp:"s \<subseteq> span t"
+ shows "\<exists>t'. (t' hassize card t) \<and> s \<subseteq> t' \<and> t' \<subseteq> s \<union> t \<and> s \<subseteq> span t'"
+using f i sp
+proof(induct c\<equiv>"card(t - s)" arbitrary: s t rule: nat_less_induct)
+ fix n:: nat and s t :: "('a ^'n) set"
+ assume H: " \<forall>m<n. \<forall>(x:: ('a ^'n) set) xa.
+ finite xa \<longrightarrow>
+ independent x \<longrightarrow>
+ x \<subseteq> span xa \<longrightarrow>
+ m = card (xa - x) \<longrightarrow>
+ (\<exists>t'. (t' hassize card xa) \<and>
+ x \<subseteq> t' \<and> t' \<subseteq> x \<union> xa \<and> x \<subseteq> span t')"
+ and ft: "finite t" and s: "independent s" and sp: "s \<subseteq> span t"
+ and n: "n = card (t - s)"
+ let ?P = "\<lambda>t'. (t' hassize card t) \<and> s \<subseteq> t' \<and> t' \<subseteq> s \<union> t \<and> s \<subseteq> span t'"
+ let ?ths = "\<exists>t'. ?P t'"
+ {assume st: "s \<subseteq> t"
+ from st ft span_mono[OF st] have ?ths apply - apply (rule exI[where x=t])
+ by (auto simp add: hassize_def intro: span_superset)}
+ moreover
+ {assume st: "t \<subseteq> s"
+
+ from spanning_subset_independent[OF st s sp]
+ st ft span_mono[OF st] have ?ths apply - apply (rule exI[where x=t])
+ by (auto simp add: hassize_def intro: span_superset)}
+ moreover
+ {assume st: "\<not> s \<subseteq> t" "\<not> t \<subseteq> s"
+ from st(2) obtain b where b: "b \<in> t" "b \<notin> s" by blast
+ from b have "t - {b} - s \<subset> t - s" by blast
+ then have cardlt: "card (t - {b} - s) < n" using n ft
+ by (auto intro: psubset_card_mono)
+ from b ft have ct0: "card t \<noteq> 0" by auto
+ {assume stb: "s \<subseteq> span(t -{b})"
+ from ft have ftb: "finite (t -{b})" by auto
+ from H[rule_format, OF cardlt ftb s stb]
+ obtain u where u: "u hassize card (t-{b})" "s \<subseteq> u" "u \<subseteq> s \<union> (t - {b})" "s \<subseteq> span u" by blast
+ let ?w = "insert b u"
+ have th0: "s \<subseteq> insert b u" using u by blast
+ from u(3) b have "u \<subseteq> s \<union> t" by blast
+ then have th1: "insert b u \<subseteq> s \<union> t" using u b by blast
+ have bu: "b \<notin> u" using b u by blast
+ from u(1) have fu: "finite u" by (simp add: hassize_def)
+ from u(1) ft b have "u hassize (card t - 1)" by auto
+ then
+ have th2: "insert b u hassize card t"
+ using card_insert_disjoint[OF fu bu] ct0 by (auto simp add: hassize_def)
+ from u(4) have "s \<subseteq> span u" .
+ also have "\<dots> \<subseteq> span (insert b u)" apply (rule span_mono) by blast
+ finally have th3: "s \<subseteq> span (insert b u)" . from th0 th1 th2 th3 have th: "?P ?w" by blast
+ from th have ?ths by blast}
+ moreover
+ {assume stb: "\<not> s \<subseteq> span(t -{b})"
+ from stb obtain a where a: "a \<in> s" "a \<notin> span (t - {b})" by blast
+ have ab: "a \<noteq> b" using a b by blast
+ have at: "a \<notin> t" using a ab span_superset[of a "t- {b}"] by auto
+ have mlt: "card ((insert a (t - {b})) - s) < n"
+ using cardlt ft n a b by auto
+ have ft': "finite (insert a (t - {b}))" using ft by auto
+ {fix x assume xs: "x \<in> s"
+ have t: "t \<subseteq> (insert b (insert a (t -{b})))" using b by auto
+ from b(1) have "b \<in> span t" by (simp add: span_superset)
+ have bs: "b \<in> span (insert a (t - {b}))"
+ by (metis in_span_delete a sp mem_def subset_eq)
+ from xs sp have "x \<in> span t" by blast
+ with span_mono[OF t]
+ have x: "x \<in> span (insert b (insert a (t - {b})))" ..
+ from span_trans[OF bs x] have "x \<in> span (insert a (t - {b}))" .}
+ then have sp': "s \<subseteq> span (insert a (t - {b}))" by blast
+
+ from H[rule_format, OF mlt ft' s sp' refl] obtain u where
+ u: "u hassize card (insert a (t -{b}))" "s \<subseteq> u" "u \<subseteq> s \<union> insert a (t -{b})"
+ "s \<subseteq> span u" by blast
+ from u a b ft at ct0 have "?P u" by (auto simp add: hassize_def)
+ then have ?ths by blast }
+ ultimately have ?ths by blast
+ }
+ ultimately
+ show ?ths by blast
+qed
+
+(* This implies corresponding size bounds. *)
+
+lemma independent_span_bound:
+ assumes f: "finite t" and i: "independent (s::('a::field^'n) set)" and sp:"s \<subseteq> span t"
+ shows "finite s \<and> card s \<le> card t"
+ by (metis exchange_lemma[OF f i sp] hassize_def finite_subset card_mono)
+
+
+lemma finite_Atleast_Atmost_nat[simp]: "finite {f x |x. x\<in> (UNIV::'a::finite set)}"
+proof-
+ have eq: "{f x |x. x\<in> UNIV} = f ` UNIV" by auto
+ show ?thesis unfolding eq
+ apply (rule finite_imageI)
+ apply (rule finite)
+ done
+qed
+
+
+lemma independent_bound:
+ fixes S:: "(real^'n::finite) set"
+ shows "independent S \<Longrightarrow> finite S \<and> card S <= CARD('n)"
+ apply (subst card_stdbasis[symmetric])
+ apply (rule independent_span_bound)
+ apply (rule finite_Atleast_Atmost_nat)
+ apply assumption
+ unfolding span_stdbasis
+ apply (rule subset_UNIV)
+ done
+
+lemma dependent_biggerset: "(finite (S::(real ^'n::finite) set) ==> card S > CARD('n)) ==> dependent S"
+ by (metis independent_bound not_less)
+
+(* Hence we can create a maximal independent subset. *)
+
+lemma maximal_independent_subset_extend:
+ assumes sv: "(S::(real^'n::finite) set) \<subseteq> V" and iS: "independent S"
+ shows "\<exists>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
+ using sv iS
+proof(induct d\<equiv> "CARD('n) - card S" arbitrary: S rule: nat_less_induct)
+ fix n and S:: "(real^'n) set"
+ assume H: "\<forall>m<n. \<forall>S \<subseteq> V. independent S \<longrightarrow> m = CARD('n) - card S \<longrightarrow>
+ (\<exists>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B)"
+ and sv: "S \<subseteq> V" and i: "independent S" and n: "n = CARD('n) - card S"
+ let ?P = "\<lambda>B. S \<subseteq> B \<and> B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
+ let ?ths = "\<exists>x. ?P x"
+ let ?d = "CARD('n)"
+ {assume "V \<subseteq> span S"
+ then have ?ths using sv i by blast }
+ moreover
+ {assume VS: "\<not> V \<subseteq> span S"
+ from VS obtain a where a: "a \<in> V" "a \<notin> span S" by blast
+ from a have aS: "a \<notin> S" by (auto simp add: span_superset)
+ have th0: "insert a S \<subseteq> V" using a sv by blast
+ from independent_insert[of a S] i a
+ have th1: "independent (insert a S)" by auto
+ have mlt: "?d - card (insert a S) < n"
+ using aS a n independent_bound[OF th1]
+ by auto
+
+ from H[rule_format, OF mlt th0 th1 refl]
+ obtain B where B: "insert a S \<subseteq> B" "B \<subseteq> V" "independent B" " V \<subseteq> span B"
+ by blast
+ from B have "?P B" by auto
+ then have ?ths by blast}
+ ultimately show ?ths by blast
+qed
+
+lemma maximal_independent_subset:
+ "\<exists>(B:: (real ^'n::finite) set). B\<subseteq> V \<and> independent B \<and> V \<subseteq> span B"
+ by (metis maximal_independent_subset_extend[of "{}:: (real ^'n) set"] empty_subsetI independent_empty)
+
+(* Notion of dimension. *)
+
+definition "dim V = (SOME n. \<exists>B. B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize n))"
+
+lemma basis_exists: "\<exists>B. (B :: (real ^'n::finite) set) \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize dim V)"
+unfolding dim_def some_eq_ex[of "\<lambda>n. \<exists>B. B \<subseteq> V \<and> independent B \<and> V \<subseteq> span B \<and> (B hassize n)"]
+unfolding hassize_def
+using maximal_independent_subset[of V] independent_bound
+by auto
+
+(* Consequences of independence or spanning for cardinality. *)
+
+lemma independent_card_le_dim: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> independent B \<Longrightarrow> finite B \<and> card B \<le> dim V"
+by (metis basis_exists[of V] independent_span_bound[where ?'a=real] hassize_def subset_trans)
+
+lemma span_card_ge_dim: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> finite B \<Longrightarrow> dim V \<le> card B"
+ by (metis basis_exists[of V] independent_span_bound hassize_def subset_trans)
+
+lemma basis_card_eq_dim:
+ "B \<subseteq> (V:: (real ^'n::finite) set) \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> independent B \<Longrightarrow> finite B \<and> card B = dim V"
+ by (metis order_eq_iff independent_card_le_dim span_card_ge_dim independent_mono)
+
+lemma dim_unique: "(B::(real ^'n::finite) set) \<subseteq> V \<Longrightarrow> V \<subseteq> span B \<Longrightarrow> independent B \<Longrightarrow> B hassize n \<Longrightarrow> dim V = n"
+ by (metis basis_card_eq_dim hassize_def)
+
+(* More lemmas about dimension. *)
+
+lemma dim_univ: "dim (UNIV :: (real^'n::finite) set) = CARD('n)"
+ apply (rule dim_unique[of "{basis i |i. i\<in> (UNIV :: 'n set)}"])
+ by (auto simp only: span_stdbasis has_size_stdbasis independent_stdbasis)
+
+lemma dim_subset:
+ "(S:: (real ^'n::finite) set) \<subseteq> T \<Longrightarrow> dim S \<le> dim T"
+ using basis_exists[of T] basis_exists[of S]
+ by (metis independent_span_bound[where ?'a = real and ?'n = 'n] subset_eq hassize_def)
+
+lemma dim_subset_univ: "dim (S:: (real^'n::finite) set) \<le> CARD('n)"
+ by (metis dim_subset subset_UNIV dim_univ)
+
+(* Converses to those. *)
+
+lemma card_ge_dim_independent:
+ assumes BV:"(B::(real ^'n::finite) set) \<subseteq> V" and iB:"independent B" and dVB:"dim V \<le> card B"
+ shows "V \<subseteq> span B"
+proof-
+ {fix a assume aV: "a \<in> V"
+ {assume aB: "a \<notin> span B"
+ then have iaB: "independent (insert a B)" using iB aV BV by (simp add: independent_insert)
+ from aV BV have th0: "insert a B \<subseteq> V" by blast
+ from aB have "a \<notin>B" by (auto simp add: span_superset)
+ with independent_card_le_dim[OF th0 iaB] dVB have False by auto}
+ then have "a \<in> span B" by blast}
+ then show ?thesis by blast
+qed
+
+lemma card_le_dim_spanning:
+ assumes BV: "(B:: (real ^'n::finite) set) \<subseteq> V" and VB: "V \<subseteq> span B"
+ and fB: "finite B" and dVB: "dim V \<ge> card B"
+ shows "independent B"
+proof-
+ {fix a assume a: "a \<in> B" "a \<in> span (B -{a})"
+ from a fB have c0: "card B \<noteq> 0" by auto
+ from a fB have cb: "card (B -{a}) = card B - 1" by auto
+ from BV a have th0: "B -{a} \<subseteq> V" by blast
+ {fix x assume x: "x \<in> V"
+ from a have eq: "insert a (B -{a}) = B" by blast
+ from x VB have x': "x \<in> span B" by blast
+ from span_trans[OF a(2), unfolded eq, OF x']
+ have "x \<in> span (B -{a})" . }
+ then have th1: "V \<subseteq> span (B -{a})" by blast
+ have th2: "finite (B -{a})" using fB by auto
+ from span_card_ge_dim[OF th0 th1 th2]
+ have c: "dim V \<le> card (B -{a})" .
+ from c c0 dVB cb have False by simp}
+ then show ?thesis unfolding dependent_def by blast
+qed
+
+lemma card_eq_dim: "(B:: (real ^'n::finite) set) \<subseteq> V \<Longrightarrow> B hassize dim V \<Longrightarrow> independent B \<longleftrightarrow> V \<subseteq> span B"
+ by (metis hassize_def order_eq_iff card_le_dim_spanning
+ card_ge_dim_independent)
+
+(* ------------------------------------------------------------------------- *)
+(* More general size bound lemmas. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma independent_bound_general:
+ "independent (S:: (real^'n::finite) set) \<Longrightarrow> finite S \<and> card S \<le> dim S"
+ by (metis independent_card_le_dim independent_bound subset_refl)
+
+lemma dependent_biggerset_general: "(finite (S:: (real^'n::finite) set) \<Longrightarrow> card S > dim S) \<Longrightarrow> dependent S"
+ using independent_bound_general[of S] by (metis linorder_not_le)
+
+lemma dim_span: "dim (span (S:: (real ^'n::finite) set)) = dim S"
+proof-
+ have th0: "dim S \<le> dim (span S)"
+ by (auto simp add: subset_eq intro: dim_subset span_superset)
+ from basis_exists[of S]
+ obtain B where B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
+ from B have fB: "finite B" "card B = dim S" unfolding hassize_def by blast+
+ have bSS: "B \<subseteq> span S" using B(1) by (metis subset_eq span_inc)
+ have sssB: "span S \<subseteq> span B" using span_mono[OF B(3)] by (simp add: span_span)
+ from span_card_ge_dim[OF bSS sssB fB(1)] th0 show ?thesis
+ using fB(2) by arith
+qed
+
+lemma subset_le_dim: "(S:: (real ^'n::finite) set) \<subseteq> span T \<Longrightarrow> dim S \<le> dim T"
+ by (metis dim_span dim_subset)
+
+lemma span_eq_dim: "span (S:: (real ^'n::finite) set) = span T ==> dim S = dim T"
+ by (metis dim_span)
+
+lemma spans_image:
+ assumes lf: "linear (f::'a::semiring_1^'n \<Rightarrow> _)" and VB: "V \<subseteq> span B"
+ shows "f ` V \<subseteq> span (f ` B)"
+ unfolding span_linear_image[OF lf]
+ by (metis VB image_mono)
+
+lemma dim_image_le:
+ fixes f :: "real^'n::finite \<Rightarrow> real^'m::finite"
+ assumes lf: "linear f" shows "dim (f ` S) \<le> dim (S:: (real ^'n::finite) set)"
+proof-
+ from basis_exists[of S] obtain B where
+ B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
+ from B have fB: "finite B" "card B = dim S" unfolding hassize_def by blast+
+ have "dim (f ` S) \<le> card (f ` B)"
+ apply (rule span_card_ge_dim)
+ using lf B fB by (auto simp add: span_linear_image spans_image subset_image_iff)
+ also have "\<dots> \<le> dim S" using card_image_le[OF fB(1)] fB by simp
+ finally show ?thesis .
+qed
+
+(* Relation between bases and injectivity/surjectivity of map. *)
+
+lemma spanning_surjective_image:
+ assumes us: "UNIV \<subseteq> span (S:: ('a::semiring_1 ^'n) set)"
+ and lf: "linear f" and sf: "surj f"
+ shows "UNIV \<subseteq> span (f ` S)"
+proof-
+ have "UNIV \<subseteq> f ` UNIV" using sf by (auto simp add: surj_def)
+ also have " \<dots> \<subseteq> span (f ` S)" using spans_image[OF lf us] .
+finally show ?thesis .
+qed
+
+lemma independent_injective_image:
+ assumes iS: "independent (S::('a::semiring_1^'n) set)" and lf: "linear f" and fi: "inj f"
+ shows "independent (f ` S)"
+proof-
+ {fix a assume a: "a \<in> S" "f a \<in> span (f ` S - {f a})"
+ have eq: "f ` S - {f a} = f ` (S - {a})" using fi
+ by (auto simp add: inj_on_def)
+ from a have "f a \<in> f ` span (S -{a})"
+ unfolding eq span_linear_image[OF lf, of "S - {a}"] by blast
+ hence "a \<in> span (S -{a})" using fi by (auto simp add: inj_on_def)
+ with a(1) iS have False by (simp add: dependent_def) }
+ then show ?thesis unfolding dependent_def by blast
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Picking an orthogonal replacement for a spanning set. *)
+(* ------------------------------------------------------------------------- *)
+ (* FIXME : Move to some general theory ?*)
+definition "pairwise R S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y\<in> S. x\<noteq>y \<longrightarrow> R x y)"
+
+lemma vector_sub_project_orthogonal: "(b::'a::ordered_field^'n::finite) \<bullet> (x - ((b \<bullet> x) / (b\<bullet>b)) *s b) = 0"
+ apply (cases "b = 0", simp)
+ apply (simp add: dot_rsub dot_rmult)
+ unfolding times_divide_eq_right[symmetric]
+ by (simp add: field_simps dot_eq_0)
+
+lemma basis_orthogonal:
+ fixes B :: "(real ^'n::finite) set"
+ assumes fB: "finite B"
+ shows "\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C"
+ (is " \<exists>C. ?P B C")
+proof(induct rule: finite_induct[OF fB])
+ case 1 thus ?case apply (rule exI[where x="{}"]) by (auto simp add: pairwise_def)
+next
+ case (2 a B)
+ note fB = `finite B` and aB = `a \<notin> B`
+ from `\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C`
+ obtain C where C: "finite C" "card C \<le> card B"
+ "span C = span B" "pairwise orthogonal C" by blast
+ let ?a = "a - setsum (\<lambda>x. (x\<bullet>a / (x\<bullet>x)) *s x) C"
+ let ?C = "insert ?a C"
+ from C(1) have fC: "finite ?C" by simp
+ from fB aB C(1,2) have cC: "card ?C \<le> card (insert a B)" by (simp add: card_insert_if)
+ {fix x k
+ have th0: "\<And>(a::'b::comm_ring) b c. a - (b - c) = c + (a - b)" by (simp add: ring_simps)
+ have "x - k *s (a - (\<Sum>x\<in>C. (x \<bullet> a / (x \<bullet> x)) *s x)) \<in> span C \<longleftrightarrow> x - k *s a \<in> span C"
+ apply (simp only: vector_ssub_ldistrib th0)
+ apply (rule span_add_eq)
+ apply (rule span_mul)
+ apply (rule span_setsum[OF C(1)])
+ apply clarify
+ apply (rule span_mul)
+ by (rule span_superset)}
+ then have SC: "span ?C = span (insert a B)"
+ unfolding expand_set_eq span_breakdown_eq C(3)[symmetric] by auto
+ thm pairwise_def
+ {fix x y assume xC: "x \<in> ?C" and yC: "y \<in> ?C" and xy: "x \<noteq> y"
+ {assume xa: "x = ?a" and ya: "y = ?a"
+ have "orthogonal x y" using xa ya xy by blast}
+ moreover
+ {assume xa: "x = ?a" and ya: "y \<noteq> ?a" "y \<in> C"
+ from ya have Cy: "C = insert y (C - {y})" by blast
+ have fth: "finite (C - {y})" using C by simp
+ have "orthogonal x y"
+ using xa ya
+ unfolding orthogonal_def xa dot_lsub dot_rsub diff_eq_0_iff_eq
+ apply simp
+ apply (subst Cy)
+ using C(1) fth
+ apply (simp only: setsum_clauses)
+ thm dot_ladd
+ apply (auto simp add: dot_ladd dot_radd dot_lmult dot_rmult dot_eq_0 dot_sym[of y a] dot_lsum[OF fth])
+ apply (rule setsum_0')
+ apply clarsimp
+ apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
+ by auto}
+ moreover
+ {assume xa: "x \<noteq> ?a" "x \<in> C" and ya: "y = ?a"
+ from xa have Cx: "C = insert x (C - {x})" by blast
+ have fth: "finite (C - {x})" using C by simp
+ have "orthogonal x y"
+ using xa ya
+ unfolding orthogonal_def ya dot_rsub dot_lsub diff_eq_0_iff_eq
+ apply simp
+ apply (subst Cx)
+ using C(1) fth
+ apply (simp only: setsum_clauses)
+ apply (subst dot_sym[of x])
+ apply (auto simp add: dot_radd dot_rmult dot_eq_0 dot_sym[of x a] dot_rsum[OF fth])
+ apply (rule setsum_0')
+ apply clarsimp
+ apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
+ by auto}
+ moreover
+ {assume xa: "x \<in> C" and ya: "y \<in> C"
+ have "orthogonal x y" using xa ya xy C(4) unfolding pairwise_def by blast}
+ ultimately have "orthogonal x y" using xC yC by blast}
+ then have CPO: "pairwise orthogonal ?C" unfolding pairwise_def by blast
+ from fC cC SC CPO have "?P (insert a B) ?C" by blast
+ then show ?case by blast
+qed
+
+lemma orthogonal_basis_exists:
+ fixes V :: "(real ^'n::finite) set"
+ shows "\<exists>B. independent B \<and> B \<subseteq> span V \<and> V \<subseteq> span B \<and> (B hassize dim V) \<and> pairwise orthogonal B"
+proof-
+ from basis_exists[of V] obtain B where B: "B \<subseteq> V" "independent B" "V \<subseteq> span B" "B hassize dim V" by blast
+ from B have fB: "finite B" "card B = dim V" by (simp_all add: hassize_def)
+ from basis_orthogonal[OF fB(1)] obtain C where
+ C: "finite C" "card C \<le> card B" "span C = span B" "pairwise orthogonal C" by blast
+ from C B
+ have CSV: "C \<subseteq> span V" by (metis span_inc span_mono subset_trans)
+ from span_mono[OF B(3)] C have SVC: "span V \<subseteq> span C" by (simp add: span_span)
+ from card_le_dim_spanning[OF CSV SVC C(1)] C(2,3) fB
+ have iC: "independent C" by (simp add: dim_span)
+ from C fB have "card C \<le> dim V" by simp
+ moreover have "dim V \<le> card C" using span_card_ge_dim[OF CSV SVC C(1)]
+ by (simp add: dim_span)
+ ultimately have CdV: "C hassize dim V" unfolding hassize_def using C(1) by simp
+ from C B CSV CdV iC show ?thesis by auto
+qed
+
+lemma span_eq: "span S = span T \<longleftrightarrow> S \<subseteq> span T \<and> T \<subseteq> span S"
+ by (metis set_eq_subset span_mono span_span span_inc) (* FIXME: slow *)
+
+(* ------------------------------------------------------------------------- *)
+(* Low-dimensional subset is in a hyperplane (weak orthogonal complement). *)
+(* ------------------------------------------------------------------------- *)
+
+lemma span_not_univ_orthogonal:
+ assumes sU: "span S \<noteq> UNIV"
+ shows "\<exists>(a:: real ^'n::finite). a \<noteq>0 \<and> (\<forall>x \<in> span S. a \<bullet> x = 0)"
+proof-
+ from sU obtain a where a: "a \<notin> span S" by blast
+ from orthogonal_basis_exists obtain B where
+ B: "independent B" "B \<subseteq> span S" "S \<subseteq> span B" "B hassize dim S" "pairwise orthogonal B"
+ by blast
+ from B have fB: "finite B" "card B = dim S" by (simp_all add: hassize_def)
+ from span_mono[OF B(2)] span_mono[OF B(3)]
+ have sSB: "span S = span B" by (simp add: span_span)
+ let ?a = "a - setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B"
+ have "setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B \<in> span S"
+ unfolding sSB
+ apply (rule span_setsum[OF fB(1)])
+ apply clarsimp
+ apply (rule span_mul)
+ by (rule span_superset)
+ with a have a0:"?a \<noteq> 0" by auto
+ have "\<forall>x\<in>span B. ?a \<bullet> x = 0"
+ proof(rule span_induct')
+ show "subspace (\<lambda>x. ?a \<bullet> x = 0)"
+ by (auto simp add: subspace_def mem_def dot_radd dot_rmult)
+ next
+ {fix x assume x: "x \<in> B"
+ from x have B': "B = insert x (B - {x})" by blast
+ have fth: "finite (B - {x})" using fB by simp
+ have "?a \<bullet> x = 0"
+ apply (subst B') using fB fth
+ unfolding setsum_clauses(2)[OF fth]
+ apply simp
+ apply (clarsimp simp add: dot_lsub dot_ladd dot_lmult dot_lsum dot_eq_0)
+ apply (rule setsum_0', rule ballI)
+ unfolding dot_sym
+ by (auto simp add: x field_simps dot_eq_0 intro: B(5)[unfolded pairwise_def orthogonal_def, rule_format])}
+ then show "\<forall>x \<in> B. ?a \<bullet> x = 0" by blast
+ qed
+ with a0 show ?thesis unfolding sSB by (auto intro: exI[where x="?a"])
+qed
+
+lemma span_not_univ_subset_hyperplane:
+ assumes SU: "span S \<noteq> (UNIV ::(real^'n::finite) set)"
+ shows "\<exists> a. a \<noteq>0 \<and> span S \<subseteq> {x. a \<bullet> x = 0}"
+ using span_not_univ_orthogonal[OF SU] by auto
+
+lemma lowdim_subset_hyperplane:
+ assumes d: "dim S < CARD('n::finite)"
+ shows "\<exists>(a::real ^'n::finite). a \<noteq> 0 \<and> span S \<subseteq> {x. a \<bullet> x = 0}"
+proof-
+ {assume "span S = UNIV"
+ hence "dim (span S) = dim (UNIV :: (real ^'n) set)" by simp
+ hence "dim S = CARD('n)" by (simp add: dim_span dim_univ)
+ with d have False by arith}
+ hence th: "span S \<noteq> UNIV" by blast
+ from span_not_univ_subset_hyperplane[OF th] show ?thesis .
+qed
+
+(* We can extend a linear basis-basis injection to the whole set. *)
+
+lemma linear_indep_image_lemma:
+ assumes lf: "linear f" and fB: "finite B"
+ and ifB: "independent (f ` B)"
+ and fi: "inj_on f B" and xsB: "x \<in> span B"
+ and fx: "f (x::'a::field^'n) = 0"
+ shows "x = 0"
+ using fB ifB fi xsB fx
+proof(induct arbitrary: x rule: finite_induct[OF fB])
+ case 1 thus ?case by (auto simp add: span_empty)
+next
+ case (2 a b x)
+ have fb: "finite b" using "2.prems" by simp
+ have th0: "f ` b \<subseteq> f ` (insert a b)"
+ apply (rule image_mono) by blast
+ from independent_mono[ OF "2.prems"(2) th0]
+ have ifb: "independent (f ` b)" .
+ have fib: "inj_on f b"
+ apply (rule subset_inj_on [OF "2.prems"(3)])
+ by blast
+ from span_breakdown[of a "insert a b", simplified, OF "2.prems"(4)]
+ obtain k where k: "x - k*s a \<in> span (b -{a})" by blast
+ have "f (x - k*s a) \<in> span (f ` b)"
+ unfolding span_linear_image[OF lf]
+ apply (rule imageI)
+ using k span_mono[of "b-{a}" b] by blast
+ hence "f x - k*s f a \<in> span (f ` b)"
+ by (simp add: linear_sub[OF lf] linear_cmul[OF lf])
+ hence th: "-k *s f a \<in> span (f ` b)"
+ using "2.prems"(5) by (simp add: vector_smult_lneg)
+ {assume k0: "k = 0"
+ from k0 k have "x \<in> span (b -{a})" by simp
+ then have "x \<in> span b" using span_mono[of "b-{a}" b]
+ by blast}
+ moreover
+ {assume k0: "k \<noteq> 0"
+ from span_mul[OF th, of "- 1/ k"] k0
+ have th1: "f a \<in> span (f ` b)"
+ by (auto simp add: vector_smult_assoc)
+ from inj_on_image_set_diff[OF "2.prems"(3), of "insert a b " "{a}", symmetric]
+ have tha: "f ` insert a b - f ` {a} = f ` (insert a b - {a})" by blast
+ from "2.prems"(2)[unfolded dependent_def bex_simps(10), rule_format, of "f a"]
+ have "f a \<notin> span (f ` b)" using tha
+ using "2.hyps"(2)
+ "2.prems"(3) by auto
+ with th1 have False by blast
+ then have "x \<in> span b" by blast}
+ ultimately have xsb: "x \<in> span b" by blast
+ from "2.hyps"(3)[OF fb ifb fib xsb "2.prems"(5)]
+ show "x = 0" .
+qed
+
+(* We can extend a linear mapping from basis. *)
+
+lemma linear_independent_extend_lemma:
+ assumes fi: "finite B" and ib: "independent B"
+ shows "\<exists>g. (\<forall>x\<in> span B. \<forall>y\<in> span B. g ((x::'a::field^'n) + y) = g x + g y)
+ \<and> (\<forall>x\<in> span B. \<forall>c. g (c*s x) = c *s g x)
+ \<and> (\<forall>x\<in> B. g x = f x)"
+using ib fi
+proof(induct rule: finite_induct[OF fi])
+ case 1 thus ?case by (auto simp add: span_empty)
+next
+ case (2 a b)
+ from "2.prems" "2.hyps" have ibf: "independent b" "finite b"
+ by (simp_all add: independent_insert)
+ from "2.hyps"(3)[OF ibf] obtain g where
+ g: "\<forall>x\<in>span b. \<forall>y\<in>span b. g (x + y) = g x + g y"
+ "\<forall>x\<in>span b. \<forall>c. g (c *s x) = c *s g x" "\<forall>x\<in>b. g x = f x" by blast
+ let ?h = "\<lambda>z. SOME k. (z - k *s a) \<in> span b"
+ {fix z assume z: "z \<in> span (insert a b)"
+ have th0: "z - ?h z *s a \<in> span b"
+ apply (rule someI_ex)
+ unfolding span_breakdown_eq[symmetric]
+ using z .
+ {fix k assume k: "z - k *s a \<in> span b"
+ have eq: "z - ?h z *s a - (z - k*s a) = (k - ?h z) *s a"
+ by (simp add: ring_simps vector_sadd_rdistrib[symmetric])
+ from span_sub[OF th0 k]
+ have khz: "(k - ?h z) *s a \<in> span b" by (simp add: eq)
+ {assume "k \<noteq> ?h z" hence k0: "k - ?h z \<noteq> 0" by simp
+ from k0 span_mul[OF khz, of "1 /(k - ?h z)"]
+ have "a \<in> span b" by (simp add: vector_smult_assoc)
+ with "2.prems"(1) "2.hyps"(2) have False
+ by (auto simp add: dependent_def)}
+ then have "k = ?h z" by blast}
+ with th0 have "z - ?h z *s a \<in> span b \<and> (\<forall>k. z - k *s a \<in> span b \<longrightarrow> k = ?h z)" by blast}
+ note h = this
+ let ?g = "\<lambda>z. ?h z *s f a + g (z - ?h z *s a)"
+ {fix x y assume x: "x \<in> span (insert a b)" and y: "y \<in> span (insert a b)"
+ have tha: "\<And>(x::'a^'n) y a k l. (x + y) - (k + l) *s a = (x - k *s a) + (y - l *s a)"
+ by (vector ring_simps)
+ have addh: "?h (x + y) = ?h x + ?h y"
+ apply (rule conjunct2[OF h, rule_format, symmetric])
+ apply (rule span_add[OF x y])
+ unfolding tha
+ by (metis span_add x y conjunct1[OF h, rule_format])
+ have "?g (x + y) = ?g x + ?g y"
+ unfolding addh tha
+ g(1)[rule_format,OF conjunct1[OF h, OF x] conjunct1[OF h, OF y]]
+ by (simp add: vector_sadd_rdistrib)}
+ moreover
+ {fix x:: "'a^'n" and c:: 'a assume x: "x \<in> span (insert a b)"
+ have tha: "\<And>(x::'a^'n) c k a. c *s x - (c * k) *s a = c *s (x - k *s a)"
+ by (vector ring_simps)
+ have hc: "?h (c *s x) = c * ?h x"
+ apply (rule conjunct2[OF h, rule_format, symmetric])
+ apply (metis span_mul x)
+ by (metis tha span_mul x conjunct1[OF h])
+ have "?g (c *s x) = c*s ?g x"
+ unfolding hc tha g(2)[rule_format, OF conjunct1[OF h, OF x]]
+ by (vector ring_simps)}
+ moreover
+ {fix x assume x: "x \<in> (insert a b)"
+ {assume xa: "x = a"
+ have ha1: "1 = ?h a"
+ apply (rule conjunct2[OF h, rule_format])
+ apply (metis span_superset insertI1)
+ using conjunct1[OF h, OF span_superset, OF insertI1]
+ by (auto simp add: span_0)
+
+ from xa ha1[symmetric] have "?g x = f x"
+ apply simp
+ using g(2)[rule_format, OF span_0, of 0]
+ by simp}
+ moreover
+ {assume xb: "x \<in> b"
+ have h0: "0 = ?h x"
+ apply (rule conjunct2[OF h, rule_format])
+ apply (metis span_superset insertI1 xb x)
+ apply simp
+ apply (metis span_superset xb)
+ done
+ have "?g x = f x"
+ by (simp add: h0[symmetric] g(3)[rule_format, OF xb])}
+ ultimately have "?g x = f x" using x by blast }
+ ultimately show ?case apply - apply (rule exI[where x="?g"]) by blast
+qed
+
+lemma linear_independent_extend:
+ assumes iB: "independent (B:: (real ^'n::finite) set)"
+ shows "\<exists>g. linear g \<and> (\<forall>x\<in>B. g x = f x)"
+proof-
+ from maximal_independent_subset_extend[of B UNIV] iB
+ obtain C where C: "B \<subseteq> C" "independent C" "\<And>x. x \<in> span C" by auto
+
+ from C(2) independent_bound[of C] linear_independent_extend_lemma[of C f]
+ obtain g where g: "(\<forall>x\<in> span C. \<forall>y\<in> span C. g (x + y) = g x + g y)
+ \<and> (\<forall>x\<in> span C. \<forall>c. g (c*s x) = c *s g x)
+ \<and> (\<forall>x\<in> C. g x = f x)" by blast
+ from g show ?thesis unfolding linear_def using C
+ apply clarsimp by blast
+qed
+
+(* Can construct an isomorphism between spaces of same dimension. *)
+
+lemma card_le_inj: assumes fA: "finite A" and fB: "finite B"
+ and c: "card A \<le> card B" shows "(\<exists>f. f ` A \<subseteq> B \<and> inj_on f A)"
+using fB c
+proof(induct arbitrary: B rule: finite_induct[OF fA])
+ case 1 thus ?case by simp
+next
+ case (2 x s t)
+ thus ?case
+ proof(induct rule: finite_induct[OF "2.prems"(1)])
+ case 1 then show ?case by simp
+ next
+ case (2 y t)
+ from "2.prems"(1,2,5) "2.hyps"(1,2) have cst:"card s \<le> card t" by simp
+ from "2.prems"(3) [OF "2.hyps"(1) cst] obtain f where
+ f: "f ` s \<subseteq> t \<and> inj_on f s" by blast
+ from f "2.prems"(2) "2.hyps"(2) show ?case
+ apply -
+ apply (rule exI[where x = "\<lambda>z. if z = x then y else f z"])
+ by (auto simp add: inj_on_def)
+ qed
+qed
+
+lemma card_subset_eq: assumes fB: "finite B" and AB: "A \<subseteq> B" and
+ c: "card A = card B"
+ shows "A = B"
+proof-
+ from fB AB have fA: "finite A" by (auto intro: finite_subset)
+ from fA fB have fBA: "finite (B - A)" by auto
+ have e: "A \<inter> (B - A) = {}" by blast
+ have eq: "A \<union> (B - A) = B" using AB by blast
+ from card_Un_disjoint[OF fA fBA e, unfolded eq c]
+ have "card (B - A) = 0" by arith
+ hence "B - A = {}" unfolding card_eq_0_iff using fA fB by simp
+ with AB show "A = B" by blast
+qed
+
+lemma subspace_isomorphism:
+ assumes s: "subspace (S:: (real ^'n::finite) set)"
+ and t: "subspace (T :: (real ^ 'm::finite) set)"
+ and d: "dim S = dim T"
+ shows "\<exists>f. linear f \<and> f ` S = T \<and> inj_on f S"
+proof-
+ from basis_exists[of S] obtain B where
+ B: "B \<subseteq> S" "independent B" "S \<subseteq> span B" "B hassize dim S" by blast
+ from basis_exists[of T] obtain C where
+ C: "C \<subseteq> T" "independent C" "T \<subseteq> span C" "C hassize dim T" by blast
+ from B(4) C(4) card_le_inj[of B C] d obtain f where
+ f: "f ` B \<subseteq> C" "inj_on f B" unfolding hassize_def by auto
+ from linear_independent_extend[OF B(2)] obtain g where
+ g: "linear g" "\<forall>x\<in> B. g x = f x" by blast
+ from B(4) have fB: "finite B" by (simp add: hassize_def)
+ from C(4) have fC: "finite C" by (simp add: hassize_def)
+ from inj_on_iff_eq_card[OF fB, of f] f(2)
+ have "card (f ` B) = card B" by simp
+ with B(4) C(4) have ceq: "card (f ` B) = card C" using d
+ by (simp add: hassize_def)
+ have "g ` B = f ` B" using g(2)
+ by (auto simp add: image_iff)
+ also have "\<dots> = C" using card_subset_eq[OF fC f(1) ceq] .
+ finally have gBC: "g ` B = C" .
+ have gi: "inj_on g B" using f(2) g(2)
+ by (auto simp add: inj_on_def)
+ note g0 = linear_indep_image_lemma[OF g(1) fB, unfolded gBC, OF C(2) gi]
+ {fix x y assume x: "x \<in> S" and y: "y \<in> S" and gxy:"g x = g y"
+ from B(3) x y have x': "x \<in> span B" and y': "y \<in> span B" by blast+
+ from gxy have th0: "g (x - y) = 0" by (simp add: linear_sub[OF g(1)])
+ have th1: "x - y \<in> span B" using x' y' by (metis span_sub)
+ have "x=y" using g0[OF th1 th0] by simp }
+ then have giS: "inj_on g S"
+ unfolding inj_on_def by blast
+ from span_subspace[OF B(1,3) s]
+ have "g ` S = span (g ` B)" by (simp add: span_linear_image[OF g(1)])
+ also have "\<dots> = span C" unfolding gBC ..
+ also have "\<dots> = T" using span_subspace[OF C(1,3) t] .
+ finally have gS: "g ` S = T" .
+ from g(1) gS giS show ?thesis by blast
+qed
+
+(* linear functions are equal on a subspace if they are on a spanning set. *)
+
+lemma subspace_kernel:
+ assumes lf: "linear (f::'a::semiring_1 ^'n \<Rightarrow> _)"
+ shows "subspace {x. f x = 0}"
+apply (simp add: subspace_def)
+by (simp add: linear_add[OF lf] linear_cmul[OF lf] linear_0[OF lf])
+
+lemma linear_eq_0_span:
+ assumes lf: "linear f" and f0: "\<forall>x\<in>B. f x = 0"
+ shows "\<forall>x \<in> span B. f x = (0::'a::semiring_1 ^'n)"
+proof
+ fix x assume x: "x \<in> span B"
+ let ?P = "\<lambda>x. f x = 0"
+ from subspace_kernel[OF lf] have "subspace ?P" unfolding Collect_def .
+ with x f0 span_induct[of B "?P" x] show "f x = 0" by blast
+qed
+
+lemma linear_eq_0:
+ assumes lf: "linear f" and SB: "S \<subseteq> span B" and f0: "\<forall>x\<in>B. f x = 0"
+ shows "\<forall>x \<in> S. f x = (0::'a::semiring_1^'n)"
+ by (metis linear_eq_0_span[OF lf] subset_eq SB f0)
+
+lemma linear_eq:
+ assumes lf: "linear (f::'a::ring_1^'n \<Rightarrow> _)" and lg: "linear g" and S: "S \<subseteq> span B"
+ and fg: "\<forall> x\<in> B. f x = g x"
+ shows "\<forall>x\<in> S. f x = g x"
+proof-
+ let ?h = "\<lambda>x. f x - g x"
+ from fg have fg': "\<forall>x\<in> B. ?h x = 0" by simp
+ from linear_eq_0[OF linear_compose_sub[OF lf lg] S fg']
+ show ?thesis by simp
+qed
+
+lemma linear_eq_stdbasis:
+ assumes lf: "linear (f::'a::ring_1^'m::finite \<Rightarrow> 'a^'n::finite)" and lg: "linear g"
+ and fg: "\<forall>i. f (basis i) = g(basis i)"
+ shows "f = g"
+proof-
+ let ?U = "UNIV :: 'm set"
+ let ?I = "{basis i:: 'a^'m|i. i \<in> ?U}"
+ {fix x assume x: "x \<in> (UNIV :: ('a^'m) set)"
+ from equalityD2[OF span_stdbasis]
+ have IU: " (UNIV :: ('a^'m) set) \<subseteq> span ?I" by blast
+ from linear_eq[OF lf lg IU] fg x
+ have "f x = g x" unfolding Collect_def Ball_def mem_def by metis}
+ then show ?thesis by (auto intro: ext)
+qed
+
+(* Similar results for bilinear functions. *)
+
+lemma bilinear_eq:
+ assumes bf: "bilinear (f:: 'a::ring^'m \<Rightarrow> 'a^'n \<Rightarrow> 'a^'p)"
+ and bg: "bilinear g"
+ and SB: "S \<subseteq> span B" and TC: "T \<subseteq> span C"
+ and fg: "\<forall>x\<in> B. \<forall>y\<in> C. f x y = g x y"
+ shows "\<forall>x\<in>S. \<forall>y\<in>T. f x y = g x y "
+proof-
+ let ?P = "\<lambda>x. \<forall>y\<in> span C. f x y = g x y"
+ from bf bg have sp: "subspace ?P"
+ unfolding bilinear_def linear_def subspace_def bf bg
+ by(auto simp add: span_0 mem_def bilinear_lzero[OF bf] bilinear_lzero[OF bg] span_add Ball_def intro: bilinear_ladd[OF bf])
+
+ have "\<forall>x \<in> span B. \<forall>y\<in> span C. f x y = g x y"
+ apply -
+ apply (rule ballI)
+ apply (rule span_induct[of B ?P])
+ defer
+ apply (rule sp)
+ apply assumption
+ apply (clarsimp simp add: Ball_def)
+ apply (rule_tac P="\<lambda>y. f xa y = g xa y" and S=C in span_induct)
+ using fg
+ apply (auto simp add: subspace_def)
+ using bf bg unfolding bilinear_def linear_def
+ by(auto simp add: span_0 mem_def bilinear_rzero[OF bf] bilinear_rzero[OF bg] span_add Ball_def intro: bilinear_ladd[OF bf])
+ then show ?thesis using SB TC by (auto intro: ext)
+qed
+
+lemma bilinear_eq_stdbasis:
+ assumes bf: "bilinear (f:: 'a::ring_1^'m::finite \<Rightarrow> 'a^'n::finite \<Rightarrow> 'a^'p)"
+ and bg: "bilinear g"
+ and fg: "\<forall>i j. f (basis i) (basis j) = g (basis i) (basis j)"
+ shows "f = g"
+proof-
+ from fg have th: "\<forall>x \<in> {basis i| i. i\<in> (UNIV :: 'm set)}. \<forall>y\<in> {basis j |j. j \<in> (UNIV :: 'n set)}. f x y = g x y" by blast
+ from bilinear_eq[OF bf bg equalityD2[OF span_stdbasis] equalityD2[OF span_stdbasis] th] show ?thesis by (blast intro: ext)
+qed
+
+(* Detailed theorems about left and right invertibility in general case. *)
+
+lemma left_invertible_transp:
+ "(\<exists>(B::'a^'n^'m). B ** transp (A::'a^'n^'m) = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B::'a^'m^'n). A ** B = mat 1)"
+ by (metis matrix_transp_mul transp_mat transp_transp)
+
+lemma right_invertible_transp:
+ "(\<exists>(B::'a^'n^'m). transp (A::'a^'n^'m) ** B = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B::'a^'m^'n). B ** A = mat 1)"
+ by (metis matrix_transp_mul transp_mat transp_transp)
+
+lemma linear_injective_left_inverse:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'m::finite)" and fi: "inj f"
+ shows "\<exists>g. linear g \<and> g o f = id"
+proof-
+ from linear_independent_extend[OF independent_injective_image, OF independent_stdbasis, OF lf fi]
+ obtain h:: "real ^'m \<Rightarrow> real ^'n" where h: "linear h" " \<forall>x \<in> f ` {basis i|i. i \<in> (UNIV::'n set)}. h x = inv f x" by blast
+ from h(2)
+ have th: "\<forall>i. (h \<circ> f) (basis i) = id (basis i)"
+ using inv_o_cancel[OF fi, unfolded stupid_ext[symmetric] id_def o_def]
+ by auto
+
+ from linear_eq_stdbasis[OF linear_compose[OF lf h(1)] linear_id th]
+ have "h o f = id" .
+ then show ?thesis using h(1) by blast
+qed
+
+lemma linear_surjective_right_inverse:
+ assumes lf: "linear (f:: real ^'m::finite \<Rightarrow> real ^'n::finite)" and sf: "surj f"
+ shows "\<exists>g. linear g \<and> f o g = id"
+proof-
+ from linear_independent_extend[OF independent_stdbasis]
+ obtain h:: "real ^'n \<Rightarrow> real ^'m" where
+ h: "linear h" "\<forall> x\<in> {basis i| i. i\<in> (UNIV :: 'n set)}. h x = inv f x" by blast
+ from h(2)
+ have th: "\<forall>i. (f o h) (basis i) = id (basis i)"
+ using sf
+ apply (auto simp add: surj_iff o_def stupid_ext[symmetric])
+ apply (erule_tac x="basis i" in allE)
+ by auto
+
+ from linear_eq_stdbasis[OF linear_compose[OF h(1) lf] linear_id th]
+ have "f o h = id" .
+ then show ?thesis using h(1) by blast
+qed
+
+lemma matrix_left_invertible_injective:
+"(\<exists>B. (B::real^'m^'n) ** (A::real^'n::finite^'m::finite) = mat 1) \<longleftrightarrow> (\<forall>x y. A *v x = A *v y \<longrightarrow> x = y)"
+proof-
+ {fix B:: "real^'m^'n" and x y assume B: "B ** A = mat 1" and xy: "A *v x = A*v y"
+ from xy have "B*v (A *v x) = B *v (A*v y)" by simp
+ hence "x = y"
+ unfolding matrix_vector_mul_assoc B matrix_vector_mul_lid .}
+ moreover
+ {assume A: "\<forall>x y. A *v x = A *v y \<longrightarrow> x = y"
+ hence i: "inj (op *v A)" unfolding inj_on_def by auto
+ from linear_injective_left_inverse[OF matrix_vector_mul_linear i]
+ obtain g where g: "linear g" "g o op *v A = id" by blast
+ have "matrix g ** A = mat 1"
+ unfolding matrix_eq matrix_vector_mul_lid matrix_vector_mul_assoc[symmetric] matrix_works[OF g(1)]
+ using g(2) by (simp add: o_def id_def stupid_ext)
+ then have "\<exists>B. (B::real ^'m^'n) ** A = mat 1" by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma matrix_left_invertible_ker:
+ "(\<exists>B. (B::real ^'m::finite^'n::finite) ** (A::real^'n^'m) = mat 1) \<longleftrightarrow> (\<forall>x. A *v x = 0 \<longrightarrow> x = 0)"
+ unfolding matrix_left_invertible_injective
+ using linear_injective_0[OF matrix_vector_mul_linear, of A]
+ by (simp add: inj_on_def)
+
+lemma matrix_right_invertible_surjective:
+"(\<exists>B. (A::real^'n::finite^'m::finite) ** (B::real^'m^'n) = mat 1) \<longleftrightarrow> surj (\<lambda>x. A *v x)"
+proof-
+ {fix B :: "real ^'m^'n" assume AB: "A ** B = mat 1"
+ {fix x :: "real ^ 'm"
+ have "A *v (B *v x) = x"
+ by (simp add: matrix_vector_mul_lid matrix_vector_mul_assoc AB)}
+ hence "surj (op *v A)" unfolding surj_def by metis }
+ moreover
+ {assume sf: "surj (op *v A)"
+ from linear_surjective_right_inverse[OF matrix_vector_mul_linear sf]
+ obtain g:: "real ^'m \<Rightarrow> real ^'n" where g: "linear g" "op *v A o g = id"
+ by blast
+
+ have "A ** (matrix g) = mat 1"
+ unfolding matrix_eq matrix_vector_mul_lid
+ matrix_vector_mul_assoc[symmetric] matrix_works[OF g(1)]
+ using g(2) unfolding o_def stupid_ext[symmetric] id_def
+ .
+ hence "\<exists>B. A ** (B::real^'m^'n) = mat 1" by blast
+ }
+ ultimately show ?thesis unfolding surj_def by blast
+qed
+
+lemma matrix_left_invertible_independent_columns:
+ fixes A :: "real^'n::finite^'m::finite"
+ shows "(\<exists>(B::real ^'m^'n). B ** A = mat 1) \<longleftrightarrow> (\<forall>c. setsum (\<lambda>i. c i *s column i A) (UNIV :: 'n set) = 0 \<longrightarrow> (\<forall>i. c i = 0))"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ let ?U = "UNIV :: 'n set"
+ {assume k: "\<forall>x. A *v x = 0 \<longrightarrow> x = 0"
+ {fix c i assume c: "setsum (\<lambda>i. c i *s column i A) ?U = 0"
+ and i: "i \<in> ?U"
+ let ?x = "\<chi> i. c i"
+ have th0:"A *v ?x = 0"
+ using c
+ unfolding matrix_mult_vsum Cart_eq
+ by auto
+ from k[rule_format, OF th0] i
+ have "c i = 0" by (vector Cart_eq)}
+ hence ?rhs by blast}
+ moreover
+ {assume H: ?rhs
+ {fix x assume x: "A *v x = 0"
+ let ?c = "\<lambda>i. ((x$i ):: real)"
+ from H[rule_format, of ?c, unfolded matrix_mult_vsum[symmetric], OF x]
+ have "x = 0" by vector}}
+ ultimately show ?thesis unfolding matrix_left_invertible_ker by blast
+qed
+
+lemma matrix_right_invertible_independent_rows:
+ fixes A :: "real^'n::finite^'m::finite"
+ shows "(\<exists>(B::real^'m^'n). A ** B = mat 1) \<longleftrightarrow> (\<forall>c. setsum (\<lambda>i. c i *s row i A) (UNIV :: 'm set) = 0 \<longrightarrow> (\<forall>i. c i = 0))"
+ unfolding left_invertible_transp[symmetric]
+ matrix_left_invertible_independent_columns
+ by (simp add: column_transp)
+
+lemma matrix_right_invertible_span_columns:
+ "(\<exists>(B::real ^'n::finite^'m::finite). (A::real ^'m^'n) ** B = mat 1) \<longleftrightarrow> span (columns A) = UNIV" (is "?lhs = ?rhs")
+proof-
+ let ?U = "UNIV :: 'm set"
+ have fU: "finite ?U" by simp
+ have lhseq: "?lhs \<longleftrightarrow> (\<forall>y. \<exists>(x::real^'m). setsum (\<lambda>i. (x$i) *s column i A) ?U = y)"
+ unfolding matrix_right_invertible_surjective matrix_mult_vsum surj_def
+ apply (subst eq_commute) ..
+ have rhseq: "?rhs \<longleftrightarrow> (\<forall>x. x \<in> span (columns A))" by blast
+ {assume h: ?lhs
+ {fix x:: "real ^'n"
+ from h[unfolded lhseq, rule_format, of x] obtain y:: "real ^'m"
+ where y: "setsum (\<lambda>i. (y$i) *s column i A) ?U = x" by blast
+ have "x \<in> span (columns A)"
+ unfolding y[symmetric]
+ apply (rule span_setsum[OF fU])
+ apply clarify
+ apply (rule span_mul)
+ apply (rule span_superset)
+ unfolding columns_def
+ by blast}
+ then have ?rhs unfolding rhseq by blast}
+ moreover
+ {assume h:?rhs
+ let ?P = "\<lambda>(y::real ^'n). \<exists>(x::real^'m). setsum (\<lambda>i. (x$i) *s column i A) ?U = y"
+ {fix y have "?P y"
+ proof(rule span_induct_alt[of ?P "columns A"])
+ show "\<exists>x\<Colon>real ^ 'm. setsum (\<lambda>i. (x$i) *s column i A) ?U = 0"
+ apply (rule exI[where x=0])
+ by (simp add: zero_index vector_smult_lzero)
+ next
+ fix c y1 y2 assume y1: "y1 \<in> columns A" and y2: "?P y2"
+ from y1 obtain i where i: "i \<in> ?U" "y1 = column i A"
+ unfolding columns_def by blast
+ from y2 obtain x:: "real ^'m" where
+ x: "setsum (\<lambda>i. (x$i) *s column i A) ?U = y2" by blast
+ let ?x = "(\<chi> j. if j = i then c + (x$i) else (x$j))::real^'m"
+ show "?P (c*s y1 + y2)"
+ proof(rule exI[where x= "?x"], vector, auto simp add: i x[symmetric] cond_value_iff right_distrib cond_application_beta cong del: if_weak_cong)
+ fix j
+ have th: "\<forall>xa \<in> ?U. (if xa = i then (c + (x$i)) * ((column xa A)$j)
+ else (x$xa) * ((column xa A$j))) = (if xa = i then c * ((column i A)$j) else 0) + ((x$xa) * ((column xa A)$j))" using i(1)
+ by (simp add: ring_simps)
+ have "setsum (\<lambda>xa. if xa = i then (c + (x$i)) * ((column xa A)$j)
+ else (x$xa) * ((column xa A$j))) ?U = setsum (\<lambda>xa. (if xa = i then c * ((column i A)$j) else 0) + ((x$xa) * ((column xa A)$j))) ?U"
+ apply (rule setsum_cong[OF refl])
+ using th by blast
+ also have "\<dots> = setsum (\<lambda>xa. if xa = i then c * ((column i A)$j) else 0) ?U + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U"
+ by (simp add: setsum_addf)
+ also have "\<dots> = c * ((column i A)$j) + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U"
+ unfolding setsum_delta[OF fU]
+ using i(1) by simp
+ finally show "setsum (\<lambda>xa. if xa = i then (c + (x$i)) * ((column xa A)$j)
+ else (x$xa) * ((column xa A$j))) ?U = c * ((column i A)$j) + setsum (\<lambda>xa. ((x$xa) * ((column xa A)$j))) ?U" .
+ qed
+ next
+ show "y \<in> span (columns A)" unfolding h by blast
+ qed}
+ then have ?lhs unfolding lhseq ..}
+ ultimately show ?thesis by blast
+qed
+
+lemma matrix_left_invertible_span_rows:
+ "(\<exists>(B::real^'m::finite^'n::finite). B ** (A::real^'n^'m) = mat 1) \<longleftrightarrow> span (rows A) = UNIV"
+ unfolding right_invertible_transp[symmetric]
+ unfolding columns_transp[symmetric]
+ unfolding matrix_right_invertible_span_columns
+ ..
+
+(* An injective map real^'n->real^'n is also surjective. *)
+
+lemma linear_injective_imp_surjective:
+ assumes lf: "linear (f:: real ^'n::finite \<Rightarrow> real ^'n)" and fi: "inj f"
+ shows "surj f"
+proof-
+ let ?U = "UNIV :: (real ^'n) set"
+ from basis_exists[of ?U] obtain B
+ where B: "B \<subseteq> ?U" "independent B" "?U \<subseteq> span B" "B hassize dim ?U"
+ by blast
+ from B(4) have d: "dim ?U = card B" by (simp add: hassize_def)
+ have th: "?U \<subseteq> span (f ` B)"
+ apply (rule card_ge_dim_independent)
+ apply blast
+ apply (rule independent_injective_image[OF B(2) lf fi])
+ apply (rule order_eq_refl)
+ apply (rule sym)
+ unfolding d
+ apply (rule card_image)
+ apply (rule subset_inj_on[OF fi])
+ by blast
+ from th show ?thesis
+ unfolding span_linear_image[OF lf] surj_def
+ using B(3) by blast
+qed
+
+(* And vice versa. *)
+
+lemma surjective_iff_injective_gen:
+ assumes fS: "finite S" and fT: "finite T" and c: "card S = card T"
+ and ST: "f ` S \<subseteq> T"
+ shows "(\<forall>y \<in> T. \<exists>x \<in> S. f x = y) \<longleftrightarrow> inj_on f S" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume h: "?lhs"
+ {fix x y assume x: "x \<in> S" and y: "y \<in> S" and f: "f x = f y"
+ from x fS have S0: "card S \<noteq> 0" by auto
+ {assume xy: "x \<noteq> y"
+ have th: "card S \<le> card (f ` (S - {y}))"
+ unfolding c
+ apply (rule card_mono)
+ apply (rule finite_imageI)
+ using fS apply simp
+ using h xy x y f unfolding subset_eq image_iff
+ apply auto
+ apply (case_tac "xa = f x")
+ apply (rule bexI[where x=x])
+ apply auto
+ done
+ also have " \<dots> \<le> card (S -{y})"
+ apply (rule card_image_le)
+ using fS by simp
+ also have "\<dots> \<le> card S - 1" using y fS by simp
+ finally have False using S0 by arith }
+ then have "x = y" by blast}
+ then have ?rhs unfolding inj_on_def by blast}
+ moreover
+ {assume h: ?rhs
+ have "f ` S = T"
+ apply (rule card_subset_eq[OF fT ST])
+ unfolding card_image[OF h] using c .
+ then have ?lhs by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma linear_surjective_imp_injective:
+ assumes lf: "linear (f::real ^'n::finite => real ^'n)" and sf: "surj f"
+ shows "inj f"
+proof-
+ let ?U = "UNIV :: (real ^'n) set"
+ from basis_exists[of ?U] obtain B
+ where B: "B \<subseteq> ?U" "independent B" "?U \<subseteq> span B" "B hassize dim ?U"
+ by blast
+ {fix x assume x: "x \<in> span B" and fx: "f x = 0"
+ from B(4) have fB: "finite B" by (simp add: hassize_def)
+ from B(4) have d: "dim ?U = card B" by (simp add: hassize_def)
+ have fBi: "independent (f ` B)"
+ apply (rule card_le_dim_spanning[of "f ` B" ?U])
+ apply blast
+ using sf B(3)
+ unfolding span_linear_image[OF lf] surj_def subset_eq image_iff
+ apply blast
+ using fB apply (blast intro: finite_imageI)
+ unfolding d
+ apply (rule card_image_le)
+ apply (rule fB)
+ done
+ have th0: "dim ?U \<le> card (f ` B)"
+ apply (rule span_card_ge_dim)
+ apply blast
+ unfolding span_linear_image[OF lf]
+ apply (rule subset_trans[where B = "f ` UNIV"])
+ using sf unfolding surj_def apply blast
+ apply (rule image_mono)
+ apply (rule B(3))
+ apply (metis finite_imageI fB)
+ done
+
+ moreover have "card (f ` B) \<le> card B"
+ by (rule card_image_le, rule fB)
+ ultimately have th1: "card B = card (f ` B)" unfolding d by arith
+ have fiB: "inj_on f B"
+ unfolding surjective_iff_injective_gen[OF fB finite_imageI[OF fB] th1 subset_refl, symmetric] by blast
+ from linear_indep_image_lemma[OF lf fB fBi fiB x] fx
+ have "x = 0" by blast}
+ note th = this
+ from th show ?thesis unfolding linear_injective_0[OF lf]
+ using B(3) by blast
+qed
+
+(* Hence either is enough for isomorphism. *)
+
+lemma left_right_inverse_eq:
+ assumes fg: "f o g = id" and gh: "g o h = id"
+ shows "f = h"
+proof-
+ have "f = f o (g o h)" unfolding gh by simp
+ also have "\<dots> = (f o g) o h" by (simp add: o_assoc)
+ finally show "f = h" unfolding fg by simp
+qed
+
+lemma isomorphism_expand:
+ "f o g = id \<and> g o f = id \<longleftrightarrow> (\<forall>x. f(g x) = x) \<and> (\<forall>x. g(f x) = x)"
+ by (simp add: expand_fun_eq o_def id_def)
+
+lemma linear_injective_isomorphism:
+ assumes lf: "linear (f :: real^'n::finite \<Rightarrow> real ^'n)" and fi: "inj f"
+ shows "\<exists>f'. linear f' \<and> (\<forall>x. f' (f x) = x) \<and> (\<forall>x. f (f' x) = x)"
+unfolding isomorphism_expand[symmetric]
+using linear_surjective_right_inverse[OF lf linear_injective_imp_surjective[OF lf fi]] linear_injective_left_inverse[OF lf fi]
+by (metis left_right_inverse_eq)
+
+lemma linear_surjective_isomorphism:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and sf: "surj f"
+ shows "\<exists>f'. linear f' \<and> (\<forall>x. f' (f x) = x) \<and> (\<forall>x. f (f' x) = x)"
+unfolding isomorphism_expand[symmetric]
+using linear_surjective_right_inverse[OF lf sf] linear_injective_left_inverse[OF lf linear_surjective_imp_injective[OF lf sf]]
+by (metis left_right_inverse_eq)
+
+(* Left and right inverses are the same for R^N->R^N. *)
+
+lemma linear_inverse_left:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and lf': "linear f'"
+ shows "f o f' = id \<longleftrightarrow> f' o f = id"
+proof-
+ {fix f f':: "real ^'n \<Rightarrow> real ^'n"
+ assume lf: "linear f" "linear f'" and f: "f o f' = id"
+ from f have sf: "surj f"
+
+ apply (auto simp add: o_def stupid_ext[symmetric] id_def surj_def)
+ by metis
+ from linear_surjective_isomorphism[OF lf(1) sf] lf f
+ have "f' o f = id" unfolding stupid_ext[symmetric] o_def id_def
+ by metis}
+ then show ?thesis using lf lf' by metis
+qed
+
+(* Moreover, a one-sided inverse is automatically linear. *)
+
+lemma left_inverse_linear:
+ assumes lf: "linear (f::real ^'n::finite \<Rightarrow> real ^'n)" and gf: "g o f = id"
+ shows "linear g"
+proof-
+ from gf have fi: "inj f" apply (auto simp add: inj_on_def o_def id_def stupid_ext[symmetric])
+ by metis
+ from linear_injective_isomorphism[OF lf fi]
+ obtain h:: "real ^'n \<Rightarrow> real ^'n" where
+ h: "linear h" "\<forall>x. h (f x) = x" "\<forall>x. f (h x) = x" by blast
+ have "h = g" apply (rule ext) using gf h(2,3)
+ apply (simp add: o_def id_def stupid_ext[symmetric])
+ by metis
+ with h(1) show ?thesis by blast
+qed
+
+lemma right_inverse_linear:
+ assumes lf: "linear (f:: real ^'n::finite \<Rightarrow> real ^'n)" and gf: "f o g = id"
+ shows "linear g"
+proof-
+ from gf have fi: "surj f" apply (auto simp add: surj_def o_def id_def stupid_ext[symmetric])
+ by metis
+ from linear_surjective_isomorphism[OF lf fi]
+ obtain h:: "real ^'n \<Rightarrow> real ^'n" where
+ h: "linear h" "\<forall>x. h (f x) = x" "\<forall>x. f (h x) = x" by blast
+ have "h = g" apply (rule ext) using gf h(2,3)
+ apply (simp add: o_def id_def stupid_ext[symmetric])
+ by metis
+ with h(1) show ?thesis by blast
+qed
+
+(* The same result in terms of square matrices. *)
+
+lemma matrix_left_right_inverse:
+ fixes A A' :: "real ^'n::finite^'n"
+ shows "A ** A' = mat 1 \<longleftrightarrow> A' ** A = mat 1"
+proof-
+ {fix A A' :: "real ^'n^'n" assume AA': "A ** A' = mat 1"
+ have sA: "surj (op *v A)"
+ unfolding surj_def
+ apply clarify
+ apply (rule_tac x="(A' *v y)" in exI)
+ by (simp add: matrix_vector_mul_assoc AA' matrix_vector_mul_lid)
+ from linear_surjective_isomorphism[OF matrix_vector_mul_linear sA]
+ obtain f' :: "real ^'n \<Rightarrow> real ^'n"
+ where f': "linear f'" "\<forall>x. f' (A *v x) = x" "\<forall>x. A *v f' x = x" by blast
+ have th: "matrix f' ** A = mat 1"
+ by (simp add: matrix_eq matrix_works[OF f'(1)] matrix_vector_mul_assoc[symmetric] matrix_vector_mul_lid f'(2)[rule_format])
+ hence "(matrix f' ** A) ** A' = mat 1 ** A'" by simp
+ hence "matrix f' = A'" by (simp add: matrix_mul_assoc[symmetric] AA' matrix_mul_rid matrix_mul_lid)
+ hence "matrix f' ** A = A' ** A" by simp
+ hence "A' ** A = mat 1" by (simp add: th)}
+ then show ?thesis by blast
+qed
+
+(* Considering an n-element vector as an n-by-1 or 1-by-n matrix. *)
+
+definition "rowvector v = (\<chi> i j. (v$j))"
+
+definition "columnvector v = (\<chi> i j. (v$i))"
+
+lemma transp_columnvector:
+ "transp(columnvector v) = rowvector v"
+ by (simp add: transp_def rowvector_def columnvector_def Cart_eq)
+
+lemma transp_rowvector: "transp(rowvector v) = columnvector v"
+ by (simp add: transp_def columnvector_def rowvector_def Cart_eq)
+
+lemma dot_rowvector_columnvector:
+ "columnvector (A *v v) = A ** columnvector v"
+ by (vector columnvector_def matrix_matrix_mult_def matrix_vector_mult_def)
+
+lemma dot_matrix_product: "(x::'a::semiring_1^'n::finite) \<bullet> y = (((rowvector x ::'a^'n^1) ** (columnvector y :: 'a^1^'n))$1)$1"
+ by (vector matrix_matrix_mult_def rowvector_def columnvector_def dot_def)
+
+lemma dot_matrix_vector_mul:
+ fixes A B :: "real ^'n::finite ^'n" and x y :: "real ^'n"
+ shows "(A *v x) \<bullet> (B *v y) =
+ (((rowvector x :: real^'n^1) ** ((transp A ** B) ** (columnvector y :: real ^1^'n)))$1)$1"
+unfolding dot_matrix_product transp_columnvector[symmetric]
+ dot_rowvector_columnvector matrix_transp_mul matrix_mul_assoc ..
+
+(* Infinity norm. *)
+
+definition "infnorm (x::real^'n::finite) = Sup {abs(x$i) |i. i\<in> (UNIV :: 'n set)}"
+
+lemma numseg_dimindex_nonempty: "\<exists>i. i \<in> (UNIV :: 'n set)"
+ by auto
+
+lemma infnorm_set_image:
+ "{abs(x$i) |i. i\<in> (UNIV :: 'n set)} =
+ (\<lambda>i. abs(x$i)) ` (UNIV :: 'n set)" by blast
+
+lemma infnorm_set_lemma:
+ shows "finite {abs((x::'a::abs ^'n::finite)$i) |i. i\<in> (UNIV :: 'n set)}"
+ and "{abs(x$i) |i. i\<in> (UNIV :: 'n::finite set)} \<noteq> {}"
+ unfolding infnorm_set_image
+ by (auto intro: finite_imageI)
+
+lemma infnorm_pos_le: "0 \<le> infnorm (x::real^'n::finite)"
+ unfolding infnorm_def
+ unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
+ unfolding infnorm_set_image
+ by auto
+
+lemma infnorm_triangle: "infnorm ((x::real^'n::finite) + y) \<le> infnorm x + infnorm y"
+proof-
+ have th: "\<And>x y (z::real). x - y <= z \<longleftrightarrow> x - z <= y" by arith
+ have th1: "\<And>S f. f ` S = { f i| i. i \<in> S}" by blast
+ have th2: "\<And>x (y::real). abs(x + y) - abs(x) <= abs(y)" by arith
+ show ?thesis
+ unfolding infnorm_def
+ unfolding Sup_finite_le_iff[ OF infnorm_set_lemma]
+ apply (subst diff_le_eq[symmetric])
+ unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
+ unfolding infnorm_set_image bex_simps
+ apply (subst th)
+ unfolding th1
+ unfolding Sup_finite_ge_iff[ OF infnorm_set_lemma]
+
+ unfolding infnorm_set_image ball_simps bex_simps
+ apply simp
+ apply (metis th2)
+ done
+qed
+
+lemma infnorm_eq_0: "infnorm x = 0 \<longleftrightarrow> (x::real ^'n::finite) = 0"
+proof-
+ have "infnorm x <= 0 \<longleftrightarrow> x = 0"
+ unfolding infnorm_def
+ unfolding Sup_finite_le_iff[OF infnorm_set_lemma]
+ unfolding infnorm_set_image ball_simps
+ by vector
+ then show ?thesis using infnorm_pos_le[of x] by simp
+qed
+
+lemma infnorm_0: "infnorm 0 = 0"
+ by (simp add: infnorm_eq_0)
+
+lemma infnorm_neg: "infnorm (- x) = infnorm x"
+ unfolding infnorm_def
+ apply (rule cong[of "Sup" "Sup"])
+ apply blast
+ apply (rule set_ext)
+ apply auto
+ done
+
+lemma infnorm_sub: "infnorm (x - y) = infnorm (y - x)"
+proof-
+ have "y - x = - (x - y)" by simp
+ then show ?thesis by (metis infnorm_neg)
+qed
+
+lemma real_abs_sub_infnorm: "\<bar> infnorm x - infnorm y\<bar> \<le> infnorm (x - y)"
+proof-
+ have th: "\<And>(nx::real) n ny. nx <= n + ny \<Longrightarrow> ny <= n + nx ==> \<bar>nx - ny\<bar> <= n"
+ by arith
+ from infnorm_triangle[of "x - y" " y"] infnorm_triangle[of "x - y" "-x"]
+ have ths: "infnorm x \<le> infnorm (x - y) + infnorm y"
+ "infnorm y \<le> infnorm (x - y) + infnorm x"
+ by (simp_all add: ring_simps infnorm_neg diff_def[symmetric])
+ from th[OF ths] show ?thesis .
+qed
+
+lemma real_abs_infnorm: " \<bar>infnorm x\<bar> = infnorm x"
+ using infnorm_pos_le[of x] by arith
+
+lemma component_le_infnorm:
+ shows "\<bar>x$i\<bar> \<le> infnorm (x::real^'n::finite)"
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?S = "{\<bar>x$i\<bar> |i. i\<in> ?U}"
+ have fS: "finite ?S" unfolding image_Collect[symmetric]
+ apply (rule finite_imageI) unfolding Collect_def mem_def by simp
+ have S0: "?S \<noteq> {}" by blast
+ have th1: "\<And>S f. f ` S = { f i| i. i \<in> S}" by blast
+ from Sup_finite_in[OF fS S0]
+ show ?thesis unfolding infnorm_def infnorm_set_image
+ by (metis Sup_finite_ge_iff finite finite_imageI UNIV_not_empty image_is_empty
+ rangeI real_le_refl)
+qed
+
+lemma infnorm_mul_lemma: "infnorm(a *s x) <= \<bar>a\<bar> * infnorm x"
+ apply (subst infnorm_def)
+ unfolding Sup_finite_le_iff[OF infnorm_set_lemma]
+ unfolding infnorm_set_image ball_simps
+ apply (simp add: abs_mult)
+ apply (rule allI)
+ apply (cut_tac component_le_infnorm[of x])
+ apply (rule mult_mono)
+ apply auto
+ done
+
+lemma infnorm_mul: "infnorm(a *s x) = abs a * infnorm x"
+proof-
+ {assume a0: "a = 0" hence ?thesis by (simp add: infnorm_0) }
+ moreover
+ {assume a0: "a \<noteq> 0"
+ from a0 have th: "(1/a) *s (a *s x) = x"
+ by (simp add: vector_smult_assoc)
+ from a0 have ap: "\<bar>a\<bar> > 0" by arith
+ from infnorm_mul_lemma[of "1/a" "a *s x"]
+ have "infnorm x \<le> 1/\<bar>a\<bar> * infnorm (a*s x)"
+ unfolding th by simp
+ with ap have "\<bar>a\<bar> * infnorm x \<le> \<bar>a\<bar> * (1/\<bar>a\<bar> * infnorm (a *s x))" by (simp add: field_simps)
+ then have "\<bar>a\<bar> * infnorm x \<le> infnorm (a*s x)"
+ using ap by (simp add: field_simps)
+ with infnorm_mul_lemma[of a x] have ?thesis by arith }
+ ultimately show ?thesis by blast
+qed
+
+lemma infnorm_pos_lt: "infnorm x > 0 \<longleftrightarrow> x \<noteq> 0"
+ using infnorm_pos_le[of x] infnorm_eq_0[of x] by arith
+
+(* Prove that it differs only up to a bound from Euclidean norm. *)
+
+lemma infnorm_le_norm: "infnorm x \<le> norm x"
+ unfolding infnorm_def Sup_finite_le_iff[OF infnorm_set_lemma]
+ unfolding infnorm_set_image ball_simps
+ by (metis component_le_norm)
+lemma card_enum: "card {1 .. n} = n" by auto
+lemma norm_le_infnorm: "norm(x) <= sqrt(real CARD('n)) * infnorm(x::real ^'n::finite)"
+proof-
+ let ?d = "CARD('n)"
+ have "real ?d \<ge> 0" by simp
+ hence d2: "(sqrt (real ?d))^2 = real ?d"
+ by (auto intro: real_sqrt_pow2)
+ have th: "sqrt (real ?d) * infnorm x \<ge> 0"
+ by (simp add: zero_le_mult_iff real_sqrt_ge_0_iff infnorm_pos_le)
+ have th1: "x\<bullet>x \<le> (sqrt (real ?d) * infnorm x)^2"
+ unfolding power_mult_distrib d2
+ apply (subst power2_abs[symmetric])
+ unfolding real_of_nat_def dot_def power2_eq_square[symmetric]
+ apply (subst power2_abs[symmetric])
+ apply (rule setsum_bounded)
+ apply (rule power_mono)
+ unfolding abs_of_nonneg[OF infnorm_pos_le]
+ unfolding infnorm_def Sup_finite_ge_iff[OF infnorm_set_lemma]
+ unfolding infnorm_set_image bex_simps
+ apply blast
+ by (rule abs_ge_zero)
+ from real_le_lsqrt[OF dot_pos_le th th1]
+ show ?thesis unfolding real_vector_norm_def id_def .
+qed
+
+(* Equality in Cauchy-Schwarz and triangle inequalities. *)
+
+lemma norm_cauchy_schwarz_eq: "(x::real ^'n::finite) \<bullet> y = norm x * norm y \<longleftrightarrow> norm x *s y = norm y *s x" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume h: "x = 0"
+ hence ?thesis by simp}
+ moreover
+ {assume h: "y = 0"
+ hence ?thesis by simp}
+ moreover
+ {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
+ from dot_eq_0[of "norm y *s x - norm x *s y"]
+ have "?rhs \<longleftrightarrow> (norm y * (norm y * norm x * norm x - norm x * (x \<bullet> y)) - norm x * (norm y * (y \<bullet> x) - norm x * norm y * norm y) = 0)"
+ using x y
+ unfolding dot_rsub dot_lsub dot_lmult dot_rmult
+ unfolding norm_pow_2[symmetric] power2_eq_square diff_eq_0_iff_eq apply (simp add: dot_sym)
+ apply (simp add: ring_simps)
+ apply metis
+ done
+ also have "\<dots> \<longleftrightarrow> (2 * norm x * norm y * (norm x * norm y - x \<bullet> y) = 0)" using x y
+ by (simp add: ring_simps dot_sym)
+ also have "\<dots> \<longleftrightarrow> ?lhs" using x y
+ apply simp
+ by metis
+ finally have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma norm_cauchy_schwarz_abs_eq:
+ fixes x y :: "real ^ 'n::finite"
+ shows "abs(x \<bullet> y) = norm x * norm y \<longleftrightarrow>
+ norm x *s y = norm y *s x \<or> norm(x) *s y = - norm y *s x" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ have th: "\<And>(x::real) a. a \<ge> 0 \<Longrightarrow> abs x = a \<longleftrightarrow> x = a \<or> x = - a" by arith
+ have "?rhs \<longleftrightarrow> norm x *s y = norm y *s x \<or> norm (- x) *s y = norm y *s (- x)"
+ apply simp by vector
+ also have "\<dots> \<longleftrightarrow>(x \<bullet> y = norm x * norm y \<or>
+ (-x) \<bullet> y = norm x * norm y)"
+ unfolding norm_cauchy_schwarz_eq[symmetric]
+ unfolding norm_minus_cancel
+ norm_mul by blast
+ also have "\<dots> \<longleftrightarrow> ?lhs"
+ unfolding th[OF mult_nonneg_nonneg, OF norm_ge_zero[of x] norm_ge_zero[of y]] dot_lneg
+ by arith
+ finally show ?thesis ..
+qed
+
+lemma norm_triangle_eq:
+ fixes x y :: "real ^ 'n::finite"
+ shows "norm(x + y) = norm x + norm y \<longleftrightarrow> norm x *s y = norm y *s x"
+proof-
+ {assume x: "x =0 \<or> y =0"
+ hence ?thesis by (cases "x=0", simp_all)}
+ moreover
+ {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
+ hence "norm x \<noteq> 0" "norm y \<noteq> 0"
+ by simp_all
+ hence n: "norm x > 0" "norm y > 0"
+ using norm_ge_zero[of x] norm_ge_zero[of y]
+ by arith+
+ have th: "\<And>(a::real) b c. a + b + c \<noteq> 0 ==> (a = b + c \<longleftrightarrow> a^2 = (b + c)^2)" by algebra
+ have "norm(x + y) = norm x + norm y \<longleftrightarrow> norm(x + y)^ 2 = (norm x + norm y) ^2"
+ apply (rule th) using n norm_ge_zero[of "x + y"]
+ by arith
+ also have "\<dots> \<longleftrightarrow> norm x *s y = norm y *s x"
+ unfolding norm_cauchy_schwarz_eq[symmetric]
+ unfolding norm_pow_2 dot_ladd dot_radd
+ by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym ring_simps)
+ finally have ?thesis .}
+ ultimately show ?thesis by blast
+qed
+
+(* Collinearity.*)
+
+definition "collinear S \<longleftrightarrow> (\<exists>u. \<forall>x \<in> S. \<forall> y \<in> S. \<exists>c. x - y = c *s u)"
+
+lemma collinear_empty: "collinear {}" by (simp add: collinear_def)
+
+lemma collinear_sing: "collinear {(x::'a::ring_1^'n)}"
+ apply (simp add: collinear_def)
+ apply (rule exI[where x=0])
+ by simp
+
+lemma collinear_2: "collinear {(x::'a::ring_1^'n),y}"
+ apply (simp add: collinear_def)
+ apply (rule exI[where x="x - y"])
+ apply auto
+ apply (rule exI[where x=0], simp)
+ apply (rule exI[where x=1], simp)
+ apply (rule exI[where x="- 1"], simp add: vector_sneg_minus1[symmetric])
+ apply (rule exI[where x=0], simp)
+ done
+
+lemma collinear_lemma: "collinear {(0::real^'n),x,y} \<longleftrightarrow> x = 0 \<or> y = 0 \<or> (\<exists>c. y = c *s x)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume "x=0 \<or> y = 0" hence ?thesis
+ by (cases "x = 0", simp_all add: collinear_2 insert_commute)}
+ moreover
+ {assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
+ {assume h: "?lhs"
+ then obtain u where u: "\<forall> x\<in> {0,x,y}. \<forall>y\<in> {0,x,y}. \<exists>c. x - y = c *s u" unfolding collinear_def by blast
+ from u[rule_format, of x 0] u[rule_format, of y 0]
+ obtain cx and cy where
+ cx: "x = cx*s u" and cy: "y = cy*s u"
+ by auto
+ from cx x have cx0: "cx \<noteq> 0" by auto
+ from cy y have cy0: "cy \<noteq> 0" by auto
+ let ?d = "cy / cx"
+ from cx cy cx0 have "y = ?d *s x"
+ by (simp add: vector_smult_assoc)
+ hence ?rhs using x y by blast}
+ moreover
+ {assume h: "?rhs"
+ then obtain c where c: "y = c*s x" using x y by blast
+ have ?lhs unfolding collinear_def c
+ apply (rule exI[where x=x])
+ apply auto
+ apply (rule exI[where x="- 1"], simp only: vector_smult_lneg vector_smult_lid)
+ apply (rule exI[where x= "-c"], simp only: vector_smult_lneg)
+ apply (rule exI[where x=1], simp)
+ apply (rule exI[where x="1 - c"], simp add: vector_smult_lneg vector_sub_rdistrib)
+ apply (rule exI[where x="c - 1"], simp add: vector_smult_lneg vector_sub_rdistrib)
+ done}
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma norm_cauchy_schwarz_equal:
+ fixes x y :: "real ^ 'n::finite"
+ shows "abs(x \<bullet> y) = norm x * norm y \<longleftrightarrow> collinear {(0::real^'n),x,y}"
+unfolding norm_cauchy_schwarz_abs_eq
+apply (cases "x=0", simp_all add: collinear_2)
+apply (cases "y=0", simp_all add: collinear_2 insert_commute)
+unfolding collinear_lemma
+apply simp
+apply (subgoal_tac "norm x \<noteq> 0")
+apply (subgoal_tac "norm y \<noteq> 0")
+apply (rule iffI)
+apply (cases "norm x *s y = norm y *s x")
+apply (rule exI[where x="(1/norm x) * norm y"])
+apply (drule sym)
+unfolding vector_smult_assoc[symmetric]
+apply (simp add: vector_smult_assoc field_simps)
+apply (rule exI[where x="(1/norm x) * - norm y"])
+apply clarify
+apply (drule sym)
+unfolding vector_smult_assoc[symmetric]
+apply (simp add: vector_smult_assoc field_simps)
+apply (erule exE)
+apply (erule ssubst)
+unfolding vector_smult_assoc
+unfolding norm_mul
+apply (subgoal_tac "norm x * c = \<bar>c\<bar> * norm x \<or> norm x * c = - \<bar>c\<bar> * norm x")
+apply (case_tac "c <= 0", simp add: ring_simps)
+apply (simp add: ring_simps)
+apply (case_tac "c <= 0", simp add: ring_simps)
+apply (simp add: ring_simps)
+apply simp
+apply simp
+done
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,95 @@
+(* Title: HOL/Library/Finite_Cartesian_Product
+ Author: Amine Chaieb, University of Cambridge
+*)
+
+header {* Definition of finite Cartesian product types. *}
+
+theory Finite_Cartesian_Product
+imports Main (*FIXME: ATP_Linkup is only needed for metis at a few places. We could dispense of that by changing the proofs.*)
+begin
+
+definition hassize (infixr "hassize" 12) where
+ "(S hassize n) = (finite S \<and> card S = n)"
+
+lemma hassize_image_inj: assumes f: "inj_on f S" and S: "S hassize n"
+ shows "f ` S hassize n"
+ using f S card_image[OF f]
+ by (simp add: hassize_def inj_on_def)
+
+
+subsection {* Finite Cartesian products, with indexing and lambdas. *}
+
+typedef (open Cart)
+ ('a, 'b) "^" (infixl "^" 15)
+ = "UNIV :: ('b \<Rightarrow> 'a) set"
+ morphisms Cart_nth Cart_lambda ..
+
+notation Cart_nth (infixl "$" 90)
+
+notation (xsymbols) Cart_lambda (binder "\<chi>" 10)
+
+lemma stupid_ext: "(\<forall>x. f x = g x) \<longleftrightarrow> (f = g)"
+ apply auto
+ apply (rule ext)
+ apply auto
+ done
+
+lemma Cart_eq: "((x:: 'a ^ 'b) = y) \<longleftrightarrow> (\<forall>i. x$i = y$i)"
+ by (simp add: Cart_nth_inject [symmetric] expand_fun_eq)
+
+lemma Cart_lambda_beta [simp]: "Cart_lambda g $ i = g i"
+ by (simp add: Cart_lambda_inverse)
+
+lemma Cart_lambda_unique:
+ fixes f :: "'a ^ 'b"
+ shows "(\<forall>i. f$i = g i) \<longleftrightarrow> Cart_lambda g = f"
+ by (auto simp add: Cart_eq)
+
+lemma Cart_lambda_eta: "(\<chi> i. (g$i)) = g"
+ by (simp add: Cart_eq)
+
+text{* A non-standard sum to "paste" Cartesian products. *}
+
+definition pastecart :: "'a ^ 'm \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a ^ ('m + 'n)" where
+ "pastecart f g = (\<chi> i. case i of Inl a \<Rightarrow> f$a | Inr b \<Rightarrow> g$b)"
+
+definition fstcart:: "'a ^('m + 'n) \<Rightarrow> 'a ^ 'm" where
+ "fstcart f = (\<chi> i. (f$(Inl i)))"
+
+definition sndcart:: "'a ^('m + 'n) \<Rightarrow> 'a ^ 'n" where
+ "sndcart f = (\<chi> i. (f$(Inr i)))"
+
+lemma nth_pastecart_Inl [simp]: "pastecart f g $ Inl a = f$a"
+ unfolding pastecart_def by simp
+
+lemma nth_pastecart_Inr [simp]: "pastecart f g $ Inr b = g$b"
+ unfolding pastecart_def by simp
+
+lemma nth_fstcart [simp]: "fstcart f $ i = f $ Inl i"
+ unfolding fstcart_def by simp
+
+lemma nth_sndtcart [simp]: "sndcart f $ i = f $ Inr i"
+ unfolding sndcart_def by simp
+
+lemma finite_sum_image: "(UNIV::('a + 'b) set) = range Inl \<union> range Inr"
+by (auto, case_tac x, auto)
+
+lemma fstcart_pastecart: "fstcart (pastecart (x::'a ^'m ) (y:: 'a ^ 'n)) = x"
+ by (simp add: Cart_eq)
+
+lemma sndcart_pastecart: "sndcart (pastecart (x::'a ^'m ) (y:: 'a ^ 'n)) = y"
+ by (simp add: Cart_eq)
+
+lemma pastecart_fst_snd: "pastecart (fstcart z) (sndcart z) = z"
+ by (simp add: Cart_eq pastecart_def fstcart_def sndcart_def split: sum.split)
+
+lemma pastecart_eq: "(x = y) \<longleftrightarrow> (fstcart x = fstcart y) \<and> (sndcart x = sndcart y)"
+ using pastecart_fst_snd[of x] pastecart_fst_snd[of y] by metis
+
+lemma forall_pastecart: "(\<forall>p. P p) \<longleftrightarrow> (\<forall>x y. P (pastecart x y))"
+ by (metis pastecart_fst_snd fstcart_pastecart sndcart_pastecart)
+
+lemma exists_pastecart: "(\<exists>p. P p) \<longleftrightarrow> (\<exists>x y. P (pastecart x y))"
+ by (metis pastecart_fst_snd fstcart_pastecart sndcart_pastecart)
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Multivariate_Analysis.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,6 @@
+theory Multivariate_Analysis imports
+ Convex_Euclidean_Space
+ Determinants
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/ROOT.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,6 @@
+(*
+ no_document use_thy "ThisTheory";
+ use_thy "ThatTheory";
+*)
+
+use_thy "Multivariate_Analysis";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,6014 @@
+(* Title: HOL/Library/Topology_Euclidian_Space.thy
+ Author: Amine Chaieb, University of Cambridge
+ Author: Robert Himmelmann, TU Muenchen
+*)
+
+header {* Elementary topology in Euclidean space. *}
+
+theory Topology_Euclidean_Space
+imports SEQ Euclidean_Space Product_Vector
+begin
+
+declare fstcart_pastecart[simp] sndcart_pastecart[simp]
+
+subsection{* General notion of a topology *}
+
+definition "istopology L \<longleftrightarrow> {} \<in> L \<and> (\<forall>S \<in>L. \<forall>T \<in>L. S \<inter> T \<in> L) \<and> (\<forall>K. K \<subseteq>L \<longrightarrow> \<Union> K \<in> L)"
+typedef (open) 'a topology = "{L::('a set) set. istopology L}"
+ morphisms "openin" "topology"
+ unfolding istopology_def by blast
+
+lemma istopology_open_in[intro]: "istopology(openin U)"
+ using openin[of U] by blast
+
+lemma topology_inverse': "istopology U \<Longrightarrow> openin (topology U) = U"
+ using topology_inverse[unfolded mem_def Collect_def] .
+
+lemma topology_inverse_iff: "istopology U \<longleftrightarrow> openin (topology U) = U"
+ using topology_inverse[of U] istopology_open_in[of "topology U"] by auto
+
+lemma topology_eq: "T1 = T2 \<longleftrightarrow> (\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S)"
+proof-
+ {assume "T1=T2" hence "\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S" by simp}
+ moreover
+ {assume H: "\<forall>S. openin T1 S \<longleftrightarrow> openin T2 S"
+ hence "openin T1 = openin T2" by (metis mem_def set_ext)
+ hence "topology (openin T1) = topology (openin T2)" by simp
+ hence "T1 = T2" unfolding openin_inverse .}
+ ultimately show ?thesis by blast
+qed
+
+text{* Infer the "universe" from union of all sets in the topology. *}
+
+definition "topspace T = \<Union>{S. openin T S}"
+
+subsection{* Main properties of open sets *}
+
+lemma openin_clauses:
+ fixes U :: "'a topology"
+ shows "openin U {}"
+ "\<And>S T. openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S\<inter>T)"
+ "\<And>K. (\<forall>S \<in> K. openin U S) \<Longrightarrow> openin U (\<Union>K)"
+ using openin[of U] unfolding istopology_def Collect_def mem_def
+ by (metis mem_def subset_eq)+
+
+lemma openin_subset[intro]: "openin U S \<Longrightarrow> S \<subseteq> topspace U"
+ unfolding topspace_def by blast
+lemma openin_empty[simp]: "openin U {}" by (simp add: openin_clauses)
+
+lemma openin_Int[intro]: "openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S \<inter> T)"
+ by (simp add: openin_clauses)
+
+lemma openin_Union[intro]: "(\<forall>S \<in>K. openin U S) \<Longrightarrow> openin U (\<Union> K)" by (simp add: openin_clauses)
+
+lemma openin_Un[intro]: "openin U S \<Longrightarrow> openin U T \<Longrightarrow> openin U (S \<union> T)"
+ using openin_Union[of "{S,T}" U] by auto
+
+lemma openin_topspace[intro, simp]: "openin U (topspace U)" by (simp add: openin_Union topspace_def)
+
+lemma openin_subopen: "openin U S \<longleftrightarrow> (\<forall>x \<in> S. \<exists>T. openin U T \<and> x \<in> T \<and> T \<subseteq> S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume ?lhs then have ?rhs by auto }
+ moreover
+ {assume H: ?rhs
+ then obtain t where t: "\<forall>x\<in>S. openin U (t x) \<and> x \<in> t x \<and> t x \<subseteq> S"
+ unfolding Ball_def ex_simps(6)[symmetric] choice_iff by blast
+ from t have th0: "\<forall>x\<in> t`S. openin U x" by auto
+ have "\<Union> t`S = S" using t by auto
+ with openin_Union[OF th0] have "openin U S" by simp }
+ ultimately show ?thesis by blast
+qed
+
+subsection{* Closed sets *}
+
+definition "closedin U S \<longleftrightarrow> S \<subseteq> topspace U \<and> openin U (topspace U - S)"
+
+lemma closedin_subset: "closedin U S \<Longrightarrow> S \<subseteq> topspace U" by (metis closedin_def)
+lemma closedin_empty[simp]: "closedin U {}" by (simp add: closedin_def)
+lemma closedin_topspace[intro,simp]:
+ "closedin U (topspace U)" by (simp add: closedin_def)
+lemma closedin_Un[intro]: "closedin U S \<Longrightarrow> closedin U T \<Longrightarrow> closedin U (S \<union> T)"
+ by (auto simp add: Diff_Un closedin_def)
+
+lemma Diff_Inter[intro]: "A - \<Inter>S = \<Union> {A - s|s. s\<in>S}" by auto
+lemma closedin_Inter[intro]: assumes Ke: "K \<noteq> {}" and Kc: "\<forall>S \<in>K. closedin U S"
+ shows "closedin U (\<Inter> K)" using Ke Kc unfolding closedin_def Diff_Inter by auto
+
+lemma closedin_Int[intro]: "closedin U S \<Longrightarrow> closedin U T \<Longrightarrow> closedin U (S \<inter> T)"
+ using closedin_Inter[of "{S,T}" U] by auto
+
+lemma Diff_Diff_Int: "A - (A - B) = A \<inter> B" by blast
+lemma openin_closedin_eq: "openin U S \<longleftrightarrow> S \<subseteq> topspace U \<and> closedin U (topspace U - S)"
+ apply (auto simp add: closedin_def Diff_Diff_Int inf_absorb2)
+ apply (metis openin_subset subset_eq)
+ done
+
+lemma openin_closedin: "S \<subseteq> topspace U \<Longrightarrow> (openin U S \<longleftrightarrow> closedin U (topspace U - S))"
+ by (simp add: openin_closedin_eq)
+
+lemma openin_diff[intro]: assumes oS: "openin U S" and cT: "closedin U T" shows "openin U (S - T)"
+proof-
+ have "S - T = S \<inter> (topspace U - T)" using openin_subset[of U S] oS cT
+ by (auto simp add: topspace_def openin_subset)
+ then show ?thesis using oS cT by (auto simp add: closedin_def)
+qed
+
+lemma closedin_diff[intro]: assumes oS: "closedin U S" and cT: "openin U T" shows "closedin U (S - T)"
+proof-
+ have "S - T = S \<inter> (topspace U - T)" using closedin_subset[of U S] oS cT
+ by (auto simp add: topspace_def )
+ then show ?thesis using oS cT by (auto simp add: openin_closedin_eq)
+qed
+
+subsection{* Subspace topology. *}
+
+definition "subtopology U V = topology {S \<inter> V |S. openin U S}"
+
+lemma istopology_subtopology: "istopology {S \<inter> V |S. openin U S}" (is "istopology ?L")
+proof-
+ have "{} \<in> ?L" by blast
+ {fix A B assume A: "A \<in> ?L" and B: "B \<in> ?L"
+ from A B obtain Sa and Sb where Sa: "openin U Sa" "A = Sa \<inter> V" and Sb: "openin U Sb" "B = Sb \<inter> V" by blast
+ have "A\<inter>B = (Sa \<inter> Sb) \<inter> V" "openin U (Sa \<inter> Sb)" using Sa Sb by blast+
+ then have "A \<inter> B \<in> ?L" by blast}
+ moreover
+ {fix K assume K: "K \<subseteq> ?L"
+ have th0: "?L = (\<lambda>S. S \<inter> V) ` openin U "
+ apply (rule set_ext)
+ apply (simp add: Ball_def image_iff)
+ by (metis mem_def)
+ from K[unfolded th0 subset_image_iff]
+ obtain Sk where Sk: "Sk \<subseteq> openin U" "K = (\<lambda>S. S \<inter> V) ` Sk" by blast
+ have "\<Union>K = (\<Union>Sk) \<inter> V" using Sk by auto
+ moreover have "openin U (\<Union> Sk)" using Sk by (auto simp add: subset_eq mem_def)
+ ultimately have "\<Union>K \<in> ?L" by blast}
+ ultimately show ?thesis unfolding istopology_def by blast
+qed
+
+lemma openin_subtopology:
+ "openin (subtopology U V) S \<longleftrightarrow> (\<exists> T. (openin U T) \<and> (S = T \<inter> V))"
+ unfolding subtopology_def topology_inverse'[OF istopology_subtopology]
+ by (auto simp add: Collect_def)
+
+lemma topspace_subtopology: "topspace(subtopology U V) = topspace U \<inter> V"
+ by (auto simp add: topspace_def openin_subtopology)
+
+lemma closedin_subtopology:
+ "closedin (subtopology U V) S \<longleftrightarrow> (\<exists>T. closedin U T \<and> S = T \<inter> V)"
+ unfolding closedin_def topspace_subtopology
+ apply (simp add: openin_subtopology)
+ apply (rule iffI)
+ apply clarify
+ apply (rule_tac x="topspace U - T" in exI)
+ by auto
+
+lemma openin_subtopology_refl: "openin (subtopology U V) V \<longleftrightarrow> V \<subseteq> topspace U"
+ unfolding openin_subtopology
+ apply (rule iffI, clarify)
+ apply (frule openin_subset[of U]) apply blast
+ apply (rule exI[where x="topspace U"])
+ by auto
+
+lemma subtopology_superset: assumes UV: "topspace U \<subseteq> V"
+ shows "subtopology U V = U"
+proof-
+ {fix S
+ {fix T assume T: "openin U T" "S = T \<inter> V"
+ from T openin_subset[OF T(1)] UV have eq: "S = T" by blast
+ have "openin U S" unfolding eq using T by blast}
+ moreover
+ {assume S: "openin U S"
+ hence "\<exists>T. openin U T \<and> S = T \<inter> V"
+ using openin_subset[OF S] UV by auto}
+ ultimately have "(\<exists>T. openin U T \<and> S = T \<inter> V) \<longleftrightarrow> openin U S" by blast}
+ then show ?thesis unfolding topology_eq openin_subtopology by blast
+qed
+
+
+lemma subtopology_topspace[simp]: "subtopology U (topspace U) = U"
+ by (simp add: subtopology_superset)
+
+lemma subtopology_UNIV[simp]: "subtopology U UNIV = U"
+ by (simp add: subtopology_superset)
+
+subsection{* The universal Euclidean versions are what we use most of the time *}
+
+definition
+ euclidean :: "'a::topological_space topology" where
+ "euclidean = topology open"
+
+lemma open_openin: "open S \<longleftrightarrow> openin euclidean S"
+ unfolding euclidean_def
+ apply (rule cong[where x=S and y=S])
+ apply (rule topology_inverse[symmetric])
+ apply (auto simp add: istopology_def)
+ by (auto simp add: mem_def subset_eq)
+
+lemma topspace_euclidean: "topspace euclidean = UNIV"
+ apply (simp add: topspace_def)
+ apply (rule set_ext)
+ by (auto simp add: open_openin[symmetric])
+
+lemma topspace_euclidean_subtopology[simp]: "topspace (subtopology euclidean S) = S"
+ by (simp add: topspace_euclidean topspace_subtopology)
+
+lemma closed_closedin: "closed S \<longleftrightarrow> closedin euclidean S"
+ by (simp add: closed_def closedin_def topspace_euclidean open_openin Compl_eq_Diff_UNIV)
+
+lemma open_subopen: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S)"
+ by (simp add: open_openin openin_subopen[symmetric])
+
+subsection{* Open and closed balls. *}
+
+definition
+ ball :: "'a::metric_space \<Rightarrow> real \<Rightarrow> 'a set" where
+ "ball x e = {y. dist x y < e}"
+
+definition
+ cball :: "'a::metric_space \<Rightarrow> real \<Rightarrow> 'a set" where
+ "cball x e = {y. dist x y \<le> e}"
+
+lemma mem_ball[simp]: "y \<in> ball x e \<longleftrightarrow> dist x y < e" by (simp add: ball_def)
+lemma mem_cball[simp]: "y \<in> cball x e \<longleftrightarrow> dist x y \<le> e" by (simp add: cball_def)
+
+lemma mem_ball_0 [simp]:
+ fixes x :: "'a::real_normed_vector"
+ shows "x \<in> ball 0 e \<longleftrightarrow> norm x < e"
+ by (simp add: dist_norm)
+
+lemma mem_cball_0 [simp]:
+ fixes x :: "'a::real_normed_vector"
+ shows "x \<in> cball 0 e \<longleftrightarrow> norm x \<le> e"
+ by (simp add: dist_norm)
+
+lemma centre_in_cball[simp]: "x \<in> cball x e \<longleftrightarrow> 0\<le> e" by simp
+lemma ball_subset_cball[simp,intro]: "ball x e \<subseteq> cball x e" by (simp add: subset_eq)
+lemma subset_ball[intro]: "d <= e ==> ball x d \<subseteq> ball x e" by (simp add: subset_eq)
+lemma subset_cball[intro]: "d <= e ==> cball x d \<subseteq> cball x e" by (simp add: subset_eq)
+lemma ball_max_Un: "ball a (max r s) = ball a r \<union> ball a s"
+ by (simp add: expand_set_eq) arith
+
+lemma ball_min_Int: "ball a (min r s) = ball a r \<inter> ball a s"
+ by (simp add: expand_set_eq)
+
+subsection{* Topological properties of open balls *}
+
+lemma diff_less_iff: "(a::real) - b > 0 \<longleftrightarrow> a > b"
+ "(a::real) - b < 0 \<longleftrightarrow> a < b"
+ "a - b < c \<longleftrightarrow> a < c +b" "a - b > c \<longleftrightarrow> a > c +b" by arith+
+lemma diff_le_iff: "(a::real) - b \<ge> 0 \<longleftrightarrow> a \<ge> b" "(a::real) - b \<le> 0 \<longleftrightarrow> a \<le> b"
+ "a - b \<le> c \<longleftrightarrow> a \<le> c +b" "a - b \<ge> c \<longleftrightarrow> a \<ge> c +b" by arith+
+
+lemma open_ball[intro, simp]: "open (ball x e)"
+ unfolding open_dist ball_def Collect_def Ball_def mem_def
+ unfolding dist_commute
+ apply clarify
+ apply (rule_tac x="e - dist xa x" in exI)
+ using dist_triangle_alt[where z=x]
+ apply (clarsimp simp add: diff_less_iff)
+ apply atomize
+ apply (erule_tac x="y" in allE)
+ apply (erule_tac x="xa" in allE)
+ by arith
+
+lemma centre_in_ball[simp]: "x \<in> ball x e \<longleftrightarrow> e > 0" by (metis mem_ball dist_self)
+lemma open_contains_ball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. ball x e \<subseteq> S)"
+ unfolding open_dist subset_eq mem_ball Ball_def dist_commute ..
+
+lemma open_contains_ball_eq: "open S \<Longrightarrow> \<forall>x. x\<in>S \<longleftrightarrow> (\<exists>e>0. ball x e \<subseteq> S)"
+ by (metis open_contains_ball subset_eq centre_in_ball)
+
+lemma ball_eq_empty[simp]: "ball x e = {} \<longleftrightarrow> e \<le> 0"
+ unfolding mem_ball expand_set_eq
+ apply (simp add: not_less)
+ by (metis zero_le_dist order_trans dist_self)
+
+lemma ball_empty[intro]: "e \<le> 0 ==> ball x e = {}" by simp
+
+subsection{* Basic "localization" results are handy for connectedness. *}
+
+lemma openin_open: "openin (subtopology euclidean U) S \<longleftrightarrow> (\<exists>T. open T \<and> (S = U \<inter> T))"
+ by (auto simp add: openin_subtopology open_openin[symmetric])
+
+lemma openin_open_Int[intro]: "open S \<Longrightarrow> openin (subtopology euclidean U) (U \<inter> S)"
+ by (auto simp add: openin_open)
+
+lemma open_openin_trans[trans]:
+ "open S \<Longrightarrow> open T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> openin (subtopology euclidean S) T"
+ by (metis Int_absorb1 openin_open_Int)
+
+lemma open_subset: "S \<subseteq> T \<Longrightarrow> open S \<Longrightarrow> openin (subtopology euclidean T) S"
+ by (auto simp add: openin_open)
+
+lemma closedin_closed: "closedin (subtopology euclidean U) S \<longleftrightarrow> (\<exists>T. closed T \<and> S = U \<inter> T)"
+ by (simp add: closedin_subtopology closed_closedin Int_ac)
+
+lemma closedin_closed_Int: "closed S ==> closedin (subtopology euclidean U) (U \<inter> S)"
+ by (metis closedin_closed)
+
+lemma closed_closedin_trans: "closed S \<Longrightarrow> closed T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> closedin (subtopology euclidean S) T"
+ apply (subgoal_tac "S \<inter> T = T" )
+ apply auto
+ apply (frule closedin_closed_Int[of T S])
+ by simp
+
+lemma closed_subset: "S \<subseteq> T \<Longrightarrow> closed S \<Longrightarrow> closedin (subtopology euclidean T) S"
+ by (auto simp add: closedin_closed)
+
+lemma openin_euclidean_subtopology_iff:
+ fixes S U :: "'a::metric_space set"
+ shows "openin (subtopology euclidean U) S
+ \<longleftrightarrow> S \<subseteq> U \<and> (\<forall>x\<in>S. \<exists>e>0. \<forall>x'\<in>U. dist x' x < e \<longrightarrow> x'\<in> S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume ?lhs hence ?rhs unfolding openin_subtopology open_openin[symmetric]
+ by (simp add: open_dist) blast}
+ moreover
+ {assume SU: "S \<subseteq> U" and H: "\<And>x. x \<in> S \<Longrightarrow> \<exists>e>0. \<forall>x'\<in>U. dist x' x < e \<longrightarrow> x' \<in> S"
+ from H obtain d where d: "\<And>x . x\<in> S \<Longrightarrow> d x > 0 \<and> (\<forall>x' \<in> U. dist x' x < d x \<longrightarrow> x' \<in> S)"
+ by metis
+ let ?T = "\<Union>{B. \<exists>x\<in>S. B = ball x (d x)}"
+ have oT: "open ?T" by auto
+ { fix x assume "x\<in>S"
+ hence "x \<in> \<Union>{B. \<exists>x\<in>S. B = ball x (d x)}"
+ apply simp apply(rule_tac x="ball x(d x)" in exI) apply auto
+ by (rule d [THEN conjunct1])
+ hence "x\<in> ?T \<inter> U" using SU and `x\<in>S` by auto }
+ moreover
+ { fix y assume "y\<in>?T"
+ then obtain B where "y\<in>B" "B\<in>{B. \<exists>x\<in>S. B = ball x (d x)}" by auto
+ then obtain x where "x\<in>S" and x:"y \<in> ball x (d x)" by auto
+ assume "y\<in>U"
+ hence "y\<in>S" using d[OF `x\<in>S`] and x by(auto simp add: dist_commute) }
+ ultimately have "S = ?T \<inter> U" by blast
+ with oT have ?lhs unfolding openin_subtopology open_openin[symmetric] by blast}
+ ultimately show ?thesis by blast
+qed
+
+text{* These "transitivity" results are handy too. *}
+
+lemma openin_trans[trans]: "openin (subtopology euclidean T) S \<Longrightarrow> openin (subtopology euclidean U) T
+ \<Longrightarrow> openin (subtopology euclidean U) S"
+ unfolding open_openin openin_open by blast
+
+lemma openin_open_trans: "openin (subtopology euclidean T) S \<Longrightarrow> open T \<Longrightarrow> open S"
+ by (auto simp add: openin_open intro: openin_trans)
+
+lemma closedin_trans[trans]:
+ "closedin (subtopology euclidean T) S \<Longrightarrow>
+ closedin (subtopology euclidean U) T
+ ==> closedin (subtopology euclidean U) S"
+ by (auto simp add: closedin_closed closed_closedin closed_Inter Int_assoc)
+
+lemma closedin_closed_trans: "closedin (subtopology euclidean T) S \<Longrightarrow> closed T \<Longrightarrow> closed S"
+ by (auto simp add: closedin_closed intro: closedin_trans)
+
+subsection{* Connectedness *}
+
+definition "connected S \<longleftrightarrow>
+ ~(\<exists>e1 e2. open e1 \<and> open e2 \<and> S \<subseteq> (e1 \<union> e2) \<and> (e1 \<inter> e2 \<inter> S = {})
+ \<and> ~(e1 \<inter> S = {}) \<and> ~(e2 \<inter> S = {}))"
+
+lemma connected_local:
+ "connected S \<longleftrightarrow> ~(\<exists>e1 e2.
+ openin (subtopology euclidean S) e1 \<and>
+ openin (subtopology euclidean S) e2 \<and>
+ S \<subseteq> e1 \<union> e2 \<and>
+ e1 \<inter> e2 = {} \<and>
+ ~(e1 = {}) \<and>
+ ~(e2 = {}))"
+unfolding connected_def openin_open by (safe, blast+)
+
+lemma exists_diff: "(\<exists>S. P(UNIV - S)) \<longleftrightarrow> (\<exists>S. P S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+
+ {assume "?lhs" hence ?rhs by blast }
+ moreover
+ {fix S assume H: "P S"
+ have "S = UNIV - (UNIV - S)" by auto
+ with H have "P (UNIV - (UNIV - S))" by metis }
+ ultimately show ?thesis by metis
+qed
+
+lemma connected_clopen: "connected S \<longleftrightarrow>
+ (\<forall>T. openin (subtopology euclidean S) T \<and>
+ closedin (subtopology euclidean S) T \<longrightarrow> T = {} \<or> T = S)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ have " \<not> connected S \<longleftrightarrow> (\<exists>e1 e2. open e1 \<and> open (UNIV - e2) \<and> S \<subseteq> e1 \<union> (UNIV - e2) \<and> e1 \<inter> (UNIV - e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (UNIV - e2) \<inter> S \<noteq> {})"
+ unfolding connected_def openin_open closedin_closed
+ apply (subst exists_diff) by blast
+ hence th0: "connected S \<longleftrightarrow> \<not> (\<exists>e2 e1. closed e2 \<and> open e1 \<and> S \<subseteq> e1 \<union> (UNIV - e2) \<and> e1 \<inter> (UNIV - e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (UNIV - e2) \<inter> S \<noteq> {})"
+ (is " _ \<longleftrightarrow> \<not> (\<exists>e2 e1. ?P e2 e1)") apply (simp add: closed_def Compl_eq_Diff_UNIV) by metis
+
+ have th1: "?rhs \<longleftrightarrow> \<not> (\<exists>t' t. closed t'\<and>t = S\<inter>t' \<and> t\<noteq>{} \<and> t\<noteq>S \<and> (\<exists>t'. open t' \<and> t = S \<inter> t'))"
+ (is "_ \<longleftrightarrow> \<not> (\<exists>t' t. ?Q t' t)")
+ unfolding connected_def openin_open closedin_closed by auto
+ {fix e2
+ {fix e1 have "?P e2 e1 \<longleftrightarrow> (\<exists>t. closed e2 \<and> t = S\<inter>e2 \<and> open e1 \<and> t = S\<inter>e1 \<and> t\<noteq>{} \<and> t\<noteq>S)"
+ by auto}
+ then have "(\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)" by metis}
+ then have "\<forall>e2. (\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)" by blast
+ then show ?thesis unfolding th0 th1 by simp
+qed
+
+lemma connected_empty[simp, intro]: "connected {}"
+ by (simp add: connected_def)
+
+subsection{* Hausdorff and other separation properties *}
+
+class t0_space =
+ assumes t0_space: "x \<noteq> y \<Longrightarrow> \<exists>U. open U \<and> \<not> (x \<in> U \<longleftrightarrow> y \<in> U)"
+
+class t1_space =
+ assumes t1_space: "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<notin> U \<and> x \<notin> V \<and> y \<in> V"
+begin
+
+subclass t0_space
+proof
+qed (fast dest: t1_space)
+
+end
+
+text {* T2 spaces are also known as Hausdorff spaces. *}
+
+class t2_space =
+ assumes hausdorff: "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
+begin
+
+subclass t1_space
+proof
+qed (fast dest: hausdorff)
+
+end
+
+instance metric_space \<subseteq> t2_space
+proof
+ fix x y :: "'a::metric_space"
+ assume xy: "x \<noteq> y"
+ let ?U = "ball x (dist x y / 2)"
+ let ?V = "ball y (dist x y / 2)"
+ have th0: "\<And>d x y z. (d x z :: real) <= d x y + d y z \<Longrightarrow> d y z = d z y
+ ==> ~(d x y * 2 < d x z \<and> d z y * 2 < d x z)" by arith
+ have "open ?U \<and> open ?V \<and> x \<in> ?U \<and> y \<in> ?V \<and> ?U \<inter> ?V = {}"
+ using dist_pos_lt[OF xy] th0[of dist,OF dist_triangle dist_commute]
+ by (auto simp add: expand_set_eq)
+ then show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
+ by blast
+qed
+
+lemma separation_t2:
+ fixes x y :: "'a::t2_space"
+ shows "x \<noteq> y \<longleftrightarrow> (\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {})"
+ using hausdorff[of x y] by blast
+
+lemma separation_t1:
+ fixes x y :: "'a::t1_space"
+ shows "x \<noteq> y \<longleftrightarrow> (\<exists>U V. open U \<and> open V \<and> x \<in>U \<and> y\<notin> U \<and> x\<notin>V \<and> y\<in>V)"
+ using t1_space[of x y] by blast
+
+lemma separation_t0:
+ fixes x y :: "'a::t0_space"
+ shows "x \<noteq> y \<longleftrightarrow> (\<exists>U. open U \<and> ~(x\<in>U \<longleftrightarrow> y\<in>U))"
+ using t0_space[of x y] by blast
+
+subsection{* Limit points *}
+
+definition
+ islimpt:: "'a::topological_space \<Rightarrow> 'a set \<Rightarrow> bool"
+ (infixr "islimpt" 60) where
+ "x islimpt S \<longleftrightarrow> (\<forall>T. x\<in>T \<longrightarrow> open T \<longrightarrow> (\<exists>y\<in>S. y\<in>T \<and> y\<noteq>x))"
+
+lemma islimptI:
+ assumes "\<And>T. x \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>y\<in>S. y \<in> T \<and> y \<noteq> x"
+ shows "x islimpt S"
+ using assms unfolding islimpt_def by auto
+
+lemma islimptE:
+ assumes "x islimpt S" and "x \<in> T" and "open T"
+ obtains y where "y \<in> S" and "y \<in> T" and "y \<noteq> x"
+ using assms unfolding islimpt_def by auto
+
+lemma islimpt_subset: "x islimpt S \<Longrightarrow> S \<subseteq> T ==> x islimpt T" by (auto simp add: islimpt_def)
+
+lemma islimpt_approachable:
+ fixes x :: "'a::metric_space"
+ shows "x islimpt S \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e)"
+ unfolding islimpt_def
+ apply auto
+ apply(erule_tac x="ball x e" in allE)
+ apply auto
+ apply(rule_tac x=y in bexI)
+ apply (auto simp add: dist_commute)
+ apply (simp add: open_dist, drule (1) bspec)
+ apply (clarify, drule spec, drule (1) mp, auto)
+ done
+
+lemma islimpt_approachable_le:
+ fixes x :: "'a::metric_space"
+ shows "x islimpt S \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in> S. x' \<noteq> x \<and> dist x' x <= e)"
+ unfolding islimpt_approachable
+ using approachable_lt_le[where f="\<lambda>x'. dist x' x" and P="\<lambda>x'. \<not> (x'\<in>S \<and> x'\<noteq>x)"]
+ by metis (* FIXME: VERY slow! *)
+
+class perfect_space =
+ (* FIXME: perfect_space should inherit from topological_space *)
+ assumes islimpt_UNIV [simp, intro]: "(x::'a::metric_space) islimpt UNIV"
+
+lemma perfect_choose_dist:
+ fixes x :: "'a::perfect_space"
+ shows "0 < r \<Longrightarrow> \<exists>a. a \<noteq> x \<and> dist a x < r"
+using islimpt_UNIV [of x]
+by (simp add: islimpt_approachable)
+
+instance real :: perfect_space
+apply default
+apply (rule islimpt_approachable [THEN iffD2])
+apply (clarify, rule_tac x="x + e/2" in bexI)
+apply (auto simp add: dist_norm)
+done
+
+instance "^" :: (perfect_space, finite) perfect_space
+proof
+ fix x :: "'a ^ 'b"
+ {
+ fix e :: real assume "0 < e"
+ def a \<equiv> "x $ undefined"
+ have "a islimpt UNIV" by (rule islimpt_UNIV)
+ with `0 < e` obtain b where "b \<noteq> a" and "dist b a < e"
+ unfolding islimpt_approachable by auto
+ def y \<equiv> "Cart_lambda ((Cart_nth x)(undefined := b))"
+ from `b \<noteq> a` have "y \<noteq> x"
+ unfolding a_def y_def by (simp add: Cart_eq)
+ from `dist b a < e` have "dist y x < e"
+ unfolding dist_vector_def a_def y_def
+ apply simp
+ apply (rule le_less_trans [OF setL2_le_setsum [OF zero_le_dist]])
+ apply (subst setsum_diff1' [where a=undefined], simp, simp, simp)
+ done
+ from `y \<noteq> x` and `dist y x < e`
+ have "\<exists>y\<in>UNIV. y \<noteq> x \<and> dist y x < e" by auto
+ }
+ then show "x islimpt UNIV" unfolding islimpt_approachable by blast
+qed
+
+lemma closed_limpt: "closed S \<longleftrightarrow> (\<forall>x. x islimpt S \<longrightarrow> x \<in> S)"
+ unfolding closed_def
+ apply (subst open_subopen)
+ apply (simp add: islimpt_def subset_eq Compl_eq_Diff_UNIV)
+ by (metis DiffE DiffI UNIV_I insertCI insert_absorb mem_def)
+
+lemma islimpt_EMPTY[simp]: "\<not> x islimpt {}"
+ unfolding islimpt_def by auto
+
+lemma closed_positive_orthant: "closed {x::real^'n::finite. \<forall>i. 0 \<le>x$i}"
+proof-
+ let ?U = "UNIV :: 'n set"
+ let ?O = "{x::real^'n. \<forall>i. x$i\<ge>0}"
+ {fix x:: "real^'n" and i::'n assume H: "\<forall>e>0. \<exists>x'\<in>?O. x' \<noteq> x \<and> dist x' x < e"
+ and xi: "x$i < 0"
+ from xi have th0: "-x$i > 0" by arith
+ from H[rule_format, OF th0] obtain x' where x': "x' \<in>?O" "x' \<noteq> x" "dist x' x < -x $ i" by blast
+ have th:" \<And>b a (x::real). abs x <= b \<Longrightarrow> b <= a ==> ~(a + x < 0)" by arith
+ have th': "\<And>x (y::real). x < 0 \<Longrightarrow> 0 <= y ==> abs x <= abs (y - x)" by arith
+ have th1: "\<bar>x$i\<bar> \<le> \<bar>(x' - x)$i\<bar>" using x'(1) xi
+ apply (simp only: vector_component)
+ by (rule th') auto
+ have th2: "\<bar>dist x x'\<bar> \<ge> \<bar>(x' - x)$i\<bar>" using component_le_norm[of "x'-x" i]
+ apply (simp add: dist_norm) by norm
+ from th[OF th1 th2] x'(3) have False by (simp add: dist_commute) }
+ then show ?thesis unfolding closed_limpt islimpt_approachable
+ unfolding not_le[symmetric] by blast
+qed
+
+lemma finite_set_avoid:
+ fixes a :: "'a::metric_space"
+ assumes fS: "finite S" shows "\<exists>d>0. \<forall>x\<in>S. x \<noteq> a \<longrightarrow> d <= dist a x"
+proof(induct rule: finite_induct[OF fS])
+ case 1 thus ?case apply auto by ferrack
+next
+ case (2 x F)
+ from 2 obtain d where d: "d >0" "\<forall>x\<in>F. x\<noteq>a \<longrightarrow> d \<le> dist a x" by blast
+ {assume "x = a" hence ?case using d by auto }
+ moreover
+ {assume xa: "x\<noteq>a"
+ let ?d = "min d (dist a x)"
+ have dp: "?d > 0" using xa d(1) using dist_nz by auto
+ from d have d': "\<forall>x\<in>F. x\<noteq>a \<longrightarrow> ?d \<le> dist a x" by auto
+ with dp xa have ?case by(auto intro!: exI[where x="?d"]) }
+ ultimately show ?case by blast
+qed
+
+lemma islimpt_finite:
+ fixes S :: "'a::metric_space set"
+ assumes fS: "finite S" shows "\<not> a islimpt S"
+ unfolding islimpt_approachable
+ using finite_set_avoid[OF fS, of a] by (metis dist_commute not_le)
+
+lemma islimpt_Un: "x islimpt (S \<union> T) \<longleftrightarrow> x islimpt S \<or> x islimpt T"
+ apply (rule iffI)
+ defer
+ apply (metis Un_upper1 Un_upper2 islimpt_subset)
+ unfolding islimpt_def
+ apply (rule ccontr, clarsimp, rename_tac A B)
+ apply (drule_tac x="A \<inter> B" in spec)
+ apply (auto simp add: open_Int)
+ done
+
+lemma discrete_imp_closed:
+ fixes S :: "'a::metric_space set"
+ assumes e: "0 < e" and d: "\<forall>x \<in> S. \<forall>y \<in> S. dist y x < e \<longrightarrow> y = x"
+ shows "closed S"
+proof-
+ {fix x assume C: "\<forall>e>0. \<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e"
+ from e have e2: "e/2 > 0" by arith
+ from C[rule_format, OF e2] obtain y where y: "y \<in> S" "y\<noteq>x" "dist y x < e/2" by blast
+ let ?m = "min (e/2) (dist x y) "
+ from e2 y(2) have mp: "?m > 0" by (simp add: dist_nz[THEN sym])
+ from C[rule_format, OF mp] obtain z where z: "z \<in> S" "z\<noteq>x" "dist z x < ?m" by blast
+ have th: "dist z y < e" using z y
+ by (intro dist_triangle_lt [where z=x], simp)
+ from d[rule_format, OF y(1) z(1) th] y z
+ have False by (auto simp add: dist_commute)}
+ then show ?thesis by (metis islimpt_approachable closed_limpt [where 'a='a])
+qed
+
+subsection{* Interior of a Set *}
+definition "interior S = {x. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S}"
+
+lemma interior_eq: "interior S = S \<longleftrightarrow> open S"
+ apply (simp add: expand_set_eq interior_def)
+ apply (subst (2) open_subopen) by (safe, blast+)
+
+lemma interior_open: "open S ==> (interior S = S)" by (metis interior_eq)
+
+lemma interior_empty[simp]: "interior {} = {}" by (simp add: interior_def)
+
+lemma open_interior[simp, intro]: "open(interior S)"
+ apply (simp add: interior_def)
+ apply (subst open_subopen) by blast
+
+lemma interior_interior[simp]: "interior(interior S) = interior S" by (metis interior_eq open_interior)
+lemma interior_subset: "interior S \<subseteq> S" by (auto simp add: interior_def)
+lemma subset_interior: "S \<subseteq> T ==> (interior S) \<subseteq> (interior T)" by (auto simp add: interior_def)
+lemma interior_maximal: "T \<subseteq> S \<Longrightarrow> open T ==> T \<subseteq> (interior S)" by (auto simp add: interior_def)
+lemma interior_unique: "T \<subseteq> S \<Longrightarrow> open T \<Longrightarrow> (\<forall>T'. T' \<subseteq> S \<and> open T' \<longrightarrow> T' \<subseteq> T) \<Longrightarrow> interior S = T"
+ by (metis equalityI interior_maximal interior_subset open_interior)
+lemma mem_interior: "x \<in> interior S \<longleftrightarrow> (\<exists>e. 0 < e \<and> ball x e \<subseteq> S)"
+ apply (simp add: interior_def)
+ by (metis open_contains_ball centre_in_ball open_ball subset_trans)
+
+lemma open_subset_interior: "open S ==> S \<subseteq> interior T \<longleftrightarrow> S \<subseteq> T"
+ by (metis interior_maximal interior_subset subset_trans)
+
+lemma interior_inter[simp]: "interior(S \<inter> T) = interior S \<inter> interior T"
+ apply (rule equalityI, simp)
+ apply (metis Int_lower1 Int_lower2 subset_interior)
+ by (metis Int_mono interior_subset open_Int open_interior open_subset_interior)
+
+lemma interior_limit_point [intro]:
+ fixes x :: "'a::perfect_space"
+ assumes x: "x \<in> interior S" shows "x islimpt S"
+proof-
+ from x obtain e where e: "e>0" "\<forall>x'. dist x x' < e \<longrightarrow> x' \<in> S"
+ unfolding mem_interior subset_eq Ball_def mem_ball by blast
+ {
+ fix d::real assume d: "d>0"
+ let ?m = "min d e"
+ have mde2: "0 < ?m" using e(1) d(1) by simp
+ from perfect_choose_dist [OF mde2, of x]
+ obtain y where "y \<noteq> x" and "dist y x < ?m" by blast
+ then have "dist y x < e" "dist y x < d" by simp_all
+ from `dist y x < e` e(2) have "y \<in> S" by (simp add: dist_commute)
+ have "\<exists>x'\<in>S. x'\<noteq> x \<and> dist x' x < d"
+ using `y \<in> S` `y \<noteq> x` `dist y x < d` by fast
+ }
+ then show ?thesis unfolding islimpt_approachable by blast
+qed
+
+lemma interior_closed_Un_empty_interior:
+ assumes cS: "closed S" and iT: "interior T = {}"
+ shows "interior(S \<union> T) = interior S"
+proof
+ show "interior S \<subseteq> interior (S\<union>T)"
+ by (rule subset_interior, blast)
+next
+ show "interior (S \<union> T) \<subseteq> interior S"
+ proof
+ fix x assume "x \<in> interior (S \<union> T)"
+ then obtain R where "open R" "x \<in> R" "R \<subseteq> S \<union> T"
+ unfolding interior_def by fast
+ show "x \<in> interior S"
+ proof (rule ccontr)
+ assume "x \<notin> interior S"
+ with `x \<in> R` `open R` obtain y where "y \<in> R - S"
+ unfolding interior_def expand_set_eq by fast
+ from `open R` `closed S` have "open (R - S)" by (rule open_Diff)
+ from `R \<subseteq> S \<union> T` have "R - S \<subseteq> T" by fast
+ from `y \<in> R - S` `open (R - S)` `R - S \<subseteq> T` `interior T = {}`
+ show "False" unfolding interior_def by fast
+ qed
+ qed
+qed
+
+
+subsection{* Closure of a Set *}
+
+definition "closure S = S \<union> {x | x. x islimpt S}"
+
+lemma closure_interior: "closure S = UNIV - interior (UNIV - S)"
+proof-
+ { fix x
+ have "x\<in>UNIV - interior (UNIV - S) \<longleftrightarrow> x \<in> closure S" (is "?lhs = ?rhs")
+ proof
+ let ?exT = "\<lambda> y. (\<exists>T. open T \<and> y \<in> T \<and> T \<subseteq> UNIV - S)"
+ assume "?lhs"
+ hence *:"\<not> ?exT x"
+ unfolding interior_def
+ by simp
+ { assume "\<not> ?rhs"
+ hence False using *
+ unfolding closure_def islimpt_def
+ by blast
+ }
+ thus "?rhs"
+ by blast
+ next
+ assume "?rhs" thus "?lhs"
+ unfolding closure_def interior_def islimpt_def
+ by blast
+ qed
+ }
+ thus ?thesis
+ by blast
+qed
+
+lemma interior_closure: "interior S = UNIV - (closure (UNIV - S))"
+proof-
+ { fix x
+ have "x \<in> interior S \<longleftrightarrow> x \<in> UNIV - (closure (UNIV - S))"
+ unfolding interior_def closure_def islimpt_def
+ by blast (* FIXME: VERY slow! *)
+ }
+ thus ?thesis
+ by blast
+qed
+
+lemma closed_closure[simp, intro]: "closed (closure S)"
+proof-
+ have "closed (UNIV - interior (UNIV -S))" by blast
+ thus ?thesis using closure_interior[of S] by simp
+qed
+
+lemma closure_hull: "closure S = closed hull S"
+proof-
+ have "S \<subseteq> closure S"
+ unfolding closure_def
+ by blast
+ moreover
+ have "closed (closure S)"
+ using closed_closure[of S]
+ by assumption
+ moreover
+ { fix t
+ assume *:"S \<subseteq> t" "closed t"
+ { fix x
+ assume "x islimpt S"
+ hence "x islimpt t" using *(1)
+ using islimpt_subset[of x, of S, of t]
+ by blast
+ }
+ with * have "closure S \<subseteq> t"
+ unfolding closure_def
+ using closed_limpt[of t]
+ by auto
+ }
+ ultimately show ?thesis
+ using hull_unique[of S, of "closure S", of closed]
+ unfolding mem_def
+ by simp
+qed
+
+lemma closure_eq: "closure S = S \<longleftrightarrow> closed S"
+ unfolding closure_hull
+ using hull_eq[of closed, unfolded mem_def, OF closed_Inter, of S]
+ by (metis mem_def subset_eq)
+
+lemma closure_closed[simp]: "closed S \<Longrightarrow> closure S = S"
+ using closure_eq[of S]
+ by simp
+
+lemma closure_closure[simp]: "closure (closure S) = closure S"
+ unfolding closure_hull
+ using hull_hull[of closed S]
+ by assumption
+
+lemma closure_subset: "S \<subseteq> closure S"
+ unfolding closure_hull
+ using hull_subset[of S closed]
+ by assumption
+
+lemma subset_closure: "S \<subseteq> T \<Longrightarrow> closure S \<subseteq> closure T"
+ unfolding closure_hull
+ using hull_mono[of S T closed]
+ by assumption
+
+lemma closure_minimal: "S \<subseteq> T \<Longrightarrow> closed T \<Longrightarrow> closure S \<subseteq> T"
+ using hull_minimal[of S T closed]
+ unfolding closure_hull mem_def
+ by simp
+
+lemma closure_unique: "S \<subseteq> T \<and> closed T \<and> (\<forall> T'. S \<subseteq> T' \<and> closed T' \<longrightarrow> T \<subseteq> T') \<Longrightarrow> closure S = T"
+ using hull_unique[of S T closed]
+ unfolding closure_hull mem_def
+ by simp
+
+lemma closure_empty[simp]: "closure {} = {}"
+ using closed_empty closure_closed[of "{}"]
+ by simp
+
+lemma closure_univ[simp]: "closure UNIV = UNIV"
+ using closure_closed[of UNIV]
+ by simp
+
+lemma closure_eq_empty: "closure S = {} \<longleftrightarrow> S = {}"
+ using closure_empty closure_subset[of S]
+ by blast
+
+lemma closure_subset_eq: "closure S \<subseteq> S \<longleftrightarrow> closed S"
+ using closure_eq[of S] closure_subset[of S]
+ by simp
+
+lemma open_inter_closure_eq_empty:
+ "open S \<Longrightarrow> (S \<inter> closure T) = {} \<longleftrightarrow> S \<inter> T = {}"
+ using open_subset_interior[of S "UNIV - T"]
+ using interior_subset[of "UNIV - T"]
+ unfolding closure_interior
+ by auto
+
+lemma open_inter_closure_subset:
+ "open S \<Longrightarrow> (S \<inter> (closure T)) \<subseteq> closure(S \<inter> T)"
+proof
+ fix x
+ assume as: "open S" "x \<in> S \<inter> closure T"
+ { assume *:"x islimpt T"
+ have "x islimpt (S \<inter> T)"
+ proof (rule islimptI)
+ fix A
+ assume "x \<in> A" "open A"
+ with as have "x \<in> A \<inter> S" "open (A \<inter> S)"
+ by (simp_all add: open_Int)
+ with * obtain y where "y \<in> T" "y \<in> A \<inter> S" "y \<noteq> x"
+ by (rule islimptE)
+ hence "y \<in> S \<inter> T" "y \<in> A \<and> y \<noteq> x"
+ by simp_all
+ thus "\<exists>y\<in>(S \<inter> T). y \<in> A \<and> y \<noteq> x" ..
+ qed
+ }
+ then show "x \<in> closure (S \<inter> T)" using as
+ unfolding closure_def
+ by blast
+qed
+
+lemma closure_complement: "closure(UNIV - S) = UNIV - interior(S)"
+proof-
+ have "S = UNIV - (UNIV - S)"
+ by auto
+ thus ?thesis
+ unfolding closure_interior
+ by auto
+qed
+
+lemma interior_complement: "interior(UNIV - S) = UNIV - closure(S)"
+ unfolding closure_interior
+ by blast
+
+subsection{* Frontier (aka boundary) *}
+
+definition "frontier S = closure S - interior S"
+
+lemma frontier_closed: "closed(frontier S)"
+ by (simp add: frontier_def closed_Diff)
+
+lemma frontier_closures: "frontier S = (closure S) \<inter> (closure(UNIV - S))"
+ by (auto simp add: frontier_def interior_closure)
+
+lemma frontier_straddle:
+ fixes a :: "'a::metric_space"
+ shows "a \<in> frontier S \<longleftrightarrow> (\<forall>e>0. (\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e))" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume "?lhs"
+ { fix e::real
+ assume "e > 0"
+ let ?rhse = "(\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e)"
+ { assume "a\<in>S"
+ have "\<exists>x\<in>S. dist a x < e" using `e>0` `a\<in>S` by(rule_tac x=a in bexI) auto
+ moreover have "\<exists>x. x \<notin> S \<and> dist a x < e" using `?lhs` `a\<in>S`
+ unfolding frontier_closures closure_def islimpt_def using `e>0`
+ by (auto, erule_tac x="ball a e" in allE, auto)
+ ultimately have ?rhse by auto
+ }
+ moreover
+ { assume "a\<notin>S"
+ hence ?rhse using `?lhs`
+ unfolding frontier_closures closure_def islimpt_def
+ using open_ball[of a e] `e > 0`
+ by (auto, erule_tac x = "ball a e" in allE, auto) (* FIXME: VERY slow! *)
+ }
+ ultimately have ?rhse by auto
+ }
+ thus ?rhs by auto
+next
+ assume ?rhs
+ moreover
+ { fix T assume "a\<notin>S" and
+ as:"\<forall>e>0. (\<exists>x\<in>S. dist a x < e) \<and> (\<exists>x. x \<notin> S \<and> dist a x < e)" "a \<notin> S" "a \<in> T" "open T"
+ from `open T` `a \<in> T` have "\<exists>e>0. ball a e \<subseteq> T" unfolding open_contains_ball[of T] by auto
+ then obtain e where "e>0" "ball a e \<subseteq> T" by auto
+ then obtain y where y:"y\<in>S" "dist a y < e" using as(1) by auto
+ have "\<exists>y\<in>S. y \<in> T \<and> y \<noteq> a"
+ using `dist a y < e` `ball a e \<subseteq> T` unfolding ball_def using `y\<in>S` `a\<notin>S` by auto
+ }
+ hence "a \<in> closure S" unfolding closure_def islimpt_def using `?rhs` by auto
+ moreover
+ { fix T assume "a \<in> T" "open T" "a\<in>S"
+ then obtain e where "e>0" and balle: "ball a e \<subseteq> T" unfolding open_contains_ball using `?rhs` by auto
+ obtain x where "x \<notin> S" "dist a x < e" using `?rhs` using `e>0` by auto
+ hence "\<exists>y\<in>UNIV - S. y \<in> T \<and> y \<noteq> a" using balle `a\<in>S` unfolding ball_def by (rule_tac x=x in bexI)auto
+ }
+ hence "a islimpt (UNIV - S) \<or> a\<notin>S" unfolding islimpt_def by auto
+ ultimately show ?lhs unfolding frontier_closures using closure_def[of "UNIV - S"] by auto
+qed
+
+lemma frontier_subset_closed: "closed S \<Longrightarrow> frontier S \<subseteq> S"
+ by (metis frontier_def closure_closed Diff_subset)
+
+lemma frontier_empty: "frontier {} = {}"
+ by (simp add: frontier_def closure_empty)
+
+lemma frontier_subset_eq: "frontier S \<subseteq> S \<longleftrightarrow> closed S"
+proof-
+ { assume "frontier S \<subseteq> S"
+ hence "closure S \<subseteq> S" using interior_subset unfolding frontier_def by auto
+ hence "closed S" using closure_subset_eq by auto
+ }
+ thus ?thesis using frontier_subset_closed[of S] by auto
+qed
+
+lemma frontier_complement: "frontier(UNIV - S) = frontier S"
+ by (auto simp add: frontier_def closure_complement interior_complement)
+
+lemma frontier_disjoint_eq: "frontier S \<inter> S = {} \<longleftrightarrow> open S"
+ using frontier_complement frontier_subset_eq[of "UNIV - S"]
+ unfolding open_closed Compl_eq_Diff_UNIV by auto
+
+subsection{* Common nets and The "within" modifier for nets. *}
+
+definition
+ at_infinity :: "'a::real_normed_vector net" where
+ "at_infinity = Abs_net (range (\<lambda>r. {x. r \<le> norm x}))"
+
+definition
+ indirection :: "'a::real_normed_vector \<Rightarrow> 'a \<Rightarrow> 'a net" (infixr "indirection" 70) where
+ "a indirection v = (at a) within {b. \<exists>c\<ge>0. b - a = scaleR c v}"
+
+text{* Prove That They are all nets. *}
+
+lemma Rep_net_at_infinity:
+ "Rep_net at_infinity = range (\<lambda>r. {x. r \<le> norm x})"
+unfolding at_infinity_def
+apply (rule Abs_net_inverse')
+apply (rule image_nonempty, simp)
+apply (clarsimp, rename_tac r s)
+apply (rule_tac x="max r s" in exI, auto)
+done
+
+lemma within_UNIV: "net within UNIV = net"
+ by (simp add: Rep_net_inject [symmetric] Rep_net_within)
+
+subsection{* Identify Trivial limits, where we can't approach arbitrarily closely. *}
+
+definition
+ trivial_limit :: "'a net \<Rightarrow> bool" where
+ "trivial_limit net \<longleftrightarrow> {} \<in> Rep_net net"
+
+lemma trivial_limit_within:
+ shows "trivial_limit (at a within S) \<longleftrightarrow> \<not> a islimpt S"
+proof
+ assume "trivial_limit (at a within S)"
+ thus "\<not> a islimpt S"
+ unfolding trivial_limit_def
+ unfolding Rep_net_within Rep_net_at
+ unfolding islimpt_def
+ apply (clarsimp simp add: expand_set_eq)
+ apply (rename_tac T, rule_tac x=T in exI)
+ apply (clarsimp, drule_tac x=y in spec, simp)
+ done
+next
+ assume "\<not> a islimpt S"
+ thus "trivial_limit (at a within S)"
+ unfolding trivial_limit_def
+ unfolding Rep_net_within Rep_net_at
+ unfolding islimpt_def
+ apply (clarsimp simp add: image_image)
+ apply (rule_tac x=T in image_eqI)
+ apply (auto simp add: expand_set_eq)
+ done
+qed
+
+lemma trivial_limit_at_iff: "trivial_limit (at a) \<longleftrightarrow> \<not> a islimpt UNIV"
+ using trivial_limit_within [of a UNIV]
+ by (simp add: within_UNIV)
+
+lemma trivial_limit_at:
+ fixes a :: "'a::perfect_space"
+ shows "\<not> trivial_limit (at a)"
+ by (simp add: trivial_limit_at_iff)
+
+lemma trivial_limit_at_infinity:
+ "\<not> trivial_limit (at_infinity :: ('a::{real_normed_vector,zero_neq_one}) net)"
+ (* FIXME: find a more appropriate type class *)
+ unfolding trivial_limit_def Rep_net_at_infinity
+ apply (clarsimp simp add: expand_set_eq)
+ apply (drule_tac x="scaleR r (sgn 1)" in spec)
+ apply (simp add: norm_sgn)
+ done
+
+lemma trivial_limit_sequentially: "\<not> trivial_limit sequentially"
+ by (auto simp add: trivial_limit_def Rep_net_sequentially)
+
+subsection{* Some property holds "sufficiently close" to the limit point. *}
+
+lemma eventually_at: (* FIXME: this replaces Limits.eventually_at *)
+ "eventually P (at a) \<longleftrightarrow> (\<exists>d>0. \<forall>x. 0 < dist x a \<and> dist x a < d \<longrightarrow> P x)"
+unfolding eventually_at dist_nz by auto
+
+lemma eventually_at_infinity:
+ "eventually P at_infinity \<longleftrightarrow> (\<exists>b. \<forall>x. norm x >= b \<longrightarrow> P x)"
+unfolding eventually_def Rep_net_at_infinity by auto
+
+lemma eventually_within: "eventually P (at a within S) \<longleftrightarrow>
+ (\<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a < d \<longrightarrow> P x)"
+unfolding eventually_within eventually_at dist_nz by auto
+
+lemma eventually_within_le: "eventually P (at a within S) \<longleftrightarrow>
+ (\<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a <= d \<longrightarrow> P x)" (is "?lhs = ?rhs")
+unfolding eventually_within
+apply safe
+apply (rule_tac x="d/2" in exI, simp)
+apply (rule_tac x="d" in exI, simp)
+done
+
+lemma eventually_happens: "eventually P net ==> trivial_limit net \<or> (\<exists>x. P x)"
+ unfolding eventually_def trivial_limit_def
+ using Rep_net_nonempty [of net] by auto
+
+lemma always_eventually: "(\<forall>x. P x) ==> eventually P net"
+ unfolding eventually_def trivial_limit_def
+ using Rep_net_nonempty [of net] by auto
+
+lemma trivial_limit_eventually: "trivial_limit net \<Longrightarrow> eventually P net"
+ unfolding trivial_limit_def eventually_def by auto
+
+lemma eventually_False: "eventually (\<lambda>x. False) net \<longleftrightarrow> trivial_limit net"
+ unfolding trivial_limit_def eventually_def by auto
+
+lemma trivial_limit_eq: "trivial_limit net \<longleftrightarrow> (\<forall>P. eventually P net)"
+ apply (safe elim!: trivial_limit_eventually)
+ apply (simp add: eventually_False [symmetric])
+ done
+
+text{* Combining theorems for "eventually" *}
+
+lemma eventually_conjI:
+ "\<lbrakk>eventually (\<lambda>x. P x) net; eventually (\<lambda>x. Q x) net\<rbrakk>
+ \<Longrightarrow> eventually (\<lambda>x. P x \<and> Q x) net"
+by (rule eventually_conj)
+
+lemma eventually_rev_mono:
+ "eventually P net \<Longrightarrow> (\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> eventually Q net"
+using eventually_mono [of P Q] by fast
+
+lemma eventually_and: " eventually (\<lambda>x. P x \<and> Q x) net \<longleftrightarrow> eventually P net \<and> eventually Q net"
+ by (auto intro!: eventually_conjI elim: eventually_rev_mono)
+
+lemma eventually_false: "eventually (\<lambda>x. False) net \<longleftrightarrow> trivial_limit net"
+ by (auto simp add: eventually_False)
+
+lemma not_eventually: "(\<forall>x. \<not> P x ) \<Longrightarrow> ~(trivial_limit net) ==> ~(eventually (\<lambda>x. P x) net)"
+ by (simp add: eventually_False)
+
+subsection{* Limits, defined as vacuously true when the limit is trivial. *}
+
+ text{* Notation Lim to avoid collition with lim defined in analysis *}
+definition
+ Lim :: "'a net \<Rightarrow> ('a \<Rightarrow> 'b::t2_space) \<Rightarrow> 'b" where
+ "Lim net f = (THE l. (f ---> l) net)"
+
+lemma Lim:
+ "(f ---> l) net \<longleftrightarrow>
+ trivial_limit net \<or>
+ (\<forall>e>0. eventually (\<lambda>x. dist (f x) l < e) net)"
+ unfolding tendsto_iff trivial_limit_eq by auto
+
+
+text{* Show that they yield usual definitions in the various cases. *}
+
+lemma Lim_within_le: "(f ---> l)(at a within S) \<longleftrightarrow>
+ (\<forall>e>0. \<exists>d>0. \<forall>x\<in>S. 0 < dist x a \<and> dist x a <= d \<longrightarrow> dist (f x) l < e)"
+ by (auto simp add: tendsto_iff eventually_within_le)
+
+lemma Lim_within: "(f ---> l) (at a within S) \<longleftrightarrow>
+ (\<forall>e >0. \<exists>d>0. \<forall>x \<in> S. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) l < e)"
+ by (auto simp add: tendsto_iff eventually_within)
+
+lemma Lim_at: "(f ---> l) (at a) \<longleftrightarrow>
+ (\<forall>e >0. \<exists>d>0. \<forall>x. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) l < e)"
+ by (auto simp add: tendsto_iff eventually_at)
+
+lemma Lim_at_iff_LIM: "(f ---> l) (at a) \<longleftrightarrow> f -- a --> l"
+ unfolding Lim_at LIM_def by (simp only: zero_less_dist_iff)
+
+lemma Lim_at_infinity:
+ "(f ---> l) at_infinity \<longleftrightarrow> (\<forall>e>0. \<exists>b. \<forall>x. norm x >= b \<longrightarrow> dist (f x) l < e)"
+ by (auto simp add: tendsto_iff eventually_at_infinity)
+
+lemma Lim_sequentially:
+ "(S ---> l) sequentially \<longleftrightarrow>
+ (\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (S n) l < e)"
+ by (auto simp add: tendsto_iff eventually_sequentially)
+
+lemma Lim_sequentially_iff_LIMSEQ: "(S ---> l) sequentially \<longleftrightarrow> S ----> l"
+ unfolding Lim_sequentially LIMSEQ_def ..
+
+lemma Lim_eventually: "eventually (\<lambda>x. f x = l) net \<Longrightarrow> (f ---> l) net"
+ by (rule topological_tendstoI, auto elim: eventually_rev_mono)
+
+text{* The expected monotonicity property. *}
+
+lemma Lim_within_empty: "(f ---> l) (net within {})"
+ unfolding tendsto_def Limits.eventually_within by simp
+
+lemma Lim_within_subset: "(f ---> l) (net within S) \<Longrightarrow> T \<subseteq> S \<Longrightarrow> (f ---> l) (net within T)"
+ unfolding tendsto_def Limits.eventually_within
+ by (auto elim!: eventually_elim1)
+
+lemma Lim_Un: assumes "(f ---> l) (net within S)" "(f ---> l) (net within T)"
+ shows "(f ---> l) (net within (S \<union> T))"
+ using assms unfolding tendsto_def Limits.eventually_within
+ apply clarify
+ apply (drule spec, drule (1) mp, drule (1) mp)
+ apply (drule spec, drule (1) mp, drule (1) mp)
+ apply (auto elim: eventually_elim2)
+ done
+
+lemma Lim_Un_univ:
+ "(f ---> l) (net within S) \<Longrightarrow> (f ---> l) (net within T) \<Longrightarrow> S \<union> T = UNIV
+ ==> (f ---> l) net"
+ by (metis Lim_Un within_UNIV)
+
+text{* Interrelations between restricted and unrestricted limits. *}
+
+lemma Lim_at_within: "(f ---> l) net ==> (f ---> l)(net within S)"
+ (* FIXME: rename *)
+ unfolding tendsto_def Limits.eventually_within
+ apply (clarify, drule spec, drule (1) mp, drule (1) mp)
+ by (auto elim!: eventually_elim1)
+
+lemma Lim_within_open:
+ fixes f :: "'a::topological_space \<Rightarrow> 'b::topological_space"
+ assumes"a \<in> S" "open S"
+ shows "(f ---> l)(at a within S) \<longleftrightarrow> (f ---> l)(at a)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume ?lhs
+ { fix A assume "open A" "l \<in> A"
+ with `?lhs` have "eventually (\<lambda>x. f x \<in> A) (at a within S)"
+ by (rule topological_tendstoD)
+ hence "eventually (\<lambda>x. x \<in> S \<longrightarrow> f x \<in> A) (at a)"
+ unfolding Limits.eventually_within .
+ then obtain T where "open T" "a \<in> T" "\<forall>x\<in>T. x \<noteq> a \<longrightarrow> x \<in> S \<longrightarrow> f x \<in> A"
+ unfolding eventually_at_topological by fast
+ hence "open (T \<inter> S)" "a \<in> T \<inter> S" "\<forall>x\<in>(T \<inter> S). x \<noteq> a \<longrightarrow> f x \<in> A"
+ using assms by auto
+ hence "\<exists>T. open T \<and> a \<in> T \<and> (\<forall>x\<in>T. x \<noteq> a \<longrightarrow> f x \<in> A)"
+ by fast
+ hence "eventually (\<lambda>x. f x \<in> A) (at a)"
+ unfolding eventually_at_topological .
+ }
+ thus ?rhs by (rule topological_tendstoI)
+next
+ assume ?rhs
+ thus ?lhs by (rule Lim_at_within)
+qed
+
+text{* Another limit point characterization. *}
+
+lemma islimpt_sequential:
+ fixes x :: "'a::metric_space" (* FIXME: generalize to topological_space *)
+ shows "x islimpt S \<longleftrightarrow> (\<exists>f. (\<forall>n::nat. f n \<in> S -{x}) \<and> (f ---> x) sequentially)"
+ (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ then obtain f where f:"\<forall>y. y>0 \<longrightarrow> f y \<in> S \<and> f y \<noteq> x \<and> dist (f y) x < y"
+ unfolding islimpt_approachable using choice[of "\<lambda>e y. e>0 \<longrightarrow> y\<in>S \<and> y\<noteq>x \<and> dist y x < e"] by auto
+ { fix n::nat
+ have "f (inverse (real n + 1)) \<in> S - {x}" using f by auto
+ }
+ moreover
+ { fix e::real assume "e>0"
+ hence "\<exists>N::nat. inverse (real (N + 1)) < e" using real_arch_inv[of e] apply (auto simp add: Suc_pred') apply(rule_tac x="n - 1" in exI) by auto
+ then obtain N::nat where "inverse (real (N + 1)) < e" by auto
+ hence "\<forall>n\<ge>N. inverse (real n + 1) < e" by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
+ moreover have "\<forall>n\<ge>N. dist (f (inverse (real n + 1))) x < (inverse (real n + 1))" using f `e>0` by auto
+ ultimately have "\<exists>N::nat. \<forall>n\<ge>N. dist (f (inverse (real n + 1))) x < e" apply(rule_tac x=N in exI) apply auto apply(erule_tac x=n in allE)+ by auto
+ }
+ hence " ((\<lambda>n. f (inverse (real n + 1))) ---> x) sequentially"
+ unfolding Lim_sequentially using f by auto
+ ultimately show ?rhs apply (rule_tac x="(\<lambda>n::nat. f (inverse (real n + 1)))" in exI) by auto
+next
+ assume ?rhs
+ then obtain f::"nat\<Rightarrow>'a" where f:"(\<forall>n. f n \<in> S - {x})" "(\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (f n) x < e)" unfolding Lim_sequentially by auto
+ { fix e::real assume "e>0"
+ then obtain N where "dist (f N) x < e" using f(2) by auto
+ moreover have "f N\<in>S" "f N \<noteq> x" using f(1) by auto
+ ultimately have "\<exists>x'\<in>S. x' \<noteq> x \<and> dist x' x < e" by auto
+ }
+ thus ?lhs unfolding islimpt_approachable by auto
+qed
+
+text{* Basic arithmetical combining theorems for limits. *}
+
+lemma Lim_linear:
+ assumes "(f ---> l) net" "bounded_linear h"
+ shows "((\<lambda>x. h (f x)) ---> h l) net"
+using `bounded_linear h` `(f ---> l) net`
+by (rule bounded_linear.tendsto)
+
+lemma Lim_ident_at: "((\<lambda>x. x) ---> a) (at a)"
+ unfolding tendsto_def Limits.eventually_at_topological by fast
+
+lemma Lim_const: "((\<lambda>x. a) ---> a) net"
+ by (rule tendsto_const)
+
+lemma Lim_cmul:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ shows "(f ---> l) net ==> ((\<lambda>x. c *\<^sub>R f x) ---> c *\<^sub>R l) net"
+ by (intro tendsto_intros)
+
+lemma Lim_neg:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ shows "(f ---> l) net ==> ((\<lambda>x. -(f x)) ---> -l) net"
+ by (rule tendsto_minus)
+
+lemma Lim_add: fixes f :: "'a \<Rightarrow> 'b::real_normed_vector" shows
+ "(f ---> l) net \<Longrightarrow> (g ---> m) net \<Longrightarrow> ((\<lambda>x. f(x) + g(x)) ---> l + m) net"
+ by (rule tendsto_add)
+
+lemma Lim_sub:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ shows "(f ---> l) net \<Longrightarrow> (g ---> m) net \<Longrightarrow> ((\<lambda>x. f(x) - g(x)) ---> l - m) net"
+ by (rule tendsto_diff)
+
+lemma Lim_null:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ shows "(f ---> l) net \<longleftrightarrow> ((\<lambda>x. f(x) - l) ---> 0) net" by (simp add: Lim dist_norm)
+
+lemma Lim_null_norm:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ shows "(f ---> 0) net \<longleftrightarrow> ((\<lambda>x. norm(f x)) ---> 0) net"
+ by (simp add: Lim dist_norm)
+
+lemma Lim_null_comparison:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes "eventually (\<lambda>x. norm (f x) \<le> g x) net" "(g ---> 0) net"
+ shows "(f ---> 0) net"
+proof(simp add: tendsto_iff, rule+)
+ fix e::real assume "0<e"
+ { fix x
+ assume "norm (f x) \<le> g x" "dist (g x) 0 < e"
+ hence "dist (f x) 0 < e" by (simp add: dist_norm)
+ }
+ thus "eventually (\<lambda>x. dist (f x) 0 < e) net"
+ using eventually_and[of "\<lambda>x. norm(f x) <= g x" "\<lambda>x. dist (g x) 0 < e" net]
+ using eventually_mono[of "(\<lambda>x. norm (f x) \<le> g x \<and> dist (g x) 0 < e)" "(\<lambda>x. dist (f x) 0 < e)" net]
+ using assms `e>0` unfolding tendsto_iff by auto
+qed
+
+lemma Lim_component:
+ fixes f :: "'a \<Rightarrow> 'b::metric_space ^ 'n::finite"
+ shows "(f ---> l) net \<Longrightarrow> ((\<lambda>a. f a $i) ---> l$i) net"
+ unfolding tendsto_iff
+ apply (clarify)
+ apply (drule spec, drule (1) mp)
+ apply (erule eventually_elim1)
+ apply (erule le_less_trans [OF dist_nth_le])
+ done
+
+lemma Lim_transform_bound:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ fixes g :: "'a \<Rightarrow> 'c::real_normed_vector"
+ assumes "eventually (\<lambda>n. norm(f n) <= norm(g n)) net" "(g ---> 0) net"
+ shows "(f ---> 0) net"
+proof (rule tendstoI)
+ fix e::real assume "e>0"
+ { fix x
+ assume "norm (f x) \<le> norm (g x)" "dist (g x) 0 < e"
+ hence "dist (f x) 0 < e" by (simp add: dist_norm)}
+ thus "eventually (\<lambda>x. dist (f x) 0 < e) net"
+ using eventually_and[of "\<lambda>x. norm (f x) \<le> norm (g x)" "\<lambda>x. dist (g x) 0 < e" net]
+ using eventually_mono[of "\<lambda>x. norm (f x) \<le> norm (g x) \<and> dist (g x) 0 < e" "\<lambda>x. dist (f x) 0 < e" net]
+ using assms `e>0` unfolding tendsto_iff by blast
+qed
+
+text{* Deducing things about the limit from the elements. *}
+
+lemma Lim_in_closed_set:
+ assumes "closed S" "eventually (\<lambda>x. f(x) \<in> S) net" "\<not>(trivial_limit net)" "(f ---> l) net"
+ shows "l \<in> S"
+proof (rule ccontr)
+ assume "l \<notin> S"
+ with `closed S` have "open (- S)" "l \<in> - S"
+ by (simp_all add: open_Compl)
+ with assms(4) have "eventually (\<lambda>x. f x \<in> - S) net"
+ by (rule topological_tendstoD)
+ with assms(2) have "eventually (\<lambda>x. False) net"
+ by (rule eventually_elim2) simp
+ with assms(3) show "False"
+ by (simp add: eventually_False)
+qed
+
+text{* Need to prove closed(cball(x,e)) before deducing this as a corollary. *}
+
+lemma Lim_dist_ubound:
+ assumes "\<not>(trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. dist a (f x) <= e) net"
+ shows "dist a l <= e"
+proof (rule ccontr)
+ assume "\<not> dist a l \<le> e"
+ then have "0 < dist a l - e" by simp
+ with assms(2) have "eventually (\<lambda>x. dist (f x) l < dist a l - e) net"
+ by (rule tendstoD)
+ with assms(3) have "eventually (\<lambda>x. dist a (f x) \<le> e \<and> dist (f x) l < dist a l - e) net"
+ by (rule eventually_conjI)
+ then obtain w where "dist a (f w) \<le> e" "dist (f w) l < dist a l - e"
+ using assms(1) eventually_happens by auto
+ hence "dist a (f w) + dist (f w) l < e + (dist a l - e)"
+ by (rule add_le_less_mono)
+ hence "dist a (f w) + dist (f w) l < dist a l"
+ by simp
+ also have "\<dots> \<le> dist a (f w) + dist (f w) l"
+ by (rule dist_triangle)
+ finally show False by simp
+qed
+
+lemma Lim_norm_ubound:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes "\<not>(trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. norm(f x) <= e) net"
+ shows "norm(l) <= e"
+proof (rule ccontr)
+ assume "\<not> norm l \<le> e"
+ then have "0 < norm l - e" by simp
+ with assms(2) have "eventually (\<lambda>x. dist (f x) l < norm l - e) net"
+ by (rule tendstoD)
+ with assms(3) have "eventually (\<lambda>x. norm (f x) \<le> e \<and> dist (f x) l < norm l - e) net"
+ by (rule eventually_conjI)
+ then obtain w where "norm (f w) \<le> e" "dist (f w) l < norm l - e"
+ using assms(1) eventually_happens by auto
+ hence "norm (f w - l) < norm l - e" "norm (f w) \<le> e" by (simp_all add: dist_norm)
+ hence "norm (f w - l) + norm (f w) < norm l" by simp
+ hence "norm (f w - l - f w) < norm l" by (rule le_less_trans [OF norm_triangle_ineq4])
+ thus False using `\<not> norm l \<le> e` by simp
+qed
+
+lemma Lim_norm_lbound:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes "\<not> (trivial_limit net)" "(f ---> l) net" "eventually (\<lambda>x. e <= norm(f x)) net"
+ shows "e \<le> norm l"
+proof (rule ccontr)
+ assume "\<not> e \<le> norm l"
+ then have "0 < e - norm l" by simp
+ with assms(2) have "eventually (\<lambda>x. dist (f x) l < e - norm l) net"
+ by (rule tendstoD)
+ with assms(3) have "eventually (\<lambda>x. e \<le> norm (f x) \<and> dist (f x) l < e - norm l) net"
+ by (rule eventually_conjI)
+ then obtain w where "e \<le> norm (f w)" "dist (f w) l < e - norm l"
+ using assms(1) eventually_happens by auto
+ hence "norm (f w - l) + norm l < e" "e \<le> norm (f w)" by (simp_all add: dist_norm)
+ hence "norm (f w - l) + norm l < norm (f w)" by (rule less_le_trans)
+ hence "norm (f w - l + l) < norm (f w)" by (rule le_less_trans [OF norm_triangle_ineq])
+ thus False by simp
+qed
+
+text{* Uniqueness of the limit, when nontrivial. *}
+
+lemma Lim_unique:
+ fixes f :: "'a \<Rightarrow> 'b::t2_space"
+ assumes "\<not> trivial_limit net" "(f ---> l) net" "(f ---> l') net"
+ shows "l = l'"
+proof (rule ccontr)
+ assume "l \<noteq> l'"
+ obtain U V where "open U" "open V" "l \<in> U" "l' \<in> V" "U \<inter> V = {}"
+ using hausdorff [OF `l \<noteq> l'`] by fast
+ have "eventually (\<lambda>x. f x \<in> U) net"
+ using `(f ---> l) net` `open U` `l \<in> U` by (rule topological_tendstoD)
+ moreover
+ have "eventually (\<lambda>x. f x \<in> V) net"
+ using `(f ---> l') net` `open V` `l' \<in> V` by (rule topological_tendstoD)
+ ultimately
+ have "eventually (\<lambda>x. False) net"
+ proof (rule eventually_elim2)
+ fix x
+ assume "f x \<in> U" "f x \<in> V"
+ hence "f x \<in> U \<inter> V" by simp
+ with `U \<inter> V = {}` show "False" by simp
+ qed
+ with `\<not> trivial_limit net` show "False"
+ by (simp add: eventually_False)
+qed
+
+lemma tendsto_Lim:
+ fixes f :: "'a \<Rightarrow> 'b::t2_space"
+ shows "~(trivial_limit net) \<Longrightarrow> (f ---> l) net ==> Lim net f = l"
+ unfolding Lim_def using Lim_unique[of net f] by auto
+
+text{* Limit under bilinear function *}
+
+lemma Lim_bilinear:
+ assumes "(f ---> l) net" and "(g ---> m) net" and "bounded_bilinear h"
+ shows "((\<lambda>x. h (f x) (g x)) ---> (h l m)) net"
+using `bounded_bilinear h` `(f ---> l) net` `(g ---> m) net`
+by (rule bounded_bilinear.tendsto)
+
+text{* These are special for limits out of the same vector space. *}
+
+lemma Lim_within_id: "(id ---> a) (at a within s)"
+ unfolding tendsto_def Limits.eventually_within eventually_at_topological
+ by auto
+
+lemma Lim_at_id: "(id ---> a) (at a)"
+apply (subst within_UNIV[symmetric]) by (simp add: Lim_within_id)
+
+lemma Lim_at_zero:
+ fixes a :: "'a::real_normed_vector"
+ fixes l :: "'b::topological_space"
+ shows "(f ---> l) (at a) \<longleftrightarrow> ((\<lambda>x. f(a + x)) ---> l) (at 0)" (is "?lhs = ?rhs")
+proof
+ assume "?lhs"
+ { fix S assume "open S" "l \<in> S"
+ with `?lhs` have "eventually (\<lambda>x. f x \<in> S) (at a)"
+ by (rule topological_tendstoD)
+ then obtain d where d: "d>0" "\<forall>x. x \<noteq> a \<and> dist x a < d \<longrightarrow> f x \<in> S"
+ unfolding Limits.eventually_at by fast
+ { fix x::"'a" assume "x \<noteq> 0 \<and> dist x 0 < d"
+ hence "f (a + x) \<in> S" using d
+ apply(erule_tac x="x+a" in allE)
+ by(auto simp add: comm_monoid_add.mult_commute dist_norm dist_commute)
+ }
+ hence "\<exists>d>0. \<forall>x. x \<noteq> 0 \<and> dist x 0 < d \<longrightarrow> f (a + x) \<in> S"
+ using d(1) by auto
+ hence "eventually (\<lambda>x. f (a + x) \<in> S) (at 0)"
+ unfolding Limits.eventually_at .
+ }
+ thus "?rhs" by (rule topological_tendstoI)
+next
+ assume "?rhs"
+ { fix S assume "open S" "l \<in> S"
+ with `?rhs` have "eventually (\<lambda>x. f (a + x) \<in> S) (at 0)"
+ by (rule topological_tendstoD)
+ then obtain d where d: "d>0" "\<forall>x. x \<noteq> 0 \<and> dist x 0 < d \<longrightarrow> f (a + x) \<in> S"
+ unfolding Limits.eventually_at by fast
+ { fix x::"'a" assume "x \<noteq> a \<and> dist x a < d"
+ hence "f x \<in> S" using d apply(erule_tac x="x-a" in allE)
+ by(auto simp add: comm_monoid_add.mult_commute dist_norm dist_commute)
+ }
+ hence "\<exists>d>0. \<forall>x. x \<noteq> a \<and> dist x a < d \<longrightarrow> f x \<in> S" using d(1) by auto
+ hence "eventually (\<lambda>x. f x \<in> S) (at a)" unfolding Limits.eventually_at .
+ }
+ thus "?lhs" by (rule topological_tendstoI)
+qed
+
+text{* It's also sometimes useful to extract the limit point from the net. *}
+
+definition
+ netlimit :: "'a::t2_space net \<Rightarrow> 'a" where
+ "netlimit net = (SOME a. ((\<lambda>x. x) ---> a) net)"
+
+lemma netlimit_within:
+ assumes "\<not> trivial_limit (at a within S)"
+ shows "netlimit (at a within S) = a"
+unfolding netlimit_def
+apply (rule some_equality)
+apply (rule Lim_at_within)
+apply (rule Lim_ident_at)
+apply (erule Lim_unique [OF assms])
+apply (rule Lim_at_within)
+apply (rule Lim_ident_at)
+done
+
+lemma netlimit_at:
+ fixes a :: "'a::perfect_space"
+ shows "netlimit (at a) = a"
+ apply (subst within_UNIV[symmetric])
+ using netlimit_within[of a UNIV]
+ by (simp add: trivial_limit_at within_UNIV)
+
+text{* Transformation of limit. *}
+
+lemma Lim_transform:
+ fixes f g :: "'a::type \<Rightarrow> 'b::real_normed_vector"
+ assumes "((\<lambda>x. f x - g x) ---> 0) net" "(f ---> l) net"
+ shows "(g ---> l) net"
+proof-
+ from assms have "((\<lambda>x. f x - g x - f x) ---> 0 - l) net" using Lim_sub[of "\<lambda>x. f x - g x" 0 net f l] by auto
+ thus "?thesis" using Lim_neg [of "\<lambda> x. - g x" "-l" net] by auto
+qed
+
+lemma Lim_transform_eventually:
+ "eventually (\<lambda>x. f x = g x) net \<Longrightarrow> (f ---> l) net ==> (g ---> l) net"
+ apply (rule topological_tendstoI)
+ apply (drule (2) topological_tendstoD)
+ apply (erule (1) eventually_elim2, simp)
+ done
+
+lemma Lim_transform_within:
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ assumes "0 < d" "(\<forall>x'\<in>S. 0 < dist x' x \<and> dist x' x < d \<longrightarrow> f x' = g x')"
+ "(f ---> l) (at x within S)"
+ shows "(g ---> l) (at x within S)"
+ using assms(1,3) unfolding Lim_within
+ apply -
+ apply (clarify, rename_tac e)
+ apply (drule_tac x=e in spec, clarsimp, rename_tac r)
+ apply (rule_tac x="min d r" in exI, clarsimp, rename_tac y)
+ apply (drule_tac x=y in bspec, assumption, clarsimp)
+ apply (simp add: assms(2))
+ done
+
+lemma Lim_transform_at:
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ shows "0 < d \<Longrightarrow> (\<forall>x'. 0 < dist x' x \<and> dist x' x < d \<longrightarrow> f x' = g x') \<Longrightarrow>
+ (f ---> l) (at x) ==> (g ---> l) (at x)"
+ apply (subst within_UNIV[symmetric])
+ using Lim_transform_within[of d UNIV x f g l]
+ by (auto simp add: within_UNIV)
+
+text{* Common case assuming being away from some crucial point like 0. *}
+
+lemma Lim_transform_away_within:
+ fixes a b :: "'a::metric_space"
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ assumes "a\<noteq>b" "\<forall>x\<in> S. x \<noteq> a \<and> x \<noteq> b \<longrightarrow> f x = g x"
+ and "(f ---> l) (at a within S)"
+ shows "(g ---> l) (at a within S)"
+proof-
+ have "\<forall>x'\<in>S. 0 < dist x' a \<and> dist x' a < dist a b \<longrightarrow> f x' = g x'" using assms(2)
+ apply auto apply(erule_tac x=x' in ballE) by (auto simp add: dist_commute)
+ thus ?thesis using Lim_transform_within[of "dist a b" S a f g l] using assms(1,3) unfolding dist_nz by auto
+qed
+
+lemma Lim_transform_away_at:
+ fixes a b :: "'a::metric_space"
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ assumes ab: "a\<noteq>b" and fg: "\<forall>x. x \<noteq> a \<and> x \<noteq> b \<longrightarrow> f x = g x"
+ and fl: "(f ---> l) (at a)"
+ shows "(g ---> l) (at a)"
+ using Lim_transform_away_within[OF ab, of UNIV f g l] fg fl
+ by (auto simp add: within_UNIV)
+
+text{* Alternatively, within an open set. *}
+
+lemma Lim_transform_within_open:
+ fixes a :: "'a::metric_space"
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ assumes "open S" "a \<in> S" "\<forall>x\<in>S. x \<noteq> a \<longrightarrow> f x = g x" "(f ---> l) (at a)"
+ shows "(g ---> l) (at a)"
+proof-
+ from assms(1,2) obtain e::real where "e>0" and e:"ball a e \<subseteq> S" unfolding open_contains_ball by auto
+ hence "\<forall>x'. 0 < dist x' a \<and> dist x' a < e \<longrightarrow> f x' = g x'" using assms(3)
+ unfolding ball_def subset_eq apply auto apply(erule_tac x=x' in allE) apply(erule_tac x=x' in ballE) by(auto simp add: dist_commute)
+ thus ?thesis using Lim_transform_at[of e a f g l] `e>0` assms(4) by auto
+qed
+
+text{* A congruence rule allowing us to transform limits assuming not at point. *}
+
+(* FIXME: Only one congruence rule for tendsto can be used at a time! *)
+
+lemma Lim_cong_within[cong add]:
+ fixes a :: "'a::metric_space"
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ shows "(\<And>x. x \<noteq> a \<Longrightarrow> f x = g x) ==> ((\<lambda>x. f x) ---> l) (at a within S) \<longleftrightarrow> ((g ---> l) (at a within S))"
+ by (simp add: Lim_within dist_nz[symmetric])
+
+lemma Lim_cong_at[cong add]:
+ fixes a :: "'a::metric_space"
+ fixes l :: "'b::metric_space" (* TODO: generalize *)
+ shows "(\<And>x. x \<noteq> a ==> f x = g x) ==> (((\<lambda>x. f x) ---> l) (at a) \<longleftrightarrow> ((g ---> l) (at a)))"
+ by (simp add: Lim_at dist_nz[symmetric])
+
+text{* Useful lemmas on closure and set of possible sequential limits.*}
+
+lemma closure_sequential:
+ fixes l :: "'a::metric_space" (* TODO: generalize *)
+ shows "l \<in> closure S \<longleftrightarrow> (\<exists>x. (\<forall>n. x n \<in> S) \<and> (x ---> l) sequentially)" (is "?lhs = ?rhs")
+proof
+ assume "?lhs" moreover
+ { assume "l \<in> S"
+ hence "?rhs" using Lim_const[of l sequentially] by auto
+ } moreover
+ { assume "l islimpt S"
+ hence "?rhs" unfolding islimpt_sequential by auto
+ } ultimately
+ show "?rhs" unfolding closure_def by auto
+next
+ assume "?rhs"
+ thus "?lhs" unfolding closure_def unfolding islimpt_sequential by auto
+qed
+
+lemma closed_sequential_limits:
+ fixes S :: "'a::metric_space set"
+ shows "closed S \<longleftrightarrow> (\<forall>x l. (\<forall>n. x n \<in> S) \<and> (x ---> l) sequentially \<longrightarrow> l \<in> S)"
+ unfolding closed_limpt
+ using closure_sequential [where 'a='a] closure_closed [where 'a='a] closed_limpt [where 'a='a] islimpt_sequential [where 'a='a] mem_delete [where 'a='a]
+ by metis
+
+lemma closure_approachable:
+ fixes S :: "'a::metric_space set"
+ shows "x \<in> closure S \<longleftrightarrow> (\<forall>e>0. \<exists>y\<in>S. dist y x < e)"
+ apply (auto simp add: closure_def islimpt_approachable)
+ by (metis dist_self)
+
+lemma closed_approachable:
+ fixes S :: "'a::metric_space set"
+ shows "closed S ==> (\<forall>e>0. \<exists>y\<in>S. dist y x < e) \<longleftrightarrow> x \<in> S"
+ by (metis closure_closed closure_approachable)
+
+text{* Some other lemmas about sequences. *}
+
+lemma seq_offset:
+ fixes l :: "'a::metric_space" (* TODO: generalize *)
+ shows "(f ---> l) sequentially ==> ((\<lambda>i. f( i + k)) ---> l) sequentially"
+ apply (auto simp add: Lim_sequentially)
+ by (metis trans_le_add1 )
+
+lemma seq_offset_neg:
+ "(f ---> l) sequentially ==> ((\<lambda>i. f(i - k)) ---> l) sequentially"
+ apply (rule topological_tendstoI)
+ apply (drule (2) topological_tendstoD)
+ apply (simp only: eventually_sequentially)
+ apply (subgoal_tac "\<And>N k (n::nat). N + k <= n ==> N <= n - k")
+ apply metis
+ by arith
+
+lemma seq_offset_rev:
+ "((\<lambda>i. f(i + k)) ---> l) sequentially ==> (f ---> l) sequentially"
+ apply (rule topological_tendstoI)
+ apply (drule (2) topological_tendstoD)
+ apply (simp only: eventually_sequentially)
+ apply (subgoal_tac "\<And>N k (n::nat). N + k <= n ==> N <= n - k \<and> (n - k) + k = n")
+ by metis arith
+
+lemma seq_harmonic: "((\<lambda>n. inverse (real n)) ---> 0) sequentially"
+proof-
+ { fix e::real assume "e>0"
+ hence "\<exists>N::nat. \<forall>n::nat\<ge>N. inverse (real n) < e"
+ using real_arch_inv[of e] apply auto apply(rule_tac x=n in exI)
+ by (metis not_le le_imp_inverse_le not_less real_of_nat_gt_zero_cancel_iff real_of_nat_less_iff xt1(7))
+ }
+ thus ?thesis unfolding Lim_sequentially dist_norm by simp
+qed
+
+text{* More properties of closed balls. *}
+
+lemma closed_cball: "closed (cball x e)"
+unfolding cball_def closed_def
+unfolding Collect_neg_eq [symmetric] not_le
+apply (clarsimp simp add: open_dist, rename_tac y)
+apply (rule_tac x="dist x y - e" in exI, clarsimp)
+apply (rename_tac x')
+apply (cut_tac x=x and y=x' and z=y in dist_triangle)
+apply simp
+done
+
+lemma open_contains_cball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. cball x e \<subseteq> S)"
+proof-
+ { fix x and e::real assume "x\<in>S" "e>0" "ball x e \<subseteq> S"
+ hence "\<exists>d>0. cball x d \<subseteq> S" unfolding subset_eq by (rule_tac x="e/2" in exI, auto)
+ } moreover
+ { fix x and e::real assume "x\<in>S" "e>0" "cball x e \<subseteq> S"
+ hence "\<exists>d>0. ball x d \<subseteq> S" unfolding subset_eq apply(rule_tac x="e/2" in exI) by auto
+ } ultimately
+ show ?thesis unfolding open_contains_ball by auto
+qed
+
+lemma open_contains_cball_eq: "open S ==> (\<forall>x. x \<in> S \<longleftrightarrow> (\<exists>e>0. cball x e \<subseteq> S))"
+ by (metis open_contains_cball subset_eq order_less_imp_le centre_in_cball mem_def)
+
+lemma mem_interior_cball: "x \<in> interior S \<longleftrightarrow> (\<exists>e>0. cball x e \<subseteq> S)"
+ apply (simp add: interior_def, safe)
+ apply (force simp add: open_contains_cball)
+ apply (rule_tac x="ball x e" in exI)
+ apply (simp add: open_ball centre_in_ball subset_trans [OF ball_subset_cball])
+ done
+
+lemma islimpt_ball:
+ fixes x y :: "'a::{real_normed_vector,perfect_space}"
+ shows "y islimpt ball x e \<longleftrightarrow> 0 < e \<and> y \<in> cball x e" (is "?lhs = ?rhs")
+proof
+ assume "?lhs"
+ { assume "e \<le> 0"
+ hence *:"ball x e = {}" using ball_eq_empty[of x e] by auto
+ have False using `?lhs` unfolding * using islimpt_EMPTY[of y] by auto
+ }
+ hence "e > 0" by (metis not_less)
+ moreover
+ have "y \<in> cball x e" using closed_cball[of x e] islimpt_subset[of y "ball x e" "cball x e"] ball_subset_cball[of x e] `?lhs` unfolding closed_limpt by auto
+ ultimately show "?rhs" by auto
+next
+ assume "?rhs" hence "e>0" by auto
+ { fix d::real assume "d>0"
+ have "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
+ proof(cases "d \<le> dist x y")
+ case True thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
+ proof(cases "x=y")
+ case True hence False using `d \<le> dist x y` `d>0` by auto
+ thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d" by auto
+ next
+ case False
+
+ have "dist x (y - (d / (2 * dist y x)) *\<^sub>R (y - x))
+ = norm (x - y + (d / (2 * norm (y - x))) *\<^sub>R (y - x))"
+ unfolding mem_cball mem_ball dist_norm diff_diff_eq2 diff_add_eq[THEN sym] by auto
+ also have "\<dots> = \<bar>- 1 + d / (2 * norm (x - y))\<bar> * norm (x - y)"
+ using scaleR_left_distrib[of "- 1" "d / (2 * norm (y - x))", THEN sym, of "y - x"]
+ unfolding scaleR_minus_left scaleR_one
+ by (auto simp add: norm_minus_commute)
+ also have "\<dots> = \<bar>- norm (x - y) + d / 2\<bar>"
+ unfolding abs_mult_pos[of "norm (x - y)", OF norm_ge_zero[of "x - y"]]
+ unfolding real_add_mult_distrib using `x\<noteq>y`[unfolded dist_nz, unfolded dist_norm] by auto
+ also have "\<dots> \<le> e - d/2" using `d \<le> dist x y` and `d>0` and `?rhs` by(auto simp add: dist_norm)
+ finally have "y - (d / (2 * dist y x)) *\<^sub>R (y - x) \<in> ball x e" using `d>0` by auto
+
+ moreover
+
+ have "(d / (2*dist y x)) *\<^sub>R (y - x) \<noteq> 0"
+ using `x\<noteq>y`[unfolded dist_nz] `d>0` unfolding scaleR_eq_0_iff by (auto simp add: dist_commute)
+ moreover
+ have "dist (y - (d / (2 * dist y x)) *\<^sub>R (y - x)) y < d" unfolding dist_norm apply simp unfolding norm_minus_cancel
+ using `d>0` `x\<noteq>y`[unfolded dist_nz] dist_commute[of x y]
+ unfolding dist_norm by auto
+ ultimately show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d" by (rule_tac x="y - (d / (2*dist y x)) *\<^sub>R (y - x)" in bexI) auto
+ qed
+ next
+ case False hence "d > dist x y" by auto
+ show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
+ proof(cases "x=y")
+ case True
+ obtain z where **: "z \<noteq> y" "dist z y < min e d"
+ using perfect_choose_dist[of "min e d" y]
+ using `d > 0` `e>0` by auto
+ show "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
+ unfolding `x = y`
+ using `z \<noteq> y` **
+ by (rule_tac x=z in bexI, auto simp add: dist_commute)
+ next
+ case False thus "\<exists>x'\<in>ball x e. x' \<noteq> y \<and> dist x' y < d"
+ using `d>0` `d > dist x y` `?rhs` by(rule_tac x=x in bexI, auto)
+ qed
+ qed }
+ thus "?lhs" unfolding mem_cball islimpt_approachable mem_ball by auto
+qed
+
+lemma closure_ball_lemma:
+ fixes x y :: "'a::real_normed_vector"
+ assumes "x \<noteq> y" shows "y islimpt ball x (dist x y)"
+proof (rule islimptI)
+ fix T assume "y \<in> T" "open T"
+ then obtain r where "0 < r" "\<forall>z. dist z y < r \<longrightarrow> z \<in> T"
+ unfolding open_dist by fast
+ (* choose point between x and y, within distance r of y. *)
+ def k \<equiv> "min 1 (r / (2 * dist x y))"
+ def z \<equiv> "y + scaleR k (x - y)"
+ have z_def2: "z = x + scaleR (1 - k) (y - x)"
+ unfolding z_def by (simp add: algebra_simps)
+ have "dist z y < r"
+ unfolding z_def k_def using `0 < r`
+ by (simp add: dist_norm min_def)
+ hence "z \<in> T" using `\<forall>z. dist z y < r \<longrightarrow> z \<in> T` by simp
+ have "dist x z < dist x y"
+ unfolding z_def2 dist_norm
+ apply (simp add: norm_minus_commute)
+ apply (simp only: dist_norm [symmetric])
+ apply (subgoal_tac "\<bar>1 - k\<bar> * dist x y < 1 * dist x y", simp)
+ apply (rule mult_strict_right_mono)
+ apply (simp add: k_def divide_pos_pos zero_less_dist_iff `0 < r` `x \<noteq> y`)
+ apply (simp add: zero_less_dist_iff `x \<noteq> y`)
+ done
+ hence "z \<in> ball x (dist x y)" by simp
+ have "z \<noteq> y"
+ unfolding z_def k_def using `x \<noteq> y` `0 < r`
+ by (simp add: min_def)
+ show "\<exists>z\<in>ball x (dist x y). z \<in> T \<and> z \<noteq> y"
+ using `z \<in> ball x (dist x y)` `z \<in> T` `z \<noteq> y`
+ by fast
+qed
+
+lemma closure_ball:
+ fixes x :: "'a::real_normed_vector"
+ shows "0 < e \<Longrightarrow> closure (ball x e) = cball x e"
+apply (rule equalityI)
+apply (rule closure_minimal)
+apply (rule ball_subset_cball)
+apply (rule closed_cball)
+apply (rule subsetI, rename_tac y)
+apply (simp add: le_less [where 'a=real])
+apply (erule disjE)
+apply (rule subsetD [OF closure_subset], simp)
+apply (simp add: closure_def)
+apply clarify
+apply (rule closure_ball_lemma)
+apply (simp add: zero_less_dist_iff)
+done
+
+(* In a trivial vector space, this fails for e = 0. *)
+lemma interior_cball:
+ fixes x :: "'a::{real_normed_vector, perfect_space}"
+ shows "interior (cball x e) = ball x e"
+proof(cases "e\<ge>0")
+ case False note cs = this
+ from cs have "ball x e = {}" using ball_empty[of e x] by auto moreover
+ { fix y assume "y \<in> cball x e"
+ hence False unfolding mem_cball using dist_nz[of x y] cs by auto }
+ hence "cball x e = {}" by auto
+ hence "interior (cball x e) = {}" using interior_empty by auto
+ ultimately show ?thesis by blast
+next
+ case True note cs = this
+ have "ball x e \<subseteq> cball x e" using ball_subset_cball by auto moreover
+ { fix S y assume as: "S \<subseteq> cball x e" "open S" "y\<in>S"
+ then obtain d where "d>0" and d:"\<forall>x'. dist x' y < d \<longrightarrow> x' \<in> S" unfolding open_dist by blast
+
+ then obtain xa where xa_y: "xa \<noteq> y" and xa: "dist xa y < d"
+ using perfect_choose_dist [of d] by auto
+ have "xa\<in>S" using d[THEN spec[where x=xa]] using xa by(auto simp add: dist_commute)
+ hence xa_cball:"xa \<in> cball x e" using as(1) by auto
+
+ hence "y \<in> ball x e" proof(cases "x = y")
+ case True
+ hence "e>0" using xa_y[unfolded dist_nz] xa_cball[unfolded mem_cball] by (auto simp add: dist_commute)
+ thus "y \<in> ball x e" using `x = y ` by simp
+ next
+ case False
+ have "dist (y + (d / 2 / dist y x) *\<^sub>R (y - x)) y < d" unfolding dist_norm
+ using `d>0` norm_ge_zero[of "y - x"] `x \<noteq> y` by auto
+ hence *:"y + (d / 2 / dist y x) *\<^sub>R (y - x) \<in> cball x e" using d as(1)[unfolded subset_eq] by blast
+ have "y - x \<noteq> 0" using `x \<noteq> y` by auto
+ hence **:"d / (2 * norm (y - x)) > 0" unfolding zero_less_norm_iff[THEN sym]
+ using `d>0` divide_pos_pos[of d "2*norm (y - x)"] by auto
+
+ have "dist (y + (d / 2 / dist y x) *\<^sub>R (y - x)) x = norm (y + (d / (2 * norm (y - x))) *\<^sub>R y - (d / (2 * norm (y - x))) *\<^sub>R x - x)"
+ by (auto simp add: dist_norm algebra_simps)
+ also have "\<dots> = norm ((1 + d / (2 * norm (y - x))) *\<^sub>R (y - x))"
+ by (auto simp add: algebra_simps)
+ also have "\<dots> = \<bar>1 + d / (2 * norm (y - x))\<bar> * norm (y - x)"
+ using ** by auto
+ also have "\<dots> = (dist y x) + d/2"using ** by (auto simp add: left_distrib dist_norm)
+ finally have "e \<ge> dist x y +d/2" using *[unfolded mem_cball] by (auto simp add: dist_commute)
+ thus "y \<in> ball x e" unfolding mem_ball using `d>0` by auto
+ qed }
+ hence "\<forall>S \<subseteq> cball x e. open S \<longrightarrow> S \<subseteq> ball x e" by auto
+ ultimately show ?thesis using interior_unique[of "ball x e" "cball x e"] using open_ball[of x e] by auto
+qed
+
+lemma frontier_ball:
+ fixes a :: "'a::real_normed_vector"
+ shows "0 < e ==> frontier(ball a e) = {x. dist a x = e}"
+ apply (simp add: frontier_def closure_ball interior_open open_ball order_less_imp_le)
+ apply (simp add: expand_set_eq)
+ by arith
+
+lemma frontier_cball:
+ fixes a :: "'a::{real_normed_vector, perfect_space}"
+ shows "frontier(cball a e) = {x. dist a x = e}"
+ apply (simp add: frontier_def interior_cball closed_cball closure_closed order_less_imp_le)
+ apply (simp add: expand_set_eq)
+ by arith
+
+lemma cball_eq_empty: "(cball x e = {}) \<longleftrightarrow> e < 0"
+ apply (simp add: expand_set_eq not_le)
+ by (metis zero_le_dist dist_self order_less_le_trans)
+lemma cball_empty: "e < 0 ==> cball x e = {}" by (simp add: cball_eq_empty)
+
+lemma cball_eq_sing:
+ fixes x :: "'a::perfect_space"
+ shows "(cball x e = {x}) \<longleftrightarrow> e = 0"
+proof (rule linorder_cases)
+ assume e: "0 < e"
+ obtain a where "a \<noteq> x" "dist a x < e"
+ using perfect_choose_dist [OF e] by auto
+ hence "a \<noteq> x" "dist x a \<le> e" by (auto simp add: dist_commute)
+ with e show ?thesis by (auto simp add: expand_set_eq)
+qed auto
+
+lemma cball_sing:
+ fixes x :: "'a::metric_space"
+ shows "e = 0 ==> cball x e = {x}"
+ by (auto simp add: expand_set_eq)
+
+text{* For points in the interior, localization of limits makes no difference. *}
+
+lemma eventually_within_interior:
+ assumes "x \<in> interior S"
+ shows "eventually P (at x within S) \<longleftrightarrow> eventually P (at x)" (is "?lhs = ?rhs")
+proof-
+ from assms obtain T where T: "open T" "x \<in> T" "T \<subseteq> S"
+ unfolding interior_def by fast
+ { assume "?lhs"
+ then obtain A where "open A" "x \<in> A" "\<forall>y\<in>A. y \<noteq> x \<longrightarrow> y \<in> S \<longrightarrow> P y"
+ unfolding Limits.eventually_within Limits.eventually_at_topological
+ by auto
+ with T have "open (A \<inter> T)" "x \<in> A \<inter> T" "\<forall>y\<in>(A \<inter> T). y \<noteq> x \<longrightarrow> P y"
+ by auto
+ then have "?rhs"
+ unfolding Limits.eventually_at_topological by auto
+ } moreover
+ { assume "?rhs" hence "?lhs"
+ unfolding Limits.eventually_within
+ by (auto elim: eventually_elim1)
+ } ultimately
+ show "?thesis" ..
+qed
+
+lemma lim_within_interior:
+ "x \<in> interior S \<Longrightarrow> (f ---> l) (at x within S) \<longleftrightarrow> (f ---> l) (at x)"
+ unfolding tendsto_def by (simp add: eventually_within_interior)
+
+lemma netlimit_within_interior:
+ fixes x :: "'a::{perfect_space, real_normed_vector}"
+ (* FIXME: generalize to perfect_space *)
+ assumes "x \<in> interior S"
+ shows "netlimit(at x within S) = x" (is "?lhs = ?rhs")
+proof-
+ from assms obtain e::real where e:"e>0" "ball x e \<subseteq> S" using open_interior[of S] unfolding open_contains_ball using interior_subset[of S] by auto
+ hence "\<not> trivial_limit (at x within S)" using islimpt_subset[of x "ball x e" S] unfolding trivial_limit_within islimpt_ball centre_in_cball by auto
+ thus ?thesis using netlimit_within by auto
+qed
+
+subsection{* Boundedness. *}
+
+ (* FIXME: This has to be unified with BSEQ!! *)
+definition
+ bounded :: "'a::metric_space set \<Rightarrow> bool" where
+ "bounded S \<longleftrightarrow> (\<exists>x e. \<forall>y\<in>S. dist x y \<le> e)"
+
+lemma bounded_any_center: "bounded S \<longleftrightarrow> (\<exists>e. \<forall>y\<in>S. dist a y \<le> e)"
+unfolding bounded_def
+apply safe
+apply (rule_tac x="dist a x + e" in exI, clarify)
+apply (drule (1) bspec)
+apply (erule order_trans [OF dist_triangle add_left_mono])
+apply auto
+done
+
+lemma bounded_iff: "bounded S \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. norm x \<le> a)"
+unfolding bounded_any_center [where a=0]
+by (simp add: dist_norm)
+
+lemma bounded_empty[simp]: "bounded {}" by (simp add: bounded_def)
+lemma bounded_subset: "bounded T \<Longrightarrow> S \<subseteq> T ==> bounded S"
+ by (metis bounded_def subset_eq)
+
+lemma bounded_interior[intro]: "bounded S ==> bounded(interior S)"
+ by (metis bounded_subset interior_subset)
+
+lemma bounded_closure[intro]: assumes "bounded S" shows "bounded(closure S)"
+proof-
+ from assms obtain x and a where a: "\<forall>y\<in>S. dist x y \<le> a" unfolding bounded_def by auto
+ { fix y assume "y \<in> closure S"
+ then obtain f where f: "\<forall>n. f n \<in> S" "(f ---> y) sequentially"
+ unfolding closure_sequential by auto
+ have "\<forall>n. f n \<in> S \<longrightarrow> dist x (f n) \<le> a" using a by simp
+ hence "eventually (\<lambda>n. dist x (f n) \<le> a) sequentially"
+ by (rule eventually_mono, simp add: f(1))
+ have "dist x y \<le> a"
+ apply (rule Lim_dist_ubound [of sequentially f])
+ apply (rule trivial_limit_sequentially)
+ apply (rule f(2))
+ apply fact
+ done
+ }
+ thus ?thesis unfolding bounded_def by auto
+qed
+
+lemma bounded_cball[simp,intro]: "bounded (cball x e)"
+ apply (simp add: bounded_def)
+ apply (rule_tac x=x in exI)
+ apply (rule_tac x=e in exI)
+ apply auto
+ done
+
+lemma bounded_ball[simp,intro]: "bounded(ball x e)"
+ by (metis ball_subset_cball bounded_cball bounded_subset)
+
+lemma finite_imp_bounded[intro]: assumes "finite S" shows "bounded S"
+proof-
+ { fix a F assume as:"bounded F"
+ then obtain x e where "\<forall>y\<in>F. dist x y \<le> e" unfolding bounded_def by auto
+ hence "\<forall>y\<in>(insert a F). dist x y \<le> max e (dist x a)" by auto
+ hence "bounded (insert a F)" unfolding bounded_def by (intro exI)
+ }
+ thus ?thesis using finite_induct[of S bounded] using bounded_empty assms by auto
+qed
+
+lemma bounded_Un[simp]: "bounded (S \<union> T) \<longleftrightarrow> bounded S \<and> bounded T"
+ apply (auto simp add: bounded_def)
+ apply (rename_tac x y r s)
+ apply (rule_tac x=x in exI)
+ apply (rule_tac x="max r (dist x y + s)" in exI)
+ apply (rule ballI, rename_tac z, safe)
+ apply (drule (1) bspec, simp)
+ apply (drule (1) bspec)
+ apply (rule min_max.le_supI2)
+ apply (erule order_trans [OF dist_triangle add_left_mono])
+ done
+
+lemma bounded_Union[intro]: "finite F \<Longrightarrow> (\<forall>S\<in>F. bounded S) \<Longrightarrow> bounded(\<Union>F)"
+ by (induct rule: finite_induct[of F], auto)
+
+lemma bounded_pos: "bounded S \<longleftrightarrow> (\<exists>b>0. \<forall>x\<in> S. norm x <= b)"
+ apply (simp add: bounded_iff)
+ apply (subgoal_tac "\<And>x (y::real). 0 < 1 + abs y \<and> (x <= y \<longrightarrow> x <= 1 + abs y)")
+ by metis arith
+
+lemma bounded_Int[intro]: "bounded S \<or> bounded T \<Longrightarrow> bounded (S \<inter> T)"
+ by (metis Int_lower1 Int_lower2 bounded_subset)
+
+lemma bounded_diff[intro]: "bounded S ==> bounded (S - T)"
+apply (metis Diff_subset bounded_subset)
+done
+
+lemma bounded_insert[intro]:"bounded(insert x S) \<longleftrightarrow> bounded S"
+ by (metis Diff_cancel Un_empty_right Un_insert_right bounded_Un bounded_subset finite.emptyI finite_imp_bounded infinite_remove subset_insertI)
+
+lemma not_bounded_UNIV[simp, intro]:
+ "\<not> bounded (UNIV :: 'a::{real_normed_vector, perfect_space} set)"
+proof(auto simp add: bounded_pos not_le)
+ obtain x :: 'a where "x \<noteq> 0"
+ using perfect_choose_dist [OF zero_less_one] by fast
+ fix b::real assume b: "b >0"
+ have b1: "b +1 \<ge> 0" using b by simp
+ with `x \<noteq> 0` have "b < norm (scaleR (b + 1) (sgn x))"
+ by (simp add: norm_sgn)
+ then show "\<exists>x::'a. b < norm x" ..
+qed
+
+lemma bounded_linear_image:
+ assumes "bounded S" "bounded_linear f"
+ shows "bounded(f ` S)"
+proof-
+ from assms(1) obtain b where b:"b>0" "\<forall>x\<in>S. norm x \<le> b" unfolding bounded_pos by auto
+ from assms(2) obtain B where B:"B>0" "\<forall>x. norm (f x) \<le> B * norm x" using bounded_linear.pos_bounded by (auto simp add: mult_ac)
+ { fix x assume "x\<in>S"
+ hence "norm x \<le> b" using b by auto
+ hence "norm (f x) \<le> B * b" using B(2) apply(erule_tac x=x in allE)
+ by (metis B(1) B(2) real_le_trans real_mult_le_cancel_iff2)
+ }
+ thus ?thesis unfolding bounded_pos apply(rule_tac x="b*B" in exI)
+ using b B real_mult_order[of b B] by (auto simp add: real_mult_commute)
+qed
+
+lemma bounded_scaling:
+ fixes S :: "'a::real_normed_vector set"
+ shows "bounded S \<Longrightarrow> bounded ((\<lambda>x. c *\<^sub>R x) ` S)"
+ apply (rule bounded_linear_image, assumption)
+ apply (rule scaleR.bounded_linear_right)
+ done
+
+lemma bounded_translation:
+ fixes S :: "'a::real_normed_vector set"
+ assumes "bounded S" shows "bounded ((\<lambda>x. a + x) ` S)"
+proof-
+ from assms obtain b where b:"b>0" "\<forall>x\<in>S. norm x \<le> b" unfolding bounded_pos by auto
+ { fix x assume "x\<in>S"
+ hence "norm (a + x) \<le> b + norm a" using norm_triangle_ineq[of a x] b by auto
+ }
+ thus ?thesis unfolding bounded_pos using norm_ge_zero[of a] b(1) using add_strict_increasing[of b 0 "norm a"]
+ by (auto intro!: add exI[of _ "b + norm a"])
+qed
+
+
+text{* Some theorems on sups and infs using the notion "bounded". *}
+
+lemma bounded_real:
+ fixes S :: "real set"
+ shows "bounded S \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. abs x <= a)"
+ by (simp add: bounded_iff)
+
+lemma bounded_has_Sup:
+ fixes S :: "real set"
+ assumes "bounded S" "S \<noteq> {}"
+ shows "\<forall>x\<in>S. x <= Sup S" and "\<forall>b. (\<forall>x\<in>S. x <= b) \<longrightarrow> Sup S <= b"
+proof
+ fix x assume "x\<in>S"
+ thus "x \<le> Sup S"
+ by (metis SupInf.Sup_upper abs_le_D1 assms(1) bounded_real)
+next
+ show "\<forall>b. (\<forall>x\<in>S. x \<le> b) \<longrightarrow> Sup S \<le> b" using assms
+ by (metis SupInf.Sup_least)
+qed
+
+lemma Sup_insert:
+ fixes S :: "real set"
+ shows "bounded S ==> Sup(insert x S) = (if S = {} then x else max x (Sup S))"
+by auto (metis Int_absorb Sup_insert_nonempty assms bounded_has_Sup(1) disjoint_iff_not_equal)
+
+lemma Sup_insert_finite:
+ fixes S :: "real set"
+ shows "finite S \<Longrightarrow> Sup(insert x S) = (if S = {} then x else max x (Sup S))"
+ apply (rule Sup_insert)
+ apply (rule finite_imp_bounded)
+ by simp
+
+lemma bounded_has_Inf:
+ fixes S :: "real set"
+ assumes "bounded S" "S \<noteq> {}"
+ shows "\<forall>x\<in>S. x >= Inf S" and "\<forall>b. (\<forall>x\<in>S. x >= b) \<longrightarrow> Inf S >= b"
+proof
+ fix x assume "x\<in>S"
+ from assms(1) obtain a where a:"\<forall>x\<in>S. \<bar>x\<bar> \<le> a" unfolding bounded_real by auto
+ thus "x \<ge> Inf S" using `x\<in>S`
+ by (metis Inf_lower_EX abs_le_D2 minus_le_iff)
+next
+ show "\<forall>b. (\<forall>x\<in>S. x >= b) \<longrightarrow> Inf S \<ge> b" using assms
+ by (metis SupInf.Inf_greatest)
+qed
+
+lemma Inf_insert:
+ fixes S :: "real set"
+ shows "bounded S ==> Inf(insert x S) = (if S = {} then x else min x (Inf S))"
+by auto (metis Int_absorb Inf_insert_nonempty bounded_has_Inf(1) disjoint_iff_not_equal)
+lemma Inf_insert_finite:
+ fixes S :: "real set"
+ shows "finite S ==> Inf(insert x S) = (if S = {} then x else min x (Inf S))"
+ by (rule Inf_insert, rule finite_imp_bounded, simp)
+
+
+(* TODO: Move this to RComplete.thy -- would need to include Glb into RComplete *)
+lemma real_isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::real)"
+ apply (frule isGlb_isLb)
+ apply (frule_tac x = y in isGlb_isLb)
+ apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
+ done
+
+subsection{* Compactness (the definition is the one based on convegent subsequences). *}
+
+definition
+ compact :: "'a::metric_space set \<Rightarrow> bool" where (* TODO: generalize *)
+ "compact S \<longleftrightarrow>
+ (\<forall>f. (\<forall>n. f n \<in> S) \<longrightarrow>
+ (\<exists>l\<in>S. \<exists>r. subseq r \<and> ((f o r) ---> l) sequentially))"
+
+text {*
+ A metric space (or topological vector space) is said to have the
+ Heine-Borel property if every closed and bounded subset is compact.
+*}
+
+class heine_borel =
+ assumes bounded_imp_convergent_subsequence:
+ "bounded s \<Longrightarrow> \<forall>n. f n \<in> s
+ \<Longrightarrow> \<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
+
+lemma bounded_closed_imp_compact:
+ fixes s::"'a::heine_borel set"
+ assumes "bounded s" and "closed s" shows "compact s"
+proof (unfold compact_def, clarify)
+ fix f :: "nat \<Rightarrow> 'a" assume f: "\<forall>n. f n \<in> s"
+ obtain l r where r: "subseq r" and l: "((f \<circ> r) ---> l) sequentially"
+ using bounded_imp_convergent_subsequence [OF `bounded s` `\<forall>n. f n \<in> s`] by auto
+ from f have fr: "\<forall>n. (f \<circ> r) n \<in> s" by simp
+ have "l \<in> s" using `closed s` fr l
+ unfolding closed_sequential_limits by blast
+ show "\<exists>l\<in>s. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
+ using `l \<in> s` r l by blast
+qed
+
+lemma subseq_bigger: assumes "subseq r" shows "n \<le> r n"
+proof(induct n)
+ show "0 \<le> r 0" by auto
+next
+ fix n assume "n \<le> r n"
+ moreover have "r n < r (Suc n)"
+ using assms [unfolded subseq_def] by auto
+ ultimately show "Suc n \<le> r (Suc n)" by auto
+qed
+
+lemma eventually_subseq:
+ assumes r: "subseq r"
+ shows "eventually P sequentially \<Longrightarrow> eventually (\<lambda>n. P (r n)) sequentially"
+unfolding eventually_sequentially
+by (metis subseq_bigger [OF r] le_trans)
+
+lemma lim_subseq:
+ "subseq r \<Longrightarrow> (s ---> l) sequentially \<Longrightarrow> ((s o r) ---> l) sequentially"
+unfolding tendsto_def eventually_sequentially o_def
+by (metis subseq_bigger le_trans)
+
+lemma num_Axiom: "EX! g. g 0 = e \<and> (\<forall>n. g (Suc n) = f n (g n))"
+ unfolding Ex1_def
+ apply (rule_tac x="nat_rec e f" in exI)
+ apply (rule conjI)+
+apply (rule def_nat_rec_0, simp)
+apply (rule allI, rule def_nat_rec_Suc, simp)
+apply (rule allI, rule impI, rule ext)
+apply (erule conjE)
+apply (induct_tac x)
+apply (simp add: nat_rec_0)
+apply (erule_tac x="n" in allE)
+apply (simp)
+done
+
+lemma convergent_bounded_increasing: fixes s ::"nat\<Rightarrow>real"
+ assumes "incseq s" and "\<forall>n. abs(s n) \<le> b"
+ shows "\<exists> l. \<forall>e::real>0. \<exists> N. \<forall>n \<ge> N. abs(s n - l) < e"
+proof-
+ have "isUb UNIV (range s) b" using assms(2) and abs_le_D1 unfolding isUb_def and setle_def by auto
+ then obtain t where t:"isLub UNIV (range s) t" using reals_complete[of "range s" ] by auto
+ { fix e::real assume "e>0" and as:"\<forall>N. \<exists>n\<ge>N. \<not> \<bar>s n - t\<bar> < e"
+ { fix n::nat
+ obtain N where "N\<ge>n" and n:"\<bar>s N - t\<bar> \<ge> e" using as[THEN spec[where x=n]] by auto
+ have "t \<ge> s N" using isLub_isUb[OF t, unfolded isUb_def setle_def] by auto
+ with n have "s N \<le> t - e" using `e>0` by auto
+ hence "s n \<le> t - e" using assms(1)[unfolded incseq_def, THEN spec[where x=n], THEN spec[where x=N]] using `n\<le>N` by auto }
+ hence "isUb UNIV (range s) (t - e)" unfolding isUb_def and setle_def by auto
+ hence False using isLub_le_isUb[OF t, of "t - e"] and `e>0` by auto }
+ thus ?thesis by blast
+qed
+
+lemma convergent_bounded_monotone: fixes s::"nat \<Rightarrow> real"
+ assumes "\<forall>n. abs(s n) \<le> b" and "monoseq s"
+ shows "\<exists>l. \<forall>e::real>0. \<exists>N. \<forall>n\<ge>N. abs(s n - l) < e"
+ using convergent_bounded_increasing[of s b] assms using convergent_bounded_increasing[of "\<lambda>n. - s n" b]
+ unfolding monoseq_def incseq_def
+ apply auto unfolding minus_add_distrib[THEN sym, unfolded diff_minus[THEN sym]]
+ unfolding abs_minus_cancel by(rule_tac x="-l" in exI)auto
+
+lemma compact_real_lemma:
+ assumes "\<forall>n::nat. abs(s n) \<le> b"
+ shows "\<exists>(l::real) r. subseq r \<and> ((s \<circ> r) ---> l) sequentially"
+proof-
+ obtain r where r:"subseq r" "monoseq (\<lambda>n. s (r n))"
+ using seq_monosub[of s] by auto
+ thus ?thesis using convergent_bounded_monotone[of "\<lambda>n. s (r n)" b] and assms
+ unfolding tendsto_iff dist_norm eventually_sequentially by auto
+qed
+
+instance real :: heine_borel
+proof
+ fix s :: "real set" and f :: "nat \<Rightarrow> real"
+ assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
+ then obtain b where b: "\<forall>n. abs (f n) \<le> b"
+ unfolding bounded_iff by auto
+ obtain l :: real and r :: "nat \<Rightarrow> nat" where
+ r: "subseq r" and l: "((f \<circ> r) ---> l) sequentially"
+ using compact_real_lemma [OF b] by auto
+ thus "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
+ by auto
+qed
+
+lemma bounded_component: "bounded s \<Longrightarrow> bounded ((\<lambda>x. x $ i) ` s)"
+unfolding bounded_def
+apply clarify
+apply (rule_tac x="x $ i" in exI)
+apply (rule_tac x="e" in exI)
+apply clarify
+apply (rule order_trans [OF dist_nth_le], simp)
+done
+
+lemma compact_lemma:
+ fixes f :: "nat \<Rightarrow> 'a::heine_borel ^ 'n::finite"
+ assumes "bounded s" and "\<forall>n. f n \<in> s"
+ shows "\<forall>d.
+ \<exists>l r. subseq r \<and>
+ (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) $ i) (l $ i) < e) sequentially)"
+proof
+ fix d::"'n set" have "finite d" by simp
+ thus "\<exists>l::'a ^ 'n. \<exists>r. subseq r \<and>
+ (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) $ i) (l $ i) < e) sequentially)"
+ proof(induct d) case empty thus ?case unfolding subseq_def by auto
+ next case (insert k d)
+ have s': "bounded ((\<lambda>x. x $ k) ` s)" using `bounded s` by (rule bounded_component)
+ obtain l1::"'a^'n" and r1 where r1:"subseq r1" and lr1:"\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 n) $ i) (l1 $ i) < e) sequentially"
+ using insert(3) by auto
+ have f': "\<forall>n. f (r1 n) $ k \<in> (\<lambda>x. x $ k) ` s" using `\<forall>n. f n \<in> s` by simp
+ obtain l2 r2 where r2:"subseq r2" and lr2:"((\<lambda>i. f (r1 (r2 i)) $ k) ---> l2) sequentially"
+ using bounded_imp_convergent_subsequence[OF s' f'] unfolding o_def by auto
+ def r \<equiv> "r1 \<circ> r2" have r:"subseq r"
+ using r1 and r2 unfolding r_def o_def subseq_def by auto
+ moreover
+ def l \<equiv> "(\<chi> i. if i = k then l2 else l1$i)::'a^'n"
+ { fix e::real assume "e>0"
+ from lr1 `e>0` have N1:"eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 n) $ i) (l1 $ i) < e) sequentially" by blast
+ from lr2 `e>0` have N2:"eventually (\<lambda>n. dist (f (r1 (r2 n)) $ k) l2 < e) sequentially" by (rule tendstoD)
+ from r2 N1 have N1': "eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r1 (r2 n)) $ i) (l1 $ i) < e) sequentially"
+ by (rule eventually_subseq)
+ have "eventually (\<lambda>n. \<forall>i\<in>(insert k d). dist (f (r n) $ i) (l $ i) < e) sequentially"
+ using N1' N2 by (rule eventually_elim2, simp add: l_def r_def)
+ }
+ ultimately show ?case by auto
+ qed
+qed
+
+instance "^" :: (heine_borel, finite) heine_borel
+proof
+ fix s :: "('a ^ 'b) set" and f :: "nat \<Rightarrow> 'a ^ 'b"
+ assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
+ then obtain l r where r: "subseq r"
+ and l: "\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>UNIV. dist (f (r n) $ i) (l $ i) < e) sequentially"
+ using compact_lemma [OF s f] by blast
+ let ?d = "UNIV::'b set"
+ { fix e::real assume "e>0"
+ hence "0 < e / (real_of_nat (card ?d))"
+ using zero_less_card_finite using divide_pos_pos[of e, of "real_of_nat (card ?d)"] by auto
+ with l have "eventually (\<lambda>n. \<forall>i. dist (f (r n) $ i) (l $ i) < e / (real_of_nat (card ?d))) sequentially"
+ by simp
+ moreover
+ { fix n assume n: "\<forall>i. dist (f (r n) $ i) (l $ i) < e / (real_of_nat (card ?d))"
+ have "dist (f (r n)) l \<le> (\<Sum>i\<in>?d. dist (f (r n) $ i) (l $ i))"
+ unfolding dist_vector_def using zero_le_dist by (rule setL2_le_setsum)
+ also have "\<dots> < (\<Sum>i\<in>?d. e / (real_of_nat (card ?d)))"
+ by (rule setsum_strict_mono) (simp_all add: n)
+ finally have "dist (f (r n)) l < e" by simp
+ }
+ ultimately have "eventually (\<lambda>n. dist (f (r n)) l < e) sequentially"
+ by (rule eventually_elim1)
+ }
+ hence *:"((f \<circ> r) ---> l) sequentially" unfolding o_def tendsto_iff by simp
+ with r show "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially" by auto
+qed
+
+lemma bounded_fst: "bounded s \<Longrightarrow> bounded (fst ` s)"
+unfolding bounded_def
+apply clarify
+apply (rule_tac x="a" in exI)
+apply (rule_tac x="e" in exI)
+apply clarsimp
+apply (drule (1) bspec)
+apply (simp add: dist_Pair_Pair)
+apply (erule order_trans [OF real_sqrt_sum_squares_ge1])
+done
+
+lemma bounded_snd: "bounded s \<Longrightarrow> bounded (snd ` s)"
+unfolding bounded_def
+apply clarify
+apply (rule_tac x="b" in exI)
+apply (rule_tac x="e" in exI)
+apply clarsimp
+apply (drule (1) bspec)
+apply (simp add: dist_Pair_Pair)
+apply (erule order_trans [OF real_sqrt_sum_squares_ge2])
+done
+
+instance "*" :: (heine_borel, heine_borel) heine_borel
+proof
+ fix s :: "('a * 'b) set" and f :: "nat \<Rightarrow> 'a * 'b"
+ assume s: "bounded s" and f: "\<forall>n. f n \<in> s"
+ from s have s1: "bounded (fst ` s)" by (rule bounded_fst)
+ from f have f1: "\<forall>n. fst (f n) \<in> fst ` s" by simp
+ obtain l1 r1 where r1: "subseq r1"
+ and l1: "((\<lambda>n. fst (f (r1 n))) ---> l1) sequentially"
+ using bounded_imp_convergent_subsequence [OF s1 f1]
+ unfolding o_def by fast
+ from s have s2: "bounded (snd ` s)" by (rule bounded_snd)
+ from f have f2: "\<forall>n. snd (f (r1 n)) \<in> snd ` s" by simp
+ obtain l2 r2 where r2: "subseq r2"
+ and l2: "((\<lambda>n. snd (f (r1 (r2 n)))) ---> l2) sequentially"
+ using bounded_imp_convergent_subsequence [OF s2 f2]
+ unfolding o_def by fast
+ have l1': "((\<lambda>n. fst (f (r1 (r2 n)))) ---> l1) sequentially"
+ using lim_subseq [OF r2 l1] unfolding o_def .
+ have l: "((f \<circ> (r1 \<circ> r2)) ---> (l1, l2)) sequentially"
+ using tendsto_Pair [OF l1' l2] unfolding o_def by simp
+ have r: "subseq (r1 \<circ> r2)"
+ using r1 r2 unfolding subseq_def by simp
+ show "\<exists>l r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
+ using l r by fast
+qed
+
+subsection{* Completeness. *}
+
+lemma cauchy_def:
+ "Cauchy s \<longleftrightarrow> (\<forall>e>0. \<exists>N. \<forall>m n. m \<ge> N \<and> n \<ge> N --> dist(s m)(s n) < e)"
+unfolding Cauchy_def by blast
+
+definition
+ complete :: "'a::metric_space set \<Rightarrow> bool" where
+ "complete s \<longleftrightarrow> (\<forall>f. (\<forall>n. f n \<in> s) \<and> Cauchy f
+ --> (\<exists>l \<in> s. (f ---> l) sequentially))"
+
+lemma cauchy: "Cauchy s \<longleftrightarrow> (\<forall>e>0.\<exists> N::nat. \<forall>n\<ge>N. dist(s n)(s N) < e)" (is "?lhs = ?rhs")
+proof-
+ { assume ?rhs
+ { fix e::real
+ assume "e>0"
+ with `?rhs` obtain N where N:"\<forall>n\<ge>N. dist (s n) (s N) < e/2"
+ by (erule_tac x="e/2" in allE) auto
+ { fix n m
+ assume nm:"N \<le> m \<and> N \<le> n"
+ hence "dist (s m) (s n) < e" using N
+ using dist_triangle_half_l[of "s m" "s N" "e" "s n"]
+ by blast
+ }
+ hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < e"
+ by blast
+ }
+ hence ?lhs
+ unfolding cauchy_def
+ by blast
+ }
+ thus ?thesis
+ unfolding cauchy_def
+ using dist_triangle_half_l
+ by blast
+qed
+
+lemma convergent_imp_cauchy:
+ "(s ---> l) sequentially ==> Cauchy s"
+proof(simp only: cauchy_def, rule, rule)
+ fix e::real assume "e>0" "(s ---> l) sequentially"
+ then obtain N::nat where N:"\<forall>n\<ge>N. dist (s n) l < e/2" unfolding Lim_sequentially by(erule_tac x="e/2" in allE) auto
+ thus "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < e" using dist_triangle_half_l[of _ l e _] by (rule_tac x=N in exI) auto
+qed
+
+lemma cauchy_imp_bounded: assumes "Cauchy s" shows "bounded {y. (\<exists>n::nat. y = s n)}"
+proof-
+ from assms obtain N::nat where "\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (s m) (s n) < 1" unfolding cauchy_def apply(erule_tac x= 1 in allE) by auto
+ hence N:"\<forall>n. N \<le> n \<longrightarrow> dist (s N) (s n) < 1" by auto
+ moreover
+ have "bounded (s ` {0..N})" using finite_imp_bounded[of "s ` {1..N}"] by auto
+ then obtain a where a:"\<forall>x\<in>s ` {0..N}. dist (s N) x \<le> a"
+ unfolding bounded_any_center [where a="s N"] by auto
+ ultimately show "?thesis"
+ unfolding bounded_any_center [where a="s N"]
+ apply(rule_tac x="max a 1" in exI) apply auto
+ apply(erule_tac x=n in allE) apply(erule_tac x=n in ballE) by auto
+qed
+
+lemma compact_imp_complete: assumes "compact s" shows "complete s"
+proof-
+ { fix f assume as: "(\<forall>n::nat. f n \<in> s)" "Cauchy f"
+ from as(1) obtain l r where lr: "l\<in>s" "subseq r" "((f \<circ> r) ---> l) sequentially" using assms unfolding compact_def by blast
+
+ note lr' = subseq_bigger [OF lr(2)]
+
+ { fix e::real assume "e>0"
+ from as(2) obtain N where N:"\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (f m) (f n) < e/2" unfolding cauchy_def using `e>0` apply (erule_tac x="e/2" in allE) by auto
+ from lr(3)[unfolded Lim_sequentially, THEN spec[where x="e/2"]] obtain M where M:"\<forall>n\<ge>M. dist ((f \<circ> r) n) l < e/2" using `e>0` by auto
+ { fix n::nat assume n:"n \<ge> max N M"
+ have "dist ((f \<circ> r) n) l < e/2" using n M by auto
+ moreover have "r n \<ge> N" using lr'[of n] n by auto
+ hence "dist (f n) ((f \<circ> r) n) < e / 2" using N using n by auto
+ ultimately have "dist (f n) l < e" using dist_triangle_half_r[of "f (r n)" "f n" e l] by (auto simp add: dist_commute) }
+ hence "\<exists>N. \<forall>n\<ge>N. dist (f n) l < e" by blast }
+ hence "\<exists>l\<in>s. (f ---> l) sequentially" using `l\<in>s` unfolding Lim_sequentially by auto }
+ thus ?thesis unfolding complete_def by auto
+qed
+
+instance heine_borel < complete_space
+proof
+ fix f :: "nat \<Rightarrow> 'a" assume "Cauchy f"
+ hence "bounded (range f)" unfolding image_def
+ using cauchy_imp_bounded [of f] by auto
+ hence "compact (closure (range f))"
+ using bounded_closed_imp_compact [of "closure (range f)"] by auto
+ hence "complete (closure (range f))"
+ using compact_imp_complete by auto
+ moreover have "\<forall>n. f n \<in> closure (range f)"
+ using closure_subset [of "range f"] by auto
+ ultimately have "\<exists>l\<in>closure (range f). (f ---> l) sequentially"
+ using `Cauchy f` unfolding complete_def by auto
+ then show "convergent f"
+ unfolding convergent_def LIMSEQ_conv_tendsto [symmetric] by auto
+qed
+
+lemma complete_univ: "complete (UNIV :: 'a::complete_space set)"
+proof(simp add: complete_def, rule, rule)
+ fix f :: "nat \<Rightarrow> 'a" assume "Cauchy f"
+ hence "convergent f" by (rule Cauchy_convergent)
+ hence "\<exists>l. f ----> l" unfolding convergent_def .
+ thus "\<exists>l. (f ---> l) sequentially" unfolding LIMSEQ_conv_tendsto .
+qed
+
+lemma complete_imp_closed: assumes "complete s" shows "closed s"
+proof -
+ { fix x assume "x islimpt s"
+ then obtain f where f: "\<forall>n. f n \<in> s - {x}" "(f ---> x) sequentially"
+ unfolding islimpt_sequential by auto
+ then obtain l where l: "l\<in>s" "(f ---> l) sequentially"
+ using `complete s`[unfolded complete_def] using convergent_imp_cauchy[of f x] by auto
+ hence "x \<in> s" using Lim_unique[of sequentially f l x] trivial_limit_sequentially f(2) by auto
+ }
+ thus "closed s" unfolding closed_limpt by auto
+qed
+
+lemma complete_eq_closed:
+ fixes s :: "'a::complete_space set"
+ shows "complete s \<longleftrightarrow> closed s" (is "?lhs = ?rhs")
+proof
+ assume ?lhs thus ?rhs by (rule complete_imp_closed)
+next
+ assume ?rhs
+ { fix f assume as:"\<forall>n::nat. f n \<in> s" "Cauchy f"
+ then obtain l where "(f ---> l) sequentially" using complete_univ[unfolded complete_def, THEN spec[where x=f]] by auto
+ hence "\<exists>l\<in>s. (f ---> l) sequentially" using `?rhs`[unfolded closed_sequential_limits, THEN spec[where x=f], THEN spec[where x=l]] using as(1) by auto }
+ thus ?lhs unfolding complete_def by auto
+qed
+
+lemma convergent_eq_cauchy:
+ fixes s :: "nat \<Rightarrow> 'a::complete_space"
+ shows "(\<exists>l. (s ---> l) sequentially) \<longleftrightarrow> Cauchy s" (is "?lhs = ?rhs")
+proof
+ assume ?lhs then obtain l where "(s ---> l) sequentially" by auto
+ thus ?rhs using convergent_imp_cauchy by auto
+next
+ assume ?rhs thus ?lhs using complete_univ[unfolded complete_def, THEN spec[where x=s]] by auto
+qed
+
+lemma convergent_imp_bounded:
+ fixes s :: "nat \<Rightarrow> 'a::metric_space"
+ shows "(s ---> l) sequentially ==> bounded (s ` (UNIV::(nat set)))"
+ using convergent_imp_cauchy[of s]
+ using cauchy_imp_bounded[of s]
+ unfolding image_def
+ by auto
+
+subsection{* Total boundedness. *}
+
+fun helper_1::"('a::metric_space set) \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> 'a" where
+ "helper_1 s e n = (SOME y::'a. y \<in> s \<and> (\<forall>m<n. \<not> (dist (helper_1 s e m) y < e)))"
+declare helper_1.simps[simp del]
+
+lemma compact_imp_totally_bounded:
+ assumes "compact s"
+ shows "\<forall>e>0. \<exists>k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> (\<Union>((\<lambda>x. ball x e) ` k))"
+proof(rule, rule, rule ccontr)
+ fix e::real assume "e>0" and assm:"\<not> (\<exists>k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k)"
+ def x \<equiv> "helper_1 s e"
+ { fix n
+ have "x n \<in> s \<and> (\<forall>m<n. \<not> dist (x m) (x n) < e)"
+ proof(induct_tac rule:nat_less_induct)
+ fix n def Q \<equiv> "(\<lambda>y. y \<in> s \<and> (\<forall>m<n. \<not> dist (x m) y < e))"
+ assume as:"\<forall>m<n. x m \<in> s \<and> (\<forall>ma<m. \<not> dist (x ma) (x m) < e)"
+ have "\<not> s \<subseteq> (\<Union>x\<in>x ` {0..<n}. ball x e)" using assm apply simp apply(erule_tac x="x ` {0 ..< n}" in allE) using as by auto
+ then obtain z where z:"z\<in>s" "z \<notin> (\<Union>x\<in>x ` {0..<n}. ball x e)" unfolding subset_eq by auto
+ have "Q (x n)" unfolding x_def and helper_1.simps[of s e n]
+ apply(rule someI2[where a=z]) unfolding x_def[symmetric] and Q_def using z by auto
+ thus "x n \<in> s \<and> (\<forall>m<n. \<not> dist (x m) (x n) < e)" unfolding Q_def by auto
+ qed }
+ hence "\<forall>n::nat. x n \<in> s" and x:"\<forall>n. \<forall>m < n. \<not> (dist (x m) (x n) < e)" by blast+
+ then obtain l r where "l\<in>s" and r:"subseq r" and "((x \<circ> r) ---> l) sequentially" using assms(1)[unfolded compact_def, THEN spec[where x=x]] by auto
+ from this(3) have "Cauchy (x \<circ> r)" using convergent_imp_cauchy by auto
+ then obtain N::nat where N:"\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist ((x \<circ> r) m) ((x \<circ> r) n) < e" unfolding cauchy_def using `e>0` by auto
+ show False
+ using N[THEN spec[where x=N], THEN spec[where x="N+1"]]
+ using r[unfolded subseq_def, THEN spec[where x=N], THEN spec[where x="N+1"]]
+ using x[THEN spec[where x="r (N+1)"], THEN spec[where x="r (N)"]] by auto
+qed
+
+subsection{* Heine-Borel theorem (following Burkill \& Burkill vol. 2) *}
+
+lemma heine_borel_lemma: fixes s::"'a::metric_space set"
+ assumes "compact s" "s \<subseteq> (\<Union> t)" "\<forall>b \<in> t. open b"
+ shows "\<exists>e>0. \<forall>x \<in> s. \<exists>b \<in> t. ball x e \<subseteq> b"
+proof(rule ccontr)
+ assume "\<not> (\<exists>e>0. \<forall>x\<in>s. \<exists>b\<in>t. ball x e \<subseteq> b)"
+ hence cont:"\<forall>e>0. \<exists>x\<in>s. \<forall>xa\<in>t. \<not> (ball x e \<subseteq> xa)" by auto
+ { fix n::nat
+ have "1 / real (n + 1) > 0" by auto
+ hence "\<exists>x. x\<in>s \<and> (\<forall>xa\<in>t. \<not> (ball x (inverse (real (n+1))) \<subseteq> xa))" using cont unfolding Bex_def by auto }
+ hence "\<forall>n::nat. \<exists>x. x \<in> s \<and> (\<forall>xa\<in>t. \<not> ball x (inverse (real (n + 1))) \<subseteq> xa)" by auto
+ then obtain f where f:"\<forall>n::nat. f n \<in> s \<and> (\<forall>xa\<in>t. \<not> ball (f n) (inverse (real (n + 1))) \<subseteq> xa)"
+ using choice[of "\<lambda>n::nat. \<lambda>x. x\<in>s \<and> (\<forall>xa\<in>t. \<not> ball x (inverse (real (n + 1))) \<subseteq> xa)"] by auto
+
+ then obtain l r where l:"l\<in>s" and r:"subseq r" and lr:"((f \<circ> r) ---> l) sequentially"
+ using assms(1)[unfolded compact_def, THEN spec[where x=f]] by auto
+
+ obtain b where "l\<in>b" "b\<in>t" using assms(2) and l by auto
+ then obtain e where "e>0" and e:"\<forall>z. dist z l < e \<longrightarrow> z\<in>b"
+ using assms(3)[THEN bspec[where x=b]] unfolding open_dist by auto
+
+ then obtain N1 where N1:"\<forall>n\<ge>N1. dist ((f \<circ> r) n) l < e / 2"
+ using lr[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
+
+ obtain N2::nat where N2:"N2>0" "inverse (real N2) < e /2" using real_arch_inv[of "e/2"] and `e>0` by auto
+ have N2':"inverse (real (r (N1 + N2) +1 )) < e/2"
+ apply(rule order_less_trans) apply(rule less_imp_inverse_less) using N2
+ using subseq_bigger[OF r, of "N1 + N2"] by auto
+
+ def x \<equiv> "(f (r (N1 + N2)))"
+ have x:"\<not> ball x (inverse (real (r (N1 + N2) + 1))) \<subseteq> b" unfolding x_def
+ using f[THEN spec[where x="r (N1 + N2)"]] using `b\<in>t` by auto
+ have "\<exists>y\<in>ball x (inverse (real (r (N1 + N2) + 1))). y\<notin>b" apply(rule ccontr) using x by auto
+ then obtain y where y:"y \<in> ball x (inverse (real (r (N1 + N2) + 1)))" "y \<notin> b" by auto
+
+ have "dist x l < e/2" using N1 unfolding x_def o_def by auto
+ hence "dist y l < e" using y N2' using dist_triangle[of y l x]by (auto simp add:dist_commute)
+
+ thus False using e and `y\<notin>b` by auto
+qed
+
+lemma compact_imp_heine_borel: "compact s ==> (\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f)
+ \<longrightarrow> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f')))"
+proof clarify
+ fix f assume "compact s" " \<forall>t\<in>f. open t" "s \<subseteq> \<Union>f"
+ then obtain e::real where "e>0" and "\<forall>x\<in>s. \<exists>b\<in>f. ball x e \<subseteq> b" using heine_borel_lemma[of s f] by auto
+ hence "\<forall>x\<in>s. \<exists>b. b\<in>f \<and> ball x e \<subseteq> b" by auto
+ hence "\<exists>bb. \<forall>x\<in>s. bb x \<in>f \<and> ball x e \<subseteq> bb x" using bchoice[of s "\<lambda>x b. b\<in>f \<and> ball x e \<subseteq> b"] by auto
+ then obtain bb where bb:"\<forall>x\<in>s. (bb x) \<in> f \<and> ball x e \<subseteq> (bb x)" by blast
+
+ from `compact s` have "\<exists> k. finite k \<and> k \<subseteq> s \<and> s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k" using compact_imp_totally_bounded[of s] `e>0` by auto
+ then obtain k where k:"finite k" "k \<subseteq> s" "s \<subseteq> \<Union>(\<lambda>x. ball x e) ` k" by auto
+
+ have "finite (bb ` k)" using k(1) by auto
+ moreover
+ { fix x assume "x\<in>s"
+ hence "x\<in>\<Union>(\<lambda>x. ball x e) ` k" using k(3) unfolding subset_eq by auto
+ hence "\<exists>X\<in>bb ` k. x \<in> X" using bb k(2) by blast
+ hence "x \<in> \<Union>(bb ` k)" using Union_iff[of x "bb ` k"] by auto
+ }
+ ultimately show "\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f'" using bb k(2) by (rule_tac x="bb ` k" in exI) auto
+qed
+
+subsection{* Bolzano-Weierstrass property. *}
+
+lemma heine_borel_imp_bolzano_weierstrass:
+ assumes "\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f) --> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f'))"
+ "infinite t" "t \<subseteq> s"
+ shows "\<exists>x \<in> s. x islimpt t"
+proof(rule ccontr)
+ assume "\<not> (\<exists>x \<in> s. x islimpt t)"
+ then obtain f where f:"\<forall>x\<in>s. x \<in> f x \<and> open (f x) \<and> (\<forall>y\<in>t. y \<in> f x \<longrightarrow> y = x)" unfolding islimpt_def
+ using bchoice[of s "\<lambda> x T. x \<in> T \<and> open T \<and> (\<forall>y\<in>t. y \<in> T \<longrightarrow> y = x)"] by auto
+ obtain g where g:"g\<subseteq>{t. \<exists>x. x \<in> s \<and> t = f x}" "finite g" "s \<subseteq> \<Union>g"
+ using assms(1)[THEN spec[where x="{t. \<exists>x. x\<in>s \<and> t = f x}"]] using f by auto
+ from g(1,3) have g':"\<forall>x\<in>g. \<exists>xa \<in> s. x = f xa" by auto
+ { fix x y assume "x\<in>t" "y\<in>t" "f x = f y"
+ hence "x \<in> f x" "y \<in> f x \<longrightarrow> y = x" using f[THEN bspec[where x=x]] and `t\<subseteq>s` by auto
+ hence "x = y" using `f x = f y` and f[THEN bspec[where x=y]] and `y\<in>t` and `t\<subseteq>s` by auto }
+ hence "infinite (f ` t)" using assms(2) using finite_imageD[unfolded inj_on_def, of f t] by auto
+ moreover
+ { fix x assume "x\<in>t" "f x \<notin> g"
+ from g(3) assms(3) `x\<in>t` obtain h where "h\<in>g" and "x\<in>h" by auto
+ then obtain y where "y\<in>s" "h = f y" using g'[THEN bspec[where x=h]] by auto
+ hence "y = x" using f[THEN bspec[where x=y]] and `x\<in>t` and `x\<in>h`[unfolded `h = f y`] by auto
+ hence False using `f x \<notin> g` `h\<in>g` unfolding `h = f y` by auto }
+ hence "f ` t \<subseteq> g" by auto
+ ultimately show False using g(2) using finite_subset by auto
+qed
+
+subsection{* Complete the chain of compactness variants. *}
+
+primrec helper_2::"(real \<Rightarrow> 'a::metric_space) \<Rightarrow> nat \<Rightarrow> 'a" where
+ "helper_2 beyond 0 = beyond 0" |
+ "helper_2 beyond (Suc n) = beyond (dist undefined (helper_2 beyond n) + 1 )"
+
+lemma bolzano_weierstrass_imp_bounded: fixes s::"'a::metric_space set"
+ assumes "\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t)"
+ shows "bounded s"
+proof(rule ccontr)
+ assume "\<not> bounded s"
+ then obtain beyond where "\<forall>a. beyond a \<in>s \<and> \<not> dist undefined (beyond a) \<le> a"
+ unfolding bounded_any_center [where a=undefined]
+ apply simp using choice[of "\<lambda>a x. x\<in>s \<and> \<not> dist undefined x \<le> a"] by auto
+ hence beyond:"\<And>a. beyond a \<in>s" "\<And>a. dist undefined (beyond a) > a"
+ unfolding linorder_not_le by auto
+ def x \<equiv> "helper_2 beyond"
+
+ { fix m n ::nat assume "m<n"
+ hence "dist undefined (x m) + 1 < dist undefined (x n)"
+ proof(induct n)
+ case 0 thus ?case by auto
+ next
+ case (Suc n)
+ have *:"dist undefined (x n) + 1 < dist undefined (x (Suc n))"
+ unfolding x_def and helper_2.simps
+ using beyond(2)[of "dist undefined (helper_2 beyond n) + 1"] by auto
+ thus ?case proof(cases "m < n")
+ case True thus ?thesis using Suc and * by auto
+ next
+ case False hence "m = n" using Suc(2) by auto
+ thus ?thesis using * by auto
+ qed
+ qed } note * = this
+ { fix m n ::nat assume "m\<noteq>n"
+ have "1 < dist (x m) (x n)"
+ proof(cases "m<n")
+ case True
+ hence "1 < dist undefined (x n) - dist undefined (x m)" using *[of m n] by auto
+ thus ?thesis using dist_triangle [of undefined "x n" "x m"] by arith
+ next
+ case False hence "n<m" using `m\<noteq>n` by auto
+ hence "1 < dist undefined (x m) - dist undefined (x n)" using *[of n m] by auto
+ thus ?thesis using dist_triangle2 [of undefined "x m" "x n"] by arith
+ qed } note ** = this
+ { fix a b assume "x a = x b" "a \<noteq> b"
+ hence False using **[of a b] by auto }
+ hence "inj x" unfolding inj_on_def by auto
+ moreover
+ { fix n::nat
+ have "x n \<in> s"
+ proof(cases "n = 0")
+ case True thus ?thesis unfolding x_def using beyond by auto
+ next
+ case False then obtain z where "n = Suc z" using not0_implies_Suc by auto
+ thus ?thesis unfolding x_def using beyond by auto
+ qed }
+ ultimately have "infinite (range x) \<and> range x \<subseteq> s" unfolding x_def using range_inj_infinite[of "helper_2 beyond"] using beyond(1) by auto
+
+ then obtain l where "l\<in>s" and l:"l islimpt range x" using assms[THEN spec[where x="range x"]] by auto
+ then obtain y where "x y \<noteq> l" and y:"dist (x y) l < 1/2" unfolding islimpt_approachable apply(erule_tac x="1/2" in allE) by auto
+ then obtain z where "x z \<noteq> l" and z:"dist (x z) l < dist (x y) l" using l[unfolded islimpt_approachable, THEN spec[where x="dist (x y) l"]]
+ unfolding dist_nz by auto
+ show False using y and z and dist_triangle_half_l[of "x y" l 1 "x z"] and **[of y z] by auto
+qed
+
+lemma sequence_infinite_lemma:
+ fixes l :: "'a::metric_space" (* TODO: generalize *)
+ assumes "\<forall>n::nat. (f n \<noteq> l)" "(f ---> l) sequentially"
+ shows "infinite {y. (\<exists> n. y = f n)}"
+proof(rule ccontr)
+ let ?A = "(\<lambda>x. dist x l) ` {y. \<exists>n. y = f n}"
+ assume "\<not> infinite {y. \<exists>n. y = f n}"
+ hence **:"finite ?A" "?A \<noteq> {}" by auto
+ obtain k where k:"dist (f k) l = Min ?A" using Min_in[OF **] by auto
+ have "0 < Min ?A" using assms(1) unfolding dist_nz unfolding Min_gr_iff[OF **] by auto
+ then obtain N where "dist (f N) l < Min ?A" using assms(2)[unfolded Lim_sequentially, THEN spec[where x="Min ?A"]] by auto
+ moreover have "dist (f N) l \<in> ?A" by auto
+ ultimately show False using Min_le[OF **(1), of "dist (f N) l"] by auto
+qed
+
+lemma sequence_unique_limpt:
+ fixes l :: "'a::metric_space" (* TODO: generalize *)
+ assumes "\<forall>n::nat. (f n \<noteq> l)" "(f ---> l) sequentially" "l' islimpt {y. (\<exists>n. y = f n)}"
+ shows "l' = l"
+proof(rule ccontr)
+ def e \<equiv> "dist l' l"
+ assume "l' \<noteq> l" hence "e>0" unfolding dist_nz e_def by auto
+ then obtain N::nat where N:"\<forall>n\<ge>N. dist (f n) l < e / 2"
+ using assms(2)[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
+ def d \<equiv> "Min (insert (e/2) ((\<lambda>n. if dist (f n) l' = 0 then e/2 else dist (f n) l') ` {0 .. N}))"
+ have "d>0" using `e>0` unfolding d_def e_def using zero_le_dist[of _ l', unfolded order_le_less] by auto
+ obtain k where k:"f k \<noteq> l'" "dist (f k) l' < d" using `d>0` and assms(3)[unfolded islimpt_approachable, THEN spec[where x="d"]] by auto
+ have "k\<ge>N" using k(1)[unfolded dist_nz] using k(2)[unfolded d_def]
+ by force
+ hence "dist l' l < e" using N[THEN spec[where x=k]] using k(2)[unfolded d_def] and dist_triangle_half_r[of "f k" l' e l] by auto
+ thus False unfolding e_def by auto
+qed
+
+lemma bolzano_weierstrass_imp_closed:
+ fixes s :: "'a::metric_space set" (* TODO: can this be generalized? *)
+ assumes "\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t)"
+ shows "closed s"
+proof-
+ { fix x l assume as: "\<forall>n::nat. x n \<in> s" "(x ---> l) sequentially"
+ hence "l \<in> s"
+ proof(cases "\<forall>n. x n \<noteq> l")
+ case False thus "l\<in>s" using as(1) by auto
+ next
+ case True note cas = this
+ with as(2) have "infinite {y. \<exists>n. y = x n}" using sequence_infinite_lemma[of x l] by auto
+ then obtain l' where "l'\<in>s" "l' islimpt {y. \<exists>n. y = x n}" using assms[THEN spec[where x="{y. \<exists>n. y = x n}"]] as(1) by auto
+ thus "l\<in>s" using sequence_unique_limpt[of x l l'] using as cas by auto
+ qed }
+ thus ?thesis unfolding closed_sequential_limits by fast
+qed
+
+text{* Hence express everything as an equivalence. *}
+
+lemma compact_eq_heine_borel:
+ fixes s :: "'a::heine_borel set"
+ shows "compact s \<longleftrightarrow>
+ (\<forall>f. (\<forall>t \<in> f. open t) \<and> s \<subseteq> (\<Union> f)
+ --> (\<exists>f'. f' \<subseteq> f \<and> finite f' \<and> s \<subseteq> (\<Union> f')))" (is "?lhs = ?rhs")
+proof
+ assume ?lhs thus ?rhs using compact_imp_heine_borel[of s] by blast
+next
+ assume ?rhs
+ hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x\<in>s. x islimpt t)"
+ by (blast intro: heine_borel_imp_bolzano_weierstrass[of s])
+ thus ?lhs using bolzano_weierstrass_imp_bounded[of s] bolzano_weierstrass_imp_closed[of s] bounded_closed_imp_compact[of s] by blast
+qed
+
+lemma compact_eq_bolzano_weierstrass:
+ fixes s :: "'a::heine_borel set"
+ shows "compact s \<longleftrightarrow> (\<forall>t. infinite t \<and> t \<subseteq> s --> (\<exists>x \<in> s. x islimpt t))" (is "?lhs = ?rhs")
+proof
+ assume ?lhs thus ?rhs unfolding compact_eq_heine_borel using heine_borel_imp_bolzano_weierstrass[of s] by auto
+next
+ assume ?rhs thus ?lhs using bolzano_weierstrass_imp_bounded bolzano_weierstrass_imp_closed bounded_closed_imp_compact by auto
+qed
+
+lemma compact_eq_bounded_closed:
+ fixes s :: "'a::heine_borel set"
+ shows "compact s \<longleftrightarrow> bounded s \<and> closed s" (is "?lhs = ?rhs")
+proof
+ assume ?lhs thus ?rhs unfolding compact_eq_bolzano_weierstrass using bolzano_weierstrass_imp_bounded bolzano_weierstrass_imp_closed by auto
+next
+ assume ?rhs thus ?lhs using bounded_closed_imp_compact by auto
+qed
+
+lemma compact_imp_bounded:
+ fixes s :: "'a::metric_space set"
+ shows "compact s ==> bounded s"
+proof -
+ assume "compact s"
+ hence "\<forall>f. (\<forall>t\<in>f. open t) \<and> s \<subseteq> \<Union>f \<longrightarrow> (\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f')"
+ by (rule compact_imp_heine_borel)
+ hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x \<in> s. x islimpt t)"
+ using heine_borel_imp_bolzano_weierstrass[of s] by auto
+ thus "bounded s"
+ by (rule bolzano_weierstrass_imp_bounded)
+qed
+
+lemma compact_imp_closed:
+ fixes s :: "'a::metric_space set"
+ shows "compact s ==> closed s"
+proof -
+ assume "compact s"
+ hence "\<forall>f. (\<forall>t\<in>f. open t) \<and> s \<subseteq> \<Union>f \<longrightarrow> (\<exists>f'\<subseteq>f. finite f' \<and> s \<subseteq> \<Union>f')"
+ by (rule compact_imp_heine_borel)
+ hence "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x \<in> s. x islimpt t)"
+ using heine_borel_imp_bolzano_weierstrass[of s] by auto
+ thus "closed s"
+ by (rule bolzano_weierstrass_imp_closed)
+qed
+
+text{* In particular, some common special cases. *}
+
+lemma compact_empty[simp]:
+ "compact {}"
+ unfolding compact_def
+ by simp
+
+(* TODO: can any of the next 3 lemmas be generalized to metric spaces? *)
+
+ (* FIXME : Rename *)
+lemma compact_union[intro]:
+ fixes s t :: "'a::heine_borel set"
+ shows "compact s \<Longrightarrow> compact t ==> compact (s \<union> t)"
+ unfolding compact_eq_bounded_closed
+ using bounded_Un[of s t]
+ using closed_Un[of s t]
+ by simp
+
+lemma compact_inter[intro]:
+ fixes s t :: "'a::heine_borel set"
+ shows "compact s \<Longrightarrow> compact t ==> compact (s \<inter> t)"
+ unfolding compact_eq_bounded_closed
+ using bounded_Int[of s t]
+ using closed_Int[of s t]
+ by simp
+
+lemma compact_inter_closed[intro]:
+ fixes s t :: "'a::heine_borel set"
+ shows "compact s \<Longrightarrow> closed t ==> compact (s \<inter> t)"
+ unfolding compact_eq_bounded_closed
+ using closed_Int[of s t]
+ using bounded_subset[of "s \<inter> t" s]
+ by blast
+
+lemma closed_inter_compact[intro]:
+ fixes s t :: "'a::heine_borel set"
+ shows "closed s \<Longrightarrow> compact t ==> compact (s \<inter> t)"
+proof-
+ assume "closed s" "compact t"
+ moreover
+ have "s \<inter> t = t \<inter> s" by auto ultimately
+ show ?thesis
+ using compact_inter_closed[of t s]
+ by auto
+qed
+
+lemma closed_sing [simp]:
+ fixes a :: "'a::metric_space"
+ shows "closed {a}"
+ apply (clarsimp simp add: closed_def open_dist)
+ apply (rule ccontr)
+ apply (drule_tac x="dist x a" in spec)
+ apply (simp add: dist_nz dist_commute)
+ done
+
+lemma finite_imp_closed:
+ fixes s :: "'a::metric_space set"
+ shows "finite s ==> closed s"
+proof (induct set: finite)
+ case empty show "closed {}" by simp
+next
+ case (insert x F)
+ hence "closed ({x} \<union> F)" by (simp only: closed_Un closed_sing)
+ thus "closed (insert x F)" by simp
+qed
+
+lemma finite_imp_compact:
+ fixes s :: "'a::heine_borel set"
+ shows "finite s ==> compact s"
+ unfolding compact_eq_bounded_closed
+ using finite_imp_closed finite_imp_bounded
+ by blast
+
+lemma compact_sing [simp]: "compact {a}"
+ unfolding compact_def o_def subseq_def
+ by (auto simp add: tendsto_const)
+
+lemma compact_cball[simp]:
+ fixes x :: "'a::heine_borel"
+ shows "compact(cball x e)"
+ using compact_eq_bounded_closed bounded_cball closed_cball
+ by blast
+
+lemma compact_frontier_bounded[intro]:
+ fixes s :: "'a::heine_borel set"
+ shows "bounded s ==> compact(frontier s)"
+ unfolding frontier_def
+ using compact_eq_bounded_closed
+ by blast
+
+lemma compact_frontier[intro]:
+ fixes s :: "'a::heine_borel set"
+ shows "compact s ==> compact (frontier s)"
+ using compact_eq_bounded_closed compact_frontier_bounded
+ by blast
+
+lemma frontier_subset_compact:
+ fixes s :: "'a::heine_borel set"
+ shows "compact s ==> frontier s \<subseteq> s"
+ using frontier_subset_closed compact_eq_bounded_closed
+ by blast
+
+lemma open_delete:
+ fixes s :: "'a::metric_space set"
+ shows "open s ==> open(s - {x})"
+ using open_Diff[of s "{x}"] closed_sing
+ by blast
+
+text{* Finite intersection property. I could make it an equivalence in fact. *}
+
+lemma compact_imp_fip:
+ fixes s :: "'a::heine_borel set"
+ assumes "compact s" "\<forall>t \<in> f. closed t"
+ "\<forall>f'. finite f' \<and> f' \<subseteq> f --> (s \<inter> (\<Inter> f') \<noteq> {})"
+ shows "s \<inter> (\<Inter> f) \<noteq> {}"
+proof
+ assume as:"s \<inter> (\<Inter> f) = {}"
+ hence "s \<subseteq> \<Union>op - UNIV ` f" by auto
+ moreover have "Ball (op - UNIV ` f) open" using open_Diff closed_Diff using assms(2) by auto
+ ultimately obtain f' where f':"f' \<subseteq> op - UNIV ` f" "finite f'" "s \<subseteq> \<Union>f'" using assms(1)[unfolded compact_eq_heine_borel, THEN spec[where x="(\<lambda>t. UNIV - t) ` f"]] by auto
+ hence "finite (op - UNIV ` f') \<and> op - UNIV ` f' \<subseteq> f" by(auto simp add: Diff_Diff_Int)
+ hence "s \<inter> \<Inter>op - UNIV ` f' \<noteq> {}" using assms(3)[THEN spec[where x="op - UNIV ` f'"]] by auto
+ thus False using f'(3) unfolding subset_eq and Union_iff by blast
+qed
+
+subsection{* Bounded closed nest property (proof does not use Heine-Borel). *}
+
+lemma bounded_closed_nest:
+ assumes "\<forall>n. closed(s n)" "\<forall>n. (s n \<noteq> {})"
+ "(\<forall>m n. m \<le> n --> s n \<subseteq> s m)" "bounded(s 0)"
+ shows "\<exists>a::'a::heine_borel. \<forall>n::nat. a \<in> s(n)"
+proof-
+ from assms(2) obtain x where x:"\<forall>n::nat. x n \<in> s n" using choice[of "\<lambda>n x. x\<in> s n"] by auto
+ from assms(4,1) have *:"compact (s 0)" using bounded_closed_imp_compact[of "s 0"] by auto
+
+ then obtain l r where lr:"l\<in>s 0" "subseq r" "((x \<circ> r) ---> l) sequentially"
+ unfolding compact_def apply(erule_tac x=x in allE) using x using assms(3) by blast
+
+ { fix n::nat
+ { fix e::real assume "e>0"
+ with lr(3) obtain N where N:"\<forall>m\<ge>N. dist ((x \<circ> r) m) l < e" unfolding Lim_sequentially by auto
+ hence "dist ((x \<circ> r) (max N n)) l < e" by auto
+ moreover
+ have "r (max N n) \<ge> n" using lr(2) using subseq_bigger[of r "max N n"] by auto
+ hence "(x \<circ> r) (max N n) \<in> s n"
+ using x apply(erule_tac x=n in allE)
+ using x apply(erule_tac x="r (max N n)" in allE)
+ using assms(3) apply(erule_tac x=n in allE)apply( erule_tac x="r (max N n)" in allE) by auto
+ ultimately have "\<exists>y\<in>s n. dist y l < e" by auto
+ }
+ hence "l \<in> s n" using closed_approachable[of "s n" l] assms(1) by blast
+ }
+ thus ?thesis by auto
+qed
+
+text{* Decreasing case does not even need compactness, just completeness. *}
+
+lemma decreasing_closed_nest:
+ assumes "\<forall>n. closed(s n)"
+ "\<forall>n. (s n \<noteq> {})"
+ "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
+ "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y \<in> (s n). dist x y < e"
+ shows "\<exists>a::'a::heine_borel. \<forall>n::nat. a \<in> s n"
+proof-
+ have "\<forall>n. \<exists> x. x\<in>s n" using assms(2) by auto
+ hence "\<exists>t. \<forall>n. t n \<in> s n" using choice[of "\<lambda> n x. x \<in> s n"] by auto
+ then obtain t where t: "\<forall>n. t n \<in> s n" by auto
+ { fix e::real assume "e>0"
+ then obtain N where N:"\<forall>x\<in>s N. \<forall>y\<in>s N. dist x y < e" using assms(4) by auto
+ { fix m n ::nat assume "N \<le> m \<and> N \<le> n"
+ hence "t m \<in> s N" "t n \<in> s N" using assms(3) t unfolding subset_eq t by blast+
+ hence "dist (t m) (t n) < e" using N by auto
+ }
+ hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (t m) (t n) < e" by auto
+ }
+ hence "Cauchy t" unfolding cauchy_def by auto
+ then obtain l where l:"(t ---> l) sequentially" using complete_univ unfolding complete_def by auto
+ { fix n::nat
+ { fix e::real assume "e>0"
+ then obtain N::nat where N:"\<forall>n\<ge>N. dist (t n) l < e" using l[unfolded Lim_sequentially] by auto
+ have "t (max n N) \<in> s n" using assms(3) unfolding subset_eq apply(erule_tac x=n in allE) apply (erule_tac x="max n N" in allE) using t by auto
+ hence "\<exists>y\<in>s n. dist y l < e" apply(rule_tac x="t (max n N)" in bexI) using N by auto
+ }
+ hence "l \<in> s n" using closed_approachable[of "s n" l] assms(1) by auto
+ }
+ then show ?thesis by auto
+qed
+
+text{* Strengthen it to the intersection actually being a singleton. *}
+
+lemma decreasing_closed_nest_sing:
+ assumes "\<forall>n. closed(s n)"
+ "\<forall>n. s n \<noteq> {}"
+ "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
+ "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y\<in>(s n). dist x y < e"
+ shows "\<exists>a::'a::heine_borel. \<Inter> {t. (\<exists>n::nat. t = s n)} = {a}"
+proof-
+ obtain a where a:"\<forall>n. a \<in> s n" using decreasing_closed_nest[of s] using assms by auto
+ { fix b assume b:"b \<in> \<Inter>{t. \<exists>n. t = s n}"
+ { fix e::real assume "e>0"
+ hence "dist a b < e" using assms(4 )using b using a by blast
+ }
+ hence "dist a b = 0" by (metis dist_eq_0_iff dist_nz real_less_def)
+ }
+ with a have "\<Inter>{t. \<exists>n. t = s n} = {a}" by auto
+ thus ?thesis by auto
+qed
+
+text{* Cauchy-type criteria for uniform convergence. *}
+
+lemma uniformly_convergent_eq_cauchy: fixes s::"nat \<Rightarrow> 'b \<Rightarrow> 'a::heine_borel" shows
+ "(\<exists>l. \<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x --> dist(s n x)(l x) < e) \<longleftrightarrow>
+ (\<forall>e>0. \<exists>N. \<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x --> dist (s m x) (s n x) < e)" (is "?lhs = ?rhs")
+proof(rule)
+ assume ?lhs
+ then obtain l where l:"\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l x) < e" by auto
+ { fix e::real assume "e>0"
+ then obtain N::nat where N:"\<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l x) < e / 2" using l[THEN spec[where x="e/2"]] by auto
+ { fix n m::nat and x::"'b" assume "N \<le> m \<and> N \<le> n \<and> P x"
+ hence "dist (s m x) (s n x) < e"
+ using N[THEN spec[where x=m], THEN spec[where x=x]]
+ using N[THEN spec[where x=n], THEN spec[where x=x]]
+ using dist_triangle_half_l[of "s m x" "l x" e "s n x"] by auto }
+ hence "\<exists>N. \<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x --> dist (s m x) (s n x) < e" by auto }
+ thus ?rhs by auto
+next
+ assume ?rhs
+ hence "\<forall>x. P x \<longrightarrow> Cauchy (\<lambda>n. s n x)" unfolding cauchy_def apply auto by (erule_tac x=e in allE)auto
+ then obtain l where l:"\<forall>x. P x \<longrightarrow> ((\<lambda>n. s n x) ---> l x) sequentially" unfolding convergent_eq_cauchy[THEN sym]
+ using choice[of "\<lambda>x l. P x \<longrightarrow> ((\<lambda>n. s n x) ---> l) sequentially"] by auto
+ { fix e::real assume "e>0"
+ then obtain N where N:"\<forall>m n x. N \<le> m \<and> N \<le> n \<and> P x \<longrightarrow> dist (s m x) (s n x) < e/2"
+ using `?rhs`[THEN spec[where x="e/2"]] by auto
+ { fix x assume "P x"
+ then obtain M where M:"\<forall>n\<ge>M. dist (s n x) (l x) < e/2"
+ using l[THEN spec[where x=x], unfolded Lim_sequentially] using `e>0` by(auto elim!: allE[where x="e/2"])
+ fix n::nat assume "n\<ge>N"
+ hence "dist(s n x)(l x) < e" using `P x`and N[THEN spec[where x=n], THEN spec[where x="N+M"], THEN spec[where x=x]]
+ using M[THEN spec[where x="N+M"]] and dist_triangle_half_l[of "s n x" "s (N+M) x" e "l x"] by (auto simp add: dist_commute) }
+ hence "\<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist(s n x)(l x) < e" by auto }
+ thus ?lhs by auto
+qed
+
+lemma uniformly_cauchy_imp_uniformly_convergent:
+ fixes s :: "nat \<Rightarrow> 'a \<Rightarrow> 'b::heine_borel"
+ assumes "\<forall>e>0.\<exists>N. \<forall>m (n::nat) x. N \<le> m \<and> N \<le> n \<and> P x --> dist(s m x)(s n x) < e"
+ "\<forall>x. P x --> (\<forall>e>0. \<exists>N. \<forall>n. N \<le> n --> dist(s n x)(l x) < e)"
+ shows "\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x --> dist(s n x)(l x) < e"
+proof-
+ obtain l' where l:"\<forall>e>0. \<exists>N. \<forall>n x. N \<le> n \<and> P x \<longrightarrow> dist (s n x) (l' x) < e"
+ using assms(1) unfolding uniformly_convergent_eq_cauchy[THEN sym] by auto
+ moreover
+ { fix x assume "P x"
+ hence "l x = l' x" using Lim_unique[OF trivial_limit_sequentially, of "\<lambda>n. s n x" "l x" "l' x"]
+ using l and assms(2) unfolding Lim_sequentially by blast }
+ ultimately show ?thesis by auto
+qed
+
+subsection{* Define continuity over a net to take in restrictions of the set. *}
+
+definition
+ continuous :: "'a::t2_space net \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) \<Rightarrow> bool" where
+ "continuous net f \<longleftrightarrow> (f ---> f(netlimit net)) net"
+
+lemma continuous_trivial_limit:
+ "trivial_limit net ==> continuous net f"
+ unfolding continuous_def tendsto_def trivial_limit_eq by auto
+
+lemma continuous_within: "continuous (at x within s) f \<longleftrightarrow> (f ---> f(x)) (at x within s)"
+ unfolding continuous_def
+ unfolding tendsto_def
+ using netlimit_within[of x s]
+ by (cases "trivial_limit (at x within s)") (auto simp add: trivial_limit_eventually)
+
+lemma continuous_at: "continuous (at x) f \<longleftrightarrow> (f ---> f(x)) (at x)"
+ using continuous_within [of x UNIV f] by (simp add: within_UNIV)
+
+lemma continuous_at_within:
+ assumes "continuous (at x) f" shows "continuous (at x within s) f"
+ using assms unfolding continuous_at continuous_within
+ by (rule Lim_at_within)
+
+text{* Derive the epsilon-delta forms, which we often use as "definitions" *}
+
+lemma continuous_within_eps_delta:
+ "continuous (at x within s) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0. \<forall>x'\<in> s. dist x' x < d --> dist (f x') (f x) < e)"
+ unfolding continuous_within and Lim_within
+ apply auto unfolding dist_nz[THEN sym] apply(auto elim!:allE) apply(rule_tac x=d in exI) by auto
+
+lemma continuous_at_eps_delta: "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
+ \<forall>x'. dist x' x < d --> dist(f x')(f x) < e)"
+ using continuous_within_eps_delta[of x UNIV f]
+ unfolding within_UNIV by blast
+
+text{* Versions in terms of open balls. *}
+
+lemma continuous_within_ball:
+ "continuous (at x within s) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
+ f ` (ball x d \<inter> s) \<subseteq> ball (f x) e)" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix e::real assume "e>0"
+ then obtain d where d: "d>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e"
+ using `?lhs`[unfolded continuous_within Lim_within] by auto
+ { fix y assume "y\<in>f ` (ball x d \<inter> s)"
+ hence "y \<in> ball (f x) e" using d(2) unfolding dist_nz[THEN sym]
+ apply (auto simp add: dist_commute mem_ball) apply(erule_tac x=xa in ballE) apply auto using `e>0` by auto
+ }
+ hence "\<exists>d>0. f ` (ball x d \<inter> s) \<subseteq> ball (f x) e" using `d>0` unfolding subset_eq ball_def by (auto simp add: dist_commute) }
+ thus ?rhs by auto
+next
+ assume ?rhs thus ?lhs unfolding continuous_within Lim_within ball_def subset_eq
+ apply (auto simp add: dist_commute) apply(erule_tac x=e in allE) by auto
+qed
+
+lemma continuous_at_ball:
+ "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0. f ` (ball x d) \<subseteq> ball (f x) e)" (is "?lhs = ?rhs")
+proof
+ assume ?lhs thus ?rhs unfolding continuous_at Lim_at subset_eq Ball_def Bex_def image_iff mem_ball
+ apply auto apply(erule_tac x=e in allE) apply auto apply(rule_tac x=d in exI) apply auto apply(erule_tac x=xa in allE) apply (auto simp add: dist_commute dist_nz)
+ unfolding dist_nz[THEN sym] by auto
+next
+ assume ?rhs thus ?lhs unfolding continuous_at Lim_at subset_eq Ball_def Bex_def image_iff mem_ball
+ apply auto apply(erule_tac x=e in allE) apply auto apply(rule_tac x=d in exI) apply auto apply(erule_tac x="f xa" in allE) by (auto simp add: dist_commute dist_nz)
+qed
+
+text{* For setwise continuity, just start from the epsilon-delta definitions. *}
+
+definition
+ continuous_on :: "'a::metric_space set \<Rightarrow> ('a \<Rightarrow> 'b::metric_space) \<Rightarrow> bool" where
+ "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. \<forall>e>0. \<exists>d::real>0. \<forall>x' \<in> s. dist x' x < d --> dist (f x') (f x) < e)"
+
+
+definition
+ uniformly_continuous_on ::
+ "'a::metric_space set \<Rightarrow> ('a \<Rightarrow> 'b::metric_space) \<Rightarrow> bool" where
+ "uniformly_continuous_on s f \<longleftrightarrow>
+ (\<forall>e>0. \<exists>d>0. \<forall>x\<in>s. \<forall> x'\<in>s. dist x' x < d
+ --> dist (f x') (f x) < e)"
+
+text{* Some simple consequential lemmas. *}
+
+lemma uniformly_continuous_imp_continuous:
+ " uniformly_continuous_on s f ==> continuous_on s f"
+ unfolding uniformly_continuous_on_def continuous_on_def by blast
+
+lemma continuous_at_imp_continuous_within:
+ "continuous (at x) f ==> continuous (at x within s) f"
+ unfolding continuous_within continuous_at using Lim_at_within by auto
+
+lemma continuous_at_imp_continuous_on: assumes "(\<forall>x \<in> s. continuous (at x) f)"
+ shows "continuous_on s f"
+proof(simp add: continuous_at continuous_on_def, rule, rule, rule)
+ fix x and e::real assume "x\<in>s" "e>0"
+ hence "eventually (\<lambda>xa. dist (f xa) (f x) < e) (at x)" using assms unfolding continuous_at tendsto_iff by auto
+ then obtain d where d:"d>0" "\<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" unfolding eventually_at by auto
+ { fix x' assume "\<not> 0 < dist x' x"
+ hence "x=x'"
+ using dist_nz[of x' x] by auto
+ hence "dist (f x') (f x) < e" using `e>0` by auto
+ }
+ thus "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using d by auto
+qed
+
+lemma continuous_on_eq_continuous_within:
+ "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. continuous (at x within s) f)" (is "?lhs = ?rhs")
+proof
+ assume ?rhs
+ { fix x assume "x\<in>s"
+ fix e::real assume "e>0"
+ assume "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e"
+ then obtain d where "d>0" and d:"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" by auto
+ { fix x' assume as:"x'\<in>s" "dist x' x < d"
+ hence "dist (f x') (f x) < e" using `e>0` d `x'\<in>s` dist_eq_0_iff[of x' x] zero_le_dist[of x' x] as(2) by (metis dist_eq_0_iff dist_nz) }
+ hence "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using `d>0` by auto
+ }
+ thus ?lhs using `?rhs` unfolding continuous_on_def continuous_within Lim_within by auto
+next
+ assume ?lhs
+ thus ?rhs unfolding continuous_on_def continuous_within Lim_within by blast
+qed
+
+lemma continuous_on:
+ "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. (f ---> f(x)) (at x within s))"
+ by (auto simp add: continuous_on_eq_continuous_within continuous_within)
+
+lemma continuous_on_eq_continuous_at:
+ "open s ==> (continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. continuous (at x) f))"
+ by (auto simp add: continuous_on continuous_at Lim_within_open)
+
+lemma continuous_within_subset:
+ "continuous (at x within s) f \<Longrightarrow> t \<subseteq> s
+ ==> continuous (at x within t) f"
+ unfolding continuous_within by(metis Lim_within_subset)
+
+lemma continuous_on_subset:
+ "continuous_on s f \<Longrightarrow> t \<subseteq> s ==> continuous_on t f"
+ unfolding continuous_on by (metis subset_eq Lim_within_subset)
+
+lemma continuous_on_interior:
+ "continuous_on s f \<Longrightarrow> x \<in> interior s ==> continuous (at x) f"
+unfolding interior_def
+apply simp
+by (meson continuous_on_eq_continuous_at continuous_on_subset)
+
+lemma continuous_on_eq:
+ "(\<forall>x \<in> s. f x = g x) \<Longrightarrow> continuous_on s f
+ ==> continuous_on s g"
+ by (simp add: continuous_on_def)
+
+text{* Characterization of various kinds of continuity in terms of sequences. *}
+
+(* \<longrightarrow> could be generalized, but \<longleftarrow> requires metric space *)
+lemma continuous_within_sequentially:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space"
+ shows "continuous (at a within s) f \<longleftrightarrow>
+ (\<forall>x. (\<forall>n::nat. x n \<in> s) \<and> (x ---> a) sequentially
+ --> ((f o x) ---> f a) sequentially)" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix x::"nat \<Rightarrow> 'a" assume x:"\<forall>n. x n \<in> s" "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (x n) a < e"
+ fix e::real assume "e>0"
+ from `?lhs` obtain d where "d>0" and d:"\<forall>x\<in>s. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) (f a) < e" unfolding continuous_within Lim_within using `e>0` by auto
+ from x(2) `d>0` obtain N where N:"\<forall>n\<ge>N. dist (x n) a < d" by auto
+ hence "\<exists>N. \<forall>n\<ge>N. dist ((f \<circ> x) n) (f a) < e"
+ apply(rule_tac x=N in exI) using N d apply auto using x(1)
+ apply(erule_tac x=n in allE) apply(erule_tac x=n in allE)
+ apply(erule_tac x="x n" in ballE) apply auto unfolding dist_nz[THEN sym] apply auto using `e>0` by auto
+ }
+ thus ?rhs unfolding continuous_within unfolding Lim_sequentially by simp
+next
+ assume ?rhs
+ { fix e::real assume "e>0"
+ assume "\<not> (\<exists>d>0. \<forall>x\<in>s. 0 < dist x a \<and> dist x a < d \<longrightarrow> dist (f x) (f a) < e)"
+ hence "\<forall>d. \<exists>x. d>0 \<longrightarrow> x\<in>s \<and> (0 < dist x a \<and> dist x a < d \<and> \<not> dist (f x) (f a) < e)" by blast
+ then obtain x where x:"\<forall>d>0. x d \<in> s \<and> (0 < dist (x d) a \<and> dist (x d) a < d \<and> \<not> dist (f (x d)) (f a) < e)"
+ using choice[of "\<lambda>d x.0<d \<longrightarrow> x\<in>s \<and> (0 < dist x a \<and> dist x a < d \<and> \<not> dist (f x) (f a) < e)"] by auto
+ { fix d::real assume "d>0"
+ hence "\<exists>N::nat. inverse (real (N + 1)) < d" using real_arch_inv[of d] by (auto, rule_tac x="n - 1" in exI)auto
+ then obtain N::nat where N:"inverse (real (N + 1)) < d" by auto
+ { fix n::nat assume n:"n\<ge>N"
+ hence "dist (x (inverse (real (n + 1)))) a < inverse (real (n + 1))" using x[THEN spec[where x="inverse (real (n + 1))"]] by auto
+ moreover have "inverse (real (n + 1)) < d" using N n by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
+ ultimately have "dist (x (inverse (real (n + 1)))) a < d" by auto
+ }
+ hence "\<exists>N::nat. \<forall>n\<ge>N. dist (x (inverse (real (n + 1)))) a < d" by auto
+ }
+ hence "(\<forall>n::nat. x (inverse (real (n + 1))) \<in> s) \<and> (\<forall>e>0. \<exists>N::nat. \<forall>n\<ge>N. dist (x (inverse (real (n + 1)))) a < e)" using x by auto
+ hence "\<forall>e>0. \<exists>N::nat. \<forall>n\<ge>N. dist (f (x (inverse (real (n + 1))))) (f a) < e" using `?rhs`[THEN spec[where x="\<lambda>n::nat. x (inverse (real (n+1)))"], unfolded Lim_sequentially] by auto
+ hence "False" apply(erule_tac x=e in allE) using `e>0` using x by auto
+ }
+ thus ?lhs unfolding continuous_within unfolding Lim_within unfolding Lim_sequentially by blast
+qed
+
+lemma continuous_at_sequentially:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space"
+ shows "continuous (at a) f \<longleftrightarrow> (\<forall>x. (x ---> a) sequentially
+ --> ((f o x) ---> f a) sequentially)"
+ using continuous_within_sequentially[of a UNIV f] unfolding within_UNIV by auto
+
+lemma continuous_on_sequentially:
+ "continuous_on s f \<longleftrightarrow> (\<forall>x. \<forall>a \<in> s. (\<forall>n. x(n) \<in> s) \<and> (x ---> a) sequentially
+ --> ((f o x) ---> f(a)) sequentially)" (is "?lhs = ?rhs")
+proof
+ assume ?rhs thus ?lhs using continuous_within_sequentially[of _ s f] unfolding continuous_on_eq_continuous_within by auto
+next
+ assume ?lhs thus ?rhs unfolding continuous_on_eq_continuous_within using continuous_within_sequentially[of _ s f] by auto
+qed
+
+lemma uniformly_continuous_on_sequentially:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+ shows "uniformly_continuous_on s f \<longleftrightarrow> (\<forall>x y. (\<forall>n. x n \<in> s) \<and> (\<forall>n. y n \<in> s) \<and>
+ ((\<lambda>n. x n - y n) ---> 0) sequentially
+ \<longrightarrow> ((\<lambda>n. f(x n) - f(y n)) ---> 0) sequentially)" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix x y assume x:"\<forall>n. x n \<in> s" and y:"\<forall>n. y n \<in> s" and xy:"((\<lambda>n. x n - y n) ---> 0) sequentially"
+ { fix e::real assume "e>0"
+ then obtain d where "d>0" and d:"\<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e"
+ using `?lhs`[unfolded uniformly_continuous_on_def, THEN spec[where x=e]] by auto
+ obtain N where N:"\<forall>n\<ge>N. norm (x n - y n - 0) < d" using xy[unfolded Lim_sequentially dist_norm] and `d>0` by auto
+ { fix n assume "n\<ge>N"
+ hence "norm (f (x n) - f (y n) - 0) < e"
+ using N[THEN spec[where x=n]] using d[THEN bspec[where x="x n"], THEN bspec[where x="y n"]] using x and y
+ unfolding dist_commute and dist_norm by simp }
+ hence "\<exists>N. \<forall>n\<ge>N. norm (f (x n) - f (y n) - 0) < e" by auto }
+ hence "((\<lambda>n. f(x n) - f(y n)) ---> 0) sequentially" unfolding Lim_sequentially and dist_norm by auto }
+ thus ?rhs by auto
+next
+ assume ?rhs
+ { assume "\<not> ?lhs"
+ then obtain e where "e>0" "\<forall>d>0. \<exists>x\<in>s. \<exists>x'\<in>s. dist x' x < d \<and> \<not> dist (f x') (f x) < e" unfolding uniformly_continuous_on_def by auto
+ then obtain fa where fa:"\<forall>x. 0 < x \<longrightarrow> fst (fa x) \<in> s \<and> snd (fa x) \<in> s \<and> dist (fst (fa x)) (snd (fa x)) < x \<and> \<not> dist (f (fst (fa x))) (f (snd (fa x))) < e"
+ using choice[of "\<lambda>d x. d>0 \<longrightarrow> fst x \<in> s \<and> snd x \<in> s \<and> dist (snd x) (fst x) < d \<and> \<not> dist (f (snd x)) (f (fst x)) < e"] unfolding Bex_def
+ by (auto simp add: dist_commute)
+ def x \<equiv> "\<lambda>n::nat. fst (fa (inverse (real n + 1)))"
+ def y \<equiv> "\<lambda>n::nat. snd (fa (inverse (real n + 1)))"
+ have xyn:"\<forall>n. x n \<in> s \<and> y n \<in> s" and xy0:"\<forall>n. dist (x n) (y n) < inverse (real n + 1)" and fxy:"\<forall>n. \<not> dist (f (x n)) (f (y n)) < e"
+ unfolding x_def and y_def using fa by auto
+ have 1:"\<And>(x::'a) y. dist (x - y) 0 = dist x y" unfolding dist_norm by auto
+ have 2:"\<And>(x::'b) y. dist (x - y) 0 = dist x y" unfolding dist_norm by auto
+ { fix e::real assume "e>0"
+ then obtain N::nat where "N \<noteq> 0" and N:"0 < inverse (real N) \<and> inverse (real N) < e" unfolding real_arch_inv[of e] by auto
+ { fix n::nat assume "n\<ge>N"
+ hence "inverse (real n + 1) < inverse (real N)" using real_of_nat_ge_zero and `N\<noteq>0` by auto
+ also have "\<dots> < e" using N by auto
+ finally have "inverse (real n + 1) < e" by auto
+ hence "dist (x n - y n) 0 < e" unfolding 1 using xy0[THEN spec[where x=n]] by auto }
+ hence "\<exists>N. \<forall>n\<ge>N. dist (x n - y n) 0 < e" by auto }
+ hence "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (f (x n) - f (y n)) 0 < e" using `?rhs`[THEN spec[where x=x], THEN spec[where x=y]] and xyn unfolding Lim_sequentially by auto
+ hence False unfolding 2 using fxy and `e>0` by auto }
+ thus ?lhs unfolding uniformly_continuous_on_def by blast
+qed
+
+text{* The usual transformation theorems. *}
+
+lemma continuous_transform_within:
+ fixes f g :: "'a::metric_space \<Rightarrow> 'b::metric_space"
+ assumes "0 < d" "x \<in> s" "\<forall>x' \<in> s. dist x' x < d --> f x' = g x'"
+ "continuous (at x within s) f"
+ shows "continuous (at x within s) g"
+proof-
+ { fix e::real assume "e>0"
+ then obtain d' where d':"d'>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < e" using assms(4) unfolding continuous_within Lim_within by auto
+ { fix x' assume "x'\<in>s" "0 < dist x' x" "dist x' x < (min d d')"
+ hence "dist (f x') (g x) < e" using assms(2,3) apply(erule_tac x=x in ballE) using d' by auto }
+ hence "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < (min d d') \<longrightarrow> dist (f xa) (g x) < e" by blast
+ hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (g x) < e" using `d>0` `d'>0` by(rule_tac x="min d d'" in exI)auto }
+ hence "(f ---> g x) (at x within s)" unfolding Lim_within using assms(1) by auto
+ thus ?thesis unfolding continuous_within using Lim_transform_within[of d s x f g "g x"] using assms by blast
+qed
+
+lemma continuous_transform_at:
+ fixes f g :: "'a::metric_space \<Rightarrow> 'b::metric_space"
+ assumes "0 < d" "\<forall>x'. dist x' x < d --> f x' = g x'"
+ "continuous (at x) f"
+ shows "continuous (at x) g"
+proof-
+ { fix e::real assume "e>0"
+ then obtain d' where d':"d'>0" "\<forall>xa. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < e" using assms(3) unfolding continuous_at Lim_at by auto
+ { fix x' assume "0 < dist x' x" "dist x' x < (min d d')"
+ hence "dist (f x') (g x) < e" using assms(2) apply(erule_tac x=x in allE) using d' by auto
+ }
+ hence "\<forall>xa. 0 < dist xa x \<and> dist xa x < (min d d') \<longrightarrow> dist (f xa) (g x) < e" by blast
+ hence "\<exists>d>0. \<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (g x) < e" using `d>0` `d'>0` by(rule_tac x="min d d'" in exI)auto
+ }
+ hence "(f ---> g x) (at x)" unfolding Lim_at using assms(1) by auto
+ thus ?thesis unfolding continuous_at using Lim_transform_at[of d x f g "g x"] using assms by blast
+qed
+
+text{* Combination results for pointwise continuity. *}
+
+lemma continuous_const: "continuous net (\<lambda>x. c)"
+ by (auto simp add: continuous_def Lim_const)
+
+lemma continuous_cmul:
+ fixes f :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous net f ==> continuous net (\<lambda>x. c *\<^sub>R f x)"
+ by (auto simp add: continuous_def Lim_cmul)
+
+lemma continuous_neg:
+ fixes f :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous net f ==> continuous net (\<lambda>x. -(f x))"
+ by (auto simp add: continuous_def Lim_neg)
+
+lemma continuous_add:
+ fixes f g :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous net f \<Longrightarrow> continuous net g \<Longrightarrow> continuous net (\<lambda>x. f x + g x)"
+ by (auto simp add: continuous_def Lim_add)
+
+lemma continuous_sub:
+ fixes f g :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous net f \<Longrightarrow> continuous net g \<Longrightarrow> continuous net (\<lambda>x. f x - g x)"
+ by (auto simp add: continuous_def Lim_sub)
+
+text{* Same thing for setwise continuity. *}
+
+lemma continuous_on_const:
+ "continuous_on s (\<lambda>x. c)"
+ unfolding continuous_on_eq_continuous_within using continuous_const by blast
+
+lemma continuous_on_cmul:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous_on s f ==> continuous_on s (\<lambda>x. c *\<^sub>R (f x))"
+ unfolding continuous_on_eq_continuous_within using continuous_cmul by blast
+
+lemma continuous_on_neg:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. - f x)"
+ unfolding continuous_on_eq_continuous_within using continuous_neg by blast
+
+lemma continuous_on_add:
+ fixes f g :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous_on s f \<Longrightarrow> continuous_on s g
+ \<Longrightarrow> continuous_on s (\<lambda>x. f x + g x)"
+ unfolding continuous_on_eq_continuous_within using continuous_add by blast
+
+lemma continuous_on_sub:
+ fixes f g :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous_on s f \<Longrightarrow> continuous_on s g
+ \<Longrightarrow> continuous_on s (\<lambda>x. f x - g x)"
+ unfolding continuous_on_eq_continuous_within using continuous_sub by blast
+
+text{* Same thing for uniform continuity, using sequential formulations. *}
+
+lemma uniformly_continuous_on_const:
+ "uniformly_continuous_on s (\<lambda>x. c)"
+ unfolding uniformly_continuous_on_def by simp
+
+lemma uniformly_continuous_on_cmul:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+ (* FIXME: generalize 'a to metric_space *)
+ assumes "uniformly_continuous_on s f"
+ shows "uniformly_continuous_on s (\<lambda>x. c *\<^sub>R f(x))"
+proof-
+ { fix x y assume "((\<lambda>n. f (x n) - f (y n)) ---> 0) sequentially"
+ hence "((\<lambda>n. c *\<^sub>R f (x n) - c *\<^sub>R f (y n)) ---> 0) sequentially"
+ using Lim_cmul[of "(\<lambda>n. f (x n) - f (y n))" 0 sequentially c]
+ unfolding scaleR_zero_right scaleR_right_diff_distrib by auto
+ }
+ thus ?thesis using assms unfolding uniformly_continuous_on_sequentially by auto
+qed
+
+lemma dist_minus:
+ fixes x y :: "'a::real_normed_vector"
+ shows "dist (- x) (- y) = dist x y"
+ unfolding dist_norm minus_diff_minus norm_minus_cancel ..
+
+lemma uniformly_continuous_on_neg:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "uniformly_continuous_on s f
+ ==> uniformly_continuous_on s (\<lambda>x. -(f x))"
+ unfolding uniformly_continuous_on_def dist_minus .
+
+lemma uniformly_continuous_on_add:
+ fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" (* FIXME: generalize 'a *)
+ assumes "uniformly_continuous_on s f" "uniformly_continuous_on s g"
+ shows "uniformly_continuous_on s (\<lambda>x. f x + g x)"
+proof-
+ { fix x y assume "((\<lambda>n. f (x n) - f (y n)) ---> 0) sequentially"
+ "((\<lambda>n. g (x n) - g (y n)) ---> 0) sequentially"
+ hence "((\<lambda>xa. f (x xa) - f (y xa) + (g (x xa) - g (y xa))) ---> 0 + 0) sequentially"
+ using Lim_add[of "\<lambda> n. f (x n) - f (y n)" 0 sequentially "\<lambda> n. g (x n) - g (y n)" 0] by auto
+ hence "((\<lambda>n. f (x n) + g (x n) - (f (y n) + g (y n))) ---> 0) sequentially" unfolding Lim_sequentially and add_diff_add [symmetric] by auto }
+ thus ?thesis using assms unfolding uniformly_continuous_on_sequentially by auto
+qed
+
+lemma uniformly_continuous_on_sub:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector" (* FIXME: generalize 'a *)
+ shows "uniformly_continuous_on s f \<Longrightarrow> uniformly_continuous_on s g
+ ==> uniformly_continuous_on s (\<lambda>x. f x - g x)"
+ unfolding ab_diff_minus
+ using uniformly_continuous_on_add[of s f "\<lambda>x. - g x"]
+ using uniformly_continuous_on_neg[of s g] by auto
+
+text{* Identity function is continuous in every sense. *}
+
+lemma continuous_within_id:
+ "continuous (at a within s) (\<lambda>x. x)"
+ unfolding continuous_within by (rule Lim_at_within [OF Lim_ident_at])
+
+lemma continuous_at_id:
+ "continuous (at a) (\<lambda>x. x)"
+ unfolding continuous_at by (rule Lim_ident_at)
+
+lemma continuous_on_id:
+ "continuous_on s (\<lambda>x. x)"
+ unfolding continuous_on Lim_within by auto
+
+lemma uniformly_continuous_on_id:
+ "uniformly_continuous_on s (\<lambda>x. x)"
+ unfolding uniformly_continuous_on_def by auto
+
+text{* Continuity of all kinds is preserved under composition. *}
+
+lemma continuous_within_compose:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ fixes g :: "'b::metric_space \<Rightarrow> 'c::metric_space"
+ assumes "continuous (at x within s) f" "continuous (at (f x) within f ` s) g"
+ shows "continuous (at x within s) (g o f)"
+proof-
+ { fix e::real assume "e>0"
+ with assms(2)[unfolded continuous_within Lim_within] obtain d where "d>0" and d:"\<forall>xa\<in>f ` s. 0 < dist xa (f x) \<and> dist xa (f x) < d \<longrightarrow> dist (g xa) (g (f x)) < e" by auto
+ from assms(1)[unfolded continuous_within Lim_within] obtain d' where "d'>0" and d':"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d' \<longrightarrow> dist (f xa) (f x) < d" using `d>0` by auto
+ { fix y assume as:"y\<in>s" "0 < dist y x" "dist y x < d'"
+ hence "dist (f y) (f x) < d" using d'[THEN bspec[where x=y]] by (auto simp add:dist_commute)
+ hence "dist (g (f y)) (g (f x)) < e" using as(1) d[THEN bspec[where x="f y"]] unfolding dist_nz[THEN sym] using `e>0` by auto }
+ hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (g (f xa)) (g (f x)) < e" using `d'>0` by auto }
+ thus ?thesis unfolding continuous_within Lim_within by auto
+qed
+
+lemma continuous_at_compose:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ fixes g :: "'b::metric_space \<Rightarrow> 'c::metric_space"
+ assumes "continuous (at x) f" "continuous (at (f x)) g"
+ shows "continuous (at x) (g o f)"
+proof-
+ have " continuous (at (f x) within range f) g" using assms(2) using continuous_within_subset[of "f x" UNIV g "range f", unfolded within_UNIV] by auto
+ thus ?thesis using assms(1) using continuous_within_compose[of x UNIV f g, unfolded within_UNIV] by auto
+qed
+
+lemma continuous_on_compose:
+ "continuous_on s f \<Longrightarrow> continuous_on (f ` s) g \<Longrightarrow> continuous_on s (g o f)"
+ unfolding continuous_on_eq_continuous_within using continuous_within_compose[of _ s f g] by auto
+
+lemma uniformly_continuous_on_compose:
+ assumes "uniformly_continuous_on s f" "uniformly_continuous_on (f ` s) g"
+ shows "uniformly_continuous_on s (g o f)"
+proof-
+ { fix e::real assume "e>0"
+ then obtain d where "d>0" and d:"\<forall>x\<in>f ` s. \<forall>x'\<in>f ` s. dist x' x < d \<longrightarrow> dist (g x') (g x) < e" using assms(2) unfolding uniformly_continuous_on_def by auto
+ obtain d' where "d'>0" "\<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d' \<longrightarrow> dist (f x') (f x) < d" using `d>0` using assms(1) unfolding uniformly_continuous_on_def by auto
+ hence "\<exists>d>0. \<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist ((g \<circ> f) x') ((g \<circ> f) x) < e" using `d>0` using d by auto }
+ thus ?thesis using assms unfolding uniformly_continuous_on_def by auto
+qed
+
+text{* Continuity in terms of open preimages. *}
+
+lemma continuous_at_open:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ shows "continuous (at x) f \<longleftrightarrow> (\<forall>t. open t \<and> f x \<in> t --> (\<exists>s. open s \<and> x \<in> s \<and> (\<forall>x' \<in> s. (f x') \<in> t)))" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix t assume as: "open t" "f x \<in> t"
+ then obtain e where "e>0" and e:"ball (f x) e \<subseteq> t" unfolding open_contains_ball by auto
+
+ obtain d where "d>0" and d:"\<forall>y. 0 < dist y x \<and> dist y x < d \<longrightarrow> dist (f y) (f x) < e" using `e>0` using `?lhs`[unfolded continuous_at Lim_at open_dist] by auto
+
+ have "open (ball x d)" using open_ball by auto
+ moreover have "x \<in> ball x d" unfolding centre_in_ball using `d>0` by simp
+ moreover
+ { fix x' assume "x'\<in>ball x d" hence "f x' \<in> t"
+ using e[unfolded subset_eq Ball_def mem_ball, THEN spec[where x="f x'"]] d[THEN spec[where x=x']]
+ unfolding mem_ball apply (auto simp add: dist_commute)
+ unfolding dist_nz[THEN sym] using as(2) by auto }
+ hence "\<forall>x'\<in>ball x d. f x' \<in> t" by auto
+ ultimately have "\<exists>s. open s \<and> x \<in> s \<and> (\<forall>x'\<in>s. f x' \<in> t)"
+ apply(rule_tac x="ball x d" in exI) by simp }
+ thus ?rhs by auto
+next
+ assume ?rhs
+ { fix e::real assume "e>0"
+ then obtain s where s: "open s" "x \<in> s" "\<forall>x'\<in>s. f x' \<in> ball (f x) e" using `?rhs`[unfolded continuous_at Lim_at, THEN spec[where x="ball (f x) e"]]
+ unfolding centre_in_ball[of "f x" e, THEN sym] by auto
+ then obtain d where "d>0" and d:"ball x d \<subseteq> s" unfolding open_contains_ball by auto
+ { fix y assume "0 < dist y x \<and> dist y x < d"
+ hence "dist (f y) (f x) < e" using d[unfolded subset_eq Ball_def mem_ball, THEN spec[where x=y]]
+ using s(3)[THEN bspec[where x=y], unfolded mem_ball] by (auto simp add: dist_commute) }
+ hence "\<exists>d>0. \<forall>xa. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" using `d>0` by auto }
+ thus ?lhs unfolding continuous_at Lim_at by auto
+qed
+
+lemma continuous_on_open:
+ "continuous_on s f \<longleftrightarrow>
+ (\<forall>t. openin (subtopology euclidean (f ` s)) t
+ --> openin (subtopology euclidean s) {x \<in> s. f x \<in> t})" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix t assume as:"openin (subtopology euclidean (f ` s)) t"
+ have "{x \<in> s. f x \<in> t} \<subseteq> s" using as[unfolded openin_euclidean_subtopology_iff] by auto
+ moreover
+ { fix x assume as':"x\<in>{x \<in> s. f x \<in> t}"
+ then obtain e where e: "e>0" "\<forall>x'\<in>f ` s. dist x' (f x) < e \<longrightarrow> x' \<in> t" using as[unfolded openin_euclidean_subtopology_iff, THEN conjunct2, THEN bspec[where x="f x"]] by auto
+ from this(1) obtain d where d: "d>0" "\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" using `?lhs`[unfolded continuous_on Lim_within, THEN bspec[where x=x]] using as' by auto
+ have "\<exists>e>0. \<forall>x'\<in>s. dist x' x < e \<longrightarrow> x' \<in> {x \<in> s. f x \<in> t}" using d e unfolding dist_nz[THEN sym] by (rule_tac x=d in exI, auto) }
+ ultimately have "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}" unfolding openin_euclidean_subtopology_iff by auto }
+ thus ?rhs unfolding continuous_on Lim_within using openin by auto
+next
+ assume ?rhs
+ { fix e::real and x assume "x\<in>s" "e>0"
+ { fix xa x' assume "dist (f xa) (f x) < e" "xa \<in> s" "x' \<in> s" "dist (f xa) (f x') < e - dist (f xa) (f x)"
+ hence "dist (f x') (f x) < e" using dist_triangle[of "f x'" "f x" "f xa"]
+ by (auto simp add: dist_commute) }
+ hence "ball (f x) e \<inter> f ` s \<subseteq> f ` s \<and> (\<forall>xa\<in>ball (f x) e \<inter> f ` s. \<exists>ea>0. \<forall>x'\<in>f ` s. dist x' xa < ea \<longrightarrow> x' \<in> ball (f x) e \<inter> f ` s)" apply auto
+ apply(rule_tac x="e - dist (f xa) (f x)" in exI) using `e>0` by (auto simp add: dist_commute)
+ hence "\<forall>xa\<in>{xa \<in> s. f xa \<in> ball (f x) e \<inter> f ` s}. \<exists>ea>0. \<forall>x'\<in>s. dist x' xa < ea \<longrightarrow> x' \<in> {xa \<in> s. f xa \<in> ball (f x) e \<inter> f ` s}"
+ using `?rhs`[unfolded openin_euclidean_subtopology_iff, THEN spec[where x="ball (f x) e \<inter> f ` s"]] by auto
+ hence "\<exists>d>0. \<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < e" apply(erule_tac x=x in ballE) apply auto using `e>0` `x\<in>s` by (auto simp add: dist_commute) }
+ thus ?lhs unfolding continuous_on Lim_within by auto
+qed
+
+(* ------------------------------------------------------------------------- *)
+(* Similarly in terms of closed sets. *)
+(* ------------------------------------------------------------------------- *)
+
+lemma continuous_on_closed:
+ "continuous_on s f \<longleftrightarrow> (\<forall>t. closedin (subtopology euclidean (f ` s)) t --> closedin (subtopology euclidean s) {x \<in> s. f x \<in> t})" (is "?lhs = ?rhs")
+proof
+ assume ?lhs
+ { fix t
+ have *:"s - {x \<in> s. f x \<in> f ` s - t} = {x \<in> s. f x \<in> t}" by auto
+ have **:"f ` s - (f ` s - (f ` s - t)) = f ` s - t" by auto
+ assume as:"closedin (subtopology euclidean (f ` s)) t"
+ hence "closedin (subtopology euclidean (f ` s)) (f ` s - (f ` s - t))" unfolding closedin_def topspace_euclidean_subtopology unfolding ** by auto
+ hence "closedin (subtopology euclidean s) {x \<in> s. f x \<in> t}" using `?lhs`[unfolded continuous_on_open, THEN spec[where x="(f ` s) - t"]]
+ unfolding openin_closedin_eq topspace_euclidean_subtopology unfolding * by auto }
+ thus ?rhs by auto
+next
+ assume ?rhs
+ { fix t
+ have *:"s - {x \<in> s. f x \<in> f ` s - t} = {x \<in> s. f x \<in> t}" by auto
+ assume as:"openin (subtopology euclidean (f ` s)) t"
+ hence "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}" using `?rhs`[THEN spec[where x="(f ` s) - t"]]
+ unfolding openin_closedin_eq topspace_euclidean_subtopology *[THEN sym] closedin_subtopology by auto }
+ thus ?lhs unfolding continuous_on_open by auto
+qed
+
+text{* Half-global and completely global cases. *}
+
+lemma continuous_open_in_preimage:
+ assumes "continuous_on s f" "open t"
+ shows "openin (subtopology euclidean s) {x \<in> s. f x \<in> t}"
+proof-
+ have *:"\<forall>x. x \<in> s \<and> f x \<in> t \<longleftrightarrow> x \<in> s \<and> f x \<in> (t \<inter> f ` s)" by auto
+ have "openin (subtopology euclidean (f ` s)) (t \<inter> f ` s)"
+ using openin_open_Int[of t "f ` s", OF assms(2)] unfolding openin_open by auto
+ thus ?thesis using assms(1)[unfolded continuous_on_open, THEN spec[where x="t \<inter> f ` s"]] using * by auto
+qed
+
+lemma continuous_closed_in_preimage:
+ assumes "continuous_on s f" "closed t"
+ shows "closedin (subtopology euclidean s) {x \<in> s. f x \<in> t}"
+proof-
+ have *:"\<forall>x. x \<in> s \<and> f x \<in> t \<longleftrightarrow> x \<in> s \<and> f x \<in> (t \<inter> f ` s)" by auto
+ have "closedin (subtopology euclidean (f ` s)) (t \<inter> f ` s)"
+ using closedin_closed_Int[of t "f ` s", OF assms(2)] unfolding Int_commute by auto
+ thus ?thesis
+ using assms(1)[unfolded continuous_on_closed, THEN spec[where x="t \<inter> f ` s"]] using * by auto
+qed
+
+lemma continuous_open_preimage:
+ assumes "continuous_on s f" "open s" "open t"
+ shows "open {x \<in> s. f x \<in> t}"
+proof-
+ obtain T where T: "open T" "{x \<in> s. f x \<in> t} = s \<inter> T"
+ using continuous_open_in_preimage[OF assms(1,3)] unfolding openin_open by auto
+ thus ?thesis using open_Int[of s T, OF assms(2)] by auto
+qed
+
+lemma continuous_closed_preimage:
+ assumes "continuous_on s f" "closed s" "closed t"
+ shows "closed {x \<in> s. f x \<in> t}"
+proof-
+ obtain T where T: "closed T" "{x \<in> s. f x \<in> t} = s \<inter> T"
+ using continuous_closed_in_preimage[OF assms(1,3)] unfolding closedin_closed by auto
+ thus ?thesis using closed_Int[of s T, OF assms(2)] by auto
+qed
+
+lemma continuous_open_preimage_univ:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ shows "\<forall>x. continuous (at x) f \<Longrightarrow> open s \<Longrightarrow> open {x. f x \<in> s}"
+ using continuous_open_preimage[of UNIV f s] open_UNIV continuous_at_imp_continuous_on by auto
+
+lemma continuous_closed_preimage_univ:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ shows "(\<forall>x. continuous (at x) f) \<Longrightarrow> closed s ==> closed {x. f x \<in> s}"
+ using continuous_closed_preimage[of UNIV f s] closed_UNIV continuous_at_imp_continuous_on by auto
+
+lemma continuous_open_vimage:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ shows "\<forall>x. continuous (at x) f \<Longrightarrow> open s \<Longrightarrow> open (f -` s)"
+ unfolding vimage_def by (rule continuous_open_preimage_univ)
+
+lemma continuous_closed_vimage:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ shows "\<forall>x. continuous (at x) f \<Longrightarrow> closed s \<Longrightarrow> closed (f -` s)"
+ unfolding vimage_def by (rule continuous_closed_preimage_univ)
+
+text{* Equality of continuous functions on closure and related results. *}
+
+lemma continuous_closed_in_preimage_constant:
+ "continuous_on s f ==> closedin (subtopology euclidean s) {x \<in> s. f x = a}"
+ using continuous_closed_in_preimage[of s f "{a}"] closed_sing by auto
+
+lemma continuous_closed_preimage_constant:
+ "continuous_on s f \<Longrightarrow> closed s ==> closed {x \<in> s. f x = a}"
+ using continuous_closed_preimage[of s f "{a}"] closed_sing by auto
+
+lemma continuous_constant_on_closure:
+ assumes "continuous_on (closure s) f"
+ "\<forall>x \<in> s. f x = a"
+ shows "\<forall>x \<in> (closure s). f x = a"
+ using continuous_closed_preimage_constant[of "closure s" f a]
+ assms closure_minimal[of s "{x \<in> closure s. f x = a}"] closure_subset unfolding subset_eq by auto
+
+lemma image_closure_subset:
+ assumes "continuous_on (closure s) f" "closed t" "(f ` s) \<subseteq> t"
+ shows "f ` (closure s) \<subseteq> t"
+proof-
+ have "s \<subseteq> {x \<in> closure s. f x \<in> t}" using assms(3) closure_subset by auto
+ moreover have "closed {x \<in> closure s. f x \<in> t}"
+ using continuous_closed_preimage[OF assms(1)] and assms(2) by auto
+ ultimately have "closure s = {x \<in> closure s . f x \<in> t}"
+ using closure_minimal[of s "{x \<in> closure s. f x \<in> t}"] by auto
+ thus ?thesis by auto
+qed
+
+lemma continuous_on_closure_norm_le:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ assumes "continuous_on (closure s) f" "\<forall>y \<in> s. norm(f y) \<le> b" "x \<in> (closure s)"
+ shows "norm(f x) \<le> b"
+proof-
+ have *:"f ` s \<subseteq> cball 0 b" using assms(2)[unfolded mem_cball_0[THEN sym]] by auto
+ show ?thesis
+ using image_closure_subset[OF assms(1) closed_cball[of 0 b] *] assms(3)
+ unfolding subset_eq apply(erule_tac x="f x" in ballE) by (auto simp add: dist_norm)
+qed
+
+text{* Making a continuous function avoid some value in a neighbourhood. *}
+
+lemma continuous_within_avoid:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ assumes "continuous (at x within s) f" "x \<in> s" "f x \<noteq> a"
+ shows "\<exists>e>0. \<forall>y \<in> s. dist x y < e --> f y \<noteq> a"
+proof-
+ obtain d where "d>0" and d:"\<forall>xa\<in>s. 0 < dist xa x \<and> dist xa x < d \<longrightarrow> dist (f xa) (f x) < dist (f x) a"
+ using assms(1)[unfolded continuous_within Lim_within, THEN spec[where x="dist (f x) a"]] assms(3)[unfolded dist_nz] by auto
+ { fix y assume " y\<in>s" "dist x y < d"
+ hence "f y \<noteq> a" using d[THEN bspec[where x=y]] assms(3)[unfolded dist_nz]
+ apply auto unfolding dist_nz[THEN sym] by (auto simp add: dist_commute) }
+ thus ?thesis using `d>0` by auto
+qed
+
+lemma continuous_at_avoid:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::metric_space" (* FIXME: generalize *)
+ assumes "continuous (at x) f" "f x \<noteq> a"
+ shows "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> f y \<noteq> a"
+using assms using continuous_within_avoid[of x UNIV f a, unfolded within_UNIV] by auto
+
+lemma continuous_on_avoid:
+ assumes "continuous_on s f" "x \<in> s" "f x \<noteq> a"
+ shows "\<exists>e>0. \<forall>y \<in> s. dist x y < e \<longrightarrow> f y \<noteq> a"
+using assms(1)[unfolded continuous_on_eq_continuous_within, THEN bspec[where x=x], OF assms(2)] continuous_within_avoid[of x s f a] assms(2,3) by auto
+
+lemma continuous_on_open_avoid:
+ assumes "continuous_on s f" "open s" "x \<in> s" "f x \<noteq> a"
+ shows "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> f y \<noteq> a"
+using assms(1)[unfolded continuous_on_eq_continuous_at[OF assms(2)], THEN bspec[where x=x], OF assms(3)] continuous_at_avoid[of x f a] assms(3,4) by auto
+
+text{* Proving a function is constant by proving open-ness of level set. *}
+
+lemma continuous_levelset_open_in_cases:
+ "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
+ openin (subtopology euclidean s) {x \<in> s. f x = a}
+ ==> (\<forall>x \<in> s. f x \<noteq> a) \<or> (\<forall>x \<in> s. f x = a)"
+unfolding connected_clopen using continuous_closed_in_preimage_constant by auto
+
+lemma continuous_levelset_open_in:
+ "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
+ openin (subtopology euclidean s) {x \<in> s. f x = a} \<Longrightarrow>
+ (\<exists>x \<in> s. f x = a) ==> (\<forall>x \<in> s. f x = a)"
+using continuous_levelset_open_in_cases[of s f ]
+by meson
+
+lemma continuous_levelset_open:
+ assumes "connected s" "continuous_on s f" "open {x \<in> s. f x = a}" "\<exists>x \<in> s. f x = a"
+ shows "\<forall>x \<in> s. f x = a"
+using continuous_levelset_open_in[OF assms(1,2), of a, unfolded openin_open] using assms (3,4) by auto
+
+text{* Some arithmetical combinations (more to prove). *}
+
+lemma open_scaling[intro]:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "c \<noteq> 0" "open s"
+ shows "open((\<lambda>x. c *\<^sub>R x) ` s)"
+proof-
+ { fix x assume "x \<in> s"
+ then obtain e where "e>0" and e:"\<forall>x'. dist x' x < e \<longrightarrow> x' \<in> s" using assms(2)[unfolded open_dist, THEN bspec[where x=x]] by auto
+ have "e * abs c > 0" using assms(1)[unfolded zero_less_abs_iff[THEN sym]] using real_mult_order[OF `e>0`] by auto
+ moreover
+ { fix y assume "dist y (c *\<^sub>R x) < e * \<bar>c\<bar>"
+ hence "norm ((1 / c) *\<^sub>R y - x) < e" unfolding dist_norm
+ using norm_scaleR[of c "(1 / c) *\<^sub>R y - x", unfolded scaleR_right_diff_distrib, unfolded scaleR_scaleR] assms(1)
+ assms(1)[unfolded zero_less_abs_iff[THEN sym]] by (simp del:zero_less_abs_iff)
+ hence "y \<in> op *\<^sub>R c ` s" using rev_image_eqI[of "(1 / c) *\<^sub>R y" s y "op *\<^sub>R c"] e[THEN spec[where x="(1 / c) *\<^sub>R y"]] assms(1) unfolding dist_norm scaleR_scaleR by auto }
+ ultimately have "\<exists>e>0. \<forall>x'. dist x' (c *\<^sub>R x) < e \<longrightarrow> x' \<in> op *\<^sub>R c ` s" apply(rule_tac x="e * abs c" in exI) by auto }
+ thus ?thesis unfolding open_dist by auto
+qed
+
+lemma minus_image_eq_vimage:
+ fixes A :: "'a::ab_group_add set"
+ shows "(\<lambda>x. - x) ` A = (\<lambda>x. - x) -` A"
+ by (auto intro!: image_eqI [where f="\<lambda>x. - x"])
+
+lemma open_negations:
+ fixes s :: "'a::real_normed_vector set"
+ shows "open s ==> open ((\<lambda> x. -x) ` s)"
+ unfolding scaleR_minus1_left [symmetric]
+ by (rule open_scaling, auto)
+
+lemma open_translation:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "open s" shows "open((\<lambda>x. a + x) ` s)"
+proof-
+ { fix x have "continuous (at x) (\<lambda>x. x - a)" using continuous_sub[of "at x" "\<lambda>x. x" "\<lambda>x. a"] continuous_at_id[of x] continuous_const[of "at x" a] by auto }
+ moreover have "{x. x - a \<in> s} = op + a ` s" apply auto unfolding image_iff apply(rule_tac x="x - a" in bexI) by auto
+ ultimately show ?thesis using continuous_open_preimage_univ[of "\<lambda>x. x - a" s] using assms by auto
+qed
+
+lemma open_affinity:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "open s" "c \<noteq> 0"
+ shows "open ((\<lambda>x. a + c *\<^sub>R x) ` s)"
+proof-
+ have *:"(\<lambda>x. a + c *\<^sub>R x) = (\<lambda>x. a + x) \<circ> (\<lambda>x. c *\<^sub>R x)" unfolding o_def ..
+ have "op + a ` op *\<^sub>R c ` s = (op + a \<circ> op *\<^sub>R c) ` s" by auto
+ thus ?thesis using assms open_translation[of "op *\<^sub>R c ` s" a] unfolding * by auto
+qed
+
+lemma interior_translation:
+ fixes s :: "'a::real_normed_vector set"
+ shows "interior ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (interior s)"
+proof (rule set_ext, rule)
+ fix x assume "x \<in> interior (op + a ` s)"
+ then obtain e where "e>0" and e:"ball x e \<subseteq> op + a ` s" unfolding mem_interior by auto
+ hence "ball (x - a) e \<subseteq> s" unfolding subset_eq Ball_def mem_ball dist_norm apply auto apply(erule_tac x="a + xa" in allE) unfolding ab_group_add_class.diff_diff_eq[THEN sym] by auto
+ thus "x \<in> op + a ` interior s" unfolding image_iff apply(rule_tac x="x - a" in bexI) unfolding mem_interior using `e > 0` by auto
+next
+ fix x assume "x \<in> op + a ` interior s"
+ then obtain y e where "e>0" and e:"ball y e \<subseteq> s" and y:"x = a + y" unfolding image_iff Bex_def mem_interior by auto
+ { fix z have *:"a + y - z = y + a - z" by auto
+ assume "z\<in>ball x e"
+ hence "z - a \<in> s" using e[unfolded subset_eq, THEN bspec[where x="z - a"]] unfolding mem_ball dist_norm y ab_group_add_class.diff_diff_eq2 * by auto
+ hence "z \<in> op + a ` s" unfolding image_iff by(auto intro!: bexI[where x="z - a"]) }
+ hence "ball x e \<subseteq> op + a ` s" unfolding subset_eq by auto
+ thus "x \<in> interior (op + a ` s)" unfolding mem_interior using `e>0` by auto
+qed
+
+subsection {* Preservation of compactness and connectedness under continuous function. *}
+
+lemma compact_continuous_image:
+ assumes "continuous_on s f" "compact s"
+ shows "compact(f ` s)"
+proof-
+ { fix x assume x:"\<forall>n::nat. x n \<in> f ` s"
+ then obtain y where y:"\<forall>n. y n \<in> s \<and> x n = f (y n)" unfolding image_iff Bex_def using choice[of "\<lambda>n xa. xa \<in> s \<and> x n = f xa"] by auto
+ then obtain l r where "l\<in>s" and r:"subseq r" and lr:"((y \<circ> r) ---> l) sequentially" using assms(2)[unfolded compact_def, THEN spec[where x=y]] by auto
+ { fix e::real assume "e>0"
+ then obtain d where "d>0" and d:"\<forall>x'\<in>s. dist x' l < d \<longrightarrow> dist (f x') (f l) < e" using assms(1)[unfolded continuous_on_def, THEN bspec[where x=l], OF `l\<in>s`] by auto
+ then obtain N::nat where N:"\<forall>n\<ge>N. dist ((y \<circ> r) n) l < d" using lr[unfolded Lim_sequentially, THEN spec[where x=d]] by auto
+ { fix n::nat assume "n\<ge>N" hence "dist ((x \<circ> r) n) (f l) < e" using N[THEN spec[where x=n]] d[THEN bspec[where x="y (r n)"]] y[THEN spec[where x="r n"]] by auto }
+ hence "\<exists>N. \<forall>n\<ge>N. dist ((x \<circ> r) n) (f l) < e" by auto }
+ hence "\<exists>l\<in>f ` s. \<exists>r. subseq r \<and> ((x \<circ> r) ---> l) sequentially" unfolding Lim_sequentially using r lr `l\<in>s` by auto }
+ thus ?thesis unfolding compact_def by auto
+qed
+
+lemma connected_continuous_image:
+ assumes "continuous_on s f" "connected s"
+ shows "connected(f ` s)"
+proof-
+ { fix T assume as: "T \<noteq> {}" "T \<noteq> f ` s" "openin (subtopology euclidean (f ` s)) T" "closedin (subtopology euclidean (f ` s)) T"
+ have "{x \<in> s. f x \<in> T} = {} \<or> {x \<in> s. f x \<in> T} = s"
+ using assms(1)[unfolded continuous_on_open, THEN spec[where x=T]]
+ using assms(1)[unfolded continuous_on_closed, THEN spec[where x=T]]
+ using assms(2)[unfolded connected_clopen, THEN spec[where x="{x \<in> s. f x \<in> T}"]] as(3,4) by auto
+ hence False using as(1,2)
+ using as(4)[unfolded closedin_def topspace_euclidean_subtopology] by auto }
+ thus ?thesis unfolding connected_clopen by auto
+qed
+
+text{* Continuity implies uniform continuity on a compact domain. *}
+
+lemma compact_uniformly_continuous:
+ assumes "continuous_on s f" "compact s"
+ shows "uniformly_continuous_on s f"
+proof-
+ { fix x assume x:"x\<in>s"
+ hence "\<forall>xa. \<exists>y. 0 < xa \<longrightarrow> (y > 0 \<and> (\<forall>x'\<in>s. dist x' x < y \<longrightarrow> dist (f x') (f x) < xa))" using assms(1)[unfolded continuous_on_def, THEN bspec[where x=x]] by auto
+ hence "\<exists>fa. \<forall>xa>0. \<forall>x'\<in>s. fa xa > 0 \<and> (dist x' x < fa xa \<longrightarrow> dist (f x') (f x) < xa)" using choice[of "\<lambda>e d. e>0 \<longrightarrow> d>0 \<and>(\<forall>x'\<in>s. (dist x' x < d \<longrightarrow> dist (f x') (f x) < e))"] by auto }
+ then have "\<forall>x\<in>s. \<exists>y. \<forall>xa. 0 < xa \<longrightarrow> (\<forall>x'\<in>s. y xa > 0 \<and> (dist x' x < y xa \<longrightarrow> dist (f x') (f x) < xa))" by auto
+ then obtain d where d:"\<forall>e>0. \<forall>x\<in>s. \<forall>x'\<in>s. d x e > 0 \<and> (dist x' x < d x e \<longrightarrow> dist (f x') (f x) < e)"
+ using bchoice[of s "\<lambda>x fa. \<forall>xa>0. \<forall>x'\<in>s. fa xa > 0 \<and> (dist x' x < fa xa \<longrightarrow> dist (f x') (f x) < xa)"] by blast
+
+ { fix e::real assume "e>0"
+
+ { fix x assume "x\<in>s" hence "x \<in> ball x (d x (e / 2))" unfolding centre_in_ball using d[THEN spec[where x="e/2"]] using `e>0` by auto }
+ hence "s \<subseteq> \<Union>{ball x (d x (e / 2)) |x. x \<in> s}" unfolding subset_eq by auto
+ moreover
+ { fix b assume "b\<in>{ball x (d x (e / 2)) |x. x \<in> s}" hence "open b" by auto }
+ ultimately obtain ea where "ea>0" and ea:"\<forall>x\<in>s. \<exists>b\<in>{ball x (d x (e / 2)) |x. x \<in> s}. ball x ea \<subseteq> b" using heine_borel_lemma[OF assms(2), of "{ball x (d x (e / 2)) | x. x\<in>s }"] by auto
+
+ { fix x y assume "x\<in>s" "y\<in>s" and as:"dist y x < ea"
+ obtain z where "z\<in>s" and z:"ball x ea \<subseteq> ball z (d z (e / 2))" using ea[THEN bspec[where x=x]] and `x\<in>s` by auto
+ hence "x\<in>ball z (d z (e / 2))" using `ea>0` unfolding subset_eq by auto
+ hence "dist (f z) (f x) < e / 2" using d[THEN spec[where x="e/2"]] and `e>0` and `x\<in>s` and `z\<in>s`
+ by (auto simp add: dist_commute)
+ moreover have "y\<in>ball z (d z (e / 2))" using as and `ea>0` and z[unfolded subset_eq]
+ by (auto simp add: dist_commute)
+ hence "dist (f z) (f y) < e / 2" using d[THEN spec[where x="e/2"]] and `e>0` and `y\<in>s` and `z\<in>s`
+ by (auto simp add: dist_commute)
+ ultimately have "dist (f y) (f x) < e" using dist_triangle_half_r[of "f z" "f x" e "f y"]
+ by (auto simp add: dist_commute) }
+ then have "\<exists>d>0. \<forall>x\<in>s. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f x') (f x) < e" using `ea>0` by auto }
+ thus ?thesis unfolding uniformly_continuous_on_def by auto
+qed
+
+text{* Continuity of inverse function on compact domain. *}
+
+lemma continuous_on_inverse:
+ fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
+ (* TODO: can this be generalized more? *)
+ assumes "continuous_on s f" "compact s" "\<forall>x \<in> s. g (f x) = x"
+ shows "continuous_on (f ` s) g"
+proof-
+ have *:"g ` f ` s = s" using assms(3) by (auto simp add: image_iff)
+ { fix t assume t:"closedin (subtopology euclidean (g ` f ` s)) t"
+ then obtain T where T: "closed T" "t = s \<inter> T" unfolding closedin_closed unfolding * by auto
+ have "continuous_on (s \<inter> T) f" using continuous_on_subset[OF assms(1), of "s \<inter> t"]
+ unfolding T(2) and Int_left_absorb by auto
+ moreover have "compact (s \<inter> T)"
+ using assms(2) unfolding compact_eq_bounded_closed
+ using bounded_subset[of s "s \<inter> T"] and T(1) by auto
+ ultimately have "closed (f ` t)" using T(1) unfolding T(2)
+ using compact_continuous_image [of "s \<inter> T" f] unfolding compact_eq_bounded_closed by auto
+ moreover have "{x \<in> f ` s. g x \<in> t} = f ` s \<inter> f ` t" using assms(3) unfolding T(2) by auto
+ ultimately have "closedin (subtopology euclidean (f ` s)) {x \<in> f ` s. g x \<in> t}"
+ unfolding closedin_closed by auto }
+ thus ?thesis unfolding continuous_on_closed by auto
+qed
+
+subsection{* A uniformly convergent limit of continuous functions is continuous. *}
+
+lemma norm_triangle_lt:
+ fixes x y :: "'a::real_normed_vector"
+ shows "norm x + norm y < e \<Longrightarrow> norm (x + y) < e"
+by (rule le_less_trans [OF norm_triangle_ineq])
+
+lemma continuous_uniform_limit:
+ fixes f :: "'a \<Rightarrow> 'b::metric_space \<Rightarrow> 'c::real_normed_vector"
+ assumes "\<not> (trivial_limit net)" "eventually (\<lambda>n. continuous_on s (f n)) net"
+ "\<forall>e>0. eventually (\<lambda>n. \<forall>x \<in> s. norm(f n x - g x) < e) net"
+ shows "continuous_on s g"
+proof-
+ { fix x and e::real assume "x\<in>s" "e>0"
+ have "eventually (\<lambda>n. \<forall>x\<in>s. norm (f n x - g x) < e / 3) net" using `e>0` assms(3)[THEN spec[where x="e/3"]] by auto
+ then obtain n where n:"\<forall>xa\<in>s. norm (f n xa - g xa) < e / 3" "continuous_on s (f n)"
+ using eventually_and[of "(\<lambda>n. \<forall>x\<in>s. norm (f n x - g x) < e / 3)" "(\<lambda>n. continuous_on s (f n))" net] assms(1,2) eventually_happens by blast
+ have "e / 3 > 0" using `e>0` by auto
+ then obtain d where "d>0" and d:"\<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (f n x') (f n x) < e / 3"
+ using n(2)[unfolded continuous_on_def, THEN bspec[where x=x], OF `x\<in>s`, THEN spec[where x="e/3"]] by blast
+ { fix y assume "y\<in>s" "dist y x < d"
+ hence "dist (f n y) (f n x) < e / 3" using d[THEN bspec[where x=y]] by auto
+ hence "norm (f n y - g x) < 2 * e / 3" using norm_triangle_lt[of "f n y - f n x" "f n x - g x" "2*e/3"]
+ using n(1)[THEN bspec[where x=x], OF `x\<in>s`] unfolding dist_norm unfolding ab_group_add_class.ab_diff_minus by auto
+ hence "dist (g y) (g x) < e" unfolding dist_norm using n(1)[THEN bspec[where x=y], OF `y\<in>s`]
+ unfolding norm_minus_cancel[of "f n y - g y", THEN sym] using norm_triangle_lt[of "f n y - g x" "g y - f n y" e] by (auto simp add: uminus_add_conv_diff) }
+ hence "\<exists>d>0. \<forall>x'\<in>s. dist x' x < d \<longrightarrow> dist (g x') (g x) < e" using `d>0` by auto }
+ thus ?thesis unfolding continuous_on_def by auto
+qed
+
+subsection{* Topological properties of linear functions. *}
+
+lemma linear_lim_0:
+ assumes "bounded_linear f" shows "(f ---> 0) (at (0))"
+proof-
+ interpret f: bounded_linear f by fact
+ have "(f ---> f 0) (at 0)"
+ using tendsto_ident_at by (rule f.tendsto)
+ thus ?thesis unfolding f.zero .
+qed
+
+lemma linear_continuous_at:
+ assumes "bounded_linear f" shows "continuous (at a) f"
+ unfolding continuous_at using assms
+ apply (rule bounded_linear.tendsto)
+ apply (rule tendsto_ident_at)
+ done
+
+lemma linear_continuous_within:
+ shows "bounded_linear f ==> continuous (at x within s) f"
+ using continuous_at_imp_continuous_within[of x f s] using linear_continuous_at[of f] by auto
+
+lemma linear_continuous_on:
+ shows "bounded_linear f ==> continuous_on s f"
+ using continuous_at_imp_continuous_on[of s f] using linear_continuous_at[of f] by auto
+
+text{* Also bilinear functions, in composition form. *}
+
+lemma bilinear_continuous_at_compose:
+ shows "continuous (at x) f \<Longrightarrow> continuous (at x) g \<Longrightarrow> bounded_bilinear h
+ ==> continuous (at x) (\<lambda>x. h (f x) (g x))"
+ unfolding continuous_at using Lim_bilinear[of f "f x" "(at x)" g "g x" h] by auto
+
+lemma bilinear_continuous_within_compose:
+ shows "continuous (at x within s) f \<Longrightarrow> continuous (at x within s) g \<Longrightarrow> bounded_bilinear h
+ ==> continuous (at x within s) (\<lambda>x. h (f x) (g x))"
+ unfolding continuous_within using Lim_bilinear[of f "f x"] by auto
+
+lemma bilinear_continuous_on_compose:
+ shows "continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> bounded_bilinear h
+ ==> continuous_on s (\<lambda>x. h (f x) (g x))"
+ unfolding continuous_on_eq_continuous_within apply auto apply(erule_tac x=x in ballE) apply auto apply(erule_tac x=x in ballE) apply auto
+ using bilinear_continuous_within_compose[of _ s f g h] by auto
+
+subsection{* Topological stuff lifted from and dropped to R *}
+
+
+lemma open_real:
+ fixes s :: "real set" shows
+ "open s \<longleftrightarrow>
+ (\<forall>x \<in> s. \<exists>e>0. \<forall>x'. abs(x' - x) < e --> x' \<in> s)" (is "?lhs = ?rhs")
+ unfolding open_dist dist_norm by simp
+
+lemma islimpt_approachable_real:
+ fixes s :: "real set"
+ shows "x islimpt s \<longleftrightarrow> (\<forall>e>0. \<exists>x'\<in> s. x' \<noteq> x \<and> abs(x' - x) < e)"
+ unfolding islimpt_approachable dist_norm by simp
+
+lemma closed_real:
+ fixes s :: "real set"
+ shows "closed s \<longleftrightarrow>
+ (\<forall>x. (\<forall>e>0. \<exists>x' \<in> s. x' \<noteq> x \<and> abs(x' - x) < e)
+ --> x \<in> s)"
+ unfolding closed_limpt islimpt_approachable dist_norm by simp
+
+lemma continuous_at_real_range:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> real"
+ shows "continuous (at x) f \<longleftrightarrow> (\<forall>e>0. \<exists>d>0.
+ \<forall>x'. norm(x' - x) < d --> abs(f x' - f x) < e)"
+ unfolding continuous_at unfolding Lim_at
+ unfolding dist_nz[THEN sym] unfolding dist_norm apply auto
+ apply(erule_tac x=e in allE) apply auto apply (rule_tac x=d in exI) apply auto apply (erule_tac x=x' in allE) apply auto
+ apply(erule_tac x=e in allE) by auto
+
+lemma continuous_on_real_range:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> real"
+ shows "continuous_on s f \<longleftrightarrow> (\<forall>x \<in> s. \<forall>e>0. \<exists>d>0. (\<forall>x' \<in> s. norm(x' - x) < d --> abs(f x' - f x) < e))"
+ unfolding continuous_on_def dist_norm by simp
+
+lemma continuous_at_norm: "continuous (at x) norm"
+ unfolding continuous_at by (intro tendsto_intros)
+
+lemma continuous_on_norm: "continuous_on s norm"
+unfolding continuous_on by (intro ballI tendsto_intros)
+
+lemma continuous_at_component: "continuous (at a) (\<lambda>x. x $ i)"
+unfolding continuous_at by (intro tendsto_intros)
+
+lemma continuous_on_component: "continuous_on s (\<lambda>x. x $ i)"
+unfolding continuous_on by (intro ballI tendsto_intros)
+
+lemma continuous_at_infnorm: "continuous (at x) infnorm"
+ unfolding continuous_at Lim_at o_def unfolding dist_norm
+ apply auto apply (rule_tac x=e in exI) apply auto
+ using order_trans[OF real_abs_sub_infnorm infnorm_le_norm, of _ x] by (metis xt1(7))
+
+text{* Hence some handy theorems on distance, diameter etc. of/from a set. *}
+
+lemma compact_attains_sup:
+ fixes s :: "real set"
+ assumes "compact s" "s \<noteq> {}"
+ shows "\<exists>x \<in> s. \<forall>y \<in> s. y \<le> x"
+proof-
+ from assms(1) have a:"bounded s" "closed s" unfolding compact_eq_bounded_closed by auto
+ { fix e::real assume as: "\<forall>x\<in>s. x \<le> Sup s" "Sup s \<notin> s" "0 < e" "\<forall>x'\<in>s. x' = Sup s \<or> \<not> Sup s - x' < e"
+ have "isLub UNIV s (Sup s)" using Sup[OF assms(2)] unfolding setle_def using as(1) by auto
+ moreover have "isUb UNIV s (Sup s - e)" unfolding isUb_def unfolding setle_def using as(4,2) by auto
+ ultimately have False using isLub_le_isUb[of UNIV s "Sup s" "Sup s - e"] using `e>0` by auto }
+ thus ?thesis using bounded_has_Sup(1)[OF a(1) assms(2)] using a(2)[unfolded closed_real, THEN spec[where x="Sup s"]]
+ apply(rule_tac x="Sup s" in bexI) by auto
+qed
+
+lemma Inf:
+ fixes S :: "real set"
+ shows "S \<noteq> {} ==> (\<exists>b. b <=* S) ==> isGlb UNIV S (Inf S)"
+by (auto simp add: isLb_def setle_def setge_def isGlb_def greatestP_def)
+
+lemma compact_attains_inf:
+ fixes s :: "real set"
+ assumes "compact s" "s \<noteq> {}" shows "\<exists>x \<in> s. \<forall>y \<in> s. x \<le> y"
+proof-
+ from assms(1) have a:"bounded s" "closed s" unfolding compact_eq_bounded_closed by auto
+ { fix e::real assume as: "\<forall>x\<in>s. x \<ge> Inf s" "Inf s \<notin> s" "0 < e"
+ "\<forall>x'\<in>s. x' = Inf s \<or> \<not> abs (x' - Inf s) < e"
+ have "isGlb UNIV s (Inf s)" using Inf[OF assms(2)] unfolding setge_def using as(1) by auto
+ moreover
+ { fix x assume "x \<in> s"
+ hence *:"abs (x - Inf s) = x - Inf s" using as(1)[THEN bspec[where x=x]] by auto
+ have "Inf s + e \<le> x" using as(4)[THEN bspec[where x=x]] using as(2) `x\<in>s` unfolding * by auto }
+ hence "isLb UNIV s (Inf s + e)" unfolding isLb_def and setge_def by auto
+ ultimately have False using isGlb_le_isLb[of UNIV s "Inf s" "Inf s + e"] using `e>0` by auto }
+ thus ?thesis using bounded_has_Inf(1)[OF a(1) assms(2)] using a(2)[unfolded closed_real, THEN spec[where x="Inf s"]]
+ apply(rule_tac x="Inf s" in bexI) by auto
+qed
+
+lemma continuous_attains_sup:
+ fixes f :: "'a::metric_space \<Rightarrow> real"
+ shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f
+ ==> (\<exists>x \<in> s. \<forall>y \<in> s. f y \<le> f x)"
+ using compact_attains_sup[of "f ` s"]
+ using compact_continuous_image[of s f] by auto
+
+lemma continuous_attains_inf:
+ fixes f :: "'a::metric_space \<Rightarrow> real"
+ shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f
+ \<Longrightarrow> (\<exists>x \<in> s. \<forall>y \<in> s. f x \<le> f y)"
+ using compact_attains_inf[of "f ` s"]
+ using compact_continuous_image[of s f] by auto
+
+lemma distance_attains_sup:
+ assumes "compact s" "s \<noteq> {}"
+ shows "\<exists>x \<in> s. \<forall>y \<in> s. dist a y \<le> dist a x"
+proof (rule continuous_attains_sup [OF assms])
+ { fix x assume "x\<in>s"
+ have "(dist a ---> dist a x) (at x within s)"
+ by (intro tendsto_dist tendsto_const Lim_at_within Lim_ident_at)
+ }
+ thus "continuous_on s (dist a)"
+ unfolding continuous_on ..
+qed
+
+text{* For *minimal* distance, we only need closure, not compactness. *}
+
+lemma distance_attains_inf:
+ fixes a :: "'a::heine_borel"
+ assumes "closed s" "s \<noteq> {}"
+ shows "\<exists>x \<in> s. \<forall>y \<in> s. dist a x \<le> dist a y"
+proof-
+ from assms(2) obtain b where "b\<in>s" by auto
+ let ?B = "cball a (dist b a) \<inter> s"
+ have "b \<in> ?B" using `b\<in>s` by (simp add: dist_commute)
+ hence "?B \<noteq> {}" by auto
+ moreover
+ { fix x assume "x\<in>?B"
+ fix e::real assume "e>0"
+ { fix x' assume "x'\<in>?B" and as:"dist x' x < e"
+ from as have "\<bar>dist a x' - dist a x\<bar> < e"
+ unfolding abs_less_iff minus_diff_eq
+ using dist_triangle2 [of a x' x]
+ using dist_triangle [of a x x']
+ by arith
+ }
+ hence "\<exists>d>0. \<forall>x'\<in>?B. dist x' x < d \<longrightarrow> \<bar>dist a x' - dist a x\<bar> < e"
+ using `e>0` by auto
+ }
+ hence "continuous_on (cball a (dist b a) \<inter> s) (dist a)"
+ unfolding continuous_on Lim_within dist_norm real_norm_def
+ by fast
+ moreover have "compact ?B"
+ using compact_cball[of a "dist b a"]
+ unfolding compact_eq_bounded_closed
+ using bounded_Int and closed_Int and assms(1) by auto
+ ultimately obtain x where "x\<in>cball a (dist b a) \<inter> s" "\<forall>y\<in>cball a (dist b a) \<inter> s. dist a x \<le> dist a y"
+ using continuous_attains_inf[of ?B "dist a"] by fastsimp
+ thus ?thesis by fastsimp
+qed
+
+subsection{* We can now extend limit compositions to consider the scalar multiplier. *}
+
+lemma Lim_mul:
+ fixes f :: "'a \<Rightarrow> 'b::real_normed_vector"
+ assumes "(c ---> d) net" "(f ---> l) net"
+ shows "((\<lambda>x. c(x) *\<^sub>R f x) ---> (d *\<^sub>R l)) net"
+ using assms by (rule scaleR.tendsto)
+
+lemma Lim_vmul:
+ fixes c :: "'a \<Rightarrow> real" and v :: "'b::real_normed_vector"
+ shows "(c ---> d) net ==> ((\<lambda>x. c(x) *\<^sub>R v) ---> d *\<^sub>R v) net"
+ by (intro tendsto_intros)
+
+lemma continuous_vmul:
+ fixes c :: "'a::metric_space \<Rightarrow> real" and v :: "'b::real_normed_vector"
+ shows "continuous net c ==> continuous net (\<lambda>x. c(x) *\<^sub>R v)"
+ unfolding continuous_def using Lim_vmul[of c] by auto
+
+lemma continuous_mul:
+ fixes c :: "'a::metric_space \<Rightarrow> real"
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous net c \<Longrightarrow> continuous net f
+ ==> continuous net (\<lambda>x. c(x) *\<^sub>R f x) "
+ unfolding continuous_def by (intro tendsto_intros)
+
+lemma continuous_on_vmul:
+ fixes c :: "'a::metric_space \<Rightarrow> real" and v :: "'b::real_normed_vector"
+ shows "continuous_on s c ==> continuous_on s (\<lambda>x. c(x) *\<^sub>R v)"
+ unfolding continuous_on_eq_continuous_within using continuous_vmul[of _ c] by auto
+
+lemma continuous_on_mul:
+ fixes c :: "'a::metric_space \<Rightarrow> real"
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
+ shows "continuous_on s c \<Longrightarrow> continuous_on s f
+ ==> continuous_on s (\<lambda>x. c(x) *\<^sub>R f x)"
+ unfolding continuous_on_eq_continuous_within using continuous_mul[of _ c] by auto
+
+text{* And so we have continuity of inverse. *}
+
+lemma Lim_inv:
+ fixes f :: "'a \<Rightarrow> real"
+ assumes "(f ---> l) (net::'a net)" "l \<noteq> 0"
+ shows "((inverse o f) ---> inverse l) net"
+ unfolding o_def using assms by (rule tendsto_inverse)
+
+lemma continuous_inv:
+ fixes f :: "'a::metric_space \<Rightarrow> real"
+ shows "continuous net f \<Longrightarrow> f(netlimit net) \<noteq> 0
+ ==> continuous net (inverse o f)"
+ unfolding continuous_def using Lim_inv by auto
+
+lemma continuous_at_within_inv:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_field"
+ assumes "continuous (at a within s) f" "f a \<noteq> 0"
+ shows "continuous (at a within s) (inverse o f)"
+ using assms unfolding continuous_within o_def
+ by (intro tendsto_intros)
+
+lemma continuous_at_inv:
+ fixes f :: "'a::metric_space \<Rightarrow> 'b::real_normed_field"
+ shows "continuous (at a) f \<Longrightarrow> f a \<noteq> 0
+ ==> continuous (at a) (inverse o f) "
+ using within_UNIV[THEN sym, of "at a"] using continuous_at_within_inv[of a UNIV] by auto
+
+subsection{* Preservation properties for pasted sets. *}
+
+lemma bounded_pastecart:
+ fixes s :: "('a::real_normed_vector ^ _) set" (* FIXME: generalize to metric_space *)
+ assumes "bounded s" "bounded t"
+ shows "bounded { pastecart x y | x y . (x \<in> s \<and> y \<in> t)}"
+proof-
+ obtain a b where ab:"\<forall>x\<in>s. norm x \<le> a" "\<forall>x\<in>t. norm x \<le> b" using assms[unfolded bounded_iff] by auto
+ { fix x y assume "x\<in>s" "y\<in>t"
+ hence "norm x \<le> a" "norm y \<le> b" using ab by auto
+ hence "norm (pastecart x y) \<le> a + b" using norm_pastecart[of x y] by auto }
+ thus ?thesis unfolding bounded_iff by auto
+qed
+
+lemma bounded_Times:
+ assumes "bounded s" "bounded t" shows "bounded (s \<times> t)"
+proof-
+ obtain x y a b where "\<forall>z\<in>s. dist x z \<le> a" "\<forall>z\<in>t. dist y z \<le> b"
+ using assms [unfolded bounded_def] by auto
+ then have "\<forall>z\<in>s \<times> t. dist (x, y) z \<le> sqrt (a\<twosuperior> + b\<twosuperior>)"
+ by (auto simp add: dist_Pair_Pair real_sqrt_le_mono add_mono power_mono)
+ thus ?thesis unfolding bounded_any_center [where a="(x, y)"] by auto
+qed
+
+lemma closed_pastecart:
+ fixes s :: "(real ^ 'a::finite) set" (* FIXME: generalize *)
+ assumes "closed s" "closed t"
+ shows "closed {pastecart x y | x y . x \<in> s \<and> y \<in> t}"
+proof-
+ { fix x l assume as:"\<forall>n::nat. x n \<in> {pastecart x y |x y. x \<in> s \<and> y \<in> t}" "(x ---> l) sequentially"
+ { fix n::nat have "fstcart (x n) \<in> s" "sndcart (x n) \<in> t" using as(1)[THEN spec[where x=n]] by auto } note * = this
+ moreover
+ { fix e::real assume "e>0"
+ then obtain N::nat where N:"\<forall>n\<ge>N. dist (x n) l < e" using as(2)[unfolded Lim_sequentially, THEN spec[where x=e]] by auto
+ { fix n::nat assume "n\<ge>N"
+ hence "dist (fstcart (x n)) (fstcart l) < e" "dist (sndcart (x n)) (sndcart l) < e"
+ using N[THEN spec[where x=n]] dist_fstcart[of "x n" l] dist_sndcart[of "x n" l] by auto }
+ hence "\<exists>N. \<forall>n\<ge>N. dist (fstcart (x n)) (fstcart l) < e" "\<exists>N. \<forall>n\<ge>N. dist (sndcart (x n)) (sndcart l) < e" by auto }
+ ultimately have "fstcart l \<in> s" "sndcart l \<in> t"
+ using assms(1)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. fstcart (x n)"], THEN spec[where x="fstcart l"]]
+ using assms(2)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. sndcart (x n)"], THEN spec[where x="sndcart l"]]
+ unfolding Lim_sequentially by auto
+ hence "l \<in> {pastecart x y |x y. x \<in> s \<and> y \<in> t}" using pastecart_fst_snd[THEN sym, of l] by auto }
+ thus ?thesis unfolding closed_sequential_limits by auto
+qed
+
+lemma compact_pastecart:
+ fixes s t :: "(real ^ _) set"
+ shows "compact s \<Longrightarrow> compact t ==> compact {pastecart x y | x y . x \<in> s \<and> y \<in> t}"
+ unfolding compact_eq_bounded_closed using bounded_pastecart[of s t] closed_pastecart[of s t] by auto
+
+lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
+by (induct x) simp
+
+lemma compact_Times: "compact s \<Longrightarrow> compact t \<Longrightarrow> compact (s \<times> t)"
+unfolding compact_def
+apply clarify
+apply (drule_tac x="fst \<circ> f" in spec)
+apply (drule mp, simp add: mem_Times_iff)
+apply (clarify, rename_tac l1 r1)
+apply (drule_tac x="snd \<circ> f \<circ> r1" in spec)
+apply (drule mp, simp add: mem_Times_iff)
+apply (clarify, rename_tac l2 r2)
+apply (rule_tac x="(l1, l2)" in rev_bexI, simp)
+apply (rule_tac x="r1 \<circ> r2" in exI)
+apply (rule conjI, simp add: subseq_def)
+apply (drule_tac r=r2 in lim_subseq [COMP swap_prems_rl], assumption)
+apply (drule (1) tendsto_Pair) back
+apply (simp add: o_def)
+done
+
+text{* Hence some useful properties follow quite easily. *}
+
+lemma compact_scaling:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" shows "compact ((\<lambda>x. c *\<^sub>R x) ` s)"
+proof-
+ let ?f = "\<lambda>x. scaleR c x"
+ have *:"bounded_linear ?f" by (rule scaleR.bounded_linear_right)
+ show ?thesis using compact_continuous_image[of s ?f] continuous_at_imp_continuous_on[of s ?f]
+ using linear_continuous_at[OF *] assms by auto
+qed
+
+lemma compact_negations:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" shows "compact ((\<lambda>x. -x) ` s)"
+ using compact_scaling [OF assms, of "- 1"] by auto
+
+lemma compact_sums:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "compact s" "compact t" shows "compact {x + y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have *:"{x + y | x y. x \<in> s \<and> y \<in> t} = (\<lambda>z. fst z + snd z) ` (s \<times> t)"
+ apply auto unfolding image_iff apply(rule_tac x="(xa, y)" in bexI) by auto
+ have "continuous_on (s \<times> t) (\<lambda>z. fst z + snd z)"
+ unfolding continuous_on by (rule ballI) (intro tendsto_intros)
+ thus ?thesis unfolding * using compact_continuous_image compact_Times [OF assms] by auto
+qed
+
+lemma compact_differences:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "compact s" "compact t" shows "compact {x - y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have "{x - y | x y. x\<in>s \<and> y \<in> t} = {x + y | x y. x \<in> s \<and> y \<in> (uminus ` t)}"
+ apply auto apply(rule_tac x= xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
+ thus ?thesis using compact_sums[OF assms(1) compact_negations[OF assms(2)]] by auto
+qed
+
+lemma compact_translation:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" shows "compact ((\<lambda>x. a + x) ` s)"
+proof-
+ have "{x + y |x y. x \<in> s \<and> y \<in> {a}} = (\<lambda>x. a + x) ` s" by auto
+ thus ?thesis using compact_sums[OF assms compact_sing[of a]] by auto
+qed
+
+lemma compact_affinity:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" shows "compact ((\<lambda>x. a + c *\<^sub>R x) ` s)"
+proof-
+ have "op + a ` op *\<^sub>R c ` s = (\<lambda>x. a + c *\<^sub>R x) ` s" by auto
+ thus ?thesis using compact_translation[OF compact_scaling[OF assms], of a c] by auto
+qed
+
+text{* Hence we get the following. *}
+
+lemma compact_sup_maxdistance:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" "s \<noteq> {}"
+ shows "\<exists>x\<in>s. \<exists>y\<in>s. \<forall>u\<in>s. \<forall>v\<in>s. norm(u - v) \<le> norm(x - y)"
+proof-
+ have "{x - y | x y . x\<in>s \<and> y\<in>s} \<noteq> {}" using `s \<noteq> {}` by auto
+ then obtain x where x:"x\<in>{x - y |x y. x \<in> s \<and> y \<in> s}" "\<forall>y\<in>{x - y |x y. x \<in> s \<and> y \<in> s}. norm y \<le> norm x"
+ using compact_differences[OF assms(1) assms(1)]
+ using distance_attains_sup[where 'a="'a", unfolded dist_norm, of "{x - y | x y . x\<in>s \<and> y\<in>s}" 0] by(auto simp add: norm_minus_cancel)
+ from x(1) obtain a b where "a\<in>s" "b\<in>s" "x = a - b" by auto
+ thus ?thesis using x(2)[unfolded `x = a - b`] by blast
+qed
+
+text{* We can state this in terms of diameter of a set. *}
+
+definition "diameter s = (if s = {} then 0::real else Sup {norm(x - y) | x y. x \<in> s \<and> y \<in> s})"
+ (* TODO: generalize to class metric_space *)
+
+lemma diameter_bounded:
+ assumes "bounded s"
+ shows "\<forall>x\<in>s. \<forall>y\<in>s. norm(x - y) \<le> diameter s"
+ "\<forall>d>0. d < diameter s --> (\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d)"
+proof-
+ let ?D = "{norm (x - y) |x y. x \<in> s \<and> y \<in> s}"
+ obtain a where a:"\<forall>x\<in>s. norm x \<le> a" using assms[unfolded bounded_iff] by auto
+ { fix x y assume "x \<in> s" "y \<in> s"
+ hence "norm (x - y) \<le> 2 * a" using norm_triangle_ineq[of x "-y", unfolded norm_minus_cancel] a[THEN bspec[where x=x]] a[THEN bspec[where x=y]] by (auto simp add: ring_simps) }
+ note * = this
+ { fix x y assume "x\<in>s" "y\<in>s" hence "s \<noteq> {}" by auto
+ have lub:"isLub UNIV ?D (Sup ?D)" using * Sup[of ?D] using `s\<noteq>{}` unfolding setle_def
+ apply auto (*FIXME: something horrible has happened here!*)
+ apply atomize
+ apply safe
+ apply metis +
+ done
+ have "norm(x - y) \<le> diameter s" unfolding diameter_def using `s\<noteq>{}` *[OF `x\<in>s` `y\<in>s`] `x\<in>s` `y\<in>s` isLubD1[OF lub] unfolding setle_def by auto }
+ moreover
+ { fix d::real assume "d>0" "d < diameter s"
+ hence "s\<noteq>{}" unfolding diameter_def by auto
+ hence lub:"isLub UNIV ?D (Sup ?D)" using * Sup[of ?D] unfolding setle_def
+ apply auto (*FIXME: something horrible has happened here!*)
+ apply atomize
+ apply safe
+ apply metis +
+ done
+ have "\<exists>d' \<in> ?D. d' > d"
+ proof(rule ccontr)
+ assume "\<not> (\<exists>d'\<in>{norm (x - y) |x y. x \<in> s \<and> y \<in> s}. d < d')"
+ hence as:"\<forall>d'\<in>?D. d' \<le> d" apply auto apply(erule_tac x="norm (x - y)" in allE) by auto
+ hence "isUb UNIV ?D d" unfolding isUb_def unfolding setle_def by auto
+ thus False using `d < diameter s` `s\<noteq>{}` isLub_le_isUb[OF lub, of d] unfolding diameter_def by auto
+ qed
+ hence "\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d" by auto }
+ ultimately show "\<forall>x\<in>s. \<forall>y\<in>s. norm(x - y) \<le> diameter s"
+ "\<forall>d>0. d < diameter s --> (\<exists>x\<in>s. \<exists>y\<in>s. norm(x - y) > d)" by auto
+qed
+
+lemma diameter_bounded_bound:
+ "bounded s \<Longrightarrow> x \<in> s \<Longrightarrow> y \<in> s ==> norm(x - y) \<le> diameter s"
+ using diameter_bounded by blast
+
+lemma diameter_compact_attained:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" "s \<noteq> {}"
+ shows "\<exists>x\<in>s. \<exists>y\<in>s. (norm(x - y) = diameter s)"
+proof-
+ have b:"bounded s" using assms(1) by (rule compact_imp_bounded)
+ then obtain x y where xys:"x\<in>s" "y\<in>s" and xy:"\<forall>u\<in>s. \<forall>v\<in>s. norm (u - v) \<le> norm (x - y)" using compact_sup_maxdistance[OF assms] by auto
+ hence "diameter s \<le> norm (x - y)"
+ by (force simp add: diameter_def intro!: Sup_least)
+ thus ?thesis using diameter_bounded(1)[OF b, THEN bspec[where x=x], THEN bspec[where x=y], OF xys] and xys by auto
+qed
+
+text{* Related results with closure as the conclusion. *}
+
+lemma closed_scaling:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "closed s" shows "closed ((\<lambda>x. c *\<^sub>R x) ` s)"
+proof(cases "s={}")
+ case True thus ?thesis by auto
+next
+ case False
+ show ?thesis
+ proof(cases "c=0")
+ have *:"(\<lambda>x. 0) ` s = {0}" using `s\<noteq>{}` by auto
+ case True thus ?thesis apply auto unfolding * using closed_sing by auto
+ next
+ case False
+ { fix x l assume as:"\<forall>n::nat. x n \<in> scaleR c ` s" "(x ---> l) sequentially"
+ { fix n::nat have "scaleR (1 / c) (x n) \<in> s"
+ using as(1)[THEN spec[where x=n]]
+ using `c\<noteq>0` by (auto simp add: vector_smult_assoc)
+ }
+ moreover
+ { fix e::real assume "e>0"
+ hence "0 < e *\<bar>c\<bar>" using `c\<noteq>0` mult_pos_pos[of e "abs c"] by auto
+ then obtain N where "\<forall>n\<ge>N. dist (x n) l < e * \<bar>c\<bar>"
+ using as(2)[unfolded Lim_sequentially, THEN spec[where x="e * abs c"]] by auto
+ hence "\<exists>N. \<forall>n\<ge>N. dist (scaleR (1 / c) (x n)) (scaleR (1 / c) l) < e"
+ unfolding dist_norm unfolding scaleR_right_diff_distrib[THEN sym]
+ using mult_imp_div_pos_less[of "abs c" _ e] `c\<noteq>0` by auto }
+ hence "((\<lambda>n. scaleR (1 / c) (x n)) ---> scaleR (1 / c) l) sequentially" unfolding Lim_sequentially by auto
+ ultimately have "l \<in> scaleR c ` s"
+ using assms[unfolded closed_sequential_limits, THEN spec[where x="\<lambda>n. scaleR (1/c) (x n)"], THEN spec[where x="scaleR (1/c) l"]]
+ unfolding image_iff using `c\<noteq>0` apply(rule_tac x="scaleR (1 / c) l" in bexI) by auto }
+ thus ?thesis unfolding closed_sequential_limits by fast
+ qed
+qed
+
+lemma closed_negations:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "closed s" shows "closed ((\<lambda>x. -x) ` s)"
+ using closed_scaling[OF assms, of "- 1"] by simp
+
+lemma compact_closed_sums:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "compact s" "closed t" shows "closed {x + y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ let ?S = "{x + y |x y. x \<in> s \<and> y \<in> t}"
+ { fix x l assume as:"\<forall>n. x n \<in> ?S" "(x ---> l) sequentially"
+ from as(1) obtain f where f:"\<forall>n. x n = fst (f n) + snd (f n)" "\<forall>n. fst (f n) \<in> s" "\<forall>n. snd (f n) \<in> t"
+ using choice[of "\<lambda>n y. x n = (fst y) + (snd y) \<and> fst y \<in> s \<and> snd y \<in> t"] by auto
+ obtain l' r where "l'\<in>s" and r:"subseq r" and lr:"(((\<lambda>n. fst (f n)) \<circ> r) ---> l') sequentially"
+ using assms(1)[unfolded compact_def, THEN spec[where x="\<lambda> n. fst (f n)"]] using f(2) by auto
+ have "((\<lambda>n. snd (f (r n))) ---> l - l') sequentially"
+ using Lim_sub[OF lim_subseq[OF r as(2)] lr] and f(1) unfolding o_def by auto
+ hence "l - l' \<in> t"
+ using assms(2)[unfolded closed_sequential_limits, THEN spec[where x="\<lambda> n. snd (f (r n))"], THEN spec[where x="l - l'"]]
+ using f(3) by auto
+ hence "l \<in> ?S" using `l' \<in> s` apply auto apply(rule_tac x=l' in exI) apply(rule_tac x="l - l'" in exI) by auto
+ }
+ thus ?thesis unfolding closed_sequential_limits by fast
+qed
+
+lemma closed_compact_sums:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "closed s" "compact t"
+ shows "closed {x + y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have "{x + y |x y. x \<in> t \<and> y \<in> s} = {x + y |x y. x \<in> s \<and> y \<in> t}" apply auto
+ apply(rule_tac x=y in exI) apply auto apply(rule_tac x=y in exI) by auto
+ thus ?thesis using compact_closed_sums[OF assms(2,1)] by simp
+qed
+
+lemma compact_closed_differences:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "compact s" "closed t"
+ shows "closed {x - y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have "{x + y |x y. x \<in> s \<and> y \<in> uminus ` t} = {x - y |x y. x \<in> s \<and> y \<in> t}"
+ apply auto apply(rule_tac x=xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
+ thus ?thesis using compact_closed_sums[OF assms(1) closed_negations[OF assms(2)]] by auto
+qed
+
+lemma closed_compact_differences:
+ fixes s t :: "'a::real_normed_vector set"
+ assumes "closed s" "compact t"
+ shows "closed {x - y | x y. x \<in> s \<and> y \<in> t}"
+proof-
+ have "{x + y |x y. x \<in> s \<and> y \<in> uminus ` t} = {x - y |x y. x \<in> s \<and> y \<in> t}"
+ apply auto apply(rule_tac x=xa in exI) apply auto apply(rule_tac x=xa in exI) by auto
+ thus ?thesis using closed_compact_sums[OF assms(1) compact_negations[OF assms(2)]] by simp
+qed
+
+lemma closed_translation:
+ fixes a :: "'a::real_normed_vector"
+ assumes "closed s" shows "closed ((\<lambda>x. a + x) ` s)"
+proof-
+ have "{a + y |y. y \<in> s} = (op + a ` s)" by auto
+ thus ?thesis using compact_closed_sums[OF compact_sing[of a] assms] by auto
+qed
+
+lemma translation_UNIV:
+ fixes a :: "'a::ab_group_add" shows "range (\<lambda>x. a + x) = UNIV"
+ apply (auto simp add: image_iff) apply(rule_tac x="x - a" in exI) by auto
+
+lemma translation_diff:
+ fixes a :: "'a::ab_group_add"
+ shows "(\<lambda>x. a + x) ` (s - t) = ((\<lambda>x. a + x) ` s) - ((\<lambda>x. a + x) ` t)"
+ by auto
+
+lemma closure_translation:
+ fixes a :: "'a::real_normed_vector"
+ shows "closure ((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (closure s)"
+proof-
+ have *:"op + a ` (UNIV - s) = UNIV - op + a ` s"
+ apply auto unfolding image_iff apply(rule_tac x="x - a" in bexI) by auto
+ show ?thesis unfolding closure_interior translation_diff translation_UNIV
+ using interior_translation[of a "UNIV - s"] unfolding * by auto
+qed
+
+lemma frontier_translation:
+ fixes a :: "'a::real_normed_vector"
+ shows "frontier((\<lambda>x. a + x) ` s) = (\<lambda>x. a + x) ` (frontier s)"
+ unfolding frontier_def translation_diff interior_translation closure_translation by auto
+
+subsection{* Separation between points and sets. *}
+
+lemma separate_point_closed:
+ fixes s :: "'a::heine_borel set"
+ shows "closed s \<Longrightarrow> a \<notin> s ==> (\<exists>d>0. \<forall>x\<in>s. d \<le> dist a x)"
+proof(cases "s = {}")
+ case True
+ thus ?thesis by(auto intro!: exI[where x=1])
+next
+ case False
+ assume "closed s" "a \<notin> s"
+ then obtain x where "x\<in>s" "\<forall>y\<in>s. dist a x \<le> dist a y" using `s \<noteq> {}` distance_attains_inf [of s a] by blast
+ with `x\<in>s` show ?thesis using dist_pos_lt[of a x] and`a \<notin> s` by blast
+qed
+
+lemma separate_compact_closed:
+ fixes s t :: "'a::{heine_borel, real_normed_vector} set"
+ (* TODO: does this generalize to heine_borel? *)
+ assumes "compact s" and "closed t" and "s \<inter> t = {}"
+ shows "\<exists>d>0. \<forall>x\<in>s. \<forall>y\<in>t. d \<le> dist x y"
+proof-
+ have "0 \<notin> {x - y |x y. x \<in> s \<and> y \<in> t}" using assms(3) by auto
+ then obtain d where "d>0" and d:"\<forall>x\<in>{x - y |x y. x \<in> s \<and> y \<in> t}. d \<le> dist 0 x"
+ using separate_point_closed[OF compact_closed_differences[OF assms(1,2)], of 0] by auto
+ { fix x y assume "x\<in>s" "y\<in>t"
+ hence "x - y \<in> {x - y |x y. x \<in> s \<and> y \<in> t}" by auto
+ hence "d \<le> dist (x - y) 0" using d[THEN bspec[where x="x - y"]] using dist_commute
+ by (auto simp add: dist_commute)
+ hence "d \<le> dist x y" unfolding dist_norm by auto }
+ thus ?thesis using `d>0` by auto
+qed
+
+lemma separate_closed_compact:
+ fixes s t :: "'a::{heine_borel, real_normed_vector} set"
+ assumes "closed s" and "compact t" and "s \<inter> t = {}"
+ shows "\<exists>d>0. \<forall>x\<in>s. \<forall>y\<in>t. d \<le> dist x y"
+proof-
+ have *:"t \<inter> s = {}" using assms(3) by auto
+ show ?thesis using separate_compact_closed[OF assms(2,1) *]
+ apply auto apply(rule_tac x=d in exI) apply auto apply (erule_tac x=y in ballE)
+ by (auto simp add: dist_commute)
+qed
+
+(* A cute way of denoting open and closed intervals using overloading. *)
+
+lemma interval: fixes a :: "'a::ord^'n::finite" shows
+ "{a <..< b} = {x::'a^'n. \<forall>i. a$i < x$i \<and> x$i < b$i}" and
+ "{a .. b} = {x::'a^'n. \<forall>i. a$i \<le> x$i \<and> x$i \<le> b$i}"
+ by (auto simp add: expand_set_eq vector_less_def vector_less_eq_def)
+
+lemma mem_interval: fixes a :: "'a::ord^'n::finite" shows
+ "x \<in> {a<..<b} \<longleftrightarrow> (\<forall>i. a$i < x$i \<and> x$i < b$i)"
+ "x \<in> {a .. b} \<longleftrightarrow> (\<forall>i. a$i \<le> x$i \<and> x$i \<le> b$i)"
+ using interval[of a b] by(auto simp add: expand_set_eq vector_less_def vector_less_eq_def)
+
+lemma mem_interval_1: fixes x :: "real^1" shows
+ "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b)"
+ "(x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
+by(simp_all add: Cart_eq vector_less_def vector_less_eq_def dest_vec1_def forall_1)
+
+lemma interval_eq_empty: fixes a :: "real^'n::finite" shows
+ "({a <..< b} = {} \<longleftrightarrow> (\<exists>i. b$i \<le> a$i))" (is ?th1) and
+ "({a .. b} = {} \<longleftrightarrow> (\<exists>i. b$i < a$i))" (is ?th2)
+proof-
+ { fix i x assume as:"b$i \<le> a$i" and x:"x\<in>{a <..< b}"
+ hence "a $ i < x $ i \<and> x $ i < b $ i" unfolding mem_interval by auto
+ hence "a$i < b$i" by auto
+ hence False using as by auto }
+ moreover
+ { assume as:"\<forall>i. \<not> (b$i \<le> a$i)"
+ let ?x = "(1/2) *\<^sub>R (a + b)"
+ { fix i
+ have "a$i < b$i" using as[THEN spec[where x=i]] by auto
+ hence "a$i < ((1/2) *\<^sub>R (a+b)) $ i" "((1/2) *\<^sub>R (a+b)) $ i < b$i"
+ unfolding vector_smult_component and vector_add_component
+ by (auto simp add: less_divide_eq_number_of1) }
+ hence "{a <..< b} \<noteq> {}" using mem_interval(1)[of "?x" a b] by auto }
+ ultimately show ?th1 by blast
+
+ { fix i x assume as:"b$i < a$i" and x:"x\<in>{a .. b}"
+ hence "a $ i \<le> x $ i \<and> x $ i \<le> b $ i" unfolding mem_interval by auto
+ hence "a$i \<le> b$i" by auto
+ hence False using as by auto }
+ moreover
+ { assume as:"\<forall>i. \<not> (b$i < a$i)"
+ let ?x = "(1/2) *\<^sub>R (a + b)"
+ { fix i
+ have "a$i \<le> b$i" using as[THEN spec[where x=i]] by auto
+ hence "a$i \<le> ((1/2) *\<^sub>R (a+b)) $ i" "((1/2) *\<^sub>R (a+b)) $ i \<le> b$i"
+ unfolding vector_smult_component and vector_add_component
+ by (auto simp add: less_divide_eq_number_of1) }
+ hence "{a .. b} \<noteq> {}" using mem_interval(2)[of "?x" a b] by auto }
+ ultimately show ?th2 by blast
+qed
+
+lemma interval_ne_empty: fixes a :: "real^'n::finite" shows
+ "{a .. b} \<noteq> {} \<longleftrightarrow> (\<forall>i. a$i \<le> b$i)" and
+ "{a <..< b} \<noteq> {} \<longleftrightarrow> (\<forall>i. a$i < b$i)"
+ unfolding interval_eq_empty[of a b] by (auto simp add: not_less not_le) (* BH: Why doesn't just "auto" work here? *)
+
+lemma subset_interval_imp: fixes a :: "real^'n::finite" shows
+ "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c .. d} \<subseteq> {a .. b}" and
+ "(\<forall>i. a$i < c$i \<and> d$i < b$i) \<Longrightarrow> {c .. d} \<subseteq> {a<..<b}" and
+ "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c<..<d} \<subseteq> {a .. b}" and
+ "(\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i) \<Longrightarrow> {c<..<d} \<subseteq> {a<..<b}"
+ unfolding subset_eq[unfolded Ball_def] unfolding mem_interval
+ by (auto intro: order_trans less_le_trans le_less_trans less_imp_le) (* BH: Why doesn't just "auto" work here? *)
+
+lemma interval_sing: fixes a :: "'a::linorder^'n::finite" shows
+ "{a .. a} = {a} \<and> {a<..<a} = {}"
+apply(auto simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
+apply (simp add: order_eq_iff)
+apply (auto simp add: not_less less_imp_le)
+done
+
+lemma interval_open_subset_closed: fixes a :: "'a::preorder^'n::finite" shows
+ "{a<..<b} \<subseteq> {a .. b}"
+proof(simp add: subset_eq, rule)
+ fix x
+ assume x:"x \<in>{a<..<b}"
+ { fix i
+ have "a $ i \<le> x $ i"
+ using x order_less_imp_le[of "a$i" "x$i"]
+ by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
+ }
+ moreover
+ { fix i
+ have "x $ i \<le> b $ i"
+ using x order_less_imp_le[of "x$i" "b$i"]
+ by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
+ }
+ ultimately
+ show "a \<le> x \<and> x \<le> b"
+ by(simp add: expand_set_eq vector_less_def vector_less_eq_def Cart_eq)
+qed
+
+lemma subset_interval: fixes a :: "real^'n::finite" shows
+ "{c .. d} \<subseteq> {a .. b} \<longleftrightarrow> (\<forall>i. c$i \<le> d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th1) and
+ "{c .. d} \<subseteq> {a<..<b} \<longleftrightarrow> (\<forall>i. c$i \<le> d$i) --> (\<forall>i. a$i < c$i \<and> d$i < b$i)" (is ?th2) and
+ "{c<..<d} \<subseteq> {a .. b} \<longleftrightarrow> (\<forall>i. c$i < d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th3) and
+ "{c<..<d} \<subseteq> {a<..<b} \<longleftrightarrow> (\<forall>i. c$i < d$i) --> (\<forall>i. a$i \<le> c$i \<and> d$i \<le> b$i)" (is ?th4)
+proof-
+ show ?th1 unfolding subset_eq and Ball_def and mem_interval by (auto intro: order_trans)
+ show ?th2 unfolding subset_eq and Ball_def and mem_interval by (auto intro: le_less_trans less_le_trans order_trans less_imp_le)
+ { assume as: "{c<..<d} \<subseteq> {a .. b}" "\<forall>i. c$i < d$i"
+ hence "{c<..<d} \<noteq> {}" unfolding interval_eq_empty by (auto, drule_tac x=i in spec, simp) (* BH: Why doesn't just "auto" work? *)
+ fix i
+ (** TODO combine the following two parts as done in the HOL_light version. **)
+ { let ?x = "(\<chi> j. (if j=i then ((min (a$j) (d$j))+c$j)/2 else (c$j+d$j)/2))::real^'n"
+ assume as2: "a$i > c$i"
+ { fix j
+ have "c $ j < ?x $ j \<and> ?x $ j < d $ j" unfolding Cart_lambda_beta
+ apply(cases "j=i") using as(2)[THEN spec[where x=j]]
+ by (auto simp add: less_divide_eq_number_of1 as2) }
+ hence "?x\<in>{c<..<d}" unfolding mem_interval by auto
+ moreover
+ have "?x\<notin>{a .. b}"
+ unfolding mem_interval apply auto apply(rule_tac x=i in exI)
+ using as(2)[THEN spec[where x=i]] and as2
+ by (auto simp add: less_divide_eq_number_of1)
+ ultimately have False using as by auto }
+ hence "a$i \<le> c$i" by(rule ccontr)auto
+ moreover
+ { let ?x = "(\<chi> j. (if j=i then ((max (b$j) (c$j))+d$j)/2 else (c$j+d$j)/2))::real^'n"
+ assume as2: "b$i < d$i"
+ { fix j
+ have "d $ j > ?x $ j \<and> ?x $ j > c $ j" unfolding Cart_lambda_beta
+ apply(cases "j=i") using as(2)[THEN spec[where x=j]]
+ by (auto simp add: less_divide_eq_number_of1 as2) }
+ hence "?x\<in>{c<..<d}" unfolding mem_interval by auto
+ moreover
+ have "?x\<notin>{a .. b}"
+ unfolding mem_interval apply auto apply(rule_tac x=i in exI)
+ using as(2)[THEN spec[where x=i]] and as2
+ by (auto simp add: less_divide_eq_number_of1)
+ ultimately have False using as by auto }
+ hence "b$i \<ge> d$i" by(rule ccontr)auto
+ ultimately
+ have "a$i \<le> c$i \<and> d$i \<le> b$i" by auto
+ } note part1 = this
+ thus ?th3 unfolding subset_eq and Ball_def and mem_interval apply auto apply (erule_tac x=ia in allE, simp)+ by (erule_tac x=i in allE, erule_tac x=i in allE, simp)+
+ { assume as:"{c<..<d} \<subseteq> {a<..<b}" "\<forall>i. c$i < d$i"
+ fix i
+ from as(1) have "{c<..<d} \<subseteq> {a..b}" using interval_open_subset_closed[of a b] by auto
+ hence "a$i \<le> c$i \<and> d$i \<le> b$i" using part1 and as(2) by auto } note * = this
+ thus ?th4 unfolding subset_eq and Ball_def and mem_interval apply auto apply (erule_tac x=ia in allE, simp)+ by (erule_tac x=i in allE, erule_tac x=i in allE, simp)+
+qed
+
+lemma disjoint_interval: fixes a::"real^'n::finite" shows
+ "{a .. b} \<inter> {c .. d} = {} \<longleftrightarrow> (\<exists>i. (b$i < a$i \<or> d$i < c$i \<or> b$i < c$i \<or> d$i < a$i))" (is ?th1) and
+ "{a .. b} \<inter> {c<..<d} = {} \<longleftrightarrow> (\<exists>i. (b$i < a$i \<or> d$i \<le> c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th2) and
+ "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> (\<exists>i. (b$i \<le> a$i \<or> d$i < c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th3) and
+ "{a<..<b} \<inter> {c<..<d} = {} \<longleftrightarrow> (\<exists>i. (b$i \<le> a$i \<or> d$i \<le> c$i \<or> b$i \<le> c$i \<or> d$i \<le> a$i))" (is ?th4)
+proof-
+ let ?z = "(\<chi> i. ((max (a$i) (c$i)) + (min (b$i) (d$i))) / 2)::real^'n"
+ show ?th1 ?th2 ?th3 ?th4
+ unfolding expand_set_eq and Int_iff and empty_iff and mem_interval and all_conj_distrib[THEN sym] and eq_False
+ apply (auto elim!: allE[where x="?z"])
+ apply ((rule_tac x=x in exI, force) | (rule_tac x=i in exI, force))+
+ done
+qed
+
+lemma inter_interval: fixes a :: "'a::linorder^'n::finite" shows
+ "{a .. b} \<inter> {c .. d} = {(\<chi> i. max (a$i) (c$i)) .. (\<chi> i. min (b$i) (d$i))}"
+ unfolding expand_set_eq and Int_iff and mem_interval
+ by (auto simp add: less_divide_eq_number_of1 intro!: bexI)
+
+(* Moved interval_open_subset_closed a bit upwards *)
+
+lemma open_interval_lemma: fixes x :: "real" shows
+ "a < x \<Longrightarrow> x < b ==> (\<exists>d>0. \<forall>x'. abs(x' - x) < d --> a < x' \<and> x' < b)"
+ by(rule_tac x="min (x - a) (b - x)" in exI, auto)
+
+lemma open_interval: fixes a :: "real^'n::finite" shows "open {a<..<b}"
+proof-
+ { fix x assume x:"x\<in>{a<..<b}"
+ { fix i
+ have "\<exists>d>0. \<forall>x'. abs (x' - (x$i)) < d \<longrightarrow> a$i < x' \<and> x' < b$i"
+ using x[unfolded mem_interval, THEN spec[where x=i]]
+ using open_interval_lemma[of "a$i" "x$i" "b$i"] by auto }
+
+ hence "\<forall>i. \<exists>d>0. \<forall>x'. abs (x' - (x$i)) < d \<longrightarrow> a$i < x' \<and> x' < b$i" by auto
+ then obtain d where d:"\<forall>i. 0 < d i \<and> (\<forall>x'. \<bar>x' - x $ i\<bar> < d i \<longrightarrow> a $ i < x' \<and> x' < b $ i)"
+ using bchoice[of "UNIV" "\<lambda>i d. d>0 \<and> (\<forall>x'. \<bar>x' - x $ i\<bar> < d \<longrightarrow> a $ i < x' \<and> x' < b $ i)"] by auto
+
+ let ?d = "Min (range d)"
+ have **:"finite (range d)" "range d \<noteq> {}" by auto
+ have "?d>0" unfolding Min_gr_iff[OF **] using d by auto
+ moreover
+ { fix x' assume as:"dist x' x < ?d"
+ { fix i
+ have "\<bar>x'$i - x $ i\<bar> < d i"
+ using norm_bound_component_lt[OF as[unfolded dist_norm], of i]
+ unfolding vector_minus_component and Min_gr_iff[OF **] by auto
+ hence "a $ i < x' $ i" "x' $ i < b $ i" using d[THEN spec[where x=i]] by auto }
+ hence "a < x' \<and> x' < b" unfolding vector_less_def by auto }
+ ultimately have "\<exists>e>0. \<forall>x'. dist x' x < e \<longrightarrow> x' \<in> {a<..<b}" by (auto, rule_tac x="?d" in exI, simp)
+ }
+ thus ?thesis unfolding open_dist using open_interval_lemma by auto
+qed
+
+lemma closed_interval: fixes a :: "real^'n::finite" shows "closed {a .. b}"
+proof-
+ { fix x i assume as:"\<forall>e>0. \<exists>x'\<in>{a..b}. x' \<noteq> x \<and> dist x' x < e"(* and xab:"a$i > x$i \<or> b$i < x$i"*)
+ { assume xa:"a$i > x$i"
+ with as obtain y where y:"y\<in>{a..b}" "y \<noteq> x" "dist y x < a$i - x$i" by(erule_tac x="a$i - x$i" in allE)auto
+ hence False unfolding mem_interval and dist_norm
+ using component_le_norm[of "y-x" i, unfolded vector_minus_component] and xa by(auto elim!: allE[where x=i])
+ } hence "a$i \<le> x$i" by(rule ccontr)auto
+ moreover
+ { assume xb:"b$i < x$i"
+ with as obtain y where y:"y\<in>{a..b}" "y \<noteq> x" "dist y x < x$i - b$i" by(erule_tac x="x$i - b$i" in allE)auto
+ hence False unfolding mem_interval and dist_norm
+ using component_le_norm[of "y-x" i, unfolded vector_minus_component] and xb by(auto elim!: allE[where x=i])
+ } hence "x$i \<le> b$i" by(rule ccontr)auto
+ ultimately
+ have "a $ i \<le> x $ i \<and> x $ i \<le> b $ i" by auto }
+ thus ?thesis unfolding closed_limpt islimpt_approachable mem_interval by auto
+qed
+
+lemma interior_closed_interval: fixes a :: "real^'n::finite" shows
+ "interior {a .. b} = {a<..<b}" (is "?L = ?R")
+proof(rule subset_antisym)
+ show "?R \<subseteq> ?L" using interior_maximal[OF interval_open_subset_closed open_interval] by auto
+next
+ { fix x assume "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> {a..b}"
+ then obtain s where s:"open s" "x \<in> s" "s \<subseteq> {a..b}" by auto
+ then obtain e where "e>0" and e:"\<forall>x'. dist x' x < e \<longrightarrow> x' \<in> {a..b}" unfolding open_dist and subset_eq by auto
+ { fix i
+ have "dist (x - (e / 2) *\<^sub>R basis i) x < e"
+ "dist (x + (e / 2) *\<^sub>R basis i) x < e"
+ unfolding dist_norm apply auto
+ unfolding norm_minus_cancel using norm_basis[of i] and `e>0` by auto
+ hence "a $ i \<le> (x - (e / 2) *\<^sub>R basis i) $ i"
+ "(x + (e / 2) *\<^sub>R basis i) $ i \<le> b $ i"
+ using e[THEN spec[where x="x - (e/2) *\<^sub>R basis i"]]
+ and e[THEN spec[where x="x + (e/2) *\<^sub>R basis i"]]
+ unfolding mem_interval by (auto elim!: allE[where x=i])
+ hence "a $ i < x $ i" and "x $ i < b $ i"
+ unfolding vector_minus_component and vector_add_component
+ unfolding vector_smult_component and basis_component using `e>0` by auto }
+ hence "x \<in> {a<..<b}" unfolding mem_interval by auto }
+ thus "?L \<subseteq> ?R" unfolding interior_def and subset_eq by auto
+qed
+
+lemma bounded_closed_interval: fixes a :: "real^'n::finite" shows
+ "bounded {a .. b}"
+proof-
+ let ?b = "\<Sum>i\<in>UNIV. \<bar>a$i\<bar> + \<bar>b$i\<bar>"
+ { fix x::"real^'n" assume x:"\<forall>i. a $ i \<le> x $ i \<and> x $ i \<le> b $ i"
+ { fix i
+ have "\<bar>x$i\<bar> \<le> \<bar>a$i\<bar> + \<bar>b$i\<bar>" using x[THEN spec[where x=i]] by auto }
+ hence "(\<Sum>i\<in>UNIV. \<bar>x $ i\<bar>) \<le> ?b" by(rule setsum_mono)
+ hence "norm x \<le> ?b" using norm_le_l1[of x] by auto }
+ thus ?thesis unfolding interval and bounded_iff by auto
+qed
+
+lemma bounded_interval: fixes a :: "real^'n::finite" shows
+ "bounded {a .. b} \<and> bounded {a<..<b}"
+ using bounded_closed_interval[of a b]
+ using interval_open_subset_closed[of a b]
+ using bounded_subset[of "{a..b}" "{a<..<b}"]
+ by simp
+
+lemma not_interval_univ: fixes a :: "real^'n::finite" shows
+ "({a .. b} \<noteq> UNIV) \<and> ({a<..<b} \<noteq> UNIV)"
+ using bounded_interval[of a b]
+ by auto
+
+lemma compact_interval: fixes a :: "real^'n::finite" shows
+ "compact {a .. b}"
+ using bounded_closed_imp_compact using bounded_interval[of a b] using closed_interval[of a b] by auto
+
+lemma open_interval_midpoint: fixes a :: "real^'n::finite"
+ assumes "{a<..<b} \<noteq> {}" shows "((1/2) *\<^sub>R (a + b)) \<in> {a<..<b}"
+proof-
+ { fix i
+ have "a $ i < ((1 / 2) *\<^sub>R (a + b)) $ i \<and> ((1 / 2) *\<^sub>R (a + b)) $ i < b $ i"
+ using assms[unfolded interval_ne_empty, THEN spec[where x=i]]
+ unfolding vector_smult_component and vector_add_component
+ by(auto simp add: less_divide_eq_number_of1) }
+ thus ?thesis unfolding mem_interval by auto
+qed
+
+lemma open_closed_interval_convex: fixes x :: "real^'n::finite"
+ assumes x:"x \<in> {a<..<b}" and y:"y \<in> {a .. b}" and e:"0 < e" "e \<le> 1"
+ shows "(e *\<^sub>R x + (1 - e) *\<^sub>R y) \<in> {a<..<b}"
+proof-
+ { fix i
+ have "a $ i = e * a$i + (1 - e) * a$i" unfolding left_diff_distrib by simp
+ also have "\<dots> < e * x $ i + (1 - e) * y $ i" apply(rule add_less_le_mono)
+ using e unfolding mult_less_cancel_left and mult_le_cancel_left apply simp_all
+ using x unfolding mem_interval apply simp
+ using y unfolding mem_interval apply simp
+ done
+ finally have "a $ i < (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i" by auto
+ moreover {
+ have "b $ i = e * b$i + (1 - e) * b$i" unfolding left_diff_distrib by simp
+ also have "\<dots> > e * x $ i + (1 - e) * y $ i" apply(rule add_less_le_mono)
+ using e unfolding mult_less_cancel_left and mult_le_cancel_left apply simp_all
+ using x unfolding mem_interval apply simp
+ using y unfolding mem_interval apply simp
+ done
+ finally have "(e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i < b $ i" by auto
+ } ultimately have "a $ i < (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i \<and> (e *\<^sub>R x + (1 - e) *\<^sub>R y) $ i < b $ i" by auto }
+ thus ?thesis unfolding mem_interval by auto
+qed
+
+lemma closure_open_interval: fixes a :: "real^'n::finite"
+ assumes "{a<..<b} \<noteq> {}"
+ shows "closure {a<..<b} = {a .. b}"
+proof-
+ have ab:"a < b" using assms[unfolded interval_ne_empty] unfolding vector_less_def by auto
+ let ?c = "(1 / 2) *\<^sub>R (a + b)"
+ { fix x assume as:"x \<in> {a .. b}"
+ def f == "\<lambda>n::nat. x + (inverse (real n + 1)) *\<^sub>R (?c - x)"
+ { fix n assume fn:"f n < b \<longrightarrow> a < f n \<longrightarrow> f n = x" and xc:"x \<noteq> ?c"
+ have *:"0 < inverse (real n + 1)" "inverse (real n + 1) \<le> 1" unfolding inverse_le_1_iff by auto
+ have "(inverse (real n + 1)) *\<^sub>R ((1 / 2) *\<^sub>R (a + b)) + (1 - inverse (real n + 1)) *\<^sub>R x =
+ x + (inverse (real n + 1)) *\<^sub>R (((1 / 2) *\<^sub>R (a + b)) - x)"
+ by (auto simp add: algebra_simps)
+ hence "f n < b" and "a < f n" using open_closed_interval_convex[OF open_interval_midpoint[OF assms] as *] unfolding f_def by auto
+ hence False using fn unfolding f_def using xc by(auto simp add: vector_mul_lcancel vector_ssub_ldistrib) }
+ moreover
+ { assume "\<not> (f ---> x) sequentially"
+ { fix e::real assume "e>0"
+ hence "\<exists>N::nat. inverse (real (N + 1)) < e" using real_arch_inv[of e] apply (auto simp add: Suc_pred') apply(rule_tac x="n - 1" in exI) by auto
+ then obtain N::nat where "inverse (real (N + 1)) < e" by auto
+ hence "\<forall>n\<ge>N. inverse (real n + 1) < e" by (auto, metis Suc_le_mono le_SucE less_imp_inverse_less nat_le_real_less order_less_trans real_of_nat_Suc real_of_nat_Suc_gt_zero)
+ hence "\<exists>N::nat. \<forall>n\<ge>N. inverse (real n + 1) < e" by auto }
+ hence "((\<lambda>n. inverse (real n + 1)) ---> 0) sequentially"
+ unfolding Lim_sequentially by(auto simp add: dist_norm)
+ hence "(f ---> x) sequentially" unfolding f_def
+ using Lim_add[OF Lim_const, of "\<lambda>n::nat. (inverse (real n + 1)) *\<^sub>R ((1 / 2) *\<^sub>R (a + b) - x)" 0 sequentially x]
+ using Lim_vmul[of "\<lambda>n::nat. inverse (real n + 1)" 0 sequentially "((1 / 2) *\<^sub>R (a + b) - x)"] by auto }
+ ultimately have "x \<in> closure {a<..<b}"
+ using as and open_interval_midpoint[OF assms] unfolding closure_def unfolding islimpt_sequential by(cases "x=?c")auto }
+ thus ?thesis using closure_minimal[OF interval_open_subset_closed closed_interval, of a b] by blast
+qed
+
+lemma bounded_subset_open_interval_symmetric: fixes s::"(real^'n::finite) set"
+ assumes "bounded s" shows "\<exists>a. s \<subseteq> {-a<..<a}"
+proof-
+ obtain b where "b>0" and b:"\<forall>x\<in>s. norm x \<le> b" using assms[unfolded bounded_pos] by auto
+ def a \<equiv> "(\<chi> i. b+1)::real^'n"
+ { fix x assume "x\<in>s"
+ fix i
+ have "(-a)$i < x$i" and "x$i < a$i" using b[THEN bspec[where x=x], OF `x\<in>s`] and component_le_norm[of x i]
+ unfolding vector_uminus_component and a_def and Cart_lambda_beta by auto
+ }
+ thus ?thesis by(auto intro: exI[where x=a] simp add: vector_less_def)
+qed
+
+lemma bounded_subset_open_interval:
+ fixes s :: "(real ^ 'n::finite) set"
+ shows "bounded s ==> (\<exists>a b. s \<subseteq> {a<..<b})"
+ by (auto dest!: bounded_subset_open_interval_symmetric)
+
+lemma bounded_subset_closed_interval_symmetric:
+ fixes s :: "(real ^ 'n::finite) set"
+ assumes "bounded s" shows "\<exists>a. s \<subseteq> {-a .. a}"
+proof-
+ obtain a where "s \<subseteq> {- a<..<a}" using bounded_subset_open_interval_symmetric[OF assms] by auto
+ thus ?thesis using interval_open_subset_closed[of "-a" a] by auto
+qed
+
+lemma bounded_subset_closed_interval:
+ fixes s :: "(real ^ 'n::finite) set"
+ shows "bounded s ==> (\<exists>a b. s \<subseteq> {a .. b})"
+ using bounded_subset_closed_interval_symmetric[of s] by auto
+
+lemma frontier_closed_interval:
+ fixes a b :: "real ^ _"
+ shows "frontier {a .. b} = {a .. b} - {a<..<b}"
+ unfolding frontier_def unfolding interior_closed_interval and closure_closed[OF closed_interval] ..
+
+lemma frontier_open_interval:
+ fixes a b :: "real ^ _"
+ shows "frontier {a<..<b} = (if {a<..<b} = {} then {} else {a .. b} - {a<..<b})"
+proof(cases "{a<..<b} = {}")
+ case True thus ?thesis using frontier_empty by auto
+next
+ case False thus ?thesis unfolding frontier_def and closure_open_interval[OF False] and interior_open[OF open_interval] by auto
+qed
+
+lemma inter_interval_mixed_eq_empty: fixes a :: "real^'n::finite"
+ assumes "{c<..<d} \<noteq> {}" shows "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> {a<..<b} \<inter> {c<..<d} = {}"
+ unfolding closure_open_interval[OF assms, THEN sym] unfolding open_inter_closure_eq_empty[OF open_interval] ..
+
+
+(* Some special cases for intervals in R^1. *)
+
+lemma all_1: "(\<forall>x::1. P x) \<longleftrightarrow> P 1"
+ by (metis num1_eq_iff)
+
+lemma ex_1: "(\<exists>x::1. P x) \<longleftrightarrow> P 1"
+ by auto (metis num1_eq_iff)
+
+lemma interval_cases_1: fixes x :: "real^1" shows
+ "x \<in> {a .. b} ==> x \<in> {a<..<b} \<or> (x = a) \<or> (x = b)"
+ by(simp add: Cart_eq vector_less_def vector_less_eq_def all_1, auto)
+
+lemma in_interval_1: fixes x :: "real^1" shows
+ "(x \<in> {a .. b} \<longleftrightarrow> dest_vec1 a \<le> dest_vec1 x \<and> dest_vec1 x \<le> dest_vec1 b) \<and>
+ (x \<in> {a<..<b} \<longleftrightarrow> dest_vec1 a < dest_vec1 x \<and> dest_vec1 x < dest_vec1 b)"
+by(simp add: Cart_eq vector_less_def vector_less_eq_def all_1 dest_vec1_def)
+
+lemma interval_eq_empty_1: fixes a :: "real^1" shows
+ "{a .. b} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a"
+ "{a<..<b} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a"
+ unfolding interval_eq_empty and ex_1 and dest_vec1_def by auto
+
+lemma subset_interval_1: fixes a :: "real^1" shows
+ "({a .. b} \<subseteq> {c .. d} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or>
+ dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a \<le> dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
+ "({a .. b} \<subseteq> {c<..<d} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or>
+ dest_vec1 c < dest_vec1 a \<and> dest_vec1 a \<le> dest_vec1 b \<and> dest_vec1 b < dest_vec1 d)"
+ "({a<..<b} \<subseteq> {c .. d} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or>
+ dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a < dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
+ "({a<..<b} \<subseteq> {c<..<d} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or>
+ dest_vec1 c \<le> dest_vec1 a \<and> dest_vec1 a < dest_vec1 b \<and> dest_vec1 b \<le> dest_vec1 d)"
+ unfolding subset_interval[of a b c d] unfolding all_1 and dest_vec1_def by auto
+
+lemma eq_interval_1: fixes a :: "real^1" shows
+ "{a .. b} = {c .. d} \<longleftrightarrow>
+ dest_vec1 b < dest_vec1 a \<and> dest_vec1 d < dest_vec1 c \<or>
+ dest_vec1 a = dest_vec1 c \<and> dest_vec1 b = dest_vec1 d"
+using set_eq_subset[of "{a .. b}" "{c .. d}"]
+using subset_interval_1(1)[of a b c d]
+using subset_interval_1(1)[of c d a b]
+by auto (* FIXME: slow *)
+
+lemma disjoint_interval_1: fixes a :: "real^1" shows
+ "{a .. b} \<inter> {c .. d} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or> dest_vec1 d < dest_vec1 c \<or> dest_vec1 b < dest_vec1 c \<or> dest_vec1 d < dest_vec1 a"
+ "{a .. b} \<inter> {c<..<d} = {} \<longleftrightarrow> dest_vec1 b < dest_vec1 a \<or> dest_vec1 d \<le> dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
+ "{a<..<b} \<inter> {c .. d} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or> dest_vec1 d < dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
+ "{a<..<b} \<inter> {c<..<d} = {} \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a \<or> dest_vec1 d \<le> dest_vec1 c \<or> dest_vec1 b \<le> dest_vec1 c \<or> dest_vec1 d \<le> dest_vec1 a"
+ unfolding disjoint_interval and dest_vec1_def ex_1 by auto
+
+lemma open_closed_interval_1: fixes a :: "real^1" shows
+ "{a<..<b} = {a .. b} - {a, b}"
+ unfolding expand_set_eq apply simp unfolding vector_less_def and vector_less_eq_def and all_1 and dest_vec1_eq[THEN sym] and dest_vec1_def by auto
+
+lemma closed_open_interval_1: "dest_vec1 (a::real^1) \<le> dest_vec1 b ==> {a .. b} = {a<..<b} \<union> {a,b}"
+ unfolding expand_set_eq apply simp unfolding vector_less_def and vector_less_eq_def and all_1 and dest_vec1_eq[THEN sym] and dest_vec1_def by auto
+
+(* Some stuff for half-infinite intervals too; FIXME: notation? *)
+
+lemma closed_interval_left: fixes b::"real^'n::finite"
+ shows "closed {x::real^'n. \<forall>i. x$i \<le> b$i}"
+proof-
+ { fix i
+ fix x::"real^'n" assume x:"\<forall>e>0. \<exists>x'\<in>{x. \<forall>i. x $ i \<le> b $ i}. x' \<noteq> x \<and> dist x' x < e"
+ { assume "x$i > b$i"
+ then obtain y where "y $ i \<le> b $ i" "y \<noteq> x" "dist y x < x$i - b$i" using x[THEN spec[where x="x$i - b$i"]] by auto
+ hence False using component_le_norm[of "y - x" i] unfolding dist_norm and vector_minus_component by auto }
+ hence "x$i \<le> b$i" by(rule ccontr)auto }
+ thus ?thesis unfolding closed_limpt unfolding islimpt_approachable by blast
+qed
+
+lemma closed_interval_right: fixes a::"real^'n::finite"
+ shows "closed {x::real^'n. \<forall>i. a$i \<le> x$i}"
+proof-
+ { fix i
+ fix x::"real^'n" assume x:"\<forall>e>0. \<exists>x'\<in>{x. \<forall>i. a $ i \<le> x $ i}. x' \<noteq> x \<and> dist x' x < e"
+ { assume "a$i > x$i"
+ then obtain y where "a $ i \<le> y $ i" "y \<noteq> x" "dist y x < a$i - x$i" using x[THEN spec[where x="a$i - x$i"]] by auto
+ hence False using component_le_norm[of "y - x" i] unfolding dist_norm and vector_minus_component by auto }
+ hence "a$i \<le> x$i" by(rule ccontr)auto }
+ thus ?thesis unfolding closed_limpt unfolding islimpt_approachable by blast
+qed
+
+subsection{* Intervals in general, including infinite and mixtures of open and closed. *}
+
+definition "is_interval s \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. \<forall>x. (\<forall>i. ((a$i \<le> x$i \<and> x$i \<le> b$i) \<or> (b$i \<le> x$i \<and> x$i \<le> a$i))) \<longrightarrow> x \<in> s)"
+
+lemma is_interval_interval: "is_interval {a .. b::real^'n::finite}" (is ?th1) "is_interval {a<..<b}" (is ?th2) proof -
+ have *:"\<And>x y z::real. x < y \<Longrightarrow> y < z \<Longrightarrow> x < z" by auto
+ show ?th1 ?th2 unfolding is_interval_def mem_interval Ball_def atLeastAtMost_iff
+ by(meson real_le_trans le_less_trans less_le_trans *)+ qed
+
+lemma is_interval_empty:
+ "is_interval {}"
+ unfolding is_interval_def
+ by simp
+
+lemma is_interval_univ:
+ "is_interval UNIV"
+ unfolding is_interval_def
+ by simp
+
+subsection{* Closure of halfspaces and hyperplanes. *}
+
+lemma Lim_inner:
+ assumes "(f ---> l) net" shows "((\<lambda>y. inner a (f y)) ---> inner a l) net"
+ by (intro tendsto_intros assms)
+
+lemma continuous_at_inner: "continuous (at x) (inner a)"
+ unfolding continuous_at by (intro tendsto_intros)
+
+lemma continuous_on_inner:
+ fixes s :: "'a::real_inner set"
+ shows "continuous_on s (inner a)"
+ unfolding continuous_on by (rule ballI) (intro tendsto_intros)
+
+lemma closed_halfspace_le: "closed {x. inner a x \<le> b}"
+proof-
+ have "\<forall>x. continuous (at x) (inner a)"
+ unfolding continuous_at by (rule allI) (intro tendsto_intros)
+ hence "closed (inner a -` {..b})"
+ using closed_real_atMost by (rule continuous_closed_vimage)
+ moreover have "{x. inner a x \<le> b} = inner a -` {..b}" by auto
+ ultimately show ?thesis by simp
+qed
+
+lemma closed_halfspace_ge: "closed {x. inner a x \<ge> b}"
+ using closed_halfspace_le[of "-a" "-b"] unfolding inner_minus_left by auto
+
+lemma closed_hyperplane: "closed {x. inner a x = b}"
+proof-
+ have "{x. inner a x = b} = {x. inner a x \<ge> b} \<inter> {x. inner a x \<le> b}" by auto
+ thus ?thesis using closed_halfspace_le[of a b] and closed_halfspace_ge[of b a] using closed_Int by auto
+qed
+
+lemma closed_halfspace_component_le:
+ shows "closed {x::real^'n::finite. x$i \<le> a}"
+ using closed_halfspace_le[of "(basis i)::real^'n" a] unfolding inner_basis[OF assms] by auto
+
+lemma closed_halfspace_component_ge:
+ shows "closed {x::real^'n::finite. x$i \<ge> a}"
+ using closed_halfspace_ge[of a "(basis i)::real^'n"] unfolding inner_basis[OF assms] by auto
+
+text{* Openness of halfspaces. *}
+
+lemma open_halfspace_lt: "open {x. inner a x < b}"
+proof-
+ have "UNIV - {x. b \<le> inner a x} = {x. inner a x < b}" by auto
+ thus ?thesis using closed_halfspace_ge[unfolded closed_def Compl_eq_Diff_UNIV, of b a] by auto
+qed
+
+lemma open_halfspace_gt: "open {x. inner a x > b}"
+proof-
+ have "UNIV - {x. b \<ge> inner a x} = {x. inner a x > b}" by auto
+ thus ?thesis using closed_halfspace_le[unfolded closed_def Compl_eq_Diff_UNIV, of a b] by auto
+qed
+
+lemma open_halfspace_component_lt:
+ shows "open {x::real^'n::finite. x$i < a}"
+ using open_halfspace_lt[of "(basis i)::real^'n" a] unfolding inner_basis[OF assms] by auto
+
+lemma open_halfspace_component_gt:
+ shows "open {x::real^'n::finite. x$i > a}"
+ using open_halfspace_gt[of a "(basis i)::real^'n"] unfolding inner_basis[OF assms] by auto
+
+text{* This gives a simple derivation of limit component bounds. *}
+
+lemma Lim_component_le: fixes f :: "'a \<Rightarrow> real^'n::finite"
+ assumes "(f ---> l) net" "\<not> (trivial_limit net)" "eventually (\<lambda>x. f(x)$i \<le> b) net"
+ shows "l$i \<le> b"
+proof-
+ { fix x have "x \<in> {x::real^'n. inner (basis i) x \<le> b} \<longleftrightarrow> x$i \<le> b" unfolding inner_basis by auto } note * = this
+ show ?thesis using Lim_in_closed_set[of "{x. inner (basis i) x \<le> b}" f net l] unfolding *
+ using closed_halfspace_le[of "(basis i)::real^'n" b] and assms(1,2,3) by auto
+qed
+
+lemma Lim_component_ge: fixes f :: "'a \<Rightarrow> real^'n::finite"
+ assumes "(f ---> l) net" "\<not> (trivial_limit net)" "eventually (\<lambda>x. b \<le> (f x)$i) net"
+ shows "b \<le> l$i"
+proof-
+ { fix x have "x \<in> {x::real^'n. inner (basis i) x \<ge> b} \<longleftrightarrow> x$i \<ge> b" unfolding inner_basis by auto } note * = this
+ show ?thesis using Lim_in_closed_set[of "{x. inner (basis i) x \<ge> b}" f net l] unfolding *
+ using closed_halfspace_ge[of b "(basis i)::real^'n"] and assms(1,2,3) by auto
+qed
+
+lemma Lim_component_eq: fixes f :: "'a \<Rightarrow> real^'n::finite"
+ assumes net:"(f ---> l) net" "~(trivial_limit net)" and ev:"eventually (\<lambda>x. f(x)$i = b) net"
+ shows "l$i = b"
+ using ev[unfolded order_eq_iff eventually_and] using Lim_component_ge[OF net, of b i] and Lim_component_le[OF net, of i b] by auto
+
+lemma Lim_drop_le: fixes f :: "'a \<Rightarrow> real^1" shows
+ "(f ---> l) net \<Longrightarrow> ~(trivial_limit net) \<Longrightarrow> eventually (\<lambda>x. dest_vec1 (f x) \<le> b) net ==> dest_vec1 l \<le> b"
+ using Lim_component_le[of f l net 1 b] unfolding dest_vec1_def by auto
+
+lemma Lim_drop_ge: fixes f :: "'a \<Rightarrow> real^1" shows
+ "(f ---> l) net \<Longrightarrow> ~(trivial_limit net) \<Longrightarrow> eventually (\<lambda>x. b \<le> dest_vec1 (f x)) net ==> b \<le> dest_vec1 l"
+ using Lim_component_ge[of f l net b 1] unfolding dest_vec1_def by auto
+
+text{* Limits relative to a union. *}
+
+lemma eventually_within_Un:
+ "eventually P (net within (s \<union> t)) \<longleftrightarrow>
+ eventually P (net within s) \<and> eventually P (net within t)"
+ unfolding Limits.eventually_within
+ by (auto elim!: eventually_rev_mp)
+
+lemma Lim_within_union:
+ "(f ---> l) (net within (s \<union> t)) \<longleftrightarrow>
+ (f ---> l) (net within s) \<and> (f ---> l) (net within t)"
+ unfolding tendsto_def
+ by (auto simp add: eventually_within_Un)
+
+lemma continuous_on_union:
+ assumes "closed s" "closed t" "continuous_on s f" "continuous_on t f"
+ shows "continuous_on (s \<union> t) f"
+ using assms unfolding continuous_on unfolding Lim_within_union
+ unfolding Lim unfolding trivial_limit_within unfolding closed_limpt by auto
+
+lemma continuous_on_cases:
+ assumes "closed s" "closed t" "continuous_on s f" "continuous_on t g"
+ "\<forall>x. (x\<in>s \<and> \<not> P x) \<or> (x \<in> t \<and> P x) \<longrightarrow> f x = g x"
+ shows "continuous_on (s \<union> t) (\<lambda>x. if P x then f x else g x)"
+proof-
+ let ?h = "(\<lambda>x. if P x then f x else g x)"
+ have "\<forall>x\<in>s. f x = (if P x then f x else g x)" using assms(5) by auto
+ hence "continuous_on s ?h" using continuous_on_eq[of s f ?h] using assms(3) by auto
+ moreover
+ have "\<forall>x\<in>t. g x = (if P x then f x else g x)" using assms(5) by auto
+ hence "continuous_on t ?h" using continuous_on_eq[of t g ?h] using assms(4) by auto
+ ultimately show ?thesis using continuous_on_union[OF assms(1,2), of ?h] by auto
+qed
+
+
+text{* Some more convenient intermediate-value theorem formulations. *}
+
+lemma connected_ivt_hyperplane:
+ assumes "connected s" "x \<in> s" "y \<in> s" "inner a x \<le> b" "b \<le> inner a y"
+ shows "\<exists>z \<in> s. inner a z = b"
+proof(rule ccontr)
+ assume as:"\<not> (\<exists>z\<in>s. inner a z = b)"
+ let ?A = "{x. inner a x < b}"
+ let ?B = "{x. inner a x > b}"
+ have "open ?A" "open ?B" using open_halfspace_lt and open_halfspace_gt by auto
+ moreover have "?A \<inter> ?B = {}" by auto
+ moreover have "s \<subseteq> ?A \<union> ?B" using as by auto
+ ultimately show False using assms(1)[unfolded connected_def not_ex, THEN spec[where x="?A"], THEN spec[where x="?B"]] and assms(2-5) by auto
+qed
+
+lemma connected_ivt_component: fixes x::"real^'n::finite" shows
+ "connected s \<Longrightarrow> x \<in> s \<Longrightarrow> y \<in> s \<Longrightarrow> x$k \<le> a \<Longrightarrow> a \<le> y$k \<Longrightarrow> (\<exists>z\<in>s. z$k = a)"
+ using connected_ivt_hyperplane[of s x y "(basis k)::real^'n" a] by (auto simp add: inner_basis)
+
+text{* Also more convenient formulations of monotone convergence. *}
+
+lemma bounded_increasing_convergent: fixes s::"nat \<Rightarrow> real^1"
+ assumes "bounded {s n| n::nat. True}" "\<forall>n. dest_vec1(s n) \<le> dest_vec1(s(Suc n))"
+ shows "\<exists>l. (s ---> l) sequentially"
+proof-
+ obtain a where a:"\<forall>n. \<bar>dest_vec1 (s n)\<bar> \<le> a" using assms(1)[unfolded bounded_iff abs_dest_vec1] by auto
+ { fix m::nat
+ have "\<And> n. n\<ge>m \<longrightarrow> dest_vec1 (s m) \<le> dest_vec1 (s n)"
+ apply(induct_tac n) apply simp using assms(2) apply(erule_tac x="na" in allE) by(auto simp add: not_less_eq_eq) }
+ hence "\<forall>m n. m \<le> n \<longrightarrow> dest_vec1 (s m) \<le> dest_vec1 (s n)" by auto
+ then obtain l where "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. \<bar>dest_vec1 (s n) - l\<bar> < e" using convergent_bounded_monotone[OF a] unfolding monoseq_def by auto
+ thus ?thesis unfolding Lim_sequentially apply(rule_tac x="vec1 l" in exI)
+ unfolding dist_norm unfolding abs_dest_vec1 and dest_vec1_sub by auto
+qed
+
+subsection{* Basic homeomorphism definitions. *}
+
+definition "homeomorphism s t f g \<equiv>
+ (\<forall>x\<in>s. (g(f x) = x)) \<and> (f ` s = t) \<and> continuous_on s f \<and>
+ (\<forall>y\<in>t. (f(g y) = y)) \<and> (g ` t = s) \<and> continuous_on t g"
+
+definition
+ homeomorphic :: "'a::metric_space set \<Rightarrow> 'b::metric_space set \<Rightarrow> bool"
+ (infixr "homeomorphic" 60) where
+ homeomorphic_def: "s homeomorphic t \<equiv> (\<exists>f g. homeomorphism s t f g)"
+
+lemma homeomorphic_refl: "s homeomorphic s"
+ unfolding homeomorphic_def
+ unfolding homeomorphism_def
+ using continuous_on_id
+ apply(rule_tac x = "(\<lambda>x. x)" in exI)
+ apply(rule_tac x = "(\<lambda>x. x)" in exI)
+ by blast
+
+lemma homeomorphic_sym:
+ "s homeomorphic t \<longleftrightarrow> t homeomorphic s"
+unfolding homeomorphic_def
+unfolding homeomorphism_def
+by blast (* FIXME: slow *)
+
+lemma homeomorphic_trans:
+ assumes "s homeomorphic t" "t homeomorphic u" shows "s homeomorphic u"
+proof-
+ obtain f1 g1 where fg1:"\<forall>x\<in>s. g1 (f1 x) = x" "f1 ` s = t" "continuous_on s f1" "\<forall>y\<in>t. f1 (g1 y) = y" "g1 ` t = s" "continuous_on t g1"
+ using assms(1) unfolding homeomorphic_def homeomorphism_def by auto
+ obtain f2 g2 where fg2:"\<forall>x\<in>t. g2 (f2 x) = x" "f2 ` t = u" "continuous_on t f2" "\<forall>y\<in>u. f2 (g2 y) = y" "g2 ` u = t" "continuous_on u g2"
+ using assms(2) unfolding homeomorphic_def homeomorphism_def by auto
+
+ { fix x assume "x\<in>s" hence "(g1 \<circ> g2) ((f2 \<circ> f1) x) = x" using fg1(1)[THEN bspec[where x=x]] and fg2(1)[THEN bspec[where x="f1 x"]] and fg1(2) by auto }
+ moreover have "(f2 \<circ> f1) ` s = u" using fg1(2) fg2(2) by auto
+ moreover have "continuous_on s (f2 \<circ> f1)" using continuous_on_compose[OF fg1(3)] and fg2(3) unfolding fg1(2) by auto
+ moreover { fix y assume "y\<in>u" hence "(f2 \<circ> f1) ((g1 \<circ> g2) y) = y" using fg2(4)[THEN bspec[where x=y]] and fg1(4)[THEN bspec[where x="g2 y"]] and fg2(5) by auto }
+ moreover have "(g1 \<circ> g2) ` u = s" using fg1(5) fg2(5) by auto
+ moreover have "continuous_on u (g1 \<circ> g2)" using continuous_on_compose[OF fg2(6)] and fg1(6) unfolding fg2(5) by auto
+ ultimately show ?thesis unfolding homeomorphic_def homeomorphism_def apply(rule_tac x="f2 \<circ> f1" in exI) apply(rule_tac x="g1 \<circ> g2" in exI) by auto
+qed
+
+lemma homeomorphic_minimal:
+ "s homeomorphic t \<longleftrightarrow>
+ (\<exists>f g. (\<forall>x\<in>s. f(x) \<in> t \<and> (g(f(x)) = x)) \<and>
+ (\<forall>y\<in>t. g(y) \<in> s \<and> (f(g(y)) = y)) \<and>
+ continuous_on s f \<and> continuous_on t g)"
+unfolding homeomorphic_def homeomorphism_def
+apply auto apply (rule_tac x=f in exI) apply (rule_tac x=g in exI)
+apply auto apply (rule_tac x=f in exI) apply (rule_tac x=g in exI) apply auto
+unfolding image_iff
+apply(erule_tac x="g x" in ballE) apply(erule_tac x="x" in ballE)
+apply auto apply(rule_tac x="g x" in bexI) apply auto
+apply(erule_tac x="f x" in ballE) apply(erule_tac x="x" in ballE)
+apply auto apply(rule_tac x="f x" in bexI) by auto
+
+subsection{* Relatively weak hypotheses if a set is compact. *}
+
+definition "inv_on f s = (\<lambda>x. SOME y. y\<in>s \<and> f y = x)"
+
+lemma assumes "inj_on f s" "x\<in>s"
+ shows "inv_on f s (f x) = x"
+ using assms unfolding inj_on_def inv_on_def by auto
+
+lemma homeomorphism_compact:
+ fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
+ (* class constraint due to continuous_on_inverse *)
+ assumes "compact s" "continuous_on s f" "f ` s = t" "inj_on f s"
+ shows "\<exists>g. homeomorphism s t f g"
+proof-
+ def g \<equiv> "\<lambda>x. SOME y. y\<in>s \<and> f y = x"
+ have g:"\<forall>x\<in>s. g (f x) = x" using assms(3) assms(4)[unfolded inj_on_def] unfolding g_def by auto
+ { fix y assume "y\<in>t"
+ then obtain x where x:"f x = y" "x\<in>s" using assms(3) by auto
+ hence "g (f x) = x" using g by auto
+ hence "f (g y) = y" unfolding x(1)[THEN sym] by auto }
+ hence g':"\<forall>x\<in>t. f (g x) = x" by auto
+ moreover
+ { fix x
+ have "x\<in>s \<Longrightarrow> x \<in> g ` t" using g[THEN bspec[where x=x]] unfolding image_iff using assms(3) by(auto intro!: bexI[where x="f x"])
+ moreover
+ { assume "x\<in>g ` t"
+ then obtain y where y:"y\<in>t" "g y = x" by auto
+ then obtain x' where x':"x'\<in>s" "f x' = y" using assms(3) by auto
+ hence "x \<in> s" unfolding g_def using someI2[of "\<lambda>b. b\<in>s \<and> f b = y" x' "\<lambda>x. x\<in>s"] unfolding y(2)[THEN sym] and g_def by auto }
+ ultimately have "x\<in>s \<longleftrightarrow> x \<in> g ` t" by auto }
+ hence "g ` t = s" by auto
+ ultimately
+ show ?thesis unfolding homeomorphism_def homeomorphic_def
+ apply(rule_tac x=g in exI) using g and assms(3) and continuous_on_inverse[OF assms(2,1), of g, unfolded assms(3)] and assms(2) by auto
+qed
+
+lemma homeomorphic_compact:
+ fixes f :: "'a::heine_borel \<Rightarrow> 'b::heine_borel"
+ (* class constraint due to continuous_on_inverse *)
+ shows "compact s \<Longrightarrow> continuous_on s f \<Longrightarrow> (f ` s = t) \<Longrightarrow> inj_on f s
+ \<Longrightarrow> s homeomorphic t"
+ unfolding homeomorphic_def by(metis homeomorphism_compact)
+
+text{* Preservation of topological properties. *}
+
+lemma homeomorphic_compactness:
+ "s homeomorphic t ==> (compact s \<longleftrightarrow> compact t)"
+unfolding homeomorphic_def homeomorphism_def
+by (metis compact_continuous_image)
+
+text{* Results on translation, scaling etc. *}
+
+lemma homeomorphic_scaling:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "c \<noteq> 0" shows "s homeomorphic ((\<lambda>x. c *\<^sub>R x) ` s)"
+ unfolding homeomorphic_minimal
+ apply(rule_tac x="\<lambda>x. c *\<^sub>R x" in exI)
+ apply(rule_tac x="\<lambda>x. (1 / c) *\<^sub>R x" in exI)
+ using assms apply auto
+ using continuous_on_cmul[OF continuous_on_id] by auto
+
+lemma homeomorphic_translation:
+ fixes s :: "'a::real_normed_vector set"
+ shows "s homeomorphic ((\<lambda>x. a + x) ` s)"
+ unfolding homeomorphic_minimal
+ apply(rule_tac x="\<lambda>x. a + x" in exI)
+ apply(rule_tac x="\<lambda>x. -a + x" in exI)
+ using continuous_on_add[OF continuous_on_const continuous_on_id] by auto
+
+lemma homeomorphic_affinity:
+ fixes s :: "'a::real_normed_vector set"
+ assumes "c \<noteq> 0" shows "s homeomorphic ((\<lambda>x. a + c *\<^sub>R x) ` s)"
+proof-
+ have *:"op + a ` op *\<^sub>R c ` s = (\<lambda>x. a + c *\<^sub>R x) ` s" by auto
+ show ?thesis
+ using homeomorphic_trans
+ using homeomorphic_scaling[OF assms, of s]
+ using homeomorphic_translation[of "(\<lambda>x. c *\<^sub>R x) ` s" a] unfolding * by auto
+qed
+
+lemma homeomorphic_balls:
+ fixes a b ::"'a::real_normed_vector" (* FIXME: generalize to metric_space *)
+ assumes "0 < d" "0 < e"
+ shows "(ball a d) homeomorphic (ball b e)" (is ?th)
+ "(cball a d) homeomorphic (cball b e)" (is ?cth)
+proof-
+ have *:"\<bar>e / d\<bar> > 0" "\<bar>d / e\<bar> >0" using assms using divide_pos_pos by auto
+ show ?th unfolding homeomorphic_minimal
+ apply(rule_tac x="\<lambda>x. b + (e/d) *\<^sub>R (x - a)" in exI)
+ apply(rule_tac x="\<lambda>x. a + (d/e) *\<^sub>R (x - b)" in exI)
+ using assms apply (auto simp add: dist_commute)
+ unfolding dist_norm
+ apply (auto simp add: pos_divide_less_eq mult_strict_left_mono)
+ unfolding continuous_on
+ by (intro ballI tendsto_intros, simp, assumption)+
+next
+ have *:"\<bar>e / d\<bar> > 0" "\<bar>d / e\<bar> >0" using assms using divide_pos_pos by auto
+ show ?cth unfolding homeomorphic_minimal
+ apply(rule_tac x="\<lambda>x. b + (e/d) *\<^sub>R (x - a)" in exI)
+ apply(rule_tac x="\<lambda>x. a + (d/e) *\<^sub>R (x - b)" in exI)
+ using assms apply (auto simp add: dist_commute)
+ unfolding dist_norm
+ apply (auto simp add: pos_divide_le_eq)
+ unfolding continuous_on
+ by (intro ballI tendsto_intros, simp, assumption)+
+qed
+
+text{* "Isometry" (up to constant bounds) of injective linear map etc. *}
+
+lemma cauchy_isometric:
+ fixes x :: "nat \<Rightarrow> real ^ 'n::finite"
+ assumes e:"0 < e" and s:"subspace s" and f:"bounded_linear f" and normf:"\<forall>x\<in>s. norm(f x) \<ge> e * norm(x)" and xs:"\<forall>n::nat. x n \<in> s" and cf:"Cauchy(f o x)"
+ shows "Cauchy x"
+proof-
+ interpret f: bounded_linear f by fact
+ { fix d::real assume "d>0"
+ then obtain N where N:"\<forall>n\<ge>N. norm (f (x n) - f (x N)) < e * d"
+ using cf[unfolded cauchy o_def dist_norm, THEN spec[where x="e*d"]] and e and mult_pos_pos[of e d] by auto
+ { fix n assume "n\<ge>N"
+ hence "norm (f (x n - x N)) < e * d" using N[THEN spec[where x=n]] unfolding f.diff[THEN sym] by auto
+ moreover have "e * norm (x n - x N) \<le> norm (f (x n - x N))"
+ using subspace_sub[OF s, of "x n" "x N"] using xs[THEN spec[where x=N]] and xs[THEN spec[where x=n]]
+ using normf[THEN bspec[where x="x n - x N"]] by auto
+ ultimately have "norm (x n - x N) < d" using `e>0`
+ using mult_left_less_imp_less[of e "norm (x n - x N)" d] by auto }
+ hence "\<exists>N. \<forall>n\<ge>N. norm (x n - x N) < d" by auto }
+ thus ?thesis unfolding cauchy and dist_norm by auto
+qed
+
+lemma complete_isometric_image:
+ fixes f :: "real ^ _ \<Rightarrow> real ^ _"
+ assumes "0 < e" and s:"subspace s" and f:"bounded_linear f" and normf:"\<forall>x\<in>s. norm(f x) \<ge> e * norm(x)" and cs:"complete s"
+ shows "complete(f ` s)"
+proof-
+ { fix g assume as:"\<forall>n::nat. g n \<in> f ` s" and cfg:"Cauchy g"
+ then obtain x where "\<forall>n. x n \<in> s \<and> g n = f (x n)" unfolding image_iff and Bex_def
+ using choice[of "\<lambda> n xa. xa \<in> s \<and> g n = f xa"] by auto
+ hence x:"\<forall>n. x n \<in> s" "\<forall>n. g n = f (x n)" by auto
+ hence "f \<circ> x = g" unfolding expand_fun_eq by auto
+ then obtain l where "l\<in>s" and l:"(x ---> l) sequentially"
+ using cs[unfolded complete_def, THEN spec[where x="x"]]
+ using cauchy_isometric[OF `0<e` s f normf] and cfg and x(1) by auto
+ hence "\<exists>l\<in>f ` s. (g ---> l) sequentially"
+ using linear_continuous_at[OF f, unfolded continuous_at_sequentially, THEN spec[where x=x], of l]
+ unfolding `f \<circ> x = g` by auto }
+ thus ?thesis unfolding complete_def by auto
+qed
+
+lemma dist_0_norm:
+ fixes x :: "'a::real_normed_vector"
+ shows "dist 0 x = norm x"
+unfolding dist_norm by simp
+
+lemma injective_imp_isometric: fixes f::"real^'m::finite \<Rightarrow> real^'n::finite"
+ assumes s:"closed s" "subspace s" and f:"bounded_linear f" "\<forall>x\<in>s. (f x = 0) \<longrightarrow> (x = 0)"
+ shows "\<exists>e>0. \<forall>x\<in>s. norm (f x) \<ge> e * norm(x)"
+proof(cases "s \<subseteq> {0::real^'m}")
+ case True
+ { fix x assume "x \<in> s"
+ hence "x = 0" using True by auto
+ hence "norm x \<le> norm (f x)" by auto }
+ thus ?thesis by(auto intro!: exI[where x=1])
+next
+ interpret f: bounded_linear f by fact
+ case False
+ then obtain a where a:"a\<noteq>0" "a\<in>s" by auto
+ from False have "s \<noteq> {}" by auto
+ let ?S = "{f x| x. (x \<in> s \<and> norm x = norm a)}"
+ let ?S' = "{x::real^'m. x\<in>s \<and> norm x = norm a}"
+ let ?S'' = "{x::real^'m. norm x = norm a}"
+
+ have "?S'' = frontier(cball 0 (norm a))" unfolding frontier_cball and dist_norm by (auto simp add: norm_minus_cancel)
+ hence "compact ?S''" using compact_frontier[OF compact_cball, of 0 "norm a"] by auto
+ moreover have "?S' = s \<inter> ?S''" by auto
+ ultimately have "compact ?S'" using closed_inter_compact[of s ?S''] using s(1) by auto
+ moreover have *:"f ` ?S' = ?S" by auto
+ ultimately have "compact ?S" using compact_continuous_image[OF linear_continuous_on[OF f(1)], of ?S'] by auto
+ hence "closed ?S" using compact_imp_closed by auto
+ moreover have "?S \<noteq> {}" using a by auto
+ ultimately obtain b' where "b'\<in>?S" "\<forall>y\<in>?S. norm b' \<le> norm y" using distance_attains_inf[of ?S 0] unfolding dist_0_norm by auto
+ then obtain b where "b\<in>s" and ba:"norm b = norm a" and b:"\<forall>x\<in>{x \<in> s. norm x = norm a}. norm (f b) \<le> norm (f x)" unfolding *[THEN sym] unfolding image_iff by auto
+
+ let ?e = "norm (f b) / norm b"
+ have "norm b > 0" using ba and a and norm_ge_zero by auto
+ moreover have "norm (f b) > 0" using f(2)[THEN bspec[where x=b], OF `b\<in>s`] using `norm b >0` unfolding zero_less_norm_iff by auto
+ ultimately have "0 < norm (f b) / norm b" by(simp only: divide_pos_pos)
+ moreover
+ { fix x assume "x\<in>s"
+ hence "norm (f b) / norm b * norm x \<le> norm (f x)"
+ proof(cases "x=0")
+ case True thus "norm (f b) / norm b * norm x \<le> norm (f x)" by auto
+ next
+ case False
+ hence *:"0 < norm a / norm x" using `a\<noteq>0` unfolding zero_less_norm_iff[THEN sym] by(simp only: divide_pos_pos)
+ have "\<forall>c. \<forall>x\<in>s. c *\<^sub>R x \<in> s" using s[unfolded subspace_def smult_conv_scaleR] by auto
+ hence "(norm a / norm x) *\<^sub>R x \<in> {x \<in> s. norm x = norm a}" using `x\<in>s` and `x\<noteq>0` by auto
+ thus "norm (f b) / norm b * norm x \<le> norm (f x)" using b[THEN bspec[where x="(norm a / norm x) *\<^sub>R x"]]
+ unfolding f.scaleR and ba using `x\<noteq>0` `a\<noteq>0`
+ by (auto simp add: real_mult_commute pos_le_divide_eq pos_divide_le_eq)
+ qed }
+ ultimately
+ show ?thesis by auto
+qed
+
+lemma closed_injective_image_subspace:
+ fixes f :: "real ^ _ \<Rightarrow> real ^ _"
+ assumes "subspace s" "bounded_linear f" "\<forall>x\<in>s. f x = 0 --> x = 0" "closed s"
+ shows "closed(f ` s)"
+proof-
+ obtain e where "e>0" and e:"\<forall>x\<in>s. e * norm x \<le> norm (f x)" using injective_imp_isometric[OF assms(4,1,2,3)] by auto
+ show ?thesis using complete_isometric_image[OF `e>0` assms(1,2) e] and assms(4)
+ unfolding complete_eq_closed[THEN sym] by auto
+qed
+
+subsection{* Some properties of a canonical subspace. *}
+
+lemma subspace_substandard:
+ "subspace {x::real^'n. (\<forall>i. P i \<longrightarrow> x$i = 0)}"
+ unfolding subspace_def by(auto simp add: vector_add_component vector_smult_component elim!: ballE)
+
+lemma closed_substandard:
+ "closed {x::real^'n::finite. \<forall>i. P i --> x$i = 0}" (is "closed ?A")
+proof-
+ let ?D = "{i. P i}"
+ let ?Bs = "{{x::real^'n. inner (basis i) x = 0}| i. i \<in> ?D}"
+ { fix x
+ { assume "x\<in>?A"
+ hence x:"\<forall>i\<in>?D. x $ i = 0" by auto
+ hence "x\<in> \<Inter> ?Bs" by(auto simp add: inner_basis x) }
+ moreover
+ { assume x:"x\<in>\<Inter>?Bs"
+ { fix i assume i:"i \<in> ?D"
+ then obtain B where BB:"B \<in> ?Bs" and B:"B = {x::real^'n. inner (basis i) x = 0}" by auto
+ hence "x $ i = 0" unfolding B using x unfolding inner_basis by auto }
+ hence "x\<in>?A" by auto }
+ ultimately have "x\<in>?A \<longleftrightarrow> x\<in> \<Inter>?Bs" by auto }
+ hence "?A = \<Inter> ?Bs" by auto
+ thus ?thesis by(auto simp add: closed_Inter closed_hyperplane)
+qed
+
+lemma dim_substandard:
+ shows "dim {x::real^'n::finite. \<forall>i. i \<notin> d \<longrightarrow> x$i = 0} = card d" (is "dim ?A = _")
+proof-
+ let ?D = "UNIV::'n set"
+ let ?B = "(basis::'n\<Rightarrow>real^'n) ` d"
+
+ let ?bas = "basis::'n \<Rightarrow> real^'n"
+
+ have "?B \<subseteq> ?A" by auto
+
+ moreover
+ { fix x::"real^'n" assume "x\<in>?A"
+ with finite[of d]
+ have "x\<in> span ?B"
+ proof(induct d arbitrary: x)
+ case empty hence "x=0" unfolding Cart_eq by auto
+ thus ?case using subspace_0[OF subspace_span[of "{}"]] by auto
+ next
+ case (insert k F)
+ hence *:"\<forall>i. i \<notin> insert k F \<longrightarrow> x $ i = 0" by auto
+ have **:"F \<subseteq> insert k F" by auto
+ def y \<equiv> "x - x$k *\<^sub>R basis k"
+ have y:"x = y + (x$k) *\<^sub>R basis k" unfolding y_def by auto
+ { fix i assume i':"i \<notin> F"
+ hence "y $ i = 0" unfolding y_def unfolding vector_minus_component
+ and vector_smult_component and basis_component
+ using *[THEN spec[where x=i]] by auto }
+ hence "y \<in> span (basis ` (insert k F))" using insert(3)
+ using span_mono[of "?bas ` F" "?bas ` (insert k F)"]
+ using image_mono[OF **, of basis] by auto
+ moreover
+ have "basis k \<in> span (?bas ` (insert k F))" by(rule span_superset, auto)
+ hence "x$k *\<^sub>R basis k \<in> span (?bas ` (insert k F))"
+ using span_mul [where 'a=real, unfolded smult_conv_scaleR] by auto
+ ultimately
+ have "y + x$k *\<^sub>R basis k \<in> span (?bas ` (insert k F))"
+ using span_add by auto
+ thus ?case using y by auto
+ qed
+ }
+ hence "?A \<subseteq> span ?B" by auto
+
+ moreover
+ { fix x assume "x \<in> ?B"
+ hence "x\<in>{(basis i)::real^'n |i. i \<in> ?D}" using assms by auto }
+ hence "independent ?B" using independent_mono[OF independent_stdbasis, of ?B] and assms by auto
+
+ moreover
+ have "d \<subseteq> ?D" unfolding subset_eq using assms by auto
+ hence *:"inj_on (basis::'n\<Rightarrow>real^'n) d" using subset_inj_on[OF basis_inj, of "d"] by auto
+ have "?B hassize (card d)" unfolding hassize_def and card_image[OF *] by auto
+
+ ultimately show ?thesis using dim_unique[of "basis ` d" ?A] by auto
+qed
+
+text{* Hence closure and completeness of all subspaces. *}
+
+lemma closed_subspace_lemma: "n \<le> card (UNIV::'n::finite set) \<Longrightarrow> \<exists>A::'n set. card A = n"
+apply (induct n)
+apply (rule_tac x="{}" in exI, simp)
+apply clarsimp
+apply (subgoal_tac "\<exists>x. x \<notin> A")
+apply (erule exE)
+apply (rule_tac x="insert x A" in exI, simp)
+apply (subgoal_tac "A \<noteq> UNIV", auto)
+done
+
+lemma closed_subspace: fixes s::"(real^'n::finite) set"
+ assumes "subspace s" shows "closed s"
+proof-
+ have "dim s \<le> card (UNIV :: 'n set)" using dim_subset_univ by auto
+ then obtain d::"'n set" where t: "card d = dim s"
+ using closed_subspace_lemma by auto
+ let ?t = "{x::real^'n. \<forall>i. i \<notin> d \<longrightarrow> x$i = 0}"
+ obtain f where f:"bounded_linear f" "f ` ?t = s" "inj_on f ?t"
+ using subspace_isomorphism[unfolded linear_conv_bounded_linear, OF subspace_substandard[of "\<lambda>i. i \<notin> d"] assms]
+ using dim_substandard[of d] and t by auto
+ interpret f: bounded_linear f by fact
+ have "\<forall>x\<in>?t. f x = 0 \<longrightarrow> x = 0" using f.zero using f(3)[unfolded inj_on_def]
+ by(erule_tac x=0 in ballE) auto
+ moreover have "closed ?t" using closed_substandard .
+ moreover have "subspace ?t" using subspace_substandard .
+ ultimately show ?thesis using closed_injective_image_subspace[of ?t f]
+ unfolding f(2) using f(1) by auto
+qed
+
+lemma complete_subspace:
+ fixes s :: "(real ^ _) set" shows "subspace s ==> complete s"
+ using complete_eq_closed closed_subspace
+ by auto
+
+lemma dim_closure:
+ fixes s :: "(real ^ _) set"
+ shows "dim(closure s) = dim s" (is "?dc = ?d")
+proof-
+ have "?dc \<le> ?d" using closure_minimal[OF span_inc, of s]
+ using closed_subspace[OF subspace_span, of s]
+ using dim_subset[of "closure s" "span s"] unfolding dim_span by auto
+ thus ?thesis using dim_subset[OF closure_subset, of s] by auto
+qed
+
+text{* Affine transformations of intervals. *}
+
+lemma affinity_inverses:
+ assumes m0: "m \<noteq> (0::'a::field)"
+ shows "(\<lambda>x. m *s x + c) o (\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) = id"
+ "(\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) o (\<lambda>x. m *s x + c) = id"
+ using m0
+apply (auto simp add: expand_fun_eq vector_add_ldistrib vector_smult_assoc)
+by (simp add: vector_smult_lneg[symmetric] vector_smult_assoc vector_sneg_minus1[symmetric])
+
+lemma real_affinity_le:
+ "0 < (m::'a::ordered_field) ==> (m * x + c \<le> y \<longleftrightarrow> x \<le> inverse(m) * y + -(c / m))"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma real_le_affinity:
+ "0 < (m::'a::ordered_field) ==> (y \<le> m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) \<le> x)"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma real_affinity_lt:
+ "0 < (m::'a::ordered_field) ==> (m * x + c < y \<longleftrightarrow> x < inverse(m) * y + -(c / m))"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma real_lt_affinity:
+ "0 < (m::'a::ordered_field) ==> (y < m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) < x)"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma real_affinity_eq:
+ "(m::'a::ordered_field) \<noteq> 0 ==> (m * x + c = y \<longleftrightarrow> x = inverse(m) * y + -(c / m))"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma real_eq_affinity:
+ "(m::'a::ordered_field) \<noteq> 0 ==> (y = m * x + c \<longleftrightarrow> inverse(m) * y + -(c / m) = x)"
+ by (simp add: field_simps inverse_eq_divide)
+
+lemma vector_affinity_eq:
+ assumes m0: "(m::'a::field) \<noteq> 0"
+ shows "m *s x + c = y \<longleftrightarrow> x = inverse m *s y + -(inverse m *s c)"
+proof
+ assume h: "m *s x + c = y"
+ hence "m *s x = y - c" by (simp add: ring_simps)
+ hence "inverse m *s (m *s x) = inverse m *s (y - c)" by simp
+ then show "x = inverse m *s y + - (inverse m *s c)"
+ using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
+next
+ assume h: "x = inverse m *s y + - (inverse m *s c)"
+ show "m *s x + c = y" unfolding h diff_minus[symmetric]
+ using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
+qed
+
+lemma vector_eq_affinity:
+ "(m::'a::field) \<noteq> 0 ==> (y = m *s x + c \<longleftrightarrow> inverse(m) *s y + -(inverse(m) *s c) = x)"
+ using vector_affinity_eq[where m=m and x=x and y=y and c=c]
+ by metis
+
+lemma image_affinity_interval: fixes m::real
+ fixes a b c :: "real^'n::finite"
+ shows "(\<lambda>x. m *\<^sub>R x + c) ` {a .. b} =
+ (if {a .. b} = {} then {}
+ else (if 0 \<le> m then {m *\<^sub>R a + c .. m *\<^sub>R b + c}
+ else {m *\<^sub>R b + c .. m *\<^sub>R a + c}))"
+proof(cases "m=0")
+ { fix x assume "x \<le> c" "c \<le> x"
+ hence "x=c" unfolding vector_less_eq_def and Cart_eq by (auto intro: order_antisym) }
+ moreover case True
+ moreover have "c \<in> {m *\<^sub>R a + c..m *\<^sub>R b + c}" unfolding True by(auto simp add: vector_less_eq_def)
+ ultimately show ?thesis by auto
+next
+ case False
+ { fix y assume "a \<le> y" "y \<le> b" "m > 0"
+ hence "m *\<^sub>R a + c \<le> m *\<^sub>R y + c" "m *\<^sub>R y + c \<le> m *\<^sub>R b + c"
+ unfolding vector_less_eq_def by(auto simp add: vector_smult_component vector_add_component)
+ } moreover
+ { fix y assume "a \<le> y" "y \<le> b" "m < 0"
+ hence "m *\<^sub>R b + c \<le> m *\<^sub>R y + c" "m *\<^sub>R y + c \<le> m *\<^sub>R a + c"
+ unfolding vector_less_eq_def by(auto simp add: vector_smult_component vector_add_component mult_left_mono_neg elim!:ballE)
+ } moreover
+ { fix y assume "m > 0" "m *\<^sub>R a + c \<le> y" "y \<le> m *\<^sub>R b + c"
+ hence "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
+ unfolding image_iff Bex_def mem_interval vector_less_eq_def
+ apply(auto simp add: vector_smult_component vector_add_component vector_minus_component vector_smult_assoc pth_3[symmetric]
+ intro!: exI[where x="(1 / m) *\<^sub>R (y - c)"])
+ by(auto simp add: pos_le_divide_eq pos_divide_le_eq real_mult_commute diff_le_iff)
+ } moreover
+ { fix y assume "m *\<^sub>R b + c \<le> y" "y \<le> m *\<^sub>R a + c" "m < 0"
+ hence "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
+ unfolding image_iff Bex_def mem_interval vector_less_eq_def
+ apply(auto simp add: vector_smult_component vector_add_component vector_minus_component vector_smult_assoc pth_3[symmetric]
+ intro!: exI[where x="(1 / m) *\<^sub>R (y - c)"])
+ by(auto simp add: neg_le_divide_eq neg_divide_le_eq real_mult_commute diff_le_iff)
+ }
+ ultimately show ?thesis using False by auto
+qed
+
+lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::real^'n::finite)) ` {a..b} =
+ (if {a..b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a..m *\<^sub>R b} else {m *\<^sub>R b..m *\<^sub>R a})"
+ using image_affinity_interval[of m 0 a b] by auto
+
+subsection{* Banach fixed point theorem (not really topological...) *}
+
+lemma banach_fix:
+ assumes s:"complete s" "s \<noteq> {}" and c:"0 \<le> c" "c < 1" and f:"(f ` s) \<subseteq> s" and
+ lipschitz:"\<forall>x\<in>s. \<forall>y\<in>s. dist (f x) (f y) \<le> c * dist x y"
+ shows "\<exists>! x\<in>s. (f x = x)"
+proof-
+ have "1 - c > 0" using c by auto
+
+ from s(2) obtain z0 where "z0 \<in> s" by auto
+ def z \<equiv> "\<lambda>n. (f ^^ n) z0"
+ { fix n::nat
+ have "z n \<in> s" unfolding z_def
+ proof(induct n) case 0 thus ?case using `z0 \<in>s` by auto
+ next case Suc thus ?case using f by auto qed }
+ note z_in_s = this
+
+ def d \<equiv> "dist (z 0) (z 1)"
+
+ have fzn:"\<And>n. f (z n) = z (Suc n)" unfolding z_def by auto
+ { fix n::nat
+ have "dist (z n) (z (Suc n)) \<le> (c ^ n) * d"
+ proof(induct n)
+ case 0 thus ?case unfolding d_def by auto
+ next
+ case (Suc m)
+ hence "c * dist (z m) (z (Suc m)) \<le> c ^ Suc m * d"
+ using `0 \<le> c` using mult_mono1_class.mult_mono1[of "dist (z m) (z (Suc m))" "c ^ m * d" c] by auto
+ thus ?case using lipschitz[THEN bspec[where x="z m"], OF z_in_s, THEN bspec[where x="z (Suc m)"], OF z_in_s]
+ unfolding fzn and mult_le_cancel_left by auto
+ qed
+ } note cf_z = this
+
+ { fix n m::nat
+ have "(1 - c) * dist (z m) (z (m+n)) \<le> (c ^ m) * d * (1 - c ^ n)"
+ proof(induct n)
+ case 0 show ?case by auto
+ next
+ case (Suc k)
+ have "(1 - c) * dist (z m) (z (m + Suc k)) \<le> (1 - c) * (dist (z m) (z (m + k)) + dist (z (m + k)) (z (Suc (m + k))))"
+ using dist_triangle and c by(auto simp add: dist_triangle)
+ also have "\<dots> \<le> (1 - c) * (dist (z m) (z (m + k)) + c ^ (m + k) * d)"
+ using cf_z[of "m + k"] and c by auto
+ also have "\<dots> \<le> c ^ m * d * (1 - c ^ k) + (1 - c) * c ^ (m + k) * d"
+ using Suc by (auto simp add: ring_simps)
+ also have "\<dots> = (c ^ m) * (d * (1 - c ^ k) + (1 - c) * c ^ k * d)"
+ unfolding power_add by (auto simp add: ring_simps)
+ also have "\<dots> \<le> (c ^ m) * d * (1 - c ^ Suc k)"
+ using c by (auto simp add: ring_simps)
+ finally show ?case by auto
+ qed
+ } note cf_z2 = this
+ { fix e::real assume "e>0"
+ hence "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (z m) (z n) < e"
+ proof(cases "d = 0")
+ case True
+ hence "\<And>n. z n = z0" using cf_z2[of 0] and c unfolding z_def by (auto simp add: pos_prod_le[OF `1 - c > 0`])
+ thus ?thesis using `e>0` by auto
+ next
+ case False hence "d>0" unfolding d_def using zero_le_dist[of "z 0" "z 1"]
+ by (metis False d_def real_less_def)
+ hence "0 < e * (1 - c) / d" using `e>0` and `1-c>0`
+ using divide_pos_pos[of "e * (1 - c)" d] and mult_pos_pos[of e "1 - c"] by auto
+ then obtain N where N:"c ^ N < e * (1 - c) / d" using real_arch_pow_inv[of "e * (1 - c) / d" c] and c by auto
+ { fix m n::nat assume "m>n" and as:"m\<ge>N" "n\<ge>N"
+ have *:"c ^ n \<le> c ^ N" using `n\<ge>N` and c using power_decreasing[OF `n\<ge>N`, of c] by auto
+ have "1 - c ^ (m - n) > 0" using c and power_strict_mono[of c 1 "m - n"] using `m>n` by auto
+ hence **:"d * (1 - c ^ (m - n)) / (1 - c) > 0"
+ using real_mult_order[OF `d>0`, of "1 - c ^ (m - n)"]
+ using divide_pos_pos[of "d * (1 - c ^ (m - n))" "1 - c"]
+ using `0 < 1 - c` by auto
+
+ have "dist (z m) (z n) \<le> c ^ n * d * (1 - c ^ (m - n)) / (1 - c)"
+ using cf_z2[of n "m - n"] and `m>n` unfolding pos_le_divide_eq[OF `1-c>0`]
+ by (auto simp add: real_mult_commute dist_commute)
+ also have "\<dots> \<le> c ^ N * d * (1 - c ^ (m - n)) / (1 - c)"
+ using mult_right_mono[OF * order_less_imp_le[OF **]]
+ unfolding real_mult_assoc by auto
+ also have "\<dots> < (e * (1 - c) / d) * d * (1 - c ^ (m - n)) / (1 - c)"
+ using mult_strict_right_mono[OF N **] unfolding real_mult_assoc by auto
+ also have "\<dots> = e * (1 - c ^ (m - n))" using c and `d>0` and `1 - c > 0` by auto
+ also have "\<dots> \<le> e" using c and `1 - c ^ (m - n) > 0` and `e>0` using mult_right_le_one_le[of e "1 - c ^ (m - n)"] by auto
+ finally have "dist (z m) (z n) < e" by auto
+ } note * = this
+ { fix m n::nat assume as:"N\<le>m" "N\<le>n"
+ hence "dist (z n) (z m) < e"
+ proof(cases "n = m")
+ case True thus ?thesis using `e>0` by auto
+ next
+ case False thus ?thesis using as and *[of n m] *[of m n] unfolding nat_neq_iff by (auto simp add: dist_commute)
+ qed }
+ thus ?thesis by auto
+ qed
+ }
+ hence "Cauchy z" unfolding cauchy_def by auto
+ then obtain x where "x\<in>s" and x:"(z ---> x) sequentially" using s(1)[unfolded compact_def complete_def, THEN spec[where x=z]] and z_in_s by auto
+
+ def e \<equiv> "dist (f x) x"
+ have "e = 0" proof(rule ccontr)
+ assume "e \<noteq> 0" hence "e>0" unfolding e_def using zero_le_dist[of "f x" x]
+ by (metis dist_eq_0_iff dist_nz e_def)
+ then obtain N where N:"\<forall>n\<ge>N. dist (z n) x < e / 2"
+ using x[unfolded Lim_sequentially, THEN spec[where x="e/2"]] by auto
+ hence N':"dist (z N) x < e / 2" by auto
+
+ have *:"c * dist (z N) x \<le> dist (z N) x" unfolding mult_le_cancel_right2
+ using zero_le_dist[of "z N" x] and c
+ by (metis dist_eq_0_iff dist_nz order_less_asym real_less_def)
+ have "dist (f (z N)) (f x) \<le> c * dist (z N) x" using lipschitz[THEN bspec[where x="z N"], THEN bspec[where x=x]]
+ using z_in_s[of N] `x\<in>s` using c by auto
+ also have "\<dots> < e / 2" using N' and c using * by auto
+ finally show False unfolding fzn
+ using N[THEN spec[where x="Suc N"]] and dist_triangle_half_r[of "z (Suc N)" "f x" e x]
+ unfolding e_def by auto
+ qed
+ hence "f x = x" unfolding e_def by auto
+ moreover
+ { fix y assume "f y = y" "y\<in>s"
+ hence "dist x y \<le> c * dist x y" using lipschitz[THEN bspec[where x=x], THEN bspec[where x=y]]
+ using `x\<in>s` and `f x = x` by auto
+ hence "dist x y = 0" unfolding mult_le_cancel_right1
+ using c and zero_le_dist[of x y] by auto
+ hence "y = x" by auto
+ }
+ ultimately show ?thesis unfolding Bex1_def using `x\<in>s` by blast+
+qed
+
+subsection{* Edelstein fixed point theorem. *}
+
+lemma edelstein_fix:
+ fixes s :: "'a::real_normed_vector set"
+ assumes s:"compact s" "s \<noteq> {}" and gs:"(g ` s) \<subseteq> s"
+ and dist:"\<forall>x\<in>s. \<forall>y\<in>s. x \<noteq> y \<longrightarrow> dist (g x) (g y) < dist x y"
+ shows "\<exists>! x\<in>s. g x = x"
+proof(cases "\<exists>x\<in>s. g x \<noteq> x")
+ obtain x where "x\<in>s" using s(2) by auto
+ case False hence g:"\<forall>x\<in>s. g x = x" by auto
+ { fix y assume "y\<in>s"
+ hence "x = y" using `x\<in>s` and dist[THEN bspec[where x=x], THEN bspec[where x=y]]
+ unfolding g[THEN bspec[where x=x], OF `x\<in>s`]
+ unfolding g[THEN bspec[where x=y], OF `y\<in>s`] by auto }
+ thus ?thesis unfolding Bex1_def using `x\<in>s` and g by blast+
+next
+ case True
+ then obtain x where [simp]:"x\<in>s" and "g x \<noteq> x" by auto
+ { fix x y assume "x \<in> s" "y \<in> s"
+ hence "dist (g x) (g y) \<le> dist x y"
+ using dist[THEN bspec[where x=x], THEN bspec[where x=y]] by auto } note dist' = this
+ def y \<equiv> "g x"
+ have [simp]:"y\<in>s" unfolding y_def using gs[unfolded image_subset_iff] and `x\<in>s` by blast
+ def f \<equiv> "\<lambda>n. g ^^ n"
+ have [simp]:"\<And>n z. g (f n z) = f (Suc n) z" unfolding f_def by auto
+ have [simp]:"\<And>z. f 0 z = z" unfolding f_def by auto
+ { fix n::nat and z assume "z\<in>s"
+ have "f n z \<in> s" unfolding f_def
+ proof(induct n)
+ case 0 thus ?case using `z\<in>s` by simp
+ next
+ case (Suc n) thus ?case using gs[unfolded image_subset_iff] by auto
+ qed } note fs = this
+ { fix m n ::nat assume "m\<le>n"
+ fix w z assume "w\<in>s" "z\<in>s"
+ have "dist (f n w) (f n z) \<le> dist (f m w) (f m z)" using `m\<le>n`
+ proof(induct n)
+ case 0 thus ?case by auto
+ next
+ case (Suc n)
+ thus ?case proof(cases "m\<le>n")
+ case True thus ?thesis using Suc(1)
+ using dist'[OF fs fs, OF `w\<in>s` `z\<in>s`, of n n] by auto
+ next
+ case False hence mn:"m = Suc n" using Suc(2) by simp
+ show ?thesis unfolding mn by auto
+ qed
+ qed } note distf = this
+
+ def h \<equiv> "\<lambda>n. (f n x, f n y)"
+ let ?s2 = "s \<times> s"
+ obtain l r where "l\<in>?s2" and r:"subseq r" and lr:"((h \<circ> r) ---> l) sequentially"
+ using compact_Times [OF s(1) s(1), unfolded compact_def, THEN spec[where x=h]] unfolding h_def
+ using fs[OF `x\<in>s`] and fs[OF `y\<in>s`] by blast
+ def a \<equiv> "fst l" def b \<equiv> "snd l"
+ have lab:"l = (a, b)" unfolding a_def b_def by simp
+ have [simp]:"a\<in>s" "b\<in>s" unfolding a_def b_def using `l\<in>?s2` by auto
+
+ have lima:"((fst \<circ> (h \<circ> r)) ---> a) sequentially"
+ and limb:"((snd \<circ> (h \<circ> r)) ---> b) sequentially"
+ using lr
+ unfolding o_def a_def b_def by (simp_all add: tendsto_intros)
+
+ { fix n::nat
+ have *:"\<And>fx fy (x::'a) y. dist fx fy \<le> dist x y \<Longrightarrow> \<not> (dist (fx - fy) (a - b) < dist a b - dist x y)" unfolding dist_norm by norm
+ { fix x y :: 'a
+ have "dist (-x) (-y) = dist x y" unfolding dist_norm
+ using norm_minus_cancel[of "x - y"] by (auto simp add: uminus_add_conv_diff) } note ** = this
+
+ { assume as:"dist a b > dist (f n x) (f n y)"
+ then obtain Na Nb where "\<forall>m\<ge>Na. dist (f (r m) x) a < (dist a b - dist (f n x) (f n y)) / 2"
+ and "\<forall>m\<ge>Nb. dist (f (r m) y) b < (dist a b - dist (f n x) (f n y)) / 2"
+ using lima limb unfolding h_def Lim_sequentially by (fastsimp simp del: less_divide_eq_number_of1)
+ hence "dist (f (r (Na + Nb + n)) x - f (r (Na + Nb + n)) y) (a - b) < dist a b - dist (f n x) (f n y)"
+ apply(erule_tac x="Na+Nb+n" in allE)
+ apply(erule_tac x="Na+Nb+n" in allE) apply simp
+ using dist_triangle_add_half[of a "f (r (Na + Nb + n)) x" "dist a b - dist (f n x) (f n y)"
+ "-b" "- f (r (Na + Nb + n)) y"]
+ unfolding ** unfolding group_simps(12) by (auto simp add: dist_commute)
+ moreover
+ have "dist (f (r (Na + Nb + n)) x - f (r (Na + Nb + n)) y) (a - b) \<ge> dist a b - dist (f n x) (f n y)"
+ using distf[of n "r (Na+Nb+n)", OF _ `x\<in>s` `y\<in>s`]
+ using subseq_bigger[OF r, of "Na+Nb+n"]
+ using *[of "f (r (Na + Nb + n)) x" "f (r (Na + Nb + n)) y" "f n x" "f n y"] by auto
+ ultimately have False by simp
+ }
+ hence "dist a b \<le> dist (f n x) (f n y)" by(rule ccontr)auto }
+ note ab_fn = this
+
+ have [simp]:"a = b" proof(rule ccontr)
+ def e \<equiv> "dist a b - dist (g a) (g b)"
+ assume "a\<noteq>b" hence "e > 0" unfolding e_def using dist by fastsimp
+ hence "\<exists>n. dist (f n x) a < e/2 \<and> dist (f n y) b < e/2"
+ using lima limb unfolding Lim_sequentially
+ apply (auto elim!: allE[where x="e/2"]) apply(rule_tac x="r (max N Na)" in exI) unfolding h_def by fastsimp
+ then obtain n where n:"dist (f n x) a < e/2 \<and> dist (f n y) b < e/2" by auto
+ have "dist (f (Suc n) x) (g a) \<le> dist (f n x) a"
+ using dist[THEN bspec[where x="f n x"], THEN bspec[where x="a"]] and fs by auto
+ moreover have "dist (f (Suc n) y) (g b) \<le> dist (f n y) b"
+ using dist[THEN bspec[where x="f n y"], THEN bspec[where x="b"]] and fs by auto
+ ultimately have "dist (f (Suc n) x) (g a) + dist (f (Suc n) y) (g b) < e" using n by auto
+ thus False unfolding e_def using ab_fn[of "Suc n"] by norm
+ qed
+
+ have [simp]:"\<And>n. f (Suc n) x = f n y" unfolding f_def y_def by(induct_tac n)auto
+ { fix x y assume "x\<in>s" "y\<in>s" moreover
+ fix e::real assume "e>0" ultimately
+ have "dist y x < e \<longrightarrow> dist (g y) (g x) < e" using dist by fastsimp }
+ hence "continuous_on s g" unfolding continuous_on_def by auto
+
+ hence "((snd \<circ> h \<circ> r) ---> g a) sequentially" unfolding continuous_on_sequentially
+ apply (rule allE[where x="\<lambda>n. (fst \<circ> h \<circ> r) n"]) apply (erule ballE[where x=a])
+ using lima unfolding h_def o_def using fs[OF `x\<in>s`] by (auto simp add: y_def)
+ hence "g a = a" using Lim_unique[OF trivial_limit_sequentially limb, of "g a"]
+ unfolding `a=b` and o_assoc by auto
+ moreover
+ { fix x assume "x\<in>s" "g x = x" "x\<noteq>a"
+ hence "False" using dist[THEN bspec[where x=a], THEN bspec[where x=x]]
+ using `g a = a` and `a\<in>s` by auto }
+ ultimately show "\<exists>!x\<in>s. g x = x" unfolding Bex1_def using `a\<in>s` by blast
+qed
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,240 @@
+(* Title: HOL/Nitpick.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Nitpick: Yet another counterexample generator for Isabelle/HOL.
+*)
+
+header {* Nitpick: Yet Another Counterexample Generator for Isabelle/HOL *}
+
+theory Nitpick
+imports Map SAT
+uses ("Tools/Nitpick/kodkod.ML")
+ ("Tools/Nitpick/kodkod_sat.ML")
+ ("Tools/Nitpick/nitpick_util.ML")
+ ("Tools/Nitpick/nitpick_hol.ML")
+ ("Tools/Nitpick/nitpick_mono.ML")
+ ("Tools/Nitpick/nitpick_scope.ML")
+ ("Tools/Nitpick/nitpick_peephole.ML")
+ ("Tools/Nitpick/nitpick_rep.ML")
+ ("Tools/Nitpick/nitpick_nut.ML")
+ ("Tools/Nitpick/nitpick_kodkod.ML")
+ ("Tools/Nitpick/nitpick_model.ML")
+ ("Tools/Nitpick/nitpick.ML")
+ ("Tools/Nitpick/nitpick_isar.ML")
+ ("Tools/Nitpick/nitpick_tests.ML")
+ ("Tools/Nitpick/minipick.ML")
+begin
+
+typedecl bisim_iterator
+
+(* FIXME: use axiomatization (here and elsewhere) *)
+axiomatization unknown :: 'a
+ and undefined_fast_The :: 'a
+ and undefined_fast_Eps :: 'a
+ and bisim :: "bisim_iterator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
+ and bisim_iterator_max :: bisim_iterator
+ and Tha :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
+
+datatype ('a, 'b) pair_box = PairBox 'a 'b
+datatype ('a, 'b) fun_box = FunBox "'a \<Rightarrow> 'b"
+
+text {*
+Alternative definitions.
+*}
+
+lemma If_def [nitpick_def]:
+"(if P then Q else R) \<equiv> (P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R)"
+by (rule eq_reflection) (rule if_bool_eq_conj)
+
+lemma Ex1_def [nitpick_def]:
+"Ex1 P \<equiv> \<exists>x. P = {x}"
+apply (rule eq_reflection)
+apply (simp add: Ex1_def expand_set_eq)
+apply (rule iffI)
+ apply (erule exE)
+ apply (erule conjE)
+ apply (rule_tac x = x in exI)
+ apply (rule allI)
+ apply (rename_tac y)
+ apply (erule_tac x = y in allE)
+by (auto simp: mem_def)
+
+lemma rtrancl_def [nitpick_def]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
+by simp
+
+lemma rtranclp_def [nitpick_def]:
+"rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
+by (rule eq_reflection) (auto dest: rtranclpD)
+
+lemma tranclp_def [nitpick_def]:
+"tranclp r a b \<equiv> trancl (split r) (a, b)"
+by (simp add: trancl_def Collect_def mem_def)
+
+definition refl' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
+"refl' r \<equiv> \<forall>x. (x, x) \<in> r"
+
+definition wf' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
+"wf' r \<equiv> acyclic r \<and> (finite r \<or> unknown)"
+
+axiomatization wf_wfrec :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
+
+definition wf_wfrec' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
+[nitpick_simp]: "wf_wfrec' R F x = F (Recdef.cut (wf_wfrec R F) R x) x"
+
+definition wfrec' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
+"wfrec' R F x \<equiv> if wf R then wf_wfrec' R F x
+ else THE y. wfrec_rel R (%f x. F (Recdef.cut f R x) x) x y"
+
+definition card' :: "('a \<Rightarrow> bool) \<Rightarrow> nat" where
+"card' X \<equiv> length (SOME xs. set xs = X \<and> distinct xs)"
+
+definition setsum' :: "('a \<Rightarrow> 'b\<Colon>comm_monoid_add) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'b" where
+"setsum' f A \<equiv> if finite A then listsum (map f (SOME xs. set xs = A \<and> distinct xs)) else 0"
+
+inductive fold_graph' :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
+"fold_graph' f z {} z" |
+"\<lbrakk>x \<in> A; fold_graph' f z (A - {x}) y\<rbrakk> \<Longrightarrow> fold_graph' f z A (f x y)"
+
+text {*
+The following lemmas are not strictly necessary but they help the
+\textit{special\_level} optimization.
+*}
+
+lemma The_psimp [nitpick_psimp]:
+"P = {x} \<Longrightarrow> The P = x"
+by (subgoal_tac "{x} = (\<lambda>y. y = x)") (auto simp: mem_def)
+
+lemma Eps_psimp [nitpick_psimp]:
+"\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
+apply (case_tac "P (Eps P)")
+ apply auto
+apply (erule contrapos_np)
+by (rule someI)
+
+lemma unit_case_def [nitpick_def]:
+"unit_case x u \<equiv> x"
+apply (subgoal_tac "u = ()")
+ apply (simp only: unit.cases)
+by simp
+
+lemma nat_case_def [nitpick_def]:
+"nat_case x f n \<equiv> if n = 0 then x else f (n - 1)"
+apply (rule eq_reflection)
+by (case_tac n) auto
+
+lemmas dvd_def = dvd_eq_mod_eq_0 [THEN eq_reflection, nitpick_def]
+
+lemma list_size_simp [nitpick_simp]:
+"list_size f xs = (if xs = [] then 0
+ else Suc (f (hd xs) + list_size f (tl xs)))"
+"size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
+by (case_tac xs) auto
+
+text {*
+Auxiliary definitions used to provide an alternative representation for
+@{text rat} and @{text real}.
+*}
+
+function nat_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+[simp del]: "nat_gcd x y = (if y = 0 then x else nat_gcd y (x mod y))"
+by auto
+termination
+apply (relation "measure (\<lambda>(x, y). x + y + (if y > x then 1 else 0))")
+ apply auto
+ apply (metis mod_less_divisor xt1(9))
+by (metis mod_mod_trivial mod_self nat_neq_iff xt1(10))
+
+definition nat_lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+"nat_lcm x y = x * y div (nat_gcd x y)"
+
+definition int_gcd :: "int \<Rightarrow> int \<Rightarrow> int" where
+"int_gcd x y = int (nat_gcd (nat (abs x)) (nat (abs y)))"
+
+definition int_lcm :: "int \<Rightarrow> int \<Rightarrow> int" where
+"int_lcm x y = int (nat_lcm (nat (abs x)) (nat (abs y)))"
+
+definition Frac :: "int \<times> int \<Rightarrow> bool" where
+"Frac \<equiv> \<lambda>(a, b). b > 0 \<and> int_gcd a b = 1"
+
+axiomatization Abs_Frac :: "int \<times> int \<Rightarrow> 'a"
+ and Rep_Frac :: "'a \<Rightarrow> int \<times> int"
+
+definition zero_frac :: 'a where
+"zero_frac \<equiv> Abs_Frac (0, 1)"
+
+definition one_frac :: 'a where
+"one_frac \<equiv> Abs_Frac (1, 1)"
+
+definition num :: "'a \<Rightarrow> int" where
+"num \<equiv> fst o Rep_Frac"
+
+definition denom :: "'a \<Rightarrow> int" where
+"denom \<equiv> snd o Rep_Frac"
+
+function norm_frac :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
+[simp del]: "norm_frac a b = (if b < 0 then norm_frac (- a) (- b)
+ else if a = 0 \<or> b = 0 then (0, 1)
+ else let c = int_gcd a b in (a div c, b div c))"
+by pat_completeness auto
+termination by (relation "measure (\<lambda>(_, b). if b < 0 then 1 else 0)") auto
+
+definition frac :: "int \<Rightarrow> int \<Rightarrow> 'a" where
+"frac a b \<equiv> Abs_Frac (norm_frac a b)"
+
+definition plus_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
+[nitpick_simp]:
+"plus_frac q r = (let d = int_lcm (denom q) (denom r) in
+ frac (num q * (d div denom q) + num r * (d div denom r)) d)"
+
+definition times_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
+[nitpick_simp]:
+"times_frac q r = frac (num q * num r) (denom q * denom r)"
+
+definition uminus_frac :: "'a \<Rightarrow> 'a" where
+"uminus_frac q \<equiv> Abs_Frac (- num q, denom q)"
+
+definition number_of_frac :: "int \<Rightarrow> 'a" where
+"number_of_frac n \<equiv> Abs_Frac (n, 1)"
+
+definition inverse_frac :: "'a \<Rightarrow> 'a" where
+"inverse_frac q \<equiv> frac (denom q) (num q)"
+
+definition less_eq_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
+[nitpick_simp]:
+"less_eq_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) \<le> 0"
+
+definition of_frac :: "'a \<Rightarrow> 'b\<Colon>{inverse,ring_1}" where
+"of_frac q \<equiv> of_int (num q) / of_int (denom q)"
+
+use "Tools/Nitpick/kodkod.ML"
+use "Tools/Nitpick/kodkod_sat.ML"
+use "Tools/Nitpick/nitpick_util.ML"
+use "Tools/Nitpick/nitpick_hol.ML"
+use "Tools/Nitpick/nitpick_mono.ML"
+use "Tools/Nitpick/nitpick_scope.ML"
+use "Tools/Nitpick/nitpick_peephole.ML"
+use "Tools/Nitpick/nitpick_rep.ML"
+use "Tools/Nitpick/nitpick_nut.ML"
+use "Tools/Nitpick/nitpick_kodkod.ML"
+use "Tools/Nitpick/nitpick_model.ML"
+use "Tools/Nitpick/nitpick.ML"
+use "Tools/Nitpick/nitpick_isar.ML"
+use "Tools/Nitpick/nitpick_tests.ML"
+use "Tools/Nitpick/minipick.ML"
+
+hide (open) const unknown undefined_fast_The undefined_fast_Eps bisim
+ bisim_iterator_max Tha refl' wf' wf_wfrec wf_wfrec' wfrec' card' setsum'
+ fold_graph' nat_gcd nat_lcm int_gcd int_lcm Frac Abs_Frac Rep_Frac zero_frac
+ one_frac num denom norm_frac frac plus_frac times_frac uminus_frac
+ number_of_frac inverse_frac less_eq_frac of_frac
+hide (open) type bisim_iterator pair_box fun_box
+hide (open) fact If_def Ex1_def rtrancl_def rtranclp_def tranclp_def refl'_def
+ wf'_def wf_wfrec'_def wfrec'_def card'_def setsum'_def fold_graph'_def
+ The_psimp Eps_psimp unit_case_def nat_case_def dvd_def list_size_simp
+ nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def
+ one_frac_def num_def denom_def norm_frac_def frac_def plus_frac_def
+ times_frac_def uminus_frac_def number_of_frac_def inverse_frac_def
+ less_eq_frac_def of_frac_def
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Core_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1123 @@
+(* Title: HOL/Nitpick_Examples/Core_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick's functional core.
+*)
+
+header {* Examples Featuring Nitpick's Functional Core *}
+
+theory Core_Nits
+imports Main
+begin
+
+subsection {* Curry in a Hurry *}
+
+lemma "(\<lambda>f x y. (curry o split) f x y) = (\<lambda>f x y. (\<lambda>x. x) f x y)"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 100, expect = none, timeout = none]
+by auto
+
+lemma "(\<lambda>f p. (split o curry) f p) = (\<lambda>f p. (\<lambda>x. x) f p)"
+nitpick [card = 2]
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 10, expect = none]
+by auto
+
+lemma "split (curry f) = f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 10, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "curry (split f) = f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "(split o curry) f = f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "(curry o split) f = f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 1000, expect = none]
+by auto
+
+lemma "(split o curry) f = (\<lambda>x. x) f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "(curry o split) f = (\<lambda>x. x) f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "((split o curry) f) p = ((\<lambda>x. x) f) p"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+lemma "((curry o split) f) x = ((\<lambda>x. x) f) x"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 1000, expect = none]
+by auto
+
+lemma "((curry o split) f) x y = ((\<lambda>x. x) f) x y"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 1000, expect = none]
+by auto
+
+lemma "split o curry = (\<lambda>x. x)"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+apply (rule ext)+
+by auto
+
+lemma "curry o split = (\<lambda>x. x)"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 100, expect = none]
+apply (rule ext)+
+by auto
+
+lemma "split (\<lambda>x y. f (x, y)) = f"
+nitpick [card = 1\<midarrow>4, expect = none]
+nitpick [card = 40, expect = none]
+by auto
+
+subsection {* Representations *}
+
+lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y = y"
+nitpick [expect = none]
+by auto
+
+lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
+nitpick [card 'a = 35, card 'b = 34, expect = genuine]
+nitpick [card = 1\<midarrow>15, mono, expect = none]
+oops
+
+lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y \<noteq> y"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 5, expect = genuine]
+oops
+
+lemma "P (\<lambda>x. x)"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 5, expect = genuine]
+oops
+
+lemma "{(a\<Colon>'a\<times>'a, b\<Colon>'b)}^-1 = {(b, a)}"
+nitpick [card = 1\<midarrow>6, expect = none]
+nitpick [card = 20, expect = none]
+by auto
+
+lemma "fst (a, b) = a"
+nitpick [card = 1\<midarrow>20, expect = none]
+by auto
+
+lemma "\<exists>P. P = Id"
+nitpick [card = 1\<midarrow>4, expect = none]
+by auto
+
+lemma "(a\<Colon>'a\<Rightarrow>'b, a) \<in> Id\<^sup>*"
+nitpick [card = 1\<midarrow>3, expect = none]
+by auto
+
+lemma "(a\<Colon>'a\<times>'a, a) \<in> Id\<^sup>* \<union> {(a, b)}\<^sup>*"
+nitpick [card = 1\<midarrow>6, expect = none]
+by auto
+
+lemma "Id (a, a)"
+nitpick [card = 1\<midarrow>100, expect = none]
+by (auto simp: Id_def Collect_def)
+
+lemma "Id ((a\<Colon>'a, b\<Colon>'a), (a, b))"
+nitpick [card = 1\<midarrow>20, expect = none]
+by (auto simp: Id_def Collect_def)
+
+lemma "UNIV (x\<Colon>'a\<times>'a)"
+nitpick [card = 1\<midarrow>50, expect = none]
+sorry
+
+lemma "{} = A - A"
+nitpick [card = 1\<midarrow>100, expect = none]
+by auto
+
+lemma "g = Let (A \<or> B)"
+nitpick [card = 1, expect = none]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 20, expect = genuine]
+oops
+
+lemma "(let a_or_b = A \<or> B in a_or_b \<or> \<not> a_or_b)"
+nitpick [expect = none]
+by auto
+
+lemma "A \<subseteq> B"
+nitpick [card = 100, expect = genuine]
+oops
+
+lemma "A = {b}"
+nitpick [card = 100, expect = genuine]
+oops
+
+lemma "{a, b} = {b}"
+nitpick [card = 100, expect = genuine]
+oops
+
+lemma "(a\<Colon>'a\<times>'a, a\<Colon>'a\<times>'a) \<in> R"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 4, expect = genuine]
+nitpick [card = 20, expect = genuine]
+nitpick [card = 10, dont_box, expect = genuine]
+oops
+
+lemma "f (g\<Colon>'a\<Rightarrow>'a) = x"
+nitpick [card = 3, expect = genuine]
+nitpick [card = 3, dont_box, expect = genuine]
+nitpick [card = 5, expect = genuine]
+nitpick [card = 10, expect = genuine]
+oops
+
+lemma "f (a, b) = x"
+nitpick [card = 3, expect = genuine]
+nitpick [card = 10, expect = genuine]
+nitpick [card = 16, expect = genuine]
+nitpick [card = 30, expect = genuine]
+oops
+
+lemma "f (a, a) = f (c, d)"
+nitpick [card = 4, expect = genuine]
+nitpick [card = 20, expect = genuine]
+oops
+
+lemma "(x\<Colon>'a) = (\<lambda>a. \<lambda>b. \<lambda>c. if c then a else b) x x True"
+nitpick [card = 2, expect = none]
+by auto
+
+lemma "\<exists>F. F a b = G a b"
+nitpick [card = 3, expect = none]
+by auto
+
+lemma "f = split"
+nitpick [card = 1, expect = none]
+nitpick [card = 2, expect = genuine]
+oops
+
+lemma "(A\<Colon>'a\<times>'a, B\<Colon>'a\<times>'a) \<in> R \<Longrightarrow> (A, B) \<in> R"
+nitpick [card = 20, expect = none]
+by auto
+
+lemma "(A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R) \<Longrightarrow>
+ A = B \<or> (A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R)"
+nitpick [card = 1\<midarrow>50, expect = none]
+by auto
+
+lemma "f = (\<lambda>x\<Colon>'a\<times>'b. x)"
+nitpick [card = 3, expect = genuine]
+nitpick [card = 4, expect = genuine]
+nitpick [card = 8, expect = genuine]
+oops
+
+subsection {* Quantifiers *}
+
+lemma "x = y"
+nitpick [card 'a = 1, expect = none]
+nitpick [card 'a = 2, expect = genuine]
+nitpick [card 'a = 100, expect = genuine]
+nitpick [card 'a = 1000, expect = genuine]
+oops
+
+lemma "\<forall>x. x = y"
+nitpick [card 'a = 1, expect = none]
+nitpick [card 'a = 2, expect = genuine]
+nitpick [card 'a = 100, expect = genuine]
+nitpick [card 'a = 1000, expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a \<Rightarrow> bool. x = y"
+nitpick [card 'a = 1, expect = genuine]
+nitpick [card 'a = 2, expect = genuine]
+nitpick [card 'a = 100, expect = genuine]
+nitpick [card 'a = 1000, expect = genuine]
+oops
+
+lemma "\<exists>x\<Colon>'a \<Rightarrow> bool. x = y"
+nitpick [card 'a = 1\<midarrow>10, expect = none]
+by auto
+
+lemma "\<exists>x y\<Colon>'a \<Rightarrow> bool. x = y"
+nitpick [card = 1\<midarrow>40, expect = none]
+by auto
+
+lemma "\<forall>x. \<exists>y. f x y = f x (g x)"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u) w (h u w)"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u w) w (h u)"
+nitpick [card = 1\<midarrow>2, expect = genuine]
+nitpick [card = 3, expect = genuine]
+oops
+
+lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
+ f u v w x y z = f u (g u) w (h u w) y (k u w y)"
+nitpick [card = 1\<midarrow>2, expect = none]
+nitpick [card = 3, expect = none]
+nitpick [card = 4, expect = none]
+sorry
+
+lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
+ f u v w x y z = f u (g u) w (h u w y) y (k u w y)"
+nitpick [card = 1\<midarrow>2, expect = genuine]
+oops
+
+lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
+ f u v w x y z = f u (g u w) w (h u w) y (k u w y)"
+nitpick [card = 1\<midarrow>2, expect = genuine]
+oops
+
+lemma "\<forall>u\<Colon>'a \<times> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<times> 'f.
+ f u v w x = f u (g u) w (h u w)"
+nitpick [card = 1\<midarrow>2, expect = none]
+sorry
+
+lemma "\<forall>u\<Colon>'a \<times> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<times> 'f.
+ f u v w x = f u (g u w) w (h u)"
+nitpick [card = 1\<midarrow>2, dont_box, expect = genuine]
+oops
+
+lemma "\<forall>u\<Colon>'a \<Rightarrow> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<Rightarrow> 'f.
+ f u v w x = f u (g u) w (h u w)"
+nitpick [card = 1\<midarrow>2, dont_box, expect = none]
+sorry
+
+lemma "\<forall>u\<Colon>'a \<Rightarrow> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<Rightarrow> 'f.
+ f u v w x = f u (g u w) w (h u)"
+nitpick [card = 1\<midarrow>2, dont_box, expect = genuine]
+oops
+
+lemma "\<forall>x. if (\<forall>y. x = y) then False else True"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2\<midarrow>5, expect = none]
+oops
+
+lemma "\<forall>x\<Colon>'a\<times>'b. if (\<forall>y. x = y) then False else True"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2, expect = none]
+oops
+
+lemma "\<forall>x. if (\<exists>y. x = y) then True else False"
+nitpick [expect = none]
+sorry
+
+lemma "\<forall>x\<Colon>'a\<times>'b. if (\<exists>y. x = y) then True else False"
+nitpick [expect = none]
+sorry
+
+lemma "(\<not> (\<exists>x. P x)) \<longleftrightarrow> (\<forall>x. \<not> P x)"
+nitpick [expect = none]
+by auto
+
+lemma "(\<not> \<not> (\<exists>x. P x)) \<longleftrightarrow> (\<not> (\<forall>x. \<not> P x))"
+nitpick [expect = none]
+by auto
+
+lemma "(\<exists>x\<Colon>'a. \<forall>y. P x y) \<or> (\<exists>x\<Colon>'a \<times> 'a. \<forall>y. P y x)"
+nitpick [card 'a = 1, expect = genuine]
+nitpick [card 'a = 2, expect = genuine]
+nitpick [card 'a = 3, expect = genuine]
+nitpick [card 'a = 4, expect = genuine]
+nitpick [card 'a = 5, expect = genuine]
+oops
+
+lemma "\<exists>x. if x = y then (\<forall>y. y = x \<or> y \<noteq> x)
+ else (\<forall>y. y = (x, x) \<or> y \<noteq> (x, x))"
+nitpick [expect = none]
+by auto
+
+lemma "\<exists>x. if x = y then (\<exists>y. y = x \<or> y \<noteq> x)
+ else (\<exists>y. y = (x, x) \<or> y \<noteq> (x, x))"
+nitpick [expect = none]
+by auto
+
+lemma "let x = (\<forall>x. P x) in if x then x else \<not> x"
+nitpick [expect = none]
+by auto
+
+lemma "let x = (\<forall>x\<Colon>'a \<times> 'b. P x) in if x then x else \<not> x"
+nitpick [expect = none]
+by auto
+
+subsection {* Schematic Variables *}
+
+lemma "x = ?x"
+nitpick [expect = none]
+by auto
+
+lemma "\<forall>x. x = ?x"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>x. x = ?x"
+nitpick [expect = none]
+by auto
+
+lemma "\<exists>x\<Colon>'a \<Rightarrow> 'b. x = ?x"
+nitpick [expect = none]
+by auto
+
+lemma "\<forall>x. ?x = ?y"
+nitpick [expect = none]
+by auto
+
+lemma "\<exists>x. ?x = ?y"
+nitpick [expect = none]
+by auto
+
+subsection {* Known Constants *}
+
+lemma "x \<equiv> all \<Longrightarrow> False"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 1, box "('a \<Rightarrow> prop) \<Rightarrow> prop", expect = genuine]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 8, expect = genuine]
+nitpick [card = 10, expect = unknown]
+oops
+
+lemma "\<And>x. f x y = f x y"
+nitpick [expect = none]
+oops
+
+lemma "\<And>x. f x y = f y x"
+nitpick [expect = genuine]
+oops
+
+lemma "all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop True"
+nitpick [expect = none]
+by auto
+
+lemma "all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop False"
+nitpick [expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> all P \<equiv> all (\<lambda>x. P (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "x \<equiv> (op \<equiv>) \<Longrightarrow> False"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 3, expect = genuine]
+nitpick [card = 4, expect = genuine]
+nitpick [card = 5, expect = genuine]
+nitpick [card = 100, expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> (op \<equiv> x) \<equiv> (\<lambda>y. (x \<equiv> I y))"
+nitpick [expect = none]
+by auto
+
+lemma "P x \<equiv> P x"
+nitpick [card = 1\<midarrow>10, expect = none]
+by auto
+
+lemma "P x \<equiv> Q x \<Longrightarrow> P x = Q x"
+nitpick [card = 1\<midarrow>10, expect = none]
+by auto
+
+lemma "P x = Q x \<Longrightarrow> P x \<equiv> Q x"
+nitpick [card = 1\<midarrow>10, expect = none]
+by auto
+
+lemma "x \<equiv> (op \<Longrightarrow>) \<Longrightarrow> False"
+nitpick [expect = genuine]
+oops
+
+lemma "I \<equiv> (\<lambda>x. x) \<Longrightarrow> (op \<Longrightarrow> x) \<equiv> (\<lambda>y. (op \<Longrightarrow> x (I y)))"
+nitpick [expect = none]
+by auto
+
+lemma "P x \<Longrightarrow> P x"
+nitpick [card = 1\<midarrow>10, expect = none]
+by auto
+
+lemma "True \<Longrightarrow> True" "False \<Longrightarrow> True" "False \<Longrightarrow> False"
+nitpick [expect = none]
+by auto
+
+lemma "True \<Longrightarrow> False"
+nitpick [expect = genuine]
+oops
+
+lemma "x = Not"
+nitpick [expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> Not = (\<lambda>x. Not (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "x = True"
+nitpick [expect = genuine]
+oops
+
+lemma "x = False"
+nitpick [expect = genuine]
+oops
+
+lemma "x = undefined"
+nitpick [expect = genuine]
+oops
+
+lemma "(False, ()) = undefined \<Longrightarrow> ((), False) = undefined"
+nitpick [expect = genuine]
+oops
+
+lemma "undefined = undefined"
+nitpick [expect = none]
+by auto
+
+lemma "f undefined = f undefined"
+nitpick [expect = none]
+by auto
+
+lemma "f undefined = g undefined"
+nitpick [card = 33, expect = genuine]
+oops
+
+lemma "\<exists>!x. x = undefined"
+nitpick [card = 30, expect = none]
+by auto
+
+lemma "x = All \<Longrightarrow> False"
+nitpick [card = 1, dont_box, expect = genuine]
+nitpick [card = 2, dont_box, expect = genuine]
+nitpick [card = 8, dont_box, expect = genuine]
+nitpick [card = 10, dont_box, expect = unknown]
+oops
+
+lemma "\<forall>x. f x y = f x y"
+nitpick [expect = none]
+oops
+
+lemma "\<forall>x. f x y = f y x"
+nitpick [expect = genuine]
+oops
+
+lemma "All (\<lambda>x. f x y = f x y) = True"
+nitpick [expect = none]
+by auto
+
+lemma "All (\<lambda>x. f x y = f x y) = False"
+nitpick [expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> All P = All (\<lambda>x. P (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "x = Ex \<Longrightarrow> False"
+nitpick [card = 1, dont_box, expect = genuine]
+nitpick [card = 2, dont_box, expect = genuine]
+nitpick [card = 8, dont_box, expect = genuine]
+nitpick [card = 10, dont_box, expect = unknown]
+oops
+
+lemma "\<exists>x. f x y = f x y"
+nitpick [expect = none]
+oops
+
+lemma "\<exists>x. f x y = f y x"
+nitpick [expect = none]
+oops
+
+lemma "Ex (\<lambda>x. f x y = f x y) = True"
+nitpick [expect = none]
+by auto
+
+lemma "Ex (\<lambda>x. f x y = f y x) = True"
+nitpick [expect = none]
+by auto
+
+lemma "Ex (\<lambda>x. f x y = f x y) = False"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex (\<lambda>x. f x y = f y x) = False"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex (\<lambda>x. f x y \<noteq> f x y) = False"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> Ex P = Ex (\<lambda>x. P (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> (op =) = (\<lambda>x. (op= (I x)))"
+ "I = (\<lambda>x. x) \<Longrightarrow> (op =) = (\<lambda>x y. x = (I y))"
+nitpick [expect = none]
+by auto
+
+lemma "x = y \<Longrightarrow> y = x"
+nitpick [expect = none]
+by auto
+
+lemma "x = y \<Longrightarrow> f x = f y"
+nitpick [expect = none]
+by auto
+
+lemma "x = y \<and> y = z \<Longrightarrow> x = z"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> (op &) = (\<lambda>x. op & (I x))"
+ "I = (\<lambda>x. x) \<Longrightarrow> (op &) = (\<lambda>x y. x & (I y))"
+nitpick [expect = none]
+by auto
+
+lemma "(a \<and> b) = (\<not> (\<not> a \<or> \<not> b))"
+nitpick [expect = none]
+by auto
+
+lemma "a \<and> b \<Longrightarrow> a" "a \<and> b \<Longrightarrow> b"
+nitpick [expect = none]
+by auto
+
+lemma "\<not> a \<Longrightarrow> \<not> (a \<and> b)" "\<not> b \<Longrightarrow> \<not> (a \<and> b)"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> (op \<or>) = (\<lambda>x. op \<or> (I x))"
+ "I = (\<lambda>x. x) \<Longrightarrow> (op \<or>) = (\<lambda>x y. x \<or> (I y))"
+nitpick [expect = none]
+by auto
+
+lemma "a \<Longrightarrow> a \<or> b" "b \<Longrightarrow> a \<or> b"
+nitpick [expect = none]
+by auto
+
+lemma "\<not> (a \<or> b) \<Longrightarrow> \<not> a" "\<not> (a \<or> b) \<Longrightarrow> \<not> b"
+nitpick [expect = none]
+by auto
+
+lemma "(op \<longrightarrow>) = (\<lambda>x. op\<longrightarrow> x)" "(op\<longrightarrow> ) = (\<lambda>x y. x \<longrightarrow> y)"
+nitpick [expect = none]
+by auto
+
+lemma "\<not>a \<Longrightarrow> a \<longrightarrow> b" "b \<Longrightarrow> a \<longrightarrow> b"
+nitpick [expect = none]
+by auto
+
+lemma "\<lbrakk>a; \<not> b\<rbrakk> \<Longrightarrow> \<not> (a \<longrightarrow> b)"
+nitpick [expect = none]
+by auto
+
+lemma "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
+nitpick [expect = none]
+by auto
+
+lemma "(if a then b else c) = (THE d. (a \<longrightarrow> (d = b)) \<and> (\<not> a \<longrightarrow> (d = c)))"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> If = (\<lambda>x. If (I x))"
+ "J = (\<lambda>x. x) \<Longrightarrow> If = (\<lambda>x y. If x (J y))"
+ "K = (\<lambda>x. x) \<Longrightarrow> If = (\<lambda>x y z. If x y (K z))"
+nitpick [expect = none]
+by auto
+
+lemma "fst (x, y) = x"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd (x, y) = y"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "fst (x\<Colon>'a\<Rightarrow>'b, y) = x"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd (x\<Colon>'a\<Rightarrow>'b, y) = y"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "fst (x, y\<Colon>'a\<Rightarrow>'b) = x"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd (x, y\<Colon>'a\<Rightarrow>'b) = y"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "fst (x\<Colon>'a\<times>'b, y) = x"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd (x\<Colon>'a\<times>'b, y) = y"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "fst (x, y\<Colon>'a\<times>'b) = x"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd (x, y\<Colon>'a\<times>'b) = y"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "fst p = (THE a. \<exists>b. p = Pair a b)"
+nitpick [expect = none]
+by (simp add: fst_def)
+
+lemma "snd p = (THE b. \<exists>a. p = Pair a b)"
+nitpick [expect = none]
+by (simp add: snd_def)
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> fst = (\<lambda>x. fst (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> snd = (\<lambda>x. snd (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "fst (x, y) = snd (y, x)"
+nitpick [expect = none]
+by auto
+
+lemma "(x, x) \<in> Id"
+nitpick [expect = none]
+by auto
+
+lemma "(x, y) \<in> Id \<Longrightarrow> x = y"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> Id = (\<lambda>x. Id (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> curry Id = (\<lambda>x y. Id (x, I y))"
+nitpick [expect = none]
+by (simp add: curry_def)
+
+lemma "{} = (\<lambda>x. False)"
+nitpick [expect = none]
+by (metis Collect_def empty_def)
+
+lemma "x \<in> {}"
+nitpick [expect = genuine]
+oops
+
+lemma "{a, b} = {b}"
+nitpick [expect = genuine]
+oops
+
+lemma "{a, b} \<noteq> {b}"
+nitpick [expect = genuine]
+oops
+
+lemma "{a} = {b}"
+nitpick [expect = genuine]
+oops
+
+lemma "{a} \<noteq> {b}"
+nitpick [expect = genuine]
+oops
+
+lemma "{a, b, c} = {c, b, a}"
+nitpick [expect = none]
+by auto
+
+lemma "UNIV = (\<lambda>x. True)"
+nitpick [expect = none]
+by (simp only: UNIV_def Collect_def)
+
+lemma "UNIV x = True"
+nitpick [expect = none]
+by (simp only: UNIV_def Collect_def)
+
+lemma "x \<notin> UNIV"
+nitpick [expect = genuine]
+oops
+
+lemma "op \<in> = (\<lambda>x P. P x)"
+nitpick [expect = none]
+apply (rule ext)
+apply (rule ext)
+by (simp add: mem_def)
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<in> = (\<lambda>x. (op \<in> (I x)))"
+nitpick [expect = none]
+apply (rule ext)
+apply (rule ext)
+by (simp add: mem_def)
+
+lemma "P x = (x \<in> P)"
+nitpick [expect = none]
+by (simp add: mem_def)
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> insert = (\<lambda>x. insert (I x))"
+nitpick [expect = none]
+by simp
+
+lemma "insert = (\<lambda>x y. insert x (y \<union> y))"
+nitpick [expect = none]
+by simp
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> trancl = (\<lambda>x. trancl (I x))"
+nitpick [card = 1\<midarrow>2, expect = none]
+by auto
+
+lemma "rtrancl = (\<lambda>x. rtrancl x \<union> {(y, y)})"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply (rule ext)
+by auto
+
+lemma "(x, x) \<in> rtrancl {(y, y)}"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> rtrancl = (\<lambda>x. rtrancl (I x))"
+nitpick [card = 1\<midarrow>2, expect = none]
+by auto
+
+lemma "((x, x), (x, x)) \<in> rtrancl {}"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<union> = (\<lambda>x. op \<union> (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<union> = (\<lambda>x y. op \<union> x (I y))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "a \<in> A \<Longrightarrow> a \<in> (A \<union> B)" "b \<in> B \<Longrightarrow> b \<in> (A \<union> B)"
+nitpick [expect = none]
+by auto
+
+lemma "a \<in> (A \<union> B) \<Longrightarrow> a \<in> A \<or> a \<in> B"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<inter> = (\<lambda>x. op \<inter> (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<inter> = (\<lambda>x y. op \<inter> x (I y))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "a \<notin> A \<Longrightarrow> a \<notin> (A \<inter> B)" "b \<notin> B \<Longrightarrow> b \<notin> (A \<inter> B)"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "a \<notin> (A \<inter> B) \<Longrightarrow> a \<notin> A \<or> a \<notin> B"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op - = (\<lambda>x\<Colon>'a set. op - (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op - = (\<lambda>x y\<Colon>'a set. op - x (I y))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "x \<in> ((A\<Colon>'a set) - B) \<longleftrightarrow> x \<in> A \<and> x \<notin> B"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<subset> = (\<lambda>x. op \<subset> (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<subset> = (\<lambda>x y. op \<subset> x (I y))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "A \<subset> B \<Longrightarrow> (\<forall>a \<in> A. a \<in> B) \<and> (\<exists>b \<in> B. b \<notin> A)"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<subseteq> = (\<lambda>x. op \<subseteq> (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<subseteq> = (\<lambda>x y. op \<subseteq> x (I y))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "A \<subseteq> B \<Longrightarrow> \<forall>a \<in> A. a \<in> B"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "A \<subseteq> B \<Longrightarrow> A \<subset> B"
+nitpick [card = 5, expect = genuine]
+oops
+
+lemma "A \<subset> B \<Longrightarrow> A \<subseteq> B"
+nitpick [expect = none]
+by auto
+
+lemma "I = (\<lambda>x\<Colon>'a set. x) \<Longrightarrow> uminus = (\<lambda>x. uminus (I x))"
+nitpick [expect = none]
+by auto
+
+lemma "A \<union> - A = UNIV"
+nitpick [expect = none]
+by auto
+
+lemma "A \<inter> - A = {}"
+nitpick [expect = none]
+by auto
+
+lemma "A = -(A\<Colon>'a set)"
+nitpick [card 'a = 10, expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> finite = (\<lambda>x. finite (I x))"
+nitpick [expect = none]
+oops
+
+lemma "finite A"
+nitpick [expect = none]
+oops
+
+lemma "finite A \<Longrightarrow> finite B"
+nitpick [expect = none]
+oops
+
+lemma "All finite"
+nitpick [expect = none]
+oops
+
+subsection {* The and Eps *}
+
+lemma "x = The"
+nitpick [card = 5, expect = genuine]
+oops
+
+lemma "\<exists>x. x = The"
+nitpick [card = 1\<midarrow>3]
+by auto
+
+lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> The P = x"
+nitpick [expect = none]
+by auto
+
+lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = z"
+nitpick [expect = genuine]
+oops
+
+lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = x \<or> The P = y"
+nitpick [card = 2, expect = none]
+nitpick [card = 3\<midarrow>5, expect = genuine]
+oops
+
+lemma "P x \<Longrightarrow> P (The P)"
+nitpick [card = 1, expect = none]
+nitpick [card = 1\<midarrow>2, expect = none]
+nitpick [card = 3\<midarrow>5, expect = genuine]
+nitpick [card = 8, expect = genuine]
+oops
+
+lemma "(\<forall>x. \<not> P x) \<longrightarrow> The P = y"
+nitpick [expect = genuine]
+oops
+
+lemma "I = (\<lambda>x. x) \<Longrightarrow> The = (\<lambda>x. The (I x))"
+nitpick [card = 1\<midarrow>5, expect = none]
+by auto
+
+lemma "x = Eps"
+nitpick [card = 5, expect = genuine]
+oops
+
+lemma "\<exists>x. x = Eps"
+nitpick [card = 1\<midarrow>3, expect = none]
+by auto
+
+lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> Eps P = x"
+nitpick [expect = none]
+by auto
+
+lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> Eps P = z"
+nitpick [expect = genuine]
+apply auto
+oops
+
+lemma "P x \<Longrightarrow> P (Eps P)"
+nitpick [card = 1\<midarrow>8, expect = none]
+by (metis exE_some)
+
+lemma "\<forall>x. \<not> P x \<longrightarrow> Eps P = y"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Eps P)"
+nitpick [expect = genuine]
+oops
+
+lemma "(P\<Colon>nat set) (Eps P)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> P (Eps P)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> (P\<Colon>nat set) (Eps P)"
+nitpick [expect = genuine]
+oops
+
+lemma "P \<noteq> {} \<Longrightarrow> P (Eps P)"
+nitpick [expect = none]
+sorry
+
+lemma "(P\<Colon>nat set) \<noteq> {} \<Longrightarrow> P (Eps P)"
+nitpick [expect = none]
+sorry
+
+lemma "P (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "(P\<Colon>nat set) (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> P (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> (P\<Colon>nat set) (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "The P \<noteq> x"
+nitpick [expect = genuine]
+oops
+
+lemma "The P \<noteq> (x\<Colon>nat)"
+nitpick [expect = genuine]
+oops
+
+lemma "P x \<Longrightarrow> P (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (x\<Colon>nat) \<Longrightarrow> P (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "P = {x} \<Longrightarrow> P (The P)"
+nitpick [expect = none]
+oops
+
+lemma "P = {x\<Colon>nat} \<Longrightarrow> P (The P)"
+nitpick [expect = none]
+oops
+
+consts Q :: 'a
+
+lemma "Q (Eps Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "(Q\<Colon>nat set) (Eps Q)"
+nitpick [expect = none]
+oops
+
+lemma "\<not> Q (Eps Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> (Q\<Colon>nat set) (Eps Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "(Q\<Colon>'a set) \<noteq> {} \<Longrightarrow> (Q\<Colon>'a set) (Eps Q)"
+nitpick [expect = none]
+sorry
+
+lemma "(Q\<Colon>nat set) \<noteq> {} \<Longrightarrow> (Q\<Colon>nat set) (Eps Q)"
+nitpick [expect = none]
+sorry
+
+lemma "Q (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "(Q\<Colon>nat set) (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> Q (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> (Q\<Colon>nat set) (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "The Q \<noteq> x"
+nitpick [expect = genuine]
+oops
+
+lemma "The Q \<noteq> (x\<Colon>nat)"
+nitpick [expect = genuine]
+oops
+
+lemma "Q x \<Longrightarrow> Q (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "Q (x\<Colon>nat) \<Longrightarrow> Q (The Q)"
+nitpick [expect = genuine]
+oops
+
+lemma "Q = {x\<Colon>'a} \<Longrightarrow> (Q\<Colon>'a set) (The Q)"
+nitpick [expect = none]
+oops
+
+lemma "Q = {x\<Colon>nat} \<Longrightarrow> (Q\<Colon>nat set) (The Q)"
+nitpick [expect = none]
+oops
+
+subsection {* Destructors and Recursors *}
+
+lemma "(x\<Colon>'a) = (case True of True \<Rightarrow> x | False \<Rightarrow> x)"
+nitpick [card = 2, expect = none]
+by auto
+
+lemma "bool_rec x y True = x"
+nitpick [card = 2, expect = none]
+by auto
+
+lemma "bool_rec x y False = y"
+nitpick [card = 2, expect = none]
+by auto
+
+lemma "(x\<Colon>bool) = bool_rec x x True"
+nitpick [card = 2, expect = none]
+by auto
+
+lemma "x = (case (x, y) of (x', y') \<Rightarrow> x')"
+nitpick [expect = none]
+sorry
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Datatype_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,104 @@
+(* Title: HOL/Nitpick_Examples/Datatype_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick applied to datatypes.
+*)
+
+header {* Examples Featuring Nitpick Applied to Datatypes *}
+
+theory Datatype_Nits
+imports Main
+begin
+
+primrec rot where
+"rot Nibble0 = Nibble1" |
+"rot Nibble1 = Nibble2" |
+"rot Nibble2 = Nibble3" |
+"rot Nibble3 = Nibble4" |
+"rot Nibble4 = Nibble5" |
+"rot Nibble5 = Nibble6" |
+"rot Nibble6 = Nibble7" |
+"rot Nibble7 = Nibble8" |
+"rot Nibble8 = Nibble9" |
+"rot Nibble9 = NibbleA" |
+"rot NibbleA = NibbleB" |
+"rot NibbleB = NibbleC" |
+"rot NibbleC = NibbleD" |
+"rot NibbleD = NibbleE" |
+"rot NibbleE = NibbleF" |
+"rot NibbleF = Nibble0"
+
+lemma "rot n \<noteq> n"
+nitpick [card = 1\<midarrow>16, expect = none]
+sorry
+
+lemma "rot Nibble2 \<noteq> Nibble3"
+nitpick [card = 1, expect = none]
+nitpick [card = 2, expect = genuine]
+nitpick [card = 2, max Nibble2 = 0, expect = none]
+nitpick [card = 2, max Nibble3 = 0, expect = none]
+oops
+
+lemma "(rot ^^ 15) n \<noteq> n"
+nitpick [card = 17, expect = none]
+sorry
+
+lemma "(rot ^^ 15) n = n"
+nitpick [card = 17, expect = genuine]
+oops
+
+lemma "(rot ^^ 16) n = n"
+nitpick [card = 17, expect = none]
+oops
+
+datatype ('a, 'b) pd = Pd "'a \<times> 'b"
+
+fun fs where
+"fs (Pd (a, _)) = a"
+
+fun sn where
+"sn (Pd (_, b)) = b"
+
+lemma "fs (Pd p) = fst p"
+nitpick [card = 20, expect = none]
+sorry
+
+lemma "fs (Pd p) = snd p"
+nitpick [expect = genuine]
+oops
+
+lemma "sn (Pd p) = snd p"
+nitpick [card = 20, expect = none]
+sorry
+
+lemma "sn (Pd p) = fst p"
+nitpick [expect = genuine]
+oops
+
+lemma "fs (Pd ((a, b), (c, d))) = (a, b)"
+nitpick [card = 1\<midarrow>12, expect = none]
+sorry
+
+lemma "fs (Pd ((a, b), (c, d))) = (c, d)"
+nitpick [expect = genuine]
+oops
+
+datatype ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"
+
+fun app where
+"app (Fn f) x = f x"
+
+lemma "app (Fn g) y = g y"
+nitpick [card = 1\<midarrow>12, expect = none]
+sorry
+
+lemma "app (Fn g) y = g' y"
+nitpick [expect = genuine]
+oops
+
+lemma "app (Fn g) y = g y'"
+nitpick [expect = genuine]
+oops
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Induct_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,171 @@
+(* Title: HOL/Nitpick_Examples/Induct_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick applied to (co)inductive definitions.
+*)
+
+header {* Examples Featuring Nitpick Applied to (Co)inductive Definitions *}
+
+theory Induct_Nits
+imports Main
+begin
+
+nitpick_params [show_all]
+
+inductive p1 :: "nat \<Rightarrow> bool" where
+"p1 0" |
+"p1 n \<Longrightarrow> p1 (n + 2)"
+
+coinductive q1 :: "nat \<Rightarrow> bool" where
+"q1 0" |
+"q1 n \<Longrightarrow> q1 (n + 2)"
+
+lemma "p1 = q1"
+nitpick [expect = none]
+nitpick [wf, expect = none]
+nitpick [non_wf, expect = none]
+nitpick [non_wf, dont_star_linear_preds, expect = none]
+oops
+
+lemma "p1 \<noteq> q1"
+nitpick [expect = potential]
+nitpick [wf, expect = potential]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_star_linear_preds, expect = potential]
+oops
+
+lemma "p1 (n - 2) \<Longrightarrow> p1 n"
+nitpick [expect = genuine]
+nitpick [non_wf, expect = genuine]
+nitpick [non_wf, dont_star_linear_preds, expect = genuine]
+oops
+
+lemma "q1 (n - 2) \<Longrightarrow> q1 n"
+nitpick [expect = genuine]
+nitpick [non_wf, expect = genuine]
+nitpick [non_wf, dont_star_linear_preds, expect = genuine]
+oops
+
+inductive p2 :: "nat \<Rightarrow> bool" where
+"p2 n \<Longrightarrow> p2 n"
+
+coinductive q2 :: "nat \<Rightarrow> bool" where
+"q2 n \<Longrightarrow> q2 n"
+
+lemma "p2 = {}"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+sorry
+
+lemma "q2 = {}"
+nitpick [expect = genuine]
+nitpick [dont_star_linear_preds, expect = genuine]
+nitpick [wf, expect = likely_genuine]
+oops
+
+lemma "p2 = UNIV"
+nitpick [expect = genuine]
+nitpick [dont_star_linear_preds, expect = genuine]
+oops
+
+lemma "q2 = UNIV"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+nitpick [wf, expect = likely_genuine]
+sorry
+
+lemma "p2 = q2"
+nitpick [expect = genuine]
+nitpick [dont_star_linear_preds, expect = genuine]
+oops
+
+lemma "p2 n"
+nitpick [expect = genuine]
+nitpick [dont_star_linear_preds, expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+lemma "q2 n"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+sorry
+
+lemma "\<not> p2 n"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+sorry
+
+lemma "\<not> q2 n"
+nitpick [expect = genuine]
+nitpick [dont_star_linear_preds, expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+inductive p3 and p4 where
+"p3 0" |
+"p3 n \<Longrightarrow> p4 (Suc n)" |
+"p4 n \<Longrightarrow> p3 (Suc n)"
+
+coinductive q3 and q4 where
+"q3 0" |
+"q3 n \<Longrightarrow> q4 (Suc n)" |
+"q4 n \<Longrightarrow> q3 (Suc n)"
+
+lemma "p3 = q3"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_box, expect = none]
+nitpick [non_wf, dont_star_linear_preds, expect = none]
+sorry
+
+lemma "p4 = q4"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_box, expect = none]
+nitpick [non_wf, dont_star_linear_preds, expect = none]
+sorry
+
+lemma "p3 = UNIV - p4"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_box, expect = none]
+nitpick [non_wf, dont_star_linear_preds, expect = none]
+sorry
+
+lemma "q3 = UNIV - q4"
+nitpick [expect = none]
+nitpick [dont_star_linear_preds, expect = none]
+nitpick [non_wf, expect = none]
+nitpick [non_wf, dont_box, expect = none]
+nitpick [non_wf, dont_star_linear_preds, expect = none]
+sorry
+
+lemma "p3 \<inter> q4 \<noteq> {}"
+nitpick [expect = potential]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_star_linear_preds, expect = potential]
+sorry
+
+lemma "q3 \<inter> p4 \<noteq> {}"
+nitpick [expect = potential]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_star_linear_preds, expect = potential]
+sorry
+
+lemma "p3 \<union> q4 \<noteq> UNIV"
+nitpick [expect = potential]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_star_linear_preds, expect = potential]
+sorry
+
+lemma "q3 \<union> p4 \<noteq> UNIV"
+nitpick [expect = potential]
+nitpick [non_wf, expect = potential]
+nitpick [non_wf, dont_star_linear_preds, expect = potential]
+sorry
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Manual_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,389 @@
+(* Title: HOL/Nitpick_Examples/Manual_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples from the Nitpick manual.
+*)
+
+header {* Examples from the Nitpick Manual *}
+
+theory Manual_Nits
+imports Main Coinductive_List RealDef
+begin
+
+chapter {* 3. First Steps *}
+
+nitpick_params [sat_solver = MiniSatJNI, max_threads = 1]
+
+subsection {* 3.1. Propositional Logic *}
+
+lemma "P \<longleftrightarrow> Q"
+nitpick
+apply auto
+nitpick 1
+nitpick 2
+oops
+
+subsection {* 3.2. Type Variables *}
+
+lemma "P x \<Longrightarrow> P (THE y. P y)"
+nitpick [verbose]
+oops
+
+subsection {* 3.3. Constants *}
+
+lemma "P x \<Longrightarrow> P (THE y. P y)"
+nitpick [show_consts]
+nitpick [full_descrs, show_consts]
+nitpick [dont_specialize, full_descrs, show_consts]
+oops
+
+lemma "\<exists>!x. P x \<Longrightarrow> P (THE y. P y)"
+nitpick
+nitpick [card 'a = 1-50]
+(* sledgehammer *)
+apply (metis the_equality)
+done
+
+subsection {* 3.4. Skolemization *}
+
+lemma "\<exists>g. \<forall>x. g (f x) = x \<Longrightarrow> \<forall>y. \<exists>x. y = f x"
+nitpick
+oops
+
+lemma "\<exists>x. \<forall>f. f x = x"
+nitpick
+oops
+
+lemma "refl r \<Longrightarrow> sym r"
+nitpick
+oops
+
+subsection {* 3.5. Numbers *}
+
+lemma "\<lbrakk>i \<le> j; n \<le> (m\<Colon>int)\<rbrakk> \<Longrightarrow> i * n + j * m \<le> i * m + j * n"
+nitpick
+oops
+
+lemma "\<forall>n. Suc n \<noteq> n \<Longrightarrow> P"
+nitpick [card nat = 100, check_potential]
+oops
+
+lemma "P Suc"
+nitpick [card = 1-6]
+oops
+
+lemma "P (op +\<Colon>nat\<Rightarrow>nat\<Rightarrow>nat)"
+nitpick [card nat = 1]
+nitpick [card nat = 2]
+oops
+
+subsection {* 3.6. Inductive Datatypes *}
+
+lemma "hd (xs @ [y, y]) = hd xs"
+nitpick
+nitpick [show_consts, show_datatypes]
+oops
+
+lemma "\<lbrakk>length xs = 1; length ys = 1\<rbrakk> \<Longrightarrow> xs = ys"
+nitpick [show_datatypes]
+oops
+
+subsection {* 3.7. Typedefs, Records, Rationals, and Reals *}
+
+typedef three = "{0\<Colon>nat, 1, 2}"
+by blast
+
+definition A :: three where "A \<equiv> Abs_three 0"
+definition B :: three where "B \<equiv> Abs_three 1"
+definition C :: three where "C \<equiv> Abs_three 2"
+
+lemma "\<lbrakk>P A; P B\<rbrakk> \<Longrightarrow> P x"
+nitpick [show_datatypes]
+oops
+
+record point =
+ Xcoord :: int
+ Ycoord :: int
+
+lemma "Xcoord (p\<Colon>point) = Xcoord (q\<Colon>point)"
+nitpick [show_datatypes]
+oops
+
+lemma "4 * x + 3 * (y\<Colon>real) \<noteq> 1 / 2"
+nitpick [show_datatypes]
+oops
+
+subsection {* 3.8. Inductive and Coinductive Predicates *}
+
+inductive even where
+"even 0" |
+"even n \<Longrightarrow> even (Suc (Suc n))"
+
+lemma "\<exists>n. even n \<and> even (Suc n)"
+nitpick [card nat = 100, verbose]
+oops
+
+lemma "\<exists>n \<le> 99. even n \<and> even (Suc n)"
+nitpick [card nat = 100]
+oops
+
+inductive even' where
+"even' (0\<Colon>nat)" |
+"even' 2" |
+"\<lbrakk>even' m; even' n\<rbrakk> \<Longrightarrow> even' (m + n)"
+
+lemma "\<exists>n \<in> {0, 2, 4, 6, 8}. \<not> even' n"
+nitpick [card nat = 10, verbose, show_consts]
+oops
+
+lemma "even' (n - 2) \<Longrightarrow> even' n"
+nitpick [card nat = 10, show_consts]
+oops
+
+coinductive nats where
+"nats (x\<Colon>nat) \<Longrightarrow> nats x"
+
+lemma "nats = {0, 1, 2, 3, 4}"
+nitpick [card nat = 10, show_consts]
+oops
+
+inductive odd where
+"odd 1" |
+"\<lbrakk>odd m; even n\<rbrakk> \<Longrightarrow> odd (m + n)"
+
+lemma "odd n \<Longrightarrow> odd (n - 2)"
+nitpick [card nat = 10, show_consts]
+oops
+
+subsection {* 3.9. Coinductive Datatypes *}
+
+lemma "xs \<noteq> LCons a xs"
+nitpick
+oops
+
+lemma "\<lbrakk>xs = LCons a xs; ys = iterates (\<lambda>b. a) b\<rbrakk> \<Longrightarrow> xs = ys"
+nitpick [verbose]
+nitpick [bisim_depth = -1, verbose]
+oops
+
+lemma "\<lbrakk>xs = LCons a xs; ys = LCons a ys\<rbrakk> \<Longrightarrow> xs = ys"
+nitpick [bisim_depth = -1, show_datatypes]
+nitpick
+sorry
+
+subsection {* 3.10. Boxing *}
+
+datatype tm = Var nat | Lam tm | App tm tm
+
+primrec lift where
+"lift (Var j) k = Var (if j < k then j else j + 1)" |
+"lift (Lam t) k = Lam (lift t (k + 1))" |
+"lift (App t u) k = App (lift t k) (lift u k)"
+
+primrec loose where
+"loose (Var j) k = (j \<ge> k)" |
+"loose (Lam t) k = loose t (Suc k)" |
+"loose (App t u) k = (loose t k \<or> loose u k)"
+
+primrec subst\<^isub>1 where
+"subst\<^isub>1 \<sigma> (Var j) = \<sigma> j" |
+"subst\<^isub>1 \<sigma> (Lam t) =
+ Lam (subst\<^isub>1 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 1) t)" |
+"subst\<^isub>1 \<sigma> (App t u) = App (subst\<^isub>1 \<sigma> t) (subst\<^isub>1 \<sigma> u)"
+
+lemma "\<not> loose t 0 \<Longrightarrow> subst\<^isub>1 \<sigma> t = t"
+nitpick [verbose]
+nitpick [eval = "subst\<^isub>1 \<sigma> t"]
+nitpick [dont_box]
+oops
+
+primrec subst\<^isub>2 where
+"subst\<^isub>2 \<sigma> (Var j) = \<sigma> j" |
+"subst\<^isub>2 \<sigma> (Lam t) =
+ Lam (subst\<^isub>2 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 0) t)" |
+"subst\<^isub>2 \<sigma> (App t u) = App (subst\<^isub>2 \<sigma> t) (subst\<^isub>2 \<sigma> u)"
+
+lemma "\<not> loose t 0 \<Longrightarrow> subst\<^isub>2 \<sigma> t = t"
+nitpick
+sorry
+
+subsection {* 3.11. Scope Monotonicity *}
+
+lemma "length xs = length ys \<Longrightarrow> rev (zip xs ys) = zip xs (rev ys)"
+nitpick [verbose]
+nitpick [card = 8, verbose]
+oops
+
+lemma "\<exists>g. \<forall>x\<Colon>'b. g (f x) = x \<Longrightarrow> \<forall>y\<Colon>'a. \<exists>x. y = f x"
+nitpick [mono]
+nitpick
+oops
+
+section {* 4. Case Studies *}
+
+nitpick_params [max_potential = 0, max_threads = 2]
+
+subsection {* 4.1. A Context-Free Grammar *}
+
+datatype alphabet = a | b
+
+inductive_set S\<^isub>1 and A\<^isub>1 and B\<^isub>1 where
+ "[] \<in> S\<^isub>1"
+| "w \<in> A\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
+| "w \<in> B\<^isub>1 \<Longrightarrow> a # w \<in> S\<^isub>1"
+| "w \<in> S\<^isub>1 \<Longrightarrow> a # w \<in> A\<^isub>1"
+| "w \<in> S\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
+| "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
+
+theorem S\<^isub>1_sound:
+"w \<in> S\<^isub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+nitpick
+oops
+
+inductive_set S\<^isub>2 and A\<^isub>2 and B\<^isub>2 where
+ "[] \<in> S\<^isub>2"
+| "w \<in> A\<^isub>2 \<Longrightarrow> b # w \<in> S\<^isub>2"
+| "w \<in> B\<^isub>2 \<Longrightarrow> a # w \<in> S\<^isub>2"
+| "w \<in> S\<^isub>2 \<Longrightarrow> a # w \<in> A\<^isub>2"
+| "w \<in> S\<^isub>2 \<Longrightarrow> b # w \<in> B\<^isub>2"
+| "\<lbrakk>v \<in> B\<^isub>2; v \<in> B\<^isub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>2"
+
+theorem S\<^isub>2_sound:
+"w \<in> S\<^isub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+nitpick
+oops
+
+inductive_set S\<^isub>3 and A\<^isub>3 and B\<^isub>3 where
+ "[] \<in> S\<^isub>3"
+| "w \<in> A\<^isub>3 \<Longrightarrow> b # w \<in> S\<^isub>3"
+| "w \<in> B\<^isub>3 \<Longrightarrow> a # w \<in> S\<^isub>3"
+| "w \<in> S\<^isub>3 \<Longrightarrow> a # w \<in> A\<^isub>3"
+| "w \<in> S\<^isub>3 \<Longrightarrow> b # w \<in> B\<^isub>3"
+| "\<lbrakk>v \<in> B\<^isub>3; w \<in> B\<^isub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>3"
+
+theorem S\<^isub>3_sound:
+"w \<in> S\<^isub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+nitpick
+sorry
+
+theorem S\<^isub>3_complete:
+"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>3"
+nitpick
+oops
+
+inductive_set S\<^isub>4 and A\<^isub>4 and B\<^isub>4 where
+ "[] \<in> S\<^isub>4"
+| "w \<in> A\<^isub>4 \<Longrightarrow> b # w \<in> S\<^isub>4"
+| "w \<in> B\<^isub>4 \<Longrightarrow> a # w \<in> S\<^isub>4"
+| "w \<in> S\<^isub>4 \<Longrightarrow> a # w \<in> A\<^isub>4"
+| "\<lbrakk>v \<in> A\<^isub>4; w \<in> A\<^isub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^isub>4"
+| "w \<in> S\<^isub>4 \<Longrightarrow> b # w \<in> B\<^isub>4"
+| "\<lbrakk>v \<in> B\<^isub>4; w \<in> B\<^isub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>4"
+
+theorem S\<^isub>4_sound:
+"w \<in> S\<^isub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+nitpick
+sorry
+
+theorem S\<^isub>4_complete:
+"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>4"
+nitpick
+sorry
+
+theorem S\<^isub>4_A\<^isub>4_B\<^isub>4_sound_and_complete:
+"w \<in> S\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+"w \<in> A\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] + 1"
+"w \<in> B\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = b] = length [x \<leftarrow> w. x = a] + 1"
+nitpick
+sorry
+
+subsection {* 4.2. AA Trees *}
+
+datatype 'a tree = \<Lambda> | N "'a\<Colon>linorder" nat "'a tree" "'a tree"
+
+primrec data where
+"data \<Lambda> = undefined" |
+"data (N x _ _ _) = x"
+
+primrec dataset where
+"dataset \<Lambda> = {}" |
+"dataset (N x _ t u) = {x} \<union> dataset t \<union> dataset u"
+
+primrec level where
+"level \<Lambda> = 0" |
+"level (N _ k _ _) = k"
+
+primrec left where
+"left \<Lambda> = \<Lambda>" |
+"left (N _ _ t\<^isub>1 _) = t\<^isub>1"
+
+primrec right where
+"right \<Lambda> = \<Lambda>" |
+"right (N _ _ _ t\<^isub>2) = t\<^isub>2"
+
+fun wf where
+"wf \<Lambda> = True" |
+"wf (N _ k t u) =
+ (if t = \<Lambda> then
+ k = 1 \<and> (u = \<Lambda> \<or> (level u = 1 \<and> left u = \<Lambda> \<and> right u = \<Lambda>))
+ else
+ wf t \<and> wf u \<and> u \<noteq> \<Lambda> \<and> level t < k \<and> level u \<le> k \<and> level (right u) < k)"
+
+fun skew where
+"skew \<Lambda> = \<Lambda>" |
+"skew (N x k t u) =
+ (if t \<noteq> \<Lambda> \<and> k = level t then
+ N (data t) k (left t) (N x k (right t) u)
+ else
+ N x k t u)"
+
+fun split where
+"split \<Lambda> = \<Lambda>" |
+"split (N x k t u) =
+ (if u \<noteq> \<Lambda> \<and> k = level (right u) then
+ N (data u) (Suc k) (N x k t (left u)) (right u)
+ else
+ N x k t u)"
+
+theorem dataset_skew_split:
+"dataset (skew t) = dataset t"
+"dataset (split t) = dataset t"
+nitpick
+sorry
+
+theorem wf_skew_split:
+"wf t \<Longrightarrow> skew t = t"
+"wf t \<Longrightarrow> split t = t"
+nitpick
+sorry
+
+primrec insort\<^isub>1 where
+"insort\<^isub>1 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
+"insort\<^isub>1 (N y k t u) x =
+ (* (split \<circ> skew) *) (N y k (if x < y then insort\<^isub>1 t x else t)
+ (if x > y then insort\<^isub>1 u x else u))"
+
+theorem wf_insort\<^isub>1: "wf t \<Longrightarrow> wf (insort\<^isub>1 t x)"
+nitpick
+oops
+
+theorem wf_insort\<^isub>1_nat: "wf t \<Longrightarrow> wf (insort\<^isub>1 t (x\<Colon>nat))"
+nitpick [eval = "insort\<^isub>1 t x"]
+oops
+
+primrec insort\<^isub>2 where
+"insort\<^isub>2 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
+"insort\<^isub>2 (N y k t u) x =
+ (split \<circ> skew) (N y k (if x < y then insort\<^isub>2 t x else t)
+ (if x > y then insort\<^isub>2 u x else u))"
+
+theorem wf_insort\<^isub>2: "wf t \<Longrightarrow> wf (insort\<^isub>2 t x)"
+nitpick
+sorry
+
+theorem dataset_insort\<^isub>2: "dataset (insort\<^isub>2 t x) = {x} \<union> dataset t"
+nitpick
+sorry
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Mini_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,107 @@
+(* Title: HOL/Nitpick_Examples/Mini_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Minipick, the minimalistic version of Nitpick.
+*)
+
+header {* Examples Featuring Minipick, the Minimalistic Version of Nitpick *}
+
+theory Mini_Nits
+imports Main
+begin
+
+ML {*
+exception FAIL
+
+(* int -> term -> string *)
+fun minipick 0 _ = "none"
+ | minipick n t =
+ case minipick (n - 1) t of
+ "none" => Minipick.pick_nits_in_term @{context} (K n) t
+ | outcome_code => outcome_code
+(* int -> term -> bool *)
+fun none n t = (minipick n t = "none" orelse raise FAIL)
+fun genuine n t = (minipick n t = "genuine" orelse raise FAIL)
+fun unknown n t = (minipick n t = "unknown" orelse raise FAIL)
+*}
+
+ML {* minipick 1 @{prop "\<forall>x\<Colon>'a. \<exists>y\<Colon>'b. f x = y"} *}
+
+ML {* genuine 1 @{prop "x = Not"} *}
+ML {* none 1 @{prop "\<exists>x. x = Not"} *}
+ML {* none 1 @{prop "\<not> False"} *}
+ML {* genuine 1 @{prop "\<not> True"} *}
+ML {* none 1 @{prop "\<not> \<not> b \<longleftrightarrow> b"} *}
+ML {* none 1 @{prop True} *}
+ML {* genuine 1 @{prop False} *}
+ML {* genuine 1 @{prop "True \<longleftrightarrow> False"} *}
+ML {* none 1 @{prop "True \<longleftrightarrow> \<not> False"} *}
+ML {* none 5 @{prop "\<forall>x. x = x"} *}
+ML {* none 5 @{prop "\<exists>x. x = x"} *}
+ML {* none 1 @{prop "\<forall>x. x = y"} *}
+ML {* genuine 2 @{prop "\<forall>x. x = y"} *}
+ML {* none 1 @{prop "\<exists>x. x = y"} *}
+ML {* none 2 @{prop "\<exists>x. x = y"} *}
+ML {* none 2 @{prop "\<forall>x\<Colon>'a \<times> 'a. x = x"} *}
+ML {* none 2 @{prop "\<exists>x\<Colon>'a \<times> 'a. x = y"} *}
+ML {* genuine 2 @{prop "\<forall>x\<Colon>'a \<times> 'a. x = y"} *}
+ML {* none 2 @{prop "\<exists>x\<Colon>'a \<times> 'a. x = y"} *}
+ML {* none 1 @{prop "All = Ex"} *}
+ML {* genuine 2 @{prop "All = Ex"} *}
+ML {* none 1 @{prop "All P = Ex P"} *}
+ML {* genuine 2 @{prop "All P = Ex P"} *}
+ML {* none 5 @{prop "x = y \<longrightarrow> P x = P y"} *}
+ML {* none 5 @{prop "(x\<Colon>'a \<times> 'a) = y \<longrightarrow> P x = P y"} *}
+ML {* none 2 @{prop "(x\<Colon>'a \<times> 'a) = y \<longrightarrow> P x y = P y x"} *}
+ML {* none 5 @{prop "\<exists>x\<Colon>'a \<times> 'a. x = y \<longrightarrow> P x = P y"} *}
+ML {* none 2 @{prop "(x\<Colon>'a \<Rightarrow> 'a) = y \<longrightarrow> P x = P y"} *}
+ML {* none 2 @{prop "\<exists>x\<Colon>'a \<Rightarrow> 'a. x = y \<longrightarrow> P x = P y"} *}
+ML {* genuine 1 @{prop "(op =) X = Ex"} *}
+ML {* none 2 @{prop "\<forall>x::'a \<Rightarrow> 'a. x = x"} *}
+ML {* none 1 @{prop "x = y"} *}
+ML {* genuine 1 @{prop "x \<longleftrightarrow> y"} *}
+ML {* genuine 2 @{prop "x = y"} *}
+ML {* genuine 1 @{prop "X \<subseteq> Y"} *}
+ML {* none 1 @{prop "P \<and> Q \<longleftrightarrow> Q \<and> P"} *}
+ML {* none 1 @{prop "P \<and> Q \<longrightarrow> P"} *}
+ML {* none 1 @{prop "P \<or> Q \<longleftrightarrow> Q \<or> P"} *}
+ML {* genuine 1 @{prop "P \<or> Q \<longrightarrow> P"} *}
+ML {* none 1 @{prop "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)"} *}
+ML {* none 5 @{prop "{a} = {a, a}"} *}
+ML {* genuine 2 @{prop "{a} = {a, b}"} *}
+ML {* genuine 1 @{prop "{a} \<noteq> {a, b}"} *}
+ML {* none 5 @{prop "{}\<^sup>+ = {}"} *}
+ML {* none 1 @{prop "{(a, b), (b, c)}\<^sup>+ = {(a, b), (a, c), (b, c)}"} *}
+ML {* genuine 2 @{prop "{(a, b), (b, c)}\<^sup>+ = {(a, b), (a, c), (b, c)}"} *}
+ML {* none 5 @{prop "a \<noteq> c \<Longrightarrow> {(a, b), (b, c)}\<^sup>+ = {(a, b), (a, c), (b, c)}"} *}
+ML {* none 5 @{prop "A \<union> B = (\<lambda>x. A x \<or> B x)"} *}
+ML {* none 5 @{prop "A \<inter> B = (\<lambda>x. A x \<and> B x)"} *}
+ML {* none 5 @{prop "A - B = (\<lambda>x. A x \<and> \<not> B x)"} *}
+ML {* none 5 @{prop "\<exists>a b. (a, b) = (b, a)"} *}
+ML {* genuine 2 @{prop "(a, b) = (b, a)"} *}
+ML {* genuine 2 @{prop "(a, b) \<noteq> (b, a)"} *}
+ML {* none 5 @{prop "\<exists>a b\<Colon>'a \<times> 'a. (a, b) = (b, a)"} *}
+ML {* genuine 2 @{prop "(a\<Colon>'a \<times> 'a, b) = (b, a)"} *}
+ML {* none 5 @{prop "\<exists>a b\<Colon>'a \<times> 'a \<times> 'a. (a, b) = (b, a)"} *}
+ML {* genuine 2 @{prop "(a\<Colon>'a \<times> 'a \<times> 'a, b) \<noteq> (b, a)"} *}
+ML {* none 5 @{prop "\<exists>a b\<Colon>'a \<Rightarrow> 'a. (a, b) = (b, a)"} *}
+ML {* genuine 1 @{prop "(a\<Colon>'a \<Rightarrow> 'a, b) \<noteq> (b, a)"} *}
+ML {* none 8 @{prop "fst (a, b) = a"} *}
+ML {* none 1 @{prop "fst (a, b) = b"} *}
+ML {* genuine 2 @{prop "fst (a, b) = b"} *}
+ML {* genuine 2 @{prop "fst (a, b) \<noteq> b"} *}
+ML {* none 8 @{prop "snd (a, b) = b"} *}
+ML {* none 1 @{prop "snd (a, b) = a"} *}
+ML {* genuine 2 @{prop "snd (a, b) = a"} *}
+ML {* genuine 2 @{prop "snd (a, b) \<noteq> a"} *}
+ML {* genuine 1 @{prop P} *}
+ML {* genuine 1 @{prop "(\<lambda>x. P) a"} *}
+ML {* genuine 1 @{prop "(\<lambda>x y z. P y x z) a b c"} *}
+ML {* none 5 @{prop "\<exists>f. f = (\<lambda>x. x) \<and> f y = y"} *}
+ML {* genuine 1 @{prop "\<exists>f. f p \<noteq> p \<and> (\<forall>a b. f (a, b) = (a, b))"} *}
+ML {* none 2 @{prop "\<exists>f. \<forall>a b. f (a, b) = (a, b)"} *}
+ML {* none 3 @{prop "f = (\<lambda>a b. (b, a)) \<longrightarrow> f x y = (y, x)"} *}
+ML {* genuine 2 @{prop "f = (\<lambda>a b. (b, a)) \<longrightarrow> f x y = (x, y)"} *}
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Mono_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,98 @@
+(* Title: HOL/Nitpick_Examples/Mono_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick's monotonicity check.
+*)
+
+header {* Examples Featuring Nitpick's Monotonicity Check *}
+
+theory Mono_Nits
+imports Main
+begin
+
+ML {*
+exception FAIL
+
+val defs = NitpickHOL.all_axioms_of @{theory} |> #1
+val def_table = NitpickHOL.const_def_table @{context} defs
+val ext_ctxt =
+ {thy = @{theory}, ctxt = @{context}, max_bisim_depth = ~1, boxes = [],
+ user_axioms = NONE, debug = false, wfs = [], destroy_constrs = false,
+ specialize = false, skolemize = false, star_linear_preds = false,
+ uncurry = false, fast_descrs = false, tac_timeout = NONE, evals = [],
+ case_names = [], def_table = def_table, nondef_table = Symtab.empty,
+ user_nondefs = [], simp_table = Unsynchronized.ref Symtab.empty,
+ psimp_table = Symtab.empty, intro_table = Symtab.empty,
+ ground_thm_table = Inttab.empty, ersatz_table = [],
+ skolems = Unsynchronized.ref [], special_funs = Unsynchronized.ref [],
+ unrolled_preds = Unsynchronized.ref [], wf_cache = Unsynchronized.ref []}
+(* term -> bool *)
+val is_mono = NitpickMono.formulas_monotonic ext_ctxt @{typ 'a} [] []
+fun is_const t =
+ let val T = fastype_of t in
+ is_mono (Logic.mk_implies (Logic.mk_equals (Free ("dummyP", T), t),
+ @{const False}))
+ end
+fun mono t = is_mono t orelse raise FAIL
+fun nonmono t = not (is_mono t) orelse raise FAIL
+fun const t = is_const t orelse raise FAIL
+fun nonconst t = not (is_const t) orelse raise FAIL
+*}
+
+ML {* const @{term "A::('a\<Rightarrow>'b)"} *}
+ML {* const @{term "(A::'a set) = A"} *}
+ML {* const @{term "(A::'a set set) = A"} *}
+ML {* const @{term "(\<lambda>x::'a set. x a)"} *}
+ML {* const @{term "{{a}} = C"} *}
+ML {* const @{term "{f::'a\<Rightarrow>nat} = {g::'a\<Rightarrow>nat}"} *}
+ML {* const @{term "A \<union> B"} *}
+ML {* const @{term "P (a::'a)"} *}
+ML {* const @{term "\<lambda>a::'a. b (c (d::'a)) (e::'a) (f::'a)"} *}
+ML {* const @{term "\<forall>A::'a set. A a"} *}
+ML {* const @{term "\<forall>A::'a set. P A"} *}
+ML {* const @{term "P \<or> Q"} *}
+ML {* const @{term "A \<union> B = C"} *}
+ML {* const @{term "(if P then (A::'a set) else B) = C"} *}
+ML {* const @{term "let A = C in A \<union> B"} *}
+ML {* const @{term "THE x::'b. P x"} *}
+ML {* const @{term "{}::'a set"} *}
+ML {* const @{term "(\<lambda>x::'a. True)"} *}
+ML {* const @{term "Let a A"} *}
+ML {* const @{term "A (a::'a)"} *}
+ML {* const @{term "insert a A = B"} *}
+ML {* const @{term "- (A::'a set)"} *}
+ML {* const @{term "finite A"} *}
+ML {* const @{term "\<not> finite A"} *}
+ML {* const @{term "finite (A::'a set set)"} *}
+ML {* const @{term "\<lambda>a::'a. A a \<and> \<not> B a"} *}
+ML {* const @{term "A < (B::'a set)"} *}
+ML {* const @{term "A \<le> (B::'a set)"} *}
+ML {* const @{term "[a::'a]"} *}
+ML {* const @{term "[a::'a set]"} *}
+ML {* const @{term "[A \<union> (B::'a set)]"} *}
+ML {* const @{term "[A \<union> (B::'a set)] = [C]"} *}
+ML {* const @{term "\<forall>P. P a"} *}
+
+ML {* nonconst @{term "{%x. True}"} *}
+ML {* nonconst @{term "{(%x. x = a)} = C"} *}
+ML {* nonconst @{term "\<forall>P (a::'a). P a"} *}
+ML {* nonconst @{term "\<forall>a::'a. P a"} *}
+ML {* nonconst @{term "(\<lambda>a::'a. \<not> A a) = B"} *}
+ML {* nonconst @{term "THE x. P x"} *}
+ML {* nonconst @{term "SOME x. P x"} *}
+
+ML {* mono @{prop "Q (\<forall>x::'a set. P x)"} *}
+ML {* mono @{prop "P (a::'a)"} *}
+ML {* mono @{prop "{a} = {b}"} *}
+ML {* mono @{prop "P (a::'a) \<and> P \<union> P = P"} *}
+ML {* mono @{prop "\<forall>F::'a set set. P"} *}
+ML {* mono @{prop "\<not> (\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> f a \<and> g a \<longrightarrow> F h)"} *}
+ML {* mono @{prop "\<not> Q (\<forall>x::'a set. P x)"} *}
+ML {* mono @{prop "\<not> (\<forall>x. P x)"} *}
+
+ML {* nonmono @{prop "\<forall>x. P x"} *}
+ML {* nonmono @{prop "\<forall>F f g (h::'a set). F f \<and> F g \<and> \<not> f a \<and> g a \<longrightarrow> F h"} *}
+ML {* nonmono @{prop "myall P = (P = (\<lambda>x. True))"} *}
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Nitpick_Examples.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,14 @@
+(* Title: HOL/Nitpick_Examples/Nitpick_Examples.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Nitpick examples.
+*)
+
+theory Nitpick_Examples
+imports Core_Nits Datatype_Nits Induct_Nits Manual_Nits Mini_Nits Mono_Nits
+ Pattern_Nits Record_Nits Refute_Nits Special_Nits Tests_Nits
+ Typedef_Nits
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Pattern_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,138 @@
+(* Title: HOL/Nitpick_Examples/Pattern_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick's "destroy_constrs" optimization.
+*)
+
+header {* Examples Featuring Nitpick's \textit{destroy\_constrs} Optimization *}
+
+theory Pattern_Nits
+imports Main
+begin
+
+nitpick_params [card = 14]
+
+lemma "x = (case u of () \<Rightarrow> y)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case b of True \<Rightarrow> x | False \<Rightarrow> y)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case p of (x, y) \<Rightarrow> y)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> n)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case opt of None \<Rightarrow> x | Some y \<Rightarrow> y)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case xs of [] \<Rightarrow> x | y # ys \<Rightarrow> y)"
+nitpick [expect = genuine]
+oops
+
+lemma "x = (case xs of
+ [] \<Rightarrow> x
+ | y # ys \<Rightarrow>
+ (case ys of
+ [] \<Rightarrow> x
+ | z # zs \<Rightarrow>
+ (case z of
+ None \<Rightarrow> x
+ | Some p \<Rightarrow>
+ (case p of
+ (a, b) \<Rightarrow> b))))"
+nitpick [expect = genuine]
+oops
+
+fun f1 where
+"f1 x () = x"
+
+lemma "x = f1 y u"
+nitpick [expect = genuine]
+oops
+
+fun f2 where
+"f2 x _ True = x" |
+"f2 _ y False = y"
+
+lemma "x = f2 x y b"
+nitpick [expect = genuine]
+oops
+
+fun f3 where
+"f3 (_, y) = y"
+
+lemma "x = f3 p"
+nitpick [expect = genuine]
+oops
+
+fun f4 where
+"f4 x 0 = x" |
+"f4 _ (Suc n) = n"
+
+lemma "x = f4 x n"
+nitpick [expect = genuine]
+oops
+
+fun f5 where
+"f5 x None = x" |
+"f5 _ (Some y) = y"
+
+lemma "x = f5 x opt"
+nitpick [expect = genuine]
+oops
+
+fun f6 where
+"f6 x [] = x" |
+"f6 _ (y # ys) = y"
+
+lemma "x = f6 x xs"
+nitpick [expect = genuine]
+oops
+
+fun f7 where
+"f7 _ (y # Some (a, b) # zs) = b" |
+"f7 x (y # None # zs) = x" |
+"f7 x [y] = x" |
+"f7 x [] = x"
+
+lemma "x = f7 x xs"
+nitpick [expect = genuine]
+oops
+
+lemma "u = ()"
+nitpick [expect = none]
+sorry
+
+lemma "\<exists>y. (b::bool) = y"
+nitpick [expect = none]
+sorry
+
+lemma "\<exists>x y. p = (x, y)"
+nitpick [expect = none]
+sorry
+
+lemma "\<exists>x. n = Suc x"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>y. x = Some y"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>y ys. xs = y # ys"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>y a b zs. x = (y # Some (a, b) # zs)"
+nitpick [expect = genuine]
+oops
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/ROOT.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,8 @@
+(* Title: HOL/Nitpick_Examples/ROOT.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Nitpick examples.
+*)
+
+setmp_noncritical quick_and_dirty true (try use_thy) "Nitpick_Examples";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Record_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,84 @@
+(* Title: HOL/Nitpick_Examples/Record_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick applied to records.
+*)
+
+header {* Examples Featuring Nitpick Applied to Records *}
+
+theory Record_Nits
+imports Main
+begin
+
+record point2d =
+ xc :: int
+ yc :: int
+
+lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x, yc := y\<rparr>"
+nitpick [expect = none]
+sorry
+
+lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y\<rparr> \<noteq> p"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y\<rparr> = p"
+nitpick [expect = genuine]
+oops
+
+record point3d = point2d +
+ zc :: int
+
+lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x, yc := y, zc := z\<rparr>"
+nitpick [expect = none]
+sorry
+
+lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>zc := z\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> \<noteq> p"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> = p"
+nitpick [expect = genuine]
+oops
+
+record point4d = point3d +
+ wc :: int
+
+lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr>"
+nitpick [expect = none]
+sorry
+
+lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>zc := z\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>wc := w\<rparr>"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> \<noteq> p"
+nitpick [expect = genuine]
+oops
+
+lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> = p"
+nitpick [expect = genuine]
+oops
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Refute_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1476 @@
+(* Title: HOL/Nitpick_Examples/Refute_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Refute examples adapted to Nitpick.
+*)
+
+header {* Refute Examples Adapted to Nitpick *}
+
+theory Refute_Nits
+imports Main
+begin
+
+lemma "P \<and> Q"
+apply (rule conjI)
+nitpick [expect = genuine] 1
+nitpick [expect = genuine] 2
+nitpick [expect = genuine]
+nitpick [card = 5, expect = genuine]
+nitpick [sat_solver = MiniSat, expect = genuine] 2
+oops
+
+subsection {* Examples and Test Cases *}
+
+subsubsection {* Propositional logic *}
+
+lemma "True"
+nitpick [expect = none]
+apply auto
+done
+
+lemma "False"
+nitpick [expect = genuine]
+oops
+
+lemma "P"
+nitpick [expect = genuine]
+oops
+
+lemma "\<not> P"
+nitpick [expect = genuine]
+oops
+
+lemma "P \<and> Q"
+nitpick [expect = genuine]
+oops
+
+lemma "P \<or> Q"
+nitpick [expect = genuine]
+oops
+
+lemma "P \<longrightarrow> Q"
+nitpick [expect = genuine]
+oops
+
+lemma "(P\<Colon>bool) = Q"
+nitpick [expect = genuine]
+oops
+
+lemma "(P \<or> Q) \<longrightarrow> (P \<and> Q)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Predicate logic *}
+
+lemma "P x y z"
+nitpick [expect = genuine]
+oops
+
+lemma "P x y \<longrightarrow> P y x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Equality *}
+
+lemma "P = True"
+nitpick [expect = genuine]
+oops
+
+lemma "P = False"
+nitpick [expect = genuine]
+oops
+
+lemma "x = y"
+nitpick [expect = genuine]
+oops
+
+lemma "f x = g x"
+nitpick [expect = genuine]
+oops
+
+lemma "(f\<Colon>'a\<Rightarrow>'b) = g"
+nitpick [expect = genuine]
+oops
+
+lemma "(f\<Colon>('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
+nitpick [expect = genuine]
+oops
+
+lemma "distinct [a, b]"
+nitpick [expect = genuine]
+apply simp
+nitpick [expect = genuine]
+oops
+
+subsubsection {* First-Order Logic *}
+
+lemma "\<exists>x. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>!x. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex P"
+nitpick [expect = genuine]
+oops
+
+lemma "All P"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex1 P"
+nitpick [expect = genuine]
+oops
+
+lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
+nitpick [expect = genuine]
+oops
+
+lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
+nitpick [expect = genuine]
+oops
+
+lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
+nitpick [expect = genuine]
+oops
+
+text {* A true statement (also testing names of free and bound variables being identical) *}
+
+lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
+nitpick [expect = none]
+apply fast
+done
+
+text {* "A type has at most 4 elements." *}
+
+lemma "\<not> distinct [a, b, c, d, e]"
+nitpick [expect = genuine]
+apply simp
+nitpick [expect = genuine]
+oops
+
+lemma "distinct [a, b, c, d]"
+nitpick [expect = genuine]
+apply simp
+nitpick [expect = genuine]
+oops
+
+text {* "Every reflexive and symmetric relation is transitive." *}
+
+lemma "\<lbrakk>\<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x\<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
+nitpick [expect = genuine]
+oops
+
+text {* The "Drinker's theorem" ... *}
+
+lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
+nitpick [expect = none]
+apply (auto simp add: ext)
+done
+
+text {* ... and an incorrect version of it *}
+
+lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
+nitpick [expect = genuine]
+oops
+
+text {* "Every function has a fixed point." *}
+
+lemma "\<exists>x. f x = x"
+nitpick [expect = genuine]
+oops
+
+text {* "Function composition is commutative." *}
+
+lemma "f (g x) = g (f x)"
+nitpick [expect = genuine]
+oops
+
+text {* "Two functions that are equivalent wrt.\ the same predicate 'P' are equal." *}
+
+lemma "((P\<Colon>('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Higher-Order Logic *}
+
+lemma "\<exists>P. P"
+nitpick [expect = none]
+apply auto
+done
+
+lemma "\<forall>P. P"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>!P. P"
+nitpick [expect = none]
+apply auto
+done
+
+lemma "\<exists>!P. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P Q \<or> Q x"
+nitpick [expect = genuine]
+oops
+
+lemma "x \<noteq> All"
+nitpick [expect = genuine]
+oops
+
+lemma "x \<noteq> Ex"
+nitpick [expect = genuine]
+oops
+
+lemma "x \<noteq> Ex1"
+nitpick [expect = genuine]
+oops
+
+text {* "The transitive closure 'T' of an arbitrary relation 'P' is non-empty." *}
+
+constdefs
+"trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
+"trans P \<equiv> (ALL x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"
+"subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
+"subset P Q \<equiv> (ALL x y. P x y \<longrightarrow> Q x y)"
+"trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
+"trans_closure P Q \<equiv> (subset Q P) \<and> (trans P) \<and> (ALL R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"
+
+lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
+nitpick [expect = genuine]
+oops
+
+text {* "The union of transitive closures is equal to the transitive closure of unions." *}
+
+lemma "(\<forall>x y. (P x y \<or> R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y \<or> R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
+ \<longrightarrow> trans_closure TP P
+ \<longrightarrow> trans_closure TR R
+ \<longrightarrow> (T x y = (TP x y \<or> TR x y))"
+nitpick [expect = genuine]
+oops
+
+text {* "Every surjective function is invertible." *}
+
+lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
+nitpick [expect = genuine]
+oops
+
+text {* "Every invertible function is surjective." *}
+
+lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
+nitpick [expect = genuine]
+oops
+
+text {* Every point is a fixed point of some function. *}
+
+lemma "\<exists>f. f x = x"
+nitpick [card = 1\<midarrow>7, expect = none]
+apply (rule_tac x = "\<lambda>x. x" in exI)
+apply simp
+done
+
+text {* Axiom of Choice: first an incorrect version ... *}
+
+lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
+nitpick [expect = genuine]
+oops
+
+text {* ... and now two correct ones *}
+
+lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
+nitpick [card = 1-5, expect = none]
+apply (simp add: choice)
+done
+
+lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
+nitpick [card = 1-4, expect = none]
+apply auto
+ apply (simp add: ex1_implies_ex choice)
+apply (fast intro: ext)
+done
+
+subsubsection {* Metalogic *}
+
+lemma "\<And>x. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "f x \<equiv> g x"
+nitpick [expect = genuine]
+oops
+
+lemma "P \<Longrightarrow> Q"
+nitpick [expect = genuine]
+oops
+
+lemma "\<lbrakk>P; Q; R\<rbrakk> \<Longrightarrow> S"
+nitpick [expect = genuine]
+oops
+
+lemma "(x \<equiv> all) \<Longrightarrow> False"
+nitpick [expect = genuine]
+oops
+
+lemma "(x \<equiv> (op \<equiv>)) \<Longrightarrow> False"
+nitpick [expect = genuine]
+oops
+
+lemma "(x \<equiv> (op \<Longrightarrow>)) \<Longrightarrow> False"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Schematic Variables *}
+
+lemma "?P"
+nitpick [expect = none]
+apply auto
+done
+
+lemma "x = ?y"
+nitpick [expect = none]
+apply auto
+done
+
+subsubsection {* Abstractions *}
+
+lemma "(\<lambda>x. x) = (\<lambda>x. y)"
+nitpick [expect = genuine]
+oops
+
+lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
+nitpick [expect = genuine]
+oops
+
+lemma "(\<lambda>x. x) = (\<lambda>y. y)"
+nitpick [expect = none]
+apply simp
+done
+
+subsubsection {* Sets *}
+
+lemma "P (A\<Colon>'a set)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (A\<Colon>'a set set)"
+nitpick [expect = genuine]
+oops
+
+lemma "{x. P x} = {y. P y}"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "x \<in> {x. P x}"
+nitpick [expect = genuine]
+oops
+
+lemma "P (op \<in>)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (op \<in> x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P Collect"
+nitpick [expect = genuine]
+oops
+
+lemma "A Un B = A Int B"
+nitpick [expect = genuine]
+oops
+
+lemma "(A Int B) Un C = (A Un C) Int B"
+nitpick [expect = genuine]
+oops
+
+lemma "Ball A P \<longrightarrow> Bex A P"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* @{const undefined} *}
+
+lemma "undefined"
+nitpick [expect = genuine]
+oops
+
+lemma "P undefined"
+nitpick [expect = genuine]
+oops
+
+lemma "undefined x"
+nitpick [expect = genuine]
+oops
+
+lemma "undefined undefined"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* @{const The} *}
+
+lemma "The P"
+nitpick [expect = genuine]
+oops
+
+lemma "P The"
+nitpick [expect = genuine]
+oops
+
+lemma "P (The P)"
+nitpick [expect = genuine]
+oops
+
+lemma "(THE x. x=y) = z"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex P \<longrightarrow> P (The P)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* @{const Eps} *}
+
+lemma "Eps P"
+nitpick [expect = genuine]
+oops
+
+lemma "P Eps"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Eps P)"
+nitpick [expect = genuine]
+oops
+
+lemma "(SOME x. x=y) = z"
+nitpick [expect = genuine]
+oops
+
+lemma "Ex P \<longrightarrow> P (Eps P)"
+nitpick [expect = none]
+apply (auto simp add: someI)
+done
+
+subsubsection {* Operations on Natural Numbers *}
+
+lemma "(x\<Colon>nat) + y = 0"
+nitpick [expect = genuine]
+oops
+
+lemma "(x\<Colon>nat) = x + x"
+nitpick [expect = genuine]
+oops
+
+lemma "(x\<Colon>nat) - y + y = x"
+nitpick [expect = genuine]
+oops
+
+lemma "(x\<Colon>nat) = x * x"
+nitpick [expect = genuine]
+oops
+
+lemma "(x\<Colon>nat) < x + y"
+nitpick [card = 1, expect = genuine]
+nitpick [card = 2-5, expect = genuine]
+oops
+
+text {* \<times> *}
+
+lemma "P (x\<Colon>'a\<times>'b)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a\<times>'b. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (x, y)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (fst x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (snd x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P Pair"
+nitpick [expect = genuine]
+oops
+
+lemma "prod_rec f p = f (fst p) (snd p)"
+nitpick [expect = none]
+by (case_tac p) auto
+
+lemma "prod_rec f (a, b) = f a b"
+nitpick [expect = none]
+by auto
+
+lemma "P (prod_rec f x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Pair a b \<Rightarrow> f a b)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Subtypes (typedef), typedecl *}
+
+text {* A completely unspecified non-empty subset of @{typ "'a"}: *}
+
+typedef 'a myTdef = "insert (undefined\<Colon>'a) (undefined\<Colon>'a set)"
+by auto
+
+lemma "(x\<Colon>'a myTdef) = y"
+nitpick [expect = genuine]
+oops
+
+typedecl myTdecl
+
+typedef 'a T_bij = "{(f\<Colon>'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"
+by auto
+
+lemma "P (f\<Colon>(myTdecl myTdef) T_bij)"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Inductive Datatypes *}
+
+text {* unit *}
+
+lemma "P (x\<Colon>unit)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>unit. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P ()"
+nitpick [expect = genuine]
+oops
+
+lemma "unit_rec u x = u"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (unit_rec u x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of () \<Rightarrow> u)"
+nitpick [expect = genuine]
+oops
+
+text {* option *}
+
+lemma "P (x\<Colon>'a option)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a option. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P None"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Some x)"
+nitpick [expect = genuine]
+oops
+
+lemma "option_rec n s None = n"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "option_rec n s (Some x) = s x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (option_rec n s x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
+nitpick [expect = genuine]
+oops
+
+text {* + *}
+
+lemma "P (x\<Colon>'a+'b)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a+'b. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Inl x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Inr x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P Inl"
+nitpick [expect = genuine]
+oops
+
+lemma "sum_rec l r (Inl x) = l x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "sum_rec l r (Inr x) = r x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (sum_rec l r x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
+nitpick [expect = genuine]
+oops
+
+text {* Non-recursive datatypes *}
+
+datatype T1 = A | B
+
+lemma "P (x\<Colon>T1)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>T1. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P A"
+nitpick [expect = genuine]
+oops
+
+lemma "P B"
+nitpick [expect = genuine]
+oops
+
+lemma "T1_rec a b A = a"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "T1_rec a b B = b"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (T1_rec a b x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
+nitpick [expect = genuine]
+oops
+
+datatype 'a T2 = C T1 | D 'a
+
+lemma "P (x\<Colon>'a T2)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a T2. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P D"
+nitpick [expect = genuine]
+oops
+
+lemma "T2_rec c d (C x) = c x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "T2_rec c d (D x) = d x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (T2_rec c d x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
+nitpick [expect = genuine]
+oops
+
+datatype ('a, 'b) T3 = E "'a \<Rightarrow> 'b"
+
+lemma "P (x\<Colon>('a, 'b) T3)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>('a, 'b) T3. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P E"
+nitpick [expect = genuine]
+oops
+
+lemma "T3_rec e (E x) = e x"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "P (T3_rec e x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of E f \<Rightarrow> e f)"
+nitpick [expect = genuine]
+oops
+
+text {* Recursive datatypes *}
+
+text {* nat *}
+
+lemma "P (x\<Colon>nat)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>nat. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Suc 0)"
+nitpick [expect = genuine]
+oops
+
+lemma "P Suc"
+nitpick [card = 1\<midarrow>7, expect = none]
+oops
+
+lemma "nat_rec zero suc 0 = zero"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "nat_rec zero suc (Suc x) = suc x (nat_rec zero suc x)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (nat_rec zero suc x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
+nitpick [expect = genuine]
+oops
+
+text {* 'a list *}
+
+lemma "P (xs\<Colon>'a list)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>xs\<Colon>'a list. P xs"
+nitpick [expect = genuine]
+oops
+
+lemma "P [x, y]"
+nitpick [expect = genuine]
+oops
+
+lemma "list_rec nil cons [] = nil"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "list_rec nil cons (x#xs) = cons x xs (list_rec nil cons xs)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (list_rec nil cons xs)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
+nitpick [expect = genuine]
+oops
+
+lemma "(xs\<Colon>'a list) = ys"
+nitpick [expect = genuine]
+oops
+
+lemma "a # xs = b # xs"
+nitpick [expect = genuine]
+oops
+
+datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList
+
+lemma "P (x\<Colon>BitList)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>BitList. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Bit0 (Bit1 BitListNil))"
+nitpick [expect = genuine]
+oops
+
+lemma "BitList_rec nil bit0 bit1 BitListNil = nil"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "BitList_rec nil bit0 bit1 (Bit0 xs) = bit0 xs (BitList_rec nil bit0 bit1 xs)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "BitList_rec nil bit0 bit1 (Bit1 xs) = bit1 xs (BitList_rec nil bit0 bit1 xs)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (BitList_rec nil bit0 bit1 x)"
+nitpick [expect = genuine]
+oops
+
+datatype 'a BinTree = Leaf 'a | Node "'a BinTree" "'a BinTree"
+
+lemma "P (x\<Colon>'a BinTree)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a BinTree. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Node (Leaf x) (Leaf y))"
+nitpick [expect = genuine]
+oops
+
+lemma "BinTree_rec l n (Leaf x) = l x"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "BinTree_rec l n (Node x y) = n x y (BinTree_rec l n x) (BinTree_rec l n y)"
+nitpick [card = 1\<midarrow>6, expect = none]
+apply simp
+done
+
+lemma "P (BinTree_rec l n x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Leaf a \<Rightarrow> l a | Node a b \<Rightarrow> n a b)"
+nitpick [expect = genuine]
+oops
+
+text {* Mutually recursive datatypes *}
+
+datatype 'a aexp = Number 'a | ITE "'a bexp" "'a aexp" "'a aexp"
+ and 'a bexp = Equal "'a aexp" "'a aexp"
+
+lemma "P (x\<Colon>'a aexp)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a aexp. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (ITE (Equal (Number x) (Number y)) (Number x) (Number y))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (x\<Colon>'a bexp)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a bexp. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "aexp_bexp_rec_1 number ite equal (Number x) = number x"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "aexp_bexp_rec_1 number ite equal (ITE x y z) = ite x y z (aexp_bexp_rec_2 number ite equal x) (aexp_bexp_rec_1 number ite equal y) (aexp_bexp_rec_1 number ite equal z)"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "P (aexp_bexp_rec_1 number ite equal x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Number a \<Rightarrow> number a | ITE b a1 a2 \<Rightarrow> ite b a1 a2)"
+nitpick [expect = genuine]
+oops
+
+lemma "aexp_bexp_rec_2 number ite equal (Equal x y) = equal x y (aexp_bexp_rec_1 number ite equal x) (aexp_bexp_rec_1 number ite equal y)"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "P (aexp_bexp_rec_2 number ite equal x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (case x of Equal a1 a2 \<Rightarrow> equal a1 a2)"
+nitpick [expect = genuine]
+oops
+
+datatype X = A | B X | C Y
+ and Y = D X | E Y | F
+
+lemma "P (x\<Colon>X)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (y\<Colon>Y)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (B (B A))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (B (C F))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (C (D A))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (C (E F))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (D (B A))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (D (C F))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (E (D A))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (E (E F))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (C (D (C F)))"
+nitpick [expect = genuine]
+oops
+
+lemma "X_Y_rec_1 a b c d e f A = a"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "X_Y_rec_1 a b c d e f (B x) = b x (X_Y_rec_1 a b c d e f x)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "X_Y_rec_1 a b c d e f (C y) = c y (X_Y_rec_2 a b c d e f y)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "X_Y_rec_2 a b c d e f (D x) = d x (X_Y_rec_1 a b c d e f x)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "X_Y_rec_2 a b c d e f (E y) = e y (X_Y_rec_2 a b c d e f y)"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "X_Y_rec_2 a b c d e f F = f"
+nitpick [expect = none]
+apply simp
+done
+
+lemma "P (X_Y_rec_1 a b c d e f x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (X_Y_rec_2 a b c d e f y)"
+nitpick [expect = genuine]
+oops
+
+text {* Other datatype examples *}
+
+text {* Indirect recursion is implemented via mutual recursion. *}
+
+datatype XOpt = CX "XOpt option" | DX "bool \<Rightarrow> XOpt option"
+
+lemma "P (x\<Colon>XOpt)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (CX None)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (CX (Some (CX None)))"
+nitpick [expect = genuine]
+oops
+
+lemma "XOpt_rec_1 cx dx n1 s1 n2 s2 (CX x) = cx x (XOpt_rec_2 cx dx n1 s1 n2 s2 x)"
+nitpick [card = 1\<midarrow>6, expect = none]
+apply simp
+done
+
+lemma "XOpt_rec_1 cx dx n1 s1 n2 s2 (DX x) = dx x (\<lambda>b. XOpt_rec_3 cx dx n1 s1 n2 s2 (x b))"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "XOpt_rec_2 cx dx n1 s1 n2 s2 None = n1"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "XOpt_rec_2 cx dx n1 s1 n2 s2 (Some x) = s1 x (XOpt_rec_1 cx dx n1 s1 n2 s2 x)"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "XOpt_rec_3 cx dx n1 s1 n2 s2 None = n2"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "XOpt_rec_3 cx dx n1 s1 n2 s2 (Some x) = s2 x (XOpt_rec_1 cx dx n1 s1 n2 s2 x)"
+nitpick [card = 1\<midarrow>4, expect = none]
+apply simp
+done
+
+lemma "P (XOpt_rec_1 cx dx n1 s1 n2 s2 x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (XOpt_rec_2 cx dx n1 s1 n2 s2 x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (XOpt_rec_3 cx dx n1 s1 n2 s2 x)"
+nitpick [expect = genuine]
+oops
+
+datatype 'a YOpt = CY "('a \<Rightarrow> 'a YOpt) option"
+
+lemma "P (x\<Colon>'a YOpt)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (CY None)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (CY (Some (\<lambda>a. CY None)))"
+nitpick [expect = genuine]
+oops
+
+lemma "YOpt_rec_1 cy n s (CY x) = cy x (YOpt_rec_2 cy n s x)"
+nitpick [card = 1\<midarrow>2, expect = none]
+apply simp
+done
+
+lemma "YOpt_rec_2 cy n s None = n"
+nitpick [card = 1\<midarrow>2, expect = none]
+apply simp
+done
+
+lemma "YOpt_rec_2 cy n s (Some x) = s x (\<lambda>a. YOpt_rec_1 cy n s (x a))"
+nitpick [card = 1\<midarrow>2, expect = none]
+apply simp
+done
+
+lemma "P (YOpt_rec_1 cy n s x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (YOpt_rec_2 cy n s x)"
+nitpick [expect = genuine]
+oops
+
+datatype Trie = TR "Trie list"
+
+lemma "P (x\<Colon>Trie)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>Trie. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (TR [TR []])"
+nitpick [expect = genuine]
+oops
+
+lemma "Trie_rec_1 tr nil cons (TR x) = tr x (Trie_rec_2 tr nil cons x)"
+nitpick [card = 1\<midarrow>6, expect = none]
+apply simp
+done
+
+lemma "Trie_rec_2 tr nil cons [] = nil"
+nitpick [card = 1\<midarrow>6, expect = none]
+apply simp
+done
+
+lemma "Trie_rec_2 tr nil cons (x#xs) = cons x xs (Trie_rec_1 tr nil cons x) (Trie_rec_2 tr nil cons xs)"
+nitpick [card = 1\<midarrow>6, expect = none]
+apply simp
+done
+
+lemma "P (Trie_rec_1 tr nil cons x)"
+nitpick [card = 1, expect = genuine]
+oops
+
+lemma "P (Trie_rec_2 tr nil cons x)"
+nitpick [card = 1, expect = genuine]
+oops
+
+datatype InfTree = Leaf | Node "nat \<Rightarrow> InfTree"
+
+lemma "P (x\<Colon>InfTree)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>InfTree. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Node (\<lambda>n. Leaf))"
+nitpick [expect = genuine]
+oops
+
+lemma "InfTree_rec leaf node Leaf = leaf"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "InfTree_rec leaf node (Node x) = node x (\<lambda>n. InfTree_rec leaf node (x n))"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "P (InfTree_rec leaf node x)"
+nitpick [expect = genuine]
+oops
+
+datatype 'a lambda = Var 'a | App "'a lambda" "'a lambda" | Lam "'a \<Rightarrow> 'a lambda"
+
+lemma "P (x\<Colon>'a lambda)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'a lambda. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (Lam (\<lambda>a. Var a))"
+nitpick [card = 1\<midarrow>5, expect = none]
+nitpick [card 'a = 4, card "'a lambda" = 5, expect = genuine]
+oops
+
+lemma "lambda_rec var app lam (Var x) = var x"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "lambda_rec var app lam (App x y) = app x y (lambda_rec var app lam x) (lambda_rec var app lam y)"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "lambda_rec var app lam (Lam x) = lam x (\<lambda>a. lambda_rec var app lam (x a))"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "P (lambda_rec v a l x)"
+nitpick [expect = genuine]
+oops
+
+text {* Taken from "Inductive datatypes in HOL", p. 8: *}
+
+datatype ('a, 'b) T = C "'a \<Rightarrow> bool" | D "'b list"
+datatype 'c U = E "('c, 'c U) T"
+
+lemma "P (x\<Colon>'c U)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<forall>x\<Colon>'c U. P x"
+nitpick [expect = genuine]
+oops
+
+lemma "P (E (C (\<lambda>a. True)))"
+nitpick [expect = genuine]
+oops
+
+lemma "U_rec_1 e c d nil cons (E x) = e x (U_rec_2 e c d nil cons x)"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "U_rec_2 e c d nil cons (C x) = c x"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "U_rec_2 e c d nil cons (D x) = d x (U_rec_3 e c d nil cons x)"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "U_rec_3 e c d nil cons [] = nil"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "U_rec_3 e c d nil cons (x#xs) = cons x xs (U_rec_1 e c d nil cons x) (U_rec_3 e c d nil cons xs)"
+nitpick [card = 1\<midarrow>3, expect = none]
+apply simp
+done
+
+lemma "P (U_rec_1 e c d nil cons x)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (U_rec_2 e c d nil cons x)"
+nitpick [card = 1, expect = genuine]
+oops
+
+lemma "P (U_rec_3 e c d nil cons x)"
+nitpick [card = 1, expect = genuine]
+oops
+
+subsubsection {* Records *}
+
+record ('a, 'b) point =
+ xpos :: 'a
+ ypos :: 'b
+
+lemma "(x\<Colon>('a, 'b) point) = y"
+nitpick [expect = genuine]
+oops
+
+record ('a, 'b, 'c) extpoint = "('a, 'b) point" +
+ ext :: 'c
+
+lemma "(x\<Colon>('a, 'b, 'c) extpoint) = y"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Inductively Defined Sets *}
+
+inductive_set undefinedSet :: "'a set" where
+"undefined \<in> undefinedSet"
+
+lemma "x \<in> undefinedSet"
+nitpick [expect = genuine]
+oops
+
+inductive_set evenCard :: "'a set set"
+where
+"{} \<in> evenCard" |
+"\<lbrakk>S \<in> evenCard; x \<notin> S; y \<notin> S; x \<noteq> y\<rbrakk> \<Longrightarrow> S \<union> {x, y} \<in> evenCard"
+
+lemma "S \<in> evenCard"
+nitpick [expect = genuine]
+oops
+
+inductive_set
+even :: "nat set"
+and odd :: "nat set"
+where
+"0 \<in> even" |
+"n \<in> even \<Longrightarrow> Suc n \<in> odd" |
+"n \<in> odd \<Longrightarrow> Suc n \<in> even"
+
+lemma "n \<in> odd"
+nitpick [expect = genuine]
+oops
+
+consts f :: "'a \<Rightarrow> 'a"
+
+inductive_set a_even :: "'a set" and a_odd :: "'a set" where
+"undefined \<in> a_even" |
+"x \<in> a_even \<Longrightarrow> f x \<in> a_odd" |
+"x \<in> a_odd \<Longrightarrow> f x \<in> a_even"
+
+lemma "x \<in> a_odd"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Examples Involving Special Functions *}
+
+lemma "card x = 0"
+nitpick [expect = genuine]
+oops
+
+lemma "finite x"
+nitpick [expect = none]
+oops
+
+lemma "xs @ [] = ys @ []"
+nitpick [expect = genuine]
+oops
+
+lemma "xs @ ys = ys @ xs"
+nitpick [expect = genuine]
+oops
+
+lemma "f (lfp f) = lfp f"
+nitpick [expect = genuine]
+oops
+
+lemma "f (gfp f) = gfp f"
+nitpick [expect = genuine]
+oops
+
+lemma "lfp f = gfp f"
+nitpick [expect = genuine]
+oops
+
+subsubsection {* Axiomatic Type Classes and Overloading *}
+
+text {* A type class without axioms: *}
+
+axclass classA
+
+lemma "P (x\<Colon>'a\<Colon>classA)"
+nitpick [expect = genuine]
+oops
+
+text {* The axiom of this type class does not contain any type variables: *}
+
+axclass classB
+classB_ax: "P \<or> \<not> P"
+
+lemma "P (x\<Colon>'a\<Colon>classB)"
+nitpick [expect = genuine]
+oops
+
+text {* An axiom with a type variable (denoting types which have at least two elements): *}
+
+axclass classC < type
+classC_ax: "\<exists>x y. x \<noteq> y"
+
+lemma "P (x\<Colon>'a\<Colon>classC)"
+nitpick [expect = genuine]
+oops
+
+lemma "\<exists>x y. (x\<Colon>'a\<Colon>classC) \<noteq> y"
+nitpick [expect = none]
+sorry
+
+text {* A type class for which a constant is defined: *}
+
+consts
+classD_const :: "'a \<Rightarrow> 'a"
+
+axclass classD < type
+classD_ax: "classD_const (classD_const x) = classD_const x"
+
+lemma "P (x\<Colon>'a\<Colon>classD)"
+nitpick [expect = genuine]
+oops
+
+text {* A type class with multiple superclasses: *}
+
+axclass classE < classC, classD
+
+lemma "P (x\<Colon>'a\<Colon>classE)"
+nitpick [expect = genuine]
+oops
+
+lemma "P (x\<Colon>'a\<Colon>{classB, classE})"
+nitpick [expect = genuine]
+oops
+
+text {* OFCLASS: *}
+
+lemma "OFCLASS('a\<Colon>type, type_class)"
+nitpick [expect = none]
+apply intro_classes
+done
+
+lemma "OFCLASS('a\<Colon>classC, type_class)"
+nitpick [expect = none]
+apply intro_classes
+done
+
+lemma "OFCLASS('a, classB_class)"
+nitpick [expect = none]
+apply intro_classes
+apply simp
+done
+
+lemma "OFCLASS('a\<Colon>type, classC_class)"
+nitpick [expect = genuine]
+oops
+
+text {* Overloading: *}
+
+consts inverse :: "'a \<Rightarrow> 'a"
+
+defs (overloaded)
+inverse_bool: "inverse (b\<Colon>bool) \<equiv> \<not> b"
+inverse_set: "inverse (S\<Colon>'a set) \<equiv> -S"
+inverse_pair: "inverse p \<equiv> (inverse (fst p), inverse (snd p))"
+
+lemma "inverse b"
+nitpick [expect = genuine]
+oops
+
+lemma "P (inverse (S\<Colon>'a set))"
+nitpick [expect = genuine]
+oops
+
+lemma "P (inverse (p\<Colon>'a\<times>'b))"
+nitpick [expect = genuine]
+oops
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Special_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,172 @@
+(* Title: HOL/Nitpick_Examples/Special_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick's "specialize" optimization.
+*)
+
+header {* Examples Featuring Nitpick's \textit{specialize} Optimization *}
+
+theory Special_Nits
+imports Main
+begin
+
+nitpick_params [card = 4, debug, show_consts, timeout = 10 s]
+
+fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+"f1 a b c d e = a + b + c + d + e"
+
+lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "f1 u v w x y = f1 y x w v u"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+"f2 a b c d (Suc e) = a + b + c + d + e"
+
+lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
+nitpick [expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+"f3 (Suc a) b 0 d (Suc e) = a + b + d + e" |
+"f3 0 b 0 d 0 = b + d"
+
+lemma "f3 a b c d e = f3 e d c b a"
+nitpick [expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+lemma "f3 a b c d a = f3 a d c d a"
+nitpick [expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u)
+ \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+nitpick [dont_skolemize, expect = none]
+nitpick [dont_specialize, dont_skolemize, expect = none]
+sorry
+
+function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+"f4 x x = 1" |
+"f4 y z = (if y = z then 1 else 0)"
+by auto
+termination by lexicographic_order
+
+lemma "f4 a b = f4 b a"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "f4 a (Suc a) = f4 a a"
+nitpick [expect = genuine]
+nitpick [dont_specialize, expect = genuine]
+oops
+
+fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
+"f5 f (Suc a) = f a"
+
+lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
+ f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
+ f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
+ f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
+nitpick [expect = genuine]
+sorry
+
+lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
+ f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
+nitpick [expect = genuine]
+sorry
+
+lemma "\<forall>a. g a = a
+ \<Longrightarrow> \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x =
+ f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
+nitpick [expect = none]
+nitpick [dont_specialize, expect = none]
+sorry
+
+lemma "\<forall>a. g a = a
+ \<Longrightarrow> \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x =
+ f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
+nitpick [expect = potential]
+nitpick [dont_specialize, expect = potential]
+sorry
+
+lemma "\<forall>a. g a = a
+ \<Longrightarrow> \<exists>b\<^isub>1 b\<^isub>2 b\<^isub>3 b\<^isub>4 b\<^isub>5 b\<^isub>6 b\<^isub>7 b\<^isub>8 b\<^isub>9 b\<^isub>10 (b\<^isub>11\<Colon>nat).
+ b\<^isub>1 < b\<^isub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^isub>1 < b\<^isub>11 then a else h b\<^isub>2) x"
+nitpick [expect = potential]
+nitpick [dont_specialize, expect = none]
+nitpick [dont_box, expect = none]
+nitpick [dont_box, dont_specialize, expect = none]
+sorry
+
+lemma "\<forall>a. g a = a
+ \<Longrightarrow> \<exists>b\<^isub>1 b\<^isub>2 b\<^isub>3 b\<^isub>4 b\<^isub>5 b\<^isub>6 b\<^isub>7 b\<^isub>8 b\<^isub>9 b\<^isub>10 (b\<^isub>11\<Colon>nat).
+ b\<^isub>1 < b\<^isub>11
+ \<and> f5 g x = f5 (\<lambda>a. if b\<^isub>1 < b\<^isub>11 then
+ a
+ else
+ h b\<^isub>2 + h b\<^isub>3 + h b\<^isub>4 + h b\<^isub>5 + h b\<^isub>6 + h b\<^isub>7 + h b\<^isub>8
+ + h b\<^isub>9 + h b\<^isub>10) x"
+nitpick [card nat = 2, card 'a = 1, expect = none]
+nitpick [card nat = 2, card 'a = 1, dont_box, expect = none]
+nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = none]
+nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize, expect = none]
+sorry
+
+lemma "\<forall>a. g a = a
+ \<Longrightarrow> \<exists>b\<^isub>1 b\<^isub>2 b\<^isub>3 b\<^isub>4 b\<^isub>5 b\<^isub>6 b\<^isub>7 b\<^isub>8 b\<^isub>9 b\<^isub>10 (b\<^isub>11\<Colon>nat).
+ b\<^isub>1 < b\<^isub>11
+ \<and> f5 g x = f5 (\<lambda>a. if b\<^isub>1 \<ge> b\<^isub>11 then
+ a
+ else
+ h b\<^isub>2 + h b\<^isub>3 + h b\<^isub>4 + h b\<^isub>5 + h b\<^isub>6 + h b\<^isub>7 + h b\<^isub>8
+ + h b\<^isub>9 + h b\<^isub>10) x"
+nitpick [card nat = 2, card 'a = 1, expect = none]
+nitpick [card nat = 2, card 'a = 1, dont_box, expect = potential]
+nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = potential]
+nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize,
+ expect = potential]
+oops
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Tests_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,16 @@
+(* Title: HOL/Nitpick_Examples/Tests_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Nitpick tests.
+*)
+
+header {* Nitpick Tests *}
+
+theory Tests_Nits
+imports Main
+begin
+
+ML {* NitpickTests.run_all_tests () *}
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Typedef_Nits.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,187 @@
+(* Title: HOL/Nitpick_Examples/Typedef_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Examples featuring Nitpick applied to typedefs.
+*)
+
+header {* Examples Featuring Nitpick Applied to Typedefs *}
+
+theory Typedef_Nits
+imports Main Rational
+begin
+
+nitpick_params [card = 1\<midarrow>4, timeout = 5 s]
+
+typedef three = "{0\<Colon>nat, 1, 2}"
+by blast
+
+definition A :: three where "A \<equiv> Abs_three 0"
+definition B :: three where "B \<equiv> Abs_three 1"
+definition C :: three where "C \<equiv> Abs_three 2"
+
+lemma "x = (y\<Colon>three)"
+nitpick [expect = genuine]
+oops
+
+typedef 'a one_or_two = "{undefined False\<Colon>'a, undefined True}"
+by auto
+
+lemma "x = (y\<Colon>unit one_or_two)"
+nitpick [expect = none]
+sorry
+
+lemma "x = (y\<Colon>bool one_or_two)"
+nitpick [expect = genuine]
+oops
+
+lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> x = (y\<Colon>bool one_or_two)"
+nitpick [expect = none]
+sorry
+
+lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> \<exists>x (y\<Colon>bool one_or_two). x \<noteq> y"
+nitpick [card = 1, expect = potential] (* unfortunate *)
+oops
+
+lemma "\<exists>x (y\<Colon>bool one_or_two). x \<noteq> y"
+nitpick [card = 1, expect = potential] (* unfortunate *)
+nitpick [card = 2, expect = none]
+oops
+
+typedef 'a bounded =
+ "{n\<Colon>nat. finite (UNIV\<Colon>'a \<Rightarrow> bool) \<longrightarrow> n < card (UNIV\<Colon>'a \<Rightarrow> bool)}"
+apply (rule_tac x = 0 in exI)
+apply (case_tac "card UNIV = 0")
+by auto
+
+lemma "x = (y\<Colon>unit bounded)"
+nitpick [expect = none]
+sorry
+
+lemma "x = (y\<Colon>bool bounded)"
+nitpick [expect = genuine]
+oops
+
+lemma "x \<noteq> (y\<Colon>bool bounded) \<Longrightarrow> z = x \<or> z = y"
+nitpick [expect = none]
+sorry
+
+lemma "x \<noteq> (y\<Colon>(bool \<times> bool) bounded) \<Longrightarrow> z = x \<or> z = y"
+nitpick [card = 1\<midarrow>5, timeout = 10 s, expect = genuine]
+oops
+
+lemma "True \<equiv> ((\<lambda>x\<Colon>bool. x) = (\<lambda>x. x))"
+nitpick [expect = none]
+by (rule True_def)
+
+lemma "False \<equiv> \<forall>P. P"
+nitpick [expect = none]
+by (rule False_def)
+
+lemma "() = Abs_unit True"
+nitpick [expect = none]
+by (rule Unity_def)
+
+lemma "() = Abs_unit False"
+nitpick [expect = none]
+by simp
+
+lemma "Rep_unit () = True"
+nitpick [expect = none]
+by (insert Rep_unit) (simp add: unit_def)
+
+lemma "Rep_unit () = False"
+nitpick [expect = genuine]
+oops
+
+lemma "Pair a b \<equiv> Abs_Prod (Pair_Rep a b)"
+nitpick [card = 1\<midarrow>2, expect = none]
+by (rule Pair_def)
+
+lemma "Pair a b \<equiv> Abs_Prod (Pair_Rep b a)"
+nitpick [card = 1\<midarrow>2, expect = none]
+nitpick [dont_box, expect = genuine]
+oops
+
+lemma "fst (Abs_Prod (Pair_Rep a b)) = a"
+nitpick [card = 2, expect = none]
+by (simp add: Pair_def [THEN symmetric])
+
+lemma "fst (Abs_Prod (Pair_Rep a b)) = b"
+nitpick [card = 1\<midarrow>2, expect = none]
+nitpick [dont_box, expect = genuine]
+oops
+
+lemma "a \<noteq> a' \<Longrightarrow> Pair_Rep a b \<noteq> Pair_Rep a' b"
+nitpick [expect = none]
+apply (rule ccontr)
+apply simp
+apply (drule subst [where P = "\<lambda>r. Abs_Prod r = Abs_Prod (Pair_Rep a b)"])
+ apply (rule refl)
+by (simp add: Pair_def [THEN symmetric])
+
+lemma "Abs_Prod (Rep_Prod a) = a"
+nitpick [card = 2, expect = none]
+by (rule Rep_Prod_inverse)
+
+lemma "Inl \<equiv> \<lambda>a. Abs_Sum (Inl_Rep a)"
+nitpick [card = 1, expect = none]
+by (rule Inl_def)
+
+lemma "Inl \<equiv> \<lambda>a. Abs_Sum (Inr_Rep a)"
+nitpick [card = 1, card "'a + 'a" = 2, expect = genuine]
+oops
+
+lemma "Inl_Rep a \<noteq> Inr_Rep a"
+nitpick [expect = none]
+by (rule Inl_Rep_not_Inr_Rep)
+
+lemma "Abs_Sum (Rep_Sum a) = a"
+nitpick [card = 1\<midarrow>2, timeout = 30 s, expect = none]
+by (rule Rep_Sum_inverse)
+
+lemma "0::nat \<equiv> Abs_Nat Zero_Rep"
+nitpick [expect = none]
+by (rule Zero_nat_def_raw)
+
+lemma "Suc \<equiv> \<lambda>n. Abs_Nat (Suc_Rep (Rep_Nat n))"
+nitpick [expect = none]
+by (rule Suc_def)
+
+lemma "Suc \<equiv> \<lambda>n. Abs_Nat (Suc_Rep (Suc_Rep (Rep_Nat n)))"
+nitpick [expect = genuine]
+oops
+
+lemma "Abs_Nat (Rep_Nat a) = a"
+nitpick [expect = none]
+by (rule Rep_Nat_inverse)
+
+lemma "0 \<equiv> Abs_Integ (intrel `` {(0, 0)})"
+nitpick [card = 1, timeout = 30 s, max_potential = 0, expect = none]
+by (rule Zero_int_def_raw)
+
+lemma "Abs_Integ (Rep_Integ a) = a"
+nitpick [card = 1, timeout = 30 s, max_potential = 0, expect = none]
+by (rule Rep_Integ_inverse)
+
+lemma "Abs_list (Rep_list a) = a"
+nitpick [card = 1\<midarrow>2, timeout = 30 s, expect = none]
+by (rule Rep_list_inverse)
+
+record point =
+ Xcoord :: int
+ Ycoord :: int
+
+lemma "Abs_point_ext_type (Rep_point_ext_type a) = a"
+nitpick [expect = unknown]
+by (rule Rep_point_ext_type_inverse)
+
+lemma "Fract a b = of_int a / of_int b"
+nitpick [card = 1\<midarrow>2, expect = unknown]
+by (rule Fract_of_int_quotient)
+
+lemma "Abs_Rat (Rep_Rat a) = a"
+nitpick [card = 1\<midarrow>2, expect = unknown]
+by (rule Rep_Rat_inverse)
+
+end--- a/src/HOL/Nominal/Examples/Nominal_Examples.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Nominal/Examples/Nominal_Examples.thy Tue Oct 27 14:46:03 2009 +0000
@@ -20,6 +20,7 @@
Contexts
Standardization
W
+ Pattern
begin
end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nominal/Examples/Pattern.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,865 @@
+header {* Simply-typed lambda-calculus with let and tuple patterns *}
+
+theory Pattern
+imports Nominal
+begin
+
+no_syntax
+ "_Map" :: "maplets => 'a ~=> 'b" ("(1[_])")
+
+atom_decl name
+
+nominal_datatype ty =
+ Atom nat
+ | Arrow ty ty (infixr "\<rightarrow>" 200)
+ | TupleT ty ty (infixr "\<otimes>" 210)
+
+lemma fresh_type [simp]: "(a::name) \<sharp> (T::ty)"
+ by (induct T rule: ty.induct) (simp_all add: fresh_nat)
+
+lemma supp_type [simp]: "supp (T::ty) = ({} :: name set)"
+ by (induct T rule: ty.induct) (simp_all add: ty.supp supp_nat)
+
+lemma perm_type: "(pi::name prm) \<bullet> (T::ty) = T"
+ by (induct T rule: ty.induct) (simp_all add: perm_nat_def)
+
+nominal_datatype trm =
+ Var name
+ | Tuple trm trm ("(1'\<langle>_,/ _'\<rangle>)")
+ | Abs ty "\<guillemotleft>name\<guillemotright>trm"
+ | App trm trm (infixl "\<cdot>" 200)
+ | Let ty trm btrm
+and btrm =
+ Base trm
+ | Bind ty "\<guillemotleft>name\<guillemotright>btrm"
+
+abbreviation
+ Abs_syn :: "name \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm" ("(3\<lambda>_:_./ _)" [0, 0, 10] 10)
+where
+ "\<lambda>x:T. t \<equiv> Abs T x t"
+
+datatype pat =
+ PVar name ty
+ | PTuple pat pat ("(1'\<langle>\<langle>_,/ _'\<rangle>\<rangle>)")
+
+(* FIXME: The following should be done automatically by the nominal package *)
+overloading pat_perm \<equiv> "perm :: name prm \<Rightarrow> pat \<Rightarrow> pat" (unchecked)
+begin
+
+primrec pat_perm
+where
+ "pat_perm pi (PVar x ty) = PVar (pi \<bullet> x) (pi \<bullet> ty)"
+| "pat_perm pi \<langle>\<langle>p, q\<rangle>\<rangle> = \<langle>\<langle>pat_perm pi p, pat_perm pi q\<rangle>\<rangle>"
+
+end
+
+declare pat_perm.simps [eqvt]
+
+lemma supp_PVar [simp]: "((supp (PVar x T))::name set) = supp x"
+ by (simp add: supp_def perm_fresh_fresh)
+
+lemma supp_PTuple [simp]: "((supp \<langle>\<langle>p, q\<rangle>\<rangle>)::name set) = supp p \<union> supp q"
+ by (simp add: supp_def Collect_disj_eq del: disj_not1)
+
+instance pat :: pt_name
+proof intro_classes
+ case goal1
+ show ?case by (induct x) simp_all
+next
+ case goal2
+ show ?case by (induct x) (simp_all add: pt_name2)
+next
+ case goal3
+ then show ?case by (induct x) (simp_all add: pt_name3)
+qed
+
+instance pat :: fs_name
+proof intro_classes
+ case goal1
+ show ?case by (induct x) (simp_all add: fin_supp)
+qed
+
+(* the following function cannot be defined using nominal_primrec, *)
+(* since variable parameters are currently not allowed. *)
+primrec abs_pat :: "pat \<Rightarrow> btrm \<Rightarrow> btrm" ("(3\<lambda>[_]./ _)" [0, 10] 10)
+where
+ "(\<lambda>[PVar x T]. t) = Bind T x t"
+| "(\<lambda>[\<langle>\<langle>p, q\<rangle>\<rangle>]. t) = (\<lambda>[p]. \<lambda>[q]. t)"
+
+lemma abs_pat_eqvt [eqvt]:
+ "(pi :: name prm) \<bullet> (\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. (pi \<bullet> t))"
+ by (induct p arbitrary: t) simp_all
+
+lemma abs_pat_fresh [simp]:
+ "(x::name) \<sharp> (\<lambda>[p]. t) = (x \<in> supp p \<or> x \<sharp> t)"
+ by (induct p arbitrary: t) (simp_all add: abs_fresh supp_atm)
+
+lemma abs_pat_alpha:
+ assumes fresh: "((pi::name prm) \<bullet> supp p::name set) \<sharp>* t"
+ and pi: "set pi \<subseteq> supp p \<times> pi \<bullet> supp p"
+ shows "(\<lambda>[p]. t) = (\<lambda>[pi \<bullet> p]. pi \<bullet> t)"
+proof -
+ note pt_name_inst at_name_inst pi
+ moreover have "(supp p::name set) \<sharp>* (\<lambda>[p]. t)"
+ by (simp add: fresh_star_def)
+ moreover from fresh
+ have "(pi \<bullet> supp p::name set) \<sharp>* (\<lambda>[p]. t)"
+ by (simp add: fresh_star_def)
+ ultimately have "pi \<bullet> (\<lambda>[p]. t) = (\<lambda>[p]. t)"
+ by (rule pt_freshs_freshs)
+ then show ?thesis by (simp add: eqvts)
+qed
+
+primrec pat_vars :: "pat \<Rightarrow> name list"
+where
+ "pat_vars (PVar x T) = [x]"
+| "pat_vars \<langle>\<langle>p, q\<rangle>\<rangle> = pat_vars q @ pat_vars p"
+
+lemma pat_vars_eqvt [eqvt]:
+ "(pi :: name prm) \<bullet> (pat_vars p) = pat_vars (pi \<bullet> p)"
+ by (induct p rule: pat.induct) (simp_all add: eqvts)
+
+lemma set_pat_vars_supp: "set (pat_vars p) = supp p"
+ by (induct p) (auto simp add: supp_atm)
+
+lemma distinct_eqvt [eqvt]:
+ "(pi :: name prm) \<bullet> (distinct (xs::name list)) = distinct (pi \<bullet> xs)"
+ by (induct xs) (simp_all add: eqvts)
+
+primrec pat_type :: "pat \<Rightarrow> ty"
+where
+ "pat_type (PVar x T) = T"
+| "pat_type \<langle>\<langle>p, q\<rangle>\<rangle> = pat_type p \<otimes> pat_type q"
+
+lemma pat_type_eqvt [eqvt]:
+ "(pi :: name prm) \<bullet> (pat_type p) = pat_type (pi \<bullet> p)"
+ by (induct p) simp_all
+
+lemma pat_type_perm_eq: "pat_type ((pi :: name prm) \<bullet> p) = pat_type p"
+ by (induct p) (simp_all add: perm_type)
+
+types ctx = "(name \<times> ty) list"
+
+inductive
+ ptyping :: "pat \<Rightarrow> ty \<Rightarrow> ctx \<Rightarrow> bool" ("\<turnstile> _ : _ \<Rightarrow> _" [60, 60, 60] 60)
+where
+ PVar: "\<turnstile> PVar x T : T \<Rightarrow> [(x, T)]"
+| PTuple: "\<turnstile> p : T \<Rightarrow> \<Delta>\<^isub>1 \<Longrightarrow> \<turnstile> q : U \<Rightarrow> \<Delta>\<^isub>2 \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> : T \<otimes> U \<Rightarrow> \<Delta>\<^isub>2 @ \<Delta>\<^isub>1"
+
+lemma pat_vars_ptyping:
+ assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
+ shows "pat_vars p = map fst \<Delta>" using assms
+ by induct simp_all
+
+inductive
+ valid :: "ctx \<Rightarrow> bool"
+where
+ Nil [intro!]: "valid []"
+| Cons [intro!]: "valid \<Gamma> \<Longrightarrow> x \<sharp> \<Gamma> \<Longrightarrow> valid ((x, T) # \<Gamma>)"
+
+inductive_cases validE[elim!]: "valid ((x, T) # \<Gamma>)"
+
+lemma fresh_ctxt_set_eq: "((x::name) \<sharp> (\<Gamma>::ctx)) = (x \<notin> fst ` set \<Gamma>)"
+ by (induct \<Gamma>) (auto simp add: fresh_list_nil fresh_list_cons fresh_prod fresh_atm)
+
+lemma valid_distinct: "valid \<Gamma> = distinct (map fst \<Gamma>)"
+ by (induct \<Gamma>) (auto simp add: fresh_ctxt_set_eq [symmetric])
+
+abbreviation
+ "sub_ctx" :: "ctx \<Rightarrow> ctx \<Rightarrow> bool" ("_ \<sqsubseteq> _")
+where
+ "\<Gamma>\<^isub>1 \<sqsubseteq> \<Gamma>\<^isub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^isub>1 \<longrightarrow> x \<in> set \<Gamma>\<^isub>2"
+
+abbreviation
+ Let_syn :: "pat \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm" ("(LET (_ =/ _)/ IN (_))" 10)
+where
+ "LET p = t IN u \<equiv> Let (pat_type p) t (\<lambda>[p]. Base u)"
+
+inductive typing :: "ctx \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60, 60, 60] 60)
+where
+ Var [intro]: "valid \<Gamma> \<Longrightarrow> (x, T) \<in> set \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
+| Tuple [intro]: "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> u : U \<Longrightarrow> \<Gamma> \<turnstile> \<langle>t, u\<rangle> : T \<otimes> U"
+| Abs [intro]: "(x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T. t) : T \<rightarrow> U"
+| App [intro]: "\<Gamma> \<turnstile> t : T \<rightarrow> U \<Longrightarrow> \<Gamma> \<turnstile> u : T \<Longrightarrow> \<Gamma> \<turnstile> t \<cdot> u : U"
+| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow>
+ \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow>
+ \<Gamma> \<turnstile> (LET p = t IN u) : U"
+
+equivariance ptyping
+
+equivariance valid
+
+equivariance typing
+
+lemma valid_typing:
+ assumes "\<Gamma> \<turnstile> t : T"
+ shows "valid \<Gamma>" using assms
+ by induct auto
+
+lemma pat_var:
+ assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
+ shows "(supp p::name set) = supp \<Delta>" using assms
+ by induct (auto simp add: supp_list_nil supp_list_cons supp_prod supp_list_append)
+
+lemma valid_app_fresh:
+ assumes "valid (\<Delta> @ \<Gamma>)" and "(x::name) \<in> supp \<Delta>"
+ shows "x \<sharp> \<Gamma>" using assms
+ by (induct \<Delta>)
+ (auto simp add: supp_list_nil supp_list_cons supp_prod supp_atm fresh_list_append)
+
+lemma pat_freshs:
+ assumes "\<turnstile> p : T \<Rightarrow> \<Delta>"
+ shows "(supp p::name set) \<sharp>* c = (supp \<Delta>::name set) \<sharp>* c" using assms
+ by (auto simp add: fresh_star_def pat_var)
+
+lemma valid_app_mono:
+ assumes "valid (\<Delta> @ \<Gamma>\<^isub>1)" and "(supp \<Delta>::name set) \<sharp>* \<Gamma>\<^isub>2" and "valid \<Gamma>\<^isub>2" and "\<Gamma>\<^isub>1 \<sqsubseteq> \<Gamma>\<^isub>2"
+ shows "valid (\<Delta> @ \<Gamma>\<^isub>2)" using assms
+ by (induct \<Delta>)
+ (auto simp add: supp_list_cons fresh_star_Un_elim supp_prod
+ fresh_list_append supp_atm fresh_star_insert_elim fresh_star_empty_elim)
+
+nominal_inductive2 typing
+avoids
+ Abs: "{x}"
+| Let: "(supp p)::name set"
+ by (auto simp add: fresh_star_def abs_fresh fin_supp pat_var
+ dest!: valid_typing valid_app_fresh)
+
+lemma better_T_Let [intro]:
+ assumes t: "\<Gamma> \<turnstile> t : T" and p: "\<turnstile> p : T \<Rightarrow> \<Delta>" and u: "\<Delta> @ \<Gamma> \<turnstile> u : U"
+ shows "\<Gamma> \<turnstile> (LET p = t IN u) : U"
+proof -
+ obtain pi::"name prm" where pi: "(pi \<bullet> (supp p::name set)) \<sharp>* (t, Base u, \<Gamma>)"
+ and pi': "set pi \<subseteq> supp p \<times> (pi \<bullet> supp p)"
+ by (rule at_set_avoiding [OF at_name_inst fin_supp fin_supp])
+ from p u have p_fresh: "(supp p::name set) \<sharp>* \<Gamma>"
+ by (auto simp add: fresh_star_def pat_var dest!: valid_typing valid_app_fresh)
+ from pi have p_fresh': "(pi \<bullet> (supp p::name set)) \<sharp>* \<Gamma>"
+ by (simp add: fresh_star_prod_elim)
+ from pi have p_fresh'': "(pi \<bullet> (supp p::name set)) \<sharp>* Base u"
+ by (simp add: fresh_star_prod_elim)
+ from pi have "(supp (pi \<bullet> p)::name set) \<sharp>* t"
+ by (simp add: fresh_star_prod_elim eqvts)
+ moreover note t
+ moreover from p have "pi \<bullet> (\<turnstile> p : T \<Rightarrow> \<Delta>)" by (rule perm_boolI)
+ then have "\<turnstile> (pi \<bullet> p) : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: eqvts perm_type)
+ moreover from u have "pi \<bullet> (\<Delta> @ \<Gamma> \<turnstile> u : U)" by (rule perm_boolI)
+ with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' p_fresh p_fresh']
+ have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> (pi \<bullet> u) : U" by (simp add: eqvts perm_type)
+ ultimately have "\<Gamma> \<turnstile> (LET (pi \<bullet> p) = t IN (pi \<bullet> u)) : U"
+ by (rule Let)
+ then show ?thesis by (simp add: abs_pat_alpha [OF p_fresh'' pi'] pat_type_perm_eq)
+qed
+
+lemma weakening:
+ assumes "\<Gamma>\<^isub>1 \<turnstile> t : T" and "valid \<Gamma>\<^isub>2" and "\<Gamma>\<^isub>1 \<sqsubseteq> \<Gamma>\<^isub>2"
+ shows "\<Gamma>\<^isub>2 \<turnstile> t : T" using assms
+ apply (nominal_induct \<Gamma>\<^isub>1 t T avoiding: \<Gamma>\<^isub>2 rule: typing.strong_induct)
+ apply auto
+ apply (drule_tac x="(x, T) # \<Gamma>\<^isub>2" in meta_spec)
+ apply (auto intro: valid_typing)
+ apply (drule_tac x="\<Gamma>\<^isub>2" in meta_spec)
+ apply (drule_tac x="\<Delta> @ \<Gamma>\<^isub>2" in meta_spec)
+ apply (auto intro: valid_typing)
+ apply (rule typing.Let)
+ apply assumption+
+ apply (drule meta_mp)
+ apply (rule valid_app_mono)
+ apply (rule valid_typing)
+ apply assumption
+ apply (auto simp add: pat_freshs)
+ done
+
+inductive
+ match :: "pat \<Rightarrow> trm \<Rightarrow> (name \<times> trm) list \<Rightarrow> bool" ("\<turnstile> _ \<rhd> _ \<Rightarrow> _" [50, 50, 50] 50)
+where
+ PVar: "\<turnstile> PVar x T \<rhd> t \<Rightarrow> [(x, t)]"
+| PProd: "\<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> \<turnstile> q \<rhd> u \<Rightarrow> \<theta>' \<Longrightarrow> \<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> \<langle>t, u\<rangle> \<Rightarrow> \<theta> @ \<theta>'"
+
+fun
+ lookup :: "(name \<times> trm) list \<Rightarrow> name \<Rightarrow> trm"
+where
+ "lookup [] x = Var x"
+| "lookup ((y, e) # \<theta>) x = (if x = y then e else lookup \<theta> x)"
+
+lemma lookup_eqvt[eqvt]:
+ fixes pi :: "name prm"
+ and \<theta> :: "(name \<times> trm) list"
+ and X :: "name"
+ shows "pi \<bullet> (lookup \<theta> X) = lookup (pi \<bullet> \<theta>) (pi \<bullet> X)"
+ by (induct \<theta>) (auto simp add: eqvts)
+
+nominal_primrec
+ psubst :: "(name \<times> trm) list \<Rightarrow> trm \<Rightarrow> trm" ("_\<lparr>_\<rparr>" [95,0] 210)
+ and psubstb :: "(name \<times> trm) list \<Rightarrow> btrm \<Rightarrow> btrm" ("_\<lparr>_\<rparr>\<^sub>b" [95,0] 210)
+where
+ "\<theta>\<lparr>Var x\<rparr> = (lookup \<theta> x)"
+| "\<theta>\<lparr>t \<cdot> u\<rparr> = \<theta>\<lparr>t\<rparr> \<cdot> \<theta>\<lparr>u\<rparr>"
+| "\<theta>\<lparr>\<langle>t, u\<rangle>\<rparr> = \<langle>\<theta>\<lparr>t\<rparr>, \<theta>\<lparr>u\<rparr>\<rangle>"
+| "\<theta>\<lparr>Let T t u\<rparr> = Let T (\<theta>\<lparr>t\<rparr>) (\<theta>\<lparr>u\<rparr>\<^sub>b)"
+| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>x:T. t\<rparr> = (\<lambda>x:T. \<theta>\<lparr>t\<rparr>)"
+| "\<theta>\<lparr>Base t\<rparr>\<^sub>b = Base (\<theta>\<lparr>t\<rparr>)"
+| "x \<sharp> \<theta> \<Longrightarrow> \<theta>\<lparr>Bind T x t\<rparr>\<^sub>b = Bind T x (\<theta>\<lparr>t\<rparr>\<^sub>b)"
+ apply finite_guess+
+ apply (simp add: abs_fresh | fresh_guess)+
+ done
+
+lemma lookup_fresh:
+ "x = y \<longrightarrow> x \<in> set (map fst \<theta>) \<Longrightarrow> \<forall>(y, t)\<in>set \<theta>. x \<sharp> t \<Longrightarrow> x \<sharp> lookup \<theta> y"
+ apply (induct \<theta>)
+ apply (simp_all add: split_paired_all fresh_atm)
+ apply (case_tac "x = y")
+ apply (auto simp add: fresh_atm)
+ done
+
+lemma psubst_fresh:
+ assumes "x \<in> set (map fst \<theta>)" and "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t"
+ shows "x \<sharp> \<theta>\<lparr>t\<rparr>" and "x \<sharp> \<theta>\<lparr>t'\<rparr>\<^sub>b" using assms
+ apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
+ apply simp
+ apply (rule lookup_fresh)
+ apply (rule impI)
+ apply (simp_all add: abs_fresh)
+ done
+
+lemma psubst_eqvt[eqvt]:
+ fixes pi :: "name prm"
+ shows "pi \<bullet> (\<theta>\<lparr>t\<rparr>) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t\<rparr>"
+ and "pi \<bullet> (\<theta>\<lparr>t'\<rparr>\<^sub>b) = (pi \<bullet> \<theta>)\<lparr>pi \<bullet> t'\<rparr>\<^sub>b"
+ by (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
+ (simp_all add: eqvts fresh_bij)
+
+abbreviation
+ subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_\<mapsto>_]" [100,0,0] 100)
+where
+ "t[x\<mapsto>t'] \<equiv> [(x,t')]\<lparr>t\<rparr>"
+
+abbreviation
+ substb :: "btrm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> btrm" ("_[_\<mapsto>_]\<^sub>b" [100,0,0] 100)
+where
+ "t[x\<mapsto>t']\<^sub>b \<equiv> [(x,t')]\<lparr>t\<rparr>\<^sub>b"
+
+lemma lookup_forget:
+ "(supp (map fst \<theta>)::name set) \<sharp>* x \<Longrightarrow> lookup \<theta> x = Var x"
+ by (induct \<theta>) (auto simp add: split_paired_all fresh_star_def fresh_atm supp_list_cons supp_atm)
+
+lemma supp_fst: "(x::name) \<in> supp (map fst (\<theta>::(name \<times> trm) list)) \<Longrightarrow> x \<in> supp \<theta>"
+ by (induct \<theta>) (auto simp add: supp_list_nil supp_list_cons supp_prod)
+
+lemma psubst_forget:
+ "(supp (map fst \<theta>)::name set) \<sharp>* t \<Longrightarrow> \<theta>\<lparr>t\<rparr> = t"
+ "(supp (map fst \<theta>)::name set) \<sharp>* t' \<Longrightarrow> \<theta>\<lparr>t'\<rparr>\<^sub>b = t'"
+ apply (nominal_induct t and t' avoiding: \<theta> rule: trm_btrm.strong_inducts)
+ apply (auto simp add: fresh_star_def lookup_forget abs_fresh)
+ apply (drule_tac x=\<theta> in meta_spec)
+ apply (drule meta_mp)
+ apply (rule ballI)
+ apply (drule_tac x=x in bspec)
+ apply assumption
+ apply (drule supp_fst)
+ apply (auto simp add: fresh_def)
+ apply (drule_tac x=\<theta> in meta_spec)
+ apply (drule meta_mp)
+ apply (rule ballI)
+ apply (drule_tac x=x in bspec)
+ apply assumption
+ apply (drule supp_fst)
+ apply (auto simp add: fresh_def)
+ done
+
+lemma psubst_nil: "[]\<lparr>t\<rparr> = t" "[]\<lparr>t'\<rparr>\<^sub>b = t'"
+ by (induct t and t' rule: trm_btrm.inducts) (simp_all add: fresh_list_nil)
+
+lemma psubst_cons:
+ assumes "(supp (map fst \<theta>)::name set) \<sharp>* u"
+ shows "((x, u) # \<theta>)\<lparr>t\<rparr> = \<theta>\<lparr>t[x\<mapsto>u]\<rparr>" and "((x, u) # \<theta>)\<lparr>t'\<rparr>\<^sub>b = \<theta>\<lparr>t'[x\<mapsto>u]\<^sub>b\<rparr>\<^sub>b"
+ using assms
+ by (nominal_induct t and t' avoiding: x u \<theta> rule: trm_btrm.strong_inducts)
+ (simp_all add: fresh_list_nil fresh_list_cons psubst_forget)
+
+lemma psubst_append:
+ "(supp (map fst (\<theta>\<^isub>1 @ \<theta>\<^isub>2))::name set) \<sharp>* map snd (\<theta>\<^isub>1 @ \<theta>\<^isub>2) \<Longrightarrow> (\<theta>\<^isub>1 @ \<theta>\<^isub>2)\<lparr>t\<rparr> = \<theta>\<^isub>2\<lparr>\<theta>\<^isub>1\<lparr>t\<rparr>\<rparr>"
+ by (induct \<theta>\<^isub>1 arbitrary: t)
+ (simp_all add: psubst_nil split_paired_all supp_list_cons psubst_cons fresh_star_def
+ fresh_list_cons fresh_list_append supp_list_append)
+
+lemma abs_pat_psubst [simp]:
+ "(supp p::name set) \<sharp>* \<theta> \<Longrightarrow> \<theta>\<lparr>\<lambda>[p]. t\<rparr>\<^sub>b = (\<lambda>[p]. \<theta>\<lparr>t\<rparr>\<^sub>b)"
+ by (induct p arbitrary: t) (auto simp add: fresh_star_def supp_atm)
+
+lemma valid_insert:
+ assumes "valid (\<Delta> @ [(x, T)] @ \<Gamma>)"
+ shows "valid (\<Delta> @ \<Gamma>)" using assms
+ by (induct \<Delta>)
+ (auto simp add: fresh_list_append fresh_list_cons)
+
+lemma fresh_set:
+ shows "y \<sharp> xs = (\<forall>x\<in>set xs. y \<sharp> x)"
+ by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)
+
+lemma context_unique:
+ assumes "valid \<Gamma>"
+ and "(x, T) \<in> set \<Gamma>"
+ and "(x, U) \<in> set \<Gamma>"
+ shows "T = U" using assms
+ by induct (auto simp add: fresh_set fresh_prod fresh_atm)
+
+lemma subst_type_aux:
+ assumes a: "\<Delta> @ [(x, U)] @ \<Gamma> \<turnstile> t : T"
+ and b: "\<Gamma> \<turnstile> u : U"
+ shows "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" using a b
+proof (nominal_induct \<Gamma>'\<equiv>"\<Delta> @ [(x, U)] @ \<Gamma>" t T avoiding: x u \<Delta> rule: typing.strong_induct)
+ case (Var \<Gamma>' y T x u \<Delta>)
+ then have a1: "valid (\<Delta> @ [(x, U)] @ \<Gamma>)"
+ and a2: "(y, T) \<in> set (\<Delta> @ [(x, U)] @ \<Gamma>)"
+ and a3: "\<Gamma> \<turnstile> u : U" by simp_all
+ from a1 have a4: "valid (\<Delta> @ \<Gamma>)" by (rule valid_insert)
+ show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T"
+ proof cases
+ assume eq: "x = y"
+ from a1 a2 have "T = U" using eq by (auto intro: context_unique)
+ with a3 show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" using eq a4 by (auto intro: weakening)
+ next
+ assume ineq: "x \<noteq> y"
+ from a2 have "(y, T) \<in> set (\<Delta> @ \<Gamma>)" using ineq by simp
+ then show "\<Delta> @ \<Gamma> \<turnstile> Var y[x\<mapsto>u] : T" using ineq a4 by auto
+ qed
+next
+ case (Tuple \<Gamma>' t\<^isub>1 T\<^isub>1 t\<^isub>2 T\<^isub>2)
+ from `\<Gamma> \<turnstile> u : U` `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta> @ \<Gamma> \<turnstile> t\<^isub>1[x\<mapsto>u] : T\<^isub>1" by (rule Tuple)
+ moreover from `\<Gamma> \<turnstile> u : U` `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta> @ \<Gamma> \<turnstile> t\<^isub>2[x\<mapsto>u] : T\<^isub>2" by (rule Tuple)
+ ultimately have "\<Delta> @ \<Gamma> \<turnstile> \<langle>t\<^isub>1[x\<mapsto>u], t\<^isub>2[x\<mapsto>u]\<rangle> : T\<^isub>1 \<otimes> T\<^isub>2" ..
+ then show ?case by simp
+next
+ case (Let p t \<Gamma>' T \<Delta>' s S)
+ from `\<Gamma> \<turnstile> u : U` `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : T" by (rule Let)
+ moreover note `\<turnstile> p : T \<Rightarrow> \<Delta>'`
+ moreover from `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta>' @ \<Gamma>' = (\<Delta>' @ \<Delta>) @ [(x, U)] @ \<Gamma>" by simp
+ with `\<Gamma> \<turnstile> u : U` have "(\<Delta>' @ \<Delta>) @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" by (rule Let)
+ then have "\<Delta>' @ \<Delta> @ \<Gamma> \<turnstile> s[x\<mapsto>u] : S" by simp
+ ultimately have "\<Delta> @ \<Gamma> \<turnstile> (LET p = t[x\<mapsto>u] IN s[x\<mapsto>u]) : S"
+ by (rule better_T_Let)
+ moreover from Let have "(supp p::name set) \<sharp>* [(x, u)]"
+ by (simp add: fresh_star_def fresh_list_nil fresh_list_cons)
+ ultimately show ?case by simp
+next
+ case (Abs y T \<Gamma>' t S)
+ from `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>` have "(y, T) # \<Gamma>' = ((y, T) # \<Delta>) @ [(x, U)] @ \<Gamma>"
+ by simp
+ with `\<Gamma> \<turnstile> u : U` have "((y, T) # \<Delta>) @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" by (rule Abs)
+ then have "(y, T) # \<Delta> @ \<Gamma> \<turnstile> t[x\<mapsto>u] : S" by simp
+ then have "\<Delta> @ \<Gamma> \<turnstile> (\<lambda>y:T. t[x\<mapsto>u]) : T \<rightarrow> S"
+ by (rule typing.Abs)
+ moreover from Abs have "y \<sharp> [(x, u)]"
+ by (simp add: fresh_list_nil fresh_list_cons)
+ ultimately show ?case by simp
+next
+ case (App \<Gamma>' t\<^isub>1 T S t\<^isub>2)
+ from `\<Gamma> \<turnstile> u : U` `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta> @ \<Gamma> \<turnstile> t\<^isub>1[x\<mapsto>u] : T \<rightarrow> S" by (rule App)
+ moreover from `\<Gamma> \<turnstile> u : U` `\<Gamma>' = \<Delta> @ [(x, U)] @ \<Gamma>`
+ have "\<Delta> @ \<Gamma> \<turnstile> t\<^isub>2[x\<mapsto>u] : T" by (rule App)
+ ultimately have "\<Delta> @ \<Gamma> \<turnstile> (t\<^isub>1[x\<mapsto>u]) \<cdot> (t\<^isub>2[x\<mapsto>u]) : S"
+ by (rule typing.App)
+ then show ?case by simp
+qed
+
+lemmas subst_type = subst_type_aux [of "[]", simplified]
+
+lemma match_supp_fst:
+ assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map fst \<theta>)::name set) = supp p" using assms
+ by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append)
+
+lemma match_supp_snd:
+ assumes "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>" shows "(supp (map snd \<theta>)::name set) = supp u" using assms
+ by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append trm.supp)
+
+lemma match_fresh: "\<turnstile> p \<rhd> u \<Rightarrow> \<theta> \<Longrightarrow> (supp p::name set) \<sharp>* u \<Longrightarrow>
+ (supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
+ by (simp add: fresh_star_def fresh_def match_supp_fst match_supp_snd)
+
+lemma match_type_aux:
+ assumes "\<turnstile> p : U \<Rightarrow> \<Delta>"
+ and "\<Gamma>\<^isub>2 \<turnstile> u : U"
+ and "\<Gamma>\<^isub>1 @ \<Delta> @ \<Gamma>\<^isub>2 \<turnstile> t : T"
+ and "\<turnstile> p \<rhd> u \<Rightarrow> \<theta>"
+ and "(supp p::name set) \<sharp>* u"
+ shows "\<Gamma>\<^isub>1 @ \<Gamma>\<^isub>2 \<turnstile> \<theta>\<lparr>t\<rparr> : T" using assms
+proof (induct arbitrary: \<Gamma>\<^isub>1 \<Gamma>\<^isub>2 t u T \<theta>)
+ case (PVar x U)
+ from `\<Gamma>\<^isub>1 @ [(x, U)] @ \<Gamma>\<^isub>2 \<turnstile> t : T` `\<Gamma>\<^isub>2 \<turnstile> u : U`
+ have "\<Gamma>\<^isub>1 @ \<Gamma>\<^isub>2 \<turnstile> t[x\<mapsto>u] : T" by (rule subst_type_aux)
+ moreover from `\<turnstile> PVar x U \<rhd> u \<Rightarrow> \<theta>` have "\<theta> = [(x, u)]"
+ by cases simp_all
+ ultimately show ?case by simp
+next
+ case (PTuple p S \<Delta>\<^isub>1 q U \<Delta>\<^isub>2)
+ from `\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>` obtain u\<^isub>1 u\<^isub>2 \<theta>\<^isub>1 \<theta>\<^isub>2
+ where u: "u = \<langle>u\<^isub>1, u\<^isub>2\<rangle>" and \<theta>: "\<theta> = \<theta>\<^isub>1 @ \<theta>\<^isub>2"
+ and p: "\<turnstile> p \<rhd> u\<^isub>1 \<Rightarrow> \<theta>\<^isub>1" and q: "\<turnstile> q \<rhd> u\<^isub>2 \<Rightarrow> \<theta>\<^isub>2"
+ by cases simp_all
+ with PTuple have "\<Gamma>\<^isub>2 \<turnstile> \<langle>u\<^isub>1, u\<^isub>2\<rangle> : S \<otimes> U" by simp
+ then obtain u\<^isub>1: "\<Gamma>\<^isub>2 \<turnstile> u\<^isub>1 : S" and u\<^isub>2: "\<Gamma>\<^isub>2 \<turnstile> u\<^isub>2 : U"
+ by cases (simp_all add: ty.inject trm.inject)
+ note u\<^isub>1
+ moreover from `\<Gamma>\<^isub>1 @ (\<Delta>\<^isub>2 @ \<Delta>\<^isub>1) @ \<Gamma>\<^isub>2 \<turnstile> t : T`
+ have "(\<Gamma>\<^isub>1 @ \<Delta>\<^isub>2) @ \<Delta>\<^isub>1 @ \<Gamma>\<^isub>2 \<turnstile> t : T" by simp
+ moreover note p
+ moreover from `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u` and u
+ have "(supp p::name set) \<sharp>* u\<^isub>1" by (simp add: fresh_star_def)
+ ultimately have \<theta>\<^isub>1: "(\<Gamma>\<^isub>1 @ \<Delta>\<^isub>2) @ \<Gamma>\<^isub>2 \<turnstile> \<theta>\<^isub>1\<lparr>t\<rparr> : T"
+ by (rule PTuple)
+ note u\<^isub>2
+ moreover from \<theta>\<^isub>1
+ have "\<Gamma>\<^isub>1 @ \<Delta>\<^isub>2 @ \<Gamma>\<^isub>2 \<turnstile> \<theta>\<^isub>1\<lparr>t\<rparr> : T" by simp
+ moreover note q
+ moreover from `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u` and u
+ have "(supp q::name set) \<sharp>* u\<^isub>2" by (simp add: fresh_star_def)
+ ultimately have "\<Gamma>\<^isub>1 @ \<Gamma>\<^isub>2 \<turnstile> \<theta>\<^isub>2\<lparr>\<theta>\<^isub>1\<lparr>t\<rparr>\<rparr> : T"
+ by (rule PTuple)
+ moreover from `\<turnstile> \<langle>\<langle>p, q\<rangle>\<rangle> \<rhd> u \<Rightarrow> \<theta>` `supp \<langle>\<langle>p, q\<rangle>\<rangle> \<sharp>* u`
+ have "(supp (map fst \<theta>)::name set) \<sharp>* map snd \<theta>"
+ by (rule match_fresh)
+ ultimately show ?case using \<theta> by (simp add: psubst_append)
+qed
+
+lemmas match_type = match_type_aux [where \<Gamma>\<^isub>1="[]", simplified]
+
+inductive eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
+where
+ TupleL: "t \<longmapsto> t' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t', u\<rangle>"
+| TupleR: "u \<longmapsto> u' \<Longrightarrow> \<langle>t, u\<rangle> \<longmapsto> \<langle>t, u'\<rangle>"
+| Abs: "t \<longmapsto> t' \<Longrightarrow> (\<lambda>x:T. t) \<longmapsto> (\<lambda>x:T. t')"
+| AppL: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
+| AppR: "u \<longmapsto> u' \<Longrightarrow> t \<cdot> u \<longmapsto> t \<cdot> u'"
+| Beta: "x \<sharp> u \<Longrightarrow> (\<lambda>x:T. t) \<cdot> u \<longmapsto> t[x\<mapsto>u]"
+| Let: "((supp p)::name set) \<sharp>* t \<Longrightarrow> distinct (pat_vars p) \<Longrightarrow>
+ \<turnstile> p \<rhd> t \<Rightarrow> \<theta> \<Longrightarrow> (LET p = t IN u) \<longmapsto> \<theta>\<lparr>u\<rparr>"
+
+equivariance match
+
+equivariance eval
+
+lemma match_vars:
+ assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "x \<in> supp p"
+ shows "x \<in> set (map fst \<theta>)" using assms
+ by induct (auto simp add: supp_atm)
+
+lemma match_fresh_mono:
+ assumes "\<turnstile> p \<rhd> t \<Rightarrow> \<theta>" and "(x::name) \<sharp> t"
+ shows "\<forall>(y, t)\<in>set \<theta>. x \<sharp> t" using assms
+ by induct auto
+
+nominal_inductive2 eval
+avoids
+ Abs: "{x}"
+| Beta: "{x}"
+| Let: "(supp p)::name set"
+ apply (simp_all add: fresh_star_def abs_fresh fin_supp)
+ apply (rule psubst_fresh)
+ apply simp
+ apply simp
+ apply (rule ballI)
+ apply (rule psubst_fresh)
+ apply (rule match_vars)
+ apply assumption+
+ apply (rule match_fresh_mono)
+ apply auto
+ done
+
+lemma typing_case_Abs:
+ assumes ty: "\<Gamma> \<turnstile> (\<lambda>x:T. t) : S"
+ and fresh: "x \<sharp> \<Gamma>"
+ and R: "\<And>U. S = T \<rightarrow> U \<Longrightarrow> (x, T) # \<Gamma> \<turnstile> t : U \<Longrightarrow> P"
+ shows P using ty
+proof cases
+ case (Abs x' T' \<Gamma>' t' U)
+ obtain y::name where y: "y \<sharp> (x, \<Gamma>, \<lambda>x':T'. t')"
+ by (rule exists_fresh) (auto intro: fin_supp)
+ from `(\<lambda>x:T. t) = (\<lambda>x':T'. t')` [symmetric]
+ have x: "x \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
+ have x': "x' \<sharp> (\<lambda>x':T'. t')" by (simp add: abs_fresh)
+ from `(x', T') # \<Gamma>' \<turnstile> t' : U` have x'': "x' \<sharp> \<Gamma>'"
+ by (auto dest: valid_typing)
+ have "(\<lambda>x:T. t) = (\<lambda>x':T'. t')" by fact
+ also from x x' y have "\<dots> = [(x, y)] \<bullet> [(x', y)] \<bullet> (\<lambda>x':T'. t')"
+ by (simp only: perm_fresh_fresh fresh_prod)
+ also have "\<dots> = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')"
+ by (simp add: swap_simps perm_fresh_fresh)
+ finally have "(\<lambda>x:T. t) = (\<lambda>x:T'. [(x, y)] \<bullet> [(x', y)] \<bullet> t')" .
+ then have T: "T = T'" and t: "[(x, y)] \<bullet> [(x', y)] \<bullet> t' = t"
+ by (simp_all add: trm.inject alpha)
+ from Abs T have "S = T \<rightarrow> U" by simp
+ moreover from `(x', T') # \<Gamma>' \<turnstile> t' : U`
+ have "[(x, y)] \<bullet> [(x', y)] \<bullet> ((x', T') # \<Gamma>' \<turnstile> t' : U)"
+ by (simp add: perm_bool)
+ with T t y `\<Gamma> = \<Gamma>'` x'' fresh have "(x, T) # \<Gamma> \<turnstile> t : U"
+ by (simp add: eqvts swap_simps perm_fresh_fresh fresh_prod)
+ ultimately show ?thesis by (rule R)
+qed simp_all
+
+nominal_primrec ty_size :: "ty \<Rightarrow> nat"
+where
+ "ty_size (Atom n) = 0"
+| "ty_size (T \<rightarrow> U) = ty_size T + ty_size U + 1"
+| "ty_size (T \<otimes> U) = ty_size T + ty_size U + 1"
+ by (rule TrueI)+
+
+lemma bind_tuple_ineq:
+ "ty_size (pat_type p) < ty_size U \<Longrightarrow> Bind U x t \<noteq> (\<lambda>[p]. u)"
+ by (induct p arbitrary: U x t u) (auto simp add: btrm.inject)
+
+lemma valid_appD: assumes "valid (\<Gamma> @ \<Delta>)"
+ shows "valid \<Gamma>" "valid \<Delta>" using assms
+ by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
+ (auto simp add: Cons_eq_append_conv fresh_list_append)
+
+lemma valid_app_freshs: assumes "valid (\<Gamma> @ \<Delta>)"
+ shows "(supp \<Gamma>::name set) \<sharp>* \<Delta>" "(supp \<Delta>::name set) \<sharp>* \<Gamma>" using assms
+ by (induct \<Gamma>'\<equiv>"\<Gamma> @ \<Delta>" arbitrary: \<Gamma> \<Delta>)
+ (auto simp add: Cons_eq_append_conv fresh_star_def
+ fresh_list_nil fresh_list_cons supp_list_nil supp_list_cons fresh_list_append
+ supp_prod fresh_prod supp_atm fresh_atm
+ dest: notE [OF iffD1 [OF fresh_def [THEN meta_eq_to_obj_eq]]])
+
+lemma perm_mem_left: "(x::name) \<in> ((pi::name prm) \<bullet> A) \<Longrightarrow> (rev pi \<bullet> x) \<in> A"
+ by (drule perm_boolI [of _ "rev pi"]) (simp add: eqvts perm_pi_simp)
+
+lemma perm_mem_right: "(rev (pi::name prm) \<bullet> (x::name)) \<in> A \<Longrightarrow> x \<in> (pi \<bullet> A)"
+ by (drule perm_boolI [of _ pi]) (simp add: eqvts perm_pi_simp)
+
+lemma perm_cases:
+ assumes pi: "set pi \<subseteq> A \<times> A"
+ shows "((pi::name prm) \<bullet> B) \<subseteq> A \<union> B"
+proof
+ fix x assume "x \<in> pi \<bullet> B"
+ then show "x \<in> A \<union> B" using pi
+ apply (induct pi arbitrary: x B rule: rev_induct)
+ apply simp
+ apply (simp add: split_paired_all supp_eqvt)
+ apply (drule perm_mem_left)
+ apply (simp add: calc_atm split: split_if_asm)
+ apply (auto dest: perm_mem_right)
+ done
+qed
+
+lemma abs_pat_alpha':
+ assumes eq: "(\<lambda>[p]. t) = (\<lambda>[q]. u)"
+ and ty: "pat_type p = pat_type q"
+ and pv: "distinct (pat_vars p)"
+ and qv: "distinct (pat_vars q)"
+ shows "\<exists>pi::name prm. p = pi \<bullet> q \<and> t = pi \<bullet> u \<and>
+ set pi \<subseteq> (supp p \<union> supp q) \<times> (supp p \<union> supp q)"
+ using assms
+proof (induct p arbitrary: q t u \<Delta>)
+ case (PVar x T)
+ note PVar' = this
+ show ?case
+ proof (cases q)
+ case (PVar x' T')
+ with `(\<lambda>[PVar x T]. t) = (\<lambda>[q]. u)`
+ have "x = x' \<and> t = u \<or> x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
+ by (simp add: btrm.inject alpha)
+ then show ?thesis
+ proof
+ assume "x = x' \<and> t = u"
+ with PVar PVar' have "PVar x T = ([]::name prm) \<bullet> q \<and>
+ t = ([]::name prm) \<bullet> u \<and>
+ set ([]::name prm) \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
+ (supp (PVar x T) \<union> supp q)" by simp
+ then show ?thesis ..
+ next
+ assume "x \<noteq> x' \<and> t = [(x, x')] \<bullet> u \<and> x \<sharp> u"
+ with PVar PVar' have "PVar x T = [(x, x')] \<bullet> q \<and>
+ t = [(x, x')] \<bullet> u \<and>
+ set [(x, x')] \<subseteq> (supp (PVar x T) \<union> supp q) \<times>
+ (supp (PVar x T) \<union> supp q)"
+ by (simp add: perm_swap swap_simps supp_atm perm_type)
+ then show ?thesis ..
+ qed
+ next
+ case (PTuple p\<^isub>1 p\<^isub>2)
+ with PVar have "ty_size (pat_type p\<^isub>1) < ty_size T" by simp
+ then have "Bind T x t \<noteq> (\<lambda>[p\<^isub>1]. \<lambda>[p\<^isub>2]. u)"
+ by (rule bind_tuple_ineq)
+ moreover from PTuple PVar
+ have "Bind T x t = (\<lambda>[p\<^isub>1]. \<lambda>[p\<^isub>2]. u)" by simp
+ ultimately show ?thesis ..
+ qed
+next
+ case (PTuple p\<^isub>1 p\<^isub>2)
+ note PTuple' = this
+ show ?case
+ proof (cases q)
+ case (PVar x T)
+ with PTuple have "ty_size (pat_type p\<^isub>1) < ty_size T" by auto
+ then have "Bind T x u \<noteq> (\<lambda>[p\<^isub>1]. \<lambda>[p\<^isub>2]. t)"
+ by (rule bind_tuple_ineq)
+ moreover from PTuple PVar
+ have "Bind T x u = (\<lambda>[p\<^isub>1]. \<lambda>[p\<^isub>2]. t)" by simp
+ ultimately show ?thesis ..
+ next
+ case (PTuple p\<^isub>1' p\<^isub>2')
+ with PTuple' have "(\<lambda>[p\<^isub>1]. \<lambda>[p\<^isub>2]. t) = (\<lambda>[p\<^isub>1']. \<lambda>[p\<^isub>2']. u)" by simp
+ moreover from PTuple PTuple' have "pat_type p\<^isub>1 = pat_type p\<^isub>1'"
+ by (simp add: ty.inject)
+ moreover from PTuple' have "distinct (pat_vars p\<^isub>1)" by simp
+ moreover from PTuple PTuple' have "distinct (pat_vars p\<^isub>1')" by simp
+ ultimately have "\<exists>pi::name prm. p\<^isub>1 = pi \<bullet> p\<^isub>1' \<and>
+ (\<lambda>[p\<^isub>2]. t) = pi \<bullet> (\<lambda>[p\<^isub>2']. u) \<and>
+ set pi \<subseteq> (supp p\<^isub>1 \<union> supp p\<^isub>1') \<times> (supp p\<^isub>1 \<union> supp p\<^isub>1')"
+ by (rule PTuple')
+ then obtain pi::"name prm" where
+ "p\<^isub>1 = pi \<bullet> p\<^isub>1'" "(\<lambda>[p\<^isub>2]. t) = pi \<bullet> (\<lambda>[p\<^isub>2']. u)" and
+ pi: "set pi \<subseteq> (supp p\<^isub>1 \<union> supp p\<^isub>1') \<times> (supp p\<^isub>1 \<union> supp p\<^isub>1')" by auto
+ from `(\<lambda>[p\<^isub>2]. t) = pi \<bullet> (\<lambda>[p\<^isub>2']. u)`
+ have "(\<lambda>[p\<^isub>2]. t) = (\<lambda>[pi \<bullet> p\<^isub>2']. pi \<bullet> u)"
+ by (simp add: eqvts)
+ moreover from PTuple PTuple' have "pat_type p\<^isub>2 = pat_type (pi \<bullet> p\<^isub>2')"
+ by (simp add: ty.inject pat_type_perm_eq)
+ moreover from PTuple' have "distinct (pat_vars p\<^isub>2)" by simp
+ moreover from PTuple PTuple' have "distinct (pat_vars (pi \<bullet> p\<^isub>2'))"
+ by (simp add: pat_vars_eqvt [symmetric] distinct_eqvt [symmetric])
+ ultimately have "\<exists>pi'::name prm. p\<^isub>2 = pi' \<bullet> pi \<bullet> p\<^isub>2' \<and>
+ t = pi' \<bullet> pi \<bullet> u \<and>
+ set pi' \<subseteq> (supp p\<^isub>2 \<union> supp (pi \<bullet> p\<^isub>2')) \<times> (supp p\<^isub>2 \<union> supp (pi \<bullet> p\<^isub>2'))"
+ by (rule PTuple')
+ then obtain pi'::"name prm" where
+ "p\<^isub>2 = pi' \<bullet> pi \<bullet> p\<^isub>2'" "t = pi' \<bullet> pi \<bullet> u" and
+ pi': "set pi' \<subseteq> (supp p\<^isub>2 \<union> supp (pi \<bullet> p\<^isub>2')) \<times>
+ (supp p\<^isub>2 \<union> supp (pi \<bullet> p\<^isub>2'))" by auto
+ from PTuple PTuple' have "pi \<bullet> distinct (pat_vars \<langle>\<langle>p\<^isub>1', p\<^isub>2'\<rangle>\<rangle>)" by simp
+ then have "distinct (pat_vars \<langle>\<langle>pi \<bullet> p\<^isub>1', pi \<bullet> p\<^isub>2'\<rangle>\<rangle>)" by (simp only: eqvts)
+ with `p\<^isub>1 = pi \<bullet> p\<^isub>1'` PTuple'
+ have fresh: "(supp p\<^isub>2 \<union> supp (pi \<bullet> p\<^isub>2') :: name set) \<sharp>* p\<^isub>1"
+ by (auto simp add: set_pat_vars_supp fresh_star_def fresh_def eqvts)
+ from `p\<^isub>1 = pi \<bullet> p\<^isub>1'` have "pi' \<bullet> (p\<^isub>1 = pi \<bullet> p\<^isub>1')" by (rule perm_boolI)
+ with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' fresh fresh]
+ have "p\<^isub>1 = pi' \<bullet> pi \<bullet> p\<^isub>1'" by (simp add: eqvts)
+ with `p\<^isub>2 = pi' \<bullet> pi \<bullet> p\<^isub>2'` have "\<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> \<langle>\<langle>p\<^isub>1', p\<^isub>2'\<rangle>\<rangle>"
+ by (simp add: pt_name2)
+ moreover
+ have "((supp p\<^isub>2 \<union> (pi \<bullet> supp p\<^isub>2')) \<times> (supp p\<^isub>2 \<union> (pi \<bullet> supp p\<^isub>2'))::(name \<times> name) set) \<subseteq>
+ (supp p\<^isub>2 \<union> (supp p\<^isub>1 \<union> supp p\<^isub>1' \<union> supp p\<^isub>2')) \<times> (supp p\<^isub>2 \<union> (supp p\<^isub>1 \<union> supp p\<^isub>1' \<union> supp p\<^isub>2'))"
+ by (rule subset_refl Sigma_mono Un_mono perm_cases [OF pi])+
+ with pi' have "set pi' \<subseteq> \<dots>" by (simp add: supp_eqvt [symmetric])
+ with pi have "set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^isub>1', p\<^isub>2'\<rangle>\<rangle>) \<times>
+ (supp \<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> \<union> supp \<langle>\<langle>p\<^isub>1', p\<^isub>2'\<rangle>\<rangle>)"
+ by (simp add: Sigma_Un_distrib1 Sigma_Un_distrib2 Un_ac) blast
+ moreover note `t = pi' \<bullet> pi \<bullet> u`
+ ultimately have "\<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> = (pi' @ pi) \<bullet> q \<and> t = (pi' @ pi) \<bullet> u \<and>
+ set (pi' @ pi) \<subseteq> (supp \<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> \<union> supp q) \<times>
+ (supp \<langle>\<langle>p\<^isub>1, p\<^isub>2\<rangle>\<rangle> \<union> supp q)" using PTuple
+ by (simp add: pt_name2)
+ then show ?thesis ..
+ qed
+qed
+
+lemma typing_case_Let:
+ assumes ty: "\<Gamma> \<turnstile> (LET p = t IN u) : U"
+ and fresh: "(supp p::name set) \<sharp>* \<Gamma>"
+ and distinct: "distinct (pat_vars p)"
+ and R: "\<And>T \<Delta>. \<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> p : T \<Rightarrow> \<Delta> \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> u : U \<Longrightarrow> P"
+ shows P using ty
+proof cases
+ case (Let p' t' \<Gamma>' T \<Delta> u' U')
+ then have "(supp \<Delta>::name set) \<sharp>* \<Gamma>"
+ by (auto intro: valid_typing valid_app_freshs)
+ with Let have "(supp p'::name set) \<sharp>* \<Gamma>"
+ by (simp add: pat_var)
+ with fresh have fresh': "(supp p \<union> supp p' :: name set) \<sharp>* \<Gamma>"
+ by (auto simp add: fresh_star_def)
+ from Let have "(\<lambda>[p]. Base u) = (\<lambda>[p']. Base u')"
+ by (simp add: trm.inject)
+ moreover from Let have "pat_type p = pat_type p'"
+ by (simp add: trm.inject)
+ moreover note distinct
+ moreover from `\<Delta> @ \<Gamma>' \<turnstile> u' : U'` have "valid (\<Delta> @ \<Gamma>')"
+ by (rule valid_typing)
+ then have "valid \<Delta>" by (rule valid_appD)
+ with `\<turnstile> p' : T \<Rightarrow> \<Delta>` have "distinct (pat_vars p')"
+ by (simp add: valid_distinct pat_vars_ptyping)
+ ultimately have "\<exists>pi::name prm. p = pi \<bullet> p' \<and> Base u = pi \<bullet> Base u' \<and>
+ set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
+ by (rule abs_pat_alpha')
+ then obtain pi::"name prm" where pi: "p = pi \<bullet> p'" "u = pi \<bullet> u'"
+ and pi': "set pi \<subseteq> (supp p \<union> supp p') \<times> (supp p \<union> supp p')"
+ by (auto simp add: btrm.inject)
+ from Let have "\<Gamma> \<turnstile> t : T" by (simp add: trm.inject)
+ moreover from `\<turnstile> p' : T \<Rightarrow> \<Delta>` have "\<turnstile> (pi \<bullet> p') : (pi \<bullet> T) \<Rightarrow> (pi \<bullet> \<Delta>)"
+ by (simp add: ptyping.eqvt)
+ with pi have "\<turnstile> p : T \<Rightarrow> (pi \<bullet> \<Delta>)" by (simp add: perm_type)
+ moreover from Let
+ have "(pi \<bullet> \<Delta>) @ (pi \<bullet> \<Gamma>) \<turnstile> (pi \<bullet> u') : (pi \<bullet> U)"
+ by (simp add: append_eqvt [symmetric] typing.eqvt)
+ with pi have "(pi \<bullet> \<Delta>) @ \<Gamma> \<turnstile> u : U"
+ by (simp add: perm_type pt_freshs_freshs
+ [OF pt_name_inst at_name_inst pi' fresh' fresh'])
+ ultimately show ?thesis by (rule R)
+qed simp_all
+
+lemma preservation:
+ assumes "t \<longmapsto> t'" and "\<Gamma> \<turnstile> t : T"
+ shows "\<Gamma> \<turnstile> t' : T" using assms
+proof (nominal_induct avoiding: \<Gamma> T rule: eval.strong_induct)
+ case (TupleL t t' u)
+ from `\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T` obtain T\<^isub>1 T\<^isub>2
+ where "T = T\<^isub>1 \<otimes> T\<^isub>2" "\<Gamma> \<turnstile> t : T\<^isub>1" "\<Gamma> \<turnstile> u : T\<^isub>2"
+ by cases (simp_all add: trm.inject)
+ from `\<Gamma> \<turnstile> t : T\<^isub>1` have "\<Gamma> \<turnstile> t' : T\<^isub>1" by (rule TupleL)
+ then have "\<Gamma> \<turnstile> \<langle>t', u\<rangle> : T\<^isub>1 \<otimes> T\<^isub>2" using `\<Gamma> \<turnstile> u : T\<^isub>2`
+ by (rule Tuple)
+ with `T = T\<^isub>1 \<otimes> T\<^isub>2` show ?case by simp
+next
+ case (TupleR u u' t)
+ from `\<Gamma> \<turnstile> \<langle>t, u\<rangle> : T` obtain T\<^isub>1 T\<^isub>2
+ where "T = T\<^isub>1 \<otimes> T\<^isub>2" "\<Gamma> \<turnstile> t : T\<^isub>1" "\<Gamma> \<turnstile> u : T\<^isub>2"
+ by cases (simp_all add: trm.inject)
+ from `\<Gamma> \<turnstile> u : T\<^isub>2` have "\<Gamma> \<turnstile> u' : T\<^isub>2" by (rule TupleR)
+ with `\<Gamma> \<turnstile> t : T\<^isub>1` have "\<Gamma> \<turnstile> \<langle>t, u'\<rangle> : T\<^isub>1 \<otimes> T\<^isub>2"
+ by (rule Tuple)
+ with `T = T\<^isub>1 \<otimes> T\<^isub>2` show ?case by simp
+next
+ case (Abs t t' x S)
+ from `\<Gamma> \<turnstile> (\<lambda>x:S. t) : T` `x \<sharp> \<Gamma>` obtain U where
+ T: "T = S \<rightarrow> U" and U: "(x, S) # \<Gamma> \<turnstile> t : U"
+ by (rule typing_case_Abs)
+ from U have "(x, S) # \<Gamma> \<turnstile> t' : U" by (rule Abs)
+ then have "\<Gamma> \<turnstile> (\<lambda>x:S. t') : S \<rightarrow> U"
+ by (rule typing.Abs)
+ with T show ?case by simp
+next
+ case (Beta x u S t)
+ from `\<Gamma> \<turnstile> (\<lambda>x:S. t) \<cdot> u : T` `x \<sharp> \<Gamma>`
+ obtain "(x, S) # \<Gamma> \<turnstile> t : T" and "\<Gamma> \<turnstile> u : S"
+ by cases (auto simp add: trm.inject ty.inject elim: typing_case_Abs)
+ then show ?case by (rule subst_type)
+next
+ case (Let p t \<theta> u)
+ from `\<Gamma> \<turnstile> (LET p = t IN u) : T` `supp p \<sharp>* \<Gamma>` `distinct (pat_vars p)`
+ obtain U \<Delta> where "\<turnstile> p : U \<Rightarrow> \<Delta>" "\<Gamma> \<turnstile> t : U" "\<Delta> @ \<Gamma> \<turnstile> u : T"
+ by (rule typing_case_Let)
+ then show ?case using `\<turnstile> p \<rhd> t \<Rightarrow> \<theta>` `supp p \<sharp>* t`
+ by (rule match_type)
+next
+ case (AppL t t' u)
+ from `\<Gamma> \<turnstile> t \<cdot> u : T` obtain U where
+ t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
+ by cases (auto simp add: trm.inject)
+ from t have "\<Gamma> \<turnstile> t' : U \<rightarrow> T" by (rule AppL)
+ then show ?case using u by (rule typing.App)
+next
+ case (AppR u u' t)
+ from `\<Gamma> \<turnstile> t \<cdot> u : T` obtain U where
+ t: "\<Gamma> \<turnstile> t : U \<rightarrow> T" and u: "\<Gamma> \<turnstile> u : U"
+ by cases (auto simp add: trm.inject)
+ from u have "\<Gamma> \<turnstile> u' : U" by (rule AppR)
+ with t show ?case by (rule typing.App)
+qed
+
+end--- a/src/HOL/Nominal/nominal_datatype.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Nominal/nominal_datatype.ML Tue Oct 27 14:46:03 2009 +0000
@@ -567,7 +567,7 @@
val rep_set_names'' = map (Sign.full_bname thy3) rep_set_names';
val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy4) =
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = false, verbose = false, kind = Thm.internalK,
alt_name = Binding.name big_rep_name, coind = false, no_elim = true, no_ind = false,
skip_mono = true, fork_mono = false}
@@ -1506,7 +1506,7 @@
val ({intrs = rec_intrs, elims = rec_elims, raw_induct = rec_induct, ...}, thy11) =
thy10 |>
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
alt_name = Binding.name big_rec_name, coind = false, no_elim = false, no_ind = false,
skip_mono = true, fork_mono = false}--- a/src/HOL/Nominal/nominal_primrec.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Nominal/nominal_primrec.ML Tue Oct 27 14:46:03 2009 +0000
@@ -280,7 +280,7 @@
else primrec_err ("functions " ^ commas_quote names2 ^
"\nare not mutually recursive");
val (defs_thms, lthy') = lthy |>
- set_group ? LocalTheory.set_group (serial_string ()) |>
+ set_group ? LocalTheory.set_group (serial ()) |>
fold_map (apfst (snd o snd) oo
LocalTheory.define Thm.definitionK o fst) defs';
val qualify = Binding.qualify false--- a/src/HOL/Predicate.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Predicate.thy Tue Oct 27 14:46:03 2009 +0000
@@ -471,49 +471,49 @@
"is_empty (A \<squnion> B) \<longleftrightarrow> is_empty A \<and> is_empty B"
by (auto simp add: is_empty_def intro: sup_eq_bot_eq1 sup_eq_bot_eq2)
-definition singleton :: "'a pred \<Rightarrow> 'a" where
- "singleton A = (if \<exists>!x. eval A x then THE x. eval A x else undefined)"
+definition singleton :: "(unit => 'a) \<Rightarrow> 'a pred \<Rightarrow> 'a" where
+ "singleton dfault A = (if \<exists>!x. eval A x then THE x. eval A x else dfault ())"
lemma singleton_eqI:
- "\<exists>!x. eval A x \<Longrightarrow> eval A x \<Longrightarrow> singleton A = x"
+ "\<exists>!x. eval A x \<Longrightarrow> eval A x \<Longrightarrow> singleton dfault A = x"
by (auto simp add: singleton_def)
lemma eval_singletonI:
- "\<exists>!x. eval A x \<Longrightarrow> eval A (singleton A)"
+ "\<exists>!x. eval A x \<Longrightarrow> eval A (singleton dfault A)"
proof -
assume assm: "\<exists>!x. eval A x"
then obtain x where "eval A x" ..
- moreover with assm have "singleton A = x" by (rule singleton_eqI)
+ moreover with assm have "singleton dfault A = x" by (rule singleton_eqI)
ultimately show ?thesis by simp
qed
lemma single_singleton:
- "\<exists>!x. eval A x \<Longrightarrow> single (singleton A) = A"
+ "\<exists>!x. eval A x \<Longrightarrow> single (singleton dfault A) = A"
proof -
assume assm: "\<exists>!x. eval A x"
- then have "eval A (singleton A)"
+ then have "eval A (singleton dfault A)"
by (rule eval_singletonI)
- moreover from assm have "\<And>x. eval A x \<Longrightarrow> singleton A = x"
+ moreover from assm have "\<And>x. eval A x \<Longrightarrow> singleton dfault A = x"
by (rule singleton_eqI)
- ultimately have "eval (single (singleton A)) = eval A"
+ ultimately have "eval (single (singleton dfault A)) = eval A"
by (simp (no_asm_use) add: single_def expand_fun_eq) blast
then show ?thesis by (simp add: eval_inject)
qed
lemma singleton_undefinedI:
- "\<not> (\<exists>!x. eval A x) \<Longrightarrow> singleton A = undefined"
+ "\<not> (\<exists>!x. eval A x) \<Longrightarrow> singleton dfault A = dfault ()"
by (simp add: singleton_def)
lemma singleton_bot:
- "singleton \<bottom> = undefined"
+ "singleton dfault \<bottom> = dfault ()"
by (auto simp add: bot_pred_def intro: singleton_undefinedI)
lemma singleton_single:
- "singleton (single x) = x"
+ "singleton dfault (single x) = x"
by (auto simp add: intro: singleton_eqI singleI elim: singleE)
lemma singleton_sup_single_single:
- "singleton (single x \<squnion> single y) = (if x = y then x else undefined)"
+ "singleton dfault (single x \<squnion> single y) = (if x = y then x else dfault ())"
proof (cases "x = y")
case True then show ?thesis by (simp add: singleton_single)
next
@@ -523,25 +523,25 @@
by (auto intro: supI1 supI2 singleI)
with False have "\<not> (\<exists>!z. eval (single x \<squnion> single y) z)"
by blast
- then have "singleton (single x \<squnion> single y) = undefined"
+ then have "singleton dfault (single x \<squnion> single y) = dfault ()"
by (rule singleton_undefinedI)
with False show ?thesis by simp
qed
lemma singleton_sup_aux:
- "singleton (A \<squnion> B) = (if A = \<bottom> then singleton B
- else if B = \<bottom> then singleton A
- else singleton
- (single (singleton A) \<squnion> single (singleton B)))"
+ "singleton dfault (A \<squnion> B) = (if A = \<bottom> then singleton dfault B
+ else if B = \<bottom> then singleton dfault A
+ else singleton dfault
+ (single (singleton dfault A) \<squnion> single (singleton dfault B)))"
proof (cases "(\<exists>!x. eval A x) \<and> (\<exists>!y. eval B y)")
case True then show ?thesis by (simp add: single_singleton)
next
case False
from False have A_or_B:
- "singleton A = undefined \<or> singleton B = undefined"
+ "singleton dfault A = dfault () \<or> singleton dfault B = dfault ()"
by (auto intro!: singleton_undefinedI)
- then have rhs: "singleton
- (single (singleton A) \<squnion> single (singleton B)) = undefined"
+ then have rhs: "singleton dfault
+ (single (singleton dfault A) \<squnion> single (singleton dfault B)) = dfault ()"
by (auto simp add: singleton_sup_single_single singleton_single)
from False have not_unique:
"\<not> (\<exists>!x. eval A x) \<or> \<not> (\<exists>!y. eval B y)" by simp
@@ -551,7 +551,7 @@
by (blast elim: not_bot)
with True not_unique have "\<not> (\<exists>!x. eval (A \<squnion> B) x)"
by (auto simp add: sup_pred_def bot_pred_def)
- then have "singleton (A \<squnion> B) = undefined" by (rule singleton_undefinedI)
+ then have "singleton dfault (A \<squnion> B) = dfault ()" by (rule singleton_undefinedI)
with True rhs show ?thesis by simp
next
case False then show ?thesis by auto
@@ -559,10 +559,10 @@
qed
lemma singleton_sup:
- "singleton (A \<squnion> B) = (if A = \<bottom> then singleton B
- else if B = \<bottom> then singleton A
- else if singleton A = singleton B then singleton A else undefined)"
-using singleton_sup_aux [of A B] by (simp only: singleton_sup_single_single)
+ "singleton dfault (A \<squnion> B) = (if A = \<bottom> then singleton dfault B
+ else if B = \<bottom> then singleton dfault A
+ else if singleton dfault A = singleton dfault B then singleton dfault A else dfault ())"
+using singleton_sup_aux [of dfault A B] by (simp only: singleton_sup_single_single)
subsubsection {* Derived operations *}
@@ -743,36 +743,43 @@
"is_empty (Seq f) \<longleftrightarrow> null (f ())"
by (simp add: null_is_empty Seq_def)
-primrec the_only :: "'a seq \<Rightarrow> 'a" where
- [code del]: "the_only Empty = undefined"
- | "the_only (Insert x P) = (if is_empty P then x else let y = singleton P in if x = y then x else undefined)"
- | "the_only (Join P xq) = (if is_empty P then the_only xq else if null xq then singleton P
- else let x = singleton P; y = the_only xq in
- if x = y then x else undefined)"
+primrec the_only :: "(unit \<Rightarrow> 'a) \<Rightarrow> 'a seq \<Rightarrow> 'a" where
+ [code del]: "the_only dfault Empty = dfault ()"
+ | "the_only dfault (Insert x P) = (if is_empty P then x else let y = singleton dfault P in if x = y then x else dfault ())"
+ | "the_only dfault (Join P xq) = (if is_empty P then the_only dfault xq else if null xq then singleton dfault P
+ else let x = singleton dfault P; y = the_only dfault xq in
+ if x = y then x else dfault ())"
lemma the_only_singleton:
- "the_only xq = singleton (pred_of_seq xq)"
+ "the_only dfault xq = singleton dfault (pred_of_seq xq)"
by (induct xq)
(auto simp add: singleton_bot singleton_single is_empty_def
null_is_empty Let_def singleton_sup)
lemma singleton_code [code]:
- "singleton (Seq f) = (case f ()
- of Empty \<Rightarrow> undefined
+ "singleton dfault (Seq f) = (case f ()
+ of Empty \<Rightarrow> dfault ()
| Insert x P \<Rightarrow> if is_empty P then x
- else let y = singleton P in
- if x = y then x else undefined
- | Join P xq \<Rightarrow> if is_empty P then the_only xq
- else if null xq then singleton P
- else let x = singleton P; y = the_only xq in
- if x = y then x else undefined)"
+ else let y = singleton dfault P in
+ if x = y then x else dfault ()
+ | Join P xq \<Rightarrow> if is_empty P then the_only dfault xq
+ else if null xq then singleton dfault P
+ else let x = singleton dfault P; y = the_only dfault xq in
+ if x = y then x else dfault ())"
by (cases "f ()")
(auto simp add: Seq_def the_only_singleton is_empty_def
null_is_empty singleton_bot singleton_single singleton_sup Let_def)
-lemma meta_fun_cong:
-"f == g ==> f x == g x"
-by simp
+definition not_unique :: "'a pred => 'a"
+where
+ [code del]: "not_unique A = (THE x. eval A x)"
+
+definition the :: "'a pred => 'a"
+where
+ [code del]: "the A = (THE x. eval A x)"
+
+lemma the_eq[code]: "the A = singleton (\<lambda>x. not_unique A) A"
+by (auto simp add: the_def singleton_def not_unique_def)
ML {*
signature PREDICATE =
@@ -819,6 +826,8 @@
code_const Seq and Empty and Insert and Join
(Eval "Predicate.Seq" and "Predicate.Empty" and "Predicate.Insert/ (_,/ _)" and "Predicate.Join/ (_,/ _)")
+code_abort not_unique
+
text {* dummy setup for @{text code_pred} and @{text values} keywords *}
ML {*
@@ -852,6 +861,6 @@
hide (open) type pred seq
hide (open) const Pred eval single bind is_empty singleton if_pred not_pred
- Empty Insert Join Seq member pred_of_seq "apply" adjunct null the_only eq map
+ Empty Insert Join Seq member pred_of_seq "apply" adjunct null the_only eq map not_unique the
end--- a/src/HOL/Product_Type.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Product_Type.thy Tue Oct 27 14:46:03 2009 +0000
@@ -6,7 +6,7 @@
header {* Cartesian products *}
theory Product_Type
-imports Inductive
+imports Inductive Nat
uses
("Tools/split_rule.ML")
("Tools/inductive_set.ML")--- a/src/HOL/Rational.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Rational.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1063,4 +1063,23 @@
fun rat_of_int i = (i, 1);
*}
+setup {*
+ Nitpick.register_frac_type @{type_name rat}
+ [(@{const_name zero_rat_inst.zero_rat}, @{const_name Nitpick.zero_frac}),
+ (@{const_name one_rat_inst.one_rat}, @{const_name Nitpick.one_frac}),
+ (@{const_name plus_rat_inst.plus_rat}, @{const_name Nitpick.plus_frac}),
+ (@{const_name times_rat_inst.times_rat}, @{const_name Nitpick.times_frac}),
+ (@{const_name uminus_rat_inst.uminus_rat}, @{const_name Nitpick.uminus_frac}),
+ (@{const_name number_rat_inst.number_of_rat}, @{const_name Nitpick.number_of_frac}),
+ (@{const_name inverse_rat_inst.inverse_rat}, @{const_name Nitpick.inverse_frac}),
+ (@{const_name ord_rat_inst.less_eq_rat}, @{const_name Nitpick.less_eq_frac}),
+ (@{const_name field_char_0_class.of_rat}, @{const_name Nitpick.of_frac}),
+ (@{const_name field_char_0_class.Rats}, @{const_name UNIV})]
+*}
+
+lemmas [nitpick_def] = inverse_rat_inst.inverse_rat
+ number_rat_inst.number_of_rat one_rat_inst.one_rat ord_rat_inst.less_eq_rat
+ plus_rat_inst.plus_rat times_rat_inst.times_rat uminus_rat_inst.uminus_rat
+ zero_rat_inst.zero_rat
+
end--- a/src/HOL/RealDef.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/RealDef.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1185,4 +1185,22 @@
fun real_of_int i = (i, 1);
*}
+setup {*
+ Nitpick.register_frac_type @{type_name real}
+ [(@{const_name zero_real_inst.zero_real}, @{const_name Nitpick.zero_frac}),
+ (@{const_name one_real_inst.one_real}, @{const_name Nitpick.one_frac}),
+ (@{const_name plus_real_inst.plus_real}, @{const_name Nitpick.plus_frac}),
+ (@{const_name times_real_inst.times_real}, @{const_name Nitpick.times_frac}),
+ (@{const_name uminus_real_inst.uminus_real}, @{const_name Nitpick.uminus_frac}),
+ (@{const_name number_real_inst.number_of_real}, @{const_name Nitpick.number_of_frac}),
+ (@{const_name inverse_real_inst.inverse_real}, @{const_name Nitpick.inverse_frac}),
+ (@{const_name ord_real_inst.less_eq_real}, @{const_name Nitpick.less_eq_frac})]
+*}
+
+lemmas [nitpick_def] = inverse_real_inst.inverse_real
+ number_real_inst.number_of_real one_real_inst.one_real
+ ord_real_inst.less_eq_real plus_real_inst.plus_real
+ times_real_inst.times_real uminus_real_inst.uminus_real
+ zero_real_inst.zero_real
+
end--- a/src/HOL/Relation.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Relation.thy Tue Oct 27 14:46:03 2009 +0000
@@ -607,6 +607,9 @@
lemma in_inv_image[simp]: "((x,y) : inv_image r f) = ((f x, f y) : r)"
by (auto simp:inv_image_def)
+lemma converse_inv_image[simp]: "(inv_image R f)^-1 = inv_image (R^-1) f"
+unfolding inv_image_def converse_def by auto
+
subsection {* Finiteness *}
--- a/src/HOL/SizeChange/sct.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/SizeChange/sct.ML Tue Oct 27 14:46:03 2009 +0000
@@ -112,7 +112,7 @@
end
fun bind_many [] = I
- | bind_many vs = FundefLib.tupled_lambda (foldr1 HOLogic.mk_prod vs)
+ | bind_many vs = Function_Lib.tupled_lambda (foldr1 HOLogic.mk_prod vs)
(* Builds relation descriptions from a relation definition *)
fun mk_reldescs (Abs a) =--- a/src/HOL/Tools/ATP_Manager/atp_manager.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/ATP_Manager/atp_manager.ML Tue Oct 27 14:46:03 2009 +0000
@@ -271,7 +271,7 @@
Markup.markup Markup.sendback "apply metis")
| ERROR msg => (false, "Error: " ^ msg);
val _ = unregister result (Thread.self ());
- in () end handle Exn.Interrupt => ())
+ in () end)
in () end);
--- a/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Tue Oct 27 14:46:03 2009 +0000
@@ -153,7 +153,7 @@
(descr' ~~ recTs ~~ rec_sets') ([], 0);
val ({intrs = rec_intrs, elims = rec_elims, ...}, thy1) =
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
alt_name = Binding.name big_rec_name', coind = false, no_elim = false, no_ind = true,
skip_mono = true, fork_mono = false}
@@ -321,7 +321,7 @@
fns2 @ (flat (Library.drop (i + 1, case_dummy_fns))) )));
val ([def_thm], thy') =
thy
- |> Sign.declare_const [] decl |> snd
+ |> Sign.declare_const decl |> snd
|> (PureThy.add_defs false o map Thm.no_attributes) [def];
in (defs @ [def_thm], thy')--- a/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Tue Oct 27 14:46:03 2009 +0000
@@ -170,7 +170,7 @@
((1 upto (length constrs)) ~~ constrs)) (descr' ~~ rep_set_names');
val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
alt_name = Binding.name big_rec_name, coind = false, no_elim = true, no_ind = false,
skip_mono = true, fork_mono = false}--- a/src/HOL/Tools/Function/auto_term.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-(* Title: HOL/Tools/Function/auto_term.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions.
-Method "relation" to commence a termination proof using a user-specified relation.
-*)
-
-signature FUNDEF_RELATION =
-sig
- val relation_tac: Proof.context -> term -> int -> tactic
- val setup: theory -> theory
-end
-
-structure FundefRelation : FUNDEF_RELATION =
-struct
-
-fun inst_thm ctxt rel st =
- let
- val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
- val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
- val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
- val Rvar = cert (Var (the_single (Term.add_vars (prop_of st') [])))
- in
- Drule.cterm_instantiate [(Rvar, rel')] st'
- end
-
-fun relation_tac ctxt rel i =
- TRY (FundefCommon.apply_termination_rule ctxt i)
- THEN PRIMITIVE (inst_thm ctxt rel)
-
-val setup =
- Method.setup @{binding relation}
- (Args.term >> (fn rel => fn ctxt => SIMPLE_METHOD' (relation_tac ctxt rel)))
- "proves termination using a user-specified wellfounded relation"
-
-end--- a/src/HOL/Tools/Function/context_tree.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/context_tree.ML Tue Oct 27 14:46:03 2009 +0000
@@ -5,15 +5,15 @@
Builds and traverses trees of nested contexts along a term.
*)
-signature FUNDEF_CTXTREE =
+signature FUNCTION_CTXTREE =
sig
type ctxt = (string * typ) list * thm list (* poor man's contexts: fixes + assumes *)
type ctx_tree
(* FIXME: This interface is a mess and needs to be cleaned up! *)
- val get_fundef_congs : Proof.context -> thm list
- val add_fundef_cong : thm -> Context.generic -> Context.generic
- val map_fundef_congs : (thm list -> thm list) -> Context.generic -> Context.generic
+ val get_function_congs : Proof.context -> thm list
+ val add_function_cong : thm -> Context.generic -> Context.generic
+ val map_function_congs : (thm list -> thm list) -> Context.generic -> Context.generic
val cong_add: attribute
val cong_del: attribute
@@ -36,15 +36,15 @@
val rewrite_by_tree : theory -> term -> thm -> (thm * thm) list -> ctx_tree -> thm * (thm * thm) list
end
-structure FundefCtxTree : FUNDEF_CTXTREE =
+structure Function_Ctx_Tree : FUNCTION_CTXTREE =
struct
type ctxt = (string * typ) list * thm list
-open FundefCommon
-open FundefLib
+open Function_Common
+open Function_Lib
-structure FundefCongs = GenericDataFun
+structure FunctionCongs = GenericDataFun
(
type T = thm list
val empty = []
@@ -52,14 +52,14 @@
fun merge _ = Thm.merge_thms
);
-val get_fundef_congs = FundefCongs.get o Context.Proof
-val map_fundef_congs = FundefCongs.map
-val add_fundef_cong = FundefCongs.map o Thm.add_thm
+val get_function_congs = FunctionCongs.get o Context.Proof
+val map_function_congs = FunctionCongs.map
+val add_function_cong = FunctionCongs.map o Thm.add_thm
(* congruence rules *)
-val cong_add = Thm.declaration_attribute (map_fundef_congs o Thm.add_thm o safe_mk_meta_eq);
-val cong_del = Thm.declaration_attribute (map_fundef_congs o Thm.del_thm o safe_mk_meta_eq);
+val cong_add = Thm.declaration_attribute (map_function_congs o Thm.add_thm o safe_mk_meta_eq);
+val cong_del = Thm.declaration_attribute (map_function_congs o Thm.del_thm o safe_mk_meta_eq);
type depgraph = int IntGraph.T
@@ -128,7 +128,7 @@
fun mk_tree fvar h ctxt t =
let
- val congs = get_fundef_congs ctxt
+ val congs = get_function_congs ctxt
val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs) (* FIXME: Save in theory *)
fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE--- a/src/HOL/Tools/Function/decompose.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/decompose.ML Tue Oct 27 14:46:03 2009 +0000
@@ -33,8 +33,8 @@
Const (@{const_name Set.empty}, fastype_of c1))
|> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *)
- val chain = case FundefLib.try_proof (cterm_of thy goal) chain_tac of
- FundefLib.Solved thm => SOME thm
+ val chain = case Function_Lib.try_proof (cterm_of thy goal) chain_tac of
+ Function_Lib.Solved thm => SOME thm
| _ => NONE
in
Termination.note_chain c1 c2 chain D
@@ -62,7 +62,7 @@
let
val is = map (fn c => find_index (curry op aconv c) cs') cs
in
- CONVERSION (Conv.arg_conv (Conv.arg_conv (FundefLib.regroup_union_conv is))) i
+ CONVERSION (Conv.arg_conv (Conv.arg_conv (Function_Lib.regroup_union_conv is))) i
end)
--- a/src/HOL/Tools/Function/descent.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/descent.ML Tue Oct 27 14:46:03 2009 +0000
@@ -35,7 +35,7 @@
(measures_of p) (measures_of q) D
end
in
- cont (FundefCommon.PROFILE "deriving descents" (fold derive cs) D) i
+ cont (Function_Common.PROFILE "deriving descents" (fold derive cs) D) i
end)
val derive_diag = gen_descent true--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/fun.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,178 @@
+(* Title: HOL/Tools/Function/fun.ML
+ Author: Alexander Krauss, TU Muenchen
+
+Sequential mode for function definitions
+Command "fun" for fully automated function definitions
+*)
+
+signature FUNCTION_FUN =
+sig
+ val add_fun : Function_Common.function_config ->
+ (binding * typ option * mixfix) list -> (Attrib.binding * term) list ->
+ bool -> local_theory -> Proof.context
+ val add_fun_cmd : Function_Common.function_config ->
+ (binding * string option * mixfix) list -> (Attrib.binding * string) list ->
+ bool -> local_theory -> Proof.context
+
+ val setup : theory -> theory
+end
+
+structure Function_Fun : FUNCTION_FUN =
+struct
+
+open Function_Lib
+open Function_Common
+
+
+fun check_pats ctxt geq =
+ let
+ fun err str = error (cat_lines ["Malformed definition:",
+ str ^ " not allowed in sequential mode.",
+ Syntax.string_of_term ctxt geq])
+ val thy = ProofContext.theory_of ctxt
+
+ fun check_constr_pattern (Bound _) = ()
+ | check_constr_pattern t =
+ let
+ val (hd, args) = strip_comb t
+ in
+ (((case Datatype.info_of_constr thy (dest_Const hd) of
+ SOME _ => ()
+ | NONE => err "Non-constructor pattern")
+ handle TERM ("dest_Const", _) => err "Non-constructor patterns");
+ map check_constr_pattern args;
+ ())
+ end
+
+ val (fname, qs, gs, args, rhs) = split_def ctxt geq
+
+ val _ = if not (null gs) then err "Conditional equations" else ()
+ val _ = map check_constr_pattern args
+
+ (* just count occurrences to check linearity *)
+ val _ = if fold (fold_aterms (fn Bound _ => Integer.add 1 | _ => I)) args 0 > length qs
+ then err "Nonlinear patterns" else ()
+ in
+ ()
+ end
+
+val by_pat_completeness_auto =
+ Proof.global_future_terminal_proof
+ (Method.Basic Pat_Completeness.pat_completeness,
+ SOME (Method.Source_i (Args.src (("HOL.auto", []), Position.none))))
+
+fun termination_by method int =
+ Function.termination_proof NONE
+ #> Proof.global_future_terminal_proof (Method.Basic method, NONE) int
+
+fun mk_catchall fixes arity_of =
+ let
+ fun mk_eqn ((fname, fT), _) =
+ let
+ val n = arity_of fname
+ val (argTs, rT) = chop n (binder_types fT)
+ |> apsnd (fn Ts => Ts ---> body_type fT)
+
+ val qs = map Free (Name.invent_list [] "a" n ~~ argTs)
+ in
+ HOLogic.mk_eq(list_comb (Free (fname, fT), qs),
+ Const ("HOL.undefined", rT))
+ |> HOLogic.mk_Trueprop
+ |> fold_rev Logic.all qs
+ end
+ in
+ map mk_eqn fixes
+ end
+
+fun add_catchall ctxt fixes spec =
+ let val fqgars = map (split_def ctxt) spec
+ val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
+ |> AList.lookup (op =) #> the
+ in
+ spec @ mk_catchall fixes arity_of
+ end
+
+fun warn_if_redundant ctxt origs tss =
+ let
+ fun msg t = "Ignoring redundant equation: " ^ quote (Syntax.string_of_term ctxt t)
+
+ val (tss', _) = chop (length origs) tss
+ fun check (t, []) = (warning (msg t); [])
+ | check (t, s) = s
+ in
+ (map check (origs ~~ tss'); tss)
+ end
+
+
+fun sequential_preproc (config as FunctionConfig {sequential, ...}) ctxt fixes spec =
+ if sequential then
+ let
+ val (bnds, eqss) = split_list spec
+
+ val eqs = map the_single eqss
+
+ val feqs = eqs
+ |> tap (check_defs ctxt fixes) (* Standard checks *)
+ |> tap (map (check_pats ctxt)) (* More checks for sequential mode *)
+
+ val compleqs = add_catchall ctxt fixes feqs (* Completion *)
+
+ val spliteqs = warn_if_redundant ctxt feqs
+ (Function_Split.split_all_equations ctxt compleqs)
+
+ fun restore_spec thms =
+ bnds ~~ Library.take (length bnds, Library.unflat spliteqs thms)
+
+ val spliteqs' = flat (Library.take (length bnds, spliteqs))
+ val fnames = map (fst o fst) fixes
+ val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
+
+ fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs)
+ |> map (map snd)
+
+
+ val bnds' = bnds @ replicate (length spliteqs - length bnds) Attrib.empty_binding
+
+ (* using theorem names for case name currently disabled *)
+ val case_names = map_index (fn (i, (_, es)) => mk_case_names i "" (length es))
+ (bnds' ~~ spliteqs)
+ |> flat
+ in
+ (flat spliteqs, restore_spec, sort, case_names)
+ end
+ else
+ Function_Common.empty_preproc check_defs config ctxt fixes spec
+
+val setup =
+ Context.theory_map (Function_Common.set_preproc sequential_preproc)
+
+
+val fun_config = FunctionConfig { sequential=true, default="%x. undefined" (*FIXME dynamic scoping*),
+ domintros=false, partials=false, tailrec=false }
+
+fun gen_fun add config fixes statements int lthy =
+ let val group = serial () in
+ lthy
+ |> LocalTheory.set_group group
+ |> add fixes statements config
+ |> by_pat_completeness_auto int
+ |> LocalTheory.restore
+ |> LocalTheory.set_group group
+ |> termination_by (Function_Common.get_termination_prover lthy) int
+ end;
+
+val add_fun = gen_fun Function.add_function
+val add_fun_cmd = gen_fun Function.add_function_cmd
+
+
+
+local structure P = OuterParse and K = OuterKeyword in
+
+val _ =
+ OuterSyntax.local_theory' "fun" "define general recursive functions (short version)" K.thy_decl
+ (function_parser fun_config
+ >> (fn ((config, fixes), statements) => add_fun_cmd config fixes statements));
+
+end
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/function.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,227 @@
+(* Title: HOL/Tools/Function/fundef.ML
+ Author: Alexander Krauss, TU Muenchen
+
+A package for general recursive function definitions.
+Isar commands.
+*)
+
+signature FUNCTION =
+sig
+ val add_function : (binding * typ option * mixfix) list
+ -> (Attrib.binding * term) list
+ -> Function_Common.function_config
+ -> local_theory
+ -> Proof.state
+ val add_function_cmd : (binding * string option * mixfix) list
+ -> (Attrib.binding * string) list
+ -> Function_Common.function_config
+ -> local_theory
+ -> Proof.state
+
+ val termination_proof : term option -> local_theory -> Proof.state
+ val termination_proof_cmd : string option -> local_theory -> Proof.state
+ val termination : term option -> local_theory -> Proof.state
+ val termination_cmd : string option -> local_theory -> Proof.state
+
+ val setup : theory -> theory
+ val get_congs : Proof.context -> thm list
+end
+
+
+structure Function : FUNCTION =
+struct
+
+open Function_Lib
+open Function_Common
+
+val simp_attribs = map (Attrib.internal o K)
+ [Simplifier.simp_add,
+ Code.add_default_eqn_attribute,
+ Nitpick_Simps.add,
+ Quickcheck_RecFun_Simps.add]
+
+val psimp_attribs = map (Attrib.internal o K)
+ [Simplifier.simp_add,
+ Nitpick_Psimps.add]
+
+fun note_theorem ((name, atts), ths) =
+ LocalTheory.note Thm.generatedK ((Binding.qualified_name name, atts), ths)
+
+fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
+
+fun add_simps fnames post sort extra_qualify label moreatts simps lthy =
+ let
+ val spec = post simps
+ |> map (apfst (apsnd (fn ats => moreatts @ ats)))
+ |> map (apfst (apfst extra_qualify))
+
+ val (saved_spec_simps, lthy) =
+ fold_map (LocalTheory.note Thm.generatedK) spec lthy
+
+ val saved_simps = maps snd saved_spec_simps
+ val simps_by_f = sort saved_simps
+
+ fun add_for_f fname simps =
+ note_theorem ((Long_Name.qualify fname label, []), simps) #> snd
+ in
+ (saved_simps,
+ fold2 add_for_f fnames simps_by_f lthy)
+ end
+
+fun gen_add_function is_external prep default_constraint fixspec eqns config lthy =
+ let
+ val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
+ val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
+ val fixes = map (apfst (apfst Binding.name_of)) fixes0;
+ val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
+ val (eqs, post, sort_cont, cnames) = get_preproc lthy config ctxt' fixes spec
+
+ val defname = mk_defname fixes
+ val FunctionConfig {partials, ...} = config
+
+ val ((goalstate, cont), lthy) =
+ Function_Mutual.prepare_function_mutual config defname fixes eqs lthy
+
+ fun afterqed [[proof]] lthy =
+ let
+ val FunctionResult {fs, R, psimps, trsimps, simple_pinducts, termination,
+ domintros, cases, ...} =
+ cont (Thm.close_derivation proof)
+
+ val fnames = map (fst o fst) fixes
+ val qualify = Long_Name.qualify defname
+ val addsmps = add_simps fnames post sort_cont
+
+ val (((psimps', pinducts'), (_, [termination'])), lthy) =
+ lthy
+ |> addsmps (Binding.qualify false "partial") "psimps"
+ psimp_attribs psimps
+ ||> fold_option (snd oo addsmps I "simps" simp_attribs) trsimps
+ ||>> note_theorem ((qualify "pinduct",
+ [Attrib.internal (K (RuleCases.case_names cnames)),
+ Attrib.internal (K (RuleCases.consumes 1)),
+ Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
+ ||>> note_theorem ((qualify "termination", []), [termination])
+ ||> (snd o note_theorem ((qualify "cases",
+ [Attrib.internal (K (RuleCases.case_names cnames))]), [cases]))
+ ||> fold_option (snd oo curry note_theorem (qualify "domintros", [])) domintros
+
+ val cdata = FunctionCtxData { add_simps=addsmps, case_names=cnames, psimps=psimps',
+ pinducts=snd pinducts', termination=termination',
+ fs=fs, R=R, defname=defname }
+ val _ =
+ if not is_external then ()
+ else Specification.print_consts lthy (K false) (map fst fixes)
+ in
+ lthy
+ |> LocalTheory.declaration (add_function_data o morph_function_data cdata)
+ end
+ in
+ lthy
+ |> is_external ? LocalTheory.set_group (serial ())
+ |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
+ |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
+ end
+
+val add_function = gen_add_function false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
+val add_function_cmd = gen_add_function true Specification.read_spec "_::type"
+
+fun gen_termination_proof prep_term raw_term_opt lthy =
+ let
+ val term_opt = Option.map (prep_term lthy) raw_term_opt
+ val data = the (case term_opt of
+ SOME t => (import_function_data t lthy
+ handle Option.Option =>
+ error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
+ | NONE => (import_last_function lthy handle Option.Option => error "Not a function"))
+
+ val FunctionCtxData { termination, R, add_simps, case_names, psimps,
+ pinducts, defname, ...} = data
+ val domT = domain_type (fastype_of R)
+ val goal = HOLogic.mk_Trueprop
+ (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
+ fun afterqed [[totality]] lthy =
+ let
+ val totality = Thm.close_derivation totality
+ val remove_domain_condition =
+ full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
+ val tsimps = map remove_domain_condition psimps
+ val tinduct = map remove_domain_condition pinducts
+ val qualify = Long_Name.qualify defname;
+ in
+ lthy
+ |> add_simps I "simps" simp_attribs tsimps |> snd
+ |> note_theorem
+ ((qualify "induct",
+ [Attrib.internal (K (RuleCases.case_names case_names))]),
+ tinduct) |> snd
+ end
+ in
+ lthy
+ |> ProofContext.note_thmss ""
+ [((Binding.empty, [ContextRules.rule_del]), [([allI], [])])] |> snd
+ |> ProofContext.note_thmss ""
+ [((Binding.empty, [ContextRules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
+ |> ProofContext.note_thmss ""
+ [((Binding.name "termination", [ContextRules.intro_bang (SOME 0)]),
+ [([Goal.norm_result termination], [])])] |> snd
+ |> Proof.theorem_i NONE afterqed [[(goal, [])]]
+ end
+
+val termination_proof = gen_termination_proof Syntax.check_term;
+val termination_proof_cmd = gen_termination_proof Syntax.read_term;
+
+fun termination term_opt lthy =
+ lthy
+ |> LocalTheory.set_group (serial ())
+ |> termination_proof term_opt;
+
+fun termination_cmd term_opt lthy =
+ lthy
+ |> LocalTheory.set_group (serial ())
+ |> termination_proof_cmd term_opt;
+
+
+(* Datatype hook to declare datatype congs as "function_congs" *)
+
+
+fun add_case_cong n thy =
+ Context.theory_map (Function_Ctx_Tree.map_function_congs (Thm.add_thm
+ (Datatype.the_info thy n
+ |> #case_cong
+ |> safe_mk_meta_eq)))
+ thy
+
+val setup_case_cong = Datatype.interpretation (K (fold add_case_cong))
+
+
+(* setup *)
+
+val setup =
+ Attrib.setup @{binding fundef_cong}
+ (Attrib.add_del Function_Ctx_Tree.cong_add Function_Ctx_Tree.cong_del)
+ "declaration of congruence rule for function definitions"
+ #> setup_case_cong
+ #> Function_Relation.setup
+ #> Function_Common.Termination_Simps.setup
+
+val get_congs = Function_Ctx_Tree.get_function_congs
+
+
+(* outer syntax *)
+
+local structure P = OuterParse and K = OuterKeyword in
+
+val _ =
+ OuterSyntax.local_theory_to_proof "function" "define general recursive functions" K.thy_goal
+ (function_parser default_config
+ >> (fn ((config, fixes), statements) => add_function_cmd fixes statements config));
+
+val _ =
+ OuterSyntax.local_theory_to_proof "termination" "prove termination of a recursive function" K.thy_goal
+ (Scan.option P.term >> termination_cmd);
+
+end;
+
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/function_common.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,348 @@
+(* Title: HOL/Tools/Function/fundef_common.ML
+ Author: Alexander Krauss, TU Muenchen
+
+A package for general recursive function definitions.
+Common definitions and other infrastructure.
+*)
+
+structure Function_Common =
+struct
+
+local open Function_Lib in
+
+(* Profiling *)
+val profile = Unsynchronized.ref false;
+
+fun PROFILE msg = if !profile then timeap_msg msg else I
+
+
+val acc_const_name = @{const_name accp}
+fun mk_acc domT R =
+ Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R
+
+val function_name = suffix "C"
+val graph_name = suffix "_graph"
+val rel_name = suffix "_rel"
+val dom_name = suffix "_dom"
+
+(* Termination rules *)
+
+structure TerminationRule = GenericDataFun
+(
+ type T = thm list
+ val empty = []
+ val extend = I
+ fun merge _ = Thm.merge_thms
+);
+
+val get_termination_rules = TerminationRule.get
+val store_termination_rule = TerminationRule.map o cons
+val apply_termination_rule = resolve_tac o get_termination_rules o Context.Proof
+
+
+(* Function definition result data *)
+
+datatype function_result =
+ FunctionResult of
+ {
+ fs: term list,
+ G: term,
+ R: term,
+
+ psimps : thm list,
+ trsimps : thm list option,
+
+ simple_pinducts : thm list,
+ cases : thm,
+ termination : thm,
+ domintros : thm list option
+ }
+
+
+datatype function_context_data =
+ FunctionCtxData of
+ {
+ defname : string,
+
+ (* contains no logical entities: invariant under morphisms *)
+ add_simps : (binding -> binding) -> string -> Attrib.src list -> thm list
+ -> local_theory -> thm list * local_theory,
+ case_names : string list,
+
+ fs : term list,
+ R : term,
+
+ psimps: thm list,
+ pinducts: thm list,
+ termination: thm
+ }
+
+fun morph_function_data (FunctionCtxData {add_simps, case_names, fs, R,
+ psimps, pinducts, termination, defname}) phi =
+ let
+ val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi
+ val name = Binding.name_of o Morphism.binding phi o Binding.name
+ in
+ FunctionCtxData { add_simps = add_simps, case_names = case_names,
+ fs = map term fs, R = term R, psimps = fact psimps,
+ pinducts = fact pinducts, termination = thm termination,
+ defname = name defname }
+ end
+
+structure FunctionData = GenericDataFun
+(
+ type T = (term * function_context_data) Item_Net.T;
+ val empty = Item_Net.init
+ (op aconv o pairself fst : (term * function_context_data) * (term * function_context_data) -> bool)
+ fst;
+ val copy = I;
+ val extend = I;
+ fun merge _ (tab1, tab2) = Item_Net.merge (tab1, tab2)
+);
+
+val get_function = FunctionData.get o Context.Proof;
+
+
+(* Generally useful?? *)
+fun lift_morphism thy f =
+ let
+ val term = Drule.term_rule thy f
+ in
+ Morphism.thm_morphism f $> Morphism.term_morphism term
+ $> Morphism.typ_morphism (Logic.type_map term)
+ end
+
+fun import_function_data t ctxt =
+ let
+ val thy = ProofContext.theory_of ctxt
+ val ct = cterm_of thy t
+ val inst_morph = lift_morphism thy o Thm.instantiate
+
+ fun match (trm, data) =
+ SOME (morph_function_data data (inst_morph (Thm.match (cterm_of thy trm, ct))))
+ handle Pattern.MATCH => NONE
+ in
+ get_first match (Item_Net.retrieve (get_function ctxt) t)
+ end
+
+fun import_last_function ctxt =
+ case Item_Net.content (get_function ctxt) of
+ [] => NONE
+ | (t, data) :: _ =>
+ let
+ val ([t'], ctxt') = Variable.import_terms true [t] ctxt
+ in
+ import_function_data t' ctxt'
+ end
+
+val all_function_data = Item_Net.content o get_function
+
+fun add_function_data (data as FunctionCtxData {fs, termination, ...}) =
+ FunctionData.map (fold (fn f => Item_Net.insert (f, data)) fs)
+ #> store_termination_rule termination
+
+
+(* Simp rules for termination proofs *)
+
+structure Termination_Simps = Named_Thms
+(
+ val name = "termination_simp"
+ val description = "Simplification rule for termination proofs"
+);
+
+
+(* Default Termination Prover *)
+
+structure TerminationProver = GenericDataFun
+(
+ type T = Proof.context -> Proof.method
+ val empty = (fn _ => error "Termination prover not configured")
+ val extend = I
+ fun merge _ (a,b) = b (* FIXME *)
+);
+
+val set_termination_prover = TerminationProver.put
+val get_termination_prover = TerminationProver.get o Context.Proof
+
+
+(* Configuration management *)
+datatype function_opt
+ = Sequential
+ | Default of string
+ | DomIntros
+ | No_Partials
+ | Tailrec
+
+datatype function_config
+ = FunctionConfig of
+ {
+ sequential: bool,
+ default: string,
+ domintros: bool,
+ partials: bool,
+ tailrec: bool
+ }
+
+fun apply_opt Sequential (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
+ FunctionConfig {sequential=true, default=default, domintros=domintros, partials=partials, tailrec=tailrec}
+ | apply_opt (Default d) (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
+ FunctionConfig {sequential=sequential, default=d, domintros=domintros, partials=partials, tailrec=tailrec}
+ | apply_opt DomIntros (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
+ FunctionConfig {sequential=sequential, default=default, domintros=true, partials=partials, tailrec=tailrec}
+ | apply_opt Tailrec (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
+ FunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=partials, tailrec=true}
+ | apply_opt No_Partials (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
+ FunctionConfig {sequential=sequential, default=default, domintros=domintros, partials=false, tailrec=true}
+
+val default_config =
+ FunctionConfig { sequential=false, default="%x. undefined" (*FIXME dynamic scoping*),
+ domintros=false, partials=true, tailrec=false }
+
+
+(* Analyzing function equations *)
+
+fun split_def ctxt geq =
+ let
+ fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq]
+ val qs = Term.strip_qnt_vars "all" geq
+ val imp = Term.strip_qnt_body "all" geq
+ val (gs, eq) = Logic.strip_horn imp
+
+ val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
+ handle TERM _ => error (input_error "Not an equation")
+
+ val (head, args) = strip_comb f_args
+
+ val fname = fst (dest_Free head)
+ handle TERM _ => error (input_error "Head symbol must not be a bound variable")
+ in
+ (fname, qs, gs, args, rhs)
+ end
+
+(* Check for all sorts of errors in the input *)
+fun check_defs ctxt fixes eqs =
+ let
+ val fnames = map (fst o fst) fixes
+
+ fun check geq =
+ let
+ fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq])
+
+ val fqgar as (fname, qs, gs, args, rhs) = split_def ctxt geq
+
+ val _ = fname mem fnames
+ orelse input_error
+ ("Head symbol of left hand side must be "
+ ^ plural "" "one out of " fnames ^ commas_quote fnames)
+
+ val _ = length args > 0 orelse input_error "Function has no arguments:"
+
+ fun add_bvs t is = add_loose_bnos (t, 0, is)
+ val rvs = (subtract (op =) (fold add_bvs args []) (add_bvs rhs []))
+ |> map (fst o nth (rev qs))
+
+ val _ = null rvs orelse input_error
+ ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs
+ ^ " occur" ^ plural "s" "" rvs ^ " on right hand side only:")
+
+ val _ = forall (not o Term.exists_subterm
+ (fn Free (n, _) => n mem fnames | _ => false)) (gs @ args)
+ orelse input_error "Defined function may not occur in premises or arguments"
+
+ val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args
+ val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs
+ val _ = null funvars
+ orelse (warning (cat_lines
+ ["Bound variable" ^ plural " " "s " funvars
+ ^ commas_quote (map fst funvars) ^
+ " occur" ^ plural "s" "" funvars ^ " in function position.",
+ "Misspelled constructor???"]); true)
+ in
+ (fname, length args)
+ end
+
+ val _ = AList.group (op =) (map check eqs)
+ |> map (fn (fname, ars) =>
+ length (distinct (op =) ars) = 1
+ orelse error ("Function " ^ quote fname ^
+ " has different numbers of arguments in different equations"))
+
+ fun check_sorts ((fname, fT), _) =
+ Sorts.of_sort (Sign.classes_of (ProofContext.theory_of ctxt)) (fT, HOLogic.typeS)
+ orelse error (cat_lines
+ ["Type of " ^ quote fname ^ " is not of sort " ^ quote "type" ^ ":",
+ setmp_CRITICAL show_sorts true (Syntax.string_of_typ ctxt) fT])
+
+ val _ = map check_sorts fixes
+ in
+ ()
+ end
+
+(* Preprocessors *)
+
+type fixes = ((string * typ) * mixfix) list
+type 'a spec = (Attrib.binding * 'a list) list
+type preproc = function_config -> Proof.context -> fixes -> term spec
+ -> (term list * (thm list -> thm spec) * (thm list -> thm list list) * string list)
+
+val fname_of = fst o dest_Free o fst o strip_comb o fst
+ o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all
+
+fun mk_case_names i "" k = mk_case_names i (string_of_int (i + 1)) k
+ | mk_case_names _ n 0 = []
+ | mk_case_names _ n 1 = [n]
+ | mk_case_names _ n k = map (fn i => n ^ "_" ^ string_of_int i) (1 upto k)
+
+fun empty_preproc check _ ctxt fixes spec =
+ let
+ val (bnds, tss) = split_list spec
+ val ts = flat tss
+ val _ = check ctxt fixes ts
+ val fnames = map (fst o fst) fixes
+ val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts
+
+ fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1)
+ (indices ~~ xs)
+ |> map (map snd)
+
+ (* using theorem names for case name currently disabled *)
+ val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat
+ in
+ (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames)
+ end
+
+structure Preprocessor = GenericDataFun
+(
+ type T = preproc
+ val empty : T = empty_preproc check_defs
+ val extend = I
+ fun merge _ (a, _) = a
+);
+
+val get_preproc = Preprocessor.get o Context.Proof
+val set_preproc = Preprocessor.map o K
+
+
+
+local
+ structure P = OuterParse and K = OuterKeyword
+
+ val option_parser =
+ P.group "option" ((P.reserved "sequential" >> K Sequential)
+ || ((P.reserved "default" |-- P.term) >> Default)
+ || (P.reserved "domintros" >> K DomIntros)
+ || (P.reserved "no_partials" >> K No_Partials)
+ || (P.reserved "tailrec" >> K Tailrec))
+
+ fun config_parser default =
+ (Scan.optional (P.$$$ "(" |-- P.!!! (P.list1 option_parser) --| P.$$$ ")") [])
+ >> (fn opts => fold apply_opt opts default)
+in
+ fun function_parser default_cfg =
+ config_parser default_cfg -- P.fixes -- SpecParse.where_alt_specs
+end
+
+
+end
+end
+--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/function_core.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,956 @@
+(* Title: HOL/Tools/Function/function_core.ML
+ Author: Alexander Krauss, TU Muenchen
+
+A package for general recursive function definitions:
+Main functionality.
+*)
+
+signature FUNCTION_CORE =
+sig
+ val trace: bool Unsynchronized.ref
+
+ val prepare_function : Function_Common.function_config
+ -> string (* defname *)
+ -> ((bstring * typ) * mixfix) list (* defined symbol *)
+ -> ((bstring * typ) list * term list * term * term) list (* specification *)
+ -> local_theory
+
+ -> (term (* f *)
+ * thm (* goalstate *)
+ * (thm -> Function_Common.function_result) (* continuation *)
+ ) * local_theory
+
+end
+
+structure Function_Core : FUNCTION_CORE =
+struct
+
+val trace = Unsynchronized.ref false;
+fun trace_msg msg = if ! trace then tracing (msg ()) else ();
+
+val boolT = HOLogic.boolT
+val mk_eq = HOLogic.mk_eq
+
+open Function_Lib
+open Function_Common
+
+datatype globals =
+ Globals of {
+ fvar: term,
+ domT: typ,
+ ranT: typ,
+ h: term,
+ y: term,
+ x: term,
+ z: term,
+ a: term,
+ P: term,
+ D: term,
+ Pbool:term
+}
+
+
+datatype rec_call_info =
+ RCInfo of
+ {
+ RIvs: (string * typ) list, (* Call context: fixes and assumes *)
+ CCas: thm list,
+ rcarg: term, (* The recursive argument *)
+
+ llRI: thm,
+ h_assum: term
+ }
+
+
+datatype clause_context =
+ ClauseContext of
+ {
+ ctxt : Proof.context,
+
+ qs : term list,
+ gs : term list,
+ lhs: term,
+ rhs: term,
+
+ cqs: cterm list,
+ ags: thm list,
+ case_hyp : thm
+ }
+
+
+fun transfer_clause_ctx thy (ClauseContext { ctxt, qs, gs, lhs, rhs, cqs, ags, case_hyp }) =
+ ClauseContext { ctxt = ProofContext.transfer thy ctxt,
+ qs = qs, gs = gs, lhs = lhs, rhs = rhs, cqs = cqs, ags = ags, case_hyp = case_hyp }
+
+
+datatype clause_info =
+ ClauseInfo of
+ {
+ no: int,
+ qglr : ((string * typ) list * term list * term * term),
+ cdata : clause_context,
+
+ tree: Function_Ctx_Tree.ctx_tree,
+ lGI: thm,
+ RCs: rec_call_info list
+ }
+
+
+(* Theory dependencies. *)
+val Pair_inject = @{thm Product_Type.Pair_inject};
+
+val acc_induct_rule = @{thm accp_induct_rule};
+
+val ex1_implies_ex = @{thm FunDef.fundef_ex1_existence};
+val ex1_implies_un = @{thm FunDef.fundef_ex1_uniqueness};
+val ex1_implies_iff = @{thm FunDef.fundef_ex1_iff};
+
+val acc_downward = @{thm accp_downward};
+val accI = @{thm accp.accI};
+val case_split = @{thm HOL.case_split};
+val fundef_default_value = @{thm FunDef.fundef_default_value};
+val not_acc_down = @{thm not_accp_down};
+
+
+
+fun find_calls tree =
+ let
+ fun add_Ri (fixes,assumes) (_ $ arg) _ (_, xs) = ([], (fixes, assumes, arg) :: xs)
+ | add_Ri _ _ _ _ = raise Match
+ in
+ rev (Function_Ctx_Tree.traverse_tree add_Ri tree [])
+ end
+
+
+(** building proof obligations *)
+
+fun mk_compat_proof_obligations domT ranT fvar f glrs =
+ let
+ fun mk_impl ((qs, gs, lhs, rhs),(qs', gs', lhs', rhs')) =
+ let
+ val shift = incr_boundvars (length qs')
+ in
+ Logic.mk_implies
+ (HOLogic.mk_Trueprop (HOLogic.eq_const domT $ shift lhs $ lhs'),
+ HOLogic.mk_Trueprop (HOLogic.eq_const ranT $ shift rhs $ rhs'))
+ |> fold_rev (curry Logic.mk_implies) (map shift gs @ gs')
+ |> fold_rev (fn (n,T) => fn b => Term.all T $ Abs(n,T,b)) (qs @ qs')
+ |> curry abstract_over fvar
+ |> curry subst_bound f
+ end
+ in
+ map mk_impl (unordered_pairs glrs)
+ end
+
+
+fun mk_completeness (Globals {x, Pbool, ...}) clauses qglrs =
+ let
+ fun mk_case (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) =
+ HOLogic.mk_Trueprop Pbool
+ |> curry Logic.mk_implies (HOLogic.mk_Trueprop (mk_eq (x, lhs)))
+ |> fold_rev (curry Logic.mk_implies) gs
+ |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
+ in
+ HOLogic.mk_Trueprop Pbool
+ |> fold_rev (curry Logic.mk_implies o mk_case) (clauses ~~ qglrs)
+ |> mk_forall_rename ("x", x)
+ |> mk_forall_rename ("P", Pbool)
+ end
+
+(** making a context with it's own local bindings **)
+
+fun mk_clause_context x ctxt (pre_qs,pre_gs,pre_lhs,pre_rhs) =
+ let
+ val (qs, ctxt') = Variable.variant_fixes (map fst pre_qs) ctxt
+ |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
+
+ val thy = ProofContext.theory_of ctxt'
+
+ fun inst t = subst_bounds (rev qs, t)
+ val gs = map inst pre_gs
+ val lhs = inst pre_lhs
+ val rhs = inst pre_rhs
+
+ val cqs = map (cterm_of thy) qs
+ val ags = map (assume o cterm_of thy) gs
+
+ val case_hyp = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (x, lhs))))
+ in
+ ClauseContext { ctxt = ctxt', qs = qs, gs = gs, lhs = lhs, rhs = rhs,
+ cqs = cqs, ags = ags, case_hyp = case_hyp }
+ end
+
+
+(* lowlevel term function. FIXME: remove *)
+fun abstract_over_list vs body =
+ let
+ fun abs lev v tm =
+ if v aconv tm then Bound lev
+ else
+ (case tm of
+ Abs (a, T, t) => Abs (a, T, abs (lev + 1) v t)
+ | t $ u => abs lev v t $ abs lev v u
+ | t => t);
+ in
+ fold_index (fn (i, v) => fn t => abs i v t) vs body
+ end
+
+
+
+fun mk_clause_info globals G f no cdata qglr tree RCs GIntro_thm RIntro_thms =
+ let
+ val Globals {h, fvar, x, ...} = globals
+
+ val ClauseContext { ctxt, qs, cqs, ags, ... } = cdata
+ val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
+
+ (* Instantiate the GIntro thm with "f" and import into the clause context. *)
+ val lGI = GIntro_thm
+ |> forall_elim (cert f)
+ |> fold forall_elim cqs
+ |> fold Thm.elim_implies ags
+
+ fun mk_call_info (rcfix, rcassm, rcarg) RI =
+ let
+ val llRI = RI
+ |> fold forall_elim cqs
+ |> fold (forall_elim o cert o Free) rcfix
+ |> fold Thm.elim_implies ags
+ |> fold Thm.elim_implies rcassm
+
+ val h_assum =
+ HOLogic.mk_Trueprop (G $ rcarg $ (h $ rcarg))
+ |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
+ |> fold_rev (Logic.all o Free) rcfix
+ |> Pattern.rewrite_term (ProofContext.theory_of ctxt) [(f, h)] []
+ |> abstract_over_list (rev qs)
+ in
+ RCInfo {RIvs=rcfix, rcarg=rcarg, CCas=rcassm, llRI=llRI, h_assum=h_assum}
+ end
+
+ val RC_infos = map2 mk_call_info RCs RIntro_thms
+ in
+ ClauseInfo
+ {
+ no=no,
+ cdata=cdata,
+ qglr=qglr,
+
+ lGI=lGI,
+ RCs=RC_infos,
+ tree=tree
+ }
+ end
+
+
+
+
+
+
+
+(* replace this by a table later*)
+fun store_compat_thms 0 thms = []
+ | store_compat_thms n thms =
+ let
+ val (thms1, thms2) = chop n thms
+ in
+ (thms1 :: store_compat_thms (n - 1) thms2)
+ end
+
+(* expects i <= j *)
+fun lookup_compat_thm i j cts =
+ nth (nth cts (i - 1)) (j - i)
+
+(* Returns "Gsi, Gsj, lhs_i = lhs_j |-- rhs_j_f = rhs_i_f" *)
+(* if j < i, then turn around *)
+fun get_compat_thm thy cts i j ctxi ctxj =
+ let
+ val ClauseContext {cqs=cqsi,ags=agsi,lhs=lhsi,...} = ctxi
+ val ClauseContext {cqs=cqsj,ags=agsj,lhs=lhsj,...} = ctxj
+
+ val lhsi_eq_lhsj = cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj)))
+ in if j < i then
+ let
+ val compat = lookup_compat_thm j i cts
+ in
+ compat (* "!!qj qi. Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
+ |> fold forall_elim (cqsj @ cqsi) (* "Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
+ |> fold Thm.elim_implies agsj
+ |> fold Thm.elim_implies agsi
+ |> Thm.elim_implies ((assume lhsi_eq_lhsj) RS sym) (* "Gsj, Gsi, lhsi = lhsj |-- rhsj = rhsi" *)
+ end
+ else
+ let
+ val compat = lookup_compat_thm i j cts
+ in
+ compat (* "!!qi qj. Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
+ |> fold forall_elim (cqsi @ cqsj) (* "Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
+ |> fold Thm.elim_implies agsi
+ |> fold Thm.elim_implies agsj
+ |> Thm.elim_implies (assume lhsi_eq_lhsj)
+ |> (fn thm => thm RS sym) (* "Gsi, Gsj, lhsi = lhsj |-- rhsj = rhsi" *)
+ end
+ end
+
+
+
+
+(* Generates the replacement lemma in fully quantified form. *)
+fun mk_replacement_lemma thy h ih_elim clause =
+ let
+ val ClauseInfo {cdata=ClauseContext {qs, lhs, rhs, cqs, ags, case_hyp, ...}, RCs, tree, ...} = clause
+ local open Conv in
+ val ih_conv = arg1_conv o arg_conv o arg_conv
+ end
+
+ val ih_elim_case = Conv.fconv_rule (ih_conv (K (case_hyp RS eq_reflection))) ih_elim
+
+ val Ris = map (fn RCInfo {llRI, ...} => llRI) RCs
+ val h_assums = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qs, h_assum)))) RCs
+
+ val (eql, _) = Function_Ctx_Tree.rewrite_by_tree thy h ih_elim_case (Ris ~~ h_assums) tree
+
+ val replace_lemma = (eql RS meta_eq_to_obj_eq)
+ |> implies_intr (cprop_of case_hyp)
+ |> fold_rev (implies_intr o cprop_of) h_assums
+ |> fold_rev (implies_intr o cprop_of) ags
+ |> fold_rev forall_intr cqs
+ |> Thm.close_derivation
+ in
+ replace_lemma
+ end
+
+
+fun mk_uniqueness_clause thy globals f compat_store clausei clausej RLj =
+ let
+ val Globals {h, y, x, fvar, ...} = globals
+ val ClauseInfo {no=i, cdata=cctxi as ClauseContext {ctxt=ctxti, lhs=lhsi, case_hyp, ...}, ...} = clausei
+ val ClauseInfo {no=j, qglr=cdescj, RCs=RCsj, ...} = clausej
+
+ val cctxj as ClauseContext {ags = agsj', lhs = lhsj', rhs = rhsj', qs = qsj', cqs = cqsj', ...}
+ = mk_clause_context x ctxti cdescj
+
+ val rhsj'h = Pattern.rewrite_term thy [(fvar,h)] [] rhsj'
+ val compat = get_compat_thm thy compat_store i j cctxi cctxj
+ val Ghsj' = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qsj', h_assum)))) RCsj
+
+ val RLj_import =
+ RLj |> fold forall_elim cqsj'
+ |> fold Thm.elim_implies agsj'
+ |> fold Thm.elim_implies Ghsj'
+
+ val y_eq_rhsj'h = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (y, rhsj'h))))
+ val lhsi_eq_lhsj' = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj')))) (* lhs_i = lhs_j' |-- lhs_i = lhs_j' *)
+ in
+ (trans OF [case_hyp, lhsi_eq_lhsj']) (* lhs_i = lhs_j' |-- x = lhs_j' *)
+ |> implies_elim RLj_import (* Rj1' ... Rjk', lhs_i = lhs_j' |-- rhs_j'_h = rhs_j'_f *)
+ |> (fn it => trans OF [it, compat]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk' |-- rhs_j'_h = rhs_i_f *)
+ |> (fn it => trans OF [y_eq_rhsj'h, it]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk', y = rhs_j_h' |-- y = rhs_i_f *)
+ |> fold_rev (implies_intr o cprop_of) Ghsj'
+ |> fold_rev (implies_intr o cprop_of) agsj' (* lhs_i = lhs_j' , y = rhs_j_h' |-- Gj', Rj1'...Rjk' ==> y = rhs_i_f *)
+ |> implies_intr (cprop_of y_eq_rhsj'h)
+ |> implies_intr (cprop_of lhsi_eq_lhsj')
+ |> fold_rev forall_intr (cterm_of thy h :: cqsj')
+ end
+
+
+
+fun mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_cases compat_store clauses rep_lemmas clausei =
+ let
+ val Globals {x, y, ranT, fvar, ...} = globals
+ val ClauseInfo {cdata = ClauseContext {lhs, rhs, qs, cqs, ags, case_hyp, ...}, lGI, RCs, ...} = clausei
+ val rhsC = Pattern.rewrite_term thy [(fvar, f)] [] rhs
+
+ val ih_intro_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ih_intro
+
+ fun prep_RC (RCInfo {llRI, RIvs, CCas, ...}) = (llRI RS ih_intro_case)
+ |> fold_rev (implies_intr o cprop_of) CCas
+ |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
+
+ val existence = fold (curry op COMP o prep_RC) RCs lGI
+
+ val P = cterm_of thy (mk_eq (y, rhsC))
+ val G_lhs_y = assume (cterm_of thy (HOLogic.mk_Trueprop (G $ lhs $ y)))
+
+ val unique_clauses = map2 (mk_uniqueness_clause thy globals f compat_store clausei) clauses rep_lemmas
+
+ val uniqueness = G_cases
+ |> forall_elim (cterm_of thy lhs)
+ |> forall_elim (cterm_of thy y)
+ |> forall_elim P
+ |> Thm.elim_implies G_lhs_y
+ |> fold Thm.elim_implies unique_clauses
+ |> implies_intr (cprop_of G_lhs_y)
+ |> forall_intr (cterm_of thy y)
+
+ val P2 = cterm_of thy (lambda y (G $ lhs $ y)) (* P2 y := (lhs, y): G *)
+
+ val exactly_one =
+ ex1I |> instantiate' [SOME (ctyp_of thy ranT)] [SOME P2, SOME (cterm_of thy rhsC)]
+ |> curry (op COMP) existence
+ |> curry (op COMP) uniqueness
+ |> simplify (HOL_basic_ss addsimps [case_hyp RS sym])
+ |> implies_intr (cprop_of case_hyp)
+ |> fold_rev (implies_intr o cprop_of) ags
+ |> fold_rev forall_intr cqs
+
+ val function_value =
+ existence
+ |> implies_intr ihyp
+ |> implies_intr (cprop_of case_hyp)
+ |> forall_intr (cterm_of thy x)
+ |> forall_elim (cterm_of thy lhs)
+ |> curry (op RS) refl
+ in
+ (exactly_one, function_value)
+ end
+
+
+
+
+fun prove_stuff ctxt globals G f R clauses complete compat compat_store G_elim f_def =
+ let
+ val Globals {h, domT, ranT, x, ...} = globals
+ val thy = ProofContext.theory_of ctxt
+
+ (* Inductive Hypothesis: !!z. (z,x):R ==> EX!y. (z,y):G *)
+ val ihyp = Term.all domT $ Abs ("z", domT,
+ Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
+ HOLogic.mk_Trueprop (Const ("Ex1", (ranT --> boolT) --> boolT) $
+ Abs ("y", ranT, G $ Bound 1 $ Bound 0))))
+ |> cterm_of thy
+
+ val ihyp_thm = assume ihyp |> Thm.forall_elim_vars 0
+ val ih_intro = ihyp_thm RS (f_def RS ex1_implies_ex)
+ val ih_elim = ihyp_thm RS (f_def RS ex1_implies_un)
+ |> instantiate' [] [NONE, SOME (cterm_of thy h)]
+
+ val _ = trace_msg (K "Proving Replacement lemmas...")
+ val repLemmas = map (mk_replacement_lemma thy h ih_elim) clauses
+
+ val _ = trace_msg (K "Proving cases for unique existence...")
+ val (ex1s, values) =
+ split_list (map (mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_elim compat_store clauses repLemmas) clauses)
+
+ val _ = trace_msg (K "Proving: Graph is a function")
+ val graph_is_function = complete
+ |> Thm.forall_elim_vars 0
+ |> fold (curry op COMP) ex1s
+ |> implies_intr (ihyp)
+ |> implies_intr (cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ x)))
+ |> forall_intr (cterm_of thy x)
+ |> (fn it => Drule.compose_single (it, 2, acc_induct_rule)) (* "EX! y. (?x,y):G" *)
+ |> (fn it => fold (forall_intr o cterm_of thy o Var) (Term.add_vars (prop_of it) []) it)
+
+ val goalstate = Conjunction.intr graph_is_function complete
+ |> Thm.close_derivation
+ |> Goal.protect
+ |> fold_rev (implies_intr o cprop_of) compat
+ |> implies_intr (cprop_of complete)
+ in
+ (goalstate, values)
+ end
+
+
+fun define_graph Gname fvar domT ranT clauses RCss lthy =
+ let
+ val GT = domT --> ranT --> boolT
+ val Gvar = Free (the_single (Variable.variant_frees lthy [] [(Gname, GT)]))
+
+ fun mk_GIntro (ClauseContext {qs, gs, lhs, rhs, ...}) RCs =
+ let
+ fun mk_h_assm (rcfix, rcassm, rcarg) =
+ HOLogic.mk_Trueprop (Gvar $ rcarg $ (fvar $ rcarg))
+ |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
+ |> fold_rev (Logic.all o Free) rcfix
+ in
+ HOLogic.mk_Trueprop (Gvar $ lhs $ rhs)
+ |> fold_rev (curry Logic.mk_implies o mk_h_assm) RCs
+ |> fold_rev (curry Logic.mk_implies) gs
+ |> fold_rev Logic.all (fvar :: qs)
+ end
+
+ val G_intros = map2 mk_GIntro clauses RCss
+
+ val (GIntro_thms, (G, G_elim, G_induct, lthy)) =
+ Function_Inductive_Wrap.inductive_def G_intros ((dest_Free Gvar, NoSyn), lthy)
+ in
+ ((G, GIntro_thms, G_elim, G_induct), lthy)
+ end
+
+
+
+fun define_function fdefname (fname, mixfix) domT ranT G default lthy =
+ let
+ val f_def =
+ Abs ("x", domT, Const (@{const_name FunDef.THE_default}, ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $
+ Abs ("y", ranT, G $ Bound 1 $ Bound 0))
+ |> Syntax.check_term lthy
+
+ val ((f, (_, f_defthm)), lthy) =
+ LocalTheory.define Thm.internalK ((Binding.name (function_name fname), mixfix), ((Binding.name fdefname, []), f_def)) lthy
+ in
+ ((f, f_defthm), lthy)
+ end
+
+
+fun define_recursion_relation Rname domT ranT fvar f qglrs clauses RCss lthy =
+ let
+
+ val RT = domT --> domT --> boolT
+ val Rvar = Free (the_single (Variable.variant_frees lthy [] [(Rname, RT)]))
+
+ fun mk_RIntro (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) (rcfix, rcassm, rcarg) =
+ HOLogic.mk_Trueprop (Rvar $ rcarg $ lhs)
+ |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
+ |> fold_rev (curry Logic.mk_implies) gs
+ |> fold_rev (Logic.all o Free) rcfix
+ |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
+ (* "!!qs xs. CS ==> G => (r, lhs) : R" *)
+
+ val R_intross = map2 (map o mk_RIntro) (clauses ~~ qglrs) RCss
+
+ val (RIntro_thmss, (R, R_elim, _, lthy)) =
+ fold_burrow Function_Inductive_Wrap.inductive_def R_intross ((dest_Free Rvar, NoSyn), lthy)
+ in
+ ((R, RIntro_thmss, R_elim), lthy)
+ end
+
+
+fun fix_globals domT ranT fvar ctxt =
+ let
+ val ([h, y, x, z, a, D, P, Pbool],ctxt') =
+ Variable.variant_fixes ["h_fd", "y_fd", "x_fd", "z_fd", "a_fd", "D_fd", "P_fd", "Pb_fd"] ctxt
+ in
+ (Globals {h = Free (h, domT --> ranT),
+ y = Free (y, ranT),
+ x = Free (x, domT),
+ z = Free (z, domT),
+ a = Free (a, domT),
+ D = Free (D, domT --> boolT),
+ P = Free (P, domT --> boolT),
+ Pbool = Free (Pbool, boolT),
+ fvar = fvar,
+ domT = domT,
+ ranT = ranT
+ },
+ ctxt')
+ end
+
+
+
+fun inst_RC thy fvar f (rcfix, rcassm, rcarg) =
+ let
+ fun inst_term t = subst_bound(f, abstract_over (fvar, t))
+ in
+ (rcfix, map (assume o cterm_of thy o inst_term o prop_of) rcassm, inst_term rcarg)
+ end
+
+
+
+(**********************************************************
+ * PROVING THE RULES
+ **********************************************************)
+
+fun mk_psimps thy globals R clauses valthms f_iff graph_is_function =
+ let
+ val Globals {domT, z, ...} = globals
+
+ fun mk_psimp (ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {cqs, lhs, ags, ...}, ...}) valthm =
+ let
+ val lhs_acc = cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ lhs)) (* "acc R lhs" *)
+ val z_smaller = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ lhs)) (* "R z lhs" *)
+ in
+ ((assume z_smaller) RS ((assume lhs_acc) RS acc_downward))
+ |> (fn it => it COMP graph_is_function)
+ |> implies_intr z_smaller
+ |> forall_intr (cterm_of thy z)
+ |> (fn it => it COMP valthm)
+ |> implies_intr lhs_acc
+ |> asm_simplify (HOL_basic_ss addsimps [f_iff])
+ |> fold_rev (implies_intr o cprop_of) ags
+ |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
+ end
+ in
+ map2 mk_psimp clauses valthms
+ end
+
+
+(** Induction rule **)
+
+
+val acc_subset_induct = @{thm Orderings.predicate1I} RS @{thm accp_subset_induct}
+
+
+fun mk_partial_induct_rule thy globals R complete_thm clauses =
+ let
+ val Globals {domT, x, z, a, P, D, ...} = globals
+ val acc_R = mk_acc domT R
+
+ val x_D = assume (cterm_of thy (HOLogic.mk_Trueprop (D $ x)))
+ val a_D = cterm_of thy (HOLogic.mk_Trueprop (D $ a))
+
+ val D_subset = cterm_of thy (Logic.all x
+ (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x), HOLogic.mk_Trueprop (acc_R $ x))))
+
+ val D_dcl = (* "!!x z. [| x: D; (z,x):R |] ==> z:D" *)
+ Logic.all x
+ (Logic.all z (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x),
+ Logic.mk_implies (HOLogic.mk_Trueprop (R $ z $ x),
+ HOLogic.mk_Trueprop (D $ z)))))
+ |> cterm_of thy
+
+
+ (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
+ val ihyp = Term.all domT $ Abs ("z", domT,
+ Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
+ HOLogic.mk_Trueprop (P $ Bound 0)))
+ |> cterm_of thy
+
+ val aihyp = assume ihyp
+
+ fun prove_case clause =
+ let
+ val ClauseInfo {cdata = ClauseContext {ctxt, qs, cqs, ags, gs, lhs, case_hyp, ...}, RCs,
+ qglr = (oqs, _, _, _), ...} = clause
+
+ val case_hyp_conv = K (case_hyp RS eq_reflection)
+ local open Conv in
+ val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
+ val sih = fconv_rule (More_Conv.binder_conv (K (arg1_conv (arg_conv (arg_conv case_hyp_conv)))) ctxt) aihyp
+ end
+
+ fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) =
+ sih |> forall_elim (cterm_of thy rcarg)
+ |> Thm.elim_implies llRI
+ |> fold_rev (implies_intr o cprop_of) CCas
+ |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
+
+ val P_recs = map mk_Prec RCs (* [P rec1, P rec2, ... ] *)
+
+ val step = HOLogic.mk_Trueprop (P $ lhs)
+ |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
+ |> fold_rev (curry Logic.mk_implies) gs
+ |> curry Logic.mk_implies (HOLogic.mk_Trueprop (D $ lhs))
+ |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
+ |> cterm_of thy
+
+ val P_lhs = assume step
+ |> fold forall_elim cqs
+ |> Thm.elim_implies lhs_D
+ |> fold Thm.elim_implies ags
+ |> fold Thm.elim_implies P_recs
+
+ val res = cterm_of thy (HOLogic.mk_Trueprop (P $ x))
+ |> Conv.arg_conv (Conv.arg_conv case_hyp_conv)
+ |> symmetric (* P lhs == P x *)
+ |> (fn eql => equal_elim eql P_lhs) (* "P x" *)
+ |> implies_intr (cprop_of case_hyp)
+ |> fold_rev (implies_intr o cprop_of) ags
+ |> fold_rev forall_intr cqs
+ in
+ (res, step)
+ end
+
+ val (cases, steps) = split_list (map prove_case clauses)
+
+ val istep = complete_thm
+ |> Thm.forall_elim_vars 0
+ |> fold (curry op COMP) cases (* P x *)
+ |> implies_intr ihyp
+ |> implies_intr (cprop_of x_D)
+ |> forall_intr (cterm_of thy x)
+
+ val subset_induct_rule =
+ acc_subset_induct
+ |> (curry op COMP) (assume D_subset)
+ |> (curry op COMP) (assume D_dcl)
+ |> (curry op COMP) (assume a_D)
+ |> (curry op COMP) istep
+ |> fold_rev implies_intr steps
+ |> implies_intr a_D
+ |> implies_intr D_dcl
+ |> implies_intr D_subset
+
+ val subset_induct_all = fold_rev (forall_intr o cterm_of thy) [P, a, D] subset_induct_rule
+
+ val simple_induct_rule =
+ subset_induct_rule
+ |> forall_intr (cterm_of thy D)
+ |> forall_elim (cterm_of thy acc_R)
+ |> assume_tac 1 |> Seq.hd
+ |> (curry op COMP) (acc_downward
+ |> (instantiate' [SOME (ctyp_of thy domT)]
+ (map (SOME o cterm_of thy) [R, x, z]))
+ |> forall_intr (cterm_of thy z)
+ |> forall_intr (cterm_of thy x))
+ |> forall_intr (cterm_of thy a)
+ |> forall_intr (cterm_of thy P)
+ in
+ simple_induct_rule
+ end
+
+
+
+(* FIXME: This should probably use fixed goals, to be more reliable and faster *)
+fun mk_domain_intro ctxt (Globals {domT, ...}) R R_cases clause =
+ let
+ val thy = ProofContext.theory_of ctxt
+ val ClauseInfo {cdata = ClauseContext {qs, gs, lhs, rhs, cqs, ...},
+ qglr = (oqs, _, _, _), ...} = clause
+ val goal = HOLogic.mk_Trueprop (mk_acc domT R $ lhs)
+ |> fold_rev (curry Logic.mk_implies) gs
+ |> cterm_of thy
+ in
+ Goal.init goal
+ |> (SINGLE (resolve_tac [accI] 1)) |> the
+ |> (SINGLE (eresolve_tac [Thm.forall_elim_vars 0 R_cases] 1)) |> the
+ |> (SINGLE (auto_tac (clasimpset_of ctxt))) |> the
+ |> Goal.conclude
+ |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
+ end
+
+
+
+(** Termination rule **)
+
+val wf_induct_rule = @{thm Wellfounded.wfP_induct_rule};
+val wf_in_rel = @{thm FunDef.wf_in_rel};
+val in_rel_def = @{thm FunDef.in_rel_def};
+
+fun mk_nest_term_case thy globals R' ihyp clause =
+ let
+ val Globals {x, z, ...} = globals
+ val ClauseInfo {cdata = ClauseContext {qs,cqs,ags,lhs,rhs,case_hyp,...},tree,
+ qglr=(oqs, _, _, _), ...} = clause
+
+ val ih_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ihyp
+
+ fun step (fixes, assumes) (_ $ arg) u (sub,(hyps,thms)) =
+ let
+ val used = map (fn (ctx,thm) => Function_Ctx_Tree.export_thm thy ctx thm) (u @ sub)
+
+ val hyp = HOLogic.mk_Trueprop (R' $ arg $ lhs)
+ |> fold_rev (curry Logic.mk_implies o prop_of) used (* additional hyps *)
+ |> Function_Ctx_Tree.export_term (fixes, assumes)
+ |> fold_rev (curry Logic.mk_implies o prop_of) ags
+ |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
+ |> cterm_of thy
+
+ val thm = assume hyp
+ |> fold forall_elim cqs
+ |> fold Thm.elim_implies ags
+ |> Function_Ctx_Tree.import_thm thy (fixes, assumes)
+ |> fold Thm.elim_implies used (* "(arg, lhs) : R'" *)
+
+ val z_eq_arg = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (z, arg))))
+
+ val acc = thm COMP ih_case
+ val z_acc_local = acc
+ |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (K (symmetric (z_eq_arg RS eq_reflection)))))
+
+ val ethm = z_acc_local
+ |> Function_Ctx_Tree.export_thm thy (fixes,
+ z_eq_arg :: case_hyp :: ags @ assumes)
+ |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
+
+ val sub' = sub @ [(([],[]), acc)]
+ in
+ (sub', (hyp :: hyps, ethm :: thms))
+ end
+ | step _ _ _ _ = raise Match
+ in
+ Function_Ctx_Tree.traverse_tree step tree
+ end
+
+
+fun mk_nest_term_rule thy globals R R_cases clauses =
+ let
+ val Globals { domT, x, z, ... } = globals
+ val acc_R = mk_acc domT R
+
+ val R' = Free ("R", fastype_of R)
+
+ val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
+ val inrel_R = Const (@{const_name FunDef.in_rel}, HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
+
+ val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
+
+ (* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
+ val ihyp = Term.all domT $ Abs ("z", domT,
+ Logic.mk_implies (HOLogic.mk_Trueprop (R' $ Bound 0 $ x),
+ HOLogic.mk_Trueprop (acc_R $ Bound 0)))
+ |> cterm_of thy
+
+ val ihyp_a = assume ihyp |> Thm.forall_elim_vars 0
+
+ val R_z_x = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ x))
+
+ val (hyps,cases) = fold (mk_nest_term_case thy globals R' ihyp_a) clauses ([],[])
+ in
+ R_cases
+ |> forall_elim (cterm_of thy z)
+ |> forall_elim (cterm_of thy x)
+ |> forall_elim (cterm_of thy (acc_R $ z))
+ |> curry op COMP (assume R_z_x)
+ |> fold_rev (curry op COMP) cases
+ |> implies_intr R_z_x
+ |> forall_intr (cterm_of thy z)
+ |> (fn it => it COMP accI)
+ |> implies_intr ihyp
+ |> forall_intr (cterm_of thy x)
+ |> (fn it => Drule.compose_single(it,2,wf_induct_rule))
+ |> curry op RS (assume wfR')
+ |> forall_intr_vars
+ |> (fn it => it COMP allI)
+ |> fold implies_intr hyps
+ |> implies_intr wfR'
+ |> forall_intr (cterm_of thy R')
+ |> forall_elim (cterm_of thy (inrel_R))
+ |> curry op RS wf_in_rel
+ |> full_simplify (HOL_basic_ss addsimps [in_rel_def])
+ |> forall_intr (cterm_of thy Rrel)
+ end
+
+
+
+(* Tail recursion (probably very fragile)
+ *
+ * FIXME:
+ * - Need to do forall_elim_vars on psimps: Unneccesary, if psimps would be taken from the same context.
+ * - Must we really replace the fvar by f here?
+ * - Splitting is not configured automatically: Problems with case?
+ *)
+fun mk_trsimps octxt globals f G R f_def R_cases G_induct clauses psimps =
+ let
+ val Globals {domT, ranT, fvar, ...} = globals
+
+ val R_cases = Thm.forall_elim_vars 0 R_cases (* FIXME: Should be already in standard form. *)
+
+ val graph_implies_dom = (* "G ?x ?y ==> dom ?x" *)
+ Goal.prove octxt ["x", "y"] [HOLogic.mk_Trueprop (G $ Free ("x", domT) $ Free ("y", ranT))]
+ (HOLogic.mk_Trueprop (mk_acc domT R $ Free ("x", domT)))
+ (fn {prems=[a], ...} =>
+ ((rtac (G_induct OF [a]))
+ THEN_ALL_NEW (rtac accI)
+ THEN_ALL_NEW (etac R_cases)
+ THEN_ALL_NEW (asm_full_simp_tac (simpset_of octxt))) 1)
+
+ val default_thm = (forall_intr_vars graph_implies_dom) COMP (f_def COMP fundef_default_value)
+
+ fun mk_trsimp clause psimp =
+ let
+ val ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {ctxt, cqs, qs, gs, lhs, rhs, ...}, ...} = clause
+ val thy = ProofContext.theory_of ctxt
+ val rhs_f = Pattern.rewrite_term thy [(fvar, f)] [] rhs
+
+ val trsimp = Logic.list_implies(gs, HOLogic.mk_Trueprop (HOLogic.mk_eq(f $ lhs, rhs_f))) (* "f lhs = rhs" *)
+ val lhs_acc = (mk_acc domT R $ lhs) (* "acc R lhs" *)
+ fun simp_default_tac ss = asm_full_simp_tac (ss addsimps [default_thm, Let_def])
+ in
+ Goal.prove ctxt [] [] trsimp
+ (fn _ =>
+ rtac (instantiate' [] [SOME (cterm_of thy lhs_acc)] case_split) 1
+ THEN (rtac (Thm.forall_elim_vars 0 psimp) THEN_ALL_NEW assume_tac) 1
+ THEN (simp_default_tac (simpset_of ctxt) 1)
+ THEN (etac not_acc_down 1)
+ THEN ((etac R_cases) THEN_ALL_NEW (simp_default_tac (simpset_of ctxt))) 1)
+ |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
+ end
+ in
+ map2 mk_trsimp clauses psimps
+ end
+
+
+fun prepare_function config defname [((fname, fT), mixfix)] abstract_qglrs lthy =
+ let
+ val FunctionConfig {domintros, tailrec, default=default_str, ...} = config
+
+ val fvar = Free (fname, fT)
+ val domT = domain_type fT
+ val ranT = range_type fT
+
+ val default = Syntax.parse_term lthy default_str
+ |> TypeInfer.constrain fT |> Syntax.check_term lthy
+
+ val (globals, ctxt') = fix_globals domT ranT fvar lthy
+
+ val Globals { x, h, ... } = globals
+
+ val clauses = map (mk_clause_context x ctxt') abstract_qglrs
+
+ val n = length abstract_qglrs
+
+ fun build_tree (ClauseContext { ctxt, rhs, ...}) =
+ Function_Ctx_Tree.mk_tree (fname, fT) h ctxt rhs
+
+ val trees = map build_tree clauses
+ val RCss = map find_calls trees
+
+ val ((G, GIntro_thms, G_elim, G_induct), lthy) =
+ PROFILE "def_graph" (define_graph (graph_name defname) fvar domT ranT clauses RCss) lthy
+
+ val ((f, f_defthm), lthy) =
+ PROFILE "def_fun" (define_function (defname ^ "_sumC_def") (fname, mixfix) domT ranT G default) lthy
+
+ val RCss = map (map (inst_RC (ProofContext.theory_of lthy) fvar f)) RCss
+ val trees = map (Function_Ctx_Tree.inst_tree (ProofContext.theory_of lthy) fvar f) trees
+
+ val ((R, RIntro_thmss, R_elim), lthy) =
+ PROFILE "def_rel" (define_recursion_relation (rel_name defname) domT ranT fvar f abstract_qglrs clauses RCss) lthy
+
+ val (_, lthy) =
+ LocalTheory.abbrev Syntax.mode_default ((Binding.name (dom_name defname), NoSyn), mk_acc domT R) lthy
+
+ val newthy = ProofContext.theory_of lthy
+ val clauses = map (transfer_clause_ctx newthy) clauses
+
+ val cert = cterm_of (ProofContext.theory_of lthy)
+
+ val xclauses = PROFILE "xclauses" (map7 (mk_clause_info globals G f) (1 upto n) clauses abstract_qglrs trees RCss GIntro_thms) RIntro_thmss
+
+ val complete = mk_completeness globals clauses abstract_qglrs |> cert |> assume
+ val compat = mk_compat_proof_obligations domT ranT fvar f abstract_qglrs |> map (cert #> assume)
+
+ val compat_store = store_compat_thms n compat
+
+ val (goalstate, values) = PROFILE "prove_stuff" (prove_stuff lthy globals G f R xclauses complete compat compat_store G_elim) f_defthm
+
+ val mk_trsimps = mk_trsimps lthy globals f G R f_defthm R_elim G_induct xclauses
+
+ fun mk_partial_rules provedgoal =
+ let
+ val newthy = theory_of_thm provedgoal (*FIXME*)
+
+ val (graph_is_function, complete_thm) =
+ provedgoal
+ |> Conjunction.elim
+ |> apfst (Thm.forall_elim_vars 0)
+
+ val f_iff = graph_is_function RS (f_defthm RS ex1_implies_iff)
+
+ val psimps = PROFILE "Proving simplification rules" (mk_psimps newthy globals R xclauses values f_iff) graph_is_function
+
+ val simple_pinduct = PROFILE "Proving partial induction rule"
+ (mk_partial_induct_rule newthy globals R complete_thm) xclauses
+
+
+ val total_intro = PROFILE "Proving nested termination rule" (mk_nest_term_rule newthy globals R R_elim) xclauses
+
+ val dom_intros = if domintros
+ then SOME (PROFILE "Proving domain introduction rules" (map (mk_domain_intro lthy globals R R_elim)) xclauses)
+ else NONE
+ val trsimps = if tailrec then SOME (mk_trsimps psimps) else NONE
+
+ in
+ FunctionResult {fs=[f], G=G, R=R, cases=complete_thm,
+ psimps=psimps, simple_pinducts=[simple_pinduct],
+ termination=total_intro, trsimps=trsimps,
+ domintros=dom_intros}
+ end
+ in
+ ((f, goalstate, mk_partial_rules), lthy)
+ end
+
+
+end--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/function_lib.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,180 @@
+(* Title: HOL/Tools/Function/fundef_lib.ML
+ Author: Alexander Krauss, TU Muenchen
+
+A package for general recursive function definitions.
+Some fairly general functions that should probably go somewhere else...
+*)
+
+structure Function_Lib =
+struct
+
+fun map_option f NONE = NONE
+ | map_option f (SOME x) = SOME (f x);
+
+fun fold_option f NONE y = y
+ | fold_option f (SOME x) y = f x y;
+
+fun fold_map_option f NONE y = (NONE, y)
+ | fold_map_option f (SOME x) y = apfst SOME (f x y);
+
+(* Ex: "The variable" ^ plural " is" "s are" vs *)
+fun plural sg pl [x] = sg
+ | plural sg pl _ = pl
+
+(* lambda-abstracts over an arbitrarily nested tuple
+ ==> hologic.ML? *)
+fun tupled_lambda vars t =
+ case vars of
+ (Free v) => lambda (Free v) t
+ | (Var v) => lambda (Var v) t
+ | (Const ("Pair", Type ("fun", [Ta, Type ("fun", [Tb, _])]))) $ us $ vs =>
+ (HOLogic.split_const (Ta,Tb, fastype_of t)) $ (tupled_lambda us (tupled_lambda vs t))
+ | _ => raise Match
+
+
+fun dest_all (Const ("all", _) $ Abs (a as (_,T,_))) =
+ let
+ val (n, body) = Term.dest_abs a
+ in
+ (Free (n, T), body)
+ end
+ | dest_all _ = raise Match
+
+
+(* Removes all quantifiers from a term, replacing bound variables by frees. *)
+fun dest_all_all (t as (Const ("all",_) $ _)) =
+ let
+ val (v,b) = dest_all t
+ val (vs, b') = dest_all_all b
+ in
+ (v :: vs, b')
+ end
+ | dest_all_all t = ([],t)
+
+
+(* FIXME: similar to Variable.focus *)
+fun dest_all_all_ctx ctx (Const ("all", _) $ Abs (a as (n,T,b))) =
+ let
+ val [(n', _)] = Variable.variant_frees ctx [] [(n,T)]
+ val (_, ctx') = ProofContext.add_fixes [(Binding.name n', SOME T, NoSyn)] ctx
+
+ val (n'', body) = Term.dest_abs (n', T, b)
+ val _ = (n' = n'') orelse error "dest_all_ctx"
+ (* Note: We assume that n' does not occur in the body. Otherwise it would be fixed. *)
+
+ val (ctx'', vs, bd) = dest_all_all_ctx ctx' body
+ in
+ (ctx'', (n', T) :: vs, bd)
+ end
+ | dest_all_all_ctx ctx t =
+ (ctx, [], t)
+
+
+fun map3 _ [] [] [] = []
+ | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
+ | map3 _ _ _ _ = raise Library.UnequalLengths;
+
+fun map4 _ [] [] [] [] = []
+ | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
+ | map4 _ _ _ _ _ = raise Library.UnequalLengths;
+
+fun map6 _ [] [] [] [] [] [] = []
+ | map6 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) = f x y z u v w :: map6 f xs ys zs us vs ws
+ | map6 _ _ _ _ _ _ _ = raise Library.UnequalLengths;
+
+fun map7 _ [] [] [] [] [] [] [] = []
+ | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
+ | map7 _ _ _ _ _ _ _ _ = raise Library.UnequalLengths;
+
+
+
+(* forms all "unordered pairs": [1, 2, 3] ==> [(1, 1), (1, 2), (1, 3), (2, 2), (2, 3), (3, 3)] *)
+(* ==> library *)
+fun unordered_pairs [] = []
+ | unordered_pairs (x::xs) = map (pair x) (x::xs) @ unordered_pairs xs
+
+
+(* Replaces Frees by name. Works with loose Bounds. *)
+fun replace_frees assoc =
+ map_aterms (fn c as Free (n, _) => the_default c (AList.lookup (op =) assoc n)
+ | t => t)
+
+
+fun rename_bound n (Q $ Abs(_, T, b)) = (Q $ Abs(n, T, b))
+ | rename_bound n _ = raise Match
+
+fun mk_forall_rename (n, v) =
+ rename_bound n o Logic.all v
+
+fun forall_intr_rename (n, cv) thm =
+ let
+ val allthm = forall_intr cv thm
+ val (_ $ abs) = prop_of allthm
+ in
+ Thm.rename_boundvars abs (Abs (n, dummyT, Term.dummy_pattern dummyT)) allthm
+ end
+
+
+(* Returns the frees in a term in canonical order, excluding the fixes from the context *)
+fun frees_in_term ctxt t =
+ Term.add_frees t []
+ |> filter_out (Variable.is_fixed ctxt o fst)
+ |> rev
+
+
+datatype proof_attempt = Solved of thm | Stuck of thm | Fail
+
+fun try_proof cgoal tac =
+ case SINGLE tac (Goal.init cgoal) of
+ NONE => Fail
+ | SOME st =>
+ if Thm.no_prems st
+ then Solved (Goal.finish (Syntax.init_pretty_global (Thm.theory_of_cterm cgoal)) st)
+ else Stuck st
+
+
+fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) =
+ if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
+ | dest_binop_list _ t = [ t ]
+
+
+(* separate two parts in a +-expression:
+ "a + b + c + d + e" --> "(a + b + d) + (c + e)"
+
+ Here, + can be any binary operation that is AC.
+
+ cn - The name of the binop-constructor (e.g. @{const_name Un})
+ ac - the AC rewrite rules for cn
+ is - the list of indices of the expressions that should become the first part
+ (e.g. [0,1,3] in the above example)
+*)
+
+fun regroup_conv neu cn ac is ct =
+ let
+ val mk = HOLogic.mk_binop cn
+ val t = term_of ct
+ val xs = dest_binop_list cn t
+ val js = subtract (op =) is (0 upto (length xs) - 1)
+ val ty = fastype_of t
+ val thy = theory_of_cterm ct
+ in
+ Goal.prove_internal []
+ (cterm_of thy
+ (Logic.mk_equals (t,
+ if is = []
+ then mk (Const (neu, ty), foldr1 mk (map (nth xs) js))
+ else if js = []
+ then mk (foldr1 mk (map (nth xs) is), Const (neu, ty))
+ else mk (foldr1 mk (map (nth xs) is), foldr1 mk (map (nth xs) js)))))
+ (K (rewrite_goals_tac ac
+ THEN rtac Drule.reflexive_thm 1))
+ end
+
+(* instance for unions *)
+fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Lattices.sup}
+ (map (fn t => t RS eq_reflection) (@{thms Un_ac} @
+ @{thms Un_empty_right} @
+ @{thms Un_empty_left})) t
+
+
+end--- a/src/HOL/Tools/Function/fundef.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,226 +0,0 @@
-(* Title: HOL/Tools/Function/fundef.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions.
-Isar commands.
-*)
-
-signature FUNDEF =
-sig
- val add_fundef : (binding * typ option * mixfix) list
- -> (Attrib.binding * term) list
- -> FundefCommon.fundef_config
- -> local_theory
- -> Proof.state
- val add_fundef_cmd : (binding * string option * mixfix) list
- -> (Attrib.binding * string) list
- -> FundefCommon.fundef_config
- -> local_theory
- -> Proof.state
-
- val termination_proof : term option -> local_theory -> Proof.state
- val termination_proof_cmd : string option -> local_theory -> Proof.state
- val termination : term option -> local_theory -> Proof.state
- val termination_cmd : string option -> local_theory -> Proof.state
-
- val setup : theory -> theory
- val get_congs : Proof.context -> thm list
-end
-
-
-structure Fundef : FUNDEF =
-struct
-
-open FundefLib
-open FundefCommon
-
-val simp_attribs = map (Attrib.internal o K)
- [Simplifier.simp_add,
- Code.add_default_eqn_attribute,
- Nitpick_Simps.add,
- Quickcheck_RecFun_Simps.add]
-
-val psimp_attribs = map (Attrib.internal o K)
- [Simplifier.simp_add,
- Nitpick_Psimps.add]
-
-fun note_theorem ((name, atts), ths) =
- LocalTheory.note Thm.generatedK ((Binding.qualified_name name, atts), ths)
-
-fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
-
-fun add_simps fnames post sort extra_qualify label moreatts simps lthy =
- let
- val spec = post simps
- |> map (apfst (apsnd (fn ats => moreatts @ ats)))
- |> map (apfst (apfst extra_qualify))
-
- val (saved_spec_simps, lthy) =
- fold_map (LocalTheory.note Thm.generatedK) spec lthy
-
- val saved_simps = maps snd saved_spec_simps
- val simps_by_f = sort saved_simps
-
- fun add_for_f fname simps =
- note_theorem ((Long_Name.qualify fname label, []), simps) #> snd
- in
- (saved_simps,
- fold2 add_for_f fnames simps_by_f lthy)
- end
-
-fun gen_add_fundef is_external prep default_constraint fixspec eqns config lthy =
- let
- val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
- val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
- val fixes = map (apfst (apfst Binding.name_of)) fixes0;
- val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
- val (eqs, post, sort_cont, cnames) = FundefCommon.get_preproc lthy config ctxt' fixes spec
-
- val defname = mk_defname fixes
-
- val ((goalstate, cont), lthy) =
- FundefMutual.prepare_fundef_mutual config defname fixes eqs lthy
-
- fun afterqed [[proof]] lthy =
- let
- val FundefResult {fs, R, psimps, trsimps, simple_pinducts, termination,
- domintros, cases, ...} =
- cont (Thm.close_derivation proof)
-
- val fnames = map (fst o fst) fixes
- val qualify = Long_Name.qualify defname
- val addsmps = add_simps fnames post sort_cont
-
- val (((psimps', pinducts'), (_, [termination'])), lthy) =
- lthy
- |> addsmps (Binding.qualify false "partial") "psimps"
- psimp_attribs psimps
- ||> fold_option (snd oo addsmps I "simps" simp_attribs) trsimps
- ||>> note_theorem ((qualify "pinduct",
- [Attrib.internal (K (RuleCases.case_names cnames)),
- Attrib.internal (K (RuleCases.consumes 1)),
- Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
- ||>> note_theorem ((qualify "termination", []), [termination])
- ||> (snd o note_theorem ((qualify "cases",
- [Attrib.internal (K (RuleCases.case_names cnames))]), [cases]))
- ||> fold_option (snd oo curry note_theorem (qualify "domintros", [])) domintros
-
- val cdata = FundefCtxData { add_simps=addsmps, case_names=cnames, psimps=psimps',
- pinducts=snd pinducts', termination=termination',
- fs=fs, R=R, defname=defname }
- val _ =
- if not is_external then ()
- else Specification.print_consts lthy (K false) (map fst fixes)
- in
- lthy
- |> LocalTheory.declaration (add_fundef_data o morph_fundef_data cdata)
- end
- in
- lthy
- |> is_external ? LocalTheory.set_group (serial_string ())
- |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
- |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
- end
-
-val add_fundef = gen_add_fundef false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
-val add_fundef_cmd = gen_add_fundef true Specification.read_spec "_::type"
-
-fun gen_termination_proof prep_term raw_term_opt lthy =
- let
- val term_opt = Option.map (prep_term lthy) raw_term_opt
- val data = the (case term_opt of
- SOME t => (import_fundef_data t lthy
- handle Option.Option =>
- error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
- | NONE => (import_last_fundef lthy handle Option.Option => error "Not a function"))
-
- val FundefCtxData { termination, R, add_simps, case_names, psimps,
- pinducts, defname, ...} = data
- val domT = domain_type (fastype_of R)
- val goal = HOLogic.mk_Trueprop
- (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
- fun afterqed [[totality]] lthy =
- let
- val totality = Thm.close_derivation totality
- val remove_domain_condition =
- full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
- val tsimps = map remove_domain_condition psimps
- val tinduct = map remove_domain_condition pinducts
- val qualify = Long_Name.qualify defname;
- in
- lthy
- |> add_simps I "simps" simp_attribs tsimps |> snd
- |> note_theorem
- ((qualify "induct",
- [Attrib.internal (K (RuleCases.case_names case_names))]),
- tinduct) |> snd
- end
- in
- lthy
- |> ProofContext.note_thmss ""
- [((Binding.empty, [ContextRules.rule_del]), [([allI], [])])] |> snd
- |> ProofContext.note_thmss ""
- [((Binding.empty, [ContextRules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
- |> ProofContext.note_thmss ""
- [((Binding.name "termination", [ContextRules.intro_bang (SOME 0)]),
- [([Goal.norm_result termination], [])])] |> snd
- |> Proof.theorem_i NONE afterqed [[(goal, [])]]
- end
-
-val termination_proof = gen_termination_proof Syntax.check_term;
-val termination_proof_cmd = gen_termination_proof Syntax.read_term;
-
-fun termination term_opt lthy =
- lthy
- |> LocalTheory.set_group (serial_string ())
- |> termination_proof term_opt;
-
-fun termination_cmd term_opt lthy =
- lthy
- |> LocalTheory.set_group (serial_string ())
- |> termination_proof_cmd term_opt;
-
-
-(* Datatype hook to declare datatype congs as "fundef_congs" *)
-
-
-fun add_case_cong n thy =
- Context.theory_map (FundefCtxTree.map_fundef_congs (Thm.add_thm
- (Datatype.the_info thy n
- |> #case_cong
- |> safe_mk_meta_eq)))
- thy
-
-val setup_case_cong = Datatype.interpretation (K (fold add_case_cong))
-
-
-(* setup *)
-
-val setup =
- Attrib.setup @{binding fundef_cong}
- (Attrib.add_del FundefCtxTree.cong_add FundefCtxTree.cong_del)
- "declaration of congruence rule for function definitions"
- #> setup_case_cong
- #> FundefRelation.setup
- #> FundefCommon.Termination_Simps.setup
-
-val get_congs = FundefCtxTree.get_fundef_congs
-
-
-(* outer syntax *)
-
-local structure P = OuterParse and K = OuterKeyword in
-
-val _ =
- OuterSyntax.local_theory_to_proof "function" "define general recursive functions" K.thy_goal
- (fundef_parser default_config
- >> (fn ((config, fixes), statements) => add_fundef_cmd fixes statements config));
-
-val _ =
- OuterSyntax.local_theory_to_proof "termination" "prove termination of a recursive function" K.thy_goal
- (Scan.option P.term >> termination_cmd);
-
-end;
-
-
-end--- a/src/HOL/Tools/Function/fundef_common.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,343 +0,0 @@
-(* Title: HOL/Tools/Function/fundef_common.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions.
-Common definitions and other infrastructure.
-*)
-
-structure FundefCommon =
-struct
-
-local open FundefLib in
-
-(* Profiling *)
-val profile = Unsynchronized.ref false;
-
-fun PROFILE msg = if !profile then timeap_msg msg else I
-
-
-val acc_const_name = @{const_name accp}
-fun mk_acc domT R =
- Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R
-
-val function_name = suffix "C"
-val graph_name = suffix "_graph"
-val rel_name = suffix "_rel"
-val dom_name = suffix "_dom"
-
-(* Termination rules *)
-
-structure TerminationRule = GenericDataFun
-(
- type T = thm list
- val empty = []
- val extend = I
- fun merge _ = Thm.merge_thms
-);
-
-val get_termination_rules = TerminationRule.get
-val store_termination_rule = TerminationRule.map o cons
-val apply_termination_rule = resolve_tac o get_termination_rules o Context.Proof
-
-
-(* Function definition result data *)
-
-datatype fundef_result =
- FundefResult of
- {
- fs: term list,
- G: term,
- R: term,
-
- psimps : thm list,
- trsimps : thm list option,
-
- simple_pinducts : thm list,
- cases : thm,
- termination : thm,
- domintros : thm list option
- }
-
-
-datatype fundef_context_data =
- FundefCtxData of
- {
- defname : string,
-
- (* contains no logical entities: invariant under morphisms *)
- add_simps : (binding -> binding) -> string -> Attrib.src list -> thm list
- -> local_theory -> thm list * local_theory,
- case_names : string list,
-
- fs : term list,
- R : term,
-
- psimps: thm list,
- pinducts: thm list,
- termination: thm
- }
-
-fun morph_fundef_data (FundefCtxData {add_simps, case_names, fs, R,
- psimps, pinducts, termination, defname}) phi =
- let
- val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi
- val name = Binding.name_of o Morphism.binding phi o Binding.name
- in
- FundefCtxData { add_simps = add_simps, case_names = case_names,
- fs = map term fs, R = term R, psimps = fact psimps,
- pinducts = fact pinducts, termination = thm termination,
- defname = name defname }
- end
-
-structure FundefData = GenericDataFun
-(
- type T = (term * fundef_context_data) Item_Net.T;
- val empty = Item_Net.init
- (op aconv o pairself fst : (term * fundef_context_data) * (term * fundef_context_data) -> bool)
- fst;
- val copy = I;
- val extend = I;
- fun merge _ (tab1, tab2) = Item_Net.merge (tab1, tab2)
-);
-
-val get_fundef = FundefData.get o Context.Proof;
-
-
-(* Generally useful?? *)
-fun lift_morphism thy f =
- let
- val term = Drule.term_rule thy f
- in
- Morphism.thm_morphism f $> Morphism.term_morphism term
- $> Morphism.typ_morphism (Logic.type_map term)
- end
-
-fun import_fundef_data t ctxt =
- let
- val thy = ProofContext.theory_of ctxt
- val ct = cterm_of thy t
- val inst_morph = lift_morphism thy o Thm.instantiate
-
- fun match (trm, data) =
- SOME (morph_fundef_data data (inst_morph (Thm.match (cterm_of thy trm, ct))))
- handle Pattern.MATCH => NONE
- in
- get_first match (Item_Net.retrieve (get_fundef ctxt) t)
- end
-
-fun import_last_fundef ctxt =
- case Item_Net.content (get_fundef ctxt) of
- [] => NONE
- | (t, data) :: _ =>
- let
- val ([t'], ctxt') = Variable.import_terms true [t] ctxt
- in
- import_fundef_data t' ctxt'
- end
-
-val all_fundef_data = Item_Net.content o get_fundef
-
-fun add_fundef_data (data as FundefCtxData {fs, termination, ...}) =
- FundefData.map (fold (fn f => Item_Net.insert (f, data)) fs)
- #> store_termination_rule termination
-
-
-(* Simp rules for termination proofs *)
-
-structure Termination_Simps = Named_Thms
-(
- val name = "termination_simp"
- val description = "Simplification rule for termination proofs"
-);
-
-
-(* Default Termination Prover *)
-
-structure TerminationProver = GenericDataFun
-(
- type T = Proof.context -> Proof.method
- val empty = (fn _ => error "Termination prover not configured")
- val extend = I
- fun merge _ (a,b) = b (* FIXME *)
-);
-
-val set_termination_prover = TerminationProver.put
-val get_termination_prover = TerminationProver.get o Context.Proof
-
-
-(* Configuration management *)
-datatype fundef_opt
- = Sequential
- | Default of string
- | DomIntros
- | Tailrec
-
-datatype fundef_config
- = FundefConfig of
- {
- sequential: bool,
- default: string,
- domintros: bool,
- tailrec: bool
- }
-
-fun apply_opt Sequential (FundefConfig {sequential, default, domintros,tailrec}) =
- FundefConfig {sequential=true, default=default, domintros=domintros, tailrec=tailrec}
- | apply_opt (Default d) (FundefConfig {sequential, default, domintros,tailrec}) =
- FundefConfig {sequential=sequential, default=d, domintros=domintros, tailrec=tailrec}
- | apply_opt DomIntros (FundefConfig {sequential, default, domintros,tailrec}) =
- FundefConfig {sequential=sequential, default=default, domintros=true,tailrec=tailrec}
- | apply_opt Tailrec (FundefConfig {sequential, default, domintros,tailrec}) =
- FundefConfig {sequential=sequential, default=default, domintros=domintros,tailrec=true}
-
-val default_config =
- FundefConfig { sequential=false, default="%x. undefined" (*FIXME dynamic scoping*),
- domintros=false, tailrec=false }
-
-
-(* Analyzing function equations *)
-
-fun split_def ctxt geq =
- let
- fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq]
- val qs = Term.strip_qnt_vars "all" geq
- val imp = Term.strip_qnt_body "all" geq
- val (gs, eq) = Logic.strip_horn imp
-
- val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
- handle TERM _ => error (input_error "Not an equation")
-
- val (head, args) = strip_comb f_args
-
- val fname = fst (dest_Free head)
- handle TERM _ => error (input_error "Head symbol must not be a bound variable")
- in
- (fname, qs, gs, args, rhs)
- end
-
-(* Check for all sorts of errors in the input *)
-fun check_defs ctxt fixes eqs =
- let
- val fnames = map (fst o fst) fixes
-
- fun check geq =
- let
- fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq])
-
- val fqgar as (fname, qs, gs, args, rhs) = split_def ctxt geq
-
- val _ = fname mem fnames
- orelse input_error
- ("Head symbol of left hand side must be "
- ^ plural "" "one out of " fnames ^ commas_quote fnames)
-
- val _ = length args > 0 orelse input_error "Function has no arguments:"
-
- fun add_bvs t is = add_loose_bnos (t, 0, is)
- val rvs = (subtract (op =) (fold add_bvs args []) (add_bvs rhs []))
- |> map (fst o nth (rev qs))
-
- val _ = null rvs orelse input_error
- ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs
- ^ " occur" ^ plural "s" "" rvs ^ " on right hand side only:")
-
- val _ = forall (not o Term.exists_subterm
- (fn Free (n, _) => n mem fnames | _ => false)) (gs @ args)
- orelse input_error "Defined function may not occur in premises or arguments"
-
- val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args
- val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs
- val _ = null funvars
- orelse (warning (cat_lines
- ["Bound variable" ^ plural " " "s " funvars
- ^ commas_quote (map fst funvars) ^
- " occur" ^ plural "s" "" funvars ^ " in function position.",
- "Misspelled constructor???"]); true)
- in
- (fname, length args)
- end
-
- val _ = AList.group (op =) (map check eqs)
- |> map (fn (fname, ars) =>
- length (distinct (op =) ars) = 1
- orelse error ("Function " ^ quote fname ^
- " has different numbers of arguments in different equations"))
-
- fun check_sorts ((fname, fT), _) =
- Sorts.of_sort (Sign.classes_of (ProofContext.theory_of ctxt)) (fT, HOLogic.typeS)
- orelse error (cat_lines
- ["Type of " ^ quote fname ^ " is not of sort " ^ quote "type" ^ ":",
- setmp_CRITICAL show_sorts true (Syntax.string_of_typ ctxt) fT])
-
- val _ = map check_sorts fixes
- in
- ()
- end
-
-(* Preprocessors *)
-
-type fixes = ((string * typ) * mixfix) list
-type 'a spec = (Attrib.binding * 'a list) list
-type preproc = fundef_config -> Proof.context -> fixes -> term spec
- -> (term list * (thm list -> thm spec) * (thm list -> thm list list) * string list)
-
-val fname_of = fst o dest_Free o fst o strip_comb o fst
- o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all
-
-fun mk_case_names i "" k = mk_case_names i (string_of_int (i + 1)) k
- | mk_case_names _ n 0 = []
- | mk_case_names _ n 1 = [n]
- | mk_case_names _ n k = map (fn i => n ^ "_" ^ string_of_int i) (1 upto k)
-
-fun empty_preproc check _ ctxt fixes spec =
- let
- val (bnds, tss) = split_list spec
- val ts = flat tss
- val _ = check ctxt fixes ts
- val fnames = map (fst o fst) fixes
- val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts
-
- fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1)
- (indices ~~ xs)
- |> map (map snd)
-
- (* using theorem names for case name currently disabled *)
- val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat
- in
- (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames)
- end
-
-structure Preprocessor = GenericDataFun
-(
- type T = preproc
- val empty : T = empty_preproc check_defs
- val extend = I
- fun merge _ (a, _) = a
-);
-
-val get_preproc = Preprocessor.get o Context.Proof
-val set_preproc = Preprocessor.map o K
-
-
-
-local
- structure P = OuterParse and K = OuterKeyword
-
- val option_parser =
- P.group "option" ((P.reserved "sequential" >> K Sequential)
- || ((P.reserved "default" |-- P.term) >> Default)
- || (P.reserved "domintros" >> K DomIntros)
- || (P.reserved "tailrec" >> K Tailrec))
-
- fun config_parser default =
- (Scan.optional (P.$$$ "(" |-- P.!!! (P.list1 option_parser) --| P.$$$ ")") [])
- >> (fn opts => fold apply_opt opts default)
-in
- fun fundef_parser default_cfg =
- config_parser default_cfg -- P.fixes -- SpecParse.where_alt_specs
-end
-
-
-end
-end
---- a/src/HOL/Tools/Function/fundef_core.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,956 +0,0 @@
-(* Title: HOL/Tools/Function/fundef_core.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions:
-Main functionality.
-*)
-
-signature FUNDEF_CORE =
-sig
- val trace: bool Unsynchronized.ref
-
- val prepare_fundef : FundefCommon.fundef_config
- -> string (* defname *)
- -> ((bstring * typ) * mixfix) list (* defined symbol *)
- -> ((bstring * typ) list * term list * term * term) list (* specification *)
- -> local_theory
-
- -> (term (* f *)
- * thm (* goalstate *)
- * (thm -> FundefCommon.fundef_result) (* continuation *)
- ) * local_theory
-
-end
-
-structure FundefCore : FUNDEF_CORE =
-struct
-
-val trace = Unsynchronized.ref false;
-fun trace_msg msg = if ! trace then tracing (msg ()) else ();
-
-val boolT = HOLogic.boolT
-val mk_eq = HOLogic.mk_eq
-
-open FundefLib
-open FundefCommon
-
-datatype globals =
- Globals of {
- fvar: term,
- domT: typ,
- ranT: typ,
- h: term,
- y: term,
- x: term,
- z: term,
- a: term,
- P: term,
- D: term,
- Pbool:term
-}
-
-
-datatype rec_call_info =
- RCInfo of
- {
- RIvs: (string * typ) list, (* Call context: fixes and assumes *)
- CCas: thm list,
- rcarg: term, (* The recursive argument *)
-
- llRI: thm,
- h_assum: term
- }
-
-
-datatype clause_context =
- ClauseContext of
- {
- ctxt : Proof.context,
-
- qs : term list,
- gs : term list,
- lhs: term,
- rhs: term,
-
- cqs: cterm list,
- ags: thm list,
- case_hyp : thm
- }
-
-
-fun transfer_clause_ctx thy (ClauseContext { ctxt, qs, gs, lhs, rhs, cqs, ags, case_hyp }) =
- ClauseContext { ctxt = ProofContext.transfer thy ctxt,
- qs = qs, gs = gs, lhs = lhs, rhs = rhs, cqs = cqs, ags = ags, case_hyp = case_hyp }
-
-
-datatype clause_info =
- ClauseInfo of
- {
- no: int,
- qglr : ((string * typ) list * term list * term * term),
- cdata : clause_context,
-
- tree: FundefCtxTree.ctx_tree,
- lGI: thm,
- RCs: rec_call_info list
- }
-
-
-(* Theory dependencies. *)
-val Pair_inject = @{thm Product_Type.Pair_inject};
-
-val acc_induct_rule = @{thm accp_induct_rule};
-
-val ex1_implies_ex = @{thm FunDef.fundef_ex1_existence};
-val ex1_implies_un = @{thm FunDef.fundef_ex1_uniqueness};
-val ex1_implies_iff = @{thm FunDef.fundef_ex1_iff};
-
-val acc_downward = @{thm accp_downward};
-val accI = @{thm accp.accI};
-val case_split = @{thm HOL.case_split};
-val fundef_default_value = @{thm FunDef.fundef_default_value};
-val not_acc_down = @{thm not_accp_down};
-
-
-
-fun find_calls tree =
- let
- fun add_Ri (fixes,assumes) (_ $ arg) _ (_, xs) = ([], (fixes, assumes, arg) :: xs)
- | add_Ri _ _ _ _ = raise Match
- in
- rev (FundefCtxTree.traverse_tree add_Ri tree [])
- end
-
-
-(** building proof obligations *)
-
-fun mk_compat_proof_obligations domT ranT fvar f glrs =
- let
- fun mk_impl ((qs, gs, lhs, rhs),(qs', gs', lhs', rhs')) =
- let
- val shift = incr_boundvars (length qs')
- in
- Logic.mk_implies
- (HOLogic.mk_Trueprop (HOLogic.eq_const domT $ shift lhs $ lhs'),
- HOLogic.mk_Trueprop (HOLogic.eq_const ranT $ shift rhs $ rhs'))
- |> fold_rev (curry Logic.mk_implies) (map shift gs @ gs')
- |> fold_rev (fn (n,T) => fn b => Term.all T $ Abs(n,T,b)) (qs @ qs')
- |> curry abstract_over fvar
- |> curry subst_bound f
- end
- in
- map mk_impl (unordered_pairs glrs)
- end
-
-
-fun mk_completeness (Globals {x, Pbool, ...}) clauses qglrs =
- let
- fun mk_case (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) =
- HOLogic.mk_Trueprop Pbool
- |> curry Logic.mk_implies (HOLogic.mk_Trueprop (mk_eq (x, lhs)))
- |> fold_rev (curry Logic.mk_implies) gs
- |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
- in
- HOLogic.mk_Trueprop Pbool
- |> fold_rev (curry Logic.mk_implies o mk_case) (clauses ~~ qglrs)
- |> mk_forall_rename ("x", x)
- |> mk_forall_rename ("P", Pbool)
- end
-
-(** making a context with it's own local bindings **)
-
-fun mk_clause_context x ctxt (pre_qs,pre_gs,pre_lhs,pre_rhs) =
- let
- val (qs, ctxt') = Variable.variant_fixes (map fst pre_qs) ctxt
- |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
-
- val thy = ProofContext.theory_of ctxt'
-
- fun inst t = subst_bounds (rev qs, t)
- val gs = map inst pre_gs
- val lhs = inst pre_lhs
- val rhs = inst pre_rhs
-
- val cqs = map (cterm_of thy) qs
- val ags = map (assume o cterm_of thy) gs
-
- val case_hyp = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (x, lhs))))
- in
- ClauseContext { ctxt = ctxt', qs = qs, gs = gs, lhs = lhs, rhs = rhs,
- cqs = cqs, ags = ags, case_hyp = case_hyp }
- end
-
-
-(* lowlevel term function. FIXME: remove *)
-fun abstract_over_list vs body =
- let
- fun abs lev v tm =
- if v aconv tm then Bound lev
- else
- (case tm of
- Abs (a, T, t) => Abs (a, T, abs (lev + 1) v t)
- | t $ u => abs lev v t $ abs lev v u
- | t => t);
- in
- fold_index (fn (i, v) => fn t => abs i v t) vs body
- end
-
-
-
-fun mk_clause_info globals G f no cdata qglr tree RCs GIntro_thm RIntro_thms =
- let
- val Globals {h, fvar, x, ...} = globals
-
- val ClauseContext { ctxt, qs, cqs, ags, ... } = cdata
- val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
-
- (* Instantiate the GIntro thm with "f" and import into the clause context. *)
- val lGI = GIntro_thm
- |> forall_elim (cert f)
- |> fold forall_elim cqs
- |> fold Thm.elim_implies ags
-
- fun mk_call_info (rcfix, rcassm, rcarg) RI =
- let
- val llRI = RI
- |> fold forall_elim cqs
- |> fold (forall_elim o cert o Free) rcfix
- |> fold Thm.elim_implies ags
- |> fold Thm.elim_implies rcassm
-
- val h_assum =
- HOLogic.mk_Trueprop (G $ rcarg $ (h $ rcarg))
- |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
- |> fold_rev (Logic.all o Free) rcfix
- |> Pattern.rewrite_term (ProofContext.theory_of ctxt) [(f, h)] []
- |> abstract_over_list (rev qs)
- in
- RCInfo {RIvs=rcfix, rcarg=rcarg, CCas=rcassm, llRI=llRI, h_assum=h_assum}
- end
-
- val RC_infos = map2 mk_call_info RCs RIntro_thms
- in
- ClauseInfo
- {
- no=no,
- cdata=cdata,
- qglr=qglr,
-
- lGI=lGI,
- RCs=RC_infos,
- tree=tree
- }
- end
-
-
-
-
-
-
-
-(* replace this by a table later*)
-fun store_compat_thms 0 thms = []
- | store_compat_thms n thms =
- let
- val (thms1, thms2) = chop n thms
- in
- (thms1 :: store_compat_thms (n - 1) thms2)
- end
-
-(* expects i <= j *)
-fun lookup_compat_thm i j cts =
- nth (nth cts (i - 1)) (j - i)
-
-(* Returns "Gsi, Gsj, lhs_i = lhs_j |-- rhs_j_f = rhs_i_f" *)
-(* if j < i, then turn around *)
-fun get_compat_thm thy cts i j ctxi ctxj =
- let
- val ClauseContext {cqs=cqsi,ags=agsi,lhs=lhsi,...} = ctxi
- val ClauseContext {cqs=cqsj,ags=agsj,lhs=lhsj,...} = ctxj
-
- val lhsi_eq_lhsj = cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj)))
- in if j < i then
- let
- val compat = lookup_compat_thm j i cts
- in
- compat (* "!!qj qi. Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
- |> fold forall_elim (cqsj @ cqsi) (* "Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
- |> fold Thm.elim_implies agsj
- |> fold Thm.elim_implies agsi
- |> Thm.elim_implies ((assume lhsi_eq_lhsj) RS sym) (* "Gsj, Gsi, lhsi = lhsj |-- rhsj = rhsi" *)
- end
- else
- let
- val compat = lookup_compat_thm i j cts
- in
- compat (* "!!qi qj. Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
- |> fold forall_elim (cqsi @ cqsj) (* "Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
- |> fold Thm.elim_implies agsi
- |> fold Thm.elim_implies agsj
- |> Thm.elim_implies (assume lhsi_eq_lhsj)
- |> (fn thm => thm RS sym) (* "Gsi, Gsj, lhsi = lhsj |-- rhsj = rhsi" *)
- end
- end
-
-
-
-
-(* Generates the replacement lemma in fully quantified form. *)
-fun mk_replacement_lemma thy h ih_elim clause =
- let
- val ClauseInfo {cdata=ClauseContext {qs, lhs, rhs, cqs, ags, case_hyp, ...}, RCs, tree, ...} = clause
- local open Conv in
- val ih_conv = arg1_conv o arg_conv o arg_conv
- end
-
- val ih_elim_case = Conv.fconv_rule (ih_conv (K (case_hyp RS eq_reflection))) ih_elim
-
- val Ris = map (fn RCInfo {llRI, ...} => llRI) RCs
- val h_assums = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qs, h_assum)))) RCs
-
- val (eql, _) = FundefCtxTree.rewrite_by_tree thy h ih_elim_case (Ris ~~ h_assums) tree
-
- val replace_lemma = (eql RS meta_eq_to_obj_eq)
- |> implies_intr (cprop_of case_hyp)
- |> fold_rev (implies_intr o cprop_of) h_assums
- |> fold_rev (implies_intr o cprop_of) ags
- |> fold_rev forall_intr cqs
- |> Thm.close_derivation
- in
- replace_lemma
- end
-
-
-fun mk_uniqueness_clause thy globals f compat_store clausei clausej RLj =
- let
- val Globals {h, y, x, fvar, ...} = globals
- val ClauseInfo {no=i, cdata=cctxi as ClauseContext {ctxt=ctxti, lhs=lhsi, case_hyp, ...}, ...} = clausei
- val ClauseInfo {no=j, qglr=cdescj, RCs=RCsj, ...} = clausej
-
- val cctxj as ClauseContext {ags = agsj', lhs = lhsj', rhs = rhsj', qs = qsj', cqs = cqsj', ...}
- = mk_clause_context x ctxti cdescj
-
- val rhsj'h = Pattern.rewrite_term thy [(fvar,h)] [] rhsj'
- val compat = get_compat_thm thy compat_store i j cctxi cctxj
- val Ghsj' = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qsj', h_assum)))) RCsj
-
- val RLj_import =
- RLj |> fold forall_elim cqsj'
- |> fold Thm.elim_implies agsj'
- |> fold Thm.elim_implies Ghsj'
-
- val y_eq_rhsj'h = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (y, rhsj'h))))
- val lhsi_eq_lhsj' = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj')))) (* lhs_i = lhs_j' |-- lhs_i = lhs_j' *)
- in
- (trans OF [case_hyp, lhsi_eq_lhsj']) (* lhs_i = lhs_j' |-- x = lhs_j' *)
- |> implies_elim RLj_import (* Rj1' ... Rjk', lhs_i = lhs_j' |-- rhs_j'_h = rhs_j'_f *)
- |> (fn it => trans OF [it, compat]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk' |-- rhs_j'_h = rhs_i_f *)
- |> (fn it => trans OF [y_eq_rhsj'h, it]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk', y = rhs_j_h' |-- y = rhs_i_f *)
- |> fold_rev (implies_intr o cprop_of) Ghsj'
- |> fold_rev (implies_intr o cprop_of) agsj' (* lhs_i = lhs_j' , y = rhs_j_h' |-- Gj', Rj1'...Rjk' ==> y = rhs_i_f *)
- |> implies_intr (cprop_of y_eq_rhsj'h)
- |> implies_intr (cprop_of lhsi_eq_lhsj')
- |> fold_rev forall_intr (cterm_of thy h :: cqsj')
- end
-
-
-
-fun mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_cases compat_store clauses rep_lemmas clausei =
- let
- val Globals {x, y, ranT, fvar, ...} = globals
- val ClauseInfo {cdata = ClauseContext {lhs, rhs, qs, cqs, ags, case_hyp, ...}, lGI, RCs, ...} = clausei
- val rhsC = Pattern.rewrite_term thy [(fvar, f)] [] rhs
-
- val ih_intro_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ih_intro
-
- fun prep_RC (RCInfo {llRI, RIvs, CCas, ...}) = (llRI RS ih_intro_case)
- |> fold_rev (implies_intr o cprop_of) CCas
- |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
-
- val existence = fold (curry op COMP o prep_RC) RCs lGI
-
- val P = cterm_of thy (mk_eq (y, rhsC))
- val G_lhs_y = assume (cterm_of thy (HOLogic.mk_Trueprop (G $ lhs $ y)))
-
- val unique_clauses = map2 (mk_uniqueness_clause thy globals f compat_store clausei) clauses rep_lemmas
-
- val uniqueness = G_cases
- |> forall_elim (cterm_of thy lhs)
- |> forall_elim (cterm_of thy y)
- |> forall_elim P
- |> Thm.elim_implies G_lhs_y
- |> fold Thm.elim_implies unique_clauses
- |> implies_intr (cprop_of G_lhs_y)
- |> forall_intr (cterm_of thy y)
-
- val P2 = cterm_of thy (lambda y (G $ lhs $ y)) (* P2 y := (lhs, y): G *)
-
- val exactly_one =
- ex1I |> instantiate' [SOME (ctyp_of thy ranT)] [SOME P2, SOME (cterm_of thy rhsC)]
- |> curry (op COMP) existence
- |> curry (op COMP) uniqueness
- |> simplify (HOL_basic_ss addsimps [case_hyp RS sym])
- |> implies_intr (cprop_of case_hyp)
- |> fold_rev (implies_intr o cprop_of) ags
- |> fold_rev forall_intr cqs
-
- val function_value =
- existence
- |> implies_intr ihyp
- |> implies_intr (cprop_of case_hyp)
- |> forall_intr (cterm_of thy x)
- |> forall_elim (cterm_of thy lhs)
- |> curry (op RS) refl
- in
- (exactly_one, function_value)
- end
-
-
-
-
-fun prove_stuff ctxt globals G f R clauses complete compat compat_store G_elim f_def =
- let
- val Globals {h, domT, ranT, x, ...} = globals
- val thy = ProofContext.theory_of ctxt
-
- (* Inductive Hypothesis: !!z. (z,x):R ==> EX!y. (z,y):G *)
- val ihyp = Term.all domT $ Abs ("z", domT,
- Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
- HOLogic.mk_Trueprop (Const ("Ex1", (ranT --> boolT) --> boolT) $
- Abs ("y", ranT, G $ Bound 1 $ Bound 0))))
- |> cterm_of thy
-
- val ihyp_thm = assume ihyp |> Thm.forall_elim_vars 0
- val ih_intro = ihyp_thm RS (f_def RS ex1_implies_ex)
- val ih_elim = ihyp_thm RS (f_def RS ex1_implies_un)
- |> instantiate' [] [NONE, SOME (cterm_of thy h)]
-
- val _ = trace_msg (K "Proving Replacement lemmas...")
- val repLemmas = map (mk_replacement_lemma thy h ih_elim) clauses
-
- val _ = trace_msg (K "Proving cases for unique existence...")
- val (ex1s, values) =
- split_list (map (mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_elim compat_store clauses repLemmas) clauses)
-
- val _ = trace_msg (K "Proving: Graph is a function")
- val graph_is_function = complete
- |> Thm.forall_elim_vars 0
- |> fold (curry op COMP) ex1s
- |> implies_intr (ihyp)
- |> implies_intr (cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ x)))
- |> forall_intr (cterm_of thy x)
- |> (fn it => Drule.compose_single (it, 2, acc_induct_rule)) (* "EX! y. (?x,y):G" *)
- |> (fn it => fold (forall_intr o cterm_of thy o Var) (Term.add_vars (prop_of it) []) it)
-
- val goalstate = Conjunction.intr graph_is_function complete
- |> Thm.close_derivation
- |> Goal.protect
- |> fold_rev (implies_intr o cprop_of) compat
- |> implies_intr (cprop_of complete)
- in
- (goalstate, values)
- end
-
-
-fun define_graph Gname fvar domT ranT clauses RCss lthy =
- let
- val GT = domT --> ranT --> boolT
- val Gvar = Free (the_single (Variable.variant_frees lthy [] [(Gname, GT)]))
-
- fun mk_GIntro (ClauseContext {qs, gs, lhs, rhs, ...}) RCs =
- let
- fun mk_h_assm (rcfix, rcassm, rcarg) =
- HOLogic.mk_Trueprop (Gvar $ rcarg $ (fvar $ rcarg))
- |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
- |> fold_rev (Logic.all o Free) rcfix
- in
- HOLogic.mk_Trueprop (Gvar $ lhs $ rhs)
- |> fold_rev (curry Logic.mk_implies o mk_h_assm) RCs
- |> fold_rev (curry Logic.mk_implies) gs
- |> fold_rev Logic.all (fvar :: qs)
- end
-
- val G_intros = map2 mk_GIntro clauses RCss
-
- val (GIntro_thms, (G, G_elim, G_induct, lthy)) =
- FundefInductiveWrap.inductive_def G_intros ((dest_Free Gvar, NoSyn), lthy)
- in
- ((G, GIntro_thms, G_elim, G_induct), lthy)
- end
-
-
-
-fun define_function fdefname (fname, mixfix) domT ranT G default lthy =
- let
- val f_def =
- Abs ("x", domT, Const (@{const_name FunDef.THE_default}, ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $
- Abs ("y", ranT, G $ Bound 1 $ Bound 0))
- |> Syntax.check_term lthy
-
- val ((f, (_, f_defthm)), lthy) =
- LocalTheory.define Thm.internalK ((Binding.name (function_name fname), mixfix), ((Binding.name fdefname, []), f_def)) lthy
- in
- ((f, f_defthm), lthy)
- end
-
-
-fun define_recursion_relation Rname domT ranT fvar f qglrs clauses RCss lthy =
- let
-
- val RT = domT --> domT --> boolT
- val Rvar = Free (the_single (Variable.variant_frees lthy [] [(Rname, RT)]))
-
- fun mk_RIntro (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) (rcfix, rcassm, rcarg) =
- HOLogic.mk_Trueprop (Rvar $ rcarg $ lhs)
- |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
- |> fold_rev (curry Logic.mk_implies) gs
- |> fold_rev (Logic.all o Free) rcfix
- |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
- (* "!!qs xs. CS ==> G => (r, lhs) : R" *)
-
- val R_intross = map2 (map o mk_RIntro) (clauses ~~ qglrs) RCss
-
- val (RIntro_thmss, (R, R_elim, _, lthy)) =
- fold_burrow FundefInductiveWrap.inductive_def R_intross ((dest_Free Rvar, NoSyn), lthy)
- in
- ((R, RIntro_thmss, R_elim), lthy)
- end
-
-
-fun fix_globals domT ranT fvar ctxt =
- let
- val ([h, y, x, z, a, D, P, Pbool],ctxt') =
- Variable.variant_fixes ["h_fd", "y_fd", "x_fd", "z_fd", "a_fd", "D_fd", "P_fd", "Pb_fd"] ctxt
- in
- (Globals {h = Free (h, domT --> ranT),
- y = Free (y, ranT),
- x = Free (x, domT),
- z = Free (z, domT),
- a = Free (a, domT),
- D = Free (D, domT --> boolT),
- P = Free (P, domT --> boolT),
- Pbool = Free (Pbool, boolT),
- fvar = fvar,
- domT = domT,
- ranT = ranT
- },
- ctxt')
- end
-
-
-
-fun inst_RC thy fvar f (rcfix, rcassm, rcarg) =
- let
- fun inst_term t = subst_bound(f, abstract_over (fvar, t))
- in
- (rcfix, map (assume o cterm_of thy o inst_term o prop_of) rcassm, inst_term rcarg)
- end
-
-
-
-(**********************************************************
- * PROVING THE RULES
- **********************************************************)
-
-fun mk_psimps thy globals R clauses valthms f_iff graph_is_function =
- let
- val Globals {domT, z, ...} = globals
-
- fun mk_psimp (ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {cqs, lhs, ags, ...}, ...}) valthm =
- let
- val lhs_acc = cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ lhs)) (* "acc R lhs" *)
- val z_smaller = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ lhs)) (* "R z lhs" *)
- in
- ((assume z_smaller) RS ((assume lhs_acc) RS acc_downward))
- |> (fn it => it COMP graph_is_function)
- |> implies_intr z_smaller
- |> forall_intr (cterm_of thy z)
- |> (fn it => it COMP valthm)
- |> implies_intr lhs_acc
- |> asm_simplify (HOL_basic_ss addsimps [f_iff])
- |> fold_rev (implies_intr o cprop_of) ags
- |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
- end
- in
- map2 mk_psimp clauses valthms
- end
-
-
-(** Induction rule **)
-
-
-val acc_subset_induct = @{thm Orderings.predicate1I} RS @{thm accp_subset_induct}
-
-
-fun mk_partial_induct_rule thy globals R complete_thm clauses =
- let
- val Globals {domT, x, z, a, P, D, ...} = globals
- val acc_R = mk_acc domT R
-
- val x_D = assume (cterm_of thy (HOLogic.mk_Trueprop (D $ x)))
- val a_D = cterm_of thy (HOLogic.mk_Trueprop (D $ a))
-
- val D_subset = cterm_of thy (Logic.all x
- (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x), HOLogic.mk_Trueprop (acc_R $ x))))
-
- val D_dcl = (* "!!x z. [| x: D; (z,x):R |] ==> z:D" *)
- Logic.all x
- (Logic.all z (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x),
- Logic.mk_implies (HOLogic.mk_Trueprop (R $ z $ x),
- HOLogic.mk_Trueprop (D $ z)))))
- |> cterm_of thy
-
-
- (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
- val ihyp = Term.all domT $ Abs ("z", domT,
- Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
- HOLogic.mk_Trueprop (P $ Bound 0)))
- |> cterm_of thy
-
- val aihyp = assume ihyp
-
- fun prove_case clause =
- let
- val ClauseInfo {cdata = ClauseContext {ctxt, qs, cqs, ags, gs, lhs, case_hyp, ...}, RCs,
- qglr = (oqs, _, _, _), ...} = clause
-
- val case_hyp_conv = K (case_hyp RS eq_reflection)
- local open Conv in
- val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
- val sih = fconv_rule (More_Conv.binder_conv (K (arg1_conv (arg_conv (arg_conv case_hyp_conv)))) ctxt) aihyp
- end
-
- fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) =
- sih |> forall_elim (cterm_of thy rcarg)
- |> Thm.elim_implies llRI
- |> fold_rev (implies_intr o cprop_of) CCas
- |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
-
- val P_recs = map mk_Prec RCs (* [P rec1, P rec2, ... ] *)
-
- val step = HOLogic.mk_Trueprop (P $ lhs)
- |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
- |> fold_rev (curry Logic.mk_implies) gs
- |> curry Logic.mk_implies (HOLogic.mk_Trueprop (D $ lhs))
- |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
- |> cterm_of thy
-
- val P_lhs = assume step
- |> fold forall_elim cqs
- |> Thm.elim_implies lhs_D
- |> fold Thm.elim_implies ags
- |> fold Thm.elim_implies P_recs
-
- val res = cterm_of thy (HOLogic.mk_Trueprop (P $ x))
- |> Conv.arg_conv (Conv.arg_conv case_hyp_conv)
- |> symmetric (* P lhs == P x *)
- |> (fn eql => equal_elim eql P_lhs) (* "P x" *)
- |> implies_intr (cprop_of case_hyp)
- |> fold_rev (implies_intr o cprop_of) ags
- |> fold_rev forall_intr cqs
- in
- (res, step)
- end
-
- val (cases, steps) = split_list (map prove_case clauses)
-
- val istep = complete_thm
- |> Thm.forall_elim_vars 0
- |> fold (curry op COMP) cases (* P x *)
- |> implies_intr ihyp
- |> implies_intr (cprop_of x_D)
- |> forall_intr (cterm_of thy x)
-
- val subset_induct_rule =
- acc_subset_induct
- |> (curry op COMP) (assume D_subset)
- |> (curry op COMP) (assume D_dcl)
- |> (curry op COMP) (assume a_D)
- |> (curry op COMP) istep
- |> fold_rev implies_intr steps
- |> implies_intr a_D
- |> implies_intr D_dcl
- |> implies_intr D_subset
-
- val subset_induct_all = fold_rev (forall_intr o cterm_of thy) [P, a, D] subset_induct_rule
-
- val simple_induct_rule =
- subset_induct_rule
- |> forall_intr (cterm_of thy D)
- |> forall_elim (cterm_of thy acc_R)
- |> assume_tac 1 |> Seq.hd
- |> (curry op COMP) (acc_downward
- |> (instantiate' [SOME (ctyp_of thy domT)]
- (map (SOME o cterm_of thy) [R, x, z]))
- |> forall_intr (cterm_of thy z)
- |> forall_intr (cterm_of thy x))
- |> forall_intr (cterm_of thy a)
- |> forall_intr (cterm_of thy P)
- in
- simple_induct_rule
- end
-
-
-
-(* FIXME: This should probably use fixed goals, to be more reliable and faster *)
-fun mk_domain_intro ctxt (Globals {domT, ...}) R R_cases clause =
- let
- val thy = ProofContext.theory_of ctxt
- val ClauseInfo {cdata = ClauseContext {qs, gs, lhs, rhs, cqs, ...},
- qglr = (oqs, _, _, _), ...} = clause
- val goal = HOLogic.mk_Trueprop (mk_acc domT R $ lhs)
- |> fold_rev (curry Logic.mk_implies) gs
- |> cterm_of thy
- in
- Goal.init goal
- |> (SINGLE (resolve_tac [accI] 1)) |> the
- |> (SINGLE (eresolve_tac [Thm.forall_elim_vars 0 R_cases] 1)) |> the
- |> (SINGLE (auto_tac (clasimpset_of ctxt))) |> the
- |> Goal.conclude
- |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
- end
-
-
-
-(** Termination rule **)
-
-val wf_induct_rule = @{thm Wellfounded.wfP_induct_rule};
-val wf_in_rel = @{thm FunDef.wf_in_rel};
-val in_rel_def = @{thm FunDef.in_rel_def};
-
-fun mk_nest_term_case thy globals R' ihyp clause =
- let
- val Globals {x, z, ...} = globals
- val ClauseInfo {cdata = ClauseContext {qs,cqs,ags,lhs,rhs,case_hyp,...},tree,
- qglr=(oqs, _, _, _), ...} = clause
-
- val ih_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ihyp
-
- fun step (fixes, assumes) (_ $ arg) u (sub,(hyps,thms)) =
- let
- val used = map (fn (ctx,thm) => FundefCtxTree.export_thm thy ctx thm) (u @ sub)
-
- val hyp = HOLogic.mk_Trueprop (R' $ arg $ lhs)
- |> fold_rev (curry Logic.mk_implies o prop_of) used (* additional hyps *)
- |> FundefCtxTree.export_term (fixes, assumes)
- |> fold_rev (curry Logic.mk_implies o prop_of) ags
- |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
- |> cterm_of thy
-
- val thm = assume hyp
- |> fold forall_elim cqs
- |> fold Thm.elim_implies ags
- |> FundefCtxTree.import_thm thy (fixes, assumes)
- |> fold Thm.elim_implies used (* "(arg, lhs) : R'" *)
-
- val z_eq_arg = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (z, arg))))
-
- val acc = thm COMP ih_case
- val z_acc_local = acc
- |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (K (symmetric (z_eq_arg RS eq_reflection)))))
-
- val ethm = z_acc_local
- |> FundefCtxTree.export_thm thy (fixes,
- z_eq_arg :: case_hyp :: ags @ assumes)
- |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
-
- val sub' = sub @ [(([],[]), acc)]
- in
- (sub', (hyp :: hyps, ethm :: thms))
- end
- | step _ _ _ _ = raise Match
- in
- FundefCtxTree.traverse_tree step tree
- end
-
-
-fun mk_nest_term_rule thy globals R R_cases clauses =
- let
- val Globals { domT, x, z, ... } = globals
- val acc_R = mk_acc domT R
-
- val R' = Free ("R", fastype_of R)
-
- val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
- val inrel_R = Const (@{const_name FunDef.in_rel}, HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
-
- val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
-
- (* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
- val ihyp = Term.all domT $ Abs ("z", domT,
- Logic.mk_implies (HOLogic.mk_Trueprop (R' $ Bound 0 $ x),
- HOLogic.mk_Trueprop (acc_R $ Bound 0)))
- |> cterm_of thy
-
- val ihyp_a = assume ihyp |> Thm.forall_elim_vars 0
-
- val R_z_x = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ x))
-
- val (hyps,cases) = fold (mk_nest_term_case thy globals R' ihyp_a) clauses ([],[])
- in
- R_cases
- |> forall_elim (cterm_of thy z)
- |> forall_elim (cterm_of thy x)
- |> forall_elim (cterm_of thy (acc_R $ z))
- |> curry op COMP (assume R_z_x)
- |> fold_rev (curry op COMP) cases
- |> implies_intr R_z_x
- |> forall_intr (cterm_of thy z)
- |> (fn it => it COMP accI)
- |> implies_intr ihyp
- |> forall_intr (cterm_of thy x)
- |> (fn it => Drule.compose_single(it,2,wf_induct_rule))
- |> curry op RS (assume wfR')
- |> forall_intr_vars
- |> (fn it => it COMP allI)
- |> fold implies_intr hyps
- |> implies_intr wfR'
- |> forall_intr (cterm_of thy R')
- |> forall_elim (cterm_of thy (inrel_R))
- |> curry op RS wf_in_rel
- |> full_simplify (HOL_basic_ss addsimps [in_rel_def])
- |> forall_intr (cterm_of thy Rrel)
- end
-
-
-
-(* Tail recursion (probably very fragile)
- *
- * FIXME:
- * - Need to do forall_elim_vars on psimps: Unneccesary, if psimps would be taken from the same context.
- * - Must we really replace the fvar by f here?
- * - Splitting is not configured automatically: Problems with case?
- *)
-fun mk_trsimps octxt globals f G R f_def R_cases G_induct clauses psimps =
- let
- val Globals {domT, ranT, fvar, ...} = globals
-
- val R_cases = Thm.forall_elim_vars 0 R_cases (* FIXME: Should be already in standard form. *)
-
- val graph_implies_dom = (* "G ?x ?y ==> dom ?x" *)
- Goal.prove octxt ["x", "y"] [HOLogic.mk_Trueprop (G $ Free ("x", domT) $ Free ("y", ranT))]
- (HOLogic.mk_Trueprop (mk_acc domT R $ Free ("x", domT)))
- (fn {prems=[a], ...} =>
- ((rtac (G_induct OF [a]))
- THEN_ALL_NEW (rtac accI)
- THEN_ALL_NEW (etac R_cases)
- THEN_ALL_NEW (asm_full_simp_tac (simpset_of octxt))) 1)
-
- val default_thm = (forall_intr_vars graph_implies_dom) COMP (f_def COMP fundef_default_value)
-
- fun mk_trsimp clause psimp =
- let
- val ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {ctxt, cqs, qs, gs, lhs, rhs, ...}, ...} = clause
- val thy = ProofContext.theory_of ctxt
- val rhs_f = Pattern.rewrite_term thy [(fvar, f)] [] rhs
-
- val trsimp = Logic.list_implies(gs, HOLogic.mk_Trueprop (HOLogic.mk_eq(f $ lhs, rhs_f))) (* "f lhs = rhs" *)
- val lhs_acc = (mk_acc domT R $ lhs) (* "acc R lhs" *)
- fun simp_default_tac ss = asm_full_simp_tac (ss addsimps [default_thm, Let_def])
- in
- Goal.prove ctxt [] [] trsimp
- (fn _ =>
- rtac (instantiate' [] [SOME (cterm_of thy lhs_acc)] case_split) 1
- THEN (rtac (Thm.forall_elim_vars 0 psimp) THEN_ALL_NEW assume_tac) 1
- THEN (simp_default_tac (simpset_of ctxt) 1)
- THEN (etac not_acc_down 1)
- THEN ((etac R_cases) THEN_ALL_NEW (simp_default_tac (simpset_of ctxt))) 1)
- |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
- end
- in
- map2 mk_trsimp clauses psimps
- end
-
-
-fun prepare_fundef config defname [((fname, fT), mixfix)] abstract_qglrs lthy =
- let
- val FundefConfig {domintros, tailrec, default=default_str, ...} = config
-
- val fvar = Free (fname, fT)
- val domT = domain_type fT
- val ranT = range_type fT
-
- val default = Syntax.parse_term lthy default_str
- |> TypeInfer.constrain fT |> Syntax.check_term lthy
-
- val (globals, ctxt') = fix_globals domT ranT fvar lthy
-
- val Globals { x, h, ... } = globals
-
- val clauses = map (mk_clause_context x ctxt') abstract_qglrs
-
- val n = length abstract_qglrs
-
- fun build_tree (ClauseContext { ctxt, rhs, ...}) =
- FundefCtxTree.mk_tree (fname, fT) h ctxt rhs
-
- val trees = map build_tree clauses
- val RCss = map find_calls trees
-
- val ((G, GIntro_thms, G_elim, G_induct), lthy) =
- PROFILE "def_graph" (define_graph (graph_name defname) fvar domT ranT clauses RCss) lthy
-
- val ((f, f_defthm), lthy) =
- PROFILE "def_fun" (define_function (defname ^ "_sumC_def") (fname, mixfix) domT ranT G default) lthy
-
- val RCss = map (map (inst_RC (ProofContext.theory_of lthy) fvar f)) RCss
- val trees = map (FundefCtxTree.inst_tree (ProofContext.theory_of lthy) fvar f) trees
-
- val ((R, RIntro_thmss, R_elim), lthy) =
- PROFILE "def_rel" (define_recursion_relation (rel_name defname) domT ranT fvar f abstract_qglrs clauses RCss) lthy
-
- val (_, lthy) =
- LocalTheory.abbrev Syntax.mode_default ((Binding.name (dom_name defname), NoSyn), mk_acc domT R) lthy
-
- val newthy = ProofContext.theory_of lthy
- val clauses = map (transfer_clause_ctx newthy) clauses
-
- val cert = cterm_of (ProofContext.theory_of lthy)
-
- val xclauses = PROFILE "xclauses" (map7 (mk_clause_info globals G f) (1 upto n) clauses abstract_qglrs trees RCss GIntro_thms) RIntro_thmss
-
- val complete = mk_completeness globals clauses abstract_qglrs |> cert |> assume
- val compat = mk_compat_proof_obligations domT ranT fvar f abstract_qglrs |> map (cert #> assume)
-
- val compat_store = store_compat_thms n compat
-
- val (goalstate, values) = PROFILE "prove_stuff" (prove_stuff lthy globals G f R xclauses complete compat compat_store G_elim) f_defthm
-
- val mk_trsimps = mk_trsimps lthy globals f G R f_defthm R_elim G_induct xclauses
-
- fun mk_partial_rules provedgoal =
- let
- val newthy = theory_of_thm provedgoal (*FIXME*)
-
- val (graph_is_function, complete_thm) =
- provedgoal
- |> Conjunction.elim
- |> apfst (Thm.forall_elim_vars 0)
-
- val f_iff = graph_is_function RS (f_defthm RS ex1_implies_iff)
-
- val psimps = PROFILE "Proving simplification rules" (mk_psimps newthy globals R xclauses values f_iff) graph_is_function
-
- val simple_pinduct = PROFILE "Proving partial induction rule"
- (mk_partial_induct_rule newthy globals R complete_thm) xclauses
-
-
- val total_intro = PROFILE "Proving nested termination rule" (mk_nest_term_rule newthy globals R R_elim) xclauses
-
- val dom_intros = if domintros
- then SOME (PROFILE "Proving domain introduction rules" (map (mk_domain_intro lthy globals R R_elim)) xclauses)
- else NONE
- val trsimps = if tailrec then SOME (mk_trsimps psimps) else NONE
-
- in
- FundefResult {fs=[f], G=G, R=R, cases=complete_thm,
- psimps=psimps, simple_pinducts=[simple_pinduct],
- termination=total_intro, trsimps=trsimps,
- domintros=dom_intros}
- end
- in
- ((f, goalstate, mk_partial_rules), lthy)
- end
-
-
-end--- a/src/HOL/Tools/Function/fundef_datatype.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,178 +0,0 @@
-(* Title: HOL/Tools/Function/fundef_datatype.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions.
-A tactic to prove completeness of datatype patterns.
-*)
-
-signature FUNDEF_DATATYPE =
-sig
- val add_fun : FundefCommon.fundef_config ->
- (binding * typ option * mixfix) list -> (Attrib.binding * term) list ->
- bool -> local_theory -> Proof.context
- val add_fun_cmd : FundefCommon.fundef_config ->
- (binding * string option * mixfix) list -> (Attrib.binding * string) list ->
- bool -> local_theory -> Proof.context
-
- val setup : theory -> theory
-end
-
-structure FundefDatatype : FUNDEF_DATATYPE =
-struct
-
-open FundefLib
-open FundefCommon
-
-
-fun check_pats ctxt geq =
- let
- fun err str = error (cat_lines ["Malformed definition:",
- str ^ " not allowed in sequential mode.",
- Syntax.string_of_term ctxt geq])
- val thy = ProofContext.theory_of ctxt
-
- fun check_constr_pattern (Bound _) = ()
- | check_constr_pattern t =
- let
- val (hd, args) = strip_comb t
- in
- (((case Datatype.info_of_constr thy (dest_Const hd) of
- SOME _ => ()
- | NONE => err "Non-constructor pattern")
- handle TERM ("dest_Const", _) => err "Non-constructor patterns");
- map check_constr_pattern args;
- ())
- end
-
- val (fname, qs, gs, args, rhs) = split_def ctxt geq
-
- val _ = if not (null gs) then err "Conditional equations" else ()
- val _ = map check_constr_pattern args
-
- (* just count occurrences to check linearity *)
- val _ = if fold (fold_aterms (fn Bound _ => Integer.add 1 | _ => I)) args 0 > length qs
- then err "Nonlinear patterns" else ()
- in
- ()
- end
-
-val by_pat_completeness_auto =
- Proof.global_future_terminal_proof
- (Method.Basic Pat_Completeness.pat_completeness,
- SOME (Method.Source_i (Args.src (("HOL.auto", []), Position.none))))
-
-fun termination_by method int =
- Fundef.termination_proof NONE
- #> Proof.global_future_terminal_proof (Method.Basic method, NONE) int
-
-fun mk_catchall fixes arity_of =
- let
- fun mk_eqn ((fname, fT), _) =
- let
- val n = arity_of fname
- val (argTs, rT) = chop n (binder_types fT)
- |> apsnd (fn Ts => Ts ---> body_type fT)
-
- val qs = map Free (Name.invent_list [] "a" n ~~ argTs)
- in
- HOLogic.mk_eq(list_comb (Free (fname, fT), qs),
- Const ("HOL.undefined", rT))
- |> HOLogic.mk_Trueprop
- |> fold_rev Logic.all qs
- end
- in
- map mk_eqn fixes
- end
-
-fun add_catchall ctxt fixes spec =
- let val fqgars = map (split_def ctxt) spec
- val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
- |> AList.lookup (op =) #> the
- in
- spec @ mk_catchall fixes arity_of
- end
-
-fun warn_if_redundant ctxt origs tss =
- let
- fun msg t = "Ignoring redundant equation: " ^ quote (Syntax.string_of_term ctxt t)
-
- val (tss', _) = chop (length origs) tss
- fun check (t, []) = (warning (msg t); [])
- | check (t, s) = s
- in
- (map check (origs ~~ tss'); tss)
- end
-
-
-fun sequential_preproc (config as FundefConfig {sequential, ...}) ctxt fixes spec =
- if sequential then
- let
- val (bnds, eqss) = split_list spec
-
- val eqs = map the_single eqss
-
- val feqs = eqs
- |> tap (check_defs ctxt fixes) (* Standard checks *)
- |> tap (map (check_pats ctxt)) (* More checks for sequential mode *)
-
- val compleqs = add_catchall ctxt fixes feqs (* Completion *)
-
- val spliteqs = warn_if_redundant ctxt feqs
- (FundefSplit.split_all_equations ctxt compleqs)
-
- fun restore_spec thms =
- bnds ~~ Library.take (length bnds, Library.unflat spliteqs thms)
-
- val spliteqs' = flat (Library.take (length bnds, spliteqs))
- val fnames = map (fst o fst) fixes
- val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
-
- fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs)
- |> map (map snd)
-
-
- val bnds' = bnds @ replicate (length spliteqs - length bnds) Attrib.empty_binding
-
- (* using theorem names for case name currently disabled *)
- val case_names = map_index (fn (i, (_, es)) => mk_case_names i "" (length es))
- (bnds' ~~ spliteqs)
- |> flat
- in
- (flat spliteqs, restore_spec, sort, case_names)
- end
- else
- FundefCommon.empty_preproc check_defs config ctxt fixes spec
-
-val setup =
- Context.theory_map (FundefCommon.set_preproc sequential_preproc)
-
-
-val fun_config = FundefConfig { sequential=true, default="%x. undefined" (*FIXME dynamic scoping*),
- domintros=false, tailrec=false }
-
-fun gen_fun add config fixes statements int lthy =
- let val group = serial_string () in
- lthy
- |> LocalTheory.set_group group
- |> add fixes statements config
- |> by_pat_completeness_auto int
- |> LocalTheory.restore
- |> LocalTheory.set_group group
- |> termination_by (FundefCommon.get_termination_prover lthy) int
- end;
-
-val add_fun = gen_fun Fundef.add_fundef
-val add_fun_cmd = gen_fun Fundef.add_fundef_cmd
-
-
-
-local structure P = OuterParse and K = OuterKeyword in
-
-val _ =
- OuterSyntax.local_theory' "fun" "define general recursive functions (short version)" K.thy_decl
- (fundef_parser fun_config
- >> (fn ((config, fixes), statements) => add_fun_cmd config fixes statements));
-
-end
-
-end--- a/src/HOL/Tools/Function/fundef_lib.ML Tue Oct 27 12:59:57 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,179 +0,0 @@
-(* Title: HOL/Tools/Function/fundef_lib.ML
- Author: Alexander Krauss, TU Muenchen
-
-A package for general recursive function definitions.
-Some fairly general functions that should probably go somewhere else...
-*)
-
-structure FundefLib = struct
-
-fun map_option f NONE = NONE
- | map_option f (SOME x) = SOME (f x);
-
-fun fold_option f NONE y = y
- | fold_option f (SOME x) y = f x y;
-
-fun fold_map_option f NONE y = (NONE, y)
- | fold_map_option f (SOME x) y = apfst SOME (f x y);
-
-(* Ex: "The variable" ^ plural " is" "s are" vs *)
-fun plural sg pl [x] = sg
- | plural sg pl _ = pl
-
-(* lambda-abstracts over an arbitrarily nested tuple
- ==> hologic.ML? *)
-fun tupled_lambda vars t =
- case vars of
- (Free v) => lambda (Free v) t
- | (Var v) => lambda (Var v) t
- | (Const ("Pair", Type ("fun", [Ta, Type ("fun", [Tb, _])]))) $ us $ vs =>
- (HOLogic.split_const (Ta,Tb, fastype_of t)) $ (tupled_lambda us (tupled_lambda vs t))
- | _ => raise Match
-
-
-fun dest_all (Const ("all", _) $ Abs (a as (_,T,_))) =
- let
- val (n, body) = Term.dest_abs a
- in
- (Free (n, T), body)
- end
- | dest_all _ = raise Match
-
-
-(* Removes all quantifiers from a term, replacing bound variables by frees. *)
-fun dest_all_all (t as (Const ("all",_) $ _)) =
- let
- val (v,b) = dest_all t
- val (vs, b') = dest_all_all b
- in
- (v :: vs, b')
- end
- | dest_all_all t = ([],t)
-
-
-(* FIXME: similar to Variable.focus *)
-fun dest_all_all_ctx ctx (Const ("all", _) $ Abs (a as (n,T,b))) =
- let
- val [(n', _)] = Variable.variant_frees ctx [] [(n,T)]
- val (_, ctx') = ProofContext.add_fixes [(Binding.name n', SOME T, NoSyn)] ctx
-
- val (n'', body) = Term.dest_abs (n', T, b)
- val _ = (n' = n'') orelse error "dest_all_ctx"
- (* Note: We assume that n' does not occur in the body. Otherwise it would be fixed. *)
-
- val (ctx'', vs, bd) = dest_all_all_ctx ctx' body
- in
- (ctx'', (n', T) :: vs, bd)
- end
- | dest_all_all_ctx ctx t =
- (ctx, [], t)
-
-
-fun map3 _ [] [] [] = []
- | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
- | map3 _ _ _ _ = raise Library.UnequalLengths;
-
-fun map4 _ [] [] [] [] = []
- | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
- | map4 _ _ _ _ _ = raise Library.UnequalLengths;
-
-fun map6 _ [] [] [] [] [] [] = []
- | map6 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) = f x y z u v w :: map6 f xs ys zs us vs ws
- | map6 _ _ _ _ _ _ _ = raise Library.UnequalLengths;
-
-fun map7 _ [] [] [] [] [] [] [] = []
- | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
- | map7 _ _ _ _ _ _ _ _ = raise Library.UnequalLengths;
-
-
-
-(* forms all "unordered pairs": [1, 2, 3] ==> [(1, 1), (1, 2), (1, 3), (2, 2), (2, 3), (3, 3)] *)
-(* ==> library *)
-fun unordered_pairs [] = []
- | unordered_pairs (x::xs) = map (pair x) (x::xs) @ unordered_pairs xs
-
-
-(* Replaces Frees by name. Works with loose Bounds. *)
-fun replace_frees assoc =
- map_aterms (fn c as Free (n, _) => the_default c (AList.lookup (op =) assoc n)
- | t => t)
-
-
-fun rename_bound n (Q $ Abs(_, T, b)) = (Q $ Abs(n, T, b))
- | rename_bound n _ = raise Match
-
-fun mk_forall_rename (n, v) =
- rename_bound n o Logic.all v
-
-fun forall_intr_rename (n, cv) thm =
- let
- val allthm = forall_intr cv thm
- val (_ $ abs) = prop_of allthm
- in
- Thm.rename_boundvars abs (Abs (n, dummyT, Term.dummy_pattern dummyT)) allthm
- end
-
-
-(* Returns the frees in a term in canonical order, excluding the fixes from the context *)
-fun frees_in_term ctxt t =
- Term.add_frees t []
- |> filter_out (Variable.is_fixed ctxt o fst)
- |> rev
-
-
-datatype proof_attempt = Solved of thm | Stuck of thm | Fail
-
-fun try_proof cgoal tac =
- case SINGLE tac (Goal.init cgoal) of
- NONE => Fail
- | SOME st =>
- if Thm.no_prems st
- then Solved (Goal.finish (Syntax.init_pretty_global (Thm.theory_of_cterm cgoal)) st)
- else Stuck st
-
-
-fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) =
- if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
- | dest_binop_list _ t = [ t ]
-
-
-(* separate two parts in a +-expression:
- "a + b + c + d + e" --> "(a + b + d) + (c + e)"
-
- Here, + can be any binary operation that is AC.
-
- cn - The name of the binop-constructor (e.g. @{const_name Un})
- ac - the AC rewrite rules for cn
- is - the list of indices of the expressions that should become the first part
- (e.g. [0,1,3] in the above example)
-*)
-
-fun regroup_conv neu cn ac is ct =
- let
- val mk = HOLogic.mk_binop cn
- val t = term_of ct
- val xs = dest_binop_list cn t
- val js = subtract (op =) is (0 upto (length xs) - 1)
- val ty = fastype_of t
- val thy = theory_of_cterm ct
- in
- Goal.prove_internal []
- (cterm_of thy
- (Logic.mk_equals (t,
- if is = []
- then mk (Const (neu, ty), foldr1 mk (map (nth xs) js))
- else if js = []
- then mk (foldr1 mk (map (nth xs) is), Const (neu, ty))
- else mk (foldr1 mk (map (nth xs) is), foldr1 mk (map (nth xs) js)))))
- (K (rewrite_goals_tac ac
- THEN rtac Drule.reflexive_thm 1))
- end
-
-(* instance for unions *)
-fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Lattices.sup}
- (map (fn t => t RS eq_reflection) (@{thms Un_ac} @
- @{thms Un_empty_right} @
- @{thms Un_empty_left})) t
-
-
-end--- a/src/HOL/Tools/Function/induction_scheme.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/induction_scheme.ML Tue Oct 27 14:46:03 2009 +0000
@@ -13,10 +13,10 @@
end
-structure InductionScheme : INDUCTION_SCHEME =
+structure Induction_Scheme : INDUCTION_SCHEME =
struct
-open FundefLib
+open Function_Lib
type rec_call_info = int * (string * typ) list * term list * term list
--- a/src/HOL/Tools/Function/inductive_wrap.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/inductive_wrap.ML Tue Oct 27 14:46:03 2009 +0000
@@ -6,17 +6,17 @@
the introduction and elimination rules.
*)
-signature FUNDEF_INDUCTIVE_WRAP =
+signature FUNCTION_INDUCTIVE_WRAP =
sig
val inductive_def : term list
-> ((bstring * typ) * mixfix) * local_theory
-> thm list * (term * thm * thm * local_theory)
end
-structure FundefInductiveWrap: FUNDEF_INDUCTIVE_WRAP =
+structure Function_Inductive_Wrap: FUNCTION_INDUCTIVE_WRAP =
struct
-open FundefLib
+open Function_Lib
fun requantify ctxt lfix orig_def thm =
let--- a/src/HOL/Tools/Function/lexicographic_order.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/lexicographic_order.ML Tue Oct 27 14:46:03 2009 +0000
@@ -13,10 +13,10 @@
val setup: theory -> theory
end
-structure LexicographicOrder : LEXICOGRAPHIC_ORDER =
+structure Lexicographic_Order : LEXICOGRAPHIC_ORDER =
struct
-open FundefLib
+open Function_Lib
(** General stuff **)
@@ -58,7 +58,7 @@
fun dest_term (t : term) =
let
- val (vars, prop) = FundefLib.dest_all_all t
+ val (vars, prop) = Function_Lib.dest_all_all t
val (prems, concl) = Logic.strip_horn prop
val (lhs, rhs) = concl
|> HOLogic.dest_Trueprop
@@ -215,9 +215,9 @@
end
fun lexicographic_order_tac ctxt =
- TRY (FundefCommon.apply_termination_rule ctxt 1)
+ TRY (Function_Common.apply_termination_rule ctxt 1)
THEN lex_order_tac ctxt
- (auto_tac (clasimpset_of ctxt addsimps2 FundefCommon.Termination_Simps.get ctxt))
+ (auto_tac (clasimpset_of ctxt addsimps2 Function_Common.Termination_Simps.get ctxt))
val lexicographic_order = SIMPLE_METHOD o lexicographic_order_tac
@@ -225,7 +225,7 @@
Method.setup @{binding lexicographic_order}
(Method.sections clasimp_modifiers >> (K lexicographic_order))
"termination prover for lexicographic orderings"
- #> Context.theory_map (FundefCommon.set_termination_prover lexicographic_order)
+ #> Context.theory_map (Function_Common.set_termination_prover lexicographic_order)
end;
--- a/src/HOL/Tools/Function/mutual.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/mutual.ML Tue Oct 27 14:46:03 2009 +0000
@@ -5,29 +5,26 @@
Tools for mutual recursive definitions.
*)
-signature FUNDEF_MUTUAL =
+signature FUNCTION_MUTUAL =
sig
- val prepare_fundef_mutual : FundefCommon.fundef_config
+ val prepare_function_mutual : Function_Common.function_config
-> string (* defname *)
-> ((string * typ) * mixfix) list
-> term list
-> local_theory
-> ((thm (* goalstate *)
- * (thm -> FundefCommon.fundef_result) (* proof continuation *)
+ * (thm -> Function_Common.function_result) (* proof continuation *)
) * local_theory)
end
-structure FundefMutual: FUNDEF_MUTUAL =
+structure Function_Mutual: FUNCTION_MUTUAL =
struct
-open FundefLib
-open FundefCommon
-
-
-
+open Function_Lib
+open Function_Common
type qgar = string * (string * typ) list * term list * term list * term
@@ -268,7 +265,7 @@
fun mk_partial_rules_mutual lthy inner_cont (m as Mutual {parts, fqgars, ...}) proof =
let
val result = inner_cont proof
- val FundefResult {fs=[f], G, R, cases, psimps, trsimps, simple_pinducts=[simple_pinduct],
+ val FunctionResult {fs=[f], G, R, cases, psimps, trsimps, simple_pinducts=[simple_pinduct],
termination,domintros} = result
val (all_f_defs, fs) = map (fn MutualPart {f_defthm = SOME f_def, f = SOME f, cargTs, ...} =>
@@ -288,20 +285,20 @@
val mtermination = full_simplify rew_ss termination
val mdomintros = map_option (map (full_simplify rew_ss)) domintros
in
- FundefResult { fs=fs, G=G, R=R,
+ FunctionResult { fs=fs, G=G, R=R,
psimps=mpsimps, simple_pinducts=minducts,
cases=cases, termination=mtermination,
domintros=mdomintros,
trsimps=mtrsimps}
end
-fun prepare_fundef_mutual config defname fixes eqss lthy =
+fun prepare_function_mutual config defname fixes eqss lthy =
let
val mutual = analyze_eqs lthy defname (map fst fixes) (map Envir.beta_eta_contract eqss)
val Mutual {fsum_var=(n, T), qglrs, ...} = mutual
val ((fsum, goalstate, cont), lthy') =
- FundefCore.prepare_fundef config defname [((n, T), NoSyn)] qglrs lthy
+ Function_Core.prepare_function config defname [((n, T), NoSyn)] qglrs lthy
val (mutual', lthy'') = define_projections fixes mutual fsum lthy'
--- a/src/HOL/Tools/Function/pat_completeness.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/pat_completeness.ML Tue Oct 27 14:46:03 2009 +0000
@@ -17,8 +17,8 @@
structure Pat_Completeness : PAT_COMPLETENESS =
struct
-open FundefLib
-open FundefCommon
+open Function_Lib
+open Function_Common
fun mk_argvar i T = Free ("_av" ^ (string_of_int i), T)--- a/src/HOL/Tools/Function/pattern_split.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/pattern_split.ML Tue Oct 27 14:46:03 2009 +0000
@@ -8,7 +8,7 @@
*)
-signature FUNDEF_SPLIT =
+signature FUNCTION_SPLIT =
sig
val split_some_equations :
Proof.context -> (bool * term) list -> term list list
@@ -17,10 +17,10 @@
Proof.context -> term list -> term list list
end
-structure FundefSplit : FUNDEF_SPLIT =
+structure Function_Split : FUNCTION_SPLIT =
struct
-open FundefLib
+open Function_Lib
(* We use proof context for the variable management *)
(* FIXME: no __ *)--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Function/relation.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,36 @@
+(* Title: HOL/Tools/Function/relation.ML
+ Author: Alexander Krauss, TU Muenchen
+
+A package for general recursive function definitions.
+Method "relation" to commence a termination proof using a user-specified relation.
+*)
+
+signature FUNCTION_RELATION =
+sig
+ val relation_tac: Proof.context -> term -> int -> tactic
+ val setup: theory -> theory
+end
+
+structure Function_Relation : FUNCTION_RELATION =
+struct
+
+fun inst_thm ctxt rel st =
+ let
+ val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
+ val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
+ val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
+ val Rvar = cert (Var (the_single (Term.add_vars (prop_of st') [])))
+ in
+ Drule.cterm_instantiate [(Rvar, rel')] st'
+ end
+
+fun relation_tac ctxt rel i =
+ TRY (Function_Common.apply_termination_rule ctxt i)
+ THEN PRIMITIVE (inst_thm ctxt rel)
+
+val setup =
+ Method.setup @{binding relation}
+ (Args.term >> (fn rel => fn ctxt => SIMPLE_METHOD' (relation_tac ctxt rel)))
+ "proves termination using a user-specified wellfounded relation"
+
+end--- a/src/HOL/Tools/Function/scnp_reconstruct.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/scnp_reconstruct.ML Tue Oct 27 14:46:03 2009 +0000
@@ -38,8 +38,8 @@
structure ScnpReconstruct : SCNP_RECONSTRUCT =
struct
-val PROFILE = FundefCommon.PROFILE
-fun TRACE x = if ! FundefCommon.profile then tracing x else ()
+val PROFILE = Function_Common.PROFILE
+fun TRACE x = if ! Function_Common.profile then tracing x else ()
open ScnpSolve
@@ -64,7 +64,7 @@
reduction_pair : thm
}
-structure MultisetSetup = TheoryDataFun
+structure Multiset_Setup = TheoryDataFun
(
type T = multiset_setup option
val empty = NONE
@@ -73,10 +73,10 @@
fun merge _ (v1, v2) = if is_some v2 then v2 else v1
)
-val multiset_setup = MultisetSetup.put o SOME
+val multiset_setup = Multiset_Setup.put o SOME
fun undef x = error "undef"
-fun get_multiset_setup thy = MultisetSetup.get thy
+fun get_multiset_setup thy = Multiset_Setup.get thy
|> the_default (Multiset
{ msetT = undef, mk_mset=undef,
mset_regroup_conv=undef, mset_member_tac = undef,
@@ -287,7 +287,7 @@
|> cterm_of thy
in
PROFILE "Proof Reconstruction"
- (CONVERSION (Conv.arg_conv (Conv.arg_conv (FundefLib.regroup_union_conv sl))) 1
+ (CONVERSION (Conv.arg_conv (Conv.arg_conv (Function_Lib.regroup_union_conv sl))) 1
THEN (rtac @{thm reduction_pair_lemma} 1)
THEN (rtac @{thm rp_inv_image_rp} 1)
THEN (rtac (order_rpair ms_rp label) 1)
@@ -350,7 +350,7 @@
fun single_scnp_tac use_tags orders ctxt cont err_cont D = Termination.CALLS (fn (cs, i) =>
let
- val ms_configured = is_some (MultisetSetup.get (ProofContext.theory_of ctxt))
+ val ms_configured = is_some (Multiset_Setup.get (ProofContext.theory_of ctxt))
val orders' = if ms_configured then orders
else filter_out (curry op = MS) orders
val gp = gen_probl D cs
@@ -395,7 +395,7 @@
end
fun gen_sizechange_tac orders autom_tac ctxt err_cont =
- TRY (FundefCommon.apply_termination_rule ctxt 1)
+ TRY (Function_Common.apply_termination_rule ctxt 1)
THEN TRY (Termination.wf_union_tac ctxt)
THEN
(rtac @{thm wf_empty} 1
@@ -406,7 +406,7 @@
fun decomp_scnp orders ctxt =
let
- val extra_simps = FundefCommon.Termination_Simps.get ctxt
+ val extra_simps = Function_Common.Termination_Simps.get ctxt
val autom_tac = auto_tac (clasimpset_of ctxt addsimps2 extra_simps)
in
SIMPLE_METHOD--- a/src/HOL/Tools/Function/scnp_solve.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/scnp_solve.ML Tue Oct 27 14:46:03 2009 +0000
@@ -73,7 +73,7 @@
(* SAT solving *)
val solver = Unsynchronized.ref "auto";
fun sat_solver x =
- FundefCommon.PROFILE "sat_solving..." (SatSolver.invoke_solver (!solver)) x
+ Function_Common.PROFILE "sat_solving..." (SatSolver.invoke_solver (!solver)) x
(* "Virtual constructors" for various propositional variables *)
fun var_constrs (gp as GP (arities, gl)) =
--- a/src/HOL/Tools/Function/termination.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Function/termination.ML Tue Oct 27 14:46:03 2009 +0000
@@ -48,7 +48,7 @@
structure Termination : TERMINATION =
struct
-open FundefLib
+open Function_Lib
val term2_ord = prod_ord TermOrd.fast_term_ord TermOrd.fast_term_ord
structure Term2tab = Table(type key = term * term val ord = term2_ord);
@@ -145,7 +145,7 @@
fun mk_sum_skel rel =
let
- val cs = FundefLib.dest_binop_list @{const_name Lattices.sup} rel
+ val cs = Function_Lib.dest_binop_list @{const_name Lattices.sup} rel
fun collect_pats (Const (@{const_name Collect}, _) $ Abs (_, _, c)) =
let
val (Const ("op &", _) $ (Const ("op =", _) $ _ $ (Const ("Pair", _) $ r $ l)) $ Gam)
@@ -233,7 +233,7 @@
fun CALLS tac i st =
if Thm.no_prems st then all_tac st
else case Thm.term_of (Thm.cprem_of st i) of
- (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name Lattices.sup} rel, i) st
+ (_ $ (_ $ rel)) => tac (Function_Lib.dest_binop_list @{const_name Lattices.sup} rel, i) st
|_ => no_tac st
type ttac = (data -> int -> tactic) -> (data -> int -> tactic) -> data -> int -> tactic
@@ -251,7 +251,7 @@
local
fun dest_term (t : term) = (* FIXME, cf. Lexicographic order *)
let
- val (vars, prop) = FundefLib.dest_all_all t
+ val (vars, prop) = Function_Lib.dest_all_all t
val (prems, concl) = Logic.strip_horn prop
val (lhs, rhs) = concl
|> HOLogic.dest_Trueprop--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/HISTORY Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,155 @@
+Version 2010
+
+ * Moved into Isabelle/HOL "Main"
+ * Renamed "nitpick_const_def" to "nitpick_def", "nitpick_const_simp" to
+ "nitpick_simp", "nitpick_const_psimp" to "nitpick_psimp", and
+ "nitpick_ind_intro" to "nitpick_intro"
+ * Replaced "special_depth" and "skolemize_depth" options by "specialize"
+ and "skolemize"
+ * Fixed monotonicity check
+
+Version 1.2.2 (16 Oct 2009)
+
+ * Added and implemented "star_linear_preds" option
+ * Added and implemented "format" option
+ * Added and implemented "coalesce_type_vars" option
+ * Added and implemented "max_genuine" option
+ * Fixed soundness issues related to "set", "distinct", "image", "Sigma",
+ "-1::nat", subset, constructors, sort axioms, and partially applied
+ interpreted constants
+ * Fixed error in "show_consts" for boxed specialized constants
+ * Fixed errors in Kodkod encoding of "The", "Eps", and "ind"
+ * Fixed display of Skolem constants
+ * Fixed error in "check_potential" and "check_genuine"
+ * Added boxing support for higher-order constructor parameters
+ * Changed notation used for coinductive datatypes
+ * Optimized Kodkod encoding of "If", "card", and "setsum"
+ * Improved the monotonicity check
+
+Version 1.2.1 (25 Sep 2009)
+
+ * Added explicit support for coinductive datatypes
+ * Added and implemented "box" option
+ * Added and implemented "fast_descrs" option
+ * Added and implemented "uncurry" option
+ * Renamed and generalized "sync_cards" and "inductive_mood" to "mono" and "wf"
+ * Fixed soundness issue related to nullary constructors
+ * Fixed soundness issue related to higher-order quantifiers
+ * Fixed soundness issue related to the "destroy_constrs" optimization
+ * Fixed soundness issues related to the "special_depth" optimization
+ * Added support for PicoSAT and incorporated it with the Nitpick package
+ * Added automatic detection of installed SAT solvers based on naming
+ convention
+ * Optimized handling of quantifiers by moving them inward whenever possible
+ * Optimized and improved precision of "wf" and "wfrec"
+ * Improved handling of definitions made in locales
+ * Fixed checked scope count in message shown upon interruption and timeout
+ * Added minimalistic Nitpick-like tool called Minipick
+
+Version 1.2.0 (27 Jul 2009)
+
+ * Optimized Kodkod encoding of datatypes and records
+ * Optimized coinductive definitions
+ * Fixed soundness issues related to pairs of functions
+ * Fixed soundness issue in the peephole optimizer
+ * Improved precision of non-well-founded predicates occurring positively in
+ the formula to falsify
+ * Added and implemented "destroy_constrs" option
+ * Changed semantics of "inductive_mood" option to ensure soundness
+ * Fixed semantics of "lockstep" option (broken in 1.1.1) and renamed it
+ "sync_cards"
+ * Improved precision of "trancl" and "rtrancl"
+ * Optimized Kodkod encoding of "tranclp" and "rtranclp"
+ * Made detection of inconsistent scope specifications more robust
+ * Fixed a few Kodkod generation bugs that resulted in exceptions
+
+Version 1.1.1 (24 Jun 2009)
+
+ * Added "show_all" option
+ * Fixed soundness issues related to type classes
+ * Improved precision of some set constructs
+ * Fiddled with the automatic monotonicity check
+ * Fixed performance issues related to scope enumeration
+ * Fixed a few Kodkod generation bugs that resulted in exceptions or stack
+ overflows
+
+Version 1.1.0 (16 Jun 2009)
+
+ * Redesigned handling of datatypes to provide an interface baded on "card" and
+ "max", obsoleting "mult"
+ * Redesigned handling of typedefs, "rat", and "real"
+ * Made "lockstep" option a three-state option and added an automatic
+ monotonicity check
+ * Made "batch_size" a (n + 1)-state option whose default depends on whether
+ "debug" is enabled
+ * Made "debug" automatically enable "verbose"
+ * Added "destroy_equals" option
+ * Added "no_assms" option
+ * Fixed bug in computation of ground type
+ * Fixed performance issue related to datatype acyclicity constraint generation
+ * Fixed performance issue related to axiom selection
+ * Improved precision of some well-founded inductive predicates
+ * Added more checks to guard against very large cardinalities
+ * Improved hit rate of potential counterexamples
+ * Fixed several soundness issues
+ * Optimized the Kodkod encoding to benefit more from symmetry breaking
+ * Optimized relational composition, cartesian product, and converse
+ * Added support for HaifaSat
+
+Version 1.0.3 (17 Mar 2009)
+
+ * Added "HOL-Nominal-Nitpick" as a target in addition to "HOL-Nitpick"
+ * Added "overlord" option to assist debugging
+ * Increased default value of "special_depth" option
+ * Fixed a bug that effectively disabled the "nitpick_const_def" attribute
+ * Ensured that no scopes are skipped when multithreading is enabled
+ * Fixed soundness issue in handling of "The", "Eps", and partial functions
+ defined using Isabelle's function package
+ * Fixed soundness issue in handling of non-definitional axioms
+ * Fixed soundness issue in handling of "Abs_" and "Rep_" functions for "unit",
+ "nat", "int", and "*"
+ * Fixed a few Kodkod generation bugs that resulted in exceptions
+ * Optimized "div", "mod", and "dvd" on "nat" and "int"
+
+Version 1.0.2 (12 Mar 2009)
+
+ * Added support for non-definitional axioms
+ * Improved Isar integration
+ * Added support for multiplicities of 0
+ * Added "max_threads" option and support for multithreaded Kodkodi
+ * Added "blocking" option to control whether Nitpick should be run
+ synchronously or asynchronously
+ * Merged "auto_timeout" and "wellfounded_timeout" into "tac_timeout"
+ * Added "auto" option to run Nitpick automatically (like Auto Quickcheck)
+ * Introduced "auto_timeout" to specify Auto Nitpick's time limit
+ * Renamed the possible values for the "expect" option
+ * Renamed the "peephole" option to "peephole_optim"
+ * Added negative versions of all Boolean options and made "= true" optional
+ * Altered order of automatic SAT solver selection
+
+Version 1.0.1 (6 Mar 2009)
+
+ * Eliminated the need to import "Nitpick" to use "nitpick"
+ * Added "debug" option
+ * Replaced "specialize_funs" with the more general "special_depth" option
+ * Renamed "watch" option to "eval"
+ * Improved parsing of "card", "mult", and "iter" options
+ * Fixed a soundness bug in the "specialize_funs" optimization
+ * Increased the scope of the "specialize_funs" optimization
+ * Fixed a soundness bug in the treatment of "<" and "<=" on type "int"
+ * Fixed a soundness bug in the "subterm property" optimization for types of
+ cardinality 1
+ * Improved the axiom selection for overloaded constants, which led to an
+ infinite loop for "Nominal.perm"
+ * Added support for multiple instantiations of non-well-founded inductive
+ predicates, which previously raised an exception
+ * Fixed a Kodkod generation bug that resulted in an exception
+ * Altered order of scope enumeration and automatic SAT solver selection
+ * Optimized "Eps", "nat_case", and "list_case"
+ * Improved output formatting
+ * Added checks to prevent infinite loops in axiom selector and constant
+ unfolding
+
+Version 1.0.0 (27 Feb 2009)
+
+ * First release
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/kodkod.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1087 @@
+(* Title: HOL/Nitpick/Tools/kodkod.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+ML interface on top of Kodkod.
+*)
+
+signature KODKOD =
+sig
+ type n_ary_index = int * int
+ type setting = string * string
+
+ datatype tuple =
+ Tuple of int list |
+ TupleIndex of n_ary_index |
+ TupleReg of n_ary_index
+
+ datatype tuple_set =
+ TupleUnion of tuple_set * tuple_set |
+ TupleDifference of tuple_set * tuple_set |
+ TupleIntersect of tuple_set * tuple_set |
+ TupleProduct of tuple_set * tuple_set |
+ TupleProject of tuple_set * int |
+ TupleSet of tuple list |
+ TupleRange of tuple * tuple |
+ TupleArea of tuple * tuple |
+ TupleAtomSeq of int * int |
+ TupleSetReg of n_ary_index
+
+ datatype tuple_assign =
+ AssignTuple of n_ary_index * tuple |
+ AssignTupleSet of n_ary_index * tuple_set
+
+ type bound = (n_ary_index * string) list * tuple_set list
+ type int_bound = int option * tuple_set list
+
+ datatype formula =
+ All of decl list * formula |
+ Exist of decl list * formula |
+ FormulaLet of expr_assign list * formula |
+ FormulaIf of formula * formula * formula |
+ Or of formula * formula |
+ Iff of formula * formula |
+ Implies of formula * formula |
+ And of formula * formula |
+ Not of formula |
+ Acyclic of n_ary_index |
+ Function of n_ary_index * rel_expr * rel_expr |
+ Functional of n_ary_index * rel_expr * rel_expr |
+ TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
+ Subset of rel_expr * rel_expr |
+ RelEq of rel_expr * rel_expr |
+ IntEq of int_expr * int_expr |
+ LT of int_expr * int_expr |
+ LE of int_expr * int_expr |
+ No of rel_expr |
+ Lone of rel_expr |
+ One of rel_expr |
+ Some of rel_expr |
+ False |
+ True |
+ FormulaReg of int
+ and rel_expr =
+ RelLet of expr_assign list * rel_expr |
+ RelIf of formula * rel_expr * rel_expr |
+ Union of rel_expr * rel_expr |
+ Difference of rel_expr * rel_expr |
+ Override of rel_expr * rel_expr |
+ Intersect of rel_expr * rel_expr |
+ Product of rel_expr * rel_expr |
+ IfNo of rel_expr * rel_expr |
+ Project of rel_expr * int_expr list |
+ Join of rel_expr * rel_expr |
+ Closure of rel_expr |
+ ReflexiveClosure of rel_expr |
+ Transpose of rel_expr |
+ Comprehension of decl list * formula |
+ Bits of int_expr |
+ Int of int_expr |
+ Iden |
+ Ints |
+ None |
+ Univ |
+ Atom of int |
+ AtomSeq of int * int |
+ Rel of n_ary_index |
+ Var of n_ary_index |
+ RelReg of n_ary_index
+ and int_expr =
+ Sum of decl list * int_expr |
+ IntLet of expr_assign list * int_expr |
+ IntIf of formula * int_expr * int_expr |
+ SHL of int_expr * int_expr |
+ SHA of int_expr * int_expr |
+ SHR of int_expr * int_expr |
+ Add of int_expr * int_expr |
+ Sub of int_expr * int_expr |
+ Mult of int_expr * int_expr |
+ Div of int_expr * int_expr |
+ Mod of int_expr * int_expr |
+ Cardinality of rel_expr |
+ SetSum of rel_expr |
+ BitOr of int_expr * int_expr |
+ BitXor of int_expr * int_expr |
+ BitAnd of int_expr * int_expr |
+ BitNot of int_expr |
+ Neg of int_expr |
+ Absolute of int_expr |
+ Signum of int_expr |
+ Num of int |
+ IntReg of int
+ and decl =
+ DeclNo of n_ary_index * rel_expr |
+ DeclLone of n_ary_index * rel_expr |
+ DeclOne of n_ary_index * rel_expr |
+ DeclSome of n_ary_index * rel_expr |
+ DeclSet of n_ary_index * rel_expr
+ and expr_assign =
+ AssignFormulaReg of int * formula |
+ AssignRelReg of n_ary_index * rel_expr |
+ AssignIntReg of int * int_expr
+
+ type 'a fold_expr_funcs = {
+ formula_func: formula -> 'a -> 'a,
+ rel_expr_func: rel_expr -> 'a -> 'a,
+ int_expr_func: int_expr -> 'a -> 'a
+ }
+
+ val fold_formula : 'a fold_expr_funcs -> formula -> 'a -> 'a
+ val fold_rel_expr : 'a fold_expr_funcs -> rel_expr -> 'a -> 'a
+ val fold_int_expr : 'a fold_expr_funcs -> int_expr -> 'a -> 'a
+ val fold_decl : 'a fold_expr_funcs -> decl -> 'a -> 'a
+ val fold_expr_assign : 'a fold_expr_funcs -> expr_assign -> 'a -> 'a
+
+ type 'a fold_tuple_funcs = {
+ tuple_func: tuple -> 'a -> 'a,
+ tuple_set_func: tuple_set -> 'a -> 'a
+ }
+
+ val fold_tuple : 'a fold_tuple_funcs -> tuple -> 'a -> 'a
+ val fold_tuple_set : 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a
+ val fold_tuple_assign : 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a
+ val fold_bound :
+ 'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a
+ val fold_int_bound : 'a fold_tuple_funcs -> int_bound -> 'a -> 'a
+
+ type problem = {
+ comment: string,
+ settings: setting list,
+ univ_card: int,
+ tuple_assigns: tuple_assign list,
+ bounds: bound list,
+ int_bounds: int_bound list,
+ expr_assigns: expr_assign list,
+ formula: formula}
+
+ type raw_bound = n_ary_index * int list list
+
+ datatype outcome =
+ Normal of (int * raw_bound list) list * int list |
+ TimedOut of int list |
+ Interrupted of int list option |
+ Error of string * int list
+
+ exception SYNTAX of string * string
+
+ val max_arity : int -> int
+ val arity_of_rel_expr : rel_expr -> int
+ val problems_equivalent : problem -> problem -> bool
+ val solve_any_problem :
+ bool -> Time.time option -> int -> int -> problem list -> outcome
+end;
+
+structure Kodkod : KODKOD =
+struct
+
+type n_ary_index = int * int
+
+type setting = string * string
+
+datatype tuple =
+ Tuple of int list |
+ TupleIndex of n_ary_index |
+ TupleReg of n_ary_index
+
+datatype tuple_set =
+ TupleUnion of tuple_set * tuple_set |
+ TupleDifference of tuple_set * tuple_set |
+ TupleIntersect of tuple_set * tuple_set |
+ TupleProduct of tuple_set * tuple_set |
+ TupleProject of tuple_set * int |
+ TupleSet of tuple list |
+ TupleRange of tuple * tuple |
+ TupleArea of tuple * tuple |
+ TupleAtomSeq of int * int |
+ TupleSetReg of n_ary_index
+
+datatype tuple_assign =
+ AssignTuple of n_ary_index * tuple |
+ AssignTupleSet of n_ary_index * tuple_set
+
+type bound = (n_ary_index * string) list * tuple_set list
+type int_bound = int option * tuple_set list
+
+datatype formula =
+ All of decl list * formula |
+ Exist of decl list * formula |
+ FormulaLet of expr_assign list * formula |
+ FormulaIf of formula * formula * formula |
+ Or of formula * formula |
+ Iff of formula * formula |
+ Implies of formula * formula |
+ And of formula * formula |
+ Not of formula |
+ Acyclic of n_ary_index |
+ Function of n_ary_index * rel_expr * rel_expr |
+ Functional of n_ary_index * rel_expr * rel_expr |
+ TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
+ Subset of rel_expr * rel_expr |
+ RelEq of rel_expr * rel_expr |
+ IntEq of int_expr * int_expr |
+ LT of int_expr * int_expr |
+ LE of int_expr * int_expr |
+ No of rel_expr |
+ Lone of rel_expr |
+ One of rel_expr |
+ Some of rel_expr |
+ False |
+ True |
+ FormulaReg of int
+and rel_expr =
+ RelLet of expr_assign list * rel_expr |
+ RelIf of formula * rel_expr * rel_expr |
+ Union of rel_expr * rel_expr |
+ Difference of rel_expr * rel_expr |
+ Override of rel_expr * rel_expr |
+ Intersect of rel_expr * rel_expr |
+ Product of rel_expr * rel_expr |
+ IfNo of rel_expr * rel_expr |
+ Project of rel_expr * int_expr list |
+ Join of rel_expr * rel_expr |
+ Closure of rel_expr |
+ ReflexiveClosure of rel_expr |
+ Transpose of rel_expr |
+ Comprehension of decl list * formula |
+ Bits of int_expr |
+ Int of int_expr |
+ Iden |
+ Ints |
+ None |
+ Univ |
+ Atom of int |
+ AtomSeq of int * int |
+ Rel of n_ary_index |
+ Var of n_ary_index |
+ RelReg of n_ary_index
+and int_expr =
+ Sum of decl list * int_expr |
+ IntLet of expr_assign list * int_expr |
+ IntIf of formula * int_expr * int_expr |
+ SHL of int_expr * int_expr |
+ SHA of int_expr * int_expr |
+ SHR of int_expr * int_expr |
+ Add of int_expr * int_expr |
+ Sub of int_expr * int_expr |
+ Mult of int_expr * int_expr |
+ Div of int_expr * int_expr |
+ Mod of int_expr * int_expr |
+ Cardinality of rel_expr |
+ SetSum of rel_expr |
+ BitOr of int_expr * int_expr |
+ BitXor of int_expr * int_expr |
+ BitAnd of int_expr * int_expr |
+ BitNot of int_expr |
+ Neg of int_expr |
+ Absolute of int_expr |
+ Signum of int_expr |
+ Num of int |
+ IntReg of int
+and decl =
+ DeclNo of n_ary_index * rel_expr |
+ DeclLone of n_ary_index * rel_expr |
+ DeclOne of n_ary_index * rel_expr |
+ DeclSome of n_ary_index * rel_expr |
+ DeclSet of n_ary_index * rel_expr
+and expr_assign =
+ AssignFormulaReg of int * formula |
+ AssignRelReg of n_ary_index * rel_expr |
+ AssignIntReg of int * int_expr
+
+type problem = {
+ comment: string,
+ settings: setting list,
+ univ_card: int,
+ tuple_assigns: tuple_assign list,
+ bounds: bound list,
+ int_bounds: int_bound list,
+ expr_assigns: expr_assign list,
+ formula: formula}
+
+type raw_bound = n_ary_index * int list list
+
+datatype outcome =
+ Normal of (int * raw_bound list) list * int list |
+ TimedOut of int list |
+ Interrupted of int list option |
+ Error of string * int list
+
+exception SYNTAX of string * string
+
+type 'a fold_expr_funcs = {
+ formula_func: formula -> 'a -> 'a,
+ rel_expr_func: rel_expr -> 'a -> 'a,
+ int_expr_func: int_expr -> 'a -> 'a
+}
+
+(* 'a fold_expr_funcs -> formula -> 'a -> 'a *)
+fun fold_formula (F : 'a fold_expr_funcs) formula =
+ case formula of
+ All (ds, f) => fold (fold_decl F) ds #> fold_formula F f
+ | Exist (ds, f) => fold (fold_decl F) ds #> fold_formula F f
+ | FormulaLet (bs, f) => fold (fold_expr_assign F) bs #> fold_formula F f
+ | FormulaIf (f, f1, f2) =>
+ fold_formula F f #> fold_formula F f1 #> fold_formula F f2
+ | Or (f1, f2) => fold_formula F f1 #> fold_formula F f2
+ | Iff (f1, f2) => fold_formula F f1 #> fold_formula F f2
+ | Implies (f1, f2) => fold_formula F f1 #> fold_formula F f2
+ | And (f1, f2) => fold_formula F f1 #> fold_formula F f2
+ | Not f => fold_formula F f
+ | Acyclic x => fold_rel_expr F (Rel x)
+ | Function (x, r1, r2) =>
+ fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Functional (x, r1, r2) =>
+ fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
+ | TotalOrdering (x1, x2, x3, x4) =>
+ fold_rel_expr F (Rel x1) #> fold_rel_expr F (Rel x2)
+ #> fold_rel_expr F (Rel x3) #> fold_rel_expr F (Rel x4)
+ | Subset (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | RelEq (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | IntEq (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | LT (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | LE (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | No r => fold_rel_expr F r
+ | Lone r => fold_rel_expr F r
+ | One r => fold_rel_expr F r
+ | Some r => fold_rel_expr F r
+ | False => #formula_func F formula
+ | True => #formula_func F formula
+ | FormulaReg _ => #formula_func F formula
+(* 'a fold_expr_funcs -> rel_expr -> 'a -> 'a *)
+and fold_rel_expr F rel_expr =
+ case rel_expr of
+ RelLet (bs, r) => fold (fold_expr_assign F) bs #> fold_rel_expr F r
+ | RelIf (f, r1, r2) =>
+ fold_formula F f #> fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Union (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Difference (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Override (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Intersect (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Product (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | IfNo (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Project (r1, is) => fold_rel_expr F r1 #> fold (fold_int_expr F) is
+ | Join (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
+ | Closure r => fold_rel_expr F r
+ | ReflexiveClosure r => fold_rel_expr F r
+ | Transpose r => fold_rel_expr F r
+ | Comprehension (ds, f) => fold (fold_decl F) ds #> fold_formula F f
+ | Bits i => fold_int_expr F i
+ | Int i => fold_int_expr F i
+ | Iden => #rel_expr_func F rel_expr
+ | Ints => #rel_expr_func F rel_expr
+ | None => #rel_expr_func F rel_expr
+ | Univ => #rel_expr_func F rel_expr
+ | Atom _ => #rel_expr_func F rel_expr
+ | AtomSeq _ => #rel_expr_func F rel_expr
+ | Rel _ => #rel_expr_func F rel_expr
+ | Var _ => #rel_expr_func F rel_expr
+ | RelReg _ => #rel_expr_func F rel_expr
+(* 'a fold_expr_funcs -> int_expr -> 'a -> 'a *)
+and fold_int_expr F int_expr =
+ case int_expr of
+ Sum (ds, i) => fold (fold_decl F) ds #> fold_int_expr F i
+ | IntLet (bs, i) => fold (fold_expr_assign F) bs #> fold_int_expr F i
+ | IntIf (f, i1, i2) =>
+ fold_formula F f #> fold_int_expr F i1 #> fold_int_expr F i2
+ | SHL (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | SHA (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | SHR (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Add (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Sub (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Mult (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Div (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Mod (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | Cardinality r => fold_rel_expr F r
+ | SetSum r => fold_rel_expr F r
+ | BitOr (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | BitXor (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | BitAnd (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
+ | BitNot i => fold_int_expr F i
+ | Neg i => fold_int_expr F i
+ | Absolute i => fold_int_expr F i
+ | Signum i => fold_int_expr F i
+ | Num _ => #int_expr_func F int_expr
+ | IntReg _ => #int_expr_func F int_expr
+(* 'a fold_expr_funcs -> decl -> 'a -> 'a *)
+and fold_decl F decl =
+ case decl of
+ DeclNo (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
+ | DeclLone (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
+ | DeclOne (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
+ | DeclSome (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
+ | DeclSet (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
+(* 'a fold_expr_funcs -> expr_assign -> 'a -> 'a *)
+and fold_expr_assign F assign =
+ case assign of
+ AssignFormulaReg (x, f) => fold_formula F (FormulaReg x) #> fold_formula F f
+ | AssignRelReg (x, r) => fold_rel_expr F (RelReg x) #> fold_rel_expr F r
+ | AssignIntReg (x, i) => fold_int_expr F (IntReg x) #> fold_int_expr F i
+
+type 'a fold_tuple_funcs = {
+ tuple_func: tuple -> 'a -> 'a,
+ tuple_set_func: tuple_set -> 'a -> 'a
+}
+
+(* 'a fold_tuple_funcs -> tuple -> 'a -> 'a *)
+fun fold_tuple (F : 'a fold_tuple_funcs) = #tuple_func F
+(* 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a *)
+fun fold_tuple_set F tuple_set =
+ case tuple_set of
+ TupleUnion (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
+ | TupleDifference (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
+ | TupleIntersect (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
+ | TupleProduct (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
+ | TupleProject (ts, _) => fold_tuple_set F ts
+ | TupleSet ts => fold (fold_tuple F) ts
+ | TupleRange (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
+ | TupleArea (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
+ | TupleAtomSeq _ => #tuple_set_func F tuple_set
+ | TupleSetReg _ => #tuple_set_func F tuple_set
+(* 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a *)
+fun fold_tuple_assign F assign =
+ case assign of
+ AssignTuple (x, t) => fold_tuple F (TupleReg x) #> fold_tuple F t
+ | AssignTupleSet (x, ts) =>
+ fold_tuple_set F (TupleSetReg x) #> fold_tuple_set F ts
+(* 'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a *)
+fun fold_bound expr_F tuple_F (zs, tss) =
+ fold (fold_rel_expr expr_F) (map (Rel o fst) zs)
+ #> fold (fold_tuple_set tuple_F) tss
+(* 'a fold_tuple_funcs -> int_bound -> 'a -> 'a *)
+fun fold_int_bound F (_, tss) = fold (fold_tuple_set F) tss
+
+(* int -> int *)
+fun max_arity univ_card = floor (Math.ln 2147483647.0
+ / Math.ln (Real.fromInt univ_card))
+(* rel_expr -> int *)
+fun arity_of_rel_expr (RelLet (_, r)) = arity_of_rel_expr r
+ | arity_of_rel_expr (RelIf (_, r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Union (r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Difference (r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Override (r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Intersect (r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Product (r1, r2)) = sum_arities_of_rel_exprs r1 r2
+ | arity_of_rel_expr (IfNo (r1, _)) = arity_of_rel_expr r1
+ | arity_of_rel_expr (Project (r, is)) = length is
+ | arity_of_rel_expr (Join (r1, r2)) = sum_arities_of_rel_exprs r1 r2 - 2
+ | arity_of_rel_expr (Closure _) = 2
+ | arity_of_rel_expr (ReflexiveClosure _) = 2
+ | arity_of_rel_expr (Transpose _) = 2
+ | arity_of_rel_expr (Comprehension (ds, _)) =
+ fold (curry op + o arity_of_decl) ds 0
+ | arity_of_rel_expr (Bits _) = 1
+ | arity_of_rel_expr (Int _) = 1
+ | arity_of_rel_expr Iden = 2
+ | arity_of_rel_expr Ints = 1
+ | arity_of_rel_expr None = 1
+ | arity_of_rel_expr Univ = 1
+ | arity_of_rel_expr (Atom _) = 1
+ | arity_of_rel_expr (AtomSeq _) = 1
+ | arity_of_rel_expr (Rel (n, _)) = n
+ | arity_of_rel_expr (Var (n, _)) = n
+ | arity_of_rel_expr (RelReg (n, _)) = n
+(* rel_expr -> rel_expr -> int *)
+and sum_arities_of_rel_exprs r1 r2 = arity_of_rel_expr r1 + arity_of_rel_expr r2
+(* decl -> int *)
+and arity_of_decl (DeclNo ((n, _), _)) = n
+ | arity_of_decl (DeclLone ((n, _), _)) = n
+ | arity_of_decl (DeclOne ((n, _), _)) = n
+ | arity_of_decl (DeclSome ((n, _), _)) = n
+ | arity_of_decl (DeclSet ((n, _), _)) = n
+
+(* string -> bool *)
+val is_relevant_setting = not o member (op =) ["solver", "delay"]
+
+(* problem -> problem -> bool *)
+fun problems_equivalent (p1 : problem) (p2 : problem) =
+ #univ_card p1 = #univ_card p2
+ andalso #formula p1 = #formula p2
+ andalso #bounds p1 = #bounds p2
+ andalso #expr_assigns p1 = #expr_assigns p2
+ andalso #tuple_assigns p1 = #tuple_assigns p2
+ andalso #int_bounds p1 = #int_bounds p2
+ andalso filter (is_relevant_setting o fst) (#settings p1)
+ = filter (is_relevant_setting o fst) (#settings p2)
+
+(* int -> string *)
+fun base_name j = if j < 0 then Int.toString (~j - 1) ^ "'" else Int.toString j
+
+(* n_ary_index -> string -> string -> string -> string *)
+fun n_ary_name (1, j) prefix _ _ = prefix ^ base_name j
+ | n_ary_name (2, j) _ prefix _ = prefix ^ base_name j
+ | n_ary_name (n, j) _ _ prefix = prefix ^ Int.toString n ^ "_" ^ base_name j
+
+(* int -> string *)
+fun atom_name j = "A" ^ base_name j
+fun atom_seq_name (k, 0) = "u" ^ base_name k
+ | atom_seq_name (k, j0) = "u" ^ base_name k ^ "@" ^ base_name j0
+fun formula_reg_name j = "$f" ^ base_name j
+fun rel_reg_name j = "$e" ^ base_name j
+fun int_reg_name j = "$i" ^ base_name j
+
+(* n_ary_index -> string *)
+fun tuple_name x = n_ary_name x "A" "P" "T"
+fun rel_name x = n_ary_name x "s" "r" "m"
+fun var_name x = n_ary_name x "S" "R" "M"
+fun tuple_reg_name x = n_ary_name x "$A" "$P" "$T"
+fun tuple_set_reg_name x = n_ary_name x "$a" "$p" "$t"
+
+(* string -> string *)
+fun inline_comment "" = ""
+ | inline_comment comment =
+ " /* " ^ translate_string (fn "\n" => " " | "*" => "* " | s => s) comment ^
+ " */"
+fun block_comment "" = ""
+ | block_comment comment = prefix_lines "// " comment ^ "\n"
+
+(* (n_ary_index * string) -> string *)
+fun commented_rel_name (x, s) = rel_name x ^ inline_comment s
+
+(* tuple -> string *)
+fun string_for_tuple (Tuple js) = "[" ^ commas (map atom_name js) ^ "]"
+ | string_for_tuple (TupleIndex x) = tuple_name x
+ | string_for_tuple (TupleReg x) = tuple_reg_name x
+
+val no_prec = 100
+val prec_TupleUnion = 1
+val prec_TupleIntersect = 2
+val prec_TupleProduct = 3
+val prec_TupleProject = 4
+
+(* tuple_set -> int *)
+fun precedence_ts (TupleUnion _) = prec_TupleUnion
+ | precedence_ts (TupleDifference _) = prec_TupleUnion
+ | precedence_ts (TupleIntersect _) = prec_TupleIntersect
+ | precedence_ts (TupleProduct _) = prec_TupleProduct
+ | precedence_ts (TupleProject _) = prec_TupleProject
+ | precedence_ts _ = no_prec
+
+(* tuple_set -> string *)
+fun string_for_tuple_set tuple_set =
+ let
+ (* tuple_set -> int -> string *)
+ fun sub tuple_set outer_prec =
+ let
+ val prec = precedence_ts tuple_set
+ val need_parens = (prec < outer_prec)
+ in
+ (if need_parens then "(" else "") ^
+ (case tuple_set of
+ TupleUnion (ts1, ts2) => sub ts1 prec ^ " + " ^ sub ts2 (prec + 1)
+ | TupleDifference (ts1, ts2) =>
+ sub ts1 prec ^ " - " ^ sub ts1 (prec + 1)
+ | TupleIntersect (ts1, ts2) => sub ts1 prec ^ " & " ^ sub ts1 prec
+ | TupleProduct (ts1, ts2) => sub ts1 prec ^ "->" ^ sub ts2 prec
+ | TupleProject (ts, c) => sub ts prec ^ "[" ^ Int.toString c ^ "]"
+ | TupleSet ts => "{" ^ commas (map string_for_tuple ts) ^ "}"
+ | TupleRange (t1, t2) =>
+ "{" ^ string_for_tuple t1 ^
+ (if t1 = t2 then "" else " .. " ^ string_for_tuple t2) ^ "}"
+ | TupleArea (t1, t2) =>
+ "{" ^ string_for_tuple t1 ^ " # " ^ string_for_tuple t2 ^ "}"
+ | TupleAtomSeq x => atom_seq_name x
+ | TupleSetReg x => tuple_set_reg_name x) ^
+ (if need_parens then ")" else "")
+ end
+ in sub tuple_set 0 end
+
+(* tuple_assign -> string *)
+fun string_for_tuple_assign (AssignTuple (x, t)) =
+ tuple_reg_name x ^ " := " ^ string_for_tuple t ^ "\n"
+ | string_for_tuple_assign (AssignTupleSet (x, ts)) =
+ tuple_set_reg_name x ^ " := " ^ string_for_tuple_set ts ^ "\n"
+
+(* bound -> string *)
+fun string_for_bound (zs, tss) =
+ "bounds " ^ commas (map commented_rel_name zs) ^ ": " ^
+ (if length tss = 1 then "" else "[") ^ commas (map string_for_tuple_set tss) ^
+ (if length tss = 1 then "" else "]") ^ "\n"
+
+(* int_bound -> string *)
+fun int_string_for_bound (opt_n, tss) =
+ (case opt_n of
+ SOME n => Int.toString n ^ ": "
+ | NONE => "") ^ "[" ^ commas (map string_for_tuple_set tss) ^ "]"
+
+val prec_All = 1
+val prec_Or = 2
+val prec_Iff = 3
+val prec_Implies = 4
+val prec_And = 5
+val prec_Not = 6
+val prec_Eq = 7
+val prec_Some = 8
+val prec_SHL = 9
+val prec_Add = 10
+val prec_Mult = 11
+val prec_Override = 12
+val prec_Intersect = 13
+val prec_Product = 14
+val prec_IfNo = 15
+val prec_Project = 17
+val prec_Join = 18
+val prec_BitNot = 19
+
+(* formula -> int *)
+fun precedence_f (All _) = prec_All
+ | precedence_f (Exist _) = prec_All
+ | precedence_f (FormulaLet _) = prec_All
+ | precedence_f (FormulaIf _) = prec_All
+ | precedence_f (Or _) = prec_Or
+ | precedence_f (Iff _) = prec_Iff
+ | precedence_f (Implies _) = prec_Implies
+ | precedence_f (And _) = prec_And
+ | precedence_f (Not _) = prec_Not
+ | precedence_f (Acyclic _) = no_prec
+ | precedence_f (Function _) = no_prec
+ | precedence_f (Functional _) = no_prec
+ | precedence_f (TotalOrdering _) = no_prec
+ | precedence_f (Subset _) = prec_Eq
+ | precedence_f (RelEq _) = prec_Eq
+ | precedence_f (IntEq _) = prec_Eq
+ | precedence_f (LT _) = prec_Eq
+ | precedence_f (LE _) = prec_Eq
+ | precedence_f (No _) = prec_Some
+ | precedence_f (Lone _) = prec_Some
+ | precedence_f (One _) = prec_Some
+ | precedence_f (Some _) = prec_Some
+ | precedence_f False = no_prec
+ | precedence_f True = no_prec
+ | precedence_f (FormulaReg _) = no_prec
+(* rel_expr -> int *)
+and precedence_r (RelLet _) = prec_All
+ | precedence_r (RelIf _) = prec_All
+ | precedence_r (Union _) = prec_Add
+ | precedence_r (Difference _) = prec_Add
+ | precedence_r (Override _) = prec_Override
+ | precedence_r (Intersect _) = prec_Intersect
+ | precedence_r (Product _) = prec_Product
+ | precedence_r (IfNo _) = prec_IfNo
+ | precedence_r (Project _) = prec_Project
+ | precedence_r (Join _) = prec_Join
+ | precedence_r (Closure _) = prec_BitNot
+ | precedence_r (ReflexiveClosure _) = prec_BitNot
+ | precedence_r (Transpose _) = prec_BitNot
+ | precedence_r (Comprehension _) = no_prec
+ | precedence_r (Bits _) = no_prec
+ | precedence_r (Int _) = no_prec
+ | precedence_r Iden = no_prec
+ | precedence_r Ints = no_prec
+ | precedence_r None = no_prec
+ | precedence_r Univ = no_prec
+ | precedence_r (Atom _) = no_prec
+ | precedence_r (AtomSeq _) = no_prec
+ | precedence_r (Rel _) = no_prec
+ | precedence_r (Var _) = no_prec
+ | precedence_r (RelReg _) = no_prec
+(* int_expr -> int *)
+and precedence_i (Sum _) = prec_All
+ | precedence_i (IntLet _) = prec_All
+ | precedence_i (IntIf _) = prec_All
+ | precedence_i (SHL _) = prec_SHL
+ | precedence_i (SHA _) = prec_SHL
+ | precedence_i (SHR _) = prec_SHL
+ | precedence_i (Add _) = prec_Add
+ | precedence_i (Sub _) = prec_Add
+ | precedence_i (Mult _) = prec_Mult
+ | precedence_i (Div _) = prec_Mult
+ | precedence_i (Mod _) = prec_Mult
+ | precedence_i (Cardinality _) = no_prec
+ | precedence_i (SetSum _) = no_prec
+ | precedence_i (BitOr _) = prec_Intersect
+ | precedence_i (BitXor _) = prec_Intersect
+ | precedence_i (BitAnd _) = prec_Intersect
+ | precedence_i (BitNot _) = prec_BitNot
+ | precedence_i (Neg _) = prec_BitNot
+ | precedence_i (Absolute _) = prec_BitNot
+ | precedence_i (Signum _) = prec_BitNot
+ | precedence_i (Num _) = no_prec
+ | precedence_i (IntReg _) = no_prec
+
+(* (string -> unit) -> problem list -> unit *)
+fun write_problem_file out problems =
+ let
+ (* formula -> unit *)
+ fun out_outmost_f (And (f1, f2)) =
+ (out_outmost_f f1; out "\n && "; out_outmost_f f2)
+ | out_outmost_f f = out_f f prec_And
+ (* formula -> int -> unit *)
+ and out_f formula outer_prec =
+ let
+ val prec = precedence_f formula
+ val need_parens = (prec < outer_prec)
+ in
+ (if need_parens then out "(" else ());
+ (case formula of
+ All (ds, f) => (out "all ["; out_decls ds; out "] | "; out_f f prec)
+ | Exist (ds, f) =>
+ (out "some ["; out_decls ds; out "] | "; out_f f prec)
+ | FormulaLet (bs, f) =>
+ (out "let ["; out_assigns bs; out "] | "; out_f f prec)
+ | FormulaIf (f, f1, f2) =>
+ (out "if "; out_f f prec; out " then "; out_f f1 prec; out " else ";
+ out_f f2 prec)
+ | Or (f1, f2) => (out_f f1 prec; out " || "; out_f f2 prec)
+ | Iff (f1, f2) => (out_f f1 prec; out " <=> "; out_f f2 prec)
+ | Implies (f1, f2) => (out_f f1 (prec + 1); out " => "; out_f f2 prec)
+ | And (f1, f2) => (out_f f1 prec; out " && "; out_f f2 prec)
+ | Not f => (out "! "; out_f f prec)
+ | Acyclic x => out ("ACYCLIC(" ^ rel_name x ^ ")")
+ | Function (x, r1, r2) =>
+ (out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> one ";
+ out_r r2 0; out ")")
+ | Functional (x, r1, r2) =>
+ (out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> lone ";
+ out_r r2 0; out ")")
+ | TotalOrdering (x1, x2, x3, x4) =>
+ out ("TOTAL_ORDERING(" ^ rel_name x1 ^ ", " ^ rel_name x2 ^ ", "
+ ^ rel_name x3 ^ ", " ^ rel_name x4 ^ ")")
+ | Subset (r1, r2) => (out_r r1 prec; out " in "; out_r r2 prec)
+ | RelEq (r1, r2) => (out_r r1 prec; out " = "; out_r r2 prec)
+ | IntEq (i1, i2) => (out_i i1 prec; out " = "; out_i i2 prec)
+ | LT (i1, i2) => (out_i i1 prec; out " < "; out_i i2 prec)
+ | LE (i1, i2) => (out_i i1 prec; out " <= "; out_i i2 prec)
+ | No r => (out "no "; out_r r prec)
+ | Lone r => (out "lone "; out_r r prec)
+ | One r => (out "one "; out_r r prec)
+ | Some r => (out "some "; out_r r prec)
+ | False => out "false"
+ | True => out "true"
+ | FormulaReg j => out (formula_reg_name j));
+ (if need_parens then out ")" else ())
+ end
+ (* rel_expr -> int -> unit *)
+ and out_r rel_expr outer_prec =
+ let
+ val prec = precedence_r rel_expr
+ val need_parens = (prec < outer_prec)
+ in
+ (if need_parens then out "(" else ());
+ (case rel_expr of
+ RelLet (bs, r) =>
+ (out "let ["; out_assigns bs; out "] | "; out_r r prec)
+ | RelIf (f, r1, r2) =>
+ (out "if "; out_f f prec; out " then "; out_r r1 prec;
+ out " else "; out_r r2 prec)
+ | Union (r1, r2) => (out_r r1 prec; out " + "; out_r r2 (prec + 1))
+ | Difference (r1, r2) =>
+ (out_r r1 prec; out " - "; out_r r2 (prec + 1))
+ | Override (r1, r2) => (out_r r1 prec; out " ++ "; out_r r2 prec)
+ | Intersect (r1, r2) => (out_r r1 prec; out " & "; out_r r2 prec)
+ | Product (r1, r2) => (out_r r1 prec; out "->"; out_r r2 prec)
+ | IfNo (r1, r2) => (out_r r1 prec; out "\\"; out_r r2 prec)
+ | Project (r1, is) => (out_r r1 prec; out "["; out_columns is; out "]")
+ | Join (r1, r2) => (out_r r1 prec; out "."; out_r r2 (prec + 1))
+ | Closure r => (out "^"; out_r r prec)
+ | ReflexiveClosure r => (out "*"; out_r r prec)
+ | Transpose r => (out "~"; out_r r prec)
+ | Comprehension (ds, f) =>
+ (out "{["; out_decls ds; out "] | "; out_f f 0; out "}")
+ | Bits i => (out "Bits["; out_i i 0; out "]")
+ | Int i => (out "Int["; out_i i 0; out "]")
+ | Iden => out "iden"
+ | Ints => out "ints"
+ | None => out "none"
+ | Univ => out "univ"
+ | Atom j => out (atom_name j)
+ | AtomSeq x => out (atom_seq_name x)
+ | Rel x => out (rel_name x)
+ | Var x => out (var_name x)
+ | RelReg (_, j) => out (rel_reg_name j));
+ (if need_parens then out ")" else ())
+ end
+ (* int_expr -> int -> unit *)
+ and out_i int_expr outer_prec =
+ let
+ val prec = precedence_i int_expr
+ val need_parens = (prec < outer_prec)
+ in
+ (if need_parens then out "(" else ());
+ (case int_expr of
+ Sum (ds, i) => (out "sum ["; out_decls ds; out "] | "; out_i i prec)
+ | IntLet (bs, i) =>
+ (out "let ["; out_assigns bs; out "] | "; out_i i prec)
+ | IntIf (f, i1, i2) =>
+ (out "if "; out_f f prec; out " then "; out_i i1 prec;
+ out " else "; out_i i2 prec)
+ | SHL (i1, i2) => (out_i i1 prec; out " << "; out_i i2 (prec + 1))
+ | SHA (i1, i2) => (out_i i1 prec; out " >> "; out_i i2 (prec + 1))
+ | SHR (i1, i2) => (out_i i1 prec; out " >>> "; out_i i2 (prec + 1))
+ | Add (i1, i2) => (out_i i1 prec; out " + "; out_i i2 (prec + 1))
+ | Sub (i1, i2) => (out_i i1 prec; out " - "; out_i i2 (prec + 1))
+ | Mult (i1, i2) => (out_i i1 prec; out " * "; out_i i2 (prec + 1))
+ | Div (i1, i2) => (out_i i1 prec; out " / "; out_i i2 (prec + 1))
+ | Mod (i1, i2) => (out_i i1 prec; out " % "; out_i i2 (prec + 1))
+ | Cardinality r => (out "#("; out_r r 0; out ")")
+ | SetSum r => (out "sum("; out_r r 0; out ")")
+ | BitOr (i1, i2) => (out_i i1 prec; out " | "; out_i i2 prec)
+ | BitXor (i1, i2) => (out_i i1 prec; out " ^ "; out_i i2 prec)
+ | BitAnd (i1, i2) => (out_i i1 prec; out " & "; out_i i2 prec)
+ | BitNot i => (out "~"; out_i i prec)
+ | Neg i => (out "-"; out_i i prec)
+ | Absolute i => (out "abs "; out_i i prec)
+ | Signum i => (out "sgn "; out_i i prec)
+ | Num k => out (Int.toString k)
+ | IntReg j => out (int_reg_name j));
+ (if need_parens then out ")" else ())
+ end
+ (* decl list -> unit *)
+ and out_decls [] = ()
+ | out_decls [d] = out_decl d
+ | out_decls (d :: ds) = (out_decl d; out ", "; out_decls ds)
+ (* decl -> unit *)
+ and out_decl (DeclNo (x, r)) =
+ (out (var_name x); out " : no "; out_r r 0)
+ | out_decl (DeclLone (x, r)) =
+ (out (var_name x); out " : lone "; out_r r 0)
+ | out_decl (DeclOne (x, r)) =
+ (out (var_name x); out " : one "; out_r r 0)
+ | out_decl (DeclSome (x, r)) =
+ (out (var_name x); out " : some "; out_r r 0)
+ | out_decl (DeclSet (x, r)) =
+ (out (var_name x); out " : set "; out_r r 0)
+ (* assign_expr list -> unit *)
+ and out_assigns [] = ()
+ | out_assigns [b] = out_assign b
+ | out_assigns (b :: bs) = (out_assign b; out ", "; out_assigns bs)
+ (* assign_expr -> unit *)
+ and out_assign (AssignFormulaReg (j, f)) =
+ (out (formula_reg_name j); out " := "; out_f f 0)
+ | out_assign (AssignRelReg ((_, j), r)) =
+ (out (rel_reg_name j); out " := "; out_r r 0)
+ | out_assign (AssignIntReg (j, i)) =
+ (out (int_reg_name j); out " := "; out_i i 0)
+ (* int_expr list -> unit *)
+ and out_columns [] = ()
+ | out_columns [i] = out_i i 0
+ | out_columns (i :: is) = (out_i i 0; out ", "; out_columns is)
+ (* problem -> unit *)
+ and out_problem {comment, settings, univ_card, tuple_assigns, bounds,
+ int_bounds, expr_assigns, formula} =
+ (out ("\n" ^ block_comment comment ^
+ implode (map (fn (key, value) => key ^ ": " ^ value ^ "\n")
+ settings) ^
+ "univ: " ^ atom_seq_name (univ_card, 0) ^ "\n" ^
+ implode (map string_for_tuple_assign tuple_assigns) ^
+ implode (map string_for_bound bounds) ^
+ (if int_bounds = [] then
+ ""
+ else
+ "int_bounds: " ^
+ commas (map int_string_for_bound int_bounds) ^ "\n"));
+ map (fn b => (out_assign b; out ";")) expr_assigns;
+ out "solve "; out_outmost_f formula; out ";\n")
+ in
+ out ("// This file was generated by Isabelle (probably Nitpick)\n" ^
+ "// " ^ Date.fmt "%Y-%m-%d %H:%M:%S"
+ (Date.fromTimeLocal (Time.now ())) ^ "\n");
+ map out_problem problems
+ end
+
+(* string -> bool *)
+fun is_ident_char s =
+ Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s
+ orelse s = "_" orelse s = "'" orelse s = "$"
+
+(* string list -> string list *)
+fun strip_blanks [] = []
+ | strip_blanks (" " :: ss) = strip_blanks ss
+ | strip_blanks [s1, " "] = [s1]
+ | strip_blanks (s1 :: " " :: s2 :: ss) =
+ if is_ident_char s1 andalso is_ident_char s2 then
+ s1 :: " " :: strip_blanks (s2 :: ss)
+ else
+ strip_blanks (s1 :: s2 :: ss)
+ | strip_blanks (s :: ss) = s :: strip_blanks ss
+
+(* (string list -> 'a * string list) -> string list -> 'a list * string list *)
+fun scan_non_empty_list scan = scan ::: Scan.repeat ($$ "," |-- scan)
+fun scan_list scan = scan_non_empty_list scan || Scan.succeed []
+(* string list -> int * string list *)
+val scan_nat = Scan.repeat1 (Scan.one Symbol.is_ascii_digit)
+ >> (the o Int.fromString o space_implode "")
+(* string list -> (int * int) * string list *)
+val scan_rel_name = $$ "s" |-- scan_nat >> pair 1
+ || $$ "r" |-- scan_nat >> pair 2
+ || ($$ "m" |-- scan_nat --| $$ "_") -- scan_nat
+(* string list -> int * string list *)
+val scan_atom = $$ "A" |-- scan_nat
+(* string list -> int list * string list *)
+val scan_tuple = $$ "[" |-- scan_list scan_atom --| $$ "]"
+(* string list -> int list list * string list *)
+val scan_tuple_set = $$ "[" |-- scan_list scan_tuple --| $$ "]"
+(* string list -> ((int * int) * int list list) * string list *)
+val scan_assignment = (scan_rel_name --| $$ "=") -- scan_tuple_set
+(* string list -> ((int * int) * int list list) list * string list *)
+val scan_instance = Scan.this_string "relations:" |--
+ $$ "{" |-- scan_list scan_assignment --| $$ "}"
+
+(* string -> raw_bound list *)
+fun parse_instance inst =
+ Scan.finite Symbol.stopper
+ (Scan.error (!! (fn _ => raise SYNTAX ("Kodkod.parse_instance",
+ "ill-formed Kodkodi output"))
+ scan_instance))
+ (strip_blanks (explode inst))
+ |> fst
+
+val problem_marker = "*** PROBLEM "
+val outcome_marker = "---OUTCOME---\n"
+val instance_marker = "---INSTANCE---\n"
+
+(* string -> substring -> string *)
+fun read_section_body marker =
+ Substring.string o fst o Substring.position "\n\n"
+ o Substring.triml (size marker)
+
+(* substring -> raw_bound list *)
+fun read_next_instance s =
+ let val s = Substring.position instance_marker s |> snd in
+ if Substring.isEmpty s then
+ raise SYNTAX ("Kodkod.read_next_instance", "expected \"INSTANCE\" marker")
+ else
+ read_section_body instance_marker s |> parse_instance
+ end
+
+(* int -> substring * (int * raw_bound list) list * int list
+ -> substring * (int * raw_bound list) list * int list *)
+fun read_next_outcomes j (s, ps, js) =
+ let val (s1, s2) = Substring.position outcome_marker s in
+ if Substring.isEmpty s2
+ orelse not (Substring.isEmpty (Substring.position problem_marker s1
+ |> snd)) then
+ (s, ps, js)
+ else
+ let
+ val outcome = read_section_body outcome_marker s2
+ val s = Substring.triml (size outcome_marker) s2
+ in
+ if String.isSuffix "UNSATISFIABLE" outcome then
+ read_next_outcomes j (s, ps, j :: js)
+ else if String.isSuffix "SATISFIABLE" outcome then
+ read_next_outcomes j (s, (j, read_next_instance s2) :: ps, js)
+ else
+ raise SYNTAX ("Kodkod.read_next_outcomes",
+ "unknown outcome " ^ quote outcome)
+ end
+ end
+
+(* substring * (int * raw_bound list) list * int list
+ -> (int * raw_bound list) list * int list *)
+fun read_next_problems (s, ps, js) =
+ let val s = Substring.position problem_marker s |> snd in
+ if Substring.isEmpty s then
+ (ps, js)
+ else
+ let
+ val s = Substring.triml (size problem_marker) s
+ val j_plus_1 = s |> Substring.takel (not_equal #" ") |> Substring.string
+ |> Int.fromString |> the
+ val j = j_plus_1 - 1
+ in read_next_problems (read_next_outcomes j (s, ps, js)) end
+ end
+ handle Option.Option => raise SYNTAX ("Kodkod.read_next_problems",
+ "expected number after \"PROBLEM\"")
+
+(* Path.T -> (int * raw_bound list) list * int list *)
+fun read_output_file path =
+ read_next_problems (Substring.full (File.read path), [], []) |>> rev ||> rev
+
+(* The fudge term below is to account for Kodkodi's slow start-up time, which
+ is partly due to the JVM and partly due to the ML "system" function. *)
+val fudge_ms = 250
+
+(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
+fun solve_any_problem overlord deadline max_threads max_solutions problems =
+ let
+ val j = find_index (equal True o #formula) problems
+ val indexed_problems = if j >= 0 then
+ [(j, nth problems j)]
+ else
+ filter (not_equal False o #formula o snd)
+ (0 upto length problems - 1 ~~ problems)
+ val triv_js = filter_out (AList.defined (op =) indexed_problems)
+ (0 upto length problems - 1)
+ (* int -> int *)
+ val reindex = fst o nth indexed_problems
+ in
+ if null indexed_problems then
+ Normal ([], triv_js)
+ else
+ let
+ val (serial_str, tmp_path) =
+ if overlord then
+ ("", Path.append (Path.variable "ISABELLE_HOME_USER") o Path.base)
+ else
+ (serial_string (), File.tmp_path)
+ (* string -> string -> Path.T *)
+ fun path_for base suf =
+ tmp_path (Path.explode (base ^ serial_str ^ "." ^ suf))
+ val in_path = path_for "isabelle" "kki"
+ val in_buf = Unsynchronized.ref Buffer.empty
+ (* string -> unit *)
+ fun out s = Unsynchronized.change in_buf (Buffer.add s)
+ val out_path = path_for "kodkodi" "out"
+ val err_path = path_for "kodkodi" "err"
+ val _ = write_problem_file out (map snd indexed_problems)
+ val _ = File.write_buffer in_path (!in_buf)
+ (* (int list -> outcome) -> outcome *)
+ fun stopped constr =
+ let val nontriv_js = map reindex (snd (read_output_file out_path)) in
+ constr (triv_js @ nontriv_js)
+ handle Exn.Interrupt => Interrupted NONE
+ end
+ in
+ let
+ val ms =
+ case deadline of
+ NONE => ~1
+ | SOME time =>
+ Int.max (0, Time.toMilliseconds (Time.- (time, Time.now ()))
+ - fudge_ms)
+ val outcome =
+ let
+ val code =
+ system ("env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
+ \\"$ISABELLE_TOOL\" java \
+ \de.tum.in.isabelle.Kodkodi.Kodkodi" ^
+ (if ms >= 0 then " -max-msecs " ^ Int.toString ms
+ else "") ^
+ (if max_solutions > 1 then " -solve-all" else "") ^
+ " -max-solutions " ^ Int.toString max_solutions ^
+ (if max_threads > 0 then
+ " -max-threads " ^ Int.toString max_threads
+ else
+ "") ^
+ " < " ^ Path.implode in_path ^
+ " > " ^ Path.implode out_path ^
+ " 2> " ^ Path.implode err_path)
+ val (ps, nontriv_js) = read_output_file out_path
+ |>> map (apfst reindex) ||> map reindex
+ val js = triv_js @ nontriv_js
+ val first_error =
+ File.fold_lines (fn line => fn "" => line | s => s) err_path ""
+ in
+ if null ps then
+ if code = 2 then
+ TimedOut js
+ else if first_error <> "" then
+ Error (first_error |> perhaps (try (unsuffix "."))
+ |> perhaps (try (unprefix "Error: ")), js)
+ else if code <> 0 then
+ Error ("Unknown error", js)
+ else
+ Normal ([], js)
+ else
+ Normal (ps, js)
+ end
+ in
+ if overlord then ()
+ else List.app File.rm [in_path, out_path, err_path];
+ outcome
+ end
+ handle Exn.Interrupt => stopped (Interrupted o SOME)
+ end
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,109 @@
+(* Title: HOL/Nitpick/Tools/kodkod_sat.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Kodkod SAT solver integration.
+*)
+
+signature KODKOD_SAT =
+sig
+ val configured_sat_solvers : bool -> string list
+ val smart_sat_solver_name : bool -> string
+ val sat_solver_spec : string -> string * string list
+end;
+
+structure KodkodSAT : KODKOD_SAT =
+struct
+
+datatype sink = ToStdout | ToFile
+
+datatype sat_solver_info =
+ Internal of bool * string list |
+ External of sink * string * string * string list |
+ ExternalV2 of sink * string * string * string list * string * string * string
+
+val berkmin_exec = getenv "BERKMIN_EXE"
+
+(* (string * sat_solver_info) list *)
+val static_list =
+ [("MiniSat", ExternalV2 (ToFile, "MINISAT_HOME", "minisat", [], "SAT", "",
+ "UNSAT")),
+ ("PicoSAT", External (ToStdout, "PICOSAT_HOME", "picosat", [])),
+ ("zChaff", ExternalV2 (ToStdout, "ZCHAFF_HOME", "zchaff", [],
+ "Instance Satisfiable", "",
+ "Instance Unsatisfiable")),
+ ("RSat", ExternalV2 (ToStdout, "RSAT_HOME", "rsat", ["-s"],
+ "s SATISFIABLE", "v ", "s UNSATISFIABLE")),
+ ("BerkMin", ExternalV2 (ToStdout, "BERKMIN_HOME",
+ if berkmin_exec = "" then "BerkMin561"
+ else berkmin_exec, [], "Satisfiable !!",
+ "solution =", "UNSATISFIABLE !!")),
+ ("BerkMinAlloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
+ ("Jerusat", External (ToStdout, "JERUSAT_HOME", "Jerusat1.3", [])),
+ ("SAT4J", Internal (true, ["DefaultSAT4J"])),
+ ("MiniSatJNI", Internal (true, ["MiniSat"])),
+ ("zChaffJNI", Internal (false, ["zChaff"])),
+ ("SAT4JLight", Internal (true, ["LightSAT4J"])),
+ ("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
+ "s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
+
+val created_temp_dir = Unsynchronized.ref false
+
+(* string -> sink -> string -> string -> string list -> string list
+ -> (string * (unit -> string list)) option *)
+fun dynamic_entry_for_external name dev home exec args markers =
+ case getenv home of
+ "" => NONE
+ | dir => SOME (name, fn () =>
+ let
+ val temp_dir = getenv "ISABELLE_TMP"
+ val _ = if !created_temp_dir then
+ ()
+ else
+ (created_temp_dir := true;
+ File.mkdir (Path.explode temp_dir))
+ val temp = temp_dir ^ "/" ^ name ^ serial_string ()
+ val out_file = temp ^ ".out"
+ in
+ [if null markers then "External" else "ExternalV2",
+ dir ^ "/" ^ exec, temp ^ ".cnf",
+ if dev = ToFile then out_file else ""] @ markers @
+ (if dev = ToFile then [out_file] else []) @ args
+ end)
+(* bool -> string * sat_solver_info
+ -> (string * (unit -> string list)) option *)
+fun dynamic_entry_for_info false (name, Internal (_, ss)) = SOME (name, K ss)
+ | dynamic_entry_for_info false (name, External (dev, home, exec, args)) =
+ dynamic_entry_for_external name dev home exec args []
+ | dynamic_entry_for_info false (name, ExternalV2 (dev, home, exec, args,
+ m1, m2, m3)) =
+ dynamic_entry_for_external name dev home exec args [m1, m2, m3]
+ | dynamic_entry_for_info true (name, Internal (true, ss)) = SOME (name, K ss)
+ | dynamic_entry_for_info true _ = NONE
+(* bool -> (string * (unit -> string list)) list *)
+fun dynamic_list incremental =
+ map_filter (dynamic_entry_for_info incremental) static_list
+
+(* bool -> string list *)
+val configured_sat_solvers = map fst o dynamic_list
+
+(* bool -> string *)
+val smart_sat_solver_name = dynamic_list #> hd #> fst
+
+(* (string * 'a) list -> string *)
+fun enum_solvers xs = commas (map (quote o fst) xs |> distinct (op =))
+(* string -> string * string list *)
+fun sat_solver_spec name =
+ let val dynamic_list = dynamic_list false in
+ (name, the (AList.lookup (op =) dynamic_list name) ())
+ handle Option.Option =>
+ error (if AList.defined (op =) static_list name then
+ "The SAT solver " ^ quote name ^ " is not configured. The \
+ \following solvers are configured:\n" ^
+ enum_solvers dynamic_list ^ "."
+ else
+ "Unknown SAT solver " ^ quote name ^ ". The following \
+ \solvers are supported:\n" ^ enum_solvers static_list ^ ".")
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/minipick.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,322 @@
+(* Title: HOL/Nitpick/Tools/minipick.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Finite model generation for HOL formulas using Kodkod, minimalistic version.
+*)
+
+signature MINIPICK =
+sig
+ val pick_nits_in_term : Proof.context -> (typ -> int) -> term -> string
+end;
+
+structure Minipick : MINIPICK =
+struct
+
+open Kodkod
+open NitpickUtil
+open NitpickHOL
+open NitpickPeephole
+open NitpickKodkod
+
+(* theory -> typ -> unit *)
+fun check_type ctxt (Type ("fun", Ts)) = List.app (check_type ctxt) Ts
+ | check_type ctxt (Type ("*", Ts)) = List.app (check_type ctxt) Ts
+ | check_type _ @{typ bool} = ()
+ | check_type _ (TFree (_, @{sort "{}"})) = ()
+ | check_type _ (TFree (_, @{sort HOL.type})) = ()
+ | check_type ctxt T =
+ raise NOT_SUPPORTED ("type " ^ quote (Syntax.string_of_typ ctxt T))
+
+(* (typ -> int) -> typ -> int *)
+fun atom_schema_of_one scope (Type ("fun", [T1, T2])) =
+ replicate_list (scope T1) (atom_schema_of_one scope T2)
+ | atom_schema_of_one scope (Type ("*", [T1, T2])) =
+ atom_schema_of_one scope T1 @ atom_schema_of_one scope T2
+ | atom_schema_of_one scope T = [scope T]
+fun atom_schema_of_set scope (Type ("fun", [T1, @{typ bool}])) =
+ atom_schema_of_one scope T1
+ | atom_schema_of_set scope (Type ("fun", [T1, T2])) =
+ atom_schema_of_one scope T1 @ atom_schema_of_set scope T2
+ | atom_schema_of_set scope T = atom_schema_of_one scope T
+val arity_of_one = length oo atom_schema_of_one
+val arity_of_set = length oo atom_schema_of_set
+
+(* (typ -> int) -> typ list -> int -> int *)
+fun index_for_bound_var _ [_] 0 = 0
+ | index_for_bound_var scope (_ :: Ts) 0 =
+ index_for_bound_var scope Ts 0 + arity_of_one scope (hd Ts)
+ | index_for_bound_var scope Ts n = index_for_bound_var scope (tl Ts) (n - 1)
+(* (typ -> int) -> typ list -> int -> rel_expr list *)
+fun one_vars_for_bound_var scope Ts j =
+ map (curry Var 1) (index_seq (index_for_bound_var scope Ts j)
+ (arity_of_one scope (nth Ts j)))
+fun set_vars_for_bound_var scope Ts j =
+ map (curry Var 1) (index_seq (index_for_bound_var scope Ts j)
+ (arity_of_set scope (nth Ts j)))
+(* (typ -> int) -> typ list -> typ -> decl list *)
+fun decls_for_one scope Ts T =
+ map2 (curry DeclOne o pair 1)
+ (index_seq (index_for_bound_var scope (T :: Ts) 0)
+ (arity_of_one scope (nth (T :: Ts) 0)))
+ (map (AtomSeq o rpair 0) (atom_schema_of_one scope T))
+fun decls_for_set scope Ts T =
+ map2 (curry DeclOne o pair 1)
+ (index_seq (index_for_bound_var scope (T :: Ts) 0)
+ (arity_of_set scope (nth (T :: Ts) 0)))
+ (map (AtomSeq o rpair 0) (atom_schema_of_set scope T))
+
+(* int list -> rel_expr *)
+val atom_product = foldl1 Product o map Atom
+
+val false_atom = Atom 0
+val true_atom = Atom 1
+
+(* rel_expr -> formula *)
+fun formula_from_atom r = RelEq (r, true_atom)
+(* formula -> rel_expr *)
+fun atom_from_formula f = RelIf (f, true_atom, false_atom)
+
+(* Proof.context -> (typ -> int) -> styp list -> term -> formula *)
+fun kodkod_formula_for_term ctxt scope frees =
+ let
+ (* typ list -> int -> rel_expr *)
+ val one_from_bound_var = foldl1 Product oo one_vars_for_bound_var scope
+ val set_from_bound_var = foldl1 Product oo set_vars_for_bound_var scope
+ (* typ -> rel_expr -> rel_expr *)
+ fun set_from_one (T as Type ("fun", [T1, @{typ bool}])) r =
+ let
+ val jss = atom_schema_of_one scope T1 |> map (rpair 0)
+ |> all_combinations
+ in
+ map2 (fn i => fn js =>
+ RelIf (RelEq (Project (r, [Num i]), true_atom),
+ atom_product js, empty_n_ary_rel (length js)))
+ (index_seq 0 (length jss)) jss
+ |> foldl1 Union
+ end
+ | set_from_one (Type ("fun", [T1, T2])) r =
+ let
+ val jss = atom_schema_of_one scope T1 |> map (rpair 0)
+ |> all_combinations
+ val arity2 = arity_of_one scope T2
+ in
+ map2 (fn i => fn js =>
+ Product (atom_product js,
+ Project (r, num_seq (i * arity2) arity2)
+ |> set_from_one T2))
+ (index_seq 0 (length jss)) jss
+ |> foldl1 Union
+ end
+ | set_from_one _ r = r
+ (* typ list -> typ -> rel_expr -> rel_expr *)
+ fun one_from_set Ts (T as Type ("fun", _)) r =
+ Comprehension (decls_for_one scope Ts T,
+ RelEq (set_from_one T (one_from_bound_var (T :: Ts) 0),
+ r))
+ | one_from_set _ _ r = r
+ (* typ list -> term -> formula *)
+ fun to_f Ts t =
+ (case t of
+ @{const Not} $ t1 => Not (to_f Ts t1)
+ | @{const False} => False
+ | @{const True} => True
+ | Const (@{const_name All}, _) $ Abs (s, T, t') =>
+ All (decls_for_one scope Ts T, to_f (T :: Ts) t')
+ | (t0 as Const (@{const_name All}, _)) $ t1 =>
+ to_f Ts (t0 $ eta_expand Ts t1 1)
+ | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
+ Exist (decls_for_one scope Ts T, to_f (T :: Ts) t')
+ | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
+ to_f Ts (t0 $ eta_expand Ts t1 1)
+ | Const (@{const_name "op ="}, _) $ t1 $ t2 =>
+ RelEq (to_set Ts t1, to_set Ts t2)
+ | Const (@{const_name ord_class.less_eq},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
+ Subset (to_set Ts t1, to_set Ts t2)
+ | @{const "op &"} $ t1 $ t2 => And (to_f Ts t1, to_f Ts t2)
+ | @{const "op |"} $ t1 $ t2 => Or (to_f Ts t1, to_f Ts t2)
+ | @{const "op -->"} $ t1 $ t2 => Implies (to_f Ts t1, to_f Ts t2)
+ | t1 $ t2 => Subset (to_one Ts t2, to_set Ts t1)
+ | Free _ => raise SAME ()
+ | Term.Var _ => raise SAME ()
+ | Bound _ => raise SAME ()
+ | Const (s, _) => raise NOT_SUPPORTED ("constant " ^ quote s)
+ | _ => raise TERM ("to_f", [t]))
+ handle SAME () => formula_from_atom (to_set Ts t)
+ (* typ list -> term -> rel_expr *)
+ and to_one Ts t =
+ case t of
+ Const (@{const_name Pair}, _) $ t1 $ t2 =>
+ Product (to_one Ts t1, to_one Ts t2)
+ | Const (@{const_name Pair}, _) $ _ => to_one Ts (eta_expand Ts t 1)
+ | Const (@{const_name Pair}, _) => to_one Ts (eta_expand Ts t 2)
+ | Const (@{const_name fst}, _) $ t1 =>
+ let val fst_arity = arity_of_one scope (fastype_of1 (Ts, t)) in
+ Project (to_one Ts t1, num_seq 0 fst_arity)
+ end
+ | Const (@{const_name fst}, _) => to_one Ts (eta_expand Ts t 1)
+ | Const (@{const_name snd}, _) $ t1 =>
+ let
+ val pair_arity = arity_of_one scope (fastype_of1 (Ts, t1))
+ val snd_arity = arity_of_one scope (fastype_of1 (Ts, t))
+ val fst_arity = pair_arity - snd_arity
+ in Project (to_one Ts t1, num_seq fst_arity snd_arity) end
+ | Const (@{const_name snd}, _) => to_one Ts (eta_expand Ts t 1)
+ | Bound j => one_from_bound_var Ts j
+ | _ => one_from_set Ts (fastype_of1 (Ts, t)) (to_set Ts t)
+ (* term -> rel_expr *)
+ and to_set Ts t =
+ (case t of
+ @{const Not} => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name All}, _) => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name Ex}, _) => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name "op ="}, _) $ _ => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name "op ="}, _) => to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name ord_class.less_eq},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ _ =>
+ to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name ord_class.less_eq}, _) =>
+ to_set Ts (eta_expand Ts t 2)
+ | @{const "op &"} $ _ => to_set Ts (eta_expand Ts t 1)
+ | @{const "op &"} => to_set Ts (eta_expand Ts t 2)
+ | @{const "op |"} $ _ => to_set Ts (eta_expand Ts t 1)
+ | @{const "op |"} => to_set Ts (eta_expand Ts t 2)
+ | @{const "op -->"} $ _ => to_set Ts (eta_expand Ts t 1)
+ | @{const "op -->"} => to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name bot_class.bot},
+ T as Type ("fun", [_, @{typ bool}])) =>
+ empty_n_ary_rel (arity_of_set scope T)
+ | Const (@{const_name insert}, _) $ t1 $ t2 =>
+ Union (to_one Ts t1, to_set Ts t2)
+ | Const (@{const_name insert}, _) $ _ => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name insert}, _) => to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name trancl}, _) $ t1 =>
+ if arity_of_set scope (fastype_of1 (Ts, t1)) = 2 then
+ Closure (to_set Ts t1)
+ else
+ raise NOT_SUPPORTED "transitive closure for function or pair type"
+ | Const (@{const_name trancl}, _) => to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name lower_semilattice_class.inf},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
+ Intersect (to_set Ts t1, to_set Ts t2)
+ | Const (@{const_name lower_semilattice_class.inf}, _) $ _ =>
+ to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name lower_semilattice_class.inf}, _) =>
+ to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name upper_semilattice_class.sup},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
+ Union (to_set Ts t1, to_set Ts t2)
+ | Const (@{const_name upper_semilattice_class.sup}, _) $ _ =>
+ to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name upper_semilattice_class.sup}, _) =>
+ to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name minus_class.minus},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
+ Difference (to_set Ts t1, to_set Ts t2)
+ | Const (@{const_name minus_class.minus},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ _ =>
+ to_set Ts (eta_expand Ts t 1)
+ | Const (@{const_name minus_class.minus},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) =>
+ to_set Ts (eta_expand Ts t 2)
+ | Const (@{const_name Pair}, _) $ _ $ _ => raise SAME ()
+ | Const (@{const_name Pair}, _) $ _ => raise SAME ()
+ | Const (@{const_name Pair}, _) => raise SAME ()
+ | Const (@{const_name fst}, _) $ _ => raise SAME ()
+ | Const (@{const_name fst}, _) => raise SAME ()
+ | Const (@{const_name snd}, _) $ _ => raise SAME ()
+ | Const (@{const_name snd}, _) => raise SAME ()
+ | Const (_, @{typ bool}) => atom_from_formula (to_f Ts t)
+ | Free (x as (_, T)) =>
+ Rel (arity_of_set scope T, find_index (equal x) frees)
+ | Term.Var _ => raise NOT_SUPPORTED "schematic variables"
+ | Bound j => raise SAME ()
+ | Abs (_, T, t') =>
+ (case fastype_of1 (T :: Ts, t') of
+ @{typ bool} => Comprehension (decls_for_one scope Ts T,
+ to_f (T :: Ts) t')
+ | T' => Comprehension (decls_for_one scope Ts T @
+ decls_for_set scope (T :: Ts) T',
+ Subset (set_from_bound_var (T' :: T :: Ts) 0,
+ to_set (T :: Ts) t')))
+ | t1 $ t2 =>
+ (case fastype_of1 (Ts, t) of
+ @{typ bool} => atom_from_formula (to_f Ts t)
+ | T =>
+ let val T2 = fastype_of1 (Ts, t2) in
+ case arity_of_one scope T2 of
+ 1 => Join (to_one Ts t2, to_set Ts t1)
+ | n =>
+ let
+ val arity2 = arity_of_one scope T2
+ val res_arity = arity_of_set scope T
+ in
+ Project (Intersect
+ (Product (to_one Ts t2,
+ atom_schema_of_set scope T
+ |> map (AtomSeq o rpair 0) |> foldl1 Product),
+ to_set Ts t1),
+ num_seq arity2 res_arity)
+ end
+ end)
+ | _ => raise NOT_SUPPORTED ("term " ^
+ quote (Syntax.string_of_term ctxt t)))
+ handle SAME () => set_from_one (fastype_of1 (Ts, t)) (to_one Ts t)
+ in to_f [] end
+
+(* (typ -> int) -> int -> styp -> bound *)
+fun bound_for_free scope i (s, T) =
+ let val js = atom_schema_of_set scope T in
+ ([((length js, i), s)],
+ [TupleSet [], atom_schema_of_set scope T |> map (rpair 0)
+ |> tuple_set_from_atom_schema])
+ end
+
+(* (typ -> int) -> typ list -> typ -> rel_expr -> formula *)
+fun declarative_axiom_for_rel_expr scope Ts (Type ("fun", [T1, T2])) r =
+ if body_type T2 = bool_T then
+ True
+ else
+ All (decls_for_one scope Ts T1,
+ declarative_axiom_for_rel_expr scope (T1 :: Ts) T2
+ (List.foldl Join r (one_vars_for_bound_var scope (T1 :: Ts) 0)))
+ | declarative_axiom_for_rel_expr _ _ _ r = One r
+
+(* (typ -> int) -> int -> styp -> formula *)
+fun declarative_axiom_for_free scope i (_, T) =
+ declarative_axiom_for_rel_expr scope [] T (Rel (arity_of_set scope T, i))
+
+(* Proof.context -> (typ -> int) -> term -> string *)
+fun pick_nits_in_term ctxt raw_scope t =
+ let
+ val thy = ProofContext.theory_of ctxt
+ (* typ -> int *)
+ fun scope (Type ("fun", [T1, T2])) = reasonable_power (scope T2) (scope T1)
+ | scope (Type ("*", [T1, T2])) = scope T1 * scope T2
+ | scope @{typ bool} = 2
+ | scope T = Int.max (1, raw_scope T)
+ val neg_t = @{const Not} $ ObjectLogic.atomize_term thy t
+ val _ = fold_types (K o check_type ctxt) neg_t ()
+ val frees = Term.add_frees neg_t []
+ val bounds = map2 (bound_for_free scope) (index_seq 0 (length frees)) frees
+ val declarative_axioms =
+ map2 (declarative_axiom_for_free scope) (index_seq 0 (length frees))
+ frees
+ val formula = kodkod_formula_for_term ctxt scope frees neg_t
+ |> fold_rev (curry And) declarative_axioms
+ val univ_card = univ_card 0 0 0 bounds formula
+ val problem =
+ {comment = "", settings = [], univ_card = univ_card, tuple_assigns = [],
+ bounds = bounds, int_bounds = [], expr_assigns = [], formula = formula}
+ in
+ case solve_any_problem true NONE 0 1 [problem] of
+ Normal ([], _) => "none"
+ | Normal _ => "genuine"
+ | TimedOut _ => "unknown"
+ | Interrupted _ => "unknown"
+ | Error (s, _) => error ("Kodkod error: " ^ s)
+ end
+ handle NOT_SUPPORTED details =>
+ (warning ("Unsupported case: " ^ details ^ "."); "unknown")
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,857 @@
+(* Title: HOL/Nitpick/Tools/nitpick.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Finite model generation for HOL formulas using Kodkod.
+*)
+
+signature NITPICK =
+sig
+ type params = {
+ cards_assigns: (typ option * int list) list,
+ maxes_assigns: (styp option * int list) list,
+ iters_assigns: (styp option * int list) list,
+ bisim_depths: int list,
+ boxes: (typ option * bool option) list,
+ monos: (typ option * bool option) list,
+ wfs: (styp option * bool option) list,
+ sat_solver: string,
+ blocking: bool,
+ falsify: bool,
+ debug: bool,
+ verbose: bool,
+ overlord: bool,
+ user_axioms: bool option,
+ assms: bool,
+ coalesce_type_vars: bool,
+ destroy_constrs: bool,
+ specialize: bool,
+ skolemize: bool,
+ star_linear_preds: bool,
+ uncurry: bool,
+ fast_descrs: bool,
+ peephole_optim: bool,
+ timeout: Time.time option,
+ tac_timeout: Time.time option,
+ sym_break: int,
+ sharing_depth: int,
+ flatten_props: bool,
+ max_threads: int,
+ show_skolems: bool,
+ show_datatypes: bool,
+ show_consts: bool,
+ evals: term list,
+ formats: (term option * int list) list,
+ max_potential: int,
+ max_genuine: int,
+ check_potential: bool,
+ check_genuine: bool,
+ batch_size: int,
+ expect: string}
+
+ val register_frac_type : string -> (string * string) list -> theory -> theory
+ val unregister_frac_type : string -> theory -> theory
+ val register_codatatype : typ -> string -> styp list -> theory -> theory
+ val unregister_codatatype : typ -> theory -> theory
+ val pick_nits_in_term :
+ Proof.state -> params -> bool -> term list -> term -> string * Proof.state
+ val pick_nits_in_subgoal :
+ Proof.state -> params -> bool -> int -> string * Proof.state
+end;
+
+structure Nitpick : NITPICK =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickMono
+open NitpickScope
+open NitpickPeephole
+open NitpickRep
+open NitpickNut
+open NitpickKodkod
+open NitpickModel
+
+type params = {
+ cards_assigns: (typ option * int list) list,
+ maxes_assigns: (styp option * int list) list,
+ iters_assigns: (styp option * int list) list,
+ bisim_depths: int list,
+ boxes: (typ option * bool option) list,
+ monos: (typ option * bool option) list,
+ wfs: (styp option * bool option) list,
+ sat_solver: string,
+ blocking: bool,
+ falsify: bool,
+ debug: bool,
+ verbose: bool,
+ overlord: bool,
+ user_axioms: bool option,
+ assms: bool,
+ coalesce_type_vars: bool,
+ destroy_constrs: bool,
+ specialize: bool,
+ skolemize: bool,
+ star_linear_preds: bool,
+ uncurry: bool,
+ fast_descrs: bool,
+ peephole_optim: bool,
+ timeout: Time.time option,
+ tac_timeout: Time.time option,
+ sym_break: int,
+ sharing_depth: int,
+ flatten_props: bool,
+ max_threads: int,
+ show_skolems: bool,
+ show_datatypes: bool,
+ show_consts: bool,
+ evals: term list,
+ formats: (term option * int list) list,
+ max_potential: int,
+ max_genuine: int,
+ check_potential: bool,
+ check_genuine: bool,
+ batch_size: int,
+ expect: string}
+
+type problem_extension = {
+ free_names: nut list,
+ sel_names: nut list,
+ nonsel_names: nut list,
+ rel_table: nut NameTable.table,
+ liberal: bool,
+ scope: scope,
+ core: Kodkod.formula,
+ defs: Kodkod.formula list}
+
+type rich_problem = Kodkod.problem * problem_extension
+
+(* Proof.context -> string -> term list -> Pretty.T list *)
+fun pretties_for_formulas _ _ [] = []
+ | pretties_for_formulas ctxt s ts =
+ [Pretty.str (s ^ plural_s_for_list ts ^ ":"),
+ Pretty.indent indent_size (Pretty.chunks
+ (map2 (fn j => fn t =>
+ Pretty.block [t |> shorten_const_names_in_term
+ |> Syntax.pretty_term ctxt,
+ Pretty.str (if j = 1 then "." else ";")])
+ (length ts downto 1) ts))]
+
+val max_liberal_delay_ms = 200
+val max_liberal_delay_percent = 2
+
+(* Time.time option -> int *)
+fun liberal_delay_for_timeout NONE = max_liberal_delay_ms
+ | liberal_delay_for_timeout (SOME timeout) =
+ Int.max (0, Int.min (max_liberal_delay_ms,
+ Time.toMilliseconds timeout
+ * max_liberal_delay_percent div 100))
+
+(* Time.time option -> bool *)
+fun passed_deadline NONE = false
+ | passed_deadline (SOME time) = Time.compare (Time.now (), time) <> LESS
+
+(* ('a * bool option) list -> bool *)
+fun none_true asgns = forall (not_equal (SOME true) o snd) asgns
+
+val weaselly_sorts =
+ [@{sort default}, @{sort zero}, @{sort one}, @{sort plus}, @{sort minus},
+ @{sort uminus}, @{sort times}, @{sort inverse}, @{sort abs}, @{sort sgn},
+ @{sort ord}, @{sort eq}, @{sort number}]
+(* theory -> typ -> bool *)
+fun is_tfree_with_weaselly_sort thy (TFree (_, S)) =
+ exists (curry (Sign.subsort thy) S) weaselly_sorts
+ | is_tfree_with_weaselly_sort _ _ = false
+(* theory term -> bool *)
+val has_weaselly_sorts =
+ exists_type o exists_subtype o is_tfree_with_weaselly_sort
+
+(* Time.time -> Proof.state -> params -> bool -> term -> string * Proof.state *)
+fun pick_them_nits_in_term deadline state (params : params) auto orig_assm_ts
+ orig_t =
+ let
+ val timer = Timer.startRealTimer ()
+ val thy = Proof.theory_of state
+ val ctxt = Proof.context_of state
+ val {cards_assigns, maxes_assigns, iters_assigns, bisim_depths, boxes,
+ monos, wfs, sat_solver, blocking, falsify, debug, verbose, overlord,
+ user_axioms, assms, coalesce_type_vars, destroy_constrs, specialize,
+ skolemize, star_linear_preds, uncurry, fast_descrs, peephole_optim,
+ tac_timeout, sym_break, sharing_depth, flatten_props, max_threads,
+ show_skolems, show_datatypes, show_consts, evals, formats,
+ max_potential, max_genuine, check_potential, check_genuine, batch_size,
+ ...} =
+ params
+ val state_ref = Unsynchronized.ref state
+ (* Pretty.T -> unit *)
+ val pprint =
+ if auto then
+ Unsynchronized.change state_ref o Proof.goal_message o K
+ o curry Pretty.blk 0 o cons (Pretty.str "") o single
+ o Pretty.mark Markup.hilite
+ else
+ priority o Pretty.string_of
+ (* (unit -> Pretty.T) -> unit *)
+ fun pprint_m f = () |> not auto ? pprint o f
+ fun pprint_v f = () |> verbose ? pprint o f
+ fun pprint_d f = () |> debug ? pprint o f
+ (* string -> unit *)
+ val print = pprint o curry Pretty.blk 0 o pstrs
+ (* (unit -> string) -> unit *)
+ fun print_m f = pprint_m (curry Pretty.blk 0 o pstrs o f)
+ fun print_v f = pprint_v (curry Pretty.blk 0 o pstrs o f)
+ fun print_d f = pprint_d (curry Pretty.blk 0 o pstrs o f)
+
+ (* unit -> unit *)
+ fun check_deadline () =
+ if debug andalso passed_deadline deadline then raise TimeLimit.TimeOut
+ else ()
+ (* unit -> 'a *)
+ fun do_interrupted () =
+ if passed_deadline deadline then raise TimeLimit.TimeOut
+ else raise Interrupt
+
+ val _ = print_m (K "Nitpicking...")
+ val neg_t = if falsify then Logic.mk_implies (orig_t, @{prop False})
+ else orig_t
+ val assms_t = if assms orelse auto then
+ Logic.mk_conjunction_list (neg_t :: orig_assm_ts)
+ else
+ neg_t
+ val (assms_t, evals) =
+ assms_t :: evals
+ |> coalesce_type_vars ? coalesce_type_vars_in_terms
+ |> hd pairf tl
+ val original_max_potential = max_potential
+ val original_max_genuine = max_genuine
+(*
+ val _ = priority ("*** " ^ Syntax.string_of_term ctxt orig_t)
+ val _ = List.app (fn t => priority ("*** " ^ Syntax.string_of_term ctxt t))
+ orig_assm_ts
+*)
+ val max_bisim_depth = fold Integer.max bisim_depths ~1
+ val case_names = case_const_names thy
+ val (defs, built_in_nondefs, user_nondefs) = all_axioms_of thy
+ val def_table = const_def_table ctxt defs
+ val nondef_table = const_nondef_table (built_in_nondefs @ user_nondefs)
+ val simp_table = Unsynchronized.ref (const_simp_table ctxt)
+ val psimp_table = const_psimp_table ctxt
+ val intro_table = inductive_intro_table ctxt def_table
+ val ground_thm_table = ground_theorem_table thy
+ val ersatz_table = ersatz_table thy
+ val (ext_ctxt as {skolems, special_funs, wf_cache, ...}) =
+ {thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
+ user_axioms = user_axioms, debug = debug, wfs = wfs,
+ destroy_constrs = destroy_constrs, specialize = specialize,
+ skolemize = skolemize, star_linear_preds = star_linear_preds,
+ uncurry = uncurry, fast_descrs = fast_descrs, tac_timeout = tac_timeout,
+ evals = evals, case_names = case_names, def_table = def_table,
+ nondef_table = nondef_table, user_nondefs = user_nondefs,
+ simp_table = simp_table, psimp_table = psimp_table,
+ intro_table = intro_table, ground_thm_table = ground_thm_table,
+ ersatz_table = ersatz_table, skolems = Unsynchronized.ref [],
+ special_funs = Unsynchronized.ref [],
+ unrolled_preds = Unsynchronized.ref [], wf_cache = Unsynchronized.ref []}
+ val frees = Term.add_frees assms_t []
+ val _ = null (Term.add_tvars assms_t [])
+ orelse raise NOT_SUPPORTED "schematic type variables"
+ val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
+ core_t) = preprocess_term ext_ctxt assms_t
+ val got_all_user_axioms =
+ got_all_mono_user_axioms andalso no_poly_user_axioms
+
+ (* styp * (bool * bool) -> unit *)
+ fun print_wf (x, (gfp, wf)) =
+ pprint (Pretty.blk (0,
+ pstrs ("The " ^ (if gfp then "co" else "") ^ "inductive predicate \"")
+ @ Syntax.pretty_term ctxt (Const x) ::
+ pstrs (if wf then
+ "\" was proved well-founded. Nitpick can compute it \
+ \efficiently."
+ else
+ "\" could not be proved well-founded. Nitpick might need to \
+ \unroll it.")))
+ val _ = if verbose then List.app print_wf (!wf_cache) else ()
+ val _ =
+ pprint_d (fn () =>
+ Pretty.chunks
+ (pretties_for_formulas ctxt "Preprocessed formula" [core_t] @
+ pretties_for_formulas ctxt "Relevant definitional axiom" def_ts @
+ pretties_for_formulas ctxt "Relevant nondefinitional axiom"
+ nondef_ts))
+ val _ = List.app (ignore o Term.type_of) (core_t :: def_ts @ nondef_ts)
+ handle TYPE (_, Ts, ts) =>
+ raise TYPE ("Nitpick.pick_them_nits_in_term", Ts, ts)
+
+ val unique_scope = forall (equal 1 o length o snd) cards_assigns
+ (* typ -> bool *)
+ fun is_free_type_monotonic T =
+ unique_scope orelse
+ case triple_lookup (type_match thy) monos T of
+ SOME (SOME b) => b
+ | _ => formulas_monotonic ext_ctxt T def_ts nondef_ts core_t
+ fun is_datatype_monotonic T =
+ unique_scope orelse
+ case triple_lookup (type_match thy) monos T of
+ SOME (SOME b) => b
+ | _ =>
+ not (is_pure_typedef thy T) orelse is_univ_typedef thy T
+ orelse is_number_type thy T
+ orelse formulas_monotonic ext_ctxt T def_ts nondef_ts core_t
+ val Ts = ground_types_in_terms ext_ctxt (core_t :: def_ts @ nondef_ts)
+ |> sort TermOrd.typ_ord
+ val (all_dataTs, all_free_Ts) =
+ List.partition (is_integer_type orf is_datatype thy) Ts
+ val (mono_dataTs, nonmono_dataTs) =
+ List.partition is_datatype_monotonic all_dataTs
+ val (mono_free_Ts, nonmono_free_Ts) =
+ List.partition is_free_type_monotonic all_free_Ts
+
+ val _ =
+ if not unique_scope andalso not (null mono_free_Ts) then
+ print_v (fn () =>
+ let
+ val ss = map (quote o string_for_type ctxt) mono_free_Ts
+ in
+ "The type" ^ plural_s_for_list ss ^ " " ^
+ space_implode " " (serial_commas "and" ss) ^ " " ^
+ (if none_true monos then
+ "passed the monotonicity test"
+ else
+ (if length ss = 1 then "is" else "are") ^
+ " considered monotonic") ^
+ ". Nitpick might be able to skip some scopes."
+ end)
+ else
+ ()
+ val mono_Ts = mono_dataTs @ mono_free_Ts
+ val nonmono_Ts = nonmono_dataTs @ nonmono_free_Ts
+
+(*
+ val _ = priority "Monotonic datatypes:"
+ val _ = List.app (priority o string_for_type ctxt) mono_dataTs
+ val _ = priority "Nonmonotonic datatypes:"
+ val _ = List.app (priority o string_for_type ctxt) nonmono_dataTs
+ val _ = priority "Monotonic free types:"
+ val _ = List.app (priority o string_for_type ctxt) mono_free_Ts
+ val _ = priority "Nonmonotonic free types:"
+ val _ = List.app (priority o string_for_type ctxt) nonmono_free_Ts
+*)
+
+ val core_u = nut_from_term thy fast_descrs (!special_funs) Eq core_t
+ val def_us = map (nut_from_term thy fast_descrs (!special_funs) DefEq)
+ def_ts
+ val nondef_us = map (nut_from_term thy fast_descrs (!special_funs) Eq)
+ nondef_ts
+ val (free_names, const_names) =
+ fold add_free_and_const_names (core_u :: def_us @ nondef_us) ([], [])
+ val nonsel_names = filter_out (is_sel o nickname_of) const_names
+ val would_be_genuine = got_all_user_axioms andalso none_true wfs
+(*
+ val _ = List.app (priority o string_for_nut ctxt)
+ (core_u :: def_us @ nondef_us)
+*)
+ val need_incremental = Int.max (max_potential, max_genuine) >= 2
+ val effective_sat_solver =
+ if sat_solver <> "smart" then
+ if need_incremental andalso
+ not (sat_solver mem KodkodSAT.configured_sat_solvers true) then
+ (print_m (K ("An incremental SAT solver is required: \"SAT4J\" will \
+ \be used instead of " ^ quote sat_solver ^ "."));
+ "SAT4J")
+ else
+ sat_solver
+ else
+ KodkodSAT.smart_sat_solver_name need_incremental
+ val _ =
+ if sat_solver = "smart" then
+ print_v (fn () => "Using SAT solver " ^ quote effective_sat_solver ^
+ ". The following" ^
+ (if need_incremental then " incremental " else " ") ^
+ "solvers are configured: " ^
+ commas (map quote (KodkodSAT.configured_sat_solvers
+ need_incremental)) ^ ".")
+ else
+ ()
+
+ val too_big_scopes = Unsynchronized.ref []
+
+ (* bool -> scope -> rich_problem option *)
+ fun problem_for_scope liberal
+ (scope as {card_assigns, bisim_depth, datatypes, ofs, ...}) =
+ let
+ val _ = not (exists (fn other => scope_less_eq other scope)
+ (!too_big_scopes))
+ orelse raise LIMIT ("Nitpick.pick_them_nits_in_term.\
+ \problem_for_scope", "too big scope")
+(*
+ val _ = priority "Offsets:"
+ val _ = List.app (fn (T, j0) =>
+ priority (string_for_type ctxt T ^ " = " ^
+ string_of_int j0))
+ (Typtab.dest ofs)
+*)
+ val all_precise = forall (is_precise_type datatypes) Ts
+ (* nut list -> rep NameTable.table -> nut list * rep NameTable.table *)
+ val repify_consts = choose_reps_for_consts scope all_precise
+ val main_j0 = offset_of_type ofs bool_T
+ val (nat_card, nat_j0) = spec_of_type scope nat_T
+ val (int_card, int_j0) = spec_of_type scope int_T
+ val _ = forall (equal main_j0) [nat_j0, int_j0]
+ orelse raise BAD ("Nitpick.pick_them_nits_in_term.\
+ \problem_for_scope", "bad offsets")
+ val kk = kodkod_constrs peephole_optim nat_card int_card main_j0
+ val (free_names, rep_table) =
+ choose_reps_for_free_vars scope free_names NameTable.empty
+ val (sel_names, rep_table) = choose_reps_for_all_sels scope rep_table
+ val (nonsel_names, rep_table) = repify_consts nonsel_names rep_table
+ val min_highest_arity =
+ NameTable.fold (curry Int.max o arity_of_rep o snd) rep_table 1
+ val min_univ_card =
+ NameTable.fold (curry Int.max o min_univ_card_of_rep o snd) rep_table
+ (univ_card nat_card int_card main_j0 [] Kodkod.True)
+ val _ = check_arity min_univ_card min_highest_arity
+
+ val core_u = choose_reps_in_nut scope liberal rep_table false core_u
+ val def_us = map (choose_reps_in_nut scope liberal rep_table true)
+ def_us
+ val nondef_us = map (choose_reps_in_nut scope liberal rep_table false)
+ nondef_us
+(*
+ val _ = List.app (priority o string_for_nut ctxt)
+ (free_names @ sel_names @ nonsel_names @
+ core_u :: def_us @ nondef_us)
+*)
+ val (free_rels, pool, rel_table) =
+ rename_free_vars free_names initial_pool NameTable.empty
+ val (sel_rels, pool, rel_table) =
+ rename_free_vars sel_names pool rel_table
+ val (other_rels, pool, rel_table) =
+ rename_free_vars nonsel_names pool rel_table
+ val core_u = rename_vars_in_nut pool rel_table core_u
+ val def_us = map (rename_vars_in_nut pool rel_table) def_us
+ val nondef_us = map (rename_vars_in_nut pool rel_table) nondef_us
+ (* nut -> Kodkod.formula *)
+ val to_f = kodkod_formula_from_nut ofs liberal kk
+ val core_f = to_f core_u
+ val def_fs = map to_f def_us
+ val nondef_fs = map to_f nondef_us
+ val formula = fold (fold s_and) [def_fs, nondef_fs] core_f
+ val comment = (if liberal then "liberal" else "conservative") ^ "\n" ^
+ PrintMode.setmp [] multiline_string_for_scope scope
+ val kodkod_sat_solver = KodkodSAT.sat_solver_spec effective_sat_solver
+ |> snd
+ val delay = if liberal then
+ Option.map (fn time => Time.- (time, Time.now ()))
+ deadline
+ |> liberal_delay_for_timeout
+ else
+ 0
+ val settings = [("solver", commas (map quote kodkod_sat_solver)),
+ ("skolem_depth", "-1"),
+ ("bit_width", "16"),
+ ("symmetry_breaking", signed_string_of_int sym_break),
+ ("sharing", signed_string_of_int sharing_depth),
+ ("flatten", Bool.toString flatten_props),
+ ("delay", signed_string_of_int delay)]
+ val plain_rels = free_rels @ other_rels
+ val plain_bounds = map (bound_for_plain_rel ctxt debug) plain_rels
+ val plain_axioms = map (declarative_axiom_for_plain_rel kk) plain_rels
+ val sel_bounds = map (bound_for_sel_rel ctxt debug datatypes) sel_rels
+ val dtype_axioms = declarative_axioms_for_datatypes ext_ctxt ofs kk
+ rel_table datatypes
+ val declarative_axioms = plain_axioms @ dtype_axioms
+ val univ_card = univ_card nat_card int_card main_j0
+ (plain_bounds @ sel_bounds) formula
+ val built_in_bounds = bounds_for_built_in_rels_in_formula debug
+ univ_card nat_card int_card main_j0 formula
+ val bounds = built_in_bounds @ plain_bounds @ sel_bounds
+ |> not debug ? merge_bounds
+ val highest_arity =
+ fold Integer.max (map (fst o fst) (maps fst bounds)) 0
+ val formula = fold_rev s_and declarative_axioms formula
+ val _ = if formula = Kodkod.False then ()
+ else check_arity univ_card highest_arity
+ in
+ SOME ({comment = comment, settings = settings, univ_card = univ_card,
+ tuple_assigns = [], bounds = bounds,
+ int_bounds = sequential_int_bounds univ_card,
+ expr_assigns = [], formula = formula},
+ {free_names = free_names, sel_names = sel_names,
+ nonsel_names = nonsel_names, rel_table = rel_table,
+ liberal = liberal, scope = scope, core = core_f,
+ defs = nondef_fs @ def_fs @ declarative_axioms})
+ end
+ handle LIMIT (loc, msg) =>
+ if loc = "NitpickKodkod.check_arity"
+ andalso not (Typtab.is_empty ofs) then
+ problem_for_scope liberal
+ {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
+ bisim_depth = bisim_depth, datatypes = datatypes,
+ ofs = Typtab.empty}
+ else if loc = "Nitpick.pick_them_nits_in_term.\
+ \problem_for_scope" then
+ NONE
+ else
+ (Unsynchronized.change too_big_scopes (cons scope);
+ print_v (fn () => ("Limit reached: " ^ msg ^
+ ". Dropping " ^ (if liberal then "potential"
+ else "genuine") ^
+ " component of scope."));
+ NONE)
+
+ (* int -> (''a * int list list) list -> ''a -> Kodkod.tuple_set *)
+ fun tuple_set_for_rel univ_card =
+ Kodkod.TupleSet o map (kk_tuple debug univ_card) o the
+ oo AList.lookup (op =)
+
+ val word_model = if falsify then "counterexample" else "model"
+
+ val scopes = Unsynchronized.ref []
+ val generated_scopes = Unsynchronized.ref []
+ val generated_problems = Unsynchronized.ref []
+ val checked_problems = Unsynchronized.ref (SOME [])
+ val met_potential = Unsynchronized.ref 0
+
+ (* rich_problem list -> int list -> unit *)
+ fun update_checked_problems problems =
+ List.app (Unsynchronized.change checked_problems o Option.map o cons
+ o nth problems)
+
+ (* bool -> Kodkod.raw_bound list -> problem_extension -> bool option *)
+ fun print_and_check_model genuine bounds
+ ({free_names, sel_names, nonsel_names, rel_table, scope, ...}
+ : problem_extension) =
+ let
+ val (reconstructed_model, codatatypes_ok) =
+ reconstruct_hol_model {show_skolems = show_skolems,
+ show_datatypes = show_datatypes,
+ show_consts = show_consts}
+ scope formats frees free_names sel_names nonsel_names rel_table
+ bounds
+ val would_be_genuine = would_be_genuine andalso codatatypes_ok
+ in
+ pprint (Pretty.chunks
+ [Pretty.blk (0,
+ (pstrs ("Nitpick found a" ^
+ (if not genuine then " potential "
+ else if would_be_genuine then " "
+ else " likely genuine ") ^ word_model) @
+ (case pretties_for_scope scope verbose of
+ [] => []
+ | pretties => pstrs " for " @ pretties) @
+ [Pretty.str ":\n"])),
+ Pretty.indent indent_size reconstructed_model]);
+ if genuine then
+ (if check_genuine then
+ (case prove_hol_model scope tac_timeout free_names sel_names
+ rel_table bounds assms_t of
+ SOME true => print ("Confirmation by \"auto\": The above " ^
+ word_model ^ " is really genuine.")
+ | SOME false =>
+ if would_be_genuine then
+ error ("A supposedly genuine " ^ word_model ^ " was shown to\
+ \be spurious by \"auto\".\nThis should never happen.\n\
+ \Please send a bug report to blanchet\
+ \te@in.tum.de.")
+ else
+ print ("Refutation by \"auto\": The above " ^ word_model ^
+ " is spurious.")
+ | NONE => print "No confirmation by \"auto\".")
+ else
+ ();
+ if has_weaselly_sorts thy orig_t then
+ print "Hint: Maybe you forgot a type constraint?"
+ else
+ ();
+ if not would_be_genuine then
+ if no_poly_user_axioms then
+ let
+ val options =
+ [] |> not got_all_mono_user_axioms
+ ? cons ("user_axioms", "\"true\"")
+ |> not (none_true wfs)
+ ? cons ("wf", "\"smart\" or \"false\"")
+ |> not codatatypes_ok
+ ? cons ("bisim_depth", "a nonnegative value")
+ val ss =
+ map (fn (name, value) => quote name ^ " set to " ^ value)
+ options
+ in
+ print ("Try again with " ^
+ space_implode " " (serial_commas "and" ss) ^
+ " to confirm that the " ^ word_model ^ " is genuine.")
+ end
+ else
+ print ("Nitpick is unable to guarantee the authenticity of \
+ \the " ^ word_model ^ " in the presence of polymorphic \
+ \axioms.")
+ else
+ ();
+ NONE)
+ else
+ if not genuine then
+ (Unsynchronized.inc met_potential;
+ if check_potential then
+ let
+ val status = prove_hol_model scope tac_timeout free_names
+ sel_names rel_table bounds assms_t
+ in
+ (case status of
+ SOME true => print ("Confirmation by \"auto\": The above " ^
+ word_model ^ " is genuine.")
+ | SOME false => print ("Refutation by \"auto\": The above " ^
+ word_model ^ " is spurious.")
+ | NONE => print "No confirmation by \"auto\".");
+ status
+ end
+ else
+ NONE)
+ else
+ NONE
+ end
+ (* int -> int -> int -> bool -> rich_problem list -> int * int * int *)
+ fun solve_any_problem max_potential max_genuine donno first_time problems =
+ let
+ val max_potential = Int.max (0, max_potential)
+ val max_genuine = Int.max (0, max_genuine)
+ (* bool -> int * Kodkod.raw_bound list -> bool option *)
+ fun print_and_check genuine (j, bounds) =
+ print_and_check_model genuine bounds (snd (nth problems j))
+ val max_solutions = max_potential + max_genuine
+ |> not need_incremental ? curry Int.min 1
+ in
+ if max_solutions <= 0 then
+ (0, 0, donno)
+ else
+ case Kodkod.solve_any_problem overlord deadline max_threads
+ max_solutions (map fst problems) of
+ Kodkod.Normal ([], unsat_js) =>
+ (update_checked_problems problems unsat_js;
+ (max_potential, max_genuine, donno))
+ | Kodkod.Normal (sat_ps, unsat_js) =>
+ let
+ val (lib_ps, con_ps) =
+ List.partition (#liberal o snd o nth problems o fst) sat_ps
+ in
+ update_checked_problems problems (unsat_js @ map fst lib_ps);
+ if null con_ps then
+ let
+ val num_genuine = Library.take (max_potential, lib_ps)
+ |> map (print_and_check false)
+ |> filter (equal (SOME true)) |> length
+ val max_genuine = max_genuine - num_genuine
+ val max_potential = max_potential
+ - (length lib_ps - num_genuine)
+ in
+ if max_genuine <= 0 then
+ (0, 0, donno)
+ else
+ let
+ (* "co_js" is the list of conservative problems whose
+ liberal pendants couldn't be satisfied and hence that
+ most probably can't be satisfied themselves. *)
+ val co_js =
+ map (fn j => j - 1) unsat_js
+ |> filter (fn j =>
+ j >= 0 andalso
+ scopes_equivalent
+ (#scope (snd (nth problems j)))
+ (#scope (snd (nth problems (j + 1)))))
+ val bye_js = sort_distinct int_ord (map fst sat_ps @
+ unsat_js @ co_js)
+ val problems =
+ problems |> filter_out_indices bye_js
+ |> max_potential <= 0
+ ? filter_out (#liberal o snd)
+ in
+ solve_any_problem max_potential max_genuine donno false
+ problems
+ end
+ end
+ else
+ let
+ val _ = Library.take (max_genuine, con_ps)
+ |> List.app (ignore o print_and_check true)
+ val max_genuine = max_genuine - length con_ps
+ in
+ if max_genuine <= 0 orelse not first_time then
+ (0, max_genuine, donno)
+ else
+ let
+ val bye_js = sort_distinct int_ord
+ (map fst sat_ps @ unsat_js)
+ val problems =
+ problems |> filter_out_indices bye_js
+ |> filter_out (#liberal o snd)
+ in solve_any_problem 0 max_genuine donno false problems end
+ end
+ end
+ | Kodkod.TimedOut unsat_js =>
+ (update_checked_problems problems unsat_js; raise TimeLimit.TimeOut)
+ | Kodkod.Interrupted NONE =>
+ (checked_problems := NONE; do_interrupted ())
+ | Kodkod.Interrupted (SOME unsat_js) =>
+ (update_checked_problems problems unsat_js; do_interrupted ())
+ | Kodkod.Error (s, unsat_js) =>
+ (update_checked_problems problems unsat_js;
+ print_v (K ("Kodkod error: " ^ s ^ "."));
+ (max_potential, max_genuine, donno + 1))
+ end
+
+ (* int -> int -> scope list -> int * int * int -> int * int * int *)
+ fun run_batch j n scopes (max_potential, max_genuine, donno) =
+ let
+ val _ =
+ if null scopes then
+ print_m (K "The scope specification is inconsistent.")
+ else if verbose then
+ pprint (Pretty.chunks
+ [Pretty.blk (0,
+ pstrs ((if n > 1 then
+ "Batch " ^ string_of_int (j + 1) ^ " of " ^
+ signed_string_of_int n ^ ": "
+ else
+ "") ^
+ "Trying " ^ string_of_int (length scopes) ^
+ " scope" ^ plural_s_for_list scopes ^ ":")),
+ Pretty.indent indent_size
+ (Pretty.chunks (map2
+ (fn j => fn scope =>
+ Pretty.block (
+ (case pretties_for_scope scope true of
+ [] => [Pretty.str "Empty"]
+ | pretties => pretties) @
+ [Pretty.str (if j = 1 then "." else ";")]))
+ (length scopes downto 1) scopes))])
+ else
+ ()
+ (* scope * bool -> rich_problem list * bool
+ -> rich_problem list * bool *)
+ fun add_problem_for_scope (scope as {datatypes, ...}, liberal)
+ (problems, donno) =
+ (check_deadline ();
+ case problem_for_scope liberal scope of
+ SOME problem =>
+ (problems
+ |> (null problems orelse
+ not (Kodkod.problems_equivalent (fst problem)
+ (fst (hd problems))))
+ ? cons problem, donno)
+ | NONE => (problems, donno + 1))
+ val (problems, donno) =
+ fold add_problem_for_scope
+ (map_product pair scopes
+ ((if max_genuine > 0 then [false] else []) @
+ (if max_potential > 0 then [true] else [])))
+ ([], donno)
+ val _ = Unsynchronized.change generated_problems (append problems)
+ val _ = Unsynchronized.change generated_scopes (append scopes)
+ in
+ solve_any_problem max_potential max_genuine donno true (rev problems)
+ end
+
+ (* rich_problem list -> scope -> int *)
+ fun scope_count (problems : rich_problem list) scope =
+ length (filter (scopes_equivalent scope o #scope o snd) problems)
+ (* string -> string *)
+ fun excipit did_so_and_so =
+ let
+ (* rich_problem list -> rich_problem list *)
+ val do_filter =
+ if !met_potential = max_potential then filter_out (#liberal o snd)
+ else I
+ val total = length (!scopes)
+ val unsat =
+ fold (fn scope =>
+ case scope_count (do_filter (!generated_problems)) scope of
+ 0 => I
+ | n =>
+ if scope_count (do_filter (these (!checked_problems)))
+ scope = n then
+ Integer.add 1
+ else
+ I) (!generated_scopes) 0
+ in
+ "Nitpick " ^ did_so_and_so ^
+ (if is_some (!checked_problems) andalso total > 0 then
+ " after checking " ^
+ string_of_int (Int.min (total - 1, unsat)) ^ " of " ^
+ string_of_int total ^ " scope" ^ plural_s total
+ else
+ "") ^ "."
+ end
+
+ (* int -> int -> scope list -> int * int * int -> Kodkod.outcome *)
+ fun run_batches _ _ [] (max_potential, max_genuine, donno) =
+ if donno > 0 andalso max_genuine > 0 then
+ (print_m (fn () => excipit "ran out of resources"); "unknown")
+ else if max_genuine = original_max_genuine then
+ if max_potential = original_max_potential then
+ (print_m (K ("Nitpick found no " ^ word_model ^ ".")); "none")
+ else
+ (print_m (K ("Nitpick could not find " ^
+ (if max_genuine = 1 then "a better " ^ word_model ^ "."
+ else "any better " ^ word_model ^ "s.")));
+ "potential")
+ else
+ if would_be_genuine then "genuine" else "likely_genuine"
+ | run_batches j n (batch :: batches) z =
+ let val (z as (_, max_genuine, _)) = run_batch j n batch z in
+ run_batches (j + 1) n (if max_genuine > 0 then batches else []) z
+ end
+
+ val _ = scopes := all_scopes ext_ctxt sym_break cards_assigns maxes_assigns
+ iters_assigns bisim_depths mono_Ts nonmono_Ts
+ val batches = batch_list batch_size (!scopes)
+ val outcome_code =
+ (run_batches 0 (length batches) batches (max_potential, max_genuine, 0)
+ handle Exn.Interrupt => do_interrupted ())
+ handle TimeLimit.TimeOut =>
+ (print_m (fn () => excipit "ran out of time");
+ if !met_potential > 0 then "potential" else "unknown")
+ | Exn.Interrupt => if auto orelse debug then raise Interrupt
+ else error (excipit "was interrupted")
+ val _ = print_v (fn () => "Total time: " ^
+ signed_string_of_int (Time.toMilliseconds
+ (Timer.checkRealTimer timer)) ^ " ms.")
+ in (outcome_code, !state_ref) end
+ handle Exn.Interrupt =>
+ if auto orelse #debug params then
+ raise Interrupt
+ else
+ if passed_deadline deadline then
+ (priority "Nitpick ran out of time."; ("unknown", state))
+ else
+ error "Nitpick was interrupted."
+
+(* Proof.state -> params -> bool -> term -> string * Proof.state *)
+fun pick_nits_in_term state (params as {debug, timeout, expect, ...})
+ auto orig_assm_ts orig_t =
+ let
+ val deadline = Option.map (curry Time.+ (Time.now ())) timeout
+ val outcome as (outcome_code, _) =
+ time_limit (if debug then NONE else timeout)
+ (pick_them_nits_in_term deadline state params auto orig_assm_ts)
+ orig_t
+ in
+ if expect = "" orelse outcome_code = expect then outcome
+ else error ("Unexpected outcome: " ^ quote outcome_code ^ ".")
+ end
+
+(* Proof.state -> params -> thm -> int -> string * Proof.state *)
+fun pick_nits_in_subgoal state params auto subgoal =
+ let
+ val ctxt = Proof.context_of state
+ val t = state |> Proof.get_goal |> snd |> snd |> prop_of
+ in
+ if Logic.count_prems t = 0 then
+ (priority "No subgoal!"; ("none", state))
+ else
+ let
+ val assms = map term_of (Assumption.all_assms_of ctxt)
+ val (t, frees) = Logic.goal_params t subgoal
+ in pick_nits_in_term state params auto assms (subst_bounds (frees, t)) end
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,3328 @@
+(* Title: HOL/Nitpick/Tools/nitpick_hol.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Auxiliary HOL-related functions used by Nitpick.
+*)
+
+signature NITPICK_HOL =
+sig
+ type const_table = term list Symtab.table
+ type special_fun = (styp * int list * term list) * styp
+ type unrolled = styp * styp
+ type wf_cache = (styp * (bool * bool)) list
+
+ type extended_context = {
+ thy: theory,
+ ctxt: Proof.context,
+ max_bisim_depth: int,
+ boxes: (typ option * bool option) list,
+ wfs: (styp option * bool option) list,
+ user_axioms: bool option,
+ debug: bool,
+ destroy_constrs: bool,
+ specialize: bool,
+ skolemize: bool,
+ star_linear_preds: bool,
+ uncurry: bool,
+ fast_descrs: bool,
+ tac_timeout: Time.time option,
+ evals: term list,
+ case_names: (string * int) list,
+ def_table: const_table,
+ nondef_table: const_table,
+ user_nondefs: term list,
+ simp_table: const_table Unsynchronized.ref,
+ psimp_table: const_table,
+ intro_table: const_table,
+ ground_thm_table: term list Inttab.table,
+ ersatz_table: (string * string) list,
+ skolems: (string * string list) list Unsynchronized.ref,
+ special_funs: special_fun list Unsynchronized.ref,
+ unrolled_preds: unrolled list Unsynchronized.ref,
+ wf_cache: wf_cache Unsynchronized.ref}
+
+ val name_sep : string
+ val numeral_prefix : string
+ val skolem_prefix : string
+ val eval_prefix : string
+ val original_name : string -> string
+ val unbox_type : typ -> typ
+ val string_for_type : Proof.context -> typ -> string
+ val prefix_name : string -> string -> string
+ val short_name : string -> string
+ val short_const_name : string -> string
+ val shorten_const_names_in_term : term -> term
+ val type_match : theory -> typ * typ -> bool
+ val const_match : theory -> styp * styp -> bool
+ val term_match : theory -> term * term -> bool
+ val is_TFree : typ -> bool
+ val is_higher_order_type : typ -> bool
+ val is_fun_type : typ -> bool
+ val is_set_type : typ -> bool
+ val is_pair_type : typ -> bool
+ val is_lfp_iterator_type : typ -> bool
+ val is_gfp_iterator_type : typ -> bool
+ val is_fp_iterator_type : typ -> bool
+ val is_boolean_type : typ -> bool
+ val is_integer_type : typ -> bool
+ val is_record_type : typ -> bool
+ val is_number_type : theory -> typ -> bool
+ val const_for_iterator_type : typ -> styp
+ val nth_range_type : int -> typ -> typ
+ val num_factors_in_type : typ -> int
+ val num_binder_types : typ -> int
+ val curried_binder_types : typ -> typ list
+ val mk_flat_tuple : typ -> term list -> term
+ val dest_n_tuple : int -> term -> term list
+ val instantiate_type : theory -> typ -> typ -> typ -> typ
+ val is_codatatype : theory -> typ -> bool
+ val is_pure_typedef : theory -> typ -> bool
+ val is_univ_typedef : theory -> typ -> bool
+ val is_datatype : theory -> typ -> bool
+ val is_record_constr : styp -> bool
+ val is_record_get : theory -> styp -> bool
+ val is_record_update : theory -> styp -> bool
+ val is_abs_fun : theory -> styp -> bool
+ val is_rep_fun : theory -> styp -> bool
+ val is_constr : theory -> styp -> bool
+ val is_sel : string -> bool
+ val discr_for_constr : styp -> styp
+ val num_sels_for_constr_type : typ -> int
+ val nth_sel_name_for_constr_name : string -> int -> string
+ val nth_sel_for_constr : styp -> int -> styp
+ val boxed_nth_sel_for_constr : extended_context -> styp -> int -> styp
+ val sel_no_from_name : string -> int
+ val eta_expand : typ list -> term -> int -> term
+ val extensionalize : term -> term
+ val distinctness_formula : typ -> term list -> term
+ val register_frac_type : string -> (string * string) list -> theory -> theory
+ val unregister_frac_type : string -> theory -> theory
+ val register_codatatype : typ -> string -> styp list -> theory -> theory
+ val unregister_codatatype : typ -> theory -> theory
+ val datatype_constrs : theory -> typ -> styp list
+ val boxed_datatype_constrs : extended_context -> typ -> styp list
+ val num_datatype_constrs : theory -> typ -> int
+ val constr_name_for_sel_like : string -> string
+ val boxed_constr_for_sel : extended_context -> styp -> styp
+ val card_of_type : (typ * int) list -> typ -> int
+ val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
+ val bounded_precise_card_of_type :
+ theory -> int -> int -> (typ * int) list -> typ -> int
+ val is_finite_type : theory -> typ -> bool
+ val all_axioms_of : theory -> term list * term list * term list
+ val arity_of_built_in_const : bool -> styp -> int option
+ val is_built_in_const : bool -> styp -> bool
+ val case_const_names : theory -> (string * int) list
+ val const_def_table : Proof.context -> term list -> const_table
+ val const_nondef_table : term list -> const_table
+ val const_simp_table : Proof.context -> const_table
+ val const_psimp_table : Proof.context -> const_table
+ val inductive_intro_table : Proof.context -> const_table -> const_table
+ val ground_theorem_table : theory -> term list Inttab.table
+ val ersatz_table : theory -> (string * string) list
+ val def_of_const : theory -> const_table -> styp -> term option
+ val is_inductive_pred : extended_context -> styp -> bool
+ val is_constr_pattern_lhs : theory -> term -> bool
+ val is_constr_pattern_formula : theory -> term -> bool
+ val coalesce_type_vars_in_terms : term list -> term list
+ val ground_types_in_type : extended_context -> typ -> typ list
+ val ground_types_in_terms : extended_context -> term list -> typ list
+ val format_type : int list -> int list -> typ -> typ
+ val format_term_type :
+ theory -> const_table -> (term option * int list) list -> term -> typ
+ val user_friendly_const :
+ extended_context -> string * string -> (term option * int list) list
+ -> styp -> term * typ
+ val assign_operator_for_const : styp -> string
+ val preprocess_term :
+ extended_context -> term -> ((term list * term list) * (bool * bool)) * term
+end;
+
+structure NitpickHOL : NITPICK_HOL =
+struct
+
+open NitpickUtil
+
+type const_table = term list Symtab.table
+type special_fun = (styp * int list * term list) * styp
+type unrolled = styp * styp
+type wf_cache = (styp * (bool * bool)) list
+
+type extended_context = {
+ thy: theory,
+ ctxt: Proof.context,
+ max_bisim_depth: int,
+ boxes: (typ option * bool option) list,
+ wfs: (styp option * bool option) list,
+ user_axioms: bool option,
+ debug: bool,
+ destroy_constrs: bool,
+ specialize: bool,
+ skolemize: bool,
+ star_linear_preds: bool,
+ uncurry: bool,
+ fast_descrs: bool,
+ tac_timeout: Time.time option,
+ evals: term list,
+ case_names: (string * int) list,
+ def_table: const_table,
+ nondef_table: const_table,
+ user_nondefs: term list,
+ simp_table: const_table Unsynchronized.ref,
+ psimp_table: const_table,
+ intro_table: const_table,
+ ground_thm_table: term list Inttab.table,
+ ersatz_table: (string * string) list,
+ skolems: (string * string list) list Unsynchronized.ref,
+ special_funs: special_fun list Unsynchronized.ref,
+ unrolled_preds: unrolled list Unsynchronized.ref,
+ wf_cache: wf_cache Unsynchronized.ref}
+
+structure TheoryData = TheoryDataFun(
+ type T = {frac_types: (string * (string * string) list) list,
+ codatatypes: (string * (string * styp list)) list}
+ val empty = {frac_types = [], codatatypes = []}
+ val copy = I
+ val extend = I
+ fun merge _ ({frac_types = fs1, codatatypes = cs1},
+ {frac_types = fs2, codatatypes = cs2}) =
+ {frac_types = AList.merge (op =) (op =) (fs1, fs2),
+ codatatypes = AList.merge (op =) (op =) (cs1, cs2)})
+
+(* term * term -> term *)
+fun s_conj (t1, @{const True}) = t1
+ | s_conj (@{const True}, t2) = t2
+ | s_conj (t1, t2) = if @{const False} mem [t1, t2] then @{const False}
+ else HOLogic.mk_conj (t1, t2)
+fun s_disj (t1, @{const False}) = t1
+ | s_disj (@{const False}, t2) = t2
+ | s_disj (t1, t2) = if @{const True} mem [t1, t2] then @{const True}
+ else HOLogic.mk_disj (t1, t2)
+(* term -> term -> term *)
+fun mk_exists v t =
+ HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
+
+(* term -> term -> term list *)
+fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
+ if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t]
+ | strip_connective _ t = [t]
+(* term -> term list * term *)
+fun strip_any_connective (t as (t0 $ t1 $ t2)) =
+ if t0 mem [@{const "op &"}, @{const "op |"}] then
+ (strip_connective t0 t, t0)
+ else
+ ([t], @{const Not})
+ | strip_any_connective t = ([t], @{const Not})
+(* term -> term list *)
+val conjuncts = strip_connective @{const "op &"}
+val disjuncts = strip_connective @{const "op |"}
+
+val name_sep = "$"
+val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep
+val sel_prefix = nitpick_prefix ^ "sel"
+val discr_prefix = nitpick_prefix ^ "is" ^ name_sep
+val set_prefix = nitpick_prefix ^ "set" ^ name_sep
+val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep
+val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep
+val nwf_prefix = nitpick_prefix ^ "nwf" ^ name_sep
+val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep
+val base_prefix = nitpick_prefix ^ "base" ^ name_sep
+val step_prefix = nitpick_prefix ^ "step" ^ name_sep
+val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep
+val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep
+val skolem_prefix = nitpick_prefix ^ "sk"
+val special_prefix = nitpick_prefix ^ "sp"
+val uncurry_prefix = nitpick_prefix ^ "unc"
+val eval_prefix = nitpick_prefix ^ "eval"
+val bound_var_prefix = "b"
+val cong_var_prefix = "c"
+val iter_var_prefix = "i"
+val val_var_prefix = nitpick_prefix ^ "v"
+val arg_var_prefix = "x"
+
+(* int -> string *)
+fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
+fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
+(* int -> int -> string *)
+fun skolem_prefix_for k j =
+ skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+fun uncurry_prefix_for k j =
+ uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+
+(* string -> string * string *)
+val strip_first_name_sep =
+ Substring.full #> Substring.position name_sep ##> Substring.triml 1
+ #> pairself Substring.string
+(* string -> string *)
+fun original_name s =
+ if String.isPrefix nitpick_prefix s then
+ case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2
+ else
+ s
+val after_name_sep = snd o strip_first_name_sep
+
+(* When you add constants to these lists, make sure to handle them in
+ "NitpickNut.nut_from_term", and perhaps in "NitpickMono.consider_term" as
+ well. *)
+val built_in_consts =
+ [(@{const_name all}, 1),
+ (@{const_name "=="}, 2),
+ (@{const_name "==>"}, 2),
+ (@{const_name Pure.conjunction}, 2),
+ (@{const_name Trueprop}, 1),
+ (@{const_name Not}, 1),
+ (@{const_name False}, 0),
+ (@{const_name True}, 0),
+ (@{const_name All}, 1),
+ (@{const_name Ex}, 1),
+ (@{const_name "op ="}, 2),
+ (@{const_name "op &"}, 2),
+ (@{const_name "op |"}, 2),
+ (@{const_name "op -->"}, 2),
+ (@{const_name If}, 3),
+ (@{const_name Let}, 2),
+ (@{const_name Unity}, 0),
+ (@{const_name Pair}, 2),
+ (@{const_name fst}, 1),
+ (@{const_name snd}, 1),
+ (@{const_name Id}, 0),
+ (@{const_name insert}, 2),
+ (@{const_name converse}, 1),
+ (@{const_name trancl}, 1),
+ (@{const_name rel_comp}, 2),
+ (@{const_name image}, 2),
+ (@{const_name Suc}, 0),
+ (@{const_name finite}, 1),
+ (@{const_name nat}, 0),
+ (@{const_name zero_nat_inst.zero_nat}, 0),
+ (@{const_name one_nat_inst.one_nat}, 0),
+ (@{const_name plus_nat_inst.plus_nat}, 0),
+ (@{const_name minus_nat_inst.minus_nat}, 0),
+ (@{const_name times_nat_inst.times_nat}, 0),
+ (@{const_name div_nat_inst.div_nat}, 0),
+ (@{const_name div_nat_inst.mod_nat}, 0),
+ (@{const_name ord_nat_inst.less_nat}, 2),
+ (@{const_name ord_nat_inst.less_eq_nat}, 2),
+ (@{const_name nat_gcd}, 0),
+ (@{const_name nat_lcm}, 0),
+ (@{const_name zero_int_inst.zero_int}, 0),
+ (@{const_name one_int_inst.one_int}, 0),
+ (@{const_name plus_int_inst.plus_int}, 0),
+ (@{const_name minus_int_inst.minus_int}, 0),
+ (@{const_name times_int_inst.times_int}, 0),
+ (@{const_name div_int_inst.div_int}, 0),
+ (@{const_name div_int_inst.mod_int}, 0),
+ (@{const_name uminus_int_inst.uminus_int}, 0), (* FIXME: needed? *)
+ (@{const_name ord_int_inst.less_int}, 2),
+ (@{const_name ord_int_inst.less_eq_int}, 2),
+ (@{const_name Tha}, 1),
+ (@{const_name Frac}, 0),
+ (@{const_name norm_frac}, 0)]
+val built_in_descr_consts =
+ [(@{const_name The}, 1),
+ (@{const_name Eps}, 1)]
+val built_in_typed_consts =
+ [((@{const_name of_nat}, nat_T --> int_T), 0)]
+val built_in_set_consts =
+ [(@{const_name lower_semilattice_fun_inst.inf_fun}, 2),
+ (@{const_name upper_semilattice_fun_inst.sup_fun}, 2),
+ (@{const_name minus_fun_inst.minus_fun}, 2),
+ (@{const_name ord_fun_inst.less_eq_fun}, 2)]
+
+(* typ -> typ *)
+fun unbox_type (Type (@{type_name fun_box}, Ts)) =
+ Type ("fun", map unbox_type Ts)
+ | unbox_type (Type (@{type_name pair_box}, Ts)) =
+ Type ("*", map unbox_type Ts)
+ | unbox_type (Type (s, Ts)) = Type (s, map unbox_type Ts)
+ | unbox_type T = T
+(* Proof.context -> typ -> string *)
+fun string_for_type ctxt = Syntax.string_of_typ ctxt o unbox_type
+
+(* string -> string -> string *)
+val prefix_name = Long_Name.qualify o Long_Name.base_name
+(* string -> string *)
+fun short_name s = List.last (space_explode "." s) handle List.Empty => ""
+(* string -> term -> term *)
+val prefix_abs_vars = Term.map_abs_vars o prefix_name
+(* term -> term *)
+val shorten_abs_vars = Term.map_abs_vars short_name
+(* string -> string *)
+fun short_const_name s =
+ case space_explode name_sep s of
+ [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix
+ | ss => map short_name ss |> space_implode "_"
+(* term -> term *)
+val shorten_const_names_in_term =
+ map_aterms (fn Const (s, T) => Const (short_const_name s, T) | t => t)
+
+(* theory -> typ * typ -> bool *)
+fun type_match thy (T1, T2) =
+ (Sign.typ_match thy (T2, T1) Vartab.empty; true)
+ handle Type.TYPE_MATCH => false
+(* theory -> styp * styp -> bool *)
+fun const_match thy ((s1, T1), (s2, T2)) =
+ s1 = s2 andalso type_match thy (T1, T2)
+(* theory -> term * term -> bool *)
+fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2)
+ | term_match thy (Free (s1, T1), Free (s2, T2)) =
+ const_match thy ((short_name s1, T1), (short_name s2, T2))
+ | term_match thy (t1, t2) = t1 aconv t2
+
+(* typ -> bool *)
+fun is_TFree (TFree _) = true
+ | is_TFree _ = false
+fun is_higher_order_type (Type ("fun", _)) = true
+ | is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts
+ | is_higher_order_type _ = false
+fun is_fun_type (Type ("fun", _)) = true
+ | is_fun_type _ = false
+fun is_set_type (Type ("fun", [_, @{typ bool}])) = true
+ | is_set_type _ = false
+fun is_pair_type (Type ("*", _)) = true
+ | is_pair_type _ = false
+fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s
+ | is_lfp_iterator_type _ = false
+fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s
+ | is_gfp_iterator_type _ = false
+val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type
+val is_boolean_type = equal prop_T orf equal bool_T
+val is_integer_type =
+ member (op =) [nat_T, int_T, @{typ bisim_iterator}] orf is_fp_iterator_type
+val is_record_type = not o null o Record.dest_recTs
+(* theory -> typ -> bool *)
+fun is_frac_type thy (Type (s, [])) =
+ not (null (these (AList.lookup (op =) (#frac_types (TheoryData.get thy))
+ s)))
+ | is_frac_type _ _ = false
+fun is_number_type thy = is_integer_type orf is_frac_type thy
+
+(* bool -> styp -> typ *)
+fun iterator_type_for_const gfp (s, T) =
+ Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s,
+ binder_types T)
+(* typ -> styp *)
+fun const_for_iterator_type (Type (s, Ts)) = (after_name_sep s, Ts ---> bool_T)
+ | const_for_iterator_type T =
+ raise TYPE ("NitpickHOL.const_for_iterator_type", [T], [])
+
+(* int -> typ -> typ * typ *)
+fun strip_n_binders 0 T = ([], T)
+ | strip_n_binders n (Type ("fun", [T1, T2])) =
+ strip_n_binders (n - 1) T2 |>> cons T1
+ | strip_n_binders n (Type (@{type_name fun_box}, Ts)) =
+ strip_n_binders n (Type ("fun", Ts))
+ | strip_n_binders _ T = raise TYPE ("NitpickHOL.strip_n_binders", [T], [])
+(* typ -> typ *)
+val nth_range_type = snd oo strip_n_binders
+
+(* typ -> int *)
+fun num_factors_in_type (Type ("*", [T1, T2])) =
+ fold (Integer.add o num_factors_in_type) [T1, T2] 0
+ | num_factors_in_type _ = 1
+fun num_binder_types (Type ("fun", [_, T2])) = 1 + num_binder_types T2
+ | num_binder_types _ = 0
+(* typ -> typ list *)
+val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types
+fun maybe_curried_binder_types T =
+ (if is_pair_type (body_type T) then binder_types else curried_binder_types) T
+
+(* typ -> term list -> term *)
+fun mk_flat_tuple _ [t] = t
+ | mk_flat_tuple (Type ("*", [T1, T2])) (t :: ts) =
+ HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts)
+ | mk_flat_tuple T ts = raise TYPE ("NitpickHOL.mk_flat_tuple", [T], ts)
+(* int -> term -> term list *)
+fun dest_n_tuple 1 t = [t]
+ | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op ::
+
+(* int -> typ -> typ list *)
+fun dest_n_tuple_type 1 T = [T]
+ | dest_n_tuple_type n (Type (_, [T1, T2])) =
+ T1 :: dest_n_tuple_type (n - 1) T2
+ | dest_n_tuple_type _ T = raise TYPE ("NitpickHOL.dest_n_tuple_type", [T], [])
+
+(* (typ * typ) list -> typ -> typ *)
+fun typ_subst [] T = T
+ | typ_subst ps T =
+ let
+ (* typ -> typ *)
+ fun subst T =
+ case AList.lookup (op =) ps T of
+ SOME T' => T'
+ | NONE => case T of Type (s, Ts) => Type (s, map subst Ts) | _ => T
+ in subst T end
+
+(* theory -> typ -> typ -> typ -> typ *)
+fun instantiate_type thy T1 T1' T2 =
+ Same.commit (Envir.subst_type_same
+ (Sign.typ_match thy (Logic.varifyT T1, T1') Vartab.empty))
+ (Logic.varifyT T2)
+ handle Type.TYPE_MATCH =>
+ raise TYPE ("NitpickHOL.instantiate_type", [T1, T1'], [])
+
+(* theory -> typ -> typ -> styp *)
+fun repair_constr_type thy body_T' T =
+ instantiate_type thy (body_type T) body_T' T
+
+(* string -> (string * string) list -> theory -> theory *)
+fun register_frac_type frac_s ersaetze thy =
+ let
+ val {frac_types, codatatypes} = TheoryData.get thy
+ val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types
+ in TheoryData.put {frac_types = frac_types, codatatypes = codatatypes} thy end
+(* string -> theory -> theory *)
+fun unregister_frac_type frac_s = register_frac_type frac_s []
+
+(* typ -> string -> styp list -> theory -> theory *)
+fun register_codatatype co_T case_name constr_xs thy =
+ let
+ val {frac_types, codatatypes} = TheoryData.get thy
+ val constr_xs = map (apsnd (repair_constr_type thy co_T)) constr_xs
+ val (co_s, co_Ts) = dest_Type co_T
+ val _ =
+ if forall is_TFree co_Ts andalso not (has_duplicates (op =) co_Ts) then ()
+ else raise TYPE ("NitpickHOL.register_codatatype", [co_T], [])
+ val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs))
+ codatatypes
+ in TheoryData.put {frac_types = frac_types, codatatypes = codatatypes} thy end
+(* typ -> theory -> theory *)
+fun unregister_codatatype co_T = register_codatatype co_T "" []
+
+type typedef_info =
+ {rep_type: typ, abs_type: typ, Rep_name: string, Abs_name: string,
+ set_def: thm option, prop_of_Rep: thm, set_name: string,
+ Rep_inverse: thm option}
+
+(* theory -> string -> typedef_info *)
+fun typedef_info thy s =
+ if is_frac_type thy (Type (s, [])) then
+ SOME {abs_type = Type (s, []), rep_type = @{typ "int * int"},
+ Abs_name = @{const_name Abs_Frac}, Rep_name = @{const_name Rep_Frac},
+ set_def = NONE, prop_of_Rep = @{prop "Rep_Frac x \<in> Frac"}
+ |> Logic.varify,
+ set_name = @{const_name Frac}, Rep_inverse = NONE}
+ else case Typedef.get_info thy s of
+ SOME {abs_type, rep_type, Abs_name, Rep_name, set_def, Rep, Rep_inverse,
+ ...} =>
+ SOME {abs_type = abs_type, rep_type = rep_type, Abs_name = Abs_name,
+ Rep_name = Rep_name, set_def = set_def, prop_of_Rep = prop_of Rep,
+ set_name = set_prefix ^ s, Rep_inverse = SOME Rep_inverse}
+ | NONE => NONE
+
+(* string -> bool *)
+fun is_basic_datatype s =
+ s mem [@{type_name "*"}, @{type_name bool}, @{type_name unit},
+ @{type_name nat}, @{type_name int}]
+(* theory -> string -> bool *)
+val is_typedef = is_some oo typedef_info
+val is_real_datatype = is_some oo Datatype.get_info
+(* theory -> typ -> bool *)
+fun is_codatatype thy (T as Type (s, _)) =
+ not (null (AList.lookup (op =) (#codatatypes (TheoryData.get thy)) s
+ |> Option.map snd |> these))
+ | is_codatatype _ _ = false
+fun is_pure_typedef thy (T as Type (s, _)) =
+ is_typedef thy s andalso
+ not (is_real_datatype thy s orelse is_codatatype thy T
+ orelse is_record_type T orelse is_integer_type T)
+ | is_pure_typedef _ _ = false
+fun is_univ_typedef thy (Type (s, _)) =
+ (case typedef_info thy s of
+ SOME {set_def, prop_of_Rep, ...} =>
+ (case set_def of
+ SOME thm =>
+ try (fst o dest_Const o snd o Logic.dest_equals o prop_of) thm
+ | NONE =>
+ try (fst o dest_Const o snd o HOLogic.dest_mem
+ o HOLogic.dest_Trueprop) prop_of_Rep) = SOME @{const_name UNIV}
+ | NONE => false)
+ | is_univ_typedef _ _ = false
+fun is_datatype thy (T as Type (s, _)) =
+ (is_typedef thy s orelse is_codatatype thy T orelse T = @{typ ind})
+ andalso not (is_basic_datatype s)
+ | is_datatype _ _ = false
+
+(* theory -> typ -> (string * typ) list * (string * typ) *)
+fun all_record_fields thy T =
+ let val (recs, more) = Record.get_extT_fields thy T in
+ recs @ more :: all_record_fields thy (snd more)
+ end
+ handle TYPE _ => []
+(* styp -> bool *)
+fun is_record_constr (x as (s, T)) =
+ String.isSuffix Record.extN s andalso
+ let val dataT = body_type T in
+ is_record_type dataT andalso
+ s = unsuffix Record.ext_typeN (fst (dest_Type dataT)) ^ Record.extN
+ end
+(* theory -> typ -> int *)
+val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields
+(* theory -> string -> typ -> int *)
+fun no_of_record_field thy s T1 =
+ find_index (equal s o fst) (Record.get_extT_fields thy T1 ||> single |> op @)
+(* theory -> styp -> bool *)
+fun is_record_get thy (s, Type ("fun", [T1, _])) =
+ exists (equal s o fst) (all_record_fields thy T1)
+ | is_record_get _ _ = false
+fun is_record_update thy (s, T) =
+ String.isSuffix Record.updateN s andalso
+ exists (equal (unsuffix Record.updateN s) o fst)
+ (all_record_fields thy (body_type T))
+ handle TYPE _ => false
+fun is_abs_fun thy (s, Type ("fun", [_, Type (s', _)])) =
+ (case typedef_info thy s' of
+ SOME {Abs_name, ...} => s = Abs_name
+ | NONE => false)
+ | is_abs_fun _ _ = false
+fun is_rep_fun thy (s, Type ("fun", [Type (s', _), _])) =
+ (case typedef_info thy s' of
+ SOME {Rep_name, ...} => s = Rep_name
+ | NONE => false)
+ | is_rep_fun _ _ = false
+
+(* theory -> styp -> styp *)
+fun mate_of_rep_fun thy (x as (_, Type ("fun", [T1 as Type (s', _), T2]))) =
+ (case typedef_info thy s' of
+ SOME {Abs_name, ...} => (Abs_name, Type ("fun", [T2, T1]))
+ | NONE => raise TERM ("NitpickHOL.mate_of_rep_fun", [Const x]))
+ | mate_of_rep_fun _ x = raise TERM ("NitpickHOL.mate_of_rep_fun", [Const x])
+
+(* theory -> styp -> bool *)
+fun is_coconstr thy (s, T) =
+ let
+ val {codatatypes, ...} = TheoryData.get thy
+ val co_T = body_type T
+ val co_s = dest_Type co_T |> fst
+ in
+ exists (fn (s', T') => s = s' andalso repair_constr_type thy co_T T' = T)
+ (AList.lookup (op =) codatatypes co_s |> Option.map snd |> these)
+ end
+ handle TYPE ("dest_Type", _, _) => false
+fun is_constr_like thy (s, T) =
+ s mem [@{const_name FunBox}, @{const_name PairBox}] orelse
+ let val (x as (s, T)) = (s, unbox_type T) in
+ Refute.is_IDT_constructor thy x orelse is_record_constr x
+ orelse (is_abs_fun thy x andalso is_pure_typedef thy (range_type T))
+ orelse s mem [@{const_name Zero_Rep}, @{const_name Suc_Rep}]
+ orelse x = (@{const_name zero_nat_inst.zero_nat}, nat_T)
+ orelse is_coconstr thy x
+ end
+fun is_constr thy (x as (_, T)) =
+ is_constr_like thy x
+ andalso not (is_basic_datatype (fst (dest_Type (body_type T))))
+(* string -> bool *)
+val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
+val is_sel_like_and_no_discr =
+ String.isPrefix sel_prefix
+ orf (member (op =) [@{const_name fst}, @{const_name snd}])
+
+datatype boxability =
+ InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
+
+(* boxability -> boxability *)
+fun in_fun_lhs_for InConstr = InSel
+ | in_fun_lhs_for _ = InFunLHS
+fun in_fun_rhs_for InConstr = InConstr
+ | in_fun_rhs_for InSel = InSel
+ | in_fun_rhs_for InFunRHS1 = InFunRHS2
+ | in_fun_rhs_for _ = InFunRHS1
+
+(* extended_context -> boxability -> typ -> bool *)
+fun is_boxing_worth_it (ext_ctxt : extended_context) boxy T =
+ case T of
+ Type ("fun", _) =>
+ boxy mem [InPair, InFunLHS] andalso not (is_boolean_type (body_type T))
+ | Type ("*", Ts) =>
+ boxy mem [InPair, InFunRHS1, InFunRHS2]
+ orelse (boxy mem [InExpr, InFunLHS]
+ andalso exists (is_boxing_worth_it ext_ctxt InPair)
+ (map (box_type ext_ctxt InPair) Ts))
+ | _ => false
+(* extended_context -> boxability -> string * typ list -> string *)
+and should_box_type (ext_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
+ case triple_lookup (type_match thy) boxes (Type z) of
+ SOME (SOME box_me) => box_me
+ | _ => is_boxing_worth_it ext_ctxt boxy (Type z)
+(* extended_context -> boxability -> typ -> typ *)
+and box_type ext_ctxt boxy T =
+ case T of
+ Type (z as ("fun", [T1, T2])) =>
+ if not (boxy mem [InConstr, InSel])
+ andalso should_box_type ext_ctxt boxy z then
+ Type (@{type_name fun_box},
+ [box_type ext_ctxt InFunLHS T1, box_type ext_ctxt InFunRHS1 T2])
+ else
+ box_type ext_ctxt (in_fun_lhs_for boxy) T1
+ --> box_type ext_ctxt (in_fun_rhs_for boxy) T2
+ | Type (z as ("*", Ts)) =>
+ if should_box_type ext_ctxt boxy z then
+ Type (@{type_name pair_box}, map (box_type ext_ctxt InSel) Ts)
+ else
+ Type ("*", map (box_type ext_ctxt
+ (if boxy mem [InConstr, InSel] then boxy
+ else InPair)) Ts)
+ | _ => T
+
+(* styp -> styp *)
+fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)
+
+(* typ -> int *)
+fun num_sels_for_constr_type T = length (maybe_curried_binder_types T)
+(* string -> int -> string *)
+fun nth_sel_name_for_constr_name s n =
+ if s = @{const_name Pair} then
+ if n = 0 then @{const_name fst} else @{const_name snd}
+ else
+ sel_prefix_for n ^ s
+(* styp -> int -> styp *)
+fun nth_sel_for_constr x ~1 = discr_for_constr x
+ | nth_sel_for_constr (s, T) n =
+ (nth_sel_name_for_constr_name s n,
+ body_type T --> nth (maybe_curried_binder_types T) n)
+(* extended_context -> styp -> int -> styp *)
+fun boxed_nth_sel_for_constr ext_ctxt =
+ apsnd (box_type ext_ctxt InSel) oo nth_sel_for_constr
+
+(* string -> int *)
+fun sel_no_from_name s =
+ if String.isPrefix discr_prefix s then
+ ~1
+ else if String.isPrefix sel_prefix s then
+ s |> unprefix sel_prefix |> Int.fromString |> the
+ else if s = @{const_name snd} then
+ 1
+ else
+ 0
+
+(* typ list -> term -> int -> term *)
+fun eta_expand _ t 0 = t
+ | eta_expand Ts (Abs (s, T, t')) n =
+ Abs (s, T, eta_expand (T :: Ts) t' (n - 1))
+ | eta_expand Ts t n =
+ fold_rev (curry3 Abs ("x\<^isub>\<eta>" ^ nat_subscript n))
+ (List.take (binder_types (fastype_of1 (Ts, t)), n))
+ (list_comb (incr_boundvars n t, map Bound (n - 1 downto 0)))
+
+(* term -> term *)
+fun extensionalize t =
+ case t of
+ (t0 as @{const Trueprop}) $ t1 => t0 $ extensionalize t1
+ | Const (@{const_name "op ="}, _) $ t1 $ Abs (s, T, t2) =>
+ let val v = Var ((s, maxidx_of_term t + 1), T) in
+ extensionalize (HOLogic.mk_eq (t1 $ v, subst_bound (v, t2)))
+ end
+ | _ => t
+
+(* typ -> term list -> term *)
+fun distinctness_formula T =
+ all_distinct_unordered_pairs_of
+ #> map (fn (t1, t2) => @{const Not} $ (HOLogic.eq_const T $ t1 $ t2))
+ #> List.foldr (s_conj o swap) @{const True}
+
+(* typ -> term *)
+fun zero_const T = Const (@{const_name zero_nat_inst.zero_nat}, T)
+fun suc_const T = Const (@{const_name Suc}, T --> T)
+
+(* theory -> typ -> styp list *)
+fun datatype_constrs thy (T as Type (s, Ts)) =
+ if is_datatype thy T then
+ case Datatype.get_info thy s of
+ SOME {index, descr, ...} =>
+ let val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the in
+ map (fn (s', Us) =>
+ (s', map (Refute.typ_of_dtyp descr (dtyps ~~ Ts)) Us ---> T))
+ constrs
+ end
+ | NONE =>
+ case AList.lookup (op =) (#codatatypes (TheoryData.get thy)) s of
+ SOME (_, xs' as (_ :: _)) =>
+ map (apsnd (repair_constr_type thy T)) xs'
+ | _ =>
+ if is_record_type T then
+ let
+ val s' = unsuffix Record.ext_typeN s ^ Record.extN
+ val T' = (Record.get_extT_fields thy T
+ |> apsnd single |> uncurry append |> map snd) ---> T
+ in [(s', T')] end
+ else case typedef_info thy s of
+ SOME {abs_type, rep_type, Abs_name, ...} =>
+ [(Abs_name, instantiate_type thy abs_type T rep_type --> T)]
+ | NONE =>
+ if T = @{typ ind} then
+ [dest_Const @{const Zero_Rep}, dest_Const @{const Suc_Rep}]
+ else
+ []
+ else
+ []
+ | datatype_constrs _ _ = []
+(* extended_context -> typ -> styp list *)
+fun boxed_datatype_constrs (ext_ctxt as {thy, ...}) =
+ map (apsnd (box_type ext_ctxt InConstr)) o datatype_constrs thy
+(* theory -> typ -> int *)
+val num_datatype_constrs = length oo datatype_constrs
+
+(* string -> string *)
+fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
+ | constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
+ | constr_name_for_sel_like s' = original_name s'
+(* extended_context -> styp -> styp *)
+fun boxed_constr_for_sel ext_ctxt (s', T') =
+ let val s = constr_name_for_sel_like s' in
+ AList.lookup (op =) (boxed_datatype_constrs ext_ctxt (domain_type T')) s
+ |> the |> pair s
+ end
+(* theory -> styp -> term *)
+fun discr_term_for_constr thy (x as (s, T)) =
+ let val dataT = body_type T in
+ if s = @{const_name Suc} then
+ Abs (Name.uu, dataT,
+ @{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0))
+ else if num_datatype_constrs thy dataT >= 2 then
+ Const (discr_for_constr x)
+ else
+ Abs (Name.uu, dataT, @{const True})
+ end
+
+(* theory -> styp -> term -> term *)
+fun discriminate_value thy (x as (_, T)) t =
+ case strip_comb t of
+ (Const x', args) =>
+ if x = x' then @{const True}
+ else if is_constr_like thy x' then @{const False}
+ else betapply (discr_term_for_constr thy x, t)
+ | _ => betapply (discr_term_for_constr thy x, t)
+
+(* styp -> term -> term *)
+fun nth_arg_sel_term_for_constr (x as (s, T)) n =
+ let val (arg_Ts, dataT) = strip_type T in
+ if dataT = nat_T then
+ @{term "%n::nat. minus_nat_inst.minus_nat n one_nat_inst.one_nat"}
+ else if is_pair_type dataT then
+ Const (nth_sel_for_constr x n)
+ else
+ let
+ (* int -> typ -> int * term *)
+ fun aux m (Type ("*", [T1, T2])) =
+ let
+ val (m, t1) = aux m T1
+ val (m, t2) = aux m T2
+ in (m, HOLogic.mk_prod (t1, t2)) end
+ | aux m T =
+ (m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T)
+ $ Bound 0)
+ val m = fold (Integer.add o num_factors_in_type)
+ (List.take (arg_Ts, n)) 0
+ in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end
+ end
+(* theory -> styp -> term -> int -> typ -> term *)
+fun select_nth_constr_arg thy x t n res_T =
+ case strip_comb t of
+ (Const x', args) =>
+ if x = x' then nth args n
+ else if is_constr_like thy x' then Const (@{const_name unknown}, res_T)
+ else betapply (nth_arg_sel_term_for_constr x n, t)
+ | _ => betapply (nth_arg_sel_term_for_constr x n, t)
+
+(* theory -> styp -> term list -> term *)
+fun construct_value _ x [] = Const x
+ | construct_value thy (x as (s, _)) args =
+ let val args = map Envir.eta_contract args in
+ case hd args of
+ Const (x' as (s', _)) $ t =>
+ if is_sel_like_and_no_discr s' andalso constr_name_for_sel_like s' = s
+ andalso forall (fn (n, t') =>
+ select_nth_constr_arg thy x t n dummyT = t')
+ (index_seq 0 (length args) ~~ args) then
+ t
+ else
+ list_comb (Const x, args)
+ | _ => list_comb (Const x, args)
+ end
+
+(* theory -> typ -> term -> term *)
+fun constr_expand thy T t =
+ (case head_of t of
+ Const x => if is_constr_like thy x then t else raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ let
+ val x' as (_, T') =
+ if is_pair_type T then
+ let val (T1, T2) = HOLogic.dest_prodT T in
+ (@{const_name Pair}, [T1, T2] ---> T)
+ end
+ else
+ datatype_constrs thy T |> the_single
+ val arg_Ts = binder_types T'
+ in
+ list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
+ (index_seq 0 (length arg_Ts)) arg_Ts)
+ end
+
+(* (typ * int) list -> typ -> int *)
+fun card_of_type asgns (Type ("fun", [T1, T2])) =
+ reasonable_power (card_of_type asgns T2) (card_of_type asgns T1)
+ | card_of_type asgns (Type ("*", [T1, T2])) =
+ card_of_type asgns T1 * card_of_type asgns T2
+ | card_of_type _ (Type (@{type_name itself}, _)) = 1
+ | card_of_type _ @{typ prop} = 2
+ | card_of_type _ @{typ bool} = 2
+ | card_of_type _ @{typ unit} = 1
+ | card_of_type asgns T =
+ case AList.lookup (op =) asgns T of
+ SOME k => k
+ | NONE => if T = @{typ bisim_iterator} then 0
+ else raise TYPE ("NitpickHOL.card_of_type", [T], [])
+(* int -> (typ * int) list -> typ -> int *)
+fun bounded_card_of_type max default_card asgns (Type ("fun", [T1, T2])) =
+ let
+ val k1 = bounded_card_of_type max default_card asgns T1
+ val k2 = bounded_card_of_type max default_card asgns T2
+ in
+ if k1 = max orelse k2 = max then max
+ else Int.min (max, reasonable_power k2 k1)
+ end
+ | bounded_card_of_type max default_card asgns (Type ("*", [T1, T2])) =
+ let
+ val k1 = bounded_card_of_type max default_card asgns T1
+ val k2 = bounded_card_of_type max default_card asgns T2
+ in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end
+ | bounded_card_of_type max default_card asgns T =
+ Int.min (max, if default_card = ~1 then
+ card_of_type asgns T
+ else
+ card_of_type asgns T
+ handle TYPE ("NitpickHOL.card_of_type", _, _) =>
+ default_card)
+(* theory -> int -> (typ * int) list -> typ -> int *)
+fun bounded_precise_card_of_type thy max default_card asgns T =
+ let
+ (* typ list -> typ -> int *)
+ fun aux avoid T =
+ (if T mem avoid then
+ 0
+ else case T of
+ Type ("fun", [T1, T2]) =>
+ let
+ val k1 = aux avoid T1
+ val k2 = aux avoid T2
+ in
+ if k1 = 0 orelse k2 = 0 then 0
+ else if k1 >= max orelse k2 >= max then max
+ else Int.min (max, reasonable_power k2 k1)
+ end
+ | Type ("*", [T1, T2]) =>
+ let
+ val k1 = aux avoid T1
+ val k2 = aux avoid T2
+ in
+ if k1 = 0 orelse k2 = 0 then 0
+ else if k1 >= max orelse k2 >= max then max
+ else Int.min (max, k1 * k2)
+ end
+ | Type (@{type_name itself}, _) => 1
+ | @{typ prop} => 2
+ | @{typ bool} => 2
+ | @{typ unit} => 1
+ | Type _ =>
+ (case datatype_constrs thy T of
+ [] => if is_integer_type T then 0 else raise SAME ()
+ | constrs =>
+ let
+ val constr_cards =
+ datatype_constrs thy T
+ |> map (Integer.prod o map (aux (T :: avoid)) o binder_types
+ o snd)
+ in
+ if exists (equal 0) constr_cards then 0
+ else Integer.sum constr_cards
+ end)
+ | _ => raise SAME ())
+ handle SAME () => AList.lookup (op =) asgns T |> the_default default_card
+ in Int.min (max, aux [] T) end
+
+(* theory -> typ -> bool *)
+fun is_finite_type thy = not_equal 0 o bounded_precise_card_of_type thy 1 2 []
+
+(* term -> bool *)
+fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
+ | is_ground_term (Const _) = true
+ | is_ground_term _ = false
+
+(* term -> word -> word *)
+fun hashw_term (t1 $ t2) = Polyhash.hashw (hashw_term t1, hashw_term t2)
+ | hashw_term (Const (s, _)) = Polyhash.hashw_string (s, 0w0)
+ | hashw_term _ = 0w0
+(* term -> int *)
+val hash_term = Word.toInt o hashw_term
+
+(* term list -> (indexname * typ) list *)
+fun special_bounds ts =
+ fold Term.add_vars ts [] |> sort (TermOrd.fast_indexname_ord o pairself fst)
+
+(* indexname * typ -> term -> term *)
+fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body))
+
+(* term -> bool *)
+fun is_arity_type_axiom (Const (@{const_name HOL.type_class}, _)
+ $ Const (@{const_name TYPE}, _)) = true
+ | is_arity_type_axiom _ = false
+(* theory -> bool -> term -> bool *)
+fun is_typedef_axiom thy boring (@{const "==>"} $ _ $ t2) =
+ is_typedef_axiom thy boring t2
+ | is_typedef_axiom thy boring
+ (@{const Trueprop} $ (Const (@{const_name Typedef.type_definition}, _)
+ $ Const (_, Type ("fun", [Type (s, _), _])) $ Const _ $ _)) =
+ boring <> (s mem [@{type_name unit}, @{type_name "*"}, @{type_name "+"}]
+ orelse is_frac_type thy (Type (s, [])))
+ andalso is_typedef thy s
+ | is_typedef_axiom _ _ _ = false
+
+(* Distinguishes between (1) constant definition axioms, (2) type arity and
+ typedef axioms, and (3) other axioms, and returns the pair ((1), (3)).
+ Typedef axioms are uninteresting to Nitpick, because it can retrieve them
+ using "typedef_info". *)
+(* theory -> (string * term) list -> string list -> term list * term list *)
+fun partition_axioms_by_definitionality thy axioms def_names =
+ let
+ val axioms = sort (fast_string_ord o pairself fst) axioms
+ val defs = OrdList.inter (fast_string_ord o apsnd fst) def_names axioms
+ val nondefs =
+ OrdList.subtract (fast_string_ord o apsnd fst) def_names axioms
+ |> filter_out ((is_arity_type_axiom orf is_typedef_axiom thy true) o snd)
+ in pairself (map snd) (defs, nondefs) end
+
+(* Ideally we would check against "Complex_Main", not "Refute", but any theory
+ will do as long as it contains all the "axioms" and "axiomatization"
+ commands. *)
+(* theory -> bool *)
+fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute})
+
+(* term -> bool *)
+val is_plain_definition =
+ let
+ (* term -> bool *)
+ fun do_lhs t1 =
+ case strip_comb t1 of
+ (Const _, args) => forall is_Var args
+ andalso not (has_duplicates (op =) args)
+ | _ => false
+ fun do_eq (Const (@{const_name "=="}, _) $ t1 $ _) = do_lhs t1
+ | do_eq (@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)) =
+ do_lhs t1
+ | do_eq _ = false
+ in do_eq end
+
+(* This table is not pretty. A better approach would be to avoid expanding the
+ operators to their low-level definitions, but this would require dealing with
+ overloading. *)
+val built_in_built_in_defs =
+ [@{thm div_int_inst.div_int}, @{thm div_int_inst.mod_int},
+ @{thm div_nat_inst.div_nat}, @{thm div_nat_inst.mod_nat},
+ @{thm lower_semilattice_fun_inst.inf_fun}, @{thm minus_fun_inst.minus_fun},
+ @{thm minus_int_inst.minus_int}, @{thm minus_nat_inst.minus_nat},
+ @{thm one_int_inst.one_int}, @{thm one_nat_inst.one_nat},
+ @{thm ord_fun_inst.less_eq_fun}, @{thm ord_int_inst.less_eq_int},
+ @{thm ord_int_inst.less_int}, @{thm ord_nat_inst.less_eq_nat},
+ @{thm ord_nat_inst.less_nat}, @{thm plus_int_inst.plus_int},
+ @{thm plus_nat_inst.plus_nat}, @{thm times_int_inst.times_int},
+ @{thm times_nat_inst.times_nat}, @{thm uminus_int_inst.uminus_int},
+ @{thm upper_semilattice_fun_inst.sup_fun}, @{thm zero_int_inst.zero_int},
+ @{thm zero_nat_inst.zero_nat}]
+ |> map prop_of
+
+(* theory -> term list * term list * term list *)
+fun all_axioms_of thy =
+ let
+ (* theory list -> term list *)
+ val axioms_of_thys = maps Thm.axioms_of #> map (apsnd prop_of)
+ val specs = Defs.all_specifications_of (Theory.defs_of thy)
+ val def_names = specs |> maps snd |> filter #is_def |> map #name
+ |> OrdList.make fast_string_ord
+ val thys = thy :: Theory.ancestors_of thy
+ val (built_in_thys, user_thys) = List.partition is_built_in_theory thys
+ val built_in_axioms = axioms_of_thys built_in_thys
+ val user_axioms = axioms_of_thys user_thys
+ val (built_in_defs, built_in_nondefs) =
+ partition_axioms_by_definitionality thy built_in_axioms def_names
+ ||> filter (is_typedef_axiom thy false)
+ val (user_defs, user_nondefs) =
+ partition_axioms_by_definitionality thy user_axioms def_names
+ val (built_in_nondefs, user_nondefs) =
+ List.partition (is_typedef_axiom thy false) user_nondefs
+ |>> append built_in_nondefs
+ val defs = built_in_built_in_defs @
+ (thy |> PureThy.all_thms_of
+ |> filter (equal Thm.definitionK o Thm.get_kind o snd)
+ |> map (prop_of o snd) |> filter is_plain_definition) @
+ user_defs @ built_in_defs
+ in (defs, built_in_nondefs, user_nondefs) end
+
+(* bool -> styp -> int option *)
+fun arity_of_built_in_const fast_descrs (s, T) =
+ if s = @{const_name If} then
+ if nth_range_type 3 T = @{typ bool} then NONE else SOME 3
+ else case AList.lookup (op =)
+ (built_in_consts
+ |> fast_descrs ? append built_in_descr_consts) s of
+ SOME n => SOME n
+ | NONE =>
+ case AList.lookup (op =) built_in_typed_consts (s, T) of
+ SOME n => SOME n
+ | NONE =>
+ if is_fun_type T andalso is_set_type (domain_type T) then
+ AList.lookup (op =) built_in_set_consts s
+ else
+ NONE
+(* bool -> styp -> bool *)
+val is_built_in_const = is_some oo arity_of_built_in_const
+
+(* This function is designed to work for both real definition axioms and
+ simplification rules (equational specifications). *)
+(* term -> term *)
+fun term_under_def t =
+ case t of
+ @{const "==>"} $ _ $ t2 => term_under_def t2
+ | Const (@{const_name "=="}, _) $ t1 $ _ => term_under_def t1
+ | @{const Trueprop} $ t1 => term_under_def t1
+ | Const (@{const_name "op ="}, _) $ t1 $ _ => term_under_def t1
+ | Abs (_, _, t') => term_under_def t'
+ | t1 $ _ => term_under_def t1
+ | _ => t
+
+(* Here we crucially rely on "Refute.specialize_type" performing a preorder
+ traversal of the term, without which the wrong occurrence of a constant could
+ be matched in the face of overloading. *)
+(* theory -> bool -> const_table -> styp -> term list *)
+fun def_props_for_const thy fast_descrs table (x as (s, _)) =
+ if is_built_in_const fast_descrs x then
+ []
+ else
+ these (Symtab.lookup table s)
+ |> map_filter (try (Refute.specialize_type thy x))
+ |> filter (equal (Const x) o term_under_def)
+
+(* term -> term *)
+fun normalized_rhs_of thy t =
+ let
+ (* term -> term *)
+ fun aux (v as Var _) t = lambda v t
+ | aux (c as Const (@{const_name TYPE}, T)) t = lambda c t
+ | aux _ _ = raise TERM ("NitpickHOL.normalized_rhs_of", [t])
+ val (lhs, rhs) =
+ case t of
+ Const (@{const_name "=="}, _) $ t1 $ t2 => (t1, t2)
+ | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ t2) =>
+ (t1, t2)
+ | _ => raise TERM ("NitpickHOL.normalized_rhs_of", [t])
+ val args = strip_comb lhs |> snd
+ in fold_rev aux args rhs end
+
+(* theory -> const_table -> styp -> term option *)
+fun def_of_const thy table (x as (s, _)) =
+ if is_built_in_const false x orelse original_name s <> s then
+ NONE
+ else
+ x |> def_props_for_const thy false table |> List.last
+ |> normalized_rhs_of thy |> prefix_abs_vars s |> SOME
+ handle List.Empty => NONE
+
+datatype fixpoint_kind = Lfp | Gfp | NoFp
+
+(* term -> fixpoint_kind *)
+fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
+ | fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp
+ | fixpoint_kind_of_rhs (Const (@{const_name gfp}, _) $ Abs _) = Gfp
+ | fixpoint_kind_of_rhs _ = NoFp
+
+(* theory -> const_table -> term -> bool *)
+fun is_mutually_inductive_pred_def thy table t =
+ let
+ (* term -> bool *)
+ fun is_good_arg (Bound _) = true
+ | is_good_arg (Const (s, _)) =
+ s mem [@{const_name True}, @{const_name False}, @{const_name undefined}]
+ | is_good_arg _ = false
+ in
+ case t |> strip_abs_body |> strip_comb of
+ (Const x, ts as (_ :: _)) =>
+ (case def_of_const thy table x of
+ SOME t' => fixpoint_kind_of_rhs t' <> NoFp andalso forall is_good_arg ts
+ | NONE => false)
+ | _ => false
+ end
+(* theory -> const_table -> term -> term *)
+fun unfold_mutually_inductive_preds thy table =
+ map_aterms (fn t as Const x =>
+ (case def_of_const thy table x of
+ SOME t' =>
+ let val t' = Envir.eta_contract t' in
+ if is_mutually_inductive_pred_def thy table t' then t'
+ else t
+ end
+ | NONE => t)
+ | t => t)
+
+(* term -> string * term *)
+fun pair_for_prop t =
+ case term_under_def t of
+ Const (s, _) => (s, t)
+ | Free _ => raise NOT_SUPPORTED "local definitions"
+ | t' => raise TERM ("NitpickHOL.pair_for_prop", [t, t'])
+
+(* (Proof.context -> term list) -> Proof.context -> const_table *)
+fun table_for get ctxt =
+ get ctxt |> map pair_for_prop |> AList.group (op =) |> Symtab.make
+
+(* theory -> (string * int) list *)
+fun case_const_names thy =
+ Symtab.fold (fn (dtype_s, {index, descr, case_name, ...}) =>
+ if is_basic_datatype dtype_s then
+ I
+ else
+ cons (case_name, AList.lookup (op =) descr index
+ |> the |> #3 |> length))
+ (Datatype.get_all thy) [] @
+ map (apsnd length o snd) (#codatatypes (TheoryData.get thy))
+
+(* Proof.context -> term list -> const_table *)
+fun const_def_table ctxt ts =
+ table_for (map prop_of o Nitpick_Defs.get) ctxt
+ |> fold (fn (s, t) => Symtab.map_default (s, []) (cons t))
+ (map pair_for_prop ts)
+(* term list -> const_table *)
+fun const_nondef_table ts =
+ fold (fn t => append (map (fn s => (s, t)) (Term.add_const_names t []))) ts []
+ |> AList.group (op =) |> Symtab.make
+(* Proof.context -> const_table *)
+val const_simp_table = table_for (map prop_of o Nitpick_Simps.get)
+val const_psimp_table = table_for (map prop_of o Nitpick_Psimps.get)
+(* Proof.context -> const_table -> const_table *)
+fun inductive_intro_table ctxt def_table =
+ table_for (map (unfold_mutually_inductive_preds (ProofContext.theory_of ctxt)
+ def_table o prop_of)
+ o Nitpick_Intros.get) ctxt
+(* theory -> term list Inttab.table *)
+fun ground_theorem_table thy =
+ fold ((fn @{const Trueprop} $ t1 =>
+ is_ground_term t1 ? Inttab.map_default (hash_term t1, []) (cons t1)
+ | _ => I) o prop_of o snd) (PureThy.all_thms_of thy) Inttab.empty
+
+val basic_ersatz_table =
+ [(@{const_name prod_case}, @{const_name split}),
+ (@{const_name card}, @{const_name card'}),
+ (@{const_name setsum}, @{const_name setsum'}),
+ (@{const_name fold_graph}, @{const_name fold_graph'}),
+ (@{const_name wf}, @{const_name wf'}),
+ (@{const_name wf_wfrec}, @{const_name wf_wfrec'}),
+ (@{const_name wfrec}, @{const_name wfrec'})]
+
+(* theory -> (string * string) list *)
+fun ersatz_table thy =
+ fold (append o snd) (#frac_types (TheoryData.get thy)) basic_ersatz_table
+
+(* const_table Unsynchronized.ref -> string -> term list -> unit *)
+fun add_simps simp_table s eqs =
+ Unsynchronized.change simp_table
+ (Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s)))
+
+(* Similar to "Refute.specialize_type" but returns all matches rather than only
+ the first (preorder) match. *)
+(* theory -> styp -> term -> term list *)
+fun multi_specialize_type thy slack (x as (s, T)) t =
+ let
+ (* term -> (typ * term) list -> (typ * term) list *)
+ fun aux (Const (s', T')) ys =
+ if s = s' then
+ ys |> (if AList.defined (op =) ys T' then
+ I
+ else
+ cons (T', Refute.monomorphic_term
+ (Sign.typ_match thy (T', T) Vartab.empty) t)
+ handle Type.TYPE_MATCH => I
+ | Refute.REFUTE _ =>
+ if slack then
+ I
+ else
+ raise NOT_SUPPORTED ("too much polymorphism in \
+ \axiom involving " ^ quote s))
+ else
+ ys
+ | aux _ ys = ys
+ in map snd (fold_aterms aux t []) end
+
+(* theory -> bool -> const_table -> styp -> term list *)
+fun nondef_props_for_const thy slack table (x as (s, _)) =
+ these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
+
+(* theory -> styp list -> term list *)
+fun optimized_typedef_axioms thy (abs_s, abs_Ts) =
+ let val abs_T = Type (abs_s, abs_Ts) in
+ if is_univ_typedef thy abs_T then
+ []
+ else case typedef_info thy abs_s of
+ SOME {abs_type, rep_type, Abs_name, Rep_name, prop_of_Rep, set_name,
+ ...} =>
+ let
+ val rep_T = instantiate_type thy abs_type abs_T rep_type
+ val rep_t = Const (Rep_name, abs_T --> rep_T)
+ val set_t = Const (set_name, rep_T --> bool_T)
+ val set_t' =
+ prop_of_Rep |> HOLogic.dest_Trueprop
+ |> Refute.specialize_type thy (dest_Const rep_t)
+ |> HOLogic.dest_mem |> snd
+ in
+ [HOLogic.all_const abs_T
+ $ Abs (Name.uu, abs_T, set_t $ (rep_t $ Bound 0))]
+ |> set_t <> set_t' ? cons (HOLogic.mk_eq (set_t, set_t'))
+ |> map HOLogic.mk_Trueprop
+ end
+ | NONE => []
+ end
+(* theory -> styp -> term *)
+fun inverse_axiom_for_rep_fun thy (x as (_, T)) =
+ typedef_info thy (fst (dest_Type (domain_type T)))
+ |> the |> #Rep_inverse |> the |> prop_of |> Refute.specialize_type thy x
+
+(* theory -> int * styp -> term *)
+fun constr_case_body thy (j, (x as (_, T))) =
+ let val arg_Ts = binder_types T in
+ list_comb (Bound j, map2 (select_nth_constr_arg thy x (Bound 0))
+ (index_seq 0 (length arg_Ts)) arg_Ts)
+ end
+(* theory -> typ -> int * styp -> term -> term *)
+fun add_constr_case thy res_T (j, x) res_t =
+ Const (@{const_name If}, [bool_T, res_T, res_T] ---> res_T)
+ $ discriminate_value thy x (Bound 0) $ constr_case_body thy (j, x) $ res_t
+(* theory -> typ -> typ -> term *)
+fun optimized_case_def thy dataT res_T =
+ let
+ val xs = datatype_constrs thy dataT
+ val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs
+ val (xs', x) = split_last xs
+ in
+ constr_case_body thy (1, x)
+ |> fold_rev (add_constr_case thy res_T) (length xs downto 2 ~~ xs')
+ |> fold_rev (curry absdummy) (func_Ts @ [dataT])
+ end
+
+val redefined_in_NitpickDefs_thy =
+ [@{const_name option_case}, @{const_name nat_case}, @{const_name list_case},
+ @{const_name list_size}]
+
+(* theory -> string -> typ -> typ -> term -> term *)
+fun optimized_record_get thy s rec_T res_T t =
+ let val constr_x = the_single (datatype_constrs thy rec_T) in
+ case no_of_record_field thy s rec_T of
+ ~1 => (case rec_T of
+ Type (_, Ts as _ :: _) =>
+ let
+ val rec_T' = List.last Ts
+ val j = num_record_fields thy rec_T - 1
+ in
+ select_nth_constr_arg thy constr_x t j res_T
+ |> optimized_record_get thy s rec_T' res_T
+ end
+ | _ => raise TYPE ("NitpickHOL.optimized_record_get", [rec_T], []))
+ | j => select_nth_constr_arg thy constr_x t j res_T
+ end
+(* theory -> string -> typ -> term -> term -> term *)
+fun optimized_record_update thy s rec_T fun_t rec_t =
+ let
+ val constr_x as (_, constr_T) = the_single (datatype_constrs thy rec_T)
+ val Ts = binder_types constr_T
+ val n = length Ts
+ val special_j = no_of_record_field thy s rec_T
+ val ts = map2 (fn j => fn T =>
+ let
+ val t = select_nth_constr_arg thy constr_x rec_t j T
+ in
+ if j = special_j then
+ betapply (fun_t, t)
+ else if j = n - 1 andalso special_j = ~1 then
+ optimized_record_update thy s
+ (rec_T |> dest_Type |> snd |> List.last) fun_t t
+ else
+ t
+ end) (index_seq 0 n) Ts
+ in list_comb (Const constr_x, ts) end
+
+(* Constants "c" whose definition is of the form "c == c'", where "c'" is also a
+ constant, are said to be trivial. For those, we ignore the simplification
+ rules and use the definition instead, to ensure that built-in symbols like
+ "ord_nat_inst.less_eq_nat" are picked up correctly. *)
+(* theory -> const_table -> styp -> bool *)
+fun has_trivial_definition thy table x =
+ case def_of_const thy table x of SOME (Const _) => true | _ => false
+
+(* theory -> const_table -> string * typ -> fixpoint_kind *)
+fun fixpoint_kind_of_const thy table x =
+ if is_built_in_const false x then
+ NoFp
+ else
+ fixpoint_kind_of_rhs (the (def_of_const thy table x))
+ handle Option.Option => NoFp
+
+(* extended_context -> styp -> bool *)
+fun is_real_inductive_pred ({thy, fast_descrs, def_table, intro_table, ...}
+ : extended_context) x =
+ not (null (def_props_for_const thy fast_descrs intro_table x))
+ andalso fixpoint_kind_of_const thy def_table x <> NoFp
+fun is_real_equational_fun ({thy, fast_descrs, simp_table, psimp_table, ...}
+ : extended_context) x =
+ exists (fn table => not (null (def_props_for_const thy fast_descrs table x)))
+ [!simp_table, psimp_table]
+fun is_inductive_pred ext_ctxt =
+ is_real_inductive_pred ext_ctxt andf (not o is_real_equational_fun ext_ctxt)
+fun is_equational_fun (ext_ctxt as {thy, def_table, ...}) =
+ (is_real_equational_fun ext_ctxt orf is_real_inductive_pred ext_ctxt
+ orf (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
+ andf (not o has_trivial_definition thy def_table)
+ andf (not o member (op =) redefined_in_NitpickDefs_thy o fst)
+
+(* term * term -> term *)
+fun s_betapply (Const (@{const_name If}, _) $ @{const True} $ t, _) = t
+ | s_betapply (Const (@{const_name If}, _) $ @{const False} $ _, t) = t
+ | s_betapply p = betapply p
+(* term * term list -> term *)
+val s_betapplys = Library.foldl s_betapply
+
+(* term -> term *)
+fun lhs_of_equation t =
+ case t of
+ Const (@{const_name all}, _) $ Abs (_, _, t1) => lhs_of_equation t1
+ | Const (@{const_name "=="}, _) $ t1 $ _ => SOME t1
+ | @{const "==>"} $ _ $ t2 => lhs_of_equation t2
+ | @{const Trueprop} $ t1 => lhs_of_equation t1
+ | Const (@{const_name All}, _) $ Abs (_, _, t1) => lhs_of_equation t1
+ | Const (@{const_name "op ="}, _) $ t1 $ _ => SOME t1
+ | @{const "op -->"} $ _ $ t2 => lhs_of_equation t2
+ | _ => NONE
+(* theory -> term -> bool *)
+fun is_constr_pattern _ (Bound _) = true
+ | is_constr_pattern thy t =
+ case strip_comb t of
+ (Const (x as (s, _)), args) =>
+ is_constr_like thy x andalso forall (is_constr_pattern thy) args
+ | _ => false
+fun is_constr_pattern_lhs thy t =
+ forall (is_constr_pattern thy) (snd (strip_comb t))
+fun is_constr_pattern_formula thy t =
+ case lhs_of_equation t of
+ SOME t' => is_constr_pattern_lhs thy t'
+ | NONE => false
+
+val unfold_max_depth = 63
+val axioms_max_depth = 63
+
+(* extended_context -> term -> term *)
+fun unfold_defs_in_term (ext_ctxt as {thy, destroy_constrs, fast_descrs,
+ case_names, def_table, ground_thm_table,
+ ersatz_table, ...}) =
+ let
+ (* int -> typ list -> term -> term *)
+ fun do_term depth Ts t =
+ case t of
+ (t0 as Const (@{const_name Int.number_class.number_of},
+ Type ("fun", [_, ran_T]))) $ t1 =>
+ ((if is_number_type thy ran_T then
+ let
+ val j = t1 |> HOLogic.dest_numeral
+ |> ran_T <> int_T ? curry Int.max 0
+ val s = numeral_prefix ^ signed_string_of_int j
+ in
+ if is_integer_type ran_T then
+ Const (s, ran_T)
+ else
+ do_term depth Ts (Const (@{const_name of_int}, int_T --> ran_T)
+ $ Const (s, int_T))
+ end
+ handle TERM _ => raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => betapply (do_term depth Ts t0, do_term depth Ts t1))
+ | Const (@{const_name refl_on}, T) $ Const (@{const_name UNIV}, _) $ t2 =>
+ do_const depth Ts t (@{const_name refl'}, range_type T) [t2]
+ | (t0 as Const (x as (@{const_name Sigma}, T))) $ t1
+ $ (t2 as Abs (_, _, t2')) =>
+ betapplys (t0 |> loose_bvar1 (t2', 0) ? do_term depth Ts,
+ map (do_term depth Ts) [t1, t2])
+ | Const (x as (@{const_name distinct},
+ Type ("fun", [Type (@{type_name list}, [T']), _])))
+ $ (t1 as _ $ _) =>
+ (t1 |> HOLogic.dest_list |> distinctness_formula T'
+ handle TERM _ => do_const depth Ts t x [t1])
+ | (t0 as Const (x as (@{const_name If}, _))) $ t1 $ t2 $ t3 =>
+ if is_ground_term t1
+ andalso exists (Pattern.matches thy o rpair t1)
+ (Inttab.lookup_list ground_thm_table
+ (hash_term t1)) then
+ do_term depth Ts t2
+ else
+ do_const depth Ts t x [t1, t2, t3]
+ | Const x $ t1 $ t2 $ t3 => do_const depth Ts t x [t1, t2, t3]
+ | Const x $ t1 $ t2 => do_const depth Ts t x [t1, t2]
+ | Const x $ t1 => do_const depth Ts t x [t1]
+ | Const x => do_const depth Ts t x []
+ | t1 $ t2 => betapply (do_term depth Ts t1, do_term depth Ts t2)
+ | Free _ => t
+ | Var _ => t
+ | Bound _ => t
+ | Abs (s, T, body) => Abs (s, T, do_term depth (T :: Ts) body)
+ (* int -> typ list -> styp -> term list -> int -> typ -> term * term list *)
+ and select_nth_constr_arg_with_args _ _ (x as (_, T)) [] n res_T =
+ (Abs (Name.uu, body_type T,
+ select_nth_constr_arg thy x (Bound 0) n res_T), [])
+ | select_nth_constr_arg_with_args depth Ts x (t :: ts) n res_T =
+ (select_nth_constr_arg thy x (do_term depth Ts t) n res_T, ts)
+ (* int -> typ list -> term -> styp -> term list -> term *)
+ and do_const depth Ts t (x as (s, T)) ts =
+ case AList.lookup (op =) ersatz_table s of
+ SOME s' =>
+ do_const (depth + 1) Ts (list_comb (Const (s', T), ts)) (s', T) ts
+ | NONE =>
+ let
+ val (const, ts) =
+ if is_built_in_const fast_descrs x then
+ if s = @{const_name finite} then
+ if is_finite_type thy (domain_type T) then
+ (Abs ("A", domain_type T, @{const True}), ts)
+ else case ts of
+ [Const (@{const_name UNIV}, _)] => (@{const False}, [])
+ | _ => (Const x, ts)
+ else
+ (Const x, ts)
+ else case AList.lookup (op =) case_names s of
+ SOME n =>
+ let
+ val (dataT, res_T) = nth_range_type n T
+ |> domain_type pairf range_type
+ in
+ (optimized_case_def thy dataT res_T
+ |> do_term (depth + 1) Ts, ts)
+ end
+ | _ =>
+ if is_constr thy x then
+ (Const x, ts)
+ else if is_record_get thy x then
+ case length ts of
+ 0 => (do_term depth Ts (eta_expand Ts t 1), [])
+ | _ => (optimized_record_get thy s (domain_type T)
+ (range_type T) (hd ts), tl ts)
+ else if is_record_update thy x then
+ case length ts of
+ 2 => (optimized_record_update thy (unsuffix Record.updateN s)
+ (nth_range_type 2 T)
+ (do_term depth Ts (hd ts))
+ (do_term depth Ts (nth ts 1)),
+ [])
+ | n => (do_term depth Ts (eta_expand Ts t (2 - n)), [])
+ else if is_rep_fun thy x then
+ let val x' = mate_of_rep_fun thy x in
+ if is_constr thy x' then
+ select_nth_constr_arg_with_args depth Ts x' ts 0
+ (range_type T)
+ else
+ (Const x, ts)
+ end
+ else if is_equational_fun ext_ctxt x then
+ (Const x, ts)
+ else case def_of_const thy def_table x of
+ SOME def =>
+ if depth > unfold_max_depth then
+ raise LIMIT ("NitpickHOL.unfold_defs_in_term",
+ "too many nested definitions (" ^
+ string_of_int depth ^ ") while expanding " ^
+ quote s)
+ else if s = @{const_name wfrec'} then
+ (do_term (depth + 1) Ts (betapplys (def, ts)), [])
+ else
+ (do_term (depth + 1) Ts def, ts)
+ | NONE => (Const x, ts)
+ in s_betapplys (const, map (do_term depth Ts) ts) |> Envir.beta_norm end
+ in do_term 0 [] end
+
+(* theory -> typ -> term list *)
+fun codatatype_bisim_axioms thy T =
+ let
+ val xs = datatype_constrs thy T
+ val set_T = T --> bool_T
+ val iter_T = @{typ bisim_iterator}
+ val bisim_const = Const (@{const_name bisim}, [iter_T, T, T] ---> bool_T)
+ val bisim_max = @{const bisim_iterator_max}
+ val n_var = Var (("n", 0), iter_T)
+ val n_var_minus_1 =
+ Const (@{const_name Tha}, (iter_T --> bool_T) --> iter_T)
+ $ Abs ("m", iter_T, HOLogic.eq_const iter_T
+ $ (suc_const iter_T $ Bound 0) $ n_var)
+ val x_var = Var (("x", 0), T)
+ val y_var = Var (("y", 0), T)
+ (* styp -> int -> typ -> term *)
+ fun nth_sub_bisim x n nth_T =
+ (if is_codatatype thy nth_T then bisim_const $ n_var_minus_1
+ else HOLogic.eq_const nth_T)
+ $ select_nth_constr_arg thy x x_var n nth_T
+ $ select_nth_constr_arg thy x y_var n nth_T
+ (* styp -> term *)
+ fun case_func (x as (_, T)) =
+ let
+ val arg_Ts = binder_types T
+ val core_t =
+ discriminate_value thy x y_var ::
+ map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts
+ |> foldr1 s_conj
+ in List.foldr absdummy core_t arg_Ts end
+ in
+ [HOLogic.eq_const bool_T $ (bisim_const $ n_var $ x_var $ y_var)
+ $ (@{term "op |"} $ (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T)
+ $ (betapplys (optimized_case_def thy T bool_T,
+ map case_func xs @ [x_var]))),
+ HOLogic.eq_const set_T $ (bisim_const $ bisim_max $ x_var)
+ $ (Const (@{const_name insert}, [T, set_T] ---> set_T)
+ $ x_var $ Const (@{const_name bot_fun_inst.bot_fun}, set_T))]
+ |> map HOLogic.mk_Trueprop
+ end
+
+exception NO_TRIPLE of unit
+
+(* theory -> styp -> term -> term list * term list * term *)
+fun triple_for_intro_rule thy x t =
+ let
+ val prems = Logic.strip_imp_prems t |> map (ObjectLogic.atomize_term thy)
+ val concl = Logic.strip_imp_concl t |> ObjectLogic.atomize_term thy
+ val (main, side) = List.partition (exists_Const (equal x)) prems
+ (* term -> bool *)
+ val is_good_head = equal (Const x) o head_of
+ in
+ if forall is_good_head main then (side, main, concl) else raise NO_TRIPLE ()
+ end
+
+(* term -> term *)
+val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb
+
+(* indexname * typ -> term list -> term -> term -> term *)
+fun wf_constraint_for rel side concl main =
+ let
+ val core = HOLogic.mk_mem (HOLogic.mk_prod (tuple_for_args main,
+ tuple_for_args concl), Var rel)
+ val t = List.foldl HOLogic.mk_imp core side
+ val vars = filter (not_equal rel) (Term.add_vars t [])
+ in
+ Library.foldl (fn (t', ((x, j), T)) =>
+ HOLogic.all_const T
+ $ Abs (x, T, abstract_over (Var ((x, j), T), t')))
+ (t, vars)
+ end
+
+(* indexname * typ -> term list * term list * term -> term *)
+fun wf_constraint_for_triple rel (side, main, concl) =
+ map (wf_constraint_for rel side concl) main |> foldr1 s_conj
+
+(* Proof.context -> Time.time option -> thm
+ -> (Proof.context -> tactic -> tactic) -> bool *)
+fun terminates_by ctxt timeout goal tac =
+ can (SINGLE (Classical.safe_tac (claset_of ctxt)) #> the
+ #> SINGLE (DETERM_TIMEOUT timeout
+ (tac ctxt (auto_tac (clasimpset_of ctxt))))
+ #> the #> Goal.finish ctxt) goal
+
+val cached_timeout = Unsynchronized.ref (SOME Time.zeroTime)
+val cached_wf_props : (term * bool) list Unsynchronized.ref =
+ Unsynchronized.ref []
+
+val termination_tacs = [Lexicographic_Order.lex_order_tac,
+ ScnpReconstruct.sizechange_tac]
+
+(* extended_context -> const_table -> styp -> bool *)
+fun is_is_well_founded_inductive_pred
+ ({thy, ctxt, debug, fast_descrs, tac_timeout, intro_table, ...}
+ : extended_context) (x as (_, T)) =
+ case def_props_for_const thy fast_descrs intro_table x of
+ [] => raise TERM ("NitpickHOL.is_is_well_founded_inductive_pred", [Const x])
+ | intro_ts =>
+ (case map (triple_for_intro_rule thy x) intro_ts
+ |> filter_out (null o #2) of
+ [] => true
+ | triples =>
+ let
+ val binders_T = HOLogic.mk_tupleT (binder_types T)
+ val rel_T = HOLogic.mk_prodT (binders_T, binders_T) --> bool_T
+ val j = List.foldl Int.max 0 (map maxidx_of_term intro_ts) + 1
+ val rel = (("R", j), rel_T)
+ val prop = Const (@{const_name wf}, rel_T --> bool_T) $ Var rel ::
+ map (wf_constraint_for_triple rel) triples
+ |> foldr1 s_conj |> HOLogic.mk_Trueprop
+ val _ = if debug then
+ priority ("Wellfoundedness goal: " ^
+ Syntax.string_of_term ctxt prop ^ ".")
+ else
+ ()
+ in
+ if tac_timeout = (!cached_timeout) then ()
+ else (cached_wf_props := []; cached_timeout := tac_timeout);
+ case AList.lookup (op =) (!cached_wf_props) prop of
+ SOME wf => wf
+ | NONE =>
+ let
+ val goal = prop |> cterm_of thy |> Goal.init
+ val wf = silence (exists (terminates_by ctxt tac_timeout goal))
+ termination_tacs
+ in Unsynchronized.change cached_wf_props (cons (prop, wf)); wf end
+ end)
+ handle List.Empty => false
+ | NO_TRIPLE () => false
+
+(* The type constraint below is a workaround for a Poly/ML bug. *)
+
+(* extended_context -> styp -> bool *)
+fun is_well_founded_inductive_pred
+ (ext_ctxt as {thy, wfs, def_table, wf_cache, ...} : extended_context)
+ (x as (s, _)) =
+ case triple_lookup (const_match thy) wfs x of
+ SOME (SOME b) => b
+ | _ => s mem [@{const_name Nats}, @{const_name fold_graph'}]
+ orelse case AList.lookup (op =) (!wf_cache) x of
+ SOME (_, wf) => wf
+ | NONE =>
+ let
+ val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
+ val wf = is_is_well_founded_inductive_pred ext_ctxt x
+ in
+ Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
+ end
+
+(* typ list -> typ -> typ -> term -> term *)
+fun ap_curry [_] _ _ t = t
+ | ap_curry arg_Ts tuple_T body_T t =
+ let val n = length arg_Ts in
+ list_abs (map (pair "c") arg_Ts,
+ incr_boundvars n t
+ $ mk_flat_tuple tuple_T (map Bound (n - 1 downto 0)))
+ end
+
+(* int -> term -> int *)
+fun num_occs_of_bound_in_term j (t1 $ t2) =
+ op + (pairself (num_occs_of_bound_in_term j) (t1, t2))
+ | num_occs_of_bound_in_term j (Abs (s, T, t')) =
+ num_occs_of_bound_in_term (j + 1) t'
+ | num_occs_of_bound_in_term j (Bound j') = if j' = j then 1 else 0
+ | num_occs_of_bound_in_term _ _ = 0
+
+(* term -> bool *)
+val is_linear_inductive_pred_def =
+ let
+ (* int -> term -> bool *)
+ fun do_disjunct j (Const (@{const_name Ex}, _) $ Abs (_, _, t2)) =
+ do_disjunct (j + 1) t2
+ | do_disjunct j t =
+ case num_occs_of_bound_in_term j t of
+ 0 => true
+ | 1 => exists (equal (Bound j) o head_of) (conjuncts t)
+ | _ => false
+ (* term -> bool *)
+ fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) =
+ let val (xs, body) = strip_abs t2 in
+ case length xs of
+ 1 => false
+ | n => forall (do_disjunct (n - 1)) (disjuncts body)
+ end
+ | do_lfp_def _ = false
+ in do_lfp_def o strip_abs_body end
+
+(* typ -> typ -> term -> term *)
+fun ap_split tuple_T =
+ HOLogic.mk_psplits (HOLogic.flat_tupleT_paths tuple_T) tuple_T
+
+(* term -> term * term *)
+val linear_pred_base_and_step_rhss =
+ let
+ (* term -> term *)
+ fun aux (Const (@{const_name lfp}, _) $ t2) =
+ let
+ val (xs, body) = strip_abs t2
+ val arg_Ts = map snd (tl xs)
+ val tuple_T = HOLogic.mk_tupleT arg_Ts
+ val j = length arg_Ts
+ (* int -> term -> term *)
+ fun repair_rec j (Const (@{const_name Ex}, T1) $ Abs (s2, T2, t2')) =
+ Const (@{const_name Ex}, T1)
+ $ Abs (s2, T2, repair_rec (j + 1) t2')
+ | repair_rec j (@{const "op &"} $ t1 $ t2) =
+ @{const "op &"} $ repair_rec j t1 $ repair_rec j t2
+ | repair_rec j t =
+ let val (head, args) = strip_comb t in
+ if head = Bound j then
+ HOLogic.eq_const tuple_T $ Bound j
+ $ mk_flat_tuple tuple_T args
+ else
+ t
+ end
+ val (nonrecs, recs) =
+ List.partition (equal 0 o num_occs_of_bound_in_term j)
+ (disjuncts body)
+ val base_body = nonrecs |> List.foldl s_disj @{const False}
+ val step_body = recs |> map (repair_rec j)
+ |> List.foldl s_disj @{const False}
+ in
+ (list_abs (tl xs, incr_bv (~1, j, base_body))
+ |> ap_split tuple_T bool_T,
+ Abs ("y", tuple_T, list_abs (tl xs, step_body)
+ |> ap_split tuple_T bool_T))
+ end
+ | aux t =
+ raise TERM ("NitpickHOL.linear_pred_base_and_step_rhss.aux", [t])
+ in aux end
+
+(* extended_context -> styp -> term -> term *)
+fun closed_linear_pred_const (ext_ctxt as {simp_table, ...}) (x as (s, T)) def =
+ let
+ val j = maxidx_of_term def + 1
+ val (outer, fp_app) = strip_abs def
+ val outer_bounds = map Bound (length outer - 1 downto 0)
+ val outer_vars = map (fn (s, T) => Var ((s, j), T)) outer
+ val fp_app = subst_bounds (rev outer_vars, fp_app)
+ val (outer_Ts, rest_T) = strip_n_binders (length outer) T
+ val tuple_arg_Ts = strip_type rest_T |> fst
+ val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
+ val set_T = tuple_T --> bool_T
+ val curried_T = tuple_T --> set_T
+ val uncurried_T = Type ("*", [tuple_T, tuple_T]) --> bool_T
+ val (base_rhs, step_rhs) = linear_pred_base_and_step_rhss fp_app
+ val base_x as (base_s, _) = (base_prefix ^ s, outer_Ts ---> set_T)
+ val base_eq = HOLogic.mk_eq (list_comb (Const base_x, outer_vars), base_rhs)
+ |> HOLogic.mk_Trueprop
+ val _ = add_simps simp_table base_s [base_eq]
+ val step_x as (step_s, _) = (step_prefix ^ s, outer_Ts ---> curried_T)
+ val step_eq = HOLogic.mk_eq (list_comb (Const step_x, outer_vars), step_rhs)
+ |> HOLogic.mk_Trueprop
+ val _ = add_simps simp_table step_s [step_eq]
+ in
+ list_abs (outer,
+ Const (@{const_name Image}, uncurried_T --> set_T --> set_T)
+ $ (Const (@{const_name rtrancl}, uncurried_T --> uncurried_T)
+ $ (Const (@{const_name split}, curried_T --> uncurried_T)
+ $ list_comb (Const step_x, outer_bounds)))
+ $ list_comb (Const base_x, outer_bounds)
+ |> ap_curry tuple_arg_Ts tuple_T bool_T)
+ |> unfold_defs_in_term ext_ctxt
+ end
+
+(* extended_context -> bool -> styp -> term *)
+fun unrolled_inductive_pred_const (ext_ctxt as {thy, star_linear_preds,
+ def_table, simp_table, ...})
+ gfp (x as (s, T)) =
+ let
+ val iter_T = iterator_type_for_const gfp x
+ val x' as (s', _) = (unrolled_prefix ^ s, iter_T --> T)
+ val unrolled_const = Const x' $ zero_const iter_T
+ val def = the (def_of_const thy def_table x)
+ in
+ if is_equational_fun ext_ctxt x' then
+ unrolled_const (* already done *)
+ else if not gfp andalso is_linear_inductive_pred_def def
+ andalso star_linear_preds then
+ closed_linear_pred_const ext_ctxt x def
+ else
+ let
+ val j = maxidx_of_term def + 1
+ val (outer, fp_app) = strip_abs def
+ val outer_bounds = map Bound (length outer - 1 downto 0)
+ val cur = Var ((iter_var_prefix, j + 1), iter_T)
+ val next = suc_const iter_T $ cur
+ val rhs = case fp_app of
+ Const _ $ t =>
+ betapply (t, list_comb (Const x', next :: outer_bounds))
+ | _ => raise TERM ("NitpickHOL.unrolled_inductive_pred_const",
+ [fp_app])
+ val (inner, naked_rhs) = strip_abs rhs
+ val all = outer @ inner
+ val bounds = map Bound (length all - 1 downto 0)
+ val vars = map (fn (s, T) => Var ((s, j), T)) all
+ val eq = HOLogic.mk_eq (list_comb (Const x', cur :: bounds), naked_rhs)
+ |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
+ val _ = add_simps simp_table s' [eq]
+ in unrolled_const end
+ end
+
+(* extended_context -> styp -> term *)
+fun raw_inductive_pred_axiom ({thy, def_table, ...} : extended_context) x =
+ let
+ val def = the (def_of_const thy def_table x)
+ val (outer, fp_app) = strip_abs def
+ val outer_bounds = map Bound (length outer - 1 downto 0)
+ val rhs = case fp_app of
+ Const _ $ t => betapply (t, list_comb (Const x, outer_bounds))
+ | _ => raise TERM ("NitpickHOL.raw_inductive_pred_axiom",
+ [fp_app])
+ val (inner, naked_rhs) = strip_abs rhs
+ val all = outer @ inner
+ val bounds = map Bound (length all - 1 downto 0)
+ val j = maxidx_of_term def + 1
+ val vars = map (fn (s, T) => Var ((s, j), T)) all
+ in
+ HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs)
+ |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
+ end
+fun inductive_pred_axiom ext_ctxt (x as (s, T)) =
+ if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then
+ let val x' = (after_name_sep s, T) in
+ raw_inductive_pred_axiom ext_ctxt x' |> subst_atomic [(Const x', Const x)]
+ end
+ else
+ raw_inductive_pred_axiom ext_ctxt x
+
+(* extended_context -> styp -> term list *)
+fun raw_equational_fun_axioms (ext_ctxt as {thy, fast_descrs, simp_table,
+ psimp_table, ...}) (x as (s, _)) =
+ if s mem redefined_in_NitpickDefs_thy then
+ []
+ else case def_props_for_const thy fast_descrs (!simp_table) x of
+ [] => (case def_props_for_const thy fast_descrs psimp_table x of
+ [] => [inductive_pred_axiom ext_ctxt x]
+ | psimps => psimps)
+ | simps => simps
+
+val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
+
+(* term list -> term list *)
+fun coalesce_type_vars_in_terms ts =
+ let
+ (* typ -> (sort * string) list -> (sort * string) list *)
+ fun add_type (TFree (s, S)) table =
+ (case AList.lookup (op =) table S of
+ SOME s' =>
+ if string_ord (s', s) = LESS then AList.update (op =) (S, s') table
+ else table
+ | NONE => (S, s) :: table)
+ | add_type _ table = table
+ val table = fold (fold_types (fold_atyps add_type)) ts []
+ (* typ -> typ *)
+ fun coalesce (TFree (s, S)) = TFree (AList.lookup (op =) table S |> the, S)
+ | coalesce T = T
+ in map (map_types (map_atyps coalesce)) ts end
+
+(* extended_context -> typ -> typ list -> typ list *)
+fun add_ground_types ext_ctxt T accum =
+ case T of
+ Type ("fun", Ts) => fold (add_ground_types ext_ctxt) Ts accum
+ | Type ("*", Ts) => fold (add_ground_types ext_ctxt) Ts accum
+ | Type (@{type_name itself}, [T1]) => add_ground_types ext_ctxt T1 accum
+ | Type (_, Ts) =>
+ if T mem @{typ prop} :: @{typ bool} :: @{typ unit} :: accum then
+ accum
+ else
+ T :: accum
+ |> fold (add_ground_types ext_ctxt)
+ (case boxed_datatype_constrs ext_ctxt T of
+ [] => Ts
+ | xs => map snd xs)
+ | _ => insert (op =) T accum
+(* extended_context -> typ -> typ list *)
+fun ground_types_in_type ext_ctxt T = add_ground_types ext_ctxt T []
+(* extended_context -> term list -> typ list *)
+fun ground_types_in_terms ext_ctxt ts =
+ fold (fold_types (add_ground_types ext_ctxt)) ts []
+
+(* typ list -> int -> term -> bool *)
+fun has_heavy_bounds_or_vars Ts level t =
+ let
+ (* typ list -> bool *)
+ fun aux [] = false
+ | aux [T] = is_fun_type T orelse is_pair_type T
+ | aux _ = true
+ in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
+
+(* typ list -> int -> int -> int -> term -> term *)
+fun fresh_value_var Ts k n j t =
+ Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
+
+(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
+ -> term * term list *)
+fun pull_out_constr_comb thy Ts relax k level t args seen =
+ let val t_comb = list_comb (t, args) in
+ case t of
+ Const x =>
+ if not relax andalso is_constr thy x
+ andalso not (is_fun_type (fastype_of1 (Ts, t_comb)))
+ andalso has_heavy_bounds_or_vars Ts level t_comb
+ andalso not (loose_bvar (t_comb, level)) then
+ let
+ val (j, seen) = case find_index (equal t_comb) seen of
+ ~1 => (0, t_comb :: seen)
+ | j => (j, seen)
+ in (fresh_value_var Ts k (length seen) j t_comb, seen) end
+ else
+ (t_comb, seen)
+ | _ => (t_comb, seen)
+ end
+
+(* (term -> term) -> typ list -> int -> term list -> term list *)
+fun equations_for_pulled_out_constrs mk_eq Ts k seen =
+ let val n = length seen in
+ map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
+ (index_seq 0 n) seen
+ end
+
+(* theory -> bool -> term -> term *)
+fun pull_out_universal_constrs thy def t =
+ let
+ val k = maxidx_of_term t + 1
+ (* typ list -> bool -> term -> term list -> term list -> term * term list *)
+ fun do_term Ts def t args seen =
+ case t of
+ (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
+ do_eq_or_imp Ts def t0 t1 t2 seen
+ | (t0 as @{const "==>"}) $ t1 $ t2 => do_eq_or_imp Ts def t0 t1 t2 seen
+ | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
+ do_eq_or_imp Ts def t0 t1 t2 seen
+ | (t0 as @{const "op -->"}) $ t1 $ t2 => do_eq_or_imp Ts def t0 t1 t2 seen
+ | Abs (s, T, t') =>
+ let val (t', seen) = do_term (T :: Ts) def t' [] seen in
+ (list_comb (Abs (s, T, t'), args), seen)
+ end
+ | t1 $ t2 =>
+ let val (t2, seen) = do_term Ts def t2 [] seen in
+ do_term Ts def t1 (t2 :: args) seen
+ end
+ | _ => pull_out_constr_comb thy Ts def k 0 t args seen
+ (* typ list -> bool -> term -> term -> term -> term list
+ -> term * term list *)
+ and do_eq_or_imp Ts def t0 t1 t2 seen =
+ let
+ val (t2, seen) = do_term Ts def t2 [] seen
+ val (t1, seen) = do_term Ts false t1 [] seen
+ in (t0 $ t1 $ t2, seen) end
+ val (concl, seen) = do_term [] def t [] []
+ in
+ Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
+ seen, concl)
+ end
+
+(* theory -> bool -> term -> term *)
+fun destroy_pulled_out_constrs thy axiom t =
+ let
+ (* styp -> int *)
+ val num_occs_of_var =
+ fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
+ | _ => I) t (K 0)
+ (* bool -> term -> term *)
+ fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
+ aux_eq careful true t0 t1 t2
+ | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
+ t0 $ aux false t1 $ aux careful t2
+ | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
+ aux_eq careful true t0 t1 t2
+ | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
+ t0 $ aux false t1 $ aux careful t2
+ | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
+ | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
+ | aux _ t = t
+ (* bool -> bool -> term -> term -> term -> term *)
+ and aux_eq careful pass1 t0 t1 t2 =
+ (if careful then
+ raise SAME ()
+ else if axiom andalso is_Var t2
+ andalso num_occs_of_var (dest_Var t2) = 1 then
+ @{const True}
+ else case strip_comb t2 of
+ (Const (x as (s, T)), args) =>
+ let val arg_Ts = binder_types T in
+ if length arg_Ts = length args
+ andalso (is_constr thy x orelse s mem [@{const_name Pair}]
+ orelse x = dest_Const @{const Suc})
+ andalso (not careful orelse not (is_Var t1)
+ orelse String.isPrefix val_var_prefix
+ (fst (fst (dest_Var t1)))) then
+ discriminate_value thy x t1 ::
+ map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
+ |> foldr1 s_conj
+ |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop
+ else
+ raise SAME ()
+ end
+ | _ => raise SAME ())
+ handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
+ else t0 $ aux false t2 $ aux false t1
+ (* styp -> term -> int -> typ -> term -> term *)
+ and sel_eq x t n nth_T nth_t =
+ HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
+ |> aux false
+ in aux axiom t end
+
+(* theory -> term -> term *)
+fun simplify_constrs_and_sels thy t =
+ let
+ (* term -> int -> term *)
+ fun is_nth_sel_on t' n (Const (s, _) $ t) =
+ (t = t' andalso is_sel_like_and_no_discr s
+ andalso sel_no_from_name s = n)
+ | is_nth_sel_on _ _ _ = false
+ (* term -> term list -> term *)
+ fun do_term (Const (@{const_name Rep_Frac}, _)
+ $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
+ | do_term (Const (@{const_name Abs_Frac}, _)
+ $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
+ | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
+ | do_term (t as Const (x as (s, T))) (args as _ :: _) =
+ ((if is_constr_like thy x then
+ if length args = num_binder_types T then
+ case hd args of
+ Const (x' as (_, T')) $ t' =>
+ if domain_type T' = body_type T
+ andalso forall (uncurry (is_nth_sel_on t'))
+ (index_seq 0 (length args) ~~ args) then
+ t'
+ else
+ raise SAME ()
+ | _ => raise SAME ()
+ else
+ raise SAME ()
+ else if is_sel_like_and_no_discr s then
+ case strip_comb (hd args) of
+ (Const (x' as (s', T')), ts') =>
+ if is_constr_like thy x'
+ andalso constr_name_for_sel_like s = s'
+ andalso not (exists is_pair_type (binder_types T')) then
+ list_comb (nth ts' (sel_no_from_name s), tl args)
+ else
+ raise SAME ()
+ | _ => raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => betapplys (t, args))
+ | do_term (Abs (s, T, t')) args =
+ betapplys (Abs (s, T, do_term t' []), args)
+ | do_term t args = betapplys (t, args)
+ in do_term t [] end
+
+(* term -> term *)
+fun curry_assms (@{const "==>"} $ (@{const Trueprop}
+ $ (@{const "op &"} $ t1 $ t2)) $ t3) =
+ curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
+ | curry_assms (@{const "==>"} $ t1 $ t2) =
+ @{const "==>"} $ curry_assms t1 $ curry_assms t2
+ | curry_assms t = t
+
+(* term -> term *)
+val destroy_universal_equalities =
+ let
+ (* term list -> (indexname * typ) list -> term -> term *)
+ fun aux prems zs t =
+ case t of
+ @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
+ | _ => Logic.list_implies (rev prems, t)
+ (* term list -> (indexname * typ) list -> term -> term -> term *)
+ and aux_implies prems zs t1 t2 =
+ case t1 of
+ Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
+ | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
+ aux_eq prems zs z t' t1 t2
+ | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
+ aux_eq prems zs z t' t1 t2
+ | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
+ (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
+ -> term -> term *)
+ and aux_eq prems zs z t' t1 t2 =
+ if not (z mem zs) andalso not (exists_subterm (equal (Var z)) t') then
+ aux prems zs (subst_free [(Var z, t')] t2)
+ else
+ aux (t1 :: prems) (Term.add_vars t1 zs) t2
+ in aux [] [] end
+
+(* theory -> term -> term *)
+fun pull_out_existential_constrs thy t =
+ let
+ val k = maxidx_of_term t + 1
+ (* typ list -> int -> term -> term list -> term list -> term * term list *)
+ fun aux Ts num_exists t args seen =
+ case t of
+ (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
+ let
+ val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
+ val n = length seen'
+ (* unit -> term list *)
+ fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
+ in
+ (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
+ |> List.foldl s_conj t1 |> fold mk_exists (vars ())
+ |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
+ end
+ | t1 $ t2 =>
+ let val (t2, seen) = aux Ts num_exists t2 [] seen in
+ aux Ts num_exists t1 (t2 :: args) seen
+ end
+ | Abs (s, T, t') =>
+ let
+ val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
+ in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
+ | _ =>
+ if num_exists > 0 then
+ pull_out_constr_comb thy Ts false k num_exists t args seen
+ else
+ (list_comb (t, args), seen)
+ in aux [] 0 t [] [] |> fst end
+
+(* theory -> int -> term list -> term list -> (term * term list) option *)
+fun find_bound_assign _ _ _ [] = NONE
+ | find_bound_assign thy j seen (t :: ts) =
+ let
+ (* bool -> term -> term -> (term * term list) option *)
+ fun aux pass1 t1 t2 =
+ (if loose_bvar1 (t2, j) then
+ if pass1 then aux false t2 t1 else raise SAME ()
+ else case t1 of
+ Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
+ | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
+ if j' = j andalso s = sel_prefix_for 0 ^ @{const_name FunBox} then
+ SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
+ ts @ seen)
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => find_bound_assign thy j (t :: seen) ts
+ in
+ case t of
+ Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
+ | _ => find_bound_assign thy j (t :: seen) ts
+ end
+
+(* int -> term -> term -> term *)
+fun subst_one_bound j arg t =
+ let
+ fun aux (Bound i, lev) =
+ if i < lev then raise SAME ()
+ else if i = lev then incr_boundvars (lev - j) arg
+ else Bound (i - 1)
+ | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
+ | aux (f $ t, lev) =
+ (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
+ handle SAME () => f $ aux (t, lev))
+ | aux _ = raise SAME ()
+ in aux (t, j) handle SAME () => t end
+
+(* theory -> term -> term *)
+fun destroy_existential_equalities thy =
+ let
+ (* string list -> typ list -> term list -> term *)
+ fun kill [] [] ts = foldr1 s_conj ts
+ | kill (s :: ss) (T :: Ts) ts =
+ (case find_bound_assign thy (length ss) [] ts of
+ SOME (_, []) => @{const True}
+ | SOME (arg_t, ts) =>
+ kill ss Ts (map (subst_one_bound (length ss)
+ (incr_bv (~1, length ss + 1, arg_t))) ts)
+ | NONE =>
+ Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
+ $ Abs (s, T, kill ss Ts ts))
+ | kill _ _ _ = raise UnequalLengths
+ (* string list -> typ list -> term -> term *)
+ fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
+ gather (ss @ [s1]) (Ts @ [T1]) t1
+ | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
+ | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
+ | gather [] [] t = t
+ | gather ss Ts t = kill ss Ts (conjuncts (gather [] [] t))
+ in gather [] [] end
+
+(* term -> term *)
+fun distribute_quantifiers t =
+ case t of
+ (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
+ (case t1 of
+ (t10 as @{const "op &"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const Not}) $ t11 =>
+ t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
+ $ Abs (s, T1, t11))
+ | t1 =>
+ if not (loose_bvar1 (t1, 0)) then
+ distribute_quantifiers (incr_boundvars ~1 t1)
+ else
+ t0 $ Abs (s, T1, distribute_quantifiers t1))
+ | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
+ (case distribute_quantifiers t1 of
+ (t10 as @{const "op |"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const "op -->"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
+ $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const Not}) $ t11 =>
+ t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
+ $ Abs (s, T1, t11))
+ | t1 =>
+ if not (loose_bvar1 (t1, 0)) then
+ distribute_quantifiers (incr_boundvars ~1 t1)
+ else
+ t0 $ Abs (s, T1, distribute_quantifiers t1))
+ | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
+ | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
+ | _ => t
+
+(* int -> int -> (int -> int) -> term -> term *)
+fun renumber_bounds j n f t =
+ case t of
+ t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
+ | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
+ | Bound j' =>
+ Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
+ | _ => t
+
+val quantifier_cluster_max_size = 8
+
+(* theory -> term -> term *)
+fun push_quantifiers_inward thy =
+ let
+ (* string -> string list -> typ list -> term -> term *)
+ fun aux quant_s ss Ts t =
+ (case t of
+ (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
+ if s0 = quant_s andalso length Ts < quantifier_cluster_max_size then
+ aux s0 (s1 :: ss) (T1 :: Ts) t1
+ else if quant_s = ""
+ andalso s0 mem [@{const_name All}, @{const_name Ex}] then
+ aux s0 [s1] [T1] t1
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ case t of
+ t1 $ t2 =>
+ if quant_s = "" then
+ aux "" [] [] t1 $ aux "" [] [] t2
+ else
+ let
+ val typical_card = 4
+ (* ('a -> ''b list) -> 'a list -> ''b list *)
+ fun big_union proj ps =
+ fold (fold (insert (op =)) o proj) ps []
+ val (ts, connective) = strip_any_connective t
+ val T_costs =
+ map (bounded_card_of_type 65536 typical_card []) Ts
+ val t_costs = map size_of_term ts
+ val num_Ts = length Ts
+ (* int -> int *)
+ val flip = curry (op -) (num_Ts - 1)
+ val t_boundss = map (map flip o loose_bnos) ts
+ (* (int list * int) list -> int list -> int *)
+ fun cost boundss_cum_costs [] =
+ map snd boundss_cum_costs |> Integer.sum
+ | cost boundss_cum_costs (j :: js) =
+ let
+ val (yeas, nays) =
+ List.partition (fn (bounds, _) => j mem bounds)
+ boundss_cum_costs
+ val yeas_bounds = big_union fst yeas
+ val yeas_cost = Integer.sum (map snd yeas)
+ * nth T_costs j
+ in cost ((yeas_bounds, yeas_cost) :: nays) js end
+ val js = all_permutations (index_seq 0 num_Ts)
+ |> map (`(cost (t_boundss ~~ t_costs)))
+ |> sort (int_ord o pairself fst) |> hd |> snd
+ val back_js = map (fn j => find_index (equal j) js)
+ (index_seq 0 num_Ts)
+ val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
+ ts
+ (* (term * int list) list -> term *)
+ fun mk_connection [] =
+ raise ARG ("NitpickHOL.push_quantifiers_inward.aux.\
+ \mk_connection", "")
+ | mk_connection ts_cum_bounds =
+ ts_cum_bounds |> map fst
+ |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
+ (* (term * int list) list -> int list -> term *)
+ fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
+ | build ts_cum_bounds (j :: js) =
+ let
+ val (yeas, nays) =
+ List.partition (fn (_, bounds) => j mem bounds)
+ ts_cum_bounds
+ ||> map (apfst (incr_boundvars ~1))
+ in
+ if null yeas then
+ build nays js
+ else
+ let val T = nth Ts (flip j) in
+ build ((Const (quant_s, (T --> bool_T) --> bool_T)
+ $ Abs (nth ss (flip j), T,
+ mk_connection yeas),
+ big_union snd yeas) :: nays) js
+ end
+ end
+ in build (ts ~~ t_boundss) js end
+ | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
+ | _ => t
+ in aux "" [] [] end
+
+(* polarity -> string -> bool *)
+fun is_positive_existential polar quant_s =
+ (polar = Pos andalso quant_s = @{const_name Ex})
+ orelse (polar = Neg andalso quant_s <> @{const_name Ex})
+
+(* extended_context -> int -> term -> term *)
+fun skolemize_term_and_more (ext_ctxt as {thy, def_table, skolems, ...})
+ skolem_depth =
+ let
+ (* int list -> int list *)
+ val incrs = map (Integer.add 1)
+ (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
+ fun aux ss Ts js depth polar t =
+ let
+ (* string -> typ -> string -> typ -> term -> term *)
+ fun do_quantifier quant_s quant_T abs_s abs_T t =
+ if not (loose_bvar1 (t, 0)) then
+ aux ss Ts js depth polar (incr_boundvars ~1 t)
+ else if depth <= skolem_depth
+ andalso is_positive_existential polar quant_s then
+ let
+ val j = length (!skolems) + 1
+ val sko_s = skolem_prefix_for (length js) j ^ abs_s
+ val _ = Unsynchronized.change skolems (cons (sko_s, ss))
+ val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
+ map Bound (rev js))
+ val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
+ in
+ if null js then betapply (abs_t, sko_t)
+ else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
+ end
+ else
+ Const (quant_s, quant_T)
+ $ Abs (abs_s, abs_T,
+ if is_higher_order_type abs_T then
+ t
+ else
+ aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
+ (depth + 1) polar t)
+ in
+ case t of
+ Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | @{const "==>"} $ t1 $ t2 =>
+ @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
+ $ aux ss Ts js depth polar t2
+ | @{const Pure.conjunction} $ t1 $ t2 =>
+ @{const Pure.conjunction} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const Trueprop} $ t1 =>
+ @{const Trueprop} $ aux ss Ts js depth polar t1
+ | @{const Not} $ t1 =>
+ @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
+ | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | @{const "op &"} $ t1 $ t2 =>
+ @{const "op &"} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const "op |"} $ t1 $ t2 =>
+ @{const "op |"} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const "op -->"} $ t1 $ t2 =>
+ @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
+ $ aux ss Ts js depth polar t2
+ | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
+ t0 $ t1 $ aux ss Ts js depth polar t2
+ | Const (x as (s, T)) =>
+ if is_inductive_pred ext_ctxt x
+ andalso not (is_well_founded_inductive_pred ext_ctxt x) then
+ let
+ val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
+ val (pref, connective, set_oper) =
+ if gfp then
+ (lbfp_prefix,
+ @{const "op |"},
+ @{const_name upper_semilattice_fun_inst.sup_fun})
+ else
+ (ubfp_prefix,
+ @{const "op &"},
+ @{const_name lower_semilattice_fun_inst.inf_fun})
+ (* unit -> term *)
+ fun pos () = unrolled_inductive_pred_const ext_ctxt gfp x
+ |> aux ss Ts js depth polar
+ fun neg () = Const (pref ^ s, T)
+ in
+ (case polar |> gfp ? flip_polarity of
+ Pos => pos ()
+ | Neg => neg ()
+ | Neut =>
+ if is_fun_type T then
+ let
+ val ((trunk_arg_Ts, rump_arg_T), body_T) =
+ T |> strip_type |>> split_last
+ val set_T = rump_arg_T --> body_T
+ (* (unit -> term) -> term *)
+ fun app f =
+ list_comb (f (),
+ map Bound (length trunk_arg_Ts - 1 downto 0))
+ in
+ List.foldl absdummy
+ (Const (set_oper, [set_T, set_T] ---> set_T)
+ $ app pos $ app neg) trunk_arg_Ts
+ end
+ else
+ connective $ pos () $ neg ())
+ end
+ else
+ Const x
+ | t1 $ t2 =>
+ betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
+ aux ss Ts [] depth Neut t2)
+ | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
+ | _ => t
+ end
+ in aux [] [] [] 0 Pos end
+
+(* extended_context -> styp -> (int * term option) list *)
+fun static_args_in_term ({ersatz_table, ...} : extended_context) x t =
+ let
+ (* term -> term list -> term list -> term list list *)
+ fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
+ | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
+ | fun_calls t args =
+ (case t of
+ Const (x' as (s', T')) =>
+ x = x' orelse (case AList.lookup (op =) ersatz_table s' of
+ SOME s'' => x = (s'', T')
+ | NONE => false)
+ | _ => false) ? cons args
+ (* term list list -> term list list -> term list -> term list list *)
+ fun call_sets [] [] vs = [vs]
+ | call_sets [] uss vs = vs :: call_sets uss [] []
+ | call_sets ([] :: _) _ _ = []
+ | call_sets ((t :: ts) :: tss) uss vs =
+ OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
+ val sets = call_sets (fun_calls t [] []) [] []
+ val indexed_sets = sets ~~ (index_seq 0 (length sets))
+ in
+ fold_rev (fn (set, j) =>
+ case set of
+ [Var _] => AList.lookup (op =) indexed_sets set = SOME j
+ ? cons (j, NONE)
+ | [t as Const _] => cons (j, SOME t)
+ | [t as Free _] => cons (j, SOME t)
+ | _ => I) indexed_sets []
+ end
+(* extended_context -> styp -> term list -> (int * term option) list *)
+fun static_args_in_terms ext_ctxt x =
+ map (static_args_in_term ext_ctxt x)
+ #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
+
+(* term -> term list *)
+fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
+ | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
+ | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
+ snd (strip_comb t1)
+ | params_in_equation _ = []
+
+(* styp -> styp -> int list -> term list -> term list -> term -> term *)
+fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
+ let
+ val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
+ + 1
+ val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
+ val fixed_params = filter_indices fixed_js (params_in_equation t)
+ (* term list -> term -> term *)
+ fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
+ | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
+ | aux args t =
+ if t = Const x then
+ list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
+ else
+ let val j = find_index (equal t) fixed_params in
+ list_comb (if j >= 0 then nth fixed_args j else t, args)
+ end
+ in aux [] t end
+
+(* typ list -> term -> bool *)
+fun is_eligible_arg Ts t =
+ let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
+ null bad_Ts
+ orelse (is_higher_order_type (fastype_of1 (Ts, t))
+ andalso forall (not o is_higher_order_type) bad_Ts)
+ end
+
+(* (int * term option) list -> (int * term) list -> int list *)
+fun overlapping_indices [] _ = []
+ | overlapping_indices _ [] = []
+ | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
+ if j1 < j2 then overlapping_indices ps1' ps2
+ else if j1 > j2 then overlapping_indices ps1 ps2'
+ else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
+
+val special_depth = 20
+
+(* extended_context -> int -> term -> term *)
+fun specialize_consts_in_term (ext_ctxt as {thy, specialize, simp_table,
+ special_funs, ...}) depth t =
+ if not specialize orelse depth > special_depth then
+ t
+ else
+ let
+ (* FIXME: strong enough in the face of user-defined axioms? *)
+ val blacklist = if depth = 0 then []
+ else case term_under_def t of Const x => [x] | _ => []
+ (* term list -> typ list -> term -> term *)
+ fun aux args Ts (Const (x as (s, T))) =
+ ((if not (x mem blacklist) andalso not (null args)
+ andalso not (String.isPrefix special_prefix s)
+ andalso is_equational_fun ext_ctxt x then
+ let
+ val eligible_args = filter (is_eligible_arg Ts o snd)
+ (index_seq 0 (length args) ~~ args)
+ val _ = not (null eligible_args) orelse raise SAME ()
+ val old_axs = equational_fun_axioms ext_ctxt x
+ |> map (destroy_existential_equalities thy)
+ val static_params = static_args_in_terms ext_ctxt x old_axs
+ val fixed_js = overlapping_indices static_params eligible_args
+ val _ = not (null fixed_js) orelse raise SAME ()
+ val fixed_args = filter_indices fixed_js args
+ val vars = fold Term.add_vars fixed_args []
+ |> sort (TermOrd.fast_indexname_ord o pairself fst)
+ val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
+ fixed_args []
+ |> sort int_ord
+ val live_args = filter_out_indices fixed_js args
+ val extra_args = map Var vars @ map Bound bound_js @ live_args
+ val extra_Ts = map snd vars @ filter_indices bound_js Ts
+ val k = maxidx_of_term t + 1
+ (* int -> term *)
+ fun var_for_bound_no j =
+ Var ((bound_var_prefix ^
+ nat_subscript (find_index (equal j) bound_js + 1), k),
+ nth Ts j)
+ val fixed_args_in_axiom =
+ map (curry subst_bounds
+ (map var_for_bound_no (index_seq 0 (length Ts))))
+ fixed_args
+ in
+ case AList.lookup (op =) (!special_funs)
+ (x, fixed_js, fixed_args_in_axiom) of
+ SOME x' => list_comb (Const x', extra_args)
+ | NONE =>
+ let
+ val extra_args_in_axiom =
+ map Var vars @ map var_for_bound_no bound_js
+ val x' as (s', _) =
+ (special_prefix_for (length (!special_funs) + 1) ^ s,
+ extra_Ts @ filter_out_indices fixed_js (binder_types T)
+ ---> body_type T)
+ val new_axs =
+ map (specialize_fun_axiom x x' fixed_js
+ fixed_args_in_axiom extra_args_in_axiom) old_axs
+ val _ =
+ Unsynchronized.change special_funs
+ (cons ((x, fixed_js, fixed_args_in_axiom), x'))
+ val _ = add_simps simp_table s' new_axs
+ in list_comb (Const x', extra_args) end
+ end
+ else
+ raise SAME ())
+ handle SAME () => list_comb (Const x, args))
+ | aux args Ts (Abs (s, T, t)) =
+ list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
+ | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
+ | aux args _ t = list_comb (t, args)
+ in aux [] [] t end
+
+(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
+fun add_to_uncurry_table thy t =
+ let
+ (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
+ fun aux (t1 $ t2) args table =
+ let val table = aux t2 [] table in aux t1 (t2 :: args) table end
+ | aux (Abs (_, _, t')) _ table = aux t' [] table
+ | aux (t as Const (x as (s, _))) args table =
+ if is_built_in_const false x orelse is_constr_like thy x orelse is_sel s
+ orelse s = @{const_name Sigma} then
+ table
+ else
+ Termtab.map_default (t, 65536) (curry Int.min (length args)) table
+ | aux _ _ table = table
+ in aux t [] end
+
+(* int Termtab.tab term -> term *)
+fun uncurry_term table t =
+ let
+ (* term -> term list -> term *)
+ fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
+ | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
+ | aux (t as Const (s, T)) args =
+ (case Termtab.lookup table t of
+ SOME n =>
+ if n >= 2 then
+ let
+ val (arg_Ts, rest_T) = strip_n_binders n T
+ val j =
+ if hd arg_Ts = @{typ bisim_iterator}
+ orelse is_fp_iterator_type (hd arg_Ts) then
+ 1
+ else case find_index (not_equal bool_T) arg_Ts of
+ ~1 => n
+ | j => j
+ val ((before_args, tuple_args), after_args) =
+ args |> chop n |>> chop j
+ val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
+ T |> strip_n_binders n |>> chop j
+ val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
+ in
+ if n - j < 2 then
+ betapplys (t, args)
+ else
+ betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
+ before_arg_Ts ---> tuple_T --> rest_T),
+ before_args @ [mk_flat_tuple tuple_T tuple_args] @
+ after_args)
+ end
+ else
+ betapplys (t, args)
+ | NONE => betapplys (t, args))
+ | aux t args = betapplys (t, args)
+ in aux t [] end
+
+(* (term -> term) -> int -> term -> term *)
+fun coerce_bound_no f j t =
+ case t of
+ t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
+ | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
+ | Bound j' => if j' = j then f t else t
+ | _ => t
+
+(* extended_context -> bool -> term -> term *)
+fun box_fun_and_pair_in_term (ext_ctxt as {thy, fast_descrs, ...}) def orig_t =
+ let
+ (* typ -> typ *)
+ fun box_relational_operator_type (Type ("fun", Ts)) =
+ Type ("fun", map box_relational_operator_type Ts)
+ | box_relational_operator_type (Type ("*", Ts)) =
+ Type ("*", map (box_type ext_ctxt InPair) Ts)
+ | box_relational_operator_type T = T
+ (* typ -> typ -> term -> term *)
+ fun coerce_bound_0_in_term new_T old_T =
+ old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
+ (* typ list -> typ -> term -> term *)
+ and coerce_term Ts new_T old_T t =
+ if old_T = new_T then
+ t
+ else
+ case (new_T, old_T) of
+ (Type (new_s, new_Ts as [new_T1, new_T2]),
+ Type ("fun", [old_T1, old_T2])) =>
+ (case eta_expand Ts t 1 of
+ Abs (s, _, t') =>
+ Abs (s, new_T1,
+ t' |> coerce_bound_0_in_term new_T1 old_T1
+ |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
+ |> Envir.eta_contract
+ |> new_s <> "fun"
+ ? construct_value thy (@{const_name FunBox},
+ Type ("fun", new_Ts) --> new_T) o single
+ | t' => raise TERM ("NitpickHOL.box_fun_and_pair_in_term.\
+ \coerce_term", [t']))
+ | (Type (new_s, new_Ts as [new_T1, new_T2]),
+ Type (old_s, old_Ts as [old_T1, old_T2])) =>
+ if old_s mem [@{type_name fun_box}, @{type_name pair_box}, "*"] then
+ case constr_expand thy old_T t of
+ Const (@{const_name FunBox}, _) $ t1 =>
+ if new_s = "fun" then
+ coerce_term Ts new_T (Type ("fun", old_Ts)) t1
+ else
+ construct_value thy
+ (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
+ [coerce_term Ts (Type ("fun", new_Ts))
+ (Type ("fun", old_Ts)) t1]
+ | Const _ $ t1 $ t2 =>
+ construct_value thy
+ (if new_s = "*" then @{const_name Pair}
+ else @{const_name PairBox}, new_Ts ---> new_T)
+ [coerce_term Ts new_T1 old_T1 t1,
+ coerce_term Ts new_T2 old_T2 t2]
+ | t' => raise TERM ("NitpickHOL.box_fun_and_pair_in_term.\
+ \coerce_term", [t'])
+ else
+ raise TYPE ("coerce_term", [new_T, old_T], [t])
+ | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
+ (* indexname * typ -> typ * term -> typ option list -> typ option list *)
+ fun add_boxed_types_for_var (z as (_, T)) (T', t') =
+ case t' of
+ Var z' => z' = z ? insert (op =) T'
+ | Const (@{const_name Pair}, _) $ t1 $ t2 =>
+ (case T' of
+ Type (_, [T1, T2]) =>
+ fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
+ | _ => raise TYPE ("NitpickHOL.box_fun_and_pair_in_term.\
+ \add_boxed_types_for_var", [T'], []))
+ | _ => exists_subterm (equal (Var z)) t' ? insert (op =) T
+ (* typ list -> typ list -> term -> indexname * typ -> typ *)
+ fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
+ case t of
+ @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
+ | Const (s0, _) $ t1 $ _ =>
+ if s0 mem [@{const_name "=="}, @{const_name "op ="}] then
+ let
+ val (t', args) = strip_comb t1
+ val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
+ in
+ case fold (add_boxed_types_for_var z)
+ (fst (strip_n_binders (length args) T') ~~ args) [] of
+ [T''] => T''
+ | _ => T
+ end
+ else
+ T
+ | _ => T
+ (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
+ -> term -> term *)
+ and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
+ let
+ val abs_T' =
+ if polar = Neut orelse is_positive_existential polar quant_s then
+ box_type ext_ctxt InFunLHS abs_T
+ else
+ abs_T
+ val body_T = body_type quant_T
+ in
+ Const (quant_s, (abs_T' --> body_T) --> body_T)
+ $ Abs (abs_s, abs_T',
+ t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
+ end
+ (* typ list -> typ list -> string -> typ -> term -> term -> term *)
+ and do_equals new_Ts old_Ts s0 T0 t1 t2 =
+ let
+ val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
+ val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
+ val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
+ in
+ list_comb (Const (s0, [T, T] ---> body_type T0),
+ map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
+ end
+ (* string -> typ -> term *)
+ and do_description_operator s T =
+ let val T1 = box_type ext_ctxt InFunLHS (range_type T) in
+ Const (s, (T1 --> bool_T) --> T1)
+ end
+ (* typ list -> typ list -> polarity -> term -> term *)
+ and do_term new_Ts old_Ts polar t =
+ case t of
+ Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
+ do_equals new_Ts old_Ts s0 T0 t1 t2
+ | @{const "==>"} $ t1 $ t2 =>
+ @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const Pure.conjunction} $ t1 $ t2 =>
+ @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const Trueprop} $ t1 =>
+ @{const Trueprop} $ do_term new_Ts old_Ts polar t1
+ | @{const Not} $ t1 =>
+ @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
+ do_equals new_Ts old_Ts s0 T0 t1 t2
+ | @{const "op &"} $ t1 $ t2 =>
+ @{const "op &"} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const "op |"} $ t1 $ t2 =>
+ @{const "op |"} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const "op -->"} $ t1 $ t2 =>
+ @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ $ do_term new_Ts old_Ts polar t2
+ | Const (s as @{const_name The}, T) => do_description_operator s T
+ | Const (s as @{const_name Eps}, T) => do_description_operator s T
+ | Const (s as @{const_name Tha}, T) => do_description_operator s T
+ | Const (x as (s, T)) =>
+ Const (s, if s mem [@{const_name converse}, @{const_name trancl}] then
+ box_relational_operator_type T
+ else if is_built_in_const fast_descrs x
+ orelse s = @{const_name Sigma} then
+ T
+ else if is_constr_like thy x then
+ box_type ext_ctxt InConstr T
+ else if is_sel s orelse is_rep_fun thy x then
+ box_type ext_ctxt InSel T
+ else
+ box_type ext_ctxt InExpr T)
+ | t1 $ Abs (s, T, t2') =>
+ let
+ val t1 = do_term new_Ts old_Ts Neut t1
+ val T1 = fastype_of1 (new_Ts, t1)
+ val (s1, Ts1) = dest_Type T1
+ val T' = hd (snd (dest_Type (hd Ts1)))
+ val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
+ val T2 = fastype_of1 (new_Ts, t2)
+ val t2 = coerce_term new_Ts (hd Ts1) T2 t2
+ in
+ betapply (if s1 = "fun" then
+ t1
+ else
+ select_nth_constr_arg thy
+ (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
+ (Type ("fun", Ts1)), t2)
+ end
+ | t1 $ t2 =>
+ let
+ val t1 = do_term new_Ts old_Ts Neut t1
+ val T1 = fastype_of1 (new_Ts, t1)
+ val (s1, Ts1) = dest_Type T1
+ val t2 = do_term new_Ts old_Ts Neut t2
+ val T2 = fastype_of1 (new_Ts, t2)
+ val t2 = coerce_term new_Ts (hd Ts1) T2 t2
+ in
+ betapply (if s1 = "fun" then
+ t1
+ else
+ select_nth_constr_arg thy
+ (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
+ (Type ("fun", Ts1)), t2)
+ end
+ | Free (s, T) => Free (s, box_type ext_ctxt InExpr T)
+ | Var (z as (x, T)) =>
+ Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
+ else box_type ext_ctxt InExpr T)
+ | Bound _ => t
+ | Abs (s, T, t') =>
+ Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
+ in do_term [] [] Pos orig_t end
+
+(* int -> term -> term *)
+fun eval_axiom_for_term j t =
+ Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
+
+(* extended_context -> styp -> bool *)
+fun is_equational_fun_surely_complete ext_ctxt x =
+ case raw_equational_fun_axioms ext_ctxt x of
+ [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
+ strip_comb t1 |> snd |> forall is_Var
+ | _ => false
+
+type special = int list * term list * styp
+
+(* styp -> special -> special -> term *)
+fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
+ let
+ val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
+ val Ts = binder_types T
+ val max_j = fold (fold (curry Int.max)) [js1, js2] ~1
+ val (eqs, (args1, args2)) =
+ fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
+ (js1 ~~ ts1, js2 ~~ ts2) of
+ (SOME t1, SOME t2) => apfst (cons (t1, t2))
+ | (SOME t1, NONE) => apsnd (apsnd (cons t1))
+ | (NONE, SOME t2) => apsnd (apfst (cons t2))
+ | (NONE, NONE) =>
+ let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
+ nth Ts j) in
+ apsnd (pairself (cons v))
+ end) (max_j downto 0) ([], ([], []))
+ in
+ Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
+ |> map Logic.mk_equals,
+ Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
+ list_comb (Const x2, bounds2 @ args2)))
+ |> Refute.close_form
+ end
+
+(* extended_context -> styp list -> term list *)
+fun special_congruence_axioms (ext_ctxt as {special_funs, ...}) xs =
+ let
+ val groups =
+ !special_funs
+ |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
+ |> AList.group (op =)
+ |> filter_out (is_equational_fun_surely_complete ext_ctxt o fst)
+ |> map (fn (x, zs) => (x, zs |> (x mem xs) ? cons ([], [], x)))
+ (* special -> int *)
+ fun generality (js, _, _) = ~(length js)
+ (* special -> special -> bool *)
+ fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
+ x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
+ (j2 ~~ t2, j1 ~~ t1)
+ (* styp -> special list -> special list -> special list -> term list
+ -> term list *)
+ fun do_pass_1 _ [] [_] [_] = I
+ | do_pass_1 x skipped _ [] = do_pass_2 x skipped
+ | do_pass_1 x skipped all (z :: zs) =
+ case filter (is_more_specific z) all
+ |> sort (int_ord o pairself generality) of
+ [] => do_pass_1 x (z :: skipped) all zs
+ | (z' :: _) => cons (special_congruence_axiom x z z')
+ #> do_pass_1 x skipped all zs
+ (* styp -> special list -> term list -> term list *)
+ and do_pass_2 _ [] = I
+ | do_pass_2 x (z :: zs) =
+ fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
+ in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
+
+(* term -> bool *)
+val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
+
+(* 'a Symtab.table -> 'a list *)
+fun all_table_entries table = Symtab.fold (append o snd) table []
+(* const_table -> string -> const_table *)
+fun extra_table table s = Symtab.make [(s, all_table_entries table)]
+
+(* extended_context -> term -> (term list * term list) * (bool * bool) *)
+fun axioms_for_term
+ (ext_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
+ def_table, nondef_table, user_nondefs, ...}) t =
+ let
+ type accumulator = styp list * (term list * term list)
+ (* (term list * term list -> term list)
+ -> ((term list -> term list) -> term list * term list
+ -> term list * term list)
+ -> int -> term -> accumulator -> accumulator *)
+ fun add_axiom get app depth t (accum as (xs, axs)) =
+ let
+ val t = t |> unfold_defs_in_term ext_ctxt
+ |> skolemize_term_and_more ext_ctxt ~1
+ in
+ if is_trivial_equation t then
+ accum
+ else
+ let val t' = t |> specialize_consts_in_term ext_ctxt depth in
+ if exists (member (op aconv) (get axs)) [t, t'] then accum
+ else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
+ end
+ end
+ (* int -> term -> accumulator -> accumulator *)
+ and add_nondef_axiom depth = add_axiom snd apsnd depth
+ and add_def_axiom depth t =
+ (if head_of t = @{const "==>"} then add_nondef_axiom
+ else add_axiom fst apfst) depth t
+ (* int -> term -> accumulator -> accumulator *)
+ and add_axioms_for_term depth t (accum as (xs, axs)) =
+ case t of
+ t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
+ | Const (x as (s, T)) =>
+ (if x mem xs orelse is_built_in_const fast_descrs x then
+ accum
+ else
+ let val accum as (xs, _) = (x :: xs, axs) in
+ if depth > axioms_max_depth then
+ raise LIMIT ("NitpickHOL.axioms_for_term.add_axioms_for_term",
+ "too many nested axioms (" ^ string_of_int depth ^
+ ")")
+ else if Refute.is_const_of_class thy x then
+ let
+ val class = Logic.class_of_const s
+ val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
+ class)
+ val ax1 = try (Refute.specialize_type thy x) of_class
+ val ax2 = Option.map (Refute.specialize_type thy x o snd)
+ (Refute.get_classdef thy class)
+ in fold (add_def_axiom depth) (map_filter I [ax1, ax2]) accum end
+ else if is_constr thy x then
+ accum
+ else if is_equational_fun ext_ctxt x then
+ fold (add_def_axiom depth) (equational_fun_axioms ext_ctxt x)
+ accum
+ else if is_abs_fun thy x then
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> fold (add_def_axiom depth)
+ (nondef_props_for_const thy true
+ (extra_table def_table s) x)
+ else if is_rep_fun thy x then
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> fold (add_def_axiom depth)
+ (nondef_props_for_const thy true
+ (extra_table def_table s) x)
+ |> add_axioms_for_term depth
+ (Const (mate_of_rep_fun thy x))
+ |> add_def_axiom depth (inverse_axiom_for_rep_fun thy x)
+ else
+ accum |> user_axioms <> SOME false
+ ? fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ end)
+ |> add_axioms_for_type depth T
+ | Free (_, T) => add_axioms_for_type depth T accum
+ | Var (_, T) => add_axioms_for_type depth T accum
+ | Bound _ => accum
+ | Abs (_, T, t) => accum |> add_axioms_for_term depth t
+ |> add_axioms_for_type depth T
+ (* int -> typ -> accumulator -> accumulator *)
+ and add_axioms_for_type depth T =
+ case T of
+ Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
+ | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
+ | @{typ prop} => I
+ | @{typ bool} => I
+ | @{typ unit} => I
+ | TFree (_, S) => add_axioms_for_sort depth T S
+ | TVar (_, S) => add_axioms_for_sort depth T S
+ | Type (z as (_, Ts)) =>
+ fold (add_axioms_for_type depth) Ts
+ #> (if is_pure_typedef thy T then
+ fold (add_def_axiom depth) (optimized_typedef_axioms thy z)
+ else if max_bisim_depth >= 0 andalso is_codatatype thy T then
+ fold (add_def_axiom depth) (codatatype_bisim_axioms thy T)
+ else
+ I)
+ (* int -> typ -> sort -> accumulator -> accumulator *)
+ and add_axioms_for_sort depth T S =
+ let
+ val supers = Sign.complete_sort thy S
+ val class_axioms =
+ maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
+ handle ERROR _ => [])) supers
+ val monomorphic_class_axioms =
+ map (fn t => case Term.add_tvars t [] of
+ [] => t
+ | [(x, S)] =>
+ Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
+ | _ => raise TERM ("NitpickHOL.axioms_for_term.\
+ \add_axioms_for_sort", [t]))
+ class_axioms
+ in fold (add_nondef_axiom depth) monomorphic_class_axioms end
+ val (mono_user_nondefs, poly_user_nondefs) =
+ List.partition (null o Term.hidden_polymorphism) user_nondefs
+ val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
+ evals
+ val (xs, (defs, nondefs)) =
+ ([], ([], [])) |> add_axioms_for_term 1 t
+ |> fold_rev (add_def_axiom 1) eval_axioms
+ |> user_axioms = SOME true
+ ? fold (add_nondef_axiom 1) mono_user_nondefs
+ val defs = defs @ special_congruence_axioms ext_ctxt xs
+ in
+ ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
+ null poly_user_nondefs))
+ end
+
+(* theory -> const_table -> styp -> int list *)
+fun const_format thy def_table (x as (s, T)) =
+ if String.isPrefix unrolled_prefix s then
+ const_format thy def_table (original_name s, range_type T)
+ else if String.isPrefix skolem_prefix s then
+ let
+ val k = unprefix skolem_prefix s
+ |> strip_first_name_sep |> fst |> space_explode "@"
+ |> hd |> Int.fromString |> the
+ in [k, num_binder_types T - k] end
+ else if original_name s <> s then
+ [num_binder_types T]
+ else case def_of_const thy def_table x of
+ SOME t' => if fixpoint_kind_of_rhs t' <> NoFp then
+ let val k = length (strip_abs_vars t') in
+ [k, num_binder_types T - k]
+ end
+ else
+ [num_binder_types T]
+ | NONE => [num_binder_types T]
+(* int list -> int list -> int list *)
+fun intersect_formats _ [] = []
+ | intersect_formats [] _ = []
+ | intersect_formats ks1 ks2 =
+ let val ((ks1', k1), (ks2', k2)) = pairself split_last (ks1, ks2) in
+ intersect_formats (ks1' @ (if k1 > k2 then [k1 - k2] else []))
+ (ks2' @ (if k2 > k1 then [k2 - k1] else [])) @
+ [Int.min (k1, k2)]
+ end
+
+(* theory -> const_table -> (term option * int list) list -> term -> int list *)
+fun lookup_format thy def_table formats t =
+ case AList.lookup (fn (SOME x, SOME y) =>
+ (term_match thy) (x, y) | _ => false)
+ formats (SOME t) of
+ SOME format => format
+ | NONE => let val format = the (AList.lookup (op =) formats NONE) in
+ case t of
+ Const x => intersect_formats format
+ (const_format thy def_table x)
+ | _ => format
+ end
+
+(* int list -> int list -> typ -> typ *)
+fun format_type default_format format T =
+ let
+ val T = unbox_type T
+ val format = format |> filter (curry (op <) 0)
+ in
+ if forall (equal 1) format then
+ T
+ else
+ let
+ val (binder_Ts, body_T) = strip_type T
+ val batched =
+ binder_Ts
+ |> map (format_type default_format default_format)
+ |> rev |> chunk_list_unevenly (rev format)
+ |> map (HOLogic.mk_tupleT o rev)
+ in List.foldl (op -->) body_T batched end
+ end
+(* theory -> const_table -> (term option * int list) list -> term -> typ *)
+fun format_term_type thy def_table formats t =
+ format_type (the (AList.lookup (op =) formats NONE))
+ (lookup_format thy def_table formats t) (fastype_of t)
+
+(* int list -> int -> int list -> int list *)
+fun repair_special_format js m format =
+ m - 1 downto 0 |> chunk_list_unevenly (rev format)
+ |> map (rev o filter_out (member (op =) js))
+ |> filter_out null |> map length |> rev
+
+(* extended_context -> string * string -> (term option * int list) list
+ -> styp -> term * typ *)
+fun user_friendly_const ({thy, evals, def_table, skolems, special_funs, ...}
+ : extended_context) (base_name, step_name) formats =
+ let
+ val default_format = the (AList.lookup (op =) formats NONE)
+ (* styp -> term * typ *)
+ fun do_const (x as (s, T)) =
+ (if String.isPrefix special_prefix s then
+ let
+ (* term -> term *)
+ val do_term = map_aterms (fn Const x => fst (do_const x) | t' => t')
+ val (x' as (_, T'), js, ts) =
+ AList.find (op =) (!special_funs) (s, unbox_type T) |> the_single
+ val max_j = List.last js
+ val Ts = List.take (binder_types T', max_j + 1)
+ val missing_js = filter_out (member (op =) js) (0 upto max_j)
+ val missing_Ts = filter_indices missing_js Ts
+ (* int -> indexname *)
+ fun nth_missing_var n =
+ ((arg_var_prefix ^ nat_subscript (n + 1), 0), nth missing_Ts n)
+ val missing_vars = map nth_missing_var (0 upto length missing_js - 1)
+ val vars = special_bounds ts @ missing_vars
+ val ts' = map2 (fn T => fn j =>
+ case AList.lookup (op =) (js ~~ ts) j of
+ SOME t => do_term t
+ | NONE =>
+ Var (nth missing_vars
+ (find_index (equal j) missing_js)))
+ Ts (0 upto max_j)
+ val t = do_const x' |> fst
+ val format =
+ case AList.lookup (fn (SOME t1, SOME t2) => term_match thy (t1, t2)
+ | _ => false) formats (SOME t) of
+ SOME format =>
+ repair_special_format js (num_binder_types T') format
+ | NONE =>
+ const_format thy def_table x'
+ |> repair_special_format js (num_binder_types T')
+ |> intersect_formats default_format
+ in
+ (list_comb (t, ts') |> fold_rev abs_var vars,
+ format_type default_format format T)
+ end
+ else if String.isPrefix uncurry_prefix s then
+ let
+ val (ss, s') = unprefix uncurry_prefix s
+ |> strip_first_name_sep |>> space_explode "@"
+ in
+ if String.isPrefix step_prefix s' then
+ do_const (s', T)
+ else
+ let
+ val k = the (Int.fromString (hd ss))
+ val j = the (Int.fromString (List.last ss))
+ val (before_Ts, (tuple_T, rest_T)) =
+ strip_n_binders j T ||> (strip_n_binders 1 #>> hd)
+ val T' = before_Ts ---> dest_n_tuple_type k tuple_T ---> rest_T
+ in do_const (s', T') end
+ end
+ else if String.isPrefix unrolled_prefix s then
+ let val t = Const (original_name s, range_type T) in
+ (lambda (Free (iter_var_prefix, nat_T)) t,
+ format_type default_format
+ (lookup_format thy def_table formats t) T)
+ end
+ else if String.isPrefix base_prefix s then
+ (Const (base_name, T --> T) $ Const (unprefix base_prefix s, T),
+ format_type default_format default_format T)
+ else if String.isPrefix step_prefix s then
+ (Const (step_name, T --> T) $ Const (unprefix step_prefix s, T),
+ format_type default_format default_format T)
+ else if String.isPrefix skolem_prefix s then
+ let
+ val ss = the (AList.lookup (op =) (!skolems) s)
+ val (Ts, Ts') = chop (length ss) (binder_types T)
+ val frees = map Free (ss ~~ Ts)
+ val s' = original_name s
+ in
+ (fold lambda frees (Const (s', Ts' ---> T)),
+ format_type default_format
+ (lookup_format thy def_table formats (Const x)) T)
+ end
+ else if String.isPrefix eval_prefix s then
+ let
+ val t = nth evals (the (Int.fromString (unprefix eval_prefix s)))
+ in (t, format_term_type thy def_table formats t) end
+ else if s = @{const_name undefined_fast_The} then
+ (Const (nitpick_prefix ^ "The fallback", T),
+ format_type default_format
+ (lookup_format thy def_table formats
+ (Const (@{const_name The}, (T --> bool_T) --> T))) T)
+ else if s = @{const_name undefined_fast_Eps} then
+ (Const (nitpick_prefix ^ "Eps fallback", T),
+ format_type default_format
+ (lookup_format thy def_table formats
+ (Const (@{const_name Eps}, (T --> bool_T) --> T))) T)
+ else
+ let val t = Const (original_name s, T) in
+ (t, format_term_type thy def_table formats t)
+ end)
+ |>> map_types (typ_subst [(@{typ bisim_iterator}, nat_T)] o unbox_type)
+ |>> shorten_const_names_in_term |>> shorten_abs_vars
+ in do_const end
+
+(* styp -> string *)
+fun assign_operator_for_const (s, T) =
+ if String.isPrefix ubfp_prefix s then
+ if is_fun_type T then "\<subseteq>" else "\<le>"
+ else if String.isPrefix lbfp_prefix s then
+ if is_fun_type T then "\<supseteq>" else "\<ge>"
+ else if original_name s <> s then
+ assign_operator_for_const (after_name_sep s, T)
+ else
+ "="
+
+(* extended_context -> term
+ -> ((term list * term list) * (bool * bool)) * term *)
+fun preprocess_term (ext_ctxt as {thy, destroy_constrs, boxes, skolemize,
+ uncurry, ...}) t =
+ let
+ val skolem_depth = if skolemize then 4 else ~1
+ val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
+ core_t) = t |> unfold_defs_in_term ext_ctxt
+ |> Refute.close_form
+ |> skolemize_term_and_more ext_ctxt skolem_depth
+ |> specialize_consts_in_term ext_ctxt 0
+ |> `(axioms_for_term ext_ctxt)
+ val maybe_box = exists (not_equal (SOME false) o snd) boxes
+ val table =
+ Termtab.empty |> uncurry
+ ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
+ (* bool -> bool -> term -> term *)
+ fun do_rest def core =
+ uncurry ? uncurry_term table
+ #> maybe_box ? box_fun_and_pair_in_term ext_ctxt def
+ #> destroy_constrs ? (pull_out_universal_constrs thy def
+ #> pull_out_existential_constrs thy
+ #> destroy_pulled_out_constrs thy def)
+ #> curry_assms
+ #> destroy_universal_equalities
+ #> destroy_existential_equalities thy
+ #> simplify_constrs_and_sels thy
+ #> distribute_quantifiers
+ #> push_quantifiers_inward thy
+ #> not core ? Refute.close_form
+ #> shorten_abs_vars
+ in
+ (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
+ (got_all_mono_user_axioms, no_poly_user_axioms)),
+ do_rest false true core_t)
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_isar.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,496 @@
+(* Title: HOL/Nitpick/Tools/nitpick_isar.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Adds the "nitpick" and "nitpick_params" commands to Isabelle/Isar's outer
+syntax.
+*)
+
+signature NITPICK_ISAR =
+sig
+ type params = Nitpick.params
+
+ val default_params : theory -> (string * string) list -> params
+end
+
+structure NitpickIsar : NITPICK_ISAR =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickRep
+open NitpickNut
+open Nitpick
+
+type raw_param = string * string list
+
+val default_default_params =
+ [("card", ["1\<midarrow>8"]),
+ ("iter", ["0,1,2,4,8,12,16,24"]),
+ ("bisim_depth", ["7"]),
+ ("box", ["smart"]),
+ ("mono", ["smart"]),
+ ("wf", ["smart"]),
+ ("sat_solver", ["smart"]),
+ ("batch_size", ["smart"]),
+ ("auto", ["false"]),
+ ("blocking", ["true"]),
+ ("falsify", ["true"]),
+ ("user_axioms", ["smart"]),
+ ("assms", ["true"]),
+ ("coalesce_type_vars", ["false"]),
+ ("destroy_constrs", ["true"]),
+ ("specialize", ["true"]),
+ ("skolemize", ["true"]),
+ ("star_linear_preds", ["true"]),
+ ("uncurry", ["true"]),
+ ("fast_descrs", ["true"]),
+ ("peephole_optim", ["true"]),
+ ("timeout", ["30 s"]),
+ ("auto_timeout", ["5 s"]),
+ ("tac_timeout", ["500 ms"]),
+ ("sym_break", ["20"]),
+ ("sharing_depth", ["3"]),
+ ("flatten_props", ["false"]),
+ ("max_threads", ["0"]),
+ ("verbose", ["false"]),
+ ("debug", ["false"]),
+ ("overlord", ["false"]),
+ ("show_all", ["false"]),
+ ("show_skolems", ["true"]),
+ ("show_datatypes", ["false"]),
+ ("show_consts", ["false"]),
+ ("format", ["1"]),
+ ("max_potential", ["1"]),
+ ("max_genuine", ["1"]),
+ ("check_potential", ["false"]),
+ ("check_genuine", ["false"])]
+
+val negated_params =
+ [("dont_box", "box"),
+ ("non_mono", "mono"),
+ ("non_wf", "wf"),
+ ("no_auto", "auto"),
+ ("non_blocking", "blocking"),
+ ("satisfy", "falsify"),
+ ("no_user_axioms", "user_axioms"),
+ ("no_assms", "assms"),
+ ("dont_coalesce_type_vars", "coalesce_type_vars"),
+ ("dont_destroy_constrs", "destroy_constrs"),
+ ("dont_specialize", "specialize"),
+ ("dont_skolemize", "skolemize"),
+ ("dont_star_linear_preds", "star_linear_preds"),
+ ("dont_uncurry", "uncurry"),
+ ("full_descrs", "fast_descrs"),
+ ("no_peephole_optim", "peephole_optim"),
+ ("dont_flatten_props", "flatten_props"),
+ ("quiet", "verbose"),
+ ("no_debug", "debug"),
+ ("no_overlord", "overlord"),
+ ("dont_show_all", "show_all"),
+ ("hide_skolems", "show_skolems"),
+ ("hide_datatypes", "show_datatypes"),
+ ("hide_consts", "show_consts"),
+ ("trust_potential", "check_potential"),
+ ("trust_genuine", "check_genuine")]
+
+(* string -> bool *)
+fun is_known_raw_param s =
+ AList.defined (op =) default_default_params s
+ orelse AList.defined (op =) negated_params s
+ orelse s mem ["max", "eval", "expect"]
+ orelse exists (fn p => String.isPrefix (p ^ " ") s)
+ ["card", "max", "iter", "box", "dont_box", "mono", "non_mono",
+ "wf", "non_wf", "format"]
+
+(* string * 'a -> unit *)
+fun check_raw_param (s, _) =
+ if is_known_raw_param s then ()
+ else error ("Unknown parameter " ^ quote s ^ ".")
+
+(* string -> string option *)
+fun unnegate_param_name name =
+ case AList.lookup (op =) negated_params name of
+ NONE => if String.isPrefix "dont_" name then SOME (unprefix "dont_" name)
+ else if String.isPrefix "non_" name then SOME (unprefix "non_" name)
+ else NONE
+ | some_name => some_name
+(* raw_param -> raw_param *)
+fun unnegate_raw_param (name, value) =
+ case unnegate_param_name name of
+ SOME name' => (name', case value of
+ ["false"] => ["true"]
+ | ["true"] => ["false"]
+ | [] => ["false"]
+ | _ => value)
+ | NONE => (name, value)
+
+structure TheoryData = TheoryDataFun(
+ type T = {params: raw_param list, registered_auto: bool}
+ val empty = {params = rev default_default_params, registered_auto = false}
+ val copy = I
+ val extend = I
+ fun merge _ ({params = ps1, registered_auto = a1},
+ {params = ps2, registered_auto = a2}) =
+ {params = AList.merge (op =) (op =) (ps1, ps2),
+ registered_auto = a1 orelse a2})
+
+(* raw_param -> theory -> theory *)
+fun set_default_raw_param param thy =
+ let val {params, registered_auto} = TheoryData.get thy in
+ TheoryData.put
+ {params = AList.update (op =) (unnegate_raw_param param) params,
+ registered_auto = registered_auto} thy
+ end
+(* theory -> raw_param list *)
+val default_raw_params = #params o TheoryData.get
+
+(* theory -> theory *)
+fun set_registered_auto thy =
+ TheoryData.put {params = default_raw_params thy, registered_auto = true} thy
+(* theory -> bool *)
+val is_registered_auto = #registered_auto o TheoryData.get
+
+(* string -> bool *)
+fun is_punctuation s = (s = "," orelse s = "-" orelse s = "\<midarrow>")
+
+(* string list -> string *)
+fun stringify_raw_param_value [] = ""
+ | stringify_raw_param_value [s] = s
+ | stringify_raw_param_value (s1 :: s2 :: ss) =
+ s1 ^ (if is_punctuation s1 orelse is_punctuation s2 then "" else " ") ^
+ stringify_raw_param_value (s2 :: ss)
+
+(* bool -> string -> string -> bool option *)
+fun bool_option_from_string option name s =
+ (case s of
+ "smart" => if option then NONE else raise Option
+ | "false" => SOME false
+ | "true" => SOME true
+ | "" => SOME true
+ | s => raise Option)
+ handle Option.Option =>
+ let val ss = map quote ((option ? cons "smart") ["true", "false"]) in
+ error ("Parameter " ^ quote name ^ " must be assigned " ^
+ space_implode " " (serial_commas "or" ss) ^ ".")
+ end
+(* bool -> raw_param list -> bool option -> string -> bool option *)
+fun general_lookup_bool option raw_params default_value name =
+ case AList.lookup (op =) raw_params name of
+ SOME s => s |> stringify_raw_param_value
+ |> bool_option_from_string option name
+ | NONE => default_value
+
+(* int -> string -> int *)
+fun maxed_int_from_string min_int s = Int.max (min_int, the (Int.fromString s))
+
+(* Proof.context -> bool -> raw_param list -> raw_param list -> params *)
+fun extract_params ctxt auto default_params override_params =
+ let
+ val override_params = map unnegate_raw_param override_params
+ val raw_params = rev override_params @ rev default_params
+ val lookup =
+ Option.map stringify_raw_param_value o AList.lookup (op =) raw_params
+ (* string -> string *)
+ fun lookup_string name = the_default "" (lookup name)
+ (* string -> bool *)
+ val lookup_bool = the o general_lookup_bool false raw_params (SOME false)
+ (* string -> bool option *)
+ val lookup_bool_option = general_lookup_bool true raw_params NONE
+ (* string -> string option -> int *)
+ fun do_int name value =
+ case value of
+ SOME s => (case Int.fromString s of
+ SOME i => i
+ | NONE => error ("Parameter " ^ quote name ^
+ " must be assigned an integer value."))
+ | NONE => 0
+ (* string -> int *)
+ fun lookup_int name = do_int name (lookup name)
+ (* string -> int option *)
+ fun lookup_int_option name =
+ case lookup name of
+ SOME "smart" => NONE
+ | value => SOME (do_int name value)
+ (* string -> int -> string -> int list *)
+ fun int_range_from_string name min_int s =
+ let
+ val (k1, k2) =
+ (case space_explode "-" s of
+ [s] => the_default (s, s) (first_field "\<midarrow>" s)
+ | ["", s2] => ("-" ^ s2, "-" ^ s2)
+ | [s1, s2] => (s1, s2)
+ | _ => raise Option)
+ |> pairself (maxed_int_from_string min_int)
+ in if k1 <= k2 then k1 upto k2 else k1 downto k2 end
+ handle Option.Option =>
+ error ("Parameter " ^ quote name ^
+ " must be assigned a sequence of integers.")
+ (* string -> int -> string -> int list *)
+ fun int_seq_from_string name min_int s =
+ maps (int_range_from_string name min_int) (space_explode "," s)
+ (* string -> int -> int list *)
+ fun lookup_int_seq name min_int =
+ case lookup name of
+ SOME s => (case int_seq_from_string name min_int s of
+ [] => [min_int]
+ | value => value)
+ | NONE => [min_int]
+ (* (string -> 'a) -> int -> string -> ('a option * int list) list *)
+ fun lookup_ints_assigns read prefix min_int =
+ (NONE, lookup_int_seq prefix min_int)
+ :: map (fn (name, value) =>
+ (SOME (read (String.extract (name, size prefix + 1, NONE))),
+ value |> stringify_raw_param_value
+ |> int_seq_from_string name min_int))
+ (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
+ (* (string -> 'a) -> string -> ('a option * bool option) list *)
+ fun lookup_bool_option_assigns read prefix =
+ (NONE, lookup_bool_option prefix)
+ :: map (fn (name, value) =>
+ (SOME (read (String.extract (name, size prefix + 1, NONE))),
+ value |> stringify_raw_param_value
+ |> bool_option_from_string true name))
+ (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
+ (* string -> Time.time option *)
+ fun lookup_time name =
+ case lookup name of
+ NONE => NONE
+ | SOME "none" => NONE
+ | SOME s =>
+ let
+ val msecs =
+ case space_explode " " s of
+ [s1, "min"] => 60000 * the (Int.fromString s1)
+ | [s1, "s"] => 1000 * the (Int.fromString s1)
+ | [s1, "ms"] => the (Int.fromString s1)
+ | _ => 0
+ in
+ if msecs <= 0 then
+ error ("Parameter " ^ quote name ^ " must be assigned a positive \
+ \time value (e.g., \"60 s\", \"200 ms\") or \"none\".")
+ else
+ SOME (Time.fromMilliseconds msecs)
+ end
+ (* string -> term list *)
+ val lookup_term_list =
+ AList.lookup (op =) raw_params #> these #> Syntax.read_terms ctxt
+ val read_type_polymorphic =
+ Syntax.read_typ ctxt #> Logic.mk_type
+ #> singleton (Variable.polymorphic ctxt) #> Logic.dest_type
+ (* string -> term *)
+ val read_term_polymorphic =
+ Syntax.read_term ctxt #> singleton (Variable.polymorphic ctxt)
+ (* string -> styp *)
+ val read_const_polymorphic = read_term_polymorphic #> dest_Const
+ val cards_assigns = lookup_ints_assigns read_type_polymorphic "card" 1
+ val maxes_assigns = lookup_ints_assigns read_const_polymorphic "max" ~1
+ val iters_assigns = lookup_ints_assigns read_const_polymorphic "iter" 0
+ val bisim_depths = lookup_int_seq "bisim_depth" ~1
+ val boxes =
+ lookup_bool_option_assigns read_type_polymorphic "box" @
+ map_filter (fn (SOME T, _) =>
+ if is_fun_type T orelse is_pair_type T then
+ SOME (SOME T, SOME true)
+ else
+ NONE
+ | (NONE, _) => NONE) cards_assigns
+ val monos = lookup_bool_option_assigns read_type_polymorphic "mono"
+ val wfs = lookup_bool_option_assigns read_const_polymorphic "wf"
+ val sat_solver = lookup_string "sat_solver"
+ val blocking = not auto andalso lookup_bool "blocking"
+ val falsify = lookup_bool "falsify"
+ val debug = not auto andalso lookup_bool "debug"
+ val verbose = debug orelse (not auto andalso lookup_bool "verbose")
+ val overlord = lookup_bool "overlord"
+ val user_axioms = lookup_bool_option "user_axioms"
+ val assms = lookup_bool "assms"
+ val coalesce_type_vars = lookup_bool "coalesce_type_vars"
+ val destroy_constrs = lookup_bool "destroy_constrs"
+ val specialize = lookup_bool "specialize"
+ val skolemize = lookup_bool "skolemize"
+ val star_linear_preds = lookup_bool "star_linear_preds"
+ val uncurry = lookup_bool "uncurry"
+ val fast_descrs = lookup_bool "fast_descrs"
+ val peephole_optim = lookup_bool "peephole_optim"
+ val timeout = if auto then lookup_time "auto_timeout"
+ else lookup_time "timeout"
+ val tac_timeout = lookup_time "tac_timeout"
+ val sym_break = Int.max (0, lookup_int "sym_break")
+ val sharing_depth = Int.max (1, lookup_int "sharing_depth")
+ val flatten_props = lookup_bool "flatten_props"
+ val max_threads = Int.max (0, lookup_int "max_threads")
+ val show_all = debug orelse lookup_bool "show_all"
+ val show_skolems = show_all orelse lookup_bool "show_skolems"
+ val show_datatypes = show_all orelse lookup_bool "show_datatypes"
+ val show_consts = show_all orelse lookup_bool "show_consts"
+ val formats = lookup_ints_assigns read_term_polymorphic "format" 0
+ val evals = lookup_term_list "eval"
+ val max_potential = if auto then 0
+ else Int.max (0, lookup_int "max_potential")
+ val max_genuine = Int.max (0, lookup_int "max_genuine")
+ val check_potential = lookup_bool "check_potential"
+ val check_genuine = lookup_bool "check_genuine"
+ val batch_size = case lookup_int_option "batch_size" of
+ SOME n => Int.max (1, n)
+ | NONE => if debug then 1 else 64
+ val expect = lookup_string "expect"
+ in
+ {cards_assigns = cards_assigns, maxes_assigns = maxes_assigns,
+ iters_assigns = iters_assigns, bisim_depths = bisim_depths, boxes = boxes,
+ monos = monos, wfs = wfs, sat_solver = sat_solver, blocking = blocking,
+ falsify = falsify, debug = debug, verbose = verbose, overlord = overlord,
+ user_axioms = user_axioms, assms = assms,
+ coalesce_type_vars = coalesce_type_vars, destroy_constrs = destroy_constrs,
+ specialize = specialize, skolemize = skolemize,
+ star_linear_preds = star_linear_preds, uncurry = uncurry,
+ fast_descrs = fast_descrs, peephole_optim = peephole_optim,
+ timeout = timeout, tac_timeout = tac_timeout, sym_break = sym_break,
+ sharing_depth = sharing_depth, flatten_props = flatten_props,
+ max_threads = max_threads, show_skolems = show_skolems,
+ show_datatypes = show_datatypes, show_consts = show_consts,
+ formats = formats, evals = evals, max_potential = max_potential,
+ max_genuine = max_genuine, check_potential = check_potential,
+ check_genuine = check_genuine, batch_size = batch_size, expect = expect}
+ end
+
+(* theory -> (string * string) list -> params *)
+fun default_params thy =
+ extract_params (ProofContext.init thy) false (default_raw_params thy)
+ o map (apsnd single)
+
+(* OuterParse.token list -> string * OuterParse.token list *)
+val scan_key = Scan.repeat1 OuterParse.typ_group >> space_implode " "
+
+(* OuterParse.token list -> string list * OuterParse.token list *)
+val scan_value =
+ Scan.repeat1 (OuterParse.minus >> single
+ || Scan.repeat1 (Scan.unless OuterParse.minus OuterParse.name)
+ || OuterParse.$$$ "," |-- OuterParse.number >> prefix ","
+ >> single) >> flat
+
+(* OuterParse.token list -> raw_param * OuterParse.token list *)
+val scan_param =
+ scan_key -- (Scan.option (OuterParse.$$$ "=" |-- scan_value) >> these)
+(* OuterParse.token list -> raw_param list option * OuterParse.token list *)
+val scan_params = Scan.option (OuterParse.$$$ "[" |-- OuterParse.list scan_param
+ --| OuterParse.$$$ "]")
+
+(* Proof.context -> ('a -> 'a) -> 'a -> 'a *)
+fun handle_exceptions ctxt f x =
+ f x
+ handle ARG (loc, details) =>
+ error ("Bad argument(s) to " ^ quote loc ^ ": " ^ details ^ ".")
+ | BAD (loc, details) =>
+ error ("Internal error (" ^ quote loc ^ "): " ^ details ^ ".")
+ | LIMIT (_, details) =>
+ (warning ("Limit reached: " ^ details ^ "."); x)
+ | NOT_SUPPORTED details =>
+ (warning ("Unsupported case: " ^ details ^ "."); x)
+ | NUT (loc, us) =>
+ error ("Invalid intermediate term" ^ plural_s_for_list us ^
+ " (" ^ quote loc ^ "): " ^
+ commas (map (string_for_nut ctxt) us) ^ ".")
+ | REP (loc, Rs) =>
+ error ("Invalid representation" ^ plural_s_for_list Rs ^
+ " (" ^ quote loc ^ "): " ^ commas (map string_for_rep Rs) ^ ".")
+ | TERM (loc, ts) =>
+ error ("Invalid term" ^ plural_s_for_list ts ^
+ " (" ^ quote loc ^ "): " ^
+ commas (map (Syntax.string_of_term ctxt) ts) ^ ".")
+ | TYPE (loc, Ts, ts) =>
+ error ("Invalid type" ^ plural_s_for_list Ts ^
+ (if null ts then
+ ""
+ else
+ " for term" ^ plural_s_for_list ts ^ " " ^
+ commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
+ " (" ^ quote loc ^ "): " ^
+ commas (map (Syntax.string_of_typ ctxt) Ts) ^ ".")
+ | Kodkod.SYNTAX (_, details) =>
+ (warning ("Ill-formed Kodkodi output: " ^ details ^ "."); x)
+ | Refute.REFUTE (loc, details) =>
+ error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^ ".")
+
+(* raw_param list -> bool -> int -> Proof.state -> Proof.state *)
+fun pick_nits override_params auto subgoal state =
+ let
+ val thy = Proof.theory_of state
+ val ctxt = Proof.context_of state
+ val thm = snd (snd (Proof.get_goal state))
+ val _ = List.app check_raw_param override_params
+ val params as {blocking, debug, ...} =
+ extract_params ctxt auto (default_raw_params thy) override_params
+ (* unit -> Proof.state *)
+ fun go () =
+ (if auto then perhaps o try
+ else if debug then fn f => fn x => f x
+ else handle_exceptions ctxt)
+ (fn state => pick_nits_in_subgoal state params auto subgoal |> snd)
+ state
+ in
+ if auto orelse blocking then
+ go ()
+ else
+ (SimpleThread.fork true (fn () => (go (); ()));
+ state)
+ end
+
+(* (TableFun().key * string list) list option * int option
+ -> Toplevel.transition -> Toplevel.transition *)
+fun nitpick_trans (opt_params, opt_subgoal) =
+ Toplevel.keep (K ()
+ o pick_nits (these opt_params) false (the_default 1 opt_subgoal)
+ o Toplevel.proof_of)
+
+(* raw_param -> string *)
+fun string_for_raw_param (name, value) =
+ name ^ " = " ^ stringify_raw_param_value value
+
+(* bool -> Proof.state -> Proof.state *)
+fun pick_nits_auto interactive state =
+ let val thy = Proof.theory_of state in
+ ((interactive andalso not (!Toplevel.quiet)
+ andalso the (general_lookup_bool false (default_raw_params thy)
+ (SOME false) "auto"))
+ ? pick_nits [] true 0) state
+ end
+
+(* theory -> theory *)
+fun register_auto thy =
+ (not (is_registered_auto thy)
+ ? (set_registered_auto
+ #> Context.theory_map (Specification.add_theorem_hook pick_nits_auto)))
+ thy
+
+(* (TableFun().key * string) list option -> Toplevel.transition
+ -> Toplevel.transition *)
+fun nitpick_params_trans opt_params =
+ Toplevel.theory
+ (fn thy =>
+ let val thy = fold set_default_raw_param (these opt_params) thy in
+ writeln ("Default parameters for Nitpick:\n" ^
+ (case rev (default_raw_params thy) of
+ [] => "none"
+ | params =>
+ (map check_raw_param params;
+ params |> map string_for_raw_param |> sort_strings
+ |> cat_lines)));
+ register_auto thy
+ end)
+
+(* OuterParse.token list
+ -> (Toplevel.transition -> Toplevel.transition) * OuterParse.token list *)
+fun scan_nitpick_command tokens =
+ (scan_params -- Scan.option OuterParse.nat) tokens |>> nitpick_trans
+fun scan_nitpick_params_command tokens =
+ scan_params tokens |>> nitpick_params_trans
+
+val _ = OuterSyntax.improper_command "nitpick"
+ "try to find a counterexample for a given subgoal using Kodkod"
+ OuterKeyword.diag scan_nitpick_command
+val _ = OuterSyntax.command "nitpick_params"
+ "set and display the default parameters for Nitpick"
+ OuterKeyword.thy_decl scan_nitpick_params_command
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1737 @@
+(* Title: HOL/Nitpick/Tools/nitpick_kodkod.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Kodkod problem generator part of Kodkod.
+*)
+
+signature NITPICK_KODKOD =
+sig
+ type extended_context = NitpickHOL.extended_context
+ type dtype_spec = NitpickScope.dtype_spec
+ type kodkod_constrs = NitpickPeephole.kodkod_constrs
+ type nut = NitpickNut.nut
+ type nfa_transition = Kodkod.rel_expr * typ
+ type nfa_entry = typ * nfa_transition list
+ type nfa_table = nfa_entry list
+
+ structure NameTable : TABLE
+
+ val univ_card :
+ int -> int -> int -> Kodkod.bound list -> Kodkod.formula -> int
+ val check_arity : int -> int -> unit
+ val kk_tuple : bool -> int -> int list -> Kodkod.tuple
+ val tuple_set_from_atom_schema : (int * int) list -> Kodkod.tuple_set
+ val sequential_int_bounds : int -> Kodkod.int_bound list
+ val bounds_for_built_in_rels_in_formula :
+ bool -> int -> int -> int -> int -> Kodkod.formula -> Kodkod.bound list
+ val bound_for_plain_rel : Proof.context -> bool -> nut -> Kodkod.bound
+ val bound_for_sel_rel :
+ Proof.context -> bool -> dtype_spec list -> nut -> Kodkod.bound
+ val merge_bounds : Kodkod.bound list -> Kodkod.bound list
+ val declarative_axiom_for_plain_rel : kodkod_constrs -> nut -> Kodkod.formula
+ val declarative_axioms_for_datatypes :
+ extended_context -> int Typtab.table -> kodkod_constrs
+ -> nut NameTable.table -> dtype_spec list -> Kodkod.formula list
+ val kodkod_formula_from_nut :
+ int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula
+end;
+
+structure NitpickKodkod : NITPICK_KODKOD =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickScope
+open NitpickPeephole
+open NitpickRep
+open NitpickNut
+
+type nfa_transition = Kodkod.rel_expr * typ
+type nfa_entry = typ * nfa_transition list
+type nfa_table = nfa_entry list
+
+structure NfaGraph = Graph(type key = typ val ord = TermOrd.typ_ord)
+
+(* int -> Kodkod.int_expr list *)
+fun flip_nums n = index_seq 1 n @ [0] |> map Kodkod.Num
+
+(* int -> int -> int -> Kodkod.bound list -> Kodkod.formula -> int *)
+fun univ_card nat_card int_card main_j0 bounds formula =
+ let
+ (* Kodkod.rel_expr -> int -> int *)
+ fun rel_expr_func r k =
+ Int.max (k, case r of
+ Kodkod.Atom j => j + 1
+ | Kodkod.AtomSeq (k', j0) => j0 + k'
+ | _ => 0)
+ (* Kodkod.tuple -> int -> int *)
+ fun tuple_func t k =
+ case t of
+ Kodkod.Tuple js => fold Integer.max (map (Integer.add 1) js) k
+ | _ => k
+ (* Kodkod.tuple_set -> int -> int *)
+ fun tuple_set_func ts k =
+ Int.max (k, case ts of Kodkod.TupleAtomSeq (k', j0) => j0 + k' | _ => 0)
+ val expr_F = {formula_func = K I, rel_expr_func = rel_expr_func,
+ int_expr_func = K I}
+ val tuple_F = {tuple_func = tuple_func, tuple_set_func = tuple_set_func}
+ val card = fold (Kodkod.fold_bound expr_F tuple_F) bounds 1
+ |> Kodkod.fold_formula expr_F formula
+ in Int.max (main_j0 + fold Integer.max [2, nat_card, int_card] 0, card) end
+
+(* Proof.context -> bool -> string -> typ -> rep -> string *)
+fun bound_comment ctxt debug nick T R =
+ short_const_name nick ^
+ (if debug then " :: " ^ plain_string_from_yxml (Syntax.string_of_typ ctxt T)
+ else "") ^ " : " ^ string_for_rep R
+
+(* int -> int -> unit *)
+fun check_arity univ_card n =
+ if n > Kodkod.max_arity univ_card then
+ raise LIMIT ("NitpickKodkod.check_arity",
+ "arity " ^ string_of_int n ^ " too large for universe of \
+ \cardinality " ^ string_of_int univ_card)
+ else
+ ()
+
+(* bool -> int -> int list -> Kodkod.tuple *)
+fun kk_tuple debug univ_card js =
+ if debug then
+ Kodkod.Tuple js
+ else
+ Kodkod.TupleIndex (length js,
+ fold (fn j => fn accum => accum * univ_card + j) js 0)
+
+(* (int * int) list -> Kodkod.tuple_set *)
+val tuple_set_from_atom_schema =
+ foldl1 Kodkod.TupleProduct o map Kodkod.TupleAtomSeq
+(* rep -> Kodkod.tuple_set *)
+val upper_bound_for_rep = tuple_set_from_atom_schema o atom_schema_of_rep
+
+(* int -> Kodkod.int_bound list *)
+fun sequential_int_bounds n =
+ [(NONE, map (Kodkod.TupleSet o single o Kodkod.Tuple o single)
+ (index_seq 0 n))]
+
+(* Kodkod.formula -> Kodkod.n_ary_index list *)
+fun built_in_rels_in_formula formula =
+ let
+ (* Kodkod.rel_expr -> Kodkod.n_ary_index list -> Kodkod.n_ary_index list *)
+ fun rel_expr_func (Kodkod.Rel (n, j)) rels =
+ (case AList.lookup (op =) (#rels initial_pool) n of
+ SOME k => (j < k ? insert (op =) (n, j)) rels
+ | NONE => rels)
+ | rel_expr_func _ rels = rels
+ val expr_F = {formula_func = K I, rel_expr_func = rel_expr_func,
+ int_expr_func = K I}
+ in Kodkod.fold_formula expr_F formula [] end
+
+val max_table_size = 65536
+
+(* int -> unit *)
+fun check_table_size k =
+ if k > max_table_size then
+ raise LIMIT ("NitpickKodkod.check_table_size",
+ "precomputed table too large (" ^ string_of_int k ^ ")")
+ else
+ ()
+
+(* bool -> int -> int * int -> (int -> int) -> Kodkod.tuple list *)
+fun tabulate_func1 debug univ_card (k, j0) f =
+ (check_table_size k;
+ map_filter (fn j1 => let val j2 = f j1 in
+ if j2 >= 0 then
+ SOME (kk_tuple debug univ_card [j1 + j0, j2 + j0])
+ else
+ NONE
+ end) (index_seq 0 k))
+(* bool -> int -> int * int -> int -> (int * int -> int) -> Kodkod.tuple list *)
+fun tabulate_op2 debug univ_card (k, j0) res_j0 f =
+ (check_table_size (k * k);
+ map_filter (fn j => let
+ val j1 = j div k
+ val j2 = j - j1 * k
+ val j3 = f (j1, j2)
+ in
+ if j3 >= 0 then
+ SOME (kk_tuple debug univ_card
+ [j1 + j0, j2 + j0, j3 + res_j0])
+ else
+ NONE
+ end) (index_seq 0 (k * k)))
+(* bool -> int -> int * int -> int -> (int * int -> int * int)
+ -> Kodkod.tuple list *)
+fun tabulate_op2_2 debug univ_card (k, j0) res_j0 f =
+ (check_table_size (k * k);
+ map_filter (fn j => let
+ val j1 = j div k
+ val j2 = j - j1 * k
+ val (j3, j4) = f (j1, j2)
+ in
+ if j3 >= 0 andalso j4 >= 0 then
+ SOME (kk_tuple debug univ_card
+ [j1 + j0, j2 + j0, j3 + res_j0,
+ j4 + res_j0])
+ else
+ NONE
+ end) (index_seq 0 (k * k)))
+(* bool -> int -> int * int -> (int * int -> int) -> Kodkod.tuple list *)
+fun tabulate_nat_op2 debug univ_card (k, j0) f =
+ tabulate_op2 debug univ_card (k, j0) j0 (atom_for_nat (k, 0) o f)
+fun tabulate_int_op2 debug univ_card (k, j0) f =
+ tabulate_op2 debug univ_card (k, j0) j0
+ (atom_for_int (k, 0) o f o pairself (int_for_atom (k, 0)))
+(* bool -> int -> int * int -> (int * int -> int * int) -> Kodkod.tuple list *)
+fun tabulate_int_op2_2 debug univ_card (k, j0) f =
+ tabulate_op2_2 debug univ_card (k, j0) j0
+ (pairself (atom_for_int (k, 0)) o f
+ o pairself (int_for_atom (k, 0)))
+
+(* int * int -> int *)
+fun isa_div (m, n) = m div n handle General.Div => 0
+fun isa_mod (m, n) = m mod n handle General.Div => m
+fun isa_gcd (m, 0) = m
+ | isa_gcd (m, n) = isa_gcd (n, isa_mod (m, n))
+fun isa_lcm (m, n) = isa_div (m * n, isa_gcd (m, n))
+val isa_zgcd = isa_gcd o pairself abs
+(* int * int -> int * int *)
+fun isa_norm_frac (m, n) =
+ if n < 0 then isa_norm_frac (~m, ~n)
+ else if m = 0 orelse n = 0 then (0, 1)
+ else let val p = isa_zgcd (m, n) in (isa_div (m, p), isa_div (n, p)) end
+
+(* bool -> int -> int -> int -> int -> int * int
+ -> string * bool * Kodkod.tuple list *)
+fun tabulate_built_in_rel debug univ_card nat_card int_card j0 (x as (n, _)) =
+ (check_arity univ_card n;
+ if Kodkod.Rel x = not3_rel then
+ ("not3", tabulate_func1 debug univ_card (2, j0) (curry (op -) 1))
+ else if Kodkod.Rel x = suc_rel then
+ ("suc", tabulate_func1 debug univ_card (univ_card - j0 - 1, j0)
+ (Integer.add 1))
+ else if Kodkod.Rel x = nat_add_rel then
+ ("nat_add", tabulate_nat_op2 debug univ_card (nat_card, j0) (op +))
+ else if Kodkod.Rel x = int_add_rel then
+ ("int_add", tabulate_int_op2 debug univ_card (int_card, j0) (op +))
+ else if Kodkod.Rel x = nat_subtract_rel then
+ ("nat_subtract",
+ tabulate_op2 debug univ_card (nat_card, j0) j0 (op nat_minus))
+ else if Kodkod.Rel x = int_subtract_rel then
+ ("int_subtract", tabulate_int_op2 debug univ_card (int_card, j0) (op -))
+ else if Kodkod.Rel x = nat_multiply_rel then
+ ("nat_multiply", tabulate_nat_op2 debug univ_card (nat_card, j0) (op * ))
+ else if Kodkod.Rel x = int_multiply_rel then
+ ("int_multiply", tabulate_int_op2 debug univ_card (int_card, j0) (op * ))
+ else if Kodkod.Rel x = nat_divide_rel then
+ ("nat_divide", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_div)
+ else if Kodkod.Rel x = int_divide_rel then
+ ("int_divide", tabulate_int_op2 debug univ_card (int_card, j0) isa_div)
+ else if Kodkod.Rel x = nat_modulo_rel then
+ ("nat_modulo", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_mod)
+ else if Kodkod.Rel x = int_modulo_rel then
+ ("int_modulo", tabulate_int_op2 debug univ_card (int_card, j0) isa_mod)
+ else if Kodkod.Rel x = nat_less_rel then
+ ("nat_less", tabulate_nat_op2 debug univ_card (nat_card, j0)
+ (int_for_bool o op <))
+ else if Kodkod.Rel x = int_less_rel then
+ ("int_less", tabulate_int_op2 debug univ_card (int_card, j0)
+ (int_for_bool o op <))
+ else if Kodkod.Rel x = gcd_rel then
+ ("gcd", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_gcd)
+ else if Kodkod.Rel x = lcm_rel then
+ ("lcm", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_lcm)
+ else if Kodkod.Rel x = norm_frac_rel then
+ ("norm_frac", tabulate_int_op2_2 debug univ_card (int_card, j0)
+ isa_norm_frac)
+ else
+ raise ARG ("NitpickKodkod.tabulate_built_in_rel", "unknown relation"))
+
+(* bool -> int -> int -> int -> int -> int * int -> Kodkod.rel_expr
+ -> Kodkod.bound *)
+fun bound_for_built_in_rel debug univ_card nat_card int_card j0 x =
+ let
+ val (nick, ts) = tabulate_built_in_rel debug univ_card nat_card int_card
+ j0 x
+ in ([(x, nick)], [Kodkod.TupleSet ts]) end
+
+(* bool -> int -> int -> int -> int -> Kodkod.formula -> Kodkod.bound list *)
+fun bounds_for_built_in_rels_in_formula debug univ_card nat_card int_card j0 =
+ map (bound_for_built_in_rel debug univ_card nat_card int_card j0)
+ o built_in_rels_in_formula
+
+(* Proof.context -> bool -> nut -> Kodkod.bound *)
+fun bound_for_plain_rel ctxt debug (u as FreeRel (x, T, R, nick)) =
+ ([(x, bound_comment ctxt debug nick T R)],
+ if nick = @{const_name bisim_iterator_max} then
+ case R of
+ Atom (k, j0) => [Kodkod.TupleSet [Kodkod.Tuple [k - 1 + j0]]]
+ | _ => raise NUT ("NitpickKodkod.bound_for_plain_rel", [u])
+ else
+ [Kodkod.TupleSet [], upper_bound_for_rep R])
+ | bound_for_plain_rel _ _ u =
+ raise NUT ("NitpickKodkod.bound_for_plain_rel", [u])
+
+(* Proof.context -> bool -> dtype_spec list -> nut -> Kodkod.bound *)
+fun bound_for_sel_rel ctxt debug dtypes
+ (FreeRel (x, T as Type ("fun", [T1, T2]), R as Func (Atom (_, j0), R2),
+ nick)) =
+ let
+ val constr as {delta, epsilon, exclusive, explicit_max, ...} =
+ constr_spec dtypes (original_name nick, T1)
+ in
+ ([(x, bound_comment ctxt debug nick T R)],
+ if explicit_max = 0 then
+ [Kodkod.TupleSet []]
+ else
+ let val ts = Kodkod.TupleAtomSeq (epsilon - delta, delta + j0) in
+ if R2 = Formula Neut then
+ [ts] |> not exclusive ? cons (Kodkod.TupleSet [])
+ else
+ [Kodkod.TupleSet [],
+ Kodkod.TupleProduct (ts, upper_bound_for_rep R2)]
+ end)
+ end
+ | bound_for_sel_rel _ _ _ u =
+ raise NUT ("NitpickKodkod.bound_for_sel_rel", [u])
+
+(* Kodkod.bound list -> Kodkod.bound list *)
+fun merge_bounds bs =
+ let
+ (* Kodkod.bound -> int *)
+ fun arity (zs, _) = fst (fst (hd zs))
+ (* Kodkod.bound list -> Kodkod.bound -> Kodkod.bound list
+ -> Kodkod.bound list *)
+ fun add_bound ds b [] = List.revAppend (ds, [b])
+ | add_bound ds b (c :: cs) =
+ if arity b = arity c andalso snd b = snd c then
+ List.revAppend (ds, (fst c @ fst b, snd c) :: cs)
+ else
+ add_bound (c :: ds) b cs
+ in fold (add_bound []) bs [] end
+
+(* int -> int -> Kodkod.rel_expr list *)
+fun unary_var_seq j0 n = map (curry Kodkod.Var 1) (index_seq j0 n)
+
+(* int list -> Kodkod.rel_expr *)
+val singleton_from_combination = foldl1 Kodkod.Product o map Kodkod.Atom
+(* rep -> Kodkod.rel_expr list *)
+fun all_singletons_for_rep R =
+ if is_lone_rep R then
+ all_combinations_for_rep R |> map singleton_from_combination
+ else
+ raise REP ("NitpickKodkod.all_singletons_for_rep", [R])
+
+(* Kodkod.rel_expr -> Kodkod.rel_expr list *)
+fun unpack_products (Kodkod.Product (r1, r2)) =
+ unpack_products r1 @ unpack_products r2
+ | unpack_products r = [r]
+fun unpack_joins (Kodkod.Join (r1, r2)) = unpack_joins r1 @ unpack_joins r2
+ | unpack_joins r = [r]
+
+(* rep -> Kodkod.rel_expr *)
+val empty_rel_for_rep = empty_n_ary_rel o arity_of_rep
+fun full_rel_for_rep R =
+ case atom_schema_of_rep R of
+ [] => raise REP ("NitpickKodkod.full_rel_for_rep", [R])
+ | schema => foldl1 Kodkod.Product (map Kodkod.AtomSeq schema)
+
+(* int -> int list -> Kodkod.decl list *)
+fun decls_for_atom_schema j0 schema =
+ map2 (fn j => fn x => Kodkod.DeclOne ((1, j), Kodkod.AtomSeq x))
+ (index_seq j0 (length schema)) schema
+
+(* The type constraint below is a workaround for a Poly/ML bug. *)
+
+(* FIXME: clean up *)
+(* kodkod_constrs -> rep -> Kodkod.rel_expr -> Kodkod.formula *)
+fun d_n_ary_function ({kk_all, kk_join, kk_lone, kk_one, ...} : kodkod_constrs)
+ R r =
+ let val body_R = body_rep R in
+ if is_lone_rep body_R then
+ let
+ val binder_schema = atom_schema_of_reps (binder_reps R)
+ val body_schema = atom_schema_of_rep body_R
+ val one = is_one_rep body_R
+ val opt_x = case r of Kodkod.Rel x => SOME x | _ => NONE
+ in
+ if opt_x <> NONE andalso length binder_schema = 1
+ andalso length body_schema = 1 then
+ (if one then Kodkod.Function else Kodkod.Functional)
+ (the opt_x, Kodkod.AtomSeq (hd binder_schema),
+ Kodkod.AtomSeq (hd body_schema))
+ else
+ let
+ val decls = decls_for_atom_schema ~1 binder_schema
+ val vars = unary_var_seq ~1 (length binder_schema)
+ val kk_xone = if one then kk_one else kk_lone
+ in kk_all decls (kk_xone (fold kk_join vars r)) end
+ end
+ else
+ Kodkod.True
+ end
+fun kk_n_ary_function kk R (r as Kodkod.Rel _) =
+ (* FIXME: weird test *)
+ if not (is_opt_rep R) then
+ if r = suc_rel then
+ Kodkod.False
+ else if r = nat_add_rel then
+ formula_for_bool (card_of_rep (body_rep R) = 1)
+ else if r = nat_multiply_rel then
+ formula_for_bool (card_of_rep (body_rep R) <= 2)
+ else
+ d_n_ary_function kk R r
+ else if r = nat_subtract_rel then
+ Kodkod.True
+ else
+ d_n_ary_function kk R r
+ | kk_n_ary_function kk R r = d_n_ary_function kk R r
+
+(* kodkod_constrs -> Kodkod.rel_expr list -> Kodkod.formula *)
+fun kk_disjoint_sets _ [] = Kodkod.True
+ | kk_disjoint_sets (kk as {kk_and, kk_no, kk_intersect, ...} : kodkod_constrs)
+ (r :: rs) =
+ fold (kk_and o kk_no o kk_intersect r) rs (kk_disjoint_sets kk rs)
+
+(* int -> kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr)
+ -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+fun basic_rel_let j ({kk_rel_let, ...} : kodkod_constrs) f r =
+ if inline_rel_expr r then
+ f r
+ else
+ let val x = (Kodkod.arity_of_rel_expr r, j) in
+ kk_rel_let [Kodkod.AssignRelReg (x, r)] (f (Kodkod.RelReg x))
+ end
+
+(* kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr) -> Kodkod.rel_expr
+ -> Kodkod.rel_expr *)
+val single_rel_let = basic_rel_let 0
+(* kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr)
+ -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+fun double_rel_let kk f r1 r2 =
+ single_rel_let kk (fn r1 => basic_rel_let 1 kk (f r1) r2) r1
+(* kodkod_constrs
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr)
+ -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr
+ -> Kodkod.rel_expr *)
+fun triple_rel_let kk f r1 r2 r3 =
+ double_rel_let kk (fn r1 => fn r2 => basic_rel_let 2 kk (f r1 r2) r3) r1 r2
+
+(* kodkod_constrs -> int -> Kodkod.formula -> Kodkod.rel_expr *)
+fun atom_from_formula ({kk_rel_if, ...} : kodkod_constrs) j0 f =
+ kk_rel_if f (Kodkod.Atom (j0 + 1)) (Kodkod.Atom j0)
+(* kodkod_constrs -> rep -> Kodkod.formula -> Kodkod.rel_expr *)
+fun rel_expr_from_formula kk R f =
+ case unopt_rep R of
+ Atom (2, j0) => atom_from_formula kk j0 f
+ | _ => raise REP ("NitpickKodkod.rel_expr_from_formula", [R])
+
+(* kodkod_cotrs -> int -> int -> Kodkod.rel_expr -> Kodkod.rel_expr list *)
+fun unpack_vect_in_chunks ({kk_project_seq, ...} : kodkod_constrs) chunk_arity
+ num_chunks r =
+ List.tabulate (num_chunks, fn j => kk_project_seq r (j * chunk_arity)
+ chunk_arity)
+
+(* kodkod_constrs -> bool -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr
+ -> Kodkod.rel_expr *)
+fun kk_n_fold_join
+ (kk as {kk_intersect, kk_product, kk_join, kk_project_seq, ...}) one R1
+ res_R r1 r2 =
+ case arity_of_rep R1 of
+ 1 => kk_join r1 r2
+ | arity1 =>
+ let
+ val unpacked_rs1 =
+ if inline_rel_expr r1 then unpack_vect_in_chunks kk 1 arity1 r1
+ else unpack_products r1
+ in
+ if one andalso length unpacked_rs1 = arity1 then
+ fold kk_join unpacked_rs1 r2
+ else
+ kk_project_seq
+ (kk_intersect (kk_product r1 (full_rel_for_rep res_R)) r2)
+ arity1 (arity_of_rep res_R)
+ end
+
+(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr list
+ -> Kodkod.rel_expr list -> Kodkod.rel_expr *)
+fun kk_case_switch (kk as {kk_union, kk_product, ...}) R1 R2 r rs1 rs2 =
+ if rs1 = rs2 then r
+ else kk_n_fold_join kk true R1 R2 r (fold1 kk_union (map2 kk_product rs1 rs2))
+
+val lone_rep_fallback_max_card = 4096
+val some_j0 = 0
+
+(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+fun lone_rep_fallback kk new_R old_R r =
+ if old_R = new_R then
+ r
+ else
+ let val card = card_of_rep old_R in
+ if is_lone_rep old_R andalso is_lone_rep new_R
+ andalso card = card_of_rep new_R then
+ if card >= lone_rep_fallback_max_card then
+ raise LIMIT ("NitpickKodkod.lone_rep_fallback",
+ "too high cardinality (" ^ string_of_int card ^ ")")
+ else
+ kk_case_switch kk old_R new_R r (all_singletons_for_rep old_R)
+ (all_singletons_for_rep new_R)
+ else
+ raise REP ("NitpickKodkod.lone_rep_fallback", [old_R, new_R])
+ end
+(* kodkod_constrs -> int * int -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and atom_from_rel_expr kk (x as (k, j0)) old_R r =
+ case old_R of
+ Func (R1, R2) =>
+ let
+ val dom_card = card_of_rep R1
+ val R2' = case R2 of Atom _ => R2 | _ => Atom (card_of_rep R2, some_j0)
+ in
+ atom_from_rel_expr kk x (Vect (dom_card, R2'))
+ (vect_from_rel_expr kk dom_card R2' old_R r)
+ end
+ | Opt _ => raise REP ("NitpickKodkod.atom_from_rel_expr", [old_R])
+ | _ => lone_rep_fallback kk (Atom x) old_R r
+(* kodkod_constrs -> rep list -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and struct_from_rel_expr kk Rs old_R r =
+ case old_R of
+ Atom _ => lone_rep_fallback kk (Struct Rs) old_R r
+ | Struct Rs' =>
+ let
+ val Rs = filter (not_equal Unit) Rs
+ val Rs' = filter (not_equal Unit) Rs'
+ in
+ if Rs' = Rs then
+ r
+ else if map card_of_rep Rs' = map card_of_rep Rs then
+ let
+ val old_arities = map arity_of_rep Rs'
+ val old_offsets = offset_list old_arities
+ val old_rs = map2 (#kk_project_seq kk r) old_offsets old_arities
+ in
+ fold1 (#kk_product kk)
+ (map3 (rel_expr_from_rel_expr kk) Rs Rs' old_rs)
+ end
+ else
+ lone_rep_fallback kk (Struct Rs) old_R r
+ end
+ | _ => raise REP ("NitpickKodkod.struct_from_rel_expr", [old_R])
+(* kodkod_constrs -> int -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and vect_from_rel_expr kk k R old_R r =
+ case old_R of
+ Atom _ => lone_rep_fallback kk (Vect (k, R)) old_R r
+ | Vect (k', R') =>
+ if k = k' andalso R = R' then r
+ else lone_rep_fallback kk (Vect (k, R)) old_R r
+ | Func (R1, Formula Neut) =>
+ if k = card_of_rep R1 then
+ fold1 (#kk_product kk)
+ (map (fn arg_r =>
+ rel_expr_from_formula kk R (#kk_subset kk arg_r r))
+ (all_singletons_for_rep R1))
+ else
+ raise REP ("NitpickKodkod.vect_from_rel_expr", [old_R])
+ | Func (Unit, R2) => rel_expr_from_rel_expr kk R R2 r
+ | Func (R1, R2) =>
+ fold1 (#kk_product kk)
+ (map (fn arg_r =>
+ rel_expr_from_rel_expr kk R R2
+ (kk_n_fold_join kk true R1 R2 arg_r r))
+ (all_singletons_for_rep R1))
+ | _ => raise REP ("NitpickKodkod.vect_from_rel_expr", [old_R])
+(* kodkod_constrs -> rep -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and func_from_no_opt_rel_expr kk R1 R2 (Atom x) r =
+ let
+ val dom_card = card_of_rep R1
+ val R2' = case R2 of Atom _ => R2 | _ => Atom (card_of_rep R2, some_j0)
+ in
+ func_from_no_opt_rel_expr kk R1 R2 (Vect (dom_card, R2'))
+ (vect_from_rel_expr kk dom_card R2' (Atom x) r)
+ end
+ | func_from_no_opt_rel_expr kk Unit R2 old_R r =
+ (case old_R of
+ Vect (k, R') => rel_expr_from_rel_expr kk R2 R' r
+ | Func (Unit, R2') => rel_expr_from_rel_expr kk R2 R2' r
+ | Func (Atom (1, _), Formula Neut) =>
+ (case unopt_rep R2 of
+ Atom (2, j0) => atom_from_formula kk j0 (#kk_some kk r)
+ | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
+ [old_R, Func (Unit, R2)]))
+ | Func (R1', R2') =>
+ rel_expr_from_rel_expr kk R2 R2' (#kk_project_seq kk r (arity_of_rep R1')
+ (arity_of_rep R2'))
+ | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
+ [old_R, Func (Unit, R2)]))
+ | func_from_no_opt_rel_expr kk R1 (Formula Neut) old_R r =
+ (case old_R of
+ Vect (k, Atom (2, j0)) =>
+ let
+ val args_rs = all_singletons_for_rep R1
+ val vals_rs = unpack_vect_in_chunks kk 1 k r
+ (* Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+ fun empty_or_singleton_set_for arg_r val_r =
+ #kk_join kk val_r (#kk_product kk (Kodkod.Atom (j0 + 1)) arg_r)
+ in
+ fold1 (#kk_union kk) (map2 empty_or_singleton_set_for args_rs vals_rs)
+ end
+ | Func (R1', Formula Neut) =>
+ if R1 = R1' then
+ r
+ else
+ let
+ val schema = atom_schema_of_rep R1
+ val r1 = fold1 (#kk_product kk) (unary_var_seq ~1 (length schema))
+ |> rel_expr_from_rel_expr kk R1' R1
+ in
+ #kk_comprehension kk (decls_for_atom_schema ~1 schema)
+ (#kk_subset kk r1 r)
+ end
+ | Func (Unit, (Atom (2, j0))) =>
+ #kk_rel_if kk (#kk_rel_eq kk r (Kodkod.Atom (j0 + 1)))
+ (full_rel_for_rep R1) (empty_rel_for_rep R1)
+ | Func (R1', Atom (2, j0)) =>
+ func_from_no_opt_rel_expr kk R1 (Formula Neut)
+ (Func (R1', Formula Neut)) (#kk_join kk r (Kodkod.Atom (j0 + 1)))
+ | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
+ [old_R, Func (R1, Formula Neut)]))
+ | func_from_no_opt_rel_expr kk R1 R2 old_R r =
+ case old_R of
+ Vect (k, R) =>
+ let
+ val args_rs = all_singletons_for_rep R1
+ val vals_rs = unpack_vect_in_chunks kk (arity_of_rep R) k r
+ |> map (rel_expr_from_rel_expr kk R2 R)
+ in fold1 (#kk_union kk) (map2 (#kk_product kk) args_rs vals_rs) end
+ | Func (R1', Formula Neut) =>
+ (case R2 of
+ Atom (x as (2, j0)) =>
+ let val schema = atom_schema_of_rep R1 in
+ if length schema = 1 then
+ #kk_override kk (#kk_product kk (Kodkod.AtomSeq (hd schema))
+ (Kodkod.Atom j0))
+ (#kk_product kk r (Kodkod.Atom (j0 + 1)))
+ else
+ let
+ val r1 = fold1 (#kk_product kk) (unary_var_seq ~1 (length schema))
+ |> rel_expr_from_rel_expr kk R1' R1
+ val r2 = Kodkod.Var (1, ~(length schema) - 1)
+ val r3 = atom_from_formula kk j0 (#kk_subset kk r1 r)
+ in
+ #kk_comprehension kk (decls_for_atom_schema ~1 (schema @ [x]))
+ (#kk_rel_eq kk r2 r3)
+ end
+ end
+ | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
+ [old_R, Func (R1, R2)]))
+ | Func (Unit, R2') =>
+ let val j0 = some_j0 in
+ func_from_no_opt_rel_expr kk R1 R2 (Func (Atom (1, j0), R2'))
+ (#kk_product kk (Kodkod.Atom j0) r)
+ end
+ | Func (R1', R2') =>
+ if R1 = R1' andalso R2 = R2' then
+ r
+ else
+ let
+ val dom_schema = atom_schema_of_rep R1
+ val ran_schema = atom_schema_of_rep R2
+ val dom_prod = fold1 (#kk_product kk)
+ (unary_var_seq ~1 (length dom_schema))
+ |> rel_expr_from_rel_expr kk R1' R1
+ val ran_prod = fold1 (#kk_product kk)
+ (unary_var_seq (~(length dom_schema) - 1)
+ (length ran_schema))
+ |> rel_expr_from_rel_expr kk R2' R2
+ val app = kk_n_fold_join kk true R1' R2' dom_prod r
+ in
+ #kk_comprehension kk (decls_for_atom_schema ~1
+ (dom_schema @ ran_schema))
+ (#kk_subset kk ran_prod app)
+ end
+ | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
+ [old_R, Func (R1, R2)])
+(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and rel_expr_from_rel_expr kk new_R old_R r =
+ let
+ val unopt_old_R = unopt_rep old_R
+ val unopt_new_R = unopt_rep new_R
+ in
+ if unopt_old_R <> old_R andalso unopt_new_R = new_R then
+ raise REP ("NitpickKodkod.rel_expr_from_rel_expr", [old_R, new_R])
+ else if unopt_new_R = unopt_old_R then
+ r
+ else
+ (case unopt_new_R of
+ Atom x => atom_from_rel_expr kk x
+ | Struct Rs => struct_from_rel_expr kk Rs
+ | Vect (k, R') => vect_from_rel_expr kk k R'
+ | Func (R1, R2) => func_from_no_opt_rel_expr kk R1 R2
+ | _ => raise REP ("NitpickKodkod.rel_expr_from_rel_expr",
+ [old_R, new_R]))
+ unopt_old_R r
+ end
+(* kodkod_constrs -> rep -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+and rel_expr_to_func kk R1 R2 = rel_expr_from_rel_expr kk (Func (R1, R2))
+
+(* kodkod_constrs -> nut -> Kodkod.formula *)
+fun declarative_axiom_for_plain_rel kk (FreeRel (x, _, R as Func _, nick)) =
+ kk_n_ary_function kk (R |> nick = @{const_name List.set} ? unopt_rep)
+ (Kodkod.Rel x)
+ | declarative_axiom_for_plain_rel ({kk_lone, kk_one, ...} : kodkod_constrs)
+ (FreeRel (x, _, R, _)) =
+ if is_one_rep R then kk_one (Kodkod.Rel x)
+ else if is_lone_rep R andalso card_of_rep R > 1 then kk_lone (Kodkod.Rel x)
+ else Kodkod.True
+ | declarative_axiom_for_plain_rel _ u =
+ raise NUT ("NitpickKodkod.declarative_axiom_for_plain_rel", [u])
+
+(* nut NameTable.table -> styp -> Kodkod.rel_expr * rep * int *)
+fun const_triple rel_table (x as (s, T)) =
+ case the_name rel_table (ConstName (s, T, Any)) of
+ FreeRel ((n, j), _, R, _) => (Kodkod.Rel (n, j), R, n)
+ | _ => raise TERM ("NitpickKodkod.const_triple", [Const x])
+
+(* nut NameTable.table -> styp -> Kodkod.rel_expr *)
+fun discr_rel_expr rel_table = #1 o const_triple rel_table o discr_for_constr
+
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+ -> styp -> int -> nfa_transition list *)
+fun nfa_transitions_for_sel ext_ctxt ({kk_project, ...} : kodkod_constrs)
+ rel_table (dtypes : dtype_spec list) constr_x n =
+ let
+ val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt constr_x n
+ val (r, R, arity) = const_triple rel_table x
+ val type_schema = type_schema_of_rep T R
+ in
+ map_filter (fn (j, T) =>
+ if forall (not_equal T o #typ) dtypes then NONE
+ else SOME (kk_project r (map Kodkod.Num [0, j]), T))
+ (index_seq 1 (arity - 1) ~~ tl type_schema)
+ end
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+ -> styp -> nfa_transition list *)
+fun nfa_transitions_for_constr ext_ctxt kk rel_table dtypes (x as (_, T)) =
+ maps (nfa_transitions_for_sel ext_ctxt kk rel_table dtypes x)
+ (index_seq 0 (num_sels_for_constr_type T))
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+ -> dtype_spec -> nfa_entry option *)
+fun nfa_entry_for_datatype _ _ _ _ ({co = true, ...} : dtype_spec) = NONE
+ | nfa_entry_for_datatype ext_ctxt kk rel_table dtypes
+ ({typ, constrs, ...} : dtype_spec) =
+ SOME (typ, maps (nfa_transitions_for_constr ext_ctxt kk rel_table dtypes
+ o #const) constrs)
+
+val empty_rel = Kodkod.Product (Kodkod.None, Kodkod.None)
+
+(* nfa_table -> typ -> typ -> Kodkod.rel_expr list *)
+fun direct_path_rel_exprs nfa start final =
+ case AList.lookup (op =) nfa final of
+ SOME trans => map fst (filter (equal start o snd) trans)
+ | NONE => []
+(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> Kodkod.rel_expr *)
+and any_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start final =
+ fold kk_union (direct_path_rel_exprs nfa start final)
+ (if start = final then Kodkod.Iden else empty_rel)
+ | any_path_rel_expr (kk as {kk_union, ...}) nfa (q :: qs) start final =
+ kk_union (any_path_rel_expr kk nfa qs start final)
+ (knot_path_rel_expr kk nfa qs start q final)
+(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> typ
+ -> Kodkod.rel_expr *)
+and knot_path_rel_expr (kk as {kk_join, kk_reflexive_closure, ...}) nfa qs start
+ knot final =
+ kk_join (kk_join (any_path_rel_expr kk nfa qs knot final)
+ (kk_reflexive_closure (loop_path_rel_expr kk nfa qs knot)))
+ (any_path_rel_expr kk nfa qs start knot)
+(* kodkod_constrs -> nfa_table -> typ list -> typ -> Kodkod.rel_expr *)
+and loop_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start =
+ fold kk_union (direct_path_rel_exprs nfa start start) empty_rel
+ | loop_path_rel_expr (kk as {kk_union, kk_closure, ...}) nfa (q :: qs) start =
+ if start = q then
+ kk_closure (loop_path_rel_expr kk nfa qs start)
+ else
+ kk_union (loop_path_rel_expr kk nfa qs start)
+ (knot_path_rel_expr kk nfa qs start q start)
+
+(* nfa_table -> unit NfaGraph.T *)
+fun graph_for_nfa nfa =
+ let
+ (* typ -> unit NfaGraph.T -> unit NfaGraph.T *)
+ fun new_node q = perhaps (try (NfaGraph.new_node (q, ())))
+ (* nfa_table -> unit NfaGraph.T -> unit NfaGraph.T *)
+ fun add_nfa [] = I
+ | add_nfa ((_, []) :: nfa) = add_nfa nfa
+ | add_nfa ((q, ((_, q') :: transitions)) :: nfa) =
+ add_nfa ((q, transitions) :: nfa) o NfaGraph.add_edge (q, q') o
+ new_node q' o new_node q
+ in add_nfa nfa NfaGraph.empty end
+
+(* nfa_table -> nfa_table list *)
+fun strongly_connected_sub_nfas nfa =
+ nfa |> graph_for_nfa |> NfaGraph.strong_conn
+ |> map (fn keys => filter (member (op =) keys o fst) nfa)
+
+(* dtype_spec list -> kodkod_constrs -> nfa_table -> typ -> Kodkod.formula *)
+fun acyclicity_axiom_for_datatype dtypes kk nfa start =
+ #kk_no kk (#kk_intersect kk
+ (loop_path_rel_expr kk nfa (map fst nfa) start) Kodkod.Iden)
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+ -> Kodkod.formula list *)
+fun acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes =
+ map_filter (nfa_entry_for_datatype ext_ctxt kk rel_table dtypes) dtypes
+ |> strongly_connected_sub_nfas
+ |> maps (fn nfa => map (acyclicity_axiom_for_datatype dtypes kk nfa o fst)
+ nfa)
+
+(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
+ -> Kodkod.rel_expr -> constr_spec -> int -> Kodkod.formula *)
+fun sel_axiom_for_sel ext_ctxt j0
+ (kk as {kk_all, kk_implies, kk_formula_if, kk_subset, kk_rel_eq, kk_no,
+ kk_join, kk_project, ...}) rel_table dom_r
+ ({const, delta, epsilon, exclusive, explicit_max, ...} : constr_spec)
+ n =
+ let
+ val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt const n
+ val (r, R, arity) = const_triple rel_table x
+ val R2 = dest_Func R |> snd
+ val z = (epsilon - delta, delta + j0)
+ in
+ if exclusive then
+ kk_n_ary_function kk (Func (Atom z, R2)) r
+ else
+ let val r' = kk_join (Kodkod.Var (1, 0)) r in
+ kk_all [Kodkod.DeclOne ((1, 0), Kodkod.AtomSeq z)]
+ (kk_formula_if (kk_subset (Kodkod.Var (1, 0)) dom_r)
+ (kk_n_ary_function kk R2 r')
+ (kk_no r'))
+ end
+ end
+(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
+ -> constr_spec -> Kodkod.formula list *)
+fun sel_axioms_for_constr ext_ctxt j0 kk rel_table
+ (constr as {const, delta, epsilon, explicit_max, ...}) =
+ let
+ val honors_explicit_max =
+ explicit_max < 0 orelse epsilon - delta <= explicit_max
+ in
+ if explicit_max = 0 then
+ [formula_for_bool honors_explicit_max]
+ else
+ let
+ val ran_r = discr_rel_expr rel_table const
+ val max_axiom =
+ if honors_explicit_max then Kodkod.True
+ else Kodkod.LE (Kodkod.Cardinality ran_r, Kodkod.Num explicit_max)
+ in
+ max_axiom ::
+ map (sel_axiom_for_sel ext_ctxt j0 kk rel_table ran_r constr)
+ (index_seq 0 (num_sels_for_constr_type (snd const)))
+ end
+ end
+(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec -> Kodkod.formula list *)
+fun sel_axioms_for_datatype ext_ctxt j0 kk rel_table
+ ({constrs, ...} : dtype_spec) =
+ maps (sel_axioms_for_constr ext_ctxt j0 kk rel_table) constrs
+
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
+ -> Kodkod.formula list *)
+fun uniqueness_axiom_for_constr ext_ctxt
+ ({kk_all, kk_implies, kk_and, kk_rel_eq, kk_lone, kk_join, ...}
+ : kodkod_constrs) rel_table ({const, ...} : constr_spec) =
+ let
+ (* Kodkod.rel_expr -> Kodkod.formula *)
+ fun conjunct_for_sel r =
+ kk_rel_eq (kk_join (Kodkod.Var (1, 0)) r)
+ (kk_join (Kodkod.Var (1, 1)) r)
+ val num_sels = num_sels_for_constr_type (snd const)
+ val triples = map (const_triple rel_table
+ o boxed_nth_sel_for_constr ext_ctxt const)
+ (~1 upto num_sels - 1)
+ val j0 = case triples |> hd |> #2 of
+ Func (Atom (_, j0), _) => j0
+ | R => raise REP ("NitpickKodkod.uniqueness_axiom_for_constr", [R])
+ val set_r = triples |> hd |> #1
+ in
+ if num_sels = 0 then
+ kk_lone set_r
+ else
+ kk_all (map (Kodkod.DeclOne o rpair set_r o pair 1) [0, 1])
+ (kk_implies
+ (fold1 kk_and (map (conjunct_for_sel o #1) (tl triples)))
+ (kk_rel_eq (Kodkod.Var (1, 0)) (Kodkod.Var (1, 1))))
+ end
+(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
+ -> Kodkod.formula list *)
+fun uniqueness_axioms_for_datatype ext_ctxt kk rel_table
+ ({constrs, ...} : dtype_spec) =
+ map (uniqueness_axiom_for_constr ext_ctxt kk rel_table) constrs
+
+(* constr_spec -> int *)
+fun effective_constr_max ({delta, epsilon, ...} : constr_spec) = epsilon - delta
+(* int -> kodkod_constrs -> nut NameTable.table -> dtype_spec
+ -> Kodkod.formula list *)
+fun partition_axioms_for_datatype j0 (kk as {kk_rel_eq, kk_union, ...})
+ rel_table
+ ({card, constrs, ...} : dtype_spec) =
+ if forall #exclusive constrs then
+ [Integer.sum (map effective_constr_max constrs) = card |> formula_for_bool]
+ else
+ let val rs = map (discr_rel_expr rel_table o #const) constrs in
+ [kk_rel_eq (fold1 kk_union rs) (Kodkod.AtomSeq (card, j0)),
+ kk_disjoint_sets kk rs]
+ end
+
+(* extended_context -> int Typtab.table -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec -> Kodkod.formula list *)
+fun other_axioms_for_datatype ext_ctxt ofs kk rel_table (dtype as {typ, ...}) =
+ let val j0 = offset_of_type ofs typ in
+ sel_axioms_for_datatype ext_ctxt j0 kk rel_table dtype @
+ uniqueness_axioms_for_datatype ext_ctxt kk rel_table dtype @
+ partition_axioms_for_datatype j0 kk rel_table dtype
+ end
+
+(* extended_context -> int Typtab.table -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec list -> Kodkod.formula list *)
+fun declarative_axioms_for_datatypes ext_ctxt ofs kk rel_table dtypes =
+ acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes @
+ maps (other_axioms_for_datatype ext_ctxt ofs kk rel_table) dtypes
+
+(* int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula *)
+fun kodkod_formula_from_nut ofs liberal
+ (kk as {kk_all, kk_exist, kk_formula_let, kk_formula_if, kk_or, kk_not,
+ kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no, kk_one,
+ kk_some, kk_rel_let, kk_rel_if, kk_union, kk_difference,
+ kk_intersect, kk_product, kk_join, kk_closure, kk_comprehension,
+ kk_project, kk_project_seq, kk_not3, kk_nat_less, kk_int_less,
+ ...}) u =
+ let
+ val main_j0 = offset_of_type ofs bool_T
+ val bool_j0 = main_j0
+ val bool_atom_R = Atom (2, main_j0)
+ val false_atom = Kodkod.Atom bool_j0
+ val true_atom = Kodkod.Atom (bool_j0 + 1)
+
+ (* polarity -> int -> Kodkod.rel_expr -> Kodkod.formula *)
+ fun formula_from_opt_atom polar j0 r =
+ case polar of
+ Neg => kk_not (kk_rel_eq r (Kodkod.Atom j0))
+ | _ => kk_rel_eq r (Kodkod.Atom (j0 + 1))
+ (* int -> Kodkod.rel_expr -> Kodkod.formula *)
+ val formula_from_atom = formula_from_opt_atom Pos
+
+ (* Kodkod.formula -> Kodkod.formula -> Kodkod.formula *)
+ fun kk_notimplies f1 f2 = kk_and f1 (kk_not f2)
+ (* Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+ val kk_or3 =
+ double_rel_let kk
+ (fn r1 => fn r2 =>
+ kk_rel_if (kk_subset true_atom (kk_union r1 r2)) true_atom
+ (kk_intersect r1 r2))
+ val kk_and3 =
+ double_rel_let kk
+ (fn r1 => fn r2 =>
+ kk_rel_if (kk_subset false_atom (kk_union r1 r2)) false_atom
+ (kk_intersect r1 r2))
+ fun kk_notimplies3 r1 r2 = kk_and3 r1 (kk_not3 r2)
+
+ (* int -> Kodkod.rel_expr -> Kodkod.formula list *)
+ val unpack_formulas =
+ map (formula_from_atom bool_j0) oo unpack_vect_in_chunks kk 1
+ (* (Kodkod.formula -> Kodkod.formula -> Kodkod.formula) -> int
+ -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+ fun kk_vect_set_op connective k r1 r2 =
+ fold1 kk_product (map2 (atom_from_formula kk bool_j0 oo connective)
+ (unpack_formulas k r1) (unpack_formulas k r2))
+ (* (Kodkod.formula -> Kodkod.formula -> Kodkod.formula) -> int
+ -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.formula *)
+ fun kk_vect_set_bool_op connective k r1 r2 =
+ fold1 kk_and (map2 connective (unpack_formulas k r1)
+ (unpack_formulas k r2))
+
+ (* nut -> Kodkod.formula *)
+ fun to_f u =
+ case rep_of u of
+ Formula polar =>
+ (case u of
+ Cst (False, _, _) => Kodkod.False
+ | Cst (True, _, _) => Kodkod.True
+ | Op1 (Not, _, _, u1) => kk_not (to_f u1)
+ | Op1 (Finite, _, _, u1) =>
+ let val opt1 = is_opt_rep (rep_of u1) in
+ case polar of
+ Neut => if opt1 then
+ raise NUT ("NitpickKodkod.to_f (Finite)", [u])
+ else
+ Kodkod.True
+ | Pos => formula_for_bool (not opt1)
+ | Neg => Kodkod.True
+ end
+ | Op1 (Cast, _, _, u1) => to_f_with_polarity polar u1
+ | Op2 (All, _, _, u1, u2) => kk_all (untuple to_decl u1) (to_f u2)
+ | Op2 (Exist, _, _, u1, u2) => kk_exist (untuple to_decl u1) (to_f u2)
+ | Op2 (Or, _, _, u1, u2) => kk_or (to_f u1) (to_f u2)
+ | Op2 (And, _, _, u1, u2) => kk_and (to_f u1) (to_f u2)
+ | Op2 (Less, T, Formula polar, u1, u2) =>
+ formula_from_opt_atom polar bool_j0
+ (to_r (Op2 (Less, T, Opt bool_atom_R, u1, u2)))
+ | Op2 (Subset, _, _, u1, u2) =>
+ let
+ val dom_T = domain_type (type_of u1)
+ val R1 = rep_of u1
+ val R2 = rep_of u2
+ val (dom_R, ran_R) =
+ case min_rep R1 R2 of
+ Func (Unit, R') =>
+ (Atom (1, offset_of_type ofs dom_T), R')
+ | Func Rp => Rp
+ | R => (Atom (card_of_domain_from_rep 2 R,
+ offset_of_type ofs dom_T),
+ if is_opt_rep R then Opt bool_atom_R else Formula Neut)
+ val set_R = Func (dom_R, ran_R)
+ in
+ if not (is_opt_rep ran_R) then
+ to_set_bool_op kk_implies kk_subset u1 u2
+ else if polar = Neut then
+ raise NUT ("NitpickKodkod.to_f (Subset)", [u])
+ else
+ let
+ (* bool -> nut -> Kodkod.rel_expr *)
+ fun set_to_r widen u =
+ if widen then
+ kk_difference (full_rel_for_rep dom_R)
+ (kk_join (to_rep set_R u) false_atom)
+ else
+ kk_join (to_rep set_R u) true_atom
+ val widen1 = (polar = Pos andalso is_opt_rep R1)
+ val widen2 = (polar = Neg andalso is_opt_rep R2)
+ in kk_subset (set_to_r widen1 u1) (set_to_r widen2 u2) end
+ end
+ | Op2 (DefEq, _, _, u1, u2) =>
+ (case min_rep (rep_of u1) (rep_of u2) of
+ Unit => Kodkod.True
+ | Formula polar =>
+ kk_iff (to_f_with_polarity polar u1) (to_f_with_polarity polar u2)
+ | min_R =>
+ let
+ (* nut -> nut list *)
+ fun args (Op2 (Apply, _, _, u1, u2)) = u2 :: args u1
+ | args (Tuple (_, _, us)) = us
+ | args _ = []
+ val opt_arg_us = filter (is_opt_rep o rep_of) (args u1)
+ in
+ if null opt_arg_us orelse not (is_Opt min_R)
+ orelse is_eval_name u1 then
+ fold (kk_or o (kk_no o to_r)) opt_arg_us
+ (kk_rel_eq (to_rep min_R u1) (to_rep min_R u2))
+ else
+ kk_no (kk_difference (to_rep min_R u1) (to_rep min_R u2))
+ end)
+ | Op2 (Eq, T, R, u1, u2) =>
+ (case min_rep (rep_of u1) (rep_of u2) of
+ Unit => Kodkod.True
+ | Formula polar =>
+ kk_iff (to_f_with_polarity polar u1) (to_f_with_polarity polar u2)
+ | min_R =>
+ if is_opt_rep min_R then
+ if polar = Neut then
+ (* continuation of hackish optimization *)
+ kk_rel_eq (to_rep min_R u1) (to_rep min_R u2)
+ else if is_Cst Unrep u1 then
+ to_could_be_unrep (polar = Neg) u2
+ else if is_Cst Unrep u2 then
+ to_could_be_unrep (polar = Neg) u1
+ else
+ let
+ val r1 = to_rep min_R u1
+ val r2 = to_rep min_R u2
+ val both_opt = forall (is_opt_rep o rep_of) [u1, u2]
+ in
+ (if polar = Pos then
+ if not both_opt then
+ kk_rel_eq r1 r2
+ else if is_lone_rep min_R
+ andalso arity_of_rep min_R = 1 then
+ kk_some (kk_intersect r1 r2)
+ else
+ raise SAME ()
+ else
+ if is_lone_rep min_R then
+ if arity_of_rep min_R = 1 then
+ kk_subset (kk_product r1 r2) Kodkod.Iden
+ else if not both_opt then
+ (r1, r2) |> is_opt_rep (rep_of u2) ? swap
+ |> uncurry kk_difference |> kk_no
+ else
+ raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () =>
+ formula_from_opt_atom polar bool_j0
+ (to_guard [u1, u2] bool_atom_R
+ (rel_expr_from_formula kk bool_atom_R
+ (kk_rel_eq r1 r2)))
+ end
+ else
+ let
+ val r1 = to_rep min_R u1
+ val r2 = to_rep min_R u2
+ in
+ if is_one_rep min_R then
+ let
+ val rs1 = unpack_products r1
+ val rs2 = unpack_products r2
+ in
+ if length rs1 = length rs2
+ andalso map Kodkod.arity_of_rel_expr rs1
+ = map Kodkod.arity_of_rel_expr rs2 then
+ fold1 kk_and (map2 kk_subset rs1 rs2)
+ else
+ kk_subset r1 r2
+ end
+ else
+ kk_rel_eq r1 r2
+ end)
+ | Op2 (Apply, T, _, u1, u2) =>
+ (case (polar, rep_of u1) of
+ (Neg, Func (R, Formula Neut)) => kk_subset (to_opt R u2) (to_r u1)
+ | _ =>
+ to_f_with_polarity polar
+ (Op2 (Apply, T, Opt (Atom (2, offset_of_type ofs T)), u1, u2)))
+ | Op3 (Let, _, _, u1, u2, u3) =>
+ kk_formula_let [to_expr_assign u1 u2] (to_f u3)
+ | Op3 (If, _, _, u1, u2, u3) =>
+ kk_formula_if (to_f u1) (to_f u2) (to_f u3)
+ | FormulaReg (j, _, _) => Kodkod.FormulaReg j
+ | _ => raise NUT ("NitpickKodkod.to_f", [u]))
+ | Atom (2, j0) => formula_from_atom j0 (to_r u)
+ | _ => raise NUT ("NitpickKodkod.to_f", [u])
+ (* polarity -> nut -> Kodkod.formula *)
+ and to_f_with_polarity polar u =
+ case rep_of u of
+ Formula _ => to_f u
+ | Atom (2, j0) => formula_from_atom j0 (to_r u)
+ | Opt (Atom (2, j0)) => formula_from_opt_atom polar j0 (to_r u)
+ | _ => raise NUT ("NitpickKodkod.to_f_with_polarity", [u])
+ (* nut -> Kodkod.rel_expr *)
+ and to_r u =
+ case u of
+ Cst (False, _, Atom _) => false_atom
+ | Cst (True, _, Atom _) => true_atom
+ | Cst (Iden, T, Func (Struct [R1, R2], Formula Neut)) =>
+ if R1 = R2 andalso arity_of_rep R1 = 1 then
+ kk_intersect Kodkod.Iden (kk_product (full_rel_for_rep R1)
+ Kodkod.Univ)
+ else
+ let
+ val schema1 = atom_schema_of_rep R1
+ val schema2 = atom_schema_of_rep R2
+ val arity1 = length schema1
+ val arity2 = length schema2
+ val r1 = fold1 kk_product (unary_var_seq 0 arity1)
+ val r2 = fold1 kk_product (unary_var_seq arity1 arity2)
+ val min_R = min_rep R1 R2
+ in
+ kk_comprehension
+ (decls_for_atom_schema 0 (schema1 @ schema2))
+ (kk_rel_eq (rel_expr_from_rel_expr kk min_R R1 r1)
+ (rel_expr_from_rel_expr kk min_R R2 r2))
+ end
+ | Cst (Iden, T, Func (Atom (1, j0), Formula Neut)) => Kodkod.Atom j0
+ | Cst (Iden, T as Type ("fun", [T1, _]), R as Func (R1, _)) =>
+ to_rep R (Cst (Iden, T, Func (one_rep ofs T1 R1, Formula Neut)))
+ | Cst (Num j, @{typ int}, R) =>
+ (case atom_for_int (card_of_rep R, offset_of_type ofs int_T) j of
+ ~1 => if is_opt_rep R then Kodkod.None
+ else raise NUT ("NitpickKodkod.to_r (Num)", [u])
+ | j' => Kodkod.Atom j')
+ | Cst (Num j, T, R) =>
+ if j < card_of_rep R then Kodkod.Atom (j + offset_of_type ofs T)
+ else if is_opt_rep R then Kodkod.None
+ else raise NUT ("NitpickKodkod.to_r", [u])
+ | Cst (Unknown, _, R) => empty_rel_for_rep R
+ | Cst (Unrep, _, R) => empty_rel_for_rep R
+ | Cst (Suc, T, Func (Atom x, _)) =>
+ if domain_type T <> nat_T then suc_rel
+ else kk_intersect suc_rel (kk_product Kodkod.Univ (Kodkod.AtomSeq x))
+ | Cst (Add, Type ("fun", [@{typ nat}, _]), _) => nat_add_rel
+ | Cst (Add, Type ("fun", [@{typ int}, _]), _) => int_add_rel
+ | Cst (Subtract, Type ("fun", [@{typ nat}, _]), _) => nat_subtract_rel
+ | Cst (Subtract, Type ("fun", [@{typ int}, _]), _) => int_subtract_rel
+ | Cst (Multiply, Type ("fun", [@{typ nat}, _]), _) => nat_multiply_rel
+ | Cst (Multiply, Type ("fun", [@{typ int}, _]), _) => int_multiply_rel
+ | Cst (Divide, Type ("fun", [@{typ nat}, _]), _) => nat_divide_rel
+ | Cst (Divide, Type ("fun", [@{typ int}, _]), _) => int_divide_rel
+ | Cst (Modulo, Type ("fun", [@{typ nat}, _]), _) => nat_modulo_rel
+ | Cst (Modulo, Type ("fun", [@{typ int}, _]), _) => int_modulo_rel
+ | Cst (Gcd, _, _) => gcd_rel
+ | Cst (Lcm, _, _) => lcm_rel
+ | Cst (Fracs, _, Func (Atom (1, _), _)) => Kodkod.None
+ | Cst (Fracs, _, Func (Struct _, _)) =>
+ kk_project_seq norm_frac_rel 2 2
+ | Cst (NormFrac, _, _) => norm_frac_rel
+ | Cst (NatToInt, _, Func (Atom _, Atom _)) => Kodkod.Iden
+ | Cst (NatToInt, _,
+ Func (Atom (nat_k, nat_j0), Opt (Atom (int_k, int_j0)))) =>
+ if nat_j0 = int_j0 then
+ kk_intersect Kodkod.Iden
+ (kk_product (Kodkod.AtomSeq (max_int_for_card int_k + 1, nat_j0))
+ Kodkod.Univ)
+ else
+ raise BAD ("NitpickKodkod.to_r (NatToInt)", "\"nat_j0 <> int_j0\"")
+ | Cst (IntToNat, _, Func (Atom (int_k, int_j0), nat_R)) =>
+ let
+ val abs_card = max_int_for_card int_k + 1
+ val (nat_k, nat_j0) = the_single (atom_schema_of_rep nat_R)
+ val overlap = Int.min (nat_k, abs_card)
+ in
+ if nat_j0 = int_j0 then
+ kk_union (kk_product (Kodkod.AtomSeq (int_k - abs_card,
+ int_j0 + abs_card))
+ (Kodkod.Atom nat_j0))
+ (kk_intersect Kodkod.Iden
+ (kk_product (Kodkod.AtomSeq (overlap, int_j0))
+ Kodkod.Univ))
+ else
+ raise BAD ("NitpickKodkod.to_r (IntToNat)", "\"nat_j0 <> int_j0\"")
+ end
+ | Op1 (Not, _, R, u1) => kk_not3 (to_rep R u1)
+ | Op1 (Finite, _, Opt (Atom _), _) => Kodkod.None
+ | Op1 (Converse, T, R, u1) =>
+ let
+ val (b_T, a_T) = HOLogic.dest_prodT (domain_type T)
+ val (b_R, a_R) =
+ case R of
+ Func (Struct [R1, R2], _) => (R1, R2)
+ | Func (R1, _) =>
+ if card_of_rep R1 <> 1 then
+ raise REP ("NitpickKodkod.to_r (Converse)", [R])
+ else
+ pairself (Atom o pair 1 o offset_of_type ofs) (b_T, a_T)
+ | _ => raise REP ("NitpickKodkod.to_r (Converse)", [R])
+ val body_R = body_rep R
+ val a_arity = arity_of_rep a_R
+ val b_arity = arity_of_rep b_R
+ val ab_arity = a_arity + b_arity
+ val body_arity = arity_of_rep body_R
+ in
+ kk_project (to_rep (Func (Struct [a_R, b_R], body_R)) u1)
+ (map Kodkod.Num (index_seq a_arity b_arity @
+ index_seq 0 a_arity @
+ index_seq ab_arity body_arity))
+ |> rel_expr_from_rel_expr kk R (Func (Struct [b_R, a_R], body_R))
+ end
+ | Op1 (Closure, _, R, u1) =>
+ if is_opt_rep R then
+ let
+ val T1 = type_of u1
+ val R' = rep_to_binary_rel_rep ofs T1 (unopt_rep (rep_of u1))
+ val R'' = opt_rep ofs T1 R'
+ in
+ single_rel_let kk
+ (fn r =>
+ let
+ val true_r = kk_closure (kk_join r true_atom)
+ val full_r = full_rel_for_rep R'
+ val false_r = kk_difference full_r
+ (kk_closure (kk_difference full_r
+ (kk_join r false_atom)))
+ in
+ rel_expr_from_rel_expr kk R R''
+ (kk_union (kk_product true_r true_atom)
+ (kk_product false_r false_atom))
+ end) (to_rep R'' u1)
+ end
+ else
+ let val R' = rep_to_binary_rel_rep ofs (type_of u1) (rep_of u1) in
+ rel_expr_from_rel_expr kk R R' (kk_closure (to_rep R' u1))
+ end
+ | Op1 (SingletonSet, _, Func (R1, Opt _), Cst (Unrep, _, _)) =>
+ (if R1 = Unit then I else kk_product (full_rel_for_rep R1)) false_atom
+ | Op1 (SingletonSet, _, R, u1) =>
+ (case R of
+ Func (R1, Formula Neut) => to_rep R1 u1
+ | Func (Unit, Opt R) => to_guard [u1] R true_atom
+ | Func (R1, R2 as Opt _) =>
+ single_rel_let kk
+ (fn r => kk_rel_if (kk_no r) (empty_rel_for_rep R)
+ (rel_expr_to_func kk R1 bool_atom_R
+ (Func (R1, Formula Neut)) r))
+ (to_opt R1 u1)
+ | _ => raise NUT ("NitpickKodkod.to_r (SingletonSet)", [u]))
+ | Op1 (Tha, T, R, u1) =>
+ if is_opt_rep R then
+ kk_join (to_rep (Func (unopt_rep R, Opt bool_atom_R)) u1) true_atom
+ else
+ to_rep (Func (R, Formula Neut)) u1
+ | Op1 (First, T, R, u1) => to_nth_pair_sel 0 T R u1
+ | Op1 (Second, T, R, u1) => to_nth_pair_sel 1 T R u1
+ | Op1 (Cast, _, R, u1) =>
+ ((case rep_of u1 of
+ Formula _ =>
+ (case unopt_rep R of
+ Atom (2, j0) => atom_from_formula kk j0 (to_f u1)
+ | _ => raise SAME ())
+ | _ => raise SAME ())
+ handle SAME () => rel_expr_from_rel_expr kk R (rep_of u1) (to_r u1))
+ | Op2 (All, T, R as Opt _, u1, u2) =>
+ to_r (Op1 (Not, T, R,
+ Op2 (Exist, T, R, u1, Op1 (Not, T, rep_of u2, u2))))
+ | Op2 (Exist, T, Opt _, u1, u2) =>
+ let val rs1 = untuple to_decl u1 in
+ if not (is_opt_rep (rep_of u2)) then
+ kk_rel_if (kk_exist rs1 (to_f u2)) true_atom Kodkod.None
+ else
+ let val r2 = to_r u2 in
+ kk_union (kk_rel_if (kk_exist rs1 (kk_rel_eq r2 true_atom))
+ true_atom Kodkod.None)
+ (kk_rel_if (kk_all rs1 (kk_rel_eq r2 false_atom))
+ false_atom Kodkod.None)
+ end
+ end
+ | Op2 (Or, _, _, u1, u2) =>
+ if is_opt_rep (rep_of u1) then kk_rel_if (to_f u2) true_atom (to_r u1)
+ else kk_rel_if (to_f u1) true_atom (to_r u2)
+ | Op2 (And, _, _, u1, u2) =>
+ if is_opt_rep (rep_of u1) then kk_rel_if (to_f u2) (to_r u1) false_atom
+ else kk_rel_if (to_f u1) (to_r u2) false_atom
+ | Op2 (Less, _, _, u1, u2) =>
+ if type_of u1 = nat_T then
+ if is_Cst Unrep u1 then to_compare_with_unrep u2 false_atom
+ else if is_Cst Unrep u2 then to_compare_with_unrep u1 true_atom
+ else kk_nat_less (to_integer u1) (to_integer u2)
+ else
+ kk_int_less (to_integer u1) (to_integer u2)
+ | Op2 (The, T, R, u1, u2) =>
+ if is_opt_rep R then
+ let val r1 = to_opt (Func (unopt_rep R, bool_atom_R)) u1 in
+ kk_rel_if (kk_one (kk_join r1 true_atom)) (kk_join r1 true_atom)
+ (kk_rel_if (kk_or (kk_some (kk_join r1 true_atom))
+ (kk_subset (full_rel_for_rep R)
+ (kk_join r1 false_atom)))
+ (to_rep R u2) Kodkod.None)
+ end
+ else
+ let val r1 = to_rep (Func (R, Formula Neut)) u1 in
+ kk_rel_if (kk_one r1) r1 (to_rep R u2)
+ end
+ | Op2 (Eps, T, R, u1, u2) =>
+ if is_opt_rep (rep_of u1) then
+ let
+ val r1 = to_rep (Func (unopt_rep R, Opt bool_atom_R)) u1
+ val r2 = to_rep R u2
+ in
+ kk_union (kk_rel_if (kk_one (kk_join r1 true_atom))
+ (kk_join r1 true_atom) Kodkod.None)
+ (kk_rel_if (kk_or (kk_subset r2 (kk_join r1 true_atom))
+ (kk_subset (full_rel_for_rep R)
+ (kk_join r1 false_atom)))
+ r2 Kodkod.None)
+ end
+ else
+ let
+ val r1 = to_rep (Func (unopt_rep R, Formula Neut)) u1
+ val r2 = to_rep R u2
+ in
+ kk_union (kk_rel_if (kk_one r1) r1 Kodkod.None)
+ (kk_rel_if (kk_or (kk_no r1) (kk_subset r2 r1))
+ r2 Kodkod.None)
+ end
+ | Op2 (Triad, T, Opt (Atom (2, j0)), u1, u2) =>
+ let
+ val f1 = to_f u1
+ val f2 = to_f u2
+ in
+ if f1 = f2 then
+ atom_from_formula kk j0 f1
+ else
+ kk_union (kk_rel_if f1 true_atom Kodkod.None)
+ (kk_rel_if f2 Kodkod.None false_atom)
+ end
+ | Op2 (Union, _, R, u1, u2) =>
+ to_set_op kk_or kk_or3 kk_union kk_union kk_intersect false R u1 u2
+ | Op2 (SetDifference, _, R, u1, u2) =>
+ to_set_op kk_notimplies kk_notimplies3 kk_difference kk_intersect
+ kk_union true R u1 u2
+ | Op2 (Intersect, _, R, u1, u2) =>
+ to_set_op kk_and kk_and3 kk_intersect kk_intersect kk_union false R
+ u1 u2
+ | Op2 (Composition, _, R, u1, u2) =>
+ let
+ val (a_T, b_T) = HOLogic.dest_prodT (domain_type (type_of u2))
+ val (_, c_T) = HOLogic.dest_prodT (domain_type (type_of u1))
+ val ab_k = card_of_domain_from_rep 2 (rep_of u2)
+ val bc_k = card_of_domain_from_rep 2 (rep_of u1)
+ val ac_k = card_of_domain_from_rep 2 R
+ val a_k = exact_root 2 (ac_k * ab_k div bc_k)
+ val b_k = exact_root 2 (ab_k * bc_k div ac_k)
+ val c_k = exact_root 2 (bc_k * ac_k div ab_k)
+ val a_R = Atom (a_k, offset_of_type ofs a_T)
+ val b_R = Atom (b_k, offset_of_type ofs b_T)
+ val c_R = Atom (c_k, offset_of_type ofs c_T)
+ val body_R = body_rep R
+ in
+ (case body_R of
+ Formula Neut =>
+ kk_join (to_rep (Func (Struct [a_R, b_R], Formula Neut)) u2)
+ (to_rep (Func (Struct [b_R, c_R], Formula Neut)) u1)
+ | Opt (Atom (2, _)) =>
+ let
+ (* Kodkod.rel_expr -> rep -> rep -> nut -> Kodkod.rel_expr *)
+ fun do_nut r R1 R2 u =
+ kk_join (to_rep (Func (Struct [R1, R2], body_R)) u) r
+ (* Kodkod.rel_expr -> Kodkod.rel_expr *)
+ fun do_term r =
+ kk_product (kk_join (do_nut r a_R b_R u2)
+ (do_nut r b_R c_R u1)) r
+ in kk_union (do_term true_atom) (do_term false_atom) end
+ | _ => raise NUT ("NitpickKodkod.to_r (Composition)", [u]))
+ |> rel_expr_from_rel_expr kk R (Func (Struct [a_R, c_R], body_R))
+ end
+ | Op2 (Product, T, R, u1, u2) =>
+ let
+ val (a_T, b_T) = HOLogic.dest_prodT (domain_type T)
+ val a_k = card_of_domain_from_rep 2 (rep_of u1)
+ val b_k = card_of_domain_from_rep 2 (rep_of u2)
+ val a_R = Atom (a_k, offset_of_type ofs a_T)
+ val b_R = Atom (b_k, offset_of_type ofs b_T)
+ val body_R = body_rep R
+ in
+ (case body_R of
+ Formula Neut =>
+ kk_product (to_rep (Func (a_R, Formula Neut)) u1)
+ (to_rep (Func (b_R, Formula Neut)) u2)
+ | Opt (Atom (2, _)) =>
+ let
+ (* Kodkod.rel_expr -> rep -> nut -> Kodkod.rel_expr *)
+ fun do_nut r R u = kk_join (to_rep (Func (R, body_R)) u) r
+ (* Kodkod.rel_expr -> Kodkod.rel_expr *)
+ fun do_term r =
+ kk_product (kk_product (do_nut r a_R u1) (do_nut r b_R u2)) r
+ in kk_union (do_term true_atom) (do_term false_atom) end
+ | _ => raise NUT ("NitpickKodkod.to_r (Product)", [u]))
+ |> rel_expr_from_rel_expr kk R (Func (Struct [a_R, b_R], body_R))
+ end
+ | Op2 (Image, T, R, u1, u2) =>
+ (case (rep_of u1, rep_of u2) of
+ (Func (R11, R12), Func (R21, Formula Neut)) =>
+ if R21 = R11 andalso is_lone_rep R12 then
+ let
+ (* Kodkod.rel_expr -> Kodkod.rel_expr *)
+ fun big_join r = kk_n_fold_join kk false R21 R12 r (to_r u1)
+ val core_r = big_join (to_r u2)
+ val core_R = Func (R12, Formula Neut)
+ in
+ if is_opt_rep R12 then
+ let
+ val schema = atom_schema_of_rep R21
+ val decls = decls_for_atom_schema ~1 schema
+ val vars = unary_var_seq ~1 (length decls)
+ val f = kk_some (big_join (fold1 kk_product vars))
+ in
+ kk_rel_if (kk_all decls f)
+ (rel_expr_from_rel_expr kk R core_R core_r)
+ (rel_expr_from_rel_expr kk R (opt_rep ofs T core_R)
+ (kk_product core_r true_atom))
+ end
+ else
+ rel_expr_from_rel_expr kk R core_R core_r
+ end
+ else
+ raise NUT ("NitpickKodkod.to_r (Image)", [u1, u2])
+ | _ => raise NUT ("NitpickKodkod.to_r (Image)", [u1, u2]))
+ | Op2 (Apply, @{typ nat}, _,
+ Op2 (Apply, _, _, Cst (Subtract, _, _), u1), u2) =>
+ if is_Cst Unrep u2 andalso not (is_opt_rep (rep_of u1)) then
+ Kodkod.Atom (offset_of_type ofs nat_T)
+ else
+ fold kk_join [to_integer u1, to_integer u2] nat_subtract_rel
+ | Op2 (Apply, _, R, u1, u2) =>
+ if is_Cst Unrep u2 andalso is_set_type (type_of u1)
+ andalso not (is_opt_rep (rep_of u1)) then
+ false_atom
+ else
+ to_apply R u1 u2
+ | Op2 (Lambda, T, R as Opt (Atom (1, j0)), u1, u2) =>
+ to_guard [u1, u2] R (Kodkod.Atom j0)
+ | Op2 (Lambda, T, Func (_, Formula Neut), u1, u2) =>
+ kk_comprehension (untuple to_decl u1) (to_f u2)
+ | Op2 (Lambda, T, Func (_, R2), u1, u2) =>
+ let
+ val dom_decls = untuple to_decl u1
+ val ran_schema = atom_schema_of_rep R2
+ val ran_decls = decls_for_atom_schema ~1 ran_schema
+ val ran_vars = unary_var_seq ~1 (length ran_decls)
+ in
+ kk_comprehension (dom_decls @ ran_decls)
+ (kk_subset (fold1 kk_product ran_vars)
+ (to_rep R2 u2))
+ end
+ | Op3 (Let, _, R, u1, u2, u3) =>
+ kk_rel_let [to_expr_assign u1 u2] (to_rep R u3)
+ | Op3 (If, _, R, u1, u2, u3) =>
+ if is_opt_rep (rep_of u1) then
+ triple_rel_let kk
+ (fn r1 => fn r2 => fn r3 =>
+ let val empty_r = empty_rel_for_rep R in
+ fold1 kk_union
+ [kk_rel_if (kk_rel_eq r1 true_atom) r2 empty_r,
+ kk_rel_if (kk_rel_eq r1 false_atom) r3 empty_r,
+ kk_rel_if (kk_rel_eq r2 r3)
+ (if inline_rel_expr r2 then r2 else r3) empty_r]
+ end)
+ (to_r u1) (to_rep R u2) (to_rep R u3)
+ else
+ kk_rel_if (to_f u1) (to_rep R u2) (to_rep R u3)
+ | Tuple (_, R, us) =>
+ (case unopt_rep R of
+ Struct Rs => to_product Rs us
+ | Vect (k, R) => to_product (replicate k R) us
+ | Atom (1, j0) =>
+ (case filter (not_equal Unit o rep_of) us of
+ [] => Kodkod.Atom j0
+ | us' =>
+ kk_rel_if (kk_some (fold1 kk_product (map to_r us')))
+ (Kodkod.Atom j0) Kodkod.None)
+ | _ => raise NUT ("NitpickKodkod.to_r (Tuple)", [u]))
+ | Construct ([u'], _, _, []) => to_r u'
+ | Construct (_ :: sel_us, T, R, arg_us) =>
+ let
+ val set_rs =
+ map2 (fn sel_u => fn arg_u =>
+ let
+ val (R1, R2) = dest_Func (rep_of sel_u)
+ val sel_r = to_r sel_u
+ val arg_r = to_opt R2 arg_u
+ in
+ if is_one_rep R2 then
+ kk_n_fold_join kk true R2 R1 arg_r
+ (kk_project sel_r (flip_nums (arity_of_rep R2)))
+ else
+ kk_comprehension
+ (decls_for_atom_schema ~1 (atom_schema_of_rep R1))
+ (kk_rel_eq (kk_join (Kodkod.Var (1, ~1)) sel_r)
+ arg_r)
+ end) sel_us arg_us
+ in fold1 kk_intersect set_rs end
+ | BoundRel (x, _, _, _) => Kodkod.Var x
+ | FreeRel (x, _, _, _) => Kodkod.Rel x
+ | RelReg (j, _, R) => Kodkod.RelReg (arity_of_rep R, j)
+ | u => raise NUT ("NitpickKodkod.to_r", [u])
+ (* nut -> Kodkod.decl *)
+ and to_decl (BoundRel (x, _, R, _)) =
+ Kodkod.DeclOne (x, Kodkod.AtomSeq (the_single (atom_schema_of_rep R)))
+ | to_decl u = raise NUT ("NitpickKodkod.to_decl", [u])
+ (* nut -> Kodkod.expr_assign *)
+ and to_expr_assign (FormulaReg (j, _, R)) u =
+ Kodkod.AssignFormulaReg (j, to_f u)
+ | to_expr_assign (RelReg (j, _, R)) u =
+ Kodkod.AssignRelReg ((arity_of_rep R, j), to_r u)
+ | to_expr_assign u1 _ = raise NUT ("NitpickKodkod.to_expr_assign", [u1])
+ (* int * int -> nut -> Kodkod.rel_expr *)
+ and to_atom (x as (k, j0)) u =
+ case rep_of u of
+ Formula _ => atom_from_formula kk j0 (to_f u)
+ | Unit => if k = 1 then Kodkod.Atom j0
+ else raise NUT ("NitpickKodkod.to_atom", [u])
+ | R => atom_from_rel_expr kk x R (to_r u)
+ (* rep list -> nut -> Kodkod.rel_expr *)
+ and to_struct Rs u =
+ case rep_of u of
+ Unit => full_rel_for_rep (Struct Rs)
+ | R' => struct_from_rel_expr kk Rs R' (to_r u)
+ (* int -> rep -> nut -> Kodkod.rel_expr *)
+ and to_vect k R u =
+ case rep_of u of
+ Unit => full_rel_for_rep (Vect (k, R))
+ | R' => vect_from_rel_expr kk k R R' (to_r u)
+ (* rep -> rep -> nut -> Kodkod.rel_expr *)
+ and to_func R1 R2 u =
+ case rep_of u of
+ Unit => full_rel_for_rep (Func (R1, R2))
+ | R' => rel_expr_to_func kk R1 R2 R' (to_r u)
+ (* rep -> nut -> Kodkod.rel_expr *)
+ and to_opt R u =
+ let val old_R = rep_of u in
+ if is_opt_rep old_R then
+ rel_expr_from_rel_expr kk (Opt R) old_R (to_r u)
+ else
+ to_rep R u
+ end
+ (* rep -> nut -> Kodkod.rel_expr *)
+ and to_rep (Atom x) u = to_atom x u
+ | to_rep (Struct Rs) u = to_struct Rs u
+ | to_rep (Vect (k, R)) u = to_vect k R u
+ | to_rep (Func (R1, R2)) u = to_func R1 R2 u
+ | to_rep (Opt R) u = to_opt R u
+ | to_rep R _ = raise REP ("NitpickKodkod.to_rep", [R])
+ (* nut -> Kodkod.rel_expr *)
+ and to_integer u = to_opt (one_rep ofs (type_of u) (rep_of u)) u
+ (* nut list -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+ and to_guard guard_us R r =
+ let
+ val unpacked_rs = unpack_joins r
+ val plain_guard_rs =
+ map to_r (filter (is_Opt o rep_of) guard_us)
+ |> filter_out (member (op =) unpacked_rs)
+ val func_guard_us =
+ filter ((is_Func andf is_opt_rep) o rep_of) guard_us
+ val func_guard_rs = map to_r func_guard_us
+ val guard_fs =
+ map kk_no plain_guard_rs @
+ map2 (kk_not oo kk_n_ary_function kk)
+ (map (unopt_rep o rep_of) func_guard_us) func_guard_rs
+ in
+ if null guard_fs then
+ r
+ else
+ kk_rel_if (fold1 kk_or guard_fs) (empty_rel_for_rep R) r
+ end
+ (* rep -> rep -> Kodkod.rel_expr -> int -> Kodkod.rel_expr *)
+ and to_project new_R old_R r j0 =
+ rel_expr_from_rel_expr kk new_R old_R
+ (kk_project_seq r j0 (arity_of_rep old_R))
+ (* rep list -> nut list -> Kodkod.rel_expr *)
+ and to_product Rs us =
+ case map (uncurry to_opt) (filter (not_equal Unit o fst) (Rs ~~ us)) of
+ [] => raise REP ("NitpickKodkod.to_product", Rs)
+ | rs => fold1 kk_product rs
+ (* int -> typ -> rep -> nut -> Kodkod.rel_expr *)
+ and to_nth_pair_sel n res_T res_R u =
+ case u of
+ Tuple (_, _, us) => to_rep res_R (nth us n)
+ | _ => let
+ val R = rep_of u
+ val (a_T, b_T) = HOLogic.dest_prodT (type_of u)
+ val Rs =
+ case unopt_rep R of
+ Struct (Rs as [_, _]) => Rs
+ | _ =>
+ let
+ val res_card = card_of_rep res_R
+ val other_card = card_of_rep R div res_card
+ val (a_card, b_card) = (res_card, other_card)
+ |> n = 1 ? swap
+ in
+ [Atom (a_card, offset_of_type ofs a_T),
+ Atom (b_card, offset_of_type ofs b_T)]
+ end
+ val nth_R = nth Rs n
+ val j0 = if n = 0 then 0 else arity_of_rep (hd Rs)
+ in
+ case arity_of_rep nth_R of
+ 0 => to_guard [u] res_R
+ (to_rep res_R (Cst (Unity, res_T, Unit)))
+ | arity => to_project res_R nth_R (to_rep (Opt (Struct Rs)) u) j0
+ end
+ (* (Kodkod.formula -> Kodkod.formula -> Kodkod.formula)
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.formula) -> nut -> nut
+ -> Kodkod.formula *)
+ and to_set_bool_op connective set_oper u1 u2 =
+ let
+ val min_R = min_rep (rep_of u1) (rep_of u2)
+ val r1 = to_rep min_R u1
+ val r2 = to_rep min_R u2
+ in
+ case min_R of
+ Vect (k, Atom _) => kk_vect_set_bool_op connective k r1 r2
+ | Func (R1, Formula Neut) => set_oper r1 r2
+ | Func (Unit, Atom (2, j0)) =>
+ connective (formula_from_atom j0 r1) (formula_from_atom j0 r2)
+ | Func (R1, Atom _) => set_oper (kk_join r1 true_atom)
+ (kk_join r2 true_atom)
+ | _ => raise REP ("NitpickKodkod.to_set_bool_op", [min_R])
+ end
+ (* (Kodkod.formula -> Kodkod.formula -> Kodkod.formula)
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr)
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.formula)
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.formula)
+ -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.formula) -> bool -> rep
+ -> nut -> nut -> Kodkod.rel_expr *)
+ and to_set_op connective connective3 set_oper true_set_oper false_set_oper
+ neg_second R u1 u2 =
+ let
+ val min_R = min_rep (rep_of u1) (rep_of u2)
+ val r1 = to_rep min_R u1
+ val r2 = to_rep min_R u2
+ val unopt_R = unopt_rep R
+ in
+ rel_expr_from_rel_expr kk unopt_R (unopt_rep min_R)
+ (case min_R of
+ Opt (Vect (k, Atom _)) => kk_vect_set_op connective k r1 r2
+ | Vect (k, Atom _) => kk_vect_set_op connective k r1 r2
+ | Func (_, Formula Neut) => set_oper r1 r2
+ | Func (Unit, _) => connective3 r1 r2
+ | Func (R1, _) =>
+ double_rel_let kk
+ (fn r1 => fn r2 =>
+ kk_union
+ (kk_product
+ (true_set_oper (kk_join r1 true_atom)
+ (kk_join r2 (atom_for_bool bool_j0
+ (not neg_second))))
+ true_atom)
+ (kk_product
+ (false_set_oper (kk_join r1 false_atom)
+ (kk_join r2 (atom_for_bool bool_j0
+ neg_second)))
+ false_atom))
+ r1 r2
+ | _ => raise REP ("NitpickKodkod.to_set_op", [min_R]))
+ end
+ (* rep -> rep -> Kodkod.rel_expr -> nut -> Kodkod.rel_expr *)
+ and to_apply res_R func_u arg_u =
+ case unopt_rep (rep_of func_u) of
+ Unit =>
+ let val j0 = offset_of_type ofs (type_of func_u) in
+ to_guard [arg_u] res_R
+ (rel_expr_from_rel_expr kk res_R (Atom (1, j0))
+ (Kodkod.Atom j0))
+ end
+ | Atom (1, j0) =>
+ to_guard [arg_u] res_R
+ (rel_expr_from_rel_expr kk res_R (Atom (1, j0)) (to_r func_u))
+ | Atom (k, j0) =>
+ let
+ val dom_card = card_of_rep (rep_of arg_u)
+ val ran_R = Atom (exact_root dom_card k,
+ offset_of_type ofs (range_type (type_of func_u)))
+ in
+ to_apply_vect dom_card ran_R res_R (to_vect dom_card ran_R func_u)
+ arg_u
+ end
+ | Vect (1, R') =>
+ to_guard [arg_u] res_R
+ (rel_expr_from_rel_expr kk res_R R' (to_r func_u))
+ | Vect (k, R') => to_apply_vect k R' res_R (to_r func_u) arg_u
+ | Func (R, Formula Neut) =>
+ to_guard [arg_u] res_R (rel_expr_from_formula kk res_R
+ (kk_subset (to_opt R arg_u) (to_r func_u)))
+ | Func (Unit, R2) =>
+ to_guard [arg_u] res_R
+ (rel_expr_from_rel_expr kk res_R R2 (to_r func_u))
+ | Func (R1, R2) =>
+ rel_expr_from_rel_expr kk res_R R2
+ (kk_n_fold_join kk true R1 R2 (to_opt R1 arg_u) (to_r func_u))
+ |> body_rep R2 = Formula Neut ? to_guard [arg_u] res_R
+ | _ => raise NUT ("NitpickKodkod.to_apply", [func_u])
+ (* int -> rep -> rep -> Kodkod.rel_expr -> nut *)
+ and to_apply_vect k R' res_R func_r arg_u =
+ let
+ val arg_R = one_rep ofs (type_of arg_u) (unopt_rep (rep_of arg_u))
+ val vect_r = vect_from_rel_expr kk k res_R (Vect (k, R')) func_r
+ val vect_rs = unpack_vect_in_chunks kk (arity_of_rep res_R) k vect_r
+ in
+ kk_case_switch kk arg_R res_R (to_opt arg_R arg_u)
+ (all_singletons_for_rep arg_R) vect_rs
+ end
+ (* bool -> nut -> Kodkod.formula *)
+ and to_could_be_unrep neg u =
+ if neg andalso is_opt_rep (rep_of u) then kk_no (to_r u)
+ else Kodkod.False
+ (* nut -> Kodkod.rel_expr -> Kodkod.rel_expr *)
+ and to_compare_with_unrep u r =
+ if is_opt_rep (rep_of u) then kk_rel_if (kk_some (to_r u)) r Kodkod.None
+ else r
+ in to_f_with_polarity Pos u end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_model.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,703 @@
+(* Title: HOL/Nitpick/Tools/nitpick_model.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Model reconstruction for Nitpick.
+*)
+
+signature NITPICK_MODEL =
+sig
+ type scope = NitpickScope.scope
+ type rep = NitpickRep.rep
+ type nut = NitpickNut.nut
+
+ type params = {
+ show_skolems: bool,
+ show_datatypes: bool,
+ show_consts: bool}
+
+ structure NameTable : TABLE
+
+ val tuple_list_for_name :
+ nut NameTable.table -> Kodkod.raw_bound list -> nut -> int list list
+ val reconstruct_hol_model :
+ params -> scope -> (term option * int list) list -> styp list -> nut list
+ -> nut list -> nut list -> nut NameTable.table -> Kodkod.raw_bound list
+ -> Pretty.T * bool
+ val prove_hol_model :
+ scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
+ -> Kodkod.raw_bound list -> term -> bool option
+end;
+
+structure NitpickModel : NITPICK_MODEL =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickScope
+open NitpickPeephole
+open NitpickRep
+open NitpickNut
+
+type params = {
+ show_skolems: bool,
+ show_datatypes: bool,
+ show_consts: bool}
+
+val unknown = "?"
+val unrep = "\<dots>"
+val maybe_mixfix = "_\<^sup>?"
+val base_mixfix = "_\<^bsub>base\<^esub>"
+val step_mixfix = "_\<^bsub>step\<^esub>"
+val abs_mixfix = "\<guillemotleft>_\<guillemotright>"
+val non_opt_name = nitpick_prefix ^ "non_opt"
+
+(* string -> typ -> int -> string *)
+fun atom_name prefix (T as Type (s, _)) j =
+ prefix ^ substring (short_name s, 0, 1) ^ nat_subscript (j + 1)
+ | atom_name prefix (T as TFree (s, _)) j =
+ prefix ^ perhaps (try (unprefix "'")) s ^ nat_subscript (j + 1)
+ | atom_name _ T _ = raise TYPE ("NitpickModel.atom_name", [T], [])
+(* bool -> typ -> int -> term *)
+fun atom for_auto T j =
+ if for_auto then
+ Free (atom_name (hd (space_explode "." nitpick_prefix)) T j, T)
+ else
+ Const (atom_name "" T j, T)
+
+(* nut NameTable.table -> Kodkod.raw_bound list -> nut -> int list list *)
+fun tuple_list_for_name rel_table bounds name =
+ the (AList.lookup (op =) bounds (the_rel rel_table name)) handle NUT _ => [[]]
+
+(* term -> term *)
+fun unbox_term (Const (@{const_name FunBox}, _) $ t1) = unbox_term t1
+ | unbox_term (Const (@{const_name PairBox},
+ Type ("fun", [T1, Type ("fun", [T2, T3])])) $ t1 $ t2) =
+ let val Ts = map unbox_type [T1, T2] in
+ Const (@{const_name Pair}, Ts ---> Type ("*", Ts))
+ $ unbox_term t1 $ unbox_term t2
+ end
+ | unbox_term (Const (s, T)) = Const (s, unbox_type T)
+ | unbox_term (t1 $ t2) = unbox_term t1 $ unbox_term t2
+ | unbox_term (Free (s, T)) = Free (s, unbox_type T)
+ | unbox_term (Var (x, T)) = Var (x, unbox_type T)
+ | unbox_term (Bound j) = Bound j
+ | unbox_term (Abs (s, T, t')) = Abs (s, unbox_type T, unbox_term t')
+
+(* typ -> typ -> (typ * typ) * (typ * typ) *)
+fun factor_out_types (T1 as Type ("*", [T11, T12]))
+ (T2 as Type ("*", [T21, T22])) =
+ let val (n1, n2) = pairself num_factors_in_type (T11, T21) in
+ if n1 = n2 then
+ let
+ val ((T11', opt_T12'), (T21', opt_T22')) = factor_out_types T12 T22
+ in
+ ((Type ("*", [T11, T11']), opt_T12'),
+ (Type ("*", [T21, T21']), opt_T22'))
+ end
+ else if n1 < n2 then
+ case factor_out_types T1 T21 of
+ (p1, (T21', NONE)) => (p1, (T21', SOME T22))
+ | (p1, (T21', SOME T22')) =>
+ (p1, (T21', SOME (Type ("*", [T22', T22]))))
+ else
+ swap (factor_out_types T2 T1)
+ end
+ | factor_out_types (Type ("*", [T11, T12])) T2 = ((T11, SOME T12), (T2, NONE))
+ | factor_out_types T1 (Type ("*", [T21, T22])) = ((T1, NONE), (T21, SOME T22))
+ | factor_out_types T1 T2 = ((T1, NONE), (T2, NONE))
+
+(* bool -> typ -> typ -> (term * term) list -> term *)
+fun make_plain_fun maybe_opt T1 T2 =
+ let
+ (* typ -> typ -> (term * term) list -> term *)
+ fun aux T1 T2 [] =
+ Const (if maybe_opt orelse T2 <> bool_T then @{const_name undefined}
+ else non_opt_name, T1 --> T2)
+ | aux T1 T2 ((t1, t2) :: ps) =
+ Const (@{const_name fun_upd}, [T1 --> T2, T1, T2] ---> T1 --> T2)
+ $ aux T1 T2 ps $ t1 $ t2
+ in aux T1 T2 o rev end
+(* term -> bool *)
+fun is_plain_fun (Const (s, _)) = s mem [@{const_name undefined}, non_opt_name]
+ | is_plain_fun (Const (@{const_name fun_upd}, _) $ t0 $ _ $ _) =
+ is_plain_fun t0
+ | is_plain_fun _ = false
+(* term -> bool * (term list * term list) *)
+val dest_plain_fun =
+ let
+ (* term -> term list * term list *)
+ fun aux (Const (s, _)) = (s <> non_opt_name, ([], []))
+ | aux (Const (@{const_name fun_upd}, _) $ t0 $ t1 $ t2) =
+ let val (s, (ts1, ts2)) = aux t0 in (s, (t1 :: ts1, t2 :: ts2)) end
+ | aux t = raise TERM ("NitpickModel.dest_plain_fun", [t])
+ in apsnd (pairself rev) o aux end
+
+(* typ -> term -> term list * term *)
+fun break_in_two (Type ("*", [T1, T2]))
+ (Const (@{const_name Pair}, _) $ t1 $ t2) =
+ break_in_two T2 t2 |>> cons t1
+ | break_in_two _ (Const (@{const_name Pair}, _) $ t1 $ t2) = ([t1], t2)
+ | break_in_two _ t = raise TERM ("NitpickModel.break_in_two", [t])
+(* typ -> term -> term -> term *)
+fun pair_up (Type ("*", [T1', T2']))
+ (t1 as Const (@{const_name Pair},
+ Type ("fun", [_, Type ("fun", [_, T1])])) $ t11 $ t12)
+ t2 =
+ if T1 = T1' then HOLogic.mk_prod (t1, t2)
+ else HOLogic.mk_prod (t11, pair_up T2' t12 t2)
+ | pair_up _ t1 t2 = HOLogic.mk_prod (t1, t2)
+(* typ -> term -> term list * term list -> (term * term) list*)
+fun multi_pair_up T1 t1 (ts2, ts3) = map2 (pair o pair_up T1 t1) ts2 ts3
+
+(* typ -> typ -> typ -> term -> term *)
+fun typecast_fun (Type ("fun", [T1', T2'])) T1 T2 t =
+ let
+ (* typ -> typ -> typ -> term -> term *)
+ fun do_curry T1a T1b T2 t =
+ let
+ val (maybe_opt, ps) = dest_plain_fun t
+ val ps =
+ ps |>> map (break_in_two T1a #>> mk_flat_tuple T1a)
+ |> uncurry (map2 (fn (t1a, t1b) => fn t2 => (t1a, (t1b, t2))))
+ |> AList.coalesce (op =)
+ |> map (apsnd (make_plain_fun maybe_opt T1b T2))
+ in make_plain_fun maybe_opt T1a (T1b --> T2) ps end
+ (* typ -> typ -> term -> term *)
+ and do_uncurry T1 T2 t =
+ let
+ val (maybe_opt, tsp) = dest_plain_fun t
+ val ps =
+ tsp |> op ~~
+ |> maps (fn (t1, t2) =>
+ multi_pair_up T1 t1 (snd (dest_plain_fun t2)))
+ in make_plain_fun maybe_opt T1 T2 ps end
+ (* typ -> typ -> typ -> typ -> term -> term *)
+ and do_arrow T1' T2' _ _ (Const (s, _)) = Const (s, T1' --> T2')
+ | do_arrow T1' T2' T1 T2
+ (Const (@{const_name fun_upd}, _) $ t0 $ t1 $ t2) =
+ Const (@{const_name fun_upd},
+ [T1' --> T2', T1', T2'] ---> T1' --> T2')
+ $ do_arrow T1' T2' T1 T2 t0 $ do_term T1' T1 t1 $ do_term T2' T2 t2
+ | do_arrow _ _ _ _ t =
+ raise TERM ("NitpickModel.typecast_fun.do_arrow", [t])
+ and do_fun T1' T2' T1 T2 t =
+ case factor_out_types T1' T1 of
+ ((_, NONE), (_, NONE)) => t |> do_arrow T1' T2' T1 T2
+ | ((_, NONE), (T1a, SOME T1b)) =>
+ t |> do_curry T1a T1b T2 |> do_arrow T1' T2' T1a (T1b --> T2)
+ | ((T1a', SOME T1b'), (_, NONE)) =>
+ t |> do_arrow T1a' (T1b' --> T2') T1 T2 |> do_uncurry T1' T2'
+ | _ => raise TYPE ("NitpickModel.typecast_fun.do_fun", [T1, T1'], [])
+ (* typ -> typ -> term -> term *)
+ and do_term (Type ("fun", [T1', T2'])) (Type ("fun", [T1, T2])) t =
+ do_fun T1' T2' T1 T2 t
+ | do_term (T' as Type ("*", Ts' as [T1', T2'])) (Type ("*", [T1, T2]))
+ (Const (@{const_name Pair}, _) $ t1 $ t2) =
+ Const (@{const_name Pair}, Ts' ---> T')
+ $ do_term T1' T1 t1 $ do_term T2' T2 t2
+ | do_term T' T t =
+ if T = T' then t
+ else raise TYPE ("NitpickModel.typecast_fun.do_term", [T, T'], [])
+ in if T1' = T1 andalso T2' = T2 then t else do_fun T1' T2' T1 T2 t end
+ | typecast_fun T' _ _ _ = raise TYPE ("NitpickModel.typecast_fun", [T'], [])
+
+(* term -> string *)
+fun truth_const_sort_key @{const True} = "0"
+ | truth_const_sort_key @{const False} = "2"
+ | truth_const_sort_key _ = "1"
+
+(* typ -> term list -> term *)
+fun mk_tuple (Type ("*", [T1, T2])) ts =
+ HOLogic.mk_prod (mk_tuple T1 ts,
+ mk_tuple T2 (List.drop (ts, length (HOLogic.flatten_tupleT T1))))
+ | mk_tuple _ (t :: _) = t
+
+(* string * string * string * string -> scope -> nut list -> nut list
+ -> nut list -> nut NameTable.table -> Kodkod.raw_bound list -> typ -> typ
+ -> rep -> int list list -> term *)
+fun reconstruct_term (maybe_name, base_name, step_name, abs_name)
+ ({ext_ctxt as {thy, ctxt, ...}, card_assigns, datatypes, ofs, ...}
+ : scope) sel_names rel_table bounds =
+ let
+ val for_auto = (maybe_name = "")
+ (* bool -> typ -> typ -> (term * term) list -> term *)
+ fun make_set maybe_opt T1 T2 =
+ let
+ val empty_const = Const (@{const_name Set.empty}, T1 --> T2)
+ val insert_const = Const (@{const_name insert},
+ [T1, T1 --> T2] ---> T1 --> T2)
+ (* (term * term) list -> term *)
+ fun aux [] =
+ if maybe_opt andalso not (is_precise_type datatypes T1) then
+ insert_const $ Const (unrep, T1) $ empty_const
+ else
+ empty_const
+ | aux ((t1, t2) :: zs) =
+ aux zs |> t2 <> @{const False}
+ ? curry (op $) (insert_const
+ $ (t1 |> t2 <> @{const True}
+ ? curry (op $)
+ (Const (maybe_name,
+ T1 --> T1))))
+ in aux end
+ (* typ -> typ -> typ -> (term * term) list -> term *)
+ fun make_map T1 T2 T2' =
+ let
+ val update_const = Const (@{const_name fun_upd},
+ [T1 --> T2, T1, T2] ---> T1 --> T2)
+ (* (term * term) list -> term *)
+ fun aux' [] = Const (@{const_name Map.empty}, T1 --> T2)
+ | aux' ((t1, t2) :: ps) =
+ (case t2 of
+ Const (@{const_name None}, _) => aux' ps
+ | _ => update_const $ aux' ps $ t1 $ t2)
+ fun aux ps =
+ if not (is_precise_type datatypes T1) then
+ update_const $ aux' ps $ Const (unrep, T1)
+ $ (Const (@{const_name Some}, T2' --> T2) $ Const (unknown, T2'))
+ else
+ aux' ps
+ in aux end
+ (* typ list -> term -> term *)
+ fun setify_mapify_funs Ts t =
+ (case fastype_of1 (Ts, t) of
+ Type ("fun", [T1, T2]) =>
+ if is_plain_fun t then
+ case T2 of
+ @{typ bool} =>
+ let
+ val (maybe_opt, ts_pair) =
+ dest_plain_fun t ||> pairself (map (setify_mapify_funs Ts))
+ in
+ make_set maybe_opt T1 T2
+ (sort_wrt (truth_const_sort_key o snd) (op ~~ ts_pair))
+ end
+ | Type (@{type_name option}, [T2']) =>
+ let
+ val ts_pair = snd (dest_plain_fun t)
+ |> pairself (map (setify_mapify_funs Ts))
+ in make_map T1 T2 T2' (rev (op ~~ ts_pair)) end
+ | _ => raise SAME ()
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ case t of
+ t1 $ t2 => setify_mapify_funs Ts t1 $ setify_mapify_funs Ts t2
+ | Abs (s, T, t') => Abs (s, T, setify_mapify_funs (T :: Ts) t')
+ | _ => t
+ (* bool -> typ -> typ -> typ -> term list -> term list -> term *)
+ fun make_fun maybe_opt T1 T2 T' ts1 ts2 =
+ ts1 ~~ ts2 |> T1 = @{typ bisim_iterator} ? rev
+ |> make_plain_fun (maybe_opt andalso not for_auto) T1 T2
+ |> unbox_term
+ |> typecast_fun (unbox_type T') (unbox_type T1) (unbox_type T2)
+ (* (typ * int) list -> typ -> typ -> int -> term *)
+ fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j =
+ let
+ val k1 = card_of_type card_assigns T1
+ val k2 = card_of_type card_assigns T2
+ in
+ term_for_rep seen T T' (Vect (k1, Atom (k2, 0)))
+ [nth_combination (replicate k1 (k2, 0)) j]
+ handle General.Subscript =>
+ raise ARG ("NitpickModel.reconstruct_term.term_for_atom",
+ signed_string_of_int j ^ " for " ^
+ string_for_rep (Vect (k1, Atom (k2, 0))))
+ end
+ | term_for_atom seen (Type ("*", [T1, T2])) _ j =
+ let val k1 = card_of_type card_assigns T1 in
+ list_comb (HOLogic.pair_const T1 T2,
+ map2 (fn T => term_for_atom seen T T) [T1, T2]
+ [j div k1, j mod k1])
+ end
+ | term_for_atom seen @{typ prop} _ j =
+ HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j)
+ | term_for_atom _ @{typ bool} _ j =
+ if j = 0 then @{const False} else @{const True}
+ | term_for_atom _ @{typ unit} _ _ = @{const Unity}
+ | term_for_atom seen T _ j =
+ if T = nat_T then
+ HOLogic.mk_number nat_T j
+ else if T = int_T then
+ HOLogic.mk_number int_T
+ (int_for_atom (card_of_type card_assigns int_T, 0) j)
+ else if is_fp_iterator_type T then
+ HOLogic.mk_number nat_T (card_of_type card_assigns T - j - 1)
+ else if T = @{typ bisim_iterator} then
+ HOLogic.mk_number nat_T j
+ else case datatype_spec datatypes T of
+ NONE => atom for_auto T j
+ | SOME {constrs, co, ...} =>
+ let
+ (* styp -> int list *)
+ fun tuples_for_const (s, T) =
+ tuple_list_for_name rel_table bounds (ConstName (s, T, Any))
+ (* unit -> indexname * typ *)
+ fun var () = ((atom_name "" T j, 0), T)
+ val discr_jsss = map (tuples_for_const o discr_for_constr o #const)
+ constrs
+ val real_j = j + offset_of_type ofs T
+ val constr_x as (constr_s, constr_T) =
+ get_first (fn (jss, {const, ...}) =>
+ if [real_j] mem jss then SOME const else NONE)
+ (discr_jsss ~~ constrs) |> the
+ val arg_Ts = curried_binder_types constr_T
+ val sel_xs = map (boxed_nth_sel_for_constr ext_ctxt constr_x)
+ (index_seq 0 (length arg_Ts))
+ val sel_Rs =
+ map (fn x => get_first
+ (fn ConstName (s', T', R) =>
+ if (s', T') = x then SOME R else NONE
+ | u => raise NUT ("NitpickModel.reconstruct_\
+ \term.term_for_atom", [u]))
+ sel_names |> the) sel_xs
+ val arg_Rs = map (snd o dest_Func) sel_Rs
+ val sel_jsss = map tuples_for_const sel_xs
+ val arg_jsss =
+ map (map_filter (fn js => if hd js = real_j then SOME (tl js)
+ else NONE)) sel_jsss
+ val uncur_arg_Ts = binder_types constr_T
+ in
+ if co andalso (T, j) mem seen then
+ Var (var ())
+ else
+ let
+ val seen = seen |> co ? cons (T, j)
+ val ts =
+ if length arg_Ts = 0 then
+ []
+ else
+ map3 (fn Ts => term_for_rep seen Ts Ts) arg_Ts arg_Rs
+ arg_jsss
+ |> mk_tuple (HOLogic.mk_tupleT uncur_arg_Ts)
+ |> dest_n_tuple (length uncur_arg_Ts)
+ val t =
+ if constr_s = @{const_name Abs_Frac} then
+ let
+ val num_T = body_type T
+ (* int -> term *)
+ val mk_num = HOLogic.mk_number num_T
+ in
+ case ts of
+ [Const (@{const_name Pair}, _) $ t1 $ t2] =>
+ (case snd (HOLogic.dest_number t1) of
+ 0 => mk_num 0
+ | n1 => case HOLogic.dest_number t2 |> snd of
+ 1 => mk_num n1
+ | n2 => Const (@{const_name HOL.divide},
+ [num_T, num_T] ---> num_T)
+ $ mk_num n1 $ mk_num n2)
+ | _ => raise TERM ("NitpickModel.reconstruct_term.term_\
+ \for_atom (Abs_Frac)", ts)
+ end
+ else if not for_auto andalso is_abs_fun thy constr_x then
+ Const (abs_name, constr_T) $ the_single ts
+ else
+ list_comb (Const constr_x, ts)
+ in
+ if co then
+ let val var = var () in
+ if exists_subterm (equal (Var var)) t then
+ Const (@{const_name The}, (T --> bool_T) --> T)
+ $ Abs ("\<omega>", T,
+ Const (@{const_name "op ="}, [T, T] ---> bool_T)
+ $ Bound 0 $ abstract_over (Var var, t))
+ else
+ t
+ end
+ else
+ t
+ end
+ end
+ (* (typ * int) list -> int -> rep -> typ -> typ -> typ -> int list
+ -> term *)
+ and term_for_vect seen k R T1 T2 T' js =
+ make_fun true T1 T2 T' (map (term_for_atom seen T1 T1) (index_seq 0 k))
+ (map (term_for_rep seen T2 T2 R o single)
+ (batch_list (arity_of_rep R) js))
+ (* (typ * int) list -> typ -> typ -> rep -> int list list -> term *)
+ and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0
+ | term_for_rep seen T T' (R as Atom (k, j0)) [[j]] =
+ if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0)
+ else raise REP ("NitpickModel.reconstruct_term.term_for_rep", [R])
+ | term_for_rep seen (Type ("*", [T1, T2])) _ (Struct [R1, R2]) [js] =
+ let
+ val arity1 = arity_of_rep R1
+ val (js1, js2) = chop arity1 js
+ in
+ list_comb (HOLogic.pair_const T1 T2,
+ map3 (fn T => term_for_rep seen T T) [T1, T2] [R1, R2]
+ [[js1], [js2]])
+ end
+ | term_for_rep seen (Type ("fun", [T1, T2])) T' (R as Vect (k, R')) [js] =
+ term_for_vect seen k R' T1 T2 T' js
+ | term_for_rep seen (Type ("fun", [T1, T2])) T' (Func (R1, Formula Neut))
+ jss =
+ let
+ val jss1 = all_combinations_for_rep R1
+ val ts1 = map (term_for_rep seen T1 T1 R1 o single) jss1
+ val ts2 =
+ map (fn js => term_for_rep seen T2 T2 (Atom (2, 0))
+ [[int_for_bool (js mem jss)]]) jss1
+ in make_fun false T1 T2 T' ts1 ts2 end
+ | term_for_rep seen (Type ("fun", [T1, T2])) T' (Func (R1, R2)) jss =
+ let
+ val arity1 = arity_of_rep R1
+ val jss1 = all_combinations_for_rep R1
+ val ts1 = map (term_for_rep seen T1 T1 R1 o single) jss1
+ val grouped_jss2 = AList.group (op =) (map (chop arity1) jss)
+ val ts2 = map (term_for_rep seen T2 T2 R2 o the_default []
+ o AList.lookup (op =) grouped_jss2) jss1
+ in make_fun true T1 T2 T' ts1 ts2 end
+ | term_for_rep seen T T' (Opt R) jss =
+ if null jss then Const (unknown, T) else term_for_rep seen T T' R jss
+ | term_for_rep seen T _ R jss =
+ raise ARG ("NitpickModel.reconstruct_term.term_for_rep",
+ Refute.string_of_typ T ^ " " ^ string_for_rep R ^ " " ^
+ string_of_int (length jss))
+ in
+ (not for_auto ? setify_mapify_funs []) o unbox_term oooo term_for_rep []
+ end
+
+(* scope -> nut list -> nut NameTable.table -> Kodkod.raw_bound list -> nut
+ -> term *)
+fun term_for_name scope sel_names rel_table bounds name =
+ let val T = type_of name in
+ tuple_list_for_name rel_table bounds name
+ |> reconstruct_term ("", "", "", "") scope sel_names rel_table bounds T T
+ (rep_of name)
+ end
+
+(* Proof.context
+ -> (string * string * string * string * string) * Proof.context *)
+fun add_wacky_syntax ctxt =
+ let
+ (* term -> string *)
+ val name_of = fst o dest_Const
+ val thy = ProofContext.theory_of ctxt |> Context.reject_draft
+ val (maybe_t, thy) =
+ Sign.declare_const ((@{binding nitpick_maybe}, @{typ "'a => 'a"}),
+ Mixfix (maybe_mixfix, [1000], 1000)) thy
+ val (base_t, thy) =
+ Sign.declare_const ((@{binding nitpick_base}, @{typ "'a => 'a"}),
+ Mixfix (base_mixfix, [1000], 1000)) thy
+ val (step_t, thy) =
+ Sign.declare_const ((@{binding nitpick_step}, @{typ "'a => 'a"}),
+ Mixfix (step_mixfix, [1000], 1000)) thy
+ val (abs_t, thy) =
+ Sign.declare_const ((@{binding nitpick_abs}, @{typ "'a => 'b"}),
+ Mixfix (abs_mixfix, [40], 40)) thy
+ in
+ ((name_of maybe_t, name_of base_t, name_of step_t, name_of abs_t),
+ ProofContext.transfer_syntax thy ctxt)
+ end
+
+(* term -> term *)
+fun unfold_outer_the_binders (t as Const (@{const_name The}, _)
+ $ Abs (s, T, Const (@{const_name "op ="}, _)
+ $ Bound 0 $ t')) =
+ betapply (Abs (s, T, t'), t) |> unfold_outer_the_binders
+ | unfold_outer_the_binders t = t
+(* typ list -> int -> term * term -> bool *)
+fun bisimilar_values _ 0 _ = true
+ | bisimilar_values coTs max_depth (t1, t2) =
+ let val T = fastype_of t1 in
+ if exists_subtype (member (op =) coTs) T then
+ let
+ val ((head1, args1), (head2, args2)) =
+ pairself (strip_comb o unfold_outer_the_binders) (t1, t2)
+ val max_depth = max_depth - (if T mem coTs then 1 else 0)
+ in
+ head1 = head2
+ andalso forall (bisimilar_values coTs max_depth) (args1 ~~ args2)
+ end
+ else
+ t1 = t2
+ end
+
+(* params -> scope -> (term option * int list) list -> styp list -> nut list
+ -> nut list -> nut list -> nut NameTable.table -> Kodkod.raw_bound list
+ -> Pretty.T * bool *)
+fun reconstruct_hol_model {show_skolems, show_datatypes, show_consts}
+ ({ext_ctxt as {thy, ctxt, max_bisim_depth, boxes, user_axioms, debug,
+ wfs, destroy_constrs, specialize, skolemize,
+ star_linear_preds, uncurry, fast_descrs, tac_timeout,
+ evals, case_names, def_table, nondef_table, user_nondefs,
+ simp_table, psimp_table, intro_table, ground_thm_table,
+ ersatz_table, skolems, special_funs, unrolled_preds,
+ wf_cache},
+ card_assigns, bisim_depth, datatypes, ofs} : scope) formats all_frees
+ free_names sel_names nonsel_names rel_table bounds =
+ let
+ val (wacky_names as (_, base_name, step_name, _), ctxt) =
+ add_wacky_syntax ctxt
+ val ext_ctxt =
+ {thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
+ wfs = wfs, user_axioms = user_axioms, debug = debug,
+ destroy_constrs = destroy_constrs, specialize = specialize,
+ skolemize = skolemize, star_linear_preds = star_linear_preds,
+ uncurry = uncurry, fast_descrs = fast_descrs, tac_timeout = tac_timeout,
+ evals = evals, case_names = case_names, def_table = def_table,
+ nondef_table = nondef_table, user_nondefs = user_nondefs,
+ simp_table = simp_table, psimp_table = psimp_table,
+ intro_table = intro_table, ground_thm_table = ground_thm_table,
+ ersatz_table = ersatz_table, skolems = skolems,
+ special_funs = special_funs, unrolled_preds = unrolled_preds,
+ wf_cache = wf_cache}
+ val scope = {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
+ bisim_depth = bisim_depth, datatypes = datatypes, ofs = ofs}
+ (* typ -> typ -> rep -> int list list -> term *)
+ val term_for_rep = reconstruct_term wacky_names scope sel_names rel_table
+ bounds
+ (* typ -> typ -> typ *)
+ fun nth_value_of_type T card n = term_for_rep T T (Atom (card, 0)) [[n]]
+ (* dtype_spec list -> dtype_spec -> bool *)
+ fun is_codatatype_wellformed (cos : dtype_spec list)
+ ({typ, card, ...} : dtype_spec) =
+ let
+ val ts = map (nth_value_of_type typ card) (index_seq 0 card)
+ val max_depth = Integer.sum (map #card cos)
+ in
+ forall (not o bisimilar_values (map #typ cos) max_depth)
+ (all_distinct_unordered_pairs_of ts)
+ end
+ (* string -> Pretty.T *)
+ fun pretty_for_assign name =
+ let
+ val (oper, (t1, T'), T) =
+ case name of
+ FreeName (s, T, _) =>
+ let val t = Free (s, unbox_type T) in
+ ("=", (t, format_term_type thy def_table formats t), T)
+ end
+ | ConstName (s, T, _) =>
+ (assign_operator_for_const (s, T),
+ user_friendly_const ext_ctxt (base_name, step_name) formats (s, T),
+ T)
+ | _ => raise NUT ("NitpickModel.reconstruct_hol_model.\
+ \pretty_for_assign", [name])
+ val t2 = if rep_of name = Any then
+ Const (@{const_name undefined}, T')
+ else
+ tuple_list_for_name rel_table bounds name
+ |> term_for_rep T T' (rep_of name)
+ in
+ Pretty.block (Pretty.breaks
+ [(setmp_CRITICAL show_question_marks false o setmp_show_all_types)
+ (Syntax.pretty_term ctxt) t1,
+ Pretty.str oper, Syntax.pretty_term ctxt t2])
+ end
+ (* dtype_spec -> Pretty.T *)
+ fun pretty_for_datatype ({typ, card, precise, ...} : dtype_spec) =
+ Pretty.block (Pretty.breaks
+ [Syntax.pretty_typ ctxt (unbox_type typ), Pretty.str "=",
+ Pretty.enum "," "{" "}"
+ (map (Syntax.pretty_term ctxt o nth_value_of_type typ card)
+ (index_seq 0 card) @
+ (if precise then [] else [Pretty.str unrep]))])
+ (* typ -> dtype_spec list *)
+ fun integer_datatype T =
+ [{typ = T, card = card_of_type card_assigns T, co = false,
+ precise = false, constrs = []}]
+ handle TYPE ("NitpickHOL.card_of_type", _, _) => []
+ val (codatatypes, datatypes) =
+ List.partition #co datatypes
+ ||> append (integer_datatype nat_T @ integer_datatype int_T)
+ val block_of_datatypes =
+ if show_datatypes andalso not (null datatypes) then
+ [Pretty.big_list ("Datatype" ^ plural_s_for_list datatypes ^ ":")
+ (map pretty_for_datatype datatypes)]
+ else
+ []
+ val block_of_codatatypes =
+ if show_datatypes andalso not (null codatatypes) then
+ [Pretty.big_list ("Codatatype" ^ plural_s_for_list codatatypes ^ ":")
+ (map pretty_for_datatype codatatypes)]
+ else
+ []
+ (* bool -> string -> nut list -> Pretty.T list *)
+ fun block_of_names show title names =
+ if show andalso not (null names) then
+ Pretty.str (title ^ plural_s_for_list names ^ ":")
+ :: map (Pretty.indent indent_size o pretty_for_assign)
+ (sort_wrt (original_name o nickname_of) names)
+ else
+ []
+ val (skolem_names, nonskolem_nonsel_names) =
+ List.partition is_skolem_name nonsel_names
+ val (eval_names, noneval_nonskolem_nonsel_names) =
+ List.partition (String.isPrefix eval_prefix o nickname_of)
+ nonskolem_nonsel_names
+ ||> filter_out (equal @{const_name bisim_iterator_max} o nickname_of)
+ val free_names =
+ map (fn x as (s, T) =>
+ case filter (equal x o nickname_of pairf (unbox_type o type_of))
+ free_names of
+ [name] => name
+ | [] => FreeName (s, T, Any)
+ | _ => raise TERM ("NitpickModel.reconstruct_hol_model",
+ [Const x])) all_frees
+ val chunks = block_of_names true "Free variable" free_names @
+ block_of_names show_skolems "Skolem constant" skolem_names @
+ block_of_names true "Evaluated term" eval_names @
+ block_of_datatypes @ block_of_codatatypes @
+ block_of_names show_consts "Constant"
+ noneval_nonskolem_nonsel_names
+ in
+ (Pretty.chunks (if null chunks then [Pretty.str "Empty assignment"]
+ else chunks),
+ bisim_depth >= 0
+ orelse forall (is_codatatype_wellformed codatatypes) codatatypes)
+ end
+
+(* scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
+ -> Kodkod.raw_bound list -> term -> bool option *)
+fun prove_hol_model (scope as {ext_ctxt as {thy, ctxt, ...}, card_assigns, ...})
+ auto_timeout free_names sel_names rel_table bounds prop =
+ let
+ (* typ * int -> term *)
+ fun free_type_assm (T, k) =
+ let
+ (* int -> term *)
+ val atom = atom true T
+ fun equation_for_atom j = HOLogic.eq_const T $ Bound 0 $ atom j
+ val eqs = map equation_for_atom (index_seq 0 k)
+ val compreh_assm =
+ Const (@{const_name All}, (T --> bool_T) --> bool_T)
+ $ Abs ("x", T, foldl1 HOLogic.mk_disj eqs)
+ val distinct_assm = distinctness_formula T (map atom (index_seq 0 k))
+ in HOLogic.mk_conj (compreh_assm, distinct_assm) end
+ (* nut -> term *)
+ fun free_name_assm name =
+ HOLogic.mk_eq (Free (nickname_of name, type_of name),
+ term_for_name scope sel_names rel_table bounds name)
+ val freeT_assms = map free_type_assm (filter (is_TFree o fst) card_assigns)
+ val model_assms = map free_name_assm free_names
+ val assm = List.foldr HOLogic.mk_conj @{const True}
+ (freeT_assms @ model_assms)
+ (* bool -> bool *)
+ fun try_out negate =
+ let
+ val concl = (negate ? curry (op $) @{const Not})
+ (ObjectLogic.atomize_term thy prop)
+ val goal = HOLogic.mk_Trueprop (HOLogic.mk_imp (assm, concl))
+ |> map_types (map_type_tfree
+ (fn (s, []) => TFree (s, HOLogic.typeS)
+ | x => TFree x))
+ |> cterm_of thy |> Goal.init
+ in
+ (goal |> SINGLE (DETERM_TIMEOUT auto_timeout
+ (auto_tac (clasimpset_of ctxt)))
+ |> the |> Goal.finish ctxt; true)
+ handle THM _ => false
+ | TimeLimit.TimeOut => false
+ end
+ in
+ if silence try_out false then SOME true
+ else if silence try_out true then SOME false
+ else NONE
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_mono.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,943 @@
+(* Title: HOL/Nitpick/Tools/nitpick_mono.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2009
+
+Monotonicity predicate for higher-order logic.
+*)
+
+signature NITPICK_MONO =
+sig
+ type extended_context = NitpickHOL.extended_context
+
+ val formulas_monotonic :
+ extended_context -> typ -> term list -> term list -> term -> bool
+end;
+
+structure NitpickMono : NITPICK_MONO =
+struct
+
+open NitpickUtil
+open NitpickHOL
+
+type var = int
+
+datatype sign = Pos | Neg
+datatype sign_atom = S of sign | V of var
+
+type literal = var * sign
+
+datatype ctype =
+ CAlpha |
+ CFun of ctype * sign_atom * ctype |
+ CPair of ctype * ctype |
+ CType of string * ctype list |
+ CRec of string * typ list
+
+type cdata =
+ {ext_ctxt: extended_context,
+ alpha_T: typ,
+ max_fresh: int Unsynchronized.ref,
+ datatype_cache: ((string * typ list) * ctype) list Unsynchronized.ref,
+ constr_cache: (styp * ctype) list Unsynchronized.ref}
+
+exception CTYPE of string * ctype list
+
+(* string -> unit *)
+fun print_g (s : string) = ()
+
+(* var -> string *)
+val string_for_var = signed_string_of_int
+(* string -> var list -> string *)
+fun string_for_vars sep [] = "0\<^bsub>" ^ sep ^ "\<^esub>"
+ | string_for_vars sep xs = space_implode sep (map string_for_var xs)
+fun subscript_string_for_vars sep xs =
+ if null xs then "" else "\<^bsub>" ^ string_for_vars sep xs ^ "\<^esub>"
+
+(* sign -> string *)
+fun string_for_sign Pos = "+"
+ | string_for_sign Neg = "-"
+
+(* sign -> sign -> sign *)
+fun xor sn1 sn2 = if sn1 = sn2 then Pos else Neg
+(* sign -> sign *)
+val negate = xor Neg
+
+(* sign_atom -> string *)
+fun string_for_sign_atom (S sn) = string_for_sign sn
+ | string_for_sign_atom (V j) = string_for_var j
+
+(* literal -> string *)
+fun string_for_literal (x, sn) = string_for_var x ^ " = " ^ string_for_sign sn
+
+val bool_C = CType (@{type_name bool}, [])
+
+(* ctype -> bool *)
+fun is_CRec (CRec _) = true
+ | is_CRec _ = false
+
+val no_prec = 100
+val prec_CFun = 1
+val prec_CPair = 2
+
+(* tuple_set -> int *)
+fun precedence_of_ctype (CFun _) = prec_CFun
+ | precedence_of_ctype (CPair _) = prec_CPair
+ | precedence_of_ctype _ = no_prec
+
+(* ctype -> string *)
+val string_for_ctype =
+ let
+ (* int -> ctype -> string *)
+ fun aux outer_prec C =
+ let
+ val prec = precedence_of_ctype C
+ val need_parens = (prec < outer_prec)
+ in
+ (if need_parens then "(" else "") ^
+ (case C of
+ CAlpha => "\<alpha>"
+ | CFun (C1, a, C2) =>
+ aux (prec + 1) C1 ^ " \<Rightarrow>\<^bsup>" ^
+ string_for_sign_atom a ^ "\<^esup> " ^ aux prec C2
+ | CPair (C1, C2) => aux (prec + 1) C1 ^ " \<times> " ^ aux prec C2
+ | CType (s, []) =>
+ if s mem [@{type_name prop}, @{type_name bool}] then "o" else s
+ | CType (s, Cs) => "(" ^ commas (map (aux 0) Cs) ^ ") " ^ s
+ | CRec (s, _) => "[" ^ s ^ "]") ^
+ (if need_parens then ")" else "")
+ end
+ in aux 0 end
+
+(* ctype -> ctype list *)
+fun flatten_ctype (CPair (C1, C2)) = maps flatten_ctype [C1, C2]
+ | flatten_ctype (CType (_, Cs)) = maps flatten_ctype Cs
+ | flatten_ctype C = [C]
+
+(* extended_context -> typ -> cdata *)
+fun initial_cdata ext_ctxt alpha_T =
+ ({ext_ctxt = ext_ctxt, alpha_T = alpha_T, max_fresh = Unsynchronized.ref 0,
+ datatype_cache = Unsynchronized.ref [],
+ constr_cache = Unsynchronized.ref []} : cdata)
+
+(* typ -> typ -> bool *)
+fun could_exist_alpha_subtype alpha_T (T as Type (_, Ts)) =
+ T = alpha_T orelse (not (is_fp_iterator_type T)
+ andalso exists (could_exist_alpha_subtype alpha_T) Ts)
+ | could_exist_alpha_subtype alpha_T T = (T = alpha_T)
+(* theory -> typ -> typ -> bool *)
+fun could_exist_alpha_sub_ctype _ (alpha_T as TFree _) =
+ could_exist_alpha_subtype alpha_T
+ | could_exist_alpha_sub_ctype thy alpha_T = equal alpha_T orf is_datatype thy
+
+(* ctype -> bool *)
+fun exists_alpha_sub_ctype CAlpha = true
+ | exists_alpha_sub_ctype (CFun (C1, _, C2)) =
+ exists exists_alpha_sub_ctype [C1, C2]
+ | exists_alpha_sub_ctype (CPair (C1, C2)) =
+ exists exists_alpha_sub_ctype [C1, C2]
+ | exists_alpha_sub_ctype (CType (_, Cs)) = exists exists_alpha_sub_ctype Cs
+ | exists_alpha_sub_ctype (CRec _) = true
+
+(* ctype -> bool *)
+fun exists_alpha_sub_ctype_fresh CAlpha = true
+ | exists_alpha_sub_ctype_fresh (CFun (_, V _, _)) = true
+ | exists_alpha_sub_ctype_fresh (CFun (_, _, C2)) =
+ exists_alpha_sub_ctype_fresh C2
+ | exists_alpha_sub_ctype_fresh (CPair (C1, C2)) =
+ exists exists_alpha_sub_ctype_fresh [C1, C2]
+ | exists_alpha_sub_ctype_fresh (CType (_, Cs)) =
+ exists exists_alpha_sub_ctype_fresh Cs
+ | exists_alpha_sub_ctype_fresh (CRec _) = true
+
+(* string * typ list -> ctype list -> ctype *)
+fun constr_ctype_for_binders z Cs =
+ fold_rev (fn C => curry3 CFun C (S Neg)) Cs (CRec z)
+
+(* ((string * typ list) * ctype) list -> ctype list -> ctype -> ctype *)
+fun repair_ctype _ _ CAlpha = CAlpha
+ | repair_ctype cache seen (CFun (C1, a, C2)) =
+ CFun (repair_ctype cache seen C1, a, repair_ctype cache seen C2)
+ | repair_ctype cache seen (CPair Cp) =
+ CPair (pairself (repair_ctype cache seen) Cp)
+ | repair_ctype cache seen (CType (s, Cs)) =
+ CType (s, maps (flatten_ctype o repair_ctype cache seen) Cs)
+ | repair_ctype cache seen (CRec (z as (s, _))) =
+ case AList.lookup (op =) cache z |> the of
+ CRec _ => CType (s, [])
+ | C => if C mem seen then CType (s, [])
+ else repair_ctype cache (C :: seen) C
+
+(* ((string * typ list) * ctype) list Unsynchronized.ref -> unit *)
+fun repair_datatype_cache cache =
+ let
+ (* (string * typ list) * ctype -> unit *)
+ fun repair_one (z, C) =
+ Unsynchronized.change cache
+ (AList.update (op =) (z, repair_ctype (!cache) [] C))
+ in List.app repair_one (rev (!cache)) end
+
+(* (typ * ctype) list -> (styp * ctype) list Unsynchronized.ref -> unit *)
+fun repair_constr_cache dtype_cache constr_cache =
+ let
+ (* styp * ctype -> unit *)
+ fun repair_one (x, C) =
+ Unsynchronized.change constr_cache
+ (AList.update (op =) (x, repair_ctype dtype_cache [] C))
+ in List.app repair_one (!constr_cache) end
+
+(* cdata -> typ -> ctype *)
+fun fresh_ctype_for_type ({ext_ctxt as {thy, ...}, alpha_T, max_fresh,
+ datatype_cache, constr_cache, ...} : cdata) =
+ let
+ (* typ -> typ -> ctype *)
+ fun do_fun T1 T2 =
+ let
+ val C1 = do_type T1
+ val C2 = do_type T2
+ val a = if is_boolean_type (body_type T2)
+ andalso exists_alpha_sub_ctype_fresh C1 then
+ V (Unsynchronized.inc max_fresh)
+ else
+ S Neg
+ in CFun (C1, a, C2) end
+ (* typ -> ctype *)
+ and do_type T =
+ if T = alpha_T then
+ CAlpha
+ else case T of
+ Type ("fun", [T1, T2]) => do_fun T1 T2
+ | Type (@{type_name fun_box}, [T1, T2]) => do_fun T1 T2
+ | Type ("*", [T1, T2]) => CPair (pairself do_type (T1, T2))
+ | Type (z as (s, _)) =>
+ if could_exist_alpha_sub_ctype thy alpha_T T then
+ case AList.lookup (op =) (!datatype_cache) z of
+ SOME C => C
+ | NONE =>
+ let
+ val _ = Unsynchronized.change datatype_cache (cons (z, CRec z))
+ val xs = datatype_constrs thy T
+ val (all_Cs, constr_Cs) =
+ fold_rev (fn (_, T') => fn (all_Cs, constr_Cs) =>
+ let
+ val binder_Cs = map do_type (binder_types T')
+ val new_Cs = filter exists_alpha_sub_ctype_fresh
+ binder_Cs
+ val constr_C = constr_ctype_for_binders z
+ binder_Cs
+ in
+ (union (op =) new_Cs all_Cs,
+ constr_C :: constr_Cs)
+ end)
+ xs ([], [])
+ val C = CType (s, all_Cs)
+ val _ = Unsynchronized.change datatype_cache
+ (AList.update (op =) (z, C))
+ val _ = Unsynchronized.change constr_cache
+ (append (xs ~~ constr_Cs))
+ in
+ if forall (not o is_CRec o snd) (!datatype_cache) then
+ (repair_datatype_cache datatype_cache;
+ repair_constr_cache (!datatype_cache) constr_cache;
+ AList.lookup (op =) (!datatype_cache) z |> the)
+ else
+ C
+ end
+ else
+ CType (s, [])
+ | _ => CType (Refute.string_of_typ T, [])
+ in do_type end
+
+(* ctype -> ctype list *)
+fun prodC_factors (CPair (C1, C2)) = maps prodC_factors [C1, C2]
+ | prodC_factors C = [C]
+(* ctype -> ctype list * ctype *)
+fun curried_strip_ctype (CFun (C1, S Neg, C2)) =
+ curried_strip_ctype C2 |>> append (prodC_factors C1)
+ | curried_strip_ctype C = ([], C)
+(* string -> ctype -> ctype *)
+fun sel_ctype_from_constr_ctype s C =
+ let val (arg_Cs, dataC) = curried_strip_ctype C in
+ CFun (dataC, S Neg,
+ case sel_no_from_name s of ~1 => bool_C | n => nth arg_Cs n)
+ end
+
+(* cdata -> styp -> ctype *)
+fun ctype_for_constr (cdata as {ext_ctxt as {thy, ...}, alpha_T, constr_cache,
+ ...}) (x as (_, T)) =
+ if could_exist_alpha_sub_ctype thy alpha_T T then
+ case AList.lookup (op =) (!constr_cache) x of
+ SOME C => C
+ | NONE => (fresh_ctype_for_type cdata (body_type T);
+ AList.lookup (op =) (!constr_cache) x |> the)
+ else
+ fresh_ctype_for_type cdata T
+fun ctype_for_sel (cdata as {ext_ctxt, ...}) (x as (s, _)) =
+ x |> boxed_constr_for_sel ext_ctxt |> ctype_for_constr cdata
+ |> sel_ctype_from_constr_ctype s
+
+(* literal list -> ctype -> ctype *)
+fun instantiate_ctype lits =
+ let
+ (* ctype -> ctype *)
+ fun aux CAlpha = CAlpha
+ | aux (CFun (C1, V x, C2)) =
+ let
+ val a = case AList.lookup (op =) lits x of
+ SOME sn => S sn
+ | NONE => V x
+ in CFun (aux C1, a, aux C2) end
+ | aux (CFun (C1, a, C2)) = CFun (aux C1, a, aux C2)
+ | aux (CPair Cp) = CPair (pairself aux Cp)
+ | aux (CType (s, Cs)) = CType (s, map aux Cs)
+ | aux (CRec z) = CRec z
+ in aux end
+
+datatype comp_op = Eq | Leq
+
+type comp = sign_atom * sign_atom * comp_op * var list
+type sign_expr = literal list
+
+datatype constraint_set =
+ UnsolvableCSet |
+ CSet of literal list * comp list * sign_expr list
+
+(* comp_op -> string *)
+fun string_for_comp_op Eq = "="
+ | string_for_comp_op Leq = "\<le>"
+
+(* sign_expr -> string *)
+fun string_for_sign_expr [] = "\<bot>"
+ | string_for_sign_expr lits =
+ space_implode " \<or> " (map string_for_literal lits)
+
+(* constraint_set *)
+val slack = CSet ([], [], [])
+
+(* literal -> literal list option -> literal list option *)
+fun do_literal _ NONE = NONE
+ | do_literal (x, sn) (SOME lits) =
+ case AList.lookup (op =) lits x of
+ SOME sn' => if sn = sn' then SOME lits else NONE
+ | NONE => SOME ((x, sn) :: lits)
+
+(* comp_op -> var list -> sign_atom -> sign_atom -> literal list * comp list
+ -> (literal list * comp list) option *)
+fun do_sign_atom_comp Eq [] a1 a2 (accum as (lits, comps)) =
+ (case (a1, a2) of
+ (S sn1, S sn2) => if sn1 = sn2 then SOME accum else NONE
+ | (V x1, S sn2) =>
+ Option.map (rpair comps) (do_literal (x1, sn2) (SOME lits))
+ | (V _, V _) => SOME (lits, insert (op =) (a1, a2, Eq, []) comps)
+ | _ => do_sign_atom_comp Eq [] a2 a1 accum)
+ | do_sign_atom_comp Leq [] a1 a2 (accum as (lits, comps)) =
+ (case (a1, a2) of
+ (_, S Neg) => SOME accum
+ | (S Pos, _) => SOME accum
+ | (S Neg, S Pos) => NONE
+ | (V _, V _) => SOME (lits, insert (op =) (a1, a2, Leq, []) comps)
+ | _ => do_sign_atom_comp Eq [] a1 a2 accum)
+ | do_sign_atom_comp cmp xs a1 a2 (accum as (lits, comps)) =
+ SOME (lits, insert (op =) (a1, a2, cmp, xs) comps)
+
+(* comp -> var list -> ctype -> ctype -> (literal list * comp list) option
+ -> (literal list * comp list) option *)
+fun do_ctype_comp _ _ _ _ NONE = NONE
+ | do_ctype_comp _ _ CAlpha CAlpha accum = accum
+ | do_ctype_comp Eq xs (CFun (C11, a1, C12)) (CFun (C21, a2, C22))
+ (SOME accum) =
+ accum |> do_sign_atom_comp Eq xs a1 a2 |> do_ctype_comp Eq xs C11 C21
+ |> do_ctype_comp Eq xs C12 C22
+ | do_ctype_comp Leq xs (CFun (C11, a1, C12)) (CFun (C21, a2, C22))
+ (SOME accum) =
+ (if exists_alpha_sub_ctype C11 then
+ accum |> do_sign_atom_comp Leq xs a1 a2
+ |> do_ctype_comp Leq xs C21 C11
+ |> (case a2 of
+ S Neg => I
+ | S Pos => do_ctype_comp Leq xs C11 C21
+ | V x => do_ctype_comp Leq (x :: xs) C11 C21)
+ else
+ SOME accum)
+ |> do_ctype_comp Leq xs C12 C22
+ | do_ctype_comp cmp xs (C1 as CPair (C11, C12)) (C2 as CPair (C21, C22))
+ accum =
+ (accum |> fold (uncurry (do_ctype_comp cmp xs)) [(C11, C21), (C12, C22)]
+ handle Library.UnequalLengths =>
+ raise CTYPE ("NitpickMono.do_ctype_comp", [C1, C2]))
+ | do_ctype_comp cmp xs (CType _) (CType _) accum =
+ accum (* no need to compare them thanks to the cache *)
+ | do_ctype_comp _ _ C1 C2 _ =
+ raise CTYPE ("NitpickMono.do_ctype_comp", [C1, C2])
+
+(* comp_op -> ctype -> ctype -> constraint_set -> constraint_set *)
+fun add_ctype_comp _ _ _ UnsolvableCSet = UnsolvableCSet
+ | add_ctype_comp cmp C1 C2 (CSet (lits, comps, sexps)) =
+ (print_g ("*** Add " ^ string_for_ctype C1 ^ " " ^ string_for_comp_op cmp ^
+ " " ^ string_for_ctype C2);
+ case do_ctype_comp cmp [] C1 C2 (SOME (lits, comps)) of
+ NONE => (print_g "**** Unsolvable"; UnsolvableCSet)
+ | SOME (lits, comps) => CSet (lits, comps, sexps))
+
+(* ctype -> ctype -> constraint_set -> constraint_set *)
+val add_ctypes_equal = add_ctype_comp Eq
+val add_is_sub_ctype = add_ctype_comp Leq
+
+(* sign -> sign_expr -> ctype -> (literal list * sign_expr list) option
+ -> (literal list * sign_expr list) option *)
+fun do_notin_ctype_fv _ _ _ NONE = NONE
+ | do_notin_ctype_fv Neg _ CAlpha accum = accum
+ | do_notin_ctype_fv Pos [] CAlpha _ = NONE
+ | do_notin_ctype_fv Pos [(x, sn)] CAlpha (SOME (lits, sexps)) =
+ SOME lits |> do_literal (x, sn) |> Option.map (rpair sexps)
+ | do_notin_ctype_fv Pos sexp CAlpha (SOME (lits, sexps)) =
+ SOME (lits, insert (op =) sexp sexps)
+ | do_notin_ctype_fv sn sexp (CFun (C1, S sn', C2)) accum =
+ accum |> (if sn' = Pos andalso sn = Pos then do_notin_ctype_fv Pos sexp C1
+ else I)
+ |> (if sn' = Neg orelse sn = Pos then do_notin_ctype_fv Neg sexp C1
+ else I)
+ |> do_notin_ctype_fv sn sexp C2
+ | do_notin_ctype_fv Pos sexp (CFun (C1, V x, C2)) accum =
+ accum |> (case do_literal (x, Neg) (SOME sexp) of
+ NONE => I
+ | SOME sexp' => do_notin_ctype_fv Pos sexp' C1)
+ |> do_notin_ctype_fv Neg sexp C1
+ |> do_notin_ctype_fv Pos sexp C2
+ | do_notin_ctype_fv Neg sexp (CFun (C1, V x, C2)) accum =
+ accum |> (case do_literal (x, Pos) (SOME sexp) of
+ NONE => I
+ | SOME sexp' => do_notin_ctype_fv Pos sexp' C1)
+ |> do_notin_ctype_fv Neg sexp C2
+ | do_notin_ctype_fv sn sexp (CPair (C1, C2)) accum =
+ accum |> fold (do_notin_ctype_fv sn sexp) [C1, C2]
+ | do_notin_ctype_fv sn sexp (CType (_, Cs)) accum =
+ accum |> fold (do_notin_ctype_fv sn sexp) Cs
+ | do_notin_ctype_fv _ _ C _ =
+ raise CTYPE ("NitpickMono.do_notin_ctype_fv", [C])
+
+(* sign -> ctype -> constraint_set -> constraint_set *)
+fun add_notin_ctype_fv _ _ UnsolvableCSet = UnsolvableCSet
+ | add_notin_ctype_fv sn C (CSet (lits, comps, sexps)) =
+ (print_g ("*** Add " ^ string_for_ctype C ^ " is right-" ^
+ (case sn of Neg => "unique" | Pos => "total") ^ ".");
+ case do_notin_ctype_fv sn [] C (SOME (lits, sexps)) of
+ NONE => (print_g "**** Unsolvable"; UnsolvableCSet)
+ | SOME (lits, sexps) => CSet (lits, comps, sexps))
+
+(* ctype -> constraint_set -> constraint_set *)
+val add_ctype_is_right_unique = add_notin_ctype_fv Neg
+val add_ctype_is_right_total = add_notin_ctype_fv Pos
+
+(* constraint_set -> constraint_set -> constraint_set *)
+fun unite (CSet (lits1, comps1, sexps1)) (CSet (lits2, comps2, sexps2)) =
+ (case SOME lits1 |> fold do_literal lits2 of
+ NONE => (print_g "**** Unsolvable"; UnsolvableCSet)
+ | SOME lits => CSet (lits, comps1 @ comps2, sexps1 @ sexps2))
+ | unite _ _ = UnsolvableCSet
+
+(* sign -> bool *)
+fun bool_from_sign Pos = false
+ | bool_from_sign Neg = true
+(* bool -> sign *)
+fun sign_from_bool false = Pos
+ | sign_from_bool true = Neg
+
+(* literal -> PropLogic.prop_formula *)
+fun prop_for_literal (x, sn) =
+ (not (bool_from_sign sn) ? PropLogic.Not) (PropLogic.BoolVar x)
+(* sign_atom -> PropLogic.prop_formula *)
+fun prop_for_sign_atom_eq (S sn', sn) =
+ if sn = sn' then PropLogic.True else PropLogic.False
+ | prop_for_sign_atom_eq (V x, sn) = prop_for_literal (x, sn)
+(* sign_expr -> PropLogic.prop_formula *)
+fun prop_for_sign_expr xs = PropLogic.exists (map prop_for_literal xs)
+(* var list -> sign -> PropLogic.prop_formula *)
+fun prop_for_exists_eq xs sn =
+ PropLogic.exists (map (fn x => prop_for_literal (x, sn)) xs)
+(* comp -> PropLogic.prop_formula *)
+fun prop_for_comp (a1, a2, Eq, []) =
+ PropLogic.SAnd (prop_for_comp (a1, a2, Leq, []),
+ prop_for_comp (a2, a1, Leq, []))
+ | prop_for_comp (a1, a2, Leq, []) =
+ PropLogic.SOr (prop_for_sign_atom_eq (a1, Pos),
+ prop_for_sign_atom_eq (a2, Neg))
+ | prop_for_comp (a1, a2, cmp, xs) =
+ PropLogic.SOr (prop_for_exists_eq xs Neg, prop_for_comp (a1, a2, cmp, []))
+
+(* var -> (int -> bool option) -> literal list -> literal list *)
+fun literals_from_assignments max_var asgns lits =
+ fold (fn x => fn accum =>
+ if AList.defined (op =) lits x then
+ accum
+ else case asgns x of
+ SOME b => (x, sign_from_bool b) :: accum
+ | NONE => accum) (max_var downto 1) lits
+
+(* literal list -> sign_atom -> sign option *)
+fun lookup_sign_atom _ (S sn) = SOME sn
+ | lookup_sign_atom lit (V x) = AList.lookup (op =) lit x
+
+(* comp -> string *)
+fun string_for_comp (a1, a2, cmp, xs) =
+ string_for_sign_atom a1 ^ " " ^ string_for_comp_op cmp ^
+ subscript_string_for_vars " \<and> " xs ^ " " ^ string_for_sign_atom a2
+
+(* literal list -> comp list -> sign_expr list -> unit *)
+fun print_problem lits comps sexps =
+ print_g ("*** Problem:\n" ^ cat_lines (map string_for_literal lits @
+ map string_for_comp comps @
+ map string_for_sign_expr sexps))
+
+(* literal list -> unit *)
+fun print_solution lits =
+ let val (pos, neg) = List.partition (equal Pos o snd) lits in
+ print_g ("*** Solution:\n" ^
+ "+: " ^ commas (map (string_for_var o fst) pos) ^ "\n" ^
+ "-: " ^ commas (map (string_for_var o fst) neg))
+ end
+
+(* var -> constraint_set -> literal list list option *)
+fun solve _ UnsolvableCSet = (print_g "*** Problem: Unsolvable"; NONE)
+ | solve max_var (CSet (lits, comps, sexps)) =
+ let
+ val _ = print_problem lits comps sexps
+ val prop = PropLogic.all (map prop_for_literal lits @
+ map prop_for_comp comps @
+ map prop_for_sign_expr sexps)
+ in
+ case silence (SatSolver.invoke_solver "dpll") prop of
+ SatSolver.SATISFIABLE asgns =>
+ SOME (literals_from_assignments max_var asgns lits
+ |> tap print_solution)
+ | _ => NONE
+ end
+
+(* var -> constraint_set -> bool *)
+val is_solvable = is_some oo solve
+
+type ctype_schema = ctype * constraint_set
+type ctype_context =
+ {bounds: ctype list,
+ frees: (styp * ctype) list,
+ consts: (styp * ctype_schema) list}
+
+type accumulator = ctype_context * constraint_set
+
+val initial_gamma = {bounds = [], frees = [], consts = []}
+val unsolvable_accum = (initial_gamma, UnsolvableCSet)
+
+(* ctype -> ctype_context -> ctype_context *)
+fun push_bound C {bounds, frees, consts} =
+ {bounds = C :: bounds, frees = frees, consts = consts}
+(* ctype_context -> ctype_context *)
+fun pop_bound {bounds, frees, consts} =
+ {bounds = tl bounds, frees = frees, consts = consts}
+ handle List.Empty => initial_gamma
+
+(* cdata -> term -> accumulator -> ctype * accumulator *)
+fun consider_term (cdata as {ext_ctxt as {ctxt, thy, def_table, ...}, alpha_T,
+ max_fresh, ...}) =
+ let
+ (* typ -> ctype *)
+ val ctype_for = fresh_ctype_for_type cdata
+ (* ctype -> ctype *)
+ fun pos_set_ctype_for_dom C =
+ CFun (C, S (if exists_alpha_sub_ctype C then Pos else Neg), bool_C)
+ (* typ -> accumulator -> ctype * accumulator *)
+ fun do_quantifier T (gamma, cset) =
+ let
+ val abs_C = ctype_for (domain_type (domain_type T))
+ val body_C = ctype_for (range_type T)
+ in
+ (CFun (CFun (abs_C, S Neg, body_C), S Neg, body_C),
+ (gamma, cset |> add_ctype_is_right_total abs_C))
+ end
+ fun do_equals T (gamma, cset) =
+ let val C = ctype_for (domain_type T) in
+ (CFun (C, S Neg, CFun (C, S Neg, ctype_for (nth_range_type 2 T))),
+ (gamma, cset |> add_ctype_is_right_unique C))
+ end
+ fun do_robust_set_operation T (gamma, cset) =
+ let
+ val set_T = domain_type T
+ val C1 = ctype_for set_T
+ val C2 = ctype_for set_T
+ val C3 = ctype_for set_T
+ in
+ (CFun (C1, S Neg, CFun (C2, S Neg, C3)),
+ (gamma, cset |> add_is_sub_ctype C1 C3 |> add_is_sub_ctype C2 C3))
+ end
+ fun do_fragile_set_operation T (gamma, cset) =
+ let
+ val set_T = domain_type T
+ val set_C = ctype_for set_T
+ (* typ -> ctype *)
+ fun custom_ctype_for (T as Type ("fun", [T1, T2])) =
+ if T = set_T then set_C
+ else CFun (custom_ctype_for T1, S Neg, custom_ctype_for T2)
+ | custom_ctype_for T = ctype_for T
+ in
+ (custom_ctype_for T, (gamma, cset |> add_ctype_is_right_unique set_C))
+ end
+ (* typ -> accumulator -> ctype * accumulator *)
+ fun do_pair_constr T accum =
+ case ctype_for (nth_range_type 2 T) of
+ C as CPair (a_C, b_C) =>
+ (CFun (a_C, S Neg, CFun (b_C, S Neg, C)), accum)
+ | C => raise CTYPE ("NitpickMono.consider_term.do_pair_constr", [C])
+ (* int -> typ -> accumulator -> ctype * accumulator *)
+ fun do_nth_pair_sel n T =
+ case ctype_for (domain_type T) of
+ C as CPair (a_C, b_C) =>
+ pair (CFun (C, S Neg, if n = 0 then a_C else b_C))
+ | C => raise CTYPE ("NitpickMono.consider_term.do_nth_pair_sel", [C])
+ val unsolvable = (CType ("unsolvable", []), unsolvable_accum)
+ (* typ -> term -> accumulator -> ctype * accumulator *)
+ fun do_bounded_quantifier abs_T bound_t body_t accum =
+ let
+ val abs_C = ctype_for abs_T
+ val (bound_C, accum) = accum |>> push_bound abs_C |> do_term bound_t
+ val expected_bound_C = pos_set_ctype_for_dom abs_C
+ in
+ accum ||> add_ctypes_equal expected_bound_C bound_C |> do_term body_t
+ ||> apfst pop_bound
+ end
+ (* term -> accumulator -> ctype * accumulator *)
+ and do_term _ (_, UnsolvableCSet) = unsolvable
+ | do_term t (accum as (gamma as {bounds, frees, consts}, cset)) =
+ (case t of
+ Const (x as (s, T)) =>
+ (case AList.lookup (op =) consts x of
+ SOME (C, cset') => (C, (gamma, cset |> unite cset'))
+ | NONE =>
+ if not (could_exist_alpha_subtype alpha_T T) then
+ (ctype_for T, accum)
+ else case s of
+ @{const_name all} => do_quantifier T accum
+ | @{const_name "=="} => do_equals T accum
+ | @{const_name All} => do_quantifier T accum
+ | @{const_name Ex} => do_quantifier T accum
+ | @{const_name "op ="} => do_equals T accum
+ | @{const_name The} => (print_g "*** The"; unsolvable)
+ | @{const_name Eps} => (print_g "*** Eps"; unsolvable)
+ | @{const_name If} =>
+ do_robust_set_operation (range_type T) accum
+ |>> curry3 CFun bool_C (S Neg)
+ | @{const_name Pair} => do_pair_constr T accum
+ | @{const_name fst} => do_nth_pair_sel 0 T accum
+ | @{const_name snd} => do_nth_pair_sel 1 T accum
+ | @{const_name Id} =>
+ (CFun (ctype_for (domain_type T), S Neg, bool_C), accum)
+ | @{const_name insert} =>
+ let
+ val set_T = domain_type (range_type T)
+ val C1 = ctype_for (domain_type set_T)
+ val C1' = pos_set_ctype_for_dom C1
+ val C2 = ctype_for set_T
+ val C3 = ctype_for set_T
+ in
+ (CFun (C1, S Neg, CFun (C2, S Neg, C3)),
+ (gamma, cset |> add_ctype_is_right_unique C1
+ |> add_is_sub_ctype C1' C3
+ |> add_is_sub_ctype C2 C3))
+ end
+ | @{const_name converse} =>
+ let
+ val x = Unsynchronized.inc max_fresh
+ (* typ -> ctype *)
+ fun ctype_for_set T =
+ CFun (ctype_for (domain_type T), V x, bool_C)
+ val ab_set_C = domain_type T |> ctype_for_set
+ val ba_set_C = range_type T |> ctype_for_set
+ in (CFun (ab_set_C, S Neg, ba_set_C), accum) end
+ | @{const_name trancl} => do_fragile_set_operation T accum
+ | @{const_name rtrancl} => (print_g "*** rtrancl"; unsolvable)
+ | @{const_name lower_semilattice_fun_inst.inf_fun} =>
+ do_robust_set_operation T accum
+ | @{const_name upper_semilattice_fun_inst.sup_fun} =>
+ do_robust_set_operation T accum
+ | @{const_name finite} =>
+ let val C1 = ctype_for (domain_type (domain_type T)) in
+ (CFun (pos_set_ctype_for_dom C1, S Neg, bool_C), accum)
+ end
+ | @{const_name rel_comp} =>
+ let
+ val x = Unsynchronized.inc max_fresh
+ (* typ -> ctype *)
+ fun ctype_for_set T =
+ CFun (ctype_for (domain_type T), V x, bool_C)
+ val bc_set_C = domain_type T |> ctype_for_set
+ val ab_set_C = domain_type (range_type T) |> ctype_for_set
+ val ac_set_C = nth_range_type 2 T |> ctype_for_set
+ in
+ (CFun (bc_set_C, S Neg, CFun (ab_set_C, S Neg, ac_set_C)),
+ accum)
+ end
+ | @{const_name image} =>
+ let
+ val a_C = ctype_for (domain_type (domain_type T))
+ val b_C = ctype_for (range_type (domain_type T))
+ in
+ (CFun (CFun (a_C, S Neg, b_C), S Neg,
+ CFun (pos_set_ctype_for_dom a_C, S Neg,
+ pos_set_ctype_for_dom b_C)), accum)
+ end
+ | @{const_name Sigma} =>
+ let
+ val x = Unsynchronized.inc max_fresh
+ (* typ -> ctype *)
+ fun ctype_for_set T =
+ CFun (ctype_for (domain_type T), V x, bool_C)
+ val a_set_T = domain_type T
+ val a_C = ctype_for (domain_type a_set_T)
+ val b_set_C = ctype_for_set (range_type (domain_type
+ (range_type T)))
+ val a_set_C = ctype_for_set a_set_T
+ val a_to_b_set_C = CFun (a_C, S Neg, b_set_C)
+ val ab_set_C = ctype_for_set (nth_range_type 2 T)
+ in
+ (CFun (a_set_C, S Neg, CFun (a_to_b_set_C, S Neg, ab_set_C)),
+ accum)
+ end
+ | @{const_name minus_fun_inst.minus_fun} =>
+ let
+ val set_T = domain_type T
+ val left_set_C = ctype_for set_T
+ val right_set_C = ctype_for set_T
+ in
+ (CFun (left_set_C, S Neg,
+ CFun (right_set_C, S Neg, left_set_C)),
+ (gamma, cset |> add_ctype_is_right_unique right_set_C
+ (* FIXME: |> add_is_sub_ctype right_set_C left_set_C *)))
+ end
+ | @{const_name ord_fun_inst.less_eq_fun} =>
+ do_fragile_set_operation T accum
+ | @{const_name Tha} =>
+ let
+ val a_C = ctype_for (domain_type (domain_type T))
+ val a_set_C = pos_set_ctype_for_dom a_C
+ in (CFun (a_set_C, S Neg, a_C), accum) end
+ | @{const_name FunBox} =>
+ let val dom_C = ctype_for (domain_type T) in
+ (CFun (dom_C, S Neg, dom_C), accum)
+ end
+ | _ => if is_sel s then
+ if constr_name_for_sel_like s = @{const_name FunBox} then
+ let val dom_C = ctype_for (domain_type T) in
+ (CFun (dom_C, S Neg, dom_C), accum)
+ end
+ else
+ (ctype_for_sel cdata x, accum)
+ else if is_constr thy x then
+ (ctype_for_constr cdata x, accum)
+ else if is_built_in_const true x then
+ case def_of_const thy def_table x of
+ SOME t' => do_term t' accum
+ | NONE => (print_g ("*** built-in " ^ s); unsolvable)
+ else
+ (ctype_for T, accum))
+ | Free (x as (_, T)) =>
+ (case AList.lookup (op =) frees x of
+ SOME C => (C, accum)
+ | NONE =>
+ let val C = ctype_for T in
+ (C, ({bounds = bounds, frees = (x, C) :: frees,
+ consts = consts}, cset))
+ end)
+ | Var _ => (print_g "*** Var"; unsolvable)
+ | Bound j => (nth bounds j, accum)
+ | Abs (_, T, @{const False}) => (ctype_for (T --> bool_T), accum)
+ | Abs (s, T, t') =>
+ let
+ val C = ctype_for T
+ val (C', accum) = do_term t' (accum |>> push_bound C)
+ in (CFun (C, S Neg, C'), accum |>> pop_bound) end
+ | Const (@{const_name All}, _)
+ $ Abs (_, T', @{const "op -->"} $ (t1 $ Bound 0) $ t2) =>
+ do_bounded_quantifier T' t1 t2 accum
+ | Const (@{const_name Ex}, _)
+ $ Abs (_, T', @{const "op &"} $ (t1 $ Bound 0) $ t2) =>
+ do_bounded_quantifier T' t1 t2 accum
+ | Const (@{const_name Let}, _) $ t1 $ t2 =>
+ do_term (betapply (t2, t1)) accum
+ | t1 $ t2 =>
+ let
+ val (C1, accum) = do_term t1 accum
+ val (C2, accum) = do_term t2 accum
+ in
+ case accum of
+ (_, UnsolvableCSet) => unsolvable
+ | _ => case C1 of
+ CFun (C11, _, C12) =>
+ (C12, accum ||> add_is_sub_ctype C2 C11)
+ | _ => raise CTYPE ("NitpickMono.consider_term.do_term \
+ \(op $)", [C1])
+ end)
+ |> tap (fn (C, _) =>
+ print_g (" \<Gamma> \<turnstile> " ^
+ Syntax.string_of_term ctxt t ^ " : " ^
+ string_for_ctype C))
+ in do_term end
+
+(* cdata -> sign -> term -> accumulator -> accumulator *)
+fun consider_general_formula (cdata as {ext_ctxt as {ctxt, ...}, ...}) =
+ let
+ (* typ -> ctype *)
+ val ctype_for = fresh_ctype_for_type cdata
+ (* term -> accumulator -> ctype * accumulator *)
+ val do_term = consider_term cdata
+ (* term -> accumulator -> accumulator *)
+ val do_boolean_term = snd oo do_term
+ (* sign -> term -> accumulator -> accumulator *)
+ fun do_formula _ _ (_, UnsolvableCSet) = unsolvable_accum
+ | do_formula sn t (accum as (gamma as {bounds, frees, consts}, cset)) =
+ let
+ (* term -> accumulator -> accumulator *)
+ val do_co_formula = do_formula sn
+ val do_contra_formula = do_formula (negate sn)
+ (* string -> typ -> term -> accumulator *)
+ fun do_quantifier quant_s abs_T body_t =
+ let
+ val abs_C = ctype_for abs_T
+ val side_cond = ((sn = Neg) = (quant_s = @{const_name Ex}))
+ val cset = cset |> side_cond ? add_ctype_is_right_total abs_C
+ in
+ (gamma |> push_bound abs_C, cset) |> do_co_formula body_t
+ |>> pop_bound
+ end
+ (* typ -> term -> accumulator *)
+ fun do_bounded_quantifier abs_T body_t =
+ accum |>> push_bound (ctype_for abs_T) |> do_co_formula body_t
+ |>> pop_bound
+ (* term -> term -> accumulator *)
+ fun do_equals t1 t2 =
+ case sn of
+ Pos => do_boolean_term t accum
+ | Neg => let
+ val (C1, accum) = do_term t1 accum
+ val (C2, accum) = do_term t2 accum
+ in accum (* FIXME: ||> add_ctypes_equal C1 C2 *) end
+ in
+ case t of
+ Const (s0 as @{const_name all}, _) $ Abs (_, T1, t1) =>
+ do_quantifier s0 T1 t1
+ | Const (@{const_name "=="}, _) $ t1 $ t2 => do_equals t1 t2
+ | @{const "==>"} $ t1 $ t2 =>
+ accum |> do_contra_formula t1 |> do_co_formula t2
+ | @{const Trueprop} $ t1 => do_co_formula t1 accum
+ | @{const Not} $ t1 => do_contra_formula t1 accum
+ | Const (@{const_name All}, _)
+ $ Abs (_, T1, t1 as @{const "op -->"} $ (_ $ Bound 0) $ _) =>
+ do_bounded_quantifier T1 t1
+ | Const (s0 as @{const_name All}, _) $ Abs (_, T1, t1) =>
+ do_quantifier s0 T1 t1
+ | Const (@{const_name Ex}, _)
+ $ Abs (_, T1, t1 as @{const "op &"} $ (_ $ Bound 0) $ _) =>
+ do_bounded_quantifier T1 t1
+ | Const (s0 as @{const_name Ex}, _) $ Abs (_, T1, t1) =>
+ do_quantifier s0 T1 t1
+ | Const (@{const_name "op ="}, _) $ t1 $ t2 => do_equals t1 t2
+ | @{const "op &"} $ t1 $ t2 =>
+ accum |> do_co_formula t1 |> do_co_formula t2
+ | @{const "op |"} $ t1 $ t2 =>
+ accum |> do_co_formula t1 |> do_co_formula t2
+ | @{const "op -->"} $ t1 $ t2 =>
+ accum |> do_contra_formula t1 |> do_co_formula t2
+ | Const (@{const_name If}, _) $ t1 $ t2 $ t3 =>
+ accum |> do_boolean_term t1 |> do_co_formula t2 |> do_co_formula t3
+ | Const (@{const_name Let}, _) $ t1 $ t2 =>
+ do_co_formula (betapply (t2, t1)) accum
+ | _ => do_boolean_term t accum
+ end
+ |> tap (fn _ => print_g ("\<Gamma> \<turnstile> " ^
+ Syntax.string_of_term ctxt t ^
+ " : o\<^sup>" ^ string_for_sign sn))
+ in do_formula end
+
+(* The harmless axiom optimization below is somewhat too aggressive in the face
+ of (rather peculiar) user-defined axioms. *)
+val harmless_consts =
+ [@{const_name ord_class.less}, @{const_name ord_class.less_eq}]
+val bounteous_consts = [@{const_name bisim}]
+
+(* term -> bool *)
+fun is_harmless_axiom t =
+ Term.add_consts t [] |> filter_out (is_built_in_const true)
+ |> (forall (member (op =) harmless_consts o original_name o fst)
+ orf exists (member (op =) bounteous_consts o fst))
+
+(* cdata -> sign -> term -> accumulator -> accumulator *)
+fun consider_nondefinitional_axiom cdata sn t =
+ not (is_harmless_axiom t) ? consider_general_formula cdata sn t
+
+(* cdata -> term -> accumulator -> accumulator *)
+fun consider_definitional_axiom (cdata as {ext_ctxt as {thy, ...}, ...}) t =
+ if not (is_constr_pattern_formula thy t) then
+ consider_nondefinitional_axiom cdata Pos t
+ else if is_harmless_axiom t then
+ I
+ else
+ let
+ (* term -> accumulator -> accumulator *)
+ val do_term = consider_term cdata
+ (* typ -> term -> accumulator -> accumulator *)
+ fun do_all abs_T body_t accum =
+ let val abs_C = fresh_ctype_for_type cdata abs_T in
+ accum |>> push_bound abs_C |> do_formula body_t |>> pop_bound
+ end
+ (* term -> term -> accumulator -> accumulator *)
+ and do_implies t1 t2 = do_term t1 #> snd #> do_formula t2
+ and do_equals t1 t2 accum =
+ let
+ val (C1, accum) = do_term t1 accum
+ val (C2, accum) = do_term t2 accum
+ in accum ||> add_ctypes_equal C1 C2 end
+ (* term -> accumulator -> accumulator *)
+ and do_formula _ (_, UnsolvableCSet) = unsolvable_accum
+ | do_formula t accum =
+ case t of
+ Const (@{const_name all}, _) $ Abs (_, T1, t1) => do_all T1 t1 accum
+ | @{const Trueprop} $ t1 => do_formula t1 accum
+ | Const (@{const_name "=="}, _) $ t1 $ t2 => do_equals t1 t2 accum
+ | @{const "==>"} $ t1 $ t2 => do_implies t1 t2 accum
+ | @{const Pure.conjunction} $ t1 $ t2 =>
+ accum |> do_formula t1 |> do_formula t2
+ | Const (@{const_name All}, _) $ Abs (_, T1, t1) => do_all T1 t1 accum
+ | Const (@{const_name "op ="}, _) $ t1 $ t2 => do_equals t1 t2 accum
+ | @{const "op &"} $ t1 $ t2 => accum |> do_formula t1 |> do_formula t2
+ | @{const "op -->"} $ t1 $ t2 => do_implies t1 t2 accum
+ | _ => raise TERM ("NitpickMono.consider_definitional_axiom.\
+ \do_formula", [t])
+ in do_formula t end
+
+(* Proof.context -> literal list -> term -> ctype -> string *)
+fun string_for_ctype_of_term ctxt lits t C =
+ Syntax.string_of_term ctxt t ^ " : " ^
+ string_for_ctype (instantiate_ctype lits C)
+
+(* theory -> literal list -> ctype_context -> unit *)
+fun print_ctype_context ctxt lits ({frees, consts, ...} : ctype_context) =
+ map (fn (x, C) => string_for_ctype_of_term ctxt lits (Free x) C) frees @
+ map (fn (x, (C, _)) => string_for_ctype_of_term ctxt lits (Const x) C) consts
+ |> cat_lines |> print_g
+
+(* extended_context -> typ -> term list -> term list -> term -> bool *)
+fun formulas_monotonic (ext_ctxt as {ctxt, ...}) alpha_T def_ts nondef_ts
+ core_t =
+ let
+ val _ = print_g ("****** " ^ string_for_ctype CAlpha ^ " is " ^
+ Syntax.string_of_typ ctxt alpha_T)
+ val cdata as {max_fresh, ...} = initial_cdata ext_ctxt alpha_T
+ val (gamma, cset) =
+ (initial_gamma, slack)
+ |> fold (consider_definitional_axiom cdata) def_ts
+ |> fold (consider_nondefinitional_axiom cdata Pos) nondef_ts
+ |> consider_general_formula cdata Pos core_t
+ in
+ case solve (!max_fresh) cset of
+ SOME lits => (print_ctype_context ctxt lits gamma; true)
+ | _ => false
+ end
+ handle CTYPE (loc, Cs) => raise BAD (loc, commas (map string_for_ctype Cs))
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_nut.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,1363 @@
+(* Title: HOL/Nitpick/Tools/nitpick_nut.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Nitpick underlying terms (nuts).
+*)
+
+signature NITPICK_NUT =
+sig
+ type special_fun = NitpickHOL.special_fun
+ type extended_context = NitpickHOL.extended_context
+ type scope = NitpickScope.scope
+ type name_pool = NitpickPeephole.name_pool
+ type rep = NitpickRep.rep
+
+ datatype cst =
+ Unity |
+ False |
+ True |
+ Iden |
+ Num of int |
+ Unknown |
+ Unrep |
+ Suc |
+ Add |
+ Subtract |
+ Multiply |
+ Divide |
+ Modulo |
+ Gcd |
+ Lcm |
+ Fracs |
+ NormFrac |
+ NatToInt |
+ IntToNat
+
+ datatype op1 =
+ Not |
+ Finite |
+ Converse |
+ Closure |
+ SingletonSet |
+ Tha |
+ First |
+ Second |
+ Cast
+
+ datatype op2 =
+ All |
+ Exist |
+ Or |
+ And |
+ Less |
+ Subset |
+ DefEq |
+ Eq |
+ The |
+ Eps |
+ Triad |
+ Union |
+ SetDifference |
+ Intersect |
+ Composition |
+ Product |
+ Image |
+ Apply |
+ Lambda
+
+ datatype op3 =
+ Let |
+ If
+
+ datatype nut =
+ Cst of cst * typ * rep |
+ Op1 of op1 * typ * rep * nut |
+ Op2 of op2 * typ * rep * nut * nut |
+ Op3 of op3 * typ * rep * nut * nut * nut |
+ Tuple of typ * rep * nut list |
+ Construct of nut list * typ * rep * nut list |
+ BoundName of int * typ * rep * string |
+ FreeName of string * typ * rep |
+ ConstName of string * typ * rep |
+ BoundRel of Kodkod.n_ary_index * typ * rep * string |
+ FreeRel of Kodkod.n_ary_index * typ * rep * string |
+ RelReg of int * typ * rep |
+ FormulaReg of int * typ * rep
+
+ structure NameTable : TABLE
+
+ exception NUT of string * nut list
+
+ val string_for_nut : Proof.context -> nut -> string
+ val inline_nut : nut -> bool
+ val type_of : nut -> typ
+ val rep_of : nut -> rep
+ val nickname_of : nut -> string
+ val is_skolem_name : nut -> bool
+ val is_eval_name : nut -> bool
+ val is_Cst : cst -> nut -> bool
+ val fold_nut : (nut -> 'a -> 'a) -> nut -> 'a -> 'a
+ val map_nut : (nut -> nut) -> nut -> nut
+ val untuple : (nut -> 'a) -> nut -> 'a list
+ val add_free_and_const_names :
+ nut -> nut list * nut list -> nut list * nut list
+ val name_ord : (nut * nut) -> order
+ val the_name : 'a NameTable.table -> nut -> 'a
+ val the_rel : nut NameTable.table -> nut -> Kodkod.n_ary_index
+ val nut_from_term : theory -> bool -> special_fun list -> op2 -> term -> nut
+ val choose_reps_for_free_vars :
+ scope -> nut list -> rep NameTable.table -> nut list * rep NameTable.table
+ val choose_reps_for_consts :
+ scope -> bool -> nut list -> rep NameTable.table
+ -> nut list * rep NameTable.table
+ val choose_reps_for_all_sels :
+ scope -> rep NameTable.table -> nut list * rep NameTable.table
+ val choose_reps_in_nut :
+ scope -> bool -> rep NameTable.table -> bool -> nut -> nut
+ val rename_free_vars :
+ nut list -> name_pool -> nut NameTable.table
+ -> nut list * name_pool * nut NameTable.table
+ val rename_vars_in_nut : name_pool -> nut NameTable.table -> nut -> nut
+end;
+
+structure NitpickNut : NITPICK_NUT =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickScope
+open NitpickPeephole
+open NitpickRep
+
+datatype cst =
+ Unity |
+ False |
+ True |
+ Iden |
+ Num of int |
+ Unknown |
+ Unrep |
+ Suc |
+ Add |
+ Subtract |
+ Multiply |
+ Divide |
+ Modulo |
+ Gcd |
+ Lcm |
+ Fracs |
+ NormFrac |
+ NatToInt |
+ IntToNat
+
+datatype op1 =
+ Not |
+ Finite |
+ Converse |
+ Closure |
+ SingletonSet |
+ Tha |
+ First |
+ Second |
+ Cast
+
+datatype op2 =
+ All |
+ Exist |
+ Or |
+ And |
+ Less |
+ Subset |
+ DefEq |
+ Eq |
+ The |
+ Eps |
+ Triad |
+ Union |
+ SetDifference |
+ Intersect |
+ Composition |
+ Product |
+ Image |
+ Apply |
+ Lambda
+
+datatype op3 =
+ Let |
+ If
+
+datatype nut =
+ Cst of cst * typ * rep |
+ Op1 of op1 * typ * rep * nut |
+ Op2 of op2 * typ * rep * nut * nut |
+ Op3 of op3 * typ * rep * nut * nut * nut |
+ Tuple of typ * rep * nut list |
+ Construct of nut list * typ * rep * nut list |
+ BoundName of int * typ * rep * string |
+ FreeName of string * typ * rep |
+ ConstName of string * typ * rep |
+ BoundRel of Kodkod.n_ary_index * typ * rep * string |
+ FreeRel of Kodkod.n_ary_index * typ * rep * string |
+ RelReg of int * typ * rep |
+ FormulaReg of int * typ * rep
+
+exception NUT of string * nut list
+
+(* cst -> string *)
+fun string_for_cst Unity = "Unity"
+ | string_for_cst False = "False"
+ | string_for_cst True = "True"
+ | string_for_cst Iden = "Iden"
+ | string_for_cst (Num j) = "Num " ^ signed_string_of_int j
+ | string_for_cst Unknown = "Unknown"
+ | string_for_cst Unrep = "Unrep"
+ | string_for_cst Suc = "Suc"
+ | string_for_cst Add = "Add"
+ | string_for_cst Subtract = "Subtract"
+ | string_for_cst Multiply = "Multiply"
+ | string_for_cst Divide = "Divide"
+ | string_for_cst Modulo = "Modulo"
+ | string_for_cst Gcd = "Gcd"
+ | string_for_cst Lcm = "Lcm"
+ | string_for_cst Fracs = "Fracs"
+ | string_for_cst NormFrac = "NormFrac"
+ | string_for_cst NatToInt = "NatToInt"
+ | string_for_cst IntToNat = "IntToNat"
+
+(* op1 -> string *)
+fun string_for_op1 Not = "Not"
+ | string_for_op1 Finite = "Finite"
+ | string_for_op1 Converse = "Converse"
+ | string_for_op1 Closure = "Closure"
+ | string_for_op1 SingletonSet = "SingletonSet"
+ | string_for_op1 Tha = "Tha"
+ | string_for_op1 First = "First"
+ | string_for_op1 Second = "Second"
+ | string_for_op1 Cast = "Cast"
+
+(* op2 -> string *)
+fun string_for_op2 All = "All"
+ | string_for_op2 Exist = "Exist"
+ | string_for_op2 Or = "Or"
+ | string_for_op2 And = "And"
+ | string_for_op2 Less = "Less"
+ | string_for_op2 Subset = "Subset"
+ | string_for_op2 DefEq = "DefEq"
+ | string_for_op2 Eq = "Eq"
+ | string_for_op2 The = "The"
+ | string_for_op2 Eps = "Eps"
+ | string_for_op2 Triad = "Triad"
+ | string_for_op2 Union = "Union"
+ | string_for_op2 SetDifference = "SetDifference"
+ | string_for_op2 Intersect = "Intersect"
+ | string_for_op2 Composition = "Composition"
+ | string_for_op2 Product = "Product"
+ | string_for_op2 Image = "Image"
+ | string_for_op2 Apply = "Apply"
+ | string_for_op2 Lambda = "Lambda"
+
+(* op3 -> string *)
+fun string_for_op3 Let = "Let"
+ | string_for_op3 If = "If"
+
+(* int -> Proof.context -> nut -> string *)
+fun basic_string_for_nut indent ctxt u =
+ let
+ (* nut -> string *)
+ val sub = basic_string_for_nut (indent + 1) ctxt
+ in
+ (if indent = 0 then "" else "\n" ^ implode (replicate (2 * indent) " ")) ^
+ "(" ^
+ (case u of
+ Cst (c, T, R) =>
+ "Cst " ^ string_for_cst c ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R
+ | Op1 (oper, T, R, u1) =>
+ "Op1 " ^ string_for_op1 oper ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R ^ " " ^ sub u1
+ | Op2 (oper, T, R, u1, u2) =>
+ "Op2 " ^ string_for_op2 oper ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R ^ " " ^ sub u1 ^ " " ^ sub u2
+ | Op3 (oper, T, R, u1, u2, u3) =>
+ "Op3 " ^ string_for_op3 oper ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R ^ " " ^ sub u1 ^ " " ^ sub u2 ^ " " ^ sub u3
+ | Tuple (T, R, us) =>
+ "Tuple " ^ Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R ^
+ implode (map sub us)
+ | Construct (us', T, R, us) =>
+ "Construct " ^ implode (map sub us') ^ Syntax.string_of_typ ctxt T ^
+ " " ^ string_for_rep R ^ " " ^ implode (map sub us)
+ | BoundName (j, T, R, nick) =>
+ "BoundName " ^ signed_string_of_int j ^ " " ^
+ Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R ^ " " ^ nick
+ | FreeName (s, T, R) =>
+ "FreeName " ^ s ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R
+ | ConstName (s, T, R) =>
+ "ConstName " ^ s ^ " " ^ Syntax.string_of_typ ctxt T ^ " " ^
+ string_for_rep R
+ | BoundRel ((n, j), T, R, nick) =>
+ "BoundRel " ^ string_of_int n ^ "." ^ signed_string_of_int j ^ " " ^
+ Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R ^ " " ^ nick
+ | FreeRel ((n, j), T, R, nick) =>
+ "FreeRel " ^ string_of_int n ^ "." ^ signed_string_of_int j ^ " " ^
+ Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R ^ " " ^ nick
+ | RelReg (j, T, R) =>
+ "RelReg " ^ signed_string_of_int j ^ " " ^ Syntax.string_of_typ ctxt T ^
+ " " ^ string_for_rep R
+ | FormulaReg (j, T, R) =>
+ "FormulaReg " ^ signed_string_of_int j ^ " " ^
+ Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R) ^
+ ")"
+ end
+(* Proof.context -> nut -> string *)
+val string_for_nut = basic_string_for_nut 0
+
+(* nut -> bool *)
+fun inline_nut (Op1 _) = false
+ | inline_nut (Op2 _) = false
+ | inline_nut (Op3 _) = false
+ | inline_nut (Tuple (_, _, us)) = forall inline_nut us
+ | inline_nut _ = true
+
+(* nut -> typ *)
+fun type_of (Cst (_, T, _)) = T
+ | type_of (Op1 (_, T, _, _)) = T
+ | type_of (Op2 (_, T, _, _, _)) = T
+ | type_of (Op3 (_, T, _, _, _, _)) = T
+ | type_of (Tuple (T, _, _)) = T
+ | type_of (Construct (_, T, _, _)) = T
+ | type_of (BoundName (_, T, _, _)) = T
+ | type_of (FreeName (_, T, _)) = T
+ | type_of (ConstName (_, T, _)) = T
+ | type_of (BoundRel (_, T, _, _)) = T
+ | type_of (FreeRel (_, T, _, _)) = T
+ | type_of (RelReg (_, T, _)) = T
+ | type_of (FormulaReg (_, T, _)) = T
+
+(* nut -> rep *)
+fun rep_of (Cst (_, _, R)) = R
+ | rep_of (Op1 (_, _, R, _)) = R
+ | rep_of (Op2 (_, _, R, _, _)) = R
+ | rep_of (Op3 (_, _, R, _, _, _)) = R
+ | rep_of (Tuple (_, R, _)) = R
+ | rep_of (Construct (_, _, R, _)) = R
+ | rep_of (BoundName (_, _, R, _)) = R
+ | rep_of (FreeName (_, _, R)) = R
+ | rep_of (ConstName (_, _, R)) = R
+ | rep_of (BoundRel (_, _, R, _)) = R
+ | rep_of (FreeRel (_, _, R, _)) = R
+ | rep_of (RelReg (_, _, R)) = R
+ | rep_of (FormulaReg (_, _, R)) = R
+
+(* nut -> string *)
+fun nickname_of (BoundName (_, _, _, nick)) = nick
+ | nickname_of (FreeName (s, _, _)) = s
+ | nickname_of (ConstName (s, _, _)) = s
+ | nickname_of (BoundRel (_, _, _, nick)) = nick
+ | nickname_of (FreeRel (_, _, _, nick)) = nick
+ | nickname_of u = raise NUT ("NitpickNut.nickname_of", [u])
+
+(* nut -> bool *)
+fun is_skolem_name u =
+ space_explode name_sep (nickname_of u)
+ |> exists (String.isPrefix skolem_prefix)
+ handle NUT ("NitpickNut.nickname_of", _) => false
+fun is_eval_name u =
+ String.isPrefix eval_prefix (nickname_of u)
+ handle NUT ("NitpickNut.nickname_of", _) => false
+(* cst -> nut -> bool *)
+fun is_Cst cst (Cst (cst', _, _)) = (cst = cst')
+ | is_Cst _ _ = false
+
+(* (nut -> 'a -> 'a) -> nut -> 'a -> 'a *)
+fun fold_nut f u =
+ case u of
+ Op1 (_, _, _, u1) => fold_nut f u1
+ | Op2 (_, _, _, u1, u2) => fold_nut f u1 #> fold_nut f u2
+ | Op3 (_, _, _, u1, u2, u3) => fold_nut f u1 #> fold_nut f u2 #> fold_nut f u3
+ | Tuple (_, _, us) => fold (fold_nut f) us
+ | Construct (us', _, _, us) => fold (fold_nut f) us #> fold (fold_nut f) us'
+ | _ => f u
+(* (nut -> nut) -> nut -> nut *)
+fun map_nut f u =
+ case u of
+ Op1 (oper, T, R, u1) => Op1 (oper, T, R, map_nut f u1)
+ | Op2 (oper, T, R, u1, u2) => Op2 (oper, T, R, map_nut f u1, map_nut f u2)
+ | Op3 (oper, T, R, u1, u2, u3) =>
+ Op3 (oper, T, R, map_nut f u1, map_nut f u2, map_nut f u3)
+ | Tuple (T, R, us) => Tuple (T, R, map (map_nut f) us)
+ | Construct (us', T, R, us) =>
+ Construct (map (map_nut f) us', T, R, map (map_nut f) us)
+ | _ => f u
+
+(* nut * nut -> order *)
+fun name_ord (BoundName (j1, _, _, _), BoundName (j2, _, _, _)) =
+ int_ord (j1, j2)
+ | name_ord (BoundName _, _) = LESS
+ | name_ord (_, BoundName _) = GREATER
+ | name_ord (FreeName (s1, T1, _), FreeName (s2, T2, _)) =
+ (case fast_string_ord (s1, s2) of
+ EQUAL => TermOrd.typ_ord (T1, T2)
+ | ord => ord)
+ | name_ord (FreeName _, _) = LESS
+ | name_ord (_, FreeName _) = GREATER
+ | name_ord (ConstName (s1, T1, _), ConstName (s2, T2, _)) =
+ (case fast_string_ord (s1, s2) of
+ EQUAL => TermOrd.typ_ord (T1, T2)
+ | ord => ord)
+ | name_ord (u1, u2) = raise NUT ("NitpickNut.name_ord", [u1, u2])
+
+(* nut -> nut -> int *)
+fun num_occs_in_nut needle_u stack_u =
+ fold_nut (fn u => if u = needle_u then Integer.add 1 else I) stack_u 0
+(* nut -> nut -> bool *)
+val is_subterm_of = not_equal 0 oo num_occs_in_nut
+
+(* nut -> nut -> nut -> nut *)
+fun substitute_in_nut needle_u needle_u' =
+ map_nut (fn u => if u = needle_u then needle_u' else u)
+
+(* nut -> nut list * nut list -> nut list * nut list *)
+val add_free_and_const_names =
+ fold_nut (fn u => case u of
+ FreeName _ => apfst (insert (op =) u)
+ | ConstName _ => apsnd (insert (op =) u)
+ | _ => I)
+
+(* nut -> rep -> nut *)
+fun modify_name_rep (BoundName (j, T, _, nick)) R = BoundName (j, T, R, nick)
+ | modify_name_rep (FreeName (s, T, _)) R = FreeName (s, T, R)
+ | modify_name_rep (ConstName (s, T, _)) R = ConstName (s, T, R)
+ | modify_name_rep u _ = raise NUT ("NitpickNut.modify_name_rep", [u])
+
+structure NameTable = Table(type key = nut val ord = name_ord)
+
+(* 'a NameTable.table -> nut -> 'a *)
+fun the_name table name =
+ case NameTable.lookup table name of
+ SOME u => u
+ | NONE => raise NUT ("NitpickNut.the_name", [name])
+(* nut NameTable.table -> nut -> Kodkod.n_ary_index *)
+fun the_rel table name =
+ case the_name table name of
+ FreeRel (x, _, _, _) => x
+ | u => raise NUT ("NitpickNut.the_rel", [u])
+
+(* typ * term -> typ * term *)
+fun mk_fst (_, Const (@{const_name Pair}, T) $ t1 $ _) = (domain_type T, t1)
+ | mk_fst (T, t) =
+ let val res_T = fst (HOLogic.dest_prodT T) in
+ (res_T, Const (@{const_name fst}, T --> res_T) $ t)
+ end
+fun mk_snd (_, Const (@{const_name Pair}, T) $ _ $ t2) =
+ (domain_type (range_type T), t2)
+ | mk_snd (T, t) =
+ let val res_T = snd (HOLogic.dest_prodT T) in
+ (res_T, Const (@{const_name snd}, T --> res_T) $ t)
+ end
+(* typ * term -> (typ * term) list *)
+fun factorize (z as (Type ("*", _), _)) = maps factorize [mk_fst z, mk_snd z]
+ | factorize z = [z]
+
+(* theory -> bool -> special_fun list -> op2 -> term -> nut *)
+fun nut_from_term thy fast_descrs special_funs eq =
+ let
+ (* string list -> typ list -> term -> nut *)
+ fun aux eq ss Ts t =
+ let
+ (* term -> nut *)
+ val sub = aux Eq ss Ts
+ val sub' = aux eq ss Ts
+ (* string -> typ -> term -> nut *)
+ fun sub_abs s T = aux eq (s :: ss) (T :: Ts)
+ (* typ -> term -> term -> nut *)
+ fun sub_equals T t1 t2 =
+ let
+ val (binder_Ts, body_T) = strip_type (domain_type T)
+ val n = length binder_Ts
+ in
+ if eq = Eq andalso n > 0 then
+ let
+ val t1 = incr_boundvars n t1
+ val t2 = incr_boundvars n t2
+ val xs = map Bound (n - 1 downto 0)
+ val equation = Const (@{const_name "op ="},
+ body_T --> body_T --> bool_T)
+ $ betapplys (t1, xs) $ betapplys (t2, xs)
+ val t =
+ fold_rev (fn T => fn (t, j) =>
+ (Const (@{const_name All}, T --> bool_T)
+ $ Abs ("x" ^ nat_subscript j, T, t), j - 1))
+ binder_Ts (equation, n) |> fst
+ in sub' t end
+ else
+ Op2 (eq, bool_T, Any, aux Eq ss Ts t1, aux Eq ss Ts t2)
+ end
+ (* op2 -> string -> typ -> term -> nut *)
+ fun do_quantifier quant s T t1 =
+ let
+ val bound_u = BoundName (length Ts, T, Any, s)
+ val body_u = sub_abs s T t1
+ in
+ if is_subterm_of bound_u body_u then
+ Op2 (quant, bool_T, Any, bound_u, body_u)
+ else
+ body_u
+ end
+ (* term -> term list -> nut *)
+ fun do_apply t0 ts =
+ let
+ val (ts', t2) = split_last ts
+ val t1 = list_comb (t0, ts')
+ val T1 = fastype_of1 (Ts, t1)
+ in Op2 (Apply, range_type T1, Any, sub t1, sub t2) end
+ in
+ case strip_comb t of
+ (Const (@{const_name all}, _), [Abs (s, T, t1)]) =>
+ do_quantifier All s T t1
+ | (t0 as Const (@{const_name all}, T), [t1]) =>
+ sub' (t0 $ eta_expand Ts t1 1)
+ | (Const (@{const_name "=="}, T), [t1, t2]) => sub_equals T t1 t2
+ | (Const (@{const_name "==>"}, _), [t1, t2]) =>
+ Op2 (Or, prop_T, Any, Op1 (Not, prop_T, Any, sub t1), sub' t2)
+ | (Const (@{const_name Pure.conjunction}, _), [t1, t2]) =>
+ Op2 (And, prop_T, Any, sub' t1, sub' t2)
+ | (Const (@{const_name Trueprop}, _), [t1]) => sub' t1
+ | (Const (@{const_name Not}, _), [t1]) =>
+ (case sub t1 of
+ Op1 (Not, _, _, u11) => u11
+ | u1 => Op1 (Not, bool_T, Any, u1))
+ | (Const (@{const_name False}, T), []) => Cst (False, T, Any)
+ | (Const (@{const_name True}, T), []) => Cst (True, T, Any)
+ | (Const (@{const_name All}, _), [Abs (s, T, t1)]) =>
+ do_quantifier All s T t1
+ | (t0 as Const (@{const_name All}, T), [t1]) =>
+ sub' (t0 $ eta_expand Ts t1 1)
+ | (Const (@{const_name Ex}, _), [Abs (s, T, t1)]) =>
+ do_quantifier Exist s T t1
+ | (t0 as Const (@{const_name Ex}, T), [t1]) =>
+ sub' (t0 $ eta_expand Ts t1 1)
+ | (t0 as Const (@{const_name The}, T), [t1]) =>
+ if fast_descrs then
+ Op2 (The, range_type T, Any, sub t1,
+ sub (Const (@{const_name undefined_fast_The}, range_type T)))
+ else
+ do_apply t0 [t1]
+ | (t0 as Const (@{const_name Eps}, T), [t1]) =>
+ if fast_descrs then
+ Op2 (Eps, range_type T, Any, sub t1,
+ sub (Const (@{const_name undefined_fast_Eps}, range_type T)))
+ else
+ do_apply t0 [t1]
+ | (Const (@{const_name "op ="}, T), [t1, t2]) => sub_equals T t1 t2
+ | (Const (@{const_name "op &"}, _), [t1, t2]) =>
+ Op2 (And, bool_T, Any, sub' t1, sub' t2)
+ | (Const (@{const_name "op |"}, _), [t1, t2]) =>
+ Op2 (Or, bool_T, Any, sub t1, sub t2)
+ | (Const (@{const_name "op -->"}, _), [t1, t2]) =>
+ Op2 (Or, bool_T, Any, Op1 (Not, bool_T, Any, sub t1), sub' t2)
+ | (Const (@{const_name If}, T), [t1, t2, t3]) =>
+ Op3 (If, nth_range_type 3 T, Any, sub t1, sub t2, sub t3)
+ | (Const (@{const_name Let}, T), [t1, Abs (s, T', t2)]) =>
+ Op3 (Let, nth_range_type 2 T, Any, BoundName (length Ts, T', Any, s),
+ sub t1, sub_abs s T' t2)
+ | (t0 as Const (@{const_name Let}, T), [t1, t2]) =>
+ sub (t0 $ t1 $ eta_expand Ts t2 1)
+ | (Const (@{const_name unknown}, T), []) => Cst (Unknown, T, Any)
+ | (@{const Unity}, []) => Cst (Unity, @{typ unit}, Any)
+ | (Const (@{const_name Pair}, T), [t1, t2]) =>
+ Tuple (nth_range_type 2 T, Any, map sub [t1, t2])
+ | (Const (@{const_name fst}, T), [t1]) =>
+ Op1 (First, range_type T, Any, sub t1)
+ | (Const (@{const_name snd}, T), [t1]) =>
+ Op1 (Second, range_type T, Any, sub t1)
+ | (Const (@{const_name Id}, T), []) => Cst (Iden, T, Any)
+ | (Const (@{const_name insert}, T), [t1, t2]) =>
+ (case t2 of
+ Abs (_, _, @{const False}) =>
+ Op1 (SingletonSet, nth_range_type 2 T, Any, sub t1)
+ | _ =>
+ Op2 (Union, nth_range_type 2 T, Any,
+ Op1 (SingletonSet, nth_range_type 2 T, Any, sub t1), sub t2))
+ | (Const (@{const_name converse}, T), [t1]) =>
+ Op1 (Converse, range_type T, Any, sub t1)
+ | (Const (@{const_name trancl}, T), [t1]) =>
+ Op1 (Closure, range_type T, Any, sub t1)
+ | (Const (@{const_name rel_comp}, T), [t1, t2]) =>
+ Op2 (Composition, nth_range_type 2 T, Any, sub t1, sub t2)
+ | (Const (@{const_name Sigma}, T), [t1, Abs (s, T', t2')]) =>
+ Op2 (Product, nth_range_type 2 T, Any, sub t1, sub_abs s T' t2')
+ | (Const (@{const_name image}, T), [t1, t2]) =>
+ Op2 (Image, nth_range_type 2 T, Any, sub t1, sub t2)
+ | (Const (@{const_name Suc}, T), []) => Cst (Suc, T, Any)
+ | (Const (@{const_name finite}, T), [t1]) =>
+ Op1 (Finite, bool_T, Any, sub t1)
+ | (Const (@{const_name nat}, T), []) => Cst (IntToNat, T, Any)
+ | (Const (@{const_name zero_nat_inst.zero_nat}, T), []) =>
+ Cst (Num 0, T, Any)
+ | (Const (@{const_name one_nat_inst.one_nat}, T), []) =>
+ Cst (Num 1, T, Any)
+ | (Const (@{const_name plus_nat_inst.plus_nat}, T), []) =>
+ Cst (Add, T, Any)
+ | (Const (@{const_name minus_nat_inst.minus_nat}, T), []) =>
+ Cst (Subtract, T, Any)
+ | (Const (@{const_name times_nat_inst.times_nat}, T), []) =>
+ Cst (Multiply, T, Any)
+ | (Const (@{const_name div_nat_inst.div_nat}, T), []) =>
+ Cst (Divide, T, Any)
+ | (Const (@{const_name div_nat_inst.mod_nat}, T), []) =>
+ Cst (Modulo, T, Any)
+ | (Const (@{const_name ord_nat_inst.less_nat}, T), [t1, t2]) =>
+ Op2 (Less, bool_T, Any, sub t1, sub t2)
+ | (Const (@{const_name ord_nat_inst.less_eq_nat}, T), [t1, t2]) =>
+ Op1 (Not, bool_T, Any, Op2 (Less, bool_T, Any, sub t2, sub t1))
+ | (Const (@{const_name nat_gcd}, T), []) => Cst (Gcd, T, Any)
+ | (Const (@{const_name nat_lcm}, T), []) => Cst (Lcm, T, Any)
+ | (Const (@{const_name zero_int_inst.zero_int}, T), []) =>
+ Cst (Num 0, T, Any)
+ | (Const (@{const_name one_int_inst.one_int}, T), []) =>
+ Cst (Num 1, T, Any)
+ | (Const (@{const_name plus_int_inst.plus_int}, T), []) =>
+ Cst (Add, T, Any)
+ | (Const (@{const_name minus_int_inst.minus_int}, T), []) =>
+ Cst (Subtract, T, Any)
+ | (Const (@{const_name times_int_inst.times_int}, T), []) =>
+ Cst (Multiply, T, Any)
+ | (Const (@{const_name div_int_inst.div_int}, T), []) =>
+ Cst (Divide, T, Any)
+ | (Const (@{const_name div_int_inst.mod_int}, T), []) =>
+ Cst (Modulo, T, Any)
+ | (Const (@{const_name uminus_int_inst.uminus_int}, T), []) =>
+ Op2 (Apply, int_T --> int_T, Any,
+ Cst (Subtract, [int_T, int_T] ---> int_T, Any),
+ Cst (Num 0, int_T, Any))
+ | (Const (@{const_name ord_int_inst.less_int}, T), [t1, t2]) =>
+ Op2 (Less, bool_T, Any, sub t1, sub t2)
+ | (Const (@{const_name ord_int_inst.less_eq_int}, T), [t1, t2]) =>
+ Op1 (Not, bool_T, Any, Op2 (Less, bool_T, Any, sub t2, sub t1))
+ | (Const (@{const_name Tha}, Type ("fun", [_, T2])), [t1]) =>
+ Op1 (Tha, T2, Any, sub t1)
+ | (Const (@{const_name Frac}, T), []) => Cst (Fracs, T, Any)
+ | (Const (@{const_name norm_frac}, T), []) => Cst (NormFrac, T, Any)
+ | (Const (@{const_name of_nat}, T as @{typ "nat => int"}), []) =>
+ Cst (NatToInt, T, Any)
+ | (Const (@{const_name lower_semilattice_fun_inst.inf_fun}, T),
+ [t1, t2]) =>
+ Op2 (Intersect, nth_range_type 2 T, Any, sub t1, sub t2)
+ | (Const (@{const_name upper_semilattice_fun_inst.sup_fun}, T),
+ [t1, t2]) =>
+ Op2 (Union, nth_range_type 2 T, Any, sub t1, sub t2)
+ | (t0 as Const (@{const_name minus_fun_inst.minus_fun}, T), [t1, t2]) =>
+ Op2 (SetDifference, nth_range_type 2 T, Any, sub t1, sub t2)
+ | (t0 as Const (@{const_name ord_fun_inst.less_eq_fun}, T), [t1, t2]) =>
+ Op2 (Subset, bool_T, Any, sub t1, sub t2)
+ | (t0 as Const (x as (s, T)), ts) =>
+ if is_constr thy x then
+ case num_binder_types T - length ts of
+ 0 => Construct (map ((fn (s, T) => ConstName (s, T, Any))
+ o nth_sel_for_constr x)
+ (~1 upto num_sels_for_constr_type T - 1),
+ body_type T, Any,
+ ts |> map (`(curry fastype_of1 Ts))
+ |> maps factorize |> map (sub o snd))
+ | k => sub (eta_expand Ts t k)
+ else if String.isPrefix numeral_prefix s then
+ Cst (Num (the (Int.fromString (unprefix numeral_prefix s))), T, Any)
+ else
+ (case arity_of_built_in_const fast_descrs x of
+ SOME n =>
+ (case n - length ts of
+ 0 => raise TERM ("NitpickNut.nut_from_term.aux", [t])
+ | k => if k > 0 then sub (eta_expand Ts t k)
+ else do_apply t0 ts)
+ | NONE => if null ts then ConstName (s, T, Any)
+ else do_apply t0 ts)
+ | (Free (s, T), []) => FreeName (s, T, Any)
+ | (Var _, []) => raise TERM ("NitpickNut.nut_from_term", [t])
+ | (Bound j, []) =>
+ BoundName (length Ts - j - 1, nth Ts j, Any, nth ss j)
+ | (Abs (s, T, t1), []) =>
+ Op2 (Lambda, T --> fastype_of1 (T :: Ts, t1), Any,
+ BoundName (length Ts, T, Any, s), sub_abs s T t1)
+ | (t0, ts) => do_apply t0 ts
+ end
+ in aux eq [] [] end
+
+(* scope -> typ -> rep *)
+fun rep_for_abs_fun scope T =
+ let val (R1, R2) = best_non_opt_symmetric_reps_for_fun_type scope T in
+ Func (R1, (card_of_rep R1 <> card_of_rep R2 ? Opt) R2)
+ end
+
+(* scope -> nut -> nut list * rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_rep_for_free_var scope v (vs, table) =
+ let
+ val R = best_non_opt_set_rep_for_type scope (type_of v)
+ val v = modify_name_rep v R
+ in (v :: vs, NameTable.update (v, R) table) end
+(* scope -> bool -> nut -> nut list * rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_rep_for_const (scope as {ext_ctxt as {thy, ctxt, ...}, datatypes,
+ ofs, ...}) all_precise v (vs, table) =
+ let
+ val x as (s, T) = (nickname_of v, type_of v)
+ val R = (if is_abs_fun thy x then
+ rep_for_abs_fun
+ else if is_rep_fun thy x then
+ Func oo best_non_opt_symmetric_reps_for_fun_type
+ else if all_precise orelse is_skolem_name v
+ orelse s mem [@{const_name undefined_fast_The},
+ @{const_name undefined_fast_Eps},
+ @{const_name bisim}] then
+ best_non_opt_set_rep_for_type
+ else if original_name s
+ mem [@{const_name set}, @{const_name distinct},
+ @{const_name ord_class.less},
+ @{const_name ord_class.less_eq},
+ @{const_name bisim_iterator_max}] then
+ best_set_rep_for_type
+ else
+ best_opt_set_rep_for_type) scope T
+ val v = modify_name_rep v R
+ in (v :: vs, NameTable.update (v, R) table) end
+
+(* scope -> nut list -> rep NameTable.table -> nut list * rep NameTable.table *)
+fun choose_reps_for_free_vars scope vs table =
+ fold (choose_rep_for_free_var scope) vs ([], table)
+(* scope -> bool -> nut list -> rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_reps_for_consts scope all_precise vs table =
+ fold (choose_rep_for_const scope all_precise) vs ([], table)
+
+(* scope -> styp -> int -> nut list * rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_rep_for_nth_sel_for_constr (scope as {ext_ctxt, ...}) x n
+ (vs, table) =
+ let
+ val (s', T') = boxed_nth_sel_for_constr ext_ctxt x n
+ val R' = if n = ~1 then best_non_opt_set_rep_for_type scope T'
+ else best_opt_set_rep_for_type scope T' |> unopt_rep
+ val v = ConstName (s', T', R')
+ in (v :: vs, NameTable.update (v, R') table) end
+(* scope -> styp -> nut list * rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_rep_for_sels_for_constr scope (x as (_, T)) =
+ fold_rev (choose_rep_for_nth_sel_for_constr scope x)
+ (~1 upto num_sels_for_constr_type T - 1)
+(* scope -> dtype_spec -> nut list * rep NameTable.table
+ -> nut list * rep NameTable.table *)
+fun choose_rep_for_sels_of_datatype scope ({constrs, ...} : dtype_spec) =
+ fold_rev (choose_rep_for_sels_for_constr scope o #const) constrs
+(* scope -> rep NameTable.table -> nut list * rep NameTable.table *)
+fun choose_reps_for_all_sels (scope as {datatypes, ...}) =
+ fold (choose_rep_for_sels_of_datatype scope) datatypes o pair []
+
+(* scope -> nut -> rep NameTable.table -> rep NameTable.table *)
+fun choose_rep_for_bound_var scope v table =
+ let val R = best_one_rep_for_type scope (type_of v) in
+ NameTable.update (v, R) table
+ end
+
+(* A nut is said to be constructive if whenever it evaluates to unknown in our
+ three-valued logic, it would evaluate to a unrepresentable value ("unrep")
+ according to the HOL semantics. For example, "Suc n" is
+ constructive if "n" is representable or "Unrep", because unknown implies
+ unrep. *)
+(* nut -> bool *)
+fun is_constructive u =
+ is_Cst Unrep u orelse
+ (not (is_fun_type (type_of u)) andalso not (is_opt_rep (rep_of u))) orelse
+ case u of
+ Cst (Num _, _, _) => true
+ | Cst (cst, T, _) => cst = Suc orelse (body_type T = nat_T andalso cst = Add)
+ | Op2 (Apply, _, _, u1, u2) => forall is_constructive [u1, u2]
+ | Op3 (If, _, _, u1, u2, u3) =>
+ not (is_opt_rep (rep_of u1)) andalso forall is_constructive [u2, u3]
+ | Tuple (_, _, us) => forall is_constructive us
+ | Construct (_, _, _, us) => forall is_constructive us
+ | _ => false
+
+(* nut -> nut *)
+fun optimize_unit u =
+ if rep_of u = Unit then Cst (Unity, type_of u, Unit) else u
+(* typ -> rep -> nut *)
+fun unknown_boolean T R =
+ Cst (case R of
+ Formula Pos => False
+ | Formula Neg => True
+ | _ => Unknown, T, R)
+
+(* op1 -> typ -> rep -> nut -> nut *)
+fun s_op1 oper T R u1 =
+ ((if oper = Not then
+ if is_Cst True u1 then Cst (False, T, R)
+ else if is_Cst False u1 then Cst (True, T, R)
+ else raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => Op1 (oper, T, R, u1))
+ |> optimize_unit
+(* op2 -> typ -> rep -> nut -> nut -> nut *)
+fun s_op2 oper T R u1 u2 =
+ ((case oper of
+ Or =>
+ if exists (is_Cst True) [u1, u2] then Cst (True, T, unopt_rep R)
+ else if is_Cst False u1 then u2
+ else if is_Cst False u2 then u1
+ else raise SAME ()
+ | And =>
+ if exists (is_Cst False) [u1, u2] then Cst (False, T, unopt_rep R)
+ else if is_Cst True u1 then u2
+ else if is_Cst True u2 then u1
+ else raise SAME ()
+ | Eq =>
+ (case pairself (is_Cst Unrep) (u1, u2) of
+ (true, true) => unknown_boolean T R
+ | (false, false) => raise SAME ()
+ | _ => if forall (is_opt_rep o rep_of) [u1, u2] then raise SAME ()
+ else Cst (False, T, Formula Neut))
+ | Triad =>
+ if is_Cst True u1 then u1
+ else if is_Cst False u2 then u2
+ else raise SAME ()
+ | Apply =>
+ if is_Cst Unrep u1 then
+ Cst (Unrep, T, R)
+ else if is_Cst Unrep u2 then
+ if is_constructive u1 then
+ Cst (Unrep, T, R)
+ else if is_boolean_type T andalso not (is_opt_rep (rep_of u1)) then
+ (* Selectors are an unfortunate exception to the rule that non-"Opt"
+ predicates return "False" for unrepresentable domain values. *)
+ case u1 of
+ ConstName (s, _, _) => if is_sel s then unknown_boolean T R
+ else Cst (False, T, Formula Neut)
+ | _ => Cst (False, T, Formula Neut)
+ else case u1 of
+ Op2 (Apply, _, _, ConstName (@{const_name List.append}, _, _), _) =>
+ Cst (Unrep, T, R)
+ | _ => raise SAME ()
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => Op2 (oper, T, R, u1, u2))
+ |> optimize_unit
+(* op3 -> typ -> rep -> nut -> nut -> nut -> nut *)
+fun s_op3 oper T R u1 u2 u3 =
+ ((case oper of
+ Let =>
+ if inline_nut u2 orelse num_occs_in_nut u1 u3 < 2 then
+ substitute_in_nut u1 u2 u3
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => Op3 (oper, T, R, u1, u2, u3))
+ |> optimize_unit
+(* typ -> rep -> nut list -> nut *)
+fun s_tuple T R us =
+ (if exists (is_Cst Unrep) us then Cst (Unrep, T, R) else Tuple (T, R, us))
+ |> optimize_unit
+
+(* theory -> nut -> nut *)
+fun optimize_nut u =
+ case u of
+ Op1 (oper, T, R, u1) => s_op1 oper T R (optimize_nut u1)
+ | Op2 (oper, T, R, u1, u2) =>
+ s_op2 oper T R (optimize_nut u1) (optimize_nut u2)
+ | Op3 (oper, T, R, u1, u2, u3) =>
+ s_op3 oper T R (optimize_nut u1) (optimize_nut u2) (optimize_nut u3)
+ | Tuple (T, R, us) => s_tuple T R (map optimize_nut us)
+ | Construct (us', T, R, us) => Construct (us', T, R, map optimize_nut us)
+ | _ => optimize_unit u
+
+(* (nut -> 'a) -> nut -> 'a list *)
+fun untuple f (Tuple (_, _, us)) = maps (untuple f) us
+ | untuple f u = if rep_of u = Unit then [] else [f u]
+
+(* scope -> bool -> rep NameTable.table -> bool -> nut -> nut *)
+fun choose_reps_in_nut (scope as {ext_ctxt as {thy, ctxt, ...}, card_assigns,
+ datatypes, ofs, ...}) liberal table def =
+ let
+ val bool_atom_R = Atom (2, offset_of_type ofs bool_T)
+ (* polarity -> bool -> rep *)
+ fun bool_rep polar opt =
+ if polar = Neut andalso opt then Opt bool_atom_R else Formula polar
+ (* nut -> nut -> nut *)
+ fun triad u1 u2 = s_op2 Triad (type_of u1) (Opt bool_atom_R) u1 u2
+ (* (polarity -> nut) -> nut *)
+ fun triad_fn f = triad (f Pos) (f Neg)
+ (* rep NameTable.table -> bool -> polarity -> nut -> nut -> nut *)
+ fun unrepify_nut_in_nut table def polar needle_u =
+ let val needle_T = type_of needle_u in
+ substitute_in_nut needle_u (Cst (if is_fun_type needle_T then Unknown
+ else Unrep, needle_T, Any))
+ #> aux table def polar
+ end
+ (* rep NameTable.table -> bool -> polarity -> nut -> nut *)
+ and aux table def polar u =
+ let
+ (* bool -> polarity -> nut -> nut *)
+ val gsub = aux table
+ (* nut -> nut *)
+ val sub = gsub false Neut
+ in
+ case u of
+ Cst (False, T, _) => Cst (False, T, Formula Neut)
+ | Cst (True, T, _) => Cst (True, T, Formula Neut)
+ | Cst (Num j, T, _) =>
+ (case spec_of_type scope T of
+ (1, j0) => if j = 0 then Cst (Unity, T, Unit)
+ else Cst (Unrep, T, Opt (Atom (1, j0)))
+ | (k, j0) =>
+ let
+ val ok = (if T = int_T then atom_for_int (k, j0) j <> ~1
+ else j < k)
+ in
+ if ok then Cst (Num j, T, Atom (k, j0))
+ else Cst (Unrep, T, Opt (Atom (k, j0)))
+ end)
+ | Cst (Suc, T as Type ("fun", [T1, _]), _) =>
+ let val R = Atom (spec_of_type scope T1) in
+ Cst (Suc, T, Func (R, Opt R))
+ end
+ | Cst (Fracs, T, _) =>
+ Cst (Fracs, T, best_non_opt_set_rep_for_type scope T)
+ | Cst (NormFrac, T, _) =>
+ let val R1 = Atom (spec_of_type scope (domain_type T)) in
+ Cst (NormFrac, T, Func (R1, Func (R1, Opt (Struct [R1, R1]))))
+ end
+ | Cst (cst, T, _) =>
+ if cst mem [Unknown, Unrep] then
+ case (is_boolean_type T, polar) of
+ (true, Pos) => Cst (False, T, Formula Pos)
+ | (true, Neg) => Cst (True, T, Formula Neg)
+ | _ => Cst (cst, T, best_opt_set_rep_for_type scope T)
+ else if cst mem [Add, Subtract, Multiply, Divide, Modulo, Gcd,
+ Lcm] then
+ let
+ val T1 = domain_type T
+ val R1 = Atom (spec_of_type scope T1)
+ val total =
+ T1 = nat_T andalso cst mem [Subtract, Divide, Modulo, Gcd]
+ in Cst (cst, T, Func (R1, Func (R1, (not total ? Opt) R1))) end
+ else if cst mem [NatToInt, IntToNat] then
+ let
+ val (nat_card, nat_j0) = spec_of_type scope nat_T
+ val (int_card, int_j0) = spec_of_type scope int_T
+ in
+ if cst = NatToInt then
+ let val total = (max_int_for_card int_card >= nat_card + 1) in
+ Cst (cst, T,
+ Func (Atom (nat_card, nat_j0),
+ (not total ? Opt) (Atom (int_card, int_j0))))
+ end
+ else
+ let val total = (max_int_for_card int_card < nat_card) in
+ Cst (cst, T, Func (Atom (int_card, int_j0),
+ Atom (nat_card, nat_j0)) |> not total ? Opt)
+ end
+ end
+ else
+ Cst (cst, T, best_set_rep_for_type scope T)
+ | Op1 (Not, T, _, u1) =>
+ (case gsub def (flip_polarity polar) u1 of
+ Op2 (Triad, T, R, u11, u12) =>
+ triad (s_op1 Not T (Formula Pos) u12)
+ (s_op1 Not T (Formula Neg) u11)
+ | u1' => s_op1 Not T (flip_rep_polarity (rep_of u1')) u1')
+ | Op1 (oper, T, _, u1) =>
+ let
+ val u1 = sub u1
+ val R1 = rep_of u1
+ val R = case oper of
+ Finite => bool_rep polar (is_opt_rep R1)
+ | _ => (if is_opt_rep R1 then best_opt_set_rep_for_type
+ else best_non_opt_set_rep_for_type) scope T
+ in s_op1 oper T R u1 end
+ | Op2 (Less, T, _, u1, u2) =>
+ let
+ val u1 = sub u1
+ val u2 = sub u2
+ val R = bool_rep polar (exists (is_opt_rep o rep_of) [u1, u2])
+ in s_op2 Less T R u1 u2 end
+ | Op2 (Subset, T, _, u1, u2) =>
+ let
+ val u1 = sub u1
+ val u2 = sub u2
+ val opt = exists (is_opt_rep o rep_of) [u1, u2]
+ val R = bool_rep polar opt
+ in
+ if is_opt_rep R then
+ triad_fn (fn polar => s_op2 Subset T (Formula polar) u1 u2)
+ else if opt andalso polar = Pos andalso
+ not (is_fully_comparable_type datatypes (type_of u1)) then
+ Cst (False, T, Formula Pos)
+ else
+ s_op2 Subset T R u1 u2
+ end
+ | Op2 (DefEq, T, _, u1, u2) =>
+ s_op2 DefEq T (Formula Neut) (sub u1) (sub u2)
+ | Op2 (Eq, T, _, u1, u2) =>
+ let
+ val u1' = sub u1
+ val u2' = sub u2
+ (* unit -> nut *)
+ fun non_opt_case () = s_op2 Eq T (Formula polar) u1' u2'
+ (* unit -> nut *)
+ fun opt_opt_case () =
+ if polar = Neut then
+ triad_fn (fn polar => s_op2 Eq T (Formula polar) u1' u2')
+ else
+ non_opt_case ()
+ (* nut -> nut *)
+ fun hybrid_case u =
+ (* hackish optimization *)
+ if is_constructive u then s_op2 Eq T (Formula Neut) u1' u2'
+ else opt_opt_case ()
+ in
+ if liberal orelse polar = Neg
+ orelse is_fully_comparable_type datatypes (type_of u1) then
+ case (is_opt_rep (rep_of u1'), is_opt_rep (rep_of u2')) of
+ (true, true) => opt_opt_case ()
+ | (true, false) => hybrid_case u1'
+ | (false, true) => hybrid_case u2'
+ | (false, false) => non_opt_case ()
+ else
+ Cst (False, T, Formula Pos)
+ |> polar = Neut ? (fn pos_u => triad pos_u (gsub def Neg u))
+ end
+ | Op2 (Image, T, _, u1, u2) =>
+ let
+ val u1' = sub u1
+ val u2' = sub u2
+ in
+ (case (rep_of u1', rep_of u2') of
+ (Func (R11, R12), Func (R21, Formula Neut)) =>
+ if R21 = R11 andalso is_lone_rep R12 then
+ let
+ val R =
+ best_non_opt_set_rep_for_type scope T
+ |> exists (is_opt_rep o rep_of) [u1', u2'] ? opt_rep ofs T
+ in s_op2 Image T R u1' u2' end
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ let
+ val T1 = type_of u1
+ val dom_T = domain_type T1
+ val ran_T = range_type T1
+ val x_u = BoundName (~1, dom_T, Any, "image.x")
+ val y_u = BoundName (~2, ran_T, Any, "image.y")
+ in
+ Op2 (Lambda, T, Any, y_u,
+ Op2 (Exist, bool_T, Any, x_u,
+ Op2 (And, bool_T, Any,
+ case u2 of
+ Op2 (Lambda, _, _, u21, u22) =>
+ if num_occs_in_nut u21 u22 = 0 then (* FIXME: move to s_op2 *)
+ u22
+ else
+ Op2 (Apply, bool_T, Any, u2, x_u)
+ | _ => Op2 (Apply, bool_T, Any, u2, x_u),
+ Op2 (Eq, bool_T, Any, y_u,
+ Op2 (Apply, ran_T, Any, u1, x_u)))))
+ |> sub
+ end
+ end
+ | Op2 (Apply, T, _, u1, u2) =>
+ let
+ val u1 = sub u1
+ val u2 = sub u2
+ val T1 = type_of u1
+ val R1 = rep_of u1
+ val R2 = rep_of u2
+ val opt =
+ case (u1, is_opt_rep R2) of
+ (ConstName (@{const_name set}, _, _), false) => false
+ | _ => exists is_opt_rep [R1, R2]
+ val ran_R =
+ if is_boolean_type T then
+ bool_rep polar opt
+ else
+ smart_range_rep ofs T1 (fn () => card_of_type card_assigns T)
+ (unopt_rep R1)
+ |> opt ? opt_rep ofs T
+ in s_op2 Apply T ran_R u1 u2 end
+ | Op2 (Lambda, T, _, u1, u2) =>
+ (case best_set_rep_for_type scope T of
+ Unit => Cst (Unity, T, Unit)
+ | R as Func (R1, _) =>
+ let
+ val table' = NameTable.update (u1, R1) table
+ val u1' = aux table' false Neut u1
+ val u2' = aux table' false Neut u2
+ val R =
+ if is_opt_rep (rep_of u2')
+ orelse (range_type T = bool_T andalso
+ not (is_Cst False
+ (unrepify_nut_in_nut table false Neut
+ u1 u2
+ |> optimize_nut))) then
+ opt_rep ofs T R
+ else
+ unopt_rep R
+ in s_op2 Lambda T R u1' u2' end
+ | R => raise NUT ("NitpickNut.aux.choose_reps_in_nut", [u]))
+ | Op2 (oper, T, _, u1, u2) =>
+ if oper mem [All, Exist] then
+ let
+ val table' = fold (choose_rep_for_bound_var scope) (untuple I u1)
+ table
+ val u1' = aux table' def polar u1
+ val u2' = aux table' def polar u2
+ in
+ if polar = Neut andalso is_opt_rep (rep_of u2') then
+ triad_fn (fn polar => gsub def polar u)
+ else
+ let val quant_u = s_op2 oper T (Formula polar) u1' u2' in
+ if def
+ orelse (liberal andalso (polar = Pos) = (oper = All))
+ orelse is_precise_type datatypes (type_of u1) then
+ quant_u
+ else
+ let
+ val connective = if oper = All then And else Or
+ val unrepified_u = unrepify_nut_in_nut table def polar
+ u1 u2
+ in
+ s_op2 connective T
+ (min_rep (rep_of quant_u) (rep_of unrepified_u))
+ quant_u unrepified_u
+ end
+ end
+ end
+ else if oper mem [Or, And] then
+ let
+ val u1' = gsub def polar u1
+ val u2' = gsub def polar u2
+ in
+ (if polar = Neut then
+ case (is_opt_rep (rep_of u1'), is_opt_rep (rep_of u2')) of
+ (true, true) => triad_fn (fn polar => gsub def polar u)
+ | (true, false) =>
+ s_op2 oper T (Opt bool_atom_R)
+ (triad_fn (fn polar => gsub def polar u1)) u2'
+ | (false, true) =>
+ s_op2 oper T (Opt bool_atom_R)
+ u1' (triad_fn (fn polar => gsub def polar u2))
+ | (false, false) => raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => s_op2 oper T (Formula polar) u1' u2'
+ end
+ else if oper mem [The, Eps] then
+ let
+ val u1' = sub u1
+ val opt1 = is_opt_rep (rep_of u1')
+ val unopt_R = best_one_rep_for_type scope T |> optable_rep ofs T
+ val R = unopt_R |> (oper = Eps orelse opt1) ? opt_rep ofs T
+ val u = Op2 (oper, T, R, u1', sub u2)
+ in
+ if is_precise_type datatypes T orelse not opt1 then
+ u
+ else
+ let
+ val x_u = BoundName (~1, T, unopt_R, "descr.x")
+ val R = R |> opt_rep ofs T
+ in
+ Op3 (If, T, R,
+ Op2 (Exist, bool_T, Formula Pos, x_u,
+ s_op2 Apply bool_T (Formula Pos) (gsub false Pos u1)
+ x_u), u, Cst (Unknown, T, R))
+ end
+ end
+ else
+ let
+ val u1 = sub u1
+ val u2 = sub u2
+ val R =
+ best_non_opt_set_rep_for_type scope T
+ |> exists (is_opt_rep o rep_of) [u1, u2] ? opt_rep ofs T
+ in s_op2 oper T R u1 u2 end
+ | Op3 (Let, T, _, u1, u2, u3) =>
+ let
+ val u2 = sub u2
+ val R2 = rep_of u2
+ val table' = NameTable.update (u1, R2) table
+ val u1 = modify_name_rep u1 R2
+ val u3 = aux table' false polar u3
+ in s_op3 Let T (rep_of u3) u1 u2 u3 end
+ | Op3 (If, T, _, u1, u2, u3) =>
+ let
+ val u1 = sub u1
+ val u2 = gsub def polar u2
+ val u3 = gsub def polar u3
+ val min_R = min_rep (rep_of u2) (rep_of u3)
+ val R = min_R |> is_opt_rep (rep_of u1) ? opt_rep ofs T
+ in s_op3 If T R u1 u2 u3 end
+ | Tuple (T, _, us) =>
+ let
+ val Rs = map (best_one_rep_for_type scope o type_of) us
+ val us = map sub us
+ val R = if forall (equal Unit) Rs then Unit else Struct Rs
+ val R' = (exists (is_opt_rep o rep_of) us ? opt_rep ofs T) R
+ in s_tuple T R' us end
+ | Construct (us', T, _, us) =>
+ let
+ val us = map sub us
+ val Rs = map rep_of us
+ val R = best_one_rep_for_type scope T
+ val {total, ...} =
+ constr_spec datatypes (original_name (nickname_of (hd us')), T)
+ val opt = exists is_opt_rep Rs orelse not total
+ in Construct (map sub us', T, R |> opt ? Opt, us) end
+ | _ =>
+ let val u = modify_name_rep u (the_name table u) in
+ if polar = Neut orelse not (is_boolean_type (type_of u))
+ orelse not (is_opt_rep (rep_of u)) then
+ u
+ else
+ s_op1 Cast (type_of u) (Formula polar) u
+ end
+ end
+ |> optimize_unit
+ in aux table def Pos end
+
+(* int -> Kodkod.n_ary_index list -> Kodkod.n_ary_index list
+ -> int * Kodkod.n_ary_index list *)
+fun fresh_n_ary_index n [] ys = (0, (n, 1) :: ys)
+ | fresh_n_ary_index n ((m, j) :: xs) ys =
+ if m = n then (j, ys @ ((m, j + 1) :: xs))
+ else fresh_n_ary_index n xs ((m, j) :: ys)
+(* int -> name_pool -> int * name_pool *)
+fun fresh_rel n {rels, vars, formula_reg, rel_reg} =
+ let val (j, rels') = fresh_n_ary_index n rels [] in
+ (j, {rels = rels', vars = vars, formula_reg = formula_reg,
+ rel_reg = rel_reg})
+ end
+(* int -> name_pool -> int * name_pool *)
+fun fresh_var n {rels, vars, formula_reg, rel_reg} =
+ let val (j, vars') = fresh_n_ary_index n vars [] in
+ (j, {rels = rels, vars = vars', formula_reg = formula_reg,
+ rel_reg = rel_reg})
+ end
+(* int -> name_pool -> int * name_pool *)
+fun fresh_formula_reg {rels, vars, formula_reg, rel_reg} =
+ (formula_reg, {rels = rels, vars = vars, formula_reg = formula_reg + 1,
+ rel_reg = rel_reg})
+(* int -> name_pool -> int * name_pool *)
+fun fresh_rel_reg {rels, vars, formula_reg, rel_reg} =
+ (rel_reg, {rels = rels, vars = vars, formula_reg = formula_reg,
+ rel_reg = rel_reg + 1})
+
+(* nut -> nut list * name_pool * nut NameTable.table
+ -> nut list * name_pool * nut NameTable.table *)
+fun rename_plain_var v (ws, pool, table) =
+ let
+ val is_formula = (rep_of v = Formula Neut)
+ val fresh = if is_formula then fresh_formula_reg else fresh_rel_reg
+ val (j, pool) = fresh pool
+ val constr = if is_formula then FormulaReg else RelReg
+ val w = constr (j, type_of v, rep_of v)
+ in (w :: ws, pool, NameTable.update (v, w) table) end
+
+(* typ -> rep -> nut list -> nut *)
+fun shape_tuple (T as Type ("*", [T1, T2])) (R as Struct [R1, R2]) us =
+ let val arity1 = arity_of_rep R1 in
+ Tuple (T, R, [shape_tuple T1 R1 (List.take (us, arity1)),
+ shape_tuple T2 R2 (List.drop (us, arity1))])
+ end
+ | shape_tuple (T as Type ("fun", [_, T2])) (R as Vect (k, R')) us =
+ Tuple (T, R, map (shape_tuple T2 R') (batch_list (length us div k) us))
+ | shape_tuple T R [u] =
+ if type_of u = T then u else raise NUT ("NitpickNut.shape_tuple", [u])
+ | shape_tuple T Unit [] = Cst (Unity, T, Unit)
+ | shape_tuple _ _ us = raise NUT ("NitpickNut.shape_tuple", us)
+
+(* bool -> nut -> nut list * name_pool * nut NameTable.table
+ -> nut list * name_pool * nut NameTable.table *)
+fun rename_n_ary_var rename_free v (ws, pool, table) =
+ let
+ val T = type_of v
+ val R = rep_of v
+ val arity = arity_of_rep R
+ val nick = nickname_of v
+ val (constr, fresh) = if rename_free then (FreeRel, fresh_rel)
+ else (BoundRel, fresh_var)
+ in
+ if not rename_free andalso arity > 1 then
+ let
+ val atom_schema = atom_schema_of_rep R
+ val type_schema = type_schema_of_rep T R
+ val (js, pool) = funpow arity (fn (js, pool) =>
+ let val (j, pool) = fresh 1 pool in
+ (j :: js, pool)
+ end)
+ ([], pool)
+ val ws' = map3 (fn j => fn x => fn T =>
+ constr ((1, j), T, Atom x,
+ nick ^ " [" ^ string_of_int j ^ "]"))
+ (rev js) atom_schema type_schema
+ in (ws' @ ws, pool, NameTable.update (v, shape_tuple T R ws') table) end
+ else
+ let
+ val (j, pool) = fresh arity pool
+ val w = constr ((arity, j), T, R, nick)
+ in (w :: ws, pool, NameTable.update (v, w) table) end
+ end
+
+(* nut list -> name_pool -> nut NameTable.table
+ -> nut list * name_pool * nut NameTable.table *)
+fun rename_free_vars vs pool table =
+ let
+ val vs = filter (not_equal Unit o rep_of) vs
+ val (vs, pool, table) = fold (rename_n_ary_var true) vs ([], pool, table)
+ in (rev vs, pool, table) end
+
+(* name_pool -> nut NameTable.table -> nut -> nut *)
+fun rename_vars_in_nut pool table u =
+ case u of
+ Cst _ => u
+ | Op1 (oper, T, R, u1) => Op1 (oper, T, R, rename_vars_in_nut pool table u1)
+ | Op2 (oper, T, R, u1, u2) =>
+ if oper mem [All, Exist, Lambda] then
+ let
+ val (_, pool, table) = fold (rename_n_ary_var false) (untuple I u1)
+ ([], pool, table)
+ in
+ Op2 (oper, T, R, rename_vars_in_nut pool table u1,
+ rename_vars_in_nut pool table u2)
+ end
+ else
+ Op2 (oper, T, R, rename_vars_in_nut pool table u1,
+ rename_vars_in_nut pool table u2)
+ | Op3 (Let, T, R, u1, u2, u3) =>
+ if rep_of u2 = Unit orelse inline_nut u2 then
+ let
+ val u2 = rename_vars_in_nut pool table u2
+ val table = NameTable.update (u1, u2) table
+ in rename_vars_in_nut pool table u3 end
+ else
+ let
+ val bs = untuple I u1
+ val (_, pool, table') = fold rename_plain_var bs ([], pool, table)
+ val u11 = rename_vars_in_nut pool table' u1
+ in
+ Op3 (Let, T, R, rename_vars_in_nut pool table' u1,
+ rename_vars_in_nut pool table u2,
+ rename_vars_in_nut pool table' u3)
+ end
+ | Op3 (oper, T, R, u1, u2, u3) =>
+ Op3 (oper, T, R, rename_vars_in_nut pool table u1,
+ rename_vars_in_nut pool table u2, rename_vars_in_nut pool table u3)
+ | Tuple (T, R, us) => Tuple (T, R, map (rename_vars_in_nut pool table) us)
+ | Construct (us', T, R, us) =>
+ Construct (map (rename_vars_in_nut pool table) us', T, R,
+ map (rename_vars_in_nut pool table) us)
+ | _ => the_name table u
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_peephole.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,643 @@
+(* Title: HOL/Nitpick/Tools/nitpick_peephole.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Peephole optimizer for Nitpick.
+*)
+
+signature NITPICK_PEEPHOLE =
+sig
+ type formula = Kodkod.formula
+ type int_expr = Kodkod.int_expr
+ type rel_expr = Kodkod.rel_expr
+ type decl = Kodkod.decl
+ type expr_assign = Kodkod.expr_assign
+
+ type name_pool = {
+ rels: Kodkod.n_ary_index list,
+ vars: Kodkod.n_ary_index list,
+ formula_reg: int,
+ rel_reg: int}
+
+ val initial_pool : name_pool
+ val not3_rel : rel_expr
+ val suc_rel : rel_expr
+ val nat_add_rel : rel_expr
+ val int_add_rel : rel_expr
+ val nat_subtract_rel : rel_expr
+ val int_subtract_rel : rel_expr
+ val nat_multiply_rel : rel_expr
+ val int_multiply_rel : rel_expr
+ val nat_divide_rel : rel_expr
+ val int_divide_rel : rel_expr
+ val nat_modulo_rel : rel_expr
+ val int_modulo_rel : rel_expr
+ val nat_less_rel : rel_expr
+ val int_less_rel : rel_expr
+ val gcd_rel : rel_expr
+ val lcm_rel : rel_expr
+ val norm_frac_rel : rel_expr
+ val atom_for_bool : int -> bool -> rel_expr
+ val formula_for_bool : bool -> formula
+ val atom_for_nat : int * int -> int -> int
+ val min_int_for_card : int -> int
+ val max_int_for_card : int -> int
+ val int_for_atom : int * int -> int -> int
+ val atom_for_int : int * int -> int -> int
+ val inline_rel_expr : rel_expr -> bool
+ val empty_n_ary_rel : int -> rel_expr
+ val num_seq : int -> int -> int_expr list
+ val s_and : formula -> formula -> formula
+
+ type kodkod_constrs = {
+ kk_all: decl list -> formula -> formula,
+ kk_exist: decl list -> formula -> formula,
+ kk_formula_let: expr_assign list -> formula -> formula,
+ kk_formula_if: formula -> formula -> formula -> formula,
+ kk_or: formula -> formula -> formula,
+ kk_not: formula -> formula,
+ kk_iff: formula -> formula -> formula,
+ kk_implies: formula -> formula -> formula,
+ kk_and: formula -> formula -> formula,
+ kk_subset: rel_expr -> rel_expr -> formula,
+ kk_rel_eq: rel_expr -> rel_expr -> formula,
+ kk_no: rel_expr -> formula,
+ kk_lone: rel_expr -> formula,
+ kk_one: rel_expr -> formula,
+ kk_some: rel_expr -> formula,
+ kk_rel_let: expr_assign list -> rel_expr -> rel_expr,
+ kk_rel_if: formula -> rel_expr -> rel_expr -> rel_expr,
+ kk_union: rel_expr -> rel_expr -> rel_expr,
+ kk_difference: rel_expr -> rel_expr -> rel_expr,
+ kk_override: rel_expr -> rel_expr -> rel_expr,
+ kk_intersect: rel_expr -> rel_expr -> rel_expr,
+ kk_product: rel_expr -> rel_expr -> rel_expr,
+ kk_join: rel_expr -> rel_expr -> rel_expr,
+ kk_closure: rel_expr -> rel_expr,
+ kk_reflexive_closure: rel_expr -> rel_expr,
+ kk_comprehension: decl list -> formula -> rel_expr,
+ kk_project: rel_expr -> int_expr list -> rel_expr,
+ kk_project_seq: rel_expr -> int -> int -> rel_expr,
+ kk_not3: rel_expr -> rel_expr,
+ kk_nat_less: rel_expr -> rel_expr -> rel_expr,
+ kk_int_less: rel_expr -> rel_expr -> rel_expr
+ }
+
+ val kodkod_constrs : bool -> int -> int -> int -> kodkod_constrs
+end;
+
+structure NitpickPeephole : NITPICK_PEEPHOLE =
+struct
+
+open Kodkod
+open NitpickUtil
+
+type name_pool = {
+ rels: n_ary_index list,
+ vars: n_ary_index list,
+ formula_reg: int,
+ rel_reg: int}
+
+(* If you add new built-in relations, make sure to increment the counters here
+ as well to avoid name clashes (which fortunately would be detected by
+ Kodkodi). *)
+val initial_pool =
+ {rels = [(2, 10), (3, 20), (4, 10)], vars = [], formula_reg = 10,
+ rel_reg = 10}
+
+val not3_rel = Rel (2, 0)
+val suc_rel = Rel (2, 1)
+val nat_add_rel = Rel (3, 0)
+val int_add_rel = Rel (3, 1)
+val nat_subtract_rel = Rel (3, 2)
+val int_subtract_rel = Rel (3, 3)
+val nat_multiply_rel = Rel (3, 4)
+val int_multiply_rel = Rel (3, 5)
+val nat_divide_rel = Rel (3, 6)
+val int_divide_rel = Rel (3, 7)
+val nat_modulo_rel = Rel (3, 8)
+val int_modulo_rel = Rel (3, 9)
+val nat_less_rel = Rel (3, 10)
+val int_less_rel = Rel (3, 11)
+val gcd_rel = Rel (3, 12)
+val lcm_rel = Rel (3, 13)
+val norm_frac_rel = Rel (4, 0)
+
+(* int -> bool -> rel_expr *)
+fun atom_for_bool j0 = Atom o Integer.add j0 o int_for_bool
+(* bool -> formula *)
+fun formula_for_bool b = if b then True else False
+
+(* int * int -> int -> int *)
+fun atom_for_nat (k, j0) n = if n < 0 orelse n >= k then ~1 else n + j0
+(* int -> int *)
+fun min_int_for_card k = ~k div 2 + 1
+fun max_int_for_card k = k div 2
+(* int * int -> int -> int *)
+fun int_for_atom (k, j0) j =
+ let val j = j - j0 in if j <= max_int_for_card k then j else j - k end
+fun atom_for_int (k, j0) n =
+ if n < min_int_for_card k orelse n > max_int_for_card k then ~1
+ else if n < 0 then n + k + j0
+ else n + j0
+
+(* rel_expr -> bool *)
+fun is_none_product (Product (r1, r2)) =
+ is_none_product r1 orelse is_none_product r2
+ | is_none_product None = true
+ | is_none_product _ = false
+
+(* rel_expr -> bool *)
+fun is_one_rel_expr (Atom _) = true
+ | is_one_rel_expr (AtomSeq (1, _)) = true
+ | is_one_rel_expr (Var _) = true
+ | is_one_rel_expr _ = false
+
+(* rel_expr -> bool *)
+fun inline_rel_expr (Product (r1, r2)) =
+ inline_rel_expr r1 andalso inline_rel_expr r2
+ | inline_rel_expr Iden = true
+ | inline_rel_expr Ints = true
+ | inline_rel_expr None = true
+ | inline_rel_expr Univ = true
+ | inline_rel_expr (Atom _) = true
+ | inline_rel_expr (AtomSeq _) = true
+ | inline_rel_expr (Rel _) = true
+ | inline_rel_expr (Var _) = true
+ | inline_rel_expr (RelReg _) = true
+ | inline_rel_expr _ = false
+
+(* rel_expr -> rel_expr -> bool option *)
+fun rel_expr_equal None (Atom _) = SOME false
+ | rel_expr_equal None (AtomSeq (k, _)) = SOME (k = 0)
+ | rel_expr_equal (Atom _) None = SOME false
+ | rel_expr_equal (AtomSeq (k, _)) None = SOME (k = 0)
+ | rel_expr_equal (Atom j1) (Atom j2) = SOME (j1 = j2)
+ | rel_expr_equal (Atom j) (AtomSeq (k, j0)) = SOME (j = j0 andalso k = 1)
+ | rel_expr_equal (AtomSeq (k, j0)) (Atom j) = SOME (j = j0 andalso k = 1)
+ | rel_expr_equal (AtomSeq x1) (AtomSeq x2) = SOME (x1 = x2)
+ | rel_expr_equal r1 r2 = if r1 = r2 then SOME true else NONE
+
+(* rel_expr -> rel_expr -> bool option *)
+fun rel_expr_intersects (Atom j1) (Atom j2) = SOME (j1 = j2)
+ | rel_expr_intersects (Atom j) (AtomSeq (k, j0)) = SOME (j < j0 + k)
+ | rel_expr_intersects (AtomSeq (k, j0)) (Atom j) = SOME (j < j0 + k)
+ | rel_expr_intersects (AtomSeq (k1, j01)) (AtomSeq (k2, j02)) =
+ SOME (k1 > 0 andalso k2 > 0 andalso j01 + k1 > j02 andalso j02 + k2 > j01)
+ | rel_expr_intersects r1 r2 =
+ if is_none_product r1 orelse is_none_product r2 then SOME false else NONE
+
+(* int -> rel_expr *)
+fun empty_n_ary_rel 0 = raise ARG ("NitpickPeephole.empty_n_ary_rel", "0")
+ | empty_n_ary_rel n = funpow (n - 1) (curry Product None) None
+
+(* decl -> rel_expr *)
+fun decl_one_set (DeclOne (_, r)) = r
+ | decl_one_set _ =
+ raise ARG ("NitpickPeephole.decl_one_set", "not \"DeclOne\"")
+
+(* int_expr -> bool *)
+fun is_Num (Num _) = true
+ | is_Num _ = false
+(* int_expr -> int *)
+fun dest_Num (Num k) = k
+ | dest_Num _ = raise ARG ("NitpickPeephole.dest_Num", "not \"Num\"")
+(* int -> int -> int_expr list *)
+fun num_seq j0 n = map Num (index_seq j0 n)
+
+(* rel_expr -> rel_expr -> bool *)
+fun occurs_in_union r (Union (r1, r2)) =
+ occurs_in_union r r1 orelse occurs_in_union r r2
+ | occurs_in_union r r' = (r = r')
+
+(* rel_expr -> rel_expr -> rel_expr *)
+fun s_and True f2 = f2
+ | s_and False _ = False
+ | s_and f1 True = f1
+ | s_and _ False = False
+ | s_and f1 f2 = And (f1, f2)
+
+type kodkod_constrs = {
+ kk_all: decl list -> formula -> formula,
+ kk_exist: decl list -> formula -> formula,
+ kk_formula_let: expr_assign list -> formula -> formula,
+ kk_formula_if: formula -> formula -> formula -> formula,
+ kk_or: formula -> formula -> formula,
+ kk_not: formula -> formula,
+ kk_iff: formula -> formula -> formula,
+ kk_implies: formula -> formula -> formula,
+ kk_and: formula -> formula -> formula,
+ kk_subset: rel_expr -> rel_expr -> formula,
+ kk_rel_eq: rel_expr -> rel_expr -> formula,
+ kk_no: rel_expr -> formula,
+ kk_lone: rel_expr -> formula,
+ kk_one: rel_expr -> formula,
+ kk_some: rel_expr -> formula,
+ kk_rel_let: expr_assign list -> rel_expr -> rel_expr,
+ kk_rel_if: formula -> rel_expr -> rel_expr -> rel_expr,
+ kk_union: rel_expr -> rel_expr -> rel_expr,
+ kk_difference: rel_expr -> rel_expr -> rel_expr,
+ kk_override: rel_expr -> rel_expr -> rel_expr,
+ kk_intersect: rel_expr -> rel_expr -> rel_expr,
+ kk_product: rel_expr -> rel_expr -> rel_expr,
+ kk_join: rel_expr -> rel_expr -> rel_expr,
+ kk_closure: rel_expr -> rel_expr,
+ kk_reflexive_closure: rel_expr -> rel_expr,
+ kk_comprehension: decl list -> formula -> rel_expr,
+ kk_project: rel_expr -> int_expr list -> rel_expr,
+ kk_project_seq: rel_expr -> int -> int -> rel_expr,
+ kk_not3: rel_expr -> rel_expr,
+ kk_nat_less: rel_expr -> rel_expr -> rel_expr,
+ kk_int_less: rel_expr -> rel_expr -> rel_expr
+}
+
+(* We assume throughout that Kodkod variables have a "one" constraint. This is
+ always the case if Kodkod's skolemization is disabled. *)
+(* bool -> int -> int -> int -> kodkod_constrs *)
+fun kodkod_constrs optim nat_card int_card main_j0 =
+ let
+ val false_atom = Atom main_j0
+ val true_atom = Atom (main_j0 + 1)
+
+ (* bool -> int *)
+ val from_bool = atom_for_bool main_j0
+ (* int -> Kodkod.rel_expr *)
+ fun from_nat n = Atom (n + main_j0)
+ val from_int = Atom o atom_for_int (int_card, main_j0)
+ (* int -> int *)
+ fun to_nat j = j - main_j0
+ val to_int = int_for_atom (int_card, main_j0)
+
+ (* decl list -> formula -> formula *)
+ fun s_all _ True = True
+ | s_all _ False = False
+ | s_all [] f = f
+ | s_all ds (All (ds', f)) = All (ds @ ds', f)
+ | s_all ds f = All (ds, f)
+ fun s_exist _ True = True
+ | s_exist _ False = False
+ | s_exist [] f = f
+ | s_exist ds (Exist (ds', f)) = Exist (ds @ ds', f)
+ | s_exist ds f = Exist (ds, f)
+
+ (* expr_assign list -> formula -> formula *)
+ fun s_formula_let _ True = True
+ | s_formula_let _ False = False
+ | s_formula_let assigns f = FormulaLet (assigns, f)
+
+ (* formula -> formula *)
+ fun s_not True = False
+ | s_not False = True
+ | s_not (All (ds, f)) = Exist (ds, s_not f)
+ | s_not (Exist (ds, f)) = All (ds, s_not f)
+ | s_not (Or (f1, f2)) = And (s_not f1, s_not f2)
+ | s_not (Implies (f1, f2)) = And (f1, s_not f2)
+ | s_not (And (f1, f2)) = Or (s_not f1, s_not f2)
+ | s_not (Not f) = f
+ | s_not (No r) = Some r
+ | s_not (Some r) = No r
+ | s_not f = Not f
+
+ (* formula -> formula -> formula *)
+ fun s_or True _ = True
+ | s_or False f2 = f2
+ | s_or _ True = True
+ | s_or f1 False = f1
+ | s_or f1 f2 = if f1 = f2 then f1 else Or (f1, f2)
+ fun s_iff True f2 = f2
+ | s_iff False f2 = s_not f2
+ | s_iff f1 True = f1
+ | s_iff f1 False = s_not f1
+ | s_iff f1 f2 = if f1 = f2 then True else Iff (f1, f2)
+ fun s_implies True f2 = f2
+ | s_implies False _ = True
+ | s_implies _ True = True
+ | s_implies f1 False = s_not f1
+ | s_implies f1 f2 = if f1 = f2 then True else Implies (f1, f2)
+
+ (* formula -> formula -> formula -> formula *)
+ fun s_formula_if True f2 _ = f2
+ | s_formula_if False _ f3 = f3
+ | s_formula_if f1 True f3 = s_or f1 f3
+ | s_formula_if f1 False f3 = s_and (s_not f1) f3
+ | s_formula_if f1 f2 True = s_implies f1 f2
+ | s_formula_if f1 f2 False = s_and f1 f2
+ | s_formula_if f f1 f2 = FormulaIf (f, f1, f2)
+
+ (* rel_expr -> int_expr list -> rel_expr *)
+ fun s_project r is =
+ (case r of
+ Project (r1, is') =>
+ if forall is_Num is then
+ s_project r1 (map (nth is' o dest_Num) is)
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ let val n = length is in
+ if arity_of_rel_expr r = n andalso is = num_seq 0 n then r
+ else Project (r, is)
+ end
+
+ (* rel_expr -> formula *)
+ fun s_no None = True
+ | s_no (Product (r1, r2)) = s_or (s_no r1) (s_no r2)
+ | s_no (Intersect (Closure (Kodkod.Rel x), Kodkod.Iden)) = Acyclic x
+ | s_no r = if is_one_rel_expr r then False else No r
+ fun s_lone None = True
+ | s_lone r = if is_one_rel_expr r then True else Lone r
+ fun s_one None = False
+ | s_one r =
+ if is_one_rel_expr r then
+ True
+ else if inline_rel_expr r then
+ case arity_of_rel_expr r of
+ 1 => One r
+ | arity => foldl1 And (map (One o s_project r o single o Num)
+ (index_seq 0 arity))
+ else
+ One r
+ fun s_some None = False
+ | s_some (Atom _) = True
+ | s_some (Product (r1, r2)) = s_and (s_some r1) (s_some r2)
+ | s_some r = if is_one_rel_expr r then True else Some r
+
+ (* rel_expr -> rel_expr *)
+ fun s_not3 (Atom j) = Atom (if j = main_j0 then j + 1 else j - 1)
+ | s_not3 (r as Join (r1, r2)) =
+ if r2 = not3_rel then r1 else Join (r, not3_rel)
+ | s_not3 r = Join (r, not3_rel)
+
+ (* rel_expr -> rel_expr -> formula *)
+ fun s_rel_eq r1 r2 =
+ (case (r1, r2) of
+ (Join (r11, r12), _) =>
+ if r12 = not3_rel then s_rel_eq r11 (s_not3 r2) else raise SAME ()
+ | (_, Join (r21, r22)) =>
+ if r22 = not3_rel then s_rel_eq r21 (s_not3 r1) else raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ case rel_expr_equal r1 r2 of
+ SOME true => True
+ | SOME false => False
+ | NONE =>
+ case (r1, r2) of
+ (_, RelIf (f, r21, r22)) =>
+ if inline_rel_expr r1 then
+ s_formula_if f (s_rel_eq r1 r21) (s_rel_eq r1 r22)
+ else
+ RelEq (r1, r2)
+ | (RelIf (f, r11, r12), _) =>
+ if inline_rel_expr r2 then
+ s_formula_if f (s_rel_eq r11 r2) (s_rel_eq r12 r2)
+ else
+ RelEq (r1, r2)
+ | (_, Kodkod.None) => s_no r1
+ | (Kodkod.None, _) => s_no r2
+ | _ => RelEq (r1, r2)
+ fun s_subset (Atom j1) (Atom j2) = formula_for_bool (j1 = j2)
+ | s_subset (Atom j) (AtomSeq (k, j0)) =
+ formula_for_bool (j >= j0 andalso j < j0 + k)
+ | s_subset (r1 as Union (r11, r12)) r2 =
+ s_and (s_subset r11 r2) (s_subset r12 r2)
+ | s_subset r1 (r2 as Union (r21, r22)) =
+ if is_one_rel_expr r1 then
+ s_or (s_subset r1 r21) (s_subset r1 r22)
+ else
+ if s_subset r1 r21 = True orelse s_subset r1 r22 = True
+ orelse r1 = r2 then
+ True
+ else
+ Subset (r1, r2)
+ | s_subset r1 r2 =
+ if r1 = r2 orelse is_none_product r1 then True
+ else if is_none_product r2 then s_no r1
+ else if forall is_one_rel_expr [r1, r2] then s_rel_eq r1 r2
+ else Subset (r1, r2)
+
+ (* expr_assign list -> rel_expr -> rel_expr *)
+ fun s_rel_let [b as AssignRelReg (x', r')] (r as RelReg x) =
+ if x = x' then r' else RelLet ([b], r)
+ | s_rel_let bs r = RelLet (bs, r)
+
+ (* formula -> rel_expr -> rel_expr -> rel_expr *)
+ fun s_rel_if f r1 r2 =
+ (case (f, r1, r2) of
+ (True, _, _) => r1
+ | (False, _, _) => r2
+ | (No r1', None, RelIf (One r2', r3', r4')) =>
+ if r1' = r2' andalso r2' = r3' then s_rel_if (Lone r1') r1' r4'
+ else raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => if r1 = r2 then r1 else RelIf (f, r1, r2)
+
+ (* rel_expr -> rel_expr -> rel_expr *)
+ fun s_union r1 (Union (r21, r22)) = s_union (s_union r1 r21) r22
+ | s_union r1 r2 =
+ if is_none_product r1 then r2
+ else if is_none_product r2 then r1
+ else if r1 = r2 then r1
+ else if occurs_in_union r2 r1 then r1
+ else Union (r1, r2)
+ fun s_difference r1 r2 =
+ if is_none_product r1 orelse is_none_product r2 then r1
+ else if r1 = r2 then empty_n_ary_rel (arity_of_rel_expr r1)
+ else Difference (r1, r2)
+ fun s_override r1 r2 =
+ if is_none_product r2 then r1
+ else if is_none_product r1 then r2
+ else Override (r1, r2)
+ fun s_intersect r1 r2 =
+ case rel_expr_intersects r1 r2 of
+ SOME true => if r1 = r2 then r1 else Intersect (r1, r2)
+ | SOME false => empty_n_ary_rel (arity_of_rel_expr r1)
+ | NONE => if is_none_product r1 then r1
+ else if is_none_product r2 then r2
+ else Intersect (r1, r2)
+ fun s_product r1 r2 =
+ if is_none_product r1 then
+ Product (r1, empty_n_ary_rel (arity_of_rel_expr r2))
+ else if is_none_product r2 then
+ Product (empty_n_ary_rel (arity_of_rel_expr r1), r2)
+ else
+ Product (r1, r2)
+ fun s_join r1 (Product (Product (r211, r212), r22)) =
+ Product (s_join r1 (Product (r211, r212)), r22)
+ | s_join (Product (r11, Product (r121, r122))) r2 =
+ Product (r11, s_join (Product (r121, r122)) r2)
+ | s_join None r = empty_n_ary_rel (arity_of_rel_expr r - 1)
+ | s_join r None = empty_n_ary_rel (arity_of_rel_expr r - 1)
+ | s_join (Product (None, None)) r = empty_n_ary_rel (arity_of_rel_expr r)
+ | s_join r (Product (None, None)) = empty_n_ary_rel (arity_of_rel_expr r)
+ | s_join Iden r2 = r2
+ | s_join r1 Iden = r1
+ | s_join (Product (r1, r2)) Univ =
+ if arity_of_rel_expr r2 = 1 then r1
+ else Product (r1, s_join r2 Univ)
+ | s_join Univ (Product (r1, r2)) =
+ if arity_of_rel_expr r1 = 1 then r2
+ else Product (s_join Univ r1, r2)
+ | s_join r1 (r2 as Product (r21, r22)) =
+ if arity_of_rel_expr r1 = 1 then
+ case rel_expr_intersects r1 r21 of
+ SOME true => r22
+ | SOME false => empty_n_ary_rel (arity_of_rel_expr r2 - 1)
+ | NONE => Join (r1, r2)
+ else
+ Join (r1, r2)
+ | s_join (r1 as Product (r11, r12)) r2 =
+ if arity_of_rel_expr r2 = 1 then
+ case rel_expr_intersects r2 r12 of
+ SOME true => r11
+ | SOME false => empty_n_ary_rel (arity_of_rel_expr r1 - 1)
+ | NONE => Join (r1, r2)
+ else
+ Join (r1, r2)
+ | s_join r1 (r2 as RelIf (f, r21, r22)) =
+ if inline_rel_expr r1 then s_rel_if f (s_join r1 r21) (s_join r1 r22)
+ else Join (r1, r2)
+ | s_join (r1 as RelIf (f, r11, r12)) r2 =
+ if inline_rel_expr r2 then s_rel_if f (s_join r11 r2) (s_join r12 r2)
+ else Join (r1, r2)
+ | s_join (r1 as Atom j1) (r2 as Rel (2, j2)) =
+ if r2 = suc_rel then
+ let val n = to_nat j1 + 1 in
+ if n < nat_card then from_nat n else None
+ end
+ else
+ Join (r1, r2)
+ | s_join r1 (r2 as Project (r21, Num k :: is)) =
+ if k = arity_of_rel_expr r21 - 1 andalso arity_of_rel_expr r1 = 1 then
+ s_project (s_join r21 r1) is
+ else
+ Join (r1, r2)
+ | s_join r1 (Join (r21, r22 as Rel (3, j22))) =
+ ((if r22 = nat_add_rel then
+ case (r21, r1) of
+ (Atom j1, Atom j2) =>
+ let val n = to_nat j1 + to_nat j2 in
+ if n < nat_card then from_nat n else None
+ end
+ | (Atom j, r) =>
+ (case to_nat j of
+ 0 => r
+ | 1 => s_join r suc_rel
+ | _ => raise SAME ())
+ | (r, Atom j) =>
+ (case to_nat j of
+ 0 => r
+ | 1 => s_join r suc_rel
+ | _ => raise SAME ())
+ | _ => raise SAME ()
+ else if r22 = nat_subtract_rel then
+ case (r21, r1) of
+ (Atom j1, Atom j2) => from_nat (to_nat j1 nat_minus to_nat j2)
+ | _ => raise SAME ()
+ else if r22 = nat_multiply_rel then
+ case (r21, r1) of
+ (Atom j1, Atom j2) =>
+ let val n = to_nat j1 * to_nat j2 in
+ if n < nat_card then from_nat n else None
+ end
+ | (Atom j, r) =>
+ (case to_nat j of 0 => Atom j | 1 => r | _ => raise SAME ())
+ | (r, Atom j) =>
+ (case to_nat j of 0 => Atom j | 1 => r | _ => raise SAME ())
+ | _ => raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => List.foldr Join r22 [r1, r21])
+ | s_join r1 r2 = Join (r1, r2)
+
+ (* rel_expr -> rel_expr *)
+ fun s_closure Iden = Iden
+ | s_closure r = if is_none_product r then r else Closure r
+ fun s_reflexive_closure Iden = Iden
+ | s_reflexive_closure r =
+ if is_none_product r then Iden else ReflexiveClosure r
+
+ (* decl list -> formula -> rel_expr *)
+ fun s_comprehension ds False = empty_n_ary_rel (length ds)
+ | s_comprehension ds True = fold1 s_product (map decl_one_set ds)
+ | s_comprehension [d as DeclOne ((1, j1), r)]
+ (f as RelEq (Var (1, j2), Atom j)) =
+ if j1 = j2 andalso rel_expr_intersects (Atom j) r = SOME true then
+ Atom j
+ else
+ Comprehension ([d], f)
+ | s_comprehension ds f = Comprehension (ds, f)
+
+ (* rel_expr -> int -> int -> rel_expr *)
+ fun s_project_seq r =
+ let
+ (* int -> rel_expr -> int -> int -> rel_expr *)
+ fun aux arity r j0 n =
+ if j0 = 0 andalso arity = n then
+ r
+ else case r of
+ RelIf (f, r1, r2) =>
+ s_rel_if f (aux arity r1 j0 n) (aux arity r2 j0 n)
+ | Product (r1, r2) =>
+ let
+ val arity2 = arity_of_rel_expr r2
+ val arity1 = arity - arity2
+ val n1 = Int.min (arity1 nat_minus j0, n)
+ val n2 = n - n1
+ (* unit -> rel_expr *)
+ fun one () = aux arity1 r1 j0 n1
+ fun two () = aux arity2 r2 (j0 nat_minus arity1) n2
+ in
+ case (n1, n2) of
+ (0, _) => s_rel_if (s_some r1) (two ()) (empty_n_ary_rel n2)
+ | (_, 0) => s_rel_if (s_some r2) (one ()) (empty_n_ary_rel n1)
+ | _ => s_product (one ()) (two ())
+ end
+ | _ => s_project r (num_seq j0 n)
+ in aux (arity_of_rel_expr r) r end
+
+ (* rel_expr -> rel_expr -> rel_expr *)
+ fun s_nat_subtract r1 r2 = fold s_join [r1, r2] nat_subtract_rel
+ fun s_nat_less (Atom j1) (Atom j2) = from_bool (j1 < j2)
+ | s_nat_less r1 r2 = fold s_join [r1, r2] nat_less_rel
+ fun s_int_less (Atom j1) (Atom j2) = from_bool (to_int j1 < to_int j2)
+ | s_int_less r1 r2 = fold s_join [r1, r2] int_less_rel
+
+ (* rel_expr -> int -> int -> rel_expr *)
+ fun d_project_seq r j0 n = Project (r, num_seq j0 n)
+ (* rel_expr -> rel_expr *)
+ fun d_not3 r = Join (r, not3_rel)
+ (* rel_expr -> rel_expr -> rel_expr *)
+ fun d_nat_subtract r1 r2 = List.foldl Join nat_subtract_rel [r1, r2]
+ fun d_nat_less r1 r2 = List.foldl Join nat_less_rel [r1, r2]
+ fun d_int_less r1 r2 = List.foldl Join int_less_rel [r1, r2]
+ in
+ if optim then
+ {kk_all = s_all, kk_exist = s_exist, kk_formula_let = s_formula_let,
+ kk_formula_if = s_formula_if, kk_or = s_or, kk_not = s_not,
+ kk_iff = s_iff, kk_implies = s_implies, kk_and = s_and,
+ kk_subset = s_subset, kk_rel_eq = s_rel_eq, kk_no = s_no,
+ kk_lone = s_lone, kk_one = s_one, kk_some = s_some,
+ kk_rel_let = s_rel_let, kk_rel_if = s_rel_if, kk_union = s_union,
+ kk_difference = s_difference, kk_override = s_override,
+ kk_intersect = s_intersect, kk_product = s_product, kk_join = s_join,
+ kk_closure = s_closure, kk_reflexive_closure = s_reflexive_closure,
+ kk_comprehension = s_comprehension, kk_project = s_project,
+ kk_project_seq = s_project_seq, kk_not3 = s_not3,
+ kk_nat_less = s_nat_less, kk_int_less = s_int_less}
+ else
+ {kk_all = curry All, kk_exist = curry Exist,
+ kk_formula_let = curry FormulaLet, kk_formula_if = curry3 FormulaIf,
+ kk_or = curry Or,kk_not = Not, kk_iff = curry Iff, kk_implies = curry
+ Implies, kk_and = curry And, kk_subset = curry Subset, kk_rel_eq = curry
+ RelEq, kk_no = No, kk_lone = Lone, kk_one = One, kk_some = Some,
+ kk_rel_let = curry RelLet, kk_rel_if = curry3 RelIf, kk_union = curry
+ Union, kk_difference = curry Difference, kk_override = curry Override,
+ kk_intersect = curry Intersect, kk_product = curry Product,
+ kk_join = curry Join, kk_closure = Closure,
+ kk_reflexive_closure = ReflexiveClosure, kk_comprehension = curry
+ Comprehension, kk_project = curry Project,
+ kk_project_seq = d_project_seq, kk_not3 = d_not3,
+ kk_nat_less = d_nat_less, kk_int_less = d_int_less}
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_rep.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,344 @@
+(* Title: HOL/Nitpick/Tools/nitpick_rep.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Kodkod representations of Nitpick terms.
+*)
+
+signature NITPICK_REP =
+sig
+ type polarity = NitpickUtil.polarity
+ type scope = NitpickScope.scope
+
+ datatype rep =
+ Any |
+ Formula of polarity |
+ Unit |
+ Atom of int * int |
+ Struct of rep list |
+ Vect of int * rep |
+ Func of rep * rep |
+ Opt of rep
+
+ exception REP of string * rep list
+
+ val string_for_polarity : polarity -> string
+ val string_for_rep : rep -> string
+ val is_Func : rep -> bool
+ val is_Opt : rep -> bool
+ val is_opt_rep : rep -> bool
+ val flip_rep_polarity : rep -> rep
+ val card_of_rep : rep -> int
+ val arity_of_rep : rep -> int
+ val min_univ_card_of_rep : rep -> int
+ val is_one_rep : rep -> bool
+ val is_lone_rep : rep -> bool
+ val dest_Func : rep -> rep * rep
+ val smart_range_rep : int Typtab.table -> typ -> (unit -> int) -> rep -> rep
+ val binder_reps : rep -> rep list
+ val body_rep : rep -> rep
+ val one_rep : int Typtab.table -> typ -> rep -> rep
+ val optable_rep : int Typtab.table -> typ -> rep -> rep
+ val opt_rep : int Typtab.table -> typ -> rep -> rep
+ val unopt_rep : rep -> rep
+ val min_rep : rep -> rep -> rep
+ val min_reps : rep list -> rep list -> rep list
+ val card_of_domain_from_rep : int -> rep -> int
+ val rep_to_binary_rel_rep : int Typtab.table -> typ -> rep -> rep
+ val best_one_rep_for_type : scope -> typ -> rep
+ val best_opt_set_rep_for_type : scope -> typ -> rep
+ val best_non_opt_set_rep_for_type : scope -> typ -> rep
+ val best_set_rep_for_type : scope -> typ -> rep
+ val best_non_opt_symmetric_reps_for_fun_type : scope -> typ -> rep * rep
+ val atom_schema_of_rep : rep -> (int * int) list
+ val atom_schema_of_reps : rep list -> (int * int) list
+ val type_schema_of_rep : typ -> rep -> typ list
+ val type_schema_of_reps : typ list -> rep list -> typ list
+ val all_combinations_for_rep : rep -> int list list
+ val all_combinations_for_reps : rep list -> int list list
+end;
+
+structure NitpickRep : NITPICK_REP =
+struct
+
+open NitpickUtil
+open NitpickHOL
+open NitpickScope
+
+datatype rep =
+ Any |
+ Formula of polarity |
+ Unit |
+ Atom of int * int |
+ Struct of rep list |
+ Vect of int * rep |
+ Func of rep * rep |
+ Opt of rep
+
+exception REP of string * rep list
+
+(* polarity -> string *)
+fun string_for_polarity Pos = "+"
+ | string_for_polarity Neg = "-"
+ | string_for_polarity Neut = "="
+
+(* rep -> string *)
+fun atomic_string_for_rep rep =
+ let val s = string_for_rep rep in
+ if String.isPrefix "[" s orelse not (is_substring_of " " s) then s
+ else "(" ^ s ^ ")"
+ end
+(* rep -> string *)
+and string_for_rep Any = "X"
+ | string_for_rep (Formula polar) = "F" ^ string_for_polarity polar
+ | string_for_rep Unit = "U"
+ | string_for_rep (Atom (k, j0)) =
+ "A" ^ string_of_int k ^ (if j0 = 0 then "" else "@" ^ string_of_int j0)
+ | string_for_rep (Struct rs) = "[" ^ commas (map string_for_rep rs) ^ "]"
+ | string_for_rep (Vect (k, R)) =
+ string_of_int k ^ " x " ^ atomic_string_for_rep R
+ | string_for_rep (Func (R1, R2)) =
+ atomic_string_for_rep R1 ^ " => " ^ string_for_rep R2
+ | string_for_rep (Opt R) = atomic_string_for_rep R ^ "?"
+
+(* rep -> bool *)
+fun is_Func (Func _) = true
+ | is_Func _ = false
+fun is_Opt (Opt _) = true
+ | is_Opt _ = false
+fun is_opt_rep (Func (_, R2)) = is_opt_rep R2
+ | is_opt_rep (Opt _) = true
+ | is_opt_rep _ = false
+
+(* rep -> int *)
+fun card_of_rep Any = raise REP ("NitpickRep.card_of_rep", [Any])
+ | card_of_rep (Formula _) = 2
+ | card_of_rep Unit = 1
+ | card_of_rep (Atom (k, _)) = k
+ | card_of_rep (Struct rs) = Integer.prod (map card_of_rep rs)
+ | card_of_rep (Vect (k, R)) = reasonable_power (card_of_rep R) k
+ | card_of_rep (Func (R1, R2)) =
+ reasonable_power (card_of_rep R2) (card_of_rep R1)
+ | card_of_rep (Opt R) = card_of_rep R
+fun arity_of_rep Any = raise REP ("NitpickRep.arity_of_rep", [Any])
+ | arity_of_rep (Formula _) = 0
+ | arity_of_rep Unit = 0
+ | arity_of_rep (Atom _) = 1
+ | arity_of_rep (Struct Rs) = Integer.sum (map arity_of_rep Rs)
+ | arity_of_rep (Vect (k, R)) = k * arity_of_rep R
+ | arity_of_rep (Func (R1, R2)) = arity_of_rep R1 + arity_of_rep R2
+ | arity_of_rep (Opt R) = arity_of_rep R
+fun min_univ_card_of_rep Any =
+ raise REP ("NitpickRep.min_univ_card_of_rep", [Any])
+ | min_univ_card_of_rep (Formula _) = 0
+ | min_univ_card_of_rep Unit = 0
+ | min_univ_card_of_rep (Atom (k, j0)) = k + j0 + 1
+ | min_univ_card_of_rep (Struct Rs) =
+ fold Integer.max (map min_univ_card_of_rep Rs) 0
+ | min_univ_card_of_rep (Vect (_, R)) = min_univ_card_of_rep R
+ | min_univ_card_of_rep (Func (R1, R2)) =
+ Int.max (min_univ_card_of_rep R1, min_univ_card_of_rep R2)
+ | min_univ_card_of_rep (Opt R) = min_univ_card_of_rep R
+
+(* rep -> bool *)
+fun is_one_rep Unit = true
+ | is_one_rep (Atom _) = true
+ | is_one_rep (Struct _) = true
+ | is_one_rep (Vect _) = true
+ | is_one_rep _ = false
+fun is_lone_rep (Opt R) = is_one_rep R
+ | is_lone_rep R = is_one_rep R
+
+(* rep -> rep * rep *)
+fun dest_Func (Func z) = z
+ | dest_Func R = raise REP ("NitpickRep.dest_Func", [R])
+(* int Typtab.table -> typ -> (unit -> int) -> rep -> rep *)
+fun smart_range_rep _ _ _ Unit = Unit
+ | smart_range_rep _ _ _ (Vect (_, R)) = R
+ | smart_range_rep _ _ _ (Func (_, R2)) = R2
+ | smart_range_rep ofs T ran_card (Opt R) =
+ Opt (smart_range_rep ofs T ran_card R)
+ | smart_range_rep ofs (Type ("fun", [_, T2])) _ (Atom (1, _)) =
+ Atom (1, offset_of_type ofs T2)
+ | smart_range_rep ofs (Type ("fun", [_, T2])) ran_card (Atom _) =
+ Atom (ran_card (), offset_of_type ofs T2)
+ | smart_range_rep _ _ _ R = raise REP ("NitpickRep.smart_range_rep", [R])
+
+(* rep -> rep list *)
+fun binder_reps (Func (R1, R2)) = R1 :: binder_reps R2
+ | binder_reps R = []
+(* rep -> rep *)
+fun body_rep (Func (_, R2)) = body_rep R2
+ | body_rep R = R
+
+(* rep -> rep *)
+fun flip_rep_polarity (Formula polar) = Formula (flip_polarity polar)
+ | flip_rep_polarity (Func (R1, R2)) = Func (R1, flip_rep_polarity R2)
+ | flip_rep_polarity R = R
+
+(* int Typtab.table -> rep -> rep *)
+fun one_rep _ _ Any = raise REP ("NitpickRep.one_rep", [Any])
+ | one_rep _ _ (Atom x) = Atom x
+ | one_rep _ _ (Struct Rs) = Struct Rs
+ | one_rep _ _ (Vect z) = Vect z
+ | one_rep ofs T (Opt R) = one_rep ofs T R
+ | one_rep ofs T R = Atom (card_of_rep R, offset_of_type ofs T)
+fun optable_rep ofs (Type ("fun", [_, T2])) (Func (R1, R2)) =
+ Func (R1, optable_rep ofs T2 R2)
+ | optable_rep ofs T R = one_rep ofs T R
+fun opt_rep ofs (Type ("fun", [_, T2])) (Func (R1, R2)) =
+ Func (R1, opt_rep ofs T2 R2)
+ | opt_rep ofs T R = Opt (optable_rep ofs T R)
+(* rep -> rep *)
+fun unopt_rep (Func (R1, R2)) = Func (R1, unopt_rep R2)
+ | unopt_rep (Opt R) = R
+ | unopt_rep R = R
+
+(* polarity -> polarity -> polarity *)
+fun min_polarity polar1 polar2 =
+ if polar1 = polar2 then
+ polar1
+ else if polar1 = Neut then
+ polar2
+ else if polar2 = Neut then
+ polar1
+ else
+ raise ARG ("NitpickRep.min_polarity",
+ commas (map (quote o string_for_polarity) [polar1, polar2]))
+
+(* It's important that Func is before Vect, because if the range is Opt we
+ could lose information by converting a Func to a Vect. *)
+(* rep -> rep -> rep *)
+fun min_rep (Opt R1) (Opt R2) = Opt (min_rep R1 R2)
+ | min_rep (Opt R) _ = Opt R
+ | min_rep _ (Opt R) = Opt R
+ | min_rep (Formula polar1) (Formula polar2) =
+ Formula (min_polarity polar1 polar2)
+ | min_rep (Formula polar) _ = Formula polar
+ | min_rep _ (Formula polar) = Formula polar
+ | min_rep Unit _ = Unit
+ | min_rep _ Unit = Unit
+ | min_rep (Atom x) _ = Atom x
+ | min_rep _ (Atom x) = Atom x
+ | min_rep (Struct Rs1) (Struct Rs2) = Struct (min_reps Rs1 Rs2)
+ | min_rep (Struct Rs) _ = Struct Rs
+ | min_rep _ (Struct Rs) = Struct Rs
+ | min_rep (R1 as Func (R11, R12)) (R2 as Func (R21, R22)) =
+ (case pairself is_opt_rep (R12, R22) of
+ (true, false) => R1
+ | (false, true) => R2
+ | _ => if R11 = R21 then Func (R11, min_rep R12 R22)
+ else if min_rep R11 R21 = R11 then R1
+ else R2)
+ | min_rep (Func z) _ = Func z
+ | min_rep _ (Func z) = Func z
+ | min_rep (Vect (k1, R1)) (Vect (k2, R2)) =
+ if k1 < k2 then Vect (k1, R1)
+ else if k1 > k2 then Vect (k2, R2)
+ else Vect (k1, min_rep R1 R2)
+ | min_rep R1 R2 = raise REP ("NitpickRep.min_rep", [R1, R2])
+(* rep list -> rep list -> rep list *)
+and min_reps [] _ = []
+ | min_reps _ [] = []
+ | min_reps (R1 :: Rs1) (R2 :: Rs2) =
+ if R1 = R2 then R1 :: min_reps Rs1 Rs2
+ else if min_rep R1 R2 = R1 then R1 :: Rs1
+ else R2 :: Rs2
+
+(* int -> rep -> int *)
+fun card_of_domain_from_rep ran_card R =
+ case R of
+ Unit => 1
+ | Atom (k, _) => exact_log ran_card k
+ | Vect (k, _) => k
+ | Func (R1, _) => card_of_rep R1
+ | Opt R => card_of_domain_from_rep ran_card R
+ | _ => raise REP ("NitpickRep.card_of_domain_from_rep", [R])
+
+(* int Typtab.table -> typ -> rep -> rep *)
+fun rep_to_binary_rel_rep ofs T R =
+ let
+ val k = exact_root 2 (card_of_domain_from_rep 2 R)
+ val j0 = offset_of_type ofs (fst (HOLogic.dest_prodT (domain_type T)))
+ in Func (Struct [Atom (k, j0), Atom (k, j0)], Formula Neut) end
+
+(* scope -> typ -> rep *)
+fun best_one_rep_for_type (scope as {card_assigns, ...} : scope)
+ (Type ("fun", [T1, T2])) =
+ (case best_one_rep_for_type scope T2 of
+ Unit => Unit
+ | R2 => Vect (card_of_type card_assigns T1, R2))
+ | best_one_rep_for_type scope (Type ("*", [T1, T2])) =
+ (case (best_one_rep_for_type scope T1, best_one_rep_for_type scope T2) of
+ (Unit, Unit) => Unit
+ | (R1, R2) => Struct [R1, R2])
+ | best_one_rep_for_type (scope as {card_assigns, datatypes, ofs, ...}) T =
+ (case card_of_type card_assigns T of
+ 1 => if is_some (datatype_spec datatypes T)
+ orelse is_fp_iterator_type T then
+ Atom (1, offset_of_type ofs T)
+ else
+ Unit
+ | k => Atom (k, offset_of_type ofs T))
+
+(* Datatypes are never represented by Unit, because it would confuse
+ "nfa_transitions_for_ctor". *)
+(* scope -> typ -> rep *)
+fun best_opt_set_rep_for_type scope (Type ("fun", [T1, T2])) =
+ Func (best_one_rep_for_type scope T1, best_opt_set_rep_for_type scope T2)
+ | best_opt_set_rep_for_type (scope as {ofs, ...}) T =
+ opt_rep ofs T (best_one_rep_for_type scope T)
+fun best_non_opt_set_rep_for_type (scope as {ofs, ...})
+ (Type ("fun", [T1, T2])) =
+ (case (best_one_rep_for_type scope T1,
+ best_non_opt_set_rep_for_type scope T2) of
+ (_, Unit) => Unit
+ | (Unit, Atom (2, _)) =>
+ Func (Atom (1, offset_of_type ofs T1), Formula Neut)
+ | (R1, Atom (2, _)) => Func (R1, Formula Neut)
+ | z => Func z)
+ | best_non_opt_set_rep_for_type scope T = best_one_rep_for_type scope T
+fun best_set_rep_for_type (scope as {datatypes, ...}) T =
+ (if is_precise_type datatypes T then best_non_opt_set_rep_for_type
+ else best_opt_set_rep_for_type) scope T
+fun best_non_opt_symmetric_reps_for_fun_type (scope as {ofs, ...})
+ (Type ("fun", [T1, T2])) =
+ (optable_rep ofs T1 (best_one_rep_for_type scope T1),
+ optable_rep ofs T2 (best_one_rep_for_type scope T2))
+ | best_non_opt_symmetric_reps_for_fun_type _ T =
+ raise TYPE ("NitpickRep.best_non_opt_symmetric_reps_for_fun_type", [T], [])
+
+(* rep -> (int * int) list *)
+fun atom_schema_of_rep Any = raise REP ("NitpickRep.atom_schema_of_rep", [Any])
+ | atom_schema_of_rep (Formula _) = []
+ | atom_schema_of_rep Unit = []
+ | atom_schema_of_rep (Atom x) = [x]
+ | atom_schema_of_rep (Struct Rs) = atom_schema_of_reps Rs
+ | atom_schema_of_rep (Vect (k, R)) = replicate_list k (atom_schema_of_rep R)
+ | atom_schema_of_rep (Func (R1, R2)) =
+ atom_schema_of_rep R1 @ atom_schema_of_rep R2
+ | atom_schema_of_rep (Opt R) = atom_schema_of_rep R
+(* rep list -> (int * int) list *)
+and atom_schema_of_reps Rs = maps atom_schema_of_rep Rs
+
+(* typ -> rep -> typ list *)
+fun type_schema_of_rep _ (Formula _) = []
+ | type_schema_of_rep _ Unit = []
+ | type_schema_of_rep T (Atom _) = [T]
+ | type_schema_of_rep (Type ("*", [T1, T2])) (Struct [R1, R2]) =
+ type_schema_of_reps [T1, T2] [R1, R2]
+ | type_schema_of_rep (Type ("fun", [_, T2])) (Vect (k, R)) =
+ replicate_list k (type_schema_of_rep T2 R)
+ | type_schema_of_rep (Type ("fun", [T1, T2])) (Func (R1, R2)) =
+ type_schema_of_rep T1 R1 @ type_schema_of_rep T2 R2
+ | type_schema_of_rep T (Opt R) = type_schema_of_rep T R
+ | type_schema_of_rep T R = raise REP ("NitpickRep.type_schema_of_rep", [R])
+(* typ list -> rep list -> typ list *)
+and type_schema_of_reps Ts Rs = flat (map2 type_schema_of_rep Ts Rs)
+
+(* rep -> int list list *)
+val all_combinations_for_rep = all_combinations o atom_schema_of_rep
+(* rep list -> int list list *)
+val all_combinations_for_reps = all_combinations o atom_schema_of_reps
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,498 @@
+(* Title: HOL/Nitpick/Tools/nitpick_scope.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Scope enumerator for Nitpick.
+*)
+
+signature NITPICK_SCOPE =
+sig
+ type extended_context = NitpickHOL.extended_context
+
+ type constr_spec = {
+ const: styp,
+ delta: int,
+ epsilon: int,
+ exclusive: bool,
+ explicit_max: int,
+ total: bool}
+
+ type dtype_spec = {
+ typ: typ,
+ card: int,
+ co: bool,
+ precise: bool,
+ constrs: constr_spec list}
+
+ type scope = {
+ ext_ctxt: extended_context,
+ card_assigns: (typ * int) list,
+ bisim_depth: int,
+ datatypes: dtype_spec list,
+ ofs: int Typtab.table}
+
+ val datatype_spec : dtype_spec list -> typ -> dtype_spec option
+ val constr_spec : dtype_spec list -> styp -> constr_spec
+ val is_precise_type : dtype_spec list -> typ -> bool
+ val is_fully_comparable_type : dtype_spec list -> typ -> bool
+ val offset_of_type : int Typtab.table -> typ -> int
+ val spec_of_type : scope -> typ -> int * int
+ val pretties_for_scope : scope -> bool -> Pretty.T list
+ val multiline_string_for_scope : scope -> string
+ val scopes_equivalent : scope -> scope -> bool
+ val scope_less_eq : scope -> scope -> bool
+ val all_scopes :
+ extended_context -> int -> (typ option * int list) list
+ -> (styp option * int list) list -> (styp option * int list) list
+ -> int list -> typ list -> typ list -> scope list
+end;
+
+structure NitpickScope : NITPICK_SCOPE =
+struct
+
+open NitpickUtil
+open NitpickHOL
+
+type constr_spec = {
+ const: styp,
+ delta: int,
+ epsilon: int,
+ exclusive: bool,
+ explicit_max: int,
+ total: bool}
+
+type dtype_spec = {
+ typ: typ,
+ card: int,
+ co: bool,
+ precise: bool,
+ constrs: constr_spec list}
+
+type scope = {
+ ext_ctxt: extended_context,
+ card_assigns: (typ * int) list,
+ bisim_depth: int,
+ datatypes: dtype_spec list,
+ ofs: int Typtab.table}
+
+datatype row_kind = Card of typ | Max of styp
+
+type row = row_kind * int list
+type block = row list
+
+(* dtype_spec list -> typ -> dtype_spec option *)
+fun datatype_spec (dtypes : dtype_spec list) T =
+ List.find (equal T o #typ) dtypes
+
+(* dtype_spec list -> styp -> constr_spec *)
+fun constr_spec [] x = raise TERM ("NitpickScope.constr_spec", [Const x])
+ | constr_spec ({constrs, ...} :: dtypes : dtype_spec list) (x as (s, T)) =
+ case List.find (equal (s, body_type T) o (apsnd body_type o #const))
+ constrs of
+ SOME c => c
+ | NONE => constr_spec dtypes x
+
+(* dtype_spec list -> typ -> bool *)
+fun is_precise_type dtypes (Type ("fun", Ts)) =
+ forall (is_precise_type dtypes) Ts
+ | is_precise_type dtypes (Type ("*", Ts)) = forall (is_precise_type dtypes) Ts
+ | is_precise_type dtypes T =
+ T <> nat_T andalso T <> int_T
+ andalso #precise (the (datatype_spec dtypes T))
+ handle Option.Option => true
+fun is_fully_comparable_type dtypes (Type ("fun", [T1, T2])) =
+ is_precise_type dtypes T1 andalso is_fully_comparable_type dtypes T2
+ | is_fully_comparable_type dtypes (Type ("*", Ts)) =
+ forall (is_fully_comparable_type dtypes) Ts
+ | is_fully_comparable_type _ _ = true
+
+(* int Typtab.table -> typ -> int *)
+fun offset_of_type ofs T =
+ case Typtab.lookup ofs T of
+ SOME j0 => j0
+ | NONE => Typtab.lookup ofs dummyT |> the_default 0
+
+(* scope -> typ -> int * int *)
+fun spec_of_type ({card_assigns, ofs, ...} : scope) T =
+ (card_of_type card_assigns T
+ handle TYPE ("NitpickHOL.card_of_type", _, _) => ~1, offset_of_type ofs T)
+
+(* (string -> string) -> scope
+ -> string list * string list * string list * string list * string list *)
+fun quintuple_for_scope quote ({ext_ctxt as {thy, ctxt, ...}, card_assigns,
+ bisim_depth, datatypes, ...} : scope) =
+ let
+ val (iter_asgns, card_asgns) =
+ card_assigns |> filter_out (equal @{typ bisim_iterator} o fst)
+ |> List.partition (is_fp_iterator_type o fst)
+ val (unimportant_card_asgns, important_card_asgns) =
+ card_asgns |> List.partition ((is_datatype thy orf is_integer_type) o fst)
+ val cards =
+ map (fn (T, k) => quote (string_for_type ctxt T) ^ " = " ^
+ string_of_int k)
+ fun maxes () =
+ maps (map_filter
+ (fn {const, explicit_max, ...} =>
+ if explicit_max < 0 then
+ NONE
+ else
+ SOME (Syntax.string_of_term ctxt (Const const) ^ " = " ^
+ string_of_int explicit_max))
+ o #constrs) datatypes
+ fun iters () =
+ map (fn (T, k) =>
+ quote (Syntax.string_of_term ctxt
+ (Const (const_for_iterator_type T))) ^ " = " ^
+ string_of_int (k - 1)) iter_asgns
+ fun bisims () =
+ if bisim_depth < 0 andalso forall (not o #co) datatypes then []
+ else ["bisim_depth = " ^ string_of_int bisim_depth]
+ in
+ setmp_show_all_types
+ (fn () => (cards important_card_asgns, cards unimportant_card_asgns,
+ maxes (), iters (), bisims ())) ()
+ end
+
+(* scope -> bool -> Pretty.T list *)
+fun pretties_for_scope scope verbose =
+ let
+ val (important_cards, unimportant_cards, maxes, iters, bisim_depths) =
+ quintuple_for_scope maybe_quote scope
+ val ss = map (prefix "card ") important_cards @
+ (if verbose then
+ map (prefix "card ") unimportant_cards @
+ map (prefix "max ") maxes @
+ map (prefix "iter ") iters @
+ bisim_depths
+ else
+ [])
+ in
+ if null ss then []
+ else serial_commas "and" ss |> map Pretty.str |> Pretty.breaks
+ end
+
+(* scope -> string *)
+fun multiline_string_for_scope scope =
+ let
+ val (important_cards, unimportant_cards, maxes, iters, bisim_depths) =
+ quintuple_for_scope I scope
+ val cards = important_cards @ unimportant_cards
+ in
+ case (if null cards then [] else ["card: " ^ commas cards]) @
+ (if null maxes then [] else ["max: " ^ commas maxes]) @
+ (if null iters then [] else ["iter: " ^ commas iters]) @
+ bisim_depths of
+ [] => "empty"
+ | lines => space_implode "\n" lines
+ end
+
+(* scope -> scope -> bool *)
+fun scopes_equivalent (s1 : scope) (s2 : scope) =
+ #datatypes s1 = #datatypes s2 andalso #card_assigns s1 = #card_assigns s2
+fun scope_less_eq (s1 : scope) (s2 : scope) =
+ (s1, s2) |> pairself (map snd o #card_assigns) |> op ~~ |> forall (op <=)
+
+(* row -> int *)
+fun rank_of_row (_, ks) = length ks
+(* block -> int *)
+fun rank_of_block block = fold Integer.max (map rank_of_row block) 1
+(* int -> typ * int list -> typ * int list *)
+fun project_row column (y, ks) = (y, [nth ks (Int.min (column, length ks - 1))])
+(* int -> block -> block *)
+fun project_block (column, block) = map (project_row column) block
+
+(* (''a * ''a -> bool) -> (''a option * int list) list -> ''a -> int list *)
+fun lookup_ints_assign eq asgns key =
+ case triple_lookup eq asgns key of
+ SOME ks => ks
+ | NONE => raise ARG ("NitpickScope.lookup_ints_assign", "")
+(* theory -> (typ option * int list) list -> typ -> int list *)
+fun lookup_type_ints_assign thy asgns T =
+ map (curry Int.max 1) (lookup_ints_assign (type_match thy) asgns T)
+ handle ARG ("NitpickScope.lookup_ints_assign", _) =>
+ raise TYPE ("NitpickScope.lookup_type_ints_assign", [T], [])
+(* theory -> (styp option * int list) list -> styp -> int list *)
+fun lookup_const_ints_assign thy asgns x =
+ lookup_ints_assign (const_match thy) asgns x
+ handle ARG ("NitpickScope.lookup_ints_assign", _) =>
+ raise TERM ("NitpickScope.lookup_const_ints_assign", [Const x])
+
+(* theory -> (styp option * int list) list -> styp -> row option *)
+fun row_for_constr thy maxes_asgns constr =
+ SOME (Max constr, lookup_const_ints_assign thy maxes_asgns constr)
+ handle TERM ("lookup_const_ints_assign", _) => NONE
+
+(* Proof.context -> (typ option * int list) list
+ -> (styp option * int list) list -> (styp option * int list) list -> int list
+ -> typ -> block *)
+fun block_for_type ctxt cards_asgns maxes_asgns iters_asgns bisim_depths T =
+ let val thy = ProofContext.theory_of ctxt in
+ if T = @{typ bisim_iterator} then
+ [(Card T, map (fn k => Int.max (0, k) + 1) bisim_depths)]
+ else if is_fp_iterator_type T then
+ [(Card T, map (fn k => Int.max (0, k) + 1)
+ (lookup_const_ints_assign thy iters_asgns
+ (const_for_iterator_type T)))]
+ else
+ (Card T, lookup_type_ints_assign thy cards_asgns T) ::
+ (case datatype_constrs thy T of
+ [_] => []
+ | constrs => map_filter (row_for_constr thy maxes_asgns) constrs)
+ end
+
+(* Proof.context -> (typ option * int list) list
+ -> (styp option * int list) list -> (styp option * int list) list -> int list
+ -> typ list -> typ list -> block list *)
+fun blocks_for_types ctxt cards_asgns maxes_asgns iters_asgns bisim_depths
+ mono_Ts nonmono_Ts =
+ let
+ val thy = ProofContext.theory_of ctxt
+ (* typ -> block *)
+ val block_for = block_for_type ctxt cards_asgns maxes_asgns iters_asgns
+ bisim_depths
+ val mono_block = maps block_for mono_Ts
+ val nonmono_blocks = map block_for nonmono_Ts
+ in mono_block :: nonmono_blocks end
+
+val sync_threshold = 5
+
+(* int list -> int list list *)
+fun all_combinations_ordered_smartly ks =
+ let
+ (* int list -> int *)
+ fun cost_with_monos [] = 0
+ | cost_with_monos (k :: ks) =
+ if k < sync_threshold andalso forall (equal k) ks then
+ k - sync_threshold
+ else
+ k * (k + 1) div 2 + Integer.sum ks
+ fun cost_without_monos [] = 0
+ | cost_without_monos [k] = k
+ | cost_without_monos (_ :: k :: ks) =
+ if k < sync_threshold andalso forall (equal k) ks then
+ k - sync_threshold
+ else
+ Integer.sum (k :: ks)
+ in
+ ks |> all_combinations
+ |> map (`(if fst (hd ks) > 1 then cost_with_monos
+ else cost_without_monos))
+ |> sort (int_ord o pairself fst) |> map snd
+ end
+
+(* typ -> bool *)
+fun is_self_recursive_constr_type T =
+ exists (exists_subtype (equal (body_type T))) (binder_types T)
+
+(* (styp * int) list -> styp -> int *)
+fun constr_max maxes x = the_default ~1 (AList.lookup (op =) maxes x)
+
+type scope_desc = (typ * int) list * (styp * int) list
+
+(* theory -> scope_desc -> typ * int -> bool *)
+fun is_surely_inconsistent_card_assign thy (card_asgns, max_asgns) (T, k) =
+ case datatype_constrs thy T of
+ [] => false
+ | xs =>
+ let
+ val precise_cards =
+ map (Integer.prod
+ o map (bounded_precise_card_of_type thy k 0 card_asgns)
+ o binder_types o snd) xs
+ val maxes = map (constr_max max_asgns) xs
+ (* int -> int -> int *)
+ fun effective_max 0 ~1 = k
+ | effective_max 0 max = max
+ | effective_max card ~1 = card
+ | effective_max card max = Int.min (card, max)
+ val max = map2 effective_max precise_cards maxes |> Integer.sum
+ (* unit -> int *)
+ fun doms_card () =
+ xs |> map (Integer.prod o map (bounded_card_of_type k ~1 card_asgns)
+ o binder_types o snd)
+ |> Integer.sum
+ in
+ max < k
+ orelse (forall (not_equal 0) precise_cards andalso doms_card () < k)
+ end
+ handle TYPE ("NitpickHOL.card_of_type", _, _) => false
+
+(* theory -> scope_desc -> bool *)
+fun is_surely_inconsistent_scope_description thy (desc as (card_asgns, _)) =
+ exists (is_surely_inconsistent_card_assign thy desc) card_asgns
+
+(* theory -> scope_desc -> (typ * int) list option *)
+fun repair_card_assigns thy (card_asgns, max_asgns) =
+ let
+ (* (typ * int) list -> (typ * int) list -> (typ * int) list option *)
+ fun aux seen [] = SOME seen
+ | aux seen ((T, 0) :: _) = NONE
+ | aux seen ((T, k) :: asgns) =
+ (if is_surely_inconsistent_scope_description thy
+ ((T, k) :: seen, max_asgns) then
+ raise SAME ()
+ else
+ case aux ((T, k) :: seen) asgns of
+ SOME asgns => SOME asgns
+ | NONE => raise SAME ())
+ handle SAME () => aux seen ((T, k - 1) :: asgns)
+ in aux [] (rev card_asgns) end
+
+(* theory -> (typ * int) list -> typ * int -> typ * int *)
+fun repair_iterator_assign thy asgns (T as Type (s, Ts), k) =
+ (T, if T = @{typ bisim_iterator} then
+ let val co_cards = map snd (filter (is_codatatype thy o fst) asgns) in
+ Int.min (k, Integer.sum co_cards)
+ end
+ else if is_fp_iterator_type T then
+ case Ts of
+ [] => 1
+ | _ => bounded_card_of_type k ~1 asgns (foldr1 HOLogic.mk_prodT Ts)
+ else
+ k)
+ | repair_iterator_assign _ _ asgn = asgn
+
+(* row -> scope_desc -> scope_desc *)
+fun add_row_to_scope_descriptor (kind, ks) (card_asgns, max_asgns) =
+ case kind of
+ Card T => ((T, the_single ks) :: card_asgns, max_asgns)
+ | Max x => (card_asgns, (x, the_single ks) :: max_asgns)
+(* block -> scope_desc *)
+fun scope_descriptor_from_block block =
+ fold_rev add_row_to_scope_descriptor block ([], [])
+(* theory -> block list -> int list -> scope_desc option *)
+fun scope_descriptor_from_combination thy blocks columns =
+ let
+ val (card_asgns, max_asgns) =
+ maps project_block (columns ~~ blocks) |> scope_descriptor_from_block
+ val card_asgns = repair_card_assigns thy (card_asgns, max_asgns) |> the
+ in
+ SOME (map (repair_iterator_assign thy card_asgns) card_asgns, max_asgns)
+ end
+ handle Option.Option => NONE
+
+(* theory -> (typ * int) list -> dtype_spec list -> int Typtab.table *)
+fun offset_table_for_card_assigns thy asgns dtypes =
+ let
+ (* int -> (int * int) list -> (typ * int) list -> int Typtab.table
+ -> int Typtab.table *)
+ fun aux next _ [] = Typtab.update_new (dummyT, next)
+ | aux next reusable ((T, k) :: asgns) =
+ if k = 1 orelse is_integer_type T then
+ aux next reusable asgns
+ else if length (these (Option.map #constrs (datatype_spec dtypes T)))
+ > 1 then
+ Typtab.update_new (T, next) #> aux (next + k) reusable asgns
+ else
+ case AList.lookup (op =) reusable k of
+ SOME j0 => Typtab.update_new (T, j0) #> aux next reusable asgns
+ | NONE => Typtab.update_new (T, next)
+ #> aux (next + k) ((k, next) :: reusable) asgns
+ in aux 0 [] asgns Typtab.empty end
+
+(* int -> (typ * int) list -> typ -> int *)
+fun domain_card max card_asgns =
+ Integer.prod o map (bounded_card_of_type max max card_asgns) o binder_types
+
+(* scope_desc -> bool -> int -> (int -> int) -> int -> int -> bool * styp
+ -> constr_spec list -> constr_spec list *)
+fun add_constr_spec (card_asgns, max_asgns) co card sum_dom_cards num_self_recs
+ num_non_self_recs (self_rec, x as (s, T)) constrs =
+ let
+ val max = constr_max max_asgns x
+ (* int -> int *)
+ fun bound k = Int.min (card, (max >= 0 ? curry Int.min max) k)
+ (* unit -> int *)
+ fun next_delta () = if null constrs then 0 else #epsilon (hd constrs)
+ val {delta, epsilon, exclusive, total} =
+ if max = 0 then
+ let val delta = next_delta () in
+ {delta = delta, epsilon = delta, exclusive = true, total = false}
+ end
+ else if not co andalso num_self_recs > 0 then
+ if not self_rec andalso num_non_self_recs = 1
+ andalso domain_card 2 card_asgns T = 1 then
+ {delta = 0, epsilon = 1, exclusive = (s = @{const_name Nil}),
+ total = true}
+ else if s = @{const_name Cons} then
+ {delta = 1, epsilon = card, exclusive = true, total = false}
+ else
+ {delta = 0, epsilon = card, exclusive = false, total = false}
+ else if card = sum_dom_cards (card + 1) then
+ let val delta = next_delta () in
+ {delta = delta, epsilon = delta + domain_card card card_asgns T,
+ exclusive = true, total = true}
+ end
+ else
+ {delta = 0, epsilon = card,
+ exclusive = (num_self_recs + num_non_self_recs = 1), total = false}
+ in
+ {const = x, delta = delta, epsilon = epsilon, exclusive = exclusive,
+ explicit_max = max, total = total} :: constrs
+ end
+
+(* extended_context -> scope_desc -> typ * int -> dtype_spec *)
+fun datatype_spec_from_scope_descriptor (ext_ctxt as {thy, ...})
+ (desc as (card_asgns, _)) (T, card) =
+ let
+ val co = is_codatatype thy T
+ val xs = boxed_datatype_constrs ext_ctxt T
+ val self_recs = map (is_self_recursive_constr_type o snd) xs
+ val (num_self_recs, num_non_self_recs) =
+ List.partition (equal true) self_recs |> pairself length
+ val precise = (card = bounded_precise_card_of_type thy (card + 1) 0
+ card_asgns T)
+ (* int -> int *)
+ fun sum_dom_cards max =
+ map (domain_card max card_asgns o snd) xs |> Integer.sum
+ val constrs =
+ fold_rev (add_constr_spec desc co card sum_dom_cards num_self_recs
+ num_non_self_recs) (self_recs ~~ xs) []
+ in {typ = T, card = card, co = co, precise = precise, constrs = constrs} end
+
+(* extended_context -> int -> scope_desc -> scope *)
+fun scope_from_descriptor (ext_ctxt as {thy, ...}) sym_break
+ (desc as (card_asgns, _)) =
+ let
+ val datatypes = map (datatype_spec_from_scope_descriptor ext_ctxt desc)
+ (filter (is_datatype thy o fst) card_asgns)
+ val bisim_depth = card_of_type card_asgns @{typ bisim_iterator} - 1
+ in
+ {ext_ctxt = ext_ctxt, card_assigns = card_asgns, datatypes = datatypes,
+ bisim_depth = bisim_depth,
+ ofs = if sym_break <= 0 then Typtab.empty
+ else offset_table_for_card_assigns thy card_asgns datatypes}
+ end
+
+(* theory -> typ list -> (typ option * int list) list
+ -> (typ option * int list) list *)
+fun fix_cards_assigns_wrt_boxing _ _ [] = []
+ | fix_cards_assigns_wrt_boxing thy Ts ((SOME T, ks) :: cards_asgns) =
+ (if is_fun_type T orelse is_pair_type T then
+ Ts |> filter (curry (type_match thy o swap) T o unbox_type)
+ |> map (rpair ks o SOME)
+ else
+ [(SOME T, ks)]) @ fix_cards_assigns_wrt_boxing thy Ts cards_asgns
+ | fix_cards_assigns_wrt_boxing thy Ts ((NONE, ks) :: cards_asgns) =
+ (NONE, ks) :: fix_cards_assigns_wrt_boxing thy Ts cards_asgns
+
+val distinct_threshold = 512
+
+(* extended_context -> int -> (typ option * int list) list
+ -> (styp option * int list) list -> (styp option * int list) list -> int list
+ -> typ list -> typ list -> scope list *)
+fun all_scopes (ext_ctxt as {thy, ctxt, ...}) sym_break cards_asgns maxes_asgns
+ iters_asgns bisim_depths mono_Ts nonmono_Ts =
+ let
+ val cards_asgns = fix_cards_assigns_wrt_boxing thy mono_Ts cards_asgns
+ val blocks = blocks_for_types ctxt cards_asgns maxes_asgns iters_asgns
+ bisim_depths mono_Ts nonmono_Ts
+ val ranks = map rank_of_block blocks
+ val descs = all_combinations_ordered_smartly (map (rpair 0) ranks)
+ |> map_filter (scope_descriptor_from_combination thy blocks)
+ in
+ descs |> length descs <= distinct_threshold ? distinct (op =)
+ |> map (scope_from_descriptor ext_ctxt sym_break)
+ end
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_tests.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,334 @@
+(* Title: HOL/Nitpick/Tools/nitpick_tests.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+Unit tests for Nitpick.
+*)
+
+signature NITPICK_TESTS =
+sig
+ val run_all_tests : unit -> unit
+end
+
+structure NitpickTests =
+struct
+
+open NitpickUtil
+open NitpickPeephole
+open NitpickRep
+open NitpickNut
+open NitpickKodkod
+open Nitpick
+
+val settings =
+ [("solver", "\"zChaff\""),
+ ("skolem_depth", "-1")]
+
+fun cast_to_rep R u = Op1 (Cast, type_of u, R, u)
+
+val unit_T = @{typ unit}
+val dummy_T = @{typ 'a}
+
+val unity = Cst (Unity, unit_T, Unit)
+val atom1_v1 = FreeName ("atom1_v1", dummy_T, Atom (1, 0))
+val atom2_v1 = FreeName ("atom2_v1", dummy_T, Atom (2, 0))
+val atom6_v1 = FreeName ("atom6_v1", dummy_T, Atom (6, 0))
+val atom16_v1 = FreeName ("atom16_v1", dummy_T, Atom (16, 0))
+val atom24_v1 = FreeName ("atom24_v1", dummy_T, Atom (24, 0))
+val atom36_v1 = FreeName ("atom36_v1", dummy_T, Atom (36, 0))
+val atom81_v1 = FreeName ("atom81_v1", dummy_T, Atom (81, 0))
+val struct_atom1_atom1_v1 =
+ FreeName ("struct_atom1_atom1_v1", dummy_T, Struct [Atom (1, 0), Atom (1, 0)])
+val struct_atom1_unit_v1 =
+ FreeName ("struct_atom1_atom1_v1", dummy_T, Struct [Atom (1, 0), Unit])
+val struct_unit_atom1_v1 =
+ FreeName ("struct_atom1_atom1_v1", dummy_T, Struct [Unit, Atom (1, 0)])
+
+(*
+ Formula Unit Atom Struct Vect Func
+ Formula X N/A X X N/A N/A
+ Unit N/A N/A N/A N/A N/A N/A
+ Atom X N/A X X X X
+ Struct N/A N/A X X N/A N/A
+ Vect N/A N/A X N/A X X
+ Func N/A N/A X N/A X X
+*)
+
+val tests =
+ [("rep_conversion_formula_formula",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Formula Neut)
+ (cast_to_rep (Formula Neut) atom2_v1), atom2_v1)),
+ ("rep_conversion_atom_atom",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0)) (cast_to_rep (Atom (16, 0)) atom16_v1),
+ atom16_v1)),
+ ("rep_conversion_struct_struct_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (4, 0), Atom (6, 0)])
+ (cast_to_rep (Struct [Atom (4, 0), Atom (6, 0)]) atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_struct_struct_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (4, 0), Struct [Atom (2, 0), Atom (3, 0)]])
+ (cast_to_rep (Struct [Atom (4, 0), Atom (6, 0)]) atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_struct_struct_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (4, 0), Atom (6, 0)])
+ (cast_to_rep (Struct [Atom (4, 0),
+ Struct [Atom (2, 0), Atom (3, 0)]])
+ atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_struct_struct_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (24, 0), Unit])
+ (cast_to_rep (Struct [Atom (24, 0), Atom (1, 0)]) atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_struct_struct_5",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (24, 0), Atom (1, 0)])
+ (cast_to_rep (Struct [Atom (24, 0), Unit]) atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_struct_struct_6",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (1, 0), Atom (1, 0)])
+ (cast_to_rep (Struct [Atom (1, 0), Unit])
+ (cast_to_rep (Struct [Unit, Atom (1, 0)]) atom1_v1)),
+ atom1_v1)),
+ ("rep_conversion_vect_vect_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (2, Atom (4, 0)))
+ (cast_to_rep (Vect (2, Struct [Atom (2, 0), Atom (2, 0)]))
+ atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_vect_vect_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (2, Struct [Atom (2, 0), Atom (2, 0)]))
+ (cast_to_rep (Vect (2, Atom (4, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_vect_vect_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (2, Atom (4, 0)))
+ (cast_to_rep (Vect (2, Vect (2, Atom (2, 0)))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_vect_vect_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (2, Vect (2, Atom (2, 0))))
+ (cast_to_rep (Vect (2, Atom (4, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_func_func_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Atom (2, 0),
+ Struct [Atom (2, 0), Atom (3, 0)]))
+ (cast_to_rep (Func (Atom (2, 0), Atom (6, 0))) atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Atom (2, 0), Atom (6, 0)))
+ (cast_to_rep (Func (Atom (2, 0),
+ Struct [Atom (2, 0), Atom (3, 0)]))
+ atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Unit, Struct [Atom (6, 0), Atom (6, 0)]))
+ (cast_to_rep (Func (Atom (1, 0), Atom (36, 0))) atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Atom (1, 0), Atom (36, 0)))
+ (cast_to_rep (Func (Unit, Struct [Atom (6, 0), Atom (6, 0)]))
+ atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_5",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Unit, Vect (2, Atom (6, 0))))
+ (cast_to_rep (Func (Atom (1, 0), Atom (36, 0))) atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_6",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Atom (1, 0), Atom (36, 0)))
+ (cast_to_rep (Func (Unit, Vect (2, Atom (6, 0))))
+ atom36_v1)),
+ atom36_v1)),
+ ("rep_conversion_func_func_7",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (2, 0))
+ (cast_to_rep (Func (Unit, Atom (2, 0)))
+ (cast_to_rep (Func (Atom (1, 0), Formula Neut)) atom2_v1)),
+ atom2_v1)),
+ ("rep_conversion_func_func_8",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (2, 0))
+ (cast_to_rep (Func (Atom (1, 0), Formula Neut))
+ (cast_to_rep (Func (Unit, Atom (2, 0))) atom2_v1)),
+ atom2_v1)),
+ ("rep_conversion_atom_formula_atom",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (2, 0)) (cast_to_rep (Formula Neut) atom2_v1),
+ atom2_v1)),
+ ("rep_conversion_unit_atom",
+ Op2 (Eq, bool_T, Formula Neut, cast_to_rep (Atom (1, 0)) unity, unity)),
+ ("rep_conversion_atom_struct_atom1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (6, 0))
+ (cast_to_rep (Struct [Atom (3, 0), Atom (2, 0)]) atom6_v1),
+ atom6_v1)),
+ ("rep_conversion_atom_struct_atom_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (24, 0))
+ (cast_to_rep (Struct [Struct [Atom (3, 0), Atom (4, 0)],
+ Atom (2, 0)]) atom24_v1),
+ atom24_v1)),
+ ("rep_conversion_atom_struct_atom_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (6, 0))
+ (cast_to_rep (Struct [Atom (6, 0), Unit]) atom6_v1),
+ atom6_v1)),
+ ("rep_conversion_atom_struct_atom_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (6, 0))
+ (cast_to_rep (Struct [Struct [Atom (3, 0), Unit], Atom (2, 0)])
+ atom6_v1),
+ atom6_v1)),
+ ("rep_conversion_atom_vect_func_atom_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (4, Atom (2, 0)))
+ (cast_to_rep (Func (Atom (4, 0), Atom (2, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_vect_func_atom_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (4, Atom (2, 0)))
+ (cast_to_rep (Func (Atom (4, 0), Atom (2, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_vect_func_atom_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (4, Atom (2, 0)))
+ (cast_to_rep (Func (Atom (4, 0), Formula Neut)) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_vect_func_atom_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (1, Atom (16, 0)))
+ (cast_to_rep (Func (Unit, Atom (16, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_vect_func_atom_5",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Vect (1, Atom (16, 0)))
+ (cast_to_rep (Func (Unit, Atom (16, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_func_vect_atom_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Func (Atom (4, 0), Atom (2, 0)))
+ (cast_to_rep (Vect (4, Atom (2, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_func_vect_atom_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Func (Atom (4, 0), Atom (2, 0)))
+ (cast_to_rep (Vect (4, Atom (2, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_func_vect_atom_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Func (Atom (4, 0), Formula Neut))
+ (cast_to_rep (Vect (4, Atom (2, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_func_vect_atom_4",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Func (Unit, Atom (16, 0)))
+ (cast_to_rep (Vect (1, Atom (16, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_func_vect_atom_5",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (16, 0))
+ (cast_to_rep (Func (Atom (1, 0), Atom (16, 0)))
+ (cast_to_rep (Vect (1, Atom (16, 0))) atom16_v1)),
+ atom16_v1)),
+ ("rep_conversion_atom_vect_atom",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Vect (2, Struct [Atom (2, 0), Atom (3, 0)]))
+ atom36_v1),
+ atom36_v1)),
+ ("rep_conversion_atom_func_atom",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Atom (36, 0))
+ (cast_to_rep (Func (Atom (2, 0),
+ Struct [Atom (2, 0), Atom (3, 0)])) atom36_v1),
+ atom36_v1)),
+ ("rep_conversion_struct_atom1_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (1, 0), Atom (1, 0)]) atom1_v1,
+ struct_atom1_atom1_v1)),
+ ("rep_conversion_struct_atom1_2",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (1, 0), Unit]) atom1_v1,
+ struct_atom1_unit_v1)),
+ ("rep_conversion_struct_atom1_3",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Unit, Atom (1, 0)]) atom1_v1,
+ struct_unit_atom1_v1))
+(*
+ ("rep_conversion_struct_formula_struct_1",
+ Op2 (Eq, bool_T, Formula Neut,
+ cast_to_rep (Struct [Atom (2, 0), Unit])
+ (cast_to_rep (Formula Neut) struct_atom_2_unit_v1),
+ struct_atom_2_unit_v1))
+*)
+ ]
+
+fun problem_for_nut ctxt name u =
+ let
+ val debug = false
+ val peephole_optim = true
+ val nat_card = 4
+ val int_card = 9
+ val j0 = 0
+ val constrs = kodkod_constrs peephole_optim nat_card int_card j0
+ val (free_rels, pool, table) =
+ rename_free_vars (fst (add_free_and_const_names u ([], []))) initial_pool
+ NameTable.empty
+ val u = Op1 (Not, type_of u, rep_of u, u)
+ |> rename_vars_in_nut pool table
+ val formula = kodkod_formula_from_nut Typtab.empty false constrs u
+ val bounds = map (bound_for_plain_rel ctxt debug) free_rels
+ val univ_card = univ_card nat_card int_card j0 bounds formula
+ val declarative_axioms = map (declarative_axiom_for_plain_rel constrs)
+ free_rels
+ val formula = fold_rev s_and declarative_axioms formula
+ in
+ {comment = name, settings = settings, univ_card = univ_card,
+ tuple_assigns = [], bounds = bounds, int_bounds = [], expr_assigns = [],
+ formula = formula}
+ end
+
+(* string -> unit *)
+fun run_test name =
+ case Kodkod.solve_any_problem true NONE 0 1
+ [problem_for_nut @{context} name
+ (the (AList.lookup (op =) tests name))] of
+ Kodkod.Normal ([], _) => ()
+ | _ => warning ("Test " ^ quote name ^ " failed")
+
+(* unit -> unit *)
+fun run_all_tests () = List.app run_test (map fst tests)
+
+end;--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_util.ML Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,307 @@
+(* Title: HOL/Nitpick/Tools/nitpick_util.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009
+
+General-purpose functions used by the Nitpick modules.
+*)
+
+infix 6 nat_minus
+infix 7 pairf
+
+signature BASIC_NITPICK_UTIL =
+sig
+ type styp = string * typ
+end;
+
+signature NITPICK_UTIL =
+sig
+ include BASIC_NITPICK_UTIL
+
+ datatype polarity = Pos | Neg | Neut
+
+ exception ARG of string * string
+ exception BAD of string * string
+ exception LIMIT of string * string
+ exception NOT_SUPPORTED of string
+ exception SAME of unit
+
+ val nitpick_prefix : string
+ val curry3 : ('a * 'b * 'c -> 'd) -> 'a -> 'b -> 'c -> 'd
+ val pairf : ('a -> 'b) * ('a -> 'c) -> 'a -> 'b * 'c
+ val int_for_bool : bool -> int
+ val nat_minus : int * int -> int
+ val reasonable_power : int -> int -> int
+ val exact_log : int -> int -> int
+ val exact_root : int -> int -> int
+ val offset_list : int list -> int list
+ val index_seq : int -> int -> int list
+ val filter_indices : int list -> 'a list -> 'a list
+ val filter_out_indices : int list -> 'a list -> 'a list
+ val fold1 : ('a -> 'a -> 'a) -> 'a list -> 'a
+ val replicate_list : int -> 'a list -> 'a list
+ val n_fold_cartesian_product : 'a list list -> 'a list list
+ val all_distinct_unordered_pairs_of : ''a list -> (''a * ''a) list
+ val nth_combination : (int * int) list -> int -> int list
+ val all_combinations : (int * int) list -> int list list
+ val all_permutations : 'a list -> 'a list list
+ val batch_list : int -> 'a list -> 'a list list
+ val chunk_list_unevenly : int list -> 'a list -> 'a list list
+ val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+ val double_lookup :
+ ('a * 'a -> bool) -> ('a option * 'b) list -> 'a -> 'b option
+ val triple_lookup :
+ (''a * ''a -> bool) -> (''a option * 'b) list -> ''a -> 'b option
+ val is_substring_of : string -> string -> bool
+ val serial_commas : string -> string list -> string list
+ val plural_s : int -> string
+ val plural_s_for_list : 'a list -> string
+ val flip_polarity : polarity -> polarity
+ val prop_T : typ
+ val bool_T : typ
+ val nat_T : typ
+ val int_T : typ
+ val subscript : string -> string
+ val nat_subscript : int -> string
+ val time_limit : Time.time option -> ('a -> 'b) -> 'a -> 'b
+ val silence : ('a -> 'b) -> 'a -> 'b
+ val DETERM_TIMEOUT : Time.time option -> tactic -> tactic
+ val setmp_show_all_types : ('a -> 'b) -> 'a -> 'b
+ val indent_size : int
+ val pstrs : string -> Pretty.T list
+ val plain_string_from_yxml : string -> string
+ val maybe_quote : string -> string
+end
+
+structure NitpickUtil : NITPICK_UTIL =
+struct
+
+type styp = string * typ
+
+datatype polarity = Pos | Neg | Neut
+
+exception ARG of string * string
+exception BAD of string * string
+exception LIMIT of string * string
+exception NOT_SUPPORTED of string
+exception SAME of unit
+
+val nitpick_prefix = "Nitpick."
+
+(* ('a * 'b * 'c -> 'd) -> 'a -> 'b -> 'c -> 'd *)
+fun curry3 f = fn x => fn y => fn z => f (x, y, z)
+
+(* ('a -> 'b) * ('a -> 'c) -> 'a -> 'b * 'c *)
+fun (f pairf g) = fn x => (f x, g x)
+
+(* bool -> int *)
+fun int_for_bool b = if b then 1 else 0
+(* int * int -> int *)
+fun (i nat_minus j) = if i > j then i - j else 0
+
+val max_exponent = 16384
+
+(* int -> int -> int *)
+fun reasonable_power a 0 = 1
+ | reasonable_power a 1 = a
+ | reasonable_power 0 _ = 0
+ | reasonable_power 1 _ = 1
+ | reasonable_power a b =
+ if b < 0 orelse b > max_exponent then
+ raise LIMIT ("NitpickUtil.reasonable_power",
+ "too large exponent (" ^ signed_string_of_int b ^ ")")
+ else
+ let
+ val c = reasonable_power a (b div 2) in
+ c * c * reasonable_power a (b mod 2)
+ end
+
+(* int -> int -> int *)
+fun exact_log m n =
+ let
+ val r = Math.ln (Real.fromInt n) / Math.ln (Real.fromInt m) |> Real.round
+ in
+ if reasonable_power m r = n then
+ r
+ else
+ raise ARG ("NitpickUtil.exact_log",
+ commas (map signed_string_of_int [m, n]))
+ end
+
+(* int -> int -> int *)
+fun exact_root m n =
+ let val r = Math.pow (Real.fromInt n, 1.0 / (Real.fromInt m)) |> Real.round in
+ if reasonable_power r m = n then
+ r
+ else
+ raise ARG ("NitpickUtil.exact_root",
+ commas (map signed_string_of_int [m, n]))
+ end
+
+(* ('a -> 'a -> 'a) -> 'a list -> 'a *)
+fun fold1 f = foldl1 (uncurry f)
+
+(* int -> 'a list -> 'a list *)
+fun replicate_list 0 _ = []
+ | replicate_list n xs = xs @ replicate_list (n - 1) xs
+
+(* int list -> int list *)
+fun offset_list ns = rev (tl (fold (fn x => fn xs => (x + hd xs) :: xs) ns [0]))
+(* int -> int -> int list *)
+fun index_seq j0 n = if j0 < 0 then j0 downto j0 - n + 1 else j0 upto j0 + n - 1
+
+(* int list -> 'a list -> 'a list *)
+fun filter_indices js xs =
+ let
+ (* int -> int list -> 'a list -> 'a list *)
+ fun aux _ [] _ = []
+ | aux i (j :: js) (x :: xs) =
+ if i = j then x :: aux (i + 1) js xs else aux (i + 1) (j :: js) xs
+ | aux _ _ _ = raise ARG ("NitpickUtil.filter_indices",
+ "indices unordered or out of range")
+ in aux 0 js xs end
+fun filter_out_indices js xs =
+ let
+ (* int -> int list -> 'a list -> 'a list *)
+ fun aux _ [] xs = xs
+ | aux i (j :: js) (x :: xs) =
+ if i = j then aux (i + 1) js xs else x :: aux (i + 1) (j :: js) xs
+ | aux _ _ _ = raise ARG ("NitpickUtil.filter_out_indices",
+ "indices unordered or out of range")
+ in aux 0 js xs end
+
+(* 'a list -> 'a list list -> 'a list list *)
+fun cartesian_product [] _ = []
+ | cartesian_product (x :: xs) yss =
+ map (cons x) yss @ cartesian_product xs yss
+(* 'a list list -> 'a list list *)
+fun n_fold_cartesian_product xss = fold_rev cartesian_product xss [[]]
+(* ''a list -> (''a * ''a) list *)
+fun all_distinct_unordered_pairs_of [] = []
+ | all_distinct_unordered_pairs_of (x :: xs) =
+ map (pair x) xs @ all_distinct_unordered_pairs_of xs
+
+(* (int * int) list -> int -> int list *)
+val nth_combination =
+ let
+ (* (int * int) list -> int -> int list * int *)
+ fun aux [] n = ([], n)
+ | aux ((k, j0) :: xs) n =
+ let val (js, n) = aux xs n in ((n mod k) + j0 :: js, n div k) end
+ in fst oo aux end
+
+(* (int * int) list -> int list list *)
+val all_combinations = n_fold_cartesian_product o map (uncurry index_seq o swap)
+
+(* 'a list -> 'a list list *)
+fun all_permutations [] = [[]]
+ | all_permutations xs =
+ maps (fn j => map (cons (nth xs j)) (all_permutations (nth_drop j xs)))
+ (index_seq 0 (length xs))
+
+(* int -> 'a list -> 'a list list *)
+fun batch_list _ [] = []
+ | batch_list k xs =
+ if length xs <= k then [xs]
+ else List.take (xs, k) :: batch_list k (List.drop (xs, k))
+
+(* int list -> 'a list -> 'a list list *)
+fun chunk_list_unevenly _ [] = []
+ | chunk_list_unevenly [] ys = map single ys
+ | chunk_list_unevenly (k :: ks) ys =
+ let val (ys1, ys2) = chop k ys in ys1 :: chunk_list_unevenly ks ys2 end
+
+(* ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list *)
+fun map3 _ [] [] [] = []
+ | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
+ | map3 _ _ _ _ = raise UnequalLengths
+
+(* ('a * 'a -> bool) -> ('a option * 'b) list -> 'a -> 'b option *)
+fun double_lookup eq ps key =
+ case AList.lookup (fn (SOME x, SOME y) => eq (x, y) | _ => false) ps
+ (SOME key) of
+ SOME z => SOME z
+ | NONE => ps |> find_first (is_none o fst) |> Option.map snd
+(* (''a * ''a -> bool) -> (''a option * 'b) list -> ''a -> 'b option *)
+fun triple_lookup eq ps key =
+ case AList.lookup (op =) ps (SOME key) of
+ SOME z => SOME z
+ | NONE => double_lookup eq ps key
+
+(* string -> string -> bool *)
+fun is_substring_of needle stack =
+ not (Substring.isEmpty (snd (Substring.position needle
+ (Substring.full stack))))
+
+(* string -> string list -> string list *)
+fun serial_commas _ [] = ["??"]
+ | serial_commas _ [s] = [s]
+ | serial_commas conj [s1, s2] = [s1, conj, s2]
+ | serial_commas conj [s1, s2, s3] = [s1 ^ ",", s2 ^ ",", conj, s3]
+ | serial_commas conj (s :: ss) = s ^ "," :: serial_commas conj ss
+
+(* int -> string *)
+fun plural_s n = if n = 1 then "" else "s"
+(* 'a list -> string *)
+fun plural_s_for_list xs = plural_s (length xs)
+
+(* polarity -> polarity *)
+fun flip_polarity Pos = Neg
+ | flip_polarity Neg = Pos
+ | flip_polarity Neut = Neut
+
+val prop_T = @{typ prop}
+val bool_T = @{typ bool}
+val nat_T = @{typ nat}
+val int_T = @{typ int}
+
+(* string -> string *)
+val subscript = implode o map (prefix "\<^isub>") o explode
+(* int -> string *)
+val nat_subscript = subscript o signed_string_of_int
+
+(* Time.time option -> ('a -> 'b) -> 'a -> 'b *)
+fun time_limit NONE f = f
+ | time_limit (SOME delay) f = TimeLimit.timeLimit delay f
+
+(* (string -> unit) Unsynchronized.ref -> ('a -> 'b) -> 'a -> 'b *)
+fun silence_one out_fn = setmp_CRITICAL out_fn (K ())
+
+(* ('a -> 'b) -> 'a -> 'b *)
+fun silence f =
+ fold silence_one
+ [Output.writeln_fn, Output.priority_fn, Output.tracing_fn,
+ Output.warning_fn, Output.error_fn, Output.debug_fn] f
+
+(* Time.time option -> tactic -> tactic *)
+fun DETERM_TIMEOUT delay tac st =
+ Seq.of_list (the_list (time_limit delay (fn () => SINGLE tac st) ()))
+
+(* ('a -> 'b) -> 'a -> 'b *)
+fun setmp_show_all_types f =
+ setmp_CRITICAL show_all_types
+ (! show_types orelse ! show_sorts orelse ! show_all_types) f
+
+val indent_size = 2
+
+(* string -> Pretty.T list *)
+val pstrs = Pretty.breaks o map Pretty.str o space_explode " "
+
+(* XML.tree -> string *)
+fun plain_string_from_xml_tree t =
+ Buffer.empty |> XML.add_content t |> Buffer.content
+(* string -> string *)
+val plain_string_from_yxml = plain_string_from_xml_tree o YXML.parse
+
+(* string -> bool *)
+val is_long_identifier = forall Syntax.is_identifier o space_explode "."
+(* string -> string *)
+fun maybe_quote y =
+ let val s = plain_string_from_yxml y in
+ y |> (not (is_long_identifier (perhaps (try (unprefix "'")) s))
+ orelse OuterKeyword.is_keyword s) ? quote
+ end
+
+end;
+
+structure BasicNitpickUtil : BASIC_NITPICK_UTIL = NitpickUtil;
+open BasicNitpickUtil;--- a/src/HOL/Tools/Predicate_Compile/pred_compile_aux.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_aux.ML Tue Oct 27 14:46:03 2009 +0000
@@ -6,8 +6,16 @@
structure Predicate_Compile_Aux =
struct
+(* general syntactic functions *)
+
+(*Like dest_conj, but flattens conjunctions however nested*)
+fun conjuncts_aux (Const ("op &", _) $ t $ t') conjs = conjuncts_aux t (conjuncts_aux t' conjs)
+ | conjuncts_aux t conjs = t::conjs;
+
+fun conjuncts t = conjuncts_aux t [];
+
(* syntactic functions *)
-
+
fun is_equationlike_term (Const ("==", _) $ _ $ _) = true
| is_equationlike_term (Const ("Trueprop", _) $ (Const ("op =", _) $ _ $ _)) = true
| is_equationlike_term _ = false
@@ -69,26 +77,52 @@
in ((ps', t''), nctxt') end;
+(* introduction rule combinators *)
+(* combinators to apply a function to all literals of an introduction rules *)
-(*
fun map_atoms f intro =
-fun fold_atoms f intro =
-*)
+ let
+ val (literals, head) = Logic.strip_horn intro
+ fun appl t = (case t of
+ (@{term "Not"} $ t') => HOLogic.mk_not (f t')
+ | _ => f t)
+ in
+ Logic.list_implies
+ (map (HOLogic.mk_Trueprop o appl o HOLogic.dest_Trueprop) literals, head)
+ end
+
+fun fold_atoms f intro s =
+ let
+ val (literals, head) = Logic.strip_horn intro
+ fun appl t s = (case t of
+ (@{term "Not"} $ t') => f t' s
+ | _ => f t s)
+ in fold appl (map HOLogic.dest_Trueprop literals) s end
+
fun fold_map_atoms f intro s =
let
val (literals, head) = Logic.strip_horn intro
fun appl t s = (case t of
- (@{term "Not"} $ t') =>
- let
- val (t'', s') = f t' s
- in (@{term "Not"} $ t'', s') end
+ (@{term "Not"} $ t') => apfst HOLogic.mk_not (f t' s)
| _ => f t s)
val (literals', s') = fold_map appl (map HOLogic.dest_Trueprop literals) s
in
(Logic.list_implies (map HOLogic.mk_Trueprop literals', head), s')
end;
+
+fun maps_premises f intro =
+ let
+ val (premises, head) = Logic.strip_horn intro
+ in
+ Logic.list_implies (maps f premises, head)
+ end
+(* lifting term operations to theorems *)
+
+fun map_term thy f th =
+ Skip_Proof.make_thm thy (f (prop_of th))
+
(*
fun equals_conv lhs_cv rhs_cv ct =
case Thm.term_of ct of
@@ -96,5 +130,107 @@
| _ => error "equals_conv"
*)
+(* Different options for compiler *)
+
+datatype options = Options of {
+ expected_modes : (string * int list list) option,
+ show_steps : bool,
+ show_mode_inference : bool,
+ show_proof_trace : bool,
+ show_intermediate_results : bool,
+ show_compilation : bool,
+ skip_proof : bool,
+
+ inductify : bool,
+ rpred : bool,
+ depth_limited : bool
+};
+
+fun expected_modes (Options opt) = #expected_modes opt
+fun show_steps (Options opt) = #show_steps opt
+fun show_mode_inference (Options opt) = #show_mode_inference opt
+fun show_intermediate_results (Options opt) = #show_intermediate_results opt
+fun show_proof_trace (Options opt) = #show_proof_trace opt
+fun show_compilation (Options opt) = #show_compilation opt
+fun skip_proof (Options opt) = #skip_proof opt
+
+fun is_inductify (Options opt) = #inductify opt
+fun is_rpred (Options opt) = #rpred opt
+fun is_depth_limited (Options opt) = #depth_limited opt
+
+val default_options = Options {
+ expected_modes = NONE,
+ show_steps = false,
+ show_intermediate_results = false,
+ show_proof_trace = false,
+ show_mode_inference = false,
+ show_compilation = false,
+ skip_proof = false,
+
+ inductify = false,
+ rpred = false,
+ depth_limited = false
+}
+
+
+fun print_step options s =
+ if show_steps options then tracing s else ()
+
+(* tuple processing *)
+
+fun expand_tuples thy intro =
+ let
+ fun rewrite_args [] (pats, intro_t, ctxt) = (pats, intro_t, ctxt)
+ | rewrite_args (arg::args) (pats, intro_t, ctxt) =
+ (case HOLogic.strip_tupleT (fastype_of arg) of
+ (Ts as _ :: _ :: _) =>
+ let
+ fun rewrite_arg' (Const ("Pair", _) $ _ $ t2, Type ("*", [_, T2]))
+ (args, (pats, intro_t, ctxt)) = rewrite_arg' (t2, T2) (args, (pats, intro_t, ctxt))
+ | rewrite_arg' (t, Type ("*", [T1, T2])) (args, (pats, intro_t, ctxt)) =
+ let
+ val ([x, y], ctxt') = Variable.variant_fixes ["x", "y"] ctxt
+ val pat = (t, HOLogic.mk_prod (Free (x, T1), Free (y, T2)))
+ val intro_t' = Pattern.rewrite_term thy [pat] [] intro_t
+ val args' = map (Pattern.rewrite_term thy [pat] []) args
+ in
+ rewrite_arg' (Free (y, T2), T2) (args', (pat::pats, intro_t', ctxt'))
+ end
+ | rewrite_arg' _ (args, (pats, intro_t, ctxt)) = (args, (pats, intro_t, ctxt))
+ val (args', (pats, intro_t', ctxt')) = rewrite_arg' (arg, fastype_of arg)
+ (args, (pats, intro_t, ctxt))
+ in
+ rewrite_args args' (pats, intro_t', ctxt')
+ end
+ | _ => rewrite_args args (pats, intro_t, ctxt))
+ fun rewrite_prem atom =
+ let
+ val (_, args) = strip_comb atom
+ in rewrite_args args end
+ val ctxt = ProofContext.init thy
+ val (((T_insts, t_insts), [intro']), ctxt1) = Variable.import false [intro] ctxt
+ val intro_t = prop_of intro'
+ val concl = Logic.strip_imp_concl intro_t
+ val (p, args) = strip_comb (HOLogic.dest_Trueprop concl)
+ val (pats', intro_t', ctxt2) = rewrite_args args ([], intro_t, ctxt1)
+ val (pats', intro_t', ctxt3) =
+ fold_atoms rewrite_prem intro_t' (pats', intro_t', ctxt2)
+ fun rewrite_pat (ct1, ct2) =
+ (ct1, cterm_of thy (Pattern.rewrite_term thy pats' [] (term_of ct2)))
+ val t_insts' = map rewrite_pat t_insts
+ val intro'' = Thm.instantiate (T_insts, t_insts') intro
+ val [intro'''] = Variable.export ctxt3 ctxt [intro'']
+ val intro'''' = Simplifier.full_simplify
+ (HOL_basic_ss addsimps [@{thm fst_conv}, @{thm snd_conv}, @{thm Pair_eq}])
+ intro'''
+ (* splitting conjunctions introduced by Pair_eq*)
+ fun split_conj prem =
+ map HOLogic.mk_Trueprop (conjuncts (HOLogic.dest_Trueprop prem))
+ val intro''''' = map_term thy (maps_premises split_conj) intro''''
+ in
+ intro'''''
+ end
+
+
end;--- a/src/HOL/Tools/Predicate_Compile/pred_compile_data.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_data.ML Tue Oct 27 14:46:03 2009 +0000
@@ -3,16 +3,16 @@
Book-keeping datastructure for the predicate compiler
*)
-signature PRED_COMPILE_DATA =
+signature PREDICATE_COMPILE_DATA =
sig
type specification_table;
val make_const_spec_table : theory -> specification_table
val get_specification : specification_table -> string -> thm list
- val obtain_specification_graph : specification_table -> string -> thm list Graph.T
+ val obtain_specification_graph : theory -> specification_table -> string -> thm list Graph.T
val normalize_equation : theory -> thm -> thm
end;
-structure Pred_Compile_Data : PRED_COMPILE_DATA =
+structure Predicate_Compile_Data : PREDICATE_COMPILE_DATA =
struct
open Predicate_Compile_Aux;
@@ -81,11 +81,13 @@
Const ("Trueprop", _) $ (Const ("op =", _) $ _ $ _) => th RS @{thm eq_reflection}
| _ => th
+val meta_fun_cong = @{lemma "f == g ==> f x == g x" by simp}
+
fun full_fun_cong_expand th =
let
val (f, args) = strip_comb (fst (Logic.dest_equals (prop_of th)))
val i = length (binder_types (fastype_of f)) - length args
- in funpow i (fn th => th RS @{thm meta_fun_cong}) th end;
+ in funpow i (fn th => th RS meta_fun_cong) th end;
fun declare_names s xs ctxt =
let
@@ -117,7 +119,7 @@
fun normalize_equation thy th =
mk_meta_equation th
- |> Pred_Compile_Set.unfold_set_notation
+ |> Predicate_Compile_Set.unfold_set_notation
|> full_fun_cong_expand
|> split_all_pairs thy
|> tap check_equation_format
@@ -127,19 +129,18 @@
fun store_thm_in_table ignore_consts thy th=
let
- val th = AxClass.unoverload thy th
+ val th = th
|> inline_equations thy
+ |> Predicate_Compile_Set.unfold_set_notation
+ |> AxClass.unoverload thy
val (const, th) =
if is_equationlike th then
let
- val _ = priority "Normalizing definition..."
val eq = normalize_equation thy th
in
(defining_const_of_equation eq, eq)
end
- else if (is_introlike th) then
- let val th = Pred_Compile_Set.unfold_set_notation th
- in (defining_const_of_introrule th, th) end
+ else if (is_introlike th) then (defining_const_of_introrule th, th)
else error "store_thm: unexpected definition format"
in
if not (member (op =) ignore_consts const) then
@@ -147,18 +148,6 @@
else I
end
-(*
-fun make_const_spec_table_warning thy =
- fold
- (fn th => fn thy => case try (store_thm th) thy of
- SOME thy => thy
- | NONE => (warning ("store_thm fails for " ^ Display.string_of_thm_global thy th) ; thy))
- (Predicate_Compile_Preproc_Const_Defs.get (ProofContext.init thy)) thy
-
-fun make_const_spec_table thy =
- fold store_thm (Predicate_Compile_Preproc_Const_Defs.get (ProofContext.init thy)) thy
- |> (fn thy => fold store_thm (Nitpick_Simps.get (ProofContext.init thy)) thy)
-*)
fun make_const_spec_table thy =
let
fun store ignore_const f = fold (store_thm_in_table ignore_const thy) (map (Thm.transfer thy) (f (ProofContext.init thy)))
@@ -166,35 +155,27 @@
|> store [] Predicate_Compile_Alternative_Defs.get
val ignore_consts = Symtab.keys table
in
- table
+ table
|> store ignore_consts Predicate_Compile_Preproc_Const_Defs.get
|> store ignore_consts Nitpick_Simps.get
|> store ignore_consts Nitpick_Intros.get
end
- (*
-fun get_specification thy constname =
- case Symtab.lookup (#const_spec_table (Data.get thy)) constname of
- SOME thms => thms
- | NONE => error ("get_specification: lookup of constant " ^ quote constname ^ " failed")
- *)
+
fun get_specification table constname =
case Symtab.lookup table constname of
- SOME thms =>
- let
- val _ = tracing ("Looking up specification of " ^ constname ^ ": "
- ^ (commas (map Display.string_of_thm_without_context thms)))
- in thms end
+ SOME thms => thms
| NONE => error ("get_specification: lookup of constant " ^ quote constname ^ " failed")
val logic_operator_names =
- [@{const_name "=="}, @{const_name "op ="}, @{const_name "op -->"}, @{const_name "All"}, @{const_name "op &"}]
+ [@{const_name "=="}, @{const_name "op ="}, @{const_name "op -->"}, @{const_name "All"}, @{const_name "Ex"},
+ @{const_name "op &"}]
-val special_cases = member (op =) [@{const_name "Suc"}, @{const_name Nat.zero_nat_inst.zero_nat},
+val special_cases = member (op =) [
+ @{const_name "False"},
+ @{const_name "Suc"}, @{const_name Nat.zero_nat_inst.zero_nat},
@{const_name Nat.one_nat_inst.one_nat},
@{const_name "HOL.ord_class.less"}, @{const_name "HOL.ord_class.less_eq"}, @{const_name "HOL.zero_class.zero"},
@{const_name "HOL.one_class.one"}, @{const_name HOL.plus_class.plus},
-@{const_name "Nat.nat.nat_case"}, @{const_name "List.list.list_case"},
-@{const_name "Option.option.option_case"},
@{const_name Nat.ord_nat_inst.less_eq_nat},
@{const_name number_nat_inst.number_of_nat},
@{const_name Int.Bit0},
@@ -203,13 +184,19 @@
@{const_name "Int.zero_int_inst.zero_int"},
@{const_name "List.filter"}]
-fun obtain_specification_graph table constname =
+fun case_consts thy s = is_some (Datatype.info_of_case thy s)
+
+fun obtain_specification_graph thy table constname =
let
fun is_nondefining_constname c = member (op =) logic_operator_names c
val is_defining_constname = member (op =) (Symtab.keys table)
+ fun has_code_pred_intros c = is_some (try (Predicate_Compile_Core.intros_of thy) c)
fun defiants_of specs =
fold (Term.add_const_names o prop_of) specs []
|> filter is_defining_constname
+ |> filter_out is_nondefining_constname
+ |> filter_out has_code_pred_intros
+ |> filter_out (case_consts thy)
|> filter_out special_cases
fun extend constname =
let--- a/src/HOL/Tools/Predicate_Compile/pred_compile_fun.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_fun.ML Tue Oct 27 14:46:03 2009 +0000
@@ -5,9 +5,10 @@
signature PREDICATE_COMPILE_FUN =
sig
- val define_predicates : (string * thm list) list -> theory -> theory
+val define_predicates : (string * thm list) list -> theory -> (string * thm list) list * theory
val rewrite_intro : theory -> thm -> thm list
val setup_oracle : theory -> theory
+ val pred_of_function : theory -> string -> string option
end;
structure Predicate_Compile_Fun : PREDICATE_COMPILE_FUN =
@@ -63,6 +64,8 @@
fun merge _ = Symtab.merge (op =);
)
+fun pred_of_function thy name = Symtab.lookup (Pred_Compile_Preproc.get thy) name
+
fun defined thy = Symtab.defined (Pred_Compile_Preproc.get thy)
@@ -99,23 +102,29 @@
(Free (Long_Name.base_name name ^ "P", pred_type T))
end
-fun mk_param lookup_pred (t as Free (v, _)) = lookup_pred t
- | mk_param lookup_pred t =
+fun mk_param thy lookup_pred (t as Free (v, _)) = lookup_pred t
+ | mk_param thy lookup_pred t =
let
- val (vs, body) = strip_abs t
- val names = Term.add_free_names body []
- val vs_names = Name.variant_list names (map fst vs)
- val vs' = map2 (curry Free) vs_names (map snd vs)
- val body' = subst_bounds (rev vs', body)
- val (f, args) = strip_comb body'
- val resname = Name.variant (vs_names @ names) "res"
- val resvar = Free (resname, body_type (fastype_of body'))
- val P = lookup_pred f
- val pred_body = list_comb (P, args @ [resvar])
- val param = fold_rev lambda (vs' @ [resvar]) pred_body
- in param end;
-
-
+ val _ = tracing ("called param with " ^ (Syntax.string_of_term_global thy t))
+ in if Predicate_Compile_Aux.is_predT (fastype_of t) then
+ t
+ else
+ let
+ val (vs, body) = strip_abs t
+ val names = Term.add_free_names body []
+ val vs_names = Name.variant_list names (map fst vs)
+ val vs' = map2 (curry Free) vs_names (map snd vs)
+ val body' = subst_bounds (rev vs', body)
+ val (f, args) = strip_comb body'
+ val resname = Name.variant (vs_names @ names) "res"
+ val resvar = Free (resname, body_type (fastype_of body'))
+ (*val P = case try lookup_pred f of SOME P => P | NONE => error "mk_param"
+ val pred_body = list_comb (P, args @ [resvar])
+ *)
+ val pred_body = HOLogic.mk_eq (body', resvar)
+ val param = fold_rev lambda (vs' @ [resvar]) pred_body
+ in param end
+ end
(* creates the list of premises for every intro rule *)
(* theory -> term -> (string list, term list list) *)
@@ -210,10 +219,14 @@
let
fun mk_prems' (t as Const (name, T)) (names, prems) =
if is_constr thy name orelse (is_none (try lookup_pred t)) then
- [(t ,(names, prems))]
+ [(t, (names, prems))]
else [(lookup_pred t, (names, prems))]
| mk_prems' (t as Free (f, T)) (names, prems) =
[(lookup_pred t, (names, prems))]
+ | mk_prems' (t as Abs _) (names, prems) =
+ if Predicate_Compile_Aux.is_predT (fastype_of t) then
+ [(t, (names, prems))] else error "mk_prems': Abs "
+ (* mk_param *)
| mk_prems' t (names, prems) =
if Predicate_Compile_Aux.is_constrt thy t then
[(t, (names, prems))]
@@ -243,8 +256,10 @@
maps mk_prems_of_assm assms
end
else
- let
+ let
val (f, args) = strip_comb t
+ (* TODO: special procedure for higher-order functions: split arguments in
+ simple types and function types *)
val resname = Name.variant names "res"
val resvar = Free (resname, body_type (fastype_of t))
val names' = resname :: names
@@ -261,8 +276,7 @@
val pred = lookup_pred t
val nparams = get_nparams pred
val (params, args) = chop nparams args
- val _ = tracing ("mk_prems'': " ^ (Syntax.string_of_term_global thy t) ^ " has " ^ string_of_int nparams ^ " parameters.")
- val params' = map (mk_param lookup_pred) params
+ val params' = map (mk_param thy lookup_pred) params
in
folds_map mk_prems' args (names', prems)
|> map (fn (argvs, (names'', prems')) =>
@@ -281,7 +295,8 @@
val prem = HOLogic.mk_Trueprop (list_comb (pred, argvs @ [resvar]))
in (names', prem :: prems') end)
end
- | mk_prems'' t = error ("Invalid term: " ^ Syntax.string_of_term_global thy t)
+ | mk_prems'' t =
+ error ("Invalid term: " ^ Syntax.string_of_term_global thy t)
in
map (pair resvar) (mk_prems'' f)
end
@@ -292,7 +307,7 @@
(* assumption: mutual recursive predicates all have the same parameters. *)
fun define_predicates specs thy =
if forall (fn (const, _) => member (op =) (Symtab.keys (Pred_Compile_Preproc.get thy)) const) specs then
- thy
+ ([], thy)
else
let
val consts = map fst specs
@@ -307,16 +322,14 @@
val funnames = map (fst o dest_Const) funs
val fun_pred_names = (funnames ~~ prednames)
(* mapping from term (Free or Const) to term *)
- fun lookup_pred (Const (@{const_name Cons}, T)) =
- Const ("Preprocessing.ConsP", pred_type T) (* FIXME: temporary - Cons lookup *)
- | lookup_pred (Const (name, T)) =
+ fun lookup_pred (Const (name, T)) =
(case (Symtab.lookup (Pred_Compile_Preproc.get thy) name) of
SOME c => Const (c, pred_type T)
| NONE =>
(case AList.lookup op = fun_pred_names name of
SOME f => Free (f, pred_type T)
| NONE => Const (name, T)))
- | lookup_pred (Free (name, T)) =
+ | lookup_pred (Free (name, T)) =
if member op = (map fst pnames) name then
Free (name, transform_ho_typ T)
else
@@ -347,16 +360,14 @@
Logic.list_implies (prems, HOLogic.mk_Trueprop (list_comb (pred, args @ [resultt]))))
end
fun mk_rewr_thm (func, pred) = @{thm refl}
- in
+ in
case try (maps mk_intros) ((funs ~~ preds) ~~ (argss' ~~ rhss)) of
- NONE => thy
- | SOME intr_ts => let
- val _ = map (tracing o (Syntax.string_of_term_global thy)) intr_ts
- in
+ NONE => ([], thy)
+ | SOME intr_ts =>
if is_some (try (map (cterm_of thy)) intr_ts) then
let
val (ind_result, thy') =
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = false, verbose = false, kind = Thm.internalK,
alt_name = Binding.empty, coind = false, no_elim = false,
no_ind = false, skip_mono = false, fork_mono = false}
@@ -367,10 +378,15 @@
val prednames = map (fst o dest_Const) (#preds ind_result)
(* val rewr_thms = map mk_rewr_eq ((distinct (op =) funs) ~~ (#preds ind_result)) *)
(* add constants to my table *)
- in Pred_Compile_Preproc.map (fold Symtab.update_new (consts ~~ prednames)) thy' end
+ val specs = map (fn predname => (predname, filter (Predicate_Compile_Aux.is_intro predname) (#intrs ind_result))) prednames
+ val thy'' = Pred_Compile_Preproc.map (fold Symtab.update_new (consts ~~ prednames)) thy'
+ in
+ (specs, thy'')
+ end
else
- thy
- end
+ let
+ val _ = tracing "Introduction rules of function_predicate are not welltyped"
+ in ([], thy) end
end
(* preprocessing intro rules - uses oracle *)
@@ -391,7 +407,6 @@
| get_nparams t = error ("No parameters for " ^ (Syntax.string_of_term_global thy t))
val intro_t = (Logic.unvarify o prop_of) intro
- val _ = tracing (Syntax.string_of_term_global thy intro_t)
val (prems, concl) = Logic.strip_horn intro_t
val frees = map fst (Term.add_frees intro_t [])
fun rewrite prem names =
@@ -415,8 +430,6 @@
rewrite concl frees'
|> map (fn (concl'::conclprems, _) =>
Logic.list_implies ((flat prems') @ conclprems, concl')))
- val _ = tracing ("intro_ts': " ^
- commas (map (Syntax.string_of_term_global thy) intro_ts'))
in
map (Drule.standard o the_oracle () o cterm_of thy) intro_ts'
end; --- a/src/HOL/Tools/Predicate_Compile/pred_compile_pred.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_pred.ML Tue Oct 27 14:46:03 2009 +0000
@@ -123,16 +123,67 @@
else
error ("unexpected specification for constant " ^ quote constname ^ ":\n"
^ commas (map (quote o Display.string_of_thm_global thy) specs))
- val _ = tracing ("Introduction rules of definitions before flattening: "
- ^ commas (map (Display.string_of_thm ctxt) intros))
- val _ = tracing "Defining local predicates and their intro rules..."
val (intros', (local_defs, thy')) = flatten_intros constname intros thy
val (intross, thy'') = fold_map preprocess local_defs thy'
in
- (intros' :: flat intross,thy'')
+ ((constname, intros') :: flat intross,thy'')
end;
fun preprocess_term t thy = error "preprocess_pred_term: to implement"
-
-
+
+fun is_Abs (Abs _) = true
+ | is_Abs _ = false
+
+fun flat_higher_order_arguments (intross, thy) =
+ let
+ fun process constname atom (new_defs, thy) =
+ let
+ val (pred, args) = strip_comb atom
+ val abs_args = filter is_Abs args
+ fun replace_abs_arg (abs_arg as Abs _ ) (new_defs, thy) =
+ let
+ val _ = tracing ("Introduce new constant for " ^
+ Syntax.string_of_term_global thy abs_arg)
+ val vars = map Var (Term.add_vars abs_arg [])
+ val abs_arg' = Logic.unvarify abs_arg
+ val frees = map Free (Term.add_frees abs_arg' [])
+ val constname = Name.variant (map (Long_Name.base_name o fst) new_defs)
+ ((Long_Name.base_name constname) ^ "_hoaux")
+ val full_constname = Sign.full_bname thy constname
+ val constT = map fastype_of frees ---> (fastype_of abs_arg')
+ val const = Const (full_constname, constT)
+ val lhs = list_comb (const, frees)
+ val def = Logic.mk_equals (lhs, abs_arg')
+ val _ = tracing (Syntax.string_of_term_global thy def)
+ val ([definition], thy') = thy
+ |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
+ |> PureThy.add_defs false [((Binding.name (constname ^ "_def"), def), [])]
+ in
+ (list_comb (Logic.varify const, vars), ((full_constname, [definition])::new_defs, thy'))
+ end
+ | replace_abs_arg arg (new_defs, thy) = (arg, (new_defs, thy))
+ val (args', (new_defs', thy')) = fold_map replace_abs_arg args (new_defs, thy)
+ in
+ (list_comb (pred, args'), (new_defs', thy'))
+ end
+ fun flat_intro intro (new_defs, thy) =
+ let
+ val constname = fst (dest_Const (fst (strip_comb
+ (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of intro))))))
+ val (intro_ts, (new_defs, thy)) = fold_map_atoms (process constname) (prop_of intro) (new_defs, thy)
+ val th = Skip_Proof.make_thm thy intro_ts
+ in
+ (th, (new_defs, thy))
+ end
+ fun fold_map_spec f [] s = ([], s)
+ | fold_map_spec f ((c, ths) :: specs) s =
+ let
+ val (ths', s') = f ths s
+ val (specs', s'') = fold_map_spec f specs s'
+ in ((c, ths') :: specs', s'') end
+ val (intross', (new_defs, thy')) = fold_map_spec (fold_map flat_intro) intross ([], thy)
+ in
+ (intross', (new_defs, thy'))
+ end
+
end;--- a/src/HOL/Tools/Predicate_Compile/pred_compile_quickcheck.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_quickcheck.ML Tue Oct 27 14:46:03 2009 +0000
@@ -3,18 +3,19 @@
A quickcheck generator based on the predicate compiler
*)
-signature PRED_COMPILE_QUICKCHECK =
+signature PREDICATE_COMPILE_QUICKCHECK =
sig
val quickcheck : Proof.context -> term -> int -> term list option
val test_ref :
((unit -> int -> int * int -> term list Predicate.pred * (int * int)) option) Unsynchronized.ref
end;
-structure Pred_Compile_Quickcheck : PRED_COMPILE_QUICKCHECK =
+structure Predicate_Compile_Quickcheck : PREDICATE_COMPILE_QUICKCHECK =
struct
val test_ref =
Unsynchronized.ref (NONE : (unit -> int -> int * int -> term list Predicate.pred * (int * int)) option)
+
val target = "Quickcheck"
fun dest_compfuns (Predicate_Compile_Core.CompilationFuns funs) = funs
@@ -63,21 +64,21 @@
val _ = tracing (Display.string_of_thm ctxt' intro)
val thy'' = thy'
|> Context.theory_map (Predicate_Compile_Preproc_Const_Defs.add_thm intro)
- |> Predicate_Compile.preprocess full_constname
- |> Predicate_Compile_Core.add_equations [full_constname]
- |> Predicate_Compile_Core.add_sizelim_equations [full_constname]
- |> Predicate_Compile_Core.add_quickcheck_equations [full_constname]
- val sizelim_modes = Predicate_Compile_Core.sizelim_modes_of thy'' full_constname
+ |> Predicate_Compile.preprocess Predicate_Compile_Aux.default_options full_constname
+ (* |> Predicate_Compile_Core.add_equations Predicate_Compile_Aux.default_options [full_constname]*)
+ (* |> Predicate_Compile_Core.add_depth_limited_equations Predicate_Compile_Aux.default_options [full_constname]*)
+ (* |> Predicate_Compile_Core.add_quickcheck_equations Predicate_Compile_Aux.default_options [full_constname] *)
+ val depth_limited_modes = Predicate_Compile_Core.depth_limited_modes_of thy'' full_constname
val modes = Predicate_Compile_Core.generator_modes_of thy'' full_constname
val prog =
if member (op =) modes ([], []) then
let
val name = Predicate_Compile_Core.generator_name_of thy'' full_constname ([], [])
- val T = @{typ code_numeral} --> (mk_rpredT (HOLogic.mk_tupleT (map snd vs')))
- in Const (name, T) $ Bound 0 end
- else if member (op =) sizelim_modes ([], []) then
+ val T = [@{typ bool}, @{typ code_numeral}] ---> (mk_rpredT (HOLogic.mk_tupleT (map snd vs')))
+ in Const (name, T) $ @{term True} $ Bound 0 end
+ else if member (op =) depth_limited_modes ([], []) then
let
- val name = Predicate_Compile_Core.sizelim_function_name_of thy'' full_constname ([], [])
+ val name = Predicate_Compile_Core.depth_limited_function_name_of thy'' full_constname ([], [])
val T = @{typ code_numeral} --> (mk_predT (HOLogic.mk_tupleT (map snd vs')))
in lift_pred (Const (name, T) $ Bound 0) end
else error "Predicate Compile Quickcheck failed"
@@ -85,7 +86,7 @@
mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
(map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))
val _ = tracing (Syntax.string_of_term ctxt' qc_term)
- val compile = Code_ML.eval (SOME target) ("Pred_Compile_Quickcheck.test_ref", test_ref)
+ val compile = Code_ML.eval (SOME target) ("Predicate_Compile_Quickcheck.test_ref", test_ref)
(fn proc => fn g => fn s => g s #>> (Predicate.map o map) proc)
thy'' qc_term []
in--- a/src/HOL/Tools/Predicate_Compile/pred_compile_set.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_set.ML Tue Oct 27 14:46:03 2009 +0000
@@ -3,7 +3,7 @@
Preprocessing sets to predicates
*)
-signature PRED_COMPILE_SET =
+signature PREDICATE_COMPILE_SET =
sig
(*
val preprocess_intro : thm -> theory -> thm * theory
@@ -12,10 +12,11 @@
val unfold_set_notation : thm -> thm;
end;
-structure Pred_Compile_Set : PRED_COMPILE_SET =
+structure Predicate_Compile_Set : PREDICATE_COMPILE_SET =
struct
(*FIXME: unfolding Ball in pretty adhoc here *)
-val unfold_set_lemmas = [@{thm Collect_def}, @{thm mem_def}, @{thm Ball_def}]
+val unfold_set_lemmas = [@{thm Collect_def}, @{thm mem_def},
+@{thm Ball_def}, @{thm Bex_def}]
val unfold_set_notation = Simplifier.rewrite_rule unfold_set_lemmas
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile.ML Tue Oct 27 14:46:03 2009 +0000
@@ -4,87 +4,170 @@
signature PREDICATE_COMPILE =
sig
val setup : theory -> theory
- val preprocess : string -> theory -> theory
+ val preprocess : Predicate_Compile_Aux.options -> string -> theory -> theory
end;
structure Predicate_Compile : PREDICATE_COMPILE =
struct
+(* options *)
+val fail_safe_mode = true
+
open Predicate_Compile_Aux;
val priority = tracing;
(* Some last processing *)
+
fun remove_pointless_clauses intro =
if Logic.strip_imp_prems (prop_of intro) = [@{prop "False"}] then
[]
else [intro]
-fun preprocess_strong_conn_constnames gr constnames thy =
+fun tracing s = ()
+
+fun print_intross options thy msg intross =
+ if show_intermediate_results options then
+ Output.tracing (msg ^
+ (space_implode "\n" (map
+ (fn (c, intros) => "Introduction rule(s) of " ^ c ^ ":\n" ^
+ commas (map (Display.string_of_thm_global thy) intros)) intross)))
+ else ()
+
+fun print_specs thy specs =
+ map (fn (c, thms) => "Constant " ^ c ^ " has specification:\n"
+ ^ (space_implode "\n" (map (Display.string_of_thm_global thy) thms)) ^ "\n") specs
+
+fun map_specs f specs =
+ map (fn (s, ths) => (s, f ths)) specs
+
+fun process_specification options specs thy' =
+ let
+ val _ = print_step options "Compiling predicates to flat introrules..."
+ val specs = map (apsnd (map
+ (fn th => if is_equationlike th then Predicate_Compile_Data.normalize_equation thy' th else th))) specs
+ val (intross1, thy'') = apfst flat (fold_map Predicate_Compile_Pred.preprocess specs thy')
+ val _ = print_intross options thy'' "Flattened introduction rules: " intross1
+ val _ = print_step options "Replacing functions in introrules..."
+ val intross2 =
+ if fail_safe_mode then
+ case try (map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross1 of
+ SOME intross => intross
+ | NONE => let val _ = warning "Function replacement failed!" in intross1 end
+ else map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy'')) intross1
+ val _ = print_intross options thy'' "Introduction rules with replaced functions: " intross2
+ val _ = print_step options "Introducing new constants for abstractions at higher-order argument positions..."
+ val (intross3, (new_defs, thy''')) = Predicate_Compile_Pred.flat_higher_order_arguments (intross2, thy'')
+ val (new_intross, thy'''') =
+ if not (null new_defs) then
+ let
+ val _ = print_step options "Recursively obtaining introduction rules for new definitions..."
+ in process_specification options new_defs thy''' end
+ else ([], thy''')
+ in
+ (intross3 @ new_intross, thy'''')
+ end
+
+
+fun preprocess_strong_conn_constnames options gr constnames thy =
let
val get_specs = map (fn k => (k, Graph.get_node gr k))
- val _ = priority ("Preprocessing scc of " ^ commas constnames)
+ val _ = print_step options ("Preprocessing scc of " ^ commas constnames)
val (prednames, funnames) = List.partition (is_pred thy) constnames
(* untangle recursion by defining predicates for all functions *)
- val _ = priority "Compiling functions to predicates..."
- val _ = tracing ("funnames: " ^ commas funnames)
- val thy' =
- thy |> not (null funnames) ? Predicate_Compile_Fun.define_predicates
- (get_specs funnames)
- val _ = priority "Compiling predicates to flat introrules..."
- val (intross, thy'') = apfst flat (fold_map Predicate_Compile_Pred.preprocess
- (get_specs prednames) thy')
- val _ = tracing ("Flattened introduction rules: " ^
- commas (map (Display.string_of_thm_global thy'') (flat intross)))
- val _ = priority "Replacing functions in introrules..."
- (* val _ = burrow (maps (Predicate_Compile_Fun.rewrite_intro thy'')) intross *)
- val intross' =
- case try (burrow (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross of
- SOME intross' => intross'
- | NONE => let val _ = warning "Function replacement failed!" in intross end
- val _ = tracing ("Introduction rules with replaced functions: " ^
- commas (map (Display.string_of_thm_global thy'') (flat intross')))
- val intross'' = burrow (maps remove_pointless_clauses) intross'
- val intross'' = burrow (map (AxClass.overload thy'')) intross''
- val _ = priority "Registering intro rules..."
- val thy''' = fold Predicate_Compile_Core.register_intros intross'' thy''
+ val _ = print_step options
+ ("Compiling functions (" ^ commas funnames ^ ") to predicates...")
+ val (fun_pred_specs, thy') =
+ if not (null funnames) then Predicate_Compile_Fun.define_predicates
+ (get_specs funnames) thy else ([], thy)
+ val _ = print_specs thy' fun_pred_specs
+ val specs = (get_specs prednames) @ fun_pred_specs
+ val (intross3, thy''') = process_specification options specs thy'
+ val _ = print_intross options thy''' "Introduction rules with new constants: " intross3
+ val intross4 = map_specs (maps remove_pointless_clauses) intross3
+ val _ = print_intross options thy''' "After removing pointless clauses: " intross4
+ (*val intross5 = map (fn s, ths) => ( s, map (AxClass.overload thy''') ths)) intross4*)
+ val intross6 = map_specs (map (expand_tuples thy''')) intross4
+ val _ = print_intross options thy''' "introduction rules before registering: " intross6
+ val _ = print_step options "Registering introduction rules..."
+ val thy'''' = fold Predicate_Compile_Core.register_intros intross6 thy'''
in
- thy'''
+ thy''''
end;
-fun preprocess const thy =
+fun preprocess options const thy =
let
- val _ = tracing ("Fetching definitions from theory...")
- val table = Pred_Compile_Data.make_const_spec_table thy
- val gr = Pred_Compile_Data.obtain_specification_graph table const
- val _ = tracing (commas (Graph.all_succs gr [const]))
+ val _ = print_step options "Fetching definitions from theory..."
+ val table = Predicate_Compile_Data.make_const_spec_table thy
+ val gr = Predicate_Compile_Data.obtain_specification_graph thy table const
val gr = Graph.subgraph (member (op =) (Graph.all_succs gr [const])) gr
- in fold_rev (preprocess_strong_conn_constnames gr)
+ in fold_rev (preprocess_strong_conn_constnames options gr)
(Graph.strong_conn gr) thy
end
-fun code_pred_cmd ((inductify_all, rpred), raw_const) lthy =
- if inductify_all then
- let
- val thy = ProofContext.theory_of lthy
- val const = Code.read_const thy raw_const
- val lthy' = LocalTheory.theory (preprocess const) lthy
- |> LocalTheory.checkpoint
- val _ = tracing "Starting Predicate Compile Core..."
- in Predicate_Compile_Core.code_pred_cmd rpred raw_const lthy' end
- else
- Predicate_Compile_Core.code_pred_cmd rpred raw_const lthy
+fun extract_options ((modes, raw_options), const) =
+ let
+ fun chk s = member (op =) raw_options s
+ in
+ Options {
+ expected_modes = Option.map (pair const) modes,
+ show_steps = chk "show_steps",
+ show_intermediate_results = chk "show_intermediate_results",
+ show_proof_trace = chk "show_proof_trace",
+ show_mode_inference = chk "show_mode_inference",
+ show_compilation = chk "show_compilation",
+ skip_proof = chk "skip_proof",
+ inductify = chk "inductify",
+ rpred = chk "rpred",
+ depth_limited = chk "depth_limited"
+ }
+ end
+
+fun code_pred_cmd ((modes, raw_options), raw_const) lthy =
+ let
+ val thy = ProofContext.theory_of lthy
+ val const = Code.read_const thy raw_const
+ val options = extract_options ((modes, raw_options), const)
+ in
+ if (is_inductify options) then
+ let
+ val lthy' = LocalTheory.theory (preprocess options const) lthy
+ |> LocalTheory.checkpoint
+ val const = case Predicate_Compile_Fun.pred_of_function (ProofContext.theory_of lthy') const of
+ SOME c => c
+ | NONE => const
+ val _ = print_step options "Starting Predicate Compile Core..."
+ in
+ Predicate_Compile_Core.code_pred options const lthy'
+ end
+ else
+ Predicate_Compile_Core.code_pred_cmd options raw_const lthy
+ end
val setup = Predicate_Compile_Fun.setup_oracle #> Predicate_Compile_Core.setup
-val _ = List.app OuterKeyword.keyword ["inductify_all", "rpred"]
+val bool_options = ["show_steps", "show_intermediate_results", "show_proof_trace",
+ "show_mode_inference", "show_compilation", "skip_proof", "inductify", "rpred", "depth_limited"]
local structure P = OuterParse
in
+val opt_modes =
+ Scan.optional (P.$$$ "(" |-- Args.$$$ "mode" |-- P.$$$ ":" |--
+ P.enum1 "," (P.$$$ "[" |-- P.enum "," P.nat --| P.$$$ "]")
+ --| P.$$$ ")" >> SOME) NONE
+
+val scan_params =
+ let
+ val scan_bool_param = foldl1 (op ||) (map Args.$$$ bool_options)
+ in
+ Scan.optional (P.$$$ "[" |-- P.enum1 "," scan_bool_param --| P.$$$ "]") []
+ end
+
val _ = OuterSyntax.local_theory_to_proof "code_pred"
"prove equations for predicate specified by intro/elim rules"
- OuterKeyword.thy_goal (P.opt_keyword "inductify_all" -- P.opt_keyword "rpred" -- P.term_group >> code_pred_cmd)
+ OuterKeyword.thy_goal (opt_modes -- scan_params -- P.term_group >>
+ code_pred_cmd)
end
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Tue Oct 27 14:46:03 2009 +0000
@@ -7,26 +7,25 @@
signature PREDICATE_COMPILE_CORE =
sig
val setup: theory -> theory
- val code_pred: bool -> string -> Proof.context -> Proof.state
- val code_pred_cmd: bool -> string -> Proof.context -> Proof.state
+ val code_pred: Predicate_Compile_Aux.options -> string -> Proof.context -> Proof.state
+ val code_pred_cmd: Predicate_Compile_Aux.options -> string -> Proof.context -> Proof.state
type smode = (int * int list option) list
type mode = smode option list * smode
datatype tmode = Mode of mode * smode * tmode option list;
- (*val add_equations_of: bool -> string list -> theory -> theory *)
- val register_predicate : (thm list * thm * int) -> theory -> theory
- val register_intros : thm list -> theory -> theory
+ val register_predicate : (string * thm list * thm * int) -> theory -> theory
+ val register_intros : string * thm list -> theory -> theory
val is_registered : theory -> string -> bool
- (* val fetch_pred_data : theory -> string -> (thm list * thm * int) *)
val predfun_intro_of: theory -> string -> mode -> thm
val predfun_elim_of: theory -> string -> mode -> thm
- val strip_intro_concl: int -> term -> term * (term list * term list)
val predfun_name_of: theory -> string -> mode -> string
val all_preds_of : theory -> string list
val modes_of: theory -> string -> mode list
- val sizelim_modes_of: theory -> string -> mode list
- val sizelim_function_name_of : theory -> string -> mode -> string
+ val depth_limited_modes_of: theory -> string -> mode list
+ val depth_limited_function_name_of : theory -> string -> mode -> string
val generator_modes_of: theory -> string -> mode list
val generator_name_of : theory -> string -> mode -> string
+ val all_modes_of : theory -> (string * mode list) list
+ val all_generator_modes_of : theory -> (string * mode list) list
val string_of_mode : mode -> string
val intros_of: theory -> string -> thm list
val nparams_of: theory -> string -> int
@@ -35,24 +34,12 @@
val set_nparams : string -> int -> theory -> theory
val print_stored_rules: theory -> unit
val print_all_modes: theory -> unit
- val do_proofs: bool Unsynchronized.ref
- val mk_casesrule : Proof.context -> int -> thm list -> term
- val analyze_compr: theory -> term -> term
- val eval_ref: (unit -> term Predicate.pred) option Unsynchronized.ref
- val add_equations : string list -> theory -> theory
+ val mk_casesrule : Proof.context -> term -> int -> thm list -> term
+ val eval_ref : (unit -> term Predicate.pred) option Unsynchronized.ref
+ val random_eval_ref : (unit -> int * int -> term Predicate.pred * (int * int)) option Unsynchronized.ref
val code_pred_intros_attrib : attribute
(* used by Quickcheck_Generator *)
- (*val funT_of : mode -> typ -> typ
- val mk_if_pred : term -> term
- val mk_Eval : term * term -> term*)
- val mk_tupleT : typ list -> typ
-(* val mk_predT : typ -> typ *)
(* temporary for testing of the compilation *)
- datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
- GeneratorPrem of term list * term | Generator of (string * typ);
- (* val prepare_intrs: theory -> string list ->
- (string * typ) list * int * string list * string list * (string * mode list) list *
- (string * (term list * indprem list) list) list * (string * (int option list * int)) list*)
datatype compilation_funs = CompilationFuns of {
mk_predT : typ -> typ,
dest_predT : typ -> typ,
@@ -64,66 +51,39 @@
mk_not : term -> term,
mk_map : typ -> typ -> term -> term -> term,
lift_pred : term -> term
- };
- type moded_clause = term list * (indprem * tmode) list
- type 'a pred_mode_table = (string * (mode * 'a) list) list
- val infer_modes : theory -> (string * mode list) list
- -> (string * mode list) list
- -> string list
- -> (string * (term list * indprem list) list) list
- -> (moded_clause list) pred_mode_table
- val infer_modes_with_generator : theory -> (string * mode list) list
- -> (string * mode list) list
- -> string list
- -> (string * (term list * indprem list) list) list
- -> (moded_clause list) pred_mode_table
- (*val compile_preds : theory -> compilation_funs -> string list -> string list
- -> (string * typ) list -> (moded_clause list) pred_mode_table -> term pred_mode_table
- val rpred_create_definitions :(string * typ) list -> string * mode list
- -> theory -> theory
- val split_smode : int list -> term list -> (term list * term list) *)
- val print_moded_clauses :
- theory -> (moded_clause list) pred_mode_table -> unit
- val print_compiled_terms : theory -> term pred_mode_table -> unit
- (*val rpred_prove_preds : theory -> term pred_mode_table -> thm pred_mode_table*)
+ };
val pred_compfuns : compilation_funs
val rpred_compfuns : compilation_funs
- val dest_funT : typ -> typ * typ
- (* val depending_preds_of : theory -> thm list -> string list *)
- val add_quickcheck_equations : string list -> theory -> theory
- val add_sizelim_equations : string list -> theory -> theory
- val is_inductive_predicate : theory -> string -> bool
- val terms_vs : term list -> string list
- val subsets : int -> int -> int list list
- val check_mode_clause : bool -> theory -> string list ->
- (string * mode list) list -> (string * mode list) list -> mode -> (term list * indprem list)
- -> (term list * (indprem * tmode) list) option
- val string_of_moded_prem : theory -> (indprem * tmode) -> string
- val all_modes_of : theory -> (string * mode list) list
- val all_generator_modes_of : theory -> (string * mode list) list
- val compile_clause : compilation_funs -> term option -> (term list -> term) ->
- theory -> string list -> string list -> mode -> term -> moded_clause -> term
- val preprocess_intro : theory -> thm -> thm
- val is_constrt : theory -> term -> bool
- val is_predT : typ -> bool
- val guess_nparams : typ -> int
- val cprods_subset : 'a list list -> 'a list list
+ (* val add_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
+ val add_quickcheck_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
+ val add_depth_limited_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
+ *)
end;
structure Predicate_Compile_Core : PREDICATE_COMPILE_CORE =
struct
open Predicate_Compile_Aux;
+
(** auxiliary **)
(* debug stuff *)
-fun tracing s = (if ! Toplevel.debug then tracing s else ());
+fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
+
+fun print_tac s = Seq.single;
+
+fun print_tac' options s =
+ if show_proof_trace options then Tactical.print_tac s else Seq.single;
-fun print_tac s = Seq.single; (*Tactical.print_tac s;*) (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *)
-fun debug_tac msg = Seq.single; (* (fn st => (tracing msg; Seq.single st)); *)
+fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
-val do_proofs = Unsynchronized.ref true;
+datatype assertion = Max_number_of_subgoals of int
+fun assert_tac (Max_number_of_subgoals i) st =
+ if (nprems_of st <= i) then Seq.single st
+ else error ("assert_tac: Numbers of subgoals mismatch at goal state :"
+ ^ "\n" ^ Pretty.string_of (Pretty.chunks
+ (Goal_Display.pretty_goals_without_context (! Goal_Display.goals_limit) st)));
(* reference to preprocessing of InductiveSet package *)
@@ -139,20 +99,6 @@
HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
in mk_eqs x xs end;
-fun mk_tupleT [] = HOLogic.unitT
- | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
-
-fun dest_tupleT (Type (@{type_name Product_Type.unit}, [])) = []
- | dest_tupleT (Type (@{type_name "*"}, [T1, T2])) = T1 :: (dest_tupleT T2)
- | dest_tupleT t = [t]
-
-fun mk_tuple [] = HOLogic.unit
- | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
-
-fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
- | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
- | dest_tuple t = [t]
-
fun mk_scomp (t, u) =
let
val T = fastype_of t
@@ -189,6 +135,13 @@
(** data structures **)
+(* new datatype for modes: *)
+(*
+datatype instantiation = Input | Output
+type arg_mode = Tuple of instantiation list | Atom of instantiation | HigherOrderMode of mode
+type mode = arg_mode list
+type tmode = Mode of mode *
+*)
type smode = (int * int list option) list
type mode = smode option list * smode;
datatype tmode = Mode of mode * smode * tmode option list;
@@ -241,35 +194,8 @@
(if null param_modes then "" else
"; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes))
-(* generation of case rules from user-given introduction rules *)
-
-fun mk_casesrule ctxt nparams introrules =
- let
- val ((_, intros_th), ctxt1) = Variable.import false introrules ctxt
- val intros = map prop_of intros_th
- val (pred, (params, args)) = strip_intro_concl nparams (hd intros)
- val ([propname], ctxt2) = Variable.variant_fixes ["thesis"] ctxt1
- val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
- val (argnames, ctxt3) = Variable.variant_fixes
- (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt2
- val argvs = map2 (curry Free) argnames (map fastype_of args)
- fun mk_case intro =
- let
- val (_, (_, args)) = strip_intro_concl nparams intro
- val prems = Logic.strip_imp_prems intro
- val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args)
- val frees = (fold o fold_aterms)
- (fn t as Free _ =>
- if member (op aconv) params t then I else insert (op aconv) t
- | _ => I) (args @ prems) []
- in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
- val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
- val cases = map mk_case intros
- in Logic.list_implies (assm :: cases, prop) end;
-
-
-datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
- GeneratorPrem of term list * term | Generator of (string * typ);
+datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term
+ | Generator of (string * typ);
type moded_clause = term list * (indprem * tmode) list
type 'a pred_mode_table = (string * (mode * 'a) list) list
@@ -300,25 +226,25 @@
nparams : int,
functions : (mode * predfun_data) list,
generators : (mode * function_data) list,
- sizelim_functions : (mode * function_data) list
+ depth_limited_functions : (mode * function_data) list
};
fun rep_pred_data (PredData data) = data;
-fun mk_pred_data ((intros, elim, nparams), (functions, generators, sizelim_functions)) =
+fun mk_pred_data ((intros, elim, nparams), (functions, generators, depth_limited_functions)) =
PredData {intros = intros, elim = elim, nparams = nparams,
- functions = functions, generators = generators, sizelim_functions = sizelim_functions}
-fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, sizelim_functions}) =
- mk_pred_data (f ((intros, elim, nparams), (functions, generators, sizelim_functions)))
-
+ functions = functions, generators = generators, depth_limited_functions = depth_limited_functions}
+fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, depth_limited_functions}) =
+ mk_pred_data (f ((intros, elim, nparams), (functions, generators, depth_limited_functions)))
+
fun eq_option eq (NONE, NONE) = true
| eq_option eq (SOME x, SOME y) = eq (x, y)
| eq_option eq _ = false
-
+
fun eq_pred_data (PredData d1, PredData d2) =
eq_list (Thm.eq_thm) (#intros d1, #intros d2) andalso
eq_option (Thm.eq_thm) (#elim d1, #elim d2) andalso
#nparams d1 = #nparams d2
-
+
structure PredData = TheoryDataFun
(
type T = pred_data Graph.T;
@@ -353,7 +279,7 @@
val modes_of = (map fst) o #functions oo the_pred_data
-val sizelim_modes_of = (map fst) o #sizelim_functions oo the_pred_data
+val depth_limited_modes_of = (map fst) o #depth_limited_functions oo the_pred_data
val rpred_modes_of = (map fst) o #generators oo the_pred_data
@@ -380,7 +306,7 @@
fun lookup_generator_data thy name mode =
Option.map rep_function_data (AList.lookup (op =)
(#generators (the_pred_data thy name)) mode)
-
+
fun the_generator_data thy name mode = case lookup_generator_data thy name mode
of NONE => error ("No generator defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
| SOME data => data
@@ -392,24 +318,25 @@
fun all_generator_modes_of thy =
map (fn name => (name, generator_modes_of thy name)) (all_preds_of thy)
-fun lookup_sizelim_function_data thy name mode =
+fun lookup_depth_limited_function_data thy name mode =
Option.map rep_function_data (AList.lookup (op =)
- (#sizelim_functions (the_pred_data thy name)) mode)
+ (#depth_limited_functions (the_pred_data thy name)) mode)
-fun the_sizelim_function_data thy name mode = case lookup_sizelim_function_data thy name mode
- of NONE => error ("No size-limited function defined for mode " ^ string_of_mode mode
+fun the_depth_limited_function_data thy name mode = case lookup_depth_limited_function_data thy name mode
+ of NONE => error ("No depth-limited function defined for mode " ^ string_of_mode mode
^ " of predicate " ^ name)
| SOME data => data
-val sizelim_function_name_of = #name ooo the_sizelim_function_data
+val depth_limited_function_name_of = #name ooo the_depth_limited_function_data
(*val generator_modes_of = (map fst) o #generators oo the_pred_data*)
-
+
(* diagnostic display functions *)
-fun print_modes modes = tracing ("Inferred modes:\n" ^
- cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
- string_of_mode ms)) modes));
+fun print_modes modes =
+ Output.tracing ("Inferred modes:\n" ^
+ cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
+ string_of_mode ms)) modes));
fun print_pred_mode_table string_of_entry thy pred_mode_table =
let
@@ -417,15 +344,20 @@
^ (string_of_entry pred mode entry)
fun print_pred (pred, modes) =
"predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
- val _ = tracing (cat_lines (map print_pred pred_mode_table))
+ val _ = Output.tracing (cat_lines (map print_pred pred_mode_table))
in () end;
+fun string_of_prem thy (Prem (ts, p)) =
+ (Syntax.string_of_term_global thy (list_comb (p, ts))) ^ "(premise)"
+ | string_of_prem thy (Negprem (ts, p)) =
+ (Syntax.string_of_term_global thy (HOLogic.mk_not (list_comb (p, ts)))) ^ "(negative premise)"
+ | string_of_prem thy (Sidecond t) =
+ (Syntax.string_of_term_global thy t) ^ "(sidecondition)"
+ | string_of_prem thy _ = error "string_of_prem: unexpected input"
+
fun string_of_moded_prem thy (Prem (ts, p), tmode) =
(Syntax.string_of_term_global thy (list_comb (p, ts))) ^
"(" ^ (string_of_tmode tmode) ^ ")"
- | string_of_moded_prem thy (GeneratorPrem (ts, p), Mode (predmode, is, _)) =
- (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
- "(generator_mode: " ^ (string_of_mode predmode) ^ ")"
| string_of_moded_prem thy (Generator (v, T), _) =
"Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T)
| string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) =
@@ -435,18 +367,25 @@
(Syntax.string_of_term_global thy t) ^
"(sidecond mode: " ^ string_of_smode is ^ ")"
| string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented"
-
+
fun print_moded_clauses thy =
- let
+ let
fun string_of_clause pred mode clauses =
cat_lines (map (fn (ts, prems) => (space_implode " --> "
(map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " "
^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses)
in print_pred_mode_table string_of_clause thy end;
-fun print_compiled_terms thy =
- print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy
-
+fun string_of_clause thy pred (ts, prems) =
+ (space_implode " --> "
+ (map (string_of_prem thy) prems)) ^ " --> " ^ pred ^ " "
+ ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))
+
+fun print_compiled_terms options thy =
+ if show_compilation options then
+ print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy
+ else K ()
+
fun print_stored_rules thy =
let
val preds = (Graph.keys o PredData.get) thy
@@ -477,7 +416,105 @@
in
fold print (all_modes_of thy) ()
end
-
+
+(* validity checks *)
+
+fun check_expected_modes (options : Predicate_Compile_Aux.options) modes =
+ case expected_modes options of
+ SOME (s, ms) => (case AList.lookup (op =) modes s of
+ SOME modes =>
+ if not (eq_set (op =) (map (map (rpair NONE)) ms, map snd modes)) then
+ error ("expected modes were not inferred:\n"
+ ^ "inferred modes for " ^ s ^ ": "
+ ^ commas (map ((enclose "[" "]") o string_of_smode o snd) modes))
+ else ()
+ | NONE => ())
+ | NONE => ()
+
+(* importing introduction rules *)
+
+fun unify_consts thy cs intr_ts =
+ (let
+ val add_term_consts_2 = fold_aterms (fn Const c => insert (op =) c | _ => I);
+ fun varify (t, (i, ts)) =
+ let val t' = map_types (Logic.incr_tvar (i + 1)) (#2 (Type.varify [] t))
+ in (maxidx_of_term t', t'::ts) end;
+ val (i, cs') = List.foldr varify (~1, []) cs;
+ val (i', intr_ts') = List.foldr varify (i, []) intr_ts;
+ val rec_consts = fold add_term_consts_2 cs' [];
+ val intr_consts = fold add_term_consts_2 intr_ts' [];
+ fun unify (cname, cT) =
+ let val consts = map snd (List.filter (fn c => fst c = cname) intr_consts)
+ in fold (Sign.typ_unify thy) ((replicate (length consts) cT) ~~ consts) end;
+ val (env, _) = fold unify rec_consts (Vartab.empty, i');
+ val subst = map_types (Envir.norm_type env)
+ in (map subst cs', map subst intr_ts')
+ end) handle Type.TUNIFY =>
+ (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts));
+
+fun import_intros inp_pred nparams [] ctxt =
+ let
+ val ([outp_pred], ctxt') = Variable.import_terms false [inp_pred] ctxt
+ val (paramTs, _) = chop nparams (binder_types (fastype_of outp_pred))
+ val (param_names, ctxt'') = Variable.variant_fixes (map (fn i => "p" ^ (string_of_int i))
+ (1 upto nparams)) ctxt'
+ val params = map Free (param_names ~~ paramTs)
+ in (((outp_pred, params), []), ctxt') end
+ | import_intros inp_pred nparams (th :: ths) ctxt =
+ let
+ val ((_, [th']), ctxt') = Variable.import false [th] ctxt
+ val thy = ProofContext.theory_of ctxt'
+ val (pred, (params, args)) = strip_intro_concl nparams (prop_of th')
+ val ho_args = filter (is_predT o fastype_of) args
+ fun subst_of (pred', pred) =
+ let
+ val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
+ in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
+ fun instantiate_typ th =
+ let
+ val (pred', _) = strip_intro_concl 0 (prop_of th)
+ val _ = if not (fst (dest_Const pred) = fst (dest_Const pred')) then
+ error "Trying to instantiate another predicate" else ()
+ in Thm.certify_instantiate (subst_of (pred', pred), []) th end;
+ fun instantiate_ho_args th =
+ let
+ val (_, (params', args')) = strip_intro_concl nparams (prop_of th)
+ val ho_args' = map dest_Var (filter (is_predT o fastype_of) args')
+ in Thm.certify_instantiate ([], map dest_Var params' ~~ params) th end
+ val outp_pred =
+ Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
+ val ((_, ths'), ctxt1) =
+ Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
+ in
+ (((outp_pred, params), th' :: ths'), ctxt1)
+ end
+
+(* generation of case rules from user-given introduction rules *)
+
+fun mk_casesrule ctxt pred nparams introrules =
+ let
+ val (((pred, params), intros_th), ctxt1) = import_intros pred nparams introrules ctxt
+ val intros = map prop_of intros_th
+ val ([propname], ctxt2) = Variable.variant_fixes ["thesis"] ctxt1
+ val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
+ val (_, argsT) = chop nparams (binder_types (fastype_of pred))
+ val (argnames, ctxt3) = Variable.variant_fixes
+ (map (fn i => "a" ^ string_of_int i) (1 upto length argsT)) ctxt2
+ val argvs = map2 (curry Free) argnames argsT
+ fun mk_case intro =
+ let
+ val (_, (_, args)) = strip_intro_concl nparams intro
+ val prems = Logic.strip_imp_prems intro
+ val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args)
+ val frees = (fold o fold_aterms)
+ (fn t as Free _ =>
+ if member (op aconv) params t then I else insert (op aconv) t
+ | _ => I) (args @ prems) []
+ in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
+ val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
+ val cases = map mk_case intros
+ in Logic.list_implies (assm :: cases, prop) end;
+
(** preprocessing rules **)
fun imp_prems_conv cv ct =
@@ -498,39 +535,30 @@
fun preprocess_elim thy nparams elimrule =
let
- val _ = tracing ("Preprocessing elimination rule "
- ^ (Display.string_of_thm_global thy elimrule))
fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) =
HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs)
| replace_eqs t = t
+ val ctxt = ProofContext.init thy
+ val ((_, [elimrule]), ctxt') = Variable.import false [elimrule] ctxt
val prems = Thm.prems_of elimrule
val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams
fun preprocess_case t =
- let
+ let
val params = Logic.strip_params t
val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t)
val assums_hyp' = assums1 @ (map replace_eqs assums2)
- in
+ in
list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t))
- end
+ end
val cases' = map preprocess_case (tl prems)
val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule)
- (*val _ = tracing ("elimrule': "^ (Syntax.string_of_term_global thy elimrule'))*)
val bigeq = (Thm.symmetric (Conv.implies_concl_conv
(MetaSimplifier.rewrite true [@{thm Predicate.eq_is_eq}])
(cterm_of thy elimrule')))
- (*
- val _ = tracing ("bigeq:" ^ (Display.string_of_thm_global thy bigeq))
- val res =
- Thm.equal_elim bigeq elimrule
- *)
- (*
- val t = (fn {...} => mycheat_tac thy 1)
- val eq = Goal.prove (ProofContext.init thy) [] [] (Logic.mk_equals ((Thm.prop_of elimrule), elimrule')) t
- *)
- val _ = tracing "Preprocessed elimination rule"
+ val tac = (fn _ => Skip_Proof.cheat_tac thy)
+ val eq = Goal.prove ctxt' [] [] (Logic.mk_equals ((Thm.prop_of elimrule), elimrule')) tac
in
- Thm.equal_elim bigeq elimrule
+ Thm.equal_elim eq elimrule |> singleton (Variable.export ctxt' ctxt)
end;
(* special case: predicate with no introduction rule *)
@@ -552,6 +580,8 @@
([intro], elim)
end
+fun expand_tuples_elim th = th
+
fun fetch_pred_data thy name =
case try (Inductive.the_inductive (ProofContext.init thy)) name of
SOME (info as (_, result)) =>
@@ -560,17 +590,23 @@
let
val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro))
in (fst (dest_Const const) = name) end;
- val intros = ind_set_codegen_preproc thy ((map (preprocess_intro thy))
- (filter is_intro_of (#intrs result)))
- val pre_elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info)))
+ val intros = ind_set_codegen_preproc thy
+ (map (expand_tuples thy #> preprocess_intro thy) (filter is_intro_of (#intrs result)))
+ val index = find_index (fn s => s = name) (#names (fst info))
+ val pre_elim = nth (#elims result) index
+ val pred = nth (#preds result) index
val nparams = length (Inductive.params_of (#raw_induct result))
- val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
- val (intros, elim) = if null intros then noclause thy name elim else (intros, elim)
+ (*val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams
+ (expand_tuples_elim pre_elim))*)
+ val elim =
+ (Drule.standard o Skip_Proof.make_thm thy)
+ (mk_casesrule (ProofContext.init thy) pred nparams intros)
+ val (intros, elim) = (*if null intros then noclause thy name elim else*) (intros, elim)
in
mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
end
| NONE => error ("No such predicate: " ^ quote name)
-
+
(* updaters *)
fun apfst3 f (x, y, z) = (f x, y, z)
@@ -605,6 +641,7 @@
(data, keys)
end;
*)
+
(* guessing number of parameters *)
fun find_indexes pred xs =
let
@@ -624,7 +661,7 @@
fun cons_intro gr =
case try (Graph.get_node gr) name of
SOME pred_data => Graph.map_node name (map_pred_data
- (apfst (fn (intro, elim, nparams) => (thm::intro, elim, nparams)))) gr
+ (apfst (fn (intros, elim, nparams) => (thm::intros, elim, nparams)))) gr
| NONE =>
let
val nparams = the_default (guess_nparams T) (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name)
@@ -640,30 +677,34 @@
fun set_nparams name nparams = let
fun set (intros, elim, _ ) = (intros, elim, nparams)
in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
-
-fun register_predicate (pre_intros, pre_elim, nparams) thy =
+
+fun register_predicate (constname, pre_intros, pre_elim, nparams) thy =
let
- val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd pre_intros))))
(* preprocessing *)
val intros = ind_set_codegen_preproc thy (map (preprocess_intro thy) pre_intros)
val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
in
- if not (member (op =) (Graph.keys (PredData.get thy)) name) then
+ if not (member (op =) (Graph.keys (PredData.get thy)) constname) then
PredData.map
- (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy
+ (Graph.new_node (constname, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy
else thy
end
-fun register_intros pre_intros thy =
+fun register_intros (constname, pre_intros) thy =
let
- val (c, T) = dest_Const (fst (strip_intro_concl 0 (prop_of (hd pre_intros))))
- val _ = tracing ("Registering introduction rules of " ^ c)
- val _ = tracing (commas (map (Display.string_of_thm_global thy) pre_intros))
+ val T = Sign.the_const_type thy constname
+ fun constname_of_intro intr = fst (dest_Const (fst (strip_intro_concl 0 (prop_of intr))))
+ val _ = if not (forall (fn intr => constname_of_intro intr = constname) pre_intros) then
+ error ("register_intros: Introduction rules of different constants are used\n" ^
+ "expected rules for " ^ constname ^ ", but received rules for " ^
+ commas (map constname_of_intro pre_intros))
+ else ()
+ val pred = Const (constname, T)
val nparams = guess_nparams T
val pre_elim =
(Drule.standard o Skip_Proof.make_thm thy)
- (mk_casesrule (ProofContext.init thy) nparams pre_intros)
- in register_predicate (pre_intros, pre_elim, nparams) thy end
+ (mk_casesrule (ProofContext.init thy) pred nparams pre_intros)
+ in register_predicate (constname, pre_intros, pre_elim, nparams) thy end
fun set_generator_name pred mode name =
let
@@ -672,7 +713,7 @@
PredData.map (Graph.map_node pred (map_pred_data set))
end
-fun set_sizelim_function_name pred mode name =
+fun set_depth_limited_function_name pred mode name =
let
val set = (apsnd o aptrd3 o cons) (mode, mk_function_data (name, NONE))
in
@@ -694,8 +735,6 @@
mk_sup : term * term -> term,
mk_if : term -> term,
mk_not : term -> term,
-(* funT_of : mode -> typ -> typ, *)
-(* mk_fun_of : theory -> (string * typ) -> mode -> term, *)
mk_map : typ -> typ -> term -> term -> term,
lift_pred : term -> term
};
@@ -708,8 +747,6 @@
fun mk_sup (CompilationFuns funs) = #mk_sup funs
fun mk_if (CompilationFuns funs) = #mk_if funs
fun mk_not (CompilationFuns funs) = #mk_not funs
-(*fun funT_of (CompilationFuns funs) = #funT_of funs*)
-(*fun mk_fun_of (CompilationFuns funs) = #mk_fun_of funs*)
fun mk_map (CompilationFuns funs) = #mk_map funs
fun lift_pred (CompilationFuns funs) = #lift_pred funs
@@ -719,7 +756,7 @@
val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs
in
- (paramTs' @ inargTs) ---> (mk_predT compfuns (mk_tupleT outargTs))
+ (paramTs' @ inargTs) ---> (mk_predT compfuns (HOLogic.mk_tupleT outargTs))
end;
fun mk_fun_of compfuns thy (name, T) mode =
@@ -809,9 +846,11 @@
fun mk_if cond = Const (@{const_name RPred.if_rpred},
HOLogic.boolT --> mk_rpredT HOLogic.unitT) $ cond;
-fun mk_not t = error "Negation is not defined for RPred"
+fun mk_not t = let val T = mk_rpredT HOLogic.unitT
+ in Const (@{const_name RPred.not_rpred}, T --> T) $ t end
-fun mk_map t = error "FIXME" (*FIXME*)
+fun mk_map T1 T2 tf tp = Const (@{const_name RPred.map},
+ (T1 --> T2) --> mk_rpredT T1 --> mk_rpredT T2) $ tf $ tp
fun lift_pred t =
let
@@ -839,20 +878,21 @@
RPredCompFuns.mk_rpredT T) $ random
end;
-fun sizelim_funT_of compfuns (iss, is) T =
+fun depth_limited_funT_of compfuns (iss, is) T =
let
val Ts = binder_types T
val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
- val paramTs' = map2 (fn SOME is => sizelim_funT_of PredicateCompFuns.compfuns ([], is) | NONE => I) iss paramTs
+ val paramTs' = map2 (fn SOME is => depth_limited_funT_of compfuns ([], is) | NONE => I) iss paramTs
in
- (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT compfuns (mk_tupleT outargTs))
+ (paramTs' @ inargTs @ [@{typ bool}, @{typ "code_numeral"}])
+ ---> (mk_predT compfuns (HOLogic.mk_tupleT outargTs))
end;
-fun mk_sizelim_fun_of compfuns thy (name, T) mode =
- Const (sizelim_function_name_of thy name mode, sizelim_funT_of compfuns mode T)
+fun mk_depth_limited_fun_of compfuns thy (name, T) mode =
+ Const (depth_limited_function_name_of thy name mode, depth_limited_funT_of compfuns mode T)
fun mk_generator_of compfuns thy (name, T) mode =
- Const (generator_name_of thy name mode, sizelim_funT_of compfuns mode T)
+ Const (generator_name_of thy name mode, depth_limited_funT_of compfuns mode T)
(* Mode analysis *)
@@ -882,16 +922,16 @@
fun term_vTs tm =
fold_aterms (fn Free xT => cons xT | _ => I) tm [];
-(*FIXME this function should not be named merge... make it local instead*)
-fun merge xs [] = xs
- | merge [] ys = ys
- | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
- else y::merge (x::xs) ys;
-
-fun subsets i j = if i <= j then
- let val is = subsets (i+1) j
- in merge (map (fn ks => i::ks) is) is end
- else [[]];
+fun subsets i j =
+ if i <= j then
+ let
+ fun merge xs [] = xs
+ | merge [] ys = ys
+ | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
+ else y::merge (x::xs) ys;
+ val is = subsets (i+1) j
+ in merge (map (fn ks => i::ks) is) is end
+ else [[]];
(* FIXME: should be in library - cprod = map_prod I *)
fun cprod ([], ys) = []
@@ -905,46 +945,9 @@
val yss = (cprods_subset xss)
in maps (fn ys => map (fn x => cons x ys) xs) yss @ yss end
-(*TODO: cleanup function and put together with modes_of_term *)
-(*
-fun modes_of_param default modes t = let
- val (vs, t') = strip_abs t
- val b = length vs
- fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
- let
- val (args1, args2) =
- if length args < length iss then
- error ("Too few arguments for inductive predicate " ^ name)
- else chop (length iss) args;
- val k = length args2;
- val perm = map (fn i => (find_index_eq (Bound (b - i)) args2) + 1)
- (1 upto b)
- val partial_mode = (1 upto k) \\ perm
- in
- if not (partial_mode subset is) then [] else
- let
- val is' =
- (fold_index (fn (i, j) => if j mem is then cons (i + 1) else I) perm [])
- |> fold (fn i => if i > k then cons (i - k + b) else I) is
-
- val res = map (fn x => Mode (m, is', x)) (cprods (map
- (fn (NONE, _) => [NONE]
- | (SOME js, arg) => map SOME (filter
- (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
- (iss ~~ args1)))
- in res end
- end)) (AList.lookup op = modes name)
- in case strip_comb t' of
- (Const (name, _), args) => the_default default (mk_modes name args)
- | (Var ((name, _), _), args) => the (mk_modes name args)
- | (Free (name, _), args) => the (mk_modes name args)
- | _ => default end
-
-and
-*)
fun modes_of_term modes t =
let
- val ks = map_index (fn (i, T) => (i, NONE)) (binder_types (fastype_of t));
+ val ks = map_index (fn (i, T) => (i + 1, NONE)) (binder_types (fastype_of t));
val default = [Mode (([], ks), ks, [])];
fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
let
@@ -956,7 +959,7 @@
val prfx = map (rpair NONE) (1 upto k)
in
if not (is_prefix op = prfx is) then [] else
- let val is' = List.drop (is, k)
+ let val is' = map (fn (i, t) => (i - k, t)) (List.drop (is, k))
in map (fn x => Mode (m, is', x)) (cprods (map
(fn (NONE, _) => [NONE]
| (SOME js, arg) => map SOME (filter
@@ -992,7 +995,7 @@
(modes_of_term modes t handle Option =>
error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
| Negprem (us, t) => find_first (fn Mode (_, is, _) =>
- length us = length is andalso
+ is = map (rpair NONE) (1 upto length us) andalso
subset (op =) (terms_vs us, vs) andalso
subset (op =) (term_vs t, vs))
(modes_of_term modes t handle Option =>
@@ -1015,24 +1018,8 @@
(Generator (v, T), Mode (([], []), [], []))
end;
-fun gen_prem (Prem (us, t)) = GeneratorPrem (us, t)
- | gen_prem (Negprem (us, t)) = error "it is a negated prem"
- | gen_prem (Sidecond t) = error "it is a sidecond"
- | gen_prem _ = error "gen_prem : invalid input for gen_prem"
-
-fun param_gen_prem param_vs (p as Prem (us, t as Free (v, _))) =
- if member (op =) param_vs v then
- GeneratorPrem (us, t)
- else p
- | param_gen_prem param_vs p = p
-
fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) =
let
- (*
- val _ = tracing ("param_vs:" ^ commas param_vs)
- val _ = tracing ("iss:" ^
- commas (map (fn is => case is of SOME is => string_of_smode is | NONE => "NONE") iss))
- *)
val modes' = modes @ map_filter
(fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
(param_vs ~~ iss);
@@ -1046,7 +1033,7 @@
NONE =>
(if with_generator then
(case select_mode_prem thy gen_modes' vs ps of
- SOME (p as Prem _, SOME mode) => check_mode_prems ((gen_prem p, mode) :: acc_ps)
+ SOME (p as Prem _, SOME mode) => check_mode_prems ((p, mode) :: acc_ps)
(case p of Prem (us, _) => union (op =) vs (terms_vs us) | _ => vs)
(filter_out (equal p) ps)
| _ =>
@@ -1057,14 +1044,11 @@
(select_mode_prem thy modes' (union (op =) vs generator_vs) ps)) all_generator_vs) of
SOME generator_vs => check_mode_prems ((map (generator vTs) generator_vs) @ acc_ps)
(union (op =) vs generator_vs) ps
- | NONE => let
- val _ = tracing ("ps:" ^ (commas
- (map (fn p => string_of_moded_prem thy (p, Mode (([], []), [], []))) ps)))
- in (*error "mode analysis failed"*)NONE end
+ | NONE => NONE
end)
else
NONE)
- | SOME (p, SOME mode) => check_mode_prems ((if with_generator then param_gen_prem param_vs p else p, mode) :: acc_ps)
+ | SOME (p, SOME mode) => check_mode_prems ((p, mode) :: acc_ps)
(case p of Prem (us, _) => union (op =) vs (terms_vs us) | _ => vs)
(filter_out (equal p) ps))
val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts));
@@ -1083,33 +1067,41 @@
else NONE
end;
-fun check_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
- let val SOME rs = AList.lookup (op =) clauses p
+fun print_failed_mode options thy modes p m rs i =
+ if show_mode_inference options then
+ let
+ val _ = Output.tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^
+ p ^ " violates mode " ^ string_of_mode m)
+ val _ = Output.tracing (string_of_clause thy p (nth rs i))
+ in () end
+ else ()
+
+fun check_modes_pred options with_generator thy param_vs clauses modes gen_modes (p, ms) =
+ let
+ val rs = case AList.lookup (op =) clauses p of SOME rs => rs | NONE => []
in (p, List.filter (fn m => case find_index
(is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of
~1 => true
- | i => (tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^
- p ^ " violates mode " ^ string_of_mode m);
- tracing (commas (map (Syntax.string_of_term_global thy) (fst (nth rs i)))); false)) ms)
+ | i => (print_failed_mode options thy modes p m rs i; false)) ms)
end;
fun get_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
let
- val SOME rs = AList.lookup (op =) clauses p
+ val rs = case AList.lookup (op =) clauses p of SOME rs => rs | NONE => []
in
(p, map (fn m =>
(m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms)
end;
-
+
fun fixp f (x : (string * mode list) list) =
let val y = f x
in if x = y then x else fixp f y end;
-fun infer_modes thy extra_modes all_modes param_vs clauses =
+fun infer_modes options thy extra_modes all_modes param_vs clauses =
let
val modes =
fixp (fn modes =>
- map (check_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes)
+ map (check_modes_pred options false thy param_vs clauses (modes @ extra_modes) []) modes)
all_modes
in
map (get_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes
@@ -1122,19 +1114,24 @@
| SOME vs' => (k, subtract (op =) vs' vs))
:: remove_from rem xs
-fun infer_modes_with_generator thy extra_modes all_modes param_vs clauses =
+fun infer_modes_with_generator options thy extra_modes all_modes param_vs clauses =
let
val prednames = map fst clauses
- val extra_modes = all_modes_of thy
+ val extra_modes' = all_modes_of thy
val gen_modes = all_generator_modes_of thy
|> filter_out (fn (name, _) => member (op =) prednames name)
- val starting_modes = remove_from extra_modes all_modes
+ val starting_modes = remove_from extra_modes' all_modes
+ fun eq_mode (m1, m2) = (m1 = m2)
val modes =
fixp (fn modes =>
- map (check_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes)
- starting_modes
+ map (check_modes_pred options true thy param_vs clauses extra_modes' (gen_modes @ modes)) modes)
+ starting_modes
in
- map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes
+ AList.join (op =)
+ (fn _ => fn ((mps1, mps2)) =>
+ merge (fn ((m1, _), (m2, _)) => eq_mode (m1, m2)) (mps1, mps2))
+ (infer_modes options thy extra_modes all_modes param_vs clauses,
+ map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes)
end;
(* term construction *)
@@ -1157,136 +1154,10 @@
in (t' $ u', nvs'') end
| distinct_v x nvs = (x, nvs);
-fun compile_match thy compfuns eqs eqs' out_ts success_t =
- let
- val eqs'' = maps mk_eq eqs @ eqs'
- val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
- val name = Name.variant names "x";
- val name' = Name.variant (name :: names) "y";
- val T = mk_tupleT (map fastype_of out_ts);
- val U = fastype_of success_t;
- val U' = dest_predT compfuns U;
- val v = Free (name, T);
- val v' = Free (name', T);
- in
- lambda v (fst (Datatype.make_case
- (ProofContext.init thy) DatatypeCase.Quiet [] v
- [(mk_tuple out_ts,
- if null eqs'' then success_t
- else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
- foldr1 HOLogic.mk_conj eqs'' $ success_t $
- mk_bot compfuns U'),
- (v', mk_bot compfuns U')]))
- end;
-
-(*FIXME function can be removed*)
-fun mk_funcomp f t =
- let
- val names = Term.add_free_names t [];
- val Ts = binder_types (fastype_of t);
- val vs = map Free
- (Name.variant_list names (replicate (length Ts) "x") ~~ Ts)
- in
- fold_rev lambda vs (f (list_comb (t, vs)))
- end;
-(*
-fun compile_param_ext thy compfuns modes (NONE, t) = t
- | compile_param_ext thy compfuns modes (m as SOME (Mode ((iss, is'), is, ms)), t) =
- let
- val (vs, u) = strip_abs t
- val (ivs, ovs) = split_mode is vs
- val (f, args) = strip_comb u
- val (params, args') = chop (length ms) args
- val (inargs, outargs) = split_mode is' args'
- val b = length vs
- val perm = map (fn i => (find_index_eq (Bound (b - i)) args') + 1) (1 upto b)
- val outp_perm =
- snd (split_mode is perm)
- |> map (fn i => i - length (filter (fn x => x < i) is'))
- val names = [] -- TODO
- val out_names = Name.variant_list names (replicate (length outargs) "x")
- val f' = case f of
- Const (name, T) =>
- if AList.defined op = modes name then
- mk_predfun_of thy compfuns (name, T) (iss, is')
- else error "compile param: Not an inductive predicate with correct mode"
- | Free (name, T) => Free (name, param_funT_of compfuns T (SOME is'))
- val outTs = dest_tupleT (dest_predT compfuns (body_type (fastype_of f')))
- val out_vs = map Free (out_names ~~ outTs)
- val params' = map (compile_param thy modes) (ms ~~ params)
- val f_app = list_comb (f', params' @ inargs)
- val single_t = (mk_single compfuns (mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm)))
- val match_t = compile_match thy compfuns [] [] out_vs single_t
- in list_abs (ivs,
- mk_bind compfuns (f_app, match_t))
- end
- | compile_param_ext _ _ _ _ = error "compile params"
-*)
-
-fun compile_param neg_in_sizelim size thy compfuns (NONE, t) = t
- | compile_param neg_in_sizelim size thy compfuns (m as SOME (Mode ((iss, is'), is, ms)), t) =
- let
- val (f, args) = strip_comb (Envir.eta_contract t)
- val (params, args') = chop (length ms) args
- val params' = map (compile_param neg_in_sizelim size thy compfuns) (ms ~~ params)
- val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
- val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
- val f' =
- case f of
- Const (name, T) =>
- mk_fun_of compfuns thy (name, T) (iss, is')
- | Free (name, T) =>
- case neg_in_sizelim of
- SOME _ => Free (name, sizelim_funT_of compfuns (iss, is') T)
- | NONE => Free (name, funT_of compfuns (iss, is') T)
-
- | _ => error ("PredicateCompiler: illegal parameter term")
- in
- (case neg_in_sizelim of SOME size_t =>
- (fn t =>
- let
- val Ts = fst (split_last (binder_types (fastype_of t)))
- val names = map (fn i => "x" ^ string_of_int i) (1 upto length Ts)
- in
- list_abs (names ~~ Ts, list_comb (t, (map Bound ((length Ts) - 1 downto 0)) @ [size_t]))
- end)
- | NONE => I)
- (list_comb (f', params' @ args'))
- end
-
-fun compile_expr neg_in_sizelim size thy ((Mode (mode, is, ms)), t) =
- case strip_comb t of
- (Const (name, T), params) =>
- let
- val params' = map (compile_param neg_in_sizelim size thy PredicateCompFuns.compfuns) (ms ~~ params)
- val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
- in
- list_comb (mk_fun_of PredicateCompFuns.compfuns thy (name, T) mode, params')
- end
- | (Free (name, T), args) =>
- let
- val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
- in
- list_comb (Free (name, funT_of PredicateCompFuns.compfuns ([], is) T), args)
- end;
-
-fun compile_gen_expr size thy compfuns ((Mode (mode, is, ms)), t) inargs =
- case strip_comb t of
- (Const (name, T), params) =>
- let
- val params' = map (compile_param NONE size thy PredicateCompFuns.compfuns) (ms ~~ params)
- in
- list_comb (mk_generator_of compfuns thy (name, T) mode, params' @ inargs)
- end
- | (Free (name, T), params) =>
- lift_pred compfuns
- (list_comb (Free (name, sizelim_funT_of PredicateCompFuns.compfuns ([], is) T), params @ inargs))
-
-
(** specific rpred functions -- move them to the correct place in this file *)
-fun mk_Eval_of size ((x, T), NONE) names = (x, names)
- | mk_Eval_of size ((x, T), SOME mode) names =
+fun mk_Eval_of additional_arguments ((x, T), NONE) names = (x, names)
+ | mk_Eval_of additional_arguments ((x, T), SOME mode) names =
let
val Ts = binder_types T
(*val argnames = Name.variant_list names
@@ -1331,32 +1202,99 @@
end
val (inoutargs, args) = split_list (map mk_arg (1 upto (length Ts) ~~ Ts))
val (inargs, outargs) = pairself flat (split_list inoutargs)
- val size_t = case size of NONE => [] | SOME size_t => [size_t]
- val r = PredicateCompFuns.mk_Eval (list_comb (x, inargs @ size_t), mk_tuple outargs)
+ val r = PredicateCompFuns.mk_Eval
+ (list_comb (x, inargs @ additional_arguments), HOLogic.mk_tuple outargs)
val t = fold_rev mk_split_lambda args r
in
(t, names)
end;
-fun compile_arg size thy param_vs iss arg =
+fun compile_arg compilation_modifiers compfuns additional_arguments thy param_vs iss arg =
let
- val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
fun map_params (t as Free (f, T)) =
if member (op =) param_vs f then
case (the (AList.lookup (op =) (param_vs ~~ iss) f)) of
- SOME is => let val T' = funT_of PredicateCompFuns.compfuns ([], is) T
- in fst (mk_Eval_of size ((Free (f, T'), T), SOME is) []) end
+ SOME is =>
+ let
+ val T' = #funT_of compilation_modifiers compfuns ([], is) T
+ in fst (mk_Eval_of additional_arguments ((Free (f, T'), T), SOME is) []) end
| NONE => t
else t
| map_params t = t
in map_aterms map_params arg end
-
-fun compile_clause compfuns size final_term thy all_vs param_vs (iss, is) inp (ts, moded_ps) =
+
+fun compile_match compilation_modifiers compfuns additional_arguments param_vs iss thy eqs eqs' out_ts success_t =
+ let
+ val eqs'' = maps mk_eq eqs @ eqs'
+ val eqs'' =
+ map (compile_arg compilation_modifiers compfuns additional_arguments thy param_vs iss) eqs''
+ val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
+ val name = Name.variant names "x";
+ val name' = Name.variant (name :: names) "y";
+ val T = HOLogic.mk_tupleT (map fastype_of out_ts);
+ val U = fastype_of success_t;
+ val U' = dest_predT compfuns U;
+ val v = Free (name, T);
+ val v' = Free (name', T);
+ in
+ lambda v (fst (Datatype.make_case
+ (ProofContext.init thy) DatatypeCase.Quiet [] v
+ [(HOLogic.mk_tuple out_ts,
+ if null eqs'' then success_t
+ else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
+ foldr1 HOLogic.mk_conj eqs'' $ success_t $
+ mk_bot compfuns U'),
+ (v', mk_bot compfuns U')]))
+ end;
+
+(*FIXME function can be removed*)
+fun mk_funcomp f t =
let
+ val names = Term.add_free_names t [];
+ val Ts = binder_types (fastype_of t);
+ val vs = map Free
+ (Name.variant_list names (replicate (length Ts) "x") ~~ Ts)
+ in
+ fold_rev lambda vs (f (list_comb (t, vs)))
+ end;
+
+fun compile_param compilation_modifiers compfuns thy (NONE, t) = t
+ | compile_param compilation_modifiers compfuns thy (m as SOME (Mode (mode, _, ms)), t) =
+ let
+ val (f, args) = strip_comb (Envir.eta_contract t)
+ val (params, args') = chop (length ms) args
+ val params' = map (compile_param compilation_modifiers compfuns thy) (ms ~~ params)
+ val f' =
+ case f of
+ Const (name, T) => Const (#const_name_of compilation_modifiers thy name mode,
+ #funT_of compilation_modifiers compfuns mode T)
+ | Free (name, T) => Free (name, #funT_of compilation_modifiers compfuns mode T)
+ | _ => error ("PredicateCompiler: illegal parameter term")
+ in
+ list_comb (f', params' @ args')
+ end
+
+fun compile_expr compilation_modifiers compfuns thy ((Mode (mode, _, ms)), t) inargs additional_arguments =
+ case strip_comb t of
+ (Const (name, T), params) =>
+ let
+ val params' = map (compile_param compilation_modifiers compfuns thy) (ms ~~ params)
+ (*val mk_fun_of = if depth_limited then mk_depth_limited_fun_of else mk_fun_of*)
+ val name' = #const_name_of compilation_modifiers thy name mode
+ val T' = #funT_of compilation_modifiers compfuns mode T
+ in
+ (list_comb (Const (name', T'), params' @ inargs @ additional_arguments))
+ end
+ | (Free (name, T), params) =>
+ list_comb (Free (name, #funT_of compilation_modifiers compfuns mode T), params @ inargs @ additional_arguments)
+
+fun compile_clause compilation_modifiers compfuns thy all_vs param_vs additional_arguments (iss, is) inp (ts, moded_ps) =
+ let
+ val compile_match = compile_match compilation_modifiers compfuns additional_arguments param_vs iss thy
fun check_constrt t (names, eqs) =
if is_constrt thy t then (t, (names, eqs)) else
let
- val s = Name.variant names "x";
+ val s = Name.variant names "x"
val v = Free (s, fastype_of t)
in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
@@ -1371,12 +1309,8 @@
val (out_ts''', (names'', constr_vs)) = fold_map distinct_v
out_ts'' (names', map (rpair []) vs);
in
- (* termify code:
- compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
- (mk_single compfuns (mk_tuple (map mk_valtermify_term out_ts)))
- *)
- compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
- (final_term out_ts)
+ compile_match constr_vs (eqs @ eqs') out_ts'''
+ (mk_single compfuns (HOLogic.mk_tuple out_ts))
end
| compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) =
let
@@ -1385,16 +1319,16 @@
fold_map check_constrt out_ts (names, [])
val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
out_ts' ((names', map (rpair []) vs))
+ val additional_arguments' =
+ #transform_additional_arguments compilation_modifiers p additional_arguments
val (compiled_clause, rest) = case p of
Prem (us, t) =>
let
val (in_ts, out_ts''') = split_smode is us;
- val in_ts = map (compile_arg size thy param_vs iss) in_ts
- val args = case size of
- NONE => in_ts
- | SOME size_t => in_ts @ [size_t]
- val u = lift_pred compfuns
- (list_comb (compile_expr NONE size thy (mode, t), args))
+ val in_ts = map (compile_arg compilation_modifiers compfuns additional_arguments
+ thy param_vs iss) in_ts
+ val u =
+ compile_expr compilation_modifiers compfuns thy (mode, t) in_ts additional_arguments'
val rest = compile_prems out_ts''' vs' names'' ps
in
(u, rest)
@@ -1402,38 +1336,32 @@
| Negprem (us, t) =>
let
val (in_ts, out_ts''') = split_smode is us
- val u = lift_pred compfuns
- (mk_not PredicateCompFuns.compfuns (list_comb (compile_expr size NONE thy (mode, t), in_ts)))
+ val in_ts = map (compile_arg compilation_modifiers compfuns additional_arguments
+ thy param_vs iss) in_ts
+ val u = mk_not compfuns
+ (compile_expr compilation_modifiers compfuns thy (mode, t) in_ts additional_arguments')
val rest = compile_prems out_ts''' vs' names'' ps
in
(u, rest)
end
| Sidecond t =>
let
+ val t = compile_arg compilation_modifiers compfuns additional_arguments
+ thy param_vs iss t
val rest = compile_prems [] vs' names'' ps;
in
(mk_if compfuns t, rest)
end
- | GeneratorPrem (us, t) =>
- let
- val (in_ts, out_ts''') = split_smode is us;
- val args = case size of
- NONE => in_ts
- | SOME size_t => in_ts @ [size_t]
- val u = compile_gen_expr size thy compfuns (mode, t) args
- val rest = compile_prems out_ts''' vs' names'' ps
- in
- (u, rest)
- end
| Generator (v, T) =>
let
- val u = lift_random (HOLogic.mk_random T (the size))
+ val [size] = additional_arguments
+ val u = lift_random (HOLogic.mk_random T size)
val rest = compile_prems [Free (v, T)] vs' names'' ps;
in
(u, rest)
end
in
- compile_match thy compfuns constr_vs' eqs out_ts''
+ compile_match constr_vs' eqs out_ts''
(mk_bind compfuns (compiled_clause, rest))
end
val prem_t = compile_prems in_ts' param_vs all_vs' moded_ps;
@@ -1441,14 +1369,13 @@
mk_bind compfuns (mk_single compfuns inp, prem_t)
end
-fun compile_pred compfuns mk_fun_of use_size thy all_vs param_vs s T mode moded_cls =
+fun compile_pred compilation_modifiers compfuns thy all_vs param_vs s T mode moded_cls =
let
val (Ts1, Ts2) = chop (length (fst mode)) (binder_types T)
val (Us1, Us2) = split_smodeT (snd mode) Ts2
- val funT_of = if use_size then sizelim_funT_of else funT_of
- val Ts1' = map2 (fn NONE => I | SOME is => funT_of PredicateCompFuns.compfuns ([], is)) (fst mode) Ts1
- val size_name = Name.variant (all_vs @ param_vs) "size"
- fun mk_input_term (i, NONE) =
+ val Ts1' =
+ map2 (fn NONE => I | SOME is => #funT_of compilation_modifiers compfuns ([], is)) (fst mode) Ts1
+ fun mk_input_term (i, NONE) =
[Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
| mk_input_term (i, SOME pis) = case HOLogic.strip_tupleT (nth Ts2 (i - 1)) of
[] => error "strange unit input"
@@ -1461,30 +1388,22 @@
else [HOLogic.mk_tuple (map Free (vnames ~~ map (fn j => nth Ts (j - 1)) pis))] end
val in_ts = maps mk_input_term (snd mode)
val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1'
- val size = Free (size_name, @{typ "code_numeral"})
- val decr_size =
- if use_size then
- SOME (Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"})
- $ size $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"}))
- else
- NONE
+ val additional_arguments = #additional_arguments compilation_modifiers (all_vs @ param_vs)
val cl_ts =
- map (compile_clause compfuns decr_size (fn out_ts => mk_single compfuns (mk_tuple out_ts))
- thy all_vs param_vs mode (mk_tuple in_ts)) moded_cls;
- val t = foldr1 (mk_sup compfuns) cl_ts
- val T' = mk_predT compfuns (mk_tupleT Us2)
- val size_t = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
- $ HOLogic.mk_eq (size, @{term "0 :: code_numeral"})
- $ mk_bot compfuns (dest_predT compfuns T') $ t
- val fun_const = mk_fun_of compfuns thy (s, T) mode
- val eq = if use_size then
- (list_comb (fun_const, params @ in_ts @ [size]), size_t)
- else
- (list_comb (fun_const, params @ in_ts), t)
+ map (compile_clause compilation_modifiers compfuns
+ thy all_vs param_vs additional_arguments mode (HOLogic.mk_tuple in_ts)) moded_cls;
+ val compilation = #wrap_compilation compilation_modifiers compfuns s T mode additional_arguments
+ (if null cl_ts then
+ mk_bot compfuns (HOLogic.mk_tupleT Us2)
+ else foldr1 (mk_sup compfuns) cl_ts)
+ val fun_const =
+ Const (#const_name_of compilation_modifiers thy s mode,
+ #funT_of compilation_modifiers compfuns mode T)
in
- HOLogic.mk_Trueprop (HOLogic.mk_eq eq)
+ HOLogic.mk_Trueprop
+ (HOLogic.mk_eq (list_comb (fun_const, params @ in_ts @ additional_arguments), compilation))
end;
-
+
(* special setup for simpset *)
val HOL_basic_ss' = HOL_basic_ss addsimps (@{thms "HOL.simp_thms"} @ [@{thm Pair_eq}])
setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
@@ -1531,15 +1450,15 @@
val param_names' = Name.variant_list (param_names @ argnames)
(map (fn i => "p" ^ string_of_int i) (1 upto (length iss)))
val param_vs = map Free (param_names' ~~ Ts1)
- val (params', names) = fold_map (mk_Eval_of NONE) ((params ~~ Ts1) ~~ iss) []
+ val (params', names) = fold_map (mk_Eval_of []) ((params ~~ Ts1) ~~ iss) []
val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ args))
val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ args))
val param_eqs = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (param_vs ~~ params')
val funargs = params @ inargs
val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
- if null outargs then Free("y", HOLogic.unitT) else mk_tuple outargs))
+ if null outargs then Free("y", HOLogic.unitT) else HOLogic.mk_tuple outargs))
val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
- mk_tuple outargs))
+ HOLogic.mk_tuple outargs))
val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
val simprules = [defthm, @{thm eval_pred},
@{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
@@ -1601,7 +1520,7 @@
val (Ts1, Ts2) = chop (length iss) Ts
val (Us1, Us2) = split_smodeT is Ts2
val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1
- val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (mk_tupleT Us2))
+ val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (HOLogic.mk_tupleT Us2))
val names = Name.variant_list []
(map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
(* old *)
@@ -1634,7 +1553,7 @@
val (xinoutargs, names) = fold_map mk_vars ((1 upto (length Ts2)) ~~ Ts2) param_names
val (xinout, xargs) = split_list xinoutargs
val (xins, xouts) = pairself flat (split_list xinout)
- val (xparams', names') = fold_map (mk_Eval_of NONE) ((xparams ~~ Ts1) ~~ iss) names
+ val (xparams', names') = fold_map (mk_Eval_of []) ((xparams ~~ Ts1) ~~ iss) names
fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t
| mk_split_lambda [x] t = lambda x t
| mk_split_lambda xs t =
@@ -1663,16 +1582,16 @@
fold create_definition modes thy
end;
-fun sizelim_create_definitions preds (name, modes) thy =
+fun create_definitions_of_depth_limited_functions preds (name, modes) thy =
let
val T = AList.lookup (op =) preds name |> the
fun create_definition mode thy =
let
- val mode_cname = create_constname_of_mode thy "sizelim_" name mode
- val funT = sizelim_funT_of PredicateCompFuns.compfuns mode T
+ val mode_cname = create_constname_of_mode thy "depth_limited_" name mode
+ val funT = depth_limited_funT_of PredicateCompFuns.compfuns mode T
in
thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
- |> set_sizelim_function_name name mode mode_cname
+ |> set_depth_limited_function_name name mode mode_cname
end;
in
fold create_definition modes thy
@@ -1682,9 +1601,10 @@
let
val Ts = binder_types T
val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
- val paramTs' = map2 (fn SOME is => sizelim_funT_of PredicateCompFuns.compfuns ([], is) | NONE => I) iss paramTs
+ val paramTs' = map2 (fn SOME is => generator_funT_of ([], is) | NONE => I) iss paramTs
in
- (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT RPredCompFuns.compfuns (mk_tupleT outargTs))
+ (paramTs' @ inargTs @ [@{typ code_numeral}]) --->
+ (mk_predT RPredCompFuns.compfuns (HOLogic.mk_tupleT outargTs))
end
fun rpred_create_definitions preds (name, modes) thy =
@@ -1696,7 +1616,7 @@
val funT = generator_funT_of mode T
in
thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
- |> set_generator_name name mode mode_cname
+ |> set_generator_name name mode mode_cname
end;
in
fold create_definition modes thy
@@ -1818,7 +1738,7 @@
(* need better control here! *)
end
-fun prove_clause thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
+fun prove_clause options thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
let
val (in_ts, clause_out_ts) = split_smode is ts;
fun prove_prems out_ts [] =
@@ -1874,7 +1794,8 @@
end;
val prems_tac = prove_prems in_ts moded_ps
in
- rtac @{thm bindI} 1
+ print_tac' options "Proving clause..."
+ THEN rtac @{thm bindI} 1
THEN rtac @{thm singleI} 1
THEN prems_tac
end;
@@ -1883,20 +1804,20 @@
| select_sup _ 1 = [rtac @{thm supI1}]
| select_sup n i = (rtac @{thm supI2})::(select_sup (n - 1) (i - 1));
-fun prove_one_direction thy clauses preds modes pred mode moded_clauses =
+fun prove_one_direction options thy clauses preds modes pred mode moded_clauses =
let
val T = the (AList.lookup (op =) preds pred)
val nargs = length (binder_types T) - nparams_of thy pred
val pred_case_rule = the_elim_of thy pred
in
REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))
- THEN print_tac "before applying elim rule"
+ THEN print_tac' options "before applying elim rule"
THEN etac (predfun_elim_of thy pred mode) 1
THEN etac pred_case_rule 1
THEN (EVERY (map
(fn i => EVERY' (select_sup (length moded_clauses) i) i)
(1 upto (length moded_clauses))))
- THEN (EVERY (map2 (prove_clause thy nargs modes mode) clauses moded_clauses))
+ THEN (EVERY (map2 (prove_clause options thy nargs modes mode) clauses moded_clauses))
THEN print_tac "proved one direction"
end;
@@ -1914,15 +1835,20 @@
| _ => PureThy.get_thms thy (((fst o dest_Type o fastype_of) t) ^ ".split_asm")
val (_, ts) = strip_comb t
in
- (Splitter.split_asm_tac split_rules 1)
-(* THEN (Simplifier.asm_full_simp_tac HOL_basic_ss 1)
- THEN (DETERM (TRY (etac @{thm Pair_inject} 1))) *)
- THEN (REPEAT_DETERM_N (num_of_constrs - 1) (etac @{thm botE} 1 ORELSE etac @{thm botE} 2))
+ (print_tac ("Term " ^ (Syntax.string_of_term_global thy t) ^
+ "splitting with rules \n" ^
+ commas (map (Display.string_of_thm_global thy) split_rules)))
+ THEN TRY ((Splitter.split_asm_tac split_rules 1)
+ THEN (print_tac "after splitting with split_asm rules")
+ (* THEN (Simplifier.asm_full_simp_tac HOL_basic_ss 1)
+ THEN (DETERM (TRY (etac @{thm Pair_inject} 1)))*)
+ THEN (REPEAT_DETERM_N (num_of_constrs - 1) (etac @{thm botE} 1 ORELSE etac @{thm botE} 2)))
+ THEN (assert_tac (Max_number_of_subgoals 2))
THEN (EVERY (map split_term_tac ts))
end
else all_tac
in
- split_term_tac (mk_tuple out_ts)
+ split_term_tac (HOLogic.mk_tuple out_ts)
THEN (DETERM (TRY ((Splitter.split_asm_tac [@{thm "split_if_asm"}] 1) THEN (etac @{thm botE} 2))))
end
@@ -2053,7 +1979,7 @@
THEN prems_tac
end;
-fun prove_other_direction thy modes pred mode moded_clauses =
+fun prove_other_direction options thy modes pred mode moded_clauses =
let
fun prove_clause clause i =
(if i < length moded_clauses then etac @{thm supE} 1 else all_tac)
@@ -2063,26 +1989,28 @@
THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all})))
THEN (rtac (predfun_intro_of thy pred mode) 1)
THEN (REPEAT_DETERM (rtac @{thm refl} 2))
- THEN (EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
+ THEN (if null moded_clauses then
+ etac @{thm botE} 1
+ else EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
end;
(** proof procedure **)
-fun prove_pred thy clauses preds modes pred mode (moded_clauses, compiled_term) =
+fun prove_pred options thy clauses preds modes pred mode (moded_clauses, compiled_term) =
let
val ctxt = ProofContext.init thy
- val clauses = the (AList.lookup (op =) clauses pred)
+ val clauses = case AList.lookup (op =) clauses pred of SOME rs => rs | NONE => []
in
Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
- (if !do_proofs then
+ (if not (skip_proof options) then
(fn _ =>
rtac @{thm pred_iffI} 1
- THEN print_tac "after pred_iffI"
- THEN prove_one_direction thy clauses preds modes pred mode moded_clauses
- THEN print_tac "proved one direction"
- THEN prove_other_direction thy modes pred mode moded_clauses
- THEN print_tac "proved other direction")
- else fn _ => Skip_Proof.cheat_tac thy)
+ THEN print_tac' options "after pred_iffI"
+ THEN prove_one_direction options thy clauses preds modes pred mode moded_clauses
+ THEN print_tac' options "proved one direction"
+ THEN prove_other_direction options thy modes pred mode moded_clauses
+ THEN print_tac' options "proved other direction")
+ else (fn _ => Skip_Proof.cheat_tac thy))
end;
(* composition of mode inference, definition, compilation and proof *)
@@ -2101,48 +2029,57 @@
map (fn (pred, modes) =>
(pred, map (fn (mode, value) => value) modes)) preds_modes_table
-fun compile_preds compfuns mk_fun_of use_size thy all_vs param_vs preds moded_clauses =
- map_preds_modes (fn pred => compile_pred compfuns mk_fun_of use_size thy all_vs param_vs pred
- (the (AList.lookup (op =) preds pred))) moded_clauses
-
-fun prove thy clauses preds modes moded_clauses compiled_terms =
- map_preds_modes (prove_pred thy clauses preds modes)
+fun compile_preds comp_modifiers compfuns thy all_vs param_vs preds moded_clauses =
+ map_preds_modes (fn pred => compile_pred comp_modifiers compfuns thy all_vs param_vs pred
+ (the (AList.lookup (op =) preds pred))) moded_clauses
+
+fun prove options thy clauses preds modes moded_clauses compiled_terms =
+ map_preds_modes (prove_pred options thy clauses preds modes)
(join_preds_modes moded_clauses compiled_terms)
-fun prove_by_skip thy _ _ _ _ compiled_terms =
+fun prove_by_skip options thy _ _ _ _ compiled_terms =
map_preds_modes (fn pred => fn mode => fn t => Drule.standard (Skip_Proof.make_thm thy t))
compiled_terms
+
+fun dest_prem thy params t =
+ (case strip_comb t of
+ (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t
+ | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem thy params t of
+ Prem (ts, t) => Negprem (ts, t)
+ | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t)))
+ | Sidecond t => Sidecond (c $ t))
+ | (c as Const (s, _), ts) =>
+ if is_registered thy s then
+ let val (ts1, ts2) = chop (nparams_of thy s) ts
+ in Prem (ts2, list_comb (c, ts1)) end
+ else Sidecond t
+ | _ => Sidecond t)
-fun prepare_intrs thy prednames =
+fun prepare_intrs thy prednames intros =
let
- val intrs = maps (intros_of thy) prednames
- |> map (Logic.unvarify o prop_of)
+ val intrs = map prop_of intros
val nparams = nparams_of thy (hd prednames)
+ val preds = map (fn c => Const (c, Sign.the_const_type thy c)) prednames
+ val (preds, intrs) = unify_consts thy preds intrs
+ val ([preds, intrs], _) = fold_burrow (Variable.import_terms false) [preds, intrs] (ProofContext.init thy)
+ val preds = map dest_Const preds
val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name)
- val preds = distinct (op =) (map (dest_Const o fst o (strip_intro_concl nparams)) intrs)
- val _ $ u = Logic.strip_imp_concl (hd intrs);
- val params = List.take (snd (strip_comb u), nparams);
+ val params = case intrs of
+ [] =>
+ let
+ val (paramTs, _) = chop nparams (binder_types (snd (hd preds)))
+ val param_names = Name.variant_list [] (map (fn i => "p" ^ string_of_int i) (1 upto length paramTs))
+ in map Free (param_names ~~ paramTs) end
+ | intr :: _ => fst (chop nparams
+ (snd (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr)))))
val param_vs = maps term_vs params
val all_vs = terms_vs intrs
- fun dest_prem t =
- (case strip_comb t of
- (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t
- | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of
- Prem (ts, t) => Negprem (ts, t)
- | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t)))
- | Sidecond t => Sidecond (c $ t))
- | (c as Const (s, _), ts) =>
- if is_registered thy s then
- let val (ts1, ts2) = chop (nparams_of thy s) ts
- in Prem (ts2, list_comb (c, ts1)) end
- else Sidecond t
- | _ => Sidecond t)
fun add_clause intr (clauses, arities) =
let
val _ $ t = Logic.strip_imp_concl intr;
val (Const (name, T), ts) = strip_comb t;
val (ts1, ts2) = chop nparams ts;
- val prems = map (dest_prem o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
+ val prems = map (dest_prem thy params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
val (Ts, Us) = chop nparams (binder_types T)
in
(AList.update op = (name, these (AList.lookup op = clauses name) @
@@ -2177,31 +2114,74 @@
val all_modes = map (fn (s, T) => (s, modes_of_typ T)) preds
in (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) end;
+fun check_format_of_intro_rule thy intro =
+ let
+ val concl = Logic.strip_imp_concl (prop_of intro)
+ val (p, args) = strip_comb (HOLogic.dest_Trueprop concl)
+ val params = List.take (args, nparams_of thy (fst (dest_Const p)))
+ fun check_arg arg = case HOLogic.strip_tupleT (fastype_of arg) of
+ (Ts as _ :: _ :: _) =>
+ if (length (HOLogic.strip_tuple arg) = length Ts) then true
+ else
+ error ("Format of introduction rule is invalid: tuples must be expanded:"
+ ^ (Syntax.string_of_term_global thy arg) ^ " in " ^
+ (Display.string_of_thm_global thy intro))
+ | _ => true
+ val prems = Logic.strip_imp_prems (prop_of intro)
+ fun check_prem (Prem (args, _)) = forall check_arg args
+ | check_prem (Negprem (args, _)) = forall check_arg args
+ | check_prem _ = true
+ in
+ forall check_arg args andalso
+ forall (check_prem o dest_prem thy params o HOLogic.dest_Trueprop) prems
+ end
+
+(*
+fun check_intros_elim_match thy prednames =
+ let
+ fun check predname =
+ let
+ val intros = intros_of thy predname
+ val elim = the_elim_of thy predname
+ val nparams = nparams_of thy predname
+ val elim' =
+ (Drule.standard o (Skip_Proof.make_thm thy))
+ (mk_casesrule (ProofContext.init thy) nparams intros)
+ in
+ if not (Thm.equiv_thm (elim, elim')) then
+ error "Introduction and elimination rules do not match!"
+ else true
+ end
+ in forall check prednames end
+*)
+
(** main function of predicate compiler **)
-fun add_equations_of steps prednames thy =
+fun add_equations_of steps options prednames thy =
let
- val _ = tracing ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
+ val _ = print_step options ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
val _ = tracing (commas (map (Display.string_of_thm_global thy) (maps (intros_of thy) prednames)))
+ (*val _ = check_intros_elim_match thy prednames*)
+ (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
val (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) =
- prepare_intrs thy prednames
- val _ = tracing "Infering modes..."
- val moded_clauses = #infer_modes steps thy extra_modes all_modes param_vs clauses
+ prepare_intrs thy prednames (maps (intros_of thy) prednames)
+ val _ = print_step options "Infering modes..."
+ val moded_clauses = #infer_modes steps options thy extra_modes all_modes param_vs clauses
val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
+ val _ = check_expected_modes options modes
val _ = print_modes modes
- val _ = print_moded_clauses thy moded_clauses
- val _ = tracing "Defining executable functions..."
+ (*val _ = print_moded_clauses thy moded_clauses*)
+ val _ = print_step options "Defining executable functions..."
val thy' = fold (#create_definitions steps preds) modes thy
|> Theory.checkpoint
- val _ = tracing "Compiling equations..."
+ val _ = print_step options "Compiling equations..."
val compiled_terms =
(#compile_preds steps) thy' all_vs param_vs preds moded_clauses
- val _ = print_compiled_terms thy' compiled_terms
- val _ = tracing "Proving equations..."
- val result_thms = #prove steps thy' clauses preds (extra_modes @ modes)
+ val _ = print_compiled_terms options thy' compiled_terms
+ val _ = print_step options "Proving equations..."
+ val result_thms = #prove steps options thy' clauses preds (extra_modes @ modes)
moded_clauses compiled_terms
val qname = #qname steps
- (* val attrib = gn thy => Attrib.attribute_i thy Code.add_eqn_attrib *)
val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute
(fn thm => Context.mapping (Code.add_eqn thm) I))))
val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
@@ -2226,7 +2206,7 @@
fun extend value_of edges_of key G = fst (extend' value_of edges_of key (G, []))
-fun gen_add_equations steps names thy =
+fun gen_add_equations steps options names thy =
let
val thy' = PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names) thy
|> Theory.checkpoint;
@@ -2235,33 +2215,83 @@
val scc = strong_conn_of (PredData.get thy') names
val thy'' = fold_rev
(fn preds => fn thy =>
- if #are_not_defined steps thy preds then add_equations_of steps preds thy else thy)
+ if #are_not_defined steps thy preds then
+ add_equations_of steps options preds thy else thy)
scc thy' |> Theory.checkpoint
in thy'' end
(* different instantiantions of the predicate compiler *)
+val predicate_comp_modifiers =
+ {const_name_of = predfun_name_of,
+ funT_of = funT_of,
+ additional_arguments = K [],
+ wrap_compilation = K (K (K (K (K I)))),
+ transform_additional_arguments = K I
+ }
+
+val depth_limited_comp_modifiers =
+ {const_name_of = depth_limited_function_name_of,
+ funT_of = depth_limited_funT_of,
+ additional_arguments = fn names =>
+ let
+ val [depth_name, polarity_name] = Name.variant_list names ["depth", "polarity"]
+ in [Free (polarity_name, @{typ "bool"}), Free (depth_name, @{typ "code_numeral"})] end,
+ wrap_compilation =
+ fn compfuns => fn s => fn T => fn mode => fn additional_arguments => fn compilation =>
+ let
+ val [polarity, depth] = additional_arguments
+ val (_, Ts2) = chop (length (fst mode)) (binder_types T)
+ val (_, Us2) = split_smodeT (snd mode) Ts2
+ val T' = mk_predT compfuns (HOLogic.mk_tupleT Us2)
+ val if_const = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
+ val full_mode = null Us2
+ in
+ if_const $ HOLogic.mk_eq (depth, @{term "0 :: code_numeral"})
+ $ (if_const $ polarity $ mk_bot compfuns (dest_predT compfuns T')
+ $ (if full_mode then mk_single compfuns HOLogic.unit else Const (@{const_name undefined}, T')))
+ $ compilation
+ end,
+ transform_additional_arguments =
+ fn prem => fn additional_arguments =>
+ let
+ val [polarity, depth] = additional_arguments
+ val polarity' = (case prem of Prem _ => I | Negprem _ => HOLogic.mk_not | _ => I) polarity
+ val depth' =
+ Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"})
+ $ depth $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"})
+ in [polarity', depth'] end
+ }
+
+val rpred_comp_modifiers =
+ {const_name_of = generator_name_of,
+ funT_of = K generator_funT_of,
+ additional_arguments = fn names => [Free (Name.variant names "size", @{typ code_numeral})],
+ wrap_compilation = K (K (K (K (K I)))),
+ transform_additional_arguments = K I
+ }
+
+
val add_equations = gen_add_equations
{infer_modes = infer_modes,
create_definitions = create_definitions,
- compile_preds = compile_preds PredicateCompFuns.compfuns mk_fun_of false,
+ compile_preds = compile_preds predicate_comp_modifiers PredicateCompFuns.compfuns,
prove = prove,
are_not_defined = fn thy => forall (null o modes_of thy),
qname = "equation"}
-val add_sizelim_equations = gen_add_equations
+val add_depth_limited_equations = gen_add_equations
{infer_modes = infer_modes,
- create_definitions = sizelim_create_definitions,
- compile_preds = compile_preds PredicateCompFuns.compfuns mk_sizelim_fun_of true,
+ create_definitions = create_definitions_of_depth_limited_functions,
+ compile_preds = compile_preds depth_limited_comp_modifiers PredicateCompFuns.compfuns,
prove = prove_by_skip,
- are_not_defined = fn thy => forall (null o sizelim_modes_of thy),
- qname = "sizelim_equation"
- }
+ are_not_defined = fn thy => forall (null o depth_limited_modes_of thy),
+ qname = "depth_limited_equation"}
val add_quickcheck_equations = gen_add_equations
{infer_modes = infer_modes_with_generator,
create_definitions = rpred_create_definitions,
- compile_preds = compile_preds RPredCompFuns.compfuns mk_generator_of true,
+ compile_preds = compile_preds rpred_comp_modifiers RPredCompFuns.compfuns,
prove = prove_by_skip,
are_not_defined = fn thy => forall (null o rpred_modes_of thy),
qname = "rpred_equation"}
@@ -2283,15 +2313,11 @@
val setup = PredData.put (Graph.empty) #>
Attrib.setup @{binding code_pred_intros} (Scan.succeed (attrib add_intro))
"adding alternative introduction rules for code generation of inductive predicates"
-(* Attrib.setup @{binding code_ind_cases} (Scan.succeed add_elim_attrib)
- "adding alternative elimination rules for code generation of inductive predicates";
- *)
(*FIXME name discrepancy in attribs and ML code*)
(*FIXME intros should be better named intro*)
- (*FIXME why distinguished attribute for cases?*)
(* TODO: make TheoryDataFun to GenericDataFun & remove duplication of local theory and theory *)
-fun generic_code_pred prep_const rpred raw_const lthy =
+fun generic_code_pred prep_const options raw_const lthy =
let
val thy = ProofContext.theory_of lthy
val const = prep_const thy raw_const
@@ -2302,9 +2328,11 @@
val preds = Graph.all_preds (PredData.get thy') [const] |> filter_out (has_elim thy')
fun mk_cases const =
let
+ val T = Sign.the_const_type thy const
+ val pred = Const (const, T)
val nparams = nparams_of thy' const
val intros = intros_of thy' const
- in mk_casesrule lthy' nparams intros end
+ in mk_casesrule lthy' pred nparams intros end
val cases_rules = map mk_cases preds
val cases =
map (fn case_rule => RuleCases.Case {fixes = [],
@@ -2320,11 +2348,14 @@
(ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms)
in
goal_ctxt |> LocalTheory.theory (fold set_elim global_thms #>
- (if rpred then
- (add_equations [const] #>
- add_sizelim_equations [const] #> add_quickcheck_equations [const])
- else add_equations [const]))
- end
+ (if is_rpred options then
+ (add_equations options [const] #>
+ add_quickcheck_equations options [const])
+ else if is_depth_limited options then
+ add_depth_limited_equations options [const]
+ else
+ add_equations options [const]))
+ end
in
Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
end;
@@ -2335,9 +2366,11 @@
(* transformation for code generation *)
val eval_ref = Unsynchronized.ref (NONE : (unit -> term Predicate.pred) option);
+val random_eval_ref = Unsynchronized.ref (NONE : (unit -> int * int -> term Predicate.pred * (int * int)) option);
(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
-fun analyze_compr thy t_compr =
+(* TODO: *)
+fun analyze_compr thy compfuns (depth_limit, random) t_compr =
let
val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
| _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t_compr);
@@ -2348,6 +2381,8 @@
(fn (i, t) => case t of Bound j => if j < length Ts then NONE
else SOME (i+1) | _ => SOME (i+1)) args); (*FIXME dangling bounds should not occur*)
val user_mode' = map (rpair NONE) user_mode
+ val all_modes_of = if random then all_generator_modes_of else all_modes_of
+ (*val compile_expr = if random then compile_gen_expr else compile_expr*)
val modes = filter (fn Mode (_, is, _) => is = user_mode')
(modes_of_term (all_modes_of thy) (list_comb (pred, params)));
val m = case modes
@@ -2357,7 +2392,17 @@
| m :: _ :: _ => (warning ("Multiple modes possible for comprehension "
^ Syntax.string_of_term_global thy t_compr); m);
val (inargs, outargs) = split_smode user_mode' args;
- val t_pred = list_comb (compile_expr NONE NONE thy (m, list_comb (pred, params)), inargs);
+ val additional_arguments =
+ case depth_limit of
+ NONE => (if random then [@{term "5 :: code_numeral"}] else [])
+ | SOME d => [@{term "True"}, HOLogic.mk_number @{typ "code_numeral"} d]
+ val comp_modifiers =
+ case depth_limit of NONE =>
+ (if random then rpred_comp_modifiers else predicate_comp_modifiers) | SOME _ => depth_limited_comp_modifiers
+ val mk_fun_of = if random then mk_generator_of else
+ if (is_some depth_limit) then mk_depth_limited_fun_of else mk_fun_of
+ val t_pred = compile_expr comp_modifiers compfuns thy
+ (m, list_comb (pred, params)) inargs additional_arguments;
val t_eval = if null outargs then t_pred else
let
val outargs_bounds = map (fn Bound i => i) outargs;
@@ -2370,22 +2415,30 @@
val arrange = funpow (length outargs_bounds - 1) HOLogic.mk_split
(Term.list_abs (map (pair "") outargsTs,
HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds)))
- in mk_map PredicateCompFuns.compfuns T_pred T_compr arrange t_pred end
+ in mk_map compfuns T_pred T_compr arrange t_pred end
in t_eval end;
-fun eval thy t_compr =
+fun eval thy (options as (depth_limit, random)) t_compr =
let
- val t = analyze_compr thy t_compr;
- val T = dest_predT PredicateCompFuns.compfuns (fastype_of t);
- val t' = mk_map PredicateCompFuns.compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
- in (T, Code_ML.eval NONE ("Predicate_Compile_Core.eval_ref", eval_ref) Predicate.map thy t' []) end;
+ val compfuns = if random then RPredCompFuns.compfuns else PredicateCompFuns.compfuns
+ val t = analyze_compr thy compfuns options t_compr;
+ val T = dest_predT compfuns (fastype_of t);
+ val t' = mk_map compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
+ val eval =
+ if random then
+ Code_ML.eval NONE ("Predicate_Compile_Core.random_eval_ref", random_eval_ref)
+ (fn proc => fn g => fn s => g s |>> Predicate.map proc) thy t' []
+ |> Random_Engine.run
+ else
+ Code_ML.eval NONE ("Predicate_Compile_Core.eval_ref", eval_ref) Predicate.map thy t' []
+ in (T, eval) end;
-fun values ctxt k t_compr =
+fun values ctxt options k t_compr =
let
val thy = ProofContext.theory_of ctxt;
- val (T, t) = eval thy t_compr;
+ val (T, ts) = eval thy options t_compr;
+ val (ts, _) = Predicate.yieldn k ts;
val setT = HOLogic.mk_setT T;
- val (ts, _) = Predicate.yieldn k t;
val elemsT = HOLogic.mk_set T ts;
in if k = ~1 orelse length ts < k then elemsT
else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ t_compr
@@ -2398,11 +2451,11 @@
in
end;
*)
-fun values_cmd modes k raw_t state =
+fun values_cmd modes options k raw_t state =
let
val ctxt = Toplevel.context_of state;
val t = Syntax.read_term ctxt raw_t;
- val t' = values ctxt k t;
+ val t' = values ctxt options k t;
val ty' = Term.type_of t';
val ctxt' = Variable.auto_fixes t' ctxt;
val p = PrintMode.with_modes modes (fn () =>
@@ -2410,15 +2463,24 @@
Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
in Pretty.writeln p end;
-
local structure P = OuterParse in
val opt_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
+val _ = List.app OuterKeyword.keyword ["depth_limit", "random"]
+
+val options =
+ let
+ val depth_limit = Scan.optional (P.$$$ "depth_limit" |-- P.$$$ "=" |-- P.nat >> SOME) NONE
+ val random = Scan.optional (P.$$$ "random" >> K true) false
+ in
+ Scan.optional (P.$$$ "[" |-- depth_limit -- random --| P.$$$ "]") (NONE, false)
+ end
+
val _ = OuterSyntax.improper_command "values" "enumerate and print comprehensions" OuterKeyword.diag
- (opt_modes -- Scan.optional P.nat ~1 -- P.term
- >> (fn ((modes, k), t) => Toplevel.no_timing o Toplevel.keep
- (values_cmd modes k t)));
+ (opt_modes -- options -- Scan.optional P.nat ~1 -- P.term
+ >> (fn (((modes, options), k), t) => Toplevel.no_timing o Toplevel.keep
+ (values_cmd modes options k t)));
end;
--- a/src/HOL/Tools/inductive.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/inductive.ML Tue Oct 27 14:46:03 2009 +0000
@@ -47,7 +47,7 @@
(Attrib.binding * string) list ->
(Facts.ref * Attrib.src list) list ->
bool -> local_theory -> inductive_result * local_theory
- val add_inductive_global: string -> inductive_flags ->
+ val add_inductive_global: serial -> inductive_flags ->
((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list ->
thm list -> theory -> inductive_result * theory
val arities_of: thm -> (string * int) list
@@ -144,7 +144,7 @@
val (tab, monos) = get_inductives ctxt;
val space = Consts.space_of (ProofContext.consts_of ctxt);
in
- [Pretty.strs ("(co)inductives:" :: map #1 (NameSpace.extern_table (space, tab))),
+ [Pretty.strs ("(co)inductives:" :: map #1 (Name_Space.extern_table (space, tab))),
Pretty.big_list "monotonicity rules:" (map (Display.pretty_thm ctxt) monos)]
|> Pretty.chunks |> Pretty.writeln
end;
@@ -859,7 +859,7 @@
skip_mono = false, fork_mono = not int};
in
lthy
- |> LocalTheory.set_group (serial_string ())
+ |> LocalTheory.set_group (serial ())
|> gen_add_inductive_i mk_def flags cs (map (apfst Binding.name_of o fst) ps) intrs monos
end;
--- a/src/HOL/Tools/inductive_realizer.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/inductive_realizer.ML Tue Oct 27 14:46:03 2009 +0000
@@ -351,7 +351,7 @@
(** realizability predicate **)
val (ind_info, thy3') = thy2 |>
- Inductive.add_inductive_global (serial_string ())
+ Inductive.add_inductive_global (serial ())
{quiet_mode = false, verbose = false, kind = Thm.generatedK, alt_name = Binding.empty,
coind = false, no_elim = false, no_ind = false, skip_mono = false, fork_mono = false}
rlzpreds rlzparams (map (fn (rintr, intr) =>--- a/src/HOL/Tools/primrec.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/primrec.ML Tue Oct 27 14:46:03 2009 +0000
@@ -275,7 +275,7 @@
[Simplifier.simp_add, Nitpick_Simps.add, Quickcheck_RecFun_Simps.add]);
in
lthy
- |> set_group ? LocalTheory.set_group (serial_string ())
+ |> set_group ? LocalTheory.set_group (serial ())
|> add_primrec_simple fixes (map snd spec)
|-> (fn (prefix, simps) => fold_map (LocalTheory.note Thm.generatedK)
(attr_bindings prefix ~~ simps)--- a/src/HOL/Tools/quickcheck_generators.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/quickcheck_generators.ML Tue Oct 27 14:46:03 2009 +0000
@@ -84,7 +84,7 @@
thy
|> TheoryTarget.instantiation ([tyco], vs, @{sort random})
|> `(fn lthy => Syntax.check_term lthy eq)
- |-> (fn eq => Specification.definition (NONE, (Attrib.empty_binding, eq)))
+ |-> (fn eq => Specification.definition (NONE, (apfst (Binding.conceal) Attrib.empty_binding, eq)))
|> snd
|> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
end;
@@ -140,7 +140,7 @@
subst_v (@{term "Suc_code_numeral"} $ t_k) eq];
val eqs1 = map (Pattern.rewrite_term thy rew_ts []) eqs0;
val ((_, eqs2), lthy') = Primrec.add_primrec_simple
- [((Binding.name random_aux, T), NoSyn)] eqs1 lthy;
+ [((Binding.conceal (Binding.name random_aux), T), NoSyn)] eqs1 lthy;
val cT_random_aux = inst pt_random_aux;
val cT_rhs = inst pt_rhs;
val rule = @{thm random_aux_rec}
@@ -176,7 +176,8 @@
val projs = mk_proj (aux_lhs) Ts;
val proj_eqs = map2 (fn v => fn proj => (v, lambda arg proj)) vs projs;
val proj_defs = map2 (fn Free (name, _) => fn (_, rhs) =>
- ((Binding.name name, NoSyn), (Attrib.empty_binding, rhs))) vs proj_eqs;
+ ((Binding.conceal (Binding.name name), NoSyn),
+ (apfst (Binding.conceal) Attrib.empty_binding, rhs))) vs proj_eqs;
val aux_eq' = Pattern.rewrite_term thy proj_eqs [] aux_eq;
fun prove_eqs aux_simp proj_defs lthy =
let
@@ -207,7 +208,8 @@
val ext_simps = map (fn thm => fun_cong OF [fun_cong OF [thm]]) proto_simps;
val tac = ALLGOALS (ProofContext.fact_tac ext_simps);
in (map (fn prop => Skip_Proof.prove lthy vs [] prop (K tac)) eqs, lthy) end;
- val b = Binding.qualify true prfx (Binding.qualify true name (Binding.name "simps"));
+ val b = Binding.conceal (Binding.qualify true prfx
+ (Binding.qualify true name (Binding.name "simps")));
in
lthy
|> random_aux_primrec_multi (name ^ prfx) proto_eqs
@@ -303,8 +305,8 @@
|> random_aux_specification prfx random_auxN auxs_eqs
|> `(fn lthy => map (Syntax.check_term lthy) random_defs)
|-> (fn random_defs' => fold_map (fn random_def =>
- Specification.definition (NONE, (Attrib.empty_binding,
- random_def))) random_defs')
+ Specification.definition (NONE, (apfst (Binding.conceal)
+ Attrib.empty_binding, random_def))) random_defs')
|> snd
|> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
end;
@@ -317,7 +319,7 @@
|> fold (fn (v, sort) => Vartab.update ((v, 0), sort)) raw_vs
|> fold meet_random insts;
in SOME (fn (v, _) => (v, (the o Vartab.lookup vtab) (v, 0)))
- end handle CLASS_ERROR => NONE;
+ end handle Sorts.CLASS_ERROR _ => NONE;
fun ensure_random_datatype config raw_tycos thy =
let--- a/src/HOL/Tools/record.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/record.ML Tue Oct 27 14:46:03 2009 +0000
@@ -1810,7 +1810,7 @@
fun record_definition (args, bname) parent (parents: parent_info list) raw_fields thy =
let
- val external_names = NameSpace.external_names (Sign.naming_of thy);
+ val external_names = Name_Space.external_names (Sign.naming_of thy);
val alphas = map fst args;
val name = Sign.full_bname thy bname;--- a/src/HOL/Tools/res_atp.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/res_atp.ML Tue Oct 27 14:46:03 2009 +0000
@@ -355,7 +355,7 @@
if run_blacklist_filter andalso is_package_def name then I
else
let val xname = Facts.extern facts name in
- if NameSpace.is_hidden xname then I
+ if Name_Space.is_hidden xname then I
else cons (xname, filter_out ResAxioms.bad_for_atp ths)
end) facts [];
--- a/src/HOL/Tools/res_axioms.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Tools/res_axioms.ML Tue Oct 27 14:46:03 2009 +0000
@@ -85,7 +85,7 @@
val rhs = list_abs_free (map dest_Free args, HOLogic.choice_const T $ xtp)
(*Forms a lambda-abstraction over the formal parameters*)
val (c, thy') =
- Sign.declare_const [Markup.property_internal] ((Binding.name cname, cT), NoSyn) thy
+ Sign.declare_const ((Binding.conceal (Binding.name cname), cT), NoSyn) thy
val cdef = cname ^ "_def"
val thy'' = Theory.add_defs_i true false [(Binding.name cdef, Logic.mk_equals (c, rhs))] thy'
val ax = Thm.axiom thy'' (Sign.full_bname thy'' cdef)--- a/src/HOL/Wellfounded.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/Wellfounded.thy Tue Oct 27 14:46:03 2009 +0000
@@ -14,19 +14,12 @@
subsection {* Basic Definitions *}
-constdefs
- wf :: "('a * 'a)set => bool"
+definition wf :: "('a * 'a) set => bool" where
"wf(r) == (!P. (!x. (!y. (y,x):r --> P(y)) --> P(x)) --> (!x. P(x)))"
- wfP :: "('a => 'a => bool) => bool"
+definition wfP :: "('a => 'a => bool) => bool" where
"wfP r == wf {(x, y). r x y}"
- acyclic :: "('a*'a)set => bool"
- "acyclic r == !x. (x,x) ~: r^+"
-
-abbreviation acyclicP :: "('a => 'a => bool) => bool" where
- "acyclicP r == acyclic {(x, y). r x y}"
-
lemma wfP_wf_eq [pred_set_conv]: "wfP (\<lambda>x y. (x, y) \<in> r) = wf r"
by (simp add: wfP_def)
@@ -59,14 +52,16 @@
lemma wf_not_sym: "wf r ==> (a, x) : r ==> (x, a) ~: r"
by (induct a arbitrary: x set: wf) blast
-(* [| wf r; ~Z ==> (a,x) : r; (x,a) ~: r ==> Z |] ==> Z *)
-lemmas wf_asym = wf_not_sym [elim_format]
+lemma wf_asym:
+ assumes "wf r" "(a, x) \<in> r"
+ obtains "(x, a) \<notin> r"
+ by (drule wf_not_sym[OF assms])
lemma wf_not_refl [simp]: "wf r ==> (a, a) ~: r"
by (blast elim: wf_asym)
-(* [| wf r; (a,a) ~: r ==> PROP W |] ==> PROP W *)
-lemmas wf_irrefl = wf_not_refl [elim_format]
+lemma wf_irrefl: assumes "wf r" obtains "(a, a) \<notin> r"
+by (drule wf_not_refl[OF assms])
lemma wf_wellorderI:
assumes wf: "wf {(x::'a::ord, y). x < y}"
@@ -82,7 +77,62 @@
subsection {* Basic Results *}
-text{*transitive closure of a well-founded relation is well-founded! *}
+text {* Point-free characterization of well-foundedness *}
+
+lemma wfE_pf:
+ assumes wf: "wf R"
+ assumes a: "A \<subseteq> R `` A"
+ shows "A = {}"
+proof -
+ { fix x
+ from wf have "x \<notin> A"
+ proof induct
+ fix x assume "\<And>y. (y, x) \<in> R \<Longrightarrow> y \<notin> A"
+ then have "x \<notin> R `` A" by blast
+ with a show "x \<notin> A" by blast
+ qed
+ } thus ?thesis by auto
+qed
+
+lemma wfI_pf:
+ assumes a: "\<And>A. A \<subseteq> R `` A \<Longrightarrow> A = {}"
+ shows "wf R"
+proof (rule wfUNIVI)
+ fix P :: "'a \<Rightarrow> bool" and x
+ let ?A = "{x. \<not> P x}"
+ assume "\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x"
+ then have "?A \<subseteq> R `` ?A" by blast
+ with a show "P x" by blast
+qed
+
+text{*Minimal-element characterization of well-foundedness*}
+
+lemma wfE_min:
+ assumes wf: "wf R" and Q: "x \<in> Q"
+ obtains z where "z \<in> Q" "\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q"
+ using Q wfE_pf[OF wf, of Q] by blast
+
+lemma wfI_min:
+ assumes a: "\<And>x Q. x \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q"
+ shows "wf R"
+proof (rule wfI_pf)
+ fix A assume b: "A \<subseteq> R `` A"
+ { fix x assume "x \<in> A"
+ from a[OF this] b have "False" by blast
+ }
+ thus "A = {}" by blast
+qed
+
+lemma wf_eq_minimal: "wf r = (\<forall>Q x. x\<in>Q --> (\<exists>z\<in>Q. \<forall>y. (y,z)\<in>r --> y\<notin>Q))"
+apply auto
+apply (erule wfE_min, assumption, blast)
+apply (rule wfI_min, auto)
+done
+
+lemmas wfP_eq_minimal = wf_eq_minimal [to_pred]
+
+text{* Well-foundedness of transitive closure *}
+
lemma wf_trancl:
assumes "wf r"
shows "wf (r^+)"
@@ -122,43 +172,8 @@
apply (erule wf_trancl)
done
+text {* Well-foundedness of subsets *}
-text{*Minimal-element characterization of well-foundedness*}
-lemma wf_eq_minimal: "wf r = (\<forall>Q x. x\<in>Q --> (\<exists>z\<in>Q. \<forall>y. (y,z)\<in>r --> y\<notin>Q))"
-proof (intro iffI strip)
- fix Q :: "'a set" and x
- assume "wf r" and "x \<in> Q"
- then show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q"
- unfolding wf_def
- by (blast dest: spec [of _ "%x. x\<in>Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y,z) \<in> r \<longrightarrow> y\<notin>Q)"])
-next
- assume 1: "\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q)"
- show "wf r"
- proof (rule wfUNIVI)
- fix P :: "'a \<Rightarrow> bool" and x
- assume 2: "\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x"
- let ?Q = "{x. \<not> P x}"
- have "x \<in> ?Q \<longrightarrow> (\<exists>z \<in> ?Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> ?Q)"
- by (rule 1 [THEN spec, THEN spec])
- then have "\<not> P x \<longrightarrow> (\<exists>z. \<not> P z \<and> (\<forall>y. (y, z) \<in> r \<longrightarrow> P y))" by simp
- with 2 have "\<not> P x \<longrightarrow> (\<exists>z. \<not> P z \<and> P z)" by fast
- then show "P x" by simp
- qed
-qed
-
-lemma wfE_min:
- assumes "wf R" "x \<in> Q"
- obtains z where "z \<in> Q" "\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q"
- using assms unfolding wf_eq_minimal by blast
-
-lemma wfI_min:
- "(\<And>x Q. x \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q)
- \<Longrightarrow> wf R"
- unfolding wf_eq_minimal by blast
-
-lemmas wfP_eq_minimal = wf_eq_minimal [to_pred]
-
-text {* Well-foundedness of subsets *}
lemma wf_subset: "[| wf(r); p<=r |] ==> wf(p)"
apply (simp (no_asm_use) add: wf_eq_minimal)
apply fast
@@ -167,7 +182,8 @@
lemmas wfP_subset = wf_subset [to_pred]
text {* Well-foundedness of the empty relation *}
-lemma wf_empty [iff]: "wf({})"
+
+lemma wf_empty [iff]: "wf {}"
by (simp add: wf_def)
lemma wfP_empty [iff]:
@@ -187,7 +203,20 @@
apply (rule Int_lower2)
done
-text{*Well-foundedness of insert*}
+text {* Exponentiation *}
+
+lemma wf_exp:
+ assumes "wf (R ^^ n)"
+ shows "wf R"
+proof (rule wfI_pf)
+ fix A assume "A \<subseteq> R `` A"
+ then have "A \<subseteq> (R ^^ n) `` A" by (induct n) force+
+ with `wf (R ^^ n)`
+ show "A = {}" by (rule wfE_pf)
+qed
+
+text {* Well-foundedness of insert *}
+
lemma wf_insert [iff]: "wf(insert (y,x) r) = (wf(r) & (x,y) ~: r^*)"
apply (rule iffI)
apply (blast elim: wf_trancl [THEN wf_irrefl]
@@ -210,6 +239,7 @@
done
text{*Well-foundedness of image*}
+
lemma wf_prod_fun_image: "[| wf r; inj f |] ==> wf(prod_fun f f ` r)"
apply (simp only: wf_eq_minimal, clarify)
apply (case_tac "EX p. f p : Q")
@@ -351,7 +381,13 @@
by (rule wf_union_merge [where S = "{}", simplified])
-subsubsection {* acyclic *}
+subsection {* Acyclic relations *}
+
+definition acyclic :: "('a * 'a) set => bool" where
+ "acyclic r == !x. (x,x) ~: r^+"
+
+abbreviation acyclicP :: "('a => 'a => bool) => bool" where
+ "acyclicP r == acyclic {(x, y). r x y}"
lemma acyclicI: "ALL x. (x, x) ~: r^+ ==> acyclic r"
by (simp add: acyclic_def)--- a/src/HOL/ex/Predicate_Compile.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/ex/Predicate_Compile.thy Tue Oct 27 14:46:03 2009 +0000
@@ -12,6 +12,6 @@
begin
setup {* Predicate_Compile.setup *}
-setup {* Quickcheck.add_generator ("pred_compile", Pred_Compile_Quickcheck.quickcheck) *}
+setup {* Quickcheck.add_generator ("pred_compile", Predicate_Compile_Quickcheck.quickcheck) *}
end
\ No newline at end of file--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/ex/Predicate_Compile_Alternative_Defs.thy Tue Oct 27 14:46:03 2009 +0000
@@ -0,0 +1,76 @@
+theory Predicate_Compile_Alternative_Defs
+imports Predicate_Compile
+begin
+
+section {* Set operations *}
+(*
+definition Empty where "Empty == {}"
+declare empty_def[symmetric, code_pred_inline]
+*)
+declare eq_reflection[OF empty_def, code_pred_inline]
+(*
+definition Union where "Union A B == A Un B"
+
+lemma [code_pred_intros]: "A x ==> Union A B x"
+and [code_pred_intros] : "B x ==> Union A B x"
+unfolding Union_def Un_def Collect_def mem_def by auto
+
+code_pred Union
+unfolding Union_def Un_def Collect_def mem_def by auto
+
+declare Union_def[symmetric, code_pred_inline]
+*)
+declare eq_reflection[OF Un_def, code_pred_inline]
+
+section {* Alternative list definitions *}
+
+subsection {* Alternative rules for set *}
+
+lemma set_ConsI1 [code_pred_intros]:
+ "set (x # xs) x"
+unfolding mem_def[symmetric, of _ x]
+by auto
+
+lemma set_ConsI2 [code_pred_intros]:
+ "set xs x ==> set (x' # xs) x"
+unfolding mem_def[symmetric, of _ x]
+by auto
+
+code_pred set
+proof -
+ case set
+ from this show thesis
+ apply (case_tac a1)
+ apply auto
+ unfolding mem_def[symmetric, of _ a2]
+ apply auto
+ unfolding mem_def
+ apply auto
+ done
+qed
+
+
+subsection {* Alternative rules for list_all2 *}
+
+lemma list_all2_NilI [code_pred_intros]: "list_all2 P [] []"
+by auto
+
+lemma list_all2_ConsI [code_pred_intros]: "list_all2 P xs ys ==> P x y ==> list_all2 P (x#xs) (y#ys)"
+by auto
+
+code_pred list_all2
+proof -
+ case list_all2
+ from this show thesis
+ apply -
+ apply (case_tac a1)
+ apply (case_tac a2)
+ apply auto
+ apply (case_tac a2)
+ apply auto
+ done
+qed
+
+
+
+end
\ No newline at end of file--- a/src/HOL/ex/Predicate_Compile_ex.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/ex/Predicate_Compile_ex.thy Tue Oct 27 14:46:03 2009 +0000
@@ -1,5 +1,5 @@
theory Predicate_Compile_ex
-imports Main Predicate_Compile
+imports Main Predicate_Compile_Alternative_Defs
begin
inductive even :: "nat \<Rightarrow> bool" and odd :: "nat \<Rightarrow> bool" where
@@ -7,66 +7,216 @@
| "even n \<Longrightarrow> odd (Suc n)"
| "odd n \<Longrightarrow> even (Suc n)"
-code_pred even .
+code_pred (mode: [], [1]) even .
+code_pred [depth_limited] even .
+code_pred [rpred] even .
thm odd.equation
thm even.equation
+thm odd.depth_limited_equation
+thm even.depth_limited_equation
+thm even.rpred_equation
+thm odd.rpred_equation
values "{x. even 2}"
values "{x. odd 2}"
values 10 "{n. even n}"
values 10 "{n. odd n}"
+values [depth_limit = 2] "{x. even 6}"
+values [depth_limit = 7] "{x. even 6}"
+values [depth_limit = 2] "{x. odd 7}"
+values [depth_limit = 8] "{x. odd 7}"
+
+values [depth_limit = 7] 10 "{n. even n}"
+
+definition odd' where "odd' x == \<not> even x"
+
+code_pred [inductify] odd' .
+code_pred [inductify, depth_limited] odd' .
+code_pred [inductify, rpred] odd' .
+
+thm odd'.depth_limited_equation
+values [depth_limit = 2] "{x. odd' 7}"
+values [depth_limit = 9] "{x. odd' 7}"
inductive append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"append [] xs xs"
| "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"
-code_pred append .
-code_pred (inductify_all) (rpred) append .
+code_pred (mode: [1, 2], [3], [2, 3], [1, 3], [1, 2, 3]) append .
+code_pred [depth_limited] append .
+code_pred [rpred] append .
thm append.equation
+thm append.depth_limited_equation
thm append.rpred_equation
values "{(ys, xs). append xs ys [0, Suc 0, 2]}"
values "{zs. append [0, Suc 0, 2] [17, 8] zs}"
-values "{ys. append [0, Suc 0, 2] ys [0, Suc 0, 2, 17, 0,5]}"
+values "{ys. append [0, Suc 0, 2] ys [0, Suc 0, 2, 17, 0, 5]}"
+values [depth_limit = 3] "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
+values [random] 15 "{(ys, zs). append [1::nat, 2] ys zs}"
+
+value [code] "Predicate.the (append_1_2 [0::int, 1, 2] [3, 4, 5])"
+value [code] "Predicate.the (append_3 ([]::int list))"
+
+subsection {* Tricky case with alternative rules *}
+
+inductive append2
+where
+ "append2 [] xs xs"
+| "append2 xs ys zs \<Longrightarrow> append2 (x # xs) ys (x # zs)"
+
+lemma append2_Nil: "append2 [] (xs::'b list) xs"
+ by (simp add: append2.intros(1))
+
+lemmas [code_pred_intros] = append2_Nil append2.intros(2)
+
+code_pred append2
+proof -
+ case append2
+ from append2.cases[OF append2(1)] append2(2-3) show thesis by blast
+qed
+
+subsection {* Tricky cases with tuples *}
+
+inductive zerozero :: "nat * nat => bool"
+where
+ "zerozero (0, 0)"
+
+code_pred zerozero .
+code_pred [rpred] zerozero .
+
+inductive tupled_append :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
+where
+ "tupled_append ([], xs, xs)"
+| "tupled_append (xs, ys, zs) \<Longrightarrow> tupled_append (x # xs, ys, x # zs)"
+
+code_pred tupled_append .
+code_pred [rpred] tupled_append .
+thm tupled_append.equation
+(*
+TODO: values with tupled modes
+values "{xs. tupled_append ([1,2,3], [4,5], xs)}"
+*)
+
+inductive tupled_append'
+where
+"tupled_append' ([], xs, xs)"
+| "[| ys = fst (xa, y); x # zs = snd (xa, y);
+ tupled_append' (xs, ys, zs) |] ==> tupled_append' (x # xs, xa, y)"
+
+code_pred tupled_append' .
+thm tupled_append'.equation
+
+inductive tupled_append'' :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
+where
+ "tupled_append'' ([], xs, xs)"
+| "ys = fst yszs ==> x # zs = snd yszs ==> tupled_append'' (xs, ys, zs) \<Longrightarrow> tupled_append'' (x # xs, yszs)"
+
+thm tupled_append''.cases
+
+code_pred [inductify] tupled_append'' .
+thm tupled_append''.equation
+
+inductive tupled_append''' :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
+where
+ "tupled_append''' ([], xs, xs)"
+| "yszs = (ys, zs) ==> tupled_append''' (xs, yszs) \<Longrightarrow> tupled_append''' (x # xs, ys, x # zs)"
+
+code_pred [inductify] tupled_append''' .
+thm tupled_append'''.equation
+
+inductive map_ofP :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
+where
+ "map_ofP ((a, b)#xs) a b"
+| "map_ofP xs a b \<Longrightarrow> map_ofP (x#xs) a b"
+
+code_pred (mode: [1], [1, 2], [1, 2, 3], [1, 3]) map_ofP .
+thm map_ofP.equation
+
+inductive filter1
+for P
+where
+ "filter1 P [] []"
+| "P x ==> filter1 P xs ys ==> filter1 P (x#xs) (x#ys)"
+| "\<not> P x ==> filter1 P xs ys ==> filter1 P (x#xs) ys"
+
+code_pred (mode: [1], [1, 2]) filter1 .
+code_pred [depth_limited] filter1 .
+code_pred [rpred] filter1 .
+
+thm filter1.equation
+
+inductive filter2
+where
+ "filter2 P [] []"
+| "P x ==> filter2 P xs ys ==> filter2 P (x#xs) (x#ys)"
+| "\<not> P x ==> filter2 P xs ys ==> filter2 P (x#xs) ys"
+
+code_pred (mode: [1, 2, 3], [1, 2]) filter2 .
+code_pred [depth_limited] filter2 .
+code_pred [rpred] filter2 .
+thm filter2.equation
+thm filter2.rpred_equation
+
+inductive filter3
+for P
+where
+ "List.filter P xs = ys ==> filter3 P xs ys"
+
+code_pred filter3 .
+code_pred [depth_limited] filter3 .
+thm filter3.depth_limited_equation
+(*code_pred [rpred] filter3 .*)
+inductive filter4
+where
+ "List.filter P xs = ys ==> filter4 P xs ys"
+
+code_pred filter4 .
+code_pred [depth_limited] filter4 .
+code_pred [rpred] filter4 .
+
+section {* reverse *}
inductive rev where
"rev [] []"
| "rev xs xs' ==> append xs' [x] ys ==> rev (x#xs) ys"
-code_pred rev .
+code_pred (mode: [1], [2], [1, 2]) rev .
thm rev.equation
values "{xs. rev [0, 1, 2, 3::nat] xs}"
+inductive tupled_rev where
+ "tupled_rev ([], [])"
+| "tupled_rev (xs, xs') \<Longrightarrow> tupled_append (xs', [x], ys) \<Longrightarrow> tupled_rev (x#xs, ys)"
+
+code_pred tupled_rev .
+thm tupled_rev.equation
+
inductive partition :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
for f where
"partition f [] [] []"
| "f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) (x # ys) zs"
| "\<not> f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) ys (x # zs)"
-code_pred partition .
+code_pred (mode: [1], [2, 3], [1, 2], [1, 3], [1, 2, 3]) partition .
+code_pred [depth_limited] partition .
+code_pred [rpred] partition .
-thm partition.equation
+inductive tupled_partition :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'a list \<times> 'a list) \<Rightarrow> bool"
+ for f where
+ "tupled_partition f ([], [], [])"
+ | "f x \<Longrightarrow> tupled_partition f (xs, ys, zs) \<Longrightarrow> tupled_partition f (x # xs, x # ys, zs)"
+ | "\<not> f x \<Longrightarrow> tupled_partition f (xs, ys, zs) \<Longrightarrow> tupled_partition f (x # xs, ys, x # zs)"
+
+code_pred tupled_partition .
+
+thm tupled_partition.equation
-inductive member
-for xs
-where "x \<in> set xs ==> member xs x"
-
-lemma [code_pred_intros]:
- "member (x#xs') x"
-by (auto intro: member.intros)
-
-lemma [code_pred_intros]:
-"member xs x ==> member (x'#xs) x"
-by (auto intro: member.intros elim!: member.cases)
-(* strange bug must be repaired! *)
-(*
-code_pred member sorry
-*)
inductive is_even :: "nat \<Rightarrow> bool"
where
"n mod 2 = 0 \<Longrightarrow> is_even n"
@@ -88,18 +238,20 @@
case tranclp
from this converse_tranclpE[OF this(1)] show thesis by metis
qed
-(*
-code_pred (inductify_all) (rpred) tranclp .
+
+code_pred [depth_limited] tranclp .
+code_pred [rpred] tranclp .
thm tranclp.equation
thm tranclp.rpred_equation
-*)
+
inductive succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"succ 0 1"
| "succ m n \<Longrightarrow> succ (Suc m) (Suc n)"
code_pred succ .
-
+code_pred [rpred] succ .
thm succ.equation
+thm succ.rpred_equation
values 10 "{(m, n). succ n m}"
values "{m. succ 0 m}"
@@ -141,6 +293,16 @@
(While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))))
[3,5] t}"
+inductive tupled_exec :: "(com \<times> state \<times> state) \<Rightarrow> bool" where
+"tupled_exec (Skip, s, s)" |
+"tupled_exec (Ass x e, s, s[x := e(s)])" |
+"tupled_exec (c1, s1, s2) ==> tupled_exec (c2, s2, s3) ==> tupled_exec (Seq c1 c2, s1, s3)" |
+"b s ==> tupled_exec (c1, s, t) ==> tupled_exec (IF b c1 c2, s, t)" |
+"~b s ==> tupled_exec (c2, s, t) ==> tupled_exec (IF b c1 c2, s, t)" |
+"~b s ==> tupled_exec (While b c, s, s)" |
+"b s1 ==> tupled_exec (c, s1, s2) ==> tupled_exec (While b c, s2, s3) ==> tupled_exec (While b c, s1, s3)"
+
+code_pred tupled_exec .
subsection{* CCS *}
@@ -171,6 +333,17 @@
values 3 "{(a,q). step (par nil nil) a q}"
*)
+inductive tupled_step :: "(proc \<times> nat \<times> proc) \<Rightarrow> bool"
+where
+"tupled_step (pre n p, n, p)" |
+"tupled_step (p1, a, q) \<Longrightarrow> tupled_step (or p1 p2, a, q)" |
+"tupled_step (p2, a, q) \<Longrightarrow> tupled_step (or p1 p2, a, q)" |
+"tupled_step (p1, a, q) \<Longrightarrow> tupled_step (par p1 p2, a, par q p2)" |
+"tupled_step (p2, a, q) \<Longrightarrow> tupled_step (par p1 p2, a, par p1 q)"
+
+code_pred tupled_step .
+thm tupled_step.equation
+
subsection {* divmod *}
inductive divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
@@ -179,52 +352,75 @@
code_pred divmod_rel ..
-value [code] "Predicate.singleton (divmod_rel_1_2 1705 42)"
+value [code] "Predicate.the (divmod_rel_1_2 1705 42)"
section {* Executing definitions *}
definition Min
where "Min s r x \<equiv> s x \<and> (\<forall>y. r x y \<longrightarrow> x = y)"
-code_pred (inductify_all) Min .
+code_pred [inductify] Min .
subsection {* Examples with lists *}
-inductive filterP for Pa where
-"(filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) [] []"
-| "[| (res::'a list) = (y::'a) # (resa::'a list); (filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) (xt::'a list) resa; Pa y |]
-==> filterP Pa (y # xt) res"
-| "[| (filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) (xt::'a list) (res::'a list); ~ Pa (y::'a) |] ==> filterP Pa (y # xt) res"
+subsubsection {* Lexicographic order *}
+
+thm lexord_def
+code_pred [inductify] lexord .
+code_pred [inductify, rpred] lexord .
+thm lexord.equation
+thm lexord.rpred_equation
+
+inductive less_than_nat :: "nat * nat => bool"
+where
+ "less_than_nat (0, x)"
+| "less_than_nat (x, y) ==> less_than_nat (Suc x, Suc y)"
+
+code_pred less_than_nat .
+
+code_pred [depth_limited] less_than_nat .
+code_pred [rpred] less_than_nat .
+inductive test_lexord :: "nat list * nat list => bool"
+where
+ "lexord less_than_nat (xs, ys) ==> test_lexord (xs, ys)"
+
+code_pred [rpred] test_lexord .
+code_pred [depth_limited] test_lexord .
+thm test_lexord.depth_limited_equation
+thm test_lexord.rpred_equation
+
+values "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"
+values [depth_limit = 5] "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"
+(*values [random] "{xys. test_lexord xys}"*)
+(*values [depth_limit = 5 random] "{xy. lexord less_than_nat xy}"*)
(*
-code_pred (inductify_all) (rpred) filterP .
-thm filterP.rpred_equation
+lemma "(u, v) : lexord less_than_nat ==> (x @ u, y @ v) : lexord less_than_nat"
+quickcheck[generator=pred_compile]
+oops
*)
-
-code_pred (inductify_all) lexord .
-
-thm lexord.equation
-
-lemma "(u, v) : lexord r ==> (x @ u, y @ v) : lexord r"
-(*quickcheck[generator=pred_compile]*)
-oops
-
lemmas [code_pred_def] = lexn_conv lex_conv lenlex_conv
-code_pred (inductify_all) lexn .
+code_pred [inductify] lexn .
thm lexn.equation
-code_pred (inductify_all) lenlex .
+code_pred [rpred] lexn .
+
+thm lexn.rpred_equation
+
+code_pred [inductify, show_steps] lenlex .
thm lenlex.equation
-(*
-code_pred (inductify_all) (rpred) lenlex .
+
+code_pred [inductify, rpred] lenlex .
thm lenlex.rpred_equation
-*)
+
thm lists.intros
-code_pred (inductify_all) lists .
+code_pred [inductify] lists .
thm lists.equation
+section {* AVL Tree Example *}
+
datatype 'a tree = ET | MKT 'a "'a tree" "'a tree" nat
fun height :: "'a tree => nat" where
"height ET = 0"
@@ -236,40 +432,107 @@
"avl (MKT x l r h) = ((height l = height r \<or> height l = 1 + height r \<or> height r = 1+height l) \<and>
h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"
-code_pred (inductify_all) avl .
+code_pred [inductify] avl .
thm avl.equation
-lemma [code_pred_inline]: "bot_fun_inst.bot_fun == (\<lambda>(y::'a::type). False)"
-unfolding bot_fun_inst.bot_fun[symmetric] bot_bool_eq[symmetric] bot_fun_eq by simp
+code_pred [rpred] avl .
+thm avl.rpred_equation
+(*values [random] 10 "{t. avl (t::int tree)}"*)
fun set_of
where
"set_of ET = {}"
| "set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"
-fun is_ord
+fun is_ord :: "nat tree => bool"
where
"is_ord ET = True"
| "is_ord (MKT n l r h) =
((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"
-declare Un_def[code_pred_def]
-
-code_pred (inductify_all) set_of .
+code_pred (mode: [1], [1, 2]) [inductify] set_of .
thm set_of.equation
-(* FIXME *)
-(*
-code_pred (inductify_all) is_ord .
+
+code_pred [inductify] is_ord .
thm is_ord.equation
-*)
+code_pred [rpred] is_ord .
+thm is_ord.rpred_equation
+
section {* Definitions about Relations *}
-code_pred (inductify_all) converse .
+code_pred [inductify] converse .
thm converse.equation
+code_pred [inductify] rel_comp .
+thm rel_comp.equation
+code_pred [inductify] Image .
+thm Image.equation
+(*TODO: *)
+ML {* Toplevel.debug := true *}
+declare Id_on_def[unfolded UNION_def, code_pred_def]
+
+code_pred [inductify] Id_on .
+thm Id_on.equation
+code_pred [inductify] Domain .
+thm Domain.equation
+code_pred [inductify] Range .
+thm sym_def
+code_pred [inductify] Field .
+declare Sigma_def[unfolded UNION_def, code_pred_def]
+declare refl_on_def[unfolded UNION_def, code_pred_def]
+code_pred [inductify] refl_on .
+thm refl_on.equation
+code_pred [inductify] total_on .
+thm total_on.equation
+(*
+code_pred [inductify] sym .
+thm sym.equation
+*)
+code_pred [inductify] antisym .
+thm antisym.equation
+code_pred [inductify] trans .
+thm trans.equation
+code_pred [inductify] single_valued .
+thm single_valued.equation
+code_pred [inductify] inv_image .
+thm inv_image.equation
-code_pred (inductify_all) Domain .
-thm Domain.equation
+section {* List functions *}
+
+code_pred [inductify] length .
+thm size_listP.equation
+code_pred [inductify, rpred] length .
+thm size_listP.rpred_equation
+values [random] 20 "{xs. size_listP (xs::nat list) (5::nat)}"
+code_pred [inductify] concat .
+code_pred [inductify] hd .
+code_pred [inductify] tl .
+code_pred [inductify] last .
+code_pred [inductify] butlast .
+(*code_pred [inductify] listsum .*)
+code_pred [inductify] take .
+code_pred [inductify] drop .
+code_pred [inductify] zip .
+code_pred [inductify] upt .
+code_pred [inductify] remdups .
+code_pred [inductify] remove1 .
+code_pred [inductify] removeAll .
+code_pred [inductify] distinct .
+code_pred [inductify] replicate .
+code_pred [inductify] splice .
+code_pred [inductify] List.rev .
+code_pred [inductify] map .
+code_pred [inductify] foldr .
+code_pred [inductify] foldl .
+code_pred [inductify] filter .
+code_pred [inductify, rpred] filter .
+thm filterP.rpred_equation
+
+definition test where "test xs = filter (\<lambda>x. x = (1::nat)) xs"
+code_pred [inductify] test .
+thm testP.equation
+code_pred [inductify, rpred] test .
+thm testP.rpred_equation
section {* Context Free Grammar *}
@@ -283,15 +546,86 @@
| "w \<in> S\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
| "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
-code_pred (inductify_all) S\<^isub>1p .
+code_pred [inductify] S\<^isub>1p .
+code_pred [inductify, rpred] S\<^isub>1p .
+thm S\<^isub>1p.equation
+thm S\<^isub>1p.rpred_equation
-thm S\<^isub>1p.equation
+values [random] 5 "{x. S\<^isub>1p x}"
+
+inductive is_a where
+ "is_a a"
+
+inductive is_b where
+ "is_b b"
-theorem S\<^isub>1_sound:
-"w \<in> S\<^isub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
-quickcheck[generator=pred_compile]
+code_pred is_a .
+code_pred [depth_limited] is_a .
+code_pred [rpred] is_a .
+
+values [random] "{x. is_a x}"
+code_pred [depth_limited] is_b .
+code_pred [rpred] is_b .
+
+code_pred [inductify, depth_limited] filter .
+
+values [depth_limit=5] "{x. filterP is_a [a, b] x}"
+values [depth_limit=3] "{x. filterP is_b [a, b] x}"
+
+lemma "w \<in> S\<^isub>1 \<Longrightarrow> length (filter (\<lambda>x. x = a) w) = 1"
+(*quickcheck[generator=pred_compile, size=10]*)
oops
+inductive test_lemma where
+ "S\<^isub>1p w ==> filterP is_a w r1 ==> size_listP r1 r2 ==> filterP is_b w r3 ==> size_listP r3 r4 ==> r2 \<noteq> r4 ==> test_lemma w"
+(*
+code_pred [rpred] test_lemma .
+*)
+(*
+definition test_lemma' where
+ "test_lemma' w == (w \<in> S\<^isub>1 \<and> (\<not> length [x <- w. x = a] = length [x <- w. x = b]))"
+
+code_pred [inductify, rpred] test_lemma' .
+thm test_lemma'.rpred_equation
+*)
+(*thm test_lemma'.rpred_equation*)
+(*
+values [depth_limit=3 random] "{x. S\<^isub>1 x}"
+*)
+code_pred [depth_limited] is_b .
+(*
+code_pred [inductify, depth_limited] filter .
+*)
+thm filterP.intros
+thm filterP.equation
+(*
+values [depth_limit=3] "{x. filterP is_b [a, b] x}"
+find_theorems "test_lemma'_hoaux"
+code_pred [depth_limited] test_lemma'_hoaux .
+thm test_lemma'_hoaux.depth_limited_equation
+values [depth_limit=2] "{x. test_lemma'_hoaux b}"
+inductive test1 where
+ "\<not> test_lemma'_hoaux x ==> test1 x"
+code_pred test1 .
+code_pred [depth_limited] test1 .
+thm test1.depth_limited_equation
+thm test_lemma'_hoaux.depth_limited_equation
+thm test1.intros
+
+values [depth_limit=2] "{x. test1 b}"
+
+thm filterP.intros
+thm filterP.depth_limited_equation
+values [depth_limit=3] "{x. filterP test_lemma'_hoaux [a, b] x}"
+values [depth_limit=4 random] "{w. test_lemma w}"
+values [depth_limit=4 random] "{w. test_lemma' w}"
+*)
+(*
+theorem S\<^isub>1_sound:
+"w \<in> S\<^isub>1p \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+quickcheck[generator=pred_compile, size=15]
+oops
+*)
inductive_set S\<^isub>2 and A\<^isub>2 and B\<^isub>2 where
"[] \<in> S\<^isub>2"
| "w \<in> A\<^isub>2 \<Longrightarrow> b # w \<in> S\<^isub>2"
@@ -299,14 +633,18 @@
| "w \<in> S\<^isub>2 \<Longrightarrow> a # w \<in> A\<^isub>2"
| "w \<in> S\<^isub>2 \<Longrightarrow> b # w \<in> B\<^isub>2"
| "\<lbrakk>v \<in> B\<^isub>2; v \<in> B\<^isub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>2"
-(*
-code_pred (inductify_all) (rpred) S\<^isub>2 .
-ML {* Predicate_Compile_Core.intros_of @{theory} @{const_name "B\<^isub>2"} *}
-*)
+
+code_pred [inductify, rpred] S\<^isub>2 .
+thm S\<^isub>2.rpred_equation
+thm A\<^isub>2.rpred_equation
+thm B\<^isub>2.rpred_equation
+
+values [random] 10 "{x. S\<^isub>2 x}"
+
theorem S\<^isub>2_sound:
"w \<in> S\<^isub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
(*quickcheck[generator=SML]*)
-quickcheck[generator=pred_compile, size=15, iterations=100]
+(*quickcheck[generator=pred_compile, size=15, iterations=1]*)
oops
inductive_set S\<^isub>3 and A\<^isub>3 and B\<^isub>3 where
@@ -317,23 +655,35 @@
| "w \<in> S\<^isub>3 \<Longrightarrow> b # w \<in> B\<^isub>3"
| "\<lbrakk>v \<in> B\<^isub>3; w \<in> B\<^isub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>3"
+code_pred [inductify] S\<^isub>3 .
+thm S\<^isub>3.equation
+
+values 10 "{x. S\<^isub>3 x}"
(*
-code_pred (inductify_all) S\<^isub>3 .
-*)
theorem S\<^isub>3_sound:
"w \<in> S\<^isub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[generator=pred_compile, size=10, iterations=1]
oops
-
+*)
lemma "\<not> (length w > 2) \<or> \<not> (length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b])"
-quickcheck[size=10, generator = pred_compile]
+(*quickcheck[size=10, generator = pred_compile]*)
oops
+(*
+inductive test
+where
+ "length [x \<leftarrow> w. a = x] = length [x \<leftarrow> w. x = b] ==> test w"
+ML {* @{term "[x \<leftarrow> w. x = a]"} *}
+code_pred (inductify_all) test .
+thm test.equation
+*)
+(*
theorem S\<^isub>3_complete:
-"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>3"
+"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. b = x] \<longrightarrow> w \<in> S\<^isub>3"
(*quickcheck[generator=SML]*)
quickcheck[generator=pred_compile, size=10, iterations=100]
oops
+*)
inductive_set S\<^isub>4 and A\<^isub>4 and B\<^isub>4 where
"[] \<in> S\<^isub>4"
@@ -343,15 +693,15 @@
| "\<lbrakk>v \<in> A\<^isub>4; w \<in> A\<^isub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^isub>4"
| "w \<in> S\<^isub>4 \<Longrightarrow> b # w \<in> B\<^isub>4"
| "\<lbrakk>v \<in> B\<^isub>4; w \<in> B\<^isub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>4"
-
+(*
theorem S\<^isub>4_sound:
"w \<in> S\<^isub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[generator = pred_compile, size=2, iterations=1]
oops
-
+*)
theorem S\<^isub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>4"
-quickcheck[generator = pred_compile, size=5, iterations=1]
+(*quickcheck[generator = pred_compile, size=5, iterations=1]*)
oops
theorem S\<^isub>4_A\<^isub>4_B\<^isub>4_sound_and_complete:
@@ -361,8 +711,8 @@
(*quickcheck[generator = pred_compile, size=5, iterations=1]*)
oops
+section {* Lambda *}
-section {* Lambda *}
datatype type =
Atom nat
| Fun type type (infixr "\<Rightarrow>" 200)
@@ -378,15 +728,15 @@
"[]\<langle>i\<rangle> = None"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"
-(*
+
inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
where
"nth_el' (x # xs) 0 x"
| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"
-*)
+
inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
- Var [intro!]: "nth_el env x = Some T \<Longrightarrow> env \<turnstile> Var x : T"
+ Var [intro!]: "nth_el' env x T \<Longrightarrow> env \<turnstile> Var x : T"
| Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
(* | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U" *)
| App [intro!]: "env \<turnstile> s : U \<Rightarrow> T \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"
@@ -414,22 +764,8 @@
| abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"
lemma "Gamma \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> Gamma \<turnstile> t' : T"
-quickcheck[generator = pred_compile, size = 10, iterations = 1000]
+(*quickcheck[generator = pred_compile, size = 10, iterations = 1]*)
oops
-(* FIXME *)
-(*
-inductive test for P where
-"[| filter P vs = res |]
-==> test P vs res"
-
-code_pred test .
-*)
-(*
-export_code test_for_1_yields_1_2 in SML file -
-code_pred (inductify_all) (rpred) test .
-
-thm test.equation
-*)
lemma filter_eq_ConsD:
"filter P ys = x#xs \<Longrightarrow>--- a/src/HOL/ex/RPred.thy Tue Oct 27 12:59:57 2009 +0000
+++ b/src/HOL/ex/RPred.thy Tue Oct 27 14:46:03 2009 +0000
@@ -2,7 +2,7 @@
imports Quickcheck Random Predicate
begin
-types 'a rpred = "Random.seed \<Rightarrow> ('a Predicate.pred \<times> Random.seed)"
+types 'a "rpred" = "Random.seed \<Rightarrow> ('a Predicate.pred \<times> Random.seed)"
section {* The RandomPred Monad *}
@@ -33,9 +33,9 @@
(* Missing a good definition for negation: not_rpred *)
-definition not_rpred :: "unit Predicate.pred \<Rightarrow> unit rpred"
+definition not_rpred :: "unit rpred \<Rightarrow> unit rpred"
where
- "not_rpred = Pair o Predicate.not_pred"
+ "not_rpred P = (\<lambda>s. let (P', s') = P s in if Predicate.eval P' () then (Orderings.bot, s') else (Predicate.single (), s'))"
definition lift_pred :: "'a Predicate.pred \<Rightarrow> 'a rpred"
where
@@ -44,9 +44,9 @@
definition lift_random :: "(Random.seed \<Rightarrow> ('a \<times> (unit \<Rightarrow> term)) \<times> Random.seed) \<Rightarrow> 'a rpred"
where "lift_random g = scomp g (Pair o (Predicate.single o fst))"
-definition map_rpred :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a rpred \<Rightarrow> 'b rpred)"
-where "map_rpred f P = bind P (return o f)"
+definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a rpred \<Rightarrow> 'b rpred)"
+ where "map f P = bind P (return o f)"
-hide (open) const return bind supp
+hide (open) const return bind supp map
end
\ No newline at end of file--- a/src/Provers/order.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Provers/order.ML Tue Oct 27 14:46:03 2009 +0000
@@ -307,7 +307,7 @@
(* *)
(* ************************************************************************ *)
-fun mkasm_partial decomp (less_thms : less_arith) sign (t, n) =
+fun mkasm_partial decomp (less_thms : less_arith) sign (n, t) =
case decomp sign t of
SOME (x, rel, y) => (case rel of
"<" => if (x aconv y) then raise Contr (Thm ([Asm n], #less_reflE less_thms))
@@ -335,7 +335,7 @@
(* *)
(* ************************************************************************ *)
-fun mkasm_linear decomp (less_thms : less_arith) sign (t, n) =
+fun mkasm_linear decomp (less_thms : less_arith) sign (n, t) =
case decomp sign t of
SOME (x, rel, y) => (case rel of
"<" => if (x aconv y) then raise Contr (Thm ([Asm n], #less_reflE less_thms))
@@ -1228,7 +1228,7 @@
val rfrees = map Free (Term.rename_wrt_term A (Logic.strip_params A));
val Hs = map prop_of prems @ map (fn H => subst_bounds (rfrees, H)) (Logic.strip_assums_hyp A)
val C = subst_bounds (rfrees, Logic.strip_assums_concl A)
- val lesss = flat (ListPair.map (mkasm decomp less_thms thy) (Hs, 0 upto (length Hs - 1)))
+ val lesss = flat (map_index (mkasm decomp less_thms thy) Hs)
val prfs = gen_solve mkconcl thy (lesss, C);
val (subgoals, prf) = mkconcl decomp less_thms thy C;
in--- a/src/Pure/Concurrent/simple_thread.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Concurrent/simple_thread.ML Tue Oct 27 14:46:03 2009 +0000
@@ -15,7 +15,7 @@
struct
fun fork interrupts body =
- Thread.fork (fn () => exception_trace (fn () => body ()),
+ Thread.fork (fn () => exception_trace (fn () => body () handle Exn.Interrupt => ()),
if interrupts then Multithreading.public_interrupts else Multithreading.no_interrupts);
fun interrupt thread = Thread.interrupt thread handle Thread _ => ();--- a/src/Pure/General/binding.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/binding.ML Tue Oct 27 14:46:03 2009 +0000
@@ -10,7 +10,7 @@
signature BINDING =
sig
type binding
- val dest: binding -> (string * bool) list * bstring
+ val dest: binding -> bool * (string * bool) list * bstring
val make: bstring * Position.T -> binding
val pos_of: binding -> Position.T
val name: bstring -> binding
@@ -27,6 +27,7 @@
val prefix_of: binding -> (string * bool) list
val map_prefix: ((string * bool) list -> (string * bool) list) -> binding -> binding
val prefix: bool -> string -> binding -> binding
+ val conceal: binding -> binding
val str_of: binding -> string
end;
@@ -38,19 +39,21 @@
(* datatype *)
abstype binding = Binding of
- {prefix: (string * bool) list, (*system prefix*)
+ {conceal: bool, (*internal -- for foundational purposes only*)
+ prefix: (string * bool) list, (*system prefix*)
qualifier: (string * bool) list, (*user qualifier*)
name: bstring, (*base name*)
pos: Position.T} (*source position*)
with
-fun make_binding (prefix, qualifier, name, pos) =
- Binding {prefix = prefix, qualifier = qualifier, name = name, pos = pos};
+fun make_binding (conceal, prefix, qualifier, name, pos) =
+ Binding {conceal = conceal, prefix = prefix, qualifier = qualifier, name = name, pos = pos};
-fun map_binding f (Binding {prefix, qualifier, name, pos}) =
- make_binding (f (prefix, qualifier, name, pos));
+fun map_binding f (Binding {conceal, prefix, qualifier, name, pos}) =
+ make_binding (f (conceal, prefix, qualifier, name, pos));
-fun dest (Binding {prefix, qualifier, name, ...}) = (prefix @ qualifier, name);
+fun dest (Binding {conceal, prefix, qualifier, name, ...}) =
+ (conceal, prefix @ qualifier, name);
@@ -58,7 +61,7 @@
(* name and position *)
-fun make (name, pos) = make_binding ([], [], name, pos);
+fun make (name, pos) = make_binding (false, [], [], name, pos);
fun name name = make (name, Position.none);
fun pos_of (Binding {pos, ...}) = pos;
@@ -66,7 +69,10 @@
fun eq_name (b, b') = name_of b = name_of b';
-fun map_name f = map_binding (fn (prefix, qualifier, name, pos) => (prefix, qualifier, f name, pos));
+fun map_name f =
+ map_binding (fn (conceal, prefix, qualifier, name, pos) =>
+ (conceal, prefix, qualifier, f name, pos));
+
val prefix_name = map_name o prefix;
val suffix_name = map_name o suffix;
@@ -77,13 +83,14 @@
(* user qualifier *)
fun qualify _ "" = I
- | qualify mandatory qual = map_binding (fn (prefix, qualifier, name, pos) =>
- (prefix, (qual, mandatory) :: qualifier, name, pos));
+ | qualify mandatory qual =
+ map_binding (fn (conceal, prefix, qualifier, name, pos) =>
+ (conceal, prefix, (qual, mandatory) :: qualifier, name, pos));
fun qualified_name "" = empty
| qualified_name s =
let val (qualifier, name) = split_last (Long_Name.explode s)
- in make_binding ([], map (rpair false) qualifier, name, Position.none) end;
+ in make_binding (false, [], map (rpair false) qualifier, name, Position.none) end;
fun qualified_name_of (b as Binding {qualifier, name, ...}) =
if is_empty b then ""
@@ -94,13 +101,21 @@
fun prefix_of (Binding {prefix, ...}) = prefix;
-fun map_prefix f = map_binding (fn (prefix, qualifier, name, pos) =>
- (f prefix, qualifier, name, pos));
+fun map_prefix f =
+ map_binding (fn (conceal, prefix, qualifier, name, pos) =>
+ (conceal, f prefix, qualifier, name, pos));
fun prefix _ "" = I
| prefix mandatory prfx = map_prefix (cons (prfx, mandatory));
+(* conceal *)
+
+val conceal =
+ map_binding (fn (_, prefix, qualifier, name, pos) =>
+ (true, prefix, qualifier, name, pos));
+
+
(* str_of *)
fun str_of binding =--- a/src/Pure/General/markup.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/markup.ML Tue Oct 27 14:46:03 2009 +0000
@@ -13,11 +13,11 @@
val nameN: string
val name: string -> T -> T
val bindingN: string val binding: string -> T
- val groupN: string
- val theory_nameN: string
val kindN: string
val internalK: string
- val property_internal: Properties.property
+ val entityN: string val entity: string -> T
+ val defN: string
+ val refN: string
val lineN: string
val columnN: string
val offsetN: string
@@ -149,16 +149,20 @@
val (bindingN, binding) = markup_string "binding" nameN;
-val groupN = "group";
-val theory_nameN = "theory_name";
-
(* kind *)
val kindN = "kind";
val internalK = "internal";
-val property_internal = (kindN, internalK);
+
+
+(* formal entities *)
+
+val (entityN, entity) = markup_string "entity" nameN;
+
+val defN = "def";
+val refN = "ref";
(* position *)
--- a/src/Pure/General/markup.scala Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/markup.scala Tue Oct 27 14:46:03 2009 +0000
@@ -15,6 +15,13 @@
val KIND = "kind"
+ /* formal entities */
+
+ val ENTITY = "entity"
+ val DEF = "def"
+ val REF = "ref"
+
+
/* position */
val LINE = "line"
--- a/src/Pure/General/name_space.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/name_space.ML Tue Oct 27 14:46:03 2009 +0000
@@ -20,33 +20,40 @@
val hidden: string -> string
val is_hidden: string -> bool
type T
- val empty: T
+ val empty: string -> T
+ val kind_of: T -> string
+ val the_entry: T -> string ->
+ {concealed: bool, group: serial option, theory_name: string, pos: Position.T, id: serial}
+ val is_concealed: T -> string -> bool
val intern: T -> xstring -> string
- val extern: T -> string -> xstring
val extern_flags: {long_names: bool, short_names: bool, unique_names: bool} ->
T -> string -> xstring
+ val extern: T -> string -> xstring
val hide: bool -> string -> T -> T
val merge: T * T -> T
type naming
val default_naming: naming
- val declare: naming -> binding -> T -> string * T
- val full_name: naming -> binding -> string
- val external_names: naming -> string -> string list
+ val conceal: naming -> naming
+ val set_group: serial -> naming -> naming
+ val set_theory_name: string -> naming -> naming
val add_path: string -> naming -> naming
val root_path: naming -> naming
val parent_path: naming -> naming
val mandatory_path: string -> naming -> naming
+ val full_name: naming -> binding -> string
+ val external_names: naming -> string -> string list
+ val declare: bool -> naming -> binding -> T -> string * T
type 'a table = T * 'a Symtab.table
- val define: naming -> binding * 'a -> 'a table -> string * 'a table (*exception Symtab.DUP*)
- val empty_table: 'a table
- val merge_tables: ('a * 'a -> bool) -> 'a table * 'a table -> 'a table (*exception Symtab.DUP*)
- val join_tables: (string -> 'a * 'a -> 'a) (*exception Symtab.DUP/Symtab.SAME*) ->
- 'a table * 'a table -> 'a table (*exception Symtab.DUP*)
+ val define: bool -> naming -> binding * 'a -> 'a table -> string * 'a table
+ val empty_table: string -> 'a table
+ val merge_tables: 'a table * 'a table -> 'a table
+ val join_tables: (string -> 'a * 'a -> 'a) (*Symtab.SAME*) ->
+ 'a table * 'a table -> 'a table
val dest_table: 'a table -> (string * 'a) list
val extern_table: 'a table -> (xstring * 'a) list
end;
-structure NameSpace: NAME_SPACE =
+structure Name_Space: NAME_SPACE =
struct
@@ -58,33 +65,76 @@
val is_hidden = String.isPrefix "??.";
+(* datatype entry *)
+
+type entry =
+ {externals: xstring list,
+ concealed: bool,
+ group: serial option,
+ theory_name: string,
+ pos: Position.T,
+ id: serial};
+
+fun str_of_entry def (name, {pos, id, ...}: entry) =
+ let
+ val occurrence = (if def then Markup.defN else Markup.refN, string_of_int id);
+ val props = occurrence :: Position.properties_of pos;
+ in Markup.markup (Markup.properties props (Markup.entity name)) name end;
+
+fun err_dup kind entry1 entry2 =
+ error ("Duplicate " ^ kind ^ " declaration " ^
+ quote (str_of_entry true entry1) ^ " vs. " ^ quote (str_of_entry true entry2));
+
+
(* datatype T *)
datatype T =
- NameSpace of
- (string list * string list) Symtab.table * (*internals, hidden internals*)
- xstring list Symtab.table; (*externals*)
+ Name_Space of
+ {kind: string,
+ internals: (string list * string list) Symtab.table, (*visible, hidden*)
+ entries: entry Symtab.table};
+
+fun make_name_space (kind, internals, entries) =
+ Name_Space {kind = kind, internals = internals, entries = entries};
+
+fun map_name_space f (Name_Space {kind = kind, internals = internals, entries = entries}) =
+ make_name_space (f (kind, internals, entries));
+
+fun map_internals f xname = map_name_space (fn (kind, internals, entries) =>
+ (kind, Symtab.map_default (xname, ([], [])) f internals, entries));
+
-val empty = NameSpace (Symtab.empty, Symtab.empty);
+fun empty kind = make_name_space (kind, Symtab.empty, Symtab.empty);
+
+fun kind_of (Name_Space {kind, ...}) = kind;
-fun lookup (NameSpace (tab, _)) xname =
- (case Symtab.lookup tab xname of
+fun the_entry (Name_Space {kind, entries, ...}) name =
+ (case Symtab.lookup entries name of
+ NONE => error ("Unknown " ^ kind ^ " " ^ quote name)
+ | SOME {concealed, group, theory_name, pos, id, ...} =>
+ {concealed = concealed, group = group, theory_name = theory_name, pos = pos, id = id});
+
+fun is_concealed space name = #concealed (the_entry space name);
+
+
+(* name accesses *)
+
+fun lookup (Name_Space {internals, ...}) xname =
+ (case Symtab.lookup internals xname of
NONE => (xname, true)
| SOME ([], []) => (xname, true)
| SOME ([name], _) => (name, true)
| SOME (name :: _, _) => (name, false)
| SOME ([], name' :: _) => (hidden name', true));
-fun get_accesses (NameSpace (_, xtab)) name =
- (case Symtab.lookup xtab name of
+fun get_accesses (Name_Space {entries, ...}) name =
+ (case Symtab.lookup entries name of
NONE => [name]
- | SOME xnames => xnames);
+ | SOME {externals, ...} => externals);
-fun put_accesses name xnames (NameSpace (tab, xtab)) =
- NameSpace (tab, Symtab.update (name, xnames) xtab);
-
-fun valid_accesses (NameSpace (tab, _)) name = Symtab.fold (fn (xname, (names, _)) =>
- if not (null names) andalso hd names = name then cons xname else I) tab [];
+fun valid_accesses (Name_Space {internals, ...}) name =
+ Symtab.fold (fn (xname, (names, _)) =>
+ if not (null names) andalso hd names = name then cons xname else I) internals [];
(* intern and extern *)
@@ -116,21 +166,13 @@
unique_names = ! unique_names} space name;
-(* basic operations *)
-
-local
-
-fun map_space f xname (NameSpace (tab, xtab)) =
- NameSpace (Symtab.map_default (xname, ([], [])) f tab, xtab);
+(* modify internals *)
-in
-
-val del_name = map_space o apfst o remove (op =);
-fun del_name_extra name = map_space (apfst (fn [] => [] | x :: xs => x :: remove (op =) name xs));
-val add_name = map_space o apfst o update (op =);
-val add_name' = map_space o apsnd o update (op =);
-
-end;
+val del_name = map_internals o apfst o remove (op =);
+fun del_name_extra name =
+ map_internals (apfst (fn [] => [] | x :: xs => x :: remove (op =) name xs));
+val add_name = map_internals o apfst o update (op =);
+val add_name' = map_internals o apsnd o update (op =);
(* hide *)
@@ -152,17 +194,24 @@
(* merge *)
-fun merge (NameSpace (tab1, xtab1), NameSpace (tab2, xtab2)) =
+fun merge
+ (Name_Space {kind = kind1, internals = internals1, entries = entries1},
+ Name_Space {kind = kind2, internals = internals2, entries = entries2}) =
let
- val tab' = (tab1, tab2) |> Symtab.join
+ val kind' =
+ if kind1 = kind2 then kind1
+ else error ("Attempt to merge different kinds of name spaces " ^
+ quote kind1 ^ " vs. " ^ quote kind2);
+ val internals' = (internals1, internals2) |> Symtab.join
(K (fn ((names1, names1'), (names2, names2')) =>
- if pointer_eq (names1, names2) andalso pointer_eq (names1', names2') then raise Symtab.SAME
+ if pointer_eq (names1, names2) andalso pointer_eq (names1', names2')
+ then raise Symtab.SAME
else (Library.merge (op =) (names1, names2), Library.merge (op =) (names1', names2'))));
- val xtab' = (xtab1, xtab2) |> Symtab.join
- (K (fn xnames =>
- if pointer_eq xnames then raise Symtab.SAME
- else (Library.merge (op =) xnames)));
- in NameSpace (tab', xtab') end;
+ val entries' = (entries1, entries2) |> Symtab.join
+ (fn name => fn (entry1, entry2) =>
+ if #id entry1 = #id entry2 then raise Symtab.SAME
+ else err_dup kind' (name, entry1) (name, entry2));
+ in make_name_space (kind', internals', entries') end;
@@ -170,36 +219,59 @@
(* datatype naming *)
-datatype naming = Naming of (string * bool) list;
-fun map_naming f (Naming path) = Naming (f path);
+datatype naming = Naming of
+ {conceal: bool,
+ group: serial option,
+ theory_name: string,
+ path: (string * bool) list};
-val default_naming = Naming [];
+fun make_naming (conceal, group, theory_name, path) =
+ Naming {conceal = conceal, group = group, theory_name = theory_name, path = path};
+
+fun map_naming f (Naming {conceal, group, theory_name, path}) =
+ make_naming (f (conceal, group, theory_name, path));
+
+fun map_path f = map_naming (fn (conceal, group, theory_name, path) =>
+ (conceal, group, theory_name, f path));
+
-fun add_path elems = map_naming (fn path => path @ [(elems, false)]);
-val root_path = map_naming (fn _ => []);
-val parent_path = map_naming (perhaps (try (#1 o split_last)));
-fun mandatory_path elems = map_naming (fn path => path @ [(elems, true)]);
+val default_naming = make_naming (false, NONE, "", []);
+
+val conceal = map_naming (fn (_, group, theory_name, path) =>
+ (true, group, theory_name, path));
+
+fun set_group group = map_naming (fn (conceal, _, theory_name, path) =>
+ (conceal, SOME group, theory_name, path));
+
+fun set_theory_name theory_name = map_naming (fn (conceal, group, _, path) =>
+ (conceal, group, theory_name, path));
+
+fun add_path elems = map_path (fn path => path @ [(elems, false)]);
+val root_path = map_path (fn _ => []);
+val parent_path = map_path (perhaps (try (#1 o split_last)));
+fun mandatory_path elems = map_path (fn path => path @ [(elems, true)]);
(* full name *)
fun err_bad binding = error ("Bad name binding " ^ quote (Binding.str_of binding));
-fun name_spec (Naming path) binding =
+fun name_spec (Naming {conceal = conceal1, path, ...}) binding =
let
- val (prefix, name) = Binding.dest binding;
+ val (conceal2, prefix, name) = Binding.dest binding;
val _ = Long_Name.is_qualified name andalso err_bad binding;
+ val concealed = conceal1 orelse conceal2;
val spec1 = maps (fn (a, b) => map (rpair b) (Long_Name.explode a)) (path @ prefix);
val spec2 = if name = "" then [] else [(name, true)];
val spec = spec1 @ spec2;
val _ =
exists (fn (a, _) => a = "" orelse a = "??" orelse exists_string (fn s => s = "\"") a) spec
andalso err_bad binding;
- in if null spec2 then [] else spec end;
+ in (concealed, if null spec2 then [] else spec) end;
-fun full naming = name_spec naming #> map fst;
-fun full_name naming = full naming #> Long_Name.implode;
+fun full_name naming =
+ name_spec naming #> #2 #> map #1 #> Long_Name.implode;
(* accesses *)
@@ -215,7 +287,7 @@
fun accesses naming binding =
let
- val spec = name_spec naming binding;
+ val spec = #2 (name_spec naming binding);
val sfxs = mandatory_suffixes spec;
val pfxs = mandatory_prefixes spec;
in pairself (map Long_Name.implode) (sfxs @ pfxs, sfxs) end;
@@ -225,13 +297,32 @@
(* declaration *)
-fun declare naming binding space =
+fun new_entry strict entry =
+ map_name_space (fn (kind, internals, entries) =>
+ let
+ val entries' =
+ (if strict then Symtab.update_new else Symtab.update) entry entries
+ handle Symtab.DUP dup =>
+ err_dup kind (dup, the (Symtab.lookup entries dup)) entry;
+ in (kind, internals, entries') end);
+
+fun declare strict naming binding space =
let
- val names = full naming binding;
- val name = Long_Name.implode names;
+ val Naming {group, theory_name, ...} = naming;
+ val (concealed, spec) = name_spec naming binding;
+ val (accs, accs') = accesses naming binding;
+
+ val name = Long_Name.implode (map fst spec);
val _ = name = "" andalso err_bad binding;
- val (accs, accs') = accesses naming binding;
- val space' = space |> fold (add_name name) accs |> put_accesses name accs';
+
+ val entry =
+ {externals = accs',
+ concealed = concealed,
+ group = group,
+ theory_name = theory_name,
+ pos = Position.default (Binding.pos_of binding),
+ id = serial ()};
+ val space' = space |> fold (add_name name) accs |> new_entry strict (name, entry);
in (name, space') end;
@@ -240,14 +331,14 @@
type 'a table = T * 'a Symtab.table;
-fun define naming (binding, x) (space, tab) =
- let val (name, space') = declare naming binding space
- in (name, (space', Symtab.update_new (name, x) tab)) end;
+fun define strict naming (binding, x) (space, tab) =
+ let val (name, space') = declare strict naming binding space
+ in (name, (space', Symtab.update (name, x) tab)) end;
-val empty_table = (empty, Symtab.empty);
+fun empty_table kind = (empty kind, Symtab.empty);
-fun merge_tables eq ((space1, tab1), (space2, tab2)) =
- (merge (space1, space2), Symtab.merge eq (tab1, tab2));
+fun merge_tables ((space1, tab1), (space2, tab2)) =
+ (merge (space1, space2), Symtab.merge (K true) (tab1, tab2));
fun join_tables f ((space1, tab1), (space2, tab2)) =
(merge (space1, space2), Symtab.join f (tab1, tab2));
@@ -261,6 +352,6 @@
end;
-structure Basic_Name_Space: BASIC_NAME_SPACE = NameSpace;
+structure Basic_Name_Space: BASIC_NAME_SPACE = Name_Space;
open Basic_Name_Space;
--- a/src/Pure/General/position.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/position.ML Tue Oct 27 14:46:03 2009 +0000
@@ -37,6 +37,7 @@
val range: T -> T -> range
val thread_data: unit -> T
val setmp_thread_data: T -> ('a -> 'b) -> 'a -> 'b
+ val default: T -> T
end;
structure Position: POSITION =
@@ -178,4 +179,8 @@
end;
+fun default pos =
+ if pos = none then thread_data ()
+ else pos;
+
end;--- a/src/Pure/General/table.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/General/table.ML Tue Oct 27 14:46:03 2009 +0000
@@ -54,8 +54,7 @@
val update_list: ('a * 'a -> bool) -> key * 'a -> 'a list table -> 'a list table
val make_list: (key * 'a) list -> 'a list table
val dest_list: 'a list table -> (key * 'a) list
- val merge_list: ('a * 'a -> bool) ->
- 'a list table * 'a list table -> 'a list table (*exception DUP*)
+ val merge_list: ('a * 'a -> bool) -> 'a list table * 'a list table -> 'a list table
end;
functor Table(Key: KEY): TABLE =--- a/src/Pure/Isar/attrib.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/attrib.ML Tue Oct 27 14:46:03 2009 +0000
@@ -67,35 +67,33 @@
structure Attributes = TheoryDataFun
(
- type T = (((src -> attribute) * string) * stamp) NameSpace.table;
- val empty = NameSpace.empty_table;
+ type T = ((src -> attribute) * string) Name_Space.table;
+ val empty : T = Name_Space.empty_table "attribute";
val copy = I;
val extend = I;
- fun merge _ tables : T = NameSpace.merge_tables (eq_snd (op =)) tables handle Symtab.DUP dup =>
- error ("Attempt to merge different versions of attribute " ^ quote dup);
+ fun merge _ tables : T = Name_Space.merge_tables tables;
);
fun print_attributes thy =
let
val attribs = Attributes.get thy;
- fun prt_attr (name, ((_, comment), _)) = Pretty.block
+ fun prt_attr (name, (_, comment)) = Pretty.block
[Pretty.str (name ^ ":"), Pretty.brk 2, Pretty.str comment];
in
- [Pretty.big_list "attributes:" (map prt_attr (NameSpace.extern_table attribs))]
+ [Pretty.big_list "attributes:" (map prt_attr (Name_Space.extern_table attribs))]
|> Pretty.chunks |> Pretty.writeln
end;
-fun add_attribute name att comment thy = thy |> Attributes.map (fn atts =>
- #2 (NameSpace.define (Sign.naming_of thy) (name, ((att, comment), stamp ())) atts)
- handle Symtab.DUP dup => error ("Duplicate declaration of attribute " ^ quote dup));
+fun add_attribute name att comment thy = thy
+ |> Attributes.map (#2 o Name_Space.define true (Sign.naming_of thy) (name, (att, comment)));
(* name space *)
-val intern = NameSpace.intern o #1 o Attributes.get;
+val intern = Name_Space.intern o #1 o Attributes.get;
val intern_src = Args.map_name o intern;
-val extern = NameSpace.extern o #1 o Attributes.get o ProofContext.theory_of;
+val extern = Name_Space.extern o #1 o Attributes.get o ProofContext.theory_of;
(* pretty printing *)
@@ -117,7 +115,7 @@
let val ((name, _), pos) = Args.dest_src src in
(case Symtab.lookup attrs name of
NONE => error ("Unknown attribute: " ^ quote name ^ Position.str_of pos)
- | SOME ((att, _), _) => (Position.report (Markup.attribute name) pos; att src))
+ | SOME (att, _) => (Position.report (Markup.attribute name) pos; att src))
end;
in attr end;
@@ -340,7 +338,7 @@
Pretty.block [Pretty.str (name ^ ": " ^ Config.print_type value ^ " ="), Pretty.brk 1,
Pretty.str (Config.print_value value)]
end;
- val configs = NameSpace.extern_table (#1 (Attributes.get thy), Configs.get thy);
+ val configs = Name_Space.extern_table (#1 (Attributes.get thy), Configs.get thy);
in Pretty.writeln (Pretty.big_list "configuration options" (map prt configs)) end;
--- a/src/Pure/Isar/class.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/class.ML Tue Oct 27 14:46:03 2009 +0000
@@ -237,7 +237,7 @@
val syn = (the_default NoSyn o AList.lookup Binding.eq_name global_syntax) b;
in
thy
- |> Sign.declare_const [] ((b, ty0), syn)
+ |> Sign.declare_const ((b, ty0), syn)
|> snd
|> pair ((Name.of_binding b, ty), (c, ty'))
end;--- a/src/Pure/Isar/class_target.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/class_target.ML Tue Oct 27 14:46:03 2009 +0000
@@ -21,10 +21,8 @@
val begin: class list -> sort -> Proof.context -> Proof.context
val init: class -> theory -> Proof.context
- val declare: class -> Properties.T
- -> (binding * mixfix) * term -> theory -> theory
- val abbrev: class -> Syntax.mode -> Properties.T
- -> (binding * mixfix) * term -> theory -> theory
+ val declare: class -> (binding * mixfix) * term -> theory -> theory
+ val abbrev: class -> Syntax.mode -> (binding * mixfix) * term -> theory -> theory
val class_prefix: string -> string
val refresh_syntax: class -> Proof.context -> Proof.context
val redeclare_operations: theory -> sort -> Proof.context -> Proof.context
@@ -325,7 +323,7 @@
val class_prefix = Logic.const_of_class o Long_Name.base_name;
-fun declare class pos ((c, mx), dict) thy =
+fun declare class ((c, mx), dict) thy =
let
val morph = morphism thy class;
val b = Morphism.binding morph c;
@@ -337,7 +335,7 @@
|> map_types Type.strip_sorts;
in
thy
- |> Sign.declare_const pos ((b, Type.strip_sorts ty'), mx)
+ |> Sign.declare_const ((b, Type.strip_sorts ty'), mx)
|> snd
|> Thm.add_def false false (b_def, def_eq)
|>> Thm.varifyT
@@ -347,7 +345,7 @@
|> Sign.add_const_constraint (c', SOME ty')
end;
-fun abbrev class prmode pos ((c, mx), rhs) thy =
+fun abbrev class prmode ((c, mx), rhs) thy =
let
val morph = morphism thy class;
val unchecks = these_unchecks thy [class];
@@ -358,7 +356,7 @@
val rhs'' = map_types Logic.varifyT rhs';
in
thy
- |> Sign.add_abbrev (#1 prmode) pos (b, rhs'')
+ |> Sign.add_abbrev (#1 prmode) (b, rhs'')
|> snd
|> Sign.add_const_constraint (c', SOME ty')
|> Sign.notation true prmode [(Const (c', ty'), mx)]--- a/src/Pure/Isar/expression.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/expression.ML Tue Oct 27 14:46:03 2009 +0000
@@ -639,7 +639,7 @@
val ([pred_def], defs_thy) =
thy
|> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
- |> Sign.declare_const [] ((bname, predT), NoSyn) |> snd
+ |> Sign.declare_const ((bname, predT), NoSyn) |> snd
|> PureThy.add_defs false
[((Binding.map_name Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])];
val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;--- a/src/Pure/Isar/isar_cmd.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/isar_cmd.ML Tue Oct 27 14:46:03 2009 +0000
@@ -400,7 +400,7 @@
val {classes = (space, algebra), ...} = Type.rep_tsig (Sign.tsig_of thy);
val {classes, ...} = Sorts.rep_algebra algebra;
fun entry (c, (i, (_, cs))) =
- (i, {name = NameSpace.extern space c, ID = c, parents = cs,
+ (i, {name = Name_Space.extern space c, ID = c, parents = cs,
dir = "", unfold = true, path = ""});
val gr =
Graph.fold (cons o entry) classes []--- a/src/Pure/Isar/local_theory.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/local_theory.ML Tue Oct 27 14:46:03 2009 +0000
@@ -9,22 +9,21 @@
signature LOCAL_THEORY =
sig
type operations
- val group_of: local_theory -> string
- val group_properties_of: local_theory -> Properties.T
- val group_position_of: local_theory -> Properties.T
- val set_group: string -> local_theory -> local_theory
+ val affirm: local_theory -> local_theory
+ val naming_of: local_theory -> Name_Space.naming
+ val full_name: local_theory -> binding -> string
+ val map_naming: (Name_Space.naming -> Name_Space.naming) -> local_theory -> local_theory
+ val conceal: local_theory -> local_theory
+ val set_group: serial -> local_theory -> local_theory
val target_of: local_theory -> Proof.context
val raw_theory_result: (theory -> 'a * theory) -> local_theory -> 'a * local_theory
val raw_theory: (theory -> theory) -> local_theory -> local_theory
val checkpoint: local_theory -> local_theory
- val full_naming: local_theory -> NameSpace.naming
- val full_name: local_theory -> binding -> string
val theory_result: (theory -> 'a * theory) -> local_theory -> 'a * local_theory
val theory: (theory -> theory) -> local_theory -> local_theory
val target_result: (Proof.context -> 'a * Proof.context) -> local_theory -> 'a * local_theory
val target: (Proof.context -> Proof.context) -> local_theory -> local_theory
val map_contexts: (Context.generic -> Context.generic) -> local_theory -> local_theory
- val affirm: local_theory -> local_theory
val pretty: local_theory -> Pretty.T list
val abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory ->
(term * term) * local_theory
@@ -71,13 +70,14 @@
exit: local_theory -> Proof.context};
datatype lthy = LThy of
- {group: string,
+ {naming: Name_Space.naming,
theory_prefix: string,
operations: operations,
target: Proof.context};
-fun make_lthy (group, theory_prefix, operations, target) =
- LThy {group = group, theory_prefix = theory_prefix, operations = operations, target = target};
+fun make_lthy (naming, theory_prefix, operations, target) =
+ LThy {naming = naming, theory_prefix = theory_prefix,
+ operations = operations, target = target};
(* context data *)
@@ -94,33 +94,30 @@
| SOME (LThy data) => data);
fun map_lthy f lthy =
- let val {group, theory_prefix, operations, target} = get_lthy lthy
- in Data.put (SOME (make_lthy (f (group, theory_prefix, operations, target)))) lthy end;
+ let val {naming, theory_prefix, operations, target} = get_lthy lthy
+ in Data.put (SOME (make_lthy (f (naming, theory_prefix, operations, target)))) lthy end;
+
+val affirm = tap get_lthy;
-(* group *)
+(* naming *)
-val group_of = #group o get_lthy;
+val naming_of = #naming o get_lthy;
+val full_name = Name_Space.full_name o naming_of;
-fun group_properties_of lthy =
- (case group_of lthy of
- "" => []
- | group => [(Markup.groupN, group)]);
+fun map_naming f = map_lthy (fn (naming, theory_prefix, operations, target) =>
+ (f naming, theory_prefix, operations, target));
-fun group_position_of lthy =
- group_properties_of lthy @ Position.properties_of (Position.thread_data ());
-
-fun set_group group = map_lthy (fn (_, theory_prefix, operations, target) =>
- (group, theory_prefix, operations, target));
+val conceal = map_naming Name_Space.conceal;
+val set_group = map_naming o Name_Space.set_group;
(* target *)
val target_of = #target o get_lthy;
-val affirm = tap target_of;
-fun map_target f = map_lthy (fn (group, theory_prefix, operations, target) =>
- (group, theory_prefix, operations, f target));
+fun map_target f = map_lthy (fn (naming, theory_prefix, operations, target) =>
+ (naming, theory_prefix, operations, f target));
(* substructure mappings *)
@@ -137,16 +134,12 @@
val checkpoint = raw_theory Theory.checkpoint;
-fun full_naming lthy =
- Sign.naming_of (ProofContext.theory_of lthy)
- |> NameSpace.mandatory_path (#theory_prefix (get_lthy lthy));
-
-fun full_name naming = NameSpace.full_name (full_naming naming);
-
-fun theory_result f lthy = lthy |> raw_theory_result (fn thy => thy
- |> Sign.mandatory_path (#theory_prefix (get_lthy lthy))
- |> f
- ||> Sign.restore_naming thy);
+fun theory_result f lthy =
+ lthy |> raw_theory_result (fn thy =>
+ thy
+ |> Sign.map_naming (K (naming_of lthy))
+ |> f
+ ||> Sign.restore_naming thy);
fun theory f = #2 o theory_result (f #> pair ());
@@ -196,13 +189,19 @@
(* init *)
-fun init theory_prefix operations target = target |> Data.map
- (fn NONE => SOME (make_lthy ("", theory_prefix, operations, target))
- | SOME _ => error "Local theory already initialized")
- |> checkpoint;
+fun init theory_prefix operations target =
+ let val naming =
+ Sign.naming_of (ProofContext.theory_of target)
+ |> Name_Space.mandatory_path theory_prefix;
+ in
+ target |> Data.map
+ (fn NONE => SOME (make_lthy (naming, theory_prefix, operations, target))
+ | SOME _ => error "Local theory already initialized")
+ |> checkpoint
+ end;
fun restore lthy =
- let val {group = _, theory_prefix, operations, target} = get_lthy lthy
+ let val {theory_prefix, operations, target, ...} = get_lthy lthy
in init theory_prefix operations target end;
val reinit = checkpoint o operation #reinit;--- a/src/Pure/Isar/locale.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/locale.ML Tue Oct 27 14:46:03 2009 +0000
@@ -124,15 +124,15 @@
structure Locales = TheoryDataFun
(
- type T = locale NameSpace.table;
- val empty = NameSpace.empty_table;
+ type T = locale Name_Space.table;
+ val empty : T = Name_Space.empty_table "locale";
val copy = I;
val extend = I;
- fun merge _ = NameSpace.join_tables (K merge_locale);
+ fun merge _ = Name_Space.join_tables (K merge_locale);
);
-val intern = NameSpace.intern o #1 o Locales.get;
-val extern = NameSpace.extern o #1 o Locales.get;
+val intern = Name_Space.intern o #1 o Locales.get;
+val extern = Name_Space.extern o #1 o Locales.get;
val get_locale = Symtab.lookup o #2 o Locales.get;
val defined = Symtab.defined o #2 o Locales.get;
@@ -143,7 +143,7 @@
| NONE => error ("Unknown locale " ^ quote name));
fun register_locale binding parameters spec intros axioms decls notes dependencies thy =
- thy |> Locales.map (NameSpace.define (Sign.naming_of thy)
+ thy |> Locales.map (Name_Space.define true (Sign.naming_of thy)
(binding,
mk_locale ((parameters, spec, intros, axioms),
((pairself (map (fn decl => (decl, stamp ()))) decls, map (fn n => (n, stamp ())) notes),
@@ -153,7 +153,7 @@
Locales.map o apsnd o Symtab.map_entry name o map_locale o apsnd;
fun print_locales thy =
- Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (Locales.get thy)))
+ Pretty.strs ("locales:" :: map #1 (Name_Space.extern_table (Locales.get thy)))
|> Pretty.writeln;
--- a/src/Pure/Isar/method.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/method.ML Tue Oct 27 14:46:03 2009 +0000
@@ -322,32 +322,30 @@
structure Methods = TheoryDataFun
(
- type T = (((src -> Proof.context -> method) * string) * stamp) NameSpace.table;
- val empty = NameSpace.empty_table;
+ type T = ((src -> Proof.context -> method) * string) Name_Space.table;
+ val empty : T = Name_Space.empty_table "method";
val copy = I;
val extend = I;
- fun merge _ tables : T = NameSpace.merge_tables (eq_snd (op =)) tables handle Symtab.DUP dup =>
- error ("Attempt to merge different versions of method " ^ quote dup);
+ fun merge _ tables : T = Name_Space.merge_tables tables;
);
fun print_methods thy =
let
val meths = Methods.get thy;
- fun prt_meth (name, ((_, comment), _)) = Pretty.block
+ fun prt_meth (name, (_, comment)) = Pretty.block
[Pretty.str (name ^ ":"), Pretty.brk 2, Pretty.str comment];
in
- [Pretty.big_list "methods:" (map prt_meth (NameSpace.extern_table meths))]
+ [Pretty.big_list "methods:" (map prt_meth (Name_Space.extern_table meths))]
|> Pretty.chunks |> Pretty.writeln
end;
-fun add_method name meth comment thy = thy |> Methods.map (fn meths =>
- #2 (NameSpace.define (Sign.naming_of thy) (name, ((meth, comment), stamp ())) meths)
- handle Symtab.DUP dup => error ("Duplicate declaration of method " ^ quote dup));
+fun add_method name meth comment thy = thy
+ |> Methods.map (#2 o Name_Space.define true (Sign.naming_of thy) (name, (meth, comment)));
(* get methods *)
-val intern = NameSpace.intern o #1 o Methods.get;
+val intern = Name_Space.intern o #1 o Methods.get;
val defined = Symtab.defined o #2 o Methods.get;
fun method_i thy =
@@ -357,11 +355,11 @@
let val ((name, _), pos) = Args.dest_src src in
(case Symtab.lookup meths name of
NONE => error ("Unknown proof method: " ^ quote name ^ Position.str_of pos)
- | SOME ((mth, _), _) => (Position.report (Markup.method name) pos; mth src))
+ | SOME (mth, _) => (Position.report (Markup.method name) pos; mth src))
end;
in meth end;
-fun method thy = method_i thy o Args.map_name (NameSpace.intern (#1 (Methods.get thy)));
+fun method thy = method_i thy o Args.map_name (Name_Space.intern (#1 (Methods.get thy)));
(* method setup *)--- a/src/Pure/Isar/object_logic.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/object_logic.ML Tue Oct 27 14:46:03 2009 +0000
@@ -90,7 +90,7 @@
val base_sort = get_base_sort thy;
val b = Binding.map_name (Syntax.type_name mx) a;
val _ = has_duplicates (op =) vs andalso
- error ("Duplicate parameters in type declaration: " ^ quote (Binding.str_of b));
+ error ("Duplicate parameters in type declaration " ^ quote (Binding.str_of b));
val name = Sign.full_name thy b;
val n = length vs;
val T = Type (name, map (fn v => TFree (v, [])) vs);--- a/src/Pure/Isar/proof.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/proof.ML Tue Oct 27 14:46:03 2009 +0000
@@ -162,7 +162,8 @@
make_node (f (context, facts, mode, goal));
val init_context =
- ProofContext.set_stmt true #> ProofContext.reset_naming;
+ ProofContext.set_stmt true #>
+ ProofContext.map_naming (K ProofContext.local_naming);
fun init ctxt =
State (Stack.init (make_node (init_context ctxt, NONE, Forward, NONE)));
--- a/src/Pure/Isar/proof_context.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/proof_context.ML Tue Oct 27 14:46:03 2009 +0000
@@ -21,7 +21,10 @@
val restore_mode: Proof.context -> Proof.context -> Proof.context
val abbrev_mode: Proof.context -> bool
val set_stmt: bool -> Proof.context -> Proof.context
- val naming_of: Proof.context -> NameSpace.naming
+ val local_naming: Name_Space.naming
+ val map_naming: (Name_Space.naming -> Name_Space.naming) -> Proof.context -> Proof.context
+ val naming_of: Proof.context -> Name_Space.naming
+ val restore_naming: Proof.context -> Proof.context -> Proof.context
val full_name: Proof.context -> binding -> string
val consts_of: Proof.context -> Consts.T
val const_syntax_name: Proof.context -> string -> string
@@ -92,10 +95,6 @@
val get_fact_single: Proof.context -> Facts.ref -> thm
val get_thms: Proof.context -> xstring -> thm list
val get_thm: Proof.context -> xstring -> thm
- val add_path: string -> Proof.context -> Proof.context
- val mandatory_path: string -> Proof.context -> Proof.context
- val restore_naming: Proof.context -> Proof.context -> Proof.context
- val reset_naming: Proof.context -> Proof.context
val note_thmss: string -> (Thm.binding * (thm list * attribute list) list) list ->
Proof.context -> (string * thm list) list * Proof.context
val put_thms: bool -> string * thm list option -> Proof.context -> Proof.context
@@ -120,8 +119,7 @@
val target_notation: bool -> Syntax.mode -> (term * mixfix) list -> morphism ->
Context.generic -> Context.generic
val add_const_constraint: string * typ option -> Proof.context -> Proof.context
- val add_abbrev: string -> Properties.T ->
- binding * term -> Proof.context -> (term * term) * Proof.context
+ val add_abbrev: string -> binding * term -> Proof.context -> (term * term) * Proof.context
val revert_abbrev: string -> string -> Proof.context -> Proof.context
val verbose: bool Unsynchronized.ref
val setmp_verbose: ('a -> 'b) -> 'a -> 'b
@@ -134,9 +132,6 @@
val prems_limit: int Unsynchronized.ref
val pretty_ctxt: Proof.context -> Pretty.T list
val pretty_context: Proof.context -> Pretty.T list
- val query_type: Proof.context -> string -> Properties.T
- val query_const: Proof.context -> string -> Properties.T
- val query_class: Proof.context -> string -> Properties.T
end;
structure ProofContext: PROOF_CONTEXT =
@@ -170,7 +165,7 @@
datatype ctxt =
Ctxt of
{mode: mode, (*inner syntax mode*)
- naming: NameSpace.naming, (*local naming conventions*)
+ naming: Name_Space.naming, (*local naming conventions*)
syntax: LocalSyntax.T, (*local syntax*)
consts: Consts.T * Consts.T, (*local/global consts*)
facts: Facts.T, (*local facts*)
@@ -180,7 +175,7 @@
Ctxt {mode = mode, naming = naming, syntax = syntax,
consts = consts, facts = facts, cases = cases};
-val local_naming = NameSpace.default_naming |> NameSpace.add_path "local";
+val local_naming = Name_Space.default_naming |> Name_Space.add_path "local";
structure ContextData = ProofDataFun
(
@@ -231,7 +226,8 @@
map_mode (fn (_, pattern, schematic, abbrev) => (stmt, pattern, schematic, abbrev));
val naming_of = #naming o rep_context;
-val full_name = NameSpace.full_name o naming_of;
+val restore_naming = map_naming o K o naming_of
+val full_name = Name_Space.full_name o naming_of;
val syntax_of = #syntax o rep_context;
val syn_of = LocalSyntax.syn_of o syntax_of;
@@ -922,14 +918,6 @@
end;
-(* name space operations *)
-
-val add_path = map_naming o NameSpace.add_path;
-val mandatory_path = map_naming o NameSpace.mandatory_path;
-val restore_naming = map_naming o K o naming_of;
-val reset_naming = map_naming (K local_naming);
-
-
(* facts *)
local
@@ -1059,13 +1047,13 @@
in cert_term ctxt (Const (c, T)); T end;
in ctxt |> (map_consts o apfst) (Consts.constrain (c, Option.map prepT opt_T)) end;
-fun add_abbrev mode tags (b, raw_t) ctxt =
+fun add_abbrev mode (b, raw_t) ctxt =
let
val t0 = cert_term (ctxt |> set_mode mode_abbrev) raw_t
handle ERROR msg => cat_error msg ("in constant abbreviation " ^ quote (Binding.str_of b));
val [t] = Variable.exportT_terms (Variable.declare_term t0 ctxt) ctxt [t0];
val ((lhs, rhs), consts') = consts_of ctxt
- |> Consts.abbreviate (Syntax.pp ctxt) (tsig_of ctxt) (naming_of ctxt) mode tags (b, t);
+ |> Consts.abbreviate (Syntax.pp ctxt) (tsig_of ctxt) (naming_of ctxt) mode (b, t);
in
ctxt
|> (map_consts o apfst) (K consts')
@@ -1230,7 +1218,7 @@
| add_abbr (c, (T, SOME t)) =
if not show_globals andalso Symtab.defined globals c then I
else cons (c, Logic.mk_equals (Const (c, T), t));
- val abbrevs = NameSpace.extern_table (space, Symtab.make (Symtab.fold add_abbr consts []));
+ val abbrevs = Name_Space.extern_table (space, Symtab.make (Symtab.fold add_abbr consts []));
in
if null abbrevs andalso not (! verbose) then []
else [Pretty.big_list "abbreviations:" (map (pretty_term_abbrev ctxt o #2) abbrevs)]
@@ -1391,14 +1379,4 @@
verb single (fn () => Pretty.big_list "default sorts:" (map prt_defS (Vartab.dest sorts)))
end;
-
-(* query meta data *)
-
-val query_type = Type.the_tags o tsig_of;
-
-fun query_const ctxt name =
- Consts.the_tags (consts_of ctxt) name handle TYPE (msg, _, _) => error msg;
-
-fun query_class ctxt name = query_const ctxt (Logic.const_of_class name);
-
end;--- a/src/Pure/Isar/specification.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/specification.ML Tue Oct 27 14:46:03 2009 +0000
@@ -161,7 +161,7 @@
val xs = map (fn ((b, T), _) => (Name.of_binding b, T)) vars;
(*consts*)
- val (consts, consts_thy) = thy |> fold_map (Theory.specify_const []) vars;
+ val (consts, consts_thy) = thy |> fold_map Theory.specify_const vars;
val subst = Term.subst_atomic (map Free xs ~~ consts);
(*axioms*)--- a/src/Pure/Isar/theory_target.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Isar/theory_target.ML Tue Oct 27 14:46:03 2009 +0000
@@ -158,8 +158,8 @@
val global_facts = PureThy.map_facts #2 facts'
|> Attrib.map_facts (if is_locale then K I else Attrib.attribute_i thy);
in
- lthy |> LocalTheory.theory
- (PureThy.note_thmss_grouped kind (LocalTheory.group_of lthy) global_facts #> snd)
+ lthy
+ |> LocalTheory.theory (PureThy.note_thmss kind global_facts #> snd)
|> not is_locale ? LocalTheory.target (ProofContext.note_thmss kind global_facts #> snd)
|> is_locale ? LocalTheory.target (Locale.add_thmss target kind target_facts)
|> ProofContext.note_thmss kind local_facts
@@ -173,7 +173,7 @@
else if not is_class then (NoSyn, mx, NoSyn)
else (mx, NoSyn, NoSyn);
-fun locale_const (Target {target, is_class, ...}) (prmode as (mode, _)) tags ((b, mx), rhs) phi =
+fun locale_const (Target {target, is_class, ...}) (prmode as (mode, _)) ((b, mx), rhs) phi =
let
val b' = Morphism.binding phi b;
val rhs' = Morphism.term phi rhs;
@@ -187,8 +187,8 @@
in
not (is_class andalso (similar_body orelse class_global)) ?
(Context.mapping_result
- (Sign.add_abbrev PrintMode.internal tags arg)
- (ProofContext.add_abbrev PrintMode.internal tags arg)
+ (Sign.add_abbrev PrintMode.internal arg)
+ (ProofContext.add_abbrev PrintMode.internal arg)
#-> (fn (lhs' as Const (d, _), _) =>
similar_body ?
(Context.mapping (Sign.revert_abbrev mode d) (ProofContext.revert_abbrev mode d) #>
@@ -199,7 +199,6 @@
fun declare_const (ta as Target {target, is_locale, is_class, ...}) depends ((b, T), mx) lthy =
let
- val tags = LocalTheory.group_position_of lthy;
val xs = filter depends (#1 (ProofContext.inferred_fixes (LocalTheory.target_of lthy)));
val U = map #2 xs ---> T;
val (mx1, mx2, mx3) = fork_mixfix ta mx;
@@ -215,13 +214,13 @@
if mx3 <> NoSyn then syntax_error c'
else LocalTheory.theory_result (Overloading.declare (c', U))
##> Overloading.confirm b
- | NONE => LocalTheory.theory_result (Sign.declare_const tags ((b, U), mx3))));
+ | NONE => LocalTheory.theory_result (Sign.declare_const ((b, U), mx3))));
val (const, lthy') = lthy |> declare_const;
val t = Term.list_comb (const, map Free xs);
in
lthy'
- |> is_locale ? term_syntax ta (locale_const ta Syntax.mode_default tags ((b, mx2), t))
- |> is_class ? class_target ta (Class_Target.declare target tags ((b, mx1), t))
+ |> is_locale ? term_syntax ta (locale_const ta Syntax.mode_default ((b, mx2), t))
+ |> is_class ? class_target ta (Class_Target.declare target ((b, mx1), t))
|> LocalDefs.add_def ((b, NoSyn), t)
end;
@@ -230,7 +229,6 @@
fun abbrev (ta as Target {target, is_locale, is_class, ...}) prmode ((b, mx), t) lthy =
let
- val tags = LocalTheory.group_position_of lthy;
val thy_ctxt = ProofContext.init (ProofContext.theory_of lthy);
val target_ctxt = LocalTheory.target_of lthy;
@@ -243,17 +241,17 @@
in
lthy |>
(if is_locale then
- LocalTheory.theory_result (Sign.add_abbrev PrintMode.internal tags (b, global_rhs))
+ LocalTheory.theory_result (Sign.add_abbrev PrintMode.internal (b, global_rhs))
#-> (fn (lhs, _) =>
let val lhs' = Term.list_comb (Logic.unvarify lhs, xs) in
- term_syntax ta (locale_const ta prmode tags ((b, mx2), lhs')) #>
- is_class ? class_target ta (Class_Target.abbrev target prmode tags ((b, mx1), t'))
+ term_syntax ta (locale_const ta prmode ((b, mx2), lhs')) #>
+ is_class ? class_target ta (Class_Target.abbrev target prmode ((b, mx1), t'))
end)
else
LocalTheory.theory
- (Sign.add_abbrev (#1 prmode) tags (b, global_rhs) #-> (fn (lhs, _) =>
+ (Sign.add_abbrev (#1 prmode) (b, global_rhs) #-> (fn (lhs, _) =>
Sign.notation true prmode [(lhs, mx3)])))
- |> ProofContext.add_abbrev PrintMode.internal tags (b, t) |> snd
+ |> ProofContext.add_abbrev PrintMode.internal (b, t) |> snd
|> LocalDefs.fixed_abbrev ((b, NoSyn), t)
end;
--- a/src/Pure/ML-Systems/multithreading_polyml.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/ML-Systems/multithreading_polyml.ML Tue Oct 27 14:46:03 2009 +0000
@@ -33,15 +33,10 @@
val max_threads = Unsynchronized.ref 0;
-val tested_platform =
- let val ml_platform = getenv "ML_PLATFORM"
- in String.isSuffix "linux" ml_platform orelse String.isSuffix "darwin" ml_platform end;
-
fun max_threads_value () =
let val m = ! max_threads in
if m > 0 then m
- else if not tested_platform then 1
- else Int.min (Int.max (Thread.numProcessors (), 1), 8)
+ else Int.min (Int.max (Thread.numProcessors (), 1), 4)
end;
fun enabled () = max_threads_value () > 1;--- a/src/Pure/ML-Systems/polyml_common.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/ML-Systems/polyml_common.ML Tue Oct 27 14:46:03 2009 +0000
@@ -18,6 +18,9 @@
val forget_structure = PolyML.Compiler.forgetStructure;
+val _ = PolyML.Compiler.forgetValue "isSome";
+val _ = PolyML.Compiler.forgetValue "getOpt";
+val _ = PolyML.Compiler.forgetValue "valOf";
val _ = PolyML.Compiler.forgetValue "foldl";
val _ = PolyML.Compiler.forgetValue "foldr";
val _ = PolyML.Compiler.forgetValue "print";
--- a/src/Pure/Thy/term_style.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Thy/term_style.ML Tue Oct 27 14:46:03 2009 +0000
@@ -54,10 +54,11 @@
>> fold I
|| Scan.succeed I));
-val parse_bare = Args.context :|-- (fn ctxt => Scan.lift Args.liberal_name
+val parse_bare = Args.context :|-- (fn ctxt => (Output.legacy_feature "Old-style antiquotation style.";
+ Scan.lift Args.liberal_name
>> (fn name => fst (Args.context_syntax "style"
(Scan.lift (the_style (ProofContext.theory_of ctxt) name))
- (Args.src (("style", []), Position.none)) ctxt |>> (fn f => f ctxt))));
+ (Args.src (("style", []), Position.none)) ctxt |>> (fn f => f ctxt)))));
(* predefined styles *)
@@ -84,10 +85,13 @@
fun style_parm_premise i = Scan.succeed (fn ctxt => fn t =>
let
val i_str = string_of_int i;
+ val _ = Output.legacy_feature (quote ("prem" ^ i_str)
+ ^ " term style encountered; use explicit argument syntax "
+ ^ quote ("prem " ^ i_str) ^ " instead.");
val prems = Logic.strip_imp_prems t;
in
if i <= length prems then nth prems (i - 1)
- else error ("Not enough premises for prem" ^ string_of_int i ^
+ else error ("Not enough premises for prem" ^ i_str ^
" in propositon: " ^ Syntax.string_of_term ctxt t)
end);
--- a/src/Pure/Thy/thm_deps.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Thy/thm_deps.ML Tue Oct 27 14:46:03 2009 +0000
@@ -48,37 +48,49 @@
fun unused_thms (base_thys, thys) =
let
- fun add_fact (name, ths) =
+ fun add_fact space (name, ths) =
if exists (fn thy => PureThy.defined_fact thy name) base_thys then I
- else fold_rev (fn th => (case Thm.get_name th of "" => I | a => cons (a, th))) ths;
+ else
+ let val {concealed, group, ...} = Name_Space.the_entry space name in
+ fold_rev (fn th =>
+ (case Thm.get_name th of
+ "" => I
+ | a => cons (a, (th, concealed, group)))) ths
+ end;
+ fun add_facts facts = Facts.fold_static (add_fact (Facts.space_of facts)) facts;
+
val thms =
- fold (Facts.fold_static add_fact o PureThy.facts_of) thys []
+ fold (add_facts o PureThy.facts_of) thys []
|> sort_distinct (string_ord o pairself #1);
val tab =
Proofterm.fold_body_thms
- (fn (name, prop, _) => name <> "" ? Symtab.insert_list (op =) (name, prop))
- (map (Proofterm.strip_thm o Thm.proof_body_of o snd) thms) Symtab.empty;
- fun is_unused (name, th) =
- not (member (op aconv) (Symtab.lookup_list tab name) (Thm.prop_of th));
+ (fn (a, prop, _) => a <> "" ? Symtab.insert_list (op =) (a, prop))
+ (map (Proofterm.strip_thm o Thm.proof_body_of o #1 o #2) thms) Symtab.empty;
+
+ fun is_unused (a, th) =
+ not (member (op aconv) (Symtab.lookup_list tab a) (Thm.prop_of th));
(* groups containing at least one used theorem *)
- val grps = fold (fn p as (_, thm) => if is_unused p then I else
- case Thm.get_group thm of
- NONE => I | SOME grp => Symtab.update (grp, ())) thms Symtab.empty;
- val (thms', _) = fold (fn p as (s, thm) => fn q as (thms, grps') =>
- if member (op =) [Thm.theoremK, Thm.generatedK, Thm.lemmaK, Thm.corollaryK, Thm.axiomK] (Thm.get_kind thm)
- andalso is_unused p
+ val used_groups = fold (fn (a, (th, _, group)) =>
+ if is_unused (a, th) then I
+ else
+ (case group of
+ NONE => I
+ | SOME grp => Inttab.update (grp, ()))) thms Inttab.empty;
+ val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, grps') =>
+ if member (op =) [Thm.theoremK, Thm.generatedK, Thm.lemmaK, Thm.corollaryK, Thm.axiomK]
+ (Thm.get_kind th) andalso not concealed andalso is_unused (a, th)
then
- (case Thm.get_group thm of
- NONE => (p :: thms, grps')
+ (case group of
+ NONE => ((a, th) :: thms, grps')
| SOME grp =>
(* do not output theorem if another theorem in group has been used *)
- if Symtab.defined grps grp then q
+ if Inttab.defined used_groups grp then q
(* output at most one unused theorem per group *)
- else if Symtab.defined grps' grp then q
- else (p :: thms, Symtab.update (grp, ()) grps'))
- else q) thms ([], Symtab.empty)
+ else if Inttab.defined grps' grp then q
+ else ((a, th) :: thms, Inttab.update (grp, ()) grps'))
+ else q) thms ([], Inttab.empty)
in rev thms' end;
end;--- a/src/Pure/Thy/thy_output.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Thy/thy_output.ML Tue Oct 27 14:46:03 2009 +0000
@@ -420,9 +420,9 @@
("show_sorts", setmp_CRITICAL Syntax.show_sorts o boolean),
("show_structs", setmp_CRITICAL show_structs o boolean),
("show_question_marks", setmp_CRITICAL show_question_marks o boolean),
- ("long_names", setmp_CRITICAL NameSpace.long_names o boolean),
- ("short_names", setmp_CRITICAL NameSpace.short_names o boolean),
- ("unique_names", setmp_CRITICAL NameSpace.unique_names o boolean),
+ ("long_names", setmp_CRITICAL Name_Space.long_names o boolean),
+ ("short_names", setmp_CRITICAL Name_Space.short_names o boolean),
+ ("unique_names", setmp_CRITICAL Name_Space.unique_names o boolean),
("eta_contract", setmp_CRITICAL Syntax.eta_contract o boolean),
("display", setmp_CRITICAL display o boolean),
("break", setmp_CRITICAL break o boolean),--- a/src/Pure/Tools/find_consts.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Tools/find_consts.ML Tue Oct 27 14:46:03 2009 +0000
@@ -87,9 +87,8 @@
val thy = ProofContext.theory_of ctxt;
val low_ranking = 10000;
- fun not_internal consts (nm, _) =
- if member (op =) (Consts.the_tags consts nm) Markup.property_internal
- then NONE else SOME low_ranking;
+ fun user_visible consts (nm, _) =
+ if Consts.is_concealed consts nm then NONE else SOME low_ranking;
fun make_pattern crit =
let
@@ -119,7 +118,7 @@
val consts = Sign.consts_of thy;
val (_, consts_tab) = #constants (Consts.dest consts);
fun eval_entry c =
- fold filter_const (not_internal consts :: criteria)
+ fold filter_const (user_visible consts :: criteria)
(SOME (c, low_ranking));
val matches =--- a/src/Pure/Tools/find_theorems.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/Tools/find_theorems.ML Tue Oct 27 14:46:03 2009 +0000
@@ -326,7 +326,7 @@
local
val index_ord = option_ord (K EQUAL);
-val hidden_ord = bool_ord o pairself NameSpace.is_hidden;
+val hidden_ord = bool_ord o pairself Name_Space.is_hidden;
val qual_ord = int_ord o pairself (length o Long_Name.explode);
val txt_ord = int_ord o pairself size;
@@ -355,7 +355,8 @@
val space = Facts.space_of (PureThy.facts_of (ProofContext.theory_of ctxt));
val shorten =
- NameSpace.extern_flags {long_names = false, short_names = false, unique_names = false} space;
+ Name_Space.extern_flags
+ {long_names = false, short_names = false, unique_names = false} space;
fun nicer (Facts.Named ((x, _), i)) (Facts.Named ((y, _), j)) =
nicer_name (shorten x, i) (shorten y, j)--- a/src/Pure/axclass.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/axclass.ML Tue Oct 27 14:46:03 2009 +0000
@@ -36,7 +36,7 @@
val lookup_inst_param: Consts.T -> ((string * string) * 'a) list -> string * typ -> 'a option
val param_of_inst: theory -> string * string -> string
val inst_of_param: theory -> string -> (string * string) option
- val arity_property: theory -> class * string -> string -> string list
+ val thynames_of_arity: theory -> class * string -> string list
type cache
val of_sort: theory -> typ * sort -> cache -> thm list * cache (*exception Sorts.CLASS_ERROR*)
val cache: cache
@@ -92,8 +92,8 @@
val arity_prefix = "arity_";
type instances =
- ((class * class) * thm) list *
- ((class * sort list) * thm) list Symtab.table;
+ ((class * class) * thm) list * (*classrel theorems*)
+ ((class * sort list) * (thm * string)) list Symtab.table; (*arity theorems with theory name*)
fun merge_instances ((classrel1, arities1): instances, (classrel2, arities2)) =
(merge (eq_fst op =) (classrel1, classrel2),
@@ -175,35 +175,32 @@
fun the_arity thy a (c, Ss) =
(case AList.lookup (op =) (Symtab.lookup_list (#2 (get_instances thy)) a) (c, Ss) of
- SOME th => Thm.transfer thy th
+ SOME (th, _) => Thm.transfer thy th
| NONE => error ("Unproven type arity " ^
Syntax.string_of_arity (ProofContext.init thy) (a, Ss, [c])));
-fun arity_property thy (c, a) x =
- Symtab.lookup_list (snd (get_instances thy)) a
- |> map_filter (fn ((c', _), th) => if c = c'
- then AList.lookup (op =) (Thm.get_tags th) x else NONE)
+fun thynames_of_arity thy (c, a) =
+ Symtab.lookup_list (#2 (get_instances thy)) a
+ |> map_filter (fn ((c', _), (_, name)) => if c = c' then SOME name else NONE)
|> rev;
-fun insert_arity_completions thy (t, ((c, Ss), th)) arities =
+fun insert_arity_completions thy (t, ((c, Ss), (th, thy_name))) arities =
let
val algebra = Sign.classes_of thy;
- val super_class_completions = Sign.super_classes thy c
+ val super_class_completions =
+ Sign.super_classes thy c
|> filter_out (fn c1 => exists (fn ((c2, Ss2), _) => c1 = c2
- andalso Sorts.sorts_le algebra (Ss2, Ss)) (Symtab.lookup_list arities t))
- val tags = Thm.get_tags th;
+ andalso Sorts.sorts_le algebra (Ss2, Ss)) (Symtab.lookup_list arities t));
val completions = map (fn c1 => (Sorts.weaken algebra
(fn (th, c2) => fn c3 => th RS the_classrel thy (c2, c3)) (th, c) c1
- |> Thm.map_tags (K tags) |> Thm.close_derivation, c1)) super_class_completions;
- val arities' = fold (fn (th1, c1) => Symtab.cons_list (t, ((c1, Ss), th1)))
+ |> Thm.close_derivation, c1)) super_class_completions;
+ val arities' = fold (fn (th1, c1) => Symtab.cons_list (t, ((c1, Ss), (th1, thy_name))))
completions arities;
- in (completions, arities') end;
+ in (null completions, arities') end;
fun put_arity ((t, Ss, c), th) thy =
let
- val th' = (Thm.map_tags o AList.default (op =))
- (Markup.theory_nameN, Context.theory_name thy) th;
- val arity' = (t, ((c, Ss), th'));
+ val arity' = (t, ((c, Ss), (th, Context.theory_name thy)));
in
thy
|> map_instances (fn (classrel, arities) => (classrel,
@@ -216,11 +213,10 @@
fun complete_arities thy =
let
val arities = snd (get_instances thy);
- val (completions, arities') = arities
- |> fold_map (insert_arity_completions thy) (Symtab.dest_list arities)
- |>> flat;
- in if null completions
- then NONE
+ val (finished, arities') = arities
+ |> fold_map (insert_arity_completions thy) (Symtab.dest_list arities);
+ in
+ if forall I finished then NONE
else SOME (thy |> map_instances (fn (classrel, _) => (classrel, arities')))
end;
@@ -309,7 +305,7 @@
in
thy
|> Sign.mandatory_path name_inst
- |> Sign.declare_const [] ((Binding.name c', T'), NoSyn)
+ |> Sign.declare_const ((Binding.name c', T'), NoSyn)
|-> (fn const' as Const (c'', _) =>
Thm.add_def false true
(Binding.name (Thm.def_name c'), Logic.mk_equals (Const (c, T'), const'))--- a/src/Pure/codegen.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/codegen.ML Tue Oct 27 14:46:03 2009 +0000
@@ -337,15 +337,16 @@
val tc = Sign.intern_type thy s;
in
case Symtab.lookup (snd (#types (Type.rep_tsig (Sign.tsig_of thy)))) tc of
- SOME ((Type.LogicalType i, _), _) =>
+ SOME (Type.LogicalType i) =>
if num_args_of (fst syn) > i then
error ("More arguments than corresponding type constructor " ^ s)
- else (case AList.lookup (op =) types tc of
- NONE => CodegenData.put {codegens = codegens,
- tycodegens = tycodegens, consts = consts,
- types = (tc, syn) :: types,
- preprocs = preprocs, modules = modules} thy
- | SOME _ => error ("Type " ^ tc ^ " already associated with code"))
+ else
+ (case AList.lookup (op =) types tc of
+ NONE => CodegenData.put {codegens = codegens,
+ tycodegens = tycodegens, consts = consts,
+ types = (tc, syn) :: types,
+ preprocs = preprocs, modules = modules} thy
+ | SOME _ => error ("Type " ^ tc ^ " already associated with code"))
| _ => error ("Not a type constructor: " ^ s)
end;
@@ -445,13 +446,8 @@
fun map_node k f (gr, x) = (Graph.map_node k f gr, x);
fun new_node p (gr, x) = (Graph.new_node p gr, x);
-fun thyname_of thy f x = the (AList.lookup (op =) (f x) Markup.theory_nameN);
-
-fun thyname_of_type thy =
- thyname_of thy (Type.the_tags (Sign.tsig_of thy));
-
-fun thyname_of_const thy =
- thyname_of thy (Consts.the_tags (Sign.consts_of thy));
+fun thyname_of_type thy = #theory_name o Name_Space.the_entry (Sign.type_space thy);
+fun thyname_of_const thy = #theory_name o Name_Space.the_entry (Sign.const_space thy);
fun rename_terms ts =
let--- a/src/Pure/consts.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/consts.ML Tue Oct 27 14:46:03 2009 +0000
@@ -11,15 +11,15 @@
val eq_consts: T * T -> bool
val retrieve_abbrevs: T -> string list -> term -> (term * term) list
val dest: T ->
- {constants: (typ * term option) NameSpace.table,
- constraints: typ NameSpace.table}
+ {constants: (typ * term option) Name_Space.table,
+ constraints: typ Name_Space.table}
val the_type: T -> string -> typ (*exception TYPE*)
val the_abbreviation: T -> string -> typ * term (*exception TYPE*)
val type_scheme: T -> string -> typ (*exception TYPE*)
- val the_tags: T -> string -> Properties.T (*exception TYPE*)
val is_monomorphic: T -> string -> bool (*exception TYPE*)
val the_constraint: T -> string -> typ (*exception TYPE*)
- val space_of: T -> NameSpace.T
+ val space_of: T -> Name_Space.T
+ val is_concealed: T -> string -> bool
val intern: T -> xstring -> string
val extern: T -> string -> xstring
val extern_early: T -> string -> xstring
@@ -29,9 +29,9 @@
val certify: Pretty.pp -> Type.tsig -> bool -> T -> term -> term (*exception TYPE*)
val typargs: T -> string * typ -> typ list
val instance: T -> string * typ list -> typ
- val declare: bool -> NameSpace.naming -> Properties.T -> (binding * typ) -> T -> T
+ val declare: bool -> Name_Space.naming -> binding * typ -> T -> T
val constrain: string * typ option -> T -> T
- val abbreviate: Pretty.pp -> Type.tsig -> NameSpace.naming -> string -> Properties.T ->
+ val abbreviate: Pretty.pp -> Type.tsig -> Name_Space.naming -> string ->
binding * term -> T -> (term * term) * T
val revert_abbrev: string -> string -> T -> T
val hide: bool -> string -> T -> T
@@ -46,11 +46,11 @@
(* datatype T *)
-type decl = {T: typ, typargs: int list list, tags: Properties.T, authentic: bool};
+type decl = {T: typ, typargs: int list list, authentic: bool};
type abbrev = {rhs: term, normal_rhs: term, force_expand: bool};
datatype T = Consts of
- {decls: ((decl * abbrev option) * serial) NameSpace.table,
+ {decls: (decl * abbrev option) Name_Space.table,
constraints: typ Symtab.table,
rev_abbrevs: (term * term) Item_Net.T Symtab.table};
@@ -70,7 +70,8 @@
(* reverted abbrevs *)
-val empty_abbrevs = Item_Net.init (fn ((t, u), (t', u')) => t aconv t' andalso u aconv u') #1;
+val empty_abbrevs =
+ Item_Net.init (fn ((t, u), (t', u')) => t aconv t' andalso u aconv u') #1;
fun insert_abbrevs mode abbrs =
Symtab.map_default (mode, empty_abbrevs) (Item_Net.insert abbrs);
@@ -84,7 +85,7 @@
fun dest (Consts {decls = (space, decls), constraints, ...}) =
{constants = (space,
- Symtab.fold (fn (c, (({T, ...}, abbr), _)) =>
+ Symtab.fold (fn (c, ({T, ...}, abbr)) =>
Symtab.update (c, (T, Option.map #rhs abbr))) decls Symtab.empty),
constraints = (space, constraints)};
@@ -93,7 +94,7 @@
fun the_const (Consts {decls = (_, tab), ...}) c =
(case Symtab.lookup tab c of
- SOME (decl, _) => decl
+ SOME decl => decl
| NONE => raise TYPE ("Unknown constant: " ^ quote c, [], []));
fun the_type consts c =
@@ -109,7 +110,6 @@
val the_decl = #1 oo the_const;
val type_scheme = #T oo the_decl;
val type_arguments = #typargs oo the_decl;
-val the_tags = #tags oo the_decl;
val is_monomorphic = null oo type_arguments;
@@ -123,8 +123,10 @@
fun space_of (Consts {decls = (space, _), ...}) = space;
-val intern = NameSpace.intern o space_of;
-val extern = NameSpace.extern o space_of;
+val is_concealed = Name_Space.is_concealed o space_of;
+
+val intern = Name_Space.intern o space_of;
+val extern = Name_Space.extern o space_of;
fun extern_early consts c =
(case try (the_const consts) c of
@@ -221,27 +223,20 @@
(** build consts **)
-fun err_dup_const c =
- error ("Duplicate declaration of constant " ^ quote c);
-
-fun extend_decls naming decl tab = NameSpace.define naming decl tab
- handle Symtab.DUP c => err_dup_const c;
-
-
(* name space *)
fun hide fully c = map_consts (fn (decls, constraints, rev_abbrevs) =>
- (apfst (NameSpace.hide fully c) decls, constraints, rev_abbrevs));
+ (apfst (Name_Space.hide fully c) decls, constraints, rev_abbrevs));
(* declarations *)
-fun declare authentic naming tags (b, declT) = map_consts (fn (decls, constraints, rev_abbrevs) =>
- let
- val tags' = tags |> Position.default_properties (Position.thread_data ());
- val decl = {T = declT, typargs = typargs_of declT, tags = tags', authentic = authentic};
- val (_, decls') = decls |> extend_decls naming (b, ((decl, NONE), serial ()));
- in (decls', constraints, rev_abbrevs) end);
+fun declare authentic naming (b, declT) =
+ map_consts (fn (decls, constraints, rev_abbrevs) =>
+ let
+ val decl = {T = declT, typargs = typargs_of declT, authentic = authentic};
+ val (_, decls') = decls |> Name_Space.define true naming (b, (decl, NONE));
+ in (decls', constraints, rev_abbrevs) end);
(* constraints *)
@@ -271,14 +266,14 @@
in
-fun abbreviate pp tsig naming mode tags (b, raw_rhs) consts =
+fun abbreviate pp tsig naming mode (b, raw_rhs) consts =
let
val cert_term = certify pp tsig false consts;
val expand_term = certify pp tsig true consts;
val force_expand = mode = PrintMode.internal;
val _ = Term.exists_subterm Term.is_Var raw_rhs andalso
- error ("Illegal schematic variables on rhs of abbreviation: " ^ Binding.str_of b);
+ error ("Illegal schematic variables on rhs of abbreviation " ^ quote (Binding.str_of b));
val rhs = raw_rhs
|> Term.map_types (Type.cert_typ tsig)
@@ -286,15 +281,14 @@
|> Term.close_schematic_term;
val normal_rhs = expand_term rhs;
val T = Term.fastype_of rhs;
- val lhs = Const (NameSpace.full_name naming b, T);
+ val lhs = Const (Name_Space.full_name naming b, T);
in
consts |> map_consts (fn (decls, constraints, rev_abbrevs) =>
let
- val tags' = tags |> Position.default_properties (Position.thread_data ());
- val decl = {T = T, typargs = typargs_of T, tags = tags', authentic = true};
+ val decl = {T = T, typargs = typargs_of T, authentic = true};
val abbr = {rhs = rhs, normal_rhs = normal_rhs, force_expand = force_expand};
val (_, decls') = decls
- |> extend_decls naming (b, ((decl, SOME abbr), serial ()));
+ |> Name_Space.define true naming (b, (decl, SOME abbr));
val rev_abbrevs' = rev_abbrevs
|> insert_abbrevs mode (rev_abbrev lhs rhs);
in (decls', constraints, rev_abbrevs') end)
@@ -313,14 +307,13 @@
(* empty and merge *)
-val empty = make_consts (NameSpace.empty_table, Symtab.empty, Symtab.empty);
+val empty = make_consts (Name_Space.empty_table "constant", Symtab.empty, Symtab.empty);
fun merge
(Consts {decls = decls1, constraints = constraints1, rev_abbrevs = rev_abbrevs1},
Consts {decls = decls2, constraints = constraints2, rev_abbrevs = rev_abbrevs2}) =
let
- val decls' = NameSpace.merge_tables (eq_snd (op =)) (decls1, decls2)
- handle Symtab.DUP c => err_dup_const c;
+ val decls' = Name_Space.merge_tables (decls1, decls2);
val constraints' = Symtab.join (K fst) (constraints1, constraints2);
val rev_abbrevs' = Symtab.join (K Item_Net.merge) (rev_abbrevs1, rev_abbrevs2);
in make_consts (decls', constraints', rev_abbrevs') end;--- a/src/Pure/display.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/display.ML Tue Oct 27 14:46:03 2009 +0000
@@ -146,14 +146,14 @@
[Pretty.str "default sort:", Pretty.brk 1, prt_sort S];
val tfrees = map (fn v => TFree (v, []));
- fun pretty_type syn (t, ((Type.LogicalType n, _), _)) =
+ fun pretty_type syn (t, (Type.LogicalType n)) =
if syn then NONE
else SOME (prt_typ (Type (t, tfrees (Name.invents Name.context Name.aT n))))
- | pretty_type syn (t, ((Type.Abbreviation (vs, U, syn'), _), _)) =
+ | pretty_type syn (t, (Type.Abbreviation (vs, U, syn'))) =
if syn <> syn' then NONE
else SOME (Pretty.block
[prt_typ (Type (t, tfrees vs)), Pretty.str " =", Pretty.brk 1, prt_typ U])
- | pretty_type syn (t, ((Type.Nonterminal, _), _)) =
+ | pretty_type syn (t, Type.Nonterminal) =
if not syn then NONE
else SOME (prt_typ (Type (t, [])));
@@ -179,25 +179,24 @@
val {restricts, reducts} = Defs.dest defs;
val {naming = _, syn = _, tsig, consts} = Sign.rep_sg thy;
val {constants, constraints} = Consts.dest consts;
- val extern_const = NameSpace.extern (#1 constants);
+ val extern_const = Name_Space.extern (#1 constants);
val {classes, default, types, ...} = Type.rep_tsig tsig;
val (class_space, class_algebra) = classes;
val {classes, arities} = Sorts.rep_algebra class_algebra;
- val clsses = NameSpace.dest_table (class_space, Symtab.make (Graph.dest classes));
- val tdecls = NameSpace.dest_table types;
- val arties = NameSpace.dest_table (Sign.type_space thy, arities);
+ val clsses = Name_Space.dest_table (class_space, Symtab.make (Graph.dest classes));
+ val tdecls = Name_Space.dest_table types;
+ val arties = Name_Space.dest_table (Sign.type_space thy, arities);
- fun prune_const c = not verbose andalso
- member (op =) (Consts.the_tags consts c) Markup.property_internal;
- val cnsts = NameSpace.extern_table (#1 constants,
+ fun prune_const c = not verbose andalso Consts.is_concealed consts c;
+ val cnsts = Name_Space.extern_table (#1 constants,
Symtab.make (filter_out (prune_const o fst) (Symtab.dest (#2 constants))));
val log_cnsts = map_filter (fn (c, (ty, NONE)) => SOME (c, ty) | _ => NONE) cnsts;
val abbrevs = map_filter (fn (c, (ty, SOME t)) => SOME (c, (ty, t)) | _ => NONE) cnsts;
- val cnstrs = NameSpace.extern_table constraints;
+ val cnstrs = Name_Space.extern_table constraints;
- val axms = NameSpace.extern_table axioms;
+ val axms = Name_Space.extern_table axioms;
val (reds0, (reds1, reds2)) = filter_out (prune_const o fst o fst) reducts
|> map (fn (lhs, rhs) =>--- a/src/Pure/drule.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/drule.ML Tue Oct 27 14:46:03 2009 +0000
@@ -452,7 +452,7 @@
val read_prop = certify o SimpleSyntax.read_prop;
-fun get_def thy = Thm.axiom thy o NameSpace.intern (Theory.axiom_space thy) o Thm.def_name;
+fun get_def thy = Thm.axiom thy o Name_Space.intern (Theory.axiom_space thy) o Thm.def_name;
fun store_thm name th =
Context.>>> (Context.map_theory_result (PureThy.store_thm (Binding.name name, th)));
--- a/src/Pure/facts.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/facts.ML Tue Oct 27 14:46:03 2009 +0000
@@ -20,7 +20,8 @@
val selections: string * thm list -> (ref * thm) list
type T
val empty: T
- val space_of: T -> NameSpace.T
+ val space_of: T -> Name_Space.T
+ val is_concealed: T -> string -> bool
val intern: T -> xstring -> string
val extern: T -> string -> xstring
val lookup: Context.generic -> T -> string -> (bool * thm list) option
@@ -31,9 +32,9 @@
val props: T -> thm list
val could_unify: T -> term -> thm list
val merge: T * T -> T
- val add_global: NameSpace.naming -> binding * thm list -> T -> string * T
- val add_local: bool -> NameSpace.naming -> binding * thm list -> T -> string * T
- val add_dynamic: NameSpace.naming -> binding * (Context.generic -> thm list) -> T -> string * T
+ val add_global: Name_Space.naming -> binding * thm list -> T -> string * T
+ val add_local: bool -> Name_Space.naming -> binding * thm list -> T -> string * T
+ val add_dynamic: Name_Space.naming -> binding * (Context.generic -> thm list) -> T -> string * T
val del: string -> T -> T
val hide: bool -> string -> T -> T
end;
@@ -44,7 +45,7 @@
(** fact references **)
fun the_single _ [th] : thm = th
- | the_single name _ = error ("Single theorem expected " ^ quote name);
+ | the_single name _ = error ("Expected singleton fact " ^ quote name);
(* datatype interval *)
@@ -122,11 +123,12 @@
datatype fact = Static of thm list | Dynamic of Context.generic -> thm list;
datatype T = Facts of
- {facts: (fact * serial) NameSpace.table,
+ {facts: fact Name_Space.table,
props: thm Net.net};
fun make_facts facts props = Facts {facts = facts, props = props};
-val empty = make_facts NameSpace.empty_table Net.empty;
+
+val empty = make_facts (Name_Space.empty_table "fact") Net.empty;
(* named facts *)
@@ -136,18 +138,21 @@
val space_of = #1 o facts_of;
val table_of = #2 o facts_of;
-val intern = NameSpace.intern o space_of;
-val extern = NameSpace.extern o space_of;
+val is_concealed = Name_Space.is_concealed o space_of;
+
+val intern = Name_Space.intern o space_of;
+val extern = Name_Space.extern o space_of;
val defined = Symtab.defined o table_of;
fun lookup context facts name =
(case Symtab.lookup (table_of facts) name of
NONE => NONE
- | SOME (Static ths, _) => SOME (true, ths)
- | SOME (Dynamic f, _) => SOME (false, f context));
+ | SOME (Static ths) => SOME (true, ths)
+ | SOME (Dynamic f) => SOME (false, f context));
-fun fold_static f = Symtab.fold (fn (name, (Static ths, _)) => f (name, ths) | _ => I) o table_of;
+fun fold_static f =
+ Symtab.fold (fn (name, Static ths) => f (name, ths) | _ => I) o table_of;
(* content difference *)
@@ -174,61 +179,52 @@
(* merge facts *)
-fun err_dup_fact name = error ("Duplicate fact " ^ quote name);
-
-(* FIXME stamp identity! *)
-fun eq_entry ((Static ths1, _), (Static ths2, _)) = is_equal (list_ord Thm.thm_ord (ths1, ths2))
- | eq_entry ((_, id1: serial), (_, id2)) = id1 = id2;
-
fun merge (Facts {facts = facts1, props = props1}, Facts {facts = facts2, props = props2}) =
let
- val facts' = NameSpace.merge_tables eq_entry (facts1, facts2)
- handle Symtab.DUP dup => err_dup_fact dup;
+ val facts' = Name_Space.merge_tables (facts1, facts2);
val props' = Net.merge (is_equal o prop_ord) (props1, props2);
in make_facts facts' props' end;
(* add static entries *)
-fun add permissive do_props naming (b, ths) (Facts {facts, props}) =
+local
+
+fun add strict do_props naming (b, ths) (Facts {facts, props}) =
let
- val (name, facts') = if Binding.is_empty b then ("", facts)
- else let
- val (space, tab) = facts;
- val (name, space') = NameSpace.declare naming b space;
- val entry = (name, (Static ths, serial ()));
- val tab' = (if permissive then Symtab.update else Symtab.update_new) entry tab
- handle Symtab.DUP dup => err_dup_fact dup;
- in (name, (space', tab')) end;
+ val (name, facts') =
+ if Binding.is_empty b then ("", facts)
+ else Name_Space.define strict naming (b, Static ths) facts;
val props' =
- if do_props then fold (fn th => Net.insert_term (K false) (Thm.full_prop_of th, th)) ths props
+ if do_props
+ then fold (fn th => Net.insert_term (K false) (Thm.full_prop_of th, th)) ths props
else props;
in (name, make_facts facts' props') end;
-val add_global = add false false;
-val add_local = add true;
+in
+
+val add_global = add true false;
+val add_local = add false;
+
+end;
(* add dynamic entries *)
-fun add_dynamic naming (b, f) (Facts {facts = (space, tab), props}) =
- let
- val (name, space') = NameSpace.declare naming b space;
- val entry = (name, (Dynamic f, serial ()));
- val tab' = Symtab.update_new entry tab
- handle Symtab.DUP dup => err_dup_fact dup;
- in (name, make_facts (space', tab') props) end;
+fun add_dynamic naming (b, f) (Facts {facts, props}) =
+ let val (name, facts') = Name_Space.define true naming (b, Dynamic f) facts;
+ in (name, make_facts facts' props) end;
(* remove entries *)
fun del name (Facts {facts = (space, tab), props}) =
let
- val space' = NameSpace.hide true name space handle ERROR _ => space;
+ val space' = Name_Space.hide true name space handle ERROR _ => space;
val tab' = Symtab.delete_safe name tab;
in make_facts (space', tab') props end;
fun hide fully name (Facts {facts = (space, tab), props}) =
- make_facts (NameSpace.hide fully name space, tab) props;
+ make_facts (Name_Space.hide fully name space, tab) props;
end;--- a/src/Pure/library.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/library.ML Tue Oct 27 14:46:03 2009 +0000
@@ -853,7 +853,7 @@
of [] => 0
| [n] => n
| _ => raise UnequalLengths;
- in map (fn m => f (map (fn xs => nth xs m) xss)) (0 upto n - 1) end;
+ in map_range (fn m => f (map (fn xs => nth xs m) xss)) n end;
--- a/src/Pure/more_thm.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/more_thm.ML Tue Oct 27 14:46:03 2009 +0000
@@ -83,9 +83,6 @@
val has_name_hint: thm -> bool
val get_name_hint: thm -> string
val put_name_hint: string -> thm -> thm
- val get_group: thm -> string option
- val put_group: string -> thm -> thm
- val group: string -> attribute
val axiomK: string
val assumptionK: string
val definitionK: string
@@ -417,15 +414,6 @@
fun put_name_hint name = untag_rule Markup.nameN #> tag_rule (Markup.nameN, name);
-(* theorem groups *)
-
-fun get_group thm = Properties.get (Thm.get_tags thm) Markup.groupN;
-
-fun put_group name = if name = "" then I else Thm.map_tags (Properties.put (Markup.groupN, name));
-
-fun group name = rule_attribute (K (put_group name));
-
-
(* theorem kinds *)
val axiomK = "axiom";
--- a/src/Pure/name.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/name.ML Tue Oct 27 14:46:03 2009 +0000
@@ -45,7 +45,7 @@
(* checked binding *)
-val of_binding = Long_Name.base_name o NameSpace.full_name NameSpace.default_naming;
+val of_binding = Long_Name.base_name o Name_Space.full_name Name_Space.default_naming;
(* encoded bounds *)
--- a/src/Pure/pure_thy.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/pure_thy.ML Tue Oct 27 14:46:03 2009 +0000
@@ -32,8 +32,6 @@
val add_thms_dynamic: binding * (Context.generic -> thm list) -> theory -> theory
val note_thmss: string -> (Thm.binding * (thm list * attribute list) list) list
-> theory -> (string * thm list) list * theory
- val note_thmss_grouped: string -> string -> (Thm.binding * (thm list * attribute list) list) list
- -> theory -> (string * thm list) list * theory
val add_axioms: ((binding * term) * attribute list) list -> theory -> thm list * theory
val add_axioms_cmd: ((binding * string) * attribute list) list -> theory -> thm list * theory
val add_defs: bool -> ((binding * term) * attribute list) list ->
@@ -146,7 +144,7 @@
else
let
val naming = Sign.naming_of thy;
- val name = NameSpace.full_name naming b;
+ val name = Name_Space.full_name naming b;
val (thy', thms') =
register_proofs (apsnd (post_name name) (app_att (thy, pre_name name thms)));
val thms'' = map (Thm.transfer thy') thms';
@@ -192,9 +190,7 @@
(* note_thmss *)
-local
-
-fun gen_note_thmss tag = fold_map (fn ((b, more_atts), ths_atts) => fn thy =>
+fun note_thmss kind = fold_map (fn ((b, more_atts), ths_atts) => fn thy =>
let
val pos = Binding.pos_of b;
val name = Sign.full_name thy b;
@@ -203,16 +199,9 @@
fun app (x, (ths, atts)) = Library.foldl_map (Thm.theory_attributes atts) (x, ths);
val (thms, thy') = thy |> enter_thms
(name_thmss true pos) (name_thms false true pos) (apsnd flat o Library.foldl_map app)
- (b, map (fn (ths, atts) => (ths, surround tag (atts @ more_atts))) ths_atts);
+ (b, map (fn (ths, atts) => (ths, surround (Thm.kind kind) (atts @ more_atts))) ths_atts);
in ((name, thms), thy') end);
-in
-
-fun note_thmss k = gen_note_thmss (Thm.kind k);
-fun note_thmss_grouped k g = gen_note_thmss (Thm.kind k #> Thm.group g);
-
-end;
-
(* store axioms as theorems *)
--- a/src/Pure/sign.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/sign.ML Tue Oct 27 14:46:03 2009 +0000
@@ -8,11 +8,12 @@
signature SIGN =
sig
val rep_sg: theory ->
- {naming: NameSpace.naming,
+ {naming: Name_Space.naming,
syn: Syntax.syntax,
tsig: Type.tsig,
consts: Consts.T}
- val naming_of: theory -> NameSpace.naming
+ val map_naming: (Name_Space.naming -> Name_Space.naming) -> theory -> theory
+ val naming_of: theory -> Name_Space.naming
val full_name: theory -> binding -> string
val full_name_path: theory -> string -> binding -> string
val full_bname: theory -> bstring -> string
@@ -44,9 +45,9 @@
val const_typargs: theory -> string * typ -> typ list
val const_instance: theory -> string * typ list -> typ
val mk_const: theory -> string * typ list -> term
- val class_space: theory -> NameSpace.T
- val type_space: theory -> NameSpace.T
- val const_space: theory -> NameSpace.T
+ val class_space: theory -> Name_Space.T
+ val type_space: theory -> Name_Space.T
+ val const_space: theory -> Name_Space.T
val intern_class: theory -> xstring -> string
val extern_class: theory -> string -> xstring
val intern_type: theory -> xstring -> string
@@ -89,10 +90,10 @@
val del_modesyntax: Syntax.mode -> (string * string * mixfix) list -> theory -> theory
val del_modesyntax_i: Syntax.mode -> (string * typ * mixfix) list -> theory -> theory
val notation: bool -> Syntax.mode -> (term * mixfix) list -> theory -> theory
- val declare_const: Properties.T -> (binding * typ) * mixfix -> theory -> term * theory
+ val declare_const: (binding * typ) * mixfix -> theory -> term * theory
val add_consts: (binding * string * mixfix) list -> theory -> theory
val add_consts_i: (binding * typ * mixfix) list -> theory -> theory
- val add_abbrev: string -> Properties.T -> binding * term -> theory -> (term * term) * theory
+ val add_abbrev: string -> binding * term -> theory -> (term * term) * theory
val revert_abbrev: string -> string -> theory -> theory
val add_const_constraint: string * typ option -> theory -> theory
val primitive_class: binding * class list -> theory -> theory
@@ -137,7 +138,7 @@
(** datatype sign **)
datatype sign = Sign of
- {naming: NameSpace.naming, (*common naming conventions*)
+ {naming: Name_Space.naming, (*common naming conventions*)
syn: Syntax.syntax, (*concrete syntax for terms, types, sorts*)
tsig: Type.tsig, (*order-sorted signature of types*)
consts: Consts.T}; (*polymorphic constants*)
@@ -150,17 +151,17 @@
type T = sign;
val copy = I;
fun extend (Sign {syn, tsig, consts, ...}) =
- make_sign (NameSpace.default_naming, syn, tsig, consts);
+ make_sign (Name_Space.default_naming, syn, tsig, consts);
val empty =
- make_sign (NameSpace.default_naming, Syntax.basic_syn, Type.empty_tsig, Consts.empty);
+ make_sign (Name_Space.default_naming, Syntax.basic_syn, Type.empty_tsig, Consts.empty);
fun merge pp (sign1, sign2) =
let
val Sign {naming = _, syn = syn1, tsig = tsig1, consts = consts1} = sign1;
val Sign {naming = _, syn = syn2, tsig = tsig2, consts = consts2} = sign2;
- val naming = NameSpace.default_naming;
+ val naming = Name_Space.default_naming;
val syn = Syntax.merge_syntaxes syn1 syn2;
val tsig = Type.merge_tsigs pp (tsig1, tsig2);
val consts = Consts.merge (consts1, consts2);
@@ -182,10 +183,10 @@
val naming_of = #naming o rep_sg;
-val full_name = NameSpace.full_name o naming_of;
-fun full_name_path thy path = NameSpace.full_name (NameSpace.add_path path (naming_of thy));
+val full_name = Name_Space.full_name o naming_of;
+fun full_name_path thy path = Name_Space.full_name (Name_Space.add_path path (naming_of thy));
-fun full_bname thy = NameSpace.full_name (naming_of thy) o Binding.name;
+fun full_bname thy = Name_Space.full_name (naming_of thy) o Binding.name;
fun full_bname_path thy path = full_name_path thy path o Binding.name;
@@ -240,12 +241,12 @@
val type_space = #1 o #types o Type.rep_tsig o tsig_of;
val const_space = Consts.space_of o consts_of;
-val intern_class = NameSpace.intern o class_space;
-val extern_class = NameSpace.extern o class_space;
-val intern_type = NameSpace.intern o type_space;
-val extern_type = NameSpace.extern o type_space;
-val intern_const = NameSpace.intern o const_space;
-val extern_const = NameSpace.extern o const_space;
+val intern_class = Name_Space.intern o class_space;
+val extern_class = Name_Space.extern o class_space;
+val intern_type = Name_Space.intern o type_space;
+val extern_type = Name_Space.extern o type_space;
+val intern_const = Name_Space.intern o const_space;
+val extern_const = Name_Space.extern o const_space;
val intern_sort = map o intern_class;
val extern_sort = map o extern_class;
@@ -433,8 +434,7 @@
let
val syn' = Syntax.update_type_gram (map (fn (a, n, mx) => (Name.of_binding a, n, mx)) types) syn;
val decls = map (fn (a, n, mx) => (Binding.map_name (Syntax.type_name mx) a, n)) types;
- val tags = [(Markup.theory_nameN, Context.theory_name thy)];
- val tsig' = fold (Type.add_type naming tags) decls tsig;
+ val tsig' = fold (Type.add_type naming) decls tsig;
in (naming, syn', tsig', consts) end);
@@ -443,7 +443,7 @@
fun add_nonterminals ns thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
let
val syn' = Syntax.update_consts (map Name.of_binding ns) syn;
- val tsig' = fold (Type.add_nonterminal naming []) ns tsig;
+ val tsig' = fold (Type.add_nonterminal naming) ns tsig;
in (naming, syn', tsig', consts) end);
@@ -457,7 +457,7 @@
val b = Binding.map_name (Syntax.type_name mx) a;
val abbr = (b, vs, certify_typ_mode Type.mode_syntax thy (parse_typ ctxt rhs))
handle ERROR msg => cat_error msg ("in type abbreviation " ^ quote (Binding.str_of b));
- val tsig' = Type.add_abbrev naming [] abbr tsig;
+ val tsig' = Type.add_abbrev naming abbr tsig;
in (naming, syn', tsig', consts) end);
val add_tyabbrs = fold (gen_add_tyabbr Syntax.parse_typ);
@@ -495,7 +495,7 @@
local
-fun gen_add_consts parse_typ authentic tags raw_args thy =
+fun gen_add_consts parse_typ authentic raw_args thy =
let
val ctxt = ProofContext.init thy;
val prepT = Type.no_tvars o Term.no_dummyT o certify_typ thy o parse_typ ctxt;
@@ -510,24 +510,22 @@
val T' = Logic.varifyT T;
in ((b, T'), (c_syn, T', mx), Const (c, T)) end;
val args = map prep raw_args;
- val tags' = tags |> Properties.put (Markup.theory_nameN, Context.theory_name thy);
in
thy
- |> map_consts (fold (Consts.declare authentic (naming_of thy) tags' o #1) args)
+ |> map_consts (fold (Consts.declare authentic (naming_of thy) o #1) args)
|> add_syntax_i (map #2 args)
|> pair (map #3 args)
end;
in
-fun add_consts args = snd o gen_add_consts Syntax.parse_typ false [] args;
-fun add_consts_i args = snd o gen_add_consts (K I) false [] args;
+fun add_consts args = snd o gen_add_consts Syntax.parse_typ false args;
+fun add_consts_i args = snd o gen_add_consts (K I) false args;
-fun declare_const tags ((b, T), mx) thy =
+fun declare_const ((b, T), mx) thy =
let
val pos = Binding.pos_of b;
- val tags' = Position.default_properties pos tags;
- val ([const as Const (c, _)], thy') = gen_add_consts (K I) true tags' [(b, T, mx)] thy;
+ val ([const as Const (c, _)], thy') = gen_add_consts (K I) true [(b, T, mx)] thy;
val _ = Position.report (Markup.const_decl c) pos;
in (const, thy') end;
@@ -536,14 +534,14 @@
(* abbreviations *)
-fun add_abbrev mode tags (b, raw_t) thy =
+fun add_abbrev mode (b, raw_t) thy =
let
val pp = Syntax.pp_global thy;
val prep_tm = no_frees pp o Term.no_dummy_patterns o cert_term_abbrev thy;
val t = (prep_tm raw_t handle TYPE (msg, _, _) => error msg | TERM (msg, _) => error msg)
handle ERROR msg => cat_error msg ("in constant abbreviation " ^ quote (Binding.str_of b));
val (res, consts') = consts_of thy
- |> Consts.abbreviate pp (tsig_of thy) (naming_of thy) mode tags (b, t);
+ |> Consts.abbreviate pp (tsig_of thy) (naming_of thy) mode (b, t);
in (res, thy |> map_consts (K consts')) end;
fun revert_abbrev mode c = map_consts (Consts.revert_abbrev mode c);
@@ -612,10 +610,10 @@
(* naming *)
-val add_path = map_naming o NameSpace.add_path;
-val root_path = map_naming NameSpace.root_path;
-val parent_path = map_naming NameSpace.parent_path;
-val mandatory_path = map_naming o NameSpace.mandatory_path;
+val add_path = map_naming o Name_Space.add_path;
+val root_path = map_naming Name_Space.root_path;
+val parent_path = map_naming Name_Space.parent_path;
+val mandatory_path = map_naming o Name_Space.mandatory_path;
fun local_path thy = thy |> root_path |> add_path (Context.theory_name thy);
--- a/src/Pure/simplifier.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/simplifier.ML Tue Oct 27 14:46:03 2009 +0000
@@ -143,18 +143,14 @@
(** named simprocs **)
-fun err_dup_simproc name = error ("Duplicate simproc: " ^ quote name);
-
-
(* data *)
structure Simprocs = GenericDataFun
(
- type T = simproc NameSpace.table;
- val empty = NameSpace.empty_table;
+ type T = simproc Name_Space.table;
+ val empty : T = Name_Space.empty_table "simproc";
val extend = I;
- fun merge _ simprocs = NameSpace.merge_tables eq_simproc simprocs
- handle Symtab.DUP dup => err_dup_simproc dup;
+ fun merge _ simprocs = Name_Space.merge_tables simprocs;
);
@@ -163,7 +159,7 @@
fun get_simproc context xname =
let
val (space, tab) = Simprocs.get context;
- val name = NameSpace.intern space xname;
+ val name = Name_Space.intern space xname;
in
(case Symtab.lookup tab name of
SOME proc => proc
@@ -181,9 +177,9 @@
fun gen_simproc prep {name, lhss, proc, identifier} lthy =
let
val b = Binding.name name;
- val naming = LocalTheory.full_naming lthy;
+ val naming = LocalTheory.naming_of lthy;
val simproc = make_simproc
- {name = LocalTheory.full_name lthy b,
+ {name = Name_Space.full_name naming b,
lhss =
let
val lhss' = prep lthy lhss;
@@ -201,9 +197,7 @@
val b' = Morphism.binding phi b;
val simproc' = morph_simproc phi simproc;
in
- Simprocs.map (fn simprocs =>
- NameSpace.define naming (b', simproc') simprocs |> snd
- handle Symtab.DUP dup => err_dup_simproc dup)
+ Simprocs.map (#2 o Name_Space.define true naming (b', simproc'))
#> map_ss (fn ss => ss addsimprocs [simproc'])
end)
end;--- a/src/Pure/theory.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/theory.ML Tue Oct 27 14:46:03 2009 +0000
@@ -19,7 +19,7 @@
val checkpoint: theory -> theory
val copy: theory -> theory
val requires: theory -> string -> string -> unit
- val axiom_space: theory -> NameSpace.T
+ val axiom_space: theory -> Name_Space.T
val axiom_table: theory -> term Symtab.table
val axioms_of: theory -> (string * term) list
val all_axioms_of: theory -> (string * term) list
@@ -35,7 +35,7 @@
val add_defs: bool -> bool -> (binding * string) list -> theory -> theory
val add_finals_i: bool -> term list -> theory -> theory
val add_finals: bool -> string list -> theory -> theory
- val specify_const: Properties.T -> (binding * typ) * mixfix -> theory -> term * theory
+ val specify_const: (binding * typ) * mixfix -> theory -> term * theory
end
structure Theory: THEORY =
@@ -80,29 +80,27 @@
perhaps (perhaps_loop (perhaps_apply (map fst wrappers)));
datatype thy = Thy of
- {axioms: term NameSpace.table,
+ {axioms: term Name_Space.table,
defs: Defs.T,
wrappers: wrapper list * wrapper list};
fun make_thy (axioms, defs, wrappers) = Thy {axioms = axioms, defs = defs, wrappers = wrappers};
-fun err_dup_axm dup = error ("Duplicate axiom: " ^ quote dup);
-
structure ThyData = TheoryDataFun
(
type T = thy;
- val empty = make_thy (NameSpace.empty_table, Defs.empty, ([], []));
+ val empty_axioms = Name_Space.empty_table "axiom" : term Name_Space.table;
+ val empty = make_thy (empty_axioms, Defs.empty, ([], []));
val copy = I;
- fun extend (Thy {axioms = _, defs, wrappers}) =
- make_thy (NameSpace.empty_table, defs, wrappers);
+ fun extend (Thy {axioms = _, defs, wrappers}) = make_thy (empty_axioms, defs, wrappers);
fun merge pp (thy1, thy2) =
let
val Thy {axioms = _, defs = defs1, wrappers = (bgs1, ens1)} = thy1;
val Thy {axioms = _, defs = defs2, wrappers = (bgs2, ens2)} = thy2;
- val axioms' = NameSpace.empty_table;
+ val axioms' = empty_axioms;
val defs' = Defs.merge pp (defs1, defs2);
val bgs' = Library.merge (eq_snd op =) (bgs1, bgs2);
val ens' = Library.merge (eq_snd op =) (ens1, ens2);
@@ -143,7 +141,12 @@
let
val thy = Context.begin_thy Syntax.pp_global name imports;
val wrappers = begin_wrappers thy;
- in thy |> Sign.local_path |> apply_wrappers wrappers end;
+ in
+ thy
+ |> Sign.local_path
+ |> Sign.map_naming (Name_Space.set_theory_name name)
+ |> apply_wrappers wrappers
+ end;
fun end_theory thy =
thy |> apply_wrappers (end_wrappers thy) |> Context.finish_thy;
@@ -166,7 +169,7 @@
fun read_axm thy (b, str) =
cert_axm thy (b, Syntax.read_prop_global thy str) handle ERROR msg =>
- cat_error msg ("The error(s) above occurred in axiom: " ^ quote (Binding.str_of b));
+ cat_error msg ("The error(s) above occurred in axiom " ^ quote (Binding.str_of b));
(* add_axioms(_i) *)
@@ -176,8 +179,7 @@
fun gen_add_axioms prep_axm raw_axms thy = thy |> map_axioms (fn axioms =>
let
val axms = map (apsnd Logic.varify o prep_axm thy) raw_axms;
- val axioms' = fold (snd oo NameSpace.define (Sign.naming_of thy)) axms axioms
- handle Symtab.DUP dup => err_dup_axm dup;
+ val axioms' = fold (#2 oo Name_Space.define true (Sign.naming_of thy)) axms axioms;
in axioms' end);
in
@@ -217,8 +219,8 @@
val name = if a = "" then (#1 lhs ^ " axiom") else a;
in thy |> map_defs (dependencies thy false false name lhs rhs) end;
-fun specify_const tags decl thy =
- let val (t as Const const, thy') = Sign.declare_const tags decl thy
+fun specify_const decl thy =
+ let val (t as Const const, thy') = Sign.declare_const decl thy
in (t, add_deps "" const [] thy') end;
--- a/src/Pure/thm.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/thm.ML Tue Oct 27 14:46:03 2009 +0000
@@ -1724,25 +1724,21 @@
(* authentic derivation names *)
-fun err_dup_ora dup = error ("Duplicate oracle: " ^ quote dup);
-
structure Oracles = TheoryDataFun
(
- type T = serial NameSpace.table;
- val empty = NameSpace.empty_table;
+ type T = unit Name_Space.table;
+ val empty : T = Name_Space.empty_table "oracle";
val copy = I;
val extend = I;
- fun merge _ oracles : T = NameSpace.merge_tables (op =) oracles
- handle Symtab.DUP dup => err_dup_ora dup;
+ fun merge _ oracles : T = Name_Space.merge_tables oracles;
);
-val extern_oracles = map #1 o NameSpace.extern_table o Oracles.get;
+val extern_oracles = map #1 o Name_Space.extern_table o Oracles.get;
fun add_oracle (b, oracle) thy =
let
val naming = Sign.naming_of thy;
- val (name, tab') = NameSpace.define naming (b, serial ()) (Oracles.get thy)
- handle Symtab.DUP _ => err_dup_ora (Binding.str_of b);
+ val (name, tab') = Name_Space.define true naming (b, ()) (Oracles.get thy);
val thy' = Oracles.put tab' thy;
in ((name, invoke_oracle (Theory.check_thy thy') name oracle), thy') end;
--- a/src/Pure/type.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Pure/type.ML Tue Oct 27 14:46:03 2009 +0000
@@ -14,9 +14,9 @@
Nonterminal
type tsig
val rep_tsig: tsig ->
- {classes: NameSpace.T * Sorts.algebra,
+ {classes: Name_Space.T * Sorts.algebra,
default: sort,
- types: ((decl * Properties.T) * serial) NameSpace.table,
+ types: decl Name_Space.table,
log_types: string list}
val empty_tsig: tsig
val defaultS: tsig -> sort
@@ -39,7 +39,6 @@
val cert_typ: tsig -> typ -> typ
val arity_number: tsig -> string -> int
val arity_sorts: Pretty.pp -> tsig -> string -> sort -> sort list
- val the_tags: tsig -> string -> Properties.T
(*special treatment of type vars*)
val strip_sorts: typ -> typ
@@ -70,12 +69,12 @@
val eq_type: tyenv -> typ * typ -> bool
(*extend and merge type signatures*)
- val add_class: Pretty.pp -> NameSpace.naming -> binding * class list -> tsig -> tsig
+ val add_class: Pretty.pp -> Name_Space.naming -> binding * class list -> tsig -> tsig
val hide_class: bool -> string -> tsig -> tsig
val set_defsort: sort -> tsig -> tsig
- val add_type: NameSpace.naming -> Properties.T -> binding * int -> tsig -> tsig
- val add_abbrev: NameSpace.naming -> Properties.T -> binding * string list * typ -> tsig -> tsig
- val add_nonterminal: NameSpace.naming -> Properties.T -> binding -> tsig -> tsig
+ val add_type: Name_Space.naming -> binding * int -> tsig -> tsig
+ val add_abbrev: Name_Space.naming -> binding * string list * typ -> tsig -> tsig
+ val add_nonterminal: Name_Space.naming -> binding -> tsig -> tsig
val hide_type: bool -> string -> tsig -> tsig
val add_arity: Pretty.pp -> arity -> tsig -> tsig
val add_classrel: Pretty.pp -> class * class -> tsig -> tsig
@@ -94,18 +93,14 @@
Abbreviation of string list * typ * bool |
Nonterminal;
-fun str_of_decl (LogicalType _) = "logical type constructor"
- | str_of_decl (Abbreviation _) = "type abbreviation"
- | str_of_decl Nonterminal = "syntactic type";
-
(* type tsig *)
datatype tsig =
TSig of {
- classes: NameSpace.T * Sorts.algebra, (*order-sorted algebra of type classes*)
+ classes: Name_Space.T * Sorts.algebra, (*order-sorted algebra of type classes*)
default: sort, (*default sort on input*)
- types: ((decl * Properties.T) * serial) NameSpace.table, (*declared types*)
+ types: decl Name_Space.table, (*declared types*)
log_types: string list}; (*logical types sorted by number of arguments*)
fun rep_tsig (TSig comps) = comps;
@@ -113,18 +108,18 @@
fun make_tsig (classes, default, types, log_types) =
TSig {classes = classes, default = default, types = types, log_types = log_types};
-fun build_tsig ((space, classes), default, types) =
+fun build_tsig (classes, default, types) =
let
val log_types =
- Symtab.fold (fn (c, ((LogicalType n, _), _)) => cons (c, n) | _ => I) (snd types) []
- |> Library.sort (Library.int_ord o pairself snd) |> map fst;
- in make_tsig ((space, classes), default, types, log_types) end;
+ Symtab.fold (fn (c, LogicalType n) => cons (c, n) | _ => I) (snd types) []
+ |> Library.sort (int_ord o pairself snd) |> map fst;
+ in make_tsig (classes, default, types, log_types) end;
fun map_tsig f (TSig {classes, default, types, log_types = _}) =
build_tsig (f (classes, default, types));
val empty_tsig =
- build_tsig ((NameSpace.empty, Sorts.empty_algebra), [], NameSpace.empty_table);
+ build_tsig ((Name_Space.empty "class", Sorts.empty_algebra), [], Name_Space.empty_table "type");
(* classes and sorts *)
@@ -167,12 +162,7 @@
fun undecl_type c = "Undeclared type constructor: " ^ quote c;
-fun lookup_type (TSig {types, ...}) = Option.map fst o Symtab.lookup (snd types);
-
-fun the_tags tsig c =
- (case lookup_type tsig c of
- SOME (_, tags) => tags
- | NONE => error (undecl_type c));
+fun lookup_type (TSig {types = (_, types), ...}) = Symtab.lookup types;
(* certified types *)
@@ -201,13 +191,13 @@
fun nargs n = if length Ts <> n then err (bad_nargs c) else ();
in
(case lookup_type tsig c of
- SOME (LogicalType n, _) => (nargs n; Type (c, Ts'))
- | SOME (Abbreviation (vs, U, syn), _) =>
+ SOME (LogicalType n) => (nargs n; Type (c, Ts'))
+ | SOME (Abbreviation (vs, U, syn)) =>
(nargs (length vs);
if syn then check_logical c else ();
if normalize then inst_typ (vs ~~ Ts') U
else Type (c, Ts'))
- | SOME (Nonterminal, _) => (nargs 0; check_logical c; T)
+ | SOME Nonterminal => (nargs 0; check_logical c; T)
| NONE => err (undecl_type c))
end
| cert (TFree (x, S)) = TFree (x, cert_sort tsig S)
@@ -228,7 +218,7 @@
fun arity_number tsig a =
(case lookup_type tsig a of
- SOME (LogicalType n, _) => n
+ SOME (LogicalType n) => n
| _ => error (undecl_type a));
fun arity_sorts _ tsig a [] = replicate (arity_number tsig a) []
@@ -515,12 +505,12 @@
let
val cs' = map (cert_class tsig) cs
handle TYPE (msg, _, _) => error msg;
- val (c', space') = space |> NameSpace.declare naming c;
+ val (c', space') = space |> Name_Space.declare true naming c;
val classes' = classes |> Sorts.add_class pp (c', cs');
in ((space', classes'), default, types) end);
fun hide_class fully c = map_tsig (fn ((space, classes), default, types) =>
- ((NameSpace.hide fully c space, classes), default, types));
+ ((Name_Space.hide fully c space, classes), default, types));
(* arities *)
@@ -529,8 +519,8 @@
let
val _ =
(case lookup_type tsig t of
- SOME (LogicalType n, _) => if length Ss <> n then error (bad_nargs t) else ()
- | SOME (decl, _) => error ("Illegal " ^ str_of_decl decl ^ ": " ^ quote t)
+ SOME (LogicalType n) => if length Ss <> n then error (bad_nargs t) else ()
+ | SOME _ => error ("Logical type constructor expected: " ^ quote t)
| NONE => error (undecl_type t));
val (Ss', S') = (map (cert_sort tsig) Ss, cert_sort tsig S)
handle TYPE (msg, _, _) => error msg;
@@ -559,68 +549,50 @@
local
-fun err_in_decls c decl decl' =
- let val s = str_of_decl decl and s' = str_of_decl decl' in
- if s = s' then error ("Duplicate declaration of " ^ s ^ ": " ^ quote c)
- else error ("Conflict of " ^ s ^ " with " ^ s' ^ ": " ^ quote c)
- end;
-
-fun new_decl naming tags (c, decl) (space, types) =
- let
- val tags' = tags |> Position.default_properties (Position.thread_data ());
- val (c', space') = NameSpace.declare naming c space;
- val types' =
- (case Symtab.lookup types c' of
- SOME ((decl', _), _) => err_in_decls c' decl decl'
- | NONE => Symtab.update (c', ((decl, tags'), serial ())) types);
- in (space', types') end;
-
-fun the_decl (_, types) = fst o fst o the o Symtab.lookup types;
+fun new_decl naming (c, decl) types =
+ #2 (Name_Space.define true naming (c, decl) types);
fun map_types f = map_tsig (fn (classes, default, types) =>
let
val (space', tab') = f types;
- val _ = NameSpace.intern space' "dummy" = "dummy" orelse
+ val _ = Name_Space.intern space' "dummy" = "dummy" orelse
error "Illegal declaration of dummy type";
in (classes, default, (space', tab')) end);
fun syntactic types (Type (c, Ts)) =
- (case Symtab.lookup types c of SOME ((Nonterminal, _), _) => true | _ => false)
+ (case Symtab.lookup types c of SOME Nonterminal => true | _ => false)
orelse exists (syntactic types) Ts
| syntactic _ _ = false;
in
-fun add_type naming tags (c, n) =
- if n < 0 then error ("Bad type constructor declaration: " ^ quote (Binding.str_of c))
- else map_types (new_decl naming tags (c, LogicalType n));
+fun add_type naming (c, n) =
+ if n < 0 then error ("Bad type constructor declaration " ^ quote (Binding.str_of c))
+ else map_types (new_decl naming (c, LogicalType n));
-fun add_abbrev naming tags (a, vs, rhs) tsig = tsig |> map_types (fn types =>
+fun add_abbrev naming (a, vs, rhs) tsig = tsig |> map_types (fn types =>
let
fun err msg =
- cat_error msg ("The error(s) above occurred in type abbreviation: " ^ quote (Binding.str_of a));
+ cat_error msg ("The error(s) above occurred in type abbreviation " ^
+ quote (Binding.str_of a));
val rhs' = strip_sorts (no_tvars (cert_typ_mode mode_syntax tsig rhs))
handle TYPE (msg, _, _) => err msg;
- in
- (case duplicates (op =) vs of
- [] => []
- | dups => err ("Duplicate variables on lhs: " ^ commas_quote dups));
- (case subtract (op =) vs (map #1 (Term.add_tfreesT rhs' [])) of
- [] => []
- | extras => err ("Extra variables on rhs: " ^ commas_quote extras));
- types |> new_decl naming tags (a, Abbreviation (vs, rhs', syntactic (#2 types) rhs'))
- end);
+ val _ =
+ (case duplicates (op =) vs of
+ [] => []
+ | dups => err ("Duplicate variables on lhs: " ^ commas_quote dups));
+ val _ =
+ (case subtract (op =) vs (map #1 (Term.add_tfreesT rhs' [])) of
+ [] => []
+ | extras => err ("Extra variables on rhs: " ^ commas_quote extras));
+ in types |> new_decl naming (a, Abbreviation (vs, rhs', syntactic (#2 types) rhs')) end);
-fun add_nonterminal naming tags = map_types o new_decl naming tags o rpair Nonterminal;
-
-fun merge_types (types1, types2) =
- NameSpace.merge_tables (Library.eq_snd (op = : serial * serial -> bool)) (types1, types2)
- handle Symtab.DUP d => err_in_decls d (the_decl types1 d) (the_decl types2 d);
+fun add_nonterminal naming = map_types o new_decl naming o rpair Nonterminal;
end;
fun hide_type fully c = map_tsig (fn (classes, default, (space, types)) =>
- (classes, default, (NameSpace.hide fully c space, types)));
+ (classes, default, (Name_Space.hide fully c space, types)));
(* merge type signatures *)
@@ -632,10 +604,10 @@
val (TSig {classes = (space2, classes2), default = default2, types = types2,
log_types = _}) = tsig2;
- val space' = NameSpace.merge (space1, space2);
+ val space' = Name_Space.merge (space1, space2);
val classes' = Sorts.merge_algebra pp (classes1, classes2);
val default' = Sorts.inter_sort classes' (default1, default2);
- val types' = merge_types (types1, types2);
+ val types' = Name_Space.merge_tables (types1, types2);
in build_tsig ((space', classes'), default', types') end;
end;--- a/src/Tools/Code/code_thingol.ML Tue Oct 27 12:59:57 2009 +0000
+++ b/src/Tools/Code/code_thingol.ML Tue Oct 27 14:46:03 2009 +0000
@@ -252,19 +252,15 @@
(* policies *)
local
- fun thyname_of thy f x = the (AList.lookup (op =) (f x) Markup.theory_nameN);
- fun thyname_of_class thy =
- thyname_of thy (ProofContext.query_class (ProofContext.init thy));
- fun thyname_of_tyco thy =
- thyname_of thy (Type.the_tags (Sign.tsig_of thy));
- fun thyname_of_instance thy inst = case AxClass.arity_property thy inst Markup.theory_nameN
- of [] => error ("no such instance: " ^ quote (snd inst ^ " :: " ^ fst inst))
+ fun thyname_of_class thy = #theory_name o Name_Space.the_entry (Sign.class_space thy);
+ fun thyname_of_instance thy inst = case AxClass.thynames_of_arity thy inst
+ of [] => error ("No such instance: " ^ quote (snd inst ^ " :: " ^ fst inst))
| thyname :: _ => thyname;
fun thyname_of_const thy c = case AxClass.class_of_param thy c
of SOME class => thyname_of_class thy class
| NONE => (case Code.get_datatype_of_constr thy c
- of SOME dtco => thyname_of_tyco thy dtco
- | NONE => thyname_of thy (Consts.the_tags (Sign.consts_of thy)) c);
+ of SOME dtco => Codegen.thyname_of_type thy dtco
+ | NONE => Codegen.thyname_of_const thy c);
fun purify_base "op &" = "and"
| purify_base "op |" = "or"
| purify_base "op -->" = "implies"
@@ -282,10 +278,11 @@
fun namify_class thy = namify thy Long_Name.base_name thyname_of_class;
fun namify_classrel thy = namify thy (fn (class1, class2) =>
- Long_Name.base_name class2 ^ "_" ^ Long_Name.base_name class1) (fn thy => thyname_of_class thy o fst);
+ Long_Name.base_name class2 ^ "_" ^ Long_Name.base_name class1)
+ (fn thy => thyname_of_class thy o fst);
(*order fits nicely with composed projections*)
fun namify_tyco thy "fun" = "Pure.fun"
- | namify_tyco thy tyco = namify thy Long_Name.base_name thyname_of_tyco tyco;
+ | namify_tyco thy tyco = namify thy Long_Name.base_name Codegen.thyname_of_type tyco;
fun namify_instance thy = namify thy (fn (class, tyco) =>
Long_Name.base_name class ^ "_" ^ Long_Name.base_name tyco) thyname_of_instance;
fun namify_const thy = namify thy Long_Name.base_name thyname_of_const;
@@ -402,7 +399,7 @@
fun expand_eta thy k thm =
let
val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm;
- val (head, args) = strip_comb lhs;
+ val (_, args) = strip_comb lhs;
val l = if k = ~1
then (length o fst o strip_abs) rhs
else Int.max (0, k - length args);