--- a/Admin/isatest/isatest-makedist Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/isatest-makedist Fri Feb 19 15:21:57 2010 +0000
@@ -91,11 +91,9 @@
## spawn test runs
-$SSH sunbroy2 "$MAKEALL $HOME/settings/sun-poly"
+$SSH macbroy22 "$MAKEALL $HOME/settings/at-poly"
# give test some time to copy settings and start
sleep 15
-$SSH macbroy22 "$MAKEALL $HOME/settings/at-poly"
-sleep 15
$SSH macbroy20 "$MAKEALL $HOME/settings/at-poly-5.1-para-e"
sleep 15
#$SSH macbroy24 "$MAKEALL -l HOL proofterms $HOME/settings/at-sml-dev-p"
@@ -113,6 +111,8 @@
$SSH macbroy6 "sleep 10800; $MAKEALL $HOME/settings/at-mac-poly-5.1-para"
#sleep 15
#$SSH atbroy51 "$HOME/admin/isatest/isatest-annomaly"
+#sleep 15
+#$SSH sunbroy2 "$MAKEALL $HOME/settings/sun-poly"
echo ------------------- spawned tests successfully --- `date` --- $HOSTNAME >> $DISTLOG 2>&1
--- a/Admin/isatest/settings/at-mac-poly-5.1-para Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-mac-poly-5.1-para Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,4 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
+unset KODKODI
--- a/Admin/isatest/settings/at-poly Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-poly Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,4 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/at-poly-5.1-para-e Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-poly-5.1-para-e Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 10"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-poly-dev-e Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-poly-dev-e Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-sml Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml-dev-e Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-sml-dev-e Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml-dev-p Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at-sml-dev-p Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-poly Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at64-poly Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-poly-5.1-para Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at64-poly-5.1-para Fri Feb 19 15:21:57 2010 +0000
@@ -1,10 +1,10 @@
# -*- shell-script -*- :mode=shellscript:
- POLYML_HOME="/home/polyml/polyml-5.2.1"
- ML_SYSTEM="polyml-5.2.1"
+ POLYML_HOME="/home/polyml/polyml-5.3.0"
+ ML_SYSTEM="polyml-5.3.0"
ML_PLATFORM="x86_64-linux"
ML_HOME="$POLYML_HOME/$ML_PLATFORM"
- ML_OPTIONS="-H 500"
+ ML_OPTIONS="-H 1000"
ISABELLE_HOME_USER=~/isabelle-at64-poly-para-e
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 2"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-sml-dev Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/at64-sml-dev Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/mac-poly Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-poly Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,4 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -g false"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/mac-poly-M4 Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-poly-M4 Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,4 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/mac-poly-M8 Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-poly-M8 Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,5 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
+
--- a/Admin/isatest/settings/mac-poly64-M4 Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-poly64-M4 Fri Feb 19 15:21:57 2010 +0000
@@ -4,7 +4,7 @@
ML_SYSTEM="polyml-5.3.0"
ML_PLATFORM="x86_64-darwin"
ML_HOME="$POLYML_HOME/$ML_PLATFORM"
- ML_OPTIONS="--mutable 12000 --immutable 4000"
+ ML_OPTIONS="--mutable 4000 --immutable 4000"
ISABELLE_HOME_USER=~/isabelle-mac-poly64-M4
@@ -25,3 +25,5 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
+
--- a/Admin/isatest/settings/mac-poly64-M8 Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-poly64-M8 Fri Feb 19 15:21:57 2010 +0000
@@ -4,7 +4,7 @@
ML_SYSTEM="polyml-5.3.0"
ML_PLATFORM="x86_64-darwin"
ML_HOME="$POLYML_HOME/$ML_PLATFORM"
- ML_OPTIONS="--mutable 12000 --immutable 4000"
+ ML_OPTIONS="--mutable 4000 --immutable 4000"
ISABELLE_HOME_USER=~/isabelle-mac-poly64-M8
@@ -25,3 +25,5 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
+
--- a/Admin/isatest/settings/mac-sml-dev Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/mac-sml-dev Fri Feb 19 15:21:57 2010 +0000
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-poly Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/sun-poly Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,5 @@
#ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true -M 6 -q 2"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-sml Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/sun-sml Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,5 @@
# ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-sml-dev Fri Feb 05 17:19:25 2010 +0000
+++ b/Admin/isatest/settings/sun-sml-dev Fri Feb 19 15:21:57 2010 +0000
@@ -25,3 +25,5 @@
# ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/NEWS Fri Feb 05 17:19:25 2010 +0000
+++ b/NEWS Fri Feb 19 15:21:57 2010 +0000
@@ -9,13 +9,87 @@
* Code generator: details of internal data cache have no impact on
the user space functionality any longer.
+* Discontinued unnamed infix syntax (legacy feature for many years) --
+need to specify constant name and syntax separately. Internal ML
+datatype constructors have been renamed from InfixName to Infix etc.
+Minor INCOMPATIBILITY.
+
*** HOL ***
-* new theory Algebras.thy contains generic algebraic structures and
+* New set of rules "ac_simps" provides combined assoc / commute rewrites
+for all interpretations of the appropriate generic locales.
+
+* Renamed theory "OrderedGroup" to "Groups" and split theory "Ring_and_Field"
+into theories "Rings" and "Fields"; for more appropriate and more
+consistent names suitable for name prefixes within the HOL theories.
+INCOMPATIBILITY.
+
+* Some generic constants have been put to appropriate theories:
+
+ less_eq, less: Orderings
+ abs, sgn: Groups
+ inverse, divide: Rings
+
+INCOMPATIBILITY.
+
+* Class division ring also requires proof of fact divide_inverse. However instantiation
+of parameter divide has also been required previously. INCOMPATIBILITY.
+
+* More consistent naming of type classes involving orderings (and lattices):
+
+ lower_semilattice ~> semilattice_inf
+ upper_semilattice ~> semilattice_sup
+
+ dense_linear_order ~> dense_linorder
+
+ pordered_ab_group_add ~> ordered_ab_group_add
+ pordered_ab_group_add_abs ~> ordered_ab_group_add_abs
+ pordered_ab_semigroup_add ~> ordered_ab_semigroup_add
+ pordered_ab_semigroup_add_imp_le ~> ordered_ab_semigroup_add_imp_le
+ pordered_cancel_ab_semigroup_add ~> ordered_cancel_ab_semigroup_add
+ pordered_cancel_comm_semiring ~> ordered_cancel_comm_semiring
+ pordered_cancel_semiring ~> ordered_cancel_semiring
+ pordered_comm_monoid_add ~> ordered_comm_monoid_add
+ pordered_comm_ring ~> ordered_comm_ring
+ pordered_comm_semiring ~> ordered_comm_semiring
+ pordered_ring ~> ordered_ring
+ pordered_ring_abs ~> ordered_ring_abs
+ pordered_semiring ~> ordered_semiring
+
+ ordered_ab_group_add ~> linordered_ab_group_add
+ ordered_ab_semigroup_add ~> linordered_ab_semigroup_add
+ ordered_cancel_ab_semigroup_add ~> linordered_cancel_ab_semigroup_add
+ ordered_comm_semiring_strict ~> linordered_comm_semiring_strict
+ ordered_field ~> linordered_field
+ ordered_field_no_lb ~> linordered_field_no_lb
+ ordered_field_no_ub ~> linordered_field_no_ub
+ ordered_field_dense_linear_order ~> dense_linordered_field
+ ordered_idom ~> linordered_idom
+ ordered_ring ~> linordered_ring
+ ordered_ring_le_cancel_factor ~> linordered_ring_le_cancel_factor
+ ordered_ring_less_cancel_factor ~> linordered_ring_less_cancel_factor
+ ordered_ring_strict ~> linordered_ring_strict
+ ordered_semidom ~> linordered_semidom
+ ordered_semiring ~> linordered_semiring
+ ordered_semiring_1 ~> linordered_semiring_1
+ ordered_semiring_1_strict ~> linordered_semiring_1_strict
+ ordered_semiring_strict ~> linordered_semiring_strict
+
+ The following slightly odd type classes have been moved to
+ a separate theory Library/Lattice_Algebras.thy:
+
+ lordered_ab_group_add ~> lattice_ab_group_add
+ lordered_ab_group_add_abs ~> lattice_ab_group_add_abs
+ lordered_ab_group_add_meet ~> semilattice_inf_ab_group_add
+ lordered_ab_group_add_join ~> semilattice_sup_ab_group_add
+ lordered_ring ~> lattice_ring
+
+INCOMPATIBILITY.
+
+* New theory Algebras contains generic algebraic structures and
generic algebraic operations. INCOMPATIBILTY: constants zero, one,
-plus, minus, uminus, times, inverse, divide, abs, sgn, less_eq and less
-have been moved from HOL.thy to Algebras.thy.
+plus, minus, uminus and times have been moved from HOL.thy to Algebras.thy.
* HOLogic.strip_psplit: types are returned in syntactic order, similar
to other strip and tuple operations. INCOMPATIBILITY.
@@ -24,24 +98,24 @@
replaced by new-style primrec, especially in theory List. The corresponding
constants now have authentic syntax. INCOMPATIBILITY.
-* Reorganized theory Multiset.thy: less duplication, less historical
+* Reorganized theory Multiset: less duplication, less historical
organization of sections, conversion from associations lists to
multisets, rudimentary code generation. Use insert_DiffM2 [symmetric]
instead of elem_imp_eq_diff_union, if needed. INCOMPATIBILITY.
-* Reorganized theory Sum_Type.thy; Inl and Inr now have
-authentic syntax. INCOMPATIBILITY.
+* Reorganized theory Sum_Type; Inl and Inr now have authentic syntax.
+INCOMPATIBILITY.
* Code generation: ML and OCaml code is decorated with signatures.
-* Complete_Lattice.thy: lemmas top_def and bot_def have been replaced
-by the more convenient lemmas Inf_empty and Sup_empty. Dropped lemmas
-Inf_insert_simp and Sup_insert_simp, which are subsumed by Inf_insert
-and Sup_insert. Lemmas Inf_UNIV and Sup_UNIV replace former Inf_Univ
-and Sup_Univ. Lemmas inf_top_right and sup_bot_right subsume inf_top
-and sup_bot respectively. INCOMPATIBILITY.
-
-* Finite_Set.thy and List.thy: some lemmas have been generalized from
+* Theory Complete_Lattice: lemmas top_def and bot_def have been
+replaced by the more convenient lemmas Inf_empty and Sup_empty.
+Dropped lemmas Inf_insert_simp and Sup_insert_simp, which are subsumed
+by Inf_insert and Sup_insert. Lemmas Inf_UNIV and Sup_UNIV replace
+former Inf_Univ and Sup_Univ. Lemmas inf_top_right and sup_bot_right
+subsume inf_top and sup_bot respectively. INCOMPATIBILITY.
+
+* Theory Finite_Set and List: some lemmas have been generalized from
sets to lattices:
fun_left_comm_idem_inter ~> fun_left_comm_idem_inf
@@ -55,10 +129,21 @@
INTER_fold_inter ~> INFI_fold_inf
UNION_fold_union ~> SUPR_fold_sup
-* Added transpose to List.thy.
+* Theory List: added transpose.
+
+* Renamed Library/Quotient.thy to Library/Quotient_Type.thy to avoid
+clash with new theory Quotient in Main HOL.
+
*** ML ***
+* Antiquotation @{syntax_const NAME} ensures that NAME refers to a raw
+syntax constant (cf. 'syntax' command).
+
+* Renamed old-style Drule.standard to Drule.export_without_context, to
+emphasize that this is in no way a standard operation.
+INCOMPATIBILITY.
+
* Curried take and drop in library.ML; negative length is interpreted
as infinity (as in chop). INCOMPATIBILITY.
--- a/doc-src/Classes/Thy/Setup.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/Classes/Thy/Setup.thy Fri Feb 19 15:21:57 2010 +0000
@@ -18,17 +18,19 @@
fun alpha_ast_tr [] = Syntax.Variable "'a"
| alpha_ast_tr asts = raise Syntax.AST ("alpha_ast_tr", asts);
fun alpha_ofsort_ast_tr [ast] =
- Syntax.Appl [Syntax.Constant "_ofsort", Syntax.Variable "'a", ast]
+ Syntax.Appl [Syntax.Constant @{syntax_const "_ofsort"}, Syntax.Variable "'a", ast]
| alpha_ofsort_ast_tr asts = raise Syntax.AST ("alpha_ast_tr", asts);
fun beta_ast_tr [] = Syntax.Variable "'b"
| beta_ast_tr asts = raise Syntax.AST ("beta_ast_tr", asts);
fun beta_ofsort_ast_tr [ast] =
- Syntax.Appl [Syntax.Constant "_ofsort", Syntax.Variable "'b", ast]
+ Syntax.Appl [Syntax.Constant @{syntax_const "_ofsort"}, Syntax.Variable "'b", ast]
| beta_ofsort_ast_tr asts = raise Syntax.AST ("beta_ast_tr", asts);
- in [
- ("_alpha", alpha_ast_tr), ("_alpha_ofsort", alpha_ofsort_ast_tr),
- ("_beta", beta_ast_tr), ("_beta_ofsort", beta_ofsort_ast_tr)
- ] end
+ in
+ [(@{syntax_const "_alpha"}, alpha_ast_tr),
+ (@{syntax_const "_alpha_ofsort"}, alpha_ofsort_ast_tr),
+ (@{syntax_const "_beta"}, beta_ast_tr),
+ (@{syntax_const "_beta_ofsort"}, beta_ofsort_ast_tr)]
+ end
*}
end
\ No newline at end of file
--- a/doc-src/IsarImplementation/implementation.tex Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/IsarImplementation/implementation.tex Fri Feb 19 15:21:57 2010 +0000
@@ -25,7 +25,7 @@
\begin{document}
-\maketitle
+\maketitle
\begin{abstract}
We describe the key concepts underlying the Isabelle/Isar
@@ -37,7 +37,7 @@
\vspace*{2.5cm}
\begin{quote}
-
+
{\small\em Isabelle was not designed; it evolved. Not everyone
likes this idea. Specification experts rightly abhor
trial-and-error programming. They suggest that no one should
@@ -45,17 +45,28 @@
specification. But university departments are not software houses.
Programs like Isabelle are not products: when they have served
their purpose, they are discarded.}
-
+
Lawrence C. Paulson, ``Isabelle: The Next 700 Theorem Provers''
\vspace*{1cm}
-
+
{\small\em As I did 20 years ago, I still fervently believe that the
only way to make software secure, reliable, and fast is to make it
small. Fight features.}
-
+
Andrew S. Tanenbaum
+ \vspace*{1cm}
+
+ {\small\em One thing that UNIX does not need is more features. It is
+ successful in part because it has a small number of good ideas
+ that work well together. Merely adding features does not make it
+ easier for users to do things --- it just makes the manual
+ thicker. The right solution in the right place is always more
+ effective than haphazard hacking.}
+
+ Rob Pike and Brian W. Kernighan
+
\end{quote}
\thispagestyle{empty}\clearpage
@@ -89,7 +100,7 @@
\end{document}
-%%% Local Variables:
+%%% Local Variables:
%%% mode: latex
%%% TeX-master: t
-%%% End:
+%%% End:
--- a/doc-src/Main/Docs/Main_Doc.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/Main/Docs/Main_Doc.thy Fri Feb 19 15:21:57 2010 +0000
@@ -48,8 +48,8 @@
\smallskip
\begin{supertabular}{@ {} l @ {~::~} l l @ {}}
-@{const HOL.less_eq} & @{typeof HOL.less_eq} & (\verb$<=$)\\
-@{const HOL.less} & @{typeof HOL.less}\\
+@{const Algebras.less_eq} & @{typeof Algebras.less_eq} & (\verb$<=$)\\
+@{const Algebras.less} & @{typeof Algebras.less}\\
@{const Orderings.Least} & @{typeof Orderings.Least}\\
@{const Orderings.min} & @{typeof Orderings.min}\\
@{const Orderings.max} & @{typeof Orderings.max}\\
@@ -297,7 +297,7 @@
\section{Algebra}
-Theories @{theory OrderedGroup}, @{theory Ring_and_Field} and @{theory
+Theories @{theory Groups}, @{theory Rings}, @{theory Fields} and @{theory
Divides} define a large collection of classes describing common algebraic
structures from semigroups up to fields. Everything is done in terms of
overloaded operators:
--- a/doc-src/Main/Docs/document/Main_Doc.tex Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/Main/Docs/document/Main_Doc.tex Fri Feb 19 15:21:57 2010 +0000
@@ -308,7 +308,7 @@
\section{Algebra}
-Theories \isa{OrderedGroup}, \isa{Ring{\isacharunderscore}and{\isacharunderscore}Field} and \isa{Divides} define a large collection of classes describing common algebraic
+Theories \isa{Groups}, \isa{Rings}, \isa{Fields} and \isa{Divides} define a large collection of classes describing common algebraic
structures from semigroups up to fields. Everything is done in terms of
overloaded operators:
--- a/doc-src/Nitpick/nitpick.tex Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/Nitpick/nitpick.tex Fri Feb 19 15:21:57 2010 +0000
@@ -154,7 +154,7 @@
the line
\prew
-\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSatJNI}, \,\textit{max\_threads}~= 1]
+\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSat\_JNI}, \,\textit{max\_threads}~= 1]
\postw
after the \textbf{begin} keyword. The JNI version of MiniSat is bundled with
@@ -311,9 +311,9 @@
\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}$
+ & \{a_1, a_2, a_3\} := a_3,\> \{a_1, a_2\} := a_3,\> \{a_1, a_3\} := a_3, \\[-2pt] %% TYPESETTING
+ & \{a_1\} := a_1,\> \{a_2, a_3\} := a_1,\> \{a_2\} := a_2, \\[-2pt]
+ & \{a_3\} := a_3,\> \{\} := a_3)\end{aligned}$
\postw
Notice that $\textit{The}~(\lambda y.\;P~y) = \textit{The}~\{a_2, a_3\} = a_1$,
@@ -472,7 +472,9 @@
\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]
+\slshape Warning: The conjecture either trivially holds for the given scopes or (more likely) lies outside Nitpick's supported
+fragment. Only potential counterexamples may be found. \\[2\smallskipamount]
+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.
@@ -550,7 +552,7 @@
\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$
+\hbox{}\qquad\qquad $\textit{y} = a_1$
\postw
To see why the counterexample is genuine, we enable \textit{show\_consts}
@@ -558,21 +560,21 @@
\prew
{\slshape Datatype:} \\
-\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_3, a_3],\, [a_3],\, \unr\}$ \\
+\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_1],\, [a_1, a_1],\, \unr\}$ \\
{\slshape Constants:} \\
-\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_3, a_3])$ \\
-\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_3, a_3] := a_3,\> [a_3] := a_3)$
+\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_1, a_1])$ \\
+\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_1] := a_1,\> [a_1, a_1] := a_1)$
\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
+append operator whose second argument is fixed to be $[y, y]$. Appending $[a_1,
+a_1]$ to $[a_1]$ would normally give $[a_1, a_1, a_1]$, 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$.
+appending $[a_1, a_1]$ to itself gives $\unk$.
Given \textit{card}~$'a = 3$ and \textit{card}~$'a~\textit{list} = 3$, Nitpick
considers the following subsets:
@@ -600,8 +602,8 @@
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
+consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_2]\}$, and observe
+that $[a_1, a_2]$ (i.e., $a_1 \mathbin{\#} [a_2]$) has $[a_2] \notin
\mathcal{S}$ as a subterm.
Here's another m\"ochtegern-lemma that Nitpick can refute without a blink:
@@ -613,11 +615,11 @@
\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\qquad $\textit{xs} = [a_1]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [a_2]$ \\
\hbox{}\qquad Datatypes: \\
\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
-\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_3],\, [a_2],\, \unr\}$
+\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_1],\, [a_2],\, \unr\}$
\postw
Because datatypes are approximated using a three-valued logic, there is usually
@@ -642,11 +644,11 @@
\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 $P = \{\Abs{0},\, \Abs{1}\}$ \\
\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\}$
+\hbox{}\qquad\qquad $\textit{three} = \{\Abs{0},\, \Abs{1},\, \Abs{2},\, \unr\}$
\postw
%% MARK
@@ -664,12 +666,13 @@
\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\qquad $p = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
+\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\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
+\hbox{}\qquad\qquad $\textit{point} = \{\!\begin{aligned}[t]
+& \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr, \\[-2pt] %% TYPESETTING
+& \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr,\, \unr\}\end{aligned}$
\postw
Finally, Nitpick provides rudimentary support for rationals and reals using a
@@ -956,16 +959,16 @@
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]
+\hbox{}\qquad\qquad $\textit{a} = a_1$ \\
+\hbox{}\qquad\qquad $\textit{b} = a_2$ \\
+\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_2~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\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
+The lazy list $\textit{xs}$ is simply $[a_1, a_1, a_1, \ldots]$, whereas
+$\textit{ys}$ is $[a_2, a_1, a_1, a_1, \ldots]$, i.e., a lasso-shaped list with
+$[a_2]$ as its stem and $[a_1]$ 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.
@@ -1000,15 +1003,15 @@
\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 $a = a_1$ \\
\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$ \\
+\textit{LCons}~a_1~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\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}$
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega, \\[-2pt]
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\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]
@@ -1198,8 +1201,8 @@
\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]
+\hbox{}\qquad\qquad $\textit{xs} = [a_1, a_2]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [b_1, b_1]$ \\[2\smallskipamount]
Total time: 1636 ms.
\postw
@@ -1330,7 +1333,7 @@
and this time \textit{arith} can finish off the subgoals.
A similar technique can be employed for structural induction. The
-following mini-formalization of full binary trees will serve as illustration:
+following mini formalization of full binary trees will serve as illustration:
\prew
\textbf{datatype} $\kern1pt'a$~\textit{bin\_tree} = $\textit{Leaf}~{\kern1pt'a}$ $\mid$ $\textit{Branch}$ ``\kern1pt$'a$ \textit{bin\_tree}'' ``\kern1pt$'a$ \textit{bin\_tree}'' \\[2\smallskipamount]
@@ -1349,8 +1352,7 @@
obtained by swapping $a$ and $b$:
\prew
-\textbf{lemma} $``\lbrakk a \in \textit{labels}~t;\, b \in \textit{labels}~t;\, a \not= b\rbrakk {}$ \\
-\phantom{\textbf{lemma} ``}$\,{\Longrightarrow}{\;\,} \textit{labels}~(\textit{swap}~t~a~b) = \textit{labels}~t$''
+\textbf{lemma} $``\{a, b\} \subseteq \textit{labels}~t \,\Longrightarrow\, \textit{labels}~(\textit{swap}~t~a~b) = \textit{labels}~t$''
\postw
Nitpick can't find any counterexample, so we proceed with induction
@@ -1368,48 +1370,47 @@
\prew
\slshape
-Hint: To check that the induction hypothesis is general enough, try the following command:
-\textbf{nitpick}~[\textit{non\_std} ``${\kern1pt'a}~\textit{bin\_tree}$'', \textit{show\_consts}].
+Hint: To check that the induction hypothesis is general enough, try this command:
+\textbf{nitpick}~[\textit{non\_std}, \textit{show\_all}].
\postw
If we follow the hint, we get a ``nonstandard'' counterexample for the step:
\prew
-\slshape Nitpick found a nonstandard counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
+\slshape Nitpick found a nonstandard counterexample for \textit{card} $'a$ = 3: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $a = a_4$ \\
-\hbox{}\qquad\qquad $b = a_3$ \\
-\hbox{}\qquad\qquad $t = \xi_3$ \\
-\hbox{}\qquad\qquad $u = \xi_4$ \\
+\hbox{}\qquad\qquad $a = a_1$ \\
+\hbox{}\qquad\qquad $b = a_2$ \\
+\hbox{}\qquad\qquad $t = \xi_1$ \\
+\hbox{}\qquad\qquad $u = \xi_2$ \\
+\hbox{}\qquad Datatype: \nopagebreak \\
+\hbox{}\qquad\qquad $\alpha~\textit{btree} = \{\xi_1 \mathbin{=} \textit{Branch}~\xi_1~\xi_1,\> \xi_2 \mathbin{=} \textit{Branch}~\xi_2~\xi_2,\> \textit{Branch}~\xi_1~\xi_2\}$ \\
\hbox{}\qquad {\slshape Constants:} \nopagebreak \\
\hbox{}\qquad\qquad $\textit{labels} = \undef
(\!\begin{aligned}[t]%
- & \xi_3 := \{a_4\},\> \xi_4 := \{a_1, a_3\}, \\[-2pt] %% TYPESETTING
- & \textit{Branch}~\xi_3~\xi_3 := \{a_4\}, \\[-2pt]
- & \textit{Branch}~\xi_3~\xi_4 := \{a_1, a_3, a_4\})\end{aligned}$ \\
+ & \xi_1 := \{a_2, a_3\},\> \xi_2 := \{a_1\},\> \\[-2pt]
+ & \textit{Branch}~\xi_1~\xi_2 := \{a_1, a_2, a_3\})\end{aligned}$ \\
\hbox{}\qquad\qquad $\lambda x_1.\> \textit{swap}~x_1~a~b = \undef
(\!\begin{aligned}[t]%
- & \xi_3 := \xi_3,\> \xi_4 := \xi_3, \\[-2pt]
- & \textit{Branch}~\xi_3~\xi_3 := \textit{Branch}~\xi_3~\xi_3, \\[-2pt]
- & \textit{Branch}~\xi_4~\xi_3 := \textit{Branch}~\xi_3~\xi_3)\end{aligned}$ \\[2\smallskipamount]
+ & \xi_1 := \xi_2,\> \xi_2 := \xi_2, \\[-2pt]
+ & \textit{Branch}~\xi_1~\xi_2 := \xi_2)\end{aligned}$ \\[2\smallskipamount]
The existence of a nonstandard model suggests that the induction hypothesis is not general enough or perhaps
even wrong. See the ``Inductive Properties'' section of the Nitpick manual for details (``\textit{isabelle doc nitpick}'').
\postw
Reading the Nitpick manual is a most excellent idea.
-But what's going on? The \textit{non\_std} ``${\kern1pt'a}~\textit{bin\_tree}$''
-option told the tool to look for nonstandard models of binary trees, which
-means that new ``nonstandard'' trees $\xi_1, \xi_2, \ldots$, are now allowed in
-addition to the standard trees generated by the \textit{Leaf} and
-\textit{Branch} constructors.%
+But what's going on? The \textit{non\_std} option told the tool to look for
+nonstandard models of binary trees, which means that new ``nonstandard'' trees
+$\xi_1, \xi_2, \ldots$, are now allowed in addition to the standard trees
+generated by the \textit{Leaf} and \textit{Branch} constructors.%
\footnote{Notice the similarity between allowing nonstandard trees here and
allowing unreachable states in the preceding example (by removing the ``$n \in
\textit{reach\/}$'' assumption). In both cases, we effectively enlarge the
set of objects over which the induction is performed while doing the step
-so as to test the induction hypothesis's strength.}
-The new trees are so nonstandard that we know nothing about them, except what
-the induction hypothesis states and what can be proved about all trees without
-relying on induction or case distinction. The key observation is,
+in order to test the induction hypothesis's strength.}
+Unlike standard trees, these new trees contain cycles. We will see later that
+every property of acyclic trees that can be proved without using induction also
+holds for cyclic trees. Hence,
%
\begin{quote}
\textsl{If the induction
@@ -1417,9 +1418,9 @@
objects, and Nitpick won't find any nonstandard counterexample.}
\end{quote}
%
-But here, Nitpick did find some nonstandard trees $t = \xi_3$
-and $u = \xi_4$ such that $a \in \textit{labels}~t$, $b \notin
-\textit{labels}~t$, $a \notin \textit{labels}~u$, and $b \in \textit{labels}~u$.
+But here the tool find some nonstandard trees $t = \xi_1$
+and $u = \xi_2$ such that $a \notin \textit{labels}~t$, $b \in
+\textit{labels}~t$, $a \in \textit{labels}~u$, and $b \notin \textit{labels}~u$.
Because neither tree contains both $a$ and $b$, the induction hypothesis tells
us nothing about the labels of $\textit{swap}~t~a~b$ and $\textit{swap}~u~a~b$,
and as a result we know nothing about the labels of the tree
@@ -1441,7 +1442,7 @@
\postw
This time, Nitpick won't find any nonstandard counterexample, and we can perform
-the induction step using \textbf{auto}.
+the induction step using \textit{auto}.
\section{Case Studies}
\label{case-studies}
@@ -1694,7 +1695,7 @@
``$\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.}
+{\slshape Nitpick found no counterexample.}
\postw
Furthermore, applying \textit{skew} or \textit{split} to a well-formed tree
@@ -1726,8 +1727,8 @@
\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$
+\hbox{}\qquad\qquad $t = N~a_1~1~\Lambda~\Lambda$ \\
+\hbox{}\qquad\qquad $x = a_2$
\postw
It's hard to see why this is a counterexample. To improve readability, we will
@@ -1756,7 +1757,7 @@
\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.}
+{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
\postw
Insertion should transform the set of elements represented by the tree in the
@@ -1766,14 +1767,14 @@
\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.}
+{\slshape Nitpick ran out of time after checking 6 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.
+We could continue like this and sketch a complete theory of AA trees. 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}
@@ -2079,9 +2080,9 @@
{\small See also \textit{mono} (\S\ref{scope-of-search}).}
\opargbool{std}{type}{non\_std}
-Specifies whether the given type should be given standard models.
-Nonstandard models are unsound but can help debug inductive arguments,
-as explained in \S\ref{inductive-properties}.
+Specifies whether the given (recursive) datatype should be given standard
+models. Nonstandard models are unsound but can help debug structural induction
+proofs, as explained in \S\ref{inductive-properties}.
\optrue{std}{non\_std}
Specifies the default standardness to use. This can be overridden on a per-type
@@ -2138,7 +2139,7 @@
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
+\textit{MiniSat\_JNI}. Also be aware that many of the counterexamples may look
identical, unless the \textit{show\_all} (\S\ref{output-format}) option is
enabled.
@@ -2150,7 +2151,7 @@
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
+\textit{sat\_solver} = \textit{MiniSat\_JNI}. Also be aware that many of the
counterexamples may look identical, unless the \textit{show\_all}
(\S\ref{output-format}) option is enabled.
@@ -2243,7 +2244,7 @@
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}
+you will need an incremental SAT solver, such as \textit{MiniSat\_JNI}
(recommended) or \textit{SAT4J}.
The supported solvers are listed below:
@@ -2257,7 +2258,7 @@
\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)
+\item[$\bullet$] \textbf{\textit{MiniSat\_JNI}}: 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.
@@ -2279,7 +2280,7 @@
\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
+\item[$\bullet$] \textbf{\textit{zChaff\_JNI}}: 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}.
@@ -2295,7 +2296,7 @@
executable. The BerkMin executables are available at
\url{http://eigold.tripod.com/BerkMin.html}.
-\item[$\bullet$] \textbf{\textit{BerkMinAlloy}}: Variant of BerkMin that is
+\item[$\bullet$] \textbf{\textit{BerkMin\_Alloy}}: 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}
@@ -2313,7 +2314,7 @@
install the official SAT4J packages, because their API is incompatible with
Kodkod.
-\item[$\bullet$] \textbf{\textit{SAT4JLight}}: Variant of SAT4J that is
+\item[$\bullet$] \textbf{\textit{SAT4J\_Light}}: 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
@@ -2324,7 +2325,7 @@
\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, Jerusat, MiniSatJNI, and zChaffJNI
+PicoSAT, zChaff, RSat, BerkMin, BerkMin\_Alloy, Jerusat, MiniSat\_JNI, and zChaff\_JNI
that is recognized by Isabelle. If none is found, it falls back on SAT4J, which
should always be available. If \textit{verbose} (\S\ref{output-format}) is
enabled, Nitpick displays which SAT solver was chosen.
--- a/doc-src/TutorialI/Inductive/Mutual.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/TutorialI/Inductive/Mutual.thy Fri Feb 19 15:21:57 2010 +0000
@@ -67,13 +67,13 @@
text{*\noindent Everything works as before, except that
you write \commdx{inductive} instead of \isacommand{inductive\_set} and
-@{prop"evn n"} instead of @{prop"n : even"}. The notation is more
-lightweight but the usual set-theoretic operations, e.g. @{term"Even \<union> Odd"},
-are not directly available on predicates.
+@{prop"evn n"} instead of @{prop"n : even"}.
+When defining an n-ary relation as a predicate, it is recommended to curry
+the predicate: its type should be \mbox{@{text"\<tau>\<^isub>1 \<Rightarrow> \<dots> \<Rightarrow> \<tau>\<^isub>n \<Rightarrow> bool"}}
+rather than
+@{text"\<tau>\<^isub>1 \<times> \<dots> \<times> \<tau>\<^isub>n \<Rightarrow> bool"}. The curried version facilitates inductions.
-When defining an n-ary relation as a predicate it is recommended to curry
-the predicate: its type should be @{text"\<tau>\<^isub>1 \<Rightarrow> \<dots> \<Rightarrow> \<tau>\<^isub>n \<Rightarrow> bool"} rather than
-@{text"\<tau>\<^isub>1 \<times> \<dots> \<times> \<tau>\<^isub>n \<Rightarrow> bool"}. The curried version facilitates inductions.
+When should you choose sets and when predicates? If you intend to combine your notion with set theoretic notation, define it as an inductive set. If not, define it as an inductive predicate, thus avoiding the @{text"\<in>"} notation. But note that predicates of more than one argument cannot be combined with the usual set theoretic operators: @{term"P \<union> Q"} is not well-typed if @{text"P, Q :: \<tau>\<^isub>1 \<Rightarrow> \<tau>\<^isub>2 \<Rightarrow> bool"}, you have to write @{term"%x y. P x y & Q x y"} instead.
\index{inductive predicates|)}
*}
--- a/doc-src/TutorialI/Inductive/document/Mutual.tex Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/TutorialI/Inductive/document/Mutual.tex Fri Feb 19 15:21:57 2010 +0000
@@ -101,13 +101,13 @@
\begin{isamarkuptext}%
\noindent Everything works as before, except that
you write \commdx{inductive} instead of \isacommand{inductive\_set} and
-\isa{evn\ n} instead of \isa{n\ {\isasymin}\ even}. The notation is more
-lightweight but the usual set-theoretic operations, e.g. \isa{Even\ {\isasymunion}\ Odd},
-are not directly available on predicates.
+\isa{evn\ n} instead of \isa{n\ {\isasymin}\ even}.
+When defining an n-ary relation as a predicate, it is recommended to curry
+the predicate: its type should be \mbox{\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymdots}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}}
+rather than
+\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymtimes}\ {\isasymdots}\ {\isasymtimes}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}. The curried version facilitates inductions.
-When defining an n-ary relation as a predicate it is recommended to curry
-the predicate: its type should be \isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymdots}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool} rather than
-\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymtimes}\ {\isasymdots}\ {\isasymtimes}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}. The curried version facilitates inductions.
+When should you choose sets and when predicates? If you intend to combine your notion with set theoretic notation, define it as an inductive set. If not, define it as an inductive predicate, thus avoiding the \isa{{\isasymin}} notation. But note that predicates of more than one argument cannot be combined with the usual set theoretic operators: \isa{P\ {\isasymunion}\ Q} is not well-typed if \isa{P{\isacharcomma}\ Q\ {\isacharcolon}{\isacharcolon}\ {\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub {\isadigit{2}}\ {\isasymRightarrow}\ bool}, you have to write \isa{{\isasymlambda}x\ y{\isachardot}\ P\ x\ y\ {\isasymand}\ Q\ x\ y} instead.
\index{inductive predicates|)}%
\end{isamarkuptext}%
\isamarkuptrue%
--- a/doc-src/TutorialI/Protocol/Message.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/TutorialI/Protocol/Message.thy Fri Feb 19 15:21:57 2010 +0000
@@ -82,14 +82,14 @@
(*<*)
text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
syntax (xsymbols)
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
translations
"{|x, y, z|}" == "{|x, {|y, z|}|}"
- "{|x, y|}" == "MPair x y"
+ "{|x, y|}" == "CONST MPair x y"
constdefs
--- a/doc-src/TutorialI/Types/document/Numbers.tex Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/TutorialI/Types/document/Numbers.tex Fri Feb 19 15:21:57 2010 +0000
@@ -107,7 +107,7 @@
\rulename{add_commute}
\begin{isabelle}%
-a\ {\isacharplus}\ {\isacharparenleft}b\ {\isacharplus}\ c{\isacharparenright}\ {\isacharequal}\ b\ {\isacharplus}\ {\isacharparenleft}a\ {\isacharplus}\ c{\isacharparenright}%
+b\ {\isacharplus}\ {\isacharparenleft}a\ {\isacharplus}\ c{\isacharparenright}\ {\isacharequal}\ a\ {\isacharplus}\ {\isacharparenleft}b\ {\isacharplus}\ c{\isacharparenright}%
\end{isabelle}
\rulename{add_left_commute}
--- a/doc-src/manual.bib Fri Feb 05 17:19:25 2010 +0000
+++ b/doc-src/manual.bib Fri Feb 19 15:21:57 2010 +0000
@@ -3,7 +3,7 @@
%publishers
@string{AP="Academic Press"}
@string{CUP="Cambridge University Press"}
-@string{IEEE="{\sc ieee} Computer Society Press"}
+@string{IEEE="IEEE Computer Society Press"}
@string{LNCS="Lecture Notes in Computer Science"}
@string{MIT="MIT Press"}
@string{NH="North-Holland"}
--- a/etc/components Fri Feb 05 17:19:25 2010 +0000
+++ b/etc/components Fri Feb 19 15:21:57 2010 +0000
@@ -13,6 +13,7 @@
#misc components
src/Tools/Code
src/Tools/WWW_Find
+src/Tools/Cache_IO
src/HOL/Tools/ATP_Manager
src/HOL/Mirabelle
src/HOL/Library/Sum_Of_Squares
--- a/etc/settings Fri Feb 05 17:19:25 2010 +0000
+++ b/etc/settings Fri Feb 19 15:21:57 2010 +0000
@@ -50,12 +50,6 @@
#ML_PLATFORM=$(eval $("$ML_HOME/.arch-n-opsys" 2>/dev/null); echo "$HEAP_SUFFIX")
#SMLNJ_CYGWIN_RUNTIME=1
-# Moscow ML 2.00 (experimental!)
-#ML_SYSTEM=mosml
-#ML_HOME="/usr/local/mosml/bin"
-#ML_OPTIONS=""
-#ML_PLATFORM=""
-
###
### JVM components (Scala or Java)
--- a/lib/Tools/keywords Fri Feb 05 17:19:25 2010 +0000
+++ b/lib/Tools/keywords Fri Feb 19 15:21:57 2010 +0000
@@ -66,5 +66,4 @@
gzip -dc "$LOG"
fi
echo
-done | \
-perl -w "$ISABELLE_HOME/lib/scripts/keywords.pl" "$KEYWORDS_NAME" "$SESSIONS"
+done | "$ISABELLE_HOME/lib/scripts/keywords" "$KEYWORDS_NAME" "$SESSIONS"
--- a/lib/Tools/unsymbolize Fri Feb 05 17:19:25 2010 +0000
+++ b/lib/Tools/unsymbolize Fri Feb 19 15:21:57 2010 +0000
@@ -34,4 +34,4 @@
## main
find $SPECS \( -name \*.ML -o -name \*.thy \) -print | \
- xargs perl -w "$ISABELLE_HOME/lib/scripts/unsymbolize.pl"
+ xargs "$ISABELLE_HOME/lib/scripts/unsymbolize"
--- a/lib/Tools/yxml Fri Feb 05 17:19:25 2010 +0000
+++ b/lib/Tools/yxml Fri Feb 19 15:21:57 2010 +0000
@@ -31,4 +31,4 @@
## main
-exec perl -w "$ISABELLE_HOME/lib/scripts/yxml.pl"
+exec "$ISABELLE_HOME/lib/scripts/yxml"
--- a/lib/fonts/IsabelleText.sfd Fri Feb 05 17:19:25 2010 +0000
+++ b/lib/fonts/IsabelleText.sfd Fri Feb 19 15:21:57 2010 +0000
@@ -13,13 +13,14 @@
LayerCount: 2
Layer: 0 1 "Back" 1
Layer: 1 1 "Fore" 0
+NeedsXUIDChange: 1
XUID: [1021 906 1711068302 4288927]
FSType: 4
OS2Version: 1
OS2_WeightWidthSlopeOnly: 0
OS2_UseTypoMetrics: 1
CreationTime: 1050361371
-ModificationTime: 1263327886
+ModificationTime: 1265397211
PfmFamily: 17
TTFWeight: 400
TTFWidth: 5
@@ -2240,7 +2241,7 @@
DisplaySize: -48
AntiAlias: 1
FitToEm: 1
-WinInfo: 160 16 10
+WinInfo: 8800 16 10
TeXData: 1 0 0 631296 315648 210432 572416 -1048576 210432 783286 444596 497025 792723 393216 433062 380633 303038 157286 324010 404750 52429 2506097 1059062 262144
BeginChars: 1114189 648
@@ -13869,61 +13870,67 @@
LayerCount: 2
Fore
SplineSet
-1401 1505 m 6,0,-1
- 402 -440 l 2,1,2
- 382 -480 382 -480 353 -480 c 0,3,4
- 332 -480 332 -480 320.5 -465 c 128,-1,5
- 309 -450 309 -450 309 -435 c 0,6,7
- 309 -426 309 -426 324 -395 c 2,8,-1
- 1323 1550 l 2,9,10
- 1343 1590 1343 1590 1372 1590 c 0,11,12
- 1393 1590 1393 1590 1404.5 1575 c 128,-1,13
- 1416 1560 1416 1560 1416 1545 c 0,14,15
- 1417 1536 1417 1536 1401 1505 c 6,0,-1
-1525 726 m 2,16,-1
- 200 726 l 2,17,18
- 186 726 186 726 178.5 726.5 c 128,-1,19
- 171 727 171 727 159 729 c 128,-1,20
- 147 731 147 731 140.5 735.5 c 128,-1,21
- 134 740 134 740 129 749 c 128,-1,22
- 124 758 124 758 124 770 c 0,23,24
- 124 786 124 786 130.5 796 c 128,-1,25
- 137 806 137 806 150 809.5 c 128,-1,26
- 163 813 163 813 172 814 c 128,-1,27
- 181 815 181 815 198 815 c 2,28,-1
- 1527 815 l 2,29,30
- 1543 815 1543 815 1552.5 814 c 128,-1,31
- 1562 813 1562 813 1575 809.5 c 128,-1,32
- 1588 806 1588 806 1594.5 796 c 128,-1,33
- 1601 786 1601 786 1601 770 c 0,34,35
- 1601 757 1601 757 1595.5 748.5 c 128,-1,36
- 1590 740 1590 740 1584 735.5 c 128,-1,37
- 1578 731 1578 731 1566 729 c 128,-1,38
- 1554 727 1554 727 1546.5 726.5 c 128,-1,39
- 1539 726 1539 726 1525 726 c 2,16,-1
-1527 295 m 2,40,-1
- 198 295 l 2,41,42
- 182 295 182 295 172.5 296 c 128,-1,43
- 163 297 163 297 150 300.5 c 128,-1,44
- 137 304 137 304 130.5 314 c 128,-1,45
- 124 324 124 324 124 340 c 0,46,47
- 124 353 124 353 129 361.5 c 128,-1,48
- 134 370 134 370 140.5 374.5 c 128,-1,49
- 147 379 147 379 159 381 c 128,-1,50
- 171 383 171 383 178.5 383.5 c 128,-1,51
- 186 384 186 384 200 384 c 2,52,-1
- 1525 384 l 2,53,54
- 1539 384 1539 384 1546.5 383.5 c 128,-1,55
- 1554 383 1554 383 1566 381 c 128,-1,56
- 1578 379 1578 379 1584 374.5 c 128,-1,57
- 1590 370 1590 370 1595.5 361 c 128,-1,58
- 1601 352 1601 352 1601 340 c 0,59,60
- 1601 324 1601 324 1594.5 314 c 128,-1,61
- 1588 304 1588 304 1575 300.5 c 128,-1,62
- 1562 297 1562 297 1552.5 296 c 128,-1,63
- 1543 295 1543 295 1527 295 c 2,40,-1
-EndSplineSet
-Validated: 5
+945 815 m 1,0,-1
+ 1323 1550 l 2,1,2
+ 1343 1590 1343 1590 1372 1590 c 0,3,4
+ 1393 1590 1393 1590 1404.5 1575 c 128,-1,5
+ 1416 1560 1416 1560 1416 1545 c 1,6,7
+ 1417 1536 1417 1536 1401 1505 c 2,8,-1
+ 1047 815 l 1,9,-1
+ 1527 815 l 2,10,11
+ 1543 815 1543 815 1552.5 814 c 128,-1,12
+ 1562 813 1562 813 1575 809.5 c 128,-1,13
+ 1588 806 1588 806 1594.5 796 c 128,-1,14
+ 1601 786 1601 786 1601 770 c 0,15,16
+ 1601 757 1601 757 1595.5 748.5 c 128,-1,17
+ 1590 740 1590 740 1584 735.5 c 128,-1,18
+ 1578 731 1578 731 1566 729 c 128,-1,19
+ 1554 727 1554 727 1546.5 726.5 c 128,-1,20
+ 1539 726 1539 726 1525 726 c 2,21,-1
+ 1001 726 l 1,22,-1
+ 825 384 l 1,23,-1
+ 1525 384 l 2,24,25
+ 1539 384 1539 384 1546.5 383.5 c 128,-1,26
+ 1554 383 1554 383 1566 381 c 128,-1,27
+ 1578 379 1578 379 1584 374.5 c 128,-1,28
+ 1590 370 1590 370 1595.5 361 c 128,-1,29
+ 1601 352 1601 352 1601 340 c 0,30,31
+ 1601 324 1601 324 1594.5 314 c 128,-1,32
+ 1588 304 1588 304 1575 300.5 c 128,-1,33
+ 1562 297 1562 297 1552.5 296 c 128,-1,34
+ 1543 295 1543 295 1527 295 c 2,35,-1
+ 780 295 l 1,36,-1
+ 402 -440 l 2,37,38
+ 382 -480 382 -480 353 -480 c 0,39,40
+ 332 -480 332 -480 320.5 -465 c 128,-1,41
+ 309 -450 309 -450 309 -435 c 0,42,43
+ 309 -426 309 -426 324 -395 c 2,44,-1
+ 678 295 l 1,45,-1
+ 198 295 l 2,46,47
+ 182 295 182 295 172.5 296 c 128,-1,48
+ 163 297 163 297 150 300.5 c 128,-1,49
+ 137 304 137 304 130.5 314 c 128,-1,50
+ 124 324 124 324 124 340 c 0,51,52
+ 124 353 124 353 129 361.5 c 128,-1,53
+ 134 370 134 370 140.5 374.5 c 128,-1,54
+ 147 379 147 379 159 381 c 128,-1,55
+ 171 383 171 383 178.5 383.5 c 128,-1,56
+ 186 384 186 384 200 384 c 2,57,-1
+ 724 384 l 1,58,-1
+ 900 726 l 1,59,-1
+ 200 726 l 2,60,61
+ 186 726 186 726 178.5 726.5 c 128,-1,62
+ 171 727 171 727 159 729 c 128,-1,63
+ 147 731 147 731 140.5 735.5 c 128,-1,64
+ 134 740 134 740 129 749 c 128,-1,65
+ 124 758 124 758 124 770 c 0,66,67
+ 124 786 124 786 130 796 c 0,68,69
+ 137 806 137 806 150 809.5 c 128,-1,70
+ 163 813 163 813 172 814 c 128,-1,71
+ 181 815 181 815 198 815 c 2,72,-1
+ 945 815 l 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: AE
@@ -14371,6 +14378,7 @@
1544 695 1544 695 1527 695 c 2,55,-1
908 695 l 1,0,-1
EndSplineSet
+Validated: 1
EndChar
StartChar: lessequal
@@ -17238,6 +17246,7 @@
163 598 163 598 172.5 599 c 128,-1,43
182 600 182 600 198 600 c 2,24,-1
EndSplineSet
+Validated: 33
EndChar
StartChar: lozenge
@@ -17930,6 +17939,7 @@
357 672 357 672 391.5 637.5 c 128,-1,0
426 603 426 603 426 555 c 128,-1,1
EndSplineSet
+Validated: 33
EndChar
StartChar: quotesinglbase
@@ -18068,7 +18078,7 @@
2098 665 2098 665 2080 634.5 c 128,-1,13
2062 604 2062 604 2049 563.5 c 128,-1,14
2036 523 2036 523 2027.5 460.5 c 128,-1,15
- 2019 398 2019 398 2019 322 c 0,16,17
+ 2019 398 2019 398 2019 322 c 128,-1,17
2019 246 2019 246 2027.5 184 c 128,-1,18
2036 122 2036 122 2049 81.5 c 128,-1,19
2062 41 2062 41 2080.5 11 c 128,-1,20
@@ -18145,7 +18155,7 @@
353 1560 353 1560 335 1529.5 c 128,-1,110
317 1499 317 1499 304 1458.5 c 128,-1,111
291 1418 291 1418 282.5 1355.5 c 128,-1,112
- 274 1293 274 1293 274 1217 c 0,113,114
+ 274 1293 274 1293 274 1217 c 128,-1,114
274 1141 274 1141 282.5 1079 c 128,-1,115
291 1017 291 1017 304 976.5 c 128,-1,116
317 936 317 936 335.5 905.5 c 128,-1,117
@@ -18166,7 +18176,7 @@
1337 665 1337 665 1318.5 634.5 c 128,-1,134
1300 604 1300 604 1287 563.5 c 128,-1,135
1274 523 1274 523 1266 460.5 c 128,-1,136
- 1258 398 1258 398 1258 322 c 0,137,138
+ 1258 398 1258 398 1258 322 c 128,-1,138
1258 246 1258 246 1266 184 c 128,-1,139
1274 122 1274 122 1287.5 81.5 c 128,-1,140
1301 41 1301 41 1319 11 c 128,-1,141
@@ -20091,6 +20101,7 @@
1389 1018 1389 1018 1370 999 c 2,41,-1
928 555 l 1,0,-1
EndSplineSet
+Validated: 1
EndChar
StartChar: uni00B9
@@ -28736,75 +28747,63 @@
LayerCount: 2
Fore
SplineSet
-213 511 m 5,0,-1
- 213 215 l 2,1,2
- 213 199 213 199 212 190 c 128,-1,3
- 211 181 211 181 207.5 168 c 128,-1,4
- 204 155 204 155 194 148.5 c 128,-1,5
- 184 142 184 142 168.5 142 c 128,-1,6
- 153 142 153 142 143 148.5 c 128,-1,7
- 133 155 133 155 129.5 168 c 128,-1,8
- 126 181 126 181 125 190 c 128,-1,9
- 124 199 124 199 124 215 c 2,10,-1
- 124 895 l 2,11,12
- 124 911 124 911 125 920 c 128,-1,13
- 126 929 126 929 129.5 942 c 128,-1,14
- 133 955 133 955 143 961.5 c 128,-1,15
- 153 968 153 968 168.5 968 c 128,-1,16
- 184 968 184 968 194 961.5 c 128,-1,17
- 204 955 204 955 207.5 942 c 128,-1,18
- 211 929 211 929 212 920 c 128,-1,19
- 213 911 213 911 213 895 c 2,20,-1
- 213 599 l 1,21,22
- 275 599 275 599 275 555 c 128,-1,23
- 275 511 275 511 213 511 c 5,0,-1
-1905 511 m 5,24,-1
- 198 511 l 2,25,26
- 184 511 184 511 177 511 c 128,-1,27
- 170 511 170 511 158 513.5 c 128,-1,28
- 146 516 146 516 140 520.5 c 128,-1,29
- 134 525 134 525 129 533.5 c 128,-1,30
- 124 542 124 542 124 555 c 128,-1,31
- 124 568 124 568 129 576.5 c 128,-1,32
- 134 585 134 585 140 589.5 c 128,-1,33
- 146 594 146 594 158 596.5 c 128,-1,34
- 170 599 170 599 177 599 c 128,-1,35
- 184 599 184 599 198 599 c 2,36,-1
- 1905 599 l 1,37,38
- 1847 641 1847 641 1798 698 c 128,-1,39
- 1749 755 1749 755 1722 802 c 128,-1,40
- 1695 849 1695 849 1680 882 c 128,-1,41
- 1665 915 1665 915 1665 924 c 0,42,43
- 1665 938 1665 938 1675 944 c 128,-1,44
- 1685 950 1685 950 1698 950 c 0,45,46
- 1715 950 1715 950 1721.5 943.5 c 128,-1,47
- 1728 937 1728 937 1736 919 c 0,48,49
- 1769 846 1769 846 1809.5 788.5 c 128,-1,50
- 1850 731 1850 731 1896.5 691.5 c 128,-1,51
- 1943 652 1943 652 1983.5 626.5 c 128,-1,52
- 2024 601 2024 601 2076 577 c 1,53,54
- 2079 577 2079 577 2085 571 c 128,-1,55
- 2091 565 2091 565 2091 555 c 0,56,57
- 2091 544 2091 544 2086 539 c 128,-1,58
- 2081 534 2081 534 2060 524 c 0,59,60
- 2014 502 2014 502 1973.5 475.5 c 128,-1,61
- 1933 449 1933 449 1904 424.5 c 128,-1,62
- 1875 400 1875 400 1848.5 369 c 128,-1,63
- 1822 338 1822 338 1806.5 316 c 128,-1,64
- 1791 294 1791 294 1774.5 264 c 128,-1,65
- 1758 234 1758 234 1751 220 c 128,-1,66
- 1744 206 1744 206 1734 182 c 0,67,68
- 1730 174 1730 174 1728.5 171.5 c 128,-1,69
- 1727 169 1727 169 1719 164.5 c 128,-1,70
- 1711 160 1711 160 1698 160 c 0,71,72
- 1684 160 1684 160 1674.5 166.5 c 128,-1,73
- 1665 173 1665 173 1665 186 c 0,74,75
- 1665 195 1665 195 1680 228 c 128,-1,76
- 1695 261 1695 261 1722 308 c 128,-1,77
- 1749 355 1749 355 1798 412 c 128,-1,78
- 1847 469 1847 469 1905 511 c 5,24,-1
-EndSplineSet
-Validated: 5
+213 599 m 1,0,-1
+ 1905 599 l 1,1,2
+ 1847 641 1847 641 1798 698 c 128,-1,3
+ 1749 755 1749 755 1722 802 c 128,-1,4
+ 1695 849 1695 849 1680 882 c 128,-1,5
+ 1665 915 1665 915 1665 924 c 0,6,7
+ 1665 938 1665 938 1675 944 c 128,-1,8
+ 1685 950 1685 950 1698 950 c 0,9,10
+ 1715 950 1715 950 1722 944 c 0,11,12
+ 1728 937 1728 937 1736 919 c 0,13,14
+ 1767 848 1767 848 1810 788 c 0,15,16
+ 1850 731 1850 731 1896.5 691.5 c 128,-1,17
+ 1943 652 1943 652 1983.5 626.5 c 128,-1,18
+ 2024 601 2024 601 2076 577 c 1,19,20
+ 2079 577 2079 577 2085 571 c 128,-1,21
+ 2091 565 2091 565 2091 555 c 0,22,23
+ 2091 544 2091 544 2086 539 c 128,-1,24
+ 2081 534 2081 534 2060 524 c 0,25,26
+ 2014 502 2014 502 1973.5 475.5 c 128,-1,27
+ 1933 449 1933 449 1904 424.5 c 128,-1,28
+ 1875 400 1875 400 1848.5 369 c 128,-1,29
+ 1822 338 1822 338 1806.5 316 c 128,-1,30
+ 1791 294 1791 294 1774.5 264 c 128,-1,31
+ 1758 234 1758 234 1751 220 c 128,-1,32
+ 1744 206 1744 206 1734 182 c 0,33,34
+ 1730 174 1730 174 1728.5 171.5 c 128,-1,35
+ 1727 169 1727 169 1719 164.5 c 128,-1,36
+ 1711 160 1711 160 1698 160 c 0,37,38
+ 1684 160 1684 160 1674 166 c 0,39,40
+ 1665 173 1665 173 1665 186 c 0,41,42
+ 1665 195 1665 195 1680 228 c 128,-1,43
+ 1695 261 1695 261 1722 308 c 128,-1,44
+ 1749 355 1749 355 1798 412 c 128,-1,45
+ 1847 469 1847 469 1905 511 c 1,46,-1
+ 213 511 l 1,47,-1
+ 213 215 l 2,48,49
+ 213 199 213 199 212 190 c 128,-1,50
+ 211 181 211 181 207.5 168 c 128,-1,51
+ 204 155 204 155 194 148.5 c 128,-1,52
+ 184 142 184 142 168.5 142 c 128,-1,53
+ 153 142 153 142 143 148.5 c 128,-1,54
+ 133 155 133 155 129.5 168 c 128,-1,55
+ 126 181 126 181 125 190 c 128,-1,56
+ 124 199 124 199 124 215 c 2,57,-1
+ 124 555 l 1,58,-1
+ 124 895 l 2,59,60
+ 124 911 124 911 125 920 c 128,-1,61
+ 126 929 126 929 129.5 942 c 128,-1,62
+ 133 955 133 955 143 961.5 c 128,-1,63
+ 153 968 153 968 168.5 968 c 128,-1,64
+ 184 968 184 968 194 961.5 c 128,-1,65
+ 204 955 204 955 207.5 942 c 128,-1,66
+ 211 929 211 929 212 920 c 128,-1,67
+ 213 911 213 911 213 895 c 2,68,-1
+ 213 599 l 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni21A9
@@ -28817,78 +28816,68 @@
LayerCount: 2
Fore
SplineSet
-2045 511 m 6,0,-1
- 337 511 l 1,1,2
- 395 469 395 469 444.5 412 c 128,-1,3
- 494 355 494 355 521 308 c 128,-1,4
- 548 261 548 261 562.5 228 c 128,-1,5
- 577 195 577 195 577 186 c 0,6,7
- 577 172 577 172 567 166 c 128,-1,8
- 557 160 557 160 544 160 c 0,9,10
- 527 160 527 160 520.5 166.5 c 128,-1,11
- 514 173 514 173 506 191 c 0,12,13
- 455 301 455 301 380 383.5 c 128,-1,14
- 305 466 305 466 178 526 c 0,15,16
- 172 529 172 529 167 532 c 128,-1,17
- 162 535 162 535 158.5 538 c 128,-1,18
- 155 541 155 541 153 545 c 128,-1,19
- 151 549 151 549 151 555 c 0,20,21
- 151 561 151 561 151.5 564 c 128,-1,22
- 152 567 152 567 158 571.5 c 128,-1,23
- 164 576 164 576 166 577 c 128,-1,24
- 168 578 168 578 182 586 c 0,25,26
- 245 616 245 616 298 655.5 c 128,-1,27
- 351 695 351 695 383 728.5 c 128,-1,28
- 415 762 415 762 443 805 c 128,-1,29
- 471 848 471 848 482.5 871.5 c 128,-1,30
- 494 895 494 895 508 928 c 0,31,32
- 512 936 512 936 514 938.5 c 128,-1,33
- 516 941 516 941 524 945.5 c 128,-1,34
- 532 950 532 950 544 950 c 0,35,36
- 558 950 558 950 567.5 943.5 c 128,-1,37
- 577 937 577 937 577 924 c 0,38,39
- 577 915 577 915 562.5 882 c 128,-1,40
- 548 849 548 849 521 802 c 128,-1,41
- 494 755 494 755 444.5 698.5 c 128,-1,42
- 395 642 395 642 337 599 c 1,43,-1
- 2045 599 l 2,44,45
- 2059 599 2059 599 2066 599 c 128,-1,46
- 2073 599 2073 599 2084.5 596.5 c 128,-1,47
- 2096 594 2096 594 2102 589.5 c 128,-1,48
- 2108 585 2108 585 2113 576.5 c 128,-1,49
- 2118 568 2118 568 2118 555 c 128,-1,50
- 2118 542 2118 542 2113 533.5 c 128,-1,51
- 2108 525 2108 525 2102 520.5 c 128,-1,52
- 2096 516 2096 516 2084.5 513.5 c 128,-1,53
- 2073 511 2073 511 2066 511 c 128,-1,54
- 2059 511 2059 511 2045 511 c 6,0,-1
-2402 770.5 m 132,-1,56
- 2402 720 2402 720 2382 676.5 c 128,-1,57
- 2362 633 2362 633 2329.5 603 c 128,-1,58
- 2297 573 2297 573 2255.5 551.5 c 128,-1,59
- 2214 530 2214 530 2171 520.5 c 128,-1,60
- 2128 511 2128 511 2087 511 c 0,61,62
- 2031 511 2031 511 2031 555 c 0,63,64
- 2031 558 2031 558 2032 563 c 128,-1,65
- 2033 568 2033 568 2037 577 c 128,-1,66
- 2041 586 2041 586 2051.5 592.5 c 128,-1,67
- 2062 599 2062 599 2078 599 c 0,68,69
- 2194 604 2194 604 2253.5 653.5 c 128,-1,70
- 2313 703 2313 703 2313 770 c 0,71,72
- 2313 798 2313 798 2302 824.5 c 128,-1,73
- 2291 851 2291 851 2266 877 c 128,-1,74
- 2241 903 2241 903 2192 920.5 c 128,-1,75
- 2143 938 2143 938 2076 941 c 0,76,77
- 2054 943 2054 943 2042.5 956 c 128,-1,78
- 2031 969 2031 969 2031 986 c 0,79,80
- 2031 1030 2031 1030 2087 1030 c 0,81,82
- 2128 1030 2128 1030 2171 1020 c 128,-1,83
- 2214 1010 2214 1010 2255.5 989 c 128,-1,84
- 2297 968 2297 968 2329.5 938 c 128,-1,85
- 2362 908 2362 908 2382 864.5 c 128,-1,55
- 2402 821 2402 821 2402 770.5 c 132,-1,56
-EndSplineSet
-Validated: 5
+2402 770.5 m 128,-1,1
+ 2402 720 2402 720 2382 676.5 c 128,-1,2
+ 2362 633 2362 633 2329.5 603 c 128,-1,3
+ 2297 573 2297 573 2256 552 c 0,4,5
+ 2211 528 2211 528 2171 520 c 0,6,7
+ 2126 511 2126 511 2087 511 c 0,8,9
+ 2080 511 2080 511 2074 512 c 1,10,11
+ 2070 511 2070 511 2066 511 c 2,12,-1
+ 2045 511 l 1,13,-1
+ 337 511 l 1,14,15
+ 395 469 395 469 444.5 412 c 128,-1,16
+ 494 355 494 355 521 308 c 128,-1,17
+ 548 261 548 261 562.5 228 c 128,-1,18
+ 577 195 577 195 577 186 c 0,19,20
+ 577 172 577 172 567 166 c 128,-1,21
+ 557 160 557 160 544 160 c 0,22,23
+ 527 160 527 160 520.5 166.5 c 128,-1,24
+ 514 173 514 173 506 191 c 0,25,26
+ 455 301 455 301 380 383.5 c 128,-1,27
+ 305 466 305 466 178 526 c 0,28,29
+ 172 529 172 529 167 532 c 128,-1,30
+ 162 535 162 535 158.5 538 c 128,-1,31
+ 155 541 155 541 153 545 c 128,-1,32
+ 151 549 151 549 151 555 c 128,-1,33
+ 151 561 151 561 151.5 564 c 128,-1,34
+ 152 567 152 567 158 571.5 c 128,-1,35
+ 164 576 164 576 166 577 c 128,-1,36
+ 168 578 168 578 182 586 c 1,37,38
+ 245 616 245 616 298 655.5 c 128,-1,39
+ 351 695 351 695 383 728 c 0,40,41
+ 415 762 415 762 443 805 c 128,-1,42
+ 471 848 471 848 482.5 871.5 c 128,-1,43
+ 494 895 494 895 508 928 c 0,44,45
+ 512 936 512 936 514 938.5 c 128,-1,46
+ 516 941 516 941 524 945.5 c 128,-1,47
+ 532 950 532 950 544 950 c 0,48,49
+ 558 950 558 950 567.5 943.5 c 128,-1,50
+ 577 937 577 937 577 924 c 0,51,52
+ 577 915 577 915 562.5 882 c 128,-1,53
+ 548 849 548 849 521 802 c 128,-1,54
+ 494 755 494 755 444.5 698.5 c 128,-1,55
+ 395 642 395 642 337 599 c 1,56,-1
+ 2045 599 l 1,57,-1
+ 2066 599 l 2,58,59
+ 2068 599 2068 599 2071 599 c 128,-1,60
+ 2074 599 2074 599 2078 599 c 0,61,62
+ 2188 599 2188 599 2254 654 c 0,63,64
+ 2313 703 2313 703 2313 770 c 0,65,66
+ 2313 798 2313 798 2302 824.5 c 128,-1,67
+ 2291 851 2291 851 2266 877 c 128,-1,68
+ 2241 903 2241 903 2192 920.5 c 128,-1,69
+ 2143 938 2143 938 2076 941 c 1,70,71
+ 2054 943 2054 943 2042 956 c 0,72,73
+ 2031 969 2031 969 2031 986 c 0,74,75
+ 2031 1030 2031 1030 2087 1030 c 0,76,77
+ 2128 1030 2128 1030 2171 1020 c 0,78,79
+ 2216 1010 2216 1010 2256 989 c 0,80,81
+ 2297 968 2297 968 2330 938 c 0,82,83
+ 2362 908 2362 908 2382 864.5 c 128,-1,0
+ 2402 821 2402 821 2402 770.5 c 128,-1,1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni21AA
@@ -28901,78 +28890,69 @@
LayerCount: 2
Fore
SplineSet
-2211 511 m 5,0,-1
- 504 511 l 2,1,2
- 490 511 490 511 483 511 c 128,-1,3
- 476 511 476 511 464.5 513.5 c 128,-1,4
- 453 516 453 516 446.5 520.5 c 128,-1,5
- 440 525 440 525 435.5 533.5 c 128,-1,6
- 431 542 431 542 431 555 c 128,-1,7
- 431 568 431 568 435.5 576.5 c 128,-1,8
- 440 585 440 585 446.5 589.5 c 128,-1,9
- 453 594 453 594 464.5 596.5 c 128,-1,10
- 476 599 476 599 483 599 c 128,-1,11
- 490 599 490 599 504 599 c 2,12,-1
- 2211 599 l 1,13,14
- 2153 641 2153 641 2104 698 c 128,-1,15
- 2055 755 2055 755 2028 802 c 128,-1,16
- 2001 849 2001 849 1986 882 c 128,-1,17
- 1971 915 1971 915 1971 924 c 0,18,19
- 1971 938 1971 938 1981 944 c 128,-1,20
- 1991 950 1991 950 2005 950 c 0,21,22
- 2022 950 2022 950 2028 943.5 c 128,-1,23
- 2034 937 2034 937 2042 919 c 0,24,25
- 2075 846 2075 846 2115.5 788.5 c 128,-1,26
- 2156 731 2156 731 2202.5 691.5 c 128,-1,27
- 2249 652 2249 652 2290 626.5 c 128,-1,28
- 2331 601 2331 601 2382 577 c 1,29,30
- 2385 577 2385 577 2391.5 571 c 128,-1,31
- 2398 565 2398 565 2398 555 c 0,32,33
- 2398 544 2398 544 2393 539 c 128,-1,34
- 2388 534 2388 534 2367 524 c 0,35,36
- 2321 502 2321 502 2280.5 475.5 c 128,-1,37
- 2240 449 2240 449 2211 424.5 c 128,-1,38
- 2182 400 2182 400 2155.5 369 c 128,-1,39
- 2129 338 2129 338 2113 316 c 128,-1,40
- 2097 294 2097 294 2080.5 264 c 128,-1,41
- 2064 234 2064 234 2057.5 220 c 128,-1,42
- 2051 206 2051 206 2040 182 c 0,43,44
- 2036 174 2036 174 2034.5 171.5 c 128,-1,45
- 2033 169 2033 169 2025 164.5 c 128,-1,46
- 2017 160 2017 160 2005 160 c 0,47,48
- 1991 160 1991 160 1981 166.5 c 128,-1,49
- 1971 173 1971 173 1971 186 c 0,50,51
- 1971 195 1971 195 1986 228 c 128,-1,52
- 2001 261 2001 261 2028 308 c 128,-1,53
- 2055 355 2055 355 2104 412 c 128,-1,54
- 2153 469 2153 469 2211 511 c 5,0,-1
-526 555 m 4,55,56
- 526 511 526 511 471 511 c 0,57,58
- 430 511 430 511 387 520.5 c 128,-1,59
- 344 530 344 530 302.5 551.5 c 128,-1,60
- 261 573 261 573 228 603 c 128,-1,61
- 195 633 195 633 175 676.5 c 128,-1,62
- 155 720 155 720 155 770.5 c 128,-1,63
- 155 821 155 821 175 864.5 c 128,-1,64
- 195 908 195 908 228 938 c 128,-1,65
- 261 968 261 968 302.5 989 c 128,-1,66
- 344 1010 344 1010 387 1020 c 128,-1,67
- 430 1030 430 1030 471 1030 c 0,68,69
- 527 1030 527 1030 526 986 c 0,70,71
- 526 983 526 983 525 978 c 128,-1,72
- 524 973 524 973 520.5 964 c 128,-1,73
- 517 955 517 955 506.5 948.5 c 128,-1,74
- 496 942 496 942 480 941 c 0,75,76
- 364 936 364 936 304 887 c 128,-1,77
- 244 838 244 838 244 770 c 0,78,79
- 244 742 244 742 255.5 716 c 128,-1,80
- 267 690 267 690 292 663.5 c 128,-1,81
- 317 637 317 637 366 620 c 128,-1,82
- 415 603 415 603 482 599 c 0,83,84
- 504 597 504 597 515 584.5 c 128,-1,85
- 526 572 526 572 526 555 c 4,55,56
-EndSplineSet
-Validated: 37
+2211 511 m 1,0,-1
+ 504 511 l 1,1,-1
+ 483 511 l 2,2,3
+ 481 511 481 511 478 511 c 128,-1,4
+ 475 511 475 511 471 511 c 0,5,6
+ 430 511 430 511 387 520.5 c 128,-1,7
+ 344 530 344 530 302.5 551.5 c 128,-1,8
+ 261 573 261 573 228 603 c 128,-1,9
+ 195 633 195 633 175 676.5 c 128,-1,10
+ 155 720 155 720 155 770.5 c 128,-1,11
+ 155 821 155 821 175 864.5 c 128,-1,12
+ 195 908 195 908 228 938 c 128,-1,13
+ 261 968 261 968 302.5 989 c 128,-1,14
+ 344 1010 344 1010 387 1020 c 128,-1,15
+ 430 1030 430 1030 471 1030 c 0,16,17
+ 527 1030 527 1030 526 986 c 0,18,19
+ 526 983 526 983 525 978 c 128,-1,20
+ 524 973 524 973 520.5 964 c 128,-1,21
+ 517 955 517 955 506.5 948.5 c 128,-1,22
+ 496 942 496 942 480 941 c 0,23,24
+ 364 936 364 936 304 887 c 128,-1,25
+ 244 838 244 838 244 770 c 0,26,27
+ 244 742 244 742 255.5 716 c 128,-1,28
+ 267 690 267 690 292 663.5 c 128,-1,29
+ 317 637 317 637 366 620 c 128,-1,30
+ 415 603 415 603 482 599 c 0,31,32
+ 483 599 483 599 483 599 c 2,33,-1
+ 504 599 l 1,34,-1
+ 2211 599 l 1,35,36
+ 2153 641 2153 641 2104 698 c 128,-1,37
+ 2055 755 2055 755 2028 802 c 128,-1,38
+ 2001 849 2001 849 1986 882 c 128,-1,39
+ 1971 915 1971 915 1971 924 c 0,40,41
+ 1971 938 1971 938 1981 944 c 128,-1,42
+ 1991 950 1991 950 2005 950 c 0,43,44
+ 2022 950 2022 950 2028 944 c 0,45,46
+ 2034 937 2034 937 2042 919 c 0,47,48
+ 2073 848 2073 848 2116 788 c 0,49,50
+ 2156 731 2156 731 2202.5 691.5 c 128,-1,51
+ 2249 652 2249 652 2290 626.5 c 128,-1,52
+ 2331 601 2331 601 2382 577 c 1,53,54
+ 2385 577 2385 577 2391.5 571 c 128,-1,55
+ 2398 565 2398 565 2398 555 c 0,56,57
+ 2398 544 2398 544 2393 539 c 128,-1,58
+ 2388 534 2388 534 2367 524 c 0,59,60
+ 2321 502 2321 502 2280.5 475.5 c 128,-1,61
+ 2240 449 2240 449 2211 424.5 c 128,-1,62
+ 2182 400 2182 400 2155.5 369 c 128,-1,63
+ 2129 338 2129 338 2113 316 c 128,-1,64
+ 2097 294 2097 294 2080.5 264 c 128,-1,65
+ 2064 234 2064 234 2058 220 c 2,66,-1
+ 2040 182 l 2,67,68
+ 2036 174 2036 174 2034.5 171.5 c 128,-1,69
+ 2033 169 2033 169 2025 164.5 c 128,-1,70
+ 2017 160 2017 160 2005 160 c 0,71,72
+ 1991 160 1991 160 1981 166.5 c 128,-1,73
+ 1971 173 1971 173 1971 186 c 0,74,75
+ 1971 195 1971 195 1986 228 c 128,-1,76
+ 2001 261 2001 261 2028 308 c 128,-1,77
+ 2055 355 2055 355 2104 412 c 128,-1,78
+ 2153 469 2153 469 2211 511 c 1,0,-1
+EndSplineSet
+Validated: 33
EndChar
StartChar: carriagereturn
@@ -30183,65 +30163,78 @@
LayerCount: 2
Fore
SplineSet
-1221 511 m 2,0,-1
- 275 511 l 1,1,2
- 288 365 288 365 370.5 247.5 c 128,-1,3
- 453 130 453 130 583.5 65 c 128,-1,4
- 714 0 714 0 868 0 c 2,5,-1
- 1221 0 l 2,6,7
- 1237 0 1237 0 1246 -1 c 128,-1,8
- 1255 -2 1255 -2 1268.5 -5.5 c 128,-1,9
- 1282 -9 1282 -9 1288 -19 c 128,-1,10
- 1294 -29 1294 -29 1294 -44.5 c 128,-1,11
- 1294 -60 1294 -60 1288 -70 c 128,-1,12
- 1282 -80 1282 -80 1268.5 -83.5 c 128,-1,13
- 1255 -87 1255 -87 1246 -88 c 128,-1,14
- 1237 -89 1237 -89 1221 -89 c 2,15,-1
- 861 -89 l 2,16,17
- 727 -89 727 -89 603 -39.5 c 128,-1,18
- 479 10 479 10 387 94.5 c 128,-1,19
- 295 179 295 179 239.5 299.5 c 128,-1,20
- 184 420 184 420 184 555 c 0,21,22
- 184 691 184 691 240 812 c 128,-1,23
- 296 933 296 933 388.5 1017 c 128,-1,24
- 481 1101 481 1101 604 1150 c 128,-1,25
- 727 1199 727 1199 859 1199 c 2,26,-1
- 1221 1199 l 2,27,28
- 1237 1199 1237 1199 1246 1198 c 128,-1,29
- 1255 1197 1255 1197 1268.5 1193.5 c 128,-1,30
- 1282 1190 1282 1190 1288 1180 c 128,-1,31
- 1294 1170 1294 1170 1294 1154.5 c 128,-1,32
- 1294 1139 1294 1139 1288 1129 c 128,-1,33
- 1282 1119 1282 1119 1268.5 1115.5 c 128,-1,34
- 1255 1112 1255 1112 1246 1111 c 128,-1,35
- 1237 1110 1237 1110 1221 1110 c 2,36,-1
- 866 1110 l 2,37,38
- 754 1110 754 1110 650.5 1072.5 c 128,-1,39
- 547 1035 547 1035 467.5 968.5 c 128,-1,40
- 388 902 388 902 336.5 806 c 128,-1,41
- 285 710 285 710 275 599 c 1,42,-1
- 1221 599 l 2,43,44
- 1237 599 1237 599 1246 598.5 c 128,-1,45
- 1255 598 1255 598 1268.5 594 c 128,-1,46
- 1282 590 1282 590 1288 580.5 c 128,-1,47
- 1294 571 1294 571 1294 555 c 128,-1,48
- 1294 539 1294 539 1288 529.5 c 128,-1,49
- 1282 520 1282 520 1268.5 516 c 128,-1,50
- 1255 512 1255 512 1246 511.5 c 128,-1,51
- 1237 511 1237 511 1221 511 c 2,0,-1
-1281 1505 m 2,52,-1
- 282 -440 l 2,53,54
- 262 -480 262 -480 233 -480 c 0,55,56
- 212 -480 212 -480 200.5 -465 c 128,-1,57
- 189 -450 189 -450 189 -435 c 0,58,59
- 189 -426 189 -426 204 -395 c 2,60,-1
+715 599 m 1,0,-1
+ 977 1110 l 1,1,-1
+ 866 1110 l 2,2,3
+ 754 1110 754 1110 650.5 1072.5 c 128,-1,4
+ 547 1035 547 1035 467.5 968.5 c 128,-1,5
+ 388 902 388 902 336.5 806 c 128,-1,6
+ 285 710 285 710 275 599 c 1,7,-1
+ 715 599 l 1,0,-1
+816 599 m 1,8,-1
+ 1221 599 l 2,9,10
+ 1237 599 1237 599 1246 598.5 c 128,-1,11
+ 1255 598 1255 598 1268.5 594 c 128,-1,12
+ 1282 590 1282 590 1288 580.5 c 128,-1,13
+ 1294 571 1294 571 1294 555 c 128,-1,14
+ 1294 539 1294 539 1288 529.5 c 128,-1,15
+ 1282 520 1282 520 1268 516 c 0,16,17
+ 1255 512 1255 512 1246 511.5 c 128,-1,18
+ 1237 511 1237 511 1221 511 c 2,19,-1
+ 770 511 l 1,20,-1
+ 550 83 l 1,21,22
+ 567 73 567 73 584 65 c 0,23,24
+ 718 0 718 0 868 0 c 2,25,-1
+ 1221 0 l 2,26,27
+ 1237 0 1237 0 1246 -1 c 128,-1,28
+ 1255 -2 1255 -2 1268.5 -5.5 c 128,-1,29
+ 1282 -9 1282 -9 1288 -19 c 128,-1,30
+ 1294 -29 1294 -29 1294 -44.5 c 128,-1,31
+ 1294 -60 1294 -60 1288 -70 c 128,-1,32
+ 1282 -80 1282 -80 1268.5 -83.5 c 128,-1,33
+ 1255 -87 1255 -87 1246 -88 c 128,-1,34
+ 1237 -89 1237 -89 1221 -89 c 2,35,-1
+ 861 -89 l 2,36,37
+ 723 -89 723 -89 603 -40 c 0,38,39
+ 554 -20 554 -20 510 5 c 1,40,-1
+ 282 -440 l 2,41,42
+ 262 -480 262 -480 233 -480 c 0,43,44
+ 212 -480 212 -480 200.5 -465 c 128,-1,45
+ 189 -450 189 -450 189 -435 c 0,46,47
+ 189 -426 189 -426 204 -395 c 2,48,-1
+ 435 55 l 1,49,50
+ 407 75 407 75 387 94 c 0,51,52
+ 294 182 294 182 240 300 c 0,53,54
+ 184 419 184 419 184 555 c 128,-1,55
+ 184 691 184 691 240 812 c 128,-1,56
+ 296 933 296 933 388.5 1017 c 128,-1,57
+ 481 1101 481 1101 604 1150 c 128,-1,58
+ 727 1199 727 1199 859 1199 c 2,59,-1
+ 1023 1199 l 1,60,-1
1203 1550 l 2,61,62
1223 1590 1223 1590 1252 1590 c 0,63,64
1273 1590 1273 1590 1284.5 1575 c 128,-1,65
- 1296 1560 1296 1560 1296 1545 c 0,66,67
- 1297 1536 1297 1536 1281 1505 c 2,52,-1
-EndSplineSet
-Validated: 5
+ 1296 1560 1296 1560 1296 1545 c 1,66,67
+ 1297 1536 1297 1536 1281 1505 c 2,68,-1
+ 1124 1199 l 1,69,-1
+ 1221 1199 l 2,70,71
+ 1237 1199 1237 1199 1246 1198 c 128,-1,72
+ 1255 1197 1255 1197 1268.5 1193.5 c 128,-1,73
+ 1282 1190 1282 1190 1288 1180 c 128,-1,74
+ 1294 1170 1294 1170 1294 1154.5 c 128,-1,75
+ 1294 1139 1294 1139 1288 1129 c 128,-1,76
+ 1282 1119 1282 1119 1268.5 1115.5 c 128,-1,77
+ 1255 1112 1255 1112 1246 1111 c 128,-1,78
+ 1237 1110 1237 1110 1221 1110 c 2,79,-1
+ 1078 1110 l 1,80,-1
+ 816 599 l 1,8,-1
+476 134 m 1,81,-1
+ 669 511 l 1,82,-1
+ 275 511 l 1,83,84
+ 288 364 288 364 370 248 c 0,85,86
+ 416 183 416 183 476 134 c 1,81,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni220D
@@ -32320,56 +32313,62 @@
LayerCount: 2
Fore
SplineSet
-1401 1505 m 2,0,-1
- 402 -440 l 2,1,2
- 382 -480 382 -480 353 -480 c 0,3,4
- 332 -480 332 -480 320.5 -465 c 128,-1,5
- 309 -450 309 -450 309 -435 c 0,6,7
- 309 -426 309 -426 324 -395 c 2,8,-1
- 1323 1550 l 2,9,10
- 1343 1590 1343 1590 1372 1590 c 0,11,12
- 1393 1590 1393 1590 1404.5 1575 c 128,-1,13
- 1416 1560 1416 1560 1416 1545 c 0,14,15
- 1417 1536 1417 1536 1401 1505 c 2,0,-1
-1467 1110 m 2,16,-1
- 866 1110 l 2,17,18
- 743 1110 743 1110 633 1066.5 c 128,-1,19
- 523 1023 523 1023 444 948.5 c 128,-1,20
- 365 874 365 874 319 771.5 c 128,-1,21
- 273 669 273 669 273 555 c 128,-1,22
- 273 441 273 441 319.5 338.5 c 128,-1,23
- 366 236 366 236 445 161.5 c 128,-1,24
- 524 87 524 87 634 43.5 c 128,-1,25
- 744 0 744 0 866 0 c 2,26,-1
- 1467 0 l 2,27,28
- 1483 0 1483 0 1492.5 -1 c 128,-1,29
- 1502 -2 1502 -2 1515 -5.5 c 128,-1,30
- 1528 -9 1528 -9 1534.5 -19 c 128,-1,31
- 1541 -29 1541 -29 1541 -44.5 c 128,-1,32
- 1541 -60 1541 -60 1534.5 -70 c 128,-1,33
- 1528 -80 1528 -80 1515 -83.5 c 128,-1,34
- 1502 -87 1502 -87 1493 -88 c 128,-1,35
- 1484 -89 1484 -89 1467 -89 c 2,36,-1
- 859 -89 l 2,37,38
- 727 -89 727 -89 604 -40 c 128,-1,39
- 481 9 481 9 388.5 93 c 128,-1,40
- 296 177 296 177 240 298 c 128,-1,41
- 184 419 184 419 184 555 c 128,-1,42
- 184 691 184 691 240 812 c 128,-1,43
- 296 933 296 933 388.5 1017 c 128,-1,44
- 481 1101 481 1101 604 1150 c 128,-1,45
- 727 1199 727 1199 859 1199 c 2,46,-1
- 1467 1199 l 2,47,48
- 1483 1199 1483 1199 1492.5 1198 c 128,-1,49
- 1502 1197 1502 1197 1515 1193.5 c 128,-1,50
- 1528 1190 1528 1190 1534.5 1180 c 128,-1,51
- 1541 1170 1541 1170 1541 1154.5 c 128,-1,52
- 1541 1139 1541 1139 1534.5 1129 c 128,-1,53
- 1528 1119 1528 1119 1515 1115.5 c 128,-1,54
- 1502 1112 1502 1112 1492.5 1111 c 128,-1,55
- 1483 1110 1483 1110 1467 1110 c 2,16,-1
-EndSplineSet
-Validated: 5
+1143 1199 m 1,0,-1
+ 1323 1550 l 2,1,2
+ 1343 1590 1343 1590 1372 1590 c 0,3,4
+ 1393 1590 1393 1590 1404.5 1575 c 128,-1,5
+ 1416 1560 1416 1560 1416 1545 c 1,6,7
+ 1417 1536 1417 1536 1401 1505 c 2,8,-1
+ 1244 1199 l 1,9,-1
+ 1467 1199 l 2,10,11
+ 1483 1199 1483 1199 1492.5 1198 c 128,-1,12
+ 1502 1197 1502 1197 1515 1193.5 c 128,-1,13
+ 1528 1190 1528 1190 1534.5 1180 c 128,-1,14
+ 1541 1170 1541 1170 1541 1154.5 c 128,-1,15
+ 1541 1139 1541 1139 1534.5 1129 c 128,-1,16
+ 1528 1119 1528 1119 1515 1115.5 c 128,-1,17
+ 1502 1112 1502 1112 1492.5 1111 c 128,-1,18
+ 1483 1110 1483 1110 1467 1110 c 2,19,-1
+ 1198 1110 l 1,20,-1
+ 648 38 l 1,21,22
+ 752 0 752 0 866 0 c 2,23,-1
+ 1467 0 l 2,24,25
+ 1483 0 1483 0 1492.5 -1 c 128,-1,26
+ 1502 -2 1502 -2 1515 -5.5 c 128,-1,27
+ 1528 -9 1528 -9 1534.5 -19 c 128,-1,28
+ 1541 -29 1541 -29 1541 -44.5 c 128,-1,29
+ 1541 -60 1541 -60 1534.5 -70 c 128,-1,30
+ 1528 -80 1528 -80 1515 -83.5 c 128,-1,31
+ 1502 -87 1502 -87 1493 -88 c 128,-1,32
+ 1484 -89 1484 -89 1467 -89 c 2,33,-1
+ 859 -89 l 2,34,35
+ 729 -89 729 -89 607 -41 c 1,36,-1
+ 402 -440 l 2,37,38
+ 382 -480 382 -480 353 -480 c 0,39,40
+ 332 -480 332 -480 320.5 -465 c 128,-1,41
+ 309 -450 309 -450 309 -435 c 0,42,43
+ 309 -426 309 -426 324 -395 c 2,44,-1
+ 525 -3 l 1,45,46
+ 450 37 450 37 388 93 c 0,47,48
+ 296 177 296 177 240 298 c 128,-1,49
+ 184 419 184 419 184 555 c 128,-1,50
+ 184 691 184 691 240 812 c 128,-1,51
+ 296 933 296 933 388.5 1017 c 128,-1,52
+ 481 1101 481 1101 604 1150 c 128,-1,53
+ 727 1199 727 1199 859 1199 c 2,54,-1
+ 1143 1199 l 1,0,-1
+566 75 m 1,55,-1
+ 1097 1110 l 1,56,-1
+ 866 1110 l 2,57,58
+ 743 1110 743 1110 633 1066.5 c 128,-1,59
+ 523 1023 523 1023 444 948.5 c 128,-1,60
+ 365 874 365 874 319 771.5 c 128,-1,61
+ 273 669 273 669 273 555 c 0,62,63
+ 273 443 273 443 320 338 c 0,64,65
+ 365 237 365 237 445 162 c 0,66,67
+ 499 110 499 110 566 75 c 1,55,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: reflexsubset
@@ -33613,77 +33612,60 @@
Width: 1971
VWidth: 2220
Flags: W
-HStem: 295 89<294 1679> 726 89<294 1679>
-LayerCount: 2
-Fore
-SplineSet
-1657 726 m 6,0,-1
- 332 726 l 2,1,2
- 318 726 318 726 310.5 726.5 c 128,-1,3
- 303 727 303 727 291 729 c 128,-1,4
- 279 731 279 731 273 735.5 c 128,-1,5
- 267 740 267 740 261.5 749 c 128,-1,6
- 256 758 256 758 256 770 c 0,7,8
- 256 786 256 786 262.5 796 c 128,-1,9
- 269 806 269 806 282 809.5 c 128,-1,10
- 295 813 295 813 304 814 c 128,-1,11
- 313 815 313 815 330 815 c 2,12,-1
- 1659 815 l 2,13,14
- 1675 815 1675 815 1684.5 814 c 128,-1,15
- 1694 813 1694 813 1707 809.5 c 128,-1,16
- 1720 806 1720 806 1726.5 796 c 128,-1,17
- 1733 786 1733 786 1733 770 c 0,18,19
- 1733 757 1733 757 1728 748.5 c 128,-1,20
- 1723 740 1723 740 1716.5 735.5 c 128,-1,21
- 1710 731 1710 731 1698 729 c 128,-1,22
- 1686 727 1686 727 1678.5 726.5 c 128,-1,23
- 1671 726 1671 726 1657 726 c 6,0,-1
-1659 295 m 6,24,-1
- 330 295 l 2,25,26
- 314 295 314 295 304.5 296 c 128,-1,27
- 295 297 295 297 282 300.5 c 128,-1,28
- 269 304 269 304 262.5 314 c 128,-1,29
- 256 324 256 324 256 340 c 0,30,31
- 256 353 256 353 261.5 361.5 c 128,-1,32
- 267 370 267 370 273 374.5 c 128,-1,33
- 279 379 279 379 291 381 c 128,-1,34
- 303 383 303 383 310.5 383.5 c 128,-1,35
- 318 384 318 384 332 384 c 2,36,-1
- 1657 384 l 2,37,38
- 1671 384 1671 384 1678.5 383.5 c 128,-1,39
- 1686 383 1686 383 1698 381 c 128,-1,40
- 1710 379 1710 379 1716.5 374.5 c 128,-1,41
- 1723 370 1723 370 1728 361 c 128,-1,42
- 1733 352 1733 352 1733 340 c 0,43,44
- 1733 324 1733 324 1726.5 314 c 128,-1,45
- 1720 304 1720 304 1707 300.5 c 128,-1,46
- 1694 297 1694 297 1684.5 296 c 128,-1,47
- 1675 295 1675 295 1659 295 c 6,24,-1
-374 1567 m 2,48,-1
- 374 -457 l 2,49,50
- 374 -472 374 -472 373.5 -481 c 128,-1,51
- 373 -490 373 -490 369.5 -505.5 c 128,-1,52
- 366 -521 366 -521 359.5 -530.5 c 128,-1,53
- 353 -540 353 -540 339 -547.5 c 128,-1,54
- 325 -555 325 -555 305 -555 c 0,55,56
- 286 -555 286 -555 272.5 -547.5 c 128,-1,57
- 259 -540 259 -540 252.5 -530.5 c 128,-1,58
- 246 -521 246 -521 243 -505 c 128,-1,59
- 240 -489 240 -489 239.5 -480 c 128,-1,60
- 239 -471 239 -471 239 -457 c 2,61,-1
- 239 1567 l 2,62,63
- 239 1582 239 1582 239.5 1591 c 128,-1,64
- 240 1600 240 1600 243.5 1615.5 c 128,-1,65
- 247 1631 247 1631 253.5 1640.5 c 128,-1,66
- 260 1650 260 1650 274 1657.5 c 128,-1,67
- 288 1665 288 1665 307 1665 c 0,68,69
- 326 1665 326 1665 339.5 1657.5 c 128,-1,70
- 353 1650 353 1650 359.5 1640.5 c 128,-1,71
- 366 1631 366 1631 369.5 1615 c 128,-1,72
- 373 1599 373 1599 373.5 1590 c 128,-1,73
- 374 1581 374 1581 374 1567 c 2,48,-1
-EndSplineSet
-Validated: 5
+HStem: 295 89<374 1726.3> 726 89<374 1726.3>
+VStem: 239 135<-551.614 295 384 726 815 1661.61>
+LayerCount: 2
+Fore
+SplineSet
+374 815 m 1,0,-1
+ 1659 815 l 2,1,2
+ 1675 815 1675 815 1684.5 814 c 128,-1,3
+ 1694 813 1694 813 1707 809.5 c 128,-1,4
+ 1720 806 1720 806 1726.5 796 c 128,-1,5
+ 1733 786 1733 786 1733 770 c 0,6,7
+ 1733 757 1733 757 1728 748.5 c 128,-1,8
+ 1723 740 1723 740 1716.5 735.5 c 128,-1,9
+ 1710 731 1710 731 1698 729 c 128,-1,10
+ 1686 727 1686 727 1678.5 726.5 c 128,-1,11
+ 1671 726 1671 726 1657 726 c 2,12,-1
+ 374 726 l 1,13,-1
+ 374 384 l 1,14,-1
+ 1657 384 l 2,15,16
+ 1671 384 1671 384 1678.5 383.5 c 128,-1,17
+ 1686 383 1686 383 1698 381 c 128,-1,18
+ 1710 379 1710 379 1716.5 374.5 c 128,-1,19
+ 1723 370 1723 370 1728 361 c 128,-1,20
+ 1733 352 1733 352 1733 340 c 0,21,22
+ 1733 324 1733 324 1726.5 314 c 128,-1,23
+ 1720 304 1720 304 1707 300.5 c 128,-1,24
+ 1694 297 1694 297 1684.5 296 c 128,-1,25
+ 1675 295 1675 295 1659 295 c 2,26,-1
+ 374 295 l 1,27,-1
+ 374 -457 l 2,28,29
+ 374 -472 374 -472 373.5 -481 c 128,-1,30
+ 373 -490 373 -490 369.5 -505.5 c 128,-1,31
+ 366 -521 366 -521 359.5 -530.5 c 128,-1,32
+ 353 -540 353 -540 339 -547.5 c 128,-1,33
+ 325 -555 325 -555 305 -555 c 0,34,35
+ 286 -555 286 -555 272.5 -547.5 c 128,-1,36
+ 259 -540 259 -540 252.5 -530.5 c 128,-1,37
+ 246 -521 246 -521 243 -505 c 128,-1,38
+ 240 -489 240 -489 239.5 -480 c 128,-1,39
+ 239 -471 239 -471 239 -457 c 2,40,-1
+ 239 1567 l 2,41,42
+ 239 1582 239 1582 239.5 1591 c 128,-1,43
+ 240 1600 240 1600 243.5 1615.5 c 128,-1,44
+ 247 1631 247 1631 254 1640 c 0,45,46
+ 260 1650 260 1650 274 1657.5 c 128,-1,47
+ 288 1665 288 1665 307 1665 c 128,-1,48
+ 326 1665 326 1665 339.5 1657.5 c 128,-1,49
+ 353 1650 353 1650 359.5 1640.5 c 128,-1,50
+ 366 1631 366 1631 369.5 1615 c 128,-1,51
+ 373 1599 373 1599 373.5 1590 c 128,-1,52
+ 374 1581 374 1581 374 1567 c 2,53,-1
+ 374 815 l 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni22A9
@@ -33691,73 +33673,67 @@
Width: 1445
VWidth: 2220
Flags: W
-HStem: 0 47G<147 191 369 413> 726 89<213 435 435 435 435 1431> 1496 44G<147 191 369 413>
-VStem: 124 89<22 726 815 1519> 346 89<22 726 815 1519>
-LayerCount: 2
-Fore
-SplineSet
-1157 726 m 6,0,-1
- 213 726 l 1,1,-1
- 213 73 l 2,2,3
- 213 57 213 57 212 48 c 128,-1,4
- 211 39 211 39 207.5 26 c 128,-1,5
- 204 13 204 13 194 6.5 c 128,-1,6
- 184 0 184 0 168.5 0 c 128,-1,7
- 153 0 153 0 143 6.5 c 128,-1,8
- 133 13 133 13 129.5 26.5 c 128,-1,9
- 126 40 126 40 125 49.5 c 128,-1,10
- 124 59 124 59 124 75 c 2,11,-1
- 124 1465 l 2,12,13
- 124 1481 124 1481 125 1490.5 c 128,-1,14
- 126 1500 126 1500 129.5 1513.5 c 128,-1,15
- 133 1527 133 1527 143 1534 c 128,-1,16
- 153 1541 153 1541 168.5 1541 c 128,-1,17
- 184 1541 184 1541 194 1534.5 c 128,-1,18
- 204 1528 204 1528 207.5 1515 c 128,-1,19
- 211 1502 211 1502 212 1493 c 128,-1,20
- 213 1484 213 1484 213 1467 c 2,21,-1
- 213 815 l 1,22,-1
- 1157 815 l 2,23,24
- 1173 815 1173 815 1182 814 c 128,-1,25
- 1191 813 1191 813 1204 809.5 c 128,-1,26
- 1217 806 1217 806 1223.5 796 c 128,-1,27
- 1230 786 1230 786 1230 770.5 c 128,-1,28
- 1230 755 1230 755 1223.5 745 c 128,-1,29
- 1217 735 1217 735 1204 731.5 c 128,-1,30
- 1191 728 1191 728 1182 727 c 128,-1,31
- 1173 726 1173 726 1157 726 c 6,0,-1
-1379 726 m 2,32,-1
- 435 726 l 1,33,-1
- 435 73 l 2,34,35
- 435 57 435 57 434 48 c 128,-1,36
- 433 39 433 39 429.5 26 c 128,-1,37
- 426 13 426 13 416 6.5 c 128,-1,38
- 406 0 406 0 390.5 0 c 128,-1,39
- 375 0 375 0 365 6.5 c 128,-1,40
- 355 13 355 13 351.5 26.5 c 128,-1,41
- 348 40 348 40 347 49.5 c 128,-1,42
- 346 59 346 59 346 75 c 2,43,-1
- 346 1465 l 2,44,45
- 346 1481 346 1481 347 1490.5 c 128,-1,46
- 348 1500 348 1500 351.5 1513.5 c 128,-1,47
- 355 1527 355 1527 365 1534 c 128,-1,48
- 375 1541 375 1541 390.5 1541 c 128,-1,49
- 406 1541 406 1541 416 1534.5 c 128,-1,50
- 426 1528 426 1528 429.5 1515 c 128,-1,51
- 433 1502 433 1502 434 1493 c 128,-1,52
- 435 1484 435 1484 435 1467 c 2,53,-1
- 435 815 l 1,54,-1
- 1379 815 l 2,55,56
- 1395 815 1395 815 1404 814 c 128,-1,57
- 1413 813 1413 813 1426 809.5 c 128,-1,58
- 1439 806 1439 806 1445.5 796 c 128,-1,59
- 1452 786 1452 786 1452 770.5 c 128,-1,60
- 1452 755 1452 755 1445.5 745 c 128,-1,61
- 1439 735 1439 735 1426 731.5 c 128,-1,62
- 1413 728 1413 728 1404 727 c 128,-1,63
- 1395 726 1395 726 1379 726 c 2,32,-1
-EndSplineSet
-Validated: 5
+HStem: 0 21G<160.75 176.25 382.75 398.25> 726 89<213 346 435 1452> 1521 20G<160.75 176.25 382.75 398.25>
+VStem: 124 89<6.70483 726 815 1533.78> 346 89<6.70483 726 815 1533.78>
+LayerCount: 2
+Fore
+SplineSet
+1157 815 m 1,0,-1
+ 1379 815 l 2,1,2
+ 1395 815 1395 815 1404 814 c 128,-1,3
+ 1413 813 1413 813 1426 809.5 c 128,-1,4
+ 1439 806 1439 806 1445.5 796 c 128,-1,5
+ 1452 786 1452 786 1452 770.5 c 128,-1,6
+ 1452 755 1452 755 1445.5 745 c 128,-1,7
+ 1439 735 1439 735 1426 731.5 c 128,-1,8
+ 1413 728 1413 728 1404 727 c 128,-1,9
+ 1395 726 1395 726 1379 726 c 2,10,-1
+ 1157 726 l 1,11,-1
+ 435 726 l 1,12,-1
+ 435 73 l 2,13,14
+ 435 57 435 57 434 48 c 0,15,16
+ 432 34 432 34 430 26 c 0,17,18
+ 426 13 426 13 416 6 c 0,19,20
+ 406 0 406 0 390.5 0 c 128,-1,21
+ 375 0 375 0 365 6 c 0,22,23
+ 355 13 355 13 351.5 26.5 c 128,-1,24
+ 348 40 348 40 347 49.5 c 128,-1,25
+ 346 59 346 59 346 75 c 2,26,-1
+ 346 726 l 1,27,-1
+ 213 726 l 1,28,-1
+ 213 73 l 2,29,30
+ 213 57 213 57 212 48 c 0,31,32
+ 210 34 210 34 208 26 c 0,33,34
+ 204 13 204 13 194 6 c 0,35,36
+ 184 0 184 0 168.5 0 c 128,-1,37
+ 153 0 153 0 143 6 c 0,38,39
+ 133 13 133 13 129.5 26.5 c 128,-1,40
+ 126 40 126 40 125 49.5 c 128,-1,41
+ 124 59 124 59 124 75 c 2,42,-1
+ 124 1465 l 2,43,44
+ 124 1481 124 1481 125 1490.5 c 128,-1,45
+ 126 1500 126 1500 129.5 1513.5 c 128,-1,46
+ 133 1527 133 1527 143 1534 c 128,-1,47
+ 153 1541 153 1541 168.5 1541 c 128,-1,48
+ 184 1541 184 1541 194 1534.5 c 128,-1,49
+ 204 1528 204 1528 207.5 1515 c 128,-1,50
+ 211 1502 211 1502 212 1493 c 128,-1,51
+ 213 1484 213 1484 213 1467 c 2,52,-1
+ 213 815 l 1,53,-1
+ 346 815 l 1,54,-1
+ 346 1465 l 2,55,56
+ 346 1481 346 1481 347 1490.5 c 128,-1,57
+ 348 1500 348 1500 351.5 1513.5 c 128,-1,58
+ 355 1527 355 1527 365 1534 c 128,-1,59
+ 375 1541 375 1541 390.5 1541 c 128,-1,60
+ 406 1541 406 1541 416 1534.5 c 128,-1,61
+ 426 1528 426 1528 429.5 1515 c 128,-1,62
+ 433 1502 433 1502 434 1493 c 128,-1,63
+ 435 1484 435 1484 435 1467 c 2,64,-1
+ 435 815 l 1,65,-1
+ 1157 815 l 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni22AB
@@ -33765,12 +33741,12 @@
Width: 2148
VWidth: 2220
Flags: W
-HStem: 295 89<565 1978> 726 89<565 1978>
-VStem: 264 89<-534 1644> 523 118<295 384 726 815>
-LayerCount: 2
-Fore
-SplineSet
-353 1592 m 6,0,-1
+HStem: 295 89<640 1992.3> 726 89<640 1992.3>
+VStem: 264 89<-554.998 1665> 505 135<-551.614 295 384 726 815 1661.61>
+LayerCount: 2
+Fore
+SplineSet
+353 1592 m 2,0,-1
353 -482 l 2,1,2
353 -498 353 -498 352 -507 c 128,-1,3
351 -516 351 -516 347.5 -529 c 128,-1,4
@@ -33788,74 +33764,56 @@
324 1665 324 1665 334 1658.5 c 128,-1,17
344 1652 344 1652 347.5 1639 c 128,-1,18
351 1626 351 1626 352 1617 c 128,-1,19
- 353 1608 353 1608 353 1592 c 6,0,-1
-1924 726 m 2,20,-1
- 598 726 l 2,21,22
- 584 726 584 726 577 726.5 c 128,-1,23
- 570 727 570 727 558 729 c 128,-1,24
- 546 731 546 731 539.5 735.5 c 128,-1,25
- 533 740 533 740 528 749 c 128,-1,26
- 523 758 523 758 523 770 c 0,27,28
- 523 786 523 786 529 796 c 128,-1,29
- 535 806 535 806 548.5 809.5 c 128,-1,30
- 562 813 562 813 571 814 c 128,-1,31
- 580 815 580 815 596 815 c 2,32,-1
- 1926 815 l 2,33,34
- 1942 815 1942 815 1951 814 c 128,-1,35
- 1960 813 1960 813 1973 809.5 c 128,-1,36
- 1986 806 1986 806 1992.5 796 c 128,-1,37
- 1999 786 1999 786 1999 770 c 0,38,39
- 1999 757 1999 757 1994 748.5 c 128,-1,40
- 1989 740 1989 740 1982.5 735.5 c 128,-1,41
- 1976 731 1976 731 1964 729 c 128,-1,42
- 1952 727 1952 727 1945 726.5 c 128,-1,43
- 1938 726 1938 726 1924 726 c 2,20,-1
-1926 295 m 2,44,-1
- 596 295 l 2,45,46
- 580 295 580 295 571 296 c 128,-1,47
- 562 297 562 297 548.5 300.5 c 128,-1,48
- 535 304 535 304 529 314 c 128,-1,49
- 523 324 523 324 523 340 c 0,50,51
- 523 353 523 353 528 361.5 c 128,-1,52
- 533 370 533 370 539.5 374.5 c 128,-1,53
- 546 379 546 379 558 381 c 128,-1,54
- 570 383 570 383 577.5 383.5 c 128,-1,55
- 585 384 585 384 598 384 c 2,56,-1
- 1924 384 l 2,57,58
- 1938 384 1938 384 1945 383.5 c 128,-1,59
- 1952 383 1952 383 1964 381 c 128,-1,60
- 1976 379 1976 379 1982.5 374.5 c 128,-1,61
- 1989 370 1989 370 1994 361 c 128,-1,62
- 1999 352 1999 352 1999 340 c 0,63,64
- 1999 324 1999 324 1992.5 314 c 128,-1,65
- 1986 304 1986 304 1973 300.5 c 128,-1,66
- 1960 297 1960 297 1951 296 c 128,-1,67
- 1942 295 1942 295 1926 295 c 2,44,-1
-640 1567 m 2,68,-1
- 640 -457 l 2,69,70
- 640 -472 640 -472 640 -481 c 128,-1,71
- 640 -490 640 -490 636 -505.5 c 128,-1,72
- 632 -521 632 -521 625.5 -530.5 c 128,-1,73
- 619 -540 619 -540 605 -547.5 c 128,-1,74
- 591 -555 591 -555 572 -555 c 0,75,76
- 553 -555 553 -555 539.5 -547.5 c 128,-1,77
- 526 -540 526 -540 519.5 -530.5 c 128,-1,78
- 513 -521 513 -521 509.5 -505 c 128,-1,79
- 506 -489 506 -489 505.5 -480 c 128,-1,80
- 505 -471 505 -471 505 -457 c 2,81,-1
- 505 1567 l 2,82,83
- 505 1582 505 1582 505.5 1591 c 128,-1,84
- 506 1600 506 1600 509.5 1615.5 c 128,-1,85
- 513 1631 513 1631 519.5 1640.5 c 128,-1,86
- 526 1650 526 1650 540 1657.5 c 128,-1,87
- 554 1665 554 1665 574 1665 c 0,88,89
- 593 1665 593 1665 606.5 1657.5 c 128,-1,90
- 620 1650 620 1650 626.5 1640.5 c 128,-1,91
- 633 1631 633 1631 636.5 1615 c 128,-1,92
- 640 1599 640 1599 640 1590 c 128,-1,93
- 640 1581 640 1581 640 1567 c 2,68,-1
-EndSplineSet
-Validated: 1029
+ 353 1608 353 1608 353 1592 c 2,0,-1
+640 384 m 1,20,-1
+ 1924 384 l 2,21,22
+ 1938 384 1938 384 1945 383.5 c 128,-1,23
+ 1952 383 1952 383 1964 381 c 128,-1,24
+ 1976 379 1976 379 1982.5 374.5 c 128,-1,25
+ 1989 370 1989 370 1994 361 c 128,-1,26
+ 1999 352 1999 352 1999 340 c 0,27,28
+ 1999 324 1999 324 1992.5 314 c 128,-1,29
+ 1986 304 1986 304 1973 300.5 c 128,-1,30
+ 1960 297 1960 297 1951 296 c 128,-1,31
+ 1942 295 1942 295 1926 295 c 2,32,-1
+ 640 295 l 1,33,-1
+ 640 -457 l 1,34,-1
+ 640 -481 l 2,35,36
+ 640 -490 640 -490 636 -505.5 c 128,-1,37
+ 632 -521 632 -521 625.5 -530.5 c 128,-1,38
+ 619 -540 619 -540 605 -547.5 c 128,-1,39
+ 591 -555 591 -555 572 -555 c 128,-1,40
+ 553 -555 553 -555 539.5 -547.5 c 128,-1,41
+ 526 -540 526 -540 519.5 -530.5 c 128,-1,42
+ 513 -521 513 -521 509.5 -505 c 128,-1,43
+ 506 -489 506 -489 505.5 -480 c 128,-1,44
+ 505 -471 505 -471 505 -457 c 2,45,-1
+ 505 1567 l 2,46,47
+ 505 1582 505 1582 505.5 1591 c 128,-1,48
+ 506 1600 506 1600 509.5 1615.5 c 128,-1,49
+ 513 1631 513 1631 519.5 1640.5 c 128,-1,50
+ 526 1650 526 1650 540 1657.5 c 128,-1,51
+ 554 1665 554 1665 574 1665 c 0,52,53
+ 593 1665 593 1665 606.5 1657.5 c 128,-1,54
+ 620 1650 620 1650 626.5 1640.5 c 128,-1,55
+ 633 1631 633 1631 636.5 1615 c 128,-1,56
+ 640 1599 640 1599 640 1590 c 2,57,-1
+ 640 1567 l 1,58,-1
+ 640 815 l 1,59,-1
+ 1926 815 l 2,60,61
+ 1942 815 1942 815 1951 814 c 128,-1,62
+ 1960 813 1960 813 1973 809.5 c 128,-1,63
+ 1986 806 1986 806 1992.5 796 c 128,-1,64
+ 1999 786 1999 786 1999 770 c 0,65,66
+ 1999 757 1999 757 1994 748.5 c 128,-1,67
+ 1989 740 1989 740 1982.5 735.5 c 128,-1,68
+ 1976 731 1976 731 1964 729 c 128,-1,69
+ 1952 727 1952 727 1945 726.5 c 128,-1,70
+ 1938 726 1938 726 1924 726 c 2,71,-1
+ 640 726 l 1,72,-1
+ 640 384 l 1,20,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni22B2
@@ -35915,72 +35873,61 @@
LayerCount: 2
Fore
SplineSet
-2101 511 m 6,0,-1
- 394 511 l 1,1,2
- 452 469 452 469 501 412 c 128,-1,3
- 550 355 550 355 577 308 c 128,-1,4
- 604 261 604 261 619 228 c 128,-1,5
- 634 195 634 195 634 186 c 0,6,7
- 634 172 634 172 624 166 c 128,-1,8
- 614 160 614 160 601 160 c 0,9,10
- 584 160 584 160 577.5 166.5 c 128,-1,11
- 571 173 571 173 563 191 c 0,12,13
- 512 301 512 301 437 383.5 c 128,-1,14
- 362 466 362 466 234 526 c 0,15,16
- 228 529 228 529 223.5 532 c 128,-1,17
- 219 535 219 535 215.5 538 c 128,-1,18
- 212 541 212 541 210 545 c 128,-1,19
- 208 549 208 549 208 555 c 0,20,21
- 208 561 208 561 208.5 564 c 128,-1,22
- 209 567 209 567 215 571.5 c 128,-1,23
- 221 576 221 576 222.5 577 c 128,-1,24
- 224 578 224 578 239 586 c 0,25,26
- 302 616 302 616 355 655.5 c 128,-1,27
- 408 695 408 695 440 728.5 c 128,-1,28
- 472 762 472 762 500 805 c 128,-1,29
- 528 848 528 848 539.5 871.5 c 128,-1,30
- 551 895 551 895 565 928 c 0,31,32
- 569 936 569 936 570.5 938.5 c 128,-1,33
- 572 941 572 941 580 945.5 c 128,-1,34
- 588 950 588 950 601 950 c 0,35,36
- 615 950 615 950 624.5 943.5 c 128,-1,37
- 634 937 634 937 634 924 c 0,38,39
- 634 915 634 915 619 882 c 128,-1,40
- 604 849 604 849 577 802 c 128,-1,41
- 550 755 550 755 501 698.5 c 128,-1,42
- 452 642 452 642 394 599 c 1,43,-1
- 2101 599 l 2,44,45
- 2115 599 2115 599 2122 599 c 128,-1,46
- 2129 599 2129 599 2141 596.5 c 128,-1,47
- 2153 594 2153 594 2159 589.5 c 128,-1,48
- 2165 585 2165 585 2169.5 576.5 c 128,-1,49
- 2174 568 2174 568 2174 555 c 128,-1,50
- 2174 542 2174 542 2169.5 533.5 c 128,-1,51
- 2165 525 2165 525 2159 520.5 c 128,-1,52
- 2153 516 2153 516 2141 513.5 c 128,-1,53
- 2129 511 2129 511 2122 511 c 128,-1,54
- 2115 511 2115 511 2101 511 c 6,0,-1
-3382 511 m 6,55,-1
- 2172 511 l 2,56,57
- 2156 511 2156 511 2147 511.5 c 128,-1,58
- 2138 512 2138 512 2125 516 c 128,-1,59
- 2112 520 2112 520 2105.5 529.5 c 128,-1,60
- 2099 539 2099 539 2099 555 c 128,-1,61
- 2099 571 2099 571 2105.5 580.5 c 128,-1,62
- 2112 590 2112 590 2125 594 c 128,-1,63
- 2138 598 2138 598 2147 598.5 c 128,-1,64
- 2156 599 2156 599 2172 599 c 2,65,-1
- 3382 599 l 2,66,67
- 3398 599 3398 599 3407.5 598.5 c 128,-1,68
- 3417 598 3417 598 3430 594 c 128,-1,69
- 3443 590 3443 590 3449 580.5 c 128,-1,70
- 3455 571 3455 571 3455 555 c 128,-1,71
- 3455 539 3455 539 3449 529.5 c 128,-1,72
- 3443 520 3443 520 3430 516 c 128,-1,73
- 3417 512 3417 512 3407.5 511.5 c 128,-1,74
- 3398 511 3398 511 3382 511 c 6,55,-1
-EndSplineSet
-Validated: 5
+3382 511 m 2,0,-1
+ 2172 511 l 2,1,2
+ 2156 511 2156 511 2147 512 c 0,3,4
+ 2143 512 2143 512 2137 513 c 1,5,6
+ 2128 511 2128 511 2122 511 c 2,7,-1
+ 2101 511 l 1,8,-1
+ 394 511 l 1,9,10
+ 452 469 452 469 501 412 c 128,-1,11
+ 550 355 550 355 577 308 c 128,-1,12
+ 604 261 604 261 619 228 c 128,-1,13
+ 634 195 634 195 634 186 c 0,14,15
+ 634 172 634 172 624 166 c 128,-1,16
+ 614 160 614 160 601 160 c 0,17,18
+ 584 160 584 160 577.5 166.5 c 128,-1,19
+ 571 173 571 173 563 191 c 0,20,21
+ 512 301 512 301 437 383.5 c 128,-1,22
+ 362 466 362 466 234 526 c 0,23,24
+ 228 529 228 529 223.5 532 c 128,-1,25
+ 219 535 219 535 215.5 538 c 128,-1,26
+ 212 541 212 541 210 545 c 128,-1,27
+ 208 549 208 549 208 555 c 128,-1,28
+ 208 561 208 561 208.5 564 c 128,-1,29
+ 209 567 209 567 215 571.5 c 128,-1,30
+ 221 576 221 576 222.5 577 c 128,-1,31
+ 224 578 224 578 239 586 c 0,32,33
+ 302 616 302 616 355 655.5 c 128,-1,34
+ 408 695 408 695 440 728 c 0,35,36
+ 472 762 472 762 500 805 c 128,-1,37
+ 528 848 528 848 539.5 871.5 c 128,-1,38
+ 551 895 551 895 565 928 c 0,39,40
+ 569 936 569 936 570.5 938.5 c 128,-1,41
+ 572 941 572 941 580 945.5 c 128,-1,42
+ 588 950 588 950 601 950 c 0,43,44
+ 615 950 615 950 624.5 943.5 c 128,-1,45
+ 634 937 634 937 634 924 c 0,46,47
+ 634 915 634 915 619 882 c 128,-1,48
+ 604 849 604 849 577 802 c 128,-1,49
+ 550 755 550 755 501 698.5 c 128,-1,50
+ 452 642 452 642 394 599 c 1,51,-1
+ 2101 599 l 1,52,-1
+ 2122 599 l 2,53,54
+ 2128 599 2128 599 2137 597 c 1,55,56
+ 2143 598 2143 598 2147 598.5 c 128,-1,57
+ 2151 599 2151 599 2172 599 c 2,58,-1
+ 3382 599 l 2,59,60
+ 3398 599 3398 599 3407.5 598.5 c 128,-1,61
+ 3417 598 3417 598 3430 594 c 128,-1,62
+ 3443 590 3443 590 3449 580.5 c 128,-1,63
+ 3455 571 3455 571 3455 555 c 128,-1,64
+ 3455 539 3455 539 3449 529.5 c 128,-1,65
+ 3443 520 3443 520 3430 516 c 128,-1,66
+ 3417 512 3417 512 3407.5 511.5 c 128,-1,67
+ 3398 511 3398 511 3382 511 c 2,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni27F6
@@ -35988,77 +35935,66 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 511 89<233 1525 1525 1525 1525 3265>
-VStem: 1484 84<511 599>
-LayerCount: 2
-Fore
-SplineSet
-3265 511 m 5,0,-1
- 1557 511 l 2,1,2
- 1543 511 1543 511 1536 511 c 128,-1,3
- 1529 511 1529 511 1517.5 513.5 c 128,-1,4
- 1506 516 1506 516 1500 520.5 c 128,-1,5
- 1494 525 1494 525 1489 533.5 c 128,-1,6
- 1484 542 1484 542 1484 555 c 128,-1,7
- 1484 568 1484 568 1489 576.5 c 128,-1,8
- 1494 585 1494 585 1500 589.5 c 128,-1,9
- 1506 594 1506 594 1517.5 596.5 c 128,-1,10
- 1529 599 1529 599 1536.5 599 c 128,-1,11
- 1544 599 1544 599 1557 599 c 2,12,-1
- 3265 599 l 1,13,14
- 3207 641 3207 641 3157.5 698 c 128,-1,15
- 3108 755 3108 755 3081 802 c 128,-1,16
- 3054 849 3054 849 3039.5 882 c 128,-1,17
- 3025 915 3025 915 3025 924 c 0,18,19
- 3025 938 3025 938 3035 944 c 128,-1,20
- 3045 950 3045 950 3058 950 c 0,21,22
- 3075 950 3075 950 3081.5 943.5 c 128,-1,23
- 3088 937 3088 937 3096 919 c 0,24,25
- 3129 846 3129 846 3169.5 788.5 c 128,-1,26
- 3210 731 3210 731 3256 691.5 c 128,-1,27
- 3302 652 3302 652 3343 626.5 c 128,-1,28
- 3384 601 3384 601 3435 577 c 1,29,30
- 3438 577 3438 577 3444.5 571 c 128,-1,31
- 3451 565 3451 565 3451 555 c 0,32,33
- 3451 544 3451 544 3446 539 c 128,-1,34
- 3441 534 3441 534 3420 524 c 0,35,36
- 3374 502 3374 502 3333.5 475.5 c 128,-1,37
- 3293 449 3293 449 3264 424.5 c 128,-1,38
- 3235 400 3235 400 3208.5 369 c 128,-1,39
- 3182 338 3182 338 3166 316 c 128,-1,40
- 3150 294 3150 294 3133.5 264 c 128,-1,41
- 3117 234 3117 234 3110.5 220 c 128,-1,42
- 3104 206 3104 206 3094 182 c 0,43,44
- 3090 174 3090 174 3088 171.5 c 128,-1,45
- 3086 169 3086 169 3078 164.5 c 128,-1,46
- 3070 160 3070 160 3058 160 c 0,47,48
- 3044 160 3044 160 3034.5 166.5 c 128,-1,49
- 3025 173 3025 173 3025 186 c 0,50,51
- 3025 195 3025 195 3039.5 228 c 128,-1,52
- 3054 261 3054 261 3081 308 c 128,-1,53
- 3108 355 3108 355 3157.5 412 c 128,-1,54
- 3207 469 3207 469 3265 511 c 5,0,-1
-1495 511 m 6,55,-1
- 285 511 l 2,56,57
- 269 511 269 511 260 511.5 c 128,-1,58
- 251 512 251 512 238 516 c 128,-1,59
- 225 520 225 520 218.5 529.5 c 128,-1,60
- 212 539 212 539 212 555 c 128,-1,61
- 212 571 212 571 218.5 580.5 c 128,-1,62
- 225 590 225 590 238 594 c 128,-1,63
- 251 598 251 598 260 598.5 c 128,-1,64
- 269 599 269 599 285 599 c 2,65,-1
- 1495 599 l 2,66,67
- 1511 599 1511 599 1520.5 598.5 c 128,-1,68
- 1530 598 1530 598 1543 594 c 128,-1,69
- 1556 590 1556 590 1562 580.5 c 128,-1,70
- 1568 571 1568 571 1568 555 c 128,-1,71
- 1568 539 1568 539 1562 529.5 c 128,-1,72
- 1556 520 1556 520 1543 516 c 128,-1,73
- 1530 512 1530 512 1520.5 511.5 c 128,-1,74
- 1511 511 1511 511 1495 511 c 6,55,-1
-EndSplineSet
-Validated: 5
+HStem: 511 88<218.705 3265>
+VStem: 3025 71<849.875 943.302>
+LayerCount: 2
+Fore
+SplineSet
+1495 511 m 2,0,-1
+ 285 511 l 2,1,2
+ 269 511 269 511 260 511.5 c 128,-1,3
+ 251 512 251 512 238 516 c 128,-1,4
+ 225 520 225 520 218.5 529.5 c 128,-1,5
+ 212 539 212 539 212 555 c 128,-1,6
+ 212 571 212 571 218.5 580.5 c 128,-1,7
+ 225 590 225 590 238 594 c 128,-1,8
+ 251 598 251 598 260 598.5 c 128,-1,9
+ 269 599 269 599 285 599 c 2,10,-1
+ 1495 599 l 2,11,12
+ 1511 599 1511 599 1520 598 c 0,13,14
+ 1526 598 1526 598 1526 598 c 0,15,16
+ 1532 599 1532 599 1536 599 c 2,17,-1
+ 1557 599 l 1,18,-1
+ 3265 599 l 1,19,20
+ 3207 641 3207 641 3157.5 698 c 128,-1,21
+ 3108 755 3108 755 3081 802 c 128,-1,22
+ 3054 849 3054 849 3039.5 882 c 128,-1,23
+ 3025 915 3025 915 3025 924 c 0,24,25
+ 3025 938 3025 938 3035 944 c 128,-1,26
+ 3045 950 3045 950 3058 950 c 0,27,28
+ 3075 950 3075 950 3082 944 c 0,29,30
+ 3088 937 3088 937 3096 919 c 0,31,32
+ 3127 848 3127 848 3170 788 c 0,33,34
+ 3210 731 3210 731 3256 691.5 c 128,-1,35
+ 3302 652 3302 652 3343 626.5 c 128,-1,36
+ 3384 601 3384 601 3435 577 c 1,37,38
+ 3438 577 3438 577 3444.5 571 c 128,-1,39
+ 3451 565 3451 565 3451 555 c 0,40,41
+ 3451 544 3451 544 3446 539 c 128,-1,42
+ 3441 534 3441 534 3420 524 c 0,43,44
+ 3374 502 3374 502 3333.5 475.5 c 128,-1,45
+ 3293 449 3293 449 3264 424.5 c 128,-1,46
+ 3235 400 3235 400 3208.5 369 c 128,-1,47
+ 3182 338 3182 338 3166 316 c 128,-1,48
+ 3150 294 3150 294 3133.5 264 c 128,-1,49
+ 3117 234 3117 234 3110.5 220 c 128,-1,50
+ 3104 206 3104 206 3094 182 c 0,51,52
+ 3090 174 3090 174 3088 171.5 c 128,-1,53
+ 3086 169 3086 169 3078 164 c 0,54,55
+ 3070 160 3070 160 3058 160 c 0,56,57
+ 3044 160 3044 160 3034.5 166.5 c 128,-1,58
+ 3025 173 3025 173 3025 186 c 0,59,60
+ 3025 195 3025 195 3039.5 228 c 128,-1,61
+ 3054 261 3054 261 3081 308 c 128,-1,62
+ 3108 355 3108 355 3157.5 412 c 128,-1,63
+ 3207 469 3207 469 3265 511 c 1,64,-1
+ 1557 511 l 1,65,-1
+ 1536 511 l 2,66,67
+ 1532 511 1532 511 1526 512 c 0,68,69
+ 1523 512 1523 512 1520.5 511.5 c 128,-1,71
+ 1518 511 1518 511 1495 511 c 2,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni27F7
@@ -36066,102 +36002,88 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 511 89<313 2047 1583 3326>
-LayerCount: 2
-Fore
-SplineSet
-2020 511 m 6,0,-1
- 313 511 l 1,1,2
- 371 469 371 469 420 412 c 128,-1,3
- 469 355 469 355 496 308 c 128,-1,4
- 523 261 523 261 538 228 c 128,-1,5
- 553 195 553 195 553 186 c 0,6,7
- 553 172 553 172 543 166 c 128,-1,8
- 533 160 533 160 519 160 c 0,9,10
- 502 160 502 160 496 166.5 c 128,-1,11
- 490 173 490 173 482 191 c 0,12,13
- 431 301 431 301 356 383.5 c 128,-1,14
- 281 466 281 466 153 526 c 0,15,16
- 147 529 147 529 142.5 532 c 128,-1,17
- 138 535 138 535 134 538 c 128,-1,18
- 130 541 130 541 128.5 545 c 128,-1,19
- 127 549 127 549 127 555 c 0,20,21
- 127 561 127 561 127.5 564 c 128,-1,22
- 128 567 128 567 134 571.5 c 128,-1,23
- 140 576 140 576 141.5 577 c 128,-1,24
- 143 578 143 578 158 586 c 0,25,26
- 221 616 221 616 274 655.5 c 128,-1,27
- 327 695 327 695 359 728.5 c 128,-1,28
- 391 762 391 762 419 805 c 128,-1,29
- 447 848 447 848 458.5 871.5 c 128,-1,30
- 470 895 470 895 484 928 c 0,31,32
- 488 936 488 936 489.5 938.5 c 128,-1,33
- 491 941 491 941 499 945.5 c 128,-1,34
- 507 950 507 950 519 950 c 0,35,36
- 533 950 533 950 543 943.5 c 128,-1,37
- 553 937 553 937 553 924 c 0,38,39
- 553 915 553 915 538 882 c 128,-1,40
- 523 849 523 849 496 802 c 128,-1,41
- 469 755 469 755 420 698.5 c 128,-1,42
- 371 642 371 642 313 599 c 1,43,-1
- 2020 599 l 2,44,45
- 2034 599 2034 599 2041 599 c 128,-1,46
- 2048 599 2048 599 2060 596.5 c 128,-1,47
- 2072 594 2072 594 2078 589.5 c 128,-1,48
- 2084 585 2084 585 2088.5 576.5 c 128,-1,49
- 2093 568 2093 568 2093 555 c 128,-1,50
- 2093 542 2093 542 2088.5 533.5 c 128,-1,51
- 2084 525 2084 525 2078 520.5 c 128,-1,52
- 2072 516 2072 516 2060 513.5 c 128,-1,53
- 2048 511 2048 511 2041 511 c 128,-1,54
- 2034 511 2034 511 2020 511 c 6,0,-1
-3328 511 m 5,55,-1
- 1621 511 l 2,56,57
- 1607 511 1607 511 1600 511 c 128,-1,58
- 1593 511 1593 511 1581 513.5 c 128,-1,59
- 1569 516 1569 516 1563 520.5 c 128,-1,60
- 1557 525 1557 525 1552 533.5 c 128,-1,61
- 1547 542 1547 542 1547 555 c 128,-1,62
- 1547 568 1547 568 1552 576.5 c 128,-1,63
- 1557 585 1557 585 1563 589.5 c 128,-1,64
- 1569 594 1569 594 1581 596.5 c 128,-1,65
- 1593 599 1593 599 1600 599 c 128,-1,66
- 1607 599 1607 599 1621 599 c 2,67,-1
- 3328 599 l 1,68,69
- 3270 641 3270 641 3221 698 c 128,-1,70
- 3172 755 3172 755 3145 802 c 128,-1,71
- 3118 849 3118 849 3103 882 c 128,-1,72
- 3088 915 3088 915 3088 924 c 0,73,74
- 3088 938 3088 938 3098 944 c 128,-1,75
- 3108 950 3108 950 3121 950 c 0,76,77
- 3138 950 3138 950 3144.5 943.5 c 128,-1,78
- 3151 937 3151 937 3159 919 c 0,79,80
- 3192 846 3192 846 3232.5 788.5 c 128,-1,81
- 3273 731 3273 731 3319.5 691.5 c 128,-1,82
- 3366 652 3366 652 3406.5 626.5 c 128,-1,83
- 3447 601 3447 601 3499 577 c 1,84,85
- 3502 577 3502 577 3508 571 c 128,-1,86
- 3514 565 3514 565 3514 555 c 0,87,88
- 3514 544 3514 544 3509 539 c 128,-1,89
- 3504 534 3504 534 3483 524 c 0,90,91
- 3437 502 3437 502 3396.5 475.5 c 128,-1,92
- 3356 449 3356 449 3327 424.5 c 128,-1,93
- 3298 400 3298 400 3271.5 369 c 128,-1,94
- 3245 338 3245 338 3229.5 316 c 128,-1,95
- 3214 294 3214 294 3197.5 264 c 128,-1,96
- 3181 234 3181 234 3174 220 c 128,-1,97
- 3167 206 3167 206 3157 182 c 0,98,99
- 3153 174 3153 174 3151.5 171.5 c 128,-1,100
- 3150 169 3150 169 3142 164.5 c 128,-1,101
- 3134 160 3134 160 3121 160 c 0,102,103
- 3107 160 3107 160 3097.5 166.5 c 128,-1,104
- 3088 173 3088 173 3088 186 c 0,105,106
- 3088 195 3088 195 3103 228 c 128,-1,107
- 3118 261 3118 261 3145 308 c 128,-1,108
- 3172 355 3172 355 3221 412 c 128,-1,109
- 3270 469 3270 469 3328 511 c 5,55,-1
-EndSplineSet
-Validated: 1029
+HStem: 511 88<313 3328>
+VStem: 482 71<166.706 257.064> 3088 71<849.875 943.302>
+LayerCount: 2
+Fore
+SplineSet
+2041 511 m 1,0,-1
+ 2020 511 l 1,1,-1
+ 1621 511 l 1,2,-1
+ 1600 511 l 1,3,-1
+ 313 511 l 1,4,5
+ 371 469 371 469 420 412 c 128,-1,6
+ 469 355 469 355 496 308 c 128,-1,7
+ 523 261 523 261 538 228 c 128,-1,8
+ 553 195 553 195 553 186 c 0,9,10
+ 553 172 553 172 543 166 c 128,-1,11
+ 533 160 533 160 519 160 c 0,12,13
+ 502 160 502 160 496 166.5 c 128,-1,14
+ 490 173 490 173 482 191 c 0,15,16
+ 431 301 431 301 356 383.5 c 128,-1,17
+ 281 466 281 466 153 526 c 0,18,19
+ 147 529 147 529 142.5 532 c 128,-1,20
+ 138 535 138 535 134 538 c 128,-1,21
+ 130 541 130 541 128.5 545 c 128,-1,22
+ 127 549 127 549 127 555 c 128,-1,23
+ 127 561 127 561 127.5 564 c 128,-1,24
+ 128 567 128 567 134 571.5 c 128,-1,25
+ 140 576 140 576 141.5 577 c 128,-1,26
+ 143 578 143 578 158 586 c 0,27,28
+ 221 616 221 616 274 655.5 c 128,-1,29
+ 327 695 327 695 359 728 c 0,30,31
+ 391 762 391 762 419 805 c 128,-1,32
+ 447 848 447 848 458.5 871.5 c 128,-1,33
+ 470 895 470 895 484 928 c 0,34,35
+ 488 936 488 936 489.5 938.5 c 128,-1,36
+ 491 941 491 941 499 945.5 c 128,-1,37
+ 507 950 507 950 519 950 c 0,38,39
+ 533 950 533 950 543 943.5 c 128,-1,40
+ 553 937 553 937 553 924 c 0,41,42
+ 553 915 553 915 538 882 c 128,-1,43
+ 523 849 523 849 496 802 c 128,-1,44
+ 469 755 469 755 420 698.5 c 128,-1,45
+ 371 642 371 642 313 599 c 1,46,-1
+ 1600 599 l 1,47,-1
+ 1621 599 l 1,48,-1
+ 2020 599 l 1,49,-1
+ 2041 599 l 1,50,-1
+ 3328 599 l 1,51,52
+ 3270 641 3270 641 3221 698 c 128,-1,53
+ 3172 755 3172 755 3145 802 c 128,-1,54
+ 3118 849 3118 849 3103 882 c 128,-1,55
+ 3088 915 3088 915 3088 924 c 0,56,57
+ 3088 938 3088 938 3098 944 c 128,-1,58
+ 3108 950 3108 950 3121 950 c 0,59,60
+ 3138 950 3138 950 3144 944 c 0,61,62
+ 3151 937 3151 937 3159 919 c 0,63,64
+ 3190 848 3190 848 3232 788 c 0,65,66
+ 3273 731 3273 731 3319.5 691.5 c 128,-1,67
+ 3366 652 3366 652 3406.5 626.5 c 128,-1,68
+ 3447 601 3447 601 3499 577 c 1,69,70
+ 3502 577 3502 577 3508 571 c 128,-1,71
+ 3514 565 3514 565 3514 555 c 0,72,73
+ 3514 544 3514 544 3509 539 c 128,-1,74
+ 3504 534 3504 534 3483 524 c 0,75,76
+ 3437 502 3437 502 3396.5 475.5 c 128,-1,77
+ 3356 449 3356 449 3327 424.5 c 128,-1,78
+ 3298 400 3298 400 3271.5 369 c 128,-1,79
+ 3245 338 3245 338 3229.5 316 c 128,-1,80
+ 3214 294 3214 294 3197.5 264 c 128,-1,81
+ 3181 234 3181 234 3174 220 c 128,-1,82
+ 3167 206 3167 206 3157 182 c 0,83,84
+ 3153 174 3153 174 3151.5 171.5 c 128,-1,85
+ 3150 169 3150 169 3142 164.5 c 128,-1,86
+ 3134 160 3134 160 3121 160 c 0,87,88
+ 3107 160 3107 160 3097.5 166.5 c 128,-1,89
+ 3088 173 3088 173 3088 186 c 0,90,91
+ 3088 195 3088 195 3103 228 c 128,-1,92
+ 3118 261 3118 261 3145 308 c 128,-1,93
+ 3172 355 3172 355 3221 412 c 128,-1,94
+ 3270 469 3270 469 3328 511 c 1,95,-1
+ 2041 511 l 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni27F8
@@ -36169,117 +36091,95 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 295 89<677 2073 2071 3457> 726 89<737 2073 2071 3457>
-LayerCount: 2
-Fore
-SplineSet
-2047 295 m 2,0,-1
- 737 295 l 1,1,2
- 799 227 799 227 846.5 163 c 128,-1,3
- 894 99 894 99 916 59.5 c 128,-1,4
- 938 20 938 20 948.5 -2.5 c 128,-1,5
- 959 -25 959 -25 959 -29 c 0,6,7
- 959 -41 959 -41 951 -47.5 c 128,-1,8
- 943 -54 943 -54 935.5 -55 c 128,-1,9
- 928 -56 928 -56 915 -56 c 0,10,11
- 891 -56 891 -56 881 -49 c 0,12,13
- 879 -48 879 -48 878 -46 c 128,-1,14
- 877 -44 877 -44 875 -40 c 128,-1,15
- 873 -36 873 -36 866.5 -24.5 c 128,-1,16
- 860 -13 860 -13 852 0 c 0,17,18
- 817 64 817 64 775.5 123 c 128,-1,19
- 734 182 734 182 674 243.5 c 128,-1,20
- 614 305 614 305 544.5 356 c 128,-1,21
- 475 407 475 407 383.5 452 c 128,-1,22
- 292 497 292 497 189 526 c 0,23,24
- 169 532 169 532 161 537.5 c 128,-1,25
- 153 543 153 543 153 555.5 c 128,-1,26
- 153 568 153 568 161 573 c 128,-1,27
- 169 578 169 578 191 584 c 0,28,29
- 318 620 318 620 426.5 679 c 128,-1,30
- 535 738 535 738 615.5 811.5 c 128,-1,31
- 696 885 696 885 755 961 c 128,-1,32
- 814 1037 814 1037 859 1123 c 0,33,34
- 876 1154 876 1154 883 1160 c 128,-1,35
- 890 1166 890 1166 915 1166 c 0,36,37
- 929 1166 929 1166 936 1165 c 128,-1,38
- 943 1164 943 1164 951 1157.5 c 128,-1,39
- 959 1151 959 1151 959 1139 c 0,40,41
- 959 1134 959 1134 948.5 1111.5 c 128,-1,42
- 938 1089 938 1089 916 1049 c 128,-1,43
- 894 1009 894 1009 846.5 945.5 c 128,-1,44
- 799 882 799 882 737 815 c 1,45,-1
- 2047 815 l 2,46,47
- 2063 815 2063 815 2072 814 c 128,-1,48
- 2081 813 2081 813 2094 809.5 c 128,-1,49
- 2107 806 2107 806 2113.5 796 c 128,-1,50
- 2120 786 2120 786 2120 770 c 0,51,52
- 2120 757 2120 757 2115 748.5 c 128,-1,53
- 2110 740 2110 740 2103.5 735.5 c 128,-1,54
- 2097 731 2097 731 2085 729 c 128,-1,55
- 2073 727 2073 727 2065.5 726.5 c 128,-1,56
- 2058 726 2058 726 2045 726 c 2,57,-1
- 677 726 l 2,58,59
- 649 726 649 726 639.5 723 c 128,-1,60
- 630 720 630 720 610 704 c 0,61,62
- 479 609 479 609 355 555 c 1,63,64
- 490 494 490 494 608 406 c 0,65,66
- 629 390 629 390 639 387 c 128,-1,67
- 649 384 649 384 677 384 c 2,68,-1
- 2045 384 l 2,69,70
- 2059 384 2059 384 2066 383.5 c 128,-1,71
- 2073 383 2073 383 2085 381 c 128,-1,72
- 2097 379 2097 379 2103.5 374.5 c 128,-1,73
- 2110 370 2110 370 2115 361 c 128,-1,74
- 2120 352 2120 352 2120 340 c 0,75,76
- 2120 324 2120 324 2113.5 314 c 128,-1,77
- 2107 304 2107 304 2094 300.5 c 128,-1,78
- 2081 297 2081 297 2072 296 c 128,-1,79
- 2063 295 2063 295 2047 295 c 2,0,-1
-3434 726 m 2,80,-1
+HStem: 295 89<737 3503.3> 726 89<737 3503.3>
+LayerCount: 2
+Fore
+SplineSet
+3437 295 m 2,0,-1
+ 2107 295 l 2,1,2
+ 2091 295 2091 295 2082 296 c 0,3,4
+ 2079 296 2079 296 2077 297 c 0,5,6
+ 2074 296 2074 296 2072 296 c 0,7,8
+ 2063 295 2063 295 2047 295 c 2,9,-1
+ 737 295 l 1,10,11
+ 793 233 793 233 846 163 c 0,12,13
+ 894 99 894 99 916 59 c 0,14,15
+ 938 20 938 20 948.5 -2.5 c 128,-1,16
+ 959 -25 959 -25 959 -29 c 0,17,18
+ 959 -41 959 -41 951 -47.5 c 128,-1,19
+ 943 -54 943 -54 935.5 -55 c 128,-1,20
+ 928 -56 928 -56 915 -56 c 0,21,22
+ 891 -56 891 -56 881 -49 c 0,23,24
+ 879 -48 879 -48 878 -46 c 2,25,-1
+ 875 -40 l 2,26,27
+ 873 -36 873 -36 866 -24 c 2,28,-1
+ 852 0 l 1,29,30
+ 817 64 817 64 775.5 123 c 128,-1,31
+ 734 182 734 182 674 243.5 c 128,-1,32
+ 614 305 614 305 544.5 356 c 128,-1,33
+ 475 407 475 407 383.5 452 c 128,-1,34
+ 292 497 292 497 189 526 c 0,35,36
+ 169 532 169 532 161 537.5 c 128,-1,37
+ 153 543 153 543 153 555.5 c 128,-1,38
+ 153 568 153 568 161 573 c 0,39,40
+ 168 578 168 578 191 584 c 0,41,42
+ 318 620 318 620 426.5 679 c 128,-1,43
+ 535 738 535 738 615.5 811.5 c 128,-1,44
+ 696 885 696 885 755 961 c 128,-1,45
+ 814 1037 814 1037 859 1123 c 0,46,47
+ 876 1154 876 1154 883 1160 c 128,-1,48
+ 890 1166 890 1166 915 1166 c 0,49,50
+ 929 1166 929 1166 936 1165 c 128,-1,51
+ 943 1164 943 1164 951 1157.5 c 128,-1,52
+ 959 1151 959 1151 959 1139 c 0,53,54
+ 959 1134 959 1134 948.5 1111.5 c 128,-1,55
+ 938 1089 938 1089 916 1049 c 128,-1,56
+ 894 1009 894 1009 846.5 945.5 c 128,-1,57
+ 799 882 799 882 737 815 c 1,58,-1
+ 2047 815 l 2,59,60
+ 2063 815 2063 815 2072 814 c 0,61,62
+ 2074 814 2074 814 2077 813 c 0,63,64
+ 2079 814 2079 814 2082 814 c 0,65,66
+ 2091 815 2091 815 2107 815 c 2,67,-1
+ 3437 815 l 2,68,69
+ 3453 815 3453 815 3462 814 c 128,-1,70
+ 3471 813 3471 813 3484 809.5 c 128,-1,71
+ 3497 806 3497 806 3503.5 796 c 128,-1,72
+ 3510 786 3510 786 3510 770 c 0,73,74
+ 3510 757 3510 757 3505 748.5 c 128,-1,75
+ 3500 740 3500 740 3494 736 c 0,76,77
+ 3487 731 3487 731 3475 729 c 128,-1,78
+ 3463 727 3463 727 3455.5 726.5 c 128,-1,79
+ 3448 726 3448 726 3434 726 c 2,80,-1
2109 726 l 2,81,82
- 2095 726 2095 726 2088 726.5 c 128,-1,83
- 2081 727 2081 727 2068.5 729 c 128,-1,84
- 2056 731 2056 731 2050 735.5 c 128,-1,85
- 2044 740 2044 740 2039 749 c 128,-1,86
- 2034 758 2034 758 2034 770 c 0,87,88
- 2034 786 2034 786 2040 796 c 128,-1,89
- 2046 806 2046 806 2059 809.5 c 128,-1,90
- 2072 813 2072 813 2081.5 814 c 128,-1,91
- 2091 815 2091 815 2107 815 c 2,92,-1
- 3437 815 l 2,93,94
- 3453 815 3453 815 3462 814 c 128,-1,95
- 3471 813 3471 813 3484 809.5 c 128,-1,96
- 3497 806 3497 806 3503.5 796 c 128,-1,97
- 3510 786 3510 786 3510 770 c 0,98,99
- 3510 757 3510 757 3505 748.5 c 128,-1,100
- 3500 740 3500 740 3493.5 735.5 c 128,-1,101
- 3487 731 3487 731 3475 729 c 128,-1,102
- 3463 727 3463 727 3455.5 726.5 c 128,-1,103
- 3448 726 3448 726 3434 726 c 2,80,-1
-3437 295 m 2,104,-1
- 2107 295 l 2,105,106
- 2091 295 2091 295 2081.5 296 c 128,-1,107
- 2072 297 2072 297 2059 300.5 c 128,-1,108
- 2046 304 2046 304 2040 314 c 128,-1,109
- 2034 324 2034 324 2034 340 c 0,110,111
- 2034 353 2034 353 2039 361.5 c 128,-1,112
- 2044 370 2044 370 2050 374.5 c 128,-1,113
- 2056 379 2056 379 2068.5 381 c 128,-1,114
- 2081 383 2081 383 2088 383.5 c 128,-1,115
- 2095 384 2095 384 2109 384 c 2,116,-1
- 3434 384 l 2,117,118
- 3448 384 3448 384 3455.5 383.5 c 128,-1,119
- 3463 383 3463 383 3475 381 c 128,-1,120
- 3487 379 3487 379 3493.5 374.5 c 128,-1,121
- 3500 370 3500 370 3505 361 c 128,-1,122
- 3510 352 3510 352 3510 340 c 0,123,124
- 3510 324 3510 324 3503.5 314 c 128,-1,125
- 3497 304 3497 304 3484 300.5 c 128,-1,126
- 3471 297 3471 297 3462 296 c 128,-1,127
- 3453 295 3453 295 3437 295 c 2,104,-1
-EndSplineSet
-Validated: 1029
+ 2088 726 2088 726 2088 726 c 0,83,84
+ 2084 727 2084 727 2077 728 c 1,85,86
+ 2070 727 2070 727 2065.5 726.5 c 128,-1,87
+ 2061 726 2061 726 2045 726 c 2,88,-1
+ 677 726 l 2,89,90
+ 649 726 649 726 639.5 723 c 128,-1,91
+ 630 720 630 720 610 704 c 1,92,93
+ 479 609 479 609 355 555 c 1,94,95
+ 490 494 490 494 608 406 c 0,96,97
+ 630 390 630 390 639 387 c 0,98,99
+ 649 384 649 384 677 384 c 2,100,-1
+ 2045 384 l 2,101,102
+ 2066 384 2066 384 2066 384 c 0,103,104
+ 2070 383 2070 383 2077 382 c 1,105,106
+ 2084 383 2084 383 2088 383.5 c 128,-1,108
+ 2092 384 2092 384 2109 384 c 2,109,-1
+ 3434 384 l 2,110,111
+ 3448 384 3448 384 3455.5 383.5 c 128,-1,112
+ 3463 383 3463 383 3475 381 c 128,-1,113
+ 3487 379 3487 379 3493.5 374.5 c 128,-1,114
+ 3500 370 3500 370 3505 361 c 128,-1,115
+ 3510 352 3510 352 3510 340 c 0,116,117
+ 3510 324 3510 324 3503.5 314 c 128,-1,118
+ 3497 304 3497 304 3484 300.5 c 128,-1,119
+ 3471 297 3471 297 3462 296 c 128,-1,120
+ 3453 295 3453 295 3437 295 c 2,0,-1
+EndSplineSet
+Validated: 1025
EndChar
StartChar: uni27F9
@@ -36287,117 +36187,91 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 295 89<195 1581 1576 2922> 726 89<195 1581 1576 2922>
-LayerCount: 2
-Fore
-SplineSet
-2981 726 m 6,0,-1
- 1614 726 l 2,1,2
- 1600 726 1600 726 1592.5 726.5 c 128,-1,3
- 1585 727 1585 727 1573 729 c 128,-1,4
- 1561 731 1561 731 1555 735.5 c 128,-1,5
- 1549 740 1549 740 1543.5 749 c 128,-1,6
- 1538 758 1538 758 1538 770 c 0,7,8
- 1538 786 1538 786 1544.5 796 c 128,-1,9
- 1551 806 1551 806 1564 809.5 c 128,-1,10
- 1577 813 1577 813 1586 814 c 128,-1,11
- 1595 815 1595 815 1612 815 c 2,12,-1
- 2922 815 l 1,13,14
- 2860 883 2860 883 2812 947 c 128,-1,15
- 2764 1011 2764 1011 2742 1050.5 c 128,-1,16
- 2720 1090 2720 1090 2710 1112.5 c 128,-1,17
- 2700 1135 2700 1135 2700 1139 c 0,18,19
- 2700 1151 2700 1151 2707.5 1157.5 c 128,-1,20
- 2715 1164 2715 1164 2722.5 1165 c 128,-1,21
- 2730 1166 2730 1166 2744 1166 c 0,22,23
- 2768 1166 2768 1166 2777 1159 c 0,24,25
- 2779 1158 2779 1158 2780.5 1156 c 128,-1,26
- 2782 1154 2782 1154 2784 1150 c 128,-1,27
- 2786 1146 2786 1146 2792 1134.5 c 128,-1,28
- 2798 1123 2798 1123 2806 1110 c 0,29,30
- 2841 1046 2841 1046 2883 987 c 128,-1,31
- 2925 928 2925 928 2985 866.5 c 128,-1,32
- 3045 805 3045 805 3114 754 c 128,-1,33
- 3183 703 3183 703 3275 658 c 128,-1,34
- 3367 613 3367 613 3470 584 c 0,35,36
- 3490 578 3490 578 3497.5 572.5 c 128,-1,37
- 3505 567 3505 567 3505 554.5 c 128,-1,38
- 3505 542 3505 542 3497 537 c 128,-1,39
- 3489 532 3489 532 3468 526 c 0,40,41
- 3341 490 3341 490 3232.5 431 c 128,-1,42
- 3124 372 3124 372 3043 298.5 c 128,-1,43
- 2962 225 2962 225 2903.5 149 c 128,-1,44
- 2845 73 2845 73 2799 -13 c 0,45,46
- 2782 -44 2782 -44 2775 -50 c 128,-1,47
- 2768 -56 2768 -56 2744 -56 c 0,48,49
- 2730 -56 2730 -56 2722.5 -55 c 128,-1,50
- 2715 -54 2715 -54 2707.5 -47.5 c 128,-1,51
- 2700 -41 2700 -41 2700 -29 c 0,52,53
- 2700 -24 2700 -24 2710 -1.5 c 128,-1,54
- 2720 21 2720 21 2742 61 c 128,-1,55
- 2764 101 2764 101 2811.5 164.5 c 128,-1,56
- 2859 228 2859 228 2922 295 c 1,57,-1
- 1612 295 l 2,58,59
- 1596 295 1596 295 1586.5 296 c 128,-1,60
- 1577 297 1577 297 1564 300.5 c 128,-1,61
- 1551 304 1551 304 1544.5 314 c 128,-1,62
- 1538 324 1538 324 1538 340 c 0,63,64
- 1538 353 1538 353 1543.5 361.5 c 128,-1,65
- 1549 370 1549 370 1555 374.5 c 128,-1,66
- 1561 379 1561 379 1573 381 c 128,-1,67
- 1585 383 1585 383 1592.5 383.5 c 128,-1,68
- 1600 384 1600 384 1614 384 c 2,69,-1
- 2981 384 l 2,70,71
- 3009 384 3009 384 3019 387 c 128,-1,72
- 3029 390 3029 390 3048 406 c 0,73,74
- 3179 501 3179 501 3303 555 c 1,75,76
- 3168 616 3168 616 3050 704 c 0,77,78
- 3029 720 3029 720 3019 723 c 128,-1,79
- 3009 726 3009 726 2981 726 c 6,0,-1
-1558 726 m 6,80,-1
- 233 726 l 2,81,82
- 219 726 219 726 212 726.5 c 128,-1,83
- 205 727 205 727 193 729 c 128,-1,84
- 181 731 181 731 174.5 735.5 c 128,-1,85
- 168 740 168 740 163 749 c 128,-1,86
- 158 758 158 758 158 770 c 0,87,88
- 158 786 158 786 164 796 c 128,-1,89
- 170 806 170 806 183 809.5 c 128,-1,90
- 196 813 196 813 205.5 814 c 128,-1,91
- 215 815 215 815 231 815 c 2,92,-1
- 1561 815 l 2,93,94
- 1577 815 1577 815 1586 814 c 128,-1,95
- 1595 813 1595 813 1608 809.5 c 128,-1,96
- 1621 806 1621 806 1627.5 796 c 128,-1,97
- 1634 786 1634 786 1634 770 c 0,98,99
- 1634 757 1634 757 1629 748.5 c 128,-1,100
- 1624 740 1624 740 1617.5 735.5 c 128,-1,101
- 1611 731 1611 731 1599 729 c 128,-1,102
- 1587 727 1587 727 1579.5 726.5 c 128,-1,103
- 1572 726 1572 726 1558 726 c 6,80,-1
-1561 295 m 6,104,-1
- 231 295 l 2,105,106
- 215 295 215 295 205.5 296 c 128,-1,107
- 196 297 196 297 183 300.5 c 128,-1,108
- 170 304 170 304 164 314 c 128,-1,109
- 158 324 158 324 158 340 c 0,110,111
- 158 353 158 353 163 361.5 c 128,-1,112
- 168 370 168 370 174.5 374.5 c 128,-1,113
- 181 379 181 379 193 381 c 128,-1,114
- 205 383 205 383 212 383.5 c 128,-1,115
- 219 384 219 384 233 384 c 2,116,-1
- 1558 384 l 2,117,118
- 1572 384 1572 384 1579.5 383.5 c 128,-1,119
- 1587 383 1587 383 1599 381 c 128,-1,120
- 1611 379 1611 379 1617.5 374.5 c 128,-1,121
- 1624 370 1624 370 1629 361 c 128,-1,122
- 1634 352 1634 352 1634 340 c 0,123,124
- 1634 324 1634 324 1627.5 314 c 128,-1,125
- 1621 304 1621 304 1608 300.5 c 128,-1,126
- 1595 297 1595 297 1586 296 c 128,-1,127
- 1577 295 1577 295 1561 295 c 6,104,-1
-EndSplineSet
-Validated: 1029
+HStem: 295 89<164.189 2922> 726.5 88.5<164.189 2922>
+LayerCount: 2
+Fore
+SplineSet
+1561 295 m 2,0,-1
+ 231 295 l 2,1,2
+ 215 295 215 295 205.5 296 c 128,-1,3
+ 196 297 196 297 183 300.5 c 128,-1,4
+ 170 304 170 304 164 314 c 128,-1,5
+ 158 324 158 324 158 340 c 0,6,7
+ 158 353 158 353 163 361.5 c 128,-1,8
+ 168 370 168 370 174.5 374.5 c 128,-1,9
+ 181 379 181 379 193 381 c 128,-1,10
+ 205 383 205 383 212 383.5 c 128,-1,11
+ 219 384 219 384 233 384 c 2,12,-1
+ 1558 384 l 1,13,-1
+ 1580 384 l 1,14,15
+ 1582 383 1582 383 1586 383 c 128,-1,16
+ 1590 383 1590 383 1592 384 c 0,17,18
+ 1595 384 1595 384 1614 384 c 2,19,-1
+ 2981 384 l 2,20,21
+ 3009 384 3009 384 3019 387 c 128,-1,22
+ 3029 390 3029 390 3048 406 c 1,23,24
+ 3179 501 3179 501 3303 555 c 1,25,26
+ 3168 616 3168 616 3050 704 c 0,27,28
+ 3029 720 3029 720 3019 723 c 128,-1,29
+ 3009 726 3009 726 2981 726 c 2,30,-1
+ 1614 726 l 1,31,-1
+ 1592 726 l 1,32,33
+ 1590 727 1590 727 1586 727 c 128,-1,34
+ 1582 727 1582 727 1579.5 726.5 c 128,-1,35
+ 1577 726 1577 726 1558 726 c 2,36,-1
+ 233 726 l 2,37,38
+ 219 726 219 726 212 726.5 c 128,-1,39
+ 205 727 205 727 193 729 c 128,-1,40
+ 181 731 181 731 174.5 735.5 c 128,-1,41
+ 168 740 168 740 163 749 c 128,-1,42
+ 158 758 158 758 158 770 c 0,43,44
+ 158 786 158 786 164 796 c 128,-1,45
+ 170 806 170 806 183 809.5 c 128,-1,46
+ 196 813 196 813 205.5 814 c 128,-1,47
+ 215 815 215 815 231 815 c 2,48,-1
+ 1561 815 l 2,49,50
+ 1577 815 1577 815 1586 814 c 1,51,52
+ 1595 815 1595 815 1612 815 c 2,53,-1
+ 2922 815 l 1,54,55
+ 2860 883 2860 883 2812 947 c 128,-1,56
+ 2764 1011 2764 1011 2742 1050.5 c 128,-1,57
+ 2720 1090 2720 1090 2710 1112.5 c 128,-1,58
+ 2700 1135 2700 1135 2700 1139 c 0,59,60
+ 2700 1151 2700 1151 2707.5 1157.5 c 128,-1,61
+ 2715 1164 2715 1164 2722.5 1165 c 128,-1,62
+ 2730 1166 2730 1166 2744 1166 c 0,63,64
+ 2768 1166 2768 1166 2777 1159 c 0,65,66
+ 2779 1158 2779 1158 2780.5 1156 c 128,-1,67
+ 2782 1154 2782 1154 2784 1150 c 2,68,-1
+ 2792 1134 l 2,69,70
+ 2798 1123 2798 1123 2806 1110 c 0,71,72
+ 2873 1001 2873 1001 2883 987 c 0,73,74
+ 2926 927 2926 927 2985 866 c 0,75,76
+ 3045 805 3045 805 3114 754 c 128,-1,77
+ 3183 703 3183 703 3275 658 c 128,-1,78
+ 3367 613 3367 613 3470 584 c 0,79,80
+ 3490 578 3490 578 3497.5 572.5 c 128,-1,81
+ 3505 567 3505 567 3505 554.5 c 128,-1,82
+ 3505 542 3505 542 3497 537 c 128,-1,83
+ 3489 532 3489 532 3468 526 c 0,84,85
+ 3340 489 3340 489 3232 431 c 0,86,87
+ 3129 375 3129 375 3043 298 c 0,88,89
+ 2961 224 2961 224 2904 149 c 0,90,91
+ 2845 73 2845 73 2799 -13 c 0,92,93
+ 2783 -43 2783 -43 2775 -50 c 0,94,95
+ 2768 -56 2768 -56 2744 -56 c 0,96,97
+ 2730 -56 2730 -56 2722.5 -55 c 128,-1,98
+ 2715 -54 2715 -54 2707.5 -47.5 c 128,-1,99
+ 2700 -41 2700 -41 2700 -29 c 0,100,101
+ 2700 -24 2700 -24 2710 -1.5 c 128,-1,102
+ 2720 21 2720 21 2742 61 c 128,-1,103
+ 2764 101 2764 101 2811.5 164.5 c 128,-1,104
+ 2859 228 2859 228 2922 295 c 1,105,-1
+ 1612 295 l 2,106,107
+ 1596 295 1596 295 1586 296 c 1,108,109
+ 1577 295 1577 295 1561 295 c 2,0,-1
+EndSplineSet
+Validated: 1025
EndChar
StartChar: uni27FA
@@ -36405,138 +36279,106 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 295 89<665 2061 1593 2938> 726 89<725 2061 1593 2938>
-LayerCount: 2
-Fore
-SplineSet
-2035 295 m 6,0,-1
- 725 295 l 1,1,2
- 787 227 787 227 834.5 163 c 128,-1,3
- 882 99 882 99 904 59.5 c 128,-1,4
- 926 20 926 20 936.5 -2.5 c 128,-1,5
- 947 -25 947 -25 947 -29 c 0,6,7
- 947 -41 947 -41 939 -47.5 c 128,-1,8
- 931 -54 931 -54 923.5 -55 c 128,-1,9
- 916 -56 916 -56 902 -56 c 0,10,11
- 878 -56 878 -56 869 -49 c 0,12,13
- 867 -48 867 -48 865.5 -46 c 128,-1,14
- 864 -44 864 -44 862 -40 c 128,-1,15
- 860 -36 860 -36 854 -24.5 c 128,-1,16
- 848 -13 848 -13 840 0 c 0,17,18
- 805 64 805 64 763.5 123 c 128,-1,19
- 722 182 722 182 662 243.5 c 128,-1,20
- 602 305 602 305 532.5 356 c 128,-1,21
- 463 407 463 407 371.5 452 c 128,-1,22
- 280 497 280 497 176 526 c 0,23,24
- 156 532 156 532 148.5 537.5 c 128,-1,25
- 141 543 141 543 141 555.5 c 128,-1,26
- 141 568 141 568 149 573 c 128,-1,27
- 157 578 157 578 179 584 c 0,28,29
- 306 620 306 620 414 679 c 128,-1,30
- 522 738 522 738 603 811.5 c 128,-1,31
- 684 885 684 885 743 961 c 128,-1,32
- 802 1037 802 1037 847 1123 c 0,33,34
- 864 1154 864 1154 871 1160 c 128,-1,35
- 878 1166 878 1166 902 1166 c 0,36,37
- 916 1166 916 1166 923.5 1165 c 128,-1,38
- 931 1164 931 1164 939 1157.5 c 128,-1,39
- 947 1151 947 1151 947 1139 c 0,40,41
- 947 1134 947 1134 936.5 1111.5 c 128,-1,42
- 926 1089 926 1089 904 1049 c 128,-1,43
- 882 1009 882 1009 834.5 945.5 c 128,-1,44
- 787 882 787 882 725 815 c 1,45,-1
- 2035 815 l 2,46,47
- 2051 815 2051 815 2060 814 c 128,-1,48
- 2069 813 2069 813 2082 809.5 c 128,-1,49
- 2095 806 2095 806 2101.5 796 c 128,-1,50
- 2108 786 2108 786 2108 770 c 0,51,52
- 2108 757 2108 757 2103 748.5 c 128,-1,53
- 2098 740 2098 740 2091.5 735.5 c 128,-1,54
- 2085 731 2085 731 2073 729 c 128,-1,55
- 2061 727 2061 727 2053.5 726.5 c 128,-1,56
- 2046 726 2046 726 2032 726 c 2,57,-1
- 665 726 l 2,58,59
- 637 726 637 726 627.5 723 c 128,-1,60
- 618 720 618 720 598 704 c 0,61,62
- 467 609 467 609 343 555 c 1,63,64
- 478 494 478 494 596 406 c 0,65,66
- 617 390 617 390 627 387 c 128,-1,67
- 637 384 637 384 665 384 c 2,68,-1
- 2032 384 l 2,69,70
- 2046 384 2046 384 2053.5 383.5 c 128,-1,71
- 2061 383 2061 383 2073 381 c 128,-1,72
- 2085 379 2085 379 2091.5 374.5 c 128,-1,73
- 2098 370 2098 370 2103 361 c 128,-1,74
- 2108 352 2108 352 2108 340 c 0,75,76
- 2108 324 2108 324 2101.5 314 c 128,-1,77
- 2095 304 2095 304 2082 300.5 c 128,-1,78
- 2069 297 2069 297 2060 296 c 128,-1,79
- 2051 295 2051 295 2035 295 c 6,0,-1
-2998 726 m 6,80,-1
- 1631 726 l 2,81,82
- 1617 726 1617 726 1609.5 726.5 c 128,-1,83
- 1602 727 1602 727 1590 729 c 128,-1,84
- 1578 731 1578 731 1571.5 735.5 c 128,-1,85
- 1565 740 1565 740 1560 749 c 128,-1,86
- 1555 758 1555 758 1555 770 c 0,87,88
- 1555 786 1555 786 1561.5 796 c 128,-1,89
- 1568 806 1568 806 1581 809.5 c 128,-1,90
- 1594 813 1594 813 1603 814 c 128,-1,91
- 1612 815 1612 815 1628 815 c 2,92,-1
- 2938 815 l 1,93,94
- 2876 883 2876 883 2828.5 947 c 128,-1,95
- 2781 1011 2781 1011 2759 1050.5 c 128,-1,96
- 2737 1090 2737 1090 2726.5 1112.5 c 128,-1,97
- 2716 1135 2716 1135 2716 1139 c 0,98,99
- 2716 1151 2716 1151 2724 1157.5 c 128,-1,100
- 2732 1164 2732 1164 2739.5 1165 c 128,-1,101
- 2747 1166 2747 1166 2761 1166 c 0,102,103
- 2785 1166 2785 1166 2794 1159 c 0,104,105
- 2796 1158 2796 1158 2797.5 1156 c 128,-1,106
- 2799 1154 2799 1154 2801 1150 c 128,-1,107
- 2803 1146 2803 1146 2809 1134.5 c 128,-1,108
- 2815 1123 2815 1123 2823 1110 c 0,109,110
- 2858 1046 2858 1046 2899.5 987 c 128,-1,111
- 2941 928 2941 928 3001 866.5 c 128,-1,112
- 3061 805 3061 805 3130.5 754 c 128,-1,113
- 3200 703 3200 703 3291.5 658 c 128,-1,114
- 3383 613 3383 613 3487 584 c 0,115,116
- 3507 578 3507 578 3514.5 572.5 c 128,-1,117
- 3522 567 3522 567 3522 554.5 c 128,-1,118
- 3522 542 3522 542 3514 537 c 128,-1,119
- 3506 532 3506 532 3484 526 c 0,120,121
- 3357 490 3357 490 3249 431 c 128,-1,122
- 3141 372 3141 372 3060 298.5 c 128,-1,123
- 2979 225 2979 225 2920 149 c 128,-1,124
- 2861 73 2861 73 2816 -13 c 0,125,126
- 2799 -44 2799 -44 2792 -50 c 128,-1,127
- 2785 -56 2785 -56 2761 -56 c 0,128,129
- 2747 -56 2747 -56 2739.5 -55 c 128,-1,130
- 2732 -54 2732 -54 2724 -47.5 c 128,-1,131
- 2716 -41 2716 -41 2716 -29 c 0,132,133
- 2716 -24 2716 -24 2726.5 -1.5 c 128,-1,134
- 2737 21 2737 21 2759 61 c 128,-1,135
- 2781 101 2781 101 2828.5 164.5 c 128,-1,136
- 2876 228 2876 228 2938 295 c 1,137,-1
- 1628 295 l 2,138,139
- 1612 295 1612 295 1603 296 c 128,-1,140
- 1594 297 1594 297 1581 300.5 c 128,-1,141
- 1568 304 1568 304 1561.5 314 c 128,-1,142
- 1555 324 1555 324 1555 340 c 0,143,144
- 1555 353 1555 353 1560 361.5 c 128,-1,145
- 1565 370 1565 370 1571.5 374.5 c 128,-1,146
- 1578 379 1578 379 1590 381 c 128,-1,147
- 1602 383 1602 383 1609.5 383.5 c 128,-1,148
- 1617 384 1617 384 1631 384 c 2,149,-1
- 2998 384 l 2,150,151
- 3026 384 3026 384 3035.5 387 c 128,-1,152
- 3045 390 3045 390 3065 406 c 0,153,154
- 3196 501 3196 501 3320 555 c 1,155,156
- 3185 616 3185 616 3067 704 c 0,157,158
- 3046 720 3046 720 3036 723 c 128,-1,159
- 3026 726 3026 726 2998 726 c 6,80,-1
-EndSplineSet
-Validated: 1029
+HStem: 295 89<725 2938> 726 89<725 2938>
+LayerCount: 2
+Fore
+SplineSet
+2032 384 m 1,0,-1
+ 2998 384 l 2,1,2
+ 3026 384 3026 384 3035.5 387 c 128,-1,3
+ 3045 390 3045 390 3065 406 c 1,4,5
+ 3196 501 3196 501 3320 555 c 1,6,7
+ 3185 616 3185 616 3067 704 c 0,8,9
+ 3046 720 3046 720 3036 723 c 128,-1,10
+ 3026 726 3026 726 2998 726 c 2,11,-1
+ 2032 726 l 1,12,-1
+ 1631 726 l 1,13,-1
+ 665 726 l 2,14,15
+ 637 726 637 726 627.5 723 c 128,-1,16
+ 618 720 618 720 598 704 c 1,17,18
+ 467 609 467 609 343 555 c 1,19,20
+ 478 494 478 494 596 406 c 0,21,22
+ 618 390 618 390 627 387 c 0,23,24
+ 637 384 637 384 665 384 c 2,25,-1
+ 1631 384 l 1,26,-1
+ 2032 384 l 1,0,-1
+2035 815 m 1,27,-1
+ 2938 815 l 1,28,29
+ 2876 883 2876 883 2828.5 947 c 128,-1,30
+ 2781 1011 2781 1011 2759 1050.5 c 128,-1,31
+ 2737 1090 2737 1090 2726.5 1112.5 c 128,-1,32
+ 2716 1135 2716 1135 2716 1139 c 0,33,34
+ 2716 1151 2716 1151 2724 1157.5 c 128,-1,35
+ 2732 1164 2732 1164 2739.5 1165 c 128,-1,36
+ 2747 1166 2747 1166 2761 1166 c 0,37,38
+ 2785 1166 2785 1166 2794 1159 c 0,39,40
+ 2796 1158 2796 1158 2797.5 1156 c 128,-1,41
+ 2799 1154 2799 1154 2801 1150 c 2,42,-1
+ 2809 1134 l 2,43,44
+ 2815 1123 2815 1123 2823 1110 c 0,45,46
+ 2893 996 2893 996 2900 987 c 0,47,48
+ 2941 928 2941 928 3001 866.5 c 128,-1,49
+ 3061 805 3061 805 3130.5 754 c 128,-1,50
+ 3200 703 3200 703 3291.5 658 c 128,-1,51
+ 3383 613 3383 613 3487 584 c 0,52,53
+ 3507 578 3507 578 3514.5 572.5 c 128,-1,54
+ 3522 567 3522 567 3522 554.5 c 128,-1,55
+ 3522 542 3522 542 3514 537 c 0,56,57
+ 3507 532 3507 532 3484 526 c 0,58,59
+ 3357 490 3357 490 3249 431 c 128,-1,60
+ 3141 372 3141 372 3060 298.5 c 128,-1,61
+ 2979 225 2979 225 2920 149 c 128,-1,62
+ 2861 73 2861 73 2816 -13 c 0,63,64
+ 2800 -43 2800 -43 2792 -50 c 0,65,66
+ 2785 -56 2785 -56 2761 -56 c 0,67,68
+ 2747 -56 2747 -56 2739.5 -55 c 128,-1,69
+ 2732 -54 2732 -54 2724 -47.5 c 128,-1,70
+ 2716 -41 2716 -41 2716 -29 c 0,71,72
+ 2716 -24 2716 -24 2726.5 -1.5 c 128,-1,73
+ 2737 21 2737 21 2759 61 c 128,-1,74
+ 2781 101 2781 101 2828.5 164.5 c 128,-1,75
+ 2876 228 2876 228 2938 295 c 1,76,-1
+ 2035 295 l 1,77,-1
+ 1628 295 l 1,78,-1
+ 725 295 l 1,79,80
+ 781 233 781 233 834 163 c 0,81,82
+ 882 99 882 99 904 59 c 0,83,84
+ 926 20 926 20 936.5 -2.5 c 128,-1,85
+ 947 -25 947 -25 947 -29 c 0,86,87
+ 947 -41 947 -41 939 -47.5 c 128,-1,88
+ 931 -54 931 -54 923.5 -55 c 128,-1,89
+ 916 -56 916 -56 902 -56 c 0,90,91
+ 878 -56 878 -56 869 -49 c 0,92,93
+ 867 -48 867 -48 865.5 -46 c 128,-1,94
+ 864 -44 864 -44 862 -40 c 2,95,-1
+ 854 -24 l 2,96,97
+ 848 -13 848 -13 840 0 c 0,98,99
+ 770 114 770 114 764 123 c 0,100,101
+ 722 182 722 182 662 243.5 c 128,-1,102
+ 602 305 602 305 532.5 356 c 128,-1,103
+ 463 407 463 407 371.5 452 c 128,-1,104
+ 280 497 280 497 176 526 c 0,105,106
+ 156 532 156 532 148.5 537.5 c 128,-1,107
+ 141 543 141 543 141 555.5 c 128,-1,108
+ 141 568 141 568 149 573 c 0,109,110
+ 156 578 156 578 179 584 c 0,111,112
+ 306 620 306 620 414 679 c 128,-1,113
+ 522 738 522 738 603 811.5 c 128,-1,114
+ 684 885 684 885 743 961 c 128,-1,115
+ 802 1037 802 1037 847 1123 c 0,116,117
+ 864 1154 864 1154 871 1160 c 128,-1,118
+ 878 1166 878 1166 902 1166 c 0,119,120
+ 916 1166 916 1166 923.5 1165 c 128,-1,121
+ 931 1164 931 1164 939 1157.5 c 128,-1,122
+ 947 1151 947 1151 947 1139 c 0,123,124
+ 947 1134 947 1134 936.5 1111.5 c 128,-1,125
+ 926 1089 926 1089 904 1049 c 128,-1,126
+ 882 1009 882 1009 834.5 945.5 c 128,-1,127
+ 787 882 787 882 725 815 c 1,128,-1
+ 1628 815 l 1,129,-1
+ 2035 815 l 1,27,-1
+EndSplineSet
+Validated: 1025
EndChar
StartChar: uni27FC
@@ -36544,99 +36386,83 @@
Width: 3663
VWidth: 2220
Flags: W
-HStem: 511 89<257 273 320 1569 1569 1569 1569 3308> 924 44G<190 235>
-VStem: 168 89<163 511 599 947> 256 63<511 599> 1528 84<511 599>
-LayerCount: 2
-Fore
-SplineSet
-1539 511 m 6,0,-1
- 329 511 l 2,1,2
- 313 511 313 511 304 511.5 c 128,-1,3
- 295 512 295 512 281.5 516 c 128,-1,4
- 268 520 268 520 262 529.5 c 128,-1,5
- 256 539 256 539 256 555 c 128,-1,6
- 256 571 256 571 262 580.5 c 128,-1,7
- 268 590 268 590 281.5 594 c 128,-1,8
- 295 598 295 598 304 598.5 c 128,-1,9
- 313 599 313 599 329 599 c 2,10,-1
- 1539 599 l 2,11,12
- 1555 599 1555 599 1564 598.5 c 128,-1,13
- 1573 598 1573 598 1586.5 594 c 128,-1,14
- 1600 590 1600 590 1606 580.5 c 128,-1,15
- 1612 571 1612 571 1612 555 c 128,-1,16
- 1612 539 1612 539 1606 529.5 c 128,-1,17
- 1600 520 1600 520 1586.5 516 c 128,-1,18
- 1573 512 1573 512 1564 511.5 c 128,-1,19
- 1555 511 1555 511 1539 511 c 6,0,-1
-3308 511 m 5,20,-1
- 1601 511 l 2,21,22
- 1587 511 1587 511 1580 511 c 128,-1,23
- 1573 511 1573 511 1561.5 513.5 c 128,-1,24
- 1550 516 1550 516 1544 520.5 c 128,-1,25
- 1538 525 1538 525 1533 533.5 c 128,-1,26
- 1528 542 1528 542 1528 555 c 128,-1,27
- 1528 568 1528 568 1533 576.5 c 128,-1,28
- 1538 585 1538 585 1544 589.5 c 128,-1,29
- 1550 594 1550 594 1561.5 596.5 c 128,-1,30
- 1573 599 1573 599 1580.5 599 c 128,-1,31
- 1588 599 1588 599 1601 599 c 2,32,-1
- 3308 599 l 1,33,34
- 3250 641 3250 641 3201 698 c 128,-1,35
- 3152 755 3152 755 3125 802 c 128,-1,36
- 3098 849 3098 849 3083.5 882 c 128,-1,37
- 3069 915 3069 915 3069 924 c 0,38,39
- 3069 938 3069 938 3078.5 944 c 128,-1,40
- 3088 950 3088 950 3102 950 c 0,41,42
- 3119 950 3119 950 3125.5 943.5 c 128,-1,43
- 3132 937 3132 937 3140 919 c 0,44,45
- 3173 846 3173 846 3213.5 788.5 c 128,-1,46
- 3254 731 3254 731 3300 691.5 c 128,-1,47
- 3346 652 3346 652 3387 626.5 c 128,-1,48
- 3428 601 3428 601 3479 577 c 1,49,50
- 3482 577 3482 577 3488.5 571 c 128,-1,51
- 3495 565 3495 565 3495 555 c 0,52,53
- 3495 544 3495 544 3490 539 c 128,-1,54
- 3485 534 3485 534 3464 524 c 0,55,56
- 3418 502 3418 502 3377.5 475.5 c 128,-1,57
- 3337 449 3337 449 3308 424.5 c 128,-1,58
- 3279 400 3279 400 3252.5 369 c 128,-1,59
- 3226 338 3226 338 3210 316 c 128,-1,60
- 3194 294 3194 294 3177.5 264 c 128,-1,61
- 3161 234 3161 234 3154.5 220 c 128,-1,62
- 3148 206 3148 206 3137 182 c 0,63,64
- 3133 174 3133 174 3131.5 171.5 c 128,-1,65
- 3130 169 3130 169 3122 164.5 c 128,-1,66
- 3114 160 3114 160 3102 160 c 0,67,68
- 3088 160 3088 160 3078.5 166.5 c 128,-1,69
- 3069 173 3069 173 3069 186 c 0,70,71
- 3069 195 3069 195 3083.5 228 c 128,-1,72
- 3098 261 3098 261 3125 308 c 128,-1,73
- 3152 355 3152 355 3201 412 c 128,-1,74
- 3250 469 3250 469 3308 511 c 5,20,-1
-257 511 m 5,75,-1
- 257 215 l 2,76,77
- 257 199 257 199 256 190 c 128,-1,78
- 255 181 255 181 251.5 168 c 128,-1,79
- 248 155 248 155 238 148.5 c 128,-1,80
- 228 142 228 142 212.5 142 c 128,-1,81
- 197 142 197 142 187 148.5 c 128,-1,82
- 177 155 177 155 173.5 168 c 128,-1,83
- 170 181 170 181 169 190 c 128,-1,84
- 168 199 168 199 168 215 c 2,85,-1
- 168 895 l 2,86,87
- 168 911 168 911 169 920 c 128,-1,88
- 170 929 170 929 173.5 942 c 128,-1,89
- 177 955 177 955 187 961.5 c 128,-1,90
- 197 968 197 968 212.5 968 c 128,-1,91
- 228 968 228 968 238 961.5 c 128,-1,92
- 248 955 248 955 251.5 942 c 128,-1,93
- 255 929 255 929 256 920 c 128,-1,94
- 257 911 257 911 257 895 c 2,95,-1
- 257 599 l 1,96,97
- 319 599 319 599 319 555 c 128,-1,98
- 319 511 319 511 257 511 c 5,75,-1
-EndSplineSet
-Validated: 1029
+HStem: 511 88<257 286.567 287.269 3308>
+VStem: 168 89<142.002 511 599 967.998> 3069 71<849.875 943.302>
+LayerCount: 2
+Fore
+SplineSet
+257 511 m 1,0,-1
+ 257 215 l 2,1,2
+ 257 199 257 199 256 190 c 128,-1,3
+ 255 181 255 181 251.5 168 c 128,-1,4
+ 248 155 248 155 238 148.5 c 128,-1,5
+ 228 142 228 142 212.5 142 c 128,-1,6
+ 197 142 197 142 187 148.5 c 128,-1,7
+ 177 155 177 155 173.5 168 c 128,-1,8
+ 170 181 170 181 169 190 c 128,-1,9
+ 168 199 168 199 168 215 c 2,10,-1
+ 168 895 l 2,11,12
+ 168 911 168 911 169 920 c 128,-1,13
+ 170 929 170 929 173.5 942 c 128,-1,14
+ 177 955 177 955 187 961.5 c 128,-1,15
+ 197 968 197 968 212.5 968 c 128,-1,16
+ 228 968 228 968 238 961.5 c 128,-1,17
+ 248 955 248 955 251.5 942 c 128,-1,18
+ 255 929 255 929 256 920 c 128,-1,19
+ 257 911 257 911 257 895 c 2,20,-1
+ 257 599 l 1,21,22
+ 274 599 274 599 287 596 c 1,23,24
+ 297 598 297 598 304 598.5 c 128,-1,25
+ 311 599 311 599 329 599 c 2,26,-1
+ 1539 599 l 2,27,28
+ 1555 599 1555 599 1564 598 c 0,29,30
+ 1569 598 1569 598 1569 598 c 0,31,32
+ 1576 599 1576 599 1580 599 c 2,33,-1
+ 1601 599 l 1,34,-1
+ 3308 599 l 1,35,36
+ 3250 641 3250 641 3201 698 c 128,-1,37
+ 3152 755 3152 755 3125 802 c 128,-1,38
+ 3098 849 3098 849 3083.5 882 c 128,-1,39
+ 3069 915 3069 915 3069 924 c 0,40,41
+ 3069 938 3069 938 3078.5 944 c 128,-1,42
+ 3088 950 3088 950 3102 950 c 0,43,44
+ 3119 950 3119 950 3126 944 c 0,45,46
+ 3132 937 3132 937 3140 919 c 0,47,48
+ 3171 848 3171 848 3214 788 c 0,49,50
+ 3254 731 3254 731 3300 691.5 c 128,-1,51
+ 3346 652 3346 652 3387 626.5 c 128,-1,52
+ 3428 601 3428 601 3479 577 c 1,53,54
+ 3482 577 3482 577 3488.5 571 c 128,-1,55
+ 3495 565 3495 565 3495 555 c 0,56,57
+ 3495 544 3495 544 3490 539 c 128,-1,58
+ 3485 534 3485 534 3464 524 c 0,59,60
+ 3418 502 3418 502 3377.5 475.5 c 128,-1,61
+ 3337 449 3337 449 3308 424.5 c 128,-1,62
+ 3279 400 3279 400 3252.5 369 c 128,-1,63
+ 3226 338 3226 338 3210 316 c 128,-1,64
+ 3194 294 3194 294 3177.5 264 c 128,-1,65
+ 3161 234 3161 234 3154 220 c 2,66,-1
+ 3137 182 l 2,67,68
+ 3133 174 3133 174 3131.5 171.5 c 128,-1,69
+ 3130 169 3130 169 3122 164.5 c 128,-1,70
+ 3114 160 3114 160 3102 160 c 0,71,72
+ 3088 160 3088 160 3078.5 166.5 c 128,-1,73
+ 3069 173 3069 173 3069 186 c 0,74,75
+ 3069 195 3069 195 3083.5 228 c 128,-1,76
+ 3098 261 3098 261 3125 308 c 128,-1,77
+ 3152 355 3152 355 3201 412 c 128,-1,78
+ 3250 469 3250 469 3308 511 c 1,79,-1
+ 1601 511 l 1,80,-1
+ 1580 511 l 2,81,82
+ 1576 511 1576 511 1569 512 c 0,83,84
+ 1566 512 1566 512 1564 511.5 c 128,-1,85
+ 1562 511 1562 511 1539 511 c 2,86,-1
+ 329 511 l 2,87,88
+ 313 511 313 511 304 512 c 0,89,90
+ 297 512 297 512 287 514 c 1,91,92
+ 274 511 274 511 257 511 c 1,0,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni2983
@@ -37269,61 +37095,54 @@
Width: 2220
VWidth: 2220
Flags: W
-HStem: -11 47G<211 236 1981 2009>
+HStem: -11 21G<1982 1993.5>
VStem: 189 89<111 999> 1942 89<111 999>
LayerCount: 2
Fore
SplineSet
-1143 506 m 6,0,-1
- 273 4 l 2,1,2
- 246 -12 246 -12 233 -11 c 0,3,4
- 217 -11 217 -11 207.5 -4 c 128,-1,5
- 198 3 198 3 194 17.5 c 128,-1,6
- 190 32 190 32 189.5 41.5 c 128,-1,7
- 189 51 189 51 189 69 c 2,8,-1
- 189 1041 l 2,9,10
- 189 1058 189 1058 189.5 1068 c 128,-1,11
- 190 1078 190 1078 194 1092.5 c 128,-1,12
- 198 1107 198 1107 207.5 1114 c 128,-1,13
- 217 1121 217 1121 233 1121 c 0,14,15
- 250 1121 250 1121 278 1103 c 2,16,-1
- 1143 604 l 2,17,18
- 1160 595 1160 595 1169 585 c 128,-1,19
- 1178 575 1178 575 1179.5 569 c 128,-1,20
- 1181 563 1181 563 1181 555 c 128,-1,21
- 1181 547 1181 547 1179.5 541 c 128,-1,22
- 1178 535 1178 535 1169 525 c 128,-1,23
- 1160 515 1160 515 1143 506 c 6,0,-1
-1048 555 m 5,24,-1
- 278 999 l 1,25,-1
- 278 111 l 1,26,-1
- 1048 555 l 5,24,-1
-1086 606 m 2,27,-1
- 1949 1106 l 2,28,29
- 1976 1122 1976 1122 1987 1121 c 0,30,31
- 2000 1121 2000 1121 2008.5 1116 c 128,-1,32
- 2017 1111 2017 1111 2021.5 1105 c 128,-1,33
- 2026 1099 2026 1099 2028.5 1086 c 128,-1,34
- 2031 1073 2031 1073 2031 1065 c 128,-1,35
- 2031 1057 2031 1057 2031 1041 c 2,36,-1
- 2031 69 l 2,37,38
- 2031 53 2031 53 2031 45 c 128,-1,39
- 2031 37 2031 37 2028.5 24 c 128,-1,40
- 2026 11 2026 11 2021.5 5 c 128,-1,41
- 2017 -1 2017 -1 2008.5 -6 c 128,-1,42
- 2000 -11 2000 -11 1987 -11 c 0,43,44
- 1977 -11 1977 -11 1945 7 c 2,45,-1
- 1081 504 l 2,46,47
- 1039 526 1039 526 1039 555 c 0,48,49
- 1039 567 1039 567 1045 576 c 128,-1,50
- 1051 585 1051 585 1059 590 c 128,-1,51
- 1067 595 1067 595 1086 606 c 2,27,-1
-1172 555 m 1,52,-1
- 1942 111 l 1,53,-1
- 1942 999 l 1,54,-1
- 1172 555 l 1,52,-1
-EndSplineSet
-Validated: 5
+1039 550 m 1,0,1
+ 1039 552 1039 552 1039 555 c 128,-1,2
+ 1039 558 1039 558 1039 560 c 1,3,-1
+ 278 999 l 1,4,-1
+ 278 111 l 1,5,-1
+ 1039 550 l 1,0,1
+1181 550 m 1,6,-1
+ 1942 111 l 1,7,-1
+ 1942 999 l 1,8,-1
+ 1181 560 l 1,9,10
+ 1181 558 1181 558 1181 555 c 128,-1,11
+ 1181 552 1181 552 1181 550 c 1,6,-1
+1113 621 m 1,12,-1
+ 1949 1106 l 2,13,14
+ 1977 1122 1977 1122 1987 1121 c 1,15,16
+ 2000 1121 2000 1121 2008.5 1116 c 128,-1,17
+ 2017 1111 2017 1111 2021.5 1105 c 128,-1,18
+ 2026 1099 2026 1099 2028.5 1086 c 128,-1,19
+ 2031 1073 2031 1073 2031 1065 c 2,20,-1
+ 2031 1041 l 1,21,-1
+ 2031 69 l 1,22,-1
+ 2031 45 l 2,23,24
+ 2031 37 2031 37 2028.5 24 c 128,-1,25
+ 2026 11 2026 11 2021.5 5 c 128,-1,26
+ 2017 -1 2017 -1 2008.5 -6 c 128,-1,27
+ 2000 -11 2000 -11 1987 -11 c 0,28,29
+ 1977 -11 1977 -11 1945 7 c 2,30,-1
+ 1110 487 l 1,31,-1
+ 273 4 l 2,32,33
+ 246 -12 246 -12 233 -11 c 1,34,35
+ 217 -11 217 -11 208 -4 c 0,36,37
+ 198 3 198 3 194 17.5 c 128,-1,38
+ 190 32 190 32 189.5 41.5 c 128,-1,39
+ 189 51 189 51 189 69 c 2,40,-1
+ 189 1041 l 2,41,42
+ 189 1058 189 1058 189.5 1068 c 128,-1,43
+ 190 1078 190 1078 194 1092.5 c 128,-1,44
+ 198 1107 198 1107 207.5 1114 c 128,-1,45
+ 217 1121 217 1121 233 1121 c 0,46,47
+ 250 1121 250 1121 278 1103 c 1,48,-1
+ 1113 621 l 1,12,-1
+EndSplineSet
+Validated: 1
EndChar
StartChar: uni2A3F
Binary file lib/fonts/IsabelleText.ttf has changed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/scripts/bash Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+#
+# Author: Makarius
+#
+# bash - invoke shell command line (with robust signal handling)
+#
+
+use warnings;
+use strict;
+
+
+# args
+
+my ($group, $script_name, $pid_name, $output_name) = @ARGV;
+
+
+# process id
+
+if ($group eq "group") {
+ use POSIX "setsid";
+ POSIX::setsid || die $!;
+}
+
+open (PID_FILE, ">", $pid_name) || die $!;
+print PID_FILE "$$";
+close PID_FILE;
+
+
+# exec script
+
+exec qq/exec bash '$script_name' > '$output_name'/;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/scripts/keywords Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,124 @@
+#!/usr/bin/env perl
+#
+# Author: Makarius
+#
+# keywords.pl - generate outer syntax keyword files from session logs
+#
+
+use warnings;
+use strict;
+
+
+## arguments
+
+my ($keywords_name, $sessions) = @ARGV;
+
+
+## keywords
+
+my %keywords;
+
+sub set_keyword {
+ my ($name, $kind) = @_;
+ if (defined $keywords{$name} and $keywords{$name} ne $kind and $keywords{$name} ne "minor") {
+ if ($kind ne "minor") {
+ print STDERR "### Inconsistent declaration of keyword \"${name}\": $keywords{$name} vs ${kind}\n";
+ $keywords{$name} = $kind;
+ }
+ } else {
+ $keywords{$name} = $kind;
+ }
+}
+
+sub collect_keywords {
+ while(<STDIN>) {
+ if (m/^Outer syntax keyword:\s*"(.*)"/) {
+ my $name = $1;
+ &set_keyword($name, "minor");
+ }
+ elsif (m/^Outer syntax command:\s*"(.*)"\s*\((.*)\)/) {
+ my $name = $1;
+ my $kind = $2;
+ &set_keyword($name, $kind);
+ }
+ }
+}
+
+
+## Emacs output
+
+sub emacs_output {
+ my @kinds = (
+ "major",
+ "minor",
+ "control",
+ "diag",
+ "theory-begin",
+ "theory-switch",
+ "theory-end",
+ "theory-heading",
+ "theory-decl",
+ "theory-script",
+ "theory-goal",
+ "qed",
+ "qed-block",
+ "qed-global",
+ "proof-heading",
+ "proof-goal",
+ "proof-block",
+ "proof-open",
+ "proof-close",
+ "proof-chain",
+ "proof-decl",
+ "proof-asm",
+ "proof-asm-goal",
+ "proof-script"
+ );
+ my $file = $keywords_name eq "" ? "isar-keywords.el" : "isar-keywords-${keywords_name}.el";
+ open (OUTPUT, "> ${file}") || die "$!";
+ select OUTPUT;
+
+ print ";;\n";
+ print ";; Keyword classification tables for Isabelle/Isar.\n";
+ print ";; Generated from ${sessions}.\n";
+ print ";; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***\n";
+ print ";;\n";
+
+ for my $kind (@kinds) {
+ my @names;
+ for my $name (keys(%keywords)) {
+ if ($kind eq "major" ? $keywords{$name} ne "minor" : $keywords{$name} eq $kind) {
+ if ($kind ne "minor" or $name =~ m/^[A-Za-z0-9_]+$/) {
+ push @names, $name;
+ }
+ }
+ }
+ @names = sort(@names);
+
+ print "\n(defconst isar-keywords-${kind}";
+ print "\n '(";
+ my $first = 1;
+ for my $name (@names) {
+ $name =~ s/([\.\*\+\?\[\]\^\$])/\\\\$1/g;
+ if ($first) {
+ print "\"${name}\"";
+ $first = 0;
+ }
+ else {
+ print "\n \"${name}\"";
+ }
+ }
+ print "))\n";
+ }
+ print "\n(provide 'isar-keywords)\n";
+
+ close OUTPUT;
+ select;
+ print STDERR "${file}\n";
+}
+
+
+## main
+
+&collect_keywords();
+&emacs_output();
--- a/lib/scripts/keywords.pl Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
-#
-# Author: Makarius
-#
-# keywords.pl - generate outer syntax keyword files from session logs
-#
-
-## arguments
-
-my ($keywords_name, $sessions) = @ARGV;
-
-
-## keywords
-
-my %keywords;
-
-sub set_keyword {
- my ($name, $kind) = @_;
- if (defined $keywords{$name} and $keywords{$name} ne $kind and $keywords{$name} ne "minor") {
- if ($kind ne "minor") {
- print STDERR "### Inconsistent declaration of keyword \"${name}\": $keywords{$name} vs ${kind}\n";
- $keywords{$name} = $kind;
- }
- } else {
- $keywords{$name} = $kind;
- }
-}
-
-sub collect_keywords {
- while(<STDIN>) {
- if (m/^Outer syntax keyword:\s*"(.*)"/) {
- my $name = $1;
- &set_keyword($name, "minor");
- }
- elsif (m/^Outer syntax command:\s*"(.*)"\s*\((.*)\)/) {
- my $name = $1;
- my $kind = $2;
- &set_keyword($name, $kind);
- }
- }
-}
-
-
-## Emacs output
-
-sub emacs_output {
- my @kinds = (
- "major",
- "minor",
- "control",
- "diag",
- "theory-begin",
- "theory-switch",
- "theory-end",
- "theory-heading",
- "theory-decl",
- "theory-script",
- "theory-goal",
- "qed",
- "qed-block",
- "qed-global",
- "proof-heading",
- "proof-goal",
- "proof-block",
- "proof-open",
- "proof-close",
- "proof-chain",
- "proof-decl",
- "proof-asm",
- "proof-asm-goal",
- "proof-script"
- );
- my $file = $keywords_name eq "" ? "isar-keywords.el" : "isar-keywords-${keywords_name}.el";
- open (OUTPUT, "> ${file}") || die "$!";
- select OUTPUT;
-
- print ";;\n";
- print ";; Keyword classification tables for Isabelle/Isar.\n";
- print ";; Generated from ${sessions}.\n";
- print ";; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***\n";
- print ";;\n";
-
- for my $kind (@kinds) {
- my @names;
- for my $name (keys(%keywords)) {
- if ($kind eq "major" ? $keywords{$name} ne "minor" : $keywords{$name} eq $kind) {
- if ($kind ne "minor" or $name =~ m/^[A-Za-z0-9_]+$/) {
- push @names, $name;
- }
- }
- }
- @names = sort(@names);
-
- print "\n(defconst isar-keywords-${kind}";
- print "\n '(";
- my $first = 1;
- for my $name (@names) {
- $name =~ s/([\.\*\+\?\[\]\^\$])/\\\\$1/g;
- if ($first) {
- print "\"${name}\"";
- $first = 0;
- }
- else {
- print "\n \"${name}\"";
- }
- }
- print "))\n";
- }
- print "\n(provide 'isar-keywords)\n";
-
- close OUTPUT;
- select;
- print STDERR "${file}\n";
-}
-
-
-## main
-
-&collect_keywords();
-&emacs_output();
-
--- a/lib/scripts/run-mosml Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,57 +0,0 @@
-#!/usr/bin/env bash
-#
-# Author: Markus Wenzel, TU Muenchen
-#
-# Moscow ML 2.00 startup script
-
-export -n INFILE OUTFILE MLTEXT TERMINATE NOWRITE
-
-
-## diagnostics
-
-function fail_out()
-{
- echo "Unable to create output heap file: \"$OUTFILE\"" >&2
- exit 2
-}
-
-
-## prepare databases
-
-MOSML="mosml -P sml90"
-
-if [ -z "$INFILE" ]; then
- EXIT='load "OS"; fun exit 0 = (OS.Process.exit OS.Process.success): unit | exit _ = OS.Process.exit OS.Process.failure;'
-else
- EXIT=""
- echo "Cannot load images yet!" >&2
- exit 2
-fi
-
-if [ -z "$OUTFILE" ]; then
- COMMIT='fun commit () = (TextIO.output (TextIO.stdErr, "Error - Database is not opened for writing.\n"); false);'
-else
- COMMIT="fun commit () = true;"
- echo "WARNING: cannot save images yet!" >&2
- [ -f "$OUTFILE" ] && { chmod +w "$OUTFILE" || fail_out; }
-fi
-
-
-## run it!
-
-MLTEXT="$EXIT $COMMIT $MLTEXT"
-MLEXIT="commit();"
-
-if [ -z "$TERMINATE" ]; then
- FEEDER_OPTS=""
-else
- FEEDER_OPTS="-q"
-fi
-
-"$ISABELLE_HOME/lib/scripts/feeder" -p -h "$MLTEXT" -t "$MLEXIT" $FEEDER_OPTS | \
- { read FPID; "$ML_HOME"/$MOSML $ML_OPTIONS 2>&1; RC="$?"; kill -HUP "$FPID"; exit "$RC"; }
-RC="$?"
-
-[ -n "$OUTFILE" -a -f "$OUTFILE" -a -n "$NOWRITE" ] && chmod -w "$OUTFILE"
-
-exit "$RC"
--- a/lib/scripts/system.pl Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-#
-# Author: Makarius
-#
-# system.pl - invoke shell command line (with robust signal handling)
-#
-
-# args
-
-($group, $script_name, $pid_name, $output_name) = @ARGV;
-
-
-# process id
-
-if ($group eq "group") {
- use POSIX "setsid";
- POSIX::setsid || die $!;
-}
-
-open (PID_FILE, ">", $pid_name) || die $!;
-print PID_FILE "$$";
-close PID_FILE;
-
-
-# exec script
-
-$SIG{'INT'} = "DEFAULT"; #paranoia setting, required for Cygwin
-exec qq/exec bash '$script_name' > '$output_name'/;
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/scripts/unsymbolize Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,65 @@
+#!/usr/bin/env perl
+#
+# Author: Markus Wenzel, TU Muenchen
+#
+# unsymbolize.pl - remove unreadable symbol names from sources
+#
+
+use warnings;
+use strict;
+
+sub unsymbolize {
+ my ($file) = @_;
+
+ open (FILE, $file) || die $!;
+ undef $/; my $text = <FILE>; $/ = "\n"; # slurp whole file
+ close FILE || die $!;
+
+ $_ = $text;
+
+ # Pure
+ s/\\?\\<And>/!!/g;
+ s/\\?\\<Colon>/::/g;
+ s/\\?\\<Longrightarrow>/==>/g;
+ s/\\?\\<Midarrow>\\?\\<Rightarrow>/==>/g;
+ s/\\?\\<Rightarrow>/=>/g;
+ s/\\?\\<equiv>/==/g;
+ s/\\?\\<dots>/.../g;
+ s/\\?\\<lbrakk> ?/[| /g;
+ s/\\?\\ ?<rbrakk>/ |]/g;
+ s/\\?\\<lparr> ?/(| /g;
+ s/\\?\\ ?<rparr>/ |)/g;
+ # HOL
+ s/\\?\\<longleftrightarrow>/<->/g;
+ s/\\?\\<longrightarrow>/-->/g;
+ s/\\?\\<midarrow>\\?\\<rightarrow>/-->/g;
+ s/\\?\\<rightarrow>/->/g;
+ s/\\?\\<not>/~/g;
+ s/\\?\\<notin>/~:/g;
+ s/\\?\\<noteq>/~=/g;
+ s/\\?\\<some> ?/SOME /g;
+ # outer syntax
+ s/\\?\\<rightleftharpoons>/==/g;
+ s/\\?\\<rightharpoonup>/=>/g;
+ s/\\?\\<leftharpoondown>/<=/g;
+
+ my $result = $_;
+
+ if ($text ne $result) {
+ print STDERR "fixing $file\n";
+ if (! -f "$file~~") {
+ rename $file, "$file~~" || die $!;
+ }
+ open (FILE, "> $file") || die $!;
+ print FILE $result;
+ close FILE || die $!;
+ }
+}
+
+
+## main
+
+foreach my $file (@ARGV) {
+ eval { &unsymbolize($file); };
+ if ($@) { print STDERR "*** unsymbolize $file: ", $@, "\n"; }
+}
--- a/lib/scripts/unsymbolize.pl Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,61 +0,0 @@
-#
-# Author: Markus Wenzel, TU Muenchen
-#
-# unsymbolize.pl - remove unreadable symbol names from sources
-#
-
-sub unsymbolize {
- my ($file) = @_;
-
- open (FILE, $file) || die $!;
- undef $/; $text = <FILE>; $/ = "\n"; # slurp whole file
- close FILE || die $!;
-
- $_ = $text;
-
- # Pure
- s/\\?\\<And>/!!/g;
- s/\\?\\<Colon>/::/g;
- s/\\?\\<Longrightarrow>/==>/g;
- s/\\?\\<Midarrow>\\?\\<Rightarrow>/==>/g;
- s/\\?\\<Rightarrow>/=>/g;
- s/\\?\\<equiv>/==/g;
- s/\\?\\<dots>/.../g;
- s/\\?\\<lbrakk> ?/[| /g;
- s/\\?\\ ?<rbrakk>/ |]/g;
- s/\\?\\<lparr> ?/(| /g;
- s/\\?\\ ?<rparr>/ |)/g;
- # HOL
- s/\\?\\<longleftrightarrow>/<->/g;
- s/\\?\\<longrightarrow>/-->/g;
- s/\\?\\<midarrow>\\?\\<rightarrow>/-->/g;
- s/\\?\\<rightarrow>/->/g;
- s/\\?\\<not>/~/g;
- s/\\?\\<notin>/~:/g;
- s/\\?\\<noteq>/~=/g;
- s/\\?\\<some> ?/SOME /g;
- # outer syntax
- s/\\?\\<rightleftharpoons>/==/g;
- s/\\?\\<rightharpoonup>/=>/g;
- s/\\?\\<leftharpoondown>/<=/g;
-
- $result = $_;
-
- if ($text ne $result) {
- print STDERR "fixing $file\n";
- if (! -f "$file~~") {
- rename $file, "$file~~" || die $!;
- }
- open (FILE, "> $file") || die $!;
- print FILE $result;
- close FILE || die $!;
- }
-}
-
-
-## main
-
-foreach $file (@ARGV) {
- eval { &unsymbolize($file); };
- if ($@) { print STDERR "*** unsymbolize $file: ", $@, "\n"; }
-}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/scripts/yxml Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+#
+# Author: Makarius
+#
+# yxml.pl - simple XML to YXML converter
+#
+
+use warnings;
+use strict;
+
+use XML::Parser;
+
+binmode(STDOUT, ":utf8");
+
+sub handle_start {
+ print chr(5), chr(6), $_[1];
+ for (my $i = 2; $i <= $#_; $i++) {
+ print ($i % 2 == 0 ? chr(6) : "=");
+ print $_[$i];
+ }
+ print chr(5);
+}
+
+sub handle_end {
+ print chr(5), chr(6), chr(5);
+}
+
+sub handle_char {
+ print $_[1];
+}
+
+my $parser = new XML::Parser(Handlers =>
+ {Start => \&handle_start,
+ End => \&handle_end,
+ Char => \&handle_char});
+
+$parser->parse(*STDIN) or die $!;
--- a/lib/scripts/yxml.pl Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
-#
-# Author: Makarius
-#
-# yxml.pl - simple XML to YXML converter
-#
-
-use strict;
-use XML::Parser;
-
-binmode(STDOUT, ":utf8");
-
-sub handle_start {
- print chr(5), chr(6), $_[1];
- for (my $i = 2; $i <= $#_; $i++) {
- print ($i % 2 == 0 ? chr(6) : "=");
- print $_[$i];
- }
- print chr(5);
-}
-
-sub handle_end {
- print chr(5), chr(6), chr(5);
-}
-
-sub handle_char {
- print $_[1];
-}
-
-my $parser = new XML::Parser(Handlers =>
- {Start => \&handle_start,
- End => \&handle_end,
- Char => \&handle_char});
-
-$parser->parse(*STDIN) or die $!;
-
--- a/src/CCL/Set.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/CCL/Set.thy Fri Feb 19 15:21:57 2010 +0000
@@ -27,24 +27,24 @@
empty :: "'a set" ("{}")
syntax
- "@Coll" :: "[idt, o] => 'a set" ("(1{_./ _})") (*collection*)
+ "_Coll" :: "[idt, o] => 'a set" ("(1{_./ _})") (*collection*)
(* Big Intersection / Union *)
- "@INTER" :: "[idt, 'a set, 'b set] => 'b set" ("(INT _:_./ _)" [0, 0, 0] 10)
- "@UNION" :: "[idt, 'a set, 'b set] => 'b set" ("(UN _:_./ _)" [0, 0, 0] 10)
+ "_INTER" :: "[idt, 'a set, 'b set] => 'b set" ("(INT _:_./ _)" [0, 0, 0] 10)
+ "_UNION" :: "[idt, 'a set, 'b set] => 'b set" ("(UN _:_./ _)" [0, 0, 0] 10)
(* Bounded Quantifiers *)
- "@Ball" :: "[idt, 'a set, o] => o" ("(ALL _:_./ _)" [0, 0, 0] 10)
- "@Bex" :: "[idt, 'a set, o] => o" ("(EX _:_./ _)" [0, 0, 0] 10)
+ "_Ball" :: "[idt, 'a set, o] => o" ("(ALL _:_./ _)" [0, 0, 0] 10)
+ "_Bex" :: "[idt, 'a set, o] => o" ("(EX _:_./ _)" [0, 0, 0] 10)
translations
- "{x. P}" == "Collect(%x. P)"
- "INT x:A. B" == "INTER(A, %x. B)"
- "UN x:A. B" == "UNION(A, %x. B)"
- "ALL x:A. P" == "Ball(A, %x. P)"
- "EX x:A. P" == "Bex(A, %x. P)"
+ "{x. P}" == "CONST Collect(%x. P)"
+ "INT x:A. B" == "CONST INTER(A, %x. B)"
+ "UN x:A. B" == "CONST UNION(A, %x. B)"
+ "ALL x:A. P" == "CONST Ball(A, %x. P)"
+ "EX x:A. P" == "CONST Bex(A, %x. P)"
local
--- a/src/CCL/Term.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/CCL/Term.thy Fri Feb 19 15:21:57 2010 +0000
@@ -40,16 +40,16 @@
letrec3 :: "[[i,i,i,i=>i=>i=>i]=>i,(i=>i=>i=>i)=>i]=>i"
syntax
- "@let" :: "[idt,i,i]=>i" ("(3let _ be _/ in _)"
+ "_let" :: "[idt,i,i]=>i" ("(3let _ be _/ in _)"
[0,0,60] 60)
- "@letrec" :: "[idt,idt,i,i]=>i" ("(3letrec _ _ be _/ in _)"
+ "_letrec" :: "[idt,idt,i,i]=>i" ("(3letrec _ _ be _/ in _)"
[0,0,0,60] 60)
- "@letrec2" :: "[idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ be _/ in _)"
+ "_letrec2" :: "[idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ be _/ in _)"
[0,0,0,0,60] 60)
- "@letrec3" :: "[idt,idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ _ be _/ in _)"
+ "_letrec3" :: "[idt,idt,idt,idt,i,i]=>i" ("(3letrec _ _ _ _ be _/ in _)"
[0,0,0,0,0,60] 60)
ML {*
@@ -58,29 +58,30 @@
(* FIXME does not handle "_idtdummy" *)
(* FIXME should use Syntax.mark_bound(T), Syntax.variant_abs' *)
-fun let_tr [Free(id,T),a,b] = Const("let",dummyT) $ a $ absfree(id,T,b);
+fun let_tr [Free(id,T),a,b] = Const(@{const_syntax let},dummyT) $ a $ absfree(id,T,b);
fun let_tr' [a,Abs(id,T,b)] =
let val (id',b') = variant_abs(id,T,b)
- in Const("@let",dummyT) $ Free(id',T) $ a $ b' end;
+ in Const(@{syntax_const "_let"},dummyT) $ Free(id',T) $ a $ b' end;
fun letrec_tr [Free(f,S),Free(x,T),a,b] =
- Const("letrec",dummyT) $ absfree(x,T,absfree(f,S,a)) $ absfree(f,S,b);
+ Const(@{const_syntax letrec},dummyT) $ absfree(x,T,absfree(f,S,a)) $ absfree(f,S,b);
fun letrec2_tr [Free(f,S),Free(x,T),Free(y,U),a,b] =
- Const("letrec2",dummyT) $ absfree(x,T,absfree(y,U,absfree(f,S,a))) $ absfree(f,S,b);
+ Const(@{const_syntax letrec2},dummyT) $ absfree(x,T,absfree(y,U,absfree(f,S,a))) $ absfree(f,S,b);
fun letrec3_tr [Free(f,S),Free(x,T),Free(y,U),Free(z,V),a,b] =
- Const("letrec3",dummyT) $ absfree(x,T,absfree(y,U,absfree(z,U,absfree(f,S,a)))) $ absfree(f,S,b);
+ Const(@{const_syntax letrec3},dummyT) $
+ absfree(x,T,absfree(y,U,absfree(z,U,absfree(f,S,a)))) $ absfree(f,S,b);
fun letrec_tr' [Abs(x,T,Abs(f,S,a)),Abs(ff,SS,b)] =
let val (f',b') = variant_abs(ff,SS,b)
val (_,a'') = variant_abs(f,S,a)
val (x',a') = variant_abs(x,T,a'')
- in Const("@letrec",dummyT) $ Free(f',SS) $ Free(x',T) $ a' $ b' end;
+ in Const(@{syntax_const "_letrec"},dummyT) $ Free(f',SS) $ Free(x',T) $ a' $ b' end;
fun letrec2_tr' [Abs(x,T,Abs(y,U,Abs(f,S,a))),Abs(ff,SS,b)] =
let val (f',b') = variant_abs(ff,SS,b)
val ( _,a1) = variant_abs(f,S,a)
val (y',a2) = variant_abs(y,U,a1)
val (x',a') = variant_abs(x,T,a2)
- in Const("@letrec2",dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ a' $ b'
+ in Const(@{syntax_const "_letrec2"},dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ a' $ b'
end;
fun letrec3_tr' [Abs(x,T,Abs(y,U,Abs(z,V,Abs(f,S,a)))),Abs(ff,SS,b)] =
let val (f',b') = variant_abs(ff,SS,b)
@@ -88,22 +89,24 @@
val (z',a2) = variant_abs(z,V,a1)
val (y',a3) = variant_abs(y,U,a2)
val (x',a') = variant_abs(x,T,a3)
- in Const("@letrec3",dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ Free(z',V) $ a' $ b'
+ in Const(@{syntax_const "_letrec3"},dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ Free(z',V) $ a' $ b'
end;
*}
parse_translation {*
- [("@let", let_tr),
- ("@letrec", letrec_tr),
- ("@letrec2", letrec2_tr),
- ("@letrec3", letrec3_tr)] *}
+ [(@{syntax_const "_let"}, let_tr),
+ (@{syntax_const "_letrec"}, letrec_tr),
+ (@{syntax_const "_letrec2"}, letrec2_tr),
+ (@{syntax_const "_letrec3"}, letrec3_tr)]
+*}
print_translation {*
- [("let", let_tr'),
- ("letrec", letrec_tr'),
- ("letrec2", letrec2_tr'),
- ("letrec3", letrec3_tr')] *}
+ [(@{const_syntax let}, let_tr'),
+ (@{const_syntax letrec}, letrec_tr'),
+ (@{const_syntax letrec2}, letrec2_tr'),
+ (@{const_syntax letrec3}, letrec3_tr')]
+*}
consts
napply :: "[i=>i,i,i]=>i" ("(_ ^ _ ` _)" [56,56,56] 56)
--- a/src/CCL/Type.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/CCL/Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -28,26 +28,27 @@
SPLIT :: "[i, [i, i] => i set] => i set"
syntax
- "@Pi" :: "[idt, i set, i set] => i set" ("(3PROD _:_./ _)"
+ "_Pi" :: "[idt, i set, i set] => i set" ("(3PROD _:_./ _)"
[0,0,60] 60)
- "@Sigma" :: "[idt, i set, i set] => i set" ("(3SUM _:_./ _)"
+ "_Sigma" :: "[idt, i set, i set] => i set" ("(3SUM _:_./ _)"
[0,0,60] 60)
- "@->" :: "[i set, i set] => i set" ("(_ ->/ _)" [54, 53] 53)
- "@*" :: "[i set, i set] => i set" ("(_ */ _)" [56, 55] 55)
- "@Subtype" :: "[idt, 'a set, o] => 'a set" ("(1{_: _ ./ _})")
+ "_arrow" :: "[i set, i set] => i set" ("(_ ->/ _)" [54, 53] 53)
+ "_star" :: "[i set, i set] => i set" ("(_ */ _)" [56, 55] 55)
+ "_Subtype" :: "[idt, 'a set, o] => 'a set" ("(1{_: _ ./ _})")
translations
- "PROD x:A. B" => "Pi(A, %x. B)"
- "A -> B" => "Pi(A, %_. B)"
- "SUM x:A. B" => "Sigma(A, %x. B)"
- "A * B" => "Sigma(A, %_. B)"
- "{x: A. B}" == "Subtype(A, %x. B)"
+ "PROD x:A. B" => "CONST Pi(A, %x. B)"
+ "A -> B" => "CONST Pi(A, %_. B)"
+ "SUM x:A. B" => "CONST Sigma(A, %x. B)"
+ "A * B" => "CONST Sigma(A, %_. B)"
+ "{x: A. B}" == "CONST Subtype(A, %x. B)"
print_translation {*
- [("Pi", dependent_tr' ("@Pi", "@->")),
- ("Sigma", dependent_tr' ("@Sigma", "@*"))] *}
+ [(@{const_syntax Pi}, dependent_tr' (@{syntax_const "_Pi"}, @{syntax_const "_arrow"})),
+ (@{const_syntax Sigma}, dependent_tr' (@{syntax_const "_Sigma"}, @{syntax_const "_star"}))]
+*}
axioms
Subtype_def: "{x:A. P(x)} == {x. x:A & P(x)}"
--- a/src/CTT/CTT.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/CTT/CTT.thy Fri Feb 19 15:21:57 2010 +0000
@@ -63,8 +63,8 @@
"_PROD" :: "[idt,t,t]=>t" ("(3PROD _:_./ _)" 10)
"_SUM" :: "[idt,t,t]=>t" ("(3SUM _:_./ _)" 10)
translations
- "PROD x:A. B" == "Prod(A, %x. B)"
- "SUM x:A. B" == "Sum(A, %x. B)"
+ "PROD x:A. B" == "CONST Prod(A, %x. B)"
+ "SUM x:A. B" == "CONST Sum(A, %x. B)"
abbreviation
Arrow :: "[t,t]=>t" (infixr "-->" 30) where
--- a/src/Cube/Cube.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Cube/Cube.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: Cube/Cube.thy
- ID: $Id$
Author: Tobias Nipkow
*)
@@ -43,9 +42,9 @@
translations
("prop") "x:X" == ("prop") "|- x:X"
- "Lam x:A. B" == "Abs(A, %x. B)"
- "Pi x:A. B" => "Prod(A, %x. B)"
- "A -> B" => "Prod(A, %_. B)"
+ "Lam x:A. B" == "CONST Abs(A, %x. B)"
+ "Pi x:A. B" => "CONST Prod(A, %x. B)"
+ "A -> B" => "CONST Prod(A, %_. B)"
syntax (xsymbols)
Trueprop :: "[context', typing'] => prop" ("(_/ \<turnstile> _)")
@@ -54,7 +53,9 @@
Pi :: "[idt, term, term] => term" ("(3\<Pi> _:_./ _)" [0, 0] 10)
arrow :: "[term, term] => term" (infixr "\<rightarrow>" 10)
-print_translation {* [("Prod", dependent_tr' ("Pi", "arrow"))] *}
+print_translation {*
+ [(@{const_syntax Prod}, dependent_tr' (@{syntax_const Pi}, @{syntax_const arrow}))]
+*}
axioms
s_b: "*: []"
--- a/src/FOL/IFOL.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/FOL/IFOL.thy Fri Feb 19 15:21:57 2010 +0000
@@ -772,7 +772,7 @@
translations
"_Let(_binds(b, bs), e)" == "_Let(b, _Let(bs, e))"
- "let x = a in e" == "Let(a, %x. e)"
+ "let x = a in e" == "CONST Let(a, %x. e)"
lemma LetI:
--- a/src/FOL/simpdata.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/FOL/simpdata.ML Fri Feb 19 15:21:57 2010 +0000
@@ -27,9 +27,9 @@
(*Congruence rules for = or <-> (instead of ==)*)
fun mk_meta_cong rl =
- Drule.standard (mk_meta_eq (mk_meta_prems rl))
- handle THM _ =>
- error("Premises and conclusion of congruence rules must use =-equality or <->");
+ Drule.export_without_context (mk_meta_eq (mk_meta_prems rl))
+ handle THM _ =>
+ error("Premises and conclusion of congruence rules must use =-equality or <->");
val mksimps_pairs =
[("op -->", [@{thm mp}]), ("op &", [@{thm conjunct1}, @{thm conjunct2}]),
--- a/src/FOLP/IFOLP.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/FOLP/IFOLP.thy Fri Feb 19 15:21:57 2010 +0000
@@ -22,19 +22,18 @@
consts
(*** Judgements ***)
- "@Proof" :: "[p,o]=>prop" ("(_ /: _)" [51,10] 5)
Proof :: "[o,p]=>prop"
EqProof :: "[p,p,o]=>prop" ("(3_ /= _ :/ _)" [10,10,10] 5)
(*** Logical Connectives -- Type Formers ***)
- "=" :: "['a,'a] => o" (infixl 50)
+ "op =" :: "['a,'a] => o" (infixl "=" 50)
True :: "o"
False :: "o"
Not :: "o => o" ("~ _" [40] 40)
- "&" :: "[o,o] => o" (infixr 35)
- "|" :: "[o,o] => o" (infixr 30)
- "-->" :: "[o,o] => o" (infixr 25)
- "<->" :: "[o,o] => o" (infixr 25)
+ "op &" :: "[o,o] => o" (infixr "&" 35)
+ "op |" :: "[o,o] => o" (infixr "|" 30)
+ "op -->" :: "[o,o] => o" (infixr "-->" 25)
+ "op <->" :: "[o,o] => o" (infixr "<->" 25)
(*Quantifiers*)
All :: "('a => o) => o" (binder "ALL " 10)
Ex :: "('a => o) => o" (binder "EX " 10)
@@ -54,9 +53,9 @@
inr :: "p=>p"
when :: "[p, p=>p, p=>p]=>p"
lambda :: "(p => p) => p" (binder "lam " 55)
- "`" :: "[p,p]=>p" (infixl 60)
+ "op `" :: "[p,p]=>p" (infixl "`" 60)
alll :: "['a=>p]=>p" (binder "all " 55)
- "^" :: "[p,'a]=>p" (infixl 55)
+ "op ^" :: "[p,'a]=>p" (infixl "^" 55)
exists :: "['a,p]=>p" ("(1[_,/_])")
xsplit :: "[p,['a,p]=>p]=>p"
ideq :: "'a=>p"
@@ -66,6 +65,8 @@
local
+syntax "_Proof" :: "[p,o]=>prop" ("(_ /: _)" [51, 10] 5)
+
ML {*
(*show_proofs:=true displays the proof terms -- they are ENORMOUS*)
@@ -74,12 +75,12 @@
fun proof_tr [p,P] = Const (@{const_name Proof}, dummyT) $ P $ p;
fun proof_tr' [P,p] =
- if !show_proofs then Const("@Proof",dummyT) $ p $ P
- else P (*this case discards the proof term*);
+ if ! show_proofs then Const (@{syntax_const "_Proof"}, dummyT) $ p $ P
+ else P (*this case discards the proof term*);
*}
-parse_translation {* [("@Proof", proof_tr)] *}
-print_translation {* [("Proof", proof_tr')] *}
+parse_translation {* [(@{syntax_const "_Proof"}, proof_tr)] *}
+print_translation {* [(@{const_syntax Proof}, proof_tr')] *}
axioms
--- a/src/FOLP/simp.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/FOLP/simp.ML Fri Feb 19 15:21:57 2010 +0000
@@ -519,7 +519,7 @@
(* Compute Congruence rules for individual constants using the substition
rules *)
-val subst_thms = map Drule.standard subst_thms;
+val subst_thms = map Drule.export_without_context subst_thms;
fun exp_app(0,t) = t
--- a/src/HOL/Algebra/FiniteProduct.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Algebra/FiniteProduct.thy Fri Feb 19 15:21:57 2010 +0000
@@ -302,7 +302,7 @@
"_finprod" :: "index => idt => 'a set => 'b => 'b"
("(3\<Otimes>__\<in>_. _)" [1000, 0, 51, 10] 10)
translations
- "\<Otimes>\<index>i:A. b" == "finprod \<struct>\<index> (%i. b) A"
+ "\<Otimes>\<index>i:A. b" == "CONST finprod \<struct>\<index> (%i. b) A"
-- {* Beware of argument permutation! *}
lemma (in comm_monoid) finprod_empty [simp]:
--- a/src/HOL/Algebra/Ring.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Algebra/Ring.thy Fri Feb 19 15:21:57 2010 +0000
@@ -213,7 +213,7 @@
"_finsum" :: "index => idt => 'a set => 'b => 'b"
("(3\<Oplus>__\<in>_. _)" [1000, 0, 51, 10] 10)
translations
- "\<Oplus>\<index>i:A. b" == "finsum \<struct>\<index> (%i. b) A"
+ "\<Oplus>\<index>i:A. b" == "CONST finsum \<struct>\<index> (%i. b) A"
-- {* Beware of argument permutation! *}
context abelian_monoid begin
--- a/src/HOL/Algebra/poly/UnivPoly2.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Algebra/poly/UnivPoly2.thy Fri Feb 19 15:21:57 2010 +0000
@@ -139,7 +139,7 @@
end
-instance up :: ("{times, comm_monoid_add}") Ring_and_Field.dvd ..
+instance up :: ("{times, comm_monoid_add}") Rings.dvd ..
instantiation up :: ("{times, one, comm_monoid_add, uminus, minus}") inverse
begin
--- a/src/HOL/Algebras.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Algebras.thy Fri Feb 19 15:21:57 2010 +0000
@@ -10,15 +10,30 @@
subsection {* Generic algebraic structures *}
+text {*
+ These locales provide basic structures for interpretation into
+ bigger structures; extensions require careful thinking, otherwise
+ undesired effects may occur due to interpretation.
+*}
+
+ML {*
+structure Ac_Simps = Named_Thms(
+ val name = "ac_simps"
+ val description = "associativity and commutativity simplification rules"
+)
+*}
+
+setup Ac_Simps.setup
+
locale semigroup =
fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 70)
- assumes assoc: "a * b * c = a * (b * c)"
+ assumes assoc [ac_simps]: "a * b * c = a * (b * c)"
locale abel_semigroup = semigroup +
- assumes commute: "a * b = b * a"
+ assumes commute [ac_simps]: "a * b = b * a"
begin
-lemma left_commute:
+lemma left_commute [ac_simps]:
"b * (a * c) = a * (b * c)"
proof -
have "(b * a) * c = (a * b) * c"
@@ -39,27 +54,8 @@
end
-locale lattice = inf!: abel_semigroup inf + sup!: abel_semigroup sup
- for inf (infixl "\<sqinter>" 70) and sup (infixl "\<squnion>" 70) +
- assumes sup_inf_absorb: "a \<squnion> (a \<sqinter> b) = a"
- and inf_sup_absorb: "a \<sqinter> (a \<squnion> b) = a"
-sublocale lattice < inf!: semilattice inf
-proof
- fix a
- have "a \<sqinter> (a \<squnion> (a \<sqinter> a)) = a" by (fact inf_sup_absorb)
- then show "a \<sqinter> a = a" by (simp add: sup_inf_absorb)
-qed
-
-sublocale lattice < sup!: semilattice sup
-proof
- fix a
- have "a \<squnion> (a \<sqinter> (a \<squnion> a)) = a" by (fact sup_inf_absorb)
- then show "a \<squnion> a = a" by (simp add: inf_sup_absorb)
-qed
-
-
-subsection {* Generic algebraic operations *}
+subsection {* Generic syntactic operations *}
class zero =
fixes zero :: 'a ("0")
@@ -67,6 +63,13 @@
class one =
fixes one :: 'a ("1")
+hide (open) const zero one
+
+syntax
+ "_index1" :: index ("\<^sub>1")
+translations
+ (index) "\<^sub>1" => (index) "\<^bsub>\<struct>\<^esub>"
+
lemma Let_0 [simp]: "Let 0 f = f 0"
unfolding Let_def ..
@@ -93,8 +96,6 @@
in map tr' [@{const_syntax Algebras.one}, @{const_syntax Algebras.zero}] end;
*} -- {* show types that are presumably too general *}
-hide (open) const zero one
-
class plus =
fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+" 65)
@@ -107,60 +108,4 @@
class times =
fixes times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 70)
-class inverse =
- fixes inverse :: "'a \<Rightarrow> 'a"
- and divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/" 70)
-
-class abs =
- fixes abs :: "'a \<Rightarrow> 'a"
-begin
-
-notation (xsymbols)
- abs ("\<bar>_\<bar>")
-
-notation (HTML output)
- abs ("\<bar>_\<bar>")
-
-end
-
-class sgn =
- fixes sgn :: "'a \<Rightarrow> 'a"
-
-class ord =
- fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
- and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-begin
-
-notation
- less_eq ("op <=") and
- less_eq ("(_/ <= _)" [51, 51] 50) and
- less ("op <") and
- less ("(_/ < _)" [51, 51] 50)
-
-notation (xsymbols)
- less_eq ("op \<le>") and
- less_eq ("(_/ \<le> _)" [51, 51] 50)
-
-notation (HTML output)
- less_eq ("op \<le>") and
- less_eq ("(_/ \<le> _)" [51, 51] 50)
-
-abbreviation (input)
- greater_eq (infix ">=" 50) where
- "x >= y \<equiv> y <= x"
-
-notation (input)
- greater_eq (infix "\<ge>" 50)
-
-abbreviation (input)
- greater (infix ">" 50) where
- "x > y \<equiv> y < x"
-
-end
-
-syntax
- "_index1" :: index ("\<^sub>1")
-translations
- (index) "\<^sub>1" => (index) "\<^bsub>\<struct>\<^esub>"
-
end
\ No newline at end of file
--- a/src/HOL/Archimedean_Field.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Archimedean_Field.thy Fri Feb 19 15:21:57 2010 +0000
@@ -12,7 +12,7 @@
text {* Archimedean fields have no infinite elements. *}
-class archimedean_field = ordered_field + number_ring +
+class archimedean_field = linordered_field + number_ring +
assumes ex_le_of_int: "\<exists>z. x \<le> of_int z"
lemma ex_less_of_int:
--- a/src/HOL/Auth/Message.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Auth/Message.thy Fri Feb 19 15:21:57 2010 +0000
@@ -51,14 +51,14 @@
text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
syntax (xsymbols)
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
translations
"{|x, y, z|}" == "{|x, {|y, z|}|}"
- "{|x, y|}" == "MPair x y"
+ "{|x, y|}" == "CONST MPair x y"
constdefs
--- a/src/HOL/Bali/AxCompl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/AxCompl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/AxCompl.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
--- a/src/HOL/Bali/AxExample.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/AxExample.thy Fri Feb 19 15:21:57 2010 +0000
@@ -166,7 +166,7 @@
apply (tactic "ax_tac 1" (* NewC *))
apply (tactic "ax_tac 1" (* ax_Alloc *))
(* just for clarification: *)
-apply (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free tree \<and>. initd Ext)" in conseq2)
+apply (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free three \<and>. initd Ext)" in conseq2)
prefer 2
apply (simp add: invocation_declclass_def dynmethd_def)
apply (unfold dynlookup_def)
--- a/src/HOL/Bali/AxSem.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/AxSem.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,12 +1,10 @@
(* Title: HOL/Bali/AxSem.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Axiomatic semantics of Java expressions and statements
(see also Eval.thy)
*}
-
theory AxSem imports Evaln TypeSafe begin
text {*
@@ -39,14 +37,15 @@
*}
types res = vals --{* result entry *}
-syntax
- Val :: "val \<Rightarrow> res"
- Var :: "var \<Rightarrow> res"
- Vals :: "val list \<Rightarrow> res"
-translations
- "Val x" => "(In1 x)"
- "Var x" => "(In2 x)"
- "Vals x" => "(In3 x)"
+
+abbreviation (input)
+ Val where "Val x == In1 x"
+
+abbreviation (input)
+ Var where "Var x == In2 x"
+
+abbreviation (input)
+ Vals where "Vals x == In3 x"
syntax
"_Val" :: "[pttrn] => pttrn" ("Val:_" [951] 950)
@@ -54,9 +53,9 @@
"_Vals" :: "[pttrn] => pttrn" ("Vals:_" [951] 950)
translations
- "\<lambda>Val:v . b" == "(\<lambda>v. b) \<circ> the_In1"
- "\<lambda>Var:v . b" == "(\<lambda>v. b) \<circ> the_In2"
- "\<lambda>Vals:v. b" == "(\<lambda>v. b) \<circ> the_In3"
+ "\<lambda>Val:v . b" == "(\<lambda>v. b) \<circ> CONST the_In1"
+ "\<lambda>Var:v . b" == "(\<lambda>v. b) \<circ> CONST the_In2"
+ "\<lambda>Vals:v. b" == "(\<lambda>v. b) \<circ> CONST the_In3"
--{* relation on result values, state and auxiliary variables *}
types 'a assn = "res \<Rightarrow> state \<Rightarrow> 'a \<Rightarrow> bool"
@@ -105,10 +104,9 @@
apply auto
done
-syntax
- Normal :: "'a assn \<Rightarrow> 'a assn"
-translations
- "Normal P" == "P \<and>. normal"
+abbreviation
+ Normal :: "'a assn \<Rightarrow> 'a assn"
+ where "Normal P == P \<and>. normal"
lemma peek_and_Normal [simp]: "peek_and (Normal P) p = Normal (peek_and P p)"
apply (rule ext)
@@ -207,9 +205,9 @@
"peek_res Pf \<equiv> \<lambda>Y. Pf Y Y"
syntax
-"@peek_res" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_:. _" [0,3] 3)
+ "_peek_res" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_:. _" [0,3] 3)
translations
- "\<lambda>w:. P" == "peek_res (\<lambda>w. P)"
+ "\<lambda>w:. P" == "CONST peek_res (\<lambda>w. P)"
lemma peek_res_def2 [simp]: "peek_res P Y = P Y Y"
apply (unfold peek_res_def)
@@ -268,9 +266,9 @@
"peek_st P \<equiv> \<lambda>Y s. P (store s) Y s"
syntax
-"@peek_st" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_.. _" [0,3] 3)
+ "_peek_st" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_.. _" [0,3] 3)
translations
- "\<lambda>s.. P" == "peek_st (\<lambda>s. P)"
+ "\<lambda>s.. P" == "CONST peek_st (\<lambda>s. P)"
lemma peek_st_def2 [simp]: "(\<lambda>s.. Pf s) Y s = Pf (store s) Y s"
apply (unfold peek_st_def)
@@ -386,33 +384,31 @@
("{(1_)}/ _>/ {(1_)}" [3,65,3]75)
types 'a triples = "'a triple set"
-syntax
-
+abbreviation
var_triple :: "['a assn, var ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _=>/ {(1_)}" [3,80,3] 75)
+ where "{P} e=> {Q} == {P} In2 e> {Q}"
+
+abbreviation
expr_triple :: "['a assn, expr ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _->/ {(1_)}" [3,80,3] 75)
+ where "{P} e-> {Q} == {P} In1l e> {Q}"
+
+abbreviation
exprs_triple :: "['a assn, expr list ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _#>/ {(1_)}" [3,65,3] 75)
+ where "{P} e#> {Q} == {P} In3 e> {Q}"
+
+abbreviation
stmt_triple :: "['a assn, stmt, 'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ ._./ {(1_)}" [3,65,3] 75)
-
-syntax (xsymbols)
+ where "{P} .c. {Q} == {P} In1r c> {Q}"
- triple :: "['a assn, term ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _\<succ>/ {(1_)}" [3,65,3] 75)
- var_triple :: "['a assn, var ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _=\<succ>/ {(1_)}" [3,80,3] 75)
- expr_triple :: "['a assn, expr ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _-\<succ>/ {(1_)}" [3,80,3] 75)
- exprs_triple :: "['a assn, expr list ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _\<doteq>\<succ>/ {(1_)}" [3,65,3] 75)
-
-translations
- "{P} e-\<succ> {Q}" == "{P} In1l e\<succ> {Q}"
- "{P} e=\<succ> {Q}" == "{P} In2 e\<succ> {Q}"
- "{P} e\<doteq>\<succ> {Q}" == "{P} In3 e\<succ> {Q}"
- "{P} .c. {Q}" == "{P} In1r c\<succ> {Q}"
+notation (xsymbols)
+ triple ("{(1_)}/ _\<succ>/ {(1_)}" [3,65,3] 75) and
+ var_triple ("{(1_)}/ _=\<succ>/ {(1_)}" [3,80,3] 75) and
+ expr_triple ("{(1_)}/ _-\<succ>/ {(1_)}" [3,80,3] 75) and
+ exprs_triple ("{(1_)}/ _\<doteq>\<succ>/ {(1_)}" [3,65,3] 75)
lemma inj_triple: "inj (\<lambda>(P,t,Q). {P} t\<succ> {Q})"
apply (rule inj_onI)
@@ -436,26 +432,25 @@
ax_valids :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triples \<Rightarrow> bool"
("_,_|\<Turnstile>_" [61,58,58] 57)
-syntax
-
+abbreviation
triples_valid:: "prog \<Rightarrow> nat \<Rightarrow> 'a triples \<Rightarrow> bool"
( "_||=_:_" [61,0, 58] 57)
- ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
- ( "_,_|=_" [61,58,58] 57)
-
-syntax (xsymbols)
+ where "G||=n:ts == Ball ts (triple_valid G n)"
- triples_valid:: "prog \<Rightarrow> nat \<Rightarrow> 'a triples \<Rightarrow> bool"
- ( "_|\<Turnstile>_:_" [61,0, 58] 57)
- ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
- ( "_,_\<Turnstile>_" [61,58,58] 57)
+abbreviation
+ ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
+ ( "_,_|=_" [61,58,58] 57)
+ where "G,A |=t == G,A|\<Turnstile>{t}"
+
+notation (xsymbols)
+ triples_valid ("_|\<Turnstile>_:_" [61,0, 58] 57) and
+ ax_valid ("_,_\<Turnstile>_" [61,58,58] 57)
defs triple_valid_def: "G\<Turnstile>n:t \<equiv> case t of {P} t\<succ> {Q} \<Rightarrow>
\<forall>Y s Z. P Y s Z \<longrightarrow> type_ok G t s \<longrightarrow>
(\<forall>Y' s'. G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (Y',s') \<longrightarrow> Q Y' s' Z)"
-translations "G|\<Turnstile>n:ts" == "Ball ts (triple_valid G n)"
-defs ax_valids_def:"G,A|\<Turnstile>ts \<equiv> \<forall>n. G|\<Turnstile>n:A \<longrightarrow> G|\<Turnstile>n:ts"
-translations "G,A \<Turnstile>t" == "G,A|\<Turnstile>{t}"
+
+defs ax_valids_def:"G,A|\<Turnstile>ts \<equiv> \<forall>n. G|\<Turnstile>n:A \<longrightarrow> G|\<Turnstile>n:ts"
lemma triple_valid_def2: "G\<Turnstile>n:{P} t\<succ> {Q} =
(\<forall>Y s Z. P Y s Z
--- a/src/HOL/Bali/AxSound.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/AxSound.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/AxSound.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Soundness proof for Axiomatic semantics of Java expressions and
--- a/src/HOL/Bali/Basis.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Basis.thy Fri Feb 19 15:21:57 2010 +0000
@@ -27,12 +27,8 @@
apply fast+
done
-syntax
- "3" :: nat ("3")
- "4" :: nat ("4")
-translations
- "3" == "Suc 2"
- "4" == "Suc 3"
+abbreviation nat3 :: nat ("3") where "3 == Suc 2"
+abbreviation nat4 :: nat ("4") where "4 == Suc 3"
(*unused*)
lemma range_bool_domain: "range f = {f True, f False}"
@@ -182,10 +178,7 @@
hide const In0 In1
-syntax
- fun_sum :: "('a => 'c) => ('b => 'c) => (('a+'b) => 'c)" (infixr "'(+')"80)
-translations
- "fun_sum" == "CONST sum_case"
+notation sum_case (infixr "'(+')"80)
consts the_Inl :: "'a + 'b \<Rightarrow> 'a"
the_Inr :: "'a + 'b \<Rightarrow> 'b"
@@ -201,18 +194,17 @@
primrec "the_In2 (In2 b) = b"
primrec "the_In3 (In3 c) = c"
-syntax
- In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
- In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
-translations
- "In1l e" == "In1 (CONST Inl e)"
- "In1r c" == "In1 (CONST Inr c)"
+abbreviation In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
+ where "In1l e == In1 (Inl e)"
+
+abbreviation In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
+ where "In1r c == In1 (Inr c)"
-syntax the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
- the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
-translations
- "the_In1l" == "the_Inl \<circ> the_In1"
- "the_In1r" == "the_Inr \<circ> the_In1"
+abbreviation the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
+ where "the_In1l == the_Inl \<circ> the_In1"
+
+abbreviation the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
+ where "the_In1r == the_Inr \<circ> the_In1"
ML {*
fun sum3_instantiate ctxt thm = map (fn s =>
@@ -319,8 +311,8 @@
syntax
"_lpttrn" :: "[pttrn,pttrn] => pttrn" ("_#/_" [901,900] 900)
translations
- "%y#x#xs. b" == "lsplit (%y x#xs. b)"
- "%x#xs . b" == "lsplit (%x xs . b)"
+ "%y#x#xs. b" == "CONST lsplit (%y x#xs. b)"
+ "%x#xs . b" == "CONST lsplit (%x xs . b)"
lemma lsplit [simp]: "lsplit c (x#xs) = c x xs"
apply (unfold lsplit_def)
--- a/src/HOL/Bali/Conform.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Conform.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Conform.thy
- ID: $Id$
Author: David von Oheimb
*)
--- a/src/HOL/Bali/Decl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Decl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Decl.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Field, method, interface, and class declarations, whole Java programs
@@ -402,17 +401,21 @@
"prog"<= (type) "\<lparr>ifaces::idecl list,classes::cdecl list\<rparr>"
"prog"<= (type) "\<lparr>ifaces::idecl list,classes::cdecl list,\<dots>::'a\<rparr>"
-syntax
- iface :: "prog \<Rightarrow> (qtname, iface) table"
- "class" :: "prog \<Rightarrow> (qtname, class) table"
- is_iface :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
- is_class :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+abbreviation
+ iface :: "prog \<Rightarrow> (qtname, iface) table"
+ where "iface G I == table_of (ifaces G) I"
+
+abbreviation
+ "class" :: "prog \<Rightarrow> (qtname, class) table"
+ where "class G C == table_of (classes G) C"
-translations
- "iface G I" == "table_of (ifaces G) I"
- "class G C" == "table_of (classes G) C"
- "is_iface G I" == "iface G I \<noteq> None"
- "is_class G C" == "class G C \<noteq> None"
+abbreviation
+ is_iface :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+ where "is_iface G I == iface G I \<noteq> None"
+
+abbreviation
+ is_class :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+ where "is_class G C == class G C \<noteq> None"
section "is type"
@@ -445,21 +448,22 @@
subint1_def: "subint1 G \<equiv> {(I,J). \<exists>i\<in>iface G I: J\<in>set (isuperIfs i)}"
subcls1_def: "subcls1 G \<equiv> {(C,D). C\<noteq>Object \<and> (\<exists>c\<in>class G C: super c = D)}"
-syntax
- "_subcls1" :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
- "_subclseq":: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
- "_subcls" :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
+abbreviation
+ subcls1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
+ where "G|-C <:C1 D == (C,D) \<in> subcls1 G"
+
+abbreviation
+ subclseq_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
+ where "G|-C <=:C D == (C,D) \<in>(subcls1 G)^*" (* cf. 8.1.3 *)
-syntax (xsymbols)
- "_subcls1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70)
- "_subclseq":: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70)
- "_subcls" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
+abbreviation
+ subcls_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
+ where "G|-C <:C D == (C,D) \<in>(subcls1 G)^+"
-translations
- "G\<turnstile>C \<prec>\<^sub>C\<^sub>1 D" == "(C,D) \<in> subcls1 G"
- "G\<turnstile>C \<preceq>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^*" (* cf. 8.1.3 *)
- "G\<turnstile>C \<prec>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^+"
-
+notation (xsymbols)
+ subcls1_syntax ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70) and
+ subclseq_syntax ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70) and
+ subcls_syntax ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
lemma subint1I: "\<lbrakk>iface G I = Some i; J \<in> set (isuperIfs i)\<rbrakk>
\<Longrightarrow> (I,J) \<in> subint1 G"
--- a/src/HOL/Bali/DeclConcepts.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/DeclConcepts.thy Fri Feb 19 15:21:57 2010 +0000
@@ -13,8 +13,8 @@
"is_public G qn \<equiv> (case class G qn of
None \<Rightarrow> (case iface G qn of
None \<Rightarrow> False
- | Some iface \<Rightarrow> access iface = Public)
- | Some class \<Rightarrow> access class = Public)"
+ | Some i \<Rightarrow> access i = Public)
+ | Some c \<Rightarrow> access c = Public)"
subsection "accessibility of types (cf. 6.6.1)"
text {*
@@ -445,21 +445,17 @@
| Protected \<Rightarrow> True
| Public \<Rightarrow> True)"
-syntax
-Method_inheritable_in::
+abbreviation
+Method_inheritable_in_syntax::
"prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> pname \<Rightarrow> bool"
("_ \<turnstile>Method _ inheritable'_in _ " [61,61,61] 60)
+ where "G\<turnstile>Method m inheritable_in p == G\<turnstile>methdMembr m inheritable_in p"
-translations
-"G\<turnstile>Method m inheritable_in p" == "G\<turnstile>methdMembr m inheritable_in p"
-
-syntax
+abbreviation
Methd_inheritable_in::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> pname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ inheritable'_in _ " [61,61,61,61] 60)
-
-translations
-"G\<turnstile>Methd s m inheritable_in p" == "G\<turnstile>(method s m) inheritable_in p"
+ where "G\<turnstile>Methd s m inheritable_in p == G\<turnstile>(method s m) inheritable_in p"
subsubsection "declared-in/undeclared-in"
@@ -486,17 +482,15 @@
fdecl (fn,f ) \<Rightarrow> cdeclaredfield G C fn = Some f
| mdecl (sig,m) \<Rightarrow> cdeclaredmethd G C sig = Some m)"
-syntax
+abbreviation
method_declared_in:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_\<turnstile>Method _ declared'_in _" [61,61,61] 60)
-translations
-"G\<turnstile>Method m declared_in C" == "G\<turnstile>mdecl (mthd m) declared_in C"
+ where "G\<turnstile>Method m declared_in C == G\<turnstile>mdecl (mthd m) declared_in C"
-syntax
+abbreviation
methd_declared_in:: "prog \<Rightarrow> sig \<Rightarrow>(qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_\<turnstile>Methd _ _ declared'_in _" [61,61,61,61] 60)
-translations
-"G\<turnstile>Methd s m declared_in C" == "G\<turnstile>mdecl (s,mthd m) declared_in C"
+ where "G\<turnstile>Methd s m declared_in C == G\<turnstile>mdecl (s,mthd m) declared_in C"
lemma declared_in_classD:
"G\<turnstile>m declared_in C \<Longrightarrow> is_class G C"
@@ -538,26 +532,20 @@
of S will not inherit the member, regardless if they are in the same
package as A or not.*}
-syntax
+abbreviation
method_member_of:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Method _ member'_of _" [61,61,61] 60)
+ where "G\<turnstile>Method m member_of C == G\<turnstile>(methdMembr m) member_of C"
-translations
- "G\<turnstile>Method m member_of C" \<rightleftharpoons> "G\<turnstile>(methdMembr m) member_of C"
-
-syntax
+abbreviation
methd_member_of:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ member'_of _" [61,61,61,61] 60)
+ where "G\<turnstile>Methd s m member_of C == G\<turnstile>(method s m) member_of C"
-translations
- "G\<turnstile>Methd s m member_of C" \<rightleftharpoons> "G\<turnstile>(method s m) member_of C"
-
-syntax
+abbreviation
fieldm_member_of:: "prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ member'_of _" [61,61,61] 60)
-
-translations
- "G\<turnstile>Field n f member_of C" \<rightleftharpoons> "G\<turnstile>fieldm n f member_of C"
+ where "G\<turnstile>Field n f member_of C == G\<turnstile>fieldm n f member_of C"
constdefs
inherits:: "prog \<Rightarrow> qtname \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> bool"
@@ -578,19 +566,15 @@
is necessary since not all members are inherited to subclasses. So such
members are not member-of the subclass but member-in the subclass.*}
-syntax
+abbreviation
method_member_in:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Method _ member'_in _" [61,61,61] 60)
+ where "G\<turnstile>Method m member_in C == G\<turnstile>(methdMembr m) member_in C"
-translations
- "G\<turnstile>Method m member_in C" \<rightleftharpoons> "G\<turnstile>(methdMembr m) member_in C"
-
-syntax
+abbreviation
methd_member_in:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ member'_in _" [61,61,61,61] 60)
-
-translations
- "G\<turnstile>Methd s m member_in C" \<rightleftharpoons> "G\<turnstile>(method s m) member_in C"
+ where "G\<turnstile>Methd s m member_in C == G\<turnstile>(method s m) member_in C"
lemma member_inD: "G\<turnstile>m member_in C
\<Longrightarrow> \<exists> provC. G\<turnstile> C \<preceq>\<^sub>C provC \<and> G \<turnstile> m member_of provC"
@@ -649,18 +633,16 @@
| Indirect: "\<lbrakk>G\<turnstile>new overrides intr; G\<turnstile>intr overrides old\<rbrakk>
\<Longrightarrow> G\<turnstile>new overrides old"
-syntax
+abbreviation (input)
sig_stat_overrides::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ overrides\<^sub>S _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new overrides\<^sub>S old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) overrides\<^sub>S (qmdecl s old)"
+ where "G,s\<turnstile>new overrides\<^sub>S old == G\<turnstile>(qmdecl s new) overrides\<^sub>S (qmdecl s old)"
-syntax
+abbreviation (input)
sig_overrides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ overrides _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new overrides old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) overrides (qmdecl s old)"
+ where "G,s\<turnstile>new overrides old == G\<turnstile>(qmdecl s new) overrides (qmdecl s old)"
subsubsection "Hiding"
@@ -674,11 +656,10 @@
G\<turnstile>Method old declared_in (declclass old) \<and>
G\<turnstile>Method old inheritable_in pid (declclass new)"
-syntax
-sig_hides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> bool"
+abbreviation
+sig_hides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ hides _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new hides old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) hides (qmdecl s old)"
+ where "G,s\<turnstile>new hides old == G\<turnstile>(qmdecl s new) hides (qmdecl s old)"
lemma hidesI:
"\<lbrakk>is_static new; msig new = msig old;
@@ -731,14 +712,14 @@
"prog \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile> _ in _ permits'_acc'_from _" [61,61,61,61] 60)
-"G\<turnstile>membr in class permits_acc_from accclass
+"G\<turnstile>membr in cls permits_acc_from accclass
\<equiv> (case (accmodi membr) of
Private \<Rightarrow> (declclass membr = accclass)
| Package \<Rightarrow> (pid (declclass membr) = pid accclass)
| Protected \<Rightarrow> (pid (declclass membr) = pid accclass)
\<or>
(G\<turnstile>accclass \<prec>\<^sub>C declclass membr
- \<and> (G\<turnstile>class \<preceq>\<^sub>C accclass \<or> is_static membr))
+ \<and> (G\<turnstile>cls \<preceq>\<^sub>C accclass \<or> is_static membr))
| Public \<Rightarrow> True)"
text {*
The subcondition of the @{term "Protected"} case:
@@ -774,12 +755,14 @@
| "G\<turnstile>Method m of cls accessible_from accclass \<equiv> accessible_fromR G accclass (methdMembr m) cls"
-| Immediate: "\<lbrakk>G\<turnstile>membr member_of class;
+| Immediate: "!!membr class.
+ \<lbrakk>G\<turnstile>membr member_of class;
G\<turnstile>(Class class) accessible_in (pid accclass);
G\<turnstile>membr in class permits_acc_from accclass
\<rbrakk> \<Longrightarrow> G\<turnstile>membr of class accessible_from accclass"
-| Overriding: "\<lbrakk>G\<turnstile>membr member_of class;
+| Overriding: "!!membr class C new old supr.
+ \<lbrakk>G\<turnstile>membr member_of class;
G\<turnstile>(Class class) accessible_in (pid accclass);
membr=(C,mdecl new);
G\<turnstile>(C,new) overrides\<^sub>S old;
@@ -787,23 +770,21 @@
G\<turnstile>Method old of supr accessible_from accclass
\<rbrakk>\<Longrightarrow> G\<turnstile>membr of class accessible_from accclass"
-syntax
+abbreviation
methd_accessible_from::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ of _ accessible'_from _" [61,61,61,61,61] 60)
+ where
+ "G\<turnstile>Methd s m of cls accessible_from accclass ==
+ G\<turnstile>(method s m) of cls accessible_from accclass"
-translations
-"G\<turnstile>Methd s m of cls accessible_from accclass"
- \<rightleftharpoons> "G\<turnstile>(method s m) of cls accessible_from accclass"
-
-syntax
+abbreviation
field_accessible_from::
"prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ of _ accessible'_from _" [61,61,61,61,61] 60)
-
-translations
-"G\<turnstile>Field fn f of C accessible_from accclass"
- \<rightleftharpoons> "G\<turnstile>(fieldm fn f) of C accessible_from accclass"
+ where
+ "G\<turnstile>Field fn f of C accessible_from accclass ==
+ G\<turnstile>(fieldm fn f) of C accessible_from accclass"
inductive
dyn_accessible_fromR :: "prog \<Rightarrow> qtname \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> qtname \<Rightarrow> bool"
@@ -817,34 +798,32 @@
| "G\<turnstile>Method m in C dyn_accessible_from accC \<equiv> dyn_accessible_fromR G accC (methdMembr m) C"
-| Immediate: "\<lbrakk>G\<turnstile>membr member_in class;
+| Immediate: "!!class. \<lbrakk>G\<turnstile>membr member_in class;
G\<turnstile>membr in class permits_acc_from accclass
\<rbrakk> \<Longrightarrow> G\<turnstile>membr in class dyn_accessible_from accclass"
-| Overriding: "\<lbrakk>G\<turnstile>membr member_in class;
+| Overriding: "!!class. \<lbrakk>G\<turnstile>membr member_in class;
membr=(C,mdecl new);
G\<turnstile>(C,new) overrides old;
G\<turnstile>class \<prec>\<^sub>C supr;
G\<turnstile>Method old in supr dyn_accessible_from accclass
\<rbrakk>\<Longrightarrow> G\<turnstile>membr in class dyn_accessible_from accclass"
-syntax
+abbreviation
methd_dyn_accessible_from::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ in _ dyn'_accessible'_from _" [61,61,61,61,61] 60)
+ where
+ "G\<turnstile>Methd s m in C dyn_accessible_from accC ==
+ G\<turnstile>(method s m) in C dyn_accessible_from accC"
-translations
-"G\<turnstile>Methd s m in C dyn_accessible_from accC"
- \<rightleftharpoons> "G\<turnstile>(method s m) in C dyn_accessible_from accC"
-
-syntax
+abbreviation
field_dyn_accessible_from::
"prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ in _ dyn'_accessible'_from _" [61,61,61,61,61] 60)
-
-translations
-"G\<turnstile>Field fn f in dynC dyn_accessible_from accC"
- \<rightleftharpoons> "G\<turnstile>(fieldm fn f) in dynC dyn_accessible_from accC"
+ where
+ "G\<turnstile>Field fn f in dynC dyn_accessible_from accC ==
+ G\<turnstile>(fieldm fn f) in dynC dyn_accessible_from accC"
lemma accessible_from_commonD: "G\<turnstile>m of C accessible_from S
--- a/src/HOL/Bali/DefiniteAssignmentCorrect.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/DefiniteAssignmentCorrect.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,3 @@
-(* $Id$ *)
-
header {* Correctness of Definite Assignment *}
theory DefiniteAssignmentCorrect imports WellForm Eval begin
--- a/src/HOL/Bali/Eval.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Eval.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Eval.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Operational evaluation (big-step) semantics of Java expressions and
@@ -125,20 +124,21 @@
assignment.
*}
-syntax (xsymbols)
+abbreviation (xsymbols)
dummy_res :: "vals" ("\<diamondsuit>")
-translations
- "\<diamondsuit>" == "In1 Unit"
+ where "\<diamondsuit> == In1 Unit"
+
+abbreviation (input)
+ val_inj_vals ("\<lfloor>_\<rfloor>\<^sub>e" 1000)
+ where "\<lfloor>e\<rfloor>\<^sub>e == In1 e"
-syntax
- val_inj_vals:: "expr \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>e" 1000)
- var_inj_vals:: "var \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>v" 1000)
- lst_inj_vals:: "expr list \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>l" 1000)
+abbreviation (input)
+ var_inj_vals ("\<lfloor>_\<rfloor>\<^sub>v" 1000)
+ where "\<lfloor>v\<rfloor>\<^sub>v == In2 v"
-translations
- "\<lfloor>e\<rfloor>\<^sub>e" \<rightharpoonup> "In1 e"
- "\<lfloor>v\<rfloor>\<^sub>v" \<rightharpoonup> "In2 v"
- "\<lfloor>es\<rfloor>\<^sub>l" \<rightharpoonup> "In3 es"
+abbreviation (input)
+ lst_inj_vals ("\<lfloor>_\<rfloor>\<^sub>l" 1000)
+ where "\<lfloor>es\<rfloor>\<^sub>l == In3 es"
constdefs
undefined3 :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> vals"
--- a/src/HOL/Bali/Evaln.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Evaln.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Evaln.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Operational evaluation (big-step) semantics of Java expressions and
--- a/src/HOL/Bali/Example.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Example.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1202,74 +1202,52 @@
abbreviation "one == Suc 0"
abbreviation "two == Suc one"
-abbreviation "tree == Suc two"
-abbreviation "four == Suc tree"
+abbreviation "three == Suc two"
+abbreviation "four == Suc three"
+
+abbreviation
+ "obj_a == \<lparr>tag=Arr (PrimT Boolean) 2
+ ,values= empty(Inr 0\<mapsto>Bool False)(Inr 1\<mapsto>Bool False)\<rparr>"
-syntax
- obj_a :: obj
- obj_b :: obj
- obj_c :: obj
- arr_N :: "(vn, val) table"
- arr_a :: "(vn, val) table"
- globs1 :: globs
- globs2 :: globs
- globs3 :: globs
- globs8 :: globs
- locs3 :: locals
- locs4 :: locals
- locs8 :: locals
- s0 :: state
- s0' :: state
- s9' :: state
- s1 :: state
- s1' :: state
- s2 :: state
- s2' :: state
- s3 :: state
- s3' :: state
- s4 :: state
- s4' :: state
- s6' :: state
- s7' :: state
- s8 :: state
- s8' :: state
+abbreviation
+ "obj_b == \<lparr>tag=CInst Ext
+ ,values=(empty(Inl (vee, Base)\<mapsto>Null )
+ (Inl (vee, Ext )\<mapsto>Intg 0))\<rparr>"
+
+abbreviation
+ "obj_c == \<lparr>tag=CInst (SXcpt NullPointer),values=CONST empty\<rparr>"
+
+abbreviation "arr_N == empty(Inl (arr, Base)\<mapsto>Null)"
+abbreviation "arr_a == empty(Inl (arr, Base)\<mapsto>Addr a)"
+
+abbreviation
+ "globs1 == empty(Inr Ext \<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inr Base \<mapsto>\<lparr>tag=undefined, values=arr_N\<rparr>)
+ (Inr Object\<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)"
-translations
- "obj_a" <= "\<lparr>tag=Arr (PrimT Boolean) (CONST two)
- ,values=CONST empty(CONST Inr 0\<mapsto>Bool False)(CONST Inr (CONST one)\<mapsto>Bool False)\<rparr>"
- "obj_b" <= "\<lparr>tag=CInst (CONST Ext)
- ,values=(CONST empty(CONST Inl (CONST vee, CONST Base)\<mapsto>Null )
- (CONST Inl (CONST vee, CONST Ext )\<mapsto>Intg 0))\<rparr>"
- "obj_c" == "\<lparr>tag=CInst (SXcpt NullPointer),values=CONST empty\<rparr>"
- "arr_N" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Null)"
- "arr_a" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Addr a)"
- "globs1" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_N\<rparr>)
- (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)"
- "globs2" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inl a\<mapsto>obj_a)
- (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_a\<rparr>)"
- "globs3" == "globs2(CONST Inl b\<mapsto>obj_b)"
- "globs8" == "globs3(CONST Inl c\<mapsto>obj_c)"
- "locs3" == "CONST empty(VName (CONST e)\<mapsto>Addr b)"
- "locs4" == "CONST empty(VName (CONST z)\<mapsto>Null)(CONST Inr()\<mapsto>Addr b)"
- "locs8" == "locs3(VName (CONST z)\<mapsto>Addr c)"
- "s0" == " st (CONST empty) (CONST empty)"
- "s0'" == " Norm s0"
- "s1" == " st globs1 (CONST empty)"
- "s1'" == " Norm s1"
- "s2" == " st globs2 (CONST empty)"
- "s2'" == " Norm s2"
- "s3" == " st globs3 locs3 "
- "s3'" == " Norm s3"
- "s4" == " st globs3 locs4"
- "s4'" == " Norm s4"
- "s6'" == "(Some (Xcpt (Std NullPointer)), s4)"
- "s7'" == "(Some (Xcpt (Std NullPointer)), s3)"
- "s8" == " st globs8 locs8"
- "s8'" == " Norm s8"
- "s9'" == "(Some (Xcpt (Std IndOutBound)), s8)"
+abbreviation
+ "globs2 == empty(Inr Ext \<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inr Object\<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inl a\<mapsto>obj_a)
+ (Inr Base \<mapsto>\<lparr>tag=undefined, values=arr_a\<rparr>)"
+
+abbreviation "globs3 == globs2(Inl b\<mapsto>obj_b)"
+abbreviation "globs8 == globs3(Inl c\<mapsto>obj_c)"
+abbreviation "locs3 == empty(VName e\<mapsto>Addr b)"
+abbreviation "locs8 == locs3(VName z\<mapsto>Addr c)"
+
+abbreviation "s0 == st empty empty"
+abbreviation "s0' == Norm s0"
+abbreviation "s1 == st globs1 empty"
+abbreviation "s1' == Norm s1"
+abbreviation "s2 == st globs2 empty"
+abbreviation "s2' == Norm s2"
+abbreviation "s3 == st globs3 locs3"
+abbreviation "s3' == Norm s3"
+abbreviation "s7' == (Some (Xcpt (Std NullPointer)), s3)"
+abbreviation "s8 == st globs8 locs8"
+abbreviation "s8' == Norm s8"
+abbreviation "s9' == (Some (Xcpt (Std IndOutBound)), s8)"
declare Pair_eq [simp del]
@@ -1293,7 +1271,7 @@
apply (rule eval_Is (* NewC *))
(* begin init Ext *)
apply (erule_tac V = "the (new_Addr ?h) = b" in thin_rl)
-apply (erule_tac V = "atleast_free ?h tree" in thin_rl)
+apply (erule_tac V = "atleast_free ?h three" in thin_rl)
apply (erule_tac [2] V = "atleast_free ?h four" in thin_rl)
apply (erule_tac [2] V = "new_Addr ?h = Some a" in thin_rl)
apply (rule eval_Is (* Init Ext *))
@@ -1336,7 +1314,7 @@
apply (drule alloc_one)
apply (simp (no_asm_simp))
apply clarsimp
-apply (erule_tac V = "atleast_free ?h tree" in thin_rl)
+apply (erule_tac V = "atleast_free ?h three" in thin_rl)
apply (drule_tac x = "a" in new_AddrD2 [THEN spec])
apply (simp (no_asm_use))
apply (rule eval_Is (* Try *))
--- a/src/HOL/Bali/Name.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Name.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Name.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Java names *}
@@ -20,13 +19,11 @@
datatype lname --{* names for local variables and the This pointer *}
= EName ename
| This
-syntax
- VName :: "vname \<Rightarrow> lname"
- Result :: lname
+abbreviation VName :: "vname \<Rightarrow> lname"
+ where "VName n == EName (VNam n)"
-translations
- "VName n" == "EName (VNam n)"
- "Result" == "EName Res"
+abbreviation Result :: lname
+ where "Result == EName Res"
datatype xname --{* names of standard exceptions *}
= Throwable
--- a/src/HOL/Bali/State.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/State.thy Fri Feb 19 15:21:57 2010 +0000
@@ -254,13 +254,11 @@
by (simp add: heap_def)
-syntax
- val_this :: "st \<Rightarrow> val"
- lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
+abbreviation val_this :: "st \<Rightarrow> val"
+ where "val_this s == the (locals s This)"
-translations
- "val_this s" == "CONST the (locals s This)"
- "lookup_obj s a'" == "CONST the (heap s (the_Addr a'))"
+abbreviation lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
+ where "lookup_obj s a' == the (heap s (the_Addr a'))"
subsection "memory allocation"
@@ -286,12 +284,8 @@
subsection "initialization"
-syntax
-
- init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
-
-translations
- "init_vals vs" == "CONST Option.map default_val \<circ> vs"
+abbreviation init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
+ where "init_vals vs == Option.map default_val \<circ> vs"
lemma init_arr_comps_base [simp]: "init_vals (arr_comps T 0) = empty"
apply (unfold arr_comps_def in_bounds_def)
@@ -325,11 +319,9 @@
init_obj :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> st \<Rightarrow> st"
"init_obj G oi r \<equiv> gupd(r\<mapsto>\<lparr>tag=oi, values=init_vals (var_tys G oi r)\<rparr>)"
-syntax
+abbreviation
init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
-
-translations
- "init_class_obj G C" == "init_obj G CONST undefined (CONST Inr C)"
+ where "init_class_obj G C == init_obj G undefined (Inr C)"
lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
apply (unfold gupd_def)
@@ -513,19 +505,17 @@
apply auto
done
-syntax
+abbreviation raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "raise_if c xn == abrupt_if c (Some (Xcpt (Std xn)))"
+
+abbreviation np :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "np v == raise_if (v = Null) NullPointer"
- raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
- np :: "val \<spacespace> \<Rightarrow> abopt \<Rightarrow> abopt"
- check_neg:: "val \<spacespace> \<Rightarrow> abopt \<Rightarrow> abopt"
- error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
-
-translations
+abbreviation check_neg :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "check_neg i' == raise_if (the_Intg i'<0) NegArrSize"
- "raise_if c xn" == "abrupt_if c (Some (Xcpt (Std xn)))"
- "np v" == "raise_if (v = Null) NullPointer"
- "check_neg i'" == "raise_if (the_Intg i'<0) NegArrSize"
- "error_if c e" == "abrupt_if c (Some (Error e))"
+abbreviation error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "error_if c e == abrupt_if c (Some (Error e))"
lemma raise_if_None [simp]: "(raise_if c x y = None) = (\<not>c \<and> y = None)"
apply (simp add: abrupt_if_def)
@@ -592,22 +582,23 @@
types
state = "abopt \<times> st" --{* state including abruption information *}
-syntax
- Norm :: "st \<Rightarrow> state"
- abrupt :: "state \<Rightarrow> abopt"
- store :: "state \<Rightarrow> st"
-
translations
-
- "Norm s" == "(None,s)"
- "abrupt" => "fst"
- "store" => "snd"
"abopt" <= (type) "State.abrupt option"
"abopt" <= (type) "abrupt option"
"state" <= (type) "abopt \<times> State.st"
"state" <= (type) "abopt \<times> st"
+abbreviation
+ Norm :: "st \<Rightarrow> state"
+ where "Norm s == (None, s)"
+abbreviation (input)
+ abrupt :: "state \<Rightarrow> abopt"
+ where "abrupt == fst"
+
+abbreviation (input)
+ store :: "state \<Rightarrow> st"
+ where "store == snd"
lemma single_stateE: "\<forall>Z. Z = (s::state) \<Longrightarrow> False"
apply (erule_tac x = "(Some k,y)" in all_dupE)
@@ -683,15 +674,11 @@
lemma supd_abrupt_invariant [simp]: "abrupt (supd f s) = abrupt s"
by (cases s) simp
-syntax
+abbreviation set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
+ where "set_lvars l == supd (set_locals l)"
- set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
- restore_lvars :: "state \<Rightarrow> state \<Rightarrow> state"
-
-translations
-
- "set_lvars l" == "supd (set_locals l)"
- "restore_lvars s' s" == "set_lvars (locals (store s')) s"
+abbreviation restore_lvars :: "state \<Rightarrow> state \<Rightarrow> state"
+ where "restore_lvars s' s == set_lvars (locals (store s')) s"
lemma set_set_lvars [simp]: "\<And> s. set_lvars l (set_lvars l' s) = set_lvars l s"
apply (simp (no_asm_simp) only: split_tupled_all)
--- a/src/HOL/Bali/Term.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Term.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Term.thy
- ID: $Id$
Author: David von Oheimb
*)
@@ -244,22 +243,23 @@
"stmt" <= (type) "Term.stmt"
"term" <= (type) "(expr+stmt,var,expr list) sum3"
-syntax
-
- this :: expr
- LAcc :: "vname \<Rightarrow> expr" ("!!")
- LAss :: "vname \<Rightarrow> expr \<Rightarrow>stmt" ("_:==_" [90,85] 85)
- Return :: "expr \<Rightarrow> stmt"
- StatRef :: "ref_ty \<Rightarrow> expr"
+abbreviation this :: expr
+ where "this == Acc (LVar This)"
+
+abbreviation LAcc :: "vname \<Rightarrow> expr" ("!!")
+ where "!!v == Acc (LVar (EName (VNam v)))"
-translations
-
- "this" == "Acc (LVar This)"
- "!!v" == "Acc (LVar (EName (VNam v)))"
- "v:==e" == "Expr (Ass (LVar (EName (VNam v))) e)"
- "Return e" == "Expr (Ass (LVar (EName Res)) e);; Jmp Ret"
- --{* \tt Res := e;; Jmp Ret *}
- "StatRef rt" == "Cast (RefT rt) (Lit Null)"
+abbreviation
+ LAss :: "vname \<Rightarrow> expr \<Rightarrow>stmt" ("_:==_" [90,85] 85)
+ where "v:==e == Expr (Ass (LVar (EName (VNam v))) e)"
+
+abbreviation
+ Return :: "expr \<Rightarrow> stmt"
+ where "Return e == Expr (Ass (LVar (EName Res)) e);; Jmp Ret" --{* \tt Res := e;; Jmp Ret *}
+
+abbreviation
+ StatRef :: "ref_ty \<Rightarrow> expr"
+ where "StatRef rt == Cast (RefT rt) (Lit Null)"
constdefs
@@ -275,17 +275,21 @@
expressions, variables and expression lists into general terms.
*}
-syntax
- expr_inj_term:: "expr \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>e" 1000)
- stmt_inj_term:: "stmt \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>s" 1000)
- var_inj_term:: "var \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>v" 1000)
- lst_inj_term:: "expr list \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>l" 1000)
+abbreviation (input)
+ expr_inj_term :: "expr \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>e" 1000)
+ where "\<langle>e\<rangle>\<^sub>e == In1l e"
+
+abbreviation (input)
+ stmt_inj_term :: "stmt \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>s" 1000)
+ where "\<langle>c\<rangle>\<^sub>s == In1r c"
-translations
- "\<langle>e\<rangle>\<^sub>e" \<rightharpoonup> "In1l e"
- "\<langle>c\<rangle>\<^sub>s" \<rightharpoonup> "In1r c"
- "\<langle>v\<rangle>\<^sub>v" \<rightharpoonup> "In2 v"
- "\<langle>es\<rangle>\<^sub>l" \<rightharpoonup> "In3 es"
+abbreviation (input)
+ var_inj_term :: "var \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>v" 1000)
+ where "\<langle>v\<rangle>\<^sub>v == In2 v"
+
+abbreviation (input)
+ lst_inj_term :: "expr list \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>l" 1000)
+ where "\<langle>es\<rangle>\<^sub>l == In3 es"
text {* It seems to be more elegant to have an overloaded injection like the
following.
@@ -300,7 +304,7 @@
@{text AxSem} don't follow this convention right now, but introduce subtle
syntactic sugar in the relations themselves to make a distinction on
expressions, statements and so on. So unfortunately you will encounter a
-mixture of dealing with these injections. The translations above are used
+mixture of dealing with these injections. The abbreviations above are used
as bridge between the different conventions.
*}
--- a/src/HOL/Bali/Trans.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Trans.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Trans.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
Operational transition (small-step) semantics of the
@@ -60,13 +59,13 @@
by (simp)
declare the_var_AVar_def [simp del]
-syntax (xsymbols)
- Ref :: "loc \<Rightarrow> expr"
- SKIP :: "expr"
+abbreviation
+ Ref :: "loc \<Rightarrow> expr"
+ where "Ref a == Lit (Addr a)"
-translations
- "Ref a" == "Lit (Addr a)"
- "SKIP" == "Lit Unit"
+abbreviation
+ SKIP :: "expr"
+ where "SKIP == Lit Unit"
inductive
step :: "[prog,term \<times> state,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>1 _"[61,82,82] 81)
--- a/src/HOL/Bali/Type.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Type.thy
- ID: $Id$
Author: David von Oheimb
*)
@@ -36,17 +35,11 @@
"ref_ty" <= (type) "Type.ref_ty"
"ty" <= (type) "Type.ty"
-syntax
- NT :: " \<spacespace> ty"
- Iface :: "qtname \<Rightarrow> ty"
- Class :: "qtname \<Rightarrow> ty"
- Array :: "ty \<Rightarrow> ty" ("_.[]" [90] 90)
-
-translations
- "NT" == "RefT NullT"
- "Iface I" == "RefT (IfaceT I)"
- "Class C" == "RefT (ClassT C)"
- "T.[]" == "RefT (ArrayT T)"
+abbreviation "NT == RefT NullT"
+abbreviation "Iface I == RefT (IfaceT I)"
+abbreviation "Class C == RefT (ClassT C)"
+abbreviation Array :: "ty \<Rightarrow> ty" ("_.[]" [90] 90)
+ where "T.[] == RefT (ArrayT T)"
constdefs
the_Class :: "ty \<Rightarrow> qtname"
--- a/src/HOL/Bali/TypeRel.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/TypeRel.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/TypeRel.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* The relations between Java types *}
@@ -35,37 +34,22 @@
(*subclseq, by translation*) (* subclass + identity *)
implmt1 :: "prog \<Rightarrow> (qtname \<times> qtname) set" --{* direct implementation *}
-syntax
+abbreviation
+ subint1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:I1_" [71,71,71] 70)
+ where "G|-I <:I1 J == (I,J) \<in> subint1 G"
- "_subint1" :: "prog => [qtname, qtname] => bool" ("_|-_<:I1_" [71,71,71] 70)
- "_subint" :: "prog => [qtname, qtname] => bool" ("_|-_<=:I _"[71,71,71] 70)
- (* Defined in Decl.thy:
- "_subcls1" :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
- "_subclseq":: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
- "_subcls" :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
- *)
- "@implmt1" :: "prog => [qtname, qtname] => bool" ("_|-_~>1_" [71,71,71] 70)
-
-syntax (xsymbols)
+abbreviation
+ subint_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<=:I _"[71,71,71] 70)
+ where "G|-I <=:I J == (I,J) \<in>(subint1 G)^*" --{* cf. 9.1.3 *}
- "_subint1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>I1_" [71,71,71] 70)
- "_subint" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>I _" [71,71,71] 70)
- (* Defined in Decl.thy:
-\ "_subcls1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70)
- "_subclseq":: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70)
- "_subcls" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
- *)
- "_implmt1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<leadsto>1_" [71,71,71] 70)
+abbreviation
+ implmt1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_~>1_" [71,71,71] 70)
+ where "G|-C ~>1 I == (C,I) \<in> implmt1 G"
-translations
-
- "G\<turnstile>I \<prec>I1 J" == "(I,J) \<in> subint1 G"
- "G\<turnstile>I \<preceq>I J" == "(I,J) \<in>(subint1 G)^*" --{* cf. 9.1.3 *}
- (* Defined in Decl.thy:
- "G\<turnstile>C \<prec>\<^sub>C\<^sub>1 D" == "(C,D) \<in> subcls1 G"
- "G\<turnstile>C \<preceq>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^*"
- *)
- "G\<turnstile>C \<leadsto>1 I" == "(C,I) \<in> implmt1 G"
+notation (xsymbols)
+ subint1_syntax ("_\<turnstile>_\<prec>I1_" [71,71,71] 70) and
+ subint_syntax ("_\<turnstile>_\<preceq>I _" [71,71,71] 70) and
+ implmt1_syntax ("_\<turnstile>_\<leadsto>1_" [71,71,71] 70)
section "subclass and subinterface relations"
--- a/src/HOL/Bali/TypeSafe.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/TypeSafe.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/TypeSafe.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* The type soundness proof for Java *}
--- a/src/HOL/Bali/Value.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/Value.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Value.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Java values *}
--- a/src/HOL/Bali/WellForm.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/WellForm.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2925,7 +2925,7 @@
then show "?P m"
by (auto simp add: permits_acc_def)
next
- case (Overriding new C declC newm old Sup)
+ case (Overriding new declC newm old Sup C)
assume member_new: "G \<turnstile> new member_in C" and
new: "new = (declC, mdecl newm)" and
override: "G \<turnstile> (declC, newm) overrides old" and
--- a/src/HOL/Bali/WellType.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Bali/WellType.thy Fri Feb 19 15:21:57 2010 +0000
@@ -43,11 +43,9 @@
"env" <= (type) "\<lparr>prg::prog,cls::qtname,lcl::lenv,\<dots>::'a\<rparr>"
-
-syntax
+abbreviation
pkg :: "env \<Rightarrow> pname" --{* select the current package from an environment *}
-translations
- "pkg e" == "pid (cls e)"
+ where "pkg e == pid (cls e)"
section "Static overloading: maximally specific methods "
@@ -426,29 +424,33 @@
E,dt\<Turnstile>e#es\<Colon>\<doteq>T#Ts"
-syntax (* for purely static typing *)
- "_wt" :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_|-_::_" [51,51,51] 50)
- "_wt_stmt" :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_|-_:<>" [51,51 ] 50)
- "_ty_expr" :: "env \<Rightarrow> [expr ,ty ] \<Rightarrow> bool" ("_|-_:-_" [51,51,51] 50)
- "_ty_var" :: "env \<Rightarrow> [var ,ty ] \<Rightarrow> bool" ("_|-_:=_" [51,51,51] 50)
- "_ty_exprs":: "env \<Rightarrow> [expr list,
- \<spacespace> ty list] \<Rightarrow> bool" ("_|-_:#_" [51,51,51] 50)
+(* for purely static typing *)
+abbreviation
+ wt_syntax :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_|-_::_" [51,51,51] 50)
+ where "E|-t::T == E,empty_dt\<Turnstile>t\<Colon> T"
+
+abbreviation
+ wt_stmt_syntax :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_|-_:<>" [51,51 ] 50)
+ where "E|-s:<> == E|-In1r s :: Inl (PrimT Void)"
+
+abbreviation
+ ty_expr_syntax :: "env \<Rightarrow> [expr, ty] \<Rightarrow> bool" ("_|-_:-_" [51,51,51] 50)
+ where "E|-e:-T == E|-In1l e :: Inl T"
-syntax (xsymbols)
- "_wt" :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>_" [51,51,51] 50)
- "_wt_stmt" :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<surd>" [51,51 ] 50)
- "_ty_expr" :: "env \<Rightarrow> [expr ,ty ] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>-_" [51,51,51] 50)
- "_ty_var" :: "env \<Rightarrow> [var ,ty ] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>=_" [51,51,51] 50)
- "_ty_exprs" :: "env \<Rightarrow> [expr list,
- \<spacespace> ty list] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<doteq>_" [51,51,51] 50)
+abbreviation
+ ty_var_syntax :: "env \<Rightarrow> [var, ty] \<Rightarrow> bool" ("_|-_:=_" [51,51,51] 50)
+ where "E|-e:=T == E|-In2 e :: Inl T"
-translations
- "E\<turnstile>t\<Colon> T" == "E,empty_dt\<Turnstile>t\<Colon> T"
- "E\<turnstile>s\<Colon>\<surd>" == "E\<turnstile>In1r s\<Colon>CONST Inl (PrimT Void)"
- "E\<turnstile>e\<Colon>-T" == "E\<turnstile>In1l e\<Colon>CONST Inl T"
- "E\<turnstile>e\<Colon>=T" == "E\<turnstile>In2 e\<Colon>CONST Inl T"
- "E\<turnstile>e\<Colon>\<doteq>T" == "E\<turnstile>In3 e\<Colon>CONST Inr T"
+abbreviation
+ ty_exprs_syntax :: "env \<Rightarrow> [expr list, ty list] \<Rightarrow> bool" ("_|-_:#_" [51,51,51] 50)
+ where "E|-e:#T == E|-In3 e :: Inr T"
+notation (xsymbols)
+ wt_syntax ("_\<turnstile>_\<Colon>_" [51,51,51] 50) and
+ wt_stmt_syntax ("_\<turnstile>_\<Colon>\<surd>" [51,51 ] 50) and
+ ty_expr_syntax ("_\<turnstile>_\<Colon>-_" [51,51,51] 50) and
+ ty_var_syntax ("_\<turnstile>_\<Colon>=_" [51,51,51] 50) and
+ ty_exprs_syntax ("_\<turnstile>_\<Colon>\<doteq>_" [51,51,51] 50)
declare not_None_eq [simp del]
declare split_if [split del] split_if_asm [split del]
--- a/src/HOL/Boogie/Boogie.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Boogie.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,7 +5,7 @@
header {* Integration of the Boogie program verifier *}
theory Boogie
-imports SMT
+imports "~~/src/HOL/SMT/SMT"
uses
("Tools/boogie_vcs.ML")
("Tools/boogie_loader.ML")
--- a/src/HOL/Boogie/Examples/Boogie_Dijkstra.certs Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Examples/Boogie_Dijkstra.certs Fri Feb 19 15:21:57 2010 +0000
@@ -1,4 +1,4 @@
-2/jIbDaU00KSkSih1o9sXg 193550
+JinTdmjIiorL0/vvOyf3+w 6542 0
#2 := false
decl up_6 :: (-> T4 T2 bool)
decl ?x47!7 :: (-> T2 T2)
@@ -6541,4 +6541,3 @@
#23081 := [unit-resolution #19916 #27207]: #17029
[unit-resolution #23081 #23182 #18055 #27235]: false
unsat
-
--- a/src/HOL/Boogie/Examples/Boogie_Max.certs Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Examples/Boogie_Max.certs Fri Feb 19 15:21:57 2010 +0000
@@ -1,4 +1,4 @@
-yJC0k+R1r4pWViX9DxewEQ 62526
+iks4GfP7O/NgNFyGZ4ynjQ 2224 0
#2 := false
#4 := 0::int
decl uf_3 :: (-> int int)
@@ -2223,4 +2223,3 @@
#2015 := [unit-resolution #2013 #2021]: #2041
[th-lemma #2015 #2047 #2043]: false
unsat
-
--- a/src/HOL/Boogie/Examples/VCC_Max.certs Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Examples/VCC_Max.certs Fri Feb 19 15:21:57 2010 +0000
@@ -1,4 +1,4 @@
-8ZKUEUSWY0Pcw6t0NqCjrQ 253722
+6Q8QWdFv463DpfVfkr0XnA 7790 0
#2 := false
decl uf_110 :: (-> T4 T5 int)
decl uf_66 :: (-> T5 int T3 T5)
@@ -7789,4 +7789,3 @@
#30656 := [unit-resolution #30273 #30655 #30643]: #30496
[unit-resolution #30529 #30656 #30639]: false
unsat
-
--- a/src/HOL/Boogie/Examples/VCC_Max.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Examples/VCC_Max.thy Fri Feb 19 15:21:57 2010 +0000
@@ -57,4 +57,4 @@
boogie_end
-end
\ No newline at end of file
+end
--- a/src/HOL/Boogie/Tools/boogie_commands.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Tools/boogie_commands.ML Fri Feb 19 15:21:57 2010 +0000
@@ -14,7 +14,7 @@
(* commands *)
-fun boogie_open (quiet, base_name) thy =
+fun boogie_open ((quiet, base_name), offsets) thy =
let
val path = Path.explode (base_name ^ ".b2i")
val _ = File.exists path orelse
@@ -22,7 +22,7 @@
val _ = Boogie_VCs.is_closed thy orelse
error ("Found the beginning of a new Boogie environment, " ^
"but another Boogie environment is still open.")
- in Boogie_Loader.load_b2i (not quiet) path thy end
+ in Boogie_Loader.load_b2i (not quiet) offsets path thy end
datatype vc_opts =
@@ -225,11 +225,15 @@
fun scan_arg f = Args.parens f
fun scan_opt n = Scan.optional (scan_arg (Args.$$$ n >> K true)) false
+val vc_offsets = Scan.optional (Args.bracks (OuterParse.list1
+ (OuterParse.string --| Args.colon -- OuterParse.nat))) []
+
val _ =
OuterSyntax.command "boogie_open"
"Open a new Boogie environment and load a Boogie-generated .b2i file."
OuterKeyword.thy_decl
- (scan_opt "quiet" -- OuterParse.name >> (Toplevel.theory o boogie_open))
+ (scan_opt "quiet" -- OuterParse.name -- vc_offsets >>
+ (Toplevel.theory o boogie_open))
val vc_name = OuterParse.name
--- a/src/HOL/Boogie/Tools/boogie_loader.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Boogie/Tools/boogie_loader.ML Fri Feb 19 15:21:57 2010 +0000
@@ -6,7 +6,7 @@
signature BOOGIE_LOADER =
sig
- val load_b2i: bool -> Path.T -> theory -> theory
+ val load_b2i: bool -> (string * int) list -> Path.T -> theory -> theory
end
structure Boogie_Loader: BOOGIE_LOADER =
@@ -414,11 +414,12 @@
fun make_label (line, col) = Free (label_name line col, @{typ bool})
fun labelled_by kind pos t = kind $ make_label pos $ t
- val label =
- $$$ "pos" |-- num -- num >> (fn (pos as (line, col)) =>
+ fun label offset =
+ $$$ "pos" |-- num -- num >> (fn (line, col) =>
if label_name line col = no_label_name then I
- else labelled_by @{term block_at} pos) ||
- $$$ "neg" |-- num -- num >> labelled_by @{term assert_at} ||
+ else labelled_by @{term block_at} (line - offset, col)) ||
+ $$$ "neg" |-- num -- num >> (fn (line, col) =>
+ labelled_by @{term assert_at} (line - offset, col)) ||
scan_fail "illegal label kind"
fun mk_store ((m, k), v) =
@@ -489,7 +490,7 @@
| rename _ t = t
in rename nctxt t end
in
-fun expr tds fds =
+fun expr offset tds fds =
let
fun binop t (u1, u2) = t $ u1 $ u2
fun binexp s f = scan_line' s |-- exp -- exp >> f
@@ -514,10 +515,10 @@
quants :|-- (fn (q, ((n, k), i)) =>
scan_count (scan_line "var" var_name -- typ tds) n --
scan_count (pattern exp) k --
- scan_count (attribute tds fds) i --
+ scan_count (attribute offset tds fds) i --
exp >> (fn (((vs, ps), _), t) =>
fold_rev (mk_quant q) vs (mk_trigger ps t))) ||
- scan_line "label" label -- exp >> (fn (mk, t) => mk t) ||
+ scan_line "label" (label offset) -- exp >> (fn (mk, t) => mk t) ||
scan_line "int-num" num >> HOLogic.mk_number @{typ int} ||
binexp "<" (binop @{term "op < :: int => _"}) ||
binexp "<=" (binop @{term "op <= :: int => _"}) ||
@@ -540,10 +541,10 @@
scan_fail "illegal expression") st
in exp >> (rename_variables o unique_labels) end
-and attribute tds fds =
+and attribute offset tds fds =
let
val attr_val =
- scan_line' "expr-attr" |-- expr tds fds >> TermValue ||
+ scan_line' "expr-attr" |-- expr offset tds fds >> TermValue ||
scan_line "string-attr" (Scan.repeat1 str) >>
(StringValue o space_implode " ") ||
scan_fail "illegal attribute value"
@@ -556,36 +557,40 @@
fun type_decls verbose = Scan.depend (fn thy =>
Scan.repeat (scan_line "type-decl" (str -- num -- num) :|-- (fn (ty, i) =>
- scan_count (attribute Symtab.empty Symtab.empty) i >> K ty)) >>
+ scan_count (attribute 0 Symtab.empty Symtab.empty) i >> K ty)) >>
(fn tys => declare_types verbose tys thy))
fun fun_decls verbose tds = Scan.depend (fn thy =>
Scan.repeat (scan_line "fun-decl" (str -- num -- num) :|--
(fn ((name, arity), i) =>
scan_count (typ tds) (arity - 1) -- typ tds --
- scan_count (attribute tds Symtab.empty) i >> pair name)) >>
+ scan_count (attribute 0 tds Symtab.empty) i >> pair name)) >>
(fn fns => declare_functions verbose fns thy))
fun axioms verbose tds fds unique_axs = Scan.depend (fn thy =>
Scan.repeat (scan_line "axiom" num :|-- (fn i =>
- expr tds fds --| scan_count (attribute tds fds) i)) >>
+ expr 0 tds fds --| scan_count (attribute 0 tds fds) i)) >>
(fn axs => (add_axioms verbose (unique_axs @ axs) thy, ())))
fun var_decls tds fds = Scan.depend (fn thy =>
Scan.repeat (scan_line "var-decl" (str -- num) :|-- (fn (_, i) =>
- typ tds -- scan_count (attribute tds fds) i >> K ())) >> K (thy, ()))
+ typ tds -- scan_count (attribute 0 tds fds) i >> K ())) >> K (thy, ()))
+
+fun local_vc_offset offsets vc_name =
+ Integer.add ~1 (the_default 1 (AList.lookup (op =) offsets vc_name))
-fun vcs verbose tds fds = Scan.depend (fn thy =>
- Scan.repeat (scan_line "vc" (str -- num) --
- (expr tds fds)) >> (fn vcs => ((), add_vcs verbose vcs thy)))
+fun vcs verbose offsets tds fds = Scan.depend (fn thy =>
+ Scan.repeat (scan_line "vc" (str -- num) :-- (fn (name, _) =>
+ (expr (local_vc_offset offsets name) tds fds))) >>
+ (fn vcs => ((), add_vcs verbose vcs thy)))
-fun parse verbose thy = Scan.pass thy
+fun parse verbose offsets thy = Scan.pass thy
(type_decls verbose :|-- (fn tds =>
fun_decls verbose tds :|-- (fn (unique_axs, fds) =>
axioms verbose tds fds unique_axs |--
var_decls tds fds |--
- vcs verbose tds fds)))
+ vcs verbose offsets tds fds)))
-fun load_b2i verbose path thy = finite (parse verbose thy) path
+fun load_b2i verbose offsets path thy = finite (parse verbose offsets thy) path
end
--- a/src/HOL/Code_Numeral.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Code_Numeral.thy Fri Feb 19 15:21:57 2010 +0000
@@ -144,7 +144,7 @@
subsection {* Basic arithmetic *}
-instantiation code_numeral :: "{minus, ordered_semidom, semiring_div, linorder}"
+instantiation code_numeral :: "{minus, linordered_semidom, semiring_div, linorder}"
begin
definition [simp, code del]:
--- a/src/HOL/Complete_Lattice.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Complete_Lattice.thy Fri Feb 19 15:21:57 2010 +0000
@@ -106,10 +106,10 @@
"INF x. B" == "INF x:CONST UNIV. B"
"INF x:A. B" == "CONST INFI A (%x. B)"
-print_translation {* [
-Syntax.preserve_binder_abs2_tr' @{const_syntax SUPR} "_SUP",
-Syntax.preserve_binder_abs2_tr' @{const_syntax INFI} "_INF"
-] *} -- {* to avoid eta-contraction of body *}
+print_translation {*
+ [Syntax.preserve_binder_abs2_tr' @{const_syntax SUPR} @{syntax_const "_SUP"},
+ Syntax.preserve_binder_abs2_tr' @{const_syntax INFI} @{syntax_const "_INF"}]
+*} -- {* to avoid eta-contraction of body *}
context complete_lattice
begin
@@ -282,16 +282,16 @@
"UNION \<equiv> SUPR"
syntax
- "@UNION1" :: "pttrns => 'b set => 'b set" ("(3UN _./ _)" [0, 10] 10)
- "@UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3UN _:_./ _)" [0, 10] 10)
+ "_UNION1" :: "pttrns => 'b set => 'b set" ("(3UN _./ _)" [0, 10] 10)
+ "_UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3UN _:_./ _)" [0, 10] 10)
syntax (xsymbols)
- "@UNION1" :: "pttrns => 'b set => 'b set" ("(3\<Union>_./ _)" [0, 10] 10)
- "@UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Union>_\<in>_./ _)" [0, 10] 10)
+ "_UNION1" :: "pttrns => 'b set => 'b set" ("(3\<Union>_./ _)" [0, 10] 10)
+ "_UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Union>_\<in>_./ _)" [0, 10] 10)
syntax (latex output)
- "@UNION1" :: "pttrns => 'b set => 'b set" ("(3\<Union>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
- "@UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Union>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 10] 10)
+ "_UNION1" :: "pttrns => 'b set => 'b set" ("(3\<Union>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
+ "_UNION" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Union>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 10] 10)
translations
"UN x y. B" == "UN x. UN y. B"
@@ -308,9 +308,9 @@
subscripts in Proof General.
*}
-print_translation {* [
-Syntax.preserve_binder_abs2_tr' @{const_syntax UNION} "@UNION"
-] *} -- {* to avoid eta-contraction of body *}
+print_translation {*
+ [Syntax.preserve_binder_abs2_tr' @{const_syntax UNION} @{syntax_const "_UNION"}]
+*} -- {* to avoid eta-contraction of body *}
lemma UNION_eq_Union_image:
"(\<Union>x\<in>A. B x) = \<Union>(B`A)"
@@ -518,16 +518,16 @@
"INTER \<equiv> INFI"
syntax
- "@INTER1" :: "pttrns => 'b set => 'b set" ("(3INT _./ _)" [0, 10] 10)
- "@INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3INT _:_./ _)" [0, 10] 10)
+ "_INTER1" :: "pttrns => 'b set => 'b set" ("(3INT _./ _)" [0, 10] 10)
+ "_INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3INT _:_./ _)" [0, 10] 10)
syntax (xsymbols)
- "@INTER1" :: "pttrns => 'b set => 'b set" ("(3\<Inter>_./ _)" [0, 10] 10)
- "@INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Inter>_\<in>_./ _)" [0, 10] 10)
+ "_INTER1" :: "pttrns => 'b set => 'b set" ("(3\<Inter>_./ _)" [0, 10] 10)
+ "_INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Inter>_\<in>_./ _)" [0, 10] 10)
syntax (latex output)
- "@INTER1" :: "pttrns => 'b set => 'b set" ("(3\<Inter>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
- "@INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Inter>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 10] 10)
+ "_INTER1" :: "pttrns => 'b set => 'b set" ("(3\<Inter>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
+ "_INTER" :: "pttrn => 'a set => 'b set => 'b set" ("(3\<Inter>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 10] 10)
translations
"INT x y. B" == "INT x. INT y. B"
@@ -535,9 +535,9 @@
"INT x. B" == "INT x:CONST UNIV. B"
"INT x:A. B" == "CONST INTER A (%x. B)"
-print_translation {* [
-Syntax.preserve_binder_abs2_tr' @{const_syntax INTER} "@INTER"
-] *} -- {* to avoid eta-contraction of body *}
+print_translation {*
+ [Syntax.preserve_binder_abs2_tr' @{const_syntax INTER} @{syntax_const "_INTER"}]
+*} -- {* to avoid eta-contraction of body *}
lemma INTER_eq_Inter_image:
"(\<Inter>x\<in>A. B x) = \<Inter>(B`A)"
--- a/src/HOL/Datatype.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Datatype.thy Fri Feb 19 15:21:57 2010 +0000
@@ -144,11 +144,10 @@
(** Scons vs Atom **)
lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
-apply (simp add: Atom_def Scons_def Push_Node_def One_nat_def)
-apply (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]
+unfolding Atom_def Scons_def Push_Node_def One_nat_def
+by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]
dest!: Abs_Node_inj
elim!: apfst_convE sym [THEN Push_neq_K0])
-done
lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym, standard]
@@ -199,14 +198,12 @@
(** Injectiveness of Scons **)
lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
-apply (simp add: Scons_def One_nat_def)
-apply (blast dest!: Push_Node_inject)
-done
+unfolding Scons_def One_nat_def
+by (blast dest!: Push_Node_inject)
lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
-apply (simp add: Scons_def One_nat_def)
-apply (blast dest!: Push_Node_inject)
-done
+unfolding Scons_def One_nat_def
+by (blast dest!: Push_Node_inject)
lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
apply (erule equalityE)
@@ -230,14 +227,14 @@
(** Scons vs Leaf **)
lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
-by (simp add: Leaf_def o_def Scons_not_Atom)
+unfolding Leaf_def o_def by (rule Scons_not_Atom)
lemmas Leaf_not_Scons [iff] = Scons_not_Leaf [THEN not_sym, standard]
(** Scons vs Numb **)
lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
-by (simp add: Numb_def o_def Scons_not_Atom)
+unfolding Numb_def o_def by (rule Scons_not_Atom)
lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym, standard]
@@ -281,14 +278,15 @@
by (auto simp add: Atom_def ntrunc_def ndepth_K0)
lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
-by (simp add: Leaf_def o_def ntrunc_Atom)
+unfolding Leaf_def o_def by (rule ntrunc_Atom)
lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
-by (simp add: Numb_def o_def ntrunc_Atom)
+unfolding Numb_def o_def by (rule ntrunc_Atom)
lemma ntrunc_Scons [simp]:
"ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
-by (auto simp add: Scons_def ntrunc_def One_nat_def ndepth_Push_Node)
+unfolding Scons_def ntrunc_def One_nat_def
+by (auto simp add: ndepth_Push_Node)
@@ -351,7 +349,7 @@
(** Injection **)
lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
-by (auto simp add: In0_def In1_def One_nat_def)
+unfolding In0_def In1_def One_nat_def by auto
lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym, standard]
@@ -417,10 +415,10 @@
by (simp add: Scons_def, blast)
lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
-by (simp add: In0_def subset_refl Scons_mono)
+by (simp add: In0_def Scons_mono)
lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
-by (simp add: In1_def subset_refl Scons_mono)
+by (simp add: In1_def Scons_mono)
(*** Split and Case ***)
--- a/src/HOL/Decision_Procs/Approximation.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Approximation.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1431,7 +1431,7 @@
moreover have "0 \<le> exp t / real (fact (get_even n)) * (real x) ^ (get_even n)"
by (auto intro!: mult_nonneg_nonneg divide_nonneg_pos simp add: get_even zero_le_even_power exp_gt_zero)
ultimately show ?thesis
- using get_odd exp_gt_zero by (auto intro!: pordered_cancel_semiring_class.mult_nonneg_nonneg)
+ using get_odd exp_gt_zero by (auto intro!: mult_nonneg_nonneg)
qed
finally have "real (lb_exp_horner prec (get_even n) 1 1 x) \<le> exp (real x)" .
} moreover
@@ -1451,7 +1451,7 @@
moreover have "exp t / real (fact (get_odd n)) * (real x) ^ (get_odd n) \<le> 0"
by (auto intro!: mult_nonneg_nonpos divide_nonpos_pos simp add: x_less_zero exp_gt_zero)
ultimately have "exp (real x) \<le> (\<Sum>j = 0..<get_odd n. 1 / real (fact j) * real x ^ j)"
- using get_odd exp_gt_zero by (auto intro!: pordered_cancel_semiring_class.mult_nonneg_nonneg)
+ using get_odd exp_gt_zero by (auto intro!: mult_nonneg_nonneg)
also have "\<dots> \<le> real (ub_exp_horner prec (get_odd n) 1 1 x)"
using bounds(2) by auto
finally have "exp (real x) \<le> real (ub_exp_horner prec (get_odd n) 1 1 x)" .
@@ -2950,7 +2950,8 @@
(\<Sum> i = 0..<Suc n. inverse (real (\<Prod> j \<in> {k..<k+i}. j)) * ?f i (real c) * (xs!x - real c)^i) +
inverse (real (\<Prod> j \<in> {k..<k+Suc n}. j)) * ?f (Suc n) t * (xs!x - real c)^Suc n" (is "_ = ?T")
unfolding funpow_Suc C_def[symmetric] setsum_move0 setprod_head_Suc
- by (auto simp add: algebra_simps setsum_right_distrib[symmetric])
+ by (auto simp add: algebra_simps)
+ (simp only: mult_left_commute [of _ "inverse (real k)"] setsum_right_distrib [symmetric])
finally have "?T \<in> {real l .. real u}" . }
thus ?thesis using DERIV by blast
qed
--- a/src/HOL/Decision_Procs/Decision_Procs.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Decision_Procs.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2,7 +2,8 @@
theory Decision_Procs
imports
- Commutative_Ring Cooper Ferrack MIR Approximation Dense_Linear_Order Parametric_Ferrante_Rackoff
+ Commutative_Ring Cooper Ferrack MIR Approximation Dense_Linear_Order
+ Parametric_Ferrante_Rackoff
Commutative_Ring_Complete
"ex/Commutative_Ring_Ex" "ex/Approximation_Ex" "ex/Dense_Linear_Order_Ex"
begin
--- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy Fri Feb 19 15:21:57 2010 +0000
@@ -208,7 +208,7 @@
section {* The classical QE after Langford for dense linear orders *}
-context dense_linear_order
+context dense_linorder
begin
lemma interval_empty_iff:
@@ -265,7 +265,7 @@
lemmas dlo_simps[noatp] = order_refl less_irrefl not_less not_le exists_neq
le_less neq_iff linear less_not_permute
-lemma axiom[noatp]: "dense_linear_order (op \<le>) (op <)" by (rule dense_linear_order_axioms)
+lemma axiom[noatp]: "dense_linorder (op \<le>) (op <)" by (rule dense_linorder_axioms)
lemma atoms[noatp]:
shows "TERM (less :: 'a \<Rightarrow> _)"
and "TERM (less_eq :: 'a \<Rightarrow> _)"
@@ -409,17 +409,17 @@
end
-locale constr_dense_linear_order = linorder_no_lb + linorder_no_ub +
+locale constr_dense_linorder = linorder_no_lb + linorder_no_ub +
fixes between
assumes between_less: "less x y \<Longrightarrow> less x (between x y) \<and> less (between x y) y"
and between_same: "between x x = x"
-sublocale constr_dense_linear_order < dense_linear_order
+sublocale constr_dense_linorder < dense_linorder
apply unfold_locales
using gt_ex lt_ex between_less
by (auto, rule_tac x="between x y" in exI, simp)
-context constr_dense_linear_order
+context constr_dense_linorder
begin
lemma rinf_U[noatp]:
@@ -500,8 +500,8 @@
lemmas npi_thms[noatp] = npi_conj npi_disj npi_eq npi_neq npi_lt npi_le npi_gt npi_ge npi_P
lemmas lin_dense_thms[noatp] = lin_dense_conj lin_dense_disj lin_dense_eq lin_dense_neq lin_dense_lt lin_dense_le lin_dense_gt lin_dense_ge lin_dense_P
-lemma ferrack_axiom[noatp]: "constr_dense_linear_order less_eq less between"
- by (rule constr_dense_linear_order_axioms)
+lemma ferrack_axiom[noatp]: "constr_dense_linorder less_eq less between"
+ by (rule constr_dense_linorder_axioms)
lemma atoms[noatp]:
shows "TERM (less :: 'a \<Rightarrow> _)"
and "TERM (less_eq :: 'a \<Rightarrow> _)"
@@ -551,7 +551,7 @@
subsection {* Ferrante and Rackoff algorithm over ordered fields *}
-lemma neg_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x < 0) == (x > 0))"
+lemma neg_prod_lt:"(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x < 0) == (x > 0))"
proof-
assume H: "c < 0"
have "c*x < 0 = (0/c < x)" by (simp only: neg_divide_less_eq[OF H] algebra_simps)
@@ -559,7 +559,7 @@
finally show "(c*x < 0) == (x > 0)" by simp
qed
-lemma pos_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x < 0) == (x < 0))"
+lemma pos_prod_lt:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x < 0) == (x < 0))"
proof-
assume H: "c > 0"
hence "c*x < 0 = (0/c > x)" by (simp only: pos_less_divide_eq[OF H] algebra_simps)
@@ -567,7 +567,7 @@
finally show "(c*x < 0) == (x < 0)" by simp
qed
-lemma neg_prod_sum_lt: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t< 0) == (x > (- 1/c)*t))"
+lemma neg_prod_sum_lt: "(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x + t< 0) == (x > (- 1/c)*t))"
proof-
assume H: "c < 0"
have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
@@ -576,7 +576,7 @@
finally show "(c*x + t < 0) == (x > (- 1/c)*t)" by simp
qed
-lemma pos_prod_sum_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t < 0) == (x < (- 1/c)*t))"
+lemma pos_prod_sum_lt:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x + t < 0) == (x < (- 1/c)*t))"
proof-
assume H: "c > 0"
have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
@@ -585,10 +585,10 @@
finally show "(c*x + t < 0) == (x < (- 1/c)*t)" by simp
qed
-lemma sum_lt:"((x::'a::pordered_ab_group_add) + t < 0) == (x < - t)"
+lemma sum_lt:"((x::'a::ordered_ab_group_add) + t < 0) == (x < - t)"
using less_diff_eq[where a= x and b=t and c=0] by simp
-lemma neg_prod_le:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x <= 0) == (x >= 0))"
+lemma neg_prod_le:"(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x <= 0) == (x >= 0))"
proof-
assume H: "c < 0"
have "c*x <= 0 = (0/c <= x)" by (simp only: neg_divide_le_eq[OF H] algebra_simps)
@@ -596,7 +596,7 @@
finally show "(c*x <= 0) == (x >= 0)" by simp
qed
-lemma pos_prod_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x <= 0) == (x <= 0))"
+lemma pos_prod_le:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x <= 0) == (x <= 0))"
proof-
assume H: "c > 0"
hence "c*x <= 0 = (0/c >= x)" by (simp only: pos_le_divide_eq[OF H] algebra_simps)
@@ -604,7 +604,7 @@
finally show "(c*x <= 0) == (x <= 0)" by simp
qed
-lemma neg_prod_sum_le: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t <= 0) == (x >= (- 1/c)*t))"
+lemma neg_prod_sum_le: "(c\<Colon>'a\<Colon>linordered_field) < 0 \<Longrightarrow> ((c*x + t <= 0) == (x >= (- 1/c)*t))"
proof-
assume H: "c < 0"
have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
@@ -613,7 +613,7 @@
finally show "(c*x + t <= 0) == (x >= (- 1/c)*t)" by simp
qed
-lemma pos_prod_sum_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t <= 0) == (x <= (- 1/c)*t))"
+lemma pos_prod_sum_le:"(c\<Colon>'a\<Colon>linordered_field) > 0 \<Longrightarrow> ((c*x + t <= 0) == (x <= (- 1/c)*t))"
proof-
assume H: "c > 0"
have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
@@ -622,24 +622,24 @@
finally show "(c*x + t <= 0) == (x <= (- 1/c)*t)" by simp
qed
-lemma sum_le:"((x::'a::pordered_ab_group_add) + t <= 0) == (x <= - t)"
+lemma sum_le:"((x::'a::ordered_ab_group_add) + t <= 0) == (x <= - t)"
using le_diff_eq[where a= x and b=t and c=0] by simp
-lemma nz_prod_eq:"(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x = 0) == (x = 0))" by simp
-lemma nz_prod_sum_eq: "(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x + t = 0) == (x = (- 1/c)*t))"
+lemma nz_prod_eq:"(c\<Colon>'a\<Colon>linordered_field) \<noteq> 0 \<Longrightarrow> ((c*x = 0) == (x = 0))" by simp
+lemma nz_prod_sum_eq: "(c\<Colon>'a\<Colon>linordered_field) \<noteq> 0 \<Longrightarrow> ((c*x + t = 0) == (x = (- 1/c)*t))"
proof-
assume H: "c \<noteq> 0"
have "c*x + t = 0 = (c*x = -t)" by (subst eq_iff_diff_eq_0 [of "c*x" "-t"], simp)
also have "\<dots> = (x = -t/c)" by (simp only: nonzero_eq_divide_eq[OF H] algebra_simps)
finally show "(c*x + t = 0) == (x = (- 1/c)*t)" by simp
qed
-lemma sum_eq:"((x::'a::pordered_ab_group_add) + t = 0) == (x = - t)"
+lemma sum_eq:"((x::'a::ordered_ab_group_add) + t = 0) == (x = - t)"
using eq_diff_eq[where a= x and b=t and c=0] by simp
-interpretation class_ordered_field_dense_linear_order: constr_dense_linear_order
+interpretation class_dense_linordered_field: constr_dense_linorder
"op <=" "op <"
- "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,number_ring}) + y)"
+ "\<lambda> x y. 1/2 * ((x::'a::{linordered_field,number_ring}) + y)"
proof (unfold_locales, dlo, dlo, auto)
fix x y::'a assume lt: "x < y"
from less_half_sum[OF lt] show "x < (x + y) /2" by simp
@@ -655,7 +655,7 @@
if h aconvc y then false else if h aconvc x then true else earlier t x y;
fun dest_frac ct = case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b=>
+ Const (@{const_name Rings.divide},_) $ a $ b=>
Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
| Const(@{const_name inverse}, _)$a => Rat.rat_of_quotient(1, HOLogic.dest_number a |> snd)
| t => Rat.rat_of_int (snd (HOLogic.dest_number t))
@@ -684,7 +684,7 @@
fun xnormalize_conv ctxt [] ct = reflexive ct
| xnormalize_conv ctxt (vs as (x::_)) ct =
case term_of ct of
- Const(@{const_name Algebras.less},_)$_$Const(@{const_name Algebras.zero},_) =>
+ Const(@{const_name Orderings.less},_)$_$Const(@{const_name Algebras.zero},_) =>
(case whatis x (Thm.dest_arg1 ct) of
("c*x+t",[c,t]) =>
let
@@ -727,7 +727,7 @@
| _ => reflexive ct)
-| Const(@{const_name Algebras.less_eq},_)$_$Const(@{const_name Algebras.zero},_) =>
+| Const(@{const_name Orderings.less_eq},_)$_$Const(@{const_name Algebras.zero},_) =>
(case whatis x (Thm.dest_arg1 ct) of
("c*x+t",[c,t]) =>
let
@@ -816,7 +816,7 @@
val eq_iff_diff_eq_0 = mk_meta_eq @{thm "eq_iff_diff_eq_0"}
in
fun field_isolate_conv phi ctxt vs ct = case term_of ct of
- Const(@{const_name Algebras.less},_)$a$b =>
+ Const(@{const_name Orderings.less},_)$a$b =>
let val (ca,cb) = Thm.dest_binop ct
val T = ctyp_of_term ca
val th = instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
@@ -825,7 +825,7 @@
(Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
in rth end
-| Const(@{const_name Algebras.less_eq},_)$a$b =>
+| Const(@{const_name Orderings.less_eq},_)$a$b =>
let val (ca,cb) = Thm.dest_binop ct
val T = ctyp_of_term ca
val th = instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
@@ -856,11 +856,11 @@
else Ferrante_Rackoff_Data.Nox
| @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
else Ferrante_Rackoff_Data.Nox
- | Const(@{const_name Algebras.less},_)$y$z =>
+ | Const(@{const_name Orderings.less},_)$y$z =>
if term_of x aconv y then Ferrante_Rackoff_Data.Lt
else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
else Ferrante_Rackoff_Data.Nox
- | Const (@{const_name Algebras.less_eq},_)$y$z =>
+ | Const (@{const_name Orderings.less_eq},_)$y$z =>
if term_of x aconv y then Ferrante_Rackoff_Data.Le
else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
else Ferrante_Rackoff_Data.Nox
@@ -871,7 +871,7 @@
addsplits [@{thm "abs_split"},@{thm "split_max"}, @{thm "split_min"}]
in
-Ferrante_Rackoff_Data.funs @{thm "class_ordered_field_dense_linear_order.ferrack_axiom"}
+Ferrante_Rackoff_Data.funs @{thm "class_dense_linordered_field.ferrack_axiom"}
{isolate_conv = field_isolate_conv, whatis = classfield_whatis, simpset = class_field_ss}
end
*}
--- a/src/HOL/Decision_Procs/MIR.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/MIR.thy Fri Feb 19 15:21:57 2010 +0000
@@ -54,7 +54,7 @@
by clarsimp
-lemma myl: "\<forall> (a::'a::{pordered_ab_group_add}) (b::'a). (a \<le> b) = (0 \<le> b - a)"
+lemma myl: "\<forall> (a::'a::{ordered_ab_group_add}) (b::'a). (a \<le> b) = (0 \<le> b - a)"
proof(clarify)
fix x y ::"'a"
have "(x \<le> y) = (x - y \<le> 0)" by (simp only: le_iff_diff_le_0[where a="x" and b="y"])
@@ -63,7 +63,7 @@
finally show "(x \<le> y) = (0 \<le> y - x)" .
qed
-lemma myless: "\<forall> (a::'a::{pordered_ab_group_add}) (b::'a). (a < b) = (0 < b - a)"
+lemma myless: "\<forall> (a::'a::{ordered_ab_group_add}) (b::'a). (a < b) = (0 < b - a)"
proof(clarify)
fix x y ::"'a"
have "(x < y) = (x - y < 0)" by (simp only: less_iff_diff_less_0[where a="x" and b="y"])
@@ -72,7 +72,7 @@
finally show "(x < y) = (0 < y - x)" .
qed
-lemma myeq: "\<forall> (a::'a::{pordered_ab_group_add}) (b::'a). (a = b) = (0 = b - a)"
+lemma myeq: "\<forall> (a::'a::{ordered_ab_group_add}) (b::'a). (a = b) = (0 = b - a)"
by auto
(* Maybe should be added to the library \<dots> *)
--- a/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Fri Feb 19 15:21:57 2010 +0000
@@ -7,9 +7,9 @@
theory Parametric_Ferrante_Rackoff
imports Reflected_Multivariate_Polynomial
"~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+ Efficient_Nat
begin
-
subsection {* Terms *}
datatype tm = CP poly | Bound nat | Add tm tm | Mul poly tm
@@ -447,7 +447,7 @@
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"
+consts Ifm ::"'a::{division_by_zero,linordered_field} list \<Rightarrow> 'a list \<Rightarrow> fm \<Rightarrow> bool"
primrec
"Ifm vs bs T = True"
"Ifm vs bs F = False"
@@ -1833,16 +1833,16 @@
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"
+lemma one_plus_one_pos[simp]: "(1::'a::{linordered_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"
+lemma one_plus_one_nonzero[simp]: "(1::'a::{linordered_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})"
+lemma half_sum_eq: "(u + u) / (1+1) = (u::'a::{linordered_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
@@ -2187,10 +2187,7 @@
{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
+ by (simp add: mult_less_0_iff field_simps)
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)"
@@ -2597,13 +2594,6 @@
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"
@@ -2948,14 +2938,7 @@
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{*
-
+ML {*
structure ReflectedFRPar =
struct
@@ -2963,7 +2946,7 @@
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 Algebras.divide},rrelT rT);
+fun divt rT = Const(@{const_name Rings.divide},rrelT rT);
fun timest rT = Const(@{const_name Algebras.times},rrelT rT);
fun plust rT = Const(@{const_name Algebras.plus},rrelT rT);
fun minust rT = Const(@{const_name Algebras.minus},rrelT rT);
@@ -2975,8 +2958,8 @@
val disjt = @{term "op |"};
val impt = @{term "op -->"};
val ifft = @{term "op = :: bool => _"}
-fun llt rT = Const(@{const_name Algebras.less},rrT rT);
-fun lle rT = Const(@{const_name Algebras.less},rrT rT);
+fun llt rT = Const(@{const_name Orderings.less},rrT rT);
+fun lle rT = Const(@{const_name Orderings.less},rrT rT);
fun eqt rT = Const("op =",rrT rT);
fun rz rT = Const(@{const_name Algebras.zero},rT);
@@ -2986,92 +2969,93 @@
fun num_of_term m t =
case t of
- Const(@{const_name Algebras.uminus},_)$t => FRPar.Neg (num_of_term m t)
- | Const(@{const_name Algebras.plus},_)$a$b => FRPar.Add (num_of_term m a, num_of_term m b)
- | Const(@{const_name Algebras.minus},_)$a$b => FRPar.Sub (num_of_term m a, num_of_term m b)
- | Const(@{const_name Algebras.times},_)$a$b => FRPar.Mul (num_of_term m a, num_of_term m b)
- | Const(@{const_name Power.power},_)$a$n => FRPar.Pw (num_of_term m a, dest_nat n)
- | Const(@{const_name Algebras.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));
+ Const(@{const_name Algebras.uminus},_)$t => @{code poly.Neg} (num_of_term m t)
+ | Const(@{const_name Algebras.plus},_)$a$b => @{code poly.Add} (num_of_term m a, num_of_term m b)
+ | Const(@{const_name Algebras.minus},_)$a$b => @{code poly.Sub} (num_of_term m a, num_of_term m b)
+ | Const(@{const_name Algebras.times},_)$a$b => @{code poly.Mul} (num_of_term m a, num_of_term m b)
+ | Const(@{const_name Power.power},_)$a$n => @{code poly.Pw} (num_of_term m a, dest_nat n)
+ | Const(@{const_name Rings.divide},_)$a$b => @{code poly.C} (HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
+ | _ => (@{code poly.C} (HOLogic.dest_number t |> snd,1)
+ handle TERM _ => @{code poly.Bound} (AList.lookup (op aconv) m t |> the));
fun tm_of_term m m' t =
case t of
- Const(@{const_name Algebras.uminus},_)$t => FRPar.tm_Neg (tm_of_term m m' t)
- | Const(@{const_name Algebras.plus},_)$a$b => FRPar.tm_Add (tm_of_term m m' a, tm_of_term m m' b)
- | Const(@{const_name Algebras.minus},_)$a$b => FRPar.tm_Sub (tm_of_term m m' a, tm_of_term m m' b)
- | Const(@{const_name Algebras.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));
+ Const(@{const_name Algebras.uminus},_)$t => @{code Neg} (tm_of_term m m' t)
+ | Const(@{const_name Algebras.plus},_)$a$b => @{code Add} (tm_of_term m m' a, tm_of_term m m' b)
+ | Const(@{const_name Algebras.minus},_)$a$b => @{code Sub} (tm_of_term m m' a, tm_of_term m m' b)
+ | Const(@{const_name Algebras.times},_)$a$b => @{code Mul} (num_of_term m' a, tm_of_term m m' b)
+ | _ => (@{code CP} (num_of_term m' t)
+ handle TERM _ => @{code Bound} (AList.lookup (op aconv) m t |> the)
+ | Option => @{code 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)
+ @{code poly.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)))
+| @{code poly.Bound} i => AList.lookup (op = : int*int -> bool) m i |> the
+| @{code poly.Add} (a,b) => (plust T)$(term_of_num T m a)$(term_of_num T m b)
+| @{code poly.Mul} (a,b) => (timest T)$(term_of_num T m a)$(term_of_num T m b)
+| @{code poly.Sub} (a,b) => (minust T)$(term_of_num T m a)$(term_of_num T m b)
+| @{code poly.Neg} a => (uminust T)$(term_of_num T m a)
+| @{code poly.Pw} (a,n) => (powt T)$(term_of_num T m t)$(HOLogic.mk_number HOLogic.natT n)
+| @{code poly.CN} (c,n,p) => term_of_num T m (@{code poly.Add} (c, @{code poly.Mul} (@{code poly.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))
+ @{code CP} p => term_of_num T m' p
+| @{code Bound} i => AList.lookup (op = : int*int -> bool) m i |> the
+| @{code Add} (a,b) => (plust T)$(term_of_tm T m m' a)$(term_of_tm T m m' b)
+| @{code Mul} (a,b) => (timest T)$(term_of_num T m' a)$(term_of_tm T m m' b)
+| @{code Sub} (a,b) => (minust T)$(term_of_tm T m m' a)$(term_of_tm T m m' b)
+| @{code Neg} a => (uminust T)$(term_of_tm T m m' a)
+| @{code CNP} (n,c,p) => term_of_tm T m m' (@{code Add}
+ (@{code Mul} (c, @{code 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("True",_) => @{code T}
+ | Const("False",_) => @{code F}
+ | Const("Not",_)$p => @{code NOT} (fm_of_term m m' p)
+ | Const("op &",_)$p$q => @{code And} (fm_of_term m m' p, fm_of_term m m' q)
+ | Const("op |",_)$p$q => @{code Or} (fm_of_term m m' p, fm_of_term m m' q)
+ | Const("op -->",_)$p$q => @{code 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 Algebras.less},_)$p$q =>
- FRPar.Lt (FRPar.tm_Sub(tm_of_term m m' p, tm_of_term m m' q))
- | Const(@{const_name Algebras.less_eq},_)$p$q =>
- FRPar.Le (FRPar.tm_Sub(tm_of_term m m' p, tm_of_term m m' q))
+ if domain_type ty = bT then @{code Iff} (fm_of_term m m' p, fm_of_term m m' q)
+ else @{code Eq} (@{code Sub} (tm_of_term m m' p, tm_of_term m m' q))
+ | Const(@{const_name Orderings.less},_)$p$q =>
+ @{code Lt} (@{code Sub} (tm_of_term m m' p, tm_of_term m m' q))
+ | Const(@{const_name Orderings.less_eq},_)$p$q =>
+ @{code Le} (@{code 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
+ in @{code 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
+ in @{code 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))
+ @{code T} => Const("True",bT)
+ | @{code F} => Const("False",bT)
+ | @{code NOT} p => nott $ (term_of_fm T m m' p)
+ | @{code And} (p,q) => conjt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | @{code Or} (p,q) => disjt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | @{code Imp} (p,q) => impt $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | @{code Iff} (p,q) => ifft $ (term_of_fm T m m' p) $ (term_of_fm T m m' q)
+ | @{code Lt} p => (llt T) $ (term_of_tm T m m' p) $ (rz T)
+ | @{code Le} p => (lle T) $ (term_of_tm T m m' p) $ (rz T)
+ | @{code Eq} p => (eqt T) $ (term_of_tm T m m' p) $ (rz T)
+ | @{code 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) =
@@ -3080,7 +3064,7 @@
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))))
+ (@{code frpar} (fm_of_term (m ~~ im) (m' ~~ im') t))))
end;
fun frpar_oracle2 (T,m, m', fm) =
@@ -3089,7 +3073,7 @@
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))))
+ (@{code frpar2} (fm_of_term (m ~~ im) (m' ~~ im') t))))
end;
end;
@@ -3172,54 +3156,54 @@
*} "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}")
+lemma "\<exists>(x::'a::{division_by_zero,linordered_field,number_ring}). y \<noteq> -1 \<longrightarrow> (y + 1)*x < 0"
+ apply (frpar type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "y::'a::{division_by_zero,linordered_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}")
+ apply (frpar type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "z::'a::{division_by_zero,linordered_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"
+lemma "\<exists>(r::'a::{division_by_zero,linordered_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")
+ have "(\<exists>(r::'a::{division_by_zero,linordered_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,linordered_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 (frpar type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "a::'a::{division_by_zero,linordered_field,number_ring}" "b::'a::{division_by_zero,linordered_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}")
+lemma "ALL (x::'a::{division_by_zero,linordered_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,linordered_field,number_ring}" pars: "t::'a::{division_by_zero,linordered_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}")
+lemma "\<exists>(x::'a::{division_by_zero,linordered_field,number_ring}). y \<noteq> -1 \<longrightarrow> (y + 1)*x < 0"
+ apply (frpar2 type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "y::'a::{division_by_zero,linordered_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}")
+ apply (frpar2 type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "z::'a::{division_by_zero,linordered_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"
+lemma "\<exists>(r::'a::{division_by_zero,linordered_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")
+ have "(\<exists>(r::'a::{division_by_zero,linordered_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,linordered_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 (frpar2 type: "'a::{division_by_zero,linordered_field,number_ring}" pars: "a::'a::{division_by_zero,linordered_field,number_ring}" "b::'a::{division_by_zero,linordered_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}")
+lemma "ALL (x::'a::{division_by_zero,linordered_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,linordered_field,number_ring}" pars: "t::'a::{division_by_zero,linordered_field,number_ring}")
apply (simp add: field_simps linorder_neq_iff[symmetric])
apply ferrack
oops
--- a/src/HOL/Decision_Procs/Polynomial_List.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Polynomial_List.thy Fri Feb 19 15:21:57 2010 +0000
@@ -772,7 +772,7 @@
text{*bound for polynomial.*}
-lemma poly_mono: "abs(x) \<le> k ==> abs(poly p (x::'a::{ordered_idom})) \<le> poly (map abs p) k"
+lemma poly_mono: "abs(x) \<le> k ==> abs(poly p (x::'a::{linordered_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)
--- a/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2,25 +2,21 @@
Author: Amine Chaieb
*)
-header {* Implementation and verification of mutivariate polynomials Library *}
-
+header {* Implementation and verification of multivariate polynomials *}
theory Reflected_Multivariate_Polynomial
-imports Parity Abstract_Rat Efficient_Nat List Polynomial_List
+imports Complex_Main Abstract_Rat Polynomial_List
begin
- (* Impelementation *)
+ (* Implementation *)
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)"
+abbreviation poly_0 :: "poly" ("0\<^sub>p") where "0\<^sub>p \<equiv> C (0\<^sub>N)"
+abbreviation poly_p :: "int \<Rightarrow> poly" ("_\<^sub>p") where "i\<^sub>p \<equiv> C (i\<^sub>N)"
subsection{* Boundedness, substitution and all that *}
consts polysize:: "poly \<Rightarrow> nat"
@@ -118,14 +114,14 @@
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"
+abbreviation poly_add :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "+\<^sub>p" 60)
+ where "a +\<^sub>p b \<equiv> polyadd (a,b)"
+abbreviation poly_mul :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "*\<^sub>p" 60)
+ where "a *\<^sub>p b \<equiv> polymul (a,b)"
+abbreviation poly_sub :: "poly \<Rightarrow> poly \<Rightarrow> poly" (infixl "-\<^sub>p" 60)
+ where "a -\<^sub>p b \<equiv> polysub (a,b)"
+abbreviation poly_pow :: "poly \<Rightarrow> nat \<Rightarrow> poly" (infixl "^\<^sub>p" 60)
+ where "a ^\<^sub>p k \<equiv> polypow k a"
recdef polyadd "measure (\<lambda> (a,b). polysize a + polysize b)"
"polyadd (C c, C c') = C (c+\<^sub>Nc')"
@@ -244,8 +240,9 @@
"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"
+abbreviation
+ Ipoly_syntax :: "poly \<Rightarrow> 'a list \<Rightarrow>'a::{ring_char_0,power,division_by_zero,field}" ("\<lparr>_\<rparr>\<^sub>p\<^bsup>_\<^esup>")
+ where "\<lparr>p\<rparr>\<^sub>p\<^bsup>bs\<^esup> \<equiv> Ipoly bs p"
lemma Ipoly_CInt: "Ipoly bs (C (i,1)) = of_int i"
by (simp add: INum_def)
--- a/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy Fri Feb 19 15:21:57 2010 +0000
@@ -7,147 +7,147 @@
begin
lemma
- "\<exists>(y::'a::{ordered_field,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
+ "\<exists>(y::'a::{linordered_field,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
by ferrack
-lemma "~ (ALL x (y::'a::{ordered_field,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
+lemma "~ (ALL x (y::'a::{linordered_field,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. x ~= y --> x < y"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y. x ~= y --> x < y"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX (y::'a::{ordered_field,number_ring, division_by_zero}). 4*x + 3*y <= 0 & 4*x + 3*y >= -1)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX (y::'a::{linordered_field,number_ring, division_by_zero}). 4*x + 3*y <= 0 & 4*x + 3*y >= -1)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) < 0. (EX (y::'a::{ordered_field,number_ring, division_by_zero}) > 0. 7*x + y > 0 & x - y <= 9)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) < 0. (EX (y::'a::{linordered_field,number_ring, division_by_zero}) > 0. 7*x + y > 0 & x - y <= 9)"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
by ferrack
-lemma "EX x. (ALL (y::'a::{ordered_field,number_ring, division_by_zero}). y < 2 --> 2*(y - x) \<le> 0 )"
+lemma "EX x. (ALL (y::'a::{linordered_field,number_ring, division_by_zero}). y < 2 --> 2*(y - x) \<le> 0 )"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + 7*y - 5* z < 0 & 5*y + 7*z + 3*x < 0"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z. x + 7*y - 5* z < 0 & 5*y + 7*z + 3*x < 0"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (abs (5*x+3*y+z) <= 5*x+3*y+z & abs (5*x+3*y+z) >= - (5*x+3*y+z)) | (abs (5*x+3*y+z) >= 5*x+3*y+z & abs (5*x+3*y+z) <= - (5*x+3*y+z))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y z. (abs (5*x+3*y+z) <= 5*x+3*y+z & abs (5*x+3*y+z) >= - (5*x+3*y+z)) | (abs (5*x+3*y+z) >= 5*x+3*y+z & abs (5*x+3*y+z) <= - (5*x+3*y+z))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero})>0. (ALL y. (EX z. 13* abs z \<noteq> abs (12*y - x) & 5*x - 3*(abs y) <= 7*z))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero})>0. (ALL y. (EX z. 13* abs z \<noteq> abs (12*y - x) & 5*x - 3*(abs y) <= 7*z))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). abs (4*x + 17) < 4 & (ALL y . abs (x*34 - 34*y - 9) \<noteq> 0 \<longrightarrow> (EX z. 5*x - 3*abs y <= 7*z))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}). abs (4*x + 17) < 4 & (ALL y . abs (x*34 - 34*y - 9) \<noteq> 0 \<longrightarrow> (EX z. 5*x - 3*abs y <= 7*z))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y > abs (23*x - 9). (ALL z > abs (3*y - 19* abs x). x+z > 2*y))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y > abs (23*x - 9). (ALL z > abs (3*y - 19* abs x). x+z > 2*y))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y< abs (3*x - 1). (ALL z >= (3*abs x - 1). abs (12*x - 13*y + 19*z) > abs (23*x) ))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y< abs (3*x - 1). (ALL z >= (3*abs x - 1). abs (12*x - 13*y + 19*z) > abs (23*x) ))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). abs x < 100 & (ALL y > x. (EX z<2*y - x. 5*x - 3*y <= 7*z))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}). abs x < 100 & (ALL y > x. (EX z<2*y - x. 5*x - 3*y <= 7*z))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 7*x<3*y --> 5*y < 7*z --> z < 2*w --> 7*(2*w-x) > 2*y"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y z w. 7*x<3*y --> 5*y < 7*z --> z < 2*w --> 7*(2*w-x) > 2*y"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + abs (y - 8*x + z) <= 89"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + abs (y - 8*x + z) <= 89"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + 7* (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + 7* (y - 8*x + z) <= max y (7*z - x + w)"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (EX w >= (x+y+z). w <= abs x + abs y + abs z)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y z. (EX w >= (x+y+z). w <= abs x + abs y + abs z)"
by ferrack
-lemma "~(ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y z w. 3* x + z*4 = 3*y & x + y < z & x> w & 3*x < w + y))"
+lemma "~(ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y z w. 3* x + z*4 = 3*y & x + y < z & x> w & 3*x < w + y))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z w. abs (x-y) = (z-w) & z*1234 < 233*x & w ~= y)"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. (EX z w. abs (x-y) = (z-w) & z*1234 < 233*x & w ~= y)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (ALL w >= abs (x+y+z). w >= abs x + abs y + abs z)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z. (ALL w >= abs (x+y+z). w >= abs x + abs y + abs z)"
by ferrack
-lemma "EX z. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX w >= (x+y+z). w <= abs x + abs y + abs z))"
+lemma "EX z. (ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. (EX w >= (x+y+z). w <= abs x + abs y + abs z))"
by ferrack
-lemma "EX z. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}) < abs z. (EX y w. x< y & x < z & x> w & 3*x < w + y))"
+lemma "EX z. (ALL (x::'a::{linordered_field,number_ring, division_by_zero}) < abs z. (EX y w. x< y & x < z & x> w & 3*x < w + y))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z. (ALL w. abs (x-y) = abs (z-w) --> z < x & w ~= y))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}) y. (EX z. (ALL w. abs (x-y) = abs (z-w) --> z < x & w ~= y))"
by ferrack
-lemma "EX y. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)))"
+lemma "EX y. (ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) z. (ALL w >= 13*x - 4*z. (EX y. w >= abs x + abs y + z))"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) z. (ALL w >= 13*x - 4*z. (EX y. w >= abs x + abs y + z))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
(ALL w. 5*w + 10*x - z >= y --> w + 7*x + 3*z >= 2*y)))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y. (EX z > y.
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}). (ALL y. (EX z > y.
(ALL w . w < 13 --> w + 10*x - z >= y --> 5*w + 7*x + 13*z >= 2*y)))"
by ferrack
-lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{linordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (y - x) < w)))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (y - x) < w)))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (x + z) < w - y)))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (x + z) < w - y)))"
by ferrack
-lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. abs y ~= abs x & (ALL z> max x y. (EX w. w ~= y & w ~= z & 3*w - z >= x + y)))"
+lemma "ALL (x::'a::{linordered_field,number_ring, division_by_zero}). (EX y. abs y ~= abs x & (ALL z> max x y. (EX w. w ~= y & w ~= z & 3*w - z >= x + y)))"
by ferrack
end
--- a/src/HOL/Decision_Procs/mir_tac.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Decision_Procs/mir_tac.ML Fri Feb 19 15:21:57 2010 +0000
@@ -33,7 +33,7 @@
@{thm "real_of_nat_number_of"},
@{thm "real_of_nat_Suc"}, @{thm "real_of_nat_one"}, @{thm "real_of_one"},
@{thm "real_of_int_zero"}, @{thm "real_of_nat_zero"},
- @{thm "Ring_and_Field.divide_zero"},
+ @{thm "Fields.divide_zero"},
@{thm "divide_divide_eq_left"}, @{thm "times_divide_eq_right"},
@{thm "times_divide_eq_left"}, @{thm "divide_divide_eq_right"},
@{thm "diff_def"}, @{thm "minus_divide_left"}]
--- a/src/HOL/Deriv.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Deriv.thy Fri Feb 19 15:21:57 2010 +0000
@@ -260,7 +260,7 @@
-- x --> d (f x) * D"
by (rule LIM_mult [OF _ f [unfolded DERIV_iff2]])
thus "(\<lambda>z. (g (f z) - g (f x)) / (z - x)) -- x --> E * D"
- by (simp add: d dfx real_scaleR_def)
+ by (simp add: d dfx)
qed
text {*
@@ -279,7 +279,7 @@
text {* Standard version *}
lemma DERIV_chain: "[| DERIV f (g x) :> Da; DERIV g x :> Db |] ==> DERIV (f o g) x :> Da * Db"
-by (drule (1) DERIV_chain', simp add: o_def real_scaleR_def mult_commute)
+by (drule (1) DERIV_chain', simp add: o_def mult_commute)
lemma DERIV_chain2: "[| DERIV f (g x) :> Da; DERIV g x :> Db |] ==> DERIV (%x. f (g x)) x :> Da * Db"
by (auto dest: DERIV_chain simp add: o_def)
@@ -290,7 +290,7 @@
lemma DERIV_pow: "DERIV (%x. x ^ n) x :> real n * (x ^ (n - Suc 0))"
apply (cut_tac DERIV_power [OF DERIV_ident])
-apply (simp add: real_scaleR_def real_of_nat_def)
+apply (simp add: real_of_nat_def)
done
text {* Power of @{text "-1"} *}
@@ -1532,12 +1532,12 @@
moreover
have "\<forall>x. a < x \<and> x < b \<longrightarrow> ?h differentiable x"
proof -
- have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. f b - f a) differentiable x" by (simp add: differentiable_const)
- with gd have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. (f b - f a) * g x) differentiable x" by (simp add: differentiable_mult)
+ have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. f b - f a) differentiable x" by simp
+ with gd have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. (f b - f a) * g x) differentiable x" by simp
moreover
- have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. g b - g a) differentiable x" by (simp add: differentiable_const)
- with fd have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. (g b - g a) * f x) differentiable x" by (simp add: differentiable_mult)
- ultimately show ?thesis by (simp add: differentiable_diff)
+ have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. g b - g a) differentiable x" by simp
+ with fd have "\<forall>x. a < x \<and> x < b \<longrightarrow> (\<lambda>x. (g b - g a) * f x) differentiable x" by simp
+ ultimately show ?thesis by simp
qed
ultimately have "\<exists>l z. a < z \<and> z < b \<and> DERIV ?h z :> l \<and> ?h b - ?h a = (b - a) * l" by (rule MVT)
then obtain l where ldef: "\<exists>z. a < z \<and> z < b \<and> DERIV ?h z :> l \<and> ?h b - ?h a = (b - a) * l" ..
--- a/src/HOL/Divides.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Divides.thy Fri Feb 19 15:21:57 2010 +0000
@@ -657,7 +657,7 @@
val trans = trans;
val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
- (@{thm monoid_add_class.add_0_left} :: @{thm monoid_add_class.add_0_right} :: @{thms add_ac}))
+ (@{thm add_0_left} :: @{thm add_0_right} :: @{thms add_ac}))
end)
@@ -1090,7 +1090,7 @@
lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
apply (subgoal_tac "m mod 2 < 2")
apply (erule less_2_cases [THEN disjE])
-apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
+apply (simp_all (no_asm_simp) add: Let_def mod_Suc)
done
lemma mod2_gr_0 [simp]: "0 < (m\<Colon>nat) mod 2 \<longleftrightarrow> m mod 2 = 1"
@@ -1655,8 +1655,8 @@
lemmas arithmetic_simps =
arith_simps
add_special
- OrderedGroup.add_0_left
- OrderedGroup.add_0_right
+ add_0_left
+ add_0_right
mult_zero_left
mult_zero_right
mult_1_left
@@ -1929,7 +1929,7 @@
apply (rule order_le_less_trans)
apply (erule_tac [2] mult_strict_right_mono)
apply (rule mult_left_mono_neg)
- using add1_zle_eq[of "q mod c"]apply(simp add: algebra_simps pos_mod_bound)
+ using add1_zle_eq[of "q mod c"]apply(simp add: algebra_simps)
apply (simp)
apply (simp)
done
@@ -1954,7 +1954,7 @@
apply (erule mult_strict_right_mono)
apply (rule_tac [2] mult_left_mono)
apply simp
- using add1_zle_eq[of "q mod c"] apply (simp add: algebra_simps pos_mod_bound)
+ using add1_zle_eq[of "q mod c"] apply (simp add: algebra_simps)
apply simp
done
--- a/src/HOL/Equiv_Relations.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Equiv_Relations.thy Fri Feb 19 15:21:57 2010 +0000
@@ -328,7 +328,7 @@
apply assumption
apply simp
apply(fastsimp simp add:inj_on_def)
-apply (simp add:setsum_constant)
+apply simp
done
end
--- a/src/HOL/Fact.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Fact.thy Fri Feb 19 15:21:57 2010 +0000
@@ -266,15 +266,15 @@
lemma of_nat_fact_not_zero [simp]: "of_nat (fact n) \<noteq> (0::'a::semiring_char_0)"
by auto
-lemma of_nat_fact_gt_zero [simp]: "(0::'a::{ordered_semidom}) < of_nat(fact n)" by auto
+lemma of_nat_fact_gt_zero [simp]: "(0::'a::{linordered_semidom}) < of_nat(fact n)" by auto
-lemma of_nat_fact_ge_zero [simp]: "(0::'a::ordered_semidom) \<le> of_nat(fact n)"
+lemma of_nat_fact_ge_zero [simp]: "(0::'a::linordered_semidom) \<le> of_nat(fact n)"
by simp
-lemma inv_of_nat_fact_gt_zero [simp]: "(0::'a::ordered_field) < inverse (of_nat (fact n))"
+lemma inv_of_nat_fact_gt_zero [simp]: "(0::'a::linordered_field) < inverse (of_nat (fact n))"
by (auto simp add: positive_imp_inverse_positive)
-lemma inv_of_nat_fact_ge_zero [simp]: "(0::'a::ordered_field) \<le> inverse (of_nat (fact n))"
+lemma inv_of_nat_fact_ge_zero [simp]: "(0::'a::linordered_field) \<le> inverse (of_nat (fact n))"
by (auto intro: order_less_imp_le)
end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Fields.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,1071 @@
+(* Title: HOL/Fields.thy
+ Author: Gertrud Bauer
+ Author: Steven Obua
+ Author: Tobias Nipkow
+ Author: Lawrence C Paulson
+ Author: Markus Wenzel
+ Author: Jeremy Avigad
+*)
+
+header {* Fields *}
+
+theory Fields
+imports Rings
+begin
+
+class field = comm_ring_1 + inverse +
+ assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
+ assumes field_divide_inverse: "a / b = a * inverse b"
+begin
+
+subclass division_ring
+proof
+ fix a :: 'a
+ assume "a \<noteq> 0"
+ thus "inverse a * a = 1" by (rule field_inverse)
+ thus "a * inverse a = 1" by (simp only: mult_commute)
+next
+ fix a b :: 'a
+ show "a / b = a * inverse b" by (rule field_divide_inverse)
+qed
+
+subclass idom ..
+
+lemma right_inverse_eq: "b \<noteq> 0 \<Longrightarrow> a / b = 1 \<longleftrightarrow> a = b"
+proof
+ assume neq: "b \<noteq> 0"
+ {
+ hence "a = (a / b) * b" by (simp add: divide_inverse mult_ac)
+ also assume "a / b = 1"
+ finally show "a = b" by simp
+ next
+ assume "a = b"
+ with neq show "a / b = 1" by (simp add: divide_inverse)
+ }
+qed
+
+lemma nonzero_inverse_eq_divide: "a \<noteq> 0 \<Longrightarrow> inverse a = 1 / a"
+by (simp add: divide_inverse)
+
+lemma divide_self [simp]: "a \<noteq> 0 \<Longrightarrow> a / a = 1"
+by (simp add: divide_inverse)
+
+lemma divide_zero_left [simp]: "0 / a = 0"
+by (simp add: divide_inverse)
+
+lemma inverse_eq_divide: "inverse a = 1 / a"
+by (simp add: divide_inverse)
+
+lemma add_divide_distrib: "(a+b) / c = a/c + b/c"
+by (simp add: divide_inverse algebra_simps)
+
+text{*There is no slick version using division by zero.*}
+lemma inverse_add:
+ "[| a \<noteq> 0; b \<noteq> 0 |]
+ ==> inverse a + inverse b = (a + b) * inverse a * inverse b"
+by (simp add: division_ring_inverse_add mult_ac)
+
+lemma nonzero_mult_divide_mult_cancel_left [simp, noatp]:
+assumes [simp]: "b\<noteq>0" and [simp]: "c\<noteq>0" shows "(c*a)/(c*b) = a/b"
+proof -
+ have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
+ by (simp add: divide_inverse nonzero_inverse_mult_distrib)
+ also have "... = a * inverse b * (inverse c * c)"
+ by (simp only: mult_ac)
+ also have "... = a * inverse b" by simp
+ finally show ?thesis by (simp add: divide_inverse)
+qed
+
+lemma nonzero_mult_divide_mult_cancel_right [simp, noatp]:
+ "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (b * c) = a / b"
+by (simp add: mult_commute [of _ c])
+
+lemma divide_1 [simp]: "a / 1 = a"
+by (simp add: divide_inverse)
+
+lemma times_divide_eq_right: "a * (b / c) = (a * b) / c"
+by (simp add: divide_inverse mult_assoc)
+
+lemma times_divide_eq_left: "(b / c) * a = (b * a) / c"
+by (simp add: divide_inverse mult_ac)
+
+text {* These are later declared as simp rules. *}
+lemmas times_divide_eq [noatp] = times_divide_eq_right times_divide_eq_left
+
+lemma add_frac_eq:
+ assumes "y \<noteq> 0" and "z \<noteq> 0"
+ shows "x / y + w / z = (x * z + w * y) / (y * z)"
+proof -
+ have "x / y + w / z = (x * z) / (y * z) + (y * w) / (y * z)"
+ using assms by simp
+ also have "\<dots> = (x * z + y * w) / (y * z)"
+ by (simp only: add_divide_distrib)
+ finally show ?thesis
+ by (simp only: mult_commute)
+qed
+
+text{*Special Cancellation Simprules for Division*}
+
+lemma nonzero_mult_divide_cancel_right [simp, noatp]:
+ "b \<noteq> 0 \<Longrightarrow> a * b / b = a"
+using nonzero_mult_divide_mult_cancel_right [of 1 b a] by simp
+
+lemma nonzero_mult_divide_cancel_left [simp, noatp]:
+ "a \<noteq> 0 \<Longrightarrow> a * b / a = b"
+using nonzero_mult_divide_mult_cancel_left [of 1 a b] by simp
+
+lemma nonzero_divide_mult_cancel_right [simp, noatp]:
+ "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> b / (a * b) = 1 / a"
+using nonzero_mult_divide_mult_cancel_right [of a b 1] by simp
+
+lemma nonzero_divide_mult_cancel_left [simp, noatp]:
+ "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / (a * b) = 1 / b"
+using nonzero_mult_divide_mult_cancel_left [of b a 1] by simp
+
+lemma nonzero_mult_divide_mult_cancel_left2 [simp, noatp]:
+ "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (c * a) / (b * c) = a / b"
+using nonzero_mult_divide_mult_cancel_left [of b c a] by (simp add: mult_ac)
+
+lemma nonzero_mult_divide_mult_cancel_right2 [simp, noatp]:
+ "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (c * b) = a / b"
+using nonzero_mult_divide_mult_cancel_right [of b c a] by (simp add: mult_ac)
+
+lemma minus_divide_left: "- (a / b) = (-a) / b"
+by (simp add: divide_inverse)
+
+lemma nonzero_minus_divide_right: "b \<noteq> 0 ==> - (a / b) = a / (- b)"
+by (simp add: divide_inverse nonzero_inverse_minus_eq)
+
+lemma nonzero_minus_divide_divide: "b \<noteq> 0 ==> (-a) / (-b) = a / b"
+by (simp add: divide_inverse nonzero_inverse_minus_eq)
+
+lemma divide_minus_left [simp, noatp]: "(-a) / b = - (a / b)"
+by (simp add: divide_inverse)
+
+lemma diff_divide_distrib: "(a - b) / c = a / c - b / c"
+by (simp add: diff_minus add_divide_distrib)
+
+lemma add_divide_eq_iff:
+ "z \<noteq> 0 \<Longrightarrow> x + y / z = (z * x + y) / z"
+by (simp add: add_divide_distrib)
+
+lemma divide_add_eq_iff:
+ "z \<noteq> 0 \<Longrightarrow> x / z + y = (x + z * y) / z"
+by (simp add: add_divide_distrib)
+
+lemma diff_divide_eq_iff:
+ "z \<noteq> 0 \<Longrightarrow> x - y / z = (z * x - y) / z"
+by (simp add: diff_divide_distrib)
+
+lemma divide_diff_eq_iff:
+ "z \<noteq> 0 \<Longrightarrow> x / z - y = (x - z * y) / z"
+by (simp add: diff_divide_distrib)
+
+lemma nonzero_eq_divide_eq: "c \<noteq> 0 \<Longrightarrow> a = b / c \<longleftrightarrow> a * c = b"
+proof -
+ assume [simp]: "c \<noteq> 0"
+ have "a = b / c \<longleftrightarrow> a * c = (b / c) * c" by simp
+ also have "... \<longleftrightarrow> a * c = b" by (simp add: divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma nonzero_divide_eq_eq: "c \<noteq> 0 \<Longrightarrow> b / c = a \<longleftrightarrow> b = a * c"
+proof -
+ assume [simp]: "c \<noteq> 0"
+ have "b / c = a \<longleftrightarrow> (b / c) * c = a * c" by simp
+ also have "... \<longleftrightarrow> b = a * c" by (simp add: divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma divide_eq_imp: "c \<noteq> 0 \<Longrightarrow> b = a * c \<Longrightarrow> b / c = a"
+by simp
+
+lemma eq_divide_imp: "c \<noteq> 0 \<Longrightarrow> a * c = b \<Longrightarrow> a = b / c"
+by (erule subst, simp)
+
+lemmas field_eq_simps[noatp] = algebra_simps
+ (* pull / out*)
+ add_divide_eq_iff divide_add_eq_iff
+ diff_divide_eq_iff divide_diff_eq_iff
+ (* multiply eqn *)
+ nonzero_eq_divide_eq nonzero_divide_eq_eq
+(* is added later:
+ times_divide_eq_left times_divide_eq_right
+*)
+
+text{*An example:*}
+lemma "\<lbrakk>a\<noteq>b; c\<noteq>d; e\<noteq>f\<rbrakk> \<Longrightarrow> ((a-b)*(c-d)*(e-f))/((c-d)*(e-f)*(a-b)) = 1"
+apply(subgoal_tac "(c-d)*(e-f)*(a-b) \<noteq> 0")
+ apply(simp add:field_eq_simps)
+apply(simp)
+done
+
+lemma diff_frac_eq:
+ "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y - w / z = (x * z - w * y) / (y * z)"
+by (simp add: field_eq_simps times_divide_eq)
+
+lemma frac_eq_eq:
+ "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> (x / y = w / z) = (x * z = w * y)"
+by (simp add: field_eq_simps times_divide_eq)
+
+end
+
+class division_by_zero = zero + inverse +
+ assumes inverse_zero [simp]: "inverse 0 = 0"
+
+lemma divide_zero [simp]:
+ "a / 0 = (0::'a::{field,division_by_zero})"
+by (simp add: divide_inverse)
+
+lemma divide_self_if [simp]:
+ "a / (a::'a::{field,division_by_zero}) = (if a=0 then 0 else 1)"
+by simp
+
+class linordered_field = field + linordered_idom
+
+lemma inverse_nonzero_iff_nonzero [simp]:
+ "(inverse a = 0) = (a = (0::'a::{division_ring,division_by_zero}))"
+by (force dest: inverse_zero_imp_zero)
+
+lemma inverse_minus_eq [simp]:
+ "inverse(-a) = -inverse(a::'a::{division_ring,division_by_zero})"
+proof cases
+ assume "a=0" thus ?thesis by simp
+next
+ assume "a\<noteq>0"
+ thus ?thesis by (simp add: nonzero_inverse_minus_eq)
+qed
+
+lemma inverse_eq_imp_eq:
+ "inverse a = inverse b ==> a = (b::'a::{division_ring,division_by_zero})"
+apply (cases "a=0 | b=0")
+ apply (force dest!: inverse_zero_imp_zero
+ simp add: eq_commute [of "0::'a"])
+apply (force dest!: nonzero_inverse_eq_imp_eq)
+done
+
+lemma inverse_eq_iff_eq [simp]:
+ "(inverse a = inverse b) = (a = (b::'a::{division_ring,division_by_zero}))"
+by (force dest!: inverse_eq_imp_eq)
+
+lemma inverse_inverse_eq [simp]:
+ "inverse(inverse (a::'a::{division_ring,division_by_zero})) = a"
+ proof cases
+ assume "a=0" thus ?thesis by simp
+ next
+ assume "a\<noteq>0"
+ thus ?thesis by (simp add: nonzero_inverse_inverse_eq)
+ qed
+
+text{*This version builds in division by zero while also re-orienting
+ the right-hand side.*}
+lemma inverse_mult_distrib [simp]:
+ "inverse(a*b) = inverse(a) * inverse(b::'a::{field,division_by_zero})"
+ proof cases
+ assume "a \<noteq> 0 & b \<noteq> 0"
+ thus ?thesis by (simp add: nonzero_inverse_mult_distrib mult_commute)
+ next
+ assume "~ (a \<noteq> 0 & b \<noteq> 0)"
+ thus ?thesis by force
+ qed
+
+lemma inverse_divide [simp]:
+ "inverse (a/b) = b / (a::'a::{field,division_by_zero})"
+by (simp add: divide_inverse mult_commute)
+
+
+subsection {* Calculations with fractions *}
+
+text{* There is a whole bunch of simp-rules just for class @{text
+field} but none for class @{text field} and @{text nonzero_divides}
+because the latter are covered by a simproc. *}
+
+lemma mult_divide_mult_cancel_left:
+ "c\<noteq>0 ==> (c*a) / (c*b) = a / (b::'a::{field,division_by_zero})"
+apply (cases "b = 0")
+apply simp_all
+done
+
+lemma mult_divide_mult_cancel_right:
+ "c\<noteq>0 ==> (a*c) / (b*c) = a / (b::'a::{field,division_by_zero})"
+apply (cases "b = 0")
+apply simp_all
+done
+
+lemma divide_divide_eq_right [simp,noatp]:
+ "a / (b/c) = (a*c) / (b::'a::{field,division_by_zero})"
+by (simp add: divide_inverse mult_ac)
+
+lemma divide_divide_eq_left [simp,noatp]:
+ "(a / b) / (c::'a::{field,division_by_zero}) = a / (b*c)"
+by (simp add: divide_inverse mult_assoc)
+
+
+subsubsection{*Special Cancellation Simprules for Division*}
+
+lemma mult_divide_mult_cancel_left_if[simp,noatp]:
+fixes c :: "'a :: {field,division_by_zero}"
+shows "(c*a) / (c*b) = (if c=0 then 0 else a/b)"
+by (simp add: mult_divide_mult_cancel_left)
+
+
+subsection {* Division and Unary Minus *}
+
+lemma minus_divide_right: "- (a/b) = a / -(b::'a::{field,division_by_zero})"
+by (simp add: divide_inverse)
+
+lemma divide_minus_right [simp, noatp]:
+ "a / -(b::'a::{field,division_by_zero}) = -(a / b)"
+by (simp add: divide_inverse)
+
+lemma minus_divide_divide:
+ "(-a)/(-b) = a / (b::'a::{field,division_by_zero})"
+apply (cases "b=0", simp)
+apply (simp add: nonzero_minus_divide_divide)
+done
+
+lemma eq_divide_eq:
+ "((a::'a::{field,division_by_zero}) = b/c) = (if c\<noteq>0 then a*c = b else a=0)"
+by (simp add: nonzero_eq_divide_eq)
+
+lemma divide_eq_eq:
+ "(b/c = (a::'a::{field,division_by_zero})) = (if c\<noteq>0 then b = a*c else a=0)"
+by (force simp add: nonzero_divide_eq_eq)
+
+
+subsection {* Ordered Fields *}
+
+lemma positive_imp_inverse_positive:
+assumes a_gt_0: "0 < a" shows "0 < inverse (a::'a::linordered_field)"
+proof -
+ have "0 < a * inverse a"
+ by (simp add: a_gt_0 [THEN order_less_imp_not_eq2])
+ thus "0 < inverse a"
+ by (simp add: a_gt_0 [THEN order_less_not_sym] zero_less_mult_iff)
+qed
+
+lemma negative_imp_inverse_negative:
+ "a < 0 ==> inverse a < (0::'a::linordered_field)"
+by (insert positive_imp_inverse_positive [of "-a"],
+ simp add: nonzero_inverse_minus_eq order_less_imp_not_eq)
+
+lemma inverse_le_imp_le:
+assumes invle: "inverse a \<le> inverse b" and apos: "0 < a"
+shows "b \<le> (a::'a::linordered_field)"
+proof (rule classical)
+ assume "~ b \<le> a"
+ hence "a < b" by (simp add: linorder_not_le)
+ hence bpos: "0 < b" by (blast intro: apos order_less_trans)
+ hence "a * inverse a \<le> a * inverse b"
+ by (simp add: apos invle order_less_imp_le mult_left_mono)
+ hence "(a * inverse a) * b \<le> (a * inverse b) * b"
+ by (simp add: bpos order_less_imp_le mult_right_mono)
+ thus "b \<le> a" by (simp add: mult_assoc apos bpos order_less_imp_not_eq2)
+qed
+
+lemma inverse_positive_imp_positive:
+assumes inv_gt_0: "0 < inverse a" and nz: "a \<noteq> 0"
+shows "0 < (a::'a::linordered_field)"
+proof -
+ have "0 < inverse (inverse a)"
+ using inv_gt_0 by (rule positive_imp_inverse_positive)
+ thus "0 < a"
+ using nz by (simp add: nonzero_inverse_inverse_eq)
+qed
+
+lemma inverse_positive_iff_positive [simp]:
+ "(0 < inverse a) = (0 < (a::'a::{linordered_field,division_by_zero}))"
+apply (cases "a = 0", simp)
+apply (blast intro: inverse_positive_imp_positive positive_imp_inverse_positive)
+done
+
+lemma inverse_negative_imp_negative:
+assumes inv_less_0: "inverse a < 0" and nz: "a \<noteq> 0"
+shows "a < (0::'a::linordered_field)"
+proof -
+ have "inverse (inverse a) < 0"
+ using inv_less_0 by (rule negative_imp_inverse_negative)
+ thus "a < 0" using nz by (simp add: nonzero_inverse_inverse_eq)
+qed
+
+lemma inverse_negative_iff_negative [simp]:
+ "(inverse a < 0) = (a < (0::'a::{linordered_field,division_by_zero}))"
+apply (cases "a = 0", simp)
+apply (blast intro: inverse_negative_imp_negative negative_imp_inverse_negative)
+done
+
+lemma inverse_nonnegative_iff_nonnegative [simp]:
+ "(0 \<le> inverse a) = (0 \<le> (a::'a::{linordered_field,division_by_zero}))"
+by (simp add: linorder_not_less [symmetric])
+
+lemma inverse_nonpositive_iff_nonpositive [simp]:
+ "(inverse a \<le> 0) = (a \<le> (0::'a::{linordered_field,division_by_zero}))"
+by (simp add: linorder_not_less [symmetric])
+
+lemma linordered_field_no_lb: "\<forall> x. \<exists>y. y < (x::'a::linordered_field)"
+proof
+ fix x::'a
+ have m1: "- (1::'a) < 0" by simp
+ from add_strict_right_mono[OF m1, where c=x]
+ have "(- 1) + x < x" by simp
+ thus "\<exists>y. y < x" by blast
+qed
+
+lemma linordered_field_no_ub: "\<forall> x. \<exists>y. y > (x::'a::linordered_field)"
+proof
+ fix x::'a
+ have m1: " (1::'a) > 0" by simp
+ from add_strict_right_mono[OF m1, where c=x]
+ have "1 + x > x" by simp
+ thus "\<exists>y. y > x" by blast
+qed
+
+subsection{*Anti-Monotonicity of @{term inverse}*}
+
+lemma less_imp_inverse_less:
+assumes less: "a < b" and apos: "0 < a"
+shows "inverse b < inverse (a::'a::linordered_field)"
+proof (rule ccontr)
+ assume "~ inverse b < inverse a"
+ hence "inverse a \<le> inverse b" by (simp add: linorder_not_less)
+ hence "~ (a < b)"
+ by (simp add: linorder_not_less inverse_le_imp_le [OF _ apos])
+ thus False by (rule notE [OF _ less])
+qed
+
+lemma inverse_less_imp_less:
+ "[|inverse a < inverse b; 0 < a|] ==> b < (a::'a::linordered_field)"
+apply (simp add: order_less_le [of "inverse a"] order_less_le [of "b"])
+apply (force dest!: inverse_le_imp_le nonzero_inverse_eq_imp_eq)
+done
+
+text{*Both premises are essential. Consider -1 and 1.*}
+lemma inverse_less_iff_less [simp,noatp]:
+ "[|0 < a; 0 < b|] ==> (inverse a < inverse b) = (b < (a::'a::linordered_field))"
+by (blast intro: less_imp_inverse_less dest: inverse_less_imp_less)
+
+lemma le_imp_inverse_le:
+ "[|a \<le> b; 0 < a|] ==> inverse b \<le> inverse (a::'a::linordered_field)"
+by (force simp add: order_le_less less_imp_inverse_less)
+
+lemma inverse_le_iff_le [simp,noatp]:
+ "[|0 < a; 0 < b|] ==> (inverse a \<le> inverse b) = (b \<le> (a::'a::linordered_field))"
+by (blast intro: le_imp_inverse_le dest: inverse_le_imp_le)
+
+
+text{*These results refer to both operands being negative. The opposite-sign
+case is trivial, since inverse preserves signs.*}
+lemma inverse_le_imp_le_neg:
+ "[|inverse a \<le> inverse b; b < 0|] ==> b \<le> (a::'a::linordered_field)"
+apply (rule classical)
+apply (subgoal_tac "a < 0")
+ prefer 2 apply (force simp add: linorder_not_le intro: order_less_trans)
+apply (insert inverse_le_imp_le [of "-b" "-a"])
+apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
+done
+
+lemma less_imp_inverse_less_neg:
+ "[|a < b; b < 0|] ==> inverse b < inverse (a::'a::linordered_field)"
+apply (subgoal_tac "a < 0")
+ prefer 2 apply (blast intro: order_less_trans)
+apply (insert less_imp_inverse_less [of "-b" "-a"])
+apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
+done
+
+lemma inverse_less_imp_less_neg:
+ "[|inverse a < inverse b; b < 0|] ==> b < (a::'a::linordered_field)"
+apply (rule classical)
+apply (subgoal_tac "a < 0")
+ prefer 2
+ apply (force simp add: linorder_not_less intro: order_le_less_trans)
+apply (insert inverse_less_imp_less [of "-b" "-a"])
+apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
+done
+
+lemma inverse_less_iff_less_neg [simp,noatp]:
+ "[|a < 0; b < 0|] ==> (inverse a < inverse b) = (b < (a::'a::linordered_field))"
+apply (insert inverse_less_iff_less [of "-b" "-a"])
+apply (simp del: inverse_less_iff_less
+ add: order_less_imp_not_eq nonzero_inverse_minus_eq)
+done
+
+lemma le_imp_inverse_le_neg:
+ "[|a \<le> b; b < 0|] ==> inverse b \<le> inverse (a::'a::linordered_field)"
+by (force simp add: order_le_less less_imp_inverse_less_neg)
+
+lemma inverse_le_iff_le_neg [simp,noatp]:
+ "[|a < 0; b < 0|] ==> (inverse a \<le> inverse b) = (b \<le> (a::'a::linordered_field))"
+by (blast intro: le_imp_inverse_le_neg dest: inverse_le_imp_le_neg)
+
+
+subsection{*Inverses and the Number One*}
+
+lemma one_less_inverse_iff:
+ "(1 < inverse x) = (0 < x & x < (1::'a::{linordered_field,division_by_zero}))"
+proof cases
+ assume "0 < x"
+ with inverse_less_iff_less [OF zero_less_one, of x]
+ show ?thesis by simp
+next
+ assume notless: "~ (0 < x)"
+ have "~ (1 < inverse x)"
+ proof
+ assume "1 < inverse x"
+ also with notless have "... \<le> 0" by (simp add: linorder_not_less)
+ also have "... < 1" by (rule zero_less_one)
+ finally show False by auto
+ qed
+ with notless show ?thesis by simp
+qed
+
+lemma inverse_eq_1_iff [simp]:
+ "(inverse x = 1) = (x = (1::'a::{field,division_by_zero}))"
+by (insert inverse_eq_iff_eq [of x 1], simp)
+
+lemma one_le_inverse_iff:
+ "(1 \<le> inverse x) = (0 < x & x \<le> (1::'a::{linordered_field,division_by_zero}))"
+by (force simp add: order_le_less one_less_inverse_iff)
+
+lemma inverse_less_1_iff:
+ "(inverse x < 1) = (x \<le> 0 | 1 < (x::'a::{linordered_field,division_by_zero}))"
+by (simp add: linorder_not_le [symmetric] one_le_inverse_iff)
+
+lemma inverse_le_1_iff:
+ "(inverse x \<le> 1) = (x \<le> 0 | 1 \<le> (x::'a::{linordered_field,division_by_zero}))"
+by (simp add: linorder_not_less [symmetric] one_less_inverse_iff)
+
+
+subsection{*Simplification of Inequalities Involving Literal Divisors*}
+
+lemma pos_le_divide_eq: "0 < (c::'a::linordered_field) ==> (a \<le> b/c) = (a*c \<le> b)"
+proof -
+ assume less: "0<c"
+ hence "(a \<le> b/c) = (a*c \<le> (b/c)*c)"
+ by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
+ also have "... = (a*c \<le> b)"
+ by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma neg_le_divide_eq: "c < (0::'a::linordered_field) ==> (a \<le> b/c) = (b \<le> a*c)"
+proof -
+ assume less: "c<0"
+ hence "(a \<le> b/c) = ((b/c)*c \<le> a*c)"
+ by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
+ also have "... = (b \<le> a*c)"
+ by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma le_divide_eq:
+ "(a \<le> b/c) =
+ (if 0 < c then a*c \<le> b
+ else if c < 0 then b \<le> a*c
+ else a \<le> (0::'a::{linordered_field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (force simp add: pos_le_divide_eq neg_le_divide_eq linorder_neq_iff)
+done
+
+lemma pos_divide_le_eq: "0 < (c::'a::linordered_field) ==> (b/c \<le> a) = (b \<le> a*c)"
+proof -
+ assume less: "0<c"
+ hence "(b/c \<le> a) = ((b/c)*c \<le> a*c)"
+ by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
+ also have "... = (b \<le> a*c)"
+ by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma neg_divide_le_eq: "c < (0::'a::linordered_field) ==> (b/c \<le> a) = (a*c \<le> b)"
+proof -
+ assume less: "c<0"
+ hence "(b/c \<le> a) = (a*c \<le> (b/c)*c)"
+ by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
+ also have "... = (a*c \<le> b)"
+ by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma divide_le_eq:
+ "(b/c \<le> a) =
+ (if 0 < c then b \<le> a*c
+ else if c < 0 then a*c \<le> b
+ else 0 \<le> (a::'a::{linordered_field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (force simp add: pos_divide_le_eq neg_divide_le_eq linorder_neq_iff)
+done
+
+lemma pos_less_divide_eq:
+ "0 < (c::'a::linordered_field) ==> (a < b/c) = (a*c < b)"
+proof -
+ assume less: "0<c"
+ hence "(a < b/c) = (a*c < (b/c)*c)"
+ by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
+ also have "... = (a*c < b)"
+ by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma neg_less_divide_eq:
+ "c < (0::'a::linordered_field) ==> (a < b/c) = (b < a*c)"
+proof -
+ assume less: "c<0"
+ hence "(a < b/c) = ((b/c)*c < a*c)"
+ by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
+ also have "... = (b < a*c)"
+ by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma less_divide_eq:
+ "(a < b/c) =
+ (if 0 < c then a*c < b
+ else if c < 0 then b < a*c
+ else a < (0::'a::{linordered_field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (force simp add: pos_less_divide_eq neg_less_divide_eq linorder_neq_iff)
+done
+
+lemma pos_divide_less_eq:
+ "0 < (c::'a::linordered_field) ==> (b/c < a) = (b < a*c)"
+proof -
+ assume less: "0<c"
+ hence "(b/c < a) = ((b/c)*c < a*c)"
+ by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
+ also have "... = (b < a*c)"
+ by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma neg_divide_less_eq:
+ "c < (0::'a::linordered_field) ==> (b/c < a) = (a*c < b)"
+proof -
+ assume less: "c<0"
+ hence "(b/c < a) = (a*c < (b/c)*c)"
+ by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
+ also have "... = (a*c < b)"
+ by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
+ finally show ?thesis .
+qed
+
+lemma divide_less_eq:
+ "(b/c < a) =
+ (if 0 < c then b < a*c
+ else if c < 0 then a*c < b
+ else 0 < (a::'a::{linordered_field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (force simp add: pos_divide_less_eq neg_divide_less_eq linorder_neq_iff)
+done
+
+
+subsection{*Field simplification*}
+
+text{* Lemmas @{text field_simps} multiply with denominators in in(equations)
+if they can be proved to be non-zero (for equations) or positive/negative
+(for inequations). Can be too aggressive and is therefore separate from the
+more benign @{text algebra_simps}. *}
+
+lemmas field_simps[noatp] = field_eq_simps
+ (* multiply ineqn *)
+ pos_divide_less_eq neg_divide_less_eq
+ pos_less_divide_eq neg_less_divide_eq
+ pos_divide_le_eq neg_divide_le_eq
+ pos_le_divide_eq neg_le_divide_eq
+
+text{* Lemmas @{text sign_simps} is a first attempt to automate proofs
+of positivity/negativity needed for @{text field_simps}. Have not added @{text
+sign_simps} to @{text field_simps} because the former can lead to case
+explosions. *}
+
+lemmas sign_simps[noatp] = group_simps
+ zero_less_mult_iff mult_less_0_iff
+
+(* Only works once linear arithmetic is installed:
+text{*An example:*}
+lemma fixes a b c d e f :: "'a::linordered_field"
+shows "\<lbrakk>a>b; c<d; e<f; 0 < u \<rbrakk> \<Longrightarrow>
+ ((a-b)*(c-d)*(e-f))/((c-d)*(e-f)*(a-b)) <
+ ((e-f)*(a-b)*(c-d))/((e-f)*(a-b)*(c-d)) + u"
+apply(subgoal_tac "(c-d)*(e-f)*(a-b) > 0")
+ prefer 2 apply(simp add:sign_simps)
+apply(subgoal_tac "(c-d)*(e-f)*(a-b)*u > 0")
+ prefer 2 apply(simp add:sign_simps)
+apply(simp add:field_simps)
+done
+*)
+
+
+subsection{*Division and Signs*}
+
+lemma zero_less_divide_iff:
+ "((0::'a::{linordered_field,division_by_zero}) < a/b) = (0 < a & 0 < b | a < 0 & b < 0)"
+by (simp add: divide_inverse zero_less_mult_iff)
+
+lemma divide_less_0_iff:
+ "(a/b < (0::'a::{linordered_field,division_by_zero})) =
+ (0 < a & b < 0 | a < 0 & 0 < b)"
+by (simp add: divide_inverse mult_less_0_iff)
+
+lemma zero_le_divide_iff:
+ "((0::'a::{linordered_field,division_by_zero}) \<le> a/b) =
+ (0 \<le> a & 0 \<le> b | a \<le> 0 & b \<le> 0)"
+by (simp add: divide_inverse zero_le_mult_iff)
+
+lemma divide_le_0_iff:
+ "(a/b \<le> (0::'a::{linordered_field,division_by_zero})) =
+ (0 \<le> a & b \<le> 0 | a \<le> 0 & 0 \<le> b)"
+by (simp add: divide_inverse mult_le_0_iff)
+
+lemma divide_eq_0_iff [simp,noatp]:
+ "(a/b = 0) = (a=0 | b=(0::'a::{field,division_by_zero}))"
+by (simp add: divide_inverse)
+
+lemma divide_pos_pos:
+ "0 < (x::'a::linordered_field) ==> 0 < y ==> 0 < x / y"
+by(simp add:field_simps)
+
+
+lemma divide_nonneg_pos:
+ "0 <= (x::'a::linordered_field) ==> 0 < y ==> 0 <= x / y"
+by(simp add:field_simps)
+
+lemma divide_neg_pos:
+ "(x::'a::linordered_field) < 0 ==> 0 < y ==> x / y < 0"
+by(simp add:field_simps)
+
+lemma divide_nonpos_pos:
+ "(x::'a::linordered_field) <= 0 ==> 0 < y ==> x / y <= 0"
+by(simp add:field_simps)
+
+lemma divide_pos_neg:
+ "0 < (x::'a::linordered_field) ==> y < 0 ==> x / y < 0"
+by(simp add:field_simps)
+
+lemma divide_nonneg_neg:
+ "0 <= (x::'a::linordered_field) ==> y < 0 ==> x / y <= 0"
+by(simp add:field_simps)
+
+lemma divide_neg_neg:
+ "(x::'a::linordered_field) < 0 ==> y < 0 ==> 0 < x / y"
+by(simp add:field_simps)
+
+lemma divide_nonpos_neg:
+ "(x::'a::linordered_field) <= 0 ==> y < 0 ==> 0 <= x / y"
+by(simp add:field_simps)
+
+
+subsection{*Cancellation Laws for Division*}
+
+lemma divide_cancel_right [simp,noatp]:
+ "(a/c = b/c) = (c = 0 | a = (b::'a::{field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (simp add: divide_inverse)
+done
+
+lemma divide_cancel_left [simp,noatp]:
+ "(c/a = c/b) = (c = 0 | a = (b::'a::{field,division_by_zero}))"
+apply (cases "c=0", simp)
+apply (simp add: divide_inverse)
+done
+
+
+subsection {* Division and the Number One *}
+
+text{*Simplify expressions equated with 1*}
+lemma divide_eq_1_iff [simp,noatp]:
+ "(a/b = 1) = (b \<noteq> 0 & a = (b::'a::{field,division_by_zero}))"
+apply (cases "b=0", simp)
+apply (simp add: right_inverse_eq)
+done
+
+lemma one_eq_divide_iff [simp,noatp]:
+ "(1 = a/b) = (b \<noteq> 0 & a = (b::'a::{field,division_by_zero}))"
+by (simp add: eq_commute [of 1])
+
+lemma zero_eq_1_divide_iff [simp,noatp]:
+ "((0::'a::{linordered_field,division_by_zero}) = 1/a) = (a = 0)"
+apply (cases "a=0", simp)
+apply (auto simp add: nonzero_eq_divide_eq)
+done
+
+lemma one_divide_eq_0_iff [simp,noatp]:
+ "(1/a = (0::'a::{linordered_field,division_by_zero})) = (a = 0)"
+apply (cases "a=0", simp)
+apply (insert zero_neq_one [THEN not_sym])
+apply (auto simp add: nonzero_divide_eq_eq)
+done
+
+text{*Simplify expressions such as @{text "0 < 1/x"} to @{text "0 < x"}*}
+lemmas zero_less_divide_1_iff = zero_less_divide_iff [of 1, simplified]
+lemmas divide_less_0_1_iff = divide_less_0_iff [of 1, simplified]
+lemmas zero_le_divide_1_iff = zero_le_divide_iff [of 1, simplified]
+lemmas divide_le_0_1_iff = divide_le_0_iff [of 1, simplified]
+
+declare zero_less_divide_1_iff [simp,noatp]
+declare divide_less_0_1_iff [simp,noatp]
+declare zero_le_divide_1_iff [simp,noatp]
+declare divide_le_0_1_iff [simp,noatp]
+
+
+subsection {* Ordering Rules for Division *}
+
+lemma divide_strict_right_mono:
+ "[|a < b; 0 < c|] ==> a / c < b / (c::'a::linordered_field)"
+by (simp add: order_less_imp_not_eq2 divide_inverse mult_strict_right_mono
+ positive_imp_inverse_positive)
+
+lemma divide_right_mono:
+ "[|a \<le> b; 0 \<le> c|] ==> a/c \<le> b/(c::'a::{linordered_field,division_by_zero})"
+by (force simp add: divide_strict_right_mono order_le_less)
+
+lemma divide_right_mono_neg: "(a::'a::{division_by_zero,linordered_field}) <= b
+ ==> c <= 0 ==> b / c <= a / c"
+apply (drule divide_right_mono [of _ _ "- c"])
+apply auto
+done
+
+lemma divide_strict_right_mono_neg:
+ "[|b < a; c < 0|] ==> a / c < b / (c::'a::linordered_field)"
+apply (drule divide_strict_right_mono [of _ _ "-c"], simp)
+apply (simp add: order_less_imp_not_eq nonzero_minus_divide_right [symmetric])
+done
+
+text{*The last premise ensures that @{term a} and @{term b}
+ have the same sign*}
+lemma divide_strict_left_mono:
+ "[|b < a; 0 < c; 0 < a*b|] ==> c / a < c / (b::'a::linordered_field)"
+by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_strict_right_mono)
+
+lemma divide_left_mono:
+ "[|b \<le> a; 0 \<le> c; 0 < a*b|] ==> c / a \<le> c / (b::'a::linordered_field)"
+by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_right_mono)
+
+lemma divide_left_mono_neg: "(a::'a::{division_by_zero,linordered_field}) <= b
+ ==> c <= 0 ==> 0 < a * b ==> c / a <= c / b"
+ apply (drule divide_left_mono [of _ _ "- c"])
+ apply (auto simp add: mult_commute)
+done
+
+lemma divide_strict_left_mono_neg:
+ "[|a < b; c < 0; 0 < a*b|] ==> c / a < c / (b::'a::linordered_field)"
+by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_strict_right_mono_neg)
+
+
+text{*Simplify quotients that are compared with the value 1.*}
+
+lemma le_divide_eq_1 [noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(1 \<le> b / a) = ((0 < a & a \<le> b) | (a < 0 & b \<le> a))"
+by (auto simp add: le_divide_eq)
+
+lemma divide_le_eq_1 [noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(b / a \<le> 1) = ((0 < a & b \<le> a) | (a < 0 & a \<le> b) | a=0)"
+by (auto simp add: divide_le_eq)
+
+lemma less_divide_eq_1 [noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(1 < b / a) = ((0 < a & a < b) | (a < 0 & b < a))"
+by (auto simp add: less_divide_eq)
+
+lemma divide_less_eq_1 [noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(b / a < 1) = ((0 < a & b < a) | (a < 0 & a < b) | a=0)"
+by (auto simp add: divide_less_eq)
+
+
+subsection{*Conditional Simplification Rules: No Case Splits*}
+
+lemma le_divide_eq_1_pos [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "0 < a \<Longrightarrow> (1 \<le> b/a) = (a \<le> b)"
+by (auto simp add: le_divide_eq)
+
+lemma le_divide_eq_1_neg [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "a < 0 \<Longrightarrow> (1 \<le> b/a) = (b \<le> a)"
+by (auto simp add: le_divide_eq)
+
+lemma divide_le_eq_1_pos [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "0 < a \<Longrightarrow> (b/a \<le> 1) = (b \<le> a)"
+by (auto simp add: divide_le_eq)
+
+lemma divide_le_eq_1_neg [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "a < 0 \<Longrightarrow> (b/a \<le> 1) = (a \<le> b)"
+by (auto simp add: divide_le_eq)
+
+lemma less_divide_eq_1_pos [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "0 < a \<Longrightarrow> (1 < b/a) = (a < b)"
+by (auto simp add: less_divide_eq)
+
+lemma less_divide_eq_1_neg [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "a < 0 \<Longrightarrow> (1 < b/a) = (b < a)"
+by (auto simp add: less_divide_eq)
+
+lemma divide_less_eq_1_pos [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "0 < a \<Longrightarrow> (b/a < 1) = (b < a)"
+by (auto simp add: divide_less_eq)
+
+lemma divide_less_eq_1_neg [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "a < 0 \<Longrightarrow> b/a < 1 <-> a < b"
+by (auto simp add: divide_less_eq)
+
+lemma eq_divide_eq_1 [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(1 = b/a) = ((a \<noteq> 0 & a = b))"
+by (auto simp add: eq_divide_eq)
+
+lemma divide_eq_eq_1 [simp,noatp]:
+ fixes a :: "'a :: {linordered_field,division_by_zero}"
+ shows "(b/a = 1) = ((a \<noteq> 0 & a = b))"
+by (auto simp add: divide_eq_eq)
+
+
+subsection {* Reasoning about inequalities with division *}
+
+lemma mult_imp_div_pos_le: "0 < (y::'a::linordered_field) ==> x <= z * y ==>
+ x / y <= z"
+by (subst pos_divide_le_eq, assumption+)
+
+lemma mult_imp_le_div_pos: "0 < (y::'a::linordered_field) ==> z * y <= x ==>
+ z <= x / y"
+by(simp add:field_simps)
+
+lemma mult_imp_div_pos_less: "0 < (y::'a::linordered_field) ==> x < z * y ==>
+ x / y < z"
+by(simp add:field_simps)
+
+lemma mult_imp_less_div_pos: "0 < (y::'a::linordered_field) ==> z * y < x ==>
+ z < x / y"
+by(simp add:field_simps)
+
+lemma frac_le: "(0::'a::linordered_field) <= x ==>
+ x <= y ==> 0 < w ==> w <= z ==> x / z <= y / w"
+ apply (rule mult_imp_div_pos_le)
+ apply simp
+ apply (subst times_divide_eq_left)
+ apply (rule mult_imp_le_div_pos, assumption)
+ apply (rule mult_mono)
+ apply simp_all
+done
+
+lemma frac_less: "(0::'a::linordered_field) <= x ==>
+ x < y ==> 0 < w ==> w <= z ==> x / z < y / w"
+ apply (rule mult_imp_div_pos_less)
+ apply simp
+ apply (subst times_divide_eq_left)
+ apply (rule mult_imp_less_div_pos, assumption)
+ apply (erule mult_less_le_imp_less)
+ apply simp_all
+done
+
+lemma frac_less2: "(0::'a::linordered_field) < x ==>
+ x <= y ==> 0 < w ==> w < z ==> x / z < y / w"
+ apply (rule mult_imp_div_pos_less)
+ apply simp_all
+ apply (subst times_divide_eq_left)
+ apply (rule mult_imp_less_div_pos, assumption)
+ apply (erule mult_le_less_imp_less)
+ apply simp_all
+done
+
+text{*It's not obvious whether these should be simprules or not.
+ Their effect is to gather terms into one big fraction, like
+ a*b*c / x*y*z. The rationale for that is unclear, but many proofs
+ seem to need them.*}
+
+declare times_divide_eq [simp]
+
+
+subsection {* Ordered Fields are Dense *}
+
+lemma less_half_sum: "a < b ==> a < (a+b) / (1+1::'a::linordered_field)"
+by (simp add: field_simps zero_less_two)
+
+lemma gt_half_sum: "a < b ==> (a+b)/(1+1::'a::linordered_field) < b"
+by (simp add: field_simps zero_less_two)
+
+instance linordered_field < dense_linorder
+proof
+ fix x y :: 'a
+ have "x < x + 1" by simp
+ then show "\<exists>y. x < y" ..
+ have "x - 1 < x" by simp
+ then show "\<exists>y. y < x" ..
+ show "x < y \<Longrightarrow> \<exists>z>x. z < y" by (blast intro!: less_half_sum gt_half_sum)
+qed
+
+
+subsection {* Absolute Value *}
+
+lemma nonzero_abs_inverse:
+ "a \<noteq> 0 ==> abs (inverse (a::'a::linordered_field)) = inverse (abs a)"
+apply (auto simp add: linorder_neq_iff abs_if nonzero_inverse_minus_eq
+ negative_imp_inverse_negative)
+apply (blast intro: positive_imp_inverse_positive elim: order_less_asym)
+done
+
+lemma abs_inverse [simp]:
+ "abs (inverse (a::'a::{linordered_field,division_by_zero})) =
+ inverse (abs a)"
+apply (cases "a=0", simp)
+apply (simp add: nonzero_abs_inverse)
+done
+
+lemma nonzero_abs_divide:
+ "b \<noteq> 0 ==> abs (a / (b::'a::linordered_field)) = abs a / abs b"
+by (simp add: divide_inverse abs_mult nonzero_abs_inverse)
+
+lemma abs_divide [simp]:
+ "abs (a / (b::'a::{linordered_field,division_by_zero})) = abs a / abs b"
+apply (cases "b=0", simp)
+apply (simp add: nonzero_abs_divide)
+done
+
+lemma abs_div_pos: "(0::'a::{division_by_zero,linordered_field}) < y ==>
+ abs x / y = abs (x / y)"
+ apply (subst abs_divide)
+ apply (simp add: order_less_imp_le)
+done
+
+
+lemma field_le_epsilon:
+ fixes x y :: "'a :: {division_by_zero,linordered_field}"
+ assumes e: "\<And>e. 0 < e \<Longrightarrow> x \<le> y + e"
+ shows "x \<le> y"
+proof (rule ccontr)
+ obtain two :: 'a where two: "two = 1 + 1" by simp
+ assume "\<not> x \<le> y"
+ then have yx: "y < x" by simp
+ then have "y + - y < x + - y" by (rule add_strict_right_mono)
+ then have "x - y > 0" by (simp add: diff_minus)
+ then have "(x - y) / two > 0"
+ by (rule divide_pos_pos) (simp add: two)
+ then have "x \<le> y + (x - y) / two" by (rule e)
+ also have "... = (x - y + two * y) / two"
+ by (simp add: add_divide_distrib two)
+ also have "... = (x + y) / two"
+ by (simp add: two algebra_simps)
+ also have "... < x" using yx
+ by (simp add: two pos_divide_less_eq algebra_simps)
+ finally have "x < x" .
+ then show False ..
+qed
+
+
+code_modulename SML
+ Fields Arith
+
+code_modulename OCaml
+ Fields Arith
+
+code_modulename Haskell
+ Fields Arith
+
+end
--- a/src/HOL/Finite_Set.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Finite_Set.thy Fri Feb 19 15:21:57 2010 +0000
@@ -355,7 +355,7 @@
apply (induct set: finite)
apply simp_all
apply (subst vimage_insert)
- apply (simp add: finite_Un finite_subset [OF inj_vimage_singleton])
+ apply (simp add: finite_subset [OF inj_vimage_singleton])
done
lemma finite_vimageD:
@@ -485,7 +485,7 @@
next
assume "finite A"
thus "finite (Pow A)"
- by induct (simp_all add: finite_UnI finite_imageI Pow_insert)
+ by induct (simp_all add: Pow_insert)
qed
lemma finite_Collect_subsets[simp,intro]: "finite A \<Longrightarrow> finite{B. B \<subseteq> A}"
@@ -634,7 +634,7 @@
from aA obtain k where hkeq: "h k = a" and klessn: "k<n" by (blast elim!: equalityE)
let ?hm = "Fun.swap k m h"
have inj_hm: "inj_on ?hm {i. i < n}" using klessn mlessn
- by (simp add: inj_on_swap_iff inj_on)
+ by (simp add: inj_on)
show ?thesis
proof (intro exI conjI)
show "inj_on ?hm {i. i < m}" using inj_hm
@@ -764,7 +764,7 @@
lemma fold_insert2:
"finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
-by (simp add: fold_insert fold_fun_comm)
+by (simp add: fold_fun_comm)
lemma fold_rec:
assumes "finite A" and "x \<in> A"
@@ -824,13 +824,13 @@
lemma fun_left_comm_idem: "fun_left_comm_idem(op *)"
apply unfold_locales
- apply (simp add: mult_ac)
-apply (simp add: mult_idem mult_assoc[symmetric])
+ apply (rule mult_left_commute)
+apply (rule mult_left_idem)
done
end
-context lower_semilattice
+context semilattice_inf
begin
lemma ab_semigroup_idem_mult_inf: "ab_semigroup_idem_mult inf"
@@ -857,20 +857,20 @@
end
-context upper_semilattice
+context semilattice_sup
begin
lemma ab_semigroup_idem_mult_sup: "ab_semigroup_idem_mult sup"
-by (rule lower_semilattice.ab_semigroup_idem_mult_inf)(rule dual_semilattice)
+by (rule semilattice_inf.ab_semigroup_idem_mult_inf)(rule dual_semilattice)
lemma fold_sup_insert[simp]: "finite A \<Longrightarrow> fold sup b (insert a A) = sup a (fold sup b A)"
-by(rule lower_semilattice.fold_inf_insert)(rule dual_semilattice)
+by(rule semilattice_inf.fold_inf_insert)(rule dual_semilattice)
lemma fold_sup_le_sup: "finite A \<Longrightarrow> ALL a:A. a \<le> b \<Longrightarrow> fold sup c A \<le> sup b c"
-by(rule lower_semilattice.inf_le_fold_inf)(rule dual_semilattice)
+by(rule semilattice_inf.inf_le_fold_inf)(rule dual_semilattice)
lemma sup_le_fold_sup: "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> sup a b \<le> fold sup b A"
-by(rule lower_semilattice.fold_inf_le_inf)(rule dual_semilattice)
+by(rule semilattice_inf.fold_inf_le_inf)(rule dual_semilattice)
end
@@ -1095,13 +1095,16 @@
print_translation {*
let
- fun setsum_tr' [Abs(x,Tx,t), Const ("Collect",_) $ Abs(y,Ty,P)] =
- if x<>y then raise Match
- else let val x' = Syntax.mark_bound x
- val t' = subst_bound(x',t)
- val P' = subst_bound(x',P)
- in Syntax.const "_qsetsum" $ Syntax.mark_bound x $ P' $ t' end
-in [("setsum", setsum_tr')] end
+ fun setsum_tr' [Abs (x, Tx, t), Const (@{const_syntax Collect}, _) $ Abs (y, Ty, P)] =
+ if x <> y then raise Match
+ else
+ let
+ val x' = Syntax.mark_bound x;
+ val t' = subst_bound (x', t);
+ val P' = subst_bound (x', P);
+ in Syntax.const @{syntax_const "_qsetsum"} $ Syntax.mark_bound x $ P' $ t' end
+ | setsum_tr' _ = raise Match;
+in [(@{const_syntax setsum}, setsum_tr')] end
*}
@@ -1363,7 +1366,7 @@
lemma (in comm_monoid_mult) fold_image_1: "finite S \<Longrightarrow> (\<forall>x\<in>S. f x = 1) \<Longrightarrow> fold_image op * f 1 S = 1"
apply (induct set: finite)
- apply simp by (auto simp add: fold_image_insert)
+ apply simp by auto
lemma (in comm_monoid_mult) fold_image_Un_one:
assumes fS: "finite S" and fT: "finite T"
@@ -1409,8 +1412,8 @@
next
case (2 T F)
then have fTF: "finite T" "\<forall>T\<in>F. finite T" "finite F" and TF: "T \<notin> F"
- and H: "setsum f (\<Union> F) = setsum (setsum f) F" by (auto simp add: finite_insert)
- from fTF have fUF: "finite (\<Union>F)" by (auto intro: finite_Union)
+ and H: "setsum f (\<Union> F) = setsum (setsum f) F" by auto
+ from fTF have fUF: "finite (\<Union>F)" by auto
from "2.prems" TF fTF
show ?case
by (auto simp add: H[symmetric] intro: setsum_Un_zero[OF fTF(1) fUF, of f])
@@ -1486,7 +1489,7 @@
qed
lemma setsum_mono:
- assumes le: "\<And>i. i\<in>K \<Longrightarrow> f (i::'a) \<le> ((g i)::('b::{comm_monoid_add, pordered_ab_semigroup_add}))"
+ assumes le: "\<And>i. i\<in>K \<Longrightarrow> f (i::'a) \<le> ((g i)::('b::{comm_monoid_add, ordered_ab_semigroup_add}))"
shows "(\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
proof (cases "finite K")
case True
@@ -1505,7 +1508,7 @@
qed
lemma setsum_strict_mono:
- fixes f :: "'a \<Rightarrow> 'b::{pordered_cancel_ab_semigroup_add,comm_monoid_add}"
+ fixes f :: "'a \<Rightarrow> 'b::{ordered_cancel_ab_semigroup_add,comm_monoid_add}"
assumes "finite A" "A \<noteq> {}"
and "!!x. x:A \<Longrightarrow> f x < g x"
shows "setsum f A < setsum g A"
@@ -1534,7 +1537,7 @@
qed
lemma setsum_nonneg:
- assumes nn: "\<forall>x\<in>A. (0::'a::{pordered_ab_semigroup_add,comm_monoid_add}) \<le> f x"
+ assumes nn: "\<forall>x\<in>A. (0::'a::{ordered_ab_semigroup_add,comm_monoid_add}) \<le> f x"
shows "0 \<le> setsum f A"
proof (cases "finite A")
case True thus ?thesis using nn
@@ -1550,7 +1553,7 @@
qed
lemma setsum_nonpos:
- assumes np: "\<forall>x\<in>A. f x \<le> (0::'a::{pordered_ab_semigroup_add,comm_monoid_add})"
+ assumes np: "\<forall>x\<in>A. f x \<le> (0::'a::{ordered_ab_semigroup_add,comm_monoid_add})"
shows "setsum f A \<le> 0"
proof (cases "finite A")
case True thus ?thesis using np
@@ -1566,7 +1569,7 @@
qed
lemma setsum_mono2:
-fixes f :: "'a \<Rightarrow> 'b :: {pordered_ab_semigroup_add_imp_le,comm_monoid_add}"
+fixes f :: "'a \<Rightarrow> 'b :: {ordered_ab_semigroup_add_imp_le,comm_monoid_add}"
assumes fin: "finite B" and sub: "A \<subseteq> B" and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 0 \<le> f b"
shows "setsum f A \<le> setsum f B"
proof -
@@ -1580,7 +1583,7 @@
lemma setsum_mono3: "finite B ==> A <= B ==>
ALL x: B - A.
- 0 <= ((f x)::'a::{comm_monoid_add,pordered_ab_semigroup_add}) ==>
+ 0 <= ((f x)::'a::{comm_monoid_add,ordered_ab_semigroup_add}) ==>
setsum f A <= setsum f B"
apply (subgoal_tac "setsum f B = setsum f A + setsum f (B - A)")
apply (erule ssubst)
@@ -1640,7 +1643,7 @@
qed
lemma setsum_abs[iff]:
- fixes f :: "'a => ('b::pordered_ab_group_add_abs)"
+ fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
shows "abs (setsum f A) \<le> setsum (%i. abs(f i)) A"
proof (cases "finite A")
case True
@@ -1656,7 +1659,7 @@
qed
lemma setsum_abs_ge_zero[iff]:
- fixes f :: "'a => ('b::pordered_ab_group_add_abs)"
+ fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
shows "0 \<le> setsum (%i. abs(f i)) A"
proof (cases "finite A")
case True
@@ -1671,7 +1674,7 @@
qed
lemma abs_setsum_abs[simp]:
- fixes f :: "'a => ('b::pordered_ab_group_add_abs)"
+ fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
shows "abs (\<Sum>a\<in>A. abs(f a)) = (\<Sum>a\<in>A. abs(f a))"
proof (cases "finite A")
case True
@@ -1946,10 +1949,10 @@
done
lemma setprod_nonneg [rule_format]:
- "(ALL x: A. (0::'a::ordered_semidom) \<le> f x) --> 0 \<le> setprod f A"
+ "(ALL x: A. (0::'a::linordered_semidom) \<le> f x) --> 0 \<le> setprod f A"
by (cases "finite A", induct set: finite, simp_all add: mult_nonneg_nonneg)
-lemma setprod_pos [rule_format]: "(ALL x: A. (0::'a::ordered_semidom) < f x)
+lemma setprod_pos [rule_format]: "(ALL x: A. (0::'a::linordered_semidom) < f x)
--> 0 < setprod f A"
by (cases "finite A", induct set: finite, simp_all add: mult_pos_pos)
@@ -2031,6 +2034,31 @@
apply auto
done
+lemma setprod_mono:
+ fixes f :: "'a \<Rightarrow> 'b\<Colon>linordered_semidom"
+ assumes "\<forall>i\<in>A. 0 \<le> f i \<and> f i \<le> g i"
+ shows "setprod f A \<le> setprod g A"
+proof (cases "finite A")
+ case True
+ hence ?thesis "setprod f A \<ge> 0" using subset_refl[of A]
+ proof (induct A rule: finite_subset_induct)
+ case (insert a F)
+ thus "setprod f (insert a F) \<le> setprod g (insert a F)" "0 \<le> setprod f (insert a F)"
+ unfolding setprod_insert[OF insert(1,3)]
+ using assms[rule_format,OF insert(2)] insert
+ by (auto intro: mult_mono mult_nonneg_nonneg)
+ qed auto
+ thus ?thesis by simp
+qed auto
+
+lemma abs_setprod:
+ fixes f :: "'a \<Rightarrow> 'b\<Colon>{linordered_field,abs}"
+ shows "abs (setprod f A) = setprod (\<lambda>x. abs (f x)) A"
+proof (cases "finite A")
+ case True thus ?thesis
+ by induct (auto simp add: field_simps abs_mult)
+qed auto
+
subsection {* Finite cardinality *}
@@ -2187,7 +2215,7 @@
(\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 --> c1 \<inter> c2 = {}) -->
k * card(C) = card (\<Union> C)"
apply (erule finite_induct, simp)
-apply (simp add: card_insert_disjoint card_Un_disjoint insert_partition
+apply (simp add: card_Un_disjoint insert_partition
finite_subset [of _ "\<Union> (insert x F)"])
done
@@ -2257,7 +2285,7 @@
lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{comm_monoid_mult})) = y^(card A)"
apply (erule finite_induct)
-apply (auto simp add: power_Suc)
+apply auto
done
lemma setprod_gen_delta:
@@ -2289,7 +2317,7 @@
lemma setsum_bounded:
- assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> (K::'a::{semiring_1, pordered_ab_semigroup_add})"
+ assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> (K::'a::{semiring_1, ordered_ab_semigroup_add})"
shows "setsum f A \<le> of_nat(card A) * K"
proof (cases "finite A")
case True
@@ -2342,7 +2370,7 @@
lemma card_image_le: "finite A ==> card (f ` A) <= card A"
apply (induct set: finite)
apply simp
-apply (simp add: le_SucI finite_imageI card_insert_if)
+apply (simp add: le_SucI card_insert_if)
done
lemma card_image: "inj_on f A ==> card (f ` A) = card A"
@@ -2445,7 +2473,7 @@
apply(rotate_tac -1)
apply (induct set: finite, simp_all, clarify)
apply (subst card_Un_disjoint)
- apply (auto simp add: dvd_add disjoint_eq_subset_Compl)
+ apply (auto simp add: disjoint_eq_subset_Compl)
done
@@ -2486,7 +2514,7 @@
ultimately have "finite (UNIV::nat set)"
by (rule finite_imageD)
then show "False"
- by (simp add: infinite_UNIV_nat)
+ by simp
qed
subsection{* A fold functional for non-empty sets *}
@@ -2514,7 +2542,7 @@
lemma fold1Set_sing [iff]: "(fold1Set f {a} b) = (a = b)"
-by (blast intro: fold_graph.intros elim: fold_graph.cases)
+by (blast elim: fold_graph.cases)
lemma fold1_singleton [simp]: "fold1 f {a} = a"
by (unfold fold1_def) blast
@@ -2584,9 +2612,9 @@
apply (best intro: fold_graph_determ theI dest: finite_imp_fold_graph [of _ times])
apply (rule sym, clarify)
apply (case_tac "Aa=A")
- apply (best intro: the_equality fold_graph_determ)
+ apply (best intro: fold_graph_determ)
apply (subgoal_tac "fold_graph times a A x")
- apply (best intro: the_equality fold_graph_determ)
+ apply (best intro: fold_graph_determ)
apply (subgoal_tac "insert aa (Aa - {a}) = A")
prefer 2 apply (blast elim: equalityE)
apply (auto dest: fold_graph_permute_diff [where a=a])
@@ -2630,16 +2658,16 @@
thus ?thesis
proof cases
assume "A' = {}"
- with prems show ?thesis by (simp add: mult_idem)
+ with prems show ?thesis by simp
next
assume "A' \<noteq> {}"
with prems show ?thesis
- by (simp add: fold1_insert mult_assoc [symmetric] mult_idem)
+ by (simp add: fold1_insert mult_assoc [symmetric])
qed
next
assume "a \<noteq> x"
with prems show ?thesis
- by (simp add: insert_commute fold1_eq_fold fold_insert_idem)
+ by (simp add: insert_commute fold1_eq_fold)
qed
qed
@@ -2682,7 +2710,7 @@
text{* Now the recursion rules for definitions: *}
lemma fold1_singleton_def: "g = fold1 f \<Longrightarrow> g {a} = a"
-by(simp add:fold1_singleton)
+by simp
lemma (in ab_semigroup_mult) fold1_insert_def:
"\<lbrakk> g = fold1 times; finite A; x \<notin> A; A \<noteq> {} \<rbrakk> \<Longrightarrow> g (insert x A) = x * g A"
@@ -2791,7 +2819,7 @@
over (non-empty) sets by means of @{text fold1}.
*}
-context lower_semilattice
+context semilattice_inf
begin
lemma below_fold1_iff:
@@ -2859,7 +2887,7 @@
apply(erule exE)
apply(rule order_trans)
apply(erule (1) fold1_belowI)
-apply(erule (1) lower_semilattice.fold1_belowI [OF dual_semilattice])
+apply(erule (1) semilattice_inf.fold1_belowI [OF dual_semilattice])
done
lemma sup_Inf_absorb [simp]:
@@ -2871,7 +2899,7 @@
lemma inf_Sup_absorb [simp]:
"finite A \<Longrightarrow> a \<in> A \<Longrightarrow> inf a (\<Squnion>\<^bsub>fin\<^esub>A) = a"
by (simp add: Sup_fin_def inf_absorb1
- lower_semilattice.fold1_belowI [OF dual_semilattice])
+ semilattice_inf.fold1_belowI [OF dual_semilattice])
end
@@ -2991,7 +3019,7 @@
proof qed (auto simp add: max_def)
lemma max_lattice:
- "lower_semilattice (op \<ge>) (op >) max"
+ "semilattice_inf (op \<ge>) (op >) max"
by (fact min_max.dual_semilattice)
lemma dual_max:
@@ -3158,7 +3186,7 @@
assumes "finite A" and "x \<in> A"
shows "x \<le> Max A"
proof -
- interpret lower_semilattice "op \<ge>" "op >" max
+ interpret semilattice_inf "op \<ge>" "op >" max
by (rule max_lattice)
from assms show ?thesis by (simp add: Max_def fold1_belowI)
qed
@@ -3172,7 +3200,7 @@
assumes "finite A" and "A \<noteq> {}"
shows "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
proof -
- interpret lower_semilattice "op \<ge>" "op >" max
+ interpret semilattice_inf "op \<ge>" "op >" max
by (rule max_lattice)
from assms show ?thesis by (simp add: Max_def below_fold1_iff)
qed
@@ -3293,7 +3321,7 @@
end
-context ordered_ab_semigroup_add
+context linordered_ab_semigroup_add
begin
lemma add_Min_commute:
@@ -3324,6 +3352,19 @@
end
+context linordered_ab_group_add
+begin
+
+lemma minus_Max_eq_Min [simp]:
+ "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - (Max S) = Min (uminus ` S)"
+ by (induct S rule: finite_ne_induct) (simp_all add: minus_max_eq_min)
+
+lemma minus_Min_eq_Max [simp]:
+ "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - (Min S) = Max (uminus ` S)"
+ by (induct S rule: finite_ne_induct) (simp_all add: minus_min_eq_max)
+
+end
+
subsection {* Expressing set operations via @{const fold} *}
@@ -3347,12 +3388,12 @@
proof
qed auto
-lemma (in lower_semilattice) fun_left_comm_idem_inf:
+lemma (in semilattice_inf) fun_left_comm_idem_inf:
"fun_left_comm_idem inf"
proof
qed (auto simp add: inf_left_commute)
-lemma (in upper_semilattice) fun_left_comm_idem_sup:
+lemma (in semilattice_sup) fun_left_comm_idem_sup:
"fun_left_comm_idem sup"
proof
qed (auto simp add: sup_left_commute)
--- a/src/HOL/Fun.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Fun.thy Fri Feb 19 15:21:57 2010 +0000
@@ -387,18 +387,16 @@
"_updbind" :: "['a, 'a] => updbind" ("(2_ :=/ _)")
"" :: "updbind => updbinds" ("_")
"_updbinds":: "[updbind, updbinds] => updbinds" ("_,/ _")
- "_Update" :: "['a, updbinds] => 'a" ("_/'((_)')" [1000,0] 900)
+ "_Update" :: "['a, updbinds] => 'a" ("_/'((_)')" [1000, 0] 900)
translations
- "_Update f (_updbinds b bs)" == "_Update (_Update f b) bs"
- "f(x:=y)" == "fun_upd f x y"
+ "_Update f (_updbinds b bs)" == "_Update (_Update f b) bs"
+ "f(x:=y)" == "CONST fun_upd f x y"
(* Hint: to define the sum of two functions (or maps), use sum_case.
A nice infix syntax could be defined (in Datatype.thy or below) by
-consts
- fun_sum :: "('a => 'c) => ('b => 'c) => (('a+'b) => 'c)" (infixr "'(+')"80)
-translations
- "fun_sum" == sum_case
+notation
+ sum_case (infixr "'(+')"80)
*)
lemma fun_upd_idem_iff: "(f(x:=y) = f) = (f x = y)"
--- a/src/HOL/GCD.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/GCD.thy Fri Feb 19 15:21:57 2010 +0000
@@ -156,7 +156,7 @@
and "x <= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> P (gcd (-x) y)"
and "x <= 0 \<Longrightarrow> y <= 0 \<Longrightarrow> P (gcd (-x) (-y))"
shows "P (gcd x y)"
-by (insert prems, auto simp add: gcd_neg1_int gcd_neg2_int, arith)
+by (insert assms, auto, arith)
lemma gcd_ge_0_int [simp]: "gcd (x::int) y >= 0"
by (simp add: gcd_int_def)
@@ -457,7 +457,7 @@
apply (case_tac "y > 0")
apply (subst gcd_non_0_int, auto)
apply (insert gcd_non_0_int [of "-y" "-x"])
- apply (auto simp add: gcd_neg1_int gcd_neg2_int)
+ apply auto
done
lemma gcd_add1_int [simp]: "gcd ((m::int) + n) n = gcd m n"
@@ -557,7 +557,7 @@
then have dvdgg':"?g * ?g' dvd a" "?g* ?g' dvd b"
by (auto simp add: dvd_mult_div_cancel [OF dvdg(1)]
dvd_mult_div_cancel [OF dvdg(2)] dvd_def)
- have "?g \<noteq> 0" using nz by (simp add: gcd_zero_nat)
+ have "?g \<noteq> 0" using nz by simp
then have gp: "?g > 0" by arith
from gcd_greatest_nat [OF dvdgg'] have "?g * ?g' dvd ?g" .
with dvd_mult_cancel1 [OF gp] show "?g' = 1" by simp
@@ -824,7 +824,7 @@
{assume "?g = 0" with ab n have ?thesis by auto }
moreover
{assume z: "?g \<noteq> 0"
- hence zn: "?g ^ n \<noteq> 0" using n by (simp add: neq0_conv)
+ hence zn: "?g ^ n \<noteq> 0" using n by simp
from gcd_coprime_exists_nat[OF z]
obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'"
by blast
@@ -852,7 +852,7 @@
{assume "?g = 0" with ab n have ?thesis by auto }
moreover
{assume z: "?g \<noteq> 0"
- hence zn: "?g ^ n \<noteq> 0" using n by (simp add: neq0_conv)
+ hence zn: "?g ^ n \<noteq> 0" using n by simp
from gcd_coprime_exists_int[OF z]
obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'"
by blast
@@ -1109,7 +1109,7 @@
(a * x = (a + b) * y + d \<or> (a + b) * x = a * y + d)"
using ex
apply clarsimp
- apply (rule_tac x="d" in exI, simp add: dvd_add)
+ apply (rule_tac x="d" in exI, simp)
apply (case_tac "a * x = b * y + d" , simp_all)
apply (rule_tac x="x + y" in exI)
apply (rule_tac x="y" in exI)
@@ -1124,10 +1124,10 @@
apply(induct a b rule: ind_euclid)
apply blast
apply clarify
- apply (rule_tac x="a" in exI, simp add: dvd_add)
+ apply (rule_tac x="a" in exI, simp)
apply clarsimp
apply (rule_tac x="d" in exI)
- apply (case_tac "a * x = b * y + d", simp_all add: dvd_add)
+ apply (case_tac "a * x = b * y + d", simp_all)
apply (rule_tac x="x+y" in exI)
apply (rule_tac x="y" in exI)
apply algebra
@@ -1445,12 +1445,12 @@
subsubsection {* The complete divisibility lattice *}
-interpretation gcd_semilattice_nat: lower_semilattice "op dvd" "(%m n::nat. m dvd n & ~ n dvd m)" gcd
+interpretation gcd_semilattice_nat: semilattice_inf "op dvd" "(%m n::nat. m dvd n & ~ n dvd m)" gcd
proof
case goal3 thus ?case by(metis gcd_unique_nat)
qed auto
-interpretation lcm_semilattice_nat: upper_semilattice "op dvd" "(%m n::nat. m dvd n & ~ n dvd m)" lcm
+interpretation lcm_semilattice_nat: semilattice_sup "op dvd" "(%m n::nat. m dvd n & ~ n dvd m)" lcm
proof
case goal3 thus ?case by(metis lcm_unique_nat)
qed auto
@@ -1693,8 +1693,7 @@
"inj_on f A \<Longrightarrow> inj_on g B \<Longrightarrow> ALL a:A. ALL b:B. coprime (f a) (g b)
\<Longrightarrow> inj_on (%(a,b). f a * g b::nat) (A \<times> B)"
apply(auto simp add:inj_on_def)
-apply (metis gcd_semilattice_nat.inf_commute coprime_dvd_mult_iff_nat
- dvd.neq_le_trans dvd_triv_left)
+apply (metis coprime_dvd_mult_iff_nat dvd.neq_le_trans dvd_triv_left)
apply (metis gcd_semilattice_nat.inf_commute coprime_dvd_mult_iff_nat
dvd.neq_le_trans dvd_triv_right mult_commute)
done
--- a/src/HOL/Groebner_Basis.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Groebner_Basis.thy Fri Feb 19 15:21:57 2010 +0000
@@ -143,16 +143,16 @@
next show "mul (pwr x p) (pwr x q) = pwr x (p + q)" by (rule mul_pwr)
next show "mul x (pwr x q) = pwr x (Suc q)" using pwr_Suc by simp
next show "mul (pwr x q) x = pwr x (Suc q)" using pwr_Suc mul_c by simp
-next show "mul x x = pwr x 2" by (simp add: nat_number pwr_Suc pwr_0 mul_1 mul_c)
+next show "mul x x = pwr x 2" by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
next show "pwr (mul x y) q = mul (pwr x q) (pwr y q)" by (rule pwr_mul)
next show "pwr (pwr x p) q = pwr x (p * q)" by (rule pwr_pwr)
next show "pwr x 0 = r1" using pwr_0 .
-next show "pwr x 1 = x" unfolding One_nat_def by (simp add: nat_number pwr_Suc pwr_0 mul_1 mul_c)
+next show "pwr x 1 = x" unfolding One_nat_def by (simp add: nat_number' pwr_Suc pwr_0 mul_1 mul_c)
next show "mul x (add y z) = add (mul x y) (mul x z)" using mul_d by simp
next show "pwr x (Suc q) = mul x (pwr x q)" using pwr_Suc by simp
-next show "pwr x (2 * n) = mul (pwr x n) (pwr x n)" by (simp add: nat_number mul_pwr)
+next show "pwr x (2 * n) = mul (pwr x n) (pwr x n)" by (simp add: nat_number' mul_pwr)
next show "pwr x (Suc (2 * n)) = mul x (mul (pwr x n) (pwr x n))"
- by (simp add: nat_number pwr_Suc mul_pwr)
+ by (simp add: nat_number' pwr_Suc mul_pwr)
qed
@@ -165,7 +165,7 @@
interpretation class_semiring: gb_semiring
"op +" "op *" "op ^" "0::'a::{comm_semiring_1}" "1"
- proof qed (auto simp add: algebra_simps power_Suc)
+ proof qed (auto simp add: algebra_simps)
lemmas nat_arith =
add_nat_number_of
@@ -175,7 +175,7 @@
less_nat_number_of
lemma not_iszero_Numeral1: "\<not> iszero (Numeral1::'a::number_ring)"
- by (simp add: numeral_1_eq_1)
+ by simp
lemmas comp_arith =
Let_def arith_simps nat_arith rel_simps neg_simps if_False
@@ -350,7 +350,7 @@
interpretation class_ringb: ringb
"op +" "op *" "op ^" "0::'a::{idom,number_ring}" "1" "op -" "uminus"
-proof(unfold_locales, simp add: algebra_simps power_Suc, auto)
+proof(unfold_locales, simp add: algebra_simps, auto)
fix w x y z ::"'a::{idom,number_ring}"
assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
hence ynz': "y - z \<noteq> 0" by simp
@@ -366,7 +366,7 @@
interpretation natgb: semiringb
"op +" "op *" "op ^" "0::nat" "1"
-proof (unfold_locales, simp add: algebra_simps power_Suc)
+proof (unfold_locales, simp add: algebra_simps)
fix w x y z ::"nat"
{ assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
hence "y < z \<or> y > z" by arith
@@ -375,13 +375,13 @@
then obtain k where kp: "k>0" and yz:"z = y + k" by blast
from p have "(w * y + x *y) + x*k = (w * y + x*y) + w*k" by (simp add: yz algebra_simps)
hence "x*k = w*k" by simp
- hence "w = x" using kp by (simp add: mult_cancel2) }
+ hence "w = x" using kp by simp }
moreover {
assume lt: "y >z" hence "\<exists>k. y = z + k \<and> k>0" by (rule_tac x="y - z" in exI, auto)
then obtain k where kp: "k>0" and yz:"y = z + k" by blast
from p have "(w * z + x *z) + w*k = (w * z + x*z) + x*k" by (simp add: yz algebra_simps)
hence "w*k = x*k" by simp
- hence "w = x" using kp by (simp add: mult_cancel2)}
+ hence "w = x" using kp by simp }
ultimately have "w=x" by blast }
thus "(w * y + x * z = w * z + x * y) = (w = x \<or> y = z)" by auto
qed
@@ -489,7 +489,13 @@
by (simp add: add_divide_distrib)
lemma add_num_frac: "y\<noteq> 0 \<Longrightarrow> z + (x::'a::{field, division_by_zero}) / y = (x + z*y) / y"
by (simp add: add_divide_distrib)
-ML{* let open Conv in fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute})))) (@{thm divide_inverse} RS sym)end*}
+
+ML {*
+let open Conv
+in fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute})))) (@{thm field_divide_inverse} RS sym)
+end
+*}
+
ML{*
local
val zr = @{cpat "0"}
@@ -527,13 +533,13 @@
val (l,r) = Thm.dest_binop ct
val T = ctyp_of_term l
in (case (term_of l, term_of r) of
- (Const(@{const_name Algebras.divide},_)$_$_, _) =>
+ (Const(@{const_name Rings.divide},_)$_$_, _) =>
let val (x,y) = Thm.dest_binop l val z = r
val _ = map (HOLogic.dest_number o term_of) [x,y,z]
val ynz = prove_nz ss T y
in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
end
- | (_, Const (@{const_name Algebras.divide},_)$_$_) =>
+ | (_, Const (@{const_name Rings.divide},_)$_$_) =>
let val (x,y) = Thm.dest_binop r val z = l
val _ = map (HOLogic.dest_number o term_of) [x,y,z]
val ynz = prove_nz ss T y
@@ -543,49 +549,49 @@
end
handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
- fun is_number (Const(@{const_name Algebras.divide},_)$a$b) = is_number a andalso is_number b
+ fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b
| is_number t = can HOLogic.dest_number t
val is_number = is_number o term_of
fun proc3 phi ss ct =
(case term_of ct of
- Const(@{const_name Algebras.less},_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less_eq},_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
in SOME (mk_meta_eq th) end
- | Const("op =",_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ | Const("op =",_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less},_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less_eq},_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
in SOME (mk_meta_eq th) end
- | Const("op =",_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const("op =",_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
@@ -621,16 +627,16 @@
val ths = [@{thm "mult_numeral_1"}, @{thm "mult_numeral_1_right"},
@{thm "divide_Numeral1"},
- @{thm "Ring_and_Field.divide_zero"}, @{thm "divide_Numeral0"},
+ @{thm "Fields.divide_zero"}, @{thm "divide_Numeral0"},
@{thm "divide_divide_eq_left"}, @{thm "mult_frac_frac"},
@{thm "mult_num_frac"}, @{thm "mult_frac_num"},
@{thm "mult_frac_frac"}, @{thm "times_divide_eq_right"},
@{thm "times_divide_eq_left"}, @{thm "divide_divide_eq_right"},
@{thm "diff_def"}, @{thm "minus_divide_left"},
@{thm "Numeral1_eq1_nat"}, @{thm "add_divide_distrib"} RS sym,
- @{thm divide_inverse} RS sym, @{thm inverse_divide},
+ @{thm field_divide_inverse} RS sym, @{thm inverse_divide},
fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute}))))
- (@{thm divide_inverse} RS sym)]
+ (@{thm field_divide_inverse} RS sym)]
val comp_conv = (Simplifier.rewrite
(HOL_basic_ss addsimps @{thms "Groebner_Basis.comp_arith"}
@@ -645,15 +651,15 @@
fun numeral_is_const ct =
case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b =>
+ Const (@{const_name Rings.divide},_) $ a $ b =>
can HOLogic.dest_number a andalso can HOLogic.dest_number b
- | Const (@{const_name Algebras.inverse},_)$t => can HOLogic.dest_number t
+ | Const (@{const_name Rings.inverse},_)$t => can HOLogic.dest_number t
| t => can HOLogic.dest_number t
fun dest_const ct = ((case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b=>
+ Const (@{const_name Rings.divide},_) $ a $ b=>
Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
- | Const (@{const_name Algebras.inverse},_)$t =>
+ | Const (@{const_name Rings.inverse},_)$t =>
Rat.inv (Rat.rat_of_int (snd (HOLogic.dest_number t)))
| t => Rat.rat_of_int (snd (HOLogic.dest_number t)))
handle TERM _ => error "ring_dest_const")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Groups.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,1188 @@
+(* Title: HOL/Groups.thy
+ Author: Gertrud Bauer, Steven Obua, Lawrence C Paulson, Markus Wenzel, Jeremy Avigad
+*)
+
+header {* Groups, also combined with orderings *}
+
+theory Groups
+imports Orderings
+uses "~~/src/Provers/Arith/abel_cancel.ML"
+begin
+
+text {*
+ The theory of partially ordered groups is taken from the books:
+ \begin{itemize}
+ \item \emph{Lattice Theory} by Garret Birkhoff, American Mathematical Society 1979
+ \item \emph{Partially Ordered Algebraic Systems}, Pergamon Press 1963
+ \end{itemize}
+ Most of the used notions can also be looked up in
+ \begin{itemize}
+ \item \url{http://www.mathworld.com} by Eric Weisstein et. al.
+ \item \emph{Algebra I} by van der Waerden, Springer.
+ \end{itemize}
+*}
+
+ML {*
+structure Algebra_Simps = Named_Thms(
+ val name = "algebra_simps"
+ val description = "algebra simplification rules"
+)
+*}
+
+setup Algebra_Simps.setup
+
+text{* The rewrites accumulated in @{text algebra_simps} deal with the
+classical algebraic structures of groups, rings and family. They simplify
+terms by multiplying everything out (in case of a ring) and bringing sums and
+products into a canonical form (by ordered rewriting). As a result it decides
+group and ring equalities but also helps with inequalities.
+
+Of course it also works for fields, but it knows nothing about multiplicative
+inverses or division. This is catered for by @{text field_simps}. *}
+
+
+subsection {* Semigroups and Monoids *}
+
+class semigroup_add = plus +
+ assumes add_assoc [algebra_simps]: "(a + b) + c = a + (b + c)"
+
+sublocale semigroup_add < plus!: semigroup plus proof
+qed (fact add_assoc)
+
+class ab_semigroup_add = semigroup_add +
+ assumes add_commute [algebra_simps]: "a + b = b + a"
+
+sublocale ab_semigroup_add < plus!: abel_semigroup plus proof
+qed (fact add_commute)
+
+context ab_semigroup_add
+begin
+
+lemmas add_left_commute [algebra_simps] = plus.left_commute
+
+theorems add_ac = add_assoc add_commute add_left_commute
+
+end
+
+theorems add_ac = add_assoc add_commute add_left_commute
+
+class semigroup_mult = times +
+ assumes mult_assoc [algebra_simps]: "(a * b) * c = a * (b * c)"
+
+sublocale semigroup_mult < times!: semigroup times proof
+qed (fact mult_assoc)
+
+class ab_semigroup_mult = semigroup_mult +
+ assumes mult_commute [algebra_simps]: "a * b = b * a"
+
+sublocale ab_semigroup_mult < times!: abel_semigroup times proof
+qed (fact mult_commute)
+
+context ab_semigroup_mult
+begin
+
+lemmas mult_left_commute [algebra_simps] = times.left_commute
+
+theorems mult_ac = mult_assoc mult_commute mult_left_commute
+
+end
+
+theorems mult_ac = mult_assoc mult_commute mult_left_commute
+
+class ab_semigroup_idem_mult = ab_semigroup_mult +
+ assumes mult_idem: "x * x = x"
+
+sublocale ab_semigroup_idem_mult < times!: semilattice times proof
+qed (fact mult_idem)
+
+context ab_semigroup_idem_mult
+begin
+
+lemmas mult_left_idem = times.left_idem
+
+end
+
+class monoid_add = zero + semigroup_add +
+ assumes add_0_left [simp]: "0 + a = a"
+ and add_0_right [simp]: "a + 0 = a"
+
+lemma zero_reorient: "0 = x \<longleftrightarrow> x = 0"
+by (rule eq_commute)
+
+class comm_monoid_add = zero + ab_semigroup_add +
+ assumes add_0: "0 + a = a"
+begin
+
+subclass monoid_add
+ proof qed (insert add_0, simp_all add: add_commute)
+
+end
+
+class monoid_mult = one + semigroup_mult +
+ assumes mult_1_left [simp]: "1 * a = a"
+ assumes mult_1_right [simp]: "a * 1 = a"
+
+lemma one_reorient: "1 = x \<longleftrightarrow> x = 1"
+by (rule eq_commute)
+
+class comm_monoid_mult = one + ab_semigroup_mult +
+ assumes mult_1: "1 * a = a"
+begin
+
+subclass monoid_mult
+ proof qed (insert mult_1, simp_all add: mult_commute)
+
+end
+
+class cancel_semigroup_add = semigroup_add +
+ assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
+ assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"
+begin
+
+lemma add_left_cancel [simp]:
+ "a + b = a + c \<longleftrightarrow> b = c"
+by (blast dest: add_left_imp_eq)
+
+lemma add_right_cancel [simp]:
+ "b + a = c + a \<longleftrightarrow> b = c"
+by (blast dest: add_right_imp_eq)
+
+end
+
+class cancel_ab_semigroup_add = ab_semigroup_add +
+ assumes add_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
+begin
+
+subclass cancel_semigroup_add
+proof
+ fix a b c :: 'a
+ assume "a + b = a + c"
+ then show "b = c" by (rule add_imp_eq)
+next
+ fix a b c :: 'a
+ assume "b + a = c + a"
+ then have "a + b = a + c" by (simp only: add_commute)
+ then show "b = c" by (rule add_imp_eq)
+qed
+
+end
+
+class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add
+
+
+subsection {* Groups *}
+
+class group_add = minus + uminus + monoid_add +
+ assumes left_minus [simp]: "- a + a = 0"
+ assumes diff_minus: "a - b = a + (- b)"
+begin
+
+lemma minus_unique:
+ assumes "a + b = 0" shows "- a = b"
+proof -
+ have "- a = - a + (a + b)" using assms by simp
+ also have "\<dots> = b" by (simp add: add_assoc [symmetric])
+ finally show ?thesis .
+qed
+
+lemmas equals_zero_I = minus_unique (* legacy name *)
+
+lemma minus_zero [simp]: "- 0 = 0"
+proof -
+ have "0 + 0 = 0" by (rule add_0_right)
+ thus "- 0 = 0" by (rule minus_unique)
+qed
+
+lemma minus_minus [simp]: "- (- a) = a"
+proof -
+ have "- a + a = 0" by (rule left_minus)
+ thus "- (- a) = a" by (rule minus_unique)
+qed
+
+lemma right_minus [simp]: "a + - a = 0"
+proof -
+ have "a + - a = - (- a) + - a" by simp
+ also have "\<dots> = 0" by (rule left_minus)
+ finally show ?thesis .
+qed
+
+lemma minus_add_cancel: "- a + (a + b) = b"
+by (simp add: add_assoc [symmetric])
+
+lemma add_minus_cancel: "a + (- a + b) = b"
+by (simp add: add_assoc [symmetric])
+
+lemma minus_add: "- (a + b) = - b + - a"
+proof -
+ have "(a + b) + (- b + - a) = 0"
+ by (simp add: add_assoc add_minus_cancel)
+ thus "- (a + b) = - b + - a"
+ by (rule minus_unique)
+qed
+
+lemma right_minus_eq: "a - b = 0 \<longleftrightarrow> a = b"
+proof
+ assume "a - b = 0"
+ have "a = (a - b) + b" by (simp add:diff_minus add_assoc)
+ also have "\<dots> = b" using `a - b = 0` by simp
+ finally show "a = b" .
+next
+ assume "a = b" thus "a - b = 0" by (simp add: diff_minus)
+qed
+
+lemma diff_self [simp]: "a - a = 0"
+by (simp add: diff_minus)
+
+lemma diff_0 [simp]: "0 - a = - a"
+by (simp add: diff_minus)
+
+lemma diff_0_right [simp]: "a - 0 = a"
+by (simp add: diff_minus)
+
+lemma diff_minus_eq_add [simp]: "a - - b = a + b"
+by (simp add: diff_minus)
+
+lemma neg_equal_iff_equal [simp]:
+ "- a = - b \<longleftrightarrow> a = b"
+proof
+ assume "- a = - b"
+ hence "- (- a) = - (- b)" by simp
+ thus "a = b" by simp
+next
+ assume "a = b"
+ thus "- a = - b" by simp
+qed
+
+lemma neg_equal_0_iff_equal [simp]:
+ "- a = 0 \<longleftrightarrow> a = 0"
+by (subst neg_equal_iff_equal [symmetric], simp)
+
+lemma neg_0_equal_iff_equal [simp]:
+ "0 = - a \<longleftrightarrow> 0 = a"
+by (subst neg_equal_iff_equal [symmetric], simp)
+
+text{*The next two equations can make the simplifier loop!*}
+
+lemma equation_minus_iff:
+ "a = - b \<longleftrightarrow> b = - a"
+proof -
+ have "- (- a) = - b \<longleftrightarrow> - a = b" by (rule neg_equal_iff_equal)
+ thus ?thesis by (simp add: eq_commute)
+qed
+
+lemma minus_equation_iff:
+ "- a = b \<longleftrightarrow> - b = a"
+proof -
+ have "- a = - (- b) \<longleftrightarrow> a = -b" by (rule neg_equal_iff_equal)
+ thus ?thesis by (simp add: eq_commute)
+qed
+
+lemma diff_add_cancel: "a - b + b = a"
+by (simp add: diff_minus add_assoc)
+
+lemma add_diff_cancel: "a + b - b = a"
+by (simp add: diff_minus add_assoc)
+
+declare diff_minus[symmetric, algebra_simps]
+
+lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
+proof
+ assume "a = - b" then show "a + b = 0" by simp
+next
+ assume "a + b = 0"
+ moreover have "a + (b + - b) = (a + b) + - b"
+ by (simp only: add_assoc)
+ ultimately show "a = - b" by simp
+qed
+
+end
+
+class ab_group_add = minus + uminus + comm_monoid_add +
+ assumes ab_left_minus: "- a + a = 0"
+ assumes ab_diff_minus: "a - b = a + (- b)"
+begin
+
+subclass group_add
+ proof qed (simp_all add: ab_left_minus ab_diff_minus)
+
+subclass cancel_comm_monoid_add
+proof
+ fix a b c :: 'a
+ assume "a + b = a + c"
+ then have "- a + a + b = - a + a + c"
+ unfolding add_assoc by simp
+ then show "b = c" by simp
+qed
+
+lemma uminus_add_conv_diff[algebra_simps]:
+ "- a + b = b - a"
+by (simp add:diff_minus add_commute)
+
+lemma minus_add_distrib [simp]:
+ "- (a + b) = - a + - b"
+by (rule minus_unique) (simp add: add_ac)
+
+lemma minus_diff_eq [simp]:
+ "- (a - b) = b - a"
+by (simp add: diff_minus add_commute)
+
+lemma add_diff_eq[algebra_simps]: "a + (b - c) = (a + b) - c"
+by (simp add: diff_minus add_ac)
+
+lemma diff_add_eq[algebra_simps]: "(a - b) + c = (a + c) - b"
+by (simp add: diff_minus add_ac)
+
+lemma diff_eq_eq[algebra_simps]: "a - b = c \<longleftrightarrow> a = c + b"
+by (auto simp add: diff_minus add_assoc)
+
+lemma eq_diff_eq[algebra_simps]: "a = c - b \<longleftrightarrow> a + b = c"
+by (auto simp add: diff_minus add_assoc)
+
+lemma diff_diff_eq[algebra_simps]: "(a - b) - c = a - (b + c)"
+by (simp add: diff_minus add_ac)
+
+lemma diff_diff_eq2[algebra_simps]: "a - (b - c) = (a + c) - b"
+by (simp add: diff_minus add_ac)
+
+lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
+by (simp add: algebra_simps)
+
+(* FIXME: duplicates right_minus_eq from class group_add *)
+(* but only this one is declared as a simp rule. *)
+lemma diff_eq_0_iff_eq [simp, noatp]: "a - b = 0 \<longleftrightarrow> a = b"
+by (simp add: algebra_simps)
+
+end
+
+subsection {* (Partially) Ordered Groups *}
+
+class ordered_ab_semigroup_add = order + ab_semigroup_add +
+ assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
+begin
+
+lemma add_right_mono:
+ "a \<le> b \<Longrightarrow> a + c \<le> b + c"
+by (simp add: add_commute [of _ c] add_left_mono)
+
+text {* non-strict, in both arguments *}
+lemma add_mono:
+ "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
+ apply (erule add_right_mono [THEN order_trans])
+ apply (simp add: add_commute add_left_mono)
+ done
+
+end
+
+class ordered_cancel_ab_semigroup_add =
+ ordered_ab_semigroup_add + cancel_ab_semigroup_add
+begin
+
+lemma add_strict_left_mono:
+ "a < b \<Longrightarrow> c + a < c + b"
+by (auto simp add: less_le add_left_mono)
+
+lemma add_strict_right_mono:
+ "a < b \<Longrightarrow> a + c < b + c"
+by (simp add: add_commute [of _ c] add_strict_left_mono)
+
+text{*Strict monotonicity in both arguments*}
+lemma add_strict_mono:
+ "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
+apply (erule add_strict_right_mono [THEN less_trans])
+apply (erule add_strict_left_mono)
+done
+
+lemma add_less_le_mono:
+ "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
+apply (erule add_strict_right_mono [THEN less_le_trans])
+apply (erule add_left_mono)
+done
+
+lemma add_le_less_mono:
+ "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
+apply (erule add_right_mono [THEN le_less_trans])
+apply (erule add_strict_left_mono)
+done
+
+end
+
+class ordered_ab_semigroup_add_imp_le =
+ ordered_cancel_ab_semigroup_add +
+ assumes add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
+begin
+
+lemma add_less_imp_less_left:
+ assumes less: "c + a < c + b" shows "a < b"
+proof -
+ from less have le: "c + a <= c + b" by (simp add: order_le_less)
+ have "a <= b"
+ apply (insert le)
+ apply (drule add_le_imp_le_left)
+ by (insert le, drule add_le_imp_le_left, assumption)
+ moreover have "a \<noteq> b"
+ proof (rule ccontr)
+ assume "~(a \<noteq> b)"
+ then have "a = b" by simp
+ then have "c + a = c + b" by simp
+ with less show "False"by simp
+ qed
+ ultimately show "a < b" by (simp add: order_le_less)
+qed
+
+lemma add_less_imp_less_right:
+ "a + c < b + c \<Longrightarrow> a < b"
+apply (rule add_less_imp_less_left [of c])
+apply (simp add: add_commute)
+done
+
+lemma add_less_cancel_left [simp]:
+ "c + a < c + b \<longleftrightarrow> a < b"
+by (blast intro: add_less_imp_less_left add_strict_left_mono)
+
+lemma add_less_cancel_right [simp]:
+ "a + c < b + c \<longleftrightarrow> a < b"
+by (blast intro: add_less_imp_less_right add_strict_right_mono)
+
+lemma add_le_cancel_left [simp]:
+ "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
+by (auto, drule add_le_imp_le_left, simp_all add: add_left_mono)
+
+lemma add_le_cancel_right [simp]:
+ "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
+by (simp add: add_commute [of a c] add_commute [of b c])
+
+lemma add_le_imp_le_right:
+ "a + c \<le> b + c \<Longrightarrow> a \<le> b"
+by simp
+
+lemma max_add_distrib_left:
+ "max x y + z = max (x + z) (y + z)"
+ unfolding max_def by auto
+
+lemma min_add_distrib_left:
+ "min x y + z = min (x + z) (y + z)"
+ unfolding min_def by auto
+
+end
+
+subsection {* Support for reasoning about signs *}
+
+class ordered_comm_monoid_add =
+ ordered_cancel_ab_semigroup_add + comm_monoid_add
+begin
+
+lemma add_pos_nonneg:
+ assumes "0 < a" and "0 \<le> b" shows "0 < a + b"
+proof -
+ have "0 + 0 < a + b"
+ using assms by (rule add_less_le_mono)
+ then show ?thesis by simp
+qed
+
+lemma add_pos_pos:
+ assumes "0 < a" and "0 < b" shows "0 < a + b"
+by (rule add_pos_nonneg) (insert assms, auto)
+
+lemma add_nonneg_pos:
+ assumes "0 \<le> a" and "0 < b" shows "0 < a + b"
+proof -
+ have "0 + 0 < a + b"
+ using assms by (rule add_le_less_mono)
+ then show ?thesis by simp
+qed
+
+lemma add_nonneg_nonneg:
+ assumes "0 \<le> a" and "0 \<le> b" shows "0 \<le> a + b"
+proof -
+ have "0 + 0 \<le> a + b"
+ using assms by (rule add_mono)
+ then show ?thesis by simp
+qed
+
+lemma add_neg_nonpos:
+ assumes "a < 0" and "b \<le> 0" shows "a + b < 0"
+proof -
+ have "a + b < 0 + 0"
+ using assms by (rule add_less_le_mono)
+ then show ?thesis by simp
+qed
+
+lemma add_neg_neg:
+ assumes "a < 0" and "b < 0" shows "a + b < 0"
+by (rule add_neg_nonpos) (insert assms, auto)
+
+lemma add_nonpos_neg:
+ assumes "a \<le> 0" and "b < 0" shows "a + b < 0"
+proof -
+ have "a + b < 0 + 0"
+ using assms by (rule add_le_less_mono)
+ then show ?thesis by simp
+qed
+
+lemma add_nonpos_nonpos:
+ assumes "a \<le> 0" and "b \<le> 0" shows "a + b \<le> 0"
+proof -
+ have "a + b \<le> 0 + 0"
+ using assms by (rule add_mono)
+ then show ?thesis by simp
+qed
+
+lemmas add_sign_intros =
+ add_pos_nonneg add_pos_pos add_nonneg_pos add_nonneg_nonneg
+ add_neg_nonpos add_neg_neg add_nonpos_neg add_nonpos_nonpos
+
+lemma add_nonneg_eq_0_iff:
+ assumes x: "0 \<le> x" and y: "0 \<le> y"
+ shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+proof (intro iffI conjI)
+ have "x = x + 0" by simp
+ also have "x + 0 \<le> x + y" using y by (rule add_left_mono)
+ also assume "x + y = 0"
+ also have "0 \<le> x" using x .
+ finally show "x = 0" .
+next
+ have "y = 0 + y" by simp
+ also have "0 + y \<le> x + y" using x by (rule add_right_mono)
+ also assume "x + y = 0"
+ also have "0 \<le> y" using y .
+ finally show "y = 0" .
+next
+ assume "x = 0 \<and> y = 0"
+ then show "x + y = 0" by simp
+qed
+
+end
+
+class ordered_ab_group_add =
+ ab_group_add + ordered_ab_semigroup_add
+begin
+
+subclass ordered_cancel_ab_semigroup_add ..
+
+subclass ordered_ab_semigroup_add_imp_le
+proof
+ fix a b c :: 'a
+ assume "c + a \<le> c + b"
+ hence "(-c) + (c + a) \<le> (-c) + (c + b)" by (rule add_left_mono)
+ hence "((-c) + c) + a \<le> ((-c) + c) + b" by (simp only: add_assoc)
+ thus "a \<le> b" by simp
+qed
+
+subclass ordered_comm_monoid_add ..
+
+lemma max_diff_distrib_left:
+ shows "max x y - z = max (x - z) (y - z)"
+by (simp add: diff_minus, rule max_add_distrib_left)
+
+lemma min_diff_distrib_left:
+ shows "min x y - z = min (x - z) (y - z)"
+by (simp add: diff_minus, rule min_add_distrib_left)
+
+lemma le_imp_neg_le:
+ assumes "a \<le> b" shows "-b \<le> -a"
+proof -
+ have "-a+a \<le> -a+b" using `a \<le> b` by (rule add_left_mono)
+ hence "0 \<le> -a+b" by simp
+ hence "0 + (-b) \<le> (-a + b) + (-b)" by (rule add_right_mono)
+ thus ?thesis by (simp add: add_assoc)
+qed
+
+lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
+proof
+ assume "- b \<le> - a"
+ hence "- (- a) \<le> - (- b)" by (rule le_imp_neg_le)
+ thus "a\<le>b" by simp
+next
+ assume "a\<le>b"
+ thus "-b \<le> -a" by (rule le_imp_neg_le)
+qed
+
+lemma neg_le_0_iff_le [simp]: "- a \<le> 0 \<longleftrightarrow> 0 \<le> a"
+by (subst neg_le_iff_le [symmetric], simp)
+
+lemma neg_0_le_iff_le [simp]: "0 \<le> - a \<longleftrightarrow> a \<le> 0"
+by (subst neg_le_iff_le [symmetric], simp)
+
+lemma neg_less_iff_less [simp]: "- b < - a \<longleftrightarrow> a < b"
+by (force simp add: less_le)
+
+lemma neg_less_0_iff_less [simp]: "- a < 0 \<longleftrightarrow> 0 < a"
+by (subst neg_less_iff_less [symmetric], simp)
+
+lemma neg_0_less_iff_less [simp]: "0 < - a \<longleftrightarrow> a < 0"
+by (subst neg_less_iff_less [symmetric], simp)
+
+text{*The next several equations can make the simplifier loop!*}
+
+lemma less_minus_iff: "a < - b \<longleftrightarrow> b < - a"
+proof -
+ have "(- (-a) < - b) = (b < - a)" by (rule neg_less_iff_less)
+ thus ?thesis by simp
+qed
+
+lemma minus_less_iff: "- a < b \<longleftrightarrow> - b < a"
+proof -
+ have "(- a < - (-b)) = (- b < a)" by (rule neg_less_iff_less)
+ thus ?thesis by simp
+qed
+
+lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
+proof -
+ have mm: "!! a (b::'a). (-(-a)) < -b \<Longrightarrow> -(-b) < -a" by (simp only: minus_less_iff)
+ have "(- (- a) <= -b) = (b <= - a)"
+ apply (auto simp only: le_less)
+ apply (drule mm)
+ apply (simp_all)
+ apply (drule mm[simplified], assumption)
+ done
+ then show ?thesis by simp
+qed
+
+lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
+by (auto simp add: le_less minus_less_iff)
+
+lemma less_iff_diff_less_0: "a < b \<longleftrightarrow> a - b < 0"
+proof -
+ have "(a < b) = (a + (- b) < b + (-b))"
+ by (simp only: add_less_cancel_right)
+ also have "... = (a - b < 0)" by (simp add: diff_minus)
+ finally show ?thesis .
+qed
+
+lemma diff_less_eq[algebra_simps]: "a - b < c \<longleftrightarrow> a < c + b"
+apply (subst less_iff_diff_less_0 [of a])
+apply (rule less_iff_diff_less_0 [of _ c, THEN ssubst])
+apply (simp add: diff_minus add_ac)
+done
+
+lemma less_diff_eq[algebra_simps]: "a < c - b \<longleftrightarrow> a + b < c"
+apply (subst less_iff_diff_less_0 [of "plus a b"])
+apply (subst less_iff_diff_less_0 [of a])
+apply (simp add: diff_minus add_ac)
+done
+
+lemma diff_le_eq[algebra_simps]: "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
+by (auto simp add: le_less diff_less_eq diff_add_cancel add_diff_cancel)
+
+lemma le_diff_eq[algebra_simps]: "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
+by (auto simp add: le_less less_diff_eq diff_add_cancel add_diff_cancel)
+
+lemma le_iff_diff_le_0: "a \<le> b \<longleftrightarrow> a - b \<le> 0"
+by (simp add: algebra_simps)
+
+text{*Legacy - use @{text algebra_simps} *}
+lemmas group_simps[noatp] = algebra_simps
+
+end
+
+text{*Legacy - use @{text algebra_simps} *}
+lemmas group_simps[noatp] = algebra_simps
+
+class linordered_ab_semigroup_add =
+ linorder + ordered_ab_semigroup_add
+
+class linordered_cancel_ab_semigroup_add =
+ linorder + ordered_cancel_ab_semigroup_add
+begin
+
+subclass linordered_ab_semigroup_add ..
+
+subclass ordered_ab_semigroup_add_imp_le
+proof
+ fix a b c :: 'a
+ assume le: "c + a <= c + b"
+ show "a <= b"
+ proof (rule ccontr)
+ assume w: "~ a \<le> b"
+ hence "b <= a" by (simp add: linorder_not_le)
+ hence le2: "c + b <= c + a" by (rule add_left_mono)
+ have "a = b"
+ apply (insert le)
+ apply (insert le2)
+ apply (drule antisym, simp_all)
+ done
+ with w show False
+ by (simp add: linorder_not_le [symmetric])
+ qed
+qed
+
+end
+
+class linordered_ab_group_add = linorder + ordered_ab_group_add
+begin
+
+subclass linordered_cancel_ab_semigroup_add ..
+
+lemma neg_less_eq_nonneg [simp]:
+ "- a \<le> a \<longleftrightarrow> 0 \<le> a"
+proof
+ assume A: "- a \<le> a" show "0 \<le> a"
+ proof (rule classical)
+ assume "\<not> 0 \<le> a"
+ then have "a < 0" by auto
+ with A have "- a < 0" by (rule le_less_trans)
+ then show ?thesis by auto
+ qed
+next
+ assume A: "0 \<le> a" show "- a \<le> a"
+ proof (rule order_trans)
+ show "- a \<le> 0" using A by (simp add: minus_le_iff)
+ next
+ show "0 \<le> a" using A .
+ qed
+qed
+
+lemma neg_less_nonneg [simp]:
+ "- a < a \<longleftrightarrow> 0 < a"
+proof
+ assume A: "- a < a" show "0 < a"
+ proof (rule classical)
+ assume "\<not> 0 < a"
+ then have "a \<le> 0" by auto
+ with A have "- a < 0" by (rule less_le_trans)
+ then show ?thesis by auto
+ qed
+next
+ assume A: "0 < a" show "- a < a"
+ proof (rule less_trans)
+ show "- a < 0" using A by (simp add: minus_le_iff)
+ next
+ show "0 < a" using A .
+ qed
+qed
+
+lemma less_eq_neg_nonpos [simp]:
+ "a \<le> - a \<longleftrightarrow> a \<le> 0"
+proof
+ assume A: "a \<le> - a" show "a \<le> 0"
+ proof (rule classical)
+ assume "\<not> a \<le> 0"
+ then have "0 < a" by auto
+ then have "0 < - a" using A by (rule less_le_trans)
+ then show ?thesis by auto
+ qed
+next
+ assume A: "a \<le> 0" show "a \<le> - a"
+ proof (rule order_trans)
+ show "0 \<le> - a" using A by (simp add: minus_le_iff)
+ next
+ show "a \<le> 0" using A .
+ qed
+qed
+
+lemma equal_neg_zero [simp]:
+ "a = - a \<longleftrightarrow> a = 0"
+proof
+ assume "a = 0" then show "a = - a" by simp
+next
+ assume A: "a = - a" show "a = 0"
+ proof (cases "0 \<le> a")
+ case True with A have "0 \<le> - a" by auto
+ with le_minus_iff have "a \<le> 0" by simp
+ with True show ?thesis by (auto intro: order_trans)
+ next
+ case False then have B: "a \<le> 0" by auto
+ with A have "- a \<le> 0" by auto
+ with B show ?thesis by (auto intro: order_trans)
+ qed
+qed
+
+lemma neg_equal_zero [simp]:
+ "- a = a \<longleftrightarrow> a = 0"
+ by (auto dest: sym)
+
+lemma double_zero [simp]:
+ "a + a = 0 \<longleftrightarrow> a = 0"
+proof
+ assume assm: "a + a = 0"
+ then have a: "- a = a" by (rule minus_unique)
+ then show "a = 0" by (simp only: neg_equal_zero)
+qed simp
+
+lemma double_zero_sym [simp]:
+ "0 = a + a \<longleftrightarrow> a = 0"
+ by (rule, drule sym) simp_all
+
+lemma zero_less_double_add_iff_zero_less_single_add [simp]:
+ "0 < a + a \<longleftrightarrow> 0 < a"
+proof
+ assume "0 < a + a"
+ then have "0 - a < a" by (simp only: diff_less_eq)
+ then have "- a < a" by simp
+ then show "0 < a" by (simp only: neg_less_nonneg)
+next
+ assume "0 < a"
+ with this have "0 + 0 < a + a"
+ by (rule add_strict_mono)
+ then show "0 < a + a" by simp
+qed
+
+lemma zero_le_double_add_iff_zero_le_single_add [simp]:
+ "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
+ by (auto simp add: le_less)
+
+lemma double_add_less_zero_iff_single_add_less_zero [simp]:
+ "a + a < 0 \<longleftrightarrow> a < 0"
+proof -
+ have "\<not> a + a < 0 \<longleftrightarrow> \<not> a < 0"
+ by (simp add: not_less)
+ then show ?thesis by simp
+qed
+
+lemma double_add_le_zero_iff_single_add_le_zero [simp]:
+ "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
+proof -
+ have "\<not> a + a \<le> 0 \<longleftrightarrow> \<not> a \<le> 0"
+ by (simp add: not_le)
+ then show ?thesis by simp
+qed
+
+lemma le_minus_self_iff:
+ "a \<le> - a \<longleftrightarrow> a \<le> 0"
+proof -
+ from add_le_cancel_left [of "- a" "a + a" 0]
+ have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
+ by (simp add: add_assoc [symmetric])
+ thus ?thesis by simp
+qed
+
+lemma minus_le_self_iff:
+ "- a \<le> a \<longleftrightarrow> 0 \<le> a"
+proof -
+ from add_le_cancel_left [of "- a" 0 "a + a"]
+ have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
+ by (simp add: add_assoc [symmetric])
+ thus ?thesis by simp
+qed
+
+lemma minus_max_eq_min:
+ "- max x y = min (-x) (-y)"
+ by (auto simp add: max_def min_def)
+
+lemma minus_min_eq_max:
+ "- min x y = max (-x) (-y)"
+ by (auto simp add: max_def min_def)
+
+end
+
+-- {* FIXME localize the following *}
+
+lemma add_increasing:
+ fixes c :: "'a::{ordered_ab_semigroup_add_imp_le, comm_monoid_add}"
+ shows "[|0\<le>a; b\<le>c|] ==> b \<le> a + c"
+by (insert add_mono [of 0 a b c], simp)
+
+lemma add_increasing2:
+ fixes c :: "'a::{ordered_ab_semigroup_add_imp_le, comm_monoid_add}"
+ shows "[|0\<le>c; b\<le>a|] ==> b \<le> a + c"
+by (simp add:add_increasing add_commute[of a])
+
+lemma add_strict_increasing:
+ fixes c :: "'a::{ordered_ab_semigroup_add_imp_le, comm_monoid_add}"
+ shows "[|0<a; b\<le>c|] ==> b < a + c"
+by (insert add_less_le_mono [of 0 a b c], simp)
+
+lemma add_strict_increasing2:
+ fixes c :: "'a::{ordered_ab_semigroup_add_imp_le, comm_monoid_add}"
+ shows "[|0\<le>a; b<c|] ==> b < a + c"
+by (insert add_le_less_mono [of 0 a b c], simp)
+
+class abs =
+ fixes abs :: "'a \<Rightarrow> 'a"
+begin
+
+notation (xsymbols)
+ abs ("\<bar>_\<bar>")
+
+notation (HTML output)
+ abs ("\<bar>_\<bar>")
+
+end
+
+class sgn =
+ fixes sgn :: "'a \<Rightarrow> 'a"
+
+class abs_if = minus + uminus + ord + zero + abs +
+ assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"
+
+class sgn_if = minus + uminus + zero + one + ord + sgn +
+ assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
+begin
+
+lemma sgn0 [simp]: "sgn 0 = 0"
+ by (simp add:sgn_if)
+
+end
+
+class ordered_ab_group_add_abs = ordered_ab_group_add + abs +
+ assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
+ and abs_ge_self: "a \<le> \<bar>a\<bar>"
+ and abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
+ and abs_minus_cancel [simp]: "\<bar>-a\<bar> = \<bar>a\<bar>"
+ and abs_triangle_ineq: "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
+begin
+
+lemma abs_minus_le_zero: "- \<bar>a\<bar> \<le> 0"
+ unfolding neg_le_0_iff_le by simp
+
+lemma abs_of_nonneg [simp]:
+ assumes nonneg: "0 \<le> a" shows "\<bar>a\<bar> = a"
+proof (rule antisym)
+ from nonneg le_imp_neg_le have "- a \<le> 0" by simp
+ from this nonneg have "- a \<le> a" by (rule order_trans)
+ then show "\<bar>a\<bar> \<le> a" by (auto intro: abs_leI)
+qed (rule abs_ge_self)
+
+lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
+by (rule antisym)
+ (auto intro!: abs_ge_self abs_leI order_trans [of "uminus (abs a)" zero "abs a"])
+
+lemma abs_eq_0 [simp]: "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
+proof -
+ have "\<bar>a\<bar> = 0 \<Longrightarrow> a = 0"
+ proof (rule antisym)
+ assume zero: "\<bar>a\<bar> = 0"
+ with abs_ge_self show "a \<le> 0" by auto
+ from zero have "\<bar>-a\<bar> = 0" by simp
+ with abs_ge_self [of "uminus a"] have "- a \<le> 0" by auto
+ with neg_le_0_iff_le show "0 \<le> a" by auto
+ qed
+ then show ?thesis by auto
+qed
+
+lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
+by simp
+
+lemma abs_0_eq [simp, noatp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
+proof -
+ have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
+ thus ?thesis by simp
+qed
+
+lemma abs_le_zero_iff [simp]: "\<bar>a\<bar> \<le> 0 \<longleftrightarrow> a = 0"
+proof
+ assume "\<bar>a\<bar> \<le> 0"
+ then have "\<bar>a\<bar> = 0" by (rule antisym) simp
+ thus "a = 0" by simp
+next
+ assume "a = 0"
+ thus "\<bar>a\<bar> \<le> 0" by simp
+qed
+
+lemma zero_less_abs_iff [simp]: "0 < \<bar>a\<bar> \<longleftrightarrow> a \<noteq> 0"
+by (simp add: less_le)
+
+lemma abs_not_less_zero [simp]: "\<not> \<bar>a\<bar> < 0"
+proof -
+ have a: "\<And>x y. x \<le> y \<Longrightarrow> \<not> y < x" by auto
+ show ?thesis by (simp add: a)
+qed
+
+lemma abs_ge_minus_self: "- a \<le> \<bar>a\<bar>"
+proof -
+ have "- a \<le> \<bar>-a\<bar>" by (rule abs_ge_self)
+ then show ?thesis by simp
+qed
+
+lemma abs_minus_commute:
+ "\<bar>a - b\<bar> = \<bar>b - a\<bar>"
+proof -
+ have "\<bar>a - b\<bar> = \<bar>- (a - b)\<bar>" by (simp only: abs_minus_cancel)
+ also have "... = \<bar>b - a\<bar>" by simp
+ finally show ?thesis .
+qed
+
+lemma abs_of_pos: "0 < a \<Longrightarrow> \<bar>a\<bar> = a"
+by (rule abs_of_nonneg, rule less_imp_le)
+
+lemma abs_of_nonpos [simp]:
+ assumes "a \<le> 0" shows "\<bar>a\<bar> = - a"
+proof -
+ let ?b = "- a"
+ have "- ?b \<le> 0 \<Longrightarrow> \<bar>- ?b\<bar> = - (- ?b)"
+ unfolding abs_minus_cancel [of "?b"]
+ unfolding neg_le_0_iff_le [of "?b"]
+ unfolding minus_minus by (erule abs_of_nonneg)
+ then show ?thesis using assms by auto
+qed
+
+lemma abs_of_neg: "a < 0 \<Longrightarrow> \<bar>a\<bar> = - a"
+by (rule abs_of_nonpos, rule less_imp_le)
+
+lemma abs_le_D1: "\<bar>a\<bar> \<le> b \<Longrightarrow> a \<le> b"
+by (insert abs_ge_self, blast intro: order_trans)
+
+lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
+by (insert abs_le_D1 [of "uminus a"], simp)
+
+lemma abs_le_iff: "\<bar>a\<bar> \<le> b \<longleftrightarrow> a \<le> b \<and> - a \<le> b"
+by (blast intro: abs_leI dest: abs_le_D1 abs_le_D2)
+
+lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
+ apply (simp add: algebra_simps)
+ apply (subgoal_tac "abs a = abs (plus b (minus a b))")
+ apply (erule ssubst)
+ apply (rule abs_triangle_ineq)
+ apply (rule arg_cong[of _ _ abs])
+ apply (simp add: algebra_simps)
+done
+
+lemma abs_triangle_ineq3: "\<bar>\<bar>a\<bar> - \<bar>b\<bar>\<bar> \<le> \<bar>a - b\<bar>"
+ apply (subst abs_le_iff)
+ apply auto
+ apply (rule abs_triangle_ineq2)
+ apply (subst abs_minus_commute)
+ apply (rule abs_triangle_ineq2)
+done
+
+lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
+proof -
+ have "abs(a - b) = abs(a + - b)" by (subst diff_minus, rule refl)
+ also have "... <= abs a + abs (- b)" by (rule abs_triangle_ineq)
+ finally show ?thesis by simp
+qed
+
+lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
+proof -
+ have "\<bar>a + b - (c+d)\<bar> = \<bar>(a-c) + (b-d)\<bar>" by (simp add: diff_minus add_ac)
+ also have "... \<le> \<bar>a-c\<bar> + \<bar>b-d\<bar>" by (rule abs_triangle_ineq)
+ finally show ?thesis .
+qed
+
+lemma abs_add_abs [simp]:
+ "\<bar>\<bar>a\<bar> + \<bar>b\<bar>\<bar> = \<bar>a\<bar> + \<bar>b\<bar>" (is "?L = ?R")
+proof (rule antisym)
+ show "?L \<ge> ?R" by(rule abs_ge_self)
+next
+ have "?L \<le> \<bar>\<bar>a\<bar>\<bar> + \<bar>\<bar>b\<bar>\<bar>" by(rule abs_triangle_ineq)
+ also have "\<dots> = ?R" by simp
+ finally show "?L \<le> ?R" .
+qed
+
+end
+
+text {* Needed for abelian cancellation simprocs: *}
+
+lemma add_cancel_21: "((x::'a::ab_group_add) + (y + z) = y + u) = (x + z = u)"
+apply (subst add_left_commute)
+apply (subst add_left_cancel)
+apply simp
+done
+
+lemma add_cancel_end: "(x + (y + z) = y) = (x = - (z::'a::ab_group_add))"
+apply (subst add_cancel_21[of _ _ _ 0, simplified])
+apply (simp add: add_right_cancel[symmetric, of "x" "-z" "z", simplified])
+done
+
+lemma less_eqI: "(x::'a::ordered_ab_group_add) - y = x' - y' \<Longrightarrow> (x < y) = (x' < y')"
+by (simp add: less_iff_diff_less_0[of x y] less_iff_diff_less_0[of x' y'])
+
+lemma le_eqI: "(x::'a::ordered_ab_group_add) - y = x' - y' \<Longrightarrow> (y <= x) = (y' <= x')"
+apply (simp add: le_iff_diff_le_0[of y x] le_iff_diff_le_0[of y' x'])
+apply (simp add: neg_le_iff_le[symmetric, of "y-x" 0] neg_le_iff_le[symmetric, of "y'-x'" 0])
+done
+
+lemma eq_eqI: "(x::'a::ab_group_add) - y = x' - y' \<Longrightarrow> (x = y) = (x' = y')"
+by (simp only: eq_iff_diff_eq_0[of x y] eq_iff_diff_eq_0[of x' y'])
+
+lemma diff_def: "(x::'a::ab_group_add) - y == x + (-y)"
+by (simp add: diff_minus)
+
+lemma le_add_right_mono:
+ assumes
+ "a <= b + (c::'a::ordered_ab_group_add)"
+ "c <= d"
+ shows "a <= b + d"
+ apply (rule_tac order_trans[where y = "b+c"])
+ apply (simp_all add: prems)
+ done
+
+
+subsection {* Tools setup *}
+
+lemma add_mono_thms_linordered_semiring [noatp]:
+ fixes i j k :: "'a\<Colon>ordered_ab_semigroup_add"
+ shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
+ and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
+ and "i \<le> j \<and> k = l \<Longrightarrow> i + k \<le> j + l"
+ and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
+by (rule add_mono, clarify+)+
+
+lemma add_mono_thms_linordered_field [noatp]:
+ fixes i j k :: "'a\<Colon>ordered_cancel_ab_semigroup_add"
+ shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
+ and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
+ and "i < j \<and> k \<le> l \<Longrightarrow> i + k < j + l"
+ and "i \<le> j \<and> k < l \<Longrightarrow> i + k < j + l"
+ and "i < j \<and> k < l \<Longrightarrow> i + k < j + l"
+by (auto intro: add_strict_right_mono add_strict_left_mono
+ add_less_le_mono add_le_less_mono add_strict_mono)
+
+text{*Simplification of @{term "x-y < 0"}, etc.*}
+lemmas diff_less_0_iff_less [simp, noatp] = less_iff_diff_less_0 [symmetric]
+lemmas diff_le_0_iff_le [simp, noatp] = le_iff_diff_le_0 [symmetric]
+
+ML {*
+structure ab_group_add_cancel = Abel_Cancel
+(
+
+(* term order for abelian groups *)
+
+fun agrp_ord (Const (a, _)) = find_index (fn a' => a = a')
+ [@{const_name Algebras.zero}, @{const_name Algebras.plus},
+ @{const_name Algebras.uminus}, @{const_name Algebras.minus}]
+ | agrp_ord _ = ~1;
+
+fun termless_agrp (a, b) = (TermOrd.term_lpo agrp_ord (a, b) = LESS);
+
+local
+ val ac1 = mk_meta_eq @{thm add_assoc};
+ val ac2 = mk_meta_eq @{thm add_commute};
+ val ac3 = mk_meta_eq @{thm add_left_commute};
+ fun solve_add_ac thy _ (_ $ (Const (@{const_name Algebras.plus},_) $ _ $ _) $ _) =
+ SOME ac1
+ | solve_add_ac thy _ (_ $ x $ (Const (@{const_name Algebras.plus},_) $ y $ z)) =
+ if termless_agrp (y, x) then SOME ac3 else NONE
+ | solve_add_ac thy _ (_ $ x $ y) =
+ if termless_agrp (y, x) then SOME ac2 else NONE
+ | solve_add_ac thy _ _ = NONE
+in
+ val add_ac_proc = Simplifier.simproc @{theory}
+ "add_ac_proc" ["x + y::'a::ab_semigroup_add"] solve_add_ac;
+end;
+
+val eq_reflection = @{thm eq_reflection};
+
+val T = @{typ "'a::ab_group_add"};
+
+val cancel_ss = HOL_basic_ss settermless termless_agrp
+ addsimprocs [add_ac_proc] addsimps
+ [@{thm add_0_left}, @{thm add_0_right}, @{thm diff_def},
+ @{thm minus_add_distrib}, @{thm minus_minus}, @{thm minus_zero},
+ @{thm right_minus}, @{thm left_minus}, @{thm add_minus_cancel},
+ @{thm minus_add_cancel}];
+
+val sum_pats = [@{cterm "x + y::'a::ab_group_add"}, @{cterm "x - y::'a::ab_group_add"}];
+
+val eqI_rules = [@{thm less_eqI}, @{thm le_eqI}, @{thm eq_eqI}];
+
+val dest_eqI =
+ fst o HOLogic.dest_bin "op =" HOLogic.boolT o HOLogic.dest_Trueprop o concl_of;
+
+);
+*}
+
+ML {*
+ Addsimprocs [ab_group_add_cancel.sum_conv, ab_group_add_cancel.rel_conv];
+*}
+
+code_modulename SML
+ Groups Arith
+
+code_modulename OCaml
+ Groups Arith
+
+code_modulename Haskell
+ Groups Arith
+
+end
--- a/src/HOL/HOL.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/HOL.thy Fri Feb 19 15:21:57 2010 +0000
@@ -129,16 +129,15 @@
"_case2" :: "[case_syn, cases_syn] => cases_syn" ("_/ | _")
translations
- "THE x. P" == "The (%x. P)"
+ "THE x. P" == "CONST The (%x. P)"
"_Let (_binds b bs) e" == "_Let b (_Let bs e)"
- "let x = a in e" == "Let a (%x. e)"
+ "let x = a in e" == "CONST Let a (%x. e)"
print_translation {*
-(* To avoid eta-contraction of body: *)
-[("The", fn [Abs abs] =>
- let val (x,t) = atomic_abs_tr' abs
- in Syntax.const "_The" $ x $ t end)]
-*}
+ [(@{const_syntax The}, fn [Abs abs] =>
+ let val (x, t) = atomic_abs_tr' abs
+ in Syntax.const @{syntax_const "_The"} $ x $ t end)]
+*} -- {* To avoid eta-contraction of body *}
syntax (xsymbols)
"_case1" :: "['a, 'b] => case_syn" ("(2_ \<Rightarrow>/ _)" 10)
--- a/src/HOL/Hilbert_Choice.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hilbert_Choice.thy Fri Feb 19 15:21:57 2010 +0000
@@ -25,11 +25,10 @@
"SOME x. P" == "CONST Eps (%x. P)"
print_translation {*
-(* to avoid eta-contraction of body *)
-[(@{const_syntax Eps}, fn [Abs abs] =>
- let val (x,t) = atomic_abs_tr' abs
- in Syntax.const "_Eps" $ x $ t end)]
-*}
+ [(@{const_syntax Eps}, fn [Abs abs] =>
+ let val (x, t) = atomic_abs_tr' abs
+ in Syntax.const @{syntax_const "_Eps"} $ x $ t end)]
+*} -- {* to avoid eta-contraction of body *}
definition inv_into :: "'a set => ('a => 'b) => ('b => 'a)" where
"inv_into A f == %x. SOME y. y : A & f y = x"
@@ -62,7 +61,7 @@
by (blast intro: someI2)
lemma some1_equality: "[| EX!x. P x; P a |] ==> (SOME x. P x) = a"
-by (blast intro: some_equality)
+by blast
lemma some_eq_ex: "P (SOME x. P x) = (\<exists>x. P x)"
by (blast intro: someI)
@@ -109,7 +108,7 @@
done
lemma inv_f_f: "inj f ==> inv f (f x) = x"
-by (simp add: inv_into_f_f)
+by simp
lemma f_inv_into_f: "y : f`A ==> f (inv_into A f y) = y"
apply (simp add: inv_into_def)
@@ -315,7 +314,7 @@
syntax
"_LeastM" :: "[pttrn, 'a => 'b::ord, bool] => 'a" ("LEAST _ WRT _. _" [0, 4, 10] 10)
translations
- "LEAST x WRT m. P" == "LeastM m (%x. P)"
+ "LEAST x WRT m. P" == "CONST LeastM m (%x. P)"
lemma LeastMI2:
"P x ==> (!!y. P y ==> m x <= m y)
@@ -369,11 +368,10 @@
"Greatest == GreatestM (%x. x)"
syntax
- "_GreatestM" :: "[pttrn, 'a=>'b::ord, bool] => 'a"
+ "_GreatestM" :: "[pttrn, 'a => 'b::ord, bool] => 'a"
("GREATEST _ WRT _. _" [0, 4, 10] 10)
-
translations
- "GREATEST x WRT m. P" == "GreatestM m (%x. P)"
+ "GREATEST x WRT m. P" == "CONST GreatestM m (%x. P)"
lemma GreatestMI2:
"P x ==> (!!y. P y ==> m y <= m x)
--- a/src/HOL/Hoare/HeapSyntax.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/HeapSyntax.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/HeapSyntax.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
*)
@@ -9,16 +8,16 @@
subsection "Field access and update"
syntax
- "@refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
+ "_refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
("_/'((_ \<rightarrow> _)')" [1000,0] 900)
- "@fassign" :: "'a ref => id => 'v => 's com"
+ "_fassign" :: "'a ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "f(r \<rightarrow> v)" == "f(addr r := v)"
- "p^.f := e" => "f := f(p \<rightarrow> e)"
- "p^.f" => "f(addr p)"
+ "f(r \<rightarrow> v)" == "f(CONST addr r := v)"
+ "p^.f := e" => "f := f(p \<rightarrow> e)"
+ "p^.f" => "f(CONST addr p)"
declare fun_upd_apply[simp del] fun_upd_same[simp] fun_upd_other[simp]
--- a/src/HOL/Hoare/HeapSyntaxAbort.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/HeapSyntaxAbort.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/HeapSyntax.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
*)
@@ -17,16 +16,16 @@
reason about storage allocation/deallocation. *}
syntax
- "refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
+ "_refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
("_/'((_ \<rightarrow> _)')" [1000,0] 900)
- "@fassign" :: "'a ref => id => 'v => 's com"
+ "_fassign" :: "'a ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "refupdate f r v" == "f(addr r := v)"
- "p^.f := e" => "(p \<noteq> Null) \<rightarrow> (f := refupdate f p e)"
- "p^.f" => "f(addr p)"
+ "_refupdate f r v" == "f(CONST addr r := v)"
+ "p^.f := e" => "(p \<noteq> CONST Null) \<rightarrow> (f := _refupdate f p e)"
+ "p^.f" => "f(CONST addr p)"
declare fun_upd_apply[simp del] fun_upd_same[simp] fun_upd_other[simp]
--- a/src/HOL/Hoare/Hoare.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/Hoare.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/Hoare.thy
- ID: $Id$
Author: Leonor Prensa Nieto & Tobias Nipkow
Copyright 1998 TUM
@@ -19,17 +18,12 @@
'a assn = "'a set"
datatype
- 'a com = Basic "'a \<Rightarrow> 'a"
+ 'a com = Basic "'a \<Rightarrow> 'a"
| Seq "'a com" "'a com" ("(_;/ _)" [61,60] 60)
| Cond "'a bexp" "'a com" "'a com" ("(1IF _/ THEN _ / ELSE _/ FI)" [0,0,0] 61)
| While "'a bexp" "'a assn" "'a com" ("(1WHILE _/ INV {_} //DO _ /OD)" [0,0,0] 61)
-
-syntax
- "@assign" :: "id => 'b => 'a com" ("(2_ :=/ _)" [70,65] 61)
- "@annskip" :: "'a com" ("SKIP")
-translations
- "SKIP" == "Basic id"
+abbreviation annskip ("SKIP") where "SKIP == Basic id"
types 'a sem = "'a => 'a => bool"
@@ -50,16 +44,19 @@
"Valid p c q == !s s'. Sem c s s' --> s : p --> s' : q"
-syntax
- "@hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
- ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
-syntax ("" output)
- "@hoare" :: "['a assn,'a com,'a assn] => bool"
- ("{_} // _ // {_}" [0,55,0] 50)
(** parse translations **)
-ML{*
+syntax
+ "_assign" :: "id => 'b => 'a com" ("(2_ :=/ _)" [70,65] 61)
+
+syntax
+ "_hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
+ ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
+syntax ("" output)
+ "_hoare" :: "['a assn,'a com,'a assn] => bool"
+ ("{_} // _ // {_}" [0,55,0] 50)
+ML {*
local
@@ -70,11 +67,11 @@
fun mk_abstuple [x] body = abs (x, body)
| mk_abstuple (x::xs) body =
- Syntax.const "split" $ abs (x, mk_abstuple xs body);
+ Syntax.const @{const_syntax split} $ abs (x, mk_abstuple xs body);
fun mk_fbody a e [x as (b,_)] = if a=b then e else Syntax.free b
| mk_fbody a e ((b,_)::xs) =
- Syntax.const "Pair" $ (if a=b then e else Syntax.free b) $ mk_fbody a e xs;
+ Syntax.const @{const_syntax Pair} $ (if a=b then e else Syntax.free b) $ mk_fbody a e xs;
fun mk_fexp a e xs = mk_abstuple xs (mk_fbody a e xs)
end
@@ -84,22 +81,22 @@
(*all meta-variables for bexp except for TRUE are translated as if they
were boolean expressions*)
ML{*
-fun bexp_tr (Const ("TRUE", _)) xs = Syntax.const "TRUE"
- | bexp_tr b xs = Syntax.const "Collect" $ mk_abstuple xs b;
-
-fun assn_tr r xs = Syntax.const "Collect" $ mk_abstuple xs r;
+fun bexp_tr (Const ("TRUE", _)) xs = Syntax.const "TRUE" (* FIXME !? *)
+ | bexp_tr b xs = Syntax.const @{const_syntax Collect} $ mk_abstuple xs b;
+
+fun assn_tr r xs = Syntax.const @{const_syntax Collect} $ mk_abstuple xs r;
*}
(* com_tr *)
ML{*
-fun com_tr (Const("@assign",_) $ Free (a,_) $ e) xs =
- Syntax.const "Basic" $ mk_fexp a e xs
- | com_tr (Const ("Basic",_) $ f) xs = Syntax.const "Basic" $ f
- | com_tr (Const ("Seq",_) $ c1 $ c2) xs =
- Syntax.const "Seq" $ com_tr c1 xs $ com_tr c2 xs
- | com_tr (Const ("Cond",_) $ b $ c1 $ c2) xs =
- Syntax.const "Cond" $ bexp_tr b xs $ com_tr c1 xs $ com_tr c2 xs
- | com_tr (Const ("While",_) $ b $ I $ c) xs =
- Syntax.const "While" $ bexp_tr b xs $ assn_tr I xs $ com_tr c xs
+fun com_tr (Const(@{syntax_const "_assign"},_) $ Free (a,_) $ e) xs =
+ Syntax.const @{const_syntax Basic} $ mk_fexp a e xs
+ | com_tr (Const (@{const_syntax Basic},_) $ f) xs = Syntax.const @{const_syntax Basic} $ f
+ | com_tr (Const (@{const_syntax Seq},_) $ c1 $ c2) xs =
+ Syntax.const @{const_syntax Seq} $ com_tr c1 xs $ com_tr c2 xs
+ | com_tr (Const (@{const_syntax Cond},_) $ b $ c1 $ c2) xs =
+ Syntax.const @{const_syntax Cond} $ bexp_tr b xs $ com_tr c1 xs $ com_tr c2 xs
+ | com_tr (Const (@{const_syntax While},_) $ b $ I $ c) xs =
+ Syntax.const @{const_syntax While} $ bexp_tr b xs $ assn_tr I xs $ com_tr c xs
| com_tr t _ = t (* if t is just a Free/Var *)
*}
@@ -108,65 +105,66 @@
local
fun var_tr(Free(a,_)) = (a,Bound 0) (* Bound 0 = dummy term *)
- | var_tr(Const ("_constrain", _) $ (Free (a,_)) $ T) = (a,T);
+ | var_tr(Const (@{syntax_const "_constrain"}, _) $ (Free (a,_)) $ T) = (a,T);
-fun vars_tr (Const ("_idts", _) $ idt $ vars) = var_tr idt :: vars_tr vars
+fun vars_tr (Const (@{syntax_const "_idts"}, _) $ idt $ vars) = var_tr idt :: vars_tr vars
| vars_tr t = [var_tr t]
in
fun hoare_vars_tr [vars, pre, prg, post] =
let val xs = vars_tr vars
- in Syntax.const "Valid" $
+ in Syntax.const @{const_syntax Valid} $
assn_tr pre xs $ com_tr prg xs $ assn_tr post xs
end
| hoare_vars_tr ts = raise TERM ("hoare_vars_tr", ts);
end
*}
-parse_translation {* [("@hoare_vars", hoare_vars_tr)] *}
+parse_translation {* [(@{syntax_const "_hoare_vars"}, hoare_vars_tr)] *}
(*****************************************************************************)
(*** print translations ***)
ML{*
-fun dest_abstuple (Const ("split",_) $ (Abs(v,_, body))) =
+fun dest_abstuple (Const (@{const_syntax split},_) $ (Abs(v,_, body))) =
subst_bound (Syntax.free v, dest_abstuple body)
| dest_abstuple (Abs(v,_, body)) = subst_bound (Syntax.free v, body)
| dest_abstuple trm = trm;
-fun abs2list (Const ("split",_) $ (Abs(x,T,t))) = Free (x, T)::abs2list t
+fun abs2list (Const (@{const_syntax split},_) $ (Abs(x,T,t))) = Free (x, T)::abs2list t
| abs2list (Abs(x,T,t)) = [Free (x, T)]
| abs2list _ = [];
-fun mk_ts (Const ("split",_) $ (Abs(x,_,t))) = mk_ts t
+fun mk_ts (Const (@{const_syntax split},_) $ (Abs(x,_,t))) = mk_ts t
| mk_ts (Abs(x,_,t)) = mk_ts t
- | mk_ts (Const ("Pair",_) $ a $ b) = a::(mk_ts b)
+ | mk_ts (Const (@{const_syntax Pair},_) $ a $ b) = a::(mk_ts b)
| mk_ts t = [t];
-fun mk_vts (Const ("split",_) $ (Abs(x,_,t))) =
+fun mk_vts (Const (@{const_syntax split},_) $ (Abs(x,_,t))) =
((Syntax.free x)::(abs2list t), mk_ts t)
| mk_vts (Abs(x,_,t)) = ([Syntax.free x], [t])
| mk_vts t = raise Match;
-
-fun find_ch [] i xs = (false, (Syntax.free "not_ch",Syntax.free "not_ch" ))
- | find_ch ((v,t)::vts) i xs = if t=(Bound i) then find_ch vts (i-1) xs
- else (true, (v, subst_bounds (xs,t)));
-
-fun is_f (Const ("split",_) $ (Abs(x,_,t))) = true
+
+fun find_ch [] i xs = (false, (Syntax.free "not_ch", Syntax.free "not_ch"))
+ | find_ch ((v,t)::vts) i xs =
+ if t = Bound i then find_ch vts (i-1) xs
+ else (true, (v, subst_bounds (xs, t)));
+
+fun is_f (Const (@{const_syntax split},_) $ (Abs(x,_,t))) = true
| is_f (Abs(x,_,t)) = true
| is_f t = false;
*}
(* assn_tr' & bexp_tr'*)
-ML{*
-fun assn_tr' (Const ("Collect",_) $ T) = dest_abstuple T
- | assn_tr' (Const (@{const_name inter}, _) $ (Const ("Collect",_) $ T1) $
- (Const ("Collect",_) $ T2)) =
- Syntax.const "Set.Int" $ dest_abstuple T1 $ dest_abstuple T2
+ML{*
+fun assn_tr' (Const (@{const_syntax Collect},_) $ T) = dest_abstuple T
+ | assn_tr' (Const (@{const_syntax inter}, _) $
+ (Const (@{const_syntax Collect},_) $ T1) $ (Const (@{const_syntax Collect},_) $ T2)) =
+ Syntax.const @{const_syntax inter} $ dest_abstuple T1 $ dest_abstuple T2
| assn_tr' t = t;
-fun bexp_tr' (Const ("Collect",_) $ T) = dest_abstuple T
+fun bexp_tr' (Const (@{const_syntax Collect},_) $ T) = dest_abstuple T
| bexp_tr' t = t;
*}
@@ -175,25 +173,27 @@
fun mk_assign f =
let val (vs, ts) = mk_vts f;
val (ch, which) = find_ch (vs~~ts) ((length vs)-1) (rev vs)
- in if ch then Syntax.const "@assign" $ fst(which) $ snd(which)
- else Syntax.const "@skip" end;
+ in
+ if ch then Syntax.const @{syntax_const "_assign"} $ fst which $ snd which
+ else Syntax.const @{const_syntax annskip}
+ end;
-fun com_tr' (Const ("Basic",_) $ f) = if is_f f then mk_assign f
- else Syntax.const "Basic" $ f
- | com_tr' (Const ("Seq",_) $ c1 $ c2) = Syntax.const "Seq" $
- com_tr' c1 $ com_tr' c2
- | com_tr' (Const ("Cond",_) $ b $ c1 $ c2) = Syntax.const "Cond" $
- bexp_tr' b $ com_tr' c1 $ com_tr' c2
- | com_tr' (Const ("While",_) $ b $ I $ c) = Syntax.const "While" $
- bexp_tr' b $ assn_tr' I $ com_tr' c
+fun com_tr' (Const (@{const_syntax Basic},_) $ f) =
+ if is_f f then mk_assign f
+ else Syntax.const @{const_syntax Basic} $ f
+ | com_tr' (Const (@{const_syntax Seq},_) $ c1 $ c2) =
+ Syntax.const @{const_syntax Seq} $ com_tr' c1 $ com_tr' c2
+ | com_tr' (Const (@{const_syntax Cond},_) $ b $ c1 $ c2) =
+ Syntax.const @{const_syntax Cond} $ bexp_tr' b $ com_tr' c1 $ com_tr' c2
+ | com_tr' (Const (@{const_syntax While},_) $ b $ I $ c) =
+ Syntax.const @{const_syntax While} $ bexp_tr' b $ assn_tr' I $ com_tr' c
| com_tr' t = t;
-
fun spec_tr' [p, c, q] =
- Syntax.const "@hoare" $ assn_tr' p $ com_tr' c $ assn_tr' q
+ Syntax.const @{syntax_const "_hoare"} $ assn_tr' p $ com_tr' c $ assn_tr' q
*}
-print_translation {* [("Valid", spec_tr')] *}
+print_translation {* [(@{const_syntax Valid}, spec_tr')] *}
lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
by (auto simp:Valid_def)
--- a/src/HOL/Hoare/HoareAbort.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/HoareAbort.thy Fri Feb 19 15:21:57 2010 +0000
@@ -20,13 +20,8 @@
| Seq "'a com" "'a com" ("(_;/ _)" [61,60] 60)
| Cond "'a bexp" "'a com" "'a com" ("(1IF _/ THEN _ / ELSE _/ FI)" [0,0,0] 61)
| While "'a bexp" "'a assn" "'a com" ("(1WHILE _/ INV {_} //DO _ /OD)" [0,0,0] 61)
-
-syntax
- "@assign" :: "id => 'b => 'a com" ("(2_ :=/ _)" [70,65] 61)
- "@annskip" :: "'a com" ("SKIP")
-translations
- "SKIP" == "Basic id"
+abbreviation annskip ("SKIP") where "SKIP == Basic id"
types 'a sem = "'a option => 'a option => bool"
@@ -51,16 +46,19 @@
"Valid p c q == \<forall>s s'. Sem c s s' \<longrightarrow> s : Some ` p \<longrightarrow> s' : Some ` q"
-syntax
- "@hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
- ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
-syntax ("" output)
- "@hoare" :: "['a assn,'a com,'a assn] => bool"
- ("{_} // _ // {_}" [0,55,0] 50)
(** parse translations **)
-ML{*
+syntax
+ "_assign" :: "id => 'b => 'a com" ("(2_ :=/ _)" [70,65] 61)
+
+syntax
+ "_hoare_vars" :: "[idts, 'a assn,'a com,'a assn] => bool"
+ ("VARS _// {_} // _ // {_}" [0,0,55,0] 50)
+syntax ("" output)
+ "_hoare" :: "['a assn,'a com,'a assn] => bool"
+ ("{_} // _ // {_}" [0,55,0] 50)
+ML {*
local
fun free a = Free(a,dummyT)
@@ -71,11 +69,11 @@
fun mk_abstuple [x] body = abs (x, body)
| mk_abstuple (x::xs) body =
- Syntax.const "split" $ abs (x, mk_abstuple xs body);
+ Syntax.const @{const_syntax split} $ abs (x, mk_abstuple xs body);
fun mk_fbody a e [x as (b,_)] = if a=b then e else free b
| mk_fbody a e ((b,_)::xs) =
- Syntax.const "Pair" $ (if a=b then e else free b) $ mk_fbody a e xs;
+ Syntax.const @{const_syntax Pair} $ (if a=b then e else free b) $ mk_fbody a e xs;
fun mk_fexp a e xs = mk_abstuple xs (mk_fbody a e xs)
end
@@ -85,22 +83,22 @@
(*all meta-variables for bexp except for TRUE are translated as if they
were boolean expressions*)
ML{*
-fun bexp_tr (Const ("TRUE", _)) xs = Syntax.const "TRUE"
- | bexp_tr b xs = Syntax.const "Collect" $ mk_abstuple xs b;
-
-fun assn_tr r xs = Syntax.const "Collect" $ mk_abstuple xs r;
+fun bexp_tr (Const ("TRUE", _)) xs = Syntax.const "TRUE" (* FIXME !? *)
+ | bexp_tr b xs = Syntax.const @{const_syntax Collect} $ mk_abstuple xs b;
+
+fun assn_tr r xs = Syntax.const @{const_syntax Collect} $ mk_abstuple xs r;
*}
(* com_tr *)
ML{*
-fun com_tr (Const("@assign",_) $ Free (a,_) $ e) xs =
- Syntax.const "Basic" $ mk_fexp a e xs
- | com_tr (Const ("Basic",_) $ f) xs = Syntax.const "Basic" $ f
- | com_tr (Const ("Seq",_) $ c1 $ c2) xs =
- Syntax.const "Seq" $ com_tr c1 xs $ com_tr c2 xs
- | com_tr (Const ("Cond",_) $ b $ c1 $ c2) xs =
- Syntax.const "Cond" $ bexp_tr b xs $ com_tr c1 xs $ com_tr c2 xs
- | com_tr (Const ("While",_) $ b $ I $ c) xs =
- Syntax.const "While" $ bexp_tr b xs $ assn_tr I xs $ com_tr c xs
+fun com_tr (Const (@{syntax_const "_assign"},_) $ Free (a,_) $ e) xs =
+ Syntax.const @{const_syntax Basic} $ mk_fexp a e xs
+ | com_tr (Const (@{const_syntax Basic},_) $ f) xs = Syntax.const @{const_syntax Basic} $ f
+ | com_tr (Const (@{const_syntax Seq},_) $ c1 $ c2) xs =
+ Syntax.const @{const_syntax Seq} $ com_tr c1 xs $ com_tr c2 xs
+ | com_tr (Const (@{const_syntax Cond},_) $ b $ c1 $ c2) xs =
+ Syntax.const @{const_syntax Cond} $ bexp_tr b xs $ com_tr c1 xs $ com_tr c2 xs
+ | com_tr (Const (@{const_syntax While},_) $ b $ I $ c) xs =
+ Syntax.const @{const_syntax While} $ bexp_tr b xs $ assn_tr I xs $ com_tr c xs
| com_tr t _ = t (* if t is just a Free/Var *)
*}
@@ -108,66 +106,67 @@
ML{*
local
-fun var_tr(Free(a,_)) = (a,Bound 0) (* Bound 0 = dummy term *)
- | var_tr(Const ("_constrain", _) $ (Free (a,_)) $ T) = (a,T);
+fun var_tr (Free (a, _)) = (a, Bound 0) (* Bound 0 = dummy term *)
+ | var_tr (Const (@{syntax_const "_constrain"}, _) $ Free (a, _) $ T) = (a, T);
-fun vars_tr (Const ("_idts", _) $ idt $ vars) = var_tr idt :: vars_tr vars
+fun vars_tr (Const (@{syntax_const "_idts"}, _) $ idt $ vars) = var_tr idt :: vars_tr vars
| vars_tr t = [var_tr t]
in
fun hoare_vars_tr [vars, pre, prg, post] =
let val xs = vars_tr vars
- in Syntax.const "Valid" $
+ in Syntax.const @{const_syntax Valid} $
assn_tr pre xs $ com_tr prg xs $ assn_tr post xs
end
| hoare_vars_tr ts = raise TERM ("hoare_vars_tr", ts);
end
*}
-parse_translation {* [("@hoare_vars", hoare_vars_tr)] *}
+parse_translation {* [(@{syntax_const "_hoare_vars"}, hoare_vars_tr)] *}
(*****************************************************************************)
(*** print translations ***)
ML{*
-fun dest_abstuple (Const ("split",_) $ (Abs(v,_, body))) =
- subst_bound (Syntax.free v, dest_abstuple body)
+fun dest_abstuple (Const (@{const_syntax split},_) $ (Abs(v,_, body))) =
+ subst_bound (Syntax.free v, dest_abstuple body)
| dest_abstuple (Abs(v,_, body)) = subst_bound (Syntax.free v, body)
| dest_abstuple trm = trm;
-fun abs2list (Const ("split",_) $ (Abs(x,T,t))) = Free (x, T)::abs2list t
+fun abs2list (Const (@{const_syntax split},_) $ (Abs(x,T,t))) = Free (x, T)::abs2list t
| abs2list (Abs(x,T,t)) = [Free (x, T)]
| abs2list _ = [];
-fun mk_ts (Const ("split",_) $ (Abs(x,_,t))) = mk_ts t
+fun mk_ts (Const (@{const_syntax split},_) $ (Abs(x,_,t))) = mk_ts t
| mk_ts (Abs(x,_,t)) = mk_ts t
- | mk_ts (Const ("Pair",_) $ a $ b) = a::(mk_ts b)
+ | mk_ts (Const (@{const_syntax Pair},_) $ a $ b) = a::(mk_ts b)
| mk_ts t = [t];
-fun mk_vts (Const ("split",_) $ (Abs(x,_,t))) =
+fun mk_vts (Const (@{const_syntax split},_) $ (Abs(x,_,t))) =
((Syntax.free x)::(abs2list t), mk_ts t)
| mk_vts (Abs(x,_,t)) = ([Syntax.free x], [t])
| mk_vts t = raise Match;
-
-fun find_ch [] i xs = (false, (Syntax.free "not_ch",Syntax.free "not_ch" ))
- | find_ch ((v,t)::vts) i xs = if t=(Bound i) then find_ch vts (i-1) xs
- else (true, (v, subst_bounds (xs,t)));
-
-fun is_f (Const ("split",_) $ (Abs(x,_,t))) = true
+
+fun find_ch [] i xs = (false, (Syntax.free "not_ch", Syntax.free "not_ch"))
+ | find_ch ((v,t)::vts) i xs =
+ if t = Bound i then find_ch vts (i-1) xs
+ else (true, (v, subst_bounds (xs,t)));
+
+fun is_f (Const (@{const_syntax split},_) $ (Abs(x,_,t))) = true
| is_f (Abs(x,_,t)) = true
| is_f t = false;
*}
(* assn_tr' & bexp_tr'*)
-ML{*
-fun assn_tr' (Const ("Collect",_) $ T) = dest_abstuple T
- | assn_tr' (Const (@{const_name inter},_) $ (Const ("Collect",_) $ T1) $
- (Const ("Collect",_) $ T2)) =
- Syntax.const "Set.Int" $ dest_abstuple T1 $ dest_abstuple T2
+ML{*
+fun assn_tr' (Const (@{const_syntax Collect},_) $ T) = dest_abstuple T
+ | assn_tr' (Const (@{const_syntax inter},_) $ (Const (@{const_syntax Collect},_) $ T1) $
+ (Const (@{const_syntax Collect},_) $ T2)) =
+ Syntax.const @{const_syntax inter} $ dest_abstuple T1 $ dest_abstuple T2
| assn_tr' t = t;
-fun bexp_tr' (Const ("Collect",_) $ T) = dest_abstuple T
+fun bexp_tr' (Const (@{const_syntax Collect},_) $ T) = dest_abstuple T
| bexp_tr' t = t;
*}
@@ -176,25 +175,26 @@
fun mk_assign f =
let val (vs, ts) = mk_vts f;
val (ch, which) = find_ch (vs~~ts) ((length vs)-1) (rev vs)
- in if ch then Syntax.const "@assign" $ fst(which) $ snd(which)
- else Syntax.const "@skip" end;
+ in
+ if ch then Syntax.const @{syntax_const "_assign"} $ fst which $ snd which
+ else Syntax.const @{const_syntax annskip}
+ end;
-fun com_tr' (Const ("Basic",_) $ f) = if is_f f then mk_assign f
- else Syntax.const "Basic" $ f
- | com_tr' (Const ("Seq",_) $ c1 $ c2) = Syntax.const "Seq" $
- com_tr' c1 $ com_tr' c2
- | com_tr' (Const ("Cond",_) $ b $ c1 $ c2) = Syntax.const "Cond" $
- bexp_tr' b $ com_tr' c1 $ com_tr' c2
- | com_tr' (Const ("While",_) $ b $ I $ c) = Syntax.const "While" $
- bexp_tr' b $ assn_tr' I $ com_tr' c
+fun com_tr' (Const (@{const_syntax Basic},_) $ f) =
+ if is_f f then mk_assign f else Syntax.const @{const_syntax Basic} $ f
+ | com_tr' (Const (@{const_syntax Seq},_) $ c1 $ c2) =
+ Syntax.const @{const_syntax Seq} $ com_tr' c1 $ com_tr' c2
+ | com_tr' (Const (@{const_syntax Cond},_) $ b $ c1 $ c2) =
+ Syntax.const @{const_syntax Cond} $ bexp_tr' b $ com_tr' c1 $ com_tr' c2
+ | com_tr' (Const (@{const_syntax While},_) $ b $ I $ c) =
+ Syntax.const @{const_syntax While} $ bexp_tr' b $ assn_tr' I $ com_tr' c
| com_tr' t = t;
-
fun spec_tr' [p, c, q] =
- Syntax.const "@hoare" $ assn_tr' p $ com_tr' c $ assn_tr' q
+ Syntax.const @{syntax_const "_hoare"} $ assn_tr' p $ com_tr' c $ assn_tr' q
*}
-print_translation {* [("Valid", spec_tr')] *}
+print_translation {* [(@{const_syntax Valid}, spec_tr')] *}
(*** The proof rules ***)
@@ -257,9 +257,9 @@
syntax
guarded_com :: "bool \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(2_ \<rightarrow>/ _)" 71)
- array_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com" ("(2_[_] :=/ _)" [70,65] 61)
+ array_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com" ("(2_[_] :=/ _)" [70, 65] 61)
translations
- "P \<rightarrow> c" == "IF P THEN c ELSE Abort FI"
+ "P \<rightarrow> c" == "IF P THEN c ELSE CONST Abort FI"
"a[i] := v" => "(i < CONST length a) \<rightarrow> (a := CONST list_update a i v)"
(* reverse translation not possible because of duplicate "a" *)
--- a/src/HOL/Hoare/Pointers0.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/Pointers0.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/Pointers.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
@@ -20,12 +19,12 @@
subsection "Field access and update"
syntax
- "@fassign" :: "'a::ref => id => 'v => 's com"
+ "_fassign" :: "'a::ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "p^.f := e" => "f := fun_upd f p e"
+ "p^.f := e" => "f := CONST fun_upd f p e"
"p^.f" => "f p"
--- a/src/HOL/Hoare/Separation.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/Separation.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/Separation.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2003 TUM
@@ -50,10 +49,10 @@
bound Hs - otherwise they may bind the implicit H. *}
syntax
- "@emp" :: "bool" ("emp")
- "@singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
- "@star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
- "@wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)
+ "_emp" :: "bool" ("emp")
+ "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
+ "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
+ "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)
(* FIXME does not handle "_idtdummy" *)
ML{*
@@ -65,22 +64,25 @@
*)
| free_tr t = t
-fun emp_tr [] = Syntax.const "is_empty" $ Syntax.free "H"
+fun emp_tr [] = Syntax.const @{const_syntax is_empty} $ Syntax.free "H"
| emp_tr ts = raise TERM ("emp_tr", ts);
-fun singl_tr [p,q] = Syntax.const "singl" $ Syntax.free "H" $ p $ q
+fun singl_tr [p, q] = Syntax.const @{const_syntax singl} $ Syntax.free "H" $ p $ q
| singl_tr ts = raise TERM ("singl_tr", ts);
-fun star_tr [P,Q] = Syntax.const "star" $
- absfree("H",dummyT,free_tr P) $ absfree("H",dummyT,free_tr Q) $
+fun star_tr [P,Q] = Syntax.const @{const_syntax star} $
+ absfree ("H", dummyT, free_tr P) $ absfree ("H", dummyT, free_tr Q) $
Syntax.free "H"
| star_tr ts = raise TERM ("star_tr", ts);
-fun wand_tr [P,Q] = Syntax.const "wand" $
- absfree("H",dummyT,P) $ absfree("H",dummyT,Q) $ Syntax.free "H"
+fun wand_tr [P, Q] = Syntax.const @{const_syntax wand} $
+ absfree ("H", dummyT, P) $ absfree ("H", dummyT, Q) $ Syntax.free "H"
| wand_tr ts = raise TERM ("wand_tr", ts);
*}
-parse_translation
- {* [("@emp", emp_tr), ("@singl", singl_tr),
- ("@star", star_tr), ("@wand", wand_tr)] *}
+parse_translation {*
+ [(@{syntax_const "_emp"}, emp_tr),
+ (@{syntax_const "_singl"}, singl_tr),
+ (@{syntax_const "_star"}, star_tr),
+ (@{syntax_const "_wand"}, wand_tr)]
+*}
text{* Now it looks much better: *}
@@ -103,17 +105,9 @@
text{* But the output is still unreadable. Thus we also strip the heap
parameters upon output: *}
-(* debugging code:
-fun sot(Free(s,_)) = s
- | sot(Var((s,i),_)) = "?" ^ s ^ string_of_int i
- | sot(Const(s,_)) = s
- | sot(Bound i) = "B." ^ string_of_int i
- | sot(s $ t) = "(" ^ sot s ^ " " ^ sot t ^ ")"
- | sot(Abs(_,_,t)) = "(% " ^ sot t ^ ")";
-*)
+ML {*
+local
-ML{*
-local
fun strip (Abs(_,_,(t as Const("_free",_) $ Free _) $ Bound 0)) = t
| strip (Abs(_,_,(t as Free _) $ Bound 0)) = t
(*
@@ -121,19 +115,25 @@
*)
| strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
| strip (Abs(_,_,P)) = P
- | strip (Const("is_empty",_)) = Syntax.const "@emp"
+ | strip (Const(@{const_syntax is_empty},_)) = Syntax.const @{syntax_const "_emp"}
| strip t = t;
+
in
-fun is_empty_tr' [_] = Syntax.const "@emp"
-fun singl_tr' [_,p,q] = Syntax.const "@singl" $ p $ q
-fun star_tr' [P,Q,_] = Syntax.const "@star" $ strip P $ strip Q
-fun wand_tr' [P,Q,_] = Syntax.const "@wand" $ strip P $ strip Q
+
+fun is_empty_tr' [_] = Syntax.const @{syntax_const "_emp"}
+fun singl_tr' [_,p,q] = Syntax.const @{syntax_const "_singl"} $ p $ q
+fun star_tr' [P,Q,_] = Syntax.const @{syntax_const "_star"} $ strip P $ strip Q
+fun wand_tr' [P,Q,_] = Syntax.const @{syntax_const "_wand"} $ strip P $ strip Q
+
end
*}
-print_translation
- {* [("is_empty", is_empty_tr'),("singl", singl_tr'),
- ("star", star_tr'),("wand", wand_tr')] *}
+print_translation {*
+ [(@{const_syntax is_empty}, is_empty_tr'),
+ (@{const_syntax singl}, singl_tr'),
+ (@{const_syntax star}, star_tr'),
+ (@{const_syntax wand}, wand_tr')]
+*}
text{* Now the intermediate proof states are also readable: *}
--- a/src/HOL/Hoare/hoare_tac.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare/hoare_tac.ML Fri Feb 19 15:21:57 2010 +0000
@@ -58,7 +58,7 @@
let val T as Type ("fun",[t,_]) = fastype_of trm
in Collect_const t $ trm end;
-fun inclt ty = Const (@{const_name Algebras.less_eq}, [ty,ty] ---> boolT);
+fun inclt ty = Const (@{const_name Orderings.less_eq}, [ty,ty] ---> boolT);
fun Mset ctxt prop =
--- a/src/HOL/Hoare_Parallel/OG_Syntax.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Syntax.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,18 +5,25 @@
text{* Syntax for commands and for assertions and boolean expressions in
commands @{text com} and annotated commands @{text ann_com}. *}
+abbreviation Skip :: "'a com" ("SKIP" 63)
+ where "SKIP \<equiv> Basic id"
+
+abbreviation AnnSkip :: "'a assn \<Rightarrow> 'a ann_com" ("_//SKIP" [90] 63)
+ where "r SKIP \<equiv> AnnBasic r id"
+
+notation
+ Seq ("_,,/ _" [55, 56] 55) and
+ AnnSeq ("_;;/ _" [60,61] 60)
+
syntax
"_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
"_AnnAssign" :: "'a assn \<Rightarrow> idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(_ \<acute>_ :=/ _)" [90,70,65] 61)
translations
- "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
- "r \<acute>\<spacespace>x := a" \<rightharpoonup> "AnnBasic r \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
+ "\<acute>x := a" \<rightharpoonup> "CONST Basic \<guillemotleft>\<acute>(_update_name x (\<lambda>_. a))\<guillemotright>"
+ "r \<acute>x := a" \<rightharpoonup> "CONST AnnBasic r \<guillemotleft>\<acute>(_update_name x (\<lambda>_. a))\<guillemotright>"
syntax
- "_AnnSkip" :: "'a assn \<Rightarrow> 'a ann_com" ("_//SKIP" [90] 63)
- "_AnnSeq" :: "'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com" ("_;;/ _" [60,61] 60)
-
"_AnnCond1" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
("_ //IF _ /THEN _ /ELSE _ /FI" [90,0,0,0] 61)
"_AnnCond2" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
@@ -28,8 +35,6 @@
"_AnnAtom" :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a ann_com" ("_//\<langle>_\<rangle>" [90,0] 61)
"_AnnWait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com" ("_//WAIT _ END" [90,0] 61)
- "_Skip" :: "'a com" ("SKIP" 63)
- "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("_,,/ _" [55, 56] 55)
"_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
"_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("IF _ THEN _ FI" [0,0] 56)
@@ -39,21 +44,16 @@
("(0WHILE _ //DO _ /OD)" [0, 0] 61)
translations
- "SKIP" \<rightleftharpoons> "Basic id"
- "c_1,, c_2" \<rightleftharpoons> "Seq c_1 c_2"
-
- "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
+ "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond .{b}. c1 c2"
"IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
- "WHILE b INV i DO c OD" \<rightharpoonup> "While .{b}. i c"
+ "WHILE b INV i DO c OD" \<rightharpoonup> "CONST While .{b}. i c"
"WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"
- "r SKIP" \<rightleftharpoons> "AnnBasic r id"
- "c_1;; c_2" \<rightleftharpoons> "AnnSeq c_1 c_2"
- "r IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "AnnCond1 r .{b}. c1 c2"
- "r IF b THEN c FI" \<rightharpoonup> "AnnCond2 r .{b}. c"
- "r WHILE b INV i DO c OD" \<rightharpoonup> "AnnWhile r .{b}. i c"
- "r AWAIT b THEN c END" \<rightharpoonup> "AnnAwait r .{b}. c"
- "r \<langle>c\<rangle>" \<rightleftharpoons> "r AWAIT True THEN c END"
+ "r IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST AnnCond1 r .{b}. c1 c2"
+ "r IF b THEN c FI" \<rightharpoonup> "CONST AnnCond2 r .{b}. c"
+ "r WHILE b INV i DO c OD" \<rightharpoonup> "CONST AnnWhile r .{b}. i c"
+ "r AWAIT b THEN c END" \<rightharpoonup> "CONST AnnAwait r .{b}. c"
+ "r \<langle>c\<rangle>" \<rightleftharpoons> "r AWAIT CONST True THEN c END"
"r WAIT b END" \<rightleftharpoons> "r AWAIT b THEN SKIP END"
nonterminals
@@ -68,73 +68,68 @@
("SCHEME [_ \<le> _ < _] _// _" [0,0,0,60, 90] 57)
translations
- "_prg c q" \<rightleftharpoons> "[(Some c, q)]"
- "_prgs c q ps" \<rightleftharpoons> "(Some c, q) # ps"
- "_PAR ps" \<rightleftharpoons> "Parallel ps"
+ "_prg c q" \<rightleftharpoons> "[(CONST Some c, q)]"
+ "_prgs c q ps" \<rightleftharpoons> "(CONST Some c, q) # ps"
+ "_PAR ps" \<rightleftharpoons> "CONST Parallel ps"
- "_prg_scheme j i k c q" \<rightleftharpoons> "CONST map (\<lambda>i. (Some c, q)) [j..<k]"
+ "_prg_scheme j i k c q" \<rightleftharpoons> "CONST map (\<lambda>i. (CONST Some c, q)) [j..<k]"
print_translation {*
let
fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ Term.list_comb (f $ Syntax.quote_tr' @{syntax_const "_antiquote"} t, ts)
| quote_tr' _ _ = raise Match;
fun annquote_tr' f (r :: t :: ts) =
- Term.list_comb (f $ r $ Syntax.quote_tr' "_antiquote" t, ts)
+ Term.list_comb (f $ r $ Syntax.quote_tr' @{syntax_const "_antiquote"} t, ts)
| annquote_tr' _ _ = raise Match;
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
+ val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
quote_tr' (Syntax.const name) (t :: ts)
| bexp_tr' _ _ = raise Match;
- fun annbexp_tr' name (r :: (Const ("Collect", _) $ t) :: ts) =
+ fun annbexp_tr' name (r :: (Const (@{const_syntax Collect}, _) $ t) :: ts) =
annquote_tr' (Syntax.const name) (r :: t :: ts)
| annbexp_tr' _ _ = raise Match;
- fun upd_tr' (x_upd, T) =
- (case try (unsuffix Record.updateN) x_upd of
- SOME x => (x, if T = dummyT then T else Term.domain_type T)
- | NONE => raise Match);
-
- fun update_name_tr' (Free x) = Free (upd_tr' x)
- | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
- c $ Free (upd_tr' x)
- | update_name_tr' (Const x) = Const (upd_tr' x)
- | update_name_tr' _ = raise Match;
-
- fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
- | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
+ fun K_tr' (Abs (_, _, t)) =
+ if null (loose_bnos t) then t else raise Match
+ | K_tr' (Abs (_, _, Abs (_, _, t) $ Bound 0)) =
+ if null (loose_bnos t) then t else raise Match
| K_tr' _ = raise Match;
fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
+ quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax.update_name_tr' f)
(Abs (x, dummyT, K_tr' k) :: ts)
| assign_tr' _ = raise Match;
fun annassign_tr' (r :: Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_AnnAssign" $ r $ update_name_tr' f)
+ quote_tr' (Syntax.const @{syntax_const "_AnnAssign"} $ r $ Syntax.update_name_tr' f)
(Abs (x, dummyT, K_tr' k) :: ts)
| annassign_tr' _ = raise Match;
- fun Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1 ) $ t2) $ Const ("Nil",_))] =
- (Syntax.const "_prg" $ t1 $ t2)
- | Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1) $ t2) $ ts)] =
- (Syntax.const "_prgs" $ t1 $ t2 $ Parallel_PAR [ts])
+ fun Parallel_PAR [(Const (@{const_syntax Cons}, _) $
+ (Const (@{const_syntax Pair}, _) $ (Const (@{const_syntax Some},_) $ t1 ) $ t2) $
+ Const (@{const_syntax Nil}, _))] = Syntax.const @{syntax_const "_prg"} $ t1 $ t2
+ | Parallel_PAR [(Const (@{const_syntax Cons}, _) $
+ (Const (@{const_syntax Pair}, _) $ (Const (@{const_syntax Some}, _) $ t1) $ t2) $ ts)] =
+ Syntax.const @{syntax_const "_prgs"} $ t1 $ t2 $ Parallel_PAR [ts]
| Parallel_PAR _ = raise Match;
-fun Parallel_tr' ts = Syntax.const "_PAR" $ Parallel_PAR ts;
+ fun Parallel_tr' ts = Syntax.const @{syntax_const "_PAR"} $ Parallel_PAR ts;
in
- [("Collect", assert_tr'), ("Basic", assign_tr'),
- ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv"),
- ("AnnBasic", annassign_tr'),
- ("AnnWhile", annbexp_tr' "_AnnWhile"), ("AnnAwait", annbexp_tr' "_AnnAwait"),
- ("AnnCond1", annbexp_tr' "_AnnCond1"), ("AnnCond2", annbexp_tr' "_AnnCond2")]
-
- end
-
+ [(@{const_syntax Collect}, assert_tr'),
+ (@{const_syntax Basic}, assign_tr'),
+ (@{const_syntax Cond}, bexp_tr' "_Cond"),
+ (@{const_syntax While}, bexp_tr' "_While_inv"),
+ (@{const_syntax AnnBasic}, annassign_tr'),
+ (@{const_syntax AnnWhile}, annbexp_tr' "_AnnWhile"),
+ (@{const_syntax AnnAwait}, annbexp_tr' "_AnnAwait"),
+ (@{const_syntax AnnCond1}, annbexp_tr' "_AnnCond1"),
+ (@{const_syntax AnnCond2}, annbexp_tr' "_AnnCond2")]
+ end;
*}
end
\ No newline at end of file
--- a/src/HOL/Hoare_Parallel/OG_Tran.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Tran.thy Fri Feb 19 15:21:57 2010 +0000
@@ -69,7 +69,7 @@
monos "rtrancl_mono"
-text {* The corresponding syntax translations are: *}
+text {* The corresponding abbreviations are: *}
abbreviation
ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
@@ -101,8 +101,8 @@
SEM :: "'a com \<Rightarrow> 'a set \<Rightarrow> 'a set"
"SEM c S \<equiv> \<Union>sem c ` S "
-syntax "_Omega" :: "'a com" ("\<Omega>" 63)
-translations "\<Omega>" \<rightleftharpoons> "While CONST UNIV CONST UNIV (Basic id)"
+abbreviation Omega :: "'a com" ("\<Omega>" 63)
+ where "\<Omega> \<equiv> While UNIV UNIV (Basic id)"
consts fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com"
primrec
--- a/src/HOL/Hoare_Parallel/Quote_Antiquote.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare_Parallel/Quote_Antiquote.thy Fri Feb 19 15:21:57 2010 +0000
@@ -12,13 +12,13 @@
"_Assert" :: "'a \<Rightarrow> 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
translations
- ".{b}." \<rightharpoonup> "Collect \<guillemotleft>b\<guillemotright>"
+ ".{b}." \<rightharpoonup> "CONST Collect \<guillemotleft>b\<guillemotright>"
parse_translation {*
let
- fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
+ fun quote_tr [t] = Syntax.quote_tr @{syntax_const "_antiquote"} t
| quote_tr ts = raise TERM ("quote_tr", ts);
- in [("_quote", quote_tr)] end
+ in [(@{syntax_const "_quote"}, quote_tr)] end
*}
end
\ No newline at end of file
--- a/src/HOL/Hoare_Parallel/RG_Syntax.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Syntax.thy Fri Feb 19 15:21:57 2010 +0000
@@ -4,10 +4,13 @@
imports RG_Hoare Quote_Antiquote
begin
+abbreviation Skip :: "'a com" ("SKIP")
+ where "SKIP \<equiv> Basic id"
+
+notation Seq ("(_;;/ _)" [60,61] 60)
+
syntax
"_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
- "_skip" :: "'a com" ("SKIP")
- "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(_;;/ _)" [60,61] 60)
"_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _/ THEN _/ ELSE _/FI)" [0, 0, 0] 61)
"_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _ THEN _ FI)" [0,0] 56)
"_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0WHILE _ /DO _ /OD)" [0, 0] 61)
@@ -16,14 +19,12 @@
"_Wait" :: "'a bexp \<Rightarrow> 'a com" ("(0WAIT _ END)" 61)
translations
- "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
- "SKIP" \<rightleftharpoons> "Basic id"
- "c1;; c2" \<rightleftharpoons> "Seq c1 c2"
- "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
+ "\<acute>x := a" \<rightharpoonup> "CONST Basic \<guillemotleft>\<acute>(_update_name x (\<lambda>_. a))\<guillemotright>"
+ "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond .{b}. c1 c2"
"IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
- "WHILE b DO c OD" \<rightharpoonup> "While .{b}. c"
- "AWAIT b THEN c END" \<rightleftharpoons> "Await .{b}. c"
- "\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT True THEN c END"
+ "WHILE b DO c OD" \<rightharpoonup> "CONST While .{b}. c"
+ "AWAIT b THEN c END" \<rightleftharpoons> "CONST Await .{b}. c"
+ "\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT CONST True THEN c END"
"WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
nonterminals
@@ -52,43 +53,36 @@
"_after" :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")
translations
- "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>fst"
- "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>snd"
+ "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>CONST fst"
+ "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>CONST snd"
print_translation {*
let
fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ Term.list_comb (f $ Syntax.quote_tr' @{syntax_const "_antiquote"} t, ts)
| quote_tr' _ _ = raise Match;
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
+ val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
quote_tr' (Syntax.const name) (t :: ts)
| bexp_tr' _ _ = raise Match;
- fun upd_tr' (x_upd, T) =
- (case try (unsuffix Record.updateN) x_upd of
- SOME x => (x, if T = dummyT then T else Term.domain_type T)
- | NONE => raise Match);
-
- fun update_name_tr' (Free x) = Free (upd_tr' x)
- | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
- c $ Free (upd_tr' x)
- | update_name_tr' (Const x) = Const (upd_tr' x)
- | update_name_tr' _ = raise Match;
-
- fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
- | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
+ fun K_tr' (Abs (_, _, t)) =
+ if null (loose_bnos t) then t else raise Match
+ | K_tr' (Abs (_, _, Abs (_, _, t) $ Bound 0)) =
+ if null (loose_bnos t) then t else raise Match
| K_tr' _ = raise Match;
fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
+ quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax.update_name_tr' f)
(Abs (x, dummyT, K_tr' k) :: ts)
| assign_tr' _ = raise Match;
in
- [("Collect", assert_tr'), ("Basic", assign_tr'),
- ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv")]
+ [(@{const_syntax Collect}, assert_tr'),
+ (@{const_syntax Basic}, assign_tr'),
+ (@{const_syntax Cond}, bexp_tr' @{syntax_const "_Cond"}),
+ (@{const_syntax While}, bexp_tr' @{syntax_const "_While"})]
end
*}
--- a/src/HOL/Imperative_HOL/Heap_Monad.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Imperative_HOL/Heap_Monad.thy Fri Feb 19 15:21:57 2010 +0000
@@ -147,16 +147,16 @@
val v_used = fold_aterms
(fn Free (w, _) => (fn s => s orelse member (op =) vs w) | _ => I) g' false;
in if v_used then
- Const ("_bindM", dummyT) $ v $ f $ unfold_monad g'
+ Const (@{syntax_const "_bindM"}, dummyT) $ v $ f $ unfold_monad g'
else
- Const ("_chainM", dummyT) $ f $ unfold_monad g'
+ Const (@{syntax_const "_chainM"}, dummyT) $ f $ unfold_monad g'
end
| unfold_monad (Const (@{const_syntax chainM}, _) $ f $ g) =
- Const ("_chainM", dummyT) $ f $ unfold_monad g
+ Const (@{syntax_const "_chainM"}, dummyT) $ f $ unfold_monad g
| unfold_monad (Const (@{const_syntax Let}, _) $ f $ g) =
let
val (v, g') = dest_abs_eta g;
- in Const ("_let", dummyT) $ v $ f $ unfold_monad g' end
+ in Const (@{syntax_const "_let"}, dummyT) $ v $ f $ unfold_monad g' end
| unfold_monad (Const (@{const_syntax Pair}, _) $ f) =
Const (@{const_syntax return}, dummyT) $ f
| unfold_monad f = f;
@@ -164,14 +164,17 @@
| contains_bindM (Const (@{const_syntax Let}, _) $ _ $ Abs (_, _, t)) =
contains_bindM t;
fun bindM_monad_tr' (f::g::ts) = list_comb
- (Const ("_do", dummyT) $ unfold_monad (Const (@{const_syntax bindM}, dummyT) $ f $ g), ts);
- fun Let_monad_tr' (f :: (g as Abs (_, _, g')) :: ts) = if contains_bindM g' then list_comb
- (Const ("_do", dummyT) $ unfold_monad (Const (@{const_syntax Let}, dummyT) $ f $ g), ts)
+ (Const (@{syntax_const "_do"}, dummyT) $
+ unfold_monad (Const (@{const_syntax bindM}, dummyT) $ f $ g), ts);
+ fun Let_monad_tr' (f :: (g as Abs (_, _, g')) :: ts) =
+ if contains_bindM g' then list_comb
+ (Const (@{syntax_const "_do"}, dummyT) $
+ unfold_monad (Const (@{const_syntax Let}, dummyT) $ f $ g), ts)
else raise Match;
-in [
- (@{const_syntax bindM}, bindM_monad_tr'),
- (@{const_syntax Let}, Let_monad_tr')
-] end;
+in
+ [(@{const_syntax bindM}, bindM_monad_tr'),
+ (@{const_syntax Let}, Let_monad_tr')]
+end;
*}
--- a/src/HOL/Imperative_HOL/ex/Imperative_Quicksort.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Imperative_HOL/ex/Imperative_Quicksort.thy Fri Feb 19 15:21:57 2010 +0000
@@ -629,6 +629,8 @@
return a
done"
+code_reserved SML upto
+
ML {* @{code qsort} (Array.fromList [42, 2, 3, 5, 0, 1705, 8, 3, 15]) () *}
export_code qsort in SML_imp module_name QSort
--- a/src/HOL/Imperative_HOL/ex/Linked_Lists.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Imperative_HOL/ex/Linked_Lists.thy Fri Feb 19 15:21:57 2010 +0000
@@ -986,6 +986,8 @@
return zs
done)"
+code_reserved SML upto
+
ML {* @{code test_1} () *}
ML {* @{code test_2} () *}
ML {* @{code test_3} () *}
--- a/src/HOL/Import/Generate-HOL/GenHOL4Base.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/Generate-HOL/GenHOL4Base.thy Fri Feb 19 15:21:57 2010 +0000
@@ -166,7 +166,7 @@
import_theory prim_rec;
const_maps
- "<" > Algebras.less :: "[nat,nat]=>bool";
+ "<" > Orderings.less :: "[nat,nat]=>bool";
end_import;
@@ -181,7 +181,7 @@
">" > HOL4Compat.nat_gt
">=" > HOL4Compat.nat_ge
FUNPOW > HOL4Compat.FUNPOW
- "<=" > Algebras.less_eq :: "[nat,nat]=>bool"
+ "<=" > Orderings.less_eq :: "[nat,nat]=>bool"
"+" > Algebras.plus :: "[nat,nat]=>nat"
"*" > Algebras.times :: "[nat,nat]=>nat"
"-" > Algebras.minus :: "[nat,nat]=>nat"
--- a/src/HOL/Import/Generate-HOL/GenHOL4Real.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/Generate-HOL/GenHOL4Real.thy Fri Feb 19 15:21:57 2010 +0000
@@ -22,7 +22,7 @@
inv > Algebras.inverse :: "real => real"
real_add > Algebras.plus :: "[real,real] => real"
real_mul > Algebras.times :: "[real,real] => real"
- real_lt > Algebras.less :: "[real,real] => bool";
+ real_lt > Orderings.less :: "[real,real] => bool";
ignore_thms
real_TY_DEF
@@ -50,11 +50,11 @@
const_maps
real_gt > HOL4Compat.real_gt
real_ge > HOL4Compat.real_ge
- real_lte > Algebras.less_eq :: "[real,real] => bool"
+ real_lte > Orderings.less_eq :: "[real,real] => bool"
real_sub > Algebras.minus :: "[real,real] => real"
"/" > Algebras.divide :: "[real,real] => real"
pow > Power.power :: "[real,nat] => real"
- abs > Algebras.abs :: "real => real"
+ abs > Groups.abs :: "real => real"
real_of_num > RealDef.real :: "nat => real";
end_import;
--- a/src/HOL/Import/HOL/arithmetic.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/arithmetic.imp Fri Feb 19 15:21:57 2010 +0000
@@ -23,7 +23,7 @@
"ALT_ZERO" > "HOL4Compat.ALT_ZERO"
">=" > "HOL4Compat.nat_ge"
">" > "HOL4Compat.nat_gt"
- "<=" > "Algebras.ord_class.less_eq" :: "nat => nat => bool"
+ "<=" > "Orderings.less_eq" :: "nat => nat => bool"
"-" > "Algebras.minus_class.minus" :: "nat => nat => nat"
"+" > "Algebras.plus_class.plus" :: "nat => nat => nat"
"*" > "Algebras.times_class.times" :: "nat => nat => nat"
@@ -162,12 +162,12 @@
"LESS_OR" > "Nat.Suc_leI"
"LESS_NOT_SUC" > "HOL4Base.arithmetic.LESS_NOT_SUC"
"LESS_MULT_MONO" > "Nat.Suc_mult_less_cancel1"
- "LESS_MULT2" > "Ring_and_Field.mult_pos_pos"
+ "LESS_MULT2" > "Rings.mult_pos_pos"
"LESS_MONO_REV" > "Nat.Suc_less_SucD"
"LESS_MONO_MULT" > "Nat.mult_le_mono1"
"LESS_MONO_EQ" > "Nat.Suc_less_eq"
- "LESS_MONO_ADD_INV" > "OrderedGroup.add_less_imp_less_right"
- "LESS_MONO_ADD_EQ" > "OrderedGroup.add_less_cancel_right"
+ "LESS_MONO_ADD_INV" > "Groups.add_less_imp_less_right"
+ "LESS_MONO_ADD_EQ" > "Groups.add_less_cancel_right"
"LESS_MONO_ADD" > "Nat.add_less_mono1"
"LESS_MOD" > "Divides.mod_less"
"LESS_LESS_SUC" > "HOL4Base.arithmetic.LESS_LESS_SUC"
@@ -180,7 +180,7 @@
"LESS_EQ_SUC_REFL" > "HOL4Base.arithmetic.LESS_EQ_SUC_REFL"
"LESS_EQ_SUB_LESS" > "HOL4Base.arithmetic.LESS_EQ_SUB_LESS"
"LESS_EQ_REFL" > "Finite_Set.max.f_below.below_refl"
- "LESS_EQ_MONO_ADD_EQ" > "OrderedGroup.add_le_cancel_right"
+ "LESS_EQ_MONO_ADD_EQ" > "Groups.add_le_cancel_right"
"LESS_EQ_MONO" > "Nat.Suc_le_mono"
"LESS_EQ_LESS_TRANS" > "Nat.le_less_trans"
"LESS_EQ_LESS_EQ_MONO" > "Nat.add_le_mono"
--- a/src/HOL/Import/HOL/divides.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/divides.imp Fri Feb 19 15:21:57 2010 +0000
@@ -9,16 +9,16 @@
"divides_def" > "HOL4Compat.divides_def"
"ONE_DIVIDES_ALL" > "HOL4Base.divides.ONE_DIVIDES_ALL"
"NOT_LT_DIV" > "NatSimprocs.nat_dvd_not_less"
- "DIVIDES_TRANS" > "Ring_and_Field.dvd_trans"
- "DIVIDES_SUB" > "Ring_and_Field.dvd_diff"
- "DIVIDES_REFL" > "Ring_and_Field.dvd_refl"
+ "DIVIDES_TRANS" > "Rings.dvd_trans"
+ "DIVIDES_SUB" > "Rings.dvd_diff"
+ "DIVIDES_REFL" > "Rings.dvd_refl"
"DIVIDES_MULT_LEFT" > "HOL4Base.divides.DIVIDES_MULT_LEFT"
"DIVIDES_MULT" > "Divides.dvd_mult2"
"DIVIDES_LE" > "Divides.dvd_imp_le"
"DIVIDES_FACT" > "HOL4Base.divides.DIVIDES_FACT"
"DIVIDES_ANTISYM" > "Divides.dvd_antisym"
"DIVIDES_ADD_2" > "HOL4Base.divides.DIVIDES_ADD_2"
- "DIVIDES_ADD_1" > "Ring_and_Field.dvd_add"
+ "DIVIDES_ADD_1" > "Rings.dvd_add"
"ALL_DIVIDES_0" > "Divides.dvd_0_right"
end
--- a/src/HOL/Import/HOL/prim_rec.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/prim_rec.imp Fri Feb 19 15:21:57 2010 +0000
@@ -18,7 +18,7 @@
"PRIM_REC_FUN" > "HOL4Base.prim_rec.PRIM_REC_FUN"
"PRIM_REC" > "HOL4Base.prim_rec.PRIM_REC"
"PRE" > "HOL4Base.prim_rec.PRE"
- "<" > "Algebras.less" :: "nat => nat => bool"
+ "<" > "Orderings.less" :: "nat => nat => bool"
thm_maps
"wellfounded_primdef" > "HOL4Base.prim_rec.wellfounded_primdef"
--- a/src/HOL/Import/HOL/prob_extra.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/prob_extra.imp Fri Feb 19 15:21:57 2010 +0000
@@ -23,9 +23,9 @@
"REAL_SUP_LE_X" > "HOL4Prob.prob_extra.REAL_SUP_LE_X"
"REAL_SUP_EXISTS_UNIQUE" > "HOL4Prob.prob_extra.REAL_SUP_EXISTS_UNIQUE"
"REAL_POW" > "RealPow.realpow_real_of_nat"
- "REAL_LE_INV_LE" > "Ring_and_Field.le_imp_inverse_le"
+ "REAL_LE_INV_LE" > "Rings.le_imp_inverse_le"
"REAL_LE_EQ" > "Set.basic_trans_rules_26"
- "REAL_INVINV_ALL" > "Ring_and_Field.inverse_inverse_eq"
+ "REAL_INVINV_ALL" > "Rings.inverse_inverse_eq"
"REAL_INF_MIN" > "HOL4Prob.prob_extra.REAL_INF_MIN"
"RAND_THM" > "HOL.arg_cong"
"POW_HALF_TWICE" > "HOL4Prob.prob_extra.POW_HALF_TWICE"
--- a/src/HOL/Import/HOL/real.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/real.imp Fri Feb 19 15:21:57 2010 +0000
@@ -12,12 +12,12 @@
"sum" > "HOL4Real.real.sum"
"real_sub" > "Algebras.minus" :: "real => real => real"
"real_of_num" > "RealDef.real" :: "nat => real"
- "real_lte" > "Algebras.less_eq" :: "real => real => bool"
+ "real_lte" > "Orderings.less_eq" :: "real => real => bool"
"real_gt" > "HOL4Compat.real_gt"
"real_ge" > "HOL4Compat.real_ge"
"pow" > "Power.power_class.power" :: "real => nat => real"
- "abs" > "Algebras.abs" :: "real => real"
- "/" > "Algebras.divide" :: "real => real => real"
+ "abs" > "Groups.abs" :: "real => real"
+ "/" > "Ring.divide" :: "real => real => real"
thm_maps
"sup_def" > "HOL4Real.real.sup_def"
@@ -25,13 +25,13 @@
"sumc" > "HOL4Real.real.sumc"
"sum_def" > "HOL4Real.real.sum_def"
"sum" > "HOL4Real.real.sum"
- "real_sub" > "OrderedGroup.diff_def"
+ "real_sub" > "Groups.diff_def"
"real_of_num" > "HOL4Compat.real_of_num"
"real_lte" > "HOL4Compat.real_lte"
"real_lt" > "Orderings.linorder_not_le"
"real_gt" > "HOL4Compat.real_gt"
"real_ge" > "HOL4Compat.real_ge"
- "real_div" > "Ring_and_Field.field_class.divide_inverse"
+ "real_div" > "Ring.divide_inverse"
"pow" > "HOL4Compat.pow"
"abs" > "HOL4Compat.abs"
"SUP_LEMMA3" > "HOL4Real.real.SUP_LEMMA3"
@@ -74,24 +74,24 @@
"REAL_SUB_TRIANGLE" > "HOL4Real.real.REAL_SUB_TRIANGLE"
"REAL_SUB_SUB2" > "HOL4Real.real.REAL_SUB_SUB2"
"REAL_SUB_SUB" > "HOL4Real.real.REAL_SUB_SUB"
- "REAL_SUB_RZERO" > "OrderedGroup.diff_0_right"
- "REAL_SUB_RNEG" > "OrderedGroup.diff_minus_eq_add"
- "REAL_SUB_REFL" > "OrderedGroup.diff_self"
- "REAL_SUB_RDISTRIB" > "Ring_and_Field.ring_eq_simps_3"
+ "REAL_SUB_RZERO" > "Groups.diff_0_right"
+ "REAL_SUB_RNEG" > "Groups.diff_minus_eq_add"
+ "REAL_SUB_REFL" > "Groups.diff_self"
+ "REAL_SUB_RDISTRIB" > "Rings.ring_eq_simps_3"
"REAL_SUB_NEG2" > "HOL4Real.real.REAL_SUB_NEG2"
- "REAL_SUB_LZERO" > "OrderedGroup.diff_0"
+ "REAL_SUB_LZERO" > "Groups.diff_0"
"REAL_SUB_LT" > "HOL4Real.real.REAL_SUB_LT"
"REAL_SUB_LNEG" > "HOL4Real.real.REAL_SUB_LNEG"
"REAL_SUB_LE" > "HOL4Real.real.REAL_SUB_LE"
- "REAL_SUB_LDISTRIB" > "Ring_and_Field.ring_eq_simps_4"
+ "REAL_SUB_LDISTRIB" > "Rings.ring_eq_simps_4"
"REAL_SUB_INV2" > "HOL4Real.real.REAL_SUB_INV2"
"REAL_SUB_ADD2" > "HOL4Real.real.REAL_SUB_ADD2"
- "REAL_SUB_ADD" > "OrderedGroup.diff_add_cancel"
- "REAL_SUB_ABS" > "OrderedGroup.abs_triangle_ineq2"
- "REAL_SUB_0" > "OrderedGroup.diff_eq_0_iff_eq"
+ "REAL_SUB_ADD" > "Groups.diff_add_cancel"
+ "REAL_SUB_ABS" > "Groups.abs_triangle_ineq2"
+ "REAL_SUB_0" > "Groups.diff_eq_0_iff_eq"
"REAL_RNEG_UNIQ" > "RealDef.real_add_eq_0_iff"
- "REAL_RINV_UNIQ" > "Ring_and_Field.inverse_unique"
- "REAL_RDISTRIB" > "Ring_and_Field.ring_eq_simps_1"
+ "REAL_RINV_UNIQ" > "Rings.inverse_unique"
+ "REAL_RDISTRIB" > "Rings.ring_eq_simps_1"
"REAL_POW_POW" > "Power.power_mult"
"REAL_POW_MONO_LT" > "HOL4Real.real.REAL_POW_MONO_LT"
"REAL_POW_LT2" > "HOL4Real.real.REAL_POW_LT2"
@@ -103,7 +103,7 @@
"REAL_POS_NZ" > "HOL4Real.real.REAL_POS_NZ"
"REAL_POS" > "RealDef.real_of_nat_ge_zero"
"REAL_POASQ" > "HOL4Real.real.REAL_POASQ"
- "REAL_OVER1" > "Ring_and_Field.divide_1"
+ "REAL_OVER1" > "Rings.divide_1"
"REAL_OF_NUM_SUC" > "RealDef.real_of_nat_Suc"
"REAL_OF_NUM_POW" > "RealPow.realpow_real_of_nat"
"REAL_OF_NUM_MUL" > "RealDef.real_of_nat_mult"
@@ -113,172 +113,172 @@
"REAL_NZ_IMP_LT" > "HOL4Real.real.REAL_NZ_IMP_LT"
"REAL_NOT_LT" > "HOL4Compat.real_lte"
"REAL_NOT_LE" > "Orderings.linorder_not_le"
- "REAL_NEG_SUB" > "OrderedGroup.minus_diff_eq"
- "REAL_NEG_RMUL" > "Ring_and_Field.mult_minus_right"
- "REAL_NEG_NEG" > "OrderedGroup.minus_minus"
- "REAL_NEG_MUL2" > "Ring_and_Field.minus_mult_minus"
+ "REAL_NEG_SUB" > "Groups.minus_diff_eq"
+ "REAL_NEG_RMUL" > "Rings.mult_minus_right"
+ "REAL_NEG_NEG" > "Groups.minus_minus"
+ "REAL_NEG_MUL2" > "Rings.minus_mult_minus"
"REAL_NEG_MINUS1" > "HOL4Real.real.REAL_NEG_MINUS1"
- "REAL_NEG_LT0" > "OrderedGroup.neg_less_0_iff_less"
- "REAL_NEG_LMUL" > "Ring_and_Field.mult_minus_left"
- "REAL_NEG_LE0" > "OrderedGroup.neg_le_0_iff_le"
- "REAL_NEG_INV" > "Ring_and_Field.nonzero_inverse_minus_eq"
- "REAL_NEG_GT0" > "OrderedGroup.neg_0_less_iff_less"
- "REAL_NEG_GE0" > "OrderedGroup.neg_0_le_iff_le"
- "REAL_NEG_EQ0" > "OrderedGroup.neg_equal_0_iff_equal"
+ "REAL_NEG_LT0" > "Groups.neg_less_0_iff_less"
+ "REAL_NEG_LMUL" > "Rings.mult_minus_left"
+ "REAL_NEG_LE0" > "Groups.neg_le_0_iff_le"
+ "REAL_NEG_INV" > "Rings.nonzero_inverse_minus_eq"
+ "REAL_NEG_GT0" > "Groups.neg_0_less_iff_less"
+ "REAL_NEG_GE0" > "Groups.neg_0_le_iff_le"
+ "REAL_NEG_EQ0" > "Groups.neg_equal_0_iff_equal"
"REAL_NEG_EQ" > "HOL4Real.real.REAL_NEG_EQ"
- "REAL_NEG_ADD" > "OrderedGroup.minus_add_distrib"
- "REAL_NEG_0" > "OrderedGroup.minus_zero"
- "REAL_NEGNEG" > "OrderedGroup.minus_minus"
+ "REAL_NEG_ADD" > "Groups.minus_add_distrib"
+ "REAL_NEG_0" > "Groups.minus_zero"
+ "REAL_NEGNEG" > "Groups.minus_minus"
"REAL_MUL_SYM" > "Int.zmult_ac_2"
- "REAL_MUL_RZERO" > "Ring_and_Field.mult_zero_right"
- "REAL_MUL_RNEG" > "Ring_and_Field.mult_minus_right"
- "REAL_MUL_RINV" > "Ring_and_Field.right_inverse"
+ "REAL_MUL_RZERO" > "Rings.mult_zero_right"
+ "REAL_MUL_RNEG" > "Rings.mult_minus_right"
+ "REAL_MUL_RINV" > "Rings.right_inverse"
"REAL_MUL_RID" > "Finite_Set.AC_mult.f_e.ident"
- "REAL_MUL_LZERO" > "Ring_and_Field.mult_zero_left"
- "REAL_MUL_LNEG" > "Ring_and_Field.mult_minus_left"
+ "REAL_MUL_LZERO" > "Rings.mult_zero_left"
+ "REAL_MUL_LNEG" > "Rings.mult_minus_left"
"REAL_MUL_LINV" > "HOL4Compat.REAL_MUL_LINV"
"REAL_MUL_LID" > "Finite_Set.AC_mult.f_e.left_ident"
"REAL_MUL_ASSOC" > "HOL4Compat.REAL_MUL_ASSOC"
"REAL_MUL" > "RealDef.real_of_nat_mult"
"REAL_MIDDLE2" > "HOL4Real.real.REAL_MIDDLE2"
"REAL_MIDDLE1" > "HOL4Real.real.REAL_MIDDLE1"
- "REAL_MEAN" > "Ring_and_Field.dense"
+ "REAL_MEAN" > "Rings.dense"
"REAL_LT_TRANS" > "Set.basic_trans_rules_21"
"REAL_LT_TOTAL" > "HOL4Compat.REAL_LT_TOTAL"
- "REAL_LT_SUB_RADD" > "OrderedGroup.compare_rls_6"
- "REAL_LT_SUB_LADD" > "OrderedGroup.compare_rls_7"
- "REAL_LT_RMUL_IMP" > "Ring_and_Field.ordered_semiring_strict_class.mult_strict_right_mono"
+ "REAL_LT_SUB_RADD" > "Groups.compare_rls_6"
+ "REAL_LT_SUB_LADD" > "Groups.compare_rls_7"
+ "REAL_LT_RMUL_IMP" > "Rings.mult_strict_right_mono"
"REAL_LT_RMUL_0" > "HOL4Real.real.REAL_LT_RMUL_0"
"REAL_LT_RMUL" > "RealDef.real_mult_less_iff1"
"REAL_LT_REFL" > "Orderings.order_less_irrefl"
- "REAL_LT_RDIV_EQ" > "Ring_and_Field.pos_less_divide_eq"
+ "REAL_LT_RDIV_EQ" > "Rings.pos_less_divide_eq"
"REAL_LT_RDIV_0" > "HOL4Real.real.REAL_LT_RDIV_0"
"REAL_LT_RDIV" > "HOL4Real.real.REAL_LT_RDIV"
- "REAL_LT_RADD" > "OrderedGroup.add_less_cancel_right"
+ "REAL_LT_RADD" > "Groups.add_less_cancel_right"
"REAL_LT_NZ" > "HOL4Real.real.REAL_LT_NZ"
"REAL_LT_NEGTOTAL" > "HOL4Real.real.REAL_LT_NEGTOTAL"
- "REAL_LT_NEG" > "OrderedGroup.neg_less_iff_less"
+ "REAL_LT_NEG" > "Groups.neg_less_iff_less"
"REAL_LT_MULTIPLE" > "HOL4Real.real.REAL_LT_MULTIPLE"
- "REAL_LT_MUL2" > "Ring_and_Field.mult_strict_mono'"
- "REAL_LT_MUL" > "Ring_and_Field.mult_pos_pos"
- "REAL_LT_LMUL_IMP" > "Ring_and_Field.ordered_comm_semiring_strict_class.mult_strict_mono"
+ "REAL_LT_MUL2" > "Rings.mult_strict_mono'"
+ "REAL_LT_MUL" > "Rings.mult_pos_pos"
+ "REAL_LT_LMUL_IMP" > "Rings.linordered_comm_semiring_strict_class.mult_strict_mono"
"REAL_LT_LMUL_0" > "HOL4Real.real.REAL_LT_LMUL_0"
"REAL_LT_LMUL" > "HOL4Real.real.REAL_LT_LMUL"
"REAL_LT_LE" > "Orderings.order_class.order_less_le"
- "REAL_LT_LDIV_EQ" > "Ring_and_Field.pos_divide_less_eq"
- "REAL_LT_LADD" > "OrderedGroup.add_less_cancel_left"
- "REAL_LT_INV_EQ" > "Ring_and_Field.inverse_positive_iff_positive"
- "REAL_LT_INV" > "Ring_and_Field.less_imp_inverse_less"
+ "REAL_LT_LDIV_EQ" > "Rings.pos_divide_less_eq"
+ "REAL_LT_LADD" > "Groups.add_less_cancel_left"
+ "REAL_LT_INV_EQ" > "Rings.inverse_positive_iff_positive"
+ "REAL_LT_INV" > "Rings.less_imp_inverse_less"
"REAL_LT_IMP_NE" > "Orderings.less_imp_neq"
"REAL_LT_IMP_LE" > "Orderings.order_less_imp_le"
- "REAL_LT_IADD" > "OrderedGroup.add_strict_left_mono"
+ "REAL_LT_IADD" > "Groups.add_strict_left_mono"
"REAL_LT_HALF2" > "HOL4Real.real.REAL_LT_HALF2"
"REAL_LT_HALF1" > "NatSimprocs.half_gt_zero_iff"
"REAL_LT_GT" > "Orderings.order_less_not_sym"
"REAL_LT_FRACTION_0" > "HOL4Real.real.REAL_LT_FRACTION_0"
"REAL_LT_FRACTION" > "HOL4Real.real.REAL_LT_FRACTION"
- "REAL_LT_DIV" > "Ring_and_Field.divide_pos_pos"
+ "REAL_LT_DIV" > "Rings.divide_pos_pos"
"REAL_LT_ANTISYM" > "HOL4Real.real.REAL_LT_ANTISYM"
- "REAL_LT_ADD_SUB" > "OrderedGroup.compare_rls_7"
+ "REAL_LT_ADD_SUB" > "Groups.compare_rls_7"
"REAL_LT_ADDR" > "HOL4Real.real.REAL_LT_ADDR"
"REAL_LT_ADDNEG2" > "HOL4Real.real.REAL_LT_ADDNEG2"
"REAL_LT_ADDNEG" > "HOL4Real.real.REAL_LT_ADDNEG"
"REAL_LT_ADDL" > "HOL4Real.real.REAL_LT_ADDL"
- "REAL_LT_ADD2" > "OrderedGroup.add_strict_mono"
+ "REAL_LT_ADD2" > "Groups.add_strict_mono"
"REAL_LT_ADD1" > "HOL4Real.real.REAL_LT_ADD1"
- "REAL_LT_ADD" > "OrderedGroup.add_pos_pos"
+ "REAL_LT_ADD" > "Groups.add_pos_pos"
"REAL_LT_1" > "HOL4Real.real.REAL_LT_1"
- "REAL_LT_01" > "Ring_and_Field.ordered_semidom_class.zero_less_one"
+ "REAL_LT_01" > "Rings.zero_less_one"
"REAL_LTE_TRANS" > "Set.basic_trans_rules_24"
"REAL_LTE_TOTAL" > "HOL4Real.real.REAL_LTE_TOTAL"
"REAL_LTE_ANTSYM" > "HOL4Real.real.REAL_LTE_ANTSYM"
- "REAL_LTE_ADD2" > "OrderedGroup.add_less_le_mono"
- "REAL_LTE_ADD" > "OrderedGroup.add_pos_nonneg"
+ "REAL_LTE_ADD2" > "Groups.add_less_le_mono"
+ "REAL_LTE_ADD" > "Groups.add_pos_nonneg"
"REAL_LT1_POW2" > "HOL4Real.real.REAL_LT1_POW2"
"REAL_LT" > "RealDef.real_of_nat_less_iff"
"REAL_LNEG_UNIQ" > "HOL4Real.real.REAL_LNEG_UNIQ"
"REAL_LINV_UNIQ" > "HOL4Real.real.REAL_LINV_UNIQ"
"REAL_LE_TRANS" > "Set.basic_trans_rules_25"
"REAL_LE_TOTAL" > "Orderings.linorder_class.linorder_linear"
- "REAL_LE_SUB_RADD" > "OrderedGroup.compare_rls_8"
- "REAL_LE_SUB_LADD" > "OrderedGroup.compare_rls_9"
- "REAL_LE_SQUARE" > "Ring_and_Field.zero_le_square"
- "REAL_LE_RNEG" > "OrderedGroup.le_eq_neg"
- "REAL_LE_RMUL_IMP" > "Ring_and_Field.pordered_semiring_class.mult_right_mono"
+ "REAL_LE_SUB_RADD" > "Groups.compare_rls_8"
+ "REAL_LE_SUB_LADD" > "Groups.compare_rls_9"
+ "REAL_LE_SQUARE" > "Rings.zero_le_square"
+ "REAL_LE_RNEG" > "Groups.le_eq_neg"
+ "REAL_LE_RMUL_IMP" > "Rings.mult_right_mono"
"REAL_LE_RMUL" > "RealDef.real_mult_le_cancel_iff1"
"REAL_LE_REFL" > "Finite_Set.max.f_below.below_refl"
- "REAL_LE_RDIV_EQ" > "Ring_and_Field.pos_le_divide_eq"
- "REAL_LE_RDIV" > "Ring_and_Field.mult_imp_le_div_pos"
- "REAL_LE_RADD" > "OrderedGroup.add_le_cancel_right"
+ "REAL_LE_RDIV_EQ" > "Rings.pos_le_divide_eq"
+ "REAL_LE_RDIV" > "Rings.mult_imp_le_div_pos"
+ "REAL_LE_RADD" > "Groups.add_le_cancel_right"
"REAL_LE_POW2" > "Nat_Numeral.zero_compare_simps_12"
"REAL_LE_NEGTOTAL" > "HOL4Real.real.REAL_LE_NEGTOTAL"
- "REAL_LE_NEGR" > "OrderedGroup.le_minus_self_iff"
- "REAL_LE_NEGL" > "OrderedGroup.minus_le_self_iff"
- "REAL_LE_NEG2" > "OrderedGroup.neg_le_iff_le"
- "REAL_LE_NEG" > "OrderedGroup.neg_le_iff_le"
+ "REAL_LE_NEGR" > "Groups.le_minus_self_iff"
+ "REAL_LE_NEGL" > "Groups.minus_le_self_iff"
+ "REAL_LE_NEG2" > "Groups.neg_le_iff_le"
+ "REAL_LE_NEG" > "Groups.neg_le_iff_le"
"REAL_LE_MUL2" > "HOL4Real.real.REAL_LE_MUL2"
- "REAL_LE_MUL" > "Ring_and_Field.mult_nonneg_nonneg"
+ "REAL_LE_MUL" > "Rings.mult_nonneg_nonneg"
"REAL_LE_LT" > "Orderings.order_le_less"
"REAL_LE_LNEG" > "RealDef.real_0_le_add_iff"
- "REAL_LE_LMUL_IMP" > "Ring_and_Field.pordered_comm_semiring_class.mult_mono"
+ "REAL_LE_LMUL_IMP" > "Rings.mult_mono"
"REAL_LE_LMUL" > "RealDef.real_mult_le_cancel_iff2"
- "REAL_LE_LDIV_EQ" > "Ring_and_Field.pos_divide_le_eq"
- "REAL_LE_LDIV" > "Ring_and_Field.mult_imp_div_pos_le"
- "REAL_LE_LADD_IMP" > "OrderedGroup.pordered_ab_semigroup_add_class.add_left_mono"
- "REAL_LE_LADD" > "OrderedGroup.add_le_cancel_left"
- "REAL_LE_INV_EQ" > "Ring_and_Field.inverse_nonnegative_iff_nonnegative"
+ "REAL_LE_LDIV_EQ" > "Rings.pos_divide_le_eq"
+ "REAL_LE_LDIV" > "Rings.mult_imp_div_pos_le"
+ "REAL_LE_LADD_IMP" > "Groups.add_left_mono"
+ "REAL_LE_LADD" > "Groups.add_le_cancel_left"
+ "REAL_LE_INV_EQ" > "Rings.inverse_nonnegative_iff_nonnegative"
"REAL_LE_INV" > "HOL4Real.real.REAL_LE_INV"
- "REAL_LE_DOUBLE" > "OrderedGroup.zero_le_double_add_iff_zero_le_single_add"
+ "REAL_LE_DOUBLE" > "Groups.zero_le_double_add_iff_zero_le_single_add"
"REAL_LE_DIV" > "HOL4Real.real.REAL_LE_DIV"
"REAL_LE_ANTISYM" > "Orderings.order_eq_iff"
"REAL_LE_ADDR" > "HOL4Real.real.REAL_LE_ADDR"
"REAL_LE_ADDL" > "HOL4Real.real.REAL_LE_ADDL"
- "REAL_LE_ADD2" > "OrderedGroup.add_mono"
- "REAL_LE_ADD" > "OrderedGroup.add_nonneg_nonneg"
- "REAL_LE_01" > "Ring_and_Field.zero_le_one"
+ "REAL_LE_ADD2" > "Groups.add_mono"
+ "REAL_LE_ADD" > "Groups.add_nonneg_nonneg"
+ "REAL_LE_01" > "Rings.zero_le_one"
"REAL_LET_TRANS" > "Set.basic_trans_rules_23"
"REAL_LET_TOTAL" > "Orderings.linorder_le_less_linear"
"REAL_LET_ANTISYM" > "HOL4Real.real.REAL_LET_ANTISYM"
- "REAL_LET_ADD2" > "OrderedGroup.add_le_less_mono"
- "REAL_LET_ADD" > "OrderedGroup.add_nonneg_pos"
+ "REAL_LET_ADD2" > "Groups.add_le_less_mono"
+ "REAL_LET_ADD" > "Groups.add_nonneg_pos"
"REAL_LE1_POW2" > "HOL4Real.real.REAL_LE1_POW2"
"REAL_LE" > "RealDef.real_of_nat_le_iff"
- "REAL_LDISTRIB" > "Ring_and_Field.ring_eq_simps_2"
- "REAL_INV_POS" > "Ring_and_Field.positive_imp_inverse_positive"
- "REAL_INV_NZ" > "Ring_and_Field.nonzero_imp_inverse_nonzero"
+ "REAL_LDISTRIB" > "Rings.ring_eq_simps_2"
+ "REAL_INV_POS" > "Rings.positive_imp_inverse_positive"
+ "REAL_INV_NZ" > "Rings.nonzero_imp_inverse_nonzero"
"REAL_INV_MUL" > "HOL4Real.real.REAL_INV_MUL"
"REAL_INV_LT1" > "RealDef.real_inverse_gt_one"
- "REAL_INV_INV" > "Ring_and_Field.inverse_inverse_eq"
- "REAL_INV_EQ_0" > "Ring_and_Field.inverse_nonzero_iff_nonzero"
- "REAL_INV_1OVER" > "Ring_and_Field.inverse_eq_divide"
- "REAL_INV_0" > "Ring_and_Field.division_by_zero_class.inverse_zero"
- "REAL_INVINV" > "Ring_and_Field.nonzero_inverse_inverse_eq"
- "REAL_INV1" > "Ring_and_Field.inverse_1"
+ "REAL_INV_INV" > "Rings.inverse_inverse_eq"
+ "REAL_INV_EQ_0" > "Rings.inverse_nonzero_iff_nonzero"
+ "REAL_INV_1OVER" > "Rings.inverse_eq_divide"
+ "REAL_INV_0" > "Rings.division_by_zero_class.inverse_zero"
+ "REAL_INVINV" > "Rings.nonzero_inverse_inverse_eq"
+ "REAL_INV1" > "Rings.inverse_1"
"REAL_INJ" > "RealDef.real_of_nat_inject"
"REAL_HALF_DOUBLE" > "RComplete.real_sum_of_halves"
"REAL_FACT_NZ" > "HOL4Real.real.REAL_FACT_NZ"
- "REAL_EQ_SUB_RADD" > "Ring_and_Field.ring_eq_simps_15"
- "REAL_EQ_SUB_LADD" > "Ring_and_Field.ring_eq_simps_16"
- "REAL_EQ_RMUL_IMP" > "Ring_and_Field.field_mult_cancel_right_lemma"
- "REAL_EQ_RMUL" > "Ring_and_Field.field_mult_cancel_right"
+ "REAL_EQ_SUB_RADD" > "Rings.ring_eq_simps_15"
+ "REAL_EQ_SUB_LADD" > "Rings.ring_eq_simps_16"
+ "REAL_EQ_RMUL_IMP" > "Rings.field_mult_cancel_right_lemma"
+ "REAL_EQ_RMUL" > "Rings.field_mult_cancel_right"
"REAL_EQ_RDIV_EQ" > "HOL4Real.real.REAL_EQ_RDIV_EQ"
- "REAL_EQ_RADD" > "OrderedGroup.add_right_cancel"
- "REAL_EQ_NEG" > "OrderedGroup.neg_equal_iff_equal"
- "REAL_EQ_MUL_LCANCEL" > "Ring_and_Field.field_mult_cancel_left"
+ "REAL_EQ_RADD" > "Groups.add_right_cancel"
+ "REAL_EQ_NEG" > "Groups.neg_equal_iff_equal"
+ "REAL_EQ_MUL_LCANCEL" > "Rings.field_mult_cancel_left"
"REAL_EQ_LMUL_IMP" > "HOL4Real.real.REAL_EQ_LMUL_IMP"
"REAL_EQ_LMUL2" > "RealDef.real_mult_left_cancel"
- "REAL_EQ_LMUL" > "Ring_and_Field.field_mult_cancel_left"
+ "REAL_EQ_LMUL" > "Rings.field_mult_cancel_left"
"REAL_EQ_LDIV_EQ" > "HOL4Real.real.REAL_EQ_LDIV_EQ"
- "REAL_EQ_LADD" > "OrderedGroup.add_left_cancel"
+ "REAL_EQ_LADD" > "Groups.add_left_cancel"
"REAL_EQ_IMP_LE" > "Orderings.order_eq_refl"
- "REAL_ENTIRE" > "Ring_and_Field.field_mult_eq_0_iff"
+ "REAL_ENTIRE" > "Rings.field_mult_eq_0_iff"
"REAL_DOWN2" > "RealDef.real_lbound_gt_zero"
"REAL_DOWN" > "HOL4Real.real.REAL_DOWN"
"REAL_DOUBLE" > "Int.mult_2"
"REAL_DIV_RMUL" > "HOL4Real.real.REAL_DIV_RMUL"
- "REAL_DIV_REFL" > "Ring_and_Field.divide_self"
+ "REAL_DIV_REFL" > "Rings.divide_self"
"REAL_DIV_MUL2" > "HOL4Real.real.REAL_DIV_MUL2"
- "REAL_DIV_LZERO" > "Ring_and_Field.divide_zero_left"
+ "REAL_DIV_LZERO" > "Rings.divide_zero_left"
"REAL_DIV_LMUL" > "HOL4Real.real.REAL_DIV_LMUL"
"REAL_DIFFSQ" > "HOL4Real.real.REAL_DIFFSQ"
"REAL_ARCH_LEAST" > "HOL4Real.real.REAL_ARCH_LEAST"
@@ -286,20 +286,20 @@
"REAL_ADD_SYM" > "Finite_Set.AC_add.f.AC_2"
"REAL_ADD_SUB2" > "HOL4Real.real.REAL_ADD_SUB2"
"REAL_ADD_SUB" > "HOL4Real.real.REAL_ADD_SUB"
- "REAL_ADD_RINV" > "OrderedGroup.right_minus"
+ "REAL_ADD_RINV" > "Groups.right_minus"
"REAL_ADD_RID_UNIQ" > "HOL4Real.real.REAL_ADD_RID_UNIQ"
"REAL_ADD_RID" > "Finite_Set.AC_add.f_e.ident"
- "REAL_ADD_RDISTRIB" > "Ring_and_Field.ring_eq_simps_1"
+ "REAL_ADD_RDISTRIB" > "Rings.ring_eq_simps_1"
"REAL_ADD_LINV" > "HOL4Compat.REAL_ADD_LINV"
"REAL_ADD_LID_UNIQ" > "HOL4Real.real.REAL_ADD_LID_UNIQ"
"REAL_ADD_LID" > "Finite_Set.AC_add.f_e.left_ident"
- "REAL_ADD_LDISTRIB" > "Ring_and_Field.ring_eq_simps_2"
+ "REAL_ADD_LDISTRIB" > "Rings.ring_eq_simps_2"
"REAL_ADD_ASSOC" > "HOL4Compat.REAL_ADD_ASSOC"
"REAL_ADD2_SUB2" > "HOL4Real.real.REAL_ADD2_SUB2"
"REAL_ADD" > "RealDef.real_of_nat_add"
- "REAL_ABS_TRIANGLE" > "OrderedGroup.abs_triangle_ineq"
- "REAL_ABS_POS" > "OrderedGroup.abs_ge_zero"
- "REAL_ABS_MUL" > "Ring_and_Field.abs_mult"
+ "REAL_ABS_TRIANGLE" > "Groups.abs_triangle_ineq"
+ "REAL_ABS_POS" > "Groups.abs_ge_zero"
+ "REAL_ABS_MUL" > "Rings.abs_mult"
"REAL_ABS_0" > "Int.bin_arith_simps_28"
"REAL_10" > "HOL4Compat.REAL_10"
"REAL_1" > "HOL4Real.real.REAL_1"
@@ -326,25 +326,25 @@
"POW_2" > "Nat_Numeral.power2_eq_square"
"POW_1" > "Power.power_one_right"
"POW_0" > "Power.power_0_Suc"
- "ABS_ZERO" > "OrderedGroup.abs_eq_0"
- "ABS_TRIANGLE" > "OrderedGroup.abs_triangle_ineq"
+ "ABS_ZERO" > "Groups.abs_eq_0"
+ "ABS_TRIANGLE" > "Groups.abs_triangle_ineq"
"ABS_SUM" > "HOL4Real.real.ABS_SUM"
- "ABS_SUB_ABS" > "OrderedGroup.abs_triangle_ineq3"
- "ABS_SUB" > "OrderedGroup.abs_minus_commute"
+ "ABS_SUB_ABS" > "Groups.abs_triangle_ineq3"
+ "ABS_SUB" > "Groups.abs_minus_commute"
"ABS_STILLNZ" > "HOL4Real.real.ABS_STILLNZ"
"ABS_SIGN2" > "HOL4Real.real.ABS_SIGN2"
"ABS_SIGN" > "HOL4Real.real.ABS_SIGN"
"ABS_REFL" > "HOL4Real.real.ABS_REFL"
"ABS_POW2" > "Nat_Numeral.abs_power2"
- "ABS_POS" > "OrderedGroup.abs_ge_zero"
- "ABS_NZ" > "OrderedGroup.zero_less_abs_iff"
- "ABS_NEG" > "OrderedGroup.abs_minus_cancel"
+ "ABS_POS" > "Groups.abs_ge_zero"
+ "ABS_NZ" > "Groups.zero_less_abs_iff"
+ "ABS_NEG" > "Groups.abs_minus_cancel"
"ABS_N" > "RealDef.abs_real_of_nat_cancel"
- "ABS_MUL" > "Ring_and_Field.abs_mult"
+ "ABS_MUL" > "Rings.abs_mult"
"ABS_LT_MUL2" > "HOL4Real.real.ABS_LT_MUL2"
- "ABS_LE" > "OrderedGroup.abs_ge_self"
- "ABS_INV" > "Ring_and_Field.nonzero_abs_inverse"
- "ABS_DIV" > "Ring_and_Field.nonzero_abs_divide"
+ "ABS_LE" > "Groups.abs_ge_self"
+ "ABS_INV" > "Rings.nonzero_abs_inverse"
+ "ABS_DIV" > "Rings.nonzero_abs_divide"
"ABS_CIRCLE" > "HOL4Real.real.ABS_CIRCLE"
"ABS_CASES" > "HOL4Real.real.ABS_CASES"
"ABS_BOUNDS" > "RealDef.abs_le_interval_iff"
@@ -352,7 +352,7 @@
"ABS_BETWEEN2" > "HOL4Real.real.ABS_BETWEEN2"
"ABS_BETWEEN1" > "HOL4Real.real.ABS_BETWEEN1"
"ABS_BETWEEN" > "HOL4Real.real.ABS_BETWEEN"
- "ABS_ABS" > "OrderedGroup.abs_idempotent"
+ "ABS_ABS" > "Groups.abs_idempotent"
"ABS_1" > "Int.bin_arith_simps_29"
"ABS_0" > "Int.bin_arith_simps_28"
--- a/src/HOL/Import/HOL/realax.imp Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/HOL/realax.imp Fri Feb 19 15:21:57 2010 +0000
@@ -29,11 +29,11 @@
"treal_0" > "HOL4Real.realax.treal_0"
"real_neg" > "Algebras.uminus_class.uminus" :: "real => real"
"real_mul" > "Algebras.times_class.times" :: "real => real => real"
- "real_lt" > "Algebras.ord_class.less" :: "real => real => bool"
+ "real_lt" > "Orderings.less" :: "real => real => bool"
"real_add" > "Algebras.plus_class.plus" :: "real => real => real"
"real_1" > "Algebras.one_class.one" :: "real"
"real_0" > "Algebras.zero_class.zero" :: "real"
- "inv" > "Algebras.divide_class.inverse" :: "real => real"
+ "inv" > "Ring.inverse" :: "real => real"
"hreal_of_treal" > "HOL4Real.realax.hreal_of_treal"
thm_maps
@@ -98,10 +98,10 @@
"REAL_LT_TRANS" > "Set.basic_trans_rules_21"
"REAL_LT_TOTAL" > "HOL4Compat.REAL_LT_TOTAL"
"REAL_LT_REFL" > "Orderings.order_less_irrefl"
- "REAL_LT_MUL" > "Ring_and_Field.mult_pos_pos"
- "REAL_LT_IADD" > "OrderedGroup.add_strict_left_mono"
- "REAL_LDISTRIB" > "Ring_and_Field.ring_eq_simps_2"
- "REAL_INV_0" > "Ring_and_Field.division_by_zero_class.inverse_zero"
+ "REAL_LT_MUL" > "Rings.mult_pos_pos"
+ "REAL_LT_IADD" > "Groups.add_strict_left_mono"
+ "REAL_LDISTRIB" > "Rings.ring_eq_simps_2"
+ "REAL_INV_0" > "Rings.division_by_zero_class.inverse_zero"
"REAL_ADD_SYM" > "Finite_Set.AC_add.f.AC_2"
"REAL_ADD_LINV" > "HOL4Compat.REAL_ADD_LINV"
"REAL_ADD_LID" > "Finite_Set.AC_add.f_e.left_ident"
--- a/src/HOL/Import/hol4rews.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/hol4rews.ML Fri Feb 19 15:21:57 2010 +0000
@@ -371,7 +371,7 @@
fun process ((bthy,bthm), hth as (_,thm)) thy =
let
val thm1 = rewrite_rule (map (Thm.transfer thy) rews) (Thm.transfer thy thm);
- val thm2 = Drule.standard thm1;
+ val thm2 = Drule.export_without_context thm1;
in
thy
|> PureThy.store_thm (Binding.name bthm, thm2)
--- a/src/HOL/Import/shuffler.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/shuffler.ML Fri Feb 19 15:21:57 2010 +0000
@@ -100,7 +100,7 @@
val th4 = implies_elim_list (assume cPPQ) [th3,th3]
|> implies_intr_list [cPPQ,cP]
in
- equal_intr th4 th1 |> Drule.standard
+ equal_intr th4 th1 |> Drule.export_without_context
end
val imp_comm =
@@ -120,7 +120,7 @@
val th2 = implies_elim_list (assume cQPR) [assume cQ,assume cP]
|> implies_intr_list [cQPR,cP,cQ]
in
- equal_intr th1 th2 |> Drule.standard
+ equal_intr th1 th2 |> Drule.export_without_context
end
val def_norm =
@@ -147,7 +147,7 @@
|> forall_intr cv
|> implies_intr cPQ
in
- equal_intr th1 th2 |> Drule.standard
+ equal_intr th1 th2 |> Drule.export_without_context
end
val all_comm =
@@ -173,7 +173,7 @@
|> forall_intr_list [cy,cx]
|> implies_intr cl
in
- equal_intr th1 th2 |> Drule.standard
+ equal_intr th1 th2 |> Drule.export_without_context
end
val equiv_comm =
@@ -187,7 +187,7 @@
val th1 = assume ctu |> symmetric |> implies_intr ctu
val th2 = assume cut |> symmetric |> implies_intr cut
in
- equal_intr th1 th2 |> Drule.standard
+ equal_intr th1 th2 |> Drule.export_without_context
end
(* This simplification procedure rewrites !!x y. P x y
--- a/src/HOL/Import/xmlconv.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Import/xmlconv.ML Fri Feb 19 15:21:57 2010 +0000
@@ -218,12 +218,9 @@
| xml_of_mixfix Structure = wrap_empty "structure"
| xml_of_mixfix (Mixfix args) = wrap "mixfix" (xml_of_triple xml_of_string (xml_of_list xml_of_int) xml_of_int) args
| xml_of_mixfix (Delimfix s) = wrap "delimfix" xml_of_string s
- | xml_of_mixfix (InfixName args) = wrap "infixname" (xml_of_pair xml_of_string xml_of_int) args
- | xml_of_mixfix (InfixlName args) = wrap "infixlname" (xml_of_pair xml_of_string xml_of_int) args
- | xml_of_mixfix (InfixrName args) = wrap "infixrname" (xml_of_pair xml_of_string xml_of_int) args
- | xml_of_mixfix (Infix i) = wrap "infix" xml_of_int i
- | xml_of_mixfix (Infixl i) = wrap "infixl" xml_of_int i
- | xml_of_mixfix (Infixr i) = wrap "infixr" xml_of_int i
+ | xml_of_mixfix (Infix args) = wrap "infix" (xml_of_pair xml_of_string xml_of_int) args
+ | xml_of_mixfix (Infixl args) = wrap "infixl" (xml_of_pair xml_of_string xml_of_int) args
+ | xml_of_mixfix (Infixr args) = wrap "infixr" (xml_of_pair xml_of_string xml_of_int) args
| xml_of_mixfix (Binder args) = wrap "binder" (xml_of_triple xml_of_string xml_of_int xml_of_int) args
fun mixfix_of_xml e =
@@ -232,12 +229,9 @@
| "structure" => unwrap_empty Structure
| "mixfix" => unwrap Mixfix (triple_of_xml string_of_xml (list_of_xml int_of_xml) int_of_xml)
| "delimfix" => unwrap Delimfix string_of_xml
- | "infixname" => unwrap InfixName (pair_of_xml string_of_xml int_of_xml)
- | "infixlname" => unwrap InfixlName (pair_of_xml string_of_xml int_of_xml)
- | "infixrname" => unwrap InfixrName (pair_of_xml string_of_xml int_of_xml)
- | "infix" => unwrap Infix int_of_xml
- | "infixl" => unwrap Infixl int_of_xml
- | "infixr" => unwrap Infixr int_of_xml
+ | "infix" => unwrap Infix (pair_of_xml string_of_xml int_of_xml)
+ | "infixl" => unwrap Infixl (pair_of_xml string_of_xml int_of_xml)
+ | "infixr" => unwrap Infixr (pair_of_xml string_of_xml int_of_xml)
| "binder" => unwrap Binder (triple_of_xml string_of_xml int_of_xml int_of_xml)
| _ => parse_err "mixfix"
) e
--- a/src/HOL/Inductive.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Inductive.thy Fri Feb 19 15:21:57 2010 +0000
@@ -301,10 +301,9 @@
fun fun_tr ctxt [cs] =
let
val x = Free (Name.variant (Term.add_free_names cs []) "x", dummyT);
- val ft = Datatype_Case.case_tr true Datatype_Data.info_of_constr
- ctxt [x, cs]
+ val ft = Datatype_Case.case_tr true Datatype_Data.info_of_constr ctxt [x, cs];
in lambda x ft end
-in [("_lam_pats_syntax", fun_tr)] end
+in [(@{syntax_const "_lam_pats_syntax"}, fun_tr)] end
*}
end
--- a/src/HOL/Int.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Int.thy Fri Feb 19 15:21:57 2010 +0000
@@ -208,7 +208,7 @@
end
-instance int :: pordered_cancel_ab_semigroup_add
+instance int :: ordered_cancel_ab_semigroup_add
proof
fix i j k :: int
show "i \<le> j \<Longrightarrow> k + i \<le> k + j"
@@ -245,7 +245,7 @@
done
text{*The integers form an ordered integral domain*}
-instance int :: ordered_idom
+instance int :: linordered_idom
proof
fix i j k :: int
show "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
@@ -256,13 +256,6 @@
by (simp only: zsgn_def)
qed
-instance int :: lordered_ring
-proof
- fix k :: int
- show "abs k = sup k (- k)"
- by (auto simp add: sup_int_def zabs_def less_minus_self_iff [symmetric])
-qed
-
lemma zless_imp_add1_zle: "w < z \<Longrightarrow> w + (1\<Colon>int) \<le> z"
apply (cases w, cases z)
apply (simp add: less le add One_int_def)
@@ -314,7 +307,7 @@
by (cases z, simp add: algebra_simps of_int minus)
lemma of_int_diff [simp]: "of_int (w - z) = of_int w - of_int z"
-by (simp add: OrderedGroup.diff_minus diff_minus)
+by (simp add: diff_minus Groups.diff_minus)
lemma of_int_mult [simp]: "of_int (w*z) = of_int w * of_int z"
apply (cases w, cases z)
@@ -331,7 +324,7 @@
end
-context ordered_idom
+context linordered_idom
begin
lemma of_int_le_iff [simp]:
@@ -370,8 +363,8 @@
end
-text{*Every @{text ordered_idom} has characteristic zero.*}
-subclass (in ordered_idom) ring_char_0 by intro_locales
+text{*Every @{text linordered_idom} has characteristic zero.*}
+subclass (in linordered_idom) ring_char_0 by intro_locales
lemma of_int_eq_id [simp]: "of_int = id"
proof
@@ -398,6 +391,7 @@
lemma nat_int [simp]: "nat (of_nat n) = n"
by (simp add: nat int_def)
+(* FIXME: duplicates nat_0 *)
lemma nat_zero [simp]: "nat 0 = 0"
by (simp add: Zero_int_def nat)
@@ -526,10 +520,10 @@
text{*This version is proved for all ordered rings, not just integers!
It is proved here because attribute @{text arith_split} is not available
- in theory @{text Ring_and_Field}.
+ in theory @{text Rings}.
But is it really better than just rewriting with @{text abs_if}?*}
lemma abs_split [arith_split,noatp]:
- "P(abs(a::'a::ordered_idom)) = ((0 \<le> a --> P a) & (a < 0 --> P(-a)))"
+ "P(abs(a::'a::linordered_idom)) = ((0 \<le> a --> P a) & (a < 0 --> P(-a)))"
by (force dest: order_less_le_trans simp add: abs_if linorder_not_less)
lemma negD: "(x \<Colon> int) < 0 \<Longrightarrow> \<exists>n. x = - (of_nat (Suc n))"
@@ -611,7 +605,7 @@
"_Numeral" :: "num_const \<Rightarrow> 'a" ("_")
use "Tools/numeral_syntax.ML"
-setup NumeralSyntax.setup
+setup Numeral_Syntax.setup
abbreviation
"Numeral0 \<equiv> number_of Pls"
@@ -633,10 +627,10 @@
lemmas
max_number_of [simp] = max_def
- [of "number_of u" "number_of v", standard, simp]
+ [of "number_of u" "number_of v", standard]
and
min_number_of [simp] = min_def
- [of "number_of u" "number_of v", standard, simp]
+ [of "number_of u" "number_of v", standard]
-- {* unfolding @{text minx} and @{text max} on numerals *}
lemmas numeral_simps =
@@ -804,7 +798,7 @@
text {* Preliminaries *}
lemma even_less_0_iff:
- "a + a < 0 \<longleftrightarrow> a < (0::'a::ordered_idom)"
+ "a + a < 0 \<longleftrightarrow> a < (0::'a::linordered_idom)"
proof -
have "a + a < 0 \<longleftrightarrow> (1+1)*a < 0" by (simp add: left_distrib)
also have "(1+1)*a < 0 \<longleftrightarrow> a < 0"
@@ -1067,7 +1061,7 @@
lemma not_iszero_1: "~ iszero 1"
by (simp add: iszero_def eq_commute)
-lemma eq_number_of_eq:
+lemma eq_number_of_eq [simp]:
"((number_of x::'a::number_ring) = number_of y) =
iszero (number_of (x + uminus y) :: 'a)"
unfolding iszero_def number_of_add number_of_minus
@@ -1137,7 +1131,7 @@
by (auto simp add: iszero_def number_of_eq numeral_simps)
qed
-lemmas iszero_simps =
+lemmas iszero_simps [simp] =
iszero_0 not_iszero_1
iszero_number_of_Pls nonzero_number_of_Min
iszero_number_of_Bit0 iszero_number_of_Bit1
@@ -1147,7 +1141,7 @@
subsubsection {* The Less-Than Relation *}
lemma double_less_0_iff:
- "(a + a < 0) = (a < (0::'a::ordered_idom))"
+ "(a + a < 0) = (a < (0::'a::linordered_idom))"
proof -
have "(a + a < 0) = ((1+1)*a < 0)" by (simp add: left_distrib)
also have "... = (a < 0)"
@@ -1180,7 +1174,7 @@
text {* Absolute value (@{term abs}) *}
lemma abs_number_of:
- "abs(number_of x::'a::{ordered_idom,number_ring}) =
+ "abs(number_of x::'a::{linordered_idom,number_ring}) =
(if number_of x < (0::'a) then -number_of x else number_of x)"
by (simp add: abs_if)
@@ -1214,18 +1208,18 @@
text {* Simplification of relational operations *}
lemma less_number_of [simp]:
- "(number_of x::'a::{ordered_idom,number_ring}) < number_of y \<longleftrightarrow> x < y"
+ "(number_of x::'a::{linordered_idom,number_ring}) < number_of y \<longleftrightarrow> x < y"
unfolding number_of_eq by (rule of_int_less_iff)
lemma le_number_of [simp]:
- "(number_of x::'a::{ordered_idom,number_ring}) \<le> number_of y \<longleftrightarrow> x \<le> y"
+ "(number_of x::'a::{linordered_idom,number_ring}) \<le> number_of y \<longleftrightarrow> x \<le> y"
unfolding number_of_eq by (rule of_int_le_iff)
lemma eq_number_of [simp]:
"(number_of x::'a::{ring_char_0,number_ring}) = number_of y \<longleftrightarrow> x = y"
unfolding number_of_eq by (rule of_int_eq_iff)
-lemmas rel_simps [simp] =
+lemmas rel_simps =
less_number_of less_bin_simps
le_number_of le_bin_simps
eq_number_of_eq eq_bin_simps
@@ -1247,7 +1241,7 @@
lemma add_number_of_diff1:
"number_of v + (number_of w - c) =
number_of(v + w) - (c::'a::number_ring)"
- by (simp add: diff_minus add_number_of_left)
+ by (simp add: diff_minus)
lemma add_number_of_diff2 [simp]:
"number_of v + (c - number_of w) =
@@ -1362,7 +1356,7 @@
lemma Ints_odd_less_0:
assumes in_Ints: "a \<in> Ints"
- shows "(1 + a + a < 0) = (a < (0::'a::ordered_idom))"
+ shows "(1 + a + a < 0) = (a < (0::'a::linordered_idom))"
proof -
from in_Ints have "a \<in> range of_int" unfolding Ints_def [symmetric] .
then obtain z where a: "a = of_int z" ..
@@ -1444,7 +1438,7 @@
text{*Allow 1 on either or both sides*}
lemma one_add_one_is_two: "1 + 1 = (2::'a::number_ring)"
-by (simp del: numeral_1_eq_1 add: numeral_1_eq_1 [symmetric] add_number_of_eq)
+by (simp del: numeral_1_eq_1 add: numeral_1_eq_1 [symmetric])
lemmas add_special =
one_add_one_is_two
@@ -1519,11 +1513,11 @@
finally show ?thesis .
qed
-lemma abs_minus_one [simp]: "abs (-1) = (1::'a::{ordered_idom,number_ring})"
+lemma abs_minus_one [simp]: "abs (-1) = (1::'a::{linordered_idom,number_ring})"
by (simp add: abs_if)
lemma abs_power_minus_one [simp]:
- "abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring})"
+ "abs(-1 ^ n) = (1::'a::{linordered_idom,number_ring})"
by (simp add: power_abs)
lemma of_int_number_of_eq [simp]:
@@ -1565,6 +1559,7 @@
lemmas diff_int_def_symmetric = diff_int_def [symmetric, simp]
+(* FIXME: duplicates nat_zero *)
lemma nat_0: "nat 0 = 0"
by (simp add: nat_eq_iff)
@@ -1906,12 +1901,12 @@
text{*To Simplify Inequalities Where One Side is the Constant 1*}
lemma less_minus_iff_1 [simp,noatp]:
- fixes b::"'b::{ordered_idom,number_ring}"
+ fixes b::"'b::{linordered_idom,number_ring}"
shows "(1 < - b) = (b < -1)"
by auto
lemma le_minus_iff_1 [simp,noatp]:
- fixes b::"'b::{ordered_idom,number_ring}"
+ fixes b::"'b::{linordered_idom,number_ring}"
shows "(1 \<le> - b) = (b \<le> -1)"
by auto
@@ -1921,12 +1916,12 @@
by (subst equation_minus_iff, auto)
lemma minus_less_iff_1 [simp,noatp]:
- fixes a::"'b::{ordered_idom,number_ring}"
+ fixes a::"'b::{linordered_idom,number_ring}"
shows "(- a < 1) = (-1 < a)"
by auto
lemma minus_le_iff_1 [simp,noatp]:
- fixes a::"'b::{ordered_idom,number_ring}"
+ fixes a::"'b::{linordered_idom,number_ring}"
shows "(- a \<le> 1) = (-1 \<le> a)"
by auto
@@ -1987,10 +1982,10 @@
lemma minus1_divide [simp]:
"-1 / (x::'a::{field,division_by_zero,number_ring}) = - (1/x)"
-by (simp add: divide_inverse inverse_minus_eq)
+by (simp add: divide_inverse)
lemma half_gt_zero_iff:
- "(0 < r/2) = (0 < (r::'a::{ordered_field,division_by_zero,number_ring}))"
+ "(0 < r/2) = (0 < (r::'a::{linordered_field,division_by_zero,number_ring}))"
by auto
lemmas half_gt_zero [simp] = half_gt_zero_iff [THEN iffD2, standard]
@@ -2105,7 +2100,7 @@
assumes mp:"m \<noteq>(0::int)" shows "(m * n dvd m) = (\<bar>n\<bar> = 1)"
proof
assume n1: "\<bar>n\<bar> = 1" thus "m * n dvd m"
- by (cases "n >0", auto simp add: minus_dvd_iff minus_equation_iff)
+ by (cases "n >0", auto simp add: minus_equation_iff)
next
assume H: "m * n dvd m" hence H2: "m * n dvd m * 1" by simp
from zdvd_mult_cancel[OF H2 mp] show "\<bar>n\<bar> = 1" by (simp only: zdvd1_eq)
@@ -2324,9 +2319,9 @@
lemmas zadd_assoc = add_assoc [of "z1::int" "z2" "z3", standard]
lemmas zadd_left_commute = add_left_commute [of "x::int" "y" "z", standard]
lemmas zadd_ac = zadd_assoc zadd_commute zadd_left_commute
-lemmas zmult_ac = OrderedGroup.mult_ac
-lemmas zadd_0 = OrderedGroup.add_0_left [of "z::int", standard]
-lemmas zadd_0_right = OrderedGroup.add_0_left [of "z::int", standard]
+lemmas zmult_ac = mult_ac
+lemmas zadd_0 = add_0_left [of "z::int", standard]
+lemmas zadd_0_right = add_0_right [of "z::int", standard]
lemmas zadd_zminus_inverse2 = left_minus [of "z::int", standard]
lemmas zmult_zminus = mult_minus_left [of "z::int" "w", standard]
lemmas zmult_commute = mult_commute [of "z::int" "w", standard]
--- a/src/HOL/IsaMakefile Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/IsaMakefile Fri Feb 19 15:21:57 2010 +0000
@@ -52,6 +52,7 @@
HOL-Nominal-Examples \
HOL-Number_Theory \
HOL-Old_Number_Theory \
+ HOL-Quotient_Examples \
HOL-Probability \
HOL-Prolog \
HOL-Proofs-Extraction \
@@ -145,15 +146,16 @@
Complete_Lattice.thy \
Datatype.thy \
Extraction.thy \
+ Fields.thy \
Finite_Set.thy \
Fun.thy \
FunDef.thy \
+ Groups.thy \
Inductive.thy \
Lattices.thy \
Nat.thy \
Nitpick.thy \
Option.thy \
- OrderedGroup.thy \
Orderings.thy \
Plain.thy \
Power.thy \
@@ -162,7 +164,7 @@
Record.thy \
Refute.thy \
Relation.thy \
- Ring_and_Field.thy \
+ Rings.thy \
SAT.thy \
Set.thy \
Sum_Type.thy \
@@ -206,6 +208,7 @@
Tools/Nitpick/nitpick_mono.ML \
Tools/Nitpick/nitpick_nut.ML \
Tools/Nitpick/nitpick_peephole.ML \
+ Tools/Nitpick/nitpick_preproc.ML \
Tools/Nitpick/nitpick_rep.ML \
Tools/Nitpick/nitpick_scope.ML \
Tools/Nitpick/nitpick_tests.ML \
@@ -263,6 +266,7 @@
Presburger.thy \
Predicate_Compile.thy \
Quickcheck.thy \
+ Quotient.thy \
Random.thy \
Random_Sequence.thy \
Recdef.thy \
@@ -305,6 +309,11 @@
Tools/Qelim/generated_cooper.ML \
Tools/Qelim/presburger.ML \
Tools/Qelim/qelim.ML \
+ Tools/Quotient/quotient_def.ML \
+ Tools/Quotient/quotient_info.ML \
+ Tools/Quotient/quotient_tacs.ML \
+ Tools/Quotient/quotient_term.ML \
+ Tools/Quotient/quotient_typ.ML \
Tools/recdef.ML \
Tools/res_atp.ML \
Tools/res_axioms.ML \
@@ -384,17 +393,17 @@
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/Quotient.thy Library/Quicksort.thy Library/Nat_Infinity.thy \
- Library/Word.thy Library/README.html Library/Continuity.thy \
+ Library/Lattice_Algebras.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_Type.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 \
Library/Ramsey.thy Library/Zorn.thy Library/Library/ROOT.ML \
Library/Library/document/root.tex Library/Library/document/root.bib \
Library/Transitive_Closure_Table.thy Library/While_Combinator.thy \
Library/Product_ord.thy Library/Char_nat.thy \
- Library/Char_ord.thy Library/Option_ord.thy \
Library/Sublist_Order.thy Library/List_lexord.thy \
Library/Coinductive_List.thy Library/AssocList.thy \
Library/Formal_Power_Series.thy Library/Binomial.thy \
@@ -405,7 +414,10 @@
Library/Diagonalize.thy Library/RBT.thy Library/Univ_Poly.thy \
Library/Poly_Deriv.thy Library/Polynomial.thy Library/Preorder.thy \
Library/Product_plus.thy Library/Product_Vector.thy Library/Tree.thy \
- Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML \
+ Library/Enum.thy Library/Float.thy Library/Quotient_List.thy \
+ Library/Quotient_Option.thy Library/Quotient_Product.thy \
+ Library/Quotient_Sum.thy Library/Quotient_Syntax.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/SML_Quickcheck.thy
@@ -622,12 +634,13 @@
$(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/Integer_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
+ Nitpick_Examples/Hotel_Nits.thy Nitpick_Examples/Induct_Nits.thy \
+ Nitpick_Examples/Integer_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
@@ -785,18 +798,21 @@
Decision_Procs/Approximation.thy \
Decision_Procs/Commutative_Ring.thy \
Decision_Procs/Commutative_Ring_Complete.thy \
- Decision_Procs/commutative_ring_tac.ML \
Decision_Procs/Cooper.thy \
- Decision_Procs/cooper_tac.ML \
+ Decision_Procs/Decision_Procs.thy \
Decision_Procs/Dense_Linear_Order.thy \
Decision_Procs/Ferrack.thy \
- Decision_Procs/ferrack_tac.ML \
Decision_Procs/MIR.thy \
- Decision_Procs/mir_tac.ML \
- Decision_Procs/Decision_Procs.thy \
- Decision_Procs/ex/Dense_Linear_Order_Ex.thy \
+ Decision_Procs/Parametric_Ferrante_Rackoff.thy \
+ Decision_Procs/Polynomial_List.thy \
+ Decision_Procs/Reflected_Multivariate_Polynomial.thy \
+ Decision_Procs/commutative_ring_tac.ML \
+ Decision_Procs/cooper_tac.ML \
Decision_Procs/ex/Approximation_Ex.thy \
Decision_Procs/ex/Commutative_Ring_Ex.thy \
+ Decision_Procs/ex/Dense_Linear_Order_Ex.thy \
+ Decision_Procs/ferrack_tac.ML \
+ Decision_Procs/mir_tac.ML \
Decision_Procs/ROOT.ML
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Decision_Procs
@@ -1220,7 +1236,8 @@
SMT/Tools/smt_solver.ML SMT/Tools/cvc3_solver.ML \
SMT/Tools/yices_solver.ML SMT/Tools/z3_proof_terms.ML \
SMT/Tools/z3_proof_rules.ML SMT/Tools/z3_proof.ML \
- SMT/Tools/z3_model.ML SMT/Tools/z3_interface.ML SMT/Tools/z3_solver.ML
+ SMT/Tools/z3_model.ML SMT/Tools/z3_interface.ML \
+ SMT/Tools/z3_solver.ML $(SRC)/Tools/Cache_IO/cache_io.ML
@cd SMT; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL-Word HOL-SMT
@@ -1266,6 +1283,15 @@
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Mutabelle
+## HOL-Quotient_Examples
+
+HOL-Quotient_Examples: HOL $(LOG)/HOL-Quotient_Examples.gz
+
+$(LOG)/HOL-Quotient_Examples.gz: $(OUT)/HOL \
+ Quotient_Examples/LarryInt.thy Quotient_Examples/LarryDatatype.thy
+ @$(ISABELLE_TOOL) usedir $(OUT)/HOL Quotient_Examples
+
+
## clean
clean:
--- a/src/HOL/Isar_Examples/Hoare.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Isar_Examples/Hoare.thy Fri Feb 19 15:21:57 2010 +0000
@@ -228,18 +228,18 @@
"_Assert" :: "'a => 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
translations
- ".{b}." => "Collect .(b)."
+ ".{b}." => "CONST Collect .(b)."
"B [a/\<acute>x]" => ".{\<acute>(_update_name x (\<lambda>_. a)) \<in> B}."
- "\<acute>x := a" => "Basic .(\<acute>(_update_name x (\<lambda>_. a)))."
- "IF b THEN c1 ELSE c2 FI" => "Cond .{b}. c1 c2"
- "WHILE b INV i DO c OD" => "While .{b}. i c"
+ "\<acute>x := a" => "CONST Basic .(\<acute>(_update_name x (\<lambda>_. a)))."
+ "IF b THEN c1 ELSE c2 FI" => "CONST Cond .{b}. c1 c2"
+ "WHILE b INV i DO c OD" => "CONST While .{b}. i c"
"WHILE b DO c OD" == "WHILE b INV CONST undefined DO c OD"
parse_translation {*
let
- fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
+ fun quote_tr [t] = Syntax.quote_tr @{syntax_const "_antiquote"} t
| quote_tr ts = raise TERM ("quote_tr", ts);
- in [("_quote", quote_tr)] end
+ in [(@{syntax_const "_quote"}, quote_tr)] end
*}
text {*
@@ -251,37 +251,30 @@
print_translation {*
let
fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ Term.list_comb (f $ Syntax.quote_tr' @{syntax_const "_antiquote"} t, ts)
| quote_tr' _ _ = raise Match;
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
+ val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
quote_tr' (Syntax.const name) (t :: ts)
| bexp_tr' _ _ = raise Match;
- fun upd_tr' (x_upd, T) =
- (case try (unsuffix Record.updateN) x_upd of
- SOME x => (x, if T = dummyT then T else Term.domain_type T)
- | NONE => raise Match);
-
- fun update_name_tr' (Free x) = Free (upd_tr' x)
- | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
- c $ Free (upd_tr' x)
- | update_name_tr' (Const x) = Const (upd_tr' x)
- | update_name_tr' _ = raise Match;
-
- fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
- | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
+ fun K_tr' (Abs (_, _, t)) =
+ if null (loose_bnos t) then t else raise Match
+ | K_tr' (Abs (_, _, Abs (_, _, t) $ Bound 0)) =
+ if null (loose_bnos t) then t else raise Match
| K_tr' _ = raise Match;
fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
+ quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax.update_name_tr' f)
(Abs (x, dummyT, K_tr' k) :: ts)
| assign_tr' _ = raise Match;
in
- [("Collect", assert_tr'), ("Basic", assign_tr'),
- ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv")]
+ [(@{const_syntax Collect}, assert_tr'),
+ (@{const_syntax Basic}, assign_tr'),
+ (@{const_syntax Cond}, bexp_tr' @{syntax_const "_Cond"}),
+ (@{const_syntax While}, bexp_tr' @{syntax_const "_While_inv"})]
end
*}
--- a/src/HOL/Lattices.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Lattices.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,7 +5,7 @@
header {* Abstract lattices *}
theory Lattices
-imports Orderings
+imports Orderings Groups
begin
subsection {* Lattices *}
@@ -16,13 +16,13 @@
top ("\<top>") and
bot ("\<bottom>")
-class lower_semilattice = order +
+class semilattice_inf = order +
fixes inf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)
assumes inf_le1 [simp]: "x \<sqinter> y \<sqsubseteq> x"
and inf_le2 [simp]: "x \<sqinter> y \<sqsubseteq> y"
and inf_greatest: "x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<sqinter> z"
-class upper_semilattice = order +
+class semilattice_sup = order +
fixes sup :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)
assumes sup_ge1 [simp]: "x \<sqsubseteq> x \<squnion> y"
and sup_ge2 [simp]: "y \<sqsubseteq> x \<squnion> y"
@@ -32,18 +32,18 @@
text {* Dual lattice *}
lemma dual_semilattice:
- "lower_semilattice (op \<ge>) (op >) sup"
-by (rule lower_semilattice.intro, rule dual_order)
+ "semilattice_inf (op \<ge>) (op >) sup"
+by (rule semilattice_inf.intro, rule dual_order)
(unfold_locales, simp_all add: sup_least)
end
-class lattice = lower_semilattice + upper_semilattice
+class lattice = semilattice_inf + semilattice_sup
subsubsection {* Intro and elim rules*}
-context lower_semilattice
+context semilattice_inf
begin
lemma le_infI1:
@@ -69,13 +69,13 @@
by (auto intro: le_infI1 antisym dest: eq_iff [THEN iffD1])
lemma mono_inf:
- fixes f :: "'a \<Rightarrow> 'b\<Colon>lower_semilattice"
+ fixes f :: "'a \<Rightarrow> 'b\<Colon>semilattice_inf"
shows "mono f \<Longrightarrow> f (A \<sqinter> B) \<sqsubseteq> f A \<sqinter> f B"
by (auto simp add: mono_def intro: Lattices.inf_greatest)
end
-context upper_semilattice
+context semilattice_sup
begin
lemma le_supI1:
@@ -103,7 +103,7 @@
by (auto intro: le_supI2 antisym dest: eq_iff [THEN iffD1])
lemma mono_sup:
- fixes f :: "'a \<Rightarrow> 'b\<Colon>upper_semilattice"
+ fixes f :: "'a \<Rightarrow> 'b\<Colon>semilattice_sup"
shows "mono f \<Longrightarrow> f A \<squnion> f B \<sqsubseteq> f (A \<squnion> B)"
by (auto simp add: mono_def intro: Lattices.sup_least)
@@ -112,7 +112,7 @@
subsubsection {* Equational laws *}
-sublocale lower_semilattice < inf!: semilattice inf
+sublocale semilattice_inf < inf!: semilattice inf
proof
fix a b c
show "(a \<sqinter> b) \<sqinter> c = a \<sqinter> (b \<sqinter> c)"
@@ -123,7 +123,7 @@
by (rule antisym) auto
qed
-context lower_semilattice
+context semilattice_inf
begin
lemma inf_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
@@ -151,7 +151,7 @@
end
-sublocale upper_semilattice < sup!: semilattice sup
+sublocale semilattice_sup < sup!: semilattice sup
proof
fix a b c
show "(a \<squnion> b) \<squnion> c = a \<squnion> (b \<squnion> c)"
@@ -162,7 +162,7 @@
by (rule antisym) auto
qed
-context upper_semilattice
+context semilattice_sup
begin
lemma sup_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
@@ -195,7 +195,7 @@
lemma dual_lattice:
"lattice (op \<ge>) (op >) sup inf"
- by (rule lattice.intro, rule dual_semilattice, rule upper_semilattice.intro, rule dual_order)
+ by (rule lattice.intro, rule dual_semilattice, rule semilattice_sup.intro, rule dual_order)
(unfold_locales, auto)
lemma inf_sup_absorb: "x \<sqinter> (x \<squnion> y) = x"
@@ -246,7 +246,7 @@
subsubsection {* Strict order *}
-context lower_semilattice
+context semilattice_inf
begin
lemma less_infI1:
@@ -259,13 +259,13 @@
end
-context upper_semilattice
+context semilattice_sup
begin
lemma less_supI1:
"x \<sqsubset> a \<Longrightarrow> x \<sqsubset> a \<squnion> b"
proof -
- interpret dual: lower_semilattice "op \<ge>" "op >" sup
+ interpret dual: semilattice_inf "op \<ge>" "op >" sup
by (fact dual_semilattice)
assume "x \<sqsubset> a"
then show "x \<sqsubset> a \<squnion> b"
@@ -275,7 +275,7 @@
lemma less_supI2:
"x \<sqsubset> b \<Longrightarrow> x \<sqsubset> a \<squnion> b"
proof -
- interpret dual: lower_semilattice "op \<ge>" "op >" sup
+ interpret dual: semilattice_inf "op \<ge>" "op >" sup
by (fact dual_semilattice)
assume "x \<sqsubset> b"
then show "x \<sqsubset> a \<squnion> b"
@@ -492,7 +492,7 @@
subsection {* Uniqueness of inf and sup *}
-lemma (in lower_semilattice) inf_unique:
+lemma (in semilattice_inf) inf_unique:
fixes f (infixl "\<triangle>" 70)
assumes le1: "\<And>x y. x \<triangle> y \<sqsubseteq> x" and le2: "\<And>x y. x \<triangle> y \<sqsubseteq> y"
and greatest: "\<And>x y z. x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<triangle> z"
@@ -504,7 +504,7 @@
show "x \<sqinter> y \<sqsubseteq> x \<triangle> y" by (rule leI) simp_all
qed
-lemma (in upper_semilattice) sup_unique:
+lemma (in semilattice_sup) sup_unique:
fixes f (infixl "\<nabla>" 70)
assumes ge1 [simp]: "\<And>x y. x \<sqsubseteq> x \<nabla> y" and ge2: "\<And>x y. y \<sqsubseteq> x \<nabla> y"
and least: "\<And>x y z. y \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> y \<nabla> z \<sqsubseteq> x"
@@ -527,10 +527,10 @@
by (auto simp add: min_def max_def)
qed (auto simp add: min_def max_def not_le less_imp_le)
-lemma inf_min: "inf = (min \<Colon> 'a\<Colon>{lower_semilattice, linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
+lemma inf_min: "inf = (min \<Colon> 'a\<Colon>{semilattice_inf, linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
by (rule ext)+ (auto intro: antisym)
-lemma sup_max: "sup = (max \<Colon> 'a\<Colon>{upper_semilattice, linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
+lemma sup_max: "sup = (max \<Colon> 'a\<Colon>{semilattice_sup, linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
by (rule ext)+ (auto intro: antisym)
lemmas le_maxI1 = min_max.sup_ge1
--- a/src/HOL/Library/Abstract_Rat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Abstract_Rat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -332,7 +332,7 @@
lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y ::'a :: {ring_char_0, division_by_zero,field})" by (simp add: Ndiv_def)
lemma Nlt0_iff[simp]: assumes nx: "isnormNum x"
- shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field})< 0) = 0>\<^sub>N x "
+ shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field})< 0) = 0>\<^sub>N x "
proof-
have " \<exists> a b. x = (a,b)" by simp
then obtain a b where x[simp]:"x = (a,b)" by blast
@@ -345,7 +345,7 @@
qed
lemma Nle0_iff[simp]:assumes nx: "isnormNum x"
- shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field}) \<le> 0) = 0\<ge>\<^sub>N x"
+ shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field}) \<le> 0) = 0\<ge>\<^sub>N x"
proof-
have " \<exists> a b. x = (a,b)" by simp
then obtain a b where x[simp]:"x = (a,b)" by blast
@@ -357,7 +357,7 @@
ultimately show ?thesis by blast
qed
-lemma Ngt0_iff[simp]:assumes nx: "isnormNum x" shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field})> 0) = 0<\<^sub>N x"
+lemma Ngt0_iff[simp]:assumes nx: "isnormNum x" shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field})> 0) = 0<\<^sub>N x"
proof-
have " \<exists> a b. x = (a,b)" by simp
then obtain a b where x[simp]:"x = (a,b)" by blast
@@ -369,7 +369,7 @@
ultimately show ?thesis by blast
qed
lemma Nge0_iff[simp]:assumes nx: "isnormNum x"
- shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field}) \<ge> 0) = 0\<le>\<^sub>N x"
+ shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field}) \<ge> 0) = 0\<le>\<^sub>N x"
proof-
have " \<exists> a b. x = (a,b)" by simp
then obtain a b where x[simp]:"x = (a,b)" by blast
@@ -382,7 +382,7 @@
qed
lemma Nlt_iff[simp]: assumes nx: "isnormNum x" and ny: "isnormNum y"
- shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field}) < INum y) = (x <\<^sub>N y)"
+ shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field}) < INum y) = (x <\<^sub>N y)"
proof-
let ?z = "0::'a"
have "((INum x ::'a) < INum y) = (INum (x -\<^sub>N y) < ?z)" using nx ny by simp
@@ -391,7 +391,7 @@
qed
lemma Nle_iff[simp]: assumes nx: "isnormNum x" and ny: "isnormNum y"
- shows "((INum x :: 'a :: {ring_char_0,division_by_zero,ordered_field})\<le> INum y) = (x \<le>\<^sub>N y)"
+ shows "((INum x :: 'a :: {ring_char_0,division_by_zero,linordered_field})\<le> INum y) = (x \<le>\<^sub>N y)"
proof-
have "((INum x ::'a) \<le> INum y) = (INum (x -\<^sub>N y) \<le> (0::'a))" using nx ny by simp
also have "\<dots> = (0\<ge>\<^sub>N (x -\<^sub>N y))" using Nle0_iff[OF Nsub_normN[OF ny]] by simp
--- a/src/HOL/Library/AssocList.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/AssocList.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,7 +5,7 @@
header {* Map operations implemented on association lists*}
theory AssocList
-imports Main
+imports Main Mapping
begin
text {*
@@ -656,4 +656,52 @@
(map_of xs k = None \<or> (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = None)) "
by (simp add: compose_conv map_comp_None_iff)
+
+subsection {* Implementation of mappings *}
+
+definition AList :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" where
+ "AList xs = Mapping (map_of xs)"
+
+code_datatype AList
+
+lemma lookup_AList [simp, code]:
+ "Mapping.lookup (AList xs) = map_of xs"
+ by (simp add: AList_def)
+
+lemma empty_AList [code]:
+ "Mapping.empty = AList []"
+ by (rule mapping_eqI) simp
+
+lemma is_empty_AList [code]:
+ "Mapping.is_empty (AList xs) \<longleftrightarrow> null xs"
+ by (cases xs) (simp_all add: is_empty_def)
+
+lemma update_AList [code]:
+ "Mapping.update k v (AList xs) = AList (update k v xs)"
+ by (rule mapping_eqI) (simp add: update_conv')
+
+lemma delete_AList [code]:
+ "Mapping.delete k (AList xs) = AList (delete k xs)"
+ by (rule mapping_eqI) (simp add: delete_conv')
+
+lemma keys_AList [code]:
+ "Mapping.keys (AList xs) = set (map fst xs)"
+ by (simp add: keys_def dom_map_of_conv_image_fst)
+
+lemma ordered_keys_AList [code]:
+ "Mapping.ordered_keys (AList xs) = sort (remdups (map fst xs))"
+ by (simp only: ordered_keys_def keys_AList sorted_list_of_set_sort_remdups)
+
+lemma size_AList [code]:
+ "Mapping.size (AList xs) = length (remdups (map fst xs))"
+ by (simp add: size_def length_remdups_card_conv dom_map_of_conv_image_fst)
+
+lemma tabulate_AList [code]:
+ "Mapping.tabulate ks f = AList (map (\<lambda>k. (k, f k)) ks)"
+ by (rule mapping_eqI) (simp add: map_of_map_restrict)
+
+lemma bulkload_AList [code]:
+ "Mapping.bulkload vs = AList (map (\<lambda>n. (n, vs ! n)) [0..<length vs])"
+ by (rule mapping_eqI) (simp add: map_of_map_restrict expand_fun_eq)
+
end
--- a/src/HOL/Library/BigO.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/BigO.thy Fri Feb 19 15:21:57 2010 +0000
@@ -38,11 +38,11 @@
subsection {* Definitions *}
definition
- bigo :: "('a => 'b::ordered_idom) => ('a => 'b) set" ("(1O'(_'))") where
+ bigo :: "('a => 'b::linordered_idom) => ('a => 'b) set" ("(1O'(_'))") where
"O(f::('a => 'b)) =
{h. EX c. ALL x. abs (h x) <= c * abs (f x)}"
-lemma bigo_pos_const: "(EX (c::'a::ordered_idom).
+lemma bigo_pos_const: "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -352,7 +352,7 @@
done
lemma bigo_mult5: "ALL x. f x ~= 0 ==>
- O(f * g) <= (f::'a => ('b::ordered_field)) *o O(g)"
+ O(f * g) <= (f::'a => ('b::linordered_field)) *o O(g)"
proof -
assume "ALL x. f x ~= 0"
show "O(f * g) <= f *o O(g)"
@@ -381,14 +381,14 @@
qed
lemma bigo_mult6: "ALL x. f x ~= 0 ==>
- O(f * g) = (f::'a => ('b::ordered_field)) *o O(g)"
+ O(f * g) = (f::'a => ('b::linordered_field)) *o O(g)"
apply (rule equalityI)
apply (erule bigo_mult5)
apply (rule bigo_mult2)
done
lemma bigo_mult7: "ALL x. f x ~= 0 ==>
- O(f * g) <= O(f::'a => ('b::ordered_field)) \<otimes> O(g)"
+ O(f * g) <= O(f::'a => ('b::linordered_field)) \<otimes> O(g)"
apply (subst bigo_mult6)
apply assumption
apply (rule set_times_mono3)
@@ -396,7 +396,7 @@
done
lemma bigo_mult8: "ALL x. f x ~= 0 ==>
- O(f * g) = O(f::'a => ('b::ordered_field)) \<otimes> O(g)"
+ O(f * g) = O(f::'a => ('b::linordered_field)) \<otimes> O(g)"
apply (rule equalityI)
apply (erule bigo_mult7)
apply (rule bigo_mult)
@@ -481,16 +481,16 @@
apply (rule bigo_const1)
done
-lemma bigo_const3: "(c::'a::ordered_field) ~= 0 ==> (%x. 1) : O(%x. c)"
+lemma bigo_const3: "(c::'a::linordered_field) ~= 0 ==> (%x. 1) : O(%x. c)"
apply (simp add: bigo_def)
apply (rule_tac x = "abs(inverse c)" in exI)
apply (simp add: abs_mult [symmetric])
done
-lemma bigo_const4: "(c::'a::ordered_field) ~= 0 ==> O(%x. 1) <= O(%x. c)"
+lemma bigo_const4: "(c::'a::linordered_field) ~= 0 ==> O(%x. 1) <= O(%x. c)"
by (rule bigo_elt_subset, rule bigo_const3, assumption)
-lemma bigo_const [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const [simp]: "(c::'a::linordered_field) ~= 0 ==>
O(%x. c) = O(%x. 1)"
by (rule equalityI, rule bigo_const2, rule bigo_const4, assumption)
@@ -503,21 +503,21 @@
lemma bigo_const_mult2: "O(%x. c * f x) <= O(f)"
by (rule bigo_elt_subset, rule bigo_const_mult1)
-lemma bigo_const_mult3: "(c::'a::ordered_field) ~= 0 ==> f : O(%x. c * f x)"
+lemma bigo_const_mult3: "(c::'a::linordered_field) ~= 0 ==> f : O(%x. c * f x)"
apply (simp add: bigo_def)
apply (rule_tac x = "abs(inverse c)" in exI)
apply (simp add: abs_mult [symmetric] mult_assoc [symmetric])
done
-lemma bigo_const_mult4: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult4: "(c::'a::linordered_field) ~= 0 ==>
O(f) <= O(%x. c * f x)"
by (rule bigo_elt_subset, rule bigo_const_mult3, assumption)
-lemma bigo_const_mult [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult [simp]: "(c::'a::linordered_field) ~= 0 ==>
O(%x. c * f x) = O(f)"
by (rule equalityI, rule bigo_const_mult2, erule bigo_const_mult4)
-lemma bigo_const_mult5 [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult5 [simp]: "(c::'a::linordered_field) ~= 0 ==>
(%x. c) *o O(f) = O(f)"
apply (auto del: subsetI)
apply (rule order_trans)
@@ -688,7 +688,7 @@
apply assumption+
done
-lemma bigo_useful_const_mult: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_useful_const_mult: "(c::'a::linordered_field) ~= 0 ==>
(%x. c) * f =o O(h) ==> f =o O(h)"
apply (rule subsetD)
apply (subgoal_tac "(%x. 1 / c) *o O(h) <= O(h)")
@@ -733,7 +733,7 @@
subsection {* Less than or equal to *}
definition
- lesso :: "('a => 'b::ordered_idom) => ('a => 'b) => ('a => 'b)"
+ lesso :: "('a => 'b::linordered_idom) => ('a => 'b) => ('a => 'b)"
(infixl "<o" 70) where
"f <o g = (%x. max (f x - g x) 0)"
@@ -833,7 +833,7 @@
apply (simp add: algebra_simps)
done
-lemma bigo_lesso4: "f <o g =o O(k::'a=>'b::ordered_field) ==>
+lemma bigo_lesso4: "f <o g =o O(k::'a=>'b::linordered_field) ==>
g =o h +o O(k) ==> f <o h =o O(k)"
apply (unfold lesso_def)
apply (drule set_plus_imp_minus)
--- a/src/HOL/Library/Coinductive_List.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Coinductive_List.thy Fri Feb 19 15:21:57 2010 +0000
@@ -204,7 +204,7 @@
LNil :: logic
LCons :: logic
translations
- "case p of LNil \<Rightarrow> a | LCons x l \<Rightarrow> b" \<rightleftharpoons> "CONST llist_case a (\<lambda>x l. b) p"
+ "case p of XCONST LNil \<Rightarrow> a | XCONST LCons x l \<Rightarrow> b" \<rightleftharpoons> "CONST llist_case a (\<lambda>x l. b) p"
lemma llist_case_LNil [simp, code]: "llist_case c d LNil = c"
by (simp add: llist_case_def LNil_def
--- a/src/HOL/Library/Float.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Float.thy Fri Feb 19 15:21:57 2010 +0000
@@ -6,7 +6,7 @@
header {* Floating-Point Numbers *}
theory Float
-imports Complex_Main
+imports Complex_Main Lattice_Algebras
begin
definition
--- a/src/HOL/Library/Formal_Power_Series.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Formal_Power_Series.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2864,8 +2864,8 @@
then have nz: "pochhammer (1 + b - of_nat n) n \<noteq> 0"
by (auto simp add: algebra_simps)
- from nz kn have nz': "pochhammer (1 + b - of_nat n) k \<noteq> 0"
- by (simp add: pochhammer_neq_0_mono)
+ from nz kn [simplified] have nz': "pochhammer (1 + b - of_nat n) k \<noteq> 0"
+ by (rule pochhammer_neq_0_mono)
{assume k0: "k = 0 \<or> n =0"
then have "b gchoose (n - k) = (?m1 n * ?p b n * ?m1 k * ?p (of_nat n) k) / (?f n * pochhammer (b - of_nat n + 1) k)"
using kn
--- a/src/HOL/Library/Infinite_Set.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Infinite_Set.thy Fri Feb 19 15:21:57 2010 +0000
@@ -192,10 +192,11 @@
by (auto simp add: infinite_nat_iff_unbounded)
qed
-lemma nat_infinite [simp]: "infinite (UNIV :: nat set)"
+(* duplicates Finite_Set.infinite_UNIV_nat *)
+lemma nat_infinite: "infinite (UNIV :: nat set)"
by (auto simp add: infinite_nat_iff_unbounded)
-lemma nat_not_finite [elim]: "finite (UNIV::nat set) \<Longrightarrow> R"
+lemma nat_not_finite: "finite (UNIV::nat set) \<Longrightarrow> R"
by simp
text {*
--- a/src/HOL/Library/Kleene_Algebra.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Kleene_Algebra.thy Fri Feb 19 15:21:57 2010 +0000
@@ -72,7 +72,7 @@
class pre_kleene = semiring_1 + order_by_add
begin
-subclass pordered_semiring proof
+subclass ordered_semiring proof
fix x y z :: 'a
assume "x \<le> y"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Lattice_Algebras.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,557 @@
+(* Author: Steven Obua, TU Muenchen *)
+
+header {* Various algebraic structures combined with a lattice *}
+
+theory Lattice_Algebras
+imports Complex_Main
+begin
+
+class semilattice_inf_ab_group_add = ordered_ab_group_add + semilattice_inf
+begin
+
+lemma add_inf_distrib_left:
+ "a + inf b c = inf (a + b) (a + c)"
+apply (rule antisym)
+apply (simp_all add: le_infI)
+apply (rule add_le_imp_le_left [of "uminus a"])
+apply (simp only: add_assoc [symmetric], simp)
+apply rule
+apply (rule add_le_imp_le_left[of "a"], simp only: add_assoc[symmetric], simp)+
+done
+
+lemma add_inf_distrib_right:
+ "inf a b + c = inf (a + c) (b + c)"
+proof -
+ have "c + inf a b = inf (c+a) (c+b)" by (simp add: add_inf_distrib_left)
+ thus ?thesis by (simp add: add_commute)
+qed
+
+end
+
+class semilattice_sup_ab_group_add = ordered_ab_group_add + semilattice_sup
+begin
+
+lemma add_sup_distrib_left:
+ "a + sup b c = sup (a + b) (a + c)"
+apply (rule antisym)
+apply (rule add_le_imp_le_left [of "uminus a"])
+apply (simp only: add_assoc[symmetric], simp)
+apply rule
+apply (rule add_le_imp_le_left [of "a"], simp only: add_assoc[symmetric], simp)+
+apply (rule le_supI)
+apply (simp_all)
+done
+
+lemma add_sup_distrib_right:
+ "sup a b + c = sup (a+c) (b+c)"
+proof -
+ have "c + sup a b = sup (c+a) (c+b)" by (simp add: add_sup_distrib_left)
+ thus ?thesis by (simp add: add_commute)
+qed
+
+end
+
+class lattice_ab_group_add = ordered_ab_group_add + lattice
+begin
+
+subclass semilattice_inf_ab_group_add ..
+subclass semilattice_sup_ab_group_add ..
+
+lemmas add_sup_inf_distribs = add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left
+
+lemma inf_eq_neg_sup: "inf a b = - sup (-a) (-b)"
+proof (rule inf_unique)
+ fix a b :: 'a
+ show "- sup (-a) (-b) \<le> a"
+ by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
+ (simp, simp add: add_sup_distrib_left)
+next
+ fix a b :: 'a
+ show "- sup (-a) (-b) \<le> b"
+ by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
+ (simp, simp add: add_sup_distrib_left)
+next
+ fix a b c :: 'a
+ assume "a \<le> b" "a \<le> c"
+ then show "a \<le> - sup (-b) (-c)" by (subst neg_le_iff_le [symmetric])
+ (simp add: le_supI)
+qed
+
+lemma sup_eq_neg_inf: "sup a b = - inf (-a) (-b)"
+proof (rule sup_unique)
+ fix a b :: 'a
+ show "a \<le> - inf (-a) (-b)"
+ by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
+ (simp, simp add: add_inf_distrib_left)
+next
+ fix a b :: 'a
+ show "b \<le> - inf (-a) (-b)"
+ by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
+ (simp, simp add: add_inf_distrib_left)
+next
+ fix a b c :: 'a
+ assume "a \<le> c" "b \<le> c"
+ then show "- inf (-a) (-b) \<le> c" by (subst neg_le_iff_le [symmetric])
+ (simp add: le_infI)
+qed
+
+lemma neg_inf_eq_sup: "- inf a b = sup (-a) (-b)"
+by (simp add: inf_eq_neg_sup)
+
+lemma neg_sup_eq_inf: "- sup a b = inf (-a) (-b)"
+by (simp add: sup_eq_neg_inf)
+
+lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
+proof -
+ have "0 = - inf 0 (a-b) + inf (a-b) 0" by (simp add: inf_commute)
+ hence "0 = sup 0 (b-a) + inf (a-b) 0" by (simp add: inf_eq_neg_sup)
+ hence "0 = (-a + sup a b) + (inf a b + (-b))"
+ by (simp add: add_sup_distrib_left add_inf_distrib_right)
+ (simp add: algebra_simps)
+ thus ?thesis by (simp add: algebra_simps)
+qed
+
+subsection {* Positive Part, Negative Part, Absolute Value *}
+
+definition
+ nprt :: "'a \<Rightarrow> 'a" where
+ "nprt x = inf x 0"
+
+definition
+ pprt :: "'a \<Rightarrow> 'a" where
+ "pprt x = sup x 0"
+
+lemma pprt_neg: "pprt (- x) = - nprt x"
+proof -
+ have "sup (- x) 0 = sup (- x) (- 0)" unfolding minus_zero ..
+ also have "\<dots> = - inf x 0" unfolding neg_inf_eq_sup ..
+ finally have "sup (- x) 0 = - inf x 0" .
+ then show ?thesis unfolding pprt_def nprt_def .
+qed
+
+lemma nprt_neg: "nprt (- x) = - pprt x"
+proof -
+ from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
+ then have "pprt x = - nprt (- x)" by simp
+ then show ?thesis by simp
+qed
+
+lemma prts: "a = pprt a + nprt a"
+by (simp add: pprt_def nprt_def add_eq_inf_sup[symmetric])
+
+lemma zero_le_pprt[simp]: "0 \<le> pprt a"
+by (simp add: pprt_def)
+
+lemma nprt_le_zero[simp]: "nprt a \<le> 0"
+by (simp add: nprt_def)
+
+lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0" (is "?l = ?r")
+proof -
+ have a: "?l \<longrightarrow> ?r"
+ apply (auto)
+ apply (rule add_le_imp_le_right[of _ "uminus b" _])
+ apply (simp add: add_assoc)
+ done
+ have b: "?r \<longrightarrow> ?l"
+ apply (auto)
+ apply (rule add_le_imp_le_right[of _ "b" _])
+ apply (simp)
+ done
+ from a b show ?thesis by blast
+qed
+
+lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
+lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)
+
+lemma pprt_eq_id [simp, noatp]: "0 \<le> x \<Longrightarrow> pprt x = x"
+ by (simp add: pprt_def sup_aci sup_absorb1)
+
+lemma nprt_eq_id [simp, noatp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
+ by (simp add: nprt_def inf_aci inf_absorb1)
+
+lemma pprt_eq_0 [simp, noatp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
+ by (simp add: pprt_def sup_aci sup_absorb2)
+
+lemma nprt_eq_0 [simp, noatp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
+ by (simp add: nprt_def inf_aci inf_absorb2)
+
+lemma sup_0_imp_0: "sup a (- a) = 0 \<Longrightarrow> a = 0"
+proof -
+ {
+ fix a::'a
+ assume hyp: "sup a (-a) = 0"
+ hence "sup a (-a) + a = a" by (simp)
+ hence "sup (a+a) 0 = a" by (simp add: add_sup_distrib_right)
+ hence "sup (a+a) 0 <= a" by (simp)
+ hence "0 <= a" by (blast intro: order_trans inf_sup_ord)
+ }
+ note p = this
+ assume hyp:"sup a (-a) = 0"
+ hence hyp2:"sup (-a) (-(-a)) = 0" by (simp add: sup_commute)
+ from p[OF hyp] p[OF hyp2] show "a = 0" by simp
+qed
+
+lemma inf_0_imp_0: "inf a (-a) = 0 \<Longrightarrow> a = 0"
+apply (simp add: inf_eq_neg_sup)
+apply (simp add: sup_commute)
+apply (erule sup_0_imp_0)
+done
+
+lemma inf_0_eq_0 [simp, noatp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
+by (rule, erule inf_0_imp_0) simp
+
+lemma sup_0_eq_0 [simp, noatp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
+by (rule, erule sup_0_imp_0) simp
+
+lemma zero_le_double_add_iff_zero_le_single_add [simp]:
+ "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
+proof
+ assume "0 <= a + a"
+ hence a:"inf (a+a) 0 = 0" by (simp add: inf_commute inf_absorb1)
+ have "(inf a 0)+(inf a 0) = inf (inf (a+a) 0) a" (is "?l=_")
+ by (simp add: add_sup_inf_distribs inf_aci)
+ hence "?l = 0 + inf a 0" by (simp add: a, simp add: inf_commute)
+ hence "inf a 0 = 0" by (simp only: add_right_cancel)
+ then show "0 <= a" unfolding le_iff_inf by (simp add: inf_commute)
+next
+ assume a: "0 <= a"
+ show "0 <= a + a" by (simp add: add_mono[OF a a, simplified])
+qed
+
+lemma double_zero [simp]:
+ "a + a = 0 \<longleftrightarrow> a = 0"
+proof
+ assume assm: "a + a = 0"
+ then have "a + a + - a = - a" by simp
+ then have "a + (a + - a) = - a" by (simp only: add_assoc)
+ then have a: "- a = a" by simp
+ show "a = 0" apply (rule antisym)
+ apply (unfold neg_le_iff_le [symmetric, of a])
+ unfolding a apply simp
+ unfolding zero_le_double_add_iff_zero_le_single_add [symmetric, of a]
+ unfolding assm unfolding le_less apply simp_all done
+next
+ assume "a = 0" then show "a + a = 0" by simp
+qed
+
+lemma zero_less_double_add_iff_zero_less_single_add [simp]:
+ "0 < a + a \<longleftrightarrow> 0 < a"
+proof (cases "a = 0")
+ case True then show ?thesis by auto
+next
+ case False then show ?thesis (*FIXME tune proof*)
+ unfolding less_le apply simp apply rule
+ apply clarify
+ apply rule
+ apply assumption
+ apply (rule notI)
+ unfolding double_zero [symmetric, of a] apply simp
+ done
+qed
+
+lemma double_add_le_zero_iff_single_add_le_zero [simp]:
+ "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
+proof -
+ have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)" by (subst le_minus_iff, simp)
+ moreover have "\<dots> \<longleftrightarrow> a \<le> 0" by (simp add: zero_le_double_add_iff_zero_le_single_add)
+ ultimately show ?thesis by blast
+qed
+
+lemma double_add_less_zero_iff_single_less_zero [simp]:
+ "a + a < 0 \<longleftrightarrow> a < 0"
+proof -
+ have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)" by (subst less_minus_iff, simp)
+ moreover have "\<dots> \<longleftrightarrow> a < 0" by (simp add: zero_less_double_add_iff_zero_less_single_add)
+ ultimately show ?thesis by blast
+qed
+
+declare neg_inf_eq_sup [simp] neg_sup_eq_inf [simp]
+
+lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
+proof -
+ from add_le_cancel_left [of "uminus a" "plus a a" zero]
+ have "(a <= -a) = (a+a <= 0)"
+ by (simp add: add_assoc[symmetric])
+ thus ?thesis by simp
+qed
+
+lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
+proof -
+ from add_le_cancel_left [of "uminus a" zero "plus a a"]
+ have "(-a <= a) = (0 <= a+a)"
+ by (simp add: add_assoc[symmetric])
+ thus ?thesis by simp
+qed
+
+lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
+unfolding le_iff_inf by (simp add: nprt_def inf_commute)
+
+lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
+unfolding le_iff_sup by (simp add: pprt_def sup_commute)
+
+lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
+unfolding le_iff_sup by (simp add: pprt_def sup_commute)
+
+lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
+unfolding le_iff_inf by (simp add: nprt_def inf_commute)
+
+lemma pprt_mono [simp, noatp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
+unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])
+
+lemma nprt_mono [simp, noatp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
+unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])
+
+end
+
+lemmas add_sup_inf_distribs = add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left
+
+
+class lattice_ab_group_add_abs = lattice_ab_group_add + abs +
+ assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
+begin
+
+lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
+proof -
+ have "0 \<le> \<bar>a\<bar>"
+ proof -
+ have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>" by (auto simp add: abs_lattice)
+ show ?thesis by (rule add_mono [OF a b, simplified])
+ qed
+ then have "0 \<le> sup a (- a)" unfolding abs_lattice .
+ then have "sup (sup a (- a)) 0 = sup a (- a)" by (rule sup_absorb1)
+ then show ?thesis
+ by (simp add: add_sup_inf_distribs sup_aci
+ pprt_def nprt_def diff_minus abs_lattice)
+qed
+
+subclass ordered_ab_group_add_abs
+proof
+ have abs_ge_zero [simp]: "\<And>a. 0 \<le> \<bar>a\<bar>"
+ proof -
+ fix a b
+ have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>" by (auto simp add: abs_lattice)
+ show "0 \<le> \<bar>a\<bar>" by (rule add_mono [OF a b, simplified])
+ qed
+ have abs_leI: "\<And>a b. a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
+ by (simp add: abs_lattice le_supI)
+ fix a b
+ show "0 \<le> \<bar>a\<bar>" by simp
+ show "a \<le> \<bar>a\<bar>"
+ by (auto simp add: abs_lattice)
+ show "\<bar>-a\<bar> = \<bar>a\<bar>"
+ by (simp add: abs_lattice sup_commute)
+ show "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" by (fact abs_leI)
+ show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
+ proof -
+ have g:"abs a + abs b = sup (a+b) (sup (-a-b) (sup (-a+b) (a + (-b))))" (is "_=sup ?m ?n")
+ by (simp add: abs_lattice add_sup_inf_distribs sup_aci diff_minus)
+ have a:"a+b <= sup ?m ?n" by (simp)
+ have b:"-a-b <= ?n" by (simp)
+ have c:"?n <= sup ?m ?n" by (simp)
+ from b c have d: "-a-b <= sup ?m ?n" by(rule order_trans)
+ have e:"-a-b = -(a+b)" by (simp add: diff_minus)
+ from a d e have "abs(a+b) <= sup ?m ?n"
+ by (drule_tac abs_leI, auto)
+ with g[symmetric] show ?thesis by simp
+ qed
+qed
+
+end
+
+lemma sup_eq_if:
+ fixes a :: "'a\<Colon>{lattice_ab_group_add, linorder}"
+ shows "sup a (- a) = (if a < 0 then - a else a)"
+proof -
+ note add_le_cancel_right [of a a "- a", symmetric, simplified]
+ moreover note add_le_cancel_right [of "-a" a a, symmetric, simplified]
+ then show ?thesis by (auto simp: sup_max min_max.sup_absorb1 min_max.sup_absorb2)
+qed
+
+lemma abs_if_lattice:
+ fixes a :: "'a\<Colon>{lattice_ab_group_add_abs, linorder}"
+ shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
+by auto
+
+lemma estimate_by_abs:
+ "a + b <= (c::'a::lattice_ab_group_add_abs) \<Longrightarrow> a <= c + abs b"
+proof -
+ assume "a+b <= c"
+ hence 2: "a <= c+(-b)" by (simp add: algebra_simps)
+ have 3: "(-b) <= abs b" by (rule abs_ge_minus_self)
+ show ?thesis by (rule le_add_right_mono[OF 2 3])
+qed
+
+class lattice_ring = ordered_ring + lattice_ab_group_add_abs
+begin
+
+subclass semilattice_inf_ab_group_add ..
+subclass semilattice_sup_ab_group_add ..
+
+end
+
+lemma abs_le_mult: "abs (a * b) \<le> (abs a) * (abs (b::'a::lattice_ring))"
+proof -
+ let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
+ let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
+ have a: "(abs a) * (abs b) = ?x"
+ by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
+ {
+ fix u v :: 'a
+ have bh: "\<lbrakk>u = a; v = b\<rbrakk> \<Longrightarrow>
+ u * v = pprt a * pprt b + pprt a * nprt b +
+ nprt a * pprt b + nprt a * nprt b"
+ apply (subst prts[of u], subst prts[of v])
+ apply (simp add: algebra_simps)
+ done
+ }
+ note b = this[OF refl[of a] refl[of b]]
+ note addm = add_mono[of "0::'a" _ "0::'a", simplified]
+ note addm2 = add_mono[of _ "0::'a" _ "0::'a", simplified]
+ have xy: "- ?x <= ?y"
+ apply (simp)
+ apply (rule_tac y="0::'a" in order_trans)
+ apply (rule addm2)
+ apply (simp_all add: mult_nonneg_nonneg mult_nonpos_nonpos)
+ apply (rule addm)
+ apply (simp_all add: mult_nonneg_nonneg mult_nonpos_nonpos)
+ done
+ have yx: "?y <= ?x"
+ apply (simp add:diff_def)
+ apply (rule_tac y=0 in order_trans)
+ apply (rule addm2, (simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)+)
+ apply (rule addm, (simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)+)
+ done
+ have i1: "a*b <= abs a * abs b" by (simp only: a b yx)
+ have i2: "- (abs a * abs b) <= a*b" by (simp only: a b xy)
+ show ?thesis
+ apply (rule abs_leI)
+ apply (simp add: i1)
+ apply (simp add: i2[simplified minus_le_iff])
+ done
+qed
+
+instance lattice_ring \<subseteq> ordered_ring_abs
+proof
+ fix a b :: "'a\<Colon> lattice_ring"
+ assume "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
+ show "abs (a*b) = abs a * abs b"
+ proof -
+ have s: "(0 <= a*b) | (a*b <= 0)"
+ apply (auto)
+ apply (rule_tac split_mult_pos_le)
+ apply (rule_tac contrapos_np[of "a*b <= 0"])
+ apply (simp)
+ apply (rule_tac split_mult_neg_le)
+ apply (insert prems)
+ apply (blast)
+ done
+ have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
+ by (simp add: prts[symmetric])
+ show ?thesis
+ proof cases
+ assume "0 <= a * b"
+ then show ?thesis
+ apply (simp_all add: mulprts abs_prts)
+ apply (insert prems)
+ apply (auto simp add:
+ algebra_simps
+ iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
+ iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
+ apply(drule (1) mult_nonneg_nonpos[of a b], simp)
+ apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
+ done
+ next
+ assume "~(0 <= a*b)"
+ with s have "a*b <= 0" by simp
+ then show ?thesis
+ apply (simp_all add: mulprts abs_prts)
+ apply (insert prems)
+ apply (auto simp add: algebra_simps)
+ apply(drule (1) mult_nonneg_nonneg[of a b],simp)
+ apply(drule (1) mult_nonpos_nonpos[of a b],simp)
+ done
+ qed
+ qed
+qed
+
+lemma mult_le_prts:
+ assumes
+ "a1 <= (a::'a::lattice_ring)"
+ "a <= a2"
+ "b1 <= b"
+ "b <= b2"
+ shows
+ "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
+proof -
+ have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
+ apply (subst prts[symmetric])+
+ apply simp
+ done
+ then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
+ by (simp add: algebra_simps)
+ moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
+ by (simp_all add: prems mult_mono)
+ moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
+ proof -
+ have "pprt a * nprt b <= pprt a * nprt b2"
+ by (simp add: mult_left_mono prems)
+ moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
+ by (simp add: mult_right_mono_neg prems)
+ ultimately show ?thesis
+ by simp
+ qed
+ moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
+ proof -
+ have "nprt a * pprt b <= nprt a2 * pprt b"
+ by (simp add: mult_right_mono prems)
+ moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
+ by (simp add: mult_left_mono_neg prems)
+ ultimately show ?thesis
+ by simp
+ qed
+ moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
+ proof -
+ have "nprt a * nprt b <= nprt a * nprt b1"
+ by (simp add: mult_left_mono_neg prems)
+ moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
+ by (simp add: mult_right_mono_neg prems)
+ ultimately show ?thesis
+ by simp
+ qed
+ ultimately show ?thesis
+ by - (rule add_mono | simp)+
+qed
+
+lemma mult_ge_prts:
+ assumes
+ "a1 <= (a::'a::lattice_ring)"
+ "a <= a2"
+ "b1 <= b"
+ "b <= b2"
+ shows
+ "a * b >= nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
+proof -
+ from prems have a1:"- a2 <= -a" by auto
+ from prems have a2: "-a <= -a1" by auto
+ from mult_le_prts[of "-a2" "-a" "-a1" "b1" b "b2", OF a1 a2 prems(3) prems(4), simplified nprt_neg pprt_neg]
+ have le: "- (a * b) <= - nprt a1 * pprt b2 + - nprt a2 * nprt b2 + - pprt a1 * pprt b1 + - pprt a2 * nprt b1" by simp
+ then have "-(- nprt a1 * pprt b2 + - nprt a2 * nprt b2 + - pprt a1 * pprt b1 + - pprt a2 * nprt b1) <= a * b"
+ by (simp only: minus_le_iff)
+ then show ?thesis by simp
+qed
+
+instance int :: lattice_ring
+proof
+ fix k :: int
+ show "abs k = sup k (- k)"
+ by (auto simp add: sup_int_def)
+qed
+
+instance real :: lattice_ring
+proof
+ fix a :: real
+ show "abs a = sup a (- a)"
+ by (auto simp add: sup_real_def)
+qed
+
+end
--- a/src/HOL/Library/Library.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Library.thy Fri Feb 19 15:21:57 2010 +0000
@@ -28,6 +28,7 @@
Fundamental_Theorem_Algebra
Infinite_Set
Inner_Product
+ Lattice_Algebras
Lattice_Syntax
ListVector
Kleene_Algebra
@@ -44,7 +45,12 @@
Preorder
Product_Vector
Quicksort
- Quotient
+ Quotient_List
+ Quotient_Option
+ Quotient_Product
+ Quotient_Sum
+ Quotient_Syntax
+ Quotient_Type
Ramsey
Reflection
RBT
--- a/src/HOL/Library/Mapping.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Mapping.thy Fri Feb 19 15:21:57 2010 +0000
@@ -3,50 +3,61 @@
header {* An abstract view on maps for code generation. *}
theory Mapping
-imports Map Main
+imports Main
begin
subsection {* Type definition and primitive operations *}
-datatype ('a, 'b) map = Map "'a \<rightharpoonup> 'b"
+datatype ('a, 'b) mapping = Mapping "'a \<rightharpoonup> 'b"
-definition empty :: "('a, 'b) map" where
- "empty = Map (\<lambda>_. None)"
-
-primrec lookup :: "('a, 'b) map \<Rightarrow> 'a \<rightharpoonup> 'b" where
- "lookup (Map f) = f"
+definition empty :: "('a, 'b) mapping" where
+ "empty = Mapping (\<lambda>_. None)"
-primrec update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) map \<Rightarrow> ('a, 'b) map" where
- "update k v (Map f) = Map (f (k \<mapsto> v))"
+primrec lookup :: "('a, 'b) mapping \<Rightarrow> 'a \<rightharpoonup> 'b" where
+ "lookup (Mapping f) = f"
-primrec delete :: "'a \<Rightarrow> ('a, 'b) map \<Rightarrow> ('a, 'b) map" where
- "delete k (Map f) = Map (f (k := None))"
+primrec update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" where
+ "update k v (Mapping f) = Mapping (f (k \<mapsto> v))"
-primrec keys :: "('a, 'b) map \<Rightarrow> 'a set" where
- "keys (Map f) = dom f"
+primrec delete :: "'a \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" where
+ "delete k (Mapping f) = Mapping (f (k := None))"
subsection {* Derived operations *}
-definition size :: "('a, 'b) map \<Rightarrow> nat" where
- "size m = (if finite (keys m) then card (keys m) else 0)"
+definition keys :: "('a, 'b) mapping \<Rightarrow> 'a set" where
+ "keys m = dom (lookup m)"
+
+definition ordered_keys :: "('a\<Colon>linorder, 'b) mapping \<Rightarrow> 'a list" where
+ "ordered_keys m = sorted_list_of_set (keys m)"
-definition replace :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) map \<Rightarrow> ('a, 'b) map" where
+definition is_empty :: "('a, 'b) mapping \<Rightarrow> bool" where
+ "is_empty m \<longleftrightarrow> dom (lookup m) = {}"
+
+definition size :: "('a, 'b) mapping \<Rightarrow> nat" where
+ "size m = (if finite (dom (lookup m)) then card (dom (lookup m)) else 0)"
+
+definition replace :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" where
"replace k v m = (if lookup m k = None then m else update k v m)"
-definition tabulate :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) map" where
- "tabulate ks f = Map (map_of (map (\<lambda>k. (k, f k)) ks))"
+definition tabulate :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping" where
+ "tabulate ks f = Mapping (map_of (map (\<lambda>k. (k, f k)) ks))"
-definition bulkload :: "'a list \<Rightarrow> (nat, 'a) map" where
- "bulkload xs = Map (\<lambda>k. if k < length xs then Some (xs ! k) else None)"
+definition bulkload :: "'a list \<Rightarrow> (nat, 'a) mapping" where
+ "bulkload xs = Mapping (\<lambda>k. if k < length xs then Some (xs ! k) else None)"
subsection {* Properties *}
-lemma lookup_inject:
+lemma lookup_inject [simp]:
"lookup m = lookup n \<longleftrightarrow> m = n"
by (cases m, cases n) simp
+lemma mapping_eqI:
+ assumes "lookup m = lookup n"
+ shows "m = n"
+ using assms by simp
+
lemma lookup_empty [simp]:
"lookup empty = Map.empty"
by (simp add: empty_def)
@@ -55,98 +66,82 @@
"lookup (update k v m) = (lookup m) (k \<mapsto> v)"
by (cases m) simp
-lemma lookup_delete:
- "lookup (delete k m) k = None"
- "k \<noteq> l \<Longrightarrow> lookup (delete k m) l = lookup m l"
- by (cases m, simp)+
+lemma lookup_delete [simp]:
+ "lookup (delete k m) = (lookup m) (k := None)"
+ by (cases m) simp
-lemma lookup_tabulate:
+lemma lookup_tabulate [simp]:
"lookup (tabulate ks f) = (Some o f) |` set ks"
by (induct ks) (auto simp add: tabulate_def restrict_map_def expand_fun_eq)
-lemma lookup_bulkload:
+lemma lookup_bulkload [simp]:
"lookup (bulkload xs) = (\<lambda>k. if k < length xs then Some (xs ! k) else None)"
- unfolding bulkload_def by simp
+ by (simp add: bulkload_def)
lemma update_update:
"update k v (update k w m) = update k v m"
"k \<noteq> l \<Longrightarrow> update k v (update l w m) = update l w (update k v m)"
- by (cases m, simp add: expand_fun_eq)+
+ by (rule mapping_eqI, simp add: fun_upd_twist)+
-lemma replace_update:
- "lookup m k = None \<Longrightarrow> replace k v m = m"
- "lookup m k \<noteq> None \<Longrightarrow> replace k v m = update k v m"
- by (auto simp add: replace_def)
-
-lemma delete_empty [simp]:
- "delete k empty = empty"
- by (simp add: empty_def)
+lemma update_delete [simp]:
+ "update k v (delete k m) = update k v m"
+ by (rule mapping_eqI) simp
lemma delete_update:
"delete k (update k v m) = delete k m"
"k \<noteq> l \<Longrightarrow> delete k (update l v m) = update l v (delete k m)"
- by (cases m, simp add: expand_fun_eq)+
-
-lemma update_delete [simp]:
- "update k v (delete k m) = update k v m"
- by (cases m) simp
-
-lemma keys_empty [simp]:
- "keys empty = {}"
- unfolding empty_def by simp
+ by (rule mapping_eqI, simp add: fun_upd_twist)+
-lemma keys_update [simp]:
- "keys (update k v m) = insert k (keys m)"
- by (cases m) simp
+lemma delete_empty [simp]:
+ "delete k empty = empty"
+ by (rule mapping_eqI) simp
-lemma keys_delete [simp]:
- "keys (delete k m) = keys m - {k}"
- by (cases m) simp
-
-lemma keys_tabulate [simp]:
- "keys (tabulate ks f) = set ks"
- by (auto simp add: tabulate_def dest: map_of_SomeD intro!: weak_map_of_SomeI)
+lemma replace_update:
+ "k \<notin> dom (lookup m) \<Longrightarrow> replace k v m = m"
+ "k \<in> dom (lookup m) \<Longrightarrow> replace k v m = update k v m"
+ by (rule mapping_eqI, auto simp add: replace_def fun_upd_twist)+
lemma size_empty [simp]:
"size empty = 0"
- by (simp add: size_def keys_empty)
+ by (simp add: size_def)
lemma size_update:
- "finite (keys m) \<Longrightarrow> size (update k v m) =
- (if k \<in> keys m then size m else Suc (size m))"
- by (simp add: size_def keys_update)
- (auto simp only: card_insert card_Suc_Diff1)
+ "finite (dom (lookup m)) \<Longrightarrow> size (update k v m) =
+ (if k \<in> dom (lookup m) then size m else Suc (size m))"
+ by (auto simp add: size_def insert_dom)
lemma size_delete:
- "size (delete k m) = (if k \<in> keys m then size m - 1 else size m)"
- by (simp add: size_def keys_delete)
+ "size (delete k m) = (if k \<in> dom (lookup m) then size m - 1 else size m)"
+ by (simp add: size_def)
lemma size_tabulate:
"size (tabulate ks f) = length (remdups ks)"
- by (simp add: size_def keys_tabulate distinct_card [of "remdups ks", symmetric])
+ by (simp add: size_def distinct_card [of "remdups ks", symmetric] comp_def)
lemma bulkload_tabulate:
"bulkload xs = tabulate [0..<length xs] (nth xs)"
- by (rule sym)
- (auto simp add: bulkload_def tabulate_def expand_fun_eq map_of_eq_None_iff comp_def)
+ by (rule mapping_eqI) (simp add: expand_fun_eq)
subsection {* Some technical code lemmas *}
lemma [code]:
- "map_case f m = f (Mapping.lookup m)"
+ "mapping_case f m = f (Mapping.lookup m)"
by (cases m) simp
lemma [code]:
- "map_rec f m = f (Mapping.lookup m)"
+ "mapping_rec f m = f (Mapping.lookup m)"
by (cases m) simp
lemma [code]:
- "Nat.size (m :: (_, _) map) = 0"
+ "Nat.size (m :: (_, _) mapping) = 0"
by (cases m) simp
lemma [code]:
- "map_size f g m = 0"
+ "mapping_size f g m = 0"
by (cases m) simp
+
+hide (open) const empty is_empty lookup update delete ordered_keys keys size replace tabulate bulkload
+
end
\ No newline at end of file
--- a/src/HOL/Library/Multiset.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Multiset.thy Fri Feb 19 15:21:57 2010 +0000
@@ -415,11 +415,11 @@
mset_le_trans simp: mset_less_def)
interpretation mset_order_cancel_semigroup:
- pordered_cancel_ab_semigroup_add "op +" "op \<le>#" "op <#"
+ ordered_cancel_ab_semigroup_add "op +" "op \<le>#" "op <#"
proof qed (erule mset_le_mono_add [OF mset_le_refl])
interpretation mset_order_semigroup_cancel:
- pordered_ab_semigroup_add_imp_le "op +" "op \<le>#" "op <#"
+ ordered_ab_semigroup_add_imp_le "op +" "op \<le>#" "op <#"
proof qed simp
lemma mset_lessD: "A \<subset># B \<Longrightarrow> x \<in># A \<Longrightarrow> x \<in># B"
@@ -1348,7 +1348,7 @@
lemma union_upper2: "B <= A + (B::'a::order multiset)"
by (subst add_commute) (rule union_upper1)
-instance multiset :: (order) pordered_ab_semigroup_add
+instance multiset :: (order) ordered_ab_semigroup_add
apply intro_classes
apply (erule union_le_mono[OF mult_le_refl])
done
--- a/src/HOL/Library/Nat_Infinity.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Nat_Infinity.thy Fri Feb 19 15:21:57 2010 +0000
@@ -234,7 +234,7 @@
subsection {* Ordering *}
-instantiation inat :: ordered_ab_semigroup_add
+instantiation inat :: linordered_ab_semigroup_add
begin
definition
@@ -268,7 +268,7 @@
end
-instance inat :: pordered_comm_semiring
+instance inat :: ordered_comm_semiring
proof
fix a b c :: inat
assume "a \<le> b" and "0 \<le> c"
--- a/src/HOL/Library/Numeral_Type.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Numeral_Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -36,8 +36,8 @@
typed_print_translation {*
let
- fun card_univ_tr' show_sorts _ [Const (@{const_syntax UNIV}, Type(_,[T,_]))] =
- Syntax.const "_type_card" $ Syntax.term_of_typ show_sorts T;
+ fun card_univ_tr' show_sorts _ [Const (@{const_syntax UNIV}, Type(_, [T, _]))] =
+ Syntax.const @{syntax_const "_type_card"} $ Syntax.term_of_typ show_sorts T;
in [(@{const_syntax card}, card_univ_tr')]
end
*}
@@ -389,7 +389,7 @@
parse_translation {*
let
-
+(* FIXME @{type_syntax} *)
val num1_const = Syntax.const "Numeral_Type.num1";
val num0_const = Syntax.const "Numeral_Type.num0";
val B0_const = Syntax.const "Numeral_Type.bit0";
@@ -411,7 +411,7 @@
mk_bintype (the (Int.fromString str))
| numeral_tr (*"_NumeralType"*) ts = raise TERM ("numeral_tr", ts);
-in [("_NumeralType", numeral_tr)] end;
+in [(@{syntax_const "_NumeralType"}, numeral_tr)] end;
*}
print_translation {*
@@ -419,6 +419,7 @@
fun int_of [] = 0
| int_of (b :: bs) = b + 2 * int_of bs;
+(* FIXME @{type_syntax} *)
fun bin_of (Const ("num0", _)) = []
| bin_of (Const ("num1", _)) = [1]
| bin_of (Const ("bit0", _) $ bs) = 0 :: bin_of bs
@@ -435,6 +436,7 @@
end
| bit_tr' b _ = raise Match;
+(* FIXME @{type_syntax} *)
in [("bit0", bit_tr' 0), ("bit1", bit_tr' 1)] end;
*}
--- a/src/HOL/Library/OptionalSugar.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/OptionalSugar.thy Fri Feb 19 15:21:57 2010 +0000
@@ -15,7 +15,7 @@
translations
"n" <= "CONST of_nat n"
"n" <= "CONST int n"
- "n" <= "real n"
+ "n" <= "CONST real n"
"n" <= "CONST real_of_nat n"
"n" <= "CONST real_of_int n"
"n" <= "CONST of_real n"
@@ -23,10 +23,10 @@
(* append *)
syntax (latex output)
- "appendL" :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<^raw:\isacharat>" 65)
+ "_appendL" :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "\<^raw:\isacharat>" 65)
translations
- "appendL xs ys" <= "xs @ ys"
- "appendL (appendL xs ys) zs" <= "appendL xs (appendL ys zs)"
+ "_appendL xs ys" <= "xs @ ys"
+ "_appendL (_appendL xs ys) zs" <= "_appendL xs (_appendL ys zs)"
(* deprecated, use thm with style instead, will be removed *)
--- a/src/HOL/Library/Poly_Deriv.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Poly_Deriv.thy Fri Feb 19 15:21:57 2010 +0000
@@ -139,7 +139,7 @@
lemma dvd_add_cancel1:
fixes a b c :: "'a::comm_ring_1"
shows "a dvd b + c \<Longrightarrow> a dvd b \<Longrightarrow> a dvd c"
- by (drule (1) Ring_and_Field.dvd_diff, simp)
+ by (drule (1) Rings.dvd_diff, simp)
lemma lemma_order_pderiv [rule_format]:
"\<forall>p q a. 0 < n &
--- a/src/HOL/Library/Polynomial.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Polynomial.thy Fri Feb 19 15:21:57 2010 +0000
@@ -706,7 +706,7 @@
subsection {* Polynomials form an ordered integral domain *}
definition
- pos_poly :: "'a::ordered_idom poly \<Rightarrow> bool"
+ pos_poly :: "'a::linordered_idom poly \<Rightarrow> bool"
where
"pos_poly p \<longleftrightarrow> 0 < coeff p (degree p)"
@@ -732,7 +732,7 @@
lemma pos_poly_total: "p = 0 \<or> pos_poly p \<or> pos_poly (- p)"
by (induct p) (auto simp add: pos_poly_pCons)
-instantiation poly :: (ordered_idom) ordered_idom
+instantiation poly :: (linordered_idom) linordered_idom
begin
definition
--- a/src/HOL/Library/Quotient.thy Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,196 +0,0 @@
-(* Title: HOL/Library/Quotient.thy
- Author: Markus Wenzel, TU Muenchen
-*)
-
-header {* Quotient types *}
-
-theory Quotient
-imports Main
-begin
-
-text {*
- We introduce the notion of quotient types over equivalence relations
- via type classes.
-*}
-
-subsection {* Equivalence relations and quotient types *}
-
-text {*
- \medskip Type class @{text equiv} models equivalence relations @{text
- "\<sim> :: 'a => 'a => bool"}.
-*}
-
-class eqv =
- fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sim>" 50)
-
-class equiv = eqv +
- assumes equiv_refl [intro]: "x \<sim> x"
- assumes equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
- assumes equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
-
-lemma equiv_not_sym [sym]: "\<not> (x \<sim> y) ==> \<not> (y \<sim> (x::'a::equiv))"
-proof -
- assume "\<not> (x \<sim> y)" then show "\<not> (y \<sim> x)"
- by (rule contrapos_nn) (rule equiv_sym)
-qed
-
-lemma not_equiv_trans1 [trans]: "\<not> (x \<sim> y) ==> y \<sim> z ==> \<not> (x \<sim> (z::'a::equiv))"
-proof -
- assume "\<not> (x \<sim> y)" and "y \<sim> z"
- show "\<not> (x \<sim> z)"
- proof
- assume "x \<sim> z"
- also from `y \<sim> z` have "z \<sim> y" ..
- finally have "x \<sim> y" .
- with `\<not> (x \<sim> y)` show False by contradiction
- qed
-qed
-
-lemma not_equiv_trans2 [trans]: "x \<sim> y ==> \<not> (y \<sim> z) ==> \<not> (x \<sim> (z::'a::equiv))"
-proof -
- assume "\<not> (y \<sim> z)" then have "\<not> (z \<sim> y)" ..
- also assume "x \<sim> y" then have "y \<sim> x" ..
- finally have "\<not> (z \<sim> x)" . then show "(\<not> x \<sim> z)" ..
-qed
-
-text {*
- \medskip The quotient type @{text "'a quot"} consists of all
- \emph{equivalence classes} over elements of the base type @{typ 'a}.
-*}
-
-typedef 'a quot = "{{x. a \<sim> x} | a::'a::eqv. True}"
- by blast
-
-lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
- unfolding quot_def by blast
-
-lemma quotE [elim]: "R \<in> quot ==> (!!a. R = {x. a \<sim> x} ==> C) ==> C"
- unfolding quot_def by blast
-
-text {*
- \medskip Abstracted equivalence classes are the canonical
- representation of elements of a quotient type.
-*}
-
-definition
- "class" :: "'a::equiv => 'a quot" ("\<lfloor>_\<rfloor>") where
- "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"
-
-theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
-proof (cases A)
- fix R assume R: "A = Abs_quot R"
- assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
- with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
- then show ?thesis unfolding class_def .
-qed
-
-lemma quot_cases [cases type: quot]: "(!!a. A = \<lfloor>a\<rfloor> ==> C) ==> C"
- using quot_exhaust by blast
-
-
-subsection {* Equality on quotients *}
-
-text {*
- Equality of canonical quotient elements coincides with the original
- relation.
-*}
-
-theorem quot_equality [iff?]: "(\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>) = (a \<sim> b)"
-proof
- assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
- show "a \<sim> b"
- proof -
- from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
- by (simp only: class_def Abs_quot_inject quotI)
- moreover have "a \<sim> a" ..
- ultimately have "a \<in> {x. b \<sim> x}" by blast
- then have "b \<sim> a" by blast
- then show ?thesis ..
- qed
-next
- assume ab: "a \<sim> b"
- show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
- proof -
- have "{x. a \<sim> x} = {x. b \<sim> x}"
- proof (rule Collect_cong)
- fix x show "(a \<sim> x) = (b \<sim> x)"
- proof
- from ab have "b \<sim> a" ..
- also assume "a \<sim> x"
- finally show "b \<sim> x" .
- next
- note ab
- also assume "b \<sim> x"
- finally show "a \<sim> x" .
- qed
- qed
- then show ?thesis by (simp only: class_def)
- qed
-qed
-
-
-subsection {* Picking representing elements *}
-
-definition
- pick :: "'a::equiv quot => 'a" where
- "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"
-
-theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
-proof (unfold pick_def)
- show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
- proof (rule someI2)
- show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
- fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
- then have "a \<sim> x" .. then show "x \<sim> a" ..
- qed
-qed
-
-theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
-proof (cases A)
- fix a assume a: "A = \<lfloor>a\<rfloor>"
- then have "pick A \<sim> a" by (simp only: pick_equiv)
- then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
- with a show ?thesis by simp
-qed
-
-text {*
- \medskip The following rules support canonical function definitions
- on quotient types (with up to two arguments). Note that the
- stripped-down version without additional conditions is sufficient
- most of the time.
-*}
-
-theorem quot_cond_function:
- assumes eq: "!!X Y. P X Y ==> f X Y == g (pick X) (pick Y)"
- and cong: "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
- ==> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> ==> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
- and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
- shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
-proof -
- from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
- also have "... = g a b"
- proof (rule cong)
- show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
- moreover
- show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
- moreover
- show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
- ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
- qed
- finally show ?thesis .
-qed
-
-theorem quot_function:
- assumes "!!X Y. f X Y == g (pick X) (pick Y)"
- and "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
- shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
- using assms and TrueI
- by (rule quot_cond_function)
-
-theorem quot_function':
- "(!!X Y. f X Y == g (pick X) (pick Y)) ==>
- (!!x x' y y'. x \<sim> x' ==> y \<sim> y' ==> g x y = g x' y') ==>
- f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
- by (rule quot_function) (simp_all only: quot_equality)
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_List.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,232 @@
+(* Title: Quotient_List.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+theory Quotient_List
+imports Main Quotient_Syntax
+begin
+
+section {* Quotient infrastructure for the list type. *}
+
+fun
+ list_rel
+where
+ "list_rel R [] [] = True"
+| "list_rel R (x#xs) [] = False"
+| "list_rel R [] (x#xs) = False"
+| "list_rel R (x#xs) (y#ys) = (R x y \<and> list_rel R xs ys)"
+
+declare [[map list = (map, list_rel)]]
+
+lemma split_list_all:
+ shows "(\<forall>x. P x) \<longleftrightarrow> P [] \<and> (\<forall>x xs. P (x#xs))"
+ apply(auto)
+ apply(case_tac x)
+ apply(simp_all)
+ done
+
+lemma map_id[id_simps]:
+ shows "map id = id"
+ apply(simp add: expand_fun_eq)
+ apply(rule allI)
+ apply(induct_tac x)
+ apply(simp_all)
+ done
+
+
+lemma list_rel_reflp:
+ shows "equivp R \<Longrightarrow> list_rel R xs xs"
+ apply(induct xs)
+ apply(simp_all add: equivp_reflp)
+ done
+
+lemma list_rel_symp:
+ assumes a: "equivp R"
+ shows "list_rel R xs ys \<Longrightarrow> list_rel R ys xs"
+ apply(induct xs ys rule: list_induct2')
+ apply(simp_all)
+ apply(rule equivp_symp[OF a])
+ apply(simp)
+ done
+
+lemma list_rel_transp:
+ assumes a: "equivp R"
+ shows "list_rel R xs1 xs2 \<Longrightarrow> list_rel R xs2 xs3 \<Longrightarrow> list_rel R xs1 xs3"
+ apply(induct xs1 xs2 arbitrary: xs3 rule: list_induct2')
+ apply(simp_all)
+ apply(case_tac xs3)
+ apply(simp_all)
+ apply(rule equivp_transp[OF a])
+ apply(auto)
+ done
+
+lemma list_equivp[quot_equiv]:
+ assumes a: "equivp R"
+ shows "equivp (list_rel R)"
+ apply(rule equivpI)
+ unfolding reflp_def symp_def transp_def
+ apply(subst split_list_all)
+ apply(simp add: equivp_reflp[OF a] list_rel_reflp[OF a])
+ apply(blast intro: list_rel_symp[OF a])
+ apply(blast intro: list_rel_transp[OF a])
+ done
+
+lemma list_rel_rel:
+ assumes q: "Quotient R Abs Rep"
+ shows "list_rel R r s = (list_rel R r r \<and> list_rel R s s \<and> (map Abs r = map Abs s))"
+ apply(induct r s rule: list_induct2')
+ apply(simp_all)
+ using Quotient_rel[OF q]
+ apply(metis)
+ done
+
+lemma list_quotient[quot_thm]:
+ assumes q: "Quotient R Abs Rep"
+ shows "Quotient (list_rel R) (map Abs) (map Rep)"
+ unfolding Quotient_def
+ apply(subst split_list_all)
+ apply(simp add: Quotient_abs_rep[OF q] abs_o_rep[OF q] map_id)
+ apply(rule conjI)
+ apply(rule allI)
+ apply(induct_tac a)
+ apply(simp)
+ apply(simp)
+ apply(simp add: Quotient_rep_reflp[OF q])
+ apply(rule allI)+
+ apply(rule list_rel_rel[OF q])
+ done
+
+
+lemma cons_prs_aux:
+ assumes q: "Quotient R Abs Rep"
+ shows "(map Abs) ((Rep h) # (map Rep t)) = h # t"
+ by (induct t) (simp_all add: Quotient_abs_rep[OF q])
+
+lemma cons_prs[quot_preserve]:
+ assumes q: "Quotient R Abs Rep"
+ shows "(Rep ---> (map Rep) ---> (map Abs)) (op #) = (op #)"
+ by (simp only: expand_fun_eq fun_map_def cons_prs_aux[OF q])
+ (simp)
+
+lemma cons_rsp[quot_respect]:
+ assumes q: "Quotient R Abs Rep"
+ shows "(R ===> list_rel R ===> list_rel R) (op #) (op #)"
+ by (auto)
+
+lemma nil_prs[quot_preserve]:
+ assumes q: "Quotient R Abs Rep"
+ shows "map Abs [] = []"
+ by simp
+
+lemma nil_rsp[quot_respect]:
+ assumes q: "Quotient R Abs Rep"
+ shows "list_rel R [] []"
+ by simp
+
+lemma map_prs_aux:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "(map abs2) (map ((abs1 ---> rep2) f) (map rep1 l)) = map f l"
+ by (induct l)
+ (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+
+lemma map_prs[quot_preserve]:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "((abs1 ---> rep2) ---> (map rep1) ---> (map abs2)) map = map"
+ by (simp only: expand_fun_eq fun_map_def map_prs_aux[OF a b])
+ (simp)
+
+
+lemma map_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "((R1 ===> R2) ===> (list_rel R1) ===> list_rel R2) map map"
+ apply(simp)
+ apply(rule allI)+
+ apply(rule impI)
+ apply(rule allI)+
+ apply (induct_tac xa ya rule: list_induct2')
+ apply simp_all
+ done
+
+lemma foldr_prs_aux:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "abs2 (foldr ((abs1 ---> abs2 ---> rep2) f) (map rep1 l) (rep2 e)) = foldr f l e"
+ by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+lemma foldr_prs[quot_preserve]:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "((abs1 ---> abs2 ---> rep2) ---> (map rep1) ---> rep2 ---> abs2) foldr = foldr"
+ by (simp only: expand_fun_eq fun_map_def foldr_prs_aux[OF a b])
+ (simp)
+
+lemma foldl_prs_aux:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "abs1 (foldl ((abs1 ---> abs2 ---> rep1) f) (rep1 e) (map rep2 l)) = foldl f e l"
+ by (induct l arbitrary:e) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b])
+
+
+lemma foldl_prs[quot_preserve]:
+ assumes a: "Quotient R1 abs1 rep1"
+ and b: "Quotient R2 abs2 rep2"
+ shows "((abs1 ---> abs2 ---> rep1) ---> rep1 ---> (map rep2) ---> abs1) foldl = foldl"
+ by (simp only: expand_fun_eq fun_map_def foldl_prs_aux[OF a b])
+ (simp)
+
+lemma list_rel_empty:
+ shows "list_rel R [] b \<Longrightarrow> length b = 0"
+ by (induct b) (simp_all)
+
+lemma list_rel_len:
+ shows "list_rel R a b \<Longrightarrow> length a = length b"
+ apply (induct a arbitrary: b)
+ apply (simp add: list_rel_empty)
+ apply (case_tac b)
+ apply simp_all
+ done
+
+(* induct_tac doesn't accept 'arbitrary', so we manually 'spec' *)
+lemma foldl_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "((R1 ===> R2 ===> R1) ===> R1 ===> list_rel R2 ===> R1) foldl foldl"
+ apply(auto)
+ apply (subgoal_tac "R1 xa ya \<longrightarrow> list_rel R2 xb yb \<longrightarrow> R1 (foldl x xa xb) (foldl y ya yb)")
+ apply simp
+ apply (rule_tac x="xa" in spec)
+ apply (rule_tac x="ya" in spec)
+ apply (rule_tac xs="xb" and ys="yb" in list_induct2)
+ apply (rule list_rel_len)
+ apply (simp_all)
+ done
+
+lemma foldr_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "((R1 ===> R2 ===> R2) ===> list_rel R1 ===> R2 ===> R2) foldr foldr"
+ apply auto
+ apply(subgoal_tac "R2 xb yb \<longrightarrow> list_rel R1 xa ya \<longrightarrow> R2 (foldr x xa xb) (foldr y ya yb)")
+ apply simp
+ apply (rule_tac xs="xa" and ys="ya" in list_induct2)
+ apply (rule list_rel_len)
+ apply (simp_all)
+ done
+
+lemma list_rel_eq[id_simps]:
+ shows "(list_rel (op =)) = (op =)"
+ unfolding expand_fun_eq
+ apply(rule allI)+
+ apply(induct_tac x xa rule: list_induct2')
+ apply(simp_all)
+ done
+
+lemma list_rel_refl:
+ assumes a: "\<And>x y. R x y = (R x = R y)"
+ shows "list_rel R x x"
+ by (induct x) (auto simp add: a)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Option.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,80 @@
+(* Title: Quotient_Option.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+theory Quotient_Option
+imports Main Quotient_Syntax
+begin
+
+section {* Quotient infrastructure for the option type. *}
+
+fun
+ option_rel
+where
+ "option_rel R None None = True"
+| "option_rel R (Some x) None = False"
+| "option_rel R None (Some x) = False"
+| "option_rel R (Some x) (Some y) = R x y"
+
+declare [[map option = (Option.map, option_rel)]]
+
+text {* should probably be in Option.thy *}
+lemma split_option_all:
+ shows "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>a. P (Some a))"
+ apply(auto)
+ apply(case_tac x)
+ apply(simp_all)
+ done
+
+lemma option_quotient[quot_thm]:
+ assumes q: "Quotient R Abs Rep"
+ shows "Quotient (option_rel R) (Option.map Abs) (Option.map Rep)"
+ unfolding Quotient_def
+ apply(simp add: split_option_all)
+ apply(simp add: Quotient_abs_rep[OF q] Quotient_rel_rep[OF q])
+ using q
+ unfolding Quotient_def
+ apply(blast)
+ done
+
+lemma option_equivp[quot_equiv]:
+ assumes a: "equivp R"
+ shows "equivp (option_rel R)"
+ apply(rule equivpI)
+ unfolding reflp_def symp_def transp_def
+ apply(simp_all add: split_option_all)
+ apply(blast intro: equivp_reflp[OF a])
+ apply(blast intro: equivp_symp[OF a])
+ apply(blast intro: equivp_transp[OF a])
+ done
+
+lemma option_None_rsp[quot_respect]:
+ assumes q: "Quotient R Abs Rep"
+ shows "option_rel R None None"
+ by simp
+
+lemma option_Some_rsp[quot_respect]:
+ assumes q: "Quotient R Abs Rep"
+ shows "(R ===> option_rel R) Some Some"
+ by simp
+
+lemma option_None_prs[quot_preserve]:
+ assumes q: "Quotient R Abs Rep"
+ shows "Option.map Abs None = None"
+ by simp
+
+lemma option_Some_prs[quot_preserve]:
+ assumes q: "Quotient R Abs Rep"
+ shows "(Rep ---> Option.map Abs) Some = Some"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q])
+ done
+
+lemma option_map_id[id_simps]:
+ shows "Option.map id = id"
+ by (simp add: expand_fun_eq split_option_all)
+
+lemma option_rel_eq[id_simps]:
+ shows "option_rel (op =) = (op =)"
+ by (simp add: expand_fun_eq split_option_all)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Product.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,104 @@
+(* Title: Quotient_Product.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+theory Quotient_Product
+imports Main Quotient_Syntax
+begin
+
+section {* Quotient infrastructure for the product type. *}
+
+fun
+ prod_rel
+where
+ "prod_rel R1 R2 = (\<lambda>(a, b) (c, d). R1 a c \<and> R2 b d)"
+
+declare [[map * = (prod_fun, prod_rel)]]
+
+
+lemma prod_equivp[quot_equiv]:
+ assumes a: "equivp R1"
+ assumes b: "equivp R2"
+ shows "equivp (prod_rel R1 R2)"
+ apply(rule equivpI)
+ unfolding reflp_def symp_def transp_def
+ apply(simp_all add: split_paired_all)
+ apply(blast intro: equivp_reflp[OF a] equivp_reflp[OF b])
+ apply(blast intro: equivp_symp[OF a] equivp_symp[OF b])
+ apply(blast intro: equivp_transp[OF a] equivp_transp[OF b])
+ done
+
+lemma prod_quotient[quot_thm]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "Quotient (prod_rel R1 R2) (prod_fun Abs1 Abs2) (prod_fun Rep1 Rep2)"
+ unfolding Quotient_def
+ apply(simp add: split_paired_all)
+ apply(simp add: Quotient_abs_rep[OF q1] Quotient_rel_rep[OF q1])
+ apply(simp add: Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q2])
+ using q1 q2
+ unfolding Quotient_def
+ apply(blast)
+ done
+
+lemma Pair_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(R1 ===> R2 ===> prod_rel R1 R2) Pair Pair"
+ by simp
+
+lemma Pair_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(Rep1 ---> Rep2 ---> (prod_fun Abs1 Abs2)) Pair = Pair"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2])
+ done
+
+lemma fst_rsp[quot_respect]:
+ assumes "Quotient R1 Abs1 Rep1"
+ assumes "Quotient R2 Abs2 Rep2"
+ shows "(prod_rel R1 R2 ===> R1) fst fst"
+ by simp
+
+lemma fst_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(prod_fun Rep1 Rep2 ---> Abs1) fst = fst"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q1])
+ done
+
+lemma snd_rsp[quot_respect]:
+ assumes "Quotient R1 Abs1 Rep1"
+ assumes "Quotient R2 Abs2 Rep2"
+ shows "(prod_rel R1 R2 ===> R2) snd snd"
+ by simp
+
+lemma snd_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(prod_fun Rep1 Rep2 ---> Abs2) snd = snd"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q2])
+ done
+
+lemma split_rsp[quot_respect]:
+ shows "((R1 ===> R2 ===> (op =)) ===> (prod_rel R1 R2) ===> (op =)) split split"
+ by auto
+
+lemma split_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "(((Abs1 ---> Abs2 ---> id) ---> prod_fun Rep1 Rep2 ---> id) split) = split"
+ by (simp add: expand_fun_eq Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2])
+
+lemma prod_fun_id[id_simps]:
+ shows "prod_fun id id = id"
+ by (simp add: prod_fun_def)
+
+lemma prod_rel_eq[id_simps]:
+ shows "prod_rel (op =) (op =) = (op =)"
+ by (simp add: expand_fun_eq)
+
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Sum.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,96 @@
+(* Title: Quotient_Sum.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+theory Quotient_Sum
+imports Main Quotient_Syntax
+begin
+
+section {* Quotient infrastructure for the sum type. *}
+
+fun
+ sum_rel
+where
+ "sum_rel R1 R2 (Inl a1) (Inl b1) = R1 a1 b1"
+| "sum_rel R1 R2 (Inl a1) (Inr b2) = False"
+| "sum_rel R1 R2 (Inr a2) (Inl b1) = False"
+| "sum_rel R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
+
+fun
+ sum_map
+where
+ "sum_map f1 f2 (Inl a) = Inl (f1 a)"
+| "sum_map f1 f2 (Inr a) = Inr (f2 a)"
+
+declare [[map "+" = (sum_map, sum_rel)]]
+
+
+text {* should probably be in Sum_Type.thy *}
+lemma split_sum_all:
+ shows "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P (Inl x)) \<and> (\<forall>x. P (Inr x))"
+ apply(auto)
+ apply(case_tac x)
+ apply(simp_all)
+ done
+
+lemma sum_equivp[quot_equiv]:
+ assumes a: "equivp R1"
+ assumes b: "equivp R2"
+ shows "equivp (sum_rel R1 R2)"
+ apply(rule equivpI)
+ unfolding reflp_def symp_def transp_def
+ apply(simp_all add: split_sum_all)
+ apply(blast intro: equivp_reflp[OF a] equivp_reflp[OF b])
+ apply(blast intro: equivp_symp[OF a] equivp_symp[OF b])
+ apply(blast intro: equivp_transp[OF a] equivp_transp[OF b])
+ done
+
+lemma sum_quotient[quot_thm]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "Quotient (sum_rel R1 R2) (sum_map Abs1 Abs2) (sum_map Rep1 Rep2)"
+ unfolding Quotient_def
+ apply(simp add: split_sum_all)
+ apply(simp_all add: Quotient_abs_rep[OF q1] Quotient_rel_rep[OF q1])
+ apply(simp_all add: Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q2])
+ using q1 q2
+ unfolding Quotient_def
+ apply(blast)+
+ done
+
+lemma sum_Inl_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(R1 ===> sum_rel R1 R2) Inl Inl"
+ by simp
+
+lemma sum_Inr_rsp[quot_respect]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(R2 ===> sum_rel R1 R2) Inr Inr"
+ by simp
+
+lemma sum_Inl_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(Rep1 ---> sum_map Abs1 Abs2) Inl = Inl"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q1])
+ done
+
+lemma sum_Inr_prs[quot_preserve]:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ assumes q2: "Quotient R2 Abs2 Rep2"
+ shows "(Rep2 ---> sum_map Abs1 Abs2) Inr = Inr"
+ apply(simp add: expand_fun_eq)
+ apply(simp add: Quotient_abs_rep[OF q2])
+ done
+
+lemma sum_map_id[id_simps]:
+ shows "sum_map id id = id"
+ by (simp add: expand_fun_eq split_sum_all)
+
+lemma sum_rel_eq[id_simps]:
+ shows "sum_rel (op =) (op =) = (op =)"
+ by (simp add: expand_fun_eq split_sum_all)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Syntax.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,18 @@
+(* Title: Quotient_Syntax.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+
+header {* Pretty syntax for Quotient operations *}
+
+(*<*)
+theory Quotient_Syntax
+imports Main
+begin
+
+notation
+ rel_conj (infixr "OOO" 75) and
+ fun_map (infixr "--->" 55) and
+ fun_rel (infixr "===>" 55)
+
+end
+(*>*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,196 @@
+(* Title: HOL/Library/Quotient_Type.thy
+ Author: Markus Wenzel, TU Muenchen
+*)
+
+header {* Quotient types *}
+
+theory Quotient_Type
+imports Main
+begin
+
+text {*
+ We introduce the notion of quotient types over equivalence relations
+ via type classes.
+*}
+
+subsection {* Equivalence relations and quotient types *}
+
+text {*
+ \medskip Type class @{text equiv} models equivalence relations @{text
+ "\<sim> :: 'a => 'a => bool"}.
+*}
+
+class eqv =
+ fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sim>" 50)
+
+class equiv = eqv +
+ assumes equiv_refl [intro]: "x \<sim> x"
+ assumes equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
+ assumes equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
+
+lemma equiv_not_sym [sym]: "\<not> (x \<sim> y) ==> \<not> (y \<sim> (x::'a::equiv))"
+proof -
+ assume "\<not> (x \<sim> y)" then show "\<not> (y \<sim> x)"
+ by (rule contrapos_nn) (rule equiv_sym)
+qed
+
+lemma not_equiv_trans1 [trans]: "\<not> (x \<sim> y) ==> y \<sim> z ==> \<not> (x \<sim> (z::'a::equiv))"
+proof -
+ assume "\<not> (x \<sim> y)" and "y \<sim> z"
+ show "\<not> (x \<sim> z)"
+ proof
+ assume "x \<sim> z"
+ also from `y \<sim> z` have "z \<sim> y" ..
+ finally have "x \<sim> y" .
+ with `\<not> (x \<sim> y)` show False by contradiction
+ qed
+qed
+
+lemma not_equiv_trans2 [trans]: "x \<sim> y ==> \<not> (y \<sim> z) ==> \<not> (x \<sim> (z::'a::equiv))"
+proof -
+ assume "\<not> (y \<sim> z)" then have "\<not> (z \<sim> y)" ..
+ also assume "x \<sim> y" then have "y \<sim> x" ..
+ finally have "\<not> (z \<sim> x)" . then show "(\<not> x \<sim> z)" ..
+qed
+
+text {*
+ \medskip The quotient type @{text "'a quot"} consists of all
+ \emph{equivalence classes} over elements of the base type @{typ 'a}.
+*}
+
+typedef 'a quot = "{{x. a \<sim> x} | a::'a::eqv. True}"
+ by blast
+
+lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
+ unfolding quot_def by blast
+
+lemma quotE [elim]: "R \<in> quot ==> (!!a. R = {x. a \<sim> x} ==> C) ==> C"
+ unfolding quot_def by blast
+
+text {*
+ \medskip Abstracted equivalence classes are the canonical
+ representation of elements of a quotient type.
+*}
+
+definition
+ "class" :: "'a::equiv => 'a quot" ("\<lfloor>_\<rfloor>") where
+ "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"
+
+theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
+proof (cases A)
+ fix R assume R: "A = Abs_quot R"
+ assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
+ with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
+ then show ?thesis unfolding class_def .
+qed
+
+lemma quot_cases [cases type: quot]: "(!!a. A = \<lfloor>a\<rfloor> ==> C) ==> C"
+ using quot_exhaust by blast
+
+
+subsection {* Equality on quotients *}
+
+text {*
+ Equality of canonical quotient elements coincides with the original
+ relation.
+*}
+
+theorem quot_equality [iff?]: "(\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>) = (a \<sim> b)"
+proof
+ assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
+ show "a \<sim> b"
+ proof -
+ from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
+ by (simp only: class_def Abs_quot_inject quotI)
+ moreover have "a \<sim> a" ..
+ ultimately have "a \<in> {x. b \<sim> x}" by blast
+ then have "b \<sim> a" by blast
+ then show ?thesis ..
+ qed
+next
+ assume ab: "a \<sim> b"
+ show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
+ proof -
+ have "{x. a \<sim> x} = {x. b \<sim> x}"
+ proof (rule Collect_cong)
+ fix x show "(a \<sim> x) = (b \<sim> x)"
+ proof
+ from ab have "b \<sim> a" ..
+ also assume "a \<sim> x"
+ finally show "b \<sim> x" .
+ next
+ note ab
+ also assume "b \<sim> x"
+ finally show "a \<sim> x" .
+ qed
+ qed
+ then show ?thesis by (simp only: class_def)
+ qed
+qed
+
+
+subsection {* Picking representing elements *}
+
+definition
+ pick :: "'a::equiv quot => 'a" where
+ "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"
+
+theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
+proof (unfold pick_def)
+ show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
+ proof (rule someI2)
+ show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
+ fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
+ then have "a \<sim> x" .. then show "x \<sim> a" ..
+ qed
+qed
+
+theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
+proof (cases A)
+ fix a assume a: "A = \<lfloor>a\<rfloor>"
+ then have "pick A \<sim> a" by (simp only: pick_equiv)
+ then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
+ with a show ?thesis by simp
+qed
+
+text {*
+ \medskip The following rules support canonical function definitions
+ on quotient types (with up to two arguments). Note that the
+ stripped-down version without additional conditions is sufficient
+ most of the time.
+*}
+
+theorem quot_cond_function:
+ assumes eq: "!!X Y. P X Y ==> f X Y == g (pick X) (pick Y)"
+ and cong: "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
+ ==> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> ==> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
+ and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
+ shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+proof -
+ from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
+ also have "... = g a b"
+ proof (rule cong)
+ show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
+ moreover
+ show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
+ moreover
+ show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
+ ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
+ qed
+ finally show ?thesis .
+qed
+
+theorem quot_function:
+ assumes "!!X Y. f X Y == g (pick X) (pick Y)"
+ and "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
+ shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+ using assms and TrueI
+ by (rule quot_cond_function)
+
+theorem quot_function':
+ "(!!X Y. f X Y == g (pick X) (pick Y)) ==>
+ (!!x x' y y'. x \<sim> x' ==> y \<sim> y' ==> g x y = g x' y') ==>
+ f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+ by (rule quot_function) (simp_all only: quot_equality)
+
+end
--- a/src/HOL/Library/Ramsey.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Ramsey.thy Fri Feb 19 15:21:57 2010 +0000
@@ -111,7 +111,7 @@
have infYx': "infinite (Yx-{yx'})" using fields px by auto
with fields px yx' Suc.prems
have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
- by (simp add: o_def part_Suc_imp_part part_subset [where ?YY=YY])
+ by (simp add: o_def part_Suc_imp_part part_subset [where YY=YY and Y=Yx])
from Suc.hyps [OF infYx' partfx']
obtain Y' and t'
where Y': "Y' \<subseteq> Yx - {yx'}" "infinite Y'" "t' < s"
--- a/src/HOL/Library/State_Monad.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/State_Monad.thy Fri Feb 19 15:21:57 2010 +0000
@@ -159,15 +159,15 @@
fun unfold_monad (Const (@{const_syntax scomp}, _) $ f $ g) =
let
val (v, g') = dest_abs_eta g;
- in Const ("_scomp", dummyT) $ v $ f $ unfold_monad g' end
+ in Const (@{syntax_const "_scomp"}, dummyT) $ v $ f $ unfold_monad g' end
| unfold_monad (Const (@{const_syntax fcomp}, _) $ f $ g) =
- Const ("_fcomp", dummyT) $ f $ unfold_monad g
+ Const (@{syntax_const "_fcomp"}, dummyT) $ f $ unfold_monad g
| unfold_monad (Const (@{const_syntax Let}, _) $ f $ g) =
let
val (v, g') = dest_abs_eta g;
- in Const ("_let", dummyT) $ v $ f $ unfold_monad g' end
+ in Const (@{syntax_const "_let"}, dummyT) $ v $ f $ unfold_monad g' end
| unfold_monad (Const (@{const_syntax Pair}, _) $ f) =
- Const ("return", dummyT) $ f
+ Const (@{const_syntax "return"}, dummyT) $ f
| unfold_monad f = f;
fun contains_scomp (Const (@{const_syntax scomp}, _) $ _ $ _) = true
| contains_scomp (Const (@{const_syntax fcomp}, _) $ _ $ t) =
@@ -175,18 +175,23 @@
| contains_scomp (Const (@{const_syntax Let}, _) $ _ $ Abs (_, _, t)) =
contains_scomp t;
fun scomp_monad_tr' (f::g::ts) = list_comb
- (Const ("_do", dummyT) $ unfold_monad (Const (@{const_syntax scomp}, dummyT) $ f $ g), ts);
- fun fcomp_monad_tr' (f::g::ts) = if contains_scomp g then list_comb
- (Const ("_do", dummyT) $ unfold_monad (Const (@{const_syntax fcomp}, dummyT) $ f $ g), ts)
+ (Const (@{syntax_const "_do"}, dummyT) $
+ unfold_monad (Const (@{const_syntax scomp}, dummyT) $ f $ g), ts);
+ fun fcomp_monad_tr' (f::g::ts) =
+ if contains_scomp g then list_comb
+ (Const (@{syntax_const "_do"}, dummyT) $
+ unfold_monad (Const (@{const_syntax fcomp}, dummyT) $ f $ g), ts)
else raise Match;
- fun Let_monad_tr' (f :: (g as Abs (_, _, g')) :: ts) = if contains_scomp g' then list_comb
- (Const ("_do", dummyT) $ unfold_monad (Const (@{const_syntax Let}, dummyT) $ f $ g), ts)
+ fun Let_monad_tr' (f :: (g as Abs (_, _, g')) :: ts) =
+ if contains_scomp g' then list_comb
+ (Const (@{syntax_const "_do"}, dummyT) $
+ unfold_monad (Const (@{const_syntax Let}, dummyT) $ f $ g), ts)
else raise Match;
-in [
- (@{const_syntax scomp}, scomp_monad_tr'),
+in
+ [(@{const_syntax scomp}, scomp_monad_tr'),
(@{const_syntax fcomp}, fcomp_monad_tr'),
- (@{const_syntax Let}, Let_monad_tr')
-] end;
+ (@{const_syntax Let}, Let_monad_tr')]
+end;
*}
text {*
--- a/src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML Fri Feb 19 15:21:57 2010 +0000
@@ -54,10 +54,12 @@
(* call solver *)
val output_file = filename dir "sos_out"
- val (output, rv) = system_out (
- if File.exists cmd then space_implode " "
- [File.shell_path cmd, File.shell_path input_file, File.shell_path output_file]
- else error ("Bad executable: " ^ File.platform_path cmd))
+ val (output, rv) =
+ bash_output
+ (if File.exists cmd then
+ space_implode " "
+ [File.shell_path cmd, File.shell_path input_file, File.shell_path output_file]
+ else error ("Bad executable: " ^ File.platform_path cmd))
(* read and analyze output *)
val (res, res_msg) = find_failure rv
--- a/src/HOL/Library/Tree.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Tree.thy Fri Feb 19 15:21:57 2010 +0000
@@ -96,11 +96,11 @@
subsection {* Trees as mappings *}
-definition Tree :: "('a\<Colon>linorder, 'b) tree \<Rightarrow> ('a, 'b) map" where
- "Tree t = Map (Tree.lookup t)"
+definition Tree :: "('a\<Colon>linorder, 'b) tree \<Rightarrow> ('a, 'b) mapping" where
+ "Tree t = Mapping (Tree.lookup t)"
lemma [code, code del]:
- "(eq_class.eq :: (_, _) map \<Rightarrow> _) = eq_class.eq" ..
+ "(eq_class.eq :: (_, _) mapping \<Rightarrow> _) = eq_class.eq" ..
lemma [code, code del]:
"Mapping.delete k m = Mapping.delete k m" ..
@@ -115,13 +115,21 @@
"Mapping.lookup (Tree t) = lookup t"
by (simp add: Tree_def)
+lemma is_empty_Tree [code]:
+ "Mapping.is_empty (Tree Empty) \<longleftrightarrow> True"
+ "Mapping.is_empty (Tree (Branch v k l r)) \<longleftrightarrow> False"
+ by (simp_all only: is_empty_def lookup_Tree dom_lookup) auto
+
lemma update_Tree [code]:
"Mapping.update k v (Tree t) = Tree (update k v t)"
by (simp add: Tree_def lookup_update)
+lemma [code, code del]:
+ "Mapping.ordered_keys = Mapping.ordered_keys " ..
+
lemma keys_Tree [code]:
"Mapping.keys (Tree t) = set (filter (\<lambda>k. lookup t k \<noteq> None) (remdups (keys t)))"
- by (simp add: Tree_def dom_lookup)
+ by (simp add: Mapping.keys_def lookup_Tree dom_lookup)
lemma size_Tree [code]:
"Mapping.size (Tree t) = size t"
@@ -135,8 +143,10 @@
"Mapping.tabulate ks f = Tree (bulkload (sort ks) f)"
proof -
have "Mapping.lookup (Mapping.tabulate ks f) = Mapping.lookup (Tree (bulkload (sort ks) f))"
- by (simp add: lookup_Tree lookup_bulkload lookup_tabulate)
- then show ?thesis by (simp add: lookup_inject)
+ by (simp add: lookup_bulkload lookup_Tree)
+ then show ?thesis by (simp only: lookup_inject)
qed
+hide (open) const Empty Branch lookup update keys size bulkload Tree
+
end
--- a/src/HOL/Library/Univ_Poly.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Univ_Poly.thy Fri Feb 19 15:21:57 2010 +0000
@@ -990,7 +990,7 @@
text{*bound for polynomial.*}
-lemma poly_mono: "abs(x) \<le> k ==> abs(poly p (x::'a::{ordered_idom})) \<le> poly (map abs p) k"
+lemma poly_mono: "abs(x) \<le> k ==> abs(poly p (x::'a::{linordered_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)
--- a/src/HOL/Library/Word.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Word.thy Fri Feb 19 15:21:57 2010 +0000
@@ -980,7 +980,8 @@
fix xs
assume "length (norm_signed (\<zero>#xs)) = Suc (length xs)"
thus "norm_signed (\<zero>#xs) = \<zero>#xs"
- by (simp add: norm_signed_Cons norm_unsigned_equal split: split_if_asm)
+ by (simp add: norm_signed_Cons norm_unsigned_equal [THEN eqTrueI]
+ split: split_if_asm)
next
fix xs
assume "length (norm_signed (\<one>#xs)) = Suc (length xs)"
--- a/src/HOL/Library/Zorn.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/Zorn.thy Fri Feb 19 15:21:57 2010 +0000
@@ -333,7 +333,7 @@
lemma antisym_init_seg_of:
"r initial_segment_of s \<Longrightarrow> s initial_segment_of r \<Longrightarrow> r=s"
-by(auto simp:init_seg_of_def)
+unfolding init_seg_of_def by safe
lemma Chain_init_seg_of_Union:
"R \<in> Chain init_seg_of \<Longrightarrow> r\<in>R \<Longrightarrow> r initial_segment_of \<Union>R"
--- a/src/HOL/Library/positivstellensatz.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Library/positivstellensatz.ML Fri Feb 19 15:21:57 2010 +0000
@@ -275,7 +275,7 @@
"((a + b + min x y + c > r) = (a + b + x + c > r & a + b + y + c > r))"
by auto};
-val abs_split' = @{lemma "P (abs (x::'a::ordered_idom)) == (x >= 0 & P x | x < 0 & P (-x))"
+val abs_split' = @{lemma "P (abs (x::'a::linordered_idom)) == (x >= 0 & P x | x < 0 & P (-x))"
by (atomize (full)) (auto split add: abs_split)};
val max_split = @{lemma "P (max x y) == ((x::'a::linorder) <= y & P y | x > y & P x)"
--- a/src/HOL/List.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/List.thy Fri Feb 19 15:21:57 2010 +0000
@@ -15,13 +15,14 @@
syntax
-- {* list Enumeration *}
- "@list" :: "args => 'a list" ("[(_)]")
+ "_list" :: "args => 'a list" ("[(_)]")
translations
"[x, xs]" == "x#[xs]"
"[x]" == "x#[]"
-subsection{*Basic list processing functions*}
+
+subsection {* Basic list processing functions *}
primrec
hd :: "'a list \<Rightarrow> 'a" where
@@ -68,15 +69,15 @@
syntax
-- {* Special syntax for filter *}
- "@filter" :: "[pttrn, 'a list, bool] => 'a list" ("(1[_<-_./ _])")
+ "_filter" :: "[pttrn, 'a list, bool] => 'a list" ("(1[_<-_./ _])")
translations
"[x<-xs . P]"== "CONST filter (%x. P) xs"
syntax (xsymbols)
- "@filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
+ "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
syntax (HTML output)
- "@filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
+ "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
primrec
foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
@@ -132,7 +133,7 @@
"_LUpdate" :: "['a, lupdbinds] => 'a" ("_/[(_)]" [900,0] 900)
translations
- "_LUpdate xs (_lupdbinds b bs)"== "_LUpdate (_LUpdate xs b) bs"
+ "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"
"xs[i:=x]" == "CONST list_update xs i x"
primrec
@@ -256,9 +257,9 @@
@{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\
@{lemma "sublist [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:sublist_def)}\\
@{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by (simp add:rotate1_def)}\\
-@{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate1_def rotate_def nat_number)}\\
-@{lemma "replicate 4 a = [a,a,a,a]" by (simp add:nat_number)}\\
-@{lemma "[2..<5] = [2,3,4]" by (simp add:nat_number)}\\
+@{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate1_def rotate_def nat_number')}\\
+@{lemma "replicate 4 a = [a,a,a,a]" by (simp add:nat_number')}\\
+@{lemma "[2..<5] = [2,3,4]" by (simp add:nat_number')}\\
@{lemma "listsum [1,2,3::nat] = 6" by simp}
\end{tabular}}
\caption{Characteristic examples}
@@ -283,9 +284,8 @@
"insort_key f x [] = [x]" |
"insort_key f x (y#ys) = (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"
-primrec sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
-"sort_key f [] = []" |
-"sort_key f (x#xs) = insort_key f x (sort_key f xs)"
+definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
+"sort_key f xs = foldr (insort_key f) xs []"
abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"
abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"
@@ -363,45 +363,52 @@
val mapC = Syntax.const @{const_name map};
val concatC = Syntax.const @{const_name concat};
val IfC = Syntax.const @{const_name If};
+
fun singl x = ConsC $ x $ NilC;
- fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)
+ fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)
let
val x = Free (Name.variant (fold Term.add_free_names [p, e] []) "x", dummyT);
val e = if opti then singl e else e;
- val case1 = Syntax.const "_case1" $ p $ e;
- val case2 = Syntax.const "_case1" $ Syntax.const Term.dummy_patternN
- $ NilC;
- val cs = Syntax.const "_case2" $ case1 $ case2
- val ft = Datatype_Case.case_tr false Datatype.info_of_constr
- ctxt [x, cs]
+ val case1 = Syntax.const @{syntax_const "_case1"} $ p $ e;
+ val case2 = Syntax.const @{syntax_const "_case1"} $ Syntax.const Term.dummy_patternN $ NilC;
+ val cs = Syntax.const @{syntax_const "_case2"} $ case1 $ case2;
+ val ft = Datatype_Case.case_tr false Datatype.info_of_constr ctxt [x, cs];
in lambda x ft end;
fun abs_tr ctxt (p as Free(s,T)) e opti =
- let val thy = ProofContext.theory_of ctxt;
- val s' = Sign.intern_const thy s
- in if Sign.declared_const thy s'
- then (pat_tr ctxt p e opti, false)
- else (lambda p e, true)
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val s' = Sign.intern_const thy s;
+ in
+ if Sign.declared_const thy s'
+ then (pat_tr ctxt p e opti, false)
+ else (lambda p e, true)
end
| abs_tr ctxt p e opti = (pat_tr ctxt p e opti, false);
- fun lc_tr ctxt [e, Const("_lc_test",_)$b, qs] =
- let val res = case qs of Const("_lc_end",_) => singl e
- | Const("_lc_quals",_)$q$qs => lc_tr ctxt [e,q,qs];
+ fun lc_tr ctxt [e, Const (@{syntax_const "_lc_test"}, _) $ b, qs] =
+ let
+ val res =
+ (case qs of
+ Const (@{syntax_const "_lc_end"}, _) => singl e
+ | Const (@{syntax_const "_lc_quals"}, _) $ q $ qs => lc_tr ctxt [e, q, qs]);
in IfC $ b $ res $ NilC end
- | lc_tr ctxt [e, Const("_lc_gen",_) $ p $ es, Const("_lc_end",_)] =
+ | lc_tr ctxt
+ [e, Const (@{syntax_const "_lc_gen"}, _) $ p $ es,
+ Const(@{syntax_const "_lc_end"}, _)] =
(case abs_tr ctxt p e true of
- (f,true) => mapC $ f $ es
- | (f, false) => concatC $ (mapC $ f $ es))
- | lc_tr ctxt [e, Const("_lc_gen",_) $ p $ es, Const("_lc_quals",_)$q$qs] =
- let val e' = lc_tr ctxt [e,q,qs];
- in concatC $ (mapC $ (fst(abs_tr ctxt p e' false)) $ es) end
-
-in [("_listcompr", lc_tr)] end
+ (f, true) => mapC $ f $ es
+ | (f, false) => concatC $ (mapC $ f $ es))
+ | lc_tr ctxt
+ [e, Const (@{syntax_const "_lc_gen"}, _) $ p $ es,
+ Const (@{syntax_const "_lc_quals"}, _) $ q $ qs] =
+ let val e' = lc_tr ctxt [e, q, qs];
+ in concatC $ (mapC $ (fst (abs_tr ctxt p e' false)) $ es) end;
+
+in [(@{syntax_const "_listcompr"}, lc_tr)] end
*}
-(*
term "[(x,y,z). b]"
term "[(x,y,z). x\<leftarrow>xs]"
term "[e x y. x\<leftarrow>xs, y\<leftarrow>ys]"
@@ -418,9 +425,11 @@
term "[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]"
term "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x]"
term "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]"
+(*
term "[(x,y). x\<leftarrow>xs, let xx = x+x, y\<leftarrow>ys, y \<noteq> xx]"
*)
+
subsubsection {* @{const Nil} and @{const Cons} *}
lemma not_Cons_self [simp]:
@@ -711,6 +720,11 @@
lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"
by (induct xs) auto
+lemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"
+apply(rule ext)
+apply(simp)
+done
+
lemma rev_map: "rev (map f xs) = map f (rev xs)"
by (induct xs) auto
@@ -1019,6 +1033,7 @@
"set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"
by (induct xs) auto
+
subsubsection {* @{text filter} *}
lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"
@@ -1200,6 +1215,7 @@
declare partition.simps[simp del]
+
subsubsection {* @{text concat} *}
lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"
@@ -2074,6 +2090,7 @@
qed simp
qed simp
+
subsubsection {* @{text list_all2} *}
lemma list_all2_lengthD [intro?]:
@@ -2253,6 +2270,12 @@
==> foldr f l a = foldr g k b"
by (induct k arbitrary: a b l) simp_all
+lemma foldl_fun_comm:
+ assumes "\<And>x y s. f (f s x) y = f (f s y) x"
+ shows "f (foldl f s xs) x = foldl f (f s x) xs"
+ by (induct xs arbitrary: s)
+ (simp_all add: assms)
+
lemma (in semigroup_add) foldl_assoc:
shows "foldl op+ (x+y) zs = x + (foldl op+ y zs)"
by (induct zs arbitrary: y) (simp_all add:add_assoc)
@@ -2261,6 +2284,15 @@
shows "x + (foldl op+ 0 zs) = foldl op+ x zs"
by (induct zs) (simp_all add:foldl_assoc)
+lemma foldl_rev:
+ assumes "\<And>x y s. f (f s x) y = f (f s y) x"
+ shows "foldl f s (rev xs) = foldl f s xs"
+proof (induct xs arbitrary: s)
+ case Nil then show ?case by simp
+next
+ case (Cons x xs) with assms show ?case by (simp add: foldl_fun_comm)
+qed
+
text{* The ``First Duality Theorem'' in Bird \& Wadler: *}
@@ -2329,6 +2361,10 @@
text {* @{const Finite_Set.fold} and @{const foldl} *}
+lemma (in fun_left_comm) fold_set_remdups:
+ "fold f y (set xs) = foldl (\<lambda>y x. f x y) y (remdups xs)"
+ by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)
+
lemma (in fun_left_comm_idem) fold_set:
"fold f y (set xs) = foldl (\<lambda>y x. f x y) y xs"
by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)
@@ -2413,6 +2449,7 @@
unfolding SUPR_def set_map [symmetric] Sup_set_fold foldl_map
by (simp add: sup_commute)
+
subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}
lemma listsum_append [simp]: "listsum (xs @ ys) = listsum xs + listsum ys"
@@ -2500,12 +2537,12 @@
by (induct xs, simp_all add: algebra_simps)
lemma listsum_abs:
- fixes xs :: "'a::pordered_ab_group_add_abs list"
+ fixes xs :: "'a::ordered_ab_group_add_abs list"
shows "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"
by (induct xs, simp, simp add: order_trans [OF abs_triangle_ineq])
lemma listsum_mono:
- fixes f g :: "'a \<Rightarrow> 'b::{comm_monoid_add, pordered_ab_semigroup_add}"
+ fixes f g :: "'a \<Rightarrow> 'b::{comm_monoid_add, ordered_ab_semigroup_add}"
shows "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sum>x\<leftarrow>xs. f x) \<le> (\<Sum>x\<leftarrow>xs. g x)"
by (induct xs, simp, simp add: add_mono)
@@ -2835,6 +2872,7 @@
from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp
qed
+
subsubsection {* @{const insert} *}
lemma in_set_insert [simp]:
@@ -3254,7 +3292,8 @@
apply auto
done
-subsubsection{*Transpose*}
+
+subsubsection {* Transpose *}
function transpose where
"transpose [] = []" |
@@ -3366,6 +3405,7 @@
by (simp add: nth_transpose filter_map comp_def)
qed
+
subsubsection {* (In)finiteness *}
lemma finite_maxlen:
@@ -3407,7 +3447,7 @@
done
-subsection {*Sorting*}
+subsection {* Sorting *}
text{* Currently it is not shown that @{const sort} returns a
permutation of its input because the nicest proof is via multisets,
@@ -3421,6 +3461,24 @@
lemma length_insert[simp] : "length (insort_key f x xs) = Suc (length xs)"
by (induct xs, auto)
+lemma insort_left_comm:
+ "insort x (insort y xs) = insort y (insort x xs)"
+ by (induct xs) auto
+
+lemma fun_left_comm_insort:
+ "fun_left_comm insort"
+proof
+qed (fact insort_left_comm)
+
+lemma sort_key_simps [simp]:
+ "sort_key f [] = []"
+ "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
+ by (simp_all add: sort_key_def)
+
+lemma sort_foldl_insort:
+ "sort xs = foldl (\<lambda>ys x. insort x ys) [] xs"
+ by (simp add: sort_key_def foldr_foldl foldl_rev insort_left_comm)
+
lemma length_sort[simp]: "length (sort_key f xs) = length xs"
by (induct xs, auto)
@@ -3626,7 +3684,8 @@
apply(simp add:sorted_Cons)
done
-subsubsection {*@{const transpose} on sorted lists*}
+
+subsubsection {* @{const transpose} on sorted lists *}
lemma sorted_transpose[simp]:
shows "sorted (rev (map length (transpose xs)))"
@@ -3774,6 +3833,7 @@
by (auto simp: nth_transpose intro: nth_equalityI)
qed
+
subsubsection {* @{text sorted_list_of_set} *}
text{* This function maps (finite) linearly ordered sets to sorted
@@ -3781,30 +3841,39 @@
sets to lists but one should convert in the other direction (via
@{const set}). *}
-
context linorder
begin
-definition
- sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
- [code del]: "sorted_list_of_set A == THE xs. set xs = A & sorted xs & distinct xs"
-
-lemma sorted_list_of_set[simp]: "finite A \<Longrightarrow>
- set(sorted_list_of_set A) = A &
- sorted(sorted_list_of_set A) & distinct(sorted_list_of_set A)"
-apply(simp add:sorted_list_of_set_def)
-apply(rule the1I2)
- apply(simp_all add: finite_sorted_distinct_unique)
-done
-
-lemma sorted_list_of_empty[simp]: "sorted_list_of_set {} = []"
-unfolding sorted_list_of_set_def
-apply(subst the_equality[of _ "[]"])
-apply simp_all
-done
+definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
+ "sorted_list_of_set = Finite_Set.fold insort []"
+
+lemma sorted_list_of_set_empty [simp]:
+ "sorted_list_of_set {} = []"
+ by (simp add: sorted_list_of_set_def)
+
+lemma sorted_list_of_set_insert [simp]:
+ assumes "finite A"
+ shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
+proof -
+ interpret fun_left_comm insort by (fact fun_left_comm_insort)
+ with assms show ?thesis by (simp add: sorted_list_of_set_def fold_insert_remove)
+qed
+
+lemma sorted_list_of_set [simp]:
+ "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A)
+ \<and> distinct (sorted_list_of_set A)"
+ by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)
+
+lemma sorted_list_of_set_sort_remdups:
+ "sorted_list_of_set (set xs) = sort (remdups xs)"
+proof -
+ interpret fun_left_comm insort by (fact fun_left_comm_insort)
+ show ?thesis by (simp add: sort_foldl_insort sorted_list_of_set_def fold_set_remdups)
+qed
end
+
subsubsection {* @{text lists}: the list-forming operator over sets *}
inductive_set
@@ -3864,8 +3933,7 @@
by auto
-
-subsubsection{* Inductive definition for membership *}
+subsubsection {* Inductive definition for membership *}
inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
@@ -3881,8 +3949,7 @@
done
-
-subsubsection{*Lists as Cartesian products*}
+subsubsection {* Lists as Cartesian products *}
text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from
@{term A} and tail drawn from @{term Xs}.*}
@@ -3903,7 +3970,7 @@
| "listset (A # As) = set_Cons A (listset As)"
-subsection{*Relations on Lists*}
+subsection {* Relations on Lists *}
subsubsection {* Length Lexicographic Ordering *}
@@ -4108,7 +4175,7 @@
by auto
-subsubsection{*Lifting a Relation on List Elements to the Lists*}
+subsubsection {* Lifting a Relation on List Elements to the Lists *}
inductive_set
listrel :: "('a * 'a)set => ('a list * 'a list)set"
--- a/src/HOL/Main.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Main.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,7 @@
header {* Main HOL *}
theory Main
-imports Plain Predicate_Compile Nitpick
+imports Plain Predicate_Compile Nitpick Quotient
begin
text {*
--- a/src/HOL/Map.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Map.thy Fri Feb 19 15:21:57 2010 +0000
@@ -68,7 +68,7 @@
translations
"_MapUpd m (_Maplets xy ms)" == "_MapUpd (_MapUpd m xy) ms"
- "_MapUpd m (_maplet x y)" == "m(x:=Some y)"
+ "_MapUpd m (_maplet x y)" == "m(x := CONST Some y)"
"_Map ms" == "_MapUpd (CONST empty) ms"
"_Map (_Maplets ms1 ms2)" <= "_MapUpd (_Map ms1) ms2"
"_Maplets ms1 (_Maplets ms2 ms3)" <= "_Maplets (_Maplets ms1 ms2) ms3"
@@ -389,6 +389,10 @@
"x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
by (simp add: restrict_map_def expand_fun_eq)
+lemma map_of_map_restrict:
+ "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
+ by (induct ks) (simp_all add: expand_fun_eq restrict_map_insert)
+
subsection {* @{term [source] map_upds} *}
@@ -534,7 +538,7 @@
by (auto simp add: map_add_def split: option.split_asm)
lemma dom_const [simp]:
- "dom (\<lambda>x. Some y) = UNIV"
+ "dom (\<lambda>x. Some (f x)) = UNIV"
by auto
(* Due to John Matthews - could be rephrased with dom *)
--- a/src/HOL/Matrix/ComputeFloat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/ComputeFloat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,7 +5,7 @@
header {* Floating Point Representation of the Reals *}
theory ComputeFloat
-imports Complex_Main
+imports Complex_Main Lattice_Algebras
uses "~~/src/Tools/float.ML" ("~~/src/HOL/Tools/float_arith.ML")
begin
--- a/src/HOL/Matrix/ComputeNumeral.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/ComputeNumeral.thy Fri Feb 19 15:21:57 2010 +0000
@@ -109,22 +109,22 @@
lemmas compute_natarith = bitarith natnorm natsuc natadd natsub natmul nateq natless natle natfac.simps
-lemma number_eq: "(((number_of x)::'a::{number_ring, ordered_idom}) = (number_of y)) = (x = y)"
+lemma number_eq: "(((number_of x)::'a::{number_ring, linordered_idom}) = (number_of y)) = (x = y)"
unfolding number_of_eq
apply simp
done
-lemma number_le: "(((number_of x)::'a::{number_ring, ordered_idom}) \<le> (number_of y)) = (x \<le> y)"
+lemma number_le: "(((number_of x)::'a::{number_ring, linordered_idom}) \<le> (number_of y)) = (x \<le> y)"
unfolding number_of_eq
apply simp
done
-lemma number_less: "(((number_of x)::'a::{number_ring, ordered_idom}) < (number_of y)) = (x < y)"
+lemma number_less: "(((number_of x)::'a::{number_ring, linordered_idom}) < (number_of y)) = (x < y)"
unfolding number_of_eq
apply simp
done
-lemma number_diff: "((number_of x)::'a::{number_ring, ordered_idom}) - number_of y = number_of (x + (- y))"
+lemma number_diff: "((number_of x)::'a::{number_ring, linordered_idom}) - number_of y = number_of (x + (- y))"
apply (subst diff_number_of_eq)
apply simp
done
--- a/src/HOL/Matrix/LP.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/LP.thy Fri Feb 19 15:21:57 2010 +0000
@@ -3,12 +3,12 @@
*)
theory LP
-imports Main
+imports Main Lattice_Algebras
begin
lemma linprog_dual_estimate:
assumes
- "A * x \<le> (b::'a::lordered_ring)"
+ "A * x \<le> (b::'a::lattice_ring)"
"0 \<le> y"
"abs (A - A') \<le> \<delta>A"
"b \<le> b'"
@@ -57,7 +57,7 @@
lemma le_ge_imp_abs_diff_1:
assumes
- "A1 <= (A::'a::lordered_ring)"
+ "A1 <= (A::'a::lattice_ring)"
"A <= A2"
shows "abs (A-A1) <= A2-A1"
proof -
@@ -72,7 +72,7 @@
lemma mult_le_prts:
assumes
- "a1 <= (a::'a::lordered_ring)"
+ "a1 <= (a::'a::lattice_ring)"
"a <= a2"
"b1 <= b"
"b <= b2"
@@ -120,7 +120,7 @@
lemma mult_le_dual_prts:
assumes
- "A * x \<le> (b::'a::lordered_ring)"
+ "A * x \<le> (b::'a::lattice_ring)"
"0 \<le> y"
"A1 \<le> A"
"A \<le> A2"
--- a/src/HOL/Matrix/Matrix.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/Matrix.thy Fri Feb 19 15:21:57 2010 +0000
@@ -3,7 +3,7 @@
*)
theory Matrix
-imports Main
+imports Main Lattice_Algebras
begin
types 'a infmatrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"
@@ -1545,7 +1545,7 @@
by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
qed
-instance matrix :: (pordered_ab_group_add) pordered_ab_group_add
+instance matrix :: (ordered_ab_group_add) ordered_ab_group_add
proof
fix A B C :: "'a matrix"
assume "A <= B"
@@ -1556,8 +1556,8 @@
done
qed
-instance matrix :: (lordered_ab_group_add) lordered_ab_group_add_meet ..
-instance matrix :: (lordered_ab_group_add) lordered_ab_group_add_join ..
+instance matrix :: (lattice_ab_group_add) semilattice_inf_ab_group_add ..
+instance matrix :: (lattice_ab_group_add) semilattice_sup_ab_group_add ..
instance matrix :: (semiring_0) semiring_0
proof
@@ -1583,7 +1583,7 @@
instance matrix :: (ring) ring ..
-instance matrix :: (pordered_ring) pordered_ring
+instance matrix :: (ordered_ring) ordered_ring
proof
fix A B C :: "'a matrix"
assume a: "A \<le> B"
@@ -1600,9 +1600,9 @@
done
qed
-instance matrix :: (lordered_ring) lordered_ring
+instance matrix :: (lattice_ring) lattice_ring
proof
- fix A B C :: "('a :: lordered_ring) matrix"
+ fix A B C :: "('a :: lattice_ring) matrix"
show "abs A = sup A (-A)"
by (simp add: abs_matrix_def)
qed
@@ -1738,7 +1738,7 @@
by auto
lemma Rep_matrix_zero_imp_mult_zero:
- "! j i k. (Rep_matrix A j k = 0) | (Rep_matrix B k i) = 0 \<Longrightarrow> A * B = (0::('a::lordered_ring) matrix)"
+ "! j i k. (Rep_matrix A j k = 0) | (Rep_matrix B k i) = 0 \<Longrightarrow> A * B = (0::('a::lattice_ring) matrix)"
apply (subst Rep_matrix_inject[symmetric])
apply (rule ext)+
apply (auto simp add: Rep_matrix_mult foldseq_zero zero_imp_mult_zero)
@@ -1803,7 +1803,7 @@
lemma Rep_minus[simp]: "Rep_matrix (-(A::_::group_add)) x y = - (Rep_matrix A x y)"
by (simp add: minus_matrix_def)
-lemma Rep_abs[simp]: "Rep_matrix (abs (A::_::lordered_ab_group_add)) x y = abs (Rep_matrix A x y)"
+lemma Rep_abs[simp]: "Rep_matrix (abs (A::_::lattice_ab_group_add)) x y = abs (Rep_matrix A x y)"
by (simp add: abs_lattice sup_matrix_def)
end
--- a/src/HOL/Matrix/SparseMatrix.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/SparseMatrix.thy Fri Feb 19 15:21:57 2010 +0000
@@ -103,7 +103,7 @@
"minus_spvec [] = []"
| "minus_spvec (a#as) = (fst a, -(snd a))#(minus_spvec as)"
-primrec abs_spvec :: "('a::lordered_ab_group_add_abs) spvec \<Rightarrow> 'a spvec" where
+primrec abs_spvec :: "('a::lattice_ab_group_add_abs) spvec \<Rightarrow> 'a spvec" where
"abs_spvec [] = []"
| "abs_spvec (a#as) = (fst a, abs (snd a))#(abs_spvec as)"
@@ -116,12 +116,12 @@
apply simp
done
-instance matrix :: (lordered_ab_group_add_abs) lordered_ab_group_add_abs
+instance matrix :: (lattice_ab_group_add_abs) lattice_ab_group_add_abs
apply default
unfolding abs_matrix_def .. (*FIXME move*)
lemma sparse_row_vector_abs:
- "sorted_spvec (v :: 'a::lordered_ring spvec) \<Longrightarrow> sparse_row_vector (abs_spvec v) = abs (sparse_row_vector v)"
+ "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (abs_spvec v) = abs (sparse_row_vector v)"
apply (induct v)
apply simp_all
apply (frule_tac sorted_spvec_cons1, simp)
@@ -174,7 +174,7 @@
lemma addmult_spvec_empty2[simp]: "addmult_spvec y a [] = a"
by (induct a) auto
-lemma sparse_row_vector_map: "(! x y. f (x+y) = (f x) + (f y)) \<Longrightarrow> (f::'a\<Rightarrow>('a::lordered_ring)) 0 = 0 \<Longrightarrow>
+lemma sparse_row_vector_map: "(! x y. f (x+y) = (f x) + (f y)) \<Longrightarrow> (f::'a\<Rightarrow>('a::lattice_ring)) 0 = 0 \<Longrightarrow>
sparse_row_vector (map (% x. (fst x, f (snd x))) a) = apply_matrix f (sparse_row_vector a)"
apply (induct a)
apply (simp_all add: apply_matrix_add)
@@ -185,7 +185,7 @@
apply (simp_all add: smult_spvec_cons scalar_mult_add)
done
-lemma sparse_row_vector_addmult_spvec: "sparse_row_vector (addmult_spvec (y::'a::lordered_ring) a b) =
+lemma sparse_row_vector_addmult_spvec: "sparse_row_vector (addmult_spvec (y::'a::lattice_ring) a b) =
(sparse_row_vector a) + (scalar_mult y (sparse_row_vector b))"
apply (induct y a b rule: addmult_spvec.induct)
apply (simp add: scalar_mult_add smult_spvec_cons sparse_row_vector_smult singleton_matrix_add)+
@@ -235,7 +235,7 @@
apply (simp_all add: sorted_spvec_addmult_spvec_helper3)
done
-fun mult_spvec_spmat :: "('a::lordered_ring) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spmat \<Rightarrow> 'a spvec" where
+fun mult_spvec_spmat :: "('a::lattice_ring) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spmat \<Rightarrow> 'a spvec" where
(* recdef mult_spvec_spmat "measure (% (c, arr, brr). (length arr) + (length brr))" *)
"mult_spvec_spmat c [] brr = c" |
"mult_spvec_spmat c arr [] = c" |
@@ -244,7 +244,7 @@
else if (j < i) then mult_spvec_spmat c ((i,a)#arr) brr
else mult_spvec_spmat (addmult_spvec a c b) arr brr)"
-lemma sparse_row_mult_spvec_spmat[rule_format]: "sorted_spvec (a::('a::lordered_ring) spvec) \<longrightarrow> sorted_spvec B \<longrightarrow>
+lemma sparse_row_mult_spvec_spmat[rule_format]: "sorted_spvec (a::('a::lattice_ring) spvec) \<longrightarrow> sorted_spvec B \<longrightarrow>
sparse_row_vector (mult_spvec_spmat c a B) = (sparse_row_vector c) + (sparse_row_vector a) * (sparse_row_matrix B)"
proof -
have comp_1: "!! a b. a < b \<Longrightarrow> Suc 0 <= nat ((int b)-(int a))" by arith
@@ -337,13 +337,13 @@
qed
lemma sorted_mult_spvec_spmat[rule_format]:
- "sorted_spvec (c::('a::lordered_ring) spvec) \<longrightarrow> sorted_spmat B \<longrightarrow> sorted_spvec (mult_spvec_spmat c a B)"
+ "sorted_spvec (c::('a::lattice_ring) spvec) \<longrightarrow> sorted_spmat B \<longrightarrow> sorted_spvec (mult_spvec_spmat c a B)"
apply (induct c a B rule: mult_spvec_spmat.induct)
apply (simp_all add: sorted_addmult_spvec)
done
consts
- mult_spmat :: "('a::lordered_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
+ mult_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
primrec
"mult_spmat [] A = []"
@@ -357,7 +357,7 @@
done
lemma sorted_spvec_mult_spmat[rule_format]:
- "sorted_spvec (A::('a::lordered_ring) spmat) \<longrightarrow> sorted_spvec (mult_spmat A B)"
+ "sorted_spvec (A::('a::lattice_ring) spmat) \<longrightarrow> sorted_spvec (mult_spmat A B)"
apply (induct A)
apply (auto)
apply (drule sorted_spvec_cons1, simp)
@@ -366,13 +366,13 @@
done
lemma sorted_spmat_mult_spmat:
- "sorted_spmat (B::('a::lordered_ring) spmat) \<Longrightarrow> sorted_spmat (mult_spmat A B)"
+ "sorted_spmat (B::('a::lattice_ring) spmat) \<Longrightarrow> sorted_spmat (mult_spmat A B)"
apply (induct A)
apply (auto simp add: sorted_mult_spvec_spmat)
done
-fun add_spvec :: "('a::lordered_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec" where
+fun add_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> 'a spvec" where
(* "measure (% (a, b). length a + (length b))" *)
"add_spvec arr [] = arr" |
"add_spvec [] brr = brr" |
@@ -389,7 +389,7 @@
apply (simp_all add: singleton_matrix_add)
done
-fun add_spmat :: "('a::lordered_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat" where
+fun add_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat" where
(* "measure (% (A,B). (length A)+(length B))" *)
"add_spmat [] bs = bs" |
"add_spmat as [] = as" |
@@ -532,7 +532,7 @@
apply (simp_all add: sorted_spvec_add_spvec)
done
-fun le_spvec :: "('a::lordered_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> bool" where
+fun le_spvec :: "('a::lattice_ab_group_add) spvec \<Rightarrow> 'a spvec \<Rightarrow> bool" where
(* "measure (% (a,b). (length a) + (length b))" *)
"le_spvec [] [] = True" |
"le_spvec ((_,a)#as) [] = (a <= 0 & le_spvec as [])" |
@@ -542,7 +542,7 @@
else if (j < i) then 0 <= b & le_spvec ((i,a)#as) bs
else a <= b & le_spvec as bs)"
-fun le_spmat :: "('a::lordered_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> bool" where
+fun le_spmat :: "('a::lattice_ab_group_add) spmat \<Rightarrow> 'a spmat \<Rightarrow> bool" where
(* "measure (% (a,b). (length a) + (length b))" *)
"le_spmat [] [] = True" |
"le_spmat ((i,a)#as) [] = (le_spvec a [] & le_spmat as [])" |
@@ -566,7 +566,7 @@
lemma disj_matrices_add: "disj_matrices A B \<Longrightarrow> disj_matrices C D \<Longrightarrow> disj_matrices A D \<Longrightarrow> disj_matrices B C \<Longrightarrow>
- (A + B <= C + D) = (A <= C & B <= (D::('a::lordered_ab_group_add) matrix))"
+ (A + B <= C + D) = (A <= C & B <= (D::('a::lattice_ab_group_add) matrix))"
apply (auto)
apply (simp (no_asm_use) only: le_matrix_def disj_matrices_def)
apply (intro strip)
@@ -596,19 +596,19 @@
by (auto simp add: disj_matrices_def)
lemma disj_matrices_add_le_zero: "disj_matrices A B \<Longrightarrow>
- (A + B <= 0) = (A <= 0 & (B::('a::lordered_ab_group_add) matrix) <= 0)"
+ (A + B <= 0) = (A <= 0 & (B::('a::lattice_ab_group_add) matrix) <= 0)"
by (rule disj_matrices_add[of A B 0 0, simplified])
lemma disj_matrices_add_zero_le: "disj_matrices A B \<Longrightarrow>
- (0 <= A + B) = (0 <= A & 0 <= (B::('a::lordered_ab_group_add) matrix))"
+ (0 <= A + B) = (0 <= A & 0 <= (B::('a::lattice_ab_group_add) matrix))"
by (rule disj_matrices_add[of 0 0 A B, simplified])
lemma disj_matrices_add_x_le: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
- (A <= B + C) = (A <= C & 0 <= (B::('a::lordered_ab_group_add) matrix))"
+ (A <= B + C) = (A <= C & 0 <= (B::('a::lattice_ab_group_add) matrix))"
by (auto simp add: disj_matrices_add[of 0 A B C, simplified])
lemma disj_matrices_add_le_x: "disj_matrices A B \<Longrightarrow> disj_matrices B C \<Longrightarrow>
- (B + A <= C) = (A <= C & (B::('a::lordered_ab_group_add) matrix) <= 0)"
+ (B + A <= C) = (A <= C & (B::('a::lattice_ab_group_add) matrix) <= 0)"
by (auto simp add: disj_matrices_add[of B A 0 C,simplified] disj_matrices_commute)
lemma disj_sparse_row_singleton: "i <= j \<Longrightarrow> sorted_spvec((j,y)#v) \<Longrightarrow> disj_matrices (sparse_row_vector v) (singleton_matrix 0 i x)"
@@ -624,7 +624,7 @@
apply (simp_all)
done
-lemma disj_matrices_x_add: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (A::('a::lordered_ab_group_add) matrix) (B+C)"
+lemma disj_matrices_x_add: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (A::('a::lattice_ab_group_add) matrix) (B+C)"
apply (simp add: disj_matrices_def)
apply (auto)
apply (drule_tac j=j and i=i in spec2)+
@@ -633,7 +633,7 @@
apply (simp_all)
done
-lemma disj_matrices_add_x: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (B+C) (A::('a::lordered_ab_group_add) matrix)"
+lemma disj_matrices_add_x: "disj_matrices A B \<Longrightarrow> disj_matrices A C \<Longrightarrow> disj_matrices (B+C) (A::('a::lattice_ab_group_add) matrix)"
by (simp add: disj_matrices_x_add disj_matrices_commute)
lemma disj_singleton_matrices[simp]: "disj_matrices (singleton_matrix j i x) (singleton_matrix u v y) = (j \<noteq> u | i \<noteq> v | x = 0 | y = 0)"
@@ -731,11 +731,11 @@
declare [[simp_depth_limit = 999]]
-primrec abs_spmat :: "('a::lordered_ring) spmat \<Rightarrow> 'a spmat" where
+primrec abs_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat" where
"abs_spmat [] = []" |
"abs_spmat (a#as) = (fst a, abs_spvec (snd a))#(abs_spmat as)"
-primrec minus_spmat :: "('a::lordered_ring) spmat \<Rightarrow> 'a spmat" where
+primrec minus_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat" where
"minus_spmat [] = []" |
"minus_spmat (a#as) = (fst a, minus_spvec (snd a))#(minus_spmat as)"
@@ -803,7 +803,7 @@
done
constdefs
- diff_spmat :: "('a::lordered_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
+ diff_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
"diff_spmat A B == add_spmat A (minus_spmat B)"
lemma sorted_spmat_diff_spmat: "sorted_spmat A \<Longrightarrow> sorted_spmat B \<Longrightarrow> sorted_spmat (diff_spmat A B)"
@@ -845,10 +845,10 @@
lemma if_case_eq: "(if b then x else y) = (case b of True => x | False => y)" by simp
consts
- pprt_spvec :: "('a::{lordered_ab_group_add}) spvec \<Rightarrow> 'a spvec"
- nprt_spvec :: "('a::{lordered_ab_group_add}) spvec \<Rightarrow> 'a spvec"
- pprt_spmat :: "('a::{lordered_ab_group_add}) spmat \<Rightarrow> 'a spmat"
- nprt_spmat :: "('a::{lordered_ab_group_add}) spmat \<Rightarrow> 'a spmat"
+ pprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
+ nprt_spvec :: "('a::{lattice_ab_group_add}) spvec \<Rightarrow> 'a spvec"
+ pprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
+ nprt_spmat :: "('a::{lattice_ab_group_add}) spmat \<Rightarrow> 'a spmat"
primrec
"pprt_spvec [] = []"
@@ -869,7 +869,7 @@
(*case (nprt_spvec (snd a)) of [] \<Rightarrow> (nprt_spmat as) | y#ys \<Rightarrow> (fst a, y#ys)#(nprt_spmat as))"*)
-lemma pprt_add: "disj_matrices A (B::(_::lordered_ring) matrix) \<Longrightarrow> pprt (A+B) = pprt A + pprt B"
+lemma pprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> pprt (A+B) = pprt A + pprt B"
apply (simp add: pprt_def sup_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
apply (rule ext)+
@@ -878,7 +878,7 @@
apply (simp_all add: disj_matrices_contr1)
done
-lemma nprt_add: "disj_matrices A (B::(_::lordered_ring) matrix) \<Longrightarrow> nprt (A+B) = nprt A + nprt B"
+lemma nprt_add: "disj_matrices A (B::(_::lattice_ring) matrix) \<Longrightarrow> nprt (A+B) = nprt A + nprt B"
apply (simp add: nprt_def inf_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
apply (rule ext)+
@@ -887,14 +887,14 @@
apply (simp_all add: disj_matrices_contr1)
done
-lemma pprt_singleton[simp]: "pprt (singleton_matrix j i (x::_::lordered_ring)) = singleton_matrix j i (pprt x)"
+lemma pprt_singleton[simp]: "pprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (pprt x)"
apply (simp add: pprt_def sup_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
apply (rule ext)+
apply simp
done
-lemma nprt_singleton[simp]: "nprt (singleton_matrix j i (x::_::lordered_ring)) = singleton_matrix j i (nprt x)"
+lemma nprt_singleton[simp]: "nprt (singleton_matrix j i (x::_::lattice_ring)) = singleton_matrix j i (nprt x)"
apply (simp add: nprt_def inf_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
apply (rule ext)+
@@ -903,7 +903,7 @@
lemma less_imp_le: "a < b \<Longrightarrow> a <= (b::_::order)" by (simp add: less_def)
-lemma sparse_row_vector_pprt: "sorted_spvec (v :: 'a::lordered_ring spvec) \<Longrightarrow> sparse_row_vector (pprt_spvec v) = pprt (sparse_row_vector v)"
+lemma sparse_row_vector_pprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (pprt_spvec v) = pprt (sparse_row_vector v)"
apply (induct v)
apply (simp_all)
apply (frule sorted_spvec_cons1, auto)
@@ -913,7 +913,7 @@
apply auto
done
-lemma sparse_row_vector_nprt: "sorted_spvec (v :: 'a::lordered_ring spvec) \<Longrightarrow> sparse_row_vector (nprt_spvec v) = nprt (sparse_row_vector v)"
+lemma sparse_row_vector_nprt: "sorted_spvec (v :: 'a::lattice_ring spvec) \<Longrightarrow> sparse_row_vector (nprt_spvec v) = nprt (sparse_row_vector v)"
apply (induct v)
apply (simp_all)
apply (frule sorted_spvec_cons1, auto)
@@ -924,7 +924,7 @@
done
-lemma pprt_move_matrix: "pprt (move_matrix (A::('a::lordered_ring) matrix) j i) = move_matrix (pprt A) j i"
+lemma pprt_move_matrix: "pprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (pprt A) j i"
apply (simp add: pprt_def)
apply (simp add: sup_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
@@ -932,7 +932,7 @@
apply (simp)
done
-lemma nprt_move_matrix: "nprt (move_matrix (A::('a::lordered_ring) matrix) j i) = move_matrix (nprt A) j i"
+lemma nprt_move_matrix: "nprt (move_matrix (A::('a::lattice_ring) matrix) j i) = move_matrix (nprt A) j i"
apply (simp add: nprt_def)
apply (simp add: inf_matrix_def)
apply (simp add: Rep_matrix_inject[symmetric])
@@ -940,7 +940,7 @@
apply (simp)
done
-lemma sparse_row_matrix_pprt: "sorted_spvec (m :: 'a::lordered_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (pprt_spmat m) = pprt (sparse_row_matrix m)"
+lemma sparse_row_matrix_pprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (pprt_spmat m) = pprt (sparse_row_matrix m)"
apply (induct m)
apply simp
apply simp
@@ -956,7 +956,7 @@
apply (simp add: pprt_move_matrix)
done
-lemma sparse_row_matrix_nprt: "sorted_spvec (m :: 'a::lordered_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (nprt_spmat m) = nprt (sparse_row_matrix m)"
+lemma sparse_row_matrix_nprt: "sorted_spvec (m :: 'a::lattice_ring spmat) \<Longrightarrow> sorted_spmat m \<Longrightarrow> sparse_row_matrix (nprt_spmat m) = nprt (sparse_row_matrix m)"
apply (induct m)
apply simp
apply simp
@@ -1015,7 +1015,7 @@
done
constdefs
- mult_est_spmat :: "('a::lordered_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
+ mult_est_spmat :: "('a::lattice_ring) spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat \<Rightarrow> 'a spmat"
"mult_est_spmat r1 r2 s1 s2 ==
add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
(add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))"
@@ -1057,7 +1057,7 @@
"sorted_spvec b"
"sorted_spvec r"
"le_spmat ([], y)"
- "A * x \<le> sparse_row_matrix (b::('a::lordered_ring) spmat)"
+ "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
"sparse_row_matrix A1 <= A"
"A <= sparse_row_matrix A2"
"sparse_row_matrix c1 <= c"
--- a/src/HOL/Matrix/cplex/Cplex.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/cplex/Cplex.thy Fri Feb 19 15:21:57 2010 +0000
@@ -25,7 +25,7 @@
"c \<le> sparse_row_matrix c2"
"sparse_row_matrix r1 \<le> x"
"x \<le> sparse_row_matrix r2"
- "A * x \<le> sparse_row_matrix (b::('a::lordered_ring) spmat)"
+ "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
shows
"c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
(let s1 = diff_spmat c1 (mult_spmat y A2); s2 = diff_spmat c2 (mult_spmat y A1) in
@@ -55,7 +55,7 @@
"c \<le> sparse_row_matrix c2"
"sparse_row_matrix r1 \<le> x"
"x \<le> sparse_row_matrix r2"
- "A * x \<le> sparse_row_matrix (b::('a::lordered_ring) spmat)"
+ "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
shows
"c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
(mult_est_spmat r1 r2 (diff_spmat c1 (mult_spmat y A2)) (diff_spmat c2 (mult_spmat y A1))))"
--- a/src/HOL/Matrix/cplex/Cplex_tools.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/cplex/Cplex_tools.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1145,7 +1145,7 @@
val cplex_path = getenv "GLPK_PATH"
val cplex = if cplex_path = "" then "glpsol" else cplex_path
val command = (wrap cplex)^" --lpt "^(wrap lpname)^" --output "^(wrap resultname)
- val answer = #1 (system_out command)
+ val answer = #1 (bash_output command)
in
let
val result = load_glpkResult resultname
@@ -1178,7 +1178,7 @@
val cplex = if cplex_path = "" then "cplex" else cplex_path
val _ = write_script scriptname lpname resultname
val command = (wrap cplex)^" < "^(wrap scriptname)^" > /dev/null"
- val answer = "return code "^(Int.toString (system command))
+ val answer = "return code "^(Int.toString (bash command))
in
let
val result = load_cplexResult resultname
--- a/src/HOL/Matrix/cplex/matrixlp.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Matrix/cplex/matrixlp.ML Fri Feb 19 15:21:57 2010 +0000
@@ -18,7 +18,7 @@
fun inst_real thm =
let val certT = ctyp_of (Thm.theory_of_thm thm) in
- Drule.standard (Thm.instantiate
+ Drule.export_without_context (Thm.instantiate
([(certT (TVar (hd (OldTerm.term_tvars (prop_of thm)))), certT HOLogic.realT)], []) thm)
end
@@ -59,7 +59,7 @@
val ord = prod_ord (prod_ord string_ord int_ord) (list_ord string_ord)
val v = TVar (hd (sort ord (OldTerm.term_tvars (prop_of thm))))
in
- Drule.standard (Thm.instantiate ([(certT v, certT ty)], []) thm)
+ Drule.export_without_context (Thm.instantiate ([(certT v, certT ty)], []) thm)
end
fun inst_tvars [] thms = thms
--- a/src/HOL/Metis_Examples/BigO.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Metis_Examples/BigO.thy Fri Feb 19 15:21:57 2010 +0000
@@ -12,11 +12,11 @@
subsection {* Definitions *}
-definition bigo :: "('a => 'b::ordered_idom) => ('a => 'b) set" ("(1O'(_'))") where
+definition bigo :: "('a => 'b::linordered_idom) => ('a => 'b) set" ("(1O'(_'))") where
"O(f::('a => 'b)) == {h. EX c. ALL x. abs (h x) <= c * abs (f x)}"
declare [[ atp_problem_prefix = "BigO__bigo_pos_const" ]]
-lemma bigo_pos_const: "(EX (c::'a::ordered_idom).
+lemma bigo_pos_const: "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -30,7 +30,7 @@
declare [[sledgehammer_modulus = 1]]
-lemma (*bigo_pos_const:*) "(EX (c::'a::ordered_idom).
+lemma (*bigo_pos_const:*) "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -39,59 +39,59 @@
apply (rule_tac x = "abs c" in exI, auto)
proof (neg_clausify)
fix c x
-have 0: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<bar>X1 * X2\<bar> = \<bar>X2 * X1\<bar>"
+have 0: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<bar>X1 * X2\<bar> = \<bar>X2 * X1\<bar>"
by (metis abs_mult mult_commute)
-have 1: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- X1 \<le> (0\<Colon>'a\<Colon>ordered_idom) \<or> \<bar>X2\<bar> * X1 = \<bar>X2 * X1\<bar>"
+have 1: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ X1 \<le> (0\<Colon>'a\<Colon>linordered_idom) \<or> \<bar>X2\<bar> * X1 = \<bar>X2 * X1\<bar>"
by (metis abs_mult_pos linorder_linear)
-have 2: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- \<not> (0\<Colon>'a\<Colon>ordered_idom) < X1 * X2 \<or>
- \<not> (0\<Colon>'a\<Colon>ordered_idom) \<le> X2 \<or> \<not> X1 \<le> (0\<Colon>'a\<Colon>ordered_idom)"
+have 2: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ \<not> (0\<Colon>'a\<Colon>linordered_idom) < X1 * X2 \<or>
+ \<not> (0\<Colon>'a\<Colon>linordered_idom) \<le> X2 \<or> \<not> X1 \<le> (0\<Colon>'a\<Colon>linordered_idom)"
by (metis linorder_not_less mult_nonneg_nonpos2)
assume 3: "\<And>x\<Colon>'b\<Colon>type.
- \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-assume 4: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
- \<le> \<bar>c\<Colon>'a\<Colon>ordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-have 5: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
+ \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+assume 4: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
+ \<le> \<bar>c\<Colon>'a\<Colon>linordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+have 5: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
by (metis 4 abs_mult)
-have 6: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- \<not> X1 \<le> (0\<Colon>'a\<Colon>ordered_idom) \<or> X1 \<le> \<bar>X2\<bar>"
+have 6: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ \<not> X1 \<le> (0\<Colon>'a\<Colon>linordered_idom) \<or> X1 \<le> \<bar>X2\<bar>"
by (metis abs_ge_zero xt1(6))
-have 7: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- X1 \<le> \<bar>X2\<bar> \<or> (0\<Colon>'a\<Colon>ordered_idom) < X1"
+have 7: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ X1 \<le> \<bar>X2\<bar> \<or> (0\<Colon>'a\<Colon>linordered_idom) < X1"
by (metis not_leE 6)
-have 8: "(0\<Colon>'a\<Colon>ordered_idom) < \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
+have 8: "(0\<Colon>'a\<Colon>linordered_idom) < \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
by (metis 5 7)
-have 9: "\<And>X1\<Colon>'a\<Colon>ordered_idom.
- \<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar> \<le> X1 \<or>
- (0\<Colon>'a\<Colon>ordered_idom) < X1"
+have 9: "\<And>X1\<Colon>'a\<Colon>linordered_idom.
+ \<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar> \<le> X1 \<or>
+ (0\<Colon>'a\<Colon>linordered_idom) < X1"
by (metis 8 order_less_le_trans)
-have 10: "(0\<Colon>'a\<Colon>ordered_idom)
-< (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
+have 10: "(0\<Colon>'a\<Colon>linordered_idom)
+< (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
by (metis 3 9)
-have 11: "\<not> (c\<Colon>'a\<Colon>ordered_idom) \<le> (0\<Colon>'a\<Colon>ordered_idom)"
+have 11: "\<not> (c\<Colon>'a\<Colon>linordered_idom) \<le> (0\<Colon>'a\<Colon>linordered_idom)"
by (metis abs_ge_zero 2 10)
-have 12: "\<And>X1\<Colon>'a\<Colon>ordered_idom. (c\<Colon>'a\<Colon>ordered_idom) * \<bar>X1\<bar> = \<bar>X1 * c\<bar>"
+have 12: "\<And>X1\<Colon>'a\<Colon>linordered_idom. (c\<Colon>'a\<Colon>linordered_idom) * \<bar>X1\<bar> = \<bar>X1 * c\<bar>"
by (metis mult_commute 1 11)
have 13: "\<And>X1\<Colon>'b\<Colon>type.
- - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1
- \<le> (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1\<bar>"
+ - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1
+ \<le> (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1\<bar>"
by (metis 3 abs_le_D2)
have 14: "\<And>X1\<Colon>'b\<Colon>type.
- - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1\<bar>"
+ - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1\<bar>"
by (metis 0 12 13)
-have 15: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
+have 15: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
by (metis abs_mult abs_mult_pos abs_ge_zero)
-have 16: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. X1 \<le> \<bar>X2\<bar> \<or> \<not> X1 \<le> X2"
+have 16: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. X1 \<le> \<bar>X2\<bar> \<or> \<not> X1 \<le> X2"
by (metis xt1(6) abs_ge_self)
-have 17: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<not> \<bar>X1\<bar> \<le> X2 \<or> X1 \<le> \<bar>X2\<bar>"
+have 17: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<not> \<bar>X1\<bar> \<le> X2 \<or> X1 \<le> \<bar>X2\<bar>"
by (metis 16 abs_le_D1)
have 18: "\<And>X1\<Colon>'b\<Colon>type.
- (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1\<bar>"
+ (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1\<bar>"
by (metis 17 3 15)
show "False"
by (metis abs_le_iff 5 18 14)
@@ -99,7 +99,7 @@
declare [[sledgehammer_modulus = 2]]
-lemma (*bigo_pos_const:*) "(EX (c::'a::ordered_idom).
+lemma (*bigo_pos_const:*) "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -108,31 +108,31 @@
apply (rule_tac x = "abs c" in exI, auto);
proof (neg_clausify)
fix c x
-have 0: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<bar>X1 * X2\<bar> = \<bar>X2 * X1\<bar>"
+have 0: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<bar>X1 * X2\<bar> = \<bar>X2 * X1\<bar>"
by (metis abs_mult mult_commute)
assume 1: "\<And>x\<Colon>'b\<Colon>type.
- \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-assume 2: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
- \<le> \<bar>c\<Colon>'a\<Colon>ordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-have 3: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
+ \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+assume 2: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
+ \<le> \<bar>c\<Colon>'a\<Colon>linordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+have 3: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
by (metis 2 abs_mult)
-have 4: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- \<not> X1 \<le> (0\<Colon>'a\<Colon>ordered_idom) \<or> X1 \<le> \<bar>X2\<bar>"
+have 4: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ \<not> X1 \<le> (0\<Colon>'a\<Colon>linordered_idom) \<or> X1 \<le> \<bar>X2\<bar>"
by (metis abs_ge_zero xt1(6))
-have 5: "(0\<Colon>'a\<Colon>ordered_idom) < \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
+have 5: "(0\<Colon>'a\<Colon>linordered_idom) < \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
by (metis not_leE 4 3)
-have 6: "(0\<Colon>'a\<Colon>ordered_idom)
-< (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
+have 6: "(0\<Colon>'a\<Colon>linordered_idom)
+< (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>"
by (metis 1 order_less_le_trans 5)
-have 7: "\<And>X1\<Colon>'a\<Colon>ordered_idom. (c\<Colon>'a\<Colon>ordered_idom) * \<bar>X1\<bar> = \<bar>X1 * c\<bar>"
+have 7: "\<And>X1\<Colon>'a\<Colon>linordered_idom. (c\<Colon>'a\<Colon>linordered_idom) * \<bar>X1\<bar> = \<bar>X1 * c\<bar>"
by (metis abs_ge_zero linorder_not_less mult_nonneg_nonpos2 6 linorder_linear abs_mult_pos mult_commute)
have 8: "\<And>X1\<Colon>'b\<Colon>type.
- - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1\<bar>"
+ - (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1\<bar>"
by (metis 0 7 abs_le_D2 1)
-have 9: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<not> \<bar>X1\<bar> \<le> X2 \<or> X1 \<le> \<bar>X2\<bar>"
+have 9: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<not> \<bar>X1\<bar> \<le> X2 \<or> X1 \<le> \<bar>X2\<bar>"
by (metis abs_ge_self xt1(6) abs_le_D1)
show "False"
by (metis 8 abs_ge_zero abs_mult_pos abs_mult 1 9 3 abs_le_iff)
@@ -140,7 +140,7 @@
declare [[sledgehammer_modulus = 3]]
-lemma (*bigo_pos_const:*) "(EX (c::'a::ordered_idom).
+lemma (*bigo_pos_const:*) "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -150,20 +150,20 @@
proof (neg_clausify)
fix c x
assume 0: "\<And>x\<Colon>'b\<Colon>type.
- \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'a\<Colon>ordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-assume 1: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
- \<le> \<bar>c\<Colon>'a\<Colon>ordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) x\<bar>"
-have 2: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom.
- X1 \<le> \<bar>X2\<bar> \<or> (0\<Colon>'a\<Colon>ordered_idom) < X1"
+ \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'a\<Colon>linordered_idom) * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+assume 1: "\<not> \<bar>(h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) (x\<Colon>'b\<Colon>type)\<bar>
+ \<le> \<bar>c\<Colon>'a\<Colon>linordered_idom\<bar> * \<bar>(f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) x\<bar>"
+have 2: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom.
+ X1 \<le> \<bar>X2\<bar> \<or> (0\<Colon>'a\<Colon>linordered_idom) < X1"
by (metis abs_ge_zero xt1(6) not_leE)
-have 3: "\<not> (c\<Colon>'a\<Colon>ordered_idom) \<le> (0\<Colon>'a\<Colon>ordered_idom)"
+have 3: "\<not> (c\<Colon>'a\<Colon>linordered_idom) \<le> (0\<Colon>'a\<Colon>linordered_idom)"
by (metis abs_ge_zero mult_nonneg_nonpos2 linorder_not_less order_less_le_trans 1 abs_mult 2 0)
-have 4: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2\<Colon>'a\<Colon>ordered_idom. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
+have 4: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2\<Colon>'a\<Colon>linordered_idom. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
by (metis abs_ge_zero abs_mult_pos abs_mult)
have 5: "\<And>X1\<Colon>'b\<Colon>type.
- (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1
- \<le> \<bar>(c\<Colon>'a\<Colon>ordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>ordered_idom) X1\<bar>"
+ (h\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1
+ \<le> \<bar>(c\<Colon>'a\<Colon>linordered_idom) * (f\<Colon>'b\<Colon>type \<Rightarrow> 'a\<Colon>linordered_idom) X1\<bar>"
by (metis 4 0 xt1(6) abs_ge_self abs_le_D1)
show "False"
by (metis abs_mult mult_commute 3 abs_mult_pos linorder_linear 0 abs_le_D2 5 1 abs_le_iff)
@@ -172,7 +172,7 @@
declare [[sledgehammer_modulus = 1]]
-lemma (*bigo_pos_const:*) "(EX (c::'a::ordered_idom).
+lemma (*bigo_pos_const:*) "(EX (c::'a::linordered_idom).
ALL x. (abs (h x)) <= (c * (abs (f x))))
= (EX c. 0 < c & (ALL x. (abs(h x)) <= (c * (abs (f x)))))"
apply auto
@@ -181,7 +181,7 @@
apply (rule_tac x = "abs c" in exI, auto);
proof (neg_clausify)
fix c x (*sort/type constraint inserted by hand!*)
-have 0: "\<And>(X1\<Colon>'a\<Colon>ordered_idom) X2. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
+have 0: "\<And>(X1\<Colon>'a\<Colon>linordered_idom) X2. \<bar>X1 * \<bar>X2\<bar>\<bar> = \<bar>X1 * X2\<bar>"
by (metis abs_ge_zero abs_mult_pos abs_mult)
assume 1: "\<And>A. \<bar>h A\<bar> \<le> c * \<bar>f A\<bar>"
have 2: "\<And>X1 X2. \<not> \<bar>X1\<bar> \<le> X2 \<or> (0\<Colon>'a) \<le> X2"
@@ -368,7 +368,7 @@
f : O(g)"
apply (auto simp add: bigo_def)
(*Version 1: one-shot proof*)
- apply (metis OrderedGroup.abs_le_D1 linorder_class.not_less order_less_le Orderings.xt1(12) Ring_and_Field.abs_mult)
+ apply (metis abs_le_D1 linorder_class.not_less order_less_le Orderings.xt1(12) abs_mult)
done
lemma (*bigo_bounded_alt:*) "ALL x. 0 <= f x ==> ALL x. f x <= c * g x ==>
@@ -383,11 +383,11 @@
by (metis 0 order_antisym_conv)
have 3: "\<And>X3. \<not> f (x \<bar>X3\<bar>) \<le> \<bar>X3 * g (x \<bar>X3\<bar>)\<bar>"
by (metis 1 abs_mult)
-have 4: "\<And>X1 X3\<Colon>'b\<Colon>ordered_idom. X3 \<le> X1 \<or> X1 \<le> \<bar>X3\<bar>"
+have 4: "\<And>X1 X3\<Colon>'b\<Colon>linordered_idom. X3 \<le> X1 \<or> X1 \<le> \<bar>X3\<bar>"
by (metis linorder_linear abs_le_D1)
have 5: "\<And>X3::'b. \<bar>X3\<bar> * \<bar>X3\<bar> = X3 * X3"
by (metis abs_mult_self)
-have 6: "\<And>X3. \<not> X3 * X3 < (0\<Colon>'b\<Colon>ordered_idom)"
+have 6: "\<And>X3. \<not> X3 * X3 < (0\<Colon>'b\<Colon>linordered_idom)"
by (metis not_square_less_zero)
have 7: "\<And>X1 X3::'b. \<bar>X1\<bar> * \<bar>X3\<bar> = \<bar>X3 * X1\<bar>"
by (metis abs_mult mult_commute)
@@ -438,26 +438,26 @@
proof (neg_clausify)
fix x
assume 0: "\<And>A\<Colon>'a\<Colon>type.
- (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) A
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) A"
-assume 1: "\<And>A\<Colon>'b\<Colon>ordered_idom.
- \<not> (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) ((x\<Colon>'b\<Colon>ordered_idom \<Rightarrow> 'a\<Colon>type) A)
- \<le> A * \<bar>(g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) (x A)\<bar>"
+ (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) A
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) A"
+assume 1: "\<And>A\<Colon>'b\<Colon>linordered_idom.
+ \<not> (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) ((x\<Colon>'b\<Colon>linordered_idom \<Rightarrow> 'a\<Colon>type) A)
+ \<le> A * \<bar>(g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) (x A)\<bar>"
have 2: "\<And>X2\<Colon>'a\<Colon>type.
- \<not> (c\<Colon>'b\<Colon>ordered_idom) * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) X2
- < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) X2"
+ \<not> (c\<Colon>'b\<Colon>linordered_idom) * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) X2
+ < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) X2"
by (metis 0 linorder_not_le)
-have 3: "\<And>X2\<Colon>'b\<Colon>ordered_idom.
- \<not> (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) ((x\<Colon>'b\<Colon>ordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)
- \<le> \<bar>X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) (x \<bar>X2\<bar>)\<bar>"
+have 3: "\<And>X2\<Colon>'b\<Colon>linordered_idom.
+ \<not> (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) ((x\<Colon>'b\<Colon>linordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)
+ \<le> \<bar>X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) (x \<bar>X2\<bar>)\<bar>"
by (metis abs_mult 1)
-have 4: "\<And>X2\<Colon>'b\<Colon>ordered_idom.
- \<bar>X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) ((x\<Colon>'b\<Colon>ordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)\<bar>
- < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) (x \<bar>X2\<bar>)"
+have 4: "\<And>X2\<Colon>'b\<Colon>linordered_idom.
+ \<bar>X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) ((x\<Colon>'b\<Colon>linordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)\<bar>
+ < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) (x \<bar>X2\<bar>)"
by (metis 3 linorder_not_less)
-have 5: "\<And>X2\<Colon>'b\<Colon>ordered_idom.
- X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) ((x\<Colon>'b\<Colon>ordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)
- < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) (x \<bar>X2\<bar>)"
+have 5: "\<And>X2\<Colon>'b\<Colon>linordered_idom.
+ X2 * (g\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) ((x\<Colon>'b\<Colon>linordered_idom \<Rightarrow> 'a\<Colon>type) \<bar>X2\<bar>)
+ < (f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) (x \<bar>X2\<bar>)"
by (metis abs_less_iff 4)
show "False"
by (metis 2 5)
@@ -595,62 +595,62 @@
using [[ atp_problem_prefix = "BigO__bigo_mult_simpler" ]]
prefer 2
apply (metis mult_assoc mult_left_commute
- OrderedGroup.abs_of_pos OrderedGroup.mult_left_commute
- Ring_and_Field.abs_mult Ring_and_Field.mult_pos_pos)
+ abs_of_pos mult_left_commute
+ abs_mult mult_pos_pos)
apply (erule ssubst)
apply (subst abs_mult)
(*not qute BigO__bigo_mult_simpler_1 (a hard problem!) as abs_mult has
just been done*)
proof (neg_clausify)
fix a c b ca x
-assume 0: "(0\<Colon>'b\<Colon>ordered_idom) < (c\<Colon>'b\<Colon>ordered_idom)"
-assume 1: "\<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar>
-\<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>"
-assume 2: "\<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar>
-\<le> (ca\<Colon>'b\<Colon>ordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>"
-assume 3: "\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar> *
- \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> *
- ((ca\<Colon>'b\<Colon>ordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>)"
-have 4: "\<bar>c\<Colon>'b\<Colon>ordered_idom\<bar> = c"
- by (metis OrderedGroup.abs_of_pos 0)
-have 5: "\<And>X1\<Colon>'b\<Colon>ordered_idom. (c\<Colon>'b\<Colon>ordered_idom) * \<bar>X1\<bar> = \<bar>c * X1\<bar>"
- by (metis Ring_and_Field.abs_mult 4)
-have 6: "(0\<Colon>'b\<Colon>ordered_idom) = (1\<Colon>'b\<Colon>ordered_idom) \<or>
-(0\<Colon>'b\<Colon>ordered_idom) < (1\<Colon>'b\<Colon>ordered_idom)"
- by (metis OrderedGroup.abs_not_less_zero Ring_and_Field.abs_one Ring_and_Field.linorder_neqE_ordered_idom)
-have 7: "(0\<Colon>'b\<Colon>ordered_idom) < (1\<Colon>'b\<Colon>ordered_idom)"
- by (metis 6 Ring_and_Field.one_neq_zero)
-have 8: "\<bar>1\<Colon>'b\<Colon>ordered_idom\<bar> = (1\<Colon>'b\<Colon>ordered_idom)"
- by (metis OrderedGroup.abs_of_pos 7)
-have 9: "\<And>X1\<Colon>'b\<Colon>ordered_idom. (0\<Colon>'b\<Colon>ordered_idom) \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>X1\<bar>"
- by (metis OrderedGroup.abs_ge_zero 5)
-have 10: "\<And>X1\<Colon>'b\<Colon>ordered_idom. X1 * (1\<Colon>'b\<Colon>ordered_idom) = X1"
- by (metis Ring_and_Field.mult_cancel_right2 mult_commute)
-have 11: "\<And>X1\<Colon>'b\<Colon>ordered_idom. \<bar>\<bar>X1\<bar>\<bar> = \<bar>X1\<bar> * \<bar>1\<Colon>'b\<Colon>ordered_idom\<bar>"
- by (metis Ring_and_Field.abs_mult OrderedGroup.abs_idempotent 10)
-have 12: "\<And>X1\<Colon>'b\<Colon>ordered_idom. \<bar>\<bar>X1\<bar>\<bar> = \<bar>X1\<bar>"
+assume 0: "(0\<Colon>'b\<Colon>linordered_idom) < (c\<Colon>'b\<Colon>linordered_idom)"
+assume 1: "\<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar>
+\<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>"
+assume 2: "\<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar>
+\<le> (ca\<Colon>'b\<Colon>linordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>"
+assume 3: "\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar> *
+ \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> *
+ ((ca\<Colon>'b\<Colon>linordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>)"
+have 4: "\<bar>c\<Colon>'b\<Colon>linordered_idom\<bar> = c"
+ by (metis abs_of_pos 0)
+have 5: "\<And>X1\<Colon>'b\<Colon>linordered_idom. (c\<Colon>'b\<Colon>linordered_idom) * \<bar>X1\<bar> = \<bar>c * X1\<bar>"
+ by (metis abs_mult 4)
+have 6: "(0\<Colon>'b\<Colon>linordered_idom) = (1\<Colon>'b\<Colon>linordered_idom) \<or>
+(0\<Colon>'b\<Colon>linordered_idom) < (1\<Colon>'b\<Colon>linordered_idom)"
+ by (metis abs_not_less_zero abs_one linorder_neqE_linordered_idom)
+have 7: "(0\<Colon>'b\<Colon>linordered_idom) < (1\<Colon>'b\<Colon>linordered_idom)"
+ by (metis 6 one_neq_zero)
+have 8: "\<bar>1\<Colon>'b\<Colon>linordered_idom\<bar> = (1\<Colon>'b\<Colon>linordered_idom)"
+ by (metis abs_of_pos 7)
+have 9: "\<And>X1\<Colon>'b\<Colon>linordered_idom. (0\<Colon>'b\<Colon>linordered_idom) \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>X1\<bar>"
+ by (metis abs_ge_zero 5)
+have 10: "\<And>X1\<Colon>'b\<Colon>linordered_idom. X1 * (1\<Colon>'b\<Colon>linordered_idom) = X1"
+ by (metis mult_cancel_right2 mult_commute)
+have 11: "\<And>X1\<Colon>'b\<Colon>linordered_idom. \<bar>\<bar>X1\<bar>\<bar> = \<bar>X1\<bar> * \<bar>1\<Colon>'b\<Colon>linordered_idom\<bar>"
+ by (metis abs_mult abs_idempotent 10)
+have 12: "\<And>X1\<Colon>'b\<Colon>linordered_idom. \<bar>\<bar>X1\<bar>\<bar> = \<bar>X1\<bar>"
by (metis 11 8 10)
-have 13: "\<And>X1\<Colon>'b\<Colon>ordered_idom. (0\<Colon>'b\<Colon>ordered_idom) \<le> \<bar>X1\<bar>"
- by (metis OrderedGroup.abs_ge_zero 12)
-have 14: "\<not> (0\<Colon>'b\<Colon>ordered_idom)
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar> \<or>
-\<not> (0\<Colon>'b\<Colon>ordered_idom) \<le> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> \<or>
-\<not> \<bar>b x\<bar> \<le> (ca\<Colon>'b\<Colon>ordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> \<or>
-\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> \<le> c * \<bar>f x\<bar>"
- by (metis 3 Ring_and_Field.mult_mono)
-have 15: "\<not> (0\<Colon>'b\<Colon>ordered_idom) \<le> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar> \<or>
-\<not> \<bar>b x\<bar> \<le> (ca\<Colon>'b\<Colon>ordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> \<or>
-\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>"
+have 13: "\<And>X1\<Colon>'b\<Colon>linordered_idom. (0\<Colon>'b\<Colon>linordered_idom) \<le> \<bar>X1\<bar>"
+ by (metis abs_ge_zero 12)
+have 14: "\<not> (0\<Colon>'b\<Colon>linordered_idom)
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar> \<or>
+\<not> (0\<Colon>'b\<Colon>linordered_idom) \<le> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> \<or>
+\<not> \<bar>b x\<bar> \<le> (ca\<Colon>'b\<Colon>linordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> \<or>
+\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> \<le> c * \<bar>f x\<bar>"
+ by (metis 3 mult_mono)
+have 15: "\<not> (0\<Colon>'b\<Colon>linordered_idom) \<le> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar> \<or>
+\<not> \<bar>b x\<bar> \<le> (ca\<Colon>'b\<Colon>linordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> \<or>
+\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>"
by (metis 14 9)
-have 16: "\<not> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar>
- \<le> (ca\<Colon>'b\<Colon>ordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar> \<or>
-\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>"
+have 16: "\<not> \<bar>(b\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar>
+ \<le> (ca\<Colon>'b\<Colon>linordered_idom) * \<bar>(g\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar> \<or>
+\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>"
by (metis 15 13)
-have 17: "\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) (x\<Colon>'a)\<bar>
- \<le> (c\<Colon>'b\<Colon>ordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>ordered_idom) x\<bar>"
+have 17: "\<not> \<bar>(a\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) (x\<Colon>'a)\<bar>
+ \<le> (c\<Colon>'b\<Colon>linordered_idom) * \<bar>(f\<Colon>'a \<Rightarrow> 'b\<Colon>linordered_idom) x\<bar>"
by (metis 16 2)
show 18: "False"
by (metis 17 1)
@@ -682,7 +682,7 @@
lemma bigo_mult5: "ALL x. f x ~= 0 ==>
- O(f * g) <= (f::'a => ('b::ordered_field)) *o O(g)"
+ O(f * g) <= (f::'a => ('b::linordered_field)) *o O(g)"
proof -
assume "ALL x. f x ~= 0"
show "O(f * g) <= f *o O(g)"
@@ -712,14 +712,14 @@
declare [[ atp_problem_prefix = "BigO__bigo_mult6" ]]
lemma bigo_mult6: "ALL x. f x ~= 0 ==>
- O(f * g) = (f::'a => ('b::ordered_field)) *o O(g)"
+ O(f * g) = (f::'a => ('b::linordered_field)) *o O(g)"
by (metis bigo_mult2 bigo_mult5 order_antisym)
(*proof requires relaxing relevance: 2007-01-25*)
declare [[ atp_problem_prefix = "BigO__bigo_mult7" ]]
declare bigo_mult6 [simp]
lemma bigo_mult7: "ALL x. f x ~= 0 ==>
- O(f * g) <= O(f::'a => ('b::ordered_field)) \<otimes> O(g)"
+ O(f * g) <= O(f::'a => ('b::linordered_field)) \<otimes> O(g)"
(*sledgehammer*)
apply (subst bigo_mult6)
apply assumption
@@ -731,7 +731,7 @@
declare [[ atp_problem_prefix = "BigO__bigo_mult8" ]]
declare bigo_mult7[intro!]
lemma bigo_mult8: "ALL x. f x ~= 0 ==>
- O(f * g) = O(f::'a => ('b::ordered_field)) \<otimes> O(g)"
+ O(f * g) = O(f::'a => ('b::linordered_field)) \<otimes> O(g)"
by (metis bigo_mult bigo_mult7 order_antisym_conv)
lemma bigo_minus [intro]: "f : O(g) ==> - f : O(g)"
@@ -810,11 +810,11 @@
lemma (*bigo_const2 [intro]:*) "O(%x. c) <= O(%x. 1)"
by (metis bigo_const1 bigo_elt_subset);
-lemma bigo_const2 [intro]: "O(%x. c::'b::ordered_idom) <= O(%x. 1)";
+lemma bigo_const2 [intro]: "O(%x. c::'b::linordered_idom) <= O(%x. 1)";
(*??FAILS because the two occurrences of COMBK have different polymorphic types
proof (neg_clausify)
-assume 0: "\<not> O(COMBK (c\<Colon>'b\<Colon>ordered_idom)) \<subseteq> O(COMBK (1\<Colon>'b\<Colon>ordered_idom))"
-have 1: "COMBK (c\<Colon>'b\<Colon>ordered_idom) \<notin> O(COMBK (1\<Colon>'b\<Colon>ordered_idom))"
+assume 0: "\<not> O(COMBK (c\<Colon>'b\<Colon>linordered_idom)) \<subseteq> O(COMBK (1\<Colon>'b\<Colon>linordered_idom))"
+have 1: "COMBK (c\<Colon>'b\<Colon>linordered_idom) \<notin> O(COMBK (1\<Colon>'b\<Colon>linordered_idom))"
apply (rule notI)
apply (rule 0 [THEN notE])
apply (rule bigo_elt_subset)
@@ -830,26 +830,26 @@
done
declare [[ atp_problem_prefix = "BigO__bigo_const3" ]]
-lemma bigo_const3: "(c::'a::ordered_field) ~= 0 ==> (%x. 1) : O(%x. c)"
+lemma bigo_const3: "(c::'a::linordered_field) ~= 0 ==> (%x. 1) : O(%x. c)"
apply (simp add: bigo_def)
proof (neg_clausify)
-assume 0: "(c\<Colon>'a\<Colon>ordered_field) \<noteq> (0\<Colon>'a\<Colon>ordered_field)"
-assume 1: "\<And>A\<Colon>'a\<Colon>ordered_field. \<not> (1\<Colon>'a\<Colon>ordered_field) \<le> A * \<bar>c\<Colon>'a\<Colon>ordered_field\<bar>"
-have 2: "(0\<Colon>'a\<Colon>ordered_field) = \<bar>c\<Colon>'a\<Colon>ordered_field\<bar> \<or>
-\<not> (1\<Colon>'a\<Colon>ordered_field) \<le> (1\<Colon>'a\<Colon>ordered_field)"
+assume 0: "(c\<Colon>'a\<Colon>linordered_field) \<noteq> (0\<Colon>'a\<Colon>linordered_field)"
+assume 1: "\<And>A\<Colon>'a\<Colon>linordered_field. \<not> (1\<Colon>'a\<Colon>linordered_field) \<le> A * \<bar>c\<Colon>'a\<Colon>linordered_field\<bar>"
+have 2: "(0\<Colon>'a\<Colon>linordered_field) = \<bar>c\<Colon>'a\<Colon>linordered_field\<bar> \<or>
+\<not> (1\<Colon>'a\<Colon>linordered_field) \<le> (1\<Colon>'a\<Colon>linordered_field)"
by (metis 1 field_inverse)
-have 3: "\<bar>c\<Colon>'a\<Colon>ordered_field\<bar> = (0\<Colon>'a\<Colon>ordered_field)"
+have 3: "\<bar>c\<Colon>'a\<Colon>linordered_field\<bar> = (0\<Colon>'a\<Colon>linordered_field)"
by (metis linorder_neq_iff linorder_antisym_conv1 2)
-have 4: "(0\<Colon>'a\<Colon>ordered_field) = (c\<Colon>'a\<Colon>ordered_field)"
+have 4: "(0\<Colon>'a\<Colon>linordered_field) = (c\<Colon>'a\<Colon>linordered_field)"
by (metis 3 abs_eq_0)
show "False"
by (metis 0 4)
qed
-lemma bigo_const4: "(c::'a::ordered_field) ~= 0 ==> O(%x. 1) <= O(%x. c)"
+lemma bigo_const4: "(c::'a::linordered_field) ~= 0 ==> O(%x. 1) <= O(%x. c)"
by (rule bigo_elt_subset, rule bigo_const3, assumption)
-lemma bigo_const [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const [simp]: "(c::'a::linordered_field) ~= 0 ==>
O(%x. c) = O(%x. 1)"
by (rule equalityI, rule bigo_const2, rule bigo_const4, assumption)
@@ -858,9 +858,9 @@
apply (simp add: bigo_def abs_mult)
proof (neg_clausify)
fix x
-assume 0: "\<And>xa\<Colon>'b\<Colon>ordered_idom.
- \<not> \<bar>c\<Colon>'b\<Colon>ordered_idom\<bar> *
- \<bar>(f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>ordered_idom) ((x\<Colon>'b\<Colon>ordered_idom \<Rightarrow> 'a\<Colon>type) xa)\<bar>
+assume 0: "\<And>xa\<Colon>'b\<Colon>linordered_idom.
+ \<not> \<bar>c\<Colon>'b\<Colon>linordered_idom\<bar> *
+ \<bar>(f\<Colon>'a\<Colon>type \<Rightarrow> 'b\<Colon>linordered_idom) ((x\<Colon>'b\<Colon>linordered_idom \<Rightarrow> 'a\<Colon>type) xa)\<bar>
\<le> xa * \<bar>f (x xa)\<bar>"
show "False"
by (metis linorder_neq_iff linorder_antisym_conv1 0)
@@ -870,7 +870,7 @@
by (rule bigo_elt_subset, rule bigo_const_mult1)
declare [[ atp_problem_prefix = "BigO__bigo_const_mult3" ]]
-lemma bigo_const_mult3: "(c::'a::ordered_field) ~= 0 ==> f : O(%x. c * f x)"
+lemma bigo_const_mult3: "(c::'a::linordered_field) ~= 0 ==> f : O(%x. c * f x)"
apply (simp add: bigo_def)
(*sledgehammer [no luck]*);
apply (rule_tac x = "abs(inverse c)" in exI)
@@ -879,16 +879,16 @@
apply (auto );
done
-lemma bigo_const_mult4: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult4: "(c::'a::linordered_field) ~= 0 ==>
O(f) <= O(%x. c * f x)"
by (rule bigo_elt_subset, rule bigo_const_mult3, assumption)
-lemma bigo_const_mult [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult [simp]: "(c::'a::linordered_field) ~= 0 ==>
O(%x. c * f x) = O(f)"
by (rule equalityI, rule bigo_const_mult2, erule bigo_const_mult4)
declare [[ atp_problem_prefix = "BigO__bigo_const_mult5" ]]
-lemma bigo_const_mult5 [simp]: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_const_mult5 [simp]: "(c::'a::linordered_field) ~= 0 ==>
(%x. c) *o O(f) = O(f)"
apply (auto del: subsetI)
apply (rule order_trans)
@@ -1057,7 +1057,7 @@
apply assumption+
done
-lemma bigo_useful_const_mult: "(c::'a::ordered_field) ~= 0 ==>
+lemma bigo_useful_const_mult: "(c::'a::linordered_field) ~= 0 ==>
(%x. c) * f =o O(h) ==> f =o O(h)"
apply (rule subsetD)
apply (subgoal_tac "(%x. 1 / c) *o O(h) <= O(h)")
@@ -1078,7 +1078,7 @@
apply (rule_tac x = c in exI)
apply safe
apply (case_tac "x = 0")
-apply (metis OrderedGroup.abs_ge_zero OrderedGroup.abs_zero order_less_le Ring_and_Field.split_mult_pos_le)
+apply (metis abs_ge_zero abs_zero order_less_le split_mult_pos_le)
apply (subgoal_tac "x = Suc (x - 1)")
apply metis
apply simp
@@ -1100,7 +1100,7 @@
subsection {* Less than or equal to *}
constdefs
- lesso :: "('a => 'b::ordered_idom) => ('a => 'b) => ('a => 'b)"
+ lesso :: "('a => 'b::linordered_idom) => ('a => 'b) => ('a => 'b)"
(infixl "<o" 70)
"f <o g == (%x. max (f x - g x) 0)"
@@ -1165,7 +1165,7 @@
proof (neg_clausify)
fix x
assume 0: "\<And>A. k A \<le> f A"
-have 1: "\<And>(X1\<Colon>'b\<Colon>ordered_idom) X2. \<not> max X1 X2 < X1"
+have 1: "\<And>(X1\<Colon>'b\<Colon>linordered_idom) X2. \<not> max X1 X2 < X1"
by (metis linorder_not_less le_maxI1) (*sort inserted by hand*)
assume 2: "(0\<Colon>'b) \<le> k x - g x"
have 3: "\<not> k x - g x < (0\<Colon>'b)"
@@ -1206,7 +1206,7 @@
apply (metis abs_ge_zero linorder_linear min_max.sup_absorb1 min_max.sup_commute)
done
-lemma bigo_lesso4: "f <o g =o O(k::'a=>'b::ordered_field) ==>
+lemma bigo_lesso4: "f <o g =o O(k::'a=>'b::linordered_field) ==>
g =o h +o O(k) ==> f <o h =o O(k)"
apply (unfold lesso_def)
apply (drule set_plus_imp_minus)
--- a/src/HOL/Metis_Examples/Message.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Metis_Examples/Message.thy Fri Feb 19 15:21:57 2010 +0000
@@ -45,14 +45,14 @@
text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
syntax (xsymbols)
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
translations
"{|x, y, z|}" == "{|x, {|y, z|}|}"
- "{|x, y|}" == "MPair x y"
+ "{|x, y|}" == "CONST MPair x y"
constdefs
@@ -252,7 +252,7 @@
declare [[ atp_problem_prefix = "Message__parts_cut" ]]
lemma parts_cut: "[|Y\<in> parts(insert X G); X\<in> parts H|] ==> Y\<in> parts(G \<union> H)"
-by (metis Un_subset_iff insert_subset parts_increasing parts_trans)
+by (metis Un_insert_left Un_insert_right insert_absorb mem_def parts_Un parts_idem sup1CI)
@@ -698,13 +698,12 @@
apply (rule subsetI)
apply (erule analz.induct)
apply (metis UnCI UnE Un_commute analz.Inj)
-apply (metis MPair_synth UnCI UnE Un_commute Un_upper1 analz.Fst analz_increasing analz_mono insert_absorb insert_subset)
-apply (metis MPair_synth UnCI UnE Un_commute Un_upper1 analz.Snd analz_increasing analz_mono insert_absorb insert_subset)
+apply (metis MPair_synth UnCI UnE Un_commute analz.Fst analz.Inj mem_def)
+apply (metis MPair_synth UnCI UnE Un_commute analz.Inj analz.Snd mem_def)
apply (blast intro: analz.Decrypt)
apply blast
done
-
declare [[ atp_problem_prefix = "Message__analz_synth" ]]
lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
proof (neg_clausify)
--- a/src/HOL/Metis_Examples/Tarski.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Metis_Examples/Tarski.thy Fri Feb 19 15:21:57 2010 +0000
@@ -78,11 +78,9 @@
{S. S \<subseteq> pset cl &
(| pset = S, order = induced S (order cl) |): CompleteLattice }"
-syntax
- "@SL" :: "['a set, 'a potype] => bool" ("_ <<= _" [51,50]50)
-
-translations
- "S <<= cl" == "S : sublattice `` {cl}"
+abbreviation
+ sublattice_syntax :: "['a set, 'a potype] => bool" ("_ <<= _" [51, 50] 50)
+ where "S <<= cl \<equiv> S : sublattice `` {cl}"
constdefs
dual :: "'a potype => 'a potype"
--- a/src/HOL/Metis_Examples/TransClosure.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Metis_Examples/TransClosure.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MetisTest/TransClosure.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Testing the metis method
--- a/src/HOL/MicroJava/BV/BVExample.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/BV/BVExample.thy Fri Feb 19 15:21:57 2010 +0000
@@ -296,12 +296,10 @@
done
text {* Some abbreviations for readability *}
-syntax
- Clist :: ty
- Ctest :: ty
-translations
- "Clist" == "Class list_name"
- "Ctest" == "Class test_name"
+abbreviation Clist :: ty
+ where "Clist == Class list_name"
+abbreviation Ctest :: ty
+ where "Ctest == Class test_name"
constdefs
phi_makelist :: method_type ("\<phi>\<^sub>m")
--- a/src/HOL/MicroJava/BV/JType.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/BV/JType.thy Fri Feb 19 15:21:57 2010 +0000
@@ -37,9 +37,7 @@
"is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
(case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C, Object) \<in> (subcls1 G)^*)"
-
-translations
- "types G" == "Collect (is_type G)"
+abbreviation "types G == Collect (is_type G)"
constdefs
esl :: "'c prog \<Rightarrow> ty esl"
--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy Fri Feb 19 15:21:57 2010 +0000
@@ -584,10 +584,9 @@
(* Currently: empty exception_table *)
-syntax
+abbreviation (input)
empty_et :: exception_table
-translations
- "empty_et" => "[]"
+ where "empty_et == []"
@@ -860,12 +859,13 @@
section "Correspondence bytecode - method types"
(* ********************************************************************** *)
-syntax
+abbreviation (input)
ST_of :: "state_type \<Rightarrow> opstack_type"
+ where "ST_of == fst"
+
+abbreviation (input)
LT_of :: "state_type \<Rightarrow> locvars_type"
-translations
- "ST_of" => "fst"
- "LT_of" => "snd"
+ where "LT_of == snd"
lemma states_lower:
"\<lbrakk> OK (Some (ST, LT)) \<in> states cG mxs mxr; length ST \<le> mxs\<rbrakk>
--- a/src/HOL/MicroJava/Comp/LemmasComp.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/Comp/LemmasComp.thy Fri Feb 19 15:21:57 2010 +0000
@@ -262,10 +262,8 @@
done
-syntax
- mtd_mb :: "cname \<times> ty \<times> 'c \<Rightarrow> 'c"
-translations
- "mtd_mb" => "Fun.comp snd snd"
+abbreviation (input)
+ "mtd_mb == snd o snd"
lemma map_of_map_fst: "\<lbrakk> inj f;
\<forall>x\<in>set xs. fst (f x) = fst x; \<forall>x\<in>set xs. fst (g x) = fst x \<rbrakk>
--- a/src/HOL/MicroJava/Comp/TranslCompTp.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/Comp/TranslCompTp.thy Fri Feb 19 15:21:57 2010 +0000
@@ -41,13 +41,13 @@
(**********************************************************************)
-syntax
- mt_of :: "method_type \<times> state_type \<Rightarrow> method_type"
- sttp_of :: "method_type \<times> state_type \<Rightarrow> state_type"
+abbreviation (input)
+ mt_of :: "method_type \<times> state_type \<Rightarrow> method_type"
+ where "mt_of == fst"
-translations
- "mt_of" => "fst"
- "sttp_of" => "snd"
+abbreviation (input)
+ sttp_of :: "method_type \<times> state_type \<Rightarrow> state_type"
+ where "sttp_of == snd"
consts
compTpExpr :: "java_mb \<Rightarrow> java_mb prog \<Rightarrow> expr
@@ -189,4 +189,3 @@
end
-
--- a/src/HOL/MicroJava/DFA/Err.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/DFA/Err.thy Fri Feb 19 15:21:57 2010 +0000
@@ -45,10 +45,9 @@
sl :: "'a esl \<Rightarrow> 'a err sl"
"sl == %(A,r,f). (err A, le r, lift2 f)"
-syntax
- err_semilat :: "'a esl \<Rightarrow> bool"
-translations
-"err_semilat L" == "semilat(Err.sl L)"
+abbreviation
+ err_semilat :: "'a esl \<Rightarrow> bool"
+ where "err_semilat L == semilat(Err.sl L)"
consts
--- a/src/HOL/MicroJava/DFA/Listn.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/DFA/Listn.thy Fri Feb 19 15:21:57 2010 +0000
@@ -17,21 +17,24 @@
le :: "'a ord \<Rightarrow> ('a list)ord"
"le r == list_all2 (%x y. x <=_r y)"
-syntax "@lesublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+abbreviation
+ lesublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
("(_ /<=[_] _)" [50, 0, 51] 50)
-syntax "@lesssublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+ where "x <=[r] y == x <=_(le r) y"
+
+abbreviation
+ lesssublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
("(_ /<[_] _)" [50, 0, 51] 50)
-translations
- "x <=[r] y" == "x <=_(Listn.le r) y"
- "x <[r] y" == "x <_(Listn.le r) y"
+ where "x <[r] y == x <_(le r) y"
constdefs
map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
"map2 f == (%xs ys. map (split f) (zip xs ys))"
-syntax "@plussublist" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
+abbreviation
+ plussublist_syntax :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
("(_ /+[_] _)" [65, 0, 66] 65)
-translations "x +[f] y" == "x +_(map2 f) y"
+ where "x +[f] y == x +_(map2 f) y"
consts coalesce :: "'a err list \<Rightarrow> 'a list err"
primrec
--- a/src/HOL/MicroJava/DFA/Product.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/DFA/Product.thy Fri Feb 19 15:21:57 2010 +0000
@@ -19,9 +19,10 @@
esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a * 'b ) esl"
"esl == %(A,rA,fA) (B,rB,fB). (A <*> B, le rA rB, sup fA fB)"
-syntax "@lesubprod" :: "'a*'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'b \<Rightarrow> bool"
+abbreviation
+ lesubprod_sntax :: "'a * 'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'a * 'b \<Rightarrow> bool"
("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
-translations "p <=(rA,rB) q" == "p <=_(Product.le rA rB) q"
+ where "p <=(rA,rB) q == p <=_(le rA rB) q"
lemma unfold_lesub_prod:
"p <=(rA,rB) q == le rA rB p q"
--- a/src/HOL/MicroJava/DFA/Semilat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/DFA/Semilat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -33,9 +33,9 @@
"plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)
(*<*)
(* allow \<sub> instead of \<bsub>..\<esub> *)
- "@lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
- "@lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
- "@plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
+ "_lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
+ "_lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
+ "_plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
translations
"x \<sqsubseteq>\<^sub>r y" => "x \<sqsubseteq>\<^bsub>r\<^esub> y"
--- a/src/HOL/MicroJava/DFA/SemilatAlg.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/DFA/SemilatAlg.thy Fri Feb 19 15:21:57 2010 +0000
@@ -15,7 +15,7 @@
"x <=|r| y \<equiv> \<forall>(p,s) \<in> set x. \<exists>s'. (p,s') \<in> set y \<and> s <=_r s'"
consts
- "@plusplussub" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65)
+ plusplussub :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65)
primrec
"[] ++_f y = y"
"(x#xs) ++_f y = xs ++_f (x +_f y)"
--- a/src/HOL/MicroJava/J/Example.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/J/Example.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Example.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -55,19 +54,16 @@
declare inj_cnam' [simp] inj_vnam' [simp]
-syntax
- Base :: cname
- Ext :: cname
- vee :: vname
- x :: vname
- e :: vname
-
-translations
- "Base" == "cnam' Base'"
- "Ext" == "cnam' Ext'"
- "vee" == "VName (vnam' vee')"
- "x" == "VName (vnam' x')"
- "e" == "VName (vnam' e')"
+abbreviation Base :: cname
+ where "Base == cnam' Base'"
+abbreviation Ext :: cname
+ where "Ext == cnam' Ext'"
+abbreviation vee :: vname
+ where "vee == VName (vnam' vee')"
+abbreviation x :: vname
+ where "x == VName (vnam' x')"
+abbreviation e :: vname
+ where "e == VName (vnam' e')"
axioms
Base_not_Object: "Base \<noteq> Object"
--- a/src/HOL/MicroJava/J/Exceptions.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/J/Exceptions.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Exceptions.thy
- ID: $Id$
Author: Gerwin Klein, Martin Strecker
Copyright 2002 Technische Universitaet Muenchen
*)
@@ -17,11 +16,9 @@
(XcptRef OutOfMemory \<mapsto> blank G (Xcpt OutOfMemory))"
-consts
+abbreviation
cname_of :: "aheap \<Rightarrow> val \<Rightarrow> cname"
-
-translations
- "cname_of hp v" == "fst (CONST the (hp (the_Addr v)))"
+ where "cname_of hp v == fst (the (hp (the_Addr v)))"
constdefs
--- a/src/HOL/MicroJava/J/State.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/J/State.thy Fri Feb 19 15:21:57 2010 +0000
@@ -27,21 +27,27 @@
state = "aheap \<times> locals" -- "heap, local parameter including This"
xstate = "val option \<times> state" -- "state including exception information"
-syntax
- heap :: "state => aheap"
- locals :: "state => locals"
- Norm :: "state => xstate"
- abrupt :: "xstate \<Rightarrow> val option"
- store :: "xstate \<Rightarrow> state"
- lookup_obj :: "state \<Rightarrow> val \<Rightarrow> obj"
+abbreviation (input)
+ heap :: "state => aheap"
+ where "heap == fst"
+
+abbreviation (input)
+ locals :: "state => locals"
+ where "locals == snd"
+
+abbreviation "Norm s == (None, s)"
-translations
- "heap" => "fst"
- "locals" => "snd"
- "Norm s" == "(None,s)"
- "abrupt" => "fst"
- "store" => "snd"
- "lookup_obj s a'" == "CONST the (heap s (the_Addr a'))"
+abbreviation (input)
+ abrupt :: "xstate \<Rightarrow> val option"
+ where "abrupt == fst"
+
+abbreviation (input)
+ store :: "xstate \<Rightarrow> state"
+ where "store == snd"
+
+abbreviation
+ lookup_obj :: "state \<Rightarrow> val \<Rightarrow> obj"
+ where "lookup_obj s a' == the (heap s (the_Addr a'))"
constdefs
--- a/src/HOL/MicroJava/J/Type.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/J/Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Type.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -47,12 +46,10 @@
= PrimT prim_ty -- "primitive type"
| RefT ref_ty -- "reference type"
-syntax
- NT :: "ty"
- Class :: "cname => ty"
+abbreviation NT :: ty
+ where "NT == RefT NullT"
-translations
- "NT" == "RefT NullT"
- "Class C" == "RefT (ClassT C)"
+abbreviation Class :: "cname => ty"
+ where "Class C == RefT (ClassT C)"
end
--- a/src/HOL/MicroJava/J/WellType.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/J/WellType.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/WellType.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -27,13 +26,13 @@
lenv = "vname \<rightharpoonup> ty"
'c env = "'c prog \<times> lenv"
-syntax
- prg :: "'c env => 'c prog"
- localT :: "'c env => (vname \<rightharpoonup> ty)"
+abbreviation (input)
+ prg :: "'c env => 'c prog"
+ where "prg == fst"
-translations
- "prg" => "fst"
- "localT" => "snd"
+abbreviation (input)
+ localT :: "'c env => (vname \<rightharpoonup> ty)"
+ where "localT == snd"
consts
more_spec :: "'c prog => (ty \<times> 'x) \<times> ty list =>
@@ -207,10 +206,7 @@
(let E = (G,map_of lvars(pns[\<mapsto>]pTs)(This\<mapsto>Class C)) in
E\<turnstile>blk\<surd> \<and> (\<exists>T. E\<turnstile>res::T \<and> G\<turnstile>T\<preceq>rT))"
-syntax
- wf_java_prog :: "'c prog => bool"
-translations
- "wf_java_prog" == "wf_prog wf_java_mdecl"
+abbreviation "wf_java_prog == wf_prog wf_java_mdecl"
lemma wf_java_prog_wf_java_mdecl: "\<lbrakk>
wf_java_prog G; (C, D, fds, mths) \<in> set G; jmdcl \<in> set mths \<rbrakk>
--- a/src/HOL/MicroJava/JVM/JVMDefensive.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/JVM/JVMDefensive.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/JVM/JVMDefensive.thy
- ID: $Id$
Author: Gerwin Klein
*)
@@ -13,9 +12,9 @@
datatype 'a type_error = TypeError | Normal 'a
-syntax "fifth" :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<Rightarrow> 'e"
-translations
- "fifth x" == "fst(snd(snd(snd(snd x))))"
+abbreviation
+ fifth :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<Rightarrow> 'e"
+ where "fifth x == fst(snd(snd(snd(snd x))))"
consts isAddr :: "val \<Rightarrow> bool"
--- a/src/HOL/MicroJava/JVM/JVMExceptions.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/MicroJava/JVM/JVMExceptions.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/JVM/JVMExceptions.thy
- ID: $Id$
Author: Gerwin Klein, Martin Strecker
Copyright 2001 Technische Universitaet Muenchen
*)
@@ -24,10 +23,9 @@
then Some (fst (snd (snd e)))
else match_exception_table G cn pc es)"
-consts
+abbreviation
ex_table_of :: "jvm_method \<Rightarrow> exception_table"
-translations
- "ex_table_of m" == "snd (snd (snd m))"
+ where "ex_table_of m == snd (snd (snd m))"
consts
--- a/src/HOL/Modelcheck/EindhovenSyn.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Modelcheck/EindhovenSyn.thy Fri Feb 19 15:21:57 2010 +0000
@@ -40,7 +40,7 @@
val pmu =
if eindhoven_home = "" then error "Environment variable EINDHOVEN_HOME not set"
else eindhoven_home ^ "/pmu";
- in #1 (system_out ("echo \"" ^ s ^ "\" | " ^ pmu ^ " -w")) end;
+ in #1 (bash_output ("echo \"" ^ s ^ "\" | " ^ pmu ^ " -w")) end;
in
fn cgoal =>
let
--- a/src/HOL/Modelcheck/MuckeSyn.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Modelcheck/MuckeSyn.thy Fri Feb 19 15:21:57 2010 +0000
@@ -38,7 +38,7 @@
"_idts" :: "[idt, idts] => idts" ("_,/ _" [1, 0] 0)
"_tuple" :: "'a => tuple_args => 'a * 'b" ("(1_,/ _)")
-(* "@pttrn" :: "[pttrn, pttrns] => pttrn" ("_,/ _" [1, 0] 0)
+(* "_pttrn" :: "[pttrn, pttrns] => pttrn" ("_,/ _" [1, 0] 0)
"_pattern" :: "[pttrn, patterns] => pttrn" ("_,/ _" [1, 0] 0) *)
"_decl" :: "[mutype,pttrn] => decl" ("_ _")
--- a/src/HOL/Modelcheck/mucke_oracle.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Modelcheck/mucke_oracle.ML Fri Feb 19 15:21:57 2010 +0000
@@ -498,7 +498,7 @@
else mucke_home ^ "/mucke";
val mucke_input_file = File.tmp_path (Path.basic "tmp.mu");
val _ = File.write mucke_input_file s;
- val (result, _) = system_out (mucke ^ " -nb -res " ^ File.shell_path mucke_input_file);
+ val (result, _) = bash_output (mucke ^ " -nb -res " ^ File.shell_path mucke_input_file);
in
if not (!trace_mc) then (File.rm mucke_input_file) else ();
result
--- a/src/HOL/Multivariate_Analysis/Derivative.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Derivative.thy Fri Feb 19 15:21:57 2010 +0000
@@ -387,7 +387,7 @@
apply(rule_tac le_less_trans[of _ "e/2"]) by(auto intro!:mult_imp_div_pos_le simp add:group_simps) qed auto qed
lemma has_derivative_at_alt:
- "(f has_derivative f') (at (x::real^'n)) \<longleftrightarrow> bounded_linear f' \<and>
+ "(f has_derivative f') (at x) \<longleftrightarrow> bounded_linear f' \<and>
(\<forall>e>0. \<exists>d>0. \<forall>y. norm(y - x) < d \<longrightarrow> norm(f y - f x - f'(y - x)) \<le> e * norm(y - x))"
using has_derivative_within_alt[where s=UNIV] unfolding within_UNIV by auto
@@ -1183,7 +1183,7 @@
fix y assume as:"y \<in> s" "0 < dist y x" "dist y x < e / (B * C * D)"
have "norm (h (f' (y - x)) (g' (y - x))) \<le> norm (f' (y - x)) * norm (g' (y - x)) * B" using B by auto
also have "\<dots> \<le> (norm (y - x) * C) * (D * norm (y - x)) * B" apply(rule mult_right_mono)
- apply(rule pordered_semiring_class.mult_mono) using B C D by (auto simp add: field_simps intro!:mult_nonneg_nonneg)
+ apply(rule mult_mono) using B C D by (auto simp add: field_simps intro!:mult_nonneg_nonneg)
also have "\<dots> = (B * C * D * norm (y - x)) * norm (y - x)" by(auto simp add:field_simps)
also have "\<dots> < e * norm (y - x)" apply(rule mult_strict_right_mono)
using as(3)[unfolded vector_dist_norm] and as(2) unfolding pos_less_divide_eq[OF bcd] by (auto simp add:field_simps)
--- a/src/HOL/Multivariate_Analysis/Determinants.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Determinants.thy Fri Feb 19 15:21:57 2010 +0000
@@ -44,7 +44,7 @@
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)"
+lemma setprod_le: assumes fS: "finite S" and fg: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (g x :: 'a::linordered_idom)"
shows "setprod f S \<le> setprod g S"
using fS fg
apply(induct S)
@@ -61,7 +61,7 @@
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)"
+lemma setprod_le_1: assumes fS: "finite S" and f: "\<forall>x\<in>S. f x \<ge> 0 \<and> f x \<le> (1::'a::linordered_idom)"
shows "setprod f S \<le> 1"
using setprod_le[OF fS f] unfolding setprod_1 .
@@ -121,7 +121,7 @@
(* Basic determinant properties. *)
(* ------------------------------------------------------------------------- *)
-lemma det_transp: "det (transp A) = det (A::'a::comm_ring_1 ^'n^'n)"
+lemma det_transpose: "det (transpose A) = det (A::'a::comm_ring_1 ^'n^'n)"
proof-
let ?di = "\<lambda>A i j. A$i$j"
let ?U = "(UNIV :: 'n set)"
@@ -133,18 +133,18 @@
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"
+ have "setprod (\<lambda>i. ?di (transpose A) i (inv p i)) ?U = setprod (\<lambda>i. ?di (transpose A) i (inv p i)) (p ` ?U)" by simp
+ also have "\<dots> = setprod ((\<lambda>i. ?di (transpose 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)
+ have "((\<lambda>i. ?di (transpose A) i (inv p i)) o p) i = ?di A i (p i)"
+ unfolding transpose_def by (simp add: expand_fun_eq)}
+ then show "setprod ((\<lambda>i. ?di (transpose 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
+ finally have "of_int (sign (inv p)) * (setprod (\<lambda>i. ?di (transpose 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
@@ -267,17 +267,17 @@
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 ..
+ let ?At = "transpose A"
+ have "of_int (sign p) * det A = det (transpose (\<chi> i. transpose A $ p i))"
+ unfolding det_permute_rows[OF p, of ?At] det_transpose ..
moreover
- have "?Ap = transp (\<chi> i. transp A $ p i)"
- by (simp add: transp_def Cart_eq)
+ have "?Ap = transpose (\<chi> i. transpose A $ p i)"
+ by (simp add: transpose_def Cart_eq)
ultimately show ?thesis by simp
qed
lemma det_identical_rows:
- fixes A :: "'a::ordered_idom^'n^'n"
+ fixes A :: "'a::linordered_idom^'n^'n"
assumes ij: "i \<noteq> j"
and r: "row i A = row j A"
shows "det A = 0"
@@ -295,13 +295,13 @@
qed
lemma det_identical_columns:
- fixes A :: "'a::ordered_idom^'n^'n"
+ fixes A :: "'a::linordered_idom^'n^'n"
assumes ij: "i \<noteq> j"
and r: "column i A = column j A"
shows "det A = 0"
-apply (subst det_transp[symmetric])
+apply (subst det_transpose[symmetric])
apply (rule det_identical_rows[OF ij])
-by (metis row_transp r)
+by (metis row_transpose r)
lemma det_zero_row:
fixes A :: "'a::{idom, ring_char_0}^'n^'n"
@@ -317,9 +317,9 @@
fixes A :: "'a::{idom,ring_char_0}^'n^'n"
assumes r: "column i A = 0"
shows "det A = 0"
- apply (subst det_transp[symmetric])
+ apply (subst det_transpose[symmetric])
apply (rule det_zero_row [of i])
- by (metis row_transp r)
+ by (metis row_transpose r)
lemma det_row_add:
fixes a b c :: "'n::finite \<Rightarrow> _ ^ 'n"
@@ -407,7 +407,7 @@
unfolding vector_smult_lzero .
lemma det_row_operation:
- fixes A :: "'a::ordered_idom^'n^'n"
+ fixes A :: "'a::linordered_idom^'n^'n"
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-
@@ -421,7 +421,7 @@
qed
lemma det_row_span:
- fixes A :: "'a:: ordered_idom^'n^'n"
+ fixes A :: "'a:: linordered_idom^'n^'n"
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-
@@ -462,7 +462,7 @@
(* ------------------------------------------------------------------------- *)
lemma det_dependent_rows:
- fixes A:: "'a::ordered_idom^'n^'n"
+ fixes A:: "'a::linordered_idom^'n^'n"
assumes d: "dependent (rows A)"
shows "det A = 0"
proof-
@@ -488,8 +488,8 @@
ultimately show ?thesis by blast
qed
-lemma det_dependent_columns: assumes d: "dependent(columns (A::'a::ordered_idom^'n^'n))" shows "det A = 0"
-by (metis d det_dependent_rows rows_transp det_transp)
+lemma det_dependent_columns: assumes d: "dependent(columns (A::'a::linordered_idom^'n^'n))" shows "det A = 0"
+by (metis d det_dependent_rows rows_transpose det_transpose)
(* ------------------------------------------------------------------------- *)
(* Multilinearity and the multiplication formula. *)
@@ -608,7 +608,7 @@
qed
lemma det_mul:
- fixes A B :: "'a::ordered_idom^'n^'n"
+ fixes A B :: "'a::linordered_idom^'n^'n"
shows "det (A ** B) = det A * det B"
proof-
let ?U = "UNIV :: 'n set"
@@ -760,8 +760,8 @@
(* Cramer's rule. *)
(* ------------------------------------------------------------------------- *)
-lemma cramer_lemma_transp:
- fixes A:: "'a::ordered_idom^'n^'n" and x :: "'a ^'n"
+lemma cramer_lemma_transpose:
+ fixes A:: "'a::linordered_idom^'n^'n" and x :: "'a ^'n"
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")
@@ -797,17 +797,17 @@
qed
lemma cramer_lemma:
- fixes A :: "'a::ordered_idom ^'n^'n"
+ fixes A :: "'a::linordered_idom ^'n^'n"
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)
+ have stupid: "\<And>c. setsum (\<lambda>i. c i *s row i (transpose A)) ?U = setsum (\<lambda>i. c i *s column i A) ?U"
+ by (auto simp add: row_transpose intro: setsum_cong2)
show ?thesis unfolding matrix_mult_vsum
- unfolding cramer_lemma_transp[of k x "transp A", unfolded det_transp, symmetric]
+ unfolding cramer_lemma_transpose[of k x "transpose A", unfolded det_transpose, 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)
+ apply (subst det_transpose[symmetric])
+ apply (rule cong[OF refl[of det]]) by (vector transpose_def column_def row_def)
qed
lemma cramer:
@@ -840,13 +840,13 @@
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"
+definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow> transpose Q ** Q = mat 1 \<and> Q ** transpose Q = mat 1"
-lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n) \<longleftrightarrow> transp Q ** Q = mat 1"
+lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n) \<longleftrightarrow> transpose Q ** Q = mat 1"
by (metis matrix_left_right_inverse orthogonal_matrix_def)
lemma orthogonal_matrix_id: "orthogonal_matrix (mat 1 :: _^'n^'n)"
- by (simp add: orthogonal_matrix_def transp_mat matrix_mul_lid)
+ by (simp add: orthogonal_matrix_def transpose_mat matrix_mul_lid)
lemma orthogonal_matrix_mul:
fixes A :: "real ^'n^'n"
@@ -854,7 +854,7 @@
and oB: "orthogonal_matrix B"
shows "orthogonal_matrix(A ** B)"
using oA oB
- unfolding orthogonal_matrix matrix_transp_mul
+ unfolding orthogonal_matrix matrix_transpose_mul
apply (subst matrix_mul_assoc)
apply (subst matrix_mul_assoc[symmetric])
by (simp add: matrix_mul_rid)
@@ -873,7 +873,7 @@
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"
+ let ?A = "transpose ?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
@@ -893,7 +893,7 @@
qed
lemma det_orthogonal_matrix:
- fixes Q:: "'a::ordered_idom^'n^'n"
+ fixes Q:: "'a::linordered_idom^'n^'n"
assumes oQ: "orthogonal_matrix Q"
shows "det Q = 1 \<or> det Q = - 1"
proof-
@@ -908,9 +908,9 @@
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)
+ from oQ have "Q ** transpose Q = mat 1" by (metis orthogonal_matrix_def)
+ hence "det (Q ** transpose Q) = det (mat 1:: 'a^'n^'n)" by simp
+ hence "det Q * det Q = 1" by (simp add: det_mul det_I det_transpose)
then show ?thesis unfolding th .
qed
@@ -1034,7 +1034,7 @@
definition "rotoinversion_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = - 1"
lemma orthogonal_rotation_or_rotoinversion:
- fixes Q :: "'a::ordered_idom^'n^'n"
+ fixes Q :: "'a::linordered_idom^'n^'n"
shows " orthogonal_matrix Q \<longleftrightarrow> rotation_matrix Q \<or> rotoinversion_matrix Q"
by (metis rotoinversion_matrix_def rotation_matrix_def det_orthogonal_matrix)
(* ------------------------------------------------------------------------- *)
--- a/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Fri Feb 19 15:21:57 2010 +0000
@@ -459,7 +459,7 @@
done
lemma setsum_nonneg_eq_0_iff:
- fixes f :: "'a \<Rightarrow> 'b::pordered_ab_group_add"
+ fixes f :: "'a \<Rightarrow> 'b::ordered_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)
@@ -836,10 +836,10 @@
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"
+lemma dot_pos_le[simp]: "(0::'a\<Colon>linordered_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)"
+lemma setsum_squares_eq_0_iff: assumes fS: "finite F" and fp: "\<forall>x \<in> F. f x \<ge> (0 ::'a::ordered_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
@@ -852,10 +852,10 @@
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) = 0"
+lemma dot_eq_0: "x \<bullet> x = 0 \<longleftrightarrow> (x::'a::{linordered_ring_strict,ring_no_zero_divisors} ^ 'n) = 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) \<noteq> 0" using dot_eq_0[of x] dot_pos_le[of x]
+lemma dot_pos_lt[simp]: "(0 < x \<bullet> x) \<longleftrightarrow> (x::'a::{linordered_ring_strict,ring_no_zero_divisors} ^ 'n) \<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. *}
@@ -1042,11 +1042,6 @@
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) + norm y <= e ==> norm(x + y) <= e"
- by (metis order_trans norm_triangle_ineq)
-lemma norm_triangle_lt: "norm(x::real ^ 'n) + 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"
apply (simp add: norm_vector_def)
apply (rule member_le_setL2, simp_all)
@@ -1146,7 +1141,7 @@
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"
+lemma ge_iff_diff_ge_0: "(a::'a::linordered_ring) \<ge> b == a - b \<ge> 0"
by (simp add: ring_simps)
lemma pth_1:
@@ -1275,6 +1270,22 @@
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 norm_triangle_half_r:
+ shows "norm (y - x1) < e / 2 \<Longrightarrow> norm (y - x2) < e / 2 \<Longrightarrow> norm (x1 - x2) < e"
+ using dist_triangle_half_r unfolding vector_dist_norm[THEN sym] by auto
+
+lemma norm_triangle_half_l: assumes "norm (x - y) < e / 2" "norm (x' - (y)) < e / 2"
+ shows "norm (x - x') < e"
+ using dist_triangle_half_l[OF assms[unfolded vector_dist_norm[THEN sym]]]
+ unfolding vector_dist_norm[THEN sym] .
+
+lemma norm_triangle_le: "norm(x) + norm y <= e ==> norm(x + y) <= e"
+ by (metis order_trans norm_triangle_ineq)
+
+lemma norm_triangle_lt: "norm(x) + norm(y) < e ==> norm(x + y) < e"
+ by (metis basic_trans_rules(21) norm_triangle_ineq)
+
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'"
@@ -2029,7 +2040,8 @@
where "v v* m == (\<chi> j. setsum (\<lambda>i. ((m$i)$j) * (v$i)) (UNIV :: 'm set)) :: 'a^'n"
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 transpose where
+ "(transpose::'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)}"
@@ -2071,8 +2083,8 @@
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^_^_)"
- by (simp add: matrix_matrix_mult_def transp_def Cart_eq mult_commute)
+lemma matrix_transpose_mul: "transpose(A ** B) = transpose B ** transpose (A::'a::comm_semiring_1^_^_)"
+ by (simp add: matrix_matrix_mult_def transpose_def Cart_eq mult_commute)
lemma matrix_eq:
fixes A B :: "'a::semiring_1 ^ 'n ^ 'm"
@@ -2094,26 +2106,26 @@
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:
+lemma transpose_mat: "transpose (mat n) = mat n"
+ by (vector transpose_def mat_def)
+
+lemma transpose_transpose: "transpose(transpose A) = A"
+ by (vector transpose_def)
+
+lemma row_transpose:
fixes A:: "'a::semiring_1^_^_"
- shows "row i (transp A) = column i A"
- by (simp add: row_def column_def transp_def Cart_eq)
-
-lemma column_transp:
+ shows "row i (transpose A) = column i A"
+ by (simp add: row_def column_def transpose_def Cart_eq)
+
+lemma column_transpose:
fixes A:: "'a::semiring_1^_^_"
- 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^_^_)) = columns A"
-by (auto simp add: rows_def columns_def row_transp intro: set_ext)
-
-lemma columns_transp: "columns(transp (A::'a::semiring_1^_^_)) = rows A" by (metis transp_transp rows_transp)
+ shows "column i (transpose A) = row i A"
+ by (simp add: row_def column_def transpose_def Cart_eq)
+
+lemma rows_transpose: "rows(transpose (A::'a::semiring_1^_^_)) = columns A"
+by (auto simp add: rows_def columns_def row_transpose intro: set_ext)
+
+lemma columns_transpose: "columns(transpose (A::'a::semiring_1^_^_)) = rows A" by (metis transpose_transpose rows_transpose)
text{* Two sometimes fruitful ways of looking at matrix-vector multiplication. *}
@@ -2176,19 +2188,19 @@
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^_) *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^'m) *v x) = (\<lambda>x. transp A *v x)"
+lemma matrix_vector_column:"(A::'a::comm_semiring_1^'n^_) *v x = setsum (\<lambda>i. (x$i) *s ((transpose A)$i)) (UNIV:: 'n set)"
+ by (simp add: matrix_vector_mult_def transpose_def Cart_eq mult_commute)
+
+lemma adjoint_matrix: "adjoint(\<lambda>x. (A::'a::comm_ring_1^'n^'m) *v x) = (\<lambda>x. transpose 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 (simp add: transpose_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 \<Rightarrow> 'a ^'m)"
- shows "matrix(adjoint f) = transp(matrix f)"
+ shows "matrix(adjoint f) = transpose(matrix f)"
apply (subst matrix_vector_mul[OF lf])
unfolding adjoint_matrix matrix_of_matrix_vector_mul ..
@@ -3827,7 +3839,7 @@
(* 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) \<bullet> (x - ((b \<bullet> x) / (b\<bullet>b)) *s b) = 0"
+lemma vector_sub_project_orthogonal: "(b::'a::linordered_field^'n) \<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]
@@ -4317,13 +4329,13 @@
(* Detailed theorems about left and right invertibility in general case. *)
-lemma left_invertible_transp:
- "(\<exists>(B). B ** transp (A) = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B). A ** B = mat 1)"
- by (metis matrix_transp_mul transp_mat transp_transp)
-
-lemma right_invertible_transp:
- "(\<exists>(B). transp (A) ** B = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B). B ** A = mat 1)"
- by (metis matrix_transp_mul transp_mat transp_transp)
+lemma left_invertible_transpose:
+ "(\<exists>(B). B ** transpose (A) = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B). A ** B = mat 1)"
+ by (metis matrix_transpose_mul transpose_mat transpose_transpose)
+
+lemma right_invertible_transpose:
+ "(\<exists>(B). transpose (A) ** B = mat (1::'a::comm_semiring_1)) \<longleftrightarrow> (\<exists>(B). B ** A = mat 1)"
+ by (metis matrix_transpose_mul transpose_mat transpose_transpose)
lemma linear_injective_left_inverse:
assumes lf: "linear (f::real ^'n \<Rightarrow> real ^'m)" and fi: "inj f"
@@ -4438,9 +4450,9 @@
lemma matrix_right_invertible_independent_rows:
fixes A :: "real^'n^'m"
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]
+ unfolding left_invertible_transpose[symmetric]
matrix_left_invertible_independent_columns
- by (simp add: column_transp)
+ by (simp add: column_transpose)
lemma matrix_right_invertible_span_columns:
"(\<exists>(B::real ^'n^'m). (A::real ^'m^'n) ** B = mat 1) \<longleftrightarrow> span (columns A) = UNIV" (is "?lhs = ?rhs")
@@ -4506,8 +4518,8 @@
lemma matrix_left_invertible_span_rows:
"(\<exists>(B::real^'m^'n). B ** (A::real^'n^'m) = mat 1) \<longleftrightarrow> span (rows A) = UNIV"
- unfolding right_invertible_transp[symmetric]
- unfolding columns_transp[symmetric]
+ unfolding right_invertible_transpose[symmetric]
+ unfolding columns_transpose[symmetric]
unfolding matrix_right_invertible_span_columns
..
@@ -4728,12 +4740,12 @@
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 transpose_columnvector:
+ "transpose(columnvector v) = rowvector v"
+ by (simp add: transpose_def rowvector_def columnvector_def Cart_eq)
+
+lemma transpose_rowvector: "transpose(rowvector v) = columnvector v"
+ by (simp add: transpose_def columnvector_def rowvector_def Cart_eq)
lemma dot_rowvector_columnvector:
"columnvector (A *v v) = A ** columnvector v"
@@ -4745,9 +4757,9 @@
lemma dot_matrix_vector_mul:
fixes A B :: "real ^'n ^'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 ..
+ (((rowvector x :: real^'n^1) ** ((transpose A ** B) ** (columnvector y :: real ^1^'n)))$1)$1"
+unfolding dot_matrix_product transpose_columnvector[symmetric]
+ dot_rowvector_columnvector matrix_transpose_mul matrix_mul_assoc ..
(* Infinity norm. *)
--- a/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Fri Feb 19 15:21:57 2010 +0000
@@ -27,14 +27,14 @@
parse_translation {*
let
- fun cart t u = Syntax.const @{type_name cart} $ t $ u
+ fun cart t u = Syntax.const @{type_name cart} $ t $ u; (* FIXME @{type_syntax} *)
fun finite_cart_tr [t, u as Free (x, _)] =
- if Syntax.is_tid x
- then cart t (Syntax.const "_ofsort" $ u $ Syntax.const (hd @{sort finite}))
+ if Syntax.is_tid x then
+ cart t (Syntax.const @{syntax_const "_ofsort"} $ u $ Syntax.const (hd @{sort finite}))
else cart t u
| finite_cart_tr [t, u] = cart t u
in
- [("_finite_cart", finite_cart_tr)]
+ [(@{syntax_const "_finite_cart"}, finite_cart_tr)]
end
*}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Integration_MV.cert Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,3270 @@
+tB2Atlor9W4pSnrAz5nHpw 907 0
+#2 := false
+#299 := 0::real
+decl uf_1 :: (-> T3 T2 real)
+decl uf_10 :: (-> T4 T2)
+decl uf_7 :: T4
+#15 := uf_7
+#22 := (uf_10 uf_7)
+decl uf_2 :: (-> T1 T3)
+decl uf_4 :: T1
+#11 := uf_4
+#91 := (uf_2 uf_4)
+#902 := (uf_1 #91 #22)
+#297 := -1::real
+#1084 := (* -1::real #902)
+decl uf_16 :: T1
+#50 := uf_16
+#78 := (uf_2 uf_16)
+#799 := (uf_1 #78 #22)
+#1267 := (+ #799 #1084)
+#1272 := (>= #1267 0::real)
+#1266 := (= #799 #902)
+decl uf_9 :: T3
+#21 := uf_9
+#23 := (uf_1 uf_9 #22)
+#905 := (= #23 #902)
+decl uf_11 :: T3
+#24 := uf_11
+#850 := (uf_1 uf_11 #22)
+#904 := (= #850 #902)
+decl uf_6 :: (-> T2 T4)
+#74 := (uf_6 #22)
+#281 := (= uf_7 #74)
+#922 := (ite #281 #905 #904)
+decl uf_8 :: T3
+#18 := uf_8
+#848 := (uf_1 uf_8 #22)
+#903 := (= #848 #902)
+#60 := 0::int
+decl uf_5 :: (-> T4 int)
+#803 := (uf_5 #74)
+#117 := -1::int
+#813 := (* -1::int #803)
+#16 := (uf_5 uf_7)
+#916 := (+ #16 #813)
+#917 := (<= #916 0::int)
+#925 := (ite #917 #922 #903)
+#6 := (:var 0 T2)
+#19 := (uf_1 uf_8 #6)
+#544 := (pattern #19)
+#25 := (uf_1 uf_11 #6)
+#543 := (pattern #25)
+#92 := (uf_1 #91 #6)
+#542 := (pattern #92)
+#13 := (uf_6 #6)
+#541 := (pattern #13)
+#447 := (= #19 #92)
+#445 := (= #25 #92)
+#444 := (= #23 #92)
+#20 := (= #13 uf_7)
+#446 := (ite #20 #444 #445)
+#120 := (* -1::int #16)
+#14 := (uf_5 #13)
+#121 := (+ #14 #120)
+#119 := (>= #121 0::int)
+#448 := (ite #119 #446 #447)
+#545 := (forall (vars (?x3 T2)) (:pat #541 #542 #543 #544) #448)
+#451 := (forall (vars (?x3 T2)) #448)
+#548 := (iff #451 #545)
+#546 := (iff #448 #448)
+#547 := [refl]: #546
+#549 := [quant-intro #547]: #548
+#26 := (ite #20 #23 #25)
+#127 := (ite #119 #26 #19)
+#368 := (= #92 #127)
+#369 := (forall (vars (?x3 T2)) #368)
+#452 := (iff #369 #451)
+#449 := (iff #368 #448)
+#450 := [rewrite]: #449
+#453 := [quant-intro #450]: #452
+#392 := (~ #369 #369)
+#390 := (~ #368 #368)
+#391 := [refl]: #390
+#366 := [nnf-pos #391]: #392
+decl uf_3 :: (-> T1 T2 real)
+#12 := (uf_3 uf_4 #6)
+#132 := (= #12 #127)
+#135 := (forall (vars (?x3 T2)) #132)
+#370 := (iff #135 #369)
+#4 := (:var 1 T1)
+#8 := (uf_3 #4 #6)
+#5 := (uf_2 #4)
+#7 := (uf_1 #5 #6)
+#9 := (= #7 #8)
+#10 := (forall (vars (?x1 T1) (?x2 T2)) #9)
+#113 := [asserted]: #10
+#371 := [rewrite* #113]: #370
+#17 := (< #14 #16)
+#27 := (ite #17 #19 #26)
+#28 := (= #12 #27)
+#29 := (forall (vars (?x3 T2)) #28)
+#136 := (iff #29 #135)
+#133 := (iff #28 #132)
+#130 := (= #27 #127)
+#118 := (not #119)
+#124 := (ite #118 #19 #26)
+#128 := (= #124 #127)
+#129 := [rewrite]: #128
+#125 := (= #27 #124)
+#122 := (iff #17 #118)
+#123 := [rewrite]: #122
+#126 := [monotonicity #123]: #125
+#131 := [trans #126 #129]: #130
+#134 := [monotonicity #131]: #133
+#137 := [quant-intro #134]: #136
+#114 := [asserted]: #29
+#138 := [mp #114 #137]: #135
+#372 := [mp #138 #371]: #369
+#367 := [mp~ #372 #366]: #369
+#454 := [mp #367 #453]: #451
+#550 := [mp #454 #549]: #545
+#738 := (not #545)
+#928 := (or #738 #925)
+#75 := (= #74 uf_7)
+#906 := (ite #75 #905 #904)
+#907 := (+ #803 #120)
+#908 := (>= #907 0::int)
+#909 := (ite #908 #906 #903)
+#929 := (or #738 #909)
+#931 := (iff #929 #928)
+#933 := (iff #928 #928)
+#934 := [rewrite]: #933
+#926 := (iff #909 #925)
+#923 := (iff #906 #922)
+#283 := (iff #75 #281)
+#284 := [rewrite]: #283
+#924 := [monotonicity #284]: #923
+#920 := (iff #908 #917)
+#910 := (+ #120 #803)
+#913 := (>= #910 0::int)
+#918 := (iff #913 #917)
+#919 := [rewrite]: #918
+#914 := (iff #908 #913)
+#911 := (= #907 #910)
+#912 := [rewrite]: #911
+#915 := [monotonicity #912]: #914
+#921 := [trans #915 #919]: #920
+#927 := [monotonicity #921 #924]: #926
+#932 := [monotonicity #927]: #931
+#935 := [trans #932 #934]: #931
+#930 := [quant-inst]: #929
+#936 := [mp #930 #935]: #928
+#1300 := [unit-resolution #936 #550]: #925
+#989 := (= #16 #803)
+#1277 := (= #803 #16)
+#280 := [asserted]: #75
+#287 := [mp #280 #284]: #281
+#1276 := [symm #287]: #75
+#1278 := [monotonicity #1276]: #1277
+#1301 := [symm #1278]: #989
+#1302 := (not #989)
+#1303 := (or #1302 #917)
+#1304 := [th-lemma]: #1303
+#1305 := [unit-resolution #1304 #1301]: #917
+#950 := (not #917)
+#949 := (not #925)
+#951 := (or #949 #950 #922)
+#952 := [def-axiom]: #951
+#1306 := [unit-resolution #952 #1305 #1300]: #922
+#937 := (not #922)
+#1307 := (or #937 #905)
+#938 := (not #281)
+#939 := (or #937 #938 #905)
+#940 := [def-axiom]: #939
+#1308 := [unit-resolution #940 #287]: #1307
+#1309 := [unit-resolution #1308 #1306]: #905
+#1356 := (= #799 #23)
+#800 := (= #23 #799)
+decl uf_15 :: T4
+#40 := uf_15
+#41 := (uf_5 uf_15)
+#814 := (+ #41 #813)
+#815 := (<= #814 0::int)
+#836 := (not #815)
+#158 := (* -1::int #41)
+#1270 := (+ #16 #158)
+#1265 := (>= #1270 0::int)
+#1339 := (not #1265)
+#1269 := (= #16 #41)
+#1298 := (not #1269)
+#286 := (= uf_7 uf_15)
+#44 := (uf_10 uf_15)
+#72 := (uf_6 #44)
+#73 := (= #72 uf_15)
+#277 := (= uf_15 #72)
+#278 := (iff #73 #277)
+#279 := [rewrite]: #278
+#276 := [asserted]: #73
+#282 := [mp #276 #279]: #277
+#1274 := [symm #282]: #73
+#729 := (= uf_7 #72)
+decl uf_17 :: (-> int T4)
+#611 := (uf_5 #72)
+#991 := (uf_17 #611)
+#1289 := (= #991 #72)
+#992 := (= #72 #991)
+#55 := (:var 0 T4)
+#56 := (uf_5 #55)
+#574 := (pattern #56)
+#57 := (uf_17 #56)
+#177 := (= #55 #57)
+#575 := (forall (vars (?x7 T4)) (:pat #574) #177)
+#195 := (forall (vars (?x7 T4)) #177)
+#578 := (iff #195 #575)
+#576 := (iff #177 #177)
+#577 := [refl]: #576
+#579 := [quant-intro #577]: #578
+#405 := (~ #195 #195)
+#403 := (~ #177 #177)
+#404 := [refl]: #403
+#406 := [nnf-pos #404]: #405
+#58 := (= #57 #55)
+#59 := (forall (vars (?x7 T4)) #58)
+#196 := (iff #59 #195)
+#193 := (iff #58 #177)
+#194 := [rewrite]: #193
+#197 := [quant-intro #194]: #196
+#155 := [asserted]: #59
+#200 := [mp #155 #197]: #195
+#407 := [mp~ #200 #406]: #195
+#580 := [mp #407 #579]: #575
+#995 := (not #575)
+#996 := (or #995 #992)
+#997 := [quant-inst]: #996
+#1273 := [unit-resolution #997 #580]: #992
+#1290 := [symm #1273]: #1289
+#1293 := (= uf_7 #991)
+#993 := (uf_17 #803)
+#1287 := (= #993 #991)
+#1284 := (= #803 #611)
+#987 := (= #41 #611)
+#1279 := (= #611 #41)
+#1280 := [monotonicity #1274]: #1279
+#1281 := [symm #1280]: #987
+#1282 := (= #803 #41)
+#1275 := [hypothesis]: #1269
+#1283 := [trans #1278 #1275]: #1282
+#1285 := [trans #1283 #1281]: #1284
+#1288 := [monotonicity #1285]: #1287
+#1291 := (= uf_7 #993)
+#994 := (= #74 #993)
+#1000 := (or #995 #994)
+#1001 := [quant-inst]: #1000
+#1286 := [unit-resolution #1001 #580]: #994
+#1292 := [trans #287 #1286]: #1291
+#1294 := [trans #1292 #1288]: #1293
+#1295 := [trans #1294 #1290]: #729
+#1296 := [trans #1295 #1274]: #286
+#290 := (not #286)
+#76 := (= uf_15 uf_7)
+#77 := (not #76)
+#291 := (iff #77 #290)
+#288 := (iff #76 #286)
+#289 := [rewrite]: #288
+#292 := [monotonicity #289]: #291
+#285 := [asserted]: #77
+#295 := [mp #285 #292]: #290
+#1297 := [unit-resolution #295 #1296]: false
+#1299 := [lemma #1297]: #1298
+#1342 := (or #1269 #1339)
+#1271 := (<= #1270 0::int)
+#621 := (* -1::int #611)
+#723 := (+ #16 #621)
+#724 := (<= #723 0::int)
+decl uf_12 :: T1
+#30 := uf_12
+#88 := (uf_2 uf_12)
+#771 := (uf_1 #88 #44)
+#45 := (uf_1 uf_9 #44)
+#772 := (= #45 #771)
+#796 := (not #772)
+decl uf_14 :: T1
+#38 := uf_14
+#83 := (uf_2 uf_14)
+#656 := (uf_1 #83 #44)
+#1239 := (= #656 #771)
+#1252 := (not #1239)
+#1324 := (iff #1252 #796)
+#1322 := (iff #1239 #772)
+#1320 := (= #656 #45)
+#661 := (= #45 #656)
+#659 := (uf_1 uf_11 #44)
+#664 := (= #656 #659)
+#667 := (ite #277 #661 #664)
+#657 := (uf_1 uf_8 #44)
+#670 := (= #656 #657)
+#622 := (+ #41 #621)
+#623 := (<= #622 0::int)
+#673 := (ite #623 #667 #670)
+#84 := (uf_1 #83 #6)
+#560 := (pattern #84)
+#467 := (= #19 #84)
+#465 := (= #25 #84)
+#464 := (= #45 #84)
+#43 := (= #13 uf_15)
+#466 := (ite #43 #464 #465)
+#159 := (+ #14 #158)
+#157 := (>= #159 0::int)
+#468 := (ite #157 #466 #467)
+#561 := (forall (vars (?x5 T2)) (:pat #541 #560 #543 #544) #468)
+#471 := (forall (vars (?x5 T2)) #468)
+#564 := (iff #471 #561)
+#562 := (iff #468 #468)
+#563 := [refl]: #562
+#565 := [quant-intro #563]: #564
+#46 := (ite #43 #45 #25)
+#165 := (ite #157 #46 #19)
+#378 := (= #84 #165)
+#379 := (forall (vars (?x5 T2)) #378)
+#472 := (iff #379 #471)
+#469 := (iff #378 #468)
+#470 := [rewrite]: #469
+#473 := [quant-intro #470]: #472
+#359 := (~ #379 #379)
+#361 := (~ #378 #378)
+#358 := [refl]: #361
+#356 := [nnf-pos #358]: #359
+#39 := (uf_3 uf_14 #6)
+#170 := (= #39 #165)
+#173 := (forall (vars (?x5 T2)) #170)
+#380 := (iff #173 #379)
+#381 := [rewrite* #113]: #380
+#42 := (< #14 #41)
+#47 := (ite #42 #19 #46)
+#48 := (= #39 #47)
+#49 := (forall (vars (?x5 T2)) #48)
+#174 := (iff #49 #173)
+#171 := (iff #48 #170)
+#168 := (= #47 #165)
+#156 := (not #157)
+#162 := (ite #156 #19 #46)
+#166 := (= #162 #165)
+#167 := [rewrite]: #166
+#163 := (= #47 #162)
+#160 := (iff #42 #156)
+#161 := [rewrite]: #160
+#164 := [monotonicity #161]: #163
+#169 := [trans #164 #167]: #168
+#172 := [monotonicity #169]: #171
+#175 := [quant-intro #172]: #174
+#116 := [asserted]: #49
+#176 := [mp #116 #175]: #173
+#382 := [mp #176 #381]: #379
+#357 := [mp~ #382 #356]: #379
+#474 := [mp #357 #473]: #471
+#566 := [mp #474 #565]: #561
+#676 := (not #561)
+#677 := (or #676 #673)
+#658 := (= #657 #656)
+#660 := (= #659 #656)
+#662 := (ite #73 #661 #660)
+#612 := (+ #611 #158)
+#613 := (>= #612 0::int)
+#663 := (ite #613 #662 #658)
+#678 := (or #676 #663)
+#680 := (iff #678 #677)
+#682 := (iff #677 #677)
+#683 := [rewrite]: #682
+#674 := (iff #663 #673)
+#671 := (iff #658 #670)
+#672 := [rewrite]: #671
+#668 := (iff #662 #667)
+#665 := (iff #660 #664)
+#666 := [rewrite]: #665
+#669 := [monotonicity #279 #666]: #668
+#626 := (iff #613 #623)
+#615 := (+ #158 #611)
+#618 := (>= #615 0::int)
+#624 := (iff #618 #623)
+#625 := [rewrite]: #624
+#619 := (iff #613 #618)
+#616 := (= #612 #615)
+#617 := [rewrite]: #616
+#620 := [monotonicity #617]: #619
+#627 := [trans #620 #625]: #626
+#675 := [monotonicity #627 #669 #672]: #674
+#681 := [monotonicity #675]: #680
+#684 := [trans #681 #683]: #680
+#679 := [quant-inst]: #678
+#685 := [mp #679 #684]: #677
+#1311 := [unit-resolution #685 #566]: #673
+#1312 := (not #987)
+#1313 := (or #1312 #623)
+#1314 := [th-lemma]: #1313
+#1315 := [unit-resolution #1314 #1281]: #623
+#645 := (not #623)
+#698 := (not #673)
+#699 := (or #698 #645 #667)
+#700 := [def-axiom]: #699
+#1316 := [unit-resolution #700 #1315 #1311]: #667
+#686 := (not #667)
+#1317 := (or #686 #661)
+#687 := (not #277)
+#688 := (or #686 #687 #661)
+#689 := [def-axiom]: #688
+#1318 := [unit-resolution #689 #282]: #1317
+#1319 := [unit-resolution #1318 #1316]: #661
+#1321 := [symm #1319]: #1320
+#1323 := [monotonicity #1321]: #1322
+#1325 := [monotonicity #1323]: #1324
+#1145 := (* -1::real #771)
+#1240 := (+ #656 #1145)
+#1241 := (<= #1240 0::real)
+#1249 := (not #1241)
+#1243 := [hypothesis]: #1241
+decl uf_18 :: T3
+#80 := uf_18
+#1040 := (uf_1 uf_18 #44)
+#1043 := (* -1::real #1040)
+#1156 := (+ #771 #1043)
+#1157 := (>= #1156 0::real)
+#1189 := (not #1157)
+#708 := (uf_1 #91 #44)
+#1168 := (+ #708 #1043)
+#1169 := (<= #1168 0::real)
+#1174 := (or #1157 #1169)
+#1177 := (not #1174)
+#89 := (uf_1 #88 #6)
+#552 := (pattern #89)
+#81 := (uf_1 uf_18 #6)
+#594 := (pattern #81)
+#324 := (* -1::real #92)
+#325 := (+ #81 #324)
+#323 := (>= #325 0::real)
+#317 := (* -1::real #89)
+#318 := (+ #81 #317)
+#319 := (<= #318 0::real)
+#436 := (or #319 #323)
+#437 := (not #436)
+#601 := (forall (vars (?x11 T2)) (:pat #594 #552 #542) #437)
+#440 := (forall (vars (?x11 T2)) #437)
+#604 := (iff #440 #601)
+#602 := (iff #437 #437)
+#603 := [refl]: #602
+#605 := [quant-intro #603]: #604
+#326 := (not #323)
+#320 := (not #319)
+#329 := (and #320 #326)
+#332 := (forall (vars (?x11 T2)) #329)
+#441 := (iff #332 #440)
+#438 := (iff #329 #437)
+#439 := [rewrite]: #438
+#442 := [quant-intro #439]: #441
+#425 := (~ #332 #332)
+#423 := (~ #329 #329)
+#424 := [refl]: #423
+#426 := [nnf-pos #424]: #425
+#306 := (* -1::real #84)
+#307 := (+ #81 #306)
+#305 := (>= #307 0::real)
+#308 := (not #305)
+#301 := (* -1::real #81)
+#79 := (uf_1 #78 #6)
+#302 := (+ #79 #301)
+#300 := (>= #302 0::real)
+#298 := (not #300)
+#311 := (and #298 #308)
+#314 := (forall (vars (?x10 T2)) #311)
+#335 := (and #314 #332)
+#93 := (< #81 #92)
+#90 := (< #89 #81)
+#94 := (and #90 #93)
+#95 := (forall (vars (?x11 T2)) #94)
+#85 := (< #81 #84)
+#82 := (< #79 #81)
+#86 := (and #82 #85)
+#87 := (forall (vars (?x10 T2)) #86)
+#96 := (and #87 #95)
+#336 := (iff #96 #335)
+#333 := (iff #95 #332)
+#330 := (iff #94 #329)
+#327 := (iff #93 #326)
+#328 := [rewrite]: #327
+#321 := (iff #90 #320)
+#322 := [rewrite]: #321
+#331 := [monotonicity #322 #328]: #330
+#334 := [quant-intro #331]: #333
+#315 := (iff #87 #314)
+#312 := (iff #86 #311)
+#309 := (iff #85 #308)
+#310 := [rewrite]: #309
+#303 := (iff #82 #298)
+#304 := [rewrite]: #303
+#313 := [monotonicity #304 #310]: #312
+#316 := [quant-intro #313]: #315
+#337 := [monotonicity #316 #334]: #336
+#293 := [asserted]: #96
+#338 := [mp #293 #337]: #335
+#340 := [and-elim #338]: #332
+#427 := [mp~ #340 #426]: #332
+#443 := [mp #427 #442]: #440
+#606 := [mp #443 #605]: #601
+#1124 := (not #601)
+#1180 := (or #1124 #1177)
+#1142 := (* -1::real #708)
+#1143 := (+ #1040 #1142)
+#1144 := (>= #1143 0::real)
+#1146 := (+ #1040 #1145)
+#1147 := (<= #1146 0::real)
+#1148 := (or #1147 #1144)
+#1149 := (not #1148)
+#1181 := (or #1124 #1149)
+#1183 := (iff #1181 #1180)
+#1185 := (iff #1180 #1180)
+#1186 := [rewrite]: #1185
+#1178 := (iff #1149 #1177)
+#1175 := (iff #1148 #1174)
+#1172 := (iff #1144 #1169)
+#1162 := (+ #1142 #1040)
+#1165 := (>= #1162 0::real)
+#1170 := (iff #1165 #1169)
+#1171 := [rewrite]: #1170
+#1166 := (iff #1144 #1165)
+#1163 := (= #1143 #1162)
+#1164 := [rewrite]: #1163
+#1167 := [monotonicity #1164]: #1166
+#1173 := [trans #1167 #1171]: #1172
+#1160 := (iff #1147 #1157)
+#1150 := (+ #1145 #1040)
+#1153 := (<= #1150 0::real)
+#1158 := (iff #1153 #1157)
+#1159 := [rewrite]: #1158
+#1154 := (iff #1147 #1153)
+#1151 := (= #1146 #1150)
+#1152 := [rewrite]: #1151
+#1155 := [monotonicity #1152]: #1154
+#1161 := [trans #1155 #1159]: #1160
+#1176 := [monotonicity #1161 #1173]: #1175
+#1179 := [monotonicity #1176]: #1178
+#1184 := [monotonicity #1179]: #1183
+#1187 := [trans #1184 #1186]: #1183
+#1182 := [quant-inst]: #1181
+#1188 := [mp #1182 #1187]: #1180
+#1244 := [unit-resolution #1188 #606]: #1177
+#1190 := (or #1174 #1189)
+#1191 := [def-axiom]: #1190
+#1245 := [unit-resolution #1191 #1244]: #1189
+#1054 := (+ #656 #1043)
+#1055 := (<= #1054 0::real)
+#1079 := (not #1055)
+#607 := (uf_1 #78 #44)
+#1044 := (+ #607 #1043)
+#1045 := (>= #1044 0::real)
+#1060 := (or #1045 #1055)
+#1063 := (not #1060)
+#567 := (pattern #79)
+#428 := (or #300 #305)
+#429 := (not #428)
+#595 := (forall (vars (?x10 T2)) (:pat #567 #594 #560) #429)
+#432 := (forall (vars (?x10 T2)) #429)
+#598 := (iff #432 #595)
+#596 := (iff #429 #429)
+#597 := [refl]: #596
+#599 := [quant-intro #597]: #598
+#433 := (iff #314 #432)
+#430 := (iff #311 #429)
+#431 := [rewrite]: #430
+#434 := [quant-intro #431]: #433
+#420 := (~ #314 #314)
+#418 := (~ #311 #311)
+#419 := [refl]: #418
+#421 := [nnf-pos #419]: #420
+#339 := [and-elim #338]: #314
+#422 := [mp~ #339 #421]: #314
+#435 := [mp #422 #434]: #432
+#600 := [mp #435 #599]: #595
+#1066 := (not #595)
+#1067 := (or #1066 #1063)
+#1039 := (* -1::real #656)
+#1041 := (+ #1040 #1039)
+#1042 := (>= #1041 0::real)
+#1046 := (or #1045 #1042)
+#1047 := (not #1046)
+#1068 := (or #1066 #1047)
+#1070 := (iff #1068 #1067)
+#1072 := (iff #1067 #1067)
+#1073 := [rewrite]: #1072
+#1064 := (iff #1047 #1063)
+#1061 := (iff #1046 #1060)
+#1058 := (iff #1042 #1055)
+#1048 := (+ #1039 #1040)
+#1051 := (>= #1048 0::real)
+#1056 := (iff #1051 #1055)
+#1057 := [rewrite]: #1056
+#1052 := (iff #1042 #1051)
+#1049 := (= #1041 #1048)
+#1050 := [rewrite]: #1049
+#1053 := [monotonicity #1050]: #1052
+#1059 := [trans #1053 #1057]: #1058
+#1062 := [monotonicity #1059]: #1061
+#1065 := [monotonicity #1062]: #1064
+#1071 := [monotonicity #1065]: #1070
+#1074 := [trans #1071 #1073]: #1070
+#1069 := [quant-inst]: #1068
+#1075 := [mp #1069 #1074]: #1067
+#1246 := [unit-resolution #1075 #600]: #1063
+#1080 := (or #1060 #1079)
+#1081 := [def-axiom]: #1080
+#1247 := [unit-resolution #1081 #1246]: #1079
+#1248 := [th-lemma #1247 #1245 #1243]: false
+#1250 := [lemma #1248]: #1249
+#1253 := (or #1252 #1241)
+#1254 := [th-lemma]: #1253
+#1310 := [unit-resolution #1254 #1250]: #1252
+#1326 := [mp #1310 #1325]: #796
+#1328 := (or #724 #772)
+decl uf_13 :: T3
+#33 := uf_13
+#609 := (uf_1 uf_13 #44)
+#773 := (= #609 #771)
+#775 := (ite #724 #773 #772)
+#32 := (uf_1 uf_9 #6)
+#553 := (pattern #32)
+#34 := (uf_1 uf_13 #6)
+#551 := (pattern #34)
+#456 := (= #32 #89)
+#455 := (= #34 #89)
+#457 := (ite #119 #455 #456)
+#554 := (forall (vars (?x4 T2)) (:pat #541 #551 #552 #553) #457)
+#460 := (forall (vars (?x4 T2)) #457)
+#557 := (iff #460 #554)
+#555 := (iff #457 #457)
+#556 := [refl]: #555
+#558 := [quant-intro #556]: #557
+#143 := (ite #119 #34 #32)
+#373 := (= #89 #143)
+#374 := (forall (vars (?x4 T2)) #373)
+#461 := (iff #374 #460)
+#458 := (iff #373 #457)
+#459 := [rewrite]: #458
+#462 := [quant-intro #459]: #461
+#362 := (~ #374 #374)
+#364 := (~ #373 #373)
+#365 := [refl]: #364
+#363 := [nnf-pos #365]: #362
+#31 := (uf_3 uf_12 #6)
+#148 := (= #31 #143)
+#151 := (forall (vars (?x4 T2)) #148)
+#375 := (iff #151 #374)
+#376 := [rewrite* #113]: #375
+#35 := (ite #17 #32 #34)
+#36 := (= #31 #35)
+#37 := (forall (vars (?x4 T2)) #36)
+#152 := (iff #37 #151)
+#149 := (iff #36 #148)
+#146 := (= #35 #143)
+#140 := (ite #118 #32 #34)
+#144 := (= #140 #143)
+#145 := [rewrite]: #144
+#141 := (= #35 #140)
+#142 := [monotonicity #123]: #141
+#147 := [trans #142 #145]: #146
+#150 := [monotonicity #147]: #149
+#153 := [quant-intro #150]: #152
+#115 := [asserted]: #37
+#154 := [mp #115 #153]: #151
+#377 := [mp #154 #376]: #374
+#360 := [mp~ #377 #363]: #374
+#463 := [mp #360 #462]: #460
+#559 := [mp #463 #558]: #554
+#778 := (not #554)
+#779 := (or #778 #775)
+#714 := (+ #611 #120)
+#715 := (>= #714 0::int)
+#774 := (ite #715 #773 #772)
+#780 := (or #778 #774)
+#782 := (iff #780 #779)
+#784 := (iff #779 #779)
+#785 := [rewrite]: #784
+#776 := (iff #774 #775)
+#727 := (iff #715 #724)
+#717 := (+ #120 #611)
+#720 := (>= #717 0::int)
+#725 := (iff #720 #724)
+#726 := [rewrite]: #725
+#721 := (iff #715 #720)
+#718 := (= #714 #717)
+#719 := [rewrite]: #718
+#722 := [monotonicity #719]: #721
+#728 := [trans #722 #726]: #727
+#777 := [monotonicity #728]: #776
+#783 := [monotonicity #777]: #782
+#786 := [trans #783 #785]: #782
+#781 := [quant-inst]: #780
+#787 := [mp #781 #786]: #779
+#1327 := [unit-resolution #787 #559]: #775
+#788 := (not #775)
+#791 := (or #788 #724 #772)
+#792 := [def-axiom]: #791
+#1329 := [unit-resolution #792 #1327]: #1328
+#1330 := [unit-resolution #1329 #1326]: #724
+#988 := (>= #622 0::int)
+#1331 := (or #1312 #988)
+#1332 := [th-lemma]: #1331
+#1333 := [unit-resolution #1332 #1281]: #988
+#761 := (not #724)
+#1334 := (not #988)
+#1335 := (or #1271 #1334 #761)
+#1336 := [th-lemma]: #1335
+#1337 := [unit-resolution #1336 #1333 #1330]: #1271
+#1338 := (not #1271)
+#1340 := (or #1269 #1338 #1339)
+#1341 := [th-lemma]: #1340
+#1343 := [unit-resolution #1341 #1337]: #1342
+#1344 := [unit-resolution #1343 #1299]: #1339
+#990 := (>= #916 0::int)
+#1345 := (or #1302 #990)
+#1346 := [th-lemma]: #1345
+#1347 := [unit-resolution #1346 #1301]: #990
+#1348 := (not #990)
+#1349 := (or #836 #1348 #1265)
+#1350 := [th-lemma]: #1349
+#1351 := [unit-resolution #1350 #1347 #1344]: #836
+#1353 := (or #815 #800)
+#801 := (uf_1 uf_13 #22)
+#820 := (= #799 #801)
+#823 := (ite #815 #820 #800)
+#476 := (= #32 #79)
+#475 := (= #34 #79)
+#477 := (ite #157 #475 #476)
+#568 := (forall (vars (?x6 T2)) (:pat #541 #551 #567 #553) #477)
+#480 := (forall (vars (?x6 T2)) #477)
+#571 := (iff #480 #568)
+#569 := (iff #477 #477)
+#570 := [refl]: #569
+#572 := [quant-intro #570]: #571
+#181 := (ite #157 #34 #32)
+#383 := (= #79 #181)
+#384 := (forall (vars (?x6 T2)) #383)
+#481 := (iff #384 #480)
+#478 := (iff #383 #477)
+#479 := [rewrite]: #478
+#482 := [quant-intro #479]: #481
+#352 := (~ #384 #384)
+#354 := (~ #383 #383)
+#355 := [refl]: #354
+#353 := [nnf-pos #355]: #352
+#51 := (uf_3 uf_16 #6)
+#186 := (= #51 #181)
+#189 := (forall (vars (?x6 T2)) #186)
+#385 := (iff #189 #384)
+#386 := [rewrite* #113]: #385
+#52 := (ite #42 #32 #34)
+#53 := (= #51 #52)
+#54 := (forall (vars (?x6 T2)) #53)
+#190 := (iff #54 #189)
+#187 := (iff #53 #186)
+#184 := (= #52 #181)
+#178 := (ite #156 #32 #34)
+#182 := (= #178 #181)
+#183 := [rewrite]: #182
+#179 := (= #52 #178)
+#180 := [monotonicity #161]: #179
+#185 := [trans #180 #183]: #184
+#188 := [monotonicity #185]: #187
+#191 := [quant-intro #188]: #190
+#139 := [asserted]: #54
+#192 := [mp #139 #191]: #189
+#387 := [mp #192 #386]: #384
+#402 := [mp~ #387 #353]: #384
+#483 := [mp #402 #482]: #480
+#573 := [mp #483 #572]: #568
+#634 := (not #568)
+#826 := (or #634 #823)
+#802 := (= #801 #799)
+#804 := (+ #803 #158)
+#805 := (>= #804 0::int)
+#806 := (ite #805 #802 #800)
+#827 := (or #634 #806)
+#829 := (iff #827 #826)
+#831 := (iff #826 #826)
+#832 := [rewrite]: #831
+#824 := (iff #806 #823)
+#821 := (iff #802 #820)
+#822 := [rewrite]: #821
+#818 := (iff #805 #815)
+#807 := (+ #158 #803)
+#810 := (>= #807 0::int)
+#816 := (iff #810 #815)
+#817 := [rewrite]: #816
+#811 := (iff #805 #810)
+#808 := (= #804 #807)
+#809 := [rewrite]: #808
+#812 := [monotonicity #809]: #811
+#819 := [trans #812 #817]: #818
+#825 := [monotonicity #819 #822]: #824
+#830 := [monotonicity #825]: #829
+#833 := [trans #830 #832]: #829
+#828 := [quant-inst]: #827
+#834 := [mp #828 #833]: #826
+#1352 := [unit-resolution #834 #573]: #823
+#835 := (not #823)
+#839 := (or #835 #815 #800)
+#840 := [def-axiom]: #839
+#1354 := [unit-resolution #840 #1352]: #1353
+#1355 := [unit-resolution #1354 #1351]: #800
+#1357 := [symm #1355]: #1356
+#1358 := [trans #1357 #1309]: #1266
+#1359 := (not #1266)
+#1360 := (or #1359 #1272)
+#1361 := [th-lemma]: #1360
+#1362 := [unit-resolution #1361 #1358]: #1272
+#1085 := (uf_1 uf_18 #22)
+#1099 := (* -1::real #1085)
+#1112 := (+ #902 #1099)
+#1113 := (<= #1112 0::real)
+#1137 := (not #1113)
+#960 := (uf_1 #88 #22)
+#1100 := (+ #960 #1099)
+#1101 := (>= #1100 0::real)
+#1118 := (or #1101 #1113)
+#1121 := (not #1118)
+#1125 := (or #1124 #1121)
+#1086 := (+ #1085 #1084)
+#1087 := (>= #1086 0::real)
+#1088 := (* -1::real #960)
+#1089 := (+ #1085 #1088)
+#1090 := (<= #1089 0::real)
+#1091 := (or #1090 #1087)
+#1092 := (not #1091)
+#1126 := (or #1124 #1092)
+#1128 := (iff #1126 #1125)
+#1130 := (iff #1125 #1125)
+#1131 := [rewrite]: #1130
+#1122 := (iff #1092 #1121)
+#1119 := (iff #1091 #1118)
+#1116 := (iff #1087 #1113)
+#1106 := (+ #1084 #1085)
+#1109 := (>= #1106 0::real)
+#1114 := (iff #1109 #1113)
+#1115 := [rewrite]: #1114
+#1110 := (iff #1087 #1109)
+#1107 := (= #1086 #1106)
+#1108 := [rewrite]: #1107
+#1111 := [monotonicity #1108]: #1110
+#1117 := [trans #1111 #1115]: #1116
+#1104 := (iff #1090 #1101)
+#1093 := (+ #1088 #1085)
+#1096 := (<= #1093 0::real)
+#1102 := (iff #1096 #1101)
+#1103 := [rewrite]: #1102
+#1097 := (iff #1090 #1096)
+#1094 := (= #1089 #1093)
+#1095 := [rewrite]: #1094
+#1098 := [monotonicity #1095]: #1097
+#1105 := [trans #1098 #1103]: #1104
+#1120 := [monotonicity #1105 #1117]: #1119
+#1123 := [monotonicity #1120]: #1122
+#1129 := [monotonicity #1123]: #1128
+#1132 := [trans #1129 #1131]: #1128
+#1127 := [quant-inst]: #1126
+#1133 := [mp #1127 #1132]: #1125
+#1363 := [unit-resolution #1133 #606]: #1121
+#1138 := (or #1118 #1137)
+#1139 := [def-axiom]: #1138
+#1364 := [unit-resolution #1139 #1363]: #1137
+#1200 := (+ #799 #1099)
+#1201 := (>= #1200 0::real)
+#1231 := (not #1201)
+#847 := (uf_1 #83 #22)
+#1210 := (+ #847 #1099)
+#1211 := (<= #1210 0::real)
+#1216 := (or #1201 #1211)
+#1219 := (not #1216)
+#1222 := (or #1066 #1219)
+#1197 := (* -1::real #847)
+#1198 := (+ #1085 #1197)
+#1199 := (>= #1198 0::real)
+#1202 := (or #1201 #1199)
+#1203 := (not #1202)
+#1223 := (or #1066 #1203)
+#1225 := (iff #1223 #1222)
+#1227 := (iff #1222 #1222)
+#1228 := [rewrite]: #1227
+#1220 := (iff #1203 #1219)
+#1217 := (iff #1202 #1216)
+#1214 := (iff #1199 #1211)
+#1204 := (+ #1197 #1085)
+#1207 := (>= #1204 0::real)
+#1212 := (iff #1207 #1211)
+#1213 := [rewrite]: #1212
+#1208 := (iff #1199 #1207)
+#1205 := (= #1198 #1204)
+#1206 := [rewrite]: #1205
+#1209 := [monotonicity #1206]: #1208
+#1215 := [trans #1209 #1213]: #1214
+#1218 := [monotonicity #1215]: #1217
+#1221 := [monotonicity #1218]: #1220
+#1226 := [monotonicity #1221]: #1225
+#1229 := [trans #1226 #1228]: #1225
+#1224 := [quant-inst]: #1223
+#1230 := [mp #1224 #1229]: #1222
+#1365 := [unit-resolution #1230 #600]: #1219
+#1232 := (or #1216 #1231)
+#1233 := [def-axiom]: #1232
+#1366 := [unit-resolution #1233 #1365]: #1231
+[th-lemma #1366 #1364 #1362]: false
+unsat
+NQHwTeL311Tq3wf2s5BReA 419 0
+#2 := false
+#194 := 0::real
+decl uf_4 :: (-> T2 T3 real)
+decl uf_6 :: (-> T1 T3)
+decl uf_3 :: T1
+#21 := uf_3
+#25 := (uf_6 uf_3)
+decl uf_5 :: T2
+#24 := uf_5
+#26 := (uf_4 uf_5 #25)
+decl uf_7 :: T2
+#27 := uf_7
+#28 := (uf_4 uf_7 #25)
+decl uf_10 :: T1
+#38 := uf_10
+#42 := (uf_6 uf_10)
+decl uf_9 :: T2
+#33 := uf_9
+#43 := (uf_4 uf_9 #42)
+#41 := (= uf_3 uf_10)
+#44 := (ite #41 #43 #28)
+#9 := 0::int
+decl uf_2 :: (-> T1 int)
+#39 := (uf_2 uf_10)
+#226 := -1::int
+#229 := (* -1::int #39)
+#22 := (uf_2 uf_3)
+#230 := (+ #22 #229)
+#228 := (>= #230 0::int)
+#236 := (ite #228 #44 #26)
+#192 := -1::real
+#244 := (* -1::real #236)
+#642 := (+ #26 #244)
+#643 := (<= #642 0::real)
+#567 := (= #26 #236)
+#227 := (not #228)
+decl uf_1 :: (-> int T1)
+#593 := (uf_1 #39)
+#660 := (= #593 uf_10)
+#594 := (= uf_10 #593)
+#4 := (:var 0 T1)
+#5 := (uf_2 #4)
+#546 := (pattern #5)
+#6 := (uf_1 #5)
+#93 := (= #4 #6)
+#547 := (forall (vars (?x1 T1)) (:pat #546) #93)
+#96 := (forall (vars (?x1 T1)) #93)
+#550 := (iff #96 #547)
+#548 := (iff #93 #93)
+#549 := [refl]: #548
+#551 := [quant-intro #549]: #550
+#448 := (~ #96 #96)
+#450 := (~ #93 #93)
+#451 := [refl]: #450
+#449 := [nnf-pos #451]: #448
+#7 := (= #6 #4)
+#8 := (forall (vars (?x1 T1)) #7)
+#97 := (iff #8 #96)
+#94 := (iff #7 #93)
+#95 := [rewrite]: #94
+#98 := [quant-intro #95]: #97
+#92 := [asserted]: #8
+#101 := [mp #92 #98]: #96
+#446 := [mp~ #101 #449]: #96
+#552 := [mp #446 #551]: #547
+#595 := (not #547)
+#600 := (or #595 #594)
+#601 := [quant-inst]: #600
+#654 := [unit-resolution #601 #552]: #594
+#680 := [symm #654]: #660
+#681 := (= uf_3 #593)
+#591 := (uf_1 #22)
+#658 := (= #591 #593)
+#656 := (= #593 #591)
+#652 := (= #39 #22)
+#647 := (= #22 #39)
+#290 := (<= #230 0::int)
+#70 := (<= #22 #39)
+#388 := (iff #70 #290)
+#389 := [rewrite]: #388
+#341 := [asserted]: #70
+#390 := [mp #341 #389]: #290
+#646 := [hypothesis]: #228
+#648 := [th-lemma #646 #390]: #647
+#653 := [symm #648]: #652
+#657 := [monotonicity #653]: #656
+#659 := [symm #657]: #658
+#592 := (= uf_3 #591)
+#596 := (or #595 #592)
+#597 := [quant-inst]: #596
+#655 := [unit-resolution #597 #552]: #592
+#682 := [trans #655 #659]: #681
+#683 := [trans #682 #680]: #41
+#570 := (not #41)
+decl uf_11 :: T2
+#47 := uf_11
+#59 := (uf_4 uf_11 #42)
+#278 := (ite #41 #26 #59)
+#459 := (* -1::real #278)
+#637 := (+ #26 #459)
+#639 := (>= #637 0::real)
+#585 := (= #26 #278)
+#661 := [hypothesis]: #41
+#587 := (or #570 #585)
+#588 := [def-axiom]: #587
+#662 := [unit-resolution #588 #661]: #585
+#663 := (not #585)
+#664 := (or #663 #639)
+#665 := [th-lemma]: #664
+#666 := [unit-resolution #665 #662]: #639
+decl uf_8 :: T2
+#30 := uf_8
+#56 := (uf_4 uf_8 #42)
+#357 := (* -1::real #56)
+#358 := (+ #43 #357)
+#356 := (>= #358 0::real)
+#355 := (not #356)
+#374 := (* -1::real #59)
+#375 := (+ #56 #374)
+#373 := (>= #375 0::real)
+#376 := (not #373)
+#381 := (and #355 #376)
+#64 := (< #39 #39)
+#67 := (ite #64 #43 #59)
+#68 := (< #56 #67)
+#53 := (uf_4 uf_5 #42)
+#65 := (ite #64 #53 #43)
+#66 := (< #65 #56)
+#69 := (and #66 #68)
+#382 := (iff #69 #381)
+#379 := (iff #68 #376)
+#370 := (< #56 #59)
+#377 := (iff #370 #376)
+#378 := [rewrite]: #377
+#371 := (iff #68 #370)
+#368 := (= #67 #59)
+#363 := (ite false #43 #59)
+#366 := (= #363 #59)
+#367 := [rewrite]: #366
+#364 := (= #67 #363)
+#343 := (iff #64 false)
+#344 := [rewrite]: #343
+#365 := [monotonicity #344]: #364
+#369 := [trans #365 #367]: #368
+#372 := [monotonicity #369]: #371
+#380 := [trans #372 #378]: #379
+#361 := (iff #66 #355)
+#352 := (< #43 #56)
+#359 := (iff #352 #355)
+#360 := [rewrite]: #359
+#353 := (iff #66 #352)
+#350 := (= #65 #43)
+#345 := (ite false #53 #43)
+#348 := (= #345 #43)
+#349 := [rewrite]: #348
+#346 := (= #65 #345)
+#347 := [monotonicity #344]: #346
+#351 := [trans #347 #349]: #350
+#354 := [monotonicity #351]: #353
+#362 := [trans #354 #360]: #361
+#383 := [monotonicity #362 #380]: #382
+#340 := [asserted]: #69
+#384 := [mp #340 #383]: #381
+#385 := [and-elim #384]: #355
+#394 := (* -1::real #53)
+#395 := (+ #43 #394)
+#393 := (>= #395 0::real)
+#54 := (uf_4 uf_7 #42)
+#402 := (* -1::real #54)
+#403 := (+ #53 #402)
+#401 := (>= #403 0::real)
+#397 := (+ #43 #374)
+#398 := (<= #397 0::real)
+#412 := (and #393 #398 #401)
+#73 := (<= #43 #59)
+#72 := (<= #53 #43)
+#74 := (and #72 #73)
+#71 := (<= #54 #53)
+#75 := (and #71 #74)
+#415 := (iff #75 #412)
+#406 := (and #393 #398)
+#409 := (and #401 #406)
+#413 := (iff #409 #412)
+#414 := [rewrite]: #413
+#410 := (iff #75 #409)
+#407 := (iff #74 #406)
+#399 := (iff #73 #398)
+#400 := [rewrite]: #399
+#392 := (iff #72 #393)
+#396 := [rewrite]: #392
+#408 := [monotonicity #396 #400]: #407
+#404 := (iff #71 #401)
+#405 := [rewrite]: #404
+#411 := [monotonicity #405 #408]: #410
+#416 := [trans #411 #414]: #415
+#342 := [asserted]: #75
+#417 := [mp #342 #416]: #412
+#418 := [and-elim #417]: #393
+#650 := (+ #26 #394)
+#651 := (<= #650 0::real)
+#649 := (= #26 #53)
+#671 := (= #53 #26)
+#669 := (= #42 #25)
+#667 := (= #25 #42)
+#668 := [monotonicity #661]: #667
+#670 := [symm #668]: #669
+#672 := [monotonicity #670]: #671
+#673 := [symm #672]: #649
+#674 := (not #649)
+#675 := (or #674 #651)
+#676 := [th-lemma]: #675
+#677 := [unit-resolution #676 #673]: #651
+#462 := (+ #56 #459)
+#465 := (>= #462 0::real)
+#438 := (not #465)
+#316 := (ite #290 #278 #43)
+#326 := (* -1::real #316)
+#327 := (+ #56 #326)
+#325 := (>= #327 0::real)
+#324 := (not #325)
+#439 := (iff #324 #438)
+#466 := (iff #325 #465)
+#463 := (= #327 #462)
+#460 := (= #326 #459)
+#457 := (= #316 #278)
+#1 := true
+#452 := (ite true #278 #43)
+#455 := (= #452 #278)
+#456 := [rewrite]: #455
+#453 := (= #316 #452)
+#444 := (iff #290 true)
+#445 := [iff-true #390]: #444
+#454 := [monotonicity #445]: #453
+#458 := [trans #454 #456]: #457
+#461 := [monotonicity #458]: #460
+#464 := [monotonicity #461]: #463
+#467 := [monotonicity #464]: #466
+#468 := [monotonicity #467]: #439
+#297 := (ite #290 #54 #53)
+#305 := (* -1::real #297)
+#306 := (+ #56 #305)
+#307 := (<= #306 0::real)
+#308 := (not #307)
+#332 := (and #308 #324)
+#58 := (= uf_10 uf_3)
+#60 := (ite #58 #26 #59)
+#52 := (< #39 #22)
+#61 := (ite #52 #43 #60)
+#62 := (< #56 #61)
+#55 := (ite #52 #53 #54)
+#57 := (< #55 #56)
+#63 := (and #57 #62)
+#335 := (iff #63 #332)
+#281 := (ite #52 #43 #278)
+#284 := (< #56 #281)
+#287 := (and #57 #284)
+#333 := (iff #287 #332)
+#330 := (iff #284 #324)
+#321 := (< #56 #316)
+#328 := (iff #321 #324)
+#329 := [rewrite]: #328
+#322 := (iff #284 #321)
+#319 := (= #281 #316)
+#291 := (not #290)
+#313 := (ite #291 #43 #278)
+#317 := (= #313 #316)
+#318 := [rewrite]: #317
+#314 := (= #281 #313)
+#292 := (iff #52 #291)
+#293 := [rewrite]: #292
+#315 := [monotonicity #293]: #314
+#320 := [trans #315 #318]: #319
+#323 := [monotonicity #320]: #322
+#331 := [trans #323 #329]: #330
+#311 := (iff #57 #308)
+#302 := (< #297 #56)
+#309 := (iff #302 #308)
+#310 := [rewrite]: #309
+#303 := (iff #57 #302)
+#300 := (= #55 #297)
+#294 := (ite #291 #53 #54)
+#298 := (= #294 #297)
+#299 := [rewrite]: #298
+#295 := (= #55 #294)
+#296 := [monotonicity #293]: #295
+#301 := [trans #296 #299]: #300
+#304 := [monotonicity #301]: #303
+#312 := [trans #304 #310]: #311
+#334 := [monotonicity #312 #331]: #333
+#288 := (iff #63 #287)
+#285 := (iff #62 #284)
+#282 := (= #61 #281)
+#279 := (= #60 #278)
+#225 := (iff #58 #41)
+#277 := [rewrite]: #225
+#280 := [monotonicity #277]: #279
+#283 := [monotonicity #280]: #282
+#286 := [monotonicity #283]: #285
+#289 := [monotonicity #286]: #288
+#336 := [trans #289 #334]: #335
+#179 := [asserted]: #63
+#337 := [mp #179 #336]: #332
+#339 := [and-elim #337]: #324
+#469 := [mp #339 #468]: #438
+#678 := [th-lemma #469 #677 #418 #385 #666]: false
+#679 := [lemma #678]: #570
+#684 := [unit-resolution #679 #683]: false
+#685 := [lemma #684]: #227
+#577 := (or #228 #567)
+#578 := [def-axiom]: #577
+#645 := [unit-resolution #578 #685]: #567
+#686 := (not #567)
+#687 := (or #686 #643)
+#688 := [th-lemma]: #687
+#689 := [unit-resolution #688 #645]: #643
+#31 := (uf_4 uf_8 #25)
+#245 := (+ #31 #244)
+#246 := (<= #245 0::real)
+#247 := (not #246)
+#34 := (uf_4 uf_9 #25)
+#48 := (uf_4 uf_11 #25)
+#255 := (ite #228 #48 #34)
+#264 := (* -1::real #255)
+#265 := (+ #31 #264)
+#263 := (>= #265 0::real)
+#266 := (not #263)
+#271 := (and #247 #266)
+#40 := (< #22 #39)
+#49 := (ite #40 #34 #48)
+#50 := (< #31 #49)
+#45 := (ite #40 #26 #44)
+#46 := (< #45 #31)
+#51 := (and #46 #50)
+#272 := (iff #51 #271)
+#269 := (iff #50 #266)
+#260 := (< #31 #255)
+#267 := (iff #260 #266)
+#268 := [rewrite]: #267
+#261 := (iff #50 #260)
+#258 := (= #49 #255)
+#252 := (ite #227 #34 #48)
+#256 := (= #252 #255)
+#257 := [rewrite]: #256
+#253 := (= #49 #252)
+#231 := (iff #40 #227)
+#232 := [rewrite]: #231
+#254 := [monotonicity #232]: #253
+#259 := [trans #254 #257]: #258
+#262 := [monotonicity #259]: #261
+#270 := [trans #262 #268]: #269
+#250 := (iff #46 #247)
+#241 := (< #236 #31)
+#248 := (iff #241 #247)
+#249 := [rewrite]: #248
+#242 := (iff #46 #241)
+#239 := (= #45 #236)
+#233 := (ite #227 #26 #44)
+#237 := (= #233 #236)
+#238 := [rewrite]: #237
+#234 := (= #45 #233)
+#235 := [monotonicity #232]: #234
+#240 := [trans #235 #238]: #239
+#243 := [monotonicity #240]: #242
+#251 := [trans #243 #249]: #250
+#273 := [monotonicity #251 #270]: #272
+#178 := [asserted]: #51
+#274 := [mp #178 #273]: #271
+#275 := [and-elim #274]: #247
+#196 := (* -1::real #31)
+#212 := (+ #26 #196)
+#213 := (<= #212 0::real)
+#214 := (not #213)
+#197 := (+ #28 #196)
+#195 := (>= #197 0::real)
+#193 := (not #195)
+#219 := (and #193 #214)
+#23 := (< #22 #22)
+#35 := (ite #23 #34 #26)
+#36 := (< #31 #35)
+#29 := (ite #23 #26 #28)
+#32 := (< #29 #31)
+#37 := (and #32 #36)
+#220 := (iff #37 #219)
+#217 := (iff #36 #214)
+#209 := (< #31 #26)
+#215 := (iff #209 #214)
+#216 := [rewrite]: #215
+#210 := (iff #36 #209)
+#207 := (= #35 #26)
+#202 := (ite false #34 #26)
+#205 := (= #202 #26)
+#206 := [rewrite]: #205
+#203 := (= #35 #202)
+#180 := (iff #23 false)
+#181 := [rewrite]: #180
+#204 := [monotonicity #181]: #203
+#208 := [trans #204 #206]: #207
+#211 := [monotonicity #208]: #210
+#218 := [trans #211 #216]: #217
+#200 := (iff #32 #193)
+#189 := (< #28 #31)
+#198 := (iff #189 #193)
+#199 := [rewrite]: #198
+#190 := (iff #32 #189)
+#187 := (= #29 #28)
+#182 := (ite false #26 #28)
+#185 := (= #182 #28)
+#186 := [rewrite]: #185
+#183 := (= #29 #182)
+#184 := [monotonicity #181]: #183
+#188 := [trans #184 #186]: #187
+#191 := [monotonicity #188]: #190
+#201 := [trans #191 #199]: #200
+#221 := [monotonicity #201 #218]: #220
+#177 := [asserted]: #37
+#222 := [mp #177 #221]: #219
+#224 := [and-elim #222]: #214
+[th-lemma #224 #275 #689]: false
+unsat
+NX/HT1QOfbspC2LtZNKpBA 428 0
+#2 := false
+decl uf_10 :: T1
+#38 := uf_10
+decl uf_3 :: T1
+#21 := uf_3
+#45 := (= uf_3 uf_10)
+decl uf_1 :: (-> int T1)
+decl uf_2 :: (-> T1 int)
+#39 := (uf_2 uf_10)
+#588 := (uf_1 #39)
+#686 := (= #588 uf_10)
+#589 := (= uf_10 #588)
+#4 := (:var 0 T1)
+#5 := (uf_2 #4)
+#541 := (pattern #5)
+#6 := (uf_1 #5)
+#93 := (= #4 #6)
+#542 := (forall (vars (?x1 T1)) (:pat #541) #93)
+#96 := (forall (vars (?x1 T1)) #93)
+#545 := (iff #96 #542)
+#543 := (iff #93 #93)
+#544 := [refl]: #543
+#546 := [quant-intro #544]: #545
+#454 := (~ #96 #96)
+#456 := (~ #93 #93)
+#457 := [refl]: #456
+#455 := [nnf-pos #457]: #454
+#7 := (= #6 #4)
+#8 := (forall (vars (?x1 T1)) #7)
+#97 := (iff #8 #96)
+#94 := (iff #7 #93)
+#95 := [rewrite]: #94
+#98 := [quant-intro #95]: #97
+#92 := [asserted]: #8
+#101 := [mp #92 #98]: #96
+#452 := [mp~ #101 #455]: #96
+#547 := [mp #452 #546]: #542
+#590 := (not #542)
+#595 := (or #590 #589)
+#596 := [quant-inst]: #595
+#680 := [unit-resolution #596 #547]: #589
+#687 := [symm #680]: #686
+#688 := (= uf_3 #588)
+#22 := (uf_2 uf_3)
+#586 := (uf_1 #22)
+#684 := (= #586 #588)
+#682 := (= #588 #586)
+#678 := (= #39 #22)
+#676 := (= #22 #39)
+#9 := 0::int
+#227 := -1::int
+#230 := (* -1::int #39)
+#231 := (+ #22 #230)
+#296 := (<= #231 0::int)
+#70 := (<= #22 #39)
+#393 := (iff #70 #296)
+#394 := [rewrite]: #393
+#347 := [asserted]: #70
+#395 := [mp #347 #394]: #296
+#229 := (>= #231 0::int)
+decl uf_4 :: (-> T2 T3 real)
+decl uf_6 :: (-> T1 T3)
+#25 := (uf_6 uf_3)
+decl uf_7 :: T2
+#27 := uf_7
+#28 := (uf_4 uf_7 #25)
+decl uf_9 :: T2
+#33 := uf_9
+#34 := (uf_4 uf_9 #25)
+#46 := (uf_6 uf_10)
+decl uf_5 :: T2
+#24 := uf_5
+#47 := (uf_4 uf_5 #46)
+#48 := (ite #45 #47 #34)
+#256 := (ite #229 #48 #28)
+#568 := (= #28 #256)
+#648 := (not #568)
+#194 := 0::real
+#192 := -1::real
+#265 := (* -1::real #256)
+#640 := (+ #28 #265)
+#642 := (>= #640 0::real)
+#645 := (not #642)
+#643 := [hypothesis]: #642
+decl uf_8 :: T2
+#30 := uf_8
+#31 := (uf_4 uf_8 #25)
+#266 := (+ #31 #265)
+#264 := (>= #266 0::real)
+#267 := (not #264)
+#26 := (uf_4 uf_5 #25)
+decl uf_11 :: T2
+#41 := uf_11
+#42 := (uf_4 uf_11 #25)
+#237 := (ite #229 #42 #26)
+#245 := (* -1::real #237)
+#246 := (+ #31 #245)
+#247 := (<= #246 0::real)
+#248 := (not #247)
+#272 := (and #248 #267)
+#40 := (< #22 #39)
+#49 := (ite #40 #28 #48)
+#50 := (< #31 #49)
+#43 := (ite #40 #26 #42)
+#44 := (< #43 #31)
+#51 := (and #44 #50)
+#273 := (iff #51 #272)
+#270 := (iff #50 #267)
+#261 := (< #31 #256)
+#268 := (iff #261 #267)
+#269 := [rewrite]: #268
+#262 := (iff #50 #261)
+#259 := (= #49 #256)
+#228 := (not #229)
+#253 := (ite #228 #28 #48)
+#257 := (= #253 #256)
+#258 := [rewrite]: #257
+#254 := (= #49 #253)
+#232 := (iff #40 #228)
+#233 := [rewrite]: #232
+#255 := [monotonicity #233]: #254
+#260 := [trans #255 #258]: #259
+#263 := [monotonicity #260]: #262
+#271 := [trans #263 #269]: #270
+#251 := (iff #44 #248)
+#242 := (< #237 #31)
+#249 := (iff #242 #248)
+#250 := [rewrite]: #249
+#243 := (iff #44 #242)
+#240 := (= #43 #237)
+#234 := (ite #228 #26 #42)
+#238 := (= #234 #237)
+#239 := [rewrite]: #238
+#235 := (= #43 #234)
+#236 := [monotonicity #233]: #235
+#241 := [trans #236 #239]: #240
+#244 := [monotonicity #241]: #243
+#252 := [trans #244 #250]: #251
+#274 := [monotonicity #252 #271]: #273
+#178 := [asserted]: #51
+#275 := [mp #178 #274]: #272
+#277 := [and-elim #275]: #267
+#196 := (* -1::real #31)
+#197 := (+ #28 #196)
+#195 := (>= #197 0::real)
+#193 := (not #195)
+#213 := (* -1::real #34)
+#214 := (+ #31 #213)
+#212 := (>= #214 0::real)
+#215 := (not #212)
+#220 := (and #193 #215)
+#23 := (< #22 #22)
+#35 := (ite #23 #28 #34)
+#36 := (< #31 #35)
+#29 := (ite #23 #26 #28)
+#32 := (< #29 #31)
+#37 := (and #32 #36)
+#221 := (iff #37 #220)
+#218 := (iff #36 #215)
+#209 := (< #31 #34)
+#216 := (iff #209 #215)
+#217 := [rewrite]: #216
+#210 := (iff #36 #209)
+#207 := (= #35 #34)
+#202 := (ite false #28 #34)
+#205 := (= #202 #34)
+#206 := [rewrite]: #205
+#203 := (= #35 #202)
+#180 := (iff #23 false)
+#181 := [rewrite]: #180
+#204 := [monotonicity #181]: #203
+#208 := [trans #204 #206]: #207
+#211 := [monotonicity #208]: #210
+#219 := [trans #211 #217]: #218
+#200 := (iff #32 #193)
+#189 := (< #28 #31)
+#198 := (iff #189 #193)
+#199 := [rewrite]: #198
+#190 := (iff #32 #189)
+#187 := (= #29 #28)
+#182 := (ite false #26 #28)
+#185 := (= #182 #28)
+#186 := [rewrite]: #185
+#183 := (= #29 #182)
+#184 := [monotonicity #181]: #183
+#188 := [trans #184 #186]: #187
+#191 := [monotonicity #188]: #190
+#201 := [trans #191 #199]: #200
+#222 := [monotonicity #201 #219]: #221
+#177 := [asserted]: #37
+#223 := [mp #177 #222]: #220
+#224 := [and-elim #223]: #193
+#644 := [th-lemma #224 #277 #643]: false
+#646 := [lemma #644]: #645
+#647 := [hypothesis]: #568
+#649 := (or #648 #642)
+#650 := [th-lemma]: #649
+#651 := [unit-resolution #650 #647 #646]: false
+#652 := [lemma #651]: #648
+#578 := (or #229 #568)
+#579 := [def-axiom]: #578
+#675 := [unit-resolution #579 #652]: #229
+#677 := [th-lemma #675 #395]: #676
+#679 := [symm #677]: #678
+#683 := [monotonicity #679]: #682
+#685 := [symm #683]: #684
+#587 := (= uf_3 #586)
+#591 := (or #590 #587)
+#592 := [quant-inst]: #591
+#681 := [unit-resolution #592 #547]: #587
+#689 := [trans #681 #685]: #688
+#690 := [trans #689 #687]: #45
+#571 := (not #45)
+#54 := (uf_4 uf_11 #46)
+#279 := (ite #45 #28 #54)
+#465 := (* -1::real #279)
+#632 := (+ #28 #465)
+#633 := (<= #632 0::real)
+#580 := (= #28 #279)
+#656 := [hypothesis]: #45
+#582 := (or #571 #580)
+#583 := [def-axiom]: #582
+#657 := [unit-resolution #583 #656]: #580
+#658 := (not #580)
+#659 := (or #658 #633)
+#660 := [th-lemma]: #659
+#661 := [unit-resolution #660 #657]: #633
+#57 := (uf_4 uf_8 #46)
+#363 := (* -1::real #57)
+#379 := (+ #47 #363)
+#380 := (<= #379 0::real)
+#381 := (not #380)
+#364 := (+ #54 #363)
+#362 := (>= #364 0::real)
+#361 := (not #362)
+#386 := (and #361 #381)
+#59 := (uf_4 uf_7 #46)
+#64 := (< #39 #39)
+#67 := (ite #64 #59 #47)
+#68 := (< #57 #67)
+#65 := (ite #64 #47 #54)
+#66 := (< #65 #57)
+#69 := (and #66 #68)
+#387 := (iff #69 #386)
+#384 := (iff #68 #381)
+#376 := (< #57 #47)
+#382 := (iff #376 #381)
+#383 := [rewrite]: #382
+#377 := (iff #68 #376)
+#374 := (= #67 #47)
+#369 := (ite false #59 #47)
+#372 := (= #369 #47)
+#373 := [rewrite]: #372
+#370 := (= #67 #369)
+#349 := (iff #64 false)
+#350 := [rewrite]: #349
+#371 := [monotonicity #350]: #370
+#375 := [trans #371 #373]: #374
+#378 := [monotonicity #375]: #377
+#385 := [trans #378 #383]: #384
+#367 := (iff #66 #361)
+#358 := (< #54 #57)
+#365 := (iff #358 #361)
+#366 := [rewrite]: #365
+#359 := (iff #66 #358)
+#356 := (= #65 #54)
+#351 := (ite false #47 #54)
+#354 := (= #351 #54)
+#355 := [rewrite]: #354
+#352 := (= #65 #351)
+#353 := [monotonicity #350]: #352
+#357 := [trans #353 #355]: #356
+#360 := [monotonicity #357]: #359
+#368 := [trans #360 #366]: #367
+#388 := [monotonicity #368 #385]: #387
+#346 := [asserted]: #69
+#389 := [mp #346 #388]: #386
+#391 := [and-elim #389]: #381
+#397 := (* -1::real #59)
+#398 := (+ #47 #397)
+#399 := (<= #398 0::real)
+#409 := (* -1::real #54)
+#410 := (+ #47 #409)
+#408 := (>= #410 0::real)
+#60 := (uf_4 uf_9 #46)
+#402 := (* -1::real #60)
+#403 := (+ #59 #402)
+#404 := (<= #403 0::real)
+#418 := (and #399 #404 #408)
+#73 := (<= #59 #60)
+#72 := (<= #47 #59)
+#74 := (and #72 #73)
+#71 := (<= #54 #47)
+#75 := (and #71 #74)
+#421 := (iff #75 #418)
+#412 := (and #399 #404)
+#415 := (and #408 #412)
+#419 := (iff #415 #418)
+#420 := [rewrite]: #419
+#416 := (iff #75 #415)
+#413 := (iff #74 #412)
+#405 := (iff #73 #404)
+#406 := [rewrite]: #405
+#400 := (iff #72 #399)
+#401 := [rewrite]: #400
+#414 := [monotonicity #401 #406]: #413
+#407 := (iff #71 #408)
+#411 := [rewrite]: #407
+#417 := [monotonicity #411 #414]: #416
+#422 := [trans #417 #420]: #421
+#348 := [asserted]: #75
+#423 := [mp #348 #422]: #418
+#424 := [and-elim #423]: #399
+#637 := (+ #28 #397)
+#639 := (>= #637 0::real)
+#636 := (= #28 #59)
+#666 := (= #59 #28)
+#664 := (= #46 #25)
+#662 := (= #25 #46)
+#663 := [monotonicity #656]: #662
+#665 := [symm #663]: #664
+#667 := [monotonicity #665]: #666
+#668 := [symm #667]: #636
+#669 := (not #636)
+#670 := (or #669 #639)
+#671 := [th-lemma]: #670
+#672 := [unit-resolution #671 #668]: #639
+#468 := (+ #57 #465)
+#471 := (<= #468 0::real)
+#444 := (not #471)
+#322 := (ite #296 #279 #47)
+#330 := (* -1::real #322)
+#331 := (+ #57 #330)
+#332 := (<= #331 0::real)
+#333 := (not #332)
+#445 := (iff #333 #444)
+#472 := (iff #332 #471)
+#469 := (= #331 #468)
+#466 := (= #330 #465)
+#463 := (= #322 #279)
+#1 := true
+#458 := (ite true #279 #47)
+#461 := (= #458 #279)
+#462 := [rewrite]: #461
+#459 := (= #322 #458)
+#450 := (iff #296 true)
+#451 := [iff-true #395]: #450
+#460 := [monotonicity #451]: #459
+#464 := [trans #460 #462]: #463
+#467 := [monotonicity #464]: #466
+#470 := [monotonicity #467]: #469
+#473 := [monotonicity #470]: #472
+#474 := [monotonicity #473]: #445
+#303 := (ite #296 #60 #59)
+#313 := (* -1::real #303)
+#314 := (+ #57 #313)
+#312 := (>= #314 0::real)
+#311 := (not #312)
+#338 := (and #311 #333)
+#52 := (< #39 #22)
+#61 := (ite #52 #59 #60)
+#62 := (< #57 #61)
+#53 := (= uf_10 uf_3)
+#55 := (ite #53 #28 #54)
+#56 := (ite #52 #47 #55)
+#58 := (< #56 #57)
+#63 := (and #58 #62)
+#341 := (iff #63 #338)
+#282 := (ite #52 #47 #279)
+#285 := (< #282 #57)
+#291 := (and #62 #285)
+#339 := (iff #291 #338)
+#336 := (iff #285 #333)
+#327 := (< #322 #57)
+#334 := (iff #327 #333)
+#335 := [rewrite]: #334
+#328 := (iff #285 #327)
+#325 := (= #282 #322)
+#297 := (not #296)
+#319 := (ite #297 #47 #279)
+#323 := (= #319 #322)
+#324 := [rewrite]: #323
+#320 := (= #282 #319)
+#298 := (iff #52 #297)
+#299 := [rewrite]: #298
+#321 := [monotonicity #299]: #320
+#326 := [trans #321 #324]: #325
+#329 := [monotonicity #326]: #328
+#337 := [trans #329 #335]: #336
+#317 := (iff #62 #311)
+#308 := (< #57 #303)
+#315 := (iff #308 #311)
+#316 := [rewrite]: #315
+#309 := (iff #62 #308)
+#306 := (= #61 #303)
+#300 := (ite #297 #59 #60)
+#304 := (= #300 #303)
+#305 := [rewrite]: #304
+#301 := (= #61 #300)
+#302 := [monotonicity #299]: #301
+#307 := [trans #302 #305]: #306
+#310 := [monotonicity #307]: #309
+#318 := [trans #310 #316]: #317
+#340 := [monotonicity #318 #337]: #339
+#294 := (iff #63 #291)
+#288 := (and #285 #62)
+#292 := (iff #288 #291)
+#293 := [rewrite]: #292
+#289 := (iff #63 #288)
+#286 := (iff #58 #285)
+#283 := (= #56 #282)
+#280 := (= #55 #279)
+#226 := (iff #53 #45)
+#278 := [rewrite]: #226
+#281 := [monotonicity #278]: #280
+#284 := [monotonicity #281]: #283
+#287 := [monotonicity #284]: #286
+#290 := [monotonicity #287]: #289
+#295 := [trans #290 #293]: #294
+#342 := [trans #295 #340]: #341
+#179 := [asserted]: #63
+#343 := [mp #179 #342]: #338
+#345 := [and-elim #343]: #333
+#475 := [mp #345 #474]: #444
+#673 := [th-lemma #475 #672 #424 #391 #661]: false
+#674 := [lemma #673]: #571
+[unit-resolution #674 #690]: false
+unsat
+IL2powemHjRpCJYwmXFxyw 211 0
+#2 := false
+#33 := 0::real
+decl uf_11 :: (-> T5 T6 real)
+decl uf_15 :: T6
+#28 := uf_15
+decl uf_16 :: T5
+#30 := uf_16
+#31 := (uf_11 uf_16 uf_15)
+decl uf_12 :: (-> T7 T8 T5)
+decl uf_14 :: T8
+#26 := uf_14
+decl uf_13 :: (-> T1 T7)
+decl uf_8 :: T1
+#16 := uf_8
+#25 := (uf_13 uf_8)
+#27 := (uf_12 #25 uf_14)
+#29 := (uf_11 #27 uf_15)
+#73 := -1::real
+#84 := (* -1::real #29)
+#85 := (+ #84 #31)
+#74 := (* -1::real #31)
+#75 := (+ #29 #74)
+#112 := (>= #75 0::real)
+#119 := (ite #112 #75 #85)
+#127 := (* -1::real #119)
+decl uf_17 :: T5
+#37 := uf_17
+#38 := (uf_11 uf_17 uf_15)
+#102 := -1/3::real
+#103 := (* -1/3::real #38)
+#128 := (+ #103 #127)
+#100 := 1/3::real
+#101 := (* 1/3::real #31)
+#129 := (+ #101 #128)
+#130 := (<= #129 0::real)
+#131 := (not #130)
+#40 := 3::real
+#39 := (- #31 #38)
+#41 := (/ #39 3::real)
+#32 := (- #29 #31)
+#35 := (- #32)
+#34 := (< #32 0::real)
+#36 := (ite #34 #35 #32)
+#42 := (< #36 #41)
+#136 := (iff #42 #131)
+#104 := (+ #101 #103)
+#78 := (< #75 0::real)
+#90 := (ite #78 #85 #75)
+#109 := (< #90 #104)
+#134 := (iff #109 #131)
+#124 := (< #119 #104)
+#132 := (iff #124 #131)
+#133 := [rewrite]: #132
+#125 := (iff #109 #124)
+#122 := (= #90 #119)
+#113 := (not #112)
+#116 := (ite #113 #85 #75)
+#120 := (= #116 #119)
+#121 := [rewrite]: #120
+#117 := (= #90 #116)
+#114 := (iff #78 #113)
+#115 := [rewrite]: #114
+#118 := [monotonicity #115]: #117
+#123 := [trans #118 #121]: #122
+#126 := [monotonicity #123]: #125
+#135 := [trans #126 #133]: #134
+#110 := (iff #42 #109)
+#107 := (= #41 #104)
+#93 := (* -1::real #38)
+#94 := (+ #31 #93)
+#97 := (/ #94 3::real)
+#105 := (= #97 #104)
+#106 := [rewrite]: #105
+#98 := (= #41 #97)
+#95 := (= #39 #94)
+#96 := [rewrite]: #95
+#99 := [monotonicity #96]: #98
+#108 := [trans #99 #106]: #107
+#91 := (= #36 #90)
+#76 := (= #32 #75)
+#77 := [rewrite]: #76
+#88 := (= #35 #85)
+#81 := (- #75)
+#86 := (= #81 #85)
+#87 := [rewrite]: #86
+#82 := (= #35 #81)
+#83 := [monotonicity #77]: #82
+#89 := [trans #83 #87]: #88
+#79 := (iff #34 #78)
+#80 := [monotonicity #77]: #79
+#92 := [monotonicity #80 #89 #77]: #91
+#111 := [monotonicity #92 #108]: #110
+#137 := [trans #111 #135]: #136
+#72 := [asserted]: #42
+#138 := [mp #72 #137]: #131
+decl uf_1 :: T1
+#4 := uf_1
+#43 := (uf_13 uf_1)
+#44 := (uf_12 #43 uf_14)
+#45 := (uf_11 #44 uf_15)
+#149 := (* -1::real #45)
+#150 := (+ #38 #149)
+#140 := (+ #93 #45)
+#161 := (<= #150 0::real)
+#168 := (ite #161 #140 #150)
+#176 := (* -1::real #168)
+#177 := (+ #103 #176)
+#178 := (+ #101 #177)
+#179 := (<= #178 0::real)
+#180 := (not #179)
+#46 := (- #45 #38)
+#48 := (- #46)
+#47 := (< #46 0::real)
+#49 := (ite #47 #48 #46)
+#50 := (< #49 #41)
+#185 := (iff #50 #180)
+#143 := (< #140 0::real)
+#155 := (ite #143 #150 #140)
+#158 := (< #155 #104)
+#183 := (iff #158 #180)
+#173 := (< #168 #104)
+#181 := (iff #173 #180)
+#182 := [rewrite]: #181
+#174 := (iff #158 #173)
+#171 := (= #155 #168)
+#162 := (not #161)
+#165 := (ite #162 #150 #140)
+#169 := (= #165 #168)
+#170 := [rewrite]: #169
+#166 := (= #155 #165)
+#163 := (iff #143 #162)
+#164 := [rewrite]: #163
+#167 := [monotonicity #164]: #166
+#172 := [trans #167 #170]: #171
+#175 := [monotonicity #172]: #174
+#184 := [trans #175 #182]: #183
+#159 := (iff #50 #158)
+#156 := (= #49 #155)
+#141 := (= #46 #140)
+#142 := [rewrite]: #141
+#153 := (= #48 #150)
+#146 := (- #140)
+#151 := (= #146 #150)
+#152 := [rewrite]: #151
+#147 := (= #48 #146)
+#148 := [monotonicity #142]: #147
+#154 := [trans #148 #152]: #153
+#144 := (iff #47 #143)
+#145 := [monotonicity #142]: #144
+#157 := [monotonicity #145 #154 #142]: #156
+#160 := [monotonicity #157 #108]: #159
+#186 := [trans #160 #184]: #185
+#139 := [asserted]: #50
+#187 := [mp #139 #186]: #180
+#299 := (+ #140 #176)
+#300 := (<= #299 0::real)
+#290 := (= #140 #168)
+#329 := [hypothesis]: #162
+#191 := (+ #29 #149)
+#192 := (<= #191 0::real)
+#51 := (<= #29 #45)
+#193 := (iff #51 #192)
+#194 := [rewrite]: #193
+#188 := [asserted]: #51
+#195 := [mp #188 #194]: #192
+#298 := (+ #75 #127)
+#301 := (<= #298 0::real)
+#284 := (= #75 #119)
+#302 := [hypothesis]: #113
+#296 := (+ #85 #127)
+#297 := (<= #296 0::real)
+#285 := (= #85 #119)
+#288 := (or #112 #285)
+#289 := [def-axiom]: #288
+#303 := [unit-resolution #289 #302]: #285
+#304 := (not #285)
+#305 := (or #304 #297)
+#306 := [th-lemma]: #305
+#307 := [unit-resolution #306 #303]: #297
+#315 := (not #290)
+#310 := (not #300)
+#311 := (or #310 #112)
+#308 := [hypothesis]: #300
+#309 := [th-lemma #308 #307 #138 #302 #187 #195]: false
+#312 := [lemma #309]: #311
+#322 := [unit-resolution #312 #302]: #310
+#316 := (or #315 #300)
+#313 := [hypothesis]: #310
+#314 := [hypothesis]: #290
+#317 := [th-lemma]: #316
+#318 := [unit-resolution #317 #314 #313]: false
+#319 := [lemma #318]: #316
+#323 := [unit-resolution #319 #322]: #315
+#292 := (or #162 #290)
+#293 := [def-axiom]: #292
+#324 := [unit-resolution #293 #323]: #162
+#325 := [th-lemma #324 #307 #138 #302 #195]: false
+#326 := [lemma #325]: #112
+#286 := (or #113 #284)
+#287 := [def-axiom]: #286
+#330 := [unit-resolution #287 #326]: #284
+#331 := (not #284)
+#332 := (or #331 #301)
+#333 := [th-lemma]: #332
+#334 := [unit-resolution #333 #330]: #301
+#335 := [th-lemma #326 #334 #195 #329 #138]: false
+#336 := [lemma #335]: #161
+#327 := [unit-resolution #293 #336]: #290
+#328 := [unit-resolution #319 #327]: #300
+[th-lemma #326 #334 #195 #328 #187 #138]: false
+unsat
+GX51o3DUO/UBS3eNP2P9kA 285 0
+#2 := false
+#7 := 0::real
+decl uf_4 :: real
+#16 := uf_4
+#40 := -1::real
+#116 := (* -1::real uf_4)
+decl uf_3 :: real
+#11 := uf_3
+#117 := (+ uf_3 #116)
+#128 := (<= #117 0::real)
+#129 := (not #128)
+#220 := 2/3::real
+#221 := (* 2/3::real uf_3)
+#222 := (+ #221 #116)
+decl uf_2 :: real
+#5 := uf_2
+#67 := 1/3::real
+#68 := (* 1/3::real uf_2)
+#233 := (+ #68 #222)
+#243 := (<= #233 0::real)
+#268 := (not #243)
+#287 := [hypothesis]: #268
+#41 := (* -1::real uf_2)
+decl uf_1 :: real
+#4 := uf_1
+#42 := (+ uf_1 #41)
+#79 := (>= #42 0::real)
+#80 := (not #79)
+#297 := (or #80 #243)
+#158 := (+ uf_1 #116)
+#159 := (<= #158 0::real)
+#22 := (<= uf_1 uf_4)
+#160 := (iff #22 #159)
+#161 := [rewrite]: #160
+#155 := [asserted]: #22
+#162 := [mp #155 #161]: #159
+#200 := (* 1/3::real uf_3)
+#198 := -4/3::real
+#199 := (* -4/3::real uf_2)
+#201 := (+ #199 #200)
+#202 := (+ uf_1 #201)
+#203 := (>= #202 0::real)
+#258 := (not #203)
+#292 := [hypothesis]: #79
+#293 := (or #80 #258)
+#69 := -1/3::real
+#70 := (* -1/3::real uf_3)
+#186 := -2/3::real
+#187 := (* -2/3::real uf_2)
+#188 := (+ #187 #70)
+#189 := (+ uf_1 #188)
+#204 := (<= #189 0::real)
+#205 := (ite #79 #203 #204)
+#210 := (not #205)
+#51 := (* -1::real uf_1)
+#52 := (+ #51 uf_2)
+#86 := (ite #79 #42 #52)
+#94 := (* -1::real #86)
+#95 := (+ #70 #94)
+#96 := (+ #68 #95)
+#97 := (<= #96 0::real)
+#98 := (not #97)
+#211 := (iff #98 #210)
+#208 := (iff #97 #205)
+#182 := 4/3::real
+#183 := (* 4/3::real uf_2)
+#184 := (+ #183 #70)
+#185 := (+ #51 #184)
+#190 := (ite #79 #185 #189)
+#195 := (<= #190 0::real)
+#206 := (iff #195 #205)
+#207 := [rewrite]: #206
+#196 := (iff #97 #195)
+#193 := (= #96 #190)
+#172 := (+ #41 #70)
+#173 := (+ uf_1 #172)
+#170 := (+ uf_2 #70)
+#171 := (+ #51 #170)
+#174 := (ite #79 #171 #173)
+#179 := (+ #68 #174)
+#191 := (= #179 #190)
+#192 := [rewrite]: #191
+#180 := (= #96 #179)
+#177 := (= #95 #174)
+#164 := (ite #79 #52 #42)
+#167 := (+ #70 #164)
+#175 := (= #167 #174)
+#176 := [rewrite]: #175
+#168 := (= #95 #167)
+#156 := (= #94 #164)
+#165 := [rewrite]: #156
+#169 := [monotonicity #165]: #168
+#178 := [trans #169 #176]: #177
+#181 := [monotonicity #178]: #180
+#194 := [trans #181 #192]: #193
+#197 := [monotonicity #194]: #196
+#209 := [trans #197 #207]: #208
+#212 := [monotonicity #209]: #211
+#13 := 3::real
+#12 := (- uf_2 uf_3)
+#14 := (/ #12 3::real)
+#6 := (- uf_1 uf_2)
+#9 := (- #6)
+#8 := (< #6 0::real)
+#10 := (ite #8 #9 #6)
+#15 := (< #10 #14)
+#103 := (iff #15 #98)
+#71 := (+ #68 #70)
+#45 := (< #42 0::real)
+#57 := (ite #45 #52 #42)
+#76 := (< #57 #71)
+#101 := (iff #76 #98)
+#91 := (< #86 #71)
+#99 := (iff #91 #98)
+#100 := [rewrite]: #99
+#92 := (iff #76 #91)
+#89 := (= #57 #86)
+#83 := (ite #80 #52 #42)
+#87 := (= #83 #86)
+#88 := [rewrite]: #87
+#84 := (= #57 #83)
+#81 := (iff #45 #80)
+#82 := [rewrite]: #81
+#85 := [monotonicity #82]: #84
+#90 := [trans #85 #88]: #89
+#93 := [monotonicity #90]: #92
+#102 := [trans #93 #100]: #101
+#77 := (iff #15 #76)
+#74 := (= #14 #71)
+#60 := (* -1::real uf_3)
+#61 := (+ uf_2 #60)
+#64 := (/ #61 3::real)
+#72 := (= #64 #71)
+#73 := [rewrite]: #72
+#65 := (= #14 #64)
+#62 := (= #12 #61)
+#63 := [rewrite]: #62
+#66 := [monotonicity #63]: #65
+#75 := [trans #66 #73]: #74
+#58 := (= #10 #57)
+#43 := (= #6 #42)
+#44 := [rewrite]: #43
+#55 := (= #9 #52)
+#48 := (- #42)
+#53 := (= #48 #52)
+#54 := [rewrite]: #53
+#49 := (= #9 #48)
+#50 := [monotonicity #44]: #49
+#56 := [trans #50 #54]: #55
+#46 := (iff #8 #45)
+#47 := [monotonicity #44]: #46
+#59 := [monotonicity #47 #56 #44]: #58
+#78 := [monotonicity #59 #75]: #77
+#104 := [trans #78 #102]: #103
+#39 := [asserted]: #15
+#105 := [mp #39 #104]: #98
+#213 := [mp #105 #212]: #210
+#259 := (or #205 #80 #258)
+#260 := [def-axiom]: #259
+#294 := [unit-resolution #260 #213]: #293
+#295 := [unit-resolution #294 #292]: #258
+#296 := [th-lemma #287 #292 #295 #162]: false
+#298 := [lemma #296]: #297
+#299 := [unit-resolution #298 #287]: #80
+#261 := (not #204)
+#281 := (or #79 #261)
+#262 := (or #205 #79 #261)
+#263 := [def-axiom]: #262
+#282 := [unit-resolution #263 #213]: #281
+#300 := [unit-resolution #282 #299]: #261
+#290 := (or #79 #204 #243)
+#276 := [hypothesis]: #261
+#288 := [hypothesis]: #80
+#289 := [th-lemma #288 #276 #162 #287]: false
+#291 := [lemma #289]: #290
+#301 := [unit-resolution #291 #300 #299 #287]: false
+#302 := [lemma #301]: #243
+#303 := (or #129 #268)
+#223 := (* -4/3::real uf_3)
+#224 := (+ #223 uf_4)
+#234 := (+ #68 #224)
+#244 := (<= #234 0::real)
+#245 := (ite #128 #243 #244)
+#250 := (not #245)
+#107 := (+ #60 uf_4)
+#135 := (ite #128 #107 #117)
+#143 := (* -1::real #135)
+#144 := (+ #70 #143)
+#145 := (+ #68 #144)
+#146 := (<= #145 0::real)
+#147 := (not #146)
+#251 := (iff #147 #250)
+#248 := (iff #146 #245)
+#235 := (ite #128 #233 #234)
+#240 := (<= #235 0::real)
+#246 := (iff #240 #245)
+#247 := [rewrite]: #246
+#241 := (iff #146 #240)
+#238 := (= #145 #235)
+#225 := (ite #128 #222 #224)
+#230 := (+ #68 #225)
+#236 := (= #230 #235)
+#237 := [rewrite]: #236
+#231 := (= #145 #230)
+#228 := (= #144 #225)
+#214 := (ite #128 #117 #107)
+#217 := (+ #70 #214)
+#226 := (= #217 #225)
+#227 := [rewrite]: #226
+#218 := (= #144 #217)
+#215 := (= #143 #214)
+#216 := [rewrite]: #215
+#219 := [monotonicity #216]: #218
+#229 := [trans #219 #227]: #228
+#232 := [monotonicity #229]: #231
+#239 := [trans #232 #237]: #238
+#242 := [monotonicity #239]: #241
+#249 := [trans #242 #247]: #248
+#252 := [monotonicity #249]: #251
+#17 := (- uf_4 uf_3)
+#19 := (- #17)
+#18 := (< #17 0::real)
+#20 := (ite #18 #19 #17)
+#21 := (< #20 #14)
+#152 := (iff #21 #147)
+#110 := (< #107 0::real)
+#122 := (ite #110 #117 #107)
+#125 := (< #122 #71)
+#150 := (iff #125 #147)
+#140 := (< #135 #71)
+#148 := (iff #140 #147)
+#149 := [rewrite]: #148
+#141 := (iff #125 #140)
+#138 := (= #122 #135)
+#132 := (ite #129 #117 #107)
+#136 := (= #132 #135)
+#137 := [rewrite]: #136
+#133 := (= #122 #132)
+#130 := (iff #110 #129)
+#131 := [rewrite]: #130
+#134 := [monotonicity #131]: #133
+#139 := [trans #134 #137]: #138
+#142 := [monotonicity #139]: #141
+#151 := [trans #142 #149]: #150
+#126 := (iff #21 #125)
+#123 := (= #20 #122)
+#108 := (= #17 #107)
+#109 := [rewrite]: #108
+#120 := (= #19 #117)
+#113 := (- #107)
+#118 := (= #113 #117)
+#119 := [rewrite]: #118
+#114 := (= #19 #113)
+#115 := [monotonicity #109]: #114
+#121 := [trans #115 #119]: #120
+#111 := (iff #18 #110)
+#112 := [monotonicity #109]: #111
+#124 := [monotonicity #112 #121 #109]: #123
+#127 := [monotonicity #124 #75]: #126
+#153 := [trans #127 #151]: #152
+#106 := [asserted]: #21
+#154 := [mp #106 #153]: #147
+#253 := [mp #154 #252]: #250
+#269 := (or #245 #129 #268)
+#270 := [def-axiom]: #269
+#304 := [unit-resolution #270 #253]: #303
+#305 := [unit-resolution #304 #302]: #129
+#271 := (not #244)
+#306 := (or #128 #271)
+#272 := (or #245 #128 #271)
+#273 := [def-axiom]: #272
+#307 := [unit-resolution #273 #253]: #306
+#308 := [unit-resolution #307 #305]: #271
+#285 := (or #128 #244)
+#274 := [hypothesis]: #271
+#275 := [hypothesis]: #129
+#278 := (or #204 #128 #244)
+#277 := [th-lemma #276 #275 #274 #162]: false
+#279 := [lemma #277]: #278
+#280 := [unit-resolution #279 #275 #274]: #204
+#283 := [unit-resolution #282 #280]: #79
+#284 := [th-lemma #275 #274 #283 #162]: false
+#286 := [lemma #284]: #285
+[unit-resolution #286 #308 #305]: false
+unsat
+cebG074uorSr8ODzgTmcKg 97 0
+#2 := false
+#18 := 0::real
+decl uf_1 :: (-> T2 T1 real)
+decl uf_5 :: T1
+#11 := uf_5
+decl uf_2 :: T2
+#4 := uf_2
+#20 := (uf_1 uf_2 uf_5)
+#42 := -1::real
+#53 := (* -1::real #20)
+decl uf_3 :: T2
+#7 := uf_3
+#19 := (uf_1 uf_3 uf_5)
+#54 := (+ #19 #53)
+#63 := (<= #54 0::real)
+#21 := (- #19 #20)
+#22 := (< 0::real #21)
+#23 := (not #22)
+#74 := (iff #23 #63)
+#57 := (< 0::real #54)
+#60 := (not #57)
+#72 := (iff #60 #63)
+#64 := (not #63)
+#67 := (not #64)
+#70 := (iff #67 #63)
+#71 := [rewrite]: #70
+#68 := (iff #60 #67)
+#65 := (iff #57 #64)
+#66 := [rewrite]: #65
+#69 := [monotonicity #66]: #68
+#73 := [trans #69 #71]: #72
+#61 := (iff #23 #60)
+#58 := (iff #22 #57)
+#55 := (= #21 #54)
+#56 := [rewrite]: #55
+#59 := [monotonicity #56]: #58
+#62 := [monotonicity #59]: #61
+#75 := [trans #62 #73]: #74
+#41 := [asserted]: #23
+#76 := [mp #41 #75]: #63
+#5 := (:var 0 T1)
+#8 := (uf_1 uf_3 #5)
+#141 := (pattern #8)
+#6 := (uf_1 uf_2 #5)
+#140 := (pattern #6)
+#45 := (* -1::real #8)
+#46 := (+ #6 #45)
+#44 := (>= #46 0::real)
+#43 := (not #44)
+#142 := (forall (vars (?x1 T1)) (:pat #140 #141) #43)
+#49 := (forall (vars (?x1 T1)) #43)
+#145 := (iff #49 #142)
+#143 := (iff #43 #43)
+#144 := [refl]: #143
+#146 := [quant-intro #144]: #145
+#80 := (~ #49 #49)
+#82 := (~ #43 #43)
+#83 := [refl]: #82
+#81 := [nnf-pos #83]: #80
+#9 := (< #6 #8)
+#10 := (forall (vars (?x1 T1)) #9)
+#50 := (iff #10 #49)
+#47 := (iff #9 #43)
+#48 := [rewrite]: #47
+#51 := [quant-intro #48]: #50
+#39 := [asserted]: #10
+#52 := [mp #39 #51]: #49
+#79 := [mp~ #52 #81]: #49
+#147 := [mp #79 #146]: #142
+#164 := (not #142)
+#165 := (or #164 #64)
+#148 := (* -1::real #19)
+#149 := (+ #20 #148)
+#150 := (>= #149 0::real)
+#151 := (not #150)
+#166 := (or #164 #151)
+#168 := (iff #166 #165)
+#170 := (iff #165 #165)
+#171 := [rewrite]: #170
+#162 := (iff #151 #64)
+#160 := (iff #150 #63)
+#152 := (+ #148 #20)
+#155 := (>= #152 0::real)
+#158 := (iff #155 #63)
+#159 := [rewrite]: #158
+#156 := (iff #150 #155)
+#153 := (= #149 #152)
+#154 := [rewrite]: #153
+#157 := [monotonicity #154]: #156
+#161 := [trans #157 #159]: #160
+#163 := [monotonicity #161]: #162
+#169 := [monotonicity #163]: #168
+#172 := [trans #169 #171]: #168
+#167 := [quant-inst]: #166
+#173 := [mp #167 #172]: #165
+[unit-resolution #173 #147 #76]: false
+unsat
+DKRtrJ2XceCkITuNwNViRw 57 0
+#2 := false
+#4 := 0::real
+decl uf_1 :: (-> T2 real)
+decl uf_2 :: (-> T1 T1 T2)
+decl uf_12 :: (-> T4 T1)
+decl uf_4 :: T4
+#11 := uf_4
+#39 := (uf_12 uf_4)
+decl uf_10 :: T4
+#27 := uf_10
+#38 := (uf_12 uf_10)
+#40 := (uf_2 #38 #39)
+#41 := (uf_1 #40)
+#264 := (>= #41 0::real)
+#266 := (not #264)
+#43 := (= #41 0::real)
+#44 := (not #43)
+#131 := [asserted]: #44
+#272 := (or #43 #266)
+#42 := (<= #41 0::real)
+#130 := [asserted]: #42
+#265 := (not #42)
+#270 := (or #43 #265 #266)
+#271 := [th-lemma]: #270
+#273 := [unit-resolution #271 #130]: #272
+#274 := [unit-resolution #273 #131]: #266
+#6 := (:var 0 T1)
+#5 := (:var 1 T1)
+#7 := (uf_2 #5 #6)
+#241 := (pattern #7)
+#8 := (uf_1 #7)
+#65 := (>= #8 0::real)
+#242 := (forall (vars (?x1 T1) (?x2 T1)) (:pat #241) #65)
+#66 := (forall (vars (?x1 T1) (?x2 T1)) #65)
+#245 := (iff #66 #242)
+#243 := (iff #65 #65)
+#244 := [refl]: #243
+#246 := [quant-intro #244]: #245
+#149 := (~ #66 #66)
+#151 := (~ #65 #65)
+#152 := [refl]: #151
+#150 := [nnf-pos #152]: #149
+#9 := (<= 0::real #8)
+#10 := (forall (vars (?x1 T1) (?x2 T1)) #9)
+#67 := (iff #10 #66)
+#63 := (iff #9 #65)
+#64 := [rewrite]: #63
+#68 := [quant-intro #64]: #67
+#60 := [asserted]: #10
+#69 := [mp #60 #68]: #66
+#147 := [mp~ #69 #150]: #66
+#247 := [mp #147 #246]: #242
+#267 := (not #242)
+#268 := (or #267 #264)
+#269 := [quant-inst]: #268
+[unit-resolution #269 #247 #274]: false
+unsat
+97KJAJfUio+nGchEHWvgAw 91 0
+#2 := false
+#38 := 0::real
+decl uf_1 :: (-> T1 T2 real)
+decl uf_3 :: T2
+#5 := uf_3
+decl uf_4 :: T1
+#7 := uf_4
+#8 := (uf_1 uf_4 uf_3)
+#35 := -1::real
+#36 := (* -1::real #8)
+decl uf_2 :: T1
+#4 := uf_2
+#6 := (uf_1 uf_2 uf_3)
+#37 := (+ #6 #36)
+#130 := (>= #37 0::real)
+#155 := (not #130)
+#43 := (= #6 #8)
+#55 := (not #43)
+#15 := (= #8 #6)
+#16 := (not #15)
+#56 := (iff #16 #55)
+#53 := (iff #15 #43)
+#54 := [rewrite]: #53
+#57 := [monotonicity #54]: #56
+#34 := [asserted]: #16
+#60 := [mp #34 #57]: #55
+#158 := (or #43 #155)
+#39 := (<= #37 0::real)
+#9 := (<= #6 #8)
+#40 := (iff #9 #39)
+#41 := [rewrite]: #40
+#32 := [asserted]: #9
+#42 := [mp #32 #41]: #39
+#154 := (not #39)
+#156 := (or #43 #154 #155)
+#157 := [th-lemma]: #156
+#159 := [unit-resolution #157 #42]: #158
+#160 := [unit-resolution #159 #60]: #155
+#10 := (:var 0 T2)
+#12 := (uf_1 uf_2 #10)
+#123 := (pattern #12)
+#11 := (uf_1 uf_4 #10)
+#122 := (pattern #11)
+#44 := (* -1::real #12)
+#45 := (+ #11 #44)
+#46 := (<= #45 0::real)
+#124 := (forall (vars (?x1 T2)) (:pat #122 #123) #46)
+#49 := (forall (vars (?x1 T2)) #46)
+#127 := (iff #49 #124)
+#125 := (iff #46 #46)
+#126 := [refl]: #125
+#128 := [quant-intro #126]: #127
+#62 := (~ #49 #49)
+#64 := (~ #46 #46)
+#65 := [refl]: #64
+#63 := [nnf-pos #65]: #62
+#13 := (<= #11 #12)
+#14 := (forall (vars (?x1 T2)) #13)
+#50 := (iff #14 #49)
+#47 := (iff #13 #46)
+#48 := [rewrite]: #47
+#51 := [quant-intro #48]: #50
+#33 := [asserted]: #14
+#52 := [mp #33 #51]: #49
+#61 := [mp~ #52 #63]: #49
+#129 := [mp #61 #128]: #124
+#144 := (not #124)
+#145 := (or #144 #130)
+#131 := (* -1::real #6)
+#132 := (+ #8 #131)
+#133 := (<= #132 0::real)
+#146 := (or #144 #133)
+#148 := (iff #146 #145)
+#150 := (iff #145 #145)
+#151 := [rewrite]: #150
+#142 := (iff #133 #130)
+#134 := (+ #131 #8)
+#137 := (<= #134 0::real)
+#140 := (iff #137 #130)
+#141 := [rewrite]: #140
+#138 := (iff #133 #137)
+#135 := (= #132 #134)
+#136 := [rewrite]: #135
+#139 := [monotonicity #136]: #138
+#143 := [trans #139 #141]: #142
+#149 := [monotonicity #143]: #148
+#152 := [trans #149 #151]: #148
+#147 := [quant-inst]: #146
+#153 := [mp #147 #152]: #145
+[unit-resolution #153 #129 #160]: false
+unsat
+flJYbeWfe+t2l/zsRqdujA 149 0
+#2 := false
+#19 := 0::real
+decl uf_1 :: (-> T1 T2 real)
+decl uf_3 :: T2
+#5 := uf_3
+decl uf_4 :: T1
+#7 := uf_4
+#8 := (uf_1 uf_4 uf_3)
+#44 := -1::real
+#156 := (* -1::real #8)
+decl uf_2 :: T1
+#4 := uf_2
+#6 := (uf_1 uf_2 uf_3)
+#203 := (+ #6 #156)
+#205 := (>= #203 0::real)
+#9 := (= #6 #8)
+#40 := [asserted]: #9
+#208 := (not #9)
+#209 := (or #208 #205)
+#210 := [th-lemma]: #209
+#211 := [unit-resolution #210 #40]: #205
+decl uf_5 :: T1
+#12 := uf_5
+#22 := (uf_1 uf_5 uf_3)
+#160 := (* -1::real #22)
+#161 := (+ #6 #160)
+#207 := (>= #161 0::real)
+#222 := (not #207)
+#206 := (= #6 #22)
+#216 := (not #206)
+#62 := (= #8 #22)
+#70 := (not #62)
+#217 := (iff #70 #216)
+#214 := (iff #62 #206)
+#212 := (iff #206 #62)
+#213 := [monotonicity #40]: #212
+#215 := [symm #213]: #214
+#218 := [monotonicity #215]: #217
+#23 := (= #22 #8)
+#24 := (not #23)
+#71 := (iff #24 #70)
+#68 := (iff #23 #62)
+#69 := [rewrite]: #68
+#72 := [monotonicity #69]: #71
+#43 := [asserted]: #24
+#75 := [mp #43 #72]: #70
+#219 := [mp #75 #218]: #216
+#225 := (or #206 #222)
+#162 := (<= #161 0::real)
+#172 := (+ #8 #160)
+#173 := (>= #172 0::real)
+#178 := (not #173)
+#163 := (not #162)
+#181 := (or #163 #178)
+#184 := (not #181)
+#10 := (:var 0 T2)
+#15 := (uf_1 uf_4 #10)
+#149 := (pattern #15)
+#13 := (uf_1 uf_5 #10)
+#148 := (pattern #13)
+#11 := (uf_1 uf_2 #10)
+#147 := (pattern #11)
+#50 := (* -1::real #15)
+#51 := (+ #13 #50)
+#52 := (<= #51 0::real)
+#76 := (not #52)
+#45 := (* -1::real #13)
+#46 := (+ #11 #45)
+#47 := (<= #46 0::real)
+#78 := (not #47)
+#73 := (or #78 #76)
+#83 := (not #73)
+#150 := (forall (vars (?x1 T2)) (:pat #147 #148 #149) #83)
+#86 := (forall (vars (?x1 T2)) #83)
+#153 := (iff #86 #150)
+#151 := (iff #83 #83)
+#152 := [refl]: #151
+#154 := [quant-intro #152]: #153
+#55 := (and #47 #52)
+#58 := (forall (vars (?x1 T2)) #55)
+#87 := (iff #58 #86)
+#84 := (iff #55 #83)
+#85 := [rewrite]: #84
+#88 := [quant-intro #85]: #87
+#79 := (~ #58 #58)
+#81 := (~ #55 #55)
+#82 := [refl]: #81
+#80 := [nnf-pos #82]: #79
+#16 := (<= #13 #15)
+#14 := (<= #11 #13)
+#17 := (and #14 #16)
+#18 := (forall (vars (?x1 T2)) #17)
+#59 := (iff #18 #58)
+#56 := (iff #17 #55)
+#53 := (iff #16 #52)
+#54 := [rewrite]: #53
+#48 := (iff #14 #47)
+#49 := [rewrite]: #48
+#57 := [monotonicity #49 #54]: #56
+#60 := [quant-intro #57]: #59
+#41 := [asserted]: #18
+#61 := [mp #41 #60]: #58
+#77 := [mp~ #61 #80]: #58
+#89 := [mp #77 #88]: #86
+#155 := [mp #89 #154]: #150
+#187 := (not #150)
+#188 := (or #187 #184)
+#157 := (+ #22 #156)
+#158 := (<= #157 0::real)
+#159 := (not #158)
+#164 := (or #163 #159)
+#165 := (not #164)
+#189 := (or #187 #165)
+#191 := (iff #189 #188)
+#193 := (iff #188 #188)
+#194 := [rewrite]: #193
+#185 := (iff #165 #184)
+#182 := (iff #164 #181)
+#179 := (iff #159 #178)
+#176 := (iff #158 #173)
+#166 := (+ #156 #22)
+#169 := (<= #166 0::real)
+#174 := (iff #169 #173)
+#175 := [rewrite]: #174
+#170 := (iff #158 #169)
+#167 := (= #157 #166)
+#168 := [rewrite]: #167
+#171 := [monotonicity #168]: #170
+#177 := [trans #171 #175]: #176
+#180 := [monotonicity #177]: #179
+#183 := [monotonicity #180]: #182
+#186 := [monotonicity #183]: #185
+#192 := [monotonicity #186]: #191
+#195 := [trans #192 #194]: #191
+#190 := [quant-inst]: #189
+#196 := [mp #190 #195]: #188
+#220 := [unit-resolution #196 #155]: #184
+#197 := (or #181 #162)
+#198 := [def-axiom]: #197
+#221 := [unit-resolution #198 #220]: #162
+#223 := (or #206 #163 #222)
+#224 := [th-lemma]: #223
+#226 := [unit-resolution #224 #221]: #225
+#227 := [unit-resolution #226 #219]: #222
+#199 := (or #181 #173)
+#200 := [def-axiom]: #199
+#228 := [unit-resolution #200 #220]: #173
+[th-lemma #228 #227 #211]: false
+unsat
+rbrrQuQfaijtLkQizgEXnQ 222 0
+#2 := false
+#4 := 0::real
+decl uf_2 :: (-> T2 T1 real)
+decl uf_5 :: T1
+#15 := uf_5
+decl uf_3 :: T2
+#7 := uf_3
+#20 := (uf_2 uf_3 uf_5)
+decl uf_6 :: T2
+#17 := uf_6
+#18 := (uf_2 uf_6 uf_5)
+#59 := -1::real
+#73 := (* -1::real #18)
+#106 := (+ #73 #20)
+decl uf_1 :: real
+#5 := uf_1
+#78 := (* -1::real #20)
+#79 := (+ #18 #78)
+#144 := (+ uf_1 #79)
+#145 := (<= #144 0::real)
+#148 := (ite #145 uf_1 #106)
+#279 := (* -1::real #148)
+#280 := (+ uf_1 #279)
+#281 := (<= #280 0::real)
+#289 := (not #281)
+#72 := 1/2::real
+#151 := (* 1/2::real #148)
+#248 := (<= #151 0::real)
+#162 := (= #151 0::real)
+#24 := 2::real
+#27 := (- #20 #18)
+#28 := (<= uf_1 #27)
+#29 := (ite #28 uf_1 #27)
+#30 := (/ #29 2::real)
+#31 := (+ #18 #30)
+#32 := (= #31 #18)
+#33 := (not #32)
+#34 := (not #33)
+#165 := (iff #34 #162)
+#109 := (<= uf_1 #106)
+#112 := (ite #109 uf_1 #106)
+#118 := (* 1/2::real #112)
+#123 := (+ #18 #118)
+#129 := (= #18 #123)
+#163 := (iff #129 #162)
+#154 := (+ #18 #151)
+#157 := (= #18 #154)
+#160 := (iff #157 #162)
+#161 := [rewrite]: #160
+#158 := (iff #129 #157)
+#155 := (= #123 #154)
+#152 := (= #118 #151)
+#149 := (= #112 #148)
+#146 := (iff #109 #145)
+#147 := [rewrite]: #146
+#150 := [monotonicity #147]: #149
+#153 := [monotonicity #150]: #152
+#156 := [monotonicity #153]: #155
+#159 := [monotonicity #156]: #158
+#164 := [trans #159 #161]: #163
+#142 := (iff #34 #129)
+#134 := (not #129)
+#137 := (not #134)
+#140 := (iff #137 #129)
+#141 := [rewrite]: #140
+#138 := (iff #34 #137)
+#135 := (iff #33 #134)
+#132 := (iff #32 #129)
+#126 := (= #123 #18)
+#130 := (iff #126 #129)
+#131 := [rewrite]: #130
+#127 := (iff #32 #126)
+#124 := (= #31 #123)
+#121 := (= #30 #118)
+#115 := (/ #112 2::real)
+#119 := (= #115 #118)
+#120 := [rewrite]: #119
+#116 := (= #30 #115)
+#113 := (= #29 #112)
+#107 := (= #27 #106)
+#108 := [rewrite]: #107
+#110 := (iff #28 #109)
+#111 := [monotonicity #108]: #110
+#114 := [monotonicity #111 #108]: #113
+#117 := [monotonicity #114]: #116
+#122 := [trans #117 #120]: #121
+#125 := [monotonicity #122]: #124
+#128 := [monotonicity #125]: #127
+#133 := [trans #128 #131]: #132
+#136 := [monotonicity #133]: #135
+#139 := [monotonicity #136]: #138
+#143 := [trans #139 #141]: #142
+#166 := [trans #143 #164]: #165
+#105 := [asserted]: #34
+#167 := [mp #105 #166]: #162
+#283 := (not #162)
+#284 := (or #283 #248)
+#285 := [th-lemma]: #284
+#286 := [unit-resolution #285 #167]: #248
+#287 := [hypothesis]: #281
+#53 := (<= uf_1 0::real)
+#54 := (not #53)
+#6 := (< 0::real uf_1)
+#55 := (iff #6 #54)
+#56 := [rewrite]: #55
+#50 := [asserted]: #6
+#57 := [mp #50 #56]: #54
+#288 := [th-lemma #57 #287 #286]: false
+#290 := [lemma #288]: #289
+#241 := (= uf_1 #148)
+#242 := (= #106 #148)
+#299 := (not #242)
+#282 := (+ #106 #279)
+#291 := (<= #282 0::real)
+#296 := (not #291)
+decl uf_4 :: T2
+#10 := uf_4
+#16 := (uf_2 uf_4 uf_5)
+#260 := (+ #16 #78)
+#261 := (>= #260 0::real)
+#266 := (not #261)
+#8 := (:var 0 T1)
+#11 := (uf_2 uf_4 #8)
+#234 := (pattern #11)
+#9 := (uf_2 uf_3 #8)
+#233 := (pattern #9)
+#60 := (* -1::real #11)
+#61 := (+ #9 #60)
+#62 := (<= #61 0::real)
+#179 := (not #62)
+#235 := (forall (vars (?x1 T1)) (:pat #233 #234) #179)
+#178 := (forall (vars (?x1 T1)) #179)
+#238 := (iff #178 #235)
+#236 := (iff #179 #179)
+#237 := [refl]: #236
+#239 := [quant-intro #237]: #238
+#65 := (exists (vars (?x1 T1)) #62)
+#68 := (not #65)
+#175 := (~ #68 #178)
+#180 := (~ #179 #179)
+#177 := [refl]: #180
+#176 := [nnf-neg #177]: #175
+#12 := (<= #9 #11)
+#13 := (exists (vars (?x1 T1)) #12)
+#14 := (not #13)
+#69 := (iff #14 #68)
+#66 := (iff #13 #65)
+#63 := (iff #12 #62)
+#64 := [rewrite]: #63
+#67 := [quant-intro #64]: #66
+#70 := [monotonicity #67]: #69
+#51 := [asserted]: #14
+#71 := [mp #51 #70]: #68
+#173 := [mp~ #71 #176]: #178
+#240 := [mp #173 #239]: #235
+#269 := (not #235)
+#270 := (or #269 #266)
+#250 := (* -1::real #16)
+#251 := (+ #20 #250)
+#252 := (<= #251 0::real)
+#253 := (not #252)
+#271 := (or #269 #253)
+#273 := (iff #271 #270)
+#275 := (iff #270 #270)
+#276 := [rewrite]: #275
+#267 := (iff #253 #266)
+#264 := (iff #252 #261)
+#254 := (+ #250 #20)
+#257 := (<= #254 0::real)
+#262 := (iff #257 #261)
+#263 := [rewrite]: #262
+#258 := (iff #252 #257)
+#255 := (= #251 #254)
+#256 := [rewrite]: #255
+#259 := [monotonicity #256]: #258
+#265 := [trans #259 #263]: #264
+#268 := [monotonicity #265]: #267
+#274 := [monotonicity #268]: #273
+#277 := [trans #274 #276]: #273
+#272 := [quant-inst]: #271
+#278 := [mp #272 #277]: #270
+#293 := [unit-resolution #278 #240]: #266
+#90 := (* 1/2::real #20)
+#102 := (+ #73 #90)
+#89 := (* 1/2::real #16)
+#103 := (+ #89 #102)
+#100 := (>= #103 0::real)
+#23 := (+ #16 #20)
+#25 := (/ #23 2::real)
+#26 := (<= #18 #25)
+#98 := (iff #26 #100)
+#91 := (+ #89 #90)
+#94 := (<= #18 #91)
+#97 := (iff #94 #100)
+#99 := [rewrite]: #97
+#95 := (iff #26 #94)
+#92 := (= #25 #91)
+#93 := [rewrite]: #92
+#96 := [monotonicity #93]: #95
+#101 := [trans #96 #99]: #98
+#58 := [asserted]: #26
+#104 := [mp #58 #101]: #100
+#294 := [hypothesis]: #291
+#295 := [th-lemma #294 #104 #293 #286]: false
+#297 := [lemma #295]: #296
+#298 := [hypothesis]: #242
+#300 := (or #299 #291)
+#301 := [th-lemma]: #300
+#302 := [unit-resolution #301 #298 #297]: false
+#303 := [lemma #302]: #299
+#246 := (or #145 #242)
+#247 := [def-axiom]: #246
+#304 := [unit-resolution #247 #303]: #145
+#243 := (not #145)
+#244 := (or #243 #241)
+#245 := [def-axiom]: #244
+#305 := [unit-resolution #245 #304]: #241
+#306 := (not #241)
+#307 := (or #306 #281)
+#308 := [th-lemma]: #307
+[unit-resolution #308 #305 #290]: false
+unsat
+hwh3oeLAWt56hnKIa8Wuow 248 0
+#2 := false
+#4 := 0::real
+decl uf_2 :: (-> T2 T1 real)
+decl uf_5 :: T1
+#15 := uf_5
+decl uf_6 :: T2
+#17 := uf_6
+#18 := (uf_2 uf_6 uf_5)
+decl uf_4 :: T2
+#10 := uf_4
+#16 := (uf_2 uf_4 uf_5)
+#66 := -1::real
+#137 := (* -1::real #16)
+#138 := (+ #137 #18)
+decl uf_1 :: real
+#5 := uf_1
+#80 := (* -1::real #18)
+#81 := (+ #16 #80)
+#201 := (+ uf_1 #81)
+#202 := (<= #201 0::real)
+#205 := (ite #202 uf_1 #138)
+#352 := (* -1::real #205)
+#353 := (+ uf_1 #352)
+#354 := (<= #353 0::real)
+#362 := (not #354)
+#79 := 1/2::real
+#244 := (* 1/2::real #205)
+#322 := (<= #244 0::real)
+#245 := (= #244 0::real)
+#158 := -1/2::real
+#208 := (* -1/2::real #205)
+#211 := (+ #18 #208)
+decl uf_3 :: T2
+#7 := uf_3
+#20 := (uf_2 uf_3 uf_5)
+#117 := (+ #80 #20)
+#85 := (* -1::real #20)
+#86 := (+ #18 #85)
+#188 := (+ uf_1 #86)
+#189 := (<= #188 0::real)
+#192 := (ite #189 uf_1 #117)
+#195 := (* 1/2::real #192)
+#198 := (+ #18 #195)
+#97 := (* 1/2::real #20)
+#109 := (+ #80 #97)
+#96 := (* 1/2::real #16)
+#110 := (+ #96 #109)
+#107 := (>= #110 0::real)
+#214 := (ite #107 #198 #211)
+#217 := (= #18 #214)
+#248 := (iff #217 #245)
+#241 := (= #18 #211)
+#246 := (iff #241 #245)
+#247 := [rewrite]: #246
+#242 := (iff #217 #241)
+#239 := (= #214 #211)
+#234 := (ite false #198 #211)
+#237 := (= #234 #211)
+#238 := [rewrite]: #237
+#235 := (= #214 #234)
+#232 := (iff #107 false)
+#104 := (not #107)
+#24 := 2::real
+#23 := (+ #16 #20)
+#25 := (/ #23 2::real)
+#26 := (< #25 #18)
+#108 := (iff #26 #104)
+#98 := (+ #96 #97)
+#101 := (< #98 #18)
+#106 := (iff #101 #104)
+#105 := [rewrite]: #106
+#102 := (iff #26 #101)
+#99 := (= #25 #98)
+#100 := [rewrite]: #99
+#103 := [monotonicity #100]: #102
+#111 := [trans #103 #105]: #108
+#65 := [asserted]: #26
+#112 := [mp #65 #111]: #104
+#233 := [iff-false #112]: #232
+#236 := [monotonicity #233]: #235
+#240 := [trans #236 #238]: #239
+#243 := [monotonicity #240]: #242
+#249 := [trans #243 #247]: #248
+#33 := (- #18 #16)
+#34 := (<= uf_1 #33)
+#35 := (ite #34 uf_1 #33)
+#36 := (/ #35 2::real)
+#37 := (- #18 #36)
+#28 := (- #20 #18)
+#29 := (<= uf_1 #28)
+#30 := (ite #29 uf_1 #28)
+#31 := (/ #30 2::real)
+#32 := (+ #18 #31)
+#27 := (<= #18 #25)
+#38 := (ite #27 #32 #37)
+#39 := (= #38 #18)
+#40 := (not #39)
+#41 := (not #40)
+#220 := (iff #41 #217)
+#141 := (<= uf_1 #138)
+#144 := (ite #141 uf_1 #138)
+#159 := (* -1/2::real #144)
+#160 := (+ #18 #159)
+#120 := (<= uf_1 #117)
+#123 := (ite #120 uf_1 #117)
+#129 := (* 1/2::real #123)
+#134 := (+ #18 #129)
+#114 := (<= #18 #98)
+#165 := (ite #114 #134 #160)
+#171 := (= #18 #165)
+#218 := (iff #171 #217)
+#215 := (= #165 #214)
+#212 := (= #160 #211)
+#209 := (= #159 #208)
+#206 := (= #144 #205)
+#203 := (iff #141 #202)
+#204 := [rewrite]: #203
+#207 := [monotonicity #204]: #206
+#210 := [monotonicity #207]: #209
+#213 := [monotonicity #210]: #212
+#199 := (= #134 #198)
+#196 := (= #129 #195)
+#193 := (= #123 #192)
+#190 := (iff #120 #189)
+#191 := [rewrite]: #190
+#194 := [monotonicity #191]: #193
+#197 := [monotonicity #194]: #196
+#200 := [monotonicity #197]: #199
+#187 := (iff #114 #107)
+#186 := [rewrite]: #187
+#216 := [monotonicity #186 #200 #213]: #215
+#219 := [monotonicity #216]: #218
+#184 := (iff #41 #171)
+#176 := (not #171)
+#179 := (not #176)
+#182 := (iff #179 #171)
+#183 := [rewrite]: #182
+#180 := (iff #41 #179)
+#177 := (iff #40 #176)
+#174 := (iff #39 #171)
+#168 := (= #165 #18)
+#172 := (iff #168 #171)
+#173 := [rewrite]: #172
+#169 := (iff #39 #168)
+#166 := (= #38 #165)
+#163 := (= #37 #160)
+#150 := (* 1/2::real #144)
+#155 := (- #18 #150)
+#161 := (= #155 #160)
+#162 := [rewrite]: #161
+#156 := (= #37 #155)
+#153 := (= #36 #150)
+#147 := (/ #144 2::real)
+#151 := (= #147 #150)
+#152 := [rewrite]: #151
+#148 := (= #36 #147)
+#145 := (= #35 #144)
+#139 := (= #33 #138)
+#140 := [rewrite]: #139
+#142 := (iff #34 #141)
+#143 := [monotonicity #140]: #142
+#146 := [monotonicity #143 #140]: #145
+#149 := [monotonicity #146]: #148
+#154 := [trans #149 #152]: #153
+#157 := [monotonicity #154]: #156
+#164 := [trans #157 #162]: #163
+#135 := (= #32 #134)
+#132 := (= #31 #129)
+#126 := (/ #123 2::real)
+#130 := (= #126 #129)
+#131 := [rewrite]: #130
+#127 := (= #31 #126)
+#124 := (= #30 #123)
+#118 := (= #28 #117)
+#119 := [rewrite]: #118
+#121 := (iff #29 #120)
+#122 := [monotonicity #119]: #121
+#125 := [monotonicity #122 #119]: #124
+#128 := [monotonicity #125]: #127
+#133 := [trans #128 #131]: #132
+#136 := [monotonicity #133]: #135
+#115 := (iff #27 #114)
+#116 := [monotonicity #100]: #115
+#167 := [monotonicity #116 #136 #164]: #166
+#170 := [monotonicity #167]: #169
+#175 := [trans #170 #173]: #174
+#178 := [monotonicity #175]: #177
+#181 := [monotonicity #178]: #180
+#185 := [trans #181 #183]: #184
+#221 := [trans #185 #219]: #220
+#113 := [asserted]: #41
+#222 := [mp #113 #221]: #217
+#250 := [mp #222 #249]: #245
+#356 := (not #245)
+#357 := (or #356 #322)
+#358 := [th-lemma]: #357
+#359 := [unit-resolution #358 #250]: #322
+#360 := [hypothesis]: #354
+#60 := (<= uf_1 0::real)
+#61 := (not #60)
+#6 := (< 0::real uf_1)
+#62 := (iff #6 #61)
+#63 := [rewrite]: #62
+#57 := [asserted]: #6
+#64 := [mp #57 #63]: #61
+#361 := [th-lemma #64 #360 #359]: false
+#363 := [lemma #361]: #362
+#315 := (= uf_1 #205)
+#316 := (= #138 #205)
+#371 := (not #316)
+#355 := (+ #138 #352)
+#364 := (<= #355 0::real)
+#368 := (not #364)
+#87 := (<= #86 0::real)
+#82 := (<= #81 0::real)
+#90 := (and #82 #87)
+#21 := (<= #18 #20)
+#19 := (<= #16 #18)
+#22 := (and #19 #21)
+#91 := (iff #22 #90)
+#88 := (iff #21 #87)
+#89 := [rewrite]: #88
+#83 := (iff #19 #82)
+#84 := [rewrite]: #83
+#92 := [monotonicity #84 #89]: #91
+#59 := [asserted]: #22
+#93 := [mp #59 #92]: #90
+#95 := [and-elim #93]: #87
+#366 := [hypothesis]: #364
+#367 := [th-lemma #366 #95 #112 #359]: false
+#369 := [lemma #367]: #368
+#370 := [hypothesis]: #316
+#372 := (or #371 #364)
+#373 := [th-lemma]: #372
+#374 := [unit-resolution #373 #370 #369]: false
+#375 := [lemma #374]: #371
+#320 := (or #202 #316)
+#321 := [def-axiom]: #320
+#376 := [unit-resolution #321 #375]: #202
+#317 := (not #202)
+#318 := (or #317 #315)
+#319 := [def-axiom]: #318
+#377 := [unit-resolution #319 #376]: #315
+#378 := (not #315)
+#379 := (or #378 #354)
+#380 := [th-lemma]: #379
+[unit-resolution #380 #377 #363]: false
+unsat
+WdMJH3tkMv/rps8y9Ukq5Q 86 0
+#2 := false
+#37 := 0::real
+decl uf_2 :: (-> T2 T1 real)
+decl uf_4 :: T1
+#12 := uf_4
+decl uf_3 :: T2
+#5 := uf_3
+#13 := (uf_2 uf_3 uf_4)
+#34 := -1::real
+#140 := (* -1::real #13)
+decl uf_1 :: real
+#4 := uf_1
+#141 := (+ uf_1 #140)
+#143 := (>= #141 0::real)
+#6 := (:var 0 T1)
+#7 := (uf_2 uf_3 #6)
+#127 := (pattern #7)
+#35 := (* -1::real #7)
+#36 := (+ uf_1 #35)
+#47 := (>= #36 0::real)
+#134 := (forall (vars (?x2 T1)) (:pat #127) #47)
+#49 := (forall (vars (?x2 T1)) #47)
+#137 := (iff #49 #134)
+#135 := (iff #47 #47)
+#136 := [refl]: #135
+#138 := [quant-intro #136]: #137
+#67 := (~ #49 #49)
+#58 := (~ #47 #47)
+#66 := [refl]: #58
+#68 := [nnf-pos #66]: #67
+#10 := (<= #7 uf_1)
+#11 := (forall (vars (?x2 T1)) #10)
+#50 := (iff #11 #49)
+#46 := (iff #10 #47)
+#48 := [rewrite]: #46
+#51 := [quant-intro #48]: #50
+#32 := [asserted]: #11
+#52 := [mp #32 #51]: #49
+#69 := [mp~ #52 #68]: #49
+#139 := [mp #69 #138]: #134
+#149 := (not #134)
+#150 := (or #149 #143)
+#151 := [quant-inst]: #150
+#144 := [unit-resolution #151 #139]: #143
+#142 := (<= #141 0::real)
+#38 := (<= #36 0::real)
+#128 := (forall (vars (?x1 T1)) (:pat #127) #38)
+#41 := (forall (vars (?x1 T1)) #38)
+#131 := (iff #41 #128)
+#129 := (iff #38 #38)
+#130 := [refl]: #129
+#132 := [quant-intro #130]: #131
+#62 := (~ #41 #41)
+#64 := (~ #38 #38)
+#65 := [refl]: #64
+#63 := [nnf-pos #65]: #62
+#8 := (<= uf_1 #7)
+#9 := (forall (vars (?x1 T1)) #8)
+#42 := (iff #9 #41)
+#39 := (iff #8 #38)
+#40 := [rewrite]: #39
+#43 := [quant-intro #40]: #42
+#31 := [asserted]: #9
+#44 := [mp #31 #43]: #41
+#61 := [mp~ #44 #63]: #41
+#133 := [mp #61 #132]: #128
+#145 := (not #128)
+#146 := (or #145 #142)
+#147 := [quant-inst]: #146
+#148 := [unit-resolution #147 #133]: #142
+#45 := (= uf_1 #13)
+#55 := (not #45)
+#14 := (= #13 uf_1)
+#15 := (not #14)
+#56 := (iff #15 #55)
+#53 := (iff #14 #45)
+#54 := [rewrite]: #53
+#57 := [monotonicity #54]: #56
+#33 := [asserted]: #15
+#60 := [mp #33 #57]: #55
+#153 := (not #143)
+#152 := (not #142)
+#154 := (or #45 #152 #153)
+#155 := [th-lemma]: #154
+[unit-resolution #155 #60 #148 #144]: false
+unsat
+V+IAyBZU/6QjYs6JkXx8LQ 57 0
+#2 := false
+#4 := 0::real
+decl uf_1 :: (-> T2 real)
+decl uf_2 :: (-> T1 T1 T2)
+decl uf_12 :: (-> T4 T1)
+decl uf_4 :: T4
+#11 := uf_4
+#39 := (uf_12 uf_4)
+decl uf_10 :: T4
+#27 := uf_10
+#38 := (uf_12 uf_10)
+#40 := (uf_2 #38 #39)
+#41 := (uf_1 #40)
+#264 := (>= #41 0::real)
+#266 := (not #264)
+#43 := (= #41 0::real)
+#44 := (not #43)
+#131 := [asserted]: #44
+#272 := (or #43 #266)
+#42 := (<= #41 0::real)
+#130 := [asserted]: #42
+#265 := (not #42)
+#270 := (or #43 #265 #266)
+#271 := [th-lemma]: #270
+#273 := [unit-resolution #271 #130]: #272
+#274 := [unit-resolution #273 #131]: #266
+#6 := (:var 0 T1)
+#5 := (:var 1 T1)
+#7 := (uf_2 #5 #6)
+#241 := (pattern #7)
+#8 := (uf_1 #7)
+#65 := (>= #8 0::real)
+#242 := (forall (vars (?x1 T1) (?x2 T1)) (:pat #241) #65)
+#66 := (forall (vars (?x1 T1) (?x2 T1)) #65)
+#245 := (iff #66 #242)
+#243 := (iff #65 #65)
+#244 := [refl]: #243
+#246 := [quant-intro #244]: #245
+#149 := (~ #66 #66)
+#151 := (~ #65 #65)
+#152 := [refl]: #151
+#150 := [nnf-pos #152]: #149
+#9 := (<= 0::real #8)
+#10 := (forall (vars (?x1 T1) (?x2 T1)) #9)
+#67 := (iff #10 #66)
+#63 := (iff #9 #65)
+#64 := [rewrite]: #63
+#68 := [quant-intro #64]: #67
+#60 := [asserted]: #10
+#69 := [mp #60 #68]: #66
+#147 := [mp~ #69 #150]: #66
+#247 := [mp #147 #246]: #242
+#267 := (not #242)
+#268 := (or #267 #264)
+#269 := [quant-inst]: #268
+[unit-resolution #269 #247 #274]: false
+unsat
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Multivariate_Analysis/Integration_MV.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,3465 @@
+
+header {* Kurzweil-Henstock gauge integration in many dimensions. *}
+(* Author: John Harrison
+ Translation from HOL light: Robert Himmelmann, TU Muenchen *)
+
+theory Integration_MV
+ imports Derivative SMT
+begin
+
+declare [[smt_certificates="~~/src/HOL/Multivariate_Analysis/Integration_MV.cert"]]
+declare [[smt_record=true]]
+declare [[z3_proofs=true]]
+
+lemma conjunctD2: assumes "a \<and> b" shows a b using assms by auto
+lemma conjunctD3: assumes "a \<and> b \<and> c" shows a b c using assms by auto
+lemma conjunctD4: assumes "a \<and> b \<and> c \<and> d" shows a b c d using assms by auto
+lemma conjunctD5: assumes "a \<and> b \<and> c \<and> d \<and> e" shows a b c d e using assms by auto
+
+declare smult_conv_scaleR[simp]
+
+subsection {* Some useful lemmas about intervals. *}
+
+lemma empty_as_interval: "{} = {1..0::real^'n}"
+ apply(rule set_ext,rule) defer unfolding vector_le_def mem_interval
+ using UNIV_witness[where 'a='n] apply(erule_tac exE,rule_tac x=x in allE) by auto
+
+lemma interior_subset_union_intervals:
+ assumes "i = {a..b::real^'n}" "j = {c..d}" "interior j \<noteq> {}" "i \<subseteq> j \<union> s" "interior(i) \<inter> interior(j) = {}"
+ shows "interior i \<subseteq> interior s" proof-
+ have "{a<..<b} \<inter> {c..d} = {}" using inter_interval_mixed_eq_empty[of c d a b] and assms(3,5)
+ unfolding assms(1,2) interior_closed_interval by auto
+ moreover have "{a<..<b} \<subseteq> {c..d} \<union> s" apply(rule order_trans,rule interval_open_subset_closed)
+ using assms(4) unfolding assms(1,2) by auto
+ ultimately show ?thesis apply-apply(rule interior_maximal) defer apply(rule open_interior)
+ unfolding assms(1,2) interior_closed_interval by auto qed
+
+lemma inter_interior_unions_intervals: fixes f::"(real^'n) set set"
+ assumes "finite f" "open s" "\<forall>t\<in>f. \<exists>a b. t = {a..b}" "\<forall>t\<in>f. s \<inter> (interior t) = {}"
+ shows "s \<inter> interior(\<Union>f) = {}" proof(rule ccontr,unfold ex_in_conv[THEN sym]) case goal1
+ have lem1:"\<And>x e s U. ball x e \<subseteq> s \<inter> interior U \<longleftrightarrow> ball x e \<subseteq> s \<inter> U" apply rule defer apply(rule_tac Int_greatest)
+ unfolding open_subset_interior[OF open_ball] using interior_subset by auto
+ have lem2:"\<And>x s P. \<exists>x\<in>s. P x \<Longrightarrow> \<exists>x\<in>insert x s. P x" by auto
+ have "\<And>f. finite f \<Longrightarrow> (\<forall>t\<in>f. \<exists>a b. t = {a..b}) \<Longrightarrow> (\<exists>x. x \<in> s \<inter> interior (\<Union>f)) \<Longrightarrow> (\<exists>t\<in>f. \<exists>x. \<exists>e>0. ball x e \<subseteq> s \<inter> t)" proof- case goal1
+ thus ?case proof(induct rule:finite_induct)
+ case empty from this(2) guess x .. hence False unfolding Union_empty interior_empty by auto thus ?case by auto next
+ case (insert i f) guess x using insert(5) .. note x = this
+ then guess e unfolding open_contains_ball_eq[OF open_Int[OF assms(2) open_interior],rule_format] .. note e=this
+ guess a using insert(4)[rule_format,OF insertI1] .. then guess b .. note ab = this
+ show ?case proof(cases "x\<in>i") case False hence "x \<in> UNIV - {a..b}" unfolding ab by auto
+ then guess d unfolding open_contains_ball_eq[OF open_Diff[OF open_UNIV closed_interval],rule_format] ..
+ hence "0 < d" "ball x (min d e) \<subseteq> UNIV - i" using e unfolding ab by auto
+ hence "ball x (min d e) \<subseteq> s \<inter> interior (\<Union>f)" using e unfolding lem1 by auto hence "x \<in> s \<inter> interior (\<Union>f)" using `d>0` e by auto
+ hence "\<exists>t\<in>f. \<exists>x e. 0 < e \<and> ball x e \<subseteq> s \<inter> t" apply-apply(rule insert(3)) using insert(4) by auto thus ?thesis by auto next
+ case True show ?thesis proof(cases "x\<in>{a<..<b}")
+ case True then guess d unfolding open_contains_ball_eq[OF open_interval,rule_format] ..
+ thus ?thesis apply(rule_tac x=i in bexI,rule_tac x=x in exI,rule_tac x="min d e" in exI)
+ unfolding ab using interval_open_subset_closed[of a b] and e by fastsimp+ next
+ case False then obtain k where "x$k \<le> a$k \<or> x$k \<ge> b$k" unfolding mem_interval by(auto simp add:not_less)
+ hence "x$k = a$k \<or> x$k = b$k" using True unfolding ab and mem_interval apply(erule_tac x=k in allE) by auto
+ hence "\<exists>x. ball x (e/2) \<subseteq> s \<inter> (\<Union>f)" proof(erule_tac disjE)
+ let ?z = "x - (e/2) *\<^sub>R basis k" assume as:"x$k = a$k" have "ball ?z (e / 2) \<inter> i = {}" apply(rule ccontr) unfolding ex_in_conv[THEN sym] proof(erule exE)
+ fix y assume "y \<in> ball ?z (e / 2) \<inter> i" hence "dist ?z y < e/2" and yi:"y\<in>i" by auto
+ hence "\<bar>(?z - y) $ k\<bar> < e/2" using component_le_norm[of "?z - y" k] unfolding vector_dist_norm by auto
+ hence "y$k < a$k" unfolding vector_component_simps vector_scaleR_component as using e[THEN conjunct1] by(auto simp add:field_simps)
+ hence "y \<notin> i" unfolding ab mem_interval not_all by(rule_tac x=k in exI,auto) thus False using yi by auto qed
+ moreover have "ball ?z (e/2) \<subseteq> s \<inter> (\<Union>insert i f)" apply(rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) proof
+ fix y assume as:"y\<in> ball ?z (e/2)" have "norm (x - y) \<le> \<bar>e\<bar> / 2 + norm (x - y - (e / 2) *\<^sub>R basis k)"
+ apply-apply(rule order_trans,rule norm_triangle_sub[of "x - y" "(e/2) *\<^sub>R basis k"])
+ unfolding norm_scaleR norm_basis by auto
+ also have "\<dots> < \<bar>e\<bar> / 2 + \<bar>e\<bar> / 2" apply(rule add_strict_left_mono) using as unfolding mem_ball vector_dist_norm using e by(auto simp add:field_simps)
+ finally show "y\<in>ball x e" unfolding mem_ball vector_dist_norm using e by(auto simp add:field_simps) qed
+ ultimately show ?thesis apply(rule_tac x="?z" in exI) unfolding Union_insert by auto
+ next let ?z = "x + (e/2) *\<^sub>R basis k" assume as:"x$k = b$k" have "ball ?z (e / 2) \<inter> i = {}" apply(rule ccontr) unfolding ex_in_conv[THEN sym] proof(erule exE)
+ fix y assume "y \<in> ball ?z (e / 2) \<inter> i" hence "dist ?z y < e/2" and yi:"y\<in>i" by auto
+ hence "\<bar>(?z - y) $ k\<bar> < e/2" using component_le_norm[of "?z - y" k] unfolding vector_dist_norm by auto
+ hence "y$k > b$k" unfolding vector_component_simps vector_scaleR_component as using e[THEN conjunct1] by(auto simp add:field_simps)
+ hence "y \<notin> i" unfolding ab mem_interval not_all by(rule_tac x=k in exI,auto) thus False using yi by auto qed
+ moreover have "ball ?z (e/2) \<subseteq> s \<inter> (\<Union>insert i f)" apply(rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) proof
+ fix y assume as:"y\<in> ball ?z (e/2)" have "norm (x - y) \<le> \<bar>e\<bar> / 2 + norm (x - y + (e / 2) *\<^sub>R basis k)"
+ apply-apply(rule order_trans,rule norm_triangle_sub[of "x - y" "- (e/2) *\<^sub>R basis k"])
+ unfolding norm_scaleR norm_basis by auto
+ also have "\<dots> < \<bar>e\<bar> / 2 + \<bar>e\<bar> / 2" apply(rule add_strict_left_mono) using as unfolding mem_ball vector_dist_norm using e by(auto simp add:field_simps)
+ finally show "y\<in>ball x e" unfolding mem_ball vector_dist_norm using e by(auto simp add:field_simps) qed
+ ultimately show ?thesis apply(rule_tac x="?z" in exI) unfolding Union_insert by auto qed
+ then guess x .. hence "x \<in> s \<inter> interior (\<Union>f)" unfolding lem1[where U="\<Union>f",THEN sym] using centre_in_ball e[THEN conjunct1] by auto
+ thus ?thesis apply-apply(rule lem2,rule insert(3)) using insert(4) by auto qed qed qed qed note * = this
+ guess t using *[OF assms(1,3) goal1] .. from this(2) guess x .. then guess e ..
+ hence "x \<in> s" "x\<in>interior t" defer using open_subset_interior[OF open_ball, of x e t] by auto
+ thus False using `t\<in>f` assms(4) by auto qed
+subsection {* Bounds on intervals where they exist. *}
+
+definition "interval_upperbound (s::(real^'n) set) = (\<chi> i. Sup {a. \<exists>x\<in>s. x$i = a})"
+
+definition "interval_lowerbound (s::(real^'n) set) = (\<chi> i. Inf {a. \<exists>x\<in>s. x$i = a})"
+
+lemma interval_upperbound[simp]: assumes "\<forall>i. a$i \<le> b$i" shows "interval_upperbound {a..b} = b"
+ using assms unfolding interval_upperbound_def Cart_eq Cart_lambda_beta apply-apply(rule,erule_tac x=i in allE)
+ apply(rule Sup_unique) unfolding setle_def apply rule unfolding mem_Collect_eq apply(erule bexE) unfolding mem_interval defer
+ apply(rule,rule) apply(rule_tac x="b$i" in bexI) defer unfolding mem_Collect_eq apply(rule_tac x=b in bexI)
+ unfolding mem_interval using assms by auto
+
+lemma interval_lowerbound[simp]: assumes "\<forall>i. a$i \<le> b$i" shows "interval_lowerbound {a..b} = a"
+ using assms unfolding interval_lowerbound_def Cart_eq Cart_lambda_beta apply-apply(rule,erule_tac x=i in allE)
+ apply(rule Inf_unique) unfolding setge_def apply rule unfolding mem_Collect_eq apply(erule bexE) unfolding mem_interval defer
+ apply(rule,rule) apply(rule_tac x="a$i" in bexI) defer unfolding mem_Collect_eq apply(rule_tac x=a in bexI)
+ unfolding mem_interval using assms by auto
+
+lemmas interval_bounds = interval_upperbound interval_lowerbound
+
+lemma interval_bounds'[simp]: assumes "{a..b}\<noteq>{}" shows "interval_upperbound {a..b} = b" "interval_lowerbound {a..b} = a"
+ using assms unfolding interval_ne_empty by auto
+
+lemma interval_upperbound_1[simp]: "dest_vec1 a \<le> dest_vec1 b \<Longrightarrow> interval_upperbound {a..b} = (b::real^1)"
+ apply(rule interval_upperbound) by auto
+
+lemma interval_lowerbound_1[simp]: "dest_vec1 a \<le> dest_vec1 b \<Longrightarrow> interval_lowerbound {a..b} = (a::real^1)"
+ apply(rule interval_lowerbound) by auto
+
+lemmas interval_bound_1 = interval_upperbound_1 interval_lowerbound_1
+
+subsection {* Content (length, area, volume...) of an interval. *}
+
+definition "content (s::(real^'n) set) =
+ (if s = {} then 0 else (\<Prod>i\<in>UNIV. (interval_upperbound s)$i - (interval_lowerbound s)$i))"
+
+lemma interval_not_empty:"\<forall>i. a$i \<le> b$i \<Longrightarrow> {a..b::real^'n} \<noteq> {}"
+ unfolding interval_eq_empty unfolding not_ex not_less by assumption
+
+lemma content_closed_interval: assumes "\<forall>i. a$i \<le> b$i"
+ shows "content {a..b} = (\<Prod>i\<in>UNIV. b$i - a$i)"
+ using interval_not_empty[OF assms] unfolding content_def interval_upperbound[OF assms] interval_lowerbound[OF assms] by auto
+
+lemma content_closed_interval': assumes "{a..b}\<noteq>{}" shows "content {a..b} = (\<Prod>i\<in>UNIV. b$i - a$i)"
+ apply(rule content_closed_interval) using assms unfolding interval_ne_empty .
+
+lemma content_1:"dest_vec1 a \<le> dest_vec1 b \<Longrightarrow> content {a..b} = dest_vec1 b - dest_vec1 a"
+ using content_closed_interval[of a b] by auto
+
+lemma content_1':"a \<le> b \<Longrightarrow> content {vec1 a..vec1 b} = b - a" using content_1[of "vec a" "vec b"] by auto
+
+lemma content_unit[intro]: "content{0..1::real^'n} = 1" proof-
+ have *:"\<forall>i. 0$i \<le> (1::real^'n::finite)$i" by auto
+ have "0 \<in> {0..1::real^'n::finite}" unfolding mem_interval by auto
+ thus ?thesis unfolding content_def interval_bounds[OF *] using setprod_1 by auto qed
+
+lemma content_pos_le[intro]: "0 \<le> content {a..b}" proof(cases "{a..b}={}")
+ case False hence *:"\<forall>i. a $ i \<le> b $ i" unfolding interval_ne_empty by assumption
+ have "(\<Prod>i\<in>UNIV. interval_upperbound {a..b} $ i - interval_lowerbound {a..b} $ i) \<ge> 0"
+ apply(rule setprod_nonneg) unfolding interval_bounds[OF *] using * apply(erule_tac x=x in allE) by auto
+ thus ?thesis unfolding content_def by(auto simp del:interval_bounds') qed(unfold content_def, auto)
+
+lemma content_pos_lt: assumes "\<forall>i. a$i < b$i" shows "0 < content {a..b}"
+proof- have help_lemma1: "\<forall>i. a$i < b$i \<Longrightarrow> \<forall>i. a$i \<le> ((b$i)::real)" apply(rule,erule_tac x=i in allE) by auto
+ show ?thesis unfolding content_closed_interval[OF help_lemma1[OF assms]] apply(rule setprod_pos)
+ using assms apply(erule_tac x=x in allE) by auto qed
+
+lemma content_pos_lt_1: "dest_vec1 a < dest_vec1 b \<Longrightarrow> 0 < content({a..b})"
+ apply(rule content_pos_lt) by auto
+
+lemma content_eq_0: "content({a..b::real^'n}) = 0 \<longleftrightarrow> (\<exists>i. b$i \<le> a$i)" proof(cases "{a..b} = {}")
+ case True thus ?thesis unfolding content_def if_P[OF True] unfolding interval_eq_empty apply-
+ apply(rule,erule exE) apply(rule_tac x=i in exI) by auto next
+ guess a using UNIV_witness[where 'a='n] .. case False note as=this[unfolded interval_eq_empty not_ex not_less]
+ show ?thesis unfolding content_def if_not_P[OF False] setprod_zero_iff[OF finite_UNIV]
+ apply(rule) apply(erule_tac[!] exE bexE) unfolding interval_bounds[OF as] apply(rule_tac x=x in exI) defer
+ apply(rule_tac x=i in bexI) using as apply(erule_tac x=i in allE) by auto qed
+
+lemma cond_cases:"(P \<Longrightarrow> Q x) \<Longrightarrow> (\<not> P \<Longrightarrow> Q y) \<Longrightarrow> Q (if P then x else y)" by auto
+
+lemma content_closed_interval_cases:
+ "content {a..b} = (if \<forall>i. a$i \<le> b$i then setprod (\<lambda>i. b$i - a$i) UNIV else 0)" apply(rule cond_cases)
+ apply(rule content_closed_interval) unfolding content_eq_0 not_all not_le defer apply(erule exE,rule_tac x=x in exI) by auto
+
+lemma content_eq_0_interior: "content {a..b} = 0 \<longleftrightarrow> interior({a..b}) = {}"
+ unfolding content_eq_0 interior_closed_interval interval_eq_empty by auto
+
+lemma content_eq_0_1: "content {a..b::real^1} = 0 \<longleftrightarrow> dest_vec1 b \<le> dest_vec1 a"
+ unfolding content_eq_0 by auto
+
+lemma content_pos_lt_eq: "0 < content {a..b} \<longleftrightarrow> (\<forall>i. a$i < b$i)"
+ apply(rule) defer apply(rule content_pos_lt,assumption) proof- assume "0 < content {a..b}"
+ hence "content {a..b} \<noteq> 0" by auto thus "\<forall>i. a$i < b$i" unfolding content_eq_0 not_ex not_le by auto qed
+
+lemma content_empty[simp]: "content {} = 0" unfolding content_def by auto
+
+lemma content_subset: assumes "{a..b} \<subseteq> {c..d}" shows "content {a..b::real^'n} \<le> content {c..d}" proof(cases "{a..b}={}")
+ case True thus ?thesis using content_pos_le[of c d] by auto next
+ case False hence ab_ne:"\<forall>i. a $ i \<le> b $ i" unfolding interval_ne_empty by auto
+ hence ab_ab:"a\<in>{a..b}" "b\<in>{a..b}" unfolding mem_interval by auto
+ have "{c..d} \<noteq> {}" using assms False by auto
+ hence cd_ne:"\<forall>i. c $ i \<le> d $ i" using assms unfolding interval_ne_empty by auto
+ show ?thesis unfolding content_def unfolding interval_bounds[OF ab_ne] interval_bounds[OF cd_ne]
+ unfolding if_not_P[OF False] if_not_P[OF `{c..d} \<noteq> {}`] apply(rule setprod_mono,rule) proof fix i::'n
+ show "0 \<le> b $ i - a $ i" using ab_ne[THEN spec[where x=i]] by auto
+ show "b $ i - a $ i \<le> d $ i - c $ i"
+ using assms[unfolded subset_eq mem_interval,rule_format,OF ab_ab(2),of i]
+ using assms[unfolded subset_eq mem_interval,rule_format,OF ab_ab(1),of i] by auto qed qed
+
+lemma content_lt_nz: "0 < content {a..b} \<longleftrightarrow> content {a..b} \<noteq> 0"
+ unfolding content_pos_lt_eq content_eq_0 unfolding not_ex not_le by auto
+
+subsection {* The notion of a gauge --- simply an open set containing the point. *}
+
+definition gauge where "gauge d \<longleftrightarrow> (\<forall>x. x\<in>(d x) \<and> open(d x))"
+
+lemma gaugeI:assumes "\<And>x. x\<in>g x" "\<And>x. open (g x)" shows "gauge g"
+ using assms unfolding gauge_def by auto
+
+lemma gaugeD[dest]: assumes "gauge d" shows "x\<in>d x" "open (d x)" using assms unfolding gauge_def by auto
+
+lemma gauge_ball_dependent: "\<forall>x. 0 < e x \<Longrightarrow> gauge (\<lambda>x. ball x (e x))"
+ unfolding gauge_def by auto
+
+lemma gauge_ball[intro?]: "0 < e \<Longrightarrow> gauge (\<lambda>x. ball x e)" unfolding gauge_def by auto
+
+lemma gauge_trivial[intro]: "gauge (\<lambda>x. ball x 1)" apply(rule gauge_ball) by auto
+
+lemma gauge_inter: "gauge d1 \<Longrightarrow> gauge d2 \<Longrightarrow> gauge (\<lambda>x. (d1 x) \<inter> (d2 x))"
+ unfolding gauge_def by auto
+
+lemma gauge_inters: assumes "finite s" "\<forall>d\<in>s. gauge (f d)" shows "gauge(\<lambda>x. \<Inter> {f d x | d. d \<in> s})" proof-
+ have *:"\<And>x. {f d x |d. d \<in> s} = (\<lambda>d. f d x) ` s" by auto show ?thesis
+ unfolding gauge_def unfolding *
+ using assms unfolding Ball_def Inter_iff mem_Collect_eq gauge_def by auto qed
+
+lemma gauge_existence_lemma: "(\<forall>x. \<exists>d::real. p x \<longrightarrow> 0 < d \<and> q d x) \<longleftrightarrow> (\<forall>x. \<exists>d>0. p x \<longrightarrow> q d x)" by(meson zero_less_one)
+
+subsection {* Divisions. *}
+
+definition division_of (infixl "division'_of" 40) where
+ "s division_of i \<equiv>
+ finite s \<and>
+ (\<forall>k\<in>s. k \<subseteq> i \<and> k \<noteq> {} \<and> (\<exists>a b. k = {a..b})) \<and>
+ (\<forall>k1\<in>s. \<forall>k2\<in>s. k1 \<noteq> k2 \<longrightarrow> interior(k1) \<inter> interior(k2) = {}) \<and>
+ (\<Union>s = i)"
+
+lemma division_ofD[dest]: assumes "s division_of i"
+ shows"finite s" "\<And>k. k\<in>s \<Longrightarrow> k \<subseteq> i" "\<And>k. k\<in>s \<Longrightarrow> k \<noteq> {}" "\<And>k. k\<in>s \<Longrightarrow> (\<exists>a b. k = {a..b})"
+ "\<And>k1 k2. \<lbrakk>k1\<in>s; k2\<in>s; k1 \<noteq> k2\<rbrakk> \<Longrightarrow> interior(k1) \<inter> interior(k2) = {}" "\<Union>s = i" using assms unfolding division_of_def by auto
+
+lemma division_ofI:
+ assumes "finite s" "\<And>k. k\<in>s \<Longrightarrow> k \<subseteq> i" "\<And>k. k\<in>s \<Longrightarrow> k \<noteq> {}" "\<And>k. k\<in>s \<Longrightarrow> (\<exists>a b. k = {a..b})"
+ "\<And>k1 k2. \<lbrakk>k1\<in>s; k2\<in>s; k1 \<noteq> k2\<rbrakk> \<Longrightarrow> interior(k1) \<inter> interior(k2) = {}" "\<Union>s = i"
+ shows "s division_of i" using assms unfolding division_of_def by auto
+
+lemma division_of_finite: "s division_of i \<Longrightarrow> finite s"
+ unfolding division_of_def by auto
+
+lemma division_of_self[intro]: "{a..b} \<noteq> {} \<Longrightarrow> {{a..b}} division_of {a..b}"
+ unfolding division_of_def by auto
+
+lemma division_of_trivial[simp]: "s division_of {} \<longleftrightarrow> s = {}" unfolding division_of_def by auto
+
+lemma division_of_sing[simp]: "s division_of {a..a::real^'n} \<longleftrightarrow> s = {{a..a}}" (is "?l = ?r") proof
+ assume ?r moreover { assume "s = {{a}}" moreover fix k assume "k\<in>s"
+ ultimately have"\<exists>x y. k = {x..y}" apply(rule_tac x=a in exI)+ unfolding interval_sing[THEN conjunct1] by auto }
+ ultimately show ?l unfolding division_of_def interval_sing[THEN conjunct1] by auto next
+ assume ?l note as=conjunctD4[OF this[unfolded division_of_def interval_sing[THEN conjunct1]]]
+ { fix x assume x:"x\<in>s" have "x={a}" using as(2)[rule_format,OF x] by auto }
+ moreover have "s \<noteq> {}" using as(4) by auto ultimately show ?r unfolding interval_sing[THEN conjunct1] by auto qed
+
+lemma elementary_empty: obtains p where "p division_of {}"
+ unfolding division_of_trivial by auto
+
+lemma elementary_interval: obtains p where "p division_of {a..b}"
+ by(metis division_of_trivial division_of_self)
+
+lemma division_contains: "s division_of i \<Longrightarrow> \<forall>x\<in>i. \<exists>k\<in>s. x \<in> k"
+ unfolding division_of_def by auto
+
+lemma forall_in_division:
+ "d division_of i \<Longrightarrow> ((\<forall>x\<in>d. P x) \<longleftrightarrow> (\<forall>a b. {a..b} \<in> d \<longrightarrow> P {a..b}))"
+ unfolding division_of_def by fastsimp
+
+lemma division_of_subset: assumes "p division_of (\<Union>p)" "q \<subseteq> p" shows "q division_of (\<Union>q)"
+ apply(rule division_ofI) proof- note as=division_ofD[OF assms(1)]
+ show "finite q" apply(rule finite_subset) using as(1) assms(2) by auto
+ { fix k assume "k \<in> q" hence kp:"k\<in>p" using assms(2) by auto show "k\<subseteq>\<Union>q" using `k \<in> q` by auto
+ show "\<exists>a b. k = {a..b}" using as(4)[OF kp] by auto show "k \<noteq> {}" using as(3)[OF kp] by auto }
+ fix k1 k2 assume "k1 \<in> q" "k2 \<in> q" "k1 \<noteq> k2" hence *:"k1\<in>p" "k2\<in>p" "k1\<noteq>k2" using assms(2) by auto
+ show "interior k1 \<inter> interior k2 = {}" using as(5)[OF *] by auto qed auto
+
+lemma division_of_union_self[intro]: "p division_of s \<Longrightarrow> p division_of (\<Union>p)" unfolding division_of_def by auto
+
+lemma division_of_content_0: assumes "content {a..b} = 0" "d division_of {a..b}" shows "\<forall>k\<in>d. content k = 0"
+ unfolding forall_in_division[OF assms(2)] apply(rule,rule,rule) apply(drule division_ofD(2)[OF assms(2)])
+ apply(drule content_subset) unfolding assms(1) proof- case goal1 thus ?case using content_pos_le[of a b] by auto qed
+
+lemma division_inter: assumes "p1 division_of s1" "p2 division_of (s2::(real^'a) set)"
+ shows "{k1 \<inter> k2 | k1 k2 .k1 \<in> p1 \<and> k2 \<in> p2 \<and> k1 \<inter> k2 \<noteq> {}} division_of (s1 \<inter> s2)" (is "?A' division_of _") proof-
+let ?A = "{s. s \<in> (\<lambda>(k1,k2). k1 \<inter> k2) ` (p1 \<times> p2) \<and> s \<noteq> {}}" have *:"?A' = ?A" by auto
+show ?thesis unfolding * proof(rule division_ofI) have "?A \<subseteq> (\<lambda>(x, y). x \<inter> y) ` (p1 \<times> p2)" by auto
+ moreover have "finite (p1 \<times> p2)" using assms unfolding division_of_def by auto ultimately show "finite ?A" by auto
+ have *:"\<And>s. \<Union>{x\<in>s. x \<noteq> {}} = \<Union>s" by auto show "\<Union>?A = s1 \<inter> s2" apply(rule set_ext) unfolding * and Union_image_eq UN_iff
+ using division_ofD(6)[OF assms(1)] and division_ofD(6)[OF assms(2)] by auto
+ { fix k assume "k\<in>?A" then obtain k1 k2 where k:"k = k1 \<inter> k2" "k1\<in>p1" "k2\<in>p2" "k\<noteq>{}" by auto thus "k \<noteq> {}" by auto
+ show "k \<subseteq> s1 \<inter> s2" using division_ofD(2)[OF assms(1) k(2)] and division_ofD(2)[OF assms(2) k(3)] unfolding k by auto
+ guess a1 using division_ofD(4)[OF assms(1) k(2)] .. then guess b1 .. note ab1=this
+ guess a2 using division_ofD(4)[OF assms(2) k(3)] .. then guess b2 .. note ab2=this
+ show "\<exists>a b. k = {a..b}" unfolding k ab1 ab2 unfolding inter_interval by auto } fix k1 k2
+ assume "k1\<in>?A" then obtain x1 y1 where k1:"k1 = x1 \<inter> y1" "x1\<in>p1" "y1\<in>p2" "k1\<noteq>{}" by auto
+ assume "k2\<in>?A" then obtain x2 y2 where k2:"k2 = x2 \<inter> y2" "x2\<in>p1" "y2\<in>p2" "k2\<noteq>{}" by auto
+ assume "k1 \<noteq> k2" hence th:"x1\<noteq>x2 \<or> y1\<noteq>y2" unfolding k1 k2 by auto
+ have *:"(interior x1 \<inter> interior x2 = {} \<or> interior y1 \<inter> interior y2 = {}) \<Longrightarrow>
+ interior(x1 \<inter> y1) \<subseteq> interior(x1) \<Longrightarrow> interior(x1 \<inter> y1) \<subseteq> interior(y1) \<Longrightarrow>
+ interior(x2 \<inter> y2) \<subseteq> interior(x2) \<Longrightarrow> interior(x2 \<inter> y2) \<subseteq> interior(y2)
+ \<Longrightarrow> interior(x1 \<inter> y1) \<inter> interior(x2 \<inter> y2) = {}" by auto
+ show "interior k1 \<inter> interior k2 = {}" unfolding k1 k2 apply(rule *) defer apply(rule_tac[1-4] subset_interior)
+ using division_ofD(5)[OF assms(1) k1(2) k2(2)]
+ using division_ofD(5)[OF assms(2) k1(3) k2(3)] using th by auto qed qed
+
+lemma division_inter_1: assumes "d division_of i" "{a..b::real^'n} \<subseteq> i"
+ shows "{ {a..b} \<inter> k |k. k \<in> d \<and> {a..b} \<inter> k \<noteq> {} } division_of {a..b}" proof(cases "{a..b} = {}")
+ case True show ?thesis unfolding True and division_of_trivial by auto next
+ have *:"{a..b} \<inter> i = {a..b}" using assms(2) by auto
+ case False show ?thesis using division_inter[OF division_of_self[OF False] assms(1)] unfolding * by auto qed
+
+lemma elementary_inter: assumes "p1 division_of s" "p2 division_of (t::(real^'n) set)"
+ shows "\<exists>p. p division_of (s \<inter> t)"
+ by(rule,rule division_inter[OF assms])
+
+lemma elementary_inters: assumes "finite f" "f\<noteq>{}" "\<forall>s\<in>f. \<exists>p. p division_of (s::(real^'n) set)"
+ shows "\<exists>p. p division_of (\<Inter> f)" using assms apply-proof(induct f rule:finite_induct)
+case (insert x f) show ?case proof(cases "f={}")
+ case True thus ?thesis unfolding True using insert by auto next
+ case False guess p using insert(3)[OF False insert(5)[unfolded ball_simps,THEN conjunct2]] ..
+ moreover guess px using insert(5)[rule_format,OF insertI1] .. ultimately
+ show ?thesis unfolding Inter_insert apply(rule_tac elementary_inter) by assumption+ qed qed auto
+
+lemma division_disjoint_union:
+ assumes "p1 division_of s1" "p2 division_of s2" "interior s1 \<inter> interior s2 = {}"
+ shows "(p1 \<union> p2) division_of (s1 \<union> s2)" proof(rule division_ofI)
+ note d1 = division_ofD[OF assms(1)] and d2 = division_ofD[OF assms(2)]
+ show "finite (p1 \<union> p2)" using d1(1) d2(1) by auto
+ show "\<Union>(p1 \<union> p2) = s1 \<union> s2" using d1(6) d2(6) by auto
+ { fix k1 k2 assume as:"k1 \<in> p1 \<union> p2" "k2 \<in> p1 \<union> p2" "k1 \<noteq> k2" moreover let ?g="interior k1 \<inter> interior k2 = {}"
+ { assume as:"k1\<in>p1" "k2\<in>p2" have ?g using subset_interior[OF d1(2)[OF as(1)]] subset_interior[OF d2(2)[OF as(2)]]
+ using assms(3) by blast } moreover
+ { assume as:"k1\<in>p2" "k2\<in>p1" have ?g using subset_interior[OF d1(2)[OF as(2)]] subset_interior[OF d2(2)[OF as(1)]]
+ using assms(3) by blast} ultimately
+ show ?g using d1(5)[OF _ _ as(3)] and d2(5)[OF _ _ as(3)] by auto }
+ fix k assume k:"k \<in> p1 \<union> p2" show "k \<subseteq> s1 \<union> s2" using k d1(2) d2(2) by auto
+ show "k \<noteq> {}" using k d1(3) d2(3) by auto show "\<exists>a b. k = {a..b}" using k d1(4) d2(4) by auto qed
+
+lemma partial_division_extend_1:
+ assumes "{c..d} \<subseteq> {a..b::real^'n}" "{c..d} \<noteq> {}"
+ obtains p where "p division_of {a..b}" "{c..d} \<in> p"
+proof- def n \<equiv> "CARD('n)" have n:"1 \<le> n" "0 < n" "n \<noteq> 0" unfolding n_def by auto
+ guess \<pi> using ex_bij_betw_nat_finite_1[OF finite_UNIV[where 'a='n]] .. note \<pi>=this
+ def \<pi>' \<equiv> "inv_into {1..n} \<pi>"
+ have \<pi>':"bij_betw \<pi>' UNIV {1..n}" using bij_betw_inv_into[OF \<pi>] unfolding \<pi>'_def n_def by auto
+ hence \<pi>'i:"\<And>i. \<pi>' i \<in> {1..n}" unfolding bij_betw_def by auto
+ have \<pi>\<pi>'[simp]:"\<And>i. \<pi> (\<pi>' i) = i" unfolding \<pi>'_def apply(rule f_inv_into_f) unfolding n_def using \<pi> unfolding bij_betw_def by auto
+ have \<pi>'\<pi>[simp]:"\<And>i. i\<in>{1..n} \<Longrightarrow> \<pi>' (\<pi> i) = i" unfolding \<pi>'_def apply(rule inv_into_f_eq) using \<pi> unfolding n_def bij_betw_def by auto
+ have "{c..d} \<noteq> {}" using assms by auto
+ let ?p1 = "\<lambda>l. {(\<chi> i. if \<pi>' i < l then c$i else a$i) .. (\<chi> i. if \<pi>' i < l then d$i else if \<pi>' i = l then c$\<pi> l else b$i)}"
+ let ?p2 = "\<lambda>l. {(\<chi> i. if \<pi>' i < l then c$i else if \<pi>' i = l then d$\<pi> l else a$i) .. (\<chi> i. if \<pi>' i < l then d$i else b$i)}"
+ let ?p = "{?p1 l |l. l \<in> {1..n+1}} \<union> {?p2 l |l. l \<in> {1..n+1}}"
+ have abcd:"\<And>i. a $ i \<le> c $ i \<and> c$i \<le> d$i \<and> d $ i \<le> b $ i" using assms unfolding subset_interval interval_eq_empty by(auto simp add:not_le not_less)
+ show ?thesis apply(rule that[of ?p]) apply(rule division_ofI)
+ proof- have "\<And>i. \<pi>' i < Suc n"
+ proof(rule ccontr,unfold not_less) fix i assume "Suc n \<le> \<pi>' i"
+ hence "\<pi>' i \<notin> {1..n}" by auto thus False using \<pi>' unfolding bij_betw_def by auto
+ qed hence "c = (\<chi> i. if \<pi>' i < Suc n then c $ i else a $ i)"
+ "d = (\<chi> i. if \<pi>' i < Suc n then d $ i else if \<pi>' i = n + 1 then c $ \<pi> (n + 1) else b $ i)"
+ unfolding Cart_eq Cart_lambda_beta using \<pi>' unfolding bij_betw_def by auto
+ thus cdp:"{c..d} \<in> ?p" apply-apply(rule UnI1) unfolding mem_Collect_eq apply(rule_tac x="n + 1" in exI) by auto
+ have "\<And>l. l\<in>{1..n+1} \<Longrightarrow> ?p1 l \<subseteq> {a..b}" "\<And>l. l\<in>{1..n+1} \<Longrightarrow> ?p2 l \<subseteq> {a..b}"
+ unfolding subset_eq apply(rule_tac[!] ballI,rule_tac[!] ccontr)
+ proof- fix l assume l:"l\<in>{1..n+1}" fix x assume "x\<notin>{a..b}"
+ then guess i unfolding mem_interval not_all .. note i=this
+ show "x \<in> ?p1 l \<Longrightarrow> False" "x \<in> ?p2 l \<Longrightarrow> False" unfolding mem_interval apply(erule_tac[!] x=i in allE)
+ apply(case_tac[!] "\<pi>' i < l", case_tac[!] "\<pi>' i = l") using abcd[of i] i by auto
+ qed moreover have "\<And>x. x \<in> {a..b} \<Longrightarrow> x \<in> \<Union>?p"
+ proof- fix x assume x:"x\<in>{a..b}"
+ { presume "x\<notin>{c..d} \<Longrightarrow> x \<in> \<Union>?p" thus "x \<in> \<Union>?p" using cdp by blast }
+ let ?M = "{i. i\<in>{1..n+1} \<and> \<not> (c $ \<pi> i \<le> x $ \<pi> i \<and> x $ \<pi> i \<le> d $ \<pi> i)}"
+ assume "x\<notin>{c..d}" then guess i0 unfolding mem_interval not_all ..
+ hence "\<pi>' i0 \<in> ?M" using \<pi>' unfolding bij_betw_def by(auto intro!:le_SucI)
+ hence M:"finite ?M" "?M \<noteq> {}" by auto
+ def l \<equiv> "Min ?M" note l = Min_less_iff[OF M,unfolded l_def[symmetric]] Min_in[OF M,unfolded mem_Collect_eq l_def[symmetric]]
+ Min_gr_iff[OF M,unfolded l_def[symmetric]]
+ have "x\<in>?p1 l \<or> x\<in>?p2 l" using l(2)[THEN conjunct2] unfolding de_Morgan_conj not_le
+ apply- apply(erule disjE) apply(rule disjI1) defer apply(rule disjI2)
+ proof- assume as:"x $ \<pi> l < c $ \<pi> l"
+ show "x \<in> ?p1 l" unfolding mem_interval Cart_lambda_beta
+ proof case goal1 have "\<pi>' i \<in> {1..n}" using \<pi>' unfolding bij_betw_def not_le by auto
+ thus ?case using as x[unfolded mem_interval,rule_format,of i]
+ apply auto using l(3)[of "\<pi>' i"] by(auto elim!:ballE[where x="\<pi>' i"])
+ qed
+ next assume as:"x $ \<pi> l > d $ \<pi> l"
+ show "x \<in> ?p2 l" unfolding mem_interval Cart_lambda_beta
+ proof case goal1 have "\<pi>' i \<in> {1..n}" using \<pi>' unfolding bij_betw_def not_le by auto
+ thus ?case using as x[unfolded mem_interval,rule_format,of i]
+ apply auto using l(3)[of "\<pi>' i"] by(auto elim!:ballE[where x="\<pi>' i"])
+ qed qed
+ thus "x \<in> \<Union>?p" using l(2) by blast
+ qed ultimately show "\<Union>?p = {a..b}" apply-apply(rule) defer apply(rule) by(assumption,blast)
+
+ show "finite ?p" by auto
+ fix k assume k:"k\<in>?p" then obtain l where l:"k = ?p1 l \<or> k = ?p2 l" "l \<in> {1..n + 1}" by auto
+ show "k\<subseteq>{a..b}" apply(rule,unfold mem_interval,rule,rule)
+ proof- fix i::'n and x assume "x \<in> k" moreover have "\<pi>' i < l \<or> \<pi>' i = l \<or> \<pi>' i > l" by auto
+ ultimately show "a$i \<le> x$i" "x$i \<le> b$i" using abcd[of i] using l by(auto elim:disjE elim!:allE[where x=i] simp add:vector_le_def)
+ qed have "\<And>l. ?p1 l \<noteq> {}" "\<And>l. ?p2 l \<noteq> {}" unfolding interval_eq_empty not_ex apply(rule_tac[!] allI)
+ proof- case goal1 thus ?case using abcd[of x] by auto
+ next case goal2 thus ?case using abcd[of x] by auto
+ qed thus "k \<noteq> {}" using k by auto
+ show "\<exists>a b. k = {a..b}" using k by auto
+ fix k' assume k':"k' \<in> ?p" "k \<noteq> k'" then obtain l' where l':"k' = ?p1 l' \<or> k' = ?p2 l'" "l' \<in> {1..n + 1}" by auto
+ { fix k k' l l'
+ assume k:"k\<in>?p" and l:"k = ?p1 l \<or> k = ?p2 l" "l \<in> {1..n + 1}"
+ assume k':"k' \<in> ?p" "k \<noteq> k'" and l':"k' = ?p1 l' \<or> k' = ?p2 l'" "l' \<in> {1..n + 1}"
+ assume "l \<le> l'" fix x
+ have "x \<notin> interior k \<inter> interior k'"
+ proof(rule,cases "l' = n+1") assume x:"x \<in> interior k \<inter> interior k'"
+ case True hence "\<And>i. \<pi>' i < l'" using \<pi>'i by(auto simp add:less_Suc_eq_le)
+ hence k':"k' = {c..d}" using l'(1) \<pi>'i by(auto simp add:Cart_nth_inverse)
+ have ln:"l < n + 1"
+ proof(rule ccontr) case goal1 hence l2:"l = n+1" using l by auto
+ hence "\<And>i. \<pi>' i < l" using \<pi>'i by(auto simp add:less_Suc_eq_le)
+ hence "k = {c..d}" using l(1) \<pi>'i by(auto simp add:Cart_nth_inverse)
+ thus False using `k\<noteq>k'` k' by auto
+ qed have **:"\<pi>' (\<pi> l) = l" using \<pi>'\<pi>[of l] using l ln by auto
+ have "x $ \<pi> l < c $ \<pi> l \<or> d $ \<pi> l < x $ \<pi> l" using l(1) apply-
+ proof(erule disjE)
+ assume as:"k = ?p1 l" note * = conjunct1[OF x[unfolded as Int_iff interior_closed_interval mem_interval],rule_format]
+ show ?thesis using *[of "\<pi> l"] using ln unfolding Cart_lambda_beta ** by auto
+ next assume as:"k = ?p2 l" note * = conjunct1[OF x[unfolded as Int_iff interior_closed_interval mem_interval],rule_format]
+ show ?thesis using *[of "\<pi> l"] using ln unfolding Cart_lambda_beta ** by auto
+ qed thus False using x unfolding k' unfolding Int_iff interior_closed_interval mem_interval
+ by(auto elim!:allE[where x="\<pi> l"])
+ next case False hence "l < n + 1" using l'(2) using `l\<le>l'` by auto
+ hence ln:"l \<in> {1..n}" "l' \<in> {1..n}" using l l' False by auto
+ note \<pi>l = \<pi>'\<pi>[OF ln(1)] \<pi>'\<pi>[OF ln(2)]
+ assume x:"x \<in> interior k \<inter> interior k'"
+ show False using l(1) l'(1) apply-
+ proof(erule_tac[!] disjE)+
+ assume as:"k = ?p1 l" "k' = ?p1 l'"
+ note * = x[unfolded as Int_iff interior_closed_interval mem_interval]
+ have "l \<noteq> l'" using k'(2)[unfolded as] by auto
+ thus False using * by(smt Cart_lambda_beta \<pi>l)
+ next assume as:"k = ?p2 l" "k' = ?p2 l'"
+ note * = conjunctD2[OF x[unfolded as Int_iff interior_closed_interval mem_interval],rule_format]
+ have "l \<noteq> l'" apply(rule) using k'(2)[unfolded as] by auto
+ thus False using *[of "\<pi> l"] *[of "\<pi> l'"]
+ unfolding Cart_lambda_beta \<pi>l using `l \<le> l'` by auto
+ next assume as:"k = ?p1 l" "k' = ?p2 l'"
+ note * = conjunctD2[OF x[unfolded as Int_iff interior_closed_interval mem_interval],rule_format]
+ show False using *[of "\<pi> l"] *[of "\<pi> l'"]
+ unfolding Cart_lambda_beta \<pi>l using `l \<le> l'` using abcd[of "\<pi> l'"] by smt
+ next assume as:"k = ?p2 l" "k' = ?p1 l'"
+ note * = conjunctD2[OF x[unfolded as Int_iff interior_closed_interval mem_interval],rule_format]
+ show False using *[of "\<pi> l"] *[of "\<pi> l'"]
+ unfolding Cart_lambda_beta \<pi>l using `l \<le> l'` using abcd[of "\<pi> l'"] by smt
+ qed qed }
+ from this[OF k l k' l'] this[OF k'(1) l' k _ l] have "\<And>x. x \<notin> interior k \<inter> interior k'"
+ apply - apply(cases "l' \<le> l") using k'(2) by auto
+ thus "interior k \<inter> interior k' = {}" by auto
+qed qed
+
+lemma partial_division_extend_interval: assumes "p division_of (\<Union>p)" "(\<Union>p) \<subseteq> {a..b}"
+ obtains q where "p \<subseteq> q" "q division_of {a..b::real^'n}" proof(cases "p = {}")
+ case True guess q apply(rule elementary_interval[of a b]) .
+ thus ?thesis apply- apply(rule that[of q]) unfolding True by auto next
+ case False note p = division_ofD[OF assms(1)]
+ have *:"\<forall>k\<in>p. \<exists>q. q division_of {a..b} \<and> k\<in>q" proof case goal1
+ guess c using p(4)[OF goal1] .. then guess d .. note cd_ = this
+ have *:"{c..d} \<subseteq> {a..b}" "{c..d} \<noteq> {}" using p(2,3)[OF goal1, unfolded cd_] using assms(2) by auto
+ guess q apply(rule partial_division_extend_1[OF *]) . thus ?case unfolding cd_ by auto qed
+ guess q using bchoice[OF *] .. note q = conjunctD2[OF this[rule_format]]
+ have "\<And>x. x\<in>p \<Longrightarrow> \<exists>d. d division_of \<Union>(q x - {x})" apply(rule,rule_tac p="q x" in division_of_subset) proof-
+ fix x assume x:"x\<in>p" show "q x division_of \<Union>q x" apply-apply(rule division_ofI)
+ using division_ofD[OF q(1)[OF x]] by auto show "q x - {x} \<subseteq> q x" by auto qed
+ hence "\<exists>d. d division_of \<Inter> ((\<lambda>i. \<Union>(q i - {i})) ` p)" apply- apply(rule elementary_inters)
+ apply(rule finite_imageI[OF p(1)]) unfolding image_is_empty apply(rule False) by auto
+ then guess d .. note d = this
+ show ?thesis apply(rule that[of "d \<union> p"]) proof-
+ have *:"\<And>s f t. s \<noteq> {} \<Longrightarrow> (\<forall>i\<in>s. f i \<union> i = t) \<Longrightarrow> t = \<Inter> (f ` s) \<union> (\<Union>s)" by auto
+ have *:"{a..b} = \<Inter> (\<lambda>i. \<Union>(q i - {i})) ` p \<union> \<Union>p" apply(rule *[OF False]) proof fix i assume i:"i\<in>p"
+ show "\<Union>(q i - {i}) \<union> i = {a..b}" using division_ofD(6)[OF q(1)[OF i]] using q(2)[OF i] by auto qed
+ show "d \<union> p division_of {a..b}" unfolding * apply(rule division_disjoint_union[OF d assms(1)])
+ apply(rule inter_interior_unions_intervals) apply(rule p open_interior ballI)+ proof(assumption,rule)
+ fix k assume k:"k\<in>p" have *:"\<And>u t s. u \<subseteq> s \<Longrightarrow> s \<inter> t = {} \<Longrightarrow> u \<inter> t = {}" by auto
+ show "interior (\<Inter>(\<lambda>i. \<Union>(q i - {i})) ` p) \<inter> interior k = {}" apply(rule *[of _ "interior (\<Union>(q k - {k}))"])
+ defer apply(subst Int_commute) apply(rule inter_interior_unions_intervals) proof- note qk=division_ofD[OF q(1)[OF k]]
+ show "finite (q k - {k})" "open (interior k)" "\<forall>t\<in>q k - {k}. \<exists>a b. t = {a..b}" using qk by auto
+ show "\<forall>t\<in>q k - {k}. interior k \<inter> interior t = {}" using qk(5) using q(2)[OF k] by auto
+ have *:"\<And>x s. x \<in> s \<Longrightarrow> \<Inter>s \<subseteq> x" by auto show "interior (\<Inter>(\<lambda>i. \<Union>(q i - {i})) ` p) \<subseteq> interior (\<Union>(q k - {k}))"
+ apply(rule subset_interior *)+ using k by auto qed qed qed auto qed
+
+lemma elementary_bounded[dest]: "p division_of s \<Longrightarrow> bounded (s::(real^'n) set)"
+ unfolding division_of_def by(metis bounded_Union bounded_interval)
+
+lemma elementary_subset_interval: "p division_of s \<Longrightarrow> \<exists>a b. s \<subseteq> {a..b::real^'n}"
+ by(meson elementary_bounded bounded_subset_closed_interval)
+
+lemma division_union_intervals_exists: assumes "{a..b::real^'n} \<noteq> {}"
+ obtains p where "(insert {a..b} p) division_of ({a..b} \<union> {c..d})" proof(cases "{c..d} = {}")
+ case True show ?thesis apply(rule that[of "{}"]) unfolding True using assms by auto next
+ case False note false=this show ?thesis proof(cases "{a..b} \<inter> {c..d} = {}")
+ have *:"\<And>a b. {a,b} = {a} \<union> {b}" by auto
+ case True show ?thesis apply(rule that[of "{{c..d}}"]) unfolding * apply(rule division_disjoint_union)
+ using false True assms using interior_subset by auto next
+ case False obtain u v where uv:"{a..b} \<inter> {c..d} = {u..v}" unfolding inter_interval by auto
+ have *:"{u..v} \<subseteq> {c..d}" using uv by auto
+ guess p apply(rule partial_division_extend_1[OF * False[unfolded uv]]) . note p=this division_ofD[OF this(1)]
+ have *:"{a..b} \<union> {c..d} = {a..b} \<union> \<Union>(p - {{u..v}})" "\<And>x s. insert x s = {x} \<union> s" using p(8) unfolding uv[THEN sym] by auto
+ show thesis apply(rule that[of "p - {{u..v}}"]) unfolding *(1) apply(subst *(2)) apply(rule division_disjoint_union)
+ apply(rule,rule assms) apply(rule division_of_subset[of p]) apply(rule division_of_union_self[OF p(1)]) defer
+ unfolding interior_inter[THEN sym] proof-
+ have *:"\<And>cd p uv ab. p \<subseteq> cd \<Longrightarrow> ab \<inter> cd = uv \<Longrightarrow> ab \<inter> p = uv \<inter> p" by auto
+ have "interior ({a..b} \<inter> \<Union>(p - {{u..v}})) = interior({u..v} \<inter> \<Union>(p - {{u..v}}))"
+ apply(rule arg_cong[of _ _ interior]) apply(rule *[OF _ uv]) using p(8) by auto
+ also have "\<dots> = {}" unfolding interior_inter apply(rule inter_interior_unions_intervals) using p(6) p(7)[OF p(2)] p(3) by auto
+ finally show "interior ({a..b} \<inter> \<Union>(p - {{u..v}})) = {}" by assumption qed auto qed qed
+
+lemma division_of_unions: assumes "finite f" "\<And>p. p\<in>f \<Longrightarrow> p division_of (\<Union>p)"
+ "\<And>k1 k2. \<lbrakk>k1 \<in> \<Union>f; k2 \<in> \<Union>f; k1 \<noteq> k2\<rbrakk> \<Longrightarrow> interior k1 \<inter> interior k2 = {}"
+ shows "\<Union>f division_of \<Union>\<Union>f" apply(rule division_ofI) prefer 5 apply(rule assms(3)|assumption)+
+ apply(rule finite_Union assms(1))+ prefer 3 apply(erule UnionE) apply(rule_tac s=X in division_ofD(3)[OF assms(2)])
+ using division_ofD[OF assms(2)] by auto
+
+lemma elementary_union_interval: assumes "p division_of \<Union>p"
+ obtains q where "q division_of ({a..b::real^'n} \<union> \<Union>p)" proof-
+ note assm=division_ofD[OF assms]
+ have lem1:"\<And>f s. \<Union>\<Union> (f ` s) = \<Union>(\<lambda>x.\<Union>(f x)) ` s" by auto
+ have lem2:"\<And>f s. f \<noteq> {} \<Longrightarrow> \<Union>{s \<union> t |t. t \<in> f} = s \<union> \<Union>f" by auto
+{ presume "p={} \<Longrightarrow> thesis" "{a..b} = {} \<Longrightarrow> thesis" "{a..b} \<noteq> {} \<Longrightarrow> interior {a..b} = {} \<Longrightarrow> thesis"
+ "p\<noteq>{} \<Longrightarrow> interior {a..b}\<noteq>{} \<Longrightarrow> {a..b} \<noteq> {} \<Longrightarrow> thesis"
+ thus thesis by auto
+next assume as:"p={}" guess p apply(rule elementary_interval[of a b]) .
+ thus thesis apply(rule_tac that[of p]) unfolding as by auto
+next assume as:"{a..b}={}" show thesis apply(rule that) unfolding as using assms by auto
+next assume as:"interior {a..b} = {}" "{a..b} \<noteq> {}"
+ show thesis apply(rule that[of "insert {a..b} p"],rule division_ofI)
+ unfolding finite_insert apply(rule assm(1)) unfolding Union_insert
+ using assm(2-4) as apply- by(fastsimp dest: assm(5))+
+next assume as:"p \<noteq> {}" "interior {a..b} \<noteq> {}" "{a..b}\<noteq>{}"
+ have "\<forall>k\<in>p. \<exists>q. (insert {a..b} q) division_of ({a..b} \<union> k)" proof case goal1
+ from assm(4)[OF this] guess c .. then guess d ..
+ thus ?case apply-apply(rule division_union_intervals_exists[OF as(3),of c d]) by auto
+ qed from bchoice[OF this] guess q .. note q=division_ofD[OF this[rule_format]]
+ let ?D = "\<Union>{insert {a..b} (q k) | k. k \<in> p}"
+ show thesis apply(rule that[of "?D"]) proof(rule division_ofI)
+ have *:"{insert {a..b} (q k) |k. k \<in> p} = (\<lambda>k. insert {a..b} (q k)) ` p" by auto
+ show "finite ?D" apply(rule finite_Union) unfolding * apply(rule finite_imageI) using assm(1) q(1) by auto
+ show "\<Union>?D = {a..b} \<union> \<Union>p" unfolding * lem1 unfolding lem2[OF as(1), of "{a..b}",THEN sym]
+ using q(6) by auto
+ fix k assume k:"k\<in>?D" thus " k \<subseteq> {a..b} \<union> \<Union>p" using q(2) by auto
+ show "k \<noteq> {}" using q(3) k by auto show "\<exists>a b. k = {a..b}" using q(4) k by auto
+ fix k' assume k':"k'\<in>?D" "k\<noteq>k'"
+ obtain x where x: "k \<in>insert {a..b} (q x)" "x\<in>p" using k by auto
+ obtain x' where x':"k'\<in>insert {a..b} (q x')" "x'\<in>p" using k' by auto
+ show "interior k \<inter> interior k' = {}" proof(cases "x=x'")
+ case True show ?thesis apply(rule q(5)) using x x' k' unfolding True by auto
+ next case False
+ { presume "k = {a..b} \<Longrightarrow> ?thesis" "k' = {a..b} \<Longrightarrow> ?thesis"
+ "k \<noteq> {a..b} \<Longrightarrow> k' \<noteq> {a..b} \<Longrightarrow> ?thesis"
+ thus ?thesis by auto }
+ { assume as':"k = {a..b}" show ?thesis apply(rule q(5)) using x' k'(2) unfolding as' by auto }
+ { assume as':"k' = {a..b}" show ?thesis apply(rule q(5)) using x k'(2) unfolding as' by auto }
+ assume as':"k \<noteq> {a..b}" "k' \<noteq> {a..b}"
+ guess c using q(4)[OF x(2,1)] .. then guess d .. note c_d=this
+ have "interior k \<inter> interior {a..b} = {}" apply(rule q(5)) using x k'(2) using as' by auto
+ hence "interior k \<subseteq> interior x" apply-
+ apply(rule interior_subset_union_intervals[OF c_d _ as(2) q(2)[OF x(2,1)]]) by auto moreover
+ guess c using q(4)[OF x'(2,1)] .. then guess d .. note c_d=this
+ have "interior k' \<inter> interior {a..b} = {}" apply(rule q(5)) using x' k'(2) using as' by auto
+ hence "interior k' \<subseteq> interior x'" apply-
+ apply(rule interior_subset_union_intervals[OF c_d _ as(2) q(2)[OF x'(2,1)]]) by auto
+ ultimately show ?thesis using assm(5)[OF x(2) x'(2) False] by auto
+ qed qed } qed
+
+lemma elementary_unions_intervals:
+ assumes "finite f" "\<And>s. s \<in> f \<Longrightarrow> \<exists>a b. s = {a..b::real^'n}"
+ obtains p where "p division_of (\<Union>f)" proof-
+ have "\<exists>p. p division_of (\<Union>f)" proof(induct_tac f rule:finite_subset_induct)
+ show "\<exists>p. p division_of \<Union>{}" using elementary_empty by auto
+ fix x F assume as:"finite F" "x \<notin> F" "\<exists>p. p division_of \<Union>F" "x\<in>f"
+ from this(3) guess p .. note p=this
+ from assms(2)[OF as(4)] guess a .. then guess b .. note ab=this
+ have *:"\<Union>F = \<Union>p" using division_ofD[OF p] by auto
+ show "\<exists>p. p division_of \<Union>insert x F" using elementary_union_interval[OF p[unfolded *], of a b]
+ unfolding Union_insert ab * by auto
+ qed(insert assms,auto) thus ?thesis apply-apply(erule exE,rule that) by auto qed
+
+lemma elementary_union: assumes "ps division_of s" "pt division_of (t::(real^'n) set)"
+ obtains p where "p division_of (s \<union> t)"
+proof- have "s \<union> t = \<Union>ps \<union> \<Union>pt" using assms unfolding division_of_def by auto
+ hence *:"\<Union>(ps \<union> pt) = s \<union> t" by auto
+ show ?thesis apply-apply(rule elementary_unions_intervals[of "ps\<union>pt"])
+ unfolding * prefer 3 apply(rule_tac p=p in that)
+ using assms[unfolded division_of_def] by auto qed
+
+lemma partial_division_extend: fixes t::"(real^'n) set"
+ assumes "p division_of s" "q division_of t" "s \<subseteq> t"
+ obtains r where "p \<subseteq> r" "r division_of t" proof-
+ note divp = division_ofD[OF assms(1)] and divq = division_ofD[OF assms(2)]
+ obtain a b where ab:"t\<subseteq>{a..b}" using elementary_subset_interval[OF assms(2)] by auto
+ guess r1 apply(rule partial_division_extend_interval) apply(rule assms(1)[unfolded divp(6)[THEN sym]])
+ apply(rule subset_trans) by(rule ab assms[unfolded divp(6)[THEN sym]])+ note r1 = this division_ofD[OF this(2)]
+ guess p' apply(rule elementary_unions_intervals[of "r1 - p"]) using r1(3,6) by auto
+ then obtain r2 where r2:"r2 division_of (\<Union>(r1 - p)) \<inter> (\<Union>q)"
+ apply- apply(drule elementary_inter[OF _ assms(2)[unfolded divq(6)[THEN sym]]]) by auto
+ { fix x assume x:"x\<in>t" "x\<notin>s"
+ hence "x\<in>\<Union>r1" unfolding r1 using ab by auto
+ then guess r unfolding Union_iff .. note r=this moreover
+ have "r \<notin> p" proof assume "r\<in>p" hence "x\<in>s" using divp(2) r by auto
+ thus False using x by auto qed
+ ultimately have "x\<in>\<Union>(r1 - p)" by auto }
+ hence *:"t = \<Union>p \<union> (\<Union>(r1 - p) \<inter> \<Union>q)" unfolding divp divq using assms(3) by auto
+ show ?thesis apply(rule that[of "p \<union> r2"]) unfolding * defer apply(rule division_disjoint_union)
+ unfolding divp(6) apply(rule assms r2)+
+ proof- have "interior s \<inter> interior (\<Union>(r1-p)) = {}"
+ proof(rule inter_interior_unions_intervals)
+ show "finite (r1 - p)" "open (interior s)" "\<forall>t\<in>r1-p. \<exists>a b. t = {a..b}" using r1 by auto
+ have *:"\<And>s. (\<And>x. x \<in> s \<Longrightarrow> False) \<Longrightarrow> s = {}" by auto
+ show "\<forall>t\<in>r1-p. interior s \<inter> interior t = {}" proof(rule)
+ fix m x assume as:"m\<in>r1-p"
+ have "interior m \<inter> interior (\<Union>p) = {}" proof(rule inter_interior_unions_intervals)
+ show "finite p" "open (interior m)" "\<forall>t\<in>p. \<exists>a b. t = {a..b}" using divp by auto
+ show "\<forall>t\<in>p. interior m \<inter> interior t = {}" apply(rule, rule r1(7)) using as using r1 by auto
+ qed thus "interior s \<inter> interior m = {}" unfolding divp by auto
+ qed qed
+ thus "interior s \<inter> interior (\<Union>(r1-p) \<inter> (\<Union>q)) = {}" using interior_subset by auto
+ qed auto qed
+
+subsection {* Tagged (partial) divisions. *}
+
+definition tagged_partial_division_of (infixr "tagged'_partial'_division'_of" 40) where
+ "(s tagged_partial_division_of i) \<equiv>
+ finite s \<and>
+ (\<forall>x k. (x,k) \<in> s \<longrightarrow> x \<in> k \<and> k \<subseteq> i \<and> (\<exists>a b. k = {a..b})) \<and>
+ (\<forall>x1 k1 x2 k2. (x1,k1) \<in> s \<and> (x2,k2) \<in> s \<and> ((x1,k1) \<noteq> (x2,k2))
+ \<longrightarrow> (interior(k1) \<inter> interior(k2) = {}))"
+
+lemma tagged_partial_division_ofD[dest]: assumes "s tagged_partial_division_of i"
+ shows "finite s" "\<And>x k. (x,k) \<in> s \<Longrightarrow> x \<in> k" "\<And>x k. (x,k) \<in> s \<Longrightarrow> k \<subseteq> i"
+ "\<And>x k. (x,k) \<in> s \<Longrightarrow> \<exists>a b. k = {a..b}"
+ "\<And>x1 k1 x2 k2. (x1,k1) \<in> s \<Longrightarrow> (x2,k2) \<in> s \<Longrightarrow> (x1,k1) \<noteq> (x2,k2) \<Longrightarrow> interior(k1) \<inter> interior(k2) = {}"
+ using assms unfolding tagged_partial_division_of_def apply- by blast+
+
+definition tagged_division_of (infixr "tagged'_division'_of" 40) where
+ "(s tagged_division_of i) \<equiv>
+ (s tagged_partial_division_of i) \<and> (\<Union>{k. \<exists>x. (x,k) \<in> s} = i)"
+
+lemma tagged_division_of_finite[dest]: "s tagged_division_of i \<Longrightarrow> finite s"
+ unfolding tagged_division_of_def tagged_partial_division_of_def by auto
+
+lemma tagged_division_of:
+ "(s tagged_division_of i) \<longleftrightarrow>
+ finite s \<and>
+ (\<forall>x k. (x,k) \<in> s
+ \<longrightarrow> x \<in> k \<and> k \<subseteq> i \<and> (\<exists>a b. k = {a..b})) \<and>
+ (\<forall>x1 k1 x2 k2. (x1,k1) \<in> s \<and> (x2,k2) \<in> s \<and> ~((x1,k1) = (x2,k2))
+ \<longrightarrow> (interior(k1) \<inter> interior(k2) = {})) \<and>
+ (\<Union>{k. \<exists>x. (x,k) \<in> s} = i)"
+ unfolding tagged_division_of_def tagged_partial_division_of_def by auto
+
+lemma tagged_division_ofI: assumes
+ "finite s" "\<And>x k. (x,k) \<in> s \<Longrightarrow> x \<in> k" "\<And>x k. (x,k) \<in> s \<Longrightarrow> k \<subseteq> i" "\<And>x k. (x,k) \<in> s \<Longrightarrow> \<exists>a b. k = {a..b}"
+ "\<And>x1 k1 x2 k2. (x1,k1) \<in> s \<Longrightarrow> (x2,k2) \<in> s \<Longrightarrow> ~((x1,k1) = (x2,k2)) \<Longrightarrow> (interior(k1) \<inter> interior(k2) = {})"
+ "(\<Union>{k. \<exists>x. (x,k) \<in> s} = i)"
+ shows "s tagged_division_of i"
+ unfolding tagged_division_of apply(rule) defer apply rule
+ apply(rule allI impI conjI assms)+ apply assumption
+ apply(rule, rule assms, assumption) apply(rule assms, assumption)
+ using assms(1,5-) apply- by blast+
+
+lemma tagged_division_ofD[dest]: assumes "s tagged_division_of i"
+ shows "finite s" "\<And>x k. (x,k) \<in> s \<Longrightarrow> x \<in> k" "\<And>x k. (x,k) \<in> s \<Longrightarrow> k \<subseteq> i" "\<And>x k. (x,k) \<in> s \<Longrightarrow> \<exists>a b. k = {a..b}"
+ "\<And>x1 k1 x2 k2. (x1,k1) \<in> s \<Longrightarrow> (x2,k2) \<in> s \<Longrightarrow> ~((x1,k1) = (x2,k2)) \<Longrightarrow> (interior(k1) \<inter> interior(k2) = {})"
+ "(\<Union>{k. \<exists>x. (x,k) \<in> s} = i)" using assms unfolding tagged_division_of apply- by blast+
+
+lemma division_of_tagged_division: assumes"s tagged_division_of i" shows "(snd ` s) division_of i"
+proof(rule division_ofI) note assm=tagged_division_ofD[OF assms]
+ show "\<Union>snd ` s = i" "finite (snd ` s)" using assm by auto
+ fix k assume k:"k \<in> snd ` s" then obtain xk where xk:"(xk, k) \<in> s" by auto
+ thus "k \<subseteq> i" "k \<noteq> {}" "\<exists>a b. k = {a..b}" using assm apply- by fastsimp+
+ fix k' assume k':"k' \<in> snd ` s" "k \<noteq> k'" from this(1) obtain xk' where xk':"(xk', k') \<in> s" by auto
+ thus "interior k \<inter> interior k' = {}" apply-apply(rule assm(5)) apply(rule xk xk')+ using k' by auto
+qed
+
+lemma partial_division_of_tagged_division: assumes "s tagged_partial_division_of i"
+ shows "(snd ` s) division_of \<Union>(snd ` s)"
+proof(rule division_ofI) note assm=tagged_partial_division_ofD[OF assms]
+ show "finite (snd ` s)" "\<Union>snd ` s = \<Union>snd ` s" using assm by auto
+ fix k assume k:"k \<in> snd ` s" then obtain xk where xk:"(xk, k) \<in> s" by auto
+ thus "k\<noteq>{}" "\<exists>a b. k = {a..b}" "k \<subseteq> \<Union>snd ` s" using assm by auto
+ fix k' assume k':"k' \<in> snd ` s" "k \<noteq> k'" from this(1) obtain xk' where xk':"(xk', k') \<in> s" by auto
+ thus "interior k \<inter> interior k' = {}" apply-apply(rule assm(5)) apply(rule xk xk')+ using k' by auto
+qed
+
+lemma tagged_partial_division_subset: assumes "s tagged_partial_division_of i" "t \<subseteq> s"
+ shows "t tagged_partial_division_of i"
+ using assms unfolding tagged_partial_division_of_def using finite_subset[OF assms(2)] by blast
+
+lemma setsum_over_tagged_division_lemma: fixes d::"(real^'m) set \<Rightarrow> 'a::real_normed_vector"
+ assumes "p tagged_division_of i" "\<And>u v. {u..v} \<noteq> {} \<Longrightarrow> content {u..v} = 0 \<Longrightarrow> d {u..v} = 0"
+ shows "setsum (\<lambda>(x,k). d k) p = setsum d (snd ` p)"
+proof- note assm=tagged_division_ofD[OF assms(1)]
+ have *:"(\<lambda>(x,k). d k) = d \<circ> snd" unfolding o_def apply(rule ext) by auto
+ show ?thesis unfolding * apply(subst eq_commute) proof(rule setsum_reindex_nonzero)
+ show "finite p" using assm by auto
+ fix x y assume as:"x\<in>p" "y\<in>p" "x\<noteq>y" "snd x = snd y"
+ obtain a b where ab:"snd x = {a..b}" using assm(4)[of "fst x" "snd x"] as(1) by auto
+ have "(fst x, snd y) \<in> p" "(fst x, snd y) \<noteq> y" unfolding as(4)[THEN sym] using as(1-3) by auto
+ hence "interior (snd x) \<inter> interior (snd y) = {}" apply-apply(rule assm(5)[of "fst x" _ "fst y"]) using as by auto
+ hence "content {a..b} = 0" unfolding as(4)[THEN sym] ab content_eq_0_interior by auto
+ hence "d {a..b} = 0" apply-apply(rule assms(2)) using assm(2)[of "fst x" "snd x"] as(1) unfolding ab[THEN sym] by auto
+ thus "d (snd x) = 0" unfolding ab by auto qed qed
+
+lemma tag_in_interval: "p tagged_division_of i \<Longrightarrow> (x,k) \<in> p \<Longrightarrow> x \<in> i" by auto
+
+lemma tagged_division_of_empty: "{} tagged_division_of {}"
+ unfolding tagged_division_of by auto
+
+lemma tagged_partial_division_of_trivial[simp]:
+ "p tagged_partial_division_of {} \<longleftrightarrow> p = {}"
+ unfolding tagged_partial_division_of_def by auto
+
+lemma tagged_division_of_trivial[simp]:
+ "p tagged_division_of {} \<longleftrightarrow> p = {}"
+ unfolding tagged_division_of by auto
+
+lemma tagged_division_of_self:
+ "x \<in> {a..b} \<Longrightarrow> {(x,{a..b})} tagged_division_of {a..b}"
+ apply(rule tagged_division_ofI) by auto
+
+lemma tagged_division_union:
+ assumes "p1 tagged_division_of s1" "p2 tagged_division_of s2" "interior s1 \<inter> interior s2 = {}"
+ shows "(p1 \<union> p2) tagged_division_of (s1 \<union> s2)"
+proof(rule tagged_division_ofI) note p1=tagged_division_ofD[OF assms(1)] and p2=tagged_division_ofD[OF assms(2)]
+ show "finite (p1 \<union> p2)" using p1(1) p2(1) by auto
+ show "\<Union>{k. \<exists>x. (x, k) \<in> p1 \<union> p2} = s1 \<union> s2" using p1(6) p2(6) by blast
+ fix x k assume xk:"(x,k)\<in>p1\<union>p2" show "x\<in>k" "\<exists>a b. k = {a..b}" using xk p1(2,4) p2(2,4) by auto
+ show "k\<subseteq>s1\<union>s2" using xk p1(3) p2(3) by blast
+ fix x' k' assume xk':"(x',k')\<in>p1\<union>p2" "(x,k) \<noteq> (x',k')"
+ have *:"\<And>a b. a\<subseteq> s1 \<Longrightarrow> b\<subseteq> s2 \<Longrightarrow> interior a \<inter> interior b = {}" using assms(3) subset_interior by blast
+ show "interior k \<inter> interior k' = {}" apply(cases "(x,k)\<in>p1", case_tac[!] "(x',k')\<in>p1")
+ apply(rule p1(5)) prefer 4 apply(rule *) prefer 6 apply(subst Int_commute,rule *) prefer 8 apply(rule p2(5))
+ using p1(3) p2(3) using xk xk' by auto qed
+
+lemma tagged_division_unions:
+ assumes "finite iset" "\<forall>i\<in>iset. (pfn(i) tagged_division_of i)"
+ "\<forall>i1 \<in> iset. \<forall>i2 \<in> iset. ~(i1 = i2) \<longrightarrow> (interior(i1) \<inter> interior(i2) = {})"
+ shows "\<Union>(pfn ` iset) tagged_division_of (\<Union>iset)"
+proof(rule tagged_division_ofI)
+ note assm = tagged_division_ofD[OF assms(2)[rule_format]]
+ show "finite (\<Union>pfn ` iset)" apply(rule finite_Union) using assms by auto
+ have "\<Union>{k. \<exists>x. (x, k) \<in> \<Union>pfn ` iset} = \<Union>(\<lambda>i. \<Union>{k. \<exists>x. (x, k) \<in> pfn i}) ` iset" by blast
+ also have "\<dots> = \<Union>iset" using assm(6) by auto
+ finally show "\<Union>{k. \<exists>x. (x, k) \<in> \<Union>pfn ` iset} = \<Union>iset" .
+ fix x k assume xk:"(x,k)\<in>\<Union>pfn ` iset" then obtain i where i:"i \<in> iset" "(x, k) \<in> pfn i" by auto
+ show "x\<in>k" "\<exists>a b. k = {a..b}" "k \<subseteq> \<Union>iset" using assm(2-4)[OF i] using i(1) by auto
+ fix x' k' assume xk':"(x',k')\<in>\<Union>pfn ` iset" "(x, k) \<noteq> (x', k')" then obtain i' where i':"i' \<in> iset" "(x', k') \<in> pfn i'" by auto
+ have *:"\<And>a b. i\<noteq>i' \<Longrightarrow> a\<subseteq> i \<Longrightarrow> b\<subseteq> i' \<Longrightarrow> interior a \<inter> interior b = {}" using i(1) i'(1)
+ using assms(3)[rule_format] subset_interior by blast
+ show "interior k \<inter> interior k' = {}" apply(cases "i=i'")
+ using assm(5)[OF i _ xk'(2)] i'(2) using assm(3)[OF i] assm(3)[OF i'] defer apply-apply(rule *) by auto
+qed
+
+lemma tagged_partial_division_of_union_self:
+ assumes "p tagged_partial_division_of s" shows "p tagged_division_of (\<Union>(snd ` p))"
+ apply(rule tagged_division_ofI) using tagged_partial_division_ofD[OF assms] by auto
+
+lemma tagged_division_of_union_self: assumes "p tagged_division_of s"
+ shows "p tagged_division_of (\<Union>(snd ` p))"
+ apply(rule tagged_division_ofI) using tagged_division_ofD[OF assms] by auto
+
+subsection {* Fine-ness of a partition w.r.t. a gauge. *}
+
+definition fine (infixr "fine" 46) where
+ "d fine s \<longleftrightarrow> (\<forall>(x,k) \<in> s. k \<subseteq> d(x))"
+
+lemma fineI: assumes "\<And>x k. (x,k) \<in> s \<Longrightarrow> k \<subseteq> d x"
+ shows "d fine s" using assms unfolding fine_def by auto
+
+lemma fineD[dest]: assumes "d fine s"
+ shows "\<And>x k. (x,k) \<in> s \<Longrightarrow> k \<subseteq> d x" using assms unfolding fine_def by auto
+
+lemma fine_inter: "(\<lambda>x. d1 x \<inter> d2 x) fine p \<longleftrightarrow> d1 fine p \<and> d2 fine p"
+ unfolding fine_def by auto
+
+lemma fine_inters:
+ "(\<lambda>x. \<Inter> {f d x | d. d \<in> s}) fine p \<longleftrightarrow> (\<forall>d\<in>s. (f d) fine p)"
+ unfolding fine_def by blast
+
+lemma fine_union:
+ "d fine p1 \<Longrightarrow> d fine p2 \<Longrightarrow> d fine (p1 \<union> p2)"
+ unfolding fine_def by blast
+
+lemma fine_unions:"(\<And>p. p \<in> ps \<Longrightarrow> d fine p) \<Longrightarrow> d fine (\<Union>ps)"
+ unfolding fine_def by auto
+
+lemma fine_subset: "p \<subseteq> q \<Longrightarrow> d fine q \<Longrightarrow> d fine p"
+ unfolding fine_def by blast
+
+subsection {* Gauge integral. Define on compact intervals first, then use a limit. *}
+
+definition has_integral_compact_interval (infixr "has'_integral'_compact'_interval" 46) where
+ "(f has_integral_compact_interval y) i \<equiv>
+ (\<forall>e>0. \<exists>d. gauge d \<and>
+ (\<forall>p. p tagged_division_of i \<and> d fine p
+ \<longrightarrow> norm(setsum (\<lambda>(x,k). content k *\<^sub>R f x) p - y) < e))"
+
+definition has_integral (infixr "has'_integral" 46) where
+"((f::(real^'n \<Rightarrow> 'b::real_normed_vector)) has_integral y) i \<equiv>
+ if (\<exists>a b. i = {a..b}) then (f has_integral_compact_interval y) i
+ else (\<forall>e>0. \<exists>B>0. \<forall>a b. ball 0 B \<subseteq> {a..b}
+ \<longrightarrow> (\<exists>z. ((\<lambda>x. if x \<in> i then f x else 0) has_integral_compact_interval z) {a..b} \<and>
+ norm(z - y) < e))"
+
+lemma has_integral:
+ "(f has_integral y) ({a..b}) \<longleftrightarrow>
+ (\<forall>e>0. \<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p
+ \<longrightarrow> norm(setsum (\<lambda>(x,k). content(k) *\<^sub>R f x) p - y) < e))"
+ unfolding has_integral_def has_integral_compact_interval_def by auto
+
+lemma has_integralD[dest]: assumes
+ "(f has_integral y) ({a..b})" "e>0"
+ obtains d where "gauge d" "\<And>p. p tagged_division_of {a..b} \<Longrightarrow> d fine p
+ \<Longrightarrow> norm(setsum (\<lambda>(x,k). content(k) *\<^sub>R f(x)) p - y) < e"
+ using assms unfolding has_integral by auto
+
+lemma has_integral_alt:
+ "(f has_integral y) i \<longleftrightarrow>
+ (if (\<exists>a b. i = {a..b}) then (f has_integral y) i
+ else (\<forall>e>0. \<exists>B>0. \<forall>a b. ball 0 B \<subseteq> {a..b}
+ \<longrightarrow> (\<exists>z. ((\<lambda>x. if x \<in> i then f(x) else 0)
+ has_integral z) ({a..b}) \<and>
+ norm(z - y) < e)))"
+ unfolding has_integral unfolding has_integral_compact_interval_def has_integral_def by auto
+
+lemma has_integral_altD:
+ assumes "(f has_integral y) i" "\<not> (\<exists>a b. i = {a..b})" "e>0"
+ obtains B where "B>0" "\<forall>a b. ball 0 B \<subseteq> {a..b}\<longrightarrow> (\<exists>z. ((\<lambda>x. if x \<in> i then f(x) else 0) has_integral z) ({a..b}) \<and> norm(z - y) < e)"
+ using assms unfolding has_integral unfolding has_integral_compact_interval_def has_integral_def by auto
+
+definition integrable_on (infixr "integrable'_on" 46) where
+ "(f integrable_on i) \<equiv> \<exists>y. (f has_integral y) i"
+
+definition "integral i f \<equiv> SOME y. (f has_integral y) i"
+
+lemma integrable_integral[dest]:
+ "f integrable_on i \<Longrightarrow> (f has_integral (integral i f)) i"
+ unfolding integrable_on_def integral_def by(rule someI_ex)
+
+lemma has_integral_integrable[intro]: "(f has_integral i) s \<Longrightarrow> f integrable_on s"
+ unfolding integrable_on_def by auto
+
+lemma has_integral_integral:"f integrable_on s \<longleftrightarrow> (f has_integral (integral s f)) s"
+ by auto
+
+lemma setsum_content_null:
+ assumes "content({a..b}) = 0" "p tagged_division_of {a..b}"
+ shows "setsum (\<lambda>(x,k). content k *\<^sub>R f x) p = (0::'a::real_normed_vector)"
+proof(rule setsum_0',rule) fix y assume y:"y\<in>p"
+ obtain x k where xk:"y = (x,k)" using surj_pair[of y] by blast
+ note assm = tagged_division_ofD(3-4)[OF assms(2) y[unfolded xk]]
+ from this(2) guess c .. then guess d .. note c_d=this
+ have "(\<lambda>(x, k). content k *\<^sub>R f x) y = content k *\<^sub>R f x" unfolding xk by auto
+ also have "\<dots> = 0" using content_subset[OF assm(1)[unfolded c_d]] content_pos_le[of c d]
+ unfolding assms(1) c_d by auto
+ finally show "(\<lambda>(x, k). content k *\<^sub>R f x) y = 0" .
+qed
+
+subsection {* Some basic combining lemmas. *}
+
+lemma tagged_division_unions_exists:
+ assumes "finite iset" "\<forall>i \<in> iset. \<exists>p. p tagged_division_of i \<and> d fine p"
+ "\<forall>i1\<in>iset. \<forall>i2\<in>iset. ~(i1 = i2) \<longrightarrow> (interior(i1) \<inter> interior(i2) = {})" "(\<Union>iset = i)"
+ obtains p where "p tagged_division_of i" "d fine p"
+proof- guess pfn using bchoice[OF assms(2)] .. note pfn = conjunctD2[OF this[rule_format]]
+ show thesis apply(rule_tac p="\<Union>(pfn ` iset)" in that) unfolding assms(4)[THEN sym]
+ apply(rule tagged_division_unions[OF assms(1) _ assms(3)]) defer
+ apply(rule fine_unions) using pfn by auto
+qed
+
+subsection {* The set we're concerned with must be closed. *}
+
+lemma division_of_closed: "s division_of i \<Longrightarrow> closed (i::(real^'n) set)"
+ unfolding division_of_def by(fastsimp intro!: closed_Union closed_interval)
+
+subsection {* General bisection principle for intervals; might be useful elsewhere. *}
+
+lemma interval_bisection_step:
+ assumes "P {}" "(\<forall>s t. P s \<and> P t \<and> interior(s) \<inter> interior(t) = {} \<longrightarrow> P(s \<union> t))" "~(P {a..b::real^'n})"
+ obtains c d where "~(P{c..d})"
+ "\<forall>i. a$i \<le> c$i \<and> c$i \<le> d$i \<and> d$i \<le> b$i \<and> 2 * (d$i - c$i) \<le> b$i - a$i"
+proof- have "{a..b} \<noteq> {}" using assms(1,3) by auto
+ note ab=this[unfolded interval_eq_empty not_ex not_less]
+ { fix f have "finite f \<Longrightarrow>
+ (\<forall>s\<in>f. P s) \<Longrightarrow>
+ (\<forall>s\<in>f. \<exists>a b. s = {a..b}) \<Longrightarrow>
+ (\<forall>s\<in>f.\<forall>t\<in>f. ~(s = t) \<longrightarrow> interior(s) \<inter> interior(t) = {}) \<Longrightarrow> P(\<Union>f)"
+ proof(induct f rule:finite_induct)
+ case empty show ?case using assms(1) by auto
+ next case (insert x f) show ?case unfolding Union_insert apply(rule assms(2)[rule_format])
+ apply rule defer apply rule defer apply(rule inter_interior_unions_intervals)
+ using insert by auto
+ qed } note * = this
+ let ?A = "{{c..d} | c d. \<forall>i. (c$i = a$i) \<and> (d$i = (a$i + b$i) / 2) \<or> (c$i = (a$i + b$i) / 2) \<and> (d$i = b$i)}"
+ let ?PP = "\<lambda>c d. \<forall>i. a$i \<le> c$i \<and> c$i \<le> d$i \<and> d$i \<le> b$i \<and> 2 * (d$i - c$i) \<le> b$i - a$i"
+ { presume "\<forall>c d. ?PP c d \<longrightarrow> P {c..d} \<Longrightarrow> False"
+ thus thesis unfolding atomize_not not_all apply-apply(erule exE)+ apply(rule_tac c=x and d=xa in that) by auto }
+ assume as:"\<forall>c d. ?PP c d \<longrightarrow> P {c..d}"
+ have "P (\<Union> ?A)" proof(rule *, rule_tac[2-] ballI, rule_tac[4] ballI, rule_tac[4] impI)
+ let ?B = "(\<lambda>s.{(\<chi> i. if i \<in> s then a$i else (a$i + b$i) / 2) ..
+ (\<chi> i. if i \<in> s then (a$i + b$i) / 2 else b$i)}) ` {s. s \<subseteq> UNIV}"
+ have "?A \<subseteq> ?B" proof case goal1
+ then guess c unfolding mem_Collect_eq .. then guess d apply- by(erule exE,(erule conjE)+) note c_d=this[rule_format]
+ have *:"\<And>a b c d. a = c \<Longrightarrow> b = d \<Longrightarrow> {a..b} = {c..d}" by auto
+ show "x\<in>?B" unfolding image_iff apply(rule_tac x="{i. c$i = a$i}" in bexI)
+ unfolding c_d apply(rule * ) unfolding Cart_eq cond_component Cart_lambda_beta
+ proof(rule_tac[1-2] allI) fix i show "c $ i = (if i \<in> {i. c $ i = a $ i} then a $ i else (a $ i + b $ i) / 2)"
+ "d $ i = (if i \<in> {i. c $ i = a $ i} then (a $ i + b $ i) / 2 else b $ i)"
+ using c_d(2)[of i] ab[THEN spec[where x=i]] by(auto simp add:field_simps)
+ qed auto qed
+ thus "finite ?A" apply(rule finite_subset[of _ ?B]) by auto
+ fix s assume "s\<in>?A" then guess c unfolding mem_Collect_eq .. then guess d apply- by(erule exE,(erule conjE)+)
+ note c_d=this[rule_format]
+ show "P s" unfolding c_d apply(rule as[rule_format]) proof- case goal1 show ?case
+ using c_d(2)[of i] using ab[THEN spec[where x=i]] by auto qed
+ show "\<exists>a b. s = {a..b}" unfolding c_d by auto
+ fix t assume "t\<in>?A" then guess e unfolding mem_Collect_eq .. then guess f apply- by(erule exE,(erule conjE)+)
+ note e_f=this[rule_format]
+ assume "s \<noteq> t" hence "\<not> (c = e \<and> d = f)" unfolding c_d e_f by auto
+ then obtain i where "c$i \<noteq> e$i \<or> d$i \<noteq> f$i" unfolding de_Morgan_conj Cart_eq by auto
+ hence i:"c$i \<noteq> e$i" "d$i \<noteq> f$i" apply- apply(erule_tac[!] disjE)
+ proof- assume "c$i \<noteq> e$i" thus "d$i \<noteq> f$i" using c_d(2)[of i] e_f(2)[of i] by fastsimp
+ next assume "d$i \<noteq> f$i" thus "c$i \<noteq> e$i" using c_d(2)[of i] e_f(2)[of i] by fastsimp
+ qed have *:"\<And>s t. (\<And>a. a\<in>s \<Longrightarrow> a\<in>t \<Longrightarrow> False) \<Longrightarrow> s \<inter> t = {}" by auto
+ show "interior s \<inter> interior t = {}" unfolding e_f c_d interior_closed_interval proof(rule *)
+ fix x assume "x\<in>{c<..<d}" "x\<in>{e<..<f}"
+ hence x:"c$i < d$i" "e$i < f$i" "c$i < f$i" "e$i < d$i" unfolding mem_interval apply-apply(erule_tac[!] x=i in allE)+ by auto
+ show False using c_d(2)[of i] apply- apply(erule_tac disjE)
+ proof(erule_tac[!] conjE) assume as:"c $ i = a $ i" "d $ i = (a $ i + b $ i) / 2"
+ show False using e_f(2)[of i] and i x unfolding as by(fastsimp simp add:field_simps)
+ next assume as:"c $ i = (a $ i + b $ i) / 2" "d $ i = b $ i"
+ show False using e_f(2)[of i] and i x unfolding as by(fastsimp simp add:field_simps)
+ qed qed qed
+ also have "\<Union> ?A = {a..b}" proof(rule set_ext,rule)
+ fix x assume "x\<in>\<Union>?A" then guess Y unfolding Union_iff ..
+ from this(1) guess c unfolding mem_Collect_eq .. then guess d ..
+ note c_d = this[THEN conjunct2,rule_format] `x\<in>Y`[unfolded this[THEN conjunct1]]
+ show "x\<in>{a..b}" unfolding mem_interval proof
+ fix i show "a $ i \<le> x $ i \<and> x $ i \<le> b $ i"
+ using c_d(1)[of i] c_d(2)[unfolded mem_interval,THEN spec[where x=i]] by auto qed
+ next fix x assume x:"x\<in>{a..b}"
+ have "\<forall>i. \<exists>c d. (c = a$i \<and> d = (a$i + b$i) / 2 \<or> c = (a$i + b$i) / 2 \<and> d = b$i) \<and> c\<le>x$i \<and> x$i \<le> d"
+ (is "\<forall>i. \<exists>c d. ?P i c d") unfolding mem_interval proof fix i
+ have "?P i (a$i) ((a $ i + b $ i) / 2) \<or> ?P i ((a $ i + b $ i) / 2) (b$i)"
+ using x[unfolded mem_interval,THEN spec[where x=i]] by auto thus "\<exists>c d. ?P i c d" by blast
+ qed thus "x\<in>\<Union>?A" unfolding Union_iff lambda_skolem unfolding Bex_def mem_Collect_eq
+ apply-apply(erule exE)+ apply(rule_tac x="{xa..xaa}" in exI) unfolding mem_interval by auto
+ qed finally show False using assms by auto qed
+
+lemma interval_bisection:
+ assumes "P {}" "(\<forall>s t. P s \<and> P t \<and> interior(s) \<inter> interior(t) = {} \<longrightarrow> P(s \<union> t))" "\<not> P {a..b::real^'n}"
+ obtains x where "x \<in> {a..b}" "\<forall>e>0. \<exists>c d. x \<in> {c..d} \<and> {c..d} \<subseteq> ball x e \<and> {c..d} \<subseteq> {a..b} \<and> ~P({c..d})"
+proof-
+ have "\<forall>x. \<exists>y. \<not> P {fst x..snd x} \<longrightarrow> (\<not> P {fst y..snd y} \<and> (\<forall>i. fst x$i \<le> fst y$i \<and> fst y$i \<le> snd y$i \<and> snd y$i \<le> snd x$i \<and>
+ 2 * (snd y$i - fst y$i) \<le> snd x$i - fst x$i))" proof case goal1 thus ?case proof-
+ presume "\<not> P {fst x..snd x} \<Longrightarrow> ?thesis"
+ thus ?thesis apply(cases "P {fst x..snd x}") by auto
+ next assume as:"\<not> P {fst x..snd x}" from interval_bisection_step[of P, OF assms(1-2) as] guess c d .
+ thus ?thesis apply- apply(rule_tac x="(c,d)" in exI) by auto
+ qed qed then guess f apply-apply(drule choice) by(erule exE) note f=this
+ def AB \<equiv> "\<lambda>n. (f ^^ n) (a,b)" def A \<equiv> "\<lambda>n. fst(AB n)" and B \<equiv> "\<lambda>n. snd(AB n)" note ab_def = this AB_def
+ have "A 0 = a" "B 0 = b" "\<And>n. \<not> P {A(Suc n)..B(Suc n)} \<and>
+ (\<forall>i. A(n)$i \<le> A(Suc n)$i \<and> A(Suc n)$i \<le> B(Suc n)$i \<and> B(Suc n)$i \<le> B(n)$i \<and>
+ 2 * (B(Suc n)$i - A(Suc n)$i) \<le> B(n)$i - A(n)$i)" (is "\<And>n. ?P n")
+ proof- show "A 0 = a" "B 0 = b" unfolding ab_def by auto
+ case goal3 note S = ab_def funpow.simps o_def id_apply show ?case
+ proof(induct n) case 0 thus ?case unfolding S apply(rule f[rule_format]) using assms(3) by auto
+ next case (Suc n) show ?case unfolding S apply(rule f[rule_format]) using Suc unfolding S by auto
+ qed qed note AB = this(1-2) conjunctD2[OF this(3),rule_format]
+
+ have interv:"\<And>e. 0 < e \<Longrightarrow> \<exists>n. \<forall>x\<in>{A n..B n}. \<forall>y\<in>{A n..B n}. dist x y < e"
+ proof- case goal1 guess n using real_arch_pow2[of "(setsum (\<lambda>i. b$i - a$i) UNIV) / e"] .. note n=this
+ show ?case apply(rule_tac x=n in exI) proof(rule,rule)
+ fix x y assume xy:"x\<in>{A n..B n}" "y\<in>{A n..B n}"
+ have "dist x y \<le> setsum (\<lambda>i. abs((x - y)$i)) UNIV" unfolding vector_dist_norm by(rule norm_le_l1)
+ also have "\<dots> \<le> setsum (\<lambda>i. B n$i - A n$i) UNIV"
+ proof(rule setsum_mono) fix i show "\<bar>(x - y) $ i\<bar> \<le> B n $ i - A n $ i"
+ using xy[unfolded mem_interval,THEN spec[where x=i]]
+ unfolding vector_minus_component by auto qed
+ also have "\<dots> \<le> setsum (\<lambda>i. b$i - a$i) UNIV / 2^n" unfolding setsum_divide_distrib
+ proof(rule setsum_mono) case goal1 thus ?case
+ proof(induct n) case 0 thus ?case unfolding AB by auto
+ next case (Suc n) have "B (Suc n) $ i - A (Suc n) $ i \<le> (B n $ i - A n $ i) / 2" using AB(4)[of n i] by auto
+ also have "\<dots> \<le> (b $ i - a $ i) / 2 ^ Suc n" using Suc by(auto simp add:field_simps) finally show ?case .
+ qed qed
+ also have "\<dots> < e" using n using goal1 by(auto simp add:field_simps) finally show "dist x y < e" .
+ qed qed
+ { fix n m ::nat assume "m \<le> n" then guess d unfolding le_Suc_ex_iff .. note d=this
+ have "{A n..B n} \<subseteq> {A m..B m}" unfolding d
+ proof(induct d) case 0 thus ?case by auto
+ next case (Suc d) show ?case apply(rule subset_trans[OF _ Suc])
+ apply(rule) unfolding mem_interval apply(rule,erule_tac x=i in allE)
+ proof- case goal1 thus ?case using AB(4)[of "m + d" i] by(auto simp add:field_simps)
+ qed qed } note ABsubset = this
+ have "\<exists>a. \<forall>n. a\<in>{A n..B n}" apply(rule decreasing_closed_nest[rule_format,OF closed_interval _ ABsubset interv])
+ proof- fix n show "{A n..B n} \<noteq> {}" apply(cases "0<n") using AB(3)[of "n - 1"] assms(1,3) AB(1-2) by auto qed auto
+ then guess x0 .. note x0=this[rule_format]
+ show thesis proof(rule that[rule_format,of x0])
+ show "x0\<in>{a..b}" using x0[of 0] unfolding AB .
+ fix e assume "0 < (e::real)" from interv[OF this] guess n .. note n=this
+ show "\<exists>c d. x0 \<in> {c..d} \<and> {c..d} \<subseteq> ball x0 e \<and> {c..d} \<subseteq> {a..b} \<and> \<not> P {c..d}"
+ apply(rule_tac x="A n" in exI,rule_tac x="B n" in exI) apply(rule,rule x0) apply rule defer
+ proof show "\<not> P {A n..B n}" apply(cases "0<n") using AB(3)[of "n - 1"] assms(3) AB(1-2) by auto
+ show "{A n..B n} \<subseteq> ball x0 e" using n using x0[of n] by auto
+ show "{A n..B n} \<subseteq> {a..b}" unfolding AB(1-2)[symmetric] apply(rule ABsubset) by auto
+ qed qed qed
+
+subsection {* Cousin's lemma. *}
+
+lemma fine_division_exists: assumes "gauge g"
+ obtains p where "p tagged_division_of {a..b::real^'n}" "g fine p"
+proof- presume "\<not> (\<exists>p. p tagged_division_of {a..b} \<and> g fine p) \<Longrightarrow> False"
+ then guess p unfolding atomize_not not_not .. thus thesis apply-apply(rule that[of p]) by auto
+next assume as:"\<not> (\<exists>p. p tagged_division_of {a..b} \<and> g fine p)"
+ guess x apply(rule interval_bisection[of "\<lambda>s. \<exists>p. p tagged_division_of s \<and> g fine p",rule_format,OF _ _ as])
+ apply(rule_tac x="{}" in exI) defer apply(erule conjE exE)+
+ proof- show "{} tagged_division_of {} \<and> g fine {}" unfolding fine_def by auto
+ fix s t p p' assume "p tagged_division_of s" "g fine p" "p' tagged_division_of t" "g fine p'" "interior s \<inter> interior t = {}"
+ thus "\<exists>p. p tagged_division_of s \<union> t \<and> g fine p" apply-apply(rule_tac x="p \<union> p'" in exI) apply rule
+ apply(rule tagged_division_union) prefer 4 apply(rule fine_union) by auto
+ qed note x=this
+ obtain e where e:"e>0" "ball x e \<subseteq> g x" using gaugeD[OF assms, of x] unfolding open_contains_ball by auto
+ from x(2)[OF e(1)] guess c d apply-apply(erule exE conjE)+ . note c_d = this
+ have "g fine {(x, {c..d})}" unfolding fine_def using e using c_d(2) by auto
+ thus False using tagged_division_of_self[OF c_d(1)] using c_d by auto qed
+
+subsection {* Basic theorems about integrals. *}
+
+lemma has_integral_unique: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "(f has_integral k1) i" "(f has_integral k2) i" shows "k1 = k2"
+proof(rule ccontr) let ?e = "norm(k1 - k2) / 2" assume as:"k1 \<noteq> k2" hence e:"?e > 0" by auto
+ have lem:"\<And>f::real^'n \<Rightarrow> 'a. \<And> a b k1 k2.
+ (f has_integral k1) ({a..b}) \<Longrightarrow> (f has_integral k2) ({a..b}) \<Longrightarrow> k1 \<noteq> k2 \<Longrightarrow> False"
+ proof- case goal1 let ?e = "norm(k1 - k2) / 2" from goal1(3) have e:"?e > 0" by auto
+ guess d1 by(rule has_integralD[OF goal1(1) e]) note d1=this
+ guess d2 by(rule has_integralD[OF goal1(2) e]) note d2=this
+ guess p by(rule fine_division_exists[OF gauge_inter[OF d1(1) d2(1)],of a b]) note p=this
+ let ?c = "(\<Sum>(x, k)\<in>p. content k *\<^sub>R f x)" have "norm (k1 - k2) \<le> norm (?c - k2) + norm (?c - k1)"
+ using norm_triangle_ineq4[of "k1 - ?c" "k2 - ?c"] by(auto simp add:group_simps norm_minus_commute)
+ also have "\<dots> < norm (k1 - k2) / 2 + norm (k1 - k2) / 2"
+ apply(rule add_strict_mono) apply(rule_tac[!] d2(2) d1(2)) using p unfolding fine_def by auto
+ finally show False by auto
+ qed { presume "\<not> (\<exists>a b. i = {a..b}) \<Longrightarrow> False"
+ thus False apply-apply(cases "\<exists>a b. i = {a..b}")
+ using assms by(auto simp add:has_integral intro:lem[OF _ _ as]) }
+ assume as:"\<not> (\<exists>a b. i = {a..b})"
+ guess B1 by(rule has_integral_altD[OF assms(1) as,OF e]) note B1=this[rule_format]
+ guess B2 by(rule has_integral_altD[OF assms(2) as,OF e]) note B2=this[rule_format]
+ have "\<exists>a b::real^'n. ball 0 B1 \<union> ball 0 B2 \<subseteq> {a..b}" apply(rule bounded_subset_closed_interval)
+ using bounded_Un bounded_ball by auto then guess a b apply-by(erule exE)+
+ note ab=conjunctD2[OF this[unfolded Un_subset_iff]]
+ guess w using B1(2)[OF ab(1)] .. note w=conjunctD2[OF this]
+ guess z using B2(2)[OF ab(2)] .. note z=conjunctD2[OF this]
+ have "z = w" using lem[OF w(1) z(1)] by auto
+ hence "norm (k1 - k2) \<le> norm (z - k2) + norm (w - k1)"
+ using norm_triangle_ineq4[of "k1 - w" "k2 - z"] by(auto simp add: norm_minus_commute)
+ also have "\<dots> < norm (k1 - k2) / 2 + norm (k1 - k2) / 2" apply(rule add_strict_mono) by(rule_tac[!] z(2) w(2))
+ finally show False by auto qed
+
+lemma integral_unique[intro]:
+ "(f has_integral y) k \<Longrightarrow> integral k f = y"
+ unfolding integral_def apply(rule some_equality) by(auto intro: has_integral_unique)
+
+lemma has_integral_is_0: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "\<forall>x\<in>s. f x = 0" shows "(f has_integral 0) s"
+proof- have lem:"\<And>a b. \<And>f::real^'n \<Rightarrow> 'a.
+ (\<forall>x\<in>{a..b}. f(x) = 0) \<Longrightarrow> (f has_integral 0) ({a..b})" unfolding has_integral
+ proof(rule,rule) fix a b e and f::"real^'n \<Rightarrow> 'a"
+ assume as:"\<forall>x\<in>{a..b}. f x = 0" "0 < (e::real)"
+ show "\<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p \<longrightarrow> norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - 0) < e)"
+ apply(rule_tac x="\<lambda>x. ball x 1" in exI) apply(rule,rule gaugeI) unfolding centre_in_ball defer apply(rule open_ball)
+ proof(rule,rule,erule conjE) case goal1
+ have "(\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) = 0" proof(rule setsum_0',rule)
+ fix x assume x:"x\<in>p" have "f (fst x) = 0" using tagged_division_ofD(2-3)[OF goal1(1), of "fst x" "snd x"] using as x by auto
+ thus "(\<lambda>(x, k). content k *\<^sub>R f x) x = 0" apply(subst surjective_pairing[of x]) unfolding split_conv by auto
+ qed thus ?case using as by auto
+ qed auto qed { presume "\<not> (\<exists>a b. s = {a..b}) \<Longrightarrow> ?thesis"
+ thus ?thesis apply-apply(cases "\<exists>a b. s = {a..b}")
+ using assms by(auto simp add:has_integral intro:lem) }
+ have *:"(\<lambda>x. if x \<in> s then f x else 0) = (\<lambda>x. 0)" apply(rule ext) using assms by auto
+ assume "\<not> (\<exists>a b. s = {a..b})" thus ?thesis apply(subst has_integral_alt) unfolding if_not_P *
+ apply(rule,rule,rule_tac x=1 in exI,rule) defer apply(rule,rule,rule)
+ proof- fix e::real and a b assume "e>0"
+ thus "\<exists>z. ((\<lambda>x::real^'n. 0::'a) has_integral z) {a..b} \<and> norm (z - 0) < e"
+ apply(rule_tac x=0 in exI) apply(rule,rule lem) by auto
+ qed auto qed
+
+lemma has_integral_0[simp]: "((\<lambda>x::real^'n. 0) has_integral 0) s"
+ apply(rule has_integral_is_0) by auto
+
+lemma has_integral_0_eq[simp]: "((\<lambda>x. 0) has_integral i) s \<longleftrightarrow> i = 0"
+ using has_integral_unique[OF has_integral_0] by auto
+
+lemma has_integral_linear: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "(f has_integral y) s" "bounded_linear h" shows "((h o f) has_integral ((h y))) s"
+proof- interpret bounded_linear h using assms(2) . from pos_bounded guess B .. note B=conjunctD2[OF this,rule_format]
+ have lem:"\<And>f::real^'n \<Rightarrow> 'a. \<And> y a b.
+ (f has_integral y) ({a..b}) \<Longrightarrow> ((h o f) has_integral h(y)) ({a..b})"
+ proof(subst has_integral,rule,rule) case goal1
+ from pos_bounded guess B .. note B=conjunctD2[OF this,rule_format]
+ have *:"e / B > 0" apply(rule divide_pos_pos) using goal1(2) B by auto
+ guess g using has_integralD[OF goal1(1) *] . note g=this
+ show ?case apply(rule_tac x=g in exI) apply(rule,rule g(1))
+ proof(rule,rule,erule conjE) fix p assume as:"p tagged_division_of {a..b}" "g fine p"
+ have *:"\<And>x k. h ((\<lambda>(x, k). content k *\<^sub>R f x) x) = (\<lambda>(x, k). h (content k *\<^sub>R f x)) x" by auto
+ have "(\<Sum>(x, k)\<in>p. content k *\<^sub>R (h \<circ> f) x) = setsum (h \<circ> (\<lambda>(x, k). content k *\<^sub>R f x)) p"
+ unfolding o_def unfolding scaleR[THEN sym] * by simp
+ also have "\<dots> = h (\<Sum>(x, k)\<in>p. content k *\<^sub>R f x)" using setsum[of "\<lambda>(x,k). content k *\<^sub>R f x" p] using as by auto
+ finally have *:"(\<Sum>(x, k)\<in>p. content k *\<^sub>R (h \<circ> f) x) = h (\<Sum>(x, k)\<in>p. content k *\<^sub>R f x)" .
+ show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R (h \<circ> f) x) - h y) < e" unfolding * diff[THEN sym]
+ apply(rule le_less_trans[OF B(2)]) using g(2)[OF as] B(1) by(auto simp add:field_simps)
+ qed qed { presume "\<not> (\<exists>a b. s = {a..b}) \<Longrightarrow> ?thesis"
+ thus ?thesis apply-apply(cases "\<exists>a b. s = {a..b}") using assms by(auto simp add:has_integral intro!:lem) }
+ assume as:"\<not> (\<exists>a b. s = {a..b})" thus ?thesis apply(subst has_integral_alt) unfolding if_not_P
+ proof(rule,rule) fix e::real assume e:"0<e"
+ have *:"0 < e/B" by(rule divide_pos_pos,rule e,rule B(1))
+ guess M using has_integral_altD[OF assms(1) as *,rule_format] . note M=this
+ show "\<exists>B>0. \<forall>a b. ball 0 B \<subseteq> {a..b} \<longrightarrow> (\<exists>z. ((\<lambda>x. if x \<in> s then (h \<circ> f) x else 0) has_integral z) {a..b} \<and> norm (z - h y) < e)"
+ apply(rule_tac x=M in exI) apply(rule,rule M(1))
+ proof(rule,rule,rule) case goal1 guess z using M(2)[OF goal1(1)] .. note z=conjunctD2[OF this]
+ have *:"(\<lambda>x. if x \<in> s then (h \<circ> f) x else 0) = h \<circ> (\<lambda>x. if x \<in> s then f x else 0)"
+ unfolding o_def apply(rule ext) using zero by auto
+ show ?case apply(rule_tac x="h z" in exI,rule) unfolding * apply(rule lem[OF z(1)]) unfolding diff[THEN sym]
+ apply(rule le_less_trans[OF B(2)]) using B(1) z(2) by(auto simp add:field_simps)
+ qed qed qed
+
+lemma has_integral_cmul:
+ shows "(f has_integral k) s \<Longrightarrow> ((\<lambda>x. c *\<^sub>R f x) has_integral (c *\<^sub>R k)) s"
+ unfolding o_def[THEN sym] apply(rule has_integral_linear,assumption)
+ by(rule scaleR.bounded_linear_right)
+
+lemma has_integral_neg:
+ shows "(f has_integral k) s \<Longrightarrow> ((\<lambda>x. -(f x)) has_integral (-k)) s"
+ apply(drule_tac c="-1" in has_integral_cmul) by auto
+
+lemma has_integral_add: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "(f has_integral k) s" "(g has_integral l) s"
+ shows "((\<lambda>x. f x + g x) has_integral (k + l)) s"
+proof- have lem:"\<And>f g::real^'n \<Rightarrow> 'a. \<And>a b k l.
+ (f has_integral k) ({a..b}) \<Longrightarrow> (g has_integral l) ({a..b}) \<Longrightarrow>
+ ((\<lambda>x. f(x) + g(x)) has_integral (k + l)) ({a..b})" proof- case goal1
+ show ?case unfolding has_integral proof(rule,rule) fix e::real assume e:"e>0" hence *:"e/2>0" by auto
+ guess d1 using has_integralD[OF goal1(1) *] . note d1=this
+ guess d2 using has_integralD[OF goal1(2) *] . note d2=this
+ show "\<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p \<longrightarrow> norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R (f x + g x)) - (k + l)) < e)"
+ apply(rule_tac x="\<lambda>x. (d1 x) \<inter> (d2 x)" in exI) apply(rule,rule gauge_inter[OF d1(1) d2(1)])
+ proof(rule,rule,erule conjE) fix p assume as:"p tagged_division_of {a..b}" "(\<lambda>x. d1 x \<inter> d2 x) fine p"
+ have *:"(\<Sum>(x, k)\<in>p. content k *\<^sub>R (f x + g x)) = (\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) + (\<Sum>(x, k)\<in>p. content k *\<^sub>R g x)"
+ unfolding scaleR_right_distrib setsum_addf[of "\<lambda>(x,k). content k *\<^sub>R f x" "\<lambda>(x,k). content k *\<^sub>R g x" p,THEN sym]
+ by(rule setsum_cong2,auto)
+ have "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R (f x + g x)) - (k + l)) = norm (((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - k) + ((\<Sum>(x, k)\<in>p. content k *\<^sub>R g x) - l))"
+ unfolding * by(auto simp add:group_simps) also let ?res = "\<dots>"
+ from as have *:"d1 fine p" "d2 fine p" unfolding fine_inter by auto
+ have "?res < e/2 + e/2" apply(rule le_less_trans[OF norm_triangle_ineq])
+ apply(rule add_strict_mono) using d1(2)[OF as(1) *(1)] and d2(2)[OF as(1) *(2)] by auto
+ finally show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R (f x + g x)) - (k + l)) < e" by auto
+ qed qed qed { presume "\<not> (\<exists>a b. s = {a..b}) \<Longrightarrow> ?thesis"
+ thus ?thesis apply-apply(cases "\<exists>a b. s = {a..b}") using assms by(auto simp add:has_integral intro!:lem) }
+ assume as:"\<not> (\<exists>a b. s = {a..b})" thus ?thesis apply(subst has_integral_alt) unfolding if_not_P
+ proof(rule,rule) case goal1 hence *:"e/2 > 0" by auto
+ from has_integral_altD[OF assms(1) as *] guess B1 . note B1=this[rule_format]
+ from has_integral_altD[OF assms(2) as *] guess B2 . note B2=this[rule_format]
+ show ?case apply(rule_tac x="max B1 B2" in exI) apply(rule,rule min_max.less_supI1,rule B1)
+ proof(rule,rule,rule) fix a b assume "ball 0 (max B1 B2) \<subseteq> {a..b::real^'n}"
+ hence *:"ball 0 B1 \<subseteq> {a..b::real^'n}" "ball 0 B2 \<subseteq> {a..b::real^'n}" by auto
+ guess w using B1(2)[OF *(1)] .. note w=conjunctD2[OF this]
+ guess z using B2(2)[OF *(2)] .. note z=conjunctD2[OF this]
+ have *:"\<And>x. (if x \<in> s then f x + g x else 0) = (if x \<in> s then f x else 0) + (if x \<in> s then g x else 0)" by auto
+ show "\<exists>z. ((\<lambda>x. if x \<in> s then f x + g x else 0) has_integral z) {a..b} \<and> norm (z - (k + l)) < e"
+ apply(rule_tac x="w + z" in exI) apply(rule,rule lem[OF w(1) z(1), unfolded *[THEN sym]])
+ using norm_triangle_ineq[of "w - k" "z - l"] w(2) z(2) by(auto simp add:field_simps)
+ qed qed qed
+
+lemma has_integral_sub:
+ shows "(f has_integral k) s \<Longrightarrow> (g has_integral l) s \<Longrightarrow> ((\<lambda>x. f(x) - g(x)) has_integral (k - l)) s"
+ using has_integral_add[OF _ has_integral_neg,of f k s g l] unfolding group_simps by auto
+
+lemma integral_0: "integral s (\<lambda>x::real^'n. 0::real^'m) = 0"
+ by(rule integral_unique has_integral_0)+
+
+lemma integral_add:
+ shows "f integrable_on s \<Longrightarrow> g integrable_on s \<Longrightarrow>
+ integral s (\<lambda>x. f x + g x) = integral s f + integral s g"
+ apply(rule integral_unique) apply(drule integrable_integral)+
+ apply(rule has_integral_add) by assumption+
+
+lemma integral_cmul:
+ shows "f integrable_on s \<Longrightarrow> integral s (\<lambda>x. c *\<^sub>R f x) = c *\<^sub>R integral s f"
+ apply(rule integral_unique) apply(drule integrable_integral)+
+ apply(rule has_integral_cmul) by assumption+
+
+lemma integral_neg:
+ shows "f integrable_on s \<Longrightarrow> integral s (\<lambda>x. - f x) = - integral s f"
+ apply(rule integral_unique) apply(drule integrable_integral)+
+ apply(rule has_integral_neg) by assumption+
+
+lemma integral_sub:
+ shows "f integrable_on s \<Longrightarrow> g integrable_on s \<Longrightarrow> integral s (\<lambda>x. f x - g x) = integral s f - integral s g"
+ apply(rule integral_unique) apply(drule integrable_integral)+
+ apply(rule has_integral_sub) by assumption+
+
+lemma integrable_0: "(\<lambda>x. 0) integrable_on s"
+ unfolding integrable_on_def using has_integral_0 by auto
+
+lemma integrable_add:
+ shows "f integrable_on s \<Longrightarrow> g integrable_on s \<Longrightarrow> (\<lambda>x. f x + g x) integrable_on s"
+ unfolding integrable_on_def by(auto intro: has_integral_add)
+
+lemma integrable_cmul:
+ shows "f integrable_on s \<Longrightarrow> (\<lambda>x. c *\<^sub>R f(x)) integrable_on s"
+ unfolding integrable_on_def by(auto intro: has_integral_cmul)
+
+lemma integrable_neg:
+ shows "f integrable_on s \<Longrightarrow> (\<lambda>x. -f(x)) integrable_on s"
+ unfolding integrable_on_def by(auto intro: has_integral_neg)
+
+lemma integrable_sub:
+ shows "f integrable_on s \<Longrightarrow> g integrable_on s \<Longrightarrow> (\<lambda>x. f x - g x) integrable_on s"
+ unfolding integrable_on_def by(auto intro: has_integral_sub)
+
+lemma integrable_linear:
+ shows "f integrable_on s \<Longrightarrow> bounded_linear h \<Longrightarrow> (h o f) integrable_on s"
+ unfolding integrable_on_def by(auto intro: has_integral_linear)
+
+lemma integral_linear:
+ shows "f integrable_on s \<Longrightarrow> bounded_linear h \<Longrightarrow> integral s (h o f) = h(integral s f)"
+ apply(rule has_integral_unique) defer unfolding has_integral_integral
+ apply(drule has_integral_linear,assumption,assumption) unfolding has_integral_integral[THEN sym]
+ apply(rule integrable_linear) by assumption+
+
+lemma has_integral_setsum:
+ assumes "finite t" "\<forall>a\<in>t. ((f a) has_integral (i a)) s"
+ shows "((\<lambda>x. setsum (\<lambda>a. f a x) t) has_integral (setsum i t)) s"
+proof(insert assms(1) subset_refl[of t],induct rule:finite_subset_induct)
+ case (insert x F) show ?case unfolding setsum_insert[OF insert(1,3)]
+ apply(rule has_integral_add) using insert assms by auto
+qed auto
+
+lemma integral_setsum:
+ shows "finite t \<Longrightarrow> \<forall>a\<in>t. (f a) integrable_on s \<Longrightarrow>
+ integral s (\<lambda>x. setsum (\<lambda>a. f a x) t) = setsum (\<lambda>a. integral s (f a)) t"
+ apply(rule integral_unique) apply(rule has_integral_setsum)
+ using integrable_integral by auto
+
+lemma integrable_setsum:
+ shows "finite t \<Longrightarrow> \<forall>a \<in> t.(f a) integrable_on s \<Longrightarrow> (\<lambda>x. setsum (\<lambda>a. f a x) t) integrable_on s"
+ unfolding integrable_on_def apply(drule bchoice) using has_integral_setsum[of t] by auto
+
+lemma has_integral_eq:
+ assumes "\<forall>x\<in>s. f x = g x" "(f has_integral k) s" shows "(g has_integral k) s"
+ using has_integral_sub[OF assms(2), of "\<lambda>x. f x - g x" 0]
+ using has_integral_is_0[of s "\<lambda>x. f x - g x"] using assms(1) by auto
+
+lemma integrable_eq:
+ shows "\<forall>x\<in>s. f x = g x \<Longrightarrow> f integrable_on s \<Longrightarrow> g integrable_on s"
+ unfolding integrable_on_def using has_integral_eq[of s f g] by auto
+
+lemma has_integral_eq_eq:
+ shows "\<forall>x\<in>s. f x = g x \<Longrightarrow> ((f has_integral k) s \<longleftrightarrow> (g has_integral k) s)"
+ using has_integral_eq[of s f g] has_integral_eq[of s g f] by auto
+
+lemma has_integral_null[dest]:
+ assumes "content({a..b}) = 0" shows "(f has_integral 0) ({a..b})"
+ unfolding has_integral apply(rule,rule,rule_tac x="\<lambda>x. ball x 1" in exI,rule) defer
+proof(rule,rule,erule conjE) fix e::real assume e:"e>0" thus "gauge (\<lambda>x. ball x 1)" by auto
+ fix p assume p:"p tagged_division_of {a..b}" (*"(\<lambda>x. ball x 1) fine p"*)
+ have "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - 0) = 0" unfolding norm_eq_zero diff_0_right
+ using setsum_content_null[OF assms(1) p, of f] .
+ thus "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - 0) < e" using e by auto qed
+
+lemma has_integral_null_eq[simp]:
+ shows "content({a..b}) = 0 \<Longrightarrow> ((f has_integral i) ({a..b}) \<longleftrightarrow> i = 0)"
+ apply rule apply(rule has_integral_unique,assumption)
+ apply(drule has_integral_null,assumption)
+ apply(drule has_integral_null) by auto
+
+lemma integral_null[dest]: shows "content({a..b}) = 0 \<Longrightarrow> integral({a..b}) f = 0"
+ by(rule integral_unique,drule has_integral_null)
+
+lemma integrable_on_null[dest]: shows "content({a..b}) = 0 \<Longrightarrow> f integrable_on {a..b}"
+ unfolding integrable_on_def apply(drule has_integral_null) by auto
+
+lemma has_integral_empty[intro]: shows "(f has_integral 0) {}"
+ unfolding empty_as_interval apply(rule has_integral_null)
+ using content_empty unfolding empty_as_interval .
+
+lemma has_integral_empty_eq[simp]: shows "(f has_integral i) {} \<longleftrightarrow> i = 0"
+ apply(rule,rule has_integral_unique,assumption) by auto
+
+lemma integrable_on_empty[intro]: shows "f integrable_on {}" unfolding integrable_on_def by auto
+
+lemma integral_empty[simp]: shows "integral {} f = 0"
+ apply(rule integral_unique) using has_integral_empty .
+
+lemma has_integral_refl[intro]: shows "(f has_integral 0) {a..a}"
+ apply(rule has_integral_null) unfolding content_eq_0_interior
+ unfolding interior_closed_interval using interval_sing by auto
+
+lemma integrable_on_refl[intro]: shows "f integrable_on {a..a}" unfolding integrable_on_def by auto
+
+lemma integral_refl: shows "integral {a..a} f = 0" apply(rule integral_unique) by auto
+
+subsection {* Cauchy-type criterion for integrability. *}
+
+lemma integrable_cauchy: fixes f::"real^'n \<Rightarrow> 'a::{real_normed_vector,complete_space}"
+ shows "f integrable_on {a..b} \<longleftrightarrow>
+ (\<forall>e>0.\<exists>d. gauge d \<and> (\<forall>p1 p2. p1 tagged_division_of {a..b} \<and> d fine p1 \<and>
+ p2 tagged_division_of {a..b} \<and> d fine p2
+ \<longrightarrow> norm(setsum (\<lambda>(x,k). content k *\<^sub>R f x) p1 -
+ setsum (\<lambda>(x,k). content k *\<^sub>R f x) p2) < e))" (is "?l = (\<forall>e>0. \<exists>d. ?P e d)")
+proof assume ?l
+ then guess y unfolding integrable_on_def has_integral .. note y=this
+ show "\<forall>e>0. \<exists>d. ?P e d" proof(rule,rule) case goal1 hence "e/2 > 0" by auto
+ then guess d apply- apply(drule y[rule_format]) by(erule exE,erule conjE) note d=this[rule_format]
+ show ?case apply(rule_tac x=d in exI,rule,rule d) apply(rule,rule,rule,(erule conjE)+)
+ proof- fix p1 p2 assume as:"p1 tagged_division_of {a..b}" "d fine p1" "p2 tagged_division_of {a..b}" "d fine p2"
+ show "norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) - (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x)) < e"
+ apply(rule dist_triangle_half_l[where y=y,unfolded vector_dist_norm])
+ using d(2)[OF conjI[OF as(1-2)]] d(2)[OF conjI[OF as(3-4)]] .
+ qed qed
+next assume "\<forall>e>0. \<exists>d. ?P e d" hence "\<forall>n::nat. \<exists>d. ?P (inverse(real (n + 1))) d" by auto
+ from choice[OF this] guess d .. note d=conjunctD2[OF this[rule_format],rule_format]
+ have "\<And>n. gauge (\<lambda>x. \<Inter>{d i x |i. i \<in> {0..n}})" apply(rule gauge_inters) using d(1) by auto
+ hence "\<forall>n. \<exists>p. p tagged_division_of {a..b} \<and> (\<lambda>x. \<Inter>{d i x |i. i \<in> {0..n}}) fine p" apply-
+ proof case goal1 from this[of n] show ?case apply(drule_tac fine_division_exists) by auto qed
+ from choice[OF this] guess p .. note p = conjunctD2[OF this[rule_format]]
+ have dp:"\<And>i n. i\<le>n \<Longrightarrow> d i fine p n" using p(2) unfolding fine_inters by auto
+ have "Cauchy (\<lambda>n. setsum (\<lambda>(x,k). content k *\<^sub>R (f x)) (p n))"
+ proof(rule CauchyI) case goal1 then guess N unfolding real_arch_inv[of e] .. note N=this
+ show ?case apply(rule_tac x=N in exI)
+ proof(rule,rule,rule,rule) fix m n assume mn:"N \<le> m" "N \<le> n" have *:"N = (N - 1) + 1" using N by auto
+ show "norm ((\<Sum>(x, k)\<in>p m. content k *\<^sub>R f x) - (\<Sum>(x, k)\<in>p n. content k *\<^sub>R f x)) < e"
+ apply(rule less_trans[OF _ N[THEN conjunct2,THEN conjunct2]]) apply(subst *) apply(rule d(2))
+ using dp p(1) using mn by auto
+ qed qed
+ then guess y unfolding convergent_eq_cauchy[THEN sym] .. note y=this[unfolded Lim_sequentially,rule_format]
+ show ?l unfolding integrable_on_def has_integral apply(rule_tac x=y in exI)
+ proof(rule,rule) fix e::real assume "e>0" hence *:"e/2 > 0" by auto
+ then guess N1 unfolding real_arch_inv[of "e/2"] .. note N1=this hence N1':"N1 = N1 - 1 + 1" by auto
+ guess N2 using y[OF *] .. note N2=this
+ show "\<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p \<longrightarrow> norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - y) < e)"
+ apply(rule_tac x="d (N1 + N2)" in exI) apply rule defer
+ proof(rule,rule,erule conjE) show "gauge (d (N1 + N2))" using d by auto
+ fix q assume as:"q tagged_division_of {a..b}" "d (N1 + N2) fine q"
+ have *:"inverse (real (N1 + N2 + 1)) < e / 2" apply(rule less_trans) using N1 by auto
+ show "norm ((\<Sum>(x, k)\<in>q. content k *\<^sub>R f x) - y) < e" apply(rule norm_triangle_half_r)
+ apply(rule less_trans[OF _ *]) apply(subst N1', rule d(2)[of "p (N1+N2)"]) defer
+ using N2[rule_format,unfolded vector_dist_norm,of "N1+N2"]
+ using as dp[of "N1 - 1 + 1 + N2" "N1 + N2"] using p(1)[of "N1 + N2"] using N1 by auto qed qed qed
+
+subsection {* Additivity of integral on abutting intervals. *}
+
+lemma interval_split:
+ "{a..b::real^'n} \<inter> {x. x$k \<le> c} = {a .. (\<chi> i. if i = k then min (b$k) c else b$i)}"
+ "{a..b} \<inter> {x. x$k \<ge> c} = {(\<chi> i. if i = k then max (a$k) c else a$i) .. b}"
+ apply(rule_tac[!] set_ext) unfolding Int_iff mem_interval mem_Collect_eq
+ unfolding Cart_lambda_beta by auto
+
+lemma content_split:
+ "content {a..b::real^'n} = content({a..b} \<inter> {x. x$k \<le> c}) + content({a..b} \<inter> {x. x$k >= c})"
+proof- note simps = interval_split content_closed_interval_cases Cart_lambda_beta vector_le_def
+ { presume "a\<le>b \<Longrightarrow> ?thesis" thus ?thesis apply(cases "a\<le>b") unfolding simps by auto }
+ have *:"UNIV = insert k (UNIV - {k})" "\<And>x. finite (UNIV-{x::'n})" "\<And>x. x\<notin>UNIV-{x}" by auto
+ have *:"\<And>X Y Z. (\<Prod>i\<in>UNIV. Z i (if i = k then X else Y i)) = Z k X * (\<Prod>i\<in>UNIV-{k}. Z i (Y i))"
+ "(\<Prod>i\<in>UNIV. b$i - a$i) = (\<Prod>i\<in>UNIV-{k}. b$i - a$i) * (b$k - a$k)"
+ apply(subst *(1)) defer apply(subst *(1)) unfolding setprod_insert[OF *(2-)] by auto
+ assume as:"a\<le>b" moreover have "\<And>x. min (b $ k) c = max (a $ k) c
+ \<Longrightarrow> x* (b$k - a$k) = x*(max (a $ k) c - a $ k) + x*(b $ k - max (a $ k) c)"
+ by (auto simp add:field_simps)
+ moreover have "\<not> a $ k \<le> c \<Longrightarrow> \<not> c \<le> b $ k \<Longrightarrow> False"
+ unfolding not_le using as[unfolded vector_le_def,rule_format,of k] by auto
+ ultimately show ?thesis
+ unfolding simps unfolding *(1)[of "\<lambda>i x. b$i - x"] *(1)[of "\<lambda>i x. x - a$i"] *(2) by(auto)
+qed
+
+lemma division_split_left_inj:
+ assumes "d division_of i" "k1 \<in> d" "k2 \<in> d" "k1 \<noteq> k2"
+ "k1 \<inter> {x::real^'n. x$k \<le> c} = k2 \<inter> {x. x$k \<le> c}"
+ shows "content(k1 \<inter> {x. x$k \<le> c}) = 0"
+proof- note d=division_ofD[OF assms(1)]
+ have *:"\<And>a b::real^'n. \<And> c k. (content({a..b} \<inter> {x. x$k \<le> c}) = 0 \<longleftrightarrow> interior({a..b} \<inter> {x. x$k \<le> c}) = {})"
+ unfolding interval_split content_eq_0_interior by auto
+ guess u1 v1 using d(4)[OF assms(2)] apply-by(erule exE)+ note uv1=this
+ guess u2 v2 using d(4)[OF assms(3)] apply-by(erule exE)+ note uv2=this
+ have **:"\<And>s t u. s \<inter> t = {} \<Longrightarrow> u \<subseteq> s \<Longrightarrow> u \<subseteq> t \<Longrightarrow> u = {}" by auto
+ show ?thesis unfolding uv1 uv2 * apply(rule **[OF d(5)[OF assms(2-4)]])
+ defer apply(subst assms(5)[unfolded uv1 uv2]) unfolding uv1 uv2 by auto qed
+
+lemma division_split_right_inj:
+ assumes "d division_of i" "k1 \<in> d" "k2 \<in> d" "k1 \<noteq> k2"
+ "k1 \<inter> {x::real^'n. x$k \<ge> c} = k2 \<inter> {x. x$k \<ge> c}"
+ shows "content(k1 \<inter> {x. x$k \<ge> c}) = 0"
+proof- note d=division_ofD[OF assms(1)]
+ have *:"\<And>a b::real^'n. \<And> c k. (content({a..b} \<inter> {x. x$k >= c}) = 0 \<longleftrightarrow> interior({a..b} \<inter> {x. x$k >= c}) = {})"
+ unfolding interval_split content_eq_0_interior by auto
+ guess u1 v1 using d(4)[OF assms(2)] apply-by(erule exE)+ note uv1=this
+ guess u2 v2 using d(4)[OF assms(3)] apply-by(erule exE)+ note uv2=this
+ have **:"\<And>s t u. s \<inter> t = {} \<Longrightarrow> u \<subseteq> s \<Longrightarrow> u \<subseteq> t \<Longrightarrow> u = {}" by auto
+ show ?thesis unfolding uv1 uv2 * apply(rule **[OF d(5)[OF assms(2-4)]])
+ defer apply(subst assms(5)[unfolded uv1 uv2]) unfolding uv1 uv2 by auto qed
+
+lemma tagged_division_split_left_inj:
+ assumes "d tagged_division_of i" "(x1,k1) \<in> d" "(x2,k2) \<in> d" "k1 \<noteq> k2" "k1 \<inter> {x. x$k \<le> c} = k2 \<inter> {x. x$k \<le> c}"
+ shows "content(k1 \<inter> {x. x$k \<le> c}) = 0"
+proof- have *:"\<And>a b c. (a,b) \<in> c \<Longrightarrow> b \<in> snd ` c" unfolding image_iff apply(rule_tac x="(a,b)" in bexI) by auto
+ show ?thesis apply(rule division_split_left_inj[OF division_of_tagged_division[OF assms(1)]])
+ apply(rule_tac[1-2] *) using assms(2-) by auto qed
+
+lemma tagged_division_split_right_inj:
+ assumes "d tagged_division_of i" "(x1,k1) \<in> d" "(x2,k2) \<in> d" "k1 \<noteq> k2" "k1 \<inter> {x. x$k \<ge> c} = k2 \<inter> {x. x$k \<ge> c}"
+ shows "content(k1 \<inter> {x. x$k \<ge> c}) = 0"
+proof- have *:"\<And>a b c. (a,b) \<in> c \<Longrightarrow> b \<in> snd ` c" unfolding image_iff apply(rule_tac x="(a,b)" in bexI) by auto
+ show ?thesis apply(rule division_split_right_inj[OF division_of_tagged_division[OF assms(1)]])
+ apply(rule_tac[1-2] *) using assms(2-) by auto qed
+
+lemma division_split:
+ assumes "p division_of {a..b::real^'n}"
+ shows "{l \<inter> {x. x$k \<le> c} | l. l \<in> p \<and> ~(l \<inter> {x. x$k \<le> c} = {})} division_of ({a..b} \<inter> {x. x$k \<le> c})" (is "?p1 division_of ?I1") and
+ "{l \<inter> {x. x$k \<ge> c} | l. l \<in> p \<and> ~(l \<inter> {x. x$k \<ge> c} = {})} division_of ({a..b} \<inter> {x. x$k \<ge> c})" (is "?p2 division_of ?I2")
+proof(rule_tac[!] division_ofI) note p=division_ofD[OF assms]
+ show "finite ?p1" "finite ?p2" using p(1) by auto show "\<Union>?p1 = ?I1" "\<Union>?p2 = ?I2" unfolding p(6)[THEN sym] by auto
+ { fix k assume "k\<in>?p1" then guess l unfolding mem_Collect_eq apply-by(erule exE,(erule conjE)+) note l=this
+ guess u v using p(4)[OF l(2)] apply-by(erule exE)+ note uv=this
+ show "k\<subseteq>?I1" "k \<noteq> {}" "\<exists>a b. k = {a..b}" unfolding l
+ using p(2-3)[OF l(2)] l(3) unfolding uv apply- prefer 3 apply(subst interval_split) by auto
+ fix k' assume "k'\<in>?p1" then guess l' unfolding mem_Collect_eq apply-by(erule exE,(erule conjE)+) note l'=this
+ assume "k\<noteq>k'" thus "interior k \<inter> interior k' = {}" unfolding l l' using p(5)[OF l(2) l'(2)] by auto }
+ { fix k assume "k\<in>?p2" then guess l unfolding mem_Collect_eq apply-by(erule exE,(erule conjE)+) note l=this
+ guess u v using p(4)[OF l(2)] apply-by(erule exE)+ note uv=this
+ show "k\<subseteq>?I2" "k \<noteq> {}" "\<exists>a b. k = {a..b}" unfolding l
+ using p(2-3)[OF l(2)] l(3) unfolding uv apply- prefer 3 apply(subst interval_split) by auto
+ fix k' assume "k'\<in>?p2" then guess l' unfolding mem_Collect_eq apply-by(erule exE,(erule conjE)+) note l'=this
+ assume "k\<noteq>k'" thus "interior k \<inter> interior k' = {}" unfolding l l' using p(5)[OF l(2) l'(2)] by auto }
+qed
+
+lemma has_integral_split: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "(f has_integral i) ({a..b} \<inter> {x. x$k \<le> c})" "(f has_integral j) ({a..b} \<inter> {x. x$k \<ge> c})"
+ shows "(f has_integral (i + j)) ({a..b})"
+proof(unfold has_integral,rule,rule) case goal1 hence e:"e/2>0" by auto
+ guess d1 using has_integralD[OF assms(1)[unfolded interval_split] e] . note d1=this[unfolded interval_split[THEN sym]]
+ guess d2 using has_integralD[OF assms(2)[unfolded interval_split] e] . note d2=this[unfolded interval_split[THEN sym]]
+ let ?d = "\<lambda>x. if x$k = c then (d1 x \<inter> d2 x) else ball x (abs(x$k - c)) \<inter> d1 x \<inter> d2 x"
+ show ?case apply(rule_tac x="?d" in exI,rule) defer apply(rule,rule,(erule conjE)+)
+ proof- show "gauge ?d" using d1(1) d2(1) unfolding gauge_def by auto
+ fix p assume "p tagged_division_of {a..b}" "?d fine p" note p = this tagged_division_ofD[OF this(1)]
+ have lem0:"\<And>x kk. (x,kk) \<in> p \<Longrightarrow> ~(kk \<inter> {x. x$k \<le> c} = {}) \<Longrightarrow> x$k \<le> c"
+ "\<And>x kk. (x,kk) \<in> p \<Longrightarrow> ~(kk \<inter> {x. x$k \<ge> c} = {}) \<Longrightarrow> x$k \<ge> c"
+ proof- fix x kk assume as:"(x,kk)\<in>p"
+ show "~(kk \<inter> {x. x$k \<le> c} = {}) \<Longrightarrow> x$k \<le> c"
+ proof(rule ccontr) case goal1
+ from this(2)[unfolded not_le] have "kk \<subseteq> ball x \<bar>x $ k - c\<bar>"
+ using p(2)[unfolded fine_def,rule_format,OF as,unfolded split_conv] by auto
+ hence "\<exists>y. y \<in> ball x \<bar>x $ k - c\<bar> \<inter> {x. x $ k \<le> c}" using goal1(1) by blast
+ then guess y .. hence "\<bar>x $ k - y $ k\<bar> < \<bar>x $ k - c\<bar>" "y$k \<le> c" apply-apply(rule le_less_trans)
+ using component_le_norm[of "x - y" k,unfolded vector_minus_component] by(auto simp add:vector_dist_norm)
+ thus False using goal1(2)[unfolded not_le] by(auto simp add:field_simps)
+ qed
+ show "~(kk \<inter> {x. x$k \<ge> c} = {}) \<Longrightarrow> x$k \<ge> c"
+ proof(rule ccontr) case goal1
+ from this(2)[unfolded not_le] have "kk \<subseteq> ball x \<bar>x $ k - c\<bar>"
+ using p(2)[unfolded fine_def,rule_format,OF as,unfolded split_conv] by auto
+ hence "\<exists>y. y \<in> ball x \<bar>x $ k - c\<bar> \<inter> {x. x $ k \<ge> c}" using goal1(1) by blast
+ then guess y .. hence "\<bar>x $ k - y $ k\<bar> < \<bar>x $ k - c\<bar>" "y$k \<ge> c" apply-apply(rule le_less_trans)
+ using component_le_norm[of "x - y" k,unfolded vector_minus_component] by(auto simp add:vector_dist_norm)
+ thus False using goal1(2)[unfolded not_le] by(auto simp add:field_simps)
+ qed
+ qed
+
+ have lem1: "\<And>f P Q. (\<forall>x k. (x,k) \<in> {(x,f k) | x k. P x k} \<longrightarrow> Q x k) \<longleftrightarrow> (\<forall>x k. P x k \<longrightarrow> Q x (f k))" by auto
+ have lem2: "\<And>f s P f. finite s \<Longrightarrow> finite {(x,f k) | x k. (x,k) \<in> s \<and> P x k}"
+ proof- case goal1 thus ?case apply-apply(rule finite_subset[of _ "(\<lambda>(x,k). (x,f k)) ` s"]) by auto qed
+ have lem3: "\<And>g::(real ^ 'n \<Rightarrow> bool) \<Rightarrow> real ^ 'n \<Rightarrow> bool. finite p \<Longrightarrow>
+ setsum (\<lambda>(x,k). content k *\<^sub>R f x) {(x,g k) |x k. (x,k) \<in> p \<and> ~(g k = {})}
+ = setsum (\<lambda>(x,k). content k *\<^sub>R f x) ((\<lambda>(x,k). (x,g k)) ` p)"
+ apply(rule setsum_mono_zero_left) prefer 3
+ proof fix g::"(real ^ 'n \<Rightarrow> bool) \<Rightarrow> real ^ 'n \<Rightarrow> bool" and i::"(real^'n) \<times> ((real^'n) set)"
+ assume "i \<in> (\<lambda>(x, k). (x, g k)) ` p - {(x, g k) |x k. (x, k) \<in> p \<and> g k \<noteq> {}}"
+ then obtain x k where xk:"i=(x,g k)" "(x,k)\<in>p" "(x,g k) \<notin> {(x, g k) |x k. (x, k) \<in> p \<and> g k \<noteq> {}}" by auto
+ have "content (g k) = 0" using xk using content_empty by auto
+ thus "(\<lambda>(x, k). content k *\<^sub>R f x) i = 0" unfolding xk split_conv by auto
+ qed auto
+ have lem4:"\<And>g. (\<lambda>(x,l). content (g l) *\<^sub>R f x) = (\<lambda>(x,l). content l *\<^sub>R f x) o (\<lambda>(x,l). (x,g l))" apply(rule ext) by auto
+
+ let ?M1 = "{(x,kk \<inter> {x. x$k \<le> c}) |x kk. (x,kk) \<in> p \<and> kk \<inter> {x. x$k \<le> c} \<noteq> {}}"
+ have "norm ((\<Sum>(x, k)\<in>?M1. content k *\<^sub>R f x) - i) < e/2" apply(rule d1(2),rule tagged_division_ofI)
+ apply(rule lem2 p(3))+ prefer 6 apply(rule fineI)
+ proof- show "\<Union>{k. \<exists>x. (x, k) \<in> ?M1} = {a..b} \<inter> {x. x$k \<le> c}" unfolding p(8)[THEN sym] by auto
+ fix x l assume xl:"(x,l)\<in>?M1"
+ then guess x' l' unfolding mem_Collect_eq apply- unfolding Pair_eq apply((erule exE)+,(erule conjE)+) . note xl'=this
+ have "l' \<subseteq> d1 x'" apply(rule order_trans[OF fineD[OF p(2) xl'(3)]]) by auto
+ thus "l \<subseteq> d1 x" unfolding xl' by auto
+ show "x\<in>l" "l \<subseteq> {a..b} \<inter> {x. x $ k \<le> c}" unfolding xl' using p(4-6)[OF xl'(3)] using xl'(4)
+ using lem0(1)[OF xl'(3-4)] by auto
+ show "\<exists>a b. l = {a..b}" unfolding xl' using p(6)[OF xl'(3)] by(fastsimp simp add: interval_split[where c=c and k=k])
+ fix y r let ?goal = "interior l \<inter> interior r = {}" assume yr:"(y,r)\<in>?M1"
+ then guess y' r' unfolding mem_Collect_eq apply- unfolding Pair_eq apply((erule exE)+,(erule conjE)+) . note yr'=this
+ assume as:"(x,l) \<noteq> (y,r)" show "interior l \<inter> interior r = {}"
+ proof(cases "l' = r' \<longrightarrow> x' = y'")
+ case False thus ?thesis using p(7)[OF xl'(3) yr'(3)] using as unfolding xl' yr' by auto
+ next case True hence "l' \<noteq> r'" using as unfolding xl' yr' by auto
+ thus ?thesis using p(7)[OF xl'(3) yr'(3)] using as unfolding xl' yr' by auto
+ qed qed moreover
+
+ let ?M2 = "{(x,kk \<inter> {x. x$k \<ge> c}) |x kk. (x,kk) \<in> p \<and> kk \<inter> {x. x$k \<ge> c} \<noteq> {}}"
+ have "norm ((\<Sum>(x, k)\<in>?M2. content k *\<^sub>R f x) - j) < e/2" apply(rule d2(2),rule tagged_division_ofI)
+ apply(rule lem2 p(3))+ prefer 6 apply(rule fineI)
+ proof- show "\<Union>{k. \<exists>x. (x, k) \<in> ?M2} = {a..b} \<inter> {x. x$k \<ge> c}" unfolding p(8)[THEN sym] by auto
+ fix x l assume xl:"(x,l)\<in>?M2"
+ then guess x' l' unfolding mem_Collect_eq apply- unfolding Pair_eq apply((erule exE)+,(erule conjE)+) . note xl'=this
+ have "l' \<subseteq> d2 x'" apply(rule order_trans[OF fineD[OF p(2) xl'(3)]]) by auto
+ thus "l \<subseteq> d2 x" unfolding xl' by auto
+ show "x\<in>l" "l \<subseteq> {a..b} \<inter> {x. x $ k \<ge> c}" unfolding xl' using p(4-6)[OF xl'(3)] using xl'(4)
+ using lem0(2)[OF xl'(3-4)] by auto
+ show "\<exists>a b. l = {a..b}" unfolding xl' using p(6)[OF xl'(3)] by(fastsimp simp add: interval_split[where c=c and k=k])
+ fix y r let ?goal = "interior l \<inter> interior r = {}" assume yr:"(y,r)\<in>?M2"
+ then guess y' r' unfolding mem_Collect_eq apply- unfolding Pair_eq apply((erule exE)+,(erule conjE)+) . note yr'=this
+ assume as:"(x,l) \<noteq> (y,r)" show "interior l \<inter> interior r = {}"
+ proof(cases "l' = r' \<longrightarrow> x' = y'")
+ case False thus ?thesis using p(7)[OF xl'(3) yr'(3)] using as unfolding xl' yr' by auto
+ next case True hence "l' \<noteq> r'" using as unfolding xl' yr' by auto
+ thus ?thesis using p(7)[OF xl'(3) yr'(3)] using as unfolding xl' yr' by auto
+ qed qed ultimately
+
+ have "norm (((\<Sum>(x, k)\<in>?M1. content k *\<^sub>R f x) - i) + ((\<Sum>(x, k)\<in>?M2. content k *\<^sub>R f x) - j)) < e/2 + e/2"
+ apply- apply(rule norm_triangle_lt) by auto
+ also { have *:"\<And>x y. x = (0::real) \<Longrightarrow> x *\<^sub>R (y::'a) = 0" using scaleR_zero_left by auto
+ have "((\<Sum>(x, k)\<in>?M1. content k *\<^sub>R f x) - i) + ((\<Sum>(x, k)\<in>?M2. content k *\<^sub>R f x) - j)
+ = (\<Sum>(x, k)\<in>?M1. content k *\<^sub>R f x) + (\<Sum>(x, k)\<in>?M2. content k *\<^sub>R f x) - (i + j)" by auto
+ also have "\<dots> = (\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. x $ k \<le> c}) *\<^sub>R f x) + (\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. c \<le> x $ k}) *\<^sub>R f x) - (i + j)"
+ unfolding lem3[OF p(3)] apply(subst setsum_reindex_nonzero[OF p(3)]) defer apply(subst setsum_reindex_nonzero[OF p(3)])
+ defer unfolding lem4[THEN sym] apply(rule refl) unfolding split_paired_all split_conv apply(rule_tac[!] *)
+ proof- case goal1 thus ?case apply- apply(rule tagged_division_split_left_inj [OF p(1), of a b aa ba]) by auto
+ next case goal2 thus ?case apply- apply(rule tagged_division_split_right_inj[OF p(1), of a b aa ba]) by auto
+ qed also note setsum_addf[THEN sym]
+ also have *:"\<And>x. x\<in>p \<Longrightarrow> (\<lambda>(x, ka). content (ka \<inter> {x. x $ k \<le> c}) *\<^sub>R f x) x + (\<lambda>(x, ka). content (ka \<inter> {x. c \<le> x $ k}) *\<^sub>R f x) x
+ = (\<lambda>(x,ka). content ka *\<^sub>R f x) x" unfolding split_paired_all split_conv
+ proof- fix a b assume "(a,b) \<in> p" from p(6)[OF this] guess u v apply-by(erule exE)+ note uv=this
+ thus "content (b \<inter> {x. x $ k \<le> c}) *\<^sub>R f a + content (b \<inter> {x. c \<le> x $ k}) *\<^sub>R f a = content b *\<^sub>R f a"
+ unfolding scaleR_left_distrib[THEN sym] unfolding uv content_split[of u v k c] by auto
+ qed note setsum_cong2[OF this]
+ finally have "(\<Sum>(x, k)\<in>{(x, kk \<inter> {x. x $ k \<le> c}) |x kk. (x, kk) \<in> p \<and> kk \<inter> {x. x $ k \<le> c} \<noteq> {}}. content k *\<^sub>R f x) - i +
+ ((\<Sum>(x, k)\<in>{(x, kk \<inter> {x. c \<le> x $ k}) |x kk. (x, kk) \<in> p \<and> kk \<inter> {x. c \<le> x $ k} \<noteq> {}}. content k *\<^sub>R f x) - j) =
+ (\<Sum>(x, ka)\<in>p. content ka *\<^sub>R f x) - (i + j)" by auto }
+ finally show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - (i + j)) < e" by auto qed qed
+
+subsection {* A sort of converse, integrability on subintervals. *}
+
+lemma tagged_division_union_interval:
+ assumes "p1 tagged_division_of ({a..b} \<inter> {x::real^'n. x$k \<le> (c::real)})" "p2 tagged_division_of ({a..b} \<inter> {x. x$k \<ge> c})"
+ shows "(p1 \<union> p2) tagged_division_of ({a..b})"
+proof- have *:"{a..b} = ({a..b} \<inter> {x. x$k \<le> c}) \<union> ({a..b} \<inter> {x. x$k \<ge> c})" by auto
+ show ?thesis apply(subst *) apply(rule tagged_division_union[OF assms])
+ unfolding interval_split interior_closed_interval
+ by(auto simp add: vector_less_def Cart_lambda_beta elim!:allE[where x=k]) qed
+
+lemma has_integral_separate_sides: fixes f::"real^'m \<Rightarrow> 'a::real_normed_vector"
+ assumes "(f has_integral i) ({a..b})" "e>0"
+ obtains d where "gauge d" "(\<forall>p1 p2. p1 tagged_division_of ({a..b} \<inter> {x. x$k \<le> c}) \<and> d fine p1 \<and>
+ p2 tagged_division_of ({a..b} \<inter> {x. x$k \<ge> c}) \<and> d fine p2
+ \<longrightarrow> norm((setsum (\<lambda>(x,k). content k *\<^sub>R f x) p1 +
+ setsum (\<lambda>(x,k). content k *\<^sub>R f x) p2) - i) < e)"
+proof- guess d using has_integralD[OF assms] . note d=this
+ show ?thesis apply(rule that[of d]) apply(rule d) apply(rule,rule,rule,(erule conjE)+)
+ proof- fix p1 p2 assume "p1 tagged_division_of {a..b} \<inter> {x. x $ k \<le> c}" "d fine p1" note p1=tagged_division_ofD[OF this(1)] this
+ assume "p2 tagged_division_of {a..b} \<inter> {x. c \<le> x $ k}" "d fine p2" note p2=tagged_division_ofD[OF this(1)] this
+ note tagged_division_union_interval[OF p1(7) p2(7)] note p12 = tagged_division_ofD[OF this] this
+ have "norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) + (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x) - i) = norm ((\<Sum>(x, k)\<in>p1 \<union> p2. content k *\<^sub>R f x) - i)"
+ apply(subst setsum_Un_zero) apply(rule p1 p2)+ apply(rule) unfolding split_paired_all split_conv
+ proof- fix a b assume ab:"(a,b) \<in> p1 \<inter> p2"
+ have "(a,b) \<in> p1" using ab by auto from p1(4)[OF this] guess u v apply-by(erule exE)+ note uv =this
+ have "b \<subseteq> {x. x$k = c}" using ab p1(3)[of a b] p2(3)[of a b] by fastsimp
+ moreover have "interior {x. x $ k = c} = {}"
+ proof(rule ccontr) case goal1 then obtain x where x:"x\<in>interior {x. x$k = c}" by auto
+ then guess e unfolding mem_interior .. note e=this
+ have x:"x$k = c" using x interior_subset by fastsimp
+ have *:"\<And>i. \<bar>(x - (x + (\<chi> i. if i = k then e / 2 else 0))) $ i\<bar> = (if i = k then e/2 else 0)" using e by auto
+ have "x + (\<chi> i. if i = k then e/2 else 0) \<in> ball x e" unfolding mem_ball vector_dist_norm
+ apply(rule le_less_trans[OF norm_le_l1]) unfolding *
+ unfolding setsum_delta[OF finite_UNIV] using e by auto
+ hence "x + (\<chi> i. if i = k then e/2 else 0) \<in> {x. x$k = c}" using e by auto
+ thus False unfolding mem_Collect_eq using e x by auto
+ qed ultimately have "content b = 0" unfolding uv content_eq_0_interior apply-apply(drule subset_interior) by auto
+ thus "content b *\<^sub>R f a = 0" by auto
+ qed auto
+ also have "\<dots> < e" by(rule d(2) p12 fine_union p1 p2)+
+ finally show "norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) + (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x) - i) < e" . qed qed
+
+lemma integrable_split[intro]: fixes f::"real^'n \<Rightarrow> 'a::{real_normed_vector,complete_space}" assumes "f integrable_on {a..b}"
+ shows "f integrable_on ({a..b} \<inter> {x. x$k \<le> c})" (is ?t1) and "f integrable_on ({a..b} \<inter> {x. x$k \<ge> c})" (is ?t2)
+proof- guess y using assms unfolding integrable_on_def .. note y=this
+ def b' \<equiv> "(\<chi> i. if i = k then min (b$k) c else b$i)::real^'n"
+ and a' \<equiv> "(\<chi> i. if i = k then max (a$k) c else a$i)::real^'n"
+ show ?t1 ?t2 unfolding interval_split integrable_cauchy unfolding interval_split[THEN sym]
+ proof(rule_tac[!] allI impI)+ fix e::real assume "e>0" hence "e/2>0" by auto
+ from has_integral_separate_sides[OF y this,of k c] guess d . note d=this[rule_format]
+ let ?P = "\<lambda>A. \<exists>d. gauge d \<and> (\<forall>p1 p2. p1 tagged_division_of {a..b} \<inter> A \<and> d fine p1 \<and> p2 tagged_division_of {a..b} \<inter> A \<and> d fine p2 \<longrightarrow>
+ norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) - (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x)) < e)"
+ show "?P {x. x $ k \<le> c}" apply(rule_tac x=d in exI) apply(rule,rule d) apply(rule,rule,rule)
+ proof- fix p1 p2 assume as:"p1 tagged_division_of {a..b} \<inter> {x. x $ k \<le> c} \<and> d fine p1 \<and> p2 tagged_division_of {a..b} \<inter> {x. x $ k \<le> c} \<and> d fine p2"
+ show "norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) - (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x)) < e"
+ proof- guess p using fine_division_exists[OF d(1), of a' b] . note p=this
+ show ?thesis using norm_triangle_half_l[OF d(2)[of p1 p] d(2)[of p2 p]]
+ using as unfolding interval_split b'_def[symmetric] a'_def[symmetric]
+ using p using assms by(auto simp add:group_simps)
+ qed qed
+ show "?P {x. x $ k \<ge> c}" apply(rule_tac x=d in exI) apply(rule,rule d) apply(rule,rule,rule)
+ proof- fix p1 p2 assume as:"p1 tagged_division_of {a..b} \<inter> {x. x $ k \<ge> c} \<and> d fine p1 \<and> p2 tagged_division_of {a..b} \<inter> {x. x $ k \<ge> c} \<and> d fine p2"
+ show "norm ((\<Sum>(x, k)\<in>p1. content k *\<^sub>R f x) - (\<Sum>(x, k)\<in>p2. content k *\<^sub>R f x)) < e"
+ proof- guess p using fine_division_exists[OF d(1), of a b'] . note p=this
+ show ?thesis using norm_triangle_half_l[OF d(2)[of p p1] d(2)[of p p2]]
+ using as unfolding interval_split b'_def[symmetric] a'_def[symmetric]
+ using p using assms by(auto simp add:group_simps) qed qed qed qed
+
+subsection {* Generalized notion of additivity. *}
+
+definition "neutral opp = (SOME x. \<forall>y. opp x y = y \<and> opp y x = y)"
+
+definition operative :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ((real^'n) set \<Rightarrow> 'a) \<Rightarrow> bool" where
+ "operative opp f \<equiv>
+ (\<forall>a b. content {a..b} = 0 \<longrightarrow> f {a..b} = neutral(opp)) \<and>
+ (\<forall>a b c k. f({a..b}) =
+ opp (f({a..b} \<inter> {x. x$k \<le> c}))
+ (f({a..b} \<inter> {x. x$k \<ge> c})))"
+
+lemma operativeD[dest]: assumes "operative opp f"
+ shows "\<And>a b. content {a..b} = 0 \<Longrightarrow> f {a..b} = neutral(opp)"
+ "\<And>a b c k. f({a..b}) = opp (f({a..b} \<inter> {x. x$k \<le> c})) (f({a..b} \<inter> {x. x$k \<ge> c}))"
+ using assms unfolding operative_def by auto
+
+lemma operative_trivial:
+ "operative opp f \<Longrightarrow> content({a..b}) = 0 \<Longrightarrow> f({a..b}) = neutral opp"
+ unfolding operative_def by auto
+
+lemma property_empty_interval:
+ "(\<forall>a b. content({a..b}) = 0 \<longrightarrow> P({a..b})) \<Longrightarrow> P {}"
+ using content_empty unfolding empty_as_interval by auto
+
+lemma operative_empty: "operative opp f \<Longrightarrow> f {} = neutral opp"
+ unfolding operative_def apply(rule property_empty_interval) by auto
+
+subsection {* Using additivity of lifted function to encode definedness. *}
+
+lemma forall_option: "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>x. P(Some x))"
+ by (metis map_of.simps option.nchotomy)
+
+lemma exists_option:
+ "(\<exists>x. P x) \<longleftrightarrow> P None \<or> (\<exists>x. P(Some x))"
+ by (metis map_of.simps option.nchotomy)
+
+fun lifted where
+ "lifted (opp::'a\<Rightarrow>'a\<Rightarrow>'b) (Some x) (Some y) = Some(opp x y)" |
+ "lifted opp None _ = (None::'b option)" |
+ "lifted opp _ None = None"
+
+lemma lifted_simp_1[simp]: "lifted opp v None = None"
+ apply(induct v) by auto
+
+definition "monoidal opp \<equiv> (\<forall>x y. opp x y = opp y x) \<and>
+ (\<forall>x y z. opp x (opp y z) = opp (opp x y) z) \<and>
+ (\<forall>x. opp (neutral opp) x = x)"
+
+lemma monoidalI: assumes "\<And>x y. opp x y = opp y x"
+ "\<And>x y z. opp x (opp y z) = opp (opp x y) z"
+ "\<And>x. opp (neutral opp) x = x" shows "monoidal opp"
+ unfolding monoidal_def using assms by fastsimp
+
+lemma monoidal_ac: assumes "monoidal opp"
+ shows "opp (neutral opp) a = a" "opp a (neutral opp) = a" "opp a b = opp b a"
+ "opp (opp a b) c = opp a (opp b c)" "opp a (opp b c) = opp b (opp a c)"
+ using assms unfolding monoidal_def apply- by metis+
+
+lemma monoidal_simps[simp]: assumes "monoidal opp"
+ shows "opp (neutral opp) a = a" "opp a (neutral opp) = a"
+ using monoidal_ac[OF assms] by auto
+
+lemma neutral_lifted[cong]: assumes "monoidal opp"
+ shows "neutral (lifted opp) = Some(neutral opp)"
+ apply(subst neutral_def) apply(rule some_equality) apply(rule,induct_tac y) prefer 3
+proof- fix x assume "\<forall>y. lifted opp x y = y \<and> lifted opp y x = y"
+ thus "x = Some (neutral opp)" apply(induct x) defer
+ apply rule apply(subst neutral_def) apply(subst eq_commute,rule some_equality)
+ apply(rule,erule_tac x="Some y" in allE) defer apply(erule_tac x="Some x" in allE) by auto
+qed(auto simp add:monoidal_ac[OF assms])
+
+lemma monoidal_lifted[intro]: assumes "monoidal opp" shows "monoidal(lifted opp)"
+ unfolding monoidal_def forall_option neutral_lifted[OF assms] using monoidal_ac[OF assms] by auto
+
+definition "support opp f s = {x. x\<in>s \<and> f x \<noteq> neutral opp}"
+definition "fold' opp e s \<equiv> (if finite s then fold opp e s else e)"
+definition "iterate opp s f \<equiv> fold' (\<lambda>x a. opp (f x) a) (neutral opp) (support opp f s)"
+
+lemma support_subset[intro]:"support opp f s \<subseteq> s" unfolding support_def by auto
+lemma support_empty[simp]:"support opp f {} = {}" using support_subset[of opp f "{}"] by auto
+
+lemma fun_left_comm_monoidal[intro]: assumes "monoidal opp" shows "fun_left_comm opp"
+ unfolding fun_left_comm_def using monoidal_ac[OF assms] by auto
+
+lemma support_clauses:
+ "\<And>f g s. support opp f {} = {}"
+ "\<And>f g s. support opp f (insert x s) = (if f(x) = neutral opp then support opp f s else insert x (support opp f s))"
+ "\<And>f g s. support opp f (s - {x}) = (support opp f s) - {x}"
+ "\<And>f g s. support opp f (s \<union> t) = (support opp f s) \<union> (support opp f t)"
+ "\<And>f g s. support opp f (s \<inter> t) = (support opp f s) \<inter> (support opp f t)"
+ "\<And>f g s. support opp f (s - t) = (support opp f s) - (support opp f t)"
+ "\<And>f g s. support opp g (f ` s) = f ` (support opp (g o f) s)"
+unfolding support_def by auto
+
+lemma finite_support[intro]:"finite s \<Longrightarrow> finite (support opp f s)"
+ unfolding support_def by auto
+
+lemma iterate_empty[simp]:"iterate opp {} f = neutral opp"
+ unfolding iterate_def fold'_def by auto
+
+lemma iterate_insert[simp]: assumes "monoidal opp" "finite s"
+ shows "iterate opp (insert x s) f = (if x \<in> s then iterate opp s f else opp (f x) (iterate opp s f))"
+proof(cases "x\<in>s") case True hence *:"insert x s = s" by auto
+ show ?thesis unfolding iterate_def if_P[OF True] * by auto
+next case False note x=this
+ note * = fun_left_comm.fun_left_comm_apply[OF fun_left_comm_monoidal[OF assms(1)]]
+ show ?thesis proof(cases "f x = neutral opp")
+ case True show ?thesis unfolding iterate_def if_not_P[OF x] support_clauses if_P[OF True]
+ unfolding True monoidal_simps[OF assms(1)] by auto
+ next case False show ?thesis unfolding iterate_def fold'_def if_not_P[OF x] support_clauses if_not_P[OF False]
+ apply(subst fun_left_comm.fold_insert[OF * finite_support])
+ using `finite s` unfolding support_def using False x by auto qed qed
+
+lemma iterate_some:
+ assumes "monoidal opp" "finite s"
+ shows "iterate (lifted opp) s (\<lambda>x. Some(f x)) = Some (iterate opp s f)" using assms(2)
+proof(induct s) case empty thus ?case using assms by auto
+next case (insert x F) show ?case apply(subst iterate_insert) prefer 3 apply(subst if_not_P)
+ defer unfolding insert(3) lifted.simps apply rule using assms insert by auto qed
+
+subsection {* Two key instances of additivity. *}
+
+lemma neutral_add[simp]:
+ "neutral op + = (0::_::comm_monoid_add)" unfolding neutral_def
+ apply(rule some_equality) defer apply(erule_tac x=0 in allE) by auto
+
+lemma operative_content[intro]: "operative (op +) content"
+ unfolding operative_def content_split[THEN sym] neutral_add by auto
+
+lemma neutral_monoid[simp]: "neutral ((op +)::('a::comm_monoid_add) \<Rightarrow> 'a \<Rightarrow> 'a) = 0"
+ unfolding neutral_def apply(rule some_equality) defer
+ apply(erule_tac x=0 in allE) by auto
+
+lemma monoidal_monoid[intro]:
+ shows "monoidal ((op +)::('a::comm_monoid_add) \<Rightarrow> 'a \<Rightarrow> 'a)"
+ unfolding monoidal_def neutral_monoid by(auto simp add: group_simps)
+
+lemma operative_integral: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ shows "operative (lifted(op +)) (\<lambda>i. if f integrable_on i then Some(integral i f) else None)"
+ unfolding operative_def unfolding neutral_lifted[OF monoidal_monoid] neutral_add
+ apply(rule,rule,rule,rule) defer apply(rule allI)+
+proof- fix a b c k show "(if f integrable_on {a..b} then Some (integral {a..b} f) else None) =
+ lifted op + (if f integrable_on {a..b} \<inter> {x. x $ k \<le> c} then Some (integral ({a..b} \<inter> {x. x $ k \<le> c}) f) else None)
+ (if f integrable_on {a..b} \<inter> {x. c \<le> x $ k} then Some (integral ({a..b} \<inter> {x. c \<le> x $ k}) f) else None)"
+ proof(cases "f integrable_on {a..b}")
+ case True show ?thesis unfolding if_P[OF True]
+ unfolding if_P[OF integrable_split(1)[OF True]] if_P[OF integrable_split(2)[OF True]]
+ unfolding lifted.simps option.inject apply(rule integral_unique) apply(rule has_integral_split)
+ apply(rule_tac[!] integrable_integral integrable_split)+ using True by assumption+
+ next case False have "(\<not> (f integrable_on {a..b} \<inter> {x. x $ k \<le> c})) \<or> (\<not> ( f integrable_on {a..b} \<inter> {x. c \<le> x $ k}))"
+ proof(rule ccontr) case goal1 hence "f integrable_on {a..b}" apply- unfolding integrable_on_def
+ apply(rule_tac x="integral ({a..b} \<inter> {x. x $ k \<le> c}) f + integral ({a..b} \<inter> {x. x $ k \<ge> c}) f" in exI)
+ apply(rule has_integral_split) apply(rule_tac[!] integrable_integral) by auto
+ thus False using False by auto
+ qed thus ?thesis using False by auto
+ qed next
+ fix a b assume as:"content {a..b::real^'n} = 0"
+ thus "(if f integrable_on {a..b} then Some (integral {a..b} f) else None) = Some 0"
+ unfolding if_P[OF integrable_on_null[OF as]] using has_integral_null_eq[OF as] by auto qed
+
+subsection {* Points of division of a partition. *}
+
+definition "division_points (k::(real^'n) set) d =
+ {(j,x). (interval_lowerbound k)$j < x \<and> x < (interval_upperbound k)$j \<and>
+ (\<exists>i\<in>d. (interval_lowerbound i)$j = x \<or> (interval_upperbound i)$j = x)}"
+
+lemma division_points_finite: assumes "d division_of i"
+ shows "finite (division_points i d)"
+proof- note assm = division_ofD[OF assms]
+ let ?M = "\<lambda>j. {(j,x)|x. (interval_lowerbound i)$j < x \<and> x < (interval_upperbound i)$j \<and>
+ (\<exists>i\<in>d. (interval_lowerbound i)$j = x \<or> (interval_upperbound i)$j = x)}"
+ have *:"division_points i d = \<Union>(?M ` UNIV)"
+ unfolding division_points_def by auto
+ show ?thesis unfolding * using assm by auto qed
+
+lemma division_points_subset:
+ assumes "d division_of {a..b}" "\<forall>i. a$i < b$i" "a$k < c" "c < b$k"
+ shows "division_points ({a..b} \<inter> {x. x$k \<le> c}) {l \<inter> {x. x$k \<le> c} | l . l \<in> d \<and> ~(l \<inter> {x. x$k \<le> c} = {})}
+ \<subseteq> division_points ({a..b}) d" (is ?t1) and
+ "division_points ({a..b} \<inter> {x. x$k \<ge> c}) {l \<inter> {x. x$k \<ge> c} | l . l \<in> d \<and> ~(l \<inter> {x. x$k \<ge> c} = {})}
+ \<subseteq> division_points ({a..b}) d" (is ?t2)
+proof- note assm = division_ofD[OF assms(1)]
+ have *:"\<forall>i. a$i \<le> b$i" "\<forall>i. a$i \<le> (\<chi> i. if i = k then min (b $ k) c else b $ i) $ i"
+ "\<forall>i. (\<chi> i. if i = k then max (a $ k) c else a $ i) $ i \<le> b$i" "min (b $ k) c = c" "max (a $ k) c = c"
+ using assms using less_imp_le by auto
+ show ?t1 unfolding division_points_def interval_split[of a b]
+ unfolding interval_bounds[OF *(1)] interval_bounds[OF *(2)] interval_bounds[OF *(3)] Cart_lambda_beta unfolding *
+ unfolding subset_eq apply(rule) unfolding mem_Collect_eq split_beta apply(erule bexE conjE)+ unfolding mem_Collect_eq apply(erule exE conjE)+
+ proof- fix i l x assume as:"a $ fst x < snd x" "snd x < (if fst x = k then c else b $ fst x)"
+ "interval_lowerbound i $ fst x = snd x \<or> interval_upperbound i $ fst x = snd x" "i = l \<inter> {x. x $ k \<le> c}" "l \<in> d" "l \<inter> {x. x $ k \<le> c} \<noteq> {}"
+ from assm(4)[OF this(5)] guess u v apply-by(erule exE)+ note l=this
+ have *:"\<forall>i. u $ i \<le> (\<chi> i. if i = k then min (v $ k) c else v $ i) $ i" using as(6) unfolding l interval_split interval_ne_empty as .
+ have **:"\<forall>i. u$i \<le> v$i" using l using as(6) unfolding interval_ne_empty[THEN sym] by auto
+ show "a $ fst x < snd x \<and> snd x < b $ fst x \<and> (\<exists>i\<in>d. interval_lowerbound i $ fst x = snd x \<or> interval_upperbound i $ fst x = snd x)"
+ using as(1-3,5) unfolding l interval_split interval_ne_empty as interval_bounds[OF *] Cart_lambda_beta apply-
+ apply(rule,assumption,rule) defer apply(rule_tac x="{u..v}" in bexI) unfolding interval_bounds[OF **]
+ apply(case_tac[!] "fst x = k") using assms by auto
+ qed
+ show ?t2 unfolding division_points_def interval_split[of a b]
+ unfolding interval_bounds[OF *(1)] interval_bounds[OF *(2)] interval_bounds[OF *(3)] Cart_lambda_beta unfolding *
+ unfolding subset_eq apply(rule) unfolding mem_Collect_eq split_beta apply(erule bexE conjE)+ unfolding mem_Collect_eq apply(erule exE conjE)+
+ proof- fix i l x assume as:"(if fst x = k then c else a $ fst x) < snd x" "snd x < b $ fst x" "interval_lowerbound i $ fst x = snd x \<or> interval_upperbound i $ fst x = snd x"
+ "i = l \<inter> {x. c \<le> x $ k}" "l \<in> d" "l \<inter> {x. c \<le> x $ k} \<noteq> {}"
+ from assm(4)[OF this(5)] guess u v apply-by(erule exE)+ note l=this
+ have *:"\<forall>i. (\<chi> i. if i = k then max (u $ k) c else u $ i) $ i \<le> v $ i" using as(6) unfolding l interval_split interval_ne_empty as .
+ have **:"\<forall>i. u$i \<le> v$i" using l using as(6) unfolding interval_ne_empty[THEN sym] by auto
+ show "a $ fst x < snd x \<and> snd x < b $ fst x \<and> (\<exists>i\<in>d. interval_lowerbound i $ fst x = snd x \<or> interval_upperbound i $ fst x = snd x)"
+ using as(1-3,5) unfolding l interval_split interval_ne_empty as interval_bounds[OF *] Cart_lambda_beta apply-
+ apply rule defer apply(rule,assumption) apply(rule_tac x="{u..v}" in bexI) unfolding interval_bounds[OF **]
+ apply(case_tac[!] "fst x = k") using assms by auto qed qed
+
+lemma division_points_psubset:
+ assumes "d division_of {a..b}" "\<forall>i. a$i < b$i" "a$k < c" "c < b$k"
+ "l \<in> d" "interval_lowerbound l$k = c \<or> interval_upperbound l$k = c"
+ shows "division_points ({a..b} \<inter> {x. x$k \<le> c}) {l \<inter> {x. x$k \<le> c} | l. l\<in>d \<and> l \<inter> {x. x$k \<le> c} \<noteq> {}} \<subset> division_points ({a..b}) d" (is "?D1 \<subset> ?D")
+ "division_points ({a..b} \<inter> {x. x$k \<ge> c}) {l \<inter> {x. x$k \<ge> c} | l. l\<in>d \<and> l \<inter> {x. x$k \<ge> c} \<noteq> {}} \<subset> division_points ({a..b}) d" (is "?D2 \<subset> ?D")
+proof- have ab:"\<forall>i. a$i \<le> b$i" using assms(2) by(auto intro!:less_imp_le)
+ guess u v using division_ofD(4)[OF assms(1,5)] apply-by(erule exE)+ note l=this
+ have uv:"\<forall>i. u$i \<le> v$i" "\<forall>i. a$i \<le> u$i \<and> v$i \<le> b$i" using division_ofD(2,2,3)[OF assms(1,5)] unfolding l interval_ne_empty
+ unfolding subset_eq apply- defer apply(erule_tac x=u in ballE, erule_tac x=v in ballE) unfolding mem_interval by auto
+ have *:"interval_upperbound ({a..b} \<inter> {x. x $ k \<le> interval_upperbound l $ k}) $ k = interval_upperbound l $ k"
+ "interval_upperbound ({a..b} \<inter> {x. x $ k \<le> interval_lowerbound l $ k}) $ k = interval_lowerbound l $ k"
+ unfolding interval_split apply(subst interval_bounds) prefer 3 apply(subst interval_bounds)
+ unfolding l interval_bounds[OF uv(1)] using uv[rule_format,of k] ab by auto
+ have "\<exists>x. x \<in> ?D - ?D1" using assms(2-) apply-apply(erule disjE)
+ apply(rule_tac x="(k,(interval_lowerbound l)$k)" in exI) defer
+ apply(rule_tac x="(k,(interval_upperbound l)$k)" in exI)
+ unfolding division_points_def unfolding interval_bounds[OF ab]
+ apply (auto simp add:interval_bounds) unfolding * by auto
+ thus "?D1 \<subset> ?D" apply-apply(rule,rule division_points_subset[OF assms(1-4)]) by auto
+
+ have *:"interval_lowerbound ({a..b} \<inter> {x. x $ k \<ge> interval_lowerbound l $ k}) $ k = interval_lowerbound l $ k"
+ "interval_lowerbound ({a..b} \<inter> {x. x $ k \<ge> interval_upperbound l $ k}) $ k = interval_upperbound l $ k"
+ unfolding interval_split apply(subst interval_bounds) prefer 3 apply(subst interval_bounds)
+ unfolding l interval_bounds[OF uv(1)] using uv[rule_format,of k] ab by auto
+ have "\<exists>x. x \<in> ?D - ?D2" using assms(2-) apply-apply(erule disjE)
+ apply(rule_tac x="(k,(interval_lowerbound l)$k)" in exI) defer
+ apply(rule_tac x="(k,(interval_upperbound l)$k)" in exI)
+ unfolding division_points_def unfolding interval_bounds[OF ab]
+ apply (auto simp add:interval_bounds) unfolding * by auto
+ thus "?D2 \<subset> ?D" apply-apply(rule,rule division_points_subset[OF assms(1-4)]) by auto qed
+
+subsection {* Preservation by divisions and tagged divisions. *}
+
+lemma support_support[simp]:"support opp f (support opp f s) = support opp f s"
+ unfolding support_def by auto
+
+lemma iterate_support[simp]: "iterate opp (support opp f s) f = iterate opp s f"
+ unfolding iterate_def support_support by auto
+
+lemma iterate_expand_cases:
+ "iterate opp s f = (if finite(support opp f s) then iterate opp (support opp f s) f else neutral opp)"
+ apply(cases) apply(subst if_P,assumption) unfolding iterate_def support_support fold'_def by auto
+
+lemma iterate_image: assumes "monoidal opp" "inj_on f s"
+ shows "iterate opp (f ` s) g = iterate opp s (g \<circ> f)"
+proof- have *:"\<And>s. finite s \<Longrightarrow> \<forall>x\<in>s. \<forall>y\<in>s. f x = f y \<longrightarrow> x = y \<Longrightarrow>
+ iterate opp (f ` s) g = iterate opp s (g \<circ> f)"
+ proof- case goal1 show ?case using goal1
+ proof(induct s) case empty thus ?case using assms(1) by auto
+ next case (insert x s) show ?case unfolding iterate_insert[OF assms(1) insert(1)]
+ unfolding if_not_P[OF insert(2)] apply(subst insert(3)[THEN sym])
+ unfolding image_insert defer apply(subst iterate_insert[OF assms(1)])
+ apply(rule finite_imageI insert)+ apply(subst if_not_P)
+ unfolding image_iff o_def using insert(2,4) by auto
+ qed qed
+ show ?thesis
+ apply(cases "finite (support opp g (f ` s))")
+ apply(subst (1) iterate_support[THEN sym],subst (2) iterate_support[THEN sym])
+ unfolding support_clauses apply(rule *)apply(rule finite_imageD,assumption) unfolding inj_on_def[symmetric]
+ apply(rule subset_inj_on[OF assms(2) support_subset])+
+ apply(subst iterate_expand_cases) unfolding support_clauses apply(simp only: if_False)
+ apply(subst iterate_expand_cases) apply(subst if_not_P) by auto qed
+
+
+(* This lemma about iterations comes up in a few places. *)
+lemma iterate_nonzero_image_lemma:
+ assumes "monoidal opp" "finite s" "g(a) = neutral opp"
+ "\<forall>x\<in>s. \<forall>y\<in>s. f x = f y \<and> x \<noteq> y \<longrightarrow> g(f x) = neutral opp"
+ shows "iterate opp {f x | x. x \<in> s \<and> f x \<noteq> a} g = iterate opp s (g \<circ> f)"
+proof- have *:"{f x |x. x \<in> s \<and> ~(f x = a)} = f ` {x. x \<in> s \<and> ~(f x = a)}" by auto
+ have **:"support opp (g \<circ> f) {x \<in> s. f x \<noteq> a} = support opp (g \<circ> f) s"
+ unfolding support_def using assms(3) by auto
+ show ?thesis unfolding *
+ apply(subst iterate_support[THEN sym]) unfolding support_clauses
+ apply(subst iterate_image[OF assms(1)]) defer
+ apply(subst(2) iterate_support[THEN sym]) apply(subst **)
+ unfolding inj_on_def using assms(3,4) unfolding support_def by auto qed
+
+lemma iterate_eq_neutral:
+ assumes "monoidal opp" "\<forall>x \<in> s. (f(x) = neutral opp)"
+ shows "(iterate opp s f = neutral opp)"
+proof- have *:"support opp f s = {}" unfolding support_def using assms(2) by auto
+ show ?thesis apply(subst iterate_support[THEN sym])
+ unfolding * using assms(1) by auto qed
+
+lemma iterate_op: assumes "monoidal opp" "finite s"
+ shows "iterate opp s (\<lambda>x. opp (f x) (g x)) = opp (iterate opp s f) (iterate opp s g)" using assms(2)
+proof(induct s) case empty thus ?case unfolding iterate_insert[OF assms(1)] using assms(1) by auto
+next case (insert x F) show ?case unfolding iterate_insert[OF assms(1) insert(1)] if_not_P[OF insert(2)] insert(3)
+ unfolding monoidal_ac[OF assms(1)] by(rule refl) qed
+
+lemma iterate_eq: assumes "monoidal opp" "\<And>x. x \<in> s \<Longrightarrow> f x = g x"
+ shows "iterate opp s f = iterate opp s g"
+proof- have *:"support opp g s = support opp f s"
+ unfolding support_def using assms(2) by auto
+ show ?thesis
+ proof(cases "finite (support opp f s)")
+ case False thus ?thesis apply(subst iterate_expand_cases,subst(2) iterate_expand_cases)
+ unfolding * by auto
+ next def su \<equiv> "support opp f s"
+ case True note support_subset[of opp f s]
+ thus ?thesis apply- apply(subst iterate_support[THEN sym],subst(2) iterate_support[THEN sym]) unfolding * using True
+ unfolding su_def[symmetric]
+ proof(induct su) case empty show ?case by auto
+ next case (insert x s) show ?case unfolding iterate_insert[OF assms(1) insert(1)]
+ unfolding if_not_P[OF insert(2)] apply(subst insert(3))
+ defer apply(subst assms(2)[of x]) using insert by auto qed qed qed
+
+lemma nonempty_witness: assumes "s \<noteq> {}" obtains x where "x \<in> s" using assms by auto
+
+lemma operative_division: fixes f::"(real^'n) set \<Rightarrow> 'a"
+ assumes "monoidal opp" "operative opp f" "d division_of {a..b}"
+ shows "iterate opp d f = f {a..b}"
+proof- def C \<equiv> "card (division_points {a..b} d)" thus ?thesis using assms
+ proof(induct C arbitrary:a b d rule:full_nat_induct)
+ case goal1
+ { presume *:"content {a..b} \<noteq> 0 \<Longrightarrow> ?case"
+ thus ?case apply-apply(cases) defer apply assumption
+ proof- assume as:"content {a..b} = 0"
+ show ?case unfolding operativeD(1)[OF assms(2) as] apply(rule iterate_eq_neutral[OF goal1(2)])
+ proof fix x assume x:"x\<in>d"
+ then guess u v apply(drule_tac division_ofD(4)[OF goal1(4)]) by(erule exE)+
+ thus "f x = neutral opp" using division_of_content_0[OF as goal1(4)]
+ using operativeD(1)[OF assms(2)] x by auto
+ qed qed }
+ assume "content {a..b} \<noteq> 0" note ab = this[unfolded content_lt_nz[THEN sym] content_pos_lt_eq]
+ hence ab':"\<forall>i. a$i \<le> b$i" by (auto intro!: less_imp_le) show ?case
+ proof(cases "division_points {a..b} d = {}")
+ case True have d':"\<forall>i\<in>d. \<exists>u v. i = {u..v} \<and>
+ (\<forall>j. u$j = a$j \<and> v$j = a$j \<or> u$j = b$j \<and> v$j = b$j \<or> u$j = a$j \<and> v$j = b$j)"
+ unfolding forall_in_division[OF goal1(4)] apply(rule,rule,rule)
+ apply(rule_tac x=a in exI,rule_tac x=b in exI) apply(rule,rule refl) apply(rule)
+ proof- fix u v j assume as:"{u..v} \<in> d" note division_ofD(3)[OF goal1(4) this]
+ hence uv:"\<forall>i. u$i \<le> v$i" "u$j \<le> v$j" unfolding interval_ne_empty by auto
+ have *:"\<And>p r Q. p \<or> r \<or> (\<forall>x\<in>d. Q x) \<Longrightarrow> p \<or> r \<or> (Q {u..v})" using as by auto
+ have "(j, u$j) \<notin> division_points {a..b} d"
+ "(j, v$j) \<notin> division_points {a..b} d" using True by auto
+ note this[unfolded de_Morgan_conj division_points_def mem_Collect_eq split_conv interval_bounds[OF ab'] bex_simps]
+ note *[OF this(1)] *[OF this(2)] note this[unfolded interval_bounds[OF uv(1)]]
+ moreover have "a$j \<le> u$j" "v$j \<le> b$j" using division_ofD(2,2,3)[OF goal1(4) as]
+ unfolding subset_eq apply- apply(erule_tac x=u in ballE,erule_tac[3] x=v in ballE)
+ unfolding interval_ne_empty mem_interval by auto
+ ultimately show "u$j = a$j \<and> v$j = a$j \<or> u$j = b$j \<and> v$j = b$j \<or> u$j = a$j \<and> v$j = b$j"
+ unfolding not_less de_Morgan_disj using ab[rule_format,of j] uv(2) by auto
+ qed have "(1/2) *\<^sub>R (a+b) \<in> {a..b}" unfolding mem_interval using ab by(auto intro!:less_imp_le)
+ note this[unfolded division_ofD(6)[OF goal1(4),THEN sym] Union_iff]
+ then guess i .. note i=this guess u v using d'[rule_format,OF i(1)] apply-by(erule exE conjE)+ note uv=this
+ have "{a..b} \<in> d"
+ proof- { presume "i = {a..b}" thus ?thesis using i by auto }
+ { presume "u = a" "v = b" thus "i = {a..b}" using uv by auto }
+ show "u = a" "v = b" unfolding Cart_eq
+ proof(rule_tac[!] allI) fix j note i(2)[unfolded uv mem_interval,rule_format,of j]
+ thus "u $ j = a $ j" "v $ j = b $ j" using uv(2)[rule_format,of j] by auto
+ qed qed
+ hence *:"d = insert {a..b} (d - {{a..b}})" by auto
+ have "iterate opp (d - {{a..b}}) f = neutral opp" apply(rule iterate_eq_neutral[OF goal1(2)])
+ proof fix x assume x:"x \<in> d - {{a..b}}" hence "x\<in>d" by auto note d'[rule_format,OF this]
+ then guess u v apply-by(erule exE conjE)+ note uv=this
+ have "u\<noteq>a \<or> v\<noteq>b" using x[unfolded uv] by auto
+ then obtain j where "u$j \<noteq> a$j \<or> v$j \<noteq> b$j" unfolding Cart_eq by auto
+ hence "u$j = v$j" using uv(2)[rule_format,of j] by auto
+ hence "content {u..v} = 0" unfolding content_eq_0 apply(rule_tac x=j in exI) by auto
+ thus "f x = neutral opp" unfolding uv(1) by(rule operativeD(1)[OF goal1(3)])
+ qed thus "iterate opp d f = f {a..b}" apply-apply(subst *)
+ apply(subst iterate_insert[OF goal1(2)]) using goal1(2,4) by auto
+ next case False hence "\<exists>x. x\<in>division_points {a..b} d" by auto
+ then guess k c unfolding split_paired_Ex apply- unfolding division_points_def mem_Collect_eq split_conv
+ by(erule exE conjE)+ note kc=this[unfolded interval_bounds[OF ab']]
+ from this(3) guess j .. note j=this
+ def d1 \<equiv> "{l \<inter> {x. x$k \<le> c} | l. l \<in> d \<and> l \<inter> {x. x$k \<le> c} \<noteq> {}}"
+ def d2 \<equiv> "{l \<inter> {x. x$k \<ge> c} | l. l \<in> d \<and> l \<inter> {x. x$k \<ge> c} \<noteq> {}}"
+ def cb \<equiv> "(\<chi> i. if i = k then c else b$i)" and ca \<equiv> "(\<chi> i. if i = k then c else a$i)"
+ note division_points_psubset[OF goal1(4) ab kc(1-2) j]
+ note psubset_card_mono[OF _ this(1)] psubset_card_mono[OF _ this(2)]
+ hence *:"(iterate opp d1 f) = f ({a..b} \<inter> {x. x$k \<le> c})" "(iterate opp d2 f) = f ({a..b} \<inter> {x. x$k \<ge> c})"
+ apply- unfolding interval_split apply(rule_tac[!] goal1(1)[rule_format])
+ using division_split[OF goal1(4), where k=k and c=c]
+ unfolding interval_split d1_def[symmetric] d2_def[symmetric] unfolding goal1(2) Suc_le_mono
+ using goal1(2-3) using division_points_finite[OF goal1(4)] by auto
+ have "f {a..b} = opp (iterate opp d1 f) (iterate opp d2 f)" (is "_ = ?prev")
+ unfolding * apply(rule operativeD(2)) using goal1(3) .
+ also have "iterate opp d1 f = iterate opp d (\<lambda>l. f(l \<inter> {x. x$k \<le> c}))"
+ unfolding d1_def apply(rule iterate_nonzero_image_lemma[unfolded o_def])
+ unfolding empty_as_interval apply(rule goal1 division_of_finite operativeD[OF goal1(3)])+
+ unfolding empty_as_interval[THEN sym] apply(rule content_empty)
+ proof(rule,rule,rule,erule conjE) fix l y assume as:"l \<in> d" "y \<in> d" "l \<inter> {x. x $ k \<le> c} = y \<inter> {x. x $ k \<le> c}" "l \<noteq> y"
+ from division_ofD(4)[OF goal1(4) this(1)] guess u v apply-by(erule exE)+ note l=this
+ show "f (l \<inter> {x. x $ k \<le> c}) = neutral opp" unfolding l interval_split
+ apply(rule operativeD(1) goal1)+ unfolding interval_split[THEN sym] apply(rule division_split_left_inj)
+ apply(rule goal1) unfolding l[THEN sym] apply(rule as(1),rule as(2)) by(rule as)+
+ qed also have "iterate opp d2 f = iterate opp d (\<lambda>l. f(l \<inter> {x. x$k \<ge> c}))"
+ unfolding d2_def apply(rule iterate_nonzero_image_lemma[unfolded o_def])
+ unfolding empty_as_interval apply(rule goal1 division_of_finite operativeD[OF goal1(3)])+
+ unfolding empty_as_interval[THEN sym] apply(rule content_empty)
+ proof(rule,rule,rule,erule conjE) fix l y assume as:"l \<in> d" "y \<in> d" "l \<inter> {x. c \<le> x $ k} = y \<inter> {x. c \<le> x $ k}" "l \<noteq> y"
+ from division_ofD(4)[OF goal1(4) this(1)] guess u v apply-by(erule exE)+ note l=this
+ show "f (l \<inter> {x. x $ k \<ge> c}) = neutral opp" unfolding l interval_split
+ apply(rule operativeD(1) goal1)+ unfolding interval_split[THEN sym] apply(rule division_split_right_inj)
+ apply(rule goal1) unfolding l[THEN sym] apply(rule as(1),rule as(2)) by(rule as)+
+ qed also have *:"\<forall>x\<in>d. f x = opp (f (x \<inter> {x. x $ k \<le> c})) (f (x \<inter> {x. c \<le> x $ k}))"
+ unfolding forall_in_division[OF goal1(4)] apply(rule,rule,rule,rule operativeD(2)) using goal1(3) .
+ have "opp (iterate opp d (\<lambda>l. f (l \<inter> {x. x $ k \<le> c}))) (iterate opp d (\<lambda>l. f (l \<inter> {x. c \<le> x $ k})))
+ = iterate opp d f" apply(subst(3) iterate_eq[OF _ *[rule_format]]) prefer 3
+ apply(rule iterate_op[THEN sym]) using goal1 by auto
+ finally show ?thesis by auto
+ qed qed qed
+
+lemma iterate_image_nonzero: assumes "monoidal opp"
+ "finite s" "\<forall>x\<in>s. \<forall>y\<in>s. ~(x = y) \<and> f x = f y \<longrightarrow> g(f x) = neutral opp"
+ shows "iterate opp (f ` s) g = iterate opp s (g \<circ> f)" using assms
+proof(induct rule:finite_subset_induct[OF assms(2) subset_refl])
+ case goal1 show ?case using assms(1) by auto
+next case goal2 have *:"\<And>x y. y = neutral opp \<Longrightarrow> x = opp y x" using assms(1) by auto
+ show ?case unfolding image_insert apply(subst iterate_insert[OF assms(1)])
+ apply(rule finite_imageI goal2)+
+ apply(cases "f a \<in> f ` F") unfolding if_P if_not_P apply(subst goal2(4)[OF assms(1) goal2(1)]) defer
+ apply(subst iterate_insert[OF assms(1) goal2(1)]) defer
+ apply(subst iterate_insert[OF assms(1) goal2(1)])
+ unfolding if_not_P[OF goal2(3)] defer unfolding image_iff defer apply(erule bexE)
+ apply(rule *) unfolding o_def apply(rule_tac y=x in goal2(7)[rule_format])
+ using goal2 unfolding o_def by auto qed
+
+lemma operative_tagged_division: assumes "monoidal opp" "operative opp f" "d tagged_division_of {a..b}"
+ shows "iterate(opp) d (\<lambda>(x,l). f l) = f {a..b}"
+proof- have *:"(\<lambda>(x,l). f l) = (f o snd)" unfolding o_def by(rule,auto) note assm = tagged_division_ofD[OF assms(3)]
+ have "iterate(opp) d (\<lambda>(x,l). f l) = iterate opp (snd ` d) f" unfolding *
+ apply(rule iterate_image_nonzero[THEN sym,OF assms(1)]) apply(rule tagged_division_of_finite assms)+
+ unfolding Ball_def split_paired_All snd_conv apply(rule,rule,rule,rule,rule,rule,rule,erule conjE)
+ proof- fix a b aa ba assume as:"(a, b) \<in> d" "(aa, ba) \<in> d" "(a, b) \<noteq> (aa, ba)" "b = ba"
+ guess u v using assm(4)[OF as(1)] apply-by(erule exE)+ note uv=this
+ show "f b = neutral opp" unfolding uv apply(rule operativeD(1)[OF assms(2)])
+ unfolding content_eq_0_interior using tagged_division_ofD(5)[OF assms(3) as(1-3)]
+ unfolding as(4)[THEN sym] uv by auto
+ qed also have "\<dots> = f {a..b}"
+ using operative_division[OF assms(1-2) division_of_tagged_division[OF assms(3)]] .
+ finally show ?thesis . qed
+
+subsection {* Additivity of content. *}
+
+lemma setsum_iterate:assumes "finite s" shows "setsum f s = iterate op + s f"
+proof- have *:"setsum f s = setsum f (support op + f s)"
+ apply(rule setsum_mono_zero_right)
+ unfolding support_def neutral_monoid using assms by auto
+ thus ?thesis unfolding * setsum_def iterate_def fold_image_def fold'_def
+ unfolding neutral_monoid . qed
+
+lemma additive_content_division: assumes "d division_of {a..b}"
+ shows "setsum content d = content({a..b})"
+ unfolding operative_division[OF monoidal_monoid operative_content assms,THEN sym]
+ apply(subst setsum_iterate) using assms by auto
+
+lemma additive_content_tagged_division:
+ assumes "d tagged_division_of {a..b}"
+ shows "setsum (\<lambda>(x,l). content l) d = content({a..b})"
+ unfolding operative_tagged_division[OF monoidal_monoid operative_content assms,THEN sym]
+ apply(subst setsum_iterate) using assms by auto
+
+subsection {* Finally, the integral of a constant\<forall> *}
+
+lemma has_integral_const[intro]:
+ "((\<lambda>x. c) has_integral (content({a..b::real^'n}) *\<^sub>R c)) ({a..b})"
+ unfolding has_integral apply(rule,rule,rule_tac x="\<lambda>x. ball x 1" in exI)
+ apply(rule,rule gauge_trivial)apply(rule,rule,erule conjE)
+ unfolding split_def apply(subst scaleR_left.setsum[THEN sym, unfolded o_def])
+ defer apply(subst additive_content_tagged_division[unfolded split_def]) apply assumption by auto
+
+subsection {* Bounds on the norm of Riemann sums and the integral itself. *}
+
+lemma dsum_bound: assumes "p division_of {a..b}" "norm(c) \<le> e"
+ shows "norm(setsum (\<lambda>l. content l *\<^sub>R c) p) \<le> e * content({a..b})" (is "?l \<le> ?r")
+ apply(rule order_trans,rule setsum_norm) defer unfolding norm_scaleR setsum_left_distrib[THEN sym]
+ apply(rule order_trans[OF mult_left_mono],rule assms,rule setsum_abs_ge_zero)
+ apply(subst real_mult_commute) apply(rule mult_left_mono)
+ apply(rule order_trans[of _ "setsum content p"]) apply(rule eq_refl,rule setsum_cong2)
+ apply(subst abs_of_nonneg) unfolding additive_content_division[OF assms(1)]
+proof- from order_trans[OF norm_ge_zero[of c] assms(2)] show "0 \<le> e" .
+ fix x assume "x\<in>p" from division_ofD(4)[OF assms(1) this] guess u v apply-by(erule exE)+
+ thus "0 \<le> content x" using content_pos_le by auto
+qed(insert assms,auto)
+
+lemma rsum_bound: assumes "p tagged_division_of {a..b}" "\<forall>x\<in>{a..b}. norm(f x) \<le> e"
+ shows "norm(setsum (\<lambda>(x,k). content k *\<^sub>R f x) p) \<le> e * content({a..b})"
+proof(cases "{a..b} = {}") case True
+ show ?thesis using assms(1) unfolding True tagged_division_of_trivial by auto
+next case False show ?thesis
+ apply(rule order_trans,rule setsum_norm) defer unfolding split_def norm_scaleR
+ apply(rule order_trans[OF setsum_mono]) apply(rule mult_left_mono[OF _ abs_ge_zero, of _ e]) defer
+ unfolding setsum_left_distrib[THEN sym] apply(subst real_mult_commute) apply(rule mult_left_mono)
+ apply(rule order_trans[of _ "setsum (content \<circ> snd) p"]) apply(rule eq_refl,rule setsum_cong2)
+ apply(subst o_def, rule abs_of_nonneg)
+ proof- show "setsum (content \<circ> snd) p \<le> content {a..b}" apply(rule eq_refl)
+ unfolding additive_content_tagged_division[OF assms(1),THEN sym] split_def by auto
+ guess w using nonempty_witness[OF False] .
+ thus "e\<ge>0" apply-apply(rule order_trans) defer apply(rule assms(2)[rule_format],assumption) by auto
+ fix xk assume *:"xk\<in>p" guess x k using surj_pair[of xk] apply-by(erule exE)+ note xk = this *[unfolded this]
+ from tagged_division_ofD(4)[OF assms(1) xk(2)] guess u v apply-by(erule exE)+ note uv=this
+ show "0\<le> content (snd xk)" unfolding xk snd_conv uv by(rule content_pos_le)
+ show "norm (f (fst xk)) \<le> e" unfolding xk fst_conv using tagged_division_ofD(2,3)[OF assms(1) xk(2)] assms(2) by auto
+ qed(insert assms,auto) qed
+
+lemma rsum_diff_bound:
+ assumes "p tagged_division_of {a..b}" "\<forall>x\<in>{a..b}. norm(f x - g x) \<le> e"
+ shows "norm(setsum (\<lambda>(x,k). content k *\<^sub>R f x) p - setsum (\<lambda>(x,k). content k *\<^sub>R g x) p) \<le> e * content({a..b})"
+ apply(rule order_trans[OF _ rsum_bound[OF assms]]) apply(rule eq_refl) apply(rule arg_cong[where f=norm])
+ unfolding setsum_subtractf[THEN sym] apply(rule setsum_cong2) unfolding scaleR.diff_right by auto
+
+lemma has_integral_bound: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "0 \<le> B" "(f has_integral i) ({a..b})" "\<forall>x\<in>{a..b}. norm(f x) \<le> B"
+ shows "norm i \<le> B * content {a..b}"
+proof- let ?P = "content {a..b} > 0" { presume "?P \<Longrightarrow> ?thesis"
+ thus ?thesis proof(cases ?P) case False
+ hence *:"content {a..b} = 0" using content_lt_nz by auto
+ hence **:"i = 0" using assms(2) apply(subst has_integral_null_eq[THEN sym]) by auto
+ show ?thesis unfolding * ** using assms(1) by auto
+ qed auto } assume ab:?P
+ { presume "\<not> ?thesis \<Longrightarrow> False" thus ?thesis by auto }
+ assume "\<not> ?thesis" hence *:"norm i - B * content {a..b} > 0" by auto
+ from assms(2)[unfolded has_integral,rule_format,OF *] guess d apply-by(erule exE conjE)+ note d=this[rule_format]
+ from fine_division_exists[OF this(1), of a b] guess p . note p=this
+ have *:"\<And>s B. norm s \<le> B \<Longrightarrow> \<not> (norm (s - i) < norm i - B)"
+ proof- case goal1 thus ?case unfolding not_less
+ using norm_triangle_sub[of i s] unfolding norm_minus_commute by auto
+ qed show False using d(2)[OF conjI[OF p]] *[OF rsum_bound[OF p(1) assms(3)]] by auto qed
+
+subsection {* Similar theorems about relationship among components. *}
+
+lemma rsum_component_le: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "p tagged_division_of {a..b}" "\<forall>x\<in>{a..b}. (f x)$i \<le> (g x)$i"
+ shows "(setsum (\<lambda>(x,k). content k *\<^sub>R f x) p)$i \<le> (setsum (\<lambda>(x,k). content k *\<^sub>R g x) p)$i"
+ unfolding setsum_component apply(rule setsum_mono)
+ apply(rule mp) defer apply assumption apply(induct_tac x,rule) unfolding split_conv
+proof- fix a b assume ab:"(a,b) \<in> p" note assm = tagged_division_ofD(2-4)[OF assms(1) ab]
+ from this(3) guess u v apply-by(erule exE)+ note b=this
+ show "(content b *\<^sub>R f a) $ i \<le> (content b *\<^sub>R g a) $ i" unfolding b
+ unfolding Cart_nth.scaleR real_scaleR_def apply(rule mult_left_mono)
+ defer apply(rule content_pos_le,rule assms(2)[rule_format]) using assm by auto qed
+
+lemma has_integral_component_le: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "(f has_integral i) s" "(g has_integral j) s" "\<forall>x\<in>s. (f x)$k \<le> (g x)$k"
+ shows "i$k \<le> j$k"
+proof- have lem:"\<And>a b g i j. \<And>f::real^'n \<Rightarrow> real^'m. (f has_integral i) ({a..b}) \<Longrightarrow>
+ (g has_integral j) ({a..b}) \<Longrightarrow> \<forall>x\<in>{a..b}. (f x)$k \<le> (g x)$k \<Longrightarrow> i$k \<le> j$k"
+ proof(rule ccontr) case goal1 hence *:"0 < (i$k - j$k) / 3" by auto
+ guess d1 using goal1(1)[unfolded has_integral,rule_format,OF *] apply-by(erule exE conjE)+ note d1=this[rule_format]
+ guess d2 using goal1(2)[unfolded has_integral,rule_format,OF *] apply-by(erule exE conjE)+ note d2=this[rule_format]
+ guess p using fine_division_exists[OF gauge_inter[OF d1(1) d2(1)], of a b] unfolding fine_inter .
+ note p = this(1) conjunctD2[OF this(2)] note le_less_trans[OF component_le_norm, of _ _ k]
+ note this[OF d1(2)[OF conjI[OF p(1,2)]]] this[OF d2(2)[OF conjI[OF p(1,3)]]]
+ thus False unfolding Cart_nth.diff using rsum_component_le[OF p(1) goal1(3)] by smt
+ qed let ?P = "\<exists>a b. s = {a..b}"
+ { presume "\<not> ?P \<Longrightarrow> ?thesis" thus ?thesis proof(cases ?P)
+ case True then guess a b apply-by(erule exE)+ note s=this
+ show ?thesis apply(rule lem) using assms[unfolded s] by auto
+ qed auto } assume as:"\<not> ?P"
+ { presume "\<not> ?thesis \<Longrightarrow> False" thus ?thesis by auto }
+ assume "\<not> i$k \<le> j$k" hence ij:"(i$k - j$k) / 3 > 0" by auto
+ note has_integral_altD[OF _ as this] from this[OF assms(1)] this[OF assms(2)] guess B1 B2 . note B=this[rule_format]
+ have "bounded (ball 0 B1 \<union> ball (0::real^'n) B2)" unfolding bounded_Un by(rule conjI bounded_ball)+
+ from bounded_subset_closed_interval[OF this] guess a b apply- by(erule exE)+
+ note ab = conjunctD2[OF this[unfolded Un_subset_iff]]
+ guess w1 using B(2)[OF ab(1)] .. note w1=conjunctD2[OF this]
+ guess w2 using B(4)[OF ab(2)] .. note w2=conjunctD2[OF this]
+ have *:"\<And>w1 w2 j i::real .\<bar>w1 - i\<bar> < (i - j) / 3 \<Longrightarrow> \<bar>w2 - j\<bar> < (i - j) / 3 \<Longrightarrow> w1 \<le> w2 \<Longrightarrow> False" by smt(*SMTSMT*)
+ note le_less_trans[OF component_le_norm[of _ k]] note this[OF w1(2)] this[OF w2(2)] moreover
+ have "w1$k \<le> w2$k" apply(rule lem[OF w1(1) w2(1)]) using assms by auto ultimately
+ show False unfolding Cart_nth.diff by(rule *) qed
+
+lemma integral_component_le: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "f integrable_on s" "g integrable_on s" "\<forall>x\<in>s. (f x)$k \<le> (g x)$k"
+ shows "(integral s f)$k \<le> (integral s g)$k"
+ apply(rule has_integral_component_le) using integrable_integral assms by auto
+
+lemma has_integral_dest_vec1_le: fixes f::"real^'n \<Rightarrow> real^1"
+ assumes "(f has_integral i) s" "(g has_integral j) s" "\<forall>x\<in>s. f x \<le> g x"
+ shows "dest_vec1 i \<le> dest_vec1 j" apply(rule has_integral_component_le[OF assms(1-2)])
+ using assms(3) unfolding vector_le_def by auto
+
+lemma integral_dest_vec1_le: fixes f::"real^'n \<Rightarrow> real^1"
+ assumes "f integrable_on s" "g integrable_on s" "\<forall>x\<in>s. f x \<le> g x"
+ shows "dest_vec1(integral s f) \<le> dest_vec1(integral s g)"
+ apply(rule has_integral_dest_vec1_le) apply(rule_tac[1-2] integrable_integral) using assms by auto
+
+lemma has_integral_component_pos: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "(f has_integral i) s" "\<forall>x\<in>s. 0 \<le> (f x)$k" shows "0 \<le> i$k"
+ using has_integral_component_le[OF has_integral_0 assms(1)] using assms(2) by auto
+
+lemma integral_component_pos: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "f integrable_on s" "\<forall>x\<in>s. 0 \<le> (f x)$k" shows "0 \<le> (integral s f)$k"
+ apply(rule has_integral_component_pos) using assms by auto
+
+lemma has_integral_dest_vec1_pos: fixes f::"real^'n \<Rightarrow> real^1"
+ assumes "(f has_integral i) s" "\<forall>x\<in>s. 0 \<le> f x" shows "0 \<le> i"
+ using has_integral_component_pos[OF assms(1), of 1]
+ using assms(2) unfolding vector_le_def by auto
+
+lemma integral_dest_vec1_pos: fixes f::"real^'n \<Rightarrow> real^1"
+ assumes "f integrable_on s" "\<forall>x\<in>s. 0 \<le> f x" shows "0 \<le> integral s f"
+ apply(rule has_integral_dest_vec1_pos) using assms by auto
+
+lemma has_integral_component_neg: fixes f::"real^'n \<Rightarrow> real^'m"
+ assumes "(f has_integral i) s" "\<forall>x\<in>s. (f x)$k \<le> 0" shows "i$k \<le> 0"
+ using has_integral_component_le[OF assms(1) has_integral_0] assms(2) by auto
+
+lemma has_integral_dest_vec1_neg: fixes f::"real^'n \<Rightarrow> real^1"
+ assumes "(f has_integral i) s" "\<forall>x\<in>s. f x \<le> 0" shows "i \<le> 0"
+ using has_integral_component_neg[OF assms(1),of 1] using assms(2) by auto
+
+lemma has_integral_component_lbound:
+ assumes "(f has_integral i) {a..b}" "\<forall>x\<in>{a..b}. B \<le> f(x)$k" shows "B * content {a..b} \<le> i$k"
+ using has_integral_component_le[OF has_integral_const assms(1),of "(\<chi> i. B)" k] assms(2)
+ unfolding Cart_lambda_beta vector_scaleR_component by(auto simp add:field_simps)
+
+lemma has_integral_component_ubound:
+ assumes "(f has_integral i) {a..b}" "\<forall>x\<in>{a..b}. f x$k \<le> B"
+ shows "i$k \<le> B * content({a..b})"
+ using has_integral_component_le[OF assms(1) has_integral_const, of k "vec B"]
+ unfolding vec_component Cart_nth.scaleR using assms(2) by(auto simp add:field_simps)
+
+lemma integral_component_lbound:
+ assumes "f integrable_on {a..b}" "\<forall>x\<in>{a..b}. B \<le> f(x)$k"
+ shows "B * content({a..b}) \<le> (integral({a..b}) f)$k"
+ apply(rule has_integral_component_lbound) using assms unfolding has_integral_integral by auto
+
+lemma integral_component_ubound:
+ assumes "f integrable_on {a..b}" "\<forall>x\<in>{a..b}. f(x)$k \<le> B"
+ shows "(integral({a..b}) f)$k \<le> B * content({a..b})"
+ apply(rule has_integral_component_ubound) using assms unfolding has_integral_integral by auto
+
+subsection {* Uniform limit of integrable functions is integrable. *}
+
+lemma real_arch_invD:
+ "0 < (e::real) \<Longrightarrow> (\<exists>n::nat. n \<noteq> 0 \<and> 0 < inverse (real n) \<and> inverse (real n) < e)"
+ by(subst(asm) real_arch_inv)
+
+lemma integrable_uniform_limit: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ assumes "\<forall>e>0. \<exists>g. (\<forall>x\<in>{a..b}. norm(f x - g x) \<le> e) \<and> g integrable_on {a..b}"
+ shows "f integrable_on {a..b}"
+proof- { presume *:"content {a..b} > 0 \<Longrightarrow> ?thesis"
+ show ?thesis apply cases apply(rule *,assumption)
+ unfolding content_lt_nz integrable_on_def using has_integral_null by auto }
+ assume as:"content {a..b} > 0"
+ have *:"\<And>P. \<forall>e>(0::real). P e \<Longrightarrow> \<forall>n::nat. P (inverse (real n+1))" by auto
+ from choice[OF *[OF assms]] guess g .. note g=conjunctD2[OF this[rule_format],rule_format]
+ from choice[OF allI[OF g(2)[unfolded integrable_on_def], of "\<lambda>x. x"]] guess i .. note i=this[rule_format]
+
+ have "Cauchy i" unfolding Cauchy_def
+ proof(rule,rule) fix e::real assume "e>0"
+ hence "e / 4 / content {a..b} > 0" using as by(auto simp add:field_simps)
+ then guess M apply-apply(subst(asm) real_arch_inv) by(erule exE conjE)+ note M=this
+ show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (i m) (i n) < e" apply(rule_tac x=M in exI,rule,rule,rule,rule)
+ proof- case goal1 have "e/4>0" using `e>0` by auto note * = i[unfolded has_integral,rule_format,OF this]
+ from *[of m] guess gm apply-by(erule conjE exE)+ note gm=this[rule_format]
+ from *[of n] guess gn apply-by(erule conjE exE)+ note gn=this[rule_format]
+ from fine_division_exists[OF gauge_inter[OF gm(1) gn(1)], of a b] guess p . note p=this
+ have lem2:"\<And>s1 s2 i1 i2. norm(s2 - s1) \<le> e/2 \<Longrightarrow> norm(s1 - i1) < e / 4 \<Longrightarrow> norm(s2 - i2) < e / 4 \<Longrightarrow>norm(i1 - i2) < e"
+ proof- case goal1 have "norm (i1 - i2) \<le> norm (i1 - s1) + norm (s1 - s2) + norm (s2 - i2)"
+ using norm_triangle_ineq[of "i1 - s1" "s1 - i2"]
+ using norm_triangle_ineq[of "s1 - s2" "s2 - i2"] by(auto simp add:group_simps)
+ also have "\<dots> < e" using goal1 unfolding norm_minus_commute by(auto simp add:group_simps)
+ finally show ?case .
+ qed
+ show ?case unfolding vector_dist_norm apply(rule lem2) defer
+ apply(rule gm(2)[OF conjI[OF p(1)]],rule_tac[2] gn(2)[OF conjI[OF p(1)]])
+ using conjunctD2[OF p(2)[unfolded fine_inter]] apply- apply assumption+ apply(rule order_trans)
+ apply(rule rsum_diff_bound[OF p(1), where e="2 / real M"])
+ proof show "2 / real M * content {a..b} \<le> e / 2" unfolding divide_inverse
+ using M as by(auto simp add:field_simps)
+ fix x assume x:"x \<in> {a..b}"
+ have "norm (f x - g n x) + norm (f x - g m x) \<le> inverse (real n + 1) + inverse (real m + 1)"
+ using g(1)[OF x, of n] g(1)[OF x, of m] by auto
+ also have "\<dots> \<le> inverse (real M) + inverse (real M)" apply(rule add_mono)
+ apply(rule_tac[!] le_imp_inverse_le) using goal1 M by auto
+ also have "\<dots> = 2 / real M" unfolding real_divide_def by auto
+ finally show "norm (g n x - g m x) \<le> 2 / real M"
+ using norm_triangle_le[of "g n x - f x" "f x - g m x" "2 / real M"]
+ by(auto simp add:group_simps simp add:norm_minus_commute)
+ qed qed qed
+ from this[unfolded convergent_eq_cauchy[THEN sym]] guess s .. note s=this
+
+ show ?thesis unfolding integrable_on_def apply(rule_tac x=s in exI) unfolding has_integral
+ proof(rule,rule)
+ case goal1 hence *:"e/3 > 0" by auto
+ from s[unfolded Lim_sequentially,rule_format,OF this] guess N1 .. note N1=this
+ from goal1 as have "e / 3 / content {a..b} > 0" by(auto simp add:field_simps)
+ from real_arch_invD[OF this] guess N2 apply-by(erule exE conjE)+ note N2=this
+ from i[of "N1 + N2",unfolded has_integral,rule_format,OF *] guess g' .. note g'=conjunctD2[OF this,rule_format]
+ have lem:"\<And>sf sg i. norm(sf - sg) \<le> e / 3 \<Longrightarrow> norm(i - s) < e / 3 \<Longrightarrow> norm(sg - i) < e / 3 \<Longrightarrow> norm(sf - s) < e"
+ proof- case goal1 have "norm (sf - s) \<le> norm (sf - sg) + norm (sg - i) + norm (i - s)"
+ using norm_triangle_ineq[of "sf - sg" "sg - s"]
+ using norm_triangle_ineq[of "sg - i" " i - s"] by(auto simp add:group_simps)
+ also have "\<dots> < e" using goal1 unfolding norm_minus_commute by(auto simp add:group_simps)
+ finally show ?case .
+ qed
+ show ?case apply(rule_tac x=g' in exI) apply(rule,rule g')
+ proof(rule,rule) fix p assume p:"p tagged_division_of {a..b} \<and> g' fine p" note * = g'(2)[OF this]
+ show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - s) < e" apply-apply(rule lem[OF _ _ *])
+ apply(rule order_trans,rule rsum_diff_bound[OF p[THEN conjunct1]]) apply(rule,rule g,assumption)
+ proof- have "content {a..b} < e / 3 * (real N2)"
+ using N2 unfolding inverse_eq_divide using as by(auto simp add:field_simps)
+ hence "content {a..b} < e / 3 * (real (N1 + N2) + 1)"
+ apply-apply(rule less_le_trans,assumption) using `e>0` by auto
+ thus "inverse (real (N1 + N2) + 1) * content {a..b} \<le> e / 3"
+ unfolding inverse_eq_divide by(auto simp add:field_simps)
+ show "norm (i (N1 + N2) - s) < e / 3" by(rule N1[rule_format,unfolded vector_dist_norm],auto)
+ qed qed qed qed
+
+subsection {* Negligible sets. *}
+
+definition "indicator s \<equiv> (\<lambda>x. if x \<in> s then 1 else (0::real))"
+
+lemma dest_vec1_indicator:
+ "indicator s x = (if x \<in> s then 1 else 0)" unfolding indicator_def by auto
+
+lemma indicator_pos_le[intro]: "0 \<le> (indicator s x)" unfolding indicator_def by auto
+
+lemma indicator_le_1[intro]: "(indicator s x) \<le> 1" unfolding indicator_def by auto
+
+lemma dest_vec1_indicator_abs_le_1: "abs(indicator s x) \<le> 1"
+ unfolding indicator_def by auto
+
+definition "negligible (s::(real^'n) set) \<equiv> (\<forall>a b. ((indicator s) has_integral 0) {a..b})"
+
+lemma indicator_simps[simp]:"x\<in>s \<Longrightarrow> indicator s x = 1" "x\<notin>s \<Longrightarrow> indicator s x = 0"
+ unfolding indicator_def by auto
+
+subsection {* Negligibility of hyperplane. *}
+
+lemma vsum_nonzero_image_lemma:
+ assumes "finite s" "g(a) = 0"
+ "\<forall>x\<in>s. \<forall>y\<in>s. f x = f y \<and> x \<noteq> y \<longrightarrow> g(f x) = 0"
+ shows "setsum g {f x |x. x \<in> s \<and> f x \<noteq> a} = setsum (g o f) s"
+ unfolding setsum_iterate[OF assms(1)] apply(subst setsum_iterate) defer
+ apply(rule iterate_nonzero_image_lemma) apply(rule assms monoidal_monoid)+
+ unfolding assms using neutral_add unfolding neutral_add using assms by auto
+
+lemma interval_doublesplit: shows "{a..b} \<inter> {x . abs(x$k - c) \<le> (e::real)} =
+ {(\<chi> i. if i = k then max (a$k) (c - e) else a$i) .. (\<chi> i. if i = k then min (b$k) (c + e) else b$i)}"
+proof- have *:"\<And>x c e::real. abs(x - c) \<le> e \<longleftrightarrow> x \<ge> c - e \<and> x \<le> c + e" by auto
+ have **:"\<And>s P Q. s \<inter> {x. P x \<and> Q x} = (s \<inter> {x. Q x}) \<inter> {x. P x}" by blast
+ show ?thesis unfolding * ** interval_split by(rule refl) qed
+
+lemma division_doublesplit: assumes "p division_of {a..b::real^'n}"
+ shows "{l \<inter> {x. abs(x$k - c) \<le> e} |l. l \<in> p \<and> l \<inter> {x. abs(x$k - c) \<le> e} \<noteq> {}} division_of ({a..b} \<inter> {x. abs(x$k - c) \<le> e})"
+proof- have *:"\<And>x c. abs(x - c) \<le> e \<longleftrightarrow> x \<ge> c - e \<and> x \<le> c + e" by auto
+ have **:"\<And>p q p' q'. p division_of q \<Longrightarrow> p = p' \<Longrightarrow> q = q' \<Longrightarrow> p' division_of q'" by auto
+ note division_split(1)[OF assms, where c="c+e" and k=k,unfolded interval_split]
+ note division_split(2)[OF this, where c="c-e" and k=k]
+ thus ?thesis apply(rule **) unfolding interval_doublesplit unfolding * unfolding interval_split interval_doublesplit
+ apply(rule set_ext) unfolding mem_Collect_eq apply rule apply(erule conjE exE)+ apply(rule_tac x=la in exI) defer
+ apply(erule conjE exE)+ apply(rule_tac x="l \<inter> {x. c + e \<ge> x $ k}" in exI) apply rule defer apply rule
+ apply(rule_tac x=l in exI) by blast+ qed
+
+lemma content_doublesplit: assumes "0 < e"
+ obtains d where "0 < d" "content({a..b} \<inter> {x. abs(x$k - c) \<le> d}) < e"
+proof(cases "content {a..b} = 0")
+ case True show ?thesis apply(rule that[of 1]) defer unfolding interval_doublesplit
+ apply(rule le_less_trans[OF content_subset]) defer apply(subst True)
+ unfolding interval_doublesplit[THEN sym] using assms by auto
+next case False def d \<equiv> "e / 3 / setprod (\<lambda>i. b$i - a$i) (UNIV - {k})"
+ note False[unfolded content_eq_0 not_ex not_le, rule_format]
+ hence prod0:"0 < setprod (\<lambda>i. b$i - a$i) (UNIV - {k})" apply-apply(rule setprod_pos) by smt
+ hence "d > 0" unfolding d_def using assms by(auto simp add:field_simps) thus ?thesis
+ proof(rule that[of d]) have *:"UNIV = insert k (UNIV - {k})" by auto
+ have **:"{a..b} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d} \<noteq> {} \<Longrightarrow>
+ (\<Prod>i\<in>UNIV - {k}. interval_upperbound ({a..b} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) $ i - interval_lowerbound ({a..b} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) $ i)
+ = (\<Prod>i\<in>UNIV - {k}. b$i - a$i)" apply(rule setprod_cong,rule refl)
+ unfolding interval_doublesplit interval_eq_empty not_ex not_less unfolding interval_bounds by auto
+ show "content ({a..b} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) < e" apply(cases) unfolding content_def apply(subst if_P,assumption,rule assms)
+ unfolding if_not_P apply(subst *) apply(subst setprod_insert) unfolding **
+ unfolding interval_doublesplit interval_eq_empty not_ex not_less unfolding interval_bounds unfolding Cart_lambda_beta if_P[OF refl]
+ proof- have "(min (b $ k) (c + d) - max (a $ k) (c - d)) \<le> 2 * d" by auto
+ also have "... < e / (\<Prod>i\<in>UNIV - {k}. b $ i - a $ i)" unfolding d_def using assms prod0 by(auto simp add:field_simps)
+ finally show "(min (b $ k) (c + d) - max (a $ k) (c - d)) * (\<Prod>i\<in>UNIV - {k}. b $ i - a $ i) < e"
+ unfolding pos_less_divide_eq[OF prod0] . qed auto qed qed
+
+lemma negligible_standard_hyperplane[intro]: "negligible {x. x$k = (c::real)}"
+ unfolding negligible_def has_integral apply(rule,rule,rule,rule)
+proof- case goal1 from content_doublesplit[OF this,of a b k c] guess d . note d=this let ?i = "indicator {x. x$k = c}"
+ show ?case apply(rule_tac x="\<lambda>x. ball x d" in exI) apply(rule,rule gauge_ball,rule d)
+ proof(rule,rule) fix p assume p:"p tagged_division_of {a..b} \<and> (\<lambda>x. ball x d) fine p"
+ have *:"(\<Sum>(x, ka)\<in>p. content ka *\<^sub>R ?i x) = (\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. abs(x$k - c) \<le> d}) *\<^sub>R ?i x)"
+ apply(rule setsum_cong2) unfolding split_paired_all real_scaleR_def mult_cancel_right split_conv
+ apply(cases,rule disjI1,assumption,rule disjI2)
+ proof- fix x l assume as:"(x,l)\<in>p" "?i x \<noteq> 0" hence xk:"x$k = c" unfolding indicator_def apply-by(rule ccontr,auto)
+ show "content l = content (l \<inter> {x. \<bar>x $ k - c\<bar> \<le> d})" apply(rule arg_cong[where f=content])
+ apply(rule set_ext,rule,rule) unfolding mem_Collect_eq
+ proof- fix y assume y:"y\<in>l" note p[THEN conjunct2,unfolded fine_def,rule_format,OF as(1),unfolded split_conv]
+ note this[unfolded subset_eq mem_ball vector_dist_norm,rule_format,OF y] note le_less_trans[OF component_le_norm[of _ k] this]
+ thus "\<bar>y $ k - c\<bar> \<le> d" unfolding Cart_nth.diff xk by auto
+ qed auto qed
+ note p'= tagged_division_ofD[OF p[THEN conjunct1]] and p''=division_of_tagged_division[OF p[THEN conjunct1]]
+ show "norm ((\<Sum>(x, ka)\<in>p. content ka *\<^sub>R ?i x) - 0) < e" unfolding diff_0_right * unfolding real_scaleR_def real_norm_def
+ apply(subst abs_of_nonneg) apply(rule setsum_nonneg,rule) unfolding split_paired_all split_conv
+ apply(rule mult_nonneg_nonneg) apply(drule p'(4)) apply(erule exE)+ apply(rule_tac b=b in back_subst)
+ prefer 2 apply(subst(asm) eq_commute) apply assumption
+ apply(subst interval_doublesplit) apply(rule content_pos_le) apply(rule indicator_pos_le)
+ proof- have "(\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) * ?i x) \<le> (\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}))"
+ apply(rule setsum_mono) unfolding split_paired_all split_conv
+ apply(rule mult_right_le_one_le) apply(drule p'(4)) by(auto simp add:interval_doublesplit intro!:content_pos_le)
+ also have "... < e" apply(subst setsum_over_tagged_division_lemma[OF p[THEN conjunct1]])
+ proof- case goal1 have "content ({u..v} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) \<le> content {u..v}"
+ unfolding interval_doublesplit apply(rule content_subset) unfolding interval_doublesplit[THEN sym] by auto
+ thus ?case unfolding goal1 unfolding interval_doublesplit using content_pos_le by smt
+ next have *:"setsum content {l \<inter> {x. \<bar>x $ k - c\<bar> \<le> d} |l. l \<in> snd ` p \<and> l \<inter> {x. \<bar>x $ k - c\<bar> \<le> d} \<noteq> {}} \<ge> 0"
+ apply(rule setsum_nonneg,rule) unfolding mem_Collect_eq image_iff apply(erule exE bexE conjE)+ unfolding split_paired_all
+ proof- fix x l a b assume as:"x = l \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}" "(a, b) \<in> p" "l = snd (a, b)"
+ guess u v using p'(4)[OF as(2)] apply-by(erule exE)+ note * = this
+ show "content x \<ge> 0" unfolding as snd_conv * interval_doublesplit by(rule content_pos_le)
+ qed have **:"norm (1::real) \<le> 1" by auto note division_doublesplit[OF p'',unfolded interval_doublesplit]
+ note dsum_bound[OF this **,unfolded interval_doublesplit[THEN sym]]
+ note this[unfolded real_scaleR_def real_norm_def class_semiring.semiring_rules, of k c d] note le_less_trans[OF this d(2)]
+ from this[unfolded abs_of_nonneg[OF *]] show "(\<Sum>ka\<in>snd ` p. content (ka \<inter> {x. \<bar>x $ k - c\<bar> \<le> d})) < e"
+ apply(subst vsum_nonzero_image_lemma[of "snd ` p" content "{}", unfolded o_def,THEN sym])
+ apply(rule finite_imageI p' content_empty)+ unfolding forall_in_division[OF p'']
+ proof(rule,rule,rule,rule,rule,rule,rule,erule conjE) fix m n u v
+ assume as:"{m..n} \<in> snd ` p" "{u..v} \<in> snd ` p" "{m..n} \<noteq> {u..v}" "{m..n} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d} = {u..v} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}"
+ have "({m..n} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) \<inter> ({u..v} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) \<subseteq> {m..n} \<inter> {u..v}" by blast
+ note subset_interior[OF this, unfolded division_ofD(5)[OF p'' as(1-3)] interior_inter[of "{m..n}"]]
+ hence "interior ({m..n} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) = {}" unfolding as Int_absorb by auto
+ thus "content ({m..n} \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) = 0" unfolding interval_doublesplit content_eq_0_interior[THEN sym] .
+ qed qed
+ finally show "(\<Sum>(x, ka)\<in>p. content (ka \<inter> {x. \<bar>x $ k - c\<bar> \<le> d}) * ?i x) < e" .
+ qed qed qed
+
+subsection {* A technical lemma about "refinement" of division. *}
+
+lemma tagged_division_finer: fixes p::"((real^'n) \<times> ((real^'n) set)) set"
+ assumes "p tagged_division_of {a..b}" "gauge d"
+ obtains q where "q tagged_division_of {a..b}" "d fine q" "\<forall>(x,k) \<in> p. k \<subseteq> d(x) \<longrightarrow> (x,k) \<in> q"
+proof-
+ let ?P = "\<lambda>p. p tagged_partial_division_of {a..b} \<longrightarrow> gauge d \<longrightarrow>
+ (\<exists>q. q tagged_division_of (\<Union>{k. \<exists>x. (x,k) \<in> p}) \<and> d fine q \<and>
+ (\<forall>(x,k) \<in> p. k \<subseteq> d(x) \<longrightarrow> (x,k) \<in> q))"
+ { have *:"finite p" "p tagged_partial_division_of {a..b}" using assms(1) unfolding tagged_division_of_def by auto
+ presume "\<And>p. finite p \<Longrightarrow> ?P p" from this[rule_format,OF * assms(2)] guess q .. note q=this
+ thus ?thesis apply-apply(rule that[of q]) unfolding tagged_division_ofD[OF assms(1)] by auto
+ } fix p::"((real^'n) \<times> ((real^'n) set)) set" assume as:"finite p"
+ show "?P p" apply(rule,rule) using as proof(induct p)
+ case empty show ?case apply(rule_tac x="{}" in exI) unfolding fine_def by auto
+ next case (insert xk p) guess x k using surj_pair[of xk] apply- by(erule exE)+ note xk=this
+ note tagged_partial_division_subset[OF insert(4) subset_insertI]
+ from insert(3)[OF this insert(5)] guess q1 .. note q1 = conjunctD3[OF this]
+ have *:"\<Union>{l. \<exists>y. (y,l) \<in> insert xk p} = k \<union> \<Union>{l. \<exists>y. (y,l) \<in> p}" unfolding xk by auto
+ note p = tagged_partial_division_ofD[OF insert(4)]
+ from p(4)[unfolded xk, OF insertI1] guess u v apply-by(erule exE)+ note uv=this
+
+ have "finite {k. \<exists>x. (x, k) \<in> p}"
+ apply(rule finite_subset[of _ "snd ` p"],rule) unfolding subset_eq image_iff mem_Collect_eq
+ apply(erule exE,rule_tac x="(xa,x)" in bexI) using p by auto
+ hence int:"interior {u..v} \<inter> interior (\<Union>{k. \<exists>x. (x, k) \<in> p}) = {}"
+ apply(rule inter_interior_unions_intervals) apply(rule open_interior) apply(rule_tac[!] ballI)
+ unfolding mem_Collect_eq apply(erule_tac[!] exE) apply(drule p(4)[OF insertI2],assumption)
+ apply(rule p(5)) unfolding uv xk apply(rule insertI1,rule insertI2) apply assumption
+ using insert(2) unfolding uv xk by auto
+
+ show ?case proof(cases "{u..v} \<subseteq> d x")
+ case True thus ?thesis apply(rule_tac x="{(x,{u..v})} \<union> q1" in exI) apply rule
+ unfolding * uv apply(rule tagged_division_union,rule tagged_division_of_self)
+ apply(rule p[unfolded xk uv] insertI1)+ apply(rule q1,rule int)
+ apply(rule,rule fine_union,subst fine_def) defer apply(rule q1)
+ unfolding Ball_def split_paired_All split_conv apply(rule,rule,rule,rule)
+ apply(erule insertE) defer apply(rule UnI2) apply(drule q1(3)[rule_format]) unfolding xk uv by auto
+ next case False from fine_division_exists[OF assms(2), of u v] guess q2 . note q2=this
+ show ?thesis apply(rule_tac x="q2 \<union> q1" in exI)
+ apply rule unfolding * uv apply(rule tagged_division_union q2 q1 int fine_union)+
+ unfolding Ball_def split_paired_All split_conv apply rule apply(rule fine_union)
+ apply(rule q1 q2)+ apply(rule,rule,rule,rule) apply(erule insertE)
+ apply(rule UnI2) defer apply(drule q1(3)[rule_format])using False unfolding xk uv by auto
+ qed qed qed
+
+subsection {* Hence the main theorem about negligible sets. *}
+
+lemma finite_product_dependent: assumes "finite s" "\<And>x. x\<in>s\<Longrightarrow> finite (t x)"
+ shows "finite {(i, j) |i j. i \<in> s \<and> j \<in> t i}" using assms
+proof(induct) case (insert x s)
+ have *:"{(i, j) |i j. i \<in> insert x s \<and> j \<in> t i} = (\<lambda>y. (x,y)) ` (t x) \<union> {(i, j) |i j. i \<in> s \<and> j \<in> t i}" by auto
+ show ?case unfolding * apply(rule finite_UnI) using insert by auto qed auto
+
+lemma sum_sum_product: assumes "finite s" "\<forall>i\<in>s. finite (t i)"
+ shows "setsum (\<lambda>i. setsum (x i) (t i)::real) s = setsum (\<lambda>(i,j). x i j) {(i,j) | i j. i \<in> s \<and> j \<in> t i}" using assms
+proof(induct) case (insert a s)
+ have *:"{(i, j) |i j. i \<in> insert a s \<and> j \<in> t i} = (\<lambda>y. (a,y)) ` (t a) \<union> {(i, j) |i j. i \<in> s \<and> j \<in> t i}" by auto
+ show ?case unfolding * apply(subst setsum_Un_disjoint) unfolding setsum_insert[OF insert(1-2)]
+ prefer 4 apply(subst insert(3)) unfolding add_right_cancel
+ proof- show "setsum (x a) (t a) = (\<Sum>(xa, y)\<in>Pair a ` t a. x xa y)" apply(subst setsum_reindex) unfolding inj_on_def by auto
+ show "finite {(i, j) |i j. i \<in> s \<and> j \<in> t i}" apply(rule finite_product_dependent) using insert by auto
+ qed(insert insert, auto) qed auto
+
+lemma has_integral_negligible: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "negligible s" "\<forall>x\<in>(t - s). f x = 0"
+ shows "(f has_integral 0) t"
+proof- presume P:"\<And>f::real^'n \<Rightarrow> 'a. \<And>a b. (\<forall>x. ~(x \<in> s) \<longrightarrow> f x = 0) \<Longrightarrow> (f has_integral 0) ({a..b})"
+ let ?f = "(\<lambda>x. if x \<in> t then f x else 0)"
+ show ?thesis apply(rule_tac f="?f" in has_integral_eq) apply(rule) unfolding if_P apply(rule refl)
+ apply(subst has_integral_alt) apply(cases,subst if_P,assumption) unfolding if_not_P
+ proof- assume "\<exists>a b. t = {a..b}" then guess a b apply-by(erule exE)+ note t = this
+ show "(?f has_integral 0) t" unfolding t apply(rule P) using assms(2) unfolding t by auto
+ next show "\<forall>e>0. \<exists>B>0. \<forall>a b. ball 0 B \<subseteq> {a..b} \<longrightarrow> (\<exists>z. ((\<lambda>x. if x \<in> t then ?f x else 0) has_integral z) {a..b} \<and> norm (z - 0) < e)"
+ apply(safe,rule_tac x=1 in exI,rule) apply(rule zero_less_one,safe) apply(rule_tac x=0 in exI)
+ apply(rule,rule P) using assms(2) by auto
+ qed
+next fix f::"real^'n \<Rightarrow> 'a" and a b::"real^'n" assume assm:"\<forall>x. x \<notin> s \<longrightarrow> f x = 0"
+ show "(f has_integral 0) {a..b}" unfolding has_integral
+ proof(safe) case goal1
+ hence "\<And>n. e / 2 / ((real n+1) * (2 ^ n)) > 0"
+ apply-apply(rule divide_pos_pos) defer apply(rule mult_pos_pos) by(auto simp add:field_simps)
+ note assms(1)[unfolded negligible_def has_integral,rule_format,OF this,of a b] note allI[OF this,of "\<lambda>x. x"]
+ from choice[OF this] guess d .. note d=conjunctD2[OF this[rule_format]]
+ show ?case apply(rule_tac x="\<lambda>x. d (nat \<lfloor>norm (f x)\<rfloor>) x" in exI)
+ proof safe show "gauge (\<lambda>x. d (nat \<lfloor>norm (f x)\<rfloor>) x)" using d(1) unfolding gauge_def by auto
+ fix p assume as:"p tagged_division_of {a..b}" "(\<lambda>x. d (nat \<lfloor>norm (f x)\<rfloor>) x) fine p"
+ let ?goal = "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - 0) < e"
+ { presume "p\<noteq>{} \<Longrightarrow> ?goal" thus ?goal apply(cases "p={}") using goal1 by auto }
+ assume as':"p \<noteq> {}" from real_arch_simple[of "Sup((\<lambda>(x,k). norm(f x)) ` p)"] guess N ..
+ hence N:"\<forall>x\<in>(\<lambda>(x, k). norm (f x)) ` p. x \<le> real N" apply(subst(asm) Sup_finite_le_iff) using as as' by auto
+ have "\<forall>i. \<exists>q. q tagged_division_of {a..b} \<and> (d i) fine q \<and> (\<forall>(x, k)\<in>p. k \<subseteq> (d i) x \<longrightarrow> (x, k) \<in> q)"
+ apply(rule,rule tagged_division_finer[OF as(1) d(1)]) by auto
+ from choice[OF this] guess q .. note q=conjunctD3[OF this[rule_format]]
+ have *:"\<And>i. (\<Sum>(x, k)\<in>q i. content k *\<^sub>R indicator s x) \<ge> 0" apply(rule setsum_nonneg,safe)
+ unfolding real_scaleR_def apply(rule mult_nonneg_nonneg) apply(drule tagged_division_ofD(4)[OF q(1)]) by auto
+ have **:"\<And>f g s t. finite s \<Longrightarrow> finite t \<Longrightarrow> (\<forall>(x,y) \<in> t. (0::real) \<le> g(x,y)) \<Longrightarrow> (\<forall>y\<in>s. \<exists>x. (x,y) \<in> t \<and> f(y) \<le> g(x,y)) \<Longrightarrow> setsum f s \<le> setsum g t"
+ proof- case goal1 thus ?case apply-apply(rule setsum_le_included[of s t g snd f]) prefer 4
+ apply safe apply(erule_tac x=x in ballE) apply(erule exE) apply(rule_tac x="(xa,x)" in bexI) by auto qed
+ have "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - 0) \<le> setsum (\<lambda>i. (real i + 1) *
+ norm(setsum (\<lambda>(x,k). content k *\<^sub>R indicator s x) (q i))) {0..N+1}"
+ unfolding real_norm_def setsum_right_distrib abs_of_nonneg[OF *] diff_0_right
+ apply(rule order_trans,rule setsum_norm) defer apply(subst sum_sum_product) prefer 3
+ proof(rule **,safe) show "finite {(i, j) |i j. i \<in> {0..N + 1} \<and> j \<in> q i}" apply(rule finite_product_dependent) using q by auto
+ fix i a b assume as'':"(a,b) \<in> q i" show "0 \<le> (real i + 1) * (content b *\<^sub>R indicator s a)"
+ unfolding real_scaleR_def apply(rule mult_nonneg_nonneg) defer apply(rule mult_nonneg_nonneg)
+ using tagged_division_ofD(4)[OF q(1) as''] by auto
+ next fix i::nat show "finite (q i)" using q by auto
+ next fix x k assume xk:"(x,k) \<in> p" def n \<equiv> "nat \<lfloor>norm (f x)\<rfloor>"
+ have *:"norm (f x) \<in> (\<lambda>(x, k). norm (f x)) ` p" using xk by auto
+ have nfx:"real n \<le> norm(f x)" "norm(f x) \<le> real n + 1" unfolding n_def by auto
+ hence "n \<in> {0..N + 1}" using N[rule_format,OF *] by auto
+ moreover note as(2)[unfolded fine_def,rule_format,OF xk,unfolded split_conv]
+ note q(3)[rule_format,OF xk,unfolded split_conv,rule_format,OF this] note this[unfolded n_def[symmetric]]
+ moreover have "norm (content k *\<^sub>R f x) \<le> (real n + 1) * (content k * indicator s x)"
+ proof(cases "x\<in>s") case False thus ?thesis using assm by auto
+ next case True have *:"content k \<ge> 0" using tagged_division_ofD(4)[OF as(1) xk] by auto
+ moreover have "content k * norm (f x) \<le> content k * (real n + 1)" apply(rule mult_mono) using nfx * by auto
+ ultimately show ?thesis unfolding abs_mult using nfx True by(auto simp add:field_simps)
+ qed ultimately show "\<exists>y. (y, x, k) \<in> {(i, j) |i j. i \<in> {0..N + 1} \<and> j \<in> q i} \<and> norm (content k *\<^sub>R f x) \<le> (real y + 1) * (content k *\<^sub>R indicator s x)"
+ apply(rule_tac x=n in exI,safe) apply(rule_tac x=n in exI,rule_tac x="(x,k)" in exI,safe) by auto
+ qed(insert as, auto)
+ also have "... \<le> setsum (\<lambda>i. e / 2 / 2 ^ i) {0..N+1}" apply(rule setsum_mono)
+ proof- case goal1 thus ?case apply(subst mult_commute, subst pos_le_divide_eq[THEN sym])
+ using d(2)[rule_format,of "q i" i] using q[rule_format] by(auto simp add:field_simps)
+ qed also have "... < e * inverse 2 * 2" unfolding real_divide_def setsum_right_distrib[THEN sym]
+ apply(rule mult_strict_left_mono) unfolding power_inverse atLeastLessThanSuc_atLeastAtMost[THEN sym]
+ apply(subst sumr_geometric) using goal1 by auto
+ finally show "?goal" by auto qed qed qed
+
+lemma has_integral_spike: fixes f::"real^'n \<Rightarrow> 'a::real_normed_vector"
+ assumes "negligible s" "(\<forall>x\<in>(t - s). g x = f x)" "(f has_integral y) t"
+ shows "(g has_integral y) t"
+proof- { fix a b::"real^'n" and f g ::"real^'n \<Rightarrow> 'a" and y::'a
+ assume as:"\<forall>x \<in> {a..b} - s. g x = f x" "(f has_integral y) {a..b}"
+ have "((\<lambda>x. f x + (g x - f x)) has_integral (y + 0)) {a..b}" apply(rule has_integral_add[OF as(2)])
+ apply(rule has_integral_negligible[OF assms(1)]) using as by auto
+ hence "(g has_integral y) {a..b}" by auto } note * = this
+ show ?thesis apply(subst has_integral_alt) using assms(2-) apply-apply(rule cond_cases,safe)
+ apply(rule *, assumption+) apply(subst(asm) has_integral_alt) unfolding if_not_P
+ apply(erule_tac x=e in allE,safe,rule_tac x=B in exI,safe) apply(erule_tac x=a in allE,erule_tac x=b in allE,safe)
+ apply(rule_tac x=z in exI,safe) apply(rule *[where fa2="\<lambda>x. if x\<in>t then f x else 0"]) by auto qed
+
+lemma has_integral_spike_eq:
+ assumes "negligible s" "\<forall>x\<in>(t - s). g x = f x"
+ shows "((f has_integral y) t \<longleftrightarrow> (g has_integral y) t)"
+ apply rule apply(rule_tac[!] has_integral_spike[OF assms(1)]) using assms(2) by auto
+
+lemma integrable_spike: assumes "negligible s" "\<forall>x\<in>(t - s). g x = f x" "f integrable_on t"
+ shows "g integrable_on t"
+ using assms unfolding integrable_on_def apply-apply(erule exE)
+ apply(rule,rule has_integral_spike) by fastsimp+
+
+lemma integral_spike: assumes "negligible s" "\<forall>x\<in>(t - s). g x = f x"
+ shows "integral t f = integral t g"
+ unfolding integral_def using has_integral_spike_eq[OF assms] by auto
+
+subsection {* Some other trivialities about negligible sets. *}
+
+lemma negligible_subset[intro]: assumes "negligible s" "t \<subseteq> s" shows "negligible t" unfolding negligible_def
+proof(safe) case goal1 show ?case using assms(1)[unfolded negligible_def,rule_format,of a b]
+ apply-apply(rule has_integral_spike[OF assms(1)]) defer apply assumption
+ using assms(2) unfolding indicator_def by auto qed
+
+lemma negligible_diff[intro?]: assumes "negligible s" shows "negligible(s - t)" using assms by auto
+
+lemma negligible_inter: assumes "negligible s \<or> negligible t" shows "negligible(s \<inter> t)" using assms by auto
+
+lemma negligible_union: assumes "negligible s" "negligible t" shows "negligible (s \<union> t)" unfolding negligible_def
+proof safe case goal1 note assm = assms[unfolded negligible_def,rule_format,of a b]
+ thus ?case apply(subst has_integral_spike_eq[OF assms(2)])
+ defer apply assumption unfolding indicator_def by auto qed
+
+lemma negligible_union_eq[simp]: "negligible (s \<union> t) \<longleftrightarrow> (negligible s \<and> negligible t)"
+ using negligible_union by auto
+
+lemma negligible_sing[intro]: "negligible {a::real^'n}"
+proof- guess x using UNIV_witness[where 'a='n] ..
+ show ?thesis using negligible_standard_hyperplane[of x "a$x"] by auto qed
+
+lemma negligible_insert[simp]: "negligible(insert a s) \<longleftrightarrow> negligible s"
+ apply(subst insert_is_Un) unfolding negligible_union_eq by auto
+
+lemma negligible_empty[intro]: "negligible {}" by auto
+
+lemma negligible_finite[intro]: assumes "finite s" shows "negligible s"
+ using assms apply(induct s) by auto
+
+lemma negligible_unions[intro]: assumes "finite s" "\<forall>t\<in>s. negligible t" shows "negligible(\<Union>s)"
+ using assms by(induct,auto)
+
+lemma negligible: "negligible s \<longleftrightarrow> (\<forall>t::(real^'n) set. (indicator s has_integral 0) t)"
+ apply safe defer apply(subst negligible_def)
+proof- fix t::"(real^'n) set" assume as:"negligible s"
+ have *:"(\<lambda>x. if x \<in> s \<inter> t then 1 else 0) = (\<lambda>x. if x\<in>t then if x\<in>s then 1 else 0 else 0)" by(rule ext,auto)
+ show "(indicator s has_integral 0) t" apply(subst has_integral_alt)
+ apply(cases,subst if_P,assumption) unfolding if_not_P apply(safe,rule as[unfolded negligible_def,rule_format])
+ apply(rule_tac x=1 in exI) apply(safe,rule zero_less_one) apply(rule_tac x=0 in exI)
+ using negligible_subset[OF as,of "s \<inter> t"] unfolding negligible_def indicator_def unfolding * by auto qed auto
+
+subsection {* Finite case of the spike theorem is quite commonly needed. *}
+
+lemma has_integral_spike_finite: assumes "finite s" "\<forall>x\<in>t-s. g x = f x"
+ "(f has_integral y) t" shows "(g has_integral y) t"
+ apply(rule has_integral_spike) using assms by auto
+
+lemma has_integral_spike_finite_eq: assumes "finite s" "\<forall>x\<in>t-s. g x = f x"
+ shows "((f has_integral y) t \<longleftrightarrow> (g has_integral y) t)"
+ apply rule apply(rule_tac[!] has_integral_spike_finite) using assms by auto
+
+lemma integrable_spike_finite:
+ assumes "finite s" "\<forall>x\<in>t-s. g x = f x" "f integrable_on t" shows "g integrable_on t"
+ using assms unfolding integrable_on_def apply safe apply(rule_tac x=y in exI)
+ apply(rule has_integral_spike_finite) by auto
+
+subsection {* In particular, the boundary of an interval is negligible. *}
+
+lemma negligible_frontier_interval: "negligible({a..b} - {a<..<b})"
+proof- let ?A = "\<Union>((\<lambda>k. {x. x$k = a$k} \<union> {x. x$k = b$k}) ` UNIV)"
+ have "{a..b} - {a<..<b} \<subseteq> ?A" apply rule unfolding Diff_iff mem_interval not_all
+ apply(erule conjE exE)+ apply(rule_tac X="{x. x $ xa = a $ xa} \<union> {x. x $ xa = b $ xa}" in UnionI)
+ apply(erule_tac[!] x=xa in allE) by auto
+ thus ?thesis apply-apply(rule negligible_subset[of ?A]) apply(rule negligible_unions[OF finite_imageI]) by auto qed
+
+lemma has_integral_spike_interior:
+ assumes "\<forall>x\<in>{a<..<b}. g x = f x" "(f has_integral y) ({a..b})" shows "(g has_integral y) ({a..b})"
+ apply(rule has_integral_spike[OF negligible_frontier_interval _ assms(2)]) using assms(1) by auto
+
+lemma has_integral_spike_interior_eq:
+ assumes "\<forall>x\<in>{a<..<b}. g x = f x" shows "((f has_integral y) ({a..b}) \<longleftrightarrow> (g has_integral y) ({a..b}))"
+ apply rule apply(rule_tac[!] has_integral_spike_interior) using assms by auto
+
+lemma integrable_spike_interior: assumes "\<forall>x\<in>{a<..<b}. g x = f x" "f integrable_on {a..b}" shows "g integrable_on {a..b}"
+ using assms unfolding integrable_on_def using has_integral_spike_interior[OF assms(1)] by auto
+
+subsection {* Integrability of continuous functions. *}
+
+lemma neutral_and[simp]: "neutral op \<and> = True"
+ unfolding neutral_def apply(rule some_equality) by auto
+
+lemma monoidal_and[intro]: "monoidal op \<and>" unfolding monoidal_def by auto
+
+lemma iterate_and[simp]: assumes "finite s" shows "(iterate op \<and>) s p \<longleftrightarrow> (\<forall>x\<in>s. p x)" using assms
+apply induct unfolding iterate_insert[OF monoidal_and] by auto
+
+lemma operative_division_and: assumes "operative op \<and> P" "d division_of {a..b}"
+ shows "(\<forall>i\<in>d. P i) \<longleftrightarrow> P {a..b}"
+ using operative_division[OF monoidal_and assms] division_of_finite[OF assms(2)] by auto
+
+lemma operative_approximable: assumes "0 \<le> e" fixes f::"real^'n \<Rightarrow> 'a::banach"
+ shows "operative op \<and> (\<lambda>i. \<exists>g. (\<forall>x\<in>i. norm (f x - g (x::real^'n)) \<le> e) \<and> g integrable_on i)" unfolding operative_def neutral_and
+proof safe fix a b::"real^'n" { assume "content {a..b} = 0"
+ thus "\<exists>g. (\<forall>x\<in>{a..b}. norm (f x - g x) \<le> e) \<and> g integrable_on {a..b}"
+ apply(rule_tac x=f in exI) using assms by(auto intro!:integrable_on_null) }
+ { fix c k g assume as:"\<forall>x\<in>{a..b}. norm (f x - g x) \<le> e" "g integrable_on {a..b}"
+ show "\<exists>g. (\<forall>x\<in>{a..b} \<inter> {x. x $ k \<le> c}. norm (f x - g x) \<le> e) \<and> g integrable_on {a..b} \<inter> {x. x $ k \<le> c}"
+ "\<exists>g. (\<forall>x\<in>{a..b} \<inter> {x. c \<le> x $ k}. norm (f x - g x) \<le> e) \<and> g integrable_on {a..b} \<inter> {x. c \<le> x $ k}"
+ apply(rule_tac[!] x=g in exI) using as(1) integrable_split[OF as(2)] by auto }
+ fix c k g1 g2 assume as:"\<forall>x\<in>{a..b} \<inter> {x. x $ k \<le> c}. norm (f x - g1 x) \<le> e" "g1 integrable_on {a..b} \<inter> {x. x $ k \<le> c}"
+ "\<forall>x\<in>{a..b} \<inter> {x. c \<le> x $ k}. norm (f x - g2 x) \<le> e" "g2 integrable_on {a..b} \<inter> {x. c \<le> x $ k}"
+ let ?g = "\<lambda>x. if x$k = c then f x else if x$k \<le> c then g1 x else g2 x"
+ show "\<exists>g. (\<forall>x\<in>{a..b}. norm (f x - g x) \<le> e) \<and> g integrable_on {a..b}" apply(rule_tac x="?g" in exI)
+ proof safe case goal1 thus ?case apply- apply(cases "x$k=c", case_tac "x$k < c") using as assms by auto
+ next case goal2 presume "?g integrable_on {a..b} \<inter> {x. x $ k \<le> c}" "?g integrable_on {a..b} \<inter> {x. x $ k \<ge> c}"
+ then guess h1 h2 unfolding integrable_on_def by auto from has_integral_split[OF this]
+ show ?case unfolding integrable_on_def by auto
+ next show "?g integrable_on {a..b} \<inter> {x. x $ k \<le> c}" "?g integrable_on {a..b} \<inter> {x. x $ k \<ge> c}"
+ apply(rule_tac[!] integrable_spike[OF negligible_standard_hyperplane[of k c]]) using as(2,4) by auto qed qed
+
+lemma approximable_on_division: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ assumes "0 \<le> e" "d division_of {a..b}" "\<forall>i\<in>d. \<exists>g. (\<forall>x\<in>i. norm (f x - g x) \<le> e) \<and> g integrable_on i"
+ obtains g where "\<forall>x\<in>{a..b}. norm (f x - g x) \<le> e" "g integrable_on {a..b}"
+proof- note * = operative_division[OF monoidal_and operative_approximable[OF assms(1)] assms(2)]
+ note this[unfolded iterate_and[OF division_of_finite[OF assms(2)]]] from assms(3)[unfolded this[of f]]
+ guess g .. thus thesis apply-apply(rule that[of g]) by auto qed
+
+lemma integrable_continuous: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ assumes "continuous_on {a..b} f" shows "f integrable_on {a..b}"
+proof(rule integrable_uniform_limit,safe) fix e::real assume e:"0 < e"
+ from compact_uniformly_continuous[OF assms compact_interval,unfolded uniformly_continuous_on_def,rule_format,OF e] guess d ..
+ note d=conjunctD2[OF this,rule_format]
+ from fine_division_exists[OF gauge_ball[OF d(1)], of a b] guess p . note p=this
+ note p' = tagged_division_ofD[OF p(1)]
+ have *:"\<forall>i\<in>snd ` p. \<exists>g. (\<forall>x\<in>i. norm (f x - g x) \<le> e) \<and> g integrable_on i"
+ proof(safe,unfold snd_conv) fix x l assume as:"(x,l) \<in> p"
+ from p'(4)[OF this] guess a b apply-by(erule exE)+ note l=this
+ show "\<exists>g. (\<forall>x\<in>l. norm (f x - g x) \<le> e) \<and> g integrable_on l" apply(rule_tac x="\<lambda>y. f x" in exI)
+ proof safe show "(\<lambda>y. f x) integrable_on l" unfolding integrable_on_def l by(rule,rule has_integral_const)
+ fix y assume y:"y\<in>l" note fineD[OF p(2) as,unfolded subset_eq,rule_format,OF this]
+ note d(2)[OF _ _ this[unfolded mem_ball]]
+ thus "norm (f y - f x) \<le> e" using y p'(2-3)[OF as] unfolding vector_dist_norm l norm_minus_commute by fastsimp qed qed
+ from e have "0 \<le> e" by auto from approximable_on_division[OF this division_of_tagged_division[OF p(1)] *] guess g .
+ thus "\<exists>g. (\<forall>x\<in>{a..b}. norm (f x - g x) \<le> e) \<and> g integrable_on {a..b}" by auto qed
+
+subsection {* Specialization of additivity to one dimension. *}
+
+lemma operative_1_lt: assumes "monoidal opp"
+ shows "operative opp f \<longleftrightarrow> ((\<forall>a b. b \<le> a \<longrightarrow> f {a..b::real^1} = neutral opp) \<and>
+ (\<forall>a b c. a < c \<and> c < b \<longrightarrow> opp (f{a..c})(f{c..b}) = f {a..b}))"
+ unfolding operative_def content_eq_0_1 forall_1 vector_le_def vector_less_def
+proof safe fix a b c::"real^1" assume as:"\<forall>a b c. f {a..b} = opp (f ({a..b} \<inter> {x. x $ 1 \<le> c})) (f ({a..b} \<inter> {x. c \<le> x $ 1}))" "a $ 1 < c $ 1" "c $ 1 < b $ 1"
+ from this(2-) have "{a..b} \<inter> {x. x $ 1 \<le> c $ 1} = {a..c}" "{a..b} \<inter> {x. x $ 1 \<ge> c $ 1} = {c..b}" by auto
+ thus "opp (f {a..c}) (f {c..b}) = f {a..b}" unfolding as(1)[rule_format,of a b "c$1"] by auto
+next fix a b::"real^1" and c::real
+ assume as:"\<forall>a b. b $ 1 \<le> a $ 1 \<longrightarrow> f {a..b} = neutral opp" "\<forall>a b c. a $ 1 < c $ 1 \<and> c $ 1 < b $ 1 \<longrightarrow> opp (f {a..c}) (f {c..b}) = f {a..b}"
+ show "f {a..b} = opp (f ({a..b} \<inter> {x. x $ 1 \<le> c})) (f ({a..b} \<inter> {x. c \<le> x $ 1}))"
+ proof(cases "c \<in> {a$1 .. b$1}")
+ case False hence "c<a$1 \<or> c>b$1" by auto
+ thus ?thesis apply-apply(erule disjE)
+ proof- assume "c<a$1" hence *:"{a..b} \<inter> {x. x $ 1 \<le> c} = {1..0}" "{a..b} \<inter> {x. c \<le> x $ 1} = {a..b}" by auto
+ show ?thesis unfolding * apply(subst as(1)[rule_format,of 0 1]) using assms by auto
+ next assume "b$1<c" hence *:"{a..b} \<inter> {x. x $ 1 \<le> c} = {a..b}" "{a..b} \<inter> {x. c \<le> x $ 1} = {1..0}" by auto
+ show ?thesis unfolding * apply(subst as(1)[rule_format,of 0 1]) using assms by auto
+ qed
+ next case True hence *:"min (b $ 1) c = c" "max (a $ 1) c = c" by auto
+ show ?thesis unfolding interval_split num1_eq_iff if_True * vec_def[THEN sym]
+ proof(cases "c = a$1 \<or> c = b$1")
+ case False thus "f {a..b} = opp (f {a..vec1 c}) (f {vec1 c..b})"
+ apply-apply(subst as(2)[rule_format]) using True by auto
+ next case True thus "f {a..b} = opp (f {a..vec1 c}) (f {vec1 c..b})" apply-
+ proof(erule disjE) assume "c=a$1" hence *:"a = vec1 c" unfolding Cart_eq by auto
+ hence "f {a..vec1 c} = neutral opp" apply-apply(rule as(1)[rule_format]) by auto
+ thus ?thesis using assms unfolding * by auto
+ next assume "c=b$1" hence *:"b = vec1 c" unfolding Cart_eq by auto
+ hence "f {vec1 c..b} = neutral opp" apply-apply(rule as(1)[rule_format]) by auto
+ thus ?thesis using assms unfolding * by auto qed qed qed qed
+
+lemma operative_1_le: assumes "monoidal opp"
+ shows "operative opp f \<longleftrightarrow> ((\<forall>a b. b \<le> a \<longrightarrow> f {a..b::real^1} = neutral opp) \<and>
+ (\<forall>a b c. a \<le> c \<and> c \<le> b \<longrightarrow> opp (f{a..c})(f{c..b}) = f {a..b}))"
+unfolding operative_1_lt[OF assms]
+proof safe fix a b c::"real^1" assume as:"\<forall>a b c. a \<le> c \<and> c \<le> b \<longrightarrow> opp (f {a..c}) (f {c..b}) = f {a..b}" "a < c" "c < b"
+ show "opp (f {a..c}) (f {c..b}) = f {a..b}" apply(rule as(1)[rule_format]) using as(2-) unfolding vector_le_def vector_less_def by auto
+next fix a b c ::"real^1"
+ assume "\<forall>a b. b \<le> a \<longrightarrow> f {a..b} = neutral opp" "\<forall>a b c. a < c \<and> c < b \<longrightarrow> opp (f {a..c}) (f {c..b}) = f {a..b}" "a \<le> c" "c \<le> b"
+ note as = this[rule_format]
+ show "opp (f {a..c}) (f {c..b}) = f {a..b}"
+ proof(cases "c = a \<or> c = b")
+ case False thus ?thesis apply-apply(subst as(2)) using as(3-) unfolding vector_le_def vector_less_def Cart_eq by(auto simp del:dest_vec1_eq)
+ next case True thus ?thesis apply-
+ proof(erule disjE) assume *:"c=a" hence "f {a..c} = neutral opp" apply-apply(rule as(1)[rule_format]) by auto
+ thus ?thesis using assms unfolding * by auto
+ next assume *:"c=b" hence "f {c..b} = neutral opp" apply-apply(rule as(1)[rule_format]) by auto
+ thus ?thesis using assms unfolding * by auto qed qed qed
+
+subsection {* Special case of additivity we need for the FCT. *}
+
+lemma additive_tagged_division_1: fixes f::"real^1 \<Rightarrow> 'a::real_normed_vector"
+ assumes "dest_vec1 a \<le> dest_vec1 b" "p tagged_division_of {a..b}"
+ shows "setsum (\<lambda>(x,k). f(interval_upperbound k) - f(interval_lowerbound k)) p = f b - f a"
+proof- let ?f = "(\<lambda>k::(real^1) set. if k = {} then 0 else f(interval_upperbound k) - f(interval_lowerbound k))"
+ have *:"operative op + ?f" unfolding operative_1_lt[OF monoidal_monoid] interval_eq_empty_1
+ by(auto simp add:not_less interval_bound_1 vector_less_def)
+ have **:"{a..b} \<noteq> {}" using assms(1) by auto note operative_tagged_division[OF monoidal_monoid * assms(2)]
+ note * = this[unfolded if_not_P[OF **] interval_bound_1[OF assms(1)],THEN sym ]
+ show ?thesis unfolding * apply(subst setsum_iterate[THEN sym]) defer
+ apply(rule setsum_cong2) unfolding split_paired_all split_conv using assms(2) by auto qed
+
+subsection {* A useful lemma allowing us to factor out the content size. *}
+
+lemma has_integral_factor_content:
+ "(f has_integral i) {a..b} \<longleftrightarrow> (\<forall>e>0. \<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p
+ \<longrightarrow> norm (setsum (\<lambda>(x,k). content k *\<^sub>R f x) p - i) \<le> e * content {a..b}))"
+proof(cases "content {a..b} = 0")
+ case True show ?thesis unfolding has_integral_null_eq[OF True] apply safe
+ apply(rule,rule,rule gauge_trivial,safe) unfolding setsum_content_null[OF True] True defer
+ apply(erule_tac x=1 in allE,safe) defer apply(rule fine_division_exists[of _ a b],assumption)
+ apply(erule_tac x=p in allE) unfolding setsum_content_null[OF True] by auto
+next case False note F = this[unfolded content_lt_nz[THEN sym]]
+ let ?P = "\<lambda>e opp. \<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {a..b} \<and> d fine p \<longrightarrow> opp (norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f x) - i)) e)"
+ show ?thesis apply(subst has_integral)
+ proof safe fix e::real assume e:"e>0"
+ { assume "\<forall>e>0. ?P e op <" thus "?P (e * content {a..b}) op \<le>" apply(erule_tac x="e * content {a..b}" in allE)
+ apply(erule impE) defer apply(erule exE,rule_tac x=d in exI)
+ using F e by(auto simp add:field_simps intro:mult_pos_pos) }
+ { assume "\<forall>e>0. ?P (e * content {a..b}) op \<le>" thus "?P e op <" apply(erule_tac x="e / 2 / content {a..b}" in allE)
+ apply(erule impE) defer apply(erule exE,rule_tac x=d in exI)
+ using F e by(auto simp add:field_simps intro:mult_pos_pos) } qed qed
+
+subsection {* Fundamental theorem of calculus. *}
+
+lemma fundamental_theorem_of_calculus: fixes f::"real^1 \<Rightarrow> 'a::banach"
+ assumes "a \<le> b" "\<forall>x\<in>{a..b}. ((f o vec1) has_vector_derivative f'(vec1 x)) (at x within {a..b})"
+ shows "(f' has_integral (f(vec1 b) - f(vec1 a))) ({vec1 a..vec1 b})"
+unfolding has_integral_factor_content
+proof safe fix e::real assume e:"e>0" have ab:"dest_vec1 (vec1 a) \<le> dest_vec1 (vec1 b)" using assms(1) by auto
+ note assm = assms(2)[unfolded has_vector_derivative_def has_derivative_within_alt]
+ have *:"\<And>P Q. \<forall>x\<in>{a..b}. P x \<and> (\<forall>e>0. \<exists>d>0. Q x e d) \<Longrightarrow> \<forall>x. \<exists>(d::real)>0. x\<in>{a..b} \<longrightarrow> Q x e d" using e by blast
+ note this[OF assm,unfolded gauge_existence_lemma] from choice[OF this,unfolded Ball_def[symmetric]]
+ guess d .. note d=conjunctD2[OF this[rule_format],rule_format]
+ show "\<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {vec1 a..vec1 b} \<and> d fine p \<longrightarrow>
+ norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f' x) - (f (vec1 b) - f (vec1 a))) \<le> e * content {vec1 a..vec1 b})"
+ apply(rule_tac x="\<lambda>x. ball x (d (dest_vec1 x))" in exI,safe)
+ apply(rule gauge_ball_dependent,rule,rule d(1))
+ proof- fix p assume as:"p tagged_division_of {vec1 a..vec1 b}" "(\<lambda>x. ball x (d (dest_vec1 x))) fine p"
+ show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f' x) - (f (vec1 b) - f (vec1 a))) \<le> e * content {vec1 a..vec1 b}"
+ unfolding content_1[OF ab] additive_tagged_division_1[OF ab as(1),of f,THEN sym]
+ unfolding vector_minus_component[THEN sym] additive_tagged_division_1[OF ab as(1),of "\<lambda>x. x",THEN sym]
+ apply(subst dest_vec1_setsum) unfolding setsum_right_distrib defer unfolding setsum_subtractf[THEN sym]
+ proof(rule setsum_norm_le,safe) fix x k assume "(x,k)\<in>p"
+ note xk = tagged_division_ofD(2-4)[OF as(1) this] from this(3) guess u v apply-by(erule exE)+ note k=this
+ have *:"dest_vec1 u \<le> dest_vec1 v" using xk unfolding k by auto
+ have ball:"\<forall>xa\<in>k. xa \<in> ball x (d (dest_vec1 x))" using as(2)[unfolded fine_def,rule_format,OF `(x,k)\<in>p`,unfolded split_conv subset_eq] .
+ have "norm ((v$1 - u$1) *\<^sub>R f' x - (f v - f u)) \<le> norm (f u - f x - (u$1 - x$1) *\<^sub>R f' x) + norm (f v - f x - (v$1 - x$1) *\<^sub>R f' x)"
+ apply(rule order_trans[OF _ norm_triangle_ineq4]) apply(rule eq_refl) apply(rule arg_cong[where f=norm])
+ unfolding scaleR.diff_left by(auto simp add:group_simps)
+ also have "... \<le> e * norm (dest_vec1 u - dest_vec1 x) + e * norm (dest_vec1 v - dest_vec1 x)"
+ apply(rule add_mono) apply(rule d(2)[of "x$1" "u$1",unfolded o_def vec1_dest_vec1]) prefer 4
+ apply(rule d(2)[of "x$1" "v$1",unfolded o_def vec1_dest_vec1])
+ using ball[rule_format,of u] ball[rule_format,of v]
+ using xk(1-2) unfolding k subset_eq by(auto simp add:vector_dist_norm norm_real)
+ also have "... \<le> e * dest_vec1 (interval_upperbound k - interval_lowerbound k)"
+ unfolding k interval_bound_1[OF *] using xk(1) unfolding k by(auto simp add:vector_dist_norm norm_real field_simps)
+ finally show "norm (content k *\<^sub>R f' x - (f (interval_upperbound k) - f (interval_lowerbound k))) \<le>
+ e * dest_vec1 (interval_upperbound k - interval_lowerbound k)" unfolding k interval_bound_1[OF *] content_1[OF *] .
+ qed(insert as, auto) qed qed
+
+subsection {* Attempt a systematic general set of "offset" results for components. *}
+
+lemma gauge_modify:
+ assumes "(\<forall>s. open s \<longrightarrow> open {x. f(x) \<in> s})" "gauge d"
+ shows "gauge (\<lambda>x y. d (f x) (f y))"
+ using assms unfolding gauge_def apply safe defer apply(erule_tac x="f x" in allE)
+ apply(erule_tac x="d (f x)" in allE) unfolding mem_def Collect_def by auto
+
+subsection {* Only need trivial subintervals if the interval itself is trivial. *}
+
+lemma division_of_nontrivial: fixes s::"(real^'n) set set"
+ assumes "s division_of {a..b}" "content({a..b}) \<noteq> 0"
+ shows "{k. k \<in> s \<and> content k \<noteq> 0} division_of {a..b}" using assms(1) apply-
+proof(induct "card s" arbitrary:s rule:nat_less_induct)
+ fix s::"(real^'n) set set" assume assm:"s division_of {a..b}"
+ "\<forall>m<card s. \<forall>x. m = card x \<longrightarrow> x division_of {a..b} \<longrightarrow> {k \<in> x. content k \<noteq> 0} division_of {a..b}"
+ note s = division_ofD[OF assm(1)] let ?thesis = "{k \<in> s. content k \<noteq> 0} division_of {a..b}"
+ { presume *:"{k \<in> s. content k \<noteq> 0} \<noteq> s \<Longrightarrow> ?thesis"
+ show ?thesis apply cases defer apply(rule *,assumption) using assm(1) by auto }
+ assume noteq:"{k \<in> s. content k \<noteq> 0} \<noteq> s"
+ then obtain k where k:"k\<in>s" "content k = 0" by auto
+ from s(4)[OF k(1)] guess c d apply-by(erule exE)+ note k=k this
+ from k have "card s > 0" unfolding card_gt_0_iff using assm(1) by auto
+ hence card:"card (s - {k}) < card s" using assm(1) k(1) apply(subst card_Diff_singleton_if) by auto
+ have *:"closed (\<Union>(s - {k}))" apply(rule closed_Union) defer apply rule apply(drule DiffD1,drule s(4))
+ apply safe apply(rule closed_interval) using assm(1) by auto
+ have "k \<subseteq> \<Union>(s - {k})" apply safe apply(rule *[unfolded closed_limpt,rule_format]) unfolding islimpt_approachable
+ proof safe fix x and e::real assume as:"x\<in>k" "e>0"
+ from k(2)[unfolded k content_eq_0] guess i ..
+ hence i:"c$i = d$i" using s(3)[OF k(1),unfolded k] unfolding interval_ne_empty by smt
+ hence xi:"x$i = d$i" using as unfolding k mem_interval by smt
+ def y \<equiv> "(\<chi> j. if j = i then if c$i \<le> (a$i + b$i) / 2 then c$i + min e (b$i - c$i) / 2 else c$i - min e (c$i - a$i) / 2 else x$j)"
+ show "\<exists>x'\<in>\<Union>(s - {k}). x' \<noteq> x \<and> dist x' x < e" apply(rule_tac x=y in bexI)
+ proof have "d \<in> {c..d}" using s(3)[OF k(1)] unfolding k interval_eq_empty mem_interval by(fastsimp simp add: not_less)
+ hence "d \<in> {a..b}" using s(2)[OF k(1)] unfolding k by auto note di = this[unfolded mem_interval,THEN spec[where x=i]]
+ hence xyi:"y$i \<noteq> x$i" unfolding y_def unfolding i xi Cart_lambda_beta if_P[OF refl]
+ apply(cases) apply(subst if_P,assumption) unfolding if_not_P not_le using as(2) using assms(2)[unfolded content_eq_0] by smt+
+ thus "y \<noteq> x" unfolding Cart_eq by auto
+ have *:"UNIV = insert i (UNIV - {i})" by auto
+ have "norm (y - x) < e + setsum (\<lambda>i. 0) (UNIV::'n set)" apply(rule le_less_trans[OF norm_le_l1])
+ apply(subst *,subst setsum_insert) prefer 3 apply(rule add_less_le_mono)
+ proof- show "\<bar>(y - x) $ i\<bar> < e" unfolding y_def Cart_lambda_beta vector_minus_component if_P[OF refl]
+ apply(cases) apply(subst if_P,assumption) unfolding if_not_P unfolding i xi using di as(2) by auto
+ show "(\<Sum>i\<in>UNIV - {i}. \<bar>(y - x) $ i\<bar>) \<le> (\<Sum>i\<in>UNIV. 0)" unfolding y_def by auto
+ qed auto thus "dist y x < e" unfolding vector_dist_norm by auto
+ have "y\<notin>k" unfolding k mem_interval apply rule apply(erule_tac x=i in allE) using xyi unfolding k i xi by auto
+ moreover have "y \<in> \<Union>s" unfolding s mem_interval
+ proof note simps = y_def Cart_lambda_beta if_not_P
+ fix j::'n show "a $ j \<le> y $ j \<and> y $ j \<le> b $ j"
+ proof(cases "j = i") case False have "x \<in> {a..b}" using s(2)[OF k(1)] as(1) by auto
+ thus ?thesis unfolding simps if_not_P[OF False] unfolding mem_interval by auto
+ next case True note T = this show ?thesis
+ proof(cases "c $ i \<le> (a $ i + b $ i) / 2")
+ case True show ?thesis unfolding simps if_P[OF T] if_P[OF True] unfolding i
+ using True as(2) di apply-apply rule unfolding T by (auto simp add:field_simps)
+ next case False thus ?thesis unfolding simps if_P[OF T] if_not_P[OF False] unfolding i
+ using True as(2) di apply-apply rule unfolding T by (auto simp add:field_simps)
+ qed qed qed
+ ultimately show "y \<in> \<Union>(s - {k})" by auto
+ qed qed hence "\<Union>(s - {k}) = {a..b}" unfolding s(6)[THEN sym] by auto
+ hence "{ka \<in> s - {k}. content ka \<noteq> 0} division_of {a..b}" apply-apply(rule assm(2)[rule_format,OF card refl])
+ apply(rule division_ofI) defer apply(rule_tac[1-4] s) using assm(1) by auto
+ moreover have "{ka \<in> s - {k}. content ka \<noteq> 0} = {k \<in> s. content k \<noteq> 0}" using k by auto ultimately show ?thesis by auto qed
+
+subsection {* Integrabibility on subintervals. *}
+
+lemma operative_integrable: fixes f::"real^'n \<Rightarrow> 'a::banach" shows
+ "operative op \<and> (\<lambda>i. f integrable_on i)"
+ unfolding operative_def neutral_and apply safe apply(subst integrable_on_def)
+ unfolding has_integral_null_eq apply(rule,rule refl) apply(rule,assumption)+
+ unfolding integrable_on_def by(auto intro: has_integral_split)
+
+lemma integrable_subinterval: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ assumes "f integrable_on {a..b}" "{c..d} \<subseteq> {a..b}" shows "f integrable_on {c..d}"
+ apply(cases "{c..d} = {}") defer apply(rule partial_division_extend_1[OF assms(2)],assumption)
+ using operative_division_and[OF operative_integrable,THEN sym,of _ _ _ f] assms(1) by auto
+
+subsection {* Combining adjacent intervals in 1 dimension. *}
+
+lemma has_integral_combine: assumes "(a::real^1) \<le> c" "c \<le> b"
+ "(f has_integral i) {a..c}" "(f has_integral (j::'a::banach)) {c..b}"
+ shows "(f has_integral (i + j)) {a..b}"
+proof- note operative_integral[of f, unfolded operative_1_le[OF monoidal_lifted[OF monoidal_monoid]]]
+ note conjunctD2[OF this,rule_format] note * = this(2)[OF conjI[OF assms(1-2)],unfolded if_P[OF assms(3)]]
+ hence "f integrable_on {a..b}" apply- apply(rule ccontr) apply(subst(asm) if_P) defer
+ apply(subst(asm) if_P) using assms(3-) by auto
+ with * show ?thesis apply-apply(subst(asm) if_P) defer apply(subst(asm) if_P) defer apply(subst(asm) if_P)
+ unfolding lifted.simps using assms(3-) by(auto simp add: integrable_on_def integral_unique) qed
+
+lemma integral_combine: fixes f::"real^1 \<Rightarrow> 'a::banach"
+ assumes "a \<le> c" "c \<le> b" "f integrable_on ({a..b})"
+ shows "integral {a..c} f + integral {c..b} f = integral({a..b}) f"
+ apply(rule integral_unique[THEN sym]) apply(rule has_integral_combine[OF assms(1-2)])
+ apply(rule_tac[!] integrable_integral integrable_subinterval[OF assms(3)])+ using assms(1-2) by auto
+
+lemma integrable_combine: fixes f::"real^1 \<Rightarrow> 'a::banach"
+ assumes "a \<le> c" "c \<le> b" "f integrable_on {a..c}" "f integrable_on {c..b}"
+ shows "f integrable_on {a..b}" using assms unfolding integrable_on_def by(fastsimp intro!:has_integral_combine)
+
+subsection {* Reduce integrability to "local" integrability. *}
+
+lemma integrable_on_little_subintervals: fixes f::"real^'n \<Rightarrow> 'a::banach"
+ assumes "\<forall>x\<in>{a..b}. \<exists>d>0. \<forall>u v. x \<in> {u..v} \<and> {u..v} \<subseteq> ball x d \<and> {u..v} \<subseteq> {a..b} \<longrightarrow> f integrable_on {u..v}"
+ shows "f integrable_on {a..b}"
+proof- have "\<forall>x. \<exists>d. x\<in>{a..b} \<longrightarrow> d>0 \<and> (\<forall>u v. x \<in> {u..v} \<and> {u..v} \<subseteq> ball x d \<and> {u..v} \<subseteq> {a..b} \<longrightarrow> f integrable_on {u..v})"
+ using assms by auto note this[unfolded gauge_existence_lemma] from choice[OF this] guess d .. note d=this[rule_format]
+ guess p apply(rule fine_division_exists[OF gauge_ball_dependent,of d a b]) using d by auto note p=this(1-2)
+ note division_of_tagged_division[OF this(1)] note * = operative_division_and[OF operative_integrable,OF this,THEN sym,of f]
+ show ?thesis unfolding * apply safe unfolding snd_conv
+ proof- fix x k assume "(x,k) \<in> p" note tagged_division_ofD(2-4)[OF p(1) this] fineD[OF p(2) this]
+ thus "f integrable_on k" apply safe apply(rule d[THEN conjunct2,rule_format,of x]) by auto qed qed
+
+subsection {* Second FCT or existence of antiderivative. *}
+
+lemma integrable_const[intro]:"(\<lambda>x. c) integrable_on {a..b}"
+ unfolding integrable_on_def by(rule,rule has_integral_const)
+
+lemma integral_has_vector_derivative: fixes f::"real \<Rightarrow> 'a::banach"
+ assumes "continuous_on {a..b} f" "x \<in> {a..b}"
+ shows "((\<lambda>u. integral {vec a..vec u} (f o dest_vec1)) has_vector_derivative f(x)) (at x within {a..b})"
+ unfolding has_vector_derivative_def has_derivative_within_alt
+apply safe apply(rule scaleR.bounded_linear_left)
+proof- fix e::real assume e:"e>0"
+ note compact_uniformly_continuous[OF assms(1) compact_real_interval,unfolded uniformly_continuous_on_def]
+ from this[rule_format,OF e] guess d apply-by(erule conjE exE)+ note d=this[rule_format]
+ let ?I = "\<lambda>a b. integral {vec1 a..vec1 b} (f \<circ> dest_vec1)"
+ show "\<exists>d>0. \<forall>y\<in>{a..b}. norm (y - x) < d \<longrightarrow> norm (?I a y - ?I a x - (y - x) *\<^sub>R f x) \<le> e * norm (y - x)"
+ proof(rule,rule,rule d,safe) case goal1 show ?case proof(cases "y < x")
+ case False have "f \<circ> dest_vec1 integrable_on {vec1 a..vec1 y}" apply(rule integrable_subinterval,rule integrable_continuous)
+ apply(rule continuous_on_o_dest_vec1 assms)+ unfolding not_less using assms(2) goal1 by auto
+ hence *:"?I a y - ?I a x = ?I x y" unfolding group_simps apply(subst eq_commute) apply(rule integral_combine)
+ using False unfolding not_less using assms(2) goal1 by auto
+ have **:"norm (y - x) = content {vec1 x..vec1 y}" apply(subst content_1) using False unfolding not_less by auto
+ show ?thesis unfolding ** apply(rule has_integral_bound[where f="(\<lambda>u. f u - f x) o dest_vec1"]) unfolding * unfolding o_def
+ defer apply(rule has_integral_sub) apply(rule integrable_integral)
+ apply(rule integrable_subinterval,rule integrable_continuous) apply(rule continuous_on_o_dest_vec1[unfolded o_def] assms)+
+ proof- show "{vec1 x..vec1 y} \<subseteq> {vec1 a..vec1 b}" using goal1 assms(2) by auto
+ have *:"y - x = norm(y - x)" using False by auto
+ show "((\<lambda>xa. f x) has_integral (y - x) *\<^sub>R f x) {vec1 x..vec1 y}" apply(subst *) unfolding ** by auto
+ show "\<forall>xa\<in>{vec1 x..vec1 y}. norm (f (dest_vec1 xa) - f x) \<le> e" apply safe apply(rule less_imp_le)
+ apply(rule d(2)[unfolded vector_dist_norm]) using assms(2) using goal1 by auto
+ qed(insert e,auto)
+ next case True have "f \<circ> dest_vec1 integrable_on {vec1 a..vec1 x}" apply(rule integrable_subinterval,rule integrable_continuous)
+ apply(rule continuous_on_o_dest_vec1 assms)+ unfolding not_less using assms(2) goal1 by auto
+ hence *:"?I a x - ?I a y = ?I y x" unfolding group_simps apply(subst eq_commute) apply(rule integral_combine)
+ using True using assms(2) goal1 by auto
+ have **:"norm (y - x) = content {vec1 y..vec1 x}" apply(subst content_1) using True unfolding not_less by auto
+ have ***:"\<And>fy fx c::'a. fx - fy - (y - x) *\<^sub>R c = -(fy - fx - (x - y) *\<^sub>R c)" unfolding scaleR_left.diff by auto
+ show ?thesis apply(subst ***) unfolding norm_minus_cancel **
+ apply(rule has_integral_bound[where f="(\<lambda>u. f u - f x) o dest_vec1"]) unfolding * unfolding o_def
+ defer apply(rule has_integral_sub) apply(subst minus_minus[THEN sym]) unfolding minus_minus
+ apply(rule integrable_integral) apply(rule integrable_subinterval,rule integrable_continuous)
+ apply(rule continuous_on_o_dest_vec1[unfolded o_def] assms)+
+ proof- show "{vec1 y..vec1 x} \<subseteq> {vec1 a..vec1 b}" using goal1 assms(2) by auto
+ have *:"x - y = norm(y - x)" using True by auto
+ show "((\<lambda>xa. f x) has_integral (x - y) *\<^sub>R f x) {vec1 y..vec1 x}" apply(subst *) unfolding ** by auto
+ show "\<forall>xa\<in>{vec1 y..vec1 x}. norm (f (dest_vec1 xa) - f x) \<le> e" apply safe apply(rule less_imp_le)
+ apply(rule d(2)[unfolded vector_dist_norm]) using assms(2) using goal1 by auto
+ qed(insert e,auto) qed qed qed
+
+lemma integral_has_vector_derivative': fixes f::"real^1 \<Rightarrow> 'a::banach"
+ assumes "continuous_on {a..b} f" "x \<in> {a..b}"
+ shows "((\<lambda>u. (integral {a..vec u} f)) has_vector_derivative f x) (at (x$1) within {a$1..b$1})"
+ using integral_has_vector_derivative[OF continuous_on_o_vec1[OF assms(1)], of "x$1"]
+ unfolding o_def vec1_dest_vec1 using assms(2) by auto
+
+lemma antiderivative_continuous: assumes "continuous_on {a..b::real} f"
+ obtains g where "\<forall>x\<in> {a..b}. (g has_vector_derivative (f(x)::_::banach)) (at x within {a..b})"
+ apply(rule that,rule) using integral_has_vector_derivative[OF assms] by auto
+
+subsection {* Combined fundamental theorem of calculus. *}
+
+lemma antiderivative_integral_continuous: fixes f::"real \<Rightarrow> 'a::banach" assumes "continuous_on {a..b} f"
+ obtains g where "\<forall>u\<in>{a..b}. \<forall>v \<in> {a..b}. u \<le> v \<longrightarrow> ((f o dest_vec1) has_integral (g v - g u)) {vec u..vec v}"
+proof- from antiderivative_continuous[OF assms] guess g . note g=this
+ show ?thesis apply(rule that[of g])
+ proof safe case goal1 have "\<forall>x\<in>{u..v}. (g has_vector_derivative f x) (at x within {u..v})"
+ apply(rule,rule has_vector_derivative_within_subset) apply(rule g[rule_format]) using goal1(1-2) by auto
+ thus ?case using fundamental_theorem_of_calculus[OF goal1(3),of "g o dest_vec1" "f o dest_vec1"]
+ unfolding o_def vec1_dest_vec1 by auto qed qed
+
+subsection {* General "twiddling" for interval-to-interval function image. *}
+
+lemma has_integral_twiddle:
+ assumes "0 < r" "\<forall>x. h(g x) = x" "\<forall>x. g(h x) = x" "\<forall>x. continuous (at x) g"
+ "\<forall>u v. \<exists>w z. g ` {u..v} = {w..z}"
+ "\<forall>u v. \<exists>w z. h ` {u..v} = {w..z}"
+ "\<forall>u v. content(g ` {u..v}) = r * content {u..v}"
+ "(f has_integral i) {a..b}"
+ shows "((\<lambda>x. f(g x)) has_integral (1 / r) *\<^sub>R i) (h ` {a..b})"
+proof- { presume *:"{a..b} \<noteq> {} \<Longrightarrow> ?thesis"
+ show ?thesis apply cases defer apply(rule *,assumption)
+ proof- case goal1 thus ?thesis unfolding goal1 assms(8)[unfolded goal1 has_integral_empty_eq] by auto qed }
+ assume "{a..b} \<noteq> {}" from assms(6)[rule_format,of a b] guess w z apply-by(erule exE)+ note wz=this
+ have inj:"inj g" "inj h" unfolding inj_on_def apply safe apply(rule_tac[!] ccontr)
+ using assms(2) apply(erule_tac x=x in allE) using assms(2) apply(erule_tac x=y in allE) defer
+ using assms(3) apply(erule_tac x=x in allE) using assms(3) apply(erule_tac x=y in allE) by auto
+ show ?thesis unfolding has_integral_def has_integral_compact_interval_def apply(subst if_P) apply(rule,rule,rule wz)
+ proof safe fix e::real assume e:"e>0" hence "e * r > 0" using assms(1) by(rule mult_pos_pos)
+ from assms(8)[unfolded has_integral,rule_format,OF this] guess d apply-by(erule exE conjE)+ note d=this[rule_format]
+ def d' \<equiv> "\<lambda>x y. d (g x) (g y)" have d':"\<And>x. d' x = {y. g y \<in> (d (g x))}" unfolding d'_def by(auto simp add:mem_def)
+ show "\<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of h ` {a..b} \<and> d fine p \<longrightarrow> norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f (g x)) - (1 / r) *\<^sub>R i) < e)"
+ proof(rule_tac x=d' in exI,safe) show "gauge d'" using d(1) unfolding gauge_def d' using continuous_open_preimage_univ[OF assms(4)] by auto
+ fix p assume as:"p tagged_division_of h ` {a..b}" "d' fine p" note p = tagged_division_ofD[OF as(1)]
+ have "(\<lambda>(x, k). (g x, g ` k)) ` p tagged_division_of {a..b} \<and> d fine (\<lambda>(x, k). (g x, g ` k)) ` p" unfolding tagged_division_of
+ proof safe show "finite ((\<lambda>(x, k). (g x, g ` k)) ` p)" using as by auto
+ show "d fine (\<lambda>(x, k). (g x, g ` k)) ` p" using as(2) unfolding fine_def d' by auto
+ fix x k assume xk[intro]:"(x,k) \<in> p" show "g x \<in> g ` k" using p(2)[OF xk] by auto
+ show "\<exists>u v. g ` k = {u..v}" using p(4)[OF xk] using assms(5-6) by auto
+ { fix y assume "y \<in> k" thus "g y \<in> {a..b}" "g y \<in> {a..b}" using p(3)[OF xk,unfolded subset_eq,rule_format,of "h (g y)"]
+ using assms(2)[rule_format,of y] unfolding inj_image_mem_iff[OF inj(2)] by auto }
+ fix x' k' assume xk':"(x',k') \<in> p" fix z assume "z \<in> interior (g ` k)" "z \<in> interior (g ` k')"
+ hence *:"interior (g ` k) \<inter> interior (g ` k') \<noteq> {}" by auto
+ have same:"(x, k) = (x', k')" apply-apply(rule ccontr,drule p(5)[OF xk xk'])
+ proof- assume as:"interior k \<inter> interior k' = {}" from nonempty_witness[OF *] guess z .
+ hence "z \<in> g ` (interior k \<inter> interior k')" using interior_image_subset[OF assms(4) inj(1)]
+ unfolding image_Int[OF inj(1)] by auto thus False using as by blast
+ qed thus "g x = g x'" by auto
+ { fix z assume "z \<in> k" thus "g z \<in> g ` k'" using same by auto }
+ { fix z assume "z \<in> k'" thus "g z \<in> g ` k" using same by auto }
+ next fix x assume "x \<in> {a..b}" hence "h x \<in> \<Union>{k. \<exists>x. (x, k) \<in> p}" using p(6) by auto
+ then guess X unfolding Union_iff .. note X=this from this(1) guess y unfolding mem_Collect_eq ..
+ thus "x \<in> \<Union>{k. \<exists>x. (x, k) \<in> (\<lambda>(x, k). (g x, g ` k)) ` p}" apply-
+ apply(rule_tac X="g ` X" in UnionI) defer apply(rule_tac x="h x" in image_eqI)
+ using X(2) assms(3)[rule_format,of x] by auto
+ qed note ** = d(2)[OF this] have *:"inj_on (\<lambda>(x, k). (g x, g ` k)) p" using inj(1) unfolding inj_on_def by fastsimp
+ have "(\<Sum>(x, k)\<in>(\<lambda>(x, k). (g x, g ` k)) ` p. content k *\<^sub>R f x) - i = r *\<^sub>R (\<Sum>(x, k)\<in>p. content k *\<^sub>R f (g x)) - i" (is "?l = _") unfolding group_simps add_left_cancel
+ unfolding setsum_reindex[OF *] apply(subst scaleR_right.setsum) defer apply(rule setsum_cong2) unfolding o_def split_paired_all split_conv
+ apply(drule p(4)) apply safe unfolding assms(7)[rule_format] using p by auto
+ also have "... = r *\<^sub>R ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f (g x)) - (1 / r) *\<^sub>R i)" (is "_ = ?r") unfolding scaleR.diff_right scaleR.scaleR_left[THEN sym]
+ unfolding real_scaleR_def using assms(1) by auto finally have *:"?l = ?r" .
+ show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R f (g x)) - (1 / r) *\<^sub>R i) < e" using ** unfolding * unfolding norm_scaleR
+ using assms(1) by(auto simp add:field_simps) qed qed qed
+
+subsection {* Special case of a basic affine transformation. *}
+
+lemma interval_image_affinity_interval: shows "\<exists>u v. (\<lambda>x. m *\<^sub>R (x::real^'n) + c) ` {a..b} = {u..v}"
+ unfolding image_affinity_interval by auto
+
+lemmas Cart_simps = Cart_nth.add Cart_nth.minus Cart_nth.zero Cart_nth.diff Cart_nth.scaleR real_scaleR_def Cart_lambda_beta
+ Cart_eq vector_le_def vector_less_def
+
+lemma setprod_cong2: assumes "\<And>x. x \<in> A \<Longrightarrow> f x = g x" shows "setprod f A = setprod g A"
+ apply(rule setprod_cong) using assms by auto
+
+lemma content_image_affinity_interval:
+ "content((\<lambda>x::real^'n. m *\<^sub>R x + c) ` {a..b}) = (abs m) ^ CARD('n) * content {a..b}" (is "?l = ?r")
+proof- { presume *:"{a..b}\<noteq>{} \<Longrightarrow> ?thesis" show ?thesis apply(cases,rule *,assumption)
+ unfolding not_not using content_empty by auto }
+ assume as:"{a..b}\<noteq>{}" show ?thesis proof(cases "m \<ge> 0")
+ case True show ?thesis unfolding image_affinity_interval if_not_P[OF as] if_P[OF True]
+ unfolding content_closed_interval'[OF as] apply(subst content_closed_interval')
+ defer apply(subst setprod_constant[THEN sym]) apply(rule finite_UNIV) unfolding setprod_timesf[THEN sym]
+ apply(rule setprod_cong2) using True as unfolding interval_ne_empty Cart_simps not_le
+ by(auto simp add:field_simps intro:mult_left_mono)
+ next case False show ?thesis unfolding image_affinity_interval if_not_P[OF as] if_not_P[OF False]
+ unfolding content_closed_interval'[OF as] apply(subst content_closed_interval')
+ defer apply(subst setprod_constant[THEN sym]) apply(rule finite_UNIV) unfolding setprod_timesf[THEN sym]
+ apply(rule setprod_cong2) using False as unfolding interval_ne_empty Cart_simps not_le
+ by(auto simp add:field_simps mult_le_cancel_left_neg) qed qed
+
+lemma has_integral_affinity: assumes "(f has_integral i) {a..b::real^'n}" "m \<noteq> 0"
+ shows "((\<lambda>x. f(m *\<^sub>R x + c)) has_integral ((1 / (abs(m) ^ CARD('n::finite))) *\<^sub>R i)) ((\<lambda>x. (1 / m) *\<^sub>R x + -((1 / m) *\<^sub>R c)) ` {a..b})"
+ apply(rule has_integral_twiddle,safe) unfolding Cart_eq Cart_simps apply(rule zero_less_power)
+ defer apply(insert assms(2), simp add:field_simps) apply(insert assms(2), simp add:field_simps)
+ apply(rule continuous_intros)+ apply(rule interval_image_affinity_interval)+ apply(rule content_image_affinity_interval) using assms by auto
+
+lemma integrable_affinity: assumes "f integrable_on {a..b}" "m \<noteq> 0"
+ shows "(\<lambda>x. f(m *\<^sub>R x + c)) integrable_on ((\<lambda>x. (1 / m) *\<^sub>R x + -((1/m) *\<^sub>R c)) ` {a..b})"
+ using assms unfolding integrable_on_def apply safe apply(drule has_integral_affinity) by auto
+
+subsection {* Special case of stretching coordinate axes separately. *}
+
+lemma image_stretch_interval:
+ "(\<lambda>x. \<chi> k. m k * x$k) ` {a..b::real^'n} =
+ (if {a..b} = {} then {} else {(\<chi> k. min (m(k) * a$k) (m(k) * b$k)) .. (\<chi> k. max (m(k) * a$k) (m(k) * b$k))})" (is "?l = ?r")
+proof(cases "{a..b}={}") case True thus ?thesis unfolding True by auto
+next have *:"\<And>P Q. (\<forall>i. P i) \<and> (\<forall>i. Q i) \<longleftrightarrow> (\<forall>i. P i \<and> Q i)" by auto
+ case False note ab = this[unfolded interval_ne_empty]
+ show ?thesis apply-apply(rule set_ext)
+ proof- fix x::"real^'n" have **:"\<And>P Q. (\<forall>i. P i = Q i) \<Longrightarrow> (\<forall>i. P i) = (\<forall>i. Q i)" by auto
+ show "x \<in> ?l \<longleftrightarrow> x \<in> ?r" unfolding if_not_P[OF False]
+ unfolding image_iff mem_interval Bex_def Cart_simps Cart_eq *
+ unfolding lambda_skolem[THEN sym,of "\<lambda> i xa. (a $ i \<le> xa \<and> xa \<le> b $ i) \<and> x $ i = m i * xa"]
+ proof(rule **,rule) fix i::'n show "(\<exists>xa. (a $ i \<le> xa \<and> xa \<le> b $ i) \<and> x $ i = m i * xa) =
+ (min (m i * a $ i) (m i * b $ i) \<le> x $ i \<and> x $ i \<le> max (m i * a $ i) (m i * b $ i))"
+ proof(cases "m i = 0") case True thus ?thesis using ab by auto
+ next case False hence "0 < m i \<or> 0 > m i" by auto thus ?thesis apply-
+ proof(erule disjE) assume as:"0 < m i" hence *:"min (m i * a $ i) (m i * b $ i) = m i * a $ i"
+ "max (m i * a $ i) (m i * b $ i) = m i * b $ i" using ab unfolding min_def max_def by auto
+ show ?thesis unfolding * apply rule defer apply(rule_tac x="1 / m i * x$i" in exI)
+ using as by(auto simp add:field_simps)
+ next assume as:"0 > m i" hence *:"max (m i * a $ i) (m i * b $ i) = m i * a $ i"
+ "min (m i * a $ i) (m i * b $ i) = m i * b $ i" using ab as unfolding min_def max_def
+ by(auto simp add:field_simps mult_le_cancel_left_neg intro:real_le_antisym)
+ show ?thesis unfolding * apply rule defer apply(rule_tac x="1 / m i * x$i" in exI)
+ using as by(auto simp add:field_simps) qed qed qed qed qed
+
+lemma interval_image_stretch_interval: "\<exists>u v. (\<lambda>x. \<chi> k. m k * x$k) ` {a..b::real^'n} = {u..v}"
+ unfolding image_stretch_interval by auto
+
+lemma content_image_stretch_interval:
+ "content((\<lambda>x::real^'n. \<chi> k. m k * x$k) ` {a..b}) = abs(setprod m UNIV) * content({a..b})"
+proof(cases "{a..b} = {}") case True thus ?thesis
+ unfolding content_def image_is_empty image_stretch_interval if_P[OF True] by auto
+next case False hence "(\<lambda>x. \<chi> k. m k * x $ k) ` {a..b} \<noteq> {}" by auto
+ thus ?thesis using False unfolding content_def image_stretch_interval apply- unfolding interval_bounds' if_not_P
+ unfolding abs_setprod setprod_timesf[THEN sym] apply(rule setprod_cong2) unfolding Cart_lambda_beta
+ proof- fix i::'n have "(m i < 0 \<or> m i > 0) \<or> m i = 0" by auto
+ thus "max (m i * a $ i) (m i * b $ i) - min (m i * a $ i) (m i * b $ i) = \<bar>m i\<bar> * (b $ i - a $ i)"
+ apply-apply(erule disjE)+ unfolding min_def max_def using False[unfolded interval_ne_empty,rule_format,of i]
+ by(auto simp add:field_simps not_le mult_le_cancel_left_neg mult_le_cancel_left_pos) qed qed
+
+lemma has_integral_stretch: assumes "(f has_integral i) {a..b}" "\<forall>k. ~(m k = 0)"
+ shows "((\<lambda>x. f(\<chi> k. m k * x$k)) has_integral
+ ((1/(abs(setprod m UNIV))) *\<^sub>R i)) ((\<lambda>x. \<chi> k. 1/(m k) * x$k) ` {a..b})"
+ apply(rule has_integral_twiddle) unfolding zero_less_abs_iff content_image_stretch_interval
+ unfolding image_stretch_interval empty_as_interval Cart_eq using assms
+proof- show "\<forall>x. continuous (at x) (\<lambda>x. \<chi> k. m k * x $ k)"
+ apply(rule,rule linear_continuous_at) unfolding linear_linear
+ unfolding linear_def Cart_simps Cart_eq by(auto simp add:field_simps) qed auto
+
+lemma integrable_stretch:
+ assumes "f integrable_on {a..b}" "\<forall>k. ~(m k = 0)"
+ shows "(\<lambda>x. f(\<chi> k. m k * x$k)) integrable_on ((\<lambda>x. \<chi> k. 1/(m k) * x$k) ` {a..b})"
+ using assms unfolding integrable_on_def apply-apply(erule exE) apply(drule has_integral_stretch) by auto
+
+subsection {* even more special cases. *}
+
+lemma uminus_interval_vector[simp]:"uminus ` {a..b} = {-b .. -a::real^'n}"
+ apply(rule set_ext,rule) defer unfolding image_iff
+ apply(rule_tac x="-x" in bexI) by(auto simp add:vector_le_def minus_le_iff le_minus_iff)
+
+lemma has_integral_reflect_lemma[intro]: assumes "(f has_integral i) {a..b}"
+ shows "((\<lambda>x. f(-x)) has_integral i) {-b .. -a}"
+ using has_integral_affinity[OF assms, of "-1" 0] by auto
+
+lemma has_integral_reflect[simp]: "((\<lambda>x. f(-x)) has_integral i) {-b..-a} \<longleftrightarrow> (f has_integral i) ({a..b})"
+ apply rule apply(drule_tac[!] has_integral_reflect_lemma) by auto
+
+lemma integrable_reflect[simp]: "(\<lambda>x. f(-x)) integrable_on {-b..-a} \<longleftrightarrow> f integrable_on {a..b}"
+ unfolding integrable_on_def by auto
+
+lemma integral_reflect[simp]: "integral {-b..-a} (\<lambda>x. f(-x)) = integral ({a..b}) f"
+ unfolding integral_def by auto
+
+subsection {* Stronger form of FCT; quite a tedious proof. *}
+
+(** move this **)
+declare norm_triangle_ineq4[intro]
+
+lemma bgauge_existence_lemma: "(\<forall>x\<in>s. \<exists>d::real. 0 < d \<and> q d x) \<longleftrightarrow> (\<forall>x. \<exists>d>0. x\<in>s \<longrightarrow> q d x)" by(meson zero_less_one)
+
+lemma additive_tagged_division_1': fixes f::"real \<Rightarrow> 'a::real_normed_vector"
+ assumes "a \<le> b" "p tagged_division_of {vec1 a..vec1 b}"
+ shows "setsum (\<lambda>(x,k). f (dest_vec1 (interval_upperbound k)) - f(dest_vec1 (interval_lowerbound k))) p = f b - f a"
+ using additive_tagged_division_1[OF _ assms(2), of "f o dest_vec1"]
+ unfolding o_def vec1_dest_vec1 using assms(1) by auto
+
+lemma split_minus[simp]:"(\<lambda>(x, k). ?f x k) x - (\<lambda>(x, k). ?g x k) x = (\<lambda>(x, k). ?f x k - ?g x k) x"
+ unfolding split_def by(rule refl)
+
+lemma norm_triangle_le_sub: "norm x + norm y \<le> e \<Longrightarrow> norm (x - y) \<le> e"
+ apply(subst(asm)(2) norm_minus_cancel[THEN sym])
+ apply(drule norm_triangle_le) by(auto simp add:group_simps)
+
+lemma fundamental_theorem_of_calculus_interior:
+ assumes"a \<le> b" "continuous_on {a..b} f" "\<forall>x\<in>{a<..<b}. (f has_vector_derivative f'(x)) (at x)"
+ shows "((f' o dest_vec1) has_integral (f b - f a)) {vec a..vec b}"
+proof- { presume *:"a < b \<Longrightarrow> ?thesis"
+ show ?thesis proof(cases,rule *,assumption)
+ assume "\<not> a < b" hence "a = b" using assms(1) by auto
+ hence *:"{vec a .. vec b} = {vec b}" "f b - f a = 0" apply(auto simp add: Cart_simps) by smt
+ show ?thesis unfolding *(2) apply(rule has_integral_null) unfolding content_eq_0_1 using * `a=b` by auto
+ qed } assume ab:"a < b"
+ let ?P = "\<lambda>e. \<exists>d. gauge d \<and> (\<forall>p. p tagged_division_of {vec1 a..vec1 b} \<and> d fine p \<longrightarrow>
+ norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R (f' \<circ> dest_vec1) x) - (f b - f a)) \<le> e * content {vec1 a..vec1 b})"
+ { presume "\<And>e. e>0 \<Longrightarrow> ?P e" thus ?thesis unfolding has_integral_factor_content by auto }
+ fix e::real assume e:"e>0"
+ note assms(3)[unfolded has_vector_derivative_def has_derivative_at_alt ball_conj_distrib]
+ note conjunctD2[OF this] note bounded=this(1) and this(2)
+ from this(2) have "\<forall>x\<in>{a<..<b}. \<exists>d>0. \<forall>y. norm (y - x) < d \<longrightarrow> norm (f y - f x - (y - x) *\<^sub>R f' x) \<le> e/2 * norm (y - x)"
+ apply-apply safe apply(erule_tac x=x in ballE,erule_tac x="e/2" in allE) using e by auto note this[unfolded bgauge_existence_lemma]
+ from choice[OF this] guess d .. note conjunctD2[OF this[rule_format]] note d = this[rule_format]
+ have "bounded (f ` {a..b})" apply(rule compact_imp_bounded compact_continuous_image)+ using compact_real_interval assms by auto
+ from this[unfolded bounded_pos] guess B .. note B = this[rule_format]
+
+ have "\<exists>da. 0 < da \<and> (\<forall>c. a \<le> c \<and> {a..c} \<subseteq> {a..b} \<and> {a..c} \<subseteq> ball a da
+ \<longrightarrow> norm(content {vec1 a..vec1 c} *\<^sub>R f' a - (f c - f a)) \<le> (e * (b - a)) / 4)"
+ proof- have "a\<in>{a..b}" using ab by auto
+ note assms(2)[unfolded continuous_on_eq_continuous_within,rule_format,OF this]
+ note * = this[unfolded continuous_within Lim_within,rule_format] have "(e * (b - a)) / 8 > 0" using e ab by(auto simp add:field_simps)
+ from *[OF this] guess k .. note k = conjunctD2[OF this,rule_format]
+ have "\<exists>l. 0 < l \<and> norm(l *\<^sub>R f' a) \<le> (e * (b - a)) / 8"
+ proof(cases "f' a = 0") case True
+ thus ?thesis apply(rule_tac x=1 in exI) using ab e by(auto intro!:mult_nonneg_nonneg)
+ next case False thus ?thesis
+ apply(rule_tac x="(e * (b - a)) / 8 / norm (f' a)" in exI)
+ using ab e by(auto simp add:field_simps)
+ qed then guess l .. note l = conjunctD2[OF this]
+ show ?thesis apply(rule_tac x="min k l" in exI) apply safe unfolding min_less_iff_conj apply(rule,(rule l k)+)
+ proof- fix c assume as:"a \<le> c" "{a..c} \<subseteq> {a..b}" "{a..c} \<subseteq> ball a (min k l)"
+ note as' = this[unfolded subset_eq Ball_def mem_ball dist_real_def mem_interval]
+ have "norm ((c - a) *\<^sub>R f' a - (f c - f a)) \<le> norm ((c - a) *\<^sub>R f' a) + norm (f c - f a)" by(rule norm_triangle_ineq4)
+ also have "... \<le> e * (b - a) / 8 + e * (b - a) / 8"
+ proof(rule add_mono) case goal1 have "\<bar>c - a\<bar> \<le> \<bar>l\<bar>" using as' by auto
+ thus ?case apply-apply(rule order_trans[OF _ l(2)]) unfolding norm_scaleR apply(rule mult_right_mono) by auto
+ next case goal2 show ?case apply(rule less_imp_le) apply(cases "a = c") defer
+ apply(rule k(2)[unfolded vector_dist_norm]) using as' e ab by(auto simp add:field_simps)
+ qed finally show "norm (content {vec1 a..vec1 c} *\<^sub>R f' a - (f c - f a)) \<le> e * (b - a) / 4" unfolding content_1'[OF as(1)] by auto
+ qed qed then guess da .. note da=conjunctD2[OF this,rule_format]
+
+ have "\<exists>db>0. \<forall>c\<le>b. {c..b} \<subseteq> {a..b} \<and> {c..b} \<subseteq> ball b db \<longrightarrow> norm(content {vec1 c..vec1 b} *\<^sub>R f' b - (f b - f c)) \<le> (e * (b - a)) / 4"
+ proof- have "b\<in>{a..b}" using ab by auto
+ note assms(2)[unfolded continuous_on_eq_continuous_within,rule_format,OF this]
+ note * = this[unfolded continuous_within Lim_within,rule_format] have "(e * (b - a)) / 8 > 0" using e ab by(auto simp add:field_simps)
+ from *[OF this] guess k .. note k = conjunctD2[OF this,rule_format]
+ have "\<exists>l. 0 < l \<and> norm(l *\<^sub>R f' b) \<le> (e * (b - a)) / 8"
+ proof(cases "f' b = 0") case True
+ thus ?thesis apply(rule_tac x=1 in exI) using ab e by(auto intro!:mult_nonneg_nonneg)
+ next case False thus ?thesis
+ apply(rule_tac x="(e * (b - a)) / 8 / norm (f' b)" in exI)
+ using ab e by(auto simp add:field_simps)
+ qed then guess l .. note l = conjunctD2[OF this]
+ show ?thesis apply(rule_tac x="min k l" in exI) apply safe unfolding min_less_iff_conj apply(rule,(rule l k)+)
+ proof- fix c assume as:"c \<le> b" "{c..b} \<subseteq> {a..b}" "{c..b} \<subseteq> ball b (min k l)"
+ note as' = this[unfolded subset_eq Ball_def mem_ball dist_real_def mem_interval]
+ have "norm ((b - c) *\<^sub>R f' b - (f b - f c)) \<le> norm ((b - c) *\<^sub>R f' b) + norm (f b - f c)" by(rule norm_triangle_ineq4)
+ also have "... \<le> e * (b - a) / 8 + e * (b - a) / 8"
+ proof(rule add_mono) case goal1 have "\<bar>c - b\<bar> \<le> \<bar>l\<bar>" using as' by auto
+ thus ?case apply-apply(rule order_trans[OF _ l(2)]) unfolding norm_scaleR apply(rule mult_right_mono) by auto
+ next case goal2 show ?case apply(rule less_imp_le) apply(cases "b = c") defer apply(subst norm_minus_commute)
+ apply(rule k(2)[unfolded vector_dist_norm]) using as' e ab by(auto simp add:field_simps)
+ qed finally show "norm (content {vec1 c..vec1 b} *\<^sub>R f' b - (f b - f c)) \<le> e * (b - a) / 4" unfolding content_1'[OF as(1)] by auto
+ qed qed then guess db .. note db=conjunctD2[OF this,rule_format]
+
+ let ?d = "(\<lambda>x. ball x (if x=vec1 a then da else if x=vec b then db else d (dest_vec1 x)))"
+ show "?P e" apply(rule_tac x="?d" in exI)
+ proof safe case goal1 show ?case apply(rule gauge_ball_dependent) using ab db(1) da(1) d(1) by auto
+ next case goal2 note as=this let ?A = "{t. fst t \<in> {vec1 a, vec1 b}}" note p = tagged_division_ofD[OF goal2(1)]
+ have pA:"p = (p \<inter> ?A) \<union> (p - ?A)" "finite (p \<inter> ?A)" "finite (p - ?A)" "(p \<inter> ?A) \<inter> (p - ?A) = {}" using goal2 by auto
+ note * = additive_tagged_division_1'[OF assms(1) goal2(1), THEN sym]
+ have **:"\<And>n1 s1 n2 s2::real. n2 \<le> s2 / 2 \<Longrightarrow> n1 - s1 \<le> s2 / 2 \<Longrightarrow> n1 + n2 \<le> s1 + s2" by arith
+ show ?case unfolding content_1'[OF assms(1)] and *[of "\<lambda>x. x"] *[of f] setsum_subtractf[THEN sym] split_minus
+ unfolding setsum_right_distrib apply(subst(2) pA,subst pA) unfolding setsum_Un_disjoint[OF pA(2-)]
+ proof(rule norm_triangle_le,rule **)
+ case goal1 show ?case apply(rule order_trans,rule setsum_norm_le) apply(rule pA) defer apply(subst divide.setsum)
+ proof(rule order_refl,safe,unfold not_le o_def split_conv fst_conv,rule ccontr) fix x k assume as:"(x,k) \<in> p"
+ "e * (dest_vec1 (interval_upperbound k) - dest_vec1 (interval_lowerbound k)) / 2
+ < norm (content k *\<^sub>R f' (dest_vec1 x) - (f (dest_vec1 (interval_upperbound k)) - f (dest_vec1 (interval_lowerbound k))))"
+ from p(4)[OF this(1)] guess u v apply-by(erule exE)+ note k=this
+ hence "\<forall>i. u$i \<le> v$i" and uv:"{u,v}\<subseteq>{u..v}" using p(2)[OF as(1)] by auto note this(1) this(1)[unfolded forall_1]
+ note result = as(2)[unfolded k interval_bounds[OF this(1)] content_1[OF this(2)]]
+
+ assume as':"x \<noteq> vec1 a" "x \<noteq> vec1 b" hence "x$1 \<in> {a<..<b}" using p(2-3)[OF as(1)] by(auto simp add:Cart_simps) note * = d(2)[OF this]
+ have "norm ((v$1 - u$1) *\<^sub>R f' (x$1) - (f (v$1) - f (u$1))) =
+ norm ((f (u$1) - f (x$1) - (u$1 - x$1) *\<^sub>R f' (x$1)) - (f (v$1) - f (x$1) - (v$1 - x$1) *\<^sub>R f' (x$1)))"
+ apply(rule arg_cong[of _ _ norm]) unfolding scaleR_left.diff by auto
+ also have "... \<le> e / 2 * norm (u$1 - x$1) + e / 2 * norm (v$1 - x$1)" apply(rule norm_triangle_le_sub)
+ apply(rule add_mono) apply(rule_tac[!] *) using fineD[OF goal2(2) as(1)] as' unfolding k subset_eq
+ apply- apply(erule_tac x=u in ballE,erule_tac[3] x=v in ballE) using uv by(auto simp add:dist_real)
+ also have "... \<le> e / 2 * norm (v$1 - u$1)" using p(2)[OF as(1)] unfolding k by(auto simp add:field_simps)
+ finally have "e * (dest_vec1 v - dest_vec1 u) / 2 < e * (dest_vec1 v - dest_vec1 u) / 2"
+ apply- apply(rule less_le_trans[OF result]) using uv by auto thus False by auto qed
+
+ next have *:"\<And>x s1 s2::real. 0 \<le> s1 \<Longrightarrow> x \<le> (s1 + s2) / 2 \<Longrightarrow> x - s1 \<le> s2 / 2" by auto
+ case goal2 show ?case apply(rule *) apply(rule setsum_nonneg) apply(rule,unfold split_paired_all split_conv)
+ defer unfolding setsum_Un_disjoint[OF pA(2-),THEN sym] pA(1)[THEN sym] unfolding setsum_right_distrib[THEN sym]
+ apply(subst additive_tagged_division_1[OF _ as(1)]) unfolding vec1_dest_vec1 apply(rule assms)
+ proof- fix x k assume "(x,k) \<in> p \<inter> {t. fst t \<in> {vec1 a, vec1 b}}" note xk=IntD1[OF this]
+ from p(4)[OF this] guess u v apply-by(erule exE)+ note uv=this
+ with p(2)[OF xk] have "{u..v} \<noteq> {}" by auto
+ thus "0 \<le> e * ((interval_upperbound k)$1 - (interval_lowerbound k)$1)"
+ unfolding uv using e by(auto simp add:field_simps)
+ next have *:"\<And>s f t e. setsum f s = setsum f t \<Longrightarrow> norm(setsum f t) \<le> e \<Longrightarrow> norm(setsum f s) \<le> e" by auto
+ show "norm (\<Sum>(x, k)\<in>p \<inter> ?A. content k *\<^sub>R (f' \<circ> dest_vec1) x -
+ (f ((interval_upperbound k)$1) - f ((interval_lowerbound k)$1))) \<le> e * (b - a) / 2"
+ apply(rule *[where t="p \<inter> {t. fst t \<in> {vec1 a, vec1 b} \<and> content(snd t) \<noteq> 0}"])
+ apply(rule setsum_mono_zero_right[OF pA(2)]) defer apply(rule) unfolding split_paired_all split_conv o_def
+ proof- fix x k assume "(x,k) \<in> p \<inter> {t. fst t \<in> {vec1 a, vec1 b}} - p \<inter> {t. fst t \<in> {vec1 a, vec1 b} \<and> content (snd t) \<noteq> 0}"
+ hence xk:"(x,k)\<in>p" "content k = 0" by auto from p(4)[OF xk(1)] guess u v apply-by(erule exE)+ note uv=this
+ have "k\<noteq>{}" using p(2)[OF xk(1)] by auto hence *:"u = v" using xk unfolding uv content_eq_0_1 interval_eq_empty by auto
+ thus "content k *\<^sub>R (f' (x$1)) - (f ((interval_upperbound k)$1) - f ((interval_lowerbound k)$1)) = 0" using xk unfolding uv by auto
+ next have *:"p \<inter> {t. fst t \<in> {vec1 a, vec1 b} \<and> content(snd t) \<noteq> 0} =
+ {t. t\<in>p \<and> fst t = vec1 a \<and> content(snd t) \<noteq> 0} \<union> {t. t\<in>p \<and> fst t = vec1 b \<and> content(snd t) \<noteq> 0}" by blast
+ have **:"\<And>s f. \<And>e::real. (\<forall>x y. x \<in> s \<and> y \<in> s \<longrightarrow> x = y) \<Longrightarrow> (\<forall>x. x \<in> s \<longrightarrow> norm(f x) \<le> e) \<Longrightarrow> e>0 \<Longrightarrow> norm(setsum f s) \<le> e"
+ proof(case_tac "s={}") case goal2 then obtain x where "x\<in>s" by auto hence *:"s = {x}" using goal2(1) by auto
+ thus ?case using `x\<in>s` goal2(2) by auto
+ qed auto
+ case goal2 show ?case apply(subst *, subst setsum_Un_disjoint) prefer 4 apply(rule order_trans[of _ "e * (b - a)/4 + e * (b - a)/4"])
+ apply(rule norm_triangle_le,rule add_mono) apply(rule_tac[1-2] **)
+ proof- let ?B = "\<lambda>x. {t \<in> p. fst t = vec1 x \<and> content (snd t) \<noteq> 0}"
+ have pa:"\<And>k. (vec1 a, k) \<in> p \<Longrightarrow> \<exists>v. k = {vec1 a .. v} \<and> vec1 a \<le> v"
+ proof- case goal1 guess u v using p(4)[OF goal1] apply-by(erule exE)+ note uv=this
+ have *:"u \<le> v" using p(2)[OF goal1] unfolding uv by auto
+ have u:"u = vec1 a" proof(rule ccontr) have "u \<in> {u..v}" using p(2-3)[OF goal1(1)] unfolding uv by auto
+ have "u \<ge> vec1 a" using p(2-3)[OF goal1(1)] unfolding uv subset_eq by auto moreover assume "u\<noteq>vec1 a" ultimately
+ have "u > vec1 a" unfolding Cart_simps by auto
+ thus False using p(2)[OF goal1(1)] unfolding uv by(auto simp add:Cart_simps)
+ qed thus ?case apply(rule_tac x=v in exI) unfolding uv using * by auto
+ qed
+ have pb:"\<And>k. (vec1 b, k) \<in> p \<Longrightarrow> \<exists>v. k = {v .. vec1 b} \<and> vec1 b \<ge> v"
+ proof- case goal1 guess u v using p(4)[OF goal1] apply-by(erule exE)+ note uv=this
+ have *:"u \<le> v" using p(2)[OF goal1] unfolding uv by auto
+ have u:"v = vec1 b" proof(rule ccontr) have "u \<in> {u..v}" using p(2-3)[OF goal1(1)] unfolding uv by auto
+ have "v \<le> vec1 b" using p(2-3)[OF goal1(1)] unfolding uv subset_eq by auto moreover assume "v\<noteq>vec1 b" ultimately
+ have "v < vec1 b" unfolding Cart_simps by auto
+ thus False using p(2)[OF goal1(1)] unfolding uv by(auto simp add:Cart_simps)
+ qed thus ?case apply(rule_tac x=u in exI) unfolding uv using * by auto
+ qed
+
+ show "\<forall>x y. x \<in> ?B a \<and> y \<in> ?B a \<longrightarrow> x = y" apply(rule,rule,rule,unfold split_paired_all)
+ unfolding mem_Collect_eq fst_conv snd_conv apply safe
+ proof- fix x k k' assume k:"(vec1 a, k) \<in> p" "(vec1 a, k') \<in> p" "content k \<noteq> 0" "content k' \<noteq> 0"
+ guess v using pa[OF k(1)] .. note v = conjunctD2[OF this]
+ guess v' using pa[OF k(2)] .. note v' = conjunctD2[OF this] let ?v = "vec1 (min (v$1) (v'$1))"
+ have "{vec1 a <..< ?v} \<subseteq> k \<inter> k'" unfolding v v' by(auto simp add:Cart_simps) note subset_interior[OF this,unfolded interior_inter]
+ moreover have "vec1 ((a + ?v$1)/2) \<in> {vec1 a <..< ?v}" using k(3-) unfolding v v' content_eq_0_1 not_le by(auto simp add:Cart_simps)
+ ultimately have "vec1 ((a + ?v$1)/2) \<in> interior k \<inter> interior k'" unfolding interior_open[OF open_interval] by auto
+ hence *:"k = k'" apply- apply(rule ccontr) using p(5)[OF k(1-2)] by auto
+ { assume "x\<in>k" thus "x\<in>k'" unfolding * . } { assume "x\<in>k'" thus "x\<in>k" unfolding * . }
+ qed
+ show "\<forall>x y. x \<in> ?B b \<and> y \<in> ?B b \<longrightarrow> x = y" apply(rule,rule,rule,unfold split_paired_all)
+ unfolding mem_Collect_eq fst_conv snd_conv apply safe
+ proof- fix x k k' assume k:"(vec1 b, k) \<in> p" "(vec1 b, k') \<in> p" "content k \<noteq> 0" "content k' \<noteq> 0"
+ guess v using pb[OF k(1)] .. note v = conjunctD2[OF this]
+ guess v' using pb[OF k(2)] .. note v' = conjunctD2[OF this] let ?v = "vec1 (max (v$1) (v'$1))"
+ have "{?v <..< vec1 b} \<subseteq> k \<inter> k'" unfolding v v' by(auto simp add:Cart_simps) note subset_interior[OF this,unfolded interior_inter]
+ moreover have "vec1 ((b + ?v$1)/2) \<in> {?v <..< vec1 b}" using k(3-) unfolding v v' content_eq_0_1 not_le by(auto simp add:Cart_simps)
+ ultimately have "vec1 ((b + ?v$1)/2) \<in> interior k \<inter> interior k'" unfolding interior_open[OF open_interval] by auto
+ hence *:"k = k'" apply- apply(rule ccontr) using p(5)[OF k(1-2)] by auto
+ { assume "x\<in>k" thus "x\<in>k'" unfolding * . } { assume "x\<in>k'" thus "x\<in>k" unfolding * . }
+ qed
+
+ let ?a = a and ?b = b (* a is something else while proofing the next theorem. *)
+ show "\<forall>x. x \<in> ?B a \<longrightarrow> norm ((\<lambda>(x, k). content k *\<^sub>R f' (x$1) - (f ((interval_upperbound k)$1) - f ((interval_lowerbound k)$1))) x)
+ \<le> e * (b - a) / 4" apply safe unfolding fst_conv snd_conv apply safe unfolding vec1_dest_vec1
+ proof- case goal1 guess v using pa[OF goal1(1)] .. note v = conjunctD2[OF this]
+ have "vec1 ?a\<in>{vec1 ?a..v}" using v(2) by auto hence "dest_vec1 v \<le> ?b" using p(3)[OF goal1(1)] unfolding subset_eq v by auto
+ moreover have "{?a..dest_vec1 v} \<subseteq> ball ?a da" using fineD[OF as(2) goal1(1)]
+ apply-apply(subst(asm) if_P,rule refl) unfolding subset_eq apply safe apply(erule_tac x="vec1 x" in ballE)
+ by(auto simp add:Cart_simps subset_eq dist_real v dist_real_def) ultimately
+ show ?case unfolding v unfolding interval_bounds[OF v(2)[unfolded v vector_le_def]] vec1_dest_vec1 apply-
+ apply(rule da(2)[of "v$1",unfolded vec1_dest_vec1])
+ using goal1 fineD[OF as(2) goal1(1)] unfolding v content_eq_0_1 by auto
+ qed
+ show "\<forall>x. x \<in> ?B b \<longrightarrow> norm ((\<lambda>(x, k). content k *\<^sub>R f' (x$1) - (f ((interval_upperbound k)$1) - f ((interval_lowerbound k)$1))) x)
+ \<le> e * (b - a) / 4" apply safe unfolding fst_conv snd_conv apply safe unfolding vec1_dest_vec1
+ proof- case goal1 guess v using pb[OF goal1(1)] .. note v = conjunctD2[OF this]
+ have "vec1 ?b\<in>{v..vec1 ?b}" using v(2) by auto hence "dest_vec1 v \<ge> ?a" using p(3)[OF goal1(1)] unfolding subset_eq v by auto
+ moreover have "{dest_vec1 v..?b} \<subseteq> ball ?b db" using fineD[OF as(2) goal1(1)]
+ apply-apply(subst(asm) if_P,rule refl) unfolding subset_eq apply safe apply(erule_tac x="vec1 x" in ballE) using ab
+ by(auto simp add:Cart_simps subset_eq dist_real v dist_real_def) ultimately
+ show ?case unfolding v unfolding interval_bounds[OF v(2)[unfolded v vector_le_def]] vec1_dest_vec1 apply-
+ apply(rule db(2)[of "v$1",unfolded vec1_dest_vec1])
+ using goal1 fineD[OF as(2) goal1(1)] unfolding v content_eq_0_1 by auto
+ qed
+ qed(insert p(1) ab e, auto simp add:field_simps) qed auto qed qed qed qed
+
+subsection {* Stronger form with finite number of exceptional points. *}
+
+lemma fundamental_theorem_of_calculus_interior_strong: fixes f::"real \<Rightarrow> 'a::banach"
+ assumes"finite s" "a \<le> b" "continuous_on {a..b} f"
+ "\<forall>x\<in>{a<..<b} - s. (f has_vector_derivative f'(x)) (at x)"
+ shows "((f' o dest_vec1) has_integral (f b - f a)) {vec a..vec b}" using assms apply-
+proof(induct "card s" arbitrary:s a b)
+ case 0 show ?case apply(rule fundamental_theorem_of_calculus_interior) using 0 by auto
+next case (Suc n) from this(2) guess c s' apply-apply(subst(asm) eq_commute) unfolding card_Suc_eq
+ apply(subst(asm)(2) eq_commute) by(erule exE conjE)+ note cs = this[rule_format]
+ show ?case proof(cases "c\<in>{a<..<b}")
+ case False thus ?thesis apply- apply(rule Suc(1)[OF cs(3) _ Suc(4,5)]) apply safe defer
+ apply(rule Suc(6)[rule_format]) using Suc(3) unfolding cs by auto
+ next have *:"f b - f a = (f c - f a) + (f b - f c)" by auto
+ case True hence "vec1 a \<le> vec1 c" "vec1 c \<le> vec1 b" by auto
+ thus ?thesis apply(subst *) apply(rule has_integral_combine) apply assumption+
+ apply(rule_tac[!] Suc(1)[OF cs(3)]) using Suc(3) unfolding cs
+ proof- show "continuous_on {a..c} f" "continuous_on {c..b} f"
+ apply(rule_tac[!] continuous_on_subset[OF Suc(5)]) using True by auto
+ let ?P = "\<lambda>i j. \<forall>x\<in>{i<..<j} - s'. (f has_vector_derivative f' x) (at x)"
+ show "?P a c" "?P c b" apply safe apply(rule_tac[!] Suc(6)[rule_format]) using True unfolding cs by auto
+ qed auto qed qed
+
+lemma fundamental_theorem_of_calculus_strong: fixes f::"real \<Rightarrow> 'a::banach"
+ assumes "finite s" "a \<le> b" "continuous_on {a..b} f"
+ "\<forall>x\<in>{a..b} - s. (f has_vector_derivative f'(x)) (at x)"
+ shows "((f' o dest_vec1) has_integral (f(b) - f(a))) {vec1 a..vec1 b}"
+ apply(rule fundamental_theorem_of_calculus_interior_strong[OF assms(1-3), of f'])
+ using assms(4) by auto
+
+end
--- a/src/HOL/Multivariate_Analysis/Multivariate_Analysis.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Multivariate_Analysis.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,5 @@
theory Multivariate_Analysis
-imports Determinants Derivative
+imports Determinants Integration_MV
begin
end
--- a/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space.thy Fri Feb 19 15:21:57 2010 +0000
@@ -3179,6 +3179,23 @@
(\<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{* Lifting and dropping *}
+
+lemma continuous_on_o_dest_vec1: fixes f::"real \<Rightarrow> 'a::real_normed_vector"
+ assumes "continuous_on {a..b::real} f" shows "continuous_on {vec1 a..vec1 b} (f o dest_vec1)"
+ using assms unfolding continuous_on_def apply safe
+ apply(erule_tac x="x$1" in ballE,erule_tac x=e in allE) apply safe
+ apply(rule_tac x=d in exI) apply safe unfolding o_def dist_real_def dist_real
+ apply(erule_tac x="dest_vec1 x'" in ballE) by(auto simp add:vector_le_def)
+
+lemma continuous_on_o_vec1: fixes f::"real^1 \<Rightarrow> 'a::real_normed_vector"
+ assumes "continuous_on {a..b} f" shows "continuous_on {dest_vec1 a..dest_vec1 b} (f o vec1)"
+ using assms unfolding continuous_on_def apply safe
+ apply(erule_tac x="vec x" in ballE,erule_tac x=e in allE) apply safe
+ apply(rule_tac x=d in exI) apply safe unfolding o_def dist_real_def dist_real
+ apply(erule_tac x="vec1 x'" in ballE) by(auto simp add:vector_le_def)
+
text{* Some simple consequential lemmas. *}
lemma uniformly_continuous_imp_continuous:
@@ -3708,6 +3725,17 @@
shows "\<forall>x. continuous (at x) f \<Longrightarrow> closed s \<Longrightarrow> closed (f -` s)"
unfolding vimage_def by (rule continuous_closed_preimage_univ)
+lemma interior_image_subset: fixes f::"_::metric_space \<Rightarrow> _::metric_space"
+ assumes "\<forall>x. continuous (at x) f" "inj f"
+ shows "interior (f ` s) \<subseteq> f ` (interior s)"
+ apply rule unfolding interior_def mem_Collect_eq image_iff apply safe
+proof- fix x T assume as:"open T" "x \<in> T" "T \<subseteq> f ` s"
+ hence "x \<in> f ` s" by auto then guess y unfolding image_iff .. note y=this
+ thus "\<exists>xa\<in>{x. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> s}. x = f xa" apply(rule_tac x=y in bexI) using assms as
+ apply safe apply(rule_tac x="{x. f x \<in> T}" in exI) apply(safe,rule continuous_open_preimage_univ)
+ proof- fix x assume "f x \<in> T" hence "f x \<in> f ` s" using as by auto
+ thus "x \<in> s" unfolding inj_image_mem_iff[OF assms(2)] . qed auto qed
+
text{* Equality of continuous functions on closure and related results. *}
lemma continuous_closed_in_preimage_constant:
@@ -5696,27 +5724,27 @@
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))"
+ "0 < (m::'a::linordered_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)"
+ "0 < (m::'a::linordered_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))"
+ "0 < (m::'a::linordered_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)"
+ "0 < (m::'a::linordered_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))"
+ "(m::'a::linordered_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)"
+ "(m::'a::linordered_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:
--- a/src/HOL/Mutabelle/Mutabelle.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Mutabelle/Mutabelle.thy Fri Feb 19 15:21:57 2010 +0000
@@ -16,7 +16,7 @@
(@{const_name dummy_pattern}, "'a::{}"),
(@{const_name Algebras.uminus}, "'a"),
(@{const_name Nat.size}, "'a"),
- (@{const_name Algebras.abs}, "'a")];
+ (@{const_name Groups.abs}, "'a")];
val forbidden_thms =
["finite_intvl_succ_class",
--- a/src/HOL/Mutabelle/mutabelle_extra.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Mutabelle/mutabelle_extra.ML Fri Feb 19 15:21:57 2010 +0000
@@ -197,7 +197,7 @@
(@{const_name "dummy_pattern"}, "'a::{}") (*,
(@{const_name "uminus"}, "'a"),
(@{const_name "Nat.size"}, "'a"),
- (@{const_name "Algebras.abs"}, "'a") *)]
+ (@{const_name "Groups.abs"}, "'a") *)]
val forbidden_thms =
["finite_intvl_succ_class",
--- a/src/HOL/NSA/HyperDef.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NSA/HyperDef.thy Fri Feb 19 15:21:57 2010 +0000
@@ -394,7 +394,7 @@
by (simp only: hypreal_three_squares_add_zero_iff hrealpow_two)
(*FIXME: This and RealPow.abs_realpow_two should be replaced by an abstract
- result proved in Ring_and_Field*)
+ result proved in Rings or Fields*)
lemma hrabs_hrealpow_two [simp]:
"abs(x ^ Suc (Suc 0)) = (x::hypreal) ^ Suc (Suc 0)"
by (simp add: abs_mult)
@@ -459,7 +459,7 @@
by transfer (rule power_inverse)
lemma hyperpow_hrabs:
- "\<And>r n. abs (r::'a::{ordered_idom} star) pow n = abs (r pow n)"
+ "\<And>r n. abs (r::'a::{linordered_idom} star) pow n = abs (r pow n)"
by transfer (rule power_abs [symmetric])
lemma hyperpow_add:
@@ -475,15 +475,15 @@
by transfer simp
lemma hyperpow_gt_zero:
- "\<And>r n. (0::'a::{ordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
+ "\<And>r n. (0::'a::{linordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
by transfer (rule zero_less_power)
lemma hyperpow_ge_zero:
- "\<And>r n. (0::'a::{ordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
+ "\<And>r n. (0::'a::{linordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
by transfer (rule zero_le_power)
lemma hyperpow_le:
- "\<And>x y n. \<lbrakk>(0::'a::{ordered_semidom} star) < x; x \<le> y\<rbrakk>
+ "\<And>x y n. \<lbrakk>(0::'a::{linordered_semidom} star) < x; x \<le> y\<rbrakk>
\<Longrightarrow> x pow n \<le> y pow n"
by transfer (rule power_mono [OF _ order_less_imp_le])
@@ -492,7 +492,7 @@
by transfer (rule power_one)
lemma hrabs_hyperpow_minus_one [simp]:
- "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,ordered_idom} star)"
+ "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,linordered_idom} star)"
by transfer (rule abs_power_minus_one)
lemma hyperpow_mult:
@@ -501,29 +501,29 @@
by transfer (rule power_mult_distrib)
lemma hyperpow_two_le [simp]:
- "(0::'a::{monoid_mult,ordered_ring_strict} star) \<le> r pow (1 + 1)"
+ "(0::'a::{monoid_mult,linordered_ring_strict} star) \<le> r pow (1 + 1)"
by (auto simp add: hyperpow_two zero_le_mult_iff)
lemma hrabs_hyperpow_two [simp]:
"abs(x pow (1 + 1)) =
- (x::'a::{monoid_mult,ordered_ring_strict} star) pow (1 + 1)"
+ (x::'a::{monoid_mult,linordered_ring_strict} star) pow (1 + 1)"
by (simp only: abs_of_nonneg hyperpow_two_le)
lemma hyperpow_two_hrabs [simp]:
- "abs(x::'a::{ordered_idom} star) pow (1 + 1) = x pow (1 + 1)"
+ "abs(x::'a::{linordered_idom} star) pow (1 + 1) = x pow (1 + 1)"
by (simp add: hyperpow_hrabs)
text{*The precondition could be weakened to @{term "0\<le>x"}*}
lemma hypreal_mult_less_mono:
"[| u<v; x<y; (0::hypreal) < v; 0 < x |] ==> u*x < v* y"
- by (simp add: Ring_and_Field.mult_strict_mono order_less_imp_le)
+ by (simp add: mult_strict_mono order_less_imp_le)
lemma hyperpow_two_gt_one:
- "\<And>r::'a::{ordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
+ "\<And>r::'a::{linordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
by transfer (simp add: power_gt1 del: power_Suc)
lemma hyperpow_two_ge_one:
- "\<And>r::'a::{ordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
+ "\<And>r::'a::{linordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
by transfer (simp add: one_le_power del: power_Suc)
lemma two_hyperpow_ge_one [simp]: "(1::hypreal) \<le> 2 pow n"
--- a/src/HOL/NSA/HyperNat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NSA/HyperNat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -386,39 +386,39 @@
by transfer (rule of_nat_mult)
lemma of_hypnat_less_iff [simp]:
- "\<And>m n. (of_hypnat m < (of_hypnat n::'a::ordered_semidom star)) = (m < n)"
+ "\<And>m n. (of_hypnat m < (of_hypnat n::'a::linordered_semidom star)) = (m < n)"
by transfer (rule of_nat_less_iff)
lemma of_hypnat_0_less_iff [simp]:
- "\<And>n. (0 < (of_hypnat n::'a::ordered_semidom star)) = (0 < n)"
+ "\<And>n. (0 < (of_hypnat n::'a::linordered_semidom star)) = (0 < n)"
by transfer (rule of_nat_0_less_iff)
lemma of_hypnat_less_0_iff [simp]:
- "\<And>m. \<not> (of_hypnat m::'a::ordered_semidom star) < 0"
+ "\<And>m. \<not> (of_hypnat m::'a::linordered_semidom star) < 0"
by transfer (rule of_nat_less_0_iff)
lemma of_hypnat_le_iff [simp]:
- "\<And>m n. (of_hypnat m \<le> (of_hypnat n::'a::ordered_semidom star)) = (m \<le> n)"
+ "\<And>m n. (of_hypnat m \<le> (of_hypnat n::'a::linordered_semidom star)) = (m \<le> n)"
by transfer (rule of_nat_le_iff)
lemma of_hypnat_0_le_iff [simp]:
- "\<And>n. 0 \<le> (of_hypnat n::'a::ordered_semidom star)"
+ "\<And>n. 0 \<le> (of_hypnat n::'a::linordered_semidom star)"
by transfer (rule of_nat_0_le_iff)
lemma of_hypnat_le_0_iff [simp]:
- "\<And>m. ((of_hypnat m::'a::ordered_semidom star) \<le> 0) = (m = 0)"
+ "\<And>m. ((of_hypnat m::'a::linordered_semidom star) \<le> 0) = (m = 0)"
by transfer (rule of_nat_le_0_iff)
lemma of_hypnat_eq_iff [simp]:
- "\<And>m n. (of_hypnat m = (of_hypnat n::'a::ordered_semidom star)) = (m = n)"
+ "\<And>m n. (of_hypnat m = (of_hypnat n::'a::linordered_semidom star)) = (m = n)"
by transfer (rule of_nat_eq_iff)
lemma of_hypnat_eq_0_iff [simp]:
- "\<And>m. ((of_hypnat m::'a::ordered_semidom star) = 0) = (m = 0)"
+ "\<And>m. ((of_hypnat m::'a::linordered_semidom star) = 0) = (m = 0)"
by transfer (rule of_nat_eq_0_iff)
lemma HNatInfinite_of_hypnat_gt_zero:
- "N \<in> HNatInfinite \<Longrightarrow> (0::'a::ordered_semidom star) < of_hypnat N"
+ "N \<in> HNatInfinite \<Longrightarrow> (0::'a::linordered_semidom star) < of_hypnat N"
by (rule ccontr, simp add: linorder_not_less)
end
--- a/src/HOL/NSA/NSComplex.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NSA/NSComplex.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: NSComplex.thy
- ID: $Id$
Author: Jacques D. Fleuriot
Copyright: 2001 University of Edinburgh
Conversion to Isar and new proofs by Lawrence C Paulson, 2003/4
@@ -161,7 +160,7 @@
lemma hcomplex_add_minus_eq_minus:
"x + y = (0::hcomplex) ==> x = -y"
-apply (drule OrderedGroup.minus_unique)
+apply (drule minus_unique)
apply (simp add: minus_equation_iff [of x y])
done
@@ -196,7 +195,7 @@
lemma hcomplex_diff_eq_eq [simp]: "((x::hcomplex) - y = z) = (x = z + y)"
(* TODO: delete *)
-by (rule OrderedGroup.diff_eq_eq)
+by (rule diff_eq_eq)
subsection{*Embedding Properties for @{term hcomplex_of_hypreal} Map*}
--- a/src/HOL/NSA/StarDef.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NSA/StarDef.thy Fri Feb 19 15:21:57 2010 +0000
@@ -530,7 +530,7 @@
end
-instance star :: (Ring_and_Field.dvd) Ring_and_Field.dvd ..
+instance star :: (Rings.dvd) Rings.dvd ..
instantiation star :: (Divides.div) Divides.div
begin
@@ -719,7 +719,7 @@
apply (transfer, erule (1) order_antisym)
done
-instantiation star :: (lower_semilattice) lower_semilattice
+instantiation star :: (semilattice_inf) semilattice_inf
begin
definition
@@ -730,7 +730,7 @@
end
-instantiation star :: (upper_semilattice) upper_semilattice
+instantiation star :: (semilattice_sup) semilattice_sup
begin
definition
@@ -833,28 +833,23 @@
apply (transfer, rule diff_minus)
done
-instance star :: (pordered_ab_semigroup_add) pordered_ab_semigroup_add
+instance star :: (ordered_ab_semigroup_add) ordered_ab_semigroup_add
by (intro_classes, transfer, rule add_left_mono)
-instance star :: (pordered_cancel_ab_semigroup_add) pordered_cancel_ab_semigroup_add ..
+instance star :: (ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..
-instance star :: (pordered_ab_semigroup_add_imp_le) pordered_ab_semigroup_add_imp_le
+instance star :: (ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
by (intro_classes, transfer, rule add_le_imp_le_left)
-instance star :: (pordered_comm_monoid_add) pordered_comm_monoid_add ..
-instance star :: (pordered_ab_group_add) pordered_ab_group_add ..
+instance star :: (ordered_comm_monoid_add) ordered_comm_monoid_add ..
+instance star :: (ordered_ab_group_add) ordered_ab_group_add ..
-instance star :: (pordered_ab_group_add_abs) pordered_ab_group_add_abs
+instance star :: (ordered_ab_group_add_abs) ordered_ab_group_add_abs
by intro_classes (transfer,
simp add: abs_ge_self abs_leI abs_triangle_ineq)+
-instance star :: (ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..
-instance star :: (lordered_ab_group_add_meet) lordered_ab_group_add_meet ..
-instance star :: (lordered_ab_group_add_meet) lordered_ab_group_add_meet ..
-instance star :: (lordered_ab_group_add) lordered_ab_group_add ..
+instance star :: (linordered_cancel_ab_semigroup_add) linordered_cancel_ab_semigroup_add ..
-instance star :: (lordered_ab_group_add_abs) lordered_ab_group_add_abs
-by (intro_classes, transfer, rule abs_lattice)
subsection {* Ring and field classes *}
@@ -898,6 +893,7 @@
apply (intro_classes)
apply (transfer, erule left_inverse)
apply (transfer, erule right_inverse)
+apply (transfer, fact divide_inverse)
done
instance star :: (field) field
@@ -909,32 +905,31 @@
instance star :: (division_by_zero) division_by_zero
by (intro_classes, transfer, rule inverse_zero)
-instance star :: (pordered_semiring) pordered_semiring
+instance star :: (ordered_semiring) ordered_semiring
apply (intro_classes)
apply (transfer, erule (1) mult_left_mono)
apply (transfer, erule (1) mult_right_mono)
done
-instance star :: (pordered_cancel_semiring) pordered_cancel_semiring ..
+instance star :: (ordered_cancel_semiring) ordered_cancel_semiring ..
-instance star :: (ordered_semiring_strict) ordered_semiring_strict
+instance star :: (linordered_semiring_strict) linordered_semiring_strict
apply (intro_classes)
apply (transfer, erule (1) mult_strict_left_mono)
apply (transfer, erule (1) mult_strict_right_mono)
done
-instance star :: (pordered_comm_semiring) pordered_comm_semiring
+instance star :: (ordered_comm_semiring) ordered_comm_semiring
by (intro_classes, transfer, rule mult_mono1_class.mult_mono1)
-instance star :: (pordered_cancel_comm_semiring) pordered_cancel_comm_semiring ..
-
-instance star :: (ordered_comm_semiring_strict) ordered_comm_semiring_strict
-by (intro_classes, transfer, rule ordered_comm_semiring_strict_class.mult_strict_left_mono_comm)
+instance star :: (ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..
-instance star :: (pordered_ring) pordered_ring ..
-instance star :: (pordered_ring_abs) pordered_ring_abs
+instance star :: (linordered_comm_semiring_strict) linordered_comm_semiring_strict
+by (intro_classes, transfer, rule mult_strict_left_mono_comm)
+
+instance star :: (ordered_ring) ordered_ring ..
+instance star :: (ordered_ring_abs) ordered_ring_abs
by intro_classes (transfer, rule abs_eq_mult)
-instance star :: (lordered_ring) lordered_ring ..
instance star :: (abs_if) abs_if
by (intro_classes, transfer, rule abs_if)
@@ -942,14 +937,14 @@
instance star :: (sgn_if) sgn_if
by (intro_classes, transfer, rule sgn_if)
-instance star :: (ordered_ring_strict) ordered_ring_strict ..
-instance star :: (pordered_comm_ring) pordered_comm_ring ..
+instance star :: (linordered_ring_strict) linordered_ring_strict ..
+instance star :: (ordered_comm_ring) ordered_comm_ring ..
-instance star :: (ordered_semidom) ordered_semidom
+instance star :: (linordered_semidom) linordered_semidom
by (intro_classes, transfer, rule zero_less_one)
-instance star :: (ordered_idom) ordered_idom ..
-instance star :: (ordered_field) ordered_field ..
+instance star :: (linordered_idom) linordered_idom ..
+instance star :: (linordered_field) linordered_field ..
subsection {* Power *}
--- a/src/HOL/NanoJava/Example.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NanoJava/Example.thy Fri Feb 19 15:21:57 2010 +0000
@@ -50,11 +50,14 @@
consts suc :: mname
add :: mname
consts any :: vname
-syntax dummy:: expr ("<>")
- one :: expr
-translations
- "<>" == "LAcc any"
- "one" == "{Nat}new Nat..suc(<>)"
+
+abbreviation
+ dummy :: expr ("<>")
+ where "<> == LAcc any"
+
+abbreviation
+ one :: expr
+ where "one == {Nat}new Nat..suc(<>)"
text {* The following properties could be derived from a more complete
program model, which we leave out for laziness. *}
--- a/src/HOL/NanoJava/TypeRel.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NanoJava/TypeRel.thy Fri Feb 19 15:21:57 2010 +0000
@@ -11,16 +11,16 @@
consts
subcls1 :: "(cname \<times> cname) set" --{* subclass *}
-syntax (xsymbols)
- subcls1 :: "[cname, cname] => bool" ("_ \<prec>C1 _" [71,71] 70)
- subcls :: "[cname, cname] => bool" ("_ \<preceq>C _" [71,71] 70)
-syntax
- subcls1 :: "[cname, cname] => bool" ("_ <=C1 _" [71,71] 70)
- subcls :: "[cname, cname] => bool" ("_ <=C _" [71,71] 70)
+abbreviation
+ subcls1_syntax :: "[cname, cname] => bool" ("_ <=C1 _" [71,71] 70)
+ where "C <=C1 D == (C,D) \<in> subcls1"
+abbreviation
+ subcls_syntax :: "[cname, cname] => bool" ("_ <=C _" [71,71] 70)
+ where "C <=C D == (C,D) \<in> subcls1^*"
-translations
- "C \<prec>C1 D" == "(C,D) \<in> subcls1"
- "C \<preceq>C D" == "(C,D) \<in> subcls1^*"
+notation (xsymbols)
+ subcls1_syntax ("_ \<prec>C1 _" [71,71] 70) and
+ subcls_syntax ("_ \<preceq>C _" [71,71] 70)
consts
method :: "cname => (mname \<rightharpoonup> methd)"
--- a/src/HOL/Nat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -8,7 +8,7 @@
header {* Natural numbers *}
theory Nat
-imports Inductive Product_Type Ring_and_Field
+imports Inductive Typedef Fun Fields
uses
"~~/src/Tools/rat.ML"
"~~/src/Provers/Arith/cancel_sums.ML"
@@ -176,6 +176,8 @@
end
+hide (open) fact add_0 add_0_right diff_0
+
instantiation nat :: comm_semiring_1_cancel
begin
@@ -730,7 +732,7 @@
apply (induct n)
apply (simp_all add: order_le_less)
apply (blast elim!: less_SucE
- intro!: add_0_right [symmetric] add_Suc_right [symmetric])
+ intro!: Nat.add_0_right [symmetric] add_Suc_right [symmetric])
done
text {* strict, in 1st argument; proof is by induction on @{text "k > 0"} *}
@@ -741,7 +743,7 @@
done
text{*The naturals form an ordered @{text comm_semiring_1_cancel}*}
-instance nat :: ordered_semidom
+instance nat :: linordered_semidom
proof
fix i j k :: nat
show "0 < (1::nat)" by simp
@@ -1289,7 +1291,7 @@
end
-context ordered_semidom
+context linordered_semidom
begin
lemma zero_le_imp_of_nat: "0 \<le> of_nat m"
@@ -1316,7 +1318,7 @@
lemma of_nat_le_iff [simp]: "of_nat m \<le> of_nat n \<longleftrightarrow> m \<le> n"
by (simp add: not_less [symmetric] linorder_not_less [symmetric])
-text{*Every @{text ordered_semidom} has characteristic zero.*}
+text{*Every @{text linordered_semidom} has characteristic zero.*}
subclass semiring_char_0
proof qed (simp add: eq_iff order_eq_iff)
@@ -1345,7 +1347,7 @@
end
-context ordered_idom
+context linordered_idom
begin
lemma abs_of_nat [simp]: "\<bar>of_nat n\<bar> = of_nat n"
@@ -1354,7 +1356,7 @@
end
lemma of_nat_id [simp]: "of_nat n = n"
- by (induct n) (auto simp add: One_nat_def)
+ by (induct n) simp_all
lemma of_nat_eq_id [simp]: "of_nat = id"
by (auto simp add: expand_fun_eq)
@@ -1489,6 +1491,8 @@
lemma diff_diff_eq: "[| k \<le> m; k \<le> (n::nat) |] ==> ((m-k) - (n-k)) = (m-n)"
by (simp split add: nat_diff_split)
+hide (open) fact diff_diff_eq
+
lemma eq_diff_iff: "[| k \<le> m; k \<le> (n::nat) |] ==> (m-k = n-k) = (m=n)"
by (auto split add: nat_diff_split)
@@ -1615,7 +1619,7 @@
lemma dvd_antisym: "[| m dvd n; n dvd m |] ==> m = (n::nat)"
unfolding dvd_def
- by (force dest: mult_eq_self_implies_10 simp add: mult_assoc mult_eq_1_iff)
+ by (force dest: mult_eq_self_implies_10 simp add: mult_assoc)
text {* @{term "op dvd"} is a partial order *}
--- a/src/HOL/Nat_Numeral.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nat_Numeral.thy Fri Feb 19 15:21:57 2010 +0000
@@ -64,7 +64,7 @@
lemma power_even_eq:
"a ^ (2*n) = (a ^ n) ^ 2"
- by (subst OrderedGroup.mult_commute) (simp add: power_mult)
+ by (subst mult_commute) (simp add: power_mult)
lemma power_odd_eq:
"a ^ Suc (2*n) = a * (a ^ n) ^ 2"
@@ -113,7 +113,7 @@
end
-context ordered_ring_strict
+context linordered_ring_strict
begin
lemma sum_squares_ge_zero:
@@ -145,7 +145,7 @@
end
-context ordered_semidom
+context linordered_semidom
begin
lemma power2_le_imp_le:
@@ -162,7 +162,7 @@
end
-context ordered_idom
+context linordered_idom
begin
lemma zero_eq_power2 [simp]:
@@ -211,7 +211,7 @@
"0 \<le> a ^ (2*n)"
proof (induct n)
case 0
- show ?case by (simp add: zero_le_one)
+ show ?case by simp
next
case (Suc n)
have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
@@ -262,7 +262,7 @@
by (simp add: neg_def)
lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
-by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
+by (simp add: neg_def del: of_nat_Suc)
lemmas neg_eq_less_0 = neg_def
@@ -275,7 +275,7 @@
by (simp add: One_int_def neg_def)
lemma not_neg_1: "~ neg 1"
-by (simp add: neg_def linorder_not_less zero_le_one)
+by (simp add: neg_def linorder_not_less)
lemma neg_nat: "neg z ==> nat z = 0"
by (simp add: neg_def order_less_imp_le)
@@ -310,7 +310,7 @@
subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
-declare nat_0 [simp] nat_1 [simp]
+declare nat_1 [simp]
lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
by (simp add: nat_number_of_def)
@@ -319,10 +319,10 @@
by (simp add: nat_number_of_def)
lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
-by (simp add: nat_1 nat_number_of_def)
+by (simp add: nat_number_of_def)
lemma numeral_1_eq_Suc_0 [code_post]: "Numeral1 = Suc 0"
-by (simp add: nat_numeral_1_eq_1)
+by (simp only: nat_numeral_1_eq_1 One_nat_def)
subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
@@ -469,7 +469,7 @@
subsubsection{*Nat *}
lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
-by (simp add: numerals)
+by simp
(*Expresses a natural number constant as the Suc of another one.
NOT suitable for rewriting because n recurs in the condition.*)
@@ -478,10 +478,10 @@
subsubsection{*Arith *}
lemma Suc_eq_plus1: "Suc n = n + 1"
-by (simp add: numerals)
+ unfolding One_nat_def by simp
lemma Suc_eq_plus1_left: "Suc n = 1 + n"
-by (simp add: numerals)
+ unfolding One_nat_def by simp
(* These two can be useful when m = number_of... *)
@@ -563,13 +563,13 @@
"(number_of v <= Suc n) =
(let pv = number_of (Int.pred v) in
if neg pv then True else nat pv <= n)"
-by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
+by (simp add: Let_def linorder_not_less [symmetric])
lemma le_Suc_number_of [simp]:
"(Suc n <= number_of v) =
(let pv = number_of (Int.pred v) in
if neg pv then False else n <= nat pv)"
-by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
+by (simp add: Let_def linorder_not_less [symmetric])
lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
@@ -660,7 +660,7 @@
power_number_of_odd [of "number_of v", standard]
lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
- by (simp add: number_of_Pls nat_number_of_def)
+ by (simp add: nat_number_of_def)
lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
@@ -684,6 +684,9 @@
nat_number_of_Pls nat_number_of_Min
nat_number_of_Bit0 nat_number_of_Bit1
+lemmas nat_number' =
+ nat_number_of_Bit0 nat_number_of_Bit1
+
lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
by (fact Let_def)
@@ -736,7 +739,7 @@
text{*Where K above is a literal*}
lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
-by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
+by (simp split: nat_diff_split)
text {*Now just instantiating @{text n} to @{text "number_of v"} does
the right simplification, but with some redundant inequality
@@ -761,7 +764,7 @@
done
lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
-by (simp add: numerals split add: nat_diff_split)
+by (simp split: nat_diff_split)
subsubsection{*For @{term nat_case} and @{term nat_rec}*}
--- a/src/HOL/Nitpick.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick.thy Fri Feb 19 15:21:57 2010 +0000
@@ -13,6 +13,7 @@
("Tools/Nitpick/kodkod_sat.ML")
("Tools/Nitpick/nitpick_util.ML")
("Tools/Nitpick/nitpick_hol.ML")
+ ("Tools/Nitpick/nitpick_preproc.ML")
("Tools/Nitpick/nitpick_mono.ML")
("Tools/Nitpick/nitpick_scope.ML")
("Tools/Nitpick/nitpick_peephole.ML")
@@ -36,7 +37,6 @@
and bisim_iterator_max :: bisim_iterator
and Quot :: "'a \<Rightarrow> 'b"
and quot_normal :: "'a \<Rightarrow> 'a"
- and NonStd :: "'a \<Rightarrow> 'b"
and Tha :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
datatype ('a, 'b) pair_box = PairBox 'a 'b
@@ -44,7 +44,6 @@
typedecl unsigned_bit
typedecl signed_bit
-typedecl \<xi>
datatype 'a word = Word "('a set)"
@@ -218,25 +217,11 @@
definition of_frac :: "'a \<Rightarrow> 'b\<Colon>{inverse,ring_1}" where
"of_frac q \<equiv> of_int (num q) / of_int (denom q)"
-(* While Nitpick normally avoids to unfold definitions for locales, it
- unfortunately needs to unfold them when dealing with the following built-in
- constants. A cleaner approach would be to change "Nitpick_HOL" and
- "Nitpick_Nut" so that they handle the unexpanded overloaded constants
- directly, but this is slightly more tricky to implement. *)
-lemmas [nitpick_def] = div_int_inst.div_int div_int_inst.mod_int
- div_nat_inst.div_nat div_nat_inst.mod_nat lower_semilattice_fun_inst.inf_fun
- minus_fun_inst.minus_fun minus_int_inst.minus_int minus_nat_inst.minus_nat
- one_int_inst.one_int one_nat_inst.one_nat ord_fun_inst.less_eq_fun
- ord_int_inst.less_eq_int ord_int_inst.less_int ord_nat_inst.less_eq_nat
- ord_nat_inst.less_nat plus_int_inst.plus_int plus_nat_inst.plus_nat
- times_int_inst.times_int times_nat_inst.times_nat uminus_int_inst.uminus_int
- upper_semilattice_fun_inst.sup_fun zero_int_inst.zero_int
- zero_nat_inst.zero_nat
-
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_preproc.ML"
use "Tools/Nitpick/nitpick_mono.ML"
use "Tools/Nitpick/nitpick_scope.ML"
use "Tools/Nitpick/nitpick_peephole.ML"
@@ -252,12 +237,12 @@
setup {* Nitpick_Isar.setup *}
hide (open) const unknown is_unknown undefined_fast_The undefined_fast_Eps bisim
- bisim_iterator_max Quot quot_normal NonStd Tha PairBox FunBox Word refl' wf'
+ bisim_iterator_max Quot quot_normal Tha PairBox FunBox Word 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 unsigned_bit signed_bit \<xi> word
+hide (open) type bisim_iterator pair_box fun_box unsigned_bit signed_bit word
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 list_size_simp nat_gcd_def
--- a/src/HOL/Nitpick_Examples/Core_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Core_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Core_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's functional core.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
subsection {* Curry in a Hurry *}
--- a/src/HOL/Nitpick_Examples/Datatype_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Datatype_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Datatype_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to datatypes.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
primrec rot where
"rot Nibble0 = Nibble1" | "rot Nibble1 = Nibble2" | "rot Nibble2 = Nibble3" |
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Hotel_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,57 @@
+(* Title: HOL/Nitpick_Examples/Hotel_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2010
+
+Nitpick example based on Tobias Nipkow's hotel key card formalization.
+*)
+
+header {* Nitpick Example Based on Tobias Nipkow's Hotel Key Card
+ Formalization *}
+
+theory Hotel_Nits
+imports Main
+begin
+
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 120 s]
+
+typedecl guest
+typedecl key
+typedecl room
+
+types keycard = "key \<times> key"
+
+record state =
+ owns :: "room \<Rightarrow> guest option"
+ currk :: "room \<Rightarrow> key"
+ issued :: "key set"
+ cards :: "guest \<Rightarrow> keycard set"
+ roomk :: "room \<Rightarrow> key"
+ isin :: "room \<Rightarrow> guest set"
+ safe :: "room \<Rightarrow> bool"
+
+inductive_set reach :: "state set" where
+init:
+"inj initk \<Longrightarrow>
+ \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
+ roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
+check_in:
+"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
+ s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
+ cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
+ owns := (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
+enter_room:
+"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
+ s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
+ roomk := (roomk s)(r := k'),
+ safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} (* \<and> k' = currk s r *)
+ \<or> safe s r)\<rparr> \<in> reach" |
+exit_room:
+"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"
+
+theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
+nitpick [card room = 1, card guest = 2, card "guest option" = 3,
+ card key = 4, card state = 6, expect = genuine]
+nitpick [card room = 1, card guest = 2, expect = genuine]
+oops
+
+end
--- a/src/HOL/Nitpick_Examples/Induct_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Induct_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Induct_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to (co)inductive definitions.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
--- a/src/HOL/Nitpick_Examples/Integer_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Integer_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Integer_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to natural numbers and integers.
*)
@@ -11,7 +11,7 @@
imports Nitpick
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 1\<midarrow>6, bits = 1,2,3,4,6,8]
lemma "Suc x = x + 1"
--- a/src/HOL/Nitpick_Examples/Manual_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Manual_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Manual_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples from the Nitpick manual.
*)
@@ -13,7 +13,7 @@
chapter {* 3. First Steps *}
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1]
subsection {* 3.1. Propositional Logic *}
@@ -259,14 +259,14 @@
(if c = a then Leaf b else if c = b then Leaf a else Leaf c)" |
"swap (Branch t u) a b = Branch (swap t a b) (swap u a b)"
-lemma "\<lbrakk>a \<in> labels t; b \<in> labels t; a \<noteq> b\<rbrakk> \<Longrightarrow> labels (swap t a b) = labels t"
+lemma "{a, b} \<subseteq> labels t \<Longrightarrow> labels (swap t a b) = labels t"
nitpick
proof (induct t)
case Leaf thus ?case by simp
next
case (Branch t u) thus ?case
nitpick
- nitpick [non_std "'a bin_tree", show_consts]
+ nitpick [non_std, show_all]
oops
lemma "labels (swap t a b) =
--- a/src/HOL/Nitpick_Examples/Mini_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Mini_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Mini_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Minipick, the minimalistic version of Nitpick.
*)
--- a/src/HOL/Nitpick_Examples/Mono_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Mono_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Mono_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's monotonicity check.
*)
@@ -16,7 +16,7 @@
val defs = Nitpick_HOL.all_axioms_of @{theory} |> #1
val def_table = Nitpick_HOL.const_def_table @{context} defs
-val ext_ctxt : Nitpick_HOL.extended_context =
+val hol_ctxt : Nitpick_HOL.hol_context =
{thy = @{theory}, ctxt = @{context}, max_bisim_depth = ~1, boxes = [],
stds = [(NONE, true)], wfs = [], user_axioms = NONE, debug = false,
binary_ints = SOME false, destroy_constrs = false, specialize = false,
@@ -29,7 +29,7 @@
special_funs = Unsynchronized.ref [], unrolled_preds = Unsynchronized.ref [],
wf_cache = Unsynchronized.ref [], constr_cache = Unsynchronized.ref []}
(* term -> bool *)
-val is_mono = Nitpick_Mono.formulas_monotonic ext_ctxt @{typ 'a}
+val is_mono = Nitpick_Mono.formulas_monotonic hol_ctxt false @{typ 'a}
Nitpick_Mono.Plus [] []
fun is_const t =
let val T = fastype_of t in
--- a/src/HOL/Nitpick_Examples/Nitpick_Examples.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Nitpick_Examples.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,13 +1,13 @@
(* Title: HOL/Nitpick_Examples/Nitpick_Examples.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Nitpick examples.
*)
theory Nitpick_Examples
-imports Core_Nits Datatype_Nits Induct_Nits Integer_Nits Manual_Nits Mini_Nits
- Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits Tests_Nits
- Typedef_Nits
+imports Core_Nits Datatype_Nits Hotel_Nits Induct_Nits Integer_Nits Manual_Nits
+ Mini_Nits Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits
+ Tests_Nits Typedef_Nits
begin
end
--- a/src/HOL/Nitpick_Examples/Pattern_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Pattern_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Pattern_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's "destroy_constrs" optimization.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 14]
lemma "x = (case u of () \<Rightarrow> y)"
--- a/src/HOL/Nitpick_Examples/Record_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Record_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Record_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to records.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
record point2d =
xc :: int
--- a/src/HOL/Nitpick_Examples/Refute_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Refute_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Refute_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Refute examples adapted to Nitpick.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
lemma "P \<and> Q"
apply (rule conjI)
@@ -885,7 +885,7 @@
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]
+nitpick [card = 1\<midarrow>5, expect = none]
apply simp
done
--- a/src/HOL/Nitpick_Examples/Special_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Special_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Special_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's "specialize" optimization.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 4]
fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
--- a/src/HOL/Nitpick_Examples/Tests_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Tests_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Tests_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Nitpick tests.
*)
--- a/src/HOL/Nitpick_Examples/Typedef_Nits.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nitpick_Examples/Typedef_Nits.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Typedef_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to typedefs.
*)
@@ -11,7 +11,8 @@
imports Main Rational
begin
-nitpick_params [card = 1\<midarrow>4, timeout = 30 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
+ card = 1\<midarrow>4]
typedef three = "{0\<Colon>nat, 1, 2}"
by blast
--- a/src/HOL/Nominal/nominal_datatype.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nominal/nominal_datatype.ML Fri Feb 19 15:21:57 2010 +0000
@@ -152,7 +152,7 @@
fun projections rule =
Project_Rule.projections (ProofContext.init (Thm.theory_of_thm rule)) rule
- |> map (Drule.standard #> Rule_Cases.save rule);
+ |> map (Drule.export_without_context #> Rule_Cases.save rule);
val supp_prod = thm "supp_prod";
val fresh_prod = thm "fresh_prod";
@@ -312,7 +312,7 @@
val unfolded_perm_eq_thms =
if length descr = length new_type_names then []
- else map Drule.standard (List.drop (split_conj_thm
+ else map Drule.export_without_context (List.drop (split_conj_thm
(Goal.prove_global thy2 [] []
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
(map (fn (c as (s, T), x) =>
@@ -332,7 +332,7 @@
val perm_empty_thms = maps (fn a =>
let val permT = mk_permT (Type (a, []))
- in map Drule.standard (List.take (split_conj_thm
+ in map Drule.export_without_context (List.take (split_conj_thm
(Goal.prove_global thy2 [] []
(augment_sort thy2 [pt_class_of thy2 a]
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
@@ -364,7 +364,7 @@
val pt_inst = pt_inst_of thy2 a;
val pt2' = pt_inst RS pt2;
val pt2_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
- in List.take (map Drule.standard (split_conj_thm
+ in List.take (map Drule.export_without_context (split_conj_thm
(Goal.prove_global thy2 [] []
(augment_sort thy2 [pt_class_of thy2 a]
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
@@ -399,7 +399,7 @@
val pt3' = pt_inst RS pt3;
val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
val pt3_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
- in List.take (map Drule.standard (split_conj_thm
+ in List.take (map Drule.export_without_context (split_conj_thm
(Goal.prove_global thy2 [] []
(augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
(HOLogic.mk_Trueprop (Const ("Nominal.prm_eq",
@@ -586,7 +586,7 @@
(fn (x, (_, ("Nominal.noption", _, _))) => NONE | (x, _) => SOME x)
(perm_indnames ~~ descr);
- fun mk_perm_closed name = map (fn th => Drule.standard (th RS mp))
+ fun mk_perm_closed name = map (fn th => Drule.export_without_context (th RS mp))
(List.take (split_conj_thm (Goal.prove_global thy4 [] []
(augment_sort thy4
(pt_class_of thy4 name :: map (cp_class_of thy4 name) (remove (op =) name dt_atoms))
@@ -812,7 +812,8 @@
val rep_const = cterm_of thy
(Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
val dist =
- Drule.standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
+ Drule.export_without_context
+ (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
val (thy', defs', eqns') = fold (make_constr_def tname T T')
(constrs ~~ constrs' ~~ constr_syntax) (Sign.add_path tname thy, defs, [])
in
@@ -877,8 +878,9 @@
let
val dist_thm = Goal.prove_global thy8 [] [] t (fn _ =>
simp_tac (global_simpset_of thy8 addsimps (dist_lemma :: rep_thms)) 1)
- in dist_thm :: Drule.standard (dist_thm RS not_sym) ::
- prove_distinct_thms p (k, ts)
+ in
+ dist_thm :: Drule.export_without_context (dist_thm RS not_sym) ::
+ prove_distinct_thms p (k, ts)
end;
val distinct_thms = map2 prove_distinct_thms
@@ -1092,7 +1094,7 @@
val finite_supp_thms = map (fn atom =>
let val atomT = Type (atom, [])
- in map Drule.standard (List.take
+ in map Drule.export_without_context (List.take
(split_conj_thm (Goal.prove_global thy8 [] []
(augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
(HOLogic.mk_Trueprop
@@ -1540,7 +1542,7 @@
in
(R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
- val ths = map (fn th => Drule.standard (th RS mp)) (split_conj_thm
+ val ths = map (fn th => Drule.export_without_context (th RS mp)) (split_conj_thm
(Goal.prove_global thy11 [] []
(augment_sort thy1 pt_cp_sort
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
@@ -1572,7 +1574,7 @@
(finite $ (Const ("Nominal.supp", T --> aset) $ f)))
(rec_fns ~~ rec_fn_Ts)
in
- map (fn th => Drule.standard (th RS mp)) (split_conj_thm
+ map (fn th => Drule.export_without_context (th RS mp)) (split_conj_thm
(Goal.prove_global thy11 []
(map (augment_sort thy11 fs_cp_sort) fins)
(augment_sort thy11 fs_cp_sort
@@ -1615,7 +1617,7 @@
val y = Free ("y", U);
val y' = Free ("y'", U)
in
- Drule.standard (Goal.prove (ProofContext.init thy11) []
+ Drule.export_without_context (Goal.prove (ProofContext.init thy11) []
(map (augment_sort thy11 fs_cp_sort)
(finite_prems @
[HOLogic.mk_Trueprop (R $ x $ y),
@@ -2060,7 +2062,7 @@
((Binding.name "rec_equiv'", flat rec_equiv_thms'), []),
((Binding.name "rec_fin_supp", flat rec_fin_supp_thms), []),
((Binding.name "rec_fresh", flat rec_fresh_thms), []),
- ((Binding.name "rec_unique", map Drule.standard rec_unique_thms), []),
+ ((Binding.name "rec_unique", map Drule.export_without_context rec_unique_thms), []),
((Binding.name "recs", rec_thms), [])] ||>
Sign.parent_path ||>
map_nominal_datatypes (fold Symtab.update dt_infos);
--- a/src/HOL/Nominal/nominal_primrec.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Nominal/nominal_primrec.ML Fri Feb 19 15:21:57 2010 +0000
@@ -303,8 +303,10 @@
HOLogic.dest_eq |> fst |> strip_comb |> snd |> take_prefix is_Var |> fst;
val (pvars, ctxtvars) = List.partition
(equal HOLogic.boolT o body_type o snd)
- (subtract (op =) (map dest_Var fvars) (fold_rev Term.add_vars (map Logic.strip_assums_concl
- (prems_of (hd rec_rewrites))) []));
+ (subtract (op =)
+ (Term.add_vars (concl_of (hd rec_rewrites)) [])
+ (fold_rev (Term.add_vars o Logic.strip_assums_concl)
+ (prems_of (hd rec_rewrites)) []));
val cfs = defs' |> hd |> snd |> strip_comb |> snd |>
curry (List.take o swap) (length fvars) |> map cert;
val invs' = (case invs of
--- a/src/HOL/NthRoot.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/NthRoot.thy Fri Feb 19 15:21:57 2010 +0000
@@ -566,7 +566,7 @@
done
lemma lemma_real_divide_sqrt_less: "0 < u ==> u / sqrt 2 < u"
-by (simp add: divide_less_eq mult_compare_simps)
+by (simp add: divide_less_eq)
lemma four_x_squared:
fixes x::real
--- a/src/HOL/Number_Theory/UniqueFactorization.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Number_Theory/UniqueFactorization.thy Fri Feb 19 15:21:57 2010 +0000
@@ -76,7 +76,7 @@
("(3PROD _:#_. _)" [0, 51, 10] 10)
translations
- "PROD i :# A. b" == "msetprod (%i. b) A"
+ "PROD i :# A. b" == "CONST msetprod (%i. b) A"
lemma msetprod_Un: "msetprod f (A+B) = msetprod f A * msetprod f B"
apply (simp add: msetprod_def power_add)
--- a/src/HOL/Old_Number_Theory/WilsonBij.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Old_Number_Theory/WilsonBij.thy Fri Feb 19 15:21:57 2010 +0000
@@ -74,9 +74,9 @@
lemma aux: "[a * (p - 1) = 1] (mod p) = [a = p - 1] (mod p)"
-- {* same as @{text WilsonRuss} *}
apply (unfold zcong_def)
- apply (simp add: OrderedGroup.diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
+ apply (simp add: diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
- apply (simp add: mult_commute)
+ apply (simp add: algebra_simps)
apply (subst dvd_minus_iff)
apply (subst zdvd_reduce)
apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
--- a/src/HOL/Old_Number_Theory/WilsonRuss.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Old_Number_Theory/WilsonRuss.thy Fri Feb 19 15:21:57 2010 +0000
@@ -82,9 +82,9 @@
lemma inv_not_p_minus_1_aux:
"[a * (p - 1) = 1] (mod p) = [a = p - 1] (mod p)"
apply (unfold zcong_def)
- apply (simp add: OrderedGroup.diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
+ apply (simp add: diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
- apply (simp add: mult_commute)
+ apply (simp add: algebra_simps)
apply (subst dvd_minus_iff)
apply (subst zdvd_reduce)
apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
--- a/src/HOL/OrderedGroup.thy Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1446 +0,0 @@
-(* Title: HOL/OrderedGroup.thy
- Author: Gertrud Bauer, Steven Obua, Lawrence C Paulson, Markus Wenzel, Jeremy Avigad
-*)
-
-header {* Ordered Groups *}
-
-theory OrderedGroup
-imports Lattices
-uses "~~/src/Provers/Arith/abel_cancel.ML"
-begin
-
-text {*
- The theory of partially ordered groups is taken from the books:
- \begin{itemize}
- \item \emph{Lattice Theory} by Garret Birkhoff, American Mathematical Society 1979
- \item \emph{Partially Ordered Algebraic Systems}, Pergamon Press 1963
- \end{itemize}
- Most of the used notions can also be looked up in
- \begin{itemize}
- \item \url{http://www.mathworld.com} by Eric Weisstein et. al.
- \item \emph{Algebra I} by van der Waerden, Springer.
- \end{itemize}
-*}
-
-ML {*
-structure Algebra_Simps = Named_Thms(
- val name = "algebra_simps"
- val description = "algebra simplification rules"
-)
-*}
-
-setup Algebra_Simps.setup
-
-text{* The rewrites accumulated in @{text algebra_simps} deal with the
-classical algebraic structures of groups, rings and family. They simplify
-terms by multiplying everything out (in case of a ring) and bringing sums and
-products into a canonical form (by ordered rewriting). As a result it decides
-group and ring equalities but also helps with inequalities.
-
-Of course it also works for fields, but it knows nothing about multiplicative
-inverses or division. This is catered for by @{text field_simps}. *}
-
-subsection {* Semigroups and Monoids *}
-
-class semigroup_add = plus +
- assumes add_assoc [algebra_simps]: "(a + b) + c = a + (b + c)"
-
-sublocale semigroup_add < plus!: semigroup plus proof
-qed (fact add_assoc)
-
-class ab_semigroup_add = semigroup_add +
- assumes add_commute [algebra_simps]: "a + b = b + a"
-
-sublocale ab_semigroup_add < plus!: abel_semigroup plus proof
-qed (fact add_commute)
-
-context ab_semigroup_add
-begin
-
-lemmas add_left_commute [algebra_simps] = plus.left_commute
-
-theorems add_ac = add_assoc add_commute add_left_commute
-
-end
-
-theorems add_ac = add_assoc add_commute add_left_commute
-
-class semigroup_mult = times +
- assumes mult_assoc [algebra_simps]: "(a * b) * c = a * (b * c)"
-
-sublocale semigroup_mult < times!: semigroup times proof
-qed (fact mult_assoc)
-
-class ab_semigroup_mult = semigroup_mult +
- assumes mult_commute [algebra_simps]: "a * b = b * a"
-
-sublocale ab_semigroup_mult < times!: abel_semigroup times proof
-qed (fact mult_commute)
-
-context ab_semigroup_mult
-begin
-
-lemmas mult_left_commute [algebra_simps] = times.left_commute
-
-theorems mult_ac = mult_assoc mult_commute mult_left_commute
-
-end
-
-theorems mult_ac = mult_assoc mult_commute mult_left_commute
-
-class ab_semigroup_idem_mult = ab_semigroup_mult +
- assumes mult_idem: "x * x = x"
-
-sublocale ab_semigroup_idem_mult < times!: semilattice times proof
-qed (fact mult_idem)
-
-context ab_semigroup_idem_mult
-begin
-
-lemmas mult_left_idem = times.left_idem
-
-end
-
-class monoid_add = zero + semigroup_add +
- assumes add_0_left [simp]: "0 + a = a"
- and add_0_right [simp]: "a + 0 = a"
-
-lemma zero_reorient: "0 = x \<longleftrightarrow> x = 0"
-by (rule eq_commute)
-
-class comm_monoid_add = zero + ab_semigroup_add +
- assumes add_0: "0 + a = a"
-begin
-
-subclass monoid_add
- proof qed (insert add_0, simp_all add: add_commute)
-
-end
-
-class monoid_mult = one + semigroup_mult +
- assumes mult_1_left [simp]: "1 * a = a"
- assumes mult_1_right [simp]: "a * 1 = a"
-
-lemma one_reorient: "1 = x \<longleftrightarrow> x = 1"
-by (rule eq_commute)
-
-class comm_monoid_mult = one + ab_semigroup_mult +
- assumes mult_1: "1 * a = a"
-begin
-
-subclass monoid_mult
- proof qed (insert mult_1, simp_all add: mult_commute)
-
-end
-
-class cancel_semigroup_add = semigroup_add +
- assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
- assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"
-begin
-
-lemma add_left_cancel [simp]:
- "a + b = a + c \<longleftrightarrow> b = c"
-by (blast dest: add_left_imp_eq)
-
-lemma add_right_cancel [simp]:
- "b + a = c + a \<longleftrightarrow> b = c"
-by (blast dest: add_right_imp_eq)
-
-end
-
-class cancel_ab_semigroup_add = ab_semigroup_add +
- assumes add_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
-begin
-
-subclass cancel_semigroup_add
-proof
- fix a b c :: 'a
- assume "a + b = a + c"
- then show "b = c" by (rule add_imp_eq)
-next
- fix a b c :: 'a
- assume "b + a = c + a"
- then have "a + b = a + c" by (simp only: add_commute)
- then show "b = c" by (rule add_imp_eq)
-qed
-
-end
-
-class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add
-
-
-subsection {* Groups *}
-
-class group_add = minus + uminus + monoid_add +
- assumes left_minus [simp]: "- a + a = 0"
- assumes diff_minus: "a - b = a + (- b)"
-begin
-
-lemma minus_unique:
- assumes "a + b = 0" shows "- a = b"
-proof -
- have "- a = - a + (a + b)" using assms by simp
- also have "\<dots> = b" by (simp add: add_assoc [symmetric])
- finally show ?thesis .
-qed
-
-lemmas equals_zero_I = minus_unique (* legacy name *)
-
-lemma minus_zero [simp]: "- 0 = 0"
-proof -
- have "0 + 0 = 0" by (rule add_0_right)
- thus "- 0 = 0" by (rule minus_unique)
-qed
-
-lemma minus_minus [simp]: "- (- a) = a"
-proof -
- have "- a + a = 0" by (rule left_minus)
- thus "- (- a) = a" by (rule minus_unique)
-qed
-
-lemma right_minus [simp]: "a + - a = 0"
-proof -
- have "a + - a = - (- a) + - a" by simp
- also have "\<dots> = 0" by (rule left_minus)
- finally show ?thesis .
-qed
-
-lemma minus_add_cancel: "- a + (a + b) = b"
-by (simp add: add_assoc [symmetric])
-
-lemma add_minus_cancel: "a + (- a + b) = b"
-by (simp add: add_assoc [symmetric])
-
-lemma minus_add: "- (a + b) = - b + - a"
-proof -
- have "(a + b) + (- b + - a) = 0"
- by (simp add: add_assoc add_minus_cancel)
- thus "- (a + b) = - b + - a"
- by (rule minus_unique)
-qed
-
-lemma right_minus_eq: "a - b = 0 \<longleftrightarrow> a = b"
-proof
- assume "a - b = 0"
- have "a = (a - b) + b" by (simp add:diff_minus add_assoc)
- also have "\<dots> = b" using `a - b = 0` by simp
- finally show "a = b" .
-next
- assume "a = b" thus "a - b = 0" by (simp add: diff_minus)
-qed
-
-lemma diff_self [simp]: "a - a = 0"
-by (simp add: diff_minus)
-
-lemma diff_0 [simp]: "0 - a = - a"
-by (simp add: diff_minus)
-
-lemma diff_0_right [simp]: "a - 0 = a"
-by (simp add: diff_minus)
-
-lemma diff_minus_eq_add [simp]: "a - - b = a + b"
-by (simp add: diff_minus)
-
-lemma neg_equal_iff_equal [simp]:
- "- a = - b \<longleftrightarrow> a = b"
-proof
- assume "- a = - b"
- hence "- (- a) = - (- b)" by simp
- thus "a = b" by simp
-next
- assume "a = b"
- thus "- a = - b" by simp
-qed
-
-lemma neg_equal_0_iff_equal [simp]:
- "- a = 0 \<longleftrightarrow> a = 0"
-by (subst neg_equal_iff_equal [symmetric], simp)
-
-lemma neg_0_equal_iff_equal [simp]:
- "0 = - a \<longleftrightarrow> 0 = a"
-by (subst neg_equal_iff_equal [symmetric], simp)
-
-text{*The next two equations can make the simplifier loop!*}
-
-lemma equation_minus_iff:
- "a = - b \<longleftrightarrow> b = - a"
-proof -
- have "- (- a) = - b \<longleftrightarrow> - a = b" by (rule neg_equal_iff_equal)
- thus ?thesis by (simp add: eq_commute)
-qed
-
-lemma minus_equation_iff:
- "- a = b \<longleftrightarrow> - b = a"
-proof -
- have "- a = - (- b) \<longleftrightarrow> a = -b" by (rule neg_equal_iff_equal)
- thus ?thesis by (simp add: eq_commute)
-qed
-
-lemma diff_add_cancel: "a - b + b = a"
-by (simp add: diff_minus add_assoc)
-
-lemma add_diff_cancel: "a + b - b = a"
-by (simp add: diff_minus add_assoc)
-
-declare diff_minus[symmetric, algebra_simps]
-
-lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
-proof
- assume "a = - b" then show "a + b = 0" by simp
-next
- assume "a + b = 0"
- moreover have "a + (b + - b) = (a + b) + - b"
- by (simp only: add_assoc)
- ultimately show "a = - b" by simp
-qed
-
-end
-
-class ab_group_add = minus + uminus + comm_monoid_add +
- assumes ab_left_minus: "- a + a = 0"
- assumes ab_diff_minus: "a - b = a + (- b)"
-begin
-
-subclass group_add
- proof qed (simp_all add: ab_left_minus ab_diff_minus)
-
-subclass cancel_comm_monoid_add
-proof
- fix a b c :: 'a
- assume "a + b = a + c"
- then have "- a + a + b = - a + a + c"
- unfolding add_assoc by simp
- then show "b = c" by simp
-qed
-
-lemma uminus_add_conv_diff[algebra_simps]:
- "- a + b = b - a"
-by (simp add:diff_minus add_commute)
-
-lemma minus_add_distrib [simp]:
- "- (a + b) = - a + - b"
-by (rule minus_unique) (simp add: add_ac)
-
-lemma minus_diff_eq [simp]:
- "- (a - b) = b - a"
-by (simp add: diff_minus add_commute)
-
-lemma add_diff_eq[algebra_simps]: "a + (b - c) = (a + b) - c"
-by (simp add: diff_minus add_ac)
-
-lemma diff_add_eq[algebra_simps]: "(a - b) + c = (a + c) - b"
-by (simp add: diff_minus add_ac)
-
-lemma diff_eq_eq[algebra_simps]: "a - b = c \<longleftrightarrow> a = c + b"
-by (auto simp add: diff_minus add_assoc)
-
-lemma eq_diff_eq[algebra_simps]: "a = c - b \<longleftrightarrow> a + b = c"
-by (auto simp add: diff_minus add_assoc)
-
-lemma diff_diff_eq[algebra_simps]: "(a - b) - c = a - (b + c)"
-by (simp add: diff_minus add_ac)
-
-lemma diff_diff_eq2[algebra_simps]: "a - (b - c) = (a + c) - b"
-by (simp add: diff_minus add_ac)
-
-lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
-by (simp add: algebra_simps)
-
-lemma diff_eq_0_iff_eq [simp, noatp]: "a - b = 0 \<longleftrightarrow> a = b"
-by (simp add: algebra_simps)
-
-end
-
-subsection {* (Partially) Ordered Groups *}
-
-class pordered_ab_semigroup_add = order + ab_semigroup_add +
- assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
-begin
-
-lemma add_right_mono:
- "a \<le> b \<Longrightarrow> a + c \<le> b + c"
-by (simp add: add_commute [of _ c] add_left_mono)
-
-text {* non-strict, in both arguments *}
-lemma add_mono:
- "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
- apply (erule add_right_mono [THEN order_trans])
- apply (simp add: add_commute add_left_mono)
- done
-
-end
-
-class pordered_cancel_ab_semigroup_add =
- pordered_ab_semigroup_add + cancel_ab_semigroup_add
-begin
-
-lemma add_strict_left_mono:
- "a < b \<Longrightarrow> c + a < c + b"
-by (auto simp add: less_le add_left_mono)
-
-lemma add_strict_right_mono:
- "a < b \<Longrightarrow> a + c < b + c"
-by (simp add: add_commute [of _ c] add_strict_left_mono)
-
-text{*Strict monotonicity in both arguments*}
-lemma add_strict_mono:
- "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
-apply (erule add_strict_right_mono [THEN less_trans])
-apply (erule add_strict_left_mono)
-done
-
-lemma add_less_le_mono:
- "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
-apply (erule add_strict_right_mono [THEN less_le_trans])
-apply (erule add_left_mono)
-done
-
-lemma add_le_less_mono:
- "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
-apply (erule add_right_mono [THEN le_less_trans])
-apply (erule add_strict_left_mono)
-done
-
-end
-
-class pordered_ab_semigroup_add_imp_le =
- pordered_cancel_ab_semigroup_add +
- assumes add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
-begin
-
-lemma add_less_imp_less_left:
- assumes less: "c + a < c + b" shows "a < b"
-proof -
- from less have le: "c + a <= c + b" by (simp add: order_le_less)
- have "a <= b"
- apply (insert le)
- apply (drule add_le_imp_le_left)
- by (insert le, drule add_le_imp_le_left, assumption)
- moreover have "a \<noteq> b"
- proof (rule ccontr)
- assume "~(a \<noteq> b)"
- then have "a = b" by simp
- then have "c + a = c + b" by simp
- with less show "False"by simp
- qed
- ultimately show "a < b" by (simp add: order_le_less)
-qed
-
-lemma add_less_imp_less_right:
- "a + c < b + c \<Longrightarrow> a < b"
-apply (rule add_less_imp_less_left [of c])
-apply (simp add: add_commute)
-done
-
-lemma add_less_cancel_left [simp]:
- "c + a < c + b \<longleftrightarrow> a < b"
-by (blast intro: add_less_imp_less_left add_strict_left_mono)
-
-lemma add_less_cancel_right [simp]:
- "a + c < b + c \<longleftrightarrow> a < b"
-by (blast intro: add_less_imp_less_right add_strict_right_mono)
-
-lemma add_le_cancel_left [simp]:
- "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
-by (auto, drule add_le_imp_le_left, simp_all add: add_left_mono)
-
-lemma add_le_cancel_right [simp]:
- "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
-by (simp add: add_commute [of a c] add_commute [of b c])
-
-lemma add_le_imp_le_right:
- "a + c \<le> b + c \<Longrightarrow> a \<le> b"
-by simp
-
-lemma max_add_distrib_left:
- "max x y + z = max (x + z) (y + z)"
- unfolding max_def by auto
-
-lemma min_add_distrib_left:
- "min x y + z = min (x + z) (y + z)"
- unfolding min_def by auto
-
-end
-
-subsection {* Support for reasoning about signs *}
-
-class pordered_comm_monoid_add =
- pordered_cancel_ab_semigroup_add + comm_monoid_add
-begin
-
-lemma add_pos_nonneg:
- assumes "0 < a" and "0 \<le> b" shows "0 < a + b"
-proof -
- have "0 + 0 < a + b"
- using assms by (rule add_less_le_mono)
- then show ?thesis by simp
-qed
-
-lemma add_pos_pos:
- assumes "0 < a" and "0 < b" shows "0 < a + b"
-by (rule add_pos_nonneg) (insert assms, auto)
-
-lemma add_nonneg_pos:
- assumes "0 \<le> a" and "0 < b" shows "0 < a + b"
-proof -
- have "0 + 0 < a + b"
- using assms by (rule add_le_less_mono)
- then show ?thesis by simp
-qed
-
-lemma add_nonneg_nonneg:
- assumes "0 \<le> a" and "0 \<le> b" shows "0 \<le> a + b"
-proof -
- have "0 + 0 \<le> a + b"
- using assms by (rule add_mono)
- then show ?thesis by simp
-qed
-
-lemma add_neg_nonpos:
- assumes "a < 0" and "b \<le> 0" shows "a + b < 0"
-proof -
- have "a + b < 0 + 0"
- using assms by (rule add_less_le_mono)
- then show ?thesis by simp
-qed
-
-lemma add_neg_neg:
- assumes "a < 0" and "b < 0" shows "a + b < 0"
-by (rule add_neg_nonpos) (insert assms, auto)
-
-lemma add_nonpos_neg:
- assumes "a \<le> 0" and "b < 0" shows "a + b < 0"
-proof -
- have "a + b < 0 + 0"
- using assms by (rule add_le_less_mono)
- then show ?thesis by simp
-qed
-
-lemma add_nonpos_nonpos:
- assumes "a \<le> 0" and "b \<le> 0" shows "a + b \<le> 0"
-proof -
- have "a + b \<le> 0 + 0"
- using assms by (rule add_mono)
- then show ?thesis by simp
-qed
-
-lemmas add_sign_intros =
- add_pos_nonneg add_pos_pos add_nonneg_pos add_nonneg_nonneg
- add_neg_nonpos add_neg_neg add_nonpos_neg add_nonpos_nonpos
-
-lemma add_nonneg_eq_0_iff:
- assumes x: "0 \<le> x" and y: "0 \<le> y"
- shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
-proof (intro iffI conjI)
- have "x = x + 0" by simp
- also have "x + 0 \<le> x + y" using y by (rule add_left_mono)
- also assume "x + y = 0"
- also have "0 \<le> x" using x .
- finally show "x = 0" .
-next
- have "y = 0 + y" by simp
- also have "0 + y \<le> x + y" using x by (rule add_right_mono)
- also assume "x + y = 0"
- also have "0 \<le> y" using y .
- finally show "y = 0" .
-next
- assume "x = 0 \<and> y = 0"
- then show "x + y = 0" by simp
-qed
-
-end
-
-class pordered_ab_group_add =
- ab_group_add + pordered_ab_semigroup_add
-begin
-
-subclass pordered_cancel_ab_semigroup_add ..
-
-subclass pordered_ab_semigroup_add_imp_le
-proof
- fix a b c :: 'a
- assume "c + a \<le> c + b"
- hence "(-c) + (c + a) \<le> (-c) + (c + b)" by (rule add_left_mono)
- hence "((-c) + c) + a \<le> ((-c) + c) + b" by (simp only: add_assoc)
- thus "a \<le> b" by simp
-qed
-
-subclass pordered_comm_monoid_add ..
-
-lemma max_diff_distrib_left:
- shows "max x y - z = max (x - z) (y - z)"
-by (simp add: diff_minus, rule max_add_distrib_left)
-
-lemma min_diff_distrib_left:
- shows "min x y - z = min (x - z) (y - z)"
-by (simp add: diff_minus, rule min_add_distrib_left)
-
-lemma le_imp_neg_le:
- assumes "a \<le> b" shows "-b \<le> -a"
-proof -
- have "-a+a \<le> -a+b" using `a \<le> b` by (rule add_left_mono)
- hence "0 \<le> -a+b" by simp
- hence "0 + (-b) \<le> (-a + b) + (-b)" by (rule add_right_mono)
- thus ?thesis by (simp add: add_assoc)
-qed
-
-lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
-proof
- assume "- b \<le> - a"
- hence "- (- a) \<le> - (- b)" by (rule le_imp_neg_le)
- thus "a\<le>b" by simp
-next
- assume "a\<le>b"
- thus "-b \<le> -a" by (rule le_imp_neg_le)
-qed
-
-lemma neg_le_0_iff_le [simp]: "- a \<le> 0 \<longleftrightarrow> 0 \<le> a"
-by (subst neg_le_iff_le [symmetric], simp)
-
-lemma neg_0_le_iff_le [simp]: "0 \<le> - a \<longleftrightarrow> a \<le> 0"
-by (subst neg_le_iff_le [symmetric], simp)
-
-lemma neg_less_iff_less [simp]: "- b < - a \<longleftrightarrow> a < b"
-by (force simp add: less_le)
-
-lemma neg_less_0_iff_less [simp]: "- a < 0 \<longleftrightarrow> 0 < a"
-by (subst neg_less_iff_less [symmetric], simp)
-
-lemma neg_0_less_iff_less [simp]: "0 < - a \<longleftrightarrow> a < 0"
-by (subst neg_less_iff_less [symmetric], simp)
-
-text{*The next several equations can make the simplifier loop!*}
-
-lemma less_minus_iff: "a < - b \<longleftrightarrow> b < - a"
-proof -
- have "(- (-a) < - b) = (b < - a)" by (rule neg_less_iff_less)
- thus ?thesis by simp
-qed
-
-lemma minus_less_iff: "- a < b \<longleftrightarrow> - b < a"
-proof -
- have "(- a < - (-b)) = (- b < a)" by (rule neg_less_iff_less)
- thus ?thesis by simp
-qed
-
-lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
-proof -
- have mm: "!! a (b::'a). (-(-a)) < -b \<Longrightarrow> -(-b) < -a" by (simp only: minus_less_iff)
- have "(- (- a) <= -b) = (b <= - a)"
- apply (auto simp only: le_less)
- apply (drule mm)
- apply (simp_all)
- apply (drule mm[simplified], assumption)
- done
- then show ?thesis by simp
-qed
-
-lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
-by (auto simp add: le_less minus_less_iff)
-
-lemma less_iff_diff_less_0: "a < b \<longleftrightarrow> a - b < 0"
-proof -
- have "(a < b) = (a + (- b) < b + (-b))"
- by (simp only: add_less_cancel_right)
- also have "... = (a - b < 0)" by (simp add: diff_minus)
- finally show ?thesis .
-qed
-
-lemma diff_less_eq[algebra_simps]: "a - b < c \<longleftrightarrow> a < c + b"
-apply (subst less_iff_diff_less_0 [of a])
-apply (rule less_iff_diff_less_0 [of _ c, THEN ssubst])
-apply (simp add: diff_minus add_ac)
-done
-
-lemma less_diff_eq[algebra_simps]: "a < c - b \<longleftrightarrow> a + b < c"
-apply (subst less_iff_diff_less_0 [of "plus a b"])
-apply (subst less_iff_diff_less_0 [of a])
-apply (simp add: diff_minus add_ac)
-done
-
-lemma diff_le_eq[algebra_simps]: "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
-by (auto simp add: le_less diff_less_eq diff_add_cancel add_diff_cancel)
-
-lemma le_diff_eq[algebra_simps]: "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
-by (auto simp add: le_less less_diff_eq diff_add_cancel add_diff_cancel)
-
-lemma le_iff_diff_le_0: "a \<le> b \<longleftrightarrow> a - b \<le> 0"
-by (simp add: algebra_simps)
-
-text{*Legacy - use @{text algebra_simps} *}
-lemmas group_simps[noatp] = algebra_simps
-
-end
-
-text{*Legacy - use @{text algebra_simps} *}
-lemmas group_simps[noatp] = algebra_simps
-
-class ordered_ab_semigroup_add =
- linorder + pordered_ab_semigroup_add
-
-class ordered_cancel_ab_semigroup_add =
- linorder + pordered_cancel_ab_semigroup_add
-begin
-
-subclass ordered_ab_semigroup_add ..
-
-subclass pordered_ab_semigroup_add_imp_le
-proof
- fix a b c :: 'a
- assume le: "c + a <= c + b"
- show "a <= b"
- proof (rule ccontr)
- assume w: "~ a \<le> b"
- hence "b <= a" by (simp add: linorder_not_le)
- hence le2: "c + b <= c + a" by (rule add_left_mono)
- have "a = b"
- apply (insert le)
- apply (insert le2)
- apply (drule antisym, simp_all)
- done
- with w show False
- by (simp add: linorder_not_le [symmetric])
- qed
-qed
-
-end
-
-class ordered_ab_group_add =
- linorder + pordered_ab_group_add
-begin
-
-subclass ordered_cancel_ab_semigroup_add ..
-
-lemma neg_less_eq_nonneg:
- "- a \<le> a \<longleftrightarrow> 0 \<le> a"
-proof
- assume A: "- a \<le> a" show "0 \<le> a"
- proof (rule classical)
- assume "\<not> 0 \<le> a"
- then have "a < 0" by auto
- with A have "- a < 0" by (rule le_less_trans)
- then show ?thesis by auto
- qed
-next
- assume A: "0 \<le> a" show "- a \<le> a"
- proof (rule order_trans)
- show "- a \<le> 0" using A by (simp add: minus_le_iff)
- next
- show "0 \<le> a" using A .
- qed
-qed
-
-lemma less_eq_neg_nonpos:
- "a \<le> - a \<longleftrightarrow> a \<le> 0"
-proof
- assume A: "a \<le> - a" show "a \<le> 0"
- proof (rule classical)
- assume "\<not> a \<le> 0"
- then have "0 < a" by auto
- then have "0 < - a" using A by (rule less_le_trans)
- then show ?thesis by auto
- qed
-next
- assume A: "a \<le> 0" show "a \<le> - a"
- proof (rule order_trans)
- show "0 \<le> - a" using A by (simp add: minus_le_iff)
- next
- show "a \<le> 0" using A .
- qed
-qed
-
-lemma equal_neg_zero:
- "a = - a \<longleftrightarrow> a = 0"
-proof
- assume "a = 0" then show "a = - a" by simp
-next
- assume A: "a = - a" show "a = 0"
- proof (cases "0 \<le> a")
- case True with A have "0 \<le> - a" by auto
- with le_minus_iff have "a \<le> 0" by simp
- with True show ?thesis by (auto intro: order_trans)
- next
- case False then have B: "a \<le> 0" by auto
- with A have "- a \<le> 0" by auto
- with B show ?thesis by (auto intro: order_trans)
- qed
-qed
-
-lemma neg_equal_zero:
- "- a = a \<longleftrightarrow> a = 0"
- unfolding equal_neg_zero [symmetric] by auto
-
-end
-
--- {* FIXME localize the following *}
-
-lemma add_increasing:
- fixes c :: "'a::{pordered_ab_semigroup_add_imp_le, comm_monoid_add}"
- shows "[|0\<le>a; b\<le>c|] ==> b \<le> a + c"
-by (insert add_mono [of 0 a b c], simp)
-
-lemma add_increasing2:
- fixes c :: "'a::{pordered_ab_semigroup_add_imp_le, comm_monoid_add}"
- shows "[|0\<le>c; b\<le>a|] ==> b \<le> a + c"
-by (simp add:add_increasing add_commute[of a])
-
-lemma add_strict_increasing:
- fixes c :: "'a::{pordered_ab_semigroup_add_imp_le, comm_monoid_add}"
- shows "[|0<a; b\<le>c|] ==> b < a + c"
-by (insert add_less_le_mono [of 0 a b c], simp)
-
-lemma add_strict_increasing2:
- fixes c :: "'a::{pordered_ab_semigroup_add_imp_le, comm_monoid_add}"
- shows "[|0\<le>a; b<c|] ==> b < a + c"
-by (insert add_le_less_mono [of 0 a b c], simp)
-
-
-class pordered_ab_group_add_abs = pordered_ab_group_add + abs +
- assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
- and abs_ge_self: "a \<le> \<bar>a\<bar>"
- and abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
- and abs_minus_cancel [simp]: "\<bar>-a\<bar> = \<bar>a\<bar>"
- and abs_triangle_ineq: "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
-begin
-
-lemma abs_minus_le_zero: "- \<bar>a\<bar> \<le> 0"
- unfolding neg_le_0_iff_le by simp
-
-lemma abs_of_nonneg [simp]:
- assumes nonneg: "0 \<le> a" shows "\<bar>a\<bar> = a"
-proof (rule antisym)
- from nonneg le_imp_neg_le have "- a \<le> 0" by simp
- from this nonneg have "- a \<le> a" by (rule order_trans)
- then show "\<bar>a\<bar> \<le> a" by (auto intro: abs_leI)
-qed (rule abs_ge_self)
-
-lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
-by (rule antisym)
- (auto intro!: abs_ge_self abs_leI order_trans [of "uminus (abs a)" zero "abs a"])
-
-lemma abs_eq_0 [simp]: "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
-proof -
- have "\<bar>a\<bar> = 0 \<Longrightarrow> a = 0"
- proof (rule antisym)
- assume zero: "\<bar>a\<bar> = 0"
- with abs_ge_self show "a \<le> 0" by auto
- from zero have "\<bar>-a\<bar> = 0" by simp
- with abs_ge_self [of "uminus a"] have "- a \<le> 0" by auto
- with neg_le_0_iff_le show "0 \<le> a" by auto
- qed
- then show ?thesis by auto
-qed
-
-lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
-by simp
-
-lemma abs_0_eq [simp, noatp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
-proof -
- have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
- thus ?thesis by simp
-qed
-
-lemma abs_le_zero_iff [simp]: "\<bar>a\<bar> \<le> 0 \<longleftrightarrow> a = 0"
-proof
- assume "\<bar>a\<bar> \<le> 0"
- then have "\<bar>a\<bar> = 0" by (rule antisym) simp
- thus "a = 0" by simp
-next
- assume "a = 0"
- thus "\<bar>a\<bar> \<le> 0" by simp
-qed
-
-lemma zero_less_abs_iff [simp]: "0 < \<bar>a\<bar> \<longleftrightarrow> a \<noteq> 0"
-by (simp add: less_le)
-
-lemma abs_not_less_zero [simp]: "\<not> \<bar>a\<bar> < 0"
-proof -
- have a: "\<And>x y. x \<le> y \<Longrightarrow> \<not> y < x" by auto
- show ?thesis by (simp add: a)
-qed
-
-lemma abs_ge_minus_self: "- a \<le> \<bar>a\<bar>"
-proof -
- have "- a \<le> \<bar>-a\<bar>" by (rule abs_ge_self)
- then show ?thesis by simp
-qed
-
-lemma abs_minus_commute:
- "\<bar>a - b\<bar> = \<bar>b - a\<bar>"
-proof -
- have "\<bar>a - b\<bar> = \<bar>- (a - b)\<bar>" by (simp only: abs_minus_cancel)
- also have "... = \<bar>b - a\<bar>" by simp
- finally show ?thesis .
-qed
-
-lemma abs_of_pos: "0 < a \<Longrightarrow> \<bar>a\<bar> = a"
-by (rule abs_of_nonneg, rule less_imp_le)
-
-lemma abs_of_nonpos [simp]:
- assumes "a \<le> 0" shows "\<bar>a\<bar> = - a"
-proof -
- let ?b = "- a"
- have "- ?b \<le> 0 \<Longrightarrow> \<bar>- ?b\<bar> = - (- ?b)"
- unfolding abs_minus_cancel [of "?b"]
- unfolding neg_le_0_iff_le [of "?b"]
- unfolding minus_minus by (erule abs_of_nonneg)
- then show ?thesis using assms by auto
-qed
-
-lemma abs_of_neg: "a < 0 \<Longrightarrow> \<bar>a\<bar> = - a"
-by (rule abs_of_nonpos, rule less_imp_le)
-
-lemma abs_le_D1: "\<bar>a\<bar> \<le> b \<Longrightarrow> a \<le> b"
-by (insert abs_ge_self, blast intro: order_trans)
-
-lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
-by (insert abs_le_D1 [of "uminus a"], simp)
-
-lemma abs_le_iff: "\<bar>a\<bar> \<le> b \<longleftrightarrow> a \<le> b \<and> - a \<le> b"
-by (blast intro: abs_leI dest: abs_le_D1 abs_le_D2)
-
-lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
- apply (simp add: algebra_simps)
- apply (subgoal_tac "abs a = abs (plus b (minus a b))")
- apply (erule ssubst)
- apply (rule abs_triangle_ineq)
- apply (rule arg_cong[of _ _ abs])
- apply (simp add: algebra_simps)
-done
-
-lemma abs_triangle_ineq3: "\<bar>\<bar>a\<bar> - \<bar>b\<bar>\<bar> \<le> \<bar>a - b\<bar>"
- apply (subst abs_le_iff)
- apply auto
- apply (rule abs_triangle_ineq2)
- apply (subst abs_minus_commute)
- apply (rule abs_triangle_ineq2)
-done
-
-lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
-proof -
- have "abs(a - b) = abs(a + - b)" by (subst diff_minus, rule refl)
- also have "... <= abs a + abs (- b)" by (rule abs_triangle_ineq)
- finally show ?thesis by simp
-qed
-
-lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
-proof -
- have "\<bar>a + b - (c+d)\<bar> = \<bar>(a-c) + (b-d)\<bar>" by (simp add: diff_minus add_ac)
- also have "... \<le> \<bar>a-c\<bar> + \<bar>b-d\<bar>" by (rule abs_triangle_ineq)
- finally show ?thesis .
-qed
-
-lemma abs_add_abs [simp]:
- "\<bar>\<bar>a\<bar> + \<bar>b\<bar>\<bar> = \<bar>a\<bar> + \<bar>b\<bar>" (is "?L = ?R")
-proof (rule antisym)
- show "?L \<ge> ?R" by(rule abs_ge_self)
-next
- have "?L \<le> \<bar>\<bar>a\<bar>\<bar> + \<bar>\<bar>b\<bar>\<bar>" by(rule abs_triangle_ineq)
- also have "\<dots> = ?R" by simp
- finally show "?L \<le> ?R" .
-qed
-
-end
-
-
-subsection {* Lattice Ordered (Abelian) Groups *}
-
-class lordered_ab_group_add_meet = pordered_ab_group_add + lower_semilattice
-begin
-
-lemma add_inf_distrib_left:
- "a + inf b c = inf (a + b) (a + c)"
-apply (rule antisym)
-apply (simp_all add: le_infI)
-apply (rule add_le_imp_le_left [of "uminus a"])
-apply (simp only: add_assoc [symmetric], simp)
-apply rule
-apply (rule add_le_imp_le_left[of "a"], simp only: add_assoc[symmetric], simp)+
-done
-
-lemma add_inf_distrib_right:
- "inf a b + c = inf (a + c) (b + c)"
-proof -
- have "c + inf a b = inf (c+a) (c+b)" by (simp add: add_inf_distrib_left)
- thus ?thesis by (simp add: add_commute)
-qed
-
-end
-
-class lordered_ab_group_add_join = pordered_ab_group_add + upper_semilattice
-begin
-
-lemma add_sup_distrib_left:
- "a + sup b c = sup (a + b) (a + c)"
-apply (rule antisym)
-apply (rule add_le_imp_le_left [of "uminus a"])
-apply (simp only: add_assoc[symmetric], simp)
-apply rule
-apply (rule add_le_imp_le_left [of "a"], simp only: add_assoc[symmetric], simp)+
-apply (rule le_supI)
-apply (simp_all)
-done
-
-lemma add_sup_distrib_right:
- "sup a b + c = sup (a+c) (b+c)"
-proof -
- have "c + sup a b = sup (c+a) (c+b)" by (simp add: add_sup_distrib_left)
- thus ?thesis by (simp add: add_commute)
-qed
-
-end
-
-class lordered_ab_group_add = pordered_ab_group_add + lattice
-begin
-
-subclass lordered_ab_group_add_meet ..
-subclass lordered_ab_group_add_join ..
-
-lemmas add_sup_inf_distribs = add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left
-
-lemma inf_eq_neg_sup: "inf a b = - sup (-a) (-b)"
-proof (rule inf_unique)
- fix a b :: 'a
- show "- sup (-a) (-b) \<le> a"
- by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
- (simp, simp add: add_sup_distrib_left)
-next
- fix a b :: 'a
- show "- sup (-a) (-b) \<le> b"
- by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
- (simp, simp add: add_sup_distrib_left)
-next
- fix a b c :: 'a
- assume "a \<le> b" "a \<le> c"
- then show "a \<le> - sup (-b) (-c)" by (subst neg_le_iff_le [symmetric])
- (simp add: le_supI)
-qed
-
-lemma sup_eq_neg_inf: "sup a b = - inf (-a) (-b)"
-proof (rule sup_unique)
- fix a b :: 'a
- show "a \<le> - inf (-a) (-b)"
- by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
- (simp, simp add: add_inf_distrib_left)
-next
- fix a b :: 'a
- show "b \<le> - inf (-a) (-b)"
- by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
- (simp, simp add: add_inf_distrib_left)
-next
- fix a b c :: 'a
- assume "a \<le> c" "b \<le> c"
- then show "- inf (-a) (-b) \<le> c" by (subst neg_le_iff_le [symmetric])
- (simp add: le_infI)
-qed
-
-lemma neg_inf_eq_sup: "- inf a b = sup (-a) (-b)"
-by (simp add: inf_eq_neg_sup)
-
-lemma neg_sup_eq_inf: "- sup a b = inf (-a) (-b)"
-by (simp add: sup_eq_neg_inf)
-
-lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
-proof -
- have "0 = - inf 0 (a-b) + inf (a-b) 0" by (simp add: inf_commute)
- hence "0 = sup 0 (b-a) + inf (a-b) 0" by (simp add: inf_eq_neg_sup)
- hence "0 = (-a + sup a b) + (inf a b + (-b))"
- by (simp add: add_sup_distrib_left add_inf_distrib_right)
- (simp add: algebra_simps)
- thus ?thesis by (simp add: algebra_simps)
-qed
-
-subsection {* Positive Part, Negative Part, Absolute Value *}
-
-definition
- nprt :: "'a \<Rightarrow> 'a" where
- "nprt x = inf x 0"
-
-definition
- pprt :: "'a \<Rightarrow> 'a" where
- "pprt x = sup x 0"
-
-lemma pprt_neg: "pprt (- x) = - nprt x"
-proof -
- have "sup (- x) 0 = sup (- x) (- 0)" unfolding minus_zero ..
- also have "\<dots> = - inf x 0" unfolding neg_inf_eq_sup ..
- finally have "sup (- x) 0 = - inf x 0" .
- then show ?thesis unfolding pprt_def nprt_def .
-qed
-
-lemma nprt_neg: "nprt (- x) = - pprt x"
-proof -
- from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
- then have "pprt x = - nprt (- x)" by simp
- then show ?thesis by simp
-qed
-
-lemma prts: "a = pprt a + nprt a"
-by (simp add: pprt_def nprt_def add_eq_inf_sup[symmetric])
-
-lemma zero_le_pprt[simp]: "0 \<le> pprt a"
-by (simp add: pprt_def)
-
-lemma nprt_le_zero[simp]: "nprt a \<le> 0"
-by (simp add: nprt_def)
-
-lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0" (is "?l = ?r")
-proof -
- have a: "?l \<longrightarrow> ?r"
- apply (auto)
- apply (rule add_le_imp_le_right[of _ "uminus b" _])
- apply (simp add: add_assoc)
- done
- have b: "?r \<longrightarrow> ?l"
- apply (auto)
- apply (rule add_le_imp_le_right[of _ "b" _])
- apply (simp)
- done
- from a b show ?thesis by blast
-qed
-
-lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
-lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)
-
-lemma pprt_eq_id [simp, noatp]: "0 \<le> x \<Longrightarrow> pprt x = x"
- by (simp add: pprt_def sup_aci sup_absorb1)
-
-lemma nprt_eq_id [simp, noatp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
- by (simp add: nprt_def inf_aci inf_absorb1)
-
-lemma pprt_eq_0 [simp, noatp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
- by (simp add: pprt_def sup_aci sup_absorb2)
-
-lemma nprt_eq_0 [simp, noatp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
- by (simp add: nprt_def inf_aci inf_absorb2)
-
-lemma sup_0_imp_0: "sup a (- a) = 0 \<Longrightarrow> a = 0"
-proof -
- {
- fix a::'a
- assume hyp: "sup a (-a) = 0"
- hence "sup a (-a) + a = a" by (simp)
- hence "sup (a+a) 0 = a" by (simp add: add_sup_distrib_right)
- hence "sup (a+a) 0 <= a" by (simp)
- hence "0 <= a" by (blast intro: order_trans inf_sup_ord)
- }
- note p = this
- assume hyp:"sup a (-a) = 0"
- hence hyp2:"sup (-a) (-(-a)) = 0" by (simp add: sup_commute)
- from p[OF hyp] p[OF hyp2] show "a = 0" by simp
-qed
-
-lemma inf_0_imp_0: "inf a (-a) = 0 \<Longrightarrow> a = 0"
-apply (simp add: inf_eq_neg_sup)
-apply (simp add: sup_commute)
-apply (erule sup_0_imp_0)
-done
-
-lemma inf_0_eq_0 [simp, noatp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
-by (rule, erule inf_0_imp_0) simp
-
-lemma sup_0_eq_0 [simp, noatp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
-by (rule, erule sup_0_imp_0) simp
-
-lemma zero_le_double_add_iff_zero_le_single_add [simp]:
- "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
-proof
- assume "0 <= a + a"
- hence a:"inf (a+a) 0 = 0" by (simp add: inf_commute inf_absorb1)
- have "(inf a 0)+(inf a 0) = inf (inf (a+a) 0) a" (is "?l=_")
- by (simp add: add_sup_inf_distribs inf_aci)
- hence "?l = 0 + inf a 0" by (simp add: a, simp add: inf_commute)
- hence "inf a 0 = 0" by (simp only: add_right_cancel)
- then show "0 <= a" unfolding le_iff_inf by (simp add: inf_commute)
-next
- assume a: "0 <= a"
- show "0 <= a + a" by (simp add: add_mono[OF a a, simplified])
-qed
-
-lemma double_zero: "a + a = 0 \<longleftrightarrow> a = 0"
-proof
- assume assm: "a + a = 0"
- then have "a + a + - a = - a" by simp
- then have "a + (a + - a) = - a" by (simp only: add_assoc)
- then have a: "- a = a" by simp
- show "a = 0" apply (rule antisym)
- apply (unfold neg_le_iff_le [symmetric, of a])
- unfolding a apply simp
- unfolding zero_le_double_add_iff_zero_le_single_add [symmetric, of a]
- unfolding assm unfolding le_less apply simp_all done
-next
- assume "a = 0" then show "a + a = 0" by simp
-qed
-
-lemma zero_less_double_add_iff_zero_less_single_add:
- "0 < a + a \<longleftrightarrow> 0 < a"
-proof (cases "a = 0")
- case True then show ?thesis by auto
-next
- case False then show ?thesis (*FIXME tune proof*)
- unfolding less_le apply simp apply rule
- apply clarify
- apply rule
- apply assumption
- apply (rule notI)
- unfolding double_zero [symmetric, of a] apply simp
- done
-qed
-
-lemma double_add_le_zero_iff_single_add_le_zero [simp]:
- "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
-proof -
- have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)" by (subst le_minus_iff, simp)
- moreover have "\<dots> \<longleftrightarrow> a \<le> 0" by (simp add: zero_le_double_add_iff_zero_le_single_add)
- ultimately show ?thesis by blast
-qed
-
-lemma double_add_less_zero_iff_single_less_zero [simp]:
- "a + a < 0 \<longleftrightarrow> a < 0"
-proof -
- have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)" by (subst less_minus_iff, simp)
- moreover have "\<dots> \<longleftrightarrow> a < 0" by (simp add: zero_less_double_add_iff_zero_less_single_add)
- ultimately show ?thesis by blast
-qed
-
-declare neg_inf_eq_sup [simp] neg_sup_eq_inf [simp]
-
-lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
-proof -
- from add_le_cancel_left [of "uminus a" "plus a a" zero]
- have "(a <= -a) = (a+a <= 0)"
- by (simp add: add_assoc[symmetric])
- thus ?thesis by simp
-qed
-
-lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
-proof -
- from add_le_cancel_left [of "uminus a" zero "plus a a"]
- have "(-a <= a) = (0 <= a+a)"
- by (simp add: add_assoc[symmetric])
- thus ?thesis by simp
-qed
-
-lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
-unfolding le_iff_inf by (simp add: nprt_def inf_commute)
-
-lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
-unfolding le_iff_sup by (simp add: pprt_def sup_commute)
-
-lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
-unfolding le_iff_sup by (simp add: pprt_def sup_commute)
-
-lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
-unfolding le_iff_inf by (simp add: nprt_def inf_commute)
-
-lemma pprt_mono [simp, noatp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
-unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])
-
-lemma nprt_mono [simp, noatp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
-unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])
-
-end
-
-lemmas add_sup_inf_distribs = add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left
-
-
-class lordered_ab_group_add_abs = lordered_ab_group_add + abs +
- assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
-begin
-
-lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
-proof -
- have "0 \<le> \<bar>a\<bar>"
- proof -
- have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>" by (auto simp add: abs_lattice)
- show ?thesis by (rule add_mono [OF a b, simplified])
- qed
- then have "0 \<le> sup a (- a)" unfolding abs_lattice .
- then have "sup (sup a (- a)) 0 = sup a (- a)" by (rule sup_absorb1)
- then show ?thesis
- by (simp add: add_sup_inf_distribs sup_aci
- pprt_def nprt_def diff_minus abs_lattice)
-qed
-
-subclass pordered_ab_group_add_abs
-proof
- have abs_ge_zero [simp]: "\<And>a. 0 \<le> \<bar>a\<bar>"
- proof -
- fix a b
- have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>" by (auto simp add: abs_lattice)
- show "0 \<le> \<bar>a\<bar>" by (rule add_mono [OF a b, simplified])
- qed
- have abs_leI: "\<And>a b. a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
- by (simp add: abs_lattice le_supI)
- fix a b
- show "0 \<le> \<bar>a\<bar>" by simp
- show "a \<le> \<bar>a\<bar>"
- by (auto simp add: abs_lattice)
- show "\<bar>-a\<bar> = \<bar>a\<bar>"
- by (simp add: abs_lattice sup_commute)
- show "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" by (fact abs_leI)
- show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
- proof -
- have g:"abs a + abs b = sup (a+b) (sup (-a-b) (sup (-a+b) (a + (-b))))" (is "_=sup ?m ?n")
- by (simp add: abs_lattice add_sup_inf_distribs sup_aci diff_minus)
- have a:"a+b <= sup ?m ?n" by (simp)
- have b:"-a-b <= ?n" by (simp)
- have c:"?n <= sup ?m ?n" by (simp)
- from b c have d: "-a-b <= sup ?m ?n" by(rule order_trans)
- have e:"-a-b = -(a+b)" by (simp add: diff_minus)
- from a d e have "abs(a+b) <= sup ?m ?n"
- by (drule_tac abs_leI, auto)
- with g[symmetric] show ?thesis by simp
- qed
-qed
-
-end
-
-lemma sup_eq_if:
- fixes a :: "'a\<Colon>{lordered_ab_group_add, linorder}"
- shows "sup a (- a) = (if a < 0 then - a else a)"
-proof -
- note add_le_cancel_right [of a a "- a", symmetric, simplified]
- moreover note add_le_cancel_right [of "-a" a a, symmetric, simplified]
- then show ?thesis by (auto simp: sup_max min_max.sup_absorb1 min_max.sup_absorb2)
-qed
-
-lemma abs_if_lattice:
- fixes a :: "'a\<Colon>{lordered_ab_group_add_abs, linorder}"
- shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
-by auto
-
-
-text {* Needed for abelian cancellation simprocs: *}
-
-lemma add_cancel_21: "((x::'a::ab_group_add) + (y + z) = y + u) = (x + z = u)"
-apply (subst add_left_commute)
-apply (subst add_left_cancel)
-apply simp
-done
-
-lemma add_cancel_end: "(x + (y + z) = y) = (x = - (z::'a::ab_group_add))"
-apply (subst add_cancel_21[of _ _ _ 0, simplified])
-apply (simp add: add_right_cancel[symmetric, of "x" "-z" "z", simplified])
-done
-
-lemma less_eqI: "(x::'a::pordered_ab_group_add) - y = x' - y' \<Longrightarrow> (x < y) = (x' < y')"
-by (simp add: less_iff_diff_less_0[of x y] less_iff_diff_less_0[of x' y'])
-
-lemma le_eqI: "(x::'a::pordered_ab_group_add) - y = x' - y' \<Longrightarrow> (y <= x) = (y' <= x')"
-apply (simp add: le_iff_diff_le_0[of y x] le_iff_diff_le_0[of y' x'])
-apply (simp add: neg_le_iff_le[symmetric, of "y-x" 0] neg_le_iff_le[symmetric, of "y'-x'" 0])
-done
-
-lemma eq_eqI: "(x::'a::ab_group_add) - y = x' - y' \<Longrightarrow> (x = y) = (x' = y')"
-by (simp only: eq_iff_diff_eq_0[of x y] eq_iff_diff_eq_0[of x' y'])
-
-lemma diff_def: "(x::'a::ab_group_add) - y == x + (-y)"
-by (simp add: diff_minus)
-
-lemma le_add_right_mono:
- assumes
- "a <= b + (c::'a::pordered_ab_group_add)"
- "c <= d"
- shows "a <= b + d"
- apply (rule_tac order_trans[where y = "b+c"])
- apply (simp_all add: prems)
- done
-
-lemma estimate_by_abs:
- "a + b <= (c::'a::lordered_ab_group_add_abs) \<Longrightarrow> a <= c + abs b"
-proof -
- assume "a+b <= c"
- hence 2: "a <= c+(-b)" by (simp add: algebra_simps)
- have 3: "(-b) <= abs b" by (rule abs_ge_minus_self)
- show ?thesis by (rule le_add_right_mono[OF 2 3])
-qed
-
-subsection {* Tools setup *}
-
-lemma add_mono_thms_ordered_semiring [noatp]:
- fixes i j k :: "'a\<Colon>pordered_ab_semigroup_add"
- shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
- and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
- and "i \<le> j \<and> k = l \<Longrightarrow> i + k \<le> j + l"
- and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
-by (rule add_mono, clarify+)+
-
-lemma add_mono_thms_ordered_field [noatp]:
- fixes i j k :: "'a\<Colon>pordered_cancel_ab_semigroup_add"
- shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
- and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
- and "i < j \<and> k \<le> l \<Longrightarrow> i + k < j + l"
- and "i \<le> j \<and> k < l \<Longrightarrow> i + k < j + l"
- and "i < j \<and> k < l \<Longrightarrow> i + k < j + l"
-by (auto intro: add_strict_right_mono add_strict_left_mono
- add_less_le_mono add_le_less_mono add_strict_mono)
-
-text{*Simplification of @{term "x-y < 0"}, etc.*}
-lemmas diff_less_0_iff_less [simp, noatp] = less_iff_diff_less_0 [symmetric]
-lemmas diff_le_0_iff_le [simp, noatp] = le_iff_diff_le_0 [symmetric]
-
-ML {*
-structure ab_group_add_cancel = Abel_Cancel
-(
-
-(* term order for abelian groups *)
-
-fun agrp_ord (Const (a, _)) = find_index (fn a' => a = a')
- [@{const_name Algebras.zero}, @{const_name Algebras.plus},
- @{const_name Algebras.uminus}, @{const_name Algebras.minus}]
- | agrp_ord _ = ~1;
-
-fun termless_agrp (a, b) = (TermOrd.term_lpo agrp_ord (a, b) = LESS);
-
-local
- val ac1 = mk_meta_eq @{thm add_assoc};
- val ac2 = mk_meta_eq @{thm add_commute};
- val ac3 = mk_meta_eq @{thm add_left_commute};
- fun solve_add_ac thy _ (_ $ (Const (@{const_name Algebras.plus},_) $ _ $ _) $ _) =
- SOME ac1
- | solve_add_ac thy _ (_ $ x $ (Const (@{const_name Algebras.plus},_) $ y $ z)) =
- if termless_agrp (y, x) then SOME ac3 else NONE
- | solve_add_ac thy _ (_ $ x $ y) =
- if termless_agrp (y, x) then SOME ac2 else NONE
- | solve_add_ac thy _ _ = NONE
-in
- val add_ac_proc = Simplifier.simproc @{theory}
- "add_ac_proc" ["x + y::'a::ab_semigroup_add"] solve_add_ac;
-end;
-
-val eq_reflection = @{thm eq_reflection};
-
-val T = @{typ "'a::ab_group_add"};
-
-val cancel_ss = HOL_basic_ss settermless termless_agrp
- addsimprocs [add_ac_proc] addsimps
- [@{thm add_0_left}, @{thm add_0_right}, @{thm diff_def},
- @{thm minus_add_distrib}, @{thm minus_minus}, @{thm minus_zero},
- @{thm right_minus}, @{thm left_minus}, @{thm add_minus_cancel},
- @{thm minus_add_cancel}];
-
-val sum_pats = [@{cterm "x + y::'a::ab_group_add"}, @{cterm "x - y::'a::ab_group_add"}];
-
-val eqI_rules = [@{thm less_eqI}, @{thm le_eqI}, @{thm eq_eqI}];
-
-val dest_eqI =
- fst o HOLogic.dest_bin "op =" HOLogic.boolT o HOLogic.dest_Trueprop o concl_of;
-
-);
-*}
-
-ML {*
- Addsimprocs [ab_group_add_cancel.sum_conv, ab_group_add_cancel.rel_conv];
-*}
-
-code_modulename SML
- OrderedGroup Arith
-
-code_modulename OCaml
- OrderedGroup Arith
-
-code_modulename Haskell
- OrderedGroup Arith
-
-end
--- a/src/HOL/Orderings.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Orderings.thy Fri Feb 19 15:21:57 2010 +0000
@@ -11,6 +11,41 @@
"~~/src/Provers/quasi.ML" (* FIXME unused? *)
begin
+subsection {* Syntactic orders *}
+
+class ord =
+ fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+ and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+begin
+
+notation
+ less_eq ("op <=") and
+ less_eq ("(_/ <= _)" [51, 51] 50) and
+ less ("op <") and
+ less ("(_/ < _)" [51, 51] 50)
+
+notation (xsymbols)
+ less_eq ("op \<le>") and
+ less_eq ("(_/ \<le> _)" [51, 51] 50)
+
+notation (HTML output)
+ less_eq ("op \<le>") and
+ less_eq ("(_/ \<le> _)" [51, 51] 50)
+
+abbreviation (input)
+ greater_eq (infix ">=" 50) where
+ "x >= y \<equiv> y <= x"
+
+notation (input)
+ greater_eq (infix "\<ge>" 50)
+
+abbreviation (input)
+ greater (infix ">" 50) where
+ "x > y \<equiv> y < x"
+
+end
+
+
subsection {* Quasi orders *}
class preorder = ord +
@@ -611,25 +646,30 @@
val less_eq = @{const_syntax less_eq};
val trans =
- [((All_binder, impl, less), ("_All_less", "_All_greater")),
- ((All_binder, impl, less_eq), ("_All_less_eq", "_All_greater_eq")),
- ((Ex_binder, conj, less), ("_Ex_less", "_Ex_greater")),
- ((Ex_binder, conj, less_eq), ("_Ex_less_eq", "_Ex_greater_eq"))];
+ [((All_binder, impl, less),
+ (@{syntax_const "_All_less"}, @{syntax_const "_All_greater"})),
+ ((All_binder, impl, less_eq),
+ (@{syntax_const "_All_less_eq"}, @{syntax_const "_All_greater_eq"})),
+ ((Ex_binder, conj, less),
+ (@{syntax_const "_Ex_less"}, @{syntax_const "_Ex_greater"})),
+ ((Ex_binder, conj, less_eq),
+ (@{syntax_const "_Ex_less_eq"}, @{syntax_const "_Ex_greater_eq"}))];
- fun matches_bound v t =
- case t of (Const ("_bound", _) $ Free (v', _)) => (v = v')
- | _ => false
- fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false)
- fun mk v c n P = Syntax.const c $ Syntax.mark_bound v $ n $ P
+ fun matches_bound v t =
+ (case t of
+ Const ("_bound", _) $ Free (v', _) => v = v'
+ | _ => false);
+ fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false);
+ fun mk v c n P = Syntax.const c $ Syntax.mark_bound v $ n $ P;
fun tr' q = (q,
fn [Const ("_bound", _) $ Free (v, _), Const (c, _) $ (Const (d, _) $ t $ u) $ P] =>
- (case AList.lookup (op =) trans (q, c, d) of
- NONE => raise Match
- | SOME (l, g) =>
- if matches_bound v t andalso not (contains_var v u) then mk v l u P
- else if matches_bound v u andalso not (contains_var v t) then mk v g t P
- else raise Match)
+ (case AList.lookup (op =) trans (q, c, d) of
+ NONE => raise Match
+ | SOME (l, g) =>
+ if matches_bound v t andalso not (contains_var v u) then mk v l u P
+ else if matches_bound v u andalso not (contains_var v t) then mk v g t P
+ else raise Match)
| _ => raise Match);
in [tr' All_binder, tr' Ex_binder] end
*}
@@ -1052,7 +1092,7 @@
subsection {* Dense orders *}
-class dense_linear_order = linorder +
+class dense_linorder = linorder +
assumes gt_ex: "\<exists>y. x < y"
and lt_ex: "\<exists>y. y < x"
and dense: "x < y \<Longrightarrow> (\<exists>z. x < z \<and> z < y)"
--- a/src/HOL/PReal.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/PReal.thy Fri Feb 19 15:21:57 2010 +0000
@@ -12,7 +12,7 @@
imports Rational
begin
-text{*Could be generalized and moved to @{text Ring_and_Field}*}
+text{*Could be generalized and moved to @{text Groups}*}
lemma add_eq_exists: "\<exists>x. a+x = (b::rat)"
by (rule_tac x="b-a" in exI, simp)
@@ -23,7 +23,7 @@
(\<forall>y \<in> A. ((\<forall>z. 0<z & z < y --> z \<in> A) & (\<exists>u \<in> A. y < u))))"
lemma interval_empty_iff:
- "{y. (x::'a::dense_linear_order) < y \<and> y < z} = {} \<longleftrightarrow> \<not> x < z"
+ "{y. (x::'a::dense_linorder) < y \<and> y < z} = {} \<longleftrightarrow> \<not> x < z"
by (auto dest: dense)
@@ -750,7 +750,7 @@
have frle: "Fract a b \<le> Fract ?k 1 * (Fract c d)"
proof -
have "?thesis = ((a * d * b * d) \<le> c * b * (a * d * b * d))"
- by (simp add: mult_rat le_rat order_less_imp_not_eq2 mult_ac)
+ by (simp add: order_less_imp_not_eq2 mult_ac)
moreover
have "(1 * (a * d * b * d)) \<le> c * b * (a * d * b * d)"
by (rule mult_mono,
@@ -822,7 +822,7 @@
also with ypos have "... = (r/y) * (y + ?d)"
by (simp only: algebra_simps divide_inverse, simp)
also have "... = r*x" using ypos
- by (simp add: times_divide_eq_left)
+ by simp
finally show "r + ?d < r*x" .
qed
with r notin rdpos
@@ -1155,7 +1155,7 @@
preal_add_le_cancel_right preal_add_le_cancel_left
preal_add_left_cancel_iff preal_add_right_cancel_iff
-instance preal :: ordered_cancel_ab_semigroup_add
+instance preal :: linordered_cancel_ab_semigroup_add
proof
fix a b c :: preal
show "a + b = a + c \<Longrightarrow> b = c" by (rule preal_add_left_cancel)
--- a/src/HOL/Parity.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Parity.thy Fri Feb 19 15:21:57 2010 +0000
@@ -184,7 +184,7 @@
apply (rule conjI)
apply simp
apply (insert even_zero_nat, blast)
- apply (simp add: power_Suc)
+ apply simp
done
lemma minus_one_even_power [simp]:
@@ -199,7 +199,7 @@
"(even x --> (-1::'a::{number_ring})^x = 1) &
(odd x --> (-1::'a)^x = -1)"
apply (induct x)
- apply (simp, simp add: power_Suc)
+ apply (simp, simp)
done
lemma neg_one_even_power [simp]:
@@ -214,11 +214,11 @@
"(-x::'a::{comm_ring_1}) ^ n =
(if even n then (x ^ n) else -(x ^ n))"
apply (induct n)
- apply (simp_all split: split_if_asm add: power_Suc)
+ apply simp_all
done
lemma zero_le_even_power: "even n ==>
- 0 <= (x::'a::{ordered_ring_strict,monoid_mult}) ^ n"
+ 0 <= (x::'a::{linordered_ring_strict,monoid_mult}) ^ n"
apply (simp add: even_nat_equiv_def2)
apply (erule exE)
apply (erule ssubst)
@@ -227,12 +227,12 @@
done
lemma zero_le_odd_power: "odd n ==>
- (0 <= (x::'a::{ordered_idom}) ^ n) = (0 <= x)"
-apply (auto simp: odd_nat_equiv_def2 power_Suc power_add zero_le_mult_iff)
+ (0 <= (x::'a::{linordered_idom}) ^ n) = (0 <= x)"
+apply (auto simp: odd_nat_equiv_def2 power_add zero_le_mult_iff)
apply (metis field_power_not_zero no_zero_divirors_neq0 order_antisym_conv zero_le_square)
done
-lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{ordered_idom}) ^ n) =
+lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{linordered_idom}) ^ n) =
(even n | (odd n & 0 <= x))"
apply auto
apply (subst zero_le_odd_power [symmetric])
@@ -240,19 +240,19 @@
apply (erule zero_le_even_power)
done
-lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{ordered_idom}) ^ n) =
+lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{linordered_idom}) ^ n) =
(n = 0 | (even n & x ~= 0) | (odd n & 0 < x))"
unfolding order_less_le zero_le_power_eq by auto
-lemma power_less_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n < 0) =
+lemma power_less_zero_eq[presburger]: "((x::'a::{linordered_idom}) ^ n < 0) =
(odd n & x < 0)"
apply (subst linorder_not_le [symmetric])+
apply (subst zero_le_power_eq)
apply auto
done
-lemma power_le_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n <= 0) =
+lemma power_le_zero_eq[presburger]: "((x::'a::{linordered_idom}) ^ n <= 0) =
(n ~= 0 & ((odd n & x <= 0) | (even n & x = 0)))"
apply (subst linorder_not_less [symmetric])+
apply (subst zero_less_power_eq)
@@ -260,7 +260,7 @@
done
lemma power_even_abs: "even n ==>
- (abs (x::'a::{ordered_idom}))^n = x^n"
+ (abs (x::'a::{linordered_idom}))^n = x^n"
apply (subst power_abs [symmetric])
apply (simp add: zero_le_even_power)
done
@@ -280,7 +280,7 @@
apply simp
done
-lemma power_mono_even: fixes x y :: "'a :: {ordered_idom}"
+lemma power_mono_even: fixes x y :: "'a :: {linordered_idom}"
assumes "even n" and "\<bar>x\<bar> \<le> \<bar>y\<bar>"
shows "x^n \<le> y^n"
proof -
@@ -292,7 +292,7 @@
lemma odd_pos: "odd (n::nat) \<Longrightarrow> 0 < n" by presburger
-lemma power_mono_odd: fixes x y :: "'a :: {ordered_idom}"
+lemma power_mono_odd: fixes x y :: "'a :: {linordered_idom}"
assumes "odd n" and "x \<le> y"
shows "x^n \<le> y^n"
proof (cases "y < 0")
@@ -372,11 +372,11 @@
subsection {* An Equivalence for @{term [source] "0 \<le> a^n"} *}
lemma even_power_le_0_imp_0:
- "a ^ (2*k) \<le> (0::'a::{ordered_idom}) ==> a=0"
- by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff power_Suc)
+ "a ^ (2*k) \<le> (0::'a::{linordered_idom}) ==> a=0"
+ by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff)
lemma zero_le_power_iff[presburger]:
- "(0 \<le> a^n) = (0 \<le> (a::'a::{ordered_idom}) | even n)"
+ "(0 \<le> a^n) = (0 \<le> (a::'a::{linordered_idom}) | even n)"
proof cases
assume even: "even n"
then obtain k where "n = 2*k"
@@ -387,7 +387,7 @@
then obtain k where "n = Suc(2*k)"
by (auto simp add: odd_nat_equiv_def2 numeral_2_eq_2)
thus ?thesis
- by (auto simp add: power_Suc zero_le_mult_iff zero_le_even_power
+ by (auto simp add: zero_le_mult_iff zero_le_even_power
dest!: even_power_le_0_imp_0)
qed
--- a/src/HOL/Power.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Power.thy Fri Feb 19 15:21:57 2010 +0000
@@ -130,7 +130,7 @@
end
-context ordered_semidom
+context linordered_semidom
begin
lemma zero_less_power [simp]:
@@ -323,7 +323,7 @@
end
-context ordered_idom
+context linordered_idom
begin
lemma power_abs:
@@ -332,7 +332,7 @@
lemma abs_power_minus [simp]:
"abs ((-a) ^ n) = abs (a ^ n)"
- by (simp add: abs_minus_cancel power_abs)
+ by (simp add: power_abs)
lemma zero_less_power_abs_iff [simp, noatp]:
"0 < abs a ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
--- a/src/HOL/Presburger.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Presburger.thy Fri Feb 19 15:21:57 2010 +0000
@@ -30,8 +30,8 @@
"\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<le> t) = True"
"\<exists>(z ::'a::{linorder}).\<forall>x<z.(x > t) = False"
"\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<ge> t) = False"
- "\<exists>z.\<forall>(x::'a::{linorder,plus,Ring_and_Field.dvd})<z. (d dvd x + s) = (d dvd x + s)"
- "\<exists>z.\<forall>(x::'a::{linorder,plus,Ring_and_Field.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
+ "\<exists>z.\<forall>(x::'a::{linorder,plus,Rings.dvd})<z. (d dvd x + s) = (d dvd x + s)"
+ "\<exists>z.\<forall>(x::'a::{linorder,plus,Rings.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
"\<exists>z.\<forall>x<z. F = F"
by ((erule exE, erule exE,rule_tac x="min z za" in exI,simp)+, (rule_tac x="t" in exI,fastsimp)+) simp_all
@@ -46,8 +46,8 @@
"\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<le> t) = False"
"\<exists>(z ::'a::{linorder}).\<forall>x>z.(x > t) = True"
"\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<ge> t) = True"
- "\<exists>z.\<forall>(x::'a::{linorder,plus,Ring_and_Field.dvd})>z. (d dvd x + s) = (d dvd x + s)"
- "\<exists>z.\<forall>(x::'a::{linorder,plus,Ring_and_Field.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
+ "\<exists>z.\<forall>(x::'a::{linorder,plus,Rings.dvd})>z. (d dvd x + s) = (d dvd x + s)"
+ "\<exists>z.\<forall>(x::'a::{linorder,plus,Rings.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
"\<exists>z.\<forall>x>z. F = F"
by ((erule exE, erule exE,rule_tac x="max z za" in exI,simp)+,(rule_tac x="t" in exI,fastsimp)+) simp_all
@@ -56,8 +56,8 @@
\<Longrightarrow> \<forall>x k. (P x \<and> Q x) = (P (x - k*D) \<and> Q (x - k*D))"
"\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
\<Longrightarrow> \<forall>x k. (P x \<or> Q x) = (P (x - k*D) \<or> Q (x - k*D))"
- "(d::'a::{comm_ring,Ring_and_Field.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
- "(d::'a::{comm_ring,Ring_and_Field.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
+ "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
+ "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
"\<forall>x k. F = F"
apply (auto elim!: dvdE simp add: algebra_simps)
unfolding mult_assoc [symmetric] left_distrib [symmetric] left_diff_distrib [symmetric]
@@ -199,16 +199,16 @@
hence "P 0" using P Pmod by simp
moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
ultimately have "P d" by simp
- moreover have "d : {1..d}" using dpos by(simp add:atLeastAtMost_iff)
+ moreover have "d : {1..d}" using dpos by simp
ultimately show ?RHS ..
next
assume not0: "x mod d \<noteq> 0"
- have "P(x mod d)" using dpos P Pmod by(simp add:pos_mod_sign pos_mod_bound)
+ have "P(x mod d)" using dpos P Pmod by simp
moreover have "x mod d : {1..d}"
proof -
from dpos have "0 \<le> x mod d" by(rule pos_mod_sign)
moreover from dpos have "x mod d < d" by(rule pos_mod_bound)
- ultimately show ?thesis using not0 by(simp add:atLeastAtMost_iff)
+ ultimately show ?thesis using not0 by simp
qed
ultimately show ?RHS ..
qed
@@ -243,7 +243,7 @@
{fix x
have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)" using minus[THEN spec, of "x - i * d"]
- by (simp add:int_distrib OrderedGroup.diff_diff_eq[symmetric])
+ by (simp add: algebra_simps)
ultimately have "P x \<longrightarrow> P(x - (i + 1) * d)" by blast}
thus ?case ..
qed
@@ -360,7 +360,7 @@
apply(fastsimp)
done
-theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Ring_and_Field.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
+theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Rings.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
apply (rule eq_reflection [symmetric])
apply (rule iffI)
defer
--- a/src/HOL/Probability/Borel.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Probability/Borel.thy Fri Feb 19 15:21:57 2010 +0000
@@ -73,7 +73,7 @@
with w have "real(Suc(natceiling(inverse(g w - f w)))) > inverse(g w - f w)"
by (metis lessI order_le_less_trans real_natceiling_ge real_of_nat_less_iff) hence "inverse(real(Suc(natceiling(inverse(g w - f w)))))
< inverse(inverse(g w - f w))"
- by (metis less_iff_diff_less_0 less_imp_inverse_less linorder_neqE_ordered_idom nz positive_imp_inverse_positive real_le_antisym real_less_def w)
+ by (metis less_iff_diff_less_0 less_imp_inverse_less linorder_neqE_linordered_idom nz positive_imp_inverse_positive real_le_antisym real_less_def w)
hence "inverse(real(Suc(natceiling(inverse(g w - f w))))) < g w - f w"
by (metis inverse_inverse_eq order_less_le_trans real_le_refl)
thus "\<exists>n. f w \<le> g w - inverse(real(Suc n))" using w
@@ -355,7 +355,7 @@
borel_measurable_add_borel_measurable f g)
have "(\<lambda>x. -((f x + -g x) ^ 2 * inverse 4)) =
(\<lambda>x. 0 + ((f x + -g x) ^ 2 * inverse -4))"
- by (simp add: Ring_and_Field.minus_divide_right)
+ by (simp add: minus_divide_right)
also have "... \<in> borel_measurable M"
by (fast intro: affine_borel_measurable borel_measurable_square
borel_measurable_add_borel_measurable
--- a/src/HOL/Product_Type.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Product_Type.thy Fri Feb 19 15:21:57 2010 +0000
@@ -180,65 +180,81 @@
"_patterns" :: "[pttrn, patterns] => patterns" ("_,/ _")
translations
- "(x, y)" == "Pair x y"
+ "(x, y)" == "CONST Pair x y"
"_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))"
- "%(x,y,zs).b" == "split(%x (y,zs).b)"
- "%(x,y).b" == "split(%x y. b)"
- "_abs (Pair x y) t" => "%(x,y).t"
+ "%(x, y, zs). b" == "CONST split (%x (y, zs). b)"
+ "%(x, y). b" == "CONST split (%x y. b)"
+ "_abs (CONST Pair x y) t" => "%(x, y). t"
(* The last rule accommodates tuples in `case C ... (x,y) ... => ...'
The (x,y) is parsed as `Pair x y' because it is logic, not pttrn *)
-(* reconstructs pattern from (nested) splits, avoiding eta-contraction of body*)
-(* works best with enclosing "let", if "let" does not avoid eta-contraction *)
+(*reconstruct pattern from (nested) splits, avoiding eta-contraction of body;
+ works best with enclosing "let", if "let" does not avoid eta-contraction*)
print_translation {*
-let fun split_tr' [Abs (x,T,t as (Abs abs))] =
- (* split (%x y. t) => %(x,y) t *)
- let val (y,t') = atomic_abs_tr' abs;
- val (x',t'') = atomic_abs_tr' (x,T,t');
-
- in Syntax.const "_abs" $ (Syntax.const "_pattern" $x'$y) $ t'' end
- | split_tr' [Abs (x,T,(s as Const ("split",_)$t))] =
- (* split (%x. (split (%y z. t))) => %(x,y,z). t *)
- let val (Const ("_abs",_)$(Const ("_pattern",_)$y$z)$t') = split_tr' [t];
- val (x',t'') = atomic_abs_tr' (x,T,t');
- in Syntax.const "_abs"$
- (Syntax.const "_pattern"$x'$(Syntax.const "_patterns"$y$z))$t'' end
- | split_tr' [Const ("split",_)$t] =
- (* split (split (%x y z. t)) => %((x,y),z). t *)
- split_tr' [(split_tr' [t])] (* inner split_tr' creates next pattern *)
- | split_tr' [Const ("_abs",_)$x_y$(Abs abs)] =
- (* split (%pttrn z. t) => %(pttrn,z). t *)
- let val (z,t) = atomic_abs_tr' abs;
- in Syntax.const "_abs" $ (Syntax.const "_pattern" $x_y$z) $ t end
- | split_tr' _ = raise Match;
-in [("split", split_tr')]
-end
+let
+ fun split_tr' [Abs (x, T, t as (Abs abs))] =
+ (* split (%x y. t) => %(x,y) t *)
+ let
+ val (y, t') = atomic_abs_tr' abs;
+ val (x', t'') = atomic_abs_tr' (x, T, t');
+ in
+ Syntax.const @{syntax_const "_abs"} $
+ (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
+ end
+ | split_tr' [Abs (x, T, (s as Const (@{const_syntax split}, _) $ t))] =
+ (* split (%x. (split (%y z. t))) => %(x,y,z). t *)
+ let
+ val Const (@{syntax_const "_abs"}, _) $
+ (Const (@{syntax_const "_pattern"}, _) $ y $ z) $ t' = split_tr' [t];
+ val (x', t'') = atomic_abs_tr' (x, T, t');
+ in
+ Syntax.const @{syntax_const "_abs"} $
+ (Syntax.const @{syntax_const "_pattern"} $ x' $
+ (Syntax.const @{syntax_const "_patterns"} $ y $ z)) $ t''
+ end
+ | split_tr' [Const (@{const_syntax split}, _) $ t] =
+ (* split (split (%x y z. t)) => %((x, y), z). t *)
+ split_tr' [(split_tr' [t])] (* inner split_tr' creates next pattern *)
+ | split_tr' [Const (@{syntax_const "_abs"}, _) $ x_y $ Abs abs] =
+ (* split (%pttrn z. t) => %(pttrn,z). t *)
+ let val (z, t) = atomic_abs_tr' abs in
+ Syntax.const @{syntax_const "_abs"} $
+ (Syntax.const @{syntax_const "_pattern"} $ x_y $ z) $ t
+ end
+ | split_tr' _ = raise Match;
+in [(@{const_syntax split}, split_tr')] end
*}
(* print "split f" as "\<lambda>(x,y). f x y" and "split (\<lambda>x. f x)" as "\<lambda>(x,y). f x y" *)
typed_print_translation {*
let
- fun split_guess_names_tr' _ T [Abs (x,_,Abs _)] = raise Match
- | split_guess_names_tr' _ T [Abs (x,xT,t)] =
+ fun split_guess_names_tr' _ T [Abs (x, _, Abs _)] = raise Match
+ | split_guess_names_tr' _ T [Abs (x, xT, t)] =
(case (head_of t) of
- Const ("split",_) => raise Match
- | _ => let
- val (_::yT::_) = binder_types (domain_type T) handle Bind => raise Match;
- val (y,t') = atomic_abs_tr' ("y",yT,(incr_boundvars 1 t)$Bound 0);
- val (x',t'') = atomic_abs_tr' (x,xT,t');
- in Syntax.const "_abs" $ (Syntax.const "_pattern" $x'$y) $ t'' end)
+ Const (@{const_syntax split}, _) => raise Match
+ | _ =>
+ let
+ val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
+ val (y, t') = atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0);
+ val (x', t'') = atomic_abs_tr' (x, xT, t');
+ in
+ Syntax.const @{syntax_const "_abs"} $
+ (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
+ end)
| split_guess_names_tr' _ T [t] =
- (case (head_of t) of
- Const ("split",_) => raise Match
- | _ => let
- val (xT::yT::_) = binder_types (domain_type T) handle Bind => raise Match;
- val (y,t') =
- atomic_abs_tr' ("y",yT,(incr_boundvars 2 t)$Bound 1$Bound 0);
- val (x',t'') = atomic_abs_tr' ("x",xT,t');
- in Syntax.const "_abs" $ (Syntax.const "_pattern" $x'$y) $ t'' end)
+ (case head_of t of
+ Const (@{const_syntax split}, _) => raise Match
+ | _ =>
+ let
+ val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
+ val (y, t') = atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0);
+ val (x', t'') = atomic_abs_tr' ("x", xT, t');
+ in
+ Syntax.const @{syntax_const "_abs"} $
+ (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t''
+ end)
| split_guess_names_tr' _ _ _ = raise Match;
-in [("split", split_guess_names_tr')]
-end
+in [(@{const_syntax split}, split_guess_names_tr')] end
*}
@@ -855,10 +871,9 @@
Times (infixr "\<times>" 80)
syntax
- "@Sigma" ::"[pttrn, 'a set, 'b set] => ('a * 'b) set" ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
-
+ "_Sigma" :: "[pttrn, 'a set, 'b set] => ('a * 'b) set" ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
translations
- "SIGMA x:A. B" == "Product_Type.Sigma A (%x. B)"
+ "SIGMA x:A. B" == "CONST Sigma A (%x. B)"
lemma SigmaI [intro!]: "[| a:A; b:B(a) |] ==> (a,b) : Sigma A B"
by (unfold Sigma_def) blast
--- a/src/HOL/Prolog/Test.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Prolog/Test.thy Fri Feb 19 15:21:57 2010 +0000
@@ -18,7 +18,7 @@
syntax
(* list Enumeration *)
- "@list" :: "args => 'a list" ("[(_)]")
+ "_list" :: "args => 'a list" ("[(_)]")
translations
"[x, xs]" == "x#[xs]"
--- a/src/HOL/Quickcheck.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Quickcheck.thy Fri Feb 19 15:21:57 2010 +0000
@@ -164,7 +164,7 @@
where
"union R1 R2 = (\<lambda>s. let
(P1, s') = R1 s; (P2, s'') = R2 s'
- in (upper_semilattice_class.sup P1 P2, s''))"
+ in (semilattice_sup_class.sup P1 P2, s''))"
definition if_randompred :: "bool \<Rightarrow> unit randompred"
where
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Quotient.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,797 @@
+(* Title: Quotient.thy
+ Author: Cezary Kaliszyk and Christian Urban
+*)
+
+theory Quotient
+imports Plain ATP_Linkup
+uses
+ ("~~/src/HOL/Tools/Quotient/quotient_info.ML")
+ ("~~/src/HOL/Tools/Quotient/quotient_typ.ML")
+ ("~~/src/HOL/Tools/Quotient/quotient_def.ML")
+ ("~~/src/HOL/Tools/Quotient/quotient_term.ML")
+ ("~~/src/HOL/Tools/Quotient/quotient_tacs.ML")
+begin
+
+
+text {*
+ Basic definition for equivalence relations
+ that are represented by predicates.
+*}
+
+definition
+ "equivp E \<equiv> \<forall>x y. E x y = (E x = E y)"
+
+definition
+ "reflp E \<equiv> \<forall>x. E x x"
+
+definition
+ "symp E \<equiv> \<forall>x y. E x y \<longrightarrow> E y x"
+
+definition
+ "transp E \<equiv> \<forall>x y z. E x y \<and> E y z \<longrightarrow> E x z"
+
+lemma equivp_reflp_symp_transp:
+ shows "equivp E = (reflp E \<and> symp E \<and> transp E)"
+ unfolding equivp_def reflp_def symp_def transp_def expand_fun_eq
+ by blast
+
+lemma equivp_reflp:
+ shows "equivp E \<Longrightarrow> E x x"
+ by (simp only: equivp_reflp_symp_transp reflp_def)
+
+lemma equivp_symp:
+ shows "equivp E \<Longrightarrow> E x y \<Longrightarrow> E y x"
+ by (metis equivp_reflp_symp_transp symp_def)
+
+lemma equivp_transp:
+ shows "equivp E \<Longrightarrow> E x y \<Longrightarrow> E y z \<Longrightarrow> E x z"
+ by (metis equivp_reflp_symp_transp transp_def)
+
+lemma equivpI:
+ assumes "reflp R" "symp R" "transp R"
+ shows "equivp R"
+ using assms by (simp add: equivp_reflp_symp_transp)
+
+lemma identity_equivp:
+ shows "equivp (op =)"
+ unfolding equivp_def
+ by auto
+
+text {* Partial equivalences: not yet used anywhere *}
+
+definition
+ "part_equivp E \<equiv> (\<exists>x. E x x) \<and> (\<forall>x y. E x y = (E x x \<and> E y y \<and> (E x = E y)))"
+
+lemma equivp_implies_part_equivp:
+ assumes a: "equivp E"
+ shows "part_equivp E"
+ using a
+ unfolding equivp_def part_equivp_def
+ by auto
+
+text {* Composition of Relations *}
+
+abbreviation
+ rel_conj (infixr "OOO" 75)
+where
+ "r1 OOO r2 \<equiv> r1 OO r2 OO r1"
+
+lemma eq_comp_r:
+ shows "((op =) OOO R) = R"
+ by (auto simp add: expand_fun_eq)
+
+section {* Respects predicate *}
+
+definition
+ Respects
+where
+ "Respects R x \<equiv> R x x"
+
+lemma in_respects:
+ shows "(x \<in> Respects R) = R x x"
+ unfolding mem_def Respects_def
+ by simp
+
+section {* Function map and function relation *}
+
+definition
+ fun_map (infixr "--->" 55)
+where
+[simp]: "fun_map f g h x = g (h (f x))"
+
+definition
+ fun_rel (infixr "===>" 55)
+where
+[simp]: "fun_rel E1 E2 f g = (\<forall>x y. E1 x y \<longrightarrow> E2 (f x) (g y))"
+
+
+lemma fun_map_id:
+ shows "(id ---> id) = id"
+ by (simp add: expand_fun_eq id_def)
+
+lemma fun_rel_eq:
+ shows "((op =) ===> (op =)) = (op =)"
+ by (simp add: expand_fun_eq)
+
+lemma fun_rel_id:
+ assumes a: "\<And>x y. R1 x y \<Longrightarrow> R2 (f x) (g y)"
+ shows "(R1 ===> R2) f g"
+ using a by simp
+
+lemma fun_rel_id_asm:
+ assumes a: "\<And>x y. R1 x y \<Longrightarrow> (A \<longrightarrow> R2 (f x) (g y))"
+ shows "A \<longrightarrow> (R1 ===> R2) f g"
+ using a by auto
+
+
+section {* Quotient Predicate *}
+
+definition
+ "Quotient E Abs Rep \<equiv>
+ (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. E (Rep a) (Rep a)) \<and>
+ (\<forall>r s. E r s = (E r r \<and> E s s \<and> (Abs r = Abs s)))"
+
+lemma Quotient_abs_rep:
+ assumes a: "Quotient E Abs Rep"
+ shows "Abs (Rep a) = a"
+ using a
+ unfolding Quotient_def
+ by simp
+
+lemma Quotient_rep_reflp:
+ assumes a: "Quotient E Abs Rep"
+ shows "E (Rep a) (Rep a)"
+ using a
+ unfolding Quotient_def
+ by blast
+
+lemma Quotient_rel:
+ assumes a: "Quotient E Abs Rep"
+ shows " E r s = (E r r \<and> E s s \<and> (Abs r = Abs s))"
+ using a
+ unfolding Quotient_def
+ by blast
+
+lemma Quotient_rel_rep:
+ assumes a: "Quotient R Abs Rep"
+ shows "R (Rep a) (Rep b) = (a = b)"
+ using a
+ unfolding Quotient_def
+ by metis
+
+lemma Quotient_rep_abs:
+ assumes a: "Quotient R Abs Rep"
+ shows "R r r \<Longrightarrow> R (Rep (Abs r)) r"
+ using a unfolding Quotient_def
+ by blast
+
+lemma Quotient_rel_abs:
+ assumes a: "Quotient E Abs Rep"
+ shows "E r s \<Longrightarrow> Abs r = Abs s"
+ using a unfolding Quotient_def
+ by blast
+
+lemma Quotient_symp:
+ assumes a: "Quotient E Abs Rep"
+ shows "symp E"
+ using a unfolding Quotient_def symp_def
+ by metis
+
+lemma Quotient_transp:
+ assumes a: "Quotient E Abs Rep"
+ shows "transp E"
+ using a unfolding Quotient_def transp_def
+ by metis
+
+lemma identity_quotient:
+ shows "Quotient (op =) id id"
+ unfolding Quotient_def id_def
+ by blast
+
+lemma fun_quotient:
+ assumes q1: "Quotient R1 abs1 rep1"
+ and q2: "Quotient R2 abs2 rep2"
+ shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
+proof -
+ have "\<forall>a. (rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
+ using q1 q2
+ unfolding Quotient_def
+ unfolding expand_fun_eq
+ by simp
+ moreover
+ have "\<forall>a. (R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
+ using q1 q2
+ unfolding Quotient_def
+ by (simp (no_asm)) (metis)
+ moreover
+ have "\<forall>r s. (R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
+ (rep1 ---> abs2) r = (rep1 ---> abs2) s)"
+ unfolding expand_fun_eq
+ apply(auto)
+ using q1 q2 unfolding Quotient_def
+ apply(metis)
+ using q1 q2 unfolding Quotient_def
+ apply(metis)
+ using q1 q2 unfolding Quotient_def
+ apply(metis)
+ using q1 q2 unfolding Quotient_def
+ apply(metis)
+ done
+ ultimately
+ show "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
+ unfolding Quotient_def by blast
+qed
+
+lemma abs_o_rep:
+ assumes a: "Quotient R Abs Rep"
+ shows "Abs o Rep = id"
+ unfolding expand_fun_eq
+ by (simp add: Quotient_abs_rep[OF a])
+
+lemma equals_rsp:
+ assumes q: "Quotient R Abs Rep"
+ and a: "R xa xb" "R ya yb"
+ shows "R xa ya = R xb yb"
+ using a Quotient_symp[OF q] Quotient_transp[OF q]
+ unfolding symp_def transp_def
+ by blast
+
+lemma lambda_prs:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
+ unfolding expand_fun_eq
+ using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
+ by simp
+
+lemma lambda_prs1:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
+ unfolding expand_fun_eq
+ using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]
+ by simp
+
+lemma rep_abs_rsp:
+ assumes q: "Quotient R Abs Rep"
+ and a: "R x1 x2"
+ shows "R x1 (Rep (Abs x2))"
+ using a Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q]
+ by metis
+
+lemma rep_abs_rsp_left:
+ assumes q: "Quotient R Abs Rep"
+ and a: "R x1 x2"
+ shows "R (Rep (Abs x1)) x2"
+ using a Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q]
+ by metis
+
+text{*
+ In the following theorem R1 can be instantiated with anything,
+ but we know some of the types of the Rep and Abs functions;
+ so by solving Quotient assumptions we can get a unique R1 that
+ will be provable; which is why we need to use apply_rsp and
+ not the primed version *}
+
+lemma apply_rsp:
+ fixes f g::"'a \<Rightarrow> 'c"
+ assumes q: "Quotient R1 Abs1 Rep1"
+ and a: "(R1 ===> R2) f g" "R1 x y"
+ shows "R2 (f x) (g y)"
+ using a by simp
+
+lemma apply_rsp':
+ assumes a: "(R1 ===> R2) f g" "R1 x y"
+ shows "R2 (f x) (g y)"
+ using a by simp
+
+section {* lemmas for regularisation of ball and bex *}
+
+lemma ball_reg_eqv:
+ fixes P :: "'a \<Rightarrow> bool"
+ assumes a: "equivp R"
+ shows "Ball (Respects R) P = (All P)"
+ using a
+ unfolding equivp_def
+ by (auto simp add: in_respects)
+
+lemma bex_reg_eqv:
+ fixes P :: "'a \<Rightarrow> bool"
+ assumes a: "equivp R"
+ shows "Bex (Respects R) P = (Ex P)"
+ using a
+ unfolding equivp_def
+ by (auto simp add: in_respects)
+
+lemma ball_reg_right:
+ assumes a: "\<And>x. R x \<Longrightarrow> P x \<longrightarrow> Q x"
+ shows "All P \<longrightarrow> Ball R Q"
+ using a by (metis COMBC_def Collect_def Collect_mem_eq)
+
+lemma bex_reg_left:
+ assumes a: "\<And>x. R x \<Longrightarrow> Q x \<longrightarrow> P x"
+ shows "Bex R Q \<longrightarrow> Ex P"
+ using a by (metis COMBC_def Collect_def Collect_mem_eq)
+
+lemma ball_reg_left:
+ assumes a: "equivp R"
+ shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
+ using a by (metis equivp_reflp in_respects)
+
+lemma bex_reg_right:
+ assumes a: "equivp R"
+ shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
+ using a by (metis equivp_reflp in_respects)
+
+lemma ball_reg_eqv_range:
+ fixes P::"'a \<Rightarrow> bool"
+ and x::"'a"
+ assumes a: "equivp R2"
+ shows "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
+ apply(rule iffI)
+ apply(rule allI)
+ apply(drule_tac x="\<lambda>y. f x" in bspec)
+ apply(simp add: in_respects)
+ apply(rule impI)
+ using a equivp_reflp_symp_transp[of "R2"]
+ apply(simp add: reflp_def)
+ apply(simp)
+ apply(simp)
+ done
+
+lemma bex_reg_eqv_range:
+ assumes a: "equivp R2"
+ shows "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
+ apply(auto)
+ apply(rule_tac x="\<lambda>y. f x" in bexI)
+ apply(simp)
+ apply(simp add: Respects_def in_respects)
+ apply(rule impI)
+ using a equivp_reflp_symp_transp[of "R2"]
+ apply(simp add: reflp_def)
+ done
+
+(* Next four lemmas are unused *)
+lemma all_reg:
+ assumes a: "!x :: 'a. (P x --> Q x)"
+ and b: "All P"
+ shows "All Q"
+ using a b by (metis)
+
+lemma ex_reg:
+ assumes a: "!x :: 'a. (P x --> Q x)"
+ and b: "Ex P"
+ shows "Ex Q"
+ using a b by metis
+
+lemma ball_reg:
+ assumes a: "!x :: 'a. (R x --> P x --> Q x)"
+ and b: "Ball R P"
+ shows "Ball R Q"
+ using a b by (metis COMBC_def Collect_def Collect_mem_eq)
+
+lemma bex_reg:
+ assumes a: "!x :: 'a. (R x --> P x --> Q x)"
+ and b: "Bex R P"
+ shows "Bex R Q"
+ using a b by (metis COMBC_def Collect_def Collect_mem_eq)
+
+
+lemma ball_all_comm:
+ assumes "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
+ shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
+ using assms by auto
+
+lemma bex_ex_comm:
+ assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
+ shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
+ using assms by auto
+
+section {* Bounded abstraction *}
+
+definition
+ Babs :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
+where
+ "x \<in> p \<Longrightarrow> Babs p m x = m x"
+
+lemma babs_rsp:
+ assumes q: "Quotient R1 Abs1 Rep1"
+ and a: "(R1 ===> R2) f g"
+ shows "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
+ apply (auto simp add: Babs_def in_respects)
+ apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
+ using a apply (simp add: Babs_def)
+ apply (simp add: in_respects)
+ using Quotient_rel[OF q]
+ by metis
+
+lemma babs_prs:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f"
+ apply (rule ext)
+ apply (simp)
+ apply (subgoal_tac "Rep1 x \<in> Respects R1")
+ apply (simp add: Babs_def Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2])
+ apply (simp add: in_respects Quotient_rel_rep[OF q1])
+ done
+
+lemma babs_simp:
+ assumes q: "Quotient R1 Abs Rep"
+ shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)"
+ apply(rule iffI)
+ apply(simp_all only: babs_rsp[OF q])
+ apply(auto simp add: Babs_def)
+ apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
+ apply(metis Babs_def)
+ apply (simp add: in_respects)
+ using Quotient_rel[OF q]
+ by metis
+
+(* If a user proves that a particular functional relation
+ is an equivalence this may be useful in regularising *)
+lemma babs_reg_eqv:
+ shows "equivp R \<Longrightarrow> Babs (Respects R) P = P"
+ by (simp add: expand_fun_eq Babs_def in_respects equivp_reflp)
+
+
+(* 3 lemmas needed for proving repabs_inj *)
+lemma ball_rsp:
+ assumes a: "(R ===> (op =)) f g"
+ shows "Ball (Respects R) f = Ball (Respects R) g"
+ using a by (simp add: Ball_def in_respects)
+
+lemma bex_rsp:
+ assumes a: "(R ===> (op =)) f g"
+ shows "(Bex (Respects R) f = Bex (Respects R) g)"
+ using a by (simp add: Bex_def in_respects)
+
+lemma bex1_rsp:
+ assumes a: "(R ===> (op =)) f g"
+ shows "Ex1 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> g x)"
+ using a
+ by (simp add: Ex1_def in_respects) auto
+
+(* 2 lemmas needed for cleaning of quantifiers *)
+lemma all_prs:
+ assumes a: "Quotient R absf repf"
+ shows "Ball (Respects R) ((absf ---> id) f) = All f"
+ using a unfolding Quotient_def Ball_def in_respects fun_map_def id_apply
+ by metis
+
+lemma ex_prs:
+ assumes a: "Quotient R absf repf"
+ shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
+ using a unfolding Quotient_def Bex_def in_respects fun_map_def id_apply
+ by metis
+
+section {* Bex1_rel quantifier *}
+
+definition
+ Bex1_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
+where
+ "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"
+
+lemma bex1_rel_aux:
+ "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> Bex1_rel R y"
+ unfolding Bex1_rel_def
+ apply (erule conjE)+
+ apply (erule bexE)
+ apply rule
+ apply (rule_tac x="xa" in bexI)
+ apply metis
+ apply metis
+ apply rule+
+ apply (erule_tac x="xaa" in ballE)
+ prefer 2
+ apply (metis)
+ apply (erule_tac x="ya" in ballE)
+ prefer 2
+ apply (metis)
+ apply (metis in_respects)
+ done
+
+lemma bex1_rel_aux2:
+ "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> Bex1_rel R x"
+ unfolding Bex1_rel_def
+ apply (erule conjE)+
+ apply (erule bexE)
+ apply rule
+ apply (rule_tac x="xa" in bexI)
+ apply metis
+ apply metis
+ apply rule+
+ apply (erule_tac x="xaa" in ballE)
+ prefer 2
+ apply (metis)
+ apply (erule_tac x="ya" in ballE)
+ prefer 2
+ apply (metis)
+ apply (metis in_respects)
+ done
+
+lemma bex1_rel_rsp:
+ assumes a: "Quotient R absf repf"
+ shows "((R ===> op =) ===> op =) (Bex1_rel R) (Bex1_rel R)"
+ apply simp
+ apply clarify
+ apply rule
+ apply (simp_all add: bex1_rel_aux bex1_rel_aux2)
+ apply (erule bex1_rel_aux2)
+ apply assumption
+ done
+
+
+lemma ex1_prs:
+ assumes a: "Quotient R absf repf"
+ shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f"
+apply simp
+apply (subst Bex1_rel_def)
+apply (subst Bex_def)
+apply (subst Ex1_def)
+apply simp
+apply rule
+ apply (erule conjE)+
+ apply (erule_tac exE)
+ apply (erule conjE)
+ apply (subgoal_tac "\<forall>y. R y y \<longrightarrow> f (absf y) \<longrightarrow> R x y")
+ apply (rule_tac x="absf x" in exI)
+ apply (simp)
+ apply rule+
+ using a unfolding Quotient_def
+ apply metis
+ apply rule+
+ apply (erule_tac x="x" in ballE)
+ apply (erule_tac x="y" in ballE)
+ apply simp
+ apply (simp add: in_respects)
+ apply (simp add: in_respects)
+apply (erule_tac exE)
+ apply rule
+ apply (rule_tac x="repf x" in exI)
+ apply (simp only: in_respects)
+ apply rule
+ apply (metis Quotient_rel_rep[OF a])
+using a unfolding Quotient_def apply (simp)
+apply rule+
+using a unfolding Quotient_def in_respects
+apply metis
+done
+
+lemma bex1_bexeq_reg: "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>x. P x))"
+ apply (simp add: Ex1_def Bex1_rel_def in_respects)
+ apply clarify
+ apply auto
+ apply (rule bexI)
+ apply assumption
+ apply (simp add: in_respects)
+ apply (simp add: in_respects)
+ apply auto
+ done
+
+section {* Various respects and preserve lemmas *}
+
+lemma quot_rel_rsp:
+ assumes a: "Quotient R Abs Rep"
+ shows "(R ===> R ===> op =) R R"
+ apply(rule fun_rel_id)+
+ apply(rule equals_rsp[OF a])
+ apply(assumption)+
+ done
+
+lemma o_prs:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ and q3: "Quotient R3 Abs3 Rep3"
+ shows "(Rep1 ---> Abs3) (((Abs2 ---> Rep3) f) o ((Abs1 ---> Rep2) g)) = f o g"
+ using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_abs_rep[OF q3]
+ unfolding o_def expand_fun_eq by simp
+
+lemma o_rsp:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ and q3: "Quotient R3 Abs3 Rep3"
+ and a1: "(R2 ===> R3) f1 f2"
+ and a2: "(R1 ===> R2) g1 g2"
+ shows "(R1 ===> R3) (f1 o g1) (f2 o g2)"
+ using a1 a2 unfolding o_def expand_fun_eq
+ by (auto)
+
+lemma cond_prs:
+ assumes a: "Quotient R absf repf"
+ shows "absf (if a then repf b else repf c) = (if a then b else c)"
+ using a unfolding Quotient_def by auto
+
+lemma if_prs:
+ assumes q: "Quotient R Abs Rep"
+ shows "Abs (If a (Rep b) (Rep c)) = If a b c"
+ using Quotient_abs_rep[OF q] by auto
+
+(* q not used *)
+lemma if_rsp:
+ assumes q: "Quotient R Abs Rep"
+ and a: "a1 = a2" "R b1 b2" "R c1 c2"
+ shows "R (If a1 b1 c1) (If a2 b2 c2)"
+ using a by auto
+
+lemma let_prs:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and q2: "Quotient R2 Abs2 Rep2"
+ shows "Abs2 (Let (Rep1 x) ((Abs1 ---> Rep2) f)) = Let x f"
+ using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] by auto
+
+lemma let_rsp:
+ assumes q1: "Quotient R1 Abs1 Rep1"
+ and a1: "(R1 ===> R2) f g"
+ and a2: "R1 x y"
+ shows "R2 ((Let x f)::'c) ((Let y g)::'c)"
+ using apply_rsp[OF q1 a1] a2 by auto
+
+locale quot_type =
+ fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+ and Abs :: "('a \<Rightarrow> bool) \<Rightarrow> 'b"
+ and Rep :: "'b \<Rightarrow> ('a \<Rightarrow> bool)"
+ assumes equivp: "equivp R"
+ and rep_prop: "\<And>y. \<exists>x. Rep y = R x"
+ and rep_inverse: "\<And>x. Abs (Rep x) = x"
+ and abs_inverse: "\<And>x. (Rep (Abs (R x))) = (R x)"
+ and rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
+begin
+
+definition
+ abs::"'a \<Rightarrow> 'b"
+where
+ "abs x \<equiv> Abs (R x)"
+
+definition
+ rep::"'b \<Rightarrow> 'a"
+where
+ "rep a = Eps (Rep a)"
+
+lemma homeier_lem9:
+ shows "R (Eps (R x)) = R x"
+proof -
+ have a: "R x x" using equivp by (simp add: equivp_reflp_symp_transp reflp_def)
+ then have "R x (Eps (R x))" by (rule someI)
+ then show "R (Eps (R x)) = R x"
+ using equivp unfolding equivp_def by simp
+qed
+
+theorem homeier_thm10:
+ shows "abs (rep a) = a"
+ unfolding abs_def rep_def
+proof -
+ from rep_prop
+ obtain x where eq: "Rep a = R x" by auto
+ have "Abs (R (Eps (Rep a))) = Abs (R (Eps (R x)))" using eq by simp
+ also have "\<dots> = Abs (R x)" using homeier_lem9 by simp
+ also have "\<dots> = Abs (Rep a)" using eq by simp
+ also have "\<dots> = a" using rep_inverse by simp
+ finally
+ show "Abs (R (Eps (Rep a))) = a" by simp
+qed
+
+lemma homeier_lem7:
+ shows "(R x = R y) = (Abs (R x) = Abs (R y))" (is "?LHS = ?RHS")
+proof -
+ have "?RHS = (Rep (Abs (R x)) = Rep (Abs (R y)))" by (simp add: rep_inject)
+ also have "\<dots> = ?LHS" by (simp add: abs_inverse)
+ finally show "?LHS = ?RHS" by simp
+qed
+
+theorem homeier_thm11:
+ shows "R r r' = (abs r = abs r')"
+ unfolding abs_def
+ by (simp only: equivp[simplified equivp_def] homeier_lem7)
+
+lemma rep_refl:
+ shows "R (rep a) (rep a)"
+ unfolding rep_def
+ by (simp add: equivp[simplified equivp_def])
+
+
+lemma rep_abs_rsp:
+ shows "R f (rep (abs g)) = R f g"
+ and "R (rep (abs g)) f = R g f"
+ by (simp_all add: homeier_thm10 homeier_thm11)
+
+lemma Quotient:
+ shows "Quotient R abs rep"
+ unfolding Quotient_def
+ apply(simp add: homeier_thm10)
+ apply(simp add: rep_refl)
+ apply(subst homeier_thm11[symmetric])
+ apply(simp add: equivp[simplified equivp_def])
+ done
+
+end
+
+section {* ML setup *}
+
+text {* Auxiliary data for the quotient package *}
+
+use "~~/src/HOL/Tools/Quotient/quotient_info.ML"
+
+declare [[map "fun" = (fun_map, fun_rel)]]
+
+lemmas [quot_thm] = fun_quotient
+lemmas [quot_respect] = quot_rel_rsp
+lemmas [quot_equiv] = identity_equivp
+
+
+text {* Lemmas about simplifying id's. *}
+lemmas [id_simps] =
+ id_def[symmetric]
+ fun_map_id
+ id_apply
+ id_o
+ o_id
+ eq_comp_r
+
+text {* Translation functions for the lifting process. *}
+use "~~/src/HOL/Tools/Quotient/quotient_term.ML"
+
+
+text {* Definitions of the quotient types. *}
+use "~~/src/HOL/Tools/Quotient/quotient_typ.ML"
+
+
+text {* Definitions for quotient constants. *}
+use "~~/src/HOL/Tools/Quotient/quotient_def.ML"
+
+
+text {*
+ An auxiliary constant for recording some information
+ about the lifted theorem in a tactic.
+*}
+definition
+ "Quot_True x \<equiv> True"
+
+lemma
+ shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
+ and QT_ex: "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
+ and QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
+ and QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
+ and QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
+ by (simp_all add: Quot_True_def ext)
+
+lemma QT_imp: "Quot_True a \<equiv> Quot_True b"
+ by (simp add: Quot_True_def)
+
+
+text {* Tactics for proving the lifted theorems *}
+use "~~/src/HOL/Tools/Quotient/quotient_tacs.ML"
+
+section {* Methods / Interface *}
+
+method_setup lifting =
+ {* Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.lift_tac ctxt thms))) *}
+ {* lifts theorems to quotient types *}
+
+method_setup lifting_setup =
+ {* Attrib.thm >> (fn thms => fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.procedure_tac ctxt thms))) *}
+ {* sets up the three goals for the quotient lifting procedure *}
+
+method_setup regularize =
+ {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.regularize_tac ctxt))) *}
+ {* proves the regularization goals from the quotient lifting procedure *}
+
+method_setup injection =
+ {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.all_injection_tac ctxt))) *}
+ {* proves the rep/abs injection goals from the quotient lifting procedure *}
+
+method_setup cleaning =
+ {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.clean_tac ctxt))) *}
+ {* proves the cleaning goals from the quotient lifting procedure *}
+
+attribute_setup quot_lifted =
+ {* Scan.succeed Quotient_Tacs.lifted_attrib *}
+ {* lifts theorems to quotient types *}
+
+no_notation
+ rel_conj (infixr "OOO" 75) and
+ fun_map (infixr "--->" 55) and
+ fun_rel (infixr "===>" 55)
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Quotient_Examples/LarryDatatype.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,394 @@
+theory LarryDatatype
+imports Main Quotient_Syntax
+begin
+
+subsection{*Defining the Free Algebra*}
+
+datatype
+ freemsg = NONCE nat
+ | MPAIR freemsg freemsg
+ | CRYPT nat freemsg
+ | DECRYPT nat freemsg
+
+inductive
+ msgrel::"freemsg \<Rightarrow> freemsg \<Rightarrow> bool" (infixl "\<sim>" 50)
+where
+ CD: "CRYPT K (DECRYPT K X) \<sim> X"
+| DC: "DECRYPT K (CRYPT K X) \<sim> X"
+| NONCE: "NONCE N \<sim> NONCE N"
+| MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
+| CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
+| DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
+| SYM: "X \<sim> Y \<Longrightarrow> Y \<sim> X"
+| TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"
+
+lemmas msgrel.intros[intro]
+
+text{*Proving that it is an equivalence relation*}
+
+lemma msgrel_refl: "X \<sim> X"
+by (induct X, (blast intro: msgrel.intros)+)
+
+theorem equiv_msgrel: "equivp msgrel"
+proof (rule equivpI)
+ show "reflp msgrel" by (simp add: reflp_def msgrel_refl)
+ show "symp msgrel" by (simp add: symp_def, blast intro: msgrel.SYM)
+ show "transp msgrel" by (simp add: transp_def, blast intro: msgrel.TRANS)
+qed
+
+subsection{*Some Functions on the Free Algebra*}
+
+subsubsection{*The Set of Nonces*}
+
+fun
+ freenonces :: "freemsg \<Rightarrow> nat set"
+where
+ "freenonces (NONCE N) = {N}"
+| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
+| "freenonces (CRYPT K X) = freenonces X"
+| "freenonces (DECRYPT K X) = freenonces X"
+
+theorem msgrel_imp_eq_freenonces:
+ assumes a: "U \<sim> V"
+ shows "freenonces U = freenonces V"
+ using a by (induct) (auto)
+
+subsubsection{*The Left Projection*}
+
+text{*A function to return the left part of the top pair in a message. It will
+be lifted to the initial algrebra, to serve as an example of that process.*}
+fun
+ freeleft :: "freemsg \<Rightarrow> freemsg"
+where
+ "freeleft (NONCE N) = NONCE N"
+| "freeleft (MPAIR X Y) = X"
+| "freeleft (CRYPT K X) = freeleft X"
+| "freeleft (DECRYPT K X) = freeleft X"
+
+text{*This theorem lets us prove that the left function respects the
+equivalence relation. It also helps us prove that MPair
+ (the abstract constructor) is injective*}
+lemma msgrel_imp_eqv_freeleft_aux:
+ shows "freeleft U \<sim> freeleft U"
+ by (induct rule: freeleft.induct) (auto)
+
+theorem msgrel_imp_eqv_freeleft:
+ assumes a: "U \<sim> V"
+ shows "freeleft U \<sim> freeleft V"
+ using a
+ by (induct) (auto intro: msgrel_imp_eqv_freeleft_aux)
+
+subsubsection{*The Right Projection*}
+
+text{*A function to return the right part of the top pair in a message.*}
+fun
+ freeright :: "freemsg \<Rightarrow> freemsg"
+where
+ "freeright (NONCE N) = NONCE N"
+| "freeright (MPAIR X Y) = Y"
+| "freeright (CRYPT K X) = freeright X"
+| "freeright (DECRYPT K X) = freeright X"
+
+text{*This theorem lets us prove that the right function respects the
+equivalence relation. It also helps us prove that MPair
+ (the abstract constructor) is injective*}
+lemma msgrel_imp_eqv_freeright_aux:
+ shows "freeright U \<sim> freeright U"
+ by (induct rule: freeright.induct) (auto)
+
+theorem msgrel_imp_eqv_freeright:
+ assumes a: "U \<sim> V"
+ shows "freeright U \<sim> freeright V"
+ using a
+ by (induct) (auto intro: msgrel_imp_eqv_freeright_aux)
+
+subsubsection{*The Discriminator for Constructors*}
+
+text{*A function to distinguish nonces, mpairs and encryptions*}
+fun
+ freediscrim :: "freemsg \<Rightarrow> int"
+where
+ "freediscrim (NONCE N) = 0"
+ | "freediscrim (MPAIR X Y) = 1"
+ | "freediscrim (CRYPT K X) = freediscrim X + 2"
+ | "freediscrim (DECRYPT K X) = freediscrim X - 2"
+
+text{*This theorem helps us prove @{term "Nonce N \<noteq> MPair X Y"}*}
+theorem msgrel_imp_eq_freediscrim:
+ assumes a: "U \<sim> V"
+ shows "freediscrim U = freediscrim V"
+ using a by (induct) (auto)
+
+subsection{*The Initial Algebra: A Quotiented Message Type*}
+
+quotient_type msg = freemsg / msgrel
+ by (rule equiv_msgrel)
+
+text{*The abstract message constructors*}
+
+quotient_definition
+ "Nonce :: nat \<Rightarrow> msg"
+is
+ "NONCE"
+
+quotient_definition
+ "MPair :: msg \<Rightarrow> msg \<Rightarrow> msg"
+is
+ "MPAIR"
+
+quotient_definition
+ "Crypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
+is
+ "CRYPT"
+
+quotient_definition
+ "Decrypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
+is
+ "DECRYPT"
+
+lemma [quot_respect]:
+ shows "(op = ===> op \<sim> ===> op \<sim>) CRYPT CRYPT"
+by (auto intro: CRYPT)
+
+lemma [quot_respect]:
+ shows "(op = ===> op \<sim> ===> op \<sim>) DECRYPT DECRYPT"
+by (auto intro: DECRYPT)
+
+text{*Establishing these two equations is the point of the whole exercise*}
+theorem CD_eq [simp]:
+ shows "Crypt K (Decrypt K X) = X"
+ by (lifting CD)
+
+theorem DC_eq [simp]:
+ shows "Decrypt K (Crypt K X) = X"
+ by (lifting DC)
+
+subsection{*The Abstract Function to Return the Set of Nonces*}
+
+quotient_definition
+ "nonces:: msg \<Rightarrow> nat set"
+is
+ "freenonces"
+
+text{*Now prove the four equations for @{term nonces}*}
+
+lemma [quot_respect]:
+ shows "(op \<sim> ===> op =) freenonces freenonces"
+ by (simp add: msgrel_imp_eq_freenonces)
+
+lemma [quot_respect]:
+ shows "(op = ===> op \<sim>) NONCE NONCE"
+ by (simp add: NONCE)
+
+lemma nonces_Nonce [simp]:
+ shows "nonces (Nonce N) = {N}"
+ by (lifting freenonces.simps(1))
+
+lemma [quot_respect]:
+ shows " (op \<sim> ===> op \<sim> ===> op \<sim>) MPAIR MPAIR"
+ by (simp add: MPAIR)
+
+lemma nonces_MPair [simp]:
+ shows "nonces (MPair X Y) = nonces X \<union> nonces Y"
+ by (lifting freenonces.simps(2))
+
+lemma nonces_Crypt [simp]:
+ shows "nonces (Crypt K X) = nonces X"
+ by (lifting freenonces.simps(3))
+
+lemma nonces_Decrypt [simp]:
+ shows "nonces (Decrypt K X) = nonces X"
+ by (lifting freenonces.simps(4))
+
+subsection{*The Abstract Function to Return the Left Part*}
+
+quotient_definition
+ "left:: msg \<Rightarrow> msg"
+is
+ "freeleft"
+
+lemma [quot_respect]:
+ shows "(op \<sim> ===> op \<sim>) freeleft freeleft"
+ by (simp add: msgrel_imp_eqv_freeleft)
+
+lemma left_Nonce [simp]:
+ shows "left (Nonce N) = Nonce N"
+ by (lifting freeleft.simps(1))
+
+lemma left_MPair [simp]:
+ shows "left (MPair X Y) = X"
+ by (lifting freeleft.simps(2))
+
+lemma left_Crypt [simp]:
+ shows "left (Crypt K X) = left X"
+ by (lifting freeleft.simps(3))
+
+lemma left_Decrypt [simp]:
+ shows "left (Decrypt K X) = left X"
+ by (lifting freeleft.simps(4))
+
+subsection{*The Abstract Function to Return the Right Part*}
+
+quotient_definition
+ "right:: msg \<Rightarrow> msg"
+is
+ "freeright"
+
+text{*Now prove the four equations for @{term right}*}
+
+lemma [quot_respect]:
+ shows "(op \<sim> ===> op \<sim>) freeright freeright"
+ by (simp add: msgrel_imp_eqv_freeright)
+
+lemma right_Nonce [simp]:
+ shows "right (Nonce N) = Nonce N"
+ by (lifting freeright.simps(1))
+
+lemma right_MPair [simp]:
+ shows "right (MPair X Y) = Y"
+ by (lifting freeright.simps(2))
+
+lemma right_Crypt [simp]:
+ shows "right (Crypt K X) = right X"
+ by (lifting freeright.simps(3))
+
+lemma right_Decrypt [simp]:
+ shows "right (Decrypt K X) = right X"
+ by (lifting freeright.simps(4))
+
+subsection{*Injectivity Properties of Some Constructors*}
+
+lemma NONCE_imp_eq:
+ shows "NONCE m \<sim> NONCE n \<Longrightarrow> m = n"
+ by (drule msgrel_imp_eq_freenonces, simp)
+
+text{*Can also be proved using the function @{term nonces}*}
+lemma Nonce_Nonce_eq [iff]:
+ shows "(Nonce m = Nonce n) = (m = n)"
+proof
+ assume "Nonce m = Nonce n"
+ then show "m = n" by (lifting NONCE_imp_eq)
+next
+ assume "m = n"
+ then show "Nonce m = Nonce n" by simp
+qed
+
+lemma MPAIR_imp_eqv_left:
+ shows "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> X \<sim> X'"
+ by (drule msgrel_imp_eqv_freeleft) (simp)
+
+lemma MPair_imp_eq_left:
+ assumes eq: "MPair X Y = MPair X' Y'"
+ shows "X = X'"
+ using eq by (lifting MPAIR_imp_eqv_left)
+
+lemma MPAIR_imp_eqv_right:
+ shows "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> Y \<sim> Y'"
+ by (drule msgrel_imp_eqv_freeright) (simp)
+
+lemma MPair_imp_eq_right:
+ shows "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
+ by (lifting MPAIR_imp_eqv_right)
+
+theorem MPair_MPair_eq [iff]:
+ shows "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
+ by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)
+
+lemma NONCE_neqv_MPAIR:
+ shows "\<not>(NONCE m \<sim> MPAIR X Y)"
+ by (auto dest: msgrel_imp_eq_freediscrim)
+
+theorem Nonce_neq_MPair [iff]:
+ shows "Nonce N \<noteq> MPair X Y"
+ by (lifting NONCE_neqv_MPAIR)
+
+text{*Example suggested by a referee*}
+
+lemma CRYPT_NONCE_neq_NONCE:
+ shows "\<not>(CRYPT K (NONCE M) \<sim> NONCE N)"
+ by (auto dest: msgrel_imp_eq_freediscrim)
+
+theorem Crypt_Nonce_neq_Nonce:
+ shows "Crypt K (Nonce M) \<noteq> Nonce N"
+ by (lifting CRYPT_NONCE_neq_NONCE)
+
+text{*...and many similar results*}
+lemma CRYPT2_NONCE_neq_NONCE:
+ shows "\<not>(CRYPT K (CRYPT K' (NONCE M)) \<sim> NONCE N)"
+ by (auto dest: msgrel_imp_eq_freediscrim)
+
+theorem Crypt2_Nonce_neq_Nonce:
+ shows "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
+ by (lifting CRYPT2_NONCE_neq_NONCE)
+
+theorem Crypt_Crypt_eq [iff]:
+ shows "(Crypt K X = Crypt K X') = (X=X')"
+proof
+ assume "Crypt K X = Crypt K X'"
+ hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
+ thus "X = X'" by simp
+next
+ assume "X = X'"
+ thus "Crypt K X = Crypt K X'" by simp
+qed
+
+theorem Decrypt_Decrypt_eq [iff]:
+ shows "(Decrypt K X = Decrypt K X') = (X=X')"
+proof
+ assume "Decrypt K X = Decrypt K X'"
+ hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
+ thus "X = X'" by simp
+next
+ assume "X = X'"
+ thus "Decrypt K X = Decrypt K X'" by simp
+qed
+
+lemma msg_induct_aux:
+ shows "\<lbrakk>\<And>N. P (Nonce N);
+ \<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y);
+ \<And>K X. P X \<Longrightarrow> P (Crypt K X);
+ \<And>K X. P X \<Longrightarrow> P (Decrypt K X)\<rbrakk> \<Longrightarrow> P msg"
+ by (lifting freemsg.induct)
+
+lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
+ assumes N: "\<And>N. P (Nonce N)"
+ and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
+ and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
+ and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
+ shows "P msg"
+ using N M C D by (rule msg_induct_aux)
+
+subsection{*The Abstract Discriminator*}
+
+text{*However, as @{text Crypt_Nonce_neq_Nonce} above illustrates, we don't
+need this function in order to prove discrimination theorems.*}
+
+quotient_definition
+ "discrim:: msg \<Rightarrow> int"
+is
+ "freediscrim"
+
+text{*Now prove the four equations for @{term discrim}*}
+
+lemma [quot_respect]:
+ shows "(op \<sim> ===> op =) freediscrim freediscrim"
+ by (auto simp add: msgrel_imp_eq_freediscrim)
+
+lemma discrim_Nonce [simp]:
+ shows "discrim (Nonce N) = 0"
+ by (lifting freediscrim.simps(1))
+
+lemma discrim_MPair [simp]:
+ shows "discrim (MPair X Y) = 1"
+ by (lifting freediscrim.simps(2))
+
+lemma discrim_Crypt [simp]:
+ shows "discrim (Crypt K X) = discrim X + 2"
+ by (lifting freediscrim.simps(3))
+
+lemma discrim_Decrypt [simp]:
+ shows "discrim (Decrypt K X) = discrim X - 2"
+ by (lifting freediscrim.simps(4))
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Quotient_Examples/LarryInt.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,395 @@
+
+header{*The Integers as Equivalence Classes over Pairs of Natural Numbers*}
+
+theory LarryInt
+imports Main Quotient_Product
+begin
+
+fun
+ intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
+where
+ "intrel (x, y) (u, v) = (x + v = u + y)"
+
+quotient_type int = "nat \<times> nat" / intrel
+ by (auto simp add: equivp_def expand_fun_eq)
+
+instantiation int :: "{zero, one, plus, uminus, minus, times, ord}"
+begin
+
+quotient_definition
+ Zero_int_def: "0::int" is "(0::nat, 0::nat)"
+
+quotient_definition
+ One_int_def: "1::int" is "(1::nat, 0::nat)"
+
+definition
+ "add_raw \<equiv> \<lambda>(x, y) (u, v). (x + (u::nat), y + (v::nat))"
+
+quotient_definition
+ "(op +) :: int \<Rightarrow> int \<Rightarrow> int"
+is
+ "add_raw"
+
+definition
+ "uminus_raw \<equiv> \<lambda>(x::nat, y::nat). (y, x)"
+
+quotient_definition
+ "uminus :: int \<Rightarrow> int"
+is
+ "uminus_raw"
+
+fun
+ mult_raw::"nat \<times> nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat"
+where
+ "mult_raw (x, y) (u, v) = (x*u + y*v, x*v + y*u)"
+
+quotient_definition
+ "(op *) :: int \<Rightarrow> int \<Rightarrow> int"
+is
+ "mult_raw"
+
+definition
+ "le_raw \<equiv> \<lambda>(x, y) (u, v). (x+v \<le> u+(y::nat))"
+
+quotient_definition
+ le_int_def: "(op \<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
+is
+ "le_raw"
+
+definition
+ less_int_def: "z < (w::int) \<equiv> (z \<le> w & z \<noteq> w)"
+
+definition
+ diff_int_def: "z - (w::int) \<equiv> z + (-w)"
+
+instance ..
+
+end
+
+subsection{*Construction of the Integers*}
+
+lemma zminus_zminus_raw:
+ "uminus_raw (uminus_raw z) = z"
+ by (cases z) (simp add: uminus_raw_def)
+
+lemma [quot_respect]:
+ shows "(intrel ===> intrel) uminus_raw uminus_raw"
+ by (simp add: uminus_raw_def)
+
+lemma zminus_zminus:
+ fixes z::"int"
+ shows "- (- z) = z"
+ by(lifting zminus_zminus_raw)
+
+lemma zminus_0_raw:
+ shows "uminus_raw (0, 0) = (0, 0::nat)"
+ by (simp add: uminus_raw_def)
+
+lemma zminus_0:
+ shows "- 0 = (0::int)"
+ by (lifting zminus_0_raw)
+
+subsection{*Integer Addition*}
+
+lemma zminus_zadd_distrib_raw:
+ shows "uminus_raw (add_raw z w) = add_raw (uminus_raw z) (uminus_raw w)"
+by (cases z, cases w)
+ (auto simp add: add_raw_def uminus_raw_def)
+
+lemma [quot_respect]:
+ shows "(intrel ===> intrel ===> intrel) add_raw add_raw"
+by (simp add: add_raw_def)
+
+lemma zminus_zadd_distrib:
+ fixes z w::"int"
+ shows "- (z + w) = (- z) + (- w)"
+ by(lifting zminus_zadd_distrib_raw)
+
+lemma zadd_commute_raw:
+ shows "add_raw z w = add_raw w z"
+by (cases z, cases w)
+ (simp add: add_raw_def)
+
+lemma zadd_commute:
+ fixes z w::"int"
+ shows "(z::int) + w = w + z"
+ by (lifting zadd_commute_raw)
+
+lemma zadd_assoc_raw:
+ shows "add_raw (add_raw z1 z2) z3 = add_raw z1 (add_raw z2 z3)"
+ by (cases z1, cases z2, cases z3) (simp add: add_raw_def)
+
+lemma zadd_assoc:
+ fixes z1 z2 z3::"int"
+ shows "(z1 + z2) + z3 = z1 + (z2 + z3)"
+ by (lifting zadd_assoc_raw)
+
+lemma zadd_0_raw:
+ shows "add_raw (0, 0) z = z"
+ by (simp add: add_raw_def)
+
+
+text {*also for the instance declaration int :: plus_ac0*}
+lemma zadd_0:
+ fixes z::"int"
+ shows "0 + z = z"
+ by (lifting zadd_0_raw)
+
+lemma zadd_zminus_inverse_raw:
+ shows "intrel (add_raw (uminus_raw z) z) (0, 0)"
+ by (cases z) (simp add: add_raw_def uminus_raw_def)
+
+lemma zadd_zminus_inverse2:
+ fixes z::"int"
+ shows "(- z) + z = 0"
+ by (lifting zadd_zminus_inverse_raw)
+
+subsection{*Integer Multiplication*}
+
+lemma zmult_zminus_raw:
+ shows "mult_raw (uminus_raw z) w = uminus_raw (mult_raw z w)"
+apply(cases z, cases w)
+apply(simp add: uminus_raw_def)
+done
+
+lemma mult_raw_fst:
+ assumes a: "intrel x z"
+ shows "intrel (mult_raw x y) (mult_raw z y)"
+using a
+apply(cases x, cases y, cases z)
+apply(auto simp add: mult_raw.simps intrel.simps)
+apply(rename_tac u v w x y z)
+apply(subgoal_tac "u*w + z*w = y*w + v*w & u*x + z*x = y*x + v*x")
+apply(simp add: mult_ac)
+apply(simp add: add_mult_distrib [symmetric])
+done
+
+lemma mult_raw_snd:
+ assumes a: "intrel x z"
+ shows "intrel (mult_raw y x) (mult_raw y z)"
+using a
+apply(cases x, cases y, cases z)
+apply(auto simp add: mult_raw.simps intrel.simps)
+apply(rename_tac u v w x y z)
+apply(subgoal_tac "u*w + z*w = y*w + v*w & u*x + z*x = y*x + v*x")
+apply(simp add: mult_ac)
+apply(simp add: add_mult_distrib [symmetric])
+done
+
+lemma [quot_respect]:
+ shows "(intrel ===> intrel ===> intrel) mult_raw mult_raw"
+apply(simp only: fun_rel_def)
+apply(rule allI | rule impI)+
+apply(rule equivp_transp[OF int_equivp])
+apply(rule mult_raw_fst)
+apply(assumption)
+apply(rule mult_raw_snd)
+apply(assumption)
+done
+
+lemma zmult_zminus:
+ fixes z w::"int"
+ shows "(- z) * w = - (z * w)"
+ by (lifting zmult_zminus_raw)
+
+lemma zmult_commute_raw:
+ shows "mult_raw z w = mult_raw w z"
+apply(cases z, cases w)
+apply(simp add: add_ac mult_ac)
+done
+
+lemma zmult_commute:
+ fixes z w::"int"
+ shows "z * w = w * z"
+ by (lifting zmult_commute_raw)
+
+lemma zmult_assoc_raw:
+ shows "mult_raw (mult_raw z1 z2) z3 = mult_raw z1 (mult_raw z2 z3)"
+apply(cases z1, cases z2, cases z3)
+apply(simp add: add_mult_distrib2 mult_ac)
+done
+
+lemma zmult_assoc:
+ fixes z1 z2 z3::"int"
+ shows "(z1 * z2) * z3 = z1 * (z2 * z3)"
+ by (lifting zmult_assoc_raw)
+
+lemma zadd_mult_distrib_raw:
+ shows "mult_raw (add_raw z1 z2) w = add_raw (mult_raw z1 w) (mult_raw z2 w)"
+apply(cases z1, cases z2, cases w)
+apply(simp add: add_mult_distrib2 mult_ac add_raw_def)
+done
+
+lemma zadd_zmult_distrib:
+ fixes z1 z2 w::"int"
+ shows "(z1 + z2) * w = (z1 * w) + (z2 * w)"
+ by(lifting zadd_mult_distrib_raw)
+
+lemma zadd_zmult_distrib2:
+ fixes w z1 z2::"int"
+ shows "w * (z1 + z2) = (w * z1) + (w * z2)"
+ by (simp add: zmult_commute [of w] zadd_zmult_distrib)
+
+lemma zdiff_zmult_distrib:
+ fixes w z1 z2::"int"
+ shows "(z1 - z2) * w = (z1 * w) - (z2 * w)"
+ by (simp add: diff_int_def zadd_zmult_distrib zmult_zminus)
+
+lemma zdiff_zmult_distrib2:
+ fixes w z1 z2::"int"
+ shows "w * (z1 - z2) = (w * z1) - (w * z2)"
+ by (simp add: zmult_commute [of w] zdiff_zmult_distrib)
+
+lemmas int_distrib =
+ zadd_zmult_distrib zadd_zmult_distrib2
+ zdiff_zmult_distrib zdiff_zmult_distrib2
+
+lemma zmult_1_raw:
+ shows "mult_raw (1, 0) z = z"
+ by (cases z) (auto)
+
+lemma zmult_1:
+ fixes z::"int"
+ shows "1 * z = z"
+ by (lifting zmult_1_raw)
+
+lemma zmult_1_right:
+ fixes z::"int"
+ shows "z * 1 = z"
+ by (rule trans [OF zmult_commute zmult_1])
+
+lemma zero_not_one:
+ shows "\<not>(intrel (0, 0) (1::nat, 0::nat))"
+ by auto
+
+text{*The Integers Form A Ring*}
+instance int :: comm_ring_1
+proof
+ fix i j k :: int
+ show "(i + j) + k = i + (j + k)" by (simp add: zadd_assoc)
+ show "i + j = j + i" by (simp add: zadd_commute)
+ show "0 + i = i" by (rule zadd_0)
+ show "- i + i = 0" by (rule zadd_zminus_inverse2)
+ show "i - j = i + (-j)" by (simp add: diff_int_def)
+ show "(i * j) * k = i * (j * k)" by (rule zmult_assoc)
+ show "i * j = j * i" by (rule zmult_commute)
+ show "1 * i = i" by (rule zmult_1)
+ show "(i + j) * k = i * k + j * k" by (simp add: int_distrib)
+ show "0 \<noteq> (1::int)" by (lifting zero_not_one)
+qed
+
+
+subsection{*The @{text "\<le>"} Ordering*}
+
+lemma zle_refl_raw:
+ shows "le_raw w w"
+ by (cases w) (simp add: le_raw_def)
+
+lemma [quot_respect]:
+ shows "(intrel ===> intrel ===> op =) le_raw le_raw"
+ by (auto) (simp_all add: le_raw_def)
+
+lemma zle_refl:
+ fixes w::"int"
+ shows "w \<le> w"
+ by (lifting zle_refl_raw)
+
+
+lemma zle_trans_raw:
+ shows "\<lbrakk>le_raw i j; le_raw j k\<rbrakk> \<Longrightarrow> le_raw i k"
+apply(cases i, cases j, cases k)
+apply(auto simp add: le_raw_def)
+done
+
+lemma zle_trans:
+ fixes i j k::"int"
+ shows "\<lbrakk>i \<le> j; j \<le> k\<rbrakk> \<Longrightarrow> i \<le> k"
+ by (lifting zle_trans_raw)
+
+lemma zle_anti_sym_raw:
+ shows "\<lbrakk>le_raw z w; le_raw w z\<rbrakk> \<Longrightarrow> intrel z w"
+apply(cases z, cases w)
+apply(auto iff: le_raw_def)
+done
+
+lemma zle_anti_sym:
+ fixes z w::"int"
+ shows "\<lbrakk>z \<le> w; w \<le> z\<rbrakk> \<Longrightarrow> z = w"
+ by (lifting zle_anti_sym_raw)
+
+
+(* Axiom 'order_less_le' of class 'order': *)
+lemma zless_le:
+ fixes w z::"int"
+ shows "(w < z) = (w \<le> z & w \<noteq> z)"
+ by (simp add: less_int_def)
+
+instance int :: order
+apply (default)
+apply(auto simp add: zless_le zle_anti_sym)[1]
+apply(rule zle_refl)
+apply(erule zle_trans, assumption)
+apply(erule zle_anti_sym, assumption)
+done
+
+(* Axiom 'linorder_linear' of class 'linorder': *)
+
+lemma zle_linear_raw:
+ shows "le_raw z w \<or> le_raw w z"
+apply(cases w, cases z)
+apply(auto iff: le_raw_def)
+done
+
+lemma zle_linear:
+ fixes z w::"int"
+ shows "z \<le> w \<or> w \<le> z"
+ by (lifting zle_linear_raw)
+
+instance int :: linorder
+apply(default)
+apply(rule zle_linear)
+done
+
+lemma zadd_left_mono_raw:
+ shows "le_raw i j \<Longrightarrow> le_raw (add_raw k i) (add_raw k j)"
+apply(cases k)
+apply(auto simp add: add_raw_def le_raw_def)
+done
+
+lemma zadd_left_mono:
+ fixes i j::"int"
+ shows "i \<le> j \<Longrightarrow> k + i \<le> k + j"
+ by (lifting zadd_left_mono_raw)
+
+
+subsection{*Magnitide of an Integer, as a Natural Number: @{term nat}*}
+
+definition
+ "nat_raw \<equiv> \<lambda>(x, y).x - (y::nat)"
+
+quotient_definition
+ "nat2::int \<Rightarrow> nat"
+is
+ "nat_raw"
+
+abbreviation
+ "less_raw x y \<equiv> (le_raw x y \<and> \<not>(intrel x y))"
+
+lemma nat_le_eq_zle_raw:
+ shows "less_raw (0, 0) w \<or> le_raw (0, 0) z \<Longrightarrow> (nat_raw w \<le> nat_raw z) = (le_raw w z)"
+ apply (cases w)
+ apply (cases z)
+ apply (simp add: nat_raw_def le_raw_def)
+ by auto
+
+lemma [quot_respect]:
+ shows "(intrel ===> op =) nat_raw nat_raw"
+ by (auto iff: nat_raw_def)
+
+lemma nat_le_eq_zle:
+ fixes w z::"int"
+ shows "0 < w \<or> 0 \<le> z \<Longrightarrow> (nat2 w \<le> nat2 z) = (w\<le>z)"
+ unfolding less_int_def
+ by (lifting nat_le_eq_zle_raw)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Quotient_Examples/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,8 @@
+(* Title: HOL/Quotient_Examples/ROOT.ML
+ Author: Cezary Kaliszyk and Christian Urban
+
+Testing the quotient package.
+*)
+
+use_thys ["LarryInt", "LarryDatatype"];
+
--- a/src/HOL/RComplete.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/RComplete.thy Fri Feb 19 15:21:57 2010 +0000
@@ -15,7 +15,7 @@
by simp
lemma abs_diff_less_iff:
- "(\<bar>x - a\<bar> < (r::'a::ordered_idom)) = (a - r < x \<and> x < a + r)"
+ "(\<bar>x - a\<bar> < (r::'a::linordered_idom)) = (a - r < x \<and> x < a + r)"
by auto
subsection {* Completeness of Positive Reals *}
--- a/src/HOL/Rational.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Rational.thy Fri Feb 19 15:21:57 2010 +0000
@@ -428,7 +428,7 @@
fix q :: rat
assume "q \<noteq> 0"
then show "inverse q * q = 1" by (cases q rule: Rat_cases_nonzero)
- (simp_all add: mult_rat inverse_rat rat_number_expand eq_rat)
+ (simp_all add: rat_number_expand eq_rat)
next
fix q r :: rat
show "q / r = q * inverse r" by (simp add: divide_rat_def)
@@ -592,7 +592,7 @@
abs_rat_def [code del]: "\<bar>q\<bar> = (if q < 0 then -q else (q::rat))"
lemma abs_rat [simp, code]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
- by (auto simp add: abs_rat_def zabs_def Zero_rat_def less_rat not_less le_less minus_rat eq_rat zero_compare_simps)
+ by (auto simp add: abs_rat_def zabs_def Zero_rat_def not_less le_less eq_rat zero_less_mult_iff)
definition
sgn_rat_def [code del]: "sgn (q::rat) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"
@@ -613,7 +613,7 @@
end
-instance rat :: ordered_field
+instance rat :: linordered_field
proof
fix q r s :: rat
show "q \<le> r ==> s + q \<le> s + r"
@@ -760,7 +760,7 @@
class field_char_0 = field + ring_char_0
-subclass (in ordered_field) field_char_0 ..
+subclass (in linordered_field) field_char_0 ..
context field_char_0
begin
@@ -832,7 +832,7 @@
done
lemma of_rat_less:
- "(of_rat r :: 'a::ordered_field) < of_rat s \<longleftrightarrow> r < s"
+ "(of_rat r :: 'a::linordered_field) < of_rat s \<longleftrightarrow> r < s"
proof (induct r, induct s)
fix a b c d :: int
assume not_zero: "b > 0" "d > 0"
@@ -841,14 +841,14 @@
"(of_int a :: 'a) / of_int b < of_int c / of_int d
\<longleftrightarrow> (of_int a :: 'a) * of_int d < of_int c * of_int b"
using not_zero by (simp add: pos_less_divide_eq pos_divide_less_eq)
- show "(of_rat (Fract a b) :: 'a::ordered_field) < of_rat (Fract c d)
+ show "(of_rat (Fract a b) :: 'a::linordered_field) < of_rat (Fract c d)
\<longleftrightarrow> Fract a b < Fract c d"
using not_zero `b * d > 0`
by (simp add: of_rat_rat of_int_divide_less_eq of_int_mult [symmetric] del: of_int_mult)
qed
lemma of_rat_less_eq:
- "(of_rat r :: 'a::ordered_field) \<le> of_rat s \<longleftrightarrow> r \<le> s"
+ "(of_rat r :: 'a::linordered_field) \<le> of_rat s \<longleftrightarrow> r \<le> s"
unfolding le_less by (auto simp add: of_rat_less)
lemmas of_rat_eq_0_iff [simp] = of_rat_eq_iff [of _ 0, simplified]
@@ -1083,14 +1083,6 @@
finally show ?thesis using assms by simp
qed
-lemma (in ordered_idom) sgn_greater [simp]:
- "0 < sgn a \<longleftrightarrow> 0 < a"
- unfolding sgn_if by auto
-
-lemma (in ordered_idom) sgn_less [simp]:
- "sgn a < 0 \<longleftrightarrow> a < 0"
- unfolding sgn_if by auto
-
lemma rat_le_eq_code [code]:
"Fract a b < Fract c d \<longleftrightarrow> (if b = 0
then sgn c * sgn d > 0
--- a/src/HOL/Real.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Real.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2,28 +2,4 @@
imports RComplete RealVector
begin
-lemma field_le_epsilon:
- fixes x y :: "'a:: {number_ring,division_by_zero,ordered_field}"
- assumes e: "(!!e. 0 < e ==> x \<le> y + e)"
- shows "x \<le> y"
-proof (rule ccontr)
- assume xy: "\<not> x \<le> y"
- hence "(x-y)/2 > 0"
- by (metis half_gt_zero le_iff_diff_le_0 linorder_not_le local.xy)
- hence "x \<le> y + (x - y) / 2"
- by (rule e [of "(x-y)/2"])
- also have "... = (x - y + 2*y)/2"
- by auto
- (metis add_less_cancel_left add_numeral_0_right class_semiring.add_c xy e
- diff_add_cancel gt_half_sum less_half_sum linorder_not_le number_of_Pls)
- also have "... = (x + y) / 2"
- by auto
- also have "... < x" using xy
- by auto
- finally have "x<x" .
- thus False
- by auto
-qed
-
-
end
--- a/src/HOL/RealDef.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/RealDef.thy Fri Feb 19 15:21:57 2010 +0000
@@ -416,7 +416,7 @@
subsection{*The Reals Form an Ordered Field*}
-instance real :: ordered_field
+instance real :: linordered_field
proof
fix x y z :: real
show "x \<le> y ==> z + x \<le> z + y" by (rule real_add_left_mono)
@@ -426,8 +426,6 @@
by (simp only: real_sgn_def)
qed
-instance real :: lordered_ab_group_add ..
-
text{*The function @{term real_of_preal} requires many proofs, but it seems
to be essential for proving completeness of the reals from that of the
positive reals.*}
@@ -523,7 +521,7 @@
lemma real_mult_less_iff1 [simp]: "(0::real) < z ==> (x*z < y*z) = (x < y)"
by (force elim: order_less_asym
- simp add: Ring_and_Field.mult_less_cancel_right)
+ simp add: mult_less_cancel_right)
lemma real_mult_le_cancel_iff1 [simp]: "(0::real) < z ==> (x*z \<le> y*z) = (x\<le>y)"
apply (simp add: mult_le_cancel_right)
@@ -769,7 +767,8 @@
lemma not_real_of_nat_less_zero [simp]: "~ real (n::nat) < 0"
by (simp add: add: real_of_nat_def)
-lemma real_of_nat_ge_zero_cancel_iff [simp]: "(0 \<le> real (n::nat))"
+(* FIXME: duplicates real_of_nat_ge_zero *)
+lemma real_of_nat_ge_zero_cancel_iff: "(0 \<le> real (n::nat))"
by (simp add: add: real_of_nat_def)
lemma nat_less_real_le: "((n::nat) < m) = (real n + 1 <= real m)"
@@ -953,13 +952,13 @@
text{*Collapse applications of @{term real} to @{term number_of}*}
lemma real_number_of [simp]: "real (number_of v :: int) = number_of v"
-by (simp add: real_of_int_def of_int_number_of_eq)
+by (simp add: real_of_int_def)
lemma real_of_nat_number_of [simp]:
"real (number_of v :: nat) =
(if neg (number_of v :: int) then 0
else (number_of v :: real))"
-by (simp add: real_of_int_real_of_nat [symmetric] int_nat_number_of)
+by (simp add: real_of_int_real_of_nat [symmetric])
declaration {*
K (Lin_Arith.add_inj_thms [@{thm real_of_nat_le_iff} RS iffD2, @{thm real_of_nat_inject} RS iffD2]
@@ -1017,7 +1016,7 @@
done
-text{*Similar results are proved in @{text Ring_and_Field}*}
+text{*Similar results are proved in @{text Fields}*}
lemma real_less_half_sum: "x < y ==> x < (x+y) / (2::real)"
by auto
@@ -1032,7 +1031,7 @@
(* FIXME: redundant, but used by Integration/RealRandVar.thy in AFP *)
lemma abs_le_interval_iff: "(abs x \<le> r) = (-r\<le>x & x\<le>(r::real))"
-by (force simp add: OrderedGroup.abs_le_iff)
+by (force simp add: abs_le_iff)
lemma abs_add_one_gt_zero [simp]: "(0::real) < 1 + abs(x)"
by (simp add: abs_if)
@@ -1046,13 +1045,6 @@
lemma abs_sum_triangle_ineq: "abs ((x::real) + y + (-l + -m)) \<le> abs(x + -l) + abs(y + -m)"
by simp
-instance real :: lordered_ring
-proof
- fix a::real
- show "abs a = sup a (-a)"
- by (auto simp add: real_abs_def sup_real_def)
-qed
-
subsection {* Implementation of rational real numbers *}
--- a/src/HOL/RealPow.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/RealPow.thy Fri Feb 19 15:21:57 2010 +0000
@@ -19,8 +19,8 @@
apply (induct "n")
apply (auto simp add: real_of_nat_Suc)
apply (subst mult_2)
-apply (rule add_less_le_mono)
-apply (auto simp add: two_realpow_ge_one)
+apply (erule add_less_le_mono)
+apply (rule two_realpow_ge_one)
done
lemma realpow_Suc_le_self: "[| 0 \<le> r; r \<le> (1::real) |] ==> r ^ Suc n \<le> r"
@@ -57,7 +57,7 @@
lemma realpow_real_of_nat_two_pos [simp] : "0 < real (Suc (Suc 0) ^ n)"
apply (induct "n")
-apply (auto simp add: real_of_nat_mult zero_less_mult_iff)
+apply (auto simp add: zero_less_mult_iff)
done
(* used by AFP Integration theory *)
@@ -186,7 +186,7 @@
syntax "_Float" :: "float_const \<Rightarrow> 'a" ("_")
use "Tools/float_syntax.ML"
-setup FloatSyntax.setup
+setup Float_Syntax.setup
text{* Test: *}
lemma "123.456 = -111.111 + 200 + 30 + 4 + 5/10 + 6/100 + (7/1000::real)"
--- a/src/HOL/RealVector.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/RealVector.thy Fri Feb 19 15:21:57 2010 +0000
@@ -268,7 +268,7 @@
by (induct n) simp_all
lemma of_real_eq_iff [simp]: "(of_real x = of_real y) = (x = y)"
-by (simp add: of_real_def scaleR_cancel_right)
+by (simp add: of_real_def)
lemmas of_real_eq_0_iff [simp] = of_real_eq_iff [of _ 0, simplified]
--- a/src/HOL/Record.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Record.thy Fri Feb 19 15:21:57 2010 +0000
@@ -79,48 +79,64 @@
subsection {* Operators and lemmas for types isomorphic to tuples *}
-datatype ('a, 'b, 'c) tuple_isomorphism = Tuple_Isomorphism "'a \<Rightarrow> 'b \<times> 'c" "'b \<times> 'c \<Rightarrow> 'a"
+datatype ('a, 'b, 'c) tuple_isomorphism =
+ Tuple_Isomorphism "'a \<Rightarrow> 'b \<times> 'c" "'b \<times> 'c \<Rightarrow> 'a"
-primrec repr :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" where
+primrec
+ repr :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" where
"repr (Tuple_Isomorphism r a) = r"
-primrec abst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a" where
+primrec
+ abst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a" where
"abst (Tuple_Isomorphism r a) = a"
-definition iso_tuple_fst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b" where
+definition
+ iso_tuple_fst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b" where
"iso_tuple_fst isom = fst \<circ> repr isom"
-definition iso_tuple_snd :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'c" where
+definition
+ iso_tuple_snd :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'c" where
"iso_tuple_snd isom = snd \<circ> repr isom"
-definition iso_tuple_fst_update :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)" where
+definition
+ iso_tuple_fst_update ::
+ "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"iso_tuple_fst_update isom f = abst isom \<circ> apfst f \<circ> repr isom"
-definition iso_tuple_snd_update :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a)" where
+definition
+ iso_tuple_snd_update ::
+ "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"iso_tuple_snd_update isom f = abst isom \<circ> apsnd f \<circ> repr isom"
-definition iso_tuple_cons :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a" where
+definition
+ iso_tuple_cons ::
+ "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a" where
"iso_tuple_cons isom = curry (abst isom)"
subsection {* Logical infrastructure for records *}
-definition iso_tuple_surjective_proof_assist :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
+definition
+ iso_tuple_surjective_proof_assist :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"iso_tuple_surjective_proof_assist x y f \<longleftrightarrow> f x = y"
-definition iso_tuple_update_accessor_cong_assist :: "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
- "iso_tuple_update_accessor_cong_assist upd acc \<longleftrightarrow>
+definition
+ iso_tuple_update_accessor_cong_assist ::
+ "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
+ "iso_tuple_update_accessor_cong_assist upd acc \<longleftrightarrow>
(\<forall>f v. upd (\<lambda>x. f (acc v)) v = upd f v) \<and> (\<forall>v. upd id v = v)"
-definition iso_tuple_update_accessor_eq_assist :: "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
+definition
+ iso_tuple_update_accessor_eq_assist ::
+ "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
"iso_tuple_update_accessor_eq_assist upd acc v f v' x \<longleftrightarrow>
upd f v = v' \<and> acc v = x \<and> iso_tuple_update_accessor_cong_assist upd acc"
lemma update_accessor_congruence_foldE:
assumes uac: "iso_tuple_update_accessor_cong_assist upd acc"
- and r: "r = r'" and v: "acc r' = v'"
- and f: "\<And>v. v' = v \<Longrightarrow> f v = f' v"
- shows "upd f r = upd f' r'"
+ and r: "r = r'" and v: "acc r' = v'"
+ and f: "\<And>v. v' = v \<Longrightarrow> f v = f' v"
+ shows "upd f r = upd f' r'"
using uac r v [symmetric]
apply (subgoal_tac "upd (\<lambda>x. f (acc r')) r' = upd (\<lambda>x. f' (acc r')) r'")
apply (simp add: iso_tuple_update_accessor_cong_assist_def)
@@ -128,8 +144,9 @@
done
lemma update_accessor_congruence_unfoldE:
- "iso_tuple_update_accessor_cong_assist upd acc \<Longrightarrow> r = r' \<Longrightarrow> acc r' = v' \<Longrightarrow> (\<And>v. v = v' \<Longrightarrow> f v = f' v)
- \<Longrightarrow> upd f r = upd f' r'"
+ "iso_tuple_update_accessor_cong_assist upd acc \<Longrightarrow>
+ r = r' \<Longrightarrow> acc r' = v' \<Longrightarrow> (\<And>v. v = v' \<Longrightarrow> f v = f' v) \<Longrightarrow>
+ upd f r = upd f' r'"
apply (erule(2) update_accessor_congruence_foldE)
apply simp
done
@@ -140,15 +157,16 @@
lemma update_accessor_noopE:
assumes uac: "iso_tuple_update_accessor_cong_assist upd acc"
- and acc: "f (acc x) = acc x"
- shows "upd f x = x"
-using uac by (simp add: acc iso_tuple_update_accessor_cong_assist_id [OF uac, unfolded id_def]
- cong: update_accessor_congruence_unfoldE [OF uac])
+ and acc: "f (acc x) = acc x"
+ shows "upd f x = x"
+ using uac
+ by (simp add: acc iso_tuple_update_accessor_cong_assist_id [OF uac, unfolded id_def]
+ cong: update_accessor_congruence_unfoldE [OF uac])
lemma update_accessor_noop_compE:
assumes uac: "iso_tuple_update_accessor_cong_assist upd acc"
- assumes acc: "f (acc x) = acc x"
- shows "upd (g \<circ> f) x = upd g x"
+ and acc: "f (acc x) = acc x"
+ shows "upd (g \<circ> f) x = upd g x"
by (simp add: acc cong: update_accessor_congruence_unfoldE[OF uac])
lemma update_accessor_cong_assist_idI:
@@ -156,7 +174,8 @@
by (simp add: iso_tuple_update_accessor_cong_assist_def)
lemma update_accessor_cong_assist_triv:
- "iso_tuple_update_accessor_cong_assist upd acc \<Longrightarrow> iso_tuple_update_accessor_cong_assist upd acc"
+ "iso_tuple_update_accessor_cong_assist upd acc \<Longrightarrow>
+ iso_tuple_update_accessor_cong_assist upd acc"
by assumption
lemma update_accessor_accessor_eqE:
@@ -172,11 +191,13 @@
by (simp add: iso_tuple_update_accessor_eq_assist_def update_accessor_cong_assist_idI)
lemma iso_tuple_update_accessor_eq_assist_triv:
- "iso_tuple_update_accessor_eq_assist upd acc v f v' x \<Longrightarrow> iso_tuple_update_accessor_eq_assist upd acc v f v' x"
+ "iso_tuple_update_accessor_eq_assist upd acc v f v' x \<Longrightarrow>
+ iso_tuple_update_accessor_eq_assist upd acc v f v' x"
by assumption
lemma iso_tuple_update_accessor_cong_from_eq:
- "iso_tuple_update_accessor_eq_assist upd acc v f v' x \<Longrightarrow> iso_tuple_update_accessor_cong_assist upd acc"
+ "iso_tuple_update_accessor_eq_assist upd acc v f v' x \<Longrightarrow>
+ iso_tuple_update_accessor_cong_assist upd acc"
by (simp add: iso_tuple_update_accessor_eq_assist_def)
lemma iso_tuple_surjective_proof_assistI:
@@ -190,124 +211,139 @@
locale isomorphic_tuple =
fixes isom :: "('a, 'b, 'c) tuple_isomorphism"
assumes repr_inv: "\<And>x. abst isom (repr isom x) = x"
- assumes abst_inv: "\<And>y. repr isom (abst isom y) = y"
+ and abst_inv: "\<And>y. repr isom (abst isom y) = y"
begin
-lemma repr_inj:
- "repr isom x = repr isom y \<longleftrightarrow> x = y"
- by (auto dest: arg_cong [of "repr isom x" "repr isom y" "abst isom"] simp add: repr_inv)
+lemma repr_inj: "repr isom x = repr isom y \<longleftrightarrow> x = y"
+ by (auto dest: arg_cong [of "repr isom x" "repr isom y" "abst isom"]
+ simp add: repr_inv)
-lemma abst_inj:
- "abst isom x = abst isom y \<longleftrightarrow> x = y"
- by (auto dest: arg_cong [of "abst isom x" "abst isom y" "repr isom"] simp add: abst_inv)
+lemma abst_inj: "abst isom x = abst isom y \<longleftrightarrow> x = y"
+ by (auto dest: arg_cong [of "abst isom x" "abst isom y" "repr isom"]
+ simp add: abst_inv)
lemmas simps = Let_def repr_inv abst_inv repr_inj abst_inj
lemma iso_tuple_access_update_fst_fst:
"f o h g = j o f \<Longrightarrow>
- (f o iso_tuple_fst isom) o (iso_tuple_fst_update isom o h) g
- = j o (f o iso_tuple_fst isom)"
+ (f o iso_tuple_fst isom) o (iso_tuple_fst_update isom o h) g =
+ j o (f o iso_tuple_fst isom)"
by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_fst_def simps
- intro!: ext elim!: o_eq_elim)
+ intro!: ext elim!: o_eq_elim)
lemma iso_tuple_access_update_snd_snd:
"f o h g = j o f \<Longrightarrow>
- (f o iso_tuple_snd isom) o (iso_tuple_snd_update isom o h) g
- = j o (f o iso_tuple_snd isom)"
+ (f o iso_tuple_snd isom) o (iso_tuple_snd_update isom o h) g =
+ j o (f o iso_tuple_snd isom)"
by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_snd_def simps
- intro!: ext elim!: o_eq_elim)
+ intro!: ext elim!: o_eq_elim)
lemma iso_tuple_access_update_fst_snd:
- "(f o iso_tuple_fst isom) o (iso_tuple_snd_update isom o h) g
- = id o (f o iso_tuple_fst isom)"
+ "(f o iso_tuple_fst isom) o (iso_tuple_snd_update isom o h) g =
+ id o (f o iso_tuple_fst isom)"
by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_fst_def simps
- intro!: ext elim!: o_eq_elim)
+ intro!: ext elim!: o_eq_elim)
lemma iso_tuple_access_update_snd_fst:
- "(f o iso_tuple_snd isom) o (iso_tuple_fst_update isom o h) g
- = id o (f o iso_tuple_snd isom)"
+ "(f o iso_tuple_snd isom) o (iso_tuple_fst_update isom o h) g =
+ id o (f o iso_tuple_snd isom)"
by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_def simps
- intro!: ext elim!: o_eq_elim)
+ intro!: ext elim!: o_eq_elim)
lemma iso_tuple_update_swap_fst_fst:
"h f o j g = j g o h f \<Longrightarrow>
- (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g
- = (iso_tuple_fst_update isom o j) g o (iso_tuple_fst_update isom o h) f"
+ (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g =
+ (iso_tuple_fst_update isom o j) g o (iso_tuple_fst_update isom o h) f"
by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose intro!: ext)
lemma iso_tuple_update_swap_snd_snd:
"h f o j g = j g o h f \<Longrightarrow>
- (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g
- = (iso_tuple_snd_update isom o j) g o (iso_tuple_snd_update isom o h) f"
+ (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g =
+ (iso_tuple_snd_update isom o j) g o (iso_tuple_snd_update isom o h) f"
by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose intro!: ext)
lemma iso_tuple_update_swap_fst_snd:
- "(iso_tuple_snd_update isom o h) f o (iso_tuple_fst_update isom o j) g
- = (iso_tuple_fst_update isom o j) g o (iso_tuple_snd_update isom o h) f"
- by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def simps intro!: ext)
+ "(iso_tuple_snd_update isom o h) f o (iso_tuple_fst_update isom o j) g =
+ (iso_tuple_fst_update isom o j) g o (iso_tuple_snd_update isom o h) f"
+ by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def
+ simps intro!: ext)
lemma iso_tuple_update_swap_snd_fst:
- "(iso_tuple_fst_update isom o h) f o (iso_tuple_snd_update isom o j) g
- = (iso_tuple_snd_update isom o j) g o (iso_tuple_fst_update isom o h) f"
+ "(iso_tuple_fst_update isom o h) f o (iso_tuple_snd_update isom o j) g =
+ (iso_tuple_snd_update isom o j) g o (iso_tuple_fst_update isom o h) f"
by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def simps intro!: ext)
lemma iso_tuple_update_compose_fst_fst:
"h f o j g = k (f o g) \<Longrightarrow>
- (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g
- = (iso_tuple_fst_update isom o k) (f o g)"
+ (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g =
+ (iso_tuple_fst_update isom o k) (f o g)"
by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose intro!: ext)
lemma iso_tuple_update_compose_snd_snd:
"h f o j g = k (f o g) \<Longrightarrow>
- (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g
- = (iso_tuple_snd_update isom o k) (f o g)"
+ (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g =
+ (iso_tuple_snd_update isom o k) (f o g)"
by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose intro!: ext)
lemma iso_tuple_surjective_proof_assist_step:
"iso_tuple_surjective_proof_assist v a (iso_tuple_fst isom o f) \<Longrightarrow>
- iso_tuple_surjective_proof_assist v b (iso_tuple_snd isom o f)
- \<Longrightarrow> iso_tuple_surjective_proof_assist v (iso_tuple_cons isom a b) f"
+ iso_tuple_surjective_proof_assist v b (iso_tuple_snd isom o f) \<Longrightarrow>
+ iso_tuple_surjective_proof_assist v (iso_tuple_cons isom a b) f"
by (clarsimp simp: iso_tuple_surjective_proof_assist_def simps
iso_tuple_fst_def iso_tuple_snd_def iso_tuple_cons_def)
lemma iso_tuple_fst_update_accessor_cong_assist:
assumes "iso_tuple_update_accessor_cong_assist f g"
- shows "iso_tuple_update_accessor_cong_assist (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)"
+ shows "iso_tuple_update_accessor_cong_assist
+ (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)"
proof -
- from assms have "f id = id" by (rule iso_tuple_update_accessor_cong_assist_id)
- with assms show ?thesis by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
- iso_tuple_fst_update_def iso_tuple_fst_def)
+ from assms have "f id = id"
+ by (rule iso_tuple_update_accessor_cong_assist_id)
+ with assms show ?thesis
+ by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
+ iso_tuple_fst_update_def iso_tuple_fst_def)
qed
lemma iso_tuple_snd_update_accessor_cong_assist:
assumes "iso_tuple_update_accessor_cong_assist f g"
- shows "iso_tuple_update_accessor_cong_assist (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)"
+ shows "iso_tuple_update_accessor_cong_assist
+ (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)"
proof -
- from assms have "f id = id" by (rule iso_tuple_update_accessor_cong_assist_id)
- with assms show ?thesis by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
- iso_tuple_snd_update_def iso_tuple_snd_def)
+ from assms have "f id = id"
+ by (rule iso_tuple_update_accessor_cong_assist_id)
+ with assms show ?thesis
+ by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
+ iso_tuple_snd_update_def iso_tuple_snd_def)
qed
lemma iso_tuple_fst_update_accessor_eq_assist:
assumes "iso_tuple_update_accessor_eq_assist f g a u a' v"
- shows "iso_tuple_update_accessor_eq_assist (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)
+ shows "iso_tuple_update_accessor_eq_assist
+ (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)
(iso_tuple_cons isom a b) u (iso_tuple_cons isom a' b) v"
proof -
from assms have "f id = id"
- by (auto simp add: iso_tuple_update_accessor_eq_assist_def intro: iso_tuple_update_accessor_cong_assist_id)
- with assms show ?thesis by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
- iso_tuple_fst_update_def iso_tuple_fst_def iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
+ by (auto simp add: iso_tuple_update_accessor_eq_assist_def
+ intro: iso_tuple_update_accessor_cong_assist_id)
+ with assms show ?thesis
+ by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
+ iso_tuple_fst_update_def iso_tuple_fst_def
+ iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed
lemma iso_tuple_snd_update_accessor_eq_assist:
assumes "iso_tuple_update_accessor_eq_assist f g b u b' v"
- shows "iso_tuple_update_accessor_eq_assist (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)
+ shows "iso_tuple_update_accessor_eq_assist
+ (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)
(iso_tuple_cons isom a b) u (iso_tuple_cons isom a b') v"
proof -
from assms have "f id = id"
- by (auto simp add: iso_tuple_update_accessor_eq_assist_def intro: iso_tuple_update_accessor_cong_assist_id)
- with assms show ?thesis by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
- iso_tuple_snd_update_def iso_tuple_snd_def iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
+ by (auto simp add: iso_tuple_update_accessor_eq_assist_def
+ intro: iso_tuple_update_accessor_cong_assist_id)
+ with assms show ?thesis
+ by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
+ iso_tuple_snd_update_def iso_tuple_snd_def
+ iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed
lemma iso_tuple_cons_conj_eqI:
@@ -316,37 +352,39 @@
by (clarsimp simp: iso_tuple_cons_def simps)
lemmas intros =
- iso_tuple_access_update_fst_fst
- iso_tuple_access_update_snd_snd
- iso_tuple_access_update_fst_snd
- iso_tuple_access_update_snd_fst
- iso_tuple_update_swap_fst_fst
- iso_tuple_update_swap_snd_snd
- iso_tuple_update_swap_fst_snd
- iso_tuple_update_swap_snd_fst
- iso_tuple_update_compose_fst_fst
- iso_tuple_update_compose_snd_snd
- iso_tuple_surjective_proof_assist_step
- iso_tuple_fst_update_accessor_eq_assist
- iso_tuple_snd_update_accessor_eq_assist
- iso_tuple_fst_update_accessor_cong_assist
- iso_tuple_snd_update_accessor_cong_assist
- iso_tuple_cons_conj_eqI
+ iso_tuple_access_update_fst_fst
+ iso_tuple_access_update_snd_snd
+ iso_tuple_access_update_fst_snd
+ iso_tuple_access_update_snd_fst
+ iso_tuple_update_swap_fst_fst
+ iso_tuple_update_swap_snd_snd
+ iso_tuple_update_swap_fst_snd
+ iso_tuple_update_swap_snd_fst
+ iso_tuple_update_compose_fst_fst
+ iso_tuple_update_compose_snd_snd
+ iso_tuple_surjective_proof_assist_step
+ iso_tuple_fst_update_accessor_eq_assist
+ iso_tuple_snd_update_accessor_eq_assist
+ iso_tuple_fst_update_accessor_cong_assist
+ iso_tuple_snd_update_accessor_cong_assist
+ iso_tuple_cons_conj_eqI
end
lemma isomorphic_tuple_intro:
fixes repr abst
assumes repr_inj: "\<And>x y. repr x = repr y \<longleftrightarrow> x = y"
- and abst_inv: "\<And>z. repr (abst z) = z"
- assumes v: "v \<equiv> Tuple_Isomorphism repr abst"
+ and abst_inv: "\<And>z. repr (abst z) = z"
+ and v: "v \<equiv> Tuple_Isomorphism repr abst"
shows "isomorphic_tuple v"
proof
- have "\<And>x. repr (abst (repr x)) = repr x"
+ fix x have "repr (abst (repr x)) = repr x"
by (simp add: abst_inv)
- then show "\<And>x. Record.abst v (Record.repr v x) = x"
+ then show "Record.abst v (Record.repr v x) = x"
by (simp add: v repr_inj)
- show P: "\<And>y. Record.repr v (Record.abst v y) = y"
+next
+ fix y
+ show "Record.repr v (Record.abst v y) = y"
by (simp add: v) (fact abst_inv)
qed
@@ -357,8 +395,7 @@
"isomorphic_tuple tuple_iso_tuple"
by (simp add: isomorphic_tuple_intro [OF _ _ reflexive] tuple_iso_tuple_def)
-lemma refl_conj_eq:
- "Q = R \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R"
+lemma refl_conj_eq: "Q = R \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R"
by simp
lemma iso_tuple_UNIV_I: "x \<in> UNIV \<equiv> True"
@@ -370,50 +407,47 @@
lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
by simp
-lemma K_record_comp: "(\<lambda>x. c) \<circ> f = (\<lambda>x. c)"
+lemma K_record_comp: "(\<lambda>x. c) \<circ> f = (\<lambda>x. c)"
by (simp add: comp_def)
-lemma o_eq_dest_lhs:
- "a o b = c \<Longrightarrow> a (b v) = c v"
+lemma o_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
by clarsimp
-lemma o_eq_id_dest:
- "a o b = id o c \<Longrightarrow> a (b v) = c v"
+lemma o_eq_id_dest: "a o b = id o c \<Longrightarrow> a (b v) = c v"
by clarsimp
subsection {* Concrete record syntax *}
nonterminals
- ident field_type field_types field fields update updates
+ ident field_type field_types field fields field_update field_updates
syntax
"_constify" :: "id => ident" ("_")
"_constify" :: "longid => ident" ("_")
- "_field_type" :: "[ident, type] => field_type" ("(2_ ::/ _)")
+ "_field_type" :: "ident => type => field_type" ("(2_ ::/ _)")
"" :: "field_type => field_types" ("_")
- "_field_types" :: "[field_type, field_types] => field_types" ("_,/ _")
+ "_field_types" :: "field_type => field_types => field_types" ("_,/ _")
"_record_type" :: "field_types => type" ("(3'(| _ |'))")
- "_record_type_scheme" :: "[field_types, type] => type" ("(3'(| _,/ (2... ::/ _) |'))")
+ "_record_type_scheme" :: "field_types => type => type" ("(3'(| _,/ (2... ::/ _) |'))")
- "_field" :: "[ident, 'a] => field" ("(2_ =/ _)")
+ "_field" :: "ident => 'a => field" ("(2_ =/ _)")
"" :: "field => fields" ("_")
- "_fields" :: "[field, fields] => fields" ("_,/ _")
+ "_fields" :: "field => fields => fields" ("_,/ _")
"_record" :: "fields => 'a" ("(3'(| _ |'))")
- "_record_scheme" :: "[fields, 'a] => 'a" ("(3'(| _,/ (2... =/ _) |'))")
+ "_record_scheme" :: "fields => 'a => 'a" ("(3'(| _,/ (2... =/ _) |'))")
- "_update_name" :: idt
- "_update" :: "[ident, 'a] => update" ("(2_ :=/ _)")
- "" :: "update => updates" ("_")
- "_updates" :: "[update, updates] => updates" ("_,/ _")
- "_record_update" :: "['a, updates] => 'b" ("_/(3'(| _ |'))" [900,0] 900)
+ "_field_update" :: "ident => 'a => field_update" ("(2_ :=/ _)")
+ "" :: "field_update => field_updates" ("_")
+ "_field_updates" :: "field_update => field_updates => field_updates" ("_,/ _")
+ "_record_update" :: "'a => field_updates => 'b" ("_/(3'(| _ |'))" [900, 0] 900)
syntax (xsymbols)
"_record_type" :: "field_types => type" ("(3\<lparr>_\<rparr>)")
- "_record_type_scheme" :: "[field_types, type] => type" ("(3\<lparr>_,/ (2\<dots> ::/ _)\<rparr>)")
- "_record" :: "fields => 'a" ("(3\<lparr>_\<rparr>)")
- "_record_scheme" :: "[fields, 'a] => 'a" ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
- "_record_update" :: "['a, updates] => 'b" ("_/(3\<lparr>_\<rparr>)" [900,0] 900)
+ "_record_type_scheme" :: "field_types => type => type" ("(3\<lparr>_,/ (2\<dots> ::/ _)\<rparr>)")
+ "_record" :: "fields => 'a" ("(3\<lparr>_\<rparr>)")
+ "_record_scheme" :: "fields => 'a => 'a" ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
+ "_record_update" :: "'a => field_updates => 'b" ("_/(3\<lparr>_\<rparr>)" [900, 0] 900)
subsection {* Record package *}
--- a/src/HOL/Ring_and_Field.thy Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,2391 +0,0 @@
-(* Title: HOL/Ring_and_Field.thy
- Author: Gertrud Bauer
- Author: Steven Obua
- Author: Tobias Nipkow
- Author: Lawrence C Paulson
- Author: Markus Wenzel
- Author: Jeremy Avigad
-*)
-
-header {* (Ordered) Rings and Fields *}
-
-theory Ring_and_Field
-imports OrderedGroup
-begin
-
-text {*
- The theory of partially ordered rings is taken from the books:
- \begin{itemize}
- \item \emph{Lattice Theory} by Garret Birkhoff, American Mathematical Society 1979
- \item \emph{Partially Ordered Algebraic Systems}, Pergamon Press 1963
- \end{itemize}
- Most of the used notions can also be looked up in
- \begin{itemize}
- \item \url{http://www.mathworld.com} by Eric Weisstein et. al.
- \item \emph{Algebra I} by van der Waerden, Springer.
- \end{itemize}
-*}
-
-class semiring = ab_semigroup_add + semigroup_mult +
- assumes left_distrib[algebra_simps]: "(a + b) * c = a * c + b * c"
- assumes right_distrib[algebra_simps]: "a * (b + c) = a * b + a * c"
-begin
-
-text{*For the @{text combine_numerals} simproc*}
-lemma combine_common_factor:
- "a * e + (b * e + c) = (a + b) * e + c"
-by (simp add: left_distrib add_ac)
-
-end
-
-class mult_zero = times + zero +
- assumes mult_zero_left [simp]: "0 * a = 0"
- assumes mult_zero_right [simp]: "a * 0 = 0"
-
-class semiring_0 = semiring + comm_monoid_add + mult_zero
-
-class semiring_0_cancel = semiring + cancel_comm_monoid_add
-begin
-
-subclass semiring_0
-proof
- fix a :: 'a
- have "0 * a + 0 * a = 0 * a + 0" by (simp add: left_distrib [symmetric])
- thus "0 * a = 0" by (simp only: add_left_cancel)
-next
- fix a :: 'a
- have "a * 0 + a * 0 = a * 0 + 0" by (simp add: right_distrib [symmetric])
- thus "a * 0 = 0" by (simp only: add_left_cancel)
-qed
-
-end
-
-class comm_semiring = ab_semigroup_add + ab_semigroup_mult +
- assumes distrib: "(a + b) * c = a * c + b * c"
-begin
-
-subclass semiring
-proof
- fix a b c :: 'a
- show "(a + b) * c = a * c + b * c" by (simp add: distrib)
- have "a * (b + c) = (b + c) * a" by (simp add: mult_ac)
- also have "... = b * a + c * a" by (simp only: distrib)
- also have "... = a * b + a * c" by (simp add: mult_ac)
- finally show "a * (b + c) = a * b + a * c" by blast
-qed
-
-end
-
-class comm_semiring_0 = comm_semiring + comm_monoid_add + mult_zero
-begin
-
-subclass semiring_0 ..
-
-end
-
-class comm_semiring_0_cancel = comm_semiring + cancel_comm_monoid_add
-begin
-
-subclass semiring_0_cancel ..
-
-subclass comm_semiring_0 ..
-
-end
-
-class zero_neq_one = zero + one +
- assumes zero_neq_one [simp]: "0 \<noteq> 1"
-begin
-
-lemma one_neq_zero [simp]: "1 \<noteq> 0"
-by (rule not_sym) (rule zero_neq_one)
-
-end
-
-class semiring_1 = zero_neq_one + semiring_0 + monoid_mult
-
-text {* Abstract divisibility *}
-
-class dvd = times
-begin
-
-definition dvd :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "dvd" 50) where
- [code del]: "b dvd a \<longleftrightarrow> (\<exists>k. a = b * k)"
-
-lemma dvdI [intro?]: "a = b * k \<Longrightarrow> b dvd a"
- unfolding dvd_def ..
-
-lemma dvdE [elim?]: "b dvd a \<Longrightarrow> (\<And>k. a = b * k \<Longrightarrow> P) \<Longrightarrow> P"
- unfolding dvd_def by blast
-
-end
-
-class comm_semiring_1 = zero_neq_one + comm_semiring_0 + comm_monoid_mult + dvd
- (*previously almost_semiring*)
-begin
-
-subclass semiring_1 ..
-
-lemma dvd_refl[simp]: "a dvd a"
-proof
- show "a = a * 1" by simp
-qed
-
-lemma dvd_trans:
- assumes "a dvd b" and "b dvd c"
- shows "a dvd c"
-proof -
- from assms obtain v where "b = a * v" by (auto elim!: dvdE)
- moreover from assms obtain w where "c = b * w" by (auto elim!: dvdE)
- ultimately have "c = a * (v * w)" by (simp add: mult_assoc)
- then show ?thesis ..
-qed
-
-lemma dvd_0_left_iff [noatp, simp]: "0 dvd a \<longleftrightarrow> a = 0"
-by (auto intro: dvd_refl elim!: dvdE)
-
-lemma dvd_0_right [iff]: "a dvd 0"
-proof
- show "0 = a * 0" by simp
-qed
-
-lemma one_dvd [simp]: "1 dvd a"
-by (auto intro!: dvdI)
-
-lemma dvd_mult[simp]: "a dvd c \<Longrightarrow> a dvd (b * c)"
-by (auto intro!: mult_left_commute dvdI elim!: dvdE)
-
-lemma dvd_mult2[simp]: "a dvd b \<Longrightarrow> a dvd (b * c)"
- apply (subst mult_commute)
- apply (erule dvd_mult)
- done
-
-lemma dvd_triv_right [simp]: "a dvd b * a"
-by (rule dvd_mult) (rule dvd_refl)
-
-lemma dvd_triv_left [simp]: "a dvd a * b"
-by (rule dvd_mult2) (rule dvd_refl)
-
-lemma mult_dvd_mono:
- assumes "a dvd b"
- and "c dvd d"
- shows "a * c dvd b * d"
-proof -
- from `a dvd b` obtain b' where "b = a * b'" ..
- moreover from `c dvd d` obtain d' where "d = c * d'" ..
- ultimately have "b * d = (a * c) * (b' * d')" by (simp add: mult_ac)
- then show ?thesis ..
-qed
-
-lemma dvd_mult_left: "a * b dvd c \<Longrightarrow> a dvd c"
-by (simp add: dvd_def mult_assoc, blast)
-
-lemma dvd_mult_right: "a * b dvd c \<Longrightarrow> b dvd c"
- unfolding mult_ac [of a] by (rule dvd_mult_left)
-
-lemma dvd_0_left: "0 dvd a \<Longrightarrow> a = 0"
-by simp
-
-lemma dvd_add[simp]:
- assumes "a dvd b" and "a dvd c" shows "a dvd (b + c)"
-proof -
- from `a dvd b` obtain b' where "b = a * b'" ..
- moreover from `a dvd c` obtain c' where "c = a * c'" ..
- ultimately have "b + c = a * (b' + c')" by (simp add: right_distrib)
- then show ?thesis ..
-qed
-
-end
-
-
-class no_zero_divisors = zero + times +
- assumes no_zero_divisors: "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> a * b \<noteq> 0"
-
-class semiring_1_cancel = semiring + cancel_comm_monoid_add
- + zero_neq_one + monoid_mult
-begin
-
-subclass semiring_0_cancel ..
-
-subclass semiring_1 ..
-
-end
-
-class comm_semiring_1_cancel = comm_semiring + cancel_comm_monoid_add
- + zero_neq_one + comm_monoid_mult
-begin
-
-subclass semiring_1_cancel ..
-subclass comm_semiring_0_cancel ..
-subclass comm_semiring_1 ..
-
-end
-
-class ring = semiring + ab_group_add
-begin
-
-subclass semiring_0_cancel ..
-
-text {* Distribution rules *}
-
-lemma minus_mult_left: "- (a * b) = - a * b"
-by (rule minus_unique) (simp add: left_distrib [symmetric])
-
-lemma minus_mult_right: "- (a * b) = a * - b"
-by (rule minus_unique) (simp add: right_distrib [symmetric])
-
-text{*Extract signs from products*}
-lemmas mult_minus_left [simp, noatp] = minus_mult_left [symmetric]
-lemmas mult_minus_right [simp,noatp] = minus_mult_right [symmetric]
-
-lemma minus_mult_minus [simp]: "- a * - b = a * b"
-by simp
-
-lemma minus_mult_commute: "- a * b = a * - b"
-by simp
-
-lemma right_diff_distrib[algebra_simps]: "a * (b - c) = a * b - a * c"
-by (simp add: right_distrib diff_minus)
-
-lemma left_diff_distrib[algebra_simps]: "(a - b) * c = a * c - b * c"
-by (simp add: left_distrib diff_minus)
-
-lemmas ring_distribs[noatp] =
- right_distrib left_distrib left_diff_distrib right_diff_distrib
-
-text{*Legacy - use @{text algebra_simps} *}
-lemmas ring_simps[noatp] = algebra_simps
-
-lemma eq_add_iff1:
- "a * e + c = b * e + d \<longleftrightarrow> (a - b) * e + c = d"
-by (simp add: algebra_simps)
-
-lemma eq_add_iff2:
- "a * e + c = b * e + d \<longleftrightarrow> c = (b - a) * e + d"
-by (simp add: algebra_simps)
-
-end
-
-lemmas ring_distribs[noatp] =
- right_distrib left_distrib left_diff_distrib right_diff_distrib
-
-class comm_ring = comm_semiring + ab_group_add
-begin
-
-subclass ring ..
-subclass comm_semiring_0_cancel ..
-
-end
-
-class ring_1 = ring + zero_neq_one + monoid_mult
-begin
-
-subclass semiring_1_cancel ..
-
-end
-
-class comm_ring_1 = comm_ring + zero_neq_one + comm_monoid_mult
- (*previously ring*)
-begin
-
-subclass ring_1 ..
-subclass comm_semiring_1_cancel ..
-
-lemma dvd_minus_iff [simp]: "x dvd - y \<longleftrightarrow> x dvd y"
-proof
- assume "x dvd - y"
- then have "x dvd - 1 * - y" by (rule dvd_mult)
- then show "x dvd y" by simp
-next
- assume "x dvd y"
- then have "x dvd - 1 * y" by (rule dvd_mult)
- then show "x dvd - y" by simp
-qed
-
-lemma minus_dvd_iff [simp]: "- x dvd y \<longleftrightarrow> x dvd y"
-proof
- assume "- x dvd y"
- then obtain k where "y = - x * k" ..
- then have "y = x * - k" by simp
- then show "x dvd y" ..
-next
- assume "x dvd y"
- then obtain k where "y = x * k" ..
- then have "y = - x * - k" by simp
- then show "- x dvd y" ..
-qed
-
-lemma dvd_diff[simp]: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
-by (simp add: diff_minus dvd_minus_iff)
-
-end
-
-class ring_no_zero_divisors = ring + no_zero_divisors
-begin
-
-lemma mult_eq_0_iff [simp]:
- shows "a * b = 0 \<longleftrightarrow> (a = 0 \<or> b = 0)"
-proof (cases "a = 0 \<or> b = 0")
- case False then have "a \<noteq> 0" and "b \<noteq> 0" by auto
- then show ?thesis using no_zero_divisors by simp
-next
- case True then show ?thesis by auto
-qed
-
-text{*Cancellation of equalities with a common factor*}
-lemma mult_cancel_right [simp, noatp]:
- "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b"
-proof -
- have "(a * c = b * c) = ((a - b) * c = 0)"
- by (simp add: algebra_simps right_minus_eq)
- thus ?thesis by (simp add: disj_commute right_minus_eq)
-qed
-
-lemma mult_cancel_left [simp, noatp]:
- "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
-proof -
- have "(c * a = c * b) = (c * (a - b) = 0)"
- by (simp add: algebra_simps right_minus_eq)
- thus ?thesis by (simp add: right_minus_eq)
-qed
-
-end
-
-class ring_1_no_zero_divisors = ring_1 + ring_no_zero_divisors
-begin
-
-lemma mult_cancel_right1 [simp]:
- "c = b * c \<longleftrightarrow> c = 0 \<or> b = 1"
-by (insert mult_cancel_right [of 1 c b], force)
-
-lemma mult_cancel_right2 [simp]:
- "a * c = c \<longleftrightarrow> c = 0 \<or> a = 1"
-by (insert mult_cancel_right [of a c 1], simp)
-
-lemma mult_cancel_left1 [simp]:
- "c = c * b \<longleftrightarrow> c = 0 \<or> b = 1"
-by (insert mult_cancel_left [of c 1 b], force)
-
-lemma mult_cancel_left2 [simp]:
- "c * a = c \<longleftrightarrow> c = 0 \<or> a = 1"
-by (insert mult_cancel_left [of c a 1], simp)
-
-end
-
-class idom = comm_ring_1 + no_zero_divisors
-begin
-
-subclass ring_1_no_zero_divisors ..
-
-lemma square_eq_iff: "a * a = b * b \<longleftrightarrow> (a = b \<or> a = - b)"
-proof
- assume "a * a = b * b"
- then have "(a - b) * (a + b) = 0"
- by (simp add: algebra_simps)
- then show "a = b \<or> a = - b"
- by (simp add: right_minus_eq eq_neg_iff_add_eq_0)
-next
- assume "a = b \<or> a = - b"
- then show "a * a = b * b" by auto
-qed
-
-lemma dvd_mult_cancel_right [simp]:
- "a * c dvd b * c \<longleftrightarrow> c = 0 \<or> a dvd b"
-proof -
- have "a * c dvd b * c \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
- unfolding dvd_def by (simp add: mult_ac)
- also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
- unfolding dvd_def by simp
- finally show ?thesis .
-qed
-
-lemma dvd_mult_cancel_left [simp]:
- "c * a dvd c * b \<longleftrightarrow> c = 0 \<or> a dvd b"
-proof -
- have "c * a dvd c * b \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
- unfolding dvd_def by (simp add: mult_ac)
- also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
- unfolding dvd_def by simp
- finally show ?thesis .
-qed
-
-end
-
-class division_ring = ring_1 + inverse +
- assumes left_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
- assumes right_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> a * inverse a = 1"
-begin
-
-subclass ring_1_no_zero_divisors
-proof
- fix a b :: 'a
- assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
- show "a * b \<noteq> 0"
- proof
- assume ab: "a * b = 0"
- hence "0 = inverse a * (a * b) * inverse b" by simp
- also have "\<dots> = (inverse a * a) * (b * inverse b)"
- by (simp only: mult_assoc)
- also have "\<dots> = 1" using a b by simp
- finally show False by simp
- qed
-qed
-
-lemma nonzero_imp_inverse_nonzero:
- "a \<noteq> 0 \<Longrightarrow> inverse a \<noteq> 0"
-proof
- assume ianz: "inverse a = 0"
- assume "a \<noteq> 0"
- hence "1 = a * inverse a" by simp
- also have "... = 0" by (simp add: ianz)
- finally have "1 = 0" .
- thus False by (simp add: eq_commute)
-qed
-
-lemma inverse_zero_imp_zero:
- "inverse a = 0 \<Longrightarrow> a = 0"
-apply (rule classical)
-apply (drule nonzero_imp_inverse_nonzero)
-apply auto
-done
-
-lemma inverse_unique:
- assumes ab: "a * b = 1"
- shows "inverse a = b"
-proof -
- have "a \<noteq> 0" using ab by (cases "a = 0") simp_all
- moreover have "inverse a * (a * b) = inverse a" by (simp add: ab)
- ultimately show ?thesis by (simp add: mult_assoc [symmetric])
-qed
-
-lemma nonzero_inverse_minus_eq:
- "a \<noteq> 0 \<Longrightarrow> inverse (- a) = - inverse a"
-by (rule inverse_unique) simp
-
-lemma nonzero_inverse_inverse_eq:
- "a \<noteq> 0 \<Longrightarrow> inverse (inverse a) = a"
-by (rule inverse_unique) simp
-
-lemma nonzero_inverse_eq_imp_eq:
- assumes "inverse a = inverse b" and "a \<noteq> 0" and "b \<noteq> 0"
- shows "a = b"
-proof -
- from `inverse a = inverse b`
- have "inverse (inverse a) = inverse (inverse b)" by (rule arg_cong)
- with `a \<noteq> 0` and `b \<noteq> 0` show "a = b"
- by (simp add: nonzero_inverse_inverse_eq)
-qed
-
-lemma inverse_1 [simp]: "inverse 1 = 1"
-by (rule inverse_unique) simp
-
-lemma nonzero_inverse_mult_distrib:
- assumes "a \<noteq> 0" and "b \<noteq> 0"
- shows "inverse (a * b) = inverse b * inverse a"
-proof -
- have "a * (b * inverse b) * inverse a = 1" using assms by simp
- hence "a * b * (inverse b * inverse a) = 1" by (simp only: mult_assoc)
- thus ?thesis by (rule inverse_unique)
-qed
-
-lemma division_ring_inverse_add:
- "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = inverse a * (a + b) * inverse b"
-by (simp add: algebra_simps)
-
-lemma division_ring_inverse_diff:
- "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a - inverse b = inverse a * (b - a) * inverse b"
-by (simp add: algebra_simps)
-
-end
-
-class field = comm_ring_1 + inverse +
- assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
- assumes divide_inverse: "a / b = a * inverse b"
-begin
-
-subclass division_ring
-proof
- fix a :: 'a
- assume "a \<noteq> 0"
- thus "inverse a * a = 1" by (rule field_inverse)
- thus "a * inverse a = 1" by (simp only: mult_commute)
-qed
-
-subclass idom ..
-
-lemma right_inverse_eq: "b \<noteq> 0 \<Longrightarrow> a / b = 1 \<longleftrightarrow> a = b"
-proof
- assume neq: "b \<noteq> 0"
- {
- hence "a = (a / b) * b" by (simp add: divide_inverse mult_ac)
- also assume "a / b = 1"
- finally show "a = b" by simp
- next
- assume "a = b"
- with neq show "a / b = 1" by (simp add: divide_inverse)
- }
-qed
-
-lemma nonzero_inverse_eq_divide: "a \<noteq> 0 \<Longrightarrow> inverse a = 1 / a"
-by (simp add: divide_inverse)
-
-lemma divide_self [simp]: "a \<noteq> 0 \<Longrightarrow> a / a = 1"
-by (simp add: divide_inverse)
-
-lemma divide_zero_left [simp]: "0 / a = 0"
-by (simp add: divide_inverse)
-
-lemma inverse_eq_divide: "inverse a = 1 / a"
-by (simp add: divide_inverse)
-
-lemma add_divide_distrib: "(a+b) / c = a/c + b/c"
-by (simp add: divide_inverse algebra_simps)
-
-text{*There is no slick version using division by zero.*}
-lemma inverse_add:
- "[| a \<noteq> 0; b \<noteq> 0 |]
- ==> inverse a + inverse b = (a + b) * inverse a * inverse b"
-by (simp add: division_ring_inverse_add mult_ac)
-
-lemma nonzero_mult_divide_mult_cancel_left [simp, noatp]:
-assumes [simp]: "b\<noteq>0" and [simp]: "c\<noteq>0" shows "(c*a)/(c*b) = a/b"
-proof -
- have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
- by (simp add: divide_inverse nonzero_inverse_mult_distrib)
- also have "... = a * inverse b * (inverse c * c)"
- by (simp only: mult_ac)
- also have "... = a * inverse b" by simp
- finally show ?thesis by (simp add: divide_inverse)
-qed
-
-lemma nonzero_mult_divide_mult_cancel_right [simp, noatp]:
- "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (b * c) = a / b"
-by (simp add: mult_commute [of _ c])
-
-lemma divide_1 [simp]: "a / 1 = a"
-by (simp add: divide_inverse)
-
-lemma times_divide_eq_right: "a * (b / c) = (a * b) / c"
-by (simp add: divide_inverse mult_assoc)
-
-lemma times_divide_eq_left: "(b / c) * a = (b * a) / c"
-by (simp add: divide_inverse mult_ac)
-
-text {* These are later declared as simp rules. *}
-lemmas times_divide_eq [noatp] = times_divide_eq_right times_divide_eq_left
-
-lemma add_frac_eq:
- assumes "y \<noteq> 0" and "z \<noteq> 0"
- shows "x / y + w / z = (x * z + w * y) / (y * z)"
-proof -
- have "x / y + w / z = (x * z) / (y * z) + (y * w) / (y * z)"
- using assms by simp
- also have "\<dots> = (x * z + y * w) / (y * z)"
- by (simp only: add_divide_distrib)
- finally show ?thesis
- by (simp only: mult_commute)
-qed
-
-text{*Special Cancellation Simprules for Division*}
-
-lemma nonzero_mult_divide_cancel_right [simp, noatp]:
- "b \<noteq> 0 \<Longrightarrow> a * b / b = a"
-using nonzero_mult_divide_mult_cancel_right [of 1 b a] by simp
-
-lemma nonzero_mult_divide_cancel_left [simp, noatp]:
- "a \<noteq> 0 \<Longrightarrow> a * b / a = b"
-using nonzero_mult_divide_mult_cancel_left [of 1 a b] by simp
-
-lemma nonzero_divide_mult_cancel_right [simp, noatp]:
- "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> b / (a * b) = 1 / a"
-using nonzero_mult_divide_mult_cancel_right [of a b 1] by simp
-
-lemma nonzero_divide_mult_cancel_left [simp, noatp]:
- "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / (a * b) = 1 / b"
-using nonzero_mult_divide_mult_cancel_left [of b a 1] by simp
-
-lemma nonzero_mult_divide_mult_cancel_left2 [simp, noatp]:
- "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (c * a) / (b * c) = a / b"
-using nonzero_mult_divide_mult_cancel_left [of b c a] by (simp add: mult_ac)
-
-lemma nonzero_mult_divide_mult_cancel_right2 [simp, noatp]:
- "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (c * b) = a / b"
-using nonzero_mult_divide_mult_cancel_right [of b c a] by (simp add: mult_ac)
-
-lemma minus_divide_left: "- (a / b) = (-a) / b"
-by (simp add: divide_inverse)
-
-lemma nonzero_minus_divide_right: "b \<noteq> 0 ==> - (a / b) = a / (- b)"
-by (simp add: divide_inverse nonzero_inverse_minus_eq)
-
-lemma nonzero_minus_divide_divide: "b \<noteq> 0 ==> (-a) / (-b) = a / b"
-by (simp add: divide_inverse nonzero_inverse_minus_eq)
-
-lemma divide_minus_left [simp, noatp]: "(-a) / b = - (a / b)"
-by (simp add: divide_inverse)
-
-lemma diff_divide_distrib: "(a - b) / c = a / c - b / c"
-by (simp add: diff_minus add_divide_distrib)
-
-lemma add_divide_eq_iff:
- "z \<noteq> 0 \<Longrightarrow> x + y / z = (z * x + y) / z"
-by (simp add: add_divide_distrib)
-
-lemma divide_add_eq_iff:
- "z \<noteq> 0 \<Longrightarrow> x / z + y = (x + z * y) / z"
-by (simp add: add_divide_distrib)
-
-lemma diff_divide_eq_iff:
- "z \<noteq> 0 \<Longrightarrow> x - y / z = (z * x - y) / z"
-by (simp add: diff_divide_distrib)
-
-lemma divide_diff_eq_iff:
- "z \<noteq> 0 \<Longrightarrow> x / z - y = (x - z * y) / z"
-by (simp add: diff_divide_distrib)
-
-lemma nonzero_eq_divide_eq: "c \<noteq> 0 \<Longrightarrow> a = b / c \<longleftrightarrow> a * c = b"
-proof -
- assume [simp]: "c \<noteq> 0"
- have "a = b / c \<longleftrightarrow> a * c = (b / c) * c" by simp
- also have "... \<longleftrightarrow> a * c = b" by (simp add: divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma nonzero_divide_eq_eq: "c \<noteq> 0 \<Longrightarrow> b / c = a \<longleftrightarrow> b = a * c"
-proof -
- assume [simp]: "c \<noteq> 0"
- have "b / c = a \<longleftrightarrow> (b / c) * c = a * c" by simp
- also have "... \<longleftrightarrow> b = a * c" by (simp add: divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma divide_eq_imp: "c \<noteq> 0 \<Longrightarrow> b = a * c \<Longrightarrow> b / c = a"
-by simp
-
-lemma eq_divide_imp: "c \<noteq> 0 \<Longrightarrow> a * c = b \<Longrightarrow> a = b / c"
-by (erule subst, simp)
-
-lemmas field_eq_simps[noatp] = algebra_simps
- (* pull / out*)
- add_divide_eq_iff divide_add_eq_iff
- diff_divide_eq_iff divide_diff_eq_iff
- (* multiply eqn *)
- nonzero_eq_divide_eq nonzero_divide_eq_eq
-(* is added later:
- times_divide_eq_left times_divide_eq_right
-*)
-
-text{*An example:*}
-lemma "\<lbrakk>a\<noteq>b; c\<noteq>d; e\<noteq>f\<rbrakk> \<Longrightarrow> ((a-b)*(c-d)*(e-f))/((c-d)*(e-f)*(a-b)) = 1"
-apply(subgoal_tac "(c-d)*(e-f)*(a-b) \<noteq> 0")
- apply(simp add:field_eq_simps)
-apply(simp)
-done
-
-lemma diff_frac_eq:
- "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y - w / z = (x * z - w * y) / (y * z)"
-by (simp add: field_eq_simps times_divide_eq)
-
-lemma frac_eq_eq:
- "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> (x / y = w / z) = (x * z = w * y)"
-by (simp add: field_eq_simps times_divide_eq)
-
-end
-
-class division_by_zero = zero + inverse +
- assumes inverse_zero [simp]: "inverse 0 = 0"
-
-lemma divide_zero [simp]:
- "a / 0 = (0::'a::{field,division_by_zero})"
-by (simp add: divide_inverse)
-
-lemma divide_self_if [simp]:
- "a / (a::'a::{field,division_by_zero}) = (if a=0 then 0 else 1)"
-by simp
-
-class mult_mono = times + zero + ord +
- assumes mult_left_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
- assumes mult_right_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a * c \<le> b * c"
-
-class pordered_semiring = mult_mono + semiring_0 + pordered_ab_semigroup_add
-begin
-
-lemma mult_mono:
- "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> c
- \<Longrightarrow> a * c \<le> b * d"
-apply (erule mult_right_mono [THEN order_trans], assumption)
-apply (erule mult_left_mono, assumption)
-done
-
-lemma mult_mono':
- "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> c
- \<Longrightarrow> a * c \<le> b * d"
-apply (rule mult_mono)
-apply (fast intro: order_trans)+
-done
-
-end
-
-class pordered_cancel_semiring = mult_mono + pordered_ab_semigroup_add
- + semiring + cancel_comm_monoid_add
-begin
-
-subclass semiring_0_cancel ..
-subclass pordered_semiring ..
-
-lemma mult_nonneg_nonneg: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a * b"
-using mult_left_mono [of zero b a] by simp
-
-lemma mult_nonneg_nonpos: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> a * b \<le> 0"
-using mult_left_mono [of b zero a] by simp
-
-lemma mult_nonpos_nonneg: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> a * b \<le> 0"
-using mult_right_mono [of a zero b] by simp
-
-text {* Legacy - use @{text mult_nonpos_nonneg} *}
-lemma mult_nonneg_nonpos2: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> b * a \<le> 0"
-by (drule mult_right_mono [of b zero], auto)
-
-lemma split_mult_neg_le: "(0 \<le> a & b \<le> 0) | (a \<le> 0 & 0 \<le> b) \<Longrightarrow> a * b \<le> 0"
-by (auto simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)
-
-end
-
-class ordered_semiring = semiring + comm_monoid_add + ordered_cancel_ab_semigroup_add + mult_mono
-begin
-
-subclass pordered_cancel_semiring ..
-
-subclass pordered_comm_monoid_add ..
-
-lemma mult_left_less_imp_less:
- "c * a < c * b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
-by (force simp add: mult_left_mono not_le [symmetric])
-
-lemma mult_right_less_imp_less:
- "a * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
-by (force simp add: mult_right_mono not_le [symmetric])
-
-end
-
-class ordered_semiring_1 = ordered_semiring + semiring_1
-
-class ordered_semiring_strict = semiring + comm_monoid_add + ordered_cancel_ab_semigroup_add +
- assumes mult_strict_left_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
- assumes mult_strict_right_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> a * c < b * c"
-begin
-
-subclass semiring_0_cancel ..
-
-subclass ordered_semiring
-proof
- fix a b c :: 'a
- assume A: "a \<le> b" "0 \<le> c"
- from A show "c * a \<le> c * b"
- unfolding le_less
- using mult_strict_left_mono by (cases "c = 0") auto
- from A show "a * c \<le> b * c"
- unfolding le_less
- using mult_strict_right_mono by (cases "c = 0") auto
-qed
-
-lemma mult_left_le_imp_le:
- "c * a \<le> c * b \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
-by (force simp add: mult_strict_left_mono _not_less [symmetric])
-
-lemma mult_right_le_imp_le:
- "a * c \<le> b * c \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
-by (force simp add: mult_strict_right_mono not_less [symmetric])
-
-lemma mult_pos_pos: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a * b"
-using mult_strict_left_mono [of zero b a] by simp
-
-lemma mult_pos_neg: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> a * b < 0"
-using mult_strict_left_mono [of b zero a] by simp
-
-lemma mult_neg_pos: "a < 0 \<Longrightarrow> 0 < b \<Longrightarrow> a * b < 0"
-using mult_strict_right_mono [of a zero b] by simp
-
-text {* Legacy - use @{text mult_neg_pos} *}
-lemma mult_pos_neg2: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> b * a < 0"
-by (drule mult_strict_right_mono [of b zero], auto)
-
-lemma zero_less_mult_pos:
- "0 < a * b \<Longrightarrow> 0 < a \<Longrightarrow> 0 < b"
-apply (cases "b\<le>0")
- apply (auto simp add: le_less not_less)
-apply (drule_tac mult_pos_neg [of a b])
- apply (auto dest: less_not_sym)
-done
-
-lemma zero_less_mult_pos2:
- "0 < b * a \<Longrightarrow> 0 < a \<Longrightarrow> 0 < b"
-apply (cases "b\<le>0")
- apply (auto simp add: le_less not_less)
-apply (drule_tac mult_pos_neg2 [of a b])
- apply (auto dest: less_not_sym)
-done
-
-text{*Strict monotonicity in both arguments*}
-lemma mult_strict_mono:
- assumes "a < b" and "c < d" and "0 < b" and "0 \<le> c"
- shows "a * c < b * d"
- using assms apply (cases "c=0")
- apply (simp add: mult_pos_pos)
- apply (erule mult_strict_right_mono [THEN less_trans])
- apply (force simp add: le_less)
- apply (erule mult_strict_left_mono, assumption)
- done
-
-text{*This weaker variant has more natural premises*}
-lemma mult_strict_mono':
- assumes "a < b" and "c < d" and "0 \<le> a" and "0 \<le> c"
- shows "a * c < b * d"
-by (rule mult_strict_mono) (insert assms, auto)
-
-lemma mult_less_le_imp_less:
- assumes "a < b" and "c \<le> d" and "0 \<le> a" and "0 < c"
- shows "a * c < b * d"
- using assms apply (subgoal_tac "a * c < b * c")
- apply (erule less_le_trans)
- apply (erule mult_left_mono)
- apply simp
- apply (erule mult_strict_right_mono)
- apply assumption
- done
-
-lemma mult_le_less_imp_less:
- assumes "a \<le> b" and "c < d" and "0 < a" and "0 \<le> c"
- shows "a * c < b * d"
- using assms apply (subgoal_tac "a * c \<le> b * c")
- apply (erule le_less_trans)
- apply (erule mult_strict_left_mono)
- apply simp
- apply (erule mult_right_mono)
- apply simp
- done
-
-lemma mult_less_imp_less_left:
- assumes less: "c * a < c * b" and nonneg: "0 \<le> c"
- shows "a < b"
-proof (rule ccontr)
- assume "\<not> a < b"
- hence "b \<le> a" by (simp add: linorder_not_less)
- hence "c * b \<le> c * a" using nonneg by (rule mult_left_mono)
- with this and less show False by (simp add: not_less [symmetric])
-qed
-
-lemma mult_less_imp_less_right:
- assumes less: "a * c < b * c" and nonneg: "0 \<le> c"
- shows "a < b"
-proof (rule ccontr)
- assume "\<not> a < b"
- hence "b \<le> a" by (simp add: linorder_not_less)
- hence "b * c \<le> a * c" using nonneg by (rule mult_right_mono)
- with this and less show False by (simp add: not_less [symmetric])
-qed
-
-end
-
-class ordered_semiring_1_strict = ordered_semiring_strict + semiring_1
-
-class mult_mono1 = times + zero + ord +
- assumes mult_mono1: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
-
-class pordered_comm_semiring = comm_semiring_0
- + pordered_ab_semigroup_add + mult_mono1
-begin
-
-subclass pordered_semiring
-proof
- fix a b c :: 'a
- assume "a \<le> b" "0 \<le> c"
- thus "c * a \<le> c * b" by (rule mult_mono1)
- thus "a * c \<le> b * c" by (simp only: mult_commute)
-qed
-
-end
-
-class pordered_cancel_comm_semiring = comm_semiring_0_cancel
- + pordered_ab_semigroup_add + mult_mono1
-begin
-
-subclass pordered_comm_semiring ..
-subclass pordered_cancel_semiring ..
-
-end
-
-class ordered_comm_semiring_strict = comm_semiring_0 + ordered_cancel_ab_semigroup_add +
- assumes mult_strict_left_mono_comm: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
-begin
-
-subclass ordered_semiring_strict
-proof
- fix a b c :: 'a
- assume "a < b" "0 < c"
- thus "c * a < c * b" by (rule mult_strict_left_mono_comm)
- thus "a * c < b * c" by (simp only: mult_commute)
-qed
-
-subclass pordered_cancel_comm_semiring
-proof
- fix a b c :: 'a
- assume "a \<le> b" "0 \<le> c"
- thus "c * a \<le> c * b"
- unfolding le_less
- using mult_strict_left_mono by (cases "c = 0") auto
-qed
-
-end
-
-class pordered_ring = ring + pordered_cancel_semiring
-begin
-
-subclass pordered_ab_group_add ..
-
-text{*Legacy - use @{text algebra_simps} *}
-lemmas ring_simps[noatp] = algebra_simps
-
-lemma less_add_iff1:
- "a * e + c < b * e + d \<longleftrightarrow> (a - b) * e + c < d"
-by (simp add: algebra_simps)
-
-lemma less_add_iff2:
- "a * e + c < b * e + d \<longleftrightarrow> c < (b - a) * e + d"
-by (simp add: algebra_simps)
-
-lemma le_add_iff1:
- "a * e + c \<le> b * e + d \<longleftrightarrow> (a - b) * e + c \<le> d"
-by (simp add: algebra_simps)
-
-lemma le_add_iff2:
- "a * e + c \<le> b * e + d \<longleftrightarrow> c \<le> (b - a) * e + d"
-by (simp add: algebra_simps)
-
-lemma mult_left_mono_neg:
- "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> c * a \<le> c * b"
- apply (drule mult_left_mono [of _ _ "uminus c"])
- apply (simp_all add: minus_mult_left [symmetric])
- done
-
-lemma mult_right_mono_neg:
- "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> a * c \<le> b * c"
- apply (drule mult_right_mono [of _ _ "uminus c"])
- apply (simp_all add: minus_mult_right [symmetric])
- done
-
-lemma mult_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> 0 \<le> a * b"
-using mult_right_mono_neg [of a zero b] by simp
-
-lemma split_mult_pos_le:
- "(0 \<le> a \<and> 0 \<le> b) \<or> (a \<le> 0 \<and> b \<le> 0) \<Longrightarrow> 0 \<le> a * b"
-by (auto simp add: mult_nonneg_nonneg mult_nonpos_nonpos)
-
-end
-
-class abs_if = minus + uminus + ord + zero + abs +
- assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"
-
-class sgn_if = minus + uminus + zero + one + ord + sgn +
- assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
-
-lemma (in sgn_if) sgn0[simp]: "sgn 0 = 0"
-by(simp add:sgn_if)
-
-class ordered_ring = ring + ordered_semiring
- + ordered_ab_group_add + abs_if
-begin
-
-subclass pordered_ring ..
-
-subclass pordered_ab_group_add_abs
-proof
- fix a b
- show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
-by (auto simp add: abs_if not_less neg_less_eq_nonneg less_eq_neg_nonpos)
- (auto simp del: minus_add_distrib simp add: minus_add_distrib [symmetric]
- neg_less_eq_nonneg less_eq_neg_nonpos, auto intro: add_nonneg_nonneg,
- auto intro!: less_imp_le add_neg_neg)
-qed (auto simp add: abs_if less_eq_neg_nonpos neg_equal_zero)
-
-end
-
-(* The "strict" suffix can be seen as describing the combination of ordered_ring and no_zero_divisors.
- Basically, ordered_ring + no_zero_divisors = ordered_ring_strict.
- *)
-class ordered_ring_strict = ring + ordered_semiring_strict
- + ordered_ab_group_add + abs_if
-begin
-
-subclass ordered_ring ..
-
-lemma mult_strict_left_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> c * a < c * b"
-using mult_strict_left_mono [of b a "- c"] by simp
-
-lemma mult_strict_right_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> a * c < b * c"
-using mult_strict_right_mono [of b a "- c"] by simp
-
-lemma mult_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> 0 < a * b"
-using mult_strict_right_mono_neg [of a zero b] by simp
-
-subclass ring_no_zero_divisors
-proof
- fix a b
- assume "a \<noteq> 0" then have A: "a < 0 \<or> 0 < a" by (simp add: neq_iff)
- assume "b \<noteq> 0" then have B: "b < 0 \<or> 0 < b" by (simp add: neq_iff)
- have "a * b < 0 \<or> 0 < a * b"
- proof (cases "a < 0")
- case True note A' = this
- show ?thesis proof (cases "b < 0")
- case True with A'
- show ?thesis by (auto dest: mult_neg_neg)
- next
- case False with B have "0 < b" by auto
- with A' show ?thesis by (auto dest: mult_strict_right_mono)
- qed
- next
- case False with A have A': "0 < a" by auto
- show ?thesis proof (cases "b < 0")
- case True with A'
- show ?thesis by (auto dest: mult_strict_right_mono_neg)
- next
- case False with B have "0 < b" by auto
- with A' show ?thesis by (auto dest: mult_pos_pos)
- qed
- qed
- then show "a * b \<noteq> 0" by (simp add: neq_iff)
-qed
-
-lemma zero_less_mult_iff:
- "0 < a * b \<longleftrightarrow> 0 < a \<and> 0 < b \<or> a < 0 \<and> b < 0"
- apply (auto simp add: mult_pos_pos mult_neg_neg)
- apply (simp_all add: not_less le_less)
- apply (erule disjE) apply assumption defer
- apply (erule disjE) defer apply (drule sym) apply simp
- apply (erule disjE) defer apply (drule sym) apply simp
- apply (erule disjE) apply assumption apply (drule sym) apply simp
- apply (drule sym) apply simp
- apply (blast dest: zero_less_mult_pos)
- apply (blast dest: zero_less_mult_pos2)
- done
-
-lemma zero_le_mult_iff:
- "0 \<le> a * b \<longleftrightarrow> 0 \<le> a \<and> 0 \<le> b \<or> a \<le> 0 \<and> b \<le> 0"
-by (auto simp add: eq_commute [of 0] le_less not_less zero_less_mult_iff)
-
-lemma mult_less_0_iff:
- "a * b < 0 \<longleftrightarrow> 0 < a \<and> b < 0 \<or> a < 0 \<and> 0 < b"
- apply (insert zero_less_mult_iff [of "-a" b])
- apply (force simp add: minus_mult_left[symmetric])
- done
-
-lemma mult_le_0_iff:
- "a * b \<le> 0 \<longleftrightarrow> 0 \<le> a \<and> b \<le> 0 \<or> a \<le> 0 \<and> 0 \<le> b"
- apply (insert zero_le_mult_iff [of "-a" b])
- apply (force simp add: minus_mult_left[symmetric])
- done
-
-lemma zero_le_square [simp]: "0 \<le> a * a"
-by (simp add: zero_le_mult_iff linear)
-
-lemma not_square_less_zero [simp]: "\<not> (a * a < 0)"
-by (simp add: not_less)
-
-text{*Cancellation laws for @{term "c*a < c*b"} and @{term "a*c < b*c"},
- also with the relations @{text "\<le>"} and equality.*}
-
-text{*These ``disjunction'' versions produce two cases when the comparison is
- an assumption, but effectively four when the comparison is a goal.*}
-
-lemma mult_less_cancel_right_disj:
- "a * c < b * c \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
- apply (cases "c = 0")
- apply (auto simp add: neq_iff mult_strict_right_mono
- mult_strict_right_mono_neg)
- apply (auto simp add: not_less
- not_le [symmetric, of "a*c"]
- not_le [symmetric, of a])
- apply (erule_tac [!] notE)
- apply (auto simp add: less_imp_le mult_right_mono
- mult_right_mono_neg)
- done
-
-lemma mult_less_cancel_left_disj:
- "c * a < c * b \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
- apply (cases "c = 0")
- apply (auto simp add: neq_iff mult_strict_left_mono
- mult_strict_left_mono_neg)
- apply (auto simp add: not_less
- not_le [symmetric, of "c*a"]
- not_le [symmetric, of a])
- apply (erule_tac [!] notE)
- apply (auto simp add: less_imp_le mult_left_mono
- mult_left_mono_neg)
- done
-
-text{*The ``conjunction of implication'' lemmas produce two cases when the
-comparison is a goal, but give four when the comparison is an assumption.*}
-
-lemma mult_less_cancel_right:
- "a * c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
- using mult_less_cancel_right_disj [of a c b] by auto
-
-lemma mult_less_cancel_left:
- "c * a < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
- using mult_less_cancel_left_disj [of c a b] by auto
-
-lemma mult_le_cancel_right:
- "a * c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
-by (simp add: not_less [symmetric] mult_less_cancel_right_disj)
-
-lemma mult_le_cancel_left:
- "c * a \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
-by (simp add: not_less [symmetric] mult_less_cancel_left_disj)
-
-lemma mult_le_cancel_left_pos:
- "0 < c \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> a \<le> b"
-by (auto simp: mult_le_cancel_left)
-
-lemma mult_le_cancel_left_neg:
- "c < 0 \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> b \<le> a"
-by (auto simp: mult_le_cancel_left)
-
-lemma mult_less_cancel_left_pos:
- "0 < c \<Longrightarrow> c * a < c * b \<longleftrightarrow> a < b"
-by (auto simp: mult_less_cancel_left)
-
-lemma mult_less_cancel_left_neg:
- "c < 0 \<Longrightarrow> c * a < c * b \<longleftrightarrow> b < a"
-by (auto simp: mult_less_cancel_left)
-
-end
-
-text{*Legacy - use @{text algebra_simps} *}
-lemmas ring_simps[noatp] = algebra_simps
-
-lemmas mult_sign_intros =
- mult_nonneg_nonneg mult_nonneg_nonpos
- mult_nonpos_nonneg mult_nonpos_nonpos
- mult_pos_pos mult_pos_neg
- mult_neg_pos mult_neg_neg
-
-class pordered_comm_ring = comm_ring + pordered_comm_semiring
-begin
-
-subclass pordered_ring ..
-subclass pordered_cancel_comm_semiring ..
-
-end
-
-class ordered_semidom = comm_semiring_1_cancel + ordered_comm_semiring_strict +
- (*previously ordered_semiring*)
- assumes zero_less_one [simp]: "0 < 1"
-begin
-
-lemma pos_add_strict:
- shows "0 < a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
- using add_strict_mono [of zero a b c] by simp
-
-lemma zero_le_one [simp]: "0 \<le> 1"
-by (rule zero_less_one [THEN less_imp_le])
-
-lemma not_one_le_zero [simp]: "\<not> 1 \<le> 0"
-by (simp add: not_le)
-
-lemma not_one_less_zero [simp]: "\<not> 1 < 0"
-by (simp add: not_less)
-
-lemma less_1_mult:
- assumes "1 < m" and "1 < n"
- shows "1 < m * n"
- using assms mult_strict_mono [of 1 m 1 n]
- by (simp add: less_trans [OF zero_less_one])
-
-end
-
-class ordered_idom = comm_ring_1 +
- ordered_comm_semiring_strict + ordered_ab_group_add +
- abs_if + sgn_if
- (*previously ordered_ring*)
-begin
-
-subclass ordered_ring_strict ..
-subclass pordered_comm_ring ..
-subclass idom ..
-
-subclass ordered_semidom
-proof
- have "0 \<le> 1 * 1" by (rule zero_le_square)
- thus "0 < 1" by (simp add: le_less)
-qed
-
-lemma linorder_neqE_ordered_idom:
- assumes "x \<noteq> y" obtains "x < y" | "y < x"
- using assms by (rule neqE)
-
-text {* These cancellation simprules also produce two cases when the comparison is a goal. *}
-
-lemma mult_le_cancel_right1:
- "c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
-by (insert mult_le_cancel_right [of 1 c b], simp)
-
-lemma mult_le_cancel_right2:
- "a * c \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
-by (insert mult_le_cancel_right [of a c 1], simp)
-
-lemma mult_le_cancel_left1:
- "c \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
-by (insert mult_le_cancel_left [of c 1 b], simp)
-
-lemma mult_le_cancel_left2:
- "c * a \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
-by (insert mult_le_cancel_left [of c a 1], simp)
-
-lemma mult_less_cancel_right1:
- "c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
-by (insert mult_less_cancel_right [of 1 c b], simp)
-
-lemma mult_less_cancel_right2:
- "a * c < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
-by (insert mult_less_cancel_right [of a c 1], simp)
-
-lemma mult_less_cancel_left1:
- "c < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
-by (insert mult_less_cancel_left [of c 1 b], simp)
-
-lemma mult_less_cancel_left2:
- "c * a < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
-by (insert mult_less_cancel_left [of c a 1], simp)
-
-lemma sgn_sgn [simp]:
- "sgn (sgn a) = sgn a"
-unfolding sgn_if by simp
-
-lemma sgn_0_0:
- "sgn a = 0 \<longleftrightarrow> a = 0"
-unfolding sgn_if by simp
-
-lemma sgn_1_pos:
- "sgn a = 1 \<longleftrightarrow> a > 0"
-unfolding sgn_if by (simp add: neg_equal_zero)
-
-lemma sgn_1_neg:
- "sgn a = - 1 \<longleftrightarrow> a < 0"
-unfolding sgn_if by (auto simp add: equal_neg_zero)
-
-lemma sgn_pos [simp]:
- "0 < a \<Longrightarrow> sgn a = 1"
-unfolding sgn_1_pos .
-
-lemma sgn_neg [simp]:
- "a < 0 \<Longrightarrow> sgn a = - 1"
-unfolding sgn_1_neg .
-
-lemma sgn_times:
- "sgn (a * b) = sgn a * sgn b"
-by (auto simp add: sgn_if zero_less_mult_iff)
-
-lemma abs_sgn: "abs k = k * sgn k"
-unfolding sgn_if abs_if by auto
-
-lemma sgn_greater [simp]:
- "0 < sgn a \<longleftrightarrow> 0 < a"
- unfolding sgn_if by auto
-
-lemma sgn_less [simp]:
- "sgn a < 0 \<longleftrightarrow> a < 0"
- unfolding sgn_if by auto
-
-lemma abs_dvd_iff [simp]: "(abs m) dvd k \<longleftrightarrow> m dvd k"
- by (simp add: abs_if)
-
-lemma dvd_abs_iff [simp]: "m dvd (abs k) \<longleftrightarrow> m dvd k"
- by (simp add: abs_if)
-
-lemma dvd_if_abs_eq:
- "abs l = abs (k) \<Longrightarrow> l dvd k"
-by(subst abs_dvd_iff[symmetric]) simp
-
-end
-
-class ordered_field = field + ordered_idom
-
-text {* Simprules for comparisons where common factors can be cancelled. *}
-
-lemmas mult_compare_simps[noatp] =
- mult_le_cancel_right mult_le_cancel_left
- mult_le_cancel_right1 mult_le_cancel_right2
- mult_le_cancel_left1 mult_le_cancel_left2
- mult_less_cancel_right mult_less_cancel_left
- mult_less_cancel_right1 mult_less_cancel_right2
- mult_less_cancel_left1 mult_less_cancel_left2
- mult_cancel_right mult_cancel_left
- mult_cancel_right1 mult_cancel_right2
- mult_cancel_left1 mult_cancel_left2
-
--- {* FIXME continue localization here *}
-
-lemma inverse_nonzero_iff_nonzero [simp]:
- "(inverse a = 0) = (a = (0::'a::{division_ring,division_by_zero}))"
-by (force dest: inverse_zero_imp_zero)
-
-lemma inverse_minus_eq [simp]:
- "inverse(-a) = -inverse(a::'a::{division_ring,division_by_zero})"
-proof cases
- assume "a=0" thus ?thesis by (simp add: inverse_zero)
-next
- assume "a\<noteq>0"
- thus ?thesis by (simp add: nonzero_inverse_minus_eq)
-qed
-
-lemma inverse_eq_imp_eq:
- "inverse a = inverse b ==> a = (b::'a::{division_ring,division_by_zero})"
-apply (cases "a=0 | b=0")
- apply (force dest!: inverse_zero_imp_zero
- simp add: eq_commute [of "0::'a"])
-apply (force dest!: nonzero_inverse_eq_imp_eq)
-done
-
-lemma inverse_eq_iff_eq [simp]:
- "(inverse a = inverse b) = (a = (b::'a::{division_ring,division_by_zero}))"
-by (force dest!: inverse_eq_imp_eq)
-
-lemma inverse_inverse_eq [simp]:
- "inverse(inverse (a::'a::{division_ring,division_by_zero})) = a"
- proof cases
- assume "a=0" thus ?thesis by simp
- next
- assume "a\<noteq>0"
- thus ?thesis by (simp add: nonzero_inverse_inverse_eq)
- qed
-
-text{*This version builds in division by zero while also re-orienting
- the right-hand side.*}
-lemma inverse_mult_distrib [simp]:
- "inverse(a*b) = inverse(a) * inverse(b::'a::{field,division_by_zero})"
- proof cases
- assume "a \<noteq> 0 & b \<noteq> 0"
- thus ?thesis by (simp add: nonzero_inverse_mult_distrib mult_commute)
- next
- assume "~ (a \<noteq> 0 & b \<noteq> 0)"
- thus ?thesis by force
- qed
-
-lemma inverse_divide [simp]:
- "inverse (a/b) = b / (a::'a::{field,division_by_zero})"
-by (simp add: divide_inverse mult_commute)
-
-
-subsection {* Calculations with fractions *}
-
-text{* There is a whole bunch of simp-rules just for class @{text
-field} but none for class @{text field} and @{text nonzero_divides}
-because the latter are covered by a simproc. *}
-
-lemma mult_divide_mult_cancel_left:
- "c\<noteq>0 ==> (c*a) / (c*b) = a / (b::'a::{field,division_by_zero})"
-apply (cases "b = 0")
-apply (simp_all add: nonzero_mult_divide_mult_cancel_left)
-done
-
-lemma mult_divide_mult_cancel_right:
- "c\<noteq>0 ==> (a*c) / (b*c) = a / (b::'a::{field,division_by_zero})"
-apply (cases "b = 0")
-apply (simp_all add: nonzero_mult_divide_mult_cancel_right)
-done
-
-lemma divide_divide_eq_right [simp,noatp]:
- "a / (b/c) = (a*c) / (b::'a::{field,division_by_zero})"
-by (simp add: divide_inverse mult_ac)
-
-lemma divide_divide_eq_left [simp,noatp]:
- "(a / b) / (c::'a::{field,division_by_zero}) = a / (b*c)"
-by (simp add: divide_inverse mult_assoc)
-
-
-subsubsection{*Special Cancellation Simprules for Division*}
-
-lemma mult_divide_mult_cancel_left_if[simp,noatp]:
-fixes c :: "'a :: {field,division_by_zero}"
-shows "(c*a) / (c*b) = (if c=0 then 0 else a/b)"
-by (simp add: mult_divide_mult_cancel_left)
-
-
-subsection {* Division and Unary Minus *}
-
-lemma minus_divide_right: "- (a/b) = a / -(b::'a::{field,division_by_zero})"
-by (simp add: divide_inverse)
-
-lemma divide_minus_right [simp, noatp]:
- "a / -(b::'a::{field,division_by_zero}) = -(a / b)"
-by (simp add: divide_inverse)
-
-lemma minus_divide_divide:
- "(-a)/(-b) = a / (b::'a::{field,division_by_zero})"
-apply (cases "b=0", simp)
-apply (simp add: nonzero_minus_divide_divide)
-done
-
-lemma eq_divide_eq:
- "((a::'a::{field,division_by_zero}) = b/c) = (if c\<noteq>0 then a*c = b else a=0)"
-by (simp add: nonzero_eq_divide_eq)
-
-lemma divide_eq_eq:
- "(b/c = (a::'a::{field,division_by_zero})) = (if c\<noteq>0 then b = a*c else a=0)"
-by (force simp add: nonzero_divide_eq_eq)
-
-
-subsection {* Ordered Fields *}
-
-lemma positive_imp_inverse_positive:
-assumes a_gt_0: "0 < a" shows "0 < inverse (a::'a::ordered_field)"
-proof -
- have "0 < a * inverse a"
- by (simp add: a_gt_0 [THEN order_less_imp_not_eq2] zero_less_one)
- thus "0 < inverse a"
- by (simp add: a_gt_0 [THEN order_less_not_sym] zero_less_mult_iff)
-qed
-
-lemma negative_imp_inverse_negative:
- "a < 0 ==> inverse a < (0::'a::ordered_field)"
-by (insert positive_imp_inverse_positive [of "-a"],
- simp add: nonzero_inverse_minus_eq order_less_imp_not_eq)
-
-lemma inverse_le_imp_le:
-assumes invle: "inverse a \<le> inverse b" and apos: "0 < a"
-shows "b \<le> (a::'a::ordered_field)"
-proof (rule classical)
- assume "~ b \<le> a"
- hence "a < b" by (simp add: linorder_not_le)
- hence bpos: "0 < b" by (blast intro: apos order_less_trans)
- hence "a * inverse a \<le> a * inverse b"
- by (simp add: apos invle order_less_imp_le mult_left_mono)
- hence "(a * inverse a) * b \<le> (a * inverse b) * b"
- by (simp add: bpos order_less_imp_le mult_right_mono)
- thus "b \<le> a" by (simp add: mult_assoc apos bpos order_less_imp_not_eq2)
-qed
-
-lemma inverse_positive_imp_positive:
-assumes inv_gt_0: "0 < inverse a" and nz: "a \<noteq> 0"
-shows "0 < (a::'a::ordered_field)"
-proof -
- have "0 < inverse (inverse a)"
- using inv_gt_0 by (rule positive_imp_inverse_positive)
- thus "0 < a"
- using nz by (simp add: nonzero_inverse_inverse_eq)
-qed
-
-lemma inverse_positive_iff_positive [simp]:
- "(0 < inverse a) = (0 < (a::'a::{ordered_field,division_by_zero}))"
-apply (cases "a = 0", simp)
-apply (blast intro: inverse_positive_imp_positive positive_imp_inverse_positive)
-done
-
-lemma inverse_negative_imp_negative:
-assumes inv_less_0: "inverse a < 0" and nz: "a \<noteq> 0"
-shows "a < (0::'a::ordered_field)"
-proof -
- have "inverse (inverse a) < 0"
- using inv_less_0 by (rule negative_imp_inverse_negative)
- thus "a < 0" using nz by (simp add: nonzero_inverse_inverse_eq)
-qed
-
-lemma inverse_negative_iff_negative [simp]:
- "(inverse a < 0) = (a < (0::'a::{ordered_field,division_by_zero}))"
-apply (cases "a = 0", simp)
-apply (blast intro: inverse_negative_imp_negative negative_imp_inverse_negative)
-done
-
-lemma inverse_nonnegative_iff_nonnegative [simp]:
- "(0 \<le> inverse a) = (0 \<le> (a::'a::{ordered_field,division_by_zero}))"
-by (simp add: linorder_not_less [symmetric])
-
-lemma inverse_nonpositive_iff_nonpositive [simp]:
- "(inverse a \<le> 0) = (a \<le> (0::'a::{ordered_field,division_by_zero}))"
-by (simp add: linorder_not_less [symmetric])
-
-lemma ordered_field_no_lb: "\<forall> x. \<exists>y. y < (x::'a::ordered_field)"
-proof
- fix x::'a
- have m1: "- (1::'a) < 0" by simp
- from add_strict_right_mono[OF m1, where c=x]
- have "(- 1) + x < x" by simp
- thus "\<exists>y. y < x" by blast
-qed
-
-lemma ordered_field_no_ub: "\<forall> x. \<exists>y. y > (x::'a::ordered_field)"
-proof
- fix x::'a
- have m1: " (1::'a) > 0" by simp
- from add_strict_right_mono[OF m1, where c=x]
- have "1 + x > x" by simp
- thus "\<exists>y. y > x" by blast
-qed
-
-subsection{*Anti-Monotonicity of @{term inverse}*}
-
-lemma less_imp_inverse_less:
-assumes less: "a < b" and apos: "0 < a"
-shows "inverse b < inverse (a::'a::ordered_field)"
-proof (rule ccontr)
- assume "~ inverse b < inverse a"
- hence "inverse a \<le> inverse b" by (simp add: linorder_not_less)
- hence "~ (a < b)"
- by (simp add: linorder_not_less inverse_le_imp_le [OF _ apos])
- thus False by (rule notE [OF _ less])
-qed
-
-lemma inverse_less_imp_less:
- "[|inverse a < inverse b; 0 < a|] ==> b < (a::'a::ordered_field)"
-apply (simp add: order_less_le [of "inverse a"] order_less_le [of "b"])
-apply (force dest!: inverse_le_imp_le nonzero_inverse_eq_imp_eq)
-done
-
-text{*Both premises are essential. Consider -1 and 1.*}
-lemma inverse_less_iff_less [simp,noatp]:
- "[|0 < a; 0 < b|] ==> (inverse a < inverse b) = (b < (a::'a::ordered_field))"
-by (blast intro: less_imp_inverse_less dest: inverse_less_imp_less)
-
-lemma le_imp_inverse_le:
- "[|a \<le> b; 0 < a|] ==> inverse b \<le> inverse (a::'a::ordered_field)"
-by (force simp add: order_le_less less_imp_inverse_less)
-
-lemma inverse_le_iff_le [simp,noatp]:
- "[|0 < a; 0 < b|] ==> (inverse a \<le> inverse b) = (b \<le> (a::'a::ordered_field))"
-by (blast intro: le_imp_inverse_le dest: inverse_le_imp_le)
-
-
-text{*These results refer to both operands being negative. The opposite-sign
-case is trivial, since inverse preserves signs.*}
-lemma inverse_le_imp_le_neg:
- "[|inverse a \<le> inverse b; b < 0|] ==> b \<le> (a::'a::ordered_field)"
-apply (rule classical)
-apply (subgoal_tac "a < 0")
- prefer 2 apply (force simp add: linorder_not_le intro: order_less_trans)
-apply (insert inverse_le_imp_le [of "-b" "-a"])
-apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
-done
-
-lemma less_imp_inverse_less_neg:
- "[|a < b; b < 0|] ==> inverse b < inverse (a::'a::ordered_field)"
-apply (subgoal_tac "a < 0")
- prefer 2 apply (blast intro: order_less_trans)
-apply (insert less_imp_inverse_less [of "-b" "-a"])
-apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
-done
-
-lemma inverse_less_imp_less_neg:
- "[|inverse a < inverse b; b < 0|] ==> b < (a::'a::ordered_field)"
-apply (rule classical)
-apply (subgoal_tac "a < 0")
- prefer 2
- apply (force simp add: linorder_not_less intro: order_le_less_trans)
-apply (insert inverse_less_imp_less [of "-b" "-a"])
-apply (simp add: order_less_imp_not_eq nonzero_inverse_minus_eq)
-done
-
-lemma inverse_less_iff_less_neg [simp,noatp]:
- "[|a < 0; b < 0|] ==> (inverse a < inverse b) = (b < (a::'a::ordered_field))"
-apply (insert inverse_less_iff_less [of "-b" "-a"])
-apply (simp del: inverse_less_iff_less
- add: order_less_imp_not_eq nonzero_inverse_minus_eq)
-done
-
-lemma le_imp_inverse_le_neg:
- "[|a \<le> b; b < 0|] ==> inverse b \<le> inverse (a::'a::ordered_field)"
-by (force simp add: order_le_less less_imp_inverse_less_neg)
-
-lemma inverse_le_iff_le_neg [simp,noatp]:
- "[|a < 0; b < 0|] ==> (inverse a \<le> inverse b) = (b \<le> (a::'a::ordered_field))"
-by (blast intro: le_imp_inverse_le_neg dest: inverse_le_imp_le_neg)
-
-
-subsection{*Inverses and the Number One*}
-
-lemma one_less_inverse_iff:
- "(1 < inverse x) = (0 < x & x < (1::'a::{ordered_field,division_by_zero}))"
-proof cases
- assume "0 < x"
- with inverse_less_iff_less [OF zero_less_one, of x]
- show ?thesis by simp
-next
- assume notless: "~ (0 < x)"
- have "~ (1 < inverse x)"
- proof
- assume "1 < inverse x"
- also with notless have "... \<le> 0" by (simp add: linorder_not_less)
- also have "... < 1" by (rule zero_less_one)
- finally show False by auto
- qed
- with notless show ?thesis by simp
-qed
-
-lemma inverse_eq_1_iff [simp]:
- "(inverse x = 1) = (x = (1::'a::{field,division_by_zero}))"
-by (insert inverse_eq_iff_eq [of x 1], simp)
-
-lemma one_le_inverse_iff:
- "(1 \<le> inverse x) = (0 < x & x \<le> (1::'a::{ordered_field,division_by_zero}))"
-by (force simp add: order_le_less one_less_inverse_iff zero_less_one
- eq_commute [of 1])
-
-lemma inverse_less_1_iff:
- "(inverse x < 1) = (x \<le> 0 | 1 < (x::'a::{ordered_field,division_by_zero}))"
-by (simp add: linorder_not_le [symmetric] one_le_inverse_iff)
-
-lemma inverse_le_1_iff:
- "(inverse x \<le> 1) = (x \<le> 0 | 1 \<le> (x::'a::{ordered_field,division_by_zero}))"
-by (simp add: linorder_not_less [symmetric] one_less_inverse_iff)
-
-
-subsection{*Simplification of Inequalities Involving Literal Divisors*}
-
-lemma pos_le_divide_eq: "0 < (c::'a::ordered_field) ==> (a \<le> b/c) = (a*c \<le> b)"
-proof -
- assume less: "0<c"
- hence "(a \<le> b/c) = (a*c \<le> (b/c)*c)"
- by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
- also have "... = (a*c \<le> b)"
- by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma neg_le_divide_eq: "c < (0::'a::ordered_field) ==> (a \<le> b/c) = (b \<le> a*c)"
-proof -
- assume less: "c<0"
- hence "(a \<le> b/c) = ((b/c)*c \<le> a*c)"
- by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
- also have "... = (b \<le> a*c)"
- by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma le_divide_eq:
- "(a \<le> b/c) =
- (if 0 < c then a*c \<le> b
- else if c < 0 then b \<le> a*c
- else a \<le> (0::'a::{ordered_field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (force simp add: pos_le_divide_eq neg_le_divide_eq linorder_neq_iff)
-done
-
-lemma pos_divide_le_eq: "0 < (c::'a::ordered_field) ==> (b/c \<le> a) = (b \<le> a*c)"
-proof -
- assume less: "0<c"
- hence "(b/c \<le> a) = ((b/c)*c \<le> a*c)"
- by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
- also have "... = (b \<le> a*c)"
- by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma neg_divide_le_eq: "c < (0::'a::ordered_field) ==> (b/c \<le> a) = (a*c \<le> b)"
-proof -
- assume less: "c<0"
- hence "(b/c \<le> a) = (a*c \<le> (b/c)*c)"
- by (simp add: mult_le_cancel_right order_less_not_sym [OF less])
- also have "... = (a*c \<le> b)"
- by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma divide_le_eq:
- "(b/c \<le> a) =
- (if 0 < c then b \<le> a*c
- else if c < 0 then a*c \<le> b
- else 0 \<le> (a::'a::{ordered_field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (force simp add: pos_divide_le_eq neg_divide_le_eq linorder_neq_iff)
-done
-
-lemma pos_less_divide_eq:
- "0 < (c::'a::ordered_field) ==> (a < b/c) = (a*c < b)"
-proof -
- assume less: "0<c"
- hence "(a < b/c) = (a*c < (b/c)*c)"
- by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
- also have "... = (a*c < b)"
- by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma neg_less_divide_eq:
- "c < (0::'a::ordered_field) ==> (a < b/c) = (b < a*c)"
-proof -
- assume less: "c<0"
- hence "(a < b/c) = ((b/c)*c < a*c)"
- by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
- also have "... = (b < a*c)"
- by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma less_divide_eq:
- "(a < b/c) =
- (if 0 < c then a*c < b
- else if c < 0 then b < a*c
- else a < (0::'a::{ordered_field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (force simp add: pos_less_divide_eq neg_less_divide_eq linorder_neq_iff)
-done
-
-lemma pos_divide_less_eq:
- "0 < (c::'a::ordered_field) ==> (b/c < a) = (b < a*c)"
-proof -
- assume less: "0<c"
- hence "(b/c < a) = ((b/c)*c < a*c)"
- by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
- also have "... = (b < a*c)"
- by (simp add: order_less_imp_not_eq2 [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma neg_divide_less_eq:
- "c < (0::'a::ordered_field) ==> (b/c < a) = (a*c < b)"
-proof -
- assume less: "c<0"
- hence "(b/c < a) = (a*c < (b/c)*c)"
- by (simp add: mult_less_cancel_right_disj order_less_not_sym [OF less])
- also have "... = (a*c < b)"
- by (simp add: order_less_imp_not_eq [OF less] divide_inverse mult_assoc)
- finally show ?thesis .
-qed
-
-lemma divide_less_eq:
- "(b/c < a) =
- (if 0 < c then b < a*c
- else if c < 0 then a*c < b
- else 0 < (a::'a::{ordered_field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (force simp add: pos_divide_less_eq neg_divide_less_eq linorder_neq_iff)
-done
-
-
-subsection{*Field simplification*}
-
-text{* Lemmas @{text field_simps} multiply with denominators in in(equations)
-if they can be proved to be non-zero (for equations) or positive/negative
-(for inequations). Can be too aggressive and is therefore separate from the
-more benign @{text algebra_simps}. *}
-
-lemmas field_simps[noatp] = field_eq_simps
- (* multiply ineqn *)
- pos_divide_less_eq neg_divide_less_eq
- pos_less_divide_eq neg_less_divide_eq
- pos_divide_le_eq neg_divide_le_eq
- pos_le_divide_eq neg_le_divide_eq
-
-text{* Lemmas @{text sign_simps} is a first attempt to automate proofs
-of positivity/negativity needed for @{text field_simps}. Have not added @{text
-sign_simps} to @{text field_simps} because the former can lead to case
-explosions. *}
-
-lemmas sign_simps[noatp] = group_simps
- zero_less_mult_iff mult_less_0_iff
-
-(* Only works once linear arithmetic is installed:
-text{*An example:*}
-lemma fixes a b c d e f :: "'a::ordered_field"
-shows "\<lbrakk>a>b; c<d; e<f; 0 < u \<rbrakk> \<Longrightarrow>
- ((a-b)*(c-d)*(e-f))/((c-d)*(e-f)*(a-b)) <
- ((e-f)*(a-b)*(c-d))/((e-f)*(a-b)*(c-d)) + u"
-apply(subgoal_tac "(c-d)*(e-f)*(a-b) > 0")
- prefer 2 apply(simp add:sign_simps)
-apply(subgoal_tac "(c-d)*(e-f)*(a-b)*u > 0")
- prefer 2 apply(simp add:sign_simps)
-apply(simp add:field_simps)
-done
-*)
-
-
-subsection{*Division and Signs*}
-
-lemma zero_less_divide_iff:
- "((0::'a::{ordered_field,division_by_zero}) < a/b) = (0 < a & 0 < b | a < 0 & b < 0)"
-by (simp add: divide_inverse zero_less_mult_iff)
-
-lemma divide_less_0_iff:
- "(a/b < (0::'a::{ordered_field,division_by_zero})) =
- (0 < a & b < 0 | a < 0 & 0 < b)"
-by (simp add: divide_inverse mult_less_0_iff)
-
-lemma zero_le_divide_iff:
- "((0::'a::{ordered_field,division_by_zero}) \<le> a/b) =
- (0 \<le> a & 0 \<le> b | a \<le> 0 & b \<le> 0)"
-by (simp add: divide_inverse zero_le_mult_iff)
-
-lemma divide_le_0_iff:
- "(a/b \<le> (0::'a::{ordered_field,division_by_zero})) =
- (0 \<le> a & b \<le> 0 | a \<le> 0 & 0 \<le> b)"
-by (simp add: divide_inverse mult_le_0_iff)
-
-lemma divide_eq_0_iff [simp,noatp]:
- "(a/b = 0) = (a=0 | b=(0::'a::{field,division_by_zero}))"
-by (simp add: divide_inverse)
-
-lemma divide_pos_pos:
- "0 < (x::'a::ordered_field) ==> 0 < y ==> 0 < x / y"
-by(simp add:field_simps)
-
-
-lemma divide_nonneg_pos:
- "0 <= (x::'a::ordered_field) ==> 0 < y ==> 0 <= x / y"
-by(simp add:field_simps)
-
-lemma divide_neg_pos:
- "(x::'a::ordered_field) < 0 ==> 0 < y ==> x / y < 0"
-by(simp add:field_simps)
-
-lemma divide_nonpos_pos:
- "(x::'a::ordered_field) <= 0 ==> 0 < y ==> x / y <= 0"
-by(simp add:field_simps)
-
-lemma divide_pos_neg:
- "0 < (x::'a::ordered_field) ==> y < 0 ==> x / y < 0"
-by(simp add:field_simps)
-
-lemma divide_nonneg_neg:
- "0 <= (x::'a::ordered_field) ==> y < 0 ==> x / y <= 0"
-by(simp add:field_simps)
-
-lemma divide_neg_neg:
- "(x::'a::ordered_field) < 0 ==> y < 0 ==> 0 < x / y"
-by(simp add:field_simps)
-
-lemma divide_nonpos_neg:
- "(x::'a::ordered_field) <= 0 ==> y < 0 ==> 0 <= x / y"
-by(simp add:field_simps)
-
-
-subsection{*Cancellation Laws for Division*}
-
-lemma divide_cancel_right [simp,noatp]:
- "(a/c = b/c) = (c = 0 | a = (b::'a::{field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (simp add: divide_inverse)
-done
-
-lemma divide_cancel_left [simp,noatp]:
- "(c/a = c/b) = (c = 0 | a = (b::'a::{field,division_by_zero}))"
-apply (cases "c=0", simp)
-apply (simp add: divide_inverse)
-done
-
-
-subsection {* Division and the Number One *}
-
-text{*Simplify expressions equated with 1*}
-lemma divide_eq_1_iff [simp,noatp]:
- "(a/b = 1) = (b \<noteq> 0 & a = (b::'a::{field,division_by_zero}))"
-apply (cases "b=0", simp)
-apply (simp add: right_inverse_eq)
-done
-
-lemma one_eq_divide_iff [simp,noatp]:
- "(1 = a/b) = (b \<noteq> 0 & a = (b::'a::{field,division_by_zero}))"
-by (simp add: eq_commute [of 1])
-
-lemma zero_eq_1_divide_iff [simp,noatp]:
- "((0::'a::{ordered_field,division_by_zero}) = 1/a) = (a = 0)"
-apply (cases "a=0", simp)
-apply (auto simp add: nonzero_eq_divide_eq)
-done
-
-lemma one_divide_eq_0_iff [simp,noatp]:
- "(1/a = (0::'a::{ordered_field,division_by_zero})) = (a = 0)"
-apply (cases "a=0", simp)
-apply (insert zero_neq_one [THEN not_sym])
-apply (auto simp add: nonzero_divide_eq_eq)
-done
-
-text{*Simplify expressions such as @{text "0 < 1/x"} to @{text "0 < x"}*}
-lemmas zero_less_divide_1_iff = zero_less_divide_iff [of 1, simplified]
-lemmas divide_less_0_1_iff = divide_less_0_iff [of 1, simplified]
-lemmas zero_le_divide_1_iff = zero_le_divide_iff [of 1, simplified]
-lemmas divide_le_0_1_iff = divide_le_0_iff [of 1, simplified]
-
-declare zero_less_divide_1_iff [simp,noatp]
-declare divide_less_0_1_iff [simp,noatp]
-declare zero_le_divide_1_iff [simp,noatp]
-declare divide_le_0_1_iff [simp,noatp]
-
-
-subsection {* Ordering Rules for Division *}
-
-lemma divide_strict_right_mono:
- "[|a < b; 0 < c|] ==> a / c < b / (c::'a::ordered_field)"
-by (simp add: order_less_imp_not_eq2 divide_inverse mult_strict_right_mono
- positive_imp_inverse_positive)
-
-lemma divide_right_mono:
- "[|a \<le> b; 0 \<le> c|] ==> a/c \<le> b/(c::'a::{ordered_field,division_by_zero})"
-by (force simp add: divide_strict_right_mono order_le_less)
-
-lemma divide_right_mono_neg: "(a::'a::{division_by_zero,ordered_field}) <= b
- ==> c <= 0 ==> b / c <= a / c"
-apply (drule divide_right_mono [of _ _ "- c"])
-apply auto
-done
-
-lemma divide_strict_right_mono_neg:
- "[|b < a; c < 0|] ==> a / c < b / (c::'a::ordered_field)"
-apply (drule divide_strict_right_mono [of _ _ "-c"], simp)
-apply (simp add: order_less_imp_not_eq nonzero_minus_divide_right [symmetric])
-done
-
-text{*The last premise ensures that @{term a} and @{term b}
- have the same sign*}
-lemma divide_strict_left_mono:
- "[|b < a; 0 < c; 0 < a*b|] ==> c / a < c / (b::'a::ordered_field)"
-by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_strict_right_mono)
-
-lemma divide_left_mono:
- "[|b \<le> a; 0 \<le> c; 0 < a*b|] ==> c / a \<le> c / (b::'a::ordered_field)"
-by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_right_mono)
-
-lemma divide_left_mono_neg: "(a::'a::{division_by_zero,ordered_field}) <= b
- ==> c <= 0 ==> 0 < a * b ==> c / a <= c / b"
- apply (drule divide_left_mono [of _ _ "- c"])
- apply (auto simp add: mult_commute)
-done
-
-lemma divide_strict_left_mono_neg:
- "[|a < b; c < 0; 0 < a*b|] ==> c / a < c / (b::'a::ordered_field)"
-by(auto simp: field_simps times_divide_eq zero_less_mult_iff mult_strict_right_mono_neg)
-
-
-text{*Simplify quotients that are compared with the value 1.*}
-
-lemma le_divide_eq_1 [noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(1 \<le> b / a) = ((0 < a & a \<le> b) | (a < 0 & b \<le> a))"
-by (auto simp add: le_divide_eq)
-
-lemma divide_le_eq_1 [noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(b / a \<le> 1) = ((0 < a & b \<le> a) | (a < 0 & a \<le> b) | a=0)"
-by (auto simp add: divide_le_eq)
-
-lemma less_divide_eq_1 [noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(1 < b / a) = ((0 < a & a < b) | (a < 0 & b < a))"
-by (auto simp add: less_divide_eq)
-
-lemma divide_less_eq_1 [noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(b / a < 1) = ((0 < a & b < a) | (a < 0 & a < b) | a=0)"
-by (auto simp add: divide_less_eq)
-
-
-subsection{*Conditional Simplification Rules: No Case Splits*}
-
-lemma le_divide_eq_1_pos [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "0 < a \<Longrightarrow> (1 \<le> b/a) = (a \<le> b)"
-by (auto simp add: le_divide_eq)
-
-lemma le_divide_eq_1_neg [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "a < 0 \<Longrightarrow> (1 \<le> b/a) = (b \<le> a)"
-by (auto simp add: le_divide_eq)
-
-lemma divide_le_eq_1_pos [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "0 < a \<Longrightarrow> (b/a \<le> 1) = (b \<le> a)"
-by (auto simp add: divide_le_eq)
-
-lemma divide_le_eq_1_neg [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "a < 0 \<Longrightarrow> (b/a \<le> 1) = (a \<le> b)"
-by (auto simp add: divide_le_eq)
-
-lemma less_divide_eq_1_pos [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "0 < a \<Longrightarrow> (1 < b/a) = (a < b)"
-by (auto simp add: less_divide_eq)
-
-lemma less_divide_eq_1_neg [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "a < 0 \<Longrightarrow> (1 < b/a) = (b < a)"
-by (auto simp add: less_divide_eq)
-
-lemma divide_less_eq_1_pos [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "0 < a \<Longrightarrow> (b/a < 1) = (b < a)"
-by (auto simp add: divide_less_eq)
-
-lemma divide_less_eq_1_neg [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "a < 0 \<Longrightarrow> b/a < 1 <-> a < b"
-by (auto simp add: divide_less_eq)
-
-lemma eq_divide_eq_1 [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(1 = b/a) = ((a \<noteq> 0 & a = b))"
-by (auto simp add: eq_divide_eq)
-
-lemma divide_eq_eq_1 [simp,noatp]:
- fixes a :: "'a :: {ordered_field,division_by_zero}"
- shows "(b/a = 1) = ((a \<noteq> 0 & a = b))"
-by (auto simp add: divide_eq_eq)
-
-
-subsection {* Reasoning about inequalities with division *}
-
-lemma mult_right_le_one_le: "0 <= (x::'a::ordered_idom) ==> 0 <= y ==> y <= 1
- ==> x * y <= x"
-by (auto simp add: mult_compare_simps)
-
-lemma mult_left_le_one_le: "0 <= (x::'a::ordered_idom) ==> 0 <= y ==> y <= 1
- ==> y * x <= x"
-by (auto simp add: mult_compare_simps)
-
-lemma mult_imp_div_pos_le: "0 < (y::'a::ordered_field) ==> x <= z * y ==>
- x / y <= z"
-by (subst pos_divide_le_eq, assumption+)
-
-lemma mult_imp_le_div_pos: "0 < (y::'a::ordered_field) ==> z * y <= x ==>
- z <= x / y"
-by(simp add:field_simps)
-
-lemma mult_imp_div_pos_less: "0 < (y::'a::ordered_field) ==> x < z * y ==>
- x / y < z"
-by(simp add:field_simps)
-
-lemma mult_imp_less_div_pos: "0 < (y::'a::ordered_field) ==> z * y < x ==>
- z < x / y"
-by(simp add:field_simps)
-
-lemma frac_le: "(0::'a::ordered_field) <= x ==>
- x <= y ==> 0 < w ==> w <= z ==> x / z <= y / w"
- apply (rule mult_imp_div_pos_le)
- apply simp
- apply (subst times_divide_eq_left)
- apply (rule mult_imp_le_div_pos, assumption)
- apply (rule mult_mono)
- apply simp_all
-done
-
-lemma frac_less: "(0::'a::ordered_field) <= x ==>
- x < y ==> 0 < w ==> w <= z ==> x / z < y / w"
- apply (rule mult_imp_div_pos_less)
- apply simp
- apply (subst times_divide_eq_left)
- apply (rule mult_imp_less_div_pos, assumption)
- apply (erule mult_less_le_imp_less)
- apply simp_all
-done
-
-lemma frac_less2: "(0::'a::ordered_field) < x ==>
- x <= y ==> 0 < w ==> w < z ==> x / z < y / w"
- apply (rule mult_imp_div_pos_less)
- apply simp_all
- apply (subst times_divide_eq_left)
- apply (rule mult_imp_less_div_pos, assumption)
- apply (erule mult_le_less_imp_less)
- apply simp_all
-done
-
-text{*It's not obvious whether these should be simprules or not.
- Their effect is to gather terms into one big fraction, like
- a*b*c / x*y*z. The rationale for that is unclear, but many proofs
- seem to need them.*}
-
-declare times_divide_eq [simp]
-
-
-subsection {* Ordered Fields are Dense *}
-
-context ordered_semidom
-begin
-
-lemma less_add_one: "a < a + 1"
-proof -
- have "a + 0 < a + 1"
- by (blast intro: zero_less_one add_strict_left_mono)
- thus ?thesis by simp
-qed
-
-lemma zero_less_two: "0 < 1 + 1"
-by (blast intro: less_trans zero_less_one less_add_one)
-
-end
-
-lemma less_half_sum: "a < b ==> a < (a+b) / (1+1::'a::ordered_field)"
-by (simp add: field_simps zero_less_two)
-
-lemma gt_half_sum: "a < b ==> (a+b)/(1+1::'a::ordered_field) < b"
-by (simp add: field_simps zero_less_two)
-
-instance ordered_field < dense_linear_order
-proof
- fix x y :: 'a
- have "x < x + 1" by simp
- then show "\<exists>y. x < y" ..
- have "x - 1 < x" by simp
- then show "\<exists>y. y < x" ..
- show "x < y \<Longrightarrow> \<exists>z>x. z < y" by (blast intro!: less_half_sum gt_half_sum)
-qed
-
-
-subsection {* Absolute Value *}
-
-context ordered_idom
-begin
-
-lemma mult_sgn_abs: "sgn x * abs x = x"
- unfolding abs_if sgn_if by auto
-
-end
-
-lemma abs_one [simp]: "abs 1 = (1::'a::ordered_idom)"
-by (simp add: abs_if zero_less_one [THEN order_less_not_sym])
-
-class pordered_ring_abs = pordered_ring + pordered_ab_group_add_abs +
- assumes abs_eq_mult:
- "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0) \<Longrightarrow> \<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
-
-
-class lordered_ring = pordered_ring + lordered_ab_group_add_abs
-begin
-
-subclass lordered_ab_group_add_meet ..
-subclass lordered_ab_group_add_join ..
-
-end
-
-lemma abs_le_mult: "abs (a * b) \<le> (abs a) * (abs (b::'a::lordered_ring))"
-proof -
- let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
- let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
- have a: "(abs a) * (abs b) = ?x"
- by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
- {
- fix u v :: 'a
- have bh: "\<lbrakk>u = a; v = b\<rbrakk> \<Longrightarrow>
- u * v = pprt a * pprt b + pprt a * nprt b +
- nprt a * pprt b + nprt a * nprt b"
- apply (subst prts[of u], subst prts[of v])
- apply (simp add: algebra_simps)
- done
- }
- note b = this[OF refl[of a] refl[of b]]
- note addm = add_mono[of "0::'a" _ "0::'a", simplified]
- note addm2 = add_mono[of _ "0::'a" _ "0::'a", simplified]
- have xy: "- ?x <= ?y"
- apply (simp)
- apply (rule_tac y="0::'a" in order_trans)
- apply (rule addm2)
- apply (simp_all add: mult_nonneg_nonneg mult_nonpos_nonpos)
- apply (rule addm)
- apply (simp_all add: mult_nonneg_nonneg mult_nonpos_nonpos)
- done
- have yx: "?y <= ?x"
- apply (simp add:diff_def)
- apply (rule_tac y=0 in order_trans)
- apply (rule addm2, (simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)+)
- apply (rule addm, (simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)+)
- done
- have i1: "a*b <= abs a * abs b" by (simp only: a b yx)
- have i2: "- (abs a * abs b) <= a*b" by (simp only: a b xy)
- show ?thesis
- apply (rule abs_leI)
- apply (simp add: i1)
- apply (simp add: i2[simplified minus_le_iff])
- done
-qed
-
-instance lordered_ring \<subseteq> pordered_ring_abs
-proof
- fix a b :: "'a\<Colon> lordered_ring"
- assume "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
- show "abs (a*b) = abs a * abs b"
-proof -
- have s: "(0 <= a*b) | (a*b <= 0)"
- apply (auto)
- apply (rule_tac split_mult_pos_le)
- apply (rule_tac contrapos_np[of "a*b <= 0"])
- apply (simp)
- apply (rule_tac split_mult_neg_le)
- apply (insert prems)
- apply (blast)
- done
- have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
- by (simp add: prts[symmetric])
- show ?thesis
- proof cases
- assume "0 <= a * b"
- then show ?thesis
- apply (simp_all add: mulprts abs_prts)
- apply (insert prems)
- apply (auto simp add:
- algebra_simps
- iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
- iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
- apply(drule (1) mult_nonneg_nonpos[of a b], simp)
- apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
- done
- next
- assume "~(0 <= a*b)"
- with s have "a*b <= 0" by simp
- then show ?thesis
- apply (simp_all add: mulprts abs_prts)
- apply (insert prems)
- apply (auto simp add: algebra_simps)
- apply(drule (1) mult_nonneg_nonneg[of a b],simp)
- apply(drule (1) mult_nonpos_nonpos[of a b],simp)
- done
- qed
-qed
-qed
-
-context ordered_idom
-begin
-
-subclass pordered_ring_abs proof
-qed (auto simp add: abs_if not_less equal_neg_zero neg_equal_zero mult_less_0_iff)
-
-lemma abs_mult:
- "abs (a * b) = abs a * abs b"
- by (rule abs_eq_mult) auto
-
-lemma abs_mult_self:
- "abs a * abs a = a * a"
- by (simp add: abs_if)
-
-end
-
-lemma nonzero_abs_inverse:
- "a \<noteq> 0 ==> abs (inverse (a::'a::ordered_field)) = inverse (abs a)"
-apply (auto simp add: linorder_neq_iff abs_if nonzero_inverse_minus_eq
- negative_imp_inverse_negative)
-apply (blast intro: positive_imp_inverse_positive elim: order_less_asym)
-done
-
-lemma abs_inverse [simp]:
- "abs (inverse (a::'a::{ordered_field,division_by_zero})) =
- inverse (abs a)"
-apply (cases "a=0", simp)
-apply (simp add: nonzero_abs_inverse)
-done
-
-lemma nonzero_abs_divide:
- "b \<noteq> 0 ==> abs (a / (b::'a::ordered_field)) = abs a / abs b"
-by (simp add: divide_inverse abs_mult nonzero_abs_inverse)
-
-lemma abs_divide [simp]:
- "abs (a / (b::'a::{ordered_field,division_by_zero})) = abs a / abs b"
-apply (cases "b=0", simp)
-apply (simp add: nonzero_abs_divide)
-done
-
-lemma abs_mult_less:
- "[| abs a < c; abs b < d |] ==> abs a * abs b < c*(d::'a::ordered_idom)"
-proof -
- assume ac: "abs a < c"
- hence cpos: "0<c" by (blast intro: order_le_less_trans abs_ge_zero)
- assume "abs b < d"
- thus ?thesis by (simp add: ac cpos mult_strict_mono)
-qed
-
-lemmas eq_minus_self_iff[noatp] = equal_neg_zero
-
-lemma less_minus_self_iff: "(a < -a) = (a < (0::'a::ordered_idom))"
- unfolding order_less_le less_eq_neg_nonpos equal_neg_zero ..
-
-lemma abs_less_iff: "(abs a < b) = (a < b & -a < (b::'a::ordered_idom))"
-apply (simp add: order_less_le abs_le_iff)
-apply (auto simp add: abs_if neg_less_eq_nonneg less_eq_neg_nonpos)
-done
-
-lemma abs_mult_pos: "(0::'a::ordered_idom) <= x ==>
- (abs y) * x = abs (y * x)"
- apply (subst abs_mult)
- apply simp
-done
-
-lemma abs_div_pos: "(0::'a::{division_by_zero,ordered_field}) < y ==>
- abs x / y = abs (x / y)"
- apply (subst abs_divide)
- apply (simp add: order_less_imp_le)
-done
-
-
-subsection {* Bounds of products via negative and positive Part *}
-
-lemma mult_le_prts:
- assumes
- "a1 <= (a::'a::lordered_ring)"
- "a <= a2"
- "b1 <= b"
- "b <= b2"
- shows
- "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
-proof -
- have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
- apply (subst prts[symmetric])+
- apply simp
- done
- then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
- by (simp add: algebra_simps)
- moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
- by (simp_all add: prems mult_mono)
- moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
- proof -
- have "pprt a * nprt b <= pprt a * nprt b2"
- by (simp add: mult_left_mono prems)
- moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
- by (simp add: mult_right_mono_neg prems)
- ultimately show ?thesis
- by simp
- qed
- moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
- proof -
- have "nprt a * pprt b <= nprt a2 * pprt b"
- by (simp add: mult_right_mono prems)
- moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
- by (simp add: mult_left_mono_neg prems)
- ultimately show ?thesis
- by simp
- qed
- moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
- proof -
- have "nprt a * nprt b <= nprt a * nprt b1"
- by (simp add: mult_left_mono_neg prems)
- moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
- by (simp add: mult_right_mono_neg prems)
- ultimately show ?thesis
- by simp
- qed
- ultimately show ?thesis
- by - (rule add_mono | simp)+
-qed
-
-lemma mult_ge_prts:
- assumes
- "a1 <= (a::'a::lordered_ring)"
- "a <= a2"
- "b1 <= b"
- "b <= b2"
- shows
- "a * b >= nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
-proof -
- from prems have a1:"- a2 <= -a" by auto
- from prems have a2: "-a <= -a1" by auto
- from mult_le_prts[of "-a2" "-a" "-a1" "b1" b "b2", OF a1 a2 prems(3) prems(4), simplified nprt_neg pprt_neg]
- have le: "- (a * b) <= - nprt a1 * pprt b2 + - nprt a2 * nprt b2 + - pprt a1 * pprt b1 + - pprt a2 * nprt b1" by simp
- then have "-(- nprt a1 * pprt b2 + - nprt a2 * nprt b2 + - pprt a1 * pprt b1 + - pprt a2 * nprt b1) <= a * b"
- by (simp only: minus_le_iff)
- then show ?thesis by simp
-qed
-
-
-code_modulename SML
- Ring_and_Field Arith
-
-code_modulename OCaml
- Ring_and_Field Arith
-
-code_modulename Haskell
- Ring_and_Field Arith
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Rings.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,1207 @@
+(* Title: HOL/Rings.thy
+ Author: Gertrud Bauer
+ Author: Steven Obua
+ Author: Tobias Nipkow
+ Author: Lawrence C Paulson
+ Author: Markus Wenzel
+ Author: Jeremy Avigad
+*)
+
+header {* Rings *}
+
+theory Rings
+imports Groups
+begin
+
+text {*
+ The theory of partially ordered rings is taken from the books:
+ \begin{itemize}
+ \item \emph{Lattice Theory} by Garret Birkhoff, American Mathematical Society 1979
+ \item \emph{Partially Ordered Algebraic Systems}, Pergamon Press 1963
+ \end{itemize}
+ Most of the used notions can also be looked up in
+ \begin{itemize}
+ \item \url{http://www.mathworld.com} by Eric Weisstein et. al.
+ \item \emph{Algebra I} by van der Waerden, Springer.
+ \end{itemize}
+*}
+
+class semiring = ab_semigroup_add + semigroup_mult +
+ assumes left_distrib[algebra_simps]: "(a + b) * c = a * c + b * c"
+ assumes right_distrib[algebra_simps]: "a * (b + c) = a * b + a * c"
+begin
+
+text{*For the @{text combine_numerals} simproc*}
+lemma combine_common_factor:
+ "a * e + (b * e + c) = (a + b) * e + c"
+by (simp add: left_distrib add_ac)
+
+end
+
+class mult_zero = times + zero +
+ assumes mult_zero_left [simp]: "0 * a = 0"
+ assumes mult_zero_right [simp]: "a * 0 = 0"
+
+class semiring_0 = semiring + comm_monoid_add + mult_zero
+
+class semiring_0_cancel = semiring + cancel_comm_monoid_add
+begin
+
+subclass semiring_0
+proof
+ fix a :: 'a
+ have "0 * a + 0 * a = 0 * a + 0" by (simp add: left_distrib [symmetric])
+ thus "0 * a = 0" by (simp only: add_left_cancel)
+next
+ fix a :: 'a
+ have "a * 0 + a * 0 = a * 0 + 0" by (simp add: right_distrib [symmetric])
+ thus "a * 0 = 0" by (simp only: add_left_cancel)
+qed
+
+end
+
+class comm_semiring = ab_semigroup_add + ab_semigroup_mult +
+ assumes distrib: "(a + b) * c = a * c + b * c"
+begin
+
+subclass semiring
+proof
+ fix a b c :: 'a
+ show "(a + b) * c = a * c + b * c" by (simp add: distrib)
+ have "a * (b + c) = (b + c) * a" by (simp add: mult_ac)
+ also have "... = b * a + c * a" by (simp only: distrib)
+ also have "... = a * b + a * c" by (simp add: mult_ac)
+ finally show "a * (b + c) = a * b + a * c" by blast
+qed
+
+end
+
+class comm_semiring_0 = comm_semiring + comm_monoid_add + mult_zero
+begin
+
+subclass semiring_0 ..
+
+end
+
+class comm_semiring_0_cancel = comm_semiring + cancel_comm_monoid_add
+begin
+
+subclass semiring_0_cancel ..
+
+subclass comm_semiring_0 ..
+
+end
+
+class zero_neq_one = zero + one +
+ assumes zero_neq_one [simp]: "0 \<noteq> 1"
+begin
+
+lemma one_neq_zero [simp]: "1 \<noteq> 0"
+by (rule not_sym) (rule zero_neq_one)
+
+end
+
+class semiring_1 = zero_neq_one + semiring_0 + monoid_mult
+
+text {* Abstract divisibility *}
+
+class dvd = times
+begin
+
+definition dvd :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "dvd" 50) where
+ [code del]: "b dvd a \<longleftrightarrow> (\<exists>k. a = b * k)"
+
+lemma dvdI [intro?]: "a = b * k \<Longrightarrow> b dvd a"
+ unfolding dvd_def ..
+
+lemma dvdE [elim?]: "b dvd a \<Longrightarrow> (\<And>k. a = b * k \<Longrightarrow> P) \<Longrightarrow> P"
+ unfolding dvd_def by blast
+
+end
+
+class comm_semiring_1 = zero_neq_one + comm_semiring_0 + comm_monoid_mult + dvd
+ (*previously almost_semiring*)
+begin
+
+subclass semiring_1 ..
+
+lemma dvd_refl[simp]: "a dvd a"
+proof
+ show "a = a * 1" by simp
+qed
+
+lemma dvd_trans:
+ assumes "a dvd b" and "b dvd c"
+ shows "a dvd c"
+proof -
+ from assms obtain v where "b = a * v" by (auto elim!: dvdE)
+ moreover from assms obtain w where "c = b * w" by (auto elim!: dvdE)
+ ultimately have "c = a * (v * w)" by (simp add: mult_assoc)
+ then show ?thesis ..
+qed
+
+lemma dvd_0_left_iff [noatp, simp]: "0 dvd a \<longleftrightarrow> a = 0"
+by (auto intro: dvd_refl elim!: dvdE)
+
+lemma dvd_0_right [iff]: "a dvd 0"
+proof
+ show "0 = a * 0" by simp
+qed
+
+lemma one_dvd [simp]: "1 dvd a"
+by (auto intro!: dvdI)
+
+lemma dvd_mult[simp]: "a dvd c \<Longrightarrow> a dvd (b * c)"
+by (auto intro!: mult_left_commute dvdI elim!: dvdE)
+
+lemma dvd_mult2[simp]: "a dvd b \<Longrightarrow> a dvd (b * c)"
+ apply (subst mult_commute)
+ apply (erule dvd_mult)
+ done
+
+lemma dvd_triv_right [simp]: "a dvd b * a"
+by (rule dvd_mult) (rule dvd_refl)
+
+lemma dvd_triv_left [simp]: "a dvd a * b"
+by (rule dvd_mult2) (rule dvd_refl)
+
+lemma mult_dvd_mono:
+ assumes "a dvd b"
+ and "c dvd d"
+ shows "a * c dvd b * d"
+proof -
+ from `a dvd b` obtain b' where "b = a * b'" ..
+ moreover from `c dvd d` obtain d' where "d = c * d'" ..
+ ultimately have "b * d = (a * c) * (b' * d')" by (simp add: mult_ac)
+ then show ?thesis ..
+qed
+
+lemma dvd_mult_left: "a * b dvd c \<Longrightarrow> a dvd c"
+by (simp add: dvd_def mult_assoc, blast)
+
+lemma dvd_mult_right: "a * b dvd c \<Longrightarrow> b dvd c"
+ unfolding mult_ac [of a] by (rule dvd_mult_left)
+
+lemma dvd_0_left: "0 dvd a \<Longrightarrow> a = 0"
+by simp
+
+lemma dvd_add[simp]:
+ assumes "a dvd b" and "a dvd c" shows "a dvd (b + c)"
+proof -
+ from `a dvd b` obtain b' where "b = a * b'" ..
+ moreover from `a dvd c` obtain c' where "c = a * c'" ..
+ ultimately have "b + c = a * (b' + c')" by (simp add: right_distrib)
+ then show ?thesis ..
+qed
+
+end
+
+
+class no_zero_divisors = zero + times +
+ assumes no_zero_divisors: "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> a * b \<noteq> 0"
+
+class semiring_1_cancel = semiring + cancel_comm_monoid_add
+ + zero_neq_one + monoid_mult
+begin
+
+subclass semiring_0_cancel ..
+
+subclass semiring_1 ..
+
+end
+
+class comm_semiring_1_cancel = comm_semiring + cancel_comm_monoid_add
+ + zero_neq_one + comm_monoid_mult
+begin
+
+subclass semiring_1_cancel ..
+subclass comm_semiring_0_cancel ..
+subclass comm_semiring_1 ..
+
+end
+
+class ring = semiring + ab_group_add
+begin
+
+subclass semiring_0_cancel ..
+
+text {* Distribution rules *}
+
+lemma minus_mult_left: "- (a * b) = - a * b"
+by (rule minus_unique) (simp add: left_distrib [symmetric])
+
+lemma minus_mult_right: "- (a * b) = a * - b"
+by (rule minus_unique) (simp add: right_distrib [symmetric])
+
+text{*Extract signs from products*}
+lemmas mult_minus_left [simp, noatp] = minus_mult_left [symmetric]
+lemmas mult_minus_right [simp,noatp] = minus_mult_right [symmetric]
+
+lemma minus_mult_minus [simp]: "- a * - b = a * b"
+by simp
+
+lemma minus_mult_commute: "- a * b = a * - b"
+by simp
+
+lemma right_diff_distrib[algebra_simps]: "a * (b - c) = a * b - a * c"
+by (simp add: right_distrib diff_minus)
+
+lemma left_diff_distrib[algebra_simps]: "(a - b) * c = a * c - b * c"
+by (simp add: left_distrib diff_minus)
+
+lemmas ring_distribs[noatp] =
+ right_distrib left_distrib left_diff_distrib right_diff_distrib
+
+text{*Legacy - use @{text algebra_simps} *}
+lemmas ring_simps[noatp] = algebra_simps
+
+lemma eq_add_iff1:
+ "a * e + c = b * e + d \<longleftrightarrow> (a - b) * e + c = d"
+by (simp add: algebra_simps)
+
+lemma eq_add_iff2:
+ "a * e + c = b * e + d \<longleftrightarrow> c = (b - a) * e + d"
+by (simp add: algebra_simps)
+
+end
+
+lemmas ring_distribs[noatp] =
+ right_distrib left_distrib left_diff_distrib right_diff_distrib
+
+class comm_ring = comm_semiring + ab_group_add
+begin
+
+subclass ring ..
+subclass comm_semiring_0_cancel ..
+
+end
+
+class ring_1 = ring + zero_neq_one + monoid_mult
+begin
+
+subclass semiring_1_cancel ..
+
+end
+
+class comm_ring_1 = comm_ring + zero_neq_one + comm_monoid_mult
+ (*previously ring*)
+begin
+
+subclass ring_1 ..
+subclass comm_semiring_1_cancel ..
+
+lemma dvd_minus_iff [simp]: "x dvd - y \<longleftrightarrow> x dvd y"
+proof
+ assume "x dvd - y"
+ then have "x dvd - 1 * - y" by (rule dvd_mult)
+ then show "x dvd y" by simp
+next
+ assume "x dvd y"
+ then have "x dvd - 1 * y" by (rule dvd_mult)
+ then show "x dvd - y" by simp
+qed
+
+lemma minus_dvd_iff [simp]: "- x dvd y \<longleftrightarrow> x dvd y"
+proof
+ assume "- x dvd y"
+ then obtain k where "y = - x * k" ..
+ then have "y = x * - k" by simp
+ then show "x dvd y" ..
+next
+ assume "x dvd y"
+ then obtain k where "y = x * k" ..
+ then have "y = - x * - k" by simp
+ then show "- x dvd y" ..
+qed
+
+lemma dvd_diff[simp]: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
+by (simp only: diff_minus dvd_add dvd_minus_iff)
+
+end
+
+class ring_no_zero_divisors = ring + no_zero_divisors
+begin
+
+lemma mult_eq_0_iff [simp]:
+ shows "a * b = 0 \<longleftrightarrow> (a = 0 \<or> b = 0)"
+proof (cases "a = 0 \<or> b = 0")
+ case False then have "a \<noteq> 0" and "b \<noteq> 0" by auto
+ then show ?thesis using no_zero_divisors by simp
+next
+ case True then show ?thesis by auto
+qed
+
+text{*Cancellation of equalities with a common factor*}
+lemma mult_cancel_right [simp, noatp]:
+ "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b"
+proof -
+ have "(a * c = b * c) = ((a - b) * c = 0)"
+ by (simp add: algebra_simps)
+ thus ?thesis by (simp add: disj_commute)
+qed
+
+lemma mult_cancel_left [simp, noatp]:
+ "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
+proof -
+ have "(c * a = c * b) = (c * (a - b) = 0)"
+ by (simp add: algebra_simps)
+ thus ?thesis by simp
+qed
+
+end
+
+class ring_1_no_zero_divisors = ring_1 + ring_no_zero_divisors
+begin
+
+lemma mult_cancel_right1 [simp]:
+ "c = b * c \<longleftrightarrow> c = 0 \<or> b = 1"
+by (insert mult_cancel_right [of 1 c b], force)
+
+lemma mult_cancel_right2 [simp]:
+ "a * c = c \<longleftrightarrow> c = 0 \<or> a = 1"
+by (insert mult_cancel_right [of a c 1], simp)
+
+lemma mult_cancel_left1 [simp]:
+ "c = c * b \<longleftrightarrow> c = 0 \<or> b = 1"
+by (insert mult_cancel_left [of c 1 b], force)
+
+lemma mult_cancel_left2 [simp]:
+ "c * a = c \<longleftrightarrow> c = 0 \<or> a = 1"
+by (insert mult_cancel_left [of c a 1], simp)
+
+end
+
+class idom = comm_ring_1 + no_zero_divisors
+begin
+
+subclass ring_1_no_zero_divisors ..
+
+lemma square_eq_iff: "a * a = b * b \<longleftrightarrow> (a = b \<or> a = - b)"
+proof
+ assume "a * a = b * b"
+ then have "(a - b) * (a + b) = 0"
+ by (simp add: algebra_simps)
+ then show "a = b \<or> a = - b"
+ by (simp add: eq_neg_iff_add_eq_0)
+next
+ assume "a = b \<or> a = - b"
+ then show "a * a = b * b" by auto
+qed
+
+lemma dvd_mult_cancel_right [simp]:
+ "a * c dvd b * c \<longleftrightarrow> c = 0 \<or> a dvd b"
+proof -
+ have "a * c dvd b * c \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
+ unfolding dvd_def by (simp add: mult_ac)
+ also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
+ unfolding dvd_def by simp
+ finally show ?thesis .
+qed
+
+lemma dvd_mult_cancel_left [simp]:
+ "c * a dvd c * b \<longleftrightarrow> c = 0 \<or> a dvd b"
+proof -
+ have "c * a dvd c * b \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
+ unfolding dvd_def by (simp add: mult_ac)
+ also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
+ unfolding dvd_def by simp
+ finally show ?thesis .
+qed
+
+end
+
+class inverse =
+ fixes inverse :: "'a \<Rightarrow> 'a"
+ and divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/" 70)
+
+class division_ring = ring_1 + inverse +
+ assumes left_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
+ assumes right_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> a * inverse a = 1"
+ assumes divide_inverse: "a / b = a * inverse b"
+begin
+
+subclass ring_1_no_zero_divisors
+proof
+ fix a b :: 'a
+ assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
+ show "a * b \<noteq> 0"
+ proof
+ assume ab: "a * b = 0"
+ hence "0 = inverse a * (a * b) * inverse b" by simp
+ also have "\<dots> = (inverse a * a) * (b * inverse b)"
+ by (simp only: mult_assoc)
+ also have "\<dots> = 1" using a b by simp
+ finally show False by simp
+ qed
+qed
+
+lemma nonzero_imp_inverse_nonzero:
+ "a \<noteq> 0 \<Longrightarrow> inverse a \<noteq> 0"
+proof
+ assume ianz: "inverse a = 0"
+ assume "a \<noteq> 0"
+ hence "1 = a * inverse a" by simp
+ also have "... = 0" by (simp add: ianz)
+ finally have "1 = 0" .
+ thus False by (simp add: eq_commute)
+qed
+
+lemma inverse_zero_imp_zero:
+ "inverse a = 0 \<Longrightarrow> a = 0"
+apply (rule classical)
+apply (drule nonzero_imp_inverse_nonzero)
+apply auto
+done
+
+lemma inverse_unique:
+ assumes ab: "a * b = 1"
+ shows "inverse a = b"
+proof -
+ have "a \<noteq> 0" using ab by (cases "a = 0") simp_all
+ moreover have "inverse a * (a * b) = inverse a" by (simp add: ab)
+ ultimately show ?thesis by (simp add: mult_assoc [symmetric])
+qed
+
+lemma nonzero_inverse_minus_eq:
+ "a \<noteq> 0 \<Longrightarrow> inverse (- a) = - inverse a"
+by (rule inverse_unique) simp
+
+lemma nonzero_inverse_inverse_eq:
+ "a \<noteq> 0 \<Longrightarrow> inverse (inverse a) = a"
+by (rule inverse_unique) simp
+
+lemma nonzero_inverse_eq_imp_eq:
+ assumes "inverse a = inverse b" and "a \<noteq> 0" and "b \<noteq> 0"
+ shows "a = b"
+proof -
+ from `inverse a = inverse b`
+ have "inverse (inverse a) = inverse (inverse b)" by (rule arg_cong)
+ with `a \<noteq> 0` and `b \<noteq> 0` show "a = b"
+ by (simp add: nonzero_inverse_inverse_eq)
+qed
+
+lemma inverse_1 [simp]: "inverse 1 = 1"
+by (rule inverse_unique) simp
+
+lemma nonzero_inverse_mult_distrib:
+ assumes "a \<noteq> 0" and "b \<noteq> 0"
+ shows "inverse (a * b) = inverse b * inverse a"
+proof -
+ have "a * (b * inverse b) * inverse a = 1" using assms by simp
+ hence "a * b * (inverse b * inverse a) = 1" by (simp only: mult_assoc)
+ thus ?thesis by (rule inverse_unique)
+qed
+
+lemma division_ring_inverse_add:
+ "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = inverse a * (a + b) * inverse b"
+by (simp add: algebra_simps)
+
+lemma division_ring_inverse_diff:
+ "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a - inverse b = inverse a * (b - a) * inverse b"
+by (simp add: algebra_simps)
+
+end
+
+class mult_mono = times + zero + ord +
+ assumes mult_left_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
+ assumes mult_right_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a * c \<le> b * c"
+
+class ordered_semiring = mult_mono + semiring_0 + ordered_ab_semigroup_add
+begin
+
+lemma mult_mono:
+ "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> c
+ \<Longrightarrow> a * c \<le> b * d"
+apply (erule mult_right_mono [THEN order_trans], assumption)
+apply (erule mult_left_mono, assumption)
+done
+
+lemma mult_mono':
+ "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> c
+ \<Longrightarrow> a * c \<le> b * d"
+apply (rule mult_mono)
+apply (fast intro: order_trans)+
+done
+
+end
+
+class ordered_cancel_semiring = mult_mono + ordered_ab_semigroup_add
+ + semiring + cancel_comm_monoid_add
+begin
+
+subclass semiring_0_cancel ..
+subclass ordered_semiring ..
+
+lemma mult_nonneg_nonneg: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a * b"
+using mult_left_mono [of zero b a] by simp
+
+lemma mult_nonneg_nonpos: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> a * b \<le> 0"
+using mult_left_mono [of b zero a] by simp
+
+lemma mult_nonpos_nonneg: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> a * b \<le> 0"
+using mult_right_mono [of a zero b] by simp
+
+text {* Legacy - use @{text mult_nonpos_nonneg} *}
+lemma mult_nonneg_nonpos2: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> b * a \<le> 0"
+by (drule mult_right_mono [of b zero], auto)
+
+lemma split_mult_neg_le: "(0 \<le> a & b \<le> 0) | (a \<le> 0 & 0 \<le> b) \<Longrightarrow> a * b \<le> 0"
+by (auto simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)
+
+end
+
+class linordered_semiring = semiring + comm_monoid_add + linordered_cancel_ab_semigroup_add + mult_mono
+begin
+
+subclass ordered_cancel_semiring ..
+
+subclass ordered_comm_monoid_add ..
+
+lemma mult_left_less_imp_less:
+ "c * a < c * b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
+by (force simp add: mult_left_mono not_le [symmetric])
+
+lemma mult_right_less_imp_less:
+ "a * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
+by (force simp add: mult_right_mono not_le [symmetric])
+
+end
+
+class linordered_semiring_1 = linordered_semiring + semiring_1
+
+class linordered_semiring_strict = semiring + comm_monoid_add + linordered_cancel_ab_semigroup_add +
+ assumes mult_strict_left_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
+ assumes mult_strict_right_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> a * c < b * c"
+begin
+
+subclass semiring_0_cancel ..
+
+subclass linordered_semiring
+proof
+ fix a b c :: 'a
+ assume A: "a \<le> b" "0 \<le> c"
+ from A show "c * a \<le> c * b"
+ unfolding le_less
+ using mult_strict_left_mono by (cases "c = 0") auto
+ from A show "a * c \<le> b * c"
+ unfolding le_less
+ using mult_strict_right_mono by (cases "c = 0") auto
+qed
+
+lemma mult_left_le_imp_le:
+ "c * a \<le> c * b \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
+by (force simp add: mult_strict_left_mono _not_less [symmetric])
+
+lemma mult_right_le_imp_le:
+ "a * c \<le> b * c \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
+by (force simp add: mult_strict_right_mono not_less [symmetric])
+
+lemma mult_pos_pos: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a * b"
+using mult_strict_left_mono [of zero b a] by simp
+
+lemma mult_pos_neg: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> a * b < 0"
+using mult_strict_left_mono [of b zero a] by simp
+
+lemma mult_neg_pos: "a < 0 \<Longrightarrow> 0 < b \<Longrightarrow> a * b < 0"
+using mult_strict_right_mono [of a zero b] by simp
+
+text {* Legacy - use @{text mult_neg_pos} *}
+lemma mult_pos_neg2: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> b * a < 0"
+by (drule mult_strict_right_mono [of b zero], auto)
+
+lemma zero_less_mult_pos:
+ "0 < a * b \<Longrightarrow> 0 < a \<Longrightarrow> 0 < b"
+apply (cases "b\<le>0")
+ apply (auto simp add: le_less not_less)
+apply (drule_tac mult_pos_neg [of a b])
+ apply (auto dest: less_not_sym)
+done
+
+lemma zero_less_mult_pos2:
+ "0 < b * a \<Longrightarrow> 0 < a \<Longrightarrow> 0 < b"
+apply (cases "b\<le>0")
+ apply (auto simp add: le_less not_less)
+apply (drule_tac mult_pos_neg2 [of a b])
+ apply (auto dest: less_not_sym)
+done
+
+text{*Strict monotonicity in both arguments*}
+lemma mult_strict_mono:
+ assumes "a < b" and "c < d" and "0 < b" and "0 \<le> c"
+ shows "a * c < b * d"
+ using assms apply (cases "c=0")
+ apply (simp add: mult_pos_pos)
+ apply (erule mult_strict_right_mono [THEN less_trans])
+ apply (force simp add: le_less)
+ apply (erule mult_strict_left_mono, assumption)
+ done
+
+text{*This weaker variant has more natural premises*}
+lemma mult_strict_mono':
+ assumes "a < b" and "c < d" and "0 \<le> a" and "0 \<le> c"
+ shows "a * c < b * d"
+by (rule mult_strict_mono) (insert assms, auto)
+
+lemma mult_less_le_imp_less:
+ assumes "a < b" and "c \<le> d" and "0 \<le> a" and "0 < c"
+ shows "a * c < b * d"
+ using assms apply (subgoal_tac "a * c < b * c")
+ apply (erule less_le_trans)
+ apply (erule mult_left_mono)
+ apply simp
+ apply (erule mult_strict_right_mono)
+ apply assumption
+ done
+
+lemma mult_le_less_imp_less:
+ assumes "a \<le> b" and "c < d" and "0 < a" and "0 \<le> c"
+ shows "a * c < b * d"
+ using assms apply (subgoal_tac "a * c \<le> b * c")
+ apply (erule le_less_trans)
+ apply (erule mult_strict_left_mono)
+ apply simp
+ apply (erule mult_right_mono)
+ apply simp
+ done
+
+lemma mult_less_imp_less_left:
+ assumes less: "c * a < c * b" and nonneg: "0 \<le> c"
+ shows "a < b"
+proof (rule ccontr)
+ assume "\<not> a < b"
+ hence "b \<le> a" by (simp add: linorder_not_less)
+ hence "c * b \<le> c * a" using nonneg by (rule mult_left_mono)
+ with this and less show False by (simp add: not_less [symmetric])
+qed
+
+lemma mult_less_imp_less_right:
+ assumes less: "a * c < b * c" and nonneg: "0 \<le> c"
+ shows "a < b"
+proof (rule ccontr)
+ assume "\<not> a < b"
+ hence "b \<le> a" by (simp add: linorder_not_less)
+ hence "b * c \<le> a * c" using nonneg by (rule mult_right_mono)
+ with this and less show False by (simp add: not_less [symmetric])
+qed
+
+end
+
+class linordered_semiring_1_strict = linordered_semiring_strict + semiring_1
+
+class mult_mono1 = times + zero + ord +
+ assumes mult_mono1: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
+
+class ordered_comm_semiring = comm_semiring_0
+ + ordered_ab_semigroup_add + mult_mono1
+begin
+
+subclass ordered_semiring
+proof
+ fix a b c :: 'a
+ assume "a \<le> b" "0 \<le> c"
+ thus "c * a \<le> c * b" by (rule mult_mono1)
+ thus "a * c \<le> b * c" by (simp only: mult_commute)
+qed
+
+end
+
+class ordered_cancel_comm_semiring = comm_semiring_0_cancel
+ + ordered_ab_semigroup_add + mult_mono1
+begin
+
+subclass ordered_comm_semiring ..
+subclass ordered_cancel_semiring ..
+
+end
+
+class linordered_comm_semiring_strict = comm_semiring_0 + linordered_cancel_ab_semigroup_add +
+ assumes mult_strict_left_mono_comm: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
+begin
+
+subclass linordered_semiring_strict
+proof
+ fix a b c :: 'a
+ assume "a < b" "0 < c"
+ thus "c * a < c * b" by (rule mult_strict_left_mono_comm)
+ thus "a * c < b * c" by (simp only: mult_commute)
+qed
+
+subclass ordered_cancel_comm_semiring
+proof
+ fix a b c :: 'a
+ assume "a \<le> b" "0 \<le> c"
+ thus "c * a \<le> c * b"
+ unfolding le_less
+ using mult_strict_left_mono by (cases "c = 0") auto
+qed
+
+end
+
+class ordered_ring = ring + ordered_cancel_semiring
+begin
+
+subclass ordered_ab_group_add ..
+
+text{*Legacy - use @{text algebra_simps} *}
+lemmas ring_simps[noatp] = algebra_simps
+
+lemma less_add_iff1:
+ "a * e + c < b * e + d \<longleftrightarrow> (a - b) * e + c < d"
+by (simp add: algebra_simps)
+
+lemma less_add_iff2:
+ "a * e + c < b * e + d \<longleftrightarrow> c < (b - a) * e + d"
+by (simp add: algebra_simps)
+
+lemma le_add_iff1:
+ "a * e + c \<le> b * e + d \<longleftrightarrow> (a - b) * e + c \<le> d"
+by (simp add: algebra_simps)
+
+lemma le_add_iff2:
+ "a * e + c \<le> b * e + d \<longleftrightarrow> c \<le> (b - a) * e + d"
+by (simp add: algebra_simps)
+
+lemma mult_left_mono_neg:
+ "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> c * a \<le> c * b"
+ apply (drule mult_left_mono [of _ _ "uminus c"])
+ apply simp_all
+ done
+
+lemma mult_right_mono_neg:
+ "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> a * c \<le> b * c"
+ apply (drule mult_right_mono [of _ _ "uminus c"])
+ apply simp_all
+ done
+
+lemma mult_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> 0 \<le> a * b"
+using mult_right_mono_neg [of a zero b] by simp
+
+lemma split_mult_pos_le:
+ "(0 \<le> a \<and> 0 \<le> b) \<or> (a \<le> 0 \<and> b \<le> 0) \<Longrightarrow> 0 \<le> a * b"
+by (auto simp add: mult_nonneg_nonneg mult_nonpos_nonpos)
+
+end
+
+class linordered_ring = ring + linordered_semiring + linordered_ab_group_add + abs_if
+begin
+
+subclass ordered_ring ..
+
+subclass ordered_ab_group_add_abs
+proof
+ fix a b
+ show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
+ by (auto simp add: abs_if not_less)
+ (auto simp del: minus_add_distrib simp add: minus_add_distrib [symmetric],
+ auto intro: add_nonneg_nonneg, auto intro!: less_imp_le add_neg_neg)
+qed (auto simp add: abs_if)
+
+end
+
+(* The "strict" suffix can be seen as describing the combination of linordered_ring and no_zero_divisors.
+ Basically, linordered_ring + no_zero_divisors = linordered_ring_strict.
+ *)
+class linordered_ring_strict = ring + linordered_semiring_strict
+ + ordered_ab_group_add + abs_if
+begin
+
+subclass linordered_ring ..
+
+lemma mult_strict_left_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> c * a < c * b"
+using mult_strict_left_mono [of b a "- c"] by simp
+
+lemma mult_strict_right_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> a * c < b * c"
+using mult_strict_right_mono [of b a "- c"] by simp
+
+lemma mult_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> 0 < a * b"
+using mult_strict_right_mono_neg [of a zero b] by simp
+
+subclass ring_no_zero_divisors
+proof
+ fix a b
+ assume "a \<noteq> 0" then have A: "a < 0 \<or> 0 < a" by (simp add: neq_iff)
+ assume "b \<noteq> 0" then have B: "b < 0 \<or> 0 < b" by (simp add: neq_iff)
+ have "a * b < 0 \<or> 0 < a * b"
+ proof (cases "a < 0")
+ case True note A' = this
+ show ?thesis proof (cases "b < 0")
+ case True with A'
+ show ?thesis by (auto dest: mult_neg_neg)
+ next
+ case False with B have "0 < b" by auto
+ with A' show ?thesis by (auto dest: mult_strict_right_mono)
+ qed
+ next
+ case False with A have A': "0 < a" by auto
+ show ?thesis proof (cases "b < 0")
+ case True with A'
+ show ?thesis by (auto dest: mult_strict_right_mono_neg)
+ next
+ case False with B have "0 < b" by auto
+ with A' show ?thesis by (auto dest: mult_pos_pos)
+ qed
+ qed
+ then show "a * b \<noteq> 0" by (simp add: neq_iff)
+qed
+
+lemma zero_less_mult_iff:
+ "0 < a * b \<longleftrightarrow> 0 < a \<and> 0 < b \<or> a < 0 \<and> b < 0"
+ apply (auto simp add: mult_pos_pos mult_neg_neg)
+ apply (simp_all add: not_less le_less)
+ apply (erule disjE) apply assumption defer
+ apply (erule disjE) defer apply (drule sym) apply simp
+ apply (erule disjE) defer apply (drule sym) apply simp
+ apply (erule disjE) apply assumption apply (drule sym) apply simp
+ apply (drule sym) apply simp
+ apply (blast dest: zero_less_mult_pos)
+ apply (blast dest: zero_less_mult_pos2)
+ done
+
+lemma zero_le_mult_iff:
+ "0 \<le> a * b \<longleftrightarrow> 0 \<le> a \<and> 0 \<le> b \<or> a \<le> 0 \<and> b \<le> 0"
+by (auto simp add: eq_commute [of 0] le_less not_less zero_less_mult_iff)
+
+lemma mult_less_0_iff:
+ "a * b < 0 \<longleftrightarrow> 0 < a \<and> b < 0 \<or> a < 0 \<and> 0 < b"
+ apply (insert zero_less_mult_iff [of "-a" b])
+ apply force
+ done
+
+lemma mult_le_0_iff:
+ "a * b \<le> 0 \<longleftrightarrow> 0 \<le> a \<and> b \<le> 0 \<or> a \<le> 0 \<and> 0 \<le> b"
+ apply (insert zero_le_mult_iff [of "-a" b])
+ apply force
+ done
+
+lemma zero_le_square [simp]: "0 \<le> a * a"
+by (simp add: zero_le_mult_iff linear)
+
+lemma not_square_less_zero [simp]: "\<not> (a * a < 0)"
+by (simp add: not_less)
+
+text{*Cancellation laws for @{term "c*a < c*b"} and @{term "a*c < b*c"},
+ also with the relations @{text "\<le>"} and equality.*}
+
+text{*These ``disjunction'' versions produce two cases when the comparison is
+ an assumption, but effectively four when the comparison is a goal.*}
+
+lemma mult_less_cancel_right_disj:
+ "a * c < b * c \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
+ apply (cases "c = 0")
+ apply (auto simp add: neq_iff mult_strict_right_mono
+ mult_strict_right_mono_neg)
+ apply (auto simp add: not_less
+ not_le [symmetric, of "a*c"]
+ not_le [symmetric, of a])
+ apply (erule_tac [!] notE)
+ apply (auto simp add: less_imp_le mult_right_mono
+ mult_right_mono_neg)
+ done
+
+lemma mult_less_cancel_left_disj:
+ "c * a < c * b \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
+ apply (cases "c = 0")
+ apply (auto simp add: neq_iff mult_strict_left_mono
+ mult_strict_left_mono_neg)
+ apply (auto simp add: not_less
+ not_le [symmetric, of "c*a"]
+ not_le [symmetric, of a])
+ apply (erule_tac [!] notE)
+ apply (auto simp add: less_imp_le mult_left_mono
+ mult_left_mono_neg)
+ done
+
+text{*The ``conjunction of implication'' lemmas produce two cases when the
+comparison is a goal, but give four when the comparison is an assumption.*}
+
+lemma mult_less_cancel_right:
+ "a * c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
+ using mult_less_cancel_right_disj [of a c b] by auto
+
+lemma mult_less_cancel_left:
+ "c * a < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
+ using mult_less_cancel_left_disj [of c a b] by auto
+
+lemma mult_le_cancel_right:
+ "a * c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
+by (simp add: not_less [symmetric] mult_less_cancel_right_disj)
+
+lemma mult_le_cancel_left:
+ "c * a \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
+by (simp add: not_less [symmetric] mult_less_cancel_left_disj)
+
+lemma mult_le_cancel_left_pos:
+ "0 < c \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> a \<le> b"
+by (auto simp: mult_le_cancel_left)
+
+lemma mult_le_cancel_left_neg:
+ "c < 0 \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> b \<le> a"
+by (auto simp: mult_le_cancel_left)
+
+lemma mult_less_cancel_left_pos:
+ "0 < c \<Longrightarrow> c * a < c * b \<longleftrightarrow> a < b"
+by (auto simp: mult_less_cancel_left)
+
+lemma mult_less_cancel_left_neg:
+ "c < 0 \<Longrightarrow> c * a < c * b \<longleftrightarrow> b < a"
+by (auto simp: mult_less_cancel_left)
+
+end
+
+text{*Legacy - use @{text algebra_simps} *}
+lemmas ring_simps[noatp] = algebra_simps
+
+lemmas mult_sign_intros =
+ mult_nonneg_nonneg mult_nonneg_nonpos
+ mult_nonpos_nonneg mult_nonpos_nonpos
+ mult_pos_pos mult_pos_neg
+ mult_neg_pos mult_neg_neg
+
+class ordered_comm_ring = comm_ring + ordered_comm_semiring
+begin
+
+subclass ordered_ring ..
+subclass ordered_cancel_comm_semiring ..
+
+end
+
+class linordered_semidom = comm_semiring_1_cancel + linordered_comm_semiring_strict +
+ (*previously linordered_semiring*)
+ assumes zero_less_one [simp]: "0 < 1"
+begin
+
+lemma pos_add_strict:
+ shows "0 < a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
+ using add_strict_mono [of zero a b c] by simp
+
+lemma zero_le_one [simp]: "0 \<le> 1"
+by (rule zero_less_one [THEN less_imp_le])
+
+lemma not_one_le_zero [simp]: "\<not> 1 \<le> 0"
+by (simp add: not_le)
+
+lemma not_one_less_zero [simp]: "\<not> 1 < 0"
+by (simp add: not_less)
+
+lemma less_1_mult:
+ assumes "1 < m" and "1 < n"
+ shows "1 < m * n"
+ using assms mult_strict_mono [of 1 m 1 n]
+ by (simp add: less_trans [OF zero_less_one])
+
+end
+
+class linordered_idom = comm_ring_1 +
+ linordered_comm_semiring_strict + ordered_ab_group_add +
+ abs_if + sgn_if
+ (*previously linordered_ring*)
+begin
+
+subclass linordered_ring_strict ..
+subclass ordered_comm_ring ..
+subclass idom ..
+
+subclass linordered_semidom
+proof
+ have "0 \<le> 1 * 1" by (rule zero_le_square)
+ thus "0 < 1" by (simp add: le_less)
+qed
+
+lemma linorder_neqE_linordered_idom:
+ assumes "x \<noteq> y" obtains "x < y" | "y < x"
+ using assms by (rule neqE)
+
+text {* These cancellation simprules also produce two cases when the comparison is a goal. *}
+
+lemma mult_le_cancel_right1:
+ "c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
+by (insert mult_le_cancel_right [of 1 c b], simp)
+
+lemma mult_le_cancel_right2:
+ "a * c \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
+by (insert mult_le_cancel_right [of a c 1], simp)
+
+lemma mult_le_cancel_left1:
+ "c \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
+by (insert mult_le_cancel_left [of c 1 b], simp)
+
+lemma mult_le_cancel_left2:
+ "c * a \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
+by (insert mult_le_cancel_left [of c a 1], simp)
+
+lemma mult_less_cancel_right1:
+ "c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
+by (insert mult_less_cancel_right [of 1 c b], simp)
+
+lemma mult_less_cancel_right2:
+ "a * c < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
+by (insert mult_less_cancel_right [of a c 1], simp)
+
+lemma mult_less_cancel_left1:
+ "c < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
+by (insert mult_less_cancel_left [of c 1 b], simp)
+
+lemma mult_less_cancel_left2:
+ "c * a < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
+by (insert mult_less_cancel_left [of c a 1], simp)
+
+lemma sgn_sgn [simp]:
+ "sgn (sgn a) = sgn a"
+unfolding sgn_if by simp
+
+lemma sgn_0_0:
+ "sgn a = 0 \<longleftrightarrow> a = 0"
+unfolding sgn_if by simp
+
+lemma sgn_1_pos:
+ "sgn a = 1 \<longleftrightarrow> a > 0"
+unfolding sgn_if by simp
+
+lemma sgn_1_neg:
+ "sgn a = - 1 \<longleftrightarrow> a < 0"
+unfolding sgn_if by auto
+
+lemma sgn_pos [simp]:
+ "0 < a \<Longrightarrow> sgn a = 1"
+unfolding sgn_1_pos .
+
+lemma sgn_neg [simp]:
+ "a < 0 \<Longrightarrow> sgn a = - 1"
+unfolding sgn_1_neg .
+
+lemma sgn_times:
+ "sgn (a * b) = sgn a * sgn b"
+by (auto simp add: sgn_if zero_less_mult_iff)
+
+lemma abs_sgn: "abs k = k * sgn k"
+unfolding sgn_if abs_if by auto
+
+lemma sgn_greater [simp]:
+ "0 < sgn a \<longleftrightarrow> 0 < a"
+ unfolding sgn_if by auto
+
+lemma sgn_less [simp]:
+ "sgn a < 0 \<longleftrightarrow> a < 0"
+ unfolding sgn_if by auto
+
+lemma abs_dvd_iff [simp]: "(abs m) dvd k \<longleftrightarrow> m dvd k"
+ by (simp add: abs_if)
+
+lemma dvd_abs_iff [simp]: "m dvd (abs k) \<longleftrightarrow> m dvd k"
+ by (simp add: abs_if)
+
+lemma dvd_if_abs_eq:
+ "abs l = abs (k) \<Longrightarrow> l dvd k"
+by(subst abs_dvd_iff[symmetric]) simp
+
+end
+
+text {* Simprules for comparisons where common factors can be cancelled. *}
+
+lemmas mult_compare_simps[noatp] =
+ mult_le_cancel_right mult_le_cancel_left
+ mult_le_cancel_right1 mult_le_cancel_right2
+ mult_le_cancel_left1 mult_le_cancel_left2
+ mult_less_cancel_right mult_less_cancel_left
+ mult_less_cancel_right1 mult_less_cancel_right2
+ mult_less_cancel_left1 mult_less_cancel_left2
+ mult_cancel_right mult_cancel_left
+ mult_cancel_right1 mult_cancel_right2
+ mult_cancel_left1 mult_cancel_left2
+
+-- {* FIXME continue localization here *}
+
+subsection {* Reasoning about inequalities with division *}
+
+lemma mult_right_le_one_le: "0 <= (x::'a::linordered_idom) ==> 0 <= y ==> y <= 1
+ ==> x * y <= x"
+by (auto simp add: mult_le_cancel_left2)
+
+lemma mult_left_le_one_le: "0 <= (x::'a::linordered_idom) ==> 0 <= y ==> y <= 1
+ ==> y * x <= x"
+by (auto simp add: mult_le_cancel_right2)
+
+context linordered_semidom
+begin
+
+lemma less_add_one: "a < a + 1"
+proof -
+ have "a + 0 < a + 1"
+ by (blast intro: zero_less_one add_strict_left_mono)
+ thus ?thesis by simp
+qed
+
+lemma zero_less_two: "0 < 1 + 1"
+by (blast intro: less_trans zero_less_one less_add_one)
+
+end
+
+
+subsection {* Absolute Value *}
+
+context linordered_idom
+begin
+
+lemma mult_sgn_abs: "sgn x * abs x = x"
+ unfolding abs_if sgn_if by auto
+
+end
+
+lemma abs_one [simp]: "abs 1 = (1::'a::linordered_idom)"
+by (simp add: abs_if zero_less_one [THEN order_less_not_sym])
+
+class ordered_ring_abs = ordered_ring + ordered_ab_group_add_abs +
+ assumes abs_eq_mult:
+ "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0) \<Longrightarrow> \<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
+
+context linordered_idom
+begin
+
+subclass ordered_ring_abs proof
+qed (auto simp add: abs_if not_less mult_less_0_iff)
+
+lemma abs_mult:
+ "abs (a * b) = abs a * abs b"
+ by (rule abs_eq_mult) auto
+
+lemma abs_mult_self:
+ "abs a * abs a = a * a"
+ by (simp add: abs_if)
+
+end
+
+lemma abs_mult_less:
+ "[| abs a < c; abs b < d |] ==> abs a * abs b < c*(d::'a::linordered_idom)"
+proof -
+ assume ac: "abs a < c"
+ hence cpos: "0<c" by (blast intro: order_le_less_trans abs_ge_zero)
+ assume "abs b < d"
+ thus ?thesis by (simp add: ac cpos mult_strict_mono)
+qed
+
+lemmas eq_minus_self_iff[noatp] = equal_neg_zero
+
+lemma less_minus_self_iff: "(a < -a) = (a < (0::'a::linordered_idom))"
+ unfolding order_less_le less_eq_neg_nonpos equal_neg_zero ..
+
+lemma abs_less_iff: "(abs a < b) = (a < b & -a < (b::'a::linordered_idom))"
+apply (simp add: order_less_le abs_le_iff)
+apply (auto simp add: abs_if)
+done
+
+lemma abs_mult_pos: "(0::'a::linordered_idom) <= x ==>
+ (abs y) * x = abs (y * x)"
+ apply (subst abs_mult)
+ apply simp
+done
+
+code_modulename SML
+ Rings Arith
+
+code_modulename OCaml
+ Rings Arith
+
+code_modulename Haskell
+ Rings Arith
+
+end
--- a/src/HOL/SEQ.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SEQ.thy Fri Feb 19 15:21:57 2010 +0000
@@ -573,7 +573,7 @@
apply (rule allI, rule impI, rule ext)
apply (erule conjE)
apply (induct_tac x)
-apply (simp add: nat_rec_0)
+apply simp
apply (erule_tac x="n" in allE)
apply (simp)
done
--- a/src/HOL/SET_Protocol/Event_SET.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SET_Protocol/Event_SET.thy Fri Feb 19 15:21:57 2010 +0000
@@ -11,8 +11,7 @@
begin
text{*The Root Certification Authority*}
-syntax RCA :: agent
-translations "RCA" == "CA 0"
+abbreviation "RCA == CA 0"
text{*Message events*}
--- a/src/HOL/SET_Protocol/Message_SET.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SET_Protocol/Message_SET.thy Fri Feb 19 15:21:57 2010 +0000
@@ -71,14 +71,14 @@
(*Concrete syntax: messages appear as {|A,B,NA|}, etc...*)
syntax
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
syntax (xsymbols)
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
translations
"{|x, y, z|}" == "{|x, {|y, z|}|}"
- "{|x, y|}" == "MPair x y"
+ "{|x, y|}" == "CONST MPair x y"
constdefs
--- a/src/HOL/SET_Protocol/Public_SET.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SET_Protocol/Public_SET.thy Fri Feb 19 15:21:57 2010 +0000
@@ -23,19 +23,12 @@
publicKey :: "[bool, agent] => key"
--{*the boolean is TRUE if a signing key*}
-syntax
- pubEK :: "agent => key"
- pubSK :: "agent => key"
- priEK :: "agent => key"
- priSK :: "agent => key"
+abbreviation "pubEK == publicKey False"
+abbreviation "pubSK == publicKey True"
-translations
- "pubEK" == "publicKey False"
- "pubSK" == "publicKey True"
-
- (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
- "priEK A" == "invKey (pubEK A)"
- "priSK A" == "invKey (pubSK A)"
+(*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
+abbreviation "priEK A == invKey (pubEK A)"
+abbreviation "priSK A == invKey (pubSK A)"
text{*By freeness of agents, no two agents have the same key. Since
@{term "True\<noteq>False"}, no agent has the same signing and encryption keys.*}
@@ -159,18 +152,12 @@
"certC PAN Ka PS T signK ==
signCert signK {|Hash {|Nonce PS, Pan PAN|}, Key Ka, T|}"
- (*cert and certA have no repeated elements, so they could be translations,
- but that's tricky and makes proofs slower*)
+(*cert and certA have no repeated elements, so they could be abbreviations,
+ but that's tricky and makes proofs slower*)
-syntax
- "onlyEnc" :: msg
- "onlySig" :: msg
- "authCode" :: msg
-
-translations
- "onlyEnc" == "Number 0"
- "onlySig" == "Number (Suc 0)"
- "authCode" == "Number (Suc (Suc 0))"
+abbreviation "onlyEnc == Number 0"
+abbreviation "onlySig == Number (Suc 0)"
+abbreviation "authCode == Number (Suc (Suc 0))"
subsection{*Encryption Primitives*}
--- a/src/HOL/SMT/Examples/SMT_Examples.certs Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Examples/SMT_Examples.certs Fri Feb 19 15:21:57 2010 +0000
@@ -1,4 +1,4 @@
-yknPpoG47N1CXnUaEL9RvQ 133
+Fg1W6egjwo9zhhAmUXOW+w 8 0
#2 := false
#1 := true
#4 := (not true)
@@ -7,8 +7,7 @@
#20 := [asserted]: #4
[mp #20 #22]: false
unsat
-
-ymB2ZiCSl9aUjMXP3tIpZA 359
+2+cndY9nzS72l7VvBCGRAw 19 0
#2 := false
decl up_1 :: bool
#4 := up_1
@@ -28,8 +27,7 @@
#23 := [asserted]: #7
[mp #23 #32]: false
unsat
-
-XC3j0tGm4Y5klDm8sMkzVg 510
+0vJQrobUDcQ9PkGJO8aM8g 25 0
#2 := false
decl up_1 :: bool
#4 := up_1
@@ -55,8 +53,7 @@
#23 := [asserted]: #7
[mp #23 #38]: false
unsat
-
-y5d/Jtt47lXm/wUEvH5fHw 794
+AGGnpwEv208Vqxly7wTWHA 38 0
#2 := false
decl up_2 :: bool
#5 := up_2
@@ -95,11 +92,9 @@
#30 := [and-elim #31]: #6
[mp #30 #52]: false
unsat
-
-mDaukNkyA4glYbkfEOtcAw 7
-unsat
-
-TmB9YjKjdtDMIh0j9rMVPw 1530
+wakXeIy1uoPgglzOQGFhJQ 1 0
+unsat
+cpSlDe0l7plVktRNxGU5dA 71 0
#2 := false
decl up_1 :: bool
#4 := up_1
@@ -171,8 +166,7 @@
#31 := [asserted]: #15
[mp #31 #82]: false
unsat
-
-olufSxMlwMAAqyArYWPVOA 1300
+pg19mjJfV75T2QDrgWd4JA 57 0
#2 := false
decl up_1 :: bool
#4 := up_1
@@ -230,8 +224,7 @@
#30 := [asserted]: #14
[mp #30 #70]: false
unsat
-
-agKJ550QwZ1mvlK8gw+tjQ 4627
+Mj1B8X1MaN7xU/W4Kz3FoQ 194 0
#2 := false
decl up_1 :: bool
#4 := up_1
@@ -426,8 +419,7 @@
#237 := [mp #83 #236]: #75
[mp #237 #247]: false
unsat
-
-+R/oj2I+uFZAw/Eu+3ULdw 1160
+JkhYJB8FDavTZkizO1/9IA 52 0
#2 := false
decl uf_1 :: (-> T1 T1 T1)
decl uf_2 :: T1
@@ -480,8 +472,7 @@
#113 := [quant-inst]: #199
[unit-resolution #113 #536 #49]: false
unsat
-
-c67Ar5f1aFkzAZ2wYy62Wg 56943
+0ZdSZH2DbtjHNTyrDkZmXg 1667 0
#2 := false
decl up_54 :: bool
#126 := up_54
@@ -2149,8 +2140,7 @@
#2371 := [unit-resolution #891 #2369]: #166
[unit-resolution #2159 #2371 #2370 #2358 #2357]: false
unsat
-
-NdJwa8pysYWhn57eCXiqFA 1731
+R3pmBDBlU9XdUrxJXhj7nA 78 0
#2 := false
decl up_1 :: (-> int bool)
decl ?x1!0 :: int
@@ -2229,8 +2219,7 @@
#82 := [and-elim #81]: #55
[unit-resolution #82 #95]: false
unsat
-
-dWWXDEA5bUZjEafLPXbSkA 3321
+IBRj/loev6P6r0J+HOit6A 135 0
#2 := false
decl up_1 :: (-> T1 T2 bool)
#5 := (:var 0 T2)
@@ -2366,9 +2355,7 @@
#176 := [quant-inst]: #538
[unit-resolution #176 #252 #535]: false
unsat
-
-iGZ7b2jaCnn82lPL6oIDZA 3465
-WARNING: failed to find a pattern for quantifier (quantifier id: k!11)
+72504KVBixGB/87pOYiU/A 135 2
#2 := false
decl up_1 :: (-> T1 T2 bool)
#5 := (:var 0 T2)
@@ -2504,8 +2491,9 @@
#235 := [quant-inst]: #597
[unit-resolution #235 #311 #594]: false
unsat
+WARNING: failed to find a pattern for quantifier (quantifier id: k!12)
-eTjcfu6S5eyz+xNJ7SVluw 1246
+RaQLz4GxtUICnOD5WoYnzQ 56 0
#2 := false
decl up_1 :: (-> T1 bool)
decl uf_2 :: T1
@@ -2562,8 +2550,7 @@
#120 := [quant-inst]: #206
[unit-resolution #120 #542 #41]: false
unsat
-
-anG1bKU/YVTHEmc1Eh/ZXw 331
+NPQIgVPhSpgSLeS+u/EatQ 17 0
#2 := false
#4 := 3::int
#5 := (= 3::int 3::int)
@@ -2581,8 +2568,7 @@
#22 := [asserted]: #6
[mp #22 #31]: false
unsat
-
-lHpRCTa744ODgmii2zARAw 334
+Lc9NwVtwY2Wo0G7UbFD1oA 17 0
#2 := false
#4 := 3::real
#5 := (= 3::real 3::real)
@@ -2600,8 +2586,7 @@
#22 := [asserted]: #6
[mp #22 #31]: false
unsat
-
-AinXomcY4W1L/t0ZtkDhBg 524
+pYVrUflpYrrZEWALJDnvPw 26 0
#2 := false
#7 := 4::int
#5 := 1::int
@@ -2628,8 +2613,7 @@
#25 := [asserted]: #9
[mp #25 #40]: false
unsat
-
-WxMdOusjxqQwBPorpXBkFQ 815
+FIqzVlbN8RT0iWarmBEpjw 41 0
#2 := false
decl uf_1 :: int
#4 := uf_1
@@ -2671,8 +2655,7 @@
#28 := [asserted]: #12
[mp #28 #52]: false
unsat
-
-K7g37p4yZoVyQcabYS4I2w 754
+HWVNtxMa8xktQsg8pHG+1w 35 0
#2 := false
#5 := 3::int
#6 := 8::int
@@ -2708,8 +2691,7 @@
#26 := [asserted]: #10
[mp #26 #51]: false
unsat
-
-eCmVy21SUmWImXZDJNOfzA 6496
+M71YYpEc8u/aEIH3MOQrcg 250 0
#2 := false
#7 := 0::real
decl uf_2 :: real
@@ -2960,8 +2942,7 @@
#294 := [unit-resolution #190 #293]: #188
[th-lemma #280 #294]: false
unsat
-
-eBRZKSXriNPK3BNu3AWMmQ 3017
+G00bTqBjtW66EmwIZbXbOg 124 0
#2 := false
decl uf_1 :: (-> T1 T2)
decl uf_3 :: T1
@@ -3086,8 +3067,7 @@
#34 := [asserted]: #11
[unit-resolution #34 #536]: false
unsat
-
-CjDkjvq1e9i+SJ3L9ESARg 1146
+6QdzkSy/RtEjUu+wUKIKqA 54 0
#2 := false
#9 := 1::int
decl uf_1 :: int
@@ -3142,8 +3122,7 @@
#28 := [asserted]: #12
[mp #28 #67]: false
unsat
-
-nonk4MmmwlBqL8YtiJY/Qw 1339
+xoSwaSeELbR0PHe0zb/BSg 63 0
#2 := false
#11 := 0::int
decl uf_2 :: int
@@ -3207,8 +3186,7 @@
#76 := [mp #52 #75]: #63
[mp #76 #84]: false
unsat
-
-dCX9jxibjKl6gmr8okzk0w 727
+ciHqmDSmPpA15rO932dhvA 35 0
#2 := false
#6 := 5::int
#4 := 2::int
@@ -3244,8 +3222,7 @@
#25 := [asserted]: #9
[mp #25 #49]: false
unsat
-
-/kLzs8f/jQjEM38PdppYPA 912
+HzwFy7SRHqpspkYnzyeF4w 45 0
#2 := false
#11 := 4::real
decl uf_2 :: real
@@ -3291,8 +3268,7 @@
#60 := [mp #36 #59]: #51
[th-lemma #60 #47 #38]: false
unsat
-
-iT8vKYi503k30rQLczD7yw 1245
+XW7QIWmzYjfQXaHHPc98eA 59 0
#2 := false
#16 := (not false)
decl uf_2 :: int
@@ -3352,8 +3328,94 @@
#34 := [asserted]: #18
[mp #34 #71]: false
unsat
-
-6R4JcV7tL9QRH7WWPAKM5g 5413
+ZGL00TLLioiLlWFiXUnbxg 86 0
+#2 := false
+decl uf_1 :: int
+#5 := uf_1
+#7 := 2::int
+#29 := (* 2::int uf_1)
+#4 := 0::int
+#54 := (= 0::int #29)
+#55 := (not #54)
+#61 := (= #29 0::int)
+#104 := (not #61)
+#110 := (iff #104 #55)
+#108 := (iff #61 #54)
+#109 := [commutativity]: #108
+#111 := [monotonicity #109]: #110
+#62 := (<= #29 0::int)
+#100 := (not #62)
+#30 := (<= uf_1 0::int)
+#31 := (not #30)
+#6 := (< 0::int uf_1)
+#32 := (iff #6 #31)
+#33 := [rewrite]: #32
+#27 := [asserted]: #6
+#34 := [mp #27 #33]: #31
+#101 := (or #100 #30)
+#102 := [th-lemma]: #101
+#103 := [unit-resolution #102 #34]: #100
+#105 := (or #104 #62)
+#106 := [th-lemma]: #105
+#107 := [unit-resolution #106 #103]: #104
+#112 := [mp #107 #111]: #55
+#56 := (= uf_1 #29)
+#57 := (not #56)
+#53 := (= 0::int uf_1)
+#50 := (not #53)
+#58 := (and #50 #55 #57)
+#69 := (not #58)
+#42 := (distinct 0::int uf_1 #29)
+#47 := (not #42)
+#9 := (- uf_1 uf_1)
+#8 := (* uf_1 2::int)
+#10 := (distinct uf_1 #8 #9)
+#11 := (not #10)
+#48 := (iff #11 #47)
+#45 := (iff #10 #42)
+#39 := (distinct uf_1 #29 0::int)
+#43 := (iff #39 #42)
+#44 := [rewrite]: #43
+#40 := (iff #10 #39)
+#37 := (= #9 0::int)
+#38 := [rewrite]: #37
+#35 := (= #8 #29)
+#36 := [rewrite]: #35
+#41 := [monotonicity #36 #38]: #40
+#46 := [trans #41 #44]: #45
+#49 := [monotonicity #46]: #48
+#28 := [asserted]: #11
+#52 := [mp #28 #49]: #47
+#80 := (or #42 #69)
+#81 := [def-axiom]: #80
+#82 := [unit-resolution #81 #52]: #69
+#59 := (= uf_1 0::int)
+#83 := (not #59)
+#89 := (iff #83 #50)
+#87 := (iff #59 #53)
+#88 := [commutativity]: #87
+#90 := [monotonicity #88]: #89
+#84 := (or #83 #30)
+#85 := [th-lemma]: #84
+#86 := [unit-resolution #85 #34]: #83
+#91 := [mp #86 #90]: #50
+#64 := -1::int
+#65 := (* -1::int #29)
+#66 := (+ uf_1 #65)
+#68 := (>= #66 0::int)
+#92 := (not #68)
+#93 := (or #92 #30)
+#94 := [th-lemma]: #93
+#95 := [unit-resolution #94 #34]: #92
+#96 := (or #57 #68)
+#97 := [th-lemma]: #96
+#98 := [unit-resolution #97 #95]: #57
+#76 := (or #58 #53 #54 #56)
+#77 := [def-axiom]: #76
+#99 := [unit-resolution #77 #98 #91 #82]: #54
+[unit-resolution #99 #112]: false
+unsat
+DWt5rIK6NWlI4vrw+691Zg 212 0
#2 := false
decl uf_4 :: T1
#13 := uf_4
@@ -3566,96 +3628,7 @@
#519 := [unit-resolution #521 #518]: #547
[unit-resolution #519 #522]: false
unsat
-
-eOXl5Nf4A2Sq4Q+Wh5XNfA 2026
-#2 := false
-decl uf_1 :: int
-#5 := uf_1
-#7 := 2::int
-#29 := (* 2::int uf_1)
-#4 := 0::int
-#54 := (= 0::int #29)
-#55 := (not #54)
-#61 := (= #29 0::int)
-#104 := (not #61)
-#110 := (iff #104 #55)
-#108 := (iff #61 #54)
-#109 := [commutativity]: #108
-#111 := [monotonicity #109]: #110
-#62 := (<= #29 0::int)
-#100 := (not #62)
-#30 := (<= uf_1 0::int)
-#31 := (not #30)
-#6 := (< 0::int uf_1)
-#32 := (iff #6 #31)
-#33 := [rewrite]: #32
-#27 := [asserted]: #6
-#34 := [mp #27 #33]: #31
-#101 := (or #100 #30)
-#102 := [th-lemma]: #101
-#103 := [unit-resolution #102 #34]: #100
-#105 := (or #104 #62)
-#106 := [th-lemma]: #105
-#107 := [unit-resolution #106 #103]: #104
-#112 := [mp #107 #111]: #55
-#56 := (= uf_1 #29)
-#57 := (not #56)
-#53 := (= 0::int uf_1)
-#50 := (not #53)
-#58 := (and #50 #55 #57)
-#69 := (not #58)
-#42 := (distinct 0::int uf_1 #29)
-#47 := (not #42)
-#9 := (- uf_1 uf_1)
-#8 := (* uf_1 2::int)
-#10 := (distinct uf_1 #8 #9)
-#11 := (not #10)
-#48 := (iff #11 #47)
-#45 := (iff #10 #42)
-#39 := (distinct uf_1 #29 0::int)
-#43 := (iff #39 #42)
-#44 := [rewrite]: #43
-#40 := (iff #10 #39)
-#37 := (= #9 0::int)
-#38 := [rewrite]: #37
-#35 := (= #8 #29)
-#36 := [rewrite]: #35
-#41 := [monotonicity #36 #38]: #40
-#46 := [trans #41 #44]: #45
-#49 := [monotonicity #46]: #48
-#28 := [asserted]: #11
-#52 := [mp #28 #49]: #47
-#80 := (or #42 #69)
-#81 := [def-axiom]: #80
-#82 := [unit-resolution #81 #52]: #69
-#59 := (= uf_1 0::int)
-#83 := (not #59)
-#89 := (iff #83 #50)
-#87 := (iff #59 #53)
-#88 := [commutativity]: #87
-#90 := [monotonicity #88]: #89
-#84 := (or #83 #30)
-#85 := [th-lemma]: #84
-#86 := [unit-resolution #85 #34]: #83
-#91 := [mp #86 #90]: #50
-#64 := -1::int
-#65 := (* -1::int #29)
-#66 := (+ uf_1 #65)
-#68 := (>= #66 0::int)
-#92 := (not #68)
-#93 := (or #92 #30)
-#94 := [th-lemma]: #93
-#95 := [unit-resolution #94 #34]: #92
-#96 := (or #57 #68)
-#97 := [th-lemma]: #96
-#98 := [unit-resolution #97 #95]: #57
-#76 := (or #58 #53 #54 #56)
-#77 := [def-axiom]: #76
-#99 := [unit-resolution #77 #98 #91 #82]: #54
-[unit-resolution #99 #112]: false
-unsat
-
-TwJgkTydtls9Q94iw4a3jw 17377
+PaSeDRf7Set5ywlblDOoTg 673 0
#2 := false
#169 := 0::int
decl uf_2 :: int
@@ -4329,8 +4302,7 @@
#410 := [mp #349 #409]: #405
[unit-resolution #410 #710 #709 #697 #706]: false
unsat
-
-ib5n9nvBAC5jXuKIpV/54g 82870
+U7jSPEM53XYq3qs03aUczw 2291 0
#2 := false
#6 := 0::int
decl z3name!0 :: int
@@ -6622,8 +6594,7 @@
#2323 := [unit-resolution #918 #2322]: #100
[unit-resolution #917 #2323 #2318]: false
unsat
-
-SqgPFdiZeq8SOFuTISQN5g 1109
+eqE7IAqFr0UIBuUsVDgHvw 52 0
#2 := false
#8 := 1::real
decl uf_1 :: real
@@ -6676,8 +6647,7 @@
#29 := [asserted]: #13
[mp #29 #65]: false
unsat
-
-rOkYPs+Q++z/M3OPR/88JQ 1272
+ADs4ZPiuUr7Xu7tk71NnEw 59 0
#2 := false
#55 := 0::int
#7 := 2::int
@@ -6737,8 +6707,7 @@
#144 := [unit-resolution #143 #28]: #58
[unit-resolution #144 #68]: false
unsat
-
-oSBTeiF6GKDeHPsMxXHXtQ 1161
+x2NmsblNl28xPXP2EG22rA 54 0
#2 := false
#5 := 2::int
decl uf_1 :: int
@@ -6793,8 +6762,7 @@
#139 := [unit-resolution #138 #27]: #127
[unit-resolution #139 #62]: false
unsat
-
-hqH9yBHvmZgES3pBkvsqVQ 2715
+kfLiOGBz3RZx9wt+FS+hfg 118 0
#2 := false
#5 := 0::real
decl uf_1 :: real
@@ -6913,8 +6881,7 @@
#126 := [mp #101 #125]: #115
[unit-resolution #126 #132 #129]: false
unsat
-
-ar4IlNF9IylWgGSPOf9paw 5159
+FPTJq9aN3ES4iIrHgaTv+A 208 0
#2 := false
#9 := 0::int
#11 := 4::int
@@ -7123,8 +7090,7 @@
#418 := [unit-resolution #417 #36]: #298
[th-lemma #418 #415 #412 #411 #99 #400 #397 #396]: false
unsat
-
-o9WM91Nq0O5f08PEA0qA6w 515
+yN0aj3KferzvOSp2KlyNwg 24 0
#2 := false
#4 := (exists (vars (?x1 int)) false)
#5 := (not #4)
@@ -7149,8 +7115,7 @@
#22 := [asserted]: #6
[mp #22 #38]: false
unsat
-
-SJxvvXYE4z1G4iLRBCPerg 516
+7iMPasu6AIeHm45slLCByA 24 0
#2 := false
#4 := (exists (vars (?x1 real)) false)
#5 := (not #4)
@@ -7175,17 +7140,13 @@
#22 := [asserted]: #6
[mp #22 #38]: false
unsat
-
-Fr3hfDrqfMuGDpDYbXAHwg 7
-unsat
-
-bFuFCRUoQSRWyp0iCwo+PA 7
-unsat
-
-NJEgv3p5NO4/yEATNBBDNw 7
-unsat
-
-RC1LWjyqEEsh1xhocCgPmQ 1633
+cv2pC2I0gIUYtVwtXngvXg 1 0
+unsat
+4r8/IxBBDH1ZqF0YfzLLTg 1 0
+unsat
+uj7n+C4nG462DNJy9Divrg 1 0
+unsat
+dn/LVwy1BXEOmtqdUBNhLw 73 0
#2 := false
#5 := 0::int
#8 := 1::int
@@ -7259,8 +7220,7 @@
#144 := [trans #142 #82]: #143
[mp #144 #146]: false
unsat
-
-6pnpFuE9SN6Jr5Upml9T0A 1896
+VzZ1W5SEEis1AJp1qZz86g 82 0
#2 := false
#5 := (:var 0 int)
#7 := 0::int
@@ -7343,8 +7303,7 @@
#30 := [asserted]: #14
[mp #30 #96]: false
unsat
-
-sHpY0IFBgZUNhP56aRB+/w 1765
+UoXgZh5LkmyNCmQEfEtnig 78 0
#2 := false
#5 := (:var 0 int)
#7 := 2::int
@@ -7423,8 +7382,7 @@
#31 := [asserted]: #15
[mp #31 #92]: false
unsat
-
-7GSX+dyn9XwHWNcjJ4X1ww 1400
+Qv4gVhCmOzC39uufV9ZpDA 61 0
#2 := false
#9 := (:var 0 int)
#4 := 2::int
@@ -7486,8 +7444,7 @@
#30 := [asserted]: #14
[mp #30 #75]: false
unsat
-
-oieid3+1h5s04LTQ9d796Q 2636
++j+tSj7aUImWej2XcTL9dw 111 0
#2 := false
#4 := 2::int
decl ?x1!1 :: int
@@ -7599,8 +7556,7 @@
#184 := [th-lemma]: #183
[unit-resolution #184 #127 #125 #126]: false
unsat
-
-+RiWXCcHPvuSeYUjZ4Ky/g 2113
+kQRsBd9oowc7exsvsEgTUg 89 0
#2 := false
#4 := 0::int
decl ?x1!0 :: int
@@ -7690,9 +7646,7 @@
#167 := [unit-resolution #154 #90]: #166
[unit-resolution #167 #165 #162]: false
unsat
-
-hlG1vHDJCcXbyvxKYDWifg 2036
-WARNING: failed to find a pattern for quantifier (quantifier id: k!1)
+VPjD8BtzPcTZKIRT4SA3Nw 83 2
#2 := false
#5 := 0::int
#4 := (:var 0 int)
@@ -7776,9 +7730,9 @@
#62 := [mp~ #54 #61]: #49
[unit-resolution #62 #174]: false
unsat
+WARNING: failed to find a pattern for quantifier (quantifier id: k!2)
-oOC8ghGUYboMezGio2exAg 4464
-WARNING: failed to find a pattern for quantifier (quantifier id: k!1)
+DCV5zpDW3cC2A61VghqFkA 180 2
#2 := false
#4 := 0::int
#5 := (:var 0 int)
@@ -7959,8 +7913,9 @@
#585 := [unit-resolution #128 #581]: #55
[unit-resolution #585 #307]: false
unsat
+WARNING: failed to find a pattern for quantifier (quantifier id: k!2)
-4Dtb5Y1TTRPWZcHG9Griog 1594
+lYXJpXHB9nLXJbOsr9VH1w 68 0
#2 := false
#12 := 1::int
#9 := (:var 1 int)
@@ -8029,8 +7984,7 @@
#32 := [asserted]: #16
[mp #32 #83]: false
unsat
-
-dbOre63OdVavsqL3lG2ttw 2516
+jNvpOd8qnh73F8B6mQDrRw 107 0
#2 := false
#4 := 0::int
decl ?x2!1 :: int
@@ -8138,8 +8092,7 @@
#123 := [and-elim #101]: #88
[th-lemma #123 #124 #125]: false
unsat
-
-LtM5szEGH9QAF1TwsVtH4w 2764
+QWWPBUGjgvTCpxqJ9oPGdQ 117 0
#2 := false
#4 := 0::int
decl ?x2!1 :: int
@@ -8257,8 +8210,7 @@
#188 := [unit-resolution #187 #110]: #98
[unit-resolution #188 #130]: false
unsat
-
-ibIqbnIUB+oyERADdbFW6w 3631
+3r4MsKEvDJc1RWnNRxu/3Q 148 0
#2 := false
#144 := (not false)
#7 := 0::int
@@ -8407,8 +8359,7 @@
#158 := [mp #126 #157]: #153
[mp #158 #181]: false
unsat
-
-1HbJvLWS/aG8IZEVLDIWyA 1506
+Q+cnHyqIFLGWsSlQkp3fEg 67 0
#2 := false
#4 := (:var 0 int)
#5 := (pattern #4)
@@ -8476,11 +8427,9 @@
#30 := [asserted]: #14
[mp #30 #80]: false
unsat
-
-K7kWge9RT44bPFRy+hxaqg 7
-unsat
-
-+rwKUm5bOzD9paEkmogLyw 1562
+Q7HDzu4ER2dw+lHHM6YgFg 1 0
+unsat
+saejIG5KeeVxOolEIo3gtw 75 0
#2 := false
#6 := 1::int
decl uf_3 :: int
@@ -8556,8 +8505,7 @@
#32 := [asserted]: #16
[mp #32 #86]: false
unsat
-
-iRJ30NP1Enylq9tZfpCPTA 1288
+PPaoU5CzQFYr3LRpOsGPhQ 62 0
#2 := false
decl uf_2 :: real
#6 := uf_2
@@ -8620,8 +8568,7 @@
#32 := [asserted]: #16
[mp #32 #74]: false
unsat
-
-Ff1vqDiuUnet19j/x+mXkA 3029
+hXKzem5+KYZMOj+GKxjszQ 141 0
#2 := false
decl uf_4 :: int
#9 := uf_4
@@ -8763,8 +8710,7 @@
#45 := [asserted]: #29
[mp #45 #150]: false
unsat
-
-iPZ87GNdi7uQw4ehEpbTPQ 6383
+3D8WhjZTO7T824d7mwXcCA 252 0
#2 := false
#9 := 0::int
decl uf_2 :: (-> T1 int)
@@ -9017,8 +8963,7 @@
#539 := [unit-resolution #532 #451]: #557
[th-lemma #455 #539 #537 #546]: false
unsat
-
-kDuOn7kAggfP4Um8ghhv5A 5551
+kyphS4o71h68g2YhvYbQQQ 223 0
#2 := false
#23 := 3::int
decl uf_2 :: (-> T1 int)
@@ -9242,8 +9187,7 @@
#598 := [unit-resolution #593 #596]: #623
[th-lemma #152 #598 #139]: false
unsat
-
-aiB004AWADNjynNrqCDsxw 9284
+M8P5WxpiY5AWxaJDBtXoLQ 367 0
#2 := false
#9 := 0::int
decl uf_2 :: (-> T1 int)
@@ -9611,8 +9555,7 @@
#456 := [th-lemma]: #455
[unit-resolution #456 #464 #452]: false
unsat
-
-twoPNF2RBLeff4yYfubpfg 7634
+Xs4JZCKb5egkcPabsrodXg 302 0
#2 := false
#9 := 0::int
decl uf_2 :: (-> T1 int)
@@ -9915,8 +9858,7 @@
#601 := [unit-resolution #615 #613]: #683
[th-lemma #623 #188 #601 #628]: false
unsat
-
-ZcLxnpFewGGQ0H47MfRXGw 11816
+clMAi2WqMi360EjFURRGLg 458 0
#2 := false
#9 := 0::int
decl uf_2 :: (-> T1 int)
@@ -10375,8 +10317,7 @@
#350 := [unit-resolution #369 #367]: #368
[unit-resolution #350 #323]: false
unsat
-
-ipe8HUL/t33OoeNl/z0smQ 4011
+mu7O1os0t3tPqWZhwizjxw 161 0
#2 := false
#9 := 0::int
decl uf_3 :: int
@@ -10538,8 +10479,7 @@
#361 := [unit-resolution #639 #655]: #647
[th-lemma #656 #361 #261]: false
unsat
-
-eRjXXrQSzpzyc8Ro409d3Q 14366
+08cmOtIT4NYs2PG/F3zeZw 557 0
#2 := false
#9 := 0::int
decl uf_2 :: (-> T1 int)
@@ -11097,83 +11037,57 @@
#990 := [unit-resolution #501 #807]: #511
[unit-resolution #990 #989 #979]: false
unsat
-
-uq2MbDTgTG1nxWdwzZtWew 7
-unsat
-
-E5BydeDaPocMMvChMGY+og 7
-unsat
-
-p81EQzqwJrGunGO7GuNt3g 7
-unsat
-
-KpYfvnTcz2WncWNg3dJDCA 7
-unsat
-
-ybGRm230DLO0wH6aROKBBw 7
-unsat
-
-goFtZfJ6kkxA8sqBVpZutw 7
-unsat
-
-0+nmgsMqioeTuwam1ScP7g 7
-unsat
-
-nI63LP/VCL//bjsS1gNB2A 7
-unsat
-
-9+2QHvrRgbKz97Zg0kfybw 7
-unsat
-
-6kquszLXeBUhTwzaw6gd2Q 7
-unsat
-
-j5Z04lpza+N5I1cpno5mtw 7
-unsat
-
-mapbfUM6Ils30x5nEBJmaw 7
-unsat
-
-e8P++0FczY3zhNhEVclACw 7
-unsat
-
-yXMQNOyCylhI+EH8hNYxHA 7
-unsat
-
-GkYN9j7cjrR2KR/lb04/qw 7
-unsat
-
-PajzgNjLWHwVHpjoje+gnA 7
-unsat
-
-URpJYU7D8PO0VRnciRgE5A 7
-unsat
-
-D9ZGhymoV3L6zbWsJlwG2A 7
-unsat
-
-0QLuovrnnANWnCkUY3l10g 7
-unsat
-
-CYprps2G0Au5F3Z7n3KTRg 7
-unsat
-
-iyIMuJd6zijfEao8zKnx2w 7
-unsat
-
-49jzsAwAEfR6NSFBhBEisQ 7
-unsat
-
-T0j6xFgrghxif91jL+2yAw 7
-unsat
-
-md/M3rVve0+8sQ6oqIoL2w 7
-unsat
-
-pY7C8PCf5lVVaim6q7PJcQ 7
-unsat
-
-4zCFLQf4Jrov/gmEvsBm4Q 1036
+8HdmSMHHP2B8XMFzjNuw5Q 1 0
+unsat
+O4aM0+/isn2q5CrIefZjzg 1 0
+unsat
+t/ni9djl2DqxH0iKupZSwg 1 0
+unsat
+RumBGekdxZQaBF1HNa3x9w 1 0
+unsat
+Q9d+IbQ8chjKld71X6/zqw 1 0
+unsat
+PhC8zQV8hnJ6E2YYjZPGjQ 1 0
+unsat
+mieI2RhSp3bYaojlWH1A4A 1 0
+unsat
+pRSV6nBLconzrQz2zUrJ6g 1 0
+unsat
+Js0JfdwDoKq3YuilPPgeZw 1 0
+unsat
+GRIqjLUJiqXbo+pXhAeKIw 1 0
+unsat
+Bg5scsmPFp82+7Y2ScL6Wg 1 0
+unsat
+XD6zX6850dLxyfZSfNv30A 1 0
+unsat
+BG/HwJYnumvDICXxtBu/tA 1 0
+unsat
+YMc4t19sUMWbUkx3woxCmQ 1 0
+unsat
+YyD9IF72pKXGGKZTO7FY5Q 1 0
+unsat
+zRPsIUi+TEoz5fPWP0H9bQ 1 0
+unsat
+8ipTE8BOXpvSo/U6D4p3lA 1 0
+unsat
+MSzQywedZPsOE0CDxrrO0g 1 0
+unsat
+SryZuXv48ItET8NPIv07pA 1 0
+unsat
+qOMUQN18hYFl/wWt54lvbA 1 0
+unsat
++njWXdn6fETK3/AjtiHjcA 1 0
+unsat
+5cQ7gJ33gzYTIIPA3hbBmQ 1 0
+unsat
+ZznT34cvumrP00mXZ3gcjw 1 0
+unsat
+//LQca1Et5RfhQJZA+CGCA 1 0
+unsat
+3ntxKz+kaQNfTrLzY9sVXw 1 0
+unsat
+4lL2Qo8ngE1EH1UdeN1Qng 43 0
#2 := false
#6 := 0::int
decl uf_1 :: (-> bv[2] int)
@@ -11217,11 +11131,9 @@
#287 := [th-lemma]: #627
[unit-resolution #287 #47 #635]: false
unsat
-
-czvSLyjMowmFNi82us4N2Q 7
-unsat
-
-aU+7kcyE8oAPbs5RjfuwIw 1160
++xe3O927LrflFUE6NDqRlA 1 0
+unsat
+JPoL7fPYhqhAkjUiVF+THQ 50 0
#2 := false
decl uf_6 :: T2
#23 := uf_6
@@ -11272,8 +11184,7 @@
#66 := [asserted]: #26
[unit-resolution #66 #235]: false
unsat
-
-dXfueqZAXkudfE6G0VKkwg 2559
+l23ZDmd0VbO/Q+uO5EtabA 105 0
#2 := false
decl uf_6 :: (-> T4 T2)
decl uf_10 :: T4
@@ -11379,8 +11290,7 @@
#110 := [asserted]: #46
[unit-resolution #110 #238]: false
unsat
-
-Dc/6bNJffjYYplvoitScJQ 4578
+GZjffeZPQnL3OyLCvxdCpg 181 0
#2 := false
decl uf_1 :: (-> T1 T2 T3)
decl uf_3 :: T2
@@ -11562,8 +11472,7 @@
#76 := [asserted]: #38
[unit-resolution #76 #489]: false
unsat
-
-jdmsd1j41Osn+WzTtqTUSQ 1352
+i6jCzzRosHYE0w7sF1Nraw 62 0
#2 := false
decl up_4 :: (-> T1 T2 bool)
decl uf_3 :: T2
@@ -11626,8 +11535,7 @@
#73 := [unit-resolution #71 #68]: #72
[unit-resolution #73 #59 #61]: false
unsat
-
-EA8ecQ7czWL46/C3k7D7tg 2697
+YZHSyhN2TGlpe+vpkzWrgQ 115 0
#2 := false
decl up_2 :: (-> T2 bool)
decl uf_3 :: T2
@@ -11743,8 +11651,7 @@
#560 := [mp #344 #559]: #557
[unit-resolution #560 #576 #561]: false
unsat
-
-mNfbN3NQCB4ik2xJmLE1UQ 11936
+TibRlXkU+X+1+zGPYTiT0g 464 0
#2 := false
decl uf_2 :: (-> T2 T3 T3)
decl uf_4 :: T3
@@ -12209,8 +12116,7 @@
#177 := [asserted]: #53
[unit-resolution #177 #793]: false
unsat
-
-Jtmz+P173L9nRQkQk52h+Q 420
+DJPKxi9AO25zGBcs5kxUrw 21 0
#2 := false
decl up_1 :: (-> T1 bool)
#4 := (:var 0 T1)
@@ -12232,8 +12138,7 @@
#25 := [asserted]: #9
[mp #25 #34]: false
unsat
-
-YG20f6Uf93koN6rVg/alpA 9362
+i5PnMbuM9mWv5LnVszz9+g 366 0
#2 := false
decl uf_1 :: (-> int T1)
#37 := 6::int
@@ -12600,8 +12505,7 @@
#182 := [asserted]: #40
[unit-resolution #182 #399]: false
unsat
-
-/fwo5o8vhLVHyS4oYEs4QA 10833
+K2SXMHU6QCZJ8TRs6zjKRg 408 0
#2 := false
#22 := 0::int
#8 := 2::int
@@ -13010,8 +12914,7 @@
#375 := [unit-resolution #374 #407]: #708
[th-lemma #375 #370 #465]: false
unsat
-
-s8LL71+1HTN+eIuEYeKhUw 1251
+1DhSL9G2fGRGmuI8IaMNOA 50 0
#2 := false
decl up_35 :: (-> int bool)
#112 := 1::int
@@ -13062,8 +12965,7 @@
#504 := [quant-inst]: #503
[unit-resolution #504 #916 #297]: false
unsat
-
-MZYsU5krlrOK4MkB71Ikeg 12985
+dyXROdcPFSd36N3K7dpmDw 506 0
#2 := false
decl uf_17 :: (-> T8 T3)
decl uf_18 :: (-> T1 T8)
@@ -13570,4 +13472,3 @@
#325 := [asserted]: #108
[unit-resolution #325 #554]: false
unsat
-
--- a/src/HOL/SMT/Examples/SMT_Examples.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Examples/SMT_Examples.thy Fri Feb 19 15:21:57 2010 +0000
@@ -17,7 +17,7 @@
the following option is set to "false":
*}
-declare [[smt_record=false]]
+declare [[smt_record=false]]
--- a/src/HOL/SMT/SMT_Base.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/SMT_Base.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,8 +5,10 @@
header {* SMT-specific definitions and basic tools *}
theory SMT_Base
-imports Real Word "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+imports Real "~~/src/HOL/Word/Word"
+ "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
uses
+ "~~/src/Tools/Cache_IO/cache_io.ML"
("Tools/smt_normalize.ML")
("Tools/smt_monomorph.ML")
("Tools/smt_translate.ML")
--- a/src/HOL/SMT/Tools/smt_normalize.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Tools/smt_normalize.ML Fri Feb 19 15:21:57 2010 +0000
@@ -125,8 +125,15 @@
Conv.rewr_conv @{thm atomize_all}
| _ => Conv.all_conv) ct
+fun unfold_quants_conv ctxt =
+ let
+ val rules = [@{thm Ex1_def}, @{thm Ball_def}, @{thm Bex_def}]
+ val unfold_conv = Conv.try_conv (More_Conv.rewrs_conv rules)
+ in More_Conv.top_conv (K unfold_conv) ctxt end
+
fun normalize_rule ctxt =
Conv.fconv_rule (
+ unfold_quants_conv ctxt then_conv
Thm.beta_conversion true then_conv
Thm.eta_conversion then_conv
norm_binder_conv ctxt) #>
--- a/src/HOL/SMT/Tools/smt_solver.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Tools/smt_solver.ML Fri Feb 19 15:21:57 2010 +0000
@@ -20,7 +20,7 @@
type solver_config = {
command: {env_var: string, remote_name: string option},
arguments: string list,
- interface: interface,
+ interface: string list -> interface,
reconstruct: proof_data -> thm }
(*options*)
@@ -28,8 +28,10 @@
val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
val trace: bool Config.T
val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
+
+ (*certificates*)
val record: bool Config.T
- val certificates: string Config.T
+ val select_certificates: string -> Context.generic -> Context.generic
(*solvers*)
type solver = Proof.context -> thm list -> thm
@@ -71,7 +73,7 @@
type solver_config = {
command: {env_var: string, remote_name: string option},
arguments: string list,
- interface: interface,
+ interface: string list -> interface,
reconstruct: proof_data -> thm }
@@ -88,30 +90,29 @@
fun trace_msg ctxt f x =
if Config.get ctxt trace then tracing (f x) else ()
+
+(* SMT certificates *)
+
val (record, setup_record) = Attrib.config_bool "smt_record" true
-val no_certificates = ""
-val (certificates, setup_certificates) =
- Attrib.config_string "smt_certificates" no_certificates
+structure Certificates = Generic_Data
+(
+ type T = Cache_IO.cache option
+ val empty = NONE
+ val extend = I
+ fun merge (s, _) = s
+)
+
+fun select_certificates name = Certificates.put (
+ if name = "" then NONE
+ else SOME (Cache_IO.make (Path.explode name)))
(* interface to external solvers *)
local
-fun with_files ctxt f =
- let
- val paths as (problem_path, proof_path) =
- "smt-" ^ serial_string ()
- |> (fn n => (n, n ^ ".proof"))
- |> pairself (File.tmp_path o Path.explode)
-
- val y = Exn.capture f (problem_path, proof_path)
-
- val _ = pairself (try File.rm) paths
- in Exn.release y end
-
-fun invoke ctxt output f (paths as (problem_path, proof_path)) =
+fun invoke ctxt output f problem_path =
let
fun pretty tag ls = Pretty.string_of (Pretty.big_list tag
(map Pretty.str ls))
@@ -120,11 +121,10 @@
val _ = trace_msg ctxt (pretty "SMT problem:" o split_lines o File.read)
problem_path
- val (s, _) = with_timeout ctxt f paths
- val _ = trace_msg ctxt (pretty "SMT solver:") (split_lines s)
+ val (res, err) = with_timeout ctxt f problem_path
+ val _ = trace_msg ctxt (pretty "SMT solver:") err
- fun lines_of path = the_default [] (try (File.fold_lines cons path) [])
- val ls = rev (dropwhile (equal "") (lines_of proof_path))
+ val ls = rev (dropwhile (equal "") (rev res))
val _ = trace_msg ctxt (pretty "SMT result:") ls
in (x, ls) end
@@ -135,47 +135,53 @@
val remote_url = getenv "REMOTE_SMT_URL"
in
if local_solver <> ""
- then (["local", local_solver],
- "Invoking local SMT solver " ^ quote local_solver ^ " ...")
- else if remote_solver <> "" andalso remote_url <> ""
- then (["remote", remote_solver],
- "Invoking remote SMT solver " ^ quote remote_solver ^ " at " ^
- quote remote_url ^ " ...")
+ then
+ (tracing ("Invoking local SMT solver " ^ quote local_solver ^ " ...");
+ [local_solver])
+ else if remote_solver <> ""
+ then
+ (tracing ("Invoking remote SMT solver " ^ quote remote_solver ^ " at " ^
+ quote remote_url ^ " ...");
+ [getenv "REMOTE_SMT", remote_solver])
else error ("Undefined Isabelle environment variable: " ^ quote env_var)
end
-fun run ctxt cmd args (problem_path, proof_path) =
- let
- val certs = Config.get ctxt certificates
- val certs' =
- if certs = no_certificates then "-"
- else File.shell_path (Path.explode certs)
- val (solver, msg) =
- if certs = no_certificates orelse Config.get ctxt record
- then choose cmd
- else (["certificate"], "Using certificate from " ^ quote certs' ^ " ...")
- val _ = tracing msg
+fun make_cmd solver args problem_path proof_path = space_implode " " (
+ map File.shell_quote (solver @ args) @
+ [File.shell_path problem_path, "2>&1", ">", File.shell_path proof_path])
+
+fun no_cmd _ _ = error ("Bad certificates cache: missing certificate")
+
+fun run ctxt cmd args problem_path =
+ let val certs = Certificates.get (Context.Proof ctxt)
in
- system_out (space_implode " " ("perl -w" ::
- File.shell_path (Path.explode (getenv "RUN_SMT_SOLVER")) :: certs' ::
- map File.shell_quote (solver @ args) @
- map File.shell_path [problem_path, proof_path]) ^ " 2>&1")
+ if is_none certs
+ then Cache_IO.run' (make_cmd (choose cmd) args) problem_path
+ else if Config.get ctxt record
+ then Cache_IO.cached' (the certs) (make_cmd (choose cmd) args) problem_path
+ else
+ (tracing ("Using cached certificate from " ^
+ File.shell_path (Cache_IO.cache_path_of (the certs)) ^ " ...");
+ Cache_IO.cached' (the certs) no_cmd problem_path)
end
in
fun run_solver ctxt cmd args output =
- with_files ctxt (invoke ctxt output (run ctxt cmd args))
+ Cache_IO.with_tmp_file "smt-" (invoke ctxt output (run ctxt cmd args))
end
fun make_proof_data ctxt ((recon, thms), ls) =
{context=ctxt, output=ls, recon=recon, assms=SOME thms}
-fun gen_solver solver ctxt prems =
+fun gen_solver name solver ctxt prems =
let
val {command, arguments, interface, reconstruct} = solver ctxt
- val {normalize=nc, translate=tc} = interface
+ val comments = ("solver: " ^ name) ::
+ ("timeout: " ^ string_of_int (Config.get ctxt timeout)) ::
+ "arguments:" :: arguments
+ val {normalize=nc, translate=tc} = interface comments
val thy = ProofContext.theory_of ctxt
in
SMT_Normalize.normalize nc ctxt prems
@@ -218,17 +224,19 @@
val solver_name_of = Selected_Solver.get
-fun select_solver name gen =
- if is_none (lookup_solver (Context.theory_of gen) name)
+fun select_solver name context =
+ if is_none (lookup_solver (Context.theory_of context) name)
then error ("SMT solver not registered: " ^ quote name)
- else Selected_Solver.map (K name) gen
+ else Selected_Solver.map (K name) context
-fun raw_solver_of gen =
- (case lookup_solver (Context.theory_of gen) (solver_name_of gen) of
+fun raw_solver_of context name =
+ (case lookup_solver (Context.theory_of context) name of
NONE => error "No SMT solver selected"
| SOME (s, _) => s)
-val solver_of = gen_solver o raw_solver_of
+fun solver_of context =
+ let val name = solver_name_of context
+ in gen_solver name (raw_solver_of context name) end
(* SMT tactic *)
@@ -278,7 +286,10 @@
setup_timeout #>
setup_trace #>
setup_record #>
- setup_certificates #>
+ Attrib.setup (Binding.name "smt_certificates")
+ (Scan.lift (OuterParse.$$$ "=" |-- Args.name) >>
+ (Thm.declaration_attribute o K o select_certificates))
+ "SMT certificates" #>
Method.setup (Binding.name "smt") smt_method
"Applies an SMT solver to the current goal."
--- a/src/HOL/SMT/Tools/smtlib_interface.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Tools/smtlib_interface.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,9 +8,9 @@
sig
val basic_builtins: SMT_Translate.builtins
val default_attributes: string list
- val gen_interface: SMT_Translate.builtins -> string list ->
+ val gen_interface: SMT_Translate.builtins -> string list -> string list ->
SMT_Solver.interface
- val interface: SMT_Solver.interface
+ val interface: string list -> SMT_Solver.interface
end
structure SMTLIB_Interface: SMTLIB_INTERFACE =
@@ -118,12 +118,13 @@
| wr_pat (T.SNoPat ts) = wrp "nopat" ts
in par (wr_quant q #> fold wr_var vs #> wre b #> fold wr_pat ps) end)
-fun serialize attributes ({typs, funs, preds} : T.sign) ts stream =
+fun serialize attributes comments ({typs, funs, preds} : T.sign) ts stream =
let
fun wr_decl (n, Ts) = wr_line (sep (par (wr n #> fold wr1 Ts)))
in
stream
|> wr_line (wr "(benchmark Isabelle")
+ |> wr_line (wr ":status unknown")
|> fold (wr_line o wr) attributes
|> length typs > 0 ?
wr_line (wr ":extrasorts" #> par (fold wr1 typs))
@@ -138,6 +139,7 @@
|> fold (fn t => wr ":assumption" #> wr_line (wr_expr false [] t)) ts
|> wr_line (wr ":formula true")
|> wr_line (wr ")")
+ |> fold (fn comment => wr_line (wr ("; " ^ comment))) comments
|> K ()
end
@@ -149,9 +151,9 @@
builtin_num = builtin_num,
builtin_fun = (fn true => builtin_funcs | false => builtin_preds) }
-val default_attributes = [":logic AUFLIRA", ":status unknown"]
+val default_attributes = [":logic AUFLIRA"]
-fun gen_interface builtins attributes = {
+fun gen_interface builtins attributes comments = {
normalize = [
SMT_Normalize.RewriteTrivialLets,
SMT_Normalize.RewriteNegativeNumerals,
@@ -170,8 +172,9 @@
term_marker = term_marker,
formula_marker = formula_marker },
builtins = builtins,
- serialize = serialize attributes }}
+ serialize = serialize attributes comments }}
-val interface = gen_interface basic_builtins default_attributes
+fun interface comments =
+ gen_interface basic_builtins default_attributes comments
end
--- a/src/HOL/SMT/Tools/z3_interface.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Tools/z3_interface.ML Fri Feb 19 15:21:57 2010 +0000
@@ -6,7 +6,7 @@
signature Z3_INTERFACE =
sig
- val interface: SMT_Solver.interface
+ val interface: string list -> SMT_Solver.interface
end
structure Z3_Interface: Z3_INTERFACE =
--- a/src/HOL/SMT/Tools/z3_proof_rules.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/Tools/z3_proof_rules.ML Fri Feb 19 15:21:57 2010 +0000
@@ -83,7 +83,7 @@
val rule_of_string = Symtab.lookup rule_names
fun string_of_rule r =
let fun fit (s, r') = if r = r' then SOME s else NONE
- in the (Symtab.get_first NONE fit rule_names) end
+ in the (Symtab.get_first fit rule_names) end
(* proof representation *)
@@ -545,7 +545,7 @@
fun derive conj t lits idx ptab =
let
- val (l, lit) = the (Termtab.get_first NONE (get_lit conj t) lits)
+ val (l, lit) = the (Termtab.get_first (get_lit conj t) lits)
val ls = explode_thm conj false false [t] lit
val lits' = fold (Termtab.update o ` prop_of) ls (Termtab.delete l lits)
fun upd (Sequent {hyps, vars, thm}) =
@@ -1231,7 +1231,7 @@
(case Termtab.lookup tab @{term False} of
SOME rs => extract_lit thm rs
| NONE =>
- pairself (extract_lit thm) (the (Termtab.get_first NONE pnlits tab))
+ pairself (extract_lit thm) (the (Termtab.get_first pnlits tab))
|> (fn (nlit, plit) => nlit COMP (plit COMP contra_rule)))
end
val falseE_v = Thm.dest_arg (Thm.dest_arg (Thm.cprop_of @{thm FalseE}))
--- a/src/HOL/SMT/etc/settings Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SMT/etc/settings Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,7 @@
ISABELLE_SMT="$COMPONENT"
-RUN_SMT_SOLVER="$ISABELLE_SMT/lib/scripts/run_smt_solver.pl"
+RUN_SMT_SOLVER="$ISABELLE_SMT/lib/scripts/run_smt_solver"
+REMOTE_SMT="$ISABELLE_SMT/lib/scripts/remote_smt"
REMOTE_SMT_URL="http://smt.in.tum.de/smt"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/lib/scripts/remote_smt Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+#
+# Author: Sascha Boehme, TU Muenchen
+#
+# Invoke remote SMT solvers.
+
+use strict;
+use warnings;
+use LWP;
+
+
+# arguments
+
+my $solver = $ARGV[0];
+my @options = @ARGV[1 .. ($#ARGV - 1)];
+my $problem_file = $ARGV[-1];
+
+
+# call solver
+
+my $agent = LWP::UserAgent->new;
+$agent->agent("SMT-Request");
+$agent->timeout(180);
+my $response = $agent->post($ENV{"REMOTE_SMT_URL"}, [
+ "Solver" => $solver,
+ "Options" => join(" ", @options),
+ "Problem" => [$problem_file] ],
+ "Content_Type" => "form-data");
+if (not $response->is_success) { die "HTTP-Error: " . $response->message; }
+else { print $response->content; }
+
--- a/src/HOL/SMT/lib/scripts/run_smt_solver.pl Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,110 +0,0 @@
-#
-# Author: Sascha Boehme, TU Muenchen
-#
-# Cache for prover results, based on discriminating problems using MD5.
-
-use strict;
-use warnings;
-use Digest::MD5;
-use LWP;
-
-
-# arguments
-
-my $certs_file = shift @ARGV;
-my $location = shift @ARGV;
-my $result_file = pop @ARGV;
-my $problem_file = $ARGV[-1];
-
-my $use_certs = not ($certs_file eq "-");
-
-
-# create MD5 problem digest
-
-my $problem_digest = "";
-if ($use_certs) {
- my $md5 = Digest::MD5->new;
- open FILE, "<$problem_file" or
- die "ERROR: Failed to open '$problem_file' ($!)";
- $md5->addfile(*FILE);
- close FILE;
- $problem_digest = $md5->b64digest;
-}
-
-
-# lookup problem digest among existing certificates and
-# return a cached result (if there is a certificate for the problem)
-
-if ($use_certs and -e $certs_file) {
- my $cached = 0;
- open CERTS, "<$certs_file" or die "ERROR: Failed to open '$certs_file' ($!)";
- while (<CERTS>) {
- if (m/(\S+) (\d+)/) {
- if ($1 eq $problem_digest) {
- my $start = tell CERTS;
- open FILE, ">$result_file" or
- die "ERROR: Failed to open '$result_file ($!)";
- while ((tell CERTS) - $start < $2) {
- my $line = <CERTS>;
- print FILE $line;
- }
- close FILE;
- $cached = 1;
- last;
- }
- else { seek CERTS, $2, 1; }
- }
- else { die "ERROR: Invalid file format in '$certs_file'"; }
- }
- close CERTS;
- if ($cached) { exit 0; }
-}
-
-
-# invoke (remote or local) prover
-
-if ($location eq "remote") {
- # arguments
- my $solver = $ARGV[0];
- my @options = @ARGV[1 .. ($#ARGV - 1)];
-
- # call solver
- my $agent = LWP::UserAgent->new;
- $agent->agent("SMT-Request");
- $agent->timeout(180);
- my $response = $agent->post($ENV{"REMOTE_SMT_URL"}, [
- "Solver" => $solver,
- "Options" => join(" ", @options),
- "Problem" => [$problem_file] ],
- "Content_Type" => "form-data");
- if (not $response->is_success) { die "HTTP-Error: " . $response->message; }
- else {
- open FILE, ">$result_file" or
- die "ERROR: Failed to create '$result_file' ($!)";
- print FILE $response->content;
- close FILE;
- }
-}
-elsif ($location eq "local") {
- system "@ARGV >$result_file 2>&1";
-}
-else { die "ERROR: No SMT solver invoked"; }
-
-
-# cache result
-
-if ($use_certs) {
- open CERTS, ">>$certs_file" or
- die "ERROR: Failed to open '$certs_file' ($!)";
- print CERTS
- ("$problem_digest " . ((-s $result_file) + (length "\n")) . "\n");
-
- open FILE, "<$result_file" or
- die "ERROR: Failed to open '$result_file' ($!)";
- foreach (<FILE>) { print CERTS $_; }
- close FILE;
-
- print CERTS "\n";
- close CERTS;
-}
-
--- a/src/HOL/Series.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Series.thy Fri Feb 19 15:21:57 2010 +0000
@@ -381,7 +381,7 @@
shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
by (rule geometric_sums [THEN sums_summable])
-lemma half: "0 < 1 / (2::'a::{number_ring,division_by_zero,ordered_field})"
+lemma half: "0 < 1 / (2::'a::{number_ring,division_by_zero,linordered_field})"
by arith
lemma power_half_series: "(\<lambda>n. (1/2::real)^Suc n) sums 1"
--- a/src/HOL/Set.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Set.thy Fri Feb 19 15:21:57 2010 +0000
@@ -48,20 +48,16 @@
text {* Set comprehensions *}
syntax
- "@Coll" :: "pttrn => bool => 'a set" ("(1{_./ _})")
-
+ "_Coll" :: "pttrn => bool => 'a set" ("(1{_./ _})")
translations
- "{x. P}" == "Collect (%x. P)"
+ "{x. P}" == "CONST Collect (%x. P)"
syntax
- "@SetCompr" :: "'a => idts => bool => 'a set" ("(1{_ |/_./ _})")
- "@Collect" :: "idt => 'a set => bool => 'a set" ("(1{_ :/ _./ _})")
-
+ "_Collect" :: "idt => 'a set => bool => 'a set" ("(1{_ :/ _./ _})")
syntax (xsymbols)
- "@Collect" :: "idt => 'a set => bool => 'a set" ("(1{_ \<in>/ _./ _})")
-
+ "_Collect" :: "idt => 'a set => bool => 'a set" ("(1{_ \<in>/ _./ _})")
translations
- "{x:A. P}" => "{x. x:A & P}"
+ "{x:A. P}" => "{x. x:A & P}"
lemma mem_Collect_eq [iff]: "(a : {x. P(x)}) = P(a)"
by (simp add: Collect_def mem_def)
@@ -107,11 +103,10 @@
insert_compr: "insert a B = {x. x = a \<or> x \<in> B}"
syntax
- "@Finset" :: "args => 'a set" ("{(_)}")
-
+ "_Finset" :: "args => 'a set" ("{(_)}")
translations
- "{x, xs}" == "CONST insert x {xs}"
- "{x}" == "CONST insert x {}"
+ "{x, xs}" == "CONST insert x {xs}"
+ "{x}" == "CONST insert x {}"
subsection {* Subsets and bounded quantifiers *}
@@ -191,9 +186,9 @@
"_Bex1" :: "pttrn => 'a set => bool => bool" ("(3\<exists>!_\<in>_./ _)" [0, 0, 10] 10)
translations
- "ALL x:A. P" == "Ball A (%x. P)"
- "EX x:A. P" == "Bex A (%x. P)"
- "EX! x:A. P" => "EX! x. x:A & P"
+ "ALL x:A. P" == "CONST Ball A (%x. P)"
+ "EX x:A. P" == "CONST Bex A (%x. P)"
+ "EX! x:A. P" => "EX! x. x:A & P"
"LEAST x:A. P" => "LEAST x. x:A & P"
syntax (output)
@@ -233,31 +228,34 @@
print_translation {*
let
- val Type (set_type, _) = @{typ "'a set"};
- val All_binder = Syntax.binder_name @{const_syntax "All"};
- val Ex_binder = Syntax.binder_name @{const_syntax "Ex"};
+ val Type (set_type, _) = @{typ "'a set"}; (* FIXME 'a => bool (!?!) *)
+ val All_binder = Syntax.binder_name @{const_syntax All};
+ val Ex_binder = Syntax.binder_name @{const_syntax Ex};
val impl = @{const_syntax "op -->"};
val conj = @{const_syntax "op &"};
- val sbset = @{const_syntax "subset"};
- val sbset_eq = @{const_syntax "subset_eq"};
+ val sbset = @{const_syntax subset};
+ val sbset_eq = @{const_syntax subset_eq};
val trans =
- [((All_binder, impl, sbset), "_setlessAll"),
- ((All_binder, impl, sbset_eq), "_setleAll"),
- ((Ex_binder, conj, sbset), "_setlessEx"),
- ((Ex_binder, conj, sbset_eq), "_setleEx")];
+ [((All_binder, impl, sbset), @{syntax_const "_setlessAll"}),
+ ((All_binder, impl, sbset_eq), @{syntax_const "_setleAll"}),
+ ((Ex_binder, conj, sbset), @{syntax_const "_setlessEx"}),
+ ((Ex_binder, conj, sbset_eq), @{syntax_const "_setleEx"})];
fun mk v v' c n P =
if v = v' andalso not (Term.exists_subterm (fn Free (x, _) => x = v | _ => false) n)
then Syntax.const c $ Syntax.mark_bound v' $ n $ P else raise Match;
fun tr' q = (q,
- fn [Const ("_bound", _) $ Free (v, Type (T, _)), Const (c, _) $ (Const (d, _) $ (Const ("_bound", _) $ Free (v', _)) $ n) $ P] =>
- if T = (set_type) then case AList.lookup (op =) trans (q, c, d)
- of NONE => raise Match
- | SOME l => mk v v' l n P
- else raise Match
- | _ => raise Match);
+ fn [Const (@{syntax_const "_bound"}, _) $ Free (v, Type (T, _)),
+ Const (c, _) $
+ (Const (d, _) $ (Const (@{syntax_const "_bound"}, _) $ Free (v', _)) $ n) $ P] =>
+ if T = set_type then
+ (case AList.lookup (op =) trans (q, c, d) of
+ NONE => raise Match
+ | SOME l => mk v v' l n P)
+ else raise Match
+ | _ => raise Match);
in
[tr' All_binder, tr' Ex_binder]
end
@@ -270,55 +268,63 @@
only translated if @{text "[0..n] subset bvs(e)"}.
*}
+syntax
+ "_Setcompr" :: "'a => idts => bool => 'a set" ("(1{_ |/_./ _})")
+
parse_translation {*
let
- val ex_tr = snd (mk_binder_tr ("EX ", "Ex"));
+ val ex_tr = snd (mk_binder_tr ("EX ", @{const_syntax Ex}));
- fun nvars (Const ("_idts", _) $ _ $ idts) = nvars idts + 1
+ fun nvars (Const (@{syntax_const "_idts"}, _) $ _ $ idts) = nvars idts + 1
| nvars _ = 1;
fun setcompr_tr [e, idts, b] =
let
- val eq = Syntax.const "op =" $ Bound (nvars idts) $ e;
- val P = Syntax.const "op &" $ eq $ b;
+ val eq = Syntax.const @{const_syntax "op ="} $ Bound (nvars idts) $ e;
+ val P = Syntax.const @{const_syntax "op &"} $ eq $ b;
val exP = ex_tr [idts, P];
- in Syntax.const "Collect" $ Term.absdummy (dummyT, exP) end;
+ in Syntax.const @{const_syntax Collect} $ Term.absdummy (dummyT, exP) end;
- in [("@SetCompr", setcompr_tr)] end;
+ in [(@{syntax_const "_Setcompr"}, setcompr_tr)] end;
*}
-print_translation {* [
-Syntax.preserve_binder_abs2_tr' @{const_syntax Ball} "_Ball",
-Syntax.preserve_binder_abs2_tr' @{const_syntax Bex} "_Bex"
-] *} -- {* to avoid eta-contraction of body *}
+print_translation {*
+ [Syntax.preserve_binder_abs2_tr' @{const_syntax Ball} @{syntax_const "_Ball"},
+ Syntax.preserve_binder_abs2_tr' @{const_syntax Bex} @{syntax_const "_Bex"}]
+*} -- {* to avoid eta-contraction of body *}
print_translation {*
let
- val ex_tr' = snd (mk_binder_tr' ("Ex", "DUMMY"));
+ val ex_tr' = snd (mk_binder_tr' (@{const_syntax Ex}, "DUMMY"));
fun setcompr_tr' [Abs (abs as (_, _, P))] =
let
- fun check (Const ("Ex", _) $ Abs (_, _, P), n) = check (P, n + 1)
- | check (Const ("op &", _) $ (Const ("op =", _) $ Bound m $ e) $ P, n) =
+ fun check (Const (@{const_syntax Ex}, _) $ Abs (_, _, P), n) = check (P, n + 1)
+ | check (Const (@{const_syntax "op &"}, _) $
+ (Const (@{const_syntax "op ="}, _) $ Bound m $ e) $ P, n) =
n > 0 andalso m = n andalso not (loose_bvar1 (P, n)) andalso
subset (op =) (0 upto (n - 1), add_loose_bnos (e, 0, []))
- | check _ = false
+ | check _ = false;
fun tr' (_ $ abs) =
let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr' [abs]
- in Syntax.const "@SetCompr" $ e $ idts $ Q end;
- in if check (P, 0) then tr' P
- else let val (x as _ $ Free(xN,_), t) = atomic_abs_tr' abs
- val M = Syntax.const "@Coll" $ x $ t
- in case t of
- Const("op &",_)
- $ (Const("op :",_) $ (Const("_bound",_) $ Free(yN,_)) $ A)
- $ P =>
- if xN=yN then Syntax.const "@Collect" $ x $ A $ P else M
- | _ => M
- end
+ in Syntax.const @{syntax_const "_Setcompr"} $ e $ idts $ Q end;
+ in
+ if check (P, 0) then tr' P
+ else
+ let
+ val (x as _ $ Free(xN, _), t) = atomic_abs_tr' abs;
+ val M = Syntax.const @{syntax_const "_Coll"} $ x $ t;
+ in
+ case t of
+ Const (@{const_syntax "op &"}, _) $
+ (Const (@{const_syntax "op :"}, _) $
+ (Const (@{syntax_const "_bound"}, _) $ Free (yN, _)) $ A) $ P =>
+ if xN = yN then Syntax.const @{syntax_const "_Collect"} $ x $ A $ P else M
+ | _ => M
+ end
end;
- in [("Collect", setcompr_tr')] end;
+ in [(@{const_syntax Collect}, setcompr_tr')] end;
*}
setup {*
--- a/src/HOL/SetInterval.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SetInterval.thy Fri Feb 19 15:21:57 2010 +0000
@@ -54,22 +54,22 @@
@{term"{m..<n}"} may not exist in @{term"{..<n}"}-form as well. *}
syntax
- "@UNION_le" :: "'a => 'a => 'b set => 'b set" ("(3UN _<=_./ _)" 10)
- "@UNION_less" :: "'a => 'a => 'b set => 'b set" ("(3UN _<_./ _)" 10)
- "@INTER_le" :: "'a => 'a => 'b set => 'b set" ("(3INT _<=_./ _)" 10)
- "@INTER_less" :: "'a => 'a => 'b set => 'b set" ("(3INT _<_./ _)" 10)
+ "_UNION_le" :: "'a => 'a => 'b set => 'b set" ("(3UN _<=_./ _)" 10)
+ "_UNION_less" :: "'a => 'a => 'b set => 'b set" ("(3UN _<_./ _)" 10)
+ "_INTER_le" :: "'a => 'a => 'b set => 'b set" ("(3INT _<=_./ _)" 10)
+ "_INTER_less" :: "'a => 'a => 'b set => 'b set" ("(3INT _<_./ _)" 10)
syntax (xsymbols)
- "@UNION_le" :: "'a => 'a => 'b set => 'b set" ("(3\<Union> _\<le>_./ _)" 10)
- "@UNION_less" :: "'a => 'a => 'b set => 'b set" ("(3\<Union> _<_./ _)" 10)
- "@INTER_le" :: "'a => 'a => 'b set => 'b set" ("(3\<Inter> _\<le>_./ _)" 10)
- "@INTER_less" :: "'a => 'a => 'b set => 'b set" ("(3\<Inter> _<_./ _)" 10)
+ "_UNION_le" :: "'a => 'a => 'b set => 'b set" ("(3\<Union> _\<le>_./ _)" 10)
+ "_UNION_less" :: "'a => 'a => 'b set => 'b set" ("(3\<Union> _<_./ _)" 10)
+ "_INTER_le" :: "'a => 'a => 'b set => 'b set" ("(3\<Inter> _\<le>_./ _)" 10)
+ "_INTER_less" :: "'a => 'a => 'b set => 'b set" ("(3\<Inter> _<_./ _)" 10)
syntax (latex output)
- "@UNION_le" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Union>(00_ \<le> _)/ _)" 10)
- "@UNION_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Union>(00_ < _)/ _)" 10)
- "@INTER_le" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Inter>(00_ \<le> _)/ _)" 10)
- "@INTER_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Inter>(00_ < _)/ _)" 10)
+ "_UNION_le" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Union>(00_ \<le> _)/ _)" 10)
+ "_UNION_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Union>(00_ < _)/ _)" 10)
+ "_INTER_le" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Inter>(00_ \<le> _)/ _)" 10)
+ "_INTER_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set" ("(3\<Inter>(00_ < _)/ _)" 10)
translations
"UN i<=n. A" == "UN i:{..n}. A"
@@ -539,7 +539,7 @@
apply (rule subset_antisym)
apply (rule UN_finite2_subset, blast)
apply (rule UN_finite2_subset [where k=k])
- apply (force simp add: atLeastLessThan_add_Un [of 0] UN_Un)
+ apply (force simp add: atLeastLessThan_add_Un [of 0])
done
@@ -613,7 +613,7 @@
apply (unfold image_def lessThan_def)
apply auto
apply (rule_tac x = "nat x" in exI)
- apply (auto simp add: zless_nat_conj zless_nat_eq_int_zless [THEN sym])
+ apply (auto simp add: zless_nat_eq_int_zless [THEN sym])
done
lemma finite_atLeastZeroLessThan_int: "finite {(0::int)..<u}"
@@ -970,6 +970,27 @@
finally show ?thesis .
qed
+lemma setsum_le_included:
+ fixes f :: "'a \<Rightarrow> 'b::{comm_monoid_add,ordered_ab_semigroup_add_imp_le}"
+ assumes "finite s" "finite t"
+ and "\<forall>y\<in>t. 0 \<le> g y" "(\<forall>x\<in>s. \<exists>y\<in>t. i y = x \<and> f x \<le> g y)"
+ shows "setsum f s \<le> setsum g t"
+proof -
+ have "setsum f s \<le> setsum (\<lambda>y. setsum g {x. x\<in>t \<and> i x = y}) s"
+ proof (rule setsum_mono)
+ fix y assume "y \<in> s"
+ with assms obtain z where z: "z \<in> t" "y = i z" "f y \<le> g z" by auto
+ with assms show "f y \<le> setsum g {x \<in> t. i x = y}" (is "?A y \<le> ?B y")
+ using order_trans[of "?A (i z)" "setsum g {z}" "?B (i z)", intro]
+ by (auto intro!: setsum_mono2)
+ qed
+ also have "... \<le> setsum (\<lambda>y. setsum g {x. x\<in>t \<and> i x = y}) (i ` t)"
+ using assms(2-4) by (auto intro!: setsum_mono2 setsum_nonneg)
+ also have "... \<le> setsum g t"
+ using assms by (auto simp: setsum_image_gen[symmetric])
+ finally show ?thesis .
+qed
+
lemma setsum_multicount_gen:
assumes "finite s" "finite t" "\<forall>j\<in>t. (card {i\<in>s. R i j} = k j)"
shows "setsum (\<lambda>i. (card {j\<in>t. R i j})) s = setsum k t" (is "?l = ?r")
@@ -985,7 +1006,7 @@
shows "setsum (\<lambda>i. card {j\<in>T. R i j}) S = k * card T" (is "?l = ?r")
proof-
have "?l = setsum (\<lambda>i. k) T" by(rule setsum_multicount_gen)(auto simp:assms)
- also have "\<dots> = ?r" by(simp add: setsum_constant mult_commute)
+ also have "\<dots> = ?r" by(simp add: mult_commute)
finally show ?thesis by auto
qed
@@ -1025,7 +1046,7 @@
lemma geometric_sum:
"x ~= 1 ==> (\<Sum>i=0..<n. x ^ i) =
(x ^ n - 1) / (x - 1::'a::{field})"
-by (induct "n") (simp_all add:field_simps power_Suc)
+by (induct "n") (simp_all add: field_simps)
subsection {* The formula for arithmetic sums *}
@@ -1077,7 +1098,7 @@
of_nat(n) * (a + (a + of_nat(n - 1)*d))"
by (rule arith_series_general)
thus ?thesis
- unfolding One_nat_def by (auto simp add: of_nat_id)
+ unfolding One_nat_def by auto
qed
lemma arith_series_int:
--- a/src/HOL/Statespace/StateFun.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Statespace/StateFun.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: StateFun.thy
- ID: $Id$
Author: Norbert Schirmer, TU Muenchen
*)
@@ -34,12 +33,12 @@
lemma K_statefun_cong [cong]: "K_statefun c x = K_statefun c x"
by (rule refl)
-constdefs lookup:: "('v \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> 'a"
-"lookup destr n s \<equiv> destr (s n)"
+definition lookup:: "('v \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> 'a"
+ where "lookup destr n s = destr (s n)"
-constdefs update::
+definition update::
"('v \<Rightarrow> 'a1) \<Rightarrow> ('a2 \<Rightarrow> 'v) \<Rightarrow> 'n \<Rightarrow> ('a1 \<Rightarrow> 'a2) \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> ('n \<Rightarrow> 'v)"
-"update destr constr n f s \<equiv> s(n := constr (f (destr (s n))))"
+ where "update destr constr n f s = s(n := constr (f (destr (s n))))"
lemma lookup_update_same:
"(\<And>v. destr (constr v) = v) \<Longrightarrow> lookup destr n (update destr constr n f s) =
--- a/src/HOL/Statespace/StateSpaceSyntax.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Statespace/StateSpaceSyntax.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: StateSpaceSyntax.thy
- ID: $Id$
Author: Norbert Schirmer, TU Muenchen
*)
@@ -13,30 +12,27 @@
can choose if you want to use it or not. *}
syntax
- "_statespace_lookup" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" ("_\<cdot>_" [60,60] 60)
- "_statespace_update" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> ('a \<Rightarrow> 'b)"
- "_statespace_updates" :: "('a \<Rightarrow> 'b) \<Rightarrow> updbinds \<Rightarrow> ('a \<Rightarrow> 'b)" ("_<_>" [900,0] 900)
+ "_statespace_lookup" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" ("_\<cdot>_" [60, 60] 60)
+ "_statespace_update" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> ('a \<Rightarrow> 'b)"
+ "_statespace_updates" :: "('a \<Rightarrow> 'b) \<Rightarrow> updbinds \<Rightarrow> ('a \<Rightarrow> 'b)" ("_<_>" [900, 0] 900)
translations
- "_statespace_updates f (_updbinds b bs)" ==
- "_statespace_updates (_statespace_updates f b) bs"
- "s<x:=y>" == "_statespace_update s x y"
+ "_statespace_updates f (_updbinds b bs)" ==
+ "_statespace_updates (_statespace_updates f b) bs"
+ "s<x:=y>" == "_statespace_update s x y"
parse_translation (advanced)
{*
-[("_statespace_lookup",StateSpace.lookup_tr),
- ("_get",StateSpace.lookup_tr),
- ("_statespace_update",StateSpace.update_tr)]
+ [(@{syntax_const "_statespace_lookup"}, StateSpace.lookup_tr),
+ (@{syntax_const "_statespace_update"}, StateSpace.update_tr)]
*}
print_translation (advanced)
{*
-[("lookup",StateSpace.lookup_tr'),
- ("StateFun.lookup",StateSpace.lookup_tr'),
- ("update",StateSpace.update_tr'),
- ("StateFun.update",StateSpace.update_tr')]
+ [(@{const_syntax lookup}, StateSpace.lookup_tr'),
+ (@{const_syntax update}, StateSpace.update_tr')]
*}
-end
\ No newline at end of file
+end
--- a/src/HOL/Statespace/state_fun.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Statespace/state_fun.ML Fri Feb 19 15:21:57 2010 +0000
@@ -310,7 +310,7 @@
val prop = list_all ([("n",nT),("x",eT)],
Logic.mk_equals (Const ("Ex",Tex)$Abs(s,T,eq),
HOLogic.true_const));
- val thm = Drule.standard (prove prop);
+ val thm = Drule.export_without_context (prove prop);
val thm' = if swap then swap_ex_eq OF [thm] else thm
in SOME thm' end
handle TERM _ => NONE)
--- a/src/HOL/String.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/String.thy Fri Feb 19 15:21:57 2010 +0000
@@ -5,7 +5,7 @@
theory String
imports List
uses
- "Tools/string_syntax.ML"
+ ("Tools/string_syntax.ML")
("Tools/string_code.ML")
begin
@@ -78,7 +78,8 @@
syntax
"_String" :: "xstr => string" ("_")
-setup StringSyntax.setup
+use "Tools/string_syntax.ML"
+setup String_Syntax.setup
definition chars :: string where
"chars = [Char Nibble0 Nibble0, Char Nibble0 Nibble1, Char Nibble0 Nibble2,
--- a/src/HOL/SupInf.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/SupInf.thy Fri Feb 19 15:21:57 2010 +0000
@@ -6,38 +6,6 @@
imports RComplete
begin
-lemma minus_max_eq_min:
- fixes x :: "'a::{lordered_ab_group_add, linorder}"
- shows "- (max x y) = min (-x) (-y)"
-by (metis le_imp_neg_le linorder_linear min_max.inf_absorb2 min_max.le_iff_inf min_max.le_iff_sup min_max.sup_absorb1)
-
-lemma minus_min_eq_max:
- fixes x :: "'a::{lordered_ab_group_add, linorder}"
- shows "- (min x y) = max (-x) (-y)"
-by (metis minus_max_eq_min minus_minus)
-
-lemma minus_Max_eq_Min [simp]:
- fixes S :: "'a::{lordered_ab_group_add, linorder} set"
- shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - (Max S) = Min (uminus ` S)"
-proof (induct S rule: finite_ne_induct)
- case (singleton x)
- thus ?case by simp
-next
- case (insert x S)
- thus ?case by (simp add: minus_max_eq_min)
-qed
-
-lemma minus_Min_eq_Max [simp]:
- fixes S :: "'a::{lordered_ab_group_add, linorder} set"
- shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - (Min S) = Max (uminus ` S)"
-proof (induct S rule: finite_ne_induct)
- case (singleton x)
- thus ?case by simp
-next
- case (insert x S)
- thus ?case by (simp add: minus_min_eq_max)
-qed
-
instantiation real :: Sup
begin
definition
@@ -281,7 +249,7 @@
and z: "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
shows "z \<le> Inf X"
proof -
- have "Sup (uminus ` X) \<le> -z" using x z by (force intro: Sup_least)
+ have "Sup (uminus ` X) \<le> -z" using x z by force
hence "z \<le> - Sup (uminus ` X)"
by simp
thus ?thesis
@@ -338,7 +306,7 @@
case True
thus ?thesis
by (simp add: min_def)
- (blast intro: Inf_eq_minimum Inf_lower real_le_refl real_le_trans z)
+ (blast intro: Inf_eq_minimum real_le_refl real_le_trans z)
next
case False
hence 1:"Inf X < a" by simp
@@ -473,7 +441,7 @@
proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x & x < d --> P x}"], auto)
show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
by (rule SupInf.Sup_upper [where z=b], auto)
- (metis prems real_le_linear real_less_def)
+ (metis `a < b` `\<not> P b` real_le_linear real_less_def)
next
show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
apply (rule SupInf.Sup_least)
--- a/src/HOL/TLA/Action.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/Action.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,8 +1,6 @@
-(*
- File: TLA/Action.thy
- ID: $Id$
- Author: Stephan Merz
- Copyright: 1998 University of Munich
+(* Title: HOL/TLA/Action.thy
+ Author: Stephan Merz
+ Copyright: 1998 University of Munich
*)
header {* The action level of TLA as an Isabelle theory *}
@@ -50,13 +48,13 @@
translations
"ACT A" => "(A::state*state => _)"
- "_before" == "before"
- "_after" == "after"
+ "_before" == "CONST before"
+ "_after" == "CONST after"
"_prime" => "_after"
- "_unchanged" == "unch"
- "_SqAct" == "SqAct"
- "_AnAct" == "AnAct"
- "_Enabled" == "enabled"
+ "_unchanged" == "CONST unch"
+ "_SqAct" == "CONST SqAct"
+ "_AnAct" == "CONST AnAct"
+ "_Enabled" == "CONST enabled"
"w |= [A]_v" <= "_SqAct A v w"
"w |= <A>_v" <= "_AnAct A v w"
"s |= Enabled A" <= "_Enabled A s"
--- a/src/HOL/TLA/Init.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/Init.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,11 +1,10 @@
-(*
- File: TLA/Init.thy
- ID: $Id$
- Author: Stephan Merz
- Copyright: 1998 University of Munich
+(* Title: HOL/TLA/Init.thy
+ Author: Stephan Merz
+ Copyright: 1998 University of Munich
-Introduces type of temporal formulas. Defines interface between
-temporal formulas and its "subformulas" (state predicates and actions).
+Introduces type of temporal formulas. Defines interface between
+temporal formulas and its "subformulas" (state predicates and
+actions).
*)
theory Init
@@ -26,12 +25,12 @@
st2 :: "behavior => state"
syntax
- TEMP :: "lift => 'a" ("(TEMP _)")
+ "_TEMP" :: "lift => 'a" ("(TEMP _)")
"_Init" :: "lift => lift" ("(Init _)"[40] 50)
translations
"TEMP F" => "(F::behavior => _)"
- "_Init" == "Initial"
+ "_Init" == "CONST Initial"
"sigma |= Init F" <= "_Init F sigma"
defs
--- a/src/HOL/TLA/Intensional.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/Intensional.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,8 +1,6 @@
-(*
- File: TLA/Intensional.thy
- ID: $Id$
- Author: Stephan Merz
- Copyright: 1998 University of Munich
+(* Title: HOL/TLA/Intensional.thy
+ Author: Stephan Merz
+ Copyright: 1998 University of Munich
*)
header {* A framework for "intensional" (possible-world based) logics
@@ -95,11 +93,11 @@
"_REx1" :: "[idts, lift] => lift" ("(3EX! _./ _)" [0, 10] 10)
translations
- "_const" == "const"
- "_lift" == "lift"
- "_lift2" == "lift2"
- "_lift3" == "lift3"
- "_Valid" == "Valid"
+ "_const" == "CONST const"
+ "_lift" == "CONST lift"
+ "_lift2" == "CONST lift2"
+ "_lift3" == "CONST lift3"
+ "_Valid" == "CONST Valid"
"_RAll x A" == "Rall x. A"
"_REx x A" == "Rex x. A"
"_REx1 x A" == "Rex! x. A"
@@ -112,11 +110,11 @@
"_liftEqu" == "_lift2 (op =)"
"_liftNeq u v" == "_liftNot (_liftEqu u v)"
- "_liftNot" == "_lift Not"
+ "_liftNot" == "_lift (CONST Not)"
"_liftAnd" == "_lift2 (op &)"
"_liftOr" == "_lift2 (op | )"
"_liftImp" == "_lift2 (op -->)"
- "_liftIf" == "_lift3 If"
+ "_liftIf" == "_lift3 (CONST If)"
"_liftPlus" == "_lift2 (op +)"
"_liftMinus" == "_lift2 (op -)"
"_liftTimes" == "_lift2 (op *)"
@@ -126,12 +124,12 @@
"_liftLeq" == "_lift2 (op <=)"
"_liftMem" == "_lift2 (op :)"
"_liftNotMem x xs" == "_liftNot (_liftMem x xs)"
- "_liftFinset (_liftargs x xs)" == "_lift2 CONST insert x (_liftFinset xs)"
- "_liftFinset x" == "_lift2 CONST insert x (_const {})"
+ "_liftFinset (_liftargs x xs)" == "_lift2 (CONST insert) x (_liftFinset xs)"
+ "_liftFinset x" == "_lift2 (CONST insert) x (_const {})"
"_liftPair x (_liftargs y z)" == "_liftPair x (_liftPair y z)"
- "_liftPair" == "_lift2 Pair"
- "_liftCons" == "lift2 Cons"
- "_liftApp" == "lift2 (op @)"
+ "_liftPair" == "_lift2 (CONST Pair)"
+ "_liftCons" == "CONST lift2 (CONST Cons)"
+ "_liftApp" == "CONST lift2 (op @)"
"_liftList (_liftargs x xs)" == "_liftCons x (_liftList xs)"
"_liftList x" == "_liftCons x (_const [])"
--- a/src/HOL/TLA/Memory/ProcedureInterface.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/Memory/ProcedureInterface.thy Fri Feb 19 15:21:57 2010 +0000
@@ -55,10 +55,10 @@
"_Return" :: "['a, 'b, lift] => lift" ("(Return _ _ _)" [90,90,90] 90)
translations
- "_slice" == "slice"
+ "_slice" == "CONST slice"
- "_Call" == "ACall"
- "_Return" == "AReturn"
+ "_Call" == "CONST ACall"
+ "_Return" == "CONST AReturn"
defs
slice_def: "(PRED (x!i)) s == x s i"
--- a/src/HOL/TLA/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,3 @@
-(* Title: HOL/TLA/ROOT.ML
-
-Adds the Temporal Logic of Actions to a database containing Isabelle/HOL.
-*)
+(* The Temporal Logic of Actions *)
use_thys ["TLA"];
-
--- a/src/HOL/TLA/Stfun.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/Stfun.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,8 +1,6 @@
-(*
- File: TLA/Stfun.thy
- ID: $Id$
- Author: Stephan Merz
- Copyright: 1998 University of Munich
+(* Title: HOL/TLA/Stfun.thy
+ Author: Stephan Merz
+ Copyright: 1998 University of Munich
*)
header {* States and state functions for TLA as an "intensional" logic *}
@@ -42,7 +40,7 @@
translations
"PRED P" => "(P::state => _)"
- "_stvars" == "stvars"
+ "_stvars" == "CONST stvars"
defs
(* Base variables may be assigned arbitrary (type-correct) values.
--- a/src/HOL/TLA/TLA.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/TLA/TLA.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,8 +1,6 @@
-(*
- File: TLA/TLA.thy
- ID: $Id$
- Author: Stephan Merz
- Copyright: 1998 University of Munich
+(* Title: HOL/TLA/TLA.thy
+ Author: Stephan Merz
+ Copyright: 1998 University of Munich
*)
header {* The temporal level of TLA *}
@@ -37,12 +35,12 @@
"_AAll" :: "[idts, lift] => lift" ("(3AALL _./ _)" [0,10] 10)
translations
- "_Box" == "Box"
- "_Dmd" == "Dmd"
- "_leadsto" == "leadsto"
- "_stable" == "Stable"
- "_WF" == "WF"
- "_SF" == "SF"
+ "_Box" == "CONST Box"
+ "_Dmd" == "CONST Dmd"
+ "_leadsto" == "CONST leadsto"
+ "_stable" == "CONST Stable"
+ "_WF" == "CONST WF"
+ "_SF" == "CONST SF"
"_EEx v A" == "Eex v. A"
"_AAll v A" == "Aall v. A"
@@ -1168,4 +1166,3 @@
done
end
-
--- a/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Fri Feb 19 15:21:57 2010 +0000
@@ -168,7 +168,7 @@
fun run_on probfile =
if File.exists cmd then
write probfile clauses
- |> pair (apfst split_time' (system_out (cmd_line probfile)))
+ |> pair (apfst split_time' (bash_output (cmd_line probfile)))
else error ("Bad executable: " ^ Path.implode cmd);
(* if problemfile has not been exported, delete problemfile; otherwise export proof, too *)
@@ -306,7 +306,7 @@
fun get_systems () =
let
- val (answer, rc) = system_out ("\"$ISABELLE_ATP_MANAGER/SystemOnTPTP\" -w")
+ val (answer, rc) = bash_output ("\"$ISABELLE_ATP_MANAGER/SystemOnTPTP\" -w")
in
if rc <> 0 then error ("Failed to get available systems from SystemOnTPTP:\n" ^ answer)
else split_lines answer
--- a/src/HOL/Tools/Datatype/datatype.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Datatype/datatype.ML Fri Feb 19 15:21:57 2010 +0000
@@ -253,9 +253,11 @@
val rep_const = cterm_of thy
(Const (Sign.intern_const thy ("Rep_" ^ tname), T --> Univ_elT));
val cong' =
- Drule.standard (cterm_instantiate [(cterm_of thy cong_f, rep_const)] arg_cong);
+ Drule.export_without_context
+ (cterm_instantiate [(cterm_of thy cong_f, rep_const)] arg_cong);
val dist =
- Drule.standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
+ Drule.export_without_context
+ (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
val (thy', defs', eqns', _) = fold ((make_constr_def tname T) (length constrs))
(constrs ~~ constr_syntax) (Sign.add_path tname thy, defs, [], 1);
in
@@ -532,7 +534,7 @@
let
val dist_thm = Skip_Proof.prove_global thy5 [] [] t (fn _ =>
EVERY [simp_tac (HOL_ss addsimps dist_rewrites') 1])
- in dist_thm :: Drule.standard (dist_thm RS not_sym) :: prove ts end;
+ in dist_thm :: Drule.export_without_context (dist_thm RS not_sym) :: prove ts end;
in prove ts end;
val distinct_thms = map2 (prove_distinct_thms)
@@ -649,7 +651,7 @@
val (tyvars, _, _, _)::_ = dts;
val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
- let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
+ let val full_tname = Sign.full_name tmp_thy tname
in
(case duplicates (op =) tvs of
[] =>
@@ -673,10 +675,10 @@
val _ =
(case subtract (op =) tvs (fold (curry OldTerm.add_typ_tfree_names) cargs' []) of
[] => ()
- | vs => error ("Extra type variables on rhs: " ^ commas vs))
- in (constrs @ [(Sign.full_name_path tmp_thy tname'
- (Binding.map_name (Syntax.const_name mx') cname),
- map (dtyp_of_typ new_dts) cargs')],
+ | vs => error ("Extra type variables on rhs: " ^ commas vs));
+ val c = Sign.full_name_path tmp_thy tname' cname;
+ in
+ (constrs @ [(c, map (dtyp_of_typ new_dts) cargs')],
constr_syntax' @ [(cname, mx')], sorts'')
end handle ERROR msg => cat_error msg
("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
@@ -684,14 +686,12 @@
val (constrs', constr_syntax', sorts') =
fold prep_constr constrs ([], [], sorts)
-
in
case duplicates (op =) (map fst constrs') of
- [] =>
- (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
- map DtTFree tvs, constrs'))],
+ [] =>
+ (dts' @ [(i, (Sign.full_name tmp_thy tname, map DtTFree tvs, constrs'))],
constr_syntax @ [constr_syntax'], sorts', i + 1)
- | dups => error ("Duplicate constructors " ^ commas dups ^
+ | dups => error ("Duplicate constructors " ^ commas dups ^
" in datatype " ^ quote (Binding.str_of tname))
end;
--- a/src/HOL/Tools/Datatype/datatype_case.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Datatype/datatype_case.ML Fri Feb 19 15:21:57 2010 +0000
@@ -42,7 +42,7 @@
let
val (_, (tname, dts, constrs)) = nth descr index;
val mk_ty = Datatype_Aux.typ_of_dtyp descr sorts;
- val T = Type (tname, map mk_ty dts)
+ val T = Type (tname, map mk_ty dts);
in
SOME {case_name = case_name,
constructors = map (fn (cname, dts') =>
@@ -70,12 +70,13 @@
fun default_names names ts =
map (fn ("", Free (name', _)) => name' | (name, _) => name) (names ~~ ts);
-fun strip_constraints (Const ("_constrain", _) $ t $ tT) =
+fun strip_constraints (Const (@{syntax_const "_constrain"}, _) $ t $ tT) =
strip_constraints t ||> cons tT
| strip_constraints t = (t, []);
-fun mk_fun_constrain tT t = Syntax.const "_constrain" $ t $
- (Syntax.free "fun" $ tT $ Syntax.free "dummy");
+fun mk_fun_constrain tT t =
+ Syntax.const @{syntax_const "_constrain"} $ t $
+ (Syntax.free "fun" $ tT $ Syntax.free "dummy"); (* FIXME @{type_syntax} (!?) *)
(*---------------------------------------------------------------------------
@@ -145,7 +146,7 @@
(replicate (length rstp) "x")
in
[((prfx, gvars @ map Free (xs ~~ Ts)),
- (Const ("HOL.undefined", res_ty), (~1, false)))]
+ (Const (@{const_syntax undefined}, res_ty), (~1, false)))]
end
else in_group
in
@@ -265,12 +266,13 @@
fun gen_make_case ty_match ty_inst type_of tab ctxt config used x clauses =
let
- fun string_of_clause (pat, rhs) = Syntax.string_of_term ctxt
- (Syntax.const "_case1" $ pat $ rhs);
+ fun string_of_clause (pat, rhs) =
+ Syntax.string_of_term ctxt (Syntax.const @{syntax_const "_case1"} $ pat $ rhs);
val _ = map (no_repeat_vars ctxt o fst) clauses;
val rows = map_index (fn (i, (pat, rhs)) =>
(([], [pat]), (rhs, (i, true)))) clauses;
- val rangeT = (case distinct op = (map (type_of o snd) clauses) of
+ val rangeT =
+ (case distinct op = (map (type_of o snd) clauses) of
[] => case_error "no clauses given"
| [T] => T
| _ => case_error "all cases must have the same result type");
@@ -283,14 +285,16 @@
val patts1 = map
(fn (_, tag, [pat]) => (pat, tag)
| _ => case_error "error in pattern-match translation") patts;
- val patts2 = Library.sort (Library.int_ord o Library.pairself row_of_pat) patts1
+ val patts2 = Library.sort (int_ord o pairself row_of_pat) patts1
val finals = map row_of_pat patts2
val originals = map (row_of_pat o #2) rows
- val _ = case subtract (op =) finals originals of
- [] => ()
- | is => (case config of Error => case_error | Warning => warning | Quiet => fn _ => {})
- ("The following clauses are redundant (covered by preceding clauses):\n" ^
- cat_lines (map (string_of_clause o nth clauses) is));
+ val _ =
+ case subtract (op =) finals originals of
+ [] => ()
+ | is =>
+ (case config of Error => case_error | Warning => warning | Quiet => fn _ => {})
+ ("The following clauses are redundant (covered by preceding clauses):\n" ^
+ cat_lines (map (string_of_clause o nth clauses) is));
in
(case_tm, patts2)
end;
@@ -308,10 +312,10 @@
val thy = ProofContext.theory_of ctxt;
(* replace occurrences of dummy_pattern by distinct variables *)
(* internalize constant names *)
- fun prep_pat ((c as Const ("_constrain", _)) $ t $ tT) used =
+ fun prep_pat ((c as Const (@{syntax_const "_constrain"}, _)) $ t $ tT) used =
let val (t', used') = prep_pat t used
in (c $ t' $ tT, used') end
- | prep_pat (Const ("dummy_pattern", T)) used =
+ | prep_pat (Const (@{const_syntax dummy_pattern}, T)) used =
let val x = Name.variant used "x"
in (Free (x, T), x :: used) end
| prep_pat (Const (s, T)) used =
@@ -333,17 +337,17 @@
(t' $ u', used'')
end
| prep_pat t used = case_error ("Bad pattern: " ^ Syntax.string_of_term ctxt t);
- fun dest_case1 (t as Const ("_case1", _) $ l $ r) =
+ fun dest_case1 (t as Const (@{syntax_const "_case1"}, _) $ l $ r) =
let val (l', cnstrts) = strip_constraints l
in ((fst (prep_pat l' (Term.add_free_names t [])), r), cnstrts)
end
| dest_case1 t = case_error "dest_case1";
- fun dest_case2 (Const ("_case2", _) $ t $ u) = t :: dest_case2 u
+ fun dest_case2 (Const (@{syntax_const "_case2"}, _) $ t $ u) = t :: dest_case2 u
| dest_case2 t = [t];
val (cases, cnstrts) = split_list (map dest_case1 (dest_case2 u));
val (case_tm, _) = make_case_untyped (tab_of thy) ctxt
(if err then Error else Warning) []
- (fold (fn tT => fn t => Syntax.const "_constrain" $ t $ tT)
+ (fold (fn tT => fn t => Syntax.const @{syntax_const "_constrain"} $ t $ tT)
(flat cnstrts) t) cases;
in case_tm end
| case_tr _ _ _ ts = case_error "case_tr";
@@ -377,7 +381,7 @@
fun count_cases (_, _, true) = I
| count_cases (c, (_, body), false) =
AList.map_default op aconv (body, []) (cons c);
- val is_undefined = name_of #> equal (SOME "HOL.undefined");
+ val is_undefined = name_of #> equal (SOME @{const_syntax undefined});
fun mk_case (c, (xs, body), _) = (list_comb (c, xs), body)
in case ty_info tab cname of
SOME {constructors, case_name} =>
@@ -394,7 +398,8 @@
val cases' = sort (int_ord o swap o pairself (length o snd))
(fold_rev count_cases cases []);
val R = type_of t;
- val dummy = if d then Const ("dummy_pattern", R)
+ val dummy =
+ if d then Const (@{const_syntax dummy_pattern}, R)
else Free (Name.variant used "x", R)
in
SOME (x, map mk_case (case find_first (is_undefined o fst) cases' of
@@ -435,7 +440,8 @@
else [(pat, rhs)]
| _ => [(pat, rhs)];
-fun gen_strip_case dest t = case dest [] t of
+fun gen_strip_case dest t =
+ case dest [] t of
SOME (x, clauses) =>
SOME (x, maps (strip_case'' dest) clauses)
| NONE => NONE;
@@ -453,7 +459,7 @@
fun mk_clause (pat, rhs) =
let val xs = Term.add_frees pat []
in
- Syntax.const "_case1" $
+ Syntax.const @{syntax_const "_case1"} $
map_aterms
(fn Free p => Syntax.mark_boundT p
| Const (s, _) => Const (Consts.extern_early consts s, dummyT)
@@ -463,10 +469,12 @@
if member (op =) xs (s, T) then Syntax.mark_bound s else x
| t => t) rhs
end
- in case strip_case' (tab_of thy) true (list_comb (Syntax.const cname, ts)) of
- SOME (x, clauses) => Syntax.const "_case_syntax" $ x $
- foldr1 (fn (t, u) => Syntax.const "_case2" $ t $ u)
- (map mk_clause clauses)
+ in
+ case strip_case' (tab_of thy) true (list_comb (Syntax.const cname, ts)) of
+ SOME (x, clauses) =>
+ Syntax.const @{syntax_const "_case_syntax"} $ x $
+ foldr1 (fn (t, u) => Syntax.const @{syntax_const "_case2"} $ t $ u)
+ (map mk_clause clauses)
| NONE => raise Match
end;
--- a/src/HOL/Tools/Datatype/datatype_data.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Datatype/datatype_data.ML Fri Feb 19 15:21:57 2010 +0000
@@ -229,7 +229,7 @@
val trfun_setup =
Sign.add_advanced_trfuns ([],
- [("_case_syntax", Datatype_Case.case_tr true info_of_constr)],
+ [(@{syntax_const "_case_syntax"}, Datatype_Case.case_tr true info_of_constr)],
[], []);
--- a/src/HOL/Tools/Function/lexicographic_order.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Function/lexicographic_order.ML Fri Feb 19 15:21:57 2010 +0000
@@ -80,10 +80,10 @@
let
val goals = cterm_of thy o mk_goal (vars, prems, mfun $ lhs, mfun $ rhs)
in
- case try_proof (goals @{const_name Algebras.less}) solve_tac of
+ case try_proof (goals @{const_name Orderings.less}) solve_tac of
Solved thm => Less thm
| Stuck thm =>
- (case try_proof (goals @{const_name Algebras.less_eq}) solve_tac of
+ (case try_proof (goals @{const_name Orderings.less_eq}) solve_tac of
Solved thm2 => LessEq (thm2, thm)
| Stuck thm2 =>
if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const] then False thm2
--- a/src/HOL/Tools/Function/size.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Function/size.ML Fri Feb 19 15:21:57 2010 +0000
@@ -153,7 +153,7 @@
val ctxt = ProofContext.init thy';
- val simpset1 = HOL_basic_ss addsimps @{thm add_0} :: @{thm add_0_right} ::
+ val simpset1 = HOL_basic_ss addsimps @{thm Nat.add_0} :: @{thm Nat.add_0_right} ::
size_def_thms @ size_def_thms' @ rec_rewrites @ extra_rewrites;
val xs = map (fn i => "x" ^ string_of_int i) (1 upto length recTs2);
@@ -197,7 +197,7 @@
fun prove_size_eqs p size_fns size_ofp simpset =
maps (fn (((_, (_, _, constrs)), size_const), T) =>
- map (fn constr => Drule.standard (Skip_Proof.prove ctxt [] []
+ map (fn constr => Drule.export_without_context (Skip_Proof.prove ctxt [] []
(gen_mk_size_eq p (AList.lookup op = (new_type_names ~~ size_fns))
size_ofp size_const T constr)
(fn _ => simp_tac simpset 1))) constrs)
--- a/src/HOL/Tools/Function/termination.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Function/termination.ML Fri Feb 19 15:21:57 2010 +0000
@@ -203,10 +203,10 @@
HOLogic.mk_Trueprop (Const (rel, @{typ "nat => nat => bool"})
$ (m2 $ r) $ (m1 $ l)))))) tac
in
- case try @{const_name Algebras.less} of
+ case try @{const_name Orderings.less} of
Solved thm => Less thm
| Stuck thm =>
- (case try @{const_name Algebras.less_eq} of
+ (case try @{const_name Orderings.less_eq} of
Solved thm2 => LessEq (thm2, thm)
| Stuck thm2 =>
if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const]
--- a/src/HOL/Tools/Groebner_Basis/normalizer.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Groebner_Basis/normalizer.ML Fri Feb 19 15:21:57 2010 +0000
@@ -60,7 +60,7 @@
(Simplifier.rewrite
(HOL_basic_ss
addsimps @{thms arith_simps} @ natarith @ @{thms rel_simps}
- @ [if_False, if_True, @{thm add_0}, @{thm add_Suc},
+ @ [if_False, if_True, @{thm Nat.add_0}, @{thm add_Suc},
@{thm add_number_of_left}, @{thm Suc_eq_plus1}]
@ map (fn th => th RS sym) @{thms numerals}));
@@ -634,7 +634,7 @@
val nat_arith = @{thms "nat_arith"};
val nat_exp_ss = HOL_basic_ss addsimps (@{thms nat_number} @ nat_arith @ @{thms arith_simps} @ @{thms rel_simps})
- addsimps [Let_def, if_False, if_True, @{thm add_0}, @{thm add_Suc}];
+ addsimps [Let_def, if_False, if_True, @{thm Nat.add_0}, @{thm add_Suc}];
fun simple_cterm_ord t u = TermOrd.term_ord (term_of t, term_of u) = LESS;
--- a/src/HOL/Tools/Nitpick/HISTORY Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/HISTORY Fri Feb 19 15:21:57 2010 +0000
@@ -4,6 +4,8 @@
* Added "std" option and implemented support for nonstandard models
* Fixed soundness bugs related to "destroy_constrs" optimization and record
getters
+ * Renamed "MiniSatJNI", "zChaffJNI", "BerkMinAlloy", and "SAT4JLight" to
+ "MiniSat_JNI", "zChaff_JNI", "BerkMin_Alloy", and "SAT4J_Light"
Version 2009-1
--- a/src/HOL/Tools/Nitpick/kodkod.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/kodkod.ML Fri Feb 19 15:21:57 2010 +0000
@@ -167,6 +167,7 @@
val max_arity : int -> int
val arity_of_rel_expr : rel_expr -> int
+ val is_problem_trivially_false : problem -> bool
val problems_equivalent : problem -> problem -> bool
val solve_any_problem :
bool -> Time.time option -> int -> int -> problem list -> outcome
@@ -491,6 +492,10 @@
| arity_of_decl (DeclSome ((n, _), _)) = n
| arity_of_decl (DeclSet ((n, _), _)) = n
+(* problem -> bool *)
+fun is_problem_trivially_false ({formula = False, ...} : problem) = true
+ | is_problem_trivially_false _ = false
+
(* string -> bool *)
val is_relevant_setting = not o member (op =) ["solver", "delay"]
@@ -1004,7 +1009,7 @@
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. *)
+ is partly due to the JVM and partly due to the ML "bash" function. *)
val fudge_ms = 250
(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
@@ -1014,8 +1019,8 @@
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)
+ filter_out (is_problem_trivially_false 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 *)
@@ -1053,24 +1058,24 @@
val outcome =
let
val code =
- system ("cd " ^ temp_dir ^ ";\n" ^
- "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
- \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
- \$JAVA_LIBRARY_PATH\" \
- \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
- \$LD_LIBRARY_PATH\" \
- \\"$KODKODI\"/bin/kodkodi" ^
- (if ms >= 0 then " -max-msecs " ^ string_of_int ms
- else "") ^
- (if max_solutions > 1 then " -solve-all" else "") ^
- " -max-solutions " ^ string_of_int max_solutions ^
- (if max_threads > 0 then
- " -max-threads " ^ string_of_int max_threads
- else
- "") ^
- " < " ^ Path.implode in_path ^
- " > " ^ Path.implode out_path ^
- " 2> " ^ Path.implode err_path)
+ bash ("cd " ^ File.shell_quote temp_dir ^ ";\n" ^
+ "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
+ \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
+ \$JAVA_LIBRARY_PATH\" \
+ \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
+ \$LD_LIBRARY_PATH\" \
+ \\"$KODKODI\"/bin/kodkodi" ^
+ (if ms >= 0 then " -max-msecs " ^ string_of_int ms
+ else "") ^
+ (if max_solutions > 1 then " -solve-all" else "") ^
+ " -max-solutions " ^ string_of_int max_solutions ^
+ (if max_threads > 0 then
+ " -max-threads " ^ string_of_int max_threads
+ else
+ "") ^
+ " < " ^ File.shell_path in_path ^
+ " > " ^ File.shell_path out_path ^
+ " 2> " ^ File.shell_path err_path)
val (ps, nontriv_js) = read_output_file out_path
|>> map (apfst reindex) ||> map reindex
val js = triv_js @ nontriv_js
--- a/src/HOL/Tools/Nitpick/kodkod_sat.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML Fri Feb 19 15:21:57 2010 +0000
@@ -9,7 +9,7 @@
sig
val configured_sat_solvers : bool -> string list
val smart_sat_solver_name : bool -> string
- val sat_solver_spec : bool -> string -> string * string list
+ val sat_solver_spec : string -> string * string list
end;
structure Kodkod_SAT : KODKOD_SAT =
@@ -42,24 +42,24 @@
if berkmin_exec = "" then "BerkMin561"
else berkmin_exec, [], "Satisfiable !!",
"solution =", "UNSATISFIABLE !!")),
- ("BerkMinAlloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
+ ("BerkMin_Alloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
("Jerusat", External (ToStdout, "JERUSAT_HOME", "Jerusat1.3", [])),
- ("MiniSatJNI", Internal (JNI, Incremental, ["MiniSat"])),
- ("zChaffJNI", Internal (JNI, Batch, ["zChaff"])),
+ ("MiniSat_JNI", Internal (JNI, Incremental, ["MiniSat"])),
+ ("zChaff_JNI", Internal (JNI, Batch, ["zChaff"])),
("SAT4J", Internal (Java, Incremental, ["DefaultSAT4J"])),
- ("SAT4JLight", Internal (Java, Incremental, ["LightSAT4J"])),
+ ("SAT4J_Light", Internal (Java, Incremental, ["LightSAT4J"])),
("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
"s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
-(* bool -> string -> sink -> string -> string -> string list -> string list
+(* string -> sink -> string -> string -> string list -> string list
-> (string * (unit -> string list)) option *)
-fun dynamic_entry_for_external overlord name dev home exec args markers =
+fun dynamic_entry_for_external name dev home exec args markers =
case getenv home of
"" => NONE
| dir =>
SOME (name, fn () =>
let
- val serial_str = if overlord then "" else serial_string ()
+ val serial_str = serial_string ()
val base = name ^ serial_str
val out_file = base ^ ".out"
val dir_sep =
@@ -76,9 +76,9 @@
end)
(* bool -> bool -> string * sat_solver_info
-> (string * (unit -> string list)) option *)
-fun dynamic_entry_for_info _ incremental (name, Internal (Java, mode, ss)) =
+fun dynamic_entry_for_info incremental (name, Internal (Java, mode, ss)) =
if incremental andalso mode = Batch then NONE else SOME (name, K ss)
- | dynamic_entry_for_info _ incremental (name, Internal (JNI, mode, ss)) =
+ | dynamic_entry_for_info incremental (name, Internal (JNI, mode, ss)) =
if incremental andalso mode = Batch then
NONE
else
@@ -92,26 +92,25 @@
else
NONE
end
- | dynamic_entry_for_info overlord false
- (name, External (dev, home, exec, args)) =
- dynamic_entry_for_external overlord name dev home exec args []
- | dynamic_entry_for_info overlord false
+ | 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 overlord name dev home exec args [m1, m2, m3]
- | dynamic_entry_for_info _ true _ = NONE
-(* bool -> bool -> (string * (unit -> string list)) list *)
-fun dynamic_list overlord incremental =
- map_filter (dynamic_entry_for_info overlord incremental) static_list
+ dynamic_entry_for_external name dev home exec args [m1, m2, m3]
+ | 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 false
+val configured_sat_solvers = map fst o dynamic_list
(* bool -> string *)
-val smart_sat_solver_name = fst o hd o dynamic_list false
+val smart_sat_solver_name = fst o hd o dynamic_list
-(* bool -> string -> string * string list *)
-fun sat_solver_spec overlord name =
+(* string -> string * string list *)
+fun sat_solver_spec name =
let
- val dyn_list = dynamic_list overlord false
+ val dyn_list = dynamic_list false
(* (string * 'a) list -> string *)
fun enum_solvers solvers =
commas (distinct (op =) (map (quote o fst) solvers))
--- a/src/HOL/Tools/Nitpick/minipick.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/minipick.ML Fri Feb 19 15:21:57 2010 +0000
@@ -84,7 +84,7 @@
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 card frees =
+fun kodkod_formula_from_term ctxt card frees =
let
(* typ -> rel_expr -> rel_expr *)
fun R_rep_from_S_rep (T as Type ("fun", [T1, @{typ bool}])) r =
@@ -145,7 +145,7 @@
| Term.Var _ => raise SAME ()
| Bound _ => raise SAME ()
| Const (s, _) => raise NOT_SUPPORTED ("constant " ^ quote s)
- | _ => raise TERM ("Minipick.kodkod_formula_for_term.to_F", [t]))
+ | _ => raise TERM ("Minipick.kodkod_formula_from_term.to_F", [t]))
handle SAME () => formula_from_atom (to_R_rep Ts t)
(* typ list -> term -> rel_expr *)
and to_S_rep Ts t =
@@ -200,19 +200,19 @@
else
raise NOT_SUPPORTED "transitive closure for function or pair type"
| Const (@{const_name trancl}, _) => to_R_rep Ts (eta_expand Ts t 1)
- | Const (@{const_name lower_semilattice_class.inf},
+ | Const (@{const_name semilattice_inf_class.inf},
Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
Intersect (to_R_rep Ts t1, to_R_rep Ts t2)
- | Const (@{const_name lower_semilattice_class.inf}, _) $ _ =>
+ | Const (@{const_name semilattice_inf_class.inf}, _) $ _ =>
to_R_rep Ts (eta_expand Ts t 1)
- | Const (@{const_name lower_semilattice_class.inf}, _) =>
+ | Const (@{const_name semilattice_inf_class.inf}, _) =>
to_R_rep Ts (eta_expand Ts t 2)
- | Const (@{const_name upper_semilattice_class.sup},
+ | Const (@{const_name semilattice_sup_class.sup},
Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
Union (to_R_rep Ts t1, to_R_rep Ts t2)
- | Const (@{const_name upper_semilattice_class.sup}, _) $ _ =>
+ | Const (@{const_name semilattice_sup_class.sup}, _) $ _ =>
to_R_rep Ts (eta_expand Ts t 1)
- | Const (@{const_name upper_semilattice_class.sup}, _) =>
+ | Const (@{const_name semilattice_sup_class.sup}, _) =>
to_R_rep Ts (eta_expand Ts t 2)
| Const (@{const_name minus_class.minus},
Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
@@ -306,7 +306,7 @@
val bounds = map2 (bound_for_free card) (index_seq 0 (length frees)) frees
val declarative_axioms =
map2 (declarative_axiom_for_free card) (index_seq 0 (length frees)) frees
- val formula = kodkod_formula_for_term ctxt card frees neg_t
+ val formula = kodkod_formula_from_term ctxt card frees neg_t
|> fold_rev (curry And) declarative_axioms
val univ_card = univ_card 0 0 0 bounds formula
val problem =
--- a/src/HOL/Tools/Nitpick/nitpick.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick.ML Fri Feb 19 15:21:57 2010 +0000
@@ -69,6 +69,7 @@
open Nitpick_Util
open Nitpick_HOL
+open Nitpick_Preproc
open Nitpick_Mono
open Nitpick_Scope
open Nitpick_Peephole
@@ -129,7 +130,7 @@
sel_names: nut list,
nonsel_names: nut list,
rel_table: nut NameTable.table,
- liberal: bool,
+ unsound: bool,
scope: scope,
core: KK.formula,
defs: KK.formula list}
@@ -156,15 +157,15 @@
(Path.variable "ISABELLE_HOME_USER" ::
map Path.basic ["etc", "components"]))) ^ "\"."
-val max_liberal_delay_ms = 200
-val max_liberal_delay_percent = 2
+val max_unsound_delay_ms = 200
+val max_unsound_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,
+fun unsound_delay_for_timeout NONE = max_unsound_delay_ms
+ | unsound_delay_for_timeout (SOME timeout) =
+ Int.max (0, Int.min (max_unsound_delay_ms,
Time.toMilliseconds timeout
- * max_liberal_delay_percent div 100))
+ * max_unsound_delay_percent div 100))
(* Time.time option -> bool *)
fun passed_deadline NONE = false
@@ -246,7 +247,7 @@
(if i <> 1 orelse n <> 1 then
"subgoal " ^ string_of_int i ^ " of " ^ string_of_int n
else
- "goal")) [orig_t]))
+ "goal")) [Logic.list_implies (orig_assm_ts, orig_t)]))
val neg_t = if falsify then Logic.mk_implies (orig_t, @{prop False})
else orig_t
val assms_t = if assms orelse auto then
@@ -264,7 +265,7 @@
orig_assm_ts
*)
val max_bisim_depth = fold Integer.max bisim_depths ~1
- val case_names = case_const_names thy
+ val case_names = case_const_names thy stds
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)
@@ -273,7 +274,7 @@
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 {wf_cache, ...}) =
+ val (hol_ctxt as {wf_cache, ...}) =
{thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
binary_ints = binary_ints, destroy_constrs = destroy_constrs,
@@ -292,7 +293,7 @@
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
+ core_t, binarize) = preprocess_term hol_ctxt assms_t
val got_all_user_axioms =
got_all_mono_user_axioms andalso no_poly_user_axioms
@@ -319,9 +320,9 @@
handle TYPE (_, Ts, ts) =>
raise TYPE ("Nitpick.pick_them_nits_in_term", Ts, ts)
- val core_u = nut_from_term ext_ctxt Eq core_t
- val def_us = map (nut_from_term ext_ctxt DefEq) def_ts
- val nondef_us = map (nut_from_term ext_ctxt Eq) nondef_ts
+ val core_u = nut_from_term hol_ctxt Eq core_t
+ val def_us = map (nut_from_term hol_ctxt DefEq) def_ts
+ val nondef_us = map (nut_from_term hol_ctxt Eq) nondef_ts
val (free_names, const_names) =
fold add_free_and_const_names (core_u :: def_us @ nondef_us) ([], [])
val (sel_names, nonsel_names) =
@@ -336,20 +337,21 @@
val unique_scope = forall (curry (op =) 1 o length o snd) cards_assigns
(* typ -> bool *)
fun is_type_always_monotonic T =
- (is_datatype thy T andalso not (is_quot_type thy T) andalso
+ (is_datatype thy stds T andalso not (is_quot_type thy T) andalso
(not (is_pure_typedef thy T) orelse is_univ_typedef thy T)) orelse
- is_number_type thy T orelse is_bit_type T orelse T = @{typ \<xi>}
+ is_number_type thy T orelse is_bit_type T
fun is_type_monotonic T =
unique_scope orelse
case triple_lookup (type_match thy) monos T of
SOME (SOME b) => b
| _ => is_type_always_monotonic T orelse
- formulas_monotonic ext_ctxt T Plus def_ts nondef_ts core_t
+ formulas_monotonic hol_ctxt binarize T Plus def_ts nondef_ts core_t
fun is_deep_datatype T =
- is_datatype thy T andalso
- (is_word_type T orelse
+ is_datatype thy stds T andalso
+ (not standard orelse T = nat_T orelse is_word_type T orelse
exists (curry (op =) T o domain_type o type_of) sel_names)
- val all_Ts = ground_types_in_terms ext_ctxt (core_t :: def_ts @ nondef_ts)
+ val all_Ts = ground_types_in_terms hol_ctxt binarize
+ (core_t :: def_ts @ nondef_ts)
|> sort TermOrd.typ_ord
val _ = if verbose andalso binary_ints = SOME true andalso
exists (member (op =) [nat_T, int_T]) all_Ts then
@@ -381,29 +383,22 @@
else
()
val deep_dataTs = filter is_deep_datatype all_Ts
- (* FIXME: Implement proper detection of induction datatypes. *)
+ (* This detection code is an ugly hack. Fortunately, it is used only to
+ provide a hint to the user. *)
(* string * (Rule_Cases.T * bool) -> bool *)
- fun is_inductive_case (_, (Rule_Cases.Case {fixes, assumes, ...}, _)) =
- false
-(*
- not (null fixes) andalso exists (String.isSuffix ".hyps" o fst) assumes
-*)
- (* unit -> typ list *)
- val induct_dataTs =
- if exists is_inductive_case (ProofContext.cases_of ctxt) then
- filter (is_datatype thy) all_Ts
- else
- []
- val _ = if standard andalso not (null induct_dataTs) then
+ fun is_struct_induct_step (name, (Rule_Cases.Case {fixes, assumes, ...}, _)) =
+ not (null fixes) andalso
+ exists (String.isSuffix ".hyps" o fst) assumes andalso
+ exists (exists (curry (op =) name o shortest_name o fst)
+ o datatype_constrs hol_ctxt) deep_dataTs
+ val likely_in_struct_induct_step =
+ exists is_struct_induct_step (ProofContext.cases_of ctxt)
+ val _ = if standard andalso likely_in_struct_induct_step then
pprint_m (fn () => Pretty.blk (0,
pstrs "Hint: To check that the induction hypothesis is \
- \general enough, try the following command: " @
+ \general enough, try this command: " @
[Pretty.mark Markup.sendback (Pretty.blk (0,
- pstrs ("nitpick [" ^
- commas (map (prefix "non_std " o maybe_quote
- o unyxml o string_for_type ctxt)
- induct_dataTs) ^
- ", show_consts]")))] @ pstrs "."))
+ pstrs ("nitpick [non_std, show_all]")))] @ pstrs "."))
else
()
(*
@@ -440,7 +435,7 @@
val too_big_scopes = Unsynchronized.ref []
(* bool -> scope -> rich_problem option *)
- fun problem_for_scope liberal
+ fun problem_for_scope unsound
(scope as {card_assigns, bits, bisim_depth, datatypes, ofs, ...}) =
let
val _ = not (exists (fn other => scope_less_eq other scope)
@@ -475,10 +470,10 @@
(univ_card nat_card int_card main_j0 [] KK.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)
+ val core_u = choose_reps_in_nut scope unsound rep_table false core_u
+ val def_us = map (choose_reps_in_nut scope unsound rep_table true)
def_us
- val nondef_us = map (choose_reps_in_nut scope liberal rep_table false)
+ val nondef_us = map (choose_reps_in_nut scope unsound rep_table false)
nondef_us
(*
val _ = List.app (priority o string_for_nut ctxt)
@@ -494,21 +489,19 @@
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 -> KK.formula *)
- val to_f = kodkod_formula_from_nut bits 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 core_f = kodkod_formula_from_nut bits ofs kk core_u
+ val def_fs = map (kodkod_formula_from_nut bits ofs kk) def_us
+ val nondef_fs = map (kodkod_formula_from_nut bits ofs kk) nondef_us
val formula = fold (fold s_and) [def_fs, nondef_fs] core_f
- val comment = (if liberal then "liberal" else "conservative") ^ "\n" ^
+ val comment = (if unsound then "unsound" else "sound") ^ "\n" ^
PrintMode.setmp [] multiline_string_for_scope scope
val kodkod_sat_solver =
- Kodkod_SAT.sat_solver_spec overlord effective_sat_solver |> snd
+ Kodkod_SAT.sat_solver_spec effective_sat_solver |> snd
val bit_width = if bits = 0 then 16 else bits + 1
- val delay = if liberal then
+ val delay = if unsound then
Option.map (fn time => Time.- (time, Time.now ()))
deadline
- |> liberal_delay_for_timeout
+ |> unsound_delay_for_timeout
else
0
val settings = [("solver", commas (map quote kodkod_sat_solver)),
@@ -522,11 +515,13 @@
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 bits ofs kk
- rel_table datatypes
+ val dtype_axioms =
+ declarative_axioms_for_datatypes hol_ctxt binarize bits 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 univ_card = Int.max (univ_card nat_card int_card main_j0
+ (plain_bounds @ sel_bounds) formula,
+ main_j0 |> bits > 0 ? Integer.add (bits + 1))
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
@@ -546,29 +541,30 @@
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,
+ unsound = unsound, scope = scope, core = core_f,
defs = nondef_fs @ def_fs @ declarative_axioms})
end
handle TOO_LARGE (loc, msg) =>
if loc = "Nitpick_Kodkod.check_arity" andalso
not (Typtab.is_empty ofs) then
- problem_for_scope liberal
- {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
- bits = bits, bisim_depth = bisim_depth,
- datatypes = datatypes, ofs = Typtab.empty}
+ problem_for_scope unsound
+ {hol_ctxt = hol_ctxt, binarize = binarize,
+ card_assigns = card_assigns, bits = bits,
+ 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 ^
- ". Skipping " ^ (if liberal then "potential"
+ ". Skipping " ^ (if unsound then "potential"
else "genuine") ^
" component of scope."));
NONE)
| TOO_SMALL (loc, msg) =>
(print_v (fn () => ("Limit reached: " ^ msg ^
- ". Skipping " ^ (if liberal then "potential"
+ ". Skipping " ^ (if unsound then "potential"
else "genuine") ^
" component of scope."));
NONE)
@@ -583,7 +579,7 @@
val scopes = Unsynchronized.ref []
val generated_scopes = Unsynchronized.ref []
- val generated_problems = Unsynchronized.ref []
+ val generated_problems = Unsynchronized.ref ([] : rich_problem list)
val checked_problems = Unsynchronized.ref (SOME [])
val met_potential = Unsynchronized.ref 0
@@ -634,7 +630,7 @@
| NONE => print "No confirmation by \"auto\".")
else
();
- if not standard andalso not (null induct_dataTs) then
+ if not standard andalso likely_in_struct_induct_step then
print "The existence of a nonstandard model suggests that the \
\induction hypothesis is not general enough or perhaps even \
\wrong. See the \"Inductive Properties\" section of the \
@@ -717,7 +713,7 @@
| KK.Normal (sat_ps, unsat_js) =>
let
val (lib_ps, con_ps) =
- List.partition (#liberal o snd o nth problems o fst) sat_ps
+ List.partition (#unsound 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
@@ -734,9 +730,9 @@
(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. *)
+ (* "co_js" is the list of sound problems whose unsound
+ 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 =>
@@ -749,7 +745,7 @@
val problems =
problems |> filter_out_indices bye_js
|> max_potential <= 0
- ? filter_out (#liberal o snd)
+ ? filter_out (#unsound o snd)
in
solve_any_problem max_potential max_genuine donno false
problems
@@ -769,7 +765,7 @@
(map fst sat_ps @ unsat_js)
val problems =
problems |> filter_out_indices bye_js
- |> filter_out (#liberal o snd)
+ |> filter_out (#unsound o snd)
in solve_any_problem 0 max_genuine donno false problems end
end
end
@@ -813,10 +809,10 @@
()
(* scope * bool -> rich_problem list * bool
-> rich_problem list * bool *)
- fun add_problem_for_scope (scope as {datatypes, ...}, liberal)
+ fun add_problem_for_scope (scope as {datatypes, ...}, unsound)
(problems, donno) =
(check_deadline ();
- case problem_for_scope liberal scope of
+ case problem_for_scope unsound scope of
SOME problem =>
(problems
|> (null problems orelse
@@ -832,6 +828,29 @@
([], donno)
val _ = Unsynchronized.change generated_problems (append problems)
val _ = Unsynchronized.change generated_scopes (append scopes)
+ val _ =
+ if j + 1 = n then
+ let
+ val (unsound_problems, sound_problems) =
+ List.partition (#unsound o snd) (!generated_problems)
+ in
+ if not (null sound_problems) andalso
+ forall (KK.is_problem_trivially_false o fst)
+ sound_problems then
+ print_m (fn () =>
+ "Warning: The conjecture either trivially holds for the \
+ \given scopes or (more likely) lies outside Nitpick's \
+ \supported fragment." ^
+ (if exists (not o KK.is_problem_trivially_false o fst)
+ unsound_problems then
+ " Only potential counterexamples may be found."
+ else
+ ""))
+ else
+ ()
+ end
+ else
+ ()
in
solve_any_problem max_potential max_genuine donno true (rev problems)
end
@@ -844,7 +863,7 @@
let
(* rich_problem list -> rich_problem list *)
val do_filter =
- if !met_potential = max_potential then filter_out (#liberal o snd)
+ if !met_potential = max_potential then filter_out (#unsound o snd)
else I
val total = length (!scopes)
val unsat =
@@ -873,7 +892,7 @@
if max_potential = original_max_potential then
(print_m (fn () =>
"Nitpick found no " ^ das_wort_model ^ "." ^
- (if not standard andalso not (null induct_dataTs) then
+ (if not standard andalso likely_in_struct_induct_step then
" This suggests that the induction hypothesis might be \
\general enough to prove this subgoal."
else
@@ -891,8 +910,8 @@
end
val (skipped, the_scopes) =
- all_scopes ext_ctxt sym_break cards_assigns maxes_assigns iters_assigns
- bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs
+ all_scopes hol_ctxt binarize sym_break cards_assigns maxes_assigns
+ iters_assigns bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs
val _ = if skipped > 0 then
print_m (fn () => "Too many scopes. Skipping " ^
string_of_int skipped ^ " scope" ^
--- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Fri Feb 19 15:21:57 2010 +0000
@@ -13,7 +13,7 @@
type unrolled = styp * styp
type wf_cache = (styp * (bool * bool)) list
- type extended_context = {
+ type hol_context = {
thy: theory,
ctxt: Proof.context,
max_bisim_depth: int,
@@ -46,13 +46,25 @@
wf_cache: wf_cache Unsynchronized.ref,
constr_cache: (typ * styp list) list Unsynchronized.ref}
+ datatype fixpoint_kind = Lfp | Gfp | NoFp
+ datatype boxability =
+ InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
+
val name_sep : string
val numeral_prefix : string
+ val ubfp_prefix : string
+ val lbfp_prefix : string
val skolem_prefix : string
+ val special_prefix : string
+ val uncurry_prefix : string
val eval_prefix : string
val original_name : string -> string
val s_conj : term * term -> term
- val unbit_and_unbox_type : typ -> typ
+ val s_disj : term * term -> term
+ val strip_any_connective : term -> term list * term
+ val conjuncts_of : term -> term list
+ val disjuncts_of : term -> term list
+ val unarize_and_unbox_type : typ -> typ
val string_for_type : Proof.context -> typ -> string
val prefix_name : string -> string -> string
val shortest_name : string -> string
@@ -73,22 +85,24 @@
val is_integer_type : typ -> bool
val is_bit_type : typ -> bool
val is_word_type : typ -> bool
+ val is_integer_like_type : typ -> bool
val is_record_type : typ -> bool
val is_number_type : theory -> typ -> bool
val const_for_iterator_type : typ -> styp
+ val strip_n_binders : int -> typ -> typ list * typ
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_real_datatype : theory -> string -> bool
+ val is_standard_datatype : theory -> (typ option * bool) list -> typ -> bool
val is_quot_type : theory -> typ -> bool
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_datatype : theory -> (typ option * bool) list -> typ -> bool
val is_record_constr : styp -> bool
val is_record_get : theory -> styp -> bool
val is_record_update : theory -> styp -> bool
@@ -96,16 +110,23 @@
val is_rep_fun : theory -> styp -> bool
val is_quot_abs_fun : Proof.context -> styp -> bool
val is_quot_rep_fun : Proof.context -> styp -> bool
- val is_constr : theory -> styp -> bool
+ val mate_of_rep_fun : theory -> styp -> styp
+ val is_constr_like : theory -> styp -> bool
val is_stale_constr : theory -> styp -> bool
+ val is_constr : theory -> (typ option * bool) list -> styp -> bool
val is_sel : string -> bool
val is_sel_like_and_no_discr : string -> bool
+ val box_type : hol_context -> boxability -> typ -> typ
+ val binarize_nat_and_int_in_type : typ -> typ
+ val binarize_nat_and_int_in_term : term -> term
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 binarized_and_boxed_nth_sel_for_constr :
+ hol_context -> bool -> styp -> int -> styp
val sel_no_from_name : string -> int
+ val close_form : term -> term
val eta_expand : typ list -> term -> int -> term
val extensionalize : term -> term
val distinctness_formula : typ -> term list -> term
@@ -113,20 +134,32 @@
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 : extended_context -> typ -> styp list
- val boxed_datatype_constrs : extended_context -> typ -> styp list
- val num_datatype_constrs : extended_context -> typ -> int
+ val datatype_constrs : hol_context -> typ -> styp list
+ val binarized_and_boxed_datatype_constrs :
+ hol_context -> bool -> typ -> styp list
+ val num_datatype_constrs : hol_context -> typ -> int
val constr_name_for_sel_like : string -> string
- val boxed_constr_for_sel : extended_context -> styp -> styp
+ val binarized_and_boxed_constr_for_sel : hol_context -> bool -> styp -> styp
+ val discriminate_value : hol_context -> styp -> term -> term
+ val select_nth_constr_arg :
+ theory -> (typ option * bool) list -> styp -> term -> int -> typ -> term
+ val construct_value :
+ theory -> (typ option * bool) list -> styp -> term list -> term
val card_of_type : (typ * int) list -> typ -> int
val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
val bounded_exact_card_of_type :
- extended_context -> int -> int -> (typ * int) list -> typ -> int
- val is_finite_type : extended_context -> typ -> bool
+ hol_context -> int -> int -> (typ * int) list -> typ -> int
+ val is_finite_type : hol_context -> typ -> bool
+ val special_bounds : term list -> (indexname * typ) list
+ val is_funky_typedef : 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 arity_of_built_in_const :
+ theory -> (typ option * bool) list -> bool -> styp -> int option
+ val is_built_in_const :
+ theory -> (typ option * bool) list -> bool -> styp -> bool
+ val term_under_def : term -> term
+ val case_const_names :
+ theory -> (typ option * bool) list -> (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
@@ -134,22 +167,34 @@
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 add_simps : const_table Unsynchronized.ref -> string -> term list -> unit
+ val inverse_axioms_for_rep_fun : theory -> styp -> term list
+ val optimized_typedef_axioms : theory -> string * typ list -> term list
+ val optimized_quot_type_axioms :
+ theory -> (typ option * bool) list -> string * typ list -> term list
val def_of_const : theory -> const_table -> styp -> term option
- val is_inductive_pred : extended_context -> styp -> bool
+ val fixpoint_kind_of_const :
+ theory -> const_table -> string * typ -> fixpoint_kind
+ val is_inductive_pred : hol_context -> styp -> bool
+ val is_equational_fun : hol_context -> styp -> bool
val is_constr_pattern_lhs : theory -> term -> bool
val is_constr_pattern_formula : theory -> term -> bool
+ val unfold_defs_in_term : hol_context -> term -> term
+ val codatatype_bisim_axioms : hol_context -> typ -> term list
+ val is_well_founded_inductive_pred : hol_context -> styp -> bool
+ val unrolled_inductive_pred_const : hol_context -> bool -> styp -> term
+ val equational_fun_axioms : hol_context -> styp -> term list
+ val is_equational_fun_surely_complete : hol_context -> styp -> bool
val merge_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 ground_types_in_type : hol_context -> bool -> typ -> typ list
+ val ground_types_in_terms : hol_context -> bool -> 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
+ hol_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 Nitpick_HOL : NITPICK_HOL =
@@ -162,7 +207,7 @@
type unrolled = styp * styp
type wf_cache = (styp * (bool * bool)) list
-type extended_context = {
+type hol_context = {
thy: theory,
ctxt: Proof.context,
max_bisim_depth: int,
@@ -195,6 +240,10 @@
wf_cache: wf_cache Unsynchronized.ref,
constr_cache: (typ * styp list) list Unsynchronized.ref}
+datatype fixpoint_kind = Lfp | Gfp | NoFp
+datatype boxability =
+ InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
+
structure Data = Theory_Data(
type T = {frac_types: (string * (string * string) list) list,
codatatypes: (string * (string * styp list)) list}
@@ -222,20 +271,11 @@
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 =
@@ -260,9 +300,6 @@
| s_disj (t1, t2) =
if t1 = @{const True} orelse t2 = @{const True} 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)) =
@@ -276,8 +313,8 @@
([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 conjuncts_of = strip_connective @{const "op &"}
+val disjuncts_of = strip_connective @{const "op |"}
(* When you add constants to these lists, make sure to handle them in
"Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as
@@ -309,63 +346,64 @@
(@{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 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 uminus_int_inst.uminus_int}, 0),
- (@{const_name ord_int_inst.less_int}, 2),
- (@{const_name ord_int_inst.less_eq_int}, 2),
(@{const_name unknown}, 0),
(@{const_name is_unknown}, 1),
(@{const_name Tha}, 1),
(@{const_name Frac}, 0),
(@{const_name norm_frac}, 0)]
+val built_in_nat_consts =
+ [(@{const_name Suc}, 0),
+ (@{const_name nat}, 0),
+ (@{const_name nat_gcd}, 0),
+ (@{const_name nat_lcm}, 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),
- ((@{const_name of_nat}, @{typ "unsigned_bit word => signed_bit word"}), 0)]
+ [((@{const_name zero_class.zero}, int_T), 0),
+ ((@{const_name one_class.one}, int_T), 0),
+ ((@{const_name plus_class.plus}, int_T --> int_T --> int_T), 0),
+ ((@{const_name minus_class.minus}, int_T --> int_T --> int_T), 0),
+ ((@{const_name times_class.times}, int_T --> int_T --> int_T), 0),
+ ((@{const_name div_class.div}, int_T --> int_T --> int_T), 0),
+ ((@{const_name uminus_class.uminus}, int_T --> int_T), 0),
+ ((@{const_name ord_class.less}, int_T --> int_T --> bool_T), 2),
+ ((@{const_name ord_class.less_eq}, int_T --> int_T --> bool_T), 2)]
+val built_in_typed_nat_consts =
+ [((@{const_name zero_class.zero}, nat_T), 0),
+ ((@{const_name one_class.one}, nat_T), 0),
+ ((@{const_name plus_class.plus}, nat_T --> nat_T --> nat_T), 0),
+ ((@{const_name minus_class.minus}, nat_T --> nat_T --> nat_T), 0),
+ ((@{const_name times_class.times}, nat_T --> nat_T --> nat_T), 0),
+ ((@{const_name div_class.div}, nat_T --> nat_T --> nat_T), 0),
+ ((@{const_name ord_class.less}, nat_T --> nat_T --> bool_T), 2),
+ ((@{const_name ord_class.less_eq}, nat_T --> nat_T --> bool_T), 2),
+ ((@{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)]
+ [(@{const_name semilattice_inf_class.inf}, 2),
+ (@{const_name semilattice_sup_class.sup}, 2),
+ (@{const_name minus_class.minus}, 2),
+ (@{const_name ord_class.less_eq}, 2)]
(* typ -> typ *)
-fun unbit_type @{typ "unsigned_bit word"} = nat_T
- | unbit_type @{typ "signed_bit word"} = int_T
- | unbit_type @{typ bisim_iterator} = nat_T
- | unbit_type (Type (s, Ts as _ :: _)) = Type (s, map unbit_type Ts)
- | unbit_type T = T
-fun unbit_and_unbox_type (Type (@{type_name fun_box}, Ts)) =
- unbit_and_unbox_type (Type ("fun", Ts))
- | unbit_and_unbox_type (Type (@{type_name pair_box}, Ts)) =
- Type ("*", map unbit_and_unbox_type Ts)
- | unbit_and_unbox_type @{typ "unsigned_bit word"} = nat_T
- | unbit_and_unbox_type @{typ "signed_bit word"} = int_T
- | unbit_and_unbox_type @{typ bisim_iterator} = nat_T
- | unbit_and_unbox_type (Type (s, Ts as _ :: _)) =
- Type (s, map unbit_and_unbox_type Ts)
- | unbit_and_unbox_type T = T
+fun unarize_type @{typ "unsigned_bit word"} = nat_T
+ | unarize_type @{typ "signed_bit word"} = int_T
+ | unarize_type @{typ bisim_iterator} = nat_T
+ | unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts)
+ | unarize_type T = T
+fun unarize_and_unbox_type (Type (@{type_name fun_box}, Ts)) =
+ unarize_and_unbox_type (Type ("fun", Ts))
+ | unarize_and_unbox_type (Type (@{type_name pair_box}, Ts)) =
+ Type ("*", map unarize_and_unbox_type Ts)
+ | unarize_and_unbox_type @{typ "unsigned_bit word"} = nat_T
+ | unarize_and_unbox_type @{typ "signed_bit word"} = int_T
+ | unarize_and_unbox_type @{typ bisim_iterator} = nat_T
+ | unarize_and_unbox_type (Type (s, Ts as _ :: _)) =
+ Type (s, map unarize_and_unbox_type Ts)
+ | unarize_and_unbox_type T = T
(* Proof.context -> typ -> string *)
-fun string_for_type ctxt = Syntax.string_of_typ ctxt o unbit_and_unbox_type
+fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_and_unbox_type
(* string -> string -> string *)
val prefix_name = Long_Name.qualify o Long_Name.base_name
@@ -373,8 +411,6 @@
fun shortest_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 shortest_name
(* string -> string *)
fun short_name s =
case space_explode name_sep s of
@@ -420,17 +456,19 @@
| is_gfp_iterator_type _ = false
val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type
fun is_boolean_type T = (T = prop_T orelse T = bool_T)
-val is_integer_type =
- member (op =) [nat_T, int_T, @{typ bisim_iterator}] orf is_fp_iterator_type
+fun is_integer_type T = (T = nat_T orelse T = int_T)
fun is_bit_type T = (T = @{typ unsigned_bit} orelse T = @{typ signed_bit})
fun is_word_type (Type (@{type_name word}, _)) = true
| is_word_type _ = false
+fun is_integer_like_type T =
+ is_fp_iterator_type T orelse is_integer_type T orelse is_word_type T orelse
+ T = @{typ bisim_iterator}
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 (Data.get thy)) s)))
| is_frac_type _ _ = false
-fun is_number_type thy = is_integer_type orf is_frac_type thy
+fun is_number_type thy = is_integer_like_type orf is_frac_type thy
(* bool -> styp -> typ *)
fun iterator_type_for_const gfp (s, T) =
@@ -441,7 +479,7 @@
| const_for_iterator_type T =
raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])
-(* int -> typ -> typ * typ *)
+(* int -> typ -> typ list * typ *)
fun strip_n_binders 0 T = ([], T)
| strip_n_binders n (Type ("fun", [T1, T2])) =
strip_n_binders (n - 1) T2 |>> cons T1
@@ -478,13 +516,41 @@
| dest_n_tuple_type _ T =
raise TYPE ("Nitpick_HOL.dest_n_tuple_type", [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,
+ Abs_inverse: thm option, 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}, Abs_inverse = NONE, Rep_inverse = NONE}
+ else case Typedef.get_info thy s of
+ SOME {abs_type, rep_type, Abs_name, Rep_name, set_def, Rep, Abs_inverse,
+ 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, Abs_inverse = SOME Abs_inverse,
+ Rep_inverse = SOME Rep_inverse}
+ | NONE => NONE
+
+(* theory -> string -> bool *)
+val is_typedef = is_some oo typedef_info
+val is_real_datatype = is_some oo Datatype.get_info
+(* theory -> (typ option * bool) list -> typ -> bool *)
+fun is_standard_datatype thy = the oo triple_lookup (type_match thy)
+
(* FIXME: Use antiquotation for "code_numeral" below or detect "rep_datatype",
e.g., by adding a field to "Datatype_Aux.info". *)
-(* string -> bool *)
-val is_basic_datatype =
- member (op =) [@{type_name "*"}, @{type_name bool}, @{type_name unit},
- @{type_name nat}, @{type_name int},
- "Code_Numeral.code_numeral"]
+(* theory -> (typ option * bool) list -> string -> bool *)
+fun is_basic_datatype thy stds s =
+ member (op =) [@{type_name "*"}, @{type_name bool}, @{type_name unit},
+ @{type_name int}, "Code_Numeral.code_numeral"] s orelse
+ (s = @{type_name nat} andalso is_standard_datatype thy stds nat_T)
(* theory -> typ -> typ -> typ -> typ *)
fun instantiate_type thy T1 T1' T2 =
@@ -515,7 +581,8 @@
val (co_s, co_Ts) = dest_Type co_T
val _ =
if forall is_TFree co_Ts andalso not (has_duplicates (op =) co_Ts) andalso
- co_s <> "fun" andalso not (is_basic_datatype co_s) then
+ co_s <> "fun" andalso
+ not (is_basic_datatype thy [(NONE, true)] co_s) then
()
else
raise TYPE ("Nitpick_HOL.register_codatatype", [co_T], [])
@@ -525,34 +592,9 @@
(* 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,
- Abs_inverse: thm option, 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}, Abs_inverse = NONE, Rep_inverse = NONE}
- else case Typedef.get_info thy s of
- SOME {abs_type, rep_type, Abs_name, Rep_name, set_def, Rep, Abs_inverse,
- 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, Abs_inverse = SOME Abs_inverse,
- Rep_inverse = SOME Rep_inverse}
- | NONE => NONE
-
-(* 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_quot_type _ (Type ("IntEx.my_int", _)) = true (* FIXME *)
- | is_quot_type _ (Type ("FSet.fset", _)) = true (* FIXME *)
+ | is_quot_type _ (Type ("FSet.fset", _)) = true
| is_quot_type _ _ = false
fun is_codatatype thy (T as Type (s, _)) =
not (null (AList.lookup (op =) (#codatatypes (Data.get thy)) s
@@ -561,7 +603,8 @@
fun is_pure_typedef thy (T as Type (s, _)) =
is_typedef thy s andalso
not (is_real_datatype thy s orelse is_quot_type thy T orelse
- is_codatatype thy T orelse is_record_type T orelse is_integer_type T)
+ is_codatatype thy T orelse is_record_type T orelse
+ is_integer_like_type T)
| is_pure_typedef _ _ = false
fun is_univ_typedef thy (Type (s, _)) =
(case typedef_info thy s of
@@ -574,11 +617,11 @@
o HOLogic.dest_Trueprop) prop_of_Rep) = SOME @{const_name top}
| NONE => false)
| is_univ_typedef _ _ = false
-fun is_datatype thy (T as Type (s, _)) =
+(* theory -> (typ option * bool) list -> typ -> bool *)
+fun is_datatype thy stds (T as Type (s, _)) =
(is_typedef thy s orelse is_codatatype thy T orelse T = @{typ ind} orelse
- is_quot_type thy T) andalso
- not (is_basic_datatype s)
- | is_datatype _ _ = false
+ is_quot_type thy T) andalso not (is_basic_datatype thy stds s)
+ | is_datatype _ _ _ = false
(* theory -> typ -> (string * typ) list * (string * typ) *)
fun all_record_fields thy T =
@@ -619,11 +662,11 @@
| NONE => false)
| is_rep_fun _ _ = false
(* Proof.context -> styp -> bool *)
-fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true (* FIXME *)
- | is_quot_abs_fun _ ("FSet.abs_fset", _) = true (* FIXME *)
+fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true
+ | is_quot_abs_fun _ ("FSet.abs_fset", _) = true
| is_quot_abs_fun _ _ = false
-fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true (* FIXME *)
- | is_quot_rep_fun _ ("FSet.rep_fset", _) = true (* FIXME *)
+fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true
+ | is_quot_rep_fun _ ("FSet.rep_fset", _) = true
| is_quot_rep_fun _ _ = false
(* theory -> styp -> styp *)
@@ -663,18 +706,19 @@
member (op =) [@{const_name FunBox}, @{const_name PairBox},
@{const_name Quot}, @{const_name Zero_Rep},
@{const_name Suc_Rep}] s orelse
- let val (x as (s, T)) = (s, unbit_and_unbox_type T) in
+ let val (x as (s, T)) = (s, unarize_and_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
- x = (@{const_name zero_nat_inst.zero_nat}, nat_T) orelse
is_coconstr thy x
end
fun is_stale_constr thy (x as (_, T)) =
is_codatatype thy (body_type T) andalso is_constr_like thy x andalso
not (is_coconstr thy x)
-fun is_constr thy (x as (_, T)) =
+(* theory -> (typ option * bool) list -> styp -> bool *)
+fun is_constr thy stds (x as (_, T)) =
is_constr_like thy x andalso
- not (is_basic_datatype (fst (dest_Type (unbit_type (body_type T))))) andalso
+ not (is_basic_datatype thy stds
+ (fst (dest_Type (unarize_type (body_type T))))) andalso
not (is_stale_constr thy x)
(* string -> bool *)
val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
@@ -682,9 +726,6 @@
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
@@ -693,8 +734,8 @@
| 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 =
+(* hol_context -> boxability -> typ -> bool *)
+fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
case T of
Type ("fun", _) =>
(boxy = InPair orelse boxy = InFunLHS) andalso
@@ -702,35 +743,44 @@
| Type ("*", Ts) =>
boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse
((boxy = InExpr orelse boxy = InFunLHS) andalso
- exists (is_boxing_worth_it ext_ctxt InPair)
- (map (box_type ext_ctxt InPair) Ts))
+ exists (is_boxing_worth_it hol_ctxt InPair)
+ (map (box_type hol_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)) =
+(* hol_context -> boxability -> string * typ list -> string *)
+and should_box_type (hol_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 =
+ | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
+(* hol_context -> boxability -> typ -> typ *)
+and box_type hol_ctxt boxy T =
case T of
Type (z as ("fun", [T1, T2])) =>
if boxy <> InConstr andalso boxy <> InSel andalso
- should_box_type ext_ctxt boxy z then
+ should_box_type hol_ctxt boxy z then
Type (@{type_name fun_box},
- [box_type ext_ctxt InFunLHS T1, box_type ext_ctxt InFunRHS1 T2])
+ [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2])
else
- box_type ext_ctxt (in_fun_lhs_for boxy) T1
- --> box_type ext_ctxt (in_fun_rhs_for boxy) T2
+ box_type hol_ctxt (in_fun_lhs_for boxy) T1
+ --> box_type hol_ctxt (in_fun_rhs_for boxy) T2
| Type (z as ("*", Ts)) =>
if boxy <> InConstr andalso boxy <> InSel
- andalso should_box_type ext_ctxt boxy z then
- Type (@{type_name pair_box}, map (box_type ext_ctxt InSel) Ts)
+ andalso should_box_type hol_ctxt boxy z then
+ Type (@{type_name pair_box}, map (box_type hol_ctxt InSel) Ts)
else
- Type ("*", map (box_type ext_ctxt
+ Type ("*", map (box_type hol_ctxt
(if boxy = InConstr orelse boxy = InSel then boxy
else InPair)) Ts)
| _ => T
+(* typ -> typ *)
+fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
+ | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
+ | binarize_nat_and_int_in_type (Type (s, Ts)) =
+ Type (s, map binarize_nat_and_int_in_type Ts)
+ | binarize_nat_and_int_in_type T = T
+(* term -> term *)
+val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
+
(* styp -> styp *)
fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)
@@ -747,9 +797,10 @@
| 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
+(* hol_context -> bool -> styp -> int -> styp *)
+fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize =
+ apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel)
+ oo nth_sel_for_constr
(* string -> int *)
fun sel_no_from_name s =
@@ -762,6 +813,22 @@
else
0
+(* term -> term *)
+val close_form =
+ let
+ (* (indexname * typ) list -> (indexname * typ) list -> term -> term *)
+ fun close_up zs zs' =
+ fold (fn (z as ((s, _), T)) => fn t' =>
+ Term.all T $ Abs (s, T, abstract_over (Var z, t')))
+ (take (length zs' - length zs) zs')
+ (* (indexname * typ) list -> term -> term *)
+ fun aux zs (@{const "==>"} $ t1 $ t2) =
+ let val zs' = Term.add_vars t1 zs in
+ close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
+ end
+ | aux zs t = close_up zs (Term.add_vars t zs) t
+ in aux [] end
+
(* typ list -> term -> int -> term *)
fun eta_expand _ t 0 = t
| eta_expand Ts (Abs (s, T, t')) n =
@@ -788,16 +855,16 @@
#> List.foldr (s_conj o swap) @{const True}
(* typ -> term *)
-fun zero_const T = Const (@{const_name zero_nat_inst.zero_nat}, T)
+fun zero_const T = Const (@{const_name zero_class.zero}, T)
fun suc_const T = Const (@{const_name Suc}, T --> T)
-(* extended_context -> typ -> styp list *)
-fun uncached_datatype_constrs ({thy, stds, ...} : extended_context)
+(* hol_context -> typ -> styp list *)
+fun uncached_datatype_constrs ({thy, stds, ...} : hol_context)
(T as Type (s, Ts)) =
(case AList.lookup (op =) (#codatatypes (Data.get thy)) s of
SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type thy T)) xs'
| _ =>
- if is_datatype thy T then
+ if is_datatype thy stds T then
case Datatype.get_info thy s of
SOME {index, descr, ...} =>
let
@@ -806,8 +873,6 @@
map (fn (s', Us) =>
(s', map (Refute.typ_of_dtyp descr (dtyps ~~ Ts)) Us
---> T)) constrs
- |> (triple_lookup (type_match thy) stds T |> the |> not) ?
- cons (@{const_name NonStd}, @{typ \<xi>} --> T)
end
| NONE =>
if is_record_type T then
@@ -829,55 +894,59 @@
else
[])
| uncached_datatype_constrs _ _ = []
-(* extended_context -> typ -> styp list *)
-fun datatype_constrs (ext_ctxt as {constr_cache, ...}) T =
+(* hol_context -> typ -> styp list *)
+fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T =
case AList.lookup (op =) (!constr_cache) T of
SOME xs => xs
| NONE =>
- let val xs = uncached_datatype_constrs ext_ctxt T in
+ let val xs = uncached_datatype_constrs hol_ctxt T in
(Unsynchronized.change constr_cache (cons (T, xs)); xs)
end
-fun boxed_datatype_constrs ext_ctxt =
- map (apsnd (box_type ext_ctxt InConstr)) o datatype_constrs ext_ctxt
-(* extended_context -> typ -> int *)
+(* hol_context -> bool -> typ -> styp list *)
+fun binarized_and_boxed_datatype_constrs hol_ctxt binarize =
+ map (apsnd ((binarize ? binarize_nat_and_int_in_type)
+ o box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt
+(* hol_context -> 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') =
+(* hol_context -> bool -> styp -> styp *)
+fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') =
let val s = constr_name_for_sel_like s' in
- AList.lookup (op =) (boxed_datatype_constrs ext_ctxt (domain_type T')) s
+ AList.lookup (op =)
+ (binarized_and_boxed_datatype_constrs hol_ctxt binarize (domain_type T'))
+ s
|> the |> pair s
end
-(* extended_context -> styp -> term *)
-fun discr_term_for_constr ext_ctxt (x as (s, T)) =
+(* hol_context -> styp -> term *)
+fun discr_term_for_constr hol_ctxt (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 ext_ctxt dataT >= 2 then
+ else if num_datatype_constrs hol_ctxt dataT >= 2 then
Const (discr_for_constr x)
else
Abs (Name.uu, dataT, @{const True})
end
-(* extended_context -> styp -> term -> term *)
-fun discriminate_value (ext_ctxt as {thy, ...}) (x as (_, T)) t =
+(* hol_context -> styp -> term -> term *)
+fun discriminate_value (hol_ctxt as {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 ext_ctxt x, t)
- | _ => betapply (discr_term_for_constr ext_ctxt x, t)
+ else betapply (discr_term_for_constr hol_ctxt x, t)
+ | _ => betapply (discr_term_for_constr hol_ctxt x, t)
-(* styp -> term -> term *)
-fun nth_arg_sel_term_for_constr (x as (s, T)) n =
+(* theory -> (typ option * bool) list -> styp -> term -> term *)
+fun nth_arg_sel_term_for_constr thy stds (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"}
+ if dataT = nat_T andalso is_standard_datatype thy stds nat_T then
+ @{term "%n::nat. n - 1"}
else if is_pair_type dataT then
Const (nth_sel_for_constr x n)
else
@@ -895,24 +964,26 @@
(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 -> (typ option * bool) list -> styp -> term -> int -> typ -> term *)
+fun select_nth_constr_arg thy stds 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 raise SAME ()
+ | _ => raise SAME())
+ handle SAME () => betapply (nth_arg_sel_term_for_constr thy stds x n, t)
-(* theory -> styp -> term list -> term *)
-fun construct_value _ x [] = Const x
- | construct_value thy (x as (s, _)) args =
+(* theory -> (typ option * bool) list -> styp -> term list -> term *)
+fun construct_value _ _ x [] = Const x
+ | construct_value thy stds (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')
+ forall (fn (n, t') =>
+ select_nth_constr_arg thy stds x t n dummyT = t')
(index_seq 0 (length args) ~~ args) then
t
else
@@ -920,26 +991,6 @@
| _ => list_comb (Const x, args)
end
-(* extended_context -> typ -> term -> term *)
-fun constr_expand (ext_ctxt as {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 ext_ctxt T |> hd
- 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 assigns (Type ("fun", [T1, T2])) =
reasonable_power (card_of_type assigns T2) (card_of_type assigns T1)
@@ -975,8 +1026,8 @@
card_of_type assigns T
handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
default_card)
-(* extended_context -> int -> (typ * int) list -> typ -> int *)
-fun bounded_exact_card_of_type ext_ctxt max default_card assigns T =
+(* hol_context -> int -> (typ * int) list -> typ -> int *)
+fun bounded_exact_card_of_type hol_ctxt max default_card assigns T =
let
(* typ list -> typ -> int *)
fun aux avoid T =
@@ -1006,13 +1057,13 @@
| @{typ bool} => 2
| @{typ unit} => 1
| Type _ =>
- (case datatype_constrs ext_ctxt T of
+ (case datatype_constrs hol_ctxt T of
[] => if is_integer_type T orelse is_bit_type T then 0
else raise SAME ()
| constrs =>
let
val constr_cards =
- datatype_constrs ext_ctxt T
+ datatype_constrs hol_ctxt T
|> map (Integer.prod o map (aux (T :: avoid)) o binder_types
o snd)
in
@@ -1024,9 +1075,9 @@
AList.lookup (op =) assigns T |> the_default default_card
in Int.min (max, aux [] T) end
-(* extended_context -> typ -> bool *)
-fun is_finite_type ext_ctxt =
- not_equal 0 o bounded_exact_card_of_type ext_ctxt 1 2 []
+(* hol_context -> typ -> bool *)
+fun is_finite_type hol_ctxt =
+ not_equal 0 o bounded_exact_card_of_type hol_ctxt 1 2 []
(* term -> bool *)
fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
@@ -1052,7 +1103,7 @@
member (op =) [@{type_name unit}, @{type_name "*"}, @{type_name "+"},
@{type_name int}] s orelse
is_frac_type thy (Type (s, []))
-(* theory -> term -> bool *)
+(* theory -> typ -> bool *)
fun is_funky_typedef thy (Type (s, _)) = is_funky_typedef_name thy s
| is_funky_typedef _ _ = false
(* term -> bool *)
@@ -1130,24 +1181,31 @@
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) =
+(* theory -> (typ option * bool) list -> bool -> styp -> int option *)
+fun arity_of_built_in_const thy stds 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
+ else
+ let val std_nats = is_standard_datatype thy stds nat_T in
+ case AList.lookup (op =)
+ (built_in_consts
+ |> std_nats ? append built_in_nat_consts
+ |> fast_descrs ? append built_in_descr_consts) s of
+ SOME n => SOME n
+ | NONE =>
+ case AList.lookup (op =)
+ (built_in_typed_consts
+ |> std_nats ? append built_in_typed_nat_consts)
+ (s, unarize_type 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
+ end
+(* theory -> (typ option * bool) list -> bool -> styp -> bool *)
+val is_built_in_const = is_some oooo arity_of_built_in_const
(* This function is designed to work for both real definition axioms and
simplification rules (equational specifications). *)
@@ -1165,9 +1223,10 @@
(* 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
+(* theory -> (typ option * bool) list -> bool -> const_table -> styp
+ -> term list *)
+fun def_props_for_const thy stds fast_descrs table (x as (s, _)) =
+ if is_built_in_const thy stds fast_descrs x then
[]
else
these (Symtab.lookup table s)
@@ -1192,15 +1251,14 @@
(* 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
+ if is_built_in_const thy [(NONE, false)] false x orelse
+ original_name s <> s then
NONE
else
- x |> def_props_for_const thy false table |> List.last
+ x |> def_props_for_const thy [(NONE, false)] false table |> List.last
|> normalized_rhs_of thy |> Option.map (prefix_abs_vars s)
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
@@ -1247,10 +1305,10 @@
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 =
+(* theory -> (typ option * bool) list -> (string * int) list *)
+fun case_const_names thy stds =
Symtab.fold (fn (dtype_s, {index, descr, case_name, ...}) =>
- if is_basic_datatype dtype_s then
+ if is_basic_datatype thy stds dtype_s then
I
else
cons (case_name, AList.lookup (op =) descr index
@@ -1299,35 +1357,6 @@
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 -> term list *)
fun inverse_axioms_for_rep_fun thy (x as (_, T)) =
let val abs_T = domain_type T in
@@ -1336,7 +1365,7 @@
|> pairself (Refute.specialize_type thy x o prop_of o the)
||> single |> op ::
end
-(* theory -> styp list -> term list *)
+(* theory -> string * typ list -> term list *)
fun optimized_typedef_axioms thy (abs_z as (abs_s, abs_Ts)) =
let val abs_T = Type abs_z in
if is_univ_typedef thy abs_T then
@@ -1360,7 +1389,7 @@
end
| NONE => []
end
-fun optimized_quot_type_axioms thy abs_z =
+fun optimized_quot_type_axioms thy stds abs_z =
let
val abs_T = Type abs_z
val rep_T = rep_type_for_quot_type thy abs_T
@@ -1369,7 +1398,7 @@
val x_var = Var (("x", 0), rep_T)
val y_var = Var (("y", 0), rep_T)
val x = (@{const_name Quot}, rep_T --> abs_T)
- val sel_a_t = select_nth_constr_arg thy x a_var 0 rep_T
+ val sel_a_t = select_nth_constr_arg thy stds x a_var 0 rep_T
val normal_t = Const (@{const_name quot_normal}, rep_T --> rep_T)
val normal_x = normal_t $ x_var
val normal_y = normal_t $ y_var
@@ -1386,42 +1415,32 @@
$ (HOLogic.mk_Trueprop (equiv_rel $ x_var $ normal_x))]
end
-(* theory -> int * styp -> term *)
-fun constr_case_body thy (j, (x as (_, T))) =
+(* theory -> (typ option * bool) list -> int * styp -> term *)
+fun constr_case_body thy stds (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))
+ list_comb (Bound j, map2 (select_nth_constr_arg thy stds x (Bound 0))
(index_seq 0 (length arg_Ts)) arg_Ts)
end
-(* extended_context -> typ -> int * styp -> term -> term *)
-fun add_constr_case (ext_ctxt as {thy, ...}) res_T (j, x) res_t =
+(* hol_context -> typ -> int * styp -> term -> term *)
+fun add_constr_case (hol_ctxt as {thy, stds, ...}) res_T (j, x) res_t =
Const (@{const_name If}, bool_T --> res_T --> res_T --> res_T)
- $ discriminate_value ext_ctxt x (Bound 0) $ constr_case_body thy (j, x)
+ $ discriminate_value hol_ctxt x (Bound 0) $ constr_case_body thy stds (j, x)
$ res_t
-(* extended_context -> typ -> typ -> term *)
-fun optimized_case_def (ext_ctxt as {thy, ...}) dataT res_T =
+(* hol_context -> typ -> typ -> term *)
+fun optimized_case_def (hol_ctxt as {thy, stds, ...}) dataT res_T =
let
- val xs = datatype_constrs ext_ctxt dataT
- val xs' = filter_out (fn (s, _) => s = @{const_name NonStd}) xs
- val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs'
+ val xs = datatype_constrs hol_ctxt dataT
+ val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs
+ val (xs', x) = split_last xs
in
- (if length xs = length xs' then
- let
- val (xs'', x) = split_last xs'
- in
- constr_case_body thy (1, x)
- |> fold_rev (add_constr_case ext_ctxt res_T)
- (length xs' downto 2 ~~ xs'')
- end
- else
- Const (@{const_name undefined}, dataT --> res_T) $ Bound 0
- |> fold_rev (add_constr_case ext_ctxt res_T)
- (length xs' downto 1 ~~ xs'))
+ constr_case_body thy stds (1, x)
+ |> fold_rev (add_constr_case hol_ctxt res_T) (length xs downto 2 ~~ xs')
|> fold_rev (curry absdummy) (func_Ts @ [dataT])
end
-(* extended_context -> string -> typ -> typ -> term -> term *)
-fun optimized_record_get (ext_ctxt as {thy, ...}) s rec_T res_T t =
- let val constr_x = hd (datatype_constrs ext_ctxt rec_T) in
+(* hol_context -> string -> typ -> typ -> term -> term *)
+fun optimized_record_get (hol_ctxt as {thy, stds, ...}) s rec_T res_T t =
+ let val constr_x = hd (datatype_constrs hol_ctxt rec_T) in
case no_of_record_field thy s rec_T of
~1 => (case rec_T of
Type (_, Ts as _ :: _) =>
@@ -1429,65 +1448,56 @@
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 ext_ctxt s rec_T' res_T
+ select_nth_constr_arg thy stds constr_x t j res_T
+ |> optimized_record_get hol_ctxt s rec_T' res_T
end
| _ => raise TYPE ("Nitpick_HOL.optimized_record_get", [rec_T],
[]))
- | j => select_nth_constr_arg thy constr_x t j res_T
+ | j => select_nth_constr_arg thy stds constr_x t j res_T
end
-(* extended_context -> string -> typ -> term -> term -> term *)
-fun optimized_record_update (ext_ctxt as {thy, ...}) s rec_T fun_t rec_t =
+(* hol_context -> string -> typ -> term -> term -> term *)
+fun optimized_record_update (hol_ctxt as {thy, stds, ...}) s rec_T fun_t rec_t =
let
- val constr_x as (_, constr_T) = hd (datatype_constrs ext_ctxt rec_T)
+ val constr_x as (_, constr_T) = hd (datatype_constrs hol_ctxt 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 ext_ctxt s
- (rec_T |> dest_Type |> snd |> List.last) fun_t t
- else
- t
- end) (index_seq 0 n) Ts
+ val ts =
+ map2 (fn j => fn T =>
+ let val t = select_nth_constr_arg thy stds 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 hol_ctxt 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
+ if is_built_in_const thy [(NONE, false)] 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)))
+(* hol_context -> styp -> bool *)
+fun is_real_inductive_pred ({thy, stds, fast_descrs, def_table, intro_table,
+ ...} : hol_context) x =
+ fixpoint_kind_of_const thy def_table x <> NoFp andalso
+ not (null (def_props_for_const thy stds fast_descrs intro_table x))
+fun is_real_equational_fun ({thy, stds, fast_descrs, simp_table, psimp_table,
+ ...} : hol_context) x =
+ exists (fn table => not (null (def_props_for_const thy stds 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
+fun is_inductive_pred hol_ctxt =
+ is_real_inductive_pred hol_ctxt andf (not o is_real_equational_fun hol_ctxt)
+fun is_equational_fun (hol_ctxt as {thy, def_table, ...}) =
+ (is_real_equational_fun hol_ctxt orf is_real_inductive_pred hol_ctxt
orf (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
- andf (not o has_trivial_definition thy def_table)
(* term * term -> term *)
fun s_betapply (Const (@{const_name If}, _) $ @{const True} $ t, _) = t
@@ -1522,11 +1532,11 @@
SOME t' => is_constr_pattern_lhs thy t'
| NONE => false
+(* Prevents divergence in case of cyclic or infinite definition dependencies. *)
val unfold_max_depth = 255
-val axioms_max_depth = 255
-(* extended_context -> term -> term *)
-fun unfold_defs_in_term (ext_ctxt as {thy, destroy_constrs, fast_descrs,
+(* hol_context -> term -> term *)
+fun unfold_defs_in_term (hol_ctxt as {thy, stds, destroy_constrs, fast_descrs,
case_names, def_table, ground_thm_table,
ersatz_table, ...}) =
let
@@ -1541,8 +1551,11 @@
|> ran_T = nat_T ? Integer.max 0
val s = numeral_prefix ^ signed_string_of_int j
in
- if is_integer_type ran_T then
- Const (s, ran_T)
+ if is_integer_like_type ran_T then
+ if is_standard_datatype thy stds ran_T then
+ Const (s, ran_T)
+ else
+ funpow j (curry (op $) (suc_const ran_T)) (zero_const ran_T)
else
do_term depth Ts (Const (@{const_name of_int}, int_T --> ran_T)
$ Const (s, int_T))
@@ -1581,9 +1594,9 @@
(* 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 thy stds 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)
+ (select_nth_constr_arg thy stds 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
@@ -1592,7 +1605,7 @@
| NONE =>
let
val (const, ts) =
- if is_built_in_const fast_descrs x then
+ if is_built_in_const thy stds fast_descrs x then
(Const x, ts)
else case AList.lookup (op =) case_names s of
SOME n =>
@@ -1600,11 +1613,11 @@
val (dataT, res_T) = nth_range_type n T
|> pairf domain_type range_type
in
- (optimized_case_def ext_ctxt dataT res_T
+ (optimized_case_def hol_ctxt dataT res_T
|> do_term (depth + 1) Ts, ts)
end
| _ =>
- if is_constr thy x then
+ if is_constr thy stds x then
(Const x, ts)
else if is_stale_constr thy x then
raise NOT_SUPPORTED ("(non-co)constructors of codatatypes \
@@ -1628,24 +1641,24 @@
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 ext_ctxt s (domain_type T)
+ | _ => (optimized_record_get hol_ctxt s (domain_type T)
(range_type T) (do_term depth Ts (hd ts)), tl ts)
else if is_record_update thy x then
case length ts of
- 2 => (optimized_record_update ext_ctxt
+ 2 => (optimized_record_update hol_ctxt
(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
+ if is_constr thy stds 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
+ else if is_equational_fun hol_ctxt x then
(Const x, ts)
else case def_of_const thy def_table x of
SOME def =>
@@ -1662,10 +1675,10 @@
in s_betapplys (const, map (do_term depth Ts) ts) |> Envir.beta_norm end
in do_term 0 [] end
-(* extended_context -> typ -> term list *)
-fun codatatype_bisim_axioms (ext_ctxt as {thy, ...}) T =
+(* hol_context -> typ -> term list *)
+fun codatatype_bisim_axioms (hol_ctxt as {thy, stds, ...}) T =
let
- val xs = datatype_constrs ext_ctxt T
+ val xs = datatype_constrs hol_ctxt 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)
@@ -1681,25 +1694,25 @@
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
+ $ select_nth_constr_arg thy stds x x_var n nth_T
+ $ select_nth_constr_arg thy stds 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 ext_ctxt x y_var ::
+ discriminate_value hol_ctxt 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 ext_ctxt T bool_T,
+ $ (betapplys (optimized_case_def hol_ctxt 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))]
+ $ x_var $ Const (@{const_name bot_class.bot}, set_T))]
|> map HOLogic.mk_Trueprop
end
@@ -1746,19 +1759,20 @@
(tac ctxt (auto_tac (clasimpset_of ctxt))))
#> the #> Goal.finish ctxt) goal
-val max_cached_wfs = 100
-val cached_timeout = Unsynchronized.ref (SOME Time.zeroTime)
-val cached_wf_props : (term * bool) list Unsynchronized.ref =
- Unsynchronized.ref []
+val max_cached_wfs = 50
+val cached_timeout =
+ Synchronized.var "Nitpick_HOL.cached_timeout" (SOME Time.zeroTime)
+val cached_wf_props =
+ Synchronized.var "Nitpick_HOL.cached_wf_props" ([] : (term * bool) list)
val termination_tacs = [Lexicographic_Order.lex_order_tac true,
ScnpReconstruct.sizechange_tac]
-(* extended_context -> const_table -> styp -> bool *)
+(* hol_context -> const_table -> styp -> bool *)
fun uncached_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
+ ({thy, ctxt, stds, debug, fast_descrs, tac_timeout, intro_table, ...}
+ : hol_context) (x as (_, T)) =
+ case def_props_for_const thy stds fast_descrs intro_table x of
[] => raise TERM ("Nitpick_HOL.uncached_is_well_founded_inductive",
[Const x])
| intro_ts =>
@@ -1780,41 +1794,42 @@
else
()
in
- if tac_timeout = (!cached_timeout) andalso
- length (!cached_wf_props) < max_cached_wfs then
+ if tac_timeout = Synchronized.value cached_timeout andalso
+ length (Synchronized.value cached_wf_props) < max_cached_wfs then
()
else
- (cached_wf_props := []; cached_timeout := tac_timeout);
- case AList.lookup (op =) (!cached_wf_props) prop of
+ (Synchronized.change cached_wf_props (K []);
+ Synchronized.change cached_timeout (K tac_timeout));
+ case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of
SOME wf => wf
| NONE =>
let
val goal = prop |> cterm_of thy |> Goal.init
val wf = exists (terminates_by ctxt tac_timeout goal)
termination_tacs
- in Unsynchronized.change cached_wf_props (cons (prop, wf)); wf end
+ in Synchronized.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. *)
+(* The type constraint below is a workaround for a Poly/ML crash. *)
-(* extended_context -> styp -> bool *)
+(* hol_context -> styp -> bool *)
fun is_well_founded_inductive_pred
- (ext_ctxt as {thy, wfs, def_table, wf_cache, ...} : extended_context)
+ (hol_ctxt as {thy, wfs, def_table, wf_cache, ...} : hol_context)
(x as (s, _)) =
case triple_lookup (const_match thy) wfs x of
SOME (SOME b) => b
| _ => s = @{const_name Nats} orelse s = @{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 = uncached_is_well_founded_inductive_pred ext_ctxt x
- in
- Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
- end
+ SOME (_, wf) => wf
+ | NONE =>
+ let
+ val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
+ val wf = uncached_is_well_founded_inductive_pred hol_ctxt x
+ in
+ Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
+ end
(* typ list -> typ -> typ -> term -> term *)
fun ap_curry [_] _ _ t = t
@@ -1842,14 +1857,14 @@
| do_disjunct j t =
case num_occs_of_bound_in_term j t of
0 => true
- | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts t)
+ | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of 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)
+ | n => forall (do_disjunct (n - 1)) (disjuncts_of body)
end
| do_lfp_def _ = false
in do_lfp_def o strip_abs_body end
@@ -1887,7 +1902,7 @@
end
val (nonrecs, recs) =
List.partition (curry (op =) 0 o num_occs_of_bound_in_term j)
- (disjuncts body)
+ (disjuncts_of 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}
@@ -1901,8 +1916,8 @@
raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t])
in aux end
-(* extended_context -> styp -> term -> term *)
-fun starred_linear_pred_const (ext_ctxt as {simp_table, ...}) (x as (s, T))
+(* hol_context -> styp -> term -> term *)
+fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (x as (s, T))
def =
let
val j = maxidx_of_term def + 1
@@ -1933,11 +1948,11 @@
$ 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
+ |> unfold_defs_in_term hol_ctxt
end
-(* extended_context -> bool -> styp -> term *)
-fun unrolled_inductive_pred_const (ext_ctxt as {thy, star_linear_preds,
+(* hol_context -> bool -> styp -> term *)
+fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds,
def_table, simp_table, ...})
gfp (x as (s, T)) =
let
@@ -1946,11 +1961,11 @@
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
+ if is_equational_fun hol_ctxt x' then
unrolled_const (* already done *)
else if not gfp andalso is_linear_inductive_pred_def def andalso
star_linear_preds then
- starred_linear_pred_const ext_ctxt x def
+ starred_linear_pred_const hol_ctxt x def
else
let
val j = maxidx_of_term def + 1
@@ -1973,8 +1988,8 @@
in unrolled_const end
end
-(* extended_context -> styp -> term *)
-fun raw_inductive_pred_axiom ({thy, def_table, ...} : extended_context) x =
+(* hol_context -> styp -> term *)
+fun raw_inductive_pred_axiom ({thy, def_table, ...} : hol_context) x =
let
val def = the (def_of_const thy def_table x)
val (outer, fp_app) = strip_abs def
@@ -1992,24 +2007,29 @@
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)) =
+fun inductive_pred_axiom hol_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)]
+ raw_inductive_pred_axiom hol_ctxt x' |> subst_atomic [(Const x', Const x)]
end
else
- raw_inductive_pred_axiom ext_ctxt x
+ raw_inductive_pred_axiom hol_ctxt x
-(* extended_context -> styp -> term list *)
-fun raw_equational_fun_axioms (ext_ctxt as {thy, fast_descrs, simp_table,
+(* hol_context -> styp -> term list *)
+fun raw_equational_fun_axioms (hol_ctxt as {thy, stds, fast_descrs, simp_table,
psimp_table, ...}) (x as (s, _)) =
- 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]
+ case def_props_for_const thy stds fast_descrs (!simp_table) x of
+ [] => (case def_props_for_const thy stds fast_descrs psimp_table x of
+ [] => [inductive_pred_axiom hol_ctxt x]
| psimps => psimps)
| simps => simps
-
val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
+(* hol_context -> styp -> bool *)
+fun is_equational_fun_surely_complete hol_ctxt x =
+ case raw_equational_fun_axioms hol_ctxt x of
+ [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
+ strip_comb t1 |> snd |> forall is_Var
+ | _ => false
(* term list -> term list *)
fun merge_type_vars_in_terms ts =
@@ -2028,1261 +2048,33 @@
| 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 member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} :: accum) T 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 (curry (op =) 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 true def t0 t1 t2 seen
- | (t0 as @{const "==>"}) $ t1 $ t2 =>
- if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
- | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
- do_eq_or_imp Ts true def t0 t1 t2 seen
- | (t0 as @{const "op -->"}) $ t1 $ t2 =>
- do_eq_or_imp Ts false 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 -> bool -> term -> term -> term -> term list
- -> term * term list *)
- and do_eq_or_imp Ts eq def t0 t1 t2 seen =
- let
- val (t2, seen) = if eq andalso def then (t2, seen)
- else do_term Ts false 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
-
-(* extended_context -> bool -> term -> term *)
-fun destroy_pulled_out_constrs (ext_ctxt as {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
- (* The first case is not as general as it could be. *)
- (Const (@{const_name PairBox}, _),
- [Const (@{const_name fst}, _) $ Var z1,
- Const (@{const_name snd}, _) $ Var z2]) =>
- if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
- else raise SAME ()
- | (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 = @{const_name Pair} orelse
- x = (@{const_name Suc}, nat_T --> nat_T)) andalso
- (not careful orelse not (is_Var t1) orelse
- String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
- discriminate_value ext_ctxt x t1 ::
- map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
- |> foldr1 s_conj
- else
- raise SAME ()
- end
- | _ => raise SAME ())
- |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
- 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 (member (op =) zs z) andalso
- not (exists_subterm (curry (op =) (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_threshold = 7
-
-(* 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 then
- aux s0 (s1 :: ss) (T1 :: Ts) t1
- else if quant_s = "" andalso
- (s0 = @{const_name All} orelse s0 = @{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 list * int) list *)
- fun merge costly_boundss [] = costly_boundss
- | merge costly_boundss (j :: js) =
- let
- val (yeas, nays) =
- List.partition (fn (bounds, _) =>
- member (op =) bounds j)
- costly_boundss
- val yeas_bounds = big_union fst yeas
- val yeas_cost = Integer.sum (map snd yeas)
- * nth T_costs j
- in merge ((yeas_bounds, yeas_cost) :: nays) js end
- (* (int list * int) list -> int list -> int *)
- val cost = Integer.sum o map snd oo merge
- (* Inspired by Claessen & Sörensson's polynomial binary
- splitting heuristic (p. 5 of their MODEL 2003 paper). *)
- (* (int list * int) list -> int list -> int list *)
- fun heuristically_best_permutation _ [] = []
- | heuristically_best_permutation costly_boundss js =
- let
- val (costly_boundss, (j, js)) =
- js |> map (`(merge costly_boundss o single))
- |> sort (int_ord
- o pairself (Integer.sum o map snd o fst))
- |> split_list |>> hd ||> pairf hd tl
- in
- j :: heuristically_best_permutation costly_boundss js
- end
- val js =
- if length Ts <= quantifier_cluster_threshold then
- all_permutations (index_seq 0 num_Ts)
- |> map (`(cost (t_boundss ~~ t_costs)))
- |> sort (int_ord o pairself fst) |> hd |> snd
- else
- heuristically_best_permutation (t_boundss ~~ t_costs)
- (index_seq 0 num_Ts)
- val back_js = map (fn j => find_index (curry (op =) 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 ("Nitpick_HOL.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) =>
- member (op =) bounds j)
- 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 =
+(* hol_context -> bool -> typ -> typ list -> typ list *)
+fun add_ground_types hol_ctxt binarize =
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.foldr 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 (curry (op =) 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
- 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 (member (op =) blacklist x) 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 (curry (op =) 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 true 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 ("Nitpick_HOL.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 = @{type_name fun_box} orelse
- old_s = @{type_name pair_box} orelse old_s = "*" then
- case constr_expand ext_ctxt 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 ("Nitpick_HOL.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 ("Nitpick_HOL.box_fun_and_pair_in_term.\
- \add_boxed_types_for_var", [T'], []))
- | _ => exists_subterm (curry (op =) (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 = @{const_name "=="} orelse s0 = @{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 (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
- let val T' = box_type ext_ctxt InSel T2 in
- Const (@{const_name quot_normal}, T' --> T')
- end
- | Const (s as @{const_name Tha}, T) => do_description_operator s T
- | Const (x as (s, T)) =>
- Const (s, if s = @{const_name converse} orelse
- s = @{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 Integer.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 (* TODO: needed? *)
- 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 |> member (op =) xs x ? 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
+ fun aux T accum =
+ case T of
+ Type ("fun", Ts) => fold aux Ts accum
+ | Type ("*", Ts) => fold aux Ts accum
+ | Type (@{type_name itself}, [T1]) => aux T1 accum
+ | Type (_, Ts) =>
+ if member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} :: accum)
+ 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_def_axiom depth = add_axiom fst apfst depth
- and add_nondef_axiom depth = add_axiom snd apsnd depth
- and add_maybe_def_axiom depth t =
- (if head_of t <> @{const "==>"} then add_def_axiom
- else add_nondef_axiom) depth t
- and add_eq_axiom depth t =
- (if is_constr_pattern_formula thy t then add_def_axiom
- else add_nondef_axiom) 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 member (op =) xs x 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 TOO_LARGE ("Nitpick_HOL.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_maybe_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_eq_axiom depth) (equational_fun_axioms ext_ctxt x)
- accum
- else if is_abs_fun thy x then
- if is_quot_type thy (range_type T) then
- raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
- else
- accum |> fold (add_nondef_axiom depth)
- (nondef_props_for_const thy false nondef_table x)
- |> is_funky_typedef thy (range_type T)
- ? fold (add_maybe_def_axiom depth)
- (nondef_props_for_const thy true
- (extra_table def_table s) x)
- else if is_rep_fun thy x then
- if is_quot_type thy (domain_type T) then
- raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
- else
- accum |> fold (add_nondef_axiom depth)
- (nondef_props_for_const thy false nondef_table x)
- |> is_funky_typedef thy (range_type T)
- ? fold (add_maybe_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))
- |> fold (add_def_axiom depth)
- (inverse_axioms_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 (s, Ts)) =>
- fold (add_axioms_for_type depth) Ts
- #> (if is_pure_typedef thy T then
- fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
- else if is_quot_type thy T then
- fold (add_def_axiom depth) (optimized_quot_type_axioms thy z)
- else if max_bisim_depth >= 0 andalso is_codatatype thy T then
- fold (add_maybe_def_axiom depth)
- (codatatype_bisim_axioms ext_ctxt 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 ("Nitpick_HOL.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
+ T :: accum
+ |> fold aux (case binarized_and_boxed_datatype_constrs hol_ctxt
+ binarize T of
+ [] => Ts
+ | xs => map snd xs)
+ | _ => insert (op =) T accum
+ in aux end
+
+(* hol_context -> bool -> typ -> typ list *)
+fun ground_types_in_type hol_ctxt binarize T =
+ add_ground_types hol_ctxt binarize T []
+(* hol_context -> term list -> typ list *)
+fun ground_types_in_terms hol_ctxt binarize ts =
+ fold (fold_types (add_ground_types hol_ctxt binarize)) ts []
(* theory -> const_table -> styp -> int list *)
fun const_format thy def_table (x as (s, T)) =
@@ -3330,7 +2122,7 @@
(* int list -> int list -> typ -> typ *)
fun format_type default_format format T =
let
- val T = unbit_and_unbox_type T
+ val T = unarize_and_unbox_type T
val format = format |> filter (curry (op <) 0)
in
if forall (curry (op =) 1) format then
@@ -3356,10 +2148,10 @@
|> map (rev o filter_out (member (op =) js))
|> filter_out null |> map length |> rev
-(* extended_context -> string * string -> (term option * int list) list
+(* hol_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 =
+ : hol_context) (base_name, step_name) formats =
let
val default_format = the (AList.lookup (op =) formats NONE)
(* styp -> term * typ *)
@@ -3369,7 +2161,7 @@
(* 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, unbit_and_unbox_type T)
+ AList.find (op =) (!special_funs) (s, unarize_and_unbox_type T)
|> the_single
val max_j = List.last js
val Ts = List.take (binder_types T', max_j + 1)
@@ -3459,8 +2251,8 @@
let val t = Const (original_name s, T) in
(t, format_term_type thy def_table formats t)
end)
- |>> map_types unbit_and_unbox_type
- |>> shorten_names_in_term |>> shorten_abs_vars
+ |>> map_types unarize_and_unbox_type
+ |>> shorten_names_in_term |>> Term.map_abs_vars shortest_name
in do_const end
(* styp -> string *)
@@ -3474,84 +2266,4 @@
else
"="
-val binary_int_threshold = 4
-
-(* term -> bool *)
-fun may_use_binary_ints (t1 $ t2) =
- may_use_binary_ints t1 andalso may_use_binary_ints t2
- | may_use_binary_ints (t as Const (s, _)) =
- t <> @{const Suc} andalso
- not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
- @{const_name nat_gcd}, @{const_name nat_lcm},
- @{const_name Frac}, @{const_name norm_frac}] s)
- | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
- | may_use_binary_ints _ = true
-fun should_use_binary_ints (t1 $ t2) =
- should_use_binary_ints t1 orelse should_use_binary_ints t2
- | should_use_binary_ints (Const (s, _)) =
- member (op =) [@{const_name times_nat_inst.times_nat},
- @{const_name div_nat_inst.div_nat},
- @{const_name times_int_inst.times_int},
- @{const_name div_int_inst.div_int}] s orelse
- (String.isPrefix numeral_prefix s andalso
- let val n = the (Int.fromString (unprefix numeral_prefix s)) in
- n <= ~ binary_int_threshold orelse n >= binary_int_threshold
- end)
- | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
- | should_use_binary_ints _ = false
-
-(* typ -> typ *)
-fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
- | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
- | binarize_nat_and_int_in_type (Type (s, Ts)) =
- Type (s, map binarize_nat_and_int_in_type Ts)
- | binarize_nat_and_int_in_type T = T
-(* term -> term *)
-val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
-
-(* extended_context -> term
- -> ((term list * term list) * (bool * bool)) * term *)
-fun preprocess_term (ext_ctxt as {thy, binary_ints, 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 binarize =
- case binary_ints of
- SOME false => false
- | _ =>
- forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
- (binary_ints = SOME true orelse
- exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
- val 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 =
- binarize ? binarize_nat_and_int_in_term
- #> uncurry ? uncurry_term table
- #> 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 ext_ctxt 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;
--- a/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Fri Feb 19 15:21:57 2010 +0000
@@ -7,7 +7,7 @@
signature NITPICK_KODKOD =
sig
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type dtype_spec = Nitpick_Scope.dtype_spec
type kodkod_constrs = Nitpick_Peephole.kodkod_constrs
type nut = Nitpick_Nut.nut
@@ -33,10 +33,10 @@
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 -> int Typtab.table -> kodkod_constrs
+ hol_context -> bool -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec list -> Kodkod.formula list
val kodkod_formula_from_nut :
- int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula
+ int -> int Typtab.table -> kodkod_constrs -> nut -> Kodkod.formula
end;
structure Nitpick_Kodkod : NITPICK_KODKOD =
@@ -131,8 +131,7 @@
let
(* int -> int -> int -> KK.int_bound list *)
fun aux 0 _ _ = []
- | aux 1 pow_of_two j =
- if j < univ_card then [(SOME (~ pow_of_two), [single_atom j])] else []
+ | aux 1 pow_of_two j = [(SOME (~ pow_of_two), [single_atom j])]
| aux iter pow_of_two j =
(SOME pow_of_two, [single_atom j]) ::
aux (iter - 1) (2 * pow_of_two) (j + 1)
@@ -316,7 +315,17 @@
if R2 = Formula Neut then
[ts] |> not exclusive ? cons (KK.TupleSet [])
else
- [KK.TupleSet [], KK.TupleProduct (ts, upper_bound_for_rep R2)]
+ [KK.TupleSet [],
+ if T1 = T2 andalso epsilon > delta andalso
+ (datatype_spec dtypes T1 |> the |> pairf #co #standard)
+ = (false, true) then
+ index_seq delta (epsilon - delta)
+ |> map (fn j =>
+ KK.TupleProduct (KK.TupleSet [Kodkod.Tuple [j + j0]],
+ KK.TupleAtomSeq (j, j0)))
+ |> foldl1 KK.TupleUnion
+ else
+ KK.TupleProduct (ts, upper_bound_for_rep R2)]
end)
end
| bound_for_sel_rel _ _ _ u =
@@ -732,12 +741,14 @@
(* nut NameTable.table -> styp -> KK.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 =
+(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec list -> styp -> int -> nfa_transition list *)
+fun nfa_transitions_for_sel hol_ctxt binarize
+ ({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 x as (_, T) =
+ binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize constr_x n
val (r, R, arity) = const_triple rel_table x
val type_schema = type_schema_of_rep T R
in
@@ -746,61 +757,66 @@
else SOME (kk_project r (map KK.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)
+(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec list -> styp -> nfa_transition list *)
+fun nfa_transitions_for_constr hol_ctxt binarize kk rel_table dtypes
+ (x as (_, T)) =
+ maps (nfa_transitions_for_sel hol_ctxt binarize 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 _ _ _ _ {deep = false, ...} = NONE
- | nfa_entry_for_datatype ext_ctxt kk rel_table dtypes {typ, constrs, ...} =
- SOME (typ, maps (nfa_transitions_for_constr ext_ctxt kk rel_table dtypes
- o #const) constrs)
+(* hol_context -> bool -> 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 _ _ _ _ _ {standard = false, ...} = NONE
+ | nfa_entry_for_datatype _ _ _ _ _ {deep = false, ...} = NONE
+ | nfa_entry_for_datatype hol_ctxt binarize kk rel_table dtypes
+ {typ, constrs, ...} =
+ SOME (typ, maps (nfa_transitions_for_constr hol_ctxt binarize kk rel_table
+ dtypes o #const) constrs)
val empty_rel = KK.Product (KK.None, KK.None)
(* nfa_table -> typ -> typ -> KK.rel_expr list *)
-fun direct_path_rel_exprs nfa start final =
- case AList.lookup (op =) nfa final of
- SOME trans => map fst (filter (curry (op =) start o snd) trans)
+fun direct_path_rel_exprs nfa start_T final_T =
+ case AList.lookup (op =) nfa final_T of
+ SOME trans => map fst (filter (curry (op =) start_T o snd) trans)
| NONE => []
(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> KK.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 KK.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)
+and any_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start_T
+ final_T =
+ fold kk_union (direct_path_rel_exprs nfa start_T final_T)
+ (if start_T = final_T then KK.Iden else empty_rel)
+ | any_path_rel_expr (kk as {kk_union, ...}) nfa (T :: Ts) start_T final_T =
+ kk_union (any_path_rel_expr kk nfa Ts start_T final_T)
+ (knot_path_rel_expr kk nfa Ts start_T T final_T)
(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> typ
-> KK.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)
+and knot_path_rel_expr (kk as {kk_join, kk_reflexive_closure, ...}) nfa Ts
+ start_T knot_T final_T =
+ kk_join (kk_join (any_path_rel_expr kk nfa Ts knot_T final_T)
+ (kk_reflexive_closure (loop_path_rel_expr kk nfa Ts knot_T)))
+ (any_path_rel_expr kk nfa Ts start_T knot_T)
(* kodkod_constrs -> nfa_table -> typ list -> typ -> KK.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)
+and loop_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start_T =
+ fold kk_union (direct_path_rel_exprs nfa start_T start_T) empty_rel
+ | loop_path_rel_expr (kk as {kk_union, kk_closure, ...}) nfa (T :: Ts)
+ start_T =
+ if start_T = T then
+ kk_closure (loop_path_rel_expr kk nfa Ts start_T)
else
- kk_union (loop_path_rel_expr kk nfa qs start)
- (knot_path_rel_expr kk nfa qs start q start)
+ kk_union (loop_path_rel_expr kk nfa Ts start_T)
+ (knot_path_rel_expr kk nfa Ts start_T T start_T)
(* 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, ())))
+ fun new_node T = perhaps (try (NfaGraph.new_node (T, ())))
(* 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
+ | add_nfa ((T, ((_, T') :: transitions)) :: nfa) =
+ add_nfa ((T, transitions) :: nfa) o NfaGraph.add_edge (T, T') o
+ new_node T' o new_node T
in add_nfa nfa NfaGraph.empty end
(* nfa_table -> nfa_table list *)
@@ -808,27 +824,29 @@
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 -> KK.formula *)
-fun acyclicity_axiom_for_datatype dtypes kk nfa start =
+(* kodkod_constrs -> dtype_spec list -> nfa_table -> typ -> KK.formula *)
+fun acyclicity_axiom_for_datatype kk dtypes nfa start_T =
#kk_no kk (#kk_intersect kk
- (loop_path_rel_expr kk nfa (map fst nfa) start) KK.Iden)
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
- -> KK.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
+ (loop_path_rel_expr kk nfa (map fst nfa) start_T) KK.Iden)
+(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
+ -> dtype_spec list -> KK.formula list *)
+fun acyclicity_axioms_for_datatypes hol_ctxt binarize kk rel_table dtypes =
+ map_filter (nfa_entry_for_datatype hol_ctxt binarize kk rel_table dtypes)
+ dtypes
|> strongly_connected_sub_nfas
- |> maps (fn nfa => map (acyclicity_axiom_for_datatype dtypes kk nfa o fst)
- nfa)
+ |> maps (fn nfa =>
+ map (acyclicity_axiom_for_datatype kk dtypes nfa o fst) nfa)
-(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
+(* hol_context -> bool -> int -> kodkod_constrs -> nut NameTable.table
-> KK.rel_expr -> constr_spec -> int -> KK.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,
+fun sel_axiom_for_sel hol_ctxt binarize j0
+ (kk as {kk_all, kk_formula_if, kk_implies, kk_subset, kk_rel_eq, kk_no,
kk_join, ...}) 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 x as (_, T) =
+ binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize const n
val (r, R, arity) = const_triple rel_table x
val R2 = dest_Func R |> snd
val z = (epsilon - delta, delta + j0)
@@ -842,9 +860,9 @@
(kk_n_ary_function kk R2 r') (kk_no r'))
end
end
-(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
+(* hol_context -> bool -> int -> int -> kodkod_constrs -> nut NameTable.table
-> constr_spec -> KK.formula list *)
-fun sel_axioms_for_constr ext_ctxt bits j0 kk rel_table
+fun sel_axioms_for_constr hol_ctxt binarize bits j0 kk rel_table
(constr as {const, delta, epsilon, explicit_max, ...}) =
let
val honors_explicit_max =
@@ -854,31 +872,31 @@
[formula_for_bool honors_explicit_max]
else
let
- val ran_r = discr_rel_expr rel_table const
+ val dom_r = discr_rel_expr rel_table const
val max_axiom =
if honors_explicit_max then
KK.True
else if is_twos_complement_representable bits (epsilon - delta) then
- KK.LE (KK.Cardinality ran_r, KK.Num explicit_max)
+ KK.LE (KK.Cardinality dom_r, KK.Num explicit_max)
else
raise TOO_SMALL ("Nitpick_Kodkod.sel_axioms_for_constr",
"\"bits\" value " ^ string_of_int bits ^
" too small for \"max\"")
in
max_axiom ::
- map (sel_axiom_for_sel ext_ctxt j0 kk rel_table ran_r constr)
+ map (sel_axiom_for_sel hol_ctxt binarize j0 kk rel_table dom_r constr)
(index_seq 0 (num_sels_for_constr_type (snd const)))
end
end
-(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
+(* hol_context -> bool -> int -> int -> kodkod_constrs -> nut NameTable.table
-> dtype_spec -> KK.formula list *)
-fun sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table
+fun sel_axioms_for_datatype hol_ctxt binarize bits j0 kk rel_table
({constrs, ...} : dtype_spec) =
- maps (sel_axioms_for_constr ext_ctxt bits j0 kk rel_table) constrs
+ maps (sel_axioms_for_constr hol_ctxt binarize bits j0 kk rel_table) constrs
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
+(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table -> constr_spec
-> KK.formula list *)
-fun uniqueness_axiom_for_constr ext_ctxt
+fun uniqueness_axiom_for_constr hol_ctxt binarize
({kk_all, kk_implies, kk_and, kk_rel_eq, kk_lone, kk_join, ...}
: kodkod_constrs) rel_table ({const, ...} : constr_spec) =
let
@@ -886,9 +904,10 @@
fun conjunct_for_sel r =
kk_rel_eq (kk_join (KK.Var (1, 0)) r) (kk_join (KK.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 triples =
+ map (const_triple rel_table
+ o binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize const)
+ (~1 upto num_sels - 1)
val j0 = case triples |> hd |> #2 of
Func (Atom (_, j0), _) => j0
| R => raise REP ("Nitpick_Kodkod.uniqueness_axiom_for_constr",
@@ -903,11 +922,11 @@
(fold1 kk_and (map (conjunct_for_sel o #1) (tl triples)))
(kk_rel_eq (KK.Var (1, 0)) (KK.Var (1, 1))))
end
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
+(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table -> dtype_spec
-> KK.formula list *)
-fun uniqueness_axioms_for_datatype ext_ctxt kk rel_table
+fun uniqueness_axioms_for_datatype hol_ctxt binarize kk rel_table
({constrs, ...} : dtype_spec) =
- map (uniqueness_axiom_for_constr ext_ctxt kk rel_table) constrs
+ map (uniqueness_axiom_for_constr hol_ctxt binarize kk rel_table) constrs
(* constr_spec -> int *)
fun effective_constr_max ({delta, epsilon, ...} : constr_spec) = epsilon - delta
@@ -924,31 +943,33 @@
kk_disjoint_sets kk rs]
end
-(* extended_context -> int -> int Typtab.table -> kodkod_constrs
+(* hol_context -> bool -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec -> KK.formula list *)
-fun other_axioms_for_datatype _ _ _ _ _ {deep = false, ...} = []
- | other_axioms_for_datatype ext_ctxt bits ofs kk rel_table
+fun other_axioms_for_datatype _ _ _ _ _ _ {deep = false, ...} = []
+ | other_axioms_for_datatype hol_ctxt binarize bits ofs kk rel_table
(dtype as {typ, ...}) =
let val j0 = offset_of_type ofs typ in
- sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table dtype @
- uniqueness_axioms_for_datatype ext_ctxt kk rel_table dtype @
+ sel_axioms_for_datatype hol_ctxt binarize bits j0 kk rel_table dtype @
+ uniqueness_axioms_for_datatype hol_ctxt binarize kk rel_table dtype @
partition_axioms_for_datatype j0 kk rel_table dtype
end
-(* extended_context -> int -> int Typtab.table -> kodkod_constrs
+(* hol_context -> bool -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec list -> KK.formula list *)
-fun declarative_axioms_for_datatypes ext_ctxt bits ofs kk rel_table dtypes =
- acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes @
- maps (other_axioms_for_datatype ext_ctxt bits ofs kk rel_table) dtypes
+fun declarative_axioms_for_datatypes hol_ctxt binarize bits ofs kk rel_table
+ dtypes =
+ acyclicity_axioms_for_datatypes hol_ctxt binarize kk rel_table dtypes @
+ maps (other_axioms_for_datatype hol_ctxt binarize bits ofs kk rel_table)
+ dtypes
-(* int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> KK.formula *)
-fun kodkod_formula_from_nut bits ofs liberal
+(* int -> int Typtab.table -> kodkod_constrs -> nut -> KK.formula *)
+fun kodkod_formula_from_nut bits ofs
(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 =
+ kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no,
+ kk_lone, 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
@@ -1108,7 +1129,7 @@
else
if is_lone_rep min_R then
if arity_of_rep min_R = 1 then
- kk_subset (kk_product r1 r2) KK.Iden
+ kk_lone (kk_union r1 r2)
else if not both_opt then
(r1, r2) |> is_opt_rep (rep_of u2) ? swap
|-> kk_subset
--- a/src/HOL/Tools/Nitpick/nitpick_model.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_model.ML Fri Feb 19 15:21:57 2010 +0000
@@ -53,32 +53,45 @@
val base_mixfix = "_\<^bsub>base\<^esub>"
val step_mixfix = "_\<^bsub>step\<^esub>"
val abs_mixfix = "\<guillemotleft>_\<guillemotright>"
+val cyclic_co_val_name = "\<omega>"
+val cyclic_const_prefix = "\<xi>"
+val cyclic_type_name = nitpick_prefix ^ cyclic_const_prefix
val opt_flag = nitpick_prefix ^ "opt"
val non_opt_flag = nitpick_prefix ^ "non_opt"
-(* string -> int -> string *)
-fun atom_suffix s j =
- nat_subscript (j + 1)
+type atom_pool = ((string * int) * int list) list
+
+(* atom_pool Unsynchronized.ref -> string -> int -> int -> string *)
+fun nth_atom_suffix pool s j k =
+ (case AList.lookup (op =) (!pool) (s, k) of
+ SOME js =>
+ (case find_index (curry (op =) j) js of
+ ~1 => (Unsynchronized.change pool (cons ((s, k), j :: js));
+ length js + 1)
+ | n => length js - n)
+ | NONE => (Unsynchronized.change pool (cons ((s, k), [j])); 1))
+ |> nat_subscript
|> (s <> "" andalso Symbol.is_ascii_digit (List.last (explode s)))
? prefix "\<^isub>,"
-(* string -> typ -> int -> string *)
-fun atom_name prefix (T as Type (s, _)) j =
+(* atom_pool Unsynchronized.ref -> string -> typ -> int -> int -> string *)
+fun nth_atom_name pool prefix (T as Type (s, _)) j k =
let val s' = shortest_name s in
prefix ^ (if String.isPrefix "\\" s' then s' else substring (s', 0, 1)) ^
- atom_suffix s j
+ nth_atom_suffix pool s j k
end
- | atom_name prefix (T as TFree (s, _)) j =
- prefix ^ perhaps (try (unprefix "'")) s ^ atom_suffix s j
- | atom_name _ T _ = raise TYPE ("Nitpick_Model.atom_name", [T], [])
-(* bool -> typ -> int -> term *)
-fun atom for_auto T j =
+ | nth_atom_name pool prefix (T as TFree (s, _)) j k =
+ prefix ^ perhaps (try (unprefix "'")) s ^ nth_atom_suffix pool s j k
+ | nth_atom_name _ _ T _ _ =
+ raise TYPE ("Nitpick_Model.nth_atom_name", [T], [])
+(* atom_pool Unsynchronized.ref -> bool -> typ -> int -> int -> term *)
+fun nth_atom pool for_auto T j k =
if for_auto then
- Free (atom_name (hd (space_explode "." nitpick_prefix)) T j, T)
+ Free (nth_atom_name pool (hd (space_explode "." nitpick_prefix)) T j k, T)
else
- Const (atom_name "" T j, T)
+ Const (nth_atom_name pool "" T j k, T)
(* term -> real *)
-fun extract_real_number (Const (@{const_name Algebras.divide}, _) $ t1 $ t2) =
+fun extract_real_number (Const (@{const_name divide}, _) $ t1 $ t2) =
real (snd (HOLogic.dest_number t1)) / real (snd (HOLogic.dest_number t2))
| extract_real_number t = real (snd (HOLogic.dest_number t))
(* term * term -> order *)
@@ -97,23 +110,23 @@
the (AList.lookup (op =) bounds (the_rel rel_table name)) handle NUT _ => [[]]
(* term -> term *)
-fun unbit_and_unbox_term (Const (@{const_name FunBox}, _) $ t1) =
- unbit_and_unbox_term t1
- | unbit_and_unbox_term (Const (@{const_name PairBox},
- Type ("fun", [T1, Type ("fun", [T2, T3])]))
- $ t1 $ t2) =
- let val Ts = map unbit_and_unbox_type [T1, T2] in
+fun unarize_and_unbox_term (Const (@{const_name FunBox}, _) $ t1) =
+ unarize_and_unbox_term t1
+ | unarize_and_unbox_term (Const (@{const_name PairBox},
+ Type ("fun", [T1, Type ("fun", [T2, T3])]))
+ $ t1 $ t2) =
+ let val Ts = map unarize_and_unbox_type [T1, T2] in
Const (@{const_name Pair}, Ts ---> Type ("*", Ts))
- $ unbit_and_unbox_term t1 $ unbit_and_unbox_term t2
+ $ unarize_and_unbox_term t1 $ unarize_and_unbox_term t2
end
- | unbit_and_unbox_term (Const (s, T)) = Const (s, unbit_and_unbox_type T)
- | unbit_and_unbox_term (t1 $ t2) =
- unbit_and_unbox_term t1 $ unbit_and_unbox_term t2
- | unbit_and_unbox_term (Free (s, T)) = Free (s, unbit_and_unbox_type T)
- | unbit_and_unbox_term (Var (x, T)) = Var (x, unbit_and_unbox_type T)
- | unbit_and_unbox_term (Bound j) = Bound j
- | unbit_and_unbox_term (Abs (s, T, t')) =
- Abs (s, unbit_and_unbox_type T, unbit_and_unbox_term t')
+ | unarize_and_unbox_term (Const (s, T)) = Const (s, unarize_and_unbox_type T)
+ | unarize_and_unbox_term (t1 $ t2) =
+ unarize_and_unbox_term t1 $ unarize_and_unbox_term t2
+ | unarize_and_unbox_term (Free (s, T)) = Free (s, unarize_and_unbox_type T)
+ | unarize_and_unbox_term (Var (x, T)) = Var (x, unarize_and_unbox_type T)
+ | unarize_and_unbox_term (Bound j) = Bound j
+ | unarize_and_unbox_term (Abs (s, T, t')) =
+ Abs (s, unarize_and_unbox_type T, unarize_and_unbox_term t')
(* typ -> typ -> (typ * typ) * (typ * typ) *)
fun factor_out_types (T1 as Type ("*", [T11, T12]))
@@ -247,12 +260,12 @@
| mk_tuple _ (t :: _) = t
| mk_tuple T [] = raise TYPE ("Nitpick_Model.mk_tuple", [T], [])
-(* string * string * string * string -> scope -> nut list -> nut list
- -> nut list -> nut NameTable.table -> KK.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, bits, datatypes, ofs, ...}
- : scope) sel_names rel_table bounds =
+(* bool -> atom_pool -> string * string * string * string -> scope -> nut list
+ -> nut list -> nut list -> nut NameTable.table -> KK.raw_bound list -> typ
+ -> typ -> rep -> int list list -> term *)
+fun reconstruct_term unfold pool (maybe_name, base_name, step_name, abs_name)
+ ({hol_ctxt as {thy, ctxt, stds, ...}, binarize, card_assigns, bits,
+ datatypes, ofs, ...} : scope) sel_names rel_table bounds =
let
val for_auto = (maybe_name = "")
(* int list list -> int *)
@@ -343,12 +356,12 @@
fun make_fun maybe_opt T1 T2 T' ts1 ts2 =
ts1 ~~ ts2 |> sort (nice_term_ord o pairself fst)
|> make_plain_fun maybe_opt T1 T2
- |> unbit_and_unbox_term
- |> typecast_fun (unbit_and_unbox_type T')
- (unbit_and_unbox_type T1)
- (unbit_and_unbox_type T2)
+ |> unarize_and_unbox_term
+ |> typecast_fun (unarize_and_unbox_type T')
+ (unarize_and_unbox_type T1)
+ (unarize_and_unbox_type T2)
(* (typ * int) list -> typ -> typ -> int -> term *)
- fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j =
+ fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j k =
let
val k1 = card_of_type card_assigns T1
val k2 = card_of_type card_assigns T2
@@ -360,37 +373,42 @@
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
+ | term_for_atom seen (Type ("*", [T1, T2])) _ j k =
+ let
+ val k1 = card_of_type card_assigns T1
+ val k2 = k div k1
+ 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])
+ map3 (fn T => term_for_atom seen T T) [T1, T2]
+ [j div k2, j mod k2] [k1, k2]) (* ### k2 or k1? FIXME *)
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 =
+ | term_for_atom seen @{typ prop} _ j k =
+ HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j k)
+ | 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
+ | term_for_atom _ @{typ unit} _ _ _ = @{const Unity}
+ | term_for_atom seen T _ j k =
+ if T = nat_T andalso is_standard_datatype thy stds 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)
+ HOLogic.mk_number int_T (int_for_atom (k, 0) j)
else if is_fp_iterator_type T then
- HOLogic.mk_number nat_T (card_of_type card_assigns T - j - 1)
+ HOLogic.mk_number nat_T (k - 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 {deep = false, ...} => atom for_auto T j
- | SOME {co, constrs, ...} =>
+ NONE => nth_atom pool for_auto T j k
+ | SOME {deep = false, ...} => nth_atom pool for_auto T j k
+ | SOME {co, standard, constrs, ...} =>
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)
+ (* unit -> term *)
+ fun cyclic_atom () =
+ nth_atom pool for_auto (Type (cyclic_type_name, [])) j k
+ fun cyclic_var () = Var ((nth_atom_name pool "" T j k, 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
@@ -400,8 +418,10 @@
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_xs =
+ map (binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize
+ constr_x)
+ (index_seq 0 (length arg_Ts))
val sel_Rs =
map (fn x => get_first
(fn ConstName (s', T', R) =>
@@ -415,16 +435,18 @@
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
+ val maybe_cyclic = co orelse not standard
in
- if co andalso member (op =) seen (T, j) then
- Var (var ())
+ if maybe_cyclic andalso not (null seen) andalso
+ member (op =) (seen |> unfold ? (fst o split_last)) (T, j) then
+ cyclic_var ()
else if constr_s = @{const_name Word} then
HOLogic.mk_number
(if T = @{typ "unsigned_bit word"} then nat_T else int_T)
(value_of_bits (the_single arg_jsss))
else
let
- val seen = seen |> co ? cons (T, j)
+ val seen = seen |> maybe_cyclic ? cons (T, j)
val ts =
if length arg_Ts = 0 then
[]
@@ -446,7 +468,7 @@
0 => mk_num 0
| n1 => case HOLogic.dest_number t2 |> snd of
1 => mk_num n1
- | n2 => Const (@{const_name Algebras.divide},
+ | n2 => Const (@{const_name divide},
num_T --> num_T --> num_T)
$ mk_num n1 $ mk_num n2)
| _ => raise TERM ("Nitpick_Model.reconstruct_term.\
@@ -456,19 +478,25 @@
(is_abs_fun thy constr_x orelse
constr_s = @{const_name Quot}) then
Const (abs_name, constr_T) $ the_single ts
- else if not for_auto andalso
- constr_s = @{const_name NonStd} then
- Const (fst (dest_Const (the_single ts)), T)
else
list_comb (Const constr_x, ts)
in
- if co then
- let val var = var () in
- if exists_subterm (curry (op =) (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))
+ if maybe_cyclic then
+ let val var = cyclic_var () in
+ if unfold andalso not standard andalso
+ length seen = 1 andalso
+ exists_subterm (fn Const (s, _) =>
+ String.isPrefix cyclic_const_prefix s
+ | t' => t' = var) t then
+ subst_atomic [(var, cyclic_atom ())] t
+ else if exists_subterm (curry (op =) var) t then
+ if co then
+ Const (@{const_name The}, (T --> bool_T) --> T)
+ $ Abs (cyclic_co_val_name, T,
+ Const (@{const_name "op ="}, T --> T --> bool_T)
+ $ Bound 0 $ abstract_over (var, t))
+ else
+ cyclic_atom ()
else
t
end
@@ -479,13 +507,14 @@
(* (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))
+ make_fun true T1 T2 T'
+ (map (fn j => term_for_atom seen T1 T1 j k) (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
+ and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0 1
| 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)
+ if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0) k
else raise REP ("Nitpick_Model.reconstruct_term.term_for_rep", [R])
| term_for_rep seen (Type ("*", [T1, T2])) _ (Struct [R1, R2]) [js] =
let
@@ -523,17 +552,15 @@
raise ARG ("Nitpick_Model.reconstruct_term.term_for_rep",
Refute.string_of_typ T ^ " " ^ string_for_rep R ^ " " ^
string_of_int (length jss))
- in
- polish_funs [] o unbit_and_unbox_term oooo term_for_rep []
- end
+ in polish_funs [] o unarize_and_unbox_term oooo term_for_rep [] end
-(* scope -> nut list -> nut NameTable.table -> KK.raw_bound list -> nut
- -> term *)
-fun term_for_name scope sel_names rel_table bounds name =
+(* atom_pool -> scope -> nut list -> nut NameTable.table -> KK.raw_bound list
+ -> nut -> term *)
+fun term_for_name pool 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)
+ |> reconstruct_term false pool ("", "", "", "") scope sel_names rel_table
+ bounds T T (rep_of name)
end
(* Proof.context -> (string * string * string * string) * Proof.context *)
@@ -586,19 +613,20 @@
-> nut list -> nut list -> nut NameTable.table -> KK.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, stds, wfs,
+ ({hol_ctxt as {thy, ctxt, max_bisim_depth, boxes, stds, wfs,
user_axioms, debug, binary_ints, 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, constr_cache},
- card_assigns, bits, bisim_depth, datatypes, ofs} : scope)
+ binarize, card_assigns, bits, bisim_depth, datatypes, ofs} : scope)
formats all_frees free_names sel_names nonsel_names rel_table bounds =
let
+ val pool = Unsynchronized.ref []
val (wacky_names as (_, base_name, step_name, _), ctxt) =
add_wacky_syntax ctxt
- val ext_ctxt =
+ val hol_ctxt =
{thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
binary_ints = binary_ints, destroy_constrs = destroy_constrs,
@@ -612,14 +640,26 @@
ersatz_table = ersatz_table, skolems = skolems,
special_funs = special_funs, unrolled_preds = unrolled_preds,
wf_cache = wf_cache, constr_cache = constr_cache}
- val scope = {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
- bits = bits, 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
- (* nat -> typ -> nat -> typ *)
- fun nth_value_of_type card T n = term_for_rep T T (Atom (card, 0)) [[n]]
+ val scope = {hol_ctxt = hol_ctxt, binarize = binarize,
+ card_assigns = card_assigns, bits = bits,
+ bisim_depth = bisim_depth, datatypes = datatypes, ofs = ofs}
+ (* bool -> typ -> typ -> rep -> int list list -> term *)
+ fun term_for_rep unfold =
+ reconstruct_term unfold pool wacky_names scope sel_names rel_table bounds
+ (* nat -> typ -> nat -> term *)
+ fun nth_value_of_type card T n =
+ let
+ (* bool -> term *)
+ fun aux unfold = term_for_rep unfold T T (Atom (card, 0)) [[n]]
+ in
+ case aux false of
+ t as Const (s, _) =>
+ if String.isPrefix cyclic_const_prefix s then
+ HOLogic.mk_eq (t, aux true)
+ else
+ t
+ | t => t
+ end
(* nat -> typ -> typ list *)
fun all_values_of_type card T =
index_seq 0 card |> map (nth_value_of_type card T) |> sort nice_term_ord
@@ -639,12 +679,12 @@
val (oper, (t1, T'), T) =
case name of
FreeName (s, T, _) =>
- let val t = Free (s, unbit_and_unbox_type T) in
+ let val t = Free (s, unarize_and_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),
+ user_friendly_const hol_ctxt (base_name, step_name) formats (s, T),
T)
| _ => raise NUT ("Nitpick_Model.reconstruct_hol_model.\
\pretty_for_assign", [name])
@@ -652,7 +692,7 @@
Const (@{const_name undefined}, T')
else
tuple_list_for_name rel_table bounds name
- |> term_for_rep T T' (rep_of name)
+ |> term_for_rep false T T' (rep_of name)
in
Pretty.block (Pretty.breaks
[setmp_show_all_types (Syntax.pretty_term ctxt) t1,
@@ -661,18 +701,21 @@
(* dtype_spec -> Pretty.T *)
fun pretty_for_datatype ({typ, card, complete, ...} : dtype_spec) =
Pretty.block (Pretty.breaks
- [Syntax.pretty_typ ctxt (unbit_and_unbox_type typ), Pretty.str "=",
+ [Syntax.pretty_typ ctxt (unarize_and_unbox_type typ), Pretty.str "=",
Pretty.enum "," "{" "}"
(map (Syntax.pretty_term ctxt) (all_values_of_type card typ) @
(if complete then [] else [Pretty.str unrep]))])
(* typ -> dtype_spec list *)
fun integer_datatype T =
[{typ = T, card = card_of_type card_assigns T, co = false,
- complete = false, concrete = true, deep = true, constrs = []}]
+ standard = true, complete = false, concrete = true, deep = true,
+ constrs = []}]
handle TYPE ("Nitpick_HOL.card_of_type", _, _) => []
val (codatatypes, datatypes) =
datatypes |> filter #deep |> List.partition #co
- ||> append (integer_datatype nat_T @ integer_datatype int_T)
+ ||> append (integer_datatype int_T
+ |> is_standard_datatype thy stds nat_T
+ ? append (integer_datatype nat_T))
val block_of_datatypes =
if show_datatypes andalso not (null datatypes) then
[Pretty.big_list ("Datatype" ^ plural_s_for_list datatypes ^ ":")
@@ -703,8 +746,8 @@
val free_names =
map (fn x as (s, T) =>
case filter (curry (op =) x
- o pairf nickname_of (unbit_and_unbox_type o type_of))
- free_names of
+ o pairf nickname_of (unarize_and_unbox_type o type_of))
+ free_names of
[name] => name
| [] => FreeName (s, T, Any)
| _ => raise TERM ("Nitpick_Model.reconstruct_hol_model",
@@ -724,15 +767,16 @@
(* scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
-> KK.raw_bound list -> term -> bool option *)
-fun prove_hol_model (scope as {ext_ctxt as {thy, ctxt, debug, ...},
+fun prove_hol_model (scope as {hol_ctxt as {thy, ctxt, debug, ...},
card_assigns, ...})
auto_timeout free_names sel_names rel_table bounds prop =
let
+ val pool = Unsynchronized.ref []
(* typ * int -> term *)
fun free_type_assm (T, k) =
let
(* int -> term *)
- val atom = atom true T
+ fun atom j = nth_atom pool true T j k
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 =
@@ -743,7 +787,7 @@
(* 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)
+ term_for_name pool 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 = foldr1 s_conj (freeT_assms @ model_assms)
--- a/src/HOL/Tools/Nitpick/nitpick_mono.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_mono.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,10 +8,10 @@
signature NITPICK_MONO =
sig
datatype sign = Plus | Minus
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
val formulas_monotonic :
- extended_context -> typ -> sign -> term list -> term list -> term -> bool
+ hol_context -> bool -> typ -> sign -> term list -> term list -> term -> bool
end;
structure Nitpick_Mono : NITPICK_MONO =
@@ -35,7 +35,8 @@
CRec of string * typ list
type cdata =
- {ext_ctxt: extended_context,
+ {hol_ctxt: hol_context,
+ binarize: bool,
alpha_T: typ,
max_fresh: int Unsynchronized.ref,
datatype_cache: ((string * typ list) * ctype) list Unsynchronized.ref,
@@ -114,10 +115,10 @@
| 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 [],
+(* hol_context -> bool -> typ -> cdata *)
+fun initial_cdata hol_ctxt binarize alpha_T =
+ ({hol_ctxt = hol_ctxt, binarize = binarize, alpha_T = alpha_T,
+ max_fresh = Unsynchronized.ref 0, datatype_cache = Unsynchronized.ref [],
constr_cache = Unsynchronized.ref []} : cdata)
(* typ -> typ -> bool *)
@@ -129,7 +130,7 @@
fun could_exist_alpha_sub_ctype _ (alpha_T as TFree _) T =
could_exist_alpha_subtype alpha_T T
| could_exist_alpha_sub_ctype thy alpha_T T =
- (T = alpha_T orelse is_datatype thy T)
+ (T = alpha_T orelse is_datatype thy [(NONE, true)] T)
(* ctype -> bool *)
fun exists_alpha_sub_ctype CAlpha = true
@@ -188,7 +189,7 @@
in List.app repair_one (!constr_cache) end
(* cdata -> typ -> ctype *)
-fun fresh_ctype_for_type ({ext_ctxt as {thy, ...}, alpha_T, max_fresh,
+fun fresh_ctype_for_type ({hol_ctxt as {thy, ...}, binarize, alpha_T, max_fresh,
datatype_cache, constr_cache, ...} : cdata) =
let
(* typ -> typ -> ctype *)
@@ -217,7 +218,7 @@
| NONE =>
let
val _ = Unsynchronized.change datatype_cache (cons (z, CRec z))
- val xs = datatype_constrs ext_ctxt T
+ val xs = binarized_and_boxed_datatype_constrs hol_ctxt binarize T
val (all_Cs, constr_Cs) =
fold_rev (fn (_, T') => fn (all_Cs, constr_Cs) =>
let
@@ -264,23 +265,18 @@
end
(* cdata -> styp -> ctype *)
-fun ctype_for_constr (cdata as {ext_ctxt as {thy, ...}, alpha_T, constr_cache,
+fun ctype_for_constr (cdata as {hol_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 => if T = alpha_T then
- let val C = fresh_ctype_for_type cdata T in
- (Unsynchronized.change constr_cache (cons (x, C)); C)
- end
- else
- (fresh_ctype_for_type cdata (body_type T);
- AList.lookup (op =) (!constr_cache) x |> the)
+ | 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
+fun ctype_for_sel (cdata as {hol_ctxt, binarize, ...}) (x as (s, _)) =
+ x |> binarized_and_boxed_constr_for_sel hol_ctxt binarize
+ |> ctype_for_constr cdata |> sel_ctype_from_constr_ctype s
(* literal list -> ctype -> ctype *)
fun instantiate_ctype lits =
@@ -549,8 +545,9 @@
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, ...}) =
+fun consider_term (cdata as {hol_ctxt as {thy, ctxt, stds, fast_descrs,
+ def_table, ...},
+ alpha_T, max_fresh, ...}) =
let
(* typ -> ctype *)
val ctype_for = fresh_ctype_for_type cdata
@@ -667,10 +664,6 @@
in (CFun (ab_set_C, S Minus, 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 Minus, bool_C), accum)
@@ -714,19 +707,6 @@
(CFun (a_set_C, S Minus,
CFun (a_to_b_set_C, S Minus, 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 Minus,
- CFun (right_set_C, S Minus, left_set_C)),
- (gamma, cset |> add_ctype_is_right_unique right_set_C
- |> 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))
@@ -736,24 +716,44 @@
let val dom_C = ctype_for (domain_type T) in
(CFun (dom_C, S Minus, 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 Minus, 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
- let val C = ctype_for T in
- (C, ({bounds = bounds, frees = frees,
- consts = (x, C) :: consts}, cset))
- end)
+ | _ =>
+ if s = @{const_name minus_class.minus} andalso
+ is_set_type (domain_type T) then
+ 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 Minus,
+ CFun (right_set_C, S Minus, left_set_C)),
+ (gamma, cset |> add_ctype_is_right_unique right_set_C
+ |> add_is_sub_ctype right_set_C left_set_C))
+ end
+ else if s = @{const_name ord_class.less_eq} andalso
+ is_set_type (domain_type T) then
+ do_fragile_set_operation T accum
+ else if (s = @{const_name semilattice_inf_class.inf} orelse
+ s = @{const_name semilattice_sup_class.sup}) andalso
+ is_set_type (domain_type T) then
+ do_robust_set_operation T accum
+ else 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 Minus, dom_C), accum)
+ end
+ else
+ (ctype_for_sel cdata x, accum)
+ else if is_constr thy stds x then
+ (ctype_for_constr cdata x, accum)
+ else if is_built_in_const thy stds fast_descrs 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
+ let val C = ctype_for T in
+ (C, ({bounds = bounds, frees = frees,
+ consts = (x, C) :: consts}, cset))
+ end)
| Free (x as (_, T)) =>
(case AList.lookup (op =) frees x of
SOME C => (C, accum)
@@ -806,7 +806,7 @@
in do_term end
(* cdata -> sign -> term -> accumulator -> accumulator *)
-fun consider_general_formula (cdata as {ext_ctxt as {ctxt, ...}, ...}) =
+fun consider_general_formula (cdata as {hol_ctxt as {ctxt, ...}, ...}) =
let
(* typ -> ctype *)
val ctype_for = fresh_ctype_for_type cdata
@@ -885,20 +885,21 @@
val bounteous_consts = [@{const_name bisim}]
(* term -> bool *)
-fun is_harmless_axiom t =
- Term.add_consts t [] |> filter_out (is_built_in_const true)
+fun is_harmless_axiom ({thy, stds, fast_descrs, ...} : hol_context) t =
+ Term.add_consts t []
+ |> filter_out (is_built_in_const thy stds fast_descrs)
|> (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
+fun consider_nondefinitional_axiom (cdata as {hol_ctxt, ...}) sn t =
+ not (is_harmless_axiom hol_ctxt t) ? consider_general_formula cdata sn t
(* cdata -> term -> accumulator -> accumulator *)
-fun consider_definitional_axiom (cdata as {ext_ctxt as {thy, ...}, ...}) t =
+fun consider_definitional_axiom (cdata as {hol_ctxt as {thy, ...}, ...}) t =
if not (is_constr_pattern_formula thy t) then
consider_nondefinitional_axiom cdata Plus t
- else if is_harmless_axiom t then
+ else if is_harmless_axiom hol_ctxt t then
I
else
let
@@ -945,13 +946,14 @@
map (fn (x, C) => string_for_ctype_of_term ctxt lits (Const x) C) consts
|> cat_lines |> print_g
-(* extended_context -> typ -> sign -> term list -> term list -> term -> bool *)
-fun formulas_monotonic (ext_ctxt as {ctxt, ...}) alpha_T sn def_ts nondef_ts
- core_t =
+(* hol_context -> bool -> typ -> sign -> term list -> term list -> term
+ -> bool *)
+fun formulas_monotonic (hol_ctxt as {ctxt, ...}) binarize alpha_T sn 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 cdata as {max_fresh, ...} = initial_cdata hol_ctxt binarize alpha_T
val (gamma, cset) =
(initial_gamma, slack)
|> fold (consider_definitional_axiom cdata) def_ts
--- a/src/HOL/Tools/Nitpick/nitpick_nut.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_nut.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,7 +8,7 @@
signature NITPICK_NUT =
sig
type special_fun = Nitpick_HOL.special_fun
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type scope = Nitpick_Scope.scope
type name_pool = Nitpick_Peephole.name_pool
type rep = Nitpick_Rep.rep
@@ -106,7 +106,7 @@
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 : extended_context -> op2 -> term -> nut
+ val nut_from_term : hol_context -> 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 :
@@ -466,8 +466,8 @@
fun factorize (z as (Type ("*", _), _)) = maps factorize [mk_fst z, mk_snd z]
| factorize z = [z]
-(* extended_context -> op2 -> term -> nut *)
-fun nut_from_term (ext_ctxt as {thy, fast_descrs, special_funs, ...}) eq =
+(* hol_context -> op2 -> term -> nut *)
+fun nut_from_term (hol_ctxt as {thy, stds, fast_descrs, special_funs, ...}) eq =
let
(* string list -> typ list -> term -> nut *)
fun aux eq ss Ts t =
@@ -597,52 +597,68 @@
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]) =>
- (if is_finite_type ext_ctxt (domain_type T) then
+ (if is_finite_type hol_ctxt (domain_type T) then
Cst (True, bool_T, Any)
else case t1 of
Const (@{const_name top}, _) => Cst (False, bool_T, Any)
| _ => 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 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 (x as (s as @{const_name zero_class.zero}, T)), []) =>
+ if is_built_in_const thy stds false x then
+ Cst (Num 0, T, Any)
+ else if is_constr thy stds x then
+ let val (s', T') = discr_for_constr x in
+ Construct ([ConstName (s', T', Any)], T, Any, [])
+ end
+ else
+ ConstName (s, T, Any)
+ | (Const (x as (s as @{const_name one_class.one}, T)), []) =>
+ if is_built_in_const thy stds false x then Cst (Num 1, T, Any)
+ else ConstName (s, T, Any)
+ | (Const (x as (s as @{const_name plus_class.plus}, T)), []) =>
+ if is_built_in_const thy stds false x then Cst (Add, T, Any)
+ else ConstName (s, T, Any)
+ | (Const (@{const_name minus_class.minus},
+ Type ("fun", [T1 as Type ("fun", [_, @{typ bool}]), _])),
+ [t1, t2]) =>
+ Op2 (SetDifference, T1, Any, sub t1, sub t2)
+ | (Const (x as (s as @{const_name minus_class.minus}, T)), []) =>
+ if is_built_in_const thy stds false x then Cst (Subtract, T, Any)
+ else ConstName (s, T, Any)
+ | (Const (x as (s as @{const_name times_class.times}, T)), []) =>
+ if is_built_in_const thy stds false x then Cst (Multiply, T, Any)
+ else ConstName (s, T, Any)
+ | (Const (x as (s as @{const_name div_class.div}, T)), []) =>
+ if is_built_in_const thy stds false x then Cst (Divide, T, Any)
+ else ConstName (s, T, Any)
+ | (t0 as Const (x as (s as @{const_name ord_class.less}, T)),
+ ts as [t1, t2]) =>
+ if is_built_in_const thy stds false x then
+ Op2 (Less, bool_T, Any, sub t1, sub t2)
+ else
+ do_apply t0 ts
+ | (Const (@{const_name ord_class.less_eq},
+ Type ("fun", [Type ("fun", [_, @{typ bool}]), _])),
+ [t1, t2]) =>
+ Op2 (Subset, bool_T, Any, sub t1, sub t2)
+ (* FIXME: find out if this case is necessary *)
+ | (t0 as Const (x as (s as @{const_name ord_class.less_eq}, T)),
+ ts as [t1, t2]) =>
+ if is_built_in_const thy stds false x then
+ Op1 (Not, bool_T, Any, Op2 (Less, bool_T, Any, sub t2, sub t1))
+ else
+ do_apply t0 ts
| (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 uminus_int_inst.uminus_int}, T), []) =>
- let val num_T = domain_type T in
- Op2 (Apply, num_T --> num_T, Any,
- Cst (Subtract, num_T --> num_T --> num_T, Any),
- Cst (Num 0, num_T, Any))
- end
- | (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 (x as (s as @{const_name uminus_class.uminus}, T)), []) =>
+ if is_built_in_const thy stds false x then
+ let val num_T = domain_type T in
+ Op2 (Apply, num_T --> num_T, Any,
+ Cst (Subtract, num_T --> num_T --> num_T, Any),
+ Cst (Num 0, num_T, Any))
+ end
+ else
+ ConstName (s, T, Any)
| (Const (@{const_name unknown}, T), []) => Cst (Unknown, T, Any)
| (Const (@{const_name is_unknown}, T), [t1]) =>
Op1 (IsUnknown, bool_T, Any, sub t1)
@@ -655,18 +671,16 @@
| (Const (@{const_name of_nat},
T as @{typ "unsigned_bit word => signed_bit word"}), []) =>
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)
+ | (Const (@{const_name semilattice_inf_class.inf},
+ Type ("fun", [T1 as Type ("fun", [_, @{typ bool}]), _])),
+ [t1, t2]) =>
+ Op2 (Intersect, T1, Any, sub t1, sub t2)
+ | (Const (@{const_name semilattice_sup_class.sup},
+ Type ("fun", [T1 as Type ("fun", [_, @{typ bool}]), _])),
+ [t1, t2]) =>
+ Op2 (Union, T1, Any, sub t1, sub t2)
| (t0 as Const (x as (s, T)), ts) =>
- if is_constr thy x then
+ if is_constr thy stds 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)
@@ -678,7 +692,7 @@
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
+ (case arity_of_built_in_const thy stds fast_descrs x of
SOME n =>
(case n - length ts of
0 => raise TERM ("Nitpick_Nut.nut_from_term.aux", [t])
@@ -712,7 +726,7 @@
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,
+fun choose_rep_for_const (scope as {hol_ctxt as {thy, ctxt, ...}, datatypes,
ofs, ...}) all_exact v (vs, table) =
let
val x as (s, T) = (nickname_of v, type_of v)
@@ -747,10 +761,10 @@
(* 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 as (_, T)) n
- (vs, table) =
+fun choose_rep_for_nth_sel_for_constr (scope as {hol_ctxt, binarize, ...})
+ (x as (_, T)) n (vs, table) =
let
- val (s', T') = boxed_nth_sel_for_constr ext_ctxt x n
+ val (s', T') = binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize x n
val R' = if n = ~1 orelse is_word_type (body_type T) orelse
(is_fun_type (range_type T') andalso
is_boolean_type (body_type T')) then
@@ -890,9 +904,9 @@
| 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,
+fun choose_reps_in_nut (scope as {hol_ctxt as {thy, ctxt, ...}, card_assigns,
bits, datatypes, ofs, ...})
- liberal table def =
+ unsound table def =
let
val bool_atom_R = Atom (2, offset_of_type ofs bool_T)
(* polarity -> bool -> rep *)
@@ -1036,7 +1050,7 @@
if is_constructive u then s_op2 Eq T (Formula Neut) u1' u2'
else opt_opt_case ()
in
- if liberal orelse polar = Neg orelse
+ if unsound orelse polar = Neg orelse
is_concrete_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 ()
@@ -1138,7 +1152,7 @@
else
let val quant_u = s_op2 oper T (Formula polar) u1' u2' in
if def orelse
- (liberal andalso (polar = Pos) = (oper = All)) orelse
+ (unsound andalso (polar = Pos) = (oper = All)) orelse
is_complete_type datatypes (type_of u1) then
quant_u
else
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_preproc.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,1431 @@
+(* Title: HOL/Tools/Nitpick/nitpick_preproc.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009, 2010
+
+Nitpick's HOL preprocessor.
+*)
+
+signature NITPICK_PREPROC =
+sig
+ type hol_context = Nitpick_HOL.hol_context
+ val preprocess_term :
+ hol_context -> term
+ -> ((term list * term list) * (bool * bool)) * term * bool
+end
+
+structure Nitpick_Preproc : NITPICK_PREPROC =
+struct
+
+open Nitpick_Util
+open Nitpick_HOL
+
+(* 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})
+
+(** Binary coding of integers **)
+
+(* If a formula contains a numeral whose absolute value is more than this
+ threshold, the unary coding is likely not to work well and we prefer the
+ binary coding. *)
+val binary_int_threshold = 3
+
+(* term -> bool *)
+fun may_use_binary_ints (t1 $ t2) =
+ may_use_binary_ints t1 andalso may_use_binary_ints t2
+ | may_use_binary_ints (t as Const (s, _)) =
+ t <> @{const Suc} andalso
+ not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
+ @{const_name nat_gcd}, @{const_name nat_lcm},
+ @{const_name Frac}, @{const_name norm_frac}] s)
+ | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
+ | may_use_binary_ints _ = true
+fun should_use_binary_ints (t1 $ t2) =
+ should_use_binary_ints t1 orelse should_use_binary_ints t2
+ | should_use_binary_ints (Const (s, T)) =
+ ((s = @{const_name times} orelse s = @{const_name div}) andalso
+ is_integer_type (body_type T)) orelse
+ (String.isPrefix numeral_prefix s andalso
+ let val n = the (Int.fromString (unprefix numeral_prefix s)) in
+ n < ~ binary_int_threshold orelse n > binary_int_threshold
+ end)
+ | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
+ | should_use_binary_ints _ = false
+
+(** Uncurrying **)
+
+(* 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 thy [(NONE, true)] true 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 -> int -> string *)
+fun uncurry_prefix_for k j =
+ uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+
+(* 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
+
+(** Boxing **)
+
+(* hol_context -> typ -> term -> term *)
+fun constr_expand (hol_ctxt as {thy, stds, ...}) 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 hol_ctxt T |> hd
+ val arg_Ts = binder_types T'
+ in
+ list_comb (Const x', map2 (select_nth_constr_arg thy stds x' t)
+ (index_seq 0 (length arg_Ts)) arg_Ts)
+ end
+
+(* hol_context -> bool -> term -> term *)
+fun box_fun_and_pair_in_term (hol_ctxt as {thy, stds, 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 hol_ctxt InPair) Ts)
+ | box_relational_operator_type T = T
+ (* (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
+ (* 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 stds
+ (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
+ o single
+ | t' => raise TERM ("Nitpick_Preproc.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 = @{type_name fun_box} orelse
+ old_s = @{type_name pair_box} orelse old_s = "*" then
+ case constr_expand hol_ctxt 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 stds
+ (@{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 stds
+ (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 ("Nitpick_Preproc.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 ("Nitpick_Preproc.box_fun_and_pair_in_term.\
+ \add_boxed_types_for_var", [T'], []))
+ | _ => exists_subterm (curry (op =) (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 = @{const_name "=="} orelse s0 = @{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 hol_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 hol_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 (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
+ let val T' = box_type hol_ctxt InSel T2 in
+ Const (@{const_name quot_normal}, T' --> T')
+ end
+ | Const (s as @{const_name Tha}, T) => do_description_operator s T
+ | Const (x as (s, T)) =>
+ Const (s, if s = @{const_name converse} orelse
+ s = @{const_name trancl} then
+ box_relational_operator_type T
+ else if is_built_in_const thy stds fast_descrs x orelse
+ s = @{const_name Sigma} then
+ T
+ else if is_constr_like thy x then
+ box_type hol_ctxt InConstr T
+ else if is_sel s
+ orelse is_rep_fun thy x then
+ box_type hol_ctxt InSel T
+ else
+ box_type hol_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 stds
+ (@{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 stds
+ (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
+ (Type ("fun", Ts1)), t2)
+ end
+ | Free (s, T) => Free (s, box_type hol_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 hol_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
+
+(** Destruction of constructors **)
+
+val val_var_prefix = nitpick_prefix ^ "v"
+
+(* 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))
+
+(* 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
+
+(* hol_context -> typ list -> bool -> int -> int -> term -> term list
+ -> term list -> term * term list *)
+fun pull_out_constr_comb ({thy, stds, ...} : hol_context) 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 stds 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 (curry (op =) 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
+
+(* hol_context -> bool -> term -> term *)
+fun pull_out_universal_constrs hol_ctxt 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 true def t0 t1 t2 seen
+ | (t0 as @{const "==>"}) $ t1 $ t2 =>
+ if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
+ | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
+ do_eq_or_imp Ts true def t0 t1 t2 seen
+ | (t0 as @{const "op -->"}) $ t1 $ t2 =>
+ do_eq_or_imp Ts false 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 hol_ctxt Ts def k 0 t args seen
+ (* typ list -> bool -> bool -> term -> term -> term -> term list
+ -> term * term list *)
+ and do_eq_or_imp Ts eq def t0 t1 t2 seen =
+ let
+ val (t2, seen) = if eq andalso def then (t2, seen)
+ else do_term Ts false 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
+
+(* term -> term -> term *)
+fun mk_exists v t =
+ HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
+
+(* hol_context -> term -> term *)
+fun pull_out_existential_constrs hol_ctxt 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 hol_ctxt Ts false k num_exists t args seen
+ else
+ (list_comb (t, args), seen)
+ in aux [] 0 t [] [] |> fst end
+
+(* hol_context -> bool -> term -> term *)
+fun destroy_pulled_out_constrs (hol_ctxt as {thy, stds, ...}) 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
+ (* The first case is not as general as it could be. *)
+ (Const (@{const_name PairBox}, _),
+ [Const (@{const_name fst}, _) $ Var z1,
+ Const (@{const_name snd}, _) $ Var z2]) =>
+ if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
+ else raise SAME ()
+ | (Const (x as (s, T)), args) =>
+ let val arg_Ts = binder_types T in
+ if length arg_Ts = length args andalso
+ (is_constr thy stds x orelse s = @{const_name Pair}) andalso
+ (not careful orelse not (is_Var t1) orelse
+ String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
+ discriminate_value hol_ctxt x t1 ::
+ map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
+ |> foldr1 s_conj
+ else
+ raise SAME ()
+ end
+ | _ => raise SAME ())
+ |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
+ 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 stds x t n nth_T
+ |> aux false
+ in aux axiom t end
+
+(** Destruction of universal and existential equalities **)
+
+(* 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 (member (op =) zs z) andalso
+ not (exists_subterm (curry (op =) (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 -> (typ option * bool) list -> int -> term list -> term list
+ -> (term * term list) option *)
+fun find_bound_assign thy stds j =
+ let
+ (* term list -> term list -> (term * term list) option *)
+ fun do_term _ [] = NONE
+ | do_term seen (t :: ts) =
+ let
+ (* bool -> term -> term -> (term * term list) option *)
+ fun do_eq pass1 t1 t2 =
+ (if loose_bvar1 (t2, j) then
+ if pass1 then do_eq 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 = nth_sel_name_for_constr_name @{const_name FunBox} 0 then
+ SOME (construct_value thy stds (@{const_name FunBox}, T2 --> T1)
+ [t2], ts @ seen)
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => do_term (t :: seen) ts
+ in
+ case t of
+ Const (@{const_name "op ="}, _) $ t1 $ t2 => do_eq true t1 t2
+ | _ => do_term (t :: seen) ts
+ end
+ in do_term end
+
+(* int -> term -> term -> term *)
+fun subst_one_bound j arg t =
+ let
+ (* term * int -> term *)
+ 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
+
+(* hol_context -> term -> term *)
+fun destroy_existential_equalities ({thy, stds, ...} : hol_context) =
+ 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 stds (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_of (gather [] [] t))
+ in gather [] [] end
+
+(** Skolemization **)
+
+(* int -> int -> string *)
+fun skolem_prefix_for k j =
+ skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+
+(* hol_context -> int -> term -> term *)
+fun skolemize_term_and_more (hol_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 hol_ctxt x andalso
+ not (is_well_founded_inductive_pred hol_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 semilattice_sup_class.sup})
+ else
+ (ubfp_prefix, @{const "op &"},
+ @{const_name semilattice_inf_class.inf})
+ (* unit -> term *)
+ fun pos () = unrolled_inductive_pred_const hol_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.foldr 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
+
+(** Function specialization **)
+
+(* 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 (curry (op =) t) fixed_params in
+ list_comb (if j >= 0 then nth fixed_args j else t, args)
+ end
+ in aux [] t end
+
+(* hol_context -> styp -> (int * term option) list *)
+fun static_args_in_term ({ersatz_table, ...} : hol_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
+(* hol_context -> styp -> term list -> (int * term option) list *)
+fun static_args_in_terms hol_ctxt x =
+ map (static_args_in_term hol_ctxt x)
+ #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
+
+(* (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
+
+(* 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 -> string *)
+fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
+
+(* If a constant's definition is picked up deeper than this threshold, we
+ prevent excessive specialization by not specializing it. *)
+val special_max_depth = 20
+
+val bound_var_prefix = "b"
+
+(* hol_context -> int -> term -> term *)
+fun specialize_consts_in_term (hol_ctxt as {thy, specialize, simp_table,
+ special_funs, ...}) depth t =
+ if not specialize orelse depth > special_max_depth then
+ t
+ else
+ let
+ 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 (member (op =) blacklist x) andalso not (null args) andalso
+ not (String.isPrefix special_prefix s) andalso
+ is_equational_fun hol_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 hol_ctxt x
+ |> map (destroy_existential_equalities hol_ctxt)
+ val static_params = static_args_in_terms hol_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 (curry (op =) 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
+
+type special_triple = int list * term list * styp
+
+val cong_var_prefix = "c"
+
+(* styp -> special_triple -> special_triple -> 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 Integer.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)))
+ |> close_form (* TODO: needed? *)
+ end
+
+(* hol_context -> styp list -> term list *)
+fun special_congruence_axioms (hol_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 hol_ctxt o fst)
+ |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
+ (* special_triple -> int *)
+ fun generality (js, _, _) = ~(length js)
+ (* special_triple -> special_triple -> 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_triple list -> special_triple list -> special_triple 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_triple 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
+
+(** Axiom selection **)
+
+(* 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)
+
+(* '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)]
+
+(* int -> term -> term *)
+fun eval_axiom_for_term j t =
+ Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
+
+(* term -> bool *)
+val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
+
+(* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
+val axioms_max_depth = 255
+
+(* hol_context -> term -> (term list * term list) * (bool * bool) *)
+fun axioms_for_term
+ (hol_ctxt as {thy, max_bisim_depth, stds, 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 hol_ctxt
+ |> skolemize_term_and_more hol_ctxt ~1
+ in
+ if is_trivial_equation t then
+ accum
+ else
+ let val t' = t |> specialize_consts_in_term hol_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_def_axiom depth = add_axiom fst apfst depth
+ and add_nondef_axiom depth = add_axiom snd apsnd depth
+ and add_maybe_def_axiom depth t =
+ (if head_of t <> @{const "==>"} then add_def_axiom
+ else add_nondef_axiom) depth t
+ and add_eq_axiom depth t =
+ (if is_constr_pattern_formula thy t then add_def_axiom
+ else add_nondef_axiom) 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 member (op =) xs x orelse
+ is_built_in_const thy stds fast_descrs x then
+ accum
+ else
+ let val accum as (xs, _) = (x :: xs, axs) in
+ if depth > axioms_max_depth then
+ raise TOO_LARGE ("Nitpick_Preproc.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_maybe_def_axiom depth) (map_filter I [ax1, ax2])
+ accum
+ end
+ else if is_constr thy stds x then
+ accum
+ else if is_equational_fun hol_ctxt x then
+ fold (add_eq_axiom depth) (equational_fun_axioms hol_ctxt x)
+ accum
+ else if is_abs_fun thy x then
+ if is_quot_type thy (range_type T) then
+ raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
+ else
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> is_funky_typedef thy (range_type T)
+ ? fold (add_maybe_def_axiom depth)
+ (nondef_props_for_const thy true
+ (extra_table def_table s) x)
+ else if is_rep_fun thy x then
+ if is_quot_type thy (domain_type T) then
+ raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
+ else
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> is_funky_typedef thy (range_type T)
+ ? fold (add_maybe_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))
+ |> fold (add_def_axiom depth)
+ (inverse_axioms_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 (s, Ts)) =>
+ fold (add_axioms_for_type depth) Ts
+ #> (if is_pure_typedef thy T then
+ fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
+ else if is_quot_type thy T then
+ fold (add_def_axiom depth) (optimized_quot_type_axioms thy stds z)
+ else if max_bisim_depth >= 0 andalso is_codatatype thy T then
+ fold (add_maybe_def_axiom depth)
+ (codatatype_bisim_axioms hol_ctxt 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 ("Nitpick_Preproc.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 hol_ctxt xs
+ in
+ ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
+ null poly_user_nondefs))
+ end
+
+(** Simplification of constructor/selector terms **)
+
+(* 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
+
+(** Quantifier massaging: Distributing quantifiers **)
+
+(* 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
+
+(** Quantifier massaging: Pushing quantifiers inward **)
+
+(* 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
+
+(* Maximum number of quantifiers in a cluster for which the exponential
+ algorithm is used. Larger clusters use a heuristic inspired by Claessen &
+ Sörensson's polynomial binary splitting procedure (p. 5 of their MODEL 2003
+ paper). *)
+val quantifier_cluster_threshold = 7
+
+(* 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 then
+ aux s0 (s1 :: ss) (T1 :: Ts) t1
+ else if quant_s = "" andalso
+ (s0 = @{const_name All} orelse s0 = @{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 list * int) list *)
+ fun merge costly_boundss [] = costly_boundss
+ | merge costly_boundss (j :: js) =
+ let
+ val (yeas, nays) =
+ List.partition (fn (bounds, _) =>
+ member (op =) bounds j)
+ costly_boundss
+ val yeas_bounds = big_union fst yeas
+ val yeas_cost = Integer.sum (map snd yeas)
+ * nth T_costs j
+ in merge ((yeas_bounds, yeas_cost) :: nays) js end
+ (* (int list * int) list -> int list -> int *)
+ val cost = Integer.sum o map snd oo merge
+ (* (int list * int) list -> int list -> int list *)
+ fun heuristically_best_permutation _ [] = []
+ | heuristically_best_permutation costly_boundss js =
+ let
+ val (costly_boundss, (j, js)) =
+ js |> map (`(merge costly_boundss o single))
+ |> sort (int_ord
+ o pairself (Integer.sum o map snd o fst))
+ |> split_list |>> hd ||> pairf hd tl
+ in
+ j :: heuristically_best_permutation costly_boundss js
+ end
+ val js =
+ if length Ts <= quantifier_cluster_threshold then
+ all_permutations (index_seq 0 num_Ts)
+ |> map (`(cost (t_boundss ~~ t_costs)))
+ |> sort (int_ord o pairself fst) |> hd |> snd
+ else
+ heuristically_best_permutation (t_boundss ~~ t_costs)
+ (index_seq 0 num_Ts)
+ val back_js = map (fn j => find_index (curry (op =) 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 ("Nitpick_Preproc.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) =>
+ member (op =) bounds j)
+ 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
+
+(** Preprocessor entry point **)
+
+(* hol_context -> term
+ -> ((term list * term list) * (bool * bool)) * term * bool *)
+fun preprocess_term (hol_ctxt as {thy, stds, binary_ints, 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 hol_ctxt
+ |> close_form
+ |> skolemize_term_and_more hol_ctxt skolem_depth
+ |> specialize_consts_in_term hol_ctxt 0
+ |> `(axioms_for_term hol_ctxt)
+ val binarize =
+ is_standard_datatype thy stds nat_T andalso
+ case binary_ints of
+ SOME false => false
+ | _ => forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
+ (binary_ints = SOME true orelse
+ exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
+ val 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 =
+ binarize ? binarize_nat_and_int_in_term
+ #> uncurry ? uncurry_term table
+ #> box ? box_fun_and_pair_in_term hol_ctxt def
+ #> destroy_constrs ? (pull_out_universal_constrs hol_ctxt def
+ #> pull_out_existential_constrs hol_ctxt
+ #> destroy_pulled_out_constrs hol_ctxt def)
+ #> curry_assms
+ #> destroy_universal_equalities
+ #> destroy_existential_equalities hol_ctxt
+ #> simplify_constrs_and_sels thy
+ #> distribute_quantifiers
+ #> push_quantifiers_inward thy
+ #> close_form
+ #> Term.map_abs_vars shortest_name
+ 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, binarize)
+ end
+
+end;
--- a/src/HOL/Tools/Nitpick/nitpick_scope.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,7 +8,7 @@
signature NITPICK_SCOPE =
sig
type styp = Nitpick_Util.styp
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type constr_spec = {
const: styp,
@@ -22,13 +22,15 @@
typ: typ,
card: int,
co: bool,
+ standard: bool,
complete: bool,
concrete: bool,
deep: bool,
constrs: constr_spec list}
type scope = {
- ext_ctxt: extended_context,
+ hol_ctxt: hol_context,
+ binarize: bool,
card_assigns: (typ * int) list,
bits: int,
bisim_depth: int,
@@ -47,7 +49,7 @@
val scopes_equivalent : scope -> scope -> bool
val scope_less_eq : scope -> scope -> bool
val all_scopes :
- extended_context -> int -> (typ option * int list) list
+ hol_context -> bool -> int -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list
-> int list -> int list -> typ list -> typ list -> typ list
-> int * scope list
@@ -71,13 +73,15 @@
typ: typ,
card: int,
co: bool,
+ standard: bool,
complete: bool,
concrete: bool,
deep: bool,
constrs: constr_spec list}
type scope = {
- ext_ctxt: extended_context,
+ hol_ctxt: hol_context,
+ binarize: bool,
card_assigns: (typ * int) list,
bits: int,
bisim_depth: int,
@@ -107,7 +111,7 @@
| is_complete_type dtypes (Type ("*", Ts)) =
forall (is_complete_type dtypes) Ts
| is_complete_type dtypes T =
- not (is_integer_type T) andalso not (is_bit_type T) andalso
+ not (is_integer_like_type T) andalso not (is_bit_type T) andalso
#complete (the (datatype_spec dtypes T))
handle Option.Option => true
and is_concrete_type dtypes (Type ("fun", [T1, T2])) =
@@ -131,16 +135,17 @@
(* (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,
- bits, bisim_depth, datatypes, ...} : scope) =
+fun quintuple_for_scope quote
+ ({hol_ctxt as {thy, ctxt, stds, ...}, card_assigns, bits, bisim_depth,
+ datatypes, ...} : scope) =
let
- val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit}, @{typ \<xi>},
+ val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit},
@{typ bisim_iterator}]
val (iter_assigns, card_assigns) =
card_assigns |> filter_out (member (op =) boring_Ts o fst)
|> List.partition (is_fp_iterator_type o fst)
val (secondary_card_assigns, primary_card_assigns) =
- card_assigns |> List.partition ((is_integer_type orf is_datatype thy)
+ card_assigns |> List.partition ((is_integer_type orf is_datatype thy stds)
o fst)
val cards =
map (fn (T, k) => quote (string_for_type ctxt T) ^ " = " ^
@@ -162,7 +167,7 @@
fun miscs () =
(if bits = 0 then [] else ["bits = " ^ string_of_int bits]) @
(if bisim_depth < 0 andalso forall (not o #co) datatypes then []
- else ["bisim_depth = " ^ string_of_int bisim_depth])
+ else ["bisim_depth = " ^ signed_string_of_int bisim_depth])
in
setmp_show_all_types
(fn () => (cards primary_card_assigns, cards secondary_card_assigns,
@@ -240,10 +245,10 @@
val max_bits = 31 (* Kodkod limit *)
-(* extended_context -> (typ option * int list) list
+(* hol_context -> bool -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list -> int list
-> int list -> typ -> block *)
-fun block_for_type (ext_ctxt as {thy, ...}) cards_assigns maxes_assigns
+fun block_for_type (hol_ctxt as {thy, ...}) binarize cards_assigns maxes_assigns
iters_assigns bitss bisim_depths T =
if T = @{typ unsigned_bit} then
[(Card T, map (Integer.min max_bits o Integer.max 1) bitss)]
@@ -261,18 +266,18 @@
(const_for_iterator_type T)))]
else
(Card T, lookup_type_ints_assign thy cards_assigns T) ::
- (case datatype_constrs ext_ctxt T of
+ (case binarized_and_boxed_datatype_constrs hol_ctxt binarize T of
[_] => []
| constrs => map_filter (row_for_constr thy maxes_assigns) constrs)
-(* extended_context -> (typ option * int list) list
+(* hol_context -> bool -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list -> int list
-> int list -> typ list -> typ list -> block list *)
-fun blocks_for_types ext_ctxt cards_assigns maxes_assigns iters_assigns bitss
- bisim_depths mono_Ts nonmono_Ts =
+fun blocks_for_types hol_ctxt binarize cards_assigns maxes_assigns iters_assigns
+ bitss bisim_depths mono_Ts nonmono_Ts =
let
(* typ -> block *)
- val block_for = block_for_type ext_ctxt cards_assigns maxes_assigns
+ val block_for = block_for_type hol_ctxt binarize cards_assigns maxes_assigns
iters_assigns bitss bisim_depths
val mono_block = maps block_for mono_Ts
val nonmono_blocks = map block_for nonmono_Ts
@@ -313,10 +318,10 @@
type scope_desc = (typ * int) list * (styp * int) list
-(* extended_context -> scope_desc -> typ * int -> bool *)
-fun is_surely_inconsistent_card_assign ext_ctxt (card_assigns, max_assigns)
- (T, k) =
- case datatype_constrs ext_ctxt T of
+(* hol_context -> bool -> scope_desc -> typ * int -> bool *)
+fun is_surely_inconsistent_card_assign hol_ctxt binarize
+ (card_assigns, max_assigns) (T, k) =
+ case binarized_and_boxed_datatype_constrs hol_ctxt binarize T of
[] => false
| xs =>
let
@@ -329,21 +334,22 @@
| effective_max card max = Int.min (card, max)
val max = map2 effective_max dom_cards maxes |> Integer.sum
in max < k end
-(* extended_context -> (typ * int) list -> (typ * int) list
+(* hol_context -> bool -> (typ * int) list -> (typ * int) list
-> (styp * int) list -> bool *)
-fun is_surely_inconsistent_scope_description ext_ctxt seen rest max_assigns =
- exists (is_surely_inconsistent_card_assign ext_ctxt
+fun is_surely_inconsistent_scope_description hol_ctxt binarize seen rest
+ max_assigns =
+ exists (is_surely_inconsistent_card_assign hol_ctxt binarize
(seen @ rest, max_assigns)) seen
-(* extended_context -> scope_desc -> (typ * int) list option *)
-fun repair_card_assigns ext_ctxt (card_assigns, max_assigns) =
+(* hol_context -> bool -> scope_desc -> (typ * int) list option *)
+fun repair_card_assigns hol_ctxt binarize (card_assigns, max_assigns) =
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) :: rest) =
- (if is_surely_inconsistent_scope_description ext_ctxt ((T, k) :: seen)
- rest max_assigns then
+ (if is_surely_inconsistent_scope_description hol_ctxt binarize
+ ((T, k) :: seen) rest max_assigns then
raise SAME ()
else
case aux ((T, k) :: seen) rest of
@@ -374,13 +380,14 @@
(* block -> scope_desc *)
fun scope_descriptor_from_block block =
fold_rev add_row_to_scope_descriptor block ([], [])
-(* extended_context -> block list -> int list -> scope_desc option *)
-fun scope_descriptor_from_combination (ext_ctxt as {thy, ...}) blocks columns =
+(* hol_context -> bool -> block list -> int list -> scope_desc option *)
+fun scope_descriptor_from_combination (hol_ctxt as {thy, ...}) binarize blocks
+ columns =
let
val (card_assigns, max_assigns) =
maps project_block (columns ~~ blocks) |> scope_descriptor_from_block
- val card_assigns = repair_card_assigns ext_ctxt (card_assigns, max_assigns)
- |> the
+ val card_assigns =
+ repair_card_assigns hol_ctxt binarize (card_assigns, max_assigns) |> the
in
SOME (map (repair_iterator_assign thy card_assigns) card_assigns,
max_assigns)
@@ -394,7 +401,8 @@
-> int Typtab.table *)
fun aux next _ [] = Typtab.update_new (dummyT, next)
| aux next reusable ((T, k) :: assigns) =
- if k = 1 orelse is_integer_type T orelse is_bit_type T then
+ if k = 1 orelse is_fp_iterator_type T orelse is_integer_type T
+ orelse T = @{typ bisim_iterator} orelse is_bit_type T then
aux next reusable assigns
else if length (these (Option.map #constrs (datatype_spec dtypes T)))
> 1 then
@@ -427,15 +435,21 @@
{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_assigns T = 1 then
- {delta = 0, epsilon = 1,
- exclusive = (s = @{const_name Nil} andalso length constrs = 2),
- total = true}
- else if s = @{const_name Cons} andalso length constrs = 2 then
- {delta = 1, epsilon = card, exclusive = true, total = false}
- else
- {delta = 0, epsilon = card, exclusive = false, total = false}
+ (if num_self_recs = 1 andalso num_non_self_recs = 1 then
+ if self_rec then
+ case constrs of
+ [{delta = 0, epsilon = 1, exclusive = true, ...}] =>
+ {delta = 1, epsilon = card, exclusive = true, total = false}
+ | _ => raise SAME ()
+ else
+ if domain_card 2 card_assigns T = 1 then
+ {delta = 0, epsilon = 1, exclusive = true, total = true}
+ else
+ raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () =>
+ {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_assigns T,
@@ -449,34 +463,37 @@
explicit_max = max, total = total} :: constrs
end
-(* extended_context -> (typ * int) list -> typ -> bool *)
-fun has_exact_card ext_ctxt card_assigns T =
+(* hol_context -> (typ * int) list -> typ -> bool *)
+fun has_exact_card hol_ctxt card_assigns T =
let val card = card_of_type card_assigns T in
- card = bounded_exact_card_of_type ext_ctxt (card + 1) 0 card_assigns T
+ card = bounded_exact_card_of_type hol_ctxt (card + 1) 0 card_assigns T
end
-(* extended_context -> typ list -> scope_desc -> typ * int -> dtype_spec *)
-fun datatype_spec_from_scope_descriptor (ext_ctxt as {thy, ...}) deep_dataTs
- (desc as (card_assigns, _)) (T, card) =
+(* hol_context -> bool -> typ list -> scope_desc -> typ * int -> dtype_spec *)
+fun datatype_spec_from_scope_descriptor (hol_ctxt as {thy, stds, ...}) binarize
+ deep_dataTs (desc as (card_assigns, _)) (T, card) =
let
val deep = member (op =) deep_dataTs T
val co = is_codatatype thy T
- val xs = boxed_datatype_constrs ext_ctxt T
+ val standard = is_standard_datatype thy stds T
+ val xs = binarized_and_boxed_datatype_constrs hol_ctxt binarize T
val self_recs = map (is_self_recursive_constr_type o snd) xs
val (num_self_recs, num_non_self_recs) =
List.partition I self_recs |> pairself length
- val complete = has_exact_card ext_ctxt card_assigns T
- val concrete = xs |> maps (binder_types o snd) |> maps binder_types
- |> forall (has_exact_card ext_ctxt card_assigns)
+ val complete = has_exact_card hol_ctxt card_assigns T
+ val concrete = is_word_type T orelse
+ (xs |> maps (binder_types o snd) |> maps binder_types
+ |> forall (has_exact_card hol_ctxt card_assigns))
(* int -> int *)
fun sum_dom_cards max =
map (domain_card max card_assigns 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) []
+ num_non_self_recs)
+ (sort (bool_ord o swap o pairself fst) (self_recs ~~ xs)) []
in
- {typ = T, card = card, co = co, complete = complete, concrete = concrete,
- deep = deep, constrs = constrs}
+ {typ = T, card = card, co = co, standard = standard, complete = complete,
+ concrete = concrete, deep = deep, constrs = constrs}
end
(* int -> int *)
@@ -487,21 +504,21 @@
min_bits_for_nat_value (fold Integer.max
(map snd card_assigns @ map snd max_assigns) 0)
-(* extended_context -> int -> typ list -> scope_desc -> scope *)
-fun scope_from_descriptor (ext_ctxt as {thy, ...}) sym_break deep_dataTs
- (desc as (card_assigns, _)) =
+(* hol_context -> bool -> int -> typ list -> scope_desc -> scope *)
+fun scope_from_descriptor (hol_ctxt as {thy, stds, ...}) binarize sym_break
+ deep_dataTs (desc as (card_assigns, _)) =
let
val datatypes =
- map (datatype_spec_from_scope_descriptor ext_ctxt deep_dataTs desc)
- (filter (is_datatype thy o fst) card_assigns)
+ map (datatype_spec_from_scope_descriptor hol_ctxt binarize deep_dataTs
+ desc) (filter (is_datatype thy stds o fst) card_assigns)
val bits = card_of_type card_assigns @{typ signed_bit} - 1
handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
card_of_type card_assigns @{typ unsigned_bit}
handle TYPE ("Nitpick_HOL.card_of_type", _, _) => 0
val bisim_depth = card_of_type card_assigns @{typ bisim_iterator} - 1
in
- {ext_ctxt = ext_ctxt, card_assigns = card_assigns, datatypes = datatypes,
- bits = bits, bisim_depth = bisim_depth,
+ {hol_ctxt = hol_ctxt, binarize = binarize, card_assigns = card_assigns,
+ datatypes = datatypes, bits = bits, bisim_depth = bisim_depth,
ofs = if sym_break <= 0 then Typtab.empty
else offset_table_for_card_assigns thy card_assigns datatypes}
end
@@ -511,7 +528,7 @@
fun repair_cards_assigns_wrt_boxing _ _ [] = []
| repair_cards_assigns_wrt_boxing thy Ts ((SOME T, ks) :: cards_assigns) =
(if is_fun_type T orelse is_pair_type T then
- Ts |> filter (curry (type_match thy o swap) T o unbit_and_unbox_type)
+ Ts |> filter (curry (type_match thy o swap) T o unarize_and_unbox_type)
|> map (rpair ks o SOME)
else
[(SOME T, ks)]) @ repair_cards_assigns_wrt_boxing thy Ts cards_assigns
@@ -521,26 +538,29 @@
val max_scopes = 4096
val distinct_threshold = 512
-(* extended_context -> int -> (typ option * int list) list
+(* hol_context -> bool -> int -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list -> int list
-> typ list -> typ list -> typ list -> int * scope list *)
-fun all_scopes (ext_ctxt as {thy, ...}) sym_break cards_assigns maxes_assigns
- iters_assigns bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs =
+fun all_scopes (hol_ctxt as {thy, ...}) binarize sym_break cards_assigns
+ maxes_assigns iters_assigns bitss bisim_depths mono_Ts nonmono_Ts
+ deep_dataTs =
let
val cards_assigns = repair_cards_assigns_wrt_boxing thy mono_Ts
cards_assigns
- val blocks = blocks_for_types ext_ctxt cards_assigns maxes_assigns
+ val blocks = blocks_for_types hol_ctxt binarize cards_assigns maxes_assigns
iters_assigns bitss bisim_depths mono_Ts
nonmono_Ts
val ranks = map rank_of_block blocks
val all = all_combinations_ordered_smartly (map (rpair 0) ranks)
val head = take max_scopes all
- val descs = map_filter (scope_descriptor_from_combination ext_ctxt blocks)
- head
+ val descs =
+ map_filter (scope_descriptor_from_combination hol_ctxt binarize blocks)
+ head
in
(length all - length head,
descs |> length descs <= distinct_threshold ? distinct (op =)
- |> map (scope_from_descriptor ext_ctxt sym_break deep_dataTs))
+ |> map (scope_from_descriptor hol_ctxt binarize sym_break
+ deep_dataTs))
end
end;
--- a/src/HOL/Tools/Nitpick/nitpick_tests.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_tests.ML Fri Feb 19 15:21:57 2010 +0000
@@ -308,7 +308,7 @@
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 bits Typtab.empty false constrs u
+ val formula = kodkod_formula_from_nut bits Typtab.empty 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)
--- a/src/HOL/Tools/Nitpick/nitpick_util.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_util.ML Fri Feb 19 15:21:57 2010 +0000
@@ -215,10 +215,11 @@
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
+fun triple_lookup _ [(NONE, z)] _ = SOME z
+ | 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 =
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Fri Feb 19 15:21:57 2010 +0000
@@ -577,7 +577,7 @@
(*val elim = singleton (Inductive_Set.codegen_preproc thy) (preprocess_elim thy nparams
(expand_tuples_elim pre_elim))*)
val elim =
- (Drule.standard o Skip_Proof.make_thm thy)
+ (Drule.export_without_context o Skip_Proof.make_thm thy)
(mk_casesrule (ProofContext.init thy) pred intros)
in
mk_pred_data ((intros, SOME elim), no_compilation)
@@ -641,7 +641,7 @@
else ()
val pred = Const (constname, T)
val pre_elim =
- (Drule.standard o Skip_Proof.make_thm thy)
+ (Drule.export_without_context o Skip_Proof.make_thm thy)
(mk_casesrule (ProofContext.init thy) pred pre_intros)
in register_predicate (constname, pre_intros, pre_elim) thy end
@@ -2178,7 +2178,8 @@
(join_preds_modes moded_clauses 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))
+ map_preds_modes
+ (fn pred => fn mode => fn t => Drule.export_without_context (Skip_Proof.make_thm thy t))
compiled_terms
(* preparation of introduction rules into special datastructures *)
@@ -2269,7 +2270,7 @@
val elim = the_elim_of thy predname
val nparams = nparams_of thy predname
val elim' =
- (Drule.standard o (Skip_Proof.make_thm thy))
+ (Drule.export_without_context o Skip_Proof.make_thm thy)
(mk_casesrule (ProofContext.init thy) nparams intros)
in
if not (Thm.equiv_thm (elim, elim')) then
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Fri Feb 19 15:21:57 2010 +0000
@@ -223,7 +223,7 @@
@{const_name False},
@{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
@{const_name Nat.one_nat_inst.one_nat},
- @{const_name Algebras.ord_class.less}, @{const_name Algebras.ord_class.less_eq},
+ @{const_name Orderings.less}, @{const_name Orderings.less_eq},
@{const_name Algebras.zero},
@{const_name Algebras.one}, @{const_name Algebras.plus},
@{const_name Nat.ord_nat_inst.less_eq_nat},
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Fri Feb 19 15:21:57 2010 +0000
@@ -391,7 +391,7 @@
|> map (fn (concl'::conclprems, _) =>
Logic.list_implies ((flat prems') @ conclprems, concl')))
in
- map (Drule.standard o (Skip_Proof.make_thm thy)) intro_ts'
+ map (Drule.export_without_context o Skip_Proof.make_thm thy) intro_ts'
end
end;
--- a/src/HOL/Tools/Qelim/cooper.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/Qelim/cooper.ML Fri Feb 19 15:21:57 2010 +0000
@@ -73,15 +73,15 @@
| Const ("op =",ty)$y$_ => if term_of x aconv y then Eq (Thm.dest_arg ct) else Nox
| Const (@{const_name Not},_) $ (Const ("op =",_)$y$_) =>
if term_of x aconv y then NEq (funpow 2 Thm.dest_arg ct) else Nox
-| Const (@{const_name Algebras.less}, _) $ y$ z =>
+| Const (@{const_name Orderings.less}, _) $ y$ z =>
if term_of x aconv y then Lt (Thm.dest_arg ct)
else if term_of x aconv z then Gt (Thm.dest_arg1 ct) else Nox
-| Const (@{const_name Algebras.less_eq}, _) $ y $ z =>
+| Const (@{const_name Orderings.less_eq}, _) $ y $ z =>
if term_of x aconv y then Le (Thm.dest_arg ct)
else if term_of x aconv z then Ge (Thm.dest_arg1 ct) else Nox
-| Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$y$_) =>
+| Const (@{const_name Rings.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$y$_) =>
if term_of x aconv y then Dvd (Thm.dest_binop ct ||> Thm.dest_arg) else Nox
-| Const (@{const_name Not},_) $ (Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$y$_)) =>
+| Const (@{const_name Not},_) $ (Const (@{const_name Rings.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$y$_)) =>
if term_of x aconv y then
NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox
| _ => Nox)
@@ -217,13 +217,13 @@
end
| _ => addC $ (mulC $ one $ tm) $ zero;
-fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name Algebras.less}, T) $ s $ t)) =
- lin vs (Const (@{const_name Algebras.less_eq}, T) $ t $ s)
- | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name Algebras.less_eq}, T) $ s $ t)) =
- lin vs (Const (@{const_name Algebras.less}, T) $ t $ s)
+fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name Orderings.less}, T) $ s $ t)) =
+ lin vs (Const (@{const_name Orderings.less_eq}, T) $ t $ s)
+ | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name Orderings.less_eq}, T) $ s $ t)) =
+ lin vs (Const (@{const_name Orderings.less}, T) $ t $ s)
| lin vs (Const (@{const_name Not},T)$t) = Const (@{const_name Not},T)$ (lin vs t)
- | lin (vs as x::_) (Const(@{const_name Ring_and_Field.dvd},_)$d$t) =
- HOLogic.mk_binrel @{const_name Ring_and_Field.dvd} (numeral1 abs d, lint vs t)
+ | lin (vs as x::_) (Const(@{const_name Rings.dvd},_)$d$t) =
+ HOLogic.mk_binrel @{const_name Rings.dvd} (numeral1 abs d, lint vs t)
| lin (vs as x::_) ((b as Const("op =",_))$s$t) =
(case lint vs (subC$t$s) of
(t as a$(m$c$y)$r) =>
@@ -253,7 +253,7 @@
| is_intrel _ = false;
fun linearize_conv ctxt vs ct = case term_of ct of
- Const(@{const_name Ring_and_Field.dvd},_)$d$t =>
+ Const(@{const_name Rings.dvd},_)$d$t =>
let
val th = binop_conv (lint_conv ctxt vs) ct
val (d',t') = Thm.dest_binop (Thm.rhs_of th)
@@ -278,7 +278,7 @@
| _ => dth
end
end
-| Const (@{const_name Not},_)$(Const(@{const_name Ring_and_Field.dvd},_)$_$_) => arg_conv (linearize_conv ctxt vs) ct
+| Const (@{const_name Not},_)$(Const(@{const_name Rings.dvd},_)$_$_) => arg_conv (linearize_conv ctxt vs) ct
| t => if is_intrel t
then (provelin ctxt ((HOLogic.eq_const bT)$t$(lin vs t) |> HOLogic.mk_Trueprop))
RS eq_reflection
@@ -295,13 +295,13 @@
case (term_of t) of
Const(s,_)$(Const(@{const_name Algebras.times},_)$c$y)$ _ =>
if x aconv y andalso member (op =)
- ["op =", @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ ["op =", @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then (ins (dest_numeral c) acc,dacc) else (acc,dacc)
| Const(s,_)$_$(Const(@{const_name Algebras.times},_)$c$y) =>
if x aconv y andalso member (op =)
- [@{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ [@{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then (ins (dest_numeral c) acc, dacc) else (acc,dacc)
- | Const(@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_) =>
+ | Const(@{const_name Rings.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_) =>
if x aconv y then (acc,ins (dest_numeral c) dacc) else (acc,dacc)
| Const("op &",_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t)
| Const("op |",_)$_$_ => h (h (acc,dacc) (Thm.dest_arg1 t)) (Thm.dest_arg t)
@@ -337,13 +337,13 @@
| Const (@{const_name Not},_)$_ => arg_conv unit_conv t
| Const(s,_)$(Const(@{const_name Algebras.times},_)$c$y)$ _ =>
if x=y andalso member (op =)
- ["op =", @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ ["op =", @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then cv (l div dest_numeral c) t else Thm.reflexive t
| Const(s,_)$_$(Const(@{const_name Algebras.times},_)$c$y) =>
if x=y andalso member (op =)
- [@{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ [@{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then cv (l div dest_numeral c) t else Thm.reflexive t
- | Const(@{const_name Ring_and_Field.dvd},_)$d$(r as (Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_)) =>
+ | Const(@{const_name Rings.dvd},_)$d$(r as (Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_)) =>
if x=y then
let
val k = l div dest_numeral c
@@ -560,9 +560,9 @@
fun qf_of_term ps vs t = case t
of Const("True",_) => T
| Const("False",_) => F
- | Const(@{const_name Algebras.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
- | Const(@{const_name Algebras.less_eq},_)$t1$t2 => Le (Sub(i_of_term vs t1,i_of_term vs t2))
- | Const(@{const_name Ring_and_Field.dvd},_)$t1$t2 =>
+ | Const(@{const_name Orderings.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
+ | Const(@{const_name Orderings.less_eq},_)$t1$t2 => Le (Sub(i_of_term vs t1,i_of_term vs t2))
+ | Const(@{const_name Rings.dvd},_)$t1$t2 =>
(Dvd(HOLogic.dest_number t1 |> snd, i_of_term vs t2) handle _ => cooper "Reification: unsupported dvd") (* FIXME avoid handle _ *)
| @{term "op = :: int => _"}$t1$t2 => Eq (Sub (i_of_term vs t1,i_of_term vs t2))
| @{term "op = :: bool => _ "}$t1$t2 => Iff(qf_of_term ps vs t1,qf_of_term ps vs t2)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Quotient/quotient_def.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,110 @@
+(* Title: quotient_def.thy
+ Author: Cezary Kaliszyk and Christian Urban
+
+ Definitions for constants on quotient types.
+
+*)
+
+signature QUOTIENT_DEF =
+sig
+ val quotient_def: (binding option * mixfix) * (Attrib.binding * (term * term)) ->
+ local_theory -> (term * thm) * local_theory
+
+ val quotdef_cmd: (binding option * mixfix) * (Attrib.binding * (string * string)) ->
+ local_theory -> (term * thm) * local_theory
+
+ val quotient_lift_const: string * term -> local_theory -> (term * thm) * local_theory
+end;
+
+structure Quotient_Def: QUOTIENT_DEF =
+struct
+
+open Quotient_Info;
+open Quotient_Term;
+
+(** Interface and Syntax Setup **)
+
+(* The ML-interface for a quotient definition takes
+ as argument:
+
+ - an optional binding and mixfix annotation
+ - attributes
+ - the new constant as term
+ - the rhs of the definition as term
+
+ It returns the defined constant and its definition
+ theorem; stores the data in the qconsts data slot.
+
+ Restriction: At the moment the right-hand side of the
+ definition must be a constant. Similarly the left-hand
+ side must be a constant.
+*)
+fun error_msg bind str =
+let
+ val name = Binding.name_of bind
+ val pos = Position.str_of (Binding.pos_of bind)
+in
+ error ("Head of quotient_definition " ^
+ (quote str) ^ " differs from declaration " ^ name ^ pos)
+end
+
+fun quotient_def ((optbind, mx), (attr, (lhs, rhs))) lthy =
+let
+ val (lhs_str, lhs_ty) = dest_Free lhs handle TERM _ => error "Constant already defined."
+ val _ = if null (strip_abs_vars rhs) then () else error "The definiens cannot be an abstraction"
+
+ fun sanity_test NONE _ = true
+ | sanity_test (SOME bind) str =
+ if Name.of_binding bind = str then true
+ else error_msg bind str
+
+ val _ = sanity_test optbind lhs_str
+
+ val qconst_bname = Binding.name lhs_str
+ val absrep_trm = absrep_fun AbsF lthy (fastype_of rhs, lhs_ty) $ rhs
+ val prop = Logic.mk_equals (lhs, Syntax.check_term lthy absrep_trm)
+ val (_, prop') = LocalDefs.cert_def lthy prop
+ val (_, newrhs) = Primitive_Defs.abs_def prop'
+
+ val ((trm, (_ , thm)), lthy') = Local_Theory.define ((qconst_bname, mx), (attr, newrhs)) lthy
+
+ (* data storage *)
+ fun qcinfo phi = transform_qconsts phi {qconst = trm, rconst = rhs, def = thm}
+ fun trans_name phi = (fst o dest_Const o #qconst) (qcinfo phi)
+ val lthy'' = Local_Theory.declaration true
+ (fn phi => qconsts_update_gen (trans_name phi) (qcinfo phi)) lthy'
+in
+ ((trm, thm), lthy'')
+end
+
+fun quotdef_cmd (decl, (attr, (lhs_str, rhs_str))) lthy =
+let
+ val lhs = Syntax.read_term lthy lhs_str
+ val rhs = Syntax.read_term lthy rhs_str
+ val lthy' = Variable.declare_term lhs lthy
+ val lthy'' = Variable.declare_term rhs lthy'
+in
+ quotient_def (decl, (attr, (lhs, rhs))) lthy''
+end
+
+fun quotient_lift_const (b, t) ctxt =
+ quotient_def ((NONE, NoSyn), (Attrib.empty_binding,
+ (Quotient_Term.quotient_lift_const (b, t) ctxt, t))) ctxt
+
+local
+ structure P = OuterParse;
+in
+
+val quotdef_decl = (P.binding >> SOME) -- P.opt_mixfix' --| P.$$$ "where"
+
+val quotdef_parser =
+ Scan.optional quotdef_decl (NONE, NoSyn) --
+ P.!!! (SpecParse.opt_thm_name ":" -- (P.term --| P.$$$ "is" -- P.term))
+end
+
+val _ =
+ OuterSyntax.local_theory "quotient_definition"
+ "definition for constants over the quotient type"
+ OuterKeyword.thy_decl (quotdef_parser >> (snd oo quotdef_cmd))
+
+end; (* structure *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Quotient/quotient_info.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,289 @@
+(* Title: quotient_info.thy
+ Author: Cezary Kaliszyk and Christian Urban
+
+ Data slots for the quotient package.
+
+*)
+
+
+signature QUOTIENT_INFO =
+sig
+ exception NotFound
+
+ type maps_info = {mapfun: string, relmap: string}
+ val maps_defined: theory -> string -> bool
+ val maps_lookup: theory -> string -> maps_info (* raises NotFound *)
+ val maps_update_thy: string -> maps_info -> theory -> theory
+ val maps_update: string -> maps_info -> Proof.context -> Proof.context
+ val print_mapsinfo: Proof.context -> unit
+
+ type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
+ val transform_quotdata: morphism -> quotdata_info -> quotdata_info
+ val quotdata_lookup_raw: theory -> string -> quotdata_info option
+ val quotdata_lookup: theory -> string -> quotdata_info (* raises NotFound *)
+ val quotdata_update_thy: string -> quotdata_info -> theory -> theory
+ val quotdata_update_gen: string -> quotdata_info -> Context.generic -> Context.generic
+ val quotdata_dest: Proof.context -> quotdata_info list
+ val print_quotinfo: Proof.context -> unit
+
+ type qconsts_info = {qconst: term, rconst: term, def: thm}
+ val transform_qconsts: morphism -> qconsts_info -> qconsts_info
+ val qconsts_lookup: theory -> term -> qconsts_info (* raises NotFound *)
+ val qconsts_update_thy: string -> qconsts_info -> theory -> theory
+ val qconsts_update_gen: string -> qconsts_info -> Context.generic -> Context.generic
+ val qconsts_dest: Proof.context -> qconsts_info list
+ val print_qconstinfo: Proof.context -> unit
+
+ val equiv_rules_get: Proof.context -> thm list
+ val equiv_rules_add: attribute
+ val rsp_rules_get: Proof.context -> thm list
+ val prs_rules_get: Proof.context -> thm list
+ val id_simps_get: Proof.context -> thm list
+ val quotient_rules_get: Proof.context -> thm list
+ val quotient_rules_add: attribute
+end;
+
+
+structure Quotient_Info: QUOTIENT_INFO =
+struct
+
+exception NotFound
+
+
+(** data containers **)
+
+(* info about map- and rel-functions for a type *)
+type maps_info = {mapfun: string, relmap: string}
+
+structure MapsData = Theory_Data
+ (type T = maps_info Symtab.table
+ val empty = Symtab.empty
+ val extend = I
+ val merge = Symtab.merge (K true))
+
+fun maps_defined thy s =
+ Symtab.defined (MapsData.get thy) s
+
+fun maps_lookup thy s =
+ case (Symtab.lookup (MapsData.get thy) s) of
+ SOME map_fun => map_fun
+ | NONE => raise NotFound
+
+fun maps_update_thy k minfo = MapsData.map (Symtab.update (k, minfo))
+fun maps_update k minfo = ProofContext.theory (maps_update_thy k minfo)
+
+fun maps_attribute_aux s minfo = Thm.declaration_attribute
+ (fn _ => Context.mapping (maps_update_thy s minfo) (maps_update s minfo))
+
+(* attribute to be used in declare statements *)
+fun maps_attribute (ctxt, (tystr, (mapstr, relstr))) =
+let
+ val thy = ProofContext.theory_of ctxt
+ val tyname = Sign.intern_type thy tystr
+ val mapname = Sign.intern_const thy mapstr
+ val relname = Sign.intern_const thy relstr
+
+ fun sanity_check s = (Const (s, dummyT) |> Syntax.check_term ctxt; ())
+ val _ = List.app sanity_check [mapname, relname]
+in
+ maps_attribute_aux tyname {mapfun = mapname, relmap = relname}
+end
+
+val maps_attr_parser =
+ Args.context -- Scan.lift
+ ((Args.name --| OuterParse.$$$ "=") --
+ (OuterParse.$$$ "(" |-- Args.name --| OuterParse.$$$ "," --
+ Args.name --| OuterParse.$$$ ")"))
+
+val _ = Context.>> (Context.map_theory
+ (Attrib.setup @{binding "map"} (maps_attr_parser >> maps_attribute)
+ "declaration of map information"))
+
+fun print_mapsinfo ctxt =
+let
+ fun prt_map (ty_name, {mapfun, relmap}) =
+ Pretty.block (Library.separate (Pretty.brk 2)
+ (map Pretty.str
+ ["type:", ty_name,
+ "map:", mapfun,
+ "relation map:", relmap]))
+in
+ MapsData.get (ProofContext.theory_of ctxt)
+ |> Symtab.dest
+ |> map (prt_map)
+ |> Pretty.big_list "maps for type constructors:"
+ |> Pretty.writeln
+end
+
+
+(* info about quotient types *)
+type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm}
+
+structure QuotData = Theory_Data
+ (type T = quotdata_info Symtab.table
+ val empty = Symtab.empty
+ val extend = I
+ val merge = Symtab.merge (K true))
+
+fun transform_quotdata phi {qtyp, rtyp, equiv_rel, equiv_thm} =
+ {qtyp = Morphism.typ phi qtyp,
+ rtyp = Morphism.typ phi rtyp,
+ equiv_rel = Morphism.term phi equiv_rel,
+ equiv_thm = Morphism.thm phi equiv_thm}
+
+fun quotdata_lookup_raw thy str = Symtab.lookup (QuotData.get thy) str
+
+fun quotdata_lookup thy str =
+ case Symtab.lookup (QuotData.get thy) str of
+ SOME qinfo => qinfo
+ | NONE => raise NotFound
+
+fun quotdata_update_thy str qinfo = QuotData.map (Symtab.update (str, qinfo))
+fun quotdata_update_gen str qinfo = Context.mapping (quotdata_update_thy str qinfo) I
+
+fun quotdata_dest lthy =
+ map snd (Symtab.dest (QuotData.get (ProofContext.theory_of lthy)))
+
+fun print_quotinfo ctxt =
+let
+ fun prt_quot {qtyp, rtyp, equiv_rel, equiv_thm} =
+ Pretty.block (Library.separate (Pretty.brk 2)
+ [Pretty.str "quotient type:",
+ Syntax.pretty_typ ctxt qtyp,
+ Pretty.str "raw type:",
+ Syntax.pretty_typ ctxt rtyp,
+ Pretty.str "relation:",
+ Syntax.pretty_term ctxt equiv_rel,
+ Pretty.str "equiv. thm:",
+ Syntax.pretty_term ctxt (prop_of equiv_thm)])
+in
+ QuotData.get (ProofContext.theory_of ctxt)
+ |> Symtab.dest
+ |> map (prt_quot o snd)
+ |> Pretty.big_list "quotients:"
+ |> Pretty.writeln
+end
+
+
+(* info about quotient constants *)
+type qconsts_info = {qconst: term, rconst: term, def: thm}
+
+fun qconsts_info_eq (x : qconsts_info, y : qconsts_info) = #qconst x = #qconst y
+
+(* We need to be able to lookup instances of lifted constants,
+ for example given "nat fset" we need to find "'a fset";
+ but overloaded constants share the same name *)
+structure QConstsData = Theory_Data
+ (type T = (qconsts_info list) Symtab.table
+ val empty = Symtab.empty
+ val extend = I
+ val merge = Symtab.merge_list qconsts_info_eq)
+
+fun transform_qconsts phi {qconst, rconst, def} =
+ {qconst = Morphism.term phi qconst,
+ rconst = Morphism.term phi rconst,
+ def = Morphism.thm phi def}
+
+fun qconsts_update_thy name qcinfo = QConstsData.map (Symtab.cons_list (name, qcinfo))
+fun qconsts_update_gen name qcinfo = Context.mapping (qconsts_update_thy name qcinfo) I
+
+fun qconsts_dest lthy =
+ flat (map snd (Symtab.dest (QConstsData.get (ProofContext.theory_of lthy))))
+
+fun qconsts_lookup thy t =
+ let
+ val (name, qty) = dest_Const t
+ fun matches x =
+ let
+ val (name', qty') = dest_Const (#qconst x);
+ in
+ name = name' andalso Sign.typ_instance thy (qty, qty')
+ end
+ in
+ case Symtab.lookup (QConstsData.get thy) name of
+ NONE => raise NotFound
+ | SOME l =>
+ (case (find_first matches l) of
+ SOME x => x
+ | NONE => raise NotFound)
+ end
+
+fun print_qconstinfo ctxt =
+let
+ fun prt_qconst {qconst, rconst, def} =
+ Pretty.block (separate (Pretty.brk 1)
+ [Syntax.pretty_term ctxt qconst,
+ Pretty.str ":=",
+ Syntax.pretty_term ctxt rconst,
+ Pretty.str "as",
+ Syntax.pretty_term ctxt (prop_of def)])
+in
+ QConstsData.get (ProofContext.theory_of ctxt)
+ |> Symtab.dest
+ |> map snd
+ |> flat
+ |> map prt_qconst
+ |> Pretty.big_list "quotient constants:"
+ |> Pretty.writeln
+end
+
+(* equivalence relation theorems *)
+structure EquivRules = Named_Thms
+ (val name = "quot_equiv"
+ val description = "Equivalence relation theorems.")
+
+val equiv_rules_get = EquivRules.get
+val equiv_rules_add = EquivRules.add
+
+(* respectfulness theorems *)
+structure RspRules = Named_Thms
+ (val name = "quot_respect"
+ val description = "Respectfulness theorems.")
+
+val rsp_rules_get = RspRules.get
+
+(* preservation theorems *)
+structure PrsRules = Named_Thms
+ (val name = "quot_preserve"
+ val description = "Preservation theorems.")
+
+val prs_rules_get = PrsRules.get
+
+(* id simplification theorems *)
+structure IdSimps = Named_Thms
+ (val name = "id_simps"
+ val description = "Identity simp rules for maps.")
+
+val id_simps_get = IdSimps.get
+
+(* quotient theorems *)
+structure QuotientRules = Named_Thms
+ (val name = "quot_thm"
+ val description = "Quotient theorems.")
+
+val quotient_rules_get = QuotientRules.get
+val quotient_rules_add = QuotientRules.add
+
+(* setup of the theorem lists *)
+
+val _ = Context.>> (Context.map_theory
+ (EquivRules.setup #>
+ RspRules.setup #>
+ PrsRules.setup #>
+ IdSimps.setup #>
+ QuotientRules.setup))
+
+(* setup of the printing commands *)
+
+fun improper_command (pp_fn, cmd_name, descr_str) =
+ OuterSyntax.improper_command cmd_name descr_str
+ OuterKeyword.diag (Scan.succeed (Toplevel.keep (pp_fn o Toplevel.context_of)))
+
+val _ = map improper_command
+ [(print_mapsinfo, "print_maps", "prints out all map functions"),
+ (print_quotinfo, "print_quotients", "prints out all quotients"),
+ (print_qconstinfo, "print_quotconsts", "prints out all quotient constants")]
+
+
+end; (* structure *)
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Quotient/quotient_tacs.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,665 @@
+(* Title: quotient_tacs.thy
+ Author: Cezary Kaliszyk and Christian Urban
+
+ Tactics for solving goal arising from lifting
+ theorems to quotient types.
+*)
+
+signature QUOTIENT_TACS =
+sig
+ val regularize_tac: Proof.context -> int -> tactic
+ val injection_tac: Proof.context -> int -> tactic
+ val all_injection_tac: Proof.context -> int -> tactic
+ val clean_tac: Proof.context -> int -> tactic
+ val procedure_tac: Proof.context -> thm -> int -> tactic
+ val lift_tac: Proof.context -> thm list -> int -> tactic
+ val quotient_tac: Proof.context -> int -> tactic
+ val quot_true_tac: Proof.context -> (term -> term) -> int -> tactic
+ val lifted_attrib: attribute
+end;
+
+structure Quotient_Tacs: QUOTIENT_TACS =
+struct
+
+open Quotient_Info;
+open Quotient_Term;
+
+
+(** various helper fuctions **)
+
+(* Since HOL_basic_ss is too "big" for us, we *)
+(* need to set up our own minimal simpset. *)
+fun mk_minimal_ss ctxt =
+ Simplifier.context ctxt empty_ss
+ setsubgoaler asm_simp_tac
+ setmksimps (mksimps [])
+
+(* composition of two theorems, used in maps *)
+fun OF1 thm1 thm2 = thm2 RS thm1
+
+(* prints a warning, if the subgoal is not solved *)
+fun WARN (tac, msg) i st =
+ case Seq.pull (SOLVED' tac i st) of
+ NONE => (warning msg; Seq.single st)
+ | seqcell => Seq.make (fn () => seqcell)
+
+fun RANGE_WARN tacs = RANGE (map WARN tacs)
+
+fun atomize_thm thm =
+let
+ val thm' = Thm.freezeT (forall_intr_vars thm) (* FIXME/TODO: is this proper Isar-technology? *)
+ val thm'' = ObjectLogic.atomize (cprop_of thm')
+in
+ @{thm equal_elim_rule1} OF [thm'', thm']
+end
+
+
+
+(*** Regularize Tactic ***)
+
+(** solvers for equivp and quotient assumptions **)
+
+fun equiv_tac ctxt =
+ REPEAT_ALL_NEW (resolve_tac (equiv_rules_get ctxt))
+
+fun equiv_solver_tac ss = equiv_tac (Simplifier.the_context ss)
+val equiv_solver = Simplifier.mk_solver' "Equivalence goal solver" equiv_solver_tac
+
+fun quotient_tac ctxt =
+ (REPEAT_ALL_NEW (FIRST'
+ [rtac @{thm identity_quotient},
+ resolve_tac (quotient_rules_get ctxt)]))
+
+fun quotient_solver_tac ss = quotient_tac (Simplifier.the_context ss)
+val quotient_solver =
+ Simplifier.mk_solver' "Quotient goal solver" quotient_solver_tac
+
+fun solve_quotient_assm ctxt thm =
+ case Seq.pull (quotient_tac ctxt 1 thm) of
+ SOME (t, _) => t
+ | _ => error "Solve_quotient_assm failed. Possibly a quotient theorem is missing."
+
+
+fun prep_trm thy (x, (T, t)) =
+ (cterm_of thy (Var (x, T)), cterm_of thy t)
+
+fun prep_ty thy (x, (S, ty)) =
+ (ctyp_of thy (TVar (x, S)), ctyp_of thy ty)
+
+fun get_match_inst thy pat trm =
+let
+ val univ = Unify.matchers thy [(pat, trm)]
+ val SOME (env, _) = Seq.pull univ (* raises BIND, if no unifier *)
+ val tenv = Vartab.dest (Envir.term_env env)
+ val tyenv = Vartab.dest (Envir.type_env env)
+in
+ (map (prep_ty thy) tyenv, map (prep_trm thy) tenv)
+end
+
+(* Calculates the instantiations for the lemmas:
+
+ ball_reg_eqv_range and bex_reg_eqv_range
+
+ Since the left-hand-side contains a non-pattern '?P (f ?x)'
+ we rely on unification/instantiation to check whether the
+ theorem applies and return NONE if it doesn't.
+*)
+fun calculate_inst ctxt ball_bex_thm redex R1 R2 =
+let
+ val thy = ProofContext.theory_of ctxt
+ fun get_lhs thm = fst (Logic.dest_equals (Thm.concl_of thm))
+ val ty_inst = map (SOME o ctyp_of thy) [domain_type (fastype_of R2)]
+ val trm_inst = map (SOME o cterm_of thy) [R2, R1]
+in
+ case try (Drule.instantiate' ty_inst trm_inst) ball_bex_thm of
+ NONE => NONE
+ | SOME thm' =>
+ (case try (get_match_inst thy (get_lhs thm')) redex of
+ NONE => NONE
+ | SOME inst2 => try (Drule.instantiate inst2) thm')
+end
+
+fun ball_bex_range_simproc ss redex =
+let
+ val ctxt = Simplifier.the_context ss
+in
+ case redex of
+ (Const (@{const_name "Ball"}, _) $ (Const (@{const_name "Respects"}, _) $
+ (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>
+ calculate_inst ctxt @{thm ball_reg_eqv_range[THEN eq_reflection]} redex R1 R2
+
+ | (Const (@{const_name "Bex"}, _) $ (Const (@{const_name "Respects"}, _) $
+ (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) =>
+ calculate_inst ctxt @{thm bex_reg_eqv_range[THEN eq_reflection]} redex R1 R2
+
+ | _ => NONE
+end
+
+(* Regularize works as follows:
+
+ 0. preliminary simplification step according to
+ ball_reg_eqv bex_reg_eqv babs_reg_eqv ball_reg_eqv_range bex_reg_eqv_range
+
+ 1. eliminating simple Ball/Bex instances (ball_reg_right bex_reg_left)
+
+ 2. monos
+
+ 3. commutation rules for ball and bex (ball_all_comm bex_ex_comm)
+
+ 4. then rel-equalities, which need to be instantiated with 'eq_imp_rel'
+ to avoid loops
+
+ 5. then simplification like 0
+
+ finally jump back to 1
+*)
+
+fun regularize_tac ctxt =
+let
+ val thy = ProofContext.theory_of ctxt
+ val ball_pat = @{term "Ball (Respects (R1 ===> R2)) P"}
+ val bex_pat = @{term "Bex (Respects (R1 ===> R2)) P"}
+ val simproc = Simplifier.simproc_i thy "" [ball_pat, bex_pat] (K (ball_bex_range_simproc))
+ val simpset = (mk_minimal_ss ctxt)
+ addsimps @{thms ball_reg_eqv bex_reg_eqv babs_reg_eqv babs_simp}
+ addsimprocs [simproc]
+ addSolver equiv_solver addSolver quotient_solver
+ val eq_imp_rel = @{lemma "equivp R ==> a = b --> R a b" by (simp add: equivp_reflp)}
+ val eq_eqvs = map (OF1 eq_imp_rel) (equiv_rules_get ctxt)
+in
+ simp_tac simpset THEN'
+ REPEAT_ALL_NEW (CHANGED o FIRST'
+ [resolve_tac @{thms ball_reg_right bex_reg_left bex1_bexeq_reg},
+ resolve_tac (Inductive.get_monos ctxt),
+ resolve_tac @{thms ball_all_comm bex_ex_comm},
+ resolve_tac eq_eqvs,
+ simp_tac simpset])
+end
+
+
+
+(*** Injection Tactic ***)
+
+(* Looks for Quot_True assumptions, and in case its parameter
+ is an application, it returns the function and the argument.
+*)
+fun find_qt_asm asms =
+let
+ fun find_fun trm =
+ case trm of
+ (Const(@{const_name Trueprop}, _) $ (Const (@{const_name Quot_True}, _) $ _)) => true
+ | _ => false
+in
+ case find_first find_fun asms of
+ SOME (_ $ (_ $ (f $ a))) => SOME (f, a)
+ | _ => NONE
+end
+
+fun quot_true_simple_conv ctxt fnctn ctrm =
+ case (term_of ctrm) of
+ (Const (@{const_name Quot_True}, _) $ x) =>
+ let
+ val fx = fnctn x;
+ val thy = ProofContext.theory_of ctxt;
+ val cx = cterm_of thy x;
+ val cfx = cterm_of thy fx;
+ val cxt = ctyp_of thy (fastype_of x);
+ val cfxt = ctyp_of thy (fastype_of fx);
+ val thm = Drule.instantiate' [SOME cxt, SOME cfxt] [SOME cx, SOME cfx] @{thm QT_imp}
+ in
+ Conv.rewr_conv thm ctrm
+ end
+
+fun quot_true_conv ctxt fnctn ctrm =
+ case (term_of ctrm) of
+ (Const (@{const_name Quot_True}, _) $ _) =>
+ quot_true_simple_conv ctxt fnctn ctrm
+ | _ $ _ => Conv.comb_conv (quot_true_conv ctxt fnctn) ctrm
+ | Abs _ => Conv.abs_conv (fn (_, ctxt) => quot_true_conv ctxt fnctn) ctxt ctrm
+ | _ => Conv.all_conv ctrm
+
+fun quot_true_tac ctxt fnctn =
+ CONVERSION
+ ((Conv.params_conv ~1 (fn ctxt =>
+ (Conv.prems_conv ~1 (quot_true_conv ctxt fnctn)))) ctxt)
+
+fun dest_comb (f $ a) = (f, a)
+fun dest_bcomb ((_ $ l) $ r) = (l, r)
+
+fun unlam t =
+ case t of
+ (Abs a) => snd (Term.dest_abs a)
+ | _ => unlam (Abs("", domain_type (fastype_of t), (incr_boundvars 1 t) $ (Bound 0)))
+
+fun dest_fun_type (Type("fun", [T, S])) = (T, S)
+ | dest_fun_type _ = error "dest_fun_type"
+
+val bare_concl = HOLogic.dest_Trueprop o Logic.strip_assums_concl
+
+(* We apply apply_rsp only in case if the type needs lifting.
+ This is the case if the type of the data in the Quot_True
+ assumption is different from the corresponding type in the goal.
+*)
+val apply_rsp_tac =
+ Subgoal.FOCUS (fn {concl, asms, context,...} =>
+ let
+ val bare_concl = HOLogic.dest_Trueprop (term_of concl)
+ val qt_asm = find_qt_asm (map term_of asms)
+ in
+ case (bare_concl, qt_asm) of
+ (R2 $ (f $ x) $ (g $ y), SOME (qt_fun, qt_arg)) =>
+ if fastype_of qt_fun = fastype_of f
+ then no_tac
+ else
+ let
+ val ty_x = fastype_of x
+ val ty_b = fastype_of qt_arg
+ val ty_f = range_type (fastype_of f)
+ val thy = ProofContext.theory_of context
+ val ty_inst = map (SOME o (ctyp_of thy)) [ty_x, ty_b, ty_f]
+ val t_inst = map (SOME o (cterm_of thy)) [R2, f, g, x, y];
+ val inst_thm = Drule.instantiate' ty_inst
+ ([NONE, NONE, NONE] @ t_inst) @{thm apply_rsp}
+ in
+ (rtac inst_thm THEN' quotient_tac context) 1
+ end
+ | _ => no_tac
+ end)
+
+(* Instantiates and applies 'equals_rsp'. Since the theorem is
+ complex we rely on instantiation to tell us if it applies
+*)
+fun equals_rsp_tac R ctxt =
+let
+ val thy = ProofContext.theory_of ctxt
+in
+ case try (cterm_of thy) R of (* There can be loose bounds in R *)
+ SOME ctm =>
+ let
+ val ty = domain_type (fastype_of R)
+ in
+ case try (Drule.instantiate' [SOME (ctyp_of thy ty)]
+ [SOME (cterm_of thy R)]) @{thm equals_rsp} of
+ SOME thm => rtac thm THEN' quotient_tac ctxt
+ | NONE => K no_tac
+ end
+ | _ => K no_tac
+end
+
+fun rep_abs_rsp_tac ctxt =
+ SUBGOAL (fn (goal, i) =>
+ case (try bare_concl goal) of
+ SOME (rel $ _ $ (rep $ (abs $ _))) =>
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val (ty_a, ty_b) = dest_fun_type (fastype_of abs);
+ val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b];
+ in
+ case try (map (SOME o (cterm_of thy))) [rel, abs, rep] of
+ SOME t_inst =>
+ (case try (Drule.instantiate' ty_inst t_inst) @{thm rep_abs_rsp} of
+ SOME inst_thm => (rtac inst_thm THEN' quotient_tac ctxt) i
+ | NONE => no_tac)
+ | NONE => no_tac
+ end
+ | _ => no_tac)
+
+
+
+(* Injection means to prove that the regularised theorem implies
+ the abs/rep injected one.
+
+ The deterministic part:
+ - remove lambdas from both sides
+ - prove Ball/Bex/Babs equalities using ball_rsp, bex_rsp, babs_rsp
+ - prove Ball/Bex relations unfolding fun_rel_id
+ - reflexivity of equality
+ - prove equality of relations using equals_rsp
+ - use user-supplied RSP theorems
+ - solve 'relation of relations' goals using quot_rel_rsp
+ - remove rep_abs from the right side
+ (Lambdas under respects may have left us some assumptions)
+
+ Then in order:
+ - split applications of lifted type (apply_rsp)
+ - split applications of non-lifted type (cong_tac)
+ - apply extentionality
+ - assumption
+ - reflexivity of the relation
+*)
+fun injection_match_tac ctxt = SUBGOAL (fn (goal, i) =>
+(case (bare_concl goal) of
+ (* (R1 ===> R2) (%x...) (%x...) ----> [|R1 x y|] ==> R2 (...x) (...y) *)
+ (Const (@{const_name fun_rel}, _) $ _ $ _) $ (Abs _) $ (Abs _)
+ => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+ (* (op =) (Ball...) (Ball...) ----> (op =) (...) (...) *)
+| (Const (@{const_name "op ="},_) $
+ (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+ (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
+ => rtac @{thm ball_rsp} THEN' dtac @{thm QT_all}
+
+ (* (R1 ===> op =) (Ball...) (Ball...) ----> [|R1 x y|] ==> (Ball...x) = (Ball...y) *)
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+ (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+ (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+ => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+ (* (op =) (Bex...) (Bex...) ----> (op =) (...) (...) *)
+| Const (@{const_name "op ="},_) $
+ (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+ (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+ => rtac @{thm bex_rsp} THEN' dtac @{thm QT_ex}
+
+ (* (R1 ===> op =) (Bex...) (Bex...) ----> [|R1 x y|] ==> (Bex...x) = (Bex...y) *)
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+ (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+ (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _)
+ => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam
+
+| (Const (@{const_name fun_rel}, _) $ _ $ _) $
+ (Const(@{const_name Bex1_rel},_) $ _) $ (Const(@{const_name Bex1_rel},_) $ _)
+ => rtac @{thm bex1_rel_rsp} THEN' quotient_tac ctxt
+
+| (_ $
+ (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $
+ (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _))
+ => rtac @{thm babs_rsp} THEN' RANGE [quotient_tac ctxt]
+
+| Const (@{const_name "op ="},_) $ (R $ _ $ _) $ (_ $ _ $ _) =>
+ (rtac @{thm refl} ORELSE'
+ (equals_rsp_tac R ctxt THEN' RANGE [
+ quot_true_tac ctxt (fst o dest_bcomb), quot_true_tac ctxt (snd o dest_bcomb)]))
+
+ (* reflexivity of operators arising from Cong_tac *)
+| Const (@{const_name "op ="},_) $ _ $ _ => rtac @{thm refl}
+
+ (* respectfulness of constants; in particular of a simple relation *)
+| _ $ (Const _) $ (Const _) (* fun_rel, list_rel, etc but not equality *)
+ => resolve_tac (rsp_rules_get ctxt) THEN_ALL_NEW quotient_tac ctxt
+
+ (* R (...) (Rep (Abs ...)) ----> R (...) (...) *)
+ (* observe fun_map *)
+| _ $ _ $ _
+ => (rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt)
+ ORELSE' rep_abs_rsp_tac ctxt
+
+| _ => K no_tac
+) i)
+
+fun injection_step_tac ctxt rel_refl =
+ FIRST' [
+ injection_match_tac ctxt,
+
+ (* R (t $ ...) (t' $ ...) ----> apply_rsp provided type of t needs lifting *)
+ apply_rsp_tac ctxt THEN'
+ RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)],
+
+ (* (op =) (t $ ...) (t' $ ...) ----> Cong provided type of t does not need lifting *)
+ (* merge with previous tactic *)
+ Cong_Tac.cong_tac @{thm cong} THEN'
+ RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)],
+
+ (* (op =) (%x...) (%y...) ----> (op =) (...) (...) *)
+ rtac @{thm ext} THEN' quot_true_tac ctxt unlam,
+
+ (* resolving with R x y assumptions *)
+ atac,
+
+ (* reflexivity of the basic relations *)
+ (* R ... ... *)
+ resolve_tac rel_refl]
+
+fun injection_tac ctxt =
+let
+ val rel_refl = map (OF1 @{thm equivp_reflp}) (equiv_rules_get ctxt)
+in
+ injection_step_tac ctxt rel_refl
+end
+
+fun all_injection_tac ctxt =
+ REPEAT_ALL_NEW (injection_tac ctxt)
+
+
+
+(*** Cleaning of the Theorem ***)
+
+(* expands all fun_maps, except in front of the (bound) variables listed in xs *)
+fun fun_map_simple_conv xs ctrm =
+ case (term_of ctrm) of
+ ((Const (@{const_name "fun_map"}, _) $ _ $ _) $ h $ _) =>
+ if member (op=) xs h
+ then Conv.all_conv ctrm
+ else Conv.rewr_conv @{thm fun_map_def[THEN eq_reflection]} ctrm
+ | _ => Conv.all_conv ctrm
+
+fun fun_map_conv xs ctxt ctrm =
+ case (term_of ctrm) of
+ _ $ _ => (Conv.comb_conv (fun_map_conv xs ctxt) then_conv
+ fun_map_simple_conv xs) ctrm
+ | Abs _ => Conv.abs_conv (fn (x, ctxt) => fun_map_conv ((term_of x)::xs) ctxt) ctxt ctrm
+ | _ => Conv.all_conv ctrm
+
+fun fun_map_tac ctxt = CONVERSION (fun_map_conv [] ctxt)
+
+(* custom matching functions *)
+fun mk_abs u i t =
+ if incr_boundvars i u aconv t then Bound i else
+ case t of
+ t1 $ t2 => mk_abs u i t1 $ mk_abs u i t2
+ | Abs (s, T, t') => Abs (s, T, mk_abs u (i + 1) t')
+ | Bound j => if i = j then error "make_inst" else t
+ | _ => t
+
+fun make_inst lhs t =
+let
+ val _ $ (Abs (_, _, (_ $ ((f as Var (_, Type ("fun", [T, _]))) $ u)))) = lhs;
+ val _ $ (Abs (_, _, (_ $ g))) = t;
+in
+ (f, Abs ("x", T, mk_abs u 0 g))
+end
+
+fun make_inst_id lhs t =
+let
+ val _ $ (Abs (_, _, (f as Var (_, Type ("fun", [T, _]))) $ u)) = lhs;
+ val _ $ (Abs (_, _, g)) = t;
+in
+ (f, Abs ("x", T, mk_abs u 0 g))
+end
+
+(* Simplifies a redex using the 'lambda_prs' theorem.
+ First instantiates the types and known subterms.
+ Then solves the quotient assumptions to get Rep2 and Abs1
+ Finally instantiates the function f using make_inst
+ If Rep2 is an identity then the pattern is simpler and
+ make_inst_id is used
+*)
+fun lambda_prs_simple_conv ctxt ctrm =
+ case (term_of ctrm) of
+ (Const (@{const_name fun_map}, _) $ r1 $ a2) $ (Abs _) =>
+ let
+ val thy = ProofContext.theory_of ctxt
+ val (ty_b, ty_a) = dest_fun_type (fastype_of r1)
+ val (ty_c, ty_d) = dest_fun_type (fastype_of a2)
+ val tyinst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c, ty_d]
+ val tinst = [NONE, NONE, SOME (cterm_of thy r1), NONE, SOME (cterm_of thy a2)]
+ val thm1 = Drule.instantiate' tyinst tinst @{thm lambda_prs[THEN eq_reflection]}
+ val thm2 = solve_quotient_assm ctxt (solve_quotient_assm ctxt thm1)
+ val thm3 = MetaSimplifier.rewrite_rule @{thms id_apply[THEN eq_reflection]} thm2
+ val (insp, inst) =
+ if ty_c = ty_d
+ then make_inst_id (term_of (Thm.lhs_of thm3)) (term_of ctrm)
+ else make_inst (term_of (Thm.lhs_of thm3)) (term_of ctrm)
+ val thm4 = Drule.instantiate ([], [(cterm_of thy insp, cterm_of thy inst)]) thm3
+ in
+ Conv.rewr_conv thm4 ctrm
+ end
+ | _ => Conv.all_conv ctrm
+
+fun lambda_prs_conv ctxt = More_Conv.top_conv lambda_prs_simple_conv ctxt
+fun lambda_prs_tac ctxt = CONVERSION (lambda_prs_conv ctxt)
+
+
+(* Cleaning consists of:
+
+ 1. unfolding of ---> in front of everything, except
+ bound variables (this prevents lambda_prs from
+ becoming stuck)
+
+ 2. simplification with lambda_prs
+
+ 3. simplification with:
+
+ - Quotient_abs_rep Quotient_rel_rep
+ babs_prs all_prs ex_prs ex1_prs
+
+ - id_simps and preservation lemmas and
+
+ - symmetric versions of the definitions
+ (that is definitions of quotient constants
+ are folded)
+
+ 4. test for refl
+*)
+fun clean_tac lthy =
+let
+ val defs = map (symmetric o #def) (qconsts_dest lthy)
+ val prs = prs_rules_get lthy
+ val ids = id_simps_get lthy
+ val thms = @{thms Quotient_abs_rep Quotient_rel_rep babs_prs all_prs ex_prs ex1_prs} @ ids @ prs @ defs
+
+ val ss = (mk_minimal_ss lthy) addsimps thms addSolver quotient_solver
+in
+ EVERY' [fun_map_tac lthy,
+ lambda_prs_tac lthy,
+ simp_tac ss,
+ TRY o rtac refl]
+end
+
+
+
+(** Tactic for Generalising Free Variables in a Goal **)
+
+fun inst_spec ctrm =
+ Drule.instantiate' [SOME (ctyp_of_term ctrm)] [NONE, SOME ctrm] @{thm spec}
+
+fun inst_spec_tac ctrms =
+ EVERY' (map (dtac o inst_spec) ctrms)
+
+fun all_list xs trm =
+ fold (fn (x, T) => fn t' => HOLogic.mk_all (x, T, t')) xs trm
+
+fun apply_under_Trueprop f =
+ HOLogic.dest_Trueprop #> f #> HOLogic.mk_Trueprop
+
+fun gen_frees_tac ctxt =
+ SUBGOAL (fn (concl, i) =>
+ let
+ val thy = ProofContext.theory_of ctxt
+ val vrs = Term.add_frees concl []
+ val cvrs = map (cterm_of thy o Free) vrs
+ val concl' = apply_under_Trueprop (all_list vrs) concl
+ val goal = Logic.mk_implies (concl', concl)
+ val rule = Goal.prove ctxt [] [] goal
+ (K (EVERY1 [inst_spec_tac (rev cvrs), atac]))
+ in
+ rtac rule i
+ end)
+
+
+(** The General Shape of the Lifting Procedure **)
+
+(* - A is the original raw theorem
+ - B is the regularized theorem
+ - C is the rep/abs injected version of B
+ - D is the lifted theorem
+
+ - 1st prem is the regularization step
+ - 2nd prem is the rep/abs injection step
+ - 3rd prem is the cleaning part
+
+ the Quot_True premise in 2nd records the lifted theorem
+*)
+val lifting_procedure_thm =
+ @{lemma "[|A;
+ A --> B;
+ Quot_True D ==> B = C;
+ C = D|] ==> D"
+ by (simp add: Quot_True_def)}
+
+fun lift_match_error ctxt msg rtrm qtrm =
+let
+ val rtrm_str = Syntax.string_of_term ctxt rtrm
+ val qtrm_str = Syntax.string_of_term ctxt qtrm
+ val msg = cat_lines [enclose "[" "]" msg, "The quotient theorem", qtrm_str,
+ "", "does not match with original theorem", rtrm_str]
+in
+ error msg
+end
+
+fun procedure_inst ctxt rtrm qtrm =
+let
+ val thy = ProofContext.theory_of ctxt
+ val rtrm' = HOLogic.dest_Trueprop rtrm
+ val qtrm' = HOLogic.dest_Trueprop qtrm
+ val reg_goal = regularize_trm_chk ctxt (rtrm', qtrm')
+ handle (LIFT_MATCH msg) => lift_match_error ctxt msg rtrm qtrm
+ val inj_goal = inj_repabs_trm_chk ctxt (reg_goal, qtrm')
+ handle (LIFT_MATCH msg) => lift_match_error ctxt msg rtrm qtrm
+in
+ Drule.instantiate' []
+ [SOME (cterm_of thy rtrm'),
+ SOME (cterm_of thy reg_goal),
+ NONE,
+ SOME (cterm_of thy inj_goal)] lifting_procedure_thm
+end
+
+(* the tactic leaves three subgoals to be proved *)
+fun procedure_tac ctxt rthm =
+ ObjectLogic.full_atomize_tac
+ THEN' gen_frees_tac ctxt
+ THEN' SUBGOAL (fn (goal, i) =>
+ let
+ val rthm' = atomize_thm rthm
+ val rule = procedure_inst ctxt (prop_of rthm') goal
+ in
+ (rtac rule THEN' rtac rthm') i
+ end)
+
+
+(* Automatic Proofs *)
+
+val msg1 = "The regularize proof failed."
+val msg2 = cat_lines ["The injection proof failed.",
+ "This is probably due to missing respects lemmas.",
+ "Try invoking the injection method manually to see",
+ "which lemmas are missing."]
+val msg3 = "The cleaning proof failed."
+
+fun lift_tac ctxt rthms =
+let
+ fun mk_tac rthm =
+ procedure_tac ctxt rthm
+ THEN' RANGE_WARN
+ [(regularize_tac ctxt, msg1),
+ (all_injection_tac ctxt, msg2),
+ (clean_tac ctxt, msg3)]
+in
+ simp_tac (mk_minimal_ss ctxt) (* unfolding multiple &&& *)
+ THEN' RANGE (map mk_tac rthms)
+end
+
+(* An Attribute which automatically constructs the qthm *)
+fun lifted_attrib_aux context thm =
+let
+ val ctxt = Context.proof_of context
+ val ((_, [thm']), ctxt') = Variable.import false [thm] ctxt
+ val goal = (quotient_lift_all ctxt' o prop_of) thm'
+in
+ Goal.prove ctxt' [] [] goal (K (lift_tac ctxt' [thm] 1))
+ |> singleton (ProofContext.export ctxt' ctxt)
+end;
+
+val lifted_attrib = Thm.rule_attribute lifted_attrib_aux
+
+end; (* structure *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Quotient/quotient_term.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,786 @@
+(* Title: quotient_term.thy
+ Author: Cezary Kaliszyk and Christian Urban
+
+ Constructs terms corresponding to goals from
+ lifting theorems to quotient types.
+*)
+
+signature QUOTIENT_TERM =
+sig
+ exception LIFT_MATCH of string
+
+ datatype flag = AbsF | RepF
+
+ val absrep_fun: flag -> Proof.context -> typ * typ -> term
+ val absrep_fun_chk: flag -> Proof.context -> typ * typ -> term
+
+ (* Allows Nitpick to represent quotient types as single elements from raw type *)
+ val absrep_const_chk: flag -> Proof.context -> string -> term
+
+ val equiv_relation: Proof.context -> typ * typ -> term
+ val equiv_relation_chk: Proof.context -> typ * typ -> term
+
+ val regularize_trm: Proof.context -> term * term -> term
+ val regularize_trm_chk: Proof.context -> term * term -> term
+
+ val inj_repabs_trm: Proof.context -> term * term -> term
+ val inj_repabs_trm_chk: Proof.context -> term * term -> term
+
+ val quotient_lift_const: string * term -> local_theory -> term
+ val quotient_lift_all: Proof.context -> term -> term
+end;
+
+structure Quotient_Term: QUOTIENT_TERM =
+struct
+
+open Quotient_Info;
+
+exception LIFT_MATCH of string
+
+
+
+(*** Aggregate Rep/Abs Function ***)
+
+
+(* The flag RepF is for types in negative position; AbsF is for types
+ in positive position. Because of this, function types need to be
+ treated specially, since there the polarity changes.
+*)
+
+datatype flag = AbsF | RepF
+
+fun negF AbsF = RepF
+ | negF RepF = AbsF
+
+fun is_identity (Const (@{const_name "id"}, _)) = true
+ | is_identity _ = false
+
+fun mk_identity ty = Const (@{const_name "id"}, ty --> ty)
+
+fun mk_fun_compose flag (trm1, trm2) =
+ case flag of
+ AbsF => Const (@{const_name "comp"}, dummyT) $ trm1 $ trm2
+ | RepF => Const (@{const_name "comp"}, dummyT) $ trm2 $ trm1
+
+fun get_mapfun ctxt s =
+let
+ val thy = ProofContext.theory_of ctxt
+ val exn = LIFT_MATCH ("No map function for type " ^ quote s ^ " found.")
+ val mapfun = #mapfun (maps_lookup thy s) handle Quotient_Info.NotFound => raise exn
+in
+ Const (mapfun, dummyT)
+end
+
+(* makes a Free out of a TVar *)
+fun mk_Free (TVar ((x, i), _)) = Free (unprefix "'" x ^ string_of_int i, dummyT)
+
+(* produces an aggregate map function for the
+ rty-part of a quotient definition; abstracts
+ over all variables listed in vs (these variables
+ correspond to the type variables in rty)
+
+ for example for: (?'a list * ?'b)
+ it produces: %a b. prod_map (map a) b
+*)
+fun mk_mapfun ctxt vs rty =
+let
+ val vs' = map (mk_Free) vs
+
+ fun mk_mapfun_aux rty =
+ case rty of
+ TVar _ => mk_Free rty
+ | Type (_, []) => mk_identity rty
+ | Type (s, tys) => list_comb (get_mapfun ctxt s, map mk_mapfun_aux tys)
+ | _ => raise LIFT_MATCH "mk_mapfun (default)"
+in
+ fold_rev Term.lambda vs' (mk_mapfun_aux rty)
+end
+
+(* looks up the (varified) rty and qty for
+ a quotient definition
+*)
+fun get_rty_qty ctxt s =
+let
+ val thy = ProofContext.theory_of ctxt
+ val exn = LIFT_MATCH ("No quotient type " ^ quote s ^ " found.")
+ val qdata = (quotdata_lookup thy s) handle Quotient_Info.NotFound => raise exn
+in
+ (#rtyp qdata, #qtyp qdata)
+end
+
+(* takes two type-environments and looks
+ up in both of them the variable v, which
+ must be listed in the environment
+*)
+fun double_lookup rtyenv qtyenv v =
+let
+ val v' = fst (dest_TVar v)
+in
+ (snd (the (Vartab.lookup rtyenv v')), snd (the (Vartab.lookup qtyenv v')))
+end
+
+(* matches a type pattern with a type *)
+fun match ctxt err ty_pat ty =
+let
+ val thy = ProofContext.theory_of ctxt
+in
+ Sign.typ_match thy (ty_pat, ty) Vartab.empty
+ handle MATCH_TYPE => err ctxt ty_pat ty
+end
+
+(* produces the rep or abs constant for a qty *)
+fun absrep_const flag ctxt qty_str =
+let
+ val thy = ProofContext.theory_of ctxt
+ val qty_name = Long_Name.base_name qty_str
+in
+ case flag of
+ AbsF => Const (Sign.full_bname thy ("abs_" ^ qty_name), dummyT)
+ | RepF => Const (Sign.full_bname thy ("rep_" ^ qty_name), dummyT)
+end
+
+(* Lets Nitpick represent elements of quotient types as elements of the raw type *)
+fun absrep_const_chk flag ctxt qty_str =
+ Syntax.check_term ctxt (absrep_const flag ctxt qty_str)
+
+fun absrep_match_err ctxt ty_pat ty =
+let
+ val ty_pat_str = Syntax.string_of_typ ctxt ty_pat
+ val ty_str = Syntax.string_of_typ ctxt ty
+in
+ raise LIFT_MATCH (space_implode " "
+ ["absrep_fun (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"])
+end
+
+
+(** generation of an aggregate absrep function **)
+
+(* - In case of equal types we just return the identity.
+
+ - In case of TFrees we also return the identity.
+
+ - In case of function types we recurse taking
+ the polarity change into account.
+
+ - If the type constructors are equal, we recurse for the
+ arguments and build the appropriate map function.
+
+ - If the type constructors are unequal, there must be an
+ instance of quotient types:
+
+ - we first look up the corresponding rty_pat and qty_pat
+ from the quotient definition; the arguments of qty_pat
+ must be some distinct TVars
+ - we then match the rty_pat with rty and qty_pat with qty;
+ if matching fails the types do not correspond -> error
+ - the matching produces two environments; we look up the
+ assignments for the qty_pat variables and recurse on the
+ assignments
+ - we prefix the aggregate map function for the rty_pat,
+ which is an abstraction over all type variables
+ - finally we compose the result with the appropriate
+ absrep function in case at least one argument produced
+ a non-identity function /
+ otherwise we just return the appropriate absrep
+ function
+
+ The composition is necessary for types like
+
+ ('a list) list / ('a foo) foo
+
+ The matching is necessary for types like
+
+ ('a * 'a) list / 'a bar
+
+ The test is necessary in order to eliminate superfluous
+ identity maps.
+*)
+
+fun absrep_fun flag ctxt (rty, qty) =
+ if rty = qty
+ then mk_identity rty
+ else
+ case (rty, qty) of
+ (Type ("fun", [ty1, ty2]), Type ("fun", [ty1', ty2'])) =>
+ let
+ val arg1 = absrep_fun (negF flag) ctxt (ty1, ty1')
+ val arg2 = absrep_fun flag ctxt (ty2, ty2')
+ in
+ list_comb (get_mapfun ctxt "fun", [arg1, arg2])
+ end
+ | (Type (s, tys), Type (s', tys')) =>
+ if s = s'
+ then
+ let
+ val args = map (absrep_fun flag ctxt) (tys ~~ tys')
+ in
+ list_comb (get_mapfun ctxt s, args)
+ end
+ else
+ let
+ val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s'
+ val rtyenv = match ctxt absrep_match_err rty_pat rty
+ val qtyenv = match ctxt absrep_match_err qty_pat qty
+ val args_aux = map (double_lookup rtyenv qtyenv) vs
+ val args = map (absrep_fun flag ctxt) args_aux
+ val map_fun = mk_mapfun ctxt vs rty_pat
+ val result = list_comb (map_fun, args)
+ in
+ if forall is_identity args
+ then absrep_const flag ctxt s'
+ else mk_fun_compose flag (absrep_const flag ctxt s', result)
+ end
+ | (TFree x, TFree x') =>
+ if x = x'
+ then mk_identity rty
+ else raise (LIFT_MATCH "absrep_fun (frees)")
+ | (TVar _, TVar _) => raise (LIFT_MATCH "absrep_fun (vars)")
+ | _ => raise (LIFT_MATCH "absrep_fun (default)")
+
+fun absrep_fun_chk flag ctxt (rty, qty) =
+ absrep_fun flag ctxt (rty, qty)
+ |> Syntax.check_term ctxt
+
+
+
+
+(*** Aggregate Equivalence Relation ***)
+
+
+(* works very similar to the absrep generation,
+ except there is no need for polarities
+*)
+
+(* instantiates TVars so that the term is of type ty *)
+fun force_typ ctxt trm ty =
+let
+ val thy = ProofContext.theory_of ctxt
+ val trm_ty = fastype_of trm
+ val ty_inst = Sign.typ_match thy (trm_ty, ty) Vartab.empty
+in
+ map_types (Envir.subst_type ty_inst) trm
+end
+
+fun is_eq (Const (@{const_name "op ="}, _)) = true
+ | is_eq _ = false
+
+fun mk_rel_compose (trm1, trm2) =
+ Const (@{const_name "rel_conj"}, dummyT) $ trm1 $ trm2
+
+fun get_relmap ctxt s =
+let
+ val thy = ProofContext.theory_of ctxt
+ val exn = LIFT_MATCH ("get_relmap (no relation map function found for type " ^ s ^ ")")
+ val relmap = #relmap (maps_lookup thy s) handle Quotient_Info.NotFound => raise exn
+in
+ Const (relmap, dummyT)
+end
+
+fun mk_relmap ctxt vs rty =
+let
+ val vs' = map (mk_Free) vs
+
+ fun mk_relmap_aux rty =
+ case rty of
+ TVar _ => mk_Free rty
+ | Type (_, []) => HOLogic.eq_const rty
+ | Type (s, tys) => list_comb (get_relmap ctxt s, map mk_relmap_aux tys)
+ | _ => raise LIFT_MATCH ("mk_relmap (default)")
+in
+ fold_rev Term.lambda vs' (mk_relmap_aux rty)
+end
+
+fun get_equiv_rel ctxt s =
+let
+ val thy = ProofContext.theory_of ctxt
+ val exn = LIFT_MATCH ("get_quotdata (no quotient found for type " ^ s ^ ")")
+in
+ #equiv_rel (quotdata_lookup thy s) handle Quotient_Info.NotFound => raise exn
+end
+
+fun equiv_match_err ctxt ty_pat ty =
+let
+ val ty_pat_str = Syntax.string_of_typ ctxt ty_pat
+ val ty_str = Syntax.string_of_typ ctxt ty
+in
+ raise LIFT_MATCH (space_implode " "
+ ["equiv_relation (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"])
+end
+
+(* builds the aggregate equivalence relation
+ that will be the argument of Respects
+*)
+fun equiv_relation ctxt (rty, qty) =
+ if rty = qty
+ then HOLogic.eq_const rty
+ else
+ case (rty, qty) of
+ (Type (s, tys), Type (s', tys')) =>
+ if s = s'
+ then
+ let
+ val args = map (equiv_relation ctxt) (tys ~~ tys')
+ in
+ list_comb (get_relmap ctxt s, args)
+ end
+ else
+ let
+ val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s'
+ val rtyenv = match ctxt equiv_match_err rty_pat rty
+ val qtyenv = match ctxt equiv_match_err qty_pat qty
+ val args_aux = map (double_lookup rtyenv qtyenv) vs
+ val args = map (equiv_relation ctxt) args_aux
+ val rel_map = mk_relmap ctxt vs rty_pat
+ val result = list_comb (rel_map, args)
+ val eqv_rel = get_equiv_rel ctxt s'
+ val eqv_rel' = force_typ ctxt eqv_rel ([rty, rty] ---> @{typ bool})
+ in
+ if forall is_eq args
+ then eqv_rel'
+ else mk_rel_compose (result, eqv_rel')
+ end
+ | _ => HOLogic.eq_const rty
+
+fun equiv_relation_chk ctxt (rty, qty) =
+ equiv_relation ctxt (rty, qty)
+ |> Syntax.check_term ctxt
+
+
+
+(*** Regularization ***)
+
+(* Regularizing an rtrm means:
+
+ - Quantifiers over types that need lifting are replaced
+ by bounded quantifiers, for example:
+
+ All P ----> All (Respects R) P
+
+ where the aggregate relation R is given by the rty and qty;
+
+ - Abstractions over types that need lifting are replaced
+ by bounded abstractions, for example:
+
+ %x. P ----> Ball (Respects R) %x. P
+
+ - Equalities over types that need lifting are replaced by
+ corresponding equivalence relations, for example:
+
+ A = B ----> R A B
+
+ or
+
+ A = B ----> (R ===> R) A B
+
+ for more complicated types of A and B
+
+
+ The regularize_trm accepts raw theorems in which equalities
+ and quantifiers match exactly the ones in the lifted theorem
+ but also accepts partially regularized terms.
+
+ This means that the raw theorems can have:
+ Ball (Respects R), Bex (Respects R), Bex1_rel (Respects R), Babs, R
+ in the places where:
+ All, Ex, Ex1, %, (op =)
+ is required the lifted theorem.
+
+*)
+
+val mk_babs = Const (@{const_name Babs}, dummyT)
+val mk_ball = Const (@{const_name Ball}, dummyT)
+val mk_bex = Const (@{const_name Bex}, dummyT)
+val mk_bex1_rel = Const (@{const_name Bex1_rel}, dummyT)
+val mk_resp = Const (@{const_name Respects}, dummyT)
+
+(* - applies f to the subterm of an abstraction,
+ otherwise to the given term,
+ - used by regularize, therefore abstracted
+ variables do not have to be treated specially
+*)
+fun apply_subt f (trm1, trm2) =
+ case (trm1, trm2) of
+ (Abs (x, T, t), Abs (_ , _, t')) => Abs (x, T, f (t, t'))
+ | _ => f (trm1, trm2)
+
+fun term_mismatch str ctxt t1 t2 =
+let
+ val t1_str = Syntax.string_of_term ctxt t1
+ val t2_str = Syntax.string_of_term ctxt t2
+ val t1_ty_str = Syntax.string_of_typ ctxt (fastype_of t1)
+ val t2_ty_str = Syntax.string_of_typ ctxt (fastype_of t2)
+in
+ raise LIFT_MATCH (cat_lines [str, t1_str ^ "::" ^ t1_ty_str, t2_str ^ "::" ^ t2_ty_str])
+end
+
+(* the major type of All and Ex quantifiers *)
+fun qnt_typ ty = domain_type (domain_type ty)
+
+(* Checks that two types match, for example:
+ rty -> rty matches qty -> qty *)
+fun matches_typ thy rT qT =
+ if rT = qT then true else
+ case (rT, qT) of
+ (Type (rs, rtys), Type (qs, qtys)) =>
+ if rs = qs then
+ if length rtys <> length qtys then false else
+ forall (fn x => x = true) (map2 (matches_typ thy) rtys qtys)
+ else
+ (case Quotient_Info.quotdata_lookup_raw thy qs of
+ SOME quotinfo => Sign.typ_instance thy (rT, #rtyp quotinfo)
+ | NONE => false)
+ | _ => false
+
+
+(* produces a regularized version of rtrm
+
+ - the result might contain dummyTs
+
+ - for regularisation we do not need any
+ special treatment of bound variables
+*)
+fun regularize_trm ctxt (rtrm, qtrm) =
+ case (rtrm, qtrm) of
+ (Abs (x, ty, t), Abs (_, ty', t')) =>
+ let
+ val subtrm = Abs(x, ty, regularize_trm ctxt (t, t'))
+ in
+ if ty = ty' then subtrm
+ else mk_babs $ (mk_resp $ equiv_relation ctxt (ty, ty')) $ subtrm
+ end
+ | (Const (@{const_name "Babs"}, T) $ resrel $ (t as (Abs (_, ty, _))), t' as (Abs (_, ty', _))) =>
+ let
+ val subtrm = regularize_trm ctxt (t, t')
+ val needres = mk_resp $ equiv_relation_chk ctxt (ty, ty')
+ in
+ if resrel <> needres
+ then term_mismatch "regularize (Babs)" ctxt resrel needres
+ else mk_babs $ resrel $ subtrm
+ end
+
+ | (Const (@{const_name "All"}, ty) $ t, Const (@{const_name "All"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ in
+ if ty = ty' then Const (@{const_name "All"}, ty) $ subtrm
+ else mk_ball $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
+ end
+
+ | (Const (@{const_name "Ex"}, ty) $ t, Const (@{const_name "Ex"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ in
+ if ty = ty' then Const (@{const_name "Ex"}, ty) $ subtrm
+ else mk_bex $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
+ end
+
+ | (Const (@{const_name "Ex1"}, ty) $ (Abs (_, _,
+ (Const (@{const_name "op &"}, _) $ (Const (@{const_name "op :"}, _) $ _ $
+ (Const (@{const_name "Respects"}, _) $ resrel)) $ (t $ _)))),
+ Const (@{const_name "Ex1"}, ty') $ t') =>
+ let
+ val t_ = incr_boundvars (~1) t
+ val subtrm = apply_subt (regularize_trm ctxt) (t_, t')
+ val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
+ in
+ if resrel <> needrel
+ then term_mismatch "regularize (Bex1)" ctxt resrel needrel
+ else mk_bex1_rel $ resrel $ subtrm
+ end
+
+ | (Const (@{const_name "Ex1"}, ty) $ t, Const (@{const_name "Ex1"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ in
+ if ty = ty' then Const (@{const_name "Ex1"}, ty) $ subtrm
+ else mk_bex1_rel $ (equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
+ end
+
+ | (Const (@{const_name "Ball"}, ty) $ (Const (@{const_name "Respects"}, _) $ resrel) $ t,
+ Const (@{const_name "All"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
+ in
+ if resrel <> needrel
+ then term_mismatch "regularize (Ball)" ctxt resrel needrel
+ else mk_ball $ (mk_resp $ resrel) $ subtrm
+ end
+
+ | (Const (@{const_name "Bex"}, ty) $ (Const (@{const_name "Respects"}, _) $ resrel) $ t,
+ Const (@{const_name "Ex"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
+ in
+ if resrel <> needrel
+ then term_mismatch "regularize (Bex)" ctxt resrel needrel
+ else mk_bex $ (mk_resp $ resrel) $ subtrm
+ end
+
+ | (Const (@{const_name "Bex1_rel"}, ty) $ resrel $ t, Const (@{const_name "Ex1"}, ty') $ t') =>
+ let
+ val subtrm = apply_subt (regularize_trm ctxt) (t, t')
+ val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
+ in
+ if resrel <> needrel
+ then term_mismatch "regularize (Bex1_res)" ctxt resrel needrel
+ else mk_bex1_rel $ resrel $ subtrm
+ end
+
+ | (* equalities need to be replaced by appropriate equivalence relations *)
+ (Const (@{const_name "op ="}, ty), Const (@{const_name "op ="}, ty')) =>
+ if ty = ty' then rtrm
+ else equiv_relation ctxt (domain_type ty, domain_type ty')
+
+ | (* in this case we just check whether the given equivalence relation is correct *)
+ (rel, Const (@{const_name "op ="}, ty')) =>
+ let
+ val rel_ty = fastype_of rel
+ val rel' = equiv_relation_chk ctxt (domain_type rel_ty, domain_type ty')
+ in
+ if rel' aconv rel then rtrm
+ else term_mismatch "regularise (relation mismatch)" ctxt rel rel'
+ end
+
+ | (_, Const _) =>
+ let
+ val thy = ProofContext.theory_of ctxt
+ fun same_const (Const (s, T)) (Const (s', T')) = (s = s') andalso matches_typ thy T T'
+ | same_const _ _ = false
+ in
+ if same_const rtrm qtrm then rtrm
+ else
+ let
+ val rtrm' = #rconst (qconsts_lookup thy qtrm)
+ handle Quotient_Info.NotFound => term_mismatch "regularize(constant notfound)" ctxt rtrm qtrm
+ in
+ if Pattern.matches thy (rtrm', rtrm)
+ then rtrm else term_mismatch "regularize(constant mismatch)" ctxt rtrm qtrm
+ end
+ end
+
+ | (((t1 as Const (@{const_name "split"}, _)) $ Abs (v1, ty, Abs(v1', ty', s1))),
+ ((t2 as Const (@{const_name "split"}, _)) $ Abs (v2, _ , Abs(v2', _ , s2)))) =>
+ regularize_trm ctxt (t1, t2) $ Abs (v1, ty, Abs (v1', ty', regularize_trm ctxt (s1, s2)))
+
+ | (((t1 as Const (@{const_name "split"}, _)) $ Abs (v1, ty, s1)),
+ ((t2 as Const (@{const_name "split"}, _)) $ Abs (v2, _ , s2))) =>
+ regularize_trm ctxt (t1, t2) $ Abs (v1, ty, regularize_trm ctxt (s1, s2))
+
+ | (t1 $ t2, t1' $ t2') =>
+ regularize_trm ctxt (t1, t1') $ regularize_trm ctxt (t2, t2')
+
+ | (Bound i, Bound i') =>
+ if i = i' then rtrm
+ else raise (LIFT_MATCH "regularize (bounds mismatch)")
+
+ | _ =>
+ let
+ val rtrm_str = Syntax.string_of_term ctxt rtrm
+ val qtrm_str = Syntax.string_of_term ctxt qtrm
+ in
+ raise (LIFT_MATCH ("regularize failed (default: " ^ rtrm_str ^ "," ^ qtrm_str ^ ")"))
+ end
+
+fun regularize_trm_chk ctxt (rtrm, qtrm) =
+ regularize_trm ctxt (rtrm, qtrm)
+ |> Syntax.check_term ctxt
+
+
+
+(*** Rep/Abs Injection ***)
+
+(*
+Injection of Rep/Abs means:
+
+ For abstractions:
+
+ * If the type of the abstraction needs lifting, then we add Rep/Abs
+ around the abstraction; otherwise we leave it unchanged.
+
+ For applications:
+
+ * If the application involves a bounded quantifier, we recurse on
+ the second argument. If the application is a bounded abstraction,
+ we always put an Rep/Abs around it (since bounded abstractions
+ are assumed to always need lifting). Otherwise we recurse on both
+ arguments.
+
+ For constants:
+
+ * If the constant is (op =), we leave it always unchanged.
+ Otherwise the type of the constant needs lifting, we put
+ and Rep/Abs around it.
+
+ For free variables:
+
+ * We put a Rep/Abs around it if the type needs lifting.
+
+ Vars case cannot occur.
+*)
+
+fun mk_repabs ctxt (T, T') trm =
+ absrep_fun RepF ctxt (T, T') $ (absrep_fun AbsF ctxt (T, T') $ trm)
+
+fun inj_repabs_err ctxt msg rtrm qtrm =
+let
+ val rtrm_str = Syntax.string_of_term ctxt rtrm
+ val qtrm_str = Syntax.string_of_term ctxt qtrm
+in
+ raise LIFT_MATCH (space_implode " " [msg, quote rtrm_str, "and", quote qtrm_str])
+end
+
+
+(* bound variables need to be treated properly,
+ as the type of subterms needs to be calculated *)
+fun inj_repabs_trm ctxt (rtrm, qtrm) =
+ case (rtrm, qtrm) of
+ (Const (@{const_name "Ball"}, T) $ r $ t, Const (@{const_name "All"}, _) $ t') =>
+ Const (@{const_name "Ball"}, T) $ r $ (inj_repabs_trm ctxt (t, t'))
+
+ | (Const (@{const_name "Bex"}, T) $ r $ t, Const (@{const_name "Ex"}, _) $ t') =>
+ Const (@{const_name "Bex"}, T) $ r $ (inj_repabs_trm ctxt (t, t'))
+
+ | (Const (@{const_name "Babs"}, T) $ r $ t, t' as (Abs _)) =>
+ let
+ val rty = fastype_of rtrm
+ val qty = fastype_of qtrm
+ in
+ mk_repabs ctxt (rty, qty) (Const (@{const_name "Babs"}, T) $ r $ (inj_repabs_trm ctxt (t, t')))
+ end
+
+ | (Abs (x, T, t), Abs (x', T', t')) =>
+ let
+ val rty = fastype_of rtrm
+ val qty = fastype_of qtrm
+ val (y, s) = Term.dest_abs (x, T, t)
+ val (_, s') = Term.dest_abs (x', T', t')
+ val yvar = Free (y, T)
+ val result = Term.lambda_name (y, yvar) (inj_repabs_trm ctxt (s, s'))
+ in
+ if rty = qty then result
+ else mk_repabs ctxt (rty, qty) result
+ end
+
+ | (t $ s, t' $ s') =>
+ (inj_repabs_trm ctxt (t, t')) $ (inj_repabs_trm ctxt (s, s'))
+
+ | (Free (_, T), Free (_, T')) =>
+ if T = T' then rtrm
+ else mk_repabs ctxt (T, T') rtrm
+
+ | (_, Const (@{const_name "op ="}, _)) => rtrm
+
+ | (_, Const (_, T')) =>
+ let
+ val rty = fastype_of rtrm
+ in
+ if rty = T' then rtrm
+ else mk_repabs ctxt (rty, T') rtrm
+ end
+
+ | _ => inj_repabs_err ctxt "injection (default):" rtrm qtrm
+
+fun inj_repabs_trm_chk ctxt (rtrm, qtrm) =
+ inj_repabs_trm ctxt (rtrm, qtrm)
+ |> Syntax.check_term ctxt
+
+
+
+(*** Wrapper for automatically transforming an rthm into a qthm ***)
+
+(* subst_tys takes a list of (rty, qty) substitution pairs
+ and replaces all occurences of rty in the given type
+ by appropriate qty, with substitution *)
+fun subst_ty thy ty (rty, qty) r =
+ if r <> NONE then r else
+ case try (Sign.typ_match thy (rty, ty)) Vartab.empty of
+ SOME inst => SOME (Envir.subst_type inst qty)
+ | NONE => NONE
+fun subst_tys thy substs ty =
+ case fold (subst_ty thy ty) substs NONE of
+ SOME ty => ty
+ | NONE =>
+ (case ty of
+ Type (s, tys) => Type (s, map (subst_tys thy substs) tys)
+ | x => x)
+
+(* subst_trms takes a list of (rtrm, qtrm) substitution pairs
+ and if the given term matches any of the raw terms it
+ returns the appropriate qtrm instantiated. If none of
+ them matched it returns NONE. *)
+fun subst_trm thy t (rtrm, qtrm) s =
+ if s <> NONE then s else
+ case try (Pattern.match thy (rtrm, t)) (Vartab.empty, Vartab.empty) of
+ SOME inst => SOME (Envir.subst_term inst qtrm)
+ | NONE => NONE;
+fun subst_trms thy substs t = fold (subst_trm thy t) substs NONE
+
+(* prepares type and term substitution pairs to be used by above
+ functions that let replace all raw constructs by appropriate
+ lifted counterparts. *)
+fun get_ty_trm_substs ctxt =
+let
+ val thy = ProofContext.theory_of ctxt
+ val quot_infos = Quotient_Info.quotdata_dest ctxt
+ val const_infos = Quotient_Info.qconsts_dest ctxt
+ val ty_substs = map (fn ri => (#rtyp ri, #qtyp ri)) quot_infos
+ val const_substs = map (fn ci => (#rconst ci, #qconst ci)) const_infos
+ fun rel_eq rel = HOLogic.eq_const (subst_tys thy ty_substs (domain_type (fastype_of rel)))
+ val rel_substs = map (fn ri => (#equiv_rel ri, rel_eq (#equiv_rel ri))) quot_infos
+in
+ (ty_substs, const_substs @ rel_substs)
+end
+
+fun quotient_lift_const (b, t) ctxt =
+let
+ val thy = ProofContext.theory_of ctxt
+ val (ty_substs, _) = get_ty_trm_substs ctxt;
+ val (_, ty) = dest_Const t;
+ val nty = subst_tys thy ty_substs ty;
+in
+ Free(b, nty)
+end
+
+(*
+Takes a term and
+
+* replaces raw constants by the quotient constants
+
+* replaces equivalence relations by equalities
+
+* replaces raw types by the quotient types
+
+*)
+
+fun quotient_lift_all ctxt t =
+let
+ val thy = ProofContext.theory_of ctxt
+ val (ty_substs, substs) = get_ty_trm_substs ctxt
+ fun lift_aux t =
+ case subst_trms thy substs t of
+ SOME x => x
+ | NONE =>
+ (case t of
+ a $ b => lift_aux a $ lift_aux b
+ | Abs(a, ty, s) =>
+ let
+ val (y, s') = Term.dest_abs (a, ty, s)
+ val nty = subst_tys thy ty_substs ty
+ in
+ Abs(y, nty, abstract_over (Free (y, nty), lift_aux s'))
+ end
+ | Free(n, ty) => Free(n, subst_tys thy ty_substs ty)
+ | Var(n, ty) => Var(n, subst_tys thy ty_substs ty)
+ | Bound i => Bound i
+ | Const(s, ty) => Const(s, subst_tys thy ty_substs ty))
+in
+ lift_aux t
+end
+
+
+end; (* structure *)
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Quotient/quotient_typ.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,309 @@
+(* Title: quotient_typ.thy
+ Author: Cezary Kaliszyk and Christian Urban
+
+ Definition of a quotient type.
+
+*)
+
+signature QUOTIENT_TYPE =
+sig
+ val quotient_type: ((string list * binding * mixfix) * (typ * term)) list
+ -> Proof.context -> Proof.state
+
+ val quotient_type_cmd: ((((string list * binding) * mixfix) * string) * string) list
+ -> Proof.context -> Proof.state
+end;
+
+structure Quotient_Type: QUOTIENT_TYPE =
+struct
+
+open Quotient_Info;
+
+(* wrappers for define, note, Attrib.internal and theorem_i *)
+fun define (name, mx, rhs) lthy =
+let
+ val ((rhs, (_ , thm)), lthy') =
+ Local_Theory.define ((name, mx), (Attrib.empty_binding, rhs)) lthy
+in
+ ((rhs, thm), lthy')
+end
+
+fun note (name, thm, attrs) lthy =
+let
+ val ((_,[thm']), lthy') = Local_Theory.note ((name, attrs), [thm]) lthy
+in
+ (thm', lthy')
+end
+
+fun intern_attr at = Attrib.internal (K at)
+
+fun theorem after_qed goals ctxt =
+let
+ val goals' = map (rpair []) goals
+ fun after_qed' thms = after_qed (the_single thms)
+in
+ Proof.theorem_i NONE after_qed' [goals'] ctxt
+end
+
+
+
+(*** definition of quotient types ***)
+
+val mem_def1 = @{lemma "y : S ==> S y" by (simp add: mem_def)}
+val mem_def2 = @{lemma "S y ==> y : S" by (simp add: mem_def)}
+
+(* constructs the term lambda (c::rty => bool). EX (x::rty). c = rel x *)
+fun typedef_term rel rty lthy =
+let
+ val [x, c] =
+ [("x", rty), ("c", HOLogic.mk_setT rty)]
+ |> Variable.variant_frees lthy [rel]
+ |> map Free
+in
+ lambda c (HOLogic.exists_const rty $
+ lambda x (HOLogic.mk_eq (c, (rel $ x))))
+end
+
+
+(* makes the new type definitions and proves non-emptyness *)
+fun typedef_make (vs, qty_name, mx, rel, rty) lthy =
+let
+ val typedef_tac =
+ EVERY1 (map rtac [@{thm exI}, mem_def2, @{thm exI}, @{thm refl}])
+in
+ Local_Theory.theory_result
+ (Typedef.add_typedef false NONE
+ (qty_name, vs, mx)
+ (typedef_term rel rty lthy)
+ NONE typedef_tac) lthy
+end
+
+
+(* tactic to prove the quot_type theorem for the new type *)
+fun typedef_quot_type_tac equiv_thm (typedef_info: Typedef.info) =
+let
+ val rep_thm = #Rep typedef_info RS mem_def1
+ val rep_inv = #Rep_inverse typedef_info
+ val abs_inv = mem_def2 RS #Abs_inverse typedef_info
+ val rep_inj = #Rep_inject typedef_info
+in
+ (rtac @{thm quot_type.intro} THEN' RANGE [
+ rtac equiv_thm,
+ rtac rep_thm,
+ rtac rep_inv,
+ EVERY' (map rtac [abs_inv, @{thm exI}, @{thm refl}]),
+ rtac rep_inj]) 1
+end
+
+
+(* proves the quot_type theorem for the new type *)
+fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy =
+let
+ val quot_type_const = Const (@{const_name "quot_type"}, dummyT)
+ val goal =
+ HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep)
+ |> Syntax.check_term lthy
+in
+ Goal.prove lthy [] [] goal
+ (K (typedef_quot_type_tac equiv_thm typedef_info))
+end
+
+(* proves the quotient theorem for the new type *)
+fun typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_type_thm) lthy =
+let
+ val quotient_const = Const (@{const_name "Quotient"}, dummyT)
+ val goal =
+ HOLogic.mk_Trueprop (quotient_const $ rel $ abs $ rep)
+ |> Syntax.check_term lthy
+
+ val typedef_quotient_thm_tac =
+ EVERY1 [
+ K (rewrite_goals_tac [abs_def, rep_def]),
+ rtac @{thm quot_type.Quotient},
+ rtac quot_type_thm]
+in
+ Goal.prove lthy [] [] goal
+ (K typedef_quotient_thm_tac)
+end
+
+
+(* main function for constructing a quotient type *)
+fun mk_quotient_type (((vs, qty_name, mx), (rty, rel)), equiv_thm) lthy =
+let
+ (* generates the typedef *)
+ val ((qty_full_name, typedef_info), lthy1) = typedef_make (vs, qty_name, mx, rel, rty) lthy
+
+ (* abs and rep functions from the typedef *)
+ val Abs_ty = #abs_type typedef_info
+ val Rep_ty = #rep_type typedef_info
+ val Abs_name = #Abs_name typedef_info
+ val Rep_name = #Rep_name typedef_info
+ val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty)
+ val Rep_const = Const (Rep_name, Abs_ty --> Rep_ty)
+
+ (* more useful abs and rep definitions *)
+ val abs_const = Const (@{const_name "quot_type.abs"}, dummyT )
+ val rep_const = Const (@{const_name "quot_type.rep"}, dummyT )
+ val abs_trm = Syntax.check_term lthy1 (abs_const $ rel $ Abs_const)
+ val rep_trm = Syntax.check_term lthy1 (rep_const $ Rep_const)
+ val abs_name = Binding.prefix_name "abs_" qty_name
+ val rep_name = Binding.prefix_name "rep_" qty_name
+
+ val ((abs, abs_def), lthy2) = define (abs_name, NoSyn, abs_trm) lthy1
+ val ((rep, rep_def), lthy3) = define (rep_name, NoSyn, rep_trm) lthy2
+
+ (* quot_type theorem *)
+ val quot_thm = typedef_quot_type_thm (rel, Abs_const, Rep_const, equiv_thm, typedef_info) lthy3
+
+ (* quotient theorem *)
+ val quotient_thm = typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_thm) lthy3
+ val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name
+
+ (* name equivalence theorem *)
+ val equiv_thm_name = Binding.suffix_name "_equivp" qty_name
+
+ (* storing the quot-info *)
+ fun qinfo phi = transform_quotdata phi
+ {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_thm}
+ val lthy4 = Local_Theory.declaration true
+ (fn phi => quotdata_update_gen qty_full_name (qinfo phi)) lthy3
+in
+ lthy4
+ |> note (quotient_thm_name, quotient_thm, [intern_attr quotient_rules_add])
+ ||>> note (equiv_thm_name, equiv_thm, [intern_attr equiv_rules_add])
+end
+
+
+(* sanity checks for the quotient type specifications *)
+fun sanity_check ((vs, qty_name, _), (rty, rel)) =
+let
+ val rty_tfreesT = map fst (Term.add_tfreesT rty [])
+ val rel_tfrees = map fst (Term.add_tfrees rel [])
+ val rel_frees = map fst (Term.add_frees rel [])
+ val rel_vars = Term.add_vars rel []
+ val rel_tvars = Term.add_tvars rel []
+ val qty_str = Binding.str_of qty_name ^ ": "
+
+ val illegal_rel_vars =
+ if null rel_vars andalso null rel_tvars then []
+ else [qty_str ^ "illegal schematic variable(s) in the relation."]
+
+ val dup_vs =
+ (case duplicates (op =) vs of
+ [] => []
+ | dups => [qty_str ^ "duplicate type variable(s) on the lhs: " ^ commas_quote dups])
+
+ val extra_rty_tfrees =
+ (case subtract (op =) vs rty_tfreesT of
+ [] => []
+ | extras => [qty_str ^ "extra type variable(s) on the lhs: " ^ commas_quote extras])
+
+ val extra_rel_tfrees =
+ (case subtract (op =) vs rel_tfrees of
+ [] => []
+ | extras => [qty_str ^ "extra type variable(s) in the relation: " ^ commas_quote extras])
+
+ val illegal_rel_frees =
+ (case rel_frees of
+ [] => []
+ | xs => [qty_str ^ "illegal variable(s) in the relation: " ^ commas_quote xs])
+
+ val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees
+in
+ if null errs then () else error (cat_lines errs)
+end
+
+(* check for existence of map functions *)
+fun map_check ctxt (_, (rty, _)) =
+let
+ val thy = ProofContext.theory_of ctxt
+
+ fun map_check_aux rty warns =
+ case rty of
+ Type (_, []) => warns
+ | Type (s, _) => if maps_defined thy s then warns else s::warns
+ | _ => warns
+
+ val warns = map_check_aux rty []
+in
+ if null warns then ()
+ else warning ("No map function defined for " ^ commas warns ^
+ ". This will cause problems later on.")
+end
+
+
+
+(*** interface and syntax setup ***)
+
+
+(* the ML-interface takes a list of 5-tuples consisting of:
+
+ - the name of the quotient type
+ - its free type variables (first argument)
+ - its mixfix annotation
+ - the type to be quotient
+ - the relation according to which the type is quotient
+
+ it opens a proof-state in which one has to show that the
+ relations are equivalence relations
+*)
+
+fun quotient_type quot_list lthy =
+let
+ (* sanity check *)
+ val _ = List.app sanity_check quot_list
+ val _ = List.app (map_check lthy) quot_list
+
+ fun mk_goal (rty, rel) =
+ let
+ val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool}
+ in
+ HOLogic.mk_Trueprop (Const (@{const_name equivp}, equivp_ty) $ rel)
+ end
+
+ val goals = map (mk_goal o snd) quot_list
+
+ fun after_qed thms lthy =
+ fold_map mk_quotient_type (quot_list ~~ thms) lthy |> snd
+in
+ theorem after_qed goals lthy
+end
+
+fun quotient_type_cmd specs lthy =
+let
+ fun parse_spec ((((vs, qty_name), mx), rty_str), rel_str) lthy =
+ let
+ (* new parsing with proper declaration *)
+ val rty = Syntax.read_typ lthy rty_str
+ val lthy1 = Variable.declare_typ rty lthy
+ val pre_rel = Syntax.parse_term lthy1 rel_str
+ val pre_rel' = Syntax.type_constraint (rty --> rty --> @{typ bool}) pre_rel
+ val rel = Syntax.check_term lthy1 pre_rel'
+ val lthy2 = Variable.declare_term rel lthy1
+
+ (* old parsing *)
+ (* val rty = Syntax.read_typ lthy rty_str
+ val rel = Syntax.read_term lthy rel_str *)
+ in
+ (((vs, qty_name, mx), (rty, rel)), lthy2)
+ end
+
+ val (spec', lthy') = fold_map parse_spec specs lthy
+in
+ quotient_type spec' lthy'
+end
+
+val quotspec_parser =
+ OuterParse.and_list1
+ ((OuterParse.type_args -- OuterParse.binding) --
+ OuterParse.opt_infix -- (OuterParse.$$$ "=" |-- OuterParse.typ) --
+ (OuterParse.$$$ "/" |-- OuterParse.term))
+
+val _ = OuterKeyword.keyword "/"
+
+val _ =
+ OuterSyntax.local_theory_to_proof "quotient_type"
+ "quotient type definitions (require equivalence proofs)"
+ OuterKeyword.thy_goal (quotspec_parser >> quotient_type_cmd)
+
+end; (* structure *)
--- a/src/HOL/Tools/TFL/post.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/TFL/post.ML Fri Feb 19 15:21:57 2010 +0000
@@ -129,7 +129,7 @@
(*lcp: put a theorem into Isabelle form, using meta-level connectives*)
val meta_outer =
- curry_rule o Drule.standard o
+ curry_rule o Drule.export_without_context o
rule_by_tactic (REPEAT (FIRSTGOAL (resolve_tac [allI, impI, conjI] ORELSE' etac conjE)));
(*Strip off the outer !P*)
@@ -151,7 +151,7 @@
{f = f, R = R, rules = rules,
full_pats_TCs = full_pats_TCs,
TCs = TCs}
- val rules' = map (Drule.standard o ObjectLogic.rulify_no_asm)
+ val rules' = map (Drule.export_without_context o ObjectLogic.rulify_no_asm)
(R.CONJUNCTS rules)
in {induct = meta_outer (ObjectLogic.rulify_no_asm (induction RS spec')),
rules = ListPair.zip(rules', rows),
@@ -180,7 +180,7 @@
| solve_eq (th, [a], i) = [(a, i)]
| solve_eq (th, splitths as (_ :: _), i) =
(writeln "Proving unsplit equation...";
- [((Drule.standard o ObjectLogic.rulify_no_asm)
+ [((Drule.export_without_context o ObjectLogic.rulify_no_asm)
(CaseSplit.splitto splitths th), i)])
(* if there's an error, pretend nothing happened with this definition
We should probably print something out so that the user knows...? *)
@@ -236,7 +236,7 @@
in (theory,
(*return the conjoined induction rule and recursion equations,
with assumptions remaining to discharge*)
- Drule.standard (induction RS (rules RS conjI)))
+ Drule.export_without_context (induction RS (rules RS conjI)))
end
fun defer thy congs fid seqs =
--- a/src/HOL/Tools/arith_data.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/arith_data.ML Fri Feb 19 15:21:57 2010 +0000
@@ -110,8 +110,8 @@
fun prove_conv tacs ctxt (_: thm list) = prove_conv_nohyps tacs ctxt;
-fun prove_conv2 expand_tac norm_tac ss tu = (*FIXME avoid standard*)
- mk_meta_eq (Drule.standard (Goal.prove (Simplifier.the_context ss) [] []
+fun prove_conv2 expand_tac norm_tac ss tu = (* FIXME avoid Drule.export_without_context *)
+ mk_meta_eq (Drule.export_without_context (Goal.prove (Simplifier.the_context ss) [] []
(HOLogic.mk_Trueprop (HOLogic.mk_eq tu))
(K (EVERY [expand_tac, norm_tac ss]))));
--- a/src/HOL/Tools/choice_specification.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/choice_specification.ML Fri Feb 19 15:21:57 2010 +0000
@@ -75,7 +75,7 @@
fun add_specification axiomatic cos arg =
arg |> apsnd Thm.freezeT
|> proc_exprop axiomatic cos
- |> apsnd Drule.standard
+ |> apsnd Drule.export_without_context
(* Collect all intances of constants in term *)
@@ -189,7 +189,7 @@
in
args |> apsnd (remove_alls frees)
|> apsnd undo_imps
- |> apsnd Drule.standard
+ |> apsnd Drule.export_without_context
|> Thm.theory_attributes (map (Attrib.attribute thy) atts)
|> add_final
|> Library.swap
--- a/src/HOL/Tools/float_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/float_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,6 @@
-(* ID: $Id$
- Authors: Tobias Nipkow, TU Muenchen
+(* Author: Tobias Nipkow, TU Muenchen
-Concrete syntax for floats
+Concrete syntax for floats.
*)
signature FLOAT_SYNTAX =
@@ -9,7 +8,7 @@
val setup: theory -> theory
end;
-structure FloatSyntax: FLOAT_SYNTAX =
+structure Float_Syntax: FLOAT_SYNTAX =
struct
(* parse translation *)
@@ -18,19 +17,21 @@
fun mk_number i =
let
- fun mk 0 = Syntax.const @{const_name Int.Pls}
- | mk ~1 = Syntax.const @{const_name Int.Min}
- | mk i = let val (q, r) = Integer.div_mod i 2
- in HOLogic.mk_bit r $ (mk q) end;
- in Syntax.const @{const_name Int.number_of} $ mk i end;
+ fun mk 0 = Syntax.const @{const_syntax Int.Pls}
+ | mk ~1 = Syntax.const @{const_syntax Int.Min}
+ | mk i =
+ let val (q, r) = Integer.div_mod i 2
+ in HOLogic.mk_bit r $ (mk q) end;
+ in Syntax.const @{const_syntax Int.number_of} $ mk i end;
fun mk_frac str =
let
- val {mant=i, exp = n} = Syntax.read_float str;
- val exp = Syntax.const @{const_name Power.power};
+ val {mant = i, exp = n} = Syntax.read_float str;
+ val exp = Syntax.const @{const_syntax Power.power};
val ten = mk_number 10;
- val exp10 = if n=1 then ten else exp $ ten $ (mk_number n);
- in (Syntax.const @{const_name divide}) $ (mk_number i) $ exp10 end
+ val exp10 = if n = 1 then ten else exp $ ten $ mk_number n;
+ in Syntax.const @{const_syntax divide} $ mk_number i $ exp10 end;
+
in
fun float_tr (*"_Float"*) [t as Const (str, _)] = mk_frac str
@@ -42,6 +43,6 @@
(* theory setup *)
val setup =
- Sign.add_trfuns ([], [("_Float", float_tr)], [], []);
+ Sign.add_trfuns ([], [(@{syntax_const "_Float"}, float_tr)], [], []);
end;
--- a/src/HOL/Tools/inductive.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/inductive.ML Fri Feb 19 15:21:57 2010 +0000
@@ -184,7 +184,7 @@
case concl_of thm of
Const ("==", _) $ _ $ _ => eq2mono (thm RS meta_eq_to_obj_eq)
| _ $ (Const ("op =", _) $ _ $ _) => eq2mono thm
- | _ $ (Const (@{const_name Algebras.less_eq}, _) $ _ $ _) =>
+ | _ $ (Const (@{const_name Orderings.less_eq}, _) $ _ $ _) =>
dest_less_concl (Seq.hd (REPEAT (FIRSTGOAL
(resolve_tac [@{thm le_funI}, @{thm le_boolI'}])) thm))
| _ => thm
@@ -561,7 +561,7 @@
(list_comb (P, make_args' argTs xs (binder_types (fastype_of P))))) preds));
val ind_concl = HOLogic.mk_Trueprop
- (HOLogic.mk_binrel @{const_name Algebras.less_eq} (rec_const, ind_pred));
+ (HOLogic.mk_binrel @{const_name Orderings.less_eq} (rec_const, ind_pred));
val raw_fp_induct = (mono RS (fp_def RS @{thm def_lfp_induct}));
--- a/src/HOL/Tools/inductive_codegen.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/inductive_codegen.ML Fri Feb 19 15:21:57 2010 +0000
@@ -544,7 +544,7 @@
(fn NONE => "X" | SOME k' => string_of_int k')
(ks @ [SOME k]))) arities));
-fun prep_intrs intrs = map (rename_term o #prop o rep_thm o Drule.standard) intrs;
+fun prep_intrs intrs = map (rename_term o #prop o rep_thm o Drule.export_without_context) intrs;
fun constrain cs [] = []
| constrain cs ((s, xs) :: ys) =
--- a/src/HOL/Tools/int_arith.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/int_arith.ML Fri Feb 19 15:21:57 2010 +0000
@@ -55,7 +55,7 @@
@{const_name Algebras.times}, @{const_name Algebras.uminus},
@{const_name Algebras.minus}, @{const_name Algebras.plus},
@{const_name Algebras.zero},
- @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
| check (a $ b) = check a andalso check b
| check _ = false;
@@ -71,8 +71,8 @@
val lhss' =
[@{cpat "(?x::?'a::ring_char_0) = (?y::?'a)"},
- @{cpat "(?x::?'a::ordered_idom) < (?y::?'a)"},
- @{cpat "(?x::?'a::ordered_idom) <= (?y::?'a)"}]
+ @{cpat "(?x::?'a::linordered_idom) < (?y::?'a)"},
+ @{cpat "(?x::?'a::linordered_idom) <= (?y::?'a)"}]
val zero_one_idom_simproc =
make_simproc {lhss = lhss' , name = "zero_one_idom_simproc",
@@ -80,9 +80,9 @@
val fast_int_arith_simproc =
Simplifier.simproc @{theory} "fast_int_arith"
- ["(m::'a::{ordered_idom,number_ring}) < n",
- "(m::'a::{ordered_idom,number_ring}) <= n",
- "(m::'a::{ordered_idom,number_ring}) = n"] (K Lin_Arith.simproc);
+ ["(m::'a::{linordered_idom,number_ring}) < n",
+ "(m::'a::{linordered_idom,number_ring}) <= n",
+ "(m::'a::{linordered_idom,number_ring}) = n"] (K Lin_Arith.simproc);
val global_setup = Simplifier.map_simpset
(fn simpset => simpset addsimprocs [fast_int_arith_simproc]);
--- a/src/HOL/Tools/lin_arith.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/lin_arith.ML Fri Feb 19 15:21:57 2010 +0000
@@ -150,7 +150,7 @@
(SOME t', m'') => (SOME (mC $ s' $ t'), m'')
| (NONE, m'') => (SOME s', m''))
| (NONE, m') => demult (t, m')))
- | demult ((mC as Const (@{const_name Algebras.divide}, _)) $ s $ t, m) =
+ | demult ((mC as Const (@{const_name Rings.divide}, _)) $ s $ t, m) =
(* FIXME: Shouldn't we simplify nested quotients, e.g. '(s/t)/u' could
become 's/(t*u)', and '(s*t)/u' could become 's*(t/u)' ? Note that
if we choose to do so here, the simpset used by arith must be able to
@@ -212,7 +212,7 @@
(case demult inj_consts (all, m) of
(NONE, m') => (p, Rat.add i m')
| (SOME u, m') => add_atom u m' pi)
- | poly (all as Const (@{const_name Algebras.divide}, _) $ _ $ _, m, pi as (p, i)) =
+ | poly (all as Const (@{const_name Rings.divide}, _) $ _ $ _, m, pi as (p, i)) =
(case demult inj_consts (all, m) of
(NONE, m') => (p, Rat.add i m')
| (SOME u, m') => add_atom u m' pi)
@@ -229,14 +229,14 @@
val (q, j) = poly (rhs, Rat.one, ([], Rat.zero))
in
case rel of
- @{const_name Algebras.less} => SOME (p, i, "<", q, j)
- | @{const_name Algebras.less_eq} => SOME (p, i, "<=", q, j)
+ @{const_name Orderings.less} => SOME (p, i, "<", q, j)
+ | @{const_name Orderings.less_eq} => SOME (p, i, "<=", q, j)
| "op =" => SOME (p, i, "=", q, j)
| _ => NONE
end handle Rat.DIVZERO => NONE;
fun of_lin_arith_sort thy U =
- Sign.of_sort thy (U, @{sort Ring_and_Field.ordered_idom});
+ Sign.of_sort thy (U, @{sort Rings.linordered_idom});
fun allows_lin_arith thy (discrete : string list) (U as Type (D, [])) : bool * bool =
if of_lin_arith_sort thy U then (true, member (op =) discrete D)
@@ -292,7 +292,7 @@
case head_of lhs of
Const (a, _) => member (op =) [@{const_name Orderings.max},
@{const_name Orderings.min},
- @{const_name Algebras.abs},
+ @{const_name Groups.abs},
@{const_name Algebras.minus},
"Int.nat" (*DYNAMIC BINDING!*),
"Divides.div_class.mod" (*DYNAMIC BINDING!*),
@@ -372,7 +372,7 @@
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, t2)]) rev_terms
- val t1_leq_t2 = Const (@{const_name Algebras.less_eq},
+ val t1_leq_t2 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val not_t1_leq_t2 = HOLogic.Not $ t1_leq_t2
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
@@ -387,7 +387,7 @@
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, t2)]) rev_terms
- val t1_leq_t2 = Const (@{const_name Algebras.less_eq},
+ val t1_leq_t2 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val not_t1_leq_t2 = HOLogic.Not $ t1_leq_t2
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
@@ -397,16 +397,16 @@
SOME [(Ts, subgoal1), (Ts, subgoal2)]
end
(* ?P (abs ?a) = ((0 <= ?a --> ?P ?a) & (?a < 0 --> ?P (- ?a))) *)
- | (Const (@{const_name Algebras.abs}, _), [t1]) =>
+ | (Const (@{const_name Groups.abs}, _), [t1]) =>
let
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, Const (@{const_name Algebras.uminus},
split_type --> split_type) $ t1)]) rev_terms
val zero = Const (@{const_name Algebras.zero}, split_type)
- val zero_leq_t1 = Const (@{const_name Algebras.less_eq},
+ val zero_leq_t1 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ t1
- val t1_lt_zero = Const (@{const_name Algebras.less},
+ val t1_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t1 $ zero
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
val subgoal1 = (HOLogic.mk_Trueprop zero_leq_t1) :: terms1 @ [not_false]
@@ -427,7 +427,7 @@
(map (incr_boundvars 1) rev_terms)
val t1' = incr_boundvars 1 t1
val t2' = incr_boundvars 1 t2
- val t1_lt_t2 = Const (@{const_name Algebras.less},
+ val t1_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val t1_eq_t2_plus_d = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus},
@@ -451,7 +451,7 @@
val t1' = incr_boundvars 1 t1
val t1_eq_nat_n = Const ("op =", HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ t1' $
(Const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) $ n)
- val t1_lt_zero = Const (@{const_name Algebras.less},
+ val t1_lt_zero = Const (@{const_name Orderings.less},
HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ t1 $ zero_int
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
val subgoal1 = (HOLogic.mk_Trueprop t1_eq_nat_n) :: terms1 @ [not_false]
@@ -477,7 +477,7 @@
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
val t2_neq_zero = HOLogic.mk_not (Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero)
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -509,7 +509,7 @@
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
val t2_neq_zero = HOLogic.mk_not (Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero)
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -545,17 +545,17 @@
val t2' = incr_boundvars 2 t2
val t2_eq_zero = Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
- val zero_lt_t2 = Const (@{const_name Algebras.less},
+ val zero_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ zero $ t2'
- val t2_lt_zero = Const (@{const_name Algebras.less},
+ val t2_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero
- val zero_leq_j = Const (@{const_name Algebras.less_eq},
+ val zero_leq_j = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ j
- val j_leq_zero = Const (@{const_name Algebras.less_eq},
+ val j_leq_zero = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ j $ zero
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
- val t2_lt_j = Const (@{const_name Algebras.less},
+ val t2_lt_j = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ t2' $ j
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -599,17 +599,17 @@
val t2' = incr_boundvars 2 t2
val t2_eq_zero = Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
- val zero_lt_t2 = Const (@{const_name Algebras.less},
+ val zero_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ zero $ t2'
- val t2_lt_zero = Const (@{const_name Algebras.less},
+ val t2_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero
- val zero_leq_j = Const (@{const_name Algebras.less_eq},
+ val zero_leq_j = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ j
- val j_leq_zero = Const (@{const_name Algebras.less_eq},
+ val j_leq_zero = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ j $ zero
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
- val t2_lt_j = Const (@{const_name Algebras.less},
+ val t2_lt_j = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ t2' $ j
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -804,18 +804,18 @@
val init_arith_data =
Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, number_of, ...} =>
- {add_mono_thms = @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field} @ add_mono_thms,
+ {add_mono_thms = @{thms add_mono_thms_linordered_semiring} @ @{thms add_mono_thms_linordered_field} @ add_mono_thms,
mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} ::
@{lemma "a = b ==> c*a = c*b" by (rule arg_cong)} :: mult_mono_thms,
inj_thms = inj_thms,
lessD = lessD @ [@{thm "Suc_leI"}],
- neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_ordered_idom}],
+ neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_linordered_idom}],
simpset = HOL_basic_ss
addsimps @{thms ring_distribs}
addsimps [@{thm if_True}, @{thm if_False}]
addsimps
- [@{thm "monoid_add_class.add_0_left"},
- @{thm "monoid_add_class.add_0_right"},
+ [@{thm add_0_left},
+ @{thm add_0_right},
@{thm "Zero_not_Suc"}, @{thm "Suc_not_Zero"}, @{thm "le_0_eq"}, @{thm "One_nat_def"},
@{thm "order_less_irrefl"}, @{thm "zero_neq_one"}, @{thm "zero_less_one"},
@{thm "zero_le_one"}, @{thm "zero_neq_one"} RS not_sym, @{thm "not_one_le_zero"},
--- a/src/HOL/Tools/nat_arith.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/nat_arith.ML Fri Feb 19 15:21:57 2010 +0000
@@ -50,8 +50,8 @@
val mk_sum = mk_norm_sum;
val dest_sum = dest_sum;
val prove_conv = Arith_Data.prove_conv2;
- val norm_tac1 = Arith_Data.simp_all_tac [@{thm "add_Suc"}, @{thm "add_Suc_right"},
- @{thm "add_0"}, @{thm "add_0_right"}];
+ val norm_tac1 = Arith_Data.simp_all_tac [@{thm add_Suc}, @{thm add_Suc_right},
+ @{thm Nat.add_0}, @{thm Nat.add_0_right}];
val norm_tac2 = Arith_Data.simp_all_tac @{thms add_ac};
fun norm_tac ss = norm_tac1 ss THEN norm_tac2 ss;
fun gen_uncancel_tac rule = let val rule' = rule RS @{thm subst_equals}
@@ -69,16 +69,16 @@
structure LessCancelSums = CancelSumsFun
(struct
open CommonCancelSums;
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less};
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT;
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less};
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT;
val uncancel_tac = gen_uncancel_tac @{thm "nat_add_left_cancel_less"};
end);
structure LeCancelSums = CancelSumsFun
(struct
open CommonCancelSums;
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq};
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT;
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq};
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT;
val uncancel_tac = gen_uncancel_tac @{thm "nat_add_left_cancel_le"};
end);
--- a/src/HOL/Tools/nat_numeral_simprocs.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/nat_numeral_simprocs.ML Fri Feb 19 15:21:57 2010 +0000
@@ -124,7 +124,7 @@
(*Simplify 1*n and n*1 to n*)
-val add_0s = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
+val add_0s = map rename_numerals [@{thm Nat.add_0}, @{thm Nat.add_0_right}];
val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
@@ -136,7 +136,7 @@
val simplify_meta_eq =
Arith_Data.simplify_meta_eq
- ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
+ ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm Nat.add_0}, @{thm Nat.add_0_right},
@{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
@@ -176,8 +176,8 @@
structure LessCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
val bal_add1 = @{thm nat_less_add_iff1} RS trans
val bal_add2 = @{thm nat_less_add_iff2} RS trans
);
@@ -185,8 +185,8 @@
structure LeCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
val bal_add1 = @{thm nat_le_add_iff1} RS trans
val bal_add2 = @{thm nat_le_add_iff2} RS trans
);
@@ -290,8 +290,8 @@
structure DvdCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
- val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Rings.dvd}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.dvd} HOLogic.natT
val cancel = @{thm nat_mult_dvd_cancel1} RS trans
val neg_exchanges = false
)
@@ -308,8 +308,8 @@
structure LessCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
val cancel = @{thm nat_mult_less_cancel1} RS trans
val neg_exchanges = true
)
@@ -317,8 +317,8 @@
structure LeCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
val cancel = @{thm nat_mult_le_cancel1} RS trans
val neg_exchanges = true
)
@@ -387,16 +387,16 @@
structure LessCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
fun simp_conv _ _ = SOME @{thm nat_mult_less_cancel_disj}
);
structure LeCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
fun simp_conv _ _ = SOME @{thm nat_mult_le_cancel_disj}
);
@@ -411,8 +411,8 @@
structure DvdCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
- val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Rings.dvd}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.dvd} HOLogic.natT
fun simp_conv _ _ = SOME @{thm nat_mult_dvd_cancel_disj}
);
--- a/src/HOL/Tools/numeral_simprocs.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/numeral_simprocs.ML Fri Feb 19 15:21:57 2010 +0000
@@ -96,7 +96,7 @@
Fractions are reduced later by the cancel_numeral_factor simproc.*)
fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
-val mk_divide = HOLogic.mk_binop @{const_name Algebras.divide};
+val mk_divide = HOLogic.mk_binop @{const_name Rings.divide};
(*Build term (p / q) * t*)
fun mk_fcoeff ((p, q), t) =
@@ -105,7 +105,7 @@
(*Express t as a product of a fraction with other sorted terms*)
fun dest_fcoeff sign (Const (@{const_name Algebras.uminus}, _) $ t) = dest_fcoeff (~sign) t
- | dest_fcoeff sign (Const (@{const_name Algebras.divide}, _) $ t $ u) =
+ | dest_fcoeff sign (Const (@{const_name Rings.divide}, _) $ t $ u) =
let val (p, t') = dest_coeff sign t
val (q, u') = dest_coeff 1 u
in (mk_frac (p, q), mk_divide (t', u')) end
@@ -181,9 +181,8 @@
(*To let us treat division as multiplication*)
val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
-(*push the unary minus down: - x * y = x * - y *)
-val minus_mult_eq_1_to_2 =
- [@{thm mult_minus_left}, @{thm minus_mult_right}] MRS trans |> Drule.standard;
+(*push the unary minus down*)
+val minus_mult_eq_1_to_2 = @{lemma "- (a::'a::ring) * b = a * - b" by simp};
(*to extract again any uncancelled minuses*)
val minus_from_mult_simps =
@@ -230,8 +229,8 @@
structure LessCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val bal_add1 = @{thm less_add_iff1} RS trans
val bal_add2 = @{thm less_add_iff2} RS trans
);
@@ -239,8 +238,8 @@
structure LeCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val bal_add1 = @{thm le_add_iff1} RS trans
val bal_add2 = @{thm le_add_iff2} RS trans
);
@@ -256,20 +255,20 @@
"(l::'a::number_ring) = m * n"],
K EqCancelNumerals.proc),
("intless_cancel_numerals",
- ["(l::'a::{ordered_idom,number_ring}) + m < n",
- "(l::'a::{ordered_idom,number_ring}) < m + n",
- "(l::'a::{ordered_idom,number_ring}) - m < n",
- "(l::'a::{ordered_idom,number_ring}) < m - n",
- "(l::'a::{ordered_idom,number_ring}) * m < n",
- "(l::'a::{ordered_idom,number_ring}) < m * n"],
+ ["(l::'a::{linordered_idom,number_ring}) + m < n",
+ "(l::'a::{linordered_idom,number_ring}) < m + n",
+ "(l::'a::{linordered_idom,number_ring}) - m < n",
+ "(l::'a::{linordered_idom,number_ring}) < m - n",
+ "(l::'a::{linordered_idom,number_ring}) * m < n",
+ "(l::'a::{linordered_idom,number_ring}) < m * n"],
K LessCancelNumerals.proc),
("intle_cancel_numerals",
- ["(l::'a::{ordered_idom,number_ring}) + m <= n",
- "(l::'a::{ordered_idom,number_ring}) <= m + n",
- "(l::'a::{ordered_idom,number_ring}) - m <= n",
- "(l::'a::{ordered_idom,number_ring}) <= m - n",
- "(l::'a::{ordered_idom,number_ring}) * m <= n",
- "(l::'a::{ordered_idom,number_ring}) <= m * n"],
+ ["(l::'a::{linordered_idom,number_ring}) + m <= n",
+ "(l::'a::{linordered_idom,number_ring}) <= m + n",
+ "(l::'a::{linordered_idom,number_ring}) - m <= n",
+ "(l::'a::{linordered_idom,number_ring}) <= m - n",
+ "(l::'a::{linordered_idom,number_ring}) * m <= n",
+ "(l::'a::{linordered_idom,number_ring}) <= m * n"],
K LeCancelNumerals.proc)];
structure CombineNumeralsData =
@@ -374,7 +373,7 @@
[@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}] @ simps
fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
val simplify_meta_eq = Arith_Data.simplify_meta_eq
- [@{thm add_0}, @{thm add_0_right}, @{thm mult_zero_left},
+ [@{thm Nat.add_0}, @{thm Nat.add_0_right}, @{thm mult_zero_left},
@{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
end
@@ -392,8 +391,8 @@
structure DivideCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binop @{const_name Algebras.divide}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.divide} Term.dummyT
+ val mk_bal = HOLogic.mk_binop @{const_name Rings.divide}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
val cancel = @{thm mult_divide_mult_cancel_left} RS trans
val neg_exchanges = false
)
@@ -410,8 +409,8 @@
structure LessCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val cancel = @{thm mult_less_cancel_left} RS trans
val neg_exchanges = true
)
@@ -419,8 +418,8 @@
structure LeCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val cancel = @{thm mult_le_cancel_left} RS trans
val neg_exchanges = true
)
@@ -432,12 +431,12 @@
"(l::'a::{idom,number_ring}) = m * n"],
K EqCancelNumeralFactor.proc),
("ring_less_cancel_numeral_factor",
- ["(l::'a::{ordered_idom,number_ring}) * m < n",
- "(l::'a::{ordered_idom,number_ring}) < m * n"],
+ ["(l::'a::{linordered_idom,number_ring}) * m < n",
+ "(l::'a::{linordered_idom,number_ring}) < m * n"],
K LessCancelNumeralFactor.proc),
("ring_le_cancel_numeral_factor",
- ["(l::'a::{ordered_idom,number_ring}) * m <= n",
- "(l::'a::{ordered_idom,number_ring}) <= m * n"],
+ ["(l::'a::{linordered_idom,number_ring}) * m <= n",
+ "(l::'a::{linordered_idom,number_ring}) <= m * n"],
K LeCancelNumeralFactor.proc),
("int_div_cancel_numeral_factors",
["((l::'a::{semiring_div,number_ring}) * m) div n",
@@ -486,7 +485,7 @@
fun sign_conv pos_th neg_th ss t =
let val T = fastype_of t;
val zero = Const(@{const_name Algebras.zero}, T);
- val less = Const(@{const_name Algebras.less}, [T,T] ---> HOLogic.boolT);
+ val less = Const(@{const_name Orderings.less}, [T,T] ---> HOLogic.boolT);
val pos = less $ zero $ t and neg = less $ t $ zero
fun prove p =
Option.map Eq_True_elim (Lin_Arith.simproc ss p)
@@ -525,8 +524,8 @@
structure LeCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val simp_conv = sign_conv
@{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
);
@@ -535,8 +534,8 @@
structure LessCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val simp_conv = sign_conv
@{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
);
@@ -562,8 +561,8 @@
structure DvdCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
- val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Rings.dvd}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.dvd} Term.dummyT
fun simp_conv _ _ = SOME @{thm dvd_mult_cancel_left}
);
@@ -571,8 +570,8 @@
structure DivideCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binop @{const_name Algebras.divide}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.divide} Term.dummyT
+ val mk_bal = HOLogic.mk_binop @{const_name Rings.divide}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
fun simp_conv _ _ = SOME @{thm mult_divide_mult_cancel_left_if}
);
@@ -582,13 +581,13 @@
["(l::'a::idom) * m = n",
"(l::'a::idom) = m * n"],
K EqCancelFactor.proc),
- ("ordered_ring_le_cancel_factor",
- ["(l::'a::ordered_ring) * m <= n",
- "(l::'a::ordered_ring) <= m * n"],
+ ("linordered_ring_le_cancel_factor",
+ ["(l::'a::linordered_ring) * m <= n",
+ "(l::'a::linordered_ring) <= m * n"],
K LeCancelFactor.proc),
- ("ordered_ring_less_cancel_factor",
- ["(l::'a::ordered_ring) * m < n",
- "(l::'a::ordered_ring) < m * n"],
+ ("linordered_ring_less_cancel_factor",
+ ["(l::'a::linordered_ring) * m < n",
+ "(l::'a::linordered_ring) < m * n"],
K LessCancelFactor.proc),
("int_div_cancel_factor",
["((l::'a::semiring_div) * m) div n", "(l::'a::semiring_div) div (m * n)"],
--- a/src/HOL/Tools/numeral_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/numeral_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -9,7 +9,7 @@
val setup: theory -> theory
end;
-structure NumeralSyntax: NUMERAL_SYNTAX =
+structure Numeral_Syntax: NUMERAL_SYNTAX =
struct
(* parse translation *)
@@ -27,7 +27,7 @@
in
fun numeral_tr (*"_Numeral"*) [t as Const (num, _)] =
- Syntax.const @{const_name Int.number_of} $ mk_bin num
+ Syntax.const @{const_syntax Int.number_of} $ mk_bin num
| numeral_tr (*"_Numeral"*) ts = raise TERM ("numeral_tr", ts);
end;
@@ -37,10 +37,10 @@
local
-fun dest_bin (Const (@{const_syntax "Int.Pls"}, _)) = []
- | dest_bin (Const (@{const_syntax "Int.Min"}, _)) = [~1]
- | dest_bin (Const (@{const_syntax "Int.Bit0"}, _) $ bs) = 0 :: dest_bin bs
- | dest_bin (Const (@{const_syntax "Int.Bit1"}, _) $ bs) = 1 :: dest_bin bs
+fun dest_bin (Const (@{const_syntax Int.Pls}, _)) = []
+ | dest_bin (Const (@{const_syntax Int.Min}, _)) = [~1]
+ | dest_bin (Const (@{const_syntax Int.Bit0}, _) $ bs) = 0 :: dest_bin bs
+ | dest_bin (Const (@{const_syntax Int.Bit1}, _) $ bs) = 1 :: dest_bin bs
| dest_bin _ = raise Match;
fun leading _ [] = 0
@@ -64,11 +64,12 @@
end;
fun syntax_numeral t =
- Syntax.const "_Numeral" $ (Syntax.const "_numeral" $ Syntax.free (dest_bin_str t));
+ Syntax.const @{syntax_const "_Numeral"} $
+ (Syntax.const @{syntax_const "_numeral"} $ Syntax.free (dest_bin_str t));
in
-fun numeral_tr' show_sorts (*"number_of"*) (Type ("fun", [_, T])) (t :: ts) =
+fun numeral_tr' show_sorts (*"number_of"*) (Type ("fun", [_, T])) (t :: ts) = (* FIXME @{type_syntax} *)
let val t' =
if not (! show_types) andalso can Term.dest_Type T then syntax_numeral t
else Syntax.const Syntax.constrainC $ syntax_numeral t $ Syntax.term_of_typ show_sorts T
@@ -84,7 +85,7 @@
(* theory setup *)
val setup =
- Sign.add_trfuns ([], [("_Numeral", numeral_tr)], [], []) #>
+ Sign.add_trfuns ([], [(@{syntax_const "_Numeral"}, numeral_tr)], [], []) #>
Sign.add_trfunsT [(@{const_syntax Int.number_of}, numeral_tr')];
end;
--- a/src/HOL/Tools/primrec.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/primrec.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,16 +8,16 @@
signature PRIMREC =
sig
val add_primrec: (binding * typ option * mixfix) list ->
- (Attrib.binding * term) list -> local_theory -> thm list * local_theory
+ (Attrib.binding * term) list -> local_theory -> (term list * thm list) * local_theory
val add_primrec_cmd: (binding * string option * mixfix) list ->
- (Attrib.binding * string) list -> local_theory -> thm list * local_theory
+ (Attrib.binding * string) list -> local_theory -> (term list * thm list) * local_theory
val add_primrec_global: (binding * typ option * mixfix) list ->
- (Attrib.binding * term) list -> theory -> thm list * theory
+ (Attrib.binding * term) list -> theory -> (term list * thm list) * theory
val add_primrec_overloaded: (string * (string * typ) * bool) list ->
(binding * typ option * mixfix) list ->
- (Attrib.binding * term) list -> theory -> thm list * theory
+ (Attrib.binding * term) list -> theory -> (term list * thm list) * theory
val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
- local_theory -> (string * thm list list) * local_theory
+ local_theory -> (string * (term list * thm list)) * local_theory
end;
structure Primrec : PRIMREC =
@@ -244,7 +244,7 @@
val rewrites = rec_rewrites' @ map (snd o snd) defs;
fun tac _ = EVERY [rewrite_goals_tac rewrites, rtac refl 1];
val _ = message ("Proving equations for primrec function(s) " ^ commas_quote names);
- in map (fn eq => [Goal.prove lthy frees [] eq tac]) eqs end;
+ in map (fn eq => Goal.prove lthy frees [] eq tac) eqs end;
in ((prefix, (fs, defs)), prove) end
handle PrimrecError (msg, some_eqn) =>
error ("Primrec definition error:\n" ^ msg ^ (case some_eqn
@@ -260,7 +260,7 @@
in
lthy
|> fold_map Local_Theory.define defs
- |-> (fn defs => `(fn lthy => (prefix, prove lthy defs)))
+ |-> (fn defs => `(fn lthy => (prefix, (map fst defs, prove lthy defs))))
end;
local
@@ -285,10 +285,10 @@
in
lthy
|> add_primrec_simple fixes (map snd spec)
- |-> (fn (prefix, simps) => fold_map Local_Theory.note (attr_bindings prefix ~~ simps)
+ |-> (fn (prefix, (ts, simps)) => fold_map Local_Theory.note (attr_bindings prefix ~~ map single simps)
#-> (fn simps' => Local_Theory.note (simp_attr_binding prefix, maps snd simps')
+ #>> (fn (_, simps'') => (ts, simps''))
##> (Spec_Rules.add Spec_Rules.Equational (specs_of simps'))))
- |>> snd
end;
in
@@ -301,16 +301,16 @@
fun add_primrec_global fixes specs thy =
let
val lthy = Theory_Target.init NONE thy;
- val (simps, lthy') = add_primrec fixes specs lthy;
+ val ((ts, simps), lthy') = add_primrec fixes specs lthy;
val simps' = ProofContext.export lthy' lthy simps;
- in (simps', Local_Theory.exit_global lthy') end;
+ in ((ts, simps'), Local_Theory.exit_global lthy') end;
fun add_primrec_overloaded ops fixes specs thy =
let
val lthy = Theory_Target.overloading ops thy;
- val (simps, lthy') = add_primrec fixes specs lthy;
+ val ((ts, simps), lthy') = add_primrec fixes specs lthy;
val simps' = ProofContext.export lthy' lthy simps;
- in (simps', Local_Theory.exit_global lthy') end;
+ in ((ts, simps'), Local_Theory.exit_global lthy') end;
(* outer syntax *)
--- a/src/HOL/Tools/quickcheck_generators.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/quickcheck_generators.ML Fri Feb 19 15:21:57 2010 +0000
@@ -139,7 +139,7 @@
val eqs0 = [subst_v @{term "0::code_numeral"} eq,
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
+ val ((_, (_, eqs2)), lthy') = Primrec.add_primrec_simple
[((Binding.conceal (Binding.name random_aux), T), NoSyn)] eqs1 lthy;
val cT_random_aux = inst pt_random_aux;
val cT_rhs = inst pt_rhs;
@@ -148,7 +148,7 @@
[(cT_random_aux, cert t_random_aux), (cT_rhs, cert t_rhs)]);
val tac = ALLGOALS (rtac rule)
THEN ALLGOALS (simp_tac rew_ss)
- THEN (ALLGOALS (ProofContext.fact_tac (flat eqs2)))
+ THEN (ALLGOALS (ProofContext.fact_tac eqs2))
val simp = Skip_Proof.prove lthy' [v] [] eq (K tac);
in (simp, lthy') end;
--- a/src/HOL/Tools/record.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/record.ML Fri Feb 19 15:21:57 2010 +0000
@@ -9,6 +9,18 @@
signature BASIC_RECORD =
sig
+ type record_info =
+ {args: (string * sort) list,
+ parent: (typ list * string) option,
+ fields: (string * typ) list,
+ extension: (string * typ list),
+ ext_induct: thm, ext_inject: thm, ext_surjective: thm, ext_split: thm, ext_def: thm,
+ select_convs: thm list, update_convs: thm list, select_defs: thm list, update_defs: thm list,
+ fold_congs: thm list, unfold_congs: thm list, splits: thm list, defs: thm list,
+ surjective: thm, equality: thm, induct_scheme: thm, induct: thm, cases_scheme: thm,
+ cases: thm, simps: thm list, iffs: thm list}
+ val get_record: theory -> string -> record_info option
+ val the_record: theory -> string -> record_info
val record_simproc: simproc
val record_eq_simproc: simproc
val record_upd_simproc: simproc
@@ -42,10 +54,10 @@
val print_records: theory -> unit
val read_typ: Proof.context -> string -> (string * sort) list -> typ * (string * sort) list
val cert_typ: Proof.context -> typ -> (string * sort) list -> typ * (string * sort) list
- val add_record: bool -> string list * string -> string option -> (string * string * mixfix) list
- -> theory -> theory
- val add_record_i: bool -> string list * string -> (typ list * string) option
- -> (string * typ * mixfix) list -> theory -> theory
+ val add_record: bool -> string list * binding -> (typ list * string) option ->
+ (binding * typ * mixfix) list -> theory -> theory
+ val add_record_cmd: bool -> string list * binding -> string option ->
+ (binding * string * mixfix) list -> theory -> theory
val setup: theory -> theory
end;
@@ -71,8 +83,7 @@
fun named_cterm_instantiate values thm =
let
- fun match name ((name', _), _) = name = name'
- | match name _ = false;
+ fun match name ((name', _), _) = name = name';
fun getvar name =
(case find_first (match name) (Term.add_vars (prop_of thm) []) of
SOME var => cterm_of (theory_of_thm thm) (Var var)
@@ -93,8 +104,8 @@
let
fun get_thms thy name =
let
- val SOME {Rep_inject = rep_inject, Abs_name = absN, abs_type = absT,
- Abs_inverse = abs_inverse, ...} = Typedef.get_info thy name;
+ val {Rep_inject = rep_inject, Abs_name = absN, abs_type = absT,
+ Abs_inverse = abs_inverse, ...} = Typedef.the_info thy name;
val rewrite_rule =
MetaSimplifier.rewrite_rule [@{thm iso_tuple_UNIV_I}, @{thm iso_tuple_True_simp}];
in
@@ -142,7 +153,8 @@
val ([isom_def], cdef_thy) =
typ_thy
|> Sign.add_consts_i [Syntax.no_syn (isom_bind, isomT)]
- |> PureThy.add_defs false [Thm.no_attributes (apfst Binding.name isom_spec)];
+ |> PureThy.add_defs false
+ [Thm.no_attributes (apfst (Binding.conceal o Binding.name) isom_spec)];
val iso_tuple = isom_def RS (abs_inverse RS (rep_inject RS iso_tuple_intro));
val cons = Const (@{const_name iso_tuple_cons}, isomT --> leftT --> rightT --> absT);
@@ -156,7 +168,8 @@
((isom, cons $ isom), thm_thy)
end;
-val iso_tuple_intros_tac = resolve_from_net_tac iso_tuple_intros THEN'
+val iso_tuple_intros_tac =
+ resolve_from_net_tac iso_tuple_intros THEN'
CSUBGOAL (fn (cgoal, i) =>
let
val thy = Thm.theory_of_cterm cgoal;
@@ -189,7 +202,7 @@
val meta_allE = @{thm Pure.meta_allE};
val prop_subst = @{thm prop_subst};
val K_record_comp = @{thm K_record_comp};
-val K_comp_convs = [@{thm o_apply}, K_record_comp]
+val K_comp_convs = [@{thm o_apply}, K_record_comp];
val o_assoc = @{thm o_assoc};
val id_apply = @{thm id_apply};
val id_o_apps = [@{thm id_apply}, @{thm id_o}, @{thm o_id}];
@@ -197,21 +210,21 @@
val refl_conj_eq = @{thm refl_conj_eq};
-val surject_assistI = @{thm "iso_tuple_surjective_proof_assistI"};
-val surject_assist_idE = @{thm "iso_tuple_surjective_proof_assist_idE"};
-
-val updacc_accessor_eqE = @{thm "update_accessor_accessor_eqE"};
-val updacc_updator_eqE = @{thm "update_accessor_updator_eqE"};
-val updacc_eq_idI = @{thm "iso_tuple_update_accessor_eq_assist_idI"};
-val updacc_eq_triv = @{thm "iso_tuple_update_accessor_eq_assist_triv"};
-
-val updacc_foldE = @{thm "update_accessor_congruence_foldE"};
-val updacc_unfoldE = @{thm "update_accessor_congruence_unfoldE"};
-val updacc_noopE = @{thm "update_accessor_noopE"};
-val updacc_noop_compE = @{thm "update_accessor_noop_compE"};
-val updacc_cong_idI = @{thm "update_accessor_cong_assist_idI"};
-val updacc_cong_triv = @{thm "update_accessor_cong_assist_triv"};
-val updacc_cong_from_eq = @{thm "iso_tuple_update_accessor_cong_from_eq"};
+val surject_assistI = @{thm iso_tuple_surjective_proof_assistI};
+val surject_assist_idE = @{thm iso_tuple_surjective_proof_assist_idE};
+
+val updacc_accessor_eqE = @{thm update_accessor_accessor_eqE};
+val updacc_updator_eqE = @{thm update_accessor_updator_eqE};
+val updacc_eq_idI = @{thm iso_tuple_update_accessor_eq_assist_idI};
+val updacc_eq_triv = @{thm iso_tuple_update_accessor_eq_assist_triv};
+
+val updacc_foldE = @{thm update_accessor_congruence_foldE};
+val updacc_unfoldE = @{thm update_accessor_congruence_unfoldE};
+val updacc_noopE = @{thm update_accessor_noopE};
+val updacc_noop_compE = @{thm update_accessor_noop_compE};
+val updacc_cong_idI = @{thm update_accessor_cong_assist_idI};
+val updacc_cong_triv = @{thm update_accessor_cong_assist_triv};
+val updacc_cong_from_eq = @{thm iso_tuple_update_accessor_cong_from_eq};
val o_eq_dest = @{thm o_eq_dest};
val o_eq_id_dest = @{thm o_eq_id_dest};
@@ -257,11 +270,9 @@
val Trueprop = HOLogic.mk_Trueprop;
fun All xs t = Term.list_all_free (xs, t);
-infix 9 $$;
infix 0 :== ===;
infixr 0 ==>;
-val op $$ = Term.list_comb;
val op :== = Primitive_Defs.mk_defpair;
val op === = Trueprop o HOLogic.mk_eq;
val op ==> = Logic.mk_implies;
@@ -337,24 +348,55 @@
parent: (typ list * string) option,
fields: (string * typ) list,
extension: (string * typ list),
+
+ ext_induct: thm,
+ ext_inject: thm,
+ ext_surjective: thm,
+ ext_split: thm,
+ ext_def: thm,
+
+ select_convs: thm list,
+ update_convs: thm list,
+ select_defs: thm list,
+ update_defs: thm list,
+ fold_congs: thm list,
+ unfold_congs: thm list,
+ splits: thm list,
+ defs: thm list,
+
+ surjective: thm,
+ equality: thm,
+ induct_scheme: thm,
induct: thm,
- extdef: thm};
-
-fun make_record_info args parent fields extension induct extdef =
+ cases_scheme: thm,
+ cases: thm,
+
+ simps: thm list,
+ iffs: thm list};
+
+fun make_record_info args parent fields extension
+ ext_induct ext_inject ext_surjective ext_split ext_def
+ select_convs update_convs select_defs update_defs fold_congs unfold_congs splits defs
+ surjective equality induct_scheme induct cases_scheme cases
+ simps iffs : record_info =
{args = args, parent = parent, fields = fields, extension = extension,
- induct = induct, extdef = extdef}: record_info;
-
+ ext_induct = ext_induct, ext_inject = ext_inject, ext_surjective = ext_surjective,
+ ext_split = ext_split, ext_def = ext_def, select_convs = select_convs,
+ update_convs = update_convs, select_defs = select_defs, update_defs = update_defs,
+ fold_congs = fold_congs, unfold_congs = unfold_congs, splits = splits, defs = defs,
+ surjective = surjective, equality = equality, induct_scheme = induct_scheme,
+ induct = induct, cases_scheme = cases_scheme, cases = cases, simps = simps, iffs = iffs};
type parent_info =
{name: string,
fields: (string * typ) list,
extension: (string * typ list),
- induct: thm,
- extdef: thm};
-
-fun make_parent_info name fields extension induct extdef =
+ induct_scheme: thm,
+ ext_def: thm};
+
+fun make_parent_info name fields extension ext_def induct_scheme : parent_info =
{name = name, fields = fields, extension = extension,
- induct = induct, extdef = extdef}: parent_info;
+ ext_def = ext_def, induct_scheme = induct_scheme};
(* theory data *)
@@ -371,7 +413,7 @@
equalities: thm Symtab.table,
extinjects: thm list,
extsplit: thm Symtab.table, (*maps extension name to split rule*)
- splits: (thm * thm * thm * thm) Symtab.table, (*!!, !, EX - split-equalities, induct rule*)
+ splits: (thm * thm * thm * thm) Symtab.table, (*!!, ALL, EX - split-equalities, induct rule*)
extfields: (string * typ) list Symtab.table, (*maps extension to its fields*)
fieldext: (string * typ list) Symtab.table}; (*maps field to its extension*)
@@ -381,7 +423,7 @@
equalities = equalities, extinjects=extinjects, extsplit = extsplit, splits = splits,
extfields = extfields, fieldext = fieldext }: record_data;
-structure RecordsData = Theory_Data
+structure Records_Data = Theory_Data
(
type T = record_data;
val empty =
@@ -434,7 +476,7 @@
fun print_records thy =
let
- val {records = recs, ...} = RecordsData.get thy;
+ val {records = recs, ...} = Records_Data.get thy;
val prt_typ = Syntax.pretty_typ_global thy;
fun pretty_parent NONE = []
@@ -454,20 +496,25 @@
(* access 'records' *)
-val get_record = Symtab.lookup o #records o RecordsData.get;
+val get_record = Symtab.lookup o #records o Records_Data.get;
+
+fun the_record thy name =
+ (case get_record thy name of
+ SOME info => info
+ | NONE => error ("Unknown record type " ^ quote name));
fun put_record name info thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ Records_Data.get thy;
val data = make_record_data (Symtab.update (name, info) records)
sel_upd equalities extinjects extsplit splits extfields fieldext;
- in RecordsData.put data thy end;
+ in Records_Data.put data thy end;
(* access 'sel_upd' *)
-val get_sel_upd = #sel_upd o RecordsData.get;
+val get_sel_upd = #sel_upd o Records_Data.get;
val is_selector = Symtab.defined o #selectors o get_sel_upd;
val get_updates = Symtab.lookup o #updates o get_sel_upd;
@@ -492,7 +539,7 @@
val upds = map (suffix updateN) all ~~ all;
val {records, sel_upd = {selectors, updates, simpset, defset, foldcong, unfoldcong},
- equalities, extinjects, extsplit, splits, extfields, fieldext} = RecordsData.get thy;
+ equalities, extinjects, extsplit, splits, extfields, fieldext} = Records_Data.get thy;
val data = make_record_data records
{selectors = fold Symtab.update_new sels selectors,
updates = fold Symtab.update_new upds updates,
@@ -501,7 +548,7 @@
foldcong = foldcong addcongs folds,
unfoldcong = unfoldcong addcongs unfolds}
equalities extinjects extsplit splits extfields fieldext;
- in RecordsData.put data thy end;
+ in Records_Data.put data thy end;
(* access 'equalities' *)
@@ -509,12 +556,12 @@
fun add_record_equalities name thm thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ Records_Data.get thy;
val data = make_record_data records sel_upd
(Symtab.update_new (name, thm) equalities) extinjects extsplit splits extfields fieldext;
- in RecordsData.put data thy end;
-
-val get_equalities = Symtab.lookup o #equalities o RecordsData.get;
+ in Records_Data.put data thy end;
+
+val get_equalities = Symtab.lookup o #equalities o Records_Data.get;
(* access 'extinjects' *)
@@ -522,13 +569,13 @@
fun add_extinjects thm thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ Records_Data.get thy;
val data =
make_record_data records sel_upd equalities (insert Thm.eq_thm_prop thm extinjects)
extsplit splits extfields fieldext;
- in RecordsData.put data thy end;
-
-val get_extinjects = rev o #extinjects o RecordsData.get;
+ in Records_Data.put data thy end;
+
+val get_extinjects = rev o #extinjects o Records_Data.get;
(* access 'extsplit' *)
@@ -536,11 +583,11 @@
fun add_extsplit name thm thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
- val data = make_record_data records sel_upd
- equalities extinjects (Symtab.update_new (name, thm) extsplit) splits
- extfields fieldext;
- in RecordsData.put data thy end;
+ Records_Data.get thy;
+ val data =
+ make_record_data records sel_upd equalities extinjects
+ (Symtab.update_new (name, thm) extsplit) splits extfields fieldext;
+ in Records_Data.put data thy end;
(* access 'splits' *)
@@ -548,19 +595,19 @@
fun add_record_splits name thmP thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
- val data = make_record_data records sel_upd
- equalities extinjects extsplit (Symtab.update_new (name, thmP) splits)
- extfields fieldext;
- in RecordsData.put data thy end;
-
-val get_splits = Symtab.lookup o #splits o RecordsData.get;
+ Records_Data.get thy;
+ val data =
+ make_record_data records sel_upd equalities extinjects extsplit
+ (Symtab.update_new (name, thmP) splits) extfields fieldext;
+ in Records_Data.put data thy end;
+
+val get_splits = Symtab.lookup o #splits o Records_Data.get;
(* parent/extension of named record *)
-val get_parent = (Option.join o Option.map #parent) oo (Symtab.lookup o #records o RecordsData.get);
-val get_extension = Option.map #extension oo (Symtab.lookup o #records o RecordsData.get);
+val get_parent = (Option.join o Option.map #parent) oo (Symtab.lookup o #records o Records_Data.get);
+val get_extension = Option.map #extension oo (Symtab.lookup o #records o Records_Data.get);
(* access 'extfields' *)
@@ -568,14 +615,13 @@
fun add_extfields name fields thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ Records_Data.get thy;
val data =
- make_record_data records sel_upd
- equalities extinjects extsplit splits
+ make_record_data records sel_upd equalities extinjects extsplit splits
(Symtab.update_new (name, fields) extfields) fieldext;
- in RecordsData.put data thy end;
-
-val get_extfields = Symtab.lookup o #extfields o RecordsData.get;
+ in Records_Data.put data thy end;
+
+val get_extfields = Symtab.lookup o #extfields o Records_Data.get;
fun get_extT_fields thy T =
let
@@ -585,21 +631,21 @@
in Long_Name.implode (rev (nm :: rst)) end;
val midx = maxidx_of_typs (moreT :: Ts);
val varifyT = varifyT midx;
- val {records, extfields, ...} = RecordsData.get thy;
- val (flds, (more, _)) = split_last (Symtab.lookup_list extfields name);
+ val {records, extfields, ...} = Records_Data.get thy;
+ val (fields, (more, _)) = split_last (Symtab.lookup_list extfields name);
val args = map varifyT (snd (#extension (the (Symtab.lookup records recname))));
- val subst = fold (Sign.typ_match thy) (but_last args ~~ but_last Ts) (Vartab.empty);
- val flds' = map (apsnd ((Envir.norm_type subst) o varifyT)) flds;
- in (flds', (more, moreT)) end;
+ val subst = fold (Sign.typ_match thy) (but_last args ~~ but_last Ts) Vartab.empty;
+ val fields' = map (apsnd (Envir.norm_type subst o varifyT)) fields;
+ in (fields', (more, moreT)) end;
fun get_recT_fields thy T =
let
- val (root_flds, (root_more, root_moreT)) = get_extT_fields thy T;
- val (rest_flds, rest_more) =
+ val (root_fields, (root_more, root_moreT)) = get_extT_fields thy T;
+ val (rest_fields, rest_more) =
if is_recT root_moreT then get_recT_fields thy root_moreT
else ([], (root_more, root_moreT));
- in (root_flds @ rest_flds, rest_more) end;
+ in (root_fields @ rest_fields, rest_more) end;
(* access 'fieldext' *)
@@ -607,15 +653,15 @@
fun add_fieldext extname_types fields thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ Records_Data.get thy;
val fieldext' =
fold (fn field => Symtab.update_new (field, extname_types)) fields fieldext;
val data =
make_record_data records sel_upd equalities extinjects
extsplit splits extfields fieldext';
- in RecordsData.put data thy end;
-
-val get_fieldext = Symtab.lookup o #fieldext o RecordsData.get;
+ in Records_Data.put data thy end;
+
+val get_fieldext = Symtab.lookup o #fieldext o Records_Data.get;
(* parent records *)
@@ -625,7 +671,7 @@
let
fun err msg = error (msg ^ " parent record " ^ quote name);
- val {args, parent, fields, extension, induct, extdef} =
+ val {args, parent, fields, extension, induct_scheme, ext_def, ...} =
(case get_record thy name of SOME info => info | NONE => err "Unknown");
val _ = if length types <> length args then err "Bad number of arguments for" else ();
@@ -641,7 +687,7 @@
val extension' = apsnd (map subst) extension;
in
add_parents thy parent'
- (make_parent_info name fields' extension' induct extdef :: parents)
+ (make_parent_info name fields' extension' ext_def induct_scheme :: parents)
end;
@@ -652,7 +698,8 @@
fun decode_type thy t =
let
- fun get_sort xs n = AList.lookup (op =) xs (n: indexname) |> the_default (Sign.defaultS thy);
+ fun get_sort env xi =
+ the_default (Sign.defaultS thy) (AList.lookup (op =) env (xi: indexname));
val map_sort = Sign.intern_sort thy;
in
Syntax.typ_of_term (get_sort (Syntax.term_sorts map_sort t)) map_sort t
@@ -662,149 +709,138 @@
(* parse translations *)
-fun gen_field_tr mark sfx (t as Const (c, _) $ Const (name, _) $ arg) =
- if c = mark then Syntax.const (suffix sfx name) $ Abs ("_", dummyT, arg)
- else raise TERM ("gen_field_tr: " ^ mark, [t])
- | gen_field_tr mark _ t = raise TERM ("gen_field_tr: " ^ mark, [t]);
-
-fun gen_fields_tr sep mark sfx (tm as Const (c, _) $ t $ u) =
- if c = sep then gen_field_tr mark sfx t :: gen_fields_tr sep mark sfx u
- else [gen_field_tr mark sfx tm]
- | gen_fields_tr _ mark sfx tm = [gen_field_tr mark sfx tm];
-
-
-fun record_update_tr [t, u] =
- Library.foldr (op $) (rev (gen_fields_tr "_updates" "_update" updateN u), t)
- | record_update_tr ts = raise TERM ("record_update_tr", ts);
-
-fun update_name_tr (Free (x, T) :: ts) = Free (suffix updateN x, T) $$ ts
- | update_name_tr (Const (x, T) :: ts) = Const (suffix updateN x, T) $$ ts
- | update_name_tr (((c as Const ("_constrain", _)) $ t $ ty) :: ts) =
- (c $ update_name_tr [t] $ (Syntax.const "fun" $ ty $ Syntax.const "dummy")) $$ ts
- | update_name_tr ts = raise TERM ("update_name_tr", ts);
-
-fun dest_ext_field mark (t as (Const (c, _) $ Const (name, _) $ arg)) =
- if c = mark then (name, arg)
- else raise TERM ("dest_ext_field: " ^ mark, [t])
- | dest_ext_field _ t = raise TERM ("dest_ext_field", [t]);
-
-fun dest_ext_fields sep mark (trm as (Const (c, _) $ t $ u)) =
- if c = sep then dest_ext_field mark t :: dest_ext_fields sep mark u
- else [dest_ext_field mark trm]
- | dest_ext_fields _ mark t = [dest_ext_field mark t];
-
-fun gen_ext_fields_tr sep mark sfx more ctxt t =
+local
+
+fun field_type_tr ((Const (@{syntax_const "_field_type"}, _) $ Const (name, _) $ arg)) =
+ (name, arg)
+ | field_type_tr t = raise TERM ("field_type_tr", [t]);
+
+fun field_types_tr (Const (@{syntax_const "_field_types"}, _) $ t $ u) =
+ field_type_tr t :: field_types_tr u
+ | field_types_tr t = [field_type_tr t];
+
+fun record_field_types_tr more ctxt t =
let
val thy = ProofContext.theory_of ctxt;
- val msg = "error in record input: ";
-
- val fieldargs = dest_ext_fields sep mark t;
- fun splitargs (field :: fields) ((name, arg) :: fargs) =
- if can (unsuffix name) field
- then
- let val (args, rest) = splitargs fields fargs
+ fun err msg = raise TERM ("Error in record-type input: " ^ msg, [t]);
+
+ fun split_args (field :: fields) ((name, arg) :: fargs) =
+ if can (unsuffix name) field then
+ let val (args, rest) = split_args fields fargs
in (arg :: args, rest) end
- else raise TERM (msg ^ "expecting field " ^ field ^ " but got " ^ name, [t])
- | splitargs [] (fargs as (_ :: _)) = ([], fargs)
- | splitargs (_ :: _) [] = raise TERM (msg ^ "expecting more fields", [t])
- | splitargs _ _ = ([], []);
-
- fun mk_ext (fargs as (name, _) :: _) =
- (case get_fieldext thy (Sign.intern_const thy name) of
- SOME (ext, _) =>
- (case get_extfields thy ext of
- SOME flds =>
- let
- val (args, rest) = splitargs (map fst (but_last flds)) fargs;
- val more' = mk_ext rest;
- in list_comb (Syntax.const (suffix sfx ext), args @ [more']) end
- | NONE => raise TERM (msg ^ "no fields defined for " ^ ext, [t]))
- | NONE => raise TERM (msg ^ name ^" is no proper field", [t]))
- | mk_ext [] = more;
- in mk_ext fieldargs end;
-
-fun gen_ext_type_tr sep mark sfx more ctxt t =
- let
- val thy = ProofContext.theory_of ctxt;
- val msg = "error in record-type input: ";
-
- val fieldargs = dest_ext_fields sep mark t;
- fun splitargs (field :: fields) ((name, arg) :: fargs) =
- if can (unsuffix name) field then
- let val (args, rest) = splitargs fields fargs
- in (arg :: args, rest) end
- else raise TERM (msg ^ "expecting field " ^ field ^ " but got " ^ name, [t])
- | splitargs [] (fargs as (_ :: _)) = ([], fargs)
- | splitargs (_ :: _) [] = raise TERM (msg ^ "expecting more fields", [t])
- | splitargs _ _ = ([], []);
+ else err ("expecting field " ^ field ^ " but got " ^ name)
+ | split_args [] (fargs as (_ :: _)) = ([], fargs)
+ | split_args (_ :: _) [] = err "expecting more fields"
+ | split_args _ _ = ([], []);
fun mk_ext (fargs as (name, _) :: _) =
(case get_fieldext thy (Sign.intern_const thy name) of
SOME (ext, alphas) =>
(case get_extfields thy ext of
- SOME flds =>
- (let
- val flds' = but_last flds;
- val types = map snd flds';
- val (args, rest) = splitargs (map fst flds') fargs;
+ SOME fields =>
+ let
+ val fields' = but_last fields;
+ val types = map snd fields';
+ val (args, rest) = split_args (map fst fields') fargs;
val argtypes = map (Sign.certify_typ thy o decode_type thy) args;
val midx = fold Term.maxidx_typ argtypes 0;
val varifyT = varifyT midx;
val vartypes = map varifyT types;
- val subst = fold (Sign.typ_match thy) (vartypes ~~ argtypes) Vartab.empty;
+ val subst = fold (Sign.typ_match thy) (vartypes ~~ argtypes) Vartab.empty
+ handle Type.TYPE_MATCH => err "type is no proper record (extension)";
val alphas' =
map (Syntax.term_of_typ (! Syntax.show_sorts) o Envir.norm_type subst o varifyT)
(but_last alphas);
val more' = mk_ext rest;
in
- list_comb (Syntax.const (suffix sfx ext), alphas' @ [more'])
- end handle Type.TYPE_MATCH =>
- raise TERM (msg ^ "type is no proper record (extension)", [t]))
- | NONE => raise TERM (msg ^ "no fields defined for " ^ ext, [t]))
- | NONE => raise TERM (msg ^ name ^" is no proper field", [t]))
+ (* FIXME authentic syntax *)
+ list_comb (Syntax.const (suffix ext_typeN ext), alphas' @ [more'])
+ end
+ | NONE => err ("no fields defined for " ^ ext))
+ | NONE => err (name ^ " is no proper field"))
| mk_ext [] = more;
-
- in mk_ext fieldargs end;
-
-fun gen_adv_record_tr sep mark sfx unit ctxt [t] =
- gen_ext_fields_tr sep mark sfx unit ctxt t
- | gen_adv_record_tr _ _ _ _ _ ts = raise TERM ("gen_record_tr", ts);
-
-fun gen_adv_record_scheme_tr sep mark sfx ctxt [t, more] =
- gen_ext_fields_tr sep mark sfx more ctxt t
- | gen_adv_record_scheme_tr _ _ _ _ ts = raise TERM ("gen_record_scheme_tr", ts);
-
-fun gen_adv_record_type_tr sep mark sfx unit ctxt [t] =
- gen_ext_type_tr sep mark sfx unit ctxt t
- | gen_adv_record_type_tr _ _ _ _ _ ts = raise TERM ("gen_record_tr", ts);
-
-fun gen_adv_record_type_scheme_tr sep mark sfx ctxt [t, more] =
- gen_ext_type_tr sep mark sfx more ctxt t
- | gen_adv_record_type_scheme_tr _ _ _ _ ts = raise TERM ("gen_record_scheme_tr", ts);
-
-val adv_record_tr = gen_adv_record_tr "_fields" "_field" extN HOLogic.unit;
-
-val adv_record_scheme_tr = gen_adv_record_scheme_tr "_fields" "_field" extN;
-
-val adv_record_type_tr =
- gen_adv_record_type_tr "_field_types" "_field_type" ext_typeN
- (Syntax.term_of_typ false (HOLogic.unitT));
-
-val adv_record_type_scheme_tr =
- gen_adv_record_type_scheme_tr "_field_types" "_field_type" ext_typeN;
-
+ in
+ mk_ext (field_types_tr t)
+ end;
+
+(* FIXME @{type_syntax} *)
+fun record_type_tr ctxt [t] = record_field_types_tr (Syntax.const "Product_Type.unit") ctxt t
+ | record_type_tr _ ts = raise TERM ("record_type_tr", ts);
+
+fun record_type_scheme_tr ctxt [t, more] = record_field_types_tr more ctxt t
+ | record_type_scheme_tr _ ts = raise TERM ("record_type_scheme_tr", ts);
+
+
+fun field_tr ((Const (@{syntax_const "_field"}, _) $ Const (name, _) $ arg)) = (name, arg)
+ | field_tr t = raise TERM ("field_tr", [t]);
+
+fun fields_tr (Const (@{syntax_const "_fields"}, _) $ t $ u) = field_tr t :: fields_tr u
+ | fields_tr t = [field_tr t];
+
+fun record_fields_tr more ctxt t =
+ let
+ val thy = ProofContext.theory_of ctxt;
+ fun err msg = raise TERM ("Error in record input: " ^ msg, [t]);
+
+ fun split_args (field :: fields) ((name, arg) :: fargs) =
+ if can (unsuffix name) field
+ then
+ let val (args, rest) = split_args fields fargs
+ in (arg :: args, rest) end
+ else err ("expecting field " ^ field ^ " but got " ^ name)
+ | split_args [] (fargs as (_ :: _)) = ([], fargs)
+ | split_args (_ :: _) [] = err "expecting more fields"
+ | split_args _ _ = ([], []);
+
+ fun mk_ext (fargs as (name, _) :: _) =
+ (case get_fieldext thy (Sign.intern_const thy name) of
+ SOME (ext, _) =>
+ (case get_extfields thy ext of
+ SOME fields =>
+ let
+ val (args, rest) = split_args (map fst (but_last fields)) fargs;
+ val more' = mk_ext rest;
+ in
+ (* FIXME authentic syntax *)
+ list_comb (Syntax.const (suffix extN ext), args @ [more'])
+ end
+ | NONE => err ("no fields defined for " ^ ext))
+ | NONE => err (name ^ " is no proper field"))
+ | mk_ext [] = more;
+ in mk_ext (fields_tr t) end;
+
+fun record_tr ctxt [t] = record_fields_tr (Syntax.const @{const_syntax Unity}) ctxt t
+ | record_tr _ ts = raise TERM ("record_tr", ts);
+
+fun record_scheme_tr ctxt [t, more] = record_fields_tr more ctxt t
+ | record_scheme_tr _ ts = raise TERM ("record_scheme_tr", ts);
+
+
+fun field_update_tr (Const (@{syntax_const "_field_update"}, _) $ Const (name, _) $ arg) =
+ Syntax.const (suffix updateN name) $ Abs ("_", dummyT, arg)
+ | field_update_tr t = raise TERM ("field_update_tr", [t]);
+
+fun field_updates_tr (Const (@{syntax_const "_field_updates"}, _) $ t $ u) =
+ field_update_tr t :: field_updates_tr u
+ | field_updates_tr t = [field_update_tr t];
+
+fun record_update_tr [t, u] = fold (curry op $) (field_updates_tr u) t
+ | record_update_tr ts = raise TERM ("record_update_tr", ts);
+
+in
val parse_translation =
- [("_record_update", record_update_tr),
- ("_update_name", update_name_tr)];
-
-val adv_parse_translation =
- [("_record", adv_record_tr),
- ("_record_scheme", adv_record_scheme_tr),
- ("_record_type", adv_record_type_tr),
- ("_record_type_scheme", adv_record_type_scheme_tr)];
+ [(@{syntax_const "_record_update"}, record_update_tr)];
+
+val advanced_parse_translation =
+ [(@{syntax_const "_record"}, record_tr),
+ (@{syntax_const "_record_scheme"}, record_scheme_tr),
+ (@{syntax_const "_record_type"}, record_type_tr),
+ (@{syntax_const "_record_type_scheme"}, record_type_scheme_tr)];
+
+end;
(* print translations *)
@@ -812,7 +848,9 @@
val print_record_type_abbr = Unsynchronized.ref true;
val print_record_type_as_fields = Unsynchronized.ref true;
-fun gen_field_upds_tr' mark sfx (tm as Const (name_field, _) $ k $ u) =
+local
+
+fun field_updates_tr' (tm as Const (c, _) $ k $ u) =
let
val t =
(case k of
@@ -821,86 +859,147 @@
| Abs (_, _, t) =>
if null (loose_bnos t) then t else raise Match
| _ => raise Match);
-
- (* FIXME ? *)
- (* (case k of (Const ("K_record", _) $ t) => t
- | Abs (x, _, Const ("K_record", _) $ t $ Bound 0) => t
- | _ => raise Match)*)
in
- (case try (unsuffix sfx) name_field of
+ (case try (unsuffix updateN) c of
SOME name =>
- apfst (cons (Syntax.const mark $ Syntax.free name $ t)) (gen_field_upds_tr' mark sfx u)
+ (* FIXME check wrt. record data (??) *)
+ (* FIXME early extern (!??) *)
+ apfst (cons (Syntax.const @{syntax_const "_field_update"} $ Syntax.free name $ t))
+ (field_updates_tr' u)
| NONE => ([], tm))
end
- | gen_field_upds_tr' _ _ tm = ([], tm);
+ | field_updates_tr' tm = ([], tm);
fun record_update_tr' tm =
- let val (ts, u) = gen_field_upds_tr' "_update" updateN tm in
- if null ts then raise Match
- else
- Syntax.const "_record_update" $ u $
- foldr1 (fn (v, w) => Syntax.const "_updates" $ v $ w) (rev ts)
- end;
-
-fun gen_field_tr' sfx tr' name =
- let val name_sfx = suffix sfx name
- in (name_sfx, fn [t, u] => tr' (Syntax.const name_sfx $ t $ u) | _ => raise Match) end;
-
-fun record_tr' sep mark record record_scheme unit ctxt t =
+ (case field_updates_tr' tm of
+ ([], _) => raise Match
+ | (ts, u) =>
+ Syntax.const @{syntax_const "_record_update"} $ u $
+ foldr1 (fn (v, w) => Syntax.const @{syntax_const "_field_updates"} $ v $ w) (rev ts));
+
+in
+
+fun field_update_tr' name =
+ let
+ (* FIXME authentic syntax *)
+ val update_name = suffix updateN name;
+ fun tr' [t, u] = record_update_tr' (Syntax.const update_name $ t $ u)
+ | tr' _ = raise Match;
+ in (update_name, tr') end;
+
+end;
+
+
+local
+
+(* FIXME early extern (!??) *)
+(* FIXME Syntax.free (??) *)
+fun field_tr' (c, t) = Syntax.const @{syntax_const "_field"} $ Syntax.const c $ t;
+
+fun fields_tr' (t, u) = Syntax.const @{syntax_const "_fields"} $ t $ u;
+
+fun record_tr' ctxt t =
let
val thy = ProofContext.theory_of ctxt;
- fun field_lst t =
+ fun strip_fields t =
(case strip_comb t of
(Const (ext, _), args as (_ :: _)) =>
- (case try (unsuffix extN) (Sign.intern_const thy ext) of
+ (case try (unsuffix extN) (Sign.intern_const thy ext) of (* FIXME authentic syntax *)
SOME ext' =>
(case get_extfields thy ext' of
- SOME flds =>
+ SOME fields =>
(let
- val f :: fs = but_last (map fst flds);
- val flds' = Sign.extern_const thy f :: map Long_Name.base_name fs;
+ val f :: fs = but_last (map fst fields);
+ val fields' = Sign.extern_const thy f :: map Long_Name.base_name fs;
val (args', more) = split_last args;
- in (flds' ~~ args') @ field_lst more end
+ in (fields' ~~ args') @ strip_fields more end
handle Library.UnequalLengths => [("", t)])
| NONE => [("", t)])
| NONE => [("", t)])
| _ => [("", t)]);
- val (flds, (_, more)) = split_last (field_lst t);
- val _ = if null flds then raise Match else ();
- val flds' = map (fn (n, t) => Syntax.const mark $ Syntax.const n $ t) flds;
- val flds'' = foldr1 (fn (x, y) => Syntax.const sep $ x $ y) flds';
+ val (fields, (_, more)) = split_last (strip_fields t);
+ val _ = null fields andalso raise Match;
+ val u = foldr1 fields_tr' (map field_tr' fields);
in
- if unit more
- then Syntax.const record $ flds''
- else Syntax.const record_scheme $ flds'' $ more
+ case more of
+ Const (@{const_syntax Unity}, _) => Syntax.const @{syntax_const "_record"} $ u
+ | _ => Syntax.const @{syntax_const "_record_scheme"} $ u $ more
end;
-fun gen_record_tr' name =
+in
+
+fun record_ext_tr' name =
+ let
+ val ext_name = suffix extN name;
+ fun tr' ctxt ts = record_tr' ctxt (list_comb (Syntax.const ext_name, ts));
+ in (ext_name, tr') end;
+
+end;
+
+
+local
+
+(* FIXME early extern (!??) *)
+(* FIXME Syntax.free (??) *)
+fun field_type_tr' (c, t) = Syntax.const @{syntax_const "_field_type"} $ Syntax.const c $ t;
+
+fun field_types_tr' (t, u) = Syntax.const @{syntax_const "_field_types"} $ t $ u;
+
+fun record_type_tr' ctxt t =
let
- val name_sfx = suffix extN name;
- val unit = (fn Const (@{const_syntax "Product_Type.Unity"}, _) => true | _ => false);
- fun tr' ctxt ts =
- record_tr' "_fields" "_field" "_record" "_record_scheme" unit ctxt
- (list_comb (Syntax.const name_sfx, ts));
- in (name_sfx, tr') end;
-
-fun print_translation names =
- map (gen_field_tr' updateN record_update_tr') names;
-
-
-(* record_type_abbr_tr' *)
+ val thy = ProofContext.theory_of ctxt;
+
+ val T = decode_type thy t;
+ val varifyT = varifyT (Term.maxidx_of_typ T);
+
+ val term_of_type = Syntax.term_of_typ (! Syntax.show_sorts) o Sign.extern_typ thy;
+
+ fun strip_fields T =
+ (case T of
+ Type (ext, args) =>
+ (case try (unsuffix ext_typeN) ext of
+ SOME ext' =>
+ (case get_extfields thy ext' of
+ SOME fields =>
+ (case get_fieldext thy (fst (hd fields)) of
+ SOME (_, alphas) =>
+ (let
+ val f :: fs = but_last fields;
+ val fields' =
+ apfst (Sign.extern_const thy) f :: map (apfst Long_Name.base_name) fs;
+ val (args', more) = split_last args;
+ val alphavars = map varifyT (but_last alphas);
+ val subst = fold (Sign.typ_match thy) (alphavars ~~ args') Vartab.empty;
+ val fields'' = (map o apsnd) (Envir.norm_type subst o varifyT) fields';
+ in fields'' @ strip_fields more end
+ handle Type.TYPE_MATCH => [("", T)]
+ | Library.UnequalLengths => [("", T)])
+ | NONE => [("", T)])
+ | NONE => [("", T)])
+ | NONE => [("", T)])
+ | _ => [("", T)]);
+
+ val (fields, (_, moreT)) = split_last (strip_fields T);
+ val _ = null fields andalso raise Match;
+ val u = foldr1 field_types_tr' (map (field_type_tr' o apsnd term_of_type) fields);
+ in
+ if not (! print_record_type_as_fields) orelse null fields then raise Match
+ else if moreT = HOLogic.unitT then Syntax.const @{syntax_const "_record_type"} $ u
+ else Syntax.const @{syntax_const "_record_type_scheme"} $ u $ term_of_type moreT
+ end;
(*try to reconstruct the record name type abbreviation from
the (nested) extension types*)
-fun record_type_abbr_tr' default_tr' abbr alphas zeta lastExt schemeT ctxt tm =
+fun record_type_abbr_tr' abbr alphas zeta last_ext schemeT ctxt tm =
let
val thy = ProofContext.theory_of ctxt;
(*tm is term representation of a (nested) field type. We first reconstruct the
type from tm so that we can continue on the type level rather then the term level*)
+ (* FIXME !??? *)
(*WORKAROUND:
If a record type occurs in an error message of type inference there
may be some internal frees donoted by ??:
@@ -929,80 +1028,35 @@
if ! print_record_type_abbr then
(case last_extT T of
SOME (name, _) =>
- if name = lastExt then
- (let val subst = match schemeT T in
+ if name = last_ext then
+ let val subst = match schemeT T in
if HOLogic.is_unitT (Envir.norm_type subst (varifyT (TFree (zeta, Sign.defaultS thy))))
then mk_type_abbr subst abbr alphas
else mk_type_abbr subst (suffix schemeN abbr) (alphas @ [zeta])
- end handle Type.TYPE_MATCH => default_tr' ctxt tm)
+ end handle Type.TYPE_MATCH => record_type_tr' ctxt tm
else raise Match (*give print translation of specialised record a chance*)
| _ => raise Match)
- else default_tr' ctxt tm
+ else record_type_tr' ctxt tm
end;
-fun record_type_tr' sep mark record record_scheme ctxt t =
+in
+
+fun record_ext_type_tr' name =
let
- val thy = ProofContext.theory_of ctxt;
-
- val T = decode_type thy t;
- val varifyT = varifyT (Term.maxidx_of_typ T);
-
- fun term_of_type T = Syntax.term_of_typ (! Syntax.show_sorts) (Sign.extern_typ thy T);
-
- fun field_lst T =
- (case T of
- Type (ext, args) =>
- (case try (unsuffix ext_typeN) ext of
- SOME ext' =>
- (case get_extfields thy ext' of
- SOME flds =>
- (case get_fieldext thy (fst (hd flds)) of
- SOME (_, alphas) =>
- (let
- val f :: fs = but_last flds;
- val flds' = apfst (Sign.extern_const thy) f ::
- map (apfst Long_Name.base_name) fs;
- val (args', more) = split_last args;
- val alphavars = map varifyT (but_last alphas);
- val subst = fold2 (curry (Sign.typ_match thy)) alphavars args' Vartab.empty;
- val flds'' = (map o apsnd) (Envir.norm_type subst o varifyT) flds';
- in flds'' @ field_lst more end
- handle Type.TYPE_MATCH => [("", T)] | Library.UnequalLengths => [("", T)])
- | NONE => [("", T)])
- | NONE => [("", T)])
- | NONE => [("", T)])
- | _ => [("", T)]);
-
- val (flds, (_, moreT)) = split_last (field_lst T);
- val flds' = map (fn (n, T) => Syntax.const mark $ Syntax.const n $ term_of_type T) flds;
- val flds'' =
- foldr1 (fn (x, y) => Syntax.const sep $ x $ y) flds'
- handle Empty => raise Match;
- in
- if not (! print_record_type_as_fields) orelse null flds then raise Match
- else if moreT = HOLogic.unitT then Syntax.const record $ flds''
- else Syntax.const record_scheme $ flds'' $ term_of_type moreT
- end;
-
-
-fun gen_record_type_tr' name =
+ val ext_type_name = suffix ext_typeN name;
+ fun tr' ctxt ts =
+ record_type_tr' ctxt (list_comb (Syntax.const ext_type_name, ts));
+ in (ext_type_name, tr') end;
+
+fun record_ext_type_abbr_tr' abbr alphas zeta last_ext schemeT name =
let
- val name_sfx = suffix ext_typeN name;
+ val ext_type_name = suffix ext_typeN name;
fun tr' ctxt ts =
- record_type_tr' "_field_types" "_field_type" "_record_type" "_record_type_scheme"
- ctxt (list_comb (Syntax.const name_sfx, ts))
- in (name_sfx, tr') end;
-
-
-fun gen_record_type_abbr_tr' abbr alphas zeta lastExt schemeT name =
- let
- val name_sfx = suffix ext_typeN name;
- val default_tr' =
- record_type_tr' "_field_types" "_field_type" "_record_type" "_record_type_scheme";
- fun tr' ctxt ts =
- record_type_abbr_tr' default_tr' abbr alphas zeta lastExt schemeT ctxt
- (list_comb (Syntax.const name_sfx, ts));
- in (name_sfx, tr') end;
+ record_type_abbr_tr' abbr alphas zeta last_ext schemeT ctxt
+ (list_comb (Syntax.const ext_type_name, ts));
+ in (ext_type_name, tr') end;
+
+end;
@@ -1014,7 +1068,7 @@
else if Goal.future_enabled () then
Goal.future_result (ProofContext.init thy) (Future.fork_pri ~1 prf) prop
else prf ()
- in Drule.standard thm end;
+ in Drule.export_without_context thm end;
fun prove_common immediate stndrd thy asms prop tac =
let
@@ -1023,7 +1077,7 @@
else if immediate orelse not (Goal.future_enabled ()) then Goal.prove
else Goal.prove_future;
val prf = prv (ProofContext.init thy) [] asms prop tac;
- in if stndrd then Drule.standard prf else prf end;
+ in if stndrd then Drule.export_without_context prf else prf end;
val prove_future_global = prove_common false;
val prove_global = prove_common true;
@@ -1040,11 +1094,11 @@
val B = range_type X;
val C = range_type (fastype_of f);
val T = (B --> C) --> (A --> B) --> A --> C;
- in Const ("Fun.comp", T) $ f $ g end;
+ in Const (@{const_name Fun.comp}, T) $ f $ g end;
fun mk_comp_id f =
let val T = range_type (fastype_of f)
- in mk_comp (Const ("Fun.id", T --> T)) f end;
+ in mk_comp (Const (@{const_name Fun.id}, T --> T)) f end;
fun get_upd_funs (upd $ _ $ t) = upd :: get_upd_funs t
| get_upd_funs _ = [];
@@ -1055,6 +1109,7 @@
val upd_funs = sort_distinct TermOrd.fast_term_ord (get_upd_funs body);
fun get_simp upd =
let
+ (* FIXME fresh "f" (!?) *)
val T = domain_type (fastype_of upd);
val lhs = mk_comp acc (upd $ Free ("f", T));
val rhs =
@@ -1072,11 +1127,12 @@
if is_sel_upd_pair thy acc upd
then o_eq_dest
else o_eq_id_dest;
- in Drule.standard (othm RS dest) end;
+ in Drule.export_without_context (othm RS dest) end;
in map get_simp upd_funs end;
fun get_updupd_simp thy defset u u' comp =
let
+ (* FIXME fresh "f" (!?) *)
val f = Free ("f", domain_type (fastype_of u));
val f' = Free ("f'", domain_type (fastype_of u'));
val lhs = mk_comp (u $ f) (u' $ f');
@@ -1092,7 +1148,7 @@
REPEAT_DETERM (Iso_Tuple_Support.iso_tuple_intros_tac 1) THEN
TRY (simp_tac (HOL_ss addsimps [id_apply]) 1));
val dest = if comp then o_eq_dest_lhs else o_eq_dest;
- in Drule.standard (othm RS dest) end;
+ in Drule.export_without_context (othm RS dest) end;
fun get_updupd_simps thy term defset =
let
@@ -1171,7 +1227,7 @@
((upd as Const (u, Type (_, [_, Type (_, [rT, _])]))) $ k $ r) =>
if is_selector thy s andalso is_some (get_updates thy u) then
let
- val {sel_upd = {updates, ...}, extfields, ...} = RecordsData.get thy;
+ val {sel_upd = {updates, ...}, extfields, ...} = Records_Data.get thy;
fun mk_eq_terms ((upd as Const (u, Type(_, [kT, _]))) $ k $ r) =
(case Symtab.lookup updates u of
@@ -1279,8 +1335,8 @@
val ss = get_sel_upd_defs thy;
val uathm = get_upd_acc_cong_thm upd acc thy ss;
in
- [Drule.standard (uathm RS updacc_noopE),
- Drule.standard (uathm RS updacc_noop_compE)]
+ [Drule.export_without_context (uathm RS updacc_noopE),
+ Drule.export_without_context (uathm RS updacc_noop_compE)]
end;
(*If f is constant then (f o g) = f. We know that K_skeleton
@@ -1306,7 +1362,8 @@
K_skeleton (Long_Name.base_name s) (domain_type T) (Bound (length vars)) f;
val (isnoop, skelf') = is_upd_noop s f term;
val funT = domain_type T;
- fun mk_comp_local (f, f') = Const ("Fun.comp", funT --> funT --> funT) $ f $ f';
+ fun mk_comp_local (f, f') =
+ Const (@{const_name Fun.comp}, funT --> funT --> funT) $ f $ f';
in
if isnoop then
(upd $ skelf' $ lhs, rhs, vars,
@@ -1359,7 +1416,7 @@
val record_eq_simproc =
Simplifier.simproc @{theory HOL} "record_eq_simp" ["r = s"]
(fn thy => fn _ => fn t =>
- (case t of Const ("op =", Type (_, [T, _])) $ _ $ _ =>
+ (case t of Const (@{const_name "op ="}, Type (_, [T, _])) $ _ $ _ =>
(case rec_id ~1 T of
"" => NONE
| name =>
@@ -1381,7 +1438,10 @@
(fn thy => fn _ => fn t =>
(case t of
Const (quantifier, Type (_, [Type (_, [T, _]), _])) $ _ =>
- if quantifier = "All" orelse quantifier = "all" orelse quantifier = "Ex" then
+ if quantifier = @{const_name all} orelse
+ quantifier = @{const_name All} orelse
+ quantifier = @{const_name Ex}
+ then
(case rec_id ~1 T of
"" => NONE
| _ =>
@@ -1392,9 +1452,9 @@
| SOME (all_thm, All_thm, Ex_thm, _) =>
SOME
(case quantifier of
- "all" => all_thm
- | "All" => All_thm RS eq_reflection
- | "Ex" => Ex_thm RS eq_reflection
+ @{const_name all} => all_thm
+ | @{const_name All} => All_thm RS eq_reflection
+ | @{const_name Ex} => Ex_thm RS eq_reflection
| _ => error "record_split_simproc"))
else NONE
end)
@@ -1419,22 +1479,23 @@
else raise TERM ("", [x]);
val sel' = Const (sel, Tsel) $ Bound 0;
val (l, r) = if lr then (sel', x') else (x', sel');
- in Const ("op =", Teq) $ l $ r end
+ in Const (@{const_name "op ="}, Teq) $ l $ r end
else raise TERM ("", [Const (sel, Tsel)]);
- fun dest_sel_eq (Const ("op =", Teq) $ (Const (sel, Tsel) $ Bound 0) $ X) =
+ fun dest_sel_eq (Const (@{const_name "op ="}, Teq) $ (Const (sel, Tsel) $ Bound 0) $ X) =
(true, Teq, (sel, Tsel), X)
- | dest_sel_eq (Const ("op =", Teq) $ X $ (Const (sel, Tsel) $ Bound 0)) =
+ | dest_sel_eq (Const (@{const_name "op ="}, Teq) $ X $ (Const (sel, Tsel) $ Bound 0)) =
(false, Teq, (sel, Tsel), X)
| dest_sel_eq _ = raise TERM ("", []);
in
(case t of
- Const ("Ex", Tex) $ Abs (s, T, t) =>
+ Const (@{const_name Ex}, Tex) $ Abs (s, T, t) =>
(let
- val eq = mkeq (dest_sel_eq t) 0;
- val prop =
- list_all ([("r", T)],
- Logic.mk_equals (Const ("Ex", Tex) $ Abs (s, T, eq), HOLogic.true_const));
+ val eq = mkeq (dest_sel_eq t) 0;
+ val prop =
+ list_all ([("r", T)],
+ Logic.mk_equals
+ (Const (@{const_name Ex}, Tex) $ Abs (s, T, eq), HOLogic.true_const));
in SOME (prove prop) end
handle TERM _ => NONE)
| _ => NONE)
@@ -1459,7 +1520,8 @@
val has_rec = exists_Const
(fn (s, Type (_, [Type (_, [T, _]), _])) =>
- (s = "all" orelse s = "All" orelse s = "Ex") andalso is_recT T
+ (s = @{const_name all} orelse s = @{const_name All} orelse s = @{const_name Ex}) andalso
+ is_recT T
| _ => false);
fun mk_split_free_tac free induct_thm i =
@@ -1501,20 +1563,20 @@
(* record_split_tac *)
-(*Split all records in the goal, which are quantified by ! or !!.*)
+(*Split all records in the goal, which are quantified by !! or ALL.*)
val record_split_tac = CSUBGOAL (fn (cgoal, i) =>
let
val goal = term_of cgoal;
val has_rec = exists_Const
(fn (s, Type (_, [Type (_, [T, _]), _])) =>
- (s = "all" orelse s = "All") andalso is_recT T
+ (s = @{const_name all} orelse s = @{const_name All}) andalso is_recT T
| _ => false);
fun is_all t =
(case t of
Const (quantifier, _) $ _ =>
- if quantifier = "All" orelse quantifier = "all" then ~1 else 0
+ if quantifier = @{const_name all} orelse quantifier = @{const_name All} then ~1 else 0
| _ => 0);
in
if has_rec goal then
@@ -1721,8 +1783,8 @@
to prove other theorems. We haven't given names to the accessors
f, g etc yet however, so we generate an ext structure with
free variables as all arguments and allow the introduction tactic to
- operate on it as far as it can. We then use Drule.standard to convert
- the free variables into unifiable variables and unify them with
+ operate on it as far as it can. We then use Drule.export_without_context
+ to convert the free variables into unifiable variables and unify them with
(roughly) the definition of the accessor.*)
fun surject_prf () =
let
@@ -1733,7 +1795,7 @@
REPEAT_ALL_NEW Iso_Tuple_Support.iso_tuple_intros_tac 1;
val tactic2 = REPEAT (rtac surject_assistI 1 THEN rtac refl 1);
val [halfway] = Seq.list_of (tactic1 start);
- val [surject] = Seq.list_of (tactic2 (Drule.standard halfway));
+ val [surject] = Seq.list_of (tactic2 (Drule.export_without_context halfway));
in
surject
end;
@@ -1759,16 +1821,16 @@
end;
val induct = timeit_msg "record extension induct proof:" induct_prf;
- val ([inject', induct', surjective', split_meta'], thm_thy) =
+ val ([induct', inject', surjective', split_meta'], thm_thy) =
defs_thy
|> PureThy.add_thms (map (Thm.no_attributes o apfst Binding.name)
- [("ext_inject", inject),
- ("ext_induct", induct),
+ [("ext_induct", induct),
+ ("ext_inject", inject),
("ext_surjective", surject),
("ext_split", split_meta)])
||> Code.add_default_eqn ext_def;
- in (thm_thy, extT, induct', inject', split_meta', ext_def) end;
+ in ((extT, induct', inject', surjective', split_meta', ext_def), thm_thy) end;
fun chunks [] [] = []
| chunks [] xs = [xs]
@@ -1814,17 +1876,19 @@
(* record_definition *)
-fun record_definition (args, bname) parent (parents: parent_info list) raw_fields thy =
+fun record_definition (args, b) parent (parents: parent_info list) raw_fields thy =
let
val external_names = Name_Space.external_names (Sign.naming_of thy);
val alphas = map fst args;
- val name = Sign.full_bname thy bname;
- val full = Sign.full_bname_path thy bname;
+
+ val base_name = Binding.name_of b; (* FIXME include qualifier etc. (!?) *)
+ val name = Sign.full_name thy b;
+ val full = Sign.full_name_path thy base_name;
val base = Long_Name.base_name;
- val (bfields, field_syntax) =
- split_list (map (fn (x, T, mx) => ((x, T), mx)) raw_fields);
+ val bfields = map (fn (x, T, _) => (x, T)) raw_fields;
+ val field_syntax = map #3 raw_fields;
val parent_fields = maps #fields parents;
val parent_chunks = map (length o #fields) parents;
@@ -1837,14 +1901,14 @@
val fields = map (apfst full) bfields;
val names = map fst fields;
- val extN = full bname;
+ val extN = full b;
val types = map snd fields;
val alphas_fields = fold Term.add_tfree_namesT types [];
val alphas_ext = inter (op =) alphas_fields alphas;
val len = length fields;
val variants =
Name.variant_list (moreN :: rN :: (rN ^ "'") :: wN :: parent_variants)
- (map fst bfields);
+ (map (Binding.name_of o fst) bfields);
val vars = ListPair.map Free (variants, types);
val named_vars = names ~~ vars;
val idxms = 0 upto len;
@@ -1859,8 +1923,8 @@
val zeta = Name.variant alphas "'z";
val moreT = TFree (zeta, HOLogic.typeS);
val more = Free (moreN, moreT);
- val full_moreN = full moreN;
- val bfields_more = bfields @ [(moreN, moreT)];
+ val full_moreN = full (Binding.name moreN);
+ val bfields_more = bfields @ [(Binding.name moreN, moreT)];
val fields_more = fields @ [(full_moreN, moreT)];
val named_vars_more = named_vars @ [(full_moreN, more)];
val all_vars_more = all_vars @ [more];
@@ -1869,9 +1933,9 @@
(* 1st stage: extension_thy *)
- val (extension_thy, extT, ext_induct, ext_inject, ext_split, ext_def) =
+ val ((extT, ext_induct, ext_inject, ext_surjective, ext_split, ext_def), extension_thy) =
thy
- |> Sign.add_path bname
+ |> Sign.add_path base_name
|> extension_definition extN fields alphas_ext zeta moreT more vars;
val _ = timing_msg "record preparing definitions";
@@ -1915,47 +1979,46 @@
(* prepare print translation functions *)
-
- val field_tr's =
- print_translation (distinct (op =) (maps external_names (full_moreN :: names)));
-
- val adv_ext_tr's =
- let val trnames = external_names extN
- in map (gen_record_tr') trnames end;
-
- val adv_record_type_abbr_tr's =
+ (* FIXME authentic syntax *)
+
+ val field_update_tr's =
+ map field_update_tr' (distinct (op =) (maps external_names (full_moreN :: names)));
+
+ val record_ext_tr's = map record_ext_tr' (external_names extN);
+
+ val record_ext_type_abbr_tr's =
let
val trnames = external_names (hd extension_names);
- val lastExt = unsuffix ext_typeN (fst extension);
- in map (gen_record_type_abbr_tr' name alphas zeta lastExt rec_schemeT0) trnames end;
-
- val adv_record_type_tr's =
+ val last_ext = unsuffix ext_typeN (fst extension);
+ in map (record_ext_type_abbr_tr' name alphas zeta last_ext rec_schemeT0) trnames end;
+
+ val record_ext_type_tr's =
let
+ (*avoid conflict with record_type_abbr_tr's*)
val trnames = if parent_len > 0 then external_names extN else [];
- (*avoid conflict with adv_record_type_abbr_tr's*)
- in map (gen_record_type_tr') trnames end;
+ in map record_ext_type_tr' trnames end;
(* prepare declarations *)
- val sel_decls = map (mk_selC rec_schemeT0) bfields_more;
- val upd_decls = map (mk_updC updateN rec_schemeT0) bfields_more;
+ val sel_decls = map (mk_selC rec_schemeT0 o apfst Binding.name_of) bfields_more;
+ val upd_decls = map (mk_updC updateN rec_schemeT0 o apfst Binding.name_of) bfields_more;
val make_decl = (makeN, all_types ---> recT0);
val fields_decl = (fields_selN, types ---> Type extension);
val extend_decl = (extendN, recT0 --> moreT --> rec_schemeT0);
val truncate_decl = (truncateN, rec_schemeT0 --> recT0);
+
(* prepare definitions *)
(*record (scheme) type abbreviation*)
val recordT_specs =
- [(Binding.name (suffix schemeN bname), alphas @ [zeta], rec_schemeT0, Syntax.NoSyn),
- (Binding.name bname, alphas, recT0, Syntax.NoSyn)];
-
- val ext_defs = ext_def :: map #extdef parents;
+ [(Binding.suffix_name schemeN b, alphas @ [zeta], rec_schemeT0, NoSyn),
+ (b, alphas, recT0, NoSyn)];
+
+ val ext_defs = ext_def :: map #ext_def parents;
(*Theorems from the iso_tuple intros.
- This is complex enough to deserve a full comment.
By unfolding ext_defs from r_rec0 we create a tree of constructor
calls (many of them Pair, but others as well). The introduction
rules for update_accessor_eq_assist can unify two different ways
@@ -2007,45 +2070,49 @@
(*updates*)
fun mk_upd_spec ((c, T), thm) =
let
- val (upd $ _ $ arg) =
- (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Envir.beta_eta_contract o concl_of) thm;
+ val upd $ _ $ arg =
+ fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (Envir.beta_eta_contract (concl_of thm))));
val _ =
- if (arg aconv r_rec0) then ()
+ if arg aconv r_rec0 then ()
else raise TERM ("mk_sel_spec: different arg", [arg]);
in Const (mk_updC updateN rec_schemeT0 (c, T)) :== upd end;
val upd_specs = map mk_upd_spec (fields_more ~~ lastN updator_thms);
(*derived operations*)
- val make_spec = Const (full makeN, all_types ---> recT0) $$ all_vars :==
- mk_rec (all_vars @ [HOLogic.unit]) 0;
- val fields_spec = Const (full fields_selN, types ---> Type extension) $$ vars :==
- mk_rec (all_vars @ [HOLogic.unit]) parent_len;
+ val make_spec =
+ list_comb (Const (full (Binding.name makeN), all_types ---> recT0), all_vars) :==
+ mk_rec (all_vars @ [HOLogic.unit]) 0;
+ val fields_spec =
+ list_comb (Const (full (Binding.name fields_selN), types ---> Type extension), vars) :==
+ mk_rec (all_vars @ [HOLogic.unit]) parent_len;
val extend_spec =
- Const (full extendN, recT0-->moreT-->rec_schemeT0) $ r_unit0 $ more :==
- mk_rec ((map (mk_sel r_unit0) all_fields) @ [more]) 0;
- val truncate_spec = Const (full truncateN, rec_schemeT0 --> recT0) $ r0 :==
- mk_rec ((map (mk_sel r0) all_fields) @ [HOLogic.unit]) 0;
+ Const (full (Binding.name extendN), recT0 --> moreT --> rec_schemeT0) $ r_unit0 $ more :==
+ mk_rec ((map (mk_sel r_unit0) all_fields) @ [more]) 0;
+ val truncate_spec =
+ Const (full (Binding.name truncateN), rec_schemeT0 --> recT0) $ r0 :==
+ mk_rec ((map (mk_sel r0) all_fields) @ [HOLogic.unit]) 0;
(* 2st stage: defs_thy *)
fun mk_defs () =
extension_thy
- |> Sign.add_trfuns ([], [], field_tr's, [])
+ |> Sign.add_trfuns ([], [], field_update_tr's, [])
|> Sign.add_advanced_trfuns
- ([], [], adv_ext_tr's @ adv_record_type_tr's @ adv_record_type_abbr_tr's, [])
+ ([], [], record_ext_tr's @ record_ext_type_tr's @ record_ext_type_abbr_tr's, [])
|> Sign.parent_path
|> Sign.add_tyabbrs_i recordT_specs
- |> Sign.add_path bname
+ |> Sign.add_path base_name
|> Sign.add_consts_i
- (map2 (fn (x, T) => fn mx => (Binding.name x, T, mx))
- sel_decls (field_syntax @ [Syntax.NoSyn]))
- |> (Sign.add_consts_i o map (fn (x, T) => (Binding.name x, T, Syntax.NoSyn)))
+ (map2 (fn (x, T) => fn mx => (Binding.name x, T, mx)) sel_decls (field_syntax @ [NoSyn]))
+ |> (Sign.add_consts_i o map (fn (x, T) => (Binding.name x, T, NoSyn)))
(upd_decls @ [make_decl, fields_decl, extend_decl, truncate_decl])
- |> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name)) sel_specs)
- ||>> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name)) upd_specs)
- ||>> ((PureThy.add_defs false o map (Thm.no_attributes o apfst Binding.name))
- [make_spec, fields_spec, extend_spec, truncate_spec])
+ |> (PureThy.add_defs false o map (Thm.no_attributes o apfst (Binding.conceal o Binding.name)))
+ sel_specs
+ ||>> (PureThy.add_defs false o map (Thm.no_attributes o apfst (Binding.conceal o Binding.name)))
+ upd_specs
+ ||>> (PureThy.add_defs false o map (Thm.no_attributes o apfst (Binding.conceal o Binding.name)))
+ [make_spec, fields_spec, extend_spec, truncate_spec]
|->
(fn defs as ((sel_defs, upd_defs), derived_defs) =>
fold Code.add_default_eqn sel_defs
@@ -2136,14 +2203,14 @@
fun sel_convs_prf () =
map (prove_simp false ss (sel_defs @ accessor_thms)) sel_conv_props;
val sel_convs = timeit_msg "record sel_convs proof:" sel_convs_prf;
- fun sel_convs_standard_prf () = map Drule.standard sel_convs
+ fun sel_convs_standard_prf () = map Drule.export_without_context sel_convs;
val sel_convs_standard =
timeit_msg "record sel_convs_standard proof:" sel_convs_standard_prf;
fun upd_convs_prf () =
map (prove_simp false ss (upd_defs @ updator_thms)) upd_conv_props;
val upd_convs = timeit_msg "record upd_convs proof:" upd_convs_prf;
- fun upd_convs_standard_prf () = map Drule.standard upd_convs
+ fun upd_convs_standard_prf () = map Drule.export_without_context upd_convs;
val upd_convs_standard =
timeit_msg "record upd_convs_standard proof:" upd_convs_standard_prf;
@@ -2151,18 +2218,18 @@
let
val symdefs = map symmetric (sel_defs @ upd_defs);
val fold_ss = HOL_basic_ss addsimps symdefs;
- val ua_congs = map (Drule.standard o simplify fold_ss) upd_acc_cong_assists;
+ val ua_congs = map (Drule.export_without_context o simplify fold_ss) upd_acc_cong_assists;
in (ua_congs RL [updacc_foldE], ua_congs RL [updacc_unfoldE]) end;
val (fold_congs, unfold_congs) =
timeit_msg "record upd fold/unfold congs:" get_upd_acc_congs;
- val parent_induct = if null parents then [] else [#induct (hd (rev parents))];
+ val parent_induct = Option.map #induct_scheme (try List.last parents);
fun induct_scheme_prf () =
prove_standard [] induct_scheme_prop
(fn _ =>
EVERY
- [if null parent_induct then all_tac else try_param_tac rN (hd parent_induct) 1,
+ [case parent_induct of NONE => all_tac | SOME ind => try_param_tac rN ind 1,
try_param_tac rN ext_induct 1,
asm_simp_tac HOL_basic_ss 1]);
val induct_scheme = timeit_msg "record induct_scheme proof:" induct_scheme_prf;
@@ -2221,7 +2288,7 @@
rtac (prop_subst OF [surjective]),
REPEAT o etac meta_allE, atac]);
val split_meta = timeit_msg "record split_meta proof:" split_meta_prf;
- fun split_meta_standardise () = Drule.standard split_meta;
+ fun split_meta_standardise () = Drule.export_without_context split_meta;
val split_meta_standard =
timeit_msg "record split_meta standard:" split_meta_standardise;
@@ -2285,7 +2352,7 @@
val ((([sel_convs', upd_convs', sel_defs', upd_defs',
fold_congs', unfold_congs',
- [split_meta', split_object', split_ex'], derived_defs'],
+ splits' as [split_meta', split_object', split_ex'], derived_defs'],
[surjective', equality']),
[induct_scheme', induct', cases_scheme', cases']), thms_thy) =
defs_thy
@@ -2311,12 +2378,22 @@
val sel_upd_defs = sel_defs' @ upd_defs';
val iffs = [ext_inject]
val depth = parent_len + 1;
- val final_thy =
+
+ val ([simps', iffs'], thms_thy') =
thms_thy
- |> (snd oo PureThy.add_thmss)
+ |> PureThy.add_thmss
[((Binding.name "simps", sel_upd_simps), [Simplifier.simp_add]),
- ((Binding.name "iffs", iffs), [iff_add])]
- |> put_record name (make_record_info args parent fields extension induct_scheme' ext_def)
+ ((Binding.name "iffs", iffs), [iff_add])];
+
+ val info =
+ make_record_info args parent fields extension
+ ext_induct ext_inject ext_surjective ext_split ext_def
+ sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs'
+ surjective' equality' induct_scheme' induct' cases_scheme' cases' simps' iffs';
+
+ val final_thy =
+ thms_thy'
+ |> put_record name info
|> put_sel_upd names full_moreN depth sel_upd_simps sel_upd_defs (fold_congs', unfold_congs')
|> add_record_equalities extension_id equality'
|> add_extinjects ext_inject
@@ -2333,10 +2410,13 @@
(*We do all preparations and error checks here, deferring the real
work to record_definition.*)
-fun gen_add_record prep_typ prep_raw_parent quiet_mode (params, bname) raw_parent raw_fields thy =
+fun gen_add_record prep_typ prep_raw_parent quiet_mode
+ (params, b) raw_parent raw_fields thy =
let
val _ = Theory.requires thy "Record" "record definitions";
- val _ = if quiet_mode then () else writeln ("Defining record " ^ quote bname ^ " ...");
+ val _ =
+ if quiet_mode then ()
+ else writeln ("Defining record " ^ quote (Binding.name_of b) ^ " ...");
val ctxt = ProofContext.init thy;
@@ -2357,10 +2437,12 @@
(* fields *)
- fun prep_field (c, raw_T, mx) env =
- let val (T, env') = prep_typ ctxt raw_T env handle ERROR msg =>
- cat_error msg ("The error(s) above occured in record field " ^ quote c)
- in ((c, T, mx), env') end;
+ fun prep_field (x, raw_T, mx) env =
+ let
+ val (T, env') =
+ prep_typ ctxt raw_T env handle ERROR msg =>
+ cat_error msg ("The error(s) above occured in record field " ^ quote (Binding.str_of x));
+ in ((x, T, mx), env') end;
val (bfields, envir) = fold_map prep_field raw_fields init_env;
val envir_names = map fst envir;
@@ -2374,7 +2456,7 @@
(* errors *)
- val name = Sign.full_bname thy bname;
+ val name = Sign.full_name thy b;
val err_dup_record =
if is_none (get_record thy name) then []
else ["Duplicate definition of record " ^ quote name];
@@ -2392,12 +2474,12 @@
val err_no_fields = if null bfields then ["No fields present"] else [];
val err_dup_fields =
- (case duplicates (op =) (map #1 bfields) of
+ (case duplicates Binding.eq_name (map #1 bfields) of
[] => []
- | dups => ["Duplicate field(s) " ^ commas_quote dups]);
+ | dups => ["Duplicate field(s) " ^ commas_quote (map Binding.str_of dups)]);
val err_bad_fields =
- if forall (not_equal moreN o #1) bfields then []
+ if forall (not_equal moreN o Binding.name_of o #1) bfields then []
else ["Illegal field name " ^ quote moreN];
val err_dup_sorts =
@@ -2411,19 +2493,19 @@
val _ = if null errs then () else error (cat_lines errs);
in
- thy |> record_definition (args, bname) parent parents bfields
+ thy |> record_definition (args, b) parent parents bfields
end
- handle ERROR msg => cat_error msg ("Failed to define record " ^ quote bname);
-
-val add_record = gen_add_record read_typ read_raw_parent;
-val add_record_i = gen_add_record cert_typ (K I);
+ handle ERROR msg => cat_error msg ("Failed to define record " ^ quote (Binding.str_of b));
+
+val add_record = gen_add_record cert_typ (K I);
+val add_record_cmd = gen_add_record read_typ read_raw_parent;
(* setup theory *)
val setup =
Sign.add_trfuns ([], parse_translation, [], []) #>
- Sign.add_advanced_trfuns ([], adv_parse_translation, [], []) #>
+ Sign.add_advanced_trfuns ([], advanced_parse_translation, [], []) #>
Simplifier.map_simpset (fn ss =>
ss addsimprocs [record_simproc, record_upd_simproc, record_eq_simproc]);
@@ -2432,13 +2514,11 @@
local structure P = OuterParse and K = OuterKeyword in
-val record_decl =
- P.type_args -- P.name --
- (P.$$$ "=" |-- Scan.option (P.typ --| P.$$$ "+") -- Scan.repeat1 P.const);
-
val _ =
OuterSyntax.command "record" "define extensible record" K.thy_decl
- (record_decl >> (fn (x, (y, z)) => Toplevel.theory (add_record false x y z)));
+ (P.type_args -- P.binding --
+ (P.$$$ "=" |-- Scan.option (P.typ --| P.$$$ "+") -- Scan.repeat1 P.const_binding)
+ >> (fn (x, (y, z)) => Toplevel.theory (add_record_cmd false x y z)));
end;
--- a/src/HOL/Tools/refute.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/refute.ML Fri Feb 19 15:21:57 2010 +0000
@@ -708,7 +708,7 @@
(* other optimizations *)
| Const (@{const_name Finite_Set.card}, _) => t
| Const (@{const_name Finite_Set.finite}, _) => t
- | Const (@{const_name Algebras.less}, Type ("fun", [Type ("nat", []),
+ | Const (@{const_name Orderings.less}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) => t
| Const (@{const_name Algebras.plus}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("nat", [])])])) => t
@@ -883,7 +883,7 @@
| Const (@{const_name Finite_Set.card}, T) => collect_type_axioms T axs
| Const (@{const_name Finite_Set.finite}, T) =>
collect_type_axioms T axs
- | Const (@{const_name Algebras.less}, T as Type ("fun", [Type ("nat", []),
+ | Const (@{const_name Orderings.less}, T as Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) =>
collect_type_axioms T axs
| Const (@{const_name Algebras.plus}, T as Type ("fun", [Type ("nat", []),
@@ -2771,7 +2771,7 @@
fun Nat_less_interpreter thy model args t =
case t of
- Const (@{const_name Algebras.less}, Type ("fun", [Type ("nat", []),
+ Const (@{const_name Orderings.less}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) =>
let
val size_of_nat = size_of_type thy model (Type ("nat", []))
--- a/src/HOL/Tools/res_clause.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/res_clause.ML Fri Feb 19 15:21:57 2010 +0000
@@ -99,7 +99,7 @@
(*Provide readable names for the more common symbolic functions*)
val const_trans_table =
Symtab.make [(@{const_name "op ="}, "equal"),
- (@{const_name Algebras.less_eq}, "lessequals"),
+ (@{const_name Orderings.less_eq}, "lessequals"),
(@{const_name "op &"}, "and"),
(@{const_name "op |"}, "or"),
(@{const_name "op -->"}, "implies"),
--- a/src/HOL/Tools/sat_solver.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/sat_solver.ML Fri Feb 19 15:21:57 2010 +0000
@@ -282,7 +282,7 @@
(* string -> (PropLogic.prop_formula -> unit) -> (unit -> result) -> solver *)
fun make_external_solver cmd writefn readfn fm =
- (writefn fm; system cmd; readfn ());
+ (writefn fm; bash cmd; readfn ());
(* ------------------------------------------------------------------------- *)
(* read_dimacs_cnf_file: returns a propositional formula that corresponds to *)
@@ -586,7 +586,7 @@
val inpath = File.tmp_path (Path.explode ("isabelle" ^ serial_str ^ ".cnf"))
val outpath = File.tmp_path (Path.explode ("result" ^ serial_str))
val proofpath = File.tmp_path (Path.explode ("result" ^ serial_str ^ ".prf"))
- val cmd = (getenv "MINISAT_HOME") ^ "/minisat " ^ (Path.implode inpath) ^ " -r " ^ (Path.implode outpath) ^ " -t " ^ (Path.implode proofpath) ^ "> /dev/null"
+ val cmd = getenv "MINISAT_HOME" ^ "/minisat " ^ File.shell_path inpath ^ " -r " ^ File.shell_path outpath ^ " -t " ^ File.shell_path proofpath ^ "> /dev/null"
fun writefn fm = SatSolver.write_dimacs_cnf_file inpath fm
fun readfn () = SatSolver.read_std_result_file outpath ("SAT", "", "UNSAT")
val _ = if File.exists inpath then warning ("overwriting existing file " ^ quote (Path.implode inpath)) else ()
@@ -767,11 +767,11 @@
let
fun minisat fm =
let
- val _ = if (getenv "MINISAT_HOME") = "" then raise SatSolver.NOT_CONFIGURED else ()
+ val _ = if getenv "MINISAT_HOME" = "" then raise SatSolver.NOT_CONFIGURED else ()
val serial_str = serial_string ()
val inpath = File.tmp_path (Path.explode ("isabelle" ^ serial_str ^ ".cnf"))
val outpath = File.tmp_path (Path.explode ("result" ^ serial_str))
- val cmd = (getenv "MINISAT_HOME") ^ "/minisat " ^ (Path.implode inpath) ^ " -r " ^ (Path.implode outpath) ^ " > /dev/null"
+ val cmd = getenv "MINISAT_HOME" ^ "/minisat " ^ File.shell_path inpath ^ " -r " ^ File.shell_path outpath ^ " > /dev/null"
fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm)
fun readfn () = SatSolver.read_std_result_file outpath ("SAT", "", "UNSAT")
val _ = if File.exists inpath then warning ("overwriting existing file " ^ quote (Path.implode inpath)) else ()
@@ -926,11 +926,11 @@
let
fun zchaff fm =
let
- val _ = if (getenv "ZCHAFF_HOME") = "" then raise SatSolver.NOT_CONFIGURED else ()
+ val _ = if getenv "ZCHAFF_HOME" = "" then raise SatSolver.NOT_CONFIGURED else ()
val serial_str = serial_string ()
val inpath = File.tmp_path (Path.explode ("isabelle" ^ serial_str ^ ".cnf"))
val outpath = File.tmp_path (Path.explode ("result" ^ serial_str))
- val cmd = (getenv "ZCHAFF_HOME") ^ "/zchaff " ^ (Path.implode inpath) ^ " > " ^ (Path.implode outpath)
+ val cmd = getenv "ZCHAFF_HOME" ^ "/zchaff " ^ File.shell_path inpath ^ " > " ^ File.shell_path outpath
fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm)
fun readfn () = SatSolver.read_std_result_file outpath ("Instance Satisfiable", "", "Instance Unsatisfiable")
val _ = if File.exists inpath then warning ("overwriting existing file " ^ quote (Path.implode inpath)) else ()
@@ -957,7 +957,7 @@
val inpath = File.tmp_path (Path.explode ("isabelle" ^ serial_str ^ ".cnf"))
val outpath = File.tmp_path (Path.explode ("result" ^ serial_str))
val exec = getenv "BERKMIN_EXE"
- val cmd = (getenv "BERKMIN_HOME") ^ "/" ^ (if exec = "" then "BerkMin561" else exec) ^ " " ^ (Path.implode inpath) ^ " > " ^ (Path.implode outpath)
+ val cmd = getenv "BERKMIN_HOME" ^ "/" ^ (if exec = "" then "BerkMin561" else exec) ^ " " ^ File.shell_path inpath ^ " > " ^ File.shell_path outpath
fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm)
fun readfn () = SatSolver.read_std_result_file outpath ("Satisfiable !!", "solution =", "UNSATISFIABLE !!")
val _ = if File.exists inpath then warning ("overwriting existing file " ^ quote (Path.implode inpath)) else ()
@@ -983,7 +983,7 @@
val serial_str = serial_string ()
val inpath = File.tmp_path (Path.explode ("isabelle" ^ serial_str ^ ".cnf"))
val outpath = File.tmp_path (Path.explode ("result" ^ serial_str))
- val cmd = (getenv "JERUSAT_HOME") ^ "/Jerusat1.3 " ^ (Path.implode inpath) ^ " > " ^ (Path.implode outpath)
+ val cmd = getenv "JERUSAT_HOME" ^ "/Jerusat1.3 " ^ File.shell_path inpath ^ " > " ^ File.shell_path outpath
fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm)
fun readfn () = SatSolver.read_std_result_file outpath ("s SATISFIABLE", "v ", "s UNSATISFIABLE")
val _ = if File.exists inpath then warning ("overwriting existing file " ^ quote (Path.implode inpath)) else ()
--- a/src/HOL/Tools/split_rule.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/split_rule.ML Fri Feb 19 15:21:57 2010 +0000
@@ -100,13 +100,13 @@
| (t, ts) => fold collect_vars ts);
-val split_rule_var = (Drule.standard o remove_internal_split) oo split_rule_var';
+val split_rule_var = (Drule.export_without_context o remove_internal_split) oo split_rule_var';
(*curries ALL function variables occurring in a rule's conclusion*)
fun split_rule rl =
fold_rev split_rule_var' (OldTerm.term_vars (concl_of rl)) rl
|> remove_internal_split
- |> Drule.standard;
+ |> Drule.export_without_context;
(*curries ALL function variables*)
fun complete_split_rule rl =
@@ -117,7 +117,7 @@
in
fst (fold_rev complete_split_rule_var vars (rl, xs))
|> remove_internal_split
- |> Drule.standard
+ |> Drule.export_without_context
|> Rule_Cases.save rl
end;
@@ -137,7 +137,7 @@
rl
|> fold_index one_goal xss
|> Simplifier.full_simplify split_rule_ss
- |> Drule.standard
+ |> Drule.export_without_context
|> Rule_Cases.save rl
end;
--- a/src/HOL/Tools/string_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/string_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -9,7 +9,7 @@
val setup: theory -> theory
end;
-structure StringSyntax: STRING_SYNTAX =
+structure String_Syntax: STRING_SYNTAX =
struct
@@ -19,7 +19,7 @@
val mk_nib =
Syntax.Constant o unprefix nib_prefix o
- fst o Term.dest_Const o HOLogic.mk_nibble;
+ fst o Term.dest_Const o HOLogic.mk_nibble;
fun dest_nib (Syntax.Constant c) =
HOLogic.dest_nibble (Const (nib_prefix ^ c, dummyT))
@@ -30,7 +30,7 @@
fun mk_char s =
if Symbol.is_ascii s then
- Syntax.Appl [Syntax.Constant "Char", mk_nib (ord s div 16), mk_nib (ord s mod 16)]
+ Syntax.Appl [Syntax.Constant @{const_syntax Char}, mk_nib (ord s div 16), mk_nib (ord s mod 16)]
else error ("Non-ASCII symbol: " ^ quote s);
val specials = explode "\\\"`'";
@@ -41,11 +41,13 @@
then c else raise Match
end;
-fun dest_char (Syntax.Appl [Syntax.Constant "Char", c1, c2]) = dest_chr c1 c2
+fun dest_char (Syntax.Appl [Syntax.Constant @{const_syntax Char}, c1, c2]) = dest_chr c1 c2
| dest_char _ = raise Match;
fun syntax_string cs =
- Syntax.Appl [Syntax.Constant "_inner_string", Syntax.Variable (Syntax.implode_xstr cs)];
+ Syntax.Appl
+ [Syntax.Constant @{syntax_const "_inner_string"},
+ Syntax.Variable (Syntax.implode_xstr cs)];
fun char_ast_tr [Syntax.Variable xstr] =
@@ -54,24 +56,29 @@
| _ => error ("Single character expected: " ^ xstr))
| char_ast_tr asts = raise AST ("char_ast_tr", asts);
-fun char_ast_tr' [c1, c2] = Syntax.Appl [Syntax.Constant "_Char", syntax_string [dest_chr c1 c2]]
+fun char_ast_tr' [c1, c2] =
+ Syntax.Appl [Syntax.Constant @{syntax_const "_Char"}, syntax_string [dest_chr c1 c2]]
| char_ast_tr' _ = raise Match;
(* string *)
-fun mk_string [] = Syntax.Constant "Nil"
- | mk_string (c :: cs) = Syntax.Appl [Syntax.Constant "Cons", mk_char c, mk_string cs];
+fun mk_string [] = Syntax.Constant @{const_syntax Nil}
+ | mk_string (c :: cs) =
+ Syntax.Appl [Syntax.Constant @{const_syntax Cons}, mk_char c, mk_string cs];
fun string_ast_tr [Syntax.Variable xstr] =
(case Syntax.explode_xstr xstr of
- [] => Syntax.Appl
- [Syntax.Constant Syntax.constrainC, Syntax.Constant "Nil", Syntax.Constant "string"]
+ [] =>
+ Syntax.Appl
+ [Syntax.Constant Syntax.constrainC,
+ Syntax.Constant @{const_syntax Nil}, Syntax.Constant "string"] (* FIXME @{type_syntax} *)
| cs => mk_string cs)
| string_ast_tr asts = raise AST ("string_tr", asts);
-fun list_ast_tr' [args] = Syntax.Appl [Syntax.Constant "_String",
- syntax_string (map dest_char (Syntax.unfold_ast "_args" args))]
+fun list_ast_tr' [args] =
+ Syntax.Appl [Syntax.Constant @{syntax_const "_String"},
+ syntax_string (map dest_char (Syntax.unfold_ast @{syntax_const "_args"} args))]
| list_ast_tr' ts = raise Match;
@@ -79,7 +86,7 @@
val setup =
Sign.add_trfuns
- ([("_Char", char_ast_tr), ("_String", string_ast_tr)], [], [],
- [("Char", char_ast_tr'), ("@list", list_ast_tr')]);
+ ([(@{syntax_const "_Char"}, char_ast_tr), (@{syntax_const "_String"}, string_ast_tr)], [], [],
+ [(@{const_syntax Char}, char_ast_tr'), (@{syntax_const "_list"}, list_ast_tr')]);
end;
--- a/src/HOL/Tools/typedef.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Tools/typedef.ML Fri Feb 19 15:21:57 2010 +0000
@@ -14,11 +14,12 @@
Rep_induct: thm, Abs_induct: thm}
val add_typedef: bool -> binding option -> binding * string list * mixfix ->
term -> (binding * binding) option -> tactic -> theory -> (string * info) * theory
- val typedef: (bool * binding) * (binding * string list * mixfix) * term
- * (binding * binding) option -> theory -> Proof.state
- val typedef_cmd: (bool * binding) * (binding * string list * mixfix) * string
- * (binding * binding) option -> theory -> Proof.state
+ val typedef: (bool * binding) * (binding * string list * mixfix) * term *
+ (binding * binding) option -> theory -> Proof.state
+ val typedef_cmd: (bool * binding) * (binding * string list * mixfix) * string *
+ (binding * binding) option -> theory -> Proof.state
val get_info: theory -> string -> info option
+ val the_info: theory -> string -> info
val interpretation: (string -> theory -> theory) -> theory -> theory
val setup: theory -> theory
end;
@@ -45,6 +46,12 @@
);
val get_info = Symtab.lookup o TypedefData.get;
+
+fun the_info thy name =
+ (case get_info thy name of
+ SOME info => info
+ | NONE => error ("Unknown typedef " ^ quote name));
+
fun put_info name info = TypedefData.map (Symtab.update (name, info));
@@ -55,7 +62,7 @@
structure Typedef_Interpretation = Interpretation(type T = string val eq = op =);
val interpretation = Typedef_Interpretation.interpretation;
-fun prepare_typedef prep_term def name (t, vs, mx) raw_set opt_morphs thy =
+fun prepare_typedef prep_term def name (tname, vs, mx) raw_set opt_morphs thy =
let
val _ = Theory.requires thy "Typedef" "typedefs";
val ctxt = ProofContext.init thy;
@@ -79,7 +86,6 @@
|> filter (member (op =) rhs_tfrees andf (not o member (op =) rhs_tfreesT))
|> map TFree;
- val tname = Binding.map_name (Syntax.type_name mx) t;
val full_tname = full tname;
val newT = Type (full_tname, map TFree lhs_tfrees);
@@ -112,9 +118,9 @@
fun add_def theory =
if def then
theory
- |> Sign.add_consts_i [(name, setT', NoSyn)]
- |> PureThy.add_defs false [Thm.no_attributes (apfst (Binding.name)
- (Primitive_Defs.mk_defpair (setC, set)))]
+ |> Sign.add_consts_i [(name, setT', NoSyn)] (* FIXME authentic syntax *)
+ |> PureThy.add_defs false
+ [((Binding.map_name Thm.def_name name, Logic.mk_equals (setC, set)), [])]
|-> (fn [th] => pair (SOME th))
else (NONE, theory);
fun contract_def NONE th = th
@@ -122,10 +128,10 @@
let
val cert = Thm.cterm_of (Thm.theory_of_thm def_eq);
val goal_eq = MetaSimplifier.rewrite true [def_eq] (cert goal');
- in Drule.standard (Drule.equal_elim_rule2 OF [goal_eq, th]) end;
+ in Drule.export_without_context (Drule.equal_elim_rule2 OF [goal_eq, th]) end;
fun typedef_result inhabited =
- ObjectLogic.typedecl (t, vs, mx)
+ ObjectLogic.typedecl (tname, vs, mx)
#> snd
#> Sign.add_consts_i
[(Rep_name, newT --> oldT, NoSyn),
@@ -139,7 +145,7 @@
##> Theory.add_deps "" (dest_Const AbsC) typedef_deps
#-> (fn ([type_definition], set_def) => fn thy1 =>
let
- fun make th = Drule.standard (th OF [type_definition]);
+ fun make th = Drule.export_without_context (th OF [type_definition]);
val ([Rep, Rep_inverse, Abs_inverse, Rep_inject, Abs_inject,
Rep_cases, Abs_cases, Rep_induct, Abs_induct], thy2) =
thy1
@@ -158,7 +164,7 @@
[Rule_Cases.case_names [Binding.name_of Rep_name], Induct.induct_pred full_name]),
((Binding.suffix_name "_induct" Abs_name, make @{thm type_definition.Abs_induct}),
[Rule_Cases.case_names [Binding.name_of Abs_name], Induct.induct_type full_tname])]
- ||> Sign.parent_path;
+ ||> Sign.restore_naming thy1;
val info = {rep_type = oldT, abs_type = newT,
Rep_name = full Rep_name, Abs_name = full Abs_name,
inhabited = inhabited, type_definition = type_definition, set_def = set_def,
@@ -244,25 +250,20 @@
val _ = OuterKeyword.keyword "morphisms";
-val typedef_decl =
- Scan.optional (P.$$$ "(" |--
- ((P.$$$ "open" >> K false) -- Scan.option P.binding || P.binding >> (fn s => (true, SOME s)))
- --| P.$$$ ")") (true, NONE) --
- (P.type_args -- P.binding) -- P.opt_infix -- (P.$$$ "=" |-- P.term) --
- Scan.option (P.$$$ "morphisms" |-- P.!!! (P.binding -- P.binding));
-
-fun mk_typedef ((((((def, opt_name), (vs, t)), mx), A), morphs)) =
- typedef_cmd ((def, the_default (Binding.map_name (Syntax.type_name mx) t) opt_name),
- (t, vs, mx), A, morphs);
-
val _ =
OuterSyntax.command "typedef" "HOL type definition (requires non-emptiness proof)"
OuterKeyword.thy_goal
- (typedef_decl >> (Toplevel.print oo (Toplevel.theory_to_proof o mk_typedef)));
+ (Scan.optional (P.$$$ "(" |--
+ ((P.$$$ "open" >> K false) -- Scan.option P.binding ||
+ P.binding >> (fn s => (true, SOME s))) --| P.$$$ ")") (true, NONE) --
+ (P.type_args -- P.binding) -- P.opt_infix -- (P.$$$ "=" |-- P.term) --
+ Scan.option (P.$$$ "morphisms" |-- P.!!! (P.binding -- P.binding))
+ >> (fn ((((((def, opt_name), (vs, t)), mx), A), morphs)) =>
+ Toplevel.print o Toplevel.theory_to_proof
+ (typedef_cmd ((def, the_default t opt_name), (t, vs, mx), A, morphs))));
end;
-
val setup = Typedef_Interpretation.init;
end;
--- a/src/HOL/Transcendental.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Transcendental.thy Fri Feb 19 15:21:57 2010 +0000
@@ -247,7 +247,7 @@
from f[OF this]
show ?thesis unfolding n_eq atLeastLessThanSuc_atLeastAtMost .
next
- case False hence "even (n - 1)" using even_num_iff odd_pos by auto
+ case False hence "even (n - 1)" by simp
from even_nat_div_two_times_two[OF this]
have n_eq: "2 * ((n - 1) div 2) = n - 1" unfolding numeral_2_eq_2[symmetric] by auto
hence range_eq: "n - 1 + 1 = n" using odd_pos[OF False] by auto
@@ -381,7 +381,7 @@
done
lemma real_setsum_nat_ivl_bounded2:
- fixes K :: "'a::ordered_semidom"
+ fixes K :: "'a::linordered_semidom"
assumes f: "\<And>p::nat. p < n \<Longrightarrow> f p \<le> K"
assumes K: "0 \<le> K"
shows "setsum f {0..<n-k} \<le> of_nat n * K"
@@ -848,7 +848,7 @@
hence "norm (x * S n) / real (Suc n) \<le> r * norm (S n)"
by (simp add: pos_divide_le_eq mult_ac)
thus "norm (S (Suc n)) \<le> r * norm (S n)"
- by (simp add: S_Suc norm_scaleR inverse_eq_divide)
+ by (simp add: S_Suc inverse_eq_divide)
qed
qed
@@ -860,7 +860,7 @@
by (rule summable_exp_generic)
next
fix n show "norm (x ^ n /\<^sub>R real (fact n)) \<le> norm x ^ n /\<^sub>R real (fact n)"
- by (simp add: norm_scaleR norm_power_ineq)
+ by (simp add: norm_power_ineq)
qed
lemma summable_exp: "summable (%n. inverse (real (fact n)) * x ^ n)"
@@ -957,7 +957,7 @@
by (simp only: scaleR_right.setsum)
finally show
"S (x + y) (Suc n) = (\<Sum>i=0..Suc n. S x i * S y (Suc n - i))"
- by (simp add: scaleR_cancel_left del: setsum_cl_ivl_Suc)
+ by (simp del: setsum_cl_ivl_Suc)
qed
lemma exp_add: "exp (x + y) = exp x * exp y"
@@ -1237,7 +1237,7 @@
{ fix x :: real assume "x \<in> {- 1<..<1}" hence "norm (-x) < 1" by auto
show "summable (\<lambda>n. -1 ^ n * (1 / real (n + 1)) * real (Suc n) * x ^ n)"
unfolding One_nat_def
- by (auto simp del: power_mult_distrib simp add: power_mult_distrib[symmetric] summable_geometric[OF `norm (-x) < 1`])
+ by (auto simp add: power_mult_distrib[symmetric] summable_geometric[OF `norm (-x) < 1`])
}
qed
hence "DERIV (\<lambda>x. suminf (?f x)) (x - 1) :> suminf (?f' x)" unfolding One_nat_def by auto
@@ -2904,10 +2904,12 @@
next
case False hence "0 < \<bar>x\<bar>" and "- \<bar>x\<bar> < \<bar>x\<bar>" by auto
have "suminf (?c (-\<bar>x\<bar>)) - arctan (-\<bar>x\<bar>) = suminf (?c 0) - arctan 0"
- by (rule suminf_eq_arctan_bounded[where x="0" and a="-\<bar>x\<bar>" and b="\<bar>x\<bar>", symmetric], auto simp add: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>`)
+ by (rule suminf_eq_arctan_bounded[where x="0" and a="-\<bar>x\<bar>" and b="\<bar>x\<bar>", symmetric])
+ (simp_all only: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>` neg_less_iff_less)
moreover
have "suminf (?c x) - arctan x = suminf (?c (-\<bar>x\<bar>)) - arctan (-\<bar>x\<bar>)"
- by (rule suminf_eq_arctan_bounded[where x="x" and a="-\<bar>x\<bar>" and b="\<bar>x\<bar>"], auto simp add: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>`)
+ by (rule suminf_eq_arctan_bounded[where x="x" and a="-\<bar>x\<bar>" and b="\<bar>x\<bar>"])
+ (simp_all only: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>` neg_less_iff_less)
ultimately
show ?thesis using suminf_arctan_zero by auto
qed
@@ -3088,7 +3090,7 @@
lemma cos_x_y_le_one: "\<bar>x / sqrt (x\<twosuperior> + y\<twosuperior>)\<bar> \<le> 1"
apply (rule power2_le_imp_le [OF _ zero_le_one])
-apply (simp add: abs_divide power_divide divide_le_eq not_sum_power2_lt_zero)
+apply (simp add: power_divide divide_le_eq not_sum_power2_lt_zero)
done
lemma cos_arccos_abs: "\<bar>y\<bar> \<le> 1 \<Longrightarrow> cos (arccos y) = y"
--- a/src/HOL/Transitive_Closure.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Transitive_Closure.thy Fri Feb 19 15:21:57 2010 +0000
@@ -464,7 +464,7 @@
apply (rule subsetI)
apply (simp only: split_tupled_all)
apply (erule trancl_induct, blast)
- apply (blast intro: rtrancl_into_trancl1 trancl_into_rtrancl r_into_trancl trancl_trans)
+ apply (blast intro: rtrancl_into_trancl1 trancl_into_rtrancl trancl_trans)
apply (rule subsetI)
apply (blast intro: trancl_mono rtrancl_mono
[THEN [2] rev_subsetD] rtrancl_trancl_trancl rtrancl_into_trancl2)
@@ -503,7 +503,7 @@
apply (rule tranclp_induct [OF tranclp_converseI, OF conversepI, OF major])
apply (rule cases)
apply (erule conversepD)
- apply (blast intro: prems dest!: tranclp_converseD conversepD)
+ apply (blast intro: assms dest!: tranclp_converseD)
done
lemmas converse_trancl_induct = converse_tranclp_induct [to_set]
--- a/src/HOL/Typerep.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Typerep.thy Fri Feb 19 15:21:57 2010 +0000
@@ -17,22 +17,27 @@
end
-setup {*
+syntax
+ "_TYPEREP" :: "type => logic" ("(1TYPEREP/(1'(_')))")
+
+parse_translation {*
let
fun typerep_tr (*"_TYPEREP"*) [ty] =
- Lexicon.const @{const_syntax typerep} $ (Lexicon.const "_constrain" $ Lexicon.const "TYPE" $
- (Lexicon.const "itself" $ ty))
+ Syntax.const @{const_syntax typerep} $
+ (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "TYPE"} $
+ (Syntax.const "itself" $ ty)) (* FIXME @{type_syntax} *)
| typerep_tr (*"_TYPEREP"*) ts = raise TERM ("typerep_tr", ts);
- fun typerep_tr' show_sorts (*"typerep"*)
+in [(@{syntax_const "_TYPEREP"}, typerep_tr)] end
+*}
+
+typed_print_translation {*
+let
+ fun typerep_tr' show_sorts (*"typerep"*) (* FIXME @{type_syntax} *)
(Type ("fun", [Type ("itself", [T]), _])) (Const (@{const_syntax TYPE}, _) :: ts) =
- Term.list_comb (Lexicon.const "_TYPEREP" $ Syntax.term_of_typ show_sorts T, ts)
+ Term.list_comb
+ (Syntax.const @{syntax_const "_TYPEREP"} $ Syntax.term_of_typ show_sorts T, ts)
| typerep_tr' _ T ts = raise Match;
-in
- Sign.add_syntax_i
- [("_TYPEREP", Simple_Syntax.read_typ "type => logic", Delimfix "(1TYPEREP/(1'(_')))")]
- #> Sign.add_trfuns ([], [("_TYPEREP", typerep_tr)], [], [])
- #> Sign.add_trfunsT [(@{const_syntax typerep}, typerep_tr')]
-end
+in [(@{const_syntax typerep}, typerep_tr')] end
*}
setup {*
--- a/src/HOL/UNITY/PPROD.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/UNITY/PPROD.thy Fri Feb 19 15:21:57 2010 +0000
@@ -11,17 +11,14 @@
theory PPROD imports Lift_prog begin
constdefs
-
PLam :: "[nat set, nat => ('b * ((nat=>'b) * 'c)) program]
=> ((nat=>'b) * 'c) program"
"PLam I F == \<Squnion>i \<in> I. lift i (F i)"
syntax
- "@PLam" :: "[pttrn, nat set, 'b set] => (nat => 'b) set"
- ("(3plam _:_./ _)" 10)
-
+ "_PLam" :: "[pttrn, nat set, 'b set] => (nat => 'b) set" ("(3plam _:_./ _)" 10)
translations
- "plam x : A. B" == "PLam A (%x. B)"
+ "plam x : A. B" == "CONST PLam A (%x. B)"
(*** Basic properties ***)
--- a/src/HOL/UNITY/Union.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/UNITY/Union.thy Fri Feb 19 15:21:57 2010 +0000
@@ -36,19 +36,19 @@
"safety_prop X == SKIP: X & (\<forall>G. Acts G \<subseteq> UNION X Acts --> G \<in> X)"
syntax
- "@JOIN1" :: "[pttrns, 'b set] => 'b set" ("(3JN _./ _)" 10)
- "@JOIN" :: "[pttrn, 'a set, 'b set] => 'b set" ("(3JN _:_./ _)" 10)
+ "_JOIN1" :: "[pttrns, 'b set] => 'b set" ("(3JN _./ _)" 10)
+ "_JOIN" :: "[pttrn, 'a set, 'b set] => 'b set" ("(3JN _:_./ _)" 10)
translations
- "JN x : A. B" == "JOIN A (%x. B)"
- "JN x y. B" == "JN x. JN y. B"
- "JN x. B" == "JOIN CONST UNIV (%x. B)"
+ "JN x: A. B" == "CONST JOIN A (%x. B)"
+ "JN x y. B" == "JN x. JN y. B"
+ "JN x. B" == "CONST JOIN (CONST UNIV) (%x. B)"
syntax (xsymbols)
SKIP :: "'a program" ("\<bottom>")
Join :: "['a program, 'a program] => 'a program" (infixl "\<squnion>" 65)
- "@JOIN1" :: "[pttrns, 'b set] => 'b set" ("(3\<Squnion> _./ _)" 10)
- "@JOIN" :: "[pttrn, 'a set, 'b set] => 'b set" ("(3\<Squnion> _\<in>_./ _)" 10)
+ "_JOIN1" :: "[pttrns, 'b set] => 'b set" ("(3\<Squnion> _./ _)" 10)
+ "_JOIN" :: "[pttrn, 'a set, 'b set] => 'b set" ("(3\<Squnion> _\<in>_./ _)" 10)
subsection{*SKIP*}
--- a/src/HOL/Wellfounded.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Wellfounded.thy Fri Feb 19 15:21:57 2010 +0000
@@ -489,7 +489,7 @@
by (simp add: less_than_def wf_pred_nat [THEN wf_trancl])
lemma trans_less_than [iff]: "trans less_than"
- by (simp add: less_than_def trans_trancl)
+ by (simp add: less_than_def)
lemma less_than_iff [iff]: "((x,y): less_than) = (x<y)"
by (simp add: less_than_def less_eq)
--- a/src/HOL/Word/BinGeneral.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Word/BinGeneral.thy Fri Feb 19 15:21:57 2010 +0000
@@ -742,7 +742,7 @@
lemma sb_inc_lem':
"(a::int) < - (2^k) \<Longrightarrow> a + 2^k + 2^(Suc k) <= (a + 2^k) mod 2^(Suc k)"
- by (rule iffD1 [OF less_diff_eq, THEN sb_inc_lem, simplified OrderedGroup.diff_0])
+ by (rule sb_inc_lem) simp
lemma sbintrunc_inc:
"x < - (2^n) ==> x + 2^(Suc n) <= sbintrunc n x"
--- a/src/HOL/Word/Word.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Word/Word.thy Fri Feb 19 15:21:57 2010 +0000
@@ -2,7 +2,7 @@
Author: Gerwin Klein, NICTA
*)
-header {* Word Library interafce *}
+header {* Word Library interface *}
theory Word
imports WordGenLib
--- a/src/HOL/Word/WordDefinition.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/Word/WordDefinition.thy Fri Feb 19 15:21:57 2010 +0000
@@ -94,7 +94,7 @@
syntax
of_int :: "int => 'a"
translations
- "case x of of_int y => b" == "CONST word_int_case (%y. b) x"
+ "case x of CONST of_int y => b" == "CONST word_int_case (%y. b) x"
subsection "Arithmetic operations"
--- a/src/HOL/ZF/Games.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ZF/Games.thy Fri Feb 19 15:21:57 2010 +0000
@@ -922,7 +922,7 @@
apply (auto simp add: Pg_def quotient_def)
done
-instance Pg :: pordered_ab_group_add
+instance Pg :: ordered_ab_group_add
proof
fix a b c :: Pg
show "a - b = a + (- b)" by (simp add: Pg_diff_def)
--- a/src/HOL/ex/Antiquote.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/Antiquote.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,11 +1,12 @@
(* Title: HOL/ex/Antiquote.thy
- ID: $Id$
Author: Markus Wenzel, TU Muenchen
*)
header {* Antiquotations *}
-theory Antiquote imports Main begin
+theory Antiquote
+imports Main
+begin
text {*
A simple example on quote / antiquote in higher-order abstract
@@ -13,17 +14,23 @@
*}
syntax
- "_Expr" :: "'a => 'a" ("EXPR _" [1000] 999)
+ "_Expr" :: "'a => 'a" ("EXPR _" [1000] 999)
-constdefs
- var :: "'a => ('a => nat) => nat" ("VAR _" [1000] 999)
- "var x env == env x"
+definition
+ var :: "'a => ('a => nat) => nat" ("VAR _" [1000] 999)
+ where "var x env = env x"
+definition
Expr :: "(('a => nat) => nat) => ('a => nat) => nat"
- "Expr exp env == exp env"
+ where "Expr exp env = exp env"
-parse_translation {* [Syntax.quote_antiquote_tr "_Expr" "var" "Expr"] *}
-print_translation {* [Syntax.quote_antiquote_tr' "_Expr" "var" "Expr"] *}
+parse_translation {*
+ [Syntax.quote_antiquote_tr @{syntax_const "_Expr"} @{const_syntax var} @{const_syntax Expr}]
+*}
+
+print_translation {*
+ [Syntax.quote_antiquote_tr' @{syntax_const "_Expr"} @{const_syntax var} @{const_syntax Expr}]
+*}
term "EXPR (a + b + c)"
term "EXPR (a + b + c + VAR x + VAR y + 1)"
--- a/src/HOL/ex/Binary.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/Binary.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/ex/Binary.thy
- ID: $Id$
Author: Makarius
*)
@@ -21,8 +20,6 @@
unfolding bit_def by simp_all
ML {*
-structure Binary =
-struct
fun dest_bit (Const (@{const_name False}, _)) = 0
| dest_bit (Const (@{const_name True}, _)) = 1
| dest_bit t = raise TERM ("dest_bit", [t]);
@@ -43,7 +40,6 @@
else
let val (q, r) = Integer.div_mod n 2
in @{term bit} $ mk_binary q $ mk_bit r end;
-end
*}
@@ -126,7 +122,7 @@
fun binary_proc proc ss ct =
(case Thm.term_of ct of
_ $ t $ u =>
- (case try (pairself (`Binary.dest_binary)) (t, u) of
+ (case try (pairself (`dest_binary)) (t, u) of
SOME args => proc (Simplifier.the_context ss) args
| NONE => NONE)
| _ => NONE);
@@ -135,34 +131,34 @@
val less_eq_proc = binary_proc (fn ctxt => fn ((m, t), (n, u)) =>
let val k = n - m in
if k >= 0 then
- SOME (@{thm binary_less_eq(1)} OF [prove ctxt (u == plus t (Binary.mk_binary k))])
+ SOME (@{thm binary_less_eq(1)} OF [prove ctxt (u == plus t (mk_binary k))])
else
SOME (@{thm binary_less_eq(2)} OF
- [prove ctxt (t == plus (plus u (Binary.mk_binary (~ k - 1))) (Binary.mk_binary 1))])
+ [prove ctxt (t == plus (plus u (mk_binary (~ k - 1))) (mk_binary 1))])
end);
val less_proc = binary_proc (fn ctxt => fn ((m, t), (n, u)) =>
let val k = m - n in
if k >= 0 then
- SOME (@{thm binary_less(1)} OF [prove ctxt (t == plus u (Binary.mk_binary k))])
+ SOME (@{thm binary_less(1)} OF [prove ctxt (t == plus u (mk_binary k))])
else
SOME (@{thm binary_less(2)} OF
- [prove ctxt (u == plus (plus t (Binary.mk_binary (~ k - 1))) (Binary.mk_binary 1))])
+ [prove ctxt (u == plus (plus t (mk_binary (~ k - 1))) (mk_binary 1))])
end);
val diff_proc = binary_proc (fn ctxt => fn ((m, t), (n, u)) =>
let val k = m - n in
if k >= 0 then
- SOME (@{thm binary_diff(1)} OF [prove ctxt (t == plus u (Binary.mk_binary k))])
+ SOME (@{thm binary_diff(1)} OF [prove ctxt (t == plus u (mk_binary k))])
else
- SOME (@{thm binary_diff(2)} OF [prove ctxt (u == plus t (Binary.mk_binary (~ k)))])
+ SOME (@{thm binary_diff(2)} OF [prove ctxt (u == plus t (mk_binary (~ k)))])
end);
fun divmod_proc rule = binary_proc (fn ctxt => fn ((m, t), (n, u)) =>
if n = 0 then NONE
else
let val (k, l) = Integer.div_mod m n
- in SOME (rule OF [prove ctxt (t == plus (mult u (Binary.mk_binary k)) (Binary.mk_binary l))]) end);
+ in SOME (rule OF [prove ctxt (t == plus (mult u (mk_binary k)) (mk_binary l))]) end);
end;
*}
@@ -194,17 +190,17 @@
parse_translation {*
let
-
-val syntax_consts = map_aterms (fn Const (c, T) => Const (Syntax.constN ^ c, T) | a => a);
+ val syntax_consts =
+ map_aterms (fn Const (c, T) => Const (Syntax.constN ^ c, T) | a => a);
-fun binary_tr [Const (num, _)] =
- let
- val {leading_zeros = z, value = n, ...} = Syntax.read_xnum num;
- val _ = z = 0 andalso n >= 0 orelse error ("Bad binary number: " ^ num);
- in syntax_consts (Binary.mk_binary n) end
- | binary_tr ts = raise TERM ("binary_tr", ts);
+ fun binary_tr [Const (num, _)] =
+ let
+ val {leading_zeros = z, value = n, ...} = Syntax.read_xnum num;
+ val _ = z = 0 andalso n >= 0 orelse error ("Bad binary number: " ^ num);
+ in syntax_consts (mk_binary n) end
+ | binary_tr ts = raise TERM ("binary_tr", ts);
-in [("_Binary", binary_tr)] end
+in [(@{syntax_const "_Binary"}, binary_tr)] end
*}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/ex/Execute_Choice.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,102 @@
+(* Author: Florian Haftmann, TU Muenchen *)
+
+header {* A simple cookbook example how to eliminate choice in programs. *}
+
+theory Execute_Choice
+imports Main AssocList
+begin
+
+text {*
+ A trivial example:
+*}
+
+definition valuesum :: "('a, 'b :: ab_group_add) mapping \<Rightarrow> 'b" where
+ "valuesum m = (\<Sum>k \<in> Mapping.keys m. the (Mapping.lookup m k))"
+
+text {*
+ Not that instead of defining @{term valuesum} with choice, we define it
+ directly and derive a description involving choice afterwards:
+*}
+
+lemma valuesum_rec:
+ assumes fin: "finite (dom (Mapping.lookup m))"
+ shows "valuesum m = (if Mapping.is_empty m then 0 else
+ let l = (SOME l. l \<in> Mapping.keys m) in the (Mapping.lookup m l) + valuesum (Mapping.delete l m))"
+proof (cases "Mapping.is_empty m")
+ case True then show ?thesis by (simp add: is_empty_def keys_def valuesum_def)
+next
+ case False
+ then have l: "\<exists>l. l \<in> dom (Mapping.lookup m)" by (auto simp add: is_empty_def expand_fun_eq mem_def)
+ then have "(let l = SOME l. l \<in> dom (Mapping.lookup m) in
+ the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
+ (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
+ proof (rule someI2_ex)
+ fix l
+ note fin
+ moreover assume "l \<in> dom (Mapping.lookup m)"
+ moreover obtain A where "A = dom (Mapping.lookup m) - {l}" by simp
+ ultimately have "dom (Mapping.lookup m) = insert l A" and "finite A" and "l \<notin> A" by auto
+ then show "(let l = l
+ in the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
+ (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
+ by simp
+ qed
+ then show ?thesis by (simp add: keys_def valuesum_def is_empty_def)
+qed
+
+text {*
+ In the context of the else-branch we can show that the exact choice is
+ irrelvant; in practice, finding this point where choice becomes irrelevant is the
+ most difficult thing!
+*}
+
+lemma valuesum_choice:
+ "finite (Mapping.keys M) \<Longrightarrow> x \<in> Mapping.keys M \<Longrightarrow> y \<in> Mapping.keys M \<Longrightarrow>
+ the (Mapping.lookup M x) + valuesum (Mapping.delete x M) =
+ the (Mapping.lookup M y) + valuesum (Mapping.delete y M)"
+ by (simp add: valuesum_def keys_def setsum_diff)
+
+text {*
+ Given @{text valuesum_rec} as initial description, we stepwise refine it to something executable;
+ first, we formally insert the constructor @{term AList} and split the one equation into two,
+ where the second one provides the necessary context:
+*}
+
+lemma valuesum_rec_AList:
+ shows [code]: "valuesum (AList []) = 0"
+ and "valuesum (AList (x # xs)) = (let l = (SOME l. l \<in> Mapping.keys (AList (x # xs))) in
+ the (Mapping.lookup (AList (x # xs)) l) + valuesum (Mapping.delete l (AList (x # xs))))"
+ by (simp_all add: valuesum_rec finite_dom_map_of is_empty_AList)
+
+text {*
+ As a side effect the precondition disappears (but note this has nothing to do with choice!).
+ The first equation deals with the uncritical empty case and can already be used for code generation.
+
+ Using @{text valuesum_choice}, we are able to prove an executable version of @{term valuesum}:
+*}
+
+lemma valuesum_rec_exec [code]:
+ "valuesum (AList (x # xs)) = (let l = fst (hd (x # xs)) in
+ the (Mapping.lookup (AList (x # xs)) l) + valuesum (Mapping.delete l (AList (x # xs))))"
+proof -
+ let ?M = "AList (x # xs)"
+ let ?l1 = "(SOME l. l \<in> Mapping.keys ?M)"
+ let ?l2 = "fst (hd (x # xs))"
+ have "finite (Mapping.keys ?M)" by (simp add: keys_AList)
+ moreover have "?l1 \<in> Mapping.keys ?M"
+ by (rule someI) (auto simp add: keys_AList)
+ moreover have "?l2 \<in> Mapping.keys ?M"
+ by (simp add: keys_AList)
+ ultimately have "the (Mapping.lookup ?M ?l1) + valuesum (Mapping.delete ?l1 ?M) =
+ the (Mapping.lookup ?M ?l2) + valuesum (Mapping.delete ?l2 ?M)"
+ by (rule valuesum_choice)
+ then show ?thesis by (simp add: valuesum_rec_AList)
+qed
+
+text {*
+ See how it works:
+*}
+
+value "valuesum (AList [(''abc'', (42::int)), (''def'', 1705)])"
+
+end
--- a/src/HOL/ex/Multiquote.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/Multiquote.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,11 +1,12 @@
(* Title: HOL/ex/Multiquote.thy
- ID: $Id$
Author: Markus Wenzel, TU Muenchen
*)
header {* Multiple nested quotations and anti-quotations *}
-theory Multiquote imports Main begin
+theory Multiquote
+imports Main
+begin
text {*
Multiple nested quotations and anti-quotations -- basically a
@@ -13,25 +14,25 @@
*}
syntax
- "_quote" :: "'b => ('a => 'b)" ("\<guillemotleft>_\<guillemotright>" [0] 1000)
- "_antiquote" :: "('a => 'b) => 'b" ("\<acute>_" [1000] 1000)
+ "_quote" :: "'b => ('a => 'b)" ("\<guillemotleft>_\<guillemotright>" [0] 1000)
+ "_antiquote" :: "('a => 'b) => 'b" ("\<acute>_" [1000] 1000)
parse_translation {*
let
- fun antiquote_tr i (Const ("_antiquote", _) $ (t as Const ("_antiquote", _) $ _)) =
- skip_antiquote_tr i t
- | antiquote_tr i (Const ("_antiquote", _) $ t) =
+ fun antiquote_tr i (Const (@{syntax_const "_antiquote"}, _) $
+ (t as Const (@{syntax_const "_antiquote"}, _) $ _)) = skip_antiquote_tr i t
+ | antiquote_tr i (Const (@{syntax_const "_antiquote"}, _) $ t) =
antiquote_tr i t $ Bound i
| antiquote_tr i (t $ u) = antiquote_tr i t $ antiquote_tr i u
| antiquote_tr i (Abs (x, T, t)) = Abs (x, T, antiquote_tr (i + 1) t)
| antiquote_tr _ a = a
- and skip_antiquote_tr i ((c as Const ("_antiquote", _)) $ t) =
+ and skip_antiquote_tr i ((c as Const (@{syntax_const "_antiquote"}, _)) $ t) =
c $ skip_antiquote_tr i t
| skip_antiquote_tr i t = antiquote_tr i t;
fun quote_tr [t] = Abs ("s", dummyT, antiquote_tr 0 (Term.incr_boundvars 1 t))
| quote_tr ts = raise TERM ("quote_tr", ts);
- in [("_quote", quote_tr)] end
+ in [(@{syntax_const "_quote"}, quote_tr)] end
*}
text {* basic examples *}
--- a/src/HOL/ex/Numeral.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/Numeral.thy Fri Feb 19 15:21:57 2010 +0000
@@ -311,7 +311,7 @@
orelse error ("Bad numeral: " ^ num);
in Const (@{const_name of_num}, @{typ num} --> dummyT) $ num_of_int value end
| numeral_tr ts = raise TERM ("numeral_tr", ts);
-in [("_Numerals", numeral_tr)] end
+in [(@{syntax_const "_Numerals"}, numeral_tr)] end
*}
typed_print_translation {*
@@ -325,9 +325,9 @@
fun num_tr' show_sorts T [n] =
let
val k = int_of_num' n;
- val t' = Syntax.const "_Numerals" $ Syntax.free ("#" ^ string_of_int k);
+ val t' = Syntax.const @{syntax_const "_Numerals"} $ Syntax.free ("#" ^ string_of_int k);
in case T
- of Type ("fun", [_, T']) =>
+ of Type ("fun", [_, T']) => (* FIXME @{type_syntax} *)
if not (! show_types) andalso can Term.dest_Type T' then t'
else Syntax.const Syntax.constrainC $ t' $ Syntax.term_of_typ show_sorts T'
| T' => if T' = dummyT then t' else raise Match
@@ -442,12 +442,12 @@
end
subsubsection {*
- Comparisons: class @{text ordered_semidom}
+ Comparisons: class @{text linordered_semidom}
*}
text {* Could be perhaps more general than here. *}
-context ordered_semidom
+context linordered_semidom
begin
lemma of_num_pos [numeral]: "0 < of_num n"
@@ -490,7 +490,7 @@
end
-context ordered_idom
+context linordered_idom
begin
lemma minus_of_num_less_of_num_iff: "- of_num m < of_num n"
@@ -896,19 +896,19 @@
declare (in semiring_char_0) of_num_eq_one_iff [simp]
declare (in semiring_char_0) one_eq_of_num_iff [simp]
-declare (in ordered_semidom) of_num_pos [simp]
-declare (in ordered_semidom) of_num_less_eq_iff [simp]
-declare (in ordered_semidom) of_num_less_eq_one_iff [simp]
-declare (in ordered_semidom) one_less_eq_of_num_iff [simp]
-declare (in ordered_semidom) of_num_less_iff [simp]
-declare (in ordered_semidom) of_num_less_one_iff [simp]
-declare (in ordered_semidom) one_less_of_num_iff [simp]
-declare (in ordered_semidom) of_num_nonneg [simp]
-declare (in ordered_semidom) of_num_less_zero_iff [simp]
-declare (in ordered_semidom) of_num_le_zero_iff [simp]
+declare (in linordered_semidom) of_num_pos [simp]
+declare (in linordered_semidom) of_num_less_eq_iff [simp]
+declare (in linordered_semidom) of_num_less_eq_one_iff [simp]
+declare (in linordered_semidom) one_less_eq_of_num_iff [simp]
+declare (in linordered_semidom) of_num_less_iff [simp]
+declare (in linordered_semidom) of_num_less_one_iff [simp]
+declare (in linordered_semidom) one_less_of_num_iff [simp]
+declare (in linordered_semidom) of_num_nonneg [simp]
+declare (in linordered_semidom) of_num_less_zero_iff [simp]
+declare (in linordered_semidom) of_num_le_zero_iff [simp]
-declare (in ordered_idom) le_signed_numeral_special [simp]
-declare (in ordered_idom) less_signed_numeral_special [simp]
+declare (in linordered_idom) le_signed_numeral_special [simp]
+declare (in linordered_idom) less_signed_numeral_special [simp]
declare (in semiring_1_minus) Dig_of_num_minus_one [simp]
declare (in semiring_1_minus) Dig_one_minus_of_num [simp]
--- a/src/HOL/ex/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -65,7 +65,9 @@
"HarmonicSeries",
"Refute_Examples",
"Quickcheck_Examples",
- "Landau"
+ "Landau",
+ "Execute_Choice",
+ "Summation"
];
HTML.with_charset "utf-8" (no_document use_thys)
--- a/src/HOL/ex/RPred.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/RPred.thy Fri Feb 19 15:21:57 2010 +0000
@@ -25,7 +25,7 @@
(* (infixl "\<squnion>" 80) *)
where
"supp RP1 RP2 = (\<lambda>s. let (P1, s') = RP1 s; (P2, s'') = RP2 s'
- in (upper_semilattice_class.sup P1 P2, s''))"
+ in (semilattice_sup_class.sup P1 P2, s''))"
definition if_rpred :: "bool \<Rightarrow> unit rpred"
where
--- a/src/HOL/ex/ReflectionEx.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/ReflectionEx.thy Fri Feb 19 15:21:57 2010 +0000
@@ -385,7 +385,7 @@
(* An example for equations containing type variables *)
datatype prod = Zero | One | Var nat | Mul prod prod
| Pw prod nat | PNM nat nat prod
-consts Iprod :: " prod \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>'a"
+consts Iprod :: " prod \<Rightarrow> ('a::{linordered_idom}) list \<Rightarrow>'a"
primrec
"Iprod Zero vs = 0"
"Iprod One vs = 1"
@@ -397,7 +397,7 @@
datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
| Or sgn sgn | And sgn sgn
-consts Isgn :: " sgn \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>bool"
+consts Isgn :: " sgn \<Rightarrow> ('a::{linordered_idom}) list \<Rightarrow>bool"
primrec
"Isgn Tr vs = True"
"Isgn F vs = False"
@@ -410,7 +410,7 @@
lemmas eqs = Isgn.simps Iprod.simps
-lemma "(x::'a::{ordered_idom})^4 * y * z * y^2 * z^23 > 0"
+lemma "(x::'a::{linordered_idom})^4 * y * z * y^2 * z^23 > 0"
apply (reify eqs)
oops
--- a/src/HOL/ex/SVC_Oracle.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/SVC_Oracle.thy Fri Feb 19 15:21:57 2010 +0000
@@ -65,7 +65,7 @@
(*abstraction of a real/rational expression*)
fun rat ((c as Const(@{const_name Algebras.plus}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.minus}, _)) $ x $ y) = c $ (rat x) $ (rat y)
- | rat ((c as Const(@{const_name Algebras.divide}, _)) $ x $ y) = c $ (rat x) $ (rat y)
+ | rat ((c as Const(@{const_name Rings.divide}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.times}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.uminus}, _)) $ x) = c $ (rat x)
| rat t = lit t
@@ -95,8 +95,8 @@
| fm ((c as Const("True", _))) = c
| fm ((c as Const("False", _))) = c
| fm (t as Const("op =", Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
- | fm (t as Const(@{const_name Algebras.less}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
- | fm (t as Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
+ | fm (t as Const(@{const_name Orderings.less}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
+ | fm (t as Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
| fm t = replace t
(*entry point, and abstraction of a meta-formula*)
fun mt ((c as Const("Trueprop", _)) $ p) = c $ (fm p)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/ex/Summation.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,107 @@
+(* Author: Florian Haftmann, TU Muenchen *)
+
+header {* Some basic facts about discrete summation *}
+
+theory Summation
+imports Main
+begin
+
+text {* Auxiliary. *}
+
+lemma add_setsum_orient:
+ "setsum f {k..<j} + setsum f {l..<k} = setsum f {l..<k} + setsum f {k..<j}"
+ by (fact plus.commute)
+
+lemma add_setsum_int:
+ fixes j k l :: int
+ shows "j < k \<Longrightarrow> k < l \<Longrightarrow> setsum f {j..<k} + setsum f {k..<l} = setsum f {j..<l}"
+ by (simp_all add: setsum_Un_Int [symmetric] ivl_disj_un)
+
+text {* The shift operator. *}
+
+definition \<Delta> :: "(int \<Rightarrow> 'a\<Colon>ab_group_add) \<Rightarrow> int \<Rightarrow> 'a" where
+ "\<Delta> f k = f (k + 1) - f k"
+
+lemma \<Delta>_shift:
+ "\<Delta> (\<lambda>k. l + f k) = \<Delta> f"
+ by (simp add: \<Delta>_def expand_fun_eq)
+
+lemma \<Delta>_same_shift:
+ assumes "\<Delta> f = \<Delta> g"
+ shows "\<exists>l. (op +) l \<circ> f = g"
+proof -
+ fix k
+ from assms have "\<And>k. \<Delta> f k = \<Delta> g k" by simp
+ then have k_incr: "\<And>k. f (k + 1) - g (k + 1) = f k - g k"
+ by (simp add: \<Delta>_def algebra_simps)
+ then have "\<And>k. f ((k - 1) + 1) - g ((k - 1) + 1) = f (k - 1) - g (k - 1)"
+ by blast
+ then have k_decr: "\<And>k. f (k - 1) - g (k - 1) = f k - g k"
+ by simp
+ have "\<And>k. f k - g k = f 0 - g 0"
+ proof -
+ fix k
+ show "f k - g k = f 0 - g 0"
+ by (induct k rule: int_induct) (simp_all add: k_incr k_decr)
+ qed
+ then have "\<And>k. ((op +) (g 0 - f 0) \<circ> f) k = g k"
+ by (simp add: algebra_simps)
+ then have "(op +) (g 0 - f 0) \<circ> f = g" ..
+ then show ?thesis ..
+qed
+
+text {* The formal sum operator. *}
+
+definition \<Sigma> :: "(int \<Rightarrow> 'a\<Colon>ab_group_add) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a" where
+ "\<Sigma> f j l = (if j < l then setsum f {j..<l}
+ else if j > l then - setsum f {l..<j}
+ else 0)"
+
+lemma \<Sigma>_same [simp]:
+ "\<Sigma> f j j = 0"
+ by (simp add: \<Sigma>_def)
+
+lemma \<Sigma>_positive:
+ "j < l \<Longrightarrow> \<Sigma> f j l = setsum f {j..<l}"
+ by (simp add: \<Sigma>_def)
+
+lemma \<Sigma>_negative:
+ "j > l \<Longrightarrow> \<Sigma> f j l = - \<Sigma> f l j"
+ by (simp add: \<Sigma>_def)
+
+lemma add_\<Sigma>:
+ "\<Sigma> f j k + \<Sigma> f k l = \<Sigma> f j l"
+ by (simp add: \<Sigma>_def algebra_simps add_setsum_int)
+ (simp_all add: add_setsum_orient [of f k j l]
+ add_setsum_orient [of f j l k]
+ add_setsum_orient [of f j k l] add_setsum_int)
+
+lemma \<Sigma>_incr_upper:
+ "\<Sigma> f j (l + 1) = \<Sigma> f j l + f l"
+proof -
+ have "{l..<l+1} = {l}" by auto
+ then have "\<Sigma> f l (l + 1) = f l" by (simp add: \<Sigma>_def)
+ moreover have "\<Sigma> f j (l + 1) = \<Sigma> f j l + \<Sigma> f l (l + 1)" by (simp add: add_\<Sigma>)
+ ultimately show ?thesis by simp
+qed
+
+text {* Fundamental lemmas: The relation between @{term \<Delta>} and @{term \<Sigma>}. *}
+
+lemma \<Delta>_\<Sigma>:
+ "\<Delta> (\<Sigma> f j) = f"
+proof
+ fix k
+ show "\<Delta> (\<Sigma> f j) k = f k"
+ by (simp add: \<Delta>_def \<Sigma>_incr_upper)
+qed
+
+lemma \<Sigma>_\<Delta>:
+ "\<Sigma> (\<Delta> f) j l = f l - f j"
+proof -
+ from \<Delta>_\<Sigma> have "\<Delta> (\<Sigma> (\<Delta> f) j) = \<Delta> f" .
+ then obtain k where "(op +) k \<circ> \<Sigma> (\<Delta> f) j = f" by (blast dest: \<Delta>_same_shift)
+ then have "\<And>q. f q = k + \<Sigma> (\<Delta> f) j q" by (simp add: expand_fun_eq)
+ then show ?thesis by simp
+qed
+
+end
--- a/src/HOL/ex/svc_funcs.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOL/ex/svc_funcs.ML Fri Feb 19 15:21:57 2010 +0000
@@ -62,11 +62,11 @@
val _ = if !trace then tracing ("Calling SVC:\n" ^ svc_input) else ()
val svc_input_file = File.tmp_path (Path.basic "SVM_in");
val svc_output_file = File.tmp_path (Path.basic "SVM_out");
- val _ = (File.write svc_input_file svc_input;
- #1 (system_out (check_valid ^ " -dump-result " ^
- File.shell_path svc_output_file ^
- " " ^ File.shell_path svc_input_file ^
- ">/dev/null 2>&1")))
+ val _ = File.write svc_input_file svc_input;
+ val _ =
+ bash_output (check_valid ^ " -dump-result " ^
+ File.shell_path svc_output_file ^ " " ^ File.shell_path svc_input_file ^
+ ">/dev/null 2>&1")
val svc_output =
(case try File.read svc_output_file of
SOME out => out
@@ -107,8 +107,8 @@
b1 orelse b2)
end
else (*might be numeric equality*) (t, is_intnat T)
- | Const(@{const_name Algebras.less}, Type ("fun", [T,_])) => (t, is_intnat T)
- | Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) => (t, is_intnat T)
+ | Const(@{const_name Orderings.less}, Type ("fun", [T,_])) => (t, is_intnat T)
+ | Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) => (t, is_intnat T)
| _ => (t, false)
end
in #1 o tag end;
@@ -173,7 +173,7 @@
| tm (Const(@{const_name Algebras.times}, T) $ x $ y) =
if is_numeric_op T then Interp("*", [tm x, tm y])
else fail t
- | tm (Const(@{const_name Algebras.inverse}, T) $ x) =
+ | tm (Const(@{const_name Rings.inverse}, T) $ x) =
if domain_type T = HOLogic.realT then
Rat(1, litExp x)
else fail t
@@ -211,13 +211,13 @@
else fail t
end
(*inequalities: possible types are nat, int, real*)
- | fm pos (t as Const(@{const_name Algebras.less}, Type ("fun", [T,_])) $ x $ y) =
+ | fm pos (t as Const(@{const_name Orderings.less}, Type ("fun", [T,_])) $ x $ y) =
if not pos orelse T = HOLogic.realT then
Buildin("<", [tm x, tm y])
else if is_intnat T then
Buildin("<=", [suc (tm x), tm y])
else fail t
- | fm pos (t as Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) $ x $ y) =
+ | fm pos (t as Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) $ x $ y) =
if pos orelse T = HOLogic.realT then
Buildin("<=", [tm x, tm y])
else if is_intnat T then
--- a/src/HOLCF/Cfun.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Cfun.thy Fri Feb 19 15:21:57 2010 +0000
@@ -40,8 +40,8 @@
syntax "_cabs" :: "'a"
parse_translation {*
-(* rewrites (_cabs x t) => (Abs_CFun (%x. t)) *)
- [mk_binder_tr ("_cabs", @{const_syntax Abs_CFun})];
+(* rewrite (_cabs x t) => (Abs_CFun (%x. t)) *)
+ [mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_CFun})];
*}
text {* To avoid eta-contraction of body: *}
@@ -49,13 +49,13 @@
let
fun cabs_tr' _ _ [Abs abs] = let
val (x,t) = atomic_abs_tr' abs
- in Syntax.const "_cabs" $ x $ t end
+ in Syntax.const @{syntax_const "_cabs"} $ x $ t end
| cabs_tr' _ T [t] = let
val xT = domain_type (domain_type T);
val abs' = ("x",xT,(incr_boundvars 1 t)$Bound 0);
val (x,t') = atomic_abs_tr' abs';
- in Syntax.const "_cabs" $ x $ t' end;
+ in Syntax.const @{syntax_const "_cabs"} $ x $ t' end;
in [(@{const_syntax Abs_CFun}, cabs_tr')] end;
*}
@@ -69,26 +69,28 @@
"_Lambda" :: "[cargs, 'a] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)
parse_ast_translation {*
-(* rewrites (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
-(* cf. Syntax.lambda_ast_tr from Syntax/syn_trans.ML *)
+(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
+(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
let
fun Lambda_ast_tr [pats, body] =
- Syntax.fold_ast_p "_cabs" (Syntax.unfold_ast "_cargs" pats, body)
+ Syntax.fold_ast_p @{syntax_const "_cabs"}
+ (Syntax.unfold_ast @{syntax_const "_cargs"} pats, body)
| Lambda_ast_tr asts = raise Syntax.AST ("Lambda_ast_tr", asts);
- in [("_Lambda", Lambda_ast_tr)] end;
+ in [(@{syntax_const "_Lambda"}, Lambda_ast_tr)] end;
*}
print_ast_translation {*
-(* rewrites (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
-(* cf. Syntax.abs_ast_tr' from Syntax/syn_trans.ML *)
+(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
+(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
let
fun cabs_ast_tr' asts =
- (case Syntax.unfold_ast_p "_cabs"
- (Syntax.Appl (Syntax.Constant "_cabs" :: asts)) of
+ (case Syntax.unfold_ast_p @{syntax_const "_cabs"}
+ (Syntax.Appl (Syntax.Constant @{syntax_const "_cabs"} :: asts)) of
([], _) => raise Syntax.AST ("cabs_ast_tr'", asts)
| (xs, body) => Syntax.Appl
- [Syntax.Constant "_Lambda", Syntax.fold_ast "_cargs" xs, body]);
- in [("_cabs", cabs_ast_tr')] end;
+ [Syntax.Constant @{syntax_const "_Lambda"},
+ Syntax.fold_ast @{syntax_const "_cargs"} xs, body]);
+ in [(@{syntax_const "_cabs"}, cabs_ast_tr')] end
*}
text {* Dummy patterns for continuous abstraction *}
@@ -519,7 +521,7 @@
text {* results about strictify *}
lemma cont_strictify1: "cont (\<lambda>f. if x = \<bottom> then \<bottom> else f\<cdot>x)"
-by (simp add: cont_if)
+by simp
lemma monofun_strictify2: "monofun (\<lambda>x. if x = \<bottom> then \<bottom> else f\<cdot>x)"
apply (rule monofunI)
--- a/src/HOLCF/Deflation.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Deflation.thy Fri Feb 19 15:21:57 2010 +0000
@@ -316,16 +316,14 @@
subsection {* Uniqueness of ep-pairs *}
lemma ep_pair_unique_e_lemma:
- assumes "ep_pair e1 p" and "ep_pair e2 p"
+ assumes 1: "ep_pair e1 p" and 2: "ep_pair e2 p"
shows "e1 \<sqsubseteq> e2"
proof (rule below_cfun_ext)
- interpret e1: ep_pair e1 p by fact
- interpret e2: ep_pair e2 p by fact
fix x
have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
- by (rule e1.e_p_below)
+ by (rule ep_pair.e_p_below [OF 1])
thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
- by (simp only: e2.e_inverse)
+ by (simp only: ep_pair.e_inverse [OF 2])
qed
lemma ep_pair_unique_e:
@@ -333,18 +331,16 @@
by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
lemma ep_pair_unique_p_lemma:
- assumes "ep_pair e p1" and "ep_pair e p2"
+ assumes 1: "ep_pair e p1" and 2: "ep_pair e p2"
shows "p1 \<sqsubseteq> p2"
proof (rule below_cfun_ext)
- interpret p1: ep_pair e p1 by fact
- interpret p2: ep_pair e p2 by fact
fix x
have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
- by (rule p1.e_p_below)
+ by (rule ep_pair.e_p_below [OF 1])
hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
by (rule monofun_cfun_arg)
thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
- by (simp only: p2.e_inverse)
+ by (simp only: ep_pair.e_inverse [OF 2])
qed
lemma ep_pair_unique_p:
--- a/src/HOLCF/Domain.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Domain.thy Fri Feb 19 15:21:57 2010 +0000
@@ -222,6 +222,12 @@
lemmas con_defined_iff_rules =
sinl_defined_iff sinr_defined_iff spair_strict_iff up_defined ONE_defined
+lemmas con_below_iff_rules =
+ sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_defined_iff_rules
+
+lemmas con_eq_iff_rules =
+ sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_defined_iff_rules
+
use "Tools/cont_consts.ML"
use "Tools/cont_proc.ML"
use "Tools/Domain/domain_library.ML"
--- a/src/HOLCF/FOCUS/Buffer_adm.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/FOCUS/Buffer_adm.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/FOCUS/Buffer_adm.thy
- ID: $Id$
Author: David von Oheimb, TU Muenchen
*)
--- a/src/HOLCF/FOCUS/FOCUS.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/FOCUS/FOCUS.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/FOCUS/FOCUS.thy
- ID: $Id$
Author: David von Oheimb, TU Muenchen
*)
--- a/src/HOLCF/FOCUS/Fstream.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/FOCUS/Fstream.thy Fri Feb 19 15:21:57 2010 +0000
@@ -207,7 +207,7 @@
lemma fsfilter_fscons:
"A(C)x~> xs = (if x:A then x~> (A(C)xs) else A(C)xs)"
apply (unfold fsfilter_def)
-apply (simp add: fscons_def2 sfilter_scons If_and_if)
+apply (simp add: fscons_def2 If_and_if)
done
lemma fsfilter_emptys: "{}(C)x = UU"
--- a/src/HOLCF/FOCUS/Fstreams.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/FOCUS/Fstreams.thy Fri Feb 19 15:21:57 2010 +0000
@@ -208,9 +208,6 @@
by (simp add: fsmap_def fsingleton_def2 flift2_def)
-declare range_composition[simp del]
-
-
lemma fstreams_chain_lemma[rule_format]:
"ALL s x y. stream_take n$(s::'a fstream) << x & x << y & y << s & x ~= y --> stream_take (Suc n)$s << y"
apply (induct_tac n, auto)
@@ -225,7 +222,7 @@
apply (drule stream_prefix, auto)
apply (case_tac "y=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
-apply (auto simp add: stream.inverts)
+apply auto
apply (simp add: flat_less_iff)
apply (erule_tac x="tt" in allE)
apply (erule_tac x="yb" in allE, auto)
--- a/src/HOLCF/FOCUS/Stream_adm.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/FOCUS/Stream_adm.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/ex/Stream_adm.thy
- ID: $Id$
Author: David von Oheimb, TU Muenchen
*)
--- a/src/HOLCF/Fix.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Fix.thy Fri Feb 19 15:21:57 2010 +0000
@@ -73,6 +73,10 @@
apply simp
done
+lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
+ unfolding fix_def2
+ using chain_iterate by (rule is_ub_thelub)
+
text {*
Kleene's fixed point theorems for continuous functions in pointed
omega cpo's
--- a/src/HOLCF/Fixrec.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Fixrec.thy Fri Feb 19 15:21:57 2010 +0000
@@ -226,10 +226,10 @@
"_variable _noargs r" => "CONST unit_when\<cdot>r"
parse_translation {*
-(* rewrites (_pat x) => (return) *)
-(* rewrites (_variable x t) => (Abs_CFun (%x. t)) *)
- [("_pat", K (Syntax.const "Fixrec.return")),
- mk_binder_tr ("_variable", "Abs_CFun")];
+(* rewrite (_pat x) => (return) *)
+(* rewrite (_variable x t) => (Abs_CFun (%x. t)) *)
+ [(@{syntax_const "_pat"}, fn _ => Syntax.const @{const_syntax Fixrec.return}),
+ mk_binder_tr (@{syntax_const "_variable"}, @{const_syntax Abs_CFun})];
*}
text {* Printing Case expressions *}
@@ -240,23 +240,26 @@
print_translation {*
let
fun dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax unit_when},_) $ t) =
- (Syntax.const "_noargs", t)
+ (Syntax.const @{syntax_const "_noargs"}, t)
| dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax csplit},_) $ t) =
let
val (v1, t1) = dest_LAM t;
val (v2, t2) = dest_LAM t1;
- in (Syntax.const "_args" $ v1 $ v2, t2) end
+ in (Syntax.const @{syntax_const "_args"} $ v1 $ v2, t2) end
| dest_LAM (Const (@{const_syntax Abs_CFun},_) $ t) =
let
- val abs = case t of Abs abs => abs
+ val abs =
+ case t of Abs abs => abs
| _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0);
val (x, t') = atomic_abs_tr' abs;
- in (Syntax.const "_variable" $ x, t') end
+ in (Syntax.const @{syntax_const "_variable"} $ x, t') end
| dest_LAM _ = raise Match; (* too few vars: abort translation *)
fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] =
- let val (v, t) = dest_LAM r;
- in Syntax.const "_Case1" $ (Syntax.const "_match" $ p $ v) $ t end;
+ let val (v, t) = dest_LAM r in
+ Syntax.const @{syntax_const "_Case1"} $
+ (Syntax.const @{syntax_const "_match"} $ p $ v) $ t
+ end;
in [(@{const_syntax Rep_CFun}, Case1_tr')] end;
*}
--- a/src/HOLCF/IMP/Denotational.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IMP/Denotational.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IMP/Denotational.thy
- ID: $Id$
Author: Tobias Nipkow and Robert Sandner, TUM
Copyright 1996 TUM
*)
--- a/src/HOLCF/IMP/HoareEx.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IMP/HoareEx.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IMP/HoareEx.thy
- ID: $Id$
Author: Tobias Nipkow, TUM
Copyright 1997 TUM
*)
--- a/src/HOLCF/IMP/README.html Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IMP/README.html Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,5 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
-<!-- $Id$ -->
-
<HTML>
<HEAD>
--- a/src/HOLCF/IMP/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IMP/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,3 +1,1 @@
-(* $Id$ *)
-
use_thys ["HoareEx"];
--- a/src/HOLCF/IOA/ABP/Abschannel.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Abschannel.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Abschannel.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Abschannel_finite.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Abschannel_finite.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Abschannels.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Action.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Action.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Action.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Check.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Check.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Check.ML
- ID: $Id$
Author: Olaf Mueller
The Model Checker.
--- a/src/HOLCF/IOA/ABP/Correctness.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Correctness.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Correctness.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -58,10 +57,12 @@
and impl_asigs = sender_asig_def receiver_asig_def
declare let_weak_cong [cong]
-declare Let_def [simp] ioa_triple_proj [simp] starts_of_par [simp]
+declare ioa_triple_proj [simp] starts_of_par [simp]
lemmas env_ioas = env_ioa_def env_asig_def env_trans_def
-lemmas hom_ioas [simp] = env_ioas impl_ioas impl_trans impl_asigs asig_projections set_lemmas
+lemmas hom_ioas =
+ env_ioas [simp] impl_ioas [simp] impl_trans [simp] impl_asigs [simp]
+ asig_projections set_lemmas
subsection {* lemmas about reduce *}
@@ -97,7 +98,7 @@
apply (induct_tac "l")
apply (simp (no_asm))
apply (case_tac "list=[]")
- apply (simp add: reverse.simps)
+ apply simp
apply (rule impI)
apply (simp (no_asm))
apply (cut_tac l = "list" in cons_not_nil)
--- a/src/HOLCF/IOA/ABP/Env.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Env.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Impl.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Impl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Impl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Impl.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Impl_finite.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Impl_finite.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Impl.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Lemmas.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Lemmas.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Lemmas.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Packet.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Packet.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Packet.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Receiver.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Receiver.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Receiver.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Sender.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Sender.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Sender.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/ABP/Spec.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/ABP/Spec.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Spec.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/Modelcheck/Cockpit.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Modelcheck/Cockpit.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,6 +1,3 @@
-
-(* $Id$ *)
-
theory Cockpit
imports MuIOAOracle
begin
--- a/src/HOLCF/IOA/Modelcheck/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Modelcheck/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/Modelcheck/ROOT.ML
- ID: $Id$
Author: Olaf Mueller and Tobias Hamberger, TU Muenchen
Modelchecker setup for I/O automata.
--- a/src/HOLCF/IOA/NTP/Abschannel.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Abschannel.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Abschannel.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/NTP/Action.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Action.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Action.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Correctness.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Correctness.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Correctness.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
@@ -51,7 +50,7 @@
apply (simp (no_asm) add: impl_ioas)
apply (simp (no_asm) add: impl_asigs)
apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
- apply (simp (no_asm) add: "transitions" unfold_renaming)
+ apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
txt {* 1 *}
apply (simp (no_asm) add: impl_ioas)
apply (simp (no_asm) add: impl_asigs)
--- a/src/HOLCF/IOA/NTP/Impl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Impl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Impl.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
@@ -62,7 +61,7 @@
subsection {* Invariants *}
-declare Let_def [simp] le_SucI [simp]
+declare le_SucI [simp]
lemmas impl_ioas =
impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
--- a/src/HOLCF/IOA/NTP/Lemmas.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Lemmas.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Lemmas.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Multiset.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Multiset.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Multiset.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Packet.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Packet.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Packet.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Receiver.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Receiver.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Receiver.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Sender.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Sender.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Sender.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/NTP/Spec.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/NTP/Spec.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/NTP/Spec.thy
- ID: $Id$
Author: Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/README.html Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/README.html Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,5 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
-<!-- $Id$ -->
-
<HTML>
<HEAD>
--- a/src/HOLCF/IOA/Storage/Action.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Storage/Action.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/ABP/Action.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/Storage/Correctness.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Storage/Correctness.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/example/Correctness.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -19,7 +18,6 @@
in
(! l:used. l < k) & b=c}"
-declare split_paired_All [simp]
declare split_paired_Ex [simp del]
--- a/src/HOLCF/IOA/Storage/Impl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Storage/Impl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/example/Spec.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/Storage/Spec.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/Storage/Spec.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/example/Spec.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/Asig.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Asig.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/IOA/meta_theory/Asig.thy
- ID: $Id$
Author: Olaf Müller, Tobias Nipkow & Konrad Slind
*)
--- a/src/HOLCF/IOA/meta_theory/Automata.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Automata.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Automata.thy
- ID: $Id$
Author: Olaf Müller, Konrad Slind, Tobias Nipkow
*)
--- a/src/HOLCF/IOA/meta_theory/CompoExecs.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/CompoExecs.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/CompoExecs.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -63,7 +62,7 @@
asig_comp sigA sigB))"
-lemmas [simp del] = ex_simps all_simps split_paired_All
+lemmas [simp del] = split_paired_All
section "recursive equations of operators"
--- a/src/HOLCF/IOA/meta_theory/CompoScheds.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/CompoScheds.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/CompoScheds.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -65,9 +64,6 @@
asig_comp sigA sigB))"
-declare surjective_pairing [symmetric, simp]
-
-
subsection "mkex rewrite rules"
--- a/src/HOLCF/IOA/meta_theory/CompoTraces.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/CompoTraces.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/CompoTraces.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -208,18 +207,18 @@
(* a:A, a:B *)
apply simp
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
(* a:A,a~:B *)
apply simp
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
apply (case_tac "a:act B")
(* a~:A, a:B *)
apply simp
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
(* a~:A,a~:B *)
apply auto
done
@@ -231,7 +230,7 @@
[@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
apply auto
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
done
lemma ForallAnBmksch [rule_format (no_asm)]: "!!A B. compatible A B ==>
@@ -241,7 +240,7 @@
[@{thm Forall_def}, @{thm sforall_def}, @{thm mksch_def}] 1 *})
apply auto
apply (rule Forall_Conc_impl [THEN mp])
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act)
+apply (simp add: intA_is_not_actB int_is_act)
done
(* safe-tac makes too many case distinctions with this lemma in the next proof *)
@@ -346,14 +345,12 @@
apply (rule_tac x = "Takewhile (%a. a:int B) $y @@ a>>y1" in exI)
apply (rule_tac x = "y2" in exI)
(* elminate all obligations up to two depending on Conc_assoc *)
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act int_is_not_ext FilterConc)
+apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
apply (simp (no_asm) add: Conc_assoc FilterConc)
done
lemmas reduceA_mksch = conjI [THEN [6] conjI [THEN [5] reduceA_mksch1]]
-declare FilterConc [simp del]
-
lemma reduceB_mksch1 [rule_format]:
" [| Finite a_s; is_asig(asig_of A); is_asig(asig_of B);compatible A B|] ==>
! x. Forall (%x. x:act A) x & Forall (%x. x:act A & x~:act B) a_s &
@@ -394,7 +391,7 @@
apply (rule_tac x = "Takewhile (%a. a:int A) $x @@ a>>x1" in exI)
apply (rule_tac x = "x2" in exI)
(* elminate all obligations up to two depending on Conc_assoc *)
-apply (simp add: ForallPTakewhileQ intA_is_not_actB int_is_act int_is_not_ext FilterConc)
+apply (simp add: intA_is_not_actB int_is_act int_is_not_ext FilterConc)
apply (simp (no_asm) add: Conc_assoc FilterConc)
done
@@ -574,7 +571,7 @@
apply (rule take_reduction)
(* f A (tw iA) = tw ~eA *)
-apply (simp add: FilterPTakewhileQid int_is_act not_ext_is_int_or_not_act)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
apply (rule refl)
apply (simp add: int_is_act not_ext_is_int_or_not_act)
apply (rotate_tac -11)
@@ -583,7 +580,7 @@
(* assumption Forall tr *)
(* assumption schB *)
-apply (simp add: Forall_Conc ext_and_act)
+apply (simp add: ext_and_act)
(* assumption schA *)
apply (drule_tac x = "schA" and g = "Filter (%a. a:act A) $rs" in subst_lemma2)
apply assumption
@@ -596,7 +593,7 @@
(* assumption Forall schA *)
apply (drule_tac s = "schA" and P = "Forall (%x. x:act A) " in subst)
apply assumption
-apply (simp add: ForallPTakewhileQ int_is_act)
+apply (simp add: int_is_act)
(* case x:actions(asig_of A) & x: actions(asig_of B) *)
@@ -624,7 +621,7 @@
apply assumption
(* f A (tw iA) = tw ~eA *)
-apply (simp add: FilterPTakewhileQid int_is_act not_ext_is_int_or_not_act)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
(* rewrite assumption forall and schB *)
apply (rotate_tac 13)
@@ -793,7 +790,7 @@
apply (rule take_reduction)
(* f B (tw iB) = tw ~eB *)
-apply (simp add: FilterPTakewhileQid int_is_act not_ext_is_int_or_not_act)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
apply (rule refl)
apply (simp add: int_is_act not_ext_is_int_or_not_act)
apply (rotate_tac -11)
@@ -801,7 +798,7 @@
(* now conclusion fulfills induction hypothesis, but assumptions are not ready *)
(* assumption schA *)
-apply (simp add: Forall_Conc ext_and_act)
+apply (simp add: ext_and_act)
(* assumption schB *)
apply (drule_tac x = "schB" and g = "Filter (%a. a:act B) $rs" in subst_lemma2)
apply assumption
@@ -814,7 +811,7 @@
(* assumption Forall schB *)
apply (drule_tac s = "schB" and P = "Forall (%x. x:act B) " in subst)
apply assumption
-apply (simp add: ForallPTakewhileQ int_is_act)
+apply (simp add: int_is_act)
(* case x:actions(asig_of A) & x: actions(asig_of B) *)
@@ -841,7 +838,7 @@
apply assumption
(* f B (tw iB) = tw ~eB *)
-apply (simp add: FilterPTakewhileQid int_is_act not_ext_is_int_or_not_act)
+apply (simp add: int_is_act not_ext_is_int_or_not_act)
(* rewrite assumption forall and schB *)
apply (rotate_tac 13)
--- a/src/HOLCF/IOA/meta_theory/Compositionality.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Compositionality.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Compositionality.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/Deadlock.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Deadlock.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Deadlock.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/IOA.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/IOA.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/IOA.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/LiveIOA.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/LiveIOA.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/LiveIOA.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -44,8 +43,6 @@
((corresp_ex (fst AM) f exec) |== (snd AM))))"
-declare split_paired_Ex [simp del]
-
lemma live_implements_trans:
"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
==> live_implements (A,LA) (C,LC)"
--- a/src/HOLCF/IOA/meta_theory/Pred.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Pred.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Pred.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/RefCorrectness.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/RefCorrectness.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/RefCorrectness.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -166,7 +165,7 @@
(* --------------------------------------------------- *)
lemma mk_traceConc: "mk_trace C$(ex1 @@ ex2)= (mk_trace C$ex1) @@ (mk_trace C$ex2)"
-apply (simp add: mk_trace_def filter_act_def FilterConc MapConc)
+apply (simp add: mk_trace_def filter_act_def MapConc)
done
--- a/src/HOLCF/IOA/meta_theory/RefMappings.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/RefMappings.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/RefMappings.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/Seq.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Seq.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Seq.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -111,7 +110,6 @@
declare Finite.intros [simp]
-declare seq.rews [simp]
subsection {* recursive equations of operators *}
@@ -362,7 +360,7 @@
lemma scons_inject_eq:
"[|x~=UU;y~=UU|]==> (x##xs=y##ys) = (x=y & xs=ys)"
-by (simp add: seq.injects)
+by simp
lemma nil_less_is_nil: "nil<<x ==> nil=x"
apply (rule_tac x="x" in seq.casedist)
@@ -448,7 +446,7 @@
apply (intro strip)
apply (erule Finite.cases)
apply fastsimp
-apply (simp add: seq.injects)
+apply simp
done
lemma Finite_cons: "a~=UU ==>(Finite (a##x)) = (Finite x)"
@@ -462,7 +460,7 @@
apply (induct arbitrary: y set: Finite)
apply (rule_tac x=y in seq.casedist, simp, simp, simp)
apply (rule_tac x=y in seq.casedist, simp, simp)
-apply (simp add: seq.inverts)
+apply simp
done
lemma adm_Finite [simp]: "adm Finite"
--- a/src/HOLCF/IOA/meta_theory/Sequence.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Sequence.thy Fri Feb 19 15:21:57 2010 +0000
@@ -300,14 +300,11 @@
done
lemma Cons_not_less_nil: "~a>>s << nil"
-apply (subst Consq_def2)
-apply (rule seq.rews)
-apply (rule Def_not_UU)
+apply (simp add: Consq_def2)
done
lemma Cons_not_nil: "a>>s ~= nil"
-apply (subst Consq_def2)
-apply (rule seq.rews)
+apply (simp add: Consq_def2)
done
lemma Cons_not_nil2: "nil ~= a>>s"
--- a/src/HOLCF/IOA/meta_theory/ShortExecutions.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/ShortExecutions.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/ShortExecutions.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/SimCorrectness.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/SimCorrectness.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/SimCorrectness.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/Simulations.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/Simulations.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/Simulations.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/TL.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/TL.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/TLS.thy
- ID: $Id$
Author: Olaf Müller
*)
--- a/src/HOLCF/IOA/meta_theory/TLS.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IOA/meta_theory/TLS.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/IOA/meta_theory/TLS.thy
- ID: $Id$
Author: Olaf Müller
*)
@@ -88,7 +87,6 @@
lemmas [simp del] = ex_simps all_simps split_paired_Ex
-declare Let_def [simp]
declaration {* fn _ => Classical.map_cs (fn cs => cs delSWrapper "split_all_tac") *}
--- a/src/HOLCF/IsaMakefile Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/IsaMakefile Fri Feb 19 15:21:57 2010 +0000
@@ -95,6 +95,7 @@
ex/Dagstuhl.thy \
ex/Dnat.thy \
ex/Domain_ex.thy \
+ ex/Domain_Proofs.thy \
ex/Fix2.thy \
ex/Fixrec_ex.thy \
ex/Focus_ex.thy \
@@ -103,6 +104,7 @@
ex/New_Domain.thy \
ex/Powerdomain_ex.thy \
ex/Stream.thy \
+ ex/Strict_Fun.thy \
ex/ROOT.ML
@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
@@ -111,7 +113,9 @@
HOLCF-FOCUS: HOLCF $(LOG)/HOLCF-FOCUS.gz
-$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF FOCUS/Fstreams.thy \
+$(LOG)/HOLCF-FOCUS.gz: $(OUT)/HOLCF \
+ ex/Stream.thy \
+ FOCUS/Fstreams.thy \
FOCUS/Fstream.thy FOCUS/FOCUS.thy \
FOCUS/Stream_adm.thy ../HOL/Library/Continuity.thy \
FOCUS/Buffer.thy FOCUS/Buffer_adm.thy
--- a/src/HOLCF/README.html Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/README.html Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,5 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
-<!-- $Id$ -->
-
<html>
<head>
--- a/src/HOLCF/Sprod.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Sprod.thy Fri Feb 19 15:21:57 2010 +0000
@@ -51,7 +51,7 @@
"ssplit = (\<Lambda> f. strictify\<cdot>(\<Lambda> p. f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"
syntax
- "@stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
+ "_stuple" :: "['a, args] => 'a ** 'b" ("(1'(:_,/ _:'))")
translations
"(:x, y, z:)" == "(:x, (:y, z:):)"
"(:x, y:)" == "CONST spair\<cdot>x\<cdot>y"
--- a/src/HOLCF/Tools/Domain/domain_extender.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/Domain/domain_extender.ML Fri Feb 19 15:21:57 2010 +0000
@@ -160,7 +160,7 @@
| typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id)))
| typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
fun one_con (con,args,mx) =
- ((Syntax.const_name mx (Binding.name_of con)),
+ (Binding.name_of con, (* FIXME preverse binding (!?) *)
ListPair.map (fn ((lazy,sel,tp),vn) =>
mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp),
Option.map Binding.name_of sel,vn))
@@ -235,7 +235,7 @@
| typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id)))
| typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
fun one_con (con,args,mx) =
- ((Syntax.const_name mx (Binding.name_of con)),
+ (Binding.name_of con, (* FIXME preverse binding (!?) *)
ListPair.map (fn ((lazy,sel,tp),vn) =>
mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp),
Option.map Binding.name_of sel,vn))
--- a/src/HOLCF/Tools/Domain/domain_isomorphism.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/Domain/domain_isomorphism.ML Fri Feb 19 15:21:57 2010 +0000
@@ -251,7 +251,7 @@
(* register unfold theorems *)
val (unfold_thms, thy) =
- (PureThy.add_thms o map (Thm.no_attributes o apsnd Drule.standard))
+ (PureThy.add_thms o map (Thm.no_attributes o apsnd Drule.export_without_context))
(mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
in
((proj_thms, unfold_thms), thy)
@@ -446,7 +446,7 @@
(* prove isomorphism and isodefl rules *)
fun mk_iso_thms ((tbind, REP_eq), (rep_def, abs_def)) thy =
let
- fun make thm = Drule.standard (thm OF [REP_eq, abs_def, rep_def]);
+ fun make thm = Drule.export_without_context (thm OF [REP_eq, abs_def, rep_def]);
val rep_iso_thm = make @{thm domain_rep_iso};
val abs_iso_thm = make @{thm domain_abs_iso};
val isodefl_thm = make @{thm isodefl_abs_rep};
@@ -545,7 +545,7 @@
val thmR = thm RS @{thm conjunct2};
in (n, thmL):: conjuncts ns thmR end;
val (isodefl_thms, thy) = thy |>
- (PureThy.add_thms o map (Thm.no_attributes o apsnd Drule.standard))
+ (PureThy.add_thms o map (Thm.no_attributes o apsnd Drule.export_without_context))
(conjuncts isodefl_binds isodefl_thm);
val thy = IsodeflData.map (fold Thm.add_thm isodefl_thms) thy;
--- a/src/HOLCF/Tools/Domain/domain_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/Domain/domain_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -28,7 +28,7 @@
open Domain_Library;
infixr 5 -->; infixr 6 ->>;
-fun calc_syntax
+fun calc_syntax (* FIXME authentic syntax *)
(definitional : bool)
(dtypeprod : typ)
((dname : string, typevars : typ list),
@@ -115,7 +115,7 @@
local open Syntax in
local
- fun c_ast con mx = Constant (Syntax.const_name mx (Binding.name_of con));
+ fun c_ast con mx = Constant (Binding.name_of con); (* FIXME proper const syntax *)
fun expvar n = Variable ("e"^(string_of_int n));
fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
(string_of_int m));
--- a/src/HOLCF/Tools/Domain/domain_theorems.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/Domain/domain_theorems.ML Fri Feb 19 15:21:57 2010 +0000
@@ -180,7 +180,7 @@
val rep_strict = ax_abs_iso RS (allI RS retraction_strict);
val abs_defin' = iso_locale RS iso_abs_defin';
val rep_defin' = iso_locale RS iso_rep_defin';
-val iso_rews = map Drule.standard [ax_abs_iso,ax_rep_iso,abs_strict,rep_strict];
+val iso_rews = map Drule.export_without_context [ax_abs_iso, ax_rep_iso, abs_strict, rep_strict];
(* ----- generating beta reduction rules from definitions-------------------- *)
@@ -263,7 +263,7 @@
val exhaust = pg con_appls (mk_trp exh) (K tacs);
val _ = trace " Proving casedist...";
val casedist =
- Drule.standard (rewrite_rule exh_casedists (exhaust RS exh_casedist0));
+ Drule.export_without_context (rewrite_rule exh_casedists (exhaust RS exh_casedist0));
end;
local
@@ -512,18 +512,19 @@
val sel_rews = sel_stricts @ sel_defins @ sel_apps;
val _ = trace " Proving dist_les...";
-val distincts_le =
+val dist_les =
let
fun dist (con1, args1) (con2, args2) =
let
- val goal = lift_defined %: (nonlazy args1,
- mk_trp (con_app con1 args1 ~<< con_app con2 args2));
- fun tacs ctxt = [
- rtac @{thm rev_contrapos} 1,
- eres_inst_tac ctxt [(("f", 0), dis_name con1)] monofun_cfun_arg 1]
- @ map (case_UU_tac ctxt (con_stricts @ dis_rews) 1) (nonlazy args2)
- @ [asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
- in pg [] goal tacs end;
+ fun iff_disj (t, []) = HOLogic.mk_not t
+ | iff_disj (t, ts) = t === foldr1 HOLogic.mk_disj ts;
+ val lhs = con_app con1 args1 << con_app con2 args2;
+ val rhss = map (fn x => %:x === UU) (nonlazy args1);
+ val goal = mk_trp (iff_disj (lhs, rhss));
+ val rule1 = iso_locale RS @{thm iso.abs_below};
+ val rules = rule1 :: @{thms con_below_iff_rules};
+ val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+ in pg con_appls goal (K tacs) end;
fun distinct (con1, args1) (con2, args2) =
let
@@ -533,28 +534,40 @@
(args2, Name.variant_list (map vname args1) (map vname args2)));
in [dist arg1 arg2, dist arg2 arg1] end;
fun distincts [] = []
- | distincts (c::cs) = (map (distinct c) cs) :: distincts cs;
+ | distincts (c::cs) = maps (distinct c) cs @ distincts cs;
in distincts cons end;
-val dist_les = flat (flat distincts_le);
val _ = trace " Proving dist_eqs...";
val dist_eqs =
let
- fun distinct (_,args1) ((_,args2), leqs) =
+ fun dist (con1, args1) (con2, args2) =
let
- val (le1,le2) = (hd leqs, hd(tl leqs));
- val (eq1,eq2) = (le1 RS dist_eqI, le2 RS dist_eqI)
- in
- if nonlazy args1 = [] then [eq1, eq1 RS not_sym] else
- if nonlazy args2 = [] then [eq2, eq2 RS not_sym] else
- [eq1, eq2]
- end;
+ fun iff_disj (t, [], us) = HOLogic.mk_not t
+ | iff_disj (t, ts, []) = HOLogic.mk_not t
+ | iff_disj (t, ts, us) =
+ let
+ val disj1 = foldr1 HOLogic.mk_disj ts;
+ val disj2 = foldr1 HOLogic.mk_disj us;
+ in t === HOLogic.mk_conj (disj1, disj2) end;
+ val lhs = con_app con1 args1 === con_app con2 args2;
+ val rhss1 = map (fn x => %:x === UU) (nonlazy args1);
+ val rhss2 = map (fn x => %:x === UU) (nonlazy args2);
+ val goal = mk_trp (iff_disj (lhs, rhss1, rhss2));
+ val rule1 = iso_locale RS @{thm iso.abs_eq};
+ val rules = rule1 :: @{thms con_eq_iff_rules};
+ val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+ in pg con_appls goal (K tacs) end;
+
+ fun distinct (con1, args1) (con2, args2) =
+ let
+ val arg1 = (con1, args1);
+ val arg2 =
+ (con2, ListPair.map (fn (arg,vn) => upd_vname (K vn) arg)
+ (args2, Name.variant_list (map vname args1) (map vname args2)));
+ in [dist arg1 arg2, dist arg2 arg1] end;
fun distincts [] = []
- | distincts ((c,leqs)::cs) =
- flat
- (ListPair.map (distinct c) ((map #1 cs),leqs)) @
- distincts cs;
- in map Drule.standard (distincts (cons ~~ distincts_le)) end;
+ | distincts (c::cs) = maps (distinct c) cs @ distincts cs;
+ in distincts cons end;
local
fun pgterm rel con args =
@@ -593,7 +606,12 @@
val goal = mk_trp (strict (dc_copy `% "f"));
val rules = [abs_strict, rep_strict] @ @{thms domain_map_stricts};
val tacs = [asm_simp_tac (HOLCF_ss addsimps rules) 1];
- in pg [ax_copy_def] goal (K tacs) end;
+ in
+ SOME (pg [ax_copy_def] goal (K tacs))
+ handle
+ THM (s, _, _) => (trace s; NONE)
+ | ERROR s => (trace s; NONE)
+ end;
local
fun copy_app (con, args) =
@@ -605,6 +623,9 @@
(proj (%:"f") eqs) (dtyp_of arg) ` (%# arg)
else (%# arg);
val rhs = con_app2 con one_rhs args;
+ fun is_rec arg = Datatype_Aux.is_rec_type (dtyp_of arg);
+ fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
+ fun nonlazy_rec args = map vname (filter is_nonlazy_rec args);
val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
val args' = filter_out (fn a => is_rec a orelse is_lazy a) args;
val stricts = abs_strict :: rep_strict :: @{thms domain_map_stricts};
@@ -621,18 +642,23 @@
fun one_strict (con, args) =
let
val goal = mk_trp (dc_copy`UU`(con_app con args) === UU);
- val rews = copy_strict :: copy_apps @ con_rews;
+ val rews = the_list copy_strict @ copy_apps @ con_rews;
fun tacs ctxt = map (case_UU_tac ctxt rews 1) (nonlazy args) @
[asm_simp_tac (HOLCF_ss addsimps rews) 1];
- in pg [] goal tacs end;
+ in
+ SOME (pg [] goal tacs)
+ handle
+ THM (s, _, _) => (trace s; NONE)
+ | ERROR s => (trace s; NONE)
+ end;
fun has_nonlazy_rec (_, args) = exists is_nonlazy_rec args;
in
val _ = trace " Proving copy_stricts...";
- val copy_stricts = map one_strict (filter has_nonlazy_rec cons);
+ val copy_stricts = map_filter one_strict (filter has_nonlazy_rec cons);
end;
-val copy_rews = copy_strict :: copy_apps @ copy_stricts;
+val copy_rews = the_list copy_strict @ copy_apps @ copy_stricts;
in
thy
@@ -706,57 +732,48 @@
val copy_take_defs =
(if n_eqs = 1 then [] else [ax_copy2_def]) @ axs_take_def;
val _ = trace " Proving take_stricts...";
- val take_stricts =
+ fun one_take_strict ((dn, args), _) =
let
- fun one_eq ((dn, args), _) = strict (dc_take dn $ %:"n");
- val goal = mk_trp (foldr1 mk_conj (map one_eq eqs));
- fun tacs ctxt = [
- InductTacs.induct_tac ctxt [[SOME "n"]] 1,
- simp_tac iterate_Cprod_ss 1,
- asm_simp_tac (iterate_Cprod_ss addsimps copy_rews) 1];
- in pg copy_take_defs goal tacs end;
-
- val take_stricts' = rewrite_rule copy_take_defs take_stricts;
+ val goal = mk_trp (strict (dc_take dn $ %:"n"));
+ val rules = [
+ @{thm monofun_fst [THEN monofunE]},
+ @{thm monofun_snd [THEN monofunE]}];
+ val tacs = [
+ rtac @{thm UU_I} 1,
+ rtac @{thm below_eq_trans} 1,
+ resolve_tac axs_reach 2,
+ rtac @{thm monofun_cfun_fun} 1,
+ REPEAT (resolve_tac rules 1),
+ rtac @{thm iterate_below_fix} 1];
+ in pg axs_take_def goal (K tacs) end;
+ val take_stricts = map one_take_strict eqs;
fun take_0 n dn =
let
- val goal = mk_trp ((dc_take dn $ %%: @{const_name Algebras.zero}) `% x_name n === UU);
+ val goal = mk_trp ((dc_take dn $ @{term "0::nat"}) `% x_name n === UU);
in pg axs_take_def goal (K [simp_tac iterate_Cprod_ss 1]) end;
val take_0s = mapn take_0 1 dnames;
- fun c_UU_tac ctxt = case_UU_tac ctxt (take_stricts'::copy_con_rews) 1;
val _ = trace " Proving take_apps...";
- val take_apps =
+ fun one_take_app dn (con, args) =
let
- fun mk_eqn dn (con, args) =
- let
- fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
- fun one_rhs arg =
- if Datatype_Aux.is_rec_type (dtyp_of arg)
- then Domain_Axioms.copy_of_dtyp map_tab
- mk_take (dtyp_of arg) ` (%# arg)
- else (%# arg);
- val lhs = (dc_take dn $ (%%:"Suc" $ %:"n"))`(con_app con args);
- val rhs = con_app2 con one_rhs args;
- in Library.foldr mk_all (map vname args, lhs === rhs) end;
- fun mk_eqns ((dn, _), cons) = map (mk_eqn dn) cons;
- val goal = mk_trp (foldr1 mk_conj (maps mk_eqns eqs));
- val simps = filter (has_fewer_prems 1) copy_rews;
- fun con_tac ctxt (con, args) =
- if nonlazy_rec args = []
- then all_tac
- else EVERY (map (c_UU_tac ctxt) (nonlazy_rec args)) THEN
- asm_full_simp_tac (HOLCF_ss addsimps copy_rews) 1;
- fun eq_tacs ctxt ((dn, _), cons) = map (con_tac ctxt) cons;
- fun tacs ctxt =
- simp_tac iterate_Cprod_ss 1 ::
- InductTacs.induct_tac ctxt [[SOME "n"]] 1 ::
- simp_tac (iterate_Cprod_ss addsimps copy_con_rews) 1 ::
- asm_full_simp_tac (HOLCF_ss addsimps simps) 1 ::
- TRY (safe_tac HOL_cs) ::
- maps (eq_tacs ctxt) eqs;
- in pg copy_take_defs goal tacs end;
+ fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
+ fun one_rhs arg =
+ if Datatype_Aux.is_rec_type (dtyp_of arg)
+ then Domain_Axioms.copy_of_dtyp map_tab
+ mk_take (dtyp_of arg) ` (%# arg)
+ else (%# arg);
+ val lhs = (dc_take dn $ (%%:"Suc" $ %:"n"))`(con_app con args);
+ val rhs = con_app2 con one_rhs args;
+ fun is_rec arg = Datatype_Aux.is_rec_type (dtyp_of arg);
+ fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
+ fun nonlazy_rec args = map vname (filter is_nonlazy_rec args);
+ val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
+ val tacs = [asm_simp_tac (HOLCF_ss addsimps copy_con_rews) 1];
+ in pg copy_take_defs goal (K tacs) end;
+ fun one_take_apps ((dn, _), cons) = map (one_take_app dn) cons;
+ val take_apps = maps one_take_apps eqs;
in
- val take_rews = map Drule.standard
- (atomize global_ctxt take_stricts @ take_0s @ atomize global_ctxt take_apps);
+ val take_rews = map Drule.export_without_context
+ (take_stricts @ take_0s @ take_apps);
end; (* local *)
local
--- a/src/HOLCF/Tools/cont_consts.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/cont_consts.ML Fri Feb 19 15:21:57 2010 +0000
@@ -40,9 +40,9 @@
fold (fn arg => fn t => Syntax.mk_appl (Constant "Rep_CFun") [t, Variable arg])
vnames (Constant name1))] @
(case mx of
- InfixName _ => [extra_parse_rule]
- | InfixlName _ => [extra_parse_rule]
- | InfixrName _ => [extra_parse_rule]
+ Infix _ => [extra_parse_rule]
+ | Infixl _ => [extra_parse_rule]
+ | Infixr _ => [extra_parse_rule]
| _ => [])
end;
@@ -53,19 +53,8 @@
declaration with the original name, type ...=>..., and the original mixfix
is generated and connected to the other declaration via some translation.
*)
-fun const_binding mx = Binding.name o Syntax.const_name mx o Binding.name_of;
-
-fun fix_mixfix (syn , T, mx as Infix p ) =
- (const_binding mx syn, T, InfixName (Binding.name_of syn, p))
- | fix_mixfix (syn , T, mx as Infixl p ) =
- (const_binding mx syn, T, InfixlName (Binding.name_of syn, p))
- | fix_mixfix (syn , T, mx as Infixr p ) =
- (const_binding mx syn, T, InfixrName (Binding.name_of syn, p))
- | fix_mixfix decl = decl;
-
-fun transform decl =
+fun transform (c, T, mx) =
let
- val (c, T, mx) = fix_mixfix decl;
val c1 = Binding.name_of c;
val c2 = "_cont_" ^ c1;
val n = Syntax.mixfix_args mx
@@ -78,9 +67,9 @@
fun is_contconst (_,_,NoSyn ) = false
| is_contconst (_,_,Binder _) = false
-| is_contconst (c,T,mx ) = cfun_arity T >= Syntax.mixfix_args mx
- handle ERROR msg => cat_error msg ("in mixfix annotation for " ^
- quote (Syntax.const_name mx (Binding.name_of c)));
+| is_contconst (c,T,mx ) =
+ cfun_arity T >= Syntax.mixfix_args mx
+ handle ERROR msg => cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
(* add_consts(_i) *)
@@ -94,6 +83,7 @@
thy
|> Sign.add_consts_i
(normal_decls @ map first transformed_decls @ map second transformed_decls)
+ (* FIXME authentic syntax *)
|> Sign.add_trrules_i (maps third transformed_decls)
end;
--- a/src/HOLCF/Tools/pcpodef.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/pcpodef.ML Fri Feb 19 15:21:57 2010 +0000
@@ -89,7 +89,7 @@
(Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1);
(* transfer thms so that they will know about the new cpo instance *)
val cpo_thms' = map (Thm.transfer thy2) cpo_thms;
- fun make thm = Drule.standard (thm OF cpo_thms');
+ fun make thm = Drule.export_without_context (thm OF cpo_thms');
val ([adm, cont_Rep, cont_Abs, lub, thelub, compact], thy3) =
thy2
|> Sign.add_path (Binding.name_of name)
@@ -100,7 +100,7 @@
((Binding.prefix_name "lub_" name, make @{thm typedef_lub}), []),
((Binding.prefix_name "thelub_" name, make @{thm typedef_thelub}), []),
((Binding.prefix_name "compact_" name, make @{thm typedef_compact}), [])])
- ||> Sign.parent_path;
+ ||> Sign.restore_naming thy2;
val cpo_info : cpo_info =
{ below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
cont_Abs = cont_Abs, lub = lub, thelub = thelub, compact = compact };
@@ -127,7 +127,7 @@
|> AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo})
(Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1);
val pcpo_thms' = map (Thm.transfer thy2) pcpo_thms;
- fun make thm = Drule.standard (thm OF pcpo_thms');
+ fun make thm = Drule.export_without_context (thm OF pcpo_thms');
val ([Rep_strict, Abs_strict, Rep_strict_iff, Abs_strict_iff,
Rep_defined, Abs_defined], thy3) =
thy2
@@ -139,7 +139,7 @@
((Binding.suffix_name "_strict_iff" Abs_name, make @{thm typedef_Abs_strict_iff}), []),
((Binding.suffix_name "_defined" Rep_name, make @{thm typedef_Rep_defined}), []),
((Binding.suffix_name "_defined" Abs_name, make @{thm typedef_Abs_defined}), [])])
- ||> Sign.parent_path;
+ ||> Sign.restore_naming thy2;
val pcpo_info =
{ Rep_strict = Rep_strict, Abs_strict = Abs_strict,
Rep_strict_iff = Rep_strict_iff, Abs_strict_iff = Abs_strict_iff,
@@ -153,7 +153,7 @@
fun declare_type_name a =
Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
-fun prepare prep_term name (t, vs, mx) raw_set opt_morphs thy =
+fun prepare prep_term name (tname, vs, mx) raw_set opt_morphs thy =
let
val _ = Theory.requires thy "Pcpodef" "pcpodefs";
val ctxt = ProofContext.init thy;
@@ -168,7 +168,6 @@
(*lhs*)
val defS = Sign.defaultS thy;
val lhs_tfrees = map (fn v => (v, the_default defS (AList.lookup (op =) rhs_tfrees v))) vs;
- val tname = Binding.map_name (Syntax.type_name mx) t;
val full_tname = Sign.full_name thy tname;
val newT = Type (full_tname, map TFree lhs_tfrees);
@@ -346,7 +345,7 @@
fun mk_pcpodef_proof pcpo ((((((def, opt_name), (vs, t)), mx), A), morphs)) =
(if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
- ((def, the_default (Binding.map_name (Syntax.type_name mx) t) opt_name), (t, vs, mx), A, morphs);
+ ((def, the_default t opt_name), (t, vs, mx), A, morphs);
val _ =
OuterSyntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)" K.thy_goal
--- a/src/HOLCF/Tools/repdef.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/Tools/repdef.ML Fri Feb 19 15:21:57 2010 +0000
@@ -59,7 +59,7 @@
(prep_term: Proof.context -> 'a -> term)
(def: bool)
(name: binding)
- (typ as (t, vs, mx) : binding * string list * mixfix)
+ (typ as (tname, vs, mx) : binding * string list * mixfix)
(raw_defl: 'a)
(opt_morphs: (binding * binding) option)
(thy: theory)
@@ -79,7 +79,6 @@
val defS = Sign.defaultS thy;
val lhs_tfrees = map (fn v => (v, the_default defS (AList.lookup (op =) rhs_tfrees v))) vs;
val lhs_sorts = map snd lhs_tfrees;
- val tname = Binding.map_name (Syntax.type_name mx) t;
val full_tname = Sign.full_name thy tname;
val newT = Type (full_tname, map TFree lhs_tfrees);
@@ -139,8 +138,8 @@
|> Sign.add_path (Binding.name_of name)
|> PureThy.add_thms
[((Binding.prefix_name "REP_" name,
- Drule.standard (@{thm typedef_REP} OF typedef_thms')), [])]
- ||> Sign.parent_path;
+ Drule.export_without_context (@{thm typedef_REP} OF typedef_thms')), [])]
+ ||> Sign.restore_naming thy4;
val rep_info =
{ emb_def = emb_def, prj_def = prj_def, approx_def = approx_def, REP = REP_thm };
@@ -172,8 +171,7 @@
Scan.option (P.$$$ "morphisms" |-- P.!!! (P.binding -- P.binding));
fun mk_repdef ((((((def, opt_name), (vs, t)), mx), A), morphs)) =
- repdef_cmd
- ((def, the_default (Binding.map_name (Syntax.type_name mx) t) opt_name), (t, vs, mx), A, morphs);
+ repdef_cmd ((def, the_default t opt_name), (t, vs, mx), A, morphs);
val _ =
OuterSyntax.command "repdef" "HOLCF definition of representable domains" K.thy_decl
--- a/src/HOLCF/ex/Dagstuhl.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Dagstuhl.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,3 @@
-(* $Id$ *)
-
theory Dagstuhl
imports Stream
begin
@@ -56,10 +54,10 @@
lemma wir_moel: "YS = YYS"
apply (rule stream.take_lemmas)
apply (induct_tac n)
- apply (simp (no_asm) add: stream.rews)
+ apply (simp (no_asm))
apply (subst YS_def2)
apply (subst YYS_def2)
- apply (simp add: stream.rews)
+ apply simp
apply (rule lemma5 [symmetric, THEN subst])
apply (rule refl)
done
--- a/src/HOLCF/ex/Dnat.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Dnat.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/Dnat.thy
- ID: $Id$
Author: Franz Regensburger
Theory for the domain of natural numbers dnat = one ++ dnat
@@ -34,18 +33,18 @@
lemma iterator1: "iterator $ UU $ f $ x = UU"
apply (subst iterator_def2)
- apply (simp add: dnat.rews)
+ apply simp
done
lemma iterator2: "iterator $ dzero $ f $ x = x"
apply (subst iterator_def2)
- apply (simp add: dnat.rews)
+ apply simp
done
lemma iterator3: "n ~= UU ==> iterator $ (dsucc $ n) $ f $ x = f $ (iterator $ n $ f $ x)"
apply (rule trans)
apply (subst iterator_def2)
- apply (simp add: dnat.rews)
+ apply simp
apply (rule refl)
done
@@ -59,13 +58,13 @@
apply (rule_tac x = y in dnat.casedist)
apply simp
apply simp
- apply (simp add: dnat.dist_les)
+ apply simp
apply (rule allI)
apply (rule_tac x = y in dnat.casedist)
apply (fast intro!: UU_I)
apply (thin_tac "ALL y. d << y --> d = UU | d = y")
- apply (simp add: dnat.dist_les)
- apply (simp (no_asm_simp) add: dnat.rews dnat.injects dnat.inverts)
+ apply simp
+ apply (simp (no_asm_simp))
apply (drule_tac x="da" in spec)
apply simp
done
--- a/src/HOLCF/ex/Fix2.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Fix2.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/ex/Fix2.thy
- ID: $Id$
Author: Franz Regensburger
Show that fix is the unique least fixed-point operator.
--- a/src/HOLCF/ex/Focus_ex.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Focus_ex.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,3 @@
-(* $Id$ *)
-
(* Specification of the following loop back device
--- a/src/HOLCF/ex/Hoare.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Hoare.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/ex/hoare.thy
- ID: $Id$
Author: Franz Regensburger
Theory for an example by C.A.R. Hoare
--- a/src/HOLCF/ex/Loop.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Loop.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/ex/Loop.thy
- ID: $Id$
Author: Franz Regensburger
*)
@@ -115,7 +114,7 @@
and t = "g$ (iterate n$ (step$b$g) $x) " in ssubst)
prefer 2 apply (assumption)
apply (simp add: step_def2)
-apply (simp del: iterate_Suc add: loop_lemma2)
+apply (drule (1) loop_lemma2, simp)
done
lemma loop_lemma4 [rule_format]:
--- a/src/HOLCF/ex/Powerdomain_ex.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Powerdomain_ex.thy Fri Feb 19 15:21:57 2010 +0000
@@ -14,8 +14,6 @@
domain ordering = LT | EQ | GT
-declare ordering.rews [simp]
-
definition
compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
"compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
--- a/src/HOLCF/ex/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -5,4 +5,5 @@
use_thys ["Dnat", "Stream", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
"Loop", "Fixrec_ex", "Powerdomain_ex", "Domain_ex", "Domain_Proofs",
+ "Strict_Fun",
"New_Domain"];
--- a/src/HOLCF/ex/Stream.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/Stream.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: HOLCF/ex/Stream.thy
- ID: $Id$
Author: Franz Regensburger, David von Oheimb, Borislav Gajanovic
*)
@@ -54,8 +53,6 @@
| \<infinity> \<Rightarrow> s1)"
-declare stream.rews [simp add]
-
(* ----------------------------------------------------------------------- *)
(* theorems about scons *)
(* ----------------------------------------------------------------------- *)
@@ -149,13 +146,13 @@
apply (insert stream.reach [of s], erule subst) back
apply (simp add: fix_def2 stream.take_def)
apply (insert contlub_cfun_fun [of "%i. iterate i$stream_copy$UU" s,THEN sym])
-by (simp add: chain_iterate)
+by simp
lemma chain_stream_take: "chain (%i. stream_take i$s)"
apply (rule chainI)
apply (rule monofun_cfun_fun)
apply (simp add: stream.take_def del: iterate_Suc)
-by (rule chainE, simp add: chain_iterate)
+by (rule chainE, simp)
lemma stream_take_prefix [simp]: "stream_take n$s << s"
apply (insert stream_reach2 [of s])
@@ -361,8 +358,7 @@
by (drule stream_finite_lemma1,auto)
lemma slen_less_1_eq: "(#x < Fin (Suc 0)) = (x = \<bottom>)"
-by (rule stream.casedist [of x], auto simp del: iSuc_Fin
- simp add: Fin_0 iSuc_Fin[THEN sym] i0_iless_iSuc iSuc_mono)
+by (rule stream.casedist [of x], auto simp add: Fin_0 iSuc_Fin[THEN sym])
lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
by (rule stream.casedist [of x], auto)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/ex/Strict_Fun.thy Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,239 @@
+(* Title: HOLCF/ex/Strict_Fun.thy
+ Author: Brian Huffman
+*)
+
+header {* The Strict Function Type *}
+
+theory Strict_Fun
+imports HOLCF
+begin
+
+pcpodef (open) ('a, 'b) sfun (infixr "->!" 0)
+ = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
+by simp_all
+
+syntax (xsymbols)
+ sfun :: "type \<Rightarrow> type \<Rightarrow> type" (infixr "\<rightarrow>!" 0)
+
+text {* TODO: Define nice syntax for abstraction, application. *}
+
+definition
+ sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
+where
+ "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"
+
+definition
+ sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
+where
+ "sfun_rep = (\<Lambda> f. Rep_sfun f)"
+
+lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
+ unfolding sfun_rep_def by (simp add: cont_Rep_sfun)
+
+lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
+ unfolding sfun_rep_beta by (rule Rep_sfun_strict)
+
+lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
+ unfolding sfun_rep_beta by (rule Rep_sfun [simplified])
+
+lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
+ by (simp add: expand_cfun_eq strictify_conv_if)
+
+lemma sfun_abs_sfun_rep: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
+ unfolding sfun_abs_def sfun_rep_def
+ apply (simp add: cont_Abs_sfun cont_Rep_sfun)
+ apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
+ apply (simp add: expand_cfun_eq strictify_conv_if)
+ apply (simp add: Rep_sfun [simplified])
+ done
+
+lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
+ unfolding sfun_abs_def sfun_rep_def
+ apply (simp add: cont_Abs_sfun cont_Rep_sfun)
+ apply (simp add: Abs_sfun_inverse)
+ done
+
+lemma ep_pair_sfun: "ep_pair sfun_rep sfun_abs"
+apply default
+apply (rule sfun_abs_sfun_rep)
+apply (simp add: expand_cfun_below strictify_conv_if)
+done
+
+interpretation sfun: ep_pair sfun_rep sfun_abs
+ by (rule ep_pair_sfun)
+
+subsection {* Map functional for strict function space *}
+
+definition
+ sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
+where
+ "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"
+
+lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
+ unfolding sfun_map_def
+ by (simp add: cfun_map_ID expand_cfun_eq)
+
+lemma sfun_map_map:
+ assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>" shows
+ "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
+ sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
+unfolding sfun_map_def
+by (simp add: expand_cfun_eq strictify_cancel assms cfun_map_map)
+
+lemma ep_pair_sfun_map:
+ assumes 1: "ep_pair e1 p1"
+ assumes 2: "ep_pair e2 p2"
+ shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
+proof
+ interpret e1p1: pcpo_ep_pair e1 p1
+ unfolding pcpo_ep_pair_def by fact
+ interpret e2p2: pcpo_ep_pair e2 p2
+ unfolding pcpo_ep_pair_def by fact
+ fix f show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f"
+ unfolding sfun_map_def
+ apply (simp add: sfun.e_eq_iff [symmetric] strictify_cancel)
+ apply (rule ep_pair.e_inverse)
+ apply (rule ep_pair_cfun_map [OF 1 2])
+ done
+ fix g show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g"
+ unfolding sfun_map_def
+ apply (simp add: sfun.e_below_iff [symmetric] strictify_cancel)
+ apply (rule ep_pair.e_p_below)
+ apply (rule ep_pair_cfun_map [OF 1 2])
+ done
+qed
+
+lemma deflation_sfun_map:
+ assumes 1: "deflation d1"
+ assumes 2: "deflation d2"
+ shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
+apply (simp add: sfun_map_def)
+apply (rule deflation.intro)
+apply simp
+apply (subst strictify_cancel)
+apply (simp add: cfun_map_def deflation_strict 1 2)
+apply (simp add: cfun_map_def deflation.idem 1 2)
+apply (simp add: sfun.e_below_iff [symmetric])
+apply (subst strictify_cancel)
+apply (simp add: cfun_map_def deflation_strict 1 2)
+apply (rule deflation.below)
+apply (rule deflation_cfun_map [OF 1 2])
+done
+
+lemma finite_deflation_sfun_map:
+ assumes 1: "finite_deflation d1"
+ assumes 2: "finite_deflation d2"
+ shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
+proof (intro finite_deflation.intro finite_deflation_axioms.intro)
+ interpret d1: finite_deflation d1 by fact
+ interpret d2: finite_deflation d2 by fact
+ have "deflation d1" and "deflation d2" by fact+
+ thus "deflation (sfun_map\<cdot>d1\<cdot>d2)" by (rule deflation_sfun_map)
+ from 1 2 have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
+ by (rule finite_deflation_cfun_map)
+ then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
+ by (rule finite_deflation.finite_fixes)
+ moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
+ by (rule inj_onI, simp)
+ ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
+ by (rule finite_vimageI)
+ then show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
+ unfolding sfun_map_def sfun.e_eq_iff [symmetric]
+ by (simp add: strictify_cancel
+ deflation_strict `deflation d1` `deflation d2`)
+qed
+
+subsection {* Strict function space is bifinite *}
+
+instantiation sfun :: (bifinite, bifinite) bifinite
+begin
+
+definition
+ "approx = (\<lambda>i. sfun_map\<cdot>(approx i)\<cdot>(approx i))"
+
+instance proof
+ show "chain (approx :: nat \<Rightarrow> ('a \<rightarrow>! 'b) \<rightarrow> ('a \<rightarrow>! 'b))"
+ unfolding approx_sfun_def by simp
+next
+ fix x :: "'a \<rightarrow>! 'b"
+ show "(\<Squnion>i. approx i\<cdot>x) = x"
+ unfolding approx_sfun_def
+ by (simp add: lub_distribs sfun_map_ID [unfolded ID_def])
+next
+ fix i :: nat and x :: "'a \<rightarrow>! 'b"
+ show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
+ unfolding approx_sfun_def
+ by (intro deflation.idem deflation_sfun_map deflation_approx)
+next
+ fix i :: nat
+ show "finite {x::'a \<rightarrow>! 'b. approx i\<cdot>x = x}"
+ unfolding approx_sfun_def
+ by (intro finite_deflation.finite_fixes
+ finite_deflation_sfun_map
+ finite_deflation_approx)
+qed
+
+end
+
+subsection {* Strict function space is representable *}
+
+instantiation sfun :: (rep, rep) rep
+begin
+
+definition
+ "emb = udom_emb oo sfun_map\<cdot>prj\<cdot>emb"
+
+definition
+ "prj = sfun_map\<cdot>emb\<cdot>prj oo udom_prj"
+
+instance
+apply (default, unfold emb_sfun_def prj_sfun_def)
+apply (rule ep_pair_comp)
+apply (rule ep_pair_sfun_map)
+apply (rule ep_pair_emb_prj)
+apply (rule ep_pair_emb_prj)
+apply (rule ep_pair_udom)
+done
+
+end
+
+text {*
+ A deflation constructor lets us configure the domain package to work
+ with the strict function space type constructor.
+*}
+
+definition
+ sfun_defl :: "TypeRep \<rightarrow> TypeRep \<rightarrow> TypeRep"
+where
+ "sfun_defl = TypeRep_fun2 sfun_map"
+
+lemma cast_sfun_defl:
+ "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) = udom_emb oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo udom_prj"
+unfolding sfun_defl_def
+apply (rule cast_TypeRep_fun2)
+apply (erule (1) finite_deflation_sfun_map)
+done
+
+lemma REP_sfun: "REP('a::rep \<rightarrow>! 'b::rep) = sfun_defl\<cdot>REP('a)\<cdot>REP('b)"
+apply (rule cast_eq_imp_eq, rule ext_cfun)
+apply (simp add: cast_REP cast_sfun_defl)
+apply (simp only: prj_sfun_def emb_sfun_def)
+apply (simp add: sfun_map_def cfun_map_def strictify_cancel)
+done
+
+lemma isodefl_sfun:
+ "isodefl d1 t1 \<Longrightarrow> isodefl d2 t2 \<Longrightarrow>
+ isodefl (sfun_map\<cdot>d1\<cdot>d2) (sfun_defl\<cdot>t1\<cdot>t2)"
+apply (rule isodeflI)
+apply (simp add: cast_sfun_defl cast_isodefl)
+apply (simp add: emb_sfun_def prj_sfun_def)
+apply (simp add: sfun_map_map deflation_strict [OF isodefl_imp_deflation])
+done
+
+setup {*
+ Domain_Isomorphism.add_type_constructor
+ (@{type_name "sfun"}, @{term sfun_defl}, @{const_name sfun_map},
+ @{thm REP_sfun}, @{thm isodefl_sfun}, @{thm sfun_map_ID})
+*}
+
+end
--- a/src/HOLCF/ex/hoare.txt Fri Feb 05 17:19:25 2010 +0000
+++ b/src/HOLCF/ex/hoare.txt Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,3 @@
-(* $Id$ *)
-
Proves about loops and tail-recursive functions
===============================================
--- a/src/LCF/LCF.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/LCF/LCF.thy Fri Feb 19 15:21:57 2010 +0000
@@ -19,8 +19,8 @@
typedecl tr
typedecl void
-typedecl ('a,'b) "*" (infixl 6)
-typedecl ('a,'b) "+" (infixl 5)
+typedecl ('a,'b) "*" (infixl "*" 6)
+typedecl ('a,'b) "+" (infixl "+" 5)
arities
"fun" :: (cpo, cpo) cpo
--- a/src/Provers/hypsubst.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Provers/hypsubst.ML Fri Feb 19 15:21:57 2010 +0000
@@ -165,7 +165,7 @@
end;
-val ssubst = Drule.standard (Data.sym RS Data.subst);
+val ssubst = Drule.export_without_context (Data.sym RS Data.subst);
fun inst_subst_tac b rl = CSUBGOAL (fn (cBi, i) =>
case try (Logic.strip_assums_hyp #> hd #>
--- a/src/Provers/typedsimp.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Provers/typedsimp.ML Fri Feb 19 15:21:57 2010 +0000
@@ -43,11 +43,11 @@
(*For simplifying both sides of an equation:
[| a=c; b=c |] ==> b=a
Can use resolve_tac [split_eqn] to prepare an equation for simplification. *)
-val split_eqn = Drule.standard (sym RSN (2,trans) RS sym);
+val split_eqn = Drule.export_without_context (sym RSN (2,trans) RS sym);
(* [| a=b; b=c |] ==> reduce(a,c) *)
-val red_trans = Drule.standard (trans RS red_if_equal);
+val red_trans = Drule.export_without_context (trans RS red_if_equal);
(*For REWRITE rule: Make a reduction rule for simplification, e.g.
[| a: C(0); ... ; a=c: C(0) |] ==> rec(0,a,b) = c: C(0) *)
--- a/src/Pure/Concurrent/future.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Concurrent/future.ML Fri Feb 19 15:21:57 2010 +0000
@@ -88,22 +88,24 @@
(* datatype future *)
+type 'a result = 'a Exn.result Single_Assignment.var;
+
datatype 'a future = Future of
{promised: bool,
task: task,
group: group,
- result: 'a Exn.result option Synchronized.var};
+ result: 'a result};
fun task_of (Future {task, ...}) = task;
fun group_of (Future {group, ...}) = group;
fun result_of (Future {result, ...}) = result;
-fun peek x = Synchronized.value (result_of x);
+fun peek x = Single_Assignment.peek (result_of x);
fun is_finished x = is_some (peek x);
fun assign_result group result res =
let
- val _ = Synchronized.assign result (K (SOME res));
+ val _ = Single_Assignment.assign result res;
val ok =
(case res of
Exn.Exn exn => (Task_Queue.cancel_group group exn; false)
@@ -167,7 +169,7 @@
fun future_job group (e: unit -> 'a) =
let
- val result = Synchronized.var "future" (NONE: 'a Exn.result option);
+ val result = Single_Assignment.var "future" : 'a result;
fun job ok =
let
val res =
@@ -409,9 +411,6 @@
Exn.Exn (Exn.EXCEPTIONS (Exn.flatten_list (Task_Queue.group_status (group_of x))))
| SOME res => res);
-fun passive_wait x =
- Synchronized.readonly_access (result_of x) (fn NONE => NONE | SOME _ => SOME ());
-
fun join_next deps = (*requires SYNCHRONIZED*)
if null deps then NONE
else
@@ -438,7 +437,7 @@
else
(case worker_task () of
SOME task => join_depend task (map task_of xs)
- | NONE => List.app passive_wait xs;
+ | NONE => List.app (ignore o Single_Assignment.await o result_of) xs;
map get_result xs);
end;
@@ -452,7 +451,7 @@
fun value (x: 'a) =
let
val group = Task_Queue.new_group NONE;
- val result = Synchronized.var "value" NONE : 'a Exn.result option Synchronized.var;
+ val result = Single_Assignment.var "value" : 'a result;
val _ = assign_result group result (Exn.Result x);
in Future {promised = false, task = Task_Queue.dummy_task, group = group, result = result} end;
@@ -476,7 +475,7 @@
fun promise_group group : 'a future =
let
- val result = Synchronized.var "promise" (NONE: 'a Exn.result option);
+ val result = Single_Assignment.var "promise" : 'a result;
val task = SYNCHRONIZED "enqueue" (fn () =>
Unsynchronized.change_result queue (Task_Queue.enqueue_passive group));
in Future {promised = true, task = task, group = group, result = result} end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/Concurrent/single_assignment.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,57 @@
+(* Title: Pure/Concurrent/single_assignment.ML
+ Author: Makarius
+
+Single-assignment variables with locking/signalling.
+*)
+
+signature SINGLE_ASSIGNMENT =
+sig
+ type 'a var
+ val var: string -> 'a var
+ val peek: 'a var -> 'a option
+ val await: 'a var -> 'a
+ val assign: 'a var -> 'a -> unit
+end;
+
+structure Single_Assignment: SINGLE_ASSIGNMENT =
+struct
+
+abstype 'a var = Var of
+ {name: string,
+ lock: Mutex.mutex,
+ cond: ConditionVar.conditionVar,
+ var: 'a SingleAssignment.saref}
+with
+
+fun var name = Var
+ {name = name,
+ lock = Mutex.mutex (),
+ cond = ConditionVar.conditionVar (),
+ var = SingleAssignment.saref ()};
+
+fun peek (Var {var, ...}) = SingleAssignment.savalue var;
+
+fun await (v as Var {name, lock, cond, var}) =
+ SimpleThread.synchronized name lock (fn () =>
+ let
+ fun wait () =
+ (case peek v of
+ NONE =>
+ (case Multithreading.sync_wait NONE NONE cond lock of
+ Exn.Result _ => wait ()
+ | Exn.Exn exn => reraise exn)
+ | SOME x => x);
+ in wait () end);
+
+fun assign (v as Var {name, lock, cond, var}) x =
+ SimpleThread.synchronized name lock (fn () =>
+ (case peek v of
+ SOME _ => raise Fail ("Duplicate assignment to variable " ^ quote name)
+ | NONE =>
+ uninterruptible (fn _ => fn () =>
+ (SingleAssignment.saset (var, x); ConditionVar.broadcast cond)) ()));
+
+end;
+
+end;
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/Concurrent/single_assignment_sequential.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,30 @@
+(* Title: Pure/Concurrent/single_assignment_sequential.ML
+ Author: Makarius
+
+Single-assignment variables (sequential version).
+*)
+
+structure Single_Assignment: SINGLE_ASSIGNMENT =
+struct
+
+abstype 'a var = Var of 'a SingleAssignment.saref
+with
+
+fun var _ = Var (SingleAssignment.saref ());
+
+fun peek (Var var) = SingleAssignment.savalue var;
+
+fun await v =
+ (case peek v of
+ SOME x => x
+ | NONE => Thread.unavailable ());
+
+fun assign (v as Var var) x =
+ (case peek v of
+ SOME _ => raise Fail "Duplicate assignment to variable"
+ | NONE => SingleAssignment.saset (var, x));
+
+end;
+
+end;
+
--- a/src/Pure/Concurrent/synchronized.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Concurrent/synchronized.ML Fri Feb 19 15:21:57 2010 +0000
@@ -11,10 +11,8 @@
val value: 'a var -> 'a
val timed_access: 'a var -> ('a -> Time.time option) -> ('a -> ('b * 'a) option) -> 'b option
val guarded_access: 'a var -> ('a -> ('b * 'a) option) -> 'b
- val readonly_access: 'a var -> ('a -> 'b option) -> 'b
val change_result: 'a var -> ('a -> 'b * 'a) -> 'b
val change: 'a var -> ('a -> 'a) -> unit
- val assign: 'a var -> ('a -> 'a) -> unit
end;
structure Synchronized: SYNCHRONIZED =
@@ -22,11 +20,12 @@
(* state variables *)
-datatype 'a var = Var of
+abstype 'a var = Var of
{name: string,
lock: Mutex.mutex,
cond: ConditionVar.conditionVar,
- var: 'a Unsynchronized.ref};
+ var: 'a Unsynchronized.ref}
+with
fun var name x = Var
{name = name,
@@ -39,7 +38,7 @@
(* synchronized access *)
-fun access {time_limit, readonly, finish} (Var {name, lock, cond, var}) f =
+fun timed_access (Var {name, lock, cond, var}) time_limit f =
SimpleThread.synchronized name lock (fn () =>
let
fun try_change () =
@@ -51,36 +50,19 @@
| Exn.Result false => NONE
| Exn.Exn exn => reraise exn)
| SOME (y, x') =>
- if readonly then SOME y
- else
- let
- val _ = magic_immutability_test var
- andalso raise Fail ("Attempt to change finished variable " ^ quote name);
- val _ = var := x';
- val _ = if finish then magic_immutability_mark var else ();
- in SOME y end)
+ uninterruptible (fn _ => fn () =>
+ (var := x'; ConditionVar.broadcast cond; SOME y)) ())
end;
- val res = try_change ();
- val _ = ConditionVar.broadcast cond;
- in res end);
-
-fun timed_access var time_limit f =
- access {time_limit = time_limit, readonly = false, finish = false} var f;
+ in try_change () end);
fun guarded_access var f = the (timed_access var (K NONE) f);
-fun readonly_access var f =
- the (access {time_limit = K NONE, readonly = true, finish = false} var
- (fn x => (case f x of NONE => NONE | SOME y => SOME (y, x))));
-
(* unconditional change *)
fun change_result var f = guarded_access var (SOME o f);
fun change var f = change_result var (fn x => ((), f x));
-fun assign var f =
- the (access {time_limit = K NONE, readonly = false, finish = true} var
- (fn x => SOME ((), f x)));
+end;
end;
--- a/src/Pure/Concurrent/synchronized_sequential.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Concurrent/synchronized_sequential.ML Fri Feb 19 15:21:57 2010 +0000
@@ -20,13 +20,8 @@
fun guarded_access var f = the (timed_access var (K NONE) f);
-fun readonly_access var f =
- guarded_access var (fn x => (case f x of NONE => NONE | SOME y => SOME (y, x)));
-
fun change_result var f = guarded_access var (SOME o f);
fun change var f = change_result var (fn x => ((), f x));
-val assign = change;
-
end;
end;
--- a/src/Pure/Concurrent/task_queue.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Concurrent/task_queue.ML Fri Feb 19 15:21:57 2010 +0000
@@ -127,7 +127,7 @@
val empty = make_queue Inttab.empty Task_Graph.empty;
fun all_passive (Queue {jobs, ...}) =
- Task_Graph.get_first NONE
+ Task_Graph.get_first
((fn Job _ => SOME () | Running _ => SOME () | Passive => NONE) o #2 o #1 o #2) jobs |> is_none;
@@ -204,7 +204,7 @@
if is_ready deps group then SOME (task, group, rev list) else NONE
| ready _ = NONE;
in
- (case Task_Graph.get_first NONE ready jobs of
+ (case Task_Graph.get_first ready jobs of
NONE => (NONE, queue)
| SOME (result as (task, _, _)) =>
let val jobs' = set_job task (Running thread) jobs
--- a/src/Pure/General/binding.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/binding.ML Fri Feb 19 15:21:57 2010 +0000
@@ -22,6 +22,7 @@
val empty: binding
val is_empty: binding -> bool
val qualify: bool -> string -> binding -> binding
+ val qualified: bool -> string -> binding -> binding
val qualified_name: string -> binding
val qualified_name_of: binding -> string
val prefix_of: binding -> (string * bool) list
@@ -87,6 +88,10 @@
map_binding (fn (conceal, prefix, qualifier, name, pos) =>
(conceal, prefix, (qual, mandatory) :: qualifier, name, pos));
+fun qualified mandatory name' = map_binding (fn (conceal, prefix, qualifier, name, pos) =>
+ let val qualifier' = if name = "" then qualifier else qualifier @ [(name, mandatory)]
+ in (conceal, prefix, qualifier', name', pos) end);
+
fun qualified_name "" = empty
| qualified_name s =
let val (qualifier, name) = split_last (Long_Name.explode s)
--- a/src/Pure/General/file.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/file.ML Fri Feb 19 15:21:57 2010 +0000
@@ -14,7 +14,6 @@
val full_path: Path.T -> Path.T
val tmp_path: Path.T -> Path.T
val isabelle_tool: string -> string -> int
- val system_command: string -> unit
eqtype ident
val rep_ident: ident -> string
val ident: Path.T -> ident option
@@ -75,11 +74,11 @@
then SOME path
else NONE
end handle OS.SysErr _ => NONE) of
- SOME path => system (shell_quote path ^ " " ^ args)
+ SOME path => bash (shell_quote path ^ " " ^ args)
| NONE => (writeln ("Unknown Isabelle tool: " ^ name); 2));
fun system_command cmd =
- if system cmd <> 0 then error ("System command failed: " ^ cmd)
+ if bash cmd <> 0 then error ("System command failed: " ^ cmd)
else ();
@@ -116,7 +115,7 @@
SOME id => id
| NONE =>
let val (id, rc) = (*potentially slow*)
- system_out ("\"$ISABELLE_HOME/lib/scripts/fileident\" " ^ shell_quote physical_path)
+ bash_output ("\"$ISABELLE_HOME/lib/scripts/fileident\" " ^ shell_quote physical_path)
in
if id <> "" andalso rc = 0 then (update_cache (physical_path, (mod_time, id)); id)
else error ("Failed to identify file " ^ quote (Path.implode path) ^ " by " ^ cmd)
--- a/src/Pure/General/graph.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/graph.ML Fri Feb 19 15:21:57 2010 +0000
@@ -15,8 +15,7 @@
val is_empty: 'a T -> bool
val keys: 'a T -> key list
val dest: 'a T -> (key * key list) list
- val get_first: key option -> (key * ('a * (key list * key list)) -> 'b option) ->
- 'a T -> 'b option
+ val get_first: (key * ('a * (key list * key list)) -> 'b option) -> 'a T -> 'b option
val fold: (key * ('a * (key list * key list)) -> 'b -> 'b) -> 'a T -> 'b -> 'b
val minimals: 'a T -> key list
val maximals: 'a T -> key list
@@ -89,7 +88,7 @@
fun keys (Graph tab) = Table.keys tab;
fun dest (Graph tab) = map (fn (x, (_, (_, succs))) => (x, succs)) (Table.dest tab);
-fun get_first b f (Graph tab) = Table.get_first b f tab;
+fun get_first f (Graph tab) = Table.get_first f tab;
fun fold_graph f (Graph tab) = Table.fold f tab;
fun minimals G = fold_graph (fn (m, (_, ([], _))) => cons m | _ => I) G [];
--- a/src/Pure/General/name_space.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/name_space.ML Fri Feb 19 15:21:57 2010 +0000
@@ -43,6 +43,7 @@
val root_path: naming -> naming
val parent_path: naming -> naming
val mandatory_path: string -> naming -> naming
+ val qualified_path: bool -> binding -> naming -> naming
val transform_binding: naming -> binding -> binding
val full_name: naming -> binding -> string
val external_names: naming -> string -> string list
@@ -261,6 +262,9 @@
val parent_path = map_path (perhaps (try (#1 o split_last)));
fun mandatory_path elems = map_path (fn path => path @ [(elems, true)]);
+fun qualified_path mandatory binding = map_path (fn path =>
+ path @ #2 (Binding.dest (Binding.qualified mandatory "" binding)));
+
(* full name *)
--- a/src/Pure/General/secure.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/secure.ML Fri Feb 19 15:21:57 2010 +0000
@@ -15,8 +15,8 @@
val toplevel_pp: string list -> string -> unit
val open_unsynchronized: unit -> unit
val commit: unit -> unit
- val system_out: string -> string * int
- val system: string -> int
+ val bash_output: string -> string * int
+ val bash: string -> int
end;
structure Secure: SECURE =
@@ -61,12 +61,12 @@
fun secure_shell () = deny_secure "Cannot execute shell commands in secure mode";
-val orig_system_out = system_out;
+val orig_bash_output = bash_output;
-fun system_out s = (secure_shell (); orig_system_out s);
+fun bash_output s = (secure_shell (); orig_bash_output s);
-fun system s =
- (case system_out s of
+fun bash s =
+ (case bash_output s of
("", rc) => rc
| (out, rc) => (writeln (perhaps (try (unsuffix "\n")) out); rc));
@@ -78,5 +78,5 @@
fun use s = Secure.use_file ML_Parse.global_context true s
handle ERROR msg => (writeln msg; error "ML error");
val toplevel_pp = Secure.toplevel_pp;
-val system_out = Secure.system_out;
-val system = Secure.system;
+val bash_output = Secure.bash_output;
+val bash = Secure.bash;
--- a/src/Pure/General/table.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/General/table.ML Fri Feb 19 15:21:57 2010 +0000
@@ -28,7 +28,7 @@
val keys: 'a table -> key list
val min_key: 'a table -> key option
val max_key: 'a table -> key option
- val get_first: key option -> (key * 'a -> 'b option) -> 'a table -> 'b option
+ val get_first: (key * 'a -> 'b option) -> 'a table -> 'b option
val exists: (key * 'a -> bool) -> 'a table -> bool
val forall: (key * 'a -> bool) -> 'a table -> bool
val lookup: 'a table -> key -> 'a option
@@ -131,40 +131,32 @@
(* get_first *)
-fun get_first boundary f tab =
+fun get_first f =
let
- val check =
- (case boundary of
- NONE => K true
- | SOME b => (fn k => Key.ord (b, k) = LESS));
- fun apply (k, x) = if check k then f (k, x) else NONE;
- fun get_bounded tb k = if check k then get tb else NONE
- and get Empty = NONE
+ fun get Empty = NONE
| get (Branch2 (left, (k, x), right)) =
- (case get_bounded left k of
+ (case get left of
NONE =>
- (case apply (k, x) of
+ (case f (k, x) of
NONE => get right
| some => some)
| some => some)
| get (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
- (case get_bounded left k1 of
+ (case get left of
NONE =>
- (case apply (k1, x1) of
+ (case f (k1, x1) of
NONE =>
- (case get_bounded mid k2 of
+ (case get mid of
NONE =>
- (case apply (k2, x2) of
+ (case f (k2, x2) of
NONE => get right
| some => some)
| some => some)
| some => some)
| some => some);
- in get tab end;
+ in get end;
-fun exists pred =
- is_some o get_first NONE (fn entry => if pred entry then SOME () else NONE);
-
+fun exists pred = is_some o get_first (fn entry => if pred entry then SOME () else NONE);
fun forall pred = not o exists (not o pred);
--- a/src/Pure/IsaMakefile Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/IsaMakefile Fri Feb 19 15:21:57 2010 +0000
@@ -21,19 +21,19 @@
## Pure
-BOOTSTRAP_FILES = ML-Systems/compiler_polyml-5.0.ML \
+BOOTSTRAP_FILES = ML-Systems/bash.ML ML-Systems/compiler_polyml-5.0.ML \
ML-Systems/compiler_polyml-5.2.ML ML-Systems/compiler_polyml-5.3.ML \
- ML-Systems/ml_name_space.ML \
- ML-Systems/ml_pretty.ML ML-Systems/mosml.ML \
+ ML-Systems/ml_name_space.ML ML-Systems/ml_pretty.ML \
ML-Systems/multithreading.ML ML-Systems/multithreading_polyml.ML \
ML-Systems/overloading_smlnj.ML ML-Systems/polyml-5.0.ML \
ML-Systems/polyml-5.1.ML ML-Systems/polyml-5.2.ML \
ML-Systems/polyml-5.2.1.ML ML-Systems/polyml.ML \
ML-Systems/polyml_common.ML ML-Systems/pp_polyml.ML \
- ML-Systems/proper_int.ML ML-Systems/smlnj.ML \
- ML-Systems/system_shell.ML ML-Systems/thread_dummy.ML \
- ML-Systems/timing.ML ML-Systems/time_limit.ML \
- ML-Systems/universal.ML ML-Systems/unsynchronized.ML
+ ML-Systems/proper_int.ML ML-Systems/single_assignment.ML \
+ ML-Systems/single_assignment_polyml.ML ML-Systems/smlnj.ML \
+ ML-Systems/thread_dummy.ML ML-Systems/timing.ML \
+ ML-Systems/time_limit.ML ML-Systems/universal.ML \
+ ML-Systems/unsynchronized.ML
RAW: $(OUT)/RAW
@@ -47,17 +47,18 @@
Concurrent/future.ML Concurrent/lazy.ML \
Concurrent/lazy_sequential.ML Concurrent/mailbox.ML \
Concurrent/par_list.ML Concurrent/par_list_sequential.ML \
- Concurrent/simple_thread.ML Concurrent/synchronized.ML \
- Concurrent/synchronized_sequential.ML Concurrent/task_queue.ML \
- General/alist.ML General/antiquote.ML General/balanced_tree.ML \
- General/basics.ML General/binding.ML General/buffer.ML \
- General/exn.ML General/file.ML General/graph.ML General/heap.ML \
- General/integer.ML General/long_name.ML General/markup.ML \
- General/name_space.ML General/ord_list.ML General/output.ML \
- General/path.ML General/position.ML General/pretty.ML \
- General/print_mode.ML General/properties.ML General/queue.ML \
- General/same.ML General/scan.ML General/secure.ML General/seq.ML \
- General/source.ML General/stack.ML General/symbol.ML \
+ Concurrent/simple_thread.ML Concurrent/single_assignment.ML \
+ Concurrent/single_assignment_sequential.ML \
+ Concurrent/synchronized.ML Concurrent/synchronized_sequential.ML \
+ Concurrent/task_queue.ML General/alist.ML General/antiquote.ML \
+ General/balanced_tree.ML General/basics.ML General/binding.ML \
+ General/buffer.ML General/exn.ML General/file.ML General/graph.ML \
+ General/heap.ML General/integer.ML General/long_name.ML \
+ General/markup.ML General/name_space.ML General/ord_list.ML \
+ General/output.ML General/path.ML General/position.ML \
+ General/pretty.ML General/print_mode.ML General/properties.ML \
+ General/queue.ML General/same.ML General/scan.ML General/secure.ML \
+ General/seq.ML General/source.ML General/stack.ML General/symbol.ML \
General/symbol_pos.ML General/table.ML General/url.ML General/xml.ML \
General/yxml.ML Isar/args.ML Isar/attrib.ML Isar/auto_bind.ML \
Isar/calculation.ML Isar/class.ML Isar/class_target.ML Isar/code.ML \
--- a/src/Pure/Isar/args.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/args.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,7 +1,7 @@
(* Title: Pure/Isar/args.ML
Author: Markus Wenzel, TU Muenchen
-Parsing with implicit value assigment. Concrete argument syntax of
+Parsing with implicit value assignment. Concrete argument syntax of
attributes, methods etc.
*)
--- a/src/Pure/Isar/attrib.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/attrib.ML Fri Feb 19 15:21:57 2010 +0000
@@ -298,7 +298,7 @@
setup (Binding.name "params")
(Scan.lift (P.and_list1 (Scan.repeat Args.name)) >> Rule_Cases.params)
"named rule parameters" #>
- setup (Binding.name "standard") (Scan.succeed (Thm.rule_attribute (K Drule.standard)))
+ setup (Binding.name "standard") (Scan.succeed (Thm.rule_attribute (K Drule.export_without_context)))
"result put into standard form (legacy)" #>
setup (Binding.name "rule_format") rule_format "result put into canonical rule format" #>
setup (Binding.name "elim_format") (Scan.succeed elim_format)
--- a/src/Pure/Isar/class.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/class.ML Fri Feb 19 15:21:57 2010 +0000
@@ -1,4 +1,4 @@
-(* Title: Pure/Isar/ML
+(* Title: Pure/Isar/class.ML
Author: Florian Haftmann, TU Muenchen
Type classes derived from primitive axclasses and locales - interfaces.
@@ -86,7 +86,7 @@
| SOME prop => Logic.mk_implies (Morphism.term const_morph
((map_types o map_atyps) (K aT) prop), of_class_prop_concl);
val sup_of_classes = map (snd o rules thy) sups;
- val loc_axiom_intros = map Drule.standard' (Locale.axioms_of thy class);
+ val loc_axiom_intros = map Drule.export_without_context_open (Locale.axioms_of thy class);
val axclass_intro = #intro (AxClass.get_info thy class);
val base_sort_trivs = Thm.of_sort (Thm.ctyp_of thy aT, base_sort);
val tac = REPEAT (SOMEGOAL
@@ -132,7 +132,7 @@
(Syntax.add_typ_check level name (fn xs => fn ctxt =>
let val xs' = f xs in if eq_list (op =) (xs, xs') then NONE else SOME (xs', ctxt) end));
- (* preprocessing elements, retrieving base sort from typechecked elements *)
+ (* preprocessing elements, retrieving base sort from type-checked elements *)
val init_class_body = fold (ProofContext.add_const_constraint o apsnd SOME) base_constraints
#> redeclare_operations thy sups
#> add_typ_check 10 "reject_bcd_etc" reject_bcd_etc
--- a/src/Pure/Isar/class_target.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/class_target.ML Fri Feb 19 15:21:57 2010 +0000
@@ -29,7 +29,7 @@
(*instances*)
val init_instantiation: string list * (string * sort) list * sort
- -> theory -> local_theory
+ -> theory -> Proof.context
val instance_arity_cmd: xstring list * xstring list * xstring -> theory -> Proof.state
val instantiation_instance: (local_theory -> local_theory)
-> local_theory -> Proof.state
@@ -233,7 +233,7 @@
fun register_subclass (sub, sup) some_dep_morph some_wit export thy =
let
val intros = (snd o rules thy) sup :: map_filter I
- [Option.map (Drule.standard' o Element.conclude_witness) some_wit,
+ [Option.map (Drule.export_without_context_open o Element.conclude_witness) some_wit,
(fst o rules thy) sub];
val tac = EVERY (map (TRYALL o Tactic.rtac) intros);
val classrel = Skip_Proof.prove_global thy [] [] (Logic.mk_classrel (sub, sup))
--- a/src/Pure/Isar/expression.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/expression.ML Fri Feb 19 15:21:57 2010 +0000
@@ -606,7 +606,7 @@
fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args =>
if length args = n then
- Syntax.const "_aprop" $
+ Syntax.const "_aprop" $ (* FIXME avoid old-style early externing (!??) *)
Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args)
else raise Match);
@@ -681,7 +681,7 @@
|> def_pred abinding parms defs' exts exts';
val (_, thy'') =
thy'
- |> Sign.mandatory_path (Binding.name_of abinding)
+ |> Sign.qualified_path true abinding
|> PureThy.note_thmss ""
[((Binding.conceal (Binding.name introN), []), [([intro], [Locale.unfold_add])])]
||> Sign.restore_naming thy';
@@ -695,11 +695,11 @@
|> def_pred binding parms defs' (ints @ the_list a_pred) (ints' @ the_list a_pred);
val (_, thy'''') =
thy'''
- |> Sign.mandatory_path (Binding.name_of binding)
+ |> Sign.qualified_path true binding
|> PureThy.note_thmss ""
[((Binding.conceal (Binding.name introN), []), [([intro], [Locale.intro_add])]),
((Binding.conceal (Binding.name axiomsN), []),
- [(map (Drule.standard o Element.conclude_witness) axioms, [])])]
+ [(map (Drule.export_without_context o Element.conclude_witness) axioms, [])])]
||> Sign.restore_naming thy''';
in (SOME statement, SOME intro, axioms, thy'''') end;
in ((a_pred, a_intro, a_axioms), (b_pred, b_intro, b_axioms), thy'''') end;
--- a/src/Pure/Isar/isar_cmd.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/isar_cmd.ML Fri Feb 19 15:21:57 2010 +0000
@@ -332,16 +332,14 @@
val print_abbrevs = Toplevel.unknown_context o
Toplevel.keep (ProofContext.print_abbrevs o Toplevel.context_of);
-val print_facts = Toplevel.unknown_context o Toplevel.keep (fn state =>
- ProofContext.setmp_verbose_CRITICAL
- ProofContext.print_lthms (Toplevel.context_of state));
+val print_facts = Toplevel.unknown_context o
+ Toplevel.keep (ProofContext.print_lthms o Toplevel.context_of);
-val print_configs = Toplevel.unknown_context o Toplevel.keep (fn state =>
- Attrib.print_configs (Toplevel.context_of state));
+val print_configs = Toplevel.unknown_context o
+ Toplevel.keep (Attrib.print_configs o Toplevel.context_of);
-val print_theorems_proof = Toplevel.keep (fn state =>
- ProofContext.setmp_verbose_CRITICAL
- ProofContext.print_lthms (Proof.context_of (Toplevel.proof_of state)));
+val print_theorems_proof =
+ Toplevel.keep (ProofContext.print_lthms o Proof.context_of o Toplevel.proof_of);
fun print_theorems_theory verbose = Toplevel.keep (fn state =>
Toplevel.theory_of state |>
@@ -430,11 +428,11 @@
(* print proof context contents *)
-val print_binds = Toplevel.unknown_context o Toplevel.keep (fn state =>
- ProofContext.setmp_verbose_CRITICAL ProofContext.print_binds (Toplevel.context_of state));
+val print_binds = Toplevel.unknown_context o
+ Toplevel.keep (ProofContext.print_binds o Toplevel.context_of);
-val print_cases = Toplevel.unknown_context o Toplevel.keep (fn state =>
- ProofContext.setmp_verbose_CRITICAL ProofContext.print_cases (Toplevel.context_of state));
+val print_cases = Toplevel.unknown_context o
+ Toplevel.keep (ProofContext.print_cases o Toplevel.context_of);
(* print theorems, terms, types etc. *)
--- a/src/Pure/Isar/isar_syn.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/isar_syn.ML Fri Feb 19 15:21:57 2010 +0000
@@ -390,7 +390,7 @@
val _ =
OuterSyntax.command "context" "enter local theory context" K.thy_decl
(P.name --| P.begin >> (fn name =>
- Toplevel.print o Toplevel.begin_local_theory true (Theory_Target.context name)));
+ Toplevel.print o Toplevel.begin_local_theory true (Theory_Target.context_cmd name)));
(* locales *)
--- a/src/Pure/Isar/object_logic.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/object_logic.ML Fri Feb 19 15:21:57 2010 +0000
@@ -84,10 +84,9 @@
(* typedecl *)
-fun typedecl (a, vs, mx) thy =
+fun typedecl (b, vs, mx) thy =
let
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));
val name = Sign.full_name thy b;
@@ -95,7 +94,7 @@
val T = Type (name, map (fn v => TFree (v, [])) vs);
in
thy
- |> Sign.add_types [(a, n, mx)]
+ |> Sign.add_types [(b, n, mx)]
|> (case base_sort of NONE => I | SOME S => AxClass.axiomatize_arity (name, replicate n S, S))
|> pair T
end;
@@ -106,7 +105,7 @@
local
fun gen_add_judgment add_consts (b, T, mx) thy =
- let val c = Sign.full_name thy (Binding.map_name (Syntax.const_name mx) b) in
+ let val c = Sign.full_name thy b in
thy
|> add_consts [(b, T, mx)]
|> (fn thy' => Theory.add_deps c (c, Sign.the_const_type thy' c) [] thy')
--- a/src/Pure/Isar/outer_parse.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/outer_parse.ML Fri Feb 19 15:21:57 2010 +0000
@@ -266,9 +266,9 @@
!!! (Scan.optional ($$$ "[" |-- !!! (list nat --| $$$ "]")) [] --
Scan.optional nat Syntax.max_pri) >> (Mixfix o triple2);
-val infx = $$$ "infix" |-- !!! (nat >> Infix || string -- nat >> InfixName);
-val infxl = $$$ "infixl" |-- !!! (nat >> Infixl || string -- nat >> InfixlName);
-val infxr = $$$ "infixr" |-- !!! (nat >> Infixr || string -- nat >> InfixrName);
+val infx = $$$ "infix" |-- !!! (string -- nat >> Infix);
+val infxl = $$$ "infixl" |-- !!! (string -- nat >> Infixl);
+val infxr = $$$ "infixr" |-- !!! (string -- nat >> Infixr);
val binder = $$$ "binder" |--
!!! (string -- ($$$ "[" |-- nat --| $$$ "]" -- nat || nat >> (fn n => (n, n))))
--- a/src/Pure/Isar/overloading.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/overloading.ML Fri Feb 19 15:21:57 2010 +0000
@@ -6,7 +6,7 @@
signature OVERLOADING =
sig
- val init: (string * (string * typ) * bool) list -> theory -> local_theory
+ val init: (string * (string * typ) * bool) list -> theory -> Proof.context
val conclude: local_theory -> local_theory
val declare: string * typ -> theory -> term * theory
val confirm: binding -> local_theory -> local_theory
--- a/src/Pure/Isar/proof_context.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/proof_context.ML Fri Feb 19 15:21:57 2010 +0000
@@ -26,10 +26,10 @@
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 syn_of: Proof.context -> Syntax.syntax
val consts_of: Proof.context -> Consts.T
val const_syntax_name: Proof.context -> string -> string
val the_const_constraint: Proof.context -> string -> typ
- val mk_const: Proof.context -> string * typ list -> term
val set_syntax_mode: Syntax.mode -> Proof.context -> Proof.context
val restore_syntax_mode: Proof.context -> Proof.context -> Proof.context
val facts_of: Proof.context -> Facts.T
@@ -122,14 +122,13 @@
val add_const_constraint: string * typ option -> Proof.context -> 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_CRITICAL: ('a -> 'b) -> 'a -> 'b
val print_syntax: Proof.context -> unit
val print_abbrevs: Proof.context -> unit
val print_binds: Proof.context -> unit
val print_lthms: Proof.context -> unit
val print_cases: Proof.context -> unit
val debug: bool Unsynchronized.ref
+ val verbose: bool Unsynchronized.ref
val prems_limit: int Unsynchronized.ref
val pretty_ctxt: Proof.context -> Pretty.T list
val pretty_context: Proof.context -> Pretty.T list
@@ -239,8 +238,6 @@
val const_syntax_name = Consts.syntax_name o consts_of;
val the_const_constraint = Consts.the_constraint o consts_of;
-fun mk_const ctxt (c, Ts) = Const (c, Consts.instance (consts_of ctxt) (c, Ts));
-
val facts_of = #facts o rep_context;
val cases_of = #cases o rep_context;
@@ -495,7 +492,7 @@
fun match_abbrev u = Option.map #1 (get_first (Pattern.match_rew thy u) (retrieve u));
in
if abbrev orelse print_mode_active "no_abbrevs" orelse not (can Term.type_of t) then t
- else Pattern.rewrite_term thy [] [match_abbrev] t
+ else Pattern.rewrite_term_top thy [] [match_abbrev] t
end;
@@ -965,19 +962,18 @@
local
fun prep_vars prep_typ internal =
- fold_map (fn (raw_b, raw_T, raw_mx) => fn ctxt =>
+ fold_map (fn (b, raw_T, mx) => fn ctxt =>
let
- val raw_x = Name.of_binding raw_b;
- val (x, mx) = Syntax.const_mixfix raw_x raw_mx;
+ val x = Name.of_binding b;
val _ = Syntax.is_identifier (no_skolem internal x) orelse
- error ("Illegal variable name: " ^ quote x);
+ error ("Illegal variable name: " ^ quote (Binding.str_of b));
fun cond_tvars T =
if internal then T
else Type.no_tvars T handle TYPE (msg, _, _) => error msg;
val opt_T = Option.map (cond_tvars o cert_typ ctxt o prep_typ ctxt) raw_T;
- val var = (Binding.map_name (K x) raw_b, opt_T, mx);
- in (var, ctxt |> declare_var (x, opt_T, mx) |> #2) end);
+ val (_, ctxt') = ctxt |> declare_var (x, opt_T, mx);
+ in ((b, opt_T, mx), ctxt') end);
in
@@ -1198,14 +1194,6 @@
(** print context information **)
-val debug = Unsynchronized.ref false;
-
-val verbose = Unsynchronized.ref false;
-fun verb f x = if ! verbose then f (x ()) else [];
-
-fun setmp_verbose_CRITICAL f x = setmp_CRITICAL verbose true f x;
-
-
(* local syntax *)
val print_syntax = Syntax.print_syntax o syn_of;
@@ -1223,7 +1211,7 @@
else cons (c, Logic.mk_equals (Const (c, T), t));
val abbrevs = Name_Space.extern_table (space, Symtab.make (Symtab.fold add_abbr consts []));
in
- if null abbrevs andalso not (! verbose) then []
+ if null abbrevs then []
else [Pretty.big_list "abbreviations:" (map (pretty_term_abbrev ctxt o #2) abbrevs)]
end;
@@ -1237,7 +1225,7 @@
val binds = Variable.binds_of ctxt;
fun prt_bind (xi, (T, t)) = pretty_term_abbrev ctxt (Logic.mk_equals (Var (xi, T), t));
in
- if Vartab.is_empty binds andalso not (! verbose) then []
+ if Vartab.is_empty binds then []
else [Pretty.big_list "term bindings:" (map prt_bind (Vartab.dest binds))]
end;
@@ -1251,10 +1239,10 @@
val local_facts = facts_of ctxt;
val props = Facts.props local_facts;
val facts =
- (if null props then [] else [("unnamed", props)]) @
+ (if null props then [] else [("<unnamed>", props)]) @
Facts.dest_static [] local_facts;
in
- if null facts andalso not (! verbose) then []
+ if null facts then []
else [Pretty.big_list "facts:" (map #1 (sort_wrt (#1 o #2) (map (`(pretty_fact ctxt)) facts)))]
end;
@@ -1277,8 +1265,9 @@
((if a = "" then [] else [Pretty.str (a ^ ":")]) @ map (Pretty.quote o prt_term) ts));
fun prt_sect _ _ _ [] = []
- | prt_sect s sep prt xs = [Pretty.block (Pretty.breaks (Pretty.str s ::
- flat (Library.separate sep (map (Library.single o prt) xs))))];
+ | prt_sect s sep prt xs =
+ [Pretty.block (Pretty.breaks (Pretty.str s ::
+ flat (separate sep (map (single o prt) xs))))];
in
Pretty.block (Pretty.fbreaks
(Pretty.str (name ^ ":") ::
@@ -1299,7 +1288,7 @@
cons (name, (fixes, case_result c ctxt));
val cases = fold add_case (cases_of ctxt) [];
in
- if null cases andalso not (! verbose) then []
+ if null cases then []
else [Pretty.big_list "cases:" (map pretty_case cases)]
end;
@@ -1310,6 +1299,8 @@
(* core context *)
+val debug = Unsynchronized.ref false;
+val verbose = Unsynchronized.ref false;
val prems_limit = Unsynchronized.ref ~1;
fun pretty_ctxt ctxt =
@@ -1320,7 +1311,8 @@
(*structures*)
val structs = Local_Syntax.structs_of (syntax_of ctxt);
- val prt_structs = if null structs then []
+ val prt_structs =
+ if null structs then []
else [Pretty.block (Pretty.str "structures:" :: Pretty.brk 1 ::
Pretty.commas (map Pretty.str structs))];
@@ -1331,7 +1323,8 @@
val fixes =
rev (filter_out ((can Name.dest_internal orf member (op =) structs) o #1)
(Variable.fixes_of ctxt));
- val prt_fixes = if null fixes then []
+ val prt_fixes =
+ if null fixes then []
else [Pretty.block (Pretty.str "fixed variables:" :: Pretty.brk 1 ::
Pretty.commas (map prt_fix fixes))];
@@ -1339,7 +1332,8 @@
val prems = Assumption.all_prems_of ctxt;
val len = length prems;
val suppressed = len - ! prems_limit;
- val prt_prems = if null prems then []
+ val prt_prems =
+ if null prems then []
else [Pretty.big_list "prems:" ((if suppressed <= 0 then [] else [Pretty.str "..."]) @
map (Display.pretty_thm ctxt) (drop suppressed prems))];
in prt_structs @ prt_fixes @ prt_prems end;
@@ -1349,6 +1343,9 @@
fun pretty_context ctxt =
let
+ val is_verbose = ! verbose;
+ fun verb f x = if is_verbose then f (x ()) else [];
+
val prt_term = Syntax.pretty_term ctxt;
val prt_typ = Syntax.pretty_typ ctxt;
val prt_sort = Syntax.pretty_sort ctxt;
--- a/src/Pure/Isar/skip_proof.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/skip_proof.ML Fri Feb 19 15:21:57 2010 +0000
@@ -39,6 +39,6 @@
else tac args st);
fun prove_global thy xs asms prop tac =
- Drule.standard (prove (ProofContext.init thy) xs asms prop tac);
+ Drule.export_without_context (prove (ProofContext.init thy) xs asms prop tac);
end;
--- a/src/Pure/Isar/theory_target.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/theory_target.ML Fri Feb 19 15:21:57 2010 +0000
@@ -7,12 +7,14 @@
signature THEORY_TARGET =
sig
- val peek: local_theory -> {target: string, is_locale: bool,
- is_class: bool, instantiation: string list * (string * sort) list * sort,
+ val peek: local_theory ->
+ {target: string,
+ is_locale: bool,
+ is_class: bool,
+ instantiation: string list * (string * sort) list * sort,
overloading: (string * (string * typ) * bool) list}
val init: string option -> theory -> local_theory
- val begin: string -> Proof.context -> local_theory
- val context: xstring -> theory -> local_theory
+ val context_cmd: xstring -> theory -> local_theory
val instantiation: string list * (string * sort) list * sort -> theory -> local_theory
val instantiation_cmd: xstring list * xstring list * xstring -> theory -> local_theory
val overloading: (string * (string * typ) * bool) list -> theory -> local_theory
@@ -88,7 +90,7 @@
in
if target = "" then
lthy
- |> direct_decl target_decl
+ |> direct_decl global_decl
else
lthy
|> pervasive ? direct_decl global_decl
@@ -305,13 +307,13 @@
in ((lhs, (res_name, res)), lthy4) end;
-(* init *)
+(* init various targets *)
local
fun init_target _ NONE = global_target
| init_target thy (SOME target) =
- if Locale.defined thy (Locale.intern thy target)
+ if Locale.defined thy target
then make_target target true (Class_Target.is_class thy target) ([], [], []) []
else error ("No such locale: " ^ quote target);
@@ -349,17 +351,12 @@
in
fun init target thy = init_lthy_ctxt (init_target thy target) thy;
-fun begin target ctxt = init_lthy (init_target (ProofContext.theory_of ctxt) (SOME target)) ctxt;
-fun context "-" thy = init NONE thy
- | context target thy = init (SOME (Locale.intern thy target)) thy;
-
-
-(* other targets *)
+fun context_cmd "-" thy = init NONE thy
+ | context_cmd target thy = init (SOME (Locale.intern thy target)) thy;
fun instantiation arities = init_lthy_ctxt (make_target "" false false arities []);
-fun instantiation_cmd raw_arities thy =
- instantiation (Class_Target.read_multi_arity thy raw_arities) thy;
+fun instantiation_cmd arities thy = instantiation (Class_Target.read_multi_arity thy arities) thy;
val overloading = gen_overloading (fn ctxt => Syntax.check_term ctxt o Const);
val overloading_cmd = gen_overloading Syntax.read_term;
--- a/src/Pure/Isar/toplevel.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Isar/toplevel.ML Fri Feb 19 15:21:57 2010 +0000
@@ -104,7 +104,7 @@
type generic_theory = Context.generic; (*theory or local_theory*)
-val loc_init = Theory_Target.context;
+val loc_init = Theory_Target.context_cmd;
val loc_exit = Local_Theory.exit_global;
fun loc_begin loc (Context.Theory thy) = loc_init (the_default "-" loc) thy
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/ML-Systems/bash.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,43 @@
+(* Title: Pure/ML-Systems/bash.ML
+ Author: Makarius
+
+Generic GNU bash processes (no provisions to propagate interrupts, but
+could work via the controlling tty).
+*)
+
+local
+
+fun read_file name =
+ let val is = TextIO.openIn name
+ in Exn.release (Exn.capture TextIO.inputAll is before TextIO.closeIn is) end;
+
+fun write_file name txt =
+ let val os = TextIO.openOut name
+ in Exn.release (Exn.capture TextIO.output (os, txt) before TextIO.closeOut os) end;
+
+in
+
+fun bash_output script =
+ let
+ val script_name = OS.FileSys.tmpName ();
+ val _ = write_file script_name script;
+
+ val output_name = OS.FileSys.tmpName ();
+
+ val status =
+ OS.Process.system ("exec \"$ISABELLE_HOME/lib/scripts/bash\" nogroup " ^
+ script_name ^ " /dev/null " ^ output_name);
+ val rc =
+ (case Posix.Process.fromStatus status of
+ Posix.Process.W_EXITED => 0
+ | Posix.Process.W_EXITSTATUS w => Word8.toInt w
+ | Posix.Process.W_SIGNALED s => 256 + LargeWord.toInt (Posix.Signal.toWord s)
+ | Posix.Process.W_STOPPED s => 512 + LargeWord.toInt (Posix.Signal.toWord s));
+
+ val output = read_file output_name handle IO.Io _ => "";
+ val _ = OS.FileSys.remove script_name handle OS.SysErr _ => ();
+ val _ = OS.FileSys.remove output_name handle OS.SysErr _ => ();
+ in (output, rc) end;
+
+end;
+
--- a/src/Pure/ML-Systems/mosml.ML Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,259 +0,0 @@
-(* Title: Pure/ML-Systems/mosml.ML
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Author: Makarius
-
-Compatibility file for Moscow ML 2.01
-
-NOTE: saving images does not work; may run it interactively as follows:
-
-$ cd Isabelle/src/Pure
-$ isabelle-process RAW_ML_SYSTEM
-> val ml_system = "mosml";
-> use "ML-Systems/mosml.ML";
-> use "ROOT.ML";
-> Session.finish ();
-> cd "../FOL";
-> use "ROOT.ML";
-> Session.finish ();
-> cd "../ZF";
-> use "ROOT.ML";
-*)
-
-(** ML system related **)
-
-val ml_system_fix_ints = false;
-
-fun forget_structure _ = ();
-
-load "Obj";
-load "Word";
-load "Bool";
-load "Int";
-load "Real";
-load "ListPair";
-load "OS";
-load "Process";
-load "FileSys";
-load "IO";
-load "CharVector";
-
-exception Interrupt;
-fun reraise exn = raise exn;
-
-use "ML-Systems/unsynchronized.ML";
-use "General/exn.ML";
-use "ML-Systems/universal.ML";
-use "ML-Systems/thread_dummy.ML";
-use "ML-Systems/multithreading.ML";
-use "ML-Systems/time_limit.ML";
-use "ML-Systems/ml_name_space.ML";
-use "ML-Systems/ml_pretty.ML";
-use "ML-Systems/use_context.ML";
-
-
-(*low-level pointer equality*)
-local val cast : 'a -> int = Obj.magic
-in fun pointer_eq (x:'a, y:'a) = (cast x = cast y) end;
-
-(*proper implementation available?*)
-structure IntInf =
-struct
- fun divMod (x, y) = (x div y, x mod y);
-
- local
- fun log 1 a = a
- | log n a = log (n div 2) (a + 1);
- in
- fun log2 n = if n > 0 then log n 0 else raise Domain;
- end;
-
- open Int;
-end;
-
-structure Substring =
-struct
- open Substring;
- val full = all;
-end;
-
-structure Real =
-struct
- open Real;
- val realFloor = real o floor;
-end;
-
-structure String =
-struct
- fun isSuffix s1 s2 =
- let val n1 = size s1 and n2 = size s2
- in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end;
- open String;
-end;
-
-structure Time =
-struct
- open Time;
- fun toString t = Time.toString t
- handle Overflow => Real.toString (Time.toReal t); (*workaround Y2004 bug*)
-end;
-
-structure OS =
-struct
- open OS
- structure Process =
- struct
- open Process
- fun sleep _ = raise Fail "OS.Process.sleep undefined"
- end;
- structure FileSys = FileSys
-end;
-
-exception Option = Option.Option;
-
-
-(*limit the printing depth*)
-local
- val depth = ref 10;
-in
- fun get_print_depth () = ! depth;
- fun print_depth n =
- (depth := n;
- Meta.printDepth := n div 2;
- Meta.printLength := n);
-end;
-
-(*dummy implementation*)
-fun toplevel_pp _ _ _ = ();
-
-(*dummy implementation*)
-fun ml_prompts p1 p2 = ();
-
-(*dummy implementation*)
-fun profile (n: int) f x = f x;
-
-(*dummy implementation*)
-fun exception_trace f = f ();
-
-
-
-(** Compiler-independent timing functions **)
-
-load "Timer";
-
-fun start_timing () =
- let
- val timer = Timer.startCPUTimer ();
- val time = Timer.checkCPUTimer timer;
- in (timer, time) end;
-
-fun end_timing (timer, {gc, sys, usr}) =
- let
- open Time; (*...for Time.toString, Time.+ and Time.- *)
- val {gc = gc2, sys = sys2, usr = usr2} = Timer.checkCPUTimer timer;
- val user = usr2 - usr + gc2 - gc;
- val all = user + sys2 - sys;
- val message = "User " ^ toString user ^ " All "^ toString all ^ " secs" handle Time => "";
- in {message = message, user = user, all = all} end;
-
-
-(* SML basis library fixes *)
-
-structure TextIO =
-struct
- fun canInput _ = raise IO.Io {cause = Fail "undefined", function = "canInput", name = ""};
- open TextIO;
- fun inputLine is =
- let val s = TextIO.inputLine is
- in if s = "" then NONE else SOME s end;
- fun getOutstream _ = ();
- structure StreamIO =
- struct
- fun setBufferMode _ = ();
- end
-end;
-
-structure IO =
-struct
- open IO;
- val BLOCK_BUF = ();
-end;
-
-
-(* ML command execution *)
-
-(*Can one redirect 'use' directly to an instream?*)
-fun use_text ({tune_source, ...}: use_context) _ _ txt =
- let
- val tmp_name = FileSys.tmpName ();
- val tmp_file = TextIO.openOut tmp_name;
- in
- TextIO.output (tmp_file, tune_source txt);
- TextIO.closeOut tmp_file;
- use tmp_name;
- FileSys.remove tmp_name
- end;
-
-fun use_file _ _ name = use name;
-
-
-
-(** interrupts **) (*Note: may get into race conditions*)
-
-(* FIXME proper implementation available? *)
-
-fun interruptible f x = f x;
-fun uninterruptible f x = f (fn (g: 'c -> 'd) => g) x;
-
-
-
-(** OS related **)
-
-(*dummy implementation*)
-structure Posix =
-struct
- structure ProcEnv =
- struct
- fun getpid () = 0;
- end;
-end;
-
-local
-
-fun read_file name =
- let val is = TextIO.openIn name
- in Exn.release (Exn.capture TextIO.inputAll is before TextIO.closeIn is) end;
-
-fun write_file name txt =
- let val os = TextIO.openOut name
- in Exn.release (Exn.capture TextIO.output (os, txt) before TextIO.closeOut os) end;
-
-in
-
-fun system_out script =
- let
- val script_name = OS.FileSys.tmpName ();
- val _ = write_file script_name script;
-
- val output_name = OS.FileSys.tmpName ();
-
- val status =
- OS.Process.system ("perl -w \"$ISABELLE_HOME/lib/scripts/system.pl\" nogroup " ^
- script_name ^ " /dev/null " ^ output_name);
- val rc = if status = OS.Process.success then 0 else 1;
-
- val output = read_file output_name handle IO.Io _ => "";
- val _ = OS.FileSys.remove script_name handle OS.SysErr _ => ();
- val _ = OS.FileSys.remove output_name handle OS.SysErr _ => ();
- in (output, rc) end;
-
-end;
-
-val cd = OS.FileSys.chDir;
-val pwd = OS.FileSys.getDir;
-
-val process_id = Int.toString o Posix.ProcEnv.getpid;
-
-fun getenv var =
- (case Process.getEnv var of
- NONE => ""
- | SOME txt => txt);
--- a/src/Pure/ML-Systems/multithreading_polyml.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML-Systems/multithreading_polyml.ML Fri Feb 19 15:21:57 2010 +0000
@@ -8,7 +8,7 @@
sig
val interruptible: ('a -> 'b) -> 'a -> 'b
val uninterruptible: ((('c -> 'd) -> 'c -> 'd) -> 'a -> 'b) -> 'a -> 'b
- val system_out: string -> string * int
+ val bash_output: string -> string * int
structure TimeLimit: TIME_LIMIT
end;
@@ -156,9 +156,9 @@
end;
-(* system shell processes, with propagation of interrupts *)
+(* GNU bash processes, with propagation of interrupts *)
-fun system_out script = with_attributes no_interrupts (fn orig_atts =>
+fun bash_output script = with_attributes no_interrupts (fn orig_atts =>
let
val script_name = OS.FileSys.tmpName ();
val _ = write_file script_name script;
@@ -180,7 +180,7 @@
val system_thread = Thread.fork (fn () =>
let
val status =
- OS.Process.system ("perl -w \"$ISABELLE_HOME/lib/scripts/system.pl\" group " ^
+ OS.Process.system ("exec \"$ISABELLE_HOME/lib/scripts/bash\" group " ^
script_name ^ " " ^ pid_name ^ " " ^ output_name);
val res =
(case Posix.Process.fromStatus status of
--- a/src/Pure/ML-Systems/polyml_common.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML-Systems/polyml_common.ML Fri Feb 19 15:21:57 2010 +0000
@@ -6,10 +6,11 @@
exception Interrupt = SML90.Interrupt;
use "General/exn.ML";
+use "ML-Systems/single_assignment_polyml.ML";
use "ML-Systems/multithreading.ML";
use "ML-Systems/time_limit.ML";
use "ML-Systems/timing.ML";
-use "ML-Systems/system_shell.ML";
+use "ML-Systems/bash.ML";
use "ML-Systems/ml_pretty.ML";
use "ML-Systems/use_context.ML";
@@ -131,12 +132,3 @@
val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
in Exn.release res end;
-
-(* magic immutability -- for internal use only! *)
-
-fun magic_immutability_mark (r: 'a Unsynchronized.ref) =
- ignore (RunCall.run_call1 RuntimeCalls.POLY_SYS_lockseg r);
-
-fun magic_immutability_test (r: 'a Unsynchronized.ref) =
- Word8.andb (0wx40, RunCall.run_call1 RuntimeCalls.POLY_SYS_get_flags r) = 0w0;
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/ML-Systems/single_assignment.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,33 @@
+(* Title: Pure/ML-Systems/single_assignment.ML
+ Author: Makarius
+
+References with single assignment. Unsynchronized!
+*)
+
+signature SINGLE_ASSIGNMENT =
+sig
+ type 'a saref
+ exception Locked
+ val saref: unit -> 'a saref
+ val savalue: 'a saref -> 'a option
+ val saset: 'a saref * 'a -> unit
+end;
+
+structure SingleAssignment: SINGLE_ASSIGNMENT =
+struct
+
+exception Locked;
+
+abstype 'a saref = SARef of 'a option ref
+with
+
+fun saref () = SARef (ref NONE);
+
+fun savalue (SARef r) = ! r;
+
+fun saset (SARef (r as ref NONE), x) = r := SOME x
+ | saset _ = raise Locked;
+
+end;
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/ML-Systems/single_assignment_polyml.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,35 @@
+(* Title: Pure/ML-Systems/single_assignment_polyml.ML
+ Author: Makarius
+
+References with single assignment. Unsynchronized! Emulates
+structure SingleAssignment from Poly/ML 5.4.
+*)
+
+signature SINGLE_ASSIGNMENT =
+sig
+ type 'a saref
+ exception Locked
+ val saref: unit -> 'a saref
+ val savalue: 'a saref -> 'a option
+ val saset: 'a saref * 'a -> unit
+end;
+
+structure SingleAssignment: SINGLE_ASSIGNMENT =
+struct
+
+exception Locked;
+
+abstype 'a saref = SARef of 'a option ref
+with
+
+fun saref () = SARef (ref NONE);
+
+fun savalue (SARef r) = ! r;
+
+fun saset (SARef (r as ref NONE), x) =
+ (r := SOME x; RunCall.run_call1 RuntimeCalls.POLY_SYS_lockseg r)
+ | saset _ = raise Locked;
+
+end;
+
+end;
--- a/src/Pure/ML-Systems/smlnj.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML-Systems/smlnj.ML Fri Feb 19 15:21:57 2010 +0000
@@ -10,11 +10,12 @@
use "ML-Systems/unsynchronized.ML";
use "ML-Systems/overloading_smlnj.ML";
use "General/exn.ML";
+use "ML-Systems/single_assignment.ML";
use "ML-Systems/universal.ML";
use "ML-Systems/thread_dummy.ML";
use "ML-Systems/multithreading.ML";
use "ML-Systems/timing.ML";
-use "ML-Systems/system_shell.ML";
+use "ML-Systems/bash.ML";
use "ML-Systems/ml_name_space.ML";
use "ML-Systems/ml_pretty.ML";
use "ML-Systems/use_context.ML";
@@ -66,10 +67,6 @@
(Control.primaryPrompt := p1; Control.secondaryPrompt := p2);
(*dummy implementation*)
-fun magic_immutability_test _ = false;
-fun magic_immutability_mark _ = ();
-
-(*dummy implementation*)
fun profile (n: int) f x = f x;
(*dummy implementation*)
@@ -179,7 +176,7 @@
(* system command execution *)
-val system_out = (fn (output, rc) => (output, mk_int rc)) o system_out;
+val bash_output = (fn (output, rc) => (output, mk_int rc)) o bash_output;
fun process_id pid =
Word.fmt StringCvt.DEC (Word.fromLargeWord (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())));
--- a/src/Pure/ML-Systems/system_shell.ML Fri Feb 05 17:19:25 2010 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-(* Title: Pure/ML-Systems/system_shell.ML
- Author: Makarius
-
-Generic system shell processes (no provisions to propagate interrupts;
-might still work via the controlling tty).
-*)
-
-local
-
-fun read_file name =
- let val is = TextIO.openIn name
- in Exn.release (Exn.capture TextIO.inputAll is before TextIO.closeIn is) end;
-
-fun write_file name txt =
- let val os = TextIO.openOut name
- in Exn.release (Exn.capture TextIO.output (os, txt) before TextIO.closeOut os) end;
-
-in
-
-fun system_out script =
- let
- val script_name = OS.FileSys.tmpName ();
- val _ = write_file script_name script;
-
- val output_name = OS.FileSys.tmpName ();
-
- val status =
- OS.Process.system ("perl -w \"$ISABELLE_HOME/lib/scripts/system.pl\" nogroup " ^
- script_name ^ " /dev/null " ^ output_name);
- val rc =
- (case Posix.Process.fromStatus status of
- Posix.Process.W_EXITED => 0
- | Posix.Process.W_EXITSTATUS w => Word8.toInt w
- | Posix.Process.W_SIGNALED s => 256 + LargeWord.toInt (Posix.Signal.toWord s)
- | Posix.Process.W_STOPPED s => 512 + LargeWord.toInt (Posix.Signal.toWord s));
-
- val output = read_file output_name handle IO.Io _ => "";
- val _ = OS.FileSys.remove script_name handle OS.SysErr _ => ();
- val _ = OS.FileSys.remove output_name handle OS.SysErr _ => ();
- in (output, rc) end;
-
-end;
-
--- a/src/Pure/ML/ml_antiquote.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML/ml_antiquote.ML Fri Feb 19 15:21:57 2010 +0000
@@ -38,17 +38,17 @@
fun macro name scan = ML_Context.add_antiq name
(fn _ => scan :|-- (fn ctxt => Scan.depend (fn _ => Scan.succeed
- (Context.Proof ctxt, fn {background, ...} => (K ("", ""), background)))));
+ (Context.Proof ctxt, fn background => (K ("", ""), background)))));
fun inline name scan = ML_Context.add_antiq name
- (fn _ => scan >> (fn s => fn {background, ...} => (K ("", s), background)));
+ (fn _ => scan >> (fn s => fn background => (K ("", s), background)));
fun declaration kind name scan = ML_Context.add_antiq name
- (fn _ => scan >> (fn s => fn {struct_name, background} =>
+ (fn _ => scan >> (fn s => fn background =>
let
val (a, background') = variant name background;
val env = kind ^ " " ^ a ^ " = " ^ s ^ ";\n";
- val body = struct_name ^ "." ^ a;
+ val body = "Isabelle." ^ a;
in (K (env, body), background') end));
val value = declaration "val";
@@ -123,9 +123,16 @@
val _ = inline "const"
(Args.context -- Scan.lift Args.name_source -- Scan.optional
(Scan.lift (Args.$$$ "(") |-- OuterParse.enum1' "," Args.typ --| Scan.lift (Args.$$$ ")")) []
- >> (fn ((ctxt, c), Ts) =>
- let val (c, _) = Term.dest_Const (ProofContext.read_const_proper ctxt c)
- in ML_Syntax.atomic (ML_Syntax.print_term (ProofContext.mk_const ctxt (c, Ts))) end));
+ >> (fn ((ctxt, raw_c), Ts) =>
+ let
+ val Const (c, _) = ProofContext.read_const_proper ctxt raw_c;
+ val const = Const (c, Consts.instance (ProofContext.consts_of ctxt) (c, Ts));
+ in ML_Syntax.atomic (ML_Syntax.print_term const) end));
+
+val _ = inline "syntax_const"
+ (Args.context -- Scan.lift Args.name >> (fn (ctxt, c) =>
+ if Syntax.is_const (ProofContext.syn_of ctxt) c then ML_Syntax.print_string c
+ else error ("Unknown syntax const: " ^ quote c)));
end;
--- a/src/Pure/ML/ml_context.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML/ml_context.ML Fri Feb 19 15:21:57 2010 +0000
@@ -22,9 +22,7 @@
val stored_thms: thm list Unsynchronized.ref
val ml_store_thm: string * thm -> unit
val ml_store_thms: string * thm list -> unit
- type antiq =
- {struct_name: string, background: Proof.context} ->
- (Proof.context -> string * string) * Proof.context
+ type antiq = Proof.context -> (Proof.context -> string * string) * Proof.context
val add_antiq: string -> (Position.T -> antiq context_parser) -> unit
val trace: bool Unsynchronized.ref
val eval_antiquotes: ML_Lex.token Antiquote.antiquote list * Position.T ->
@@ -72,8 +70,8 @@
val ml_store_thms = ml_store "";
fun ml_store_thm (name, th) = ml_store "hd" (name, [th]);
-fun bind_thm (name, thm) = ml_store_thm (name, Drule.standard thm);
-fun bind_thms (name, thms) = ml_store_thms (name, map Drule.standard thms);
+fun bind_thm (name, thm) = ml_store_thm (name, Drule.export_without_context thm);
+fun bind_thms (name, thms) = ml_store_thms (name, map Drule.export_without_context thms);
fun thm name = ProofContext.get_thm (the_local_context ()) name;
fun thms name = ProofContext.get_thms (the_local_context ()) name;
@@ -84,9 +82,7 @@
(* antiquotation commands *)
-type antiq =
- {struct_name: string, background: Proof.context} ->
- (Proof.context -> string * string) * Proof.context;
+type antiq = Proof.context -> (Proof.context -> string * string) * Proof.context;
local
@@ -123,8 +119,7 @@
P.!!! (P.position P.xname -- Args.parse --| Scan.ahead P.eof)
>> (fn ((x, pos), y) => Args.src ((x, y), pos));
-val struct_name = "Isabelle";
-val begin_env = ML_Lex.tokenize ("structure " ^ struct_name ^ " =\nstruct\n");
+val begin_env = ML_Lex.tokenize "structure Isabelle =\nstruct\n";
val end_env = ML_Lex.tokenize "end;";
val reset_env = ML_Lex.tokenize "structure Isabelle = struct end";
@@ -151,7 +146,7 @@
let
val context = Stack.top scope;
val (f, context') = antiquotation (T.read_antiq lex antiq (ss, #1 range)) context;
- val (decl, background') = f {background = background, struct_name = struct_name};
+ val (decl, background') = f background;
val decl' = decl #> pairself (ML_Lex.tokenize #> map (ML_Lex.set_range range));
in (decl', (Stack.map_top (K context') scope, background')) end
| expand (Antiquote.Open _) (scope, background) =
--- a/src/Pure/ML/ml_thms.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ML/ml_thms.ML Fri Feb 19 15:21:57 2010 +0000
@@ -34,12 +34,12 @@
(* fact references *)
fun thm_antiq kind scan = ML_Context.add_antiq kind
- (fn _ => scan >> (fn ths => fn {struct_name, background} =>
+ (fn _ => scan >> (fn ths => fn background =>
let
val i = serial ();
val (a, background') = background
|> ML_Antiquote.variant kind ||> put_thms (i, ths);
- val ml = (thm_bind kind a i, struct_name ^ "." ^ a);
+ val ml = (thm_bind kind a i, "Isabelle." ^ a);
in (K ml, background') end));
val _ = thm_antiq "thm" (Attrib.thm >> single);
@@ -56,7 +56,7 @@
(fn _ => Args.context -- Args.mode "open" --
Scan.lift (OuterParse.and_list1 (Scan.repeat1 goal) --
(by |-- Method.parse -- Scan.option Method.parse)) >>
- (fn ((ctxt, is_open), (raw_propss, methods)) => fn {struct_name, background} =>
+ (fn ((ctxt, is_open), (raw_propss, methods)) => fn background =>
let
val propss = burrow (map (rpair []) o Syntax.read_props ctxt) raw_propss;
val i = serial ();
@@ -69,8 +69,7 @@
val (a, background') = background
|> ML_Antiquote.variant "lemma" ||> put_thms (i, the_thms ctxt' i);
val ml =
- (thm_bind (if length (flat propss) = 1 then "thm" else "thms") a i,
- struct_name ^ "." ^ a);
+ (thm_bind (if length (flat propss) = 1 then "thm" else "thms") a i, "Isabelle." ^ a);
in (K ml, background') end));
end;
--- a/src/Pure/Proof/proof_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Proof/proof_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -47,15 +47,15 @@
|> Sign.root_path
|> Sign.add_defsort_i []
|> Sign.add_types [(Binding.name "proof", 0, NoSyn)]
- |> Sign.add_consts_i
- [(Binding.name "Appt", [proofT, aT] ---> proofT, Mixfix ("(1_ %/ _)", [4, 5], 4)),
- (Binding.name "AppP", [proofT, proofT] ---> proofT, Mixfix ("(1_ %%/ _)", [4, 5], 4)),
- (Binding.name "Abst", (aT --> proofT) --> proofT, NoSyn),
- (Binding.name "AbsP", [propT, proofT --> proofT] ---> proofT, NoSyn),
- (Binding.name "Hyp", propT --> proofT, NoSyn),
- (Binding.name "Oracle", propT --> proofT, NoSyn),
- (Binding.name "OfClass", (Term.a_itselfT --> propT) --> proofT, NoSyn),
- (Binding.name "MinProof", proofT, Delimfix "?")]
+ |> fold (snd oo Sign.declare_const)
+ [((Binding.name "Appt", [proofT, aT] ---> proofT), Mixfix ("(1_ %/ _)", [4, 5], 4)),
+ ((Binding.name "AppP", [proofT, proofT] ---> proofT), Mixfix ("(1_ %%/ _)", [4, 5], 4)),
+ ((Binding.name "Abst", (aT --> proofT) --> proofT), NoSyn),
+ ((Binding.name "AbsP", [propT, proofT --> proofT] ---> proofT), NoSyn),
+ ((Binding.name "Hyp", propT --> proofT), NoSyn),
+ ((Binding.name "Oracle", propT --> proofT), NoSyn),
+ ((Binding.name "OfClass", (Term.a_itselfT --> propT) --> proofT), NoSyn),
+ ((Binding.name "MinProof", proofT), Delimfix "?")]
|> Sign.add_nonterminals [Binding.name "param", Binding.name "params"]
|> Sign.add_syntax_i
[("_Lam", [paramsT, proofT] ---> proofT, Mixfix ("(1Lam _./ _)", [0, 3], 3)),
@@ -65,10 +65,10 @@
("", paramT --> paramT, Delimfix "'(_')"),
("", idtT --> paramsT, Delimfix "_"),
("", paramT --> paramsT, Delimfix "_")]
- |> Sign.add_modesyntax_i ("xsymbols", true)
+ |> Sign.add_modesyntax_i (Symbol.xsymbolsN, true)
[("_Lam", [paramsT, proofT] ---> proofT, Mixfix ("(1\\<Lambda>_./ _)", [0, 3], 3)),
- ("Appt", [proofT, aT] ---> proofT, Mixfix ("(1_ \\<cdot>/ _)", [4, 5], 4)),
- ("AppP", [proofT, proofT] ---> proofT, Mixfix ("(1_ \\<bullet>/ _)", [4, 5], 4))]
+ (Syntax.constN ^ "Appt", [proofT, aT] ---> proofT, Mixfix ("(1_ \\<cdot>/ _)", [4, 5], 4)),
+ (Syntax.constN ^ "AppP", [proofT, proofT] ---> proofT, Mixfix ("(1_ \\<bullet>/ _)", [4, 5], 4))]
|> Sign.add_modesyntax_i ("latex", false)
[("_Lam", [paramsT, proofT] ---> proofT, Mixfix ("(1\\<^bold>\\<lambda>_./ _)", [0, 3], 3))]
|> Sign.add_trrules_i (map Syntax.ParsePrintRule
@@ -78,10 +78,10 @@
[Variable "l", Syntax.mk_appl (Constant "_Lam") [Variable "m", Variable "A"]]),
(Syntax.mk_appl (Constant "_Lam")
[Syntax.mk_appl (Constant "_Lam1") [Variable "x", Variable "A"], Variable "B"],
- Syntax.mk_appl (Constant "AbsP") [Variable "A",
+ Syntax.mk_appl (Constant (Syntax.constN ^ "AbsP")) [Variable "A",
(Syntax.mk_appl (Constant "_abs") [Variable "x", Variable "B"])]),
(Syntax.mk_appl (Constant "_Lam") [Variable "x", Variable "A"],
- Syntax.mk_appl (Constant "Abst")
+ Syntax.mk_appl (Constant (Syntax.constN ^ "Abst"))
[(Syntax.mk_appl (Constant "_abs") [Variable "x", Variable "A"])])]);
--- a/src/Pure/ROOT.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/ROOT.ML Fri Feb 19 15:21:57 2010 +0000
@@ -57,6 +57,10 @@
use "Concurrent/simple_thread.ML";
+use "Concurrent/single_assignment.ML";
+if Multithreading.available then ()
+else use "Concurrent/single_assignment_sequential.ML";
+
use "Concurrent/synchronized.ML";
if Multithreading.available then ()
else use "Concurrent/synchronized_sequential.ML";
--- a/src/Pure/Syntax/mixfix.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Syntax/mixfix.ML Fri Feb 19 15:21:57 2010 +0000
@@ -10,12 +10,9 @@
NoSyn |
Mixfix of string * int list * int |
Delimfix of string |
- InfixName of string * int |
- InfixlName of string * int |
- InfixrName of string * int |
- Infix of int | (*obsolete*)
- Infixl of int | (*obsolete*)
- Infixr of int | (*obsolete*)
+ Infix of string * int |
+ Infixl of string * int |
+ Infixr of string * int |
Binder of string * int * int |
Structure
val binder_name: string -> string
@@ -27,9 +24,6 @@
val literal: string -> mixfix
val no_syn: 'a * 'b -> 'a * 'b * mixfix
val pretty_mixfix: mixfix -> Pretty.T
- val type_name: mixfix -> string -> string
- val const_name: mixfix -> string -> string
- val const_mixfix: string -> mixfix -> string * mixfix
val mixfix_args: mixfix -> int
val mixfixT: mixfix -> typ
end;
@@ -51,12 +45,9 @@
NoSyn |
Mixfix of string * int list * int |
Delimfix of string |
- InfixName of string * int |
- InfixlName of string * int |
- InfixrName of string * int |
- Infix of int | (*obsolete*)
- Infixl of int | (*obsolete*)
- Infixr of int | (*obsolete*)
+ Infix of string * int |
+ Infixl of string * int |
+ Infixr of string * int |
Binder of string * int * int |
Structure;
@@ -81,12 +72,9 @@
| pretty_mixfix (Mixfix (s, ps, p)) =
parens (Pretty.breaks [quoted s, brackets (Pretty.commas (map int ps)), int p])
| pretty_mixfix (Delimfix s) = parens [quoted s]
- | pretty_mixfix (InfixName (s, p)) = parens (Pretty.breaks [keyword "infix", quoted s, int p])
- | pretty_mixfix (InfixlName (s, p)) = parens (Pretty.breaks [keyword "infixl", quoted s, int p])
- | pretty_mixfix (InfixrName (s, p)) = parens (Pretty.breaks [keyword "infixl", quoted s, int p])
- | pretty_mixfix (Infix p) = parens (Pretty.breaks [keyword "infix", int p])
- | pretty_mixfix (Infixl p) = parens (Pretty.breaks [keyword "infixl", int p])
- | pretty_mixfix (Infixr p) = parens (Pretty.breaks [keyword "infixr", int p])
+ | pretty_mixfix (Infix (s, p)) = parens (Pretty.breaks [keyword "infix", quoted s, int p])
+ | pretty_mixfix (Infixl (s, p)) = parens (Pretty.breaks [keyword "infixl", quoted s, int p])
+ | pretty_mixfix (Infixr (s, p)) = parens (Pretty.breaks [keyword "infixl", quoted s, int p])
| pretty_mixfix (Binder (s, p1, p2)) =
parens (Pretty.breaks [keyword "binder", quoted s, brackets [int p1], int p2])
| pretty_mixfix Structure = parens [keyword "structure"];
@@ -96,47 +84,12 @@
(* syntax specifications *)
-fun strip ("'" :: c :: cs) = c :: strip cs
- | strip ["'"] = []
- | strip (c :: cs) = c :: strip cs
- | strip [] = [];
-
-val strip_esc = implode o strip o Symbol.explode;
-
-fun deprecated c = (legacy_feature ("Unnamed infix operator " ^ quote c); c);
-
-fun type_name (InfixName _) = I
- | type_name (InfixlName _) = I
- | type_name (InfixrName _) = I
- | type_name (Infix _) = deprecated o strip_esc
- | type_name (Infixl _) = deprecated o strip_esc
- | type_name (Infixr _) = deprecated o strip_esc
- | type_name _ = I;
-
-fun const_name (InfixName _) = I
- | const_name (InfixlName _) = I
- | const_name (InfixrName _) = I
- | const_name (Infix _) = prefix "op " o deprecated o strip_esc
- | const_name (Infixl _) = prefix "op " o deprecated o strip_esc
- | const_name (Infixr _) = prefix "op " o deprecated o strip_esc
- | const_name _ = I;
-
-fun fix_mixfix c (Infix p) = InfixName (c, p)
- | fix_mixfix c (Infixl p) = InfixlName (c, p)
- | fix_mixfix c (Infixr p) = InfixrName (c, p)
- | fix_mixfix _ mx = mx;
-
-fun const_mixfix c mx = (const_name mx c, fix_mixfix c mx);
-
fun mixfix_args NoSyn = 0
| mixfix_args (Mixfix (sy, _, _)) = SynExt.mfix_args sy
| mixfix_args (Delimfix sy) = SynExt.mfix_args sy
- | mixfix_args (InfixName (sy, _)) = 2 + SynExt.mfix_args sy
- | mixfix_args (InfixlName (sy, _)) = 2 + SynExt.mfix_args sy
- | mixfix_args (InfixrName (sy, _)) = 2 + SynExt.mfix_args sy
- | mixfix_args (Infix _) = 2
- | mixfix_args (Infixl _) = 2
- | mixfix_args (Infixr _) = 2
+ | mixfix_args (Infix (sy, _)) = 2 + SynExt.mfix_args sy
+ | mixfix_args (Infixl (sy, _)) = 2 + SynExt.mfix_args sy
+ | mixfix_args (Infixr (sy, _)) = 2 + SynExt.mfix_args sy
| mixfix_args (Binder _) = 1
| mixfix_args Structure = 0;
@@ -148,27 +101,19 @@
fun syn_ext_types type_decls =
let
- fun name_of (t, _, mx) = type_name mx t;
-
fun mk_infix sy t p1 p2 p3 =
SynExt.Mfix ("(_ " ^ sy ^ "/ _)",
[SynExt.typeT, SynExt.typeT] ---> SynExt.typeT, t, [p1, p2], p3);
- fun mfix_of decl =
- let val t = name_of decl in
- (case decl of
- (_, _, NoSyn) => NONE
- | (_, 2, InfixName (sy, p)) => SOME (mk_infix sy t (p + 1) (p + 1) p)
- | (_, 2, InfixlName (sy, p)) => SOME (mk_infix sy t p (p + 1) p)
- | (_, 2, InfixrName (sy, p)) => SOME (mk_infix sy t (p + 1) p p)
- | (sy, 2, Infix p) => SOME (mk_infix sy t (p + 1) (p + 1) p)
- | (sy, 2, Infixl p) => SOME (mk_infix sy t p (p + 1) p)
- | (sy, 2, Infixr p) => SOME (mk_infix sy t (p + 1) p p)
- | _ => error ("Bad mixfix declaration for type: " ^ quote t))
- end;
+ fun mfix_of (_, _, NoSyn) = NONE
+ | mfix_of (t, 2, Infix (sy, p)) = SOME (mk_infix sy t (p + 1) (p + 1) p)
+ | mfix_of (t, 2, Infixl (sy, p)) = SOME (mk_infix sy t p (p + 1) p)
+ | mfix_of (t, 2, Infixr (sy, p)) = SOME (mk_infix sy t (p + 1) p p)
+ | mfix_of (t, _, _) =
+ error ("Bad mixfix declaration for type: " ^ quote t); (* FIXME printable!? *)
val mfix = map_filter mfix_of type_decls;
- val xconsts = map name_of type_decls;
+ val xconsts = map #1 type_decls;
in SynExt.syn_ext mfix xconsts ([], [], [], []) [] ([], []) end;
@@ -179,8 +124,6 @@
fun syn_ext_consts is_logtype const_decls =
let
- fun name_of (c, _, mx) = const_name mx c;
-
fun mk_infix sy ty c p1 p2 p3 =
[SynExt.Mfix ("op " ^ sy, ty, c, [], SynExt.max_pri),
SynExt.Mfix ("(_ " ^ sy ^ "/ _)", ty, c, [p1, p2], p3)];
@@ -189,33 +132,27 @@
[Type ("idts", []), ty2] ---> ty3
| binder_typ c _ = error ("Bad type of binder: " ^ quote c);
- fun mfix_of decl =
- let val c = name_of decl in
- (case decl of
- (_, _, NoSyn) => []
- | (_, ty, Mixfix (sy, ps, p)) => [SynExt.Mfix (sy, ty, c, ps, p)]
- | (_, ty, Delimfix sy) => [SynExt.Mfix (sy, ty, c, [], SynExt.max_pri)]
- | (_, ty, InfixName (sy, p)) => mk_infix sy ty c (p + 1) (p + 1) p
- | (_, ty, InfixlName (sy, p)) => mk_infix sy ty c p (p + 1) p
- | (_, ty, InfixrName (sy, p)) => mk_infix sy ty c (p + 1) p p
- | (sy, ty, Infix p) => mk_infix sy ty c (p + 1) (p + 1) p
- | (sy, ty, Infixl p) => mk_infix sy ty c p (p + 1) p
- | (sy, ty, Infixr p) => mk_infix sy ty c (p + 1) p p
- | (_, ty, Binder (sy, p, q)) =>
- [SynExt.Mfix ("(3" ^ sy ^ "_./ _)", binder_typ c ty, (binder_name c), [0, p], q)]
- | _ => error ("Bad mixfix declaration for const: " ^ quote c))
- end;
+ fun mfix_of (_, _, NoSyn) = []
+ | mfix_of (c, ty, Mixfix (sy, ps, p)) = [SynExt.Mfix (sy, ty, c, ps, p)]
+ | mfix_of (c, ty, Delimfix sy) = [SynExt.Mfix (sy, ty, c, [], SynExt.max_pri)]
+ | mfix_of (c, ty, Infix (sy, p)) = mk_infix sy ty c (p + 1) (p + 1) p
+ | mfix_of (c, ty, Infixl (sy, p)) = mk_infix sy ty c p (p + 1) p
+ | mfix_of (c, ty, Infixr (sy, p)) = mk_infix sy ty c (p + 1) p p
+ | mfix_of (c, ty, Binder (sy, p, q)) =
+ [SynExt.Mfix ("(3" ^ sy ^ "_./ _)", binder_typ c ty, (binder_name c), [0, p], q)]
+ | mfix_of (c, _, _) = error ("Bad mixfix declaration for const: " ^ quote c);
fun binder (c, _, Binder _) = SOME (binder_name c, c)
| binder _ = NONE;
val mfix = maps mfix_of const_decls;
- val xconsts = map name_of const_decls;
+ val xconsts = map #1 const_decls;
val binders = map_filter binder const_decls;
- val binder_trs = binders |> map (SynExt.stamp_trfun binder_stamp o
- apsnd K o SynTrans.mk_binder_tr);
- val binder_trs' = binders |> map (SynExt.stamp_trfun binder_stamp o
- apsnd (K o SynTrans.non_typed_tr') o SynTrans.mk_binder_tr' o swap);
+ val binder_trs = binders
+ |> map (SynExt.stamp_trfun binder_stamp o apsnd K o SynTrans.mk_binder_tr);
+ val binder_trs' = binders
+ |> map (SynExt.stamp_trfun binder_stamp o
+ apsnd (K o SynTrans.non_typed_tr') o SynTrans.mk_binder_tr' o swap);
in
SynExt.syn_ext' true is_logtype
mfix xconsts ([], binder_trs, binder_trs', []) [] ([], [])
--- a/src/Pure/Syntax/syn_ext.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Syntax/syn_ext.ML Fri Feb 19 15:21:57 2010 +0000
@@ -401,7 +401,7 @@
Mfix ("'(_')", spropT --> spropT, "", [0], max_pri),
Mfix ("_::_", [logicT, typeT] ---> logicT, "_constrain", [4, 0], 3),
Mfix ("_::_", [spropT, typeT] ---> spropT, "_constrain", [4, 0], 3)]
- []
+ standard_token_markers
([], [], [], [])
[]
([], []);
--- a/src/Pure/Syntax/syn_trans.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Syntax/syn_trans.ML Fri Feb 19 15:21:57 2010 +0000
@@ -19,6 +19,7 @@
val antiquote_tr': string -> term -> term
val quote_tr': string -> term -> term
val quote_antiquote_tr': string -> string -> string -> string * (term list -> term)
+ val update_name_tr': term -> term
val mark_bound: string -> term
val mark_boundT: string * typ -> term
val bound_vars: (string * typ) list -> term -> term
@@ -187,6 +188,15 @@
in (quoteN, tr) end;
+(* corresponding updates *)
+
+fun update_name_tr (Free (x, T) :: ts) = list_comb (Free (suffix "_update" x, T), ts)
+ | update_name_tr (Const (x, T) :: ts) = list_comb (Const (suffix "_update" x, T), ts)
+ | update_name_tr (((c as Const ("_constrain", _)) $ t $ ty) :: ts) =
+ list_comb (c $ update_name_tr [t] $ (Lexicon.const "fun" $ ty $ Lexicon.const "dummy"), ts)
+ | update_name_tr ts = raise TERM ("update_name_tr", ts);
+
+
(* indexed syntax *)
fun struct_ast_tr (*"_struct"*) [Ast.Appl [Ast.Constant "_index", ast]] = ast
@@ -444,6 +454,19 @@
in (name, tr') end;
+(* corresponding updates *)
+
+fun upd_tr' (x_upd, T) =
+ (case try (unsuffix "_update") x_upd of
+ SOME x => (x, if T = dummyT then T else Term.domain_type T)
+ | NONE => raise Match);
+
+fun update_name_tr' (Free x) = Free (upd_tr' x)
+ | update_name_tr' ((c as Const ("_free", _)) $ Free x) = c $ Free (upd_tr' x)
+ | update_name_tr' (Const x) = Const (upd_tr' x)
+ | update_name_tr' _ = raise Match;
+
+
(* indexed syntax *)
fun index_ast_tr' (*"_index"*) [Ast.Appl [Ast.Constant "_struct", ast]] = ast
@@ -468,17 +491,31 @@
(** Pure translations **)
val pure_trfuns =
- ([("_constify", constify_ast_tr), ("_appl", appl_ast_tr), ("_applC", applC_ast_tr),
- ("_lambda", lambda_ast_tr), ("_idtyp", idtyp_ast_tr), ("_idtypdummy", idtypdummy_ast_tr),
- ("_bigimpl", bigimpl_ast_tr), ("_indexdefault", indexdefault_ast_tr),
- ("_indexnum", indexnum_ast_tr), ("_indexvar", indexvar_ast_tr), ("_struct", struct_ast_tr)],
- [("_abs", abs_tr), ("_aprop", aprop_tr), ("_ofclass", ofclass_tr),
- ("_sort_constraint", sort_constraint_tr), ("_TYPE", type_tr),
- ("_DDDOT", dddot_tr), ("_index", index_tr)],
- ([]: (string * (term list -> term)) list),
- [("_abs", abs_ast_tr'), ("_idts", idtyp_ast_tr' "_idts"),
- ("_pttrns", idtyp_ast_tr' "_pttrns"), ("==>", impl_ast_tr'),
- ("_index", index_ast_tr')]);
+ ([("_constify", constify_ast_tr),
+ ("_appl", appl_ast_tr),
+ ("_applC", applC_ast_tr),
+ ("_lambda", lambda_ast_tr),
+ ("_idtyp", idtyp_ast_tr),
+ ("_idtypdummy", idtypdummy_ast_tr),
+ ("_bigimpl", bigimpl_ast_tr),
+ ("_indexdefault", indexdefault_ast_tr),
+ ("_indexnum", indexnum_ast_tr),
+ ("_indexvar", indexvar_ast_tr),
+ ("_struct", struct_ast_tr)],
+ [("_abs", abs_tr),
+ ("_aprop", aprop_tr),
+ ("_ofclass", ofclass_tr),
+ ("_sort_constraint", sort_constraint_tr),
+ ("_TYPE", type_tr),
+ ("_DDDOT", dddot_tr),
+ ("_update_name", update_name_tr),
+ ("_index", index_tr)],
+ ([]: (string * (term list -> term)) list),
+ [("_abs", abs_ast_tr'),
+ ("_idts", idtyp_ast_tr' "_idts"),
+ ("_pttrns", idtyp_ast_tr' "_pttrns"),
+ ("==>", impl_ast_tr'),
+ ("_index", index_ast_tr')]);
val pure_trfunsT =
[("_type_prop", type_prop_tr'), ("TYPE", type_tr'), ("_type_constraint_", type_constraint_tr')];
--- a/src/Pure/Syntax/syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Syntax/syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -54,6 +54,7 @@
PrintRule of 'a * 'a |
ParsePrintRule of 'a * 'a
val map_trrule: ('a -> 'b) -> 'a trrule -> 'b trrule
+ val is_const: syntax -> string -> bool
val standard_unparse_term: (string -> xstring) ->
Proof.context -> syntax -> bool -> term -> Pretty.T
val standard_unparse_typ: Proof.context -> syntax -> typ -> Pretty.T
@@ -449,9 +450,9 @@
fun guess_infix (Syntax ({gram, ...}, _)) c =
(case Parser.guess_infix_lr gram c of
SOME (s, l, r, j) => SOME
- (if l then Mixfix.InfixlName (s, j)
- else if r then Mixfix.InfixrName (s, j)
- else Mixfix.InfixName (s, j))
+ (if l then Mixfix.Infixl (s, j)
+ else if r then Mixfix.Infixr (s, j)
+ else Mixfix.Infix (s, j))
| NONE => NONE);
@@ -592,6 +593,8 @@
| print_rule (ParsePrintRule pats) = SOME (swap pats);
+fun is_const (Syntax ({consts, ...}, _)) c = member (op =) consts c;
+
local
fun check_rule (rule as (lhs, rhs)) =
@@ -603,11 +606,9 @@
fun read_pattern ctxt is_logtype syn (root, str) =
let
- val Syntax ({consts, ...}, _) = syn;
-
fun constify (ast as Ast.Constant _) = ast
| constify (ast as Ast.Variable x) =
- if member (op =) consts x orelse Long_Name.is_qualified x then Ast.Constant x
+ if is_const syn x orelse Long_Name.is_qualified x then Ast.Constant x
else ast
| constify (Ast.Appl asts) = Ast.Appl (map constify asts);
@@ -913,8 +914,8 @@
end;
-structure BasicSyntax: BASIC_SYNTAX = Syntax;
-open BasicSyntax;
+structure Basic_Syntax: BASIC_SYNTAX = Syntax;
+open Basic_Syntax;
forget_structure "Ast";
forget_structure "SynExt";
--- a/src/Pure/System/isabelle_system.scala Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/System/isabelle_system.scala Fri Feb 19 15:21:57 2010 +0000
@@ -162,7 +162,7 @@
/** system tools **/
- def system_out(script: String): (String, Int) =
+ def bash_output(script: String): (String, Int) =
{
Standard_System.with_tmp_file("isabelle_script") { script_file =>
Standard_System.with_tmp_file("isabelle_pid") { pid_file =>
@@ -170,8 +170,7 @@
Standard_System.write_file(script_file, script)
- val proc = execute(true, "perl", "-w",
- expand_path("$ISABELLE_HOME/lib/scripts/system.pl"), "group",
+ val proc = execute(true, expand_path("$ISABELLE_HOME/lib/scripts/bash"), "group",
script_file.getPath, pid_file.getPath, output_file.getPath)
def kill(strict: Boolean) =
@@ -310,20 +309,29 @@
val font_family = "IsabelleText"
- private def check_font(): Boolean =
- new Font(font_family, Font.PLAIN, 1).getFamily == font_family
-
- private def create_font(name: String) =
- Font.createFont(Font.TRUETYPE_FONT, platform_file(name))
+ def get_font(bold: Boolean): Font =
+ new Font(font_family, if (bold) Font.BOLD else Font.PLAIN, 1)
def install_fonts()
{
+ def create_font(bold: Boolean): Font =
+ {
+ val name =
+ if (bold) "$ISABELLE_HOME/lib/fonts/IsabelleTextBold.ttf"
+ else "$ISABELLE_HOME/lib/fonts/IsabelleText.ttf"
+ Font.createFont(Font.TRUETYPE_FONT, platform_file(name))
+ }
+ def check_font() = get_font(false).getFamily == font_family
+
if (!check_font()) {
+ val font = create_font(false)
+ val bold_font = create_font(true)
+
val ge = GraphicsEnvironment.getLocalGraphicsEnvironment()
- ge.registerFont(create_font("$ISABELLE_HOME/lib/fonts/IsabelleText.ttf"))
- ge.registerFont(create_font("$ISABELLE_HOME/lib/fonts/IsabelleTextBold.ttf"))
- if (!check_font())
- error("Failed to install IsabelleText fonts")
+ ge.registerFont(font)
+ // workaround strange problem with Apple's Java 1.6 font manager
+ if (bold_font.getFamily == font_family) ge.registerFont(bold_font)
+ if (!check_font()) error("Failed to install IsabelleText fonts")
}
}
}
--- a/src/Pure/System/platform.scala Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/System/platform.scala Fri Feb 19 15:21:57 2010 +0000
@@ -55,15 +55,15 @@
/* Swing look-and-feel */
+ private def find_laf(name: String): Option[String] =
+ UIManager.getInstalledLookAndFeels().find(_.getName == name).map(_.getClassName)
+
def look_and_feel(): String =
{
if (is_windows || is_macos) UIManager.getSystemLookAndFeelClassName()
- else {
- UIManager.getInstalledLookAndFeels().find(laf => laf.getName == "Nimbus") match {
- case None => UIManager.getCrossPlatformLookAndFeelClassName()
- case Some(laf) => laf.getClassName
- }
- }
+ else
+ find_laf("Nimbus") orElse find_laf("GTK+") getOrElse
+ UIManager.getCrossPlatformLookAndFeelClassName()
}
}
--- a/src/Pure/System/session.scala Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/System/session.scala Fri Feb 19 15:21:57 2010 +0000
@@ -122,14 +122,13 @@
// global status message
result.body match {
- // document state assigment
+ // document state assignment
case List(XML.Elem(Markup.ASSIGN, _, edits)) if target_id.isDefined =>
documents.get(target_id.get) match {
case Some(doc) =>
val states =
for {
- XML.Elem(Markup.EDIT, (Markup.ID, cmd_id) :: (Markup.STATE, state_id) :: _, _)
- <- edits
+ XML.Elem(Markup.EDIT, (Markup.ID, cmd_id) :: (Markup.STATE, state_id) :: _, _) <- edits
cmd <- lookup_command(cmd_id)
} yield {
val st = cmd.assign_state(state_id)
--- a/src/Pure/Thy/completion.scala Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Thy/completion.scala Fri Feb 19 15:21:57 2010 +0000
@@ -88,12 +88,11 @@
abbrevs_lex.parse(abbrevs_lex.keyword, new Library.Reverse(line)) match {
case abbrevs_lex.Success(rev_a, _) =>
val (word, c) = abbrevs_map(rev_a)
- if (word == c) None
- else Some(word, List(c))
+ Some(word, List(c))
case _ =>
Completion.Parse.read(line) match {
case Some(word) =>
- words_lex.completions(word).map(words_map(_)).filter(_ != word) match {
+ words_lex.completions(word).map(words_map(_)) match {
case Nil => None
case cs => Some(word, cs.sort(_ < _))
}
--- a/src/Pure/Thy/present.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/Thy/present.ML Fri Feb 19 15:21:57 2010 +0000
@@ -328,7 +328,7 @@
\-n '" ^ name ^ "' -t '" ^ tags ^ "' " ^ File.shell_path path ^ " 2>&1";
val doc_path = Path.append result_path (Path.ext format (Path.basic name));
val _ = if verbose then writeln s else ();
- val (out, rc) = system_out s;
+ val (out, rc) = bash_output s;
val _ =
if not (File.exists doc_path) orelse rc <> 0 then
cat_error out ("Failed to build document " ^ quote (show_path doc_path))
--- a/src/Pure/axclass.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/axclass.ML Fri Feb 19 15:21:57 2010 +0000
@@ -286,23 +286,25 @@
(* declaration and definition of instances of overloaded constants *)
-fun inst_tyco_of thy (c, T) = case get_inst_tyco (Sign.consts_of thy) (c, T)
- of SOME tyco => tyco
- | NONE => error ("Illegal type for instantiation of class parameter: "
- ^ quote (c ^ " :: " ^ Syntax.string_of_typ_global thy T));
+fun inst_tyco_of thy (c, T) =
+ (case get_inst_tyco (Sign.consts_of thy) (c, T) of
+ SOME tyco => tyco
+ | NONE => error ("Illegal type for instantiation of class parameter: " ^
+ quote (c ^ " :: " ^ Syntax.string_of_typ_global thy T)));
fun declare_overloaded (c, T) thy =
let
- val class = case class_of_param thy c
- of SOME class => class
- | NONE => error ("Not a class parameter: " ^ quote c);
+ val class =
+ (case class_of_param thy c of
+ SOME class => class
+ | NONE => error ("Not a class parameter: " ^ quote c));
val tyco = inst_tyco_of thy (c, T);
val name_inst = instance_name (tyco, class) ^ "_inst";
val c' = Long_Name.base_name c ^ "_" ^ Long_Name.base_name tyco;
val T' = Type.strip_sorts T;
in
thy
- |> Sign.mandatory_path name_inst
+ |> Sign.qualified_path true (Binding.name name_inst)
|> Sign.declare_const ((Binding.name c', T'), NoSyn)
|-> (fn const' as Const (c'', _) =>
Thm.add_def false true
@@ -311,8 +313,8 @@
#-> (fn thm => add_inst_param (c, tyco) (c'', thm)
#> PureThy.add_thm ((Binding.conceal (Binding.name c'), thm), [])
#> snd
- #> Sign.restore_naming thy
#> pair (Const (c, T))))
+ ||> Sign.restore_naming thy
end;
fun define_overloaded b (c, t) thy =
@@ -482,12 +484,12 @@
val class_triv = Thm.class_triv def_thy class;
val ([(_, [intro]), (_, classrel), (_, axioms)], facts_thy) =
def_thy
- |> Sign.mandatory_path (Binding.name_of bconst)
+ |> Sign.qualified_path true bconst
|> PureThy.note_thmss ""
- [((Binding.name introN, []), [([Drule.standard raw_intro], [])]),
- ((Binding.name superN, []), [(map Drule.standard raw_classrel, [])]),
+ [((Binding.name introN, []), [([Drule.export_without_context raw_intro], [])]),
+ ((Binding.name superN, []), [(map Drule.export_without_context raw_classrel, [])]),
((Binding.name axiomsN, []),
- [(map (fn th => Drule.standard (class_triv RS th)) raw_axioms, [])])]
+ [(map (fn th => Drule.export_without_context (class_triv RS th)) raw_axioms, [])])]
||> Sign.restore_naming def_thy;
@@ -497,7 +499,7 @@
val result_thy =
facts_thy
|> fold put_classrel (map (pair class) super ~~ classrel)
- |> Sign.add_path (Binding.name_of bconst)
+ |> Sign.qualified_path false bconst
|> PureThy.note_thmss "" (name_atts ~~ map Thm.simple_fact (unflat axiomss axioms)) |> snd
|> Sign.restore_naming facts_thy
|> map_axclasses (fn (axclasses, parameters) =>
--- a/src/Pure/display.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/display.ML Fri Feb 19 15:21:57 2010 +0000
@@ -125,7 +125,7 @@
fun pretty_full_theory verbose thy =
let
- val ctxt = ProofContext.init thy;
+ val ctxt = Syntax.init_pretty_global thy;
fun prt_cls c = Syntax.pretty_sort ctxt [c];
fun prt_sort S = Syntax.pretty_sort ctxt S;
--- a/src/Pure/drule.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/drule.ML Fri Feb 19 15:21:57 2010 +0000
@@ -75,8 +75,8 @@
val beta_conv: cterm -> cterm -> cterm
val types_sorts: thm -> (indexname-> typ option) * (indexname-> sort option)
val flexflex_unique: thm -> thm
- val standard: thm -> thm
- val standard': thm -> thm
+ val export_without_context: thm -> thm
+ val export_without_context_open: thm -> thm
val get_def: theory -> xstring -> thm
val store_thm: binding -> thm -> thm
val store_standard_thm: binding -> thm -> thm
@@ -303,9 +303,9 @@
| _ => raise THM("flexflex_unique: multiple unifiers", 0, [th]);
-(* legacy standard operations *)
+(* old-style export without context *)
-val standard' =
+val export_without_context_open =
implies_intr_hyps
#> forall_intr_frees
#> `Thm.maxidx_of
@@ -315,9 +315,9 @@
#> zero_var_indexes
#> Thm.varifyT);
-val standard =
+val export_without_context =
flexflex_unique
- #> standard'
+ #> export_without_context_open
#> Thm.close_derivation;
@@ -459,8 +459,8 @@
fun store_thm_open name th =
Context.>>> (Context.map_theory_result (PureThy.store_thm_open (name, th)));
-fun store_standard_thm name th = store_thm name (standard th);
-fun store_standard_thm_open name thm = store_thm_open name (standard' thm);
+fun store_standard_thm name th = store_thm name (export_without_context th);
+fun store_standard_thm_open name thm = store_thm_open name (export_without_context_open thm);
val reflexive_thm =
let val cx = certify (Var(("x",0),TVar(("'a",0),[])))
@@ -708,12 +708,12 @@
val protect = Thm.capply (certify Logic.protectC);
val protectI =
- store_thm (Binding.conceal (Binding.name "protectI"))
- (standard (Thm.equal_elim (Thm.symmetric prop_def) (Thm.assume A)));
+ store_standard_thm (Binding.conceal (Binding.name "protectI"))
+ (Thm.equal_elim (Thm.symmetric prop_def) (Thm.assume A));
val protectD =
- store_thm (Binding.conceal (Binding.name "protectD"))
- (standard (Thm.equal_elim prop_def (Thm.assume (protect A))));
+ store_standard_thm (Binding.conceal (Binding.name "protectD"))
+ (Thm.equal_elim prop_def (Thm.assume (protect A)));
val protect_cong =
store_standard_thm_open (Binding.name "protect_cong") (Thm.reflexive (protect A));
@@ -730,8 +730,8 @@
(* term *)
val termI =
- store_thm (Binding.conceal (Binding.name "termI"))
- (standard (Thm.equal_elim (Thm.symmetric term_def) (Thm.forall_intr A (Thm.trivial A))));
+ store_standard_thm (Binding.conceal (Binding.name "termI"))
+ (Thm.equal_elim (Thm.symmetric term_def) (Thm.forall_intr A (Thm.trivial A)));
fun mk_term ct =
let
@@ -759,15 +759,14 @@
(* sort_constraint *)
val sort_constraintI =
- store_thm (Binding.conceal (Binding.name "sort_constraintI"))
- (standard (Thm.equal_elim (Thm.symmetric sort_constraint_def) (mk_term T)));
+ store_standard_thm (Binding.conceal (Binding.name "sort_constraintI"))
+ (Thm.equal_elim (Thm.symmetric sort_constraint_def) (mk_term T));
val sort_constraint_eq =
- store_thm (Binding.conceal (Binding.name "sort_constraint_eq"))
- (standard
- (Thm.equal_intr
- (Thm.implies_intr CA (Thm.implies_elim (Thm.assume CA) (Thm.unvarify sort_constraintI)))
- (implies_intr_list [A, C] (Thm.assume A))));
+ store_standard_thm (Binding.conceal (Binding.name "sort_constraint_eq"))
+ (Thm.equal_intr
+ (Thm.implies_intr CA (Thm.implies_elim (Thm.assume CA) (Thm.unvarify sort_constraintI)))
+ (implies_intr_list [A, C] (Thm.assume A)));
end;
@@ -983,5 +982,5 @@
end;
-structure BasicDrule: BASIC_DRULE = Drule;
-open BasicDrule;
+structure Basic_Drule: BASIC_DRULE = Drule;
+open Basic_Drule;
--- a/src/Pure/goal.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/goal.ML Fri Feb 19 15:21:57 2010 +0000
@@ -210,7 +210,7 @@
fun prove ctxt xs asms prop tac = hd (prove_common true ctxt xs asms [prop] tac);
fun prove_global thy xs asms prop tac =
- Drule.standard (prove (ProofContext.init thy) xs asms prop tac);
+ Drule.export_without_context (prove (ProofContext.init thy) xs asms prop tac);
--- a/src/Pure/old_goals.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/old_goals.ML Fri Feb 19 15:21:57 2010 +0000
@@ -305,7 +305,7 @@
val th = Goal.conclude ath
val thy' = Thm.theory_of_thm th
val {hyps, prop, ...} = Thm.rep_thm th
- val final_th = Drule.standard th
+ val final_th = Drule.export_without_context th
in if not check then final_th
else if not (Theory.eq_thy(thy,thy')) then !result_error_fn state
("Theory of proof state has changed!" ^
@@ -512,7 +512,7 @@
0 => thm
| i => !result_error_fn thm (string_of_int i ^ " unsolved goals!"))
in
- Drule.standard (implies_intr_list As
+ Drule.export_without_context (implies_intr_list As
(check (Seq.pull (EVERY (f asms) (trivial B)))))
end;
--- a/src/Pure/pattern.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/pattern.ML Fri Feb 19 15:21:57 2010 +0000
@@ -29,6 +29,7 @@
val pattern: term -> bool
val match_rew: theory -> term -> term * term -> (term * term) option
val rewrite_term: theory -> (term * term) list -> (term -> term option) list -> term -> term
+ val rewrite_term_top: theory -> (term * term) list -> (term -> term option) list -> term -> term
exception Unif
exception MATCH
exception Pattern
@@ -432,7 +433,7 @@
handle MATCH => NONE
end;
-fun rewrite_term thy rules procs tm =
+fun gen_rewrite_term bot thy rules procs tm =
let
val skel0 = Bound 0;
@@ -448,42 +449,53 @@
NONE => Option.map (rpair skel0) (get_first (fn p => p tm) procs)
| x => x);
- fun rew1 bounds (Var _) _ = NONE
- | rew1 bounds skel tm = (case rew2 bounds skel tm of
- SOME tm1 => (case rew tm1 of
- SOME (tm2, skel') => SOME (the_default tm2 (rew1 bounds skel' tm2))
- | NONE => SOME tm1)
- | NONE => (case rew tm of
- SOME (tm1, skel') => SOME (the_default tm1 (rew1 bounds skel' tm1))
- | NONE => NONE))
-
- and rew2 bounds skel (tm1 $ tm2) = (case tm1 of
+ fun rew_sub r bounds skel (tm1 $ tm2) = (case tm1 of
Abs (_, _, body) =>
let val tm' = subst_bound (tm2, body)
- in SOME (the_default tm' (rew2 bounds skel0 tm')) end
+ in SOME (the_default tm' (rew_sub r bounds skel0 tm')) end
| _ =>
let val (skel1, skel2) = (case skel of
skel1 $ skel2 => (skel1, skel2)
| _ => (skel0, skel0))
- in case rew1 bounds skel1 tm1 of
- SOME tm1' => (case rew1 bounds skel2 tm2 of
+ in case r bounds skel1 tm1 of
+ SOME tm1' => (case r bounds skel2 tm2 of
SOME tm2' => SOME (tm1' $ tm2')
| NONE => SOME (tm1' $ tm2))
- | NONE => (case rew1 bounds skel2 tm2 of
+ | NONE => (case r bounds skel2 tm2 of
SOME tm2' => SOME (tm1 $ tm2')
| NONE => NONE)
end)
- | rew2 bounds skel (Abs body) =
+ | rew_sub r bounds skel (Abs body) =
let
val (abs, tm') = variant_absfree bounds body;
val skel' = (case skel of Abs (_, _, skel') => skel' | _ => skel0)
- in case rew1 (bounds + 1) skel' tm' of
+ in case r (bounds + 1) skel' tm' of
SOME tm'' => SOME (abs tm'')
| NONE => NONE
end
- | rew2 _ _ _ = NONE;
+ | rew_sub _ _ _ _ = NONE;
+
+ fun rew_bot bounds (Var _) _ = NONE
+ | rew_bot bounds skel tm = (case rew_sub rew_bot bounds skel tm of
+ SOME tm1 => (case rew tm1 of
+ SOME (tm2, skel') => SOME (the_default tm2 (rew_bot bounds skel' tm2))
+ | NONE => SOME tm1)
+ | NONE => (case rew tm of
+ SOME (tm1, skel') => SOME (the_default tm1 (rew_bot bounds skel' tm1))
+ | NONE => NONE));
- in the_default tm (rew1 0 skel0 tm) end;
+ fun rew_top bounds _ tm = (case rew tm of
+ SOME (tm1, _) => (case rew_sub rew_top bounds skel0 tm1 of
+ SOME tm2 => SOME (the_default tm2 (rew_top bounds skel0 tm2))
+ | NONE => SOME tm1)
+ | NONE => (case rew_sub rew_top bounds skel0 tm of
+ SOME tm1 => SOME (the_default tm1 (rew_top bounds skel0 tm1))
+ | NONE => NONE));
+
+ in the_default tm ((if bot then rew_bot else rew_top) 0 skel0 tm) end;
+
+val rewrite_term = gen_rewrite_term true;
+val rewrite_term_top = gen_rewrite_term false;
end;
--- a/src/Pure/pure_thy.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/pure_thy.ML Fri Feb 19 15:21:57 2010 +0000
@@ -309,11 +309,12 @@
("_indexdefault", typ "index", Delimfix ""),
("_indexvar", typ "index", Delimfix "'\\<index>"),
("_struct", typ "index => logic", Mixfix ("\\<struct>_", [1000], 1000)),
+ ("_update_name", typ "idt", NoSyn),
("==>", typ "prop => prop => prop", Delimfix "op ==>"),
(Term.dummy_patternN, typ "aprop", Delimfix "'_"),
("_sort_constraint", typ "type => prop", Delimfix "(1SORT'_CONSTRAINT/(1'(_')))"),
("Pure.term", typ "logic => prop", Delimfix "TERM _"),
- ("Pure.conjunction", typ "prop => prop => prop", InfixrName ("&&&", 2))]
+ ("Pure.conjunction", typ "prop => prop => prop", Infixr ("&&&", 2))]
#> Sign.add_syntax_i applC_syntax
#> Sign.add_modesyntax_i (Symbol.xsymbolsN, true)
[("fun", typ "type => type => type", Mixfix ("(_/ \\<Rightarrow> _)", [1, 0], 0)),
@@ -325,9 +326,9 @@
("_idtypdummy", typ "type => idt", Mixfix ("'_()\\<Colon>_", [], 0)),
("_type_constraint_", typ "'a", NoSyn),
("_lambda", typ "pttrns => 'a => logic", Mixfix ("(3\\<lambda>_./ _)", [0, 3], 3)),
- ("==", typ "'a => 'a => prop", InfixrName ("\\<equiv>", 2)),
+ ("==", typ "'a => 'a => prop", Infixr ("\\<equiv>", 2)),
("all_binder", typ "idts => prop => prop", Mixfix ("(3\\<And>_./ _)", [0, 0], 0)),
- ("==>", typ "prop => prop => prop", InfixrName ("\\<Longrightarrow>", 1)),
+ ("==>", typ "prop => prop => prop", Infixr ("\\<Longrightarrow>", 1)),
("_DDDOT", typ "aprop", Delimfix "\\<dots>"),
("_bigimpl", typ "asms => prop => prop", Mixfix ("((1\\<lbrakk>_\\<rbrakk>)/ \\<Longrightarrow> _)", [0, 1], 1)),
("_DDDOT", typ "logic", Delimfix "\\<dots>")]
@@ -336,7 +337,7 @@
#> Sign.add_modesyntax_i ("HTML", false)
[("_lambda", typ "pttrns => 'a => logic", Mixfix ("(3\\<lambda>_./ _)", [0, 3], 3))]
#> Sign.add_consts_i
- [(Binding.name "==", typ "'a => 'a => prop", InfixrName ("==", 2)),
+ [(Binding.name "==", typ "'a => 'a => prop", Infixr ("==", 2)),
(Binding.name "==>", typ "prop => prop => prop", Mixfix ("(_/ ==> _)", [2, 1], 1)),
(Binding.name "all", typ "('a => prop) => prop", Binder ("!!", 0, 0)),
(Binding.name "prop", typ "prop => prop", NoSyn),
--- a/src/Pure/sign.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/sign.ML Fri Feb 19 15:21:57 2010 +0000
@@ -127,6 +127,7 @@
val root_path: theory -> theory
val parent_path: theory -> theory
val mandatory_path: string -> theory -> theory
+ val qualified_path: bool -> binding -> theory -> theory
val local_path: theory -> theory
val restore_naming: theory -> theory -> theory
val hide_class: bool -> string -> theory -> theory
@@ -434,7 +435,7 @@
fun add_types types thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
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 decls = map (fn (a, n, _) => (a, n)) types;
val tsig' = fold (Type.add_type naming) decls tsig;
in (naming, syn', tsig', consts) end);
@@ -450,12 +451,11 @@
(* add type abbreviations *)
-fun gen_add_tyabbr parse_typ (a, vs, rhs, mx) thy =
+fun gen_add_tyabbr parse_typ (b, vs, rhs, mx) thy =
thy |> map_sign (fn (naming, syn, tsig, consts) =>
let
val ctxt = ProofContext.init thy;
- val syn' = Syntax.update_type_gram [(Name.of_binding a, length vs, mx)] syn;
- val b = Binding.map_name (Syntax.type_name mx) a;
+ val syn' = Syntax.update_type_gram [(Name.of_binding b, length vs, mx)] syn;
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;
@@ -471,8 +471,7 @@
let
val ctxt = ProofContext.init thy;
fun prep (c, T, mx) = (c, certify_typ_mode Type.mode_syntax thy (parse_typ ctxt T), mx)
- handle ERROR msg =>
- cat_error msg ("in syntax declaration " ^ quote (Syntax.const_name mx c));
+ handle ERROR msg => cat_error msg ("in syntax declaration " ^ quote c);
in thy |> map_syn (change_gram (is_logtype thy) mode (map prep args)) end;
fun gen_add_syntax x = gen_syntax Syntax.update_const_gram x;
@@ -500,10 +499,8 @@
let
val ctxt = ProofContext.init thy;
val prepT = Type.no_tvars o Term.no_dummyT o certify_typ thy o parse_typ ctxt;
- fun prep (raw_b, raw_T, raw_mx) =
+ fun prep (b, raw_T, mx) =
let
- val (mx_name, mx) = Syntax.const_mixfix (Name.of_binding raw_b) raw_mx;
- val b = Binding.map_name (K mx_name) raw_b;
val c = full_name thy b;
val c_syn = if authentic then Syntax.constN ^ c else Name.of_binding b;
val T = (prepT raw_T handle TYPE (msg, _, _) => error msg) handle ERROR msg =>
@@ -618,6 +615,7 @@
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;
+val qualified_path = map_naming oo Name_Space.qualified_path;
fun local_path thy = thy |> root_path |> add_path (Context.theory_name thy);
--- a/src/Pure/type_infer.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Pure/type_infer.ML Fri Feb 19 15:21:57 2010 +0000
@@ -284,7 +284,7 @@
| meets _ tye_idx = tye_idx;
- (* occurs check and assigment *)
+ (* occurs check and assignment *)
fun occurs_check tye i (Param (i', S)) =
if i = i' then raise NO_UNIFIER ("Occurs check!", tye)
--- a/src/Sequents/ILL.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/ILL.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: Sequents/ILL.thy
- ID: $Id$
Author: Sara Kalvala and Valeria de Paiva
Copyright 1995 University of Cambridge
*)
@@ -32,19 +31,21 @@
PromAux :: "three_seqi"
syntax
- "@Trueprop" :: "single_seqe" ("((_)/ |- (_))" [6,6] 5)
- "@Context" :: "two_seqe" ("((_)/ :=: (_))" [6,6] 5)
- "@PromAux" :: "three_seqe" ("promaux {_||_||_}")
+ "_Trueprop" :: "single_seqe" ("((_)/ |- (_))" [6,6] 5)
+ "_Context" :: "two_seqe" ("((_)/ :=: (_))" [6,6] 5)
+ "_PromAux" :: "three_seqe" ("promaux {_||_||_}")
parse_translation {*
- [("@Trueprop", single_tr "Trueprop"),
- ("@Context", two_seq_tr "Context"),
- ("@PromAux", three_seq_tr "PromAux")] *}
+ [(@{syntax_const "_Trueprop"}, single_tr @{const_syntax Trueprop}),
+ (@{syntax_const "_Context"}, two_seq_tr @{const_syntax Context}),
+ (@{syntax_const "_PromAux"}, three_seq_tr @{const_syntax PromAux})]
+*}
print_translation {*
- [("Trueprop", single_tr' "@Trueprop"),
- ("Context", two_seq_tr'"@Context"),
- ("PromAux", three_seq_tr'"@PromAux")] *}
+ [(@{const_syntax Trueprop}, single_tr' @{syntax_const "_Trueprop"}),
+ (@{const_syntax Context}, two_seq_tr' @{syntax_const "_Context"}),
+ (@{const_syntax PromAux}, three_seq_tr' @{syntax_const "_PromAux"})]
+*}
defs
--- a/src/Sequents/ILL_predlog.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/ILL_predlog.thy Fri Feb 19 15:21:57 2010 +0000
@@ -22,8 +22,8 @@
"[* A & B *]" == "[*A*] && [*B*]"
"[* A | B *]" == "![*A*] ++ ![*B*]"
- "[* - A *]" == "[*A > ff*]"
- "[* ff *]" == "0"
+ "[* - A *]" == "[*A > CONST ff*]"
+ "[* XCONST ff *]" == "0"
"[* A = B *]" => "[* (A > B) & (B > A) *]"
"[* A > B *]" == "![*A*] -o [*B*]"
--- a/src/Sequents/LK0.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/LK0.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,10 +1,9 @@
(* Title: LK/LK0.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1993 University of Cambridge
There may be printing problems if a seqent is in expanded normal form
- (eta-expanded, beta-contracted)
+(eta-expanded, beta-contracted).
*)
header {* Classical First-Order Sequent Calculus *}
@@ -35,10 +34,10 @@
Ex :: "('a => o) => o" (binder "EX " 10)
syntax
- "@Trueprop" :: "two_seqe" ("((_)/ |- (_))" [6,6] 5)
+ "_Trueprop" :: "two_seqe" ("((_)/ |- (_))" [6,6] 5)
-parse_translation {* [("@Trueprop", two_seq_tr "Trueprop")] *}
-print_translation {* [("Trueprop", two_seq_tr' "@Trueprop")] *}
+parse_translation {* [(@{syntax_const "_Trueprop"}, two_seq_tr @{const_syntax Trueprop})] *}
+print_translation {* [(@{const_syntax Trueprop}, two_seq_tr' @{syntax_const "_Trueprop"})] *}
abbreviation
not_equal (infixl "~=" 50) where
--- a/src/Sequents/Modal0.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/Modal0.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: Sequents/Modal0.thy
- ID: $Id$
Author: Martin Coen
Copyright 1991 University of Cambridge
*)
@@ -18,21 +17,23 @@
Rstar :: "two_seqi"
syntax
- "@Lstar" :: "two_seqe" ("(_)|L>(_)" [6,6] 5)
- "@Rstar" :: "two_seqe" ("(_)|R>(_)" [6,6] 5)
+ "_Lstar" :: "two_seqe" ("(_)|L>(_)" [6,6] 5)
+ "_Rstar" :: "two_seqe" ("(_)|R>(_)" [6,6] 5)
ML {*
- val Lstar = "Lstar";
- val Rstar = "Rstar";
- val SLstar = "@Lstar";
- val SRstar = "@Rstar";
-
- fun star_tr c [s1,s2] = Const(c,dummyT)$ seq_tr s1$ seq_tr s2;
- fun star_tr' c [s1,s2] = Const(c,dummyT) $ seq_tr' s1 $ seq_tr' s2;
+ fun star_tr c [s1, s2] = Const(c, dummyT) $ seq_tr s1 $ seq_tr s2;
+ fun star_tr' c [s1, s2] = Const(c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
*}
-parse_translation {* [(SLstar,star_tr Lstar), (SRstar,star_tr Rstar)] *}
-print_translation {* [(Lstar,star_tr' SLstar), (Rstar,star_tr' SRstar)] *}
+parse_translation {*
+ [(@{syntax_const "_Lstar"}, star_tr @{const_syntax Lstar}),
+ (@{syntax_const "_Rstar"}, star_tr @{const_syntax Rstar})]
+*}
+
+print_translation {*
+ [(@{const_syntax Lstar}, star_tr' @{syntax_const "_Lstar"}),
+ (@{const_syntax Rstar}, star_tr' @{syntax_const "_Rstar"})]
+*}
defs
strimp_def: "P --< Q == [](P --> Q)"
--- a/src/Sequents/S43.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/S43.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: Modal/S43.thy
- ID: $Id$
Author: Martin Coen
Copyright 1991 University of Cambridge
@@ -14,25 +13,24 @@
S43pi :: "[seq'=>seq', seq'=>seq', seq'=>seq',
seq'=>seq', seq'=>seq', seq'=>seq'] => prop"
syntax
- "@S43pi" :: "[seq, seq, seq, seq, seq, seq] => prop"
+ "_S43pi" :: "[seq, seq, seq, seq, seq, seq] => prop"
("S43pi((_);(_);(_);(_);(_);(_))" [] 5)
-ML {*
- val S43pi = "S43pi";
- val SS43pi = "@S43pi";
-
- val tr = seq_tr;
- val tr' = seq_tr';
-
- fun s43pi_tr[s1,s2,s3,s4,s5,s6]=
- Const(S43pi,dummyT)$tr s1$tr s2$tr s3$tr s4$tr s5$tr s6;
- fun s43pi_tr'[s1,s2,s3,s4,s5,s6] =
- Const(SS43pi,dummyT)$tr' s1$tr' s2$tr' s3$tr' s4$tr' s5$tr' s6;
-
+parse_translation {*
+ let
+ val tr = seq_tr;
+ fun s43pi_tr [s1, s2, s3, s4, s5, s6] =
+ Const (@{const_syntax S43pi}, dummyT) $ tr s1 $ tr s2 $ tr s3 $ tr s4 $ tr s5 $ tr s6;
+ in [(@{syntax_const "_S43pi"}, s43pi_tr)] end
*}
-parse_translation {* [(SS43pi,s43pi_tr)] *}
-print_translation {* [(S43pi,s43pi_tr')] *}
+print_translation {*
+let
+ val tr' = seq_tr';
+ fun s43pi_tr' [s1, s2, s3, s4, s5, s6] =
+ Const(@{syntax_const "_S43pi"}, dummyT) $ tr' s1 $ tr' s2 $ tr' s3 $ tr' s4 $ tr' s5 $ tr' s6;
+in [(@{const_syntax S43pi}, s43pi_tr')] end
+*}
axioms
(* Definition of the star operation using a set of Horn clauses *)
--- a/src/Sequents/Sequents.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/Sequents.thy Fri Feb 19 15:21:57 2010 +0000
@@ -1,5 +1,4 @@
(* Title: Sequents/Sequents.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1993 University of Cambridge
*)
@@ -36,14 +35,14 @@
syntax
- SeqEmp :: seq ("")
- SeqApp :: "[seqobj,seqcont] => seq" ("__")
+ "_SeqEmp" :: seq ("")
+ "_SeqApp" :: "[seqobj,seqcont] => seq" ("__")
- SeqContEmp :: seqcont ("")
- SeqContApp :: "[seqobj,seqcont] => seqcont" (",/ __")
+ "_SeqContEmp" :: seqcont ("")
+ "_SeqContApp" :: "[seqobj,seqcont] => seqcont" (",/ __")
- SeqO :: "o => seqobj" ("_")
- SeqId :: "'a => seqobj" ("$_")
+ "_SeqO" :: "o => seqobj" ("_")
+ "_SeqId" :: "'a => seqobj" ("$_")
types
single_seqe = "[seq,seqobj] => prop"
@@ -60,86 +59,76 @@
syntax
(*Constant to allow definitions of SEQUENCES of formulas*)
- "@Side" :: "seq=>(seq'=>seq')" ("<<(_)>>")
+ "_Side" :: "seq=>(seq'=>seq')" ("<<(_)>>")
ML {*
(* parse translation for sequences *)
-fun abs_seq' t = Abs("s", Type("seq'",[]), t);
+fun abs_seq' t = Abs ("s", Type ("seq'", []), t); (* FIXME @{type_syntax} *)
-fun seqobj_tr(Const("SeqO",_) $ f) = Const("SeqO'",dummyT) $ f |
- seqobj_tr(_ $ i) = i;
-
-fun seqcont_tr(Const("SeqContEmp",_)) = Bound 0 |
- seqcont_tr(Const("SeqContApp",_) $ so $ sc) =
- (seqobj_tr so) $ (seqcont_tr sc);
+fun seqobj_tr (Const (@{syntax_const "_SeqO"}, _) $ f) =
+ Const (@{const_syntax SeqO'}, dummyT) $ f
+ | seqobj_tr (_ $ i) = i;
-fun seq_tr(Const("SeqEmp",_)) = abs_seq'(Bound 0) |
- seq_tr(Const("SeqApp",_) $ so $ sc) =
- abs_seq'(seqobj_tr(so) $ seqcont_tr(sc));
+fun seqcont_tr (Const (@{syntax_const "_SeqContEmp"}, _)) = Bound 0
+ | seqcont_tr (Const (@{syntax_const "_SeqContApp"}, _) $ so $ sc) =
+ seqobj_tr so $ seqcont_tr sc;
+fun seq_tr (Const (@{syntax_const "_SeqEmp"}, _)) = abs_seq' (Bound 0)
+ | seq_tr (Const (@{syntax_const "_SeqApp"}, _) $ so $ sc) =
+ abs_seq'(seqobj_tr so $ seqcont_tr sc);
-fun singlobj_tr(Const("SeqO",_) $ f) =
- abs_seq' ((Const("SeqO'",dummyT) $ f) $ Bound 0);
-
+fun singlobj_tr (Const (@{syntax_const "_SeqO"},_) $ f) =
+ abs_seq' ((Const (@{const_syntax SeqO'}, dummyT) $ f) $ Bound 0);
(* print translation for sequences *)
fun seqcont_tr' (Bound 0) =
- Const("SeqContEmp",dummyT) |
- seqcont_tr' (Const("SeqO'",_) $ f $ s) =
- Const("SeqContApp",dummyT) $
- (Const("SeqO",dummyT) $ f) $
- (seqcont_tr' s) |
-(* seqcont_tr' ((a as Abs(_,_,_)) $ s)=
- seqcont_tr'(Term.betapply(a,s)) | *)
- seqcont_tr' (i $ s) =
- Const("SeqContApp",dummyT) $
- (Const("SeqId",dummyT) $ i) $
- (seqcont_tr' s);
+ Const (@{syntax_const "_SeqContEmp"}, dummyT)
+ | seqcont_tr' (Const (@{const_syntax SeqO'}, _) $ f $ s) =
+ Const (@{syntax_const "_SeqContApp"}, dummyT) $
+ (Const (@{syntax_const "_SeqO"}, dummyT) $ f) $ seqcont_tr' s
+ | seqcont_tr' (i $ s) =
+ Const (@{syntax_const "_SeqContApp"}, dummyT) $
+ (Const (@{syntax_const "_SeqId"}, dummyT) $ i) $ seqcont_tr' s;
fun seq_tr' s =
- let fun seq_itr' (Bound 0) =
- Const("SeqEmp",dummyT) |
- seq_itr' (Const("SeqO'",_) $ f $ s) =
- Const("SeqApp",dummyT) $
- (Const("SeqO",dummyT) $ f) $ (seqcont_tr' s) |
-(* seq_itr' ((a as Abs(_,_,_)) $ s) =
- seq_itr'(Term.betapply(a,s)) | *)
- seq_itr' (i $ s) =
- Const("SeqApp",dummyT) $
- (Const("SeqId",dummyT) $ i) $
- (seqcont_tr' s)
- in case s of
- Abs(_,_,t) => seq_itr' t |
- _ => s $ (Bound 0)
- end;
+ let
+ fun seq_itr' (Bound 0) = Const (@{syntax_const "_SeqEmp"}, dummyT)
+ | seq_itr' (Const (@{const_syntax SeqO'}, _) $ f $ s) =
+ Const (@{syntax_const "_SeqApp"}, dummyT) $
+ (Const (@{syntax_const "_SeqO"}, dummyT) $ f) $ seqcont_tr' s
+ | seq_itr' (i $ s) =
+ Const (@{syntax_const "_SeqApp"}, dummyT) $
+ (Const (@{syntax_const "_SeqId"}, dummyT) $ i) $ seqcont_tr' s
+ in
+ case s of
+ Abs (_, _, t) => seq_itr' t
+ | _ => s $ Bound 0
+ end;
+fun single_tr c [s1, s2] =
+ Const (c, dummyT) $ seq_tr s1 $ singlobj_tr s2;
+
+fun two_seq_tr c [s1, s2] =
+ Const (c, dummyT) $ seq_tr s1 $ seq_tr s2;
+
+fun three_seq_tr c [s1, s2, s3] =
+ Const (c, dummyT) $ seq_tr s1 $ seq_tr s2 $ seq_tr s3;
+
+fun four_seq_tr c [s1, s2, s3, s4] =
+ Const (c, dummyT) $ seq_tr s1 $ seq_tr s2 $ seq_tr s3 $ seq_tr s4;
-fun single_tr c [s1,s2] =
- Const(c,dummyT) $ seq_tr s1 $ singlobj_tr s2;
-
-fun two_seq_tr c [s1,s2] =
- Const(c,dummyT) $ seq_tr s1 $ seq_tr s2;
-
-fun three_seq_tr c [s1,s2,s3] =
- Const(c,dummyT) $ seq_tr s1 $ seq_tr s2 $ seq_tr s3;
-
-fun four_seq_tr c [s1,s2,s3,s4] =
- Const(c,dummyT) $ seq_tr s1 $ seq_tr s2 $ seq_tr s3 $ seq_tr s4;
-
-
-fun singlobj_tr'(Const("SeqO'",_) $ fm) = fm |
- singlobj_tr'(id) = Const("@SeqId",dummyT) $ id;
+fun singlobj_tr' (Const (@{const_syntax SeqO'},_) $ fm) = fm
+ | singlobj_tr' id = Const (@{syntax_const "_SeqId"}, dummyT) $ id;
fun single_tr' c [s1, s2] =
-(Const (c, dummyT) $ seq_tr' s1 $ seq_tr' s2 );
-
+ Const (c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
fun two_seq_tr' c [s1, s2] =
Const (c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
@@ -157,7 +146,7 @@
fun side_tr [s1] = seq_tr s1;
*}
-parse_translation {* [("@Side", side_tr)] *}
+parse_translation {* [(@{syntax_const "_Side"}, side_tr)] *}
use "prover.ML"
--- a/src/Sequents/simpdata.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Sequents/simpdata.ML Fri Feb 19 15:21:57 2010 +0000
@@ -49,9 +49,9 @@
(*Congruence rules for = or <-> (instead of ==)*)
fun mk_meta_cong rl =
- Drule.standard(mk_meta_eq (mk_meta_prems rl))
- handle THM _ =>
- error("Premises and conclusion of congruence rules must use =-equality or <->");
+ Drule.export_without_context(mk_meta_eq (mk_meta_prems rl))
+ handle THM _ =>
+ error("Premises and conclusion of congruence rules must use =-equality or <->");
(*** Standard simpsets ***)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Cache_IO/cache_io.ML Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,121 @@
+(* Title: Tools/Cache_IO/cache_io.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Cache for output of external processes.
+*)
+
+signature CACHE_IO =
+sig
+ val with_tmp_file: string -> (Path.T -> 'a) -> 'a
+ val run: (Path.T -> string) -> Path.T -> string list
+ val run': (Path.T -> Path.T -> string) -> Path.T -> string list * string list
+
+ type cache
+ val make: Path.T -> cache
+ val cache_path_of: cache -> Path.T
+ val cached: cache -> (Path.T -> string) -> Path.T -> string list
+ val cached': cache -> (Path.T -> Path.T -> string) -> Path.T ->
+ string list * string list
+end
+
+structure Cache_IO : CACHE_IO =
+struct
+
+fun with_tmp_file name f =
+ let
+ val path = File.tmp_path (Path.explode (name ^ serial_string ()))
+ val x = Exn.capture f path
+ val _ = try File.rm path
+ in Exn.release x end
+
+fun run' make_cmd in_path =
+ with_tmp_file "cache-io-" (fn out_path =>
+ let
+ val (out2, _) = bash_output (make_cmd in_path out_path)
+ val out1 = the_default [] (try (rev o File.fold_lines cons out_path) [])
+ in (out1, split_lines out2) end)
+
+fun run make_cmd = snd o run' (fn in_path => fn _ => make_cmd in_path)
+
+
+
+abstype cache = Cache of {
+ path: Path.T,
+ table: (int * (int * int * int) Symtab.table) Synchronized.var }
+with
+
+
+fun cache_path_of (Cache {path, ...}) = path
+
+
+fun load cache_path =
+ let
+ fun err () = error ("Cache IO: corrupted cache file: " ^
+ File.shell_path cache_path)
+
+ fun int_of_string s =
+ (case read_int (explode s) of
+ (i, []) => i
+ | _ => err ())
+
+ fun split line =
+ (case space_explode " " line of
+ [key, len1, len2] => (key, int_of_string len1, int_of_string len2)
+ | _ => err ())
+
+ fun parse line ((i, l), tab) =
+ if i = l
+ then
+ let val (key, l1, l2) = split line
+ in ((i+1, l+l1+l2+1), Symtab.update (key, (i+1, l1, l2)) tab) end
+ else ((i+1, l), tab)
+ in apfst fst (File.fold_lines parse cache_path ((1, 1), Symtab.empty)) end
+
+fun make path =
+ let val table = if File.exists path then load path else (1, Symtab.empty)
+ in Cache {path=path, table=Synchronized.var (Path.implode path) table} end
+
+
+fun get_hash_key path =
+ let
+ val arg = File.shell_path path
+ val (out, res) = bash_output (getenv "COMPUTE_HASH_KEY" ^ " " ^ arg)
+ in
+ if res = 0 then hd (split_lines out)
+ else error ("Cache IO: failed to generate hash key for file " ^ arg)
+ end
+
+fun load_cached_result cache_path (p, len1, len2) =
+ let
+ fun load line (i, xsp) =
+ if i < p then (i+1, xsp)
+ else if i < p + len1 then (i+1, apfst (cons line) xsp)
+ else if i < p + len2 then (i+1, apsnd (cons line) xsp)
+ else (i, xsp)
+ in pairself rev (snd (File.fold_lines load cache_path (1, ([], [])))) end
+
+fun cached' (Cache {path=cache_path, table}) make_cmd in_path =
+ let val key = get_hash_key in_path
+ in
+ (case Symtab.lookup (snd (Synchronized.value table)) key of
+ SOME pos => load_cached_result cache_path pos
+ | NONE =>
+ let
+ val res as (out, err) = run' make_cmd in_path
+ val (l1, l2) = pairself length res
+ val header = key ^ " " ^ string_of_int l1 ^ " " ^ string_of_int l2
+ val lines = map (suffix "\n") (header :: out @ err)
+
+ val _ = Synchronized.change table (fn (p, tab) =>
+ if Symtab.defined tab key then (p, tab)
+ else
+ let val _ = File.append_list cache_path lines
+ in (p+l1+l2+1, Symtab.update (key, (p+1, l1, l2)) tab) end)
+ in res end)
+ end
+
+fun cached cache make_cmd =
+ snd o cached' cache (fn in_path => fn _ => make_cmd in_path)
+
+end
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Cache_IO/etc/settings Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,4 @@
+ISABELLE_CACHE_IO="$COMPONENT"
+
+COMPUTE_HASH_KEY="$ISABELLE_CACHE_IO/lib/scripts/compute_hash_key"
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Cache_IO/lib/scripts/compute_hash_key Fri Feb 19 15:21:57 2010 +0000
@@ -0,0 +1,24 @@
+#!/usr/bin/env perl
+#
+# Author: Sascha Boehme, TU Muenchen
+#
+# Compute MD5 hash key.
+
+use strict;
+use warnings;
+use Digest::MD5;
+
+
+# argument
+
+my $file = $ARGV[0];
+
+
+# compute MD5 hash key
+
+my $md5 = Digest::MD5->new;
+open FILE, "<$file" or die "ERROR: Failed to open '$file' ($!)";
+$md5->addfile(*FILE);
+close FILE;
+print $md5->b64digest . "\n";
+
--- a/src/Tools/Code/code_eval.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Tools/Code/code_eval.ML Fri Feb 19 15:21:57 2010 +0000
@@ -107,25 +107,25 @@
val _ = map2 check_base constrs constrs'';
in "datatype " ^ tyco'' ^ " = datatype " ^ Long_Name.append all_struct_name tyco'' end;
-fun print_code struct_name is_first print_it ctxt =
+fun print_code is_first print_it ctxt =
let
val (_, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
val (ml_code, (tycos_map, consts_map)) = Lazy.force acc_code;
val ml_code = if is_first then ml_code
else "";
- val all_struct_name = Long_Name.append struct_name struct_code_name;
+ val all_struct_name = "Isabelle." ^ struct_code_name;
in (ml_code, print_it all_struct_name tycos_map consts_map) end;
in
-fun ml_code_antiq raw_const {struct_name, background} =
+fun ml_code_antiq raw_const background =
let
val const = Code.check_const (ProofContext.theory_of background) raw_const;
val is_first = is_first_occ background;
val background' = register_const const background;
- in (print_code struct_name is_first (print_const const), background') end;
+ in (print_code is_first (print_const const), background') end;
-fun ml_code_datatype_antiq (raw_tyco, raw_constrs) {struct_name, background} =
+fun ml_code_datatype_antiq (raw_tyco, raw_constrs) background =
let
val thy = ProofContext.theory_of background;
val tyco = Sign.intern_type thy raw_tyco;
@@ -135,7 +135,7 @@
else error ("Type " ^ quote tyco ^ ": given constructors diverge from real constructors")
val is_first = is_first_occ background;
val background' = register_datatype tyco constrs background;
- in (print_code struct_name is_first (print_datatype tyco constrs), background') end;
+ in (print_code is_first (print_datatype tyco constrs), background') end;
end; (*local*)
--- a/src/Tools/Compute_Oracle/am_ghc.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Tools/Compute_Oracle/am_ghc.ML Fri Feb 19 15:21:57 2010 +0000
@@ -228,7 +228,7 @@
val module_file = tmp_file (module^".hs")
val object_file = tmp_file (module^".o")
val _ = writeTextFile module_file source
- val _ = system ((!ghc)^" -c "^module_file)
+ val _ = bash ((!ghc)^" -c "^module_file)
val _ = if not (fileExists object_file) then raise Compile ("Failure compiling haskell code (GHC_PATH = '"^(!ghc)^"')") else ()
in
(guid, module_file, arity)
@@ -309,7 +309,7 @@
val term = print_term arity_of 0 t
val call_source = "module "^call^" where\n\nimport "^module^"\n\ncall = "^module^".calc \""^result_file^"\" ("^term^")"
val _ = writeTextFile call_file call_source
- val _ = system ((!ghc)^" -e \""^call^".call\" "^module_file^" "^call_file)
+ val _ = bash ((!ghc)^" -e \""^call^".call\" "^module_file^" "^call_file)
val result = readResultFile result_file handle IO.Io _ => raise Run ("Failure running haskell compiler (GHC_PATH = '"^(!ghc)^"')")
val t' = parse_result arity_of result
val _ = OS.FileSys.remove call_file
--- a/src/Tools/jEdit/README_BUILD Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Tools/jEdit/README_BUILD Fri Feb 19 15:21:57 2010 +0000
@@ -2,10 +2,10 @@
Requirements to build from sources
==================================
-* Proper Java JRE/JDK from Sun, e.g. 1.6.0_17
+* Proper Java JRE/JDK from Sun, e.g. 1.6.0_18
http://java.sun.com/javase/downloads/index.jsp
-* Netbeans 6.7
+* Netbeans 6.7.1
http://www.netbeans.org/downloads/index.html
* Scala for Netbeans: version 6.7v1 for NB 6.7
@@ -13,7 +13,7 @@
http://blogtrader.net/dcaoyuan/category/NetBeans
http://wiki.netbeans.org/Scala
-* jEdit 4.3 (final)
+* jEdit 4.3.1 (final)
http://www.jedit.org/
Netbeans Project "jEdit": install official sources as ./contrib/jEdit/.
--- a/src/Tools/jEdit/src/jedit/isabelle_sidekick.scala Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Tools/jEdit/src/jedit/isabelle_sidekick.scala Fri Feb 19 15:21:57 2010 +0000
@@ -88,11 +88,11 @@
case None => null
case Some((word, cs)) =>
val ds =
- if (Isabelle_Encoding.is_active(buffer))
+ (if (Isabelle_Encoding.is_active(buffer))
cs.map(Isabelle.system.symbols.decode(_)).sort(_ < _)
- else cs
- new SideKickCompletion(pane.getView, word, ds.toArray.asInstanceOf[Array[Object]]) { }
+ else cs).filter(_ != word)
+ if (ds.isEmpty) null
+ else new SideKickCompletion(pane.getView, word, ds.toArray.asInstanceOf[Array[Object]]) { }
}
}
-
}
--- a/src/Tools/quickcheck.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/Tools/quickcheck.ML Fri Feb 19 15:21:57 2010 +0000
@@ -153,9 +153,9 @@
|> ObjectLogic.atomize_term thy;
in test_term ctxt quiet generator_name size iterations gi' end;
-fun pretty_counterex ctxt NONE = Pretty.str "No counterexamples found."
+fun pretty_counterex ctxt NONE = Pretty.str "Quickcheck found no counterexample."
| pretty_counterex ctxt (SOME cex) =
- Pretty.chunks (Pretty.str "Counterexample found:\n" ::
+ Pretty.chunks (Pretty.str "Quickcheck found a counterexample:\n" ::
map (fn (s, t) =>
Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, Syntax.pretty_term ctxt t]) cex);
--- a/src/ZF/Bin.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Bin.thy Fri Feb 19 15:21:57 2010 +0000
@@ -26,11 +26,6 @@
| Min
| Bit ("w: bin", "b: bool") (infixl "BIT" 90)
-use "Tools/numeral_syntax.ML"
-
-syntax
- "_Int" :: "xnum => i" ("_")
-
consts
integ_of :: "i=>i"
NCons :: "[i,i]=>i"
@@ -106,7 +101,11 @@
"bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
NCons(bin_mult(v,w),0))"
-setup NumeralSyntax.setup
+syntax
+ "_Int" :: "xnum => i" ("_")
+
+use "Tools/numeral_syntax.ML"
+setup Numeral_Syntax.setup
declare bin.intros [simp,TC]
--- a/src/ZF/IMP/Com.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/IMP/Com.thy Fri Feb 19 15:21:57 2010 +0000
@@ -22,8 +22,10 @@
consts evala :: i
-syntax "_evala" :: "[i, i] => o" (infixl "-a->" 50)
-translations "p -a-> n" == "<p,n> \<in> evala"
+
+abbreviation
+ evala_syntax :: "[i, i] => o" (infixl "-a->" 50)
+ where "p -a-> n == <p,n> \<in> evala"
inductive
domains "evala" \<subseteq> "(aexp \<times> (loc -> nat)) \<times> nat"
@@ -50,8 +52,10 @@
consts evalb :: i
-syntax "_evalb" :: "[i,i] => o" (infixl "-b->" 50)
-translations "p -b-> b" == "<p,b> \<in> evalb"
+
+abbreviation
+ evalb_syntax :: "[i,i] => o" (infixl "-b->" 50)
+ where "p -b-> b == <p,b> \<in> evalb"
inductive
domains "evalb" \<subseteq> "(bexp \<times> (loc -> nat)) \<times> bool"
@@ -82,8 +86,10 @@
consts evalc :: i
-syntax "_evalc" :: "[i, i] => o" (infixl "-c->" 50)
-translations "p -c-> s" == "<p,s> \<in> evalc"
+
+abbreviation
+ evalc_syntax :: "[i, i] => o" (infixl "-c->" 50)
+ where "p -c-> s == <p,s> \<in> evalc"
inductive
domains "evalc" \<subseteq> "(com \<times> (loc -> nat)) \<times> (loc -> nat)"
--- a/src/ZF/Induct/Comb.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Induct/Comb.thy Fri Feb 19 15:21:57 2010 +0000
@@ -30,12 +30,14 @@
consts
contract :: i
-syntax
- "_contract" :: "[i,i] => o" (infixl "-1->" 50)
- "_contract_multi" :: "[i,i] => o" (infixl "--->" 50)
-translations
- "p -1-> q" == "<p,q> \<in> contract"
- "p ---> q" == "<p,q> \<in> contract^*"
+
+abbreviation
+ contract_syntax :: "[i,i] => o" (infixl "-1->" 50)
+ where "p -1-> q == <p,q> \<in> contract"
+
+abbreviation
+ contract_multi :: "[i,i] => o" (infixl "--->" 50)
+ where "p ---> q == <p,q> \<in> contract^*"
syntax (xsymbols)
"comb.app" :: "[i, i] => i" (infixl "\<bullet>" 90)
@@ -56,12 +58,14 @@
consts
parcontract :: i
-syntax
- "_parcontract" :: "[i,i] => o" (infixl "=1=>" 50)
- "_parcontract_multi" :: "[i,i] => o" (infixl "===>" 50)
-translations
- "p =1=> q" == "<p,q> \<in> parcontract"
- "p ===> q" == "<p,q> \<in> parcontract^+"
+
+abbreviation
+ parcontract_syntax :: "[i,i] => o" (infixl "=1=>" 50)
+ where "p =1=> q == <p,q> \<in> parcontract"
+
+abbreviation
+ parcontract_multi :: "[i,i] => o" (infixl "===>" 50)
+ where "p ===> q == <p,q> \<in> parcontract^+"
inductive
domains "parcontract" \<subseteq> "comb \<times> comb"
--- a/src/ZF/Induct/Multiset.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Induct/Multiset.thy Fri Feb 19 15:21:57 2010 +0000
@@ -74,9 +74,9 @@
"a :# M == a \<in> mset_of(M)"
syntax
- "@MColl" :: "[pttrn, i, o] => i" ("(1{# _ : _./ _#})")
+ "_MColl" :: "[pttrn, i, o] => i" ("(1{# _ : _./ _#})")
syntax (xsymbols)
- "@MColl" :: "[pttrn, i, o] => i" ("(1{# _ \<in> _./ _#})")
+ "_MColl" :: "[pttrn, i, o] => i" ("(1{# _ \<in> _./ _#})")
translations
"{#x \<in> M. P#}" == "CONST MCollect(M, %x. P)"
--- a/src/ZF/Induct/PropLog.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Induct/PropLog.thy Fri Feb 19 15:21:57 2010 +0000
@@ -34,8 +34,10 @@
subsection {* The proof system *}
consts thms :: "i => i"
-syntax "_thms" :: "[i,i] => o" (infixl "|-" 50)
-translations "H |- p" == "p \<in> thms(H)"
+
+abbreviation
+ thms_syntax :: "[i,i] => o" (infixl "|-" 50)
+ where "H |- p == p \<in> thms(H)"
inductive
domains "thms(H)" \<subseteq> "propn"
--- a/src/ZF/List_ZF.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/List_ZF.thy Fri Feb 19 15:21:57 2010 +0000
@@ -16,12 +16,12 @@
syntax
"[]" :: i ("[]")
- "@List" :: "is => i" ("[(_)]")
+ "_List" :: "is => i" ("[(_)]")
translations
- "[x, xs]" == "Cons(x, [xs])"
- "[x]" == "Cons(x, [])"
- "[]" == "Nil"
+ "[x, xs]" == "CONST Cons(x, [xs])"
+ "[x]" == "CONST Cons(x, [])"
+ "[]" == "CONST Nil"
consts
--- a/src/ZF/OrdQuant.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/OrdQuant.thy Fri Feb 19 15:21:57 2010 +0000
@@ -23,9 +23,9 @@
"OUnion(i,B) == {z: \<Union>x\<in>i. B(x). Ord(i)}"
syntax
- "@oall" :: "[idt, i, o] => o" ("(3ALL _<_./ _)" 10)
- "@oex" :: "[idt, i, o] => o" ("(3EX _<_./ _)" 10)
- "@OUNION" :: "[idt, i, i] => i" ("(3UN _<_./ _)" 10)
+ "_oall" :: "[idt, i, o] => o" ("(3ALL _<_./ _)" 10)
+ "_oex" :: "[idt, i, o] => o" ("(3EX _<_./ _)" 10)
+ "_OUNION" :: "[idt, i, i] => i" ("(3UN _<_./ _)" 10)
translations
"ALL x<a. P" == "CONST oall(a, %x. P)"
@@ -33,13 +33,13 @@
"UN x<a. B" == "CONST OUnion(a, %x. B)"
syntax (xsymbols)
- "@oall" :: "[idt, i, o] => o" ("(3\<forall>_<_./ _)" 10)
- "@oex" :: "[idt, i, o] => o" ("(3\<exists>_<_./ _)" 10)
- "@OUNION" :: "[idt, i, i] => i" ("(3\<Union>_<_./ _)" 10)
+ "_oall" :: "[idt, i, o] => o" ("(3\<forall>_<_./ _)" 10)
+ "_oex" :: "[idt, i, o] => o" ("(3\<exists>_<_./ _)" 10)
+ "_OUNION" :: "[idt, i, i] => i" ("(3\<Union>_<_./ _)" 10)
syntax (HTML output)
- "@oall" :: "[idt, i, o] => o" ("(3\<forall>_<_./ _)" 10)
- "@oex" :: "[idt, i, o] => o" ("(3\<exists>_<_./ _)" 10)
- "@OUNION" :: "[idt, i, i] => i" ("(3\<Union>_<_./ _)" 10)
+ "_oall" :: "[idt, i, o] => o" ("(3\<forall>_<_./ _)" 10)
+ "_oex" :: "[idt, i, o] => o" ("(3\<exists>_<_./ _)" 10)
+ "_OUNION" :: "[idt, i, i] => i" ("(3\<Union>_<_./ _)" 10)
subsubsection {*simplification of the new quantifiers*}
@@ -203,15 +203,15 @@
"rex(M, P) == EX x. M(x) & P(x)"
syntax
- "@rall" :: "[pttrn, i=>o, o] => o" ("(3ALL _[_]./ _)" 10)
- "@rex" :: "[pttrn, i=>o, o] => o" ("(3EX _[_]./ _)" 10)
+ "_rall" :: "[pttrn, i=>o, o] => o" ("(3ALL _[_]./ _)" 10)
+ "_rex" :: "[pttrn, i=>o, o] => o" ("(3EX _[_]./ _)" 10)
syntax (xsymbols)
- "@rall" :: "[pttrn, i=>o, o] => o" ("(3\<forall>_[_]./ _)" 10)
- "@rex" :: "[pttrn, i=>o, o] => o" ("(3\<exists>_[_]./ _)" 10)
+ "_rall" :: "[pttrn, i=>o, o] => o" ("(3\<forall>_[_]./ _)" 10)
+ "_rex" :: "[pttrn, i=>o, o] => o" ("(3\<exists>_[_]./ _)" 10)
syntax (HTML output)
- "@rall" :: "[pttrn, i=>o, o] => o" ("(3\<forall>_[_]./ _)" 10)
- "@rex" :: "[pttrn, i=>o, o] => o" ("(3\<exists>_[_]./ _)" 10)
+ "_rall" :: "[pttrn, i=>o, o] => o" ("(3\<forall>_[_]./ _)" 10)
+ "_rex" :: "[pttrn, i=>o, o] => o" ("(3\<exists>_[_]./ _)" 10)
translations
"ALL x[M]. P" == "CONST rall(M, %x. P)"
--- a/src/ZF/Tools/datatype_package.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Tools/datatype_package.ML Fri Feb 19 15:21:57 2010 +0000
@@ -292,7 +292,7 @@
rtac case_trans 1,
REPEAT (resolve_tac [refl, split_trans, Su.case_inl RS trans, Su.case_inr RS trans] 1)]);
- val free_iffs = map Drule.standard (con_defs RL [@{thm def_swap_iff}]);
+ val free_iffs = map Drule.export_without_context (con_defs RL [@{thm def_swap_iff}]);
val case_eqns = map prove_case_eqn (flat con_ty_lists ~~ case_args ~~ tl con_defs);
@@ -338,7 +338,7 @@
val constructors =
map (head_of o #1 o Logic.dest_equals o #prop o rep_thm) (tl con_defs);
- val free_SEs = map Drule.standard (Ind_Syntax.mk_free_SEs free_iffs);
+ val free_SEs = map Drule.export_without_context (Ind_Syntax.mk_free_SEs free_iffs);
val {intrs, elim, induct, mutual_induct, ...} = ind_result
--- a/src/ZF/Tools/inductive_package.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Tools/inductive_package.ML Fri Feb 19 15:21:57 2010 +0000
@@ -193,9 +193,9 @@
[rtac (@{thm Collect_subset} RS @{thm bnd_monoI}) 1,
REPEAT (ares_tac (@{thms basic_monos} @ monos) 1)]);
- val dom_subset = Drule.standard (big_rec_def RS Fp.subs);
+ val dom_subset = Drule.export_without_context (big_rec_def RS Fp.subs);
- val unfold = Drule.standard ([big_rec_def, bnd_mono] MRS Fp.Tarski);
+ val unfold = Drule.export_without_context ([big_rec_def, bnd_mono] MRS Fp.Tarski);
(********)
val dummy = writeln " Proving the introduction rules...";
@@ -205,7 +205,7 @@
val Part_trans =
case rec_names of
[_] => asm_rl
- | _ => Drule.standard (@{thm Part_subset} RS @{thm subset_trans});
+ | _ => Drule.export_without_context (@{thm Part_subset} RS @{thm subset_trans});
(*To type-check recursive occurrences of the inductive sets, possibly
enclosed in some monotonic operator M.*)
@@ -272,7 +272,7 @@
rule_by_tactic
(basic_elim_tac THEN ALLGOALS (asm_full_simp_tac ss) THEN basic_elim_tac)
(Thm.assume A RS elim)
- |> Drule.standard';
+ |> Drule.export_without_context_open;
fun induction_rules raw_induct thy =
let
@@ -503,7 +503,7 @@
val Const (@{const_name Trueprop}, _) $ (pred_var $ _) = concl_of induct0
val induct = CP.split_rule_var(pred_var, elem_type-->FOLogic.oT, induct0)
- |> Drule.standard
+ |> Drule.export_without_context
and mutual_induct = CP.remove_split mutual_induct_fsplit
val ([induct', mutual_induct'], thy') =
@@ -514,7 +514,7 @@
in ((thy', induct'), mutual_induct')
end; (*of induction_rules*)
- val raw_induct = Drule.standard ([big_rec_def, bnd_mono] MRS Fp.induct)
+ val raw_induct = Drule.export_without_context ([big_rec_def, bnd_mono] MRS Fp.induct)
val ((thy2, induct), mutual_induct) =
if not coind then induction_rules raw_induct thy1
--- a/src/ZF/Tools/numeral_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/Tools/numeral_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -7,92 +7,83 @@
signature NUMERAL_SYNTAX =
sig
- val dest_bin : term -> int
- val mk_bin : int -> term
- val int_tr : term list -> term
- val int_tr' : bool -> typ -> term list -> term
- val setup : theory -> theory
+ val make_binary: int -> int list
+ val dest_binary: int list -> int
+ val int_tr: term list -> term
+ val int_tr': bool -> typ -> term list -> term
+ val setup: theory -> theory
end;
-structure NumeralSyntax: NUMERAL_SYNTAX =
+structure Numeral_Syntax: NUMERAL_SYNTAX =
struct
-(* Bits *)
+(* bits *)
-fun mk_bit 0 = @{term "0"}
- | mk_bit 1 = @{term "succ(0)"}
+fun mk_bit 0 = Syntax.const @{const_syntax "0"}
+ | mk_bit 1 = Syntax.const @{const_syntax succ} $ Syntax.const @{const_syntax 0}
| mk_bit _ = sys_error "mk_bit";
-fun dest_bit (Const (@{const_name "0"}, _)) = 0
- | dest_bit (Const (@{const_name succ}, _) $ Const (@{const_name "0"}, _)) = 1
+fun dest_bit (Const (@{const_syntax "0"}, _)) = 0
+ | dest_bit (Const (@{const_syntax succ}, _) $ Const (@{const_syntax "0"}, _)) = 1
| dest_bit _ = raise Match;
-(* Bit strings *) (*we try to handle superfluous leading digits nicely*)
+(* bit strings *)
+
+fun make_binary 0 = []
+ | make_binary ~1 = [~1]
+ | make_binary n = (n mod 2) :: make_binary (n div 2);
+fun dest_binary [] = 0
+ | dest_binary (b :: bs) = b + 2 * dest_binary bs;
+
+
+(*try to handle superfluous leading digits nicely*)
fun prefix_len _ [] = 0
| prefix_len pred (x :: xs) =
if pred x then 1 + prefix_len pred xs else 0;
fun mk_bin i =
- let fun bin_of_int 0 = []
- | bin_of_int ~1 = [~1]
- | bin_of_int n = (n mod 2) :: bin_of_int (n div 2);
-
- fun term_of [] = @{const Pls}
- | term_of [~1] = @{const Min}
- | term_of (b :: bs) = @{const Bit} $ term_of bs $ mk_bit b;
- in
- term_of (bin_of_int i)
- end;
+ let
+ fun term_of [] = Syntax.const @{const_syntax Pls}
+ | term_of [~1] = Syntax.const @{const_syntax Min}
+ | term_of (b :: bs) = Syntax.const @{const_syntax Bit} $ term_of bs $ mk_bit b;
+ in term_of (make_binary i) end;
-(*we consider all "spellings", since they could vary depending on the caller*)
-fun bin_of (Const ("Pls", _)) = []
- | bin_of (Const ("bin.Pls", _)) = []
- | bin_of (Const ("Bin.bin.Pls", _)) = []
- | bin_of (Const ("Min", _)) = [~1]
- | bin_of (Const ("bin.Min", _)) = [~1]
- | bin_of (Const ("Bin.bin.Min", _)) = [~1]
- | bin_of (Const ("Bit", _) $ bs $ b) = dest_bit b :: bin_of bs
- | bin_of (Const ("bin.Bit", _) $ bs $ b) = dest_bit b :: bin_of bs
- | bin_of (Const ("Bin.bin.Bit", _) $ bs $ b) = dest_bit b :: bin_of bs
+fun bin_of (Const (@{const_syntax Pls}, _)) = []
+ | bin_of (Const (@{const_syntax Min}, _)) = [~1]
+ | bin_of (Const (@{const_syntax Bit}, _) $ bs $ b) = dest_bit b :: bin_of bs
| bin_of _ = raise Match;
-(*Convert a list of bits to an integer*)
-fun integ_of [] = 0
- | integ_of (b :: bs) = b + 2 * integ_of bs;
-
-val dest_bin = integ_of o bin_of;
-
-(*leading 0s and (for negative numbers) -1s cause complications, though they
+(*Leading 0s and (for negative numbers) -1s cause complications, though they
should never arise in normal use. The formalization used in HOL prevents
them altogether.*)
fun show_int t =
let
val rev_digs = bin_of t;
val (sign, zs) =
- (case rev rev_digs of
- ~1 :: bs => ("-", prefix_len (equal 1) bs)
- | bs => ("", prefix_len (equal 0) bs));
- val num = string_of_int (abs (integ_of rev_digs));
+ (case rev rev_digs of
+ ~1 :: bs => ("-", prefix_len (equal 1) bs)
+ | bs => ("", prefix_len (equal 0) bs));
+ val num = string_of_int (abs (dest_binary rev_digs));
in
"#" ^ sign ^ implode (replicate zs "0") ^ num
end;
-
(* translation of integer constant tokens to and from binary *)
fun int_tr (*"_Int"*) [t as Free (str, _)] =
- Syntax.const "integ_of" $ mk_bin (#value (Syntax.read_xnum str))
+ Syntax.const @{const_syntax integ_of} $ mk_bin (#value (Syntax.read_xnum str))
| int_tr (*"_Int"*) ts = raise TERM ("int_tr", ts);
-fun int_tr' _ _ (*"integ_of"*) [t] = Syntax.const "_Int" $ Syntax.free (show_int t)
- | int_tr' (_:bool) (_:typ) _ = raise Match;
+fun int_tr' _ _ (*"integ_of"*) [t] =
+ Syntax.const @{syntax_const "_Int"} $ Syntax.free (show_int t)
+ | int_tr' (_: bool) (_: typ) _ = raise Match;
val setup =
- (Sign.add_trfuns ([], [("_Int", int_tr)], [], []) #>
- Sign.add_trfunsT [("integ_of", int_tr'), ("Bin.integ_of", int_tr')]);
+ (Sign.add_trfuns ([], [(@{syntax_const "_Int"}, int_tr)], [], []) #>
+ Sign.add_trfunsT [(@{const_syntax integ_of}, int_tr')]);
end;
--- a/src/ZF/UNITY/Union.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/UNITY/Union.thy Fri Feb 19 15:21:57 2010 +0000
@@ -41,8 +41,8 @@
SKIP \<in> X & (\<forall>G \<in> program. Acts(G) \<subseteq> (\<Union>F \<in> X. Acts(F)) --> G \<in> X)"
syntax
- "@JOIN1" :: "[pttrns, i] => i" ("(3JN _./ _)" 10)
- "@JOIN" :: "[pttrn, i, i] => i" ("(3JN _:_./ _)" 10)
+ "_JOIN1" :: "[pttrns, i] => i" ("(3JN _./ _)" 10)
+ "_JOIN" :: "[pttrn, i, i] => i" ("(3JN _:_./ _)" 10)
translations
"JN x:A. B" == "CONST JOIN(A, (%x. B))"
@@ -54,8 +54,8 @@
Join (infixl "\<squnion>" 65)
syntax (xsymbols)
- "@JOIN1" :: "[pttrns, i] => i" ("(3\<Squnion> _./ _)" 10)
- "@JOIN" :: "[pttrn, i, i] => i" ("(3\<Squnion> _ \<in> _./ _)" 10)
+ "_JOIN1" :: "[pttrns, i] => i" ("(3\<Squnion> _./ _)" 10)
+ "_JOIN" :: "[pttrn, i, i] => i" ("(3\<Squnion> _ \<in> _./ _)" 10)
subsection{*SKIP*}
--- a/src/ZF/ZF.thy Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/ZF.thy Fri Feb 19 15:21:57 2010 +0000
@@ -105,45 +105,45 @@
syntax
"" :: "i => is" ("_")
- "@Enum" :: "[i, is] => is" ("_,/ _")
+ "_Enum" :: "[i, is] => is" ("_,/ _")
- "@Finset" :: "is => i" ("{(_)}")
- "@Tuple" :: "[i, is] => i" ("<(_,/ _)>")
- "@Collect" :: "[pttrn, i, o] => i" ("(1{_: _ ./ _})")
- "@Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _: _, _})")
- "@RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _: _})" [51,0,51])
- "@INTER" :: "[pttrn, i, i] => i" ("(3INT _:_./ _)" 10)
- "@UNION" :: "[pttrn, i, i] => i" ("(3UN _:_./ _)" 10)
- "@PROD" :: "[pttrn, i, i] => i" ("(3PROD _:_./ _)" 10)
- "@SUM" :: "[pttrn, i, i] => i" ("(3SUM _:_./ _)" 10)
- "@lam" :: "[pttrn, i, i] => i" ("(3lam _:_./ _)" 10)
- "@Ball" :: "[pttrn, i, o] => o" ("(3ALL _:_./ _)" 10)
- "@Bex" :: "[pttrn, i, o] => o" ("(3EX _:_./ _)" 10)
+ "_Finset" :: "is => i" ("{(_)}")
+ "_Tuple" :: "[i, is] => i" ("<(_,/ _)>")
+ "_Collect" :: "[pttrn, i, o] => i" ("(1{_: _ ./ _})")
+ "_Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _: _, _})")
+ "_RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _: _})" [51,0,51])
+ "_INTER" :: "[pttrn, i, i] => i" ("(3INT _:_./ _)" 10)
+ "_UNION" :: "[pttrn, i, i] => i" ("(3UN _:_./ _)" 10)
+ "_PROD" :: "[pttrn, i, i] => i" ("(3PROD _:_./ _)" 10)
+ "_SUM" :: "[pttrn, i, i] => i" ("(3SUM _:_./ _)" 10)
+ "_lam" :: "[pttrn, i, i] => i" ("(3lam _:_./ _)" 10)
+ "_Ball" :: "[pttrn, i, o] => o" ("(3ALL _:_./ _)" 10)
+ "_Bex" :: "[pttrn, i, o] => o" ("(3EX _:_./ _)" 10)
(** Patterns -- extends pre-defined type "pttrn" used in abstractions **)
- "@pattern" :: "patterns => pttrn" ("<_>")
+ "_pattern" :: "patterns => pttrn" ("<_>")
"" :: "pttrn => patterns" ("_")
- "@patterns" :: "[pttrn, patterns] => patterns" ("_,/_")
+ "_patterns" :: "[pttrn, patterns] => patterns" ("_,/_")
translations
- "{x, xs}" == "cons(x, {xs})"
- "{x}" == "cons(x, 0)"
- "{x:A. P}" == "Collect(A, %x. P)"
- "{y. x:A, Q}" == "Replace(A, %x y. Q)"
- "{b. x:A}" == "RepFun(A, %x. b)"
- "INT x:A. B" == "Inter({B. x:A})"
- "UN x:A. B" == "Union({B. x:A})"
- "PROD x:A. B" == "Pi(A, %x. B)"
- "SUM x:A. B" == "Sigma(A, %x. B)"
- "lam x:A. f" == "Lambda(A, %x. f)"
- "ALL x:A. P" == "Ball(A, %x. P)"
- "EX x:A. P" == "Bex(A, %x. P)"
+ "{x, xs}" == "CONST cons(x, {xs})"
+ "{x}" == "CONST cons(x, 0)"
+ "{x:A. P}" == "CONST Collect(A, %x. P)"
+ "{y. x:A, Q}" == "CONST Replace(A, %x y. Q)"
+ "{b. x:A}" == "CONST RepFun(A, %x. b)"
+ "INT x:A. B" == "CONST Inter({B. x:A})"
+ "UN x:A. B" == "CONST Union({B. x:A})"
+ "PROD x:A. B" == "CONST Pi(A, %x. B)"
+ "SUM x:A. B" == "CONST Sigma(A, %x. B)"
+ "lam x:A. f" == "CONST Lambda(A, %x. f)"
+ "ALL x:A. P" == "CONST Ball(A, %x. P)"
+ "EX x:A. P" == "CONST Bex(A, %x. P)"
"<x, y, z>" == "<x, <y, z>>"
- "<x, y>" == "Pair(x, y)"
- "%<x,y,zs>.b" == "split(%x <y,zs>.b)"
- "%<x,y>.b" == "split(%x y. b)"
+ "<x, y>" == "CONST Pair(x, y)"
+ "%<x,y,zs>.b" == "CONST split(%x <y,zs>.b)"
+ "%<x,y>.b" == "CONST split(%x y. b)"
notation (xsymbols)
@@ -158,18 +158,18 @@
Inter ("\<Inter>_" [90] 90)
syntax (xsymbols)
- "@Collect" :: "[pttrn, i, o] => i" ("(1{_ \<in> _ ./ _})")
- "@Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
- "@RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _ \<in> _})" [51,0,51])
- "@UNION" :: "[pttrn, i, i] => i" ("(3\<Union>_\<in>_./ _)" 10)
- "@INTER" :: "[pttrn, i, i] => i" ("(3\<Inter>_\<in>_./ _)" 10)
- "@PROD" :: "[pttrn, i, i] => i" ("(3\<Pi>_\<in>_./ _)" 10)
- "@SUM" :: "[pttrn, i, i] => i" ("(3\<Sigma>_\<in>_./ _)" 10)
- "@lam" :: "[pttrn, i, i] => i" ("(3\<lambda>_\<in>_./ _)" 10)
- "@Ball" :: "[pttrn, i, o] => o" ("(3\<forall>_\<in>_./ _)" 10)
- "@Bex" :: "[pttrn, i, o] => o" ("(3\<exists>_\<in>_./ _)" 10)
- "@Tuple" :: "[i, is] => i" ("\<langle>(_,/ _)\<rangle>")
- "@pattern" :: "patterns => pttrn" ("\<langle>_\<rangle>")
+ "_Collect" :: "[pttrn, i, o] => i" ("(1{_ \<in> _ ./ _})")
+ "_Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
+ "_RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _ \<in> _})" [51,0,51])
+ "_UNION" :: "[pttrn, i, i] => i" ("(3\<Union>_\<in>_./ _)" 10)
+ "_INTER" :: "[pttrn, i, i] => i" ("(3\<Inter>_\<in>_./ _)" 10)
+ "_PROD" :: "[pttrn, i, i] => i" ("(3\<Pi>_\<in>_./ _)" 10)
+ "_SUM" :: "[pttrn, i, i] => i" ("(3\<Sigma>_\<in>_./ _)" 10)
+ "_lam" :: "[pttrn, i, i] => i" ("(3\<lambda>_\<in>_./ _)" 10)
+ "_Ball" :: "[pttrn, i, o] => o" ("(3\<forall>_\<in>_./ _)" 10)
+ "_Bex" :: "[pttrn, i, o] => o" ("(3\<exists>_\<in>_./ _)" 10)
+ "_Tuple" :: "[i, is] => i" ("\<langle>(_,/ _)\<rangle>")
+ "_pattern" :: "patterns => pttrn" ("\<langle>_\<rangle>")
notation (HTML output)
cart_prod (infixr "\<times>" 80) and
@@ -182,18 +182,18 @@
Inter ("\<Inter>_" [90] 90)
syntax (HTML output)
- "@Collect" :: "[pttrn, i, o] => i" ("(1{_ \<in> _ ./ _})")
- "@Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
- "@RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _ \<in> _})" [51,0,51])
- "@UNION" :: "[pttrn, i, i] => i" ("(3\<Union>_\<in>_./ _)" 10)
- "@INTER" :: "[pttrn, i, i] => i" ("(3\<Inter>_\<in>_./ _)" 10)
- "@PROD" :: "[pttrn, i, i] => i" ("(3\<Pi>_\<in>_./ _)" 10)
- "@SUM" :: "[pttrn, i, i] => i" ("(3\<Sigma>_\<in>_./ _)" 10)
- "@lam" :: "[pttrn, i, i] => i" ("(3\<lambda>_\<in>_./ _)" 10)
- "@Ball" :: "[pttrn, i, o] => o" ("(3\<forall>_\<in>_./ _)" 10)
- "@Bex" :: "[pttrn, i, o] => o" ("(3\<exists>_\<in>_./ _)" 10)
- "@Tuple" :: "[i, is] => i" ("\<langle>(_,/ _)\<rangle>")
- "@pattern" :: "patterns => pttrn" ("\<langle>_\<rangle>")
+ "_Collect" :: "[pttrn, i, o] => i" ("(1{_ \<in> _ ./ _})")
+ "_Replace" :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
+ "_RepFun" :: "[i, pttrn, i] => i" ("(1{_ ./ _ \<in> _})" [51,0,51])
+ "_UNION" :: "[pttrn, i, i] => i" ("(3\<Union>_\<in>_./ _)" 10)
+ "_INTER" :: "[pttrn, i, i] => i" ("(3\<Inter>_\<in>_./ _)" 10)
+ "_PROD" :: "[pttrn, i, i] => i" ("(3\<Pi>_\<in>_./ _)" 10)
+ "_SUM" :: "[pttrn, i, i] => i" ("(3\<Sigma>_\<in>_./ _)" 10)
+ "_lam" :: "[pttrn, i, i] => i" ("(3\<lambda>_\<in>_./ _)" 10)
+ "_Ball" :: "[pttrn, i, o] => o" ("(3\<forall>_\<in>_./ _)" 10)
+ "_Bex" :: "[pttrn, i, o] => o" ("(3\<exists>_\<in>_./ _)" 10)
+ "_Tuple" :: "[i, is] => i" ("\<langle>(_,/ _)\<rangle>")
+ "_pattern" :: "patterns => pttrn" ("\<langle>_\<rangle>")
finalconsts
--- a/src/ZF/ind_syntax.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/ind_syntax.ML Fri Feb 19 15:21:57 2010 +0000
@@ -65,15 +65,14 @@
| dest_mem _ = error "Constructor specifications must have the form x:A";
(*read a constructor specification*)
-fun read_construct ctxt (id, sprems, syn) =
+fun read_construct ctxt (id: string, sprems, syn: mixfix) =
let val prems = map (Syntax.parse_term ctxt #> TypeInfer.constrain FOLogic.oT) sprems
|> Syntax.check_terms ctxt
val args = map (#1 o dest_mem) prems
val T = (map (#2 o dest_Free) args) ---> iT
handle TERM _ => error
"Bad variable in constructor specification"
- val name = Syntax.const_name syn id
- in ((id,T,syn), name, args, prems) end;
+ in ((id,T,syn), id, args, prems) end;
val read_constructs = map o map o read_construct;
@@ -114,7 +113,7 @@
| tryres (th, []) = raise THM("tryres", 0, [th]);
fun gen_make_elim elim_rls rl =
- Drule.standard (tryres (rl, elim_rls @ [revcut_rl]));
+ Drule.export_without_context (tryres (rl, elim_rls @ [revcut_rl]));
(*Turns iff rules into safe elimination rules*)
fun mk_free_SEs iffs = map (gen_make_elim [@{thm conjE}, @{thm FalseE}]) (iffs RL [@{thm iffD1}]);
--- a/src/ZF/int_arith.ML Fri Feb 05 17:19:25 2010 +0000
+++ b/src/ZF/int_arith.ML Fri Feb 19 15:21:57 2010 +0000
@@ -7,15 +7,40 @@
structure Int_Numeral_Simprocs =
struct
+(* abstract syntax operations *)
+
+fun mk_bit 0 = @{term "0"}
+ | mk_bit 1 = @{term "succ(0)"}
+ | mk_bit _ = sys_error "mk_bit";
+
+fun dest_bit @{term "0"} = 0
+ | dest_bit @{term "succ(0)"} = 1
+ | dest_bit _ = raise Match;
+
+fun mk_bin i =
+ let
+ fun term_of [] = @{term Pls}
+ | term_of [~1] = @{term Min}
+ | term_of (b :: bs) = @{term Bit} $ term_of bs $ mk_bit b;
+ in term_of (Numeral_Syntax.make_binary i) end;
+
+fun dest_bin tm =
+ let
+ fun bin_of @{term Pls} = []
+ | bin_of @{term Min} = [~1]
+ | bin_of (@{term Bit} $ bs $ b) = dest_bit b :: bin_of bs
+ | bin_of _ = sys_error "dest_bin";
+ in Numeral_Syntax.dest_binary (bin_of tm) end;
+
+
(*Utilities*)
-fun mk_numeral n = @{const integ_of} $ NumeralSyntax.mk_bin n;
+fun mk_numeral i = @{const integ_of} $ mk_bin i;
(*Decodes a binary INTEGER*)
fun dest_numeral (Const(@{const_name integ_of}, _) $ w) =
- (NumeralSyntax.dest_bin w
- handle Match => raise TERM("Int_Numeral_Simprocs.dest_numeral:1", [w]))
- | dest_numeral t = raise TERM("Int_Numeral_Simprocs.dest_numeral:2", [t]);
+ (dest_bin w handle SYS_ERROR _ => raise TERM("Int_Numeral_Simprocs.dest_numeral:1", [w]))
+ | dest_numeral t = raise TERM("Int_Numeral_Simprocs.dest_numeral:2", [t]);
fun find_first_numeral past (t::terms) =
((dest_numeral t, rev past @ terms)
@@ -110,9 +135,8 @@
(*To let us treat subtraction as addition*)
val diff_simps = [@{thm zdiff_def}, @{thm zminus_zadd_distrib}, @{thm zminus_zminus}];
-(*push the unary minus down: - x * y = x * - y *)
-val int_minus_mult_eq_1_to_2 =
- [@{thm zmult_zminus}, @{thm zmult_zminus_right} RS sym] MRS trans |> Drule.standard;
+(*push the unary minus down*)
+val int_minus_mult_eq_1_to_2 = @{lemma "$- w $* z = w $* $- z" by simp};
(*to extract again any uncancelled minuses*)
val int_minus_from_mult_simps =