Merged.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/E/eproof Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,93 @@
+#!/usr/bin/perl -w
+#
+# eproof - run E and translate its output into TSTP format
+#
+# Author: Sascha Boehme, TU Muenchen
+#
+# This script is a port of a Bash script with the same name coming with
+# E 1.0-004 (written by Stephan Schulz).
+#
+
+
+use File::Basename qw/ dirname /;
+use File::Temp qw/ tempfile /;
+use English;
+
+
+# E executables
+
+my $edir = dirname($0);
+my $eprover = "$edir/eprover";
+my $epclextract = "$edir/epclextract";
+
+
+# build E command from given commandline arguments
+
+my $format = "";
+my $timelimit = 2000000000; # effectively unlimited
+
+my $eprover_cmd = "'$eprover'";
+foreach (@ARGV) {
+ if (m/--cpu-limit=([0-9]+)/) {
+ $timelimit = $1;
+ }
+
+ if (m/--tstp-out/) {
+ $format = $_;
+ }
+ else {
+ $eprover_cmd = "$eprover_cmd '$_'";
+ }
+}
+$eprover_cmd = "$eprover_cmd -l4 -R -o- --pcl-terms-compressed --pcl-compact";
+
+
+# run E, redirecting output into a temporary file
+
+my ($fh, $filename) = tempfile(UNLINK => 1);
+my $r = system "$eprover_cmd > '$filename'";
+exit ($r >> 8) if $r != 0;
+
+
+# analyze E output
+
+my @lines = <$fh>;
+my $content = join "", @lines[-60 .. -1];
+ # Note: Like the original eproof, we only look at the last 60 lines.
+
+if ($content =~ m/Total time\s*:\s*([0-9]+\.[0-9]+)/) {
+ $timelimit = int($timelimit - $1 - 1);
+
+ if ($content =~ m/No proof found!/) {
+ print "# Problem is satisfiable (or invalid), " .
+ "generating saturation derivation\n";
+ }
+ elsif ($content =~ m/Proof found!/) {
+ print "# Problem is unsatisfiable (or provable), " .
+ "constructing proof object\n";
+ }
+ elsif ($content =~ m/Watchlist is empty!/) {
+ print "# All watchlist clauses generated, constructing derivation\n";
+ }
+ else {
+ print "# Cannot determine problem status\n";
+ exit $r;
+ }
+}
+else {
+ print "# Cannot determine problem status within resource limit\n";
+ exit $r;
+}
+
+
+# translate E output
+
+foreach (@lines) {
+ print if (m/# SZS status/ or m/"# Failure"/);
+}
+$r = system ("exec bash -c \"ulimit -S -t $timelimit; " .
+ "'$epclextract' $format -f --competition-framing '$filename'\"");
+ # Note: Setting the user time is not supported on Cygwin, i.e., ulimit fails
+ # and prints and error message. How could we then limit the execution time?
+exit ($r >> 8);
+
--- a/Admin/isatest/annomaly.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/Admin/isatest/annomaly.ML Thu Oct 01 07:40:25 2009 +0200
@@ -20,7 +20,7 @@
val isabelleHome =
case OS.Process.getEnv "ISABELLE_HOME"
of NONE => OS.FileSys.getDir ()
- | SOME home => mkAbsolute home
+ | SOME home => mkAbsolute home
fun noparent [] = []
| noparent (n :: ns) =
@@ -33,12 +33,12 @@
fun rewrite defPrefix name =
let val abs = mkAbsolute name
- val rel = OS.Path.mkRelative { path = abs, relativeTo = isabelleHome }
- val exists = (OS.FileSys.access(abs, nil)
- handle OS.SysErr _ => false)
+ val rel = OS.Path.mkRelative { path = abs, relativeTo = isabelleHome }
+ val exists = (OS.FileSys.access(abs, nil)
+ handle OS.SysErr _ => false)
in if exists andalso rel <> ""
- then isabellePath (toArcs rel)
- else defPrefix @ noparent (toArcs name)
+ then isabellePath (toArcs rel)
+ else defPrefix @ noparent (toArcs name)
end handle OS.Path.Path => defPrefix @ noparent (toArcs name)
in
@@ -49,10 +49,10 @@
(* should we have different files for different line numbers? *
val arcs = if line <= 1 then arcs
else arcs @ [ "l." ^ Int.toString line ]
- *)
- val arcs = if t = "structure Isabelle =\nstruct\nend;"
- andalso name = "ML"
- then ["empty_Isabelle", "empty" ] else arcs
+ *)
+ val arcs = if t = "structure Isabelle =\nstruct\nend;"
+ andalso name = "ML"
+ then ["empty_Isabelle", "empty" ] else arcs
val _ = AnnoMaLy.nameNextStream arcs
in smlnj_use_text tune str_of_pos name_space (line, name) p v t end;
--- a/Admin/isatest/isatest-makeall Tue Sep 29 22:15:54 2009 +0200
+++ b/Admin/isatest/isatest-makeall Thu Oct 01 07:40:25 2009 +0200
@@ -10,6 +10,8 @@
# max time until test is aborted (in sec)
MAXTIME=28800
+PUBLISH_TEST=/home/isabelle-repository/repos/testtool/publish_test.py
+
## diagnostics
PRG="$(basename "$0")"
@@ -80,7 +82,7 @@
NICE=""
;;
- macbroy21)
+ macbroy22)
MFLAGS="-k"
NICE=""
;;
@@ -120,6 +122,8 @@
TOOL="$ISABELLE_TOOL makeall $MFLAGS all"
fi
+IDENT=$(cat "$DISTPREFIX/ISABELLE_IDENT")
+
# main test loop
log "starting [$@]"
@@ -159,10 +163,16 @@
then
# test log and cleanup
echo ------------------- test successful --- `date` --- $HOSTNAME >> $TESTLOG 2>&1
+ if [ -x $PUBLISH_TEST ]; then
+ $PUBLISH_TEST -r $IDENT -s "SUCCESS" -a log $TESTLOG
+ fi
gzip -f $TESTLOG
else
# test log
echo ------------------- test FAILED --- `date` --- $HOSTNAME >> $TESTLOG 2>&1
+ if [ -x $PUBLISH_TEST ]; then
+ $PUBLISH_TEST -r $IDENT -s "FAIL" -a log $TESTLOG
+ fi
# error log
echo "Test for platform ${SHORT} failed. Log file attached." >> $ERRORLOG
--- a/Admin/isatest/isatest-makedist Tue Sep 29 22:15:54 2009 +0200
+++ b/Admin/isatest/isatest-makedist Thu Oct 01 07:40:25 2009 +0200
@@ -94,17 +94,17 @@
$SSH sunbroy2 "$MAKEALL $HOME/settings/sun-poly"
# give test some time to copy settings and start
sleep 15
-$SSH macbroy21 "$MAKEALL $HOME/settings/at-poly"
+$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"
#sleep 15
-$SSH macbroy22 "$MAKEALL $HOME/settings/at64-poly-5.1-para"
+$SSH macbroy21 "$MAKEALL $HOME/settings/at64-poly-5.1-para"
sleep 15
-$SSH macbroy23 -l HOL images "$MAKEALL $HOME/settings/at-sml-dev-e"
+$SSH macbroy23 "$MAKEALL -l HOL images $HOME/settings/at-sml-dev-e"
sleep 15
-$SSH atbroy101 "$MAKEALL $HOME/settings/at64-poly"
+$SSH atbroy99 "$MAKEALL $HOME/settings/at64-poly"
sleep 15
$SSH macbroy2 "$MAKEALL $HOME/settings/mac-poly-M4; $MAKEALL $HOME/settings/mac-poly-M8; $MAKEALL $HOME/settings/mac-poly64-M4; $MAKEALL $HOME/settings/mac-poly64-M8"
sleep 15
--- a/Admin/isatest/isatest-stats Tue Sep 29 22:15:54 2009 +0200
+++ b/Admin/isatest/isatest-stats Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
THIS=$(cd "$(dirname "$0")"; pwd -P)
-PLATFORMS="at-poly at64-poly mac-poly-M4 mac-poly64-M4 mac-poly-M8 at-poly-5.1-para-e at64-poly-5.1-para at-mac-poly-5.1-para afp at-sml-dev"
+PLATFORMS="at-poly at64-poly mac-poly-M4 mac-poly64-M4 mac-poly-M8 mac-poly64-M8 at-poly-5.1-para-e at64-poly-5.1-para at-mac-poly-5.1-para afp at-sml-dev"
ISABELLE_SESSIONS="\
HOL-Plain \
@@ -24,9 +24,9 @@
HOL-MetisExamples \
HOL-MicroJava \
HOL-NSA \
- HOL-NewNumberTheory \
HOL-Nominal-Examples \
- HOL-NumberTheory \
+ HOL-Number_Theory \
+ HOL-Old_Number_Theory \
HOL-SET-Protocol \
HOL-UNITY \
HOL-Word \
--- a/Admin/user-aliases Tue Sep 29 22:15:54 2009 +0200
+++ b/Admin/user-aliases Thu Oct 01 07:40:25 2009 +0200
@@ -4,3 +4,5 @@
nipkow@lapbroy100.local nipkow
chaieb@chaieb-laptop chaieb
immler@in.tum.de immler
+tsewell@rubicon.NSW.bigpond.net.au tsewell
+tsewell@nicta.com.au tsewell
--- a/CONTRIBUTORS Tue Sep 29 22:15:54 2009 +0200
+++ b/CONTRIBUTORS Thu Oct 01 07:40:25 2009 +0200
@@ -7,6 +7,18 @@
Contributions to this Isabelle version
--------------------------------------
+* September 2009: Thomas Sewell, NICTA
+ More efficient HOL/record implementation
+
+* September 2009: Sascha Boehme, TUM
+ SMT method using external SMT solvers
+
+* September 2009: Florian Haftmann, TUM
+ Refinement of Sets and Lattices
+
+* July 2009: Jeremy Avigad and Amine Chaieb
+ New number theory
+
* July 2009: Philipp Meyer, TUM
HOL/Library/Sum_of_Squares: functionality to call a remote csdp prover
--- a/NEWS Tue Sep 29 22:15:54 2009 +0200
+++ b/NEWS Thu Oct 01 07:40:25 2009 +0200
@@ -18,51 +18,31 @@
*** HOL ***
-* New proof method "sos" (sum of squares) for nonlinear real arithmetic
-(originally due to John Harison). It requires Library/Sum_Of_Squares.
-It is not a complete decision procedure but works well in practice
-on quantifier-free real arithmetic with +, -, *, ^, =, <= and <,
-i.e. boolean combinations of equalities and inequalities between
-polynomials. It makes use of external semidefinite programming solvers.
-For more information and examples see Library/Sum_Of_Squares.
-
-* Set.UNIV and Set.empty are mere abbreviations for top and bot. INCOMPATIBILITY.
-
-* More convenient names for set intersection and union. INCOMPATIBILITY:
-
- Set.Int ~> Set.inter
- Set.Un ~> Set.union
-
-* Code generator attributes follow the usual underscore convention:
- code_unfold replaces code unfold
- code_post replaces code post
- etc.
- INCOMPATIBILITY.
-
-* New quickcheck implementation using new code generator.
-
-* New class "boolean_algebra".
-
-* Refinements to lattices classes:
- - added boolean_algebra type class
- - less default intro/elim rules in locale variant, more default
- intro/elim rules in class variant: more uniformity
- - lemma ge_sup_conv renamed to le_sup_iff, in accordance with le_inf_iff
- - dropped lemma alias inf_ACI for inf_aci (same for sup_ACI and sup_aci)
- - renamed ACI to inf_sup_aci
- - class "complete_lattice" moved to separate theory "complete_lattice";
- corresponding constants renamed:
-
- Set.Inf ~> Complete_Lattice.Inf
- Set.Sup ~> Complete_Lattice.Sup
- Set.INFI ~> Complete_Lattice.INFI
- Set.SUPR ~> Complete_Lattice.SUPR
- Set.Inter ~> Complete_Lattice.Inter
- Set.Union ~> Complete_Lattice.Union
- Set.INTER ~> Complete_Lattice.INTER
- Set.UNION ~> Complete_Lattice.UNION
-
- INCOMPATIBILITY.
+* Most rules produced by inductive and datatype package
+have mandatory prefixes.
+INCOMPATIBILITY.
+
+* New proof method "smt" for a combination of first-order logic
+with equality, linear and nonlinear (natural/integer/real)
+arithmetic, and fixed-size bitvectors; there is also basic
+support for higher-order features (esp. lambda abstractions).
+It is an incomplete decision procedure based on external SMT
+solvers using the oracle mechanism.
+
+* Reorganization of number theory:
+ * former session NumberTheory now named Old_Number_Theory
+ * new session Number_Theory by Jeremy Avigad; if possible, prefer this.
+ * moved legacy theories Legacy_GCD and Primes from Library/ to Old_Number_Theory/;
+ * moved theory Pocklington from Library/ to Old_Number_Theory/;
+ * removed various references to Old_Number_Theory from HOL distribution.
+INCOMPATIBILITY.
+
+* Theory GCD now has functions Gcd/GCD and Lcm/LCM for the gcd and lcm
+of finite and infinite sets. It is shown that they form a complete
+lattice.
+
+* Split off prime number ingredients from theory GCD
+to theory Number_Theory/Primes;
* Class semiring_div requires superclass no_zero_divisors and proof of
div_mult_mult1; theorems div_mult_mult1, div_mult_mult2,
@@ -72,20 +52,83 @@
zdiv_zmult_zmult2. div_mult_mult1 is now [simp] by default.
INCOMPATIBILITY.
+* New testing tool "Mirabelle" for automated (proof) tools. Applies
+several tools and tactics like sledgehammer, metis, or quickcheck, to
+every proof step in a theory. To be used in batch mode via the
+"mirabelle" utility.
+
+* New proof method "sos" (sum of squares) for nonlinear real
+arithmetic (originally due to John Harison). It requires
+Library/Sum_Of_Squares. It is not a complete decision procedure but
+works well in practice on quantifier-free real arithmetic with +, -,
+*, ^, =, <= and <, i.e. boolean combinations of equalities and
+inequalities between polynomials. It makes use of external
+semidefinite programming solvers. For more information and examples
+see src/HOL/Library/Sum_Of_Squares.
+
+* Code generator attributes follow the usual underscore convention:
+ code_unfold replaces code unfold
+ code_post replaces code post
+ etc.
+ INCOMPATIBILITY.
+
+* Refinements to lattice classes and sets:
+ - less default intro/elim rules in locale variant, more default
+ intro/elim rules in class variant: more uniformity
+ - lemma ge_sup_conv renamed to le_sup_iff, in accordance with le_inf_iff
+ - dropped lemma alias inf_ACI for inf_aci (same for sup_ACI and sup_aci)
+ - renamed ACI to inf_sup_aci
+ - new class "boolean_algebra"
+ - class "complete_lattice" moved to separate theory "complete_lattice";
+ corresponding constants (and abbreviations) renamed and with authentic syntax:
+ Set.Inf ~> Complete_Lattice.Inf
+ Set.Sup ~> Complete_Lattice.Sup
+ Set.INFI ~> Complete_Lattice.INFI
+ Set.SUPR ~> Complete_Lattice.SUPR
+ Set.Inter ~> Complete_Lattice.Inter
+ Set.Union ~> Complete_Lattice.Union
+ Set.INTER ~> Complete_Lattice.INTER
+ Set.UNION ~> Complete_Lattice.UNION
+ - more convenient names for set intersection and union:
+ Set.Int ~> Set.inter
+ Set.Un ~> Set.union
+ - authentic syntax for
+ Set.Pow
+ Set.image
+ - mere abbreviations:
+ Set.empty (for bot)
+ Set.UNIV (for top)
+ Set.inter (for inf)
+ Set.union (for sup)
+ Complete_Lattice.Inter (for Inf)
+ Complete_Lattice.Union (for Sup)
+ Complete_Lattice.INTER (for INFI)
+ Complete_Lattice.UNION (for SUPR)
+ - object-logic definitions as far as appropriate
+
+INCOMPATIBILITY. Care is required when theorems Int_subset_iff or
+Un_subset_iff are explicitly deleted as default simp rules; then
+also their lattice counterparts le_inf_iff and le_sup_iff have to be
+deleted to achieve the desired effect.
+
+* Rules inf_absorb1, inf_absorb2, sup_absorb1, sup_absorb2 are no
+simp rules by default any longer. The same applies to
+min_max.inf_absorb1 etc.! INCOMPATIBILITY.
+
+* sup_Int_eq and sup_Un_eq are no default pred_set_conv rules any longer.
+INCOMPATIBILITY.
+
* Power operations on relations and functions are now one dedicate
-constant compow with infix syntax "^^". Power operations on
+constant "compow" with infix syntax "^^". Power operation on
multiplicative monoids retains syntax "^" and is now defined generic
in class power. INCOMPATIBILITY.
-* Relation composition "R O S" now has a "more standard" argument order,
-i.e., "R O S = {(x,z). EX y. (x,y) : R & (y,z) : S }".
+* Relation composition "R O S" now has a "more standard" argument
+order, i.e., "R O S = {(x,z). EX y. (x,y) : R & (y,z) : S }".
INCOMPATIBILITY: Rewrite propositions with "S O R" --> "R O S". Proofs
-may occationally break, since the O_assoc rule was not rewritten like this.
-Fix using O_assoc[symmetric].
-The same applies to the curried version "R OO S".
-
-* GCD now has functions Gcd/GCD and Lcm/LCM for the gcd and lcm of finite and
-infinite sets. It is shown that they form a complete lattice.
+may occationally break, since the O_assoc rule was not rewritten like
+this. Fix using O_assoc[symmetric]. The same applies to the curried
+version "R OO S".
* ML antiquotation @{code_datatype} inserts definition of a datatype
generated by the code generator; see Predicate.thy for an example.
@@ -93,41 +136,36 @@
* New method "linarith" invokes existing linear arithmetic decision
procedure only.
-* Implementation of quickcheck using generic code generator; default
-generators are provided for all suitable HOL types, records and
-datatypes.
-
-* Constants Set.Pow and Set.image now with authentic syntax;
-object-logic definitions Set.Pow_def and Set.image_def.
-INCOMPATIBILITY.
+* New implementation of quickcheck uses generic code generator;
+default generators are provided for all suitable HOL types, records
+and datatypes.
* Renamed theorems:
Suc_eq_add_numeral_1 -> Suc_eq_plus1
Suc_eq_add_numeral_1_left -> Suc_eq_plus1_left
Suc_plus1 -> Suc_eq_plus1
+* Moved theorems:
+Wellfounded.in_inv_image -> Relation.in_inv_image
+
* New sledgehammer option "Full Types" in Proof General settings menu.
Causes full type information to be output to the ATPs. This slows
ATPs down considerably but eliminates a source of unsound "proofs"
that fail later.
+* New method metisFT: A version of metis that uses full type information
+in order to avoid failures of proof reconstruction.
+
* Discontinued ancient tradition to suffix certain ML module names
with "_package", e.g.:
DatatypePackage ~> Datatype
InductivePackage ~> Inductive
- etc.
-
INCOMPATIBILITY.
-* NewNumberTheory: Jeremy Avigad's new version of part of
-NumberTheory. If possible, use NewNumberTheory, not NumberTheory.
-
-* Simplified interfaces of datatype module. INCOMPATIBILITY.
-
-* Abbreviation "arbitrary" of "undefined" has disappeared; use
-"undefined" directly. INCOMPATIBILITY.
+* Discontinued abbreviation "arbitrary" of constant
+"undefined". INCOMPATIBILITY, use "undefined" directly.
* New evaluator "approximate" approximates an real valued term using
the same method as the approximation method.
@@ -148,13 +186,30 @@
*** ML ***
+* Structure Synchronized (cf. src/Pure/Concurrent/synchronized.ML)
+provides a high-level programming interface to synchronized state
+variables with atomic update. This works via pure function
+application within a critical section -- its runtime should be as
+short as possible; beware of deadlocks if critical code is nested,
+either directly or indirectly via other synchronized variables!
+
+* Structure Unsynchronized (cf. src/Pure/ML-Systems/unsynchronized.ML)
+wraps raw ML references, explicitly indicating their non-thread-safe
+behaviour. The Isar toplevel keeps this structure open, to
+accommodate Proof General as well as quick and dirty interactive
+experiments with references.
+
* PARALLEL_CHOICE and PARALLEL_GOALS provide basic support for
parallel tactical reasoning.
-* Tactical FOCUS is similar to SUBPROOF, but allows the body tactic to
-introduce new subgoals and schematic variables. FOCUS_PARAMS is
-similar, but focuses on the parameter prefix only, leaving subgoal
-premises unchanged.
+* Tacticals Subgoal.FOCUS, Subgoal.FOCUS_PREMS, Subgoal.FOCUS_PARAMS
+are similar to SUBPROOF, but are slightly more flexible: only the
+specified parts of the subgoal are imported into the context, and the
+body tactic may introduce new subgoals and schematic variables.
+
+* Old tactical METAHYPS, which does not observe the proof context, has
+been renamed to Old_Goals.METAHYPS and awaits deletion. Use SUBPROOF
+or Subgoal.FOCUS etc.
* Renamed functor TableFun to Table, and GraphFun to Graph. (Since
functors have their own ML name space there is no point to mark them
@@ -175,6 +230,10 @@
or even Display.pretty_thm_without_context as last resort.
INCOMPATIBILITY.
+* Discontinued Display.pretty_ctyp/cterm etc. INCOMPATIBILITY, use
+Syntax.pretty_typ/term directly, preferably with proper context
+instead of global theory.
+
*** System ***
--- a/bin/isabelle Tue Sep 29 22:15:54 2009 +0200
+++ b/bin/isabelle Thu Oct 01 07:40:25 2009 +0200
@@ -17,7 +17,7 @@
ISABELLE_HOME="$(cd "$(dirname "$0")"; cd "$(pwd -P)"; cd ..; pwd)"
source "$ISABELLE_HOME/lib/scripts/getsettings" || exit 2
-ORIG_IFS="$IFS"; IFS=":"; declare -a TOOLS=($ISABELLE_TOOLS); IFS="$ORIG_IFS"
+splitarray ":" "$ISABELLE_TOOLS"; TOOLS=("${SPLITARRAY[@]}")
## diagnostics
--- a/bin/isabelle-process Tue Sep 29 22:15:54 2009 +0200
+++ b/bin/isabelle-process Thu Oct 01 07:40:25 2009 +0200
@@ -160,7 +160,7 @@
INFILE=""
ISA_PATH=""
- ORIG_IFS="$IFS"; IFS=":"; declare -a PATHS=($ISABELLE_PATH); IFS="$ORIG_IFS"
+ splitarray ":" "$ISABELLE_PATH"; PATHS=("${SPLITARRAY[@]}")
for DIR in "${PATHS[@]}"
do
DIR="$DIR/$ML_IDENTIFIER"
--- a/doc-src/manual.bib Tue Sep 29 22:15:54 2009 +0200
+++ b/doc-src/manual.bib Thu Oct 01 07:40:25 2009 +0200
@@ -484,7 +484,7 @@
booktitle = {Types for Proofs and Programs, TYPES 2008},
publisher = {Springer},
series = {LNCS},
- volume = {????},
+ volume = {5497},
year = {2009}
}
--- a/doc-src/rail.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/doc-src/rail.ML Thu Oct 01 07:40:25 2009 +0200
@@ -99,7 +99,7 @@
|> (if markup = "" then I else enclose ("\\" ^ markup ^ "{") "}")
|> (if ! ThyOutput.quotes then quote else I)
|> (if ! ThyOutput.display then enclose "\\begin{isabelle}%\n" "%\n\\end{isabelle}"
- else hyper o enclose "\\mbox{\\isa{" "}}")), style)
+ else hyper o enclose "\\mbox{\\isa{" "}}")), style)
else ("Bad " ^ kind ^ " " ^ name, false)
end;
end;
@@ -147,8 +147,8 @@
) >> (Identifier o enclose "\\isa{" "}" o Output.output o implode) ||
scan_link >> (decode_link ctxt) >>
(fn (txt, style) =>
- if style then Special_Identifier(txt)
- else Identifier(txt))
+ if style then Special_Identifier(txt)
+ else Identifier(txt))
end;
fun scan_anot ctxt =
@@ -169,12 +169,12 @@
val text_sq =
Scan.repeat (
Scan.one (fn s =>
- s <> "\n" andalso
- s <> "\t" andalso
- s <> "'" andalso
- s <> "\\" andalso
- Symbol.is_regular s) ||
- ($$ "\\" |-- $$ "'")
+ s <> "\n" andalso
+ s <> "\t" andalso
+ s <> "'" andalso
+ s <> "\\" andalso
+ Symbol.is_regular s) ||
+ ($$ "\\" |-- $$ "'")
) >> implode
fun quoted scan = $$ "'" |-- scan --| $$ "'";
in
@@ -305,9 +305,9 @@
parse_body2 -- ($$$ "*" |-- !!! "body4e expected" (parse_body4e)) >>
(fn (body1, body2) =>
if is_empty body2 then
- add_body(PLUS, new_empty_body, rev_body body1)
+ add_body(PLUS, new_empty_body, rev_body body1)
else
- add_body(BAR, new_empty_body, add_body (PLUS, body1, rev_body body2)) ) ||
+ add_body(BAR, new_empty_body, add_body (PLUS, body1, rev_body body2)) ) ||
parse_body2 -- ($$$ "+" |-- !!! "body4e expected" (parse_body4e)) >>
(fn (body1, body2) => new_body (PLUS, body1, rev_body body2) ) ||
parse_body2e
@@ -365,36 +365,36 @@
fun position_body (body as Body(kind, text, annot, id, bodies), ystart) =
let fun max (x,y) = if x > y then x else y
fun set_body_position (Body(kind, text, annot, id, bodies), ystart, ynext) =
- Body_Pos(kind, text, annot, id, bodies, ystart, ynext)
+ Body_Pos(kind, text, annot, id, bodies, ystart, ynext)
fun pos_bodies_cat ([],_,ynext,liste) = (liste, ynext)
| pos_bodies_cat (x::xs, ystart, ynext, liste) =
- if is_kind_of CR x then
- (case set_body_position(x, ystart, ynext+1) of
- body as Body_Pos(_,_,_,_,_,_,ynext1) =>
- pos_bodies_cat(xs, ynext1, max(ynext,ynext1), liste@[body])
- )
- else
- (case position_body(x, ystart) of
- body as Body_Pos(_,_,_,_,_,_,ynext1) =>
- pos_bodies_cat(xs, ystart, max(ynext,ynext1), liste@[body])
- )
+ if is_kind_of CR x then
+ (case set_body_position(x, ystart, ynext+1) of
+ body as Body_Pos(_,_,_,_,_,_,ynext1) =>
+ pos_bodies_cat(xs, ynext1, max(ynext,ynext1), liste@[body])
+ )
+ else
+ (case position_body(x, ystart) of
+ body as Body_Pos(_,_,_,_,_,_,ynext1) =>
+ pos_bodies_cat(xs, ystart, max(ynext,ynext1), liste@[body])
+ )
fun pos_bodies_bar_plus ([],_,ynext,liste) = (liste, ynext)
| pos_bodies_bar_plus (x::xs, ystart, ynext, liste) =
- (case position_body(x, ystart) of
- body as Body_Pos(_,_,_,_,_,_,ynext1) =>
- pos_bodies_bar_plus(xs, ynext1, max(ynext,ynext1), liste@[body])
- )
+ (case position_body(x, ystart) of
+ body as Body_Pos(_,_,_,_,_,_,ynext1) =>
+ pos_bodies_bar_plus(xs, ynext1, max(ynext,ynext1), liste@[body])
+ )
in
(case kind of
CAT => (case pos_bodies_cat(bodies,ystart,ystart+1,[]) of
- (bodiesPos, ynext) =>
- Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
+ (bodiesPos, ynext) =>
+ Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
| BAR => (case pos_bodies_bar_plus(bodies,ystart,ystart+1,[]) of
- (bodiesPos, ynext) =>
- Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
+ (bodiesPos, ynext) =>
+ Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
| PLUS => (case pos_bodies_bar_plus(bodies,ystart,ystart+1,[]) of
- (bodiesPos, ynext) =>
- Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
+ (bodiesPos, ynext) =>
+ Body_Pos(kind, text, annot, id, bodiesPos, ystart, ynext))
| CR => set_body_position(body, ystart, ystart+3)
| EMPTY => set_body_position(body, ystart, ystart+1)
| ANNOTE => set_body_position(body, ystart, ystart+1)
@@ -406,15 +406,15 @@
fun format_body (Body_Pos(EMPTY,_,_,_,_,_,_), _) = ""
| format_body (Body_Pos(CAT,_,_,_,bodies,_,_), cent) =
let fun format_bodies([]) = ""
- | format_bodies(x::xs) = format_body (x, "") ^ format_bodies(xs)
+ | format_bodies(x::xs) = format_body (x, "") ^ format_bodies(xs)
in
format_bodies(bodies)
end
| format_body (Body_Pos(BAR,_,_,_,bodies,_,_),cent) =
let fun format_bodies([]) = "\\rail@endbar\n"
- | format_bodies(x::xs) =
- "\\rail@nextbar{" ^ string_of_int(getystart(x)) ^"}\n" ^
- format_body(x, "") ^ format_bodies(xs)
+ | format_bodies(x::xs) =
+ "\\rail@nextbar{" ^ string_of_int(getystart(x)) ^"}\n" ^
+ format_body(x, "") ^ format_bodies(xs)
in
"\\rail@bar\n" ^ format_body(hd(bodies), "") ^ format_bodies(tl(bodies))
end
--- a/etc/components Tue Sep 29 22:15:54 2009 +0200
+++ b/etc/components Thu Oct 01 07:40:25 2009 +0200
@@ -11,6 +11,8 @@
src/LCF
src/Sequents
#misc components
+src/Tools/Code
src/HOL/Tools/ATP_Manager
+src/HOL/Mirabelle
src/HOL/Library/Sum_Of_Squares
-
+src/HOL/SMT
--- a/etc/settings Tue Sep 29 22:15:54 2009 +0200
+++ b/etc/settings Thu Oct 01 07:40:25 2009 +0200
@@ -173,7 +173,7 @@
# The pdf file viewer
if [ $(uname -s) = Darwin ]; then
- PDF_VIEWER=open
+ PDF_VIEWER="open -W -n"
else
PDF_VIEWER=xpdf
fi
@@ -207,22 +207,6 @@
###
-### jEdit
-###
-
-JEDIT_HOME=$(choosefrom \
- "$ISABELLE_HOME/contrib/jedit" \
- "$ISABELLE_HOME/../jedit" \
- "/usr/local/jedit" \
- "/usr/share/jedit" \
- "/opt/jedit" \
- "")
-
-JEDIT_JAVA_OPTIONS=""
-#JEDIT_JAVA_OPTIONS="-server -Xms128m -Xmx512m"
-JEDIT_OPTIONS="-reuseview -noserver -nobackground"
-
-###
### External reasoning tools
###
--- a/lib/Tools/codegen Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,40 +0,0 @@
-#!/usr/bin/env bash
-#
-# Author: Florian Haftmann, TUM
-#
-# DESCRIPTION: issue code generation from shell
-
-
-## diagnostics
-
-PRG="$(basename "$0")"
-
-function usage()
-{
- echo
- echo "Usage: isabelle $PRG IMAGE THY CMD"
- echo
- echo " Issues code generation using image IMAGE,"
- echo " theory THY,"
- echo " with Isar command 'export_code CMD'"
- echo
- exit 1
-}
-
-
-## process command line
-
-[ "$#" -lt 2 -o "$1" = "-?" ] && usage
-
-IMAGE="$1"; shift
-THY="$1"; shift
-CMD="$1"
-
-
-## main
-
-CODE_CMD=$(echo $CMD | perl -pe 's/\\/\\\\/g; s/"/\\\"/g')
-CTXT_CMD="ML_Context.eval_in (SOME (ProofContext.init (theory \"HOL\"))) false Position.none \"Code_Target.shell_command thyname cmd\";"
-FULL_CMD="val thyname = \"$THY\"; val cmd = \"$CODE_CMD\"; $CTXT_CMD"
-
-"$ISABELLE" -q -e "$FULL_CMD" "$IMAGE" || exit 1
--- a/lib/Tools/doc Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/Tools/doc Thu Oct 01 07:40:25 2009 +0200
@@ -34,7 +34,7 @@
## main
-ORIG_IFS="$IFS"; IFS=":"; declare -a DOCS=($ISABELLE_DOCS); IFS="$ORIG_IFS"
+splitarray ":" "$ISABELLE_DOCS"; DOCS=("${SPLITARRAY[@]}")
if [ -z "$DOC" ]; then
for DIR in "${DOCS[@]}"
--- a/lib/Tools/document Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/Tools/document Thu Oct 01 07:40:25 2009 +0200
@@ -53,7 +53,7 @@
OUTFORMAT="$OPTARG"
;;
t)
- ORIG_IFS="$IFS"; IFS=","; TAGS=($OPTARG); IFS="$ORIG_IFS"
+ splitarray "," "$OPTARG"; TAGS=("${SPLITARRAY[@]}")
;;
\?)
usage
--- a/lib/Tools/findlogics Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/Tools/findlogics Thu Oct 01 07:40:25 2009 +0200
@@ -25,7 +25,7 @@
declare -a LOGICS=()
declare -a ISABELLE_PATHS=()
-ORIG_IFS="$IFS"; IFS=":"; ISABELLE_PATHS=($ISABELLE_PATH); IFS=$ORIG_IFS
+splitarray ":" "$ISABELLE_PATH"; ISABELLE_PATHS=("${SPLITARRAY[@]}")
for DIR in "${ISABELLE_PATHS[@]}"
do
@@ -34,7 +34,7 @@
do
if [ -f "$FILE" ]; then
NAME=$(basename "$FILE")
- LOGICS+=("$NAME")
+ LOGICS["${#LOGICS[@]}"]="$NAME"
fi
done
done
--- a/lib/Tools/jedit Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-#!/usr/bin/env bash
-#
-# Author: Makarius
-#
-# DESCRIPTION: Isabelle/jEdit interface wrapper
-
-
-## diagnostics
-
-function fail()
-{
- echo "$1" >&2
- exit 2
-}
-
-
-## main
-
-[ -z "$JEDIT_HOME" ] && fail "Missing Isabelle/jEdit installation (JEDIT_HOME)"
-
-INTERFACE="$JEDIT_HOME/interface"
-[ ! -x "$INTERFACE" ] && fail "Bad interface script: \"$INTERFACE\""
-
-exec "$INTERFACE" "$@"
--- a/lib/Tools/makeall Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/Tools/makeall Thu Oct 01 07:40:25 2009 +0200
@@ -34,7 +34,7 @@
echo "Started at $(date) ($ML_IDENTIFIER on $(hostname))"
. "$ISABELLE_HOME/lib/scripts/timestart.bash"
-ORIG_IFS="$IFS"; IFS=":"; declare -a COMPONENTS=($ISABELLE_COMPONENTS); IFS="$ORIG_IFS"
+splitarray ":" "$ISABELLE_COMPONENTS"; COMPONENTS=("${SPLITARRAY[@]}")
for DIR in "${COMPONENTS[@]}"
do
--- a/lib/Tools/usedir Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/Tools/usedir Thu Oct 01 07:40:25 2009 +0200
@@ -262,7 +262,7 @@
else
{ echo "$ITEM FAILED";
echo "(see also $LOG)";
- echo; tail "$LOG"; echo; } >&2
+ echo; tail -n 20 "$LOG"; echo; } >&2
fi
exit "$RC"
--- a/lib/scripts/getsettings Tue Sep 29 22:15:54 2009 +0200
+++ b/lib/scripts/getsettings Thu Oct 01 07:40:25 2009 +0200
@@ -68,6 +68,17 @@
done
}
+#arrays
+function splitarray ()
+{
+ SPLITARRAY=()
+ local IFS="$1"; shift
+ for X in $*
+ do
+ SPLITARRAY["${#SPLITARRAY[@]}"]="$X"
+ done
+}
+
#nested components
ISABELLE_COMPONENTS=""
function init_component ()
--- a/lib/scripts/mirabelle Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,129 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-use File::Basename;
-
-# Taken from http://www.skywayradio.com/tech/perl/trim_blanks.html
-sub trim {
- my @out = @_;
- for (@out) {
- s/^\s+//;
- s/\s+$//;
- }
- return wantarray ? @out : $out[0];
-}
-
-sub quote {
- my $str = pop;
- return "\"" . $str . "\"";
-}
-
-sub print_usage_and_quit {
- print STDERR "Usage: mirabelle actions file1.thy...\n" .
- " actions: action1:...:actionN\n" .
- " action: name or name[key1=value1,...,keyM=valueM]\n";
- exit 1;
-}
-
-my $num_args = $#ARGV + 1;
-if ($num_args < 2) {
- print_usage_and_quit();
-}
-
-my @action_names;
-my @action_settings;
-
-foreach (split(/:/, $ARGV[0])) {
- my %settings;
-
- $_ =~ /([^[]*)(?:\[(.*)\])?/;
- my ($name, $settings_str) = ($1, $2 || "");
- my @setting_strs = split(/,/, $settings_str);
- foreach (@setting_strs) {
- $_ =~ /(.*)=(.*)/;
- my $key = $1;
- my $value = $2;
- $settings{trim($key)} = trim($value);
- }
-
- push @action_names, trim($name);
- push @action_settings, \%settings;
-}
-
-my $output_path = "/tmp/mirabelle"; # FIXME: generate path
-my $mirabellesetup_thy_name = $output_path . "/MirabelleSetup";
-my $mirabellesetup_file = $mirabellesetup_thy_name . ".thy";
-my $mirabelle_log_file = $output_path . "/mirabelle.log";
-
-mkdir $output_path, 0755;
-
-open(FILE, ">$mirabellesetup_file")
- || die "Could not create file '$mirabellesetup_file'";
-
-my $invoke_lines;
-
-for my $i (0 .. $#action_names) {
- my $settings_str = "";
- my $settings = $action_settings[$i];
- my $key;
- my $value;
-
- while (($key, $value) = each(%$settings)) {
- $settings_str .= "(" . quote ($key) . ", " . quote ($value) . "), ";
- }
- $settings_str =~ s/, $//;
-
- $invoke_lines .= "setup {* Mirabelle.invoke \"$action_names[$i]\" ";
- $invoke_lines .= "[$settings_str] *}\n"
-}
-
-print FILE <<EOF;
-theory MirabelleSetup
-imports Mirabelle
-begin
-
-setup {* Mirabelle.set_logfile "$mirabelle_log_file" *}
-
-$invoke_lines
-
-end
-EOF
-
-my $root_text = "";
-my @new_thy_files;
-
-for my $i (1 .. $num_args - 1) {
- my $old_thy_file = $ARGV[$i];
- my ($base, $dir, $ext) = fileparse($old_thy_file, "\.thy");
- my $new_thy_name = $base . "Mirabelle";
- my $new_thy_file = $dir . $new_thy_name . $ext;
-
- open(OLD_FILE, "<$old_thy_file")
- || die "Cannot open file $old_thy_file";
- my @lines = <OLD_FILE>;
- close(OLD_FILE);
-
- my $thy_text = join("", @lines);
- my $old_len = length($thy_text);
- $thy_text =~ s/\btheory\b[^\n]*\s*\bimports\s/theory $new_thy_name\nimports "$mirabellesetup_thy_name" /gm;
- die "No 'imports' found" if length($thy_text) == $old_len;
-
- open(NEW_FILE, ">$new_thy_file");
- print NEW_FILE $thy_text;
- close(NEW_FILE);
-
- $root_text .= "use_thy \"" . $dir . $new_thy_name . "\";\n";
-
- push @new_thy_files, $new_thy_file;
-}
-
-my $root_file = "ROOT_mirabelle.ML";
-open(ROOT_FILE, ">$root_file") || die "Cannot open file $root_file";
-print ROOT_FILE $root_text;
-close(ROOT_FILE);
-
-system "isabelle-process -e 'use \"ROOT_mirabelle.ML\";' -f -q HOL";
-
-# unlink $mirabellesetup_file;
-unlink $root_file;
-unlink @new_thy_files;
--- a/src/CCL/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/CCL/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -3,12 +3,11 @@
Copyright 1993 University of Cambridge
Classical Computational Logic based on First-Order Logic.
+
+A computational logic for an untyped functional language with
+evaluation to weak head-normal form.
*)
-set eta_contract;
-
-(* CCL - a computational logic for an untyped functional language *)
-(* with evaluation to weak head-normal form *)
+Unsynchronized.set eta_contract;
use_thys ["Wfd", "Fix"];
-
--- a/src/FOL/fologic.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/FOL/fologic.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,28 +6,28 @@
signature FOLOGIC =
sig
- val oT : typ
- val mk_Trueprop : term -> term
- val dest_Trueprop : term -> term
- val not : term
- val conj : term
- val disj : term
- val imp : term
- val iff : term
- val mk_conj : term * term -> term
- val mk_disj : term * term -> term
- val mk_imp : term * term -> term
- val dest_imp : term -> term*term
- val dest_conj : term -> term list
- val mk_iff : term * term -> term
- val dest_iff : term -> term*term
- val all_const : typ -> term
- val mk_all : term * term -> term
- val exists_const : typ -> term
- val mk_exists : term * term -> term
- val eq_const : typ -> term
- val mk_eq : term * term -> term
- val dest_eq : term -> term*term
+ val oT: typ
+ val mk_Trueprop: term -> term
+ val dest_Trueprop: term -> term
+ val not: term
+ val conj: term
+ val disj: term
+ val imp: term
+ val iff: term
+ val mk_conj: term * term -> term
+ val mk_disj: term * term -> term
+ val mk_imp: term * term -> term
+ val dest_imp: term -> term * term
+ val dest_conj: term -> term list
+ val mk_iff: term * term -> term
+ val dest_iff: term -> term * term
+ val all_const: typ -> term
+ val mk_all: term * term -> term
+ val exists_const: typ -> term
+ val mk_exists: term * term -> term
+ val eq_const: typ -> term
+ val mk_eq: term * term -> term
+ val dest_eq: term -> term * term
val mk_binop: string -> term * term -> term
val mk_binrel: string -> term * term -> term
val dest_bin: string -> typ -> term -> term * term
@@ -46,7 +46,8 @@
fun dest_Trueprop (Const ("Trueprop", _) $ P) = P
| dest_Trueprop t = raise TERM ("dest_Trueprop", [t]);
-(** Logical constants **)
+
+(* Logical constants *)
val not = Const ("Not", oT --> oT);
val conj = Const("op &", [oT,oT]--->oT);
@@ -80,6 +81,7 @@
fun exists_const T = Const ("Ex", [T --> oT] ---> oT);
fun mk_exists (Free(x,T),P) = exists_const T $ (absfree (x,T,P));
+
(* binary oprations and relations *)
fun mk_binop c (t, u) =
@@ -97,5 +99,4 @@
else raise TERM ("dest_bin " ^ c, [tm])
| dest_bin c _ tm = raise TERM ("dest_bin " ^ c, [tm]);
-
end;
--- a/src/FOL/intprover.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/FOL/intprover.ML Thu Oct 01 07:40:25 2009 +0200
@@ -79,8 +79,7 @@
(*One safe or unsafe step. *)
fun step_tac i = FIRST [safe_tac, inst_step_tac i, biresolve_tac haz_brls i];
-fun step_dup_tac i = FIRST [safe_tac, inst_step_tac i,
- biresolve_tac haz_dup_brls i];
+fun step_dup_tac i = FIRST [safe_tac, inst_step_tac i, biresolve_tac haz_dup_brls i];
(*Dumb but fast*)
val fast_tac = SELECT_GOAL (DEPTH_SOLVE (step_tac 1));
--- a/src/FOLP/IFOLP.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/FOLP/IFOLP.thy Thu Oct 01 07:40:25 2009 +0200
@@ -69,7 +69,7 @@
ML {*
(*show_proofs:=true displays the proof terms -- they are ENORMOUS*)
-val show_proofs = ref false;
+val show_proofs = Unsynchronized.ref false;
fun proof_tr [p,P] = Const (@{const_name Proof}, dummyT) $ P $ p;
--- a/src/FOLP/hypsubst.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/FOLP/hypsubst.ML Thu Oct 01 07:40:25 2009 +0200
@@ -27,7 +27,7 @@
val inspect_pair : bool -> term * term -> thm
end;
-functor HypsubstFun(Data: HYPSUBST_DATA): HYPSUBST =
+functor HypsubstFun(Data: HYPSUBST_DATA): HYPSUBST =
struct
local open Data in
@@ -43,13 +43,13 @@
but how could we check for this?*)
fun inspect_pair bnd (t,u) =
case (Envir.eta_contract t, Envir.eta_contract u) of
- (Bound i, _) => if loose(i,u) then raise Match
+ (Bound i, _) => if loose(i,u) then raise Match
else sym (*eliminates t*)
- | (_, Bound i) => if loose(i,t) then raise Match
+ | (_, Bound i) => if loose(i,t) then raise Match
else asm_rl (*eliminates u*)
- | (Free _, _) => if bnd orelse Logic.occs(t,u) then raise Match
+ | (Free _, _) => if bnd orelse Logic.occs(t,u) then raise Match
else sym (*eliminates t*)
- | (_, Free _) => if bnd orelse Logic.occs(u,t) then raise Match
+ | (_, Free _) => if bnd orelse Logic.occs(u,t) then raise Match
else asm_rl (*eliminates u*)
| _ => raise Match;
@@ -58,7 +58,7 @@
the rule asm_rl (resp. sym). *)
fun eq_var bnd =
let fun eq_var_aux k (Const("all",_) $ Abs(_,_,t)) = eq_var_aux k t
- | eq_var_aux k (Const("==>",_) $ A $ B) =
+ | eq_var_aux k (Const("==>",_) $ A $ B) =
((k, inspect_pair bnd (dest_eq A))
(*Exception Match comes from inspect_pair or dest_eq*)
handle Match => eq_var_aux (k+1) B)
@@ -70,13 +70,13 @@
fun gen_hyp_subst_tac bnd = SUBGOAL(fn (Bi,i) =>
let val n = length(Logic.strip_assums_hyp Bi) - 1
val (k,symopt) = eq_var bnd Bi
- in
+ in
DETERM
(EVERY [REPEAT_DETERM_N k (etac rev_mp i),
- etac revcut_rl i,
- REPEAT_DETERM_N (n-k) (etac rev_mp i),
- etac (symopt RS subst) i,
- REPEAT_DETERM_N n (rtac imp_intr i)])
+ etac revcut_rl i,
+ REPEAT_DETERM_N (n-k) (etac rev_mp i),
+ etac (symopt RS subst) i,
+ REPEAT_DETERM_N n (rtac imp_intr i)])
end
handle THM _ => no_tac | EQ_VAR => no_tac);
--- a/src/FOLP/simp.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/FOLP/simp.ML Thu Oct 01 07:40:25 2009 +0200
@@ -49,10 +49,10 @@
(* temporarily disabled:
val extract_free_congs : unit -> thm list
*)
- val tracing : bool ref
+ val tracing : bool Unsynchronized.ref
end;
-functor SimpFun (Simp_data: SIMP_DATA) : SIMP =
+functor SimpFun (Simp_data: SIMP_DATA) : SIMP =
struct
local open Simp_data in
@@ -74,12 +74,12 @@
Similar to match_from_nat_tac, but the net does not contain numbers;
rewrite rules are not ordered.*)
fun net_tac net =
- SUBGOAL(fn (prem,i) =>
+ SUBGOAL(fn (prem,i) =>
resolve_tac (Net.unify_term net (Logic.strip_assums_concl prem)) i);
(*match subgoal i against possible theorems indexed by lhs in the net*)
fun lhs_net_tac net =
- SUBGOAL(fn (prem,i) =>
+ SUBGOAL(fn (prem,i) =>
biresolve_tac (Net.unify_term net
(lhs_of (Logic.strip_assums_concl prem))) i);
@@ -110,7 +110,7 @@
(*Get the norm constants from norm_thms*)
val norms =
- let fun norm thm =
+ let fun norm thm =
case lhs_of(concl_of thm) of
Const(n,_)$_ => n
| _ => error "No constant in lhs of a norm_thm"
@@ -144,7 +144,7 @@
(**** Adding "NORM" tags ****)
(*get name of the constant from conclusion of a congruence rule*)
-fun cong_const cong =
+fun cong_const cong =
case head_of (lhs_of (concl_of cong)) of
Const(c,_) => c
| _ => "" (*a placeholder distinct from const names*);
@@ -156,9 +156,9 @@
fun add_hidden_vars ccs =
let fun add_hvars tm hvars = case tm of
Abs(_,_,body) => OldTerm.add_term_vars(body,hvars)
- | _$_ => let val (f,args) = strip_comb tm
+ | _$_ => let val (f,args) = strip_comb tm
in case f of
- Const(c,T) =>
+ Const(c,T) =>
if member (op =) ccs c
then fold_rev add_hvars args hvars
else OldTerm.add_term_vars (tm, hvars)
@@ -202,13 +202,13 @@
val hvs = map (#1 o dest_Var) hvars
val refl1_tac = refl_tac 1
fun norm_step_tac st = st |>
- (case head_of(rhs_of_eq 1 st) of
- Var(ixn,_) => if ixn mem hvs then refl1_tac
- else resolve_tac normI_thms 1 ORELSE refl1_tac
- | Const _ => resolve_tac normI_thms 1 ORELSE
- resolve_tac congs 1 ORELSE refl1_tac
- | Free _ => resolve_tac congs 1 ORELSE refl1_tac
- | _ => refl1_tac)
+ (case head_of(rhs_of_eq 1 st) of
+ Var(ixn,_) => if ixn mem hvs then refl1_tac
+ else resolve_tac normI_thms 1 ORELSE refl1_tac
+ | Const _ => resolve_tac normI_thms 1 ORELSE
+ resolve_tac congs 1 ORELSE refl1_tac
+ | Free _ => resolve_tac congs 1 ORELSE refl1_tac
+ | _ => refl1_tac)
val add_norm_tac = DEPTH_FIRST (has_fewer_prems nops) norm_step_tac
val SOME(thm'',_) = Seq.pull(add_norm_tac thm')
in thm'' end;
@@ -246,9 +246,9 @@
(** Insertion of congruences and rewrites **)
(*insert a thm in a thm net*)
-fun insert_thm_warn th net =
+fun insert_thm_warn th net =
Net.insert_term Thm.eq_thm_prop (concl_of th, th) net
- handle Net.INSERT =>
+ handle Net.INSERT =>
(writeln ("Duplicate rewrite or congruence rule:\n" ^
Display.string_of_thm_without_context th); net);
@@ -272,9 +272,9 @@
(** Deletion of congruences and rewrites **)
(*delete a thm from a thm net*)
-fun delete_thm_warn th net =
+fun delete_thm_warn th net =
Net.delete_term Thm.eq_thm_prop (concl_of th, th) net
- handle Net.DELETE =>
+ handle Net.DELETE =>
(writeln ("No such rewrite or congruence rule:\n" ^
Display.string_of_thm_without_context th); net);
@@ -337,17 +337,17 @@
in find_if(tm,0) end;
fun IF1_TAC cong_tac i =
- let fun seq_try (ifth::ifths,ifc::ifcs) thm =
+ let fun seq_try (ifth::ifths,ifc::ifcs) thm =
(COND (if_rewritable ifc i) (DETERM(rtac ifth i))
(seq_try(ifths,ifcs))) thm
| seq_try([],_) thm = no_tac thm
and try_rew thm = (seq_try(case_rews,case_consts) ORELSE one_subt) thm
and one_subt thm =
let val test = has_fewer_prems (nprems_of thm + 1)
- fun loop thm =
- COND test no_tac
+ fun loop thm =
+ COND test no_tac
((try_rew THEN DEPTH_FIRST test (refl_tac i))
- ORELSE (refl_tac i THEN loop)) thm
+ ORELSE (refl_tac i THEN loop)) thm
in (cong_tac THEN loop) thm end
in COND (may_match(case_consts,i)) try_rew no_tac end;
@@ -366,7 +366,7 @@
(** Tracing **)
-val tracing = ref false;
+val tracing = Unsynchronized.ref false;
(*Replace parameters by Free variables in P*)
fun variants_abs ([],P) = P
@@ -381,12 +381,12 @@
(*print lhs of conclusion of subgoal i*)
fun pr_goal_lhs i st =
- writeln (Syntax.string_of_term_global (Thm.theory_of_thm st)
+ writeln (Syntax.string_of_term_global (Thm.theory_of_thm st)
(lhs_of (prepare_goal i st)));
(*print conclusion of subgoal i*)
fun pr_goal_concl i st =
- writeln (Syntax.string_of_term_global (Thm.theory_of_thm st) (prepare_goal i st))
+ writeln (Syntax.string_of_term_global (Thm.theory_of_thm st) (prepare_goal i st))
(*print subgoals i to j (inclusive)*)
fun pr_goals (i,j) st =
@@ -439,7 +439,7 @@
then writeln (cat_lines
("Adding rewrites:" :: map Display.string_of_thm_without_context new_rws))
else ();
- (ss,thm,anet',anet::ats,cs)
+ (ss,thm,anet',anet::ats,cs)
end;
fun rew(seq,thm,ss,anet,ats,cs, more) = case Seq.pull seq of
@@ -492,7 +492,7 @@
fun EXEC_TAC(ss,fl) (SS{auto_tac,cong_net,simp_net,...}) =
let val cong_tac = net_tac cong_net
-in fn i =>
+in fn i =>
(fn thm =>
if i <= 0 orelse nprems_of thm < i then Seq.empty
else Seq.single(execute(ss,fl,auto_tac,cong_tac,simp_net,i,thm)))
--- a/src/HOL/Algebra/Divisibility.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/Divisibility.thy Thu Oct 01 07:40:25 2009 +0200
@@ -2656,25 +2656,7 @@
shows "(x \<in> carrier G \<and> x gcdof a b) =
greatest (division_rel G) x (Lower (division_rel G) {a, b})"
unfolding isgcd_def greatest_def Lower_def elem_def
-proof (simp, safe)
- fix xa
- assume r1[rule_format]: "\<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> xa divides x"
- assume r2[rule_format]: "\<forall>y\<in>carrier G. y divides a \<and> y divides b \<longrightarrow> y divides x"
-
- assume "xa \<in> carrier G" "x divides a" "x divides b"
- with carr
- show "xa divides x"
- by (fast intro: r1 r2)
-next
- fix a' y
- assume r1[rule_format]:
- "\<forall>xa\<in>{l. \<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> l divides x} \<inter> carrier G.
- xa divides x"
- assume "y \<in> carrier G" "y divides a" "y divides b"
- with carr
- show "y divides x"
- by (fast intro: r1)
-qed (simp, simp)
+by auto
lemma lcmof_leastUpper:
fixes G (structure)
@@ -2682,25 +2664,7 @@
shows "(x \<in> carrier G \<and> x lcmof a b) =
least (division_rel G) x (Upper (division_rel G) {a, b})"
unfolding islcm_def least_def Upper_def elem_def
-proof (simp, safe)
- fix xa
- assume r1[rule_format]: "\<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> x divides xa"
- assume r2[rule_format]: "\<forall>y\<in>carrier G. a divides y \<and> b divides y \<longrightarrow> x divides y"
-
- assume "xa \<in> carrier G" "a divides x" "b divides x"
- with carr
- show "x divides xa"
- by (fast intro: r1 r2)
-next
- fix a' y
- assume r1[rule_format]:
- "\<forall>xa\<in>{l. \<forall>x. (x = a \<or> x = b) \<and> x \<in> carrier G \<longrightarrow> x divides l} \<inter> carrier G.
- x divides xa"
- assume "y \<in> carrier G" "a divides y" "b divides y"
- with carr
- show "x divides y"
- by (fast intro: r1)
-qed (simp, simp)
+by auto
lemma somegcd_meet:
fixes G (structure)
--- a/src/HOL/Algebra/Exponent.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/Exponent.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,16 +1,13 @@
(* Title: HOL/Algebra/Exponent.thy
- ID: $Id$
Author: Florian Kammueller, with new proofs by L C Paulson
exponent p s yields the greatest power of p that divides s.
*)
theory Exponent
-imports Main Primes Binomial
+imports Main "~~/src/HOL/Old_Number_Theory/Primes" Binomial
begin
-hide (open) const GCD.gcd GCD.coprime GCD.prime
-
section {*Sylow's Theorem*}
subsection {*The Combinatorial Argument Underlying the First Sylow Theorem*}
--- a/src/HOL/Algebra/FiniteProduct.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/FiniteProduct.thy Thu Oct 01 07:40:25 2009 +0200
@@ -212,7 +212,7 @@
apply (induct set: finite)
apply simp
apply (simp add: foldD_insert foldD_commute Int_insert_left insert_absorb
- Int_mono2 Un_subset_iff)
+ Int_mono2)
done
lemma (in LCD) foldD_nest_Un_disjoint:
@@ -274,14 +274,14 @@
apply (simp add: AC insert_absorb Int_insert_left
LCD.foldD_insert [OF LCD.intro [of D]]
LCD.foldD_closed [OF LCD.intro [of D]]
- Int_mono2 Un_subset_iff)
+ Int_mono2)
done
lemma (in ACeD) foldD_Un_disjoint:
"[| finite A; finite B; A Int B = {}; A \<subseteq> D; B \<subseteq> D |] ==>
foldD D f e (A Un B) = foldD D f e A \<cdot> foldD D f e B"
by (simp add: foldD_Un_Int
- left_commute LCD.foldD_closed [OF LCD.intro [of D]] Un_subset_iff)
+ left_commute LCD.foldD_closed [OF LCD.intro [of D]])
subsubsection {* Products over Finite Sets *}
@@ -377,7 +377,7 @@
from insert have A: "g \<in> A -> carrier G" by fast
from insert A a show ?case
by (simp add: m_ac Int_insert_left insert_absorb finprod_closed
- Int_mono2 Un_subset_iff)
+ Int_mono2)
qed
lemma finprod_Un_disjoint:
--- a/src/HOL/Algebra/IntRing.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/IntRing.thy Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
*)
theory IntRing
-imports QuotRing Lattice Int Primes
+imports QuotRing Lattice Int "~~/src/HOL/Old_Number_Theory/Primes"
begin
--- a/src/HOL/Algebra/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -5,7 +5,7 @@
*)
(* Preliminaries from set and number theory *)
-no_document use_thys ["FuncSet", "Primes", "Binomial", "Permutation"];
+no_document use_thys ["FuncSet", "~~/src/HOL/Old_Number_Theory/Primes", "Binomial", "Permutation"];
(*** New development, based on explicit structures ***)
--- a/src/HOL/Algebra/UnivPoly.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/UnivPoly.thy Thu Oct 01 07:40:25 2009 +0200
@@ -592,15 +592,14 @@
proof (cases "n = k")
case True
then have "\<zero> = (\<Oplus>i \<in> {..<n} \<union> {n}. ?s i)"
- by (simp cong: R.finsum_cong add: ivl_disj_int_singleton Pi_def)
+ by (simp cong: R.finsum_cong add: Pi_def)
also from True have "... = (\<Oplus>i \<in> {..k}. ?s i)"
by (simp only: ivl_disj_un_singleton)
finally show ?thesis .
next
case False with n_le_k have n_less_k: "n < k" by arith
with neq have "\<zero> = (\<Oplus>i \<in> {..<n} \<union> {n}. ?s i)"
- by (simp add: R.finsum_Un_disjoint f1 f2
- ivl_disj_int_singleton Pi_def del: Un_insert_right)
+ by (simp add: R.finsum_Un_disjoint f1 f2 Pi_def del: Un_insert_right)
also have "... = (\<Oplus>i \<in> {..n}. ?s i)"
by (simp only: ivl_disj_un_singleton)
also from n_less_k neq have "... = (\<Oplus>i \<in> {..n} \<union> {n<..k}. ?s i)"
@@ -817,15 +816,9 @@
text {* Degree and polynomial operations *}
lemma deg_add [simp]:
- assumes R: "p \<in> carrier P" "q \<in> carrier P"
- shows "deg R (p \<oplus>\<^bsub>P\<^esub> q) <= max (deg R p) (deg R q)"
-proof (cases "deg R p <= deg R q")
- case True show ?thesis
- by (rule deg_aboveI) (simp_all add: True R deg_aboveD)
-next
- case False show ?thesis
- by (rule deg_aboveI) (simp_all add: False R deg_aboveD)
-qed
+ "p \<in> carrier P \<Longrightarrow> q \<in> carrier P \<Longrightarrow>
+ deg R (p \<oplus>\<^bsub>P\<^esub> q) <= max (deg R p) (deg R q)"
+by(rule deg_aboveI)(simp_all add: deg_aboveD)
lemma deg_monom_le:
"a \<in> carrier R ==> deg R (monom P a n) <= n"
@@ -945,8 +938,7 @@
also have "...= (\<Oplus>i \<in> {deg R p} \<union> {deg R p <.. deg R p + deg R q}. ?s i)"
by (simp only: ivl_disj_un_singleton)
also have "... = coeff P p (deg R p) \<otimes> coeff P q (deg R q)"
- by (simp cong: R.finsum_cong
- add: ivl_disj_int_singleton deg_aboveD R Pi_def)
+ by (simp cong: R.finsum_cong add: deg_aboveD R Pi_def)
finally have "(\<Oplus>i \<in> {.. deg R p + deg R q}. ?s i)
= coeff P p (deg R p) \<otimes> coeff P q (deg R q)" .
with nz show "(\<Oplus>i \<in> {.. deg R p + deg R q}. ?s i) ~= \<zero>"
@@ -989,8 +981,7 @@
have "... = coeff P (\<Oplus>\<^bsub>P\<^esub> i \<in> {..<k} \<union> {k}. ?s i) k"
by (simp only: ivl_disj_un_singleton)
also have "... = coeff P p k"
- by (simp cong: R.finsum_cong
- add: ivl_disj_int_singleton coeff_finsum deg_aboveD R RR Pi_def)
+ by (simp cong: R.finsum_cong add: coeff_finsum deg_aboveD R RR Pi_def)
finally show ?thesis .
next
case False
@@ -998,8 +989,7 @@
coeff P (\<Oplus>\<^bsub>P\<^esub> i \<in> {..<deg R p} \<union> {deg R p}. ?s i) k"
by (simp only: ivl_disj_un_singleton)
also from False have "... = coeff P p k"
- by (simp cong: R.finsum_cong
- add: ivl_disj_int_singleton coeff_finsum deg_aboveD R Pi_def)
+ by (simp cong: R.finsum_cong add: coeff_finsum deg_aboveD R Pi_def)
finally show ?thesis .
qed
qed (simp_all add: R Pi_def)
--- a/src/HOL/Algebra/abstract/Ring2.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/abstract/Ring2.thy Thu Oct 01 07:40:25 2009 +0200
@@ -241,7 +241,7 @@
proof (induct n)
case 0 show ?case by simp
next
- case Suc thus ?case by (simp add: add_assoc)
+ case Suc thus ?case by (simp add: add_assoc)
qed
lemma natsum_cong [cong]:
@@ -269,21 +269,21 @@
ML {*
local
- val lhss =
+ val lhss =
["t + u::'a::ring",
- "t - u::'a::ring",
- "t * u::'a::ring",
- "- t::'a::ring"];
- fun proc ss t =
+ "t - u::'a::ring",
+ "t * u::'a::ring",
+ "- t::'a::ring"];
+ fun proc ss t =
let val rew = Goal.prove (Simplifier.the_context ss) [] []
(HOLogic.mk_Trueprop
(HOLogic.mk_eq (t, Var (("x", Term.maxidx_of_term t + 1), fastype_of t))))
(fn _ => simp_tac (Simplifier.inherit_context ss ring_ss) 1)
|> mk_meta_eq;
val (t', u) = Logic.dest_equals (Thm.prop_of rew);
- in if t' aconv u
+ in if t' aconv u
then NONE
- else SOME rew
+ else SOME rew
end;
in
val ring_simproc = Simplifier.simproc @{theory} "ring" lhss (K proc);
@@ -305,7 +305,7 @@
declare one_not_zero [simp]
lemma zero_not_one [simp]:
- "0 ~= (1::'a::domain)"
+ "0 ~= (1::'a::domain)"
by (rule not_sym) simp
lemma integral_iff: (* not by default a simp rule! *)
@@ -322,7 +322,7 @@
*)
(*
lemma bug: "(b::'a::ring) - (b - a) = a" by simp
- simproc for rings cannot prove "(a::'a::ring) - (a - b) = b"
+ simproc for rings cannot prove "(a::'a::ring) - (a - b) = b"
*)
lemma m_lcancel:
assumes prem: "(a::'a::domain) ~= 0" shows conc: "(a * b = a * c) = (b = c)"
@@ -330,8 +330,8 @@
assume eq: "a * b = a * c"
then have "a * (b - c) = 0" by simp
then have "a = 0 | (b - c) = 0" by (simp only: integral_iff)
- with prem have "b - c = 0" by auto
- then have "b = b - (b - c)" by simp
+ with prem have "b - c = 0" by auto
+ then have "b = b - (b - c)" by simp
also have "b - (b - c) = c" by simp
finally show "b = c" .
next
@@ -386,7 +386,7 @@
qed
-lemma unit_mult:
+lemma unit_mult:
"!!a::'a::ring. [| a dvd 1; b dvd 1 |] ==> a * b dvd 1"
apply (unfold dvd_def)
apply clarify
--- a/src/HOL/Algebra/poly/UnivPoly2.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Algebra/poly/UnivPoly2.thy Thu Oct 01 07:40:25 2009 +0200
@@ -563,11 +563,7 @@
lemma deg_add [simp]:
"deg ((p::'a::ring up) + q) <= max (deg p) (deg q)"
-proof (cases "deg p <= deg q")
- case True show ?thesis by (rule deg_aboveI) (simp add: True deg_aboveD)
-next
- case False show ?thesis by (rule deg_aboveI) (simp add: False deg_aboveD)
-qed
+by (rule deg_aboveI) (simp add: deg_aboveD)
lemma deg_monom_ring:
"deg (monom a n::'a::ring up) <= n"
@@ -678,8 +674,7 @@
also have "... = setsum ?s ({deg p} Un {deg p <.. deg p + deg q})"
by (simp only: ivl_disj_un_singleton)
also have "... = coeff p (deg p) * coeff q (deg q)"
- by (simp add: setsum_Un_disjoint ivl_disj_int_singleton
- setsum_0 deg_aboveD)
+ by (simp add: setsum_Un_disjoint setsum_0 deg_aboveD)
finally have "setsum ?s {.. deg p + deg q}
= coeff p (deg p) * coeff q (deg q)" .
with nz show "setsum ?s {.. deg p + deg q} ~= 0"
@@ -723,8 +718,7 @@
have "... = coeff (setsum ?s ({..<k} Un {k})) k"
by (simp only: ivl_disj_un_singleton)
also have "... = coeff p k"
- by (simp add: setsum_Un_disjoint ivl_disj_int_singleton
- setsum_0 coeff_natsum deg_aboveD)
+ by (simp add: setsum_Un_disjoint setsum_0 coeff_natsum deg_aboveD)
finally show ?thesis .
next
case False
@@ -732,8 +726,7 @@
coeff (setsum ?s ({..<deg p} Un {deg p})) k"
by (simp only: ivl_disj_un_singleton)
also from False have "... = coeff p k"
- by (simp add: setsum_Un_disjoint ivl_disj_int_singleton
- setsum_0 coeff_natsum deg_aboveD)
+ by (simp add: setsum_Un_disjoint setsum_0 coeff_natsum deg_aboveD)
finally show ?thesis .
qed
qed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/All_Symmetric.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,12 @@
+theory All_Symmetric
+imports Message
+begin
+
+text {* All keys are symmetric *}
+
+defs all_symmetric_def: "all_symmetric \<equiv> True"
+
+lemma isSym_keys: "K \<in> symKeys"
+ by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Auth_Public.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,15 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Conventional protocols: rely on conventional Message, Event and Public -- Public-key protocols *}
+
+theory Auth_Public
+imports
+ "NS_Public_Bad"
+ "NS_Public"
+ "TLS"
+ "CertifiedEmail"
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Auth_Shared.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,27 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Conventional protocols: rely on conventional Message, Event and Public -- Shared-key protocols *}
+
+theory Auth_Shared
+imports
+ "NS_Shared"
+ "Kerberos_BAN"
+ "Kerberos_BAN_Gets"
+ "KerberosIV"
+ "KerberosIV_Gets"
+ "KerberosV"
+ "OtwayRees"
+ "OtwayRees_AN"
+ "OtwayRees_Bad"
+ "OtwayReesBella"
+ "WooLam"
+ "Recur"
+ "Yahalom"
+ "Yahalom2"
+ "Yahalom_Bad"
+ "ZhouGollmann"
+begin
+
+end
--- a/src/HOL/Auth/Event.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Event.thy Thu Oct 01 07:40:25 2009 +0200
@@ -139,9 +139,11 @@
text{*Elimination rules: derive contradictions from old Says events containing
items known to be fresh*}
+lemmas Says_imp_parts_knows_Spy =
+ Says_imp_knows_Spy [THEN parts.Inj, THEN revcut_rl, standard]
+
lemmas knows_Spy_partsEs =
- Says_imp_knows_Spy [THEN parts.Inj, THEN revcut_rl, standard]
- parts.Body [THEN revcut_rl, standard]
+ Says_imp_parts_knows_Spy parts.Body [THEN revcut_rl, standard]
lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Guard/Auth_Guard_Public.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,15 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Blanqui's "guard" concept: protocol-independent secrecy *}
+
+theory Auth_Guard_Public
+imports
+ "P1"
+ "P2"
+ "Guard_NS_Public"
+ "Proto"
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Guard/Auth_Guard_Shared.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,13 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Blanqui's "guard" concept: protocol-independent secrecy *}
+
+theory Auth_Guard_Shared
+imports
+ "Guard_OtwayRees"
+ "Guard_Yahalom"
+begin
+
+end
--- a/src/HOL/Auth/Guard/Extensions.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Guard/Extensions.thy Thu Oct 01 07:40:25 2009 +0200
@@ -11,7 +11,9 @@
header {*Extensions to Standard Theories*}
-theory Extensions imports "../Event" begin
+theory Extensions
+imports "../Event"
+begin
subsection{*Extensions to Theory @{text Set}*}
@@ -173,7 +175,7 @@
subsubsection{*lemmas on analz*}
lemma analz_UnI1 [intro]: "X:analz G ==> X:analz (G Un H)"
-by (subgoal_tac "G <= G Un H", auto dest: analz_mono)
+ by (subgoal_tac "G <= G Un H") (blast dest: analz_mono)+
lemma analz_sub: "[| X:analz G; G <= H |] ==> X:analz H"
by (auto dest: analz_mono)
--- a/src/HOL/Auth/KerberosIV.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/KerberosIV.thy Thu Oct 01 07:40:25 2009 +0200
@@ -899,7 +899,6 @@
apply (frule_tac [7] Says_ticket_parts)
apply (simp_all (no_asm_simp))
apply blast
-atp_minimize [atp=spass] Crypt_imp_invKey_keysFor invKey_K new_keys_not_used
apply (metis Crypt_imp_invKey_keysFor invKey_K new_keys_not_used)
apply (clarify)
apply (frule Says_Tgs_message_form, assumption)
@@ -1316,7 +1315,6 @@
txt{*K4*}
apply blast
txt{*Level 8: K5*}
-atp_minimize [atp=e] Tgs_not_bad authKeysI less_SucI mem_def nat_add_commute servK_notin_authKeysD spies_partsEs(1)
apply (blast dest: servK_notin_authKeysD Says_Kas_message_form intro: less_SucI)
txt{*Oops1*}
apply (blast dest!: unique_authKeys intro: less_SucI)
--- a/src/HOL/Auth/KerberosV.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/KerberosV.thy Thu Oct 01 07:40:25 2009 +0200
@@ -697,9 +697,7 @@
txt{*K4*}
apply (force dest!: Crypt_imp_keysFor, clarify)
txt{*K6*}
-apply (drule Says_imp_spies [THEN parts.Inj, THEN parts.Fst])
-apply (drule Says_imp_spies [THEN parts.Inj, THEN parts.Snd])
-apply (blast dest!: unique_CryptKey)
+apply (metis Says_imp_spies Says_ticket_parts analz.Fst analz.Inj analz_conj_parts unique_CryptKey)
done
text{*Needs a unicity theorem, hence moved here*}
@@ -841,13 +839,10 @@
apply (erule kerbV.induct, analz_mono_contra)
apply (frule_tac [7] Says_ticket_parts)
apply (frule_tac [5] Says_ticket_parts, simp_all, blast)
-txt{*K4 splits into distinct subcases*}
-apply auto
-txt{*servK can't have been enclosed in two certificates*}
- prefer 2 apply (blast dest: unique_CryptKey)
-txt{*servK is fresh and so could not have been used, by
- @{text new_keys_not_used}*}
-apply (force dest!: Crypt_imp_invKey_keysFor simp add: AKcryptSK_def)
+txt{*K4*}
+apply (metis Auth_fresh_not_AKcryptSK Crypt_imp_invKey_keysFor Says_ticket_analz
+ analz.Fst invKey_K new_keys_not_analzd parts.Fst Says_imp_parts_knows_Spy
+ unique_CryptKey)
done
text{*Long term keys are not issued as servKeys*}
@@ -981,9 +976,7 @@
txt{*K4*}
apply (blast dest!: authK_not_AKcryptSK)
txt{*Oops1*}
-apply clarify
-apply simp
-apply (blast dest!: AKcryptSK_analz_insert)
+apply (metis AKcryptSK_analz_insert insert_Key_singleton)
done
text{* First simplification law for analz: no session keys encrypt
@@ -1039,8 +1032,8 @@
\<in> set evs; authK \<in> symKeys;
Key authK \<in> analz (spies evs); evs \<in> kerbV \<rbrakk>
\<Longrightarrow> Key servK \<in> analz (spies evs)"
-apply (force dest: Says_imp_spies [THEN analz.Inj, THEN analz.Fst, THEN analz.Decrypt, THEN analz.Fst])
-done
+ by (metis Says_imp_analz_Spy analz.Fst analz_Decrypt')
+
text{*lemma @{text servK_notin_authKeysD} not needed in version V*}
@@ -1112,16 +1105,16 @@
apply (frule_tac [5] Says_ticket_analz)
apply (safe del: impI conjI impCE)
apply (simp_all add: less_SucI new_keys_not_analzd Says_Kas_message_form Says_Tgs_message_form analz_insert_eq not_parts_not_analz analz_insert_freshK1 analz_insert_freshK2 analz_insert_freshK3_bis pushes)
-txt{*Fake*}
-apply spy_analz
-txt{*K2*}
-apply (blast intro: parts_insertI less_SucI)
-txt{*K4*}
-apply (blast dest: authTicket_authentic Confidentiality_Kas)
-txt{*Oops1*}
+ txt{*Fake*}
+ apply spy_analz
+ txt{*K2*}
+ apply (blast intro: parts_insertI less_SucI)
+ txt{*K4*}
+ apply (blast dest: authTicket_authentic Confidentiality_Kas)
+ txt{*Oops1*}
apply (blast dest: Says_Kas_message_form Says_Tgs_message_form intro: less_SucI)
txt{*Oops2*}
- apply (blast dest: Says_imp_spies [THEN parts.Inj] Key_unique_SesKey intro: less_SucI)
+apply (metis Suc_le_eq linorder_linear linorder_not_le msg.simps(2) unique_servKeys)
done
@@ -1270,17 +1263,7 @@
Key authK \<notin> analz (spies evs); Key servK \<notin> analz (spies evs);
A \<notin> bad; B \<notin> bad; evs \<in> kerbV \<rbrakk>
\<Longrightarrow> Says B A (Crypt servK (Number T3)) \<in> set evs"
-apply (frule authK_authentic)
-apply assumption+
-apply (frule servK_authentic)
-prefer 2 apply (blast dest: authK_authentic Says_Kas_message_form)
-apply assumption+
-apply clarify
-apply (blast dest: K4_imp_K2 Key_unique_SesKey intro!: Says_K6)
-(*Single command proof: much slower!
-apply (blast dest: authK_authentic servK_authentic Says_Kas_message_form Key_unique_SesKey K4_imp_K2 intro!: Says_K6)
-*)
-done
+ by (metis authK_authentic Oops_range_spies1 Says_K6 servK_authentic u_K4_imp_K2 unique_authKeys)
lemma A_authenticates_B_r:
"\<lbrakk> Crypt servK (Number T3) \<in> parts (spies evs);
@@ -1301,8 +1284,7 @@
apply (erule_tac [9] exE)
apply (frule_tac [9] K4_imp_K2)
apply assumption+
-apply (blast dest: Key_unique_SesKey intro!: Says_K6 dest: Confidentiality_Tgs
-)
+apply (blast dest: Key_unique_SesKey intro!: Says_K6 dest: Confidentiality_Tgs)
done
@@ -1478,7 +1460,7 @@
...expands as follows - including extra exE because of new form of lemmas*)
apply (frule K3_imp_K2, assumption, assumption, erule exE, erule exE)
apply (case_tac "Key authK \<in> analz (spies evs5)")
-apply (drule Says_imp_knows_Spy [THEN analz.Inj, THEN analz.Fst, THEN analz_Decrypt', THEN analz.Fst], assumption, assumption, simp)
+ apply (metis Says_imp_analz_Spy analz.Fst analz_Decrypt')
apply (frule K3_imp_K2, assumption, assumption, erule exE, erule exE)
apply (drule Says_imp_knows_Spy [THEN parts.Inj, THEN parts.Fst])
apply (frule servK_authentic_ter, blast, assumption+)
--- a/src/HOL/Auth/Kerberos_BAN.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Kerberos_BAN.thy Thu Oct 01 07:40:25 2009 +0200
@@ -288,15 +288,8 @@
on evs)"
apply (unfold before_def)
apply (erule rev_mp)
-apply (erule bankerberos.induct, simp_all)
-txt{*We need this simplification only for Message 2*}
-apply (simp (no_asm) add: takeWhile_tail)
-apply auto
-txt{*Two subcases of Message 2. Subcase: used before*}
-apply (blast dest: used_evs_rev [THEN equalityD2, THEN contra_subsetD]
- used_takeWhile_used)
-txt{*subcase: CT before*}
-apply (fastsimp dest!: set_evs_rev [THEN equalityD2, THEN contra_subsetD, THEN takeWhile_void])
+apply (erule bankerberos.induct, simp_all add: takeWhile_tail)
+apply (metis length_rev set_rev takeWhile_void used_evs_rev)
done
@@ -492,6 +485,7 @@
txt{*BK3*}
apply (blast dest: Kab_authentic unique_session_keys)
done
+
lemma lemma_B [rule_format]:
"\<lbrakk> B \<notin> bad; evs \<in> bankerberos \<rbrakk>
\<Longrightarrow> Key K \<notin> analz (spies evs) \<longrightarrow>
@@ -585,9 +579,8 @@
txt{*BK2*}
apply (blast intro: parts_insertI less_SucI)
txt{*BK3*}
-apply (case_tac "Aa \<in> bad")
- prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
-apply (blast dest: Says_imp_spies [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz intro: less_SucI)
+apply (metis Crypt_Spy_analz_bad Kab_authentic Says_imp_analz_Spy
+ Says_imp_parts_knows_Spy analz.Snd less_SucI unique_session_keys)
txt{*Oops: PROOF FAILS if unsafe intro below*}
apply (blast dest: unique_session_keys intro!: less_SucI)
done
--- a/src/HOL/Auth/NS_Shared.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/NS_Shared.thy Thu Oct 01 07:40:25 2009 +0200
@@ -273,11 +273,11 @@
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes split_ifs, spy_analz)
txt{*NS2*}
apply blast
-txt{*NS3, Server sub-case*}
+txt{*NS3*}
apply (blast dest!: Crypt_Spy_analz_bad A_trusts_NS2
dest: Says_imp_knows_Spy analz.Inj unique_session_keys)
-txt{*NS3, Spy sub-case; also Oops*}
-apply (blast dest: unique_session_keys)+
+txt{*Oops*}
+apply (blast dest: unique_session_keys)
done
@@ -318,9 +318,7 @@
@{term "Crypt K (Nonce NB) \<in> parts (spies evs2)"} *}
apply (force dest!: Crypt_imp_keysFor)
txt{*NS4*}
-apply (blast dest: B_trusts_NS3
- Says_imp_knows_Spy [THEN analz.Inj]
- Crypt_Spy_analz_bad unique_session_keys)
+apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done
text{*This version no longer assumes that K is secure*}
@@ -349,9 +347,7 @@
txt{*NS2*}
apply (blast dest!: new_keys_not_used Crypt_imp_keysFor)
txt{*NS4*}
-apply (blast dest: B_trusts_NS3
- dest: Says_imp_knows_Spy [THEN analz.Inj]
- unique_session_keys Crypt_Spy_analz_bad)
+apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done
@@ -475,18 +471,15 @@
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
-apply (frule_tac [5] Says_S_message_form)
apply (simp_all)
txt{*Fake*}
apply blast
txt{*NS2*}
apply (force dest!: Crypt_imp_keysFor)
-txt{*NS3, much quicker having installed @{term Says_S_message_form} before simplication*}
-apply fastsimp
+txt{*NS3*}
+apply (metis NS3_msg_in_parts_spies parts_cut_eq)
txt{*NS5, the most important case, can be solved by unicity*}
-apply (case_tac "Aa \<in> bad")
-apply (force dest!: Says_imp_spies [THEN analz.Inj, THEN analz.Decrypt, THEN analz.Snd, THEN analz.Snd, THEN analz.Fst])
-apply (blast dest: A_trusts_NS2 unique_session_keys)
+apply (metis A_trusts_NS2 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst analz.Snd unique_session_keys)
done
lemma A_Issues_B:
--- a/src/HOL/Auth/Public.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Public.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Auth/Public
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1996 University of Cambridge
@@ -8,7 +7,9 @@
Private and public keys; initial states of agents
*)
-theory Public imports Event begin
+theory Public
+imports Event
+begin
lemma invKey_K: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)
--- a/src/HOL/Auth/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,51 +1,2 @@
-(* Title: HOL/Auth/ROOT.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1996 University of Cambridge
-Root file for protocol proofs.
-*)
-
-use_thys [
-
-(* Conventional protocols: rely on
- conventional Message, Event and Public *)
-
-(*Shared-key protocols*)
- "NS_Shared",
- "Kerberos_BAN",
- "Kerberos_BAN_Gets",
- "KerberosIV",
- "KerberosIV_Gets",
- "KerberosV",
- "OtwayRees",
- "OtwayRees_AN",
- "OtwayRees_Bad",
- "OtwayReesBella",
- "WooLam",
- "Recur",
- "Yahalom",
- "Yahalom2",
- "Yahalom_Bad",
- "ZhouGollmann",
-
-(*Public-key protocols*)
- "NS_Public_Bad",
- "NS_Public",
- "TLS",
- "CertifiedEmail",
-
-(*Smartcard protocols: rely on conventional Message and on new
- EventSC and Smartcard *)
-
- "Smartcard/ShoupRubin",
- "Smartcard/ShoupRubinBella",
-
-(*Blanqui's "guard" concept: protocol-independent secrecy*)
- "Guard/P1",
- "Guard/P2",
- "Guard/Guard_NS_Public",
- "Guard/Guard_OtwayRees",
- "Guard/Guard_Yahalom",
- "Guard/Proto"
-];
+use_thys ["Auth_Shared", "Auth_Public", "Smartcard/Auth_Smartcard", "Guard/Auth_Guard_Shared", "Guard/Auth_Guard_Public"];
--- a/src/HOL/Auth/Recur.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Recur.thy Thu Oct 01 07:40:25 2009 +0200
@@ -419,15 +419,10 @@
apply spy_analz
txt{*RA2*}
apply blast
-txt{*RA3 remains*}
+txt{*RA3*}
apply (simp add: parts_insert_spies)
-txt{*Now we split into two cases. A single blast could do it, but it would take
- a CPU minute.*}
-apply (safe del: impCE)
-txt{*RA3, case 1: use lemma previously proved by induction*}
-apply (blast elim: rev_notE [OF _ respond_Spy_not_see_session_key])
-txt{*RA3, case 2: K is an old key*}
-apply (blast dest: resp_analz_insert dest: Key_in_parts_respond)
+apply (metis Key_in_parts_respond parts.Body parts.Fst resp_analz_insert
+ respond_Spy_not_see_session_key usedI)
txt{*RA4*}
apply blast
done
--- a/src/HOL/Auth/Shared.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Shared.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Auth/Shared
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1996 University of Cambridge
@@ -8,7 +7,9 @@
Shared, long-term keys; initial states of agents
*)
-theory Shared imports Event begin
+theory Shared
+imports Event All_Symmetric
+begin
consts
shrK :: "agent => key" (*symmetric keys*);
@@ -20,13 +21,6 @@
apply (simp add: inj_on_def split: agent.split)
done
-text{*All keys are symmetric*}
-
-defs all_symmetric_def: "all_symmetric == True"
-
-lemma isSym_keys: "K \<in> symKeys"
-by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
-
text{*Server knows all long-term keys; other agents know only their own*}
primrec
initState_Server: "initState Server = Key ` range shrK"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Smartcard/Auth_Smartcard.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,13 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Smartcard protocols: rely on conventional Message and on new EventSC and Smartcard *}
+
+theory Auth_Smartcard
+imports
+ "ShoupRubin"
+ "ShoupRubinBella"
+begin
+
+end
--- a/src/HOL/Auth/Smartcard/Smartcard.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Auth/Smartcard/Smartcard.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,10 +1,11 @@
-(* ID: $Id$
- Author: Giampaolo Bella, Catania University
+(* Author: Giampaolo Bella, Catania University
*)
header{*Theory of smartcards*}
-theory Smartcard imports EventSC begin
+theory Smartcard
+imports EventSC All_Symmetric
+begin
text{*
As smartcards handle long-term (symmetric) keys, this theoy extends and
@@ -42,14 +43,6 @@
shrK_disj_pin [iff]: "shrK P \<noteq> pin Q"
crdK_disj_pin [iff]: "crdK C \<noteq> pin P"
-
-text{*All keys are symmetric*}
-defs all_symmetric_def: "all_symmetric == True"
-
-lemma isSym_keys: "K \<in> symKeys"
-by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
-
-
constdefs
legalUse :: "card => bool" ("legalUse (_)")
"legalUse C == C \<notin> stolen"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Bali/Bali.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,11 @@
+(* Author: David von Oheimb
+ Copyright 1999 Technische Universitaet Muenchen
+*)
+
+header {* The Hoare logic for Bali. *}
+
+theory Bali
+imports AxExample AxSound AxCompl Trans
+begin
+
+end
--- a/src/HOL/Bali/DeclConcepts.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Bali/DeclConcepts.thy Thu Oct 01 07:40:25 2009 +0200
@@ -154,21 +154,14 @@
instance decl_ext_type :: ("has_static") has_static ..
-defs (overloaded)
-decl_is_static_def:
- "is_static (m::('a::has_static) decl_scheme) \<equiv> is_static (Decl.decl.more m)"
-
instance member_ext_type :: ("type") has_static ..
defs (overloaded)
static_field_type_is_static_def:
- "is_static (m::('b::type) member_ext_type) \<equiv> static_sel m"
+ "is_static (m::('b member_scheme)) \<equiv> static m"
lemma member_is_static_simp: "is_static (m::'a member_scheme) = static m"
-apply (cases m)
-apply (simp add: static_field_type_is_static_def
- decl_is_static_def Decl.member.dest_convs)
-done
+by (simp add: static_field_type_is_static_def)
instance * :: ("type","has_static") has_static ..
@@ -402,30 +395,16 @@
instance decl_ext_type :: ("has_resTy") has_resTy ..
-defs (overloaded)
-decl_resTy_def:
- "resTy (m::('a::has_resTy) decl_scheme) \<equiv> resTy (Decl.decl.more m)"
-
instance member_ext_type :: ("has_resTy") has_resTy ..
-defs (overloaded)
-member_ext_type_resTy_def:
- "resTy (m::('b::has_resTy) member_ext_type)
- \<equiv> resTy (member.more_sel m)"
-
instance mhead_ext_type :: ("type") has_resTy ..
defs (overloaded)
mhead_ext_type_resTy_def:
- "resTy (m::('b mhead_ext_type))
- \<equiv> resT_sel m"
+ "resTy (m::('b mhead_scheme)) \<equiv> resT m"
lemma mhead_resTy_simp: "resTy (m::'a mhead_scheme) = resT m"
-apply (cases m)
-apply (simp add: decl_resTy_def member_ext_type_resTy_def
- mhead_ext_type_resTy_def
- member.dest_convs mhead.dest_convs)
-done
+by (simp add: mhead_ext_type_resTy_def)
lemma resTy_mhead [simp]:"resTy (mhead m) = resTy m"
by (simp add: mhead_def mhead_resTy_simp)
--- a/src/HOL/Bali/DefiniteAssignmentCorrect.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Bali/DefiniteAssignmentCorrect.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1747,7 +1747,7 @@
have "assigns (In1l e2) \<subseteq> dom (locals (store s2))"
by (simp add: need_second_arg_def)
with s2
- show ?thesis using False by (simp add: Un_subset_iff)
+ show ?thesis using False by simp
qed
next
case Super thus ?case by simp
--- a/src/HOL/Bali/Example.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Bali/Example.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1167,7 +1167,6 @@
apply (simp,rule assigned.select_convs)
apply (simp)
apply simp
-apply blast
apply simp
apply (simp add: intersect_ts_def)
done
--- a/src/HOL/Bali/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Bali/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,9 +1,2 @@
-(* Title: HOL/Bali/ROOT.ML
- ID: $Id$
- Author: David von Oheimb
- Copyright 1999 Technische Universitaet Muenchen
-The Hoare logic for Bali.
-*)
-
-use_thys ["AxExample", "AxSound", "AxCompl", "Trans"];
+use_thy "Bali"
--- a/src/HOL/Bali/TypeSafe.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Bali/TypeSafe.thy Thu Oct 01 07:40:25 2009 +0200
@@ -2953,7 +2953,7 @@
by simp
from da_e1 s0_s1 True obtain E1' where
"\<lparr>prg=G,cls=accC,lcl=L\<rparr>\<turnstile> (dom (locals (store s1)))\<guillemotright>In1l e1\<guillemotright> E1'"
- by - (rule da_weakenE, auto iff del: Un_subset_iff)
+ by - (rule da_weakenE, auto iff del: Un_subset_iff le_sup_iff)
with conf_s1 wt_e1
obtain
"s2\<Colon>\<preceq>(G, L)"
@@ -2972,7 +2972,7 @@
by simp
from da_e2 s0_s1 False obtain E2' where
"\<lparr>prg=G,cls=accC,lcl=L\<rparr>\<turnstile> (dom (locals (store s1)))\<guillemotright>In1l e2\<guillemotright> E2'"
- by - (rule da_weakenE, auto iff del: Un_subset_iff)
+ by - (rule da_weakenE, auto iff del: Un_subset_iff le_sup_iff)
with conf_s1 wt_e2
obtain
"s2\<Colon>\<preceq>(G, L)"
--- a/src/HOL/Code_Eval.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,271 +0,0 @@
-(* Title: HOL/Code_Eval.thy
- Author: Florian Haftmann, TU Muenchen
-*)
-
-header {* Term evaluation using the generic code generator *}
-
-theory Code_Eval
-imports Plain Typerep Code_Numeral
-begin
-
-subsection {* Term representation *}
-
-subsubsection {* Terms and class @{text term_of} *}
-
-datatype "term" = dummy_term
-
-definition Const :: "String.literal \<Rightarrow> typerep \<Rightarrow> term" where
- "Const _ _ = dummy_term"
-
-definition App :: "term \<Rightarrow> term \<Rightarrow> term" where
- "App _ _ = dummy_term"
-
-code_datatype Const App
-
-class term_of = typerep +
- fixes term_of :: "'a \<Rightarrow> term"
-
-lemma term_of_anything: "term_of x \<equiv> t"
- by (rule eq_reflection) (cases "term_of x", cases t, simp)
-
-definition valapp :: "('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)
- \<Rightarrow> 'a \<times> (unit \<Rightarrow> term) \<Rightarrow> 'b \<times> (unit \<Rightarrow> term)" where
- "valapp f x = (fst f (fst x), \<lambda>u. App (snd f ()) (snd x ()))"
-
-lemma valapp_code [code, code_unfold]:
- "valapp (f, tf) (x, tx) = (f x, \<lambda>u. App (tf ()) (tx ()))"
- by (simp only: valapp_def fst_conv snd_conv)
-
-
-subsubsection {* @{text term_of} instances *}
-
-instantiation "fun" :: (typerep, typerep) term_of
-begin
-
-definition
- "term_of (f \<Colon> 'a \<Rightarrow> 'b) = Const (STR ''dummy_pattern'') (Typerep.Typerep (STR ''fun'')
- [Typerep.typerep TYPE('a), Typerep.typerep TYPE('b)])"
-
-instance ..
-
-end
-
-setup {*
-let
- fun add_term_of tyco raw_vs thy =
- let
- val vs = map (fn (v, _) => (v, @{sort typerep})) raw_vs;
- val ty = Type (tyco, map TFree vs);
- val lhs = Const (@{const_name term_of}, ty --> @{typ term})
- $ Free ("x", ty);
- val rhs = @{term "undefined \<Colon> term"};
- val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
- fun triv_name_of t = (fst o dest_Free o fst o strip_comb o fst
- o HOLogic.dest_eq o HOLogic.dest_Trueprop) t ^ "_triv";
- in
- thy
- |> TheoryTarget.instantiation ([tyco], vs, @{sort term_of})
- |> `(fn lthy => Syntax.check_term lthy eq)
- |-> (fn eq => Specification.definition (NONE, ((Binding.name (triv_name_of eq), []), eq)))
- |> snd
- |> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
- end;
- fun ensure_term_of (tyco, (raw_vs, _)) thy =
- let
- val need_inst = not (can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of})
- andalso can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort typerep};
- in if need_inst then add_term_of tyco raw_vs thy else thy end;
-in
- Code.type_interpretation ensure_term_of
-end
-*}
-
-setup {*
-let
- fun mk_term_of_eq thy ty vs tyco (c, tys) =
- let
- val t = list_comb (Const (c, tys ---> ty),
- map Free (Name.names Name.context "a" tys));
- val (arg, rhs) = pairself (Thm.cterm_of thy o map_types Logic.unvarifyT o Logic.varify)
- (t, (map_aterms (fn t as Free (v, ty) => HOLogic.mk_term_of ty t | t => t) o HOLogic.reflect_term) t)
- val cty = Thm.ctyp_of thy ty;
- in
- @{thm term_of_anything}
- |> Drule.instantiate' [SOME cty] [SOME arg, SOME rhs]
- |> Thm.varifyT
- end;
- fun add_term_of_code tyco raw_vs raw_cs thy =
- let
- val algebra = Sign.classes_of thy;
- val vs = map (fn (v, sort) =>
- (v, curry (Sorts.inter_sort algebra) @{sort typerep} sort)) raw_vs;
- val ty = Type (tyco, map TFree vs);
- val cs = (map o apsnd o map o map_atyps)
- (fn TFree (v, _) => TFree (v, (the o AList.lookup (op =) vs) v)) raw_cs;
- val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
- val eqs = map (mk_term_of_eq thy ty vs tyco) cs;
- in
- thy
- |> Code.del_eqns const
- |> fold Code.add_eqn eqs
- end;
- fun ensure_term_of_code (tyco, (raw_vs, cs)) thy =
- let
- val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
- in if has_inst then add_term_of_code tyco raw_vs cs thy else thy end;
-in
- Code.type_interpretation ensure_term_of_code
-end
-*}
-
-
-subsubsection {* Code generator setup *}
-
-lemmas [code del] = term.recs term.cases term.size
-lemma [code, code del]: "eq_class.eq (t1\<Colon>term) t2 \<longleftrightarrow> eq_class.eq t1 t2" ..
-
-lemma [code, code del]: "(term_of \<Colon> typerep \<Rightarrow> term) = term_of" ..
-lemma [code, code del]: "(term_of \<Colon> term \<Rightarrow> term) = term_of" ..
-lemma [code, code del]: "(term_of \<Colon> String.literal \<Rightarrow> term) = term_of" ..
-lemma [code, code del]:
- "(Code_Eval.term_of \<Colon> 'a::{type, term_of} Predicate.pred \<Rightarrow> Code_Eval.term) = Code_Eval.term_of" ..
-lemma [code, code del]:
- "(Code_Eval.term_of \<Colon> 'a::{type, term_of} Predicate.seq \<Rightarrow> Code_Eval.term) = Code_Eval.term_of" ..
-
-lemma term_of_char [unfolded typerep_fun_def typerep_char_def typerep_nibble_def, code]: "Code_Eval.term_of c =
- (let (n, m) = nibble_pair_of_char c
- in Code_Eval.App (Code_Eval.App (Code_Eval.Const (STR ''String.char.Char'') (TYPEREP(nibble \<Rightarrow> nibble \<Rightarrow> char)))
- (Code_Eval.term_of n)) (Code_Eval.term_of m))"
- by (subst term_of_anything) rule
-
-code_type "term"
- (Eval "Term.term")
-
-code_const Const and App
- (Eval "Term.Const/ ((_), (_))" and "Term.$/ ((_), (_))")
-
-code_const "term_of \<Colon> String.literal \<Rightarrow> term"
- (Eval "HOLogic.mk'_message'_string")
-
-code_reserved Eval HOLogic
-
-
-subsubsection {* Syntax *}
-
-definition termify :: "'a \<Rightarrow> term" where
- [code del]: "termify x = dummy_term"
-
-abbreviation valtermify :: "'a \<Rightarrow> 'a \<times> (unit \<Rightarrow> term)" where
- "valtermify x \<equiv> (x, \<lambda>u. termify x)"
-
-setup {*
-let
- fun map_default f xs =
- let val ys = map f xs
- in if exists is_some ys
- then SOME (map2 the_default xs ys)
- else NONE
- end;
- fun subst_termify_app (Const (@{const_name termify}, T), [t]) =
- if not (Term.has_abs t)
- then if fold_aterms (fn Const _ => I | _ => K false) t true
- then SOME (HOLogic.reflect_term t)
- else error "Cannot termify expression containing variables"
- else error "Cannot termify expression containing abstraction"
- | subst_termify_app (t, ts) = case map_default subst_termify ts
- of SOME ts' => SOME (list_comb (t, ts'))
- | NONE => NONE
- and subst_termify (Abs (v, T, t)) = (case subst_termify t
- of SOME t' => SOME (Abs (v, T, t'))
- | NONE => NONE)
- | subst_termify t = subst_termify_app (strip_comb t)
- fun check_termify ts ctxt = map_default subst_termify ts
- |> Option.map (rpair ctxt)
-in
- Context.theory_map (Syntax.add_term_check 0 "termify" check_termify)
-end;
-*}
-
-locale term_syntax
-begin
-
-notation App (infixl "<\<cdot>>" 70)
- and valapp (infixl "{\<cdot>}" 70)
-
-end
-
-interpretation term_syntax .
-
-no_notation App (infixl "<\<cdot>>" 70)
- and valapp (infixl "{\<cdot>}" 70)
-
-
-subsection {* Numeric types *}
-
-definition term_of_num :: "'a\<Colon>{semiring_div} \<Rightarrow> 'a\<Colon>{semiring_div} \<Rightarrow> term" where
- "term_of_num two = (\<lambda>_. dummy_term)"
-
-lemma (in term_syntax) term_of_num_code [code]:
- "term_of_num two k = (if k = 0 then termify Int.Pls
- else (if k mod two = 0
- then termify Int.Bit0 <\<cdot>> term_of_num two (k div two)
- else termify Int.Bit1 <\<cdot>> term_of_num two (k div two)))"
- by (auto simp add: term_of_anything Const_def App_def term_of_num_def Let_def)
-
-lemma (in term_syntax) term_of_nat_code [code]:
- "term_of (n::nat) = termify (number_of :: int \<Rightarrow> nat) <\<cdot>> term_of_num (2::nat) n"
- by (simp only: term_of_anything)
-
-lemma (in term_syntax) term_of_int_code [code]:
- "term_of (k::int) = (if k = 0 then termify (0 :: int)
- else if k > 0 then termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) k
- else termify (uminus :: int \<Rightarrow> int) <\<cdot>> (termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) (- k)))"
- by (simp only: term_of_anything)
-
-lemma (in term_syntax) term_of_code_numeral_code [code]:
- "term_of (k::code_numeral) = termify (number_of :: int \<Rightarrow> code_numeral) <\<cdot>> term_of_num (2::code_numeral) k"
- by (simp only: term_of_anything)
-
-subsection {* Obfuscate *}
-
-print_translation {*
-let
- val term = Const ("<TERM>", dummyT);
- fun tr1' [_, _] = term;
- fun tr2' [] = term;
-in
- [(@{const_syntax Const}, tr1'),
- (@{const_syntax App}, tr1'),
- (@{const_syntax dummy_term}, tr2')]
-end
-*}
-
-hide const dummy_term App valapp
-hide (open) const Const termify valtermify term_of term_of_num
-
-
-subsection {* Evaluation setup *}
-
-ML {*
-signature EVAL =
-sig
- val eval_ref: (unit -> term) option ref
- val eval_term: theory -> term -> term
-end;
-
-structure Eval : EVAL =
-struct
-
-val eval_ref = ref (NONE : (unit -> term) option);
-
-fun eval_term thy t =
- Code_ML.eval NONE ("Eval.eval_ref", eval_ref) I thy (HOLogic.mk_term_of (fastype_of t) t) [];
-
-end;
-*}
-
-setup {*
- Value.add_evaluator ("code", Eval.eval_term o ProofContext.theory_of)
-*}
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Code_Evaluation.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,271 @@
+(* Title: HOL/Code_Evaluation.thy
+ Author: Florian Haftmann, TU Muenchen
+*)
+
+header {* Term evaluation using the generic code generator *}
+
+theory Code_Evaluation
+imports Plain Typerep Code_Numeral
+begin
+
+subsection {* Term representation *}
+
+subsubsection {* Terms and class @{text term_of} *}
+
+datatype "term" = dummy_term
+
+definition Const :: "String.literal \<Rightarrow> typerep \<Rightarrow> term" where
+ "Const _ _ = dummy_term"
+
+definition App :: "term \<Rightarrow> term \<Rightarrow> term" where
+ "App _ _ = dummy_term"
+
+code_datatype Const App
+
+class term_of = typerep +
+ fixes term_of :: "'a \<Rightarrow> term"
+
+lemma term_of_anything: "term_of x \<equiv> t"
+ by (rule eq_reflection) (cases "term_of x", cases t, simp)
+
+definition valapp :: "('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)
+ \<Rightarrow> 'a \<times> (unit \<Rightarrow> term) \<Rightarrow> 'b \<times> (unit \<Rightarrow> term)" where
+ "valapp f x = (fst f (fst x), \<lambda>u. App (snd f ()) (snd x ()))"
+
+lemma valapp_code [code, code_unfold]:
+ "valapp (f, tf) (x, tx) = (f x, \<lambda>u. App (tf ()) (tx ()))"
+ by (simp only: valapp_def fst_conv snd_conv)
+
+
+subsubsection {* @{text term_of} instances *}
+
+instantiation "fun" :: (typerep, typerep) term_of
+begin
+
+definition
+ "term_of (f \<Colon> 'a \<Rightarrow> 'b) = Const (STR ''dummy_pattern'') (Typerep.Typerep (STR ''fun'')
+ [Typerep.typerep TYPE('a), Typerep.typerep TYPE('b)])"
+
+instance ..
+
+end
+
+setup {*
+let
+ fun add_term_of tyco raw_vs thy =
+ let
+ val vs = map (fn (v, _) => (v, @{sort typerep})) raw_vs;
+ val ty = Type (tyco, map TFree vs);
+ val lhs = Const (@{const_name term_of}, ty --> @{typ term})
+ $ Free ("x", ty);
+ val rhs = @{term "undefined \<Colon> term"};
+ val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
+ fun triv_name_of t = (fst o dest_Free o fst o strip_comb o fst
+ o HOLogic.dest_eq o HOLogic.dest_Trueprop) t ^ "_triv";
+ in
+ thy
+ |> TheoryTarget.instantiation ([tyco], vs, @{sort term_of})
+ |> `(fn lthy => Syntax.check_term lthy eq)
+ |-> (fn eq => Specification.definition (NONE, ((Binding.name (triv_name_of eq), []), eq)))
+ |> snd
+ |> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
+ end;
+ fun ensure_term_of (tyco, (raw_vs, _)) thy =
+ let
+ val need_inst = not (can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of})
+ andalso can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort typerep};
+ in if need_inst then add_term_of tyco raw_vs thy else thy end;
+in
+ Code.type_interpretation ensure_term_of
+end
+*}
+
+setup {*
+let
+ fun mk_term_of_eq thy ty vs tyco (c, tys) =
+ let
+ val t = list_comb (Const (c, tys ---> ty),
+ map Free (Name.names Name.context "a" tys));
+ val (arg, rhs) = pairself (Thm.cterm_of thy o map_types Logic.unvarifyT o Logic.varify)
+ (t, (map_aterms (fn t as Free (v, ty) => HOLogic.mk_term_of ty t | t => t) o HOLogic.reflect_term) t)
+ val cty = Thm.ctyp_of thy ty;
+ in
+ @{thm term_of_anything}
+ |> Drule.instantiate' [SOME cty] [SOME arg, SOME rhs]
+ |> Thm.varifyT
+ end;
+ fun add_term_of_code tyco raw_vs raw_cs thy =
+ let
+ val algebra = Sign.classes_of thy;
+ val vs = map (fn (v, sort) =>
+ (v, curry (Sorts.inter_sort algebra) @{sort typerep} sort)) raw_vs;
+ val ty = Type (tyco, map TFree vs);
+ val cs = (map o apsnd o map o map_atyps)
+ (fn TFree (v, _) => TFree (v, (the o AList.lookup (op =) vs) v)) raw_cs;
+ val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
+ val eqs = map (mk_term_of_eq thy ty vs tyco) cs;
+ in
+ thy
+ |> Code.del_eqns const
+ |> fold Code.add_eqn eqs
+ end;
+ fun ensure_term_of_code (tyco, (raw_vs, cs)) thy =
+ let
+ val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
+ in if has_inst then add_term_of_code tyco raw_vs cs thy else thy end;
+in
+ Code.type_interpretation ensure_term_of_code
+end
+*}
+
+
+subsubsection {* Code generator setup *}
+
+lemmas [code del] = term.recs term.cases term.size
+lemma [code, code del]: "eq_class.eq (t1\<Colon>term) t2 \<longleftrightarrow> eq_class.eq t1 t2" ..
+
+lemma [code, code del]: "(term_of \<Colon> typerep \<Rightarrow> term) = term_of" ..
+lemma [code, code del]: "(term_of \<Colon> term \<Rightarrow> term) = term_of" ..
+lemma [code, code del]: "(term_of \<Colon> String.literal \<Rightarrow> term) = term_of" ..
+lemma [code, code del]:
+ "(Code_Evaluation.term_of \<Colon> 'a::{type, term_of} Predicate.pred \<Rightarrow> Code_Evaluation.term) = Code_Evaluation.term_of" ..
+lemma [code, code del]:
+ "(Code_Evaluation.term_of \<Colon> 'a::{type, term_of} Predicate.seq \<Rightarrow> Code_Evaluation.term) = Code_Evaluation.term_of" ..
+
+lemma term_of_char [unfolded typerep_fun_def typerep_char_def typerep_nibble_def, code]: "Code_Evaluation.term_of c =
+ (let (n, m) = nibble_pair_of_char c
+ in Code_Evaluation.App (Code_Evaluation.App (Code_Evaluation.Const (STR ''String.char.Char'') (TYPEREP(nibble \<Rightarrow> nibble \<Rightarrow> char)))
+ (Code_Evaluation.term_of n)) (Code_Evaluation.term_of m))"
+ by (subst term_of_anything) rule
+
+code_type "term"
+ (Eval "Term.term")
+
+code_const Const and App
+ (Eval "Term.Const/ ((_), (_))" and "Term.$/ ((_), (_))")
+
+code_const "term_of \<Colon> String.literal \<Rightarrow> term"
+ (Eval "HOLogic.mk'_message'_string")
+
+code_reserved Eval HOLogic
+
+
+subsubsection {* Syntax *}
+
+definition termify :: "'a \<Rightarrow> term" where
+ [code del]: "termify x = dummy_term"
+
+abbreviation valtermify :: "'a \<Rightarrow> 'a \<times> (unit \<Rightarrow> term)" where
+ "valtermify x \<equiv> (x, \<lambda>u. termify x)"
+
+setup {*
+let
+ fun map_default f xs =
+ let val ys = map f xs
+ in if exists is_some ys
+ then SOME (map2 the_default xs ys)
+ else NONE
+ end;
+ fun subst_termify_app (Const (@{const_name termify}, T), [t]) =
+ if not (Term.has_abs t)
+ then if fold_aterms (fn Const _ => I | _ => K false) t true
+ then SOME (HOLogic.reflect_term t)
+ else error "Cannot termify expression containing variables"
+ else error "Cannot termify expression containing abstraction"
+ | subst_termify_app (t, ts) = case map_default subst_termify ts
+ of SOME ts' => SOME (list_comb (t, ts'))
+ | NONE => NONE
+ and subst_termify (Abs (v, T, t)) = (case subst_termify t
+ of SOME t' => SOME (Abs (v, T, t'))
+ | NONE => NONE)
+ | subst_termify t = subst_termify_app (strip_comb t)
+ fun check_termify ts ctxt = map_default subst_termify ts
+ |> Option.map (rpair ctxt)
+in
+ Context.theory_map (Syntax.add_term_check 0 "termify" check_termify)
+end;
+*}
+
+locale term_syntax
+begin
+
+notation App (infixl "<\<cdot>>" 70)
+ and valapp (infixl "{\<cdot>}" 70)
+
+end
+
+interpretation term_syntax .
+
+no_notation App (infixl "<\<cdot>>" 70)
+ and valapp (infixl "{\<cdot>}" 70)
+
+
+subsection {* Numeric types *}
+
+definition term_of_num :: "'a\<Colon>{semiring_div} \<Rightarrow> 'a\<Colon>{semiring_div} \<Rightarrow> term" where
+ "term_of_num two = (\<lambda>_. dummy_term)"
+
+lemma (in term_syntax) term_of_num_code [code]:
+ "term_of_num two k = (if k = 0 then termify Int.Pls
+ else (if k mod two = 0
+ then termify Int.Bit0 <\<cdot>> term_of_num two (k div two)
+ else termify Int.Bit1 <\<cdot>> term_of_num two (k div two)))"
+ by (auto simp add: term_of_anything Const_def App_def term_of_num_def Let_def)
+
+lemma (in term_syntax) term_of_nat_code [code]:
+ "term_of (n::nat) = termify (number_of :: int \<Rightarrow> nat) <\<cdot>> term_of_num (2::nat) n"
+ by (simp only: term_of_anything)
+
+lemma (in term_syntax) term_of_int_code [code]:
+ "term_of (k::int) = (if k = 0 then termify (0 :: int)
+ else if k > 0 then termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) k
+ else termify (uminus :: int \<Rightarrow> int) <\<cdot>> (termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) (- k)))"
+ by (simp only: term_of_anything)
+
+lemma (in term_syntax) term_of_code_numeral_code [code]:
+ "term_of (k::code_numeral) = termify (number_of :: int \<Rightarrow> code_numeral) <\<cdot>> term_of_num (2::code_numeral) k"
+ by (simp only: term_of_anything)
+
+subsection {* Obfuscate *}
+
+print_translation {*
+let
+ val term = Const ("<TERM>", dummyT);
+ fun tr1' [_, _] = term;
+ fun tr2' [] = term;
+in
+ [(@{const_syntax Const}, tr1'),
+ (@{const_syntax App}, tr1'),
+ (@{const_syntax dummy_term}, tr2')]
+end
+*}
+
+hide const dummy_term App valapp
+hide (open) const Const termify valtermify term_of term_of_num
+
+
+subsection {* Evaluation setup *}
+
+ML {*
+signature EVAL =
+sig
+ val eval_ref: (unit -> term) option Unsynchronized.ref
+ val eval_term: theory -> term -> term
+end;
+
+structure Eval : EVAL =
+struct
+
+val eval_ref = Unsynchronized.ref (NONE : (unit -> term) option);
+
+fun eval_term thy t =
+ Code_ML.eval NONE ("Eval.eval_ref", eval_ref) I thy (HOLogic.mk_term_of (fastype_of t) t) [];
+
+end;
+*}
+
+setup {*
+ Value.add_evaluator ("code", Eval.eval_term o ProofContext.theory_of)
+*}
+
+end
--- a/src/HOL/Complete_Lattice.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Complete_Lattice.thy Thu Oct 01 07:40:25 2009 +0200
@@ -10,7 +10,9 @@
less_eq (infix "\<sqsubseteq>" 50) and
less (infix "\<sqsubset>" 50) and
inf (infixl "\<sqinter>" 70) and
- sup (infixl "\<squnion>" 65)
+ sup (infixl "\<squnion>" 65) and
+ top ("\<top>") and
+ bot ("\<bottom>")
subsection {* Abstract complete lattices *}
@@ -24,6 +26,15 @@
and Sup_least: "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> \<Squnion>A \<sqsubseteq> z"
begin
+term complete_lattice
+
+lemma dual_complete_lattice:
+ "complete_lattice (op \<ge>) (op >) (op \<squnion>) (op \<sqinter>) \<top> \<bottom> Sup Inf"
+ by (auto intro!: complete_lattice.intro dual_lattice
+ bot.intro top.intro dual_preorder, unfold_locales)
+ (fact bot_least top_greatest
+ Sup_upper Sup_least Inf_lower Inf_greatest)+
+
lemma Inf_Sup: "\<Sqinter>A = \<Squnion>{b. \<forall>a \<in> A. b \<le> a}"
by (auto intro: antisym Inf_lower Inf_greatest Sup_upper Sup_least)
@@ -76,11 +87,11 @@
lemma sup_bot [simp]:
"x \<squnion> bot = x"
- using bot_least [of x] by (simp add: le_iff_sup sup_commute)
+ using bot_least [of x] by (simp add: sup_commute sup_absorb2)
lemma inf_top [simp]:
"x \<sqinter> top = x"
- using top_greatest [of x] by (simp add: le_iff_inf inf_commute)
+ using top_greatest [of x] by (simp add: inf_commute inf_absorb2)
definition SUPR :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
"SUPR A f = \<Squnion> (f ` A)"
@@ -203,8 +214,8 @@
subsection {* Union *}
-definition Union :: "'a set set \<Rightarrow> 'a set" where
- Sup_set_eq [symmetric]: "Union S = \<Squnion>S"
+abbreviation Union :: "'a set set \<Rightarrow> 'a set" where
+ "Union S \<equiv> \<Squnion>S"
notation (xsymbols)
Union ("\<Union>_" [90] 90)
@@ -216,7 +227,7 @@
have "(\<exists>Q\<in>{P. \<exists>B\<in>A. P \<longleftrightarrow> x \<in> B}. Q) \<longleftrightarrow> (\<exists>B\<in>A. x \<in> B)"
by auto
then show "x \<in> \<Union>A \<longleftrightarrow> x \<in> {x. \<exists>B\<in>A. x \<in> B}"
- by (simp add: Sup_set_eq [symmetric] Sup_fun_def Sup_bool_def) (simp add: mem_def)
+ by (simp add: Sup_fun_def Sup_bool_def) (simp add: mem_def)
qed
lemma Union_iff [simp, noatp]:
@@ -278,8 +289,8 @@
subsection {* Unions of families *}
-definition UNION :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
- SUPR_set_eq [symmetric]: "UNION S f = (SUP x:S. f x)"
+abbreviation UNION :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
+ "UNION \<equiv> SUPR"
syntax
"@UNION1" :: "pttrns => 'b set => 'b set" ("(3UN _./ _)" [0, 10] 10)
@@ -314,7 +325,7 @@
lemma UNION_eq_Union_image:
"(\<Union>x\<in>A. B x) = \<Union>(B`A)"
- by (simp add: SUPR_def SUPR_set_eq [symmetric] Sup_set_eq)
+ by (fact SUPR_def)
lemma Union_def:
"\<Union>S = (\<Union>x\<in>S. x)"
@@ -351,7 +362,7 @@
by blast
lemma UN_upper: "a \<in> A ==> B a \<subseteq> (\<Union>x\<in>A. B x)"
- by blast
+ by (fact le_SUPI)
lemma UN_least: "(!!x. x \<in> A ==> B x \<subseteq> C) ==> (\<Union>x\<in>A. B x) \<subseteq> C"
by (iprover intro: subsetI elim: UN_E dest: subsetD)
@@ -439,8 +450,8 @@
subsection {* Inter *}
-definition Inter :: "'a set set \<Rightarrow> 'a set" where
- Inf_set_eq [symmetric]: "Inter S = \<Sqinter>S"
+abbreviation Inter :: "'a set set \<Rightarrow> 'a set" where
+ "Inter S \<equiv> \<Sqinter>S"
notation (xsymbols)
Inter ("\<Inter>_" [90] 90)
@@ -452,7 +463,7 @@
have "(\<forall>Q\<in>{P. \<exists>B\<in>A. P \<longleftrightarrow> x \<in> B}. Q) \<longleftrightarrow> (\<forall>B\<in>A. x \<in> B)"
by auto
then show "x \<in> \<Inter>A \<longleftrightarrow> x \<in> {x. \<forall>B \<in> A. x \<in> B}"
- by (simp add: Inf_fun_def Inf_bool_def Inf_set_eq [symmetric]) (simp add: mem_def)
+ by (simp add: Inf_fun_def Inf_bool_def) (simp add: mem_def)
qed
lemma Inter_iff [simp,noatp]: "(A : Inter C) = (ALL X:C. A:X)"
@@ -514,8 +525,8 @@
subsection {* Intersections of families *}
-definition INTER :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
- INFI_set_eq [symmetric]: "INTER S f = (INF x:S. f x)"
+abbreviation INTER :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
+ "INTER \<equiv> INFI"
syntax
"@INTER1" :: "pttrns => 'b set => 'b set" ("(3INT _./ _)" [0, 10] 10)
@@ -541,7 +552,7 @@
lemma INTER_eq_Inter_image:
"(\<Inter>x\<in>A. B x) = \<Inter>(B`A)"
- by (simp add: INFI_def INFI_set_eq [symmetric] Inf_set_eq)
+ by (fact INFI_def)
lemma Inter_def:
"\<Inter>S = (\<Inter>x\<in>S. x)"
@@ -579,10 +590,10 @@
by blast
lemma INT_lower: "a \<in> A ==> (\<Inter>x\<in>A. B x) \<subseteq> B a"
- by blast
+ by (fact INF_leI)
lemma INT_greatest: "(!!x. x \<in> A ==> C \<subseteq> B x) ==> C \<subseteq> (\<Inter>x\<in>A. B x)"
- by (iprover intro: INT_I subsetI dest: subsetD)
+ by (fact le_INFI)
lemma INT_empty [simp]: "(\<Inter>x\<in>{}. B x) = UNIV"
by blast
@@ -784,7 +795,9 @@
inf (infixl "\<sqinter>" 70) and
sup (infixl "\<squnion>" 65) and
Inf ("\<Sqinter>_" [900] 900) and
- Sup ("\<Squnion>_" [900] 900)
+ Sup ("\<Squnion>_" [900] 900) and
+ top ("\<top>") and
+ bot ("\<bottom>")
lemmas mem_simps =
insert_iff empty_iff Un_iff Int_iff Compl_iff Diff_iff
--- a/src/HOL/Decision_Procs/Approximation.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/Approximation.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1904,7 +1904,7 @@
show "0 < real x * 2/3" using * by auto
show "real ?max + 1 \<le> real x * 2/3" using * up
by (cases "0 < real x * real (lapprox_posrat prec 2 3) - 1",
- auto simp add: real_of_float_max max_def)
+ auto simp add: real_of_float_max min_max.sup_absorb1)
qed
finally have "real (?lb_horner (Float 1 -1)) + real (?lb_horner ?max)
\<le> ln (real x)"
@@ -3246,12 +3246,13 @@
= map (` (variable_of_bound o prop_of)) prems
fun add_deps (name, bnds)
- = Graph.add_deps_acyclic
- (name, remove (op =) name (Term.add_free_names (prop_of bnds) []))
+ = Graph.add_deps_acyclic (name,
+ remove (op =) name (Term.add_free_names (prop_of bnds) []))
+
val order = Graph.empty
|> fold Graph.new_node variable_bounds
|> fold add_deps variable_bounds
- |> Graph.topological_order |> rev
+ |> Graph.strong_conn |> map the_single |> rev
|> map_filter (AList.lookup (op =) variable_bounds)
fun prepend_prem th tac
@@ -3338,7 +3339,7 @@
etac @{thm meta_eqE},
rtac @{thm impI}] i)
THEN Subgoal.FOCUS (fn {prems, ...} => reorder_bounds_tac prems i) @{context} i
- THEN TRY (filter_prems_tac (K false) i)
+ THEN DETERM (TRY (filter_prems_tac (K false) i))
THEN DETERM (Reflection.genreify_tac ctxt form_equations NONE i)
THEN rewrite_interpret_form_tac ctxt prec splitting taylor i
THEN gen_eval_tac eval_oracle ctxt i))
@@ -3350,7 +3351,7 @@
fun mk_approx' prec t = (@{const "approx'"}
$ HOLogic.mk_number @{typ nat} prec
- $ t $ @{term "[] :: (float * float) list"})
+ $ t $ @{term "[] :: (float * float) option list"})
fun dest_result (Const (@{const_name "Some"}, _) $
((Const (@{const_name "Pair"}, _)) $
--- a/src/HOL/Decision_Procs/Ferrack.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/Ferrack.thy Thu Oct 01 07:40:25 2009 +0200
@@ -512,7 +512,7 @@
assumes g0: "numgcd t = 0"
shows "Inum bs t = 0"
using g0[simplified numgcd_def]
- by (induct t rule: numgcdh.induct, auto simp add: natabs0 max_def maxcoeff_pos)
+ by (induct t rule: numgcdh.induct, auto simp add: natabs0 maxcoeff_pos min_max.sup_absorb2)
lemma numgcdh_pos: assumes gp: "g \<ge> 0" shows "numgcdh t g \<ge> 0"
using gp
--- a/src/HOL/Decision_Procs/cooper_tac.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/cooper_tac.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
signature COOPER_TAC =
sig
- val trace: bool ref
+ val trace: bool Unsynchronized.ref
val linz_tac: Proof.context -> bool -> int -> tactic
val setup: theory -> theory
end
@@ -12,7 +12,7 @@
structure Cooper_Tac: COOPER_TAC =
struct
-val trace = ref false;
+val trace = Unsynchronized.ref false;
fun trace_msg s = if !trace then tracing s else ();
val cooper_ss = @{simpset};
--- a/src/HOL/Decision_Procs/ex/Approximation_Ex.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/ex/Approximation_Ex.thy Thu Oct 01 07:40:25 2009 +0200
@@ -72,7 +72,9 @@
shows "g / v * tan (35 * d) \<in> { 3 * d .. 3.1 * d }"
using assms by (approximation 80)
-lemma "\<phi> \<in> { 0 .. 1 :: real } \<longrightarrow> \<phi> ^ 2 \<le> \<phi>"
- by (approximation 30 splitting: \<phi>=1 taylor: \<phi> = 3)
+lemma "x \<in> { 0 .. 1 :: real } \<longrightarrow> x ^ 2 \<le> x"
+ by (approximation 30 splitting: x=1 taylor: x = 3)
+
+value [approximate] "10"
end
--- a/src/HOL/Decision_Procs/ferrack_tac.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/ferrack_tac.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
signature FERRACK_TAC =
sig
- val trace: bool ref
+ val trace: bool Unsynchronized.ref
val linr_tac: Proof.context -> bool -> int -> tactic
val setup: theory -> theory
end
@@ -12,7 +12,7 @@
structure Ferrack_Tac =
struct
-val trace = ref false;
+val trace = Unsynchronized.ref false;
fun trace_msg s = if !trace then tracing s else ();
val ferrack_ss = let val ths = [@{thm real_of_int_inject}, @{thm real_of_int_less_iff},
--- a/src/HOL/Decision_Procs/mir_tac.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Decision_Procs/mir_tac.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
signature MIR_TAC =
sig
- val trace: bool ref
+ val trace: bool Unsynchronized.ref
val mir_tac: Proof.context -> bool -> int -> tactic
val setup: theory -> theory
end
@@ -12,7 +12,7 @@
structure Mir_Tac =
struct
-val trace = ref false;
+val trace = Unsynchronized.ref false;
fun trace_msg s = if !trace then tracing s else ();
val mir_ss =
--- a/src/HOL/Extraction/Euclid.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Extraction/Euclid.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Extraction/Euclid.thy
- ID: $Id$
Author: Markus Wenzel, TU Muenchen
Freek Wiedijk, Radboud University Nijmegen
Stefan Berghofer, TU Muenchen
@@ -8,7 +7,7 @@
header {* Euclid's theorem *}
theory Euclid
-imports "~~/src/HOL/NumberTheory/Factorization" Util Efficient_Nat
+imports "~~/src/HOL/Old_Number_Theory/Factorization" Util Efficient_Nat
begin
text {*
--- a/src/HOL/Extraction/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Extraction/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Extraction/ROOT.ML
- ID: $Id$
Examples for program extraction in Higher-Order Logic.
*)
@@ -8,5 +7,5 @@
warning "HOL proof terms required for running extraction examples"
else
(Proofterm.proofs := 2;
- no_document use_thys ["Efficient_Nat", "~~/src/HOL/NumberTheory/Factorization"];
+ no_document use_thys ["Efficient_Nat", "~~/src/HOL/Old_Number_Theory/Factorization"];
use_thys ["Greatest_Common_Divisor", "Warshall", "Higman", "Pigeonhole", "Euclid"]);
--- a/src/HOL/Fact.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Fact.thy Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,7 @@
header{*Factorial Function*}
theory Fact
-imports NatTransfer
+imports Nat_Transfer
begin
class fact =
--- a/src/HOL/Finite_Set.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Finite_Set.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1565,9 +1565,7 @@
apply (rule finite_subset)
prefer 2
apply assumption
- apply auto
- apply (rule setsum_cong)
- apply auto
+ apply (auto simp add: sup_absorb2)
done
lemma setsum_right_distrib:
@@ -2615,6 +2613,23 @@
finally show ?case .
qed
+lemma fold1_eq_fold_idem:
+ assumes "finite A"
+ shows "fold1 times (insert a A) = fold times a A"
+proof (cases "a \<in> A")
+ case False
+ with assms show ?thesis by (simp add: fold1_eq_fold)
+next
+ interpret fun_left_comm_idem times by (fact fun_left_comm_idem)
+ case True then obtain b B
+ where A: "A = insert a B" and "a \<notin> B" by (rule set_insert)
+ with assms have "finite B" by auto
+ then have "fold times a (insert a B) = fold times (a * a) B"
+ using `a \<notin> B` by (rule fold_insert2)
+ then show ?thesis
+ using `a \<notin> B` `finite B` by (simp add: fold1_eq_fold A)
+qed
+
end
@@ -2966,11 +2981,11 @@
lemma dual_max:
"ord.max (op \<ge>) = min"
- by (auto simp add: ord.max_def_raw min_def_raw expand_fun_eq)
+ by (auto simp add: ord.max_def_raw min_def expand_fun_eq)
lemma dual_min:
"ord.min (op \<ge>) = max"
- by (auto simp add: ord.min_def_raw max_def_raw expand_fun_eq)
+ by (auto simp add: ord.min_def_raw max_def expand_fun_eq)
lemma strict_below_fold1_iff:
assumes "finite A" and "A \<noteq> {}"
--- a/src/HOL/Fun.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Fun.thy Thu Oct 01 07:40:25 2009 +0200
@@ -7,6 +7,7 @@
theory Fun
imports Complete_Lattice
+uses ("Tools/transfer.ML")
begin
text{*As a simplification rule, it replaces all function equalities by
@@ -568,6 +569,16 @@
*}
+subsection {* Generic transfer procedure *}
+
+definition TransferMorphism:: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> bool"
+ where "TransferMorphism a B \<longleftrightarrow> True"
+
+use "Tools/transfer.ML"
+
+setup Transfer.setup
+
+
subsection {* Code generator setup *}
types_code
@@ -578,7 +589,7 @@
attach (test) {*
fun gen_fun_type aF aT bG bT i =
let
- val tab = ref [];
+ val tab = Unsynchronized.ref [];
fun mk_upd (x, (_, y)) t = Const ("Fun.fun_upd",
(aT --> bT) --> aT --> bT --> aT --> bT) $ t $ aF x $ y ()
in
--- a/src/HOL/GCD.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/GCD.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,11 +1,9 @@
-(* Title: GCD.thy
- Authors: Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
+(* Authors: Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
Thomas M. Rasmussen, Jeremy Avigad, Tobias Nipkow
-This file deals with the functions gcd and lcm, and properties of
-primes. Definitions and lemmas are proved uniformly for the natural
-numbers and integers.
+This file deals with the functions gcd and lcm. Definitions and
+lemmas are proved uniformly for the natural numbers and integers.
This file combines and revises a number of prior developments.
@@ -52,11 +50,6 @@
end
-class prime = one +
-
-fixes
- prime :: "'a \<Rightarrow> bool"
-
(* definitions for the natural numbers *)
@@ -80,20 +73,6 @@
end
-instantiation nat :: prime
-
-begin
-
-definition
- prime_nat :: "nat \<Rightarrow> bool"
-where
- [code del]: "prime_nat p = (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"
-
-instance proof qed
-
-end
-
-
(* definitions for the integers *)
instantiation int :: gcd
@@ -115,28 +94,13 @@
end
-instantiation int :: prime
-
-begin
-
-definition
- prime_int :: "int \<Rightarrow> bool"
-where
- [code del]: "prime_int p = prime (nat p)"
-
-instance proof qed
-
-end
-
-
subsection {* Set up Transfer *}
lemma transfer_nat_int_gcd:
"(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> gcd (nat x) (nat y) = nat (gcd x y)"
"(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> lcm (nat x) (nat y) = nat (lcm x y)"
- "(x::int) >= 0 \<Longrightarrow> prime (nat x) = prime x"
- unfolding gcd_int_def lcm_int_def prime_int_def
+ unfolding gcd_int_def lcm_int_def
by auto
lemma transfer_nat_int_gcd_closures:
@@ -150,8 +114,7 @@
lemma transfer_int_nat_gcd:
"gcd (int x) (int y) = int (gcd x y)"
"lcm (int x) (int y) = int (lcm x y)"
- "prime (int x) = prime x"
- by (unfold gcd_int_def lcm_int_def prime_int_def, auto)
+ by (unfold gcd_int_def lcm_int_def, auto)
lemma transfer_int_nat_gcd_closures:
"is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> gcd x y >= 0"
@@ -1003,20 +966,6 @@
apply (auto simp add: gcd_mult_cancel_int)
done
-lemma prime_odd_nat: "prime (p::nat) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
- unfolding prime_nat_def
- apply (subst even_mult_two_ex)
- apply clarify
- apply (drule_tac x = 2 in spec)
- apply auto
-done
-
-lemma prime_odd_int: "prime (p::int) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
- unfolding prime_int_def
- apply (frule prime_odd_nat)
- apply (auto simp add: even_nat_def)
-done
-
lemma coprime_common_divisor_nat: "coprime (a::nat) b \<Longrightarrow> x dvd a \<Longrightarrow>
x dvd b \<Longrightarrow> x = 1"
apply (subgoal_tac "x dvd gcd a b")
@@ -1753,329 +1702,4 @@
show ?thesis by(simp add: Gcd_def fold_set gcd_commute_int)
qed
-
-subsection {* Primes *}
-
-(* FIXME Is there a better way to handle these, rather than making them elim rules? *)
-
-lemma prime_ge_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 0"
- by (unfold prime_nat_def, auto)
-
-lemma prime_gt_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p > 0"
- by (unfold prime_nat_def, auto)
-
-lemma prime_ge_1_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 1"
- by (unfold prime_nat_def, auto)
-
-lemma prime_gt_1_nat [elim]: "prime (p::nat) \<Longrightarrow> p > 1"
- by (unfold prime_nat_def, auto)
-
-lemma prime_ge_Suc_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= Suc 0"
- by (unfold prime_nat_def, auto)
-
-lemma prime_gt_Suc_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p > Suc 0"
- by (unfold prime_nat_def, auto)
-
-lemma prime_ge_2_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 2"
- by (unfold prime_nat_def, auto)
-
-lemma prime_ge_0_int [elim]: "prime (p::int) \<Longrightarrow> p >= 0"
- by (unfold prime_int_def prime_nat_def) auto
-
-lemma prime_gt_0_int [elim]: "prime (p::int) \<Longrightarrow> p > 0"
- by (unfold prime_int_def prime_nat_def, auto)
-
-lemma prime_ge_1_int [elim]: "prime (p::int) \<Longrightarrow> p >= 1"
- by (unfold prime_int_def prime_nat_def, auto)
-
-lemma prime_gt_1_int [elim]: "prime (p::int) \<Longrightarrow> p > 1"
- by (unfold prime_int_def prime_nat_def, auto)
-
-lemma prime_ge_2_int [elim]: "prime (p::int) \<Longrightarrow> p >= 2"
- by (unfold prime_int_def prime_nat_def, auto)
-
-
-lemma prime_int_altdef: "prime (p::int) = (1 < p \<and> (\<forall>m \<ge> 0. m dvd p \<longrightarrow>
- m = 1 \<or> m = p))"
- using prime_nat_def [transferred]
- apply (case_tac "p >= 0")
- by (blast, auto simp add: prime_ge_0_int)
-
-lemma prime_imp_coprime_nat: "prime (p::nat) \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
- apply (unfold prime_nat_def)
- apply (metis gcd_dvd1_nat gcd_dvd2_nat)
- done
-
-lemma prime_imp_coprime_int: "prime (p::int) \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
- apply (unfold prime_int_altdef)
- apply (metis gcd_dvd1_int gcd_dvd2_int gcd_ge_0_int)
- done
-
-lemma prime_dvd_mult_nat: "prime (p::nat) \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
- by (blast intro: coprime_dvd_mult_nat prime_imp_coprime_nat)
-
-lemma prime_dvd_mult_int: "prime (p::int) \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
- by (blast intro: coprime_dvd_mult_int prime_imp_coprime_int)
-
-lemma prime_dvd_mult_eq_nat [simp]: "prime (p::nat) \<Longrightarrow>
- p dvd m * n = (p dvd m \<or> p dvd n)"
- by (rule iffI, rule prime_dvd_mult_nat, auto)
-
-lemma prime_dvd_mult_eq_int [simp]: "prime (p::int) \<Longrightarrow>
- p dvd m * n = (p dvd m \<or> p dvd n)"
- by (rule iffI, rule prime_dvd_mult_int, auto)
-
-lemma not_prime_eq_prod_nat: "(n::nat) > 1 \<Longrightarrow> ~ prime n \<Longrightarrow>
- EX m k. n = m * k & 1 < m & m < n & 1 < k & k < n"
- unfolding prime_nat_def dvd_def apply auto
- by(metis mult_commute linorder_neq_iff linorder_not_le mult_1 n_less_n_mult_m one_le_mult_iff less_imp_le_nat)
-
-lemma not_prime_eq_prod_int: "(n::int) > 1 \<Longrightarrow> ~ prime n \<Longrightarrow>
- EX m k. n = m * k & 1 < m & m < n & 1 < k & k < n"
- unfolding prime_int_altdef dvd_def
- apply auto
- by(metis div_mult_self1_is_id div_mult_self2_is_id int_div_less_self int_one_le_iff_zero_less zero_less_mult_pos zless_le)
-
-lemma prime_dvd_power_nat [rule_format]: "prime (p::nat) -->
- n > 0 --> (p dvd x^n --> p dvd x)"
- by (induct n rule: nat_induct, auto)
-
-lemma prime_dvd_power_int [rule_format]: "prime (p::int) -->
- n > 0 --> (p dvd x^n --> p dvd x)"
- apply (induct n rule: nat_induct, auto)
- apply (frule prime_ge_0_int)
- apply auto
-done
-
-subsubsection{* Make prime naively executable *}
-
-lemma zero_not_prime_nat [simp]: "~prime (0::nat)"
- by (simp add: prime_nat_def)
-
-lemma zero_not_prime_int [simp]: "~prime (0::int)"
- by (simp add: prime_int_def)
-
-lemma one_not_prime_nat [simp]: "~prime (1::nat)"
- by (simp add: prime_nat_def)
-
-lemma Suc_0_not_prime_nat [simp]: "~prime (Suc 0)"
- by (simp add: prime_nat_def One_nat_def)
-
-lemma one_not_prime_int [simp]: "~prime (1::int)"
- by (simp add: prime_int_def)
-
-lemma prime_nat_code[code]:
- "prime(p::nat) = (p > 1 & (ALL n : {1<..<p}. ~(n dvd p)))"
-apply(simp add: Ball_def)
-apply (metis less_not_refl prime_nat_def dvd_triv_right not_prime_eq_prod_nat)
-done
-
-lemma prime_nat_simp:
- "prime(p::nat) = (p > 1 & (list_all (%n. ~ n dvd p) [2..<p]))"
-apply(simp only:prime_nat_code list_ball_code greaterThanLessThan_upt)
-apply(simp add:nat_number One_nat_def)
-done
-
-lemmas prime_nat_simp_number_of[simp] = prime_nat_simp[of "number_of m", standard]
-
-lemma prime_int_code[code]:
- "prime(p::int) = (p > 1 & (ALL n : {1<..<p}. ~(n dvd p)))" (is "?L = ?R")
-proof
- assume "?L" thus "?R"
- by (clarsimp simp: prime_gt_1_int) (metis int_one_le_iff_zero_less prime_int_altdef zless_le)
-next
- assume "?R" thus "?L" by (clarsimp simp:Ball_def) (metis dvdI not_prime_eq_prod_int)
-qed
-
-lemma prime_int_simp:
- "prime(p::int) = (p > 1 & (list_all (%n. ~ n dvd p) [2..p - 1]))"
-apply(simp only:prime_int_code list_ball_code greaterThanLessThan_upto)
-apply simp
-done
-
-lemmas prime_int_simp_number_of[simp] = prime_int_simp[of "number_of m", standard]
-
-declare successor_int_def[simp]
-
-lemma two_is_prime_nat [simp]: "prime (2::nat)"
-by simp
-
-lemma two_is_prime_int [simp]: "prime (2::int)"
-by simp
-
-text{* A bit of regression testing: *}
-
-lemma "prime(97::nat)"
-by simp
-
-lemma "prime(97::int)"
-by simp
-
-lemma "prime(997::nat)"
-by eval
-
-lemma "prime(997::int)"
-by eval
-
-
-lemma prime_imp_power_coprime_nat: "prime (p::nat) \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
- apply (rule coprime_exp_nat)
- apply (subst gcd_commute_nat)
- apply (erule (1) prime_imp_coprime_nat)
-done
-
-lemma prime_imp_power_coprime_int: "prime (p::int) \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
- apply (rule coprime_exp_int)
- apply (subst gcd_commute_int)
- apply (erule (1) prime_imp_coprime_int)
-done
-
-lemma primes_coprime_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
- apply (rule prime_imp_coprime_nat, assumption)
- apply (unfold prime_nat_def, auto)
-done
-
-lemma primes_coprime_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
- apply (rule prime_imp_coprime_int, assumption)
- apply (unfold prime_int_altdef, clarify)
- apply (drule_tac x = q in spec)
- apply (drule_tac x = p in spec)
- apply auto
-done
-
-lemma primes_imp_powers_coprime_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow> p ~= q \<Longrightarrow> coprime (p^m) (q^n)"
- by (rule coprime_exp2_nat, rule primes_coprime_nat)
-
-lemma primes_imp_powers_coprime_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow> p ~= q \<Longrightarrow> coprime (p^m) (q^n)"
- by (rule coprime_exp2_int, rule primes_coprime_int)
-
-lemma prime_factor_nat: "n \<noteq> (1::nat) \<Longrightarrow> \<exists> p. prime p \<and> p dvd n"
- apply (induct n rule: nat_less_induct)
- apply (case_tac "n = 0")
- using two_is_prime_nat apply blast
- apply (case_tac "prime n")
- apply blast
- apply (subgoal_tac "n > 1")
- apply (frule (1) not_prime_eq_prod_nat)
- apply (auto intro: dvd_mult dvd_mult2)
-done
-
-(* An Isar version:
-
-lemma prime_factor_b_nat:
- fixes n :: nat
- assumes "n \<noteq> 1"
- shows "\<exists>p. prime p \<and> p dvd n"
-
-using `n ~= 1`
-proof (induct n rule: less_induct_nat)
- fix n :: nat
- assume "n ~= 1" and
- ih: "\<forall>m<n. m \<noteq> 1 \<longrightarrow> (\<exists>p. prime p \<and> p dvd m)"
- thus "\<exists>p. prime p \<and> p dvd n"
- proof -
- {
- assume "n = 0"
- moreover note two_is_prime_nat
- ultimately have ?thesis
- by (auto simp del: two_is_prime_nat)
- }
- moreover
- {
- assume "prime n"
- hence ?thesis by auto
- }
- moreover
- {
- assume "n ~= 0" and "~ prime n"
- with `n ~= 1` have "n > 1" by auto
- with `~ prime n` and not_prime_eq_prod_nat obtain m k where
- "n = m * k" and "1 < m" and "m < n" by blast
- with ih obtain p where "prime p" and "p dvd m" by blast
- with `n = m * k` have ?thesis by auto
- }
- ultimately show ?thesis by blast
- qed
-qed
-
-*)
-
-text {* One property of coprimality is easier to prove via prime factors. *}
-
-lemma prime_divprod_pow_nat:
- assumes p: "prime (p::nat)" and ab: "coprime a b" and pab: "p^n dvd a * b"
- shows "p^n dvd a \<or> p^n dvd b"
-proof-
- {assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
- apply (cases "n=0", simp_all)
- apply (cases "a=1", simp_all) done}
- moreover
- {assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
- then obtain m where m: "n = Suc m" by (cases n, auto)
- from n have "p dvd p^n" by (intro dvd_power, auto)
- also note pab
- finally have pab': "p dvd a * b".
- from prime_dvd_mult_nat[OF p pab']
- have "p dvd a \<or> p dvd b" .
- moreover
- {assume pa: "p dvd a"
- have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
- from coprime_common_divisor_nat [OF ab, OF pa] p have "\<not> p dvd b" by auto
- with p have "coprime b p"
- by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
- hence pnb: "coprime (p^n) b"
- by (subst gcd_commute_nat, rule coprime_exp_nat)
- from coprime_divprod_nat[OF pnba pnb] have ?thesis by blast }
- moreover
- {assume pb: "p dvd b"
- have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
- from coprime_common_divisor_nat [OF ab, of p] pb p have "\<not> p dvd a"
- by auto
- with p have "coprime a p"
- by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
- hence pna: "coprime (p^n) a"
- by (subst gcd_commute_nat, rule coprime_exp_nat)
- from coprime_divprod_nat[OF pab pna] have ?thesis by blast }
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-subsection {* Infinitely many primes *}
-
-lemma next_prime_bound: "\<exists>(p::nat). prime p \<and> n < p \<and> p <= fact n + 1"
-proof-
- have f1: "fact n + 1 \<noteq> 1" using fact_ge_one_nat [of n] by arith
- from prime_factor_nat [OF f1]
- obtain p where "prime p" and "p dvd fact n + 1" by auto
- hence "p \<le> fact n + 1"
- by (intro dvd_imp_le, auto)
- {assume "p \<le> n"
- from `prime p` have "p \<ge> 1"
- by (cases p, simp_all)
- with `p <= n` have "p dvd fact n"
- by (intro dvd_fact_nat)
- with `p dvd fact n + 1` have "p dvd fact n + 1 - fact n"
- by (rule dvd_diff_nat)
- hence "p dvd 1" by simp
- hence "p <= 1" by auto
- moreover from `prime p` have "p > 1" by auto
- ultimately have False by auto}
- hence "n < p" by arith
- with `prime p` and `p <= fact n + 1` show ?thesis by auto
-qed
-
-lemma bigger_prime: "\<exists>p. prime p \<and> p > (n::nat)"
-using next_prime_bound by auto
-
-lemma primes_infinite: "\<not> (finite {(p::nat). prime p})"
-proof
- assume "finite {(p::nat). prime p}"
- with Max_ge have "(EX b. (ALL x : {(p::nat). prime p}. x <= b))"
- by auto
- then obtain b where "ALL (x::nat). prime x \<longrightarrow> x <= b"
- by auto
- with bigger_prime [of b] show False by auto
-qed
-
-
end
--- a/src/HOL/HOL.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/HOL.thy Thu Oct 01 07:40:25 2009 +0200
@@ -15,6 +15,7 @@
"~~/src/Tools/IsaPlanner/rw_inst.ML"
"~~/src/Tools/intuitionistic.ML"
"~~/src/Tools/project_rule.ML"
+ "~~/src/Tools/cong_tac.ML"
"~~/src/Provers/hypsubst.ML"
"~~/src/Provers/splitter.ML"
"~~/src/Provers/classical.ML"
@@ -29,6 +30,7 @@
"~~/src/Tools/induct.ML"
("~~/src/Tools/induct_tacs.ML")
("Tools/recfun_codegen.ML")
+ "~~/src/Tools/more_conv.ML"
begin
setup {* Intuitionistic.method_setup @{binding iprover} *}
@@ -239,15 +241,15 @@
by (rule subst)
-subsubsection {*Congruence rules for application*}
+subsubsection {* Congruence rules for application *}
-(*similar to AP_THM in Gordon's HOL*)
+text {* Similar to @{text AP_THM} in Gordon's HOL. *}
lemma fun_cong: "(f::'a=>'b) = g ==> f(x)=g(x)"
apply (erule subst)
apply (rule refl)
done
-(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
+text {* Similar to @{text AP_TERM} in Gordon's HOL and FOL's @{text subst_context}. *}
lemma arg_cong: "x=y ==> f(x)=f(y)"
apply (erule subst)
apply (rule refl)
@@ -258,13 +260,15 @@
apply (rule refl)
done
-lemma cong: "[| f = g; (x::'a) = y |] ==> f(x) = g(y)"
+lemma cong: "[| f = g; (x::'a) = y |] ==> f x = g y"
apply (erule subst)+
apply (rule refl)
done
+ML {* val cong_tac = Cong_Tac.cong_tac @{thm cong} *}
-subsubsection {*Equality of booleans -- iff*}
+
+subsubsection {* Equality of booleans -- iff *}
lemma iffI: assumes "P ==> Q" and "Q ==> P" shows "P=Q"
by (iprover intro: iff [THEN mp, THEN mp] impI assms)
@@ -1465,7 +1469,7 @@
subsubsection {* Coherent logic *}
ML {*
-structure Coherent = CoherentFun
+structure Coherent = Coherent
(
val atomize_elimL = @{thm atomize_elimL}
val atomize_exL = @{thm atomize_exL}
@@ -1886,7 +1890,7 @@
*}
setup {*
- Code.add_const_alias @{thm equals_alias_cert}
+ Nbe.add_const_alias @{thm equals_alias_cert}
*}
hide (open) const eq
@@ -1966,7 +1970,7 @@
structure Eval_Method =
struct
-val eval_ref : (unit -> bool) option ref = ref NONE;
+val eval_ref : (unit -> bool) option Unsynchronized.ref = Unsynchronized.ref NONE;
end;
*}
@@ -2020,6 +2024,29 @@
quickcheck_params [size = 5, iterations = 50]
+subsection {* Preprocessing for the predicate compiler *}
+
+ML {*
+structure Predicate_Compile_Alternative_Defs = Named_Thms
+(
+ val name = "code_pred_def"
+ val description = "alternative definitions of constants for the Predicate Compiler"
+)
+*}
+
+ML {*
+structure Predicate_Compile_Inline_Defs = Named_Thms
+(
+ val name = "code_pred_inline"
+ val description = "inlining definitions for the Predicate Compiler"
+)
+*}
+
+setup {*
+ Predicate_Compile_Alternative_Defs.setup
+ #> Predicate_Compile_Inline_Defs.setup
+ #> Predicate_Compile_Preproc_Const_Defs.setup
+*}
subsection {* Nitpick setup *}
--- a/src/HOL/HoareParallel/Gar_Coll.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,846 +0,0 @@
-
-header {* \section{The Single Mutator Case} *}
-
-theory Gar_Coll imports Graph OG_Syntax begin
-
-declare psubsetE [rule del]
-
-text {* Declaration of variables: *}
-
-record gar_coll_state =
- M :: nodes
- E :: edges
- bc :: "nat set"
- obc :: "nat set"
- Ma :: nodes
- ind :: nat
- k :: nat
- z :: bool
-
-subsection {* The Mutator *}
-
-text {* The mutator first redirects an arbitrary edge @{text "R"} from
-an arbitrary accessible node towards an arbitrary accessible node
-@{text "T"}. It then colors the new target @{text "T"} black.
-
-We declare the arbitrarily selected node and edge as constants:*}
-
-consts R :: nat T :: nat
-
-text {* \noindent The following predicate states, given a list of
-nodes @{text "m"} and a list of edges @{text "e"}, the conditions
-under which the selected edge @{text "R"} and node @{text "T"} are
-valid: *}
-
-constdefs
- Mut_init :: "gar_coll_state \<Rightarrow> bool"
- "Mut_init \<equiv> \<guillemotleft> T \<in> Reach \<acute>E \<and> R < length \<acute>E \<and> T < length \<acute>M \<guillemotright>"
-
-text {* \noindent For the mutator we
-consider two modules, one for each action. An auxiliary variable
-@{text "\<acute>z"} is set to false if the mutator has already redirected an
-edge but has not yet colored the new target. *}
-
-constdefs
- Redirect_Edge :: "gar_coll_state ann_com"
- "Redirect_Edge \<equiv> .{\<acute>Mut_init \<and> \<acute>z}. \<langle>\<acute>E:=\<acute>E[R:=(fst(\<acute>E!R), T)],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
-
- Color_Target :: "gar_coll_state ann_com"
- "Color_Target \<equiv> .{\<acute>Mut_init \<and> \<not>\<acute>z}. \<langle>\<acute>M:=\<acute>M[T:=Black],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
-
- Mutator :: "gar_coll_state ann_com"
- "Mutator \<equiv>
- .{\<acute>Mut_init \<and> \<acute>z}.
- WHILE True INV .{\<acute>Mut_init \<and> \<acute>z}.
- DO Redirect_Edge ;; Color_Target OD"
-
-subsubsection {* Correctness of the mutator *}
-
-lemmas mutator_defs = Mut_init_def Redirect_Edge_def Color_Target_def
-
-lemma Redirect_Edge:
- "\<turnstile> Redirect_Edge pre(Color_Target)"
-apply (unfold mutator_defs)
-apply annhoare
-apply(simp_all)
-apply(force elim:Graph2)
-done
-
-lemma Color_Target:
- "\<turnstile> Color_Target .{\<acute>Mut_init \<and> \<acute>z}."
-apply (unfold mutator_defs)
-apply annhoare
-apply(simp_all)
-done
-
-lemma Mutator:
- "\<turnstile> Mutator .{False}."
-apply(unfold Mutator_def)
-apply annhoare
-apply(simp_all add:Redirect_Edge Color_Target)
-apply(simp add:mutator_defs Redirect_Edge_def)
-done
-
-subsection {* The Collector *}
-
-text {* \noindent A constant @{text "M_init"} is used to give @{text "\<acute>Ma"} a
-suitable first value, defined as a list of nodes where only the @{text
-"Roots"} are black. *}
-
-consts M_init :: nodes
-
-constdefs
- Proper_M_init :: "gar_coll_state \<Rightarrow> bool"
- "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
-
- Proper :: "gar_coll_state \<Rightarrow> bool"
- "Proper \<equiv> \<guillemotleft> Proper_Roots \<acute>M \<and> Proper_Edges(\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<guillemotright>"
-
- Safe :: "gar_coll_state \<Rightarrow> bool"
- "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
-
-lemmas collector_defs = Proper_M_init_def Proper_def Safe_def
-
-subsubsection {* Blackening the roots *}
-
-constdefs
- Blacken_Roots :: " gar_coll_state ann_com"
- "Blacken_Roots \<equiv>
- .{\<acute>Proper}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>ind\<in>Roots THEN
- .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
- \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
- .{\<acute>Proper \<and> (\<forall>i<\<acute>ind+1. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Blacken_Roots:
- "\<turnstile> Blacken_Roots .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}."
-apply (unfold Blacken_Roots_def)
-apply annhoare
-apply(simp_all add:collector_defs Graph_defs)
-apply safe
-apply(simp_all add:nth_list_update)
- apply (erule less_SucE)
- apply simp+
- apply force
-apply force
-done
-
-subsubsection {* Propagating black *}
-
-constdefs
- PBInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "PBInv \<equiv> \<guillemotleft> \<lambda>ind. \<acute>obc < Blacks \<acute>M \<or> (\<forall>i <ind. \<not>BtoW (\<acute>E!i, \<acute>M) \<or>
- (\<not>\<acute>z \<and> i=R \<and> (snd(\<acute>E!R)) = T \<and> (\<exists>r. ind \<le> r \<and> r < length \<acute>E \<and> BtoW(\<acute>E!r,\<acute>M))))\<guillemotright>"
-
-constdefs
- Propagate_Black_aux :: "gar_coll_state ann_com"
- "Propagate_Black_aux \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- IF \<acute>M!(fst (\<acute>E!\<acute>ind)) = Black THEN
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black}.
- \<acute>M:=\<acute>M[snd(\<acute>E!\<acute>ind):=Black];;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv (\<acute>ind + 1) \<and> \<acute>ind<length \<acute>E}.
- \<acute>ind:=\<acute>ind+1
- FI
- OD"
-
-lemma Propagate_Black_aux:
- "\<turnstile> Propagate_Black_aux
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
-apply (unfold Propagate_Black_aux_def PBInv_def collector_defs)
-apply annhoare
-apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
- apply force
- apply force
- apply force
---{* 4 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Proper_Roots_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply(rule disjI1)
- apply(erule Graph13)
- apply force
-apply (case_tac "M x ! snd (E x ! ind x)=Black")
- apply (simp add: Graph10 BtoW_def)
- apply (rule disjI2)
- apply clarify
- apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply fast
- apply fast
-apply(rule disjI1)
-apply(erule subset_psubset_trans)
-apply(erule Graph11)
-apply fast
---{* 3 subgoals left *}
-apply force
-apply force
---{* last *}
-apply clarify
-apply simp
-apply(subgoal_tac "ind x = length (E x)")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply(drule Graph1)
- apply simp
- apply clarify
- apply(erule allE, erule impE, assumption)
- apply force
- apply force
-apply arith
-done
-
-subsubsection {* Refining propagating black *}
-
-constdefs
- Auxk :: "gar_coll_state \<Rightarrow> bool"
- "Auxk \<equiv> \<guillemotleft>\<acute>k<length \<acute>M \<and> (\<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or>
- \<acute>obc<Blacks \<acute>M \<or> (\<not>\<acute>z \<and> \<acute>ind=R \<and> snd(\<acute>E!R)=T
- \<and> (\<exists>r. \<acute>ind<r \<and> r<length \<acute>E \<and> BtoW(\<acute>E!r, \<acute>M))))\<guillemotright>"
-
-constdefs
- Propagate_Black :: " gar_coll_state ann_com"
- "Propagate_Black \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))=Black THEN
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black}.
- \<acute>k:=(snd(\<acute>E!\<acute>ind));;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black
- \<and> \<acute>Auxk}.
- \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],, \<acute>ind:=\<acute>ind+1\<rangle>
- ELSE .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- \<langle>IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle>
- FI
- OD"
-
-lemma Propagate_Black:
- "\<turnstile> Propagate_Black
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
-apply (unfold Propagate_Black_def PBInv_def Auxk_def collector_defs)
-apply annhoare
-apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
- apply force
- apply force
- apply force
---{* 5 subgoals left *}
-apply clarify
-apply(simp add:BtoW_def Proper_Edges_def)
---{* 4 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply (rule disjI1)
- apply (erule psubset_subset_trans)
- apply (erule Graph9)
-apply (case_tac "M x!k x=Black")
- apply (case_tac "M x ! snd (E x ! ind x)=Black")
- apply (simp add: Graph10 BtoW_def)
- apply (rule disjI2)
- apply clarify
- apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply fast
- apply fast
- apply (simp add: Graph10 BtoW_def)
- apply (erule disjE)
- apply (erule disjI1)
- apply clarify
- apply (erule less_SucE)
- apply force
- apply simp
- apply (subgoal_tac "Suc R\<le>r")
- apply fast
- apply arith
-apply(rule disjI1)
-apply(erule subset_psubset_trans)
-apply(erule Graph11)
-apply fast
---{* 3 subgoals left *}
-apply force
---{* 2 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply fast
-apply clarify
-apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply (simp add: BtoW_def)
-apply (simp add: BtoW_def)
---{* last *}
-apply clarify
-apply simp
-apply(subgoal_tac "ind x = length (E x)")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply(drule Graph1)
- apply simp
- apply clarify
- apply(erule allE, erule impE, assumption)
- apply force
- apply force
-apply arith
-done
-
-subsubsection {* Counting black nodes *}
-
-constdefs
- CountInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
-
-constdefs
- Count :: " gar_coll_state ann_com"
- "Count \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}
- \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black
- THEN .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>bc:=insert \<acute>ind \<acute>bc
- FI;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv (\<acute>ind+1)
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Count:
- "\<turnstile> Count
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}."
-apply(unfold Count_def)
-apply annhoare
-apply(simp_all add:CountInv_def Graph6 Graph7 Graph8 Graph12 Blacks_def collector_defs)
- apply force
- apply force
- apply force
- apply clarify
- apply simp
- apply(fast elim:less_SucE)
- apply clarify
- apply simp
- apply(fast elim:less_SucE)
- apply force
-apply force
-done
-
-subsubsection {* Appending garbage nodes to the free list *}
-
-consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
-
-axioms
- Append_to_free0: "length (Append_to_free (i, e)) = length e"
- Append_to_free1: "Proper_Edges (m, e)
- \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
- Append_to_free2: "i \<notin> Reach e
- \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
-
-constdefs
- AppendInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "AppendInv \<equiv> \<guillemotleft>\<lambda>ind. \<forall>i<length \<acute>M. ind\<le>i \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black\<guillemotright>"
-
-constdefs
- Append :: " gar_coll_state ann_com"
- "Append \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black THEN
- .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>M:=\<acute>M[\<acute>ind:=White]
- ELSE .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
- \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
- FI;;
- .{\<acute>Proper \<and> \<acute>AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Append:
- "\<turnstile> Append .{\<acute>Proper}."
-apply(unfold Append_def AppendInv_def)
-apply annhoare
-apply(simp_all add:collector_defs Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
- apply(force simp:Blacks_def nth_list_update)
- apply force
- apply force
- apply(force simp add:Graph_defs)
- apply force
- apply clarify
- apply simp
- apply(rule conjI)
- apply (erule Append_to_free1)
- apply clarify
- apply (drule_tac n = "i" in Append_to_free2)
- apply force
- apply force
-apply force
-done
-
-subsubsection {* Correctness of the Collector *}
-
-constdefs
- Collector :: " gar_coll_state ann_com"
- "Collector \<equiv>
-.{\<acute>Proper}.
- WHILE True INV .{\<acute>Proper}.
- DO
- Blacken_Roots;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}.
- \<acute>obc:={};;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
- \<acute>bc:=Roots;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
- \<acute>Ma:=M_init;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>Ma=M_init}.
- WHILE \<acute>obc\<noteq>\<acute>bc
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>obc:=\<acute>bc;;
- Propagate_Black;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}.
- \<acute>Ma:=\<acute>M;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma
- \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
- \<acute>bc:={};;
- Count
- OD;;
- Append
- OD"
-
-lemma Collector:
- "\<turnstile> Collector .{False}."
-apply(unfold Collector_def)
-apply annhoare
-apply(simp_all add: Blacken_Roots Propagate_Black Count Append)
-apply(simp_all add:Blacken_Roots_def Propagate_Black_def Count_def Append_def collector_defs)
- apply (force simp add: Proper_Roots_def)
- apply force
- apply force
-apply clarify
-apply (erule disjE)
-apply(simp add:psubsetI)
- apply(force dest:subset_antisym)
-done
-
-subsection {* Interference Freedom *}
-
-lemmas modules = Redirect_Edge_def Color_Target_def Blacken_Roots_def
- Propagate_Black_def Count_def Append_def
-lemmas Invariants = PBInv_def Auxk_def CountInv_def AppendInv_def
-lemmas abbrev = collector_defs mutator_defs Invariants
-
-lemma interfree_Blacken_Roots_Redirect_Edge:
- "interfree_aux (Some Blacken_Roots, {}, Some Redirect_Edge)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply (simp_all add:Graph6 Graph12 abbrev)
-done
-
-lemma interfree_Redirect_Edge_Blacken_Roots:
- "interfree_aux (Some Redirect_Edge, {}, Some Blacken_Roots)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply(simp add:abbrev)+
-done
-
-lemma interfree_Blacken_Roots_Color_Target:
- "interfree_aux (Some Blacken_Roots, {}, Some Color_Target)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:Graph7 Graph8 nth_list_update abbrev)
-done
-
-lemma interfree_Color_Target_Blacken_Roots:
- "interfree_aux (Some Color_Target, {}, Some Blacken_Roots)"
-apply (unfold modules )
-apply interfree_aux
-apply safe
-apply(simp add:abbrev)+
-done
-
-lemma interfree_Propagate_Black_Redirect_Edge:
- "interfree_aux (Some Propagate_Black, {}, Some Redirect_Edge)"
-apply (unfold modules )
-apply interfree_aux
---{* 11 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
---{* 7 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
- apply(rule conjI)
- apply (force simp add:BtoW_def)
- apply(erule Graph4)
- apply simp+
-apply(simp add:BtoW_def nth_list_update)
-apply force
---{* 5 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
---{* 4 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
- apply(rule conjI)
- apply (force simp add:BtoW_def)
- apply(erule Graph4)
- apply simp+
-apply(rule conjI)
- apply(simp add:nth_list_update)
- apply force
-apply(rule impI, rule impI, erule disjE, erule disjI1, case_tac "R = (ind x)" ,case_tac "M x ! T = Black")
- apply(force simp add:BtoW_def)
- apply(case_tac "M x !snd (E x ! ind x)=Black")
- apply(rule disjI2)
- apply simp
- apply (erule Graph5)
- apply simp+
- apply(force simp add:BtoW_def)
-apply(force simp add:BtoW_def)
---{* 3 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply clarify
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
-done
-
-lemma interfree_Redirect_Edge_Propagate_Black:
- "interfree_aux (Some Redirect_Edge, {}, Some Propagate_Black)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-done
-
-lemma interfree_Propagate_Black_Color_Target:
- "interfree_aux (Some Propagate_Black, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
---{* 11 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)+
-apply(erule conjE)+
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 7 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(erule conjE)+
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply clarify
-apply (rule conjI)
- apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(simp add:nth_list_update)
---{* 5 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
---{* 4 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply (rule conjI)
- apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(rule conjI)
-apply(simp add:nth_list_update)
-apply(rule impI,rule impI, case_tac "M x!T=Black",rotate_tac -1, force simp add: BtoW_def Graph10,
- erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply(simp add:abbrev)
-done
-
-lemma interfree_Color_Target_Propagate_Black:
- "interfree_aux (Some Color_Target, {}, Some Propagate_Black)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-done
-
-lemma interfree_Count_Redirect_Edge:
- "interfree_aux (Some Count, {}, Some Redirect_Edge)"
-apply (unfold modules)
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp_all add:abbrev Graph6 Graph12)
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12,
- erule disjE,erule disjI1,rule disjI2,rule subset_trans, erule Graph3,force,force)+
-done
-
-lemma interfree_Redirect_Edge_Count:
- "interfree_aux (Some Redirect_Edge, {}, Some Count)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify,simp add:abbrev)+
-apply(simp add:abbrev)
-done
-
-lemma interfree_Count_Color_Target:
- "interfree_aux (Some Count, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp_all add:abbrev Graph7 Graph8 Graph12)
---{* 6 subgoals left *}
-apply(clarify,simp add:abbrev Graph7 Graph8 Graph12,
- erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)+
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
-apply(simp add:nth_list_update)
---{* 1 subgoal left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12,
- erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
-done
-
-lemma interfree_Color_Target_Count:
- "interfree_aux (Some Color_Target, {}, Some Count)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-apply(simp add:abbrev)
-done
-
-lemma interfree_Append_Redirect_Edge:
- "interfree_aux (Some Append, {}, Some Redirect_Edge)"
-apply (unfold modules )
-apply interfree_aux
-apply( simp_all add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12)
-apply(clarify, simp add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12, force dest:Graph3)+
-done
-
-lemma interfree_Redirect_Edge_Append:
- "interfree_aux (Some Redirect_Edge, {}, Some Append)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Append_to_free0)+
-apply (force simp add: Append_to_free2)
-apply(clarify, simp add:abbrev Append_to_free0)+
-done
-
-lemma interfree_Append_Color_Target:
- "interfree_aux (Some Append, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)+
-apply(simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)
-done
-
-lemma interfree_Color_Target_Append:
- "interfree_aux (Some Color_Target, {}, Some Append)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Append_to_free0)+
-apply (force simp add: Append_to_free2)
-apply(clarify,simp add:abbrev Append_to_free0)+
-done
-
-lemmas collector_mutator_interfree =
- interfree_Blacken_Roots_Redirect_Edge interfree_Blacken_Roots_Color_Target
- interfree_Propagate_Black_Redirect_Edge interfree_Propagate_Black_Color_Target
- interfree_Count_Redirect_Edge interfree_Count_Color_Target
- interfree_Append_Redirect_Edge interfree_Append_Color_Target
- interfree_Redirect_Edge_Blacken_Roots interfree_Color_Target_Blacken_Roots
- interfree_Redirect_Edge_Propagate_Black interfree_Color_Target_Propagate_Black
- interfree_Redirect_Edge_Count interfree_Color_Target_Count
- interfree_Redirect_Edge_Append interfree_Color_Target_Append
-
-subsubsection {* Interference freedom Collector-Mutator *}
-
-lemma interfree_Collector_Mutator:
- "interfree_aux (Some Collector, {}, Some Mutator)"
-apply(unfold Collector_def Mutator_def)
-apply interfree_aux
-apply(simp_all add:collector_mutator_interfree)
-apply(unfold modules collector_defs mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 32 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 20 subgoals left *}
-apply(tactic{* TRYALL (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(tactic {* TRYALL (etac disjE) *})
-apply simp_all
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,etac subset_trans,rtac @{thm Graph9},force_tac @{clasimpset}]) *})
-apply(tactic {* TRYALL(EVERY'[rtac disjI1,etac @{thm psubset_subset_trans},rtac @{thm Graph9},force_tac @{clasimpset}]) *})
-done
-
-subsubsection {* Interference freedom Mutator-Collector *}
-
-lemma interfree_Mutator_Collector:
- "interfree_aux (Some Mutator, {}, Some Collector)"
-apply(unfold Collector_def Mutator_def)
-apply interfree_aux
-apply(simp_all add:collector_mutator_interfree)
-apply(unfold modules collector_defs mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 64 subgoals left *}
-apply(simp_all add:nth_list_update Invariants Append_to_free0)+
-apply(tactic{* TRYALL (clarify_tac @{claset}) *})
---{* 4 subgoals left *}
-apply force
-apply(simp add:Append_to_free2)
-apply force
-apply(simp add:Append_to_free2)
-done
-
-subsubsection {* The Garbage Collection algorithm *}
-
-text {* In total there are 289 verification conditions. *}
-
-lemma Gar_Coll:
- "\<parallel>- .{\<acute>Proper \<and> \<acute>Mut_init \<and> \<acute>z}.
- COBEGIN
- Collector
- .{False}.
- \<parallel>
- Mutator
- .{False}.
- COEND
- .{False}."
-apply oghoare
-apply(force simp add: Mutator_def Collector_def modules)
-apply(rule Collector)
-apply(rule Mutator)
-apply(simp add:interfree_Collector_Mutator)
-apply(simp add:interfree_Mutator_Collector)
-apply force
-done
-
-end
--- a/src/HOL/HoareParallel/Graph.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,411 +0,0 @@
-header {* \chapter{Case Study: Single and Multi-Mutator Garbage Collection Algorithms}
-
-\section {Formalization of the Memory} *}
-
-theory Graph imports Main begin
-
-datatype node = Black | White
-
-types
- nodes = "node list"
- edge = "nat \<times> nat"
- edges = "edge list"
-
-consts Roots :: "nat set"
-
-constdefs
- Proper_Roots :: "nodes \<Rightarrow> bool"
- "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"
-
- Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool"
- "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"
-
- BtoW :: "(edge \<times> nodes) \<Rightarrow> bool"
- "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"
-
- Blacks :: "nodes \<Rightarrow> nat set"
- "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"
-
- Reach :: "edges \<Rightarrow> nat set"
- "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
- \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
- \<or> x\<in>Roots}"
-
-text{* Reach: the set of reachable nodes is the set of Roots together with the
-nodes reachable from some Root by a path represented by a list of
- nodes (at least two since we traverse at least one edge), where two
-consecutive nodes correspond to an edge in E. *}
-
-subsection {* Proofs about Graphs *}
-
-lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
-declare Graph_defs [simp]
-
-subsubsection{* Graph 1 *}
-
-lemma Graph1_aux [rule_format]:
- "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
- \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
- (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
- \<longrightarrow> M!(path!0) = Black"
-apply(induct_tac "path")
- apply force
-apply clarify
-apply simp
-apply(case_tac "list")
- apply force
-apply simp
-apply(rotate_tac -2)
-apply(erule_tac x = "0" in all_dupE)
-apply simp
-apply clarify
-apply(erule allE , erule (1) notE impE)
-apply simp
-apply(erule mp)
-apply(case_tac "lista")
- apply force
-apply simp
-apply(erule mp)
-apply clarify
-apply(erule_tac x = "Suc i" in allE)
-apply force
-done
-
-lemma Graph1:
- "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
- \<Longrightarrow> Reach E\<subseteq>Blacks M"
-apply (unfold Reach_def)
-apply simp
-apply clarify
-apply(erule disjE)
- apply clarify
- apply(rule conjI)
- apply(subgoal_tac "0< length path - Suc 0")
- apply(erule allE , erule (1) notE impE)
- apply force
- apply simp
- apply(rule Graph1_aux)
-apply auto
-done
-
-subsubsection{* Graph 2 *}
-
-lemma Ex_first_occurrence [rule_format]:
- "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))";
-apply(rule nat_less_induct)
-apply clarify
-apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
-apply auto
-done
-
-lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
-apply(rule_tac x = "l - n" in exI)
-apply arith
-done
-
-lemma Ex_last_occurrence:
- "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
-apply(drule Compl_lemma)
-apply clarify
-apply(erule Ex_first_occurrence)
-done
-
-lemma Graph2:
- "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
-apply (unfold Reach_def)
-apply clarify
-apply simp
-apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
- apply(rule_tac x = "path" in exI)
- apply simp
- apply clarify
- apply(erule allE , erule (1) notE impE)
- apply clarify
- apply(rule_tac x = "j" in exI)
- apply(case_tac "j=R")
- apply(erule_tac x = "Suc i" in allE)
- apply simp
- apply (force simp add:nth_list_update)
-apply simp
-apply(erule exE)
-apply(subgoal_tac "z \<le> length path - Suc 0")
- prefer 2 apply arith
-apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
- apply assumption
-apply clarify
-apply simp
-apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
-apply simp
-apply(case_tac "length path - (length path - Suc m)")
- apply arith
-apply simp
-apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
- prefer 2 apply arith
-apply(drule nth_drop)
-apply simp
-apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
- prefer 2 apply arith
-apply simp
-apply clarify
-apply(case_tac "i")
- apply(force simp add: nth_list_update)
-apply simp
-apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
- prefer 2 apply arith
-apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
- prefer 2 apply arith
-apply simp
-apply(erule_tac x = "length path - Suc m + nata" in allE)
-apply simp
-apply clarify
-apply(rule_tac x = "j" in exI)
-apply(case_tac "R=j")
- prefer 2 apply force
-apply simp
-apply(drule_tac t = "path ! (length path - Suc m)" in sym)
-apply simp
-apply(case_tac " length path - Suc 0 < m")
- apply(subgoal_tac "(length path - Suc m)=0")
- prefer 2 apply arith
- apply(simp del: diff_is_0_eq)
- apply(subgoal_tac "Suc nata\<le>nat")
- prefer 2 apply arith
- apply(drule_tac n = "Suc nata" in Compl_lemma)
- apply clarify
- using [[linarith_split_limit = 0]]
- apply force
- using [[linarith_split_limit = 9]]
-apply(drule leI)
-apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
- apply(erule_tac x = "m - (Suc nata)" in allE)
- apply(case_tac "m")
- apply simp
- apply simp
-apply simp
-done
-
-
-subsubsection{* Graph 3 *}
-
-lemma Graph3:
- "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
-apply (unfold Reach_def)
-apply clarify
-apply simp
-apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
---{* the changed edge is part of the path *}
- apply(erule exE)
- apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
- apply clarify
- apply(erule disjE)
---{* T is NOT a root *}
- apply clarify
- apply(rule_tac x = "(take m path)@patha" in exI)
- apply(subgoal_tac "\<not>(length path\<le>m)")
- prefer 2 apply arith
- apply(simp add: min_def)
- apply(rule conjI)
- apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
- prefer 2 apply arith
- apply(simp add: nth_append min_def)
- apply(rule conjI)
- apply(case_tac "m")
- apply force
- apply(case_tac "path")
- apply force
- apply force
- apply clarify
- apply(case_tac "Suc i\<le>m")
- apply(erule_tac x = "i" in allE)
- apply simp
- apply clarify
- apply(rule_tac x = "j" in exI)
- apply(case_tac "Suc i<m")
- apply(simp add: nth_append)
- apply(case_tac "R=j")
- apply(simp add: nth_list_update)
- apply(case_tac "i=m")
- apply force
- apply(erule_tac x = "i" in allE)
- apply force
- apply(force simp add: nth_list_update)
- apply(simp add: nth_append)
- apply(subgoal_tac "i=m - 1")
- prefer 2 apply arith
- apply(case_tac "R=j")
- apply(erule_tac x = "m - 1" in allE)
- apply(simp add: nth_list_update)
- apply(force simp add: nth_list_update)
- apply(simp add: nth_append min_def)
- apply(rotate_tac -4)
- apply(erule_tac x = "i - m" in allE)
- apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
- prefer 2 apply arith
- apply simp
---{* T is a root *}
- apply(case_tac "m=0")
- apply force
- apply(rule_tac x = "take (Suc m) path" in exI)
- apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
- prefer 2 apply arith
- apply(simp add: min_def)
- apply clarify
- apply(erule_tac x = "i" in allE)
- apply simp
- apply clarify
- apply(case_tac "R=j")
- apply(force simp add: nth_list_update)
- apply(force simp add: nth_list_update)
---{* the changed edge is not part of the path *}
-apply(rule_tac x = "path" in exI)
-apply simp
-apply clarify
-apply(erule_tac x = "i" in allE)
-apply clarify
-apply(case_tac "R=j")
- apply(erule_tac x = "i" in allE)
- apply simp
-apply(force simp add: nth_list_update)
-done
-
-subsubsection{* Graph 4 *}
-
-lemma Graph4:
- "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
- \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
- (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
-apply (unfold Reach_def)
-apply simp
-apply(erule disjE)
- prefer 2 apply force
-apply clarify
---{* there exist a black node in the path to T *}
-apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
- apply(erule exE)
- apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
- apply clarify
- apply(case_tac "ma")
- apply force
- apply simp
- apply(case_tac "length path")
- apply force
- apply simp
- apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply clarify
- apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply(case_tac "j<I")
- apply(erule_tac x = "j" in allE)
- apply force
- apply(rule_tac x = "j" in exI)
- apply(force simp add: nth_list_update)
-apply simp
-apply(rotate_tac -1)
-apply(erule_tac x = "length path - 1" in allE)
-apply(case_tac "length path")
- apply force
-apply force
-done
-
-subsubsection {* Graph 5 *}
-
-lemma Graph5:
- "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
- R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
- \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
-apply (unfold Reach_def)
-apply simp
-apply(erule disjE)
- prefer 2 apply force
-apply clarify
---{* there exist a black node in the path to T*}
-apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
- apply(erule exE)
- apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
- apply clarify
- apply(case_tac "ma")
- apply force
- apply simp
- apply(case_tac "length path")
- apply force
- apply simp
- apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply clarify
- apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply(case_tac "j\<le>R")
- apply(drule le_imp_less_or_eq [of _ R])
- apply(erule disjE)
- apply(erule allE , erule (1) notE impE)
- apply force
- apply force
- apply(rule_tac x = "j" in exI)
- apply(force simp add: nth_list_update)
-apply simp
-apply(rotate_tac -1)
-apply(erule_tac x = "length path - 1" in allE)
-apply(case_tac "length path")
- apply force
-apply force
-done
-
-subsubsection {* Other lemmas about graphs *}
-
-lemma Graph6:
- "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
-apply (unfold Proper_Edges_def)
- apply(force simp add: nth_list_update)
-done
-
-lemma Graph7:
- "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
-apply (unfold Proper_Edges_def)
-apply force
-done
-
-lemma Graph8:
- "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
-apply (unfold Proper_Roots_def)
-apply force
-done
-
-text{* Some specific lemmata for the verification of garbage collection algorithms. *}
-
-lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
-apply (unfold Blacks_def)
- apply(force simp add: nth_list_update)
-done
-
-lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
-apply(induct_tac "M")
-apply auto
-apply(case_tac "i")
-apply auto
-done
-
-lemma Graph11 [rule_format (no_asm)]:
- "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(rule psubsetI)
- apply(force simp add: nth_list_update)
-apply safe
-apply(erule_tac c = "j" in equalityCE)
-apply auto
-done
-
-lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(force simp add: nth_list_update)
-done
-
-lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(erule psubset_subset_trans)
-apply(force simp add: nth_list_update)
-done
-
-declare Graph_defs [simp del]
-
-end
--- a/src/HOL/HoareParallel/Mul_Gar_Coll.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1283 +0,0 @@
-
-header {* \section{The Multi-Mutator Case} *}
-
-theory Mul_Gar_Coll imports Graph OG_Syntax begin
-
-text {* The full theory takes aprox. 18 minutes. *}
-
-record mut =
- Z :: bool
- R :: nat
- T :: nat
-
-text {* Declaration of variables: *}
-
-record mul_gar_coll_state =
- M :: nodes
- E :: edges
- bc :: "nat set"
- obc :: "nat set"
- Ma :: nodes
- ind :: nat
- k :: nat
- q :: nat
- l :: nat
- Muts :: "mut list"
-
-subsection {* The Mutators *}
-
-constdefs
- Mul_mut_init :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_mut_init \<equiv> \<guillemotleft> \<lambda>n. n=length \<acute>Muts \<and> (\<forall>i<n. R (\<acute>Muts!i)<length \<acute>E
- \<and> T (\<acute>Muts!i)<length \<acute>M) \<guillemotright>"
-
- Mul_Redirect_Edge :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Redirect_Edge j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- \<langle>IF T(\<acute>Muts!j) \<in> Reach \<acute>E THEN
- \<acute>E:= \<acute>E[R (\<acute>Muts!j):= (fst (\<acute>E!R(\<acute>Muts!j)), T (\<acute>Muts!j))] FI,,
- \<acute>Muts:= \<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=False\<rparr>]\<rangle>"
-
- Mul_Color_Target :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Color_Target j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> \<not> Z (\<acute>Muts!j)}.
- \<langle>\<acute>M:=\<acute>M[T (\<acute>Muts!j):=Black],, \<acute>Muts:=\<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=True\<rparr>]\<rangle>"
-
- Mul_Mutator :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Mutator j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- WHILE True
- INV .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- DO Mul_Redirect_Edge j n ;;
- Mul_Color_Target j n
- OD"
-
-lemmas mul_mutator_defs = Mul_mut_init_def Mul_Redirect_Edge_def Mul_Color_Target_def
-
-subsubsection {* Correctness of the proof outline of one mutator *}
-
-lemma Mul_Redirect_Edge: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Redirect_Edge j n
- pre(Mul_Color_Target j n)"
-apply (unfold mul_mutator_defs)
-apply annhoare
-apply(simp_all)
-apply clarify
-apply(simp add:nth_list_update)
-done
-
-lemma Mul_Color_Target: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Color_Target j n
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}."
-apply (unfold mul_mutator_defs)
-apply annhoare
-apply(simp_all)
-apply clarify
-apply(simp add:nth_list_update)
-done
-
-lemma Mul_Mutator: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Mutator j n .{False}."
-apply(unfold Mul_Mutator_def)
-apply annhoare
-apply(simp_all add:Mul_Redirect_Edge Mul_Color_Target)
-apply(simp add:mul_mutator_defs Mul_Redirect_Edge_def)
-done
-
-subsubsection {* Interference freedom between mutators *}
-
-lemma Mul_interfree_Redirect_Edge_Redirect_Edge:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some (Mul_Redirect_Edge i n),{}, Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Color_Target:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge i n),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Redirect_Edge:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add:nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Color_Target:
- " \<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemmas mul_mutator_interfree =
- Mul_interfree_Redirect_Edge_Redirect_Edge Mul_interfree_Redirect_Edge_Color_Target
- Mul_interfree_Color_Target_Redirect_Edge Mul_interfree_Color_Target_Color_Target
-
-lemma Mul_interfree_Mutator_Mutator: "\<lbrakk>i < n; j < n; i \<noteq> j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some (Mul_Mutator i n), {}, Some (Mul_Mutator j n))"
-apply(unfold Mul_Mutator_def)
-apply(interfree_aux)
-apply(simp_all add:mul_mutator_interfree)
-apply(simp_all add: mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply (simp_all add:nth_list_update)
-done
-
-subsubsection {* Modular Parameterized Mutators *}
-
-lemma Mul_Parameterized_Mutators: "0<n \<Longrightarrow>
- \<parallel>- .{\<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
- COBEGIN
- SCHEME [0\<le> j< n]
- Mul_Mutator j n
- .{False}.
- COEND
- .{False}."
-apply oghoare
-apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
-apply(erule Mul_Mutator)
-apply(simp add:Mul_interfree_Mutator_Mutator)
-apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
-done
-
-subsection {* The Collector *}
-
-constdefs
- Queue :: "mul_gar_coll_state \<Rightarrow> nat"
- "Queue \<equiv> \<guillemotleft> length (filter (\<lambda>i. \<not> Z i \<and> \<acute>M!(T i) \<noteq> Black) \<acute>Muts) \<guillemotright>"
-
-consts M_init :: nodes
-
-constdefs
- Proper_M_init :: "mul_gar_coll_state \<Rightarrow> bool"
- "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
-
- Mul_Proper :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_Proper \<equiv> \<guillemotleft> \<lambda>n. Proper_Roots \<acute>M \<and> Proper_Edges (\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<and> n=length \<acute>Muts \<guillemotright>"
-
- Safe :: "mul_gar_coll_state \<Rightarrow> bool"
- "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
-
-lemmas mul_collector_defs = Proper_M_init_def Mul_Proper_def Safe_def
-
-subsubsection {* Blackening Roots *}
-
-constdefs
- Mul_Blacken_Roots :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Blacken_Roots n \<equiv>
- .{\<acute>Mul_Proper n}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>ind\<in>Roots THEN
- .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
- \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
- .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind+1. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Blacken_Roots:
- "\<turnstile> Mul_Blacken_Roots n
- .{\<acute>Mul_Proper n \<and> Roots \<subseteq> Blacks \<acute>M}."
-apply (unfold Mul_Blacken_Roots_def)
-apply annhoare
-apply(simp_all add:mul_collector_defs Graph_defs)
-apply safe
-apply(simp_all add:nth_list_update)
- apply (erule less_SucE)
- apply simp+
- apply force
-apply force
-done
-
-subsubsection {* Propagating Black *}
-
-constdefs
- Mul_PBInv :: "mul_gar_coll_state \<Rightarrow> bool"
- "Mul_PBInv \<equiv> \<guillemotleft>\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M)) \<and> \<acute>l\<le>\<acute>Queue\<guillemotright>"
-
- Mul_Auxk :: "mul_gar_coll_state \<Rightarrow> bool"
- "Mul_Auxk \<equiv> \<guillemotleft>\<acute>l<\<acute>Queue \<or> \<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or> \<acute>obc\<subset>Blacks \<acute>M\<guillemotright>"
-
-constdefs
- Mul_Propagate_Black :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Propagate_Black n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> Blacks \<acute>M\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
- IF \<acute>M!(fst (\<acute>E!\<acute>ind))=Black THEN
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black \<and> \<acute>ind<length \<acute>E}.
- \<acute>k:=snd(\<acute>E!\<acute>ind);;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M))
- \<and> \<acute>l\<le>\<acute>Queue \<and> \<acute>Mul_Auxk ) \<and> \<acute>k<length \<acute>M \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black
- \<and> \<acute>ind<length \<acute>E}.
- \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],,\<acute>ind:=\<acute>ind+1\<rangle>
- ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
- \<langle>IF \<acute>M!(fst (\<acute>E!\<acute>ind))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle> FI
- OD"
-
-lemma Mul_Propagate_Black:
- "\<turnstile> Mul_Propagate_Black n
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}."
-apply(unfold Mul_Propagate_Black_def)
-apply annhoare
-apply(simp_all add:Mul_PBInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
---{* 8 subgoals left *}
-apply force
-apply force
-apply force
-apply(force simp add:BtoW_def Graph_defs)
---{* 4 subgoals left *}
-apply clarify
-apply(simp add: mul_collector_defs Graph12 Graph6 Graph7 Graph8)
-apply(disjE_tac)
- apply(simp_all add:Graph12 Graph13)
- apply(case_tac "M x! k x=Black")
- apply(simp add: Graph10)
- apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(case_tac "M x! k x=Black")
- apply(simp add: Graph10 BtoW_def)
- apply(rule disjI2, clarify, erule less_SucE, force)
- apply(case_tac "M x!snd(E x! ind x)=Black")
- apply(force)
- apply(force)
-apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply force
---{* 2 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply (simp_all)
-apply clarify
-apply(erule less_SucE)
- apply force
-apply (simp add:BtoW_def)
---{* 1 subgoal left *}
-apply clarify
-apply simp
-apply(disjE_tac)
-apply (simp_all)
-apply(rule disjI1 , rule Graph1)
- apply simp_all
-done
-
-subsubsection {* Counting Black Nodes *}
-
-constdefs
- Mul_CountInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
-
- Mul_Count :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Count n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
- \<and> \<acute>q<n+1 \<and> \<acute>bc={}}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
- \<and> \<acute>q<n+1 \<and> \<acute>bc={} \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black
- THEN .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>bc:=insert \<acute>ind \<acute>bc
- FI;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv (\<acute>ind+1)
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Count:
- "\<turnstile> Mul_Count n
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1}."
-apply (unfold Mul_Count_def)
-apply annhoare
-apply(simp_all add:Mul_CountInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
---{* 7 subgoals left *}
-apply force
-apply force
-apply force
---{* 4 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply simp_all
-apply(simp add:Blacks_def)
-apply clarify
-apply(erule less_SucE)
- back
- apply force
-apply force
---{* 3 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply simp_all
-apply clarify
-apply(erule less_SucE)
- back
- apply force
-apply simp
-apply(rotate_tac -1)
-apply (force simp add:Blacks_def)
---{* 2 subgoals left *}
-apply force
---{* 1 subgoal left *}
-apply clarify
-apply(drule_tac x = "ind x" in le_imp_less_or_eq)
-apply (simp_all add:Blacks_def)
-done
-
-subsubsection {* Appending garbage nodes to the free list *}
-
-consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
-
-axioms
- Append_to_free0: "length (Append_to_free (i, e)) = length e"
- Append_to_free1: "Proper_Edges (m, e)
- \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
- Append_to_free2: "i \<notin> Reach e
- \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
-
-constdefs
- Mul_AppendInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_AppendInv \<equiv> \<guillemotleft> \<lambda>ind. (\<forall>i. ind\<le>i \<longrightarrow> i<length \<acute>M \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black)\<guillemotright>"
-
- Mul_Append :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Append n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black THEN
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>M:=\<acute>M[\<acute>ind:=White]
- ELSE
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
- \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
- FI;;
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Append:
- "\<turnstile> Mul_Append n
- .{\<acute>Mul_Proper n}."
-apply(unfold Mul_Append_def)
-apply annhoare
-apply(simp_all add: mul_collector_defs Mul_AppendInv_def
- Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(force simp add:Blacks_def)
-apply(force simp add:Blacks_def)
-apply(force simp add:Blacks_def)
-apply(force simp add:Graph_defs)
-apply force
-apply(force simp add:Append_to_free1 Append_to_free2)
-apply force
-apply force
-done
-
-subsubsection {* Collector *}
-
-constdefs
- Mul_Collector :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Collector n \<equiv>
-.{\<acute>Mul_Proper n}.
-WHILE True INV .{\<acute>Mul_Proper n}.
-DO
-Mul_Blacken_Roots n ;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M}.
- \<acute>obc:={};;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
- \<acute>bc:=Roots;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
- \<acute>l:=0;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>l=0}.
- WHILE \<acute>l<n+1
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and>
- (\<acute>Safe \<or> (\<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M) \<and> \<acute>l<n+1)}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M)}.
- \<acute>obc:=\<acute>bc;;
- Mul_Propagate_Black n;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}.
- \<acute>bc:={};;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)) \<and> \<acute>bc={}}.
- \<langle> \<acute>Ma:=\<acute>M,, \<acute>q:=\<acute>Queue \<rangle>;;
- Mul_Count n;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1}.
- IF \<acute>obc=\<acute>bc THEN
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>obc=\<acute>bc}.
- \<acute>l:=\<acute>l+1
- ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>obc\<noteq>\<acute>bc}.
- \<acute>l:=0 FI
- OD;;
- Mul_Append n
-OD"
-
-lemmas mul_modules = Mul_Redirect_Edge_def Mul_Color_Target_def
- Mul_Blacken_Roots_def Mul_Propagate_Black_def
- Mul_Count_def Mul_Append_def
-
-lemma Mul_Collector:
- "\<turnstile> Mul_Collector n
- .{False}."
-apply(unfold Mul_Collector_def)
-apply annhoare
-apply(simp_all only:pre.simps Mul_Blacken_Roots
- Mul_Propagate_Black Mul_Count Mul_Append)
-apply(simp_all add:mul_modules)
-apply(simp_all add:mul_collector_defs Queue_def)
-apply force
-apply force
-apply force
-apply (force simp add: less_Suc_eq_le)
-apply force
-apply (force dest:subset_antisym)
-apply force
-apply force
-apply force
-done
-
-subsection {* Interference Freedom *}
-
-lemma le_length_filter_update[rule_format]:
- "\<forall>i. (\<not>P (list!i) \<or> P j) \<and> i<length list
- \<longrightarrow> length(filter P list) \<le> length(filter P (list[i:=j]))"
-apply(induct_tac "list")
- apply(simp)
-apply(clarify)
-apply(case_tac i)
- apply(simp)
-apply(simp)
-done
-
-lemma less_length_filter_update [rule_format]:
- "\<forall>i. P j \<and> \<not>(P (list!i)) \<and> i<length list
- \<longrightarrow> length(filter P list) < length(filter P (list[i:=j]))"
-apply(induct_tac "list")
- apply(simp)
-apply(clarify)
-apply(case_tac i)
- apply(simp)
-apply(simp)
-done
-
-lemma Mul_interfree_Blacken_Roots_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Blacken_Roots n),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:Graph6 Graph9 Graph12 nth_list_update mul_mutator_defs mul_collector_defs)
-done
-
-lemma Mul_interfree_Redirect_Edge_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Blacken_Roots n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Blacken_Roots_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Blacken_Roots n),{},Some (Mul_Color_Target j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs mul_collector_defs nth_list_update Graph7 Graph8 Graph9 Graph12)
-done
-
-lemma Mul_interfree_Color_Target_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n ),{},Some (Mul_Blacken_Roots n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Propagate_Black_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Redirect_Edge j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_PBInv_def nth_list_update Graph6)
---{* 7 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 6 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 5 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
---{* 4 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
---{* 3 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply (rule impI)
- apply(rule conjI)
- apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule conjI)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(erule conjE)
- apply(rule conjI)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule impI,rule conjI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI,rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
- apply(case_tac "R (Muts x! j)=ind x")
- apply (force simp add: nth_list_update)
- apply (force simp add: nth_list_update)
-apply(rule impI, (rule disjI2)+, erule le_trans)
-apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 2 subgoals left *}
-apply clarify
-apply(rule conjI)
- apply(disjE_tac)
- apply(simp_all add:Mul_Auxk_def Graph6)
- apply (rule impI)
- apply(rule conjI)
- apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
-apply(rule impI)
-apply(rule conjI)
- apply(erule conjE)+
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(rule conjI)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update BtoW_def)
- apply (simp add:nth_list_update)
- apply(rule impI)
- apply simp
- apply(disjE_tac)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply force
- apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
-apply(disjE_tac)
-apply simp_all
-apply(conjI_tac)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)+
-apply(rule impI,(rule disjI2)+,rule conjI)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI)+
-apply simp
-apply(disjE_tac)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply force
---{* 1 subgoal left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Propagate_Black n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Propagate_Black_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Color_Target j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add: mul_collector_defs mul_mutator_defs)
---{* 7 subgoals left *}
-apply clarify
-apply (simp add:Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 6 subgoals left *}
-apply clarify
-apply (simp add:Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 5 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+)
- apply (rule conjI)
- apply(simp add:Graph10)
- apply(erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
---{* 4 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+)
- apply (rule conjI)
- apply(simp add:Graph10)
- apply(erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
---{* 3 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)
- apply((rule disjI2)+,erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule conjI)
- apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-apply (force simp add:nth_list_update)
---{* 2 subgoals left *}
-apply clarify
-apply(simp add:Mul_Auxk_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)+
- apply((rule disjI2)+,rule conjI, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule impI)+)
- apply simp
- apply(erule disjE)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply force
-apply(rule conjI)
- apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-apply (force simp add:nth_list_update)
---{* 1 subgoal left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)
- apply((rule disjI2)+,erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-done
-
-lemma Mul_interfree_Color_Target_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{},Some(Mul_Propagate_Black n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Count_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Count n ),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 8 subgoals left *}
-apply(simp add:mul_mutator_defs nth_list_update)
---{* 7 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 6 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6 Queue_def)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 5 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 4 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 3 subgoals left *}
-apply(simp add:mul_mutator_defs nth_list_update)
---{* 2 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 1 subgoal left *}
-apply(simp add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Count n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Count_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Count n ),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add:mul_collector_defs mul_mutator_defs Mul_CountInv_def)
---{* 6 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 5 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 4 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 3 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 2 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
- apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(rule conjI)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
- apply (simp add: nth_list_update)
-apply (simp add: Graph7 Graph8 Graph12)
-apply(rule conjI)
- apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
-apply (simp add: nth_list_update)
---{* 1 subgoal left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
-done
-
-lemma Mul_interfree_Color_Target_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Count n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Append_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Append n),{}, Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Append_to_free0 Append_to_free1 mul_collector_defs mul_mutator_defs Mul_AppendInv_def)
-apply(erule_tac x=j in allE, force dest:Graph3)+
-done
-
-lemma Mul_interfree_Redirect_Edge_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Append n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:mul_collector_defs Append_to_free0 Mul_AppendInv_def mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Append_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Append n),{}, Some(Mul_Color_Target j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_AppendInv_def Graph7 Graph8 Append_to_free0 Append_to_free1
- Graph12 nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Append n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add: mul_mutator_defs nth_list_update)
-apply(simp add:Mul_AppendInv_def Append_to_free0)
-done
-
-subsubsection {* Interference freedom Collector-Mutator *}
-
-lemmas mul_collector_mutator_interfree =
- Mul_interfree_Blacken_Roots_Redirect_Edge Mul_interfree_Blacken_Roots_Color_Target
- Mul_interfree_Propagate_Black_Redirect_Edge Mul_interfree_Propagate_Black_Color_Target
- Mul_interfree_Count_Redirect_Edge Mul_interfree_Count_Color_Target
- Mul_interfree_Append_Redirect_Edge Mul_interfree_Append_Color_Target
- Mul_interfree_Redirect_Edge_Blacken_Roots Mul_interfree_Color_Target_Blacken_Roots
- Mul_interfree_Redirect_Edge_Propagate_Black Mul_interfree_Color_Target_Propagate_Black
- Mul_interfree_Redirect_Edge_Count Mul_interfree_Color_Target_Count
- Mul_interfree_Redirect_Edge_Append Mul_interfree_Color_Target_Append
-
-lemma Mul_interfree_Collector_Mutator: "j<n \<Longrightarrow>
- interfree_aux (Some (Mul_Collector n), {}, Some (Mul_Mutator j n))"
-apply(unfold Mul_Collector_def Mul_Mutator_def)
-apply interfree_aux
-apply(simp_all add:mul_collector_mutator_interfree)
-apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 42 subgoals left *}
-apply (clarify,simp add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)+
---{* 24 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 14 subgoals left *}
-apply(tactic {* TRYALL (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(tactic {* TRYALL (rtac conjI) *})
-apply(tactic {* TRYALL (rtac impI) *})
-apply(tactic {* TRYALL (etac disjE) *})
-apply(tactic {* TRYALL (etac conjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
---{* 72 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 35 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI1,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
---{* 28 subgoals left *}
-apply(tactic {* TRYALL (etac conjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
---{* 34 subgoals left *}
-apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(case_tac [!] "M x!(T (Muts x ! j))=Black")
-apply(simp_all add:Graph10)
---{* 47 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 41 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
---{* 35 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "psubset_subset_trans"),rtac (thm "Graph9"),force_tac @{clasimpset}]) *})
---{* 31 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 29 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 25 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
---{* 10 subgoals left *}
-apply(rule disjI2,rule disjI2,rule conjI,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update, rule disjI1, rule less_imp_le, erule less_le_trans, force simp add:Queue_def less_Suc_eq_le le_length_filter_update)+
-done
-
-subsubsection {* Interference freedom Mutator-Collector *}
-
-lemma Mul_interfree_Mutator_Collector: " j < n \<Longrightarrow>
- interfree_aux (Some (Mul_Mutator j n), {}, Some (Mul_Collector n))"
-apply(unfold Mul_Collector_def Mul_Mutator_def)
-apply interfree_aux
-apply(simp_all add:mul_collector_mutator_interfree)
-apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 76 subgoals left *}
-apply (clarify,simp add: nth_list_update)+
---{* 56 subgoals left *}
-apply(clarify,simp add:Mul_AppendInv_def Append_to_free0 nth_list_update)+
-done
-
-subsubsection {* The Multi-Mutator Garbage Collection Algorithm *}
-
-text {* The total number of verification conditions is 328 *}
-
-lemma Mul_Gar_Coll:
- "\<parallel>- .{\<acute>Mul_Proper n \<and> \<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
- COBEGIN
- Mul_Collector n
- .{False}.
- \<parallel>
- SCHEME [0\<le> j< n]
- Mul_Mutator j n
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* Strengthening the precondition *}
-apply(rule Int_greatest)
- apply (case_tac n)
- apply(force simp add: Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
- apply(simp add: Mul_Mutator_def mul_collector_defs mul_mutator_defs nth_append)
- apply force
-apply clarify
-apply(case_tac i)
- apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
-apply(simp add: Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append nth_map_upt)
---{* Collector *}
-apply(rule Mul_Collector)
---{* Mutator *}
-apply(erule Mul_Mutator)
---{* Interference freedom *}
-apply(simp add:Mul_interfree_Collector_Mutator)
-apply(simp add:Mul_interfree_Mutator_Collector)
-apply(simp add:Mul_interfree_Mutator_Mutator)
---{* Weakening of the postcondition *}
-apply(case_tac n)
- apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
-apply(simp add:Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append)
-done
-
-end
--- a/src/HOL/HoareParallel/OG_Com.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,55 +0,0 @@
-
-header {* \chapter{The Owicki-Gries Method}
-
-\section{Abstract Syntax} *}
-
-theory OG_Com imports Main begin
-
-text {* Type abbreviations for boolean expressions and assertions: *}
-
-types
- 'a bexp = "'a set"
- 'a assn = "'a set"
-
-text {* The syntax of commands is defined by two mutually recursive
-datatypes: @{text "'a ann_com"} for annotated commands and @{text "'a
-com"} for non-annotated commands. *}
-
-datatype 'a ann_com =
- AnnBasic "('a assn)" "('a \<Rightarrow> 'a)"
- | AnnSeq "('a ann_com)" "('a ann_com)"
- | AnnCond1 "('a assn)" "('a bexp)" "('a ann_com)" "('a ann_com)"
- | AnnCond2 "('a assn)" "('a bexp)" "('a ann_com)"
- | AnnWhile "('a assn)" "('a bexp)" "('a assn)" "('a ann_com)"
- | AnnAwait "('a assn)" "('a bexp)" "('a com)"
-and 'a com =
- Parallel "('a ann_com option \<times> 'a assn) list"
- | Basic "('a \<Rightarrow> 'a)"
- | Seq "('a com)" "('a com)"
- | Cond "('a bexp)" "('a com)" "('a com)"
- | While "('a bexp)" "('a assn)" "('a com)"
-
-text {* The function @{text pre} extracts the precondition of an
-annotated command: *}
-
-consts
- pre ::"'a ann_com \<Rightarrow> 'a assn"
-primrec
- "pre (AnnBasic r f) = r"
- "pre (AnnSeq c1 c2) = pre c1"
- "pre (AnnCond1 r b c1 c2) = r"
- "pre (AnnCond2 r b c) = r"
- "pre (AnnWhile r b i c) = r"
- "pre (AnnAwait r b c) = r"
-
-text {* Well-formedness predicate for atomic programs: *}
-
-consts atom_com :: "'a com \<Rightarrow> bool"
-primrec
- "atom_com (Parallel Ts) = False"
- "atom_com (Basic f) = True"
- "atom_com (Seq c1 c2) = (atom_com c1 \<and> atom_com c2)"
- "atom_com (Cond b c1 c2) = (atom_com c1 \<and> atom_com c2)"
- "atom_com (While b i c) = atom_com c"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Examples.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,549 +0,0 @@
-
-header {* \section{Examples} *}
-
-theory OG_Examples imports OG_Syntax begin
-
-subsection {* Mutual Exclusion *}
-
-subsubsection {* Peterson's Algorithm I*}
-
-text {* Eike Best. "Semantics of Sequential and Parallel Programs", page 217. *}
-
-record Petersons_mutex_1 =
- pr1 :: nat
- pr2 :: nat
- in1 :: bool
- in2 :: bool
- hold :: nat
-
-lemma Petersons_mutex_1:
- "\<parallel>- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 }.
- COBEGIN .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- WHILE True INV .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- DO
- .{\<acute>pr1=0 \<and> \<not>\<acute>in1}. \<langle> \<acute>in1:=True,,\<acute>pr1:=1 \<rangle>;;
- .{\<acute>pr1=1 \<and> \<acute>in1}. \<langle> \<acute>hold:=1,,\<acute>pr1:=2 \<rangle>;;
- .{\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
- AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
- .{\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
- \<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
- OD .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- \<parallel>
- .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- WHILE True INV .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- DO
- .{\<acute>pr2=0 \<and> \<not>\<acute>in2}. \<langle> \<acute>in2:=True,,\<acute>pr2:=1 \<rangle>;;
- .{\<acute>pr2=1 \<and> \<acute>in2}. \<langle> \<acute>hold:=2,,\<acute>pr2:=2 \<rangle>;;
- .{\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
- AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
- .{\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
- \<langle>\<acute>in2:=False,,\<acute>pr2:=0\<rangle>
- OD .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- COEND
- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2}."
-apply oghoare
---{* 104 verification conditions. *}
-apply auto
-done
-
-subsubsection {*Peterson's Algorithm II: A Busy Wait Solution *}
-
-text {* Apt and Olderog. "Verification of sequential and concurrent Programs", page 282. *}
-
-record Busy_wait_mutex =
- flag1 :: bool
- flag2 :: bool
- turn :: nat
- after1 :: bool
- after2 :: bool
-
-lemma Busy_wait_mutex:
- "\<parallel>- .{True}.
- \<acute>flag1:=False,, \<acute>flag2:=False,,
- COBEGIN .{\<not>\<acute>flag1}.
- WHILE True
- INV .{\<not>\<acute>flag1}.
- DO .{\<not>\<acute>flag1}. \<langle> \<acute>flag1:=True,,\<acute>after1:=False \<rangle>;;
- .{\<acute>flag1 \<and> \<not>\<acute>after1}. \<langle> \<acute>turn:=1,,\<acute>after1:=True \<rangle>;;
- .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- WHILE \<not>(\<acute>flag2 \<longrightarrow> \<acute>turn=2)
- INV .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- DO .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
- .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>flag2 \<and> \<acute>after2 \<longrightarrow> \<acute>turn=2)}.
- \<acute>flag1:=False
- OD
- .{False}.
- \<parallel>
- .{\<not>\<acute>flag2}.
- WHILE True
- INV .{\<not>\<acute>flag2}.
- DO .{\<not>\<acute>flag2}. \<langle> \<acute>flag2:=True,,\<acute>after2:=False \<rangle>;;
- .{\<acute>flag2 \<and> \<not>\<acute>after2}. \<langle> \<acute>turn:=2,,\<acute>after2:=True \<rangle>;;
- .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- WHILE \<not>(\<acute>flag1 \<longrightarrow> \<acute>turn=1)
- INV .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- DO .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
- .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>flag1 \<and> \<acute>after1 \<longrightarrow> \<acute>turn=1)}.
- \<acute>flag2:=False
- OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 122 vc *}
-apply auto
-done
-
-subsubsection {* Peterson's Algorithm III: A Solution using Semaphores *}
-
-record Semaphores_mutex =
- out :: bool
- who :: nat
-
-lemma Semaphores_mutex:
- "\<parallel>- .{i\<noteq>j}.
- \<acute>out:=True ,,
- COBEGIN .{i\<noteq>j}.
- WHILE True INV .{i\<noteq>j}.
- DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
- .{\<not>\<acute>out \<and> \<acute>who=i \<and> i\<noteq>j}. \<acute>out:=True OD
- .{False}.
- \<parallel>
- .{i\<noteq>j}.
- WHILE True INV .{i\<noteq>j}.
- DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,,\<acute>who:=j END;;
- .{\<not>\<acute>out \<and> \<acute>who=j \<and> i\<noteq>j}. \<acute>out:=True OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 38 vc *}
-apply auto
-done
-
-subsubsection {* Peterson's Algorithm III: Parameterized version: *}
-
-lemma Semaphores_parameterized_mutex:
- "0<n \<Longrightarrow> \<parallel>- .{True}.
- \<acute>out:=True ,,
- COBEGIN
- SCHEME [0\<le> i< n]
- .{True}.
- WHILE True INV .{True}.
- DO .{True}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
- .{\<not>\<acute>out \<and> \<acute>who=i}. \<acute>out:=True OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 20 vc *}
-apply auto
-done
-
-subsubsection{* The Ticket Algorithm *}
-
-record Ticket_mutex =
- num :: nat
- nextv :: nat
- turn :: "nat list"
- index :: nat
-
-lemma Ticket_mutex:
- "\<lbrakk> 0<n; I=\<guillemotleft>n=length \<acute>turn \<and> 0<\<acute>nextv \<and> (\<forall>k l. k<n \<and> l<n \<and> k\<noteq>l
- \<longrightarrow> \<acute>turn!k < \<acute>num \<and> (\<acute>turn!k =0 \<or> \<acute>turn!k\<noteq>\<acute>turn!l))\<guillemotright> \<rbrakk>
- \<Longrightarrow> \<parallel>- .{n=length \<acute>turn}.
- \<acute>index:= 0,,
- WHILE \<acute>index < n INV .{n=length \<acute>turn \<and> (\<forall>i<\<acute>index. \<acute>turn!i=0)}.
- DO \<acute>turn:= \<acute>turn[\<acute>index:=0],, \<acute>index:=\<acute>index +1 OD,,
- \<acute>num:=1 ,, \<acute>nextv:=1 ,,
- COBEGIN
- SCHEME [0\<le> i< n]
- .{\<acute>I}.
- WHILE True INV .{\<acute>I}.
- DO .{\<acute>I}. \<langle> \<acute>turn :=\<acute>turn[i:=\<acute>num],, \<acute>num:=\<acute>num+1 \<rangle>;;
- .{\<acute>I}. WAIT \<acute>turn!i=\<acute>nextv END;;
- .{\<acute>I \<and> \<acute>turn!i=\<acute>nextv}. \<acute>nextv:=\<acute>nextv+1
- OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 35 vc *}
-apply simp_all
---{* 21 vc *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 11 vc *}
-apply simp_all
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 10 subgoals left *}
-apply(erule less_SucE)
- apply simp
-apply simp
---{* 9 subgoals left *}
-apply(case_tac "i=k")
- apply force
-apply simp
-apply(case_tac "i=l")
- apply force
-apply force
---{* 8 subgoals left *}
-prefer 8
-apply force
-apply force
---{* 6 subgoals left *}
-prefer 6
-apply(erule_tac x=i in allE)
-apply fastsimp
---{* 5 subgoals left *}
-prefer 5
-apply(case_tac [!] "j=k")
---{* 10 subgoals left *}
-apply simp_all
-apply(erule_tac x=k in allE)
-apply force
---{* 9 subgoals left *}
-apply(case_tac "j=l")
- apply simp
- apply(erule_tac x=k in allE)
- apply(erule_tac x=k in allE)
- apply(erule_tac x=l in allE)
- apply force
-apply(erule_tac x=k in allE)
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply force
---{* 8 subgoals left *}
-apply force
-apply(case_tac "j=l")
- apply simp
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply force
-apply force
-apply force
---{* 5 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-apply force
---{* 3 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-apply force
---{* 1 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-done
-
-subsection{* Parallel Zero Search *}
-
-text {* Synchronized Zero Search. Zero-6 *}
-
-text {*Apt and Olderog. "Verification of sequential and concurrent Programs" page 294: *}
-
-record Zero_search =
- turn :: nat
- found :: bool
- x :: nat
- y :: nat
-
-lemma Zero_search:
- "\<lbrakk>I1= \<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> a<\<acute> x \<longrightarrow> f(\<acute>x)\<noteq>0) \<guillemotright> ;
- I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0) \<guillemotright> \<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<exists> u. f(u)=0}.
- \<acute>turn:=1,, \<acute>found:= False,,
- \<acute>x:=a,, \<acute>y:=a+1 ,,
- COBEGIN .{\<acute>I1}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I1}.
- DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- WAIT \<acute>turn=1 END;;
- .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<acute>turn:=2;;
- .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<langle> \<acute>x:=\<acute>x+1,,
- IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD;;
- .{\<acute>I1 \<and> \<acute>found}.
- \<acute>turn:=2
- .{\<acute>I1 \<and> \<acute>found}.
- \<parallel>
- .{\<acute>I2}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I2}.
- DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- WAIT \<acute>turn=2 END;;
- .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<acute>turn:=1;;
- .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<langle> \<acute>y:=(\<acute>y - 1),,
- IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD;;
- .{\<acute>I2 \<and> \<acute>found}.
- \<acute>turn:=1
- .{\<acute>I2 \<and> \<acute>found}.
- COEND
- .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
-apply oghoare
---{* 98 verification conditions *}
-apply auto
---{* auto takes about 3 minutes !! *}
-done
-
-text {* Easier Version: without AWAIT. Apt and Olderog. page 256: *}
-
-lemma Zero_Search_2:
-"\<lbrakk>I1=\<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<guillemotright>;
- I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<guillemotright>\<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<exists>u. f(u)=0}.
- \<acute>found:= False,,
- \<acute>x:=a,, \<acute>y:=a+1,,
- COBEGIN .{\<acute>I1}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I1}.
- DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<langle> \<acute>x:=\<acute>x+1,,IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD
- .{\<acute>I1 \<and> \<acute>found}.
- \<parallel>
- .{\<acute>I2}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I2}.
- DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<langle> \<acute>y:=(\<acute>y - 1),,IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD
- .{\<acute>I2 \<and> \<acute>found}.
- COEND
- .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
-apply oghoare
---{* 20 vc *}
-apply auto
---{* auto takes aprox. 2 minutes. *}
-done
-
-subsection {* Producer/Consumer *}
-
-subsubsection {* Previous lemmas *}
-
-lemma nat_lemma2: "\<lbrakk> b = m*(n::nat) + t; a = s*n + u; t=u; b-a < n \<rbrakk> \<Longrightarrow> m \<le> s"
-proof -
- assume "b = m*(n::nat) + t" "a = s*n + u" "t=u"
- hence "(m - s) * n = b - a" by (simp add: diff_mult_distrib)
- also assume "\<dots> < n"
- finally have "m - s < 1" by simp
- thus ?thesis by arith
-qed
-
-lemma mod_lemma: "\<lbrakk> (c::nat) \<le> a; a < b; b - c < n \<rbrakk> \<Longrightarrow> b mod n \<noteq> a mod n"
-apply(subgoal_tac "b=b div n*n + b mod n" )
- prefer 2 apply (simp add: mod_div_equality [symmetric])
-apply(subgoal_tac "a=a div n*n + a mod n")
- prefer 2
- apply(simp add: mod_div_equality [symmetric])
-apply(subgoal_tac "b - a \<le> b - c")
- prefer 2 apply arith
-apply(drule le_less_trans)
-back
- apply assumption
-apply(frule less_not_refl2)
-apply(drule less_imp_le)
-apply (drule_tac m = "a" and k = n in div_le_mono)
-apply(safe)
-apply(frule_tac b = "b" and a = "a" and n = "n" in nat_lemma2, assumption, assumption)
-apply assumption
-apply(drule order_antisym, assumption)
-apply(rotate_tac -3)
-apply(simp)
-done
-
-
-subsubsection {* Producer/Consumer Algorithm *}
-
-record Producer_consumer =
- ins :: nat
- outs :: nat
- li :: nat
- lj :: nat
- vx :: nat
- vy :: nat
- buffer :: "nat list"
- b :: "nat list"
-
-text {* The whole proof takes aprox. 4 minutes. *}
-
-lemma Producer_consumer:
- "\<lbrakk>INIT= \<guillemotleft>0<length a \<and> 0<length \<acute>buffer \<and> length \<acute>b=length a\<guillemotright> ;
- I= \<guillemotleft>(\<forall>k<\<acute>ins. \<acute>outs\<le>k \<longrightarrow> (a ! k) = \<acute>buffer ! (k mod (length \<acute>buffer))) \<and>
- \<acute>outs\<le>\<acute>ins \<and> \<acute>ins-\<acute>outs\<le>length \<acute>buffer\<guillemotright> ;
- I1= \<guillemotleft>\<acute>I \<and> \<acute>li\<le>length a\<guillemotright> ;
- p1= \<guillemotleft>\<acute>I1 \<and> \<acute>li=\<acute>ins\<guillemotright> ;
- I2 = \<guillemotleft>\<acute>I \<and> (\<forall>k<\<acute>lj. (a ! k)=(\<acute>b ! k)) \<and> \<acute>lj\<le>length a\<guillemotright> ;
- p2 = \<guillemotleft>\<acute>I2 \<and> \<acute>lj=\<acute>outs\<guillemotright> \<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<acute>INIT}.
- \<acute>ins:=0,, \<acute>outs:=0,, \<acute>li:=0,, \<acute>lj:=0,,
- COBEGIN .{\<acute>p1 \<and> \<acute>INIT}.
- WHILE \<acute>li <length a
- INV .{\<acute>p1 \<and> \<acute>INIT}.
- DO .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a}.
- \<acute>vx:= (a ! \<acute>li);;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)}.
- WAIT \<acute>ins-\<acute>outs < length \<acute>buffer END;;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)
- \<and> \<acute>ins-\<acute>outs < length \<acute>buffer}.
- \<acute>buffer:=(list_update \<acute>buffer (\<acute>ins mod (length \<acute>buffer)) \<acute>vx);;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a
- \<and> (a ! \<acute>li)=(\<acute>buffer ! (\<acute>ins mod (length \<acute>buffer)))
- \<and> \<acute>ins-\<acute>outs <length \<acute>buffer}.
- \<acute>ins:=\<acute>ins+1;;
- .{\<acute>I1 \<and> \<acute>INIT \<and> (\<acute>li+1)=\<acute>ins \<and> \<acute>li<length a}.
- \<acute>li:=\<acute>li+1
- OD
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li=length a}.
- \<parallel>
- .{\<acute>p2 \<and> \<acute>INIT}.
- WHILE \<acute>lj < length a
- INV .{\<acute>p2 \<and> \<acute>INIT}.
- DO .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>INIT}.
- WAIT \<acute>outs<\<acute>ins END;;
- .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>INIT}.
- \<acute>vy:=(\<acute>buffer ! (\<acute>outs mod (length \<acute>buffer)));;
- .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>outs:=\<acute>outs+1;;
- .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>b:=(list_update \<acute>b \<acute>lj \<acute>vy);;
- .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> (a ! \<acute>lj)=(\<acute>b ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>lj:=\<acute>lj+1
- OD
- .{\<acute>p2 \<and> \<acute>lj=length a \<and> \<acute>INIT}.
- COEND
- .{ \<forall>k<length a. (a ! k)=(\<acute>b ! k)}."
-apply oghoare
---{* 138 vc *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 112 subgoals left *}
-apply(simp_all (no_asm))
-apply(tactic {*ALLGOALS (conjI_Tac (K all_tac)) *})
---{* 930 subgoals left *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all (asm_lr) only:length_0_conv [THEN sym])
---{* 44 subgoals left *}
-apply (simp_all (asm_lr) del:length_0_conv add: neq0_conv nth_list_update mod_less_divisor mod_lemma)
---{* 32 subgoals left *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-
-apply(tactic {* TRYALL (Lin_Arith.tac @{context}) *})
---{* 9 subgoals left *}
-apply (force simp add:less_Suc_eq)
-apply(drule sym)
-apply (force simp add:less_Suc_eq)+
-done
-
-subsection {* Parameterized Examples *}
-
-subsubsection {* Set Elements of an Array to Zero *}
-
-record Example1 =
- a :: "nat \<Rightarrow> nat"
-
-lemma Example1:
- "\<parallel>- .{True}.
- COBEGIN SCHEME [0\<le>i<n] .{True}. \<acute>a:=\<acute>a (i:=0) .{\<acute>a i=0}. COEND
- .{\<forall>i < n. \<acute>a i = 0}."
-apply oghoare
-apply simp_all
-done
-
-text {* Same example with lists as auxiliary variables. *}
-record Example1_list =
- A :: "nat list"
-lemma Example1_list:
- "\<parallel>- .{n < length \<acute>A}.
- COBEGIN
- SCHEME [0\<le>i<n] .{n < length \<acute>A}. \<acute>A:=\<acute>A[i:=0] .{\<acute>A!i=0}.
- COEND
- .{\<forall>i < n. \<acute>A!i = 0}."
-apply oghoare
-apply force+
-done
-
-subsubsection {* Increment a Variable in Parallel *}
-
-text {* First some lemmas about summation properties. *}
-(*
-lemma Example2_lemma1: "!!b. j<n \<Longrightarrow> (\<Sum>i::nat<n. b i) = (0::nat) \<Longrightarrow> b j = 0 "
-apply(induct n)
- apply simp_all
-apply(force simp add: less_Suc_eq)
-done
-*)
-lemma Example2_lemma2_aux: "!!b. j<n \<Longrightarrow>
- (\<Sum>i=0..<n. (b i::nat)) =
- (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
-apply(induct n)
- apply simp_all
-apply(simp add:less_Suc_eq)
- apply(auto)
-apply(subgoal_tac "n - j = Suc(n- Suc j)")
- apply simp
-apply arith
-done
-
-lemma Example2_lemma2_aux2:
- "!!b. j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
-apply(induct j)
- apply simp_all
-done
-
-lemma Example2_lemma2:
- "!!b. \<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
-apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
-apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
-apply(frule_tac b=b in Example2_lemma2_aux)
-apply(erule_tac t="setsum b {0..<n}" in ssubst)
-apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply(subgoal_tac "j\<le>j")
- apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply simp_all
-done
-
-
-record Example2 =
- c :: "nat \<Rightarrow> nat"
- x :: nat
-
-lemma Example_2: "0<n \<Longrightarrow>
- \<parallel>- .{\<acute>x=0 \<and> (\<Sum>i=0..<n. \<acute>c i)=0}.
- COBEGIN
- SCHEME [0\<le>i<n]
- .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=0}.
- \<langle> \<acute>x:=\<acute>x+(Suc 0),, \<acute>c:=\<acute>c (i:=(Suc 0)) \<rangle>
- .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=(Suc 0)}.
- COEND
- .{\<acute>x=n}."
-apply oghoare
-apply (simp_all cong del: strong_setsum_cong)
-apply (tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply (simp_all cong del: strong_setsum_cong)
- apply(erule (1) Example2_lemma2)
- apply(erule (1) Example2_lemma2)
- apply(erule (1) Example2_lemma2)
-apply(simp)
-done
-
-end
--- a/src/HOL/HoareParallel/OG_Hoare.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,469 +0,0 @@
-
-header {* \section{The Proof System} *}
-
-theory OG_Hoare imports OG_Tran begin
-
-consts assertions :: "'a ann_com \<Rightarrow> ('a assn) set"
-primrec
- "assertions (AnnBasic r f) = {r}"
- "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
- "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
- "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
- "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
- "assertions (AnnAwait r b c) = {r}"
-
-consts atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set"
-primrec
- "atomics (AnnBasic r f) = {(r, Basic f)}"
- "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
- "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
- "atomics (AnnCond2 r b c) = atomics c"
- "atomics (AnnWhile r b i c) = atomics c"
- "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"
-
-consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
-primrec "com (c, q) = c"
-
-consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
-primrec "post (c, q) = q"
-
-constdefs interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool"
- "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
- (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
- (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"
-
-constdefs interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool"
- "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
- interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "
-
-inductive
- oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>- _//_//_)" [90,55,90] 50)
- and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(2\<turnstile> _// _)" [60,90] 45)
-where
- AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"
-
-| AnnSeq: "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"
-
-| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
- \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
-| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"
-
-| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"
-
-| AnnAwait: "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"
-
-| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"
-
-
-| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
- Parallel Ts
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
-
-| Basic: "\<parallel>- {s. f s \<in>q} (Basic f) q"
-
-| Seq: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "
-
-| Cond: "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
-
-| While: "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"
-
-| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"
-
-section {* Soundness *}
-(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
-parts of conditional expressions (if P then x else y) are no longer
-simplified. (This allows the simplifier to unfold recursive
-functional programs.) To restore the old behaviour, we declare
-@{text "lemmas [cong del] = if_weak_cong"}. *)
-
-lemmas [cong del] = if_weak_cong
-
-lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
-lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]
-
-lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
-lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
-lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
-lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
-lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
-lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
-lemmas AnnConseq = oghoare_ann_hoare.AnnConseq
-
-lemmas Parallel = oghoare_ann_hoare.Parallel
-lemmas Basic = oghoare_ann_hoare.Basic
-lemmas Seq = oghoare_ann_hoare.Seq
-lemmas Cond = oghoare_ann_hoare.Cond
-lemmas While = oghoare_ann_hoare.While
-lemmas Conseq = oghoare_ann_hoare.Conseq
-
-subsection {* Soundness of the System for Atomic Programs *}
-
-lemma Basic_ntran [rule_format]:
- "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
-apply(induct "n")
- apply(simp (no_asm))
-apply(fast dest: rel_pow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
-done
-
-lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
-apply (induct "k")
- apply(simp (no_asm) add: L3_5v_lemma3)
-apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
-apply(rule conjI)
- apply (blast dest: L3_5i)
-apply(simp add: SEM_def sem_def id_def)
-apply (blast dest: Basic_ntran rtrancl_imp_UN_rel_pow)
-done
-
-lemma atom_hoare_sound [rule_format]:
- " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
-apply (unfold com_validity_def)
-apply(rule oghoare_induct)
-apply simp_all
---{*Basic*}
- apply(simp add: SEM_def sem_def)
- apply(fast dest: rtrancl_imp_UN_rel_pow Basic_ntran)
---{* Seq *}
- apply(rule impI)
- apply(rule subset_trans)
- prefer 2 apply simp
- apply(simp add: L3_5ii L3_5i)
---{* Cond *}
- apply(simp add: L3_5iv)
---{* While *}
- apply (force simp add: L3_5v dest: SEM_fwhile)
---{* Conseq *}
-apply(force simp add: SEM_def sem_def)
-done
-
-subsection {* Soundness of the System for Component Programs *}
-
-inductive_cases ann_transition_cases:
- "(None,s) -1\<rightarrow> (c', s')"
- "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
- "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
- "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
- "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
- "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
- "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"
-
-text {* Strong Soundness for Component Programs:*}
-
-lemma ann_hoare_case_analysis [rule_format]:
- defines I: "I \<equiv> \<lambda>C q'.
- ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
- (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
- (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
- r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
- (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
- (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
- (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
- (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
- (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
- shows "\<turnstile> C q' \<longrightarrow> I C q'"
-apply(rule ann_hoare_induct)
-apply (simp_all add: I)
- apply(rule_tac x=q in exI,simp)+
-apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
-apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
-done
-
-lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
-apply force
-done
-
-lemma Strong_Soundness_aux_aux [rule_format]:
- "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
- (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
-apply(rule ann_transition_transition.induct [THEN conjunct1])
-apply simp_all
---{* Basic *}
- apply clarify
- apply(frule ann_hoare_case_analysis)
- apply force
---{* Seq *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply clarify
- apply(rule conjI)
- apply force
- apply(rule AnnSeq,simp)
- apply(fast intro: AnnConseq)
---{* Cond1 *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
---{* Cond2 *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
---{* While *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply force
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply auto
- apply(rule AnnSeq)
- apply simp
- apply(rule AnnWhile)
- apply simp_all
---{* Await *}
-apply(frule ann_hoare_case_analysis,simp)
-apply clarify
-apply(drule atom_hoare_sound)
- apply simp
-apply(simp add: com_validity_def SEM_def sem_def)
-apply(simp add: Help All_None_def)
-apply force
-done
-
-lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
- \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
-apply(erule rtrancl_induct2)
- apply simp
-apply(case_tac "a")
- apply(fast elim: ann_transition_cases)
-apply(erule Strong_Soundness_aux_aux)
- apply simp
-apply simp_all
-done
-
-lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
- \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
-apply(force dest:Strong_Soundness_aux)
-done
-
-lemma ann_hoare_sound: "\<turnstile> c q \<Longrightarrow> \<Turnstile> c q"
-apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
-apply clarify
-apply(drule Strong_Soundness)
-apply simp_all
-done
-
-subsection {* Soundness of the System for Parallel Programs *}
-
-lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
- (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
- (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
-apply(erule transition_cases)
-apply simp
-apply clarify
-apply(case_tac "i=ia")
-apply simp+
-done
-
-lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
- (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
- (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
-apply(erule rtrancl_induct2)
- apply(simp_all)
-apply clarify
-apply simp
-apply(drule Parallel_length_post_P1)
-apply auto
-done
-
-lemma assertions_lemma: "pre c \<in> assertions c"
-apply(rule ann_com_com.induct [THEN conjunct1])
-apply auto
-done
-
-lemma interfree_aux1 [rule_format]:
- "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
-apply (rule ann_transition_transition.induct [THEN conjunct1])
-apply(safe)
-prefer 13
-apply (rule TrueI)
-apply (simp_all add:interfree_aux_def)
-apply force+
-done
-
-lemma interfree_aux2 [rule_format]:
- "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a) \<longrightarrow> interfree_aux(r, q, a) )"
-apply (rule ann_transition_transition.induct [THEN conjunct1])
-apply(force simp add:interfree_aux_def)+
-done
-
-lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
- Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
-apply(simp add: interfree_def)
-apply clarify
-apply(case_tac "i=j")
- apply(drule_tac t = "ia" in not_sym)
- apply simp_all
-apply(force elim: interfree_aux1)
-apply(force elim: interfree_aux2 simp add:nth_list_update)
-done
-
-text {* Strong Soundness Theorem for Parallel Programs:*}
-
-lemma Parallel_Strong_Soundness_Seq_aux:
- "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
- \<Longrightarrow> interfree (Ts[i:=(Some c0, pre c1)])"
-apply(simp add: interfree_def)
-apply clarify
-apply(case_tac "i=j")
- apply(force simp add: nth_list_update interfree_aux_def)
-apply(case_tac "i=ia")
- apply(erule_tac x=ia in allE)
- apply(force simp add:interfree_aux_def assertions_lemma)
-apply simp
-done
-
-lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
- "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
- else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
- com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
- (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
- then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
- else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
- \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
- \<and> interfree (Ts[i:= (Some c0, pre c1)])"
-apply(rule conjI)
- apply safe
- apply(case_tac "i=ia")
- apply simp
- apply(force dest: ann_hoare_case_analysis)
- apply simp
-apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
-done
-
-lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
- "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
- (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
- (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
- else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
- interfree Ts \<longrightarrow>
- (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
- else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
-apply(rule ann_transition_transition.induct [THEN conjunct1])
-apply safe
-prefer 11
-apply(rule TrueI)
-apply simp_all
---{* Basic *}
- apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
- apply(erule_tac x = "j" in allE , erule (1) notE impE)
- apply(simp add: interfree_def)
- apply(erule_tac x = "j" in allE,simp)
- apply(erule_tac x = "i" in allE,simp)
- apply(drule_tac t = "i" in not_sym)
- apply(case_tac "com(Ts ! j)=None")
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
- apply(simp add:interfree_aux_def)
- apply clarify
- apply simp
- apply(erule_tac x="pre y" in ballE)
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: com_validity_def SEM_def sem_def All_None_def)
- apply(simp add:assertions_lemma)
---{* Seqs *}
- apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
- apply(drule Parallel_Strong_Soundness_Seq,simp+)
- apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
- apply(drule Parallel_Strong_Soundness_Seq,simp+)
---{* Await *}
-apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
-apply(erule_tac x = "j" in allE , erule (1) notE impE)
-apply(simp add: interfree_def)
-apply(erule_tac x = "j" in allE,simp)
-apply(erule_tac x = "i" in allE,simp)
-apply(drule_tac t = "i" in not_sym)
-apply(case_tac "com(Ts ! j)=None")
- apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
- com_validity_def SEM_def sem_def All_None_def Help)
-apply(simp add:interfree_aux_def)
-apply clarify
-apply simp
-apply(erule_tac x="pre y" in ballE)
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: com_validity_def SEM_def sem_def All_None_def Help)
-apply(simp add:assertions_lemma)
-done
-
-lemma Parallel_Strong_Soundness_aux [rule_format]:
- "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t); Ts' = (Parallel Ts); interfree Ts;
- \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
- \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
- (if com(Rs ! j) = None then t\<in>post(Ts ! j)
- else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
-apply(erule rtrancl_induct2)
- apply clarify
---{* Base *}
- apply force
---{* Induction step *}
-apply clarify
-apply(drule Parallel_length_post_PStar)
-apply clarify
-apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
-apply(rule conjI)
- apply clarify
- apply(case_tac "i=j")
- apply(simp split del:split_if)
- apply(erule Strong_Soundness_aux_aux,simp+)
- apply force
- apply force
- apply(simp split del: split_if)
- apply(erule Parallel_Strong_Soundness_aux_aux)
- apply(simp_all add: split del:split_if)
- apply force
-apply(rule interfree_lemma)
-apply simp_all
-done
-
-lemma Parallel_Strong_Soundness:
- "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
- \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
- if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
-apply(drule Parallel_Strong_Soundness_aux)
-apply simp+
-done
-
-lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
-apply (unfold com_validity_def)
-apply(rule oghoare_induct)
-apply(rule TrueI)+
---{* Parallel *}
- apply(simp add: SEM_def sem_def)
- apply clarify
- apply(frule Parallel_length_post_PStar)
- apply clarify
- apply(drule_tac j=xb in Parallel_Strong_Soundness)
- apply clarify
- apply simp
- apply force
- apply simp
- apply(erule_tac V = "\<forall>i. ?P i" in thin_rl)
- apply(drule_tac s = "length Rs" in sym)
- apply(erule allE, erule impE, assumption)
- apply(force dest: nth_mem simp add: All_None_def)
---{* Basic *}
- apply(simp add: SEM_def sem_def)
- apply(force dest: rtrancl_imp_UN_rel_pow Basic_ntran)
---{* Seq *}
- apply(rule subset_trans)
- prefer 2 apply assumption
- apply(simp add: L3_5ii L3_5i)
---{* Cond *}
- apply(simp add: L3_5iv)
---{* While *}
- apply(simp add: L3_5v)
- apply (blast dest: SEM_fwhile)
---{* Conseq *}
-apply(auto simp add: SEM_def sem_def)
-done
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Syntax.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,140 +0,0 @@
-theory OG_Syntax
-imports OG_Tactics Quote_Antiquote
-begin
-
-text{* Syntax for commands and for assertions and boolean expressions in
- commands @{text com} and annotated commands @{text ann_com}. *}
-
-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>"
-
-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"
- ("_ //IF _ /THEN _ /FI" [90,0,0] 61)
- "_AnnWhile" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
- ("_ //WHILE _ /INV _ //DO _//OD" [90,0,0,0] 61)
- "_AnnAwait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a ann_com"
- ("_ //AWAIT _ /THEN /_ /END" [90,0,0] 61)
- "_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)
- "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
- ("(0WHILE _/ INV _ //DO _ /OD)" [0, 0, 0] 61)
- "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"
- ("(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 c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
- "WHILE b INV i DO c OD" \<rightharpoonup> "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 WAIT b END" \<rightleftharpoons> "r AWAIT b THEN SKIP END"
-
-nonterminals
- prgs
-
-syntax
- "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" [57] 56)
- "_prg" :: "['a, 'a] \<Rightarrow> prgs" ("_//_" [60, 90] 57)
- "_prgs" :: "['a, 'a, prgs] \<Rightarrow> prgs" ("_//_//\<parallel>//_" [60,90,57] 57)
-
- "_prg_scheme" :: "['a, 'a, 'a, 'a, 'a] \<Rightarrow> prgs"
- ("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_scheme j i k c q" \<rightleftharpoons> "map (\<lambda>i. (Some c, q)) [j..<k]"
-
-print_translation {*
- let
- fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_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)
- | annquote_tr' _ _ = raise Match;
-
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
-
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
- quote_tr' (Syntax.const name) (t :: ts)
- | bexp_tr' _ _ = raise Match;
-
- fun annbexp_tr' name (r :: (Const ("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
- | K_tr' _ = raise Match;
-
- fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ 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)
- (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])
- | Parallel_PAR _ = raise Match;
-
-fun Parallel_tr' ts = 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
-
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Tactics.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,496 +0,0 @@
-header {* \section{Generation of Verification Conditions} *}
-
-theory OG_Tactics
-imports OG_Hoare
-begin
-
-lemmas ann_hoare_intros=AnnBasic AnnSeq AnnCond1 AnnCond2 AnnWhile AnnAwait AnnConseq
-lemmas oghoare_intros=Parallel Basic Seq Cond While Conseq
-
-lemma ParallelConseqRule:
- "\<lbrakk> p \<subseteq> (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))));
- \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))))
- (Parallel Ts)
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i));
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i)) \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (Parallel Ts) q"
-apply (rule Conseq)
-prefer 2
- apply fast
-apply assumption+
-done
-
-lemma SkipRule: "p \<subseteq> q \<Longrightarrow> \<parallel>- p (Basic id) q"
-apply(rule oghoare_intros)
- prefer 2 apply(rule Basic)
- prefer 2 apply(rule subset_refl)
-apply(simp add:Id_def)
-done
-
-lemma BasicRule: "p \<subseteq> {s. (f s)\<in>q} \<Longrightarrow> \<parallel>- p (Basic f) q"
-apply(rule oghoare_intros)
- prefer 2 apply(rule oghoare_intros)
- prefer 2 apply(rule subset_refl)
-apply assumption
-done
-
-lemma SeqRule: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q"
-apply(rule Seq)
-apply fast+
-done
-
-lemma CondRule:
- "\<lbrakk> p \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>w) \<and> (s\<notin>b \<longrightarrow> s\<in>w')}; \<parallel>- w c1 q; \<parallel>- w' c2 q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
-apply(rule Cond)
- apply(rule Conseq)
- prefer 4 apply(rule Conseq)
-apply simp_all
-apply force+
-done
-
-lemma WhileRule: "\<lbrakk> p \<subseteq> i; \<parallel>- (i \<inter> b) c i ; (i \<inter> (-b)) \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (While b i c) q"
-apply(rule Conseq)
- prefer 2 apply(rule While)
-apply assumption+
-done
-
-text {* Three new proof rules for special instances of the @{text
-AnnBasic} and the @{text AnnAwait} commands when the transformation
-performed on the state is the identity, and for an @{text AnnAwait}
-command where the boolean condition is @{text "{s. True}"}: *}
-
-lemma AnnatomRule:
- "\<lbrakk> atom_com(c); \<parallel>- r c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r {s. True} c) q"
-apply(rule AnnAwait)
-apply simp_all
-done
-
-lemma AnnskipRule:
- "r \<subseteq> q \<Longrightarrow> \<turnstile> (AnnBasic r id) q"
-apply(rule AnnBasic)
-apply simp
-done
-
-lemma AnnwaitRule:
- "\<lbrakk> (r \<inter> b) \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b (Basic id)) q"
-apply(rule AnnAwait)
- apply simp
-apply(rule BasicRule)
-apply simp
-done
-
-text {* Lemmata to avoid using the definition of @{text
-map_ann_hoare}, @{text interfree_aux}, @{text interfree_swap} and
-@{text interfree} by splitting it into different cases: *}
-
-lemma interfree_aux_rule1: "interfree_aux(co, q, None)"
-by(simp add:interfree_aux_def)
-
-lemma interfree_aux_rule2:
- "\<forall>(R,r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<Longrightarrow> interfree_aux(None, q, Some a)"
-apply(simp add:interfree_aux_def)
-apply(force elim:oghoare_sound)
-done
-
-lemma interfree_aux_rule3:
- "(\<forall>(R, r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<and> (\<forall>p\<in>(assertions c). \<parallel>- (p \<inter> R) r p))
- \<Longrightarrow> interfree_aux(Some c, q, Some a)"
-apply(simp add:interfree_aux_def)
-apply(force elim:oghoare_sound)
-done
-
-lemma AnnBasic_assertions:
- "\<lbrakk>interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk> \<Longrightarrow>
- interfree_aux(Some (AnnBasic r f), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnSeq_assertions:
- "\<lbrakk> interfree_aux(Some c1, q, Some a); interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnSeq c1 c2), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond1_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c1, q, Some a);
- interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some(AnnCond1 r b c1 c2), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond2_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnCond2 r b c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnWhile_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, i, Some a);
- interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnWhile r b i c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnAwait_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnAwait r b c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnBasic_atomics:
- "\<parallel>- (q \<inter> r) (Basic f) q \<Longrightarrow> interfree_aux(None, q, Some (AnnBasic r f))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-lemma AnnSeq_atomics:
- "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
- interfree_aux(Any, q, Some (AnnSeq a1 a2))"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond1_atomics:
- "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
- interfree_aux(Any, q, Some (AnnCond1 r b a1 a2))"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond2_atomics:
- "interfree_aux (Any, q, Some a)\<Longrightarrow> interfree_aux(Any, q, Some (AnnCond2 r b a))"
-by(simp add: interfree_aux_def)
-
-lemma AnnWhile_atomics: "interfree_aux (Any, q, Some a)
- \<Longrightarrow> interfree_aux(Any, q, Some (AnnWhile r b i a))"
-by(simp add: interfree_aux_def)
-
-lemma Annatom_atomics:
- "\<parallel>- (q \<inter> r) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r {x. True} a))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-lemma AnnAwait_atomics:
- "\<parallel>- (q \<inter> (r \<inter> b)) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r b a))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-constdefs
- interfree_swap :: "('a ann_triple_op * ('a ann_triple_op) list) \<Rightarrow> bool"
- "interfree_swap == \<lambda>(x, xs). \<forall>y\<in>set xs. interfree_aux (com x, post x, com y)
- \<and> interfree_aux(com y, post y, com x)"
-
-lemma interfree_swap_Empty: "interfree_swap (x, [])"
-by(simp add:interfree_swap_def)
-
-lemma interfree_swap_List:
- "\<lbrakk> interfree_aux (com x, post x, com y);
- interfree_aux (com y, post y ,com x); interfree_swap (x, xs) \<rbrakk>
- \<Longrightarrow> interfree_swap (x, y#xs)"
-by(simp add:interfree_swap_def)
-
-lemma interfree_swap_Map: "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> interfree_aux (com x, post x, c k)
- \<and> interfree_aux (c k, Q k, com x)
- \<Longrightarrow> interfree_swap (x, map (\<lambda>k. (c k, Q k)) [i..<j])"
-by(force simp add: interfree_swap_def less_diff_conv)
-
-lemma interfree_Empty: "interfree []"
-by(simp add:interfree_def)
-
-lemma interfree_List:
- "\<lbrakk> interfree_swap(x, xs); interfree xs \<rbrakk> \<Longrightarrow> interfree (x#xs)"
-apply(simp add:interfree_def interfree_swap_def)
-apply clarify
-apply(case_tac i)
- apply(case_tac j)
- apply simp_all
-apply(case_tac j,simp+)
-done
-
-lemma interfree_Map:
- "(\<forall>i j. a\<le>i \<and> i<b \<and> a\<le>j \<and> j<b \<and> i\<noteq>j \<longrightarrow> interfree_aux (c i, Q i, c j))
- \<Longrightarrow> interfree (map (\<lambda>k. (c k, Q k)) [a..<b])"
-by(force simp add: interfree_def less_diff_conv)
-
-constdefs map_ann_hoare :: "(('a ann_com_op * 'a assn) list) \<Rightarrow> bool " ("[\<turnstile>] _" [0] 45)
- "[\<turnstile>] Ts == (\<forall>i<length Ts. \<exists>c q. Ts!i=(Some c, q) \<and> \<turnstile> c q)"
-
-lemma MapAnnEmpty: "[\<turnstile>] []"
-by(simp add:map_ann_hoare_def)
-
-lemma MapAnnList: "\<lbrakk> \<turnstile> c q ; [\<turnstile>] xs \<rbrakk> \<Longrightarrow> [\<turnstile>] (Some c,q)#xs"
-apply(simp add:map_ann_hoare_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma MapAnnMap:
- "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> \<turnstile> (c k) (Q k) \<Longrightarrow> [\<turnstile>] map (\<lambda>k. (Some (c k), Q k)) [i..<j]"
-apply(simp add: map_ann_hoare_def less_diff_conv)
-done
-
-lemma ParallelRule:"\<lbrakk> [\<turnstile>] Ts ; interfree Ts \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
- Parallel Ts
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
-apply(rule Parallel)
- apply(simp add:map_ann_hoare_def)
-apply simp
-done
-(*
-lemma ParamParallelRule:
- "\<lbrakk> \<forall>k<n. \<turnstile> (c k) (Q k);
- \<forall>k l. k<n \<and> l<n \<and> k\<noteq>l \<longrightarrow> interfree_aux (Some(c k), Q k, Some(c l)) \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<n} . pre(c i)) COBEGIN SCHEME [0\<le>i<n] (c i) (Q i) COEND (\<Inter>i\<in>{i. i<n} . Q i )"
-apply(rule ParallelConseqRule)
- apply simp
- apply clarify
- apply force
- apply(rule ParallelRule)
- apply(rule MapAnnMap)
- apply simp
- apply(rule interfree_Map)
- apply simp
-apply simp
-apply clarify
-apply force
-done
-*)
-
-text {* The following are some useful lemmas and simplification
-tactics to control which theorems are used to simplify at each moment,
-so that the original input does not suffer any unexpected
-transformation. *}
-
-lemma Compl_Collect: "-(Collect b) = {x. \<not>(b x)}"
-by fast
-lemma list_length: "length []=0 \<and> length (x#xs) = Suc(length xs)"
-by simp
-lemma list_lemmas: "length []=0 \<and> length (x#xs) = Suc(length xs)
-\<and> (x#xs) ! 0=x \<and> (x#xs) ! Suc n = xs ! n"
-by simp
-lemma le_Suc_eq_insert: "{i. i <Suc n} = insert n {i. i< n}"
-by auto
-lemmas primrecdef_list = "pre.simps" "assertions.simps" "atomics.simps" "atom_com.simps"
-lemmas my_simp_list = list_lemmas fst_conv snd_conv
-not_less0 refl le_Suc_eq_insert Suc_not_Zero Zero_not_Suc nat.inject
-Collect_mem_eq ball_simps option.simps primrecdef_list
-lemmas ParallelConseq_list = INTER_def Collect_conj_eq length_map length_upt length_append list_length
-
-ML {*
-val before_interfree_simp_tac = (simp_tac (HOL_basic_ss addsimps [thm "com.simps", thm "post.simps"]))
-
-val interfree_simp_tac = (asm_simp_tac (HOL_ss addsimps [thm "split", thm "ball_Un", thm "ball_empty"]@(thms "my_simp_list")))
-
-val ParallelConseq = (simp_tac (HOL_basic_ss addsimps (thms "ParallelConseq_list")@(thms "my_simp_list")))
-*}
-
-text {* The following tactic applies @{text tac} to each conjunct in a
-subgoal of the form @{text "A \<Longrightarrow> a1 \<and> a2 \<and> .. \<and> an"} returning
-@{text n} subgoals, one for each conjunct: *}
-
-ML {*
-fun conjI_Tac tac i st = st |>
- ( (EVERY [rtac conjI i,
- conjI_Tac tac (i+1),
- tac i]) ORELSE (tac i) )
-*}
-
-
-subsubsection {* Tactic for the generation of the verification conditions *}
-
-text {* The tactic basically uses two subtactics:
-
-\begin{description}
-
-\item[HoareRuleTac] is called at the level of parallel programs, it
- uses the ParallelTac to solve parallel composition of programs.
- This verification has two parts, namely, (1) all component programs are
- correct and (2) they are interference free. @{text HoareRuleTac} is
- also called at the level of atomic regions, i.e. @{text "\<langle> \<rangle>"} and
- @{text "AWAIT b THEN _ END"}, and at each interference freedom test.
-
-\item[AnnHoareRuleTac] is for component programs which
- are annotated programs and so, there are not unknown assertions
- (no need to use the parameter precond, see NOTE).
-
- NOTE: precond(::bool) informs if the subgoal has the form @{text "\<parallel>- ?p c q"},
- in this case we have precond=False and the generated verification
- condition would have the form @{text "?p \<subseteq> \<dots>"} which can be solved by
- @{text "rtac subset_refl"}, if True we proceed to simplify it using
- the simplification tactics above.
-
-\end{description}
-*}
-
-ML {*
-
- fun WlpTac i = (rtac (@{thm SeqRule}) i) THEN (HoareRuleTac false (i+1))
-and HoareRuleTac precond i st = st |>
- ( (WlpTac i THEN HoareRuleTac precond i)
- ORELSE
- (FIRST[rtac (@{thm SkipRule}) i,
- rtac (@{thm BasicRule}) i,
- EVERY[rtac (@{thm ParallelConseqRule}) i,
- ParallelConseq (i+2),
- ParallelTac (i+1),
- ParallelConseq i],
- EVERY[rtac (@{thm CondRule}) i,
- HoareRuleTac false (i+2),
- HoareRuleTac false (i+1)],
- EVERY[rtac (@{thm WhileRule}) i,
- HoareRuleTac true (i+1)],
- K all_tac i ]
- THEN (if precond then (K all_tac i) else (rtac (@{thm subset_refl}) i))))
-
-and AnnWlpTac i = (rtac (@{thm AnnSeq}) i) THEN (AnnHoareRuleTac (i+1))
-and AnnHoareRuleTac i st = st |>
- ( (AnnWlpTac i THEN AnnHoareRuleTac i )
- ORELSE
- (FIRST[(rtac (@{thm AnnskipRule}) i),
- EVERY[rtac (@{thm AnnatomRule}) i,
- HoareRuleTac true (i+1)],
- (rtac (@{thm AnnwaitRule}) i),
- rtac (@{thm AnnBasic}) i,
- EVERY[rtac (@{thm AnnCond1}) i,
- AnnHoareRuleTac (i+3),
- AnnHoareRuleTac (i+1)],
- EVERY[rtac (@{thm AnnCond2}) i,
- AnnHoareRuleTac (i+1)],
- EVERY[rtac (@{thm AnnWhile}) i,
- AnnHoareRuleTac (i+2)],
- EVERY[rtac (@{thm AnnAwait}) i,
- HoareRuleTac true (i+1)],
- K all_tac i]))
-
-and ParallelTac i = EVERY[rtac (@{thm ParallelRule}) i,
- interfree_Tac (i+1),
- MapAnn_Tac i]
-
-and MapAnn_Tac i st = st |>
- (FIRST[rtac (@{thm MapAnnEmpty}) i,
- EVERY[rtac (@{thm MapAnnList}) i,
- MapAnn_Tac (i+1),
- AnnHoareRuleTac i],
- EVERY[rtac (@{thm MapAnnMap}) i,
- rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- AnnHoareRuleTac i]])
-
-and interfree_swap_Tac i st = st |>
- (FIRST[rtac (@{thm interfree_swap_Empty}) i,
- EVERY[rtac (@{thm interfree_swap_List}) i,
- interfree_swap_Tac (i+2),
- interfree_aux_Tac (i+1),
- interfree_aux_Tac i ],
- EVERY[rtac (@{thm interfree_swap_Map}) i,
- rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- conjI_Tac (interfree_aux_Tac) i]])
-
-and interfree_Tac i st = st |>
- (FIRST[rtac (@{thm interfree_Empty}) i,
- EVERY[rtac (@{thm interfree_List}) i,
- interfree_Tac (i+1),
- interfree_swap_Tac i],
- EVERY[rtac (@{thm interfree_Map}) i,
- rtac (@{thm allI}) i,rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- interfree_aux_Tac i ]])
-
-and interfree_aux_Tac i = (before_interfree_simp_tac i ) THEN
- (FIRST[rtac (@{thm interfree_aux_rule1}) i,
- dest_assertions_Tac i])
-
-and dest_assertions_Tac i st = st |>
- (FIRST[EVERY[rtac (@{thm AnnBasic_assertions}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnSeq_assertions}) i,
- dest_assertions_Tac (i+1),
- dest_assertions_Tac i],
- EVERY[rtac (@{thm AnnCond1_assertions}) i,
- dest_assertions_Tac (i+2),
- dest_assertions_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond2_assertions}) i,
- dest_assertions_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnWhile_assertions}) i,
- dest_assertions_Tac (i+2),
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnAwait_assertions}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- dest_atomics_Tac i])
-
-and dest_atomics_Tac i st = st |>
- (FIRST[EVERY[rtac (@{thm AnnBasic_atomics}) i,
- HoareRuleTac true i],
- EVERY[rtac (@{thm AnnSeq_atomics}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond1_atomics}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond2_atomics}) i,
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnWhile_atomics}) i,
- dest_atomics_Tac i],
- EVERY[rtac (@{thm Annatom_atomics}) i,
- HoareRuleTac true i],
- EVERY[rtac (@{thm AnnAwait_atomics}) i,
- HoareRuleTac true i],
- K all_tac i])
-*}
-
-
-text {* The final tactic is given the name @{text oghoare}: *}
-
-ML {*
-val oghoare_tac = SUBGOAL (fn (_, i) =>
- (HoareRuleTac true i))
-*}
-
-text {* Notice that the tactic for parallel programs @{text
-"oghoare_tac"} is initially invoked with the value @{text true} for
-the parameter @{text precond}.
-
-Parts of the tactic can be also individually used to generate the
-verification conditions for annotated sequential programs and to
-generate verification conditions out of interference freedom tests: *}
-
-ML {* val annhoare_tac = SUBGOAL (fn (_, i) =>
- (AnnHoareRuleTac i))
-
-val interfree_aux_tac = SUBGOAL (fn (_, i) =>
- (interfree_aux_Tac i))
-*}
-
-text {* The so defined ML tactics are then ``exported'' to be used in
-Isabelle proofs. *}
-
-method_setup oghoare = {*
- Scan.succeed (K (SIMPLE_METHOD' oghoare_tac)) *}
- "verification condition generator for the oghoare logic"
-
-method_setup annhoare = {*
- Scan.succeed (K (SIMPLE_METHOD' annhoare_tac)) *}
- "verification condition generator for the ann_hoare logic"
-
-method_setup interfree_aux = {*
- Scan.succeed (K (SIMPLE_METHOD' interfree_aux_tac)) *}
- "verification condition generator for interference freedom tests"
-
-text {* Tactics useful for dealing with the generated verification conditions: *}
-
-method_setup conjI_tac = {*
- Scan.succeed (K (SIMPLE_METHOD' (conjI_Tac (K all_tac)))) *}
- "verification condition generator for interference freedom tests"
-
-ML {*
-fun disjE_Tac tac i st = st |>
- ( (EVERY [etac disjE i,
- disjE_Tac tac (i+1),
- tac i]) ORELSE (tac i) )
-*}
-
-method_setup disjE_tac = {*
- Scan.succeed (K (SIMPLE_METHOD' (disjE_Tac (K all_tac)))) *}
- "verification condition generator for interference freedom tests"
-
-end
--- a/src/HOL/HoareParallel/OG_Tran.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,309 +0,0 @@
-
-header {* \section{Operational Semantics} *}
-
-theory OG_Tran imports OG_Com begin
-
-types
- 'a ann_com_op = "('a ann_com) option"
- 'a ann_triple_op = "('a ann_com_op \<times> 'a assn)"
-
-consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
-primrec "com (c, q) = c"
-
-consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
-primrec "post (c, q) = q"
-
-constdefs
- All_None :: "'a ann_triple_op list \<Rightarrow> bool"
- "All_None Ts \<equiv> \<forall>(c, q) \<in> set Ts. c = None"
-
-subsection {* The Transition Relation *}
-
-inductive_set
- ann_transition :: "(('a ann_com_op \<times> 'a) \<times> ('a ann_com_op \<times> 'a)) set"
- and transition :: "(('a com \<times> 'a) \<times> ('a com \<times> 'a)) set"
- and ann_transition' :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
- ("_ -1\<rightarrow> _"[81,81] 100)
- and transition' :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P1\<rightarrow> _"[81,81] 100)
- and transitions :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P*\<rightarrow> _"[81,81] 100)
-where
- "con_0 -1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition"
-| "con_0 -P1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition"
-| "con_0 -P*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition\<^sup>*"
-
-| AnnBasic: "(Some (AnnBasic r f), s) -1\<rightarrow> (None, f s)"
-
-| AnnSeq1: "(Some c0, s) -1\<rightarrow> (None, t) \<Longrightarrow>
- (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some c1, t)"
-| AnnSeq2: "(Some c0, s) -1\<rightarrow> (Some c2, t) \<Longrightarrow>
- (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some (AnnSeq c2 c1), t)"
-
-| AnnCond1T: "s \<in> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c1, s)"
-| AnnCond1F: "s \<notin> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c2, s)"
-
-| AnnCond2T: "s \<in> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (Some c, s)"
-| AnnCond2F: "s \<notin> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (None, s)"
-
-| AnnWhileF: "s \<notin> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow> (None, s)"
-| AnnWhileT: "s \<in> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow>
- (Some (AnnSeq c (AnnWhile i b i c)), s)"
-
-| AnnAwait: "\<lbrakk> s \<in> b; atom_com c; (c, s) -P*\<rightarrow> (Parallel [], t) \<rbrakk> \<Longrightarrow>
- (Some (AnnAwait r b c), s) -1\<rightarrow> (None, t)"
-
-| Parallel: "\<lbrakk> i<length Ts; Ts!i = (Some c, q); (Some c, s) -1\<rightarrow> (r, t) \<rbrakk>
- \<Longrightarrow> (Parallel Ts, s) -P1\<rightarrow> (Parallel (Ts [i:=(r, q)]), t)"
-
-| Basic: "(Basic f, s) -P1\<rightarrow> (Parallel [], f s)"
-
-| Seq1: "All_None Ts \<Longrightarrow> (Seq (Parallel Ts) c, s) -P1\<rightarrow> (c, s)"
-| Seq2: "(c0, s) -P1\<rightarrow> (c2, t) \<Longrightarrow> (Seq c0 c1, s) -P1\<rightarrow> (Seq c2 c1, t)"
-
-| CondT: "s \<in> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c1, s)"
-| CondF: "s \<notin> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c2, s)"
-
-| WhileF: "s \<notin> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Parallel [], s)"
-| WhileT: "s \<in> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Seq c (While b i c), s)"
-
-monos "rtrancl_mono"
-
-text {* The corresponding syntax translations are: *}
-
-abbreviation
- ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
- \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
- "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
-
-abbreviation
- ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
- ("_ -*\<rightarrow> _"[81,81] 100) where
- "con_0 -*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition\<^sup>*"
-
-abbreviation
- transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P_\<rightarrow> _"[81,81,81] 100) where
- "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
-
-subsection {* Definition of Semantics *}
-
-constdefs
- ann_sem :: "'a ann_com \<Rightarrow> 'a \<Rightarrow> 'a set"
- "ann_sem c \<equiv> \<lambda>s. {t. (Some c, s) -*\<rightarrow> (None, t)}"
-
- ann_SEM :: "'a ann_com \<Rightarrow> 'a set \<Rightarrow> 'a set"
- "ann_SEM c S \<equiv> \<Union>ann_sem c ` S"
-
- sem :: "'a com \<Rightarrow> 'a \<Rightarrow> 'a set"
- "sem c \<equiv> \<lambda>s. {t. \<exists>Ts. (c, s) -P*\<rightarrow> (Parallel Ts, t) \<and> All_None Ts}"
-
- 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)"
-
-consts fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com"
-primrec
- "fwhile b c 0 = \<Omega>"
- "fwhile b c (Suc n) = Cond b (Seq c (fwhile b c n)) (Basic id)"
-
-subsubsection {* Proofs *}
-
-declare ann_transition_transition.intros [intro]
-inductive_cases transition_cases:
- "(Parallel T,s) -P1\<rightarrow> t"
- "(Basic f, s) -P1\<rightarrow> t"
- "(Seq c1 c2, s) -P1\<rightarrow> t"
- "(Cond b c1 c2, s) -P1\<rightarrow> t"
- "(While b i c, s) -P1\<rightarrow> t"
-
-lemma Parallel_empty_lemma [rule_format (no_asm)]:
- "(Parallel [],s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=[] \<and> n=0 \<and> s=t"
-apply(induct n)
- apply(simp (no_asm))
-apply clarify
-apply(drule rel_pow_Suc_D2)
-apply(force elim:transition_cases)
-done
-
-lemma Parallel_AllNone_lemma [rule_format (no_asm)]:
- "All_None Ss \<longrightarrow> (Parallel Ss,s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=Ss \<and> n=0 \<and> s=t"
-apply(induct "n")
- apply(simp (no_asm))
-apply clarify
-apply(drule rel_pow_Suc_D2)
-apply clarify
-apply(erule transition_cases,simp_all)
-apply(force dest:nth_mem simp add:All_None_def)
-done
-
-lemma Parallel_AllNone: "All_None Ts \<Longrightarrow> (SEM (Parallel Ts) X) = X"
-apply (unfold SEM_def sem_def)
-apply auto
-apply(drule rtrancl_imp_UN_rel_pow)
-apply clarify
-apply(drule Parallel_AllNone_lemma)
-apply auto
-done
-
-lemma Parallel_empty: "Ts=[] \<Longrightarrow> (SEM (Parallel Ts) X) = X"
-apply(rule Parallel_AllNone)
-apply(simp add:All_None_def)
-done
-
-text {* Set of lemmas from Apt and Olderog "Verification of sequential
-and concurrent programs", page 63. *}
-
-lemma L3_5i: "X\<subseteq>Y \<Longrightarrow> SEM c X \<subseteq> SEM c Y"
-apply (unfold SEM_def)
-apply force
-done
-
-lemma L3_5ii_lemma1:
- "\<lbrakk> (c1, s1) -P*\<rightarrow> (Parallel Ts, s2); All_None Ts;
- (c2, s2) -P*\<rightarrow> (Parallel Ss, s3); All_None Ss \<rbrakk>
- \<Longrightarrow> (Seq c1 c2, s1) -P*\<rightarrow> (Parallel Ss, s3)"
-apply(erule converse_rtrancl_induct2)
-apply(force intro:converse_rtrancl_into_rtrancl)+
-done
-
-lemma L3_5ii_lemma2 [rule_format (no_asm)]:
- "\<forall>c1 c2 s t. (Seq c1 c2, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow>
- (All_None Ts) \<longrightarrow> (\<exists>y m Rs. (c1,s) -P*\<rightarrow> (Parallel Rs, y) \<and>
- (All_None Rs) \<and> (c2, y) -Pm\<rightarrow> (Parallel Ts, t) \<and> m \<le> n)"
-apply(induct "n")
- apply(force)
-apply(safe dest!: rel_pow_Suc_D2)
-apply(erule transition_cases,simp_all)
- apply (fast intro!: le_SucI)
-apply (fast intro!: le_SucI elim!: rel_pow_imp_rtrancl converse_rtrancl_into_rtrancl)
-done
-
-lemma L3_5ii_lemma3:
- "\<lbrakk>(Seq c1 c2,s) -P*\<rightarrow> (Parallel Ts,t); All_None Ts\<rbrakk> \<Longrightarrow>
- (\<exists>y Rs. (c1,s) -P*\<rightarrow> (Parallel Rs,y) \<and> All_None Rs
- \<and> (c2,y) -P*\<rightarrow> (Parallel Ts,t))"
-apply(drule rtrancl_imp_UN_rel_pow)
-apply(fast dest: L3_5ii_lemma2 rel_pow_imp_rtrancl)
-done
-
-lemma L3_5ii: "SEM (Seq c1 c2) X = SEM c2 (SEM c1 X)"
-apply (unfold SEM_def sem_def)
-apply auto
- apply(fast dest: L3_5ii_lemma3)
-apply(fast elim: L3_5ii_lemma1)
-done
-
-lemma L3_5iii: "SEM (Seq (Seq c1 c2) c3) X = SEM (Seq c1 (Seq c2 c3)) X"
-apply (simp (no_asm) add: L3_5ii)
-done
-
-lemma L3_5iv:
- "SEM (Cond b c1 c2) X = (SEM c1 (X \<inter> b)) Un (SEM c2 (X \<inter> (-b)))"
-apply (unfold SEM_def sem_def)
-apply auto
-apply(erule converse_rtranclE)
- prefer 2
- apply (erule transition_cases,simp_all)
- apply(fast intro: converse_rtrancl_into_rtrancl elim: transition_cases)+
-done
-
-
-lemma L3_5v_lemma1[rule_format]:
- "(S,s) -Pn\<rightarrow> (T,t) \<longrightarrow> S=\<Omega> \<longrightarrow> (\<not>(\<exists>Rs. T=(Parallel Rs) \<and> All_None Rs))"
-apply (unfold UNIV_def)
-apply(rule nat_less_induct)
-apply safe
-apply(erule rel_pow_E2)
- apply simp_all
-apply(erule transition_cases)
- apply simp_all
-apply(erule rel_pow_E2)
- apply(simp add: Id_def)
-apply(erule transition_cases,simp_all)
-apply clarify
-apply(erule transition_cases,simp_all)
-apply(erule rel_pow_E2,simp)
-apply clarify
-apply(erule transition_cases)
- apply simp+
- apply clarify
- apply(erule transition_cases)
-apply simp_all
-done
-
-lemma L3_5v_lemma2: "\<lbrakk>(\<Omega>, s) -P*\<rightarrow> (Parallel Ts, t); All_None Ts \<rbrakk> \<Longrightarrow> False"
-apply(fast dest: rtrancl_imp_UN_rel_pow L3_5v_lemma1)
-done
-
-lemma L3_5v_lemma3: "SEM (\<Omega>) S = {}"
-apply (unfold SEM_def sem_def)
-apply(fast dest: L3_5v_lemma2)
-done
-
-lemma L3_5v_lemma4 [rule_format]:
- "\<forall>s. (While b i c, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
- (\<exists>k. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t))"
-apply(rule nat_less_induct)
-apply safe
-apply(erule rel_pow_E2)
- apply safe
-apply(erule transition_cases,simp_all)
- apply (rule_tac x = "1" in exI)
- apply(force dest: Parallel_empty_lemma intro: converse_rtrancl_into_rtrancl simp add: Id_def)
-apply safe
-apply(drule L3_5ii_lemma2)
- apply safe
-apply(drule le_imp_less_Suc)
-apply (erule allE , erule impE,assumption)
-apply (erule allE , erule impE, assumption)
-apply safe
-apply (rule_tac x = "k+1" in exI)
-apply(simp (no_asm))
-apply(rule converse_rtrancl_into_rtrancl)
- apply fast
-apply(fast elim: L3_5ii_lemma1)
-done
-
-lemma L3_5v_lemma5 [rule_format]:
- "\<forall>s. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
- (While b i c, s) -P*\<rightarrow> (Parallel Ts,t)"
-apply(induct "k")
- apply(force dest: L3_5v_lemma2)
-apply safe
-apply(erule converse_rtranclE)
- apply simp_all
-apply(erule transition_cases,simp_all)
- apply(rule converse_rtrancl_into_rtrancl)
- apply(fast)
- apply(fast elim!: L3_5ii_lemma1 dest: L3_5ii_lemma3)
-apply(drule rtrancl_imp_UN_rel_pow)
-apply clarify
-apply(erule rel_pow_E2)
- apply simp_all
-apply(erule transition_cases,simp_all)
-apply(fast dest: Parallel_empty_lemma)
-done
-
-lemma L3_5v: "SEM (While b i c) = (\<lambda>x. (\<Union>k. SEM (fwhile b c k) x))"
-apply(rule ext)
-apply (simp add: SEM_def sem_def)
-apply safe
- apply(drule rtrancl_imp_UN_rel_pow,simp)
- apply clarify
- apply(fast dest:L3_5v_lemma4)
-apply(fast intro: L3_5v_lemma5)
-done
-
-section {* Validity of Correctness Formulas *}
-
-constdefs
- com_validity :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>= _// _//_)" [90,55,90] 50)
- "\<parallel>= p c q \<equiv> SEM c p \<subseteq> q"
-
- ann_com_validity :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> _ _" [60,90] 45)
- "\<Turnstile> c q \<equiv> ann_SEM c (pre c) \<subseteq> q"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/Quote_Antiquote.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-
-header {* \section{Concrete Syntax} *}
-
-theory Quote_Antiquote imports Main begin
-
-syntax
- "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
- "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b" ("\<acute>_" [1000] 1000)
- "_Assert" :: "'a \<Rightarrow> 'a set" ("(.{_}.)" [0] 1000)
-
-syntax (xsymbols)
- "_Assert" :: "'a \<Rightarrow> 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
-
-translations
- ".{b}." \<rightharpoonup> "Collect \<guillemotleft>b\<guillemotright>"
-
-parse_translation {*
- let
- fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
- | quote_tr ts = raise TERM ("quote_tr", ts);
- in [("_quote", quote_tr)] end
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Com.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,25 +0,0 @@
-
-header {* \chapter{The Rely-Guarantee Method}
-
-\section {Abstract Syntax}
-*}
-
-theory RG_Com imports Main begin
-
-text {* Semantics of assertions and boolean expressions (bexp) as sets
-of states. Syntax of commands @{text com} and parallel commands
-@{text par_com}. *}
-
-types
- 'a bexp = "'a set"
-
-datatype 'a com =
- Basic "'a \<Rightarrow>'a"
- | Seq "'a com" "'a com"
- | Cond "'a bexp" "'a com" "'a com"
- | While "'a bexp" "'a com"
- | Await "'a bexp" "'a com"
-
-types 'a par_com = "(('a com) option) list"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Examples.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,359 +0,0 @@
-header {* \section{Examples} *}
-
-theory RG_Examples
-imports RG_Syntax
-begin
-
-lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def
-
-subsection {* Set Elements of an Array to Zero *}
-
-lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
-by simp
-
-lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
-by simp
-
-record Example1 =
- A :: "nat list"
-
-lemma Example1:
- "\<turnstile> COBEGIN
- SCHEME [0 \<le> i < n]
- (\<acute>A := \<acute>A [i := 0],
- \<lbrace> n < length \<acute>A \<rbrace>,
- \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
- \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
- \<lbrace> \<acute>A ! i = 0 \<rbrace>)
- COEND
- SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
-apply(rule Parallel)
-apply (auto intro!: Basic)
-done
-
-lemma Example1_parameterized:
-"k < t \<Longrightarrow>
- \<turnstile> COBEGIN
- SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
- \<lbrace>t*n < length \<acute>A\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
- \<lbrace>\<acute>A!i=0\<rbrace>)
- COEND
- SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
- (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
- \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
-apply(rule Parallel)
- apply auto
- apply(erule_tac x="k*n +i" in allE)
- apply(subgoal_tac "k*n+i <length (A b)")
- apply force
- apply(erule le_less_trans2)
- apply(case_tac t,simp+)
- apply (simp add:add_commute)
- apply(simp add: add_le_mono)
-apply(rule Basic)
- apply simp
- apply clarify
- apply (subgoal_tac "k*n+i< length (A x)")
- apply simp
- apply(erule le_less_trans2)
- apply(case_tac t,simp+)
- apply (simp add:add_commute)
- apply(rule add_le_mono, auto)
-done
-
-
-subsection {* Increment a Variable in Parallel *}
-
-subsubsection {* Two components *}
-
-record Example2 =
- x :: nat
- c_0 :: nat
- c_1 :: nat
-
-lemma Example2:
- "\<turnstile> COBEGIN
- (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=0\<rbrace>,
- \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
- \<parallel>
- (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
- \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
- COEND
- SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
- \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and> \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
- \<lbrace>True\<rbrace>,
- \<lbrace>\<acute>x=2\<rbrace>]"
-apply(rule Parallel)
- apply simp_all
- apply clarify
- apply(case_tac i)
- apply simp
- apply(rule conjI)
- apply clarify
- apply simp
- apply clarify
- apply simp
- apply(case_tac j,simp)
- apply simp
- apply simp
- apply(rule conjI)
- apply clarify
- apply simp
- apply clarify
- apply simp
- apply(subgoal_tac "j=0")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply arith
- apply clarify
- apply(case_tac i,simp,simp)
- apply clarify
- apply simp
- apply(erule_tac x=0 in all_dupE)
- apply(erule_tac x=1 in allE,simp)
-apply clarify
-apply(case_tac i,simp)
- apply(rule Await)
- apply simp_all
- apply(clarify)
- apply(rule Seq)
- prefer 2
- apply(rule Basic)
- apply simp_all
- apply(rule subset_refl)
- apply(rule Basic)
- apply simp_all
- apply clarify
- apply simp
-apply(rule Await)
- apply simp_all
-apply(clarify)
-apply(rule Seq)
- prefer 2
- apply(rule Basic)
- apply simp_all
- apply(rule subset_refl)
-apply(auto intro!: Basic)
-done
-
-subsubsection {* Parameterized *}
-
-lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
- (\<Sum>i=0..<n. (b i::nat)) =
- (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
-apply(induct n)
- apply simp_all
-apply(simp add:less_Suc_eq)
- apply(auto)
-apply(subgoal_tac "n - j = Suc(n- Suc j)")
- apply simp
-apply arith
-done
-
-lemma Example2_lemma2_aux2:
- "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
-apply(induct j)
- apply (simp_all cong:setsum_cong)
-done
-
-lemma Example2_lemma2:
- "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
-apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
-apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
-apply(frule_tac b=b in Example2_lemma2_aux)
-apply(erule_tac t="setsum b {0..<n}" in ssubst)
-apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply(subgoal_tac "j\<le>j")
- apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply simp_all
-done
-
-lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
- Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
-by(simp add:Example2_lemma2)
-
-record Example2_parameterized =
- C :: "nat \<Rightarrow> nat"
- y :: nat
-
-lemma Example2_parameterized: "0<n \<Longrightarrow>
- \<turnstile> COBEGIN SCHEME [0\<le>i<n]
- (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
- \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
- \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
- (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
- (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
- \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
- COEND
- SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
-apply(rule Parallel)
-apply force
-apply force
-apply(force)
-apply clarify
-apply simp
-apply(simp cong:setsum_ivl_cong)
-apply clarify
-apply simp
-apply(rule Await)
-apply simp_all
-apply clarify
-apply(rule Seq)
-prefer 2
-apply(rule Basic)
-apply(rule subset_refl)
-apply simp+
-apply(rule Basic)
-apply simp
-apply clarify
-apply simp
-apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
-apply simp+
-done
-
-subsection {* Find Least Element *}
-
-text {* A previous lemma: *}
-
-lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i; j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
-apply(subgoal_tac "a=a div n*n + a mod n" )
- prefer 2 apply (simp (no_asm_use))
-apply(subgoal_tac "j=j div n*n + j mod n")
- prefer 2 apply (simp (no_asm_use))
-apply simp
-apply(subgoal_tac "a div n*n < j div n*n")
-prefer 2 apply arith
-apply(subgoal_tac "j div n*n < (a div n + 1)*n")
-prefer 2 apply simp
-apply (simp only:mult_less_cancel2)
-apply arith
-done
-
-record Example3 =
- X :: "nat \<Rightarrow> nat"
- Y :: "nat \<Rightarrow> nat"
-
-lemma Example3: "m mod n=0 \<Longrightarrow>
- \<turnstile> COBEGIN
- SCHEME [0\<le>i<n]
- (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j) DO
- IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
- ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
- OD,
- \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
- \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
- \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
- \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
- COEND
- SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
- \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
- (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
-apply(rule Parallel)
---{*5 subgoals left *}
-apply force+
-apply clarify
-apply simp
-apply(rule While)
- apply force
- apply force
- apply force
- apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * q \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
- apply force
- apply(rule subset_refl)+
- apply(rule Cond)
- apply force
- apply(rule Basic)
- apply force
- apply fastsimp
- apply force
- apply force
- apply(rule Basic)
- apply simp
- apply clarify
- apply simp
- apply (case_tac "X x (j mod n) \<le> j")
- apply (drule le_imp_less_or_eq)
- apply (erule disjE)
- apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
- apply auto
-done
-
-text {* Same but with a list as auxiliary variable: *}
-
-record Example3_list =
- X :: "nat list"
- Y :: "nat list"
-
-lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
- (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j) DO
- IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
- OD,
- \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
- \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
- \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
- \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
- SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
- \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
- \<lbrace>True\<rbrace>,
- \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
- (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
-apply(rule Parallel)
---{* 5 subgoals left *}
-apply force+
-apply clarify
-apply simp
-apply(rule While)
- apply force
- apply force
- apply force
- apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * q \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
- apply force
- apply(rule subset_refl)+
- apply(rule Cond)
- apply force
- apply(rule Basic)
- apply force
- apply force
- apply force
- apply force
- apply(rule Basic)
- apply simp
- apply clarify
- apply simp
- apply(rule allI)
- apply(rule impI)+
- apply(case_tac "X x ! i\<le> j")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
- apply auto
-done
-
-end
--- a/src/HOL/HoareParallel/RG_Hoare.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1375 +0,0 @@
-header {* \section{The Proof System} *}
-
-theory RG_Hoare imports RG_Tran begin
-
-subsection {* Proof System for Component Programs *}
-
-declare Un_subset_iff [iff del]
-declare Cons_eq_map_conv[iff]
-
-constdefs
- stable :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
- "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"
-
-inductive
- rghoare :: "['a com, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
- ("\<turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
-where
- Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s \<or> t=s)} \<subseteq> guar;
- stable pre rely; stable post rely \<rbrakk>
- \<Longrightarrow> \<turnstile> Basic f sat [pre, rely, guar, post]"
-
-| Seq: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mid]; \<turnstile> Q sat [mid, rely, guar, post] \<rbrakk>
- \<Longrightarrow> \<turnstile> Seq P Q sat [pre, rely, guar, post]"
-
-| Cond: "\<lbrakk> stable pre rely; \<turnstile> P1 sat [pre \<inter> b, rely, guar, post];
- \<turnstile> P2 sat [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
- \<Longrightarrow> \<turnstile> Cond b P1 P2 sat [pre, rely, guar, post]"
-
-| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
- \<turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
- \<Longrightarrow> \<turnstile> While b P sat [pre, rely, guar, post]"
-
-| Await: "\<lbrakk> stable pre rely; stable post rely;
- \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
- \<Longrightarrow> \<turnstile> Await b P sat [pre, rely, guar, post]"
-
-| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
- \<turnstile> P sat [pre', rely', guar', post'] \<rbrakk>
- \<Longrightarrow> \<turnstile> P sat [pre, rely, guar, post]"
-
-constdefs
- Pre :: "'a rgformula \<Rightarrow> 'a set"
- "Pre x \<equiv> fst(snd x)"
- Post :: "'a rgformula \<Rightarrow> 'a set"
- "Post x \<equiv> snd(snd(snd(snd x)))"
- Rely :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
- "Rely x \<equiv> fst(snd(snd x))"
- Guar :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
- "Guar x \<equiv> fst(snd(snd(snd x)))"
- Com :: "'a rgformula \<Rightarrow> 'a com"
- "Com x \<equiv> fst x"
-
-subsection {* Proof System for Parallel Programs *}
-
-types 'a par_rgformula = "('a rgformula) list \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
-
-inductive
- par_rghoare :: "('a rgformula) list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
- ("\<turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
-where
- Parallel:
- "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j<length xs \<and> j\<noteq>i}. Guar(xs!j)) \<subseteq> Rely(xs!i);
- (\<Union>j\<in>{j. j<length xs}. Guar(xs!j)) \<subseteq> guar;
- pre \<subseteq> (\<Inter>i\<in>{i. i<length xs}. Pre(xs!i));
- (\<Inter>i\<in>{i. i<length xs}. Post(xs!i)) \<subseteq> post;
- \<forall>i<length xs. \<turnstile> Com(xs!i) sat [Pre(xs!i),Rely(xs!i),Guar(xs!i),Post(xs!i)] \<rbrakk>
- \<Longrightarrow> \<turnstile> xs SAT [pre, rely, guar, post]"
-
-section {* Soundness*}
-
-subsubsection {* Some previous lemmas *}
-
-lemma tl_of_assum_in_assum:
- "(P, s) # (P, t) # xs \<in> assum (pre, rely) \<Longrightarrow> stable pre rely
- \<Longrightarrow> (P, t) # xs \<in> assum (pre, rely)"
-apply(simp add:assum_def)
-apply clarify
-apply(rule conjI)
- apply(erule_tac x=0 in allE)
- apply(simp (no_asm_use)only:stable_def)
- apply(erule allE,erule allE,erule impE,assumption,erule mp)
- apply(simp add:Env)
-apply clarify
-apply(erule_tac x="Suc i" in allE)
-apply simp
-done
-
-lemma etran_in_comm:
- "(P, t) # xs \<in> comm(guar, post) \<Longrightarrow> (P, s) # (P, t) # xs \<in> comm(guar, post)"
-apply(simp add:comm_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma ctran_in_comm:
- "\<lbrakk>(s, s) \<in> guar; (Q, s) # xs \<in> comm(guar, post)\<rbrakk>
- \<Longrightarrow> (P, s) # (Q, s) # xs \<in> comm(guar, post)"
-apply(simp add:comm_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma takecptn_is_cptn [rule_format, elim!]:
- "\<forall>j. c \<in> cptn \<longrightarrow> take (Suc j) c \<in> cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j)
- apply simp
- apply(rule CptnOne)
-apply simp
-apply(force intro:cptn.intros elim:cptn.cases)
-done
-
-lemma dropcptn_is_cptn [rule_format,elim!]:
- "\<forall>j<length c. c \<in> cptn \<longrightarrow> drop j c \<in> cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j,simp+)
-apply(erule cptn.cases)
- apply simp
- apply force
-apply force
-done
-
-lemma takepar_cptn_is_par_cptn [rule_format,elim]:
- "\<forall>j. c \<in> par_cptn \<longrightarrow> take (Suc j) c \<in> par_cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j,simp)
- apply(rule ParCptnOne)
-apply(force intro:par_cptn.intros elim:par_cptn.cases)
-done
-
-lemma droppar_cptn_is_par_cptn [rule_format]:
- "\<forall>j<length c. c \<in> par_cptn \<longrightarrow> drop j c \<in> par_cptn"
-apply(induct "c")
- apply(force elim: par_cptn.cases)
-apply clarify
-apply(case_tac j,simp+)
-apply(erule par_cptn.cases)
- apply simp
- apply force
-apply force
-done
-
-lemma tl_of_cptn_is_cptn: "\<lbrakk>x # xs \<in> cptn; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs \<in> cptn"
-apply(subgoal_tac "1 < length (x # xs)")
- apply(drule dropcptn_is_cptn,simp+)
-done
-
-lemma not_ctran_None [rule_format]:
- "\<forall>s. (None, s)#xs \<in> cptn \<longrightarrow> (\<forall>i<length xs. ((None, s)#xs)!i -e\<rightarrow> xs!i)"
-apply(induct xs,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply simp
- apply(case_tac i,simp)
- apply(rule Env)
- apply simp
-apply(force elim:ctran.cases)
-done
-
-lemma cptn_not_empty [simp]:"[] \<notin> cptn"
-apply(force elim:cptn.cases)
-done
-
-lemma etran_or_ctran [rule_format]:
- "\<forall>m i. x\<in>cptn \<longrightarrow> m \<le> length x
- \<longrightarrow> (\<forall>i. Suc i < m \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i) \<longrightarrow> Suc i < m
- \<longrightarrow> x!i -e\<rightarrow> x!Suc i"
-apply(induct x,simp)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp)
- apply(rule Env)
- apply simp
- apply(erule_tac x="m - 1" in allE)
- apply(case_tac m,simp,simp)
- apply(subgoal_tac "(\<forall>i. Suc i < nata \<longrightarrow> (((P, t) # xs) ! i, xs ! i) \<notin> ctran)")
- apply force
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp)
-apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?J j) \<notin> ctran" in allE,simp)
-done
-
-lemma etran_or_ctran2 [rule_format]:
- "\<forall>i. Suc i<length x \<longrightarrow> x\<in>cptn \<longrightarrow> (x!i -c\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i)
- \<or> (x!i -e\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i)"
-apply(induct x)
- apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
-apply(case_tac i,simp)
- apply(force elim:etran.cases)
-apply simp
-done
-
-lemma etran_or_ctran2_disjI1:
- "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i"
-by(drule etran_or_ctran2,simp_all)
-
-lemma etran_or_ctran2_disjI2:
- "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -e\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i"
-by(drule etran_or_ctran2,simp_all)
-
-lemma not_ctran_None2 [rule_format]:
- "\<lbrakk> (None, s) # xs \<in>cptn; i<length xs\<rbrakk> \<Longrightarrow> \<not> ((None, s) # xs) ! i -c\<rightarrow> xs ! i"
-apply(frule not_ctran_None,simp)
-apply(case_tac i,simp)
- apply(force elim:etranE)
-apply simp
-apply(rule etran_or_ctran2_disjI2,simp_all)
-apply(force intro:tl_of_cptn_is_cptn)
-done
-
-lemma Ex_first_occurrence [rule_format]: "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i<m. \<not> P i))";
-apply(rule nat_less_induct)
-apply clarify
-apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
-apply auto
-done
-
-lemma stability [rule_format]:
- "\<forall>j k. x \<in> cptn \<longrightarrow> stable p rely \<longrightarrow> j\<le>k \<longrightarrow> k<length x \<longrightarrow> snd(x!j)\<in>p \<longrightarrow>
- (\<forall>i. (Suc i)<length x \<longrightarrow>
- (x!i -e\<rightarrow> x!(Suc i)) \<longrightarrow> (snd(x!i), snd(x!(Suc i))) \<in> rely) \<longrightarrow>
- (\<forall>i. j\<le>i \<and> i<k \<longrightarrow> x!i -e\<rightarrow> x!Suc i) \<longrightarrow> snd(x!k)\<in>p \<and> fst(x!j)=fst(x!k)"
-apply(induct x)
- apply clarify
- apply(force elim:cptn.cases)
-apply clarify
-apply(erule cptn.cases,simp)
- apply simp
- apply(case_tac k,simp,simp)
- apply(case_tac j,simp)
- apply(erule_tac x=0 in allE)
- apply(erule_tac x="nat" and P="\<lambda>j. (0\<le>j) \<longrightarrow> (?J j)" in allE,simp)
- apply(subgoal_tac "t\<in>p")
- apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran \<longrightarrow> ?T j" in allE,simp)
- apply(simp(no_asm_use) only:stable_def)
- apply(erule_tac x=s in allE)
- apply(erule_tac x=t in allE)
- apply simp
- apply(erule mp)
- apply(erule mp)
- apply(rule Env)
- apply simp
- apply(erule_tac x="nata" in allE)
- apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
- apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
-apply(case_tac k,simp,simp)
-apply(case_tac j)
- apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply(erule etran.cases,simp)
-apply(erule_tac x="nata" in allE)
-apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
-apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((Q, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((Q, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
-apply clarify
-apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
-done
-
-subsection {* Soundness of the System for Component Programs *}
-
-subsubsection {* Soundness of the Basic rule *}
-
-lemma unique_ctran_Basic [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s) \<longrightarrow>
- Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
- (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
-apply(induct x,simp)
-apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply clarify
- apply(case_tac j,simp)
- apply(rule Env)
- apply simp
-apply clarify
-apply simp
-apply(case_tac i)
- apply(case_tac j,simp,simp)
- apply(erule ctran.cases,simp_all)
- apply(force elim: not_ctran_None)
-apply(ind_cases "((Some (Basic f), sa), Q, t) \<in> ctran" for sa Q t)
-apply simp
-apply(drule_tac i=nat in not_ctran_None,simp)
-apply(erule etranE,simp)
-done
-
-lemma exists_ctran_Basic_None [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s)
- \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
-apply(induct x,simp)
-apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp,simp)
- apply(erule_tac x=nat in allE,simp)
- apply clarify
- apply(rule_tac x="Suc j" in exI,simp,simp)
-apply clarify
-apply(case_tac i,simp,simp)
-apply(rule_tac x=0 in exI,simp)
-done
-
-lemma Basic_sound:
- " \<lbrakk>pre \<subseteq> {s. f s \<in> post}; {(s, t). s \<in> pre \<and> t = f s} \<subseteq> guar;
- stable pre rely; stable post rely\<rbrakk>
- \<Longrightarrow> \<Turnstile> Basic f sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:comm_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:cp_def assum_def)
- apply clarify
- apply(frule_tac j=0 and k=i and p=pre in stability)
- apply simp_all
- apply(erule_tac x=ia in allE,simp)
- apply(erule_tac i=i and f=f in unique_ctran_Basic,simp_all)
- apply(erule subsetD,simp)
- apply(case_tac "x!i")
- apply clarify
- apply(drule_tac s="Some (Basic f)" in sym,simp)
- apply(thin_tac "\<forall>j. ?H j")
- apply(force elim:ctran.cases)
-apply clarify
-apply(simp add:cp_def)
-apply clarify
-apply(frule_tac i="length x - 1" and f=f in exists_ctran_Basic_None,simp+)
- apply(case_tac x,simp+)
- apply(rule last_fst_esp,simp add:last_length)
- apply (case_tac x,simp+)
-apply(simp add:assum_def)
-apply clarify
-apply(frule_tac j=0 and k="j" and p=pre in stability)
- apply simp_all
- apply(erule_tac x=i in allE,simp)
- apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
-apply(case_tac "x!j")
-apply clarify
-apply simp
-apply(drule_tac s="Some (Basic f)" in sym,simp)
-apply(case_tac "x!Suc j",simp)
-apply(rule ctran.cases,simp)
-apply(simp_all)
-apply(drule_tac c=sa in subsetD,simp)
-apply clarify
-apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
- apply(case_tac x,simp+)
- apply(erule_tac x=i in allE)
-apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
- apply arith+
-apply(case_tac x)
-apply(simp add:last_length)+
-done
-
-subsubsection{* Soundness of the Await rule *}
-
-lemma unique_ctran_Await [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s) \<longrightarrow>
- Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
- (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
-apply(induct x,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply clarify
- apply(case_tac j,simp)
- apply(rule Env)
- apply simp
-apply clarify
-apply simp
-apply(case_tac i)
- apply(case_tac j,simp,simp)
- apply(erule ctran.cases,simp_all)
- apply(force elim: not_ctran_None)
-apply(ind_cases "((Some (Await b c), sa), Q, t) \<in> ctran" for sa Q t,simp)
-apply(drule_tac i=nat in not_ctran_None,simp)
-apply(erule etranE,simp)
-done
-
-lemma exists_ctran_Await_None [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s)
- \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
-apply(induct x,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply(erule_tac x=nat in allE,simp)
- apply clarify
- apply(rule_tac x="Suc j" in exI,simp,simp)
-apply clarify
-apply(case_tac i,simp,simp)
-apply(rule_tac x=0 in exI,simp)
-done
-
-lemma Star_imp_cptn:
- "(P, s) -c*\<rightarrow> (R, t) \<Longrightarrow> \<exists>l \<in> cp P s. (last l)=(R, t)
- \<and> (\<forall>i. Suc i<length l \<longrightarrow> l!i -c\<rightarrow> l!Suc i)"
-apply (erule converse_rtrancl_induct2)
- apply(rule_tac x="[(R,t)]" in bexI)
- apply simp
- apply(simp add:cp_def)
- apply(rule CptnOne)
-apply clarify
-apply(rule_tac x="(a, b)#l" in bexI)
- apply (rule conjI)
- apply(case_tac l,simp add:cp_def)
- apply(simp add:last_length)
- apply clarify
-apply(case_tac i,simp)
-apply(simp add:cp_def)
-apply force
-apply(simp add:cp_def)
- apply(case_tac l)
- apply(force elim:cptn.cases)
-apply simp
-apply(erule CptnComp)
-apply clarify
-done
-
-lemma Await_sound:
- "\<lbrakk>stable pre rely; stable post rely;
- \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
- \<Turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
- \<Longrightarrow> \<Turnstile> Await b P sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:comm_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:cp_def assum_def)
- apply clarify
- apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
- apply(erule_tac x=ia in allE,simp)
- apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
- apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
- apply(simp add:cp_def)
---{* here starts the different part. *}
- apply(erule ctran.cases,simp_all)
- apply(drule Star_imp_cptn)
- apply clarify
- apply(erule_tac x=sa in allE)
- apply clarify
- apply(erule_tac x=sa in allE)
- apply(drule_tac c=l in subsetD)
- apply (simp add:cp_def)
- apply clarify
- apply(erule_tac x=ia and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
- apply(erule etranE,simp)
- apply simp
-apply clarify
-apply(simp add:cp_def)
-apply clarify
-apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
- apply (case_tac x,simp+)
- apply(rule last_fst_esp,simp add:last_length)
- apply(case_tac x, (simp add:cptn_not_empty)+)
-apply clarify
-apply(simp add:assum_def)
-apply clarify
-apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
- apply(erule_tac x=i in allE,simp)
- apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
-apply(case_tac "x!j")
-apply clarify
-apply simp
-apply(drule_tac s="Some (Await b P)" in sym,simp)
-apply(case_tac "x!Suc j",simp)
-apply(rule ctran.cases,simp)
-apply(simp_all)
-apply(drule Star_imp_cptn)
-apply clarify
-apply(erule_tac x=sa in allE)
-apply clarify
-apply(erule_tac x=sa in allE)
-apply(drule_tac c=l in subsetD)
- apply (simp add:cp_def)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
- apply(erule etranE,simp)
-apply simp
-apply clarify
-apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
- apply(case_tac x,simp+)
- apply(erule_tac x=i in allE)
-apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
- apply arith+
-apply(case_tac x)
-apply(simp add:last_length)+
-done
-
-subsubsection{* Soundness of the Conditional rule *}
-
-lemma Cond_sound:
- "\<lbrakk> stable pre rely; \<Turnstile> P1 sat [pre \<inter> b, rely, guar, post];
- \<Turnstile> P2 sat [pre \<inter> - b, rely, guar, post]; \<forall>s. (s,s)\<in>guar\<rbrakk>
- \<Longrightarrow> \<Turnstile> (Cond b P1 P2) sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:cp_def comm_def)
-apply(case_tac "\<exists>i. Suc i<length x \<and> x!i -c\<rightarrow> x!Suc i")
- prefer 2
- apply simp
- apply clarify
- apply(frule_tac j="0" and k="length x - 1" and p=pre in stability,simp+)
- apply(case_tac x,simp+)
- apply(simp add:assum_def)
- apply(simp add:assum_def)
- apply(erule_tac m="length x" in etran_or_ctran,simp+)
- apply(case_tac x, (simp add:last_length)+)
-apply(erule exE)
-apply(drule_tac n=i and P="\<lambda>i. ?H i \<and> (?J i,?I i)\<in> ctran" in Ex_first_occurrence)
-apply clarify
-apply (simp add:assum_def)
-apply(frule_tac j=0 and k="m" and p=pre in stability,simp+)
- apply(erule_tac m="Suc m" in etran_or_ctran,simp+)
-apply(erule ctran.cases,simp_all)
- apply(erule_tac x="sa" in allE)
- apply(drule_tac c="drop (Suc m) x" in subsetD)
- apply simp
- apply clarify
- apply simp
- apply clarify
- apply(case_tac "i\<le>m")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(erule_tac x=i in allE, erule impE, assumption)
- apply simp+
- apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
- apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
- apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
- apply(rotate_tac -2)
- apply simp
- apply arith
- apply arith
-apply(case_tac "length (drop (Suc m) x)",simp)
-apply(erule_tac x="sa" in allE)
-back
-apply(drule_tac c="drop (Suc m) x" in subsetD,simp)
- apply clarify
-apply simp
-apply clarify
-apply(case_tac "i\<le>m")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(erule_tac x=i in allE, erule impE, assumption)
- apply simp
- apply simp
-apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
-apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
- apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
- apply(rotate_tac -2)
- apply simp
- apply arith
-apply arith
-done
-
-subsubsection{* Soundness of the Sequential rule *}
-
-inductive_cases Seq_cases [elim!]: "(Some (Seq P Q), s) -c\<rightarrow> t"
-
-lemma last_lift_not_None: "fst ((lift Q) ((x#xs)!(length xs))) \<noteq> None"
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-
-declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
-lemma Seq_sound1 [rule_format]:
- "x\<in> cptn_mod \<Longrightarrow> \<forall>s P. x !0=(Some (Seq P Q), s) \<longrightarrow>
- (\<forall>i<length x. fst(x!i)\<noteq>Some Q) \<longrightarrow>
- (\<exists>xs\<in> cp (Some P) s. x=map (lift Q) xs)"
-apply(erule cptn_mod.induct)
-apply(unfold cp_def)
-apply safe
-apply simp_all
- apply(simp add:lift_def)
- apply(rule_tac x="[(Some Pa, sa)]" in exI,simp add:CptnOne)
- apply(subgoal_tac "(\<forall>i < Suc (length xs). fst (((Some (Seq Pa Q), t) # xs) ! i) \<noteq> Some Q)")
- apply clarify
- apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # zs" in exI,simp)
- apply(rule conjI,erule CptnEnv)
- apply(simp (no_asm_use) add:lift_def)
- apply clarify
- apply(erule_tac x="Suc i" in allE, simp)
- apply(ind_cases "((Some (Seq Pa Q), sa), None, t) \<in> ctran" for Pa sa t)
- apply(rule_tac x="(Some P, sa) # xs" in exI, simp add:cptn_iff_cptn_mod lift_def)
-apply(erule_tac x="length xs" in allE, simp)
-apply(simp only:Cons_lift_append)
-apply(subgoal_tac "length xs < length ((Some P, sa) # xs)")
- apply(simp only :nth_append length_map last_length nth_map)
- apply(case_tac "last((Some P, sa) # xs)")
- apply(simp add:lift_def)
-apply simp
-done
-declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
-
-lemma Seq_sound2 [rule_format]:
- "x \<in> cptn \<Longrightarrow> \<forall>s P i. x!0=(Some (Seq P Q), s) \<longrightarrow> i<length x
- \<longrightarrow> fst(x!i)=Some Q \<longrightarrow>
- (\<forall>j<i. fst(x!j)\<noteq>(Some Q)) \<longrightarrow>
- (\<exists>xs ys. xs \<in> cp (Some P) s \<and> length xs=Suc i
- \<and> ys \<in> cp (Some Q) (snd(xs !i)) \<and> x=(map (lift Q) xs)@tl ys)"
-apply(erule cptn.induct)
-apply(unfold cp_def)
-apply safe
-apply simp_all
- apply(case_tac i,simp+)
- apply(erule allE,erule impE,assumption,simp)
- apply clarify
- apply(subgoal_tac "(\<forall>j < nat. fst (((Some (Seq Pa Q), t) # xs) ! j) \<noteq> Some Q)",clarify)
- prefer 2
- apply force
- apply(case_tac xsa,simp,simp)
- apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # list" in exI,simp)
- apply(rule conjI,erule CptnEnv)
- apply(simp (no_asm_use) add:lift_def)
- apply(rule_tac x=ys in exI,simp)
-apply(ind_cases "((Some (Seq Pa Q), sa), t) \<in> ctran" for Pa sa t)
- apply simp
- apply(rule_tac x="(Some Pa, sa)#[(None, ta)]" in exI,simp)
- apply(rule conjI)
- apply(drule_tac xs="[]" in CptnComp,force simp add:CptnOne,simp)
- apply(case_tac i, simp+)
- apply(case_tac nat,simp+)
- apply(rule_tac x="(Some Q,ta)#xs" in exI,simp add:lift_def)
- apply(case_tac nat,simp+)
- apply(force)
-apply(case_tac i, simp+)
-apply(case_tac nat,simp+)
-apply(erule_tac x="Suc nata" in allE,simp)
-apply clarify
-apply(subgoal_tac "(\<forall>j<Suc nata. fst (((Some (Seq P2 Q), ta) # xs) ! j) \<noteq> Some Q)",clarify)
- prefer 2
- apply clarify
- apply force
-apply(rule_tac x="(Some Pa, sa)#(Some P2, ta)#(tl xsa)" in exI,simp)
-apply(rule conjI,erule CptnComp)
-apply(rule nth_tl_if,force,simp+)
-apply(rule_tac x=ys in exI,simp)
-apply(rule conjI)
-apply(rule nth_tl_if,force,simp+)
- apply(rule tl_zero,simp+)
- apply force
-apply(rule conjI,simp add:lift_def)
-apply(subgoal_tac "lift Q (Some P2, ta) =(Some (Seq P2 Q), ta)")
- apply(simp add:Cons_lift del:map.simps)
- apply(rule nth_tl_if)
- apply force
- apply simp+
-apply(simp add:lift_def)
-done
-(*
-lemma last_lift_not_None3: "fst (last (map (lift Q) (x#xs))) \<noteq> None"
-apply(simp only:last_length [THEN sym])
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-*)
-
-lemma last_lift_not_None2: "fst ((lift Q) (last (x#xs))) \<noteq> None"
-apply(simp only:last_length [THEN sym])
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-
-lemma Seq_sound:
- "\<lbrakk>\<Turnstile> P sat [pre, rely, guar, mid]; \<Turnstile> Q sat [mid, rely, guar, post]\<rbrakk>
- \<Longrightarrow> \<Turnstile> Seq P Q sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(case_tac "\<exists>i<length x. fst(x!i)=Some Q")
- prefer 2
- apply (simp add:cp_def cptn_iff_cptn_mod)
- apply clarify
- apply(frule_tac Seq_sound1,force)
- apply force
- apply clarify
- apply(erule_tac x=s in allE,simp)
- apply(drule_tac c=xs in subsetD,simp add:cp_def cptn_iff_cptn_mod)
- apply(simp add:assum_def)
- apply clarify
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(force elim:etranE intro:Env simp add:lift_def)
- apply(simp add:comm_def)
- apply(rule conjI)
- apply clarify
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(case_tac "(xs!i)")
- apply(case_tac "(xs! Suc i)")
- apply(case_tac "fst(xs!i)")
- apply(erule_tac x=i in allE, simp add:lift_def)
- apply(case_tac "fst(xs!Suc i)")
- apply(force simp add:lift_def)
- apply(force simp add:lift_def)
- apply clarify
- apply(case_tac xs,simp add:cp_def)
- apply clarify
- apply (simp del:map.simps)
- apply(subgoal_tac "(map (lift Q) ((a, b) # list))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
- apply simp
---{* @{text "\<exists>i<length x. fst (x ! i) = Some Q"} *}
-apply(erule exE)
-apply(drule_tac n=i and P="\<lambda>i. i < length x \<and> fst (x ! i) = Some Q" in Ex_first_occurrence)
-apply clarify
-apply (simp add:cp_def)
- apply clarify
- apply(frule_tac i=m in Seq_sound2,force)
- apply simp+
-apply clarify
-apply(simp add:comm_def)
-apply(erule_tac x=s in allE)
-apply(drule_tac c=xs in subsetD,simp)
- apply(case_tac "xs=[]",simp)
- apply(simp add:cp_def assum_def nth_append)
- apply clarify
- apply(erule_tac x=i in allE)
- back
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(force elim:etranE intro:Env simp add:lift_def)
-apply simp
-apply clarify
-apply(erule_tac x="snd(xs!m)" in allE)
-apply(drule_tac c=ys in subsetD,simp add:cp_def assum_def)
- apply(case_tac "xs\<noteq>[]")
- apply(drule last_conv_nth,simp)
- apply(rule conjI)
- apply(erule mp)
- apply(case_tac "xs!m")
- apply(case_tac "fst(xs!m)",simp)
- apply(simp add:lift_def nth_append)
- apply clarify
- apply(erule_tac x="m+i" in allE)
- back
- back
- apply(case_tac ys,(simp add:nth_append)+)
- apply (case_tac i, (simp add:snd_lift)+)
- apply(erule mp)
- apply(case_tac "xs!m")
- apply(force elim:etran.cases intro:Env simp add:lift_def)
- apply simp
-apply simp
-apply clarify
-apply(rule conjI,clarify)
- apply(case_tac "i<m",simp add:nth_append)
- apply(simp add:snd_lift)
- apply(erule allE, erule impE, assumption, erule mp)
- apply(case_tac "(xs ! i)")
- apply(case_tac "(xs ! Suc i)")
- apply(case_tac "fst(xs ! i)",force simp add:lift_def)
- apply(case_tac "fst(xs ! Suc i)")
- apply (force simp add:lift_def)
- apply (force simp add:lift_def)
- apply(erule_tac x="i-m" in allE)
- back
- back
- apply(subgoal_tac "Suc (i - m) < length ys",simp)
- prefer 2
- apply arith
- apply(simp add:nth_append snd_lift)
- apply(rule conjI,clarify)
- apply(subgoal_tac "i=m")
- prefer 2
- apply arith
- apply clarify
- apply(simp add:cp_def)
- apply(rule tl_zero)
- apply(erule mp)
- apply(case_tac "lift Q (xs!m)",simp add:snd_lift)
- apply(case_tac "xs!m",case_tac "fst(xs!m)",simp add:lift_def snd_lift)
- apply(case_tac ys,simp+)
- apply(simp add:lift_def)
- apply simp
- apply force
- apply clarify
- apply(rule tl_zero)
- apply(rule tl_zero)
- apply (subgoal_tac "i-m=Suc(i-Suc m)")
- apply simp
- apply(erule mp)
- apply(case_tac ys,simp+)
- apply force
- apply arith
- apply force
-apply clarify
-apply(case_tac "(map (lift Q) xs @ tl ys)\<noteq>[]")
- apply(drule last_conv_nth)
- apply(simp add: snd_lift nth_append)
- apply(rule conjI,clarify)
- apply(case_tac ys,simp+)
- apply clarify
- apply(case_tac ys,simp+)
-done
-
-subsubsection{* Soundness of the While rule *}
-
-lemma last_append[rule_format]:
- "\<forall>xs. ys\<noteq>[] \<longrightarrow> ((xs@ys)!(length (xs@ys) - (Suc 0)))=(ys!(length ys - (Suc 0)))"
-apply(induct ys)
- apply simp
-apply clarify
-apply (simp add:nth_append length_append)
-done
-
-lemma assum_after_body:
- "\<lbrakk> \<Turnstile> P sat [pre \<inter> b, rely, guar, pre];
- (Some P, s) # xs \<in> cptn_mod; fst (last ((Some P, s) # xs)) = None; s \<in> b;
- (Some (While b P), s) # (Some (Seq P (While b P)), s) #
- map (lift (While b P)) xs @ ys \<in> assum (pre, rely)\<rbrakk>
- \<Longrightarrow> (Some (While b P), snd (last ((Some P, s) # xs))) # ys \<in> assum (pre, rely)"
-apply(simp add:assum_def com_validity_def cp_def cptn_iff_cptn_mod)
-apply clarify
-apply(erule_tac x=s in allE)
-apply(drule_tac c="(Some P, s) # xs" in subsetD,simp)
- apply clarify
- apply(erule_tac x="Suc i" in allE)
- apply simp
- apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
- apply(erule mp)
- apply(erule etranE,simp)
- apply(case_tac "fst(((Some P, s) # xs) ! i)")
- apply(force intro:Env simp add:lift_def)
- apply(force intro:Env simp add:lift_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:comm_def last_length)
-apply clarify
-apply(rule conjI)
- apply(simp add:comm_def)
-apply clarify
-apply(erule_tac x="Suc(length xs + i)" in allE,simp)
-apply(case_tac i, simp add:nth_append Cons_lift_append snd_lift del:map.simps)
- apply(simp add:last_length)
- apply(erule mp)
- apply(case_tac "last xs")
- apply(simp add:lift_def)
-apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
-done
-
-lemma While_sound_aux [rule_format]:
- "\<lbrakk> pre \<inter> - b \<subseteq> post; \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s, s) \<in> guar;
- stable pre rely; stable post rely; x \<in> cptn_mod \<rbrakk>
- \<Longrightarrow> \<forall>s xs. x=(Some(While b P),s)#xs \<longrightarrow> x\<in>assum(pre, rely) \<longrightarrow> x \<in> comm (guar, post)"
-apply(erule cptn_mod.induct)
-apply safe
-apply (simp_all del:last.simps)
---{* 5 subgoals left *}
-apply(simp add:comm_def)
---{* 4 subgoals left *}
-apply(rule etran_in_comm)
-apply(erule mp)
-apply(erule tl_of_assum_in_assum,simp)
---{* While-None *}
-apply(ind_cases "((Some (While b P), s), None, t) \<in> ctran" for s t)
-apply(simp add:comm_def)
-apply(simp add:cptn_iff_cptn_mod [THEN sym])
-apply(rule conjI,clarify)
- apply(force simp add:assum_def)
-apply clarify
-apply(rule conjI, clarify)
- apply(case_tac i,simp,simp)
- apply(force simp add:not_ctran_None2)
-apply(subgoal_tac "\<forall>i. Suc i < length ((None, t) # xs) \<longrightarrow> (((None, t) # xs) ! i, ((None, t) # xs) ! Suc i)\<in> etran")
- prefer 2
- apply clarify
- apply(rule_tac m="length ((None, s) # xs)" in etran_or_ctran,simp+)
- apply(erule not_ctran_None2,simp)
- apply simp+
-apply(frule_tac j="0" and k="length ((None, s) # xs) - 1" and p=post in stability,simp+)
- apply(force simp add:assum_def subsetD)
- apply(simp add:assum_def)
- apply clarify
- apply(erule_tac x="i" in allE,simp)
- apply(erule_tac x="Suc i" in allE,simp)
- apply simp
-apply clarify
-apply (simp add:last_length)
---{* WhileOne *}
-apply(thin_tac "P = While b P \<longrightarrow> ?Q")
-apply(rule ctran_in_comm,simp)
-apply(simp add:Cons_lift del:map.simps)
-apply(simp add:comm_def del:map.simps)
-apply(rule conjI)
- apply clarify
- apply(case_tac "fst(((Some P, sa) # xs) ! i)")
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply (simp add:lift_def)
- apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
- apply simp
- apply simp
- apply(simp add:snd_lift del:map.simps)
- apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
- apply(erule_tac x=sa in allE)
- apply(drule_tac c="(Some P, sa) # xs" in subsetD)
- apply (simp add:assum_def del:map.simps)
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp add:snd_lift del:map.simps)
- apply(erule mp)
- apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply (simp add:comm_def del:map.simps)
- apply clarify
- apply(erule allE,erule impE,assumption)
- apply(erule mp)
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply(case_tac "xs!i")
- apply(simp add:lift_def)
- apply(case_tac "fst(xs!i)")
- apply force
- apply force
---{* last=None *}
-apply clarify
-apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
-apply simp
---{* WhileMore *}
-apply(thin_tac "P = While b P \<longrightarrow> ?Q")
-apply(rule ctran_in_comm,simp del:last.simps)
---{* metiendo la hipotesis antes de dividir la conclusion. *}
-apply(subgoal_tac "(Some (While b P), snd (last ((Some P, sa) # xs))) # ys \<in> assum (pre, rely)")
- apply (simp del:last.simps)
- prefer 2
- apply(erule assum_after_body)
- apply (simp del:last.simps)+
---{* lo de antes. *}
-apply(simp add:comm_def del:map.simps last.simps)
-apply(rule conjI)
- apply clarify
- apply(simp only:Cons_lift_append)
- apply(case_tac "i<length xs")
- apply(simp add:nth_append del:map.simps last.simps)
- apply(case_tac "fst(((Some P, sa) # xs) ! i)")
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply (simp add:lift_def del:last.simps)
- apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
- apply simp
- apply simp
- apply(simp add:snd_lift del:map.simps last.simps)
- apply(thin_tac " \<forall>i. i < length ys \<longrightarrow> ?P i")
- apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
- apply(erule_tac x=sa in allE)
- apply(drule_tac c="(Some P, sa) # xs" in subsetD)
- apply (simp add:assum_def del:map.simps last.simps)
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp add:nth_append snd_lift del:map.simps last.simps, erule mp)
- apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply (simp add:comm_def del:map.simps)
- apply clarify
- apply(erule allE,erule impE,assumption)
- apply(erule mp)
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply(case_tac "xs!i")
- apply(simp add:lift_def)
- apply(case_tac "fst(xs!i)")
- apply force
- apply force
---{* @{text "i \<ge> length xs"} *}
-apply(subgoal_tac "i-length xs <length ys")
- prefer 2
- apply arith
-apply(erule_tac x="i-length xs" in allE,clarify)
-apply(case_tac "i=length xs")
- apply (simp add:nth_append snd_lift del:map.simps last.simps)
- apply(simp add:last_length del:last.simps)
- apply(erule mp)
- apply(case_tac "last((Some P, sa) # xs)")
- apply(simp add:lift_def del:last.simps)
---{* @{text "i>length xs"} *}
-apply(case_tac "i-length xs")
- apply arith
-apply(simp add:nth_append del:map.simps last.simps)
-apply(rotate_tac -3)
-apply(subgoal_tac "i- Suc (length xs)=nat")
- prefer 2
- apply arith
-apply simp
---{* last=None *}
-apply clarify
-apply(case_tac ys)
- apply(simp add:Cons_lift del:map.simps last.simps)
- apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
- apply simp
-apply(subgoal_tac "((Some (Seq P (While b P)), sa) # map (lift (While b P)) xs @ ys)\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps last.simps)
- apply(simp add:nth_append del:last.simps)
- apply(subgoal_tac "((Some (While b P), snd (last ((Some P, sa) # xs))) # a # list)\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps last.simps)
- apply simp
-apply simp
-done
-
-lemma While_sound:
- "\<lbrakk>stable pre rely; pre \<inter> - b \<subseteq> post; stable post rely;
- \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar\<rbrakk>
- \<Longrightarrow> \<Turnstile> While b P sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(erule_tac xs="tl x" in While_sound_aux)
- apply(simp add:com_validity_def)
- apply force
- apply simp_all
-apply(simp add:cptn_iff_cptn_mod cp_def)
-apply(simp add:cp_def)
-apply clarify
-apply(rule nth_equalityI)
- apply simp_all
- apply(case_tac x,simp+)
-apply clarify
-apply(case_tac i,simp+)
-apply(case_tac x,simp+)
-done
-
-subsubsection{* Soundness of the Rule of Consequence *}
-
-lemma Conseq_sound:
- "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
- \<Turnstile> P sat [pre', rely', guar', post']\<rbrakk>
- \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
-apply(simp add:com_validity_def assum_def comm_def)
-apply clarify
-apply(erule_tac x=s in allE)
-apply(drule_tac c=x in subsetD)
- apply force
-apply force
-done
-
-subsubsection {* Soundness of the system for sequential component programs *}
-
-theorem rgsound:
- "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
-apply(erule rghoare.induct)
- apply(force elim:Basic_sound)
- apply(force elim:Seq_sound)
- apply(force elim:Cond_sound)
- apply(force elim:While_sound)
- apply(force elim:Await_sound)
-apply(erule Conseq_sound,simp+)
-done
-
-subsection {* Soundness of the System for Parallel Programs *}
-
-constdefs
- ParallelCom :: "('a rgformula) list \<Rightarrow> 'a par_com"
- "ParallelCom Ps \<equiv> map (Some \<circ> fst) Ps"
-
-lemma two:
- "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i<length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x\<in>par_assum(pre, rely);
- \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
- \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -c\<rightarrow> (clist!i!Suc j)
- \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> Guar(xs!i)"
-apply(unfold par_cp_def)
-apply (rule ccontr)
---{* By contradiction: *}
-apply (simp del: Un_subset_iff)
-apply(erule exE)
---{* the first c-tran that does not satisfy the guarantee-condition is from @{text "\<sigma>_i"} at step @{text "m"}. *}
-apply(drule_tac n=j and P="\<lambda>j. \<exists>i. ?H i j" in Ex_first_occurrence)
-apply(erule exE)
-apply clarify
---{* @{text "\<sigma>_i \<in> A(pre, rely_1)"} *}
-apply(subgoal_tac "take (Suc (Suc m)) (clist!i) \<in> assum(Pre(xs!i), Rely(xs!i))")
---{* but this contradicts @{text "\<Turnstile> \<sigma>_i sat [pre_i,rely_i,guar_i,post_i]"} *}
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
- apply(simp add:com_validity_def)
- apply(erule_tac x=s in allE)
- apply(simp add:cp_def comm_def)
- apply(drule_tac c="take (Suc (Suc m)) (clist ! i)" in subsetD)
- apply simp
- apply (blast intro: takecptn_is_cptn)
- apply simp
- apply clarify
- apply(erule_tac x=m and P="\<lambda>j. ?I j \<and> ?J j \<longrightarrow> ?H j" in allE)
- apply (simp add:conjoin_def same_length_def)
-apply(simp add:assum_def del: Un_subset_iff)
-apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<in>cp (?K j) (?J j)" in allE)
- apply(simp add:cp_def par_assum_def)
- apply(drule_tac c="s" in subsetD,simp)
- apply simp
-apply clarify
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?M \<union> UNION (?S j) (?T j) \<subseteq> (?L j)" in allE)
-apply(simp del: Un_subset_iff)
-apply(erule subsetD)
-apply simp
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j) \<or> ?Q j" in allE,simp)
---{* each etran in @{text "\<sigma>_1[0\<dots>m]"} corresponds to *}
-apply(erule disjE)
---{* a c-tran in some @{text "\<sigma>_{ib}"} *}
- apply clarify
- apply(case_tac "i=ib",simp)
- apply(erule etranE,simp)
- apply(erule_tac x="ib" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE)
- apply (erule etranE)
- apply(case_tac "ia=m",simp)
- apply simp
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (\<forall> i. ?P i j)" in allE)
- apply(subgoal_tac "ia<m",simp)
- prefer 2
- apply arith
- apply(erule_tac x=ib and P="\<lambda>j. (?I j, ?H j)\<in> ctran \<longrightarrow> (?P i j)" in allE,simp)
- apply(simp add:same_state_def)
- apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
- apply(erule_tac x=ib and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
---{* or an e-tran in @{text "\<sigma>"},
-therefore it satisfies @{text "rely \<or> guar_{ib}"} *}
-apply (force simp add:par_assum_def same_state_def)
-done
-
-
-lemma three [rule_format]:
- "\<lbrakk> xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i<length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum(pre, rely);
- \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
- \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -e\<rightarrow> (clist!i!Suc j)
- \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))"
-apply(drule two)
- apply simp_all
-apply clarify
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (?J j \<and> (\<exists>i. ?P i j)) \<or> ?I j" in allE,simp)
-apply(erule disjE)
- prefer 2
- apply(force simp add:same_state_def par_assum_def)
-apply clarify
-apply(case_tac "i=ia",simp)
- apply(erule etranE,simp)
-apply(erule_tac x="ia" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE,simp)
-apply(erule_tac x=j and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
-apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
-apply(simp add:same_state_def)
-apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
-done
-
-lemma four:
- "\<lbrakk>xs\<noteq>[]; \<forall>i < length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- (\<Union>j\<in>{j. j < length xs}. Guar (xs ! j)) \<subseteq> guar;
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i < length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely); Suc i < length x;
- x ! i -pc\<rightarrow> x ! Suc i\<rbrakk>
- \<Longrightarrow> (snd (x ! i), snd (x ! Suc i)) \<in> guar"
-apply(simp add: ParallelCom_def del: Un_subset_iff)
-apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
- prefer 2
- apply simp
-apply(frule rev_subsetD)
- apply(erule one [THEN equalityD1])
-apply(erule subsetD)
-apply (simp del: Un_subset_iff)
-apply clarify
-apply(drule_tac pre=pre and rely=rely and x=x and s=s and xs=xs and clist=clist in two)
-apply(assumption+)
- apply(erule sym)
- apply(simp add:ParallelCom_def)
- apply assumption
- apply(simp add:Com_def)
- apply assumption
-apply(simp add:conjoin_def same_program_def)
-apply clarify
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in all_dupE)
-apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
-apply(erule par_ctranE,simp)
-apply(erule_tac x=i and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
-apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
-apply(rule_tac x=ia in exI)
-apply(simp add:same_state_def)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE,simp)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE)
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE,simp)
-apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
-apply(erule mp)
-apply(subgoal_tac "r=fst(clist ! ia ! Suc i)",simp)
-apply(drule_tac i=ia in list_eq_if)
-back
-apply simp_all
-done
-
-lemma parcptn_not_empty [simp]:"[] \<notin> par_cptn"
-apply(force elim:par_cptn.cases)
-done
-
-lemma five:
- "\<lbrakk>xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- (\<Inter>i\<in>{i. i < length xs}. Post (xs ! i)) \<subseteq> post;
- \<forall>i < length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely);
- All_None (fst (last x)) \<rbrakk> \<Longrightarrow> snd (last x) \<in> post"
-apply(simp add: ParallelCom_def del: Un_subset_iff)
-apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
- prefer 2
- apply simp
-apply(frule rev_subsetD)
- apply(erule one [THEN equalityD1])
-apply(erule subsetD)
-apply(simp del: Un_subset_iff)
-apply clarify
-apply(subgoal_tac "\<forall>i<length clist. clist!i\<in>assum(Pre(xs!i), Rely(xs!i))")
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
- apply(simp add:com_validity_def)
- apply(erule_tac x=s in allE)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I j) \<in> cp (?J j) s" in allE,simp)
- apply(drule_tac c="clist!i" in subsetD)
- apply (force simp add:Com_def)
- apply(simp add:comm_def conjoin_def same_program_def del:last.simps)
- apply clarify
- apply(erule_tac x="length x - 1" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
- apply (simp add:All_None_def same_length_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> length(?J j)=(?K j)" in allE)
- apply(subgoal_tac "length x - 1 < length x",simp)
- apply(case_tac "x\<noteq>[]")
- apply(simp add: last_conv_nth)
- apply(erule_tac x="clist!i" in ballE)
- apply(simp add:same_state_def)
- apply(subgoal_tac "clist!i\<noteq>[]")
- apply(simp add: last_conv_nth)
- apply(case_tac x)
- apply (force simp add:par_cp_def)
- apply (force simp add:par_cp_def)
- apply force
- apply (force simp add:par_cp_def)
- apply(case_tac x)
- apply (force simp add:par_cp_def)
- apply (force simp add:par_cp_def)
-apply clarify
-apply(simp add:assum_def)
-apply(rule conjI)
- apply(simp add:conjoin_def same_state_def par_cp_def)
- apply clarify
- apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(case_tac x,simp+)
- apply (simp add:par_assum_def)
- apply clarify
- apply(drule_tac c="snd (clist ! ia ! 0)" in subsetD)
- apply assumption
- apply simp
-apply clarify
-apply(erule_tac x=ia in all_dupE)
-apply(rule subsetD, erule mp, assumption)
-apply(erule_tac pre=pre and rely=rely and x=x and s=s in three)
- apply(erule_tac x=ic in allE,erule mp)
- apply simp_all
- apply(simp add:ParallelCom_def)
- apply(force simp add:Com_def)
-apply(simp add:conjoin_def same_length_def)
-done
-
-lemma ParallelEmpty [rule_format]:
- "\<forall>i s. x \<in> par_cp (ParallelCom []) s \<longrightarrow>
- Suc i < length x \<longrightarrow> (x ! i, x ! Suc i) \<notin> par_ctran"
-apply(induct_tac x)
- apply(simp add:par_cp_def ParallelCom_def)
-apply clarify
-apply(case_tac list,simp,simp)
-apply(case_tac i)
- apply(simp add:par_cp_def ParallelCom_def)
- apply(erule par_ctranE,simp)
-apply(simp add:par_cp_def ParallelCom_def)
-apply clarify
-apply(erule par_cptn.cases,simp)
- apply simp
-apply(erule par_ctranE)
-back
-apply simp
-done
-
-theorem par_rgsound:
- "\<turnstile> c SAT [pre, rely, guar, post] \<Longrightarrow>
- \<Turnstile> (ParallelCom c) SAT [pre, rely, guar, post]"
-apply(erule par_rghoare.induct)
-apply(case_tac xs,simp)
- apply(simp add:par_com_validity_def par_comm_def)
- apply clarify
- apply(case_tac "post=UNIV",simp)
- apply clarify
- apply(drule ParallelEmpty)
- apply assumption
- apply simp
- apply clarify
- apply simp
-apply(subgoal_tac "xs\<noteq>[]")
- prefer 2
- apply simp
-apply(thin_tac "xs = a # list")
-apply(simp add:par_com_validity_def par_comm_def)
-apply clarify
-apply(rule conjI)
- apply clarify
- apply(erule_tac pre=pre and rely=rely and guar=guar and x=x and s=s and xs=xs in four)
- apply(assumption+)
- apply clarify
- apply (erule allE, erule impE, assumption,erule rgsound)
- apply(assumption+)
-apply clarify
-apply(erule_tac pre=pre and rely=rely and post=post and x=x and s=s and xs=xs in five)
- apply(assumption+)
- apply clarify
- apply (erule allE, erule impE, assumption,erule rgsound)
- apply(assumption+)
-done
-
-end
--- a/src/HOL/HoareParallel/RG_Syntax.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,95 +0,0 @@
-header {* \section{Concrete Syntax} *}
-
-theory RG_Syntax
-imports RG_Hoare Quote_Antiquote
-begin
-
-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)
- "_Await" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0AWAIT _ /THEN /_ /END)" [0,0] 61)
- "_Atom" :: "'a com \<Rightarrow> 'a com" ("(\<langle>_\<rangle>)" 61)
- "_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"
- "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"
- "WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
-
-nonterminals
- prgs
-
-syntax
- "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" 60)
- "_prg" :: "'a \<Rightarrow> prgs" ("_" 57)
- "_prgs" :: "['a, prgs] \<Rightarrow> prgs" ("_//\<parallel>//_" [60,57] 57)
-
-translations
- "_prg a" \<rightharpoonup> "[a]"
- "_prgs a ps" \<rightharpoonup> "a # ps"
- "_PAR ps" \<rightharpoonup> "ps"
-
-syntax
- "_prg_scheme" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs" ("SCHEME [_ \<le> _ < _] _" [0,0,0,60] 57)
-
-translations
- "_prg_scheme j i k c" \<rightleftharpoons> "(map (\<lambda>i. c) [j..<k])"
-
-text {* Translations for variables before and after a transition: *}
-
-syntax
- "_before" :: "id \<Rightarrow> 'a" ("\<ordmasculine>_")
- "_after" :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")
-
-translations
- "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>fst"
- "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>snd"
-
-print_translation {*
- let
- fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
- | quote_tr' _ _ = raise Match;
-
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
-
- fun bexp_tr' name ((Const ("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
- | K_tr' _ = raise Match;
-
- fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ 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")]
- end
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Tran.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1075 +0,0 @@
-header {* \section{Operational Semantics} *}
-
-theory RG_Tran
-imports RG_Com
-begin
-
-subsection {* Semantics of Component Programs *}
-
-subsubsection {* Environment transitions *}
-
-types 'a conf = "(('a com) option) \<times> 'a"
-
-inductive_set
- etran :: "('a conf \<times> 'a conf) set"
- and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -e\<rightarrow> _" [81,81] 80)
-where
- "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
-| Env: "(P, s) -e\<rightarrow> (P, t)"
-
-lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
- by (induct c, induct c', erule etran.cases, blast)
-
-subsubsection {* Component transitions *}
-
-inductive_set
- ctran :: "('a conf \<times> 'a conf) set"
- and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c\<rightarrow> _" [81,81] 80)
- and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c*\<rightarrow> _" [81,81] 80)
-where
- "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
-| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran^*"
-
-| Basic: "(Some(Basic f), s) -c\<rightarrow> (None, f s)"
-
-| Seq1: "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"
-
-| Seq2: "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"
-
-| CondT: "s\<in>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
-| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"
-
-| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
-| WhileT: "s\<in>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"
-
-| Await: "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"
-
-monos "rtrancl_mono"
-
-subsection {* Semantics of Parallel Programs *}
-
-types 'a par_conf = "('a par_com) \<times> 'a"
-
-inductive_set
- par_etran :: "('a par_conf \<times> 'a par_conf) set"
- and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
-where
- "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
-| ParEnv: "(Ps, s) -pe\<rightarrow> (Ps, t)"
-
-inductive_set
- par_ctran :: "('a par_conf \<times> 'a par_conf) set"
- and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
-where
- "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
-| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"
-
-lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
- (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
- (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
- by (induct c, induct c', erule par_ctran.cases, blast)
-
-subsection {* Computations *}
-
-subsubsection {* Sequential computations *}
-
-types 'a confs = "('a conf) list"
-
-inductive_set cptn :: "('a confs) set"
-where
- CptnOne: "[(P,s)] \<in> cptn"
-| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
-| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"
-
-constdefs
- cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set"
- "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"
-
-subsubsection {* Parallel computations *}
-
-types 'a par_confs = "('a par_conf) list"
-
-inductive_set par_cptn :: "('a par_confs) set"
-where
- ParCptnOne: "[(P,s)] \<in> par_cptn"
-| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
-| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"
-
-constdefs
- par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set"
- "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"
-
-subsection{* Modular Definition of Computation *}
-
-constdefs
- lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf"
- "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"
-
-inductive_set cptn_mod :: "('a confs) set"
-where
- CptnModOne: "[(P, s)] \<in> cptn_mod"
-| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
-| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
-| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
-| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
-| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
- \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
-| CptnModSeq2:
- "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
- (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
- zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
-
-| CptnModWhile1:
- "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
- \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
-| CptnModWhile2:
- "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
- zs=(map (lift (While b P)) xs)@ys;
- (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
- \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
-
-subsection {* Equivalence of Both Definitions.*}
-
-lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
-apply simp
-apply(induct xs,simp+)
-apply(case_tac xs)
-apply simp_all
-done
-
-lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
- (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
- (\<exists>xs. (Some P, s)#xs \<in> cptn_mod \<and> (zs=(map (lift Q) xs) \<or>
- ( fst(((Some P, s)#xs)!length xs)=None \<and>
- (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
- \<and> zs=(map (lift (Q)) xs)@ys)))))"
-apply(erule cptn_mod.induct)
-apply simp_all
- apply clarify
- apply(force intro:CptnModOne)
- apply clarify
- apply(erule_tac x=Pa in allE)
- apply(erule_tac x=Q in allE)
- apply simp
- apply clarify
- apply(erule disjE)
- apply(rule_tac x="(Some Pa,t)#xsa" in exI)
- apply(rule conjI)
- apply clarify
- apply(erule CptnModEnv)
- apply(rule disjI1)
- apply(simp add:lift_def)
- apply clarify
- apply(rule_tac x="(Some Pa,t)#xsa" in exI)
- apply(rule conjI)
- apply(erule CptnModEnv)
- apply(rule disjI2)
- apply(rule conjI)
- apply(case_tac xsa,simp,simp)
- apply(rule_tac x="ys" in exI)
- apply(rule conjI)
- apply simp
- apply(simp add:lift_def)
- apply clarify
- apply(erule ctran.cases,simp_all)
- apply clarify
- apply(rule_tac x="xs" in exI)
- apply simp
- apply clarify
-apply(rule_tac x="xs" in exI)
-apply(simp add: last_length)
-done
-
-lemma cptn_onlyif_cptn_mod_aux [rule_format]:
- "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
- \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
-apply(induct a)
-apply simp_all
---{* basic *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,rule Basic,simp)
-apply clarify
-apply(erule ctran.cases,simp_all)
---{* Seq1 *}
-apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
- apply(erule CptnModNone)
- apply(rule CptnModOne)
- apply simp
-apply simp
-apply(simp add:lift_def)
---{* Seq2 *}
-apply(erule_tac x=sa in allE)
-apply(erule_tac x="Some P2" in allE)
-apply(erule allE,erule impE, assumption)
-apply(drule div_seq,simp)
-apply force
-apply clarify
-apply(erule disjE)
- apply clarify
- apply(erule allE,erule impE, assumption)
- apply(erule_tac CptnModSeq1)
- apply(simp add:lift_def)
-apply clarify
-apply(erule allE,erule impE, assumption)
-apply(erule_tac CptnModSeq2)
- apply (simp add:last_length)
- apply (simp add:last_length)
-apply(simp add:lift_def)
---{* Cond *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(force elim: CptnModCondT)
-apply(force elim: CptnModCondF)
---{* While *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,erule WhileF,simp)
-apply(drule div_seq,force)
-apply clarify
-apply (erule disjE)
- apply(force elim:CptnModWhile1)
-apply clarify
-apply(force simp add:last_length elim:CptnModWhile2)
---{* await *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,erule Await,simp+)
-done
-
-lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
-apply(erule cptn.induct)
- apply(rule CptnModOne)
- apply(erule CptnModEnv)
-apply(case_tac P)
- apply simp
- apply(erule ctran.cases,simp_all)
-apply(force elim:cptn_onlyif_cptn_mod_aux)
-done
-
-lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
-apply(erule cptn.induct)
- apply(force simp add:lift_def CptnOne)
- apply(force intro:CptnEnv simp add:lift_def)
-apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
-done
-
-lemma cptn_append_is_cptn [rule_format]:
- "\<forall>b a. b#c1\<in>cptn \<longrightarrow> a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
-apply(induct c1)
- apply simp
-apply clarify
-apply(erule cptn.cases,simp_all)
- apply(force intro:CptnEnv)
-apply(force elim:CptnComp)
-done
-
-lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
- \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
-apply(case_tac "(xs ! (length xs - (Suc 0)))")
-apply (simp add:lift_def)
-done
-
-lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
-apply(induct x,simp+)
-done
-
-lemma last_fst_esp:
- "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
-apply(erule last_fst)
-apply simp
-done
-
-lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
- snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
-apply(case_tac "(xs ! (length xs - (Suc 0)))",simp)
-apply (simp add:lift_def)
-done
-
-lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
-by(simp add:lift_def)
-
-lemma Cons_lift_append:
- "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
-by(simp add:lift_def)
-
-lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q (xs! i)"
-by (simp add:lift_def)
-
-lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
-apply(case_tac "xs!i")
-apply(simp add:lift_def)
-done
-
-lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
-apply(erule cptn_mod.induct)
- apply(rule CptnOne)
- apply(erule CptnEnv)
- apply(erule CptnComp,simp)
- apply(rule CptnComp)
- apply(erule CondT,simp)
- apply(rule CptnComp)
- apply(erule CondF,simp)
---{* Seq1 *}
-apply(erule cptn.cases,simp_all)
- apply(rule CptnOne)
- apply clarify
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
- apply(rule CptnEnv,simp)
-apply clarify
-apply(simp add:lift_def)
-apply(rule conjI)
- apply clarify
- apply(rule CptnComp)
- apply(rule Seq1,simp)
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
-apply clarify
-apply(rule CptnComp)
- apply(rule Seq2,simp)
-apply(drule_tac P=P1 in lift_is_cptn)
-apply(simp add:lift_def)
---{* Seq2 *}
-apply(rule cptn_append_is_cptn)
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
- apply simp
-apply(case_tac "xs\<noteq>[]")
- apply(drule_tac P=P1 in last_lift)
- apply(rule last_fst_esp)
- apply (simp add:last_length)
- apply(simp add:Cons_lift del:map.simps)
- apply(rule conjI, clarify, simp)
- apply(case_tac "(((Some P0, s) # xs) ! length xs)")
- apply clarify
- apply (simp add:lift_def last_length)
-apply (simp add:last_length)
---{* While1 *}
-apply(rule CptnComp)
-apply(rule WhileT,simp)
-apply(drule_tac P="While b P" in lift_is_cptn)
-apply(simp add:lift_def)
---{* While2 *}
-apply(rule CptnComp)
-apply(rule WhileT,simp)
-apply(rule cptn_append_is_cptn)
-apply(drule_tac P="While b P" in lift_is_cptn)
- apply(simp add:lift_def)
- apply simp
-apply(case_tac "xs\<noteq>[]")
- apply(drule_tac P="While b P" in last_lift)
- apply(rule last_fst_esp,simp add:last_length)
- apply(simp add:Cons_lift del:map.simps)
- apply(rule conjI, clarify, simp)
- apply(case_tac "(((Some P, s) # xs) ! length xs)")
- apply clarify
- apply (simp add:last_length lift_def)
-apply simp
-done
-
-theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
-apply(rule iffI)
- apply(erule cptn_onlyif_cptn_mod)
-apply(erule cptn_if_cptn_mod)
-done
-
-section {* Validity of Correctness Formulas*}
-
-subsection {* Validity for Component Programs. *}
-
-types 'a rgformula = "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
-
-constdefs
- assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set"
- "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
-
- comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set"
- "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
- (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"
-
- com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
- ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
- "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
- \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"
-
-subsection {* Validity for Parallel Programs. *}
-
-constdefs
- All_None :: "(('a com) option) list \<Rightarrow> bool"
- "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"
-
- par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set"
- "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
-
- par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set"
- "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
- (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"
-
- par_com_validity :: "'a par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
-\<Rightarrow> 'a set \<Rightarrow> bool" ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
- "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
- \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"
-
-subsection {* Compositionality of the Semantics *}
-
-subsubsection {* Definition of the conjoin operator *}
-
-constdefs
- same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"
-
- same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"
-
- same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"
-
- compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
- (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
- (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
- (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"
-
- conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" ("_ \<propto> _" [65,65] 64)
- "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"
-
-subsubsection {* Some previous lemmas *}
-
-lemma list_eq_if [rule_format]:
- "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
-apply (induct xs)
- apply simp
-apply clarify
-done
-
-lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
-apply(rule iffI)
- apply clarify
- apply(erule nth_equalityI)
- apply simp+
-done
-
-lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
-apply(case_tac ys)
- apply simp+
-done
-
-lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
-apply(induct ys)
- apply simp+
-done
-
-lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
-apply(induct ys)
- apply simp+
-done
-
-lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
-seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
-if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]
-
-lemma prog_not_eq_in_ctran_aux:
- assumes c: "(P,s) -c\<rightarrow> (Q,t)"
- shows "P\<noteq>Q" using c
- by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto
-
-lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
-apply clarify
-apply(drule prog_not_eq_in_ctran_aux)
-apply simp
-done
-
-lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
-apply(erule par_ctran.induct)
-apply(drule prog_not_eq_in_ctran_aux)
-apply clarify
-apply(drule list_eq_if)
- apply simp_all
-apply force
-done
-
-lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
-apply clarify
-apply(drule prog_not_eq_in_par_ctran_aux)
-apply simp
-done
-
-lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
-apply(force elim:cptn.cases)
-done
-
-lemma tl_zero[rule_format]:
- "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
-apply(induct ys)
- apply simp_all
-done
-
-subsection {* The Semantics is Compositional *}
-
-lemma aux_if [rule_format]:
- "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
- \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
- \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
-apply(induct ys)
- apply(clarify)
- apply(rule ParCptnOne)
-apply(clarify)
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in all_dupE,simp)
-apply(erule disjE)
---{* first step is a Component step *}
- apply clarify
- apply simp
- apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
- apply(subgoal_tac "b=snd(clist!i!0)",simp)
- prefer 2
- apply(simp add: same_state_def)
- apply(erule_tac x=i in allE,erule impE,assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- prefer 2
- apply(simp add:same_program_def)
- apply(erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(rule ParCptnComp)
- apply(erule ParComp,simp)
---{* applying the induction hypothesis *}
- apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
- apply(erule_tac x="snd (clist ! i ! 0)" in allE)
- apply(erule mp)
- apply(rule_tac x="map tl clist" in exI,simp)
- apply(rule conjI,clarify)
- apply(case_tac "i=ia",simp)
- apply(rule nth_tl_if)
- apply(force simp add:same_length_def length_Suc_conv)
- apply simp
- apply(erule allE,erule impE,assumption,erule tl_in_cptn)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(rule nth_tl_if)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(simp add:same_state_def)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(erule allE,erule impE,assumption,erule tl_in_cptn)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(simp add:same_length_def same_state_def)
- apply(rule conjI)
- apply clarify
- apply(case_tac j,simp,simp)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp,simp)
- apply(force simp add:length_Suc_conv)
- apply(rule allI,rule impI)
- apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
- apply(erule disjE)
- apply clarify
- apply(rule_tac x=ia in exI,simp)
- apply(case_tac "i=ia",simp)
- apply(rule conjI)
- apply(force simp add: length_Suc_conv)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
- apply simp
- apply(case_tac j,simp)
- apply(rule tl_zero)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(force elim:etranE intro:Env)
- apply force
- apply force
- apply simp
- apply(rule tl_zero)
- apply(erule tl_zero)
- apply force
- apply force
- apply force
- apply force
- apply(rule conjI,simp)
- apply(rule nth_tl_if)
- apply force
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(erule tl_zero)
- apply force
- apply force
- apply clarify
- apply(case_tac "i=l",simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption,erule impE,assumption)
- apply(erule tl_zero,force)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
- apply(erule etranE,simp)
- apply(rule tl_zero)
- apply force
- apply force
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(rule disjI2)
- apply(case_tac j,simp)
- apply clarify
- apply(rule tl_zero)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j\<in>etran" in allE,erule impE, assumption)
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
- apply(force elim:etranE intro:Env)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply clarify
- apply(rule tl_zero)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
---{* first step is an environmental step *}
-apply clarify
-apply(erule par_etran.cases)
-apply simp
-apply(rule ParCptnEnv)
-apply(erule_tac x="Ps" in allE)
-apply(erule_tac x="t" in allE)
-apply(erule mp)
-apply(rule_tac x="map tl clist" in exI,simp)
-apply(rule conjI)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I ?s j) \<in> cptn" in allE,simp)
- apply(erule cptn.cases)
- apply(simp add:same_length_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(simp add:same_state_def)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<in>etran" in allE,simp)
- apply(erule etranE,simp)
-apply(simp add:same_state_def same_length_def)
-apply(rule conjI,clarify)
- apply(case_tac j,simp,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule tl_zero)
- apply(simp)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply simp
- apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp,simp)
- apply(force simp add:length_Suc_conv)
-apply(rule allI,rule impI)
-apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
-apply(erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule etranE,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(erule tl_zero,force)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule etranE,simp)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply(rule disjI2)
-apply simp
-apply clarify
-apply(case_tac j,simp)
- apply(rule tl_zero)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(force elim:etranE intro:Env)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply simp
-apply(rule tl_zero)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-done
-
-lemma less_Suc_0 [iff]: "(n < Suc 0) = (n = 0)"
-by auto
-
-lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
- (\<exists>clist. (length clist = length xs) \<and>
- (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
- (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
-apply(induct ys)
- apply(clarify)
- apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
- apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
- apply(rule conjI)
- apply(rule nth_equalityI,simp,simp)
- apply(force intro: cptn.intros)
-apply(clarify)
-apply(erule par_cptn.cases,simp)
- apply simp
- apply(erule_tac x="xs" in allE)
- apply(erule_tac x="t" in allE,simp)
- apply clarify
- apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
- apply(rule conjI)
- prefer 2
- apply clarify
- apply(rule CptnEnv,simp)
- apply(simp add:conjoin_def same_length_def same_state_def)
- apply (rule conjI)
- apply clarify
- apply(case_tac j,simp,simp)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp,simp)
- apply simp
- apply(rule nth_equalityI,simp,simp)
- apply(simp add:compat_label_def)
- apply clarify
- apply(case_tac j,simp)
- apply(simp add:ParEnv)
- apply clarify
- apply(simp add:Env)
- apply simp
- apply(erule_tac x=nat in allE,erule impE, assumption)
- apply(erule disjE,simp)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply force
-apply(erule par_ctran.cases,simp)
-apply(erule_tac x="Ps[i:=r]" in allE)
-apply(erule_tac x="ta" in allE,simp)
-apply clarify
-apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
-apply(rule conjI)
- prefer 2
- apply clarify
- apply(case_tac "i=ia",simp)
- apply(erule CptnComp)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<in> cptn)" in allE,simp)
- apply simp
- apply(erule_tac x=ia in allE)
- apply(rule CptnEnv,simp)
-apply(simp add:conjoin_def)
-apply (rule conjI)
- apply(simp add:same_length_def)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
-apply(rule conjI)
- apply(simp add:same_state_def)
- apply clarify
- apply(case_tac j, simp, simp (no_asm_simp))
- apply(case_tac "i=ia",simp,simp)
-apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp,simp)
- apply simp
- apply(rule nth_equalityI,simp,simp)
- apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (fst (?a j))=((?b j))" in allE)
- apply(case_tac nat)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
-apply(simp add:compat_label_def)
-apply clarify
-apply(case_tac j)
- apply(rule conjI,simp)
- apply(erule ParComp,assumption)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply clarify
- apply(rule Env)
-apply simp
-apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in allE,simp)
-apply(erule disjE)
- apply clarify
- apply(rule_tac x=ia in exI,simp)
- apply(rule conjI)
- apply(case_tac "i=ia",simp,simp)
- apply clarify
- apply(case_tac "i=l",simp)
- apply(case_tac "l=ia",simp,simp)
- apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
- apply simp
- apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
-apply clarify
-apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption)
-apply(case_tac "i=ia",simp,simp)
-done
-
-lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
- (\<exists>clist. length clist= length xs \<and>
- ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
- (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
- (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
- (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
-apply (rule iffI)
- apply(rule subset_antisym)
- apply(rule subsetI)
- apply(clarify)
- apply(simp add:par_cp_def cp_def)
- apply(case_tac x)
- apply(force elim:par_cptn.cases)
- apply simp
- apply(erule_tac x="list" in allE)
- apply clarify
- apply simp
- apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
- apply(rule subsetI)
- apply(clarify)
- apply(case_tac x)
- apply(erule_tac x=0 in allE)
- apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
- apply clarify
- apply(erule cptn.cases,force,force,force)
- apply(simp add:par_cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
- apply clarify
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in all_dupE)
- apply(subgoal_tac "a = xs")
- apply(subgoal_tac "b = s",simp)
- prefer 3
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=((?t j))" in allE)
- apply (simp add:cp_def)
- apply(rule nth_equalityI,simp,simp)
- prefer 2
- apply(erule_tac x=0 in allE)
- apply (simp add:cp_def)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (\<forall>i. ?T i \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=list in allE)
- apply(rule_tac x="map tl clist" in exI,simp)
- apply(rule conjI)
- apply clarify
- apply(case_tac j,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="Suc nat" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(rule conjI)
- apply clarify
- apply(rule nth_equalityI,simp,simp)
- apply(case_tac j)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply clarify
- apply simp
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(thin_tac "?H = (\<exists>i. ?J i)")
- apply(rule conjI)
- apply clarify
- apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(case_tac j,simp)
- apply(rule conjI)
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply clarify
- apply(simp add:cp_def)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply simp
- apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp)
- apply(rule nth_tl_if,simp,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption,simp)
- apply(simp add:cp_def)
- apply clarify
- apply(rule nth_tl_if)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply force
- apply force
-apply clarify
-apply(rule iffI)
- apply(simp add:par_cp_def)
- apply(erule_tac c="(xs, s) # ys" in equalityCE)
- apply simp
- apply clarify
- apply(rule_tac x="map tl clist" in exI)
- apply simp
- apply (rule conjI)
- apply(simp add:conjoin_def cp_def)
- apply(rule conjI)
- apply clarify
- apply(unfold same_length_def)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,simp)
- apply(rule conjI)
- apply(simp add:same_state_def)
- apply clarify
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(case_tac j,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(rule nth_equalityI,simp,simp)
- apply(case_tac j,simp)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(simp add:compat_label_def)
- apply(rule allI,rule impI)
- apply(erule_tac x=j in allE,erule impE, assumption)
- apply(erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(rule conjI)
- apply(erule_tac x=i in allE)
- apply(case_tac j,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply(erule_tac x=l in allE,simp)
- apply(rule disjI2)
- apply clarify
- apply(rule tl_zero)
- apply(case_tac j,simp,simp)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(rule nth_tl_if)
- apply(simp add:conjoin_def)
- apply clarify
- apply(simp add:same_length_def)
- apply(erule_tac x=i in allE,simp)
- apply simp
- apply simp
- apply simp
-apply clarify
-apply(erule_tac c="(xs, s) # ys" in equalityCE)
- apply(simp add:par_cp_def)
-apply simp
-apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
-apply simp
-apply clarify
-apply(simp add:cp_def)
-done
-
-theorem one: "xs\<noteq>[] \<Longrightarrow>
- par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
- (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
-apply(frule one_iff_aux)
-apply(drule sym)
-apply(erule iffD2)
-apply clarify
-apply(rule iffI)
- apply(erule aux_onlyif)
-apply clarify
-apply(force intro:aux_if)
-done
-
-end
--- a/src/HOL/HoareParallel/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(* $Id$ *)
-
-use_thys ["OG_Examples", "Gar_Coll", "Mul_Gar_Coll", "RG_Examples"];
--- a/src/HOL/HoareParallel/document/root.bib Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-@inproceedings{NipkowP-FASE99,author={Tobias Nipkow and Prensa Nieto, Leonor},
-title={{Owicki/Gries} in {Isabelle/HOL}},
-booktitle={Fundamental Approaches to Software Engineering (FASE'99)},
-editor={J.-P. Finance},publisher="Springer",series="LNCS",volume=1577,
-pages={188--203},year=1999}
-
-@InProceedings{PrenEsp00,
- author = {Prensa Nieto, Leonor and Javier Esparza},
- title = {Verifying Single and Multi-mutator Garbage Collectors
- with {Owicki/Gries} in {Isabelle/HOL}},
- booktitle = {Mathematical Foundations of Computer Science (MFCS 2000)},
- editor = {M. Nielsen and B. Rovan},
- publisher = {Springer-Verlag},
- series = {LNCS},
- volume = 1893,
- pages = {619--628},
- year = 2000
-}
-
-@PhdThesis{Prensa-PhD,author={Leonor Prensa Nieto},
-title={Verification of Parallel Programs with the Owicki-Gries and
-Rely-Guarantee Methods in Isabelle/HOL},
-school={Technische Universit{\"a}t M{\"u}nchen},year=2002}
-
-@inproceedings{Prensa-ESOP03,author={Prensa Nieto, Leonor},
-title={The {Rely-Guarantee} Method in {Isabelle/HOL}},
-booktitle={European Symposium on Programming (ESOP'03)},editor={P. Degano},
-publisher=Springer,series=LNCS,volume=2618,pages={348--362},year=2003}
--- a/src/HOL/HoareParallel/document/root.tex Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,62 +0,0 @@
-
-% $Id$
-
-\documentclass[11pt,a4paper]{report}
-\usepackage{graphicx}
-\usepackage[english]{babel}
-\usepackage{isabelle,isabellesym}
-\usepackage{pdfsetup}
-
-\urlstyle{rm}
-\isabellestyle{it}
-
-\renewcommand{\isamarkupheader}[1]{#1}
-
-\begin{document}
-
-\title{Hoare Logic for Parallel Programs}
-\author{Leonor Prensa Nieto}
-\maketitle
-
-\begin{abstract}\noindent
- In the following theories a formalization of the Owicki-Gries and
- the rely-guarantee methods is presented. These methods are widely
- used for correctness proofs of parallel imperative programs with
- shared variables. We define syntax, semantics and proof rules in
- Isabelle/HOL. The proof rules also provide for programs
- parameterized in the number of parallel components. Their
- correctness w.r.t.\ the semantics is proven. Completeness proofs
- for both methods are extended to the new case of parameterized
- programs. (These proofs have not been formalized in Isabelle. They
- can be found in~\cite{Prensa-PhD}.) Using this formalizations we
- verify several non-trivial examples for parameterized and
- non-parameterized programs. For the automatic generation of
- verification conditions with the Owicki-Gries method we define a
- tactic based on the proof rules. The most involved examples are the
- verification of two garbage-collection algorithms, the second one
- parameterized in the number of mutators.
-
-For excellent descriptions of this work see
-\cite{NipkowP-FASE99,PrenEsp00,Prensa-PhD,Prensa-ESOP03}.
-
-\end{abstract}
-
-\pagestyle{plain}
-\thispagestyle{empty}
-\tableofcontents
-
-\clearpage
-
-\begin{center}
- \includegraphics[scale=0.7]{session_graph}
-\end{center}
-
-\newpage
-
-\parindent 0pt\parskip 0.5ex
-\input{session}
-
-\bibliographystyle{plain}
-\bibliography{root}
-
-\end{document}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Gar_Coll.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,844 @@
+
+header {* \section{The Single Mutator Case} *}
+
+theory Gar_Coll imports Graph OG_Syntax begin
+
+declare psubsetE [rule del]
+
+text {* Declaration of variables: *}
+
+record gar_coll_state =
+ M :: nodes
+ E :: edges
+ bc :: "nat set"
+ obc :: "nat set"
+ Ma :: nodes
+ ind :: nat
+ k :: nat
+ z :: bool
+
+subsection {* The Mutator *}
+
+text {* The mutator first redirects an arbitrary edge @{text "R"} from
+an arbitrary accessible node towards an arbitrary accessible node
+@{text "T"}. It then colors the new target @{text "T"} black.
+
+We declare the arbitrarily selected node and edge as constants:*}
+
+consts R :: nat T :: nat
+
+text {* \noindent The following predicate states, given a list of
+nodes @{text "m"} and a list of edges @{text "e"}, the conditions
+under which the selected edge @{text "R"} and node @{text "T"} are
+valid: *}
+
+constdefs
+ Mut_init :: "gar_coll_state \<Rightarrow> bool"
+ "Mut_init \<equiv> \<guillemotleft> T \<in> Reach \<acute>E \<and> R < length \<acute>E \<and> T < length \<acute>M \<guillemotright>"
+
+text {* \noindent For the mutator we
+consider two modules, one for each action. An auxiliary variable
+@{text "\<acute>z"} is set to false if the mutator has already redirected an
+edge but has not yet colored the new target. *}
+
+constdefs
+ Redirect_Edge :: "gar_coll_state ann_com"
+ "Redirect_Edge \<equiv> .{\<acute>Mut_init \<and> \<acute>z}. \<langle>\<acute>E:=\<acute>E[R:=(fst(\<acute>E!R), T)],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
+
+ Color_Target :: "gar_coll_state ann_com"
+ "Color_Target \<equiv> .{\<acute>Mut_init \<and> \<not>\<acute>z}. \<langle>\<acute>M:=\<acute>M[T:=Black],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
+
+ Mutator :: "gar_coll_state ann_com"
+ "Mutator \<equiv>
+ .{\<acute>Mut_init \<and> \<acute>z}.
+ WHILE True INV .{\<acute>Mut_init \<and> \<acute>z}.
+ DO Redirect_Edge ;; Color_Target OD"
+
+subsubsection {* Correctness of the mutator *}
+
+lemmas mutator_defs = Mut_init_def Redirect_Edge_def Color_Target_def
+
+lemma Redirect_Edge:
+ "\<turnstile> Redirect_Edge pre(Color_Target)"
+apply (unfold mutator_defs)
+apply annhoare
+apply(simp_all)
+apply(force elim:Graph2)
+done
+
+lemma Color_Target:
+ "\<turnstile> Color_Target .{\<acute>Mut_init \<and> \<acute>z}."
+apply (unfold mutator_defs)
+apply annhoare
+apply(simp_all)
+done
+
+lemma Mutator:
+ "\<turnstile> Mutator .{False}."
+apply(unfold Mutator_def)
+apply annhoare
+apply(simp_all add:Redirect_Edge Color_Target)
+apply(simp add:mutator_defs Redirect_Edge_def)
+done
+
+subsection {* The Collector *}
+
+text {* \noindent A constant @{text "M_init"} is used to give @{text "\<acute>Ma"} a
+suitable first value, defined as a list of nodes where only the @{text
+"Roots"} are black. *}
+
+consts M_init :: nodes
+
+constdefs
+ Proper_M_init :: "gar_coll_state \<Rightarrow> bool"
+ "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
+
+ Proper :: "gar_coll_state \<Rightarrow> bool"
+ "Proper \<equiv> \<guillemotleft> Proper_Roots \<acute>M \<and> Proper_Edges(\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<guillemotright>"
+
+ Safe :: "gar_coll_state \<Rightarrow> bool"
+ "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
+
+lemmas collector_defs = Proper_M_init_def Proper_def Safe_def
+
+subsubsection {* Blackening the roots *}
+
+constdefs
+ Blacken_Roots :: " gar_coll_state ann_com"
+ "Blacken_Roots \<equiv>
+ .{\<acute>Proper}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>ind\<in>Roots THEN
+ .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
+ \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
+ .{\<acute>Proper \<and> (\<forall>i<\<acute>ind+1. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Blacken_Roots:
+ "\<turnstile> Blacken_Roots .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}."
+apply (unfold Blacken_Roots_def)
+apply annhoare
+apply(simp_all add:collector_defs Graph_defs)
+apply safe
+apply(simp_all add:nth_list_update)
+ apply (erule less_SucE)
+ apply simp+
+ apply force
+apply force
+done
+
+subsubsection {* Propagating black *}
+
+constdefs
+ PBInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "PBInv \<equiv> \<guillemotleft> \<lambda>ind. \<acute>obc < Blacks \<acute>M \<or> (\<forall>i <ind. \<not>BtoW (\<acute>E!i, \<acute>M) \<or>
+ (\<not>\<acute>z \<and> i=R \<and> (snd(\<acute>E!R)) = T \<and> (\<exists>r. ind \<le> r \<and> r < length \<acute>E \<and> BtoW(\<acute>E!r,\<acute>M))))\<guillemotright>"
+
+constdefs
+ Propagate_Black_aux :: "gar_coll_state ann_com"
+ "Propagate_Black_aux \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ IF \<acute>M!(fst (\<acute>E!\<acute>ind)) = Black THEN
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black}.
+ \<acute>M:=\<acute>M[snd(\<acute>E!\<acute>ind):=Black];;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv (\<acute>ind + 1) \<and> \<acute>ind<length \<acute>E}.
+ \<acute>ind:=\<acute>ind+1
+ FI
+ OD"
+
+lemma Propagate_Black_aux:
+ "\<turnstile> Propagate_Black_aux
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
+apply (unfold Propagate_Black_aux_def PBInv_def collector_defs)
+apply annhoare
+apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
+ apply force
+ apply force
+ apply force
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Proper_Roots_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply(rule disjI1)
+ apply(erule Graph13)
+ apply force
+apply (case_tac "M x ! snd (E x ! ind x)=Black")
+ apply (simp add: Graph10 BtoW_def)
+ apply (rule disjI2)
+ apply clarify
+ apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply fast
+ apply fast
+apply(rule disjI1)
+apply(erule subset_psubset_trans)
+apply(erule Graph11)
+apply fast
+--{* 3 subgoals left *}
+apply force
+apply force
+--{* last *}
+apply clarify
+apply simp
+apply(subgoal_tac "ind x = length (E x)")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply(drule Graph1)
+ apply simp
+ apply clarify
+ apply(erule allE, erule impE, assumption)
+ apply force
+ apply force
+apply arith
+done
+
+subsubsection {* Refining propagating black *}
+
+constdefs
+ Auxk :: "gar_coll_state \<Rightarrow> bool"
+ "Auxk \<equiv> \<guillemotleft>\<acute>k<length \<acute>M \<and> (\<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or>
+ \<acute>obc<Blacks \<acute>M \<or> (\<not>\<acute>z \<and> \<acute>ind=R \<and> snd(\<acute>E!R)=T
+ \<and> (\<exists>r. \<acute>ind<r \<and> r<length \<acute>E \<and> BtoW(\<acute>E!r, \<acute>M))))\<guillemotright>"
+
+constdefs
+ Propagate_Black :: " gar_coll_state ann_com"
+ "Propagate_Black \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))=Black THEN
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black}.
+ \<acute>k:=(snd(\<acute>E!\<acute>ind));;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black
+ \<and> \<acute>Auxk}.
+ \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],, \<acute>ind:=\<acute>ind+1\<rangle>
+ ELSE .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ \<langle>IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle>
+ FI
+ OD"
+
+lemma Propagate_Black:
+ "\<turnstile> Propagate_Black
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
+apply (unfold Propagate_Black_def PBInv_def Auxk_def collector_defs)
+apply annhoare
+apply(simp_all add: Graph6 Graph7 Graph8 Graph12)
+ apply force
+ apply force
+ apply force
+--{* 5 subgoals left *}
+apply clarify
+apply(simp add:BtoW_def Proper_Edges_def)
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply (rule disjI1)
+ apply (erule psubset_subset_trans)
+ apply (erule Graph9)
+apply (case_tac "M x!k x=Black")
+ apply (case_tac "M x ! snd (E x ! ind x)=Black")
+ apply (simp add: Graph10 BtoW_def)
+ apply (rule disjI2)
+ apply clarify
+ apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply fast
+ apply fast
+ apply (simp add: Graph10 BtoW_def)
+ apply (erule disjE)
+ apply (erule disjI1)
+ apply clarify
+ apply (erule less_SucE)
+ apply force
+ apply simp
+ apply (subgoal_tac "Suc R\<le>r")
+ apply fast
+ apply arith
+apply(rule disjI1)
+apply(erule subset_psubset_trans)
+apply(erule Graph11)
+apply fast
+--{* 2 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply fast
+apply clarify
+apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply (simp add: BtoW_def)
+apply (simp add: BtoW_def)
+--{* last *}
+apply clarify
+apply simp
+apply(subgoal_tac "ind x = length (E x)")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply(drule Graph1)
+ apply simp
+ apply clarify
+ apply(erule allE, erule impE, assumption)
+ apply force
+ apply force
+apply arith
+done
+
+subsubsection {* Counting black nodes *}
+
+constdefs
+ CountInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
+
+constdefs
+ Count :: " gar_coll_state ann_com"
+ "Count \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}
+ \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black
+ THEN .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>bc:=insert \<acute>ind \<acute>bc
+ FI;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv (\<acute>ind+1)
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Count:
+ "\<turnstile> Count
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}."
+apply(unfold Count_def)
+apply annhoare
+apply(simp_all add:CountInv_def Graph6 Graph7 Graph8 Graph12 Blacks_def collector_defs)
+ apply force
+ apply force
+ apply force
+ apply clarify
+ apply simp
+ apply(fast elim:less_SucE)
+ apply clarify
+ apply simp
+ apply(fast elim:less_SucE)
+ apply force
+apply force
+done
+
+subsubsection {* Appending garbage nodes to the free list *}
+
+consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
+
+axioms
+ Append_to_free0: "length (Append_to_free (i, e)) = length e"
+ Append_to_free1: "Proper_Edges (m, e)
+ \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
+ Append_to_free2: "i \<notin> Reach e
+ \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
+
+constdefs
+ AppendInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "AppendInv \<equiv> \<guillemotleft>\<lambda>ind. \<forall>i<length \<acute>M. ind\<le>i \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black\<guillemotright>"
+
+constdefs
+ Append :: " gar_coll_state ann_com"
+ "Append \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black THEN
+ .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>M:=\<acute>M[\<acute>ind:=White]
+ ELSE .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
+ \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
+ FI;;
+ .{\<acute>Proper \<and> \<acute>AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Append:
+ "\<turnstile> Append .{\<acute>Proper}."
+apply(unfold Append_def AppendInv_def)
+apply annhoare
+apply(simp_all add:collector_defs Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+ apply(force simp:Blacks_def nth_list_update)
+ apply force
+ apply force
+ apply(force simp add:Graph_defs)
+ apply force
+ apply clarify
+ apply simp
+ apply(rule conjI)
+ apply (erule Append_to_free1)
+ apply clarify
+ apply (drule_tac n = "i" in Append_to_free2)
+ apply force
+ apply force
+apply force
+done
+
+subsubsection {* Correctness of the Collector *}
+
+constdefs
+ Collector :: " gar_coll_state ann_com"
+ "Collector \<equiv>
+.{\<acute>Proper}.
+ WHILE True INV .{\<acute>Proper}.
+ DO
+ Blacken_Roots;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:={};;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
+ \<acute>bc:=Roots;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
+ \<acute>Ma:=M_init;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>Ma=M_init}.
+ WHILE \<acute>obc\<noteq>\<acute>bc
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:=\<acute>bc;;
+ Propagate_Black;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}.
+ \<acute>Ma:=\<acute>M;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma
+ \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
+ \<acute>bc:={};;
+ Count
+ OD;;
+ Append
+ OD"
+
+lemma Collector:
+ "\<turnstile> Collector .{False}."
+apply(unfold Collector_def)
+apply annhoare
+apply(simp_all add: Blacken_Roots Propagate_Black Count Append)
+apply(simp_all add:Blacken_Roots_def Propagate_Black_def Count_def Append_def collector_defs)
+ apply (force simp add: Proper_Roots_def)
+ apply force
+ apply force
+apply clarify
+apply (erule disjE)
+apply(simp add:psubsetI)
+ apply(force dest:subset_antisym)
+done
+
+subsection {* Interference Freedom *}
+
+lemmas modules = Redirect_Edge_def Color_Target_def Blacken_Roots_def
+ Propagate_Black_def Count_def Append_def
+lemmas Invariants = PBInv_def Auxk_def CountInv_def AppendInv_def
+lemmas abbrev = collector_defs mutator_defs Invariants
+
+lemma interfree_Blacken_Roots_Redirect_Edge:
+ "interfree_aux (Some Blacken_Roots, {}, Some Redirect_Edge)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply (simp_all add:Graph6 Graph12 abbrev)
+done
+
+lemma interfree_Redirect_Edge_Blacken_Roots:
+ "interfree_aux (Some Redirect_Edge, {}, Some Blacken_Roots)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply(simp add:abbrev)+
+done
+
+lemma interfree_Blacken_Roots_Color_Target:
+ "interfree_aux (Some Blacken_Roots, {}, Some Color_Target)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:Graph7 Graph8 nth_list_update abbrev)
+done
+
+lemma interfree_Color_Target_Blacken_Roots:
+ "interfree_aux (Some Color_Target, {}, Some Blacken_Roots)"
+apply (unfold modules )
+apply interfree_aux
+apply safe
+apply(simp add:abbrev)+
+done
+
+lemma interfree_Propagate_Black_Redirect_Edge:
+ "interfree_aux (Some Propagate_Black, {}, Some Redirect_Edge)"
+apply (unfold modules )
+apply interfree_aux
+--{* 11 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+--{* 7 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+ apply(rule conjI)
+ apply (force simp add:BtoW_def)
+ apply(erule Graph4)
+ apply simp+
+apply(simp add:BtoW_def nth_list_update)
+apply force
+--{* 5 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+--{* 4 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+ apply(rule conjI)
+ apply (force simp add:BtoW_def)
+ apply(erule Graph4)
+ apply simp+
+apply(rule conjI)
+ apply(simp add:nth_list_update)
+ apply force
+apply(rule impI, rule impI, erule disjE, erule disjI1, case_tac "R = (ind x)" ,case_tac "M x ! T = Black")
+ apply(force simp add:BtoW_def)
+ apply(case_tac "M x !snd (E x ! ind x)=Black")
+ apply(rule disjI2)
+ apply simp
+ apply (erule Graph5)
+ apply simp+
+ apply(force simp add:BtoW_def)
+apply(force simp add:BtoW_def)
+--{* 3 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply clarify
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+done
+
+lemma interfree_Redirect_Edge_Propagate_Black:
+ "interfree_aux (Some Redirect_Edge, {}, Some Propagate_Black)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+done
+
+lemma interfree_Propagate_Black_Color_Target:
+ "interfree_aux (Some Propagate_Black, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+--{* 11 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)+
+apply(erule conjE)+
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 7 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(erule conjE)+
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply clarify
+apply (rule conjI)
+ apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(simp add:nth_list_update)
+--{* 5 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+--{* 4 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply (rule conjI)
+ apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(rule conjI)
+apply(simp add:nth_list_update)
+apply(rule impI,rule impI, case_tac "M x!T=Black",rotate_tac -1, force simp add: BtoW_def Graph10,
+ erule subset_psubset_trans, erule Graph11, force)
+--{* 3 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 3 subgoals left *}
+apply(simp add:abbrev)
+done
+
+lemma interfree_Color_Target_Propagate_Black:
+ "interfree_aux (Some Color_Target, {}, Some Propagate_Black)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+done
+
+lemma interfree_Count_Redirect_Edge:
+ "interfree_aux (Some Count, {}, Some Redirect_Edge)"
+apply (unfold modules)
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp_all add:abbrev Graph6 Graph12)
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12,
+ erule disjE,erule disjI1,rule disjI2,rule subset_trans, erule Graph3,force,force)+
+done
+
+lemma interfree_Redirect_Edge_Count:
+ "interfree_aux (Some Redirect_Edge, {}, Some Count)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify,simp add:abbrev)+
+apply(simp add:abbrev)
+done
+
+lemma interfree_Count_Color_Target:
+ "interfree_aux (Some Count, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp_all add:abbrev Graph7 Graph8 Graph12)
+--{* 6 subgoals left *}
+apply(clarify,simp add:abbrev Graph7 Graph8 Graph12,
+ erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)+
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
+apply(simp add:nth_list_update)
+--{* 1 subgoal left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12,
+ erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
+done
+
+lemma interfree_Color_Target_Count:
+ "interfree_aux (Some Color_Target, {}, Some Count)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+apply(simp add:abbrev)
+done
+
+lemma interfree_Append_Redirect_Edge:
+ "interfree_aux (Some Append, {}, Some Redirect_Edge)"
+apply (unfold modules )
+apply interfree_aux
+apply( simp_all add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12)
+apply(clarify, simp add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12, force dest:Graph3)+
+done
+
+lemma interfree_Redirect_Edge_Append:
+ "interfree_aux (Some Redirect_Edge, {}, Some Append)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Append_to_free0)+
+apply (force simp add: Append_to_free2)
+apply(clarify, simp add:abbrev Append_to_free0)+
+done
+
+lemma interfree_Append_Color_Target:
+ "interfree_aux (Some Append, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)+
+apply(simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)
+done
+
+lemma interfree_Color_Target_Append:
+ "interfree_aux (Some Color_Target, {}, Some Append)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Append_to_free0)+
+apply (force simp add: Append_to_free2)
+apply(clarify,simp add:abbrev Append_to_free0)+
+done
+
+lemmas collector_mutator_interfree =
+ interfree_Blacken_Roots_Redirect_Edge interfree_Blacken_Roots_Color_Target
+ interfree_Propagate_Black_Redirect_Edge interfree_Propagate_Black_Color_Target
+ interfree_Count_Redirect_Edge interfree_Count_Color_Target
+ interfree_Append_Redirect_Edge interfree_Append_Color_Target
+ interfree_Redirect_Edge_Blacken_Roots interfree_Color_Target_Blacken_Roots
+ interfree_Redirect_Edge_Propagate_Black interfree_Color_Target_Propagate_Black
+ interfree_Redirect_Edge_Count interfree_Color_Target_Count
+ interfree_Redirect_Edge_Append interfree_Color_Target_Append
+
+subsubsection {* Interference freedom Collector-Mutator *}
+
+lemma interfree_Collector_Mutator:
+ "interfree_aux (Some Collector, {}, Some Mutator)"
+apply(unfold Collector_def Mutator_def)
+apply interfree_aux
+apply(simp_all add:collector_mutator_interfree)
+apply(unfold modules collector_defs mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 32 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 20 subgoals left *}
+apply(tactic{* TRYALL (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(tactic {* TRYALL (etac disjE) *})
+apply simp_all
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,etac subset_trans,rtac @{thm Graph9},force_tac @{clasimpset}]) *})
+apply(tactic {* TRYALL(EVERY'[rtac disjI1,etac @{thm psubset_subset_trans},rtac @{thm Graph9},force_tac @{clasimpset}]) *})
+done
+
+subsubsection {* Interference freedom Mutator-Collector *}
+
+lemma interfree_Mutator_Collector:
+ "interfree_aux (Some Mutator, {}, Some Collector)"
+apply(unfold Collector_def Mutator_def)
+apply interfree_aux
+apply(simp_all add:collector_mutator_interfree)
+apply(unfold modules collector_defs mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 64 subgoals left *}
+apply(simp_all add:nth_list_update Invariants Append_to_free0)+
+apply(tactic{* TRYALL (clarify_tac @{claset}) *})
+--{* 4 subgoals left *}
+apply force
+apply(simp add:Append_to_free2)
+apply force
+apply(simp add:Append_to_free2)
+done
+
+subsubsection {* The Garbage Collection algorithm *}
+
+text {* In total there are 289 verification conditions. *}
+
+lemma Gar_Coll:
+ "\<parallel>- .{\<acute>Proper \<and> \<acute>Mut_init \<and> \<acute>z}.
+ COBEGIN
+ Collector
+ .{False}.
+ \<parallel>
+ Mutator
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+apply(force simp add: Mutator_def Collector_def modules)
+apply(rule Collector)
+apply(rule Mutator)
+apply(simp add:interfree_Collector_Mutator)
+apply(simp add:interfree_Mutator_Collector)
+apply force
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Graph.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,414 @@
+header {* \chapter{Case Study: Single and Multi-Mutator Garbage Collection Algorithms}
+
+\section {Formalization of the Memory} *}
+
+theory Graph imports Main begin
+
+datatype node = Black | White
+
+types
+ nodes = "node list"
+ edge = "nat \<times> nat"
+ edges = "edge list"
+
+consts Roots :: "nat set"
+
+constdefs
+ Proper_Roots :: "nodes \<Rightarrow> bool"
+ "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"
+
+ Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool"
+ "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"
+
+ BtoW :: "(edge \<times> nodes) \<Rightarrow> bool"
+ "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"
+
+ Blacks :: "nodes \<Rightarrow> nat set"
+ "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"
+
+ Reach :: "edges \<Rightarrow> nat set"
+ "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
+ \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
+ \<or> x\<in>Roots}"
+
+text{* Reach: the set of reachable nodes is the set of Roots together with the
+nodes reachable from some Root by a path represented by a list of
+ nodes (at least two since we traverse at least one edge), where two
+consecutive nodes correspond to an edge in E. *}
+
+subsection {* Proofs about Graphs *}
+
+lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
+declare Graph_defs [simp]
+
+subsubsection{* Graph 1 *}
+
+lemma Graph1_aux [rule_format]:
+ "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
+ \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
+ (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
+ \<longrightarrow> M!(path!0) = Black"
+apply(induct_tac "path")
+ apply force
+apply clarify
+apply simp
+apply(case_tac "list")
+ apply force
+apply simp
+apply(rotate_tac -2)
+apply(erule_tac x = "0" in all_dupE)
+apply simp
+apply clarify
+apply(erule allE , erule (1) notE impE)
+apply simp
+apply(erule mp)
+apply(case_tac "lista")
+ apply force
+apply simp
+apply(erule mp)
+apply clarify
+apply(erule_tac x = "Suc i" in allE)
+apply force
+done
+
+lemma Graph1:
+ "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
+ \<Longrightarrow> Reach E\<subseteq>Blacks M"
+apply (unfold Reach_def)
+apply simp
+apply clarify
+apply(erule disjE)
+ apply clarify
+ apply(rule conjI)
+ apply(subgoal_tac "0< length path - Suc 0")
+ apply(erule allE , erule (1) notE impE)
+ apply force
+ apply simp
+ apply(rule Graph1_aux)
+apply auto
+done
+
+subsubsection{* Graph 2 *}
+
+lemma Ex_first_occurrence [rule_format]:
+ "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))";
+apply(rule nat_less_induct)
+apply clarify
+apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
+apply auto
+done
+
+lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
+apply(rule_tac x = "l - n" in exI)
+apply arith
+done
+
+lemma Ex_last_occurrence:
+ "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
+apply(drule Compl_lemma)
+apply clarify
+apply(erule Ex_first_occurrence)
+done
+
+lemma Graph2:
+ "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
+apply (unfold Reach_def)
+apply clarify
+apply simp
+apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
+ apply(rule_tac x = "path" in exI)
+ apply simp
+ apply clarify
+ apply(erule allE , erule (1) notE impE)
+ apply clarify
+ apply(rule_tac x = "j" in exI)
+ apply(case_tac "j=R")
+ apply(erule_tac x = "Suc i" in allE)
+ apply simp
+ apply (force simp add:nth_list_update)
+apply simp
+apply(erule exE)
+apply(subgoal_tac "z \<le> length path - Suc 0")
+ prefer 2 apply arith
+apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
+ apply assumption
+apply clarify
+apply simp
+apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
+apply simp
+apply(case_tac "length path - (length path - Suc m)")
+ apply arith
+apply simp
+apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
+ prefer 2 apply arith
+apply(drule nth_drop)
+apply simp
+apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
+ prefer 2 apply arith
+apply simp
+apply clarify
+apply(case_tac "i")
+ apply(force simp add: nth_list_update)
+apply simp
+apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
+ prefer 2 apply arith
+apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
+ prefer 2 apply arith
+apply simp
+apply(erule_tac x = "length path - Suc m + nata" in allE)
+apply simp
+apply clarify
+apply(rule_tac x = "j" in exI)
+apply(case_tac "R=j")
+ prefer 2 apply force
+apply simp
+apply(drule_tac t = "path ! (length path - Suc m)" in sym)
+apply simp
+apply(case_tac " length path - Suc 0 < m")
+ apply(subgoal_tac "(length path - Suc m)=0")
+ prefer 2 apply arith
+ apply(simp del: diff_is_0_eq)
+ apply(subgoal_tac "Suc nata\<le>nat")
+ prefer 2 apply arith
+ apply(drule_tac n = "Suc nata" in Compl_lemma)
+ apply clarify
+ using [[linarith_split_limit = 0]]
+ apply force
+ using [[linarith_split_limit = 9]]
+apply(drule leI)
+apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
+ apply(erule_tac x = "m - (Suc nata)" in allE)
+ apply(case_tac "m")
+ apply simp
+ apply simp
+apply simp
+done
+
+
+subsubsection{* Graph 3 *}
+
+declare min_max.inf_absorb1 [simp] min_max.inf_absorb2 [simp]
+
+lemma Graph3:
+ "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
+apply (unfold Reach_def)
+apply clarify
+apply simp
+apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
+--{* the changed edge is part of the path *}
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
+ apply clarify
+ apply(erule disjE)
+--{* T is NOT a root *}
+ apply clarify
+ apply(rule_tac x = "(take m path)@patha" in exI)
+ apply(subgoal_tac "\<not>(length path\<le>m)")
+ prefer 2 apply arith
+ apply(simp)
+ apply(rule conjI)
+ apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
+ prefer 2 apply arith
+ apply(simp add: nth_append)
+ apply(rule conjI)
+ apply(case_tac "m")
+ apply force
+ apply(case_tac "path")
+ apply force
+ apply force
+ apply clarify
+ apply(case_tac "Suc i\<le>m")
+ apply(erule_tac x = "i" in allE)
+ apply simp
+ apply clarify
+ apply(rule_tac x = "j" in exI)
+ apply(case_tac "Suc i<m")
+ apply(simp add: nth_append)
+ apply(case_tac "R=j")
+ apply(simp add: nth_list_update)
+ apply(case_tac "i=m")
+ apply force
+ apply(erule_tac x = "i" in allE)
+ apply force
+ apply(force simp add: nth_list_update)
+ apply(simp add: nth_append)
+ apply(subgoal_tac "i=m - 1")
+ prefer 2 apply arith
+ apply(case_tac "R=j")
+ apply(erule_tac x = "m - 1" in allE)
+ apply(simp add: nth_list_update)
+ apply(force simp add: nth_list_update)
+ apply(simp add: nth_append)
+ apply(rotate_tac -4)
+ apply(erule_tac x = "i - m" in allE)
+ apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
+ prefer 2 apply arith
+ apply simp
+--{* T is a root *}
+ apply(case_tac "m=0")
+ apply force
+ apply(rule_tac x = "take (Suc m) path" in exI)
+ apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
+ prefer 2 apply arith
+ apply clarsimp
+ apply(erule_tac x = "i" in allE)
+ apply simp
+ apply clarify
+ apply(case_tac "R=j")
+ apply(force simp add: nth_list_update)
+ apply(force simp add: nth_list_update)
+--{* the changed edge is not part of the path *}
+apply(rule_tac x = "path" in exI)
+apply simp
+apply clarify
+apply(erule_tac x = "i" in allE)
+apply clarify
+apply(case_tac "R=j")
+ apply(erule_tac x = "i" in allE)
+ apply simp
+apply(force simp add: nth_list_update)
+done
+
+subsubsection{* Graph 4 *}
+
+lemma Graph4:
+ "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
+ \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
+ (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
+apply (unfold Reach_def)
+apply simp
+apply(erule disjE)
+ prefer 2 apply force
+apply clarify
+--{* there exist a black node in the path to T *}
+apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
+ apply clarify
+ apply(case_tac "ma")
+ apply force
+ apply simp
+ apply(case_tac "length path")
+ apply force
+ apply simp
+ apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply clarify
+ apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply(case_tac "j<I")
+ apply(erule_tac x = "j" in allE)
+ apply force
+ apply(rule_tac x = "j" in exI)
+ apply(force simp add: nth_list_update)
+apply simp
+apply(rotate_tac -1)
+apply(erule_tac x = "length path - 1" in allE)
+apply(case_tac "length path")
+ apply force
+apply force
+done
+
+declare min_max.inf_absorb1 [simp del] min_max.inf_absorb2 [simp del]
+
+subsubsection {* Graph 5 *}
+
+lemma Graph5:
+ "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
+ R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
+ \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
+apply (unfold Reach_def)
+apply simp
+apply(erule disjE)
+ prefer 2 apply force
+apply clarify
+--{* there exist a black node in the path to T*}
+apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
+ apply clarify
+ apply(case_tac "ma")
+ apply force
+ apply simp
+ apply(case_tac "length path")
+ apply force
+ apply simp
+ apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply clarify
+ apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply(case_tac "j\<le>R")
+ apply(drule le_imp_less_or_eq [of _ R])
+ apply(erule disjE)
+ apply(erule allE , erule (1) notE impE)
+ apply force
+ apply force
+ apply(rule_tac x = "j" in exI)
+ apply(force simp add: nth_list_update)
+apply simp
+apply(rotate_tac -1)
+apply(erule_tac x = "length path - 1" in allE)
+apply(case_tac "length path")
+ apply force
+apply force
+done
+
+subsubsection {* Other lemmas about graphs *}
+
+lemma Graph6:
+ "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
+apply (unfold Proper_Edges_def)
+ apply(force simp add: nth_list_update)
+done
+
+lemma Graph7:
+ "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
+apply (unfold Proper_Edges_def)
+apply force
+done
+
+lemma Graph8:
+ "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
+apply (unfold Proper_Roots_def)
+apply force
+done
+
+text{* Some specific lemmata for the verification of garbage collection algorithms. *}
+
+lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+ apply(force simp add: nth_list_update)
+done
+
+lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
+apply(induct_tac "M")
+apply auto
+apply(case_tac "i")
+apply auto
+done
+
+lemma Graph11 [rule_format (no_asm)]:
+ "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(rule psubsetI)
+ apply(force simp add: nth_list_update)
+apply safe
+apply(erule_tac c = "j" in equalityCE)
+apply auto
+done
+
+lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(force simp add: nth_list_update)
+done
+
+lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(erule psubset_subset_trans)
+apply(force simp add: nth_list_update)
+done
+
+declare Graph_defs [simp del]
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Hoare_Parallel.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,5 @@
+theory Hoare_Parallel
+imports OG_Examples Gar_Coll Mul_Gar_Coll RG_Examples
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Mul_Gar_Coll.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1281 @@
+
+header {* \section{The Multi-Mutator Case} *}
+
+theory Mul_Gar_Coll imports Graph OG_Syntax begin
+
+text {* The full theory takes aprox. 18 minutes. *}
+
+record mut =
+ Z :: bool
+ R :: nat
+ T :: nat
+
+text {* Declaration of variables: *}
+
+record mul_gar_coll_state =
+ M :: nodes
+ E :: edges
+ bc :: "nat set"
+ obc :: "nat set"
+ Ma :: nodes
+ ind :: nat
+ k :: nat
+ q :: nat
+ l :: nat
+ Muts :: "mut list"
+
+subsection {* The Mutators *}
+
+constdefs
+ Mul_mut_init :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_mut_init \<equiv> \<guillemotleft> \<lambda>n. n=length \<acute>Muts \<and> (\<forall>i<n. R (\<acute>Muts!i)<length \<acute>E
+ \<and> T (\<acute>Muts!i)<length \<acute>M) \<guillemotright>"
+
+ Mul_Redirect_Edge :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Redirect_Edge j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ \<langle>IF T(\<acute>Muts!j) \<in> Reach \<acute>E THEN
+ \<acute>E:= \<acute>E[R (\<acute>Muts!j):= (fst (\<acute>E!R(\<acute>Muts!j)), T (\<acute>Muts!j))] FI,,
+ \<acute>Muts:= \<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=False\<rparr>]\<rangle>"
+
+ Mul_Color_Target :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Color_Target j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> \<not> Z (\<acute>Muts!j)}.
+ \<langle>\<acute>M:=\<acute>M[T (\<acute>Muts!j):=Black],, \<acute>Muts:=\<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=True\<rparr>]\<rangle>"
+
+ Mul_Mutator :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Mutator j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ WHILE True
+ INV .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ DO Mul_Redirect_Edge j n ;;
+ Mul_Color_Target j n
+ OD"
+
+lemmas mul_mutator_defs = Mul_mut_init_def Mul_Redirect_Edge_def Mul_Color_Target_def
+
+subsubsection {* Correctness of the proof outline of one mutator *}
+
+lemma Mul_Redirect_Edge: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Redirect_Edge j n
+ pre(Mul_Color_Target j n)"
+apply (unfold mul_mutator_defs)
+apply annhoare
+apply(simp_all)
+apply clarify
+apply(simp add:nth_list_update)
+done
+
+lemma Mul_Color_Target: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Color_Target j n
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}."
+apply (unfold mul_mutator_defs)
+apply annhoare
+apply(simp_all)
+apply clarify
+apply(simp add:nth_list_update)
+done
+
+lemma Mul_Mutator: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Mutator j n .{False}."
+apply(unfold Mul_Mutator_def)
+apply annhoare
+apply(simp_all add:Mul_Redirect_Edge Mul_Color_Target)
+apply(simp add:mul_mutator_defs Mul_Redirect_Edge_def)
+done
+
+subsubsection {* Interference freedom between mutators *}
+
+lemma Mul_interfree_Redirect_Edge_Redirect_Edge:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some (Mul_Redirect_Edge i n),{}, Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Color_Target:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge i n),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Redirect_Edge:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add:nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Color_Target:
+ " \<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemmas mul_mutator_interfree =
+ Mul_interfree_Redirect_Edge_Redirect_Edge Mul_interfree_Redirect_Edge_Color_Target
+ Mul_interfree_Color_Target_Redirect_Edge Mul_interfree_Color_Target_Color_Target
+
+lemma Mul_interfree_Mutator_Mutator: "\<lbrakk>i < n; j < n; i \<noteq> j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some (Mul_Mutator i n), {}, Some (Mul_Mutator j n))"
+apply(unfold Mul_Mutator_def)
+apply(interfree_aux)
+apply(simp_all add:mul_mutator_interfree)
+apply(simp_all add: mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply (simp_all add:nth_list_update)
+done
+
+subsubsection {* Modular Parameterized Mutators *}
+
+lemma Mul_Parameterized_Mutators: "0<n \<Longrightarrow>
+ \<parallel>- .{\<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
+ COBEGIN
+ SCHEME [0\<le> j< n]
+ Mul_Mutator j n
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
+apply(erule Mul_Mutator)
+apply(simp add:Mul_interfree_Mutator_Mutator)
+apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
+done
+
+subsection {* The Collector *}
+
+constdefs
+ Queue :: "mul_gar_coll_state \<Rightarrow> nat"
+ "Queue \<equiv> \<guillemotleft> length (filter (\<lambda>i. \<not> Z i \<and> \<acute>M!(T i) \<noteq> Black) \<acute>Muts) \<guillemotright>"
+
+consts M_init :: nodes
+
+constdefs
+ Proper_M_init :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
+
+ Mul_Proper :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_Proper \<equiv> \<guillemotleft> \<lambda>n. Proper_Roots \<acute>M \<and> Proper_Edges (\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<and> n=length \<acute>Muts \<guillemotright>"
+
+ Safe :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
+
+lemmas mul_collector_defs = Proper_M_init_def Mul_Proper_def Safe_def
+
+subsubsection {* Blackening Roots *}
+
+constdefs
+ Mul_Blacken_Roots :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Blacken_Roots n \<equiv>
+ .{\<acute>Mul_Proper n}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>ind\<in>Roots THEN
+ .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
+ \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
+ .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind+1. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Blacken_Roots:
+ "\<turnstile> Mul_Blacken_Roots n
+ .{\<acute>Mul_Proper n \<and> Roots \<subseteq> Blacks \<acute>M}."
+apply (unfold Mul_Blacken_Roots_def)
+apply annhoare
+apply(simp_all add:mul_collector_defs Graph_defs)
+apply safe
+apply(simp_all add:nth_list_update)
+ apply (erule less_SucE)
+ apply simp+
+ apply force
+apply force
+done
+
+subsubsection {* Propagating Black *}
+
+constdefs
+ Mul_PBInv :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Mul_PBInv \<equiv> \<guillemotleft>\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M)) \<and> \<acute>l\<le>\<acute>Queue\<guillemotright>"
+
+ Mul_Auxk :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Mul_Auxk \<equiv> \<guillemotleft>\<acute>l<\<acute>Queue \<or> \<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or> \<acute>obc\<subset>Blacks \<acute>M\<guillemotright>"
+
+constdefs
+ Mul_Propagate_Black :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Propagate_Black n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> Blacks \<acute>M\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
+ IF \<acute>M!(fst (\<acute>E!\<acute>ind))=Black THEN
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black \<and> \<acute>ind<length \<acute>E}.
+ \<acute>k:=snd(\<acute>E!\<acute>ind);;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M))
+ \<and> \<acute>l\<le>\<acute>Queue \<and> \<acute>Mul_Auxk ) \<and> \<acute>k<length \<acute>M \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black
+ \<and> \<acute>ind<length \<acute>E}.
+ \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],,\<acute>ind:=\<acute>ind+1\<rangle>
+ ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
+ \<langle>IF \<acute>M!(fst (\<acute>E!\<acute>ind))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle> FI
+ OD"
+
+lemma Mul_Propagate_Black:
+ "\<turnstile> Mul_Propagate_Black n
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}."
+apply(unfold Mul_Propagate_Black_def)
+apply annhoare
+apply(simp_all add:Mul_PBInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
+--{* 8 subgoals left *}
+apply force
+apply force
+apply force
+apply(force simp add:BtoW_def Graph_defs)
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add: mul_collector_defs Graph12 Graph6 Graph7 Graph8)
+apply(disjE_tac)
+ apply(simp_all add:Graph12 Graph13)
+ apply(case_tac "M x! k x=Black")
+ apply(simp add: Graph10)
+ apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(case_tac "M x! k x=Black")
+ apply(simp add: Graph10 BtoW_def)
+ apply(rule disjI2, clarify, erule less_SucE, force)
+ apply(case_tac "M x!snd(E x! ind x)=Black")
+ apply(force)
+ apply(force)
+apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 2 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply (simp_all)
+apply clarify
+apply(erule less_SucE)
+ apply force
+apply (simp add:BtoW_def)
+--{* 1 subgoal left *}
+apply clarify
+apply simp
+apply(disjE_tac)
+apply (simp_all)
+apply(rule disjI1 , rule Graph1)
+ apply simp_all
+done
+
+subsubsection {* Counting Black Nodes *}
+
+constdefs
+ Mul_CountInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
+
+ Mul_Count :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Count n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
+ \<and> \<acute>q<n+1 \<and> \<acute>bc={}}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
+ \<and> \<acute>q<n+1 \<and> \<acute>bc={} \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black
+ THEN .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>bc:=insert \<acute>ind \<acute>bc
+ FI;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv (\<acute>ind+1)
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Count:
+ "\<turnstile> Mul_Count n
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1}."
+apply (unfold Mul_Count_def)
+apply annhoare
+apply(simp_all add:Mul_CountInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
+--{* 7 subgoals left *}
+apply force
+apply force
+apply force
+--{* 4 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply simp_all
+apply(simp add:Blacks_def)
+apply clarify
+apply(erule less_SucE)
+ back
+ apply force
+apply force
+--{* 3 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply simp_all
+apply clarify
+apply(erule less_SucE)
+ back
+ apply force
+apply simp
+apply(rotate_tac -1)
+apply (force simp add:Blacks_def)
+--{* 2 subgoals left *}
+apply force
+--{* 1 subgoal left *}
+apply clarify
+apply(drule_tac x = "ind x" in le_imp_less_or_eq)
+apply (simp_all add:Blacks_def)
+done
+
+subsubsection {* Appending garbage nodes to the free list *}
+
+consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
+
+axioms
+ Append_to_free0: "length (Append_to_free (i, e)) = length e"
+ Append_to_free1: "Proper_Edges (m, e)
+ \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
+ Append_to_free2: "i \<notin> Reach e
+ \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
+
+constdefs
+ Mul_AppendInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_AppendInv \<equiv> \<guillemotleft> \<lambda>ind. (\<forall>i. ind\<le>i \<longrightarrow> i<length \<acute>M \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black)\<guillemotright>"
+
+ Mul_Append :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Append n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black THEN
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>M:=\<acute>M[\<acute>ind:=White]
+ ELSE
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
+ \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
+ FI;;
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Append:
+ "\<turnstile> Mul_Append n
+ .{\<acute>Mul_Proper n}."
+apply(unfold Mul_Append_def)
+apply annhoare
+apply(simp_all add: mul_collector_defs Mul_AppendInv_def
+ Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(force simp add:Blacks_def)
+apply(force simp add:Blacks_def)
+apply(force simp add:Blacks_def)
+apply(force simp add:Graph_defs)
+apply force
+apply(force simp add:Append_to_free1 Append_to_free2)
+apply force
+apply force
+done
+
+subsubsection {* Collector *}
+
+constdefs
+ Mul_Collector :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Collector n \<equiv>
+.{\<acute>Mul_Proper n}.
+WHILE True INV .{\<acute>Mul_Proper n}.
+DO
+Mul_Blacken_Roots n ;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:={};;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
+ \<acute>bc:=Roots;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
+ \<acute>l:=0;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>l=0}.
+ WHILE \<acute>l<n+1
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and>
+ (\<acute>Safe \<or> (\<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M) \<and> \<acute>l<n+1)}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M)}.
+ \<acute>obc:=\<acute>bc;;
+ Mul_Propagate_Black n;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}.
+ \<acute>bc:={};;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)) \<and> \<acute>bc={}}.
+ \<langle> \<acute>Ma:=\<acute>M,, \<acute>q:=\<acute>Queue \<rangle>;;
+ Mul_Count n;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1}.
+ IF \<acute>obc=\<acute>bc THEN
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>obc=\<acute>bc}.
+ \<acute>l:=\<acute>l+1
+ ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>obc\<noteq>\<acute>bc}.
+ \<acute>l:=0 FI
+ OD;;
+ Mul_Append n
+OD"
+
+lemmas mul_modules = Mul_Redirect_Edge_def Mul_Color_Target_def
+ Mul_Blacken_Roots_def Mul_Propagate_Black_def
+ Mul_Count_def Mul_Append_def
+
+lemma Mul_Collector:
+ "\<turnstile> Mul_Collector n
+ .{False}."
+apply(unfold Mul_Collector_def)
+apply annhoare
+apply(simp_all only:pre.simps Mul_Blacken_Roots
+ Mul_Propagate_Black Mul_Count Mul_Append)
+apply(simp_all add:mul_modules)
+apply(simp_all add:mul_collector_defs Queue_def)
+apply force
+apply force
+apply force
+apply (force simp add: less_Suc_eq_le)
+apply force
+apply (force dest:subset_antisym)
+apply force
+apply force
+apply force
+done
+
+subsection {* Interference Freedom *}
+
+lemma le_length_filter_update[rule_format]:
+ "\<forall>i. (\<not>P (list!i) \<or> P j) \<and> i<length list
+ \<longrightarrow> length(filter P list) \<le> length(filter P (list[i:=j]))"
+apply(induct_tac "list")
+ apply(simp)
+apply(clarify)
+apply(case_tac i)
+ apply(simp)
+apply(simp)
+done
+
+lemma less_length_filter_update [rule_format]:
+ "\<forall>i. P j \<and> \<not>(P (list!i)) \<and> i<length list
+ \<longrightarrow> length(filter P list) < length(filter P (list[i:=j]))"
+apply(induct_tac "list")
+ apply(simp)
+apply(clarify)
+apply(case_tac i)
+ apply(simp)
+apply(simp)
+done
+
+lemma Mul_interfree_Blacken_Roots_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Blacken_Roots n),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:Graph6 Graph9 Graph12 nth_list_update mul_mutator_defs mul_collector_defs)
+done
+
+lemma Mul_interfree_Redirect_Edge_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Blacken_Roots n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Blacken_Roots_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Blacken_Roots n),{},Some (Mul_Color_Target j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs mul_collector_defs nth_list_update Graph7 Graph8 Graph9 Graph12)
+done
+
+lemma Mul_interfree_Color_Target_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n ),{},Some (Mul_Blacken_Roots n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Propagate_Black_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Redirect_Edge j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_PBInv_def nth_list_update Graph6)
+--{* 7 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 6 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 5 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+--{* 4 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+--{* 3 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply (rule impI)
+ apply(rule conjI)
+ apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule conjI)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(erule conjE)
+ apply(rule conjI)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule impI,rule conjI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI,rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+ apply(case_tac "R (Muts x! j)=ind x")
+ apply (force simp add: nth_list_update)
+ apply (force simp add: nth_list_update)
+apply(rule impI, (rule disjI2)+, erule le_trans)
+apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 2 subgoals left *}
+apply clarify
+apply(rule conjI)
+ apply(disjE_tac)
+ apply(simp_all add:Mul_Auxk_def Graph6)
+ apply (rule impI)
+ apply(rule conjI)
+ apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+apply(rule impI)
+apply(rule conjI)
+ apply(erule conjE)+
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(rule conjI)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update BtoW_def)
+ apply (simp add:nth_list_update)
+ apply(rule impI)
+ apply simp
+ apply(disjE_tac)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply force
+ apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+apply(disjE_tac)
+apply simp_all
+apply(conjI_tac)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)+
+apply(rule impI,(rule disjI2)+,rule conjI)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI)+
+apply simp
+apply(disjE_tac)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply force
+--{* 1 subgoal left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Propagate_Black n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Propagate_Black_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Color_Target j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add: mul_collector_defs mul_mutator_defs)
+--{* 7 subgoals left *}
+apply clarify
+apply (simp add:Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 6 subgoals left *}
+apply clarify
+apply (simp add:Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 5 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+)
+ apply (rule conjI)
+ apply(simp add:Graph10)
+ apply(erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+--{* 4 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+)
+ apply (rule conjI)
+ apply(simp add:Graph10)
+ apply(erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+--{* 3 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)
+ apply((rule disjI2)+,erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule conjI)
+ apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+apply (force simp add:nth_list_update)
+--{* 2 subgoals left *}
+apply clarify
+apply(simp add:Mul_Auxk_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)+
+ apply((rule disjI2)+,rule conjI, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule impI)+)
+ apply simp
+ apply(erule disjE)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply force
+apply(rule conjI)
+ apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+apply (force simp add:nth_list_update)
+--{* 1 subgoal left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)
+ apply((rule disjI2)+,erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+done
+
+lemma Mul_interfree_Color_Target_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{},Some(Mul_Propagate_Black n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Count_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Count n ),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 8 subgoals left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+--{* 7 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 6 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6 Queue_def)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 5 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 4 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 3 subgoals left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+--{* 2 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 1 subgoal left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Count n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Count_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Count n ),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add:mul_collector_defs mul_mutator_defs Mul_CountInv_def)
+--{* 6 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 5 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 4 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 3 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 2 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
+ apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(rule conjI)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+ apply (simp add: nth_list_update)
+apply (simp add: Graph7 Graph8 Graph12)
+apply(rule conjI)
+ apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+apply (simp add: nth_list_update)
+--{* 1 subgoal left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+done
+
+lemma Mul_interfree_Color_Target_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Count n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Append_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Append n),{}, Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Append_to_free0 Append_to_free1 mul_collector_defs mul_mutator_defs Mul_AppendInv_def)
+apply(erule_tac x=j in allE, force dest:Graph3)+
+done
+
+lemma Mul_interfree_Redirect_Edge_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Append n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:mul_collector_defs Append_to_free0 Mul_AppendInv_def mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Append_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Append n),{}, Some(Mul_Color_Target j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_AppendInv_def Graph7 Graph8 Append_to_free0 Append_to_free1
+ Graph12 nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Append n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add: mul_mutator_defs nth_list_update)
+apply(simp add:Mul_AppendInv_def Append_to_free0)
+done
+
+subsubsection {* Interference freedom Collector-Mutator *}
+
+lemmas mul_collector_mutator_interfree =
+ Mul_interfree_Blacken_Roots_Redirect_Edge Mul_interfree_Blacken_Roots_Color_Target
+ Mul_interfree_Propagate_Black_Redirect_Edge Mul_interfree_Propagate_Black_Color_Target
+ Mul_interfree_Count_Redirect_Edge Mul_interfree_Count_Color_Target
+ Mul_interfree_Append_Redirect_Edge Mul_interfree_Append_Color_Target
+ Mul_interfree_Redirect_Edge_Blacken_Roots Mul_interfree_Color_Target_Blacken_Roots
+ Mul_interfree_Redirect_Edge_Propagate_Black Mul_interfree_Color_Target_Propagate_Black
+ Mul_interfree_Redirect_Edge_Count Mul_interfree_Color_Target_Count
+ Mul_interfree_Redirect_Edge_Append Mul_interfree_Color_Target_Append
+
+lemma Mul_interfree_Collector_Mutator: "j<n \<Longrightarrow>
+ interfree_aux (Some (Mul_Collector n), {}, Some (Mul_Mutator j n))"
+apply(unfold Mul_Collector_def Mul_Mutator_def)
+apply interfree_aux
+apply(simp_all add:mul_collector_mutator_interfree)
+apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 42 subgoals left *}
+apply (clarify,simp add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)+
+--{* 24 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 14 subgoals left *}
+apply(tactic {* TRYALL (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(tactic {* TRYALL (rtac conjI) *})
+apply(tactic {* TRYALL (rtac impI) *})
+apply(tactic {* TRYALL (etac disjE) *})
+apply(tactic {* TRYALL (etac conjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+--{* 72 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 35 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI1,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
+--{* 28 subgoals left *}
+apply(tactic {* TRYALL (etac conjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+--{* 34 subgoals left *}
+apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(case_tac [!] "M x!(T (Muts x ! j))=Black")
+apply(simp_all add:Graph10)
+--{* 47 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 41 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
+--{* 35 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "psubset_subset_trans"),rtac (thm "Graph9"),force_tac @{clasimpset}]) *})
+--{* 31 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 29 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 25 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
+--{* 10 subgoals left *}
+apply(rule disjI2,rule disjI2,rule conjI,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update, rule disjI1, rule less_imp_le, erule less_le_trans, force simp add:Queue_def less_Suc_eq_le le_length_filter_update)+
+done
+
+subsubsection {* Interference freedom Mutator-Collector *}
+
+lemma Mul_interfree_Mutator_Collector: " j < n \<Longrightarrow>
+ interfree_aux (Some (Mul_Mutator j n), {}, Some (Mul_Collector n))"
+apply(unfold Mul_Collector_def Mul_Mutator_def)
+apply interfree_aux
+apply(simp_all add:mul_collector_mutator_interfree)
+apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 76 subgoals left *}
+apply (clarsimp simp add: nth_list_update)+
+--{* 56 subgoals left *}
+apply (clarsimp simp add: Mul_AppendInv_def Append_to_free0 nth_list_update)+
+done
+
+subsubsection {* The Multi-Mutator Garbage Collection Algorithm *}
+
+text {* The total number of verification conditions is 328 *}
+
+lemma Mul_Gar_Coll:
+ "\<parallel>- .{\<acute>Mul_Proper n \<and> \<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
+ COBEGIN
+ Mul_Collector n
+ .{False}.
+ \<parallel>
+ SCHEME [0\<le> j< n]
+ Mul_Mutator j n
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* Strengthening the precondition *}
+apply(rule Int_greatest)
+ apply (case_tac n)
+ apply(force simp add: Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+ apply(simp add: Mul_Mutator_def mul_collector_defs mul_mutator_defs nth_append)
+ apply force
+apply clarify
+apply(case_tac i)
+ apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+apply(simp add: Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append nth_map_upt)
+--{* Collector *}
+apply(rule Mul_Collector)
+--{* Mutator *}
+apply(erule Mul_Mutator)
+--{* Interference freedom *}
+apply(simp add:Mul_interfree_Collector_Mutator)
+apply(simp add:Mul_interfree_Mutator_Collector)
+apply(simp add:Mul_interfree_Mutator_Mutator)
+--{* Weakening of the postcondition *}
+apply(case_tac n)
+ apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+apply(simp add:Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Com.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,55 @@
+
+header {* \chapter{The Owicki-Gries Method}
+
+\section{Abstract Syntax} *}
+
+theory OG_Com imports Main begin
+
+text {* Type abbreviations for boolean expressions and assertions: *}
+
+types
+ 'a bexp = "'a set"
+ 'a assn = "'a set"
+
+text {* The syntax of commands is defined by two mutually recursive
+datatypes: @{text "'a ann_com"} for annotated commands and @{text "'a
+com"} for non-annotated commands. *}
+
+datatype 'a ann_com =
+ AnnBasic "('a assn)" "('a \<Rightarrow> 'a)"
+ | AnnSeq "('a ann_com)" "('a ann_com)"
+ | AnnCond1 "('a assn)" "('a bexp)" "('a ann_com)" "('a ann_com)"
+ | AnnCond2 "('a assn)" "('a bexp)" "('a ann_com)"
+ | AnnWhile "('a assn)" "('a bexp)" "('a assn)" "('a ann_com)"
+ | AnnAwait "('a assn)" "('a bexp)" "('a com)"
+and 'a com =
+ Parallel "('a ann_com option \<times> 'a assn) list"
+ | Basic "('a \<Rightarrow> 'a)"
+ | Seq "('a com)" "('a com)"
+ | Cond "('a bexp)" "('a com)" "('a com)"
+ | While "('a bexp)" "('a assn)" "('a com)"
+
+text {* The function @{text pre} extracts the precondition of an
+annotated command: *}
+
+consts
+ pre ::"'a ann_com \<Rightarrow> 'a assn"
+primrec
+ "pre (AnnBasic r f) = r"
+ "pre (AnnSeq c1 c2) = pre c1"
+ "pre (AnnCond1 r b c1 c2) = r"
+ "pre (AnnCond2 r b c) = r"
+ "pre (AnnWhile r b i c) = r"
+ "pre (AnnAwait r b c) = r"
+
+text {* Well-formedness predicate for atomic programs: *}
+
+consts atom_com :: "'a com \<Rightarrow> bool"
+primrec
+ "atom_com (Parallel Ts) = False"
+ "atom_com (Basic f) = True"
+ "atom_com (Seq c1 c2) = (atom_com c1 \<and> atom_com c2)"
+ "atom_com (Cond b c1 c2) = (atom_com c1 \<and> atom_com c2)"
+ "atom_com (While b i c) = atom_com c"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Examples.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,549 @@
+
+header {* \section{Examples} *}
+
+theory OG_Examples imports OG_Syntax begin
+
+subsection {* Mutual Exclusion *}
+
+subsubsection {* Peterson's Algorithm I*}
+
+text {* Eike Best. "Semantics of Sequential and Parallel Programs", page 217. *}
+
+record Petersons_mutex_1 =
+ pr1 :: nat
+ pr2 :: nat
+ in1 :: bool
+ in2 :: bool
+ hold :: nat
+
+lemma Petersons_mutex_1:
+ "\<parallel>- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 }.
+ COBEGIN .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ WHILE True INV .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ DO
+ .{\<acute>pr1=0 \<and> \<not>\<acute>in1}. \<langle> \<acute>in1:=True,,\<acute>pr1:=1 \<rangle>;;
+ .{\<acute>pr1=1 \<and> \<acute>in1}. \<langle> \<acute>hold:=1,,\<acute>pr1:=2 \<rangle>;;
+ .{\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
+ AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
+ .{\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
+ \<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
+ OD .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ \<parallel>
+ .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ WHILE True INV .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ DO
+ .{\<acute>pr2=0 \<and> \<not>\<acute>in2}. \<langle> \<acute>in2:=True,,\<acute>pr2:=1 \<rangle>;;
+ .{\<acute>pr2=1 \<and> \<acute>in2}. \<langle> \<acute>hold:=2,,\<acute>pr2:=2 \<rangle>;;
+ .{\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
+ AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
+ .{\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
+ \<langle>\<acute>in2:=False,,\<acute>pr2:=0\<rangle>
+ OD .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ COEND
+ .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2}."
+apply oghoare
+--{* 104 verification conditions. *}
+apply auto
+done
+
+subsubsection {*Peterson's Algorithm II: A Busy Wait Solution *}
+
+text {* Apt and Olderog. "Verification of sequential and concurrent Programs", page 282. *}
+
+record Busy_wait_mutex =
+ flag1 :: bool
+ flag2 :: bool
+ turn :: nat
+ after1 :: bool
+ after2 :: bool
+
+lemma Busy_wait_mutex:
+ "\<parallel>- .{True}.
+ \<acute>flag1:=False,, \<acute>flag2:=False,,
+ COBEGIN .{\<not>\<acute>flag1}.
+ WHILE True
+ INV .{\<not>\<acute>flag1}.
+ DO .{\<not>\<acute>flag1}. \<langle> \<acute>flag1:=True,,\<acute>after1:=False \<rangle>;;
+ .{\<acute>flag1 \<and> \<not>\<acute>after1}. \<langle> \<acute>turn:=1,,\<acute>after1:=True \<rangle>;;
+ .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ WHILE \<not>(\<acute>flag2 \<longrightarrow> \<acute>turn=2)
+ INV .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ DO .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
+ .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>flag2 \<and> \<acute>after2 \<longrightarrow> \<acute>turn=2)}.
+ \<acute>flag1:=False
+ OD
+ .{False}.
+ \<parallel>
+ .{\<not>\<acute>flag2}.
+ WHILE True
+ INV .{\<not>\<acute>flag2}.
+ DO .{\<not>\<acute>flag2}. \<langle> \<acute>flag2:=True,,\<acute>after2:=False \<rangle>;;
+ .{\<acute>flag2 \<and> \<not>\<acute>after2}. \<langle> \<acute>turn:=2,,\<acute>after2:=True \<rangle>;;
+ .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ WHILE \<not>(\<acute>flag1 \<longrightarrow> \<acute>turn=1)
+ INV .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ DO .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
+ .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>flag1 \<and> \<acute>after1 \<longrightarrow> \<acute>turn=1)}.
+ \<acute>flag2:=False
+ OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 122 vc *}
+apply auto
+done
+
+subsubsection {* Peterson's Algorithm III: A Solution using Semaphores *}
+
+record Semaphores_mutex =
+ out :: bool
+ who :: nat
+
+lemma Semaphores_mutex:
+ "\<parallel>- .{i\<noteq>j}.
+ \<acute>out:=True ,,
+ COBEGIN .{i\<noteq>j}.
+ WHILE True INV .{i\<noteq>j}.
+ DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
+ .{\<not>\<acute>out \<and> \<acute>who=i \<and> i\<noteq>j}. \<acute>out:=True OD
+ .{False}.
+ \<parallel>
+ .{i\<noteq>j}.
+ WHILE True INV .{i\<noteq>j}.
+ DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,,\<acute>who:=j END;;
+ .{\<not>\<acute>out \<and> \<acute>who=j \<and> i\<noteq>j}. \<acute>out:=True OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 38 vc *}
+apply auto
+done
+
+subsubsection {* Peterson's Algorithm III: Parameterized version: *}
+
+lemma Semaphores_parameterized_mutex:
+ "0<n \<Longrightarrow> \<parallel>- .{True}.
+ \<acute>out:=True ,,
+ COBEGIN
+ SCHEME [0\<le> i< n]
+ .{True}.
+ WHILE True INV .{True}.
+ DO .{True}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
+ .{\<not>\<acute>out \<and> \<acute>who=i}. \<acute>out:=True OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 20 vc *}
+apply auto
+done
+
+subsubsection{* The Ticket Algorithm *}
+
+record Ticket_mutex =
+ num :: nat
+ nextv :: nat
+ turn :: "nat list"
+ index :: nat
+
+lemma Ticket_mutex:
+ "\<lbrakk> 0<n; I=\<guillemotleft>n=length \<acute>turn \<and> 0<\<acute>nextv \<and> (\<forall>k l. k<n \<and> l<n \<and> k\<noteq>l
+ \<longrightarrow> \<acute>turn!k < \<acute>num \<and> (\<acute>turn!k =0 \<or> \<acute>turn!k\<noteq>\<acute>turn!l))\<guillemotright> \<rbrakk>
+ \<Longrightarrow> \<parallel>- .{n=length \<acute>turn}.
+ \<acute>index:= 0,,
+ WHILE \<acute>index < n INV .{n=length \<acute>turn \<and> (\<forall>i<\<acute>index. \<acute>turn!i=0)}.
+ DO \<acute>turn:= \<acute>turn[\<acute>index:=0],, \<acute>index:=\<acute>index +1 OD,,
+ \<acute>num:=1 ,, \<acute>nextv:=1 ,,
+ COBEGIN
+ SCHEME [0\<le> i< n]
+ .{\<acute>I}.
+ WHILE True INV .{\<acute>I}.
+ DO .{\<acute>I}. \<langle> \<acute>turn :=\<acute>turn[i:=\<acute>num],, \<acute>num:=\<acute>num+1 \<rangle>;;
+ .{\<acute>I}. WAIT \<acute>turn!i=\<acute>nextv END;;
+ .{\<acute>I \<and> \<acute>turn!i=\<acute>nextv}. \<acute>nextv:=\<acute>nextv+1
+ OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 35 vc *}
+apply simp_all
+--{* 21 vc *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 11 vc *}
+apply simp_all
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 10 subgoals left *}
+apply(erule less_SucE)
+ apply simp
+apply simp
+--{* 9 subgoals left *}
+apply(case_tac "i=k")
+ apply force
+apply simp
+apply(case_tac "i=l")
+ apply force
+apply force
+--{* 8 subgoals left *}
+prefer 8
+apply force
+apply force
+--{* 6 subgoals left *}
+prefer 6
+apply(erule_tac x=i in allE)
+apply fastsimp
+--{* 5 subgoals left *}
+prefer 5
+apply(case_tac [!] "j=k")
+--{* 10 subgoals left *}
+apply simp_all
+apply(erule_tac x=k in allE)
+apply force
+--{* 9 subgoals left *}
+apply(case_tac "j=l")
+ apply simp
+ apply(erule_tac x=k in allE)
+ apply(erule_tac x=k in allE)
+ apply(erule_tac x=l in allE)
+ apply force
+apply(erule_tac x=k in allE)
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply force
+--{* 8 subgoals left *}
+apply force
+apply(case_tac "j=l")
+ apply simp
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply force
+apply force
+apply force
+--{* 5 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+apply force
+--{* 3 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+apply force
+--{* 1 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+done
+
+subsection{* Parallel Zero Search *}
+
+text {* Synchronized Zero Search. Zero-6 *}
+
+text {*Apt and Olderog. "Verification of sequential and concurrent Programs" page 294: *}
+
+record Zero_search =
+ turn :: nat
+ found :: bool
+ x :: nat
+ y :: nat
+
+lemma Zero_search:
+ "\<lbrakk>I1= \<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> a<\<acute> x \<longrightarrow> f(\<acute>x)\<noteq>0) \<guillemotright> ;
+ I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0) \<guillemotright> \<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<exists> u. f(u)=0}.
+ \<acute>turn:=1,, \<acute>found:= False,,
+ \<acute>x:=a,, \<acute>y:=a+1 ,,
+ COBEGIN .{\<acute>I1}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I1}.
+ DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ WAIT \<acute>turn=1 END;;
+ .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<acute>turn:=2;;
+ .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<langle> \<acute>x:=\<acute>x+1,,
+ IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD;;
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<acute>turn:=2
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<parallel>
+ .{\<acute>I2}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I2}.
+ DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ WAIT \<acute>turn=2 END;;
+ .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<acute>turn:=1;;
+ .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<langle> \<acute>y:=(\<acute>y - 1),,
+ IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD;;
+ .{\<acute>I2 \<and> \<acute>found}.
+ \<acute>turn:=1
+ .{\<acute>I2 \<and> \<acute>found}.
+ COEND
+ .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
+apply oghoare
+--{* 98 verification conditions *}
+apply auto
+--{* auto takes about 3 minutes !! *}
+done
+
+text {* Easier Version: without AWAIT. Apt and Olderog. page 256: *}
+
+lemma Zero_Search_2:
+"\<lbrakk>I1=\<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<guillemotright>;
+ I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<guillemotright>\<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<exists>u. f(u)=0}.
+ \<acute>found:= False,,
+ \<acute>x:=a,, \<acute>y:=a+1,,
+ COBEGIN .{\<acute>I1}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I1}.
+ DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<langle> \<acute>x:=\<acute>x+1,,IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<parallel>
+ .{\<acute>I2}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I2}.
+ DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<langle> \<acute>y:=(\<acute>y - 1),,IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD
+ .{\<acute>I2 \<and> \<acute>found}.
+ COEND
+ .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
+apply oghoare
+--{* 20 vc *}
+apply auto
+--{* auto takes aprox. 2 minutes. *}
+done
+
+subsection {* Producer/Consumer *}
+
+subsubsection {* Previous lemmas *}
+
+lemma nat_lemma2: "\<lbrakk> b = m*(n::nat) + t; a = s*n + u; t=u; b-a < n \<rbrakk> \<Longrightarrow> m \<le> s"
+proof -
+ assume "b = m*(n::nat) + t" "a = s*n + u" "t=u"
+ hence "(m - s) * n = b - a" by (simp add: diff_mult_distrib)
+ also assume "\<dots> < n"
+ finally have "m - s < 1" by simp
+ thus ?thesis by arith
+qed
+
+lemma mod_lemma: "\<lbrakk> (c::nat) \<le> a; a < b; b - c < n \<rbrakk> \<Longrightarrow> b mod n \<noteq> a mod n"
+apply(subgoal_tac "b=b div n*n + b mod n" )
+ prefer 2 apply (simp add: mod_div_equality [symmetric])
+apply(subgoal_tac "a=a div n*n + a mod n")
+ prefer 2
+ apply(simp add: mod_div_equality [symmetric])
+apply(subgoal_tac "b - a \<le> b - c")
+ prefer 2 apply arith
+apply(drule le_less_trans)
+back
+ apply assumption
+apply(frule less_not_refl2)
+apply(drule less_imp_le)
+apply (drule_tac m = "a" and k = n in div_le_mono)
+apply(safe)
+apply(frule_tac b = "b" and a = "a" and n = "n" in nat_lemma2, assumption, assumption)
+apply assumption
+apply(drule order_antisym, assumption)
+apply(rotate_tac -3)
+apply(simp)
+done
+
+
+subsubsection {* Producer/Consumer Algorithm *}
+
+record Producer_consumer =
+ ins :: nat
+ outs :: nat
+ li :: nat
+ lj :: nat
+ vx :: nat
+ vy :: nat
+ buffer :: "nat list"
+ b :: "nat list"
+
+text {* The whole proof takes aprox. 4 minutes. *}
+
+lemma Producer_consumer:
+ "\<lbrakk>INIT= \<guillemotleft>0<length a \<and> 0<length \<acute>buffer \<and> length \<acute>b=length a\<guillemotright> ;
+ I= \<guillemotleft>(\<forall>k<\<acute>ins. \<acute>outs\<le>k \<longrightarrow> (a ! k) = \<acute>buffer ! (k mod (length \<acute>buffer))) \<and>
+ \<acute>outs\<le>\<acute>ins \<and> \<acute>ins-\<acute>outs\<le>length \<acute>buffer\<guillemotright> ;
+ I1= \<guillemotleft>\<acute>I \<and> \<acute>li\<le>length a\<guillemotright> ;
+ p1= \<guillemotleft>\<acute>I1 \<and> \<acute>li=\<acute>ins\<guillemotright> ;
+ I2 = \<guillemotleft>\<acute>I \<and> (\<forall>k<\<acute>lj. (a ! k)=(\<acute>b ! k)) \<and> \<acute>lj\<le>length a\<guillemotright> ;
+ p2 = \<guillemotleft>\<acute>I2 \<and> \<acute>lj=\<acute>outs\<guillemotright> \<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<acute>INIT}.
+ \<acute>ins:=0,, \<acute>outs:=0,, \<acute>li:=0,, \<acute>lj:=0,,
+ COBEGIN .{\<acute>p1 \<and> \<acute>INIT}.
+ WHILE \<acute>li <length a
+ INV .{\<acute>p1 \<and> \<acute>INIT}.
+ DO .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a}.
+ \<acute>vx:= (a ! \<acute>li);;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)}.
+ WAIT \<acute>ins-\<acute>outs < length \<acute>buffer END;;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)
+ \<and> \<acute>ins-\<acute>outs < length \<acute>buffer}.
+ \<acute>buffer:=(list_update \<acute>buffer (\<acute>ins mod (length \<acute>buffer)) \<acute>vx);;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a
+ \<and> (a ! \<acute>li)=(\<acute>buffer ! (\<acute>ins mod (length \<acute>buffer)))
+ \<and> \<acute>ins-\<acute>outs <length \<acute>buffer}.
+ \<acute>ins:=\<acute>ins+1;;
+ .{\<acute>I1 \<and> \<acute>INIT \<and> (\<acute>li+1)=\<acute>ins \<and> \<acute>li<length a}.
+ \<acute>li:=\<acute>li+1
+ OD
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li=length a}.
+ \<parallel>
+ .{\<acute>p2 \<and> \<acute>INIT}.
+ WHILE \<acute>lj < length a
+ INV .{\<acute>p2 \<and> \<acute>INIT}.
+ DO .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>INIT}.
+ WAIT \<acute>outs<\<acute>ins END;;
+ .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>INIT}.
+ \<acute>vy:=(\<acute>buffer ! (\<acute>outs mod (length \<acute>buffer)));;
+ .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>outs:=\<acute>outs+1;;
+ .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>b:=(list_update \<acute>b \<acute>lj \<acute>vy);;
+ .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> (a ! \<acute>lj)=(\<acute>b ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>lj:=\<acute>lj+1
+ OD
+ .{\<acute>p2 \<and> \<acute>lj=length a \<and> \<acute>INIT}.
+ COEND
+ .{ \<forall>k<length a. (a ! k)=(\<acute>b ! k)}."
+apply oghoare
+--{* 138 vc *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 112 subgoals left *}
+apply(simp_all (no_asm))
+apply(tactic {*ALLGOALS (conjI_Tac (K all_tac)) *})
+--{* 930 subgoals left *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all (asm_lr) only:length_0_conv [THEN sym])
+--{* 44 subgoals left *}
+apply (simp_all (asm_lr) del:length_0_conv add: neq0_conv nth_list_update mod_less_divisor mod_lemma)
+--{* 32 subgoals left *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+
+apply(tactic {* TRYALL (Lin_Arith.tac @{context}) *})
+--{* 9 subgoals left *}
+apply (force simp add:less_Suc_eq)
+apply(drule sym)
+apply (force simp add:less_Suc_eq)+
+done
+
+subsection {* Parameterized Examples *}
+
+subsubsection {* Set Elements of an Array to Zero *}
+
+record Example1 =
+ a :: "nat \<Rightarrow> nat"
+
+lemma Example1:
+ "\<parallel>- .{True}.
+ COBEGIN SCHEME [0\<le>i<n] .{True}. \<acute>a:=\<acute>a (i:=0) .{\<acute>a i=0}. COEND
+ .{\<forall>i < n. \<acute>a i = 0}."
+apply oghoare
+apply simp_all
+done
+
+text {* Same example with lists as auxiliary variables. *}
+record Example1_list =
+ A :: "nat list"
+lemma Example1_list:
+ "\<parallel>- .{n < length \<acute>A}.
+ COBEGIN
+ SCHEME [0\<le>i<n] .{n < length \<acute>A}. \<acute>A:=\<acute>A[i:=0] .{\<acute>A!i=0}.
+ COEND
+ .{\<forall>i < n. \<acute>A!i = 0}."
+apply oghoare
+apply force+
+done
+
+subsubsection {* Increment a Variable in Parallel *}
+
+text {* First some lemmas about summation properties. *}
+(*
+lemma Example2_lemma1: "!!b. j<n \<Longrightarrow> (\<Sum>i::nat<n. b i) = (0::nat) \<Longrightarrow> b j = 0 "
+apply(induct n)
+ apply simp_all
+apply(force simp add: less_Suc_eq)
+done
+*)
+lemma Example2_lemma2_aux: "!!b. j<n \<Longrightarrow>
+ (\<Sum>i=0..<n. (b i::nat)) =
+ (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
+apply(induct n)
+ apply simp_all
+apply(simp add:less_Suc_eq)
+ apply(auto)
+apply(subgoal_tac "n - j = Suc(n- Suc j)")
+ apply simp
+apply arith
+done
+
+lemma Example2_lemma2_aux2:
+ "!!b. j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
+apply(induct j)
+ apply simp_all
+done
+
+lemma Example2_lemma2:
+ "!!b. \<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
+apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
+apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
+apply(frule_tac b=b in Example2_lemma2_aux)
+apply(erule_tac t="setsum b {0..<n}" in ssubst)
+apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply(subgoal_tac "j\<le>j")
+ apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply simp_all
+done
+
+
+record Example2 =
+ c :: "nat \<Rightarrow> nat"
+ x :: nat
+
+lemma Example_2: "0<n \<Longrightarrow>
+ \<parallel>- .{\<acute>x=0 \<and> (\<Sum>i=0..<n. \<acute>c i)=0}.
+ COBEGIN
+ SCHEME [0\<le>i<n]
+ .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=0}.
+ \<langle> \<acute>x:=\<acute>x+(Suc 0),, \<acute>c:=\<acute>c (i:=(Suc 0)) \<rangle>
+ .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=(Suc 0)}.
+ COEND
+ .{\<acute>x=n}."
+apply oghoare
+apply (simp_all cong del: strong_setsum_cong)
+apply (tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply (simp_all cong del: strong_setsum_cong)
+ apply(erule (1) Example2_lemma2)
+ apply(erule (1) Example2_lemma2)
+ apply(erule (1) Example2_lemma2)
+apply(simp)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Hoare.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,469 @@
+
+header {* \section{The Proof System} *}
+
+theory OG_Hoare imports OG_Tran begin
+
+consts assertions :: "'a ann_com \<Rightarrow> ('a assn) set"
+primrec
+ "assertions (AnnBasic r f) = {r}"
+ "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
+ "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
+ "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
+ "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
+ "assertions (AnnAwait r b c) = {r}"
+
+consts atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set"
+primrec
+ "atomics (AnnBasic r f) = {(r, Basic f)}"
+ "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
+ "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
+ "atomics (AnnCond2 r b c) = atomics c"
+ "atomics (AnnWhile r b i c) = atomics c"
+ "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"
+
+consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
+primrec "com (c, q) = c"
+
+consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
+primrec "post (c, q) = q"
+
+constdefs interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool"
+ "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
+ (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
+ (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"
+
+constdefs interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool"
+ "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
+ interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "
+
+inductive
+ oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>- _//_//_)" [90,55,90] 50)
+ and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(2\<turnstile> _// _)" [60,90] 45)
+where
+ AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"
+
+| AnnSeq: "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"
+
+| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
+ \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
+| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"
+
+| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"
+
+| AnnAwait: "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"
+
+| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"
+
+
+| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
+ Parallel Ts
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
+
+| Basic: "\<parallel>- {s. f s \<in>q} (Basic f) q"
+
+| Seq: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "
+
+| Cond: "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
+
+| While: "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"
+
+| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"
+
+section {* Soundness *}
+(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
+parts of conditional expressions (if P then x else y) are no longer
+simplified. (This allows the simplifier to unfold recursive
+functional programs.) To restore the old behaviour, we declare
+@{text "lemmas [cong del] = if_weak_cong"}. *)
+
+lemmas [cong del] = if_weak_cong
+
+lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
+lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]
+
+lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
+lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
+lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
+lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
+lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
+lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
+lemmas AnnConseq = oghoare_ann_hoare.AnnConseq
+
+lemmas Parallel = oghoare_ann_hoare.Parallel
+lemmas Basic = oghoare_ann_hoare.Basic
+lemmas Seq = oghoare_ann_hoare.Seq
+lemmas Cond = oghoare_ann_hoare.Cond
+lemmas While = oghoare_ann_hoare.While
+lemmas Conseq = oghoare_ann_hoare.Conseq
+
+subsection {* Soundness of the System for Atomic Programs *}
+
+lemma Basic_ntran [rule_format]:
+ "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
+apply(induct "n")
+ apply(simp (no_asm))
+apply(fast dest: rel_pow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
+done
+
+lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
+apply (induct "k")
+ apply(simp (no_asm) add: L3_5v_lemma3)
+apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
+apply(rule conjI)
+ apply (blast dest: L3_5i)
+apply(simp add: SEM_def sem_def id_def)
+apply (blast dest: Basic_ntran rtrancl_imp_UN_rel_pow)
+done
+
+lemma atom_hoare_sound [rule_format]:
+ " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
+apply (unfold com_validity_def)
+apply(rule oghoare_induct)
+apply simp_all
+--{*Basic*}
+ apply(simp add: SEM_def sem_def)
+ apply(fast dest: rtrancl_imp_UN_rel_pow Basic_ntran)
+--{* Seq *}
+ apply(rule impI)
+ apply(rule subset_trans)
+ prefer 2 apply simp
+ apply(simp add: L3_5ii L3_5i)
+--{* Cond *}
+ apply(simp add: L3_5iv)
+--{* While *}
+ apply (force simp add: L3_5v dest: SEM_fwhile)
+--{* Conseq *}
+apply(force simp add: SEM_def sem_def)
+done
+
+subsection {* Soundness of the System for Component Programs *}
+
+inductive_cases ann_transition_cases:
+ "(None,s) -1\<rightarrow> (c', s')"
+ "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
+ "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"
+
+text {* Strong Soundness for Component Programs:*}
+
+lemma ann_hoare_case_analysis [rule_format]:
+ defines I: "I \<equiv> \<lambda>C q'.
+ ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
+ (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
+ (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
+ r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
+ (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
+ (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
+ (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
+ (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
+ (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
+ shows "\<turnstile> C q' \<longrightarrow> I C q'"
+apply(rule ann_hoare_induct)
+apply (simp_all add: I)
+ apply(rule_tac x=q in exI,simp)+
+apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
+apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
+done
+
+lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
+apply force
+done
+
+lemma Strong_Soundness_aux_aux [rule_format]:
+ "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
+ (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
+apply(rule ann_transition_transition.induct [THEN conjunct1])
+apply simp_all
+--{* Basic *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis)
+ apply force
+--{* Seq *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply clarify
+ apply(rule conjI)
+ apply force
+ apply(rule AnnSeq,simp)
+ apply(fast intro: AnnConseq)
+--{* Cond1 *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+--{* Cond2 *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+--{* While *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply force
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply auto
+ apply(rule AnnSeq)
+ apply simp
+ apply(rule AnnWhile)
+ apply simp_all
+--{* Await *}
+apply(frule ann_hoare_case_analysis,simp)
+apply clarify
+apply(drule atom_hoare_sound)
+ apply simp
+apply(simp add: com_validity_def SEM_def sem_def)
+apply(simp add: Help All_None_def)
+apply force
+done
+
+lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
+ \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
+apply(erule rtrancl_induct2)
+ apply simp
+apply(case_tac "a")
+ apply(fast elim: ann_transition_cases)
+apply(erule Strong_Soundness_aux_aux)
+ apply simp
+apply simp_all
+done
+
+lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
+ \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
+apply(force dest:Strong_Soundness_aux)
+done
+
+lemma ann_hoare_sound: "\<turnstile> c q \<Longrightarrow> \<Turnstile> c q"
+apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
+apply clarify
+apply(drule Strong_Soundness)
+apply simp_all
+done
+
+subsection {* Soundness of the System for Parallel Programs *}
+
+lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
+ (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
+ (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
+apply(erule transition_cases)
+apply simp
+apply clarify
+apply(case_tac "i=ia")
+apply simp+
+done
+
+lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
+ (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
+ (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
+apply(erule rtrancl_induct2)
+ apply(simp_all)
+apply clarify
+apply simp
+apply(drule Parallel_length_post_P1)
+apply auto
+done
+
+lemma assertions_lemma: "pre c \<in> assertions c"
+apply(rule ann_com_com.induct [THEN conjunct1])
+apply auto
+done
+
+lemma interfree_aux1 [rule_format]:
+ "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
+apply (rule ann_transition_transition.induct [THEN conjunct1])
+apply(safe)
+prefer 13
+apply (rule TrueI)
+apply (simp_all add:interfree_aux_def)
+apply force+
+done
+
+lemma interfree_aux2 [rule_format]:
+ "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a) \<longrightarrow> interfree_aux(r, q, a) )"
+apply (rule ann_transition_transition.induct [THEN conjunct1])
+apply(force simp add:interfree_aux_def)+
+done
+
+lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
+ Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
+apply(simp add: interfree_def)
+apply clarify
+apply(case_tac "i=j")
+ apply(drule_tac t = "ia" in not_sym)
+ apply simp_all
+apply(force elim: interfree_aux1)
+apply(force elim: interfree_aux2 simp add:nth_list_update)
+done
+
+text {* Strong Soundness Theorem for Parallel Programs:*}
+
+lemma Parallel_Strong_Soundness_Seq_aux:
+ "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
+ \<Longrightarrow> interfree (Ts[i:=(Some c0, pre c1)])"
+apply(simp add: interfree_def)
+apply clarify
+apply(case_tac "i=j")
+ apply(force simp add: nth_list_update interfree_aux_def)
+apply(case_tac "i=ia")
+ apply(erule_tac x=ia in allE)
+ apply(force simp add:interfree_aux_def assertions_lemma)
+apply simp
+done
+
+lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
+ "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
+ else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
+ com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
+ (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
+ then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
+ else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
+ \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
+ \<and> interfree (Ts[i:= (Some c0, pre c1)])"
+apply(rule conjI)
+ apply safe
+ apply(case_tac "i=ia")
+ apply simp
+ apply(force dest: ann_hoare_case_analysis)
+ apply simp
+apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
+done
+
+lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
+ "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
+ (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
+ (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
+ else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
+ interfree Ts \<longrightarrow>
+ (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
+ else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
+apply(rule ann_transition_transition.induct [THEN conjunct1])
+apply safe
+prefer 11
+apply(rule TrueI)
+apply simp_all
+--{* Basic *}
+ apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
+ apply(erule_tac x = "j" in allE , erule (1) notE impE)
+ apply(simp add: interfree_def)
+ apply(erule_tac x = "j" in allE,simp)
+ apply(erule_tac x = "i" in allE,simp)
+ apply(drule_tac t = "i" in not_sym)
+ apply(case_tac "com(Ts ! j)=None")
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
+ apply(simp add:interfree_aux_def)
+ apply clarify
+ apply simp
+ apply(erule_tac x="pre y" in ballE)
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: com_validity_def SEM_def sem_def All_None_def)
+ apply(simp add:assertions_lemma)
+--{* Seqs *}
+ apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
+ apply(drule Parallel_Strong_Soundness_Seq,simp+)
+ apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
+ apply(drule Parallel_Strong_Soundness_Seq,simp+)
+--{* Await *}
+apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
+apply(erule_tac x = "j" in allE , erule (1) notE impE)
+apply(simp add: interfree_def)
+apply(erule_tac x = "j" in allE,simp)
+apply(erule_tac x = "i" in allE,simp)
+apply(drule_tac t = "i" in not_sym)
+apply(case_tac "com(Ts ! j)=None")
+ apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
+ com_validity_def SEM_def sem_def All_None_def Help)
+apply(simp add:interfree_aux_def)
+apply clarify
+apply simp
+apply(erule_tac x="pre y" in ballE)
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: com_validity_def SEM_def sem_def All_None_def Help)
+apply(simp add:assertions_lemma)
+done
+
+lemma Parallel_Strong_Soundness_aux [rule_format]:
+ "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t); Ts' = (Parallel Ts); interfree Ts;
+ \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
+ \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
+ (if com(Rs ! j) = None then t\<in>post(Ts ! j)
+ else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
+apply(erule rtrancl_induct2)
+ apply clarify
+--{* Base *}
+ apply force
+--{* Induction step *}
+apply clarify
+apply(drule Parallel_length_post_PStar)
+apply clarify
+apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
+apply(rule conjI)
+ apply clarify
+ apply(case_tac "i=j")
+ apply(simp split del:split_if)
+ apply(erule Strong_Soundness_aux_aux,simp+)
+ apply force
+ apply force
+ apply(simp split del: split_if)
+ apply(erule Parallel_Strong_Soundness_aux_aux)
+ apply(simp_all add: split del:split_if)
+ apply force
+apply(rule interfree_lemma)
+apply simp_all
+done
+
+lemma Parallel_Strong_Soundness:
+ "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
+ \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
+ if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
+apply(drule Parallel_Strong_Soundness_aux)
+apply simp+
+done
+
+lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
+apply (unfold com_validity_def)
+apply(rule oghoare_induct)
+apply(rule TrueI)+
+--{* Parallel *}
+ apply(simp add: SEM_def sem_def)
+ apply clarify
+ apply(frule Parallel_length_post_PStar)
+ apply clarify
+ apply(drule_tac j=xb in Parallel_Strong_Soundness)
+ apply clarify
+ apply simp
+ apply force
+ apply simp
+ apply(erule_tac V = "\<forall>i. ?P i" in thin_rl)
+ apply(drule_tac s = "length Rs" in sym)
+ apply(erule allE, erule impE, assumption)
+ apply(force dest: nth_mem simp add: All_None_def)
+--{* Basic *}
+ apply(simp add: SEM_def sem_def)
+ apply(force dest: rtrancl_imp_UN_rel_pow Basic_ntran)
+--{* Seq *}
+ apply(rule subset_trans)
+ prefer 2 apply assumption
+ apply(simp add: L3_5ii L3_5i)
+--{* Cond *}
+ apply(simp add: L3_5iv)
+--{* While *}
+ apply(simp add: L3_5v)
+ apply (blast dest: SEM_fwhile)
+--{* Conseq *}
+apply(auto simp add: SEM_def sem_def)
+done
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Syntax.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,140 @@
+theory OG_Syntax
+imports OG_Tactics Quote_Antiquote
+begin
+
+text{* Syntax for commands and for assertions and boolean expressions in
+ commands @{text com} and annotated commands @{text ann_com}. *}
+
+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>"
+
+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"
+ ("_ //IF _ /THEN _ /FI" [90,0,0] 61)
+ "_AnnWhile" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
+ ("_ //WHILE _ /INV _ //DO _//OD" [90,0,0,0] 61)
+ "_AnnAwait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a ann_com"
+ ("_ //AWAIT _ /THEN /_ /END" [90,0,0] 61)
+ "_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)
+ "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
+ ("(0WHILE _/ INV _ //DO _ /OD)" [0, 0, 0] 61)
+ "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"
+ ("(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 c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
+ "WHILE b INV i DO c OD" \<rightharpoonup> "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 WAIT b END" \<rightleftharpoons> "r AWAIT b THEN SKIP END"
+
+nonterminals
+ prgs
+
+syntax
+ "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" [57] 56)
+ "_prg" :: "['a, 'a] \<Rightarrow> prgs" ("_//_" [60, 90] 57)
+ "_prgs" :: "['a, 'a, prgs] \<Rightarrow> prgs" ("_//_//\<parallel>//_" [60,90,57] 57)
+
+ "_prg_scheme" :: "['a, 'a, 'a, 'a, 'a] \<Rightarrow> prgs"
+ ("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_scheme j i k c q" \<rightleftharpoons> "map (\<lambda>i. (Some c, q)) [j..<k]"
+
+print_translation {*
+ let
+ fun quote_tr' f (t :: ts) =
+ Term.list_comb (f $ Syntax.quote_tr' "_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)
+ | annquote_tr' _ _ = raise Match;
+
+ val assert_tr' = quote_tr' (Syntax.const "_Assert");
+
+ fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ quote_tr' (Syntax.const name) (t :: ts)
+ | bexp_tr' _ _ = raise Match;
+
+ fun annbexp_tr' name (r :: (Const ("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
+ | K_tr' _ = raise Match;
+
+ fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
+ quote_tr' (Syntax.const "_Assign" $ 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)
+ (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])
+ | Parallel_PAR _ = raise Match;
+
+fun Parallel_tr' ts = 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
+
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Tactics.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,496 @@
+header {* \section{Generation of Verification Conditions} *}
+
+theory OG_Tactics
+imports OG_Hoare
+begin
+
+lemmas ann_hoare_intros=AnnBasic AnnSeq AnnCond1 AnnCond2 AnnWhile AnnAwait AnnConseq
+lemmas oghoare_intros=Parallel Basic Seq Cond While Conseq
+
+lemma ParallelConseqRule:
+ "\<lbrakk> p \<subseteq> (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))));
+ \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))))
+ (Parallel Ts)
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i));
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i)) \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (Parallel Ts) q"
+apply (rule Conseq)
+prefer 2
+ apply fast
+apply assumption+
+done
+
+lemma SkipRule: "p \<subseteq> q \<Longrightarrow> \<parallel>- p (Basic id) q"
+apply(rule oghoare_intros)
+ prefer 2 apply(rule Basic)
+ prefer 2 apply(rule subset_refl)
+apply(simp add:Id_def)
+done
+
+lemma BasicRule: "p \<subseteq> {s. (f s)\<in>q} \<Longrightarrow> \<parallel>- p (Basic f) q"
+apply(rule oghoare_intros)
+ prefer 2 apply(rule oghoare_intros)
+ prefer 2 apply(rule subset_refl)
+apply assumption
+done
+
+lemma SeqRule: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q"
+apply(rule Seq)
+apply fast+
+done
+
+lemma CondRule:
+ "\<lbrakk> p \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>w) \<and> (s\<notin>b \<longrightarrow> s\<in>w')}; \<parallel>- w c1 q; \<parallel>- w' c2 q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
+apply(rule Cond)
+ apply(rule Conseq)
+ prefer 4 apply(rule Conseq)
+apply simp_all
+apply force+
+done
+
+lemma WhileRule: "\<lbrakk> p \<subseteq> i; \<parallel>- (i \<inter> b) c i ; (i \<inter> (-b)) \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (While b i c) q"
+apply(rule Conseq)
+ prefer 2 apply(rule While)
+apply assumption+
+done
+
+text {* Three new proof rules for special instances of the @{text
+AnnBasic} and the @{text AnnAwait} commands when the transformation
+performed on the state is the identity, and for an @{text AnnAwait}
+command where the boolean condition is @{text "{s. True}"}: *}
+
+lemma AnnatomRule:
+ "\<lbrakk> atom_com(c); \<parallel>- r c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r {s. True} c) q"
+apply(rule AnnAwait)
+apply simp_all
+done
+
+lemma AnnskipRule:
+ "r \<subseteq> q \<Longrightarrow> \<turnstile> (AnnBasic r id) q"
+apply(rule AnnBasic)
+apply simp
+done
+
+lemma AnnwaitRule:
+ "\<lbrakk> (r \<inter> b) \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b (Basic id)) q"
+apply(rule AnnAwait)
+ apply simp
+apply(rule BasicRule)
+apply simp
+done
+
+text {* Lemmata to avoid using the definition of @{text
+map_ann_hoare}, @{text interfree_aux}, @{text interfree_swap} and
+@{text interfree} by splitting it into different cases: *}
+
+lemma interfree_aux_rule1: "interfree_aux(co, q, None)"
+by(simp add:interfree_aux_def)
+
+lemma interfree_aux_rule2:
+ "\<forall>(R,r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<Longrightarrow> interfree_aux(None, q, Some a)"
+apply(simp add:interfree_aux_def)
+apply(force elim:oghoare_sound)
+done
+
+lemma interfree_aux_rule3:
+ "(\<forall>(R, r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<and> (\<forall>p\<in>(assertions c). \<parallel>- (p \<inter> R) r p))
+ \<Longrightarrow> interfree_aux(Some c, q, Some a)"
+apply(simp add:interfree_aux_def)
+apply(force elim:oghoare_sound)
+done
+
+lemma AnnBasic_assertions:
+ "\<lbrakk>interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk> \<Longrightarrow>
+ interfree_aux(Some (AnnBasic r f), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnSeq_assertions:
+ "\<lbrakk> interfree_aux(Some c1, q, Some a); interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnSeq c1 c2), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond1_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c1, q, Some a);
+ interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some(AnnCond1 r b c1 c2), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond2_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnCond2 r b c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnWhile_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, i, Some a);
+ interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnWhile r b i c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnAwait_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnAwait r b c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnBasic_atomics:
+ "\<parallel>- (q \<inter> r) (Basic f) q \<Longrightarrow> interfree_aux(None, q, Some (AnnBasic r f))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+lemma AnnSeq_atomics:
+ "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Any, q, Some (AnnSeq a1 a2))"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond1_atomics:
+ "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Any, q, Some (AnnCond1 r b a1 a2))"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond2_atomics:
+ "interfree_aux (Any, q, Some a)\<Longrightarrow> interfree_aux(Any, q, Some (AnnCond2 r b a))"
+by(simp add: interfree_aux_def)
+
+lemma AnnWhile_atomics: "interfree_aux (Any, q, Some a)
+ \<Longrightarrow> interfree_aux(Any, q, Some (AnnWhile r b i a))"
+by(simp add: interfree_aux_def)
+
+lemma Annatom_atomics:
+ "\<parallel>- (q \<inter> r) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r {x. True} a))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+lemma AnnAwait_atomics:
+ "\<parallel>- (q \<inter> (r \<inter> b)) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r b a))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+constdefs
+ interfree_swap :: "('a ann_triple_op * ('a ann_triple_op) list) \<Rightarrow> bool"
+ "interfree_swap == \<lambda>(x, xs). \<forall>y\<in>set xs. interfree_aux (com x, post x, com y)
+ \<and> interfree_aux(com y, post y, com x)"
+
+lemma interfree_swap_Empty: "interfree_swap (x, [])"
+by(simp add:interfree_swap_def)
+
+lemma interfree_swap_List:
+ "\<lbrakk> interfree_aux (com x, post x, com y);
+ interfree_aux (com y, post y ,com x); interfree_swap (x, xs) \<rbrakk>
+ \<Longrightarrow> interfree_swap (x, y#xs)"
+by(simp add:interfree_swap_def)
+
+lemma interfree_swap_Map: "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> interfree_aux (com x, post x, c k)
+ \<and> interfree_aux (c k, Q k, com x)
+ \<Longrightarrow> interfree_swap (x, map (\<lambda>k. (c k, Q k)) [i..<j])"
+by(force simp add: interfree_swap_def less_diff_conv)
+
+lemma interfree_Empty: "interfree []"
+by(simp add:interfree_def)
+
+lemma interfree_List:
+ "\<lbrakk> interfree_swap(x, xs); interfree xs \<rbrakk> \<Longrightarrow> interfree (x#xs)"
+apply(simp add:interfree_def interfree_swap_def)
+apply clarify
+apply(case_tac i)
+ apply(case_tac j)
+ apply simp_all
+apply(case_tac j,simp+)
+done
+
+lemma interfree_Map:
+ "(\<forall>i j. a\<le>i \<and> i<b \<and> a\<le>j \<and> j<b \<and> i\<noteq>j \<longrightarrow> interfree_aux (c i, Q i, c j))
+ \<Longrightarrow> interfree (map (\<lambda>k. (c k, Q k)) [a..<b])"
+by(force simp add: interfree_def less_diff_conv)
+
+constdefs map_ann_hoare :: "(('a ann_com_op * 'a assn) list) \<Rightarrow> bool " ("[\<turnstile>] _" [0] 45)
+ "[\<turnstile>] Ts == (\<forall>i<length Ts. \<exists>c q. Ts!i=(Some c, q) \<and> \<turnstile> c q)"
+
+lemma MapAnnEmpty: "[\<turnstile>] []"
+by(simp add:map_ann_hoare_def)
+
+lemma MapAnnList: "\<lbrakk> \<turnstile> c q ; [\<turnstile>] xs \<rbrakk> \<Longrightarrow> [\<turnstile>] (Some c,q)#xs"
+apply(simp add:map_ann_hoare_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma MapAnnMap:
+ "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> \<turnstile> (c k) (Q k) \<Longrightarrow> [\<turnstile>] map (\<lambda>k. (Some (c k), Q k)) [i..<j]"
+apply(simp add: map_ann_hoare_def less_diff_conv)
+done
+
+lemma ParallelRule:"\<lbrakk> [\<turnstile>] Ts ; interfree Ts \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
+ Parallel Ts
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
+apply(rule Parallel)
+ apply(simp add:map_ann_hoare_def)
+apply simp
+done
+(*
+lemma ParamParallelRule:
+ "\<lbrakk> \<forall>k<n. \<turnstile> (c k) (Q k);
+ \<forall>k l. k<n \<and> l<n \<and> k\<noteq>l \<longrightarrow> interfree_aux (Some(c k), Q k, Some(c l)) \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<n} . pre(c i)) COBEGIN SCHEME [0\<le>i<n] (c i) (Q i) COEND (\<Inter>i\<in>{i. i<n} . Q i )"
+apply(rule ParallelConseqRule)
+ apply simp
+ apply clarify
+ apply force
+ apply(rule ParallelRule)
+ apply(rule MapAnnMap)
+ apply simp
+ apply(rule interfree_Map)
+ apply simp
+apply simp
+apply clarify
+apply force
+done
+*)
+
+text {* The following are some useful lemmas and simplification
+tactics to control which theorems are used to simplify at each moment,
+so that the original input does not suffer any unexpected
+transformation. *}
+
+lemma Compl_Collect: "-(Collect b) = {x. \<not>(b x)}"
+by fast
+lemma list_length: "length []=0 \<and> length (x#xs) = Suc(length xs)"
+by simp
+lemma list_lemmas: "length []=0 \<and> length (x#xs) = Suc(length xs)
+\<and> (x#xs) ! 0=x \<and> (x#xs) ! Suc n = xs ! n"
+by simp
+lemma le_Suc_eq_insert: "{i. i <Suc n} = insert n {i. i< n}"
+by auto
+lemmas primrecdef_list = "pre.simps" "assertions.simps" "atomics.simps" "atom_com.simps"
+lemmas my_simp_list = list_lemmas fst_conv snd_conv
+not_less0 refl le_Suc_eq_insert Suc_not_Zero Zero_not_Suc nat.inject
+Collect_mem_eq ball_simps option.simps primrecdef_list
+lemmas ParallelConseq_list = INTER_def Collect_conj_eq length_map length_upt length_append list_length
+
+ML {*
+val before_interfree_simp_tac = (simp_tac (HOL_basic_ss addsimps [thm "com.simps", thm "post.simps"]))
+
+val interfree_simp_tac = (asm_simp_tac (HOL_ss addsimps [thm "split", thm "ball_Un", thm "ball_empty"]@(thms "my_simp_list")))
+
+val ParallelConseq = (simp_tac (HOL_basic_ss addsimps (thms "ParallelConseq_list")@(thms "my_simp_list")))
+*}
+
+text {* The following tactic applies @{text tac} to each conjunct in a
+subgoal of the form @{text "A \<Longrightarrow> a1 \<and> a2 \<and> .. \<and> an"} returning
+@{text n} subgoals, one for each conjunct: *}
+
+ML {*
+fun conjI_Tac tac i st = st |>
+ ( (EVERY [rtac conjI i,
+ conjI_Tac tac (i+1),
+ tac i]) ORELSE (tac i) )
+*}
+
+
+subsubsection {* Tactic for the generation of the verification conditions *}
+
+text {* The tactic basically uses two subtactics:
+
+\begin{description}
+
+\item[HoareRuleTac] is called at the level of parallel programs, it
+ uses the ParallelTac to solve parallel composition of programs.
+ This verification has two parts, namely, (1) all component programs are
+ correct and (2) they are interference free. @{text HoareRuleTac} is
+ also called at the level of atomic regions, i.e. @{text "\<langle> \<rangle>"} and
+ @{text "AWAIT b THEN _ END"}, and at each interference freedom test.
+
+\item[AnnHoareRuleTac] is for component programs which
+ are annotated programs and so, there are not unknown assertions
+ (no need to use the parameter precond, see NOTE).
+
+ NOTE: precond(::bool) informs if the subgoal has the form @{text "\<parallel>- ?p c q"},
+ in this case we have precond=False and the generated verification
+ condition would have the form @{text "?p \<subseteq> \<dots>"} which can be solved by
+ @{text "rtac subset_refl"}, if True we proceed to simplify it using
+ the simplification tactics above.
+
+\end{description}
+*}
+
+ML {*
+
+ fun WlpTac i = (rtac (@{thm SeqRule}) i) THEN (HoareRuleTac false (i+1))
+and HoareRuleTac precond i st = st |>
+ ( (WlpTac i THEN HoareRuleTac precond i)
+ ORELSE
+ (FIRST[rtac (@{thm SkipRule}) i,
+ rtac (@{thm BasicRule}) i,
+ EVERY[rtac (@{thm ParallelConseqRule}) i,
+ ParallelConseq (i+2),
+ ParallelTac (i+1),
+ ParallelConseq i],
+ EVERY[rtac (@{thm CondRule}) i,
+ HoareRuleTac false (i+2),
+ HoareRuleTac false (i+1)],
+ EVERY[rtac (@{thm WhileRule}) i,
+ HoareRuleTac true (i+1)],
+ K all_tac i ]
+ THEN (if precond then (K all_tac i) else (rtac (@{thm subset_refl}) i))))
+
+and AnnWlpTac i = (rtac (@{thm AnnSeq}) i) THEN (AnnHoareRuleTac (i+1))
+and AnnHoareRuleTac i st = st |>
+ ( (AnnWlpTac i THEN AnnHoareRuleTac i )
+ ORELSE
+ (FIRST[(rtac (@{thm AnnskipRule}) i),
+ EVERY[rtac (@{thm AnnatomRule}) i,
+ HoareRuleTac true (i+1)],
+ (rtac (@{thm AnnwaitRule}) i),
+ rtac (@{thm AnnBasic}) i,
+ EVERY[rtac (@{thm AnnCond1}) i,
+ AnnHoareRuleTac (i+3),
+ AnnHoareRuleTac (i+1)],
+ EVERY[rtac (@{thm AnnCond2}) i,
+ AnnHoareRuleTac (i+1)],
+ EVERY[rtac (@{thm AnnWhile}) i,
+ AnnHoareRuleTac (i+2)],
+ EVERY[rtac (@{thm AnnAwait}) i,
+ HoareRuleTac true (i+1)],
+ K all_tac i]))
+
+and ParallelTac i = EVERY[rtac (@{thm ParallelRule}) i,
+ interfree_Tac (i+1),
+ MapAnn_Tac i]
+
+and MapAnn_Tac i st = st |>
+ (FIRST[rtac (@{thm MapAnnEmpty}) i,
+ EVERY[rtac (@{thm MapAnnList}) i,
+ MapAnn_Tac (i+1),
+ AnnHoareRuleTac i],
+ EVERY[rtac (@{thm MapAnnMap}) i,
+ rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ AnnHoareRuleTac i]])
+
+and interfree_swap_Tac i st = st |>
+ (FIRST[rtac (@{thm interfree_swap_Empty}) i,
+ EVERY[rtac (@{thm interfree_swap_List}) i,
+ interfree_swap_Tac (i+2),
+ interfree_aux_Tac (i+1),
+ interfree_aux_Tac i ],
+ EVERY[rtac (@{thm interfree_swap_Map}) i,
+ rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ conjI_Tac (interfree_aux_Tac) i]])
+
+and interfree_Tac i st = st |>
+ (FIRST[rtac (@{thm interfree_Empty}) i,
+ EVERY[rtac (@{thm interfree_List}) i,
+ interfree_Tac (i+1),
+ interfree_swap_Tac i],
+ EVERY[rtac (@{thm interfree_Map}) i,
+ rtac (@{thm allI}) i,rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ interfree_aux_Tac i ]])
+
+and interfree_aux_Tac i = (before_interfree_simp_tac i ) THEN
+ (FIRST[rtac (@{thm interfree_aux_rule1}) i,
+ dest_assertions_Tac i])
+
+and dest_assertions_Tac i st = st |>
+ (FIRST[EVERY[rtac (@{thm AnnBasic_assertions}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnSeq_assertions}) i,
+ dest_assertions_Tac (i+1),
+ dest_assertions_Tac i],
+ EVERY[rtac (@{thm AnnCond1_assertions}) i,
+ dest_assertions_Tac (i+2),
+ dest_assertions_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond2_assertions}) i,
+ dest_assertions_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnWhile_assertions}) i,
+ dest_assertions_Tac (i+2),
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnAwait_assertions}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ dest_atomics_Tac i])
+
+and dest_atomics_Tac i st = st |>
+ (FIRST[EVERY[rtac (@{thm AnnBasic_atomics}) i,
+ HoareRuleTac true i],
+ EVERY[rtac (@{thm AnnSeq_atomics}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond1_atomics}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond2_atomics}) i,
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnWhile_atomics}) i,
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm Annatom_atomics}) i,
+ HoareRuleTac true i],
+ EVERY[rtac (@{thm AnnAwait_atomics}) i,
+ HoareRuleTac true i],
+ K all_tac i])
+*}
+
+
+text {* The final tactic is given the name @{text oghoare}: *}
+
+ML {*
+val oghoare_tac = SUBGOAL (fn (_, i) =>
+ (HoareRuleTac true i))
+*}
+
+text {* Notice that the tactic for parallel programs @{text
+"oghoare_tac"} is initially invoked with the value @{text true} for
+the parameter @{text precond}.
+
+Parts of the tactic can be also individually used to generate the
+verification conditions for annotated sequential programs and to
+generate verification conditions out of interference freedom tests: *}
+
+ML {* val annhoare_tac = SUBGOAL (fn (_, i) =>
+ (AnnHoareRuleTac i))
+
+val interfree_aux_tac = SUBGOAL (fn (_, i) =>
+ (interfree_aux_Tac i))
+*}
+
+text {* The so defined ML tactics are then ``exported'' to be used in
+Isabelle proofs. *}
+
+method_setup oghoare = {*
+ Scan.succeed (K (SIMPLE_METHOD' oghoare_tac)) *}
+ "verification condition generator for the oghoare logic"
+
+method_setup annhoare = {*
+ Scan.succeed (K (SIMPLE_METHOD' annhoare_tac)) *}
+ "verification condition generator for the ann_hoare logic"
+
+method_setup interfree_aux = {*
+ Scan.succeed (K (SIMPLE_METHOD' interfree_aux_tac)) *}
+ "verification condition generator for interference freedom tests"
+
+text {* Tactics useful for dealing with the generated verification conditions: *}
+
+method_setup conjI_tac = {*
+ Scan.succeed (K (SIMPLE_METHOD' (conjI_Tac (K all_tac)))) *}
+ "verification condition generator for interference freedom tests"
+
+ML {*
+fun disjE_Tac tac i st = st |>
+ ( (EVERY [etac disjE i,
+ disjE_Tac tac (i+1),
+ tac i]) ORELSE (tac i) )
+*}
+
+method_setup disjE_tac = {*
+ Scan.succeed (K (SIMPLE_METHOD' (disjE_Tac (K all_tac)))) *}
+ "verification condition generator for interference freedom tests"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Tran.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,309 @@
+
+header {* \section{Operational Semantics} *}
+
+theory OG_Tran imports OG_Com begin
+
+types
+ 'a ann_com_op = "('a ann_com) option"
+ 'a ann_triple_op = "('a ann_com_op \<times> 'a assn)"
+
+consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
+primrec "com (c, q) = c"
+
+consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
+primrec "post (c, q) = q"
+
+constdefs
+ All_None :: "'a ann_triple_op list \<Rightarrow> bool"
+ "All_None Ts \<equiv> \<forall>(c, q) \<in> set Ts. c = None"
+
+subsection {* The Transition Relation *}
+
+inductive_set
+ ann_transition :: "(('a ann_com_op \<times> 'a) \<times> ('a ann_com_op \<times> 'a)) set"
+ and transition :: "(('a com \<times> 'a) \<times> ('a com \<times> 'a)) set"
+ and ann_transition' :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
+ ("_ -1\<rightarrow> _"[81,81] 100)
+ and transition' :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P1\<rightarrow> _"[81,81] 100)
+ and transitions :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P*\<rightarrow> _"[81,81] 100)
+where
+ "con_0 -1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition"
+| "con_0 -P1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition"
+| "con_0 -P*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition\<^sup>*"
+
+| AnnBasic: "(Some (AnnBasic r f), s) -1\<rightarrow> (None, f s)"
+
+| AnnSeq1: "(Some c0, s) -1\<rightarrow> (None, t) \<Longrightarrow>
+ (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some c1, t)"
+| AnnSeq2: "(Some c0, s) -1\<rightarrow> (Some c2, t) \<Longrightarrow>
+ (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some (AnnSeq c2 c1), t)"
+
+| AnnCond1T: "s \<in> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c1, s)"
+| AnnCond1F: "s \<notin> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c2, s)"
+
+| AnnCond2T: "s \<in> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (Some c, s)"
+| AnnCond2F: "s \<notin> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (None, s)"
+
+| AnnWhileF: "s \<notin> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow> (None, s)"
+| AnnWhileT: "s \<in> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow>
+ (Some (AnnSeq c (AnnWhile i b i c)), s)"
+
+| AnnAwait: "\<lbrakk> s \<in> b; atom_com c; (c, s) -P*\<rightarrow> (Parallel [], t) \<rbrakk> \<Longrightarrow>
+ (Some (AnnAwait r b c), s) -1\<rightarrow> (None, t)"
+
+| Parallel: "\<lbrakk> i<length Ts; Ts!i = (Some c, q); (Some c, s) -1\<rightarrow> (r, t) \<rbrakk>
+ \<Longrightarrow> (Parallel Ts, s) -P1\<rightarrow> (Parallel (Ts [i:=(r, q)]), t)"
+
+| Basic: "(Basic f, s) -P1\<rightarrow> (Parallel [], f s)"
+
+| Seq1: "All_None Ts \<Longrightarrow> (Seq (Parallel Ts) c, s) -P1\<rightarrow> (c, s)"
+| Seq2: "(c0, s) -P1\<rightarrow> (c2, t) \<Longrightarrow> (Seq c0 c1, s) -P1\<rightarrow> (Seq c2 c1, t)"
+
+| CondT: "s \<in> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c1, s)"
+| CondF: "s \<notin> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c2, s)"
+
+| WhileF: "s \<notin> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Parallel [], s)"
+| WhileT: "s \<in> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Seq c (While b i c), s)"
+
+monos "rtrancl_mono"
+
+text {* The corresponding syntax translations are: *}
+
+abbreviation
+ ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
+ \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
+ "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
+
+abbreviation
+ ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
+ ("_ -*\<rightarrow> _"[81,81] 100) where
+ "con_0 -*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition\<^sup>*"
+
+abbreviation
+ transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P_\<rightarrow> _"[81,81,81] 100) where
+ "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
+
+subsection {* Definition of Semantics *}
+
+constdefs
+ ann_sem :: "'a ann_com \<Rightarrow> 'a \<Rightarrow> 'a set"
+ "ann_sem c \<equiv> \<lambda>s. {t. (Some c, s) -*\<rightarrow> (None, t)}"
+
+ ann_SEM :: "'a ann_com \<Rightarrow> 'a set \<Rightarrow> 'a set"
+ "ann_SEM c S \<equiv> \<Union>ann_sem c ` S"
+
+ sem :: "'a com \<Rightarrow> 'a \<Rightarrow> 'a set"
+ "sem c \<equiv> \<lambda>s. {t. \<exists>Ts. (c, s) -P*\<rightarrow> (Parallel Ts, t) \<and> All_None Ts}"
+
+ 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)"
+
+consts fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com"
+primrec
+ "fwhile b c 0 = \<Omega>"
+ "fwhile b c (Suc n) = Cond b (Seq c (fwhile b c n)) (Basic id)"
+
+subsubsection {* Proofs *}
+
+declare ann_transition_transition.intros [intro]
+inductive_cases transition_cases:
+ "(Parallel T,s) -P1\<rightarrow> t"
+ "(Basic f, s) -P1\<rightarrow> t"
+ "(Seq c1 c2, s) -P1\<rightarrow> t"
+ "(Cond b c1 c2, s) -P1\<rightarrow> t"
+ "(While b i c, s) -P1\<rightarrow> t"
+
+lemma Parallel_empty_lemma [rule_format (no_asm)]:
+ "(Parallel [],s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=[] \<and> n=0 \<and> s=t"
+apply(induct n)
+ apply(simp (no_asm))
+apply clarify
+apply(drule rel_pow_Suc_D2)
+apply(force elim:transition_cases)
+done
+
+lemma Parallel_AllNone_lemma [rule_format (no_asm)]:
+ "All_None Ss \<longrightarrow> (Parallel Ss,s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=Ss \<and> n=0 \<and> s=t"
+apply(induct "n")
+ apply(simp (no_asm))
+apply clarify
+apply(drule rel_pow_Suc_D2)
+apply clarify
+apply(erule transition_cases,simp_all)
+apply(force dest:nth_mem simp add:All_None_def)
+done
+
+lemma Parallel_AllNone: "All_None Ts \<Longrightarrow> (SEM (Parallel Ts) X) = X"
+apply (unfold SEM_def sem_def)
+apply auto
+apply(drule rtrancl_imp_UN_rel_pow)
+apply clarify
+apply(drule Parallel_AllNone_lemma)
+apply auto
+done
+
+lemma Parallel_empty: "Ts=[] \<Longrightarrow> (SEM (Parallel Ts) X) = X"
+apply(rule Parallel_AllNone)
+apply(simp add:All_None_def)
+done
+
+text {* Set of lemmas from Apt and Olderog "Verification of sequential
+and concurrent programs", page 63. *}
+
+lemma L3_5i: "X\<subseteq>Y \<Longrightarrow> SEM c X \<subseteq> SEM c Y"
+apply (unfold SEM_def)
+apply force
+done
+
+lemma L3_5ii_lemma1:
+ "\<lbrakk> (c1, s1) -P*\<rightarrow> (Parallel Ts, s2); All_None Ts;
+ (c2, s2) -P*\<rightarrow> (Parallel Ss, s3); All_None Ss \<rbrakk>
+ \<Longrightarrow> (Seq c1 c2, s1) -P*\<rightarrow> (Parallel Ss, s3)"
+apply(erule converse_rtrancl_induct2)
+apply(force intro:converse_rtrancl_into_rtrancl)+
+done
+
+lemma L3_5ii_lemma2 [rule_format (no_asm)]:
+ "\<forall>c1 c2 s t. (Seq c1 c2, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow>
+ (All_None Ts) \<longrightarrow> (\<exists>y m Rs. (c1,s) -P*\<rightarrow> (Parallel Rs, y) \<and>
+ (All_None Rs) \<and> (c2, y) -Pm\<rightarrow> (Parallel Ts, t) \<and> m \<le> n)"
+apply(induct "n")
+ apply(force)
+apply(safe dest!: rel_pow_Suc_D2)
+apply(erule transition_cases,simp_all)
+ apply (fast intro!: le_SucI)
+apply (fast intro!: le_SucI elim!: rel_pow_imp_rtrancl converse_rtrancl_into_rtrancl)
+done
+
+lemma L3_5ii_lemma3:
+ "\<lbrakk>(Seq c1 c2,s) -P*\<rightarrow> (Parallel Ts,t); All_None Ts\<rbrakk> \<Longrightarrow>
+ (\<exists>y Rs. (c1,s) -P*\<rightarrow> (Parallel Rs,y) \<and> All_None Rs
+ \<and> (c2,y) -P*\<rightarrow> (Parallel Ts,t))"
+apply(drule rtrancl_imp_UN_rel_pow)
+apply(fast dest: L3_5ii_lemma2 rel_pow_imp_rtrancl)
+done
+
+lemma L3_5ii: "SEM (Seq c1 c2) X = SEM c2 (SEM c1 X)"
+apply (unfold SEM_def sem_def)
+apply auto
+ apply(fast dest: L3_5ii_lemma3)
+apply(fast elim: L3_5ii_lemma1)
+done
+
+lemma L3_5iii: "SEM (Seq (Seq c1 c2) c3) X = SEM (Seq c1 (Seq c2 c3)) X"
+apply (simp (no_asm) add: L3_5ii)
+done
+
+lemma L3_5iv:
+ "SEM (Cond b c1 c2) X = (SEM c1 (X \<inter> b)) Un (SEM c2 (X \<inter> (-b)))"
+apply (unfold SEM_def sem_def)
+apply auto
+apply(erule converse_rtranclE)
+ prefer 2
+ apply (erule transition_cases,simp_all)
+ apply(fast intro: converse_rtrancl_into_rtrancl elim: transition_cases)+
+done
+
+
+lemma L3_5v_lemma1[rule_format]:
+ "(S,s) -Pn\<rightarrow> (T,t) \<longrightarrow> S=\<Omega> \<longrightarrow> (\<not>(\<exists>Rs. T=(Parallel Rs) \<and> All_None Rs))"
+apply (unfold UNIV_def)
+apply(rule nat_less_induct)
+apply safe
+apply(erule rel_pow_E2)
+ apply simp_all
+apply(erule transition_cases)
+ apply simp_all
+apply(erule rel_pow_E2)
+ apply(simp add: Id_def)
+apply(erule transition_cases,simp_all)
+apply clarify
+apply(erule transition_cases,simp_all)
+apply(erule rel_pow_E2,simp)
+apply clarify
+apply(erule transition_cases)
+ apply simp+
+ apply clarify
+ apply(erule transition_cases)
+apply simp_all
+done
+
+lemma L3_5v_lemma2: "\<lbrakk>(\<Omega>, s) -P*\<rightarrow> (Parallel Ts, t); All_None Ts \<rbrakk> \<Longrightarrow> False"
+apply(fast dest: rtrancl_imp_UN_rel_pow L3_5v_lemma1)
+done
+
+lemma L3_5v_lemma3: "SEM (\<Omega>) S = {}"
+apply (unfold SEM_def sem_def)
+apply(fast dest: L3_5v_lemma2)
+done
+
+lemma L3_5v_lemma4 [rule_format]:
+ "\<forall>s. (While b i c, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
+ (\<exists>k. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t))"
+apply(rule nat_less_induct)
+apply safe
+apply(erule rel_pow_E2)
+ apply safe
+apply(erule transition_cases,simp_all)
+ apply (rule_tac x = "1" in exI)
+ apply(force dest: Parallel_empty_lemma intro: converse_rtrancl_into_rtrancl simp add: Id_def)
+apply safe
+apply(drule L3_5ii_lemma2)
+ apply safe
+apply(drule le_imp_less_Suc)
+apply (erule allE , erule impE,assumption)
+apply (erule allE , erule impE, assumption)
+apply safe
+apply (rule_tac x = "k+1" in exI)
+apply(simp (no_asm))
+apply(rule converse_rtrancl_into_rtrancl)
+ apply fast
+apply(fast elim: L3_5ii_lemma1)
+done
+
+lemma L3_5v_lemma5 [rule_format]:
+ "\<forall>s. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
+ (While b i c, s) -P*\<rightarrow> (Parallel Ts,t)"
+apply(induct "k")
+ apply(force dest: L3_5v_lemma2)
+apply safe
+apply(erule converse_rtranclE)
+ apply simp_all
+apply(erule transition_cases,simp_all)
+ apply(rule converse_rtrancl_into_rtrancl)
+ apply(fast)
+ apply(fast elim!: L3_5ii_lemma1 dest: L3_5ii_lemma3)
+apply(drule rtrancl_imp_UN_rel_pow)
+apply clarify
+apply(erule rel_pow_E2)
+ apply simp_all
+apply(erule transition_cases,simp_all)
+apply(fast dest: Parallel_empty_lemma)
+done
+
+lemma L3_5v: "SEM (While b i c) = (\<lambda>x. (\<Union>k. SEM (fwhile b c k) x))"
+apply(rule ext)
+apply (simp add: SEM_def sem_def)
+apply safe
+ apply(drule rtrancl_imp_UN_rel_pow,simp)
+ apply clarify
+ apply(fast dest:L3_5v_lemma4)
+apply(fast intro: L3_5v_lemma5)
+done
+
+section {* Validity of Correctness Formulas *}
+
+constdefs
+ com_validity :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>= _// _//_)" [90,55,90] 50)
+ "\<parallel>= p c q \<equiv> SEM c p \<subseteq> q"
+
+ ann_com_validity :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> _ _" [60,90] 45)
+ "\<Turnstile> c q \<equiv> ann_SEM c (pre c) \<subseteq> q"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Quote_Antiquote.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,24 @@
+
+header {* \section{Concrete Syntax} *}
+
+theory Quote_Antiquote imports Main begin
+
+syntax
+ "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
+ "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b" ("\<acute>_" [1000] 1000)
+ "_Assert" :: "'a \<Rightarrow> 'a set" ("(.{_}.)" [0] 1000)
+
+syntax (xsymbols)
+ "_Assert" :: "'a \<Rightarrow> 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
+
+translations
+ ".{b}." \<rightharpoonup> "Collect \<guillemotleft>b\<guillemotright>"
+
+parse_translation {*
+ let
+ fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
+ | quote_tr ts = raise TERM ("quote_tr", ts);
+ in [("_quote", quote_tr)] end
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Com.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,25 @@
+
+header {* \chapter{The Rely-Guarantee Method}
+
+\section {Abstract Syntax}
+*}
+
+theory RG_Com imports Main begin
+
+text {* Semantics of assertions and boolean expressions (bexp) as sets
+of states. Syntax of commands @{text com} and parallel commands
+@{text par_com}. *}
+
+types
+ 'a bexp = "'a set"
+
+datatype 'a com =
+ Basic "'a \<Rightarrow>'a"
+ | Seq "'a com" "'a com"
+ | Cond "'a bexp" "'a com" "'a com"
+ | While "'a bexp" "'a com"
+ | Await "'a bexp" "'a com"
+
+types 'a par_com = "(('a com) option) list"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Examples.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,359 @@
+header {* \section{Examples} *}
+
+theory RG_Examples
+imports RG_Syntax
+begin
+
+lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def
+
+subsection {* Set Elements of an Array to Zero *}
+
+lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
+by simp
+
+lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
+by simp
+
+record Example1 =
+ A :: "nat list"
+
+lemma Example1:
+ "\<turnstile> COBEGIN
+ SCHEME [0 \<le> i < n]
+ (\<acute>A := \<acute>A [i := 0],
+ \<lbrace> n < length \<acute>A \<rbrace>,
+ \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
+ \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
+ \<lbrace> \<acute>A ! i = 0 \<rbrace>)
+ COEND
+ SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
+apply(rule Parallel)
+apply (auto intro!: Basic)
+done
+
+lemma Example1_parameterized:
+"k < t \<Longrightarrow>
+ \<turnstile> COBEGIN
+ SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
+ \<lbrace>t*n < length \<acute>A\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
+ \<lbrace>\<acute>A!i=0\<rbrace>)
+ COEND
+ SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
+ (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
+ \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
+apply(rule Parallel)
+ apply auto
+ apply(erule_tac x="k*n +i" in allE)
+ apply(subgoal_tac "k*n+i <length (A b)")
+ apply force
+ apply(erule le_less_trans2)
+ apply(case_tac t,simp+)
+ apply (simp add:add_commute)
+ apply(simp add: add_le_mono)
+apply(rule Basic)
+ apply simp
+ apply clarify
+ apply (subgoal_tac "k*n+i< length (A x)")
+ apply simp
+ apply(erule le_less_trans2)
+ apply(case_tac t,simp+)
+ apply (simp add:add_commute)
+ apply(rule add_le_mono, auto)
+done
+
+
+subsection {* Increment a Variable in Parallel *}
+
+subsubsection {* Two components *}
+
+record Example2 =
+ x :: nat
+ c_0 :: nat
+ c_1 :: nat
+
+lemma Example2:
+ "\<turnstile> COBEGIN
+ (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=0\<rbrace>,
+ \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
+ \<parallel>
+ (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
+ \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
+ COEND
+ SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
+ \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and> \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
+ \<lbrace>True\<rbrace>,
+ \<lbrace>\<acute>x=2\<rbrace>]"
+apply(rule Parallel)
+ apply simp_all
+ apply clarify
+ apply(case_tac i)
+ apply simp
+ apply(rule conjI)
+ apply clarify
+ apply simp
+ apply clarify
+ apply simp
+ apply(case_tac j,simp)
+ apply simp
+ apply simp
+ apply(rule conjI)
+ apply clarify
+ apply simp
+ apply clarify
+ apply simp
+ apply(subgoal_tac "j=0")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply arith
+ apply clarify
+ apply(case_tac i,simp,simp)
+ apply clarify
+ apply simp
+ apply(erule_tac x=0 in all_dupE)
+ apply(erule_tac x=1 in allE,simp)
+apply clarify
+apply(case_tac i,simp)
+ apply(rule Await)
+ apply simp_all
+ apply(clarify)
+ apply(rule Seq)
+ prefer 2
+ apply(rule Basic)
+ apply simp_all
+ apply(rule subset_refl)
+ apply(rule Basic)
+ apply simp_all
+ apply clarify
+ apply simp
+apply(rule Await)
+ apply simp_all
+apply(clarify)
+apply(rule Seq)
+ prefer 2
+ apply(rule Basic)
+ apply simp_all
+ apply(rule subset_refl)
+apply(auto intro!: Basic)
+done
+
+subsubsection {* Parameterized *}
+
+lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
+ (\<Sum>i=0..<n. (b i::nat)) =
+ (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
+apply(induct n)
+ apply simp_all
+apply(simp add:less_Suc_eq)
+ apply(auto)
+apply(subgoal_tac "n - j = Suc(n- Suc j)")
+ apply simp
+apply arith
+done
+
+lemma Example2_lemma2_aux2:
+ "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
+apply(induct j)
+ apply (simp_all cong:setsum_cong)
+done
+
+lemma Example2_lemma2:
+ "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
+apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
+apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
+apply(frule_tac b=b in Example2_lemma2_aux)
+apply(erule_tac t="setsum b {0..<n}" in ssubst)
+apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply(subgoal_tac "j\<le>j")
+ apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply simp_all
+done
+
+lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
+ Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
+by(simp add:Example2_lemma2)
+
+record Example2_parameterized =
+ C :: "nat \<Rightarrow> nat"
+ y :: nat
+
+lemma Example2_parameterized: "0<n \<Longrightarrow>
+ \<turnstile> COBEGIN SCHEME [0\<le>i<n]
+ (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
+ \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
+ \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
+ (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
+ (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
+ \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
+ COEND
+ SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
+apply(rule Parallel)
+apply force
+apply force
+apply(force)
+apply clarify
+apply simp
+apply(simp cong:setsum_ivl_cong)
+apply clarify
+apply simp
+apply(rule Await)
+apply simp_all
+apply clarify
+apply(rule Seq)
+prefer 2
+apply(rule Basic)
+apply(rule subset_refl)
+apply simp+
+apply(rule Basic)
+apply simp
+apply clarify
+apply simp
+apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
+apply simp+
+done
+
+subsection {* Find Least Element *}
+
+text {* A previous lemma: *}
+
+lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i; j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
+apply(subgoal_tac "a=a div n*n + a mod n" )
+ prefer 2 apply (simp (no_asm_use))
+apply(subgoal_tac "j=j div n*n + j mod n")
+ prefer 2 apply (simp (no_asm_use))
+apply simp
+apply(subgoal_tac "a div n*n < j div n*n")
+prefer 2 apply arith
+apply(subgoal_tac "j div n*n < (a div n + 1)*n")
+prefer 2 apply simp
+apply (simp only:mult_less_cancel2)
+apply arith
+done
+
+record Example3 =
+ X :: "nat \<Rightarrow> nat"
+ Y :: "nat \<Rightarrow> nat"
+
+lemma Example3: "m mod n=0 \<Longrightarrow>
+ \<turnstile> COBEGIN
+ SCHEME [0\<le>i<n]
+ (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j) DO
+ IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
+ ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
+ OD,
+ \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
+ \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
+ \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
+ \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
+ COEND
+ SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
+ \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
+ (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
+apply(rule Parallel)
+--{*5 subgoals left *}
+apply force+
+apply clarify
+apply simp
+apply(rule While)
+ apply force
+ apply force
+ apply force
+ apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * q \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
+ apply force
+ apply(rule subset_refl)+
+ apply(rule Cond)
+ apply force
+ apply(rule Basic)
+ apply force
+ apply fastsimp
+ apply force
+ apply force
+ apply(rule Basic)
+ apply simp
+ apply clarify
+ apply simp
+ apply (case_tac "X x (j mod n) \<le> j")
+ apply (drule le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
+ apply auto
+done
+
+text {* Same but with a list as auxiliary variable: *}
+
+record Example3_list =
+ X :: "nat list"
+ Y :: "nat list"
+
+lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
+ (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j) DO
+ IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
+ OD,
+ \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
+ \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
+ \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
+ \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
+ SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
+ \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
+ \<lbrace>True\<rbrace>,
+ \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
+ (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
+apply(rule Parallel)
+--{* 5 subgoals left *}
+apply force+
+apply clarify
+apply simp
+apply(rule While)
+ apply force
+ apply force
+ apply force
+ apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * q \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
+ apply force
+ apply(rule subset_refl)+
+ apply(rule Cond)
+ apply force
+ apply(rule Basic)
+ apply force
+ apply force
+ apply force
+ apply force
+ apply(rule Basic)
+ apply simp
+ apply clarify
+ apply simp
+ apply(rule allI)
+ apply(rule impI)+
+ apply(case_tac "X x ! i\<le> j")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
+ apply auto
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Hoare.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1375 @@
+header {* \section{The Proof System} *}
+
+theory RG_Hoare imports RG_Tran begin
+
+subsection {* Proof System for Component Programs *}
+
+declare Un_subset_iff [simp del] le_sup_iff [simp del]
+declare Cons_eq_map_conv [iff]
+
+constdefs
+ stable :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
+ "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"
+
+inductive
+ rghoare :: "['a com, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
+ ("\<turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
+where
+ Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s \<or> t=s)} \<subseteq> guar;
+ stable pre rely; stable post rely \<rbrakk>
+ \<Longrightarrow> \<turnstile> Basic f sat [pre, rely, guar, post]"
+
+| Seq: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mid]; \<turnstile> Q sat [mid, rely, guar, post] \<rbrakk>
+ \<Longrightarrow> \<turnstile> Seq P Q sat [pre, rely, guar, post]"
+
+| Cond: "\<lbrakk> stable pre rely; \<turnstile> P1 sat [pre \<inter> b, rely, guar, post];
+ \<turnstile> P2 sat [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
+ \<Longrightarrow> \<turnstile> Cond b P1 P2 sat [pre, rely, guar, post]"
+
+| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
+ \<turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
+ \<Longrightarrow> \<turnstile> While b P sat [pre, rely, guar, post]"
+
+| Await: "\<lbrakk> stable pre rely; stable post rely;
+ \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
+ \<Longrightarrow> \<turnstile> Await b P sat [pre, rely, guar, post]"
+
+| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
+ \<turnstile> P sat [pre', rely', guar', post'] \<rbrakk>
+ \<Longrightarrow> \<turnstile> P sat [pre, rely, guar, post]"
+
+constdefs
+ Pre :: "'a rgformula \<Rightarrow> 'a set"
+ "Pre x \<equiv> fst(snd x)"
+ Post :: "'a rgformula \<Rightarrow> 'a set"
+ "Post x \<equiv> snd(snd(snd(snd x)))"
+ Rely :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
+ "Rely x \<equiv> fst(snd(snd x))"
+ Guar :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
+ "Guar x \<equiv> fst(snd(snd(snd x)))"
+ Com :: "'a rgformula \<Rightarrow> 'a com"
+ "Com x \<equiv> fst x"
+
+subsection {* Proof System for Parallel Programs *}
+
+types 'a par_rgformula = "('a rgformula) list \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
+
+inductive
+ par_rghoare :: "('a rgformula) list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
+ ("\<turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
+where
+ Parallel:
+ "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j<length xs \<and> j\<noteq>i}. Guar(xs!j)) \<subseteq> Rely(xs!i);
+ (\<Union>j\<in>{j. j<length xs}. Guar(xs!j)) \<subseteq> guar;
+ pre \<subseteq> (\<Inter>i\<in>{i. i<length xs}. Pre(xs!i));
+ (\<Inter>i\<in>{i. i<length xs}. Post(xs!i)) \<subseteq> post;
+ \<forall>i<length xs. \<turnstile> Com(xs!i) sat [Pre(xs!i),Rely(xs!i),Guar(xs!i),Post(xs!i)] \<rbrakk>
+ \<Longrightarrow> \<turnstile> xs SAT [pre, rely, guar, post]"
+
+section {* Soundness*}
+
+subsubsection {* Some previous lemmas *}
+
+lemma tl_of_assum_in_assum:
+ "(P, s) # (P, t) # xs \<in> assum (pre, rely) \<Longrightarrow> stable pre rely
+ \<Longrightarrow> (P, t) # xs \<in> assum (pre, rely)"
+apply(simp add:assum_def)
+apply clarify
+apply(rule conjI)
+ apply(erule_tac x=0 in allE)
+ apply(simp (no_asm_use)only:stable_def)
+ apply(erule allE,erule allE,erule impE,assumption,erule mp)
+ apply(simp add:Env)
+apply clarify
+apply(erule_tac x="Suc i" in allE)
+apply simp
+done
+
+lemma etran_in_comm:
+ "(P, t) # xs \<in> comm(guar, post) \<Longrightarrow> (P, s) # (P, t) # xs \<in> comm(guar, post)"
+apply(simp add:comm_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma ctran_in_comm:
+ "\<lbrakk>(s, s) \<in> guar; (Q, s) # xs \<in> comm(guar, post)\<rbrakk>
+ \<Longrightarrow> (P, s) # (Q, s) # xs \<in> comm(guar, post)"
+apply(simp add:comm_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma takecptn_is_cptn [rule_format, elim!]:
+ "\<forall>j. c \<in> cptn \<longrightarrow> take (Suc j) c \<in> cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j)
+ apply simp
+ apply(rule CptnOne)
+apply simp
+apply(force intro:cptn.intros elim:cptn.cases)
+done
+
+lemma dropcptn_is_cptn [rule_format,elim!]:
+ "\<forall>j<length c. c \<in> cptn \<longrightarrow> drop j c \<in> cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j,simp+)
+apply(erule cptn.cases)
+ apply simp
+ apply force
+apply force
+done
+
+lemma takepar_cptn_is_par_cptn [rule_format,elim]:
+ "\<forall>j. c \<in> par_cptn \<longrightarrow> take (Suc j) c \<in> par_cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j,simp)
+ apply(rule ParCptnOne)
+apply(force intro:par_cptn.intros elim:par_cptn.cases)
+done
+
+lemma droppar_cptn_is_par_cptn [rule_format]:
+ "\<forall>j<length c. c \<in> par_cptn \<longrightarrow> drop j c \<in> par_cptn"
+apply(induct "c")
+ apply(force elim: par_cptn.cases)
+apply clarify
+apply(case_tac j,simp+)
+apply(erule par_cptn.cases)
+ apply simp
+ apply force
+apply force
+done
+
+lemma tl_of_cptn_is_cptn: "\<lbrakk>x # xs \<in> cptn; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs \<in> cptn"
+apply(subgoal_tac "1 < length (x # xs)")
+ apply(drule dropcptn_is_cptn,simp+)
+done
+
+lemma not_ctran_None [rule_format]:
+ "\<forall>s. (None, s)#xs \<in> cptn \<longrightarrow> (\<forall>i<length xs. ((None, s)#xs)!i -e\<rightarrow> xs!i)"
+apply(induct xs,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply simp
+ apply(case_tac i,simp)
+ apply(rule Env)
+ apply simp
+apply(force elim:ctran.cases)
+done
+
+lemma cptn_not_empty [simp]:"[] \<notin> cptn"
+apply(force elim:cptn.cases)
+done
+
+lemma etran_or_ctran [rule_format]:
+ "\<forall>m i. x\<in>cptn \<longrightarrow> m \<le> length x
+ \<longrightarrow> (\<forall>i. Suc i < m \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i) \<longrightarrow> Suc i < m
+ \<longrightarrow> x!i -e\<rightarrow> x!Suc i"
+apply(induct x,simp)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp)
+ apply(rule Env)
+ apply simp
+ apply(erule_tac x="m - 1" in allE)
+ apply(case_tac m,simp,simp)
+ apply(subgoal_tac "(\<forall>i. Suc i < nata \<longrightarrow> (((P, t) # xs) ! i, xs ! i) \<notin> ctran)")
+ apply force
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp)
+apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?J j) \<notin> ctran" in allE,simp)
+done
+
+lemma etran_or_ctran2 [rule_format]:
+ "\<forall>i. Suc i<length x \<longrightarrow> x\<in>cptn \<longrightarrow> (x!i -c\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i)
+ \<or> (x!i -e\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i)"
+apply(induct x)
+ apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+apply(case_tac i,simp)
+ apply(force elim:etran.cases)
+apply simp
+done
+
+lemma etran_or_ctran2_disjI1:
+ "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i"
+by(drule etran_or_ctran2,simp_all)
+
+lemma etran_or_ctran2_disjI2:
+ "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -e\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i"
+by(drule etran_or_ctran2,simp_all)
+
+lemma not_ctran_None2 [rule_format]:
+ "\<lbrakk> (None, s) # xs \<in>cptn; i<length xs\<rbrakk> \<Longrightarrow> \<not> ((None, s) # xs) ! i -c\<rightarrow> xs ! i"
+apply(frule not_ctran_None,simp)
+apply(case_tac i,simp)
+ apply(force elim:etranE)
+apply simp
+apply(rule etran_or_ctran2_disjI2,simp_all)
+apply(force intro:tl_of_cptn_is_cptn)
+done
+
+lemma Ex_first_occurrence [rule_format]: "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i<m. \<not> P i))";
+apply(rule nat_less_induct)
+apply clarify
+apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
+apply auto
+done
+
+lemma stability [rule_format]:
+ "\<forall>j k. x \<in> cptn \<longrightarrow> stable p rely \<longrightarrow> j\<le>k \<longrightarrow> k<length x \<longrightarrow> snd(x!j)\<in>p \<longrightarrow>
+ (\<forall>i. (Suc i)<length x \<longrightarrow>
+ (x!i -e\<rightarrow> x!(Suc i)) \<longrightarrow> (snd(x!i), snd(x!(Suc i))) \<in> rely) \<longrightarrow>
+ (\<forall>i. j\<le>i \<and> i<k \<longrightarrow> x!i -e\<rightarrow> x!Suc i) \<longrightarrow> snd(x!k)\<in>p \<and> fst(x!j)=fst(x!k)"
+apply(induct x)
+ apply clarify
+ apply(force elim:cptn.cases)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply simp
+ apply(case_tac k,simp,simp)
+ apply(case_tac j,simp)
+ apply(erule_tac x=0 in allE)
+ apply(erule_tac x="nat" and P="\<lambda>j. (0\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+ apply(subgoal_tac "t\<in>p")
+ apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran \<longrightarrow> ?T j" in allE,simp)
+ apply(simp(no_asm_use) only:stable_def)
+ apply(erule_tac x=s in allE)
+ apply(erule_tac x=t in allE)
+ apply simp
+ apply(erule mp)
+ apply(erule mp)
+ apply(rule Env)
+ apply simp
+ apply(erule_tac x="nata" in allE)
+ apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+ apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+apply(case_tac k,simp,simp)
+apply(case_tac j)
+ apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply(erule etran.cases,simp)
+apply(erule_tac x="nata" in allE)
+apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((Q, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((Q, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+apply clarify
+apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+done
+
+subsection {* Soundness of the System for Component Programs *}
+
+subsubsection {* Soundness of the Basic rule *}
+
+lemma unique_ctran_Basic [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s) \<longrightarrow>
+ Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
+ (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
+apply(induct x,simp)
+apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule Env)
+ apply simp
+apply clarify
+apply simp
+apply(case_tac i)
+ apply(case_tac j,simp,simp)
+ apply(erule ctran.cases,simp_all)
+ apply(force elim: not_ctran_None)
+apply(ind_cases "((Some (Basic f), sa), Q, t) \<in> ctran" for sa Q t)
+apply simp
+apply(drule_tac i=nat in not_ctran_None,simp)
+apply(erule etranE,simp)
+done
+
+lemma exists_ctran_Basic_None [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s)
+ \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
+apply(induct x,simp)
+apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp,simp)
+ apply(erule_tac x=nat in allE,simp)
+ apply clarify
+ apply(rule_tac x="Suc j" in exI,simp,simp)
+apply clarify
+apply(case_tac i,simp,simp)
+apply(rule_tac x=0 in exI,simp)
+done
+
+lemma Basic_sound:
+ " \<lbrakk>pre \<subseteq> {s. f s \<in> post}; {(s, t). s \<in> pre \<and> t = f s} \<subseteq> guar;
+ stable pre rely; stable post rely\<rbrakk>
+ \<Longrightarrow> \<Turnstile> Basic f sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:comm_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:cp_def assum_def)
+ apply clarify
+ apply(frule_tac j=0 and k=i and p=pre in stability)
+ apply simp_all
+ apply(erule_tac x=ia in allE,simp)
+ apply(erule_tac i=i and f=f in unique_ctran_Basic,simp_all)
+ apply(erule subsetD,simp)
+ apply(case_tac "x!i")
+ apply clarify
+ apply(drule_tac s="Some (Basic f)" in sym,simp)
+ apply(thin_tac "\<forall>j. ?H j")
+ apply(force elim:ctran.cases)
+apply clarify
+apply(simp add:cp_def)
+apply clarify
+apply(frule_tac i="length x - 1" and f=f in exists_ctran_Basic_None,simp+)
+ apply(case_tac x,simp+)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply (case_tac x,simp+)
+apply(simp add:assum_def)
+apply clarify
+apply(frule_tac j=0 and k="j" and p=pre in stability)
+ apply simp_all
+ apply(erule_tac x=i in allE,simp)
+ apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
+apply(case_tac "x!j")
+apply clarify
+apply simp
+apply(drule_tac s="Some (Basic f)" in sym,simp)
+apply(case_tac "x!Suc j",simp)
+apply(rule ctran.cases,simp)
+apply(simp_all)
+apply(drule_tac c=sa in subsetD,simp)
+apply clarify
+apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
+ apply(case_tac x,simp+)
+ apply(erule_tac x=i in allE)
+apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
+ apply arith+
+apply(case_tac x)
+apply(simp add:last_length)+
+done
+
+subsubsection{* Soundness of the Await rule *}
+
+lemma unique_ctran_Await [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s) \<longrightarrow>
+ Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
+ (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
+apply(induct x,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule Env)
+ apply simp
+apply clarify
+apply simp
+apply(case_tac i)
+ apply(case_tac j,simp,simp)
+ apply(erule ctran.cases,simp_all)
+ apply(force elim: not_ctran_None)
+apply(ind_cases "((Some (Await b c), sa), Q, t) \<in> ctran" for sa Q t,simp)
+apply(drule_tac i=nat in not_ctran_None,simp)
+apply(erule etranE,simp)
+done
+
+lemma exists_ctran_Await_None [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s)
+ \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
+apply(induct x,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply(erule_tac x=nat in allE,simp)
+ apply clarify
+ apply(rule_tac x="Suc j" in exI,simp,simp)
+apply clarify
+apply(case_tac i,simp,simp)
+apply(rule_tac x=0 in exI,simp)
+done
+
+lemma Star_imp_cptn:
+ "(P, s) -c*\<rightarrow> (R, t) \<Longrightarrow> \<exists>l \<in> cp P s. (last l)=(R, t)
+ \<and> (\<forall>i. Suc i<length l \<longrightarrow> l!i -c\<rightarrow> l!Suc i)"
+apply (erule converse_rtrancl_induct2)
+ apply(rule_tac x="[(R,t)]" in bexI)
+ apply simp
+ apply(simp add:cp_def)
+ apply(rule CptnOne)
+apply clarify
+apply(rule_tac x="(a, b)#l" in bexI)
+ apply (rule conjI)
+ apply(case_tac l,simp add:cp_def)
+ apply(simp add:last_length)
+ apply clarify
+apply(case_tac i,simp)
+apply(simp add:cp_def)
+apply force
+apply(simp add:cp_def)
+ apply(case_tac l)
+ apply(force elim:cptn.cases)
+apply simp
+apply(erule CptnComp)
+apply clarify
+done
+
+lemma Await_sound:
+ "\<lbrakk>stable pre rely; stable post rely;
+ \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
+ \<Turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
+ \<Longrightarrow> \<Turnstile> Await b P sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:comm_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:cp_def assum_def)
+ apply clarify
+ apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
+ apply(erule_tac x=ia in allE,simp)
+ apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
+ apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
+ apply(simp add:cp_def)
+--{* here starts the different part. *}
+ apply(erule ctran.cases,simp_all)
+ apply(drule Star_imp_cptn)
+ apply clarify
+ apply(erule_tac x=sa in allE)
+ apply clarify
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c=l in subsetD)
+ apply (simp add:cp_def)
+ apply clarify
+ apply(erule_tac x=ia and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
+ apply(erule etranE,simp)
+ apply simp
+apply clarify
+apply(simp add:cp_def)
+apply clarify
+apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
+ apply (case_tac x,simp+)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply(case_tac x, (simp add:cptn_not_empty)+)
+apply clarify
+apply(simp add:assum_def)
+apply clarify
+apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
+ apply(erule_tac x=i in allE,simp)
+ apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
+apply(case_tac "x!j")
+apply clarify
+apply simp
+apply(drule_tac s="Some (Await b P)" in sym,simp)
+apply(case_tac "x!Suc j",simp)
+apply(rule ctran.cases,simp)
+apply(simp_all)
+apply(drule Star_imp_cptn)
+apply clarify
+apply(erule_tac x=sa in allE)
+apply clarify
+apply(erule_tac x=sa in allE)
+apply(drule_tac c=l in subsetD)
+ apply (simp add:cp_def)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
+ apply(erule etranE,simp)
+apply simp
+apply clarify
+apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
+ apply(case_tac x,simp+)
+ apply(erule_tac x=i in allE)
+apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
+ apply arith+
+apply(case_tac x)
+apply(simp add:last_length)+
+done
+
+subsubsection{* Soundness of the Conditional rule *}
+
+lemma Cond_sound:
+ "\<lbrakk> stable pre rely; \<Turnstile> P1 sat [pre \<inter> b, rely, guar, post];
+ \<Turnstile> P2 sat [pre \<inter> - b, rely, guar, post]; \<forall>s. (s,s)\<in>guar\<rbrakk>
+ \<Longrightarrow> \<Turnstile> (Cond b P1 P2) sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:cp_def comm_def)
+apply(case_tac "\<exists>i. Suc i<length x \<and> x!i -c\<rightarrow> x!Suc i")
+ prefer 2
+ apply simp
+ apply clarify
+ apply(frule_tac j="0" and k="length x - 1" and p=pre in stability,simp+)
+ apply(case_tac x,simp+)
+ apply(simp add:assum_def)
+ apply(simp add:assum_def)
+ apply(erule_tac m="length x" in etran_or_ctran,simp+)
+ apply(case_tac x, (simp add:last_length)+)
+apply(erule exE)
+apply(drule_tac n=i and P="\<lambda>i. ?H i \<and> (?J i,?I i)\<in> ctran" in Ex_first_occurrence)
+apply clarify
+apply (simp add:assum_def)
+apply(frule_tac j=0 and k="m" and p=pre in stability,simp+)
+ apply(erule_tac m="Suc m" in etran_or_ctran,simp+)
+apply(erule ctran.cases,simp_all)
+ apply(erule_tac x="sa" in allE)
+ apply(drule_tac c="drop (Suc m) x" in subsetD)
+ apply simp
+ apply clarify
+ apply simp
+ apply clarify
+ apply(case_tac "i\<le>m")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(erule_tac x=i in allE, erule impE, assumption)
+ apply simp+
+ apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
+ apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
+ apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
+ apply(rotate_tac -2)
+ apply simp
+ apply arith
+ apply arith
+apply(case_tac "length (drop (Suc m) x)",simp)
+apply(erule_tac x="sa" in allE)
+back
+apply(drule_tac c="drop (Suc m) x" in subsetD,simp)
+ apply clarify
+apply simp
+apply clarify
+apply(case_tac "i\<le>m")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(erule_tac x=i in allE, erule impE, assumption)
+ apply simp
+ apply simp
+apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
+apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
+ apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
+ apply(rotate_tac -2)
+ apply simp
+ apply arith
+apply arith
+done
+
+subsubsection{* Soundness of the Sequential rule *}
+
+inductive_cases Seq_cases [elim!]: "(Some (Seq P Q), s) -c\<rightarrow> t"
+
+lemma last_lift_not_None: "fst ((lift Q) ((x#xs)!(length xs))) \<noteq> None"
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+
+declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
+lemma Seq_sound1 [rule_format]:
+ "x\<in> cptn_mod \<Longrightarrow> \<forall>s P. x !0=(Some (Seq P Q), s) \<longrightarrow>
+ (\<forall>i<length x. fst(x!i)\<noteq>Some Q) \<longrightarrow>
+ (\<exists>xs\<in> cp (Some P) s. x=map (lift Q) xs)"
+apply(erule cptn_mod.induct)
+apply(unfold cp_def)
+apply safe
+apply simp_all
+ apply(simp add:lift_def)
+ apply(rule_tac x="[(Some Pa, sa)]" in exI,simp add:CptnOne)
+ apply(subgoal_tac "(\<forall>i < Suc (length xs). fst (((Some (Seq Pa Q), t) # xs) ! i) \<noteq> Some Q)")
+ apply clarify
+ apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # zs" in exI,simp)
+ apply(rule conjI,erule CptnEnv)
+ apply(simp (no_asm_use) add:lift_def)
+ apply clarify
+ apply(erule_tac x="Suc i" in allE, simp)
+ apply(ind_cases "((Some (Seq Pa Q), sa), None, t) \<in> ctran" for Pa sa t)
+ apply(rule_tac x="(Some P, sa) # xs" in exI, simp add:cptn_iff_cptn_mod lift_def)
+apply(erule_tac x="length xs" in allE, simp)
+apply(simp only:Cons_lift_append)
+apply(subgoal_tac "length xs < length ((Some P, sa) # xs)")
+ apply(simp only :nth_append length_map last_length nth_map)
+ apply(case_tac "last((Some P, sa) # xs)")
+ apply(simp add:lift_def)
+apply simp
+done
+declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
+
+lemma Seq_sound2 [rule_format]:
+ "x \<in> cptn \<Longrightarrow> \<forall>s P i. x!0=(Some (Seq P Q), s) \<longrightarrow> i<length x
+ \<longrightarrow> fst(x!i)=Some Q \<longrightarrow>
+ (\<forall>j<i. fst(x!j)\<noteq>(Some Q)) \<longrightarrow>
+ (\<exists>xs ys. xs \<in> cp (Some P) s \<and> length xs=Suc i
+ \<and> ys \<in> cp (Some Q) (snd(xs !i)) \<and> x=(map (lift Q) xs)@tl ys)"
+apply(erule cptn.induct)
+apply(unfold cp_def)
+apply safe
+apply simp_all
+ apply(case_tac i,simp+)
+ apply(erule allE,erule impE,assumption,simp)
+ apply clarify
+ apply(subgoal_tac "(\<forall>j < nat. fst (((Some (Seq Pa Q), t) # xs) ! j) \<noteq> Some Q)",clarify)
+ prefer 2
+ apply force
+ apply(case_tac xsa,simp,simp)
+ apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # list" in exI,simp)
+ apply(rule conjI,erule CptnEnv)
+ apply(simp (no_asm_use) add:lift_def)
+ apply(rule_tac x=ys in exI,simp)
+apply(ind_cases "((Some (Seq Pa Q), sa), t) \<in> ctran" for Pa sa t)
+ apply simp
+ apply(rule_tac x="(Some Pa, sa)#[(None, ta)]" in exI,simp)
+ apply(rule conjI)
+ apply(drule_tac xs="[]" in CptnComp,force simp add:CptnOne,simp)
+ apply(case_tac i, simp+)
+ apply(case_tac nat,simp+)
+ apply(rule_tac x="(Some Q,ta)#xs" in exI,simp add:lift_def)
+ apply(case_tac nat,simp+)
+ apply(force)
+apply(case_tac i, simp+)
+apply(case_tac nat,simp+)
+apply(erule_tac x="Suc nata" in allE,simp)
+apply clarify
+apply(subgoal_tac "(\<forall>j<Suc nata. fst (((Some (Seq P2 Q), ta) # xs) ! j) \<noteq> Some Q)",clarify)
+ prefer 2
+ apply clarify
+ apply force
+apply(rule_tac x="(Some Pa, sa)#(Some P2, ta)#(tl xsa)" in exI,simp)
+apply(rule conjI,erule CptnComp)
+apply(rule nth_tl_if,force,simp+)
+apply(rule_tac x=ys in exI,simp)
+apply(rule conjI)
+apply(rule nth_tl_if,force,simp+)
+ apply(rule tl_zero,simp+)
+ apply force
+apply(rule conjI,simp add:lift_def)
+apply(subgoal_tac "lift Q (Some P2, ta) =(Some (Seq P2 Q), ta)")
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule nth_tl_if)
+ apply force
+ apply simp+
+apply(simp add:lift_def)
+done
+(*
+lemma last_lift_not_None3: "fst (last (map (lift Q) (x#xs))) \<noteq> None"
+apply(simp only:last_length [THEN sym])
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+*)
+
+lemma last_lift_not_None2: "fst ((lift Q) (last (x#xs))) \<noteq> None"
+apply(simp only:last_length [THEN sym])
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+
+lemma Seq_sound:
+ "\<lbrakk>\<Turnstile> P sat [pre, rely, guar, mid]; \<Turnstile> Q sat [mid, rely, guar, post]\<rbrakk>
+ \<Longrightarrow> \<Turnstile> Seq P Q sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(case_tac "\<exists>i<length x. fst(x!i)=Some Q")
+ prefer 2
+ apply (simp add:cp_def cptn_iff_cptn_mod)
+ apply clarify
+ apply(frule_tac Seq_sound1,force)
+ apply force
+ apply clarify
+ apply(erule_tac x=s in allE,simp)
+ apply(drule_tac c=xs in subsetD,simp add:cp_def cptn_iff_cptn_mod)
+ apply(simp add:assum_def)
+ apply clarify
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(force elim:etranE intro:Env simp add:lift_def)
+ apply(simp add:comm_def)
+ apply(rule conjI)
+ apply clarify
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(case_tac "(xs!i)")
+ apply(case_tac "(xs! Suc i)")
+ apply(case_tac "fst(xs!i)")
+ apply(erule_tac x=i in allE, simp add:lift_def)
+ apply(case_tac "fst(xs!Suc i)")
+ apply(force simp add:lift_def)
+ apply(force simp add:lift_def)
+ apply clarify
+ apply(case_tac xs,simp add:cp_def)
+ apply clarify
+ apply (simp del:map.simps)
+ apply(subgoal_tac "(map (lift Q) ((a, b) # list))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+ apply simp
+--{* @{text "\<exists>i<length x. fst (x ! i) = Some Q"} *}
+apply(erule exE)
+apply(drule_tac n=i and P="\<lambda>i. i < length x \<and> fst (x ! i) = Some Q" in Ex_first_occurrence)
+apply clarify
+apply (simp add:cp_def)
+ apply clarify
+ apply(frule_tac i=m in Seq_sound2,force)
+ apply simp+
+apply clarify
+apply(simp add:comm_def)
+apply(erule_tac x=s in allE)
+apply(drule_tac c=xs in subsetD,simp)
+ apply(case_tac "xs=[]",simp)
+ apply(simp add:cp_def assum_def nth_append)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ back
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(force elim:etranE intro:Env simp add:lift_def)
+apply simp
+apply clarify
+apply(erule_tac x="snd(xs!m)" in allE)
+apply(drule_tac c=ys in subsetD,simp add:cp_def assum_def)
+ apply(case_tac "xs\<noteq>[]")
+ apply(drule last_conv_nth,simp)
+ apply(rule conjI)
+ apply(erule mp)
+ apply(case_tac "xs!m")
+ apply(case_tac "fst(xs!m)",simp)
+ apply(simp add:lift_def nth_append)
+ apply clarify
+ apply(erule_tac x="m+i" in allE)
+ back
+ back
+ apply(case_tac ys,(simp add:nth_append)+)
+ apply (case_tac i, (simp add:snd_lift)+)
+ apply(erule mp)
+ apply(case_tac "xs!m")
+ apply(force elim:etran.cases intro:Env simp add:lift_def)
+ apply simp
+apply simp
+apply clarify
+apply(rule conjI,clarify)
+ apply(case_tac "i<m",simp add:nth_append)
+ apply(simp add:snd_lift)
+ apply(erule allE, erule impE, assumption, erule mp)
+ apply(case_tac "(xs ! i)")
+ apply(case_tac "(xs ! Suc i)")
+ apply(case_tac "fst(xs ! i)",force simp add:lift_def)
+ apply(case_tac "fst(xs ! Suc i)")
+ apply (force simp add:lift_def)
+ apply (force simp add:lift_def)
+ apply(erule_tac x="i-m" in allE)
+ back
+ back
+ apply(subgoal_tac "Suc (i - m) < length ys",simp)
+ prefer 2
+ apply arith
+ apply(simp add:nth_append snd_lift)
+ apply(rule conjI,clarify)
+ apply(subgoal_tac "i=m")
+ prefer 2
+ apply arith
+ apply clarify
+ apply(simp add:cp_def)
+ apply(rule tl_zero)
+ apply(erule mp)
+ apply(case_tac "lift Q (xs!m)",simp add:snd_lift)
+ apply(case_tac "xs!m",case_tac "fst(xs!m)",simp add:lift_def snd_lift)
+ apply(case_tac ys,simp+)
+ apply(simp add:lift_def)
+ apply simp
+ apply force
+ apply clarify
+ apply(rule tl_zero)
+ apply(rule tl_zero)
+ apply (subgoal_tac "i-m=Suc(i-Suc m)")
+ apply simp
+ apply(erule mp)
+ apply(case_tac ys,simp+)
+ apply force
+ apply arith
+ apply force
+apply clarify
+apply(case_tac "(map (lift Q) xs @ tl ys)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply(simp add: snd_lift nth_append)
+ apply(rule conjI,clarify)
+ apply(case_tac ys,simp+)
+ apply clarify
+ apply(case_tac ys,simp+)
+done
+
+subsubsection{* Soundness of the While rule *}
+
+lemma last_append[rule_format]:
+ "\<forall>xs. ys\<noteq>[] \<longrightarrow> ((xs@ys)!(length (xs@ys) - (Suc 0)))=(ys!(length ys - (Suc 0)))"
+apply(induct ys)
+ apply simp
+apply clarify
+apply (simp add:nth_append length_append)
+done
+
+lemma assum_after_body:
+ "\<lbrakk> \<Turnstile> P sat [pre \<inter> b, rely, guar, pre];
+ (Some P, s) # xs \<in> cptn_mod; fst (last ((Some P, s) # xs)) = None; s \<in> b;
+ (Some (While b P), s) # (Some (Seq P (While b P)), s) #
+ map (lift (While b P)) xs @ ys \<in> assum (pre, rely)\<rbrakk>
+ \<Longrightarrow> (Some (While b P), snd (last ((Some P, s) # xs))) # ys \<in> assum (pre, rely)"
+apply(simp add:assum_def com_validity_def cp_def cptn_iff_cptn_mod)
+apply clarify
+apply(erule_tac x=s in allE)
+apply(drule_tac c="(Some P, s) # xs" in subsetD,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" in allE)
+ apply simp
+ apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
+ apply(erule mp)
+ apply(erule etranE,simp)
+ apply(case_tac "fst(((Some P, s) # xs) ! i)")
+ apply(force intro:Env simp add:lift_def)
+ apply(force intro:Env simp add:lift_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:comm_def last_length)
+apply clarify
+apply(rule conjI)
+ apply(simp add:comm_def)
+apply clarify
+apply(erule_tac x="Suc(length xs + i)" in allE,simp)
+apply(case_tac i, simp add:nth_append Cons_lift_append snd_lift del:map.simps)
+ apply(simp add:last_length)
+ apply(erule mp)
+ apply(case_tac "last xs")
+ apply(simp add:lift_def)
+apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
+done
+
+lemma While_sound_aux [rule_format]:
+ "\<lbrakk> pre \<inter> - b \<subseteq> post; \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s, s) \<in> guar;
+ stable pre rely; stable post rely; x \<in> cptn_mod \<rbrakk>
+ \<Longrightarrow> \<forall>s xs. x=(Some(While b P),s)#xs \<longrightarrow> x\<in>assum(pre, rely) \<longrightarrow> x \<in> comm (guar, post)"
+apply(erule cptn_mod.induct)
+apply safe
+apply (simp_all del:last.simps)
+--{* 5 subgoals left *}
+apply(simp add:comm_def)
+--{* 4 subgoals left *}
+apply(rule etran_in_comm)
+apply(erule mp)
+apply(erule tl_of_assum_in_assum,simp)
+--{* While-None *}
+apply(ind_cases "((Some (While b P), s), None, t) \<in> ctran" for s t)
+apply(simp add:comm_def)
+apply(simp add:cptn_iff_cptn_mod [THEN sym])
+apply(rule conjI,clarify)
+ apply(force simp add:assum_def)
+apply clarify
+apply(rule conjI, clarify)
+ apply(case_tac i,simp,simp)
+ apply(force simp add:not_ctran_None2)
+apply(subgoal_tac "\<forall>i. Suc i < length ((None, t) # xs) \<longrightarrow> (((None, t) # xs) ! i, ((None, t) # xs) ! Suc i)\<in> etran")
+ prefer 2
+ apply clarify
+ apply(rule_tac m="length ((None, s) # xs)" in etran_or_ctran,simp+)
+ apply(erule not_ctran_None2,simp)
+ apply simp+
+apply(frule_tac j="0" and k="length ((None, s) # xs) - 1" and p=post in stability,simp+)
+ apply(force simp add:assum_def subsetD)
+ apply(simp add:assum_def)
+ apply clarify
+ apply(erule_tac x="i" in allE,simp)
+ apply(erule_tac x="Suc i" in allE,simp)
+ apply simp
+apply clarify
+apply (simp add:last_length)
+--{* WhileOne *}
+apply(thin_tac "P = While b P \<longrightarrow> ?Q")
+apply(rule ctran_in_comm,simp)
+apply(simp add:Cons_lift del:map.simps)
+apply(simp add:comm_def del:map.simps)
+apply(rule conjI)
+ apply clarify
+ apply(case_tac "fst(((Some P, sa) # xs) ! i)")
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply (simp add:lift_def)
+ apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
+ apply simp
+ apply simp
+ apply(simp add:snd_lift del:map.simps)
+ apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c="(Some P, sa) # xs" in subsetD)
+ apply (simp add:assum_def del:map.simps)
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp add:snd_lift del:map.simps)
+ apply(erule mp)
+ apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply (simp add:comm_def del:map.simps)
+ apply clarify
+ apply(erule allE,erule impE,assumption)
+ apply(erule mp)
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply(case_tac "xs!i")
+ apply(simp add:lift_def)
+ apply(case_tac "fst(xs!i)")
+ apply force
+ apply force
+--{* last=None *}
+apply clarify
+apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+apply simp
+--{* WhileMore *}
+apply(thin_tac "P = While b P \<longrightarrow> ?Q")
+apply(rule ctran_in_comm,simp del:last.simps)
+--{* metiendo la hipotesis antes de dividir la conclusion. *}
+apply(subgoal_tac "(Some (While b P), snd (last ((Some P, sa) # xs))) # ys \<in> assum (pre, rely)")
+ apply (simp del:last.simps)
+ prefer 2
+ apply(erule assum_after_body)
+ apply (simp del:last.simps)+
+--{* lo de antes. *}
+apply(simp add:comm_def del:map.simps last.simps)
+apply(rule conjI)
+ apply clarify
+ apply(simp only:Cons_lift_append)
+ apply(case_tac "i<length xs")
+ apply(simp add:nth_append del:map.simps last.simps)
+ apply(case_tac "fst(((Some P, sa) # xs) ! i)")
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply (simp add:lift_def del:last.simps)
+ apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
+ apply simp
+ apply simp
+ apply(simp add:snd_lift del:map.simps last.simps)
+ apply(thin_tac " \<forall>i. i < length ys \<longrightarrow> ?P i")
+ apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c="(Some P, sa) # xs" in subsetD)
+ apply (simp add:assum_def del:map.simps last.simps)
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp add:nth_append snd_lift del:map.simps last.simps, erule mp)
+ apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply (simp add:comm_def del:map.simps)
+ apply clarify
+ apply(erule allE,erule impE,assumption)
+ apply(erule mp)
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply(case_tac "xs!i")
+ apply(simp add:lift_def)
+ apply(case_tac "fst(xs!i)")
+ apply force
+ apply force
+--{* @{text "i \<ge> length xs"} *}
+apply(subgoal_tac "i-length xs <length ys")
+ prefer 2
+ apply arith
+apply(erule_tac x="i-length xs" in allE,clarify)
+apply(case_tac "i=length xs")
+ apply (simp add:nth_append snd_lift del:map.simps last.simps)
+ apply(simp add:last_length del:last.simps)
+ apply(erule mp)
+ apply(case_tac "last((Some P, sa) # xs)")
+ apply(simp add:lift_def del:last.simps)
+--{* @{text "i>length xs"} *}
+apply(case_tac "i-length xs")
+ apply arith
+apply(simp add:nth_append del:map.simps last.simps)
+apply(rotate_tac -3)
+apply(subgoal_tac "i- Suc (length xs)=nat")
+ prefer 2
+ apply arith
+apply simp
+--{* last=None *}
+apply clarify
+apply(case_tac ys)
+ apply(simp add:Cons_lift del:map.simps last.simps)
+ apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+ apply simp
+apply(subgoal_tac "((Some (Seq P (While b P)), sa) # map (lift (While b P)) xs @ ys)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps last.simps)
+ apply(simp add:nth_append del:last.simps)
+ apply(subgoal_tac "((Some (While b P), snd (last ((Some P, sa) # xs))) # a # list)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps last.simps)
+ apply simp
+apply simp
+done
+
+lemma While_sound:
+ "\<lbrakk>stable pre rely; pre \<inter> - b \<subseteq> post; stable post rely;
+ \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar\<rbrakk>
+ \<Longrightarrow> \<Turnstile> While b P sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(erule_tac xs="tl x" in While_sound_aux)
+ apply(simp add:com_validity_def)
+ apply force
+ apply simp_all
+apply(simp add:cptn_iff_cptn_mod cp_def)
+apply(simp add:cp_def)
+apply clarify
+apply(rule nth_equalityI)
+ apply simp_all
+ apply(case_tac x,simp+)
+apply clarify
+apply(case_tac i,simp+)
+apply(case_tac x,simp+)
+done
+
+subsubsection{* Soundness of the Rule of Consequence *}
+
+lemma Conseq_sound:
+ "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
+ \<Turnstile> P sat [pre', rely', guar', post']\<rbrakk>
+ \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
+apply(simp add:com_validity_def assum_def comm_def)
+apply clarify
+apply(erule_tac x=s in allE)
+apply(drule_tac c=x in subsetD)
+ apply force
+apply force
+done
+
+subsubsection {* Soundness of the system for sequential component programs *}
+
+theorem rgsound:
+ "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
+apply(erule rghoare.induct)
+ apply(force elim:Basic_sound)
+ apply(force elim:Seq_sound)
+ apply(force elim:Cond_sound)
+ apply(force elim:While_sound)
+ apply(force elim:Await_sound)
+apply(erule Conseq_sound,simp+)
+done
+
+subsection {* Soundness of the System for Parallel Programs *}
+
+constdefs
+ ParallelCom :: "('a rgformula) list \<Rightarrow> 'a par_com"
+ "ParallelCom Ps \<equiv> map (Some \<circ> fst) Ps"
+
+lemma two:
+ "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i<length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x\<in>par_assum(pre, rely);
+ \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
+ \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -c\<rightarrow> (clist!i!Suc j)
+ \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> Guar(xs!i)"
+apply(unfold par_cp_def)
+apply (rule ccontr)
+--{* By contradiction: *}
+apply (simp del: Un_subset_iff)
+apply(erule exE)
+--{* the first c-tran that does not satisfy the guarantee-condition is from @{text "\<sigma>_i"} at step @{text "m"}. *}
+apply(drule_tac n=j and P="\<lambda>j. \<exists>i. ?H i j" in Ex_first_occurrence)
+apply(erule exE)
+apply clarify
+--{* @{text "\<sigma>_i \<in> A(pre, rely_1)"} *}
+apply(subgoal_tac "take (Suc (Suc m)) (clist!i) \<in> assum(Pre(xs!i), Rely(xs!i))")
+--{* but this contradicts @{text "\<Turnstile> \<sigma>_i sat [pre_i,rely_i,guar_i,post_i]"} *}
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
+ apply(simp add:com_validity_def)
+ apply(erule_tac x=s in allE)
+ apply(simp add:cp_def comm_def)
+ apply(drule_tac c="take (Suc (Suc m)) (clist ! i)" in subsetD)
+ apply simp
+ apply (blast intro: takecptn_is_cptn)
+ apply simp
+ apply clarify
+ apply(erule_tac x=m and P="\<lambda>j. ?I j \<and> ?J j \<longrightarrow> ?H j" in allE)
+ apply (simp add:conjoin_def same_length_def)
+apply(simp add:assum_def del: Un_subset_iff)
+apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<in>cp (?K j) (?J j)" in allE)
+ apply(simp add:cp_def par_assum_def)
+ apply(drule_tac c="s" in subsetD,simp)
+ apply simp
+apply clarify
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?M \<union> UNION (?S j) (?T j) \<subseteq> (?L j)" in allE)
+apply(simp del: Un_subset_iff)
+apply(erule subsetD)
+apply simp
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j) \<or> ?Q j" in allE,simp)
+--{* each etran in @{text "\<sigma>_1[0\<dots>m]"} corresponds to *}
+apply(erule disjE)
+--{* a c-tran in some @{text "\<sigma>_{ib}"} *}
+ apply clarify
+ apply(case_tac "i=ib",simp)
+ apply(erule etranE,simp)
+ apply(erule_tac x="ib" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE)
+ apply (erule etranE)
+ apply(case_tac "ia=m",simp)
+ apply simp
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (\<forall> i. ?P i j)" in allE)
+ apply(subgoal_tac "ia<m",simp)
+ prefer 2
+ apply arith
+ apply(erule_tac x=ib and P="\<lambda>j. (?I j, ?H j)\<in> ctran \<longrightarrow> (?P i j)" in allE,simp)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
+ apply(erule_tac x=ib and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+--{* or an e-tran in @{text "\<sigma>"},
+therefore it satisfies @{text "rely \<or> guar_{ib}"} *}
+apply (force simp add:par_assum_def same_state_def)
+done
+
+
+lemma three [rule_format]:
+ "\<lbrakk> xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i<length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum(pre, rely);
+ \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
+ \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -e\<rightarrow> (clist!i!Suc j)
+ \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))"
+apply(drule two)
+ apply simp_all
+apply clarify
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (?J j \<and> (\<exists>i. ?P i j)) \<or> ?I j" in allE,simp)
+apply(erule disjE)
+ prefer 2
+ apply(force simp add:same_state_def par_assum_def)
+apply clarify
+apply(case_tac "i=ia",simp)
+ apply(erule etranE,simp)
+apply(erule_tac x="ia" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE,simp)
+apply(erule_tac x=j and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
+apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
+apply(simp add:same_state_def)
+apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+done
+
+lemma four:
+ "\<lbrakk>xs\<noteq>[]; \<forall>i < length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ (\<Union>j\<in>{j. j < length xs}. Guar (xs ! j)) \<subseteq> guar;
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i < length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely); Suc i < length x;
+ x ! i -pc\<rightarrow> x ! Suc i\<rbrakk>
+ \<Longrightarrow> (snd (x ! i), snd (x ! Suc i)) \<in> guar"
+apply(simp add: ParallelCom_def del: Un_subset_iff)
+apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
+ prefer 2
+ apply simp
+apply(frule rev_subsetD)
+ apply(erule one [THEN equalityD1])
+apply(erule subsetD)
+apply (simp del: Un_subset_iff)
+apply clarify
+apply(drule_tac pre=pre and rely=rely and x=x and s=s and xs=xs and clist=clist in two)
+apply(assumption+)
+ apply(erule sym)
+ apply(simp add:ParallelCom_def)
+ apply assumption
+ apply(simp add:Com_def)
+ apply assumption
+apply(simp add:conjoin_def same_program_def)
+apply clarify
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in all_dupE)
+apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
+apply(erule par_ctranE,simp)
+apply(erule_tac x=i and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
+apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
+apply(rule_tac x=ia in exI)
+apply(simp add:same_state_def)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE,simp)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE)
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE,simp)
+apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+apply(erule mp)
+apply(subgoal_tac "r=fst(clist ! ia ! Suc i)",simp)
+apply(drule_tac i=ia in list_eq_if)
+back
+apply simp_all
+done
+
+lemma parcptn_not_empty [simp]:"[] \<notin> par_cptn"
+apply(force elim:par_cptn.cases)
+done
+
+lemma five:
+ "\<lbrakk>xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ (\<Inter>i\<in>{i. i < length xs}. Post (xs ! i)) \<subseteq> post;
+ \<forall>i < length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely);
+ All_None (fst (last x)) \<rbrakk> \<Longrightarrow> snd (last x) \<in> post"
+apply(simp add: ParallelCom_def del: Un_subset_iff)
+apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
+ prefer 2
+ apply simp
+apply(frule rev_subsetD)
+ apply(erule one [THEN equalityD1])
+apply(erule subsetD)
+apply(simp del: Un_subset_iff)
+apply clarify
+apply(subgoal_tac "\<forall>i<length clist. clist!i\<in>assum(Pre(xs!i), Rely(xs!i))")
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
+ apply(simp add:com_validity_def)
+ apply(erule_tac x=s in allE)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I j) \<in> cp (?J j) s" in allE,simp)
+ apply(drule_tac c="clist!i" in subsetD)
+ apply (force simp add:Com_def)
+ apply(simp add:comm_def conjoin_def same_program_def del:last.simps)
+ apply clarify
+ apply(erule_tac x="length x - 1" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
+ apply (simp add:All_None_def same_length_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> length(?J j)=(?K j)" in allE)
+ apply(subgoal_tac "length x - 1 < length x",simp)
+ apply(case_tac "x\<noteq>[]")
+ apply(simp add: last_conv_nth)
+ apply(erule_tac x="clist!i" in ballE)
+ apply(simp add:same_state_def)
+ apply(subgoal_tac "clist!i\<noteq>[]")
+ apply(simp add: last_conv_nth)
+ apply(case_tac x)
+ apply (force simp add:par_cp_def)
+ apply (force simp add:par_cp_def)
+ apply force
+ apply (force simp add:par_cp_def)
+ apply(case_tac x)
+ apply (force simp add:par_cp_def)
+ apply (force simp add:par_cp_def)
+apply clarify
+apply(simp add:assum_def)
+apply(rule conjI)
+ apply(simp add:conjoin_def same_state_def par_cp_def)
+ apply clarify
+ apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(case_tac x,simp+)
+ apply (simp add:par_assum_def)
+ apply clarify
+ apply(drule_tac c="snd (clist ! ia ! 0)" in subsetD)
+ apply assumption
+ apply simp
+apply clarify
+apply(erule_tac x=ia in all_dupE)
+apply(rule subsetD, erule mp, assumption)
+apply(erule_tac pre=pre and rely=rely and x=x and s=s in three)
+ apply(erule_tac x=ic in allE,erule mp)
+ apply simp_all
+ apply(simp add:ParallelCom_def)
+ apply(force simp add:Com_def)
+apply(simp add:conjoin_def same_length_def)
+done
+
+lemma ParallelEmpty [rule_format]:
+ "\<forall>i s. x \<in> par_cp (ParallelCom []) s \<longrightarrow>
+ Suc i < length x \<longrightarrow> (x ! i, x ! Suc i) \<notin> par_ctran"
+apply(induct_tac x)
+ apply(simp add:par_cp_def ParallelCom_def)
+apply clarify
+apply(case_tac list,simp,simp)
+apply(case_tac i)
+ apply(simp add:par_cp_def ParallelCom_def)
+ apply(erule par_ctranE,simp)
+apply(simp add:par_cp_def ParallelCom_def)
+apply clarify
+apply(erule par_cptn.cases,simp)
+ apply simp
+apply(erule par_ctranE)
+back
+apply simp
+done
+
+theorem par_rgsound:
+ "\<turnstile> c SAT [pre, rely, guar, post] \<Longrightarrow>
+ \<Turnstile> (ParallelCom c) SAT [pre, rely, guar, post]"
+apply(erule par_rghoare.induct)
+apply(case_tac xs,simp)
+ apply(simp add:par_com_validity_def par_comm_def)
+ apply clarify
+ apply(case_tac "post=UNIV",simp)
+ apply clarify
+ apply(drule ParallelEmpty)
+ apply assumption
+ apply simp
+ apply clarify
+ apply simp
+apply(subgoal_tac "xs\<noteq>[]")
+ prefer 2
+ apply simp
+apply(thin_tac "xs = a # list")
+apply(simp add:par_com_validity_def par_comm_def)
+apply clarify
+apply(rule conjI)
+ apply clarify
+ apply(erule_tac pre=pre and rely=rely and guar=guar and x=x and s=s and xs=xs in four)
+ apply(assumption+)
+ apply clarify
+ apply (erule allE, erule impE, assumption,erule rgsound)
+ apply(assumption+)
+apply clarify
+apply(erule_tac pre=pre and rely=rely and post=post and x=x and s=s and xs=xs in five)
+ apply(assumption+)
+ apply clarify
+ apply (erule allE, erule impE, assumption,erule rgsound)
+ apply(assumption+)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Syntax.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,95 @@
+header {* \section{Concrete Syntax} *}
+
+theory RG_Syntax
+imports RG_Hoare Quote_Antiquote
+begin
+
+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)
+ "_Await" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0AWAIT _ /THEN /_ /END)" [0,0] 61)
+ "_Atom" :: "'a com \<Rightarrow> 'a com" ("(\<langle>_\<rangle>)" 61)
+ "_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"
+ "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"
+ "WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
+
+nonterminals
+ prgs
+
+syntax
+ "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" 60)
+ "_prg" :: "'a \<Rightarrow> prgs" ("_" 57)
+ "_prgs" :: "['a, prgs] \<Rightarrow> prgs" ("_//\<parallel>//_" [60,57] 57)
+
+translations
+ "_prg a" \<rightharpoonup> "[a]"
+ "_prgs a ps" \<rightharpoonup> "a # ps"
+ "_PAR ps" \<rightharpoonup> "ps"
+
+syntax
+ "_prg_scheme" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs" ("SCHEME [_ \<le> _ < _] _" [0,0,0,60] 57)
+
+translations
+ "_prg_scheme j i k c" \<rightleftharpoons> "(map (\<lambda>i. c) [j..<k])"
+
+text {* Translations for variables before and after a transition: *}
+
+syntax
+ "_before" :: "id \<Rightarrow> 'a" ("\<ordmasculine>_")
+ "_after" :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")
+
+translations
+ "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>fst"
+ "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>snd"
+
+print_translation {*
+ let
+ fun quote_tr' f (t :: ts) =
+ Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ | quote_tr' _ _ = raise Match;
+
+ val assert_tr' = quote_tr' (Syntax.const "_Assert");
+
+ fun bexp_tr' name ((Const ("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
+ | K_tr' _ = raise Match;
+
+ fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
+ quote_tr' (Syntax.const "_Assign" $ 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")]
+ end
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Tran.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1075 @@
+header {* \section{Operational Semantics} *}
+
+theory RG_Tran
+imports RG_Com
+begin
+
+subsection {* Semantics of Component Programs *}
+
+subsubsection {* Environment transitions *}
+
+types 'a conf = "(('a com) option) \<times> 'a"
+
+inductive_set
+ etran :: "('a conf \<times> 'a conf) set"
+ and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -e\<rightarrow> _" [81,81] 80)
+where
+ "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
+| Env: "(P, s) -e\<rightarrow> (P, t)"
+
+lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
+ by (induct c, induct c', erule etran.cases, blast)
+
+subsubsection {* Component transitions *}
+
+inductive_set
+ ctran :: "('a conf \<times> 'a conf) set"
+ and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c\<rightarrow> _" [81,81] 80)
+ and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c*\<rightarrow> _" [81,81] 80)
+where
+ "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
+| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran^*"
+
+| Basic: "(Some(Basic f), s) -c\<rightarrow> (None, f s)"
+
+| Seq1: "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"
+
+| Seq2: "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"
+
+| CondT: "s\<in>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
+| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"
+
+| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
+| WhileT: "s\<in>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"
+
+| Await: "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"
+
+monos "rtrancl_mono"
+
+subsection {* Semantics of Parallel Programs *}
+
+types 'a par_conf = "('a par_com) \<times> 'a"
+
+inductive_set
+ par_etran :: "('a par_conf \<times> 'a par_conf) set"
+ and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
+where
+ "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
+| ParEnv: "(Ps, s) -pe\<rightarrow> (Ps, t)"
+
+inductive_set
+ par_ctran :: "('a par_conf \<times> 'a par_conf) set"
+ and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
+where
+ "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
+| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"
+
+lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
+ (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
+ (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
+ by (induct c, induct c', erule par_ctran.cases, blast)
+
+subsection {* Computations *}
+
+subsubsection {* Sequential computations *}
+
+types 'a confs = "('a conf) list"
+
+inductive_set cptn :: "('a confs) set"
+where
+ CptnOne: "[(P,s)] \<in> cptn"
+| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
+| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"
+
+constdefs
+ cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set"
+ "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"
+
+subsubsection {* Parallel computations *}
+
+types 'a par_confs = "('a par_conf) list"
+
+inductive_set par_cptn :: "('a par_confs) set"
+where
+ ParCptnOne: "[(P,s)] \<in> par_cptn"
+| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
+| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"
+
+constdefs
+ par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set"
+ "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"
+
+subsection{* Modular Definition of Computation *}
+
+constdefs
+ lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf"
+ "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"
+
+inductive_set cptn_mod :: "('a confs) set"
+where
+ CptnModOne: "[(P, s)] \<in> cptn_mod"
+| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
+| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
+| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
+| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
+| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
+ \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
+| CptnModSeq2:
+ "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
+ (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
+ zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
+
+| CptnModWhile1:
+ "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
+ \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
+| CptnModWhile2:
+ "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
+ zs=(map (lift (While b P)) xs)@ys;
+ (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
+ \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
+
+subsection {* Equivalence of Both Definitions.*}
+
+lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
+apply simp
+apply(induct xs,simp+)
+apply(case_tac xs)
+apply simp_all
+done
+
+lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
+ (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
+ (\<exists>xs. (Some P, s)#xs \<in> cptn_mod \<and> (zs=(map (lift Q) xs) \<or>
+ ( fst(((Some P, s)#xs)!length xs)=None \<and>
+ (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
+ \<and> zs=(map (lift (Q)) xs)@ys)))))"
+apply(erule cptn_mod.induct)
+apply simp_all
+ apply clarify
+ apply(force intro:CptnModOne)
+ apply clarify
+ apply(erule_tac x=Pa in allE)
+ apply(erule_tac x=Q in allE)
+ apply simp
+ apply clarify
+ apply(erule disjE)
+ apply(rule_tac x="(Some Pa,t)#xsa" in exI)
+ apply(rule conjI)
+ apply clarify
+ apply(erule CptnModEnv)
+ apply(rule disjI1)
+ apply(simp add:lift_def)
+ apply clarify
+ apply(rule_tac x="(Some Pa,t)#xsa" in exI)
+ apply(rule conjI)
+ apply(erule CptnModEnv)
+ apply(rule disjI2)
+ apply(rule conjI)
+ apply(case_tac xsa,simp,simp)
+ apply(rule_tac x="ys" in exI)
+ apply(rule conjI)
+ apply simp
+ apply(simp add:lift_def)
+ apply clarify
+ apply(erule ctran.cases,simp_all)
+ apply clarify
+ apply(rule_tac x="xs" in exI)
+ apply simp
+ apply clarify
+apply(rule_tac x="xs" in exI)
+apply(simp add: last_length)
+done
+
+lemma cptn_onlyif_cptn_mod_aux [rule_format]:
+ "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
+ \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
+apply(induct a)
+apply simp_all
+--{* basic *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,rule Basic,simp)
+apply clarify
+apply(erule ctran.cases,simp_all)
+--{* Seq1 *}
+apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
+ apply(erule CptnModNone)
+ apply(rule CptnModOne)
+ apply simp
+apply simp
+apply(simp add:lift_def)
+--{* Seq2 *}
+apply(erule_tac x=sa in allE)
+apply(erule_tac x="Some P2" in allE)
+apply(erule allE,erule impE, assumption)
+apply(drule div_seq,simp)
+apply force
+apply clarify
+apply(erule disjE)
+ apply clarify
+ apply(erule allE,erule impE, assumption)
+ apply(erule_tac CptnModSeq1)
+ apply(simp add:lift_def)
+apply clarify
+apply(erule allE,erule impE, assumption)
+apply(erule_tac CptnModSeq2)
+ apply (simp add:last_length)
+ apply (simp add:last_length)
+apply(simp add:lift_def)
+--{* Cond *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(force elim: CptnModCondT)
+apply(force elim: CptnModCondF)
+--{* While *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,erule WhileF,simp)
+apply(drule div_seq,force)
+apply clarify
+apply (erule disjE)
+ apply(force elim:CptnModWhile1)
+apply clarify
+apply(force simp add:last_length elim:CptnModWhile2)
+--{* await *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,erule Await,simp+)
+done
+
+lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
+apply(erule cptn.induct)
+ apply(rule CptnModOne)
+ apply(erule CptnModEnv)
+apply(case_tac P)
+ apply simp
+ apply(erule ctran.cases,simp_all)
+apply(force elim:cptn_onlyif_cptn_mod_aux)
+done
+
+lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
+apply(erule cptn.induct)
+ apply(force simp add:lift_def CptnOne)
+ apply(force intro:CptnEnv simp add:lift_def)
+apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
+done
+
+lemma cptn_append_is_cptn [rule_format]:
+ "\<forall>b a. b#c1\<in>cptn \<longrightarrow> a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
+apply(induct c1)
+ apply simp
+apply clarify
+apply(erule cptn.cases,simp_all)
+ apply(force intro:CptnEnv)
+apply(force elim:CptnComp)
+done
+
+lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
+ \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
+apply(case_tac "(xs ! (length xs - (Suc 0)))")
+apply (simp add:lift_def)
+done
+
+lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
+apply(induct x,simp+)
+done
+
+lemma last_fst_esp:
+ "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
+apply(erule last_fst)
+apply simp
+done
+
+lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
+ snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
+apply(case_tac "(xs ! (length xs - (Suc 0)))",simp)
+apply (simp add:lift_def)
+done
+
+lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
+by(simp add:lift_def)
+
+lemma Cons_lift_append:
+ "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
+by(simp add:lift_def)
+
+lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q (xs! i)"
+by (simp add:lift_def)
+
+lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
+apply(case_tac "xs!i")
+apply(simp add:lift_def)
+done
+
+lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
+apply(erule cptn_mod.induct)
+ apply(rule CptnOne)
+ apply(erule CptnEnv)
+ apply(erule CptnComp,simp)
+ apply(rule CptnComp)
+ apply(erule CondT,simp)
+ apply(rule CptnComp)
+ apply(erule CondF,simp)
+--{* Seq1 *}
+apply(erule cptn.cases,simp_all)
+ apply(rule CptnOne)
+ apply clarify
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply(rule CptnEnv,simp)
+apply clarify
+apply(simp add:lift_def)
+apply(rule conjI)
+ apply clarify
+ apply(rule CptnComp)
+ apply(rule Seq1,simp)
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+apply clarify
+apply(rule CptnComp)
+ apply(rule Seq2,simp)
+apply(drule_tac P=P1 in lift_is_cptn)
+apply(simp add:lift_def)
+--{* Seq2 *}
+apply(rule cptn_append_is_cptn)
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply simp
+apply(case_tac "xs\<noteq>[]")
+ apply(drule_tac P=P1 in last_lift)
+ apply(rule last_fst_esp)
+ apply (simp add:last_length)
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule conjI, clarify, simp)
+ apply(case_tac "(((Some P0, s) # xs) ! length xs)")
+ apply clarify
+ apply (simp add:lift_def last_length)
+apply (simp add:last_length)
+--{* While1 *}
+apply(rule CptnComp)
+apply(rule WhileT,simp)
+apply(drule_tac P="While b P" in lift_is_cptn)
+apply(simp add:lift_def)
+--{* While2 *}
+apply(rule CptnComp)
+apply(rule WhileT,simp)
+apply(rule cptn_append_is_cptn)
+apply(drule_tac P="While b P" in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply simp
+apply(case_tac "xs\<noteq>[]")
+ apply(drule_tac P="While b P" in last_lift)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule conjI, clarify, simp)
+ apply(case_tac "(((Some P, s) # xs) ! length xs)")
+ apply clarify
+ apply (simp add:last_length lift_def)
+apply simp
+done
+
+theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
+apply(rule iffI)
+ apply(erule cptn_onlyif_cptn_mod)
+apply(erule cptn_if_cptn_mod)
+done
+
+section {* Validity of Correctness Formulas*}
+
+subsection {* Validity for Component Programs. *}
+
+types 'a rgformula = "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
+
+constdefs
+ assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set"
+ "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
+
+ comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set"
+ "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
+ (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"
+
+ com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
+ ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
+ "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
+ \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"
+
+subsection {* Validity for Parallel Programs. *}
+
+constdefs
+ All_None :: "(('a com) option) list \<Rightarrow> bool"
+ "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"
+
+ par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set"
+ "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
+
+ par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set"
+ "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
+ (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"
+
+ par_com_validity :: "'a par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
+\<Rightarrow> 'a set \<Rightarrow> bool" ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
+ "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
+ \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"
+
+subsection {* Compositionality of the Semantics *}
+
+subsubsection {* Definition of the conjoin operator *}
+
+constdefs
+ same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"
+
+ same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"
+
+ same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"
+
+ compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
+ (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
+ (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
+ (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"
+
+ conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" ("_ \<propto> _" [65,65] 64)
+ "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"
+
+subsubsection {* Some previous lemmas *}
+
+lemma list_eq_if [rule_format]:
+ "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
+apply (induct xs)
+ apply simp
+apply clarify
+done
+
+lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
+apply(rule iffI)
+ apply clarify
+ apply(erule nth_equalityI)
+ apply simp+
+done
+
+lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
+apply(case_tac ys)
+ apply simp+
+done
+
+lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
+apply(induct ys)
+ apply simp+
+done
+
+lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
+apply(induct ys)
+ apply simp+
+done
+
+lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
+seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
+if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]
+
+lemma prog_not_eq_in_ctran_aux:
+ assumes c: "(P,s) -c\<rightarrow> (Q,t)"
+ shows "P\<noteq>Q" using c
+ by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto
+
+lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
+apply clarify
+apply(drule prog_not_eq_in_ctran_aux)
+apply simp
+done
+
+lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
+apply(erule par_ctran.induct)
+apply(drule prog_not_eq_in_ctran_aux)
+apply clarify
+apply(drule list_eq_if)
+ apply simp_all
+apply force
+done
+
+lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
+apply clarify
+apply(drule prog_not_eq_in_par_ctran_aux)
+apply simp
+done
+
+lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
+apply(force elim:cptn.cases)
+done
+
+lemma tl_zero[rule_format]:
+ "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
+apply(induct ys)
+ apply simp_all
+done
+
+subsection {* The Semantics is Compositional *}
+
+lemma aux_if [rule_format]:
+ "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
+ \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
+ \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
+apply(induct ys)
+ apply(clarify)
+ apply(rule ParCptnOne)
+apply(clarify)
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in all_dupE,simp)
+apply(erule disjE)
+--{* first step is a Component step *}
+ apply clarify
+ apply simp
+ apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
+ apply(subgoal_tac "b=snd(clist!i!0)",simp)
+ prefer 2
+ apply(simp add: same_state_def)
+ apply(erule_tac x=i in allE,erule impE,assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ prefer 2
+ apply(simp add:same_program_def)
+ apply(erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(rule ParCptnComp)
+ apply(erule ParComp,simp)
+--{* applying the induction hypothesis *}
+ apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
+ apply(erule_tac x="snd (clist ! i ! 0)" in allE)
+ apply(erule mp)
+ apply(rule_tac x="map tl clist" in exI,simp)
+ apply(rule conjI,clarify)
+ apply(case_tac "i=ia",simp)
+ apply(rule nth_tl_if)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply simp
+ apply(erule allE,erule impE,assumption,erule tl_in_cptn)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(rule nth_tl_if)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(erule allE,erule impE,assumption,erule tl_in_cptn)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(simp add:same_length_def same_state_def)
+ apply(rule conjI)
+ apply clarify
+ apply(case_tac j,simp,simp)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force simp add:length_Suc_conv)
+ apply(rule allI,rule impI)
+ apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
+ apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=ia in exI,simp)
+ apply(case_tac "i=ia",simp)
+ apply(rule conjI)
+ apply(force simp add: length_Suc_conv)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
+ apply simp
+ apply(case_tac j,simp)
+ apply(rule tl_zero)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply force
+ apply simp
+ apply(rule tl_zero)
+ apply(erule tl_zero)
+ apply force
+ apply force
+ apply force
+ apply force
+ apply(rule conjI,simp)
+ apply(rule nth_tl_if)
+ apply force
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(erule tl_zero)
+ apply force
+ apply force
+ apply clarify
+ apply(case_tac "i=l",simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption,erule impE,assumption)
+ apply(erule tl_zero,force)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
+ apply(erule etranE,simp)
+ apply(rule tl_zero)
+ apply force
+ apply force
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(rule disjI2)
+ apply(case_tac j,simp)
+ apply clarify
+ apply(rule tl_zero)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j\<in>etran" in allE,erule impE, assumption)
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply clarify
+ apply(rule tl_zero)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+--{* first step is an environmental step *}
+apply clarify
+apply(erule par_etran.cases)
+apply simp
+apply(rule ParCptnEnv)
+apply(erule_tac x="Ps" in allE)
+apply(erule_tac x="t" in allE)
+apply(erule mp)
+apply(rule_tac x="map tl clist" in exI,simp)
+apply(rule conjI)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I ?s j) \<in> cptn" in allE,simp)
+ apply(erule cptn.cases)
+ apply(simp add:same_length_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<in>etran" in allE,simp)
+ apply(erule etranE,simp)
+apply(simp add:same_state_def same_length_def)
+apply(rule conjI,clarify)
+ apply(case_tac j,simp,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule tl_zero)
+ apply(simp)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply simp
+ apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force simp add:length_Suc_conv)
+apply(rule allI,rule impI)
+apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
+apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule etranE,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(erule tl_zero,force)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule etranE,simp)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply(rule disjI2)
+apply simp
+apply clarify
+apply(case_tac j,simp)
+ apply(rule tl_zero)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply simp
+apply(rule tl_zero)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+done
+
+lemma less_Suc_0 [iff]: "(n < Suc 0) = (n = 0)"
+by auto
+
+lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
+ (\<exists>clist. (length clist = length xs) \<and>
+ (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
+ (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
+apply(induct ys)
+ apply(clarify)
+ apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
+ apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
+ apply(rule conjI)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force intro: cptn.intros)
+apply(clarify)
+apply(erule par_cptn.cases,simp)
+ apply simp
+ apply(erule_tac x="xs" in allE)
+ apply(erule_tac x="t" in allE,simp)
+ apply clarify
+ apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
+ apply(rule conjI)
+ prefer 2
+ apply clarify
+ apply(rule CptnEnv,simp)
+ apply(simp add:conjoin_def same_length_def same_state_def)
+ apply (rule conjI)
+ apply clarify
+ apply(case_tac j,simp,simp)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply simp
+ apply(rule nth_equalityI,simp,simp)
+ apply(simp add:compat_label_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(simp add:ParEnv)
+ apply clarify
+ apply(simp add:Env)
+ apply simp
+ apply(erule_tac x=nat in allE,erule impE, assumption)
+ apply(erule disjE,simp)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply force
+apply(erule par_ctran.cases,simp)
+apply(erule_tac x="Ps[i:=r]" in allE)
+apply(erule_tac x="ta" in allE,simp)
+apply clarify
+apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
+apply(rule conjI)
+ prefer 2
+ apply clarify
+ apply(case_tac "i=ia",simp)
+ apply(erule CptnComp)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<in> cptn)" in allE,simp)
+ apply simp
+ apply(erule_tac x=ia in allE)
+ apply(rule CptnEnv,simp)
+apply(simp add:conjoin_def)
+apply (rule conjI)
+ apply(simp add:same_length_def)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+apply(rule conjI)
+ apply(simp add:same_state_def)
+ apply clarify
+ apply(case_tac j, simp, simp (no_asm_simp))
+ apply(case_tac "i=ia",simp,simp)
+apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply simp
+ apply(rule nth_equalityI,simp,simp)
+ apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (fst (?a j))=((?b j))" in allE)
+ apply(case_tac nat)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+apply(simp add:compat_label_def)
+apply clarify
+apply(case_tac j)
+ apply(rule conjI,simp)
+ apply(erule ParComp,assumption)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply clarify
+ apply(rule Env)
+apply simp
+apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in allE,simp)
+apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=ia in exI,simp)
+ apply(rule conjI)
+ apply(case_tac "i=ia",simp,simp)
+ apply clarify
+ apply(case_tac "i=l",simp)
+ apply(case_tac "l=ia",simp,simp)
+ apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
+ apply simp
+ apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
+apply clarify
+apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption)
+apply(case_tac "i=ia",simp,simp)
+done
+
+lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
+ (\<exists>clist. length clist= length xs \<and>
+ ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
+ (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
+ (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
+ (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
+apply (rule iffI)
+ apply(rule subset_antisym)
+ apply(rule subsetI)
+ apply(clarify)
+ apply(simp add:par_cp_def cp_def)
+ apply(case_tac x)
+ apply(force elim:par_cptn.cases)
+ apply simp
+ apply(erule_tac x="list" in allE)
+ apply clarify
+ apply simp
+ apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
+ apply(rule subsetI)
+ apply(clarify)
+ apply(case_tac x)
+ apply(erule_tac x=0 in allE)
+ apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
+ apply clarify
+ apply(erule cptn.cases,force,force,force)
+ apply(simp add:par_cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
+ apply clarify
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in all_dupE)
+ apply(subgoal_tac "a = xs")
+ apply(subgoal_tac "b = s",simp)
+ prefer 3
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=((?t j))" in allE)
+ apply (simp add:cp_def)
+ apply(rule nth_equalityI,simp,simp)
+ prefer 2
+ apply(erule_tac x=0 in allE)
+ apply (simp add:cp_def)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (\<forall>i. ?T i \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=list in allE)
+ apply(rule_tac x="map tl clist" in exI,simp)
+ apply(rule conjI)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="Suc nat" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(rule conjI)
+ apply clarify
+ apply(rule nth_equalityI,simp,simp)
+ apply(case_tac j)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply clarify
+ apply simp
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(thin_tac "?H = (\<exists>i. ?J i)")
+ apply(rule conjI)
+ apply clarify
+ apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(case_tac j,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply clarify
+ apply(simp add:cp_def)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply simp
+ apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp)
+ apply(rule nth_tl_if,simp,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption,simp)
+ apply(simp add:cp_def)
+ apply clarify
+ apply(rule nth_tl_if)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply force
+ apply force
+apply clarify
+apply(rule iffI)
+ apply(simp add:par_cp_def)
+ apply(erule_tac c="(xs, s) # ys" in equalityCE)
+ apply simp
+ apply clarify
+ apply(rule_tac x="map tl clist" in exI)
+ apply simp
+ apply (rule conjI)
+ apply(simp add:conjoin_def cp_def)
+ apply(rule conjI)
+ apply clarify
+ apply(unfold same_length_def)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,simp)
+ apply(rule conjI)
+ apply(simp add:same_state_def)
+ apply clarify
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(case_tac j,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(rule nth_equalityI,simp,simp)
+ apply(case_tac j,simp)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(simp add:compat_label_def)
+ apply(rule allI,rule impI)
+ apply(erule_tac x=j in allE,erule impE, assumption)
+ apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i in allE)
+ apply(case_tac j,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply(erule_tac x=l in allE,simp)
+ apply(rule disjI2)
+ apply clarify
+ apply(rule tl_zero)
+ apply(case_tac j,simp,simp)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(rule nth_tl_if)
+ apply(simp add:conjoin_def)
+ apply clarify
+ apply(simp add:same_length_def)
+ apply(erule_tac x=i in allE,simp)
+ apply simp
+ apply simp
+ apply simp
+apply clarify
+apply(erule_tac c="(xs, s) # ys" in equalityCE)
+ apply(simp add:par_cp_def)
+apply simp
+apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
+apply simp
+apply clarify
+apply(simp add:cp_def)
+done
+
+theorem one: "xs\<noteq>[] \<Longrightarrow>
+ par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
+ (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
+apply(frule one_iff_aux)
+apply(drule sym)
+apply(erule iffD2)
+apply clarify
+apply(rule iffI)
+ apply(erule aux_onlyif)
+apply clarify
+apply(force intro:aux_if)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,2 @@
+
+use_thy "Hoare_Parallel";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/document/root.bib Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,28 @@
+@inproceedings{NipkowP-FASE99,author={Tobias Nipkow and Prensa Nieto, Leonor},
+title={{Owicki/Gries} in {Isabelle/HOL}},
+booktitle={Fundamental Approaches to Software Engineering (FASE'99)},
+editor={J.-P. Finance},publisher="Springer",series="LNCS",volume=1577,
+pages={188--203},year=1999}
+
+@InProceedings{PrenEsp00,
+ author = {Prensa Nieto, Leonor and Javier Esparza},
+ title = {Verifying Single and Multi-mutator Garbage Collectors
+ with {Owicki/Gries} in {Isabelle/HOL}},
+ booktitle = {Mathematical Foundations of Computer Science (MFCS 2000)},
+ editor = {M. Nielsen and B. Rovan},
+ publisher = {Springer-Verlag},
+ series = {LNCS},
+ volume = 1893,
+ pages = {619--628},
+ year = 2000
+}
+
+@PhdThesis{Prensa-PhD,author={Leonor Prensa Nieto},
+title={Verification of Parallel Programs with the Owicki-Gries and
+Rely-Guarantee Methods in Isabelle/HOL},
+school={Technische Universit{\"a}t M{\"u}nchen},year=2002}
+
+@inproceedings{Prensa-ESOP03,author={Prensa Nieto, Leonor},
+title={The {Rely-Guarantee} Method in {Isabelle/HOL}},
+booktitle={European Symposium on Programming (ESOP'03)},editor={P. Degano},
+publisher=Springer,series=LNCS,volume=2618,pages={348--362},year=2003}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/document/root.tex Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,62 @@
+
+% $Id$
+
+\documentclass[11pt,a4paper]{report}
+\usepackage{graphicx}
+\usepackage[english]{babel}
+\usepackage{isabelle,isabellesym}
+\usepackage{pdfsetup}
+
+\urlstyle{rm}
+\isabellestyle{it}
+
+\renewcommand{\isamarkupheader}[1]{#1}
+
+\begin{document}
+
+\title{Hoare Logic for Parallel Programs}
+\author{Leonor Prensa Nieto}
+\maketitle
+
+\begin{abstract}\noindent
+ In the following theories a formalization of the Owicki-Gries and
+ the rely-guarantee methods is presented. These methods are widely
+ used for correctness proofs of parallel imperative programs with
+ shared variables. We define syntax, semantics and proof rules in
+ Isabelle/HOL. The proof rules also provide for programs
+ parameterized in the number of parallel components. Their
+ correctness w.r.t.\ the semantics is proven. Completeness proofs
+ for both methods are extended to the new case of parameterized
+ programs. (These proofs have not been formalized in Isabelle. They
+ can be found in~\cite{Prensa-PhD}.) Using this formalizations we
+ verify several non-trivial examples for parameterized and
+ non-parameterized programs. For the automatic generation of
+ verification conditions with the Owicki-Gries method we define a
+ tactic based on the proof rules. The most involved examples are the
+ verification of two garbage-collection algorithms, the second one
+ parameterized in the number of mutators.
+
+For excellent descriptions of this work see
+\cite{NipkowP-FASE99,PrenEsp00,Prensa-PhD,Prensa-ESOP03}.
+
+\end{abstract}
+
+\pagestyle{plain}
+\thispagestyle{empty}
+\tableofcontents
+
+\clearpage
+
+\begin{center}
+ \includegraphics[scale=0.7]{session_graph}
+\end{center}
+
+\newpage
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\bibliographystyle{plain}
+\bibliography{root}
+
+\end{document}
--- a/src/HOL/Imperative_HOL/Array.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Imperative_HOL/Array.thy Thu Oct 01 07:40:25 2009 +0200
@@ -176,12 +176,11 @@
code_type array (OCaml "_/ array")
code_const Array (OCaml "failwith/ \"bare Array\"")
-code_const Array.new' (OCaml "(fun/ ()/ ->/ Array.make/ _/ _)")
+code_const Array.new' (OCaml "(fun/ ()/ ->/ Array.make/ (Big'_int.int'_of'_big'_int/ _)/ _)")
code_const Array.of_list (OCaml "(fun/ ()/ ->/ Array.of'_list/ _)")
-code_const Array.make' (OCaml "(fun/ ()/ ->/ Array.init/ _/ _)")
-code_const Array.length' (OCaml "(fun/ ()/ ->/ Array.length/ _)")
-code_const Array.nth' (OCaml "(fun/ ()/ ->/ Array.get/ _/ _)")
-code_const Array.upd' (OCaml "(fun/ ()/ ->/ Array.set/ _/ _/ _)")
+code_const Array.length' (OCaml "(fun/ ()/ ->/ Big'_int.big'_int'_of'_int/ (Array.length/ _))")
+code_const Array.nth' (OCaml "(fun/ ()/ ->/ Array.get/ _/ (Big'_int.int'_of'_big'_int/ _))")
+code_const Array.upd' (OCaml "(fun/ ()/ ->/ Array.set/ _/ (Big'_int.int'_of'_big'_int/ _)/ _)")
code_reserved OCaml Array
--- a/src/HOL/Imperative_HOL/ex/Sublist.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Imperative_HOL/ex/Sublist.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,4 +1,3 @@
-(* $Id$ *)
header {* Slices of lists *}
@@ -6,7 +5,6 @@
imports Multiset
begin
-
lemma sublist_split: "i \<le> j \<and> j \<le> k \<Longrightarrow> sublist xs {i..<j} @ sublist xs {j..<k} = sublist xs {i..<k}"
apply (induct xs arbitrary: i j k)
apply simp
--- a/src/HOL/Import/HOL/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/HOL/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,8 +1,4 @@
-(* Title: HOL/Import/HOL/ROOT.ML
- ID: $Id$
- Author: Sebastian Skalberg (TU Muenchen)
-*)
-use_thy "Primes";
+use_thy "~~/src/HOL/Old_Number_Theory/Primes";
setmp_noncritical quick_and_dirty true use_thy "HOL4Prob";
setmp_noncritical quick_and_dirty true use_thy "HOL4";
--- a/src/HOL/Import/HOL4Compat.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/HOL4Compat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -3,7 +3,7 @@
*)
theory HOL4Compat
-imports HOL4Setup Complex_Main Primes ContNotDenum
+imports HOL4Setup Complex_Main "~~/src/HOL/Old_Number_Theory/Primes" ContNotDenum
begin
no_notation differentiable (infixl "differentiable" 60)
--- a/src/HOL/Import/hol4rews.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/hol4rews.ML Thu Oct 01 07:40:25 2009 +0200
@@ -168,7 +168,7 @@
fun merge _ = Library.gen_union Thm.eq_thm
)
-val hol4_debug = ref false
+val hol4_debug = Unsynchronized.ref false
fun message s = if !hol4_debug then writeln s else ()
local
@@ -531,7 +531,7 @@
val _ = app (fn (hol,(internal,isa,opt_ty)) =>
(out ("\n " ^ (trans_string hol) ^ " > " ^ (trans_string (follow_cname isa thy)));
case opt_ty of
- SOME ty => out (" :: \"" ^ (Display.string_of_ctyp (ctyp_of thy ty)) ^ "\"")
+ SOME ty => out (" :: \"" ^ Syntax.string_of_typ_global thy ty ^ "\"")
| NONE => ())) constmaps
val _ = if null constmaps
then ()
--- a/src/HOL/Import/import.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/import.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
signature IMPORT =
sig
- val debug : bool ref
+ val debug : bool Unsynchronized.ref
val import_tac : Proof.context -> string * string -> tactic
val setup : theory -> theory
end
@@ -21,7 +21,7 @@
structure Import :> IMPORT =
struct
-val debug = ref false
+val debug = Unsynchronized.ref false
fun message s = if !debug then writeln s else ()
fun import_tac ctxt (thyname, thmname) =
--- a/src/HOL/Import/import_syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/import_syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -157,8 +157,9 @@
val _ = TextIO.closeIn is
val orig_source = Source.of_string inp
val symb_source = Symbol.source {do_recover = false} orig_source
- val lexes = ref (Scan.make_lexicon (map Symbol.explode ["import_segment","ignore_thms","import","end",">","::","const_maps","const_moves","thm_maps","const_renames","type_maps","def_maps"]),
- Scan.empty_lexicon)
+ val lexes = Unsynchronized.ref
+ (Scan.make_lexicon (map Symbol.explode ["import_segment","ignore_thms","import","end",">","::","const_maps","const_moves","thm_maps","const_renames","type_maps","def_maps"]),
+ Scan.empty_lexicon)
val get_lexes = fn () => !lexes
val token_source = OuterLex.source {do_recover = NONE} get_lexes Position.start symb_source
val token_list = filter_out (OuterLex.is_kind OuterLex.Space) (Source.exhaust token_source)
--- a/src/HOL/Import/importrecorder.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/importrecorder.ML Thu Oct 01 07:40:25 2009 +0200
@@ -72,9 +72,9 @@
| AbortReplay of string*string
| Delta of deltastate list
-val history = ref ([]:history_entry list)
-val history_dir = ref (SOME "")
-val skip_imports = ref false
+val history = Unsynchronized.ref ([]:history_entry list)
+val history_dir = Unsynchronized.ref (SOME "")
+val skip_imports = Unsynchronized.ref false
fun set_skip_import b = skip_imports := b
fun get_skip_import () = !skip_imports
--- a/src/HOL/Import/lazy_seq.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/lazy_seq.ML Thu Oct 01 07:40:25 2009 +0200
@@ -299,7 +299,7 @@
fun cycle seqfn =
let
- val knot = ref (Seq (Lazy.value NONE))
+ val knot = Unsynchronized.ref (Seq (Lazy.value NONE))
in
knot := seqfn (fn () => !knot);
!knot
@@ -350,7 +350,7 @@
fun of_instream is =
let
- val buffer : char list ref = ref []
+ val buffer : char list Unsynchronized.ref = Unsynchronized.ref []
fun get_input () =
case !buffer of
(c::cs) => (buffer:=cs;
--- a/src/HOL/Import/proof_kernel.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/proof_kernel.ML Thu Oct 01 07:40:25 2009 +0200
@@ -53,7 +53,7 @@
val get_proof_dir: string -> theory -> string option
val disambiguate_frees : Thm.thm -> Thm.thm
- val debug : bool ref
+ val debug : bool Unsynchronized.ref
val disk_info_of : proof -> (string * string) option
val set_disk_info_of : proof -> string -> string -> unit
val mk_proof : proof_content -> proof
@@ -132,7 +132,7 @@
fun add_dump s thy = (ImportRecorder.add_dump s; replay_add_dump s thy)
datatype proof_info
- = Info of {disk_info: (string * string) option ref}
+ = Info of {disk_info: (string * string) option Unsynchronized.ref}
datatype proof = Proof of proof_info * proof_content
and proof_content
@@ -199,12 +199,12 @@
val ct = (cterm_of thy (HOLogic.dest_Trueprop t)
handle TERM _ => ct)
in
- quote(
+ quote (
PrintMode.setmp [] (
Library.setmp show_brackets false (
Library.setmp show_all_types true (
Library.setmp Syntax.ambiguity_is_error false (
- Library.setmp show_sorts true Display.string_of_cterm))))
+ Library.setmp show_sorts true (Syntax.string_of_term_global thy o Thm.term_of)))))
ct)
end
@@ -226,7 +226,8 @@
| G _ = raise SMART_STRING
fun F n =
let
- val str = Library.setmp show_brackets false (G n Display.string_of_cterm) ct
+ val str =
+ Library.setmp show_brackets false (G n (Syntax.string_of_term ctxt o term_of)) ct
val u = Syntax.parse_term ctxt str
|> TypeInfer.constrain T |> Syntax.check_term ctxt
in
@@ -234,8 +235,9 @@
then quote str
else F (n+1)
end
- handle ERROR mesg => F (n+1)
- | SMART_STRING => error ("smart_string failed for: "^(G 0 Display.string_of_cterm ct))
+ handle ERROR mesg => F (n + 1)
+ | SMART_STRING =>
+ error ("smart_string failed for: "^ G 0 (Syntax.string_of_term ctxt o term_of) ct)
in
PrintMode.setmp [] (Library.setmp Syntax.ambiguity_is_error true F) 0
end
@@ -243,8 +245,7 @@
val smart_string_of_thm = smart_string_of_cterm o cprop_of
-fun prth th = writeln (PrintMode.setmp [] Display.string_of_thm_without_context th)
-fun prc ct = writeln (PrintMode.setmp [] Display.string_of_cterm ct)
+fun prth th = writeln (PrintMode.setmp [] Display.string_of_thm_without_context th);
fun prin t = writeln (PrintMode.setmp []
(fn () => Syntax.string_of_term (ML_Context.the_local_context ()) t) ());
fun pth (HOLThm(ren,thm)) =
@@ -257,7 +258,7 @@
end
fun disk_info_of (Proof(Info{disk_info,...},_)) = !disk_info
-fun mk_proof p = Proof(Info{disk_info = ref NONE},p)
+fun mk_proof p = Proof(Info{disk_info = Unsynchronized.ref NONE},p)
fun content_of (Proof(_,p)) = p
fun set_disk_info_of (Proof(Info{disk_info,...},_)) thyname thmname =
@@ -462,8 +463,8 @@
s |> no_quest |> beg_prime
end
-val protected_varnames = ref (Symtab.empty:string Symtab.table)
-val invented_isavar = ref 0
+val protected_varnames = Unsynchronized.ref (Symtab.empty:string Symtab.table)
+val invented_isavar = Unsynchronized.ref 0
fun innocent_varname s = Syntax.is_identifier s andalso not (String.isPrefix "u_" s)
@@ -481,7 +482,7 @@
SOME t => t
| NONE =>
let
- val _ = inc invented_isavar
+ val _ = Unsynchronized.inc invented_isavar
val t = "u_" ^ string_of_int (!invented_isavar)
val _ = ImportRecorder.protect_varname s t
val _ = protected_varnames := Symtab.update (s, t) (!protected_varnames)
@@ -496,7 +497,7 @@
SOME t' => raise REPLAY_PROTECT_VARNAME (s, t, t')
| NONE =>
let
- val _ = inc invented_isavar
+ val _ = Unsynchronized.inc invented_isavar
val t = "u_" ^ string_of_int (!invented_isavar)
val _ = protected_varnames := Symtab.update (s, t) (!protected_varnames)
in
@@ -1187,7 +1188,7 @@
end
end
-val debug = ref false
+val debug = Unsynchronized.ref false
fun if_debug f x = if !debug then f x else ()
val message = if_debug writeln
@@ -1939,16 +1940,17 @@
then
let
val p1 = quotename constname
- val p2 = Display.string_of_ctyp (ctyp_of thy'' ctype)
+ val p2 = Syntax.string_of_typ_global thy'' ctype
val p3 = string_of_mixfix csyn
val p4 = smart_string_of_cterm crhs
in
- add_dump ("constdefs\n " ^p1^ " :: \"" ^p2^ "\" "^p3^ "\n " ^p4) thy''
+ add_dump ("constdefs\n " ^ p1 ^ " :: \"" ^ p2 ^ "\" "^ p3 ^ "\n " ^ p4) thy''
end
else
- (add_dump ("consts\n " ^ (quotename constname) ^ " :: \"" ^ Display.string_of_ctyp (ctyp_of thy'' ctype) ^
- "\" " ^ (string_of_mixfix csyn) ^ "\n\ndefs\n " ^ (quotename thmname) ^ ": " ^ (smart_string_of_cterm crhs))
- thy'')
+ add_dump ("consts\n " ^ quotename constname ^ " :: \"" ^
+ Syntax.string_of_typ_global thy'' ctype ^
+ "\" " ^ string_of_mixfix csyn ^ "\n\ndefs\n " ^
+ quotename thmname ^ ": " ^ smart_string_of_cterm crhs) thy''
val hth = case Shuffler.set_prop thy22 (HOLogic.mk_Trueprop tm24) [("",th)] of
SOME (_,res) => HOLThm(rens_of linfo,res)
| NONE => raise ERR "new_definition" "Bad conclusion"
@@ -2008,8 +2010,9 @@
in
((cname,cT,mk_syn thy cname)::cs,p)
end) (([],HOLogic.dest_Trueprop (concl_of th)),names)
- val str = Library.foldl (fn (acc,(c,T,csyn)) =>
- acc ^ "\n " ^ (quotename c) ^ " :: \"" ^ Display.string_of_ctyp (ctyp_of thy T) ^ "\" " ^ (string_of_mixfix csyn)) ("consts",consts)
+ val str = Library.foldl (fn (acc, (c, T, csyn)) =>
+ acc ^ "\n " ^ quotename c ^ " :: \"" ^
+ Syntax.string_of_typ_global thy T ^ "\" " ^ string_of_mixfix csyn) ("consts", consts)
val thy' = add_dump str thy
val _ = ImportRecorder.add_consts consts
in
@@ -2137,7 +2140,7 @@
fun add_dump_constdefs thy defname constname rhs ty =
let
val n = quotename constname
- val t = Display.string_of_ctyp (ctyp_of thy ty)
+ val t = Syntax.string_of_typ_global thy ty
val syn = string_of_mixfix (mk_syn thy constname)
(*val eq = smart_string_of_cterm (cterm_of thy (Const(rhs, ty)))*)
val eq = quote (constname ^ " == "^rhs)
@@ -2224,7 +2227,7 @@
(" apply (rule light_ex_imp_nonempty[where t="^
(proc_prop (cterm_of thy4 t))^"])\n"^
(" by (import " ^ thyname ^ " " ^ (quotename thmname) ^ ")"))) thy4
- val str_aty = Display.string_of_ctyp (ctyp_of thy aty)
+ val str_aty = Syntax.string_of_typ_global thy aty
val thy = add_dump_syntax thy rep_name
val thy = add_dump_syntax thy abs_name
val thy = add_dump ("lemmas " ^ (quote (thmname^"_@intern")) ^
--- a/src/HOL/Import/shuffler.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Import/shuffler.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,7 +7,7 @@
signature Shuffler =
sig
- val debug : bool ref
+ val debug : bool Unsynchronized.ref
val norm_term : theory -> term -> thm
val make_equal : theory -> term -> term -> thm option
@@ -30,7 +30,7 @@
structure Shuffler :> Shuffler =
struct
-val debug = ref false
+val debug = Unsynchronized.ref false
fun if_debug f x = if !debug then f x else ()
val message = if_debug writeln
@@ -57,7 +57,6 @@
fun print_sign_exn sign e = (print_sign_exn_unit sign e; raise e)
val string_of_thm = PrintMode.setmp [] Display.string_of_thm_without_context;
-val string_of_cterm = PrintMode.setmp [] Display.string_of_cterm;
fun mk_meta_eq th =
(case concl_of th of
@@ -304,13 +303,14 @@
val lhs = #1 (Logic.dest_equals (prop_of (final init)))
in
if not (lhs aconv origt)
- then (writeln "Something is utterly wrong: (orig,lhs,frozen type,t,tinst)";
- writeln (Display.string_of_cterm (cterm_of thy origt));
- writeln (Display.string_of_cterm (cterm_of thy lhs));
- writeln (Display.string_of_cterm (cterm_of thy typet));
- writeln (Display.string_of_cterm (cterm_of thy t));
- app (fn (n,T) => writeln (n ^ ": " ^ (Display.string_of_ctyp (ctyp_of thy T)))) Tinst;
- writeln "done")
+ then
+ writeln (cat_lines
+ (["Something is utterly wrong: (orig, lhs, frozen type, t, tinst)",
+ Syntax.string_of_term_global thy origt,
+ Syntax.string_of_term_global thy lhs,
+ Syntax.string_of_term_global thy typet,
+ Syntax.string_of_term_global thy t] @
+ map (fn (n, T) => n ^ ": " ^ Syntax.string_of_typ_global thy T) Tinst))
else ()
end
in
@@ -366,13 +366,14 @@
val lhs = #1 (Logic.dest_equals (prop_of (final init)))
in
if not (lhs aconv origt)
- then (writeln "Something is utterly wrong: (orig,lhs,frozen type,t,tinst)";
- writeln (Display.string_of_cterm (cterm_of thy origt));
- writeln (Display.string_of_cterm (cterm_of thy lhs));
- writeln (Display.string_of_cterm (cterm_of thy typet));
- writeln (Display.string_of_cterm (cterm_of thy t));
- app (fn (n,T) => writeln (n ^ ": " ^ (Display.string_of_ctyp (ctyp_of thy T)))) Tinst;
- writeln "done")
+ then
+ writeln (cat_lines
+ (["Something is utterly wrong: (orig, lhs, frozen type, t, tinst)",
+ Syntax.string_of_term_global thy origt,
+ Syntax.string_of_term_global thy lhs,
+ Syntax.string_of_term_global thy typet,
+ Syntax.string_of_term_global thy t] @
+ map (fn (n, T) => n ^ ": " ^ Syntax.string_of_typ_global thy T) Tinst))
else ()
end
in
@@ -407,9 +408,8 @@
end
| _ => NONE)
else NONE
- | _ => (error ("Bad eta_expand argument" ^ (string_of_cterm (cterm_of thy t))); NONE)
- end
- handle e => (writeln "eta_expand internal error"; OldGoals.print_exn e)
+ | _ => error ("Bad eta_expand argument" ^ Syntax.string_of_term_global thy t)
+ end;
fun mk_tfree s = TFree("'"^s,[])
fun mk_free s t = Free (s,t)
--- a/src/HOL/Induct/LList.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Induct/LList.thy Thu Oct 01 07:40:25 2009 +0200
@@ -665,7 +665,7 @@
apply (subst LList_corec, force)
done
-lemma llist_corec:
+lemma llist_corec [nitpick_const_simp]:
"llist_corec a f =
(case f a of None => LNil | Some(z,w) => LCons z (llist_corec w f))"
apply (unfold llist_corec_def LNil_def LCons_def)
@@ -774,10 +774,11 @@
subsection{* The functional @{text lmap} *}
-lemma lmap_LNil [simp]: "lmap f LNil = LNil"
+lemma lmap_LNil [simp, nitpick_const_simp]: "lmap f LNil = LNil"
by (rule lmap_def [THEN def_llist_corec, THEN trans], simp)
-lemma lmap_LCons [simp]: "lmap f (LCons M N) = LCons (f M) (lmap f N)"
+lemma lmap_LCons [simp, nitpick_const_simp]:
+"lmap f (LCons M N) = LCons (f M) (lmap f N)"
by (rule lmap_def [THEN def_llist_corec, THEN trans], simp)
@@ -792,7 +793,7 @@
subsection{* iterates -- @{text llist_fun_equalityI} cannot be used! *}
-lemma iterates: "iterates f x = LCons x (iterates f (f x))"
+lemma iterates [nitpick_const_simp]: "iterates f x = LCons x (iterates f (f x))"
by (rule iterates_def [THEN def_llist_corec, THEN trans], simp)
lemma lmap_iterates [simp]: "lmap f (iterates f x) = iterates f (f x)"
@@ -847,18 +848,18 @@
subsection{* @{text lappend} -- its two arguments cause some complications! *}
-lemma lappend_LNil_LNil [simp]: "lappend LNil LNil = LNil"
+lemma lappend_LNil_LNil [simp, nitpick_const_simp]: "lappend LNil LNil = LNil"
apply (simp add: lappend_def)
apply (rule llist_corec [THEN trans], simp)
done
-lemma lappend_LNil_LCons [simp]:
+lemma lappend_LNil_LCons [simp, nitpick_const_simp]:
"lappend LNil (LCons l l') = LCons l (lappend LNil l')"
apply (simp add: lappend_def)
apply (rule llist_corec [THEN trans], simp)
done
-lemma lappend_LCons [simp]:
+lemma lappend_LCons [simp, nitpick_const_simp]:
"lappend (LCons l l') N = LCons l (lappend l' N)"
apply (simp add: lappend_def)
apply (rule llist_corec [THEN trans], simp)
--- a/src/HOL/Inductive.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Inductive.thy Thu Oct 01 07:40:25 2009 +0200
@@ -83,7 +83,7 @@
and indhyp: "!!x. [| x: f(lfp(f) Int {x. P(x)}) |] ==> P(x)"
shows "P(a)"
by (rule lfp_induct [THEN subsetD, THEN CollectD, OF mono _ lfp])
- (auto simp: inf_set_eq intro: indhyp)
+ (auto simp: intro: indhyp)
lemma lfp_ordinal_induct:
fixes f :: "'a\<Colon>complete_lattice \<Rightarrow> 'a"
@@ -111,8 +111,7 @@
and P_f: "!!S. P S ==> P(f S)"
and P_Union: "!!M. !S:M. P S ==> P(Union M)"
shows "P(lfp f)"
- using assms unfolding Sup_set_eq [symmetric]
- by (rule lfp_ordinal_induct [where P=P])
+ using assms by (rule lfp_ordinal_induct [where P=P])
text{*Definition forms of @{text lfp_unfold} and @{text lfp_induct},
@@ -185,7 +184,7 @@
text{*strong version, thanks to Coen and Frost*}
lemma coinduct_set: "[| mono(f); a: X; X \<subseteq> f(X Un gfp(f)) |] ==> a : gfp(f)"
-by (blast intro: weak_coinduct [OF _ coinduct_lemma, simplified sup_set_eq])
+by (blast intro: weak_coinduct [OF _ coinduct_lemma])
lemma coinduct: "[| mono(f); X \<le> f (sup X (gfp f)) |] ==> X \<le> gfp(f)"
apply (rule order_trans)
@@ -268,26 +267,6 @@
Ball_def Bex_def
induct_rulify_fallback
-ML {*
-val def_lfp_unfold = @{thm def_lfp_unfold}
-val def_gfp_unfold = @{thm def_gfp_unfold}
-val def_lfp_induct = @{thm def_lfp_induct}
-val def_coinduct = @{thm def_coinduct}
-val inf_bool_eq = @{thm inf_bool_eq} RS @{thm eq_reflection}
-val inf_fun_eq = @{thm inf_fun_eq} RS @{thm eq_reflection}
-val sup_bool_eq = @{thm sup_bool_eq} RS @{thm eq_reflection}
-val sup_fun_eq = @{thm sup_fun_eq} RS @{thm eq_reflection}
-val le_boolI = @{thm le_boolI}
-val le_boolI' = @{thm le_boolI'}
-val le_funI = @{thm le_funI}
-val le_boolE = @{thm le_boolE}
-val le_funE = @{thm le_funE}
-val le_boolD = @{thm le_boolD}
-val le_funD = @{thm le_funD}
-val le_bool_def = @{thm le_bool_def} RS @{thm eq_reflection}
-val le_fun_def = @{thm le_fun_def} RS @{thm eq_reflection}
-*}
-
use "Tools/inductive.ML"
setup Inductive.setup
--- a/src/HOL/Int.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Int.thy Thu Oct 01 07:40:25 2009 +0200
@@ -266,7 +266,7 @@
proof
fix k :: int
show "abs k = sup k (- k)"
- by (auto simp add: sup_int_def zabs_def max_def less_minus_self_iff [symmetric])
+ 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"
@@ -1487,21 +1487,6 @@
add_special diff_special eq_special less_special le_special
-lemma min_max_01: "min (0::int) 1 = 0 & min (1::int) 0 = 0 &
- max (0::int) 1 = 1 & max (1::int) 0 = 1"
-by(simp add:min_def max_def)
-
-lemmas min_max_special[simp] =
- min_max_01
- max_def[of "0::int" "number_of v", standard, simp]
- min_def[of "0::int" "number_of v", standard, simp]
- max_def[of "number_of u" "0::int", standard, simp]
- min_def[of "number_of u" "0::int", standard, simp]
- max_def[of "1::int" "number_of v", standard, simp]
- min_def[of "1::int" "number_of v", standard, simp]
- max_def[of "number_of u" "1::int", standard, simp]
- min_def[of "number_of u" "1::int", standard, simp]
-
text {* Legacy theorems *}
lemmas zle_int = of_nat_le_iff [where 'a=int]
--- a/src/HOL/IntDiv.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/IntDiv.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1102,20 +1102,6 @@
thus ?thesis by simp
qed
-
-theorem ex_nat: "(\<exists>x::nat. P x) = (\<exists>x::int. 0 <= x \<and> P (nat x))"
-apply (simp split add: split_nat)
-apply (rule iffI)
-apply (erule exE)
-apply (rule_tac x = "int x" in exI)
-apply simp
-apply (erule exE)
-apply (rule_tac x = "nat x" in exI)
-apply (erule conjE)
-apply (erule_tac x = "nat x" in allE)
-apply simp
-done
-
theorem zdvd_int: "(x dvd y) = (int x dvd int y)"
proof -
have "\<And>k. int y = int x * k \<Longrightarrow> x dvd y"
--- a/src/HOL/IsaMakefile Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/IsaMakefile Thu Oct 01 07:40:25 2009 +0200
@@ -18,7 +18,7 @@
HOL-Extraction \
HOL-Hahn_Banach \
HOL-Hoare \
- HOL-HoareParallel \
+ HOL-Hoare_Parallel \
HOL-Import \
HOL-IMP \
HOL-IMPP \
@@ -31,14 +31,16 @@
HOL-Matrix \
HOL-MetisExamples \
HOL-MicroJava \
+ HOL-Mirabelle \
HOL-Modelcheck \
HOL-NanoJava \
HOL-Nominal-Examples \
- HOL-NewNumberTheory \
- HOL-NumberTheory \
+ HOL-Number_Theory \
+ HOL-Old_Number_Theory \
HOL-Prolog \
HOL-SET-Protocol \
HOL-SizeChange \
+ HOL-SMT \
HOL-Statespace \
HOL-Subst \
TLA-Buffer \
@@ -85,29 +87,31 @@
$(SRC)/Provers/hypsubst.ML \
$(SRC)/Provers/quantifier1.ML \
$(SRC)/Provers/splitter.ML \
- $(SRC)/Tools/IsaPlanner/isand.ML \
- $(SRC)/Tools/IsaPlanner/rw_inst.ML \
- $(SRC)/Tools/IsaPlanner/rw_tools.ML \
- $(SRC)/Tools/IsaPlanner/zipper.ML \
- $(SRC)/Tools/atomize_elim.ML \
- $(SRC)/Tools/auto_solve.ML \
$(SRC)/Tools/Code/code_haskell.ML \
$(SRC)/Tools/Code/code_ml.ML \
$(SRC)/Tools/Code/code_preproc.ML \
$(SRC)/Tools/Code/code_printer.ML \
$(SRC)/Tools/Code/code_target.ML \
$(SRC)/Tools/Code/code_thingol.ML \
+ $(SRC)/Tools/Code_Generator.thy \
+ $(SRC)/Tools/IsaPlanner/isand.ML \
+ $(SRC)/Tools/IsaPlanner/rw_inst.ML \
+ $(SRC)/Tools/IsaPlanner/rw_tools.ML \
+ $(SRC)/Tools/IsaPlanner/zipper.ML \
+ $(SRC)/Tools/atomize_elim.ML \
+ $(SRC)/Tools/auto_solve.ML \
$(SRC)/Tools/coherent.ML \
+ $(SRC)/Tools/cong_tac.ML \
$(SRC)/Tools/eqsubst.ML \
$(SRC)/Tools/induct.ML \
+ $(SRC)/Tools/induct_tacs.ML \
$(SRC)/Tools/intuitionistic.ML \
- $(SRC)/Tools/induct_tacs.ML \
+ $(SRC)/Tools/more_conv.ML \
$(SRC)/Tools/nbe.ML \
+ $(SRC)/Tools/project_rule.ML \
$(SRC)/Tools/quickcheck.ML \
- $(SRC)/Tools/project_rule.ML \
$(SRC)/Tools/random_word.ML \
$(SRC)/Tools/value.ML \
- $(SRC)/Tools/Code_Generator.thy \
HOL.thy \
Tools/hologic.ML \
Tools/recfun_codegen.ML \
@@ -127,9 +131,9 @@
Inductive.thy \
Lattices.thy \
Nat.thy \
+ Option.thy \
OrderedGroup.thy \
Orderings.thy \
- Option.thy \
Plain.thy \
Power.thy \
Predicate.thy \
@@ -207,13 +211,13 @@
MAIN_DEPENDENCIES = $(PLAIN_DEPENDENCIES) \
ATP_Linkup.thy \
- Code_Eval.thy \
+ Code_Evaluation.thy \
Code_Numeral.thy \
Equiv_Relations.thy \
Groebner_Basis.thy \
Hilbert_Choice.thy \
+ Int.thy \
IntDiv.thy \
- Int.thy \
List.thy \
Main.thy \
Map.thy \
@@ -277,34 +281,34 @@
$(OUT)/HOL: ROOT.ML $(MAIN_DEPENDENCIES) \
Archimedean_Field.thy \
+ Complex.thy \
Complex_Main.thy \
- Complex.thy \
Deriv.thy \
Fact.thy \
+ GCD.thy \
Integration.thy \
Lim.thy \
Limits.thy \
Ln.thy \
Log.thy \
+ Lubs.thy \
MacLaurin.thy \
- NatTransfer.thy \
+ Nat_Transfer.thy \
NthRoot.thy \
+ PReal.thy \
+ Parity.thy \
+ RComplete.thy \
+ Rational.thy \
+ Real.thy \
+ RealDef.thy \
+ RealPow.thy \
+ RealVector.thy \
SEQ.thy \
Series.thy \
Taylor.thy \
Transcendental.thy \
- GCD.thy \
- Parity.thy \
- Lubs.thy \
- PReal.thy \
- Rational.thy \
- RComplete.thy \
- RealDef.thy \
- RealPow.thy \
- Real.thy \
- RealVector.thy \
Tools/float_syntax.ML \
- Tools/transfer_data.ML \
+ Tools/transfer.ML \
Tools/Qelim/ferrante_rackoff_data.ML \
Tools/Qelim/ferrante_rackoff.ML \
Tools/Qelim/langford_data.ML \
@@ -329,10 +333,10 @@
Library/Finite_Cartesian_Product.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/Legacy_GCD.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/Primes.thy Library/Pocklington.thy \
+ Library/Permutation.thy \
Library/Quotient.thy Library/Quicksort.thy Library/Nat_Infinity.thy \
Library/Word.thy Library/README.html Library/Continuity.thy \
Library/Order_Relation.thy Library/Nested_Environment.thy \
@@ -486,38 +490,39 @@
@cd Import/HOLLight; $(ISABELLE_TOOL) usedir -b $(OUT)/HOL HOLLight
-## HOL-NewNumberTheory
+## HOL-Number_Theory
-HOL-NewNumberTheory: HOL $(LOG)/HOL-NewNumberTheory.gz
+HOL-Number_Theory: HOL $(LOG)/HOL-Number_Theory.gz
-$(LOG)/HOL-NewNumberTheory.gz: $(OUT)/HOL $(ALGEBRA_DEPENDENCIES) \
+$(LOG)/HOL-Number_Theory.gz: $(OUT)/HOL $(ALGEBRA_DEPENDENCIES) \
Library/Multiset.thy \
- NewNumberTheory/Binomial.thy \
- NewNumberTheory/Cong.thy \
- NewNumberTheory/Fib.thy \
- NewNumberTheory/MiscAlgebra.thy \
- NewNumberTheory/Residues.thy \
- NewNumberTheory/UniqueFactorization.thy \
- NewNumberTheory/ROOT.ML
- @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL NewNumberTheory
+ Number_Theory/Binomial.thy \
+ Number_Theory/Cong.thy \
+ Number_Theory/Fib.thy \
+ Number_Theory/MiscAlgebra.thy \
+ Number_Theory/Number_Theory.thy \
+ Number_Theory/Residues.thy \
+ Number_Theory/UniqueFactorization.thy \
+ Number_Theory/ROOT.ML
+ @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Number_Theory
-## HOL-NumberTheory
+## HOL-Old_Number_Theory
-HOL-NumberTheory: HOL $(LOG)/HOL-NumberTheory.gz
+HOL-Old_Number_Theory: HOL $(LOG)/HOL-Old_Number_Theory.gz
-$(LOG)/HOL-NumberTheory.gz: $(OUT)/HOL Library/Permutation.thy \
- Library/Primes.thy NumberTheory/Fib.thy \
- NumberTheory/Factorization.thy NumberTheory/BijectionRel.thy \
- NumberTheory/Chinese.thy NumberTheory/EulerFermat.thy \
- NumberTheory/IntFact.thy NumberTheory/IntPrimes.thy \
- NumberTheory/WilsonBij.thy NumberTheory/WilsonRuss.thy \
- NumberTheory/Finite2.thy NumberTheory/Int2.thy \
- NumberTheory/EvenOdd.thy NumberTheory/Residues.thy \
- NumberTheory/Euler.thy NumberTheory/Gauss.thy \
- NumberTheory/Quadratic_Reciprocity.thy Library/Infinite_Set.thy \
- NumberTheory/ROOT.ML
- @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL NumberTheory
+$(LOG)/HOL-Old_Number_Theory.gz: $(OUT)/HOL Library/Permutation.thy \
+ Old_Number_Theory/Primes.thy Old_Number_Theory/Fib.thy \
+ Old_Number_Theory/Factorization.thy Old_Number_Theory/BijectionRel.thy \
+ Old_Number_Theory/Chinese.thy Old_Number_Theory/EulerFermat.thy \
+ Old_Number_Theory/IntFact.thy Old_Number_Theory/IntPrimes.thy \
+ Old_Number_Theory/WilsonBij.thy Old_Number_Theory/WilsonRuss.thy \
+ Old_Number_Theory/Finite2.thy Old_Number_Theory/Int2.thy \
+ Old_Number_Theory/EvenOdd.thy Old_Number_Theory/Residues.thy \
+ Old_Number_Theory/Euler.thy Old_Number_Theory/Gauss.thy \
+ Old_Number_Theory/Quadratic_Reciprocity.thy Library/Infinite_Set.thy \
+ Old_Number_Theory/Legacy_GCD.thy Old_Number_Theory/Pocklington.thy Old_Number_Theory/ROOT.ML
+ @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Old_Number_Theory
## HOL-Hoare
@@ -533,21 +538,22 @@
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Hoare
-## HOL-HoareParallel
+## HOL-Hoare_Parallel
-HOL-HoareParallel: HOL $(LOG)/HOL-HoareParallel.gz
+HOL-Hoare_Parallel: HOL $(LOG)/HOL-Hoare_Parallel.gz
-$(LOG)/HOL-HoareParallel.gz: $(OUT)/HOL HoareParallel/Gar_Coll.thy \
- HoareParallel/Graph.thy HoareParallel/Mul_Gar_Coll.thy \
- HoareParallel/OG_Com.thy HoareParallel/OG_Examples.thy \
- HoareParallel/OG_Hoare.thy HoareParallel/OG_Syntax.thy \
- HoareParallel/OG_Tactics.thy HoareParallel/OG_Tran.thy \
- HoareParallel/Quote_Antiquote.thy HoareParallel/RG_Com.thy \
- HoareParallel/RG_Examples.thy HoareParallel/RG_Hoare.thy \
- HoareParallel/RG_Syntax.thy HoareParallel/RG_Tran.thy \
- HoareParallel/ROOT.ML HoareParallel/document/root.tex \
- HoareParallel/document/root.bib
- @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL HoareParallel
+$(LOG)/HOL-Hoare_Parallel.gz: $(OUT)/HOL Hoare_Parallel/Gar_Coll.thy \
+ Hoare_Parallel/Graph.thy Hoare_Parallel/Hoare_Parallel.thy \
+ Hoare_Parallel/Mul_Gar_Coll.thy \
+ Hoare_Parallel/OG_Com.thy Hoare_Parallel/OG_Examples.thy \
+ Hoare_Parallel/OG_Hoare.thy Hoare_Parallel/OG_Syntax.thy \
+ Hoare_Parallel/OG_Tactics.thy Hoare_Parallel/OG_Tran.thy \
+ Hoare_Parallel/Quote_Antiquote.thy Hoare_Parallel/RG_Com.thy \
+ Hoare_Parallel/RG_Examples.thy Hoare_Parallel/RG_Hoare.thy \
+ Hoare_Parallel/RG_Syntax.thy Hoare_Parallel/RG_Tran.thy \
+ Hoare_Parallel/ROOT.ML Hoare_Parallel/document/root.tex \
+ Hoare_Parallel/document/root.bib
+ @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Hoare_Parallel
## HOL-MetisExamples
@@ -572,7 +578,7 @@
Library/FuncSet.thy \
Library/Multiset.thy \
Library/Permutation.thy \
- Library/Primes.thy \
+ Number_Theory/Primes.thy \
Algebra/AbelCoset.thy \
Algebra/Bij.thy \
Algebra/Congruence.thy \
@@ -614,6 +620,10 @@
HOL-Auth: HOL $(LOG)/HOL-Auth.gz
$(LOG)/HOL-Auth.gz: $(OUT)/HOL \
+ Auth/Auth_Shared.thy Auth/Auth_Public.thy Auth/All_Symmetric.thy \
+ Auth/Guard/Auth_Guard_Shared.thy \
+ Auth/Guard/Auth_Guard_Public.thy \
+ Auth/Smartcard/Auth_Smartcard.thy Auth/All_Symmetric.thy \
Auth/CertifiedEmail.thy Auth/Event.thy Auth/Message.thy \
Auth/NS_Public.thy Auth/NS_Public_Bad.thy Auth/NS_Shared.thy \
Auth/OtwayRees.thy Auth/OtwayReesBella.thy Auth/OtwayRees_AN.thy \
@@ -638,7 +648,7 @@
HOL-UNITY: HOL $(LOG)/HOL-UNITY.gz
$(LOG)/HOL-UNITY.gz: $(OUT)/HOL Library/Multiset.thy UNITY/ROOT.ML \
- UNITY/UNITY_Main.thy UNITY/UNITY_tactics.ML UNITY/Comp.thy \
+ UNITY/UNITY_Main.thy UNITY/UNITY_Examples.thy UNITY/UNITY_tactics.ML UNITY/Comp.thy \
UNITY/Constrains.thy UNITY/Detects.thy UNITY/ELT.thy \
UNITY/Extend.thy UNITY/FP.thy UNITY/Follows.thy UNITY/Guar.thy \
UNITY/Lift_prog.thy UNITY/ListOrder.thy UNITY/ProgressSets.thy \
@@ -827,7 +837,7 @@
HOL-Bali: HOL $(LOG)/HOL-Bali.gz
-$(LOG)/HOL-Bali.gz: $(OUT)/HOL Bali/AxCompl.thy Bali/AxExample.thy \
+$(LOG)/HOL-Bali.gz: $(OUT)/HOL Bali/Bali.thy Bali/AxCompl.thy Bali/AxExample.thy \
Bali/AxSem.thy Bali/AxSound.thy Bali/Basis.thy Bali/Conform.thy \
Bali/Decl.thy Bali/DeclConcepts.thy Bali/Eval.thy Bali/Evaln.thy \
Bali/Example.thy Bali/Name.thy Bali/ROOT.ML Bali/State.thy \
@@ -875,7 +885,7 @@
HOL-ex: HOL $(LOG)/HOL-ex.gz
$(LOG)/HOL-ex.gz: $(OUT)/HOL Library/Commutative_Ring.thy \
- Library/Primes.thy ex/Abstract_NAT.thy ex/Antiquote.thy \
+ Number_Theory/Primes.thy ex/Abstract_NAT.thy ex/Antiquote.thy \
ex/Arith_Examples.thy \
ex/Arithmetic_Series_Complex.thy ex/BT.thy ex/BinEx.thy \
ex/Binary.thy ex/CTL.thy ex/Chinese.thy ex/Classical.thy \
@@ -898,10 +908,9 @@
ex/Refute_Examples.thy ex/SAT_Examples.thy ex/SVC_Oracle.thy \
ex/Serbian.thy ex/Sqrt.thy ex/Sqrt_Script.thy \
ex/Sudoku.thy ex/Tarski.thy \
- ex/Termination.thy ex/Unification.thy ex/document/root.bib \
+ ex/Termination.thy ex/Transfer_Ex.thy ex/Unification.thy ex/document/root.bib \
ex/document/root.tex ex/set.thy ex/svc_funcs.ML ex/svc_test.thy \
- ex/Predicate_Compile.thy ex/predicate_compile.ML ex/Predicate_Compile_ex.thy \
- ex/Mirabelle.thy ex/mirabelle.ML
+ ex/Predicate_Compile.thy Tools/Predicate_Compile/predicate_compile_core.ML ex/Predicate_Compile_ex.thy
@$(ISABELLE_TOOL) usedir $(OUT)/HOL ex
@@ -939,7 +948,7 @@
HOL-Matrix: HOL $(LOG)/HOL-Matrix.gz
-$(LOG)/HOL-Matrix.gz: $(OUT)/HOL \
+$(LOG)/HOL-Matrix.gz: $(OUT)/HOL \
$(SRC)/Tools/Compute_Oracle/Compute_Oracle.thy \
$(SRC)/Tools/Compute_Oracle/am_compiler.ML \
$(SRC)/Tools/Compute_Oracle/am_interpreter.ML \
@@ -947,8 +956,8 @@
$(SRC)/Tools/Compute_Oracle/linker.ML \
$(SRC)/Tools/Compute_Oracle/am_ghc.ML \
$(SRC)/Tools/Compute_Oracle/am_sml.ML \
- $(SRC)/Tools/Compute_Oracle/compute.ML \
- Tools/ComputeFloat.thy Tools/float_arith.ML \
+ $(SRC)/Tools/Compute_Oracle/compute.ML Matrix/ComputeFloat.thy \
+ Matrix/ComputeHOL.thy Matrix/ComputeNumeral.thy Tools/float_arith.ML \
Matrix/Matrix.thy Matrix/SparseMatrix.thy Matrix/LP.thy \
Matrix/document/root.tex Matrix/ROOT.ML Matrix/cplex/Cplex.thy \
Matrix/cplex/CplexMatrixConverter.ML Matrix/cplex/Cplex_tools.ML \
@@ -1018,6 +1027,7 @@
HOL-Nominal-Examples: HOL-Nominal $(LOG)/HOL-Nominal-Examples.gz
$(LOG)/HOL-Nominal-Examples.gz: $(OUT)/HOL-Nominal \
+ Nominal/Examples/Nominal_Examples.thy \
Nominal/Examples/CK_Machine.thy \
Nominal/Examples/CR.thy \
Nominal/Examples/CR_Takahashi.thy \
@@ -1118,6 +1128,33 @@
@cd NSA; $(ISABELLE_TOOL) usedir $(OUT)/HOL-NSA Examples
+## HOL-Mirabelle
+
+HOL-Mirabelle: HOL $(LOG)/HOL-Mirabelle.gz
+
+$(LOG)/HOL-Mirabelle.gz: $(OUT)/HOL Mirabelle/Mirabelle_Test.thy \
+ Mirabelle/Mirabelle.thy Mirabelle/Tools/mirabelle.ML Mirabelle/ROOT.ML \
+ Mirabelle/Tools/mirabelle_arith.ML \
+ Mirabelle/Tools/mirabelle_metis.ML \
+ Mirabelle/Tools/mirabelle_quickcheck.ML \
+ Mirabelle/Tools/mirabelle_refute.ML \
+ Mirabelle/Tools/mirabelle_sledgehammer.ML
+ @$(ISABELLE_TOOL) usedir $(OUT)/HOL Mirabelle
+
+
+## HOL-SMT
+
+HOL-SMT: HOL-Word $(LOG)/HOL-SMT.gz
+
+$(LOG)/HOL-SMT.gz: $(OUT)/HOL-Word SMT/SMT_Definitions.thy SMT/SMT.thy \
+ SMT/Tools/smt_normalize.ML SMT/Tools/smt_monomorph.ML \
+ SMT/Tools/smt_translate.ML SMT/Tools/smt_builtin.ML \
+ SMT/Tools/smtlib_interface.ML SMT/Tools/smt_solver.ML \
+ SMT/Tools/cvc3_solver.ML SMT/Tools/yices_solver.ML \
+ SMT/Tools/z3_interface.ML SMT/Tools/z3_solver.ML SMT/Tools/z3_model.ML
+ @cd SMT; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL-Word HOL-SMT
+
+
## clean
clean:
@@ -1127,7 +1164,7 @@
$(LOG)/HOL-Induct.gz $(LOG)/HOL-ex.gz \
$(LOG)/HOL-Subst.gz $(LOG)/HOL-IMP.gz \
$(LOG)/HOL-IMPP.gz $(LOG)/HOL-Hoare.gz \
- $(LOG)/HOL-HoareParallel.gz $(LOG)/HOL-Lex.gz \
+ $(LOG)/HOL-Hoare_Parallel.gz $(LOG)/HOL-Lex.gz \
$(LOG)/HOL-Algebra.gz $(LOG)/HOL-Auth.gz \
$(LOG)/HOL-UNITY.gz $(LOG)/HOL-Modelcheck.gz \
$(LOG)/HOL-Lambda.gz $(LOG)/HOL-Bali.gz \
@@ -1139,4 +1176,5 @@
$(LOG)/TLA-Memory.gz $(LOG)/HOL-Library.gz \
$(LOG)/HOL-Unix.gz $(OUT)/HOL-Word $(LOG)/HOL-Word.gz \
$(LOG)/HOL-Word-Examples.gz $(OUT)/HOL-NSA \
- $(LOG)/HOL-NSA.gz $(LOG)/HOL-NSA-Examples.gz
+ $(LOG)/HOL-NSA.gz $(LOG)/HOL-NSA-Examples.gz \
+ $(LOG)/HOL-Mirabelle.gz $(LOG)/HOL-SMT.gz
--- a/src/HOL/Isar_examples/Mutilated_Checkerboard.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Isar_examples/Mutilated_Checkerboard.thy Thu Oct 01 07:40:25 2009 +0200
@@ -113,7 +113,7 @@
lemma evnodd_insert: "evnodd (insert (i, j) C) b =
(if (i + j) mod 2 = b
then insert (i, j) (evnodd C b) else evnodd C b)"
- by (simp add: evnodd_def) blast
+ by (simp add: evnodd_def)
subsection {* Dominoes *}
--- a/src/HOL/Isar_examples/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Isar_examples/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
Miscellaneous Isabelle/Isar examples for Higher-Order Logic.
*)
-no_document use_thys ["../NumberTheory/Primes", "../NumberTheory/Fibonacci"];
+no_document use_thys ["../Old_Number_Theory/Primes", "../Old_Number_Theory/Fibonacci"];
use_thys [
"Basic_Logic",
--- a/src/HOL/Lambda/Eta.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Lambda/Eta.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Lambda/Eta.thy
- ID: $Id$
Author: Tobias Nipkow and Stefan Berghofer
Copyright 1995, 2005 TU Muenchen
*)
@@ -87,7 +86,6 @@
lemma square_eta: "square eta eta (eta^==) (eta^==)"
apply (unfold square_def id_def)
apply (rule impI [THEN allI [THEN allI]])
- apply simp
apply (erule eta.induct)
apply (slowsimp intro: subst_not_free eta_subst free_eta [THEN iffD1])
apply safe
--- a/src/HOL/Lattices.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Lattices.thy Thu Oct 01 07:40:25 2009 +0200
@@ -12,7 +12,9 @@
notation
less_eq (infix "\<sqsubseteq>" 50) and
- less (infix "\<sqsubset>" 50)
+ less (infix "\<sqsubset>" 50) and
+ top ("\<top>") and
+ bot ("\<bottom>")
class lower_semilattice = order +
fixes inf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)
@@ -199,7 +201,7 @@
shows "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
proof-
have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by(simp add:sup_inf_absorb)
- also have "\<dots> = x \<squnion> (z \<sqinter> (x \<squnion> y))" by(simp add:D inf_commute sup_assoc)
+ also have "\<dots> = x \<squnion> (z \<sqinter> (x \<squnion> y))" by(simp add:D inf_commute sup_assoc del:sup_absorb1)
also have "\<dots> = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)"
by(simp add:inf_sup_absorb inf_commute)
also have "\<dots> = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by(simp add:D)
@@ -211,7 +213,7 @@
shows "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
proof-
have "x \<sqinter> (y \<squnion> z) = (x \<sqinter> (x \<squnion> z)) \<sqinter> (y \<squnion> z)" by(simp add:inf_sup_absorb)
- also have "\<dots> = x \<sqinter> (z \<squnion> (x \<sqinter> y))" by(simp add:D sup_commute inf_assoc)
+ also have "\<dots> = x \<sqinter> (z \<squnion> (x \<sqinter> y))" by(simp add:D sup_commute inf_assoc del:inf_absorb1)
also have "\<dots> = ((x \<sqinter> y) \<squnion> x) \<sqinter> ((x \<sqinter> y) \<squnion> z)"
by(simp add:sup_inf_absorb sup_commute)
also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by(simp add:D)
@@ -220,6 +222,46 @@
end
+subsubsection {* Strict order *}
+
+context lower_semilattice
+begin
+
+lemma less_infI1:
+ "a \<sqsubset> x \<Longrightarrow> a \<sqinter> b \<sqsubset> x"
+ by (auto simp add: less_le inf_absorb1 intro: le_infI1)
+
+lemma less_infI2:
+ "b \<sqsubset> x \<Longrightarrow> a \<sqinter> b \<sqsubset> x"
+ by (auto simp add: less_le inf_absorb2 intro: le_infI2)
+
+end
+
+context upper_semilattice
+begin
+
+lemma less_supI1:
+ "x < a \<Longrightarrow> x < a \<squnion> b"
+proof -
+ interpret dual: lower_semilattice "op \<ge>" "op >" sup
+ by (fact dual_semilattice)
+ assume "x < a"
+ then show "x < a \<squnion> b"
+ by (fact dual.less_infI1)
+qed
+
+lemma less_supI2:
+ "x < b \<Longrightarrow> x < a \<squnion> b"
+proof -
+ interpret dual: lower_semilattice "op \<ge>" "op >" sup
+ by (fact dual_semilattice)
+ assume "x < b"
+ then show "x < a \<squnion> b"
+ by (fact dual.less_infI2)
+qed
+
+end
+
subsection {* Distributive lattices *}
@@ -306,6 +348,40 @@
"x \<squnion> bot = x"
by (rule sup_absorb1) simp
+lemma inf_eq_top_eq1:
+ assumes "A \<sqinter> B = \<top>"
+ shows "A = \<top>"
+proof (cases "B = \<top>")
+ case True with assms show ?thesis by simp
+next
+ case False with top_greatest have "B < \<top>" by (auto intro: neq_le_trans)
+ then have "A \<sqinter> B < \<top>" by (rule less_infI2)
+ with assms show ?thesis by simp
+qed
+
+lemma inf_eq_top_eq2:
+ assumes "A \<sqinter> B = \<top>"
+ shows "B = \<top>"
+ by (rule inf_eq_top_eq1, unfold inf_commute [of B]) (fact assms)
+
+lemma sup_eq_bot_eq1:
+ assumes "A \<squnion> B = \<bottom>"
+ shows "A = \<bottom>"
+proof -
+ interpret dual: boolean_algebra "\<lambda>x y. x \<squnion> - y" uminus "op \<ge>" "op >" "op \<squnion>" "op \<sqinter>" top bot
+ by (rule dual_boolean_algebra)
+ from dual.inf_eq_top_eq1 assms show ?thesis .
+qed
+
+lemma sup_eq_bot_eq2:
+ assumes "A \<squnion> B = \<bottom>"
+ shows "B = \<bottom>"
+proof -
+ interpret dual: boolean_algebra "\<lambda>x y. x \<squnion> - y" uminus "op \<ge>" "op >" "op \<squnion>" "op \<sqinter>" top bot
+ by (rule dual_boolean_algebra)
+ from dual.inf_eq_top_eq2 assms show ?thesis .
+qed
+
lemma compl_unique:
assumes "x \<sqinter> y = bot"
and "x \<squnion> y = top"
@@ -413,12 +489,11 @@
subsection {* @{const min}/@{const max} on linear orders as
special case of @{const inf}/@{const sup} *}
-sublocale linorder < min_max!: distrib_lattice less_eq less "Orderings.ord.min less_eq" "Orderings.ord.max less_eq"
+sublocale linorder < min_max!: distrib_lattice less_eq less min max
proof
fix x y z
- show "Orderings.ord.max less_eq x (Orderings.ord.min less_eq y z) =
- Orderings.ord.min less_eq (Orderings.ord.max less_eq x y) (Orderings.ord.max less_eq x z)"
- unfolding min_def max_def by auto
+ show "max x (min y z) = min (max x y) (max x z)"
+ 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)"
@@ -460,6 +535,18 @@
end
+lemma sup_boolI1:
+ "P \<Longrightarrow> P \<squnion> Q"
+ by (simp add: sup_bool_eq)
+
+lemma sup_boolI2:
+ "Q \<Longrightarrow> P \<squnion> Q"
+ by (simp add: sup_bool_eq)
+
+lemma sup_boolE:
+ "P \<squnion> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
+ by (auto simp add: sup_bool_eq)
+
subsection {* Fun as lattice *}
@@ -472,21 +559,14 @@
definition
sup_fun_eq [code del]: "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"
-instance
-apply intro_classes
-unfolding inf_fun_eq sup_fun_eq
-apply (auto intro: le_funI)
-apply (rule le_funI)
-apply (auto dest: le_funD)
-apply (rule le_funI)
-apply (auto dest: le_funD)
-done
+instance proof
+qed (simp_all add: le_fun_def inf_fun_eq sup_fun_eq)
end
instance "fun" :: (type, distrib_lattice) distrib_lattice
proof
-qed (auto simp add: inf_fun_eq sup_fun_eq sup_inf_distrib1)
+qed (simp_all add: inf_fun_eq sup_fun_eq sup_inf_distrib1)
instantiation "fun" :: (type, uminus) uminus
begin
@@ -514,13 +594,12 @@
inf_compl_bot sup_compl_top diff_eq)
-text {* redundant bindings *}
-
-
no_notation
less_eq (infix "\<sqsubseteq>" 50) and
less (infix "\<sqsubset>" 50) and
inf (infixl "\<sqinter>" 70) and
- sup (infixl "\<squnion>" 65)
+ sup (infixl "\<squnion>" 65) and
+ top ("\<top>") and
+ bot ("\<bottom>")
end
--- a/src/HOL/Library/Abstract_Rat.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Abstract_Rat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -189,14 +189,9 @@
have "\<exists> a b a' b'. x = (a,b) \<and> y = (a',b')" by auto
then obtain a b a' b' where xy[simp]: "x = (a,b)" "y=(a',b')" by blast
assume H: ?lhs
- {assume "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0" hence ?rhs
- using na nb H
- apply (simp add: INum_def split_def isnormNum_def)
- apply (cases "a = 0", simp_all)
- apply (cases "b = 0", simp_all)
- apply (cases "a' = 0", simp_all)
- apply (cases "a' = 0", simp_all add: of_int_eq_0_iff)
- done}
+ {assume "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0"
+ hence ?rhs using na nb H
+ by (simp add: INum_def split_def isnormNum_def split: split_if_asm)}
moreover
{ assume az: "a \<noteq> 0" and bz: "b \<noteq> 0" and a'z: "a'\<noteq>0" and b'z: "b'\<noteq>0"
from az bz a'z b'z na nb have pos: "b > 0" "b' > 0" by (simp_all add: isnormNum_def)
@@ -517,10 +512,7 @@
have n0: "isnormNum 0\<^sub>N" by simp
show ?thesis using nx ny
apply (simp only: isnormNum_unique[where ?'a = 'a, OF Nmul_normN[OF nx ny] n0, symmetric] Nmul[where ?'a = 'a])
- apply (simp add: INum_def split_def isnormNum_def fst_conv snd_conv)
- apply (cases "a=0",simp_all)
- apply (cases "a'=0",simp_all)
- done
+ by (simp add: INum_def split_def isnormNum_def fst_conv snd_conv split: split_if_asm)
}
qed
lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
--- a/src/HOL/Library/Code_Char.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Code_Char.thy Thu Oct 01 07:40:25 2009 +0200
@@ -5,7 +5,7 @@
header {* Code generation of pretty characters (and strings) *}
theory Code_Char
-imports List Code_Eval Main
+imports List Code_Evaluation Main
begin
code_type char
@@ -32,7 +32,7 @@
(OCaml "!((_ : char) = _)")
(Haskell infixl 4 "==")
-code_const "Code_Eval.term_of \<Colon> char \<Rightarrow> term"
+code_const "Code_Evaluation.term_of \<Colon> char \<Rightarrow> term"
(Eval "HOLogic.mk'_char/ (IntInf.fromInt/ (Char.ord/ _))")
end
--- a/src/HOL/Library/Code_Integer.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Code_Integer.thy Thu Oct 01 07:40:25 2009 +0200
@@ -100,7 +100,7 @@
text {* Evaluation *}
-code_const "Code_Eval.term_of \<Colon> int \<Rightarrow> term"
+code_const "Code_Evaluation.term_of \<Colon> int \<Rightarrow> term"
(Eval "HOLogic.mk'_number/ HOLogic.intT")
end
\ No newline at end of file
--- a/src/HOL/Library/Coinductive_List.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Coinductive_List.thy Thu Oct 01 07:40:25 2009 +0200
@@ -260,7 +260,7 @@
qed
qed
-lemma llist_corec [code]:
+lemma llist_corec [code, nitpick_const_simp]:
"llist_corec a f =
(case f a of None \<Rightarrow> LNil | Some (z, w) \<Rightarrow> LCons z (llist_corec w f))"
proof (cases "f a")
@@ -656,8 +656,9 @@
qed
qed
-lemma lmap_LNil [simp]: "lmap f LNil = LNil"
- and lmap_LCons [simp]: "lmap f (LCons M N) = LCons (f M) (lmap f N)"
+lemma lmap_LNil [simp, nitpick_const_simp]: "lmap f LNil = LNil"
+ and lmap_LCons [simp, nitpick_const_simp]:
+ "lmap f (LCons M N) = LCons (f M) (lmap f N)"
by (simp_all add: lmap_def llist_corec)
lemma lmap_compose [simp]: "lmap (f o g) l = lmap f (lmap g l)"
@@ -728,9 +729,9 @@
qed
qed
-lemma lappend_LNil_LNil [simp]: "lappend LNil LNil = LNil"
- and lappend_LNil_LCons [simp]: "lappend LNil (LCons l l') = LCons l (lappend LNil l')"
- and lappend_LCons [simp]: "lappend (LCons l l') m = LCons l (lappend l' m)"
+lemma lappend_LNil_LNil [simp, nitpick_const_simp]: "lappend LNil LNil = LNil"
+ and lappend_LNil_LCons [simp, nitpick_const_simp]: "lappend LNil (LCons l l') = LCons l (lappend LNil l')"
+ and lappend_LCons [simp, nitpick_const_simp]: "lappend (LCons l l') m = LCons l (lappend l' m)"
by (simp_all add: lappend_def llist_corec)
lemma lappend_LNil1 [simp]: "lappend LNil l = l"
@@ -754,7 +755,7 @@
iterates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
"iterates f a = llist_corec a (\<lambda>x. Some (x, f x))"
-lemma iterates: "iterates f x = LCons x (iterates f (f x))"
+lemma iterates [nitpick_const_simp]: "iterates f x = LCons x (iterates f (f x))"
apply (unfold iterates_def)
apply (subst llist_corec)
apply simp
--- a/src/HOL/Library/Continuity.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Continuity.thy Thu Oct 01 07:40:25 2009 +0200
@@ -156,7 +156,7 @@
apply (rule up_chainI)
apply simp
apply (drule Un_absorb1)
-apply (auto simp add: nat_not_singleton)
+apply (auto split:split_if_asm)
done
@@ -184,8 +184,7 @@
apply (rule down_chainI)
apply simp
apply (drule Int_absorb1)
-apply auto
-apply (auto simp add: nat_not_singleton)
+apply (auto split:split_if_asm)
done
--- a/src/HOL/Library/Convex_Euclidean_Space.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Convex_Euclidean_Space.thy Thu Oct 01 07:40:25 2009 +0200
@@ -3355,9 +3355,8 @@
qed(auto intro!:path_connected_singleton) next
case False hence *:"{x::real^'n. norm(x - a) = r} = (\<lambda>x. a + r *\<^sub>R x) ` {x. norm x = 1}" unfolding not_le apply -apply(rule set_ext,rule)
unfolding image_iff apply(rule_tac x="(1/r) *\<^sub>R (x - a)" in bexI) unfolding mem_Collect_eq norm_scaleR by (auto simp add: scaleR_right_diff_distrib)
- have ***:"\<And>xa. (if xa = 0 then 0 else 1) \<noteq> 1 \<Longrightarrow> xa = 0" apply(rule ccontr) by auto
have **:"{x::real^'n. norm x = 1} = (\<lambda>x. (1/norm x) *\<^sub>R x) ` (UNIV - {0})" apply(rule set_ext,rule)
- unfolding image_iff apply(rule_tac x=x in bexI) unfolding mem_Collect_eq by(auto intro!: ***)
+ unfolding image_iff apply(rule_tac x=x in bexI) unfolding mem_Collect_eq by(auto split:split_if_asm)
have "continuous_on (UNIV - {0}) (\<lambda>x::real^'n. 1 / norm x)" unfolding o_def continuous_on_eq_continuous_within
apply(rule, rule continuous_at_within_inv[unfolded o_def inverse_eq_divide]) apply(rule continuous_at_within)
apply(rule continuous_at_norm[unfolded o_def]) by auto
--- a/src/HOL/Library/Efficient_Nat.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Efficient_Nat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -415,9 +415,9 @@
text {* Evaluation *}
lemma [code, code del]:
- "(Code_Eval.term_of \<Colon> nat \<Rightarrow> term) = Code_Eval.term_of" ..
+ "(Code_Evaluation.term_of \<Colon> nat \<Rightarrow> term) = Code_Evaluation.term_of" ..
-code_const "Code_Eval.term_of \<Colon> nat \<Rightarrow> term"
+code_const "Code_Evaluation.term_of \<Colon> nat \<Rightarrow> term"
(SML "HOLogic.mk'_number/ HOLogic.natT")
--- a/src/HOL/Library/Euclidean_Space.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Euclidean_Space.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1055,28 +1055,6 @@
lemma norm_triangle_lt: "norm(x::real ^'n::finite) + norm(y) < e ==> norm(x + y) < e"
by (metis basic_trans_rules(21) norm_triangle_ineq)
-lemma setsum_delta:
- assumes fS: "finite S"
- shows "setsum (\<lambda>k. if k=a then b k else 0) S = (if a \<in> S then b a else 0)"
-proof-
- let ?f = "(\<lambda>k. if k=a then b k else 0)"
- {assume a: "a \<notin> S"
- hence "\<forall> k\<in> S. ?f k = 0" by simp
- hence ?thesis using a by simp}
- moreover
- {assume a: "a \<in> S"
- let ?A = "S - {a}"
- let ?B = "{a}"
- have eq: "S = ?A \<union> ?B" using a by blast
- have dj: "?A \<inter> ?B = {}" by simp
- from fS have fAB: "finite ?A" "finite ?B" by auto
- have "setsum ?f S = setsum ?f ?A + setsum ?f ?B"
- using setsum_Un_disjoint[OF fAB dj, of ?f, unfolded eq[symmetric]]
- by simp
- then have ?thesis using a by simp}
- ultimately show ?thesis by blast
-qed
-
lemma component_le_norm: "\<bar>x$i\<bar> <= norm (x::real ^ 'n::finite)"
apply (simp add: norm_vector_def)
apply (rule member_le_setL2, simp_all)
@@ -2079,13 +2057,6 @@
lemma matrix_add_ldistrib: "(A ** (B + C)) = (A \<star> B) + (A \<star> C)"
by (vector matrix_matrix_mult_def setsum_addf[symmetric] ring_simps)
-lemma setsum_delta':
- assumes fS: "finite S" shows
- "setsum (\<lambda>k. if a = k then b k else 0) S =
- (if a\<in> S then b a else 0)"
- using setsum_delta[OF fS, of a b, symmetric]
- by (auto intro: setsum_cong)
-
lemma matrix_mul_lid:
fixes A :: "'a::semiring_1 ^ 'm ^ 'n::finite"
shows "mat 1 ** A = A"
@@ -3678,10 +3649,7 @@
from setsum_restrict_set[OF fS, of "\<lambda>v. u v *s v" S', symmetric] SS'
have "setsum (\<lambda>v. ?u v *s v) S = setsum (\<lambda>v. u v *s v) S'"
unfolding cond_value_iff cond_application_beta
- apply (simp add: cond_value_iff cong del: if_weak_cong)
- apply (rule setsum_cong)
- apply auto
- done
+ by (simp add: cond_value_iff inf_absorb2 cong del: if_weak_cong)
hence "setsum (\<lambda>v. ?u v *s v) S = y" by (metis u)
hence "y \<in> ?rhs" by auto}
moreover
@@ -3926,14 +3894,6 @@
shows "finite s \<and> card s \<le> card t"
by (metis exchange_lemma[OF f i sp] hassize_def finite_subset card_mono)
-lemma finite_Atleast_Atmost[simp]: "finite {f x |x. x\<in> {(i::'a::finite_intvl_succ) .. j}}"
-proof-
- have eq: "{f x |x. x\<in> {i .. j}} = f ` {i .. j}" by auto
- show ?thesis unfolding eq
- apply (rule finite_imageI)
- apply (rule finite_intvl)
- done
-qed
lemma finite_Atleast_Atmost_nat[simp]: "finite {f x |x. x\<in> (UNIV::'a::finite set)}"
proof-
--- a/src/HOL/Library/Eval_Witness.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Eval_Witness.thy Thu Oct 01 07:40:25 2009 +0200
@@ -48,7 +48,7 @@
structure Eval_Witness_Method =
struct
-val eval_ref : (unit -> bool) option ref = ref NONE;
+val eval_ref : (unit -> bool) option Unsynchronized.ref = Unsynchronized.ref NONE;
end;
*}
--- a/src/HOL/Library/Executable_Set.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Executable_Set.thy Thu Oct 01 07:40:25 2009 +0200
@@ -8,10 +8,25 @@
imports Main Fset
begin
-subsection {* Derived set operations *}
+subsection {* Preprocessor setup *}
declare member [code]
+definition empty :: "'a set" where
+ "empty = {}"
+
+declare empty_def [symmetric, code_unfold]
+
+definition inter :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
+ "inter = op \<inter>"
+
+declare inter_def [symmetric, code_unfold]
+
+definition union :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
+ "union = op \<union>"
+
+declare union_def [symmetric, code_unfold]
+
definition subset :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"subset = op \<le>"
@@ -24,9 +39,7 @@
definition eq_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
[code del]: "eq_set = op ="
-(* FIXME allow for Stefan's code generator:
-declare set_eq_subset[code_unfold]
-*)
+(*declare eq_set_def [symmetric, code_unfold]*)
lemma [code]:
"eq_set A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
@@ -34,16 +47,20 @@
declare inter [code]
-declare Inter_image_eq [symmetric, code]
-declare Union_image_eq [symmetric, code]
+declare List_Set.project_def [symmetric, code_unfold]
+
+definition Inter :: "'a set set \<Rightarrow> 'a set" where
+ "Inter = Complete_Lattice.Inter"
+
+declare Inter_def [symmetric, code_unfold]
+
+definition Union :: "'a set set \<Rightarrow> 'a set" where
+ "Union = Complete_Lattice.Union"
+
+declare Union_def [symmetric, code_unfold]
-subsection {* Rewrites for primitive operations *}
-
-declare List_Set.project_def [symmetric, code_unfold]
-
-
-subsection {* code generator setup *}
+subsection {* Code generator setup *}
ML {*
nonfix inter;
@@ -64,7 +81,7 @@
Set ("\<module>Set")
consts_code
- "Set.empty" ("{*Fset.empty*}")
+ "empty" ("{*Fset.empty*}")
"List_Set.is_empty" ("{*Fset.is_empty*}")
"Set.insert" ("{*Fset.insert*}")
"List_Set.remove" ("{*Fset.remove*}")
@@ -72,12 +89,14 @@
"List_Set.project" ("{*Fset.filter*}")
"Ball" ("{*flip Fset.forall*}")
"Bex" ("{*flip Fset.exists*}")
- "op \<union>" ("{*Fset.union*}")
- "op \<inter>" ("{*Fset.inter*}")
+ "union" ("{*Fset.union*}")
+ "inter" ("{*Fset.inter*}")
"op - \<Colon> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" ("{*flip Fset.subtract*}")
- "Complete_Lattice.Union" ("{*Fset.Union*}")
- "Complete_Lattice.Inter" ("{*Fset.Inter*}")
+ "Union" ("{*Fset.Union*}")
+ "Inter" ("{*Fset.Inter*}")
card ("{*Fset.card*}")
fold ("{*foldl o flip*}")
+hide (open) const empty inter union subset eq_set Inter Union flip
+
end
\ No newline at end of file
--- a/src/HOL/Library/Fin_Fun.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Fin_Fun.thy Thu Oct 01 07:40:25 2009 +0200
@@ -311,17 +311,17 @@
notation scomp (infixl "o\<rightarrow>" 60)
definition (in term_syntax) valtermify_finfun_const ::
- "'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> ('a\<Colon>typerep \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Eval.term)" where
- "valtermify_finfun_const y = Code_Eval.valtermify finfun_const {\<cdot>} y"
+ "'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a\<Colon>typerep \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
+ "valtermify_finfun_const y = Code_Evaluation.valtermify finfun_const {\<cdot>} y"
definition (in term_syntax) valtermify_finfun_update_code ::
- "'a\<Colon>typerep \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> 'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Eval.term)" where
- "valtermify_finfun_update_code x y f = Code_Eval.valtermify finfun_update_code {\<cdot>} f {\<cdot>} x {\<cdot>} y"
+ "'a\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> 'b\<Colon>typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b) \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
+ "valtermify_finfun_update_code x y f = Code_Evaluation.valtermify finfun_update_code {\<cdot>} f {\<cdot>} x {\<cdot>} y"
instantiation finfun :: (random, random) random
begin
-primrec random_finfun_aux :: "code_numeral \<Rightarrow> code_numeral \<Rightarrow> Random.seed \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b \<times> (unit \<Rightarrow> Code_Eval.term)) \<times> Random.seed" where
+primrec random_finfun_aux :: "code_numeral \<Rightarrow> code_numeral \<Rightarrow> Random.seed \<Rightarrow> ('a \<Rightarrow>\<^isub>f 'b \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed" where
"random_finfun_aux 0 j = Quickcheck.collapse (Random.select_weight
[(1, Quickcheck.random j o\<rightarrow> (\<lambda>y. Pair (valtermify_finfun_const y)))])"
| "random_finfun_aux (Suc_code_numeral i) j = Quickcheck.collapse (Random.select_weight
--- a/src/HOL/Library/Formal_Power_Series.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Formal_Power_Series.thy Thu Oct 01 07:40:25 2009 +0200
@@ -633,8 +633,7 @@
by (auto simp add: inverse_eq_divide power_divide)
from k have kn: "k > n"
- apply (simp add: leastP_def setge_def fps_sum_rep_nth)
- by (cases "k \<le> n", auto)
+ by (simp add: leastP_def setge_def fps_sum_rep_nth split:split_if_asm)
then have "dist (?s n) a < (1/2)^n" unfolding dth
by (auto intro: power_strict_decreasing)
also have "\<dots> <= (1/2)^n0" using nn0
@@ -1244,10 +1243,9 @@
{assume n0: "n \<noteq> 0"
then have u: "{0} \<union> ({1} \<union> {2..n}) = {0..n}" "{1}\<union>{2..n} = {1..n}"
"{0..n - 1}\<union>{n} = {0..n}"
- apply (simp_all add: expand_set_eq) by presburger+
+ by (auto simp: expand_set_eq)
have d: "{0} \<inter> ({1} \<union> {2..n}) = {}" "{1} \<inter> {2..n} = {}"
- "{0..n - 1}\<inter>{n} ={}" using n0
- by (simp_all add: expand_set_eq, presburger+)
+ "{0..n - 1}\<inter>{n} ={}" using n0 by simp_all
have f: "finite {0}" "finite {1}" "finite {2 .. n}"
"finite {0 .. n - 1}" "finite {n}" by simp_all
have "((1 - ?X) * ?sa) $ n = setsum (\<lambda>i. (1 - ?X)$ i * ?sa $ (n - i)) {0 .. n}"
@@ -2503,6 +2501,29 @@
then show ?thesis unfolding fps_inv_right[OF c0 c1] by simp
qed
+lemma fps_ginv_deriv:
+ assumes a0:"a$0 = (0::'a::{field})" and a1: "a$1 \<noteq> 0"
+ shows "fps_deriv (fps_ginv b a) = (fps_deriv b / fps_deriv a) oo fps_ginv X a"
+proof-
+ let ?ia = "fps_ginv b a"
+ let ?iXa = "fps_ginv X a"
+ let ?d = "fps_deriv"
+ let ?dia = "?d ?ia"
+ have iXa0: "?iXa $ 0 = 0" by (simp add: fps_ginv_def)
+ have da0: "?d a $ 0 \<noteq> 0" using a1 by simp
+ from fps_ginv[OF a0 a1, of b] have "?d (?ia oo a) = fps_deriv b" by simp
+ then have "(?d ?ia oo a) * ?d a = ?d b" unfolding fps_compose_deriv[OF a0] .
+ then have "(?d ?ia oo a) * ?d a * inverse (?d a) = ?d b * inverse (?d a)" by simp
+ then have "(?d ?ia oo a) * (inverse (?d a) * ?d a) = ?d b / ?d a"
+ by (simp add: fps_divide_def)
+ then have "(?d ?ia oo a) oo ?iXa = (?d b / ?d a) oo ?iXa "
+ unfolding inverse_mult_eq_1[OF da0] by simp
+ then have "?d ?ia oo (a oo ?iXa) = (?d b / ?d a) oo ?iXa"
+ unfolding fps_compose_assoc[OF iXa0 a0] .
+ then show ?thesis unfolding fps_inv_ginv[symmetric]
+ unfolding fps_inv_right[OF a0 a1] by simp
+qed
+
subsection{* Elementary series *}
subsubsection{* Exponential series *}
--- a/src/HOL/Library/Fundamental_Theorem_Algebra.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Fundamental_Theorem_Algebra.thy Thu Oct 01 07:40:25 2009 +0200
@@ -577,11 +577,12 @@
next
case (pCons c cs)
{assume c0: "c = 0"
- from pCons.hyps pCons.prems c0 have ?case apply auto
+ from pCons.hyps pCons.prems c0 have ?case
+ apply (auto)
apply (rule_tac x="k+1" in exI)
apply (rule_tac x="a" in exI, clarsimp)
apply (rule_tac x="q" in exI)
- by (auto simp add: power_Suc)}
+ by (auto)}
moreover
{assume c0: "c\<noteq>0"
hence ?case apply-
--- a/src/HOL/Library/Legacy_GCD.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,787 +0,0 @@
-(* Title: HOL/GCD.thy
- Author: Christophe Tabacznyj and Lawrence C Paulson
- Copyright 1996 University of Cambridge
-*)
-
-header {* The Greatest Common Divisor *}
-
-theory Legacy_GCD
-imports Main
-begin
-
-text {*
- See \cite{davenport92}. \bigskip
-*}
-
-subsection {* Specification of GCD on nats *}
-
-definition
- is_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where -- {* @{term gcd} as a relation *}
- [code del]: "is_gcd m n p \<longleftrightarrow> p dvd m \<and> p dvd n \<and>
- (\<forall>d. d dvd m \<longrightarrow> d dvd n \<longrightarrow> d dvd p)"
-
-text {* Uniqueness *}
-
-lemma is_gcd_unique: "is_gcd a b m \<Longrightarrow> is_gcd a b n \<Longrightarrow> m = n"
- by (simp add: is_gcd_def) (blast intro: dvd_anti_sym)
-
-text {* Connection to divides relation *}
-
-lemma is_gcd_dvd: "is_gcd a b m \<Longrightarrow> k dvd a \<Longrightarrow> k dvd b \<Longrightarrow> k dvd m"
- by (auto simp add: is_gcd_def)
-
-text {* Commutativity *}
-
-lemma is_gcd_commute: "is_gcd m n k = is_gcd n m k"
- by (auto simp add: is_gcd_def)
-
-
-subsection {* GCD on nat by Euclid's algorithm *}
-
-fun
- gcd :: "nat => nat => nat"
-where
- "gcd m n = (if n = 0 then m else gcd n (m mod n))"
-lemma gcd_induct [case_names "0" rec]:
- fixes m n :: nat
- assumes "\<And>m. P m 0"
- and "\<And>m n. 0 < n \<Longrightarrow> P n (m mod n) \<Longrightarrow> P m n"
- shows "P m n"
-proof (induct m n rule: gcd.induct)
- case (1 m n) with assms show ?case by (cases "n = 0") simp_all
-qed
-
-lemma gcd_0 [simp, algebra]: "gcd m 0 = m"
- by simp
-
-lemma gcd_0_left [simp,algebra]: "gcd 0 m = m"
- by simp
-
-lemma gcd_non_0: "n > 0 \<Longrightarrow> gcd m n = gcd n (m mod n)"
- by simp
-
-lemma gcd_1 [simp, algebra]: "gcd m (Suc 0) = Suc 0"
- by simp
-
-lemma nat_gcd_1_right [simp, algebra]: "gcd m 1 = 1"
- unfolding One_nat_def by (rule gcd_1)
-
-declare gcd.simps [simp del]
-
-text {*
- \medskip @{term "gcd m n"} divides @{text m} and @{text n}. The
- conjunctions don't seem provable separately.
-*}
-
-lemma gcd_dvd1 [iff, algebra]: "gcd m n dvd m"
- and gcd_dvd2 [iff, algebra]: "gcd m n dvd n"
- apply (induct m n rule: gcd_induct)
- apply (simp_all add: gcd_non_0)
- apply (blast dest: dvd_mod_imp_dvd)
- done
-
-text {*
- \medskip Maximality: for all @{term m}, @{term n}, @{term k}
- naturals, if @{term k} divides @{term m} and @{term k} divides
- @{term n} then @{term k} divides @{term "gcd m n"}.
-*}
-
-lemma gcd_greatest: "k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd gcd m n"
- by (induct m n rule: gcd_induct) (simp_all add: gcd_non_0 dvd_mod)
-
-text {*
- \medskip Function gcd yields the Greatest Common Divisor.
-*}
-
-lemma is_gcd: "is_gcd m n (gcd m n) "
- by (simp add: is_gcd_def gcd_greatest)
-
-
-subsection {* Derived laws for GCD *}
-
-lemma gcd_greatest_iff [iff, algebra]: "k dvd gcd m n \<longleftrightarrow> k dvd m \<and> k dvd n"
- by (blast intro!: gcd_greatest intro: dvd_trans)
-
-lemma gcd_zero[algebra]: "gcd m n = 0 \<longleftrightarrow> m = 0 \<and> n = 0"
- by (simp only: dvd_0_left_iff [symmetric] gcd_greatest_iff)
-
-lemma gcd_commute: "gcd m n = gcd n m"
- apply (rule is_gcd_unique)
- apply (rule is_gcd)
- apply (subst is_gcd_commute)
- apply (simp add: is_gcd)
- done
-
-lemma gcd_assoc: "gcd (gcd k m) n = gcd k (gcd m n)"
- apply (rule is_gcd_unique)
- apply (rule is_gcd)
- apply (simp add: is_gcd_def)
- apply (blast intro: dvd_trans)
- done
-
-lemma gcd_1_left [simp, algebra]: "gcd (Suc 0) m = Suc 0"
- by (simp add: gcd_commute)
-
-lemma nat_gcd_1_left [simp, algebra]: "gcd 1 m = 1"
- unfolding One_nat_def by (rule gcd_1_left)
-
-text {*
- \medskip Multiplication laws
-*}
-
-lemma gcd_mult_distrib2: "k * gcd m n = gcd (k * m) (k * n)"
- -- {* \cite[page 27]{davenport92} *}
- apply (induct m n rule: gcd_induct)
- apply simp
- apply (case_tac "k = 0")
- apply (simp_all add: mod_geq gcd_non_0 mod_mult_distrib2)
- done
-
-lemma gcd_mult [simp, algebra]: "gcd k (k * n) = k"
- apply (rule gcd_mult_distrib2 [of k 1 n, simplified, symmetric])
- done
-
-lemma gcd_self [simp, algebra]: "gcd k k = k"
- apply (rule gcd_mult [of k 1, simplified])
- done
-
-lemma relprime_dvd_mult: "gcd k n = 1 ==> k dvd m * n ==> k dvd m"
- apply (insert gcd_mult_distrib2 [of m k n])
- apply simp
- apply (erule_tac t = m in ssubst)
- apply simp
- done
-
-lemma relprime_dvd_mult_iff: "gcd k n = 1 ==> (k dvd m * n) = (k dvd m)"
- by (auto intro: relprime_dvd_mult dvd_mult2)
-
-lemma gcd_mult_cancel: "gcd k n = 1 ==> gcd (k * m) n = gcd m n"
- apply (rule dvd_anti_sym)
- apply (rule gcd_greatest)
- apply (rule_tac n = k in relprime_dvd_mult)
- apply (simp add: gcd_assoc)
- apply (simp add: gcd_commute)
- apply (simp_all add: mult_commute)
- done
-
-
-text {* \medskip Addition laws *}
-
-lemma gcd_add1 [simp, algebra]: "gcd (m + n) n = gcd m n"
- by (cases "n = 0") (auto simp add: gcd_non_0)
-
-lemma gcd_add2 [simp, algebra]: "gcd m (m + n) = gcd m n"
-proof -
- have "gcd m (m + n) = gcd (m + n) m" by (rule gcd_commute)
- also have "... = gcd (n + m) m" by (simp add: add_commute)
- also have "... = gcd n m" by simp
- also have "... = gcd m n" by (rule gcd_commute)
- finally show ?thesis .
-qed
-
-lemma gcd_add2' [simp, algebra]: "gcd m (n + m) = gcd m n"
- apply (subst add_commute)
- apply (rule gcd_add2)
- done
-
-lemma gcd_add_mult[algebra]: "gcd m (k * m + n) = gcd m n"
- by (induct k) (simp_all add: add_assoc)
-
-lemma gcd_dvd_prod: "gcd m n dvd m * n"
- using mult_dvd_mono [of 1] by auto
-
-text {*
- \medskip Division by gcd yields rrelatively primes.
-*}
-
-lemma div_gcd_relprime:
- assumes nz: "a \<noteq> 0 \<or> b \<noteq> 0"
- shows "gcd (a div gcd a b) (b div gcd a b) = 1"
-proof -
- let ?g = "gcd a b"
- let ?a' = "a div ?g"
- let ?b' = "b div ?g"
- let ?g' = "gcd ?a' ?b'"
- have dvdg: "?g dvd a" "?g dvd b" by simp_all
- have dvdg': "?g' dvd ?a'" "?g' dvd ?b'" by simp_all
- from dvdg dvdg' obtain ka kb ka' kb' where
- kab: "a = ?g * ka" "b = ?g * kb" "?a' = ?g' * ka'" "?b' = ?g' * kb'"
- unfolding dvd_def by blast
- then have "?g * ?a' = (?g * ?g') * ka'" "?g * ?b' = (?g * ?g') * kb'" by simp_all
- 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)
- then have gp: "?g > 0" by simp
- from gcd_greatest [OF dvdgg'] have "?g * ?g' dvd ?g" .
- with dvd_mult_cancel1 [OF gp] show "?g' = 1" by simp
-qed
-
-
-lemma gcd_unique: "d dvd a\<and>d dvd b \<and> (\<forall>e. e dvd a \<and> e dvd b \<longrightarrow> e dvd d) \<longleftrightarrow> d = gcd a b"
-proof(auto)
- assume H: "d dvd a" "d dvd b" "\<forall>e. e dvd a \<and> e dvd b \<longrightarrow> e dvd d"
- from H(3)[rule_format] gcd_dvd1[of a b] gcd_dvd2[of a b]
- have th: "gcd a b dvd d" by blast
- from dvd_anti_sym[OF th gcd_greatest[OF H(1,2)]] show "d = gcd a b" by blast
-qed
-
-lemma gcd_eq: assumes H: "\<forall>d. d dvd x \<and> d dvd y \<longleftrightarrow> d dvd u \<and> d dvd v"
- shows "gcd x y = gcd u v"
-proof-
- from H have "\<forall>d. d dvd x \<and> d dvd y \<longleftrightarrow> d dvd gcd u v" by simp
- with gcd_unique[of "gcd u v" x y] show ?thesis by auto
-qed
-
-lemma ind_euclid:
- assumes c: " \<forall>a b. P (a::nat) b \<longleftrightarrow> P b a" and z: "\<forall>a. P a 0"
- and add: "\<forall>a b. P a b \<longrightarrow> P a (a + b)"
- shows "P a b"
-proof(induct n\<equiv>"a+b" arbitrary: a b rule: nat_less_induct)
- fix n a b
- assume H: "\<forall>m < n. \<forall>a b. m = a + b \<longrightarrow> P a b" "n = a + b"
- have "a = b \<or> a < b \<or> b < a" by arith
- moreover {assume eq: "a= b"
- from add[rule_format, OF z[rule_format, of a]] have "P a b" using eq by simp}
- moreover
- {assume lt: "a < b"
- hence "a + b - a < n \<or> a = 0" using H(2) by arith
- moreover
- {assume "a =0" with z c have "P a b" by blast }
- moreover
- {assume ab: "a + b - a < n"
- have th0: "a + b - a = a + (b - a)" using lt by arith
- from add[rule_format, OF H(1)[rule_format, OF ab th0]]
- have "P a b" by (simp add: th0[symmetric])}
- ultimately have "P a b" by blast}
- moreover
- {assume lt: "a > b"
- hence "b + a - b < n \<or> b = 0" using H(2) by arith
- moreover
- {assume "b =0" with z c have "P a b" by blast }
- moreover
- {assume ab: "b + a - b < n"
- have th0: "b + a - b = b + (a - b)" using lt by arith
- from add[rule_format, OF H(1)[rule_format, OF ab th0]]
- have "P b a" by (simp add: th0[symmetric])
- hence "P a b" using c by blast }
- ultimately have "P a b" by blast}
-ultimately show "P a b" by blast
-qed
-
-lemma bezout_lemma:
- assumes ex: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x = b * y + d \<or> b * x = a * y + d)"
- shows "\<exists>d x y. d dvd a \<and> d dvd a + b \<and> (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 (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
-apply (rule_tac x="x" in exI)
-apply (rule_tac x="x + y" in exI)
-apply algebra
-done
-
-lemma bezout_add: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x = b * y + d \<or> b * x = a * y + d)"
-apply(induct a b rule: ind_euclid)
-apply blast
-apply clarify
-apply (rule_tac x="a" in exI, simp add: dvd_add)
-apply clarsimp
-apply (rule_tac x="d" in exI)
-apply (case_tac "a * x = b * y + d", simp_all add: dvd_add)
-apply (rule_tac x="x+y" in exI)
-apply (rule_tac x="y" in exI)
-apply algebra
-apply (rule_tac x="x" in exI)
-apply (rule_tac x="x+y" in exI)
-apply algebra
-done
-
-lemma bezout: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x - b * y = d \<or> b * x - a * y = d)"
-using bezout_add[of a b]
-apply clarsimp
-apply (rule_tac x="d" in exI, simp)
-apply (rule_tac x="x" in exI)
-apply (rule_tac x="y" in exI)
-apply auto
-done
-
-
-text {* We can get a stronger version with a nonzeroness assumption. *}
-lemma divides_le: "m dvd n ==> m <= n \<or> n = (0::nat)" by (auto simp add: dvd_def)
-
-lemma bezout_add_strong: assumes nz: "a \<noteq> (0::nat)"
- shows "\<exists>d x y. d dvd a \<and> d dvd b \<and> a * x = b * y + d"
-proof-
- from nz have ap: "a > 0" by simp
- from bezout_add[of a b]
- have "(\<exists>d x y. d dvd a \<and> d dvd b \<and> a * x = b * y + d) \<or> (\<exists>d x y. d dvd a \<and> d dvd b \<and> b * x = a * y + d)" by blast
- moreover
- {fix d x y assume H: "d dvd a" "d dvd b" "a * x = b * y + d"
- from H have ?thesis by blast }
- moreover
- {fix d x y assume H: "d dvd a" "d dvd b" "b * x = a * y + d"
- {assume b0: "b = 0" with H have ?thesis by simp}
- moreover
- {assume b: "b \<noteq> 0" hence bp: "b > 0" by simp
- from divides_le[OF H(2)] b have "d < b \<or> d = b" using le_less by blast
- moreover
- {assume db: "d=b"
- from prems have ?thesis apply simp
- apply (rule exI[where x = b], simp)
- apply (rule exI[where x = b])
- by (rule exI[where x = "a - 1"], simp add: diff_mult_distrib2)}
- moreover
- {assume db: "d < b"
- {assume "x=0" hence ?thesis using prems by simp }
- moreover
- {assume x0: "x \<noteq> 0" hence xp: "x > 0" by simp
-
- from db have "d \<le> b - 1" by simp
- hence "d*b \<le> b*(b - 1)" by simp
- with xp mult_mono[of "1" "x" "d*b" "b*(b - 1)"]
- have dble: "d*b \<le> x*b*(b - 1)" using bp by simp
- from H (3) have "a * ((b - 1) * y) + d * (b - 1 + 1) = d + x*b*(b - 1)" by algebra
- hence "a * ((b - 1) * y) = d + x*b*(b - 1) - d*b" using bp by simp
- hence "a * ((b - 1) * y) = d + (x*b*(b - 1) - d*b)"
- by (simp only: diff_add_assoc[OF dble, of d, symmetric])
- hence "a * ((b - 1) * y) = b*(x*(b - 1) - d) + d"
- by (simp only: diff_mult_distrib2 add_commute mult_ac)
- hence ?thesis using H(1,2)
- apply -
- apply (rule exI[where x=d], simp)
- apply (rule exI[where x="(b - 1) * y"])
- by (rule exI[where x="x*(b - 1) - d"], simp)}
- ultimately have ?thesis by blast}
- ultimately have ?thesis by blast}
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-
-lemma bezout_gcd: "\<exists>x y. a * x - b * y = gcd a b \<or> b * x - a * y = gcd a b"
-proof-
- let ?g = "gcd a b"
- from bezout[of a b] obtain d x y where d: "d dvd a" "d dvd b" "a * x - b * y = d \<or> b * x - a * y = d" by blast
- from d(1,2) have "d dvd ?g" by simp
- then obtain k where k: "?g = d*k" unfolding dvd_def by blast
- from d(3) have "(a * x - b * y)*k = d*k \<or> (b * x - a * y)*k = d*k" by blast
- hence "a * x * k - b * y*k = d*k \<or> b * x * k - a * y*k = d*k"
- by (algebra add: diff_mult_distrib)
- hence "a * (x * k) - b * (y*k) = ?g \<or> b * (x * k) - a * (y*k) = ?g"
- by (simp add: k mult_assoc)
- thus ?thesis by blast
-qed
-
-lemma bezout_gcd_strong: assumes a: "a \<noteq> 0"
- shows "\<exists>x y. a * x = b * y + gcd a b"
-proof-
- let ?g = "gcd a b"
- from bezout_add_strong[OF a, of b]
- obtain d x y where d: "d dvd a" "d dvd b" "a * x = b * y + d" by blast
- from d(1,2) have "d dvd ?g" by simp
- then obtain k where k: "?g = d*k" unfolding dvd_def by blast
- from d(3) have "a * x * k = (b * y + d) *k " by algebra
- hence "a * (x * k) = b * (y*k) + ?g" by (algebra add: k)
- thus ?thesis by blast
-qed
-
-lemma gcd_mult_distrib: "gcd(a * c) (b * c) = c * gcd a b"
-by(simp add: gcd_mult_distrib2 mult_commute)
-
-lemma gcd_bezout: "(\<exists>x y. a * x - b * y = d \<or> b * x - a * y = d) \<longleftrightarrow> gcd a b dvd d"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- let ?g = "gcd a b"
- {assume H: ?rhs then obtain k where k: "d = ?g*k" unfolding dvd_def by blast
- from bezout_gcd[of a b] obtain x y where xy: "a * x - b * y = ?g \<or> b * x - a * y = ?g"
- by blast
- hence "(a * x - b * y)*k = ?g*k \<or> (b * x - a * y)*k = ?g*k" by auto
- hence "a * x*k - b * y*k = ?g*k \<or> b * x * k - a * y*k = ?g*k"
- by (simp only: diff_mult_distrib)
- hence "a * (x*k) - b * (y*k) = d \<or> b * (x * k) - a * (y*k) = d"
- by (simp add: k[symmetric] mult_assoc)
- hence ?lhs by blast}
- moreover
- {fix x y assume H: "a * x - b * y = d \<or> b * x - a * y = d"
- have dv: "?g dvd a*x" "?g dvd b * y" "?g dvd b*x" "?g dvd a * y"
- using dvd_mult2[OF gcd_dvd1[of a b]] dvd_mult2[OF gcd_dvd2[of a b]] by simp_all
- from dvd_diff_nat[OF dv(1,2)] dvd_diff_nat[OF dv(3,4)] H
- have ?rhs by auto}
- ultimately show ?thesis by blast
-qed
-
-lemma gcd_bezout_sum: assumes H:"a * x + b * y = d" shows "gcd a b dvd d"
-proof-
- let ?g = "gcd a b"
- have dv: "?g dvd a*x" "?g dvd b * y"
- using dvd_mult2[OF gcd_dvd1[of a b]] dvd_mult2[OF gcd_dvd2[of a b]] by simp_all
- from dvd_add[OF dv] H
- show ?thesis by auto
-qed
-
-lemma gcd_mult': "gcd b (a * b) = b"
-by (simp add: gcd_mult mult_commute[of a b])
-
-lemma gcd_add: "gcd(a + b) b = gcd a b"
- "gcd(b + a) b = gcd a b" "gcd a (a + b) = gcd a b" "gcd a (b + a) = gcd a b"
-apply (simp_all add: gcd_add1)
-by (simp add: gcd_commute gcd_add1)
-
-lemma gcd_sub: "b <= a ==> gcd(a - b) b = gcd a b" "a <= b ==> gcd a (b - a) = gcd a b"
-proof-
- {fix a b assume H: "b \<le> (a::nat)"
- hence th: "a - b + b = a" by arith
- from gcd_add(1)[of "a - b" b] th have "gcd(a - b) b = gcd a b" by simp}
- note th = this
-{
- assume ab: "b \<le> a"
- from th[OF ab] show "gcd (a - b) b = gcd a b" by blast
-next
- assume ab: "a \<le> b"
- from th[OF ab] show "gcd a (b - a) = gcd a b"
- by (simp add: gcd_commute)}
-qed
-
-
-subsection {* LCM defined by GCD *}
-
-
-definition
- lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat"
-where
- lcm_def: "lcm m n = m * n div gcd m n"
-
-lemma prod_gcd_lcm:
- "m * n = gcd m n * lcm m n"
- unfolding lcm_def by (simp add: dvd_mult_div_cancel [OF gcd_dvd_prod])
-
-lemma lcm_0 [simp]: "lcm m 0 = 0"
- unfolding lcm_def by simp
-
-lemma lcm_1 [simp]: "lcm m 1 = m"
- unfolding lcm_def by simp
-
-lemma lcm_0_left [simp]: "lcm 0 n = 0"
- unfolding lcm_def by simp
-
-lemma lcm_1_left [simp]: "lcm 1 m = m"
- unfolding lcm_def by simp
-
-lemma dvd_pos:
- fixes n m :: nat
- assumes "n > 0" and "m dvd n"
- shows "m > 0"
-using assms by (cases m) auto
-
-lemma lcm_least:
- assumes "m dvd k" and "n dvd k"
- shows "lcm m n dvd k"
-proof (cases k)
- case 0 then show ?thesis by auto
-next
- case (Suc _) then have pos_k: "k > 0" by auto
- from assms dvd_pos [OF this] have pos_mn: "m > 0" "n > 0" by auto
- with gcd_zero [of m n] have pos_gcd: "gcd m n > 0" by simp
- from assms obtain p where k_m: "k = m * p" using dvd_def by blast
- from assms obtain q where k_n: "k = n * q" using dvd_def by blast
- from pos_k k_m have pos_p: "p > 0" by auto
- from pos_k k_n have pos_q: "q > 0" by auto
- have "k * k * gcd q p = k * gcd (k * q) (k * p)"
- by (simp add: mult_ac gcd_mult_distrib2)
- also have "\<dots> = k * gcd (m * p * q) (n * q * p)"
- by (simp add: k_m [symmetric] k_n [symmetric])
- also have "\<dots> = k * p * q * gcd m n"
- by (simp add: mult_ac gcd_mult_distrib2)
- finally have "(m * p) * (n * q) * gcd q p = k * p * q * gcd m n"
- by (simp only: k_m [symmetric] k_n [symmetric])
- then have "p * q * m * n * gcd q p = p * q * k * gcd m n"
- by (simp add: mult_ac)
- with pos_p pos_q have "m * n * gcd q p = k * gcd m n"
- by simp
- with prod_gcd_lcm [of m n]
- have "lcm m n * gcd q p * gcd m n = k * gcd m n"
- by (simp add: mult_ac)
- with pos_gcd have "lcm m n * gcd q p = k" by simp
- then show ?thesis using dvd_def by auto
-qed
-
-lemma lcm_dvd1 [iff]:
- "m dvd lcm m n"
-proof (cases m)
- case 0 then show ?thesis by simp
-next
- case (Suc _)
- then have mpos: "m > 0" by simp
- show ?thesis
- proof (cases n)
- case 0 then show ?thesis by simp
- next
- case (Suc _)
- then have npos: "n > 0" by simp
- have "gcd m n dvd n" by simp
- then obtain k where "n = gcd m n * k" using dvd_def by auto
- then have "m * n div gcd m n = m * (gcd m n * k) div gcd m n" by (simp add: mult_ac)
- also have "\<dots> = m * k" using mpos npos gcd_zero by simp
- finally show ?thesis by (simp add: lcm_def)
- qed
-qed
-
-lemma lcm_dvd2 [iff]:
- "n dvd lcm m n"
-proof (cases n)
- case 0 then show ?thesis by simp
-next
- case (Suc _)
- then have npos: "n > 0" by simp
- show ?thesis
- proof (cases m)
- case 0 then show ?thesis by simp
- next
- case (Suc _)
- then have mpos: "m > 0" by simp
- have "gcd m n dvd m" by simp
- then obtain k where "m = gcd m n * k" using dvd_def by auto
- then have "m * n div gcd m n = (gcd m n * k) * n div gcd m n" by (simp add: mult_ac)
- also have "\<dots> = n * k" using mpos npos gcd_zero by simp
- finally show ?thesis by (simp add: lcm_def)
- qed
-qed
-
-lemma gcd_add1_eq: "gcd (m + k) k = gcd (m + k) m"
- by (simp add: gcd_commute)
-
-lemma gcd_diff2: "m \<le> n ==> gcd n (n - m) = gcd n m"
- apply (subgoal_tac "n = m + (n - m)")
- apply (erule ssubst, rule gcd_add1_eq, simp)
- done
-
-
-subsection {* GCD and LCM on integers *}
-
-definition
- zgcd :: "int \<Rightarrow> int \<Rightarrow> int" where
- "zgcd i j = int (gcd (nat (abs i)) (nat (abs j)))"
-
-lemma zgcd_zdvd1 [iff,simp, algebra]: "zgcd i j dvd i"
-by (simp add: zgcd_def int_dvd_iff)
-
-lemma zgcd_zdvd2 [iff,simp, algebra]: "zgcd i j dvd j"
-by (simp add: zgcd_def int_dvd_iff)
-
-lemma zgcd_pos: "zgcd i j \<ge> 0"
-by (simp add: zgcd_def)
-
-lemma zgcd0 [simp,algebra]: "(zgcd i j = 0) = (i = 0 \<and> j = 0)"
-by (simp add: zgcd_def gcd_zero)
-
-lemma zgcd_commute: "zgcd i j = zgcd j i"
-unfolding zgcd_def by (simp add: gcd_commute)
-
-lemma zgcd_zminus [simp, algebra]: "zgcd (- i) j = zgcd i j"
-unfolding zgcd_def by simp
-
-lemma zgcd_zminus2 [simp, algebra]: "zgcd i (- j) = zgcd i j"
-unfolding zgcd_def by simp
-
- (* should be solved by algebra*)
-lemma zrelprime_dvd_mult: "zgcd i j = 1 \<Longrightarrow> i dvd k * j \<Longrightarrow> i dvd k"
- unfolding zgcd_def
-proof -
- assume "int (gcd (nat \<bar>i\<bar>) (nat \<bar>j\<bar>)) = 1" "i dvd k * j"
- then have g: "gcd (nat \<bar>i\<bar>) (nat \<bar>j\<bar>) = 1" by simp
- from `i dvd k * j` obtain h where h: "k*j = i*h" unfolding dvd_def by blast
- have th: "nat \<bar>i\<bar> dvd nat \<bar>k\<bar> * nat \<bar>j\<bar>"
- unfolding dvd_def
- by (rule_tac x= "nat \<bar>h\<bar>" in exI, simp add: h nat_abs_mult_distrib [symmetric])
- from relprime_dvd_mult [OF g th] obtain h' where h': "nat \<bar>k\<bar> = nat \<bar>i\<bar> * h'"
- unfolding dvd_def by blast
- from h' have "int (nat \<bar>k\<bar>) = int (nat \<bar>i\<bar> * h')" by simp
- then have "\<bar>k\<bar> = \<bar>i\<bar> * int h'" by (simp add: int_mult)
- then show ?thesis
- apply (subst abs_dvd_iff [symmetric])
- apply (subst dvd_abs_iff [symmetric])
- apply (unfold dvd_def)
- apply (rule_tac x = "int h'" in exI, simp)
- done
-qed
-
-lemma int_nat_abs: "int (nat (abs x)) = abs x" by arith
-
-lemma zgcd_greatest:
- assumes "k dvd m" and "k dvd n"
- shows "k dvd zgcd m n"
-proof -
- let ?k' = "nat \<bar>k\<bar>"
- let ?m' = "nat \<bar>m\<bar>"
- let ?n' = "nat \<bar>n\<bar>"
- from `k dvd m` and `k dvd n` have dvd': "?k' dvd ?m'" "?k' dvd ?n'"
- unfolding zdvd_int by (simp_all only: int_nat_abs abs_dvd_iff dvd_abs_iff)
- from gcd_greatest [OF dvd'] have "int (nat \<bar>k\<bar>) dvd zgcd m n"
- unfolding zgcd_def by (simp only: zdvd_int)
- then have "\<bar>k\<bar> dvd zgcd m n" by (simp only: int_nat_abs)
- then show "k dvd zgcd m n" by simp
-qed
-
-lemma div_zgcd_relprime:
- assumes nz: "a \<noteq> 0 \<or> b \<noteq> 0"
- shows "zgcd (a div (zgcd a b)) (b div (zgcd a b)) = 1"
-proof -
- from nz have nz': "nat \<bar>a\<bar> \<noteq> 0 \<or> nat \<bar>b\<bar> \<noteq> 0" by arith
- let ?g = "zgcd a b"
- let ?a' = "a div ?g"
- let ?b' = "b div ?g"
- let ?g' = "zgcd ?a' ?b'"
- have dvdg: "?g dvd a" "?g dvd b" by (simp_all add: zgcd_zdvd1 zgcd_zdvd2)
- have dvdg': "?g' dvd ?a'" "?g' dvd ?b'" by (simp_all add: zgcd_zdvd1 zgcd_zdvd2)
- from dvdg dvdg' obtain ka kb ka' kb' where
- kab: "a = ?g*ka" "b = ?g*kb" "?a' = ?g'*ka'" "?b' = ?g' * kb'"
- unfolding dvd_def by blast
- then have "?g* ?a' = (?g * ?g') * ka'" "?g* ?b' = (?g * ?g') * kb'" by simp_all
- then have dvdgg':"?g * ?g' dvd a" "?g* ?g' dvd b"
- by (auto simp add: zdvd_mult_div_cancel [OF dvdg(1)]
- zdvd_mult_div_cancel [OF dvdg(2)] dvd_def)
- have "?g \<noteq> 0" using nz by simp
- then have gp: "?g \<noteq> 0" using zgcd_pos[where i="a" and j="b"] by arith
- from zgcd_greatest [OF dvdgg'] have "?g * ?g' dvd ?g" .
- with zdvd_mult_cancel1 [OF gp] have "\<bar>?g'\<bar> = 1" by simp
- with zgcd_pos show "?g' = 1" by simp
-qed
-
-lemma zgcd_0 [simp, algebra]: "zgcd m 0 = abs m"
- by (simp add: zgcd_def abs_if)
-
-lemma zgcd_0_left [simp, algebra]: "zgcd 0 m = abs m"
- by (simp add: zgcd_def abs_if)
-
-lemma zgcd_non_0: "0 < n ==> zgcd m n = zgcd n (m mod n)"
- apply (frule_tac b = n and a = m in pos_mod_sign)
- apply (simp del: pos_mod_sign add: zgcd_def abs_if nat_mod_distrib)
- apply (auto simp add: gcd_non_0 nat_mod_distrib [symmetric] zmod_zminus1_eq_if)
- apply (frule_tac a = m in pos_mod_bound)
- apply (simp del: pos_mod_bound add: nat_diff_distrib gcd_diff2 nat_le_eq_zle)
- done
-
-lemma zgcd_eq: "zgcd m n = zgcd n (m mod n)"
- apply (case_tac "n = 0", simp add: DIVISION_BY_ZERO)
- apply (auto simp add: linorder_neq_iff zgcd_non_0)
- apply (cut_tac m = "-m" and n = "-n" in zgcd_non_0, auto)
- done
-
-lemma zgcd_1 [simp, algebra]: "zgcd m 1 = 1"
- by (simp add: zgcd_def abs_if)
-
-lemma zgcd_0_1_iff [simp, algebra]: "zgcd 0 m = 1 \<longleftrightarrow> \<bar>m\<bar> = 1"
- by (simp add: zgcd_def abs_if)
-
-lemma zgcd_greatest_iff[algebra]: "k dvd zgcd m n = (k dvd m \<and> k dvd n)"
- by (simp add: zgcd_def abs_if int_dvd_iff dvd_int_iff nat_dvd_iff)
-
-lemma zgcd_1_left [simp, algebra]: "zgcd 1 m = 1"
- by (simp add: zgcd_def gcd_1_left)
-
-lemma zgcd_assoc: "zgcd (zgcd k m) n = zgcd k (zgcd m n)"
- by (simp add: zgcd_def gcd_assoc)
-
-lemma zgcd_left_commute: "zgcd k (zgcd m n) = zgcd m (zgcd k n)"
- apply (rule zgcd_commute [THEN trans])
- apply (rule zgcd_assoc [THEN trans])
- apply (rule zgcd_commute [THEN arg_cong])
- done
-
-lemmas zgcd_ac = zgcd_assoc zgcd_commute zgcd_left_commute
- -- {* addition is an AC-operator *}
-
-lemma zgcd_zmult_distrib2: "0 \<le> k ==> k * zgcd m n = zgcd (k * m) (k * n)"
- by (simp del: minus_mult_right [symmetric]
- add: minus_mult_right nat_mult_distrib zgcd_def abs_if
- mult_less_0_iff gcd_mult_distrib2 [symmetric] zmult_int [symmetric])
-
-lemma zgcd_zmult_distrib2_abs: "zgcd (k * m) (k * n) = abs k * zgcd m n"
- by (simp add: abs_if zgcd_zmult_distrib2)
-
-lemma zgcd_self [simp]: "0 \<le> m ==> zgcd m m = m"
- by (cut_tac k = m and m = 1 and n = 1 in zgcd_zmult_distrib2, simp_all)
-
-lemma zgcd_zmult_eq_self [simp]: "0 \<le> k ==> zgcd k (k * n) = k"
- by (cut_tac k = k and m = 1 and n = n in zgcd_zmult_distrib2, simp_all)
-
-lemma zgcd_zmult_eq_self2 [simp]: "0 \<le> k ==> zgcd (k * n) k = k"
- by (cut_tac k = k and m = n and n = 1 in zgcd_zmult_distrib2, simp_all)
-
-
-definition "zlcm i j = int (lcm(nat(abs i)) (nat(abs j)))"
-
-lemma dvd_zlcm_self1[simp, algebra]: "i dvd zlcm i j"
-by(simp add:zlcm_def dvd_int_iff)
-
-lemma dvd_zlcm_self2[simp, algebra]: "j dvd zlcm i j"
-by(simp add:zlcm_def dvd_int_iff)
-
-
-lemma dvd_imp_dvd_zlcm1:
- assumes "k dvd i" shows "k dvd (zlcm i j)"
-proof -
- have "nat(abs k) dvd nat(abs i)" using `k dvd i`
- by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
- thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
-qed
-
-lemma dvd_imp_dvd_zlcm2:
- assumes "k dvd j" shows "k dvd (zlcm i j)"
-proof -
- have "nat(abs k) dvd nat(abs j)" using `k dvd j`
- by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
- thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
-qed
-
-
-lemma zdvd_self_abs1: "(d::int) dvd (abs d)"
-by (case_tac "d <0", simp_all)
-
-lemma zdvd_self_abs2: "(abs (d::int)) dvd d"
-by (case_tac "d<0", simp_all)
-
-(* lcm a b is positive for positive a and b *)
-
-lemma lcm_pos:
- assumes mpos: "m > 0"
- and npos: "n>0"
- shows "lcm m n > 0"
-proof(rule ccontr, simp add: lcm_def gcd_zero)
-assume h:"m*n div gcd m n = 0"
-from mpos npos have "gcd m n \<noteq> 0" using gcd_zero by simp
-hence gcdp: "gcd m n > 0" by simp
-with h
-have "m*n < gcd m n"
- by (cases "m * n < gcd m n") (auto simp add: div_if[OF gcdp, where m="m*n"])
-moreover
-have "gcd m n dvd m" by simp
- with mpos dvd_imp_le have t1:"gcd m n \<le> m" by simp
- with npos have t1:"gcd m n *n \<le> m*n" by simp
- have "gcd m n \<le> gcd m n*n" using npos by simp
- with t1 have "gcd m n \<le> m*n" by arith
-ultimately show "False" by simp
-qed
-
-lemma zlcm_pos:
- assumes anz: "a \<noteq> 0"
- and bnz: "b \<noteq> 0"
- shows "0 < zlcm a b"
-proof-
- let ?na = "nat (abs a)"
- let ?nb = "nat (abs b)"
- have nap: "?na >0" using anz by simp
- have nbp: "?nb >0" using bnz by simp
- have "0 < lcm ?na ?nb" by (rule lcm_pos[OF nap nbp])
- thus ?thesis by (simp add: zlcm_def)
-qed
-
-lemma zgcd_code [code]:
- "zgcd k l = \<bar>if l = 0 then k else zgcd l (\<bar>k\<bar> mod \<bar>l\<bar>)\<bar>"
- by (simp add: zgcd_def gcd.simps [of "nat \<bar>k\<bar>"] nat_mod_distrib)
-
-end
--- a/src/HOL/Library/Library.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Library.thy Thu Oct 01 07:40:25 2009 +0200
@@ -43,11 +43,9 @@
OptionalSugar
Option_ord
Permutation
- Pocklington
Poly_Deriv
Polynomial
Preorder
- Primes
Product_Vector
Quicksort
Quotient
--- a/src/HOL/Library/Multiset.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Multiset.thy Thu Oct 01 07:40:25 2009 +0200
@@ -331,7 +331,7 @@
lemma multiset_inter_count:
"count (A #\<inter> B) x = min (count A x) (count B x)"
-by (simp add: multiset_inter_def min_def)
+by (simp add: multiset_inter_def)
lemma multiset_inter_commute: "A #\<inter> B = B #\<inter> A"
by (simp add: multiset_eq_conv_count_eq multiset_inter_count
@@ -353,7 +353,7 @@
by (simp add: multiset_eq_conv_count_eq multiset_inter_count)
lemma multiset_union_diff_commute: "B #\<inter> C = {#} \<Longrightarrow> A + B - C = A - C + B"
-apply (simp add: multiset_eq_conv_count_eq multiset_inter_count min_def
+apply (simp add: multiset_eq_conv_count_eq multiset_inter_count
split: split_if_asm)
apply clarsimp
apply (erule_tac x = a in allE)
--- a/src/HOL/Library/Nested_Environment.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Nested_Environment.thy Thu Oct 01 07:40:25 2009 +0200
@@ -567,6 +567,6 @@
qed simp_all
lemma [code, code del]:
- "(Code_Eval.term_of :: ('a::{term_of, type}, 'b::{term_of, type}, 'c::{term_of, type}) env \<Rightarrow> term) = Code_Eval.term_of" ..
+ "(Code_Evaluation.term_of :: ('a::{term_of, type}, 'b::{term_of, type}, 'c::{term_of, type}) env \<Rightarrow> term) = Code_Evaluation.term_of" ..
end
--- a/src/HOL/Library/Permutations.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Permutations.thy Thu Oct 01 07:40:25 2009 +0200
@@ -843,9 +843,7 @@
unfolding permutes_def by metis+
from eq have "(Fun.swap a b id o p) a = (Fun.swap a c id o q) a" by simp
hence bc: "b = c"
- apply (simp add: permutes_def pa qa o_def fun_upd_def swap_def id_def cong del: if_weak_cong)
- apply (cases "a = b", auto)
- by (cases "b = c", auto)
+ by (simp add: permutes_def pa qa o_def fun_upd_def swap_def id_def cong del: if_weak_cong split: split_if_asm)
from eq[unfolded bc] have "(\<lambda>p. Fun.swap a c id o p) (Fun.swap a c id o p) = (\<lambda>p. Fun.swap a c id o p) (Fun.swap a c id o q)" by simp
hence "p = q" unfolding o_assoc swap_id_idempotent
by (simp add: o_def)
--- a/src/HOL/Library/Pocklington.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1263 +0,0 @@
-(* Title: HOL/Library/Pocklington.thy
- Author: Amine Chaieb
-*)
-
-header {* Pocklington's Theorem for Primes *}
-
-theory Pocklington
-imports Main Primes
-begin
-
-definition modeq:: "nat => nat => nat => bool" ("(1[_ = _] '(mod _'))")
- where "[a = b] (mod p) == ((a mod p) = (b mod p))"
-
-definition modneq:: "nat => nat => nat => bool" ("(1[_ \<noteq> _] '(mod _'))")
- where "[a \<noteq> b] (mod p) == ((a mod p) \<noteq> (b mod p))"
-
-lemma modeq_trans:
- "\<lbrakk> [a = b] (mod p); [b = c] (mod p) \<rbrakk> \<Longrightarrow> [a = c] (mod p)"
- by (simp add:modeq_def)
-
-
-lemma nat_mod_lemma: assumes xyn: "[x = y] (mod n)" and xy:"y \<le> x"
- shows "\<exists>q. x = y + n * q"
-using xyn xy unfolding modeq_def using nat_mod_eq_lemma by blast
-
-lemma nat_mod[algebra]: "[x = y] (mod n) \<longleftrightarrow> (\<exists>q1 q2. x + n * q1 = y + n * q2)"
-unfolding modeq_def nat_mod_eq_iff ..
-
-(* Lemmas about previously defined terms. *)
-
-lemma prime: "prime p \<longleftrightarrow> p \<noteq> 0 \<and> p\<noteq>1 \<and> (\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m)"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume "p=0 \<or> p=1" hence ?thesis using prime_0 prime_1 by (cases "p=0", simp_all)}
- moreover
- {assume p0: "p\<noteq>0" "p\<noteq>1"
- {assume H: "?lhs"
- {fix m assume m: "m > 0" "m < p"
- {assume "m=1" hence "coprime p m" by simp}
- moreover
- {assume "p dvd m" hence "p \<le> m" using dvd_imp_le m by blast with m(2)
- have "coprime p m" by simp}
- ultimately have "coprime p m" using prime_coprime[OF H, of m] by blast}
- hence ?rhs using p0 by auto}
- moreover
- { assume H: "\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m"
- from prime_factor[OF p0(2)] obtain q where q: "prime q" "q dvd p" by blast
- from prime_ge_2[OF q(1)] have q0: "q > 0" by arith
- from dvd_imp_le[OF q(2)] p0 have qp: "q \<le> p" by arith
- {assume "q = p" hence ?lhs using q(1) by blast}
- moreover
- {assume "q\<noteq>p" with qp have qplt: "q < p" by arith
- from H[rule_format, of q] qplt q0 have "coprime p q" by arith
- with coprime_prime[of p q q] q have False by simp hence ?lhs by blast}
- ultimately have ?lhs by blast}
- ultimately have ?thesis by blast}
- ultimately show ?thesis by (cases"p=0 \<or> p=1", auto)
-qed
-
-lemma finite_number_segment: "card { m. 0 < m \<and> m < n } = n - 1"
-proof-
- have "{ m. 0 < m \<and> m < n } = {1..<n}" by auto
- thus ?thesis by simp
-qed
-
-lemma coprime_mod: assumes n: "n \<noteq> 0" shows "coprime (a mod n) n \<longleftrightarrow> coprime a n"
- using n dvd_mod_iff[of _ n a] by (auto simp add: coprime)
-
-(* Congruences. *)
-
-lemma cong_mod_01[simp,presburger]:
- "[x = y] (mod 0) \<longleftrightarrow> x = y" "[x = y] (mod 1)" "[x = 0] (mod n) \<longleftrightarrow> n dvd x"
- by (simp_all add: modeq_def, presburger)
-
-lemma cong_sub_cases:
- "[x = y] (mod n) \<longleftrightarrow> (if x <= y then [y - x = 0] (mod n) else [x - y = 0] (mod n))"
-apply (auto simp add: nat_mod)
-apply (rule_tac x="q2" in exI)
-apply (rule_tac x="q1" in exI, simp)
-apply (rule_tac x="q2" in exI)
-apply (rule_tac x="q1" in exI, simp)
-apply (rule_tac x="q1" in exI)
-apply (rule_tac x="q2" in exI, simp)
-apply (rule_tac x="q1" in exI)
-apply (rule_tac x="q2" in exI, simp)
-done
-
-lemma cong_mult_lcancel: assumes an: "coprime a n" and axy:"[a * x = a * y] (mod n)"
- shows "[x = y] (mod n)"
-proof-
- {assume "a = 0" with an axy coprime_0'[of n] have ?thesis by (simp add: modeq_def) }
- moreover
- {assume az: "a\<noteq>0"
- {assume xy: "x \<le> y" hence axy': "a*x \<le> a*y" by simp
- with axy cong_sub_cases[of "a*x" "a*y" n] have "[a*(y - x) = 0] (mod n)"
- by (simp only: if_True diff_mult_distrib2)
- hence th: "n dvd a*(y -x)" by simp
- from coprime_divprod[OF th] an have "n dvd y - x"
- by (simp add: coprime_commute)
- hence ?thesis using xy cong_sub_cases[of x y n] by simp}
- moreover
- {assume H: "\<not>x \<le> y" hence xy: "y \<le> x" by arith
- from H az have axy': "\<not> a*x \<le> a*y" by auto
- with axy H cong_sub_cases[of "a*x" "a*y" n] have "[a*(x - y) = 0] (mod n)"
- by (simp only: if_False diff_mult_distrib2)
- hence th: "n dvd a*(x - y)" by simp
- from coprime_divprod[OF th] an have "n dvd x - y"
- by (simp add: coprime_commute)
- hence ?thesis using xy cong_sub_cases[of x y n] by simp}
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma cong_mult_rcancel: assumes an: "coprime a n" and axy:"[x*a = y*a] (mod n)"
- shows "[x = y] (mod n)"
- using cong_mult_lcancel[OF an axy[unfolded mult_commute[of _a]]] .
-
-lemma cong_refl: "[x = x] (mod n)" by (simp add: modeq_def)
-
-lemma eq_imp_cong: "a = b \<Longrightarrow> [a = b] (mod n)" by (simp add: cong_refl)
-
-lemma cong_commute: "[x = y] (mod n) \<longleftrightarrow> [y = x] (mod n)"
- by (auto simp add: modeq_def)
-
-lemma cong_trans[trans]: "[x = y] (mod n) \<Longrightarrow> [y = z] (mod n) \<Longrightarrow> [x = z] (mod n)"
- by (simp add: modeq_def)
-
-lemma cong_add: assumes xx': "[x = x'] (mod n)" and yy':"[y = y'] (mod n)"
- shows "[x + y = x' + y'] (mod n)"
-proof-
- have "(x + y) mod n = (x mod n + y mod n) mod n"
- by (simp add: mod_add_left_eq[of x y n] mod_add_right_eq[of "x mod n" y n])
- also have "\<dots> = (x' mod n + y' mod n) mod n" using xx' yy' modeq_def by simp
- also have "\<dots> = (x' + y') mod n"
- by (simp add: mod_add_left_eq[of x' y' n] mod_add_right_eq[of "x' mod n" y' n])
- finally show ?thesis unfolding modeq_def .
-qed
-
-lemma cong_mult: assumes xx': "[x = x'] (mod n)" and yy':"[y = y'] (mod n)"
- shows "[x * y = x' * y'] (mod n)"
-proof-
- have "(x * y) mod n = (x mod n) * (y mod n) mod n"
- by (simp add: mod_mult_left_eq[of x y n] mod_mult_right_eq[of "x mod n" y n])
- also have "\<dots> = (x' mod n) * (y' mod n) mod n" using xx'[unfolded modeq_def] yy'[unfolded modeq_def] by simp
- also have "\<dots> = (x' * y') mod n"
- by (simp add: mod_mult_left_eq[of x' y' n] mod_mult_right_eq[of "x' mod n" y' n])
- finally show ?thesis unfolding modeq_def .
-qed
-
-lemma cong_exp: "[x = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
- by (induct k, auto simp add: cong_refl cong_mult)
-lemma cong_sub: assumes xx': "[x = x'] (mod n)" and yy': "[y = y'] (mod n)"
- and yx: "y <= x" and yx': "y' <= x'"
- shows "[x - y = x' - y'] (mod n)"
-proof-
- { fix x a x' a' y b y' b'
- have "(x::nat) + a = x' + a' \<Longrightarrow> y + b = y' + b' \<Longrightarrow> y <= x \<Longrightarrow> y' <= x'
- \<Longrightarrow> (x - y) + (a + b') = (x' - y') + (a' + b)" by arith}
- note th = this
- from xx' yy' obtain q1 q2 q1' q2' where q12: "x + n*q1 = x'+n*q2"
- and q12': "y + n*q1' = y'+n*q2'" unfolding nat_mod by blast+
- from th[OF q12 q12' yx yx']
- have "(x - y) + n*(q1 + q2') = (x' - y') + n*(q2 + q1')"
- by (simp add: right_distrib)
- thus ?thesis unfolding nat_mod by blast
-qed
-
-lemma cong_mult_lcancel_eq: assumes an: "coprime a n"
- shows "[a * x = a * y] (mod n) \<longleftrightarrow> [x = y] (mod n)" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume H: "?rhs" from cong_mult[OF cong_refl[of a n] H] show ?lhs .
-next
- assume H: "?lhs" hence H': "[x*a = y*a] (mod n)" by (simp add: mult_commute)
- from cong_mult_rcancel[OF an H'] show ?rhs .
-qed
-
-lemma cong_mult_rcancel_eq: assumes an: "coprime a n"
- shows "[x * a = y * a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
-using cong_mult_lcancel_eq[OF an, of x y] by (simp add: mult_commute)
-
-lemma cong_add_lcancel_eq: "[a + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_add_rcancel_eq: "[x + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_add_rcancel: "[x + a = y + a] (mod n) \<Longrightarrow> [x = y] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_add_lcancel: "[a + x = a + y] (mod n) \<Longrightarrow> [x = y] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_add_lcancel_eq_0: "[a + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_add_rcancel_eq_0: "[x + a = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: nat_mod)
-
-lemma cong_imp_eq: assumes xn: "x < n" and yn: "y < n" and xy: "[x = y] (mod n)"
- shows "x = y"
- using xy[unfolded modeq_def mod_less[OF xn] mod_less[OF yn]] .
-
-lemma cong_divides_modulus: "[x = y] (mod m) \<Longrightarrow> n dvd m ==> [x = y] (mod n)"
- apply (auto simp add: nat_mod dvd_def)
- apply (rule_tac x="k*q1" in exI)
- apply (rule_tac x="k*q2" in exI)
- by simp
-
-lemma cong_0_divides: "[x = 0] (mod n) \<longleftrightarrow> n dvd x" by simp
-
-lemma cong_1_divides:"[x = 1] (mod n) ==> n dvd x - 1"
- apply (cases "x\<le>1", simp_all)
- using cong_sub_cases[of x 1 n] by auto
-
-lemma cong_divides: "[x = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
-apply (auto simp add: nat_mod dvd_def)
-apply (rule_tac x="k + q1 - q2" in exI, simp add: add_mult_distrib2 diff_mult_distrib2)
-apply (rule_tac x="k + q2 - q1" in exI, simp add: add_mult_distrib2 diff_mult_distrib2)
-done
-
-lemma cong_coprime: assumes xy: "[x = y] (mod n)"
- shows "coprime n x \<longleftrightarrow> coprime n y"
-proof-
- {assume "n=0" hence ?thesis using xy by simp}
- moreover
- {assume nz: "n \<noteq> 0"
- have "coprime n x \<longleftrightarrow> coprime (x mod n) n"
- by (simp add: coprime_mod[OF nz, of x] coprime_commute[of n x])
- also have "\<dots> \<longleftrightarrow> coprime (y mod n) n" using xy[unfolded modeq_def] by simp
- also have "\<dots> \<longleftrightarrow> coprime y n" by (simp add: coprime_mod[OF nz, of y])
- finally have ?thesis by (simp add: coprime_commute) }
-ultimately show ?thesis by blast
-qed
-
-lemma cong_mod: "~(n = 0) \<Longrightarrow> [a mod n = a] (mod n)" by (simp add: modeq_def)
-
-lemma mod_mult_cong: "~(a = 0) \<Longrightarrow> ~(b = 0)
- \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
- by (simp add: modeq_def mod_mult2_eq mod_add_left_eq)
-
-lemma cong_mod_mult: "[x = y] (mod n) \<Longrightarrow> m dvd n \<Longrightarrow> [x = y] (mod m)"
- apply (auto simp add: nat_mod dvd_def)
- apply (rule_tac x="k*q1" in exI)
- apply (rule_tac x="k*q2" in exI, simp)
- done
-
-(* Some things when we know more about the order. *)
-
-lemma cong_le: "y <= x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
- using nat_mod_lemma[of x y n]
- apply auto
- apply (simp add: nat_mod)
- apply (rule_tac x="q" in exI)
- apply (rule_tac x="q + q" in exI)
- by (auto simp: algebra_simps)
-
-lemma cong_to_1: "[a = 1] (mod n) \<longleftrightarrow> a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
-proof-
- {assume "n = 0 \<or> n = 1\<or> a = 0 \<or> a = 1" hence ?thesis
- apply (cases "n=0", simp_all add: cong_commute)
- apply (cases "n=1", simp_all add: cong_commute modeq_def)
- apply arith
- by (cases "a=1", simp_all add: modeq_def cong_commute)}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1" and a:"a\<noteq>0" "a \<noteq> 1" hence a': "a \<ge> 1" by simp
- hence ?thesis using cong_le[OF a', of n] by auto }
- ultimately show ?thesis by auto
-qed
-
-(* Some basic theorems about solving congruences. *)
-
-
-lemma cong_solve: assumes an: "coprime a n" shows "\<exists>x. [a * x = b] (mod n)"
-proof-
- {assume "a=0" hence ?thesis using an by (simp add: modeq_def)}
- moreover
- {assume az: "a\<noteq>0"
- from bezout_add_strong[OF az, of n]
- obtain d x y where dxy: "d dvd a" "d dvd n" "a*x = n*y + d" by blast
- from an[unfolded coprime, rule_format, of d] dxy(1,2) have d1: "d = 1" by blast
- hence "a*x*b = (n*y + 1)*b" using dxy(3) by simp
- hence "a*(x*b) = n*(y*b) + b" by algebra
- hence "a*(x*b) mod n = (n*(y*b) + b) mod n" by simp
- hence "a*(x*b) mod n = b mod n" by (simp add: mod_add_left_eq)
- hence "[a*(x*b) = b] (mod n)" unfolding modeq_def .
- hence ?thesis by blast}
-ultimately show ?thesis by blast
-qed
-
-lemma cong_solve_unique: assumes an: "coprime a n" and nz: "n \<noteq> 0"
- shows "\<exists>!x. x < n \<and> [a * x = b] (mod n)"
-proof-
- let ?P = "\<lambda>x. x < n \<and> [a * x = b] (mod n)"
- from cong_solve[OF an] obtain x where x: "[a*x = b] (mod n)" by blast
- let ?x = "x mod n"
- from x have th: "[a * ?x = b] (mod n)"
- by (simp add: modeq_def mod_mult_right_eq[of a x n])
- from mod_less_divisor[ of n x] nz th have Px: "?P ?x" by simp
- {fix y assume Py: "y < n" "[a * y = b] (mod n)"
- from Py(2) th have "[a * y = a*?x] (mod n)" by (simp add: modeq_def)
- hence "[y = ?x] (mod n)" by (simp add: cong_mult_lcancel_eq[OF an])
- with mod_less[OF Py(1)] mod_less_divisor[ of n x] nz
- have "y = ?x" by (simp add: modeq_def)}
- with Px show ?thesis by blast
-qed
-
-lemma cong_solve_unique_nontrivial:
- assumes p: "prime p" and pa: "coprime p a" and x0: "0 < x" and xp: "x < p"
- shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = a] (mod p)"
-proof-
- from p have p1: "p > 1" using prime_ge_2[OF p] by arith
- hence p01: "p \<noteq> 0" "p \<noteq> 1" by arith+
- from pa have ap: "coprime a p" by (simp add: coprime_commute)
- from prime_coprime[OF p, of x] dvd_imp_le[of p x] x0 xp have px:"coprime x p"
- by (auto simp add: coprime_commute)
- from cong_solve_unique[OF px p01(1)]
- obtain y where y: "y < p" "[x * y = a] (mod p)" "\<forall>z. z < p \<and> [x * z = a] (mod p) \<longrightarrow> z = y" by blast
- {assume y0: "y = 0"
- with y(2) have th: "p dvd a" by (simp add: cong_commute[of 0 a p])
- with p coprime_prime[OF pa, of p] have False by simp}
- with y show ?thesis unfolding Ex1_def using neq0_conv by blast
-qed
-lemma cong_unique_inverse_prime:
- assumes p: "prime p" and x0: "0 < x" and xp: "x < p"
- shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = 1] (mod p)"
- using cong_solve_unique_nontrivial[OF p coprime_1[of p] x0 xp] .
-
-(* Forms of the Chinese remainder theorem. *)
-
-lemma cong_chinese:
- assumes ab: "coprime a b" and xya: "[x = y] (mod a)"
- and xyb: "[x = y] (mod b)"
- shows "[x = y] (mod a*b)"
- using ab xya xyb
- by (simp add: cong_sub_cases[of x y a] cong_sub_cases[of x y b]
- cong_sub_cases[of x y "a*b"])
-(cases "x \<le> y", simp_all add: divides_mul[of a _ b])
-
-lemma chinese_remainder_unique:
- assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b\<noteq>0"
- shows "\<exists>!x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
-proof-
- from az bz have abpos: "a*b > 0" by simp
- from chinese_remainder[OF ab az bz] obtain x q1 q2 where
- xq12: "x = m + q1 * a" "x = n + q2 * b" by blast
- let ?w = "x mod (a*b)"
- have wab: "?w < a*b" by (simp add: mod_less_divisor[OF abpos])
- from xq12(1) have "?w mod a = ((m + q1 * a) mod (a*b)) mod a" by simp
- also have "\<dots> = m mod a" apply (simp add: mod_mult2_eq)
- apply (subst mod_add_left_eq)
- by simp
- finally have th1: "[?w = m] (mod a)" by (simp add: modeq_def)
- from xq12(2) have "?w mod b = ((n + q2 * b) mod (a*b)) mod b" by simp
- also have "\<dots> = ((n + q2 * b) mod (b*a)) mod b" by (simp add: mult_commute)
- also have "\<dots> = n mod b" apply (simp add: mod_mult2_eq)
- apply (subst mod_add_left_eq)
- by simp
- finally have th2: "[?w = n] (mod b)" by (simp add: modeq_def)
- {fix y assume H: "y < a*b" "[y = m] (mod a)" "[y = n] (mod b)"
- with th1 th2 have H': "[y = ?w] (mod a)" "[y = ?w] (mod b)"
- by (simp_all add: modeq_def)
- from cong_chinese[OF ab H'] mod_less[OF H(1)] mod_less[OF wab]
- have "y = ?w" by (simp add: modeq_def)}
- with th1 th2 wab show ?thesis by blast
-qed
-
-lemma chinese_remainder_coprime_unique:
- assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b \<noteq> 0"
- and ma: "coprime m a" and nb: "coprime n b"
- shows "\<exists>!x. coprime x (a * b) \<and> x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
-proof-
- let ?P = "\<lambda>x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
- from chinese_remainder_unique[OF ab az bz]
- obtain x where x: "x < a * b" "[x = m] (mod a)" "[x = n] (mod b)"
- "\<forall>y. ?P y \<longrightarrow> y = x" by blast
- from ma nb cong_coprime[OF x(2)] cong_coprime[OF x(3)]
- have "coprime x a" "coprime x b" by (simp_all add: coprime_commute)
- with coprime_mul[of x a b] have "coprime x (a*b)" by simp
- with x show ?thesis by blast
-qed
-
-(* Euler totient function. *)
-
-definition phi_def: "\<phi> n = card { m. 0 < m \<and> m <= n \<and> coprime m n }"
-
-lemma phi_0[simp]: "\<phi> 0 = 0"
- unfolding phi_def by auto
-
-lemma phi_finite[simp]: "finite ({ m. 0 < m \<and> m <= n \<and> coprime m n })"
-proof-
- have "{ m. 0 < m \<and> m <= n \<and> coprime m n } \<subseteq> {0..n}" by auto
- thus ?thesis by (auto intro: finite_subset)
-qed
-
-declare coprime_1[presburger]
-lemma phi_1[simp]: "\<phi> 1 = 1"
-proof-
- {fix m
- have "0 < m \<and> m <= 1 \<and> coprime m 1 \<longleftrightarrow> m = 1" by presburger }
- thus ?thesis by (simp add: phi_def)
-qed
-
-lemma [simp]: "\<phi> (Suc 0) = Suc 0" using phi_1 by simp
-
-lemma phi_alt: "\<phi>(n) = card { m. coprime m n \<and> m < n}"
-proof-
- {assume "n=0 \<or> n=1" hence ?thesis by (cases "n=0", simp_all)}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- {fix m
- from n have "0 < m \<and> m <= n \<and> coprime m n \<longleftrightarrow> coprime m n \<and> m < n"
- apply (cases "m = 0", simp_all)
- apply (cases "m = 1", simp_all)
- apply (cases "m = n", auto)
- done }
- hence ?thesis unfolding phi_def by simp}
- ultimately show ?thesis by auto
-qed
-
-lemma phi_finite_lemma[simp]: "finite {m. coprime m n \<and> m < n}" (is "finite ?S")
- by (rule finite_subset[of "?S" "{0..n}"], auto)
-
-lemma phi_another: assumes n: "n\<noteq>1"
- shows "\<phi> n = card {m. 0 < m \<and> m < n \<and> coprime m n }"
-proof-
- {fix m
- from n have "0 < m \<and> m < n \<and> coprime m n \<longleftrightarrow> coprime m n \<and> m < n"
- by (cases "m=0", auto)}
- thus ?thesis unfolding phi_alt by auto
-qed
-
-lemma phi_limit: "\<phi> n \<le> n"
-proof-
- have "{ m. coprime m n \<and> m < n} \<subseteq> {0 ..<n}" by auto
- with card_mono[of "{0 ..<n}" "{ m. coprime m n \<and> m < n}"]
- show ?thesis unfolding phi_alt by auto
-qed
-
-lemma stupid[simp]: "{m. (0::nat) < m \<and> m < n} = {1..<n}"
- by auto
-
-lemma phi_limit_strong: assumes n: "n\<noteq>1"
- shows "\<phi>(n) \<le> n - 1"
-proof-
- show ?thesis
- unfolding phi_another[OF n] finite_number_segment[of n, symmetric]
- by (rule card_mono[of "{m. 0 < m \<and> m < n}" "{m. 0 < m \<and> m < n \<and> coprime m n}"], auto)
-qed
-
-lemma phi_lowerbound_1_strong: assumes n: "n \<ge> 1"
- shows "\<phi>(n) \<ge> 1"
-proof-
- let ?S = "{ m. 0 < m \<and> m <= n \<and> coprime m n }"
- from card_0_eq[of ?S] n have "\<phi> n \<noteq> 0" unfolding phi_alt
- apply auto
- apply (cases "n=1", simp_all)
- apply (rule exI[where x=1], simp)
- done
- thus ?thesis by arith
-qed
-
-lemma phi_lowerbound_1: "2 <= n ==> 1 <= \<phi>(n)"
- using phi_lowerbound_1_strong[of n] by auto
-
-lemma phi_lowerbound_2: assumes n: "3 <= n" shows "2 <= \<phi> (n)"
-proof-
- let ?S = "{ m. 0 < m \<and> m <= n \<and> coprime m n }"
- have inS: "{1, n - 1} \<subseteq> ?S" using n coprime_plus1[of "n - 1"]
- by (auto simp add: coprime_commute)
- from n have c2: "card {1, n - 1} = 2" by (auto simp add: card_insert_if)
- from card_mono[of ?S "{1, n - 1}", simplified inS c2] show ?thesis
- unfolding phi_def by auto
-qed
-
-lemma phi_prime: "\<phi> n = n - 1 \<and> n\<noteq>0 \<and> n\<noteq>1 \<longleftrightarrow> prime n"
-proof-
- {assume "n=0 \<or> n=1" hence ?thesis by (cases "n=1", simp_all)}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- let ?S = "{m. 0 < m \<and> m < n}"
- have fS: "finite ?S" by simp
- let ?S' = "{m. 0 < m \<and> m < n \<and> coprime m n}"
- have fS':"finite ?S'" apply (rule finite_subset[of ?S' ?S]) by auto
- {assume H: "\<phi> n = n - 1 \<and> n\<noteq>0 \<and> n\<noteq>1"
- hence ceq: "card ?S' = card ?S"
- using n finite_number_segment[of n] phi_another[OF n(2)] by simp
- {fix m assume m: "0 < m" "m < n" "\<not> coprime m n"
- hence mS': "m \<notin> ?S'" by auto
- have "insert m ?S' \<le> ?S" using m by auto
- from m have "card (insert m ?S') \<le> card ?S"
- by - (rule card_mono[of ?S "insert m ?S'"], auto)
- hence False
- unfolding card_insert_disjoint[of "?S'" m, OF fS' mS'] ceq
- by simp }
- hence "\<forall>m. 0 <m \<and> m < n \<longrightarrow> coprime m n" by blast
- hence "prime n" unfolding prime using n by (simp add: coprime_commute)}
- moreover
- {assume H: "prime n"
- hence "?S = ?S'" unfolding prime using n
- by (auto simp add: coprime_commute)
- hence "card ?S = card ?S'" by simp
- hence "\<phi> n = n - 1" unfolding phi_another[OF n(2)] by simp}
- ultimately have ?thesis using n by blast}
- ultimately show ?thesis by (cases "n=0") blast+
-qed
-
-(* Multiplicativity property. *)
-
-lemma phi_multiplicative: assumes ab: "coprime a b"
- shows "\<phi> (a * b) = \<phi> a * \<phi> b"
-proof-
- {assume "a = 0 \<or> b = 0 \<or> a = 1 \<or> b = 1"
- hence ?thesis
- by (cases "a=0", simp, cases "b=0", simp, cases"a=1", simp_all) }
- moreover
- {assume a: "a\<noteq>0" "a\<noteq>1" and b: "b\<noteq>0" "b\<noteq>1"
- hence ab0: "a*b \<noteq> 0" by simp
- let ?S = "\<lambda>k. {m. coprime m k \<and> m < k}"
- let ?f = "\<lambda>x. (x mod a, x mod b)"
- have eq: "?f ` (?S (a*b)) = (?S a \<times> ?S b)"
- proof-
- {fix x assume x:"x \<in> ?S (a*b)"
- hence x': "coprime x (a*b)" "x < a*b" by simp_all
- hence xab: "coprime x a" "coprime x b" by (simp_all add: coprime_mul_eq)
- from mod_less_divisor a b have xab':"x mod a < a" "x mod b < b" by auto
- from xab xab' have "?f x \<in> (?S a \<times> ?S b)"
- by (simp add: coprime_mod[OF a(1)] coprime_mod[OF b(1)])}
- moreover
- {fix x y assume x: "x \<in> ?S a" and y: "y \<in> ?S b"
- hence x': "coprime x a" "x < a" and y': "coprime y b" "y < b" by simp_all
- from chinese_remainder_coprime_unique[OF ab a(1) b(1) x'(1) y'(1)]
- obtain z where z: "coprime z (a * b)" "z < a * b" "[z = x] (mod a)"
- "[z = y] (mod b)" by blast
- hence "(x,y) \<in> ?f ` (?S (a*b))"
- using y'(2) mod_less_divisor[of b y] x'(2) mod_less_divisor[of a x]
- by (auto simp add: image_iff modeq_def)}
- ultimately show ?thesis by auto
- qed
- have finj: "inj_on ?f (?S (a*b))"
- unfolding inj_on_def
- proof(clarify)
- fix x y assume H: "coprime x (a * b)" "x < a * b" "coprime y (a * b)"
- "y < a * b" "x mod a = y mod a" "x mod b = y mod b"
- hence cp: "coprime x a" "coprime x b" "coprime y a" "coprime y b"
- by (simp_all add: coprime_mul_eq)
- from chinese_remainder_coprime_unique[OF ab a(1) b(1) cp(3,4)] H
- show "x = y" unfolding modeq_def by blast
- qed
- from card_image[OF finj, unfolded eq] have ?thesis
- unfolding phi_alt by simp }
- ultimately show ?thesis by auto
-qed
-
-(* Fermat's Little theorem / Fermat-Euler theorem. *)
-
-
-lemma nproduct_mod:
- assumes fS: "finite S" and n0: "n \<noteq> 0"
- shows "[setprod (\<lambda>m. a(m) mod n) S = setprod a S] (mod n)"
-proof-
- have th1:"[1 = 1] (mod n)" by (simp add: modeq_def)
- from cong_mult
- have th3:"\<forall>x1 y1 x2 y2.
- [x1 = x2] (mod n) \<and> [y1 = y2] (mod n) \<longrightarrow> [x1 * y1 = x2 * y2] (mod n)"
- by blast
- have th4:"\<forall>x\<in>S. [a x mod n = a x] (mod n)" by (simp add: modeq_def)
- from fold_image_related[where h="(\<lambda>m. a(m) mod n)" and g=a, OF th1 th3 fS, OF th4] show ?thesis unfolding setprod_def by (simp add: fS)
-qed
-
-lemma nproduct_cmul:
- assumes fS:"finite S"
- shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult})* a(m)) S = c ^ (card S) * setprod a S"
-unfolding setprod_timesf setprod_constant[OF fS, of c] ..
-
-lemma coprime_nproduct:
- assumes fS: "finite S" and Sn: "\<forall>x\<in>S. coprime n (a x)"
- shows "coprime n (setprod a S)"
- using fS unfolding setprod_def by (rule finite_subset_induct)
- (insert Sn, auto simp add: coprime_mul)
-
-lemma fermat_little: assumes an: "coprime a n"
- shows "[a ^ (\<phi> n) = 1] (mod n)"
-proof-
- {assume "n=0" hence ?thesis by simp}
- moreover
- {assume "n=1" hence ?thesis by (simp add: modeq_def)}
- moreover
- {assume nz: "n \<noteq> 0" and n1: "n \<noteq> 1"
- let ?S = "{m. coprime m n \<and> m < n}"
- let ?P = "\<Prod> ?S"
- have fS: "finite ?S" by simp
- have cardfS: "\<phi> n = card ?S" unfolding phi_alt ..
- {fix m assume m: "m \<in> ?S"
- hence "coprime m n" by simp
- with coprime_mul[of n a m] an have "coprime (a*m) n"
- by (simp add: coprime_commute)}
- hence Sn: "\<forall>m\<in> ?S. coprime (a*m) n " by blast
- from coprime_nproduct[OF fS, of n "\<lambda>m. m"] have nP:"coprime ?P n"
- by (simp add: coprime_commute)
- have Paphi: "[?P*a^ (\<phi> n) = ?P*1] (mod n)"
- proof-
- let ?h = "\<lambda>m. m mod n"
- {fix m assume mS: "m\<in> ?S"
- hence "?h m \<in> ?S" by simp}
- hence hS: "?h ` ?S = ?S"by (auto simp add: image_iff)
- have "a\<noteq>0" using an n1 nz apply- apply (rule ccontr) by simp
- hence inj: "inj_on (op * a) ?S" unfolding inj_on_def by simp
-
- have eq0: "fold_image op * (?h \<circ> op * a) 1 {m. coprime m n \<and> m < n} =
- fold_image op * (\<lambda>m. m) 1 {m. coprime m n \<and> m < n}"
- proof (rule fold_image_eq_general[where h="?h o (op * a)"])
- show "finite ?S" using fS .
- next
- {fix y assume yS: "y \<in> ?S" hence y: "coprime y n" "y < n" by simp_all
- from cong_solve_unique[OF an nz, of y]
- obtain x where x:"x < n" "[a * x = y] (mod n)" "\<forall>z. z < n \<and> [a * z = y] (mod n) \<longrightarrow> z=x" by blast
- from cong_coprime[OF x(2)] y(1)
- have xm: "coprime x n" by (simp add: coprime_mul_eq coprime_commute)
- {fix z assume "z \<in> ?S" "(?h \<circ> op * a) z = y"
- hence z: "coprime z n" "z < n" "(?h \<circ> op * a) z = y" by simp_all
- from x(3)[rule_format, of z] z(2,3) have "z=x"
- unfolding modeq_def mod_less[OF y(2)] by simp}
- with xm x(1,2) have "\<exists>!x. x \<in> ?S \<and> (?h \<circ> op * a) x = y"
- unfolding modeq_def mod_less[OF y(2)] by auto }
- thus "\<forall>y\<in>{m. coprime m n \<and> m < n}.
- \<exists>!x. x \<in> {m. coprime m n \<and> m < n} \<and> ((\<lambda>m. m mod n) \<circ> op * a) x = y" by blast
- next
- {fix x assume xS: "x\<in> ?S"
- hence x: "coprime x n" "x < n" by simp_all
- with an have "coprime (a*x) n"
- by (simp add: coprime_mul_eq[of n a x] coprime_commute)
- hence "?h (a*x) \<in> ?S" using nz
- by (simp add: coprime_mod[OF nz] mod_less_divisor)}
- thus " \<forall>x\<in>{m. coprime m n \<and> m < n}.
- ((\<lambda>m. m mod n) \<circ> op * a) x \<in> {m. coprime m n \<and> m < n} \<and>
- ((\<lambda>m. m mod n) \<circ> op * a) x = ((\<lambda>m. m mod n) \<circ> op * a) x" by simp
- qed
- from nproduct_mod[OF fS nz, of "op * a"]
- have "[(setprod (op *a) ?S) = (setprod (?h o (op * a)) ?S)] (mod n)"
- unfolding o_def
- by (simp add: cong_commute)
- also have "[setprod (?h o (op * a)) ?S = ?P ] (mod n)"
- using eq0 fS an by (simp add: setprod_def modeq_def o_def)
- finally show "[?P*a^ (\<phi> n) = ?P*1] (mod n)"
- unfolding cardfS mult_commute[of ?P "a^ (card ?S)"]
- nproduct_cmul[OF fS, symmetric] mult_1_right by simp
- qed
- from cong_mult_lcancel[OF nP Paphi] have ?thesis . }
- ultimately show ?thesis by blast
-qed
-
-lemma fermat_little_prime: assumes p: "prime p" and ap: "coprime a p"
- shows "[a^ (p - 1) = 1] (mod p)"
- using fermat_little[OF ap] p[unfolded phi_prime[symmetric]]
-by simp
-
-
-(* Lucas's theorem. *)
-
-lemma lucas_coprime_lemma:
- assumes m: "m\<noteq>0" and am: "[a^m = 1] (mod n)"
- shows "coprime a n"
-proof-
- {assume "n=1" hence ?thesis by simp}
- moreover
- {assume "n = 0" hence ?thesis using am m exp_eq_1[of a m] by simp}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- from m obtain m' where m': "m = Suc m'" by (cases m, blast+)
- {fix d
- assume d: "d dvd a" "d dvd n"
- from n have n1: "1 < n" by arith
- from am mod_less[OF n1] have am1: "a^m mod n = 1" unfolding modeq_def by simp
- from dvd_mult2[OF d(1), of "a^m'"] have dam:"d dvd a^m" by (simp add: m')
- from dvd_mod_iff[OF d(2), of "a^m"] dam am1
- have "d = 1" by simp }
- hence ?thesis unfolding coprime by auto
- }
- ultimately show ?thesis by blast
-qed
-
-lemma lucas_weak:
- assumes n: "n \<ge> 2" and an:"[a^(n - 1) = 1] (mod n)"
- and nm: "\<forall>m. 0 <m \<and> m < n - 1 \<longrightarrow> \<not> [a^m = 1] (mod n)"
- shows "prime n"
-proof-
- from n have n1: "n \<noteq> 1" "n\<noteq>0" "n - 1 \<noteq> 0" "n - 1 > 0" "n - 1 < n" by arith+
- from lucas_coprime_lemma[OF n1(3) an] have can: "coprime a n" .
- from fermat_little[OF can] have afn: "[a ^ \<phi> n = 1] (mod n)" .
- {assume "\<phi> n \<noteq> n - 1"
- with phi_limit_strong[OF n1(1)] phi_lowerbound_1[OF n]
- have c:"\<phi> n > 0 \<and> \<phi> n < n - 1" by arith
- from nm[rule_format, OF c] afn have False ..}
- hence "\<phi> n = n - 1" by blast
- with phi_prime[of n] n1(1,2) show ?thesis by simp
-qed
-
-lemma nat_exists_least_iff: "(\<exists>(n::nat). P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume ?rhs thus ?lhs by blast
-next
- assume H: ?lhs then obtain n where n: "P n" by blast
- let ?x = "Least P"
- {fix m assume m: "m < ?x"
- from not_less_Least[OF m] have "\<not> P m" .}
- with LeastI_ex[OF H] show ?rhs by blast
-qed
-
-lemma nat_exists_least_iff': "(\<exists>(n::nat). P n) \<longleftrightarrow> (P (Least P) \<and> (\<forall>m < (Least P). \<not> P m))"
- (is "?lhs \<longleftrightarrow> ?rhs")
-proof-
- {assume ?rhs hence ?lhs by blast}
- moreover
- { assume H: ?lhs then obtain n where n: "P n" by blast
- let ?x = "Least P"
- {fix m assume m: "m < ?x"
- from not_less_Least[OF m] have "\<not> P m" .}
- with LeastI_ex[OF H] have ?rhs by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma power_mod: "((x::nat) mod m)^n mod m = x^n mod m"
-proof(induct n)
- case 0 thus ?case by simp
-next
- case (Suc n)
- have "(x mod m)^(Suc n) mod m = ((x mod m) * (((x mod m) ^ n) mod m)) mod m"
- by (simp add: mod_mult_right_eq[symmetric])
- also have "\<dots> = ((x mod m) * (x^n mod m)) mod m" using Suc.hyps by simp
- also have "\<dots> = x^(Suc n) mod m"
- by (simp add: mod_mult_left_eq[symmetric] mod_mult_right_eq[symmetric])
- finally show ?case .
-qed
-
-lemma lucas:
- assumes n2: "n \<ge> 2" and an1: "[a^(n - 1) = 1] (mod n)"
- and pn: "\<forall>p. prime p \<and> p dvd n - 1 \<longrightarrow> \<not> [a^((n - 1) div p) = 1] (mod n)"
- shows "prime n"
-proof-
- from n2 have n01: "n\<noteq>0" "n\<noteq>1" "n - 1 \<noteq> 0" by arith+
- from mod_less_divisor[of n 1] n01 have onen: "1 mod n = 1" by simp
- from lucas_coprime_lemma[OF n01(3) an1] cong_coprime[OF an1]
- have an: "coprime a n" "coprime (a^(n - 1)) n" by (simp_all add: coprime_commute)
- {assume H0: "\<exists>m. 0 < m \<and> m < n - 1 \<and> [a ^ m = 1] (mod n)" (is "EX m. ?P m")
- from H0[unfolded nat_exists_least_iff[of ?P]] obtain m where
- m: "0 < m" "m < n - 1" "[a ^ m = 1] (mod n)" "\<forall>k <m. \<not>?P k" by blast
- {assume nm1: "(n - 1) mod m > 0"
- from mod_less_divisor[OF m(1)] have th0:"(n - 1) mod m < m" by blast
- let ?y = "a^ ((n - 1) div m * m)"
- note mdeq = mod_div_equality[of "(n - 1)" m]
- from coprime_exp[OF an(1)[unfolded coprime_commute[of a n]],
- of "(n - 1) div m * m"]
- have yn: "coprime ?y n" by (simp add: coprime_commute)
- have "?y mod n = (a^m)^((n - 1) div m) mod n"
- by (simp add: algebra_simps power_mult)
- also have "\<dots> = (a^m mod n)^((n - 1) div m) mod n"
- using power_mod[of "a^m" n "(n - 1) div m"] by simp
- also have "\<dots> = 1" using m(3)[unfolded modeq_def onen] onen
- by (simp add: power_Suc0)
- finally have th3: "?y mod n = 1" .
- have th2: "[?y * a ^ ((n - 1) mod m) = ?y* 1] (mod n)"
- using an1[unfolded modeq_def onen] onen
- mod_div_equality[of "(n - 1)" m, symmetric]
- by (simp add:power_add[symmetric] modeq_def th3 del: One_nat_def)
- from cong_mult_lcancel[of ?y n "a^((n - 1) mod m)" 1, OF yn th2]
- have th1: "[a ^ ((n - 1) mod m) = 1] (mod n)" .
- from m(4)[rule_format, OF th0] nm1
- less_trans[OF mod_less_divisor[OF m(1), of "n - 1"] m(2)] th1
- have False by blast }
- hence "(n - 1) mod m = 0" by auto
- then have mn: "m dvd n - 1" by presburger
- then obtain r where r: "n - 1 = m*r" unfolding dvd_def by blast
- from n01 r m(2) have r01: "r\<noteq>0" "r\<noteq>1" by - (rule ccontr, simp)+
- from prime_factor[OF r01(2)] obtain p where p: "prime p" "p dvd r" by blast
- hence th: "prime p \<and> p dvd n - 1" unfolding r by (auto intro: dvd_mult)
- have "(a ^ ((n - 1) div p)) mod n = (a^(m*r div p)) mod n" using r
- by (simp add: power_mult)
- also have "\<dots> = (a^(m*(r div p))) mod n" using div_mult1_eq[of m r p] p(2)[unfolded dvd_eq_mod_eq_0] by simp
- also have "\<dots> = ((a^m)^(r div p)) mod n" by (simp add: power_mult)
- also have "\<dots> = ((a^m mod n)^(r div p)) mod n" using power_mod[of "a^m" "n" "r div p" ] ..
- also have "\<dots> = 1" using m(3) onen by (simp add: modeq_def power_Suc0)
- finally have "[(a ^ ((n - 1) div p))= 1] (mod n)"
- using onen by (simp add: modeq_def)
- with pn[rule_format, OF th] have False by blast}
- hence th: "\<forall>m. 0 < m \<and> m < n - 1 \<longrightarrow> \<not> [a ^ m = 1] (mod n)" by blast
- from lucas_weak[OF n2 an1 th] show ?thesis .
-qed
-
-(* Definition of the order of a number mod n (0 in non-coprime case). *)
-
-definition "ord n a = (if coprime n a then Least (\<lambda>d. d > 0 \<and> [a ^d = 1] (mod n)) else 0)"
-
-(* This has the expected properties. *)
-
-lemma coprime_ord:
- assumes na: "coprime n a"
- shows "ord n a > 0 \<and> [a ^(ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> \<not> [a^ m = 1] (mod n))"
-proof-
- let ?P = "\<lambda>d. 0 < d \<and> [a ^ d = 1] (mod n)"
- from euclid[of a] obtain p where p: "prime p" "a < p" by blast
- from na have o: "ord n a = Least ?P" by (simp add: ord_def)
- {assume "n=0 \<or> n=1" with na have "\<exists>m>0. ?P m" apply auto apply (rule exI[where x=1]) by (simp add: modeq_def)}
- moreover
- {assume "n\<noteq>0 \<and> n\<noteq>1" hence n2:"n \<ge> 2" by arith
- from na have na': "coprime a n" by (simp add: coprime_commute)
- from phi_lowerbound_1[OF n2] fermat_little[OF na']
- have ex: "\<exists>m>0. ?P m" by - (rule exI[where x="\<phi> n"], auto) }
- ultimately have ex: "\<exists>m>0. ?P m" by blast
- from nat_exists_least_iff'[of ?P] ex na show ?thesis
- unfolding o[symmetric] by auto
-qed
-(* With the special value 0 for non-coprime case, it's more convenient. *)
-lemma ord_works:
- "[a ^ (ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> ~[a^ m = 1] (mod n))"
-apply (cases "coprime n a")
-using coprime_ord[of n a]
-by (blast, simp add: ord_def modeq_def)
-
-lemma ord: "[a^(ord n a) = 1] (mod n)" using ord_works by blast
-lemma ord_minimal: "0 < m \<Longrightarrow> m < ord n a \<Longrightarrow> ~[a^m = 1] (mod n)"
- using ord_works by blast
-lemma ord_eq_0: "ord n a = 0 \<longleftrightarrow> ~coprime n a"
-by (cases "coprime n a", simp add: neq0_conv coprime_ord, simp add: neq0_conv ord_def)
-
-lemma ord_divides:
- "[a ^ d = 1] (mod n) \<longleftrightarrow> ord n a dvd d" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume rh: ?rhs
- then obtain k where "d = ord n a * k" unfolding dvd_def by blast
- hence "[a ^ d = (a ^ (ord n a) mod n)^k] (mod n)"
- by (simp add : modeq_def power_mult power_mod)
- also have "[(a ^ (ord n a) mod n)^k = 1] (mod n)"
- using ord[of a n, unfolded modeq_def]
- by (simp add: modeq_def power_mod power_Suc0)
- finally show ?lhs .
-next
- assume lh: ?lhs
- { assume H: "\<not> coprime n a"
- hence o: "ord n a = 0" by (simp add: ord_def)
- {assume d: "d=0" with o H have ?rhs by (simp add: modeq_def)}
- moreover
- {assume d0: "d\<noteq>0" then obtain d' where d': "d = Suc d'" by (cases d, auto)
- from H[unfolded coprime]
- obtain p where p: "p dvd n" "p dvd a" "p \<noteq> 1" by auto
- from lh[unfolded nat_mod]
- obtain q1 q2 where q12:"a ^ d + n * q1 = 1 + n * q2" by blast
- hence "a ^ d + n * q1 - n * q2 = 1" by simp
- with dvd_diff_nat [OF dvd_add [OF divides_rexp[OF p(2), of d'] dvd_mult2[OF p(1), of q1]] dvd_mult2[OF p(1), of q2]] d' have "p dvd 1" by simp
- with p(3) have False by simp
- hence ?rhs ..}
- ultimately have ?rhs by blast}
- moreover
- {assume H: "coprime n a"
- let ?o = "ord n a"
- let ?q = "d div ord n a"
- let ?r = "d mod ord n a"
- from cong_exp[OF ord[of a n], of ?q]
- have eqo: "[(a^?o)^?q = 1] (mod n)" by (simp add: modeq_def power_Suc0)
- from H have onz: "?o \<noteq> 0" by (simp add: ord_eq_0)
- hence op: "?o > 0" by simp
- from mod_div_equality[of d "ord n a"] lh
- have "[a^(?o*?q + ?r) = 1] (mod n)" by (simp add: modeq_def mult_commute)
- hence "[(a^?o)^?q * (a^?r) = 1] (mod n)"
- by (simp add: modeq_def power_mult[symmetric] power_add[symmetric])
- hence th: "[a^?r = 1] (mod n)"
- using eqo mod_mult_left_eq[of "(a^?o)^?q" "a^?r" n]
- apply (simp add: modeq_def del: One_nat_def)
- by (simp add: mod_mult_left_eq[symmetric])
- {assume r: "?r = 0" hence ?rhs by (simp add: dvd_eq_mod_eq_0)}
- moreover
- {assume r: "?r \<noteq> 0"
- with mod_less_divisor[OF op, of d] have r0o:"?r >0 \<and> ?r < ?o" by simp
- from conjunct2[OF ord_works[of a n], rule_format, OF r0o] th
- have ?rhs by blast}
- ultimately have ?rhs by blast}
- ultimately show ?rhs by blast
-qed
-
-lemma order_divides_phi: "coprime n a \<Longrightarrow> ord n a dvd \<phi> n"
-using ord_divides fermat_little coprime_commute by simp
-lemma order_divides_expdiff:
- assumes na: "coprime n a"
- shows "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
-proof-
- {fix n a d e
- assume na: "coprime n a" and ed: "(e::nat) \<le> d"
- hence "\<exists>c. d = e + c" by arith
- then obtain c where c: "d = e + c" by arith
- from na have an: "coprime a n" by (simp add: coprime_commute)
- from coprime_exp[OF na, of e]
- have aen: "coprime (a^e) n" by (simp add: coprime_commute)
- from coprime_exp[OF na, of c]
- have acn: "coprime (a^c) n" by (simp add: coprime_commute)
- have "[a^d = a^e] (mod n) \<longleftrightarrow> [a^(e + c) = a^(e + 0)] (mod n)"
- using c by simp
- also have "\<dots> \<longleftrightarrow> [a^e* a^c = a^e *a^0] (mod n)" by (simp add: power_add)
- also have "\<dots> \<longleftrightarrow> [a ^ c = 1] (mod n)"
- using cong_mult_lcancel_eq[OF aen, of "a^c" "a^0"] by simp
- also have "\<dots> \<longleftrightarrow> ord n a dvd c" by (simp only: ord_divides)
- also have "\<dots> \<longleftrightarrow> [e + c = e + 0] (mod ord n a)"
- using cong_add_lcancel_eq[of e c 0 "ord n a", simplified cong_0_divides]
- by simp
- finally have "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
- using c by simp }
- note th = this
- have "e \<le> d \<or> d \<le> e" by arith
- moreover
- {assume ed: "e \<le> d" from th[OF na ed] have ?thesis .}
- moreover
- {assume de: "d \<le> e"
- from th[OF na de] have ?thesis by (simp add: cong_commute) }
- ultimately show ?thesis by blast
-qed
-
-(* Another trivial primality characterization. *)
-
-lemma prime_prime_factor:
- "prime n \<longleftrightarrow> n \<noteq> 1\<and> (\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n)"
-proof-
- {assume n: "n=0 \<or> n=1" hence ?thesis using prime_0 two_is_prime by auto}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- {assume pn: "prime n"
-
- from pn[unfolded prime_def] have "\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n"
- using n
- apply (cases "n = 0 \<or> n=1",simp)
- by (clarsimp, erule_tac x="p" in allE, auto)}
- moreover
- {assume H: "\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n"
- from n have n1: "n > 1" by arith
- {fix m assume m: "m dvd n" "m\<noteq>1"
- from prime_factor[OF m(2)] obtain p where
- p: "prime p" "p dvd m" by blast
- from dvd_trans[OF p(2) m(1)] p(1) H have "p = n" by blast
- with p(2) have "n dvd m" by simp
- hence "m=n" using dvd_anti_sym[OF m(1)] by simp }
- with n1 have "prime n" unfolding prime_def by auto }
- ultimately have ?thesis using n by blast}
- ultimately show ?thesis by auto
-qed
-
-lemma prime_divisor_sqrt:
- "prime n \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>d. d dvd n \<and> d^2 \<le> n \<longrightarrow> d = 1)"
-proof-
- {assume "n=0 \<or> n=1" hence ?thesis using prime_0 prime_1
- by (auto simp add: nat_power_eq_0_iff)}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- hence np: "n > 1" by arith
- {fix d assume d: "d dvd n" "d^2 \<le> n" and H: "\<forall>m. m dvd n \<longrightarrow> m=1 \<or> m=n"
- from H d have d1n: "d = 1 \<or> d=n" by blast
- {assume dn: "d=n"
- have "n^2 > n*1" using n
- by (simp add: power2_eq_square mult_less_cancel1)
- with dn d(2) have "d=1" by simp}
- with d1n have "d = 1" by blast }
- moreover
- {fix d assume d: "d dvd n" and H: "\<forall>d'. d' dvd n \<and> d'^2 \<le> n \<longrightarrow> d' = 1"
- from d n have "d \<noteq> 0" apply - apply (rule ccontr) by simp
- hence dp: "d > 0" by simp
- from d[unfolded dvd_def] obtain e where e: "n= d*e" by blast
- from n dp e have ep:"e > 0" by simp
- have "d^2 \<le> n \<or> e^2 \<le> n" using dp ep
- by (auto simp add: e power2_eq_square mult_le_cancel_left)
- moreover
- {assume h: "d^2 \<le> n"
- from H[rule_format, of d] h d have "d = 1" by blast}
- moreover
- {assume h: "e^2 \<le> n"
- from e have "e dvd n" unfolding dvd_def by (simp add: mult_commute)
- with H[rule_format, of e] h have "e=1" by simp
- with e have "d = n" by simp}
- ultimately have "d=1 \<or> d=n" by blast}
- ultimately have ?thesis unfolding prime_def using np n(2) by blast}
- ultimately show ?thesis by auto
-qed
-lemma prime_prime_factor_sqrt:
- "prime n \<longleftrightarrow> n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p^2 \<le> n)"
- (is "?lhs \<longleftrightarrow>?rhs")
-proof-
- {assume "n=0 \<or> n=1" hence ?thesis using prime_0 prime_1 by auto}
- moreover
- {assume n: "n\<noteq>0" "n\<noteq>1"
- {assume H: ?lhs
- from H[unfolded prime_divisor_sqrt] n
- have ?rhs apply clarsimp by (erule_tac x="p" in allE, simp add: prime_1)
- }
- moreover
- {assume H: ?rhs
- {fix d assume d: "d dvd n" "d^2 \<le> n" "d\<noteq>1"
- from prime_factor[OF d(3)]
- obtain p where p: "prime p" "p dvd d" by blast
- from n have np: "n > 0" by arith
- from d(1) n have "d \<noteq> 0" by - (rule ccontr, auto)
- hence dp: "d > 0" by arith
- from mult_mono[OF dvd_imp_le[OF p(2) dp] dvd_imp_le[OF p(2) dp]] d(2)
- have "p^2 \<le> n" unfolding power2_eq_square by arith
- with H n p(1) dvd_trans[OF p(2) d(1)] have False by blast}
- with n prime_divisor_sqrt have ?lhs by auto}
- ultimately have ?thesis by blast }
- ultimately show ?thesis by (cases "n=0 \<or> n=1", auto)
-qed
-(* Pocklington theorem. *)
-
-lemma pocklington_lemma:
- assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and an: "[a^ (n - 1) = 1] (mod n)"
- and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
- and pp: "prime p" and pn: "p dvd n"
- shows "[p = 1] (mod q)"
-proof-
- from pp prime_0 prime_1 have p01: "p \<noteq> 0" "p \<noteq> 1" by - (rule ccontr, simp)+
- from cong_1_divides[OF an, unfolded nqr, unfolded dvd_def]
- obtain k where k: "a ^ (q * r) - 1 = n*k" by blast
- from pn[unfolded dvd_def] obtain l where l: "n = p*l" by blast
- {assume a0: "a = 0"
- hence "a^ (n - 1) = 0" using n by (simp add: power_0_left)
- with n an mod_less[of 1 n] have False by (simp add: power_0_left modeq_def)}
- hence a0: "a\<noteq>0" ..
- from n nqr have aqr0: "a ^ (q * r) \<noteq> 0" using a0 by (simp add: neq0_conv)
- hence "(a ^ (q * r) - 1) + 1 = a ^ (q * r)" by simp
- with k l have "a ^ (q * r) = p*l*k + 1" by simp
- hence "a ^ (r * q) + p * 0 = 1 + p * (l*k)" by (simp add: mult_ac)
- hence odq: "ord p (a^r) dvd q"
- unfolding ord_divides[symmetric] power_mult[symmetric] nat_mod by blast
- from odq[unfolded dvd_def] obtain d where d: "q = ord p (a^r) * d" by blast
- {assume d1: "d \<noteq> 1"
- from prime_factor[OF d1] obtain P where P: "prime P" "P dvd d" by blast
- from d dvd_mult[OF P(2), of "ord p (a^r)"] have Pq: "P dvd q" by simp
- from aq P(1) Pq have caP:"coprime (a^ ((n - 1) div P) - 1) n" by blast
- from Pq obtain s where s: "q = P*s" unfolding dvd_def by blast
- have P0: "P \<noteq> 0" using P(1) prime_0 by - (rule ccontr, simp)
- from P(2) obtain t where t: "d = P*t" unfolding dvd_def by blast
- from d s t P0 have s': "ord p (a^r) * t = s" by algebra
- have "ord p (a^r) * t*r = r * ord p (a^r) * t" by algebra
- hence exps: "a^(ord p (a^r) * t*r) = ((a ^ r) ^ ord p (a^r)) ^ t"
- by (simp only: power_mult)
- have "[((a ^ r) ^ ord p (a^r)) ^ t= 1^t] (mod p)"
- by (rule cong_exp, rule ord)
- then have th: "[((a ^ r) ^ ord p (a^r)) ^ t= 1] (mod p)"
- by (simp add: power_Suc0)
- from cong_1_divides[OF th] exps have pd0: "p dvd a^(ord p (a^r) * t*r) - 1" by simp
- from nqr s s' have "(n - 1) div P = ord p (a^r) * t*r" using P0 by simp
- with caP have "coprime (a^(ord p (a^r) * t*r) - 1) n" by simp
- with p01 pn pd0 have False unfolding coprime by auto}
- hence d1: "d = 1" by blast
- hence o: "ord p (a^r) = q" using d by simp
- from pp phi_prime[of p] have phip: " \<phi> p = p - 1" by simp
- {fix d assume d: "d dvd p" "d dvd a" "d \<noteq> 1"
- from pp[unfolded prime_def] d have dp: "d = p" by blast
- from n have n12:"Suc (n - 2) = n - 1" by arith
- with divides_rexp[OF d(2)[unfolded dp], of "n - 2"]
- have th0: "p dvd a ^ (n - 1)" by simp
- from n have n0: "n \<noteq> 0" by simp
- from d(2) an n12[symmetric] have a0: "a \<noteq> 0"
- by - (rule ccontr, simp add: modeq_def)
- have th1: "a^ (n - 1) \<noteq> 0" using n d(2) dp a0 by (auto simp add: neq0_conv)
- from coprime_minus1[OF th1, unfolded coprime]
- dvd_trans[OF pn cong_1_divides[OF an]] th0 d(3) dp
- have False by auto}
- hence cpa: "coprime p a" using coprime by auto
- from coprime_exp[OF cpa, of r] coprime_commute
- have arp: "coprime (a^r) p" by blast
- from fermat_little[OF arp, simplified ord_divides] o phip
- have "q dvd (p - 1)" by simp
- then obtain d where d:"p - 1 = q * d" unfolding dvd_def by blast
- from prime_0 pp have p0:"p \<noteq> 0" by - (rule ccontr, auto)
- from p0 d have "p + q * 0 = 1 + q * d" by simp
- with nat_mod[of p 1 q, symmetric]
- show ?thesis by blast
-qed
-
-lemma pocklington:
- assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q^2"
- and an: "[a^ (n - 1) = 1] (mod n)"
- and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
- shows "prime n"
-unfolding prime_prime_factor_sqrt[of n]
-proof-
- let ?ths = "n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<twosuperior> \<le> n)"
- from n have n01: "n\<noteq>0" "n\<noteq>1" by arith+
- {fix p assume p: "prime p" "p dvd n" "p^2 \<le> n"
- from p(3) sqr have "p^(Suc 1) \<le> q^(Suc 1)" by (simp add: power2_eq_square)
- hence pq: "p \<le> q" unfolding exp_mono_le .
- from pocklington_lemma[OF n nqr an aq p(1,2)] cong_1_divides
- have th: "q dvd p - 1" by blast
- have "p - 1 \<noteq> 0"using prime_ge_2[OF p(1)] by arith
- with divides_ge[OF th] pq have False by arith }
- with n01 show ?ths by blast
-qed
-
-(* Variant for application, to separate the exponentiation. *)
-lemma pocklington_alt:
- assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q^2"
- and an: "[a^ (n - 1) = 1] (mod n)"
- and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> (\<exists>b. [a^((n - 1) div p) = b] (mod n) \<and> coprime (b - 1) n)"
- shows "prime n"
-proof-
- {fix p assume p: "prime p" "p dvd q"
- from aq[rule_format] p obtain b where
- b: "[a^((n - 1) div p) = b] (mod n)" "coprime (b - 1) n" by blast
- {assume a0: "a=0"
- from n an have "[0 = 1] (mod n)" unfolding a0 power_0_left by auto
- hence False using n by (simp add: modeq_def dvd_eq_mod_eq_0[symmetric])}
- hence a0: "a\<noteq> 0" ..
- hence a1: "a \<ge> 1" by arith
- from one_le_power[OF a1] have ath: "1 \<le> a ^ ((n - 1) div p)" .
- {assume b0: "b = 0"
- from p(2) nqr have "(n - 1) mod p = 0"
- apply (simp only: dvd_eq_mod_eq_0[symmetric]) by (rule dvd_mult2, simp)
- with mod_div_equality[of "n - 1" p]
- have "(n - 1) div p * p= n - 1" by auto
- hence eq: "(a^((n - 1) div p))^p = a^(n - 1)"
- by (simp only: power_mult[symmetric])
- from prime_ge_2[OF p(1)] have pS: "Suc (p - 1) = p" by arith
- from b(1) have d: "n dvd a^((n - 1) div p)" unfolding b0 cong_0_divides .
- from divides_rexp[OF d, of "p - 1"] pS eq cong_divides[OF an] n
- have False by simp}
- then have b0: "b \<noteq> 0" ..
- hence b1: "b \<ge> 1" by arith
- from cong_coprime[OF cong_sub[OF b(1) cong_refl[of 1] ath b1]] b(2) nqr
- have "coprime (a ^ ((n - 1) div p) - 1) n" by (simp add: coprime_commute)}
- hence th: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a ^ ((n - 1) div p) - 1) n "
- by blast
- from pocklington[OF n nqr sqr an th] show ?thesis .
-qed
-
-(* Prime factorizations. *)
-
-definition "primefact ps n = (foldr op * ps 1 = n \<and> (\<forall>p\<in> set ps. prime p))"
-
-lemma primefact: assumes n: "n \<noteq> 0"
- shows "\<exists>ps. primefact ps n"
-using n
-proof(induct n rule: nat_less_induct)
- fix n assume H: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>ps. primefact ps m)" and n: "n\<noteq>0"
- let ?ths = "\<exists>ps. primefact ps n"
- {assume "n = 1"
- hence "primefact [] n" by (simp add: primefact_def)
- hence ?ths by blast }
- moreover
- {assume n1: "n \<noteq> 1"
- with n have n2: "n \<ge> 2" by arith
- from prime_factor[OF n1] obtain p where p: "prime p" "p dvd n" by blast
- from p(2) obtain m where m: "n = p*m" unfolding dvd_def by blast
- from n m have m0: "m > 0" "m\<noteq>0" by auto
- from prime_ge_2[OF p(1)] have "1 < p" by arith
- with m0 m have mn: "m < n" by auto
- from H[rule_format, OF mn m0(2)] obtain ps where ps: "primefact ps m" ..
- from ps m p(1) have "primefact (p#ps) n" by (simp add: primefact_def)
- hence ?ths by blast}
- ultimately show ?ths by blast
-qed
-
-lemma primefact_contains:
- assumes pf: "primefact ps n" and p: "prime p" and pn: "p dvd n"
- shows "p \<in> set ps"
- using pf p pn
-proof(induct ps arbitrary: p n)
- case Nil thus ?case by (auto simp add: primefact_def)
-next
- case (Cons q qs p n)
- from Cons.prems[unfolded primefact_def]
- have q: "prime q" "q * foldr op * qs 1 = n" "\<forall>p \<in>set qs. prime p" and p: "prime p" "p dvd q * foldr op * qs 1" by simp_all
- {assume "p dvd q"
- with p(1) q(1) have "p = q" unfolding prime_def by auto
- hence ?case by simp}
- moreover
- { assume h: "p dvd foldr op * qs 1"
- from q(3) have pqs: "primefact qs (foldr op * qs 1)"
- by (simp add: primefact_def)
- from Cons.hyps[OF pqs p(1) h] have ?case by simp}
- ultimately show ?case using prime_divprod[OF p] by blast
-qed
-
-lemma primefact_variant: "primefact ps n \<longleftrightarrow> foldr op * ps 1 = n \<and> list_all prime ps" by (auto simp add: primefact_def list_all_iff)
-
-(* Variant of Lucas theorem. *)
-
-lemma lucas_primefact:
- assumes n: "n \<ge> 2" and an: "[a^(n - 1) = 1] (mod n)"
- and psn: "foldr op * ps 1 = n - 1"
- and psp: "list_all (\<lambda>p. prime p \<and> \<not> [a^((n - 1) div p) = 1] (mod n)) ps"
- shows "prime n"
-proof-
- {fix p assume p: "prime p" "p dvd n - 1" "[a ^ ((n - 1) div p) = 1] (mod n)"
- from psn psp have psn1: "primefact ps (n - 1)"
- by (auto simp add: list_all_iff primefact_variant)
- from p(3) primefact_contains[OF psn1 p(1,2)] psp
- have False by (induct ps, auto)}
- with lucas[OF n an] show ?thesis by blast
-qed
-
-(* Variant of Pocklington theorem. *)
-
-lemma mod_le: assumes n: "n \<noteq> (0::nat)" shows "m mod n \<le> m"
-proof-
- from mod_div_equality[of m n]
- have "\<exists>x. x + m mod n = m" by blast
- then show ?thesis by auto
-qed
-
-
-lemma pocklington_primefact:
- assumes n: "n \<ge> 2" and qrn: "q*r = n - 1" and nq2: "n \<le> q^2"
- and arnb: "(a^r) mod n = b" and psq: "foldr op * ps 1 = q"
- and bqn: "(b^q) mod n = 1"
- and psp: "list_all (\<lambda>p. prime p \<and> coprime ((b^(q div p)) mod n - 1) n) ps"
- shows "prime n"
-proof-
- from bqn psp qrn
- have bqn: "a ^ (n - 1) mod n = 1"
- and psp: "list_all (\<lambda>p. prime p \<and> coprime (a^(r *(q div p)) mod n - 1) n) ps" unfolding arnb[symmetric] power_mod
- by (simp_all add: power_mult[symmetric] algebra_simps)
- from n have n0: "n > 0" by arith
- from mod_div_equality[of "a^(n - 1)" n]
- mod_less_divisor[OF n0, of "a^(n - 1)"]
- have an1: "[a ^ (n - 1) = 1] (mod n)"
- unfolding nat_mod bqn
- apply -
- apply (rule exI[where x="0"])
- apply (rule exI[where x="a^(n - 1) div n"])
- by (simp add: algebra_simps)
- {fix p assume p: "prime p" "p dvd q"
- from psp psq have pfpsq: "primefact ps q"
- by (auto simp add: primefact_variant list_all_iff)
- from psp primefact_contains[OF pfpsq p]
- have p': "coprime (a ^ (r * (q div p)) mod n - 1) n"
- by (simp add: list_all_iff)
- from prime_ge_2[OF p(1)] have p01: "p \<noteq> 0" "p \<noteq> 1" "p =Suc(p - 1)" by arith+
- from div_mult1_eq[of r q p] p(2)
- have eq1: "r* (q div p) = (n - 1) div p"
- unfolding qrn[symmetric] dvd_eq_mod_eq_0 by (simp add: mult_commute)
- have ath: "\<And>a (b::nat). a <= b \<Longrightarrow> a \<noteq> 0 ==> 1 <= a \<and> 1 <= b" by arith
- from n0 have n00: "n \<noteq> 0" by arith
- from mod_le[OF n00]
- have th10: "a ^ ((n - 1) div p) mod n \<le> a ^ ((n - 1) div p)" .
- {assume "a ^ ((n - 1) div p) mod n = 0"
- then obtain s where s: "a ^ ((n - 1) div p) = n*s"
- unfolding mod_eq_0_iff by blast
- hence eq0: "(a^((n - 1) div p))^p = (n*s)^p" by simp
- from qrn[symmetric] have qn1: "q dvd n - 1" unfolding dvd_def by auto
- from dvd_trans[OF p(2) qn1] div_mod_equality'[of "n - 1" p]
- have npp: "(n - 1) div p * p = n - 1" by (simp add: dvd_eq_mod_eq_0)
- with eq0 have "a^ (n - 1) = (n*s)^p"
- by (simp add: power_mult[symmetric])
- hence "1 = (n*s)^(Suc (p - 1)) mod n" using bqn p01 by simp
- also have "\<dots> = 0" by (simp add: mult_assoc)
- finally have False by simp }
- then have th11: "a ^ ((n - 1) div p) mod n \<noteq> 0" by auto
- have th1: "[a ^ ((n - 1) div p) mod n = a ^ ((n - 1) div p)] (mod n)"
- unfolding modeq_def by simp
- from cong_sub[OF th1 cong_refl[of 1]] ath[OF th10 th11]
- have th: "[a ^ ((n - 1) div p) mod n - 1 = a ^ ((n - 1) div p) - 1] (mod n)"
- by blast
- from cong_coprime[OF th] p'[unfolded eq1]
- have "coprime (a ^ ((n - 1) div p) - 1) n" by (simp add: coprime_commute) }
- with pocklington[OF n qrn[symmetric] nq2 an1]
- show ?thesis by blast
-qed
-
-end
--- a/src/HOL/Library/Primes.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,828 +0,0 @@
-(* Title: HOL/Library/Primes.thy
- Author: Amine Chaieb, Christophe Tabacznyj and Lawrence C Paulson
- Copyright 1996 University of Cambridge
-*)
-
-header {* Primality on nat *}
-
-theory Primes
-imports Complex_Main Legacy_GCD
-begin
-
-hide (open) const GCD.gcd GCD.coprime GCD.prime
-
-definition
- coprime :: "nat => nat => bool" where
- "coprime m n \<longleftrightarrow> gcd m n = 1"
-
-definition
- prime :: "nat \<Rightarrow> bool" where
- [code del]: "prime p \<longleftrightarrow> (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"
-
-
-lemma two_is_prime: "prime 2"
- apply (auto simp add: prime_def)
- apply (case_tac m)
- apply (auto dest!: dvd_imp_le)
- done
-
-lemma prime_imp_relprime: "prime p ==> \<not> p dvd n ==> gcd p n = 1"
- apply (auto simp add: prime_def)
- apply (metis One_nat_def gcd_dvd1 gcd_dvd2)
- done
-
-text {*
- This theorem leads immediately to a proof of the uniqueness of
- factorization. If @{term p} divides a product of primes then it is
- one of those primes.
-*}
-
-lemma prime_dvd_mult: "prime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
- by (blast intro: relprime_dvd_mult prime_imp_relprime)
-
-lemma prime_dvd_square: "prime p ==> p dvd m^Suc (Suc 0) ==> p dvd m"
- by (auto dest: prime_dvd_mult)
-
-lemma prime_dvd_power_two: "prime p ==> p dvd m\<twosuperior> ==> p dvd m"
- by (rule prime_dvd_square) (simp_all add: power2_eq_square)
-
-
-lemma exp_eq_1:"(x::nat)^n = 1 \<longleftrightarrow> x = 1 \<or> n = 0"
-by (induct n, auto)
-
-lemma exp_mono_lt: "(x::nat) ^ (Suc n) < y ^ (Suc n) \<longleftrightarrow> x < y"
-by(metis linorder_not_less not_less0 power_le_imp_le_base power_less_imp_less_base)
-
-lemma exp_mono_le: "(x::nat) ^ (Suc n) \<le> y ^ (Suc n) \<longleftrightarrow> x \<le> y"
-by (simp only: linorder_not_less[symmetric] exp_mono_lt)
-
-lemma exp_mono_eq: "(x::nat) ^ Suc n = y ^ Suc n \<longleftrightarrow> x = y"
-using power_inject_base[of x n y] by auto
-
-
-lemma even_square: assumes e: "even (n::nat)" shows "\<exists>x. n ^ 2 = 4*x"
-proof-
- from e have "2 dvd n" by presburger
- then obtain k where k: "n = 2*k" using dvd_def by auto
- hence "n^2 = 4* (k^2)" by (simp add: power2_eq_square)
- thus ?thesis by blast
-qed
-
-lemma odd_square: assumes e: "odd (n::nat)" shows "\<exists>x. n ^ 2 = 4*x + 1"
-proof-
- from e have np: "n > 0" by presburger
- from e have "2 dvd (n - 1)" by presburger
- then obtain k where "n - 1 = 2*k" using dvd_def by auto
- hence k: "n = 2*k + 1" using e by presburger
- hence "n^2 = 4* (k^2 + k) + 1" by algebra
- thus ?thesis by blast
-qed
-
-lemma diff_square: "(x::nat)^2 - y^2 = (x+y)*(x - y)"
-proof-
- have "x \<le> y \<or> y \<le> x" by (rule nat_le_linear)
- moreover
- {assume le: "x \<le> y"
- hence "x ^2 \<le> y^2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
- with le have ?thesis by simp }
- moreover
- {assume le: "y \<le> x"
- hence le2: "y ^2 \<le> x^2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
- from le have "\<exists>z. y + z = x" by presburger
- then obtain z where z: "x = y + z" by blast
- from le2 have "\<exists>z. x^2 = y^2 + z" by presburger
- then obtain z2 where z2: "x^2 = y^2 + z2" by blast
- from z z2 have ?thesis apply simp by algebra }
- ultimately show ?thesis by blast
-qed
-
-text {* Elementary theory of divisibility *}
-lemma divides_ge: "(a::nat) dvd b \<Longrightarrow> b = 0 \<or> a \<le> b" unfolding dvd_def by auto
-lemma divides_antisym: "(x::nat) dvd y \<and> y dvd x \<longleftrightarrow> x = y"
- using dvd_anti_sym[of x y] by auto
-
-lemma divides_add_revr: assumes da: "(d::nat) dvd a" and dab:"d dvd (a + b)"
- shows "d dvd b"
-proof-
- from da obtain k where k:"a = d*k" by (auto simp add: dvd_def)
- from dab obtain k' where k': "a + b = d*k'" by (auto simp add: dvd_def)
- from k k' have "b = d *(k' - k)" by (simp add : diff_mult_distrib2)
- thus ?thesis unfolding dvd_def by blast
-qed
-
-declare nat_mult_dvd_cancel_disj[presburger]
-lemma nat_mult_dvd_cancel_disj'[presburger]:
- "(m\<Colon>nat)*k dvd n*k \<longleftrightarrow> k = 0 \<or> m dvd n" unfolding mult_commute[of m k] mult_commute[of n k] by presburger
-
-lemma divides_mul_l: "(a::nat) dvd b ==> (c * a) dvd (c * b)"
- by presburger
-
-lemma divides_mul_r: "(a::nat) dvd b ==> (a * c) dvd (b * c)" by presburger
-lemma divides_cases: "(n::nat) dvd m ==> m = 0 \<or> m = n \<or> 2 * n <= m"
- by (auto simp add: dvd_def)
-
-lemma divides_div_not: "(x::nat) = (q * n) + r \<Longrightarrow> 0 < r \<Longrightarrow> r < n ==> ~(n dvd x)"
-proof(auto simp add: dvd_def)
- fix k assume H: "0 < r" "r < n" "q * n + r = n * k"
- from H(3) have r: "r = n* (k -q)" by(simp add: diff_mult_distrib2 mult_commute)
- {assume "k - q = 0" with r H(1) have False by simp}
- moreover
- {assume "k - q \<noteq> 0" with r have "r \<ge> n" by auto
- with H(2) have False by simp}
- ultimately show False by blast
-qed
-lemma divides_exp: "(x::nat) dvd y ==> x ^ n dvd y ^ n"
- by (auto simp add: power_mult_distrib dvd_def)
-
-lemma divides_exp2: "n \<noteq> 0 \<Longrightarrow> (x::nat) ^ n dvd y \<Longrightarrow> x dvd y"
- by (induct n ,auto simp add: dvd_def)
-
-fun fact :: "nat \<Rightarrow> nat" where
- "fact 0 = 1"
-| "fact (Suc n) = Suc n * fact n"
-
-lemma fact_lt: "0 < fact n" by(induct n, simp_all)
-lemma fact_le: "fact n \<ge> 1" using fact_lt[of n] by simp
-lemma fact_mono: assumes le: "m \<le> n" shows "fact m \<le> fact n"
-proof-
- from le have "\<exists>i. n = m+i" by presburger
- then obtain i where i: "n = m+i" by blast
- have "fact m \<le> fact (m + i)"
- proof(induct m)
- case 0 thus ?case using fact_le[of i] by simp
- next
- case (Suc m)
- have "fact (Suc m) = Suc m * fact m" by simp
- have th1: "Suc m \<le> Suc (m + i)" by simp
- from mult_le_mono[of "Suc m" "Suc (m+i)" "fact m" "fact (m+i)", OF th1 Suc.hyps]
- show ?case by simp
- qed
- thus ?thesis using i by simp
-qed
-
-lemma divides_fact: "1 <= p \<Longrightarrow> p <= n ==> p dvd fact n"
-proof(induct n arbitrary: p)
- case 0 thus ?case by simp
-next
- case (Suc n p)
- from Suc.prems have "p = Suc n \<or> p \<le> n" by presburger
- moreover
- {assume "p = Suc n" hence ?case by (simp only: fact.simps dvd_triv_left)}
- moreover
- {assume "p \<le> n"
- with Suc.prems(1) Suc.hyps have th: "p dvd fact n" by simp
- from dvd_mult[OF th] have ?case by (simp only: fact.simps) }
- ultimately show ?case by blast
-qed
-
-declare dvd_triv_left[presburger]
-declare dvd_triv_right[presburger]
-lemma divides_rexp:
- "x dvd y \<Longrightarrow> (x::nat) dvd (y^(Suc n))" by (simp add: dvd_mult2[of x y])
-
-text {* Coprimality *}
-
-lemma coprime: "coprime a b \<longleftrightarrow> (\<forall>d. d dvd a \<and> d dvd b \<longleftrightarrow> d = 1)"
-using gcd_unique[of 1 a b, simplified] by (auto simp add: coprime_def)
-lemma coprime_commute: "coprime a b \<longleftrightarrow> coprime b a" by (simp add: coprime_def gcd_commute)
-
-lemma coprime_bezout: "coprime a b \<longleftrightarrow> (\<exists>x y. a * x - b * y = 1 \<or> b * x - a * y = 1)"
-using coprime_def gcd_bezout by auto
-
-lemma coprime_divprod: "d dvd a * b \<Longrightarrow> coprime d a \<Longrightarrow> d dvd b"
- using relprime_dvd_mult_iff[of d a b] by (auto simp add: coprime_def mult_commute)
-
-lemma coprime_1[simp]: "coprime a 1" by (simp add: coprime_def)
-lemma coprime_1'[simp]: "coprime 1 a" by (simp add: coprime_def)
-lemma coprime_Suc0[simp]: "coprime a (Suc 0)" by (simp add: coprime_def)
-lemma coprime_Suc0'[simp]: "coprime (Suc 0) a" by (simp add: coprime_def)
-
-lemma gcd_coprime:
- assumes z: "gcd a b \<noteq> 0" and a: "a = a' * gcd a b" and b: "b = b' * gcd a b"
- shows "coprime a' b'"
-proof-
- let ?g = "gcd a b"
- {assume bz: "a = 0" from b bz z a have ?thesis by (simp add: gcd_zero coprime_def)}
- moreover
- {assume az: "a\<noteq> 0"
- from z have z': "?g > 0" by simp
- from bezout_gcd_strong[OF az, of b]
- obtain x y where xy: "a*x = b*y + ?g" by blast
- from xy a b have "?g * a'*x = ?g * (b'*y + 1)" by (simp add: algebra_simps)
- hence "?g * (a'*x) = ?g * (b'*y + 1)" by (simp add: mult_assoc)
- hence "a'*x = (b'*y + 1)"
- by (simp only: nat_mult_eq_cancel1[OF z'])
- hence "a'*x - b'*y = 1" by simp
- with coprime_bezout[of a' b'] have ?thesis by auto}
- ultimately show ?thesis by blast
-qed
-lemma coprime_0: "coprime d 0 \<longleftrightarrow> d = 1" by (simp add: coprime_def)
-lemma coprime_mul: assumes da: "coprime d a" and db: "coprime d b"
- shows "coprime d (a * b)"
-proof-
- from da have th: "gcd a d = 1" by (simp add: coprime_def gcd_commute)
- from gcd_mult_cancel[of a d b, OF th] db[unfolded coprime_def] have "gcd d (a*b) = 1"
- by (simp add: gcd_commute)
- thus ?thesis unfolding coprime_def .
-qed
-lemma coprime_lmul2: assumes dab: "coprime d (a * b)" shows "coprime d b"
-using prems unfolding coprime_bezout
-apply clarsimp
-apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
-apply (rule_tac x="x" in exI)
-apply (rule_tac x="a*y" in exI)
-apply (simp add: mult_ac)
-apply (rule_tac x="a*x" in exI)
-apply (rule_tac x="y" in exI)
-apply (simp add: mult_ac)
-done
-
-lemma coprime_rmul2: "coprime d (a * b) \<Longrightarrow> coprime d a"
-unfolding coprime_bezout
-apply clarsimp
-apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
-apply (rule_tac x="x" in exI)
-apply (rule_tac x="b*y" in exI)
-apply (simp add: mult_ac)
-apply (rule_tac x="b*x" in exI)
-apply (rule_tac x="y" in exI)
-apply (simp add: mult_ac)
-done
-lemma coprime_mul_eq: "coprime d (a * b) \<longleftrightarrow> coprime d a \<and> coprime d b"
- using coprime_rmul2[of d a b] coprime_lmul2[of d a b] coprime_mul[of d a b]
- by blast
-
-lemma gcd_coprime_exists:
- assumes nz: "gcd a b \<noteq> 0"
- shows "\<exists>a' b'. a = a' * gcd a b \<and> b = b' * gcd a b \<and> coprime a' b'"
-proof-
- let ?g = "gcd a b"
- from gcd_dvd1[of a b] gcd_dvd2[of a b]
- obtain a' b' where "a = ?g*a'" "b = ?g*b'" unfolding dvd_def by blast
- hence ab': "a = a'*?g" "b = b'*?g" by algebra+
- from ab' gcd_coprime[OF nz ab'] show ?thesis by blast
-qed
-
-lemma coprime_exp: "coprime d a ==> coprime d (a^n)"
- by(induct n, simp_all add: coprime_mul)
-
-lemma coprime_exp_imp: "coprime a b ==> coprime (a ^n) (b ^n)"
- by (induct n, simp_all add: coprime_mul_eq coprime_commute coprime_exp)
-lemma coprime_refl[simp]: "coprime n n \<longleftrightarrow> n = 1" by (simp add: coprime_def)
-lemma coprime_plus1[simp]: "coprime (n + 1) n"
- apply (simp add: coprime_bezout)
- apply (rule exI[where x=1])
- apply (rule exI[where x=1])
- apply simp
- done
-lemma coprime_minus1: "n \<noteq> 0 ==> coprime (n - 1) n"
- using coprime_plus1[of "n - 1"] coprime_commute[of "n - 1" n] by auto
-
-lemma bezout_gcd_pow: "\<exists>x y. a ^n * x - b ^ n * y = gcd a b ^ n \<or> b ^ n * x - a ^ n * y = gcd a b ^ n"
-proof-
- let ?g = "gcd a b"
- {assume z: "?g = 0" hence ?thesis
- apply (cases n, simp)
- apply arith
- apply (simp only: z power_0_Suc)
- apply (rule exI[where x=0])
- apply (rule exI[where x=0])
- by simp}
- moreover
- {assume z: "?g \<noteq> 0"
- from gcd_dvd1[of a b] gcd_dvd2[of a b] obtain a' b' where
- ab': "a = a'*?g" "b = b'*?g" unfolding dvd_def by (auto simp add: mult_ac)
- hence ab'': "?g*a' = a" "?g * b' = b" by algebra+
- from coprime_exp_imp[OF gcd_coprime[OF z ab'], unfolded coprime_bezout, of n]
- obtain x y where "a'^n * x - b'^n * y = 1 \<or> b'^n * x - a'^n * y = 1" by blast
- hence "?g^n * (a'^n * x - b'^n * y) = ?g^n \<or> ?g^n*(b'^n * x - a'^n * y) = ?g^n"
- using z by auto
- then have "a^n * x - b^n * y = ?g^n \<or> b^n * x - a^n * y = ?g^n"
- using z ab'' by (simp only: power_mult_distrib[symmetric]
- diff_mult_distrib2 mult_assoc[symmetric])
- hence ?thesis by blast }
- ultimately show ?thesis by blast
-qed
-
-lemma gcd_exp: "gcd (a^n) (b^n) = gcd a b^n"
-proof-
- let ?g = "gcd (a^n) (b^n)"
- let ?gn = "gcd a b^n"
- {fix e assume H: "e dvd a^n" "e dvd b^n"
- from bezout_gcd_pow[of a n b] obtain x y
- where xy: "a ^ n * x - b ^ n * y = ?gn \<or> b ^ n * x - a ^ n * y = ?gn" by blast
- from dvd_diff_nat [OF dvd_mult2[OF H(1), of x] dvd_mult2[OF H(2), of y]]
- dvd_diff_nat [OF dvd_mult2[OF H(2), of x] dvd_mult2[OF H(1), of y]] xy
- have "e dvd ?gn" by (cases "a ^ n * x - b ^ n * y = gcd a b ^ n", simp_all)}
- hence th: "\<forall>e. e dvd a^n \<and> e dvd b^n \<longrightarrow> e dvd ?gn" by blast
- from divides_exp[OF gcd_dvd1[of a b], of n] divides_exp[OF gcd_dvd2[of a b], of n] th
- gcd_unique have "?gn = ?g" by blast thus ?thesis by simp
-qed
-
-lemma coprime_exp2: "coprime (a ^ Suc n) (b^ Suc n) \<longleftrightarrow> coprime a b"
-by (simp only: coprime_def gcd_exp exp_eq_1) simp
-
-lemma division_decomp: assumes dc: "(a::nat) dvd b * c"
- shows "\<exists>b' c'. a = b' * c' \<and> b' dvd b \<and> c' dvd c"
-proof-
- let ?g = "gcd a b"
- {assume "?g = 0" with dc have ?thesis apply (simp add: gcd_zero)
- apply (rule exI[where x="0"])
- by (rule exI[where x="c"], simp)}
- moreover
- {assume z: "?g \<noteq> 0"
- from gcd_coprime_exists[OF z]
- obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
- from gcd_dvd2[of a b] have thb: "?g dvd b" .
- from ab'(1) have "a' dvd a" unfolding dvd_def by blast
- with dc have th0: "a' dvd b*c" using dvd_trans[of a' a "b*c"] by simp
- from dc ab'(1,2) have "a'*?g dvd (b'*?g) *c" by auto
- hence "?g*a' dvd ?g * (b' * c)" by (simp add: mult_assoc)
- with z have th_1: "a' dvd b'*c" by simp
- from coprime_divprod[OF th_1 ab'(3)] have thc: "a' dvd c" .
- from ab' have "a = ?g*a'" by algebra
- with thb thc have ?thesis by blast }
- ultimately show ?thesis by blast
-qed
-
-lemma nat_power_eq_0_iff: "(m::nat) ^ n = 0 \<longleftrightarrow> n \<noteq> 0 \<and> m = 0" by (induct n, auto)
-
-lemma divides_rev: assumes ab: "(a::nat) ^ n dvd b ^n" and n:"n \<noteq> 0" shows "a dvd b"
-proof-
- let ?g = "gcd a b"
- from n obtain m where m: "n = Suc m" by (cases n, simp_all)
- {assume "?g = 0" with ab n have ?thesis by (simp add: gcd_zero)}
- moreover
- {assume z: "?g \<noteq> 0"
- hence zn: "?g ^ n \<noteq> 0" using n by (simp add: neq0_conv)
- from gcd_coprime_exists[OF z]
- obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
- from ab have "(a' * ?g) ^ n dvd (b' * ?g)^n" by (simp add: ab'(1,2)[symmetric])
- hence "?g^n*a'^n dvd ?g^n *b'^n" by (simp only: power_mult_distrib mult_commute)
- with zn z n have th0:"a'^n dvd b'^n" by (auto simp add: nat_power_eq_0_iff)
- have "a' dvd a'^n" by (simp add: m)
- with th0 have "a' dvd b'^n" using dvd_trans[of a' "a'^n" "b'^n"] by simp
- hence th1: "a' dvd b'^m * b'" by (simp add: m mult_commute)
- from coprime_divprod[OF th1 coprime_exp[OF ab'(3), of m]]
- have "a' dvd b'" .
- hence "a'*?g dvd b'*?g" by simp
- with ab'(1,2) have ?thesis by simp }
- ultimately show ?thesis by blast
-qed
-
-lemma divides_mul: assumes mr: "m dvd r" and nr: "n dvd r" and mn:"coprime m n"
- shows "m * n dvd r"
-proof-
- from mr nr obtain m' n' where m': "r = m*m'" and n': "r = n*n'"
- unfolding dvd_def by blast
- from mr n' have "m dvd n'*n" by (simp add: mult_commute)
- hence "m dvd n'" using relprime_dvd_mult_iff[OF mn[unfolded coprime_def]] by simp
- then obtain k where k: "n' = m*k" unfolding dvd_def by blast
- from n' k show ?thesis unfolding dvd_def by auto
-qed
-
-
-text {* A binary form of the Chinese Remainder Theorem. *}
-
-lemma chinese_remainder: assumes ab: "coprime a b" and a:"a \<noteq> 0" and b:"b \<noteq> 0"
- shows "\<exists>x q1 q2. x = u + q1 * a \<and> x = v + q2 * b"
-proof-
- from bezout_add_strong[OF a, of b] bezout_add_strong[OF b, of a]
- obtain d1 x1 y1 d2 x2 y2 where dxy1: "d1 dvd a" "d1 dvd b" "a * x1 = b * y1 + d1"
- and dxy2: "d2 dvd b" "d2 dvd a" "b * x2 = a * y2 + d2" by blast
- from gcd_unique[of 1 a b, simplified ab[unfolded coprime_def], simplified]
- dxy1(1,2) dxy2(1,2) have d12: "d1 = 1" "d2 =1" by auto
- let ?x = "v * a * x1 + u * b * x2"
- let ?q1 = "v * x1 + u * y2"
- let ?q2 = "v * y1 + u * x2"
- from dxy2(3)[simplified d12] dxy1(3)[simplified d12]
- have "?x = u + ?q1 * a" "?x = v + ?q2 * b" by algebra+
- thus ?thesis by blast
-qed
-
-text {* Primality *}
-
-text {* A few useful theorems about primes *}
-
-lemma prime_0[simp]: "~prime 0" by (simp add: prime_def)
-lemma prime_1[simp]: "~ prime 1" by (simp add: prime_def)
-lemma prime_Suc0[simp]: "~ prime (Suc 0)" by (simp add: prime_def)
-
-lemma prime_ge_2: "prime p ==> p \<ge> 2" by (simp add: prime_def)
-lemma prime_factor: assumes n: "n \<noteq> 1" shows "\<exists> p. prime p \<and> p dvd n"
-using n
-proof(induct n rule: nat_less_induct)
- fix n
- assume H: "\<forall>m<n. m \<noteq> 1 \<longrightarrow> (\<exists>p. prime p \<and> p dvd m)" "n \<noteq> 1"
- let ?ths = "\<exists>p. prime p \<and> p dvd n"
- {assume "n=0" hence ?ths using two_is_prime by auto}
- moreover
- {assume nz: "n\<noteq>0"
- {assume "prime n" hence ?ths by - (rule exI[where x="n"], simp)}
- moreover
- {assume n: "\<not> prime n"
- with nz H(2)
- obtain k where k:"k dvd n" "k \<noteq> 1" "k \<noteq> n" by (auto simp add: prime_def)
- from dvd_imp_le[OF k(1)] nz k(3) have kn: "k < n" by simp
- from H(1)[rule_format, OF kn k(2)] obtain p where p: "prime p" "p dvd k" by blast
- from dvd_trans[OF p(2) k(1)] p(1) have ?ths by blast}
- ultimately have ?ths by blast}
- ultimately show ?ths by blast
-qed
-
-lemma prime_factor_lt: assumes p: "prime p" and n: "n \<noteq> 0" and npm:"n = p * m"
- shows "m < n"
-proof-
- {assume "m=0" with n have ?thesis by simp}
- moreover
- {assume m: "m \<noteq> 0"
- from npm have mn: "m dvd n" unfolding dvd_def by auto
- from npm m have "n \<noteq> m" using p by auto
- with dvd_imp_le[OF mn] n have ?thesis by simp}
- ultimately show ?thesis by blast
-qed
-
-lemma euclid_bound: "\<exists>p. prime p \<and> n < p \<and> p <= Suc (fact n)"
-proof-
- have f1: "fact n + 1 \<noteq> 1" using fact_le[of n] by arith
- from prime_factor[OF f1] obtain p where p: "prime p" "p dvd fact n + 1" by blast
- from dvd_imp_le[OF p(2)] have pfn: "p \<le> fact n + 1" by simp
- {assume np: "p \<le> n"
- from p(1) have p1: "p \<ge> 1" by (cases p, simp_all)
- from divides_fact[OF p1 np] have pfn': "p dvd fact n" .
- from divides_add_revr[OF pfn' p(2)] p(1) have False by simp}
- hence "n < p" by arith
- with p(1) pfn show ?thesis by auto
-qed
-
-lemma euclid: "\<exists>p. prime p \<and> p > n" using euclid_bound by auto
-
-lemma primes_infinite: "\<not> (finite {p. prime p})"
-apply(simp add: finite_nat_set_iff_bounded_le)
-apply (metis euclid linorder_not_le)
-done
-
-lemma coprime_prime: assumes ab: "coprime a b"
- shows "~(prime p \<and> p dvd a \<and> p dvd b)"
-proof
- assume "prime p \<and> p dvd a \<and> p dvd b"
- thus False using ab gcd_greatest[of p a b] by (simp add: coprime_def)
-qed
-lemma coprime_prime_eq: "coprime a b \<longleftrightarrow> (\<forall>p. ~(prime p \<and> p dvd a \<and> p dvd b))"
- (is "?lhs = ?rhs")
-proof-
- {assume "?lhs" with coprime_prime have ?rhs by blast}
- moreover
- {assume r: "?rhs" and c: "\<not> ?lhs"
- then obtain g where g: "g\<noteq>1" "g dvd a" "g dvd b" unfolding coprime_def by blast
- from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
- from dvd_trans [OF p(2) g(2)] dvd_trans [OF p(2) g(3)]
- have "p dvd a" "p dvd b" . with p(1) r have False by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma prime_coprime: assumes p: "prime p"
- shows "n = 1 \<or> p dvd n \<or> coprime p n"
-using p prime_imp_relprime[of p n] by (auto simp add: coprime_def)
-
-lemma prime_coprime_strong: "prime p \<Longrightarrow> p dvd n \<or> coprime p n"
- using prime_coprime[of p n] by auto
-
-declare coprime_0[simp]
-
-lemma coprime_0'[simp]: "coprime 0 d \<longleftrightarrow> d = 1" by (simp add: coprime_commute[of 0 d])
-lemma coprime_bezout_strong: assumes ab: "coprime a b" and b: "b \<noteq> 1"
- shows "\<exists>x y. a * x = b * y + 1"
-proof-
- from ab b have az: "a \<noteq> 0" by - (rule ccontr, auto)
- from bezout_gcd_strong[OF az, of b] ab[unfolded coprime_def]
- show ?thesis by auto
-qed
-
-lemma bezout_prime: assumes p: "prime p" and pa: "\<not> p dvd a"
- shows "\<exists>x y. a*x = p*y + 1"
-proof-
- from p have p1: "p \<noteq> 1" using prime_1 by blast
- from prime_coprime[OF p, of a] p1 pa have ap: "coprime a p"
- by (auto simp add: coprime_commute)
- from coprime_bezout_strong[OF ap p1] show ?thesis .
-qed
-lemma prime_divprod: assumes p: "prime p" and pab: "p dvd a*b"
- shows "p dvd a \<or> p dvd b"
-proof-
- {assume "a=1" hence ?thesis using pab by simp }
- moreover
- {assume "p dvd a" hence ?thesis by blast}
- moreover
- {assume pa: "coprime p a" from coprime_divprod[OF pab pa] have ?thesis .. }
- ultimately show ?thesis using prime_coprime[OF p, of a] by blast
-qed
-
-lemma prime_divprod_eq: assumes p: "prime p"
- shows "p dvd a*b \<longleftrightarrow> p dvd a \<or> p dvd b"
-using p prime_divprod dvd_mult dvd_mult2 by auto
-
-lemma prime_divexp: assumes p:"prime p" and px: "p dvd x^n"
- shows "p dvd x"
-using px
-proof(induct n)
- case 0 thus ?case by simp
-next
- case (Suc n)
- hence th: "p dvd x*x^n" by simp
- {assume H: "p dvd x^n"
- from Suc.hyps[OF H] have ?case .}
- with prime_divprod[OF p th] show ?case by blast
-qed
-
-lemma prime_divexp_n: "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p^n dvd x^n"
- using prime_divexp[of p x n] divides_exp[of p x n] by blast
-
-lemma coprime_prime_dvd_ex: assumes xy: "\<not>coprime x y"
- shows "\<exists>p. prime p \<and> p dvd x \<and> p dvd y"
-proof-
- from xy[unfolded coprime_def] obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd y"
- by blast
- from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
- from g(2,3) dvd_trans[OF p(2)] p(1) show ?thesis by auto
-qed
-lemma coprime_sos: assumes xy: "coprime x y"
- shows "coprime (x * y) (x^2 + y^2)"
-proof-
- {assume c: "\<not> coprime (x * y) (x^2 + y^2)"
- from coprime_prime_dvd_ex[OF c] obtain p
- where p: "prime p" "p dvd x*y" "p dvd x^2 + y^2" by blast
- {assume px: "p dvd x"
- from dvd_mult[OF px, of x] p(3)
- obtain r s where "x * x = p * r" and "x^2 + y^2 = p * s"
- by (auto elim!: dvdE)
- then have "y^2 = p * (s - r)"
- by (auto simp add: power2_eq_square diff_mult_distrib2)
- then have "p dvd y^2" ..
- with prime_divexp[OF p(1), of y 2] have py: "p dvd y" .
- from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
- have False by simp }
- moreover
- {assume py: "p dvd y"
- from dvd_mult[OF py, of y] p(3)
- obtain r s where "y * y = p * r" and "x^2 + y^2 = p * s"
- by (auto elim!: dvdE)
- then have "x^2 = p * (s - r)"
- by (auto simp add: power2_eq_square diff_mult_distrib2)
- then have "p dvd x^2" ..
- with prime_divexp[OF p(1), of x 2] have px: "p dvd x" .
- from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
- have False by simp }
- ultimately have False using prime_divprod[OF p(1,2)] by blast}
- thus ?thesis by blast
-qed
-
-lemma distinct_prime_coprime: "prime p \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
- unfolding prime_def coprime_prime_eq by blast
-
-lemma prime_coprime_lt: assumes p: "prime p" and x: "0 < x" and xp: "x < p"
- shows "coprime x p"
-proof-
- {assume c: "\<not> coprime x p"
- then obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd p" unfolding coprime_def by blast
- from dvd_imp_le[OF g(2)] x xp have gp: "g < p" by arith
- from g(2) x have "g \<noteq> 0" by - (rule ccontr, simp)
- with g gp p[unfolded prime_def] have False by blast}
-thus ?thesis by blast
-qed
-
-lemma even_dvd[simp]: "even (n::nat) \<longleftrightarrow> 2 dvd n" by presburger
-lemma prime_odd: "prime p \<Longrightarrow> p = 2 \<or> odd p" unfolding prime_def by auto
-
-
-text {* One property of coprimality is easier to prove via prime factors. *}
-
-lemma prime_divprod_pow:
- assumes p: "prime p" and ab: "coprime a b" and pab: "p^n dvd a * b"
- shows "p^n dvd a \<or> p^n dvd b"
-proof-
- {assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
- apply (cases "n=0", simp_all)
- apply (cases "a=1", simp_all) done}
- moreover
- {assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
- then obtain m where m: "n = Suc m" by (cases n, auto)
- from divides_exp2[OF n pab] have pab': "p dvd a*b" .
- from prime_divprod[OF p pab']
- have "p dvd a \<or> p dvd b" .
- moreover
- {assume pa: "p dvd a"
- have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
- from coprime_prime[OF ab, of p] p pa have "\<not> p dvd b" by blast
- with prime_coprime[OF p, of b] b
- have cpb: "coprime b p" using coprime_commute by blast
- from coprime_exp[OF cpb] have pnb: "coprime (p^n) b"
- by (simp add: coprime_commute)
- from coprime_divprod[OF pnba pnb] have ?thesis by blast }
- moreover
- {assume pb: "p dvd b"
- have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
- from coprime_prime[OF ab, of p] p pb have "\<not> p dvd a" by blast
- with prime_coprime[OF p, of a] a
- have cpb: "coprime a p" using coprime_commute by blast
- from coprime_exp[OF cpb] have pnb: "coprime (p^n) a"
- by (simp add: coprime_commute)
- from coprime_divprod[OF pab pnb] have ?thesis by blast }
- ultimately have ?thesis by blast}
- ultimately show ?thesis by blast
-qed
-
-lemma nat_mult_eq_one: "(n::nat) * m = 1 \<longleftrightarrow> n = 1 \<and> m = 1" (is "?lhs \<longleftrightarrow> ?rhs")
-proof
- assume H: "?lhs"
- hence "n dvd 1" "m dvd 1" unfolding dvd_def by (auto simp add: mult_commute)
- thus ?rhs by auto
-next
- assume ?rhs then show ?lhs by auto
-qed
-
-lemma power_Suc0[simp]: "Suc 0 ^ n = Suc 0"
- unfolding One_nat_def[symmetric] power_one ..
-lemma coprime_pow: assumes ab: "coprime a b" and abcn: "a * b = c ^n"
- shows "\<exists>r s. a = r^n \<and> b = s ^n"
- using ab abcn
-proof(induct c arbitrary: a b rule: nat_less_induct)
- fix c a b
- assume H: "\<forall>m<c. \<forall>a b. coprime a b \<longrightarrow> a * b = m ^ n \<longrightarrow> (\<exists>r s. a = r ^ n \<and> b = s ^ n)" "coprime a b" "a * b = c ^ n"
- let ?ths = "\<exists>r s. a = r^n \<and> b = s ^n"
- {assume n: "n = 0"
- with H(3) power_one have "a*b = 1" by simp
- hence "a = 1 \<and> b = 1" by simp
- hence ?ths
- apply -
- apply (rule exI[where x=1])
- apply (rule exI[where x=1])
- using power_one[of n]
- by simp}
- moreover
- {assume n: "n \<noteq> 0" then obtain m where m: "n = Suc m" by (cases n, auto)
- {assume c: "c = 0"
- with H(3) m H(2) have ?ths apply simp
- apply (cases "a=0", simp_all)
- apply (rule exI[where x="0"], simp)
- apply (rule exI[where x="0"], simp)
- done}
- moreover
- {assume "c=1" with H(3) power_one have "a*b = 1" by simp
- hence "a = 1 \<and> b = 1" by simp
- hence ?ths
- apply -
- apply (rule exI[where x=1])
- apply (rule exI[where x=1])
- using power_one[of n]
- by simp}
- moreover
- {assume c: "c\<noteq>1" "c \<noteq> 0"
- from prime_factor[OF c(1)] obtain p where p: "prime p" "p dvd c" by blast
- from prime_divprod_pow[OF p(1) H(2), unfolded H(3), OF divides_exp[OF p(2), of n]]
- have pnab: "p ^ n dvd a \<or> p^n dvd b" .
- from p(2) obtain l where l: "c = p*l" unfolding dvd_def by blast
- have pn0: "p^n \<noteq> 0" using n prime_ge_2 [OF p(1)] by (simp add: neq0_conv)
- {assume pa: "p^n dvd a"
- then obtain k where k: "a = p^n * k" unfolding dvd_def by blast
- from l have "l dvd c" by auto
- with dvd_imp_le[of l c] c have "l \<le> c" by auto
- moreover {assume "l = c" with l c have "p = 1" by simp with p have False by simp}
- ultimately have lc: "l < c" by arith
- from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" b]]]
- have kb: "coprime k b" by (simp add: coprime_commute)
- from H(3) l k pn0 have kbln: "k * b = l ^ n"
- by (auto simp add: power_mult_distrib)
- from H(1)[rule_format, OF lc kb kbln]
- obtain r s where rs: "k = r ^n" "b = s^n" by blast
- from k rs(1) have "a = (p*r)^n" by (simp add: power_mult_distrib)
- with rs(2) have ?ths by blast }
- moreover
- {assume pb: "p^n dvd b"
- then obtain k where k: "b = p^n * k" unfolding dvd_def by blast
- from l have "l dvd c" by auto
- with dvd_imp_le[of l c] c have "l \<le> c" by auto
- moreover {assume "l = c" with l c have "p = 1" by simp with p have False by simp}
- ultimately have lc: "l < c" by arith
- from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" a]]]
- have kb: "coprime k a" by (simp add: coprime_commute)
- from H(3) l k pn0 n have kbln: "k * a = l ^ n"
- by (simp add: power_mult_distrib mult_commute)
- from H(1)[rule_format, OF lc kb kbln]
- obtain r s where rs: "k = r ^n" "a = s^n" by blast
- from k rs(1) have "b = (p*r)^n" by (simp add: power_mult_distrib)
- with rs(2) have ?ths by blast }
- ultimately have ?ths using pnab by blast}
- ultimately have ?ths by blast}
-ultimately show ?ths by blast
-qed
-
-text {* More useful lemmas. *}
-lemma prime_product:
- assumes "prime (p * q)"
- shows "p = 1 \<or> q = 1"
-proof -
- from assms have
- "1 < p * q" and P: "\<And>m. m dvd p * q \<Longrightarrow> m = 1 \<or> m = p * q"
- unfolding prime_def by auto
- from `1 < p * q` have "p \<noteq> 0" by (cases p) auto
- then have Q: "p = p * q \<longleftrightarrow> q = 1" by auto
- have "p dvd p * q" by simp
- then have "p = 1 \<or> p = p * q" by (rule P)
- then show ?thesis by (simp add: Q)
-qed
-
-lemma prime_exp: "prime (p^n) \<longleftrightarrow> prime p \<and> n = 1"
-proof(induct n)
- case 0 thus ?case by simp
-next
- case (Suc n)
- {assume "p = 0" hence ?case by simp}
- moreover
- {assume "p=1" hence ?case by simp}
- moreover
- {assume p: "p \<noteq> 0" "p\<noteq>1"
- {assume pp: "prime (p^Suc n)"
- hence "p = 1 \<or> p^n = 1" using prime_product[of p "p^n"] by simp
- with p have n: "n = 0"
- by (simp only: exp_eq_1 ) simp
- with pp have "prime p \<and> Suc n = 1" by simp}
- moreover
- {assume n: "prime p \<and> Suc n = 1" hence "prime (p^Suc n)" by simp}
- ultimately have ?case by blast}
- ultimately show ?case by blast
-qed
-
-lemma prime_power_mult:
- assumes p: "prime p" and xy: "x * y = p ^ k"
- shows "\<exists>i j. x = p ^i \<and> y = p^ j"
- using xy
-proof(induct k arbitrary: x y)
- case 0 thus ?case apply simp by (rule exI[where x="0"], simp)
-next
- case (Suc k x y)
- from Suc.prems have pxy: "p dvd x*y" by auto
- from prime_divprod[OF p pxy] have pxyc: "p dvd x \<or> p dvd y" .
- from p have p0: "p \<noteq> 0" by - (rule ccontr, simp)
- {assume px: "p dvd x"
- then obtain d where d: "x = p*d" unfolding dvd_def by blast
- from Suc.prems d have "p*d*y = p^Suc k" by simp
- hence th: "d*y = p^k" using p0 by simp
- from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "y = p^j" by blast
- with d have "x = p^Suc i" by simp
- with ij(2) have ?case by blast}
- moreover
- {assume px: "p dvd y"
- then obtain d where d: "y = p*d" unfolding dvd_def by blast
- from Suc.prems d have "p*d*x = p^Suc k" by (simp add: mult_commute)
- hence th: "d*x = p^k" using p0 by simp
- from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "x = p^j" by blast
- with d have "y = p^Suc i" by simp
- with ij(2) have ?case by blast}
- ultimately show ?case using pxyc by blast
-qed
-
-lemma prime_power_exp: assumes p: "prime p" and n:"n \<noteq> 0"
- and xn: "x^n = p^k" shows "\<exists>i. x = p^i"
- using n xn
-proof(induct n arbitrary: k)
- case 0 thus ?case by simp
-next
- case (Suc n k) hence th: "x*x^n = p^k" by simp
- {assume "n = 0" with prems have ?case apply simp
- by (rule exI[where x="k"],simp)}
- moreover
- {assume n: "n \<noteq> 0"
- from prime_power_mult[OF p th]
- obtain i j where ij: "x = p^i" "x^n = p^j"by blast
- from Suc.hyps[OF n ij(2)] have ?case .}
- ultimately show ?case by blast
-qed
-
-lemma divides_primepow: assumes p: "prime p"
- shows "d dvd p^k \<longleftrightarrow> (\<exists> i. i \<le> k \<and> d = p ^i)"
-proof
- assume H: "d dvd p^k" then obtain e where e: "d*e = p^k"
- unfolding dvd_def apply (auto simp add: mult_commute) by blast
- from prime_power_mult[OF p e] obtain i j where ij: "d = p^i" "e=p^j" by blast
- from prime_ge_2[OF p] have p1: "p > 1" by arith
- from e ij have "p^(i + j) = p^k" by (simp add: power_add)
- hence "i + j = k" using power_inject_exp[of p "i+j" k, OF p1] by simp
- hence "i \<le> k" by arith
- with ij(1) show "\<exists>i\<le>k. d = p ^ i" by blast
-next
- {fix i assume H: "i \<le> k" "d = p^i"
- hence "\<exists>j. k = i + j" by arith
- then obtain j where j: "k = i + j" by blast
- hence "p^k = p^j*d" using H(2) by (simp add: power_add)
- hence "d dvd p^k" unfolding dvd_def by auto}
- thus "\<exists>i\<le>k. d = p ^ i \<Longrightarrow> d dvd p ^ k" by blast
-qed
-
-lemma coprime_divisors: "d dvd a \<Longrightarrow> e dvd b \<Longrightarrow> coprime a b \<Longrightarrow> coprime d e"
- by (auto simp add: dvd_def coprime)
-
-declare power_Suc0[simp del]
-declare even_dvd[simp del]
-
-end
--- a/src/HOL/Library/Sum_Of_Squares.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Sum_Of_Squares.thy Thu Oct 01 07:40:25 2009 +0200
@@ -10,6 +10,7 @@
uses
("positivstellensatz.ML") (* duplicate use!? -- cf. Euclidian_Space.thy *)
("Sum_Of_Squares/sum_of_squares.ML")
+ ("Sum_Of_Squares/positivstellensatz_tools.ML")
("Sum_Of_Squares/sos_wrapper.ML")
begin
@@ -22,113 +23,142 @@
of a minute for one sos call, because sos calls CSDP repeatedly. If
you install CSDP locally, sos calls typically takes only a few
seconds.
+ sos generates a certificate which can be used to repeat the proof
+ without calling an external prover.
*}
text {* setup sos tactic *}
use "positivstellensatz.ML"
+use "Sum_Of_Squares/positivstellensatz_tools.ML"
use "Sum_Of_Squares/sum_of_squares.ML"
use "Sum_Of_Squares/sos_wrapper.ML"
setup SosWrapper.setup
-text {* Tests -- commented since they work only when csdp is installed
- or take too long with remote csdps *}
+text {* Tests *}
-(*
-lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<Longrightarrow> a < 0" by sos
+lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<Longrightarrow> a < 0"
+by (sos_cert "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")
-lemma "a1 >= 0 & a2 >= 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)" by sos
+lemma "a1 >= 0 & a2 >= 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)"
+by (sos_cert "(((A<0 * R<1) + (([~1/2*a1*b2 + ~1/2*a2*b1] * A=0) + (([~1/2*a1*a2 + 1/2*b1*b2] * A=1) + (((A<0 * R<1) * ((R<1/2 * [b2]^2) + (R<1/2 * [b1]^2))) + ((A<=0 * (A<=1 * R<1)) * ((R<1/2 * [b2]^2) + ((R<1/2 * [b1]^2) + ((R<1/2 * [a2]^2) + (R<1/2 * [a1]^2))))))))))")
-lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0" by sos
+lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0"
+by (sos_cert "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")
-lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1 --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1" by sos
+lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1 --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1"
+by (sos_cert "((R<1 + (((A<=3 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=7 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2)))))))")
-lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z" by sos
+lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z"
+by (sos_cert "(((A<0 * R<1) + (((A<0 * R<1) * (R<1/2 * [1]^2)) + (((A<=2 * R<1) * (R<1/2 * [~1*x + y]^2)) + (((A<=1 * R<1) * (R<1/2 * [~1*x + z]^2)) + (((A<=1 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + (((A<=0 * R<1) * (R<1/2 * [~1*y + z]^2)) + (((A<=0 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + ((A<=0 * (A<=1 * (A<=3 * R<1))) * (R<1/2 * [1]^2))))))))))")
-lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3" by sos
+lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3"
+by (sos_cert "(((A<0 * R<1) + (([~3] * A=0) + (R<1 * ((R<2 * [~1/2*x + ~1/2*y + z]^2) + (R<3/2 * [~1*x + y]^2))))))")
-lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)" by sos
+lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)"
+by (sos_cert "(((A<0 * R<1) + (([~4] * A=0) + (R<1 * ((R<3 * [~1/3*w + ~1/3*x + ~1/3*y + z]^2) + ((R<8/3 * [~1/2*w + ~1/2*x + y]^2) + (R<2 * [~1*w + x]^2)))))))")
-lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1" by sos
+lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1"
+by (sos_cert "(((A<0 * R<1) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))")
-lemma "(x::real) > 1 & y > 1 --> x * y > x + y - 1" by sos;
+lemma "(x::real) > 1 & y > 1 --> x * y > x + y - 1"
+by (sos_cert "((((A<0 * A<1) * R<1) + ((A<=0 * R<1) * (R<1 * [1]^2))))")
-lemma "abs(x) <= 1 --> abs(64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x) <= (1::real)" by sos
-*)
+lemma "abs(x) <= 1 --> abs(64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x) <= (1::real)"
+by (sos_cert "((((A<0 * R<1) + ((A<=1 * R<1) * (R<1 * [~8*x^3 + ~4*x^2 + 4*x + 1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=1 * (A<0 * R<1)) * (R<1 * [8*x^3 + ~4*x^2 + ~4*x + 1]^2)))))")
+
(* ------------------------------------------------------------------------- *)
(* One component of denominator in dodecahedral example. *)
(* ------------------------------------------------------------------------- *)
-(*
-lemma "2 <= x & x <= 125841 / 50000 & 2 <= y & y <= 125841 / 50000 & 2 <= z & z <= 125841 / 50000 --> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= (0::real)" by sos;
-*)
+
+lemma "2 <= x & x <= 125841 / 50000 & 2 <= y & y <= 125841 / 50000 & 2 <= z & z <= 125841 / 50000 --> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= (0::real)"
+by (sos_cert "(((A<0 * R<1) + ((R<1 * ((R<5749028157/5000000000 * [~25000/222477*x + ~25000/222477*y + ~25000/222477*z + 1]^2) + ((R<864067/1779816 * [419113/864067*x + 419113/864067*y + z]^2) + ((R<320795/864067 * [419113/1283180*x + y]^2) + (R<1702293/5132720 * [x]^2))))) + (((A<=4 * (A<=5 * R<1)) * (R<3/2 * [1]^2)) + (((A<=3 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<3/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=3 * R<1)) * (R<1/2 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<3/2 * [1]^2)))))))))))))")
+
(* ------------------------------------------------------------------------- *)
(* Over a larger but simpler interval. *)
(* ------------------------------------------------------------------------- *)
-(*
-lemma "(2::real) <= x & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 0 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos
-*)
+
+lemma "(2::real) <= x & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 0 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
+by (sos_cert "((R<1 + ((R<1 * ((R<1 * [~1/6*x + ~1/6*y + ~1/6*z + 1]^2) + ((R<1/18 * [~1/2*x + ~1/2*y + z]^2) + (R<1/24 * [~1*x + y]^2)))) + (((A<0 * R<1) * (R<1/12 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1/6 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1/6 * [1]^2)))))))))))")
+
(* ------------------------------------------------------------------------- *)
(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *)
(* ------------------------------------------------------------------------- *)
-(*
-lemma "2 <= (x::real) & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos
-*)
+
+lemma "2 <= (x::real) & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
+by (sos_cert "(((A<0 * R<1) + (((A<=4 * R<1) * (R<2/3 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1 * [1]^2)) + (((A<=3 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * R<1) * (R<2/3 * [1]^2)) + (((A<=2 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * R<1) * (R<2/3 * [1]^2)) + (((A<=0 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=0 * (A<=3 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<8/3 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))))))))))))))))")
(* ------------------------------------------------------------------------- *)
(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *)
(* ------------------------------------------------------------------------- *)
-(*
-lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x + y <= x^2 + y^2" by sos
+
+lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x + y <= x^2 + y^2"
+by (sos_cert "(((A<0 * R<1) + (([1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))")
-lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x * y * (x + y) <= x^2 + y^2" by sos
+lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x * y * (x + y) <= x^2 + y^2"
+by (sos_cert "(((A<0 * R<1) + (([~1*x + ~1*y + 1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))")
-lemma "0 <= (x::real) & 0 <= y --> x * y * (x + y)^2 <= (x^2 + y^2)^2" by sos
+lemma "0 <= (x::real) & 0 <= y --> x * y * (x + y)^2 <= (x^2 + y^2)^2"
+by (sos_cert "(((A<0 * R<1) + (R<1 * ((R<1 * [~1/2*x^2 + y^2 + ~1/2*x*y]^2) + (R<3/4 * [~1*x^2 + x*y]^2)))))")
-lemma "(0::real) <= a & 0 <= b & 0 <= c & c * (2 * a + b)^3/ 27 <= x \<longrightarrow> c * a^2 * b <= x" by sos
+lemma "(0::real) <= a & 0 <= b & 0 <= c & c * (2 * a + b)^3/ 27 <= x \<longrightarrow> c * a^2 * b <= x"
+by (sos_cert "(((A<0 * R<1) + (((A<=3 * R<1) * (R<1 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/27 * [~1*a + b]^2)) + ((A<=0 * (A<=2 * R<1)) * (R<8/27 * [~1*a + b]^2))))))")
-lemma "(0::real) < x --> 0 < 1 + x + x^2" by sos
+lemma "(0::real) < x --> 0 < 1 + x + x^2"
+by (sos_cert "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")
-lemma "(0::real) <= x --> 0 < 1 + x + x^2" by sos
+lemma "(0::real) <= x --> 0 < 1 + x + x^2"
+by (sos_cert "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")
-lemma "(0::real) < 1 + x^2" by sos
+lemma "(0::real) < 1 + x^2"
+by (sos_cert "((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))")
-lemma "(0::real) <= 1 + 2 * x + x^2" by sos
+lemma "(0::real) <= 1 + 2 * x + x^2"
+by (sos_cert "(((A<0 * R<1) + (R<1 * (R<1 * [x + 1]^2))))")
-lemma "(0::real) < 1 + abs x" by sos
+lemma "(0::real) < 1 + abs x"
+by (sos_cert "((R<1 + (((A<=1 * R<1) * (R<1/2 * [1]^2)) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))")
-lemma "(0::real) < 1 + (1 + x)^2 * (abs x)" by sos
+lemma "(0::real) < 1 + (1 + x)^2 * (abs x)"
+by (sos_cert "(((R<1 + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [x + 1]^2))))) & ((R<1 + (((A<0 * R<1) * (R<1 * [x + 1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))")
-lemma "abs ((1::real) + x^2) = (1::real) + x^2" by sos
-lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0" by sos
+lemma "abs ((1::real) + x^2) = (1::real) + x^2"
+by (sos_cert "(() & (((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<1 * R<1) * (R<1/2 * [1]^2))))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2)))))))")
+lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
+by (sos_cert "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))")
-lemma "(0::real) < x --> 1 < y --> y * x <= z --> x < z" by sos
-lemma "(1::real) < x --> x^2 < y --> 1 < y" by sos
-lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" by sos
-lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" by sos
-lemma "((a::real) * x^2 + b * x + c = 0) --> b^2 >= 4 * a * c" by sos
-lemma "(0::real) <= b & 0 <= c & 0 <= x & 0 <= y & (x^2 = c) & (y^2 = a^2 * c + b) --> a * c <= y * x" by sos
-lemma "abs(x - z) <= e & abs(y - z) <= e & 0 <= u & 0 <= v & (u + v = 1) --> abs((u * x + v * y) - z) <= (e::real)" by sos
-*)
-(*
-lemma "((x::real) - y - 2 * x^4 = 0) & 0 <= x & x <= 2 & 0 <= y & y <= 3 --> y^2 - 7 * y - 12 * x + 17 >= 0" by sos *) (* Too hard?*)
-(*
+lemma "(0::real) < x --> 1 < y --> y * x <= z --> x < z"
+by (sos_cert "((((A<0 * A<1) * R<1) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))")
+lemma "(1::real) < x --> x^2 < y --> 1 < y"
+by (sos_cert "((((A<0 * A<1) * R<1) + ((R<1 * ((R<1/10 * [~2*x + y + 1]^2) + (R<1/10 * [~1*x + y]^2))) + (((A<1 * R<1) * (R<1/2 * [1]^2)) + (((A<0 * R<1) * (R<1 * [x]^2)) + (((A<=0 * R<1) * ((R<1/10 * [x + 1]^2) + (R<1/10 * [x]^2))) + (((A<=0 * (A<1 * R<1)) * (R<1/5 * [1]^2)) + ((A<=0 * (A<0 * R<1)) * (R<1/5 * [1]^2)))))))))")
+lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)"
+by (sos_cert "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")
+lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)"
+by (sos_cert "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")
+lemma "((a::real) * x^2 + b * x + c = 0) --> b^2 >= 4 * a * c"
+by (sos_cert "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))")
+lemma "(0::real) <= b & 0 <= c & 0 <= x & 0 <= y & (x^2 = c) & (y^2 = a^2 * c + b) --> a * c <= y * x"
+by (sos_cert "(((A<0 * (A<0 * R<1)) + (((A<=2 * (A<=3 * (A<0 * R<1))) * (R<2 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2)))))")
+lemma "abs(x - z) <= e & abs(y - z) <= e & 0 <= u & 0 <= v & (u + v = 1) --> abs((u * x + v * y) - z) <= (e::real)"
+by (sos_cert "((((A<0 * R<1) + (((A<=3 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2))))) & ((((A<0 * A<1) * R<1) + (((A<=3 * (A<=5 * (A<0 * R<1))) * (R<1 * [1]^2)) + ((A<=1 * (A<=4 * (A<0 * R<1))) * (R<1 * [1]^2))))))")
+
+
+(* lemma "((x::real) - y - 2 * x^4 = 0) & 0 <= x & x <= 2 & 0 <= y & y <= 3 --> y^2 - 7 * y - 12 * x + 17 >= 0" by sos *) (* Too hard?*)
+
lemma "(0::real) <= x --> (1 + x + x^2)/(1 + x^2) <= 1 + x"
-apply sos
-done
+by (sos_cert "(((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2))))))")
lemma "(0::real) <= x --> 1 - x <= 1 / (1 + x + x^2)"
-apply sos
-done
+by (sos_cert "(((R<1 + (([~4/3] * A=0) + ((R<1 * ((R<1/3 * [3/2*x + 1]^2) + (R<7/12 * [x]^2))) + ((A<=0 * R<1) * (R<1/3 * [1]^2)))))) & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))))")
lemma "(x::real) <= 1 / 2 --> - x - 2 * x^2 <= - x / (1 - x)"
-apply sos
-done
+by (sos_cert "((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2))))")
-lemma "4*r^2 = p^2 - 4*q & r >= (0::real) & x^2 + p*x + q = 0 --> 2*(x::real) = - p + 2*r | 2*x = -p - 2*r" by sos
-*)
+lemma "4*r^2 = p^2 - 4*q & r >= (0::real) & x^2 + p*x + q = 0 --> 2*(x::real) = - p + 2*r | 2*x = -p - 2*r"
+by (sos_cert "((((((A<0 * A<1) * R<1) + ([~4] * A=0))) & ((((A<0 * A<1) * R<1) + ([4] * A=0)))) & (((((A<0 * A<1) * R<1) + ([4] * A=0))) & ((((A<0 * A<1) * R<1) + ([~4] * A=0)))))")
end
--- a/src/HOL/Library/Sum_Of_Squares/neos_csdp_client Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Sum_Of_Squares/neos_csdp_client Thu Oct 01 07:40:25 2009 +0200
@@ -9,9 +9,10 @@
NEOS_HOST="neos.mcs.anl.gov"
NEOS_PORT=3332
+neos=xmlrpclib.Server("http://%s:%d" % (NEOS_HOST, NEOS_PORT))
+
jobNumber = 0
password = ""
-neos = None
inputfile = None
outputfile = None
# interrupt handler
@@ -34,8 +35,6 @@
sys.stderr.write("Usage: neos_csdp_client <input_filename> <output_filename>\n")
sys.exit(19)
-neos=xmlrpclib.Server("http://%s:%d" % (NEOS_HOST, NEOS_PORT))
-
xml_pre = "<document>\n<category>sdp</category>\n<solver>csdp</solver>\n<inputMethod>SPARSE_SDPA</inputMethod>\n<dat><![CDATA["
xml_post = "]]></dat>\n</document>\n"
xml = xml_pre
@@ -74,9 +73,9 @@
if len(result) > 1:
solution = result[1].strip()
if solution != "":
- output = open(sys.argv[2],"w")
- output.write(solution)
- output.close()
+ outputfile = open(sys.argv[2],"w")
+ outputfile.write(solution)
+ outputfile.close()
# extract return code
p = re.compile(r"^Error: Command exited with non-zero status (\d+)$", re.MULTILINE)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Sum_Of_Squares/positivstellensatz_tools.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,158 @@
+(* Title: positivstellensatz_tools.ML
+ Author: Philipp Meyer, TU Muenchen
+
+Functions for generating a certificate from a positivstellensatz and vice versa
+*)
+
+signature POSITIVSTELLENSATZ_TOOLS =
+sig
+ val pss_tree_to_cert : RealArith.pss_tree -> string
+
+ val cert_to_pss_tree : Proof.context -> string -> RealArith.pss_tree
+
+end
+
+
+structure PositivstellensatzTools : POSITIVSTELLENSATZ_TOOLS =
+struct
+
+open RealArith FuncUtil
+
+(*** certificate generation ***)
+
+fun string_of_rat r =
+ let
+ val (nom, den) = Rat.quotient_of_rat r
+ in
+ if den = 1 then string_of_int nom
+ else string_of_int nom ^ "/" ^ string_of_int den
+ end
+
+(* map polynomials to strings *)
+
+fun string_of_varpow x k =
+ let
+ val term = term_of x
+ val name = case term of
+ Free (n, _) => n
+ | _ => error "Term in monomial not free variable"
+ in
+ if k = 1 then name else name ^ "^" ^ string_of_int k
+ end
+
+fun string_of_monomial m =
+ if Ctermfunc.is_undefined m then "1"
+ else
+ let
+ val m' = dest_monomial m
+ val vps = fold_rev (fn (x,k) => cons (string_of_varpow x k)) m' []
+ in foldr1 (fn (s, t) => s ^ "*" ^ t) vps
+ end
+
+fun string_of_cmonomial (m,c) =
+ if Ctermfunc.is_undefined m then string_of_rat c
+ else if c = Rat.one then string_of_monomial m
+ else (string_of_rat c) ^ "*" ^ (string_of_monomial m);
+
+fun string_of_poly p =
+ if Monomialfunc.is_undefined p then "0"
+ else
+ let
+ val cms = map string_of_cmonomial
+ (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p))
+ in foldr1 (fn (t1, t2) => t1 ^ " + " ^ t2) cms
+ end;
+
+fun pss_to_cert (Axiom_eq i) = "A=" ^ string_of_int i
+ | pss_to_cert (Axiom_le i) = "A<=" ^ string_of_int i
+ | pss_to_cert (Axiom_lt i) = "A<" ^ string_of_int i
+ | pss_to_cert (Rational_eq r) = "R=" ^ string_of_rat r
+ | pss_to_cert (Rational_le r) = "R<=" ^ string_of_rat r
+ | pss_to_cert (Rational_lt r) = "R<" ^ string_of_rat r
+ | pss_to_cert (Square p) = "[" ^ string_of_poly p ^ "]^2"
+ | pss_to_cert (Eqmul (p, pss)) = "([" ^ string_of_poly p ^ "] * " ^ pss_to_cert pss ^ ")"
+ | pss_to_cert (Sum (pss1, pss2)) = "(" ^ pss_to_cert pss1 ^ " + " ^ pss_to_cert pss2 ^ ")"
+ | pss_to_cert (Product (pss1, pss2)) = "(" ^ pss_to_cert pss1 ^ " * " ^ pss_to_cert pss2 ^ ")"
+
+fun pss_tree_to_cert Trivial = "()"
+ | pss_tree_to_cert (Cert pss) = "(" ^ pss_to_cert pss ^ ")"
+ | pss_tree_to_cert (Branch (t1, t2)) = "(" ^ pss_tree_to_cert t1 ^ " & " ^ pss_tree_to_cert t2 ^ ")"
+
+(*** certificate parsing ***)
+
+(* basic parser *)
+
+val str = Scan.this_string
+
+val number = Scan.repeat1 (Scan.one Symbol.is_ascii_digit >>
+ (fn s => ord s - ord "0")) >>
+ foldl1 (fn (n, d) => n * 10 + d)
+
+val nat = number
+val int = Scan.optional (str "~" >> K ~1) 1 -- nat >> op *;
+val rat = int --| str "/" -- int >> Rat.rat_of_quotient
+val rat_int = rat || int >> Rat.rat_of_int
+
+(* polynomial parser *)
+
+fun repeat_sep s f = f ::: Scan.repeat (str s |-- f)
+
+val parse_id = Scan.one Symbol.is_letter ::: Scan.many Symbol.is_letdig >> implode
+
+fun parse_varpow ctxt = parse_id -- Scan.optional (str "^" |-- nat) 1 >>
+ (fn (x, k) => (cterm_of (Context.theory_of_proof ctxt) (Free (x, @{typ real})), k))
+
+fun parse_monomial ctxt = repeat_sep "*" (parse_varpow ctxt) >>
+ foldl (uncurry Ctermfunc.update) Ctermfunc.undefined
+
+fun parse_cmonomial ctxt =
+ rat_int --| str "*" -- (parse_monomial ctxt) >> swap ||
+ (parse_monomial ctxt) >> (fn m => (m, Rat.one)) ||
+ rat_int >> (fn r => (Ctermfunc.undefined, r))
+
+fun parse_poly ctxt = repeat_sep "+" (parse_cmonomial ctxt) >>
+ foldl (uncurry Monomialfunc.update) Monomialfunc.undefined
+
+(* positivstellensatz parser *)
+
+val parse_axiom =
+ (str "A=" |-- int >> Axiom_eq) ||
+ (str "A<=" |-- int >> Axiom_le) ||
+ (str "A<" |-- int >> Axiom_lt)
+
+val parse_rational =
+ (str "R=" |-- rat_int >> Rational_eq) ||
+ (str "R<=" |-- rat_int >> Rational_le) ||
+ (str "R<" |-- rat_int >> Rational_lt)
+
+fun parse_cert ctxt input =
+ let
+ val pc = parse_cert ctxt
+ val pp = parse_poly ctxt
+ in
+ (parse_axiom ||
+ parse_rational ||
+ str "[" |-- pp --| str "]^2" >> Square ||
+ str "([" |-- pp --| str "]*" -- pc --| str ")" >> Eqmul ||
+ str "(" |-- pc --| str "*" -- pc --| str ")" >> Product ||
+ str "(" |-- pc --| str "+" -- pc --| str ")" >> Sum) input
+ end
+
+fun parse_cert_tree ctxt input =
+ let
+ val pc = parse_cert ctxt
+ val pt = parse_cert_tree ctxt
+ in
+ (str "()" >> K Trivial ||
+ str "(" |-- pc --| str ")" >> Cert ||
+ str "(" |-- pt --| str "&" -- pt --| str ")" >> Branch) input
+ end
+
+(* scanner *)
+
+fun cert_to_pss_tree ctxt input_str = Symbol.scanner "bad certificate" (parse_cert_tree ctxt)
+ (filter_out Symbol.is_blank (Symbol.explode input_str))
+
+end
+
+
--- a/src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML Thu Oct 01 07:40:25 2009 +0200
@@ -10,7 +10,7 @@
datatype prover_result = Success | Failure | Error
val setup: theory -> theory
- val destdir: string ref
+ val destdir: string Unsynchronized.ref
val get_prover_name: unit -> string
val set_prover_name: string -> unit
end
@@ -30,7 +30,7 @@
(*** calling provers ***)
-val destdir = ref ""
+val destdir = Unsynchronized.ref ""
fun filename dir name =
let
@@ -113,7 +113,7 @@
(* default prover *)
-val prover_name = ref "remote_csdp"
+val prover_name = Unsynchronized.ref "remote_csdp"
fun get_prover_name () = CRITICAL (fn () => ! prover_name);
fun set_prover_name str = CRITICAL (fn () => prover_name := str);
@@ -136,13 +136,32 @@
run_solver name (Path.explode cmd) find_failure
end
+(* certificate output *)
+
+fun output_line cert = "To repeat this proof with a certifiate use this command:\n" ^
+ (Markup.markup Markup.sendback) ("by (sos_cert \"" ^ cert ^ "\")")
+
+val print_cert = Output.writeln o output_line o PositivstellensatzTools.pss_tree_to_cert
+
(* setup tactic *)
-fun sos_solver name = (SIMPLE_METHOD' o (Sos.sos_tac (call_solver name)))
+fun parse_cert (input as (ctxt, _)) =
+ (Scan.lift OuterParse.string >>
+ PositivstellensatzTools.cert_to_pss_tree (Context.proof_of ctxt)) input
+
+fun sos_solver print method = (SIMPLE_METHOD' o (Sos.sos_tac print method))
-val sos_method = Scan.option (Scan.lift OuterParse.xname) >> sos_solver
+val sos_method =
+ Scan.lift (Scan.option OuterParse.xname) >> (fn n => Sos.Prover (call_solver n)) >>
+ sos_solver print_cert
-val setup = Method.setup @{binding sos} sos_method
- "Prove universal problems over the reals using sums of squares"
+val sos_cert_method =
+ parse_cert >> Sos.Certificate >> sos_solver ignore
+
+val setup =
+ Method.setup @{binding sos} sos_method
+ "Prove universal problems over the reals using sums of squares"
+ #> Method.setup @{binding sos_cert} sos_cert_method
+ "Prove universal problems over the reals using sums of squares with certificates"
end
--- a/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML Thu Oct 01 07:40:25 2009 +0200
@@ -8,9 +8,14 @@
signature SOS =
sig
- val sos_tac : (string -> string) -> Proof.context -> int -> Tactical.tactic
+ datatype proof_method =
+ Certificate of RealArith.pss_tree
+ | Prover of (string -> string)
- val debugging : bool ref;
+ val sos_tac : (RealArith.pss_tree -> unit) ->
+ proof_method -> Proof.context -> int -> tactic
+
+ val debugging : bool Unsynchronized.ref;
exception Failure of string;
end
@@ -18,6 +23,8 @@
structure Sos : SOS =
struct
+open FuncUtil;
+
val rat_0 = Rat.zero;
val rat_1 = Rat.one;
val rat_2 = Rat.two;
@@ -51,7 +58,7 @@
val pow2 = rat_pow rat_2;
val pow10 = rat_pow rat_10;
-val debugging = ref false;
+val debugging = Unsynchronized.ref false;
exception Sanity;
@@ -59,6 +66,10 @@
exception Failure of string;
+datatype proof_method =
+ Certificate of RealArith.pss_tree
+ | Prover of (string -> string)
+
(* Turn a rational into a decimal string with d sig digits. *)
local
@@ -93,23 +104,11 @@
(* The main types. *)
-fun strict_ord ord (x,y) = case ord (x,y) of LESS => LESS | _ => GREATER
-
-structure Intpairfunc = FuncFun(type key = int*int val ord = prod_ord int_ord int_ord);
-
type vector = int* Rat.rat Intfunc.T;
type matrix = (int*int)*(Rat.rat Intpairfunc.T);
-type monomial = int Ctermfunc.T;
-
-val cterm_ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t))
- fun monomial_ord (m1,m2) = list_ord (prod_ord cterm_ord int_ord) (Ctermfunc.graph m1, Ctermfunc.graph m2)
-structure Monomialfunc = FuncFun(type key = monomial val ord = monomial_ord)
-
-type poly = Rat.rat Monomialfunc.T;
-
- fun iszero (k,r) = r =/ rat_0;
+fun iszero (k,r) = r =/ rat_0;
fun fold_rev2 f l1 l2 b =
case (l1,l2) of
@@ -346,11 +345,6 @@
sort humanorder_varpow (Ctermfunc.graph m2))
end;
-fun fold1 f l = case l of
- [] => error "fold1"
- | [x] => x
- | (h::t) => f h (fold1 f t);
-
(* Conversions to strings. *)
fun string_of_vector min_size max_size (v:vector) =
@@ -359,7 +353,7 @@
let
val n = max min_size (min n_raw max_size)
val xs = map (Rat.string_of_rat o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n)
- in "[" ^ fold1 (fn s => fn t => s ^ ", " ^ t) xs ^
+ in "[" ^ foldr1 (fn (s, t) => s ^ ", " ^ t) xs ^
(if n_raw > max_size then ", ...]" else "]")
end
end;
@@ -370,7 +364,7 @@
val i = min max_size i_raw
val j = min max_size j_raw
val rstr = map (fn k => string_of_vector j j (row k m)) (1 upto i)
- in "["^ fold1 (fn s => fn t => s^";\n "^t) rstr ^
+ in "["^ foldr1 (fn (s, t) => s^";\n "^t) rstr ^
(if j > max_size then "\n ...]" else "]")
end;
@@ -396,7 +390,7 @@
if Ctermfunc.is_undefined m then "1" else
let val vps = fold_rev (fn (x,k) => fn a => string_of_varpow x k :: a)
(sort humanorder_varpow (Ctermfunc.graph m)) []
- in fold1 (fn s => fn t => s^"*"^t) vps
+ in foldr1 (fn (s, t) => s^"*"^t) vps
end;
fun string_of_cmonomial (c,m) =
@@ -404,7 +398,7 @@
else if c =/ rat_1 then string_of_monomial m
else Rat.string_of_rat c ^ "*" ^ string_of_monomial m;;
-fun string_of_poly (p:poly) =
+fun string_of_poly p =
if Monomialfunc.is_undefined p then "<<0>>" else
let
val cms = sort (fn ((m1,_),(m2,_)) => humanorder_monomial m1 m2) (Monomialfunc.graph p)
@@ -478,10 +472,9 @@
let
val n = dim v
val strs = map (decimalize 20 o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n)
- in fold1 (fn x => fn y => x ^ " " ^ y) strs ^ "\n"
+ in foldr1 (fn (x, y) => x ^ " " ^ y) strs ^ "\n"
end;
-fun increasing f ord (x,y) = ord (f x, f y);
fun triple_int_ord ((a,b,c),(a',b',c')) =
prod_ord int_ord (prod_ord int_ord int_ord)
((a,(b,c)),(a',(b',c')));
@@ -989,7 +982,7 @@
let val alts =
map (fn k => let val oths = enumerate_monomials (d - k) (tl vars)
in map (fn ks => if k = 0 then ks else Ctermfunc.update (hd vars, k) ks) oths end) (0 upto d)
- in fold1 (curry op @) alts
+ in foldr1 op @ alts
end;
(* Enumerate products of distinct input polys with degree <= d. *)
@@ -1040,7 +1033,7 @@
in
string_of_int m ^ "\n" ^
string_of_int nblocks ^ "\n" ^
- (fold1 (fn s => fn t => s^" "^t) (map string_of_int blocksizes)) ^
+ (foldr1 (fn (s, t) => s^" "^t) (map string_of_int blocksizes)) ^
"\n" ^
sdpa_of_vector obj ^
fold_rev2 (fn k => fn m => fn a => sdpa_of_blockdiagonal (k - 1) m ^ a)
@@ -1080,11 +1073,6 @@
fun tryfind f = tryfind_with "tryfind" f
end
-(*
-fun tryfind f [] = error "tryfind"
- | tryfind f (x::xs) = (f x handle ERROR _ => tryfind f xs);
-*)
-
(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
@@ -1210,61 +1198,17 @@
fun deepen f n =
(writeln ("Searching with depth limit " ^ string_of_int n) ; (f n handle Failure s => (writeln ("failed with message: " ^ s) ; deepen f (n+1))))
-(* The ordering so we can create canonical HOL polynomials. *)
-fun dest_monomial mon = sort (increasing fst cterm_ord) (Ctermfunc.graph mon);
-
-fun monomial_order (m1,m2) =
- if Ctermfunc.is_undefined m2 then LESS
- else if Ctermfunc.is_undefined m1 then GREATER
- else
- let val mon1 = dest_monomial m1
- val mon2 = dest_monomial m2
- val deg1 = fold (curry op + o snd) mon1 0
- val deg2 = fold (curry op + o snd) mon2 0
- in if deg1 < deg2 then GREATER else if deg1 > deg2 then LESS
- else list_ord (prod_ord cterm_ord int_ord) (mon1,mon2)
- end;
-
-fun dest_poly p =
- map (fn (m,c) => (c,dest_monomial m))
- (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p));
-
-(* Map back polynomials and their composites to HOL. *)
+(* Map back polynomials and their composites to a positivstellensatz. *)
local
open Thm Numeral RealArith
in
-fun cterm_of_varpow x k = if k = 1 then x else capply (capply @{cterm "op ^ :: real => _"} x)
- (mk_cnumber @{ctyp nat} k)
-
-fun cterm_of_monomial m =
- if Ctermfunc.is_undefined m then @{cterm "1::real"}
- else
- let
- val m' = dest_monomial m
- val vps = fold_rev (fn (x,k) => cons (cterm_of_varpow x k)) m' []
- in fold1 (fn s => fn t => capply (capply @{cterm "op * :: real => _"} s) t) vps
- end
-
-fun cterm_of_cmonomial (m,c) = if Ctermfunc.is_undefined m then cterm_of_rat c
- else if c = Rat.one then cterm_of_monomial m
- else capply (capply @{cterm "op *::real => _"} (cterm_of_rat c)) (cterm_of_monomial m);
-
-fun cterm_of_poly p =
- if Monomialfunc.is_undefined p then @{cterm "0::real"}
- else
- let
- val cms = map cterm_of_cmonomial
- (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p))
- in fold1 (fn t1 => fn t2 => capply(capply @{cterm "op + :: real => _"} t1) t2) cms
- end;
-
-fun cterm_of_sqterm (c,p) = Product(Rational_lt c,Square(cterm_of_poly p));
+fun cterm_of_sqterm (c,p) = Product(Rational_lt c,Square p);
fun cterm_of_sos (pr,sqs) = if null sqs then pr
- else Product(pr,fold1 (fn a => fn b => Sum(a,b)) (map cterm_of_sqterm sqs));
+ else Product(pr,foldr1 (fn (a, b) => Sum(a,b)) (map cterm_of_sqterm sqs));
end
@@ -1275,14 +1219,14 @@
fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS
in
(* FIXME: Replace tryfind by get_first !! *)
-fun real_nonlinear_prover prover ctxt =
+fun real_nonlinear_prover proof_method ctxt =
let
val {add,mul,neg,pow,sub,main} = Normalizer.semiring_normalizers_ord_wrapper ctxt
(valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"}))
simple_cterm_ord
val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv,
real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main)
- fun mainf translator (eqs,les,lts) =
+ fun mainf cert_choice translator (eqs,les,lts) =
let
val eq0 = map (poly_of_term o dest_arg1 o concl) eqs
val le0 = map (poly_of_term o dest_arg o concl) les
@@ -1303,33 +1247,49 @@
else raise Failure "trivial_axiom: Not a trivial axiom"
| _ => error "trivial_axiom: Not a trivial axiom"
in
- ((let val th = tryfind trivial_axiom (keq @ klep @ kltp)
- in fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv field_comp_conv) th end)
- handle Failure _ => (
- let
- val pol = fold_rev poly_mul (map fst ltp) (poly_const Rat.one)
- val leq = lep @ ltp
- fun tryall d =
- let val e = multidegree pol
- val k = if e = 0 then 0 else d div e
- val eq' = map fst eq
- in tryfind (fn i => (d,i,real_positivnullstellensatz_general prover false d eq' leq
- (poly_neg(poly_pow pol i))))
- (0 upto k)
- end
- val (d,i,(cert_ideal,cert_cone)) = deepen tryall 0
- val proofs_ideal =
- map2 (fn q => fn (p,ax) => Eqmul(cterm_of_poly q,ax)) cert_ideal eq
- val proofs_cone = map cterm_of_sos cert_cone
- val proof_ne = if null ltp then Rational_lt Rat.one else
- let val p = fold1 (fn s => fn t => Product(s,t)) (map snd ltp)
- in funpow i (fn q => Product(p,q)) (Rational_lt Rat.one)
- end
- val proof = fold1 (fn s => fn t => Sum(s,t))
- (proof_ne :: proofs_ideal @ proofs_cone)
- in writeln "Translating proof certificate to HOL";
- translator (eqs,les,lts) proof
- end))
+ (let val th = tryfind trivial_axiom (keq @ klep @ kltp)
+ in
+ (fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv field_comp_conv) th, Trivial)
+ end)
+ handle Failure _ =>
+ (let val proof =
+ (case proof_method of Certificate certs =>
+ (* choose certificate *)
+ let
+ fun chose_cert [] (Cert c) = c
+ | chose_cert (Left::s) (Branch (l, _)) = chose_cert s l
+ | chose_cert (Right::s) (Branch (_, r)) = chose_cert s r
+ | chose_cert _ _ = error "certificate tree in invalid form"
+ in
+ chose_cert cert_choice certs
+ end
+ | Prover prover =>
+ (* call prover *)
+ let
+ val pol = fold_rev poly_mul (map fst ltp) (poly_const Rat.one)
+ val leq = lep @ ltp
+ fun tryall d =
+ let val e = multidegree pol
+ val k = if e = 0 then 0 else d div e
+ val eq' = map fst eq
+ in tryfind (fn i => (d,i,real_positivnullstellensatz_general prover false d eq' leq
+ (poly_neg(poly_pow pol i))))
+ (0 upto k)
+ end
+ val (d,i,(cert_ideal,cert_cone)) = deepen tryall 0
+ val proofs_ideal =
+ map2 (fn q => fn (p,ax) => Eqmul(q,ax)) cert_ideal eq
+ val proofs_cone = map cterm_of_sos cert_cone
+ val proof_ne = if null ltp then Rational_lt Rat.one else
+ let val p = foldr1 (fn (s, t) => Product(s,t)) (map snd ltp)
+ in funpow i (fn q => Product(p,q)) (Rational_lt Rat.one)
+ end
+ in
+ foldr1 (fn (s, t) => Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone)
+ end)
+ in
+ (translator (eqs,les,lts) proof, Cert proof)
+ end)
end
in mainf end
end
@@ -1396,7 +1356,7 @@
orelse g aconvc @{cterm "op < :: real => _"}
then arg_conv cv ct else arg1_conv cv ct
end
- fun mainf translator =
+ fun mainf cert_choice translator =
let
fun substfirst(eqs,les,lts) =
((let
@@ -1407,7 +1367,7 @@
aconvc @{cterm "0::real"}) (map modify eqs),
map modify les,map modify lts)
end)
- handle Failure _ => real_nonlinear_prover prover ctxt translator (rev eqs, rev les, rev lts))
+ handle Failure _ => real_nonlinear_prover prover ctxt cert_choice translator (rev eqs, rev les, rev lts))
in substfirst
end
@@ -1417,7 +1377,8 @@
(* Overall function. *)
-fun real_sos prover ctxt t = gen_prover_real_arith ctxt (real_nonlinear_subst_prover prover ctxt) t;
+fun real_sos prover ctxt =
+ gen_prover_real_arith ctxt (real_nonlinear_subst_prover prover ctxt)
end;
(* A tactic *)
@@ -1429,8 +1390,6 @@
end
| _ => ([],ct)
-fun core_sos_conv prover ctxt t = Drule.arg_cong_rule @{cterm Trueprop} (real_sos prover ctxt (Thm.dest_arg t) RS @{thm Eq_TrueI})
-
val known_sos_constants =
[@{term "op ==>"}, @{term "Trueprop"},
@{term "op -->"}, @{term "op &"}, @{term "op |"},
@@ -1458,17 +1417,19 @@
val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs
then error "SOS: not sos. Variables with type not real" else ()
val vs = Term.add_vars t []
- val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs
+ val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) vs
then error "SOS: not sos. Variables with type not real" else ()
val ukcs = subtract (fn (t,p) => Const p aconv t) kcts (Term.add_consts t [])
val _ = if null ukcs then ()
else error ("SOSO: Unknown constants in Subgoal:" ^ commas (map fst ukcs))
in () end
-fun core_sos_tac prover ctxt = CSUBGOAL (fn (ct, i) =>
+fun core_sos_tac print_cert prover ctxt = CSUBGOAL (fn (ct, i) =>
let val _ = check_sos known_sos_constants ct
val (avs, p) = strip_all ct
- val th = standard (fold_rev forall_intr avs (real_sos prover ctxt (Thm.dest_arg p)))
+ val (ths, certificates) = real_sos prover ctxt (Thm.dest_arg p)
+ val th = standard (fold_rev forall_intr avs ths)
+ val _ = print_cert certificates
in rtac th i end);
fun default_SOME f NONE v = SOME v
@@ -1506,7 +1467,7 @@
fun elim_denom_tac ctxt i = REPEAT (elim_one_denom_tac ctxt i);
-fun sos_tac prover ctxt = ObjectLogic.full_atomize_tac THEN' elim_denom_tac ctxt THEN' core_sos_tac prover ctxt
+fun sos_tac print_cert prover ctxt = ObjectLogic.full_atomize_tac THEN' elim_denom_tac ctxt THEN' core_sos_tac print_cert prover ctxt
end;
--- a/src/HOL/Library/Topology_Euclidean_Space.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Topology_Euclidean_Space.thy Thu Oct 01 07:40:25 2009 +0200
@@ -99,11 +99,9 @@
lemma Diff_Diff_Int: "A - (A - B) = A \<inter> B" by blast
lemma openin_closedin_eq: "openin U S \<longleftrightarrow> S \<subseteq> topspace U \<and> closedin U (topspace U - S)"
- apply (auto simp add: closedin_def)
+ apply (auto simp add: closedin_def Diff_Diff_Int inf_absorb2)
apply (metis openin_subset subset_eq)
- apply (auto simp add: Diff_Diff_Int)
- apply (subgoal_tac "topspace U \<inter> S = S")
- by auto
+ done
lemma openin_closedin: "S \<subseteq> topspace U \<Longrightarrow> (openin U S \<longleftrightarrow> closedin U (topspace U - S))"
by (simp add: openin_closedin_eq)
--- a/src/HOL/Library/Univ_Poly.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Univ_Poly.thy Thu Oct 01 07:40:25 2009 +0200
@@ -820,37 +820,24 @@
done
qed
-lemma (in semiring_0) pnormalize_sing: "(pnormalize [x] = [x]) \<longleftrightarrow> x \<noteq> 0" by simp
+lemma (in semiring_0) pnormalize_sing: "(pnormalize [x] = [x]) \<longleftrightarrow> x \<noteq> 0"
+by simp
lemma (in semiring_0) pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> (pnormalize [x, y] = [x, y])" by simp
lemma (in semiring_0) pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c#p)"
unfolding pnormal_def by simp
lemma (in semiring_0) pnormal_tail: "p\<noteq>[] \<Longrightarrow> pnormal (c#p) \<Longrightarrow> pnormal p"
- unfolding pnormal_def
- apply (cases "pnormalize p = []", auto)
- by (cases "c = 0", auto)
+ unfolding pnormal_def by(auto split: split_if_asm)
lemma (in semiring_0) pnormal_last_nonzero: "pnormal p ==> last p \<noteq> 0"
-proof(induct p)
- case Nil thus ?case by (simp add: pnormal_def)
-next
- case (Cons a as) thus ?case
- apply (simp add: pnormal_def)
- apply (cases "pnormalize as = []", simp_all)
- apply (cases "as = []", simp_all)
- apply (cases "a=0", simp_all)
- apply (cases "a=0", simp_all)
- done
-qed
+by(induct p) (simp_all add: pnormal_def split: split_if_asm)
lemma (in semiring_0) pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
unfolding pnormal_def length_greater_0_conv by blast
lemma (in semiring_0) pnormal_last_length: "\<lbrakk>0 < length p ; last p \<noteq> 0\<rbrakk> \<Longrightarrow> pnormal p"
- apply (induct p, auto)
- apply (case_tac "p = []", auto)
- apply (simp add: pnormal_def)
- by (rule pnormal_cons, auto)
+by (induct p) (auto simp: pnormal_def split: split_if_asm)
+
lemma (in semiring_0) pnormal_id: "pnormal p \<longleftrightarrow> (0 < length p \<and> last p \<noteq> 0)"
using pnormal_last_length pnormal_length pnormal_last_nonzero by blast
@@ -918,9 +905,7 @@
qed
lemma (in semiring_0) pnormalize_eq: "last p \<noteq> 0 \<Longrightarrow> pnormalize p = p"
- apply (induct p, auto)
- apply (case_tac p, auto)+
- done
+by (induct p) (auto split: split_if_asm)
lemma (in semiring_0) last_pnormalize: "pnormalize p \<noteq> [] \<Longrightarrow> last (pnormalize p) \<noteq> 0"
by (induct p, auto)
--- a/src/HOL/Library/Word.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/Word.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1008,12 +1008,7 @@
fix xs
assume "length (norm_signed (\<zero>#xs)) = Suc (length xs)"
thus "norm_signed (\<zero>#xs) = \<zero>#xs"
- apply (simp add: norm_signed_Cons)
- apply safe
- apply simp_all
- apply (rule norm_unsigned_equal)
- apply assumption
- done
+ by (simp add: norm_signed_Cons norm_unsigned_equal split: split_if_asm)
next
fix xs
assume "length (norm_signed (\<one>#xs)) = Suc (length xs)"
@@ -1519,9 +1514,7 @@
proof -
have "((2::int) ^ (length w1 - 1)) + (2 ^ (length w2 - 1)) \<le>
2 ^ (max (length w1) (length w2) - 1) + 2 ^ (max (length w1) (length w2) - 1)"
- apply (cases "length w1 \<le> length w2")
- apply (auto simp add: max_def)
- done
+ by (auto simp:max_def)
also have "... = 2 ^ max (length w1) (length w2)"
proof -
from lw
@@ -2173,16 +2166,16 @@
apply (subst bv_sliceI [where ?j = i and ?i = j and ?w = w and ?w1.0 = "w1 @ w2" and ?w2.0 = w3 and ?w3.0 = "w4 @ w5"])
apply simp_all
apply (rule w_def)
- apply (simp add: w_defs min_def)
- apply (simp add: w_defs min_def)
+ apply (simp add: w_defs)
+ apply (simp add: w_defs)
apply (subst bv_sliceI [where ?j = k and ?i = l and ?w = w and ?w1.0 = w1 and ?w2.0 = "w2 @ w3 @ w4" and ?w3.0 = w5])
apply simp_all
apply (rule w_def)
- apply (simp add: w_defs min_def)
- apply (simp add: w_defs min_def)
+ apply (simp add: w_defs)
+ apply (simp add: w_defs)
apply (subst bv_sliceI [where ?j = "i-k" and ?i = "j-k" and ?w = "w2 @ w3 @ w4" and ?w1.0 = w2 and ?w2.0 = w3 and ?w3.0 = w4])
apply simp_all
- apply (simp_all add: w_defs min_def)
+ apply (simp_all add: w_defs)
done
qed
--- a/src/HOL/Library/normarith.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/normarith.ML Thu Oct 01 07:40:25 2009 +0200
@@ -15,7 +15,7 @@
structure NormArith : NORM_ARITH =
struct
- open Conv Thm Conv2;
+ open Conv Thm FuncUtil;
val bool_eq = op = : bool *bool -> bool
fun dest_ratconst t = case term_of t of
Const(@{const_name divide}, _)$a$b => Rat.rat_of_quotient(HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
@@ -322,6 +322,7 @@
val ths = map_filter (fn (v,t) => if v =/ Rat.zero then NONE
else SOME(norm_cmul_rule v t))
(v ~~ nubs)
+ fun end_itlist f xs = split_last xs |> uncurry (fold_rev f)
in inequality_canon_rule ctxt (end_itlist norm_add_rule ths)
end
val ges' = map_filter (try compute_ineq) (fold_rev (append o consider) destfuns []) @
@@ -329,13 +330,13 @@
val zerodests = filter
(fn t => null (Ctermfunc.dom (vector_lincomb t))) (map snd rawdests)
- in RealArith.real_linear_prover translator
+ in fst (RealArith.real_linear_prover translator
(map (fn t => instantiate ([(tv_n, ctyp_of_term t)],[]) pth_zero)
zerodests,
- map (fconv_rule (once_depth_conv (norm_canon_conv) then_conv
+ map (fconv_rule (try_conv (More_Conv.top_sweep_conv (K norm_canon_conv) ctxt) then_conv
arg_conv (arg_conv real_poly_conv))) ges',
- map (fconv_rule (once_depth_conv (norm_canon_conv) then_conv
- arg_conv (arg_conv real_poly_conv))) gts)
+ map (fconv_rule (try_conv (More_Conv.top_sweep_conv (K norm_canon_conv) ctxt) then_conv
+ arg_conv (arg_conv real_poly_conv))) gts))
end
in val real_vector_combo_prover = real_vector_combo_prover
end;
@@ -353,6 +354,7 @@
val ntms = fold_rev find_normedterms (map (dest_arg o concl) (ges @ gts)) []
val lctab = vector_lincombs (map snd (filter (not o fst) ntms))
val (fxns, ctxt') = Variable.variant_fixes (replicate (length lctab) "x") ctxt
+ fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
fun mk_norm t = capply (instantiate_cterm' [SOME (ctyp_of_term t)] [] @{cpat "norm :: (?'a :: real_normed_vector) => real"}) t
fun mk_equals l r = capply (capply (instantiate_cterm' [SOME (ctyp_of_term l)] [] @{cpat "op == :: ?'a =>_"}) l) r
val asl = map2 (fn (t,_) => fn n => assume (mk_equals (mk_norm t) (cterm_of (ProofContext.theory_of ctxt') (Free(n,@{typ real}))))) lctab fxns
@@ -387,9 +389,9 @@
val (th1,th2) = conj_pair(rawrule th)
in th1::fconv_rule (arg_conv (arg_conv real_poly_neg_conv)) th2::acc
end
-in fun real_vector_prover ctxt translator (eqs,ges,gts) =
- real_vector_ineq_prover ctxt translator
- (fold_rev (splitequation ctxt) eqs ges,gts)
+in fun real_vector_prover ctxt _ translator (eqs,ges,gts) =
+ (real_vector_ineq_prover ctxt translator
+ (fold_rev (splitequation ctxt) eqs ges,gts), RealArith.Trivial)
end;
fun init_conv ctxt =
@@ -398,7 +400,7 @@
then_conv field_comp_conv
then_conv nnf_conv
- fun pure ctxt = RealArith.gen_prover_real_arith ctxt (real_vector_prover ctxt);
+ fun pure ctxt = fst o RealArith.gen_prover_real_arith ctxt (real_vector_prover ctxt);
fun norm_arith ctxt ct =
let
val ctxt' = Variable.declare_term (term_of ct) ctxt
--- a/src/HOL/Library/positivstellensatz.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Library/positivstellensatz.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,10 +1,11 @@
-(* Title: Library/positivstellensatz
+(* Title: Library/Sum_Of_Squares/positivstellensatz
Author: Amine Chaieb, University of Cambridge
Description: A generic arithmetic prover based on Positivstellensatz certificates ---
also implements Fourrier-Motzkin elimination as a special case Fourrier-Motzkin elimination.
*)
(* A functor for finite mappings based on Tables *)
+
signature FUNC =
sig
type 'a T
@@ -75,103 +76,54 @@
end
end;
+(* Some standard functors and utility functions for them *)
+
+structure FuncUtil =
+struct
+
+fun increasing f ord (x,y) = ord (f x, f y);
+
structure Intfunc = FuncFun(type key = int val ord = int_ord);
+structure Ratfunc = FuncFun(type key = Rat.rat val ord = Rat.ord);
+structure Intpairfunc = FuncFun(type key = int*int val ord = prod_ord int_ord int_ord);
structure Symfunc = FuncFun(type key = string val ord = fast_string_ord);
structure Termfunc = FuncFun(type key = term val ord = TermOrd.fast_term_ord);
-structure Ctermfunc = FuncFun(type key = cterm val ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t)));
+
+val cterm_ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t))
-structure Ratfunc = FuncFun(type key = Rat.rat val ord = Rat.ord);
- (* Some conversions-related stuff which has been forbidden entrance into Pure/conv.ML*)
-structure Conv2 =
-struct
- open Conv
-fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
-fun is_comb t = case (term_of t) of _$_ => true | _ => false;
-fun is_abs t = case (term_of t) of Abs _ => true | _ => false;
+structure Ctermfunc = FuncFun(type key = cterm val ord = cterm_ord);
-fun end_itlist f l =
- case l of
- [] => error "end_itlist"
- | [x] => x
- | (h::t) => f h (end_itlist f t);
+type monomial = int Ctermfunc.T;
- fun absc cv ct = case term_of ct of
- Abs (v,_, _) =>
- let val (x,t) = Thm.dest_abs (SOME v) ct
- in Thm.abstract_rule ((fst o dest_Free o term_of) x) x (cv t)
- end
- | _ => all_conv ct;
+fun monomial_ord (m1,m2) = list_ord (prod_ord cterm_ord int_ord) (Ctermfunc.graph m1, Ctermfunc.graph m2)
+
+structure Monomialfunc = FuncFun(type key = monomial val ord = monomial_ord)
-fun cache_conv conv =
- let
- val tab = ref Termtab.empty
- fun cconv t =
- case Termtab.lookup (!tab) (term_of t) of
- SOME th => th
- | NONE => let val th = conv t
- in ((tab := Termtab.insert Thm.eq_thm (term_of t, th) (!tab)); th) end
- in cconv end;
-fun is_binop ct ct' = ct aconvc (Thm.dest_fun (Thm.dest_fun ct'))
- handle CTERM _ => false;
+type poly = Rat.rat Monomialfunc.T;
-local
- fun thenqc conv1 conv2 tm =
- case try conv1 tm of
- SOME th1 => (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
- | NONE => conv2 tm
+(* The ordering so we can create canonical HOL polynomials. *)
- fun thencqc conv1 conv2 tm =
- let val th1 = conv1 tm
- in (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
- end
- fun comb_qconv conv tm =
- let val (l,r) = Thm.dest_comb tm
- in (case try conv l of
- SOME th1 => (case try conv r of SOME th2 => Thm.combination th1 th2
- | NONE => Drule.fun_cong_rule th1 r)
- | NONE => Drule.arg_cong_rule l (conv r))
- end
- fun repeatqc conv tm = thencqc conv (repeatqc conv) tm
- fun sub_qconv conv tm = if is_abs tm then absc conv tm else comb_qconv conv tm
- fun once_depth_qconv conv tm =
- (conv else_conv (sub_qconv (once_depth_qconv conv))) tm
- fun depth_qconv conv tm =
- thenqc (sub_qconv (depth_qconv conv))
- (repeatqc conv) tm
- fun redepth_qconv conv tm =
- thenqc (sub_qconv (redepth_qconv conv))
- (thencqc conv (redepth_qconv conv)) tm
- fun top_depth_qconv conv tm =
- thenqc (repeatqc conv)
- (thencqc (sub_qconv (top_depth_qconv conv))
- (thencqc conv (top_depth_qconv conv))) tm
- fun top_sweep_qconv conv tm =
- thenqc (repeatqc conv)
- (sub_qconv (top_sweep_qconv conv)) tm
-in
-val (once_depth_conv, depth_conv, rdepth_conv, top_depth_conv, top_sweep_conv) =
- (fn c => try_conv (once_depth_qconv c),
- fn c => try_conv (depth_qconv c),
- fn c => try_conv (redepth_qconv c),
- fn c => try_conv (top_depth_qconv c),
- fn c => try_conv (top_sweep_qconv c));
-end;
-end;
+fun dest_monomial mon = sort (increasing fst cterm_ord) (Ctermfunc.graph mon);
-
- (* Some useful derived rules *)
-fun deduct_antisym_rule tha thb =
- equal_intr (implies_intr (cprop_of thb) tha)
- (implies_intr (cprop_of tha) thb);
+fun monomial_order (m1,m2) =
+ if Ctermfunc.is_undefined m2 then LESS
+ else if Ctermfunc.is_undefined m1 then GREATER
+ else
+ let val mon1 = dest_monomial m1
+ val mon2 = dest_monomial m2
+ val deg1 = fold (curry op + o snd) mon1 0
+ val deg2 = fold (curry op + o snd) mon2 0
+ in if deg1 < deg2 then GREATER else if deg1 > deg2 then LESS
+ else list_ord (prod_ord cterm_ord int_ord) (mon1,mon2)
+ end;
-fun prove_hyp tha thb =
- if exists (curry op aconv (concl_of tha)) (#hyps (rep_thm thb))
- then equal_elim (symmetric (deduct_antisym_rule tha thb)) tha else thb;
+end
-
+(* positivstellensatz datatype and prover generation *)
signature REAL_ARITH =
sig
+
datatype positivstellensatz =
Axiom_eq of int
| Axiom_le of int
@@ -179,34 +131,41 @@
| Rational_eq of Rat.rat
| Rational_le of Rat.rat
| Rational_lt of Rat.rat
- | Square of cterm
- | Eqmul of cterm * positivstellensatz
+ | Square of FuncUtil.poly
+ | Eqmul of FuncUtil.poly * positivstellensatz
| Sum of positivstellensatz * positivstellensatz
| Product of positivstellensatz * positivstellensatz;
+datatype pss_tree = Trivial | Cert of positivstellensatz | Branch of pss_tree * pss_tree
+
+datatype tree_choice = Left | Right
+
+type prover = tree_choice list ->
+ (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+ thm list * thm list * thm list -> thm * pss_tree
+type cert_conv = cterm -> thm * pss_tree
+
val gen_gen_real_arith :
- Proof.context -> (Rat.rat -> Thm.cterm) * conv * conv * conv *
- conv * conv * conv * conv * conv * conv *
- ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
- thm list * thm list * thm list -> thm) -> conv
-val real_linear_prover :
- (thm list * thm list * thm list -> positivstellensatz -> thm) ->
- thm list * thm list * thm list -> thm
+ Proof.context -> (Rat.rat -> cterm) * conv * conv * conv *
+ conv * conv * conv * conv * conv * conv * prover -> cert_conv
+val real_linear_prover : (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+ thm list * thm list * thm list -> thm * pss_tree
val gen_real_arith : Proof.context ->
- (Rat.rat -> cterm) * conv * conv * conv * conv * conv * conv * conv *
- ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
- thm list * thm list * thm list -> thm) -> conv
-val gen_prover_real_arith : Proof.context ->
- ((thm list * thm list * thm list -> positivstellensatz -> thm) ->
- thm list * thm list * thm list -> thm) -> conv
-val real_arith : Proof.context -> conv
+ (Rat.rat -> cterm) * conv * conv * conv * conv * conv * conv * conv * prover -> cert_conv
+
+val gen_prover_real_arith : Proof.context -> prover -> cert_conv
+
+val is_ratconst : cterm -> bool
+val dest_ratconst : cterm -> Rat.rat
+val cterm_of_rat : Rat.rat -> cterm
+
end
-structure RealArith (* : REAL_ARITH *)=
+structure RealArith : REAL_ARITH =
struct
- open Conv Thm;;
+ open Conv Thm FuncUtil;;
(* ------------------------------------------------------------------------- *)
(* Data structure for Positivstellensatz refutations. *)
(* ------------------------------------------------------------------------- *)
@@ -218,27 +177,43 @@
| Rational_eq of Rat.rat
| Rational_le of Rat.rat
| Rational_lt of Rat.rat
- | Square of cterm
- | Eqmul of cterm * positivstellensatz
+ | Square of FuncUtil.poly
+ | Eqmul of FuncUtil.poly * positivstellensatz
| Sum of positivstellensatz * positivstellensatz
| Product of positivstellensatz * positivstellensatz;
(* Theorems used in the procedure *)
+datatype pss_tree = Trivial | Cert of positivstellensatz | Branch of pss_tree * pss_tree
+datatype tree_choice = Left | Right
+type prover = tree_choice list ->
+ (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+ thm list * thm list * thm list -> thm * pss_tree
+type cert_conv = cterm -> thm * pss_tree
-val my_eqs = ref ([] : thm list);
-val my_les = ref ([] : thm list);
-val my_lts = ref ([] : thm list);
-val my_proof = ref (Axiom_eq 0);
-val my_context = ref @{context};
+val my_eqs = Unsynchronized.ref ([] : thm list);
+val my_les = Unsynchronized.ref ([] : thm list);
+val my_lts = Unsynchronized.ref ([] : thm list);
+val my_proof = Unsynchronized.ref (Axiom_eq 0);
+val my_context = Unsynchronized.ref @{context};
-val my_mk_numeric = ref ((K @{cterm True}) :Rat.rat -> cterm);
-val my_numeric_eq_conv = ref no_conv;
-val my_numeric_ge_conv = ref no_conv;
-val my_numeric_gt_conv = ref no_conv;
-val my_poly_conv = ref no_conv;
-val my_poly_neg_conv = ref no_conv;
-val my_poly_add_conv = ref no_conv;
-val my_poly_mul_conv = ref no_conv;
+val my_mk_numeric = Unsynchronized.ref ((K @{cterm True}) :Rat.rat -> cterm);
+val my_numeric_eq_conv = Unsynchronized.ref no_conv;
+val my_numeric_ge_conv = Unsynchronized.ref no_conv;
+val my_numeric_gt_conv = Unsynchronized.ref no_conv;
+val my_poly_conv = Unsynchronized.ref no_conv;
+val my_poly_neg_conv = Unsynchronized.ref no_conv;
+val my_poly_add_conv = Unsynchronized.ref no_conv;
+val my_poly_mul_conv = Unsynchronized.ref no_conv;
+
+
+ (* Some useful derived rules *)
+fun deduct_antisym_rule tha thb =
+ equal_intr (implies_intr (cprop_of thb) tha)
+ (implies_intr (cprop_of tha) thb);
+
+fun prove_hyp tha thb =
+ if exists (curry op aconv (concl_of tha)) (#hyps (rep_thm thb))
+ then equal_elim (symmetric (deduct_antisym_rule tha thb)) tha else thb;
fun conjunctions th = case try Conjunction.elim th of
SOME (th1,th2) => (conjunctions th1) @ conjunctions th2
@@ -368,23 +343,46 @@
| Abs (_,_,t') => find_cterm p (Thm.dest_abs NONE t |> snd)
| _ => raise CTERM ("find_cterm",[t]);
-
(* Some conversions-related stuff which has been forbidden entrance into Pure/conv.ML*)
fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
fun is_comb t = case (term_of t) of _$_ => true | _ => false;
-fun cache_conv conv =
- let
- val tab = ref Termtab.empty
- fun cconv t =
- case Termtab.lookup (!tab) (term_of t) of
- SOME th => th
- | NONE => let val th = conv t
- in ((tab := Termtab.insert Thm.eq_thm (term_of t, th) (!tab)); th) end
- in cconv end;
fun is_binop ct ct' = ct aconvc (Thm.dest_fun (Thm.dest_fun ct'))
handle CTERM _ => false;
+
+(* Map back polynomials to HOL. *)
+
+local
+ open Thm Numeral
+in
+
+fun cterm_of_varpow x k = if k = 1 then x else capply (capply @{cterm "op ^ :: real => _"} x)
+ (mk_cnumber @{ctyp nat} k)
+
+fun cterm_of_monomial m =
+ if Ctermfunc.is_undefined m then @{cterm "1::real"}
+ else
+ let
+ val m' = dest_monomial m
+ val vps = fold_rev (fn (x,k) => cons (cterm_of_varpow x k)) m' []
+ in foldr1 (fn (s, t) => capply (capply @{cterm "op * :: real => _"} s) t) vps
+ end
+
+fun cterm_of_cmonomial (m,c) = if Ctermfunc.is_undefined m then cterm_of_rat c
+ else if c = Rat.one then cterm_of_monomial m
+ else capply (capply @{cterm "op *::real => _"} (cterm_of_rat c)) (cterm_of_monomial m);
+
+fun cterm_of_poly p =
+ if Monomialfunc.is_undefined p then @{cterm "0::real"}
+ else
+ let
+ val cms = map cterm_of_cmonomial
+ (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p))
+ in foldr1 (fn (t1, t2) => capply(capply @{cterm "op + :: real => _"} t1) t2) cms
+ end;
+
+end;
(* A general real arithmetic prover *)
fun gen_gen_real_arith ctxt (mk_numeric,
@@ -453,8 +451,8 @@
| Rational_lt x => eqT_elim(numeric_gt_conv(capply @{cterm Trueprop}
(capply (capply @{cterm "op <::real => _"} @{cterm "0::real"})
(mk_numeric x))))
- | Square t => square_rule t
- | Eqmul(t,p) => emul_rule t (translate p)
+ | Square pt => square_rule (cterm_of_poly pt)
+ | Eqmul(pt,p) => emul_rule (cterm_of_poly pt) (translate p)
| Sum(p1,p2) => add_rule (translate p1) (translate p2)
| Product(p1,p2) => mul_rule (translate p1) (translate p2)
in fconv_rule (first_conv [numeric_ge_conv, numeric_gt_conv, numeric_eq_conv, all_conv])
@@ -479,13 +477,13 @@
val _ = if c aconvc (concl th2) then () else error "disj_cases : conclusions not alpha convertible"
in implies_elim (implies_elim (implies_elim (instantiate' [] (map SOME [p,q,c]) @{thm disjE}) th) (implies_intr (capply @{cterm Trueprop} p) th1)) (implies_intr (capply @{cterm Trueprop} q) th2)
end
- fun overall dun ths = case ths of
+ fun overall cert_choice dun ths = case ths of
[] =>
let
val (eq,ne) = List.partition (is_req o concl) dun
val (le,nl) = List.partition (is_ge o concl) ne
val lt = filter (is_gt o concl) nl
- in prover hol_of_positivstellensatz (eq,le,lt) end
+ in prover (rev cert_choice) hol_of_positivstellensatz (eq,le,lt) end
| th::oths =>
let
val ct = concl th
@@ -493,13 +491,13 @@
if is_conj ct then
let
val (th1,th2) = conj_pair th in
- overall dun (th1::th2::oths) end
+ overall cert_choice dun (th1::th2::oths) end
else if is_disj ct then
let
- val th1 = overall dun (assume (capply @{cterm Trueprop} (dest_arg1 ct))::oths)
- val th2 = overall dun (assume (capply @{cterm Trueprop} (dest_arg ct))::oths)
- in disj_cases th th1 th2 end
- else overall (th::dun) oths
+ val (th1, cert1) = overall (Left::cert_choice) dun (assume (capply @{cterm Trueprop} (dest_arg1 ct))::oths)
+ val (th2, cert2) = overall (Right::cert_choice) dun (assume (capply @{cterm Trueprop} (dest_arg ct))::oths)
+ in (disj_cases th th1 th2, Branch (cert1, cert2)) end
+ else overall cert_choice (th::dun) oths
end
fun dest_binary b ct = if is_binop b ct then dest_binop ct
else raise CTERM ("dest_binary",[b,ct])
@@ -571,7 +569,7 @@
val nnf_norm_conv' =
nnf_conv then_conv
literals_conv [@{term "op &"}, @{term "op |"}] []
- (cache_conv
+ (More_Conv.cache_conv
(first_conv [real_lt_conv, real_le_conv,
real_eq_conv, real_not_lt_conv,
real_not_le_conv, real_not_eq_conv, all_conv]))
@@ -581,16 +579,16 @@
val nct = capply @{cterm Trueprop} (capply @{cterm "Not"} ct)
val th0 = (init_conv then_conv arg_conv nnf_norm_conv') nct
val tm0 = dest_arg (rhs_of th0)
- val th = if tm0 aconvc @{cterm False} then equal_implies_1_rule th0 else
+ val (th, certificates) = if tm0 aconvc @{cterm False} then (equal_implies_1_rule th0, Trivial) else
let
val (evs,bod) = strip_exists tm0
val (avs,ibod) = strip_forall bod
val th1 = Drule.arg_cong_rule @{cterm Trueprop} (fold mk_forall avs (absremover ibod))
- val th2 = overall [] [specl avs (assume (rhs_of th1))]
+ val (th2, certs) = overall [] [] [specl avs (assume (rhs_of th1))]
val th3 = fold simple_choose evs (prove_hyp (equal_elim th1 (assume (capply @{cterm Trueprop} bod))) th2)
- in Drule.implies_intr_hyps (prove_hyp (equal_elim th0 (assume nct)) th3)
+ in (Drule.implies_intr_hyps (prove_hyp (equal_elim th0 (assume nct)) th3), certs)
end
- in implies_elim (instantiate' [] [SOME ct] pth_final) th
+ in (implies_elim (instantiate' [] [SOME ct] pth_final) th, certificates)
end
in f
end;
@@ -665,7 +663,7 @@
val k = (Rat.neg d) */ Rat.abs c // c
val e' = linear_cmul k e
val t' = linear_cmul (Rat.abs c) t
- val p' = Eqmul(cterm_of_rat k,p)
+ val p' = Eqmul(Monomialfunc.onefunc (Ctermfunc.undefined, k),p)
val q' = Product(Rational_lt(Rat.abs c),q)
in (linear_add e' t',Sum(p',q'))
end
@@ -717,7 +715,7 @@
val le_pols' = le_pols @ map (fn v => Ctermfunc.onefunc (v,Rat.one)) aliens
val (_,proof) = linear_prover (eq_pols,le_pols',lt_pols)
val le' = le @ map (fn a => instantiate' [] [SOME (dest_arg a)] @{thm real_of_nat_ge_zero}) aliens
- in (translator (eq,le',lt) proof) : thm
+ in ((translator (eq,le',lt) proof), Trivial)
end
end;
@@ -783,5 +781,4 @@
main,neg,add,mul, prover)
end;
-fun real_arith ctxt = gen_prover_real_arith ctxt real_linear_prover;
end
--- a/src/HOL/Lim.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Lim.thy Thu Oct 01 07:40:25 2009 +0200
@@ -84,6 +84,8 @@
lemma LIM_const [simp]: "(%x. k) -- x --> k"
by (simp add: LIM_def)
+lemma LIM_cong_limit: "\<lbrakk> f -- x --> L ; K = L \<rbrakk> \<Longrightarrow> f -- x --> K" by simp
+
lemma LIM_add:
fixes f g :: "'a::metric_space \<Rightarrow> 'b::real_normed_vector"
assumes f: "f -- a --> L" and g: "g -- a --> M"
@@ -544,8 +546,7 @@
case True thus ?thesis using `0 < s` by auto
next
case False hence "s / 2 \<ge> (x - b) / 2" by auto
- from inf_absorb2[OF this, unfolded inf_real_def]
- have "?x = (x + b) / 2" by auto
+ hence "?x = (x + b) / 2" by (simp add: field_simps min_max.inf_absorb2)
thus ?thesis using `b < x` by auto
qed
hence "0 \<le> f ?x" using all_le `?x < x` by auto
--- a/src/HOL/List.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/List.thy Thu Oct 01 07:40:25 2009 +0200
@@ -881,10 +881,8 @@
lemma set_filter [simp]: "set (filter P xs) = {x. x : set xs \<and> P x}"
by (induct xs) auto
-lemma set_upt [simp]: "set[i..<j] = {k. i \<le> k \<and> k < j}"
-apply (induct j, simp_all)
-apply (erule ssubst, auto)
-done
+lemma set_upt [simp]: "set[i..<j] = {i..<j}"
+by (induct j) (simp_all add: atLeastLessThanSuc)
lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
@@ -2169,6 +2167,71 @@
"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)
+lemma (in ab_semigroup_idem_mult) fold1_set:
+ assumes "xs \<noteq> []"
+ shows "fold1 times (set xs) = foldl times (hd xs) (tl xs)"
+proof -
+ interpret fun_left_comm_idem times by (fact fun_left_comm_idem)
+ from assms obtain y ys where xs: "xs = y # ys"
+ by (cases xs) auto
+ show ?thesis
+ proof (cases "set ys = {}")
+ case True with xs show ?thesis by simp
+ next
+ case False
+ then have "fold1 times (insert y (set ys)) = fold times y (set ys)"
+ by (simp only: finite_set fold1_eq_fold_idem)
+ with xs show ?thesis by (simp add: fold_set mult_commute)
+ qed
+qed
+
+lemma (in lattice) Inf_fin_set_fold [code_unfold]:
+ "Inf_fin (set (x # xs)) = foldl inf x xs"
+proof -
+ interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ by (fact ab_semigroup_idem_mult_inf)
+ show ?thesis
+ by (simp add: Inf_fin_def fold1_set del: set.simps)
+qed
+
+lemma (in lattice) Sup_fin_set_fold [code_unfold]:
+ "Sup_fin (set (x # xs)) = foldl sup x xs"
+proof -
+ interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ by (fact ab_semigroup_idem_mult_sup)
+ show ?thesis
+ by (simp add: Sup_fin_def fold1_set del: set.simps)
+qed
+
+lemma (in linorder) Min_fin_set_fold [code_unfold]:
+ "Min (set (x # xs)) = foldl min x xs"
+proof -
+ interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ by (fact ab_semigroup_idem_mult_min)
+ show ?thesis
+ by (simp add: Min_def fold1_set del: set.simps)
+qed
+
+lemma (in linorder) Max_fin_set_fold [code_unfold]:
+ "Max (set (x # xs)) = foldl max x xs"
+proof -
+ interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ by (fact ab_semigroup_idem_mult_max)
+ show ?thesis
+ by (simp add: Max_def fold1_set del: set.simps)
+qed
+
+lemma (in complete_lattice) Inf_set_fold [code_unfold]:
+ "Inf (set xs) = foldl inf top xs"
+ by (cases xs)
+ (simp_all add: Inf_fin_Inf [symmetric] Inf_fin_set_fold
+ inf_commute del: set.simps, simp add: top_def)
+
+lemma (in complete_lattice) Sup_set_fold [code_unfold]:
+ "Sup (set xs) = foldl sup bot xs"
+ by (cases xs)
+ (simp_all add: Sup_fin_Sup [symmetric] Sup_fin_set_fold
+ sup_commute del: set.simps, simp add: bot_def)
subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}
@@ -2394,6 +2457,30 @@
nth_Cons_number_of [simp]
+subsubsection {* @{text upto}: interval-list on @{typ int} *}
+
+(* FIXME make upto tail recursive? *)
+
+function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where
+"upto i j = (if i \<le> j then i # [i+1..j] else [])"
+by auto
+termination
+by(relation "measure(%(i::int,j). nat(j - i + 1))") auto
+
+declare upto.simps[code, simp del]
+
+lemmas upto_rec_number_of[simp] =
+ upto.simps[of "number_of m" "number_of n", standard]
+
+lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
+by(simp add: upto.simps)
+
+lemma set_upto[simp]: "set[i..j] = {i..j}"
+apply(induct i j rule:upto.induct)
+apply(simp add: upto.simps simp_from_to)
+done
+
+
subsubsection {* @{text "distinct"} and @{text remdups} *}
lemma distinct_append [simp]:
@@ -2448,6 +2535,12 @@
lemma distinct_upt[simp]: "distinct[i..<j]"
by (induct j) auto
+lemma distinct_upto[simp]: "distinct[i..j]"
+apply(induct i j rule:upto.induct)
+apply(subst upto.simps)
+apply(simp)
+done
+
lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"
apply(induct xs arbitrary: i)
apply simp
@@ -3091,6 +3184,12 @@
lemma sorted_upt[simp]: "sorted[i..<j]"
by (induct j) (simp_all add:sorted_append)
+lemma sorted_upto[simp]: "sorted[i..j]"
+apply(induct i j rule:upto.induct)
+apply(subst upto.simps)
+apply(simp add:sorted_Cons)
+done
+
subsubsection {* @{text sorted_list_of_set} *}
@@ -3124,89 +3223,6 @@
end
-subsubsection {* @{text upto}: the generic interval-list *}
-
-class finite_intvl_succ = linorder +
-fixes successor :: "'a \<Rightarrow> 'a"
-assumes finite_intvl: "finite{a..b}"
-and successor_incr: "a < successor a"
-and ord_discrete: "\<not>(\<exists>x. a < x & x < successor a)"
-
-context finite_intvl_succ
-begin
-
-definition
- upto :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list" ("(1[_../_])") where
-"upto i j == sorted_list_of_set {i..j}"
-
-lemma upto[simp]: "set[a..b] = {a..b} & sorted[a..b] & distinct[a..b]"
-by(simp add:upto_def finite_intvl)
-
-lemma insert_intvl: "i \<le> j \<Longrightarrow> insert i {successor i..j} = {i..j}"
-apply(insert successor_incr[of i])
-apply(auto simp: atLeastAtMost_def atLeast_def atMost_def)
-apply(metis ord_discrete less_le not_le)
-done
-
-lemma sorted_list_of_set_rec: "i \<le> j \<Longrightarrow>
- sorted_list_of_set {i..j} = i # sorted_list_of_set {successor i..j}"
-apply(simp add:sorted_list_of_set_def upto_def)
-apply (rule the1_equality[OF finite_sorted_distinct_unique])
- apply (simp add:finite_intvl)
-apply(rule the1I2[OF finite_sorted_distinct_unique])
- apply (simp add:finite_intvl)
-apply (simp add: sorted_Cons insert_intvl Ball_def)
-apply (metis successor_incr leD less_imp_le order_trans)
-done
-
-lemma sorted_list_of_set_rec2: "i \<le> j \<Longrightarrow>
- sorted_list_of_set {i..successor j} =
- sorted_list_of_set {i..j} @ [successor j]"
-apply(simp add:sorted_list_of_set_def upto_def)
-apply (rule the1_equality[OF finite_sorted_distinct_unique])
- apply (simp add:finite_intvl)
-apply(rule the1I2[OF finite_sorted_distinct_unique])
- apply (simp add:finite_intvl)
-apply (simp add: sorted_append Ball_def expand_set_eq)
-apply(rule conjI)
-apply (metis eq_iff leD linear not_leE ord_discrete order_trans successor_incr)
-apply (metis leD linear order_trans successor_incr)
-done
-
-lemma upto_rec[code]: "[i..j] = (if i \<le> j then i # [successor i..j] else [])"
-by(simp add: upto_def sorted_list_of_set_rec)
-
-lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
-by(simp add: upto_rec)
-
-lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..successor j] = [i..j] @ [successor j]"
-by(simp add: upto_def sorted_list_of_set_rec2)
-
-end
-
-text{* The integers are an instance of the above class: *}
-
-instantiation int:: finite_intvl_succ
-begin
-
-definition
-successor_int_def[simp]: "successor = (%i\<Colon>int. i+1)"
-
-instance
-by intro_classes (simp_all add: successor_int_def)
-
-end
-
-text{* Now @{term"[i..j::int]"} is defined for integers. *}
-
-hide (open) const successor
-
-lemma upto_rec2_int: "(i::int) \<le> j \<Longrightarrow> [i..j+1] = [i..j] @ [j+1]"
-by(rule upto_rec2[where 'a = int, simplified successor_int_def])
-
-lemmas upto_rec_number_of_int[simp] = upto_rec[of "number_of m :: int" "number_of n", standard]
-
-
subsubsection {* @{text lists}: the list-forming operator over sets *}
inductive_set
@@ -3812,6 +3828,11 @@
"length (remdups xs) = length_unique xs"
by (induct xs) simp_all
+declare INFI_def [code_unfold]
+declare SUPR_def [code_unfold]
+
+declare set_map [symmetric, code_unfold]
+
hide (open) const length_unique
@@ -3829,9 +3850,7 @@
"{n<..<m} = set [Suc n..<m]"
by auto
-lemma atLeastLessThan_upt [code_unfold]:
- "{n..<m} = set [n..<m]"
-by auto
+lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
lemma greaterThanAtMost_upt [code_unfold]:
"{n<..m} = set [Suc n..<Suc m]"
@@ -3880,12 +3899,123 @@
"{i<..j::int} = set [i+1..j]"
by auto
-lemma atLeastAtMost_upto [code_unfold]:
- "{i..j::int} = set [i..j]"
-by auto
+lemmas atLeastAtMost_upto [code_unfold] = set_upto[symmetric]
lemma setsum_set_upto_conv_listsum [code_unfold]:
"setsum f (set [i..j::int]) = listsum (map f [i..j])"
by (rule setsum_set_distinct_conv_listsum) simp
+
+text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}
+and similiarly for @{text"\<exists>"}. *}
+
+function all_from_to_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
+"all_from_to_nat P i j =
+ (if i < j then if P i then all_from_to_nat P (i+1) j else False
+ else True)"
+by auto
+termination
+by (relation "measure(%(P,i,j). j - i)") auto
+
+declare all_from_to_nat.simps[simp del]
+
+lemma all_from_to_nat_iff_ball:
+ "all_from_to_nat P i j = (ALL n : {i ..< j}. P n)"
+proof(induct P i j rule:all_from_to_nat.induct)
+ case (1 P i j)
+ let ?yes = "i < j & P i"
+ show ?case
+ proof (cases)
+ assume ?yes
+ hence "all_from_to_nat P i j = (P i & all_from_to_nat P (i+1) j)"
+ by(simp add: all_from_to_nat.simps)
+ also have "... = (P i & (ALL n : {i+1 ..< j}. P n))" using `?yes` 1 by simp
+ also have "... = (ALL n : {i ..< j}. P n)" (is "?L = ?R")
+ proof
+ assume L: ?L
+ show ?R
+ proof clarify
+ fix n assume n: "n : {i..<j}"
+ show "P n"
+ proof cases
+ assume "n = i" thus "P n" using L by simp
+ next
+ assume "n ~= i"
+ hence "i+1 <= n" using n by auto
+ thus "P n" using L n by simp
+ qed
+ qed
+ next
+ assume R: ?R thus ?L using `?yes` 1 by auto
+ qed
+ finally show ?thesis .
+ next
+ assume "~?yes" thus ?thesis by(auto simp add: all_from_to_nat.simps)
+ qed
+qed
+
+
+lemma list_all_iff_all_from_to_nat[code_unfold]:
+ "list_all P [i..<j] = all_from_to_nat P i j"
+by(simp add: all_from_to_nat_iff_ball list_all_iff)
+
+lemma list_ex_iff_not_all_from_to_not_nat[code_unfold]:
+ "list_ex P [i..<j] = (~all_from_to_nat (%x. ~P x) i j)"
+by(simp add: all_from_to_nat_iff_ball list_ex_iff)
+
+
+function all_from_to_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
+"all_from_to_int P i j =
+ (if i <= j then if P i then all_from_to_int P (i+1) j else False
+ else True)"
+by auto
+termination
+by (relation "measure(%(P,i,j). nat(j - i + 1))") auto
+
+declare all_from_to_int.simps[simp del]
+
+lemma all_from_to_int_iff_ball:
+ "all_from_to_int P i j = (ALL n : {i .. j}. P n)"
+proof(induct P i j rule:all_from_to_int.induct)
+ case (1 P i j)
+ let ?yes = "i <= j & P i"
+ show ?case
+ proof (cases)
+ assume ?yes
+ hence "all_from_to_int P i j = (P i & all_from_to_int P (i+1) j)"
+ by(simp add: all_from_to_int.simps)
+ also have "... = (P i & (ALL n : {i+1 .. j}. P n))" using `?yes` 1 by simp
+ also have "... = (ALL n : {i .. j}. P n)" (is "?L = ?R")
+ proof
+ assume L: ?L
+ show ?R
+ proof clarify
+ fix n assume n: "n : {i..j}"
+ show "P n"
+ proof cases
+ assume "n = i" thus "P n" using L by simp
+ next
+ assume "n ~= i"
+ hence "i+1 <= n" using n by auto
+ thus "P n" using L n by simp
+ qed
+ qed
+ next
+ assume R: ?R thus ?L using `?yes` 1 by auto
+ qed
+ finally show ?thesis .
+ next
+ assume "~?yes" thus ?thesis by(auto simp add: all_from_to_int.simps)
+ qed
+qed
+
+lemma list_all_iff_all_from_to_int[code_unfold]:
+ "list_all P [i..j] = all_from_to_int P i j"
+by(simp add: all_from_to_int_iff_ball list_all_iff)
+
+lemma list_ex_iff_not_all_from_to_not_int[code_unfold]:
+ "list_ex P [i..j] = (~ all_from_to_int (%x. ~P x) i j)"
+by(simp add: all_from_to_int_iff_ball list_ex_iff)
+
+
end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Matrix/ComputeFloat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,568 @@
+(* Title: HOL/Tools/ComputeFloat.thy
+ Author: Steven Obua
+*)
+
+header {* Floating Point Representation of the Reals *}
+
+theory ComputeFloat
+imports Complex_Main
+uses "~~/src/Tools/float.ML" ("~~/src/HOL/Tools/float_arith.ML")
+begin
+
+definition
+ pow2 :: "int \<Rightarrow> real" where
+ "pow2 a = (if (0 <= a) then (2^(nat a)) else (inverse (2^(nat (-a)))))"
+
+definition
+ float :: "int * int \<Rightarrow> real" where
+ "float x = real (fst x) * pow2 (snd x)"
+
+lemma pow2_0[simp]: "pow2 0 = 1"
+by (simp add: pow2_def)
+
+lemma pow2_1[simp]: "pow2 1 = 2"
+by (simp add: pow2_def)
+
+lemma pow2_neg: "pow2 x = inverse (pow2 (-x))"
+by (simp add: pow2_def)
+
+lemma pow2_add1: "pow2 (1 + a) = 2 * (pow2 a)"
+proof -
+ have h: "! n. nat (2 + int n) - Suc 0 = nat (1 + int n)" by arith
+ have g: "! a b. a - -1 = a + (1::int)" by arith
+ have pos: "! n. pow2 (int n + 1) = 2 * pow2 (int n)"
+ apply (auto, induct_tac n)
+ apply (simp_all add: pow2_def)
+ apply (rule_tac m1="2" and n1="nat (2 + int na)" in ssubst[OF realpow_num_eq_if])
+ by (auto simp add: h)
+ show ?thesis
+ proof (induct a)
+ case (1 n)
+ from pos show ?case by (simp add: algebra_simps)
+ next
+ case (2 n)
+ show ?case
+ apply (auto)
+ apply (subst pow2_neg[of "- int n"])
+ apply (subst pow2_neg[of "-1 - int n"])
+ apply (auto simp add: g pos)
+ done
+ qed
+qed
+
+lemma pow2_add: "pow2 (a+b) = (pow2 a) * (pow2 b)"
+proof (induct b)
+ case (1 n)
+ show ?case
+ proof (induct n)
+ case 0
+ show ?case by simp
+ next
+ case (Suc m)
+ show ?case by (auto simp add: algebra_simps pow2_add1 prems)
+ qed
+next
+ case (2 n)
+ show ?case
+ proof (induct n)
+ case 0
+ show ?case
+ apply (auto)
+ apply (subst pow2_neg[of "a + -1"])
+ apply (subst pow2_neg[of "-1"])
+ apply (simp)
+ apply (insert pow2_add1[of "-a"])
+ apply (simp add: algebra_simps)
+ apply (subst pow2_neg[of "-a"])
+ apply (simp)
+ done
+ case (Suc m)
+ have a: "int m - (a + -2) = 1 + (int m - a + 1)" by arith
+ have b: "int m - -2 = 1 + (int m + 1)" by arith
+ show ?case
+ apply (auto)
+ apply (subst pow2_neg[of "a + (-2 - int m)"])
+ apply (subst pow2_neg[of "-2 - int m"])
+ apply (auto simp add: algebra_simps)
+ apply (subst a)
+ apply (subst b)
+ apply (simp only: pow2_add1)
+ apply (subst pow2_neg[of "int m - a + 1"])
+ apply (subst pow2_neg[of "int m + 1"])
+ apply auto
+ apply (insert prems)
+ apply (auto simp add: algebra_simps)
+ done
+ qed
+qed
+
+lemma "float (a, e) + float (b, e) = float (a + b, e)"
+by (simp add: float_def algebra_simps)
+
+definition
+ int_of_real :: "real \<Rightarrow> int" where
+ "int_of_real x = (SOME y. real y = x)"
+
+definition
+ real_is_int :: "real \<Rightarrow> bool" where
+ "real_is_int x = (EX (u::int). x = real u)"
+
+lemma real_is_int_def2: "real_is_int x = (x = real (int_of_real x))"
+by (auto simp add: real_is_int_def int_of_real_def)
+
+lemma float_transfer: "real_is_int ((real a)*(pow2 c)) \<Longrightarrow> float (a, b) = float (int_of_real ((real a)*(pow2 c)), b - c)"
+by (simp add: float_def real_is_int_def2 pow2_add[symmetric])
+
+lemma pow2_int: "pow2 (int c) = 2^c"
+by (simp add: pow2_def)
+
+lemma float_transfer_nat: "float (a, b) = float (a * 2^c, b - int c)"
+by (simp add: float_def pow2_int[symmetric] pow2_add[symmetric])
+
+lemma real_is_int_real[simp]: "real_is_int (real (x::int))"
+by (auto simp add: real_is_int_def int_of_real_def)
+
+lemma int_of_real_real[simp]: "int_of_real (real x) = x"
+by (simp add: int_of_real_def)
+
+lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real (int_of_real x) = x"
+by (auto simp add: int_of_real_def real_is_int_def)
+
+lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
+by (auto simp add: int_of_real_def real_is_int_def)
+
+lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
+apply (subst real_is_int_def2)
+apply (simp add: real_is_int_add_int_of_real real_int_of_real)
+done
+
+lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
+by (auto simp add: int_of_real_def real_is_int_def)
+
+lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
+apply (subst real_is_int_def2)
+apply (simp add: int_of_real_sub real_int_of_real)
+done
+
+lemma real_is_int_rep: "real_is_int x \<Longrightarrow> ?! (a::int). real a = x"
+by (auto simp add: real_is_int_def)
+
+lemma int_of_real_mult:
+ assumes "real_is_int a" "real_is_int b"
+ shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
+proof -
+ from prems have a: "?! (a'::int). real a' = a" by (rule_tac real_is_int_rep, auto)
+ from prems have b: "?! (b'::int). real b' = b" by (rule_tac real_is_int_rep, auto)
+ from a obtain a'::int where a':"a = real a'" by auto
+ from b obtain b'::int where b':"b = real b'" by auto
+ have r: "real a' * real b' = real (a' * b')" by auto
+ show ?thesis
+ apply (simp add: a' b')
+ apply (subst r)
+ apply (simp only: int_of_real_real)
+ done
+qed
+
+lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
+apply (subst real_is_int_def2)
+apply (simp add: int_of_real_mult)
+done
+
+lemma real_is_int_0[simp]: "real_is_int (0::real)"
+by (simp add: real_is_int_def int_of_real_def)
+
+lemma real_is_int_1[simp]: "real_is_int (1::real)"
+proof -
+ have "real_is_int (1::real) = real_is_int(real (1::int))" by auto
+ also have "\<dots> = True" by (simp only: real_is_int_real)
+ ultimately show ?thesis by auto
+qed
+
+lemma real_is_int_n1: "real_is_int (-1::real)"
+proof -
+ have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
+ also have "\<dots> = True" by (simp only: real_is_int_real)
+ ultimately show ?thesis by auto
+qed
+
+lemma real_is_int_number_of[simp]: "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
+proof -
+ have neg1: "real_is_int (-1::real)"
+ proof -
+ have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
+ also have "\<dots> = True" by (simp only: real_is_int_real)
+ ultimately show ?thesis by auto
+ qed
+
+ {
+ fix x :: int
+ have "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
+ unfolding number_of_eq
+ apply (induct x)
+ apply (induct_tac n)
+ apply (simp)
+ apply (simp)
+ apply (induct_tac n)
+ apply (simp add: neg1)
+ proof -
+ fix n :: nat
+ assume rn: "(real_is_int (of_int (- (int (Suc n)))))"
+ have s: "-(int (Suc (Suc n))) = -1 + - (int (Suc n))" by simp
+ show "real_is_int (of_int (- (int (Suc (Suc n)))))"
+ apply (simp only: s of_int_add)
+ apply (rule real_is_int_add)
+ apply (simp add: neg1)
+ apply (simp only: rn)
+ done
+ qed
+ }
+ note Abs_Bin = this
+ {
+ fix x :: int
+ have "? u. x = u"
+ apply (rule exI[where x = "x"])
+ apply (simp)
+ done
+ }
+ then obtain u::int where "x = u" by auto
+ with Abs_Bin show ?thesis by auto
+qed
+
+lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
+by (simp add: int_of_real_def)
+
+lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
+proof -
+ have 1: "(1::real) = real (1::int)" by auto
+ show ?thesis by (simp only: 1 int_of_real_real)
+qed
+
+lemma int_of_real_number_of[simp]: "int_of_real (number_of b) = number_of b"
+proof -
+ have "real_is_int (number_of b)" by simp
+ then have uu: "?! u::int. number_of b = real u" by (auto simp add: real_is_int_rep)
+ then obtain u::int where u:"number_of b = real u" by auto
+ have "number_of b = real ((number_of b)::int)"
+ by (simp add: number_of_eq real_of_int_def)
+ have ub: "number_of b = real ((number_of b)::int)"
+ by (simp add: number_of_eq real_of_int_def)
+ from uu u ub have unb: "u = number_of b"
+ by blast
+ have "int_of_real (number_of b) = u" by (simp add: u)
+ with unb show ?thesis by simp
+qed
+
+lemma float_transfer_even: "even a \<Longrightarrow> float (a, b) = float (a div 2, b+1)"
+ apply (subst float_transfer[where a="a" and b="b" and c="-1", simplified])
+ apply (simp_all add: pow2_def even_def real_is_int_def algebra_simps)
+ apply (auto)
+proof -
+ fix q::int
+ have a:"b - (-1\<Colon>int) = (1\<Colon>int) + b" by arith
+ show "(float (q, (b - (-1\<Colon>int)))) = (float (q, ((1\<Colon>int) + b)))"
+ by (simp add: a)
+qed
+
+lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
+by (rule zdiv_int)
+
+lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
+by (rule zmod_int)
+
+lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
+by arith
+
+function norm_float :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
+ "norm_float a b = (if a \<noteq> 0 \<and> even a then norm_float (a div 2) (b + 1)
+ else if a = 0 then (0, 0) else (a, b))"
+by auto
+
+termination by (relation "measure (nat o abs o fst)")
+ (auto intro: abs_div_2_less)
+
+lemma norm_float: "float x = float (split norm_float x)"
+proof -
+ {
+ fix a b :: int
+ have norm_float_pair: "float (a, b) = float (norm_float a b)"
+ proof (induct a b rule: norm_float.induct)
+ case (1 u v)
+ show ?case
+ proof cases
+ assume u: "u \<noteq> 0 \<and> even u"
+ with prems have ind: "float (u div 2, v + 1) = float (norm_float (u div 2) (v + 1))" by auto
+ with u have "float (u,v) = float (u div 2, v+1)" by (simp add: float_transfer_even)
+ then show ?thesis
+ apply (subst norm_float.simps)
+ apply (simp add: ind)
+ done
+ next
+ assume "~(u \<noteq> 0 \<and> even u)"
+ then show ?thesis
+ by (simp add: prems float_def)
+ qed
+ qed
+ }
+ note helper = this
+ have "? a b. x = (a,b)" by auto
+ then obtain a b where "x = (a, b)" by blast
+ then show ?thesis by (simp add: helper)
+qed
+
+lemma float_add_l0: "float (0, e) + x = x"
+ by (simp add: float_def)
+
+lemma float_add_r0: "x + float (0, e) = x"
+ by (simp add: float_def)
+
+lemma float_add:
+ "float (a1, e1) + float (a2, e2) =
+ (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1)
+ else float (a1*2^(nat (e1-e2))+a2, e2))"
+ apply (simp add: float_def algebra_simps)
+ apply (auto simp add: pow2_int[symmetric] pow2_add[symmetric])
+ done
+
+lemma float_add_assoc1:
+ "(x + float (y1, e1)) + float (y2, e2) = (float (y1, e1) + float (y2, e2)) + x"
+ by simp
+
+lemma float_add_assoc2:
+ "(float (y1, e1) + x) + float (y2, e2) = (float (y1, e1) + float (y2, e2)) + x"
+ by simp
+
+lemma float_add_assoc3:
+ "float (y1, e1) + (x + float (y2, e2)) = (float (y1, e1) + float (y2, e2)) + x"
+ by simp
+
+lemma float_add_assoc4:
+ "float (y1, e1) + (float (y2, e2) + x) = (float (y1, e1) + float (y2, e2)) + x"
+ by simp
+
+lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
+ by (simp add: float_def)
+
+lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
+ by (simp add: float_def)
+
+definition
+ lbound :: "real \<Rightarrow> real"
+where
+ "lbound x = min 0 x"
+
+definition
+ ubound :: "real \<Rightarrow> real"
+where
+ "ubound x = max 0 x"
+
+lemma lbound: "lbound x \<le> x"
+ by (simp add: lbound_def)
+
+lemma ubound: "x \<le> ubound x"
+ by (simp add: ubound_def)
+
+lemma float_mult:
+ "float (a1, e1) * float (a2, e2) =
+ (float (a1 * a2, e1 + e2))"
+ by (simp add: float_def pow2_add)
+
+lemma float_minus:
+ "- (float (a,b)) = float (-a, b)"
+ by (simp add: float_def)
+
+lemma zero_less_pow2:
+ "0 < pow2 x"
+proof -
+ {
+ fix y
+ have "0 <= y \<Longrightarrow> 0 < pow2 y"
+ by (induct y, induct_tac n, simp_all add: pow2_add)
+ }
+ note helper=this
+ show ?thesis
+ apply (case_tac "0 <= x")
+ apply (simp add: helper)
+ apply (subst pow2_neg)
+ apply (simp add: helper)
+ done
+qed
+
+lemma zero_le_float:
+ "(0 <= float (a,b)) = (0 <= a)"
+ apply (auto simp add: float_def)
+ apply (auto simp add: zero_le_mult_iff zero_less_pow2)
+ apply (insert zero_less_pow2[of b])
+ apply (simp_all)
+ done
+
+lemma float_le_zero:
+ "(float (a,b) <= 0) = (a <= 0)"
+ apply (auto simp add: float_def)
+ apply (auto simp add: mult_le_0_iff)
+ apply (insert zero_less_pow2[of b])
+ apply auto
+ done
+
+lemma float_abs:
+ "abs (float (a,b)) = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
+ apply (auto simp add: abs_if)
+ apply (simp_all add: zero_le_float[symmetric, of a b] float_minus)
+ done
+
+lemma float_zero:
+ "float (0, b) = 0"
+ by (simp add: float_def)
+
+lemma float_pprt:
+ "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
+ by (auto simp add: zero_le_float float_le_zero float_zero)
+
+lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
+ apply (simp add: float_def)
+ apply (rule pprt_eq_0)
+ apply (simp add: lbound_def)
+ done
+
+lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
+ apply (simp add: float_def)
+ apply (rule nprt_eq_0)
+ apply (simp add: ubound_def)
+ done
+
+lemma float_nprt:
+ "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
+ by (auto simp add: zero_le_float float_le_zero float_zero)
+
+lemma norm_0_1: "(0::_::number_ring) = Numeral0 & (1::_::number_ring) = Numeral1"
+ by auto
+
+lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
+ by simp
+
+lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
+ by simp
+
+lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
+ by simp
+
+lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
+ by simp
+
+lemma int_pow_0: "(a::int)^(Numeral0) = 1"
+ by simp
+
+lemma int_pow_1: "(a::int)^(Numeral1) = a"
+ by simp
+
+lemma zero_eq_Numeral0_nring: "(0::'a::number_ring) = Numeral0"
+ by simp
+
+lemma one_eq_Numeral1_nring: "(1::'a::number_ring) = Numeral1"
+ by simp
+
+lemma zero_eq_Numeral0_nat: "(0::nat) = Numeral0"
+ by simp
+
+lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
+ by simp
+
+lemma zpower_Pls: "(z::int)^Numeral0 = Numeral1"
+ by simp
+
+lemma zpower_Min: "(z::int)^((-1)::nat) = Numeral1"
+proof -
+ have 1:"((-1)::nat) = 0"
+ by simp
+ show ?thesis by (simp add: 1)
+qed
+
+lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
+ by simp
+
+lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
+ by simp
+
+lemma lift_bool: "x \<Longrightarrow> x=True"
+ by simp
+
+lemma nlift_bool: "~x \<Longrightarrow> x=False"
+ by simp
+
+lemma not_false_eq_true: "(~ False) = True" by simp
+
+lemma not_true_eq_false: "(~ True) = False" by simp
+
+lemmas binarith =
+ normalize_bin_simps
+ pred_bin_simps succ_bin_simps
+ add_bin_simps minus_bin_simps mult_bin_simps
+
+lemma int_eq_number_of_eq:
+ "(((number_of v)::int)=(number_of w)) = iszero ((number_of (v + uminus w))::int)"
+ by (rule eq_number_of_eq)
+
+lemma int_iszero_number_of_Pls: "iszero (Numeral0::int)"
+ by (simp only: iszero_number_of_Pls)
+
+lemma int_nonzero_number_of_Min: "~(iszero ((-1)::int))"
+ by simp
+
+lemma int_iszero_number_of_Bit0: "iszero ((number_of (Int.Bit0 w))::int) = iszero ((number_of w)::int)"
+ by simp
+
+lemma int_iszero_number_of_Bit1: "\<not> iszero ((number_of (Int.Bit1 w))::int)"
+ by simp
+
+lemma int_less_number_of_eq_neg: "(((number_of x)::int) < number_of y) = neg ((number_of (x + (uminus y)))::int)"
+ unfolding neg_def number_of_is_id by simp
+
+lemma int_not_neg_number_of_Pls: "\<not> (neg (Numeral0::int))"
+ by simp
+
+lemma int_neg_number_of_Min: "neg (-1::int)"
+ by simp
+
+lemma int_neg_number_of_Bit0: "neg ((number_of (Int.Bit0 w))::int) = neg ((number_of w)::int)"
+ by simp
+
+lemma int_neg_number_of_Bit1: "neg ((number_of (Int.Bit1 w))::int) = neg ((number_of w)::int)"
+ by simp
+
+lemma int_le_number_of_eq: "(((number_of x)::int) \<le> number_of y) = (\<not> neg ((number_of (y + (uminus x)))::int))"
+ unfolding neg_def number_of_is_id by (simp add: not_less)
+
+lemmas intarithrel =
+ int_eq_number_of_eq
+ lift_bool[OF int_iszero_number_of_Pls] nlift_bool[OF int_nonzero_number_of_Min] int_iszero_number_of_Bit0
+ lift_bool[OF int_iszero_number_of_Bit1] int_less_number_of_eq_neg nlift_bool[OF int_not_neg_number_of_Pls] lift_bool[OF int_neg_number_of_Min]
+ int_neg_number_of_Bit0 int_neg_number_of_Bit1 int_le_number_of_eq
+
+lemma int_number_of_add_sym: "((number_of v)::int) + number_of w = number_of (v + w)"
+ by simp
+
+lemma int_number_of_diff_sym: "((number_of v)::int) - number_of w = number_of (v + (uminus w))"
+ by simp
+
+lemma int_number_of_mult_sym: "((number_of v)::int) * number_of w = number_of (v * w)"
+ by simp
+
+lemma int_number_of_minus_sym: "- ((number_of v)::int) = number_of (uminus v)"
+ by simp
+
+lemmas intarith = int_number_of_add_sym int_number_of_minus_sym int_number_of_diff_sym int_number_of_mult_sym
+
+lemmas natarith = add_nat_number_of diff_nat_number_of mult_nat_number_of eq_nat_number_of less_nat_number_of
+
+lemmas powerarith = nat_number_of zpower_number_of_even
+ zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
+ zpower_Pls zpower_Min
+
+lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
+ float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound
+
+(* for use with the compute oracle *)
+lemmas arith = binarith intarith intarithrel natarith powerarith floatarith not_false_eq_true not_true_eq_false
+
+use "~~/src/HOL/Tools/float_arith.ML"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Matrix/ComputeHOL.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,191 @@
+theory ComputeHOL
+imports Complex_Main "~~/src/Tools/Compute_Oracle/Compute_Oracle"
+begin
+
+lemma Trueprop_eq_eq: "Trueprop X == (X == True)" by (simp add: atomize_eq)
+lemma meta_eq_trivial: "x == y \<Longrightarrow> x == y" by simp
+lemma meta_eq_imp_eq: "x == y \<Longrightarrow> x = y" by auto
+lemma eq_trivial: "x = y \<Longrightarrow> x = y" by auto
+lemma bool_to_true: "x :: bool \<Longrightarrow> x == True" by simp
+lemma transmeta_1: "x = y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
+lemma transmeta_2: "x == y \<Longrightarrow> y = z \<Longrightarrow> x = z" by simp
+lemma transmeta_3: "x == y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
+
+
+(**** compute_if ****)
+
+lemma If_True: "If True = (\<lambda> x y. x)" by ((rule ext)+,auto)
+lemma If_False: "If False = (\<lambda> x y. y)" by ((rule ext)+, auto)
+
+lemmas compute_if = If_True If_False
+
+(**** compute_bool ****)
+
+lemma bool1: "(\<not> True) = False" by blast
+lemma bool2: "(\<not> False) = True" by blast
+lemma bool3: "(P \<and> True) = P" by blast
+lemma bool4: "(True \<and> P) = P" by blast
+lemma bool5: "(P \<and> False) = False" by blast
+lemma bool6: "(False \<and> P) = False" by blast
+lemma bool7: "(P \<or> True) = True" by blast
+lemma bool8: "(True \<or> P) = True" by blast
+lemma bool9: "(P \<or> False) = P" by blast
+lemma bool10: "(False \<or> P) = P" by blast
+lemma bool11: "(True \<longrightarrow> P) = P" by blast
+lemma bool12: "(P \<longrightarrow> True) = True" by blast
+lemma bool13: "(True \<longrightarrow> P) = P" by blast
+lemma bool14: "(P \<longrightarrow> False) = (\<not> P)" by blast
+lemma bool15: "(False \<longrightarrow> P) = True" by blast
+lemma bool16: "(False = False) = True" by blast
+lemma bool17: "(True = True) = True" by blast
+lemma bool18: "(False = True) = False" by blast
+lemma bool19: "(True = False) = False" by blast
+
+lemmas compute_bool = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10 bool11 bool12 bool13 bool14 bool15 bool16 bool17 bool18 bool19
+
+
+(*** compute_pair ***)
+
+lemma compute_fst: "fst (x,y) = x" by simp
+lemma compute_snd: "snd (x,y) = y" by simp
+lemma compute_pair_eq: "((a, b) = (c, d)) = (a = c \<and> b = d)" by auto
+
+lemma prod_case_simp: "prod_case f (x,y) = f x y" by simp
+
+lemmas compute_pair = compute_fst compute_snd compute_pair_eq prod_case_simp
+
+(*** compute_option ***)
+
+lemma compute_the: "the (Some x) = x" by simp
+lemma compute_None_Some_eq: "(None = Some x) = False" by auto
+lemma compute_Some_None_eq: "(Some x = None) = False" by auto
+lemma compute_None_None_eq: "(None = None) = True" by auto
+lemma compute_Some_Some_eq: "(Some x = Some y) = (x = y)" by auto
+
+definition
+ option_case_compute :: "'b option \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
+where
+ "option_case_compute opt a f = option_case a f opt"
+
+lemma option_case_compute: "option_case = (\<lambda> a f opt. option_case_compute opt a f)"
+ by (simp add: option_case_compute_def)
+
+lemma option_case_compute_None: "option_case_compute None = (\<lambda> a f. a)"
+ apply (rule ext)+
+ apply (simp add: option_case_compute_def)
+ done
+
+lemma option_case_compute_Some: "option_case_compute (Some x) = (\<lambda> a f. f x)"
+ apply (rule ext)+
+ apply (simp add: option_case_compute_def)
+ done
+
+lemmas compute_option_case = option_case_compute option_case_compute_None option_case_compute_Some
+
+lemmas compute_option = compute_the compute_None_Some_eq compute_Some_None_eq compute_None_None_eq compute_Some_Some_eq compute_option_case
+
+(**** compute_list_length ****)
+
+lemma length_cons:"length (x#xs) = 1 + (length xs)"
+ by simp
+
+lemma length_nil: "length [] = 0"
+ by simp
+
+lemmas compute_list_length = length_nil length_cons
+
+(*** compute_list_case ***)
+
+definition
+ list_case_compute :: "'b list \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a"
+where
+ "list_case_compute l a f = list_case a f l"
+
+lemma list_case_compute: "list_case = (\<lambda> (a::'a) f (l::'b list). list_case_compute l a f)"
+ apply (rule ext)+
+ apply (simp add: list_case_compute_def)
+ done
+
+lemma list_case_compute_empty: "list_case_compute ([]::'b list) = (\<lambda> (a::'a) f. a)"
+ apply (rule ext)+
+ apply (simp add: list_case_compute_def)
+ done
+
+lemma list_case_compute_cons: "list_case_compute (u#v) = (\<lambda> (a::'a) f. (f (u::'b) v))"
+ apply (rule ext)+
+ apply (simp add: list_case_compute_def)
+ done
+
+lemmas compute_list_case = list_case_compute list_case_compute_empty list_case_compute_cons
+
+(*** compute_list_nth ***)
+(* Of course, you will need computation with nats for this to work \<dots> *)
+
+lemma compute_list_nth: "((x#xs) ! n) = (if n = 0 then x else (xs ! (n - 1)))"
+ by (cases n, auto)
+
+(*** compute_list ***)
+
+lemmas compute_list = compute_list_case compute_list_length compute_list_nth
+
+(*** compute_let ***)
+
+lemmas compute_let = Let_def
+
+(***********************)
+(* Everything together *)
+(***********************)
+
+lemmas compute_hol = compute_if compute_bool compute_pair compute_option compute_list compute_let
+
+ML {*
+signature ComputeHOL =
+sig
+ val prep_thms : thm list -> thm list
+ val to_meta_eq : thm -> thm
+ val to_hol_eq : thm -> thm
+ val symmetric : thm -> thm
+ val trans : thm -> thm -> thm
+end
+
+structure ComputeHOL : ComputeHOL =
+struct
+
+local
+fun lhs_of eq = fst (Thm.dest_equals (cprop_of eq));
+in
+fun rewrite_conv [] ct = raise CTERM ("rewrite_conv", [])
+ | rewrite_conv (eq :: eqs) ct =
+ Thm.instantiate (Thm.match (lhs_of eq, ct)) eq
+ handle Pattern.MATCH => rewrite_conv eqs ct;
+end
+
+val convert_conditions = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.try_conv (rewrite_conv [@{thm "Trueprop_eq_eq"}])))
+
+val eq_th = @{thm "HOL.eq_reflection"}
+val meta_eq_trivial = @{thm "ComputeHOL.meta_eq_trivial"}
+val bool_to_true = @{thm "ComputeHOL.bool_to_true"}
+
+fun to_meta_eq th = eq_th OF [th] handle THM _ => meta_eq_trivial OF [th] handle THM _ => bool_to_true OF [th]
+
+fun to_hol_eq th = @{thm "meta_eq_imp_eq"} OF [th] handle THM _ => @{thm "eq_trivial"} OF [th]
+
+fun prep_thms ths = map (convert_conditions o to_meta_eq) ths
+
+fun symmetric th = @{thm "HOL.sym"} OF [th] handle THM _ => @{thm "Pure.symmetric"} OF [th]
+
+local
+ val trans_HOL = @{thm "HOL.trans"}
+ val trans_HOL_1 = @{thm "ComputeHOL.transmeta_1"}
+ val trans_HOL_2 = @{thm "ComputeHOL.transmeta_2"}
+ val trans_HOL_3 = @{thm "ComputeHOL.transmeta_3"}
+ fun tr [] th1 th2 = trans_HOL OF [th1, th2]
+ | tr (t::ts) th1 th2 = (t OF [th1, th2] handle THM _ => tr ts th1 th2)
+in
+ fun trans th1 th2 = tr [trans_HOL, trans_HOL_1, trans_HOL_2, trans_HOL_3] th1 th2
+end
+
+end
+*}
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Matrix/ComputeNumeral.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,195 @@
+theory ComputeNumeral
+imports ComputeHOL ComputeFloat
+begin
+
+(* normalization of bit strings *)
+lemmas bitnorm = normalize_bin_simps
+
+(* neg for bit strings *)
+lemma neg1: "neg Int.Pls = False" by (simp add: Int.Pls_def)
+lemma neg2: "neg Int.Min = True" apply (subst Int.Min_def) by auto
+lemma neg3: "neg (Int.Bit0 x) = neg x" apply (simp add: neg_def) apply (subst Bit0_def) by auto
+lemma neg4: "neg (Int.Bit1 x) = neg x" apply (simp add: neg_def) apply (subst Bit1_def) by auto
+lemmas bitneg = neg1 neg2 neg3 neg4
+
+(* iszero for bit strings *)
+lemma iszero1: "iszero Int.Pls = True" by (simp add: Int.Pls_def iszero_def)
+lemma iszero2: "iszero Int.Min = False" apply (subst Int.Min_def) apply (subst iszero_def) by simp
+lemma iszero3: "iszero (Int.Bit0 x) = iszero x" apply (subst Int.Bit0_def) apply (subst iszero_def)+ by auto
+lemma iszero4: "iszero (Int.Bit1 x) = False" apply (subst Int.Bit1_def) apply (subst iszero_def)+ apply simp by arith
+lemmas bitiszero = iszero1 iszero2 iszero3 iszero4
+
+(* lezero for bit strings *)
+constdefs
+ "lezero x == (x \<le> 0)"
+lemma lezero1: "lezero Int.Pls = True" unfolding Int.Pls_def lezero_def by auto
+lemma lezero2: "lezero Int.Min = True" unfolding Int.Min_def lezero_def by auto
+lemma lezero3: "lezero (Int.Bit0 x) = lezero x" unfolding Int.Bit0_def lezero_def by auto
+lemma lezero4: "lezero (Int.Bit1 x) = neg x" unfolding Int.Bit1_def lezero_def neg_def by auto
+lemmas bitlezero = lezero1 lezero2 lezero3 lezero4
+
+(* equality for bit strings *)
+lemmas biteq = eq_bin_simps
+
+(* x < y for bit strings *)
+lemmas bitless = less_bin_simps
+
+(* x \<le> y for bit strings *)
+lemmas bitle = le_bin_simps
+
+(* succ for bit strings *)
+lemmas bitsucc = succ_bin_simps
+
+(* pred for bit strings *)
+lemmas bitpred = pred_bin_simps
+
+(* unary minus for bit strings *)
+lemmas bituminus = minus_bin_simps
+
+(* addition for bit strings *)
+lemmas bitadd = add_bin_simps
+
+(* multiplication for bit strings *)
+lemma mult_Pls_right: "x * Int.Pls = Int.Pls" by (simp add: Pls_def)
+lemma mult_Min_right: "x * Int.Min = - x" by (subst mult_commute, simp add: mult_Min)
+lemma multb0x: "(Int.Bit0 x) * y = Int.Bit0 (x * y)" by (rule mult_Bit0)
+lemma multxb0: "x * (Int.Bit0 y) = Int.Bit0 (x * y)" unfolding Bit0_def by simp
+lemma multb1: "(Int.Bit1 x) * (Int.Bit1 y) = Int.Bit1 (Int.Bit0 (x * y) + x + y)"
+ unfolding Bit0_def Bit1_def by (simp add: algebra_simps)
+lemmas bitmul = mult_Pls mult_Min mult_Pls_right mult_Min_right multb0x multxb0 multb1
+
+lemmas bitarith = bitnorm bitiszero bitneg bitlezero biteq bitless bitle bitsucc bitpred bituminus bitadd bitmul
+
+constdefs
+ "nat_norm_number_of (x::nat) == x"
+
+lemma nat_norm_number_of: "nat_norm_number_of (number_of w) = (if lezero w then 0 else number_of w)"
+ apply (simp add: nat_norm_number_of_def)
+ unfolding lezero_def iszero_def neg_def
+ apply (simp add: numeral_simps)
+ done
+
+(* Normalization of nat literals *)
+lemma natnorm0: "(0::nat) = number_of (Int.Pls)" by auto
+lemma natnorm1: "(1 :: nat) = number_of (Int.Bit1 Int.Pls)" by auto
+lemmas natnorm = natnorm0 natnorm1 nat_norm_number_of
+
+(* Suc *)
+lemma natsuc: "Suc (number_of x) = (if neg x then 1 else number_of (Int.succ x))" by (auto simp add: number_of_is_id)
+
+(* Addition for nat *)
+lemma natadd: "number_of x + ((number_of y)::nat) = (if neg x then (number_of y) else (if neg y then number_of x else (number_of (x + y))))"
+ unfolding nat_number_of_def number_of_is_id neg_def
+ by auto
+
+(* Subtraction for nat *)
+lemma natsub: "(number_of x) - ((number_of y)::nat) =
+ (if neg x then 0 else (if neg y then number_of x else (nat_norm_number_of (number_of (x + (- y))))))"
+ unfolding nat_norm_number_of
+ by (auto simp add: number_of_is_id neg_def lezero_def iszero_def Let_def nat_number_of_def)
+
+(* Multiplication for nat *)
+lemma natmul: "(number_of x) * ((number_of y)::nat) =
+ (if neg x then 0 else (if neg y then 0 else number_of (x * y)))"
+ unfolding nat_number_of_def number_of_is_id neg_def
+ by (simp add: nat_mult_distrib)
+
+lemma nateq: "(((number_of x)::nat) = (number_of y)) = ((lezero x \<and> lezero y) \<or> (x = y))"
+ by (auto simp add: iszero_def lezero_def neg_def number_of_is_id)
+
+lemma natless: "(((number_of x)::nat) < (number_of y)) = ((x < y) \<and> (\<not> (lezero y)))"
+ by (simp add: lezero_def numeral_simps not_le)
+
+lemma natle: "(((number_of x)::nat) \<le> (number_of y)) = (y < x \<longrightarrow> lezero x)"
+ by (auto simp add: number_of_is_id lezero_def nat_number_of_def)
+
+fun natfac :: "nat \<Rightarrow> nat"
+where
+ "natfac n = (if n = 0 then 1 else n * (natfac (n - 1)))"
+
+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)"
+ 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)"
+ unfolding number_of_eq
+ apply simp
+ done
+
+lemma number_less: "(((number_of x)::'a::{number_ring, ordered_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))"
+ apply (subst diff_number_of_eq)
+ apply simp
+ done
+
+lemmas number_norm = number_of_Pls[symmetric] numeral_1_eq_1[symmetric]
+
+lemmas compute_numberarith = number_of_minus[symmetric] number_of_add[symmetric] number_diff number_of_mult[symmetric] number_norm number_eq number_le number_less
+
+lemma compute_real_of_nat_number_of: "real ((number_of v)::nat) = (if neg v then 0 else number_of v)"
+ by (simp only: real_of_nat_number_of number_of_is_id)
+
+lemma compute_nat_of_int_number_of: "nat ((number_of v)::int) = (number_of v)"
+ by simp
+
+lemmas compute_num_conversions = compute_real_of_nat_number_of compute_nat_of_int_number_of real_number_of
+
+lemmas zpowerarith = zpower_number_of_even
+ zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
+ zpower_Pls zpower_Min
+
+(* div, mod *)
+
+lemma adjust: "adjust b (q, r) = (if 0 \<le> r - b then (2 * q + 1, r - b) else (2 * q, r))"
+ by (auto simp only: adjust_def)
+
+lemma negateSnd: "negateSnd (q, r) = (q, -r)"
+ by (simp add: negateSnd_def)
+
+lemma divmod: "IntDiv.divmod a b = (if 0\<le>a then
+ if 0\<le>b then posDivAlg a b
+ else if a=0 then (0, 0)
+ else negateSnd (negDivAlg (-a) (-b))
+ else
+ if 0<b then negDivAlg a b
+ else negateSnd (posDivAlg (-a) (-b)))"
+ by (auto simp only: IntDiv.divmod_def)
+
+lemmas compute_div_mod = div_def mod_def divmod adjust negateSnd posDivAlg.simps negDivAlg.simps
+
+
+
+(* collecting all the theorems *)
+
+lemma even_Pls: "even (Int.Pls) = True"
+ apply (unfold Pls_def even_def)
+ by simp
+
+lemma even_Min: "even (Int.Min) = False"
+ apply (unfold Min_def even_def)
+ by simp
+
+lemma even_B0: "even (Int.Bit0 x) = True"
+ apply (unfold Bit0_def)
+ by simp
+
+lemma even_B1: "even (Int.Bit1 x) = False"
+ apply (unfold Bit1_def)
+ by simp
+
+lemma even_number_of: "even ((number_of w)::int) = even w"
+ by (simp only: number_of_is_id)
+
+lemmas compute_even = even_Pls even_Min even_B0 even_B1 even_number_of
+
+lemmas compute_numeral = compute_if compute_let compute_pair compute_bool
+ compute_natarith compute_numberarith max_def min_def compute_num_conversions zpowerarith compute_div_mod compute_even
+
+end
--- a/src/HOL/Matrix/LP.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/LP.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Matrix/LP.thy
- ID: $Id$
Author: Steven Obua
*)
--- a/src/HOL/Matrix/Matrix.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/Matrix.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Matrix/Matrix.thy
- ID: $Id$
Author: Steven Obua
*)
@@ -1663,7 +1662,7 @@
apply (simp add: times_matrix_def Rep_mult_matrix)
apply (rule_tac j1="xa" in ssubst[OF foldseq_almostzero])
apply (simp_all)
-by (simp add: max_def ncols)
+by (simp add: ncols)
lemma one_matrix_mult_left[simp]: "nrows A <= n \<Longrightarrow> (one_matrix n) * A = (A::('a::ring_1) matrix)"
apply (subst Rep_matrix_inject[THEN sym])
@@ -1671,7 +1670,7 @@
apply (simp add: times_matrix_def Rep_mult_matrix)
apply (rule_tac j1="x" in ssubst[OF foldseq_almostzero])
apply (simp_all)
-by (simp add: max_def nrows)
+by (simp add: nrows)
lemma transpose_matrix_mult: "transpose_matrix ((A::('a::comm_ring) matrix)*B) = (transpose_matrix B) * (transpose_matrix A)"
apply (simp add: times_matrix_def)
--- a/src/HOL/Matrix/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,1 @@
-(* Title: HOL/Matrix/ROOT.ML
- ID: $Id$
-*)
-
use_thys ["SparseMatrix", "cplex/Cplex"];
--- a/src/HOL/Matrix/SparseMatrix.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/SparseMatrix.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Matrix/SparseMatrix.thy
- ID: $Id$
Author: Steven Obua
*)
--- a/src/HOL/Matrix/cplex/Cplex.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/cplex/Cplex.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,10 +1,9 @@
(* Title: HOL/Matrix/cplex/Cplex.thy
- ID: $Id$
Author: Steven Obua
*)
theory Cplex
-imports SparseMatrix LP "~~/src/HOL/Tools/ComputeFloat" "~~/src/HOL/Tools/ComputeNumeral"
+imports SparseMatrix LP ComputeFloat ComputeNumeral
uses "Cplex_tools.ML" "CplexMatrixConverter.ML" "FloatSparseMatrixBuilder.ML"
"fspmlp.ML" ("matrixlp.ML")
begin
--- a/src/HOL/Matrix/cplex/CplexMatrixConverter.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/cplex/CplexMatrixConverter.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Matrix/cplex/CplexMatrixConverter.ML
- ID: $Id$
Author: Steven Obua
*)
--- a/src/HOL/Matrix/cplex/Cplex_tools.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/cplex/Cplex_tools.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/Matrix/cplex/Cplex_tools.ML
- ID: $Id$
Author: Steven Obua
*)
@@ -63,7 +62,7 @@
datatype cplexSolver = SOLVER_DEFAULT | SOLVER_CPLEX | SOLVER_GLPK
-val cplexsolver = ref SOLVER_DEFAULT;
+val cplexsolver = Unsynchronized.ref SOLVER_DEFAULT;
fun get_solver () = !cplexsolver;
fun set_solver s = (cplexsolver := s);
@@ -306,8 +305,8 @@
fun load_cplexFile name =
let
val f = TextIO.openIn name
- val ignore_NL = ref true
- val rest = ref []
+ val ignore_NL = Unsynchronized.ref true
+ val rest = Unsynchronized.ref []
fun is_symbol s c = (fst c) = TOKEN_SYMBOL andalso (to_upper (snd c)) = s
@@ -613,7 +612,7 @@
fun basic_write s = TextIO.output(f, s)
- val linebuf = ref ""
+ val linebuf = Unsynchronized.ref ""
fun buf_flushline s =
(basic_write (!linebuf);
basic_write "\n";
@@ -861,7 +860,7 @@
val f = TextIO.openIn name
- val rest = ref []
+ val rest = Unsynchronized.ref []
fun readToken_helper () =
if length (!rest) > 0 then
@@ -996,7 +995,7 @@
val f = TextIO.openIn name
- val rest = ref []
+ val rest = Unsynchronized.ref []
fun readToken_helper () =
if length (!rest) > 0 then
--- a/src/HOL/Matrix/cplex/FloatSparseMatrixBuilder.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Matrix/cplex/FloatSparseMatrixBuilder.ML Thu Oct 01 07:40:25 2009 +0200
@@ -136,7 +136,7 @@
fun cplexProg c A b =
let
- val ytable = ref Inttab.empty
+ val ytable = Unsynchronized.ref Inttab.empty
fun indexof s =
if String.size s = 0 then raise (No_name s)
else case Int.fromString (String.extract(s, 1, NONE)) of
@@ -145,7 +145,7 @@
fun nameof i =
let
val s = "x"^(Int.toString i)
- val _ = change ytable (Inttab.update (i, s))
+ val _ = Unsynchronized.change ytable (Inttab.update (i, s))
in
s
end
@@ -242,7 +242,7 @@
fun cut_vector size v =
let
- val count = ref 0;
+ val count = Unsynchronized.ref 0;
fun app (i, s) = if (!count < size) then
(count := !count +1 ; Inttab.update (i, s))
else I
--- a/src/HOL/MetisExamples/Message.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MetisExamples/Message.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/MetisTest/Message.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Testing the metis method
@@ -711,17 +710,17 @@
proof (neg_clausify)
assume 0: "analz (synth H) \<noteq> analz H \<union> synth H"
have 1: "\<And>X1 X3. sup (analz (sup X3 X1)) (synth X3) = analz (sup (synth X3) X1)"
- by (metis analz_synth_Un sup_set_eq sup_set_eq sup_set_eq)
+ by (metis analz_synth_Un)
have 2: "sup (analz H) (synth H) \<noteq> analz (synth H)"
- by (metis 0 sup_set_eq)
+ by (metis 0)
have 3: "\<And>X1 X3. sup (synth X3) (analz (sup X3 X1)) = analz (sup (synth X3) X1)"
- by (metis 1 Un_commute sup_set_eq sup_set_eq)
+ by (metis 1 Un_commute)
have 4: "\<And>X3. sup (synth X3) (analz X3) = analz (sup (synth X3) {})"
- by (metis 3 Un_empty_right sup_set_eq)
+ by (metis 3 Un_empty_right)
have 5: "\<And>X3. sup (synth X3) (analz X3) = analz (synth X3)"
- by (metis 4 Un_empty_right sup_set_eq)
+ by (metis 4 Un_empty_right)
have 6: "\<And>X3. sup (analz X3) (synth X3) = analz (synth X3)"
- by (metis 5 Un_commute sup_set_eq sup_set_eq)
+ by (metis 5 Un_commute)
show "False"
by (metis 2 6)
qed
--- a/src/HOL/MetisExamples/set.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MetisExamples/set.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/MetisExamples/set.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Testing the metis method
@@ -36,23 +35,23 @@
assume 4: "(\<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X \<or> \<not> X \<subseteq> x) \<or> X \<noteq> Y \<union> Z"
assume 5: "\<And>V. ((\<not> Y \<subseteq> V \<or> \<not> Z \<subseteq> V) \<or> X \<subseteq> V) \<or> X = Y \<union> Z"
have 6: "sup Y Z = X \<or> Y \<subseteq> X"
- by (metis 0 sup_set_eq)
+ by (metis 0)
have 7: "sup Y Z = X \<or> Z \<subseteq> X"
- by (metis 1 sup_set_eq)
+ by (metis 1)
have 8: "\<And>X3. sup Y Z = X \<or> X \<subseteq> X3 \<or> \<not> Y \<subseteq> X3 \<or> \<not> Z \<subseteq> X3"
- by (metis 5 sup_set_eq)
+ by (metis 5)
have 9: "Y \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 2 sup_set_eq)
+ by (metis 2)
have 10: "Z \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 3 sup_set_eq)
+ by (metis 3)
have 11: "sup Y Z \<noteq> X \<or> \<not> X \<subseteq> x \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 4 sup_set_eq)
+ by (metis 4)
have 12: "Z \<subseteq> X"
- by (metis Un_upper2 sup_set_eq 7)
+ by (metis Un_upper2 7)
have 13: "\<And>X3. sup Y Z = X \<or> X \<subseteq> sup X3 Z \<or> \<not> Y \<subseteq> sup X3 Z"
- by (metis 8 Un_upper2 sup_set_eq)
+ by (metis 8 Un_upper2)
have 14: "Y \<subseteq> X"
- by (metis Un_upper1 sup_set_eq 6)
+ by (metis Un_upper1 6)
have 15: "Z \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X"
by (metis 10 12)
have 16: "Y \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X"
@@ -66,17 +65,17 @@
have 20: "Y \<subseteq> x \<or> sup Y Z \<noteq> X"
by (metis 16 14)
have 21: "sup Y Z = X \<or> X \<subseteq> sup Y Z"
- by (metis 13 Un_upper1 sup_set_eq)
+ by (metis 13 Un_upper1)
have 22: "sup Y Z = X \<or> \<not> sup Y Z \<subseteq> X"
by (metis equalityI 21)
have 23: "sup Y Z = X \<or> \<not> Z \<subseteq> X \<or> \<not> Y \<subseteq> X"
- by (metis 22 Un_least sup_set_eq)
+ by (metis 22 Un_least)
have 24: "sup Y Z = X \<or> \<not> Y \<subseteq> X"
by (metis 23 12)
have 25: "sup Y Z = X"
by (metis 24 14)
have 26: "\<And>X3. X \<subseteq> X3 \<or> \<not> Z \<subseteq> X3 \<or> \<not> Y \<subseteq> X3"
- by (metis Un_least sup_set_eq 25)
+ by (metis Un_least 25)
have 27: "Y \<subseteq> x"
by (metis 20 25)
have 28: "Z \<subseteq> x"
@@ -105,31 +104,31 @@
assume 4: "(\<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X \<or> \<not> X \<subseteq> x) \<or> X \<noteq> Y \<union> Z"
assume 5: "\<And>V. ((\<not> Y \<subseteq> V \<or> \<not> Z \<subseteq> V) \<or> X \<subseteq> V) \<or> X = Y \<union> Z"
have 6: "sup Y Z = X \<or> Y \<subseteq> X"
- by (metis 0 sup_set_eq)
+ by (metis 0)
have 7: "Y \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 2 sup_set_eq)
+ by (metis 2)
have 8: "sup Y Z \<noteq> X \<or> \<not> X \<subseteq> x \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 4 sup_set_eq)
+ by (metis 4)
have 9: "\<And>X3. sup Y Z = X \<or> X \<subseteq> sup X3 Z \<or> \<not> Y \<subseteq> sup X3 Z"
- by (metis 5 sup_set_eq Un_upper2 sup_set_eq)
+ by (metis 5 Un_upper2)
have 10: "Z \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X"
- by (metis 3 sup_set_eq Un_upper2 sup_set_eq sup_set_eq)
+ by (metis 3 Un_upper2)
have 11: "sup Y Z \<noteq> X \<or> \<not> X \<subseteq> x \<or> \<not> Y \<subseteq> X"
- by (metis 8 Un_upper2 sup_set_eq sup_set_eq)
+ by (metis 8 Un_upper2)
have 12: "Z \<subseteq> x \<or> sup Y Z \<noteq> X"
- by (metis 10 Un_upper1 sup_set_eq)
+ by (metis 10 Un_upper1)
have 13: "sup Y Z = X \<or> X \<subseteq> sup Y Z"
- by (metis 9 Un_upper1 sup_set_eq)
+ by (metis 9 Un_upper1)
have 14: "sup Y Z = X \<or> \<not> Z \<subseteq> X \<or> \<not> Y \<subseteq> X"
- by (metis equalityI 13 Un_least sup_set_eq)
+ by (metis equalityI 13 Un_least)
have 15: "sup Y Z = X"
- by (metis 14 sup_set_eq 1 sup_set_eq sup_set_eq 6)
+ by (metis 14 1 6)
have 16: "Y \<subseteq> x"
- by (metis 7 Un_upper2 sup_set_eq sup_set_eq Un_upper1 sup_set_eq 15)
+ by (metis 7 Un_upper2 Un_upper1 15)
have 17: "\<not> X \<subseteq> x"
- by (metis 11 Un_upper1 sup_set_eq 15)
+ by (metis 11 Un_upper1 15)
have 18: "X \<subseteq> x"
- by (metis Un_least sup_set_eq 15 12 15 16)
+ by (metis Un_least 15 12 15 16)
show "False"
by (metis 18 17)
qed
@@ -148,23 +147,23 @@
assume 4: "(\<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X \<or> \<not> X \<subseteq> x) \<or> X \<noteq> Y \<union> Z"
assume 5: "\<And>V. ((\<not> Y \<subseteq> V \<or> \<not> Z \<subseteq> V) \<or> X \<subseteq> V) \<or> X = Y \<union> Z"
have 6: "Z \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 3 sup_set_eq)
+ by (metis 3)
have 7: "\<And>X3. sup Y Z = X \<or> X \<subseteq> sup X3 Z \<or> \<not> Y \<subseteq> sup X3 Z"
- by (metis 5 sup_set_eq Un_upper2 sup_set_eq)
+ by (metis 5 Un_upper2)
have 8: "Y \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X"
- by (metis 2 sup_set_eq Un_upper2 sup_set_eq sup_set_eq)
+ by (metis 2 Un_upper2)
have 9: "Z \<subseteq> x \<or> sup Y Z \<noteq> X"
- by (metis 6 Un_upper2 sup_set_eq sup_set_eq Un_upper1 sup_set_eq sup_set_eq)
+ by (metis 6 Un_upper2 Un_upper1)
have 10: "sup Y Z = X \<or> \<not> sup Y Z \<subseteq> X"
- by (metis equalityI 7 Un_upper1 sup_set_eq)
+ by (metis equalityI 7 Un_upper1)
have 11: "sup Y Z = X"
- by (metis 10 Un_least sup_set_eq sup_set_eq 1 sup_set_eq sup_set_eq 0 sup_set_eq)
+ by (metis 10 Un_least 1 0)
have 12: "Z \<subseteq> x"
by (metis 9 11)
have 13: "X \<subseteq> x"
- by (metis Un_least sup_set_eq 11 12 8 Un_upper1 sup_set_eq sup_set_eq 11)
+ by (metis Un_least 11 12 8 Un_upper1 11)
show "False"
- by (metis 13 4 sup_set_eq Un_upper2 sup_set_eq sup_set_eq Un_upper1 sup_set_eq sup_set_eq 11)
+ by (metis 13 4 Un_upper2 Un_upper1 11)
qed
(*Example included in TPHOLs paper*)
@@ -183,19 +182,19 @@
assume 4: "(\<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X \<or> \<not> X \<subseteq> x) \<or> X \<noteq> Y \<union> Z"
assume 5: "\<And>V. ((\<not> Y \<subseteq> V \<or> \<not> Z \<subseteq> V) \<or> X \<subseteq> V) \<or> X = Y \<union> Z"
have 6: "sup Y Z \<noteq> X \<or> \<not> X \<subseteq> x \<or> \<not> Y \<subseteq> X \<or> \<not> Z \<subseteq> X"
- by (metis 4 sup_set_eq)
+ by (metis 4)
have 7: "Z \<subseteq> x \<or> sup Y Z \<noteq> X \<or> \<not> Y \<subseteq> X"
- by (metis 3 sup_set_eq Un_upper2 sup_set_eq sup_set_eq)
+ by (metis 3 Un_upper2)
have 8: "Z \<subseteq> x \<or> sup Y Z \<noteq> X"
- by (metis 7 Un_upper1 sup_set_eq sup_set_eq)
+ by (metis 7 Un_upper1)
have 9: "sup Y Z = X \<or> \<not> Z \<subseteq> X \<or> \<not> Y \<subseteq> X"
- by (metis equalityI 5 sup_set_eq Un_upper2 sup_set_eq Un_upper1 sup_set_eq Un_least sup_set_eq)
+ by (metis equalityI 5 Un_upper2 Un_upper1 Un_least)
have 10: "Y \<subseteq> x"
- by (metis 2 sup_set_eq Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq 9 Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq)
+ by (metis 2 Un_upper2 1 Un_upper1 0 9 Un_upper2 1 Un_upper1 0)
have 11: "X \<subseteq> x"
- by (metis Un_least sup_set_eq 9 Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq 8 9 Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq 10)
+ by (metis Un_least 9 Un_upper2 1 Un_upper1 0 8 9 Un_upper2 1 Un_upper1 0 10)
show "False"
- by (metis 11 6 Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq 9 Un_upper2 sup_set_eq 1 sup_set_eq Un_upper1 sup_set_eq 0 sup_set_eq)
+ by (metis 11 6 Un_upper2 1 Un_upper1 0 9 Un_upper2 1 Un_upper1 0)
qed
ML {*AtpWrapper.problem_name := "set__equal_union"*}
@@ -238,7 +237,7 @@
lemma (*singleton_example_2:*)
"\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
-by (metis Un_absorb2 Union_insert insertI1 insert_Diff insert_Diff_single subset_eq)
+by (metis Set.subsetI Union_upper insert_iff set_eq_subset)
lemma singleton_example_2:
"\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
@@ -275,8 +274,8 @@
apply (metis emptyE)
apply (metis insert_iff singletonE)
apply (metis insertCI singletonE zless_le)
-apply (metis insert_iff singletonE)
-apply (metis insert_iff singletonE)
+apply (metis Collect_def Collect_mem_eq)
+apply (metis Collect_def Collect_mem_eq)
apply (metis DiffE)
apply (metis pair_in_Id_conv)
done
--- a/src/HOL/MicroJava/BV/BVNoTypeError.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/BV/BVNoTypeError.thy Thu Oct 01 07:40:25 2009 +0200
@@ -145,7 +145,7 @@
method (G,C) (mn,fpTs) = Some (mD', rT', b') \<and> G \<turnstile> X \<preceq> Class C)"
(is "?app ST LT = ?P ST LT")
proof
- assume "?P ST LT" thus "?app ST LT" by (auto simp add: min_def list_all2_def)
+ assume "?P ST LT" thus "?app ST LT" by (auto simp add: list_all2_def)
next
assume app: "?app ST LT"
hence l: "length fpTs < length ST" by simp
@@ -153,7 +153,7 @@
proof -
have "ST = take (length fpTs) ST @ drop (length fpTs) ST" by simp
moreover from l have "length (take (length fpTs) ST) = length fpTs"
- by (simp add: min_def)
+ by simp
ultimately show ?thesis ..
qed
obtain apTs where
@@ -168,11 +168,11 @@
have "ST = (rev apTs) @ X # ST'" "length apTs = length fpTs" by auto
with app
show "?P ST LT"
- apply (clarsimp simp add: list_all2_def min_def)
+ apply (clarsimp simp add: list_all2_def)
apply ((rule exI)+, (rule conjI)?)+
apply auto
done
-qed
+qed
lemma approx_loc_len [simp]:
"approx_loc G hp loc LT \<Longrightarrow> length loc = length LT"
--- a/src/HOL/MicroJava/BV/Effect.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/BV/Effect.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/BV/Effect.thy
- ID: $Id$
Author: Gerwin Klein
Copyright 2000 Technische Universitaet Muenchen
*)
@@ -375,7 +374,7 @@
hence "?a \<and> 0 < length (drop (length fpTs) a)" (is "?a \<and> ?l")
by auto
hence "?a \<and> ?l \<and> length (rev (take (length fpTs) a)) = length fpTs"
- by (auto simp add: min_def)
+ by (auto)
hence "\<exists>apTs ST. a = rev apTs @ ST \<and> length apTs = length fpTs \<and> 0 < length ST"
by blast
hence "\<exists>apTs ST. a = rev apTs @ ST \<and> length apTs = length fpTs \<and> ST \<noteq> []"
@@ -391,7 +390,7 @@
with Pair
have "?app s \<Longrightarrow> ?P s" by (simp only:)
moreover
- have "?P s \<Longrightarrow> ?app s" by (unfold app_def) (clarsimp simp add: min_def)
+ have "?P s \<Longrightarrow> ?app s" by (clarsimp simp add: min_max.inf_absorb2)
ultimately
show ?thesis by (rule iffI)
qed
--- a/src/HOL/MicroJava/BV/LBVSpec.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/BV/LBVSpec.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/BV/LBVSpec.thy
- ID: $Id$
Author: Gerwin Klein
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -293,7 +292,7 @@
shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
proof -
from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
- with suc wtl show ?thesis by (simp add: min_def)
+ with suc wtl show ?thesis by (simp add: min_max.inf_absorb2)
qed
lemma (in lbv) wtl_all:
@@ -308,7 +307,7 @@
with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
from pc have "is!pc = drop pc is ! 0" by simp
with Cons have "is!pc = i" by simp
- with take pc show ?thesis by (auto simp add: min_def split: split_if_asm)
+ with take pc show ?thesis by (auto simp add: min_max.inf_absorb2)
qed
section "preserves-type"
--- a/src/HOL/MicroJava/BV/Typing_Framework_JVM.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/BV/Typing_Framework_JVM.thy Thu Oct 01 07:40:25 2009 +0200
@@ -140,7 +140,7 @@
apply fastsimp
apply (erule disjE)
- apply (clarsimp simp add: Un_subset_iff)
+ apply clarsimp
apply (drule method_wf_mdecl, assumption+)
apply (clarsimp simp add: wf_mdecl_def wf_mhead_def)
apply fastsimp
--- a/src/HOL/MicroJava/BV/Typing_Framework_err.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/BV/Typing_Framework_err.thy Thu Oct 01 07:40:25 2009 +0200
@@ -62,15 +62,9 @@
lemma bounded_err_stepI:
"\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
\<Longrightarrow> bounded (err_step n ap step) n"
-apply (unfold bounded_def)
-apply clarify
-apply (simp add: err_step_def split: err.splits)
-apply (simp add: error_def)
- apply blast
-apply (simp split: split_if_asm)
- apply (blast dest: in_map_sndD)
-apply (simp add: error_def)
-apply blast
+apply (clarsimp simp: bounded_def err_step_def split: err.splits)
+apply (simp add: error_def image_def)
+apply (blast dest: in_map_sndD)
done
--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/Comp/CorrCompTp.thy
- ID: $Id$
Author: Martin Strecker
*)
@@ -959,7 +958,7 @@
apply simp
apply (simp (no_asm_simp))+
apply simp
-apply (simp add: max_ssize_def max_of_list_append) apply (simp (no_asm_simp) add: max_def)
+apply (simp add: max_ssize_def max_of_list_append) apply (simp (no_asm_simp))
(* show check_type \<dots> *)
apply (subgoal_tac "((mt2 @ [Some sttp2]) ! length bc2) = Some sttp2")
@@ -973,7 +972,7 @@
apply (simp add: check_type_def)
apply (rule states_lower, assumption)
apply (simp (no_asm_simp) add: max_ssize_def max_of_list_append)
-apply (simp (no_asm_simp) add: max_of_list_def ssize_sto_def max_def)
+apply (simp (no_asm_simp) add: max_of_list_def ssize_sto_def)
apply (simp (no_asm_simp))+
done
@@ -988,7 +987,7 @@
apply (drule_tac x=sttp in spec, erule exE)
apply simp
apply (rule check_type_mono, assumption)
-apply (simp add: max_ssize_def max_of_list_def ssize_sto_def max_def split: prod.split)
+apply (simp add: max_ssize_def max_of_list_def ssize_sto_def split: prod.split)
done
(* ********************************************************************** *)
@@ -1058,8 +1057,7 @@
lemma bc_mt_corresp_New: "\<lbrakk>is_class cG cname \<rbrakk>
\<Longrightarrow> bc_mt_corresp [New cname] (pushST [Class cname]) (ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def pushST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1070,8 +1068,7 @@
bc_mt_corresp [Pop] (popST (Suc 0)) (T # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def popST_def wt_instr_altern_def eff_def norm_eff_def)
apply (simp add: max_ssize_def ssize_sto_def max_of_list_def)
- apply (simp add: max_def)
- apply (simp add: check_type_simps)
+ apply (simp add: check_type_simps min_max.sup_absorb1)
apply clarify
apply (rule_tac x="(length ST)" in exI)
apply simp+
@@ -1082,7 +1079,7 @@
\<Longrightarrow> bc_mt_corresp [Checkcast cname] (replST (Suc 0) (Class cname)) sttp cG rT mxr (Suc 0)"
apply (erule exE)+
apply (simp add: bc_mt_corresp_def replST_def wt_instr_altern_def eff_def norm_eff_def)
- apply (simp add: max_ssize_def max_of_list_def ssize_sto_def max_def)
+ apply (simp add: max_ssize_def max_of_list_def ssize_sto_def)
apply (simp add: check_type_simps)
apply clarify
apply (rule_tac x="Suc (length STo)" in exI)
@@ -1094,8 +1091,7 @@
\<Longrightarrow> bc_mt_corresp [LitPush val] (pushST [T]) sttp cG rT mxr (Suc 0)"
apply (subgoal_tac "\<exists> ST LT. sttp= (ST, LT)", (erule exE)+)
apply (simp add: bc_mt_corresp_def pushST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1114,8 +1110,7 @@
\<Longrightarrow> bc_mt_corresp [LitPush val] (pushST [T']) sttp cG rT mxr (Suc 0)"
apply (subgoal_tac "\<exists> ST LT. sttp= (ST, LT)", (erule exE)+)
apply (simp add: bc_mt_corresp_def pushST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1131,8 +1126,7 @@
\<Longrightarrow> bc_mt_corresp [Load i]
(\<lambda>(ST, LT). pushST [ok_val (LT ! i)] (ST, LT)) (ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def pushST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1153,10 +1147,10 @@
lemma bc_mt_corresp_Store_init: "\<lbrakk> i < length LT \<rbrakk>
\<Longrightarrow> bc_mt_corresp [Store i] (storeST i T) (T # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def storeST_def wt_instr_altern_def eff_def norm_eff_def)
- apply (simp add: max_ssize_def max_of_list_def )
- apply (simp add: ssize_sto_def) apply (simp add: max_def)
+ apply (simp add: max_ssize_def max_of_list_def)
+ apply (simp add: ssize_sto_def)
apply (intro strip)
-apply (simp add: check_type_simps)
+apply (simp add: check_type_simps min_max.sup_absorb1)
apply clarify
apply (rule conjI)
apply (rule_tac x="(length ST)" in exI)
@@ -1164,15 +1158,13 @@
done
-
lemma bc_mt_corresp_Store: "\<lbrakk> i < length LT; cG \<turnstile> LT[i := OK T] <=l LT \<rbrakk>
\<Longrightarrow> bc_mt_corresp [Store i] (popST (Suc 0)) (T # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def popST_def wt_instr_altern_def eff_def norm_eff_def)
apply (simp add: sup_state_conv)
apply (simp add: max_ssize_def max_of_list_def ssize_sto_def)
- apply (simp add: max_def)
apply (intro strip)
-apply (simp add: check_type_simps)
+apply (simp add: check_type_simps min_max.sup_absorb1)
apply clarify
apply (rule_tac x="(length ST)" in exI)
apply simp+
@@ -1182,8 +1174,7 @@
lemma bc_mt_corresp_Dup: "
bc_mt_corresp [Dup] dupST (T # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def dupST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1196,8 +1187,7 @@
lemma bc_mt_corresp_Dup_x1: "
bc_mt_corresp [Dup_x1] dup_x1ST (T1 # T2 # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def dup_x1ST_def wt_instr_altern_def
- max_ssize_def max_of_list_def ssize_sto_def max_def
- eff_def norm_eff_def)
+ max_ssize_def max_of_list_def ssize_sto_def eff_def norm_eff_def min_max.sup_absorb2)
apply (intro strip)
apply (rule conjI)
apply (rule check_type_mono, assumption, simp)
@@ -1213,8 +1203,8 @@
bc_mt_corresp [IAdd] (replST 2 (PrimT Integer))
(PrimT Integer # PrimT Integer # ST, LT) cG rT mxr (Suc 0)"
apply (simp add: bc_mt_corresp_def replST_def wt_instr_altern_def eff_def norm_eff_def)
- apply (simp add: max_ssize_def max_of_list_def ssize_sto_def max_def)
- apply (simp add: check_type_simps)
+ apply (simp add: max_ssize_def max_of_list_def ssize_sto_def)
+ apply (simp add: check_type_simps min_max.sup_absorb1)
apply clarify
apply (rule_tac x="Suc (length ST)" in exI)
apply simp+
@@ -1254,10 +1244,10 @@
apply (frule widen_field, assumption+)
apply (simp add: bc_mt_corresp_def popST_def wt_instr_altern_def eff_def norm_eff_def)
apply (simp add: comp_field comp_subcls1 comp_widen comp_is_class)
- apply (simp add: max_ssize_def max_of_list_def ssize_sto_def max_def)
+ apply (simp add: max_ssize_def max_of_list_def ssize_sto_def)
apply (intro strip)
-apply (simp add: check_type_simps)
+apply (simp add: check_type_simps min_max.sup_absorb1)
apply clarify
apply (rule_tac x="Suc (length ST)" in exI)
apply simp+
@@ -1305,7 +1295,7 @@
apply (simp add: max_spec_preserves_length [THEN sym])
-- "@{text check_type}"
-apply (simp add: max_ssize_def ssize_sto_def max_def)
+apply (simp add: max_ssize_def ssize_sto_def)
apply (simp add: max_of_list_def)
apply (subgoal_tac "(max (length pTsa + length ST) (length ST)) = (length pTsa + length ST)")
apply simp
@@ -1316,7 +1306,7 @@
apply (simp only: comp_is_type)
apply (frule method_wf_mdecl) apply assumption apply assumption
apply (simp add: wf_mdecl_def wf_mhead_def)
-apply (simp add: max_def)
+apply (simp)
done
@@ -1473,7 +1463,7 @@
apply (case_tac "sttp1", simp)
apply (rule check_type_lower) apply assumption
apply (simp (no_asm_simp) add: max_ssize_def ssize_sto_def)
-apply (simp (no_asm_simp) add: max_of_list_def max_def)
+apply (simp (no_asm_simp) add: max_of_list_def)
(* subgoals \<exists> ... *)
apply (rule surj_pair)+
--- a/src/HOL/MicroJava/J/TypeRel.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/MicroJava/J/TypeRel.thy Thu Oct 01 07:40:25 2009 +0200
@@ -97,6 +97,14 @@
qed
qed
+text {* Code generator setup (FIXME!) *}
+
+consts_code
+ "wfrec" ("\<module>wfrec?")
+attach {*
+fun wfrec f x = f (wfrec f) x;
+*}
+
consts
method :: "'c prog \<times> cname => ( sig \<rightharpoonup> cname \<times> ty \<times> 'c)" (* ###curry *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Mirabelle.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,25 @@
+(* Title: HOL/Mirabelle/Mirabelle.thy
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+theory Mirabelle
+imports Pure
+uses "Tools/mirabelle.ML"
+begin
+
+(* no multithreading, no parallel proofs *)
+ML {* Multithreading.max_threads := 1 *}
+ML {* Goal.parallel_proofs := 0 *}
+
+ML {* Toplevel.add_hook Mirabelle.step_hook *}
+
+setup Mirabelle.setup
+
+ML {*
+signature MIRABELLE_ACTION =
+sig
+ val invoke : (string * string) list -> theory -> theory
+end
+*}
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Mirabelle_Test.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,22 @@
+(* Title: HOL/Mirabelle/Mirabelle_Test.thy
+ Author: Sascha Boehme, TU Munich
+*)
+
+header {* Simple test theory for Mirabelle actions *}
+
+theory Mirabelle_Test
+imports Main Mirabelle
+uses
+ "Tools/mirabelle_arith.ML"
+ "Tools/mirabelle_metis.ML"
+ "Tools/mirabelle_quickcheck.ML"
+ "Tools/mirabelle_refute.ML"
+ "Tools/mirabelle_sledgehammer.ML"
+begin
+
+text {*
+ Only perform type-checking of the actions,
+ any reasonable test would be too complicated.
+*}
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1 @@
+use_thy "Mirabelle_Test";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,218 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle.ML
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+signature MIRABELLE =
+sig
+ (*configuration*)
+ val logfile : string Config.T
+ val timeout : int Config.T
+ val start_line : int Config.T
+ val end_line : int Config.T
+ val setup : theory -> theory
+
+ (*core*)
+ type init_action = int -> theory -> theory
+ type done_args = {last: Toplevel.state, log: string -> unit}
+ type done_action = int -> done_args -> unit
+ type run_args = {pre: Proof.state, post: Toplevel.state option,
+ timeout: Time.time, log: string -> unit, pos: Position.T, name: string}
+ type run_action = int -> run_args -> unit
+ type action = init_action * run_action * done_action
+ val catch : (int -> string) -> run_action -> run_action
+ val register : action -> theory -> theory
+ val step_hook : Toplevel.transition -> Toplevel.state -> Toplevel.state ->
+ unit
+
+ (*utility functions*)
+ val goal_thm_of : Proof.state -> thm
+ val can_apply : Time.time -> (Proof.context -> int -> tactic) ->
+ Proof.state -> bool
+ val theorems_in_proof_term : Thm.thm -> Thm.thm list
+ val theorems_of_sucessful_proof : Toplevel.state option -> Thm.thm list
+ val get_setting : (string * string) list -> string * string -> string
+ val get_int_setting : (string * string) list -> string * int -> int
+ val cpu_time : ('a -> 'b) -> 'a -> 'b * int
+end
+
+
+
+structure Mirabelle : MIRABELLE =
+struct
+
+(* Mirabelle configuration *)
+
+val (logfile, setup1) = Attrib.config_string "mirabelle_logfile" ""
+val (timeout, setup2) = Attrib.config_int "mirabelle_timeout" 30
+val (start_line, setup3) = Attrib.config_int "mirabelle_start_line" 0
+val (end_line, setup4) = Attrib.config_int "mirabelle_end_line" ~1
+
+val setup = setup1 #> setup2 #> setup3 #> setup4
+
+
+(* Mirabelle core *)
+
+type init_action = int -> theory -> theory
+type done_args = {last: Toplevel.state, log: string -> unit}
+type done_action = int -> done_args -> unit
+type run_args = {pre: Proof.state, post: Toplevel.state option,
+ timeout: Time.time, log: string -> unit, pos: Position.T, name: string}
+type run_action = int -> run_args -> unit
+type action = init_action * run_action * done_action
+
+structure Actions = TheoryDataFun
+(
+ type T = (int * run_action * done_action) list
+ val empty = []
+ val copy = I
+ val extend = I
+ fun merge _ = Library.merge (K true)
+)
+
+
+fun app_with f g x = (g x; ())
+ handle (exn as Exn.Interrupt) => reraise exn | exn => (f exn; ())
+
+fun catch tag f id (st as {log, ...}: run_args) =
+ let fun log_exn e = log (tag id ^ "exception:\n" ^ General.exnMessage e)
+ in app_with log_exn (f id) st end
+
+fun register (init, run, done) thy =
+ let val id = length (Actions.get thy) + 1
+ in
+ thy
+ |> init id
+ |> Actions.map (cons (id, run, done))
+ end
+
+local
+
+fun log thy s =
+ let fun append_to n = if n = "" then K () else File.append (Path.explode n)
+ in append_to (Config.get_thy thy logfile) (s ^ "\n") end
+ (* FIXME: with multithreading and parallel proofs enabled, we might need to
+ encapsulate this inside a critical section *)
+
+fun log_sep thy = log thy "------------------"
+
+fun apply_actions thy pos name info (pre, post, time) actions =
+ let
+ fun apply f = f {pre=pre, post=post, timeout=time, log=log thy, pos=pos, name=name}
+ fun run (id, run, _) = (apply (run id); log_sep thy)
+ in (log thy info; log_sep thy; List.app run actions) end
+
+fun in_range _ _ NONE = true
+ | in_range l r (SOME i) = (l <= i andalso (r < 0 orelse i <= r))
+
+fun only_within_range thy pos f x =
+ let val l = Config.get_thy thy start_line and r = Config.get_thy thy end_line
+ in if in_range l r (Position.line_of pos) then f x else () end
+
+in
+
+fun run_actions tr pre post =
+ let
+ val thy = Proof.theory_of pre
+ val pos = Toplevel.pos_of tr
+ val name = Toplevel.name_of tr
+ val st = (pre, post, Time.fromSeconds (Config.get_thy thy timeout))
+
+ val str0 = string_of_int o the_default 0
+ val loc = str0 (Position.line_of pos) ^ ":" ^ str0 (Position.column_of pos)
+ val info = "\n\nat " ^ loc ^ " (" ^ name ^ "):"
+ in
+ only_within_range thy pos (apply_actions thy pos name info st) (Actions.get thy)
+ end
+
+fun done_actions st =
+ let
+ val thy = Toplevel.theory_of st
+ val _ = log thy "\n\n";
+ in
+ thy
+ |> Actions.get
+ |> List.app (fn (id, _, done) => done id {last=st, log=log thy})
+ end
+
+end
+
+val whitelist = ["apply", "by", "proof"]
+
+fun step_hook tr pre post =
+ (* FIXME: might require wrapping into "interruptible" *)
+ if can (Proof.assert_backward o Toplevel.proof_of) pre andalso
+ member (op =) whitelist (Toplevel.name_of tr)
+ then run_actions tr (Toplevel.proof_of pre) (SOME post)
+ else if not (Toplevel.is_toplevel pre) andalso Toplevel.is_toplevel post
+ then done_actions pre
+ else () (* FIXME: add theory_hook here *)
+
+
+
+(* Mirabelle utility functions *)
+
+val goal_thm_of = snd o snd o Proof.get_goal
+
+fun can_apply time tac st =
+ let
+ val (ctxt, (facts, goal)) = Proof.get_goal st
+ val full_tac = HEADGOAL (Method.insert_tac facts THEN' tac ctxt)
+ in
+ (case TimeLimit.timeLimit time (Seq.pull o full_tac) goal of
+ SOME (thm, _) => true
+ | NONE => false)
+ end
+
+local
+
+fun fold_body_thms f =
+ let
+ fun app n (PBody {thms, ...}) = thms |> fold (fn (i, (name, prop, body)) =>
+ fn (x, seen) =>
+ if Inttab.defined seen i then (x, seen)
+ else
+ let
+ val body' = Future.join body
+ val (x', seen') = app (n + (if name = "" then 0 else 1)) body'
+ (x, Inttab.update (i, ()) seen)
+ in (x' |> n = 0 ? f (name, prop, body'), seen') end)
+ in fn bodies => fn x => #1 (fold (app 0) bodies (x, Inttab.empty)) end
+
+in
+
+fun theorems_in_proof_term thm =
+ let
+ val all_thms = PureThy.all_thms_of (Thm.theory_of_thm thm)
+ fun collect (s, _, _) = if s <> "" then insert (op =) s else I
+ fun member_of xs (x, y) = if member (op =) xs x then SOME y else NONE
+ fun resolve_thms names = map_filter (member_of names) all_thms
+ in
+ resolve_thms (fold_body_thms collect [Thm.proof_body_of thm] [])
+ end
+
+end
+
+fun theorems_of_sucessful_proof state =
+ (case state of
+ NONE => []
+ | SOME st =>
+ if not (Toplevel.is_proof st) then []
+ else theorems_in_proof_term (goal_thm_of (Toplevel.proof_of st)))
+
+fun get_setting settings (key, default) =
+ the_default default (AList.lookup (op =) settings key)
+
+fun get_int_setting settings (key, default) =
+ (case Option.map Int.fromString (AList.lookup (op =) settings key) of
+ SOME (SOME i) => i
+ | SOME NONE => error ("bad option: " ^ key)
+ | NONE => default)
+
+fun cpu_time f x =
+ let
+ val start = start_timing ()
+ val result = Exn.capture (fn () => f x) ()
+ val time = Time.toMilliseconds (#cpu (end_timing start))
+ in (Exn.release result, time) end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_arith.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,21 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle_arith.ML
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+structure Mirabelle_Arith : MIRABELLE_ACTION =
+struct
+
+fun arith_tag id = "#" ^ string_of_int id ^ " arith: "
+
+fun init _ = I
+fun done _ _ = ()
+
+fun run id ({pre, timeout, log, ...}: Mirabelle.run_args) =
+ if Mirabelle.can_apply timeout Arith_Data.arith_tac pre
+ then log (arith_tag id ^ "succeeded")
+ else ()
+ handle TimeLimit.TimeOut => log (arith_tag id ^ "timeout")
+
+fun invoke _ = Mirabelle.register (init, Mirabelle.catch arith_tag run, done)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_metis.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,33 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle_metis.ML
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+structure Mirabelle_Metis : MIRABELLE_ACTION =
+struct
+
+fun metis_tag id = "#" ^ string_of_int id ^ " metis: "
+
+fun init _ = I
+fun done _ _ = ()
+
+fun run id ({pre, post, timeout, log, ...}: Mirabelle.run_args) =
+ let
+ val thms = Mirabelle.theorems_of_sucessful_proof post
+ val names = map Thm.get_name thms
+ val add_info = if null names then I else suffix (":\n" ^ commas names)
+
+ val facts = Facts.props (ProofContext.facts_of (Proof.context_of pre))
+
+ fun metis ctxt = MetisTools.metis_tac ctxt (thms @ facts)
+ in
+ (if Mirabelle.can_apply timeout metis pre then "succeeded" else "failed")
+ |> prefix (metis_tag id)
+ |> add_info
+ |> log
+ end
+ handle TimeLimit.TimeOut => log (metis_tag id ^ "timeout")
+ | ERROR msg => log (metis_tag id ^ "error: " ^ msg)
+
+fun invoke _ = Mirabelle.register (init, Mirabelle.catch metis_tag run, done)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_quickcheck.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,28 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle_quickcheck.ML
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+structure Mirabelle_Quickcheck : MIRABELLE_ACTION =
+struct
+
+fun qc_tag id = "#" ^ string_of_int id ^ " quickcheck: "
+
+fun init _ = I
+fun done _ _ = ()
+
+fun run args id ({pre, timeout, log, ...}: Mirabelle.run_args) =
+ let
+ val has_valid_key = member (op =) ["iterations", "size", "generator"] o fst
+ val quickcheck = Quickcheck.quickcheck (filter has_valid_key args) 1
+ in
+ (case TimeLimit.timeLimit timeout quickcheck pre of
+ NONE => log (qc_tag id ^ "no counterexample")
+ | SOME _ => log (qc_tag id ^ "counterexample found"))
+ end
+ handle TimeLimit.TimeOut => log (qc_tag id ^ "timeout")
+ | ERROR msg => log (qc_tag id ^ "error: " ^ msg)
+
+fun invoke args =
+ Mirabelle.register (init, Mirabelle.catch qc_tag (run args), done)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_refute.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,39 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle_refute.ML
+ Author: Jasmin Blanchette and Sascha Boehme, TU Munich
+*)
+
+structure Mirabelle_Refute : MIRABELLE_ACTION =
+struct
+
+
+(* FIXME:
+fun refute_action args timeout {pre=st, ...} =
+ let
+ val subgoal = 0
+ val thy = Proof.theory_of st
+ val thm = goal_thm_of st
+
+ val refute = Refute.refute_subgoal thy args thm
+ val _ = TimeLimit.timeLimit timeout refute subgoal
+ in
+ val writ_log = Substring.full (the (Symtab.lookup tab "writeln"))
+ val warn_log = Substring.full (the (Symtab.lookup tab "warning"))
+
+ val r =
+ if Substring.isSubstring "model found" writ_log
+ then
+ if Substring.isSubstring "spurious" warn_log
+ then SOME "potential counterexample"
+ else SOME "real counterexample (bug?)"
+ else
+ if Substring.isSubstring "time limit" writ_log
+ then SOME "no counterexample (timeout)"
+ else if Substring.isSubstring "Search terminated" writ_log
+ then SOME "no counterexample (normal termination)"
+ else SOME "no counterexample (unknown)"
+ in r end
+*)
+
+fun invoke args = I (*Mirabelle.register ("refute", refute_action args)*)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,444 @@
+(* Title: HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML
+ Author: Jasmin Blanchette and Sascha Boehme and Tobias Nipkow, TU Munich
+*)
+
+structure Mirabelle_Sledgehammer : MIRABELLE_ACTION =
+struct
+
+val proverK = "prover"
+val prover_timeoutK = "prover_timeout"
+val prover_hard_timeoutK = "prover_hard_timeout"
+val keepK = "keep"
+val full_typesK = "full_types"
+val minimizeK = "minimize"
+val minimize_timeoutK = "minimize_timeout"
+
+fun sh_tag id = "#" ^ string_of_int id ^ " sledgehammer: "
+fun minimize_tag id = "#" ^ string_of_int id ^ " minimize (sledgehammer): "
+fun metis_tag id = "#" ^ string_of_int id ^ " metis (sledgehammer): "
+
+val separator = "-----"
+
+
+datatype sh_data = ShData of {
+ calls: int,
+ success: int,
+ lemmas: int,
+ time_isa: int,
+ time_atp: int,
+ time_atp_fail: int}
+
+datatype me_data = MeData of {
+ calls: int,
+ success: int,
+ proofs: int,
+ time: int,
+ timeout: int,
+ lemmas: int,
+ posns: Position.T list
+ }
+
+datatype min_data = MinData of {
+ succs: int,
+ ab_ratios: int,
+ it_ratios: int
+ }
+
+(* The first me_data component is only used if "minimize" is on.
+ Then it records how metis behaves with un-minimized lemmas.
+*)
+datatype data = Data of sh_data * me_data * min_data * me_data
+
+fun make_sh_data (calls,success,lemmas,time_isa,time_atp,time_atp_fail) =
+ ShData{calls=calls, success=success, lemmas=lemmas, time_isa=time_isa,
+ time_atp=time_atp, time_atp_fail=time_atp_fail}
+
+fun make_min_data (succs, ab_ratios, it_ratios) =
+ MinData{succs=succs, ab_ratios=ab_ratios, it_ratios=it_ratios}
+
+fun make_me_data (calls, success, proofs, time, timeout, lemmas, posns) =
+ MeData{calls=calls, success=success, proofs=proofs, time=time, timeout=timeout, lemmas=lemmas, posns=posns}
+
+val empty_data =
+ Data(make_sh_data (0, 0, 0, 0, 0, 0),
+ make_me_data(0, 0, 0, 0, 0, 0, []),
+ MinData{succs=0, ab_ratios=0, it_ratios=0},
+ make_me_data(0, 0, 0, 0, 0, 0, []))
+
+fun map_sh_data f
+ (Data (ShData{calls, success, lemmas, time_isa, time_atp, time_atp_fail}, meda0, minda, meda)) =
+ Data (make_sh_data (f (calls, success, lemmas, time_isa, time_atp, time_atp_fail)),
+ meda0, minda, meda)
+
+fun map_min_data f
+ (Data(shda, meda0, MinData{succs,ab_ratios,it_ratios}, meda)) =
+ Data(shda, meda0, make_min_data(f(succs,ab_ratios,it_ratios)), meda)
+
+fun map_me_data0 f (Data (shda, MeData{calls,success,proofs,time,timeout,lemmas,posns}, minda, meda)) =
+ Data(shda, make_me_data(f (calls,success,proofs,time,timeout,lemmas,posns)), minda, meda)
+
+fun map_me_data f (Data (shda, meda0, minda, MeData{calls,success,proofs,time,timeout,lemmas,posns})) =
+ Data(shda, meda0, minda, make_me_data(f (calls,success,proofs,time,timeout,lemmas,posns)))
+
+val inc_sh_calls =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls + 1, success, lemmas, time_isa, time_atp, time_atp_fail))
+
+val inc_sh_success =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls, success + 1, lemmas, time_isa, time_atp, time_atp_fail))
+
+fun inc_sh_lemmas n =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls, success, lemmas + n, time_isa, time_atp, time_atp_fail))
+
+fun inc_sh_time_isa t =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls, success, lemmas, time_isa + t, time_atp, time_atp_fail))
+
+fun inc_sh_time_atp t =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls, success, lemmas, time_isa, time_atp + t, time_atp_fail))
+
+fun inc_sh_time_atp_fail t =
+ map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
+ => (calls, success, lemmas, time_isa, time_atp, time_atp_fail + t))
+
+val inc_min_succs =
+ map_min_data (fn (succs,ab_ratios,it_ratios) => (succs+1, ab_ratios, it_ratios))
+
+fun inc_min_ab_ratios r =
+ map_min_data (fn (succs, ab_ratios, it_ratios) => (succs, ab_ratios+r, it_ratios))
+
+fun inc_min_it_ratios r =
+ map_min_data (fn (succs, ab_ratios, it_ratios) => (succs, ab_ratios, it_ratios+r))
+
+val inc_metis_calls = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls + 1, success, proofs, time, timeout, lemmas,posns))
+
+val inc_metis_success = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success + 1, proofs, time, timeout, lemmas,posns))
+
+val inc_metis_proofs = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs + 1, time, timeout, lemmas,posns))
+
+fun inc_metis_time t = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time + t, timeout, lemmas,posns))
+
+val inc_metis_timeout = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout + 1, lemmas,posns))
+
+fun inc_metis_lemmas n = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout, lemmas + n, posns))
+
+fun inc_metis_posns pos = map_me_data
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout, lemmas, pos::posns))
+
+val inc_metis_calls0 = map_me_data0
+(fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls + 1, success, proofs, time, timeout, lemmas,posns))
+
+val inc_metis_success0 = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success + 1, proofs, time, timeout, lemmas,posns))
+
+val inc_metis_proofs0 = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs + 1, time, timeout, lemmas,posns))
+
+fun inc_metis_time0 t = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time + t, timeout, lemmas,posns))
+
+val inc_metis_timeout0 = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout + 1, lemmas,posns))
+
+fun inc_metis_lemmas0 n = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout, lemmas + n, posns))
+
+fun inc_metis_posns0 pos = map_me_data0
+ (fn (calls,success,proofs,time,timeout,lemmas,posns)
+ => (calls, success, proofs, time, timeout, lemmas, pos::posns))
+
+local
+
+val str = string_of_int
+val str3 = Real.fmt (StringCvt.FIX (SOME 3))
+fun percentage a b = string_of_int (a * 100 div b)
+fun time t = Real.fromInt t / 1000.0
+fun avg_time t n =
+ if n > 0 then (Real.fromInt t / 1000.0) / Real.fromInt n else 0.0
+
+fun log_sh_data log sh_calls sh_success sh_lemmas sh_time_isa sh_time_atp sh_time_atp_fail =
+ (log ("Total number of sledgehammer calls: " ^ str sh_calls);
+ log ("Number of successful sledgehammer calls: " ^ str sh_success);
+ log ("Number of sledgehammer lemmas: " ^ str sh_lemmas);
+ log ("Success rate: " ^ percentage sh_success sh_calls ^ "%");
+ log ("Total time for sledgehammer calls (Isabelle): " ^ str3 (time sh_time_isa));
+ log ("Total time for successful sledgehammer calls (ATP): " ^ str3 (time sh_time_atp));
+ log ("Total time for failed sledgehammer calls (ATP): " ^ str3 (time sh_time_atp_fail));
+ log ("Average time for sledgehammer calls (Isabelle): " ^
+ str3 (avg_time sh_time_isa sh_calls));
+ log ("Average time for successful sledgehammer calls (ATP): " ^
+ str3 (avg_time sh_time_atp sh_success));
+ log ("Average time for failed sledgehammer calls (ATP): " ^
+ str3 (avg_time sh_time_atp_fail (sh_calls - sh_success)))
+ )
+
+
+fun str_of_pos pos =
+ let val str0 = string_of_int o the_default 0
+ in str0 (Position.line_of pos) ^ ":" ^ str0 (Position.column_of pos) end
+
+fun log_metis_data log tag sh_calls sh_success metis_calls metis_success metis_proofs metis_time
+ metis_timeout metis_lemmas metis_posns =
+ (log ("Total number of " ^ tag ^ "metis calls: " ^ str metis_calls);
+ log ("Number of successful " ^ tag ^ "metis calls: " ^ str metis_success ^
+ " (proof: " ^ str metis_proofs ^ ")");
+ log ("Number of " ^ tag ^ "metis timeouts: " ^ str metis_timeout);
+ log ("Success rate: " ^ percentage metis_success sh_calls ^ "%");
+ log ("Number of successful " ^ tag ^ "metis lemmas: " ^ str metis_lemmas);
+ log ("Total time for successful metis calls: " ^ str3 (time metis_time));
+ log ("Average time for successful metis calls: " ^
+ str3 (avg_time metis_time metis_success));
+ if tag=""
+ then log ("Proved: " ^ space_implode " " (map str_of_pos metis_posns))
+ else ()
+ )
+
+fun log_min_data log succs ab_ratios it_ratios =
+ (log ("Number of successful minimizations: " ^ string_of_int succs);
+ log ("After/before ratios: " ^ string_of_int ab_ratios);
+ log ("Iterations ratios: " ^ string_of_int it_ratios)
+ )
+
+in
+
+fun log_data id log (Data
+ (ShData{calls=sh_calls, lemmas=sh_lemmas, success=sh_success,
+ time_isa=sh_time_isa,time_atp=sh_time_atp,time_atp_fail=sh_time_atp_fail},
+ MeData{calls=metis_calls0, proofs=metis_proofs0,
+ success=metis_success0, time=metis_time0, timeout=metis_timeout0,
+ lemmas=metis_lemmas0,posns=metis_posns0},
+ MinData{succs=min_succs, ab_ratios=ab_ratios, it_ratios=it_ratios},
+ MeData{calls=metis_calls, proofs=metis_proofs,
+ success=metis_success, time=metis_time, timeout=metis_timeout,
+ lemmas=metis_lemmas,posns=metis_posns})) =
+ if sh_calls > 0
+ then
+ (log ("\n\n\nReport #" ^ string_of_int id ^ ":\n");
+ log_sh_data log sh_calls sh_success sh_lemmas sh_time_isa sh_time_atp sh_time_atp_fail;
+ log "";
+ if metis_calls > 0 then log_metis_data log "" sh_calls sh_success metis_calls
+ metis_success metis_proofs metis_time metis_timeout metis_lemmas metis_posns else ();
+ log "";
+ if metis_calls0 > 0
+ then (log_min_data log min_succs ab_ratios it_ratios; log "";
+ log_metis_data log "unminimized " sh_calls sh_success metis_calls0
+ metis_success0 metis_proofs0 metis_time0 metis_timeout0 metis_lemmas0 metis_posns0)
+ else ()
+ )
+ else ()
+
+end
+
+
+(* Warning: we implicitly assume single-threaded execution here! *)
+val data = Unsynchronized.ref ([] : (int * data) list)
+
+fun init id thy = (Unsynchronized.change data (cons (id, empty_data)); thy)
+fun done id ({log, ...}: Mirabelle.done_args) =
+ AList.lookup (op =) (!data) id
+ |> Option.map (log_data id log)
+ |> K ()
+
+fun change_data id f = (Unsynchronized.change data (AList.map_entry (op =) id f); ())
+
+
+fun get_atp thy args =
+ AList.lookup (op =) args proverK
+ |> the_default (hd (space_explode " " (AtpManager.get_atps ())))
+ |> (fn name => (name, the (AtpManager.get_prover name thy)))
+
+local
+
+fun safe init done f x =
+ let
+ val y = init x
+ val z = Exn.capture f y
+ val _ = done y
+ in Exn.release z end
+
+fun init_sh NONE = !AtpWrapper.destdir
+ | init_sh (SOME path) =
+ let
+ (* Warning: we implicitly assume single-threaded execution here! *)
+ val old = !AtpWrapper.destdir
+ val _ = AtpWrapper.destdir := path
+ in old end
+
+fun done_sh path = AtpWrapper.destdir := path
+
+datatype sh_result =
+ SH_OK of int * int * string list |
+ SH_FAIL of int * int |
+ SH_ERROR
+
+fun run_sh (prover_name, prover) hard_timeout timeout st _ =
+ let
+ val atp = prover timeout NONE NONE prover_name 1
+ val time_limit =
+ (case hard_timeout of
+ NONE => I
+ | SOME secs => TimeLimit.timeLimit (Time.fromSeconds secs))
+ val ((success, (message, thm_names), time_atp, _, _, _), time_isa) =
+ time_limit (Mirabelle.cpu_time atp) (Proof.get_goal st)
+ in
+ if success then (message, SH_OK (time_isa, time_atp, thm_names))
+ else (message, SH_FAIL(time_isa, time_atp))
+ end
+ handle ResHolClause.TOO_TRIVIAL => ("trivial", SH_OK (0, 0, []))
+ | ERROR msg => ("error: " ^ msg, SH_ERROR)
+ | TimeLimit.TimeOut => ("timeout", SH_ERROR)
+
+fun thms_of_name ctxt name =
+ let
+ val lex = OuterKeyword.get_lexicons
+ val get = maps (ProofContext.get_fact ctxt o fst)
+ in
+ Source.of_string name
+ |> Symbol.source {do_recover=false}
+ |> OuterLex.source {do_recover=SOME false} lex Position.start
+ |> OuterLex.source_proper
+ |> Source.source OuterLex.stopper (SpecParse.xthms1 >> get) NONE
+ |> Source.exhaust
+ end
+
+in
+
+fun run_sledgehammer args named_thms id ({pre=st, log, ...}: Mirabelle.run_args) =
+ let
+ val _ = change_data id inc_sh_calls
+ val atp as (prover_name, _) = get_atp (Proof.theory_of st) args
+ val dir = AList.lookup (op =) args keepK
+ val timeout = Mirabelle.get_int_setting args (prover_timeoutK, 30)
+ val hard_timeout = AList.lookup (op =) args prover_hard_timeoutK
+ |> Option.map (fst o read_int o explode)
+ val (msg, result) = safe init_sh done_sh
+ (run_sh atp hard_timeout timeout st) dir
+ in
+ case result of
+ SH_OK (time_isa, time_atp, names) =>
+ let
+ val _ = change_data id inc_sh_success
+ val _ = change_data id (inc_sh_lemmas (length names))
+ val _ = change_data id (inc_sh_time_isa time_isa)
+ val _ = change_data id (inc_sh_time_atp time_atp)
+
+ fun get_thms name = (name, thms_of_name (Proof.context_of st) name)
+ val _ = named_thms := SOME (map get_thms names)
+ in
+ log (sh_tag id ^ "succeeded (" ^ string_of_int time_isa ^ "+" ^
+ string_of_int time_atp ^ ") [" ^ prover_name ^ "]:\n" ^ msg)
+ end
+ | SH_FAIL (time_isa, time_atp) =>
+ let
+ val _ = change_data id (inc_sh_time_isa time_isa)
+ val _ = change_data id (inc_sh_time_atp_fail time_atp)
+ in log (sh_tag id ^ "failed: " ^ msg) end
+ | SH_ERROR => log (sh_tag id ^ "failed: " ^ msg)
+ end
+
+end
+
+
+fun run_minimize args named_thms id ({pre=st, log, ...}: Mirabelle.run_args) =
+ let
+ val n0 = length (these (!named_thms))
+ val (prover_name, prover) = get_atp (Proof.theory_of st) args
+ val minimize = AtpMinimal.minimalize prover prover_name
+ val timeout =
+ AList.lookup (op =) args minimize_timeoutK
+ |> Option.map (fst o read_int o explode)
+ |> the_default 5
+ val _ = log separator
+ in
+ case minimize timeout st (these (!named_thms)) of
+ (SOME (named_thms',its), msg) =>
+ (change_data id inc_min_succs;
+ change_data id (inc_min_ab_ratios ((100 * length named_thms') div n0));
+ change_data id (inc_min_it_ratios ((100*its) div n0));
+ if length named_thms' = n0
+ then log (minimize_tag id ^ "already minimal")
+ else (named_thms := SOME named_thms';
+ log (minimize_tag id ^ "succeeded:\n" ^ msg))
+ )
+ | (NONE, msg) => log (minimize_tag id ^ "failed: " ^ msg)
+ end
+
+
+fun run_metis (inc_metis_calls, inc_metis_success, inc_metis_proofs, inc_metis_time, inc_metis_timeout,
+ inc_metis_lemmas, inc_metis_posns) args name named_thms id
+ ({pre=st, timeout, log, pos, ...}: Mirabelle.run_args) =
+ let
+ fun metis thms ctxt = MetisTools.metis_tac ctxt thms
+ fun apply_metis thms = Mirabelle.can_apply timeout (metis thms) st
+
+ fun with_time (false, t) = "failed (" ^ string_of_int t ^ ")"
+ | with_time (true, t) = (change_data id inc_metis_success;
+ change_data id (inc_metis_lemmas (length named_thms));
+ change_data id (inc_metis_time t);
+ change_data id (inc_metis_posns pos);
+ if name = "proof" then change_data id inc_metis_proofs else ();
+ "succeeded (" ^ string_of_int t ^ ")")
+ fun timed_metis thms = with_time (Mirabelle.cpu_time apply_metis thms)
+ handle TimeLimit.TimeOut => (change_data id inc_metis_timeout; "timeout")
+ | ERROR msg => "error: " ^ msg
+
+ val _ = log separator
+ val _ = change_data id inc_metis_calls
+ in
+ maps snd named_thms
+ |> timed_metis
+ |> log o prefix (metis_tag id)
+ end
+
+fun sledgehammer_action args id (st as {log, pre, name, ...}: Mirabelle.run_args) =
+ if can Logic.dest_conjunction (Thm.major_prem_of(snd(snd(Proof.get_goal pre))))
+ then () else
+ let
+ val metis_fns = (inc_metis_calls, inc_metis_success, inc_metis_proofs, inc_metis_time,
+ inc_metis_timeout, inc_metis_lemmas, inc_metis_posns)
+ val metis0_fns = (inc_metis_calls0, inc_metis_success0, inc_metis_proofs0, inc_metis_time0,
+ inc_metis_timeout0, inc_metis_lemmas0, inc_metis_posns0)
+ val named_thms = Unsynchronized.ref (NONE : (string * thm list) list option)
+ val minimize = AList.defined (op =) args minimizeK
+ in
+ Mirabelle.catch sh_tag (run_sledgehammer args named_thms) id st;
+ if is_some (!named_thms)
+ then
+ (if minimize
+ then Mirabelle.catch metis_tag (run_metis metis0_fns args name (these (!named_thms))) id st
+ else ();
+ if minimize andalso not(null(these(!named_thms)))
+ then Mirabelle.catch minimize_tag (run_minimize args named_thms) id st
+ else ();
+ Mirabelle.catch metis_tag (run_metis metis_fns args name (these (!named_thms))) id st)
+ else ()
+ end
+
+fun invoke args =
+ let
+ val _ = AtpManager.set_full_types (AList.defined (op =) args full_typesK)
+ in Mirabelle.register (init, sledgehammer_action args, done) end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/doc/options.txt Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,11 @@
+Options for sledgehammer:
+
+ * prover=NAME: name of the external prover to call
+ * prover_timeout=TIME: timeout for invoked ATP (seconds of process time)
+ * prover_hard_timeout=TIME: timeout for invoked ATP (seconds of elapsed time)
+ * keep=PATH: path where to keep temporary files created by sledgehammer
+ * full_types: enable full-typed encoding
+ * minimize: enable minimization of theorem set found by sledgehammer
+ * minimize_timeout=TIME: timeout for each minimization step (seconds of
+ process time)
+ * metis: apply metis with the theorems found by sledgehammer
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/etc/settings Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,8 @@
+MIRABELLE_HOME="$COMPONENT"
+
+MIRABELLE_LOGIC=HOL
+MIRABELLE_THEORY=Main
+MIRABELLE_OUTPUT_PATH=/tmp/mirabelle
+MIRABELLE_TIMEOUT=30
+
+ISABELLE_TOOLS="$ISABELLE_TOOLS:$COMPONENT/lib/Tools"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/lib/Tools/mirabelle Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,97 @@
+#!/usr/bin/env bash
+#
+# Author: Sascha Boehme
+#
+# DESCRIPTION: testing tool for automated proof tools
+
+
+PRG="$(basename "$0")"
+
+function print_action_names() {
+ TOOLS="$MIRABELLE_HOME/Tools/mirabelle_*.ML"
+ for NAME in $TOOLS
+ do
+ echo $NAME | sed 's/.*mirabelle_\(.*\)\.ML/ \1/'
+ done
+}
+
+function usage() {
+ out="$MIRABELLE_OUTPUT_PATH"
+ timeout="$MIRABELLE_TIMEOUT"
+ echo
+ echo "Usage: isabelle $PRG [OPTIONS] ACTIONS FILES"
+ echo
+ echo " Options are:"
+ echo " -L LOGIC parent logic to use (default $ISABELLE_LOGIC)"
+ echo " -T THEORY parent theory to use (default $MIRABELLE_THEORY)"
+ echo " -O DIR output directory for test data (default $out)"
+ echo " -t TIMEOUT timeout for each action in seconds (default $timeout)"
+ echo " -q be quiet (suppress output of Isabelle process)"
+ echo
+ echo " Apply the given actions (i.e., automated proof tools)"
+ echo " at all proof steps in the given theory files."
+ echo
+ echo " ACTIONS is a colon-separated list of actions, where each action is"
+ echo " either NAME or NAME[OPTION,...,OPTION]. Available actions are:"
+ print_action_names
+ echo
+ echo " A list of available OPTIONs can be found here:"
+ echo " $MIRABELLE_HOME/doc/options.txt"
+ echo
+ echo " FILES is a list of theory files, where each file is either NAME.thy"
+ echo " or NAME.thy[START:END] and START and END are numbers indicating the"
+ echo " range the given actions are to be applied."
+ echo
+ exit 1
+}
+
+
+## process command line
+
+# options
+
+while getopts "L:T:O:t:q?" OPT
+do
+ case "$OPT" in
+ L)
+ MIRABELLE_LOGIC="$OPTARG"
+ ;;
+ T)
+ MIRABELLE_THEORY="$OPTARG"
+ ;;
+ O)
+ MIRABELLE_OUTPUT_PATH="$OPTARG"
+ ;;
+ t)
+ MIRABELLE_TIMEOUT="$OPTARG"
+ ;;
+ q)
+ MIRABELLE_QUIET="true"
+ ;;
+ \?)
+ usage
+ ;;
+ esac
+done
+
+export MIRABELLE_QUIET
+
+shift $(($OPTIND - 1))
+
+export MIRABELLE_ACTIONS="$1"
+
+shift
+
+
+# setup
+
+mkdir -p "$MIRABELLE_OUTPUT_PATH"
+
+
+## main
+
+for FILE in "$@"
+do
+ perl -w "$MIRABELLE_HOME/lib/scripts/mirabelle.pl" "$FILE"
+done
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Mirabelle/lib/scripts/mirabelle.pl Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,147 @@
+#
+# Author: Jasmin Blanchette and Sascha Boehme
+#
+# Testing tool for automated proof tools.
+#
+
+use File::Basename;
+
+# environment
+
+my $isabelle_home = $ENV{'ISABELLE_HOME'};
+my $mirabelle_home = $ENV{'MIRABELLE_HOME'};
+my $mirabelle_logic = $ENV{'MIRABELLE_LOGIC'};
+my $mirabelle_theory = $ENV{'MIRABELLE_THEORY'};
+my $output_path = $ENV{'MIRABELLE_OUTPUT_PATH'};
+my $timeout = $ENV{'MIRABELLE_TIMEOUT'};
+my $be_quiet = $ENV{'MIRABELLE_QUIET'};
+my $actions = $ENV{'MIRABELLE_ACTIONS'};
+
+my $mirabelle_thy = $mirabelle_home . "/Mirabelle";
+
+
+# arguments
+
+my $thy_file = $ARGV[0];
+my $start_line = "0";
+my $end_line = "~1";
+if ($thy_file =~ /^(.*)\[([0-9]+)\:(~?[0-9]+)\]$/) {
+ $thy_file = $1;
+ $start_line = $2;
+ $end_line = $3;
+}
+my ($thy_name, $path, $ext) = fileparse($thy_file, ".thy");
+my $new_thy_name = $thy_name . "_Mirabelle";
+my $new_thy_file = $output_path . "/" . $new_thy_name . $ext;
+
+
+# setup
+
+my $setup_thy_name = $thy_name . "_Setup";
+my $setup_file = $output_path . "/" . $setup_thy_name . ".thy";
+my $log_file = $output_path . "/" . $thy_name . ".log";
+
+my @action_files;
+my @action_names;
+foreach (split(/:/, $actions)) {
+ if (m/([^[]*)/) {
+ push @action_files, "\"$mirabelle_home/Tools/mirabelle_$1.ML\"";
+ push @action_names, $1;
+ }
+}
+my $tools = "";
+if ($#action_files >= 0) {
+ $tools = "uses " . join(" ", @action_files);
+}
+
+open(SETUP_FILE, ">$setup_file") || die "Could not create file '$setup_file'";
+
+print SETUP_FILE <<END;
+theory "$setup_thy_name"
+imports "$mirabelle_thy" "$mirabelle_theory"
+$tools
+begin
+
+setup {*
+ Config.put_thy Mirabelle.logfile "$log_file" #>
+ Config.put_thy Mirabelle.timeout $timeout #>
+ Config.put_thy Mirabelle.start_line $start_line #>
+ Config.put_thy Mirabelle.end_line $end_line
+*}
+
+END
+
+foreach (split(/:/, $actions)) {
+ if (m/([^[]*)(?:\[(.*)\])?/) {
+ my ($name, $settings_str) = ($1, $2 || "");
+ $name =~ s/^([a-z])/\U$1/;
+ print SETUP_FILE "setup {* Mirabelle_$name.invoke [";
+ my $sep = "";
+ foreach (split(/,/, $settings_str)) {
+ if (m/\s*(.*)\s*=\s*(.*)\s*/) {
+ print SETUP_FILE "$sep(\"$1\", \"$2\")";
+ $sep = ", ";
+ }
+ elsif (m/\s*(.*)\s*/) {
+ print SETUP_FILE "$sep(\"$1\", \"\")";
+ $sep = ", ";
+ }
+ }
+ print SETUP_FILE "] *}\n";
+ }
+}
+
+print SETUP_FILE "\nend";
+close SETUP_FILE;
+
+
+# modify target theory file
+
+open(OLD_FILE, "<$thy_file") || die "Cannot open file '$thy_file'";
+my @lines = <OLD_FILE>;
+close(OLD_FILE);
+
+my $thy_text = join("", @lines);
+my $old_len = length($thy_text);
+$thy_text =~ s/(theory\s+)\"?$thy_name\"?/$1"$new_thy_name"/g;
+$thy_text =~ s/(imports)(\s+)/$1 "$setup_thy_name"$2/g;
+die "No 'imports' found" if length($thy_text) == $old_len;
+
+open(NEW_FILE, ">$new_thy_file") || die "Cannot create file '$new_thy_file'";
+print NEW_FILE $thy_text;
+close(NEW_FILE);
+
+my $root_file = "$output_path/ROOT_$thy_name.ML";
+open(ROOT_FILE, ">$root_file") || die "Cannot create file '$root_file'";
+print ROOT_FILE "use_thy \"$output_path/$new_thy_name\";\n";
+close(ROOT_FILE);
+
+
+# run isabelle
+
+open(LOG_FILE, ">$log_file");
+print LOG_FILE "Run of $new_thy_file with:\n";
+foreach $name (@action_names) {
+ print LOG_FILE " $name\n";
+}
+close(LOG_FILE);
+
+my $quiet = "";
+if (defined $be_quiet and $be_quiet ne "") {
+ $quiet = " > /dev/null 2>&1";
+}
+
+print "Mirabelle: $thy_file\n" if ($quiet ne "");
+
+my $result = system "\"$ENV{'ISABELLE_PROCESS'}\" " .
+ "-e 'use \"$root_file\";' -q $mirabelle_logic" . $quiet;
+
+print "Finished: $thy_file\n" if ($quiet ne "");
+
+
+# cleanup
+
+unlink $root_file;
+unlink $setup_file;
+
+exit $result;
--- a/src/HOL/Modelcheck/EindhovenSyn.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Modelcheck/EindhovenSyn.thy Thu Oct 01 07:40:25 2009 +0200
@@ -26,7 +26,7 @@
"Nu " :: "[idts, 'a pred] => 'a pred" ("(3[nu _./ _])" 1000)
ML {*
- val trace_eindhoven = ref false;
+ val trace_eindhoven = Unsynchronized.ref false;
*}
oracle mc_eindhoven_oracle =
--- a/src/HOL/Modelcheck/mucke_oracle.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Modelcheck/mucke_oracle.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,5 @@
-val trace_mc = ref false;
+val trace_mc = Unsynchronized.ref false;
(* transform_case post-processes output strings of the syntax "Mucke" *)
--- a/src/HOL/NSA/Examples/NSPrimes.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/NSA/Examples/NSPrimes.thy Thu Oct 01 07:40:25 2009 +0200
@@ -7,7 +7,7 @@
header{*The Nonstandard Primes as an Extension of the Prime Numbers*}
theory NSPrimes
-imports "~~/src/HOL/NumberTheory/Factorization" Hyperreal
+imports "~~/src/HOL/Old_Number_Theory/Factorization" Hyperreal
begin
text{*These can be used to derive an alternative proof of the infinitude of
--- a/src/HOL/Nat.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -86,7 +86,7 @@
assumes "P 0"
and "\<And>n. P n \<Longrightarrow> P (Suc n)"
shows "P n"
- using assms by (rule nat.induct)
+ using assms by (rule nat.induct)
declare nat.exhaust [case_names 0 Suc, cases type: nat]
@@ -1512,7 +1512,7 @@
by (simp split add: nat_diff_split)
lemma min_diff: "min (m - (i::nat)) (n - i) = min m n - i"
-unfolding min_def by auto
+by auto
lemma inj_on_diff_nat:
assumes k_le_n: "\<forall>n \<in> N. k \<le> (n::nat)"
@@ -1588,9 +1588,6 @@
lemma zero_induct: "P k ==> (!!n. P (Suc n) ==> P n) ==> P 0"
using inc_induct[of 0 k P] by blast
-lemma nat_not_singleton: "(\<forall>x. x = (0::nat)) = False"
- by auto
-
(*The others are
i - j - k = i - (j + k),
k \<le> j ==> j - k + i = j + i - k,
--- a/src/HOL/NatTransfer.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,537 +0,0 @@
-(* Title: HOL/Library/NatTransfer.thy
- Authors: Jeremy Avigad and Amine Chaieb
-
- Sets up transfer from nats to ints and
- back.
-*)
-
-
-header {* NatTransfer *}
-
-theory NatTransfer
-imports Main Parity
-uses ("Tools/transfer_data.ML")
-begin
-
-subsection {* A transfer Method between isomorphic domains*}
-
-definition TransferMorphism:: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> bool"
- where "TransferMorphism a B = True"
-
-use "Tools/transfer_data.ML"
-
-setup TransferData.setup
-
-
-subsection {* Set up transfer from nat to int *}
-
-(* set up transfer direction *)
-
-lemma TransferMorphism_nat_int: "TransferMorphism nat (op <= (0::int))"
- by (simp add: TransferMorphism_def)
-
-declare TransferMorphism_nat_int[transfer
- add mode: manual
- return: nat_0_le
- labels: natint
-]
-
-(* basic functions and relations *)
-
-lemma transfer_nat_int_numerals:
- "(0::nat) = nat 0"
- "(1::nat) = nat 1"
- "(2::nat) = nat 2"
- "(3::nat) = nat 3"
- by auto
-
-definition
- tsub :: "int \<Rightarrow> int \<Rightarrow> int"
-where
- "tsub x y = (if x >= y then x - y else 0)"
-
-lemma tsub_eq: "x >= y \<Longrightarrow> tsub x y = x - y"
- by (simp add: tsub_def)
-
-
-lemma transfer_nat_int_functions:
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) + (nat y) = nat (x + y)"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) * (nat y) = nat (x * y)"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) - (nat y) = nat (tsub x y)"
- "(x::int) >= 0 \<Longrightarrow> (nat x)^n = nat (x^n)"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) div (nat y) = nat (x div y)"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) mod (nat y) = nat (x mod y)"
- by (auto simp add: eq_nat_nat_iff nat_mult_distrib
- nat_power_eq nat_div_distrib nat_mod_distrib tsub_def)
-
-lemma transfer_nat_int_function_closures:
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x + y >= 0"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x * y >= 0"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> tsub x y >= 0"
- "(x::int) >= 0 \<Longrightarrow> x^n >= 0"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x div y >= 0"
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x mod y >= 0"
- "(0::int) >= 0"
- "(1::int) >= 0"
- "(2::int) >= 0"
- "(3::int) >= 0"
- "int z >= 0"
- apply (auto simp add: zero_le_mult_iff tsub_def)
- apply (case_tac "y = 0")
- apply auto
- apply (subst pos_imp_zdiv_nonneg_iff, auto)
- apply (case_tac "y = 0")
- apply force
- apply (rule pos_mod_sign)
- apply arith
-done
-
-lemma transfer_nat_int_relations:
- "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
- (nat (x::int) = nat y) = (x = y)"
- "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
- (nat (x::int) < nat y) = (x < y)"
- "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
- (nat (x::int) <= nat y) = (x <= y)"
- "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
- (nat (x::int) dvd nat y) = (x dvd y)"
- by (auto simp add: zdvd_int even_nat_def)
-
-declare TransferMorphism_nat_int[transfer add return:
- transfer_nat_int_numerals
- transfer_nat_int_functions
- transfer_nat_int_function_closures
- transfer_nat_int_relations
-]
-
-
-(* first-order quantifiers *)
-
-lemma transfer_nat_int_quantifiers:
- "(ALL (x::nat). P x) = (ALL (x::int). x >= 0 \<longrightarrow> P (nat x))"
- "(EX (x::nat). P x) = (EX (x::int). x >= 0 & P (nat x))"
- by (rule all_nat, rule ex_nat)
-
-(* should we restrict these? *)
-lemma all_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
- (ALL x. Q x \<longrightarrow> P x) = (ALL x. Q x \<longrightarrow> P' x)"
- by auto
-
-lemma ex_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
- (EX x. Q x \<and> P x) = (EX x. Q x \<and> P' x)"
- by auto
-
-declare TransferMorphism_nat_int[transfer add
- return: transfer_nat_int_quantifiers
- cong: all_cong ex_cong]
-
-
-(* if *)
-
-lemma nat_if_cong: "(if P then (nat x) else (nat y)) =
- nat (if P then x else y)"
- by auto
-
-declare TransferMorphism_nat_int [transfer add return: nat_if_cong]
-
-
-(* operations with sets *)
-
-definition
- nat_set :: "int set \<Rightarrow> bool"
-where
- "nat_set S = (ALL x:S. x >= 0)"
-
-lemma transfer_nat_int_set_functions:
- "card A = card (int ` A)"
- "{} = nat ` ({}::int set)"
- "A Un B = nat ` (int ` A Un int ` B)"
- "A Int B = nat ` (int ` A Int int ` B)"
- "{x. P x} = nat ` {x. x >= 0 & P(nat x)}"
- "{..n} = nat ` {0..int n}"
- "{m..n} = nat ` {int m..int n}" (* need all variants of these! *)
- apply (rule card_image [symmetric])
- apply (auto simp add: inj_on_def image_def)
- apply (rule_tac x = "int x" in bexI)
- apply auto
- apply (rule_tac x = "int x" in bexI)
- apply auto
- apply (rule_tac x = "int x" in bexI)
- apply auto
- apply (rule_tac x = "int x" in exI)
- apply auto
- apply (rule_tac x = "int x" in bexI)
- apply auto
- apply (rule_tac x = "int x" in bexI)
- apply auto
-done
-
-lemma transfer_nat_int_set_function_closures:
- "nat_set {}"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
- "x >= 0 \<Longrightarrow> nat_set {x..y}"
- "nat_set {x. x >= 0 & P x}"
- "nat_set (int ` C)"
- "nat_set A \<Longrightarrow> x : A \<Longrightarrow> x >= 0" (* does it hurt to turn this on? *)
- unfolding nat_set_def apply auto
-done
-
-lemma transfer_nat_int_set_relations:
- "(finite A) = (finite (int ` A))"
- "(x : A) = (int x : int ` A)"
- "(A = B) = (int ` A = int ` B)"
- "(A < B) = (int ` A < int ` B)"
- "(A <= B) = (int ` A <= int ` B)"
-
- apply (rule iffI)
- apply (erule finite_imageI)
- apply (erule finite_imageD)
- apply (auto simp add: image_def expand_set_eq inj_on_def)
- apply (drule_tac x = "int x" in spec, auto)
- apply (drule_tac x = "int x" in spec, auto)
- apply (drule_tac x = "int x" in spec, auto)
-done
-
-lemma transfer_nat_int_set_return_embed: "nat_set A \<Longrightarrow>
- (int ` nat ` A = A)"
- by (auto simp add: nat_set_def image_def)
-
-lemma transfer_nat_int_set_cong: "(!!x. x >= 0 \<Longrightarrow> P x = P' x) \<Longrightarrow>
- {(x::int). x >= 0 & P x} = {x. x >= 0 & P' x}"
- by auto
-
-declare TransferMorphism_nat_int[transfer add
- return: transfer_nat_int_set_functions
- transfer_nat_int_set_function_closures
- transfer_nat_int_set_relations
- transfer_nat_int_set_return_embed
- cong: transfer_nat_int_set_cong
-]
-
-
-(* setsum and setprod *)
-
-(* this handles the case where the *domain* of f is nat *)
-lemma transfer_nat_int_sum_prod:
- "setsum f A = setsum (%x. f (nat x)) (int ` A)"
- "setprod f A = setprod (%x. f (nat x)) (int ` A)"
- apply (subst setsum_reindex)
- apply (unfold inj_on_def, auto)
- apply (subst setprod_reindex)
- apply (unfold inj_on_def o_def, auto)
-done
-
-(* this handles the case where the *range* of f is nat *)
-lemma transfer_nat_int_sum_prod2:
- "setsum f A = nat(setsum (%x. int (f x)) A)"
- "setprod f A = nat(setprod (%x. int (f x)) A)"
- apply (subst int_setsum [symmetric])
- apply auto
- apply (subst int_setprod [symmetric])
- apply auto
-done
-
-lemma transfer_nat_int_sum_prod_closure:
- "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
- "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
- unfolding nat_set_def
- apply (rule setsum_nonneg)
- apply auto
- apply (rule setprod_nonneg)
- apply auto
-done
-
-(* this version doesn't work, even with nat_set A \<Longrightarrow>
- x : A \<Longrightarrow> x >= 0 turned on. Why not?
-
- also: what does =simp=> do?
-
-lemma transfer_nat_int_sum_prod_closure:
- "(!!x. x : A ==> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
- "(!!x. x : A ==> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
- unfolding nat_set_def simp_implies_def
- apply (rule setsum_nonneg)
- apply auto
- apply (rule setprod_nonneg)
- apply auto
-done
-*)
-
-(* Making A = B in this lemma doesn't work. Why not?
- Also, why aren't setsum_cong and setprod_cong enough,
- with the previously mentioned rule turned on? *)
-
-lemma transfer_nat_int_sum_prod_cong:
- "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
- setsum f A = setsum g B"
- "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
- setprod f A = setprod g B"
- unfolding nat_set_def
- apply (subst setsum_cong, assumption)
- apply auto [2]
- apply (subst setprod_cong, assumption, auto)
-done
-
-declare TransferMorphism_nat_int[transfer add
- return: transfer_nat_int_sum_prod transfer_nat_int_sum_prod2
- transfer_nat_int_sum_prod_closure
- cong: transfer_nat_int_sum_prod_cong]
-
-(* lists *)
-
-definition
- embed_list :: "nat list \<Rightarrow> int list"
-where
- "embed_list l = map int l";
-
-definition
- nat_list :: "int list \<Rightarrow> bool"
-where
- "nat_list l = nat_set (set l)";
-
-definition
- return_list :: "int list \<Rightarrow> nat list"
-where
- "return_list l = map nat l";
-
-thm nat_0_le;
-
-lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>
- embed_list (return_list l) = l";
- unfolding embed_list_def return_list_def nat_list_def nat_set_def
- apply (induct l);
- apply auto;
-done;
-
-lemma transfer_nat_int_list_functions:
- "l @ m = return_list (embed_list l @ embed_list m)"
- "[] = return_list []";
- unfolding return_list_def embed_list_def;
- apply auto;
- apply (induct l, auto);
- apply (induct m, auto);
-done;
-
-(*
-lemma transfer_nat_int_fold1: "fold f l x =
- fold (%x. f (nat x)) (embed_list l) x";
-*)
-
-
-
-
-subsection {* Set up transfer from int to nat *}
-
-(* set up transfer direction *)
-
-lemma TransferMorphism_int_nat: "TransferMorphism int (UNIV :: nat set)"
- by (simp add: TransferMorphism_def)
-
-declare TransferMorphism_int_nat[transfer add
- mode: manual
-(* labels: int-nat *)
- return: nat_int
-]
-
-
-(* basic functions and relations *)
-
-definition
- is_nat :: "int \<Rightarrow> bool"
-where
- "is_nat x = (x >= 0)"
-
-lemma transfer_int_nat_numerals:
- "0 = int 0"
- "1 = int 1"
- "2 = int 2"
- "3 = int 3"
- by auto
-
-lemma transfer_int_nat_functions:
- "(int x) + (int y) = int (x + y)"
- "(int x) * (int y) = int (x * y)"
- "tsub (int x) (int y) = int (x - y)"
- "(int x)^n = int (x^n)"
- "(int x) div (int y) = int (x div y)"
- "(int x) mod (int y) = int (x mod y)"
- by (auto simp add: int_mult tsub_def int_power zdiv_int zmod_int)
-
-lemma transfer_int_nat_function_closures:
- "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x + y)"
- "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x * y)"
- "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (tsub x y)"
- "is_nat x \<Longrightarrow> is_nat (x^n)"
- "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x div y)"
- "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x mod y)"
- "is_nat 0"
- "is_nat 1"
- "is_nat 2"
- "is_nat 3"
- "is_nat (int z)"
- by (simp_all only: is_nat_def transfer_nat_int_function_closures)
-
-lemma transfer_int_nat_relations:
- "(int x = int y) = (x = y)"
- "(int x < int y) = (x < y)"
- "(int x <= int y) = (x <= y)"
- "(int x dvd int y) = (x dvd y)"
- "(even (int x)) = (even x)"
- by (auto simp add: zdvd_int even_nat_def)
-
-lemma UNIV_apply:
- "UNIV x = True"
- by (simp add: top_fun_eq top_bool_eq)
-
-declare TransferMorphism_int_nat[transfer add return:
- transfer_int_nat_numerals
- transfer_int_nat_functions
- transfer_int_nat_function_closures
- transfer_int_nat_relations
- UNIV_apply
-]
-
-
-(* first-order quantifiers *)
-
-lemma transfer_int_nat_quantifiers:
- "(ALL (x::int) >= 0. P x) = (ALL (x::nat). P (int x))"
- "(EX (x::int) >= 0. P x) = (EX (x::nat). P (int x))"
- apply (subst all_nat)
- apply auto [1]
- apply (subst ex_nat)
- apply auto
-done
-
-declare TransferMorphism_int_nat[transfer add
- return: transfer_int_nat_quantifiers]
-
-
-(* if *)
-
-lemma int_if_cong: "(if P then (int x) else (int y)) =
- int (if P then x else y)"
- by auto
-
-declare TransferMorphism_int_nat [transfer add return: int_if_cong]
-
-
-
-(* operations with sets *)
-
-lemma transfer_int_nat_set_functions:
- "nat_set A \<Longrightarrow> card A = card (nat ` A)"
- "{} = int ` ({}::nat set)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Un B = int ` (nat ` A Un nat ` B)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Int B = int ` (nat ` A Int nat ` B)"
- "{x. x >= 0 & P x} = int ` {x. P(int x)}"
- "is_nat m \<Longrightarrow> is_nat n \<Longrightarrow> {m..n} = int ` {nat m..nat n}"
- (* need all variants of these! *)
- by (simp_all only: is_nat_def transfer_nat_int_set_functions
- transfer_nat_int_set_function_closures
- transfer_nat_int_set_return_embed nat_0_le
- cong: transfer_nat_int_set_cong)
-
-lemma transfer_int_nat_set_function_closures:
- "nat_set {}"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
- "is_nat x \<Longrightarrow> nat_set {x..y}"
- "nat_set {x. x >= 0 & P x}"
- "nat_set (int ` C)"
- "nat_set A \<Longrightarrow> x : A \<Longrightarrow> is_nat x"
- by (simp_all only: transfer_nat_int_set_function_closures is_nat_def)
-
-lemma transfer_int_nat_set_relations:
- "nat_set A \<Longrightarrow> finite A = finite (nat ` A)"
- "is_nat x \<Longrightarrow> nat_set A \<Longrightarrow> (x : A) = (nat x : nat ` A)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A = B) = (nat ` A = nat ` B)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A < B) = (nat ` A < nat ` B)"
- "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A <= B) = (nat ` A <= nat ` B)"
- by (simp_all only: is_nat_def transfer_nat_int_set_relations
- transfer_nat_int_set_return_embed nat_0_le)
-
-lemma transfer_int_nat_set_return_embed: "nat ` int ` A = A"
- by (simp only: transfer_nat_int_set_relations
- transfer_nat_int_set_function_closures
- transfer_nat_int_set_return_embed nat_0_le)
-
-lemma transfer_int_nat_set_cong: "(!!x. P x = P' x) \<Longrightarrow>
- {(x::nat). P x} = {x. P' x}"
- by auto
-
-declare TransferMorphism_int_nat[transfer add
- return: transfer_int_nat_set_functions
- transfer_int_nat_set_function_closures
- transfer_int_nat_set_relations
- transfer_int_nat_set_return_embed
- cong: transfer_int_nat_set_cong
-]
-
-
-(* setsum and setprod *)
-
-(* this handles the case where the *domain* of f is int *)
-lemma transfer_int_nat_sum_prod:
- "nat_set A \<Longrightarrow> setsum f A = setsum (%x. f (int x)) (nat ` A)"
- "nat_set A \<Longrightarrow> setprod f A = setprod (%x. f (int x)) (nat ` A)"
- apply (subst setsum_reindex)
- apply (unfold inj_on_def nat_set_def, auto simp add: eq_nat_nat_iff)
- apply (subst setprod_reindex)
- apply (unfold inj_on_def nat_set_def o_def, auto simp add: eq_nat_nat_iff
- cong: setprod_cong)
-done
-
-(* this handles the case where the *range* of f is int *)
-lemma transfer_int_nat_sum_prod2:
- "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow> setsum f A = int(setsum (%x. nat (f x)) A)"
- "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow>
- setprod f A = int(setprod (%x. nat (f x)) A)"
- unfolding is_nat_def
- apply (subst int_setsum, auto)
- apply (subst int_setprod, auto simp add: cong: setprod_cong)
-done
-
-declare TransferMorphism_int_nat[transfer add
- return: transfer_int_nat_sum_prod transfer_int_nat_sum_prod2
- cong: setsum_cong setprod_cong]
-
-
-subsection {* Test it out *}
-
-(* nat to int *)
-
-lemma ex1: "(x::nat) + y = y + x"
- by auto
-
-thm ex1 [transferred]
-
-lemma ex2: "(a::nat) div b * b + a mod b = a"
- by (rule mod_div_equality)
-
-thm ex2 [transferred]
-
-lemma ex3: "ALL (x::nat). ALL y. EX z. z >= x + y"
- by auto
-
-thm ex3 [transferred natint]
-
-lemma ex4: "(x::nat) >= y \<Longrightarrow> (x - y) + y = x"
- by auto
-
-thm ex4 [transferred]
-
-lemma ex5: "(2::nat) * (SUM i <= n. i) = n * (n + 1)"
- by (induct n rule: nat_induct, auto)
-
-thm ex5 [transferred]
-
-theorem ex6: "0 <= (n::int) \<Longrightarrow> 2 * \<Sum>{0..n} = n * (n + 1)"
- by (rule ex5 [transferred])
-
-thm ex6 [transferred]
-
-thm ex5 [transferred, transferred]
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nat_Transfer.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,484 @@
+
+(* Authors: Jeremy Avigad and Amine Chaieb *)
+
+header {* Sets up transfer from nats to ints and back. *}
+
+theory Nat_Transfer
+imports Main Parity
+begin
+
+subsection {* Set up transfer from nat to int *}
+
+(* set up transfer direction *)
+
+lemma TransferMorphism_nat_int: "TransferMorphism nat (op <= (0::int))"
+ by (simp add: TransferMorphism_def)
+
+declare TransferMorphism_nat_int[transfer
+ add mode: manual
+ return: nat_0_le
+ labels: natint
+]
+
+(* basic functions and relations *)
+
+lemma transfer_nat_int_numerals:
+ "(0::nat) = nat 0"
+ "(1::nat) = nat 1"
+ "(2::nat) = nat 2"
+ "(3::nat) = nat 3"
+ by auto
+
+definition
+ tsub :: "int \<Rightarrow> int \<Rightarrow> int"
+where
+ "tsub x y = (if x >= y then x - y else 0)"
+
+lemma tsub_eq: "x >= y \<Longrightarrow> tsub x y = x - y"
+ by (simp add: tsub_def)
+
+
+lemma transfer_nat_int_functions:
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) + (nat y) = nat (x + y)"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) * (nat y) = nat (x * y)"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) - (nat y) = nat (tsub x y)"
+ "(x::int) >= 0 \<Longrightarrow> (nat x)^n = nat (x^n)"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) div (nat y) = nat (x div y)"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) mod (nat y) = nat (x mod y)"
+ by (auto simp add: eq_nat_nat_iff nat_mult_distrib
+ nat_power_eq nat_div_distrib nat_mod_distrib tsub_def)
+
+lemma transfer_nat_int_function_closures:
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x + y >= 0"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x * y >= 0"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> tsub x y >= 0"
+ "(x::int) >= 0 \<Longrightarrow> x^n >= 0"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x div y >= 0"
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x mod y >= 0"
+ "(0::int) >= 0"
+ "(1::int) >= 0"
+ "(2::int) >= 0"
+ "(3::int) >= 0"
+ "int z >= 0"
+ apply (auto simp add: zero_le_mult_iff tsub_def)
+ apply (case_tac "y = 0")
+ apply auto
+ apply (subst pos_imp_zdiv_nonneg_iff, auto)
+ apply (case_tac "y = 0")
+ apply force
+ apply (rule pos_mod_sign)
+ apply arith
+done
+
+lemma transfer_nat_int_relations:
+ "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
+ (nat (x::int) = nat y) = (x = y)"
+ "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
+ (nat (x::int) < nat y) = (x < y)"
+ "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
+ (nat (x::int) <= nat y) = (x <= y)"
+ "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
+ (nat (x::int) dvd nat y) = (x dvd y)"
+ by (auto simp add: zdvd_int)
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_numerals
+ transfer_nat_int_functions
+ transfer_nat_int_function_closures
+ transfer_nat_int_relations
+]
+
+
+(* first-order quantifiers *)
+
+lemma transfer_nat_int_quantifiers:
+ "(ALL (x::nat). P x) = (ALL (x::int). x >= 0 \<longrightarrow> P (nat x))"
+ "(EX (x::nat). P x) = (EX (x::int). x >= 0 & P (nat x))"
+ by (rule all_nat, rule ex_nat)
+
+(* should we restrict these? *)
+lemma all_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
+ (ALL x. Q x \<longrightarrow> P x) = (ALL x. Q x \<longrightarrow> P' x)"
+ by auto
+
+lemma ex_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
+ (EX x. Q x \<and> P x) = (EX x. Q x \<and> P' x)"
+ by auto
+
+declare TransferMorphism_nat_int[transfer add
+ return: transfer_nat_int_quantifiers
+ cong: all_cong ex_cong]
+
+
+(* if *)
+
+lemma nat_if_cong: "(if P then (nat x) else (nat y)) =
+ nat (if P then x else y)"
+ by auto
+
+declare TransferMorphism_nat_int [transfer add return: nat_if_cong]
+
+
+(* operations with sets *)
+
+definition
+ nat_set :: "int set \<Rightarrow> bool"
+where
+ "nat_set S = (ALL x:S. x >= 0)"
+
+lemma transfer_nat_int_set_functions:
+ "card A = card (int ` A)"
+ "{} = nat ` ({}::int set)"
+ "A Un B = nat ` (int ` A Un int ` B)"
+ "A Int B = nat ` (int ` A Int int ` B)"
+ "{x. P x} = nat ` {x. x >= 0 & P(nat x)}"
+ "{..n} = nat ` {0..int n}"
+ "{m..n} = nat ` {int m..int n}" (* need all variants of these! *)
+ apply (rule card_image [symmetric])
+ apply (auto simp add: inj_on_def image_def)
+ apply (rule_tac x = "int x" in bexI)
+ apply auto
+ apply (rule_tac x = "int x" in bexI)
+ apply auto
+ apply (rule_tac x = "int x" in bexI)
+ apply auto
+ apply (rule_tac x = "int x" in exI)
+ apply auto
+ apply (rule_tac x = "int x" in bexI)
+ apply auto
+ apply (rule_tac x = "int x" in bexI)
+ apply auto
+done
+
+lemma transfer_nat_int_set_function_closures:
+ "nat_set {}"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
+ "x >= 0 \<Longrightarrow> nat_set {x..y}"
+ "nat_set {x. x >= 0 & P x}"
+ "nat_set (int ` C)"
+ "nat_set A \<Longrightarrow> x : A \<Longrightarrow> x >= 0" (* does it hurt to turn this on? *)
+ unfolding nat_set_def apply auto
+done
+
+lemma transfer_nat_int_set_relations:
+ "(finite A) = (finite (int ` A))"
+ "(x : A) = (int x : int ` A)"
+ "(A = B) = (int ` A = int ` B)"
+ "(A < B) = (int ` A < int ` B)"
+ "(A <= B) = (int ` A <= int ` B)"
+
+ apply (rule iffI)
+ apply (erule finite_imageI)
+ apply (erule finite_imageD)
+ apply (auto simp add: image_def expand_set_eq inj_on_def)
+ apply (drule_tac x = "int x" in spec, auto)
+ apply (drule_tac x = "int x" in spec, auto)
+ apply (drule_tac x = "int x" in spec, auto)
+done
+
+lemma transfer_nat_int_set_return_embed: "nat_set A \<Longrightarrow>
+ (int ` nat ` A = A)"
+ by (auto simp add: nat_set_def image_def)
+
+lemma transfer_nat_int_set_cong: "(!!x. x >= 0 \<Longrightarrow> P x = P' x) \<Longrightarrow>
+ {(x::int). x >= 0 & P x} = {x. x >= 0 & P' x}"
+ by auto
+
+declare TransferMorphism_nat_int[transfer add
+ return: transfer_nat_int_set_functions
+ transfer_nat_int_set_function_closures
+ transfer_nat_int_set_relations
+ transfer_nat_int_set_return_embed
+ cong: transfer_nat_int_set_cong
+]
+
+
+(* setsum and setprod *)
+
+(* this handles the case where the *domain* of f is nat *)
+lemma transfer_nat_int_sum_prod:
+ "setsum f A = setsum (%x. f (nat x)) (int ` A)"
+ "setprod f A = setprod (%x. f (nat x)) (int ` A)"
+ apply (subst setsum_reindex)
+ apply (unfold inj_on_def, auto)
+ apply (subst setprod_reindex)
+ apply (unfold inj_on_def o_def, auto)
+done
+
+(* this handles the case where the *range* of f is nat *)
+lemma transfer_nat_int_sum_prod2:
+ "setsum f A = nat(setsum (%x. int (f x)) A)"
+ "setprod f A = nat(setprod (%x. int (f x)) A)"
+ apply (subst int_setsum [symmetric])
+ apply auto
+ apply (subst int_setprod [symmetric])
+ apply auto
+done
+
+lemma transfer_nat_int_sum_prod_closure:
+ "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
+ "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
+ unfolding nat_set_def
+ apply (rule setsum_nonneg)
+ apply auto
+ apply (rule setprod_nonneg)
+ apply auto
+done
+
+(* this version doesn't work, even with nat_set A \<Longrightarrow>
+ x : A \<Longrightarrow> x >= 0 turned on. Why not?
+
+ also: what does =simp=> do?
+
+lemma transfer_nat_int_sum_prod_closure:
+ "(!!x. x : A ==> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
+ "(!!x. x : A ==> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
+ unfolding nat_set_def simp_implies_def
+ apply (rule setsum_nonneg)
+ apply auto
+ apply (rule setprod_nonneg)
+ apply auto
+done
+*)
+
+(* Making A = B in this lemma doesn't work. Why not?
+ Also, why aren't setsum_cong and setprod_cong enough,
+ with the previously mentioned rule turned on? *)
+
+lemma transfer_nat_int_sum_prod_cong:
+ "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
+ setsum f A = setsum g B"
+ "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
+ setprod f A = setprod g B"
+ unfolding nat_set_def
+ apply (subst setsum_cong, assumption)
+ apply auto [2]
+ apply (subst setprod_cong, assumption, auto)
+done
+
+declare TransferMorphism_nat_int[transfer add
+ return: transfer_nat_int_sum_prod transfer_nat_int_sum_prod2
+ transfer_nat_int_sum_prod_closure
+ cong: transfer_nat_int_sum_prod_cong]
+
+(* lists *)
+
+definition
+ embed_list :: "nat list \<Rightarrow> int list"
+where
+ "embed_list l = map int l";
+
+definition
+ nat_list :: "int list \<Rightarrow> bool"
+where
+ "nat_list l = nat_set (set l)";
+
+definition
+ return_list :: "int list \<Rightarrow> nat list"
+where
+ "return_list l = map nat l";
+
+thm nat_0_le;
+
+lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>
+ embed_list (return_list l) = l";
+ unfolding embed_list_def return_list_def nat_list_def nat_set_def
+ apply (induct l);
+ apply auto;
+done;
+
+lemma transfer_nat_int_list_functions:
+ "l @ m = return_list (embed_list l @ embed_list m)"
+ "[] = return_list []";
+ unfolding return_list_def embed_list_def;
+ apply auto;
+ apply (induct l, auto);
+ apply (induct m, auto);
+done;
+
+(*
+lemma transfer_nat_int_fold1: "fold f l x =
+ fold (%x. f (nat x)) (embed_list l) x";
+*)
+
+
+
+
+subsection {* Set up transfer from int to nat *}
+
+(* set up transfer direction *)
+
+lemma TransferMorphism_int_nat: "TransferMorphism int (UNIV :: nat set)"
+ by (simp add: TransferMorphism_def)
+
+declare TransferMorphism_int_nat[transfer add
+ mode: manual
+(* labels: int-nat *)
+ return: nat_int
+]
+
+
+(* basic functions and relations *)
+
+definition
+ is_nat :: "int \<Rightarrow> bool"
+where
+ "is_nat x = (x >= 0)"
+
+lemma transfer_int_nat_numerals:
+ "0 = int 0"
+ "1 = int 1"
+ "2 = int 2"
+ "3 = int 3"
+ by auto
+
+lemma transfer_int_nat_functions:
+ "(int x) + (int y) = int (x + y)"
+ "(int x) * (int y) = int (x * y)"
+ "tsub (int x) (int y) = int (x - y)"
+ "(int x)^n = int (x^n)"
+ "(int x) div (int y) = int (x div y)"
+ "(int x) mod (int y) = int (x mod y)"
+ by (auto simp add: int_mult tsub_def int_power zdiv_int zmod_int)
+
+lemma transfer_int_nat_function_closures:
+ "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x + y)"
+ "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x * y)"
+ "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (tsub x y)"
+ "is_nat x \<Longrightarrow> is_nat (x^n)"
+ "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x div y)"
+ "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x mod y)"
+ "is_nat 0"
+ "is_nat 1"
+ "is_nat 2"
+ "is_nat 3"
+ "is_nat (int z)"
+ by (simp_all only: is_nat_def transfer_nat_int_function_closures)
+
+lemma transfer_int_nat_relations:
+ "(int x = int y) = (x = y)"
+ "(int x < int y) = (x < y)"
+ "(int x <= int y) = (x <= y)"
+ "(int x dvd int y) = (x dvd y)"
+ "(even (int x)) = (even x)"
+ by (auto simp add: zdvd_int even_nat_def)
+
+lemma UNIV_apply:
+ "UNIV x = True"
+ by (simp add: top_fun_eq top_bool_eq)
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_numerals
+ transfer_int_nat_functions
+ transfer_int_nat_function_closures
+ transfer_int_nat_relations
+ UNIV_apply
+]
+
+
+(* first-order quantifiers *)
+
+lemma transfer_int_nat_quantifiers:
+ "(ALL (x::int) >= 0. P x) = (ALL (x::nat). P (int x))"
+ "(EX (x::int) >= 0. P x) = (EX (x::nat). P (int x))"
+ apply (subst all_nat)
+ apply auto [1]
+ apply (subst ex_nat)
+ apply auto
+done
+
+declare TransferMorphism_int_nat[transfer add
+ return: transfer_int_nat_quantifiers]
+
+
+(* if *)
+
+lemma int_if_cong: "(if P then (int x) else (int y)) =
+ int (if P then x else y)"
+ by auto
+
+declare TransferMorphism_int_nat [transfer add return: int_if_cong]
+
+
+
+(* operations with sets *)
+
+lemma transfer_int_nat_set_functions:
+ "nat_set A \<Longrightarrow> card A = card (nat ` A)"
+ "{} = int ` ({}::nat set)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Un B = int ` (nat ` A Un nat ` B)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Int B = int ` (nat ` A Int nat ` B)"
+ "{x. x >= 0 & P x} = int ` {x. P(int x)}"
+ "is_nat m \<Longrightarrow> is_nat n \<Longrightarrow> {m..n} = int ` {nat m..nat n}"
+ (* need all variants of these! *)
+ by (simp_all only: is_nat_def transfer_nat_int_set_functions
+ transfer_nat_int_set_function_closures
+ transfer_nat_int_set_return_embed nat_0_le
+ cong: transfer_nat_int_set_cong)
+
+lemma transfer_int_nat_set_function_closures:
+ "nat_set {}"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
+ "is_nat x \<Longrightarrow> nat_set {x..y}"
+ "nat_set {x. x >= 0 & P x}"
+ "nat_set (int ` C)"
+ "nat_set A \<Longrightarrow> x : A \<Longrightarrow> is_nat x"
+ by (simp_all only: transfer_nat_int_set_function_closures is_nat_def)
+
+lemma transfer_int_nat_set_relations:
+ "nat_set A \<Longrightarrow> finite A = finite (nat ` A)"
+ "is_nat x \<Longrightarrow> nat_set A \<Longrightarrow> (x : A) = (nat x : nat ` A)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A = B) = (nat ` A = nat ` B)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A < B) = (nat ` A < nat ` B)"
+ "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A <= B) = (nat ` A <= nat ` B)"
+ by (simp_all only: is_nat_def transfer_nat_int_set_relations
+ transfer_nat_int_set_return_embed nat_0_le)
+
+lemma transfer_int_nat_set_return_embed: "nat ` int ` A = A"
+ by (simp only: transfer_nat_int_set_relations
+ transfer_nat_int_set_function_closures
+ transfer_nat_int_set_return_embed nat_0_le)
+
+lemma transfer_int_nat_set_cong: "(!!x. P x = P' x) \<Longrightarrow>
+ {(x::nat). P x} = {x. P' x}"
+ by auto
+
+declare TransferMorphism_int_nat[transfer add
+ return: transfer_int_nat_set_functions
+ transfer_int_nat_set_function_closures
+ transfer_int_nat_set_relations
+ transfer_int_nat_set_return_embed
+ cong: transfer_int_nat_set_cong
+]
+
+
+(* setsum and setprod *)
+
+(* this handles the case where the *domain* of f is int *)
+lemma transfer_int_nat_sum_prod:
+ "nat_set A \<Longrightarrow> setsum f A = setsum (%x. f (int x)) (nat ` A)"
+ "nat_set A \<Longrightarrow> setprod f A = setprod (%x. f (int x)) (nat ` A)"
+ apply (subst setsum_reindex)
+ apply (unfold inj_on_def nat_set_def, auto simp add: eq_nat_nat_iff)
+ apply (subst setprod_reindex)
+ apply (unfold inj_on_def nat_set_def o_def, auto simp add: eq_nat_nat_iff
+ cong: setprod_cong)
+done
+
+(* this handles the case where the *range* of f is int *)
+lemma transfer_int_nat_sum_prod2:
+ "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow> setsum f A = int(setsum (%x. nat (f x)) A)"
+ "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow>
+ setprod f A = int(setprod (%x. nat (f x)) A)"
+ unfolding is_nat_def
+ apply (subst int_setsum, auto)
+ apply (subst int_setprod, auto simp add: cong: setprod_cong)
+done
+
+declare TransferMorphism_int_nat[transfer add
+ return: transfer_int_nat_sum_prod transfer_int_nat_sum_prod2
+ cong: setsum_cong setprod_cong]
+
+end
--- a/src/HOL/NewNumberTheory/Binomial.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,373 +0,0 @@
-(* Title: Binomial.thy
- Authors: Lawrence C. Paulson, Jeremy Avigad, Tobias Nipkow
-
-
-Defines the "choose" function, and establishes basic properties.
-
-The original theory "Binomial" was by Lawrence C. Paulson, based on
-the work of Andy Gordon and Florian Kammueller. The approach here,
-which derives the definition of binomial coefficients in terms of the
-factorial function, is due to Jeremy Avigad. The binomial theorem was
-formalized by Tobias Nipkow.
-
-*)
-
-
-header {* Binomial *}
-
-theory Binomial
-imports Cong Fact
-begin
-
-
-subsection {* Main definitions *}
-
-class binomial =
-
-fixes
- binomial :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "choose" 65)
-
-(* definitions for the natural numbers *)
-
-instantiation nat :: binomial
-
-begin
-
-fun
- binomial_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
-where
- "binomial_nat n k =
- (if k = 0 then 1 else
- if n = 0 then 0 else
- (binomial (n - 1) k) + (binomial (n - 1) (k - 1)))"
-
-instance proof qed
-
-end
-
-(* definitions for the integers *)
-
-instantiation int :: binomial
-
-begin
-
-definition
- binomial_int :: "int => int \<Rightarrow> int"
-where
- "binomial_int n k = (if n \<ge> 0 \<and> k \<ge> 0 then int (binomial (nat n) (nat k))
- else 0)"
-instance proof qed
-
-end
-
-
-subsection {* Set up Transfer *}
-
-lemma transfer_nat_int_binomial:
- "(n::int) >= 0 \<Longrightarrow> k >= 0 \<Longrightarrow> binomial (nat n) (nat k) =
- nat (binomial n k)"
- unfolding binomial_int_def
- by auto
-
-lemma transfer_nat_int_binomial_closure:
- "n >= (0::int) \<Longrightarrow> k >= 0 \<Longrightarrow> binomial n k >= 0"
- by (auto simp add: binomial_int_def)
-
-declare TransferMorphism_nat_int[transfer add return:
- transfer_nat_int_binomial transfer_nat_int_binomial_closure]
-
-lemma transfer_int_nat_binomial:
- "binomial (int n) (int k) = int (binomial n k)"
- unfolding fact_int_def binomial_int_def by auto
-
-lemma transfer_int_nat_binomial_closure:
- "is_nat n \<Longrightarrow> is_nat k \<Longrightarrow> binomial n k >= 0"
- by (auto simp add: binomial_int_def)
-
-declare TransferMorphism_int_nat[transfer add return:
- transfer_int_nat_binomial transfer_int_nat_binomial_closure]
-
-
-subsection {* Binomial coefficients *}
-
-lemma choose_zero_nat [simp]: "(n::nat) choose 0 = 1"
- by simp
-
-lemma choose_zero_int [simp]: "n \<ge> 0 \<Longrightarrow> (n::int) choose 0 = 1"
- by (simp add: binomial_int_def)
-
-lemma zero_choose_nat [rule_format,simp]: "ALL (k::nat) > n. n choose k = 0"
- by (induct n rule: induct'_nat, auto)
-
-lemma zero_choose_int [rule_format,simp]: "(k::int) > n \<Longrightarrow> n choose k = 0"
- unfolding binomial_int_def apply (case_tac "n < 0")
- apply force
- apply (simp del: binomial_nat.simps)
-done
-
-lemma choose_reduce_nat: "(n::nat) > 0 \<Longrightarrow> 0 < k \<Longrightarrow>
- (n choose k) = ((n - 1) choose k) + ((n - 1) choose (k - 1))"
- by simp
-
-lemma choose_reduce_int: "(n::int) > 0 \<Longrightarrow> 0 < k \<Longrightarrow>
- (n choose k) = ((n - 1) choose k) + ((n - 1) choose (k - 1))"
- unfolding binomial_int_def apply (subst choose_reduce_nat)
- apply (auto simp del: binomial_nat.simps
- simp add: nat_diff_distrib)
-done
-
-lemma choose_plus_one_nat: "((n::nat) + 1) choose (k + 1) =
- (n choose (k + 1)) + (n choose k)"
- by (simp add: choose_reduce_nat)
-
-lemma choose_Suc_nat: "(Suc n) choose (Suc k) =
- (n choose (Suc k)) + (n choose k)"
- by (simp add: choose_reduce_nat One_nat_def)
-
-lemma choose_plus_one_int: "n \<ge> 0 \<Longrightarrow> k \<ge> 0 \<Longrightarrow> ((n::int) + 1) choose (k + 1) =
- (n choose (k + 1)) + (n choose k)"
- by (simp add: binomial_int_def choose_plus_one_nat nat_add_distrib del: binomial_nat.simps)
-
-declare binomial_nat.simps [simp del]
-
-lemma choose_self_nat [simp]: "((n::nat) choose n) = 1"
- by (induct n rule: induct'_nat, auto simp add: choose_plus_one_nat)
-
-lemma choose_self_int [simp]: "n \<ge> 0 \<Longrightarrow> ((n::int) choose n) = 1"
- by (auto simp add: binomial_int_def)
-
-lemma choose_one_nat [simp]: "(n::nat) choose 1 = n"
- by (induct n rule: induct'_nat, auto simp add: choose_reduce_nat)
-
-lemma choose_one_int [simp]: "n \<ge> 0 \<Longrightarrow> (n::int) choose 1 = n"
- by (auto simp add: binomial_int_def)
-
-lemma plus_one_choose_self_nat [simp]: "(n::nat) + 1 choose n = n + 1"
- apply (induct n rule: induct'_nat, force)
- apply (case_tac "n = 0")
- apply auto
- apply (subst choose_reduce_nat)
- apply (auto simp add: One_nat_def)
- (* natdiff_cancel_numerals introduces Suc *)
-done
-
-lemma Suc_choose_self_nat [simp]: "(Suc n) choose n = Suc n"
- using plus_one_choose_self_nat by (simp add: One_nat_def)
-
-lemma plus_one_choose_self_int [rule_format, simp]:
- "(n::int) \<ge> 0 \<longrightarrow> n + 1 choose n = n + 1"
- by (auto simp add: binomial_int_def nat_add_distrib)
-
-(* bounded quantification doesn't work with the unicode characters? *)
-lemma choose_pos_nat [rule_format]: "ALL k <= (n::nat).
- ((n::nat) choose k) > 0"
- apply (induct n rule: induct'_nat)
- apply force
- apply clarify
- apply (case_tac "k = 0")
- apply force
- apply (subst choose_reduce_nat)
- apply auto
-done
-
-lemma choose_pos_int: "n \<ge> 0 \<Longrightarrow> k >= 0 \<Longrightarrow> k \<le> n \<Longrightarrow>
- ((n::int) choose k) > 0"
- by (auto simp add: binomial_int_def choose_pos_nat)
-
-lemma binomial_induct [rule_format]: "(ALL (n::nat). P n n) \<longrightarrow>
- (ALL n. P (n + 1) 0) \<longrightarrow> (ALL n. (ALL k < n. P n k \<longrightarrow> P n (k + 1) \<longrightarrow>
- P (n + 1) (k + 1))) \<longrightarrow> (ALL k <= n. P n k)"
- apply (induct n rule: induct'_nat)
- apply auto
- apply (case_tac "k = 0")
- apply auto
- apply (case_tac "k = n + 1")
- apply auto
- apply (drule_tac x = n in spec) back back
- apply (drule_tac x = "k - 1" in spec) back back back
- apply auto
-done
-
-lemma choose_altdef_aux_nat: "(k::nat) \<le> n \<Longrightarrow>
- fact k * fact (n - k) * (n choose k) = fact n"
- apply (rule binomial_induct [of _ k n])
- apply auto
-proof -
- fix k :: nat and n
- assume less: "k < n"
- assume ih1: "fact k * fact (n - k) * (n choose k) = fact n"
- hence one: "fact (k + 1) * fact (n - k) * (n choose k) = (k + 1) * fact n"
- by (subst fact_plus_one_nat, auto)
- assume ih2: "fact (k + 1) * fact (n - (k + 1)) * (n choose (k + 1)) =
- fact n"
- with less have "fact (k + 1) * fact ((n - (k + 1)) + 1) *
- (n choose (k + 1)) = (n - k) * fact n"
- by (subst (2) fact_plus_one_nat, auto)
- with less have two: "fact (k + 1) * fact (n - k) * (n choose (k + 1)) =
- (n - k) * fact n" by simp
- have "fact (k + 1) * fact (n - k) * (n + 1 choose (k + 1)) =
- fact (k + 1) * fact (n - k) * (n choose (k + 1)) +
- fact (k + 1) * fact (n - k) * (n choose k)"
- by (subst choose_reduce_nat, auto simp add: ring_simps)
- also note one
- also note two
- also with less have "(n - k) * fact n + (k + 1) * fact n= fact (n + 1)"
- apply (subst fact_plus_one_nat)
- apply (subst left_distrib [symmetric])
- apply simp
- done
- finally show "fact (k + 1) * fact (n - k) * (n + 1 choose (k + 1)) =
- fact (n + 1)" .
-qed
-
-lemma choose_altdef_nat: "(k::nat) \<le> n \<Longrightarrow>
- n choose k = fact n div (fact k * fact (n - k))"
- apply (frule choose_altdef_aux_nat)
- apply (erule subst)
- apply (simp add: mult_ac)
-done
-
-
-lemma choose_altdef_int:
- assumes "(0::int) <= k" and "k <= n"
- shows "n choose k = fact n div (fact k * fact (n - k))"
-
- apply (subst tsub_eq [symmetric], rule prems)
- apply (rule choose_altdef_nat [transferred])
- using prems apply auto
-done
-
-lemma choose_dvd_nat: "(k::nat) \<le> n \<Longrightarrow> fact k * fact (n - k) dvd fact n"
- unfolding dvd_def apply (frule choose_altdef_aux_nat)
- (* why don't blast and auto get this??? *)
- apply (rule exI)
- apply (erule sym)
-done
-
-lemma choose_dvd_int:
- assumes "(0::int) <= k" and "k <= n"
- shows "fact k * fact (n - k) dvd fact n"
-
- apply (subst tsub_eq [symmetric], rule prems)
- apply (rule choose_dvd_nat [transferred])
- using prems apply auto
-done
-
-(* generalizes Tobias Nipkow's proof to any commutative semiring *)
-theorem binomial: "(a+b::'a::{comm_ring_1,power})^n =
- (SUM k=0..n. (of_nat (n choose k)) * a^k * b^(n-k))" (is "?P n")
-proof (induct n rule: induct'_nat)
- show "?P 0" by simp
-next
- fix n
- assume ih: "?P n"
- have decomp: "{0..n+1} = {0} Un {n+1} Un {1..n}"
- by auto
- have decomp2: "{0..n} = {0} Un {1..n}"
- by auto
- have decomp3: "{1..n+1} = {n+1} Un {1..n}"
- by auto
- have "(a+b)^(n+1) =
- (a+b) * (SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
- using ih by (simp add: power_plus_one)
- also have "... = a*(SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k)) +
- b*(SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
- by (rule distrib)
- also have "... = (SUM k=0..n. of_nat (n choose k) * a^(k+1) * b^(n-k)) +
- (SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k+1))"
- by (subst (1 2) power_plus_one, simp add: setsum_right_distrib mult_ac)
- also have "... = (SUM k=0..n. of_nat (n choose k) * a^k * b^(n+1-k)) +
- (SUM k=1..n+1. of_nat (n choose (k - 1)) * a^k * b^(n+1-k))"
- by (simp add:setsum_shift_bounds_cl_Suc_ivl Suc_diff_le
- power_Suc ring_simps One_nat_def del:setsum_cl_ivl_Suc)
- also have "... = a^(n+1) + b^(n+1) +
- (SUM k=1..n. of_nat (n choose (k - 1)) * a^k * b^(n+1-k)) +
- (SUM k=1..n. of_nat (n choose k) * a^k * b^(n+1-k))"
- by (simp add: decomp2 decomp3)
- also have
- "... = a^(n+1) + b^(n+1) +
- (SUM k=1..n. of_nat(n+1 choose k) * a^k * b^(n+1-k))"
- by (auto simp add: ring_simps setsum_addf [symmetric]
- choose_reduce_nat)
- also have "... = (SUM k=0..n+1. of_nat (n+1 choose k) * a^k * b^(n+1-k))"
- using decomp by (simp add: ring_simps)
- finally show "?P (n + 1)" by simp
-qed
-
-lemma set_explicit: "{S. S = T \<and> P S} = (if P T then {T} else {})"
- by auto
-
-lemma card_subsets_nat [rule_format]:
- fixes S :: "'a set"
- assumes "finite S"
- shows "ALL k. card {T. T \<le> S \<and> card T = k} = card S choose k"
- (is "?P S")
-using `finite S`
-proof (induct set: finite)
- show "?P {}" by (auto simp add: set_explicit)
- next fix x :: "'a" and F
- assume iassms: "finite F" "x ~: F"
- assume ih: "?P F"
- show "?P (insert x F)" (is "ALL k. ?Q k")
- proof
- fix k
- show "card {T. T \<subseteq> (insert x F) \<and> card T = k} =
- card (insert x F) choose k" (is "?Q k")
- proof (induct k rule: induct'_nat)
- from iassms have "{T. T \<le> (insert x F) \<and> card T = 0} = {{}}"
- apply auto
- apply (subst (asm) card_0_eq)
- apply (auto elim: finite_subset)
- done
- thus "?Q 0"
- by auto
- next fix k
- show "?Q (k + 1)"
- proof -
- from iassms have fin: "finite (insert x F)" by auto
- hence "{ T. T \<subseteq> insert x F \<and> card T = k + 1} =
- {T. T \<le> F & card T = k + 1} Un
- {T. T \<le> insert x F & x : T & card T = k + 1}"
- by (auto intro!: subsetI)
- with iassms fin have "card ({T. T \<le> insert x F \<and> card T = k + 1}) =
- card ({T. T \<subseteq> F \<and> card T = k + 1}) +
- card ({T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1})"
- apply (subst card_Un_disjoint [symmetric])
- apply auto
- (* note: nice! Didn't have to say anything here *)
- done
- also from ih have "card ({T. T \<subseteq> F \<and> card T = k + 1}) =
- card F choose (k+1)" by auto
- also have "card ({T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1}) =
- card ({T. T <= F & card T = k})"
- proof -
- let ?f = "%T. T Un {x}"
- from iassms have "inj_on ?f {T. T <= F & card T = k}"
- unfolding inj_on_def by (auto intro!: subsetI)
- hence "card ({T. T <= F & card T = k}) =
- card(?f ` {T. T <= F & card T = k})"
- by (rule card_image [symmetric])
- also from iassms fin have "?f ` {T. T <= F & card T = k} =
- {T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1}"
- unfolding image_def
- (* I can't figure out why this next line takes so long *)
- apply auto
- apply (frule (1) finite_subset, force)
- apply (rule_tac x = "xa - {x}" in exI)
- apply (subst card_Diff_singleton)
- apply (auto elim: finite_subset)
- done
- finally show ?thesis by (rule sym)
- qed
- also from ih have "card ({T. T <= F & card T = k}) = card F choose k"
- by auto
- finally have "card ({T. T \<le> insert x F \<and> card T = k + 1}) =
- card F choose (k + 1) + (card F choose k)".
- with iassms choose_plus_one_nat show ?thesis
- by auto
- qed
- qed
- qed
-qed
-
-end
--- a/src/HOL/NewNumberTheory/Cong.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1091 +0,0 @@
-(* Title: HOL/Library/Cong.thy
- ID:
- Authors: Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
- Thomas M. Rasmussen, Jeremy Avigad
-
-
-Defines congruence (notation: [x = y] (mod z)) for natural numbers and
-integers.
-
-This file combines and revises a number of prior developments.
-
-The original theories "GCD" and "Primes" were by Christophe Tabacznyj
-and Lawrence C. Paulson, based on \cite{davenport92}. They introduced
-gcd, lcm, and prime for the natural numbers.
-
-The original theory "IntPrimes" was by Thomas M. Rasmussen, and
-extended gcd, lcm, primes to the integers. Amine Chaieb provided
-another extension of the notions to the integers, and added a number
-of results to "Primes" and "GCD".
-
-The original theory, "IntPrimes", by Thomas M. Rasmussen, defined and
-developed the congruence relations on the integers. The notion was
-extended to the natural numbers by Chiaeb. Jeremy Avigad combined
-these, revised and tidied them, made the development uniform for the
-natural numbers and the integers, and added a number of new theorems.
-
-*)
-
-
-header {* Congruence *}
-
-theory Cong
-imports GCD
-begin
-
-subsection {* Turn off One_nat_def *}
-
-lemma induct'_nat [case_names zero plus1, induct type: nat]:
- "\<lbrakk> P (0::nat); !!n. P n \<Longrightarrow> P (n + 1)\<rbrakk> \<Longrightarrow> P n"
-by (erule nat_induct) (simp add:One_nat_def)
-
-lemma cases_nat [case_names zero plus1, cases type: nat]:
- "P (0::nat) \<Longrightarrow> (!!n. P (n + 1)) \<Longrightarrow> P n"
-by(metis induct'_nat)
-
-lemma power_plus_one [simp]: "(x::'a::power)^(n + 1) = x * x^n"
-by (simp add: One_nat_def)
-
-lemma power_eq_one_eq_nat [simp]:
- "((x::nat)^m = 1) = (m = 0 | x = 1)"
-by (induct m, auto)
-
-lemma card_insert_if' [simp]: "finite A \<Longrightarrow>
- card (insert x A) = (if x \<in> A then (card A) else (card A) + 1)"
-by (auto simp add: insert_absorb)
-
-(* why wasn't card_insert_if a simp rule? *)
-declare card_insert_disjoint [simp del]
-
-lemma nat_1' [simp]: "nat 1 = 1"
-by simp
-
-(* For those annoying moments where Suc reappears, use Suc_eq_plus1 *)
-
-declare nat_1 [simp del]
-declare add_2_eq_Suc [simp del]
-declare add_2_eq_Suc' [simp del]
-
-
-declare mod_pos_pos_trivial [simp]
-
-
-subsection {* Main definitions *}
-
-class cong =
-
-fixes
- cong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(1[_ = _] '(mod _'))")
-
-begin
-
-abbreviation
- notcong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(1[_ \<noteq> _] '(mod _'))")
-where
- "notcong x y m == (~cong x y m)"
-
-end
-
-(* definitions for the natural numbers *)
-
-instantiation nat :: cong
-
-begin
-
-definition
- cong_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
-where
- "cong_nat x y m = ((x mod m) = (y mod m))"
-
-instance proof qed
-
-end
-
-
-(* definitions for the integers *)
-
-instantiation int :: cong
-
-begin
-
-definition
- cong_int :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
-where
- "cong_int x y m = ((x mod m) = (y mod m))"
-
-instance proof qed
-
-end
-
-
-subsection {* Set up Transfer *}
-
-
-lemma transfer_nat_int_cong:
- "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> m >= 0 \<Longrightarrow>
- ([(nat x) = (nat y)] (mod (nat m))) = ([x = y] (mod m))"
- unfolding cong_int_def cong_nat_def
- apply (auto simp add: nat_mod_distrib [symmetric])
- apply (subst (asm) eq_nat_nat_iff)
- apply (case_tac "m = 0", force, rule pos_mod_sign, force)+
- apply assumption
-done
-
-declare TransferMorphism_nat_int[transfer add return:
- transfer_nat_int_cong]
-
-lemma transfer_int_nat_cong:
- "[(int x) = (int y)] (mod (int m)) = [x = y] (mod m)"
- apply (auto simp add: cong_int_def cong_nat_def)
- apply (auto simp add: zmod_int [symmetric])
-done
-
-declare TransferMorphism_int_nat[transfer add return:
- transfer_int_nat_cong]
-
-
-subsection {* Congruence *}
-
-(* was zcong_0, etc. *)
-lemma cong_0_nat [simp, presburger]: "([(a::nat) = b] (mod 0)) = (a = b)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_0_int [simp, presburger]: "([(a::int) = b] (mod 0)) = (a = b)"
- by (unfold cong_int_def, auto)
-
-lemma cong_1_nat [simp, presburger]: "[(a::nat) = b] (mod 1)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_Suc_0_nat [simp, presburger]: "[(a::nat) = b] (mod Suc 0)"
- by (unfold cong_nat_def, auto simp add: One_nat_def)
-
-lemma cong_1_int [simp, presburger]: "[(a::int) = b] (mod 1)"
- by (unfold cong_int_def, auto)
-
-lemma cong_refl_nat [simp]: "[(k::nat) = k] (mod m)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_refl_int [simp]: "[(k::int) = k] (mod m)"
- by (unfold cong_int_def, auto)
-
-lemma cong_sym_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_sym_int: "[(a::int) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
- by (unfold cong_int_def, auto)
-
-lemma cong_sym_eq_nat: "[(a::nat) = b] (mod m) = [b = a] (mod m)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_sym_eq_int: "[(a::int) = b] (mod m) = [b = a] (mod m)"
- by (unfold cong_int_def, auto)
-
-lemma cong_trans_nat [trans]:
- "[(a::nat) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_trans_int [trans]:
- "[(a::int) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
- by (unfold cong_int_def, auto)
-
-lemma cong_add_nat:
- "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
- apply (unfold cong_nat_def)
- apply (subst (1 2) mod_add_eq)
- apply simp
-done
-
-lemma cong_add_int:
- "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
- apply (unfold cong_int_def)
- apply (subst (1 2) mod_add_left_eq)
- apply (subst (1 2) mod_add_right_eq)
- apply simp
-done
-
-lemma cong_diff_int:
- "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a - c = b - d] (mod m)"
- apply (unfold cong_int_def)
- apply (subst (1 2) mod_diff_eq)
- apply simp
-done
-
-lemma cong_diff_aux_int:
- "(a::int) >= c \<Longrightarrow> b >= d \<Longrightarrow> [(a::int) = b] (mod m) \<Longrightarrow>
- [c = d] (mod m) \<Longrightarrow> [tsub a c = tsub b d] (mod m)"
- apply (subst (1 2) tsub_eq)
- apply (auto intro: cong_diff_int)
-done;
-
-lemma cong_diff_nat:
- assumes "(a::nat) >= c" and "b >= d" and "[a = b] (mod m)" and
- "[c = d] (mod m)"
- shows "[a - c = b - d] (mod m)"
-
- using prems by (rule cong_diff_aux_int [transferred]);
-
-lemma cong_mult_nat:
- "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
- apply (unfold cong_nat_def)
- apply (subst (1 2) mod_mult_eq)
- apply simp
-done
-
-lemma cong_mult_int:
- "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
- apply (unfold cong_int_def)
- apply (subst (1 2) zmod_zmult1_eq)
- apply (subst (1 2) mult_commute)
- apply (subst (1 2) zmod_zmult1_eq)
- apply simp
-done
-
-lemma cong_exp_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
- apply (induct k)
- apply (auto simp add: cong_refl_nat cong_mult_nat)
-done
-
-lemma cong_exp_int: "[(x::int) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
- apply (induct k)
- apply (auto simp add: cong_refl_int cong_mult_int)
-done
-
-lemma cong_setsum_nat [rule_format]:
- "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
- [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
- apply (case_tac "finite A")
- apply (induct set: finite)
- apply (auto intro: cong_add_nat)
-done
-
-lemma cong_setsum_int [rule_format]:
- "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
- [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
- apply (case_tac "finite A")
- apply (induct set: finite)
- apply (auto intro: cong_add_int)
-done
-
-lemma cong_setprod_nat [rule_format]:
- "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
- [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
- apply (case_tac "finite A")
- apply (induct set: finite)
- apply (auto intro: cong_mult_nat)
-done
-
-lemma cong_setprod_int [rule_format]:
- "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
- [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
- apply (case_tac "finite A")
- apply (induct set: finite)
- apply (auto intro: cong_mult_int)
-done
-
-lemma cong_scalar_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
- by (rule cong_mult_nat, simp_all)
-
-lemma cong_scalar_int: "[(a::int)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
- by (rule cong_mult_int, simp_all)
-
-lemma cong_scalar2_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
- by (rule cong_mult_nat, simp_all)
-
-lemma cong_scalar2_int: "[(a::int)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
- by (rule cong_mult_int, simp_all)
-
-lemma cong_mult_self_nat: "[(a::nat) * m = 0] (mod m)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_mult_self_int: "[(a::int) * m = 0] (mod m)"
- by (unfold cong_int_def, auto)
-
-lemma cong_eq_diff_cong_0_int: "[(a::int) = b] (mod m) = [a - b = 0] (mod m)"
- apply (rule iffI)
- apply (erule cong_diff_int [of a b m b b, simplified])
- apply (erule cong_add_int [of "a - b" 0 m b b, simplified])
-done
-
-lemma cong_eq_diff_cong_0_aux_int: "a >= b \<Longrightarrow>
- [(a::int) = b] (mod m) = [tsub a b = 0] (mod m)"
- by (subst tsub_eq, assumption, rule cong_eq_diff_cong_0_int)
-
-lemma cong_eq_diff_cong_0_nat:
- assumes "(a::nat) >= b"
- shows "[a = b] (mod m) = [a - b = 0] (mod m)"
-
- using prems by (rule cong_eq_diff_cong_0_aux_int [transferred])
-
-lemma cong_diff_cong_0'_nat:
- "[(x::nat) = y] (mod n) \<longleftrightarrow>
- (if x <= y then [y - x = 0] (mod n) else [x - y = 0] (mod n))"
- apply (case_tac "y <= x")
- apply (frule cong_eq_diff_cong_0_nat [where m = n])
- apply auto [1]
- apply (subgoal_tac "x <= y")
- apply (frule cong_eq_diff_cong_0_nat [where m = n])
- apply (subst cong_sym_eq_nat)
- apply auto
-done
-
-lemma cong_altdef_nat: "(a::nat) >= b \<Longrightarrow> [a = b] (mod m) = (m dvd (a - b))"
- apply (subst cong_eq_diff_cong_0_nat, assumption)
- apply (unfold cong_nat_def)
- apply (simp add: dvd_eq_mod_eq_0 [symmetric])
-done
-
-lemma cong_altdef_int: "[(a::int) = b] (mod m) = (m dvd (a - b))"
- apply (subst cong_eq_diff_cong_0_int)
- apply (unfold cong_int_def)
- apply (simp add: dvd_eq_mod_eq_0 [symmetric])
-done
-
-lemma cong_abs_int: "[(x::int) = y] (mod abs m) = [x = y] (mod m)"
- by (simp add: cong_altdef_int)
-
-lemma cong_square_int:
- "\<lbrakk> prime (p::int); 0 < a; [a * a = 1] (mod p) \<rbrakk>
- \<Longrightarrow> [a = 1] (mod p) \<or> [a = - 1] (mod p)"
- apply (simp only: cong_altdef_int)
- apply (subst prime_dvd_mult_eq_int [symmetric], assumption)
- (* any way around this? *)
- apply (subgoal_tac "a * a - 1 = (a - 1) * (a - -1)")
- apply (auto simp add: ring_simps)
-done
-
-lemma cong_mult_rcancel_int:
- "coprime k (m::int) \<Longrightarrow> [a * k = b * k] (mod m) = [a = b] (mod m)"
- apply (subst (1 2) cong_altdef_int)
- apply (subst left_diff_distrib [symmetric])
- apply (rule coprime_dvd_mult_iff_int)
- apply (subst gcd_commute_int, assumption)
-done
-
-lemma cong_mult_rcancel_nat:
- assumes "coprime k (m::nat)"
- shows "[a * k = b * k] (mod m) = [a = b] (mod m)"
-
- apply (rule cong_mult_rcancel_int [transferred])
- using prems apply auto
-done
-
-lemma cong_mult_lcancel_nat:
- "coprime k (m::nat) \<Longrightarrow> [k * a = k * b ] (mod m) = [a = b] (mod m)"
- by (simp add: mult_commute cong_mult_rcancel_nat)
-
-lemma cong_mult_lcancel_int:
- "coprime k (m::int) \<Longrightarrow> [k * a = k * b] (mod m) = [a = b] (mod m)"
- by (simp add: mult_commute cong_mult_rcancel_int)
-
-(* was zcong_zgcd_zmult_zmod *)
-lemma coprime_cong_mult_int:
- "[(a::int) = b] (mod m) \<Longrightarrow> [a = b] (mod n) \<Longrightarrow> coprime m n
- \<Longrightarrow> [a = b] (mod m * n)"
- apply (simp only: cong_altdef_int)
- apply (erule (2) divides_mult_int)
-done
-
-lemma coprime_cong_mult_nat:
- assumes "[(a::nat) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
- shows "[a = b] (mod m * n)"
-
- apply (rule coprime_cong_mult_int [transferred])
- using prems apply auto
-done
-
-lemma cong_less_imp_eq_nat: "0 \<le> (a::nat) \<Longrightarrow>
- a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
- by (auto simp add: cong_nat_def mod_pos_pos_trivial)
-
-lemma cong_less_imp_eq_int: "0 \<le> (a::int) \<Longrightarrow>
- a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
- by (auto simp add: cong_int_def mod_pos_pos_trivial)
-
-lemma cong_less_unique_nat:
- "0 < (m::nat) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
- apply auto
- apply (rule_tac x = "a mod m" in exI)
- apply (unfold cong_nat_def, auto)
-done
-
-lemma cong_less_unique_int:
- "0 < (m::int) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
- apply auto
- apply (rule_tac x = "a mod m" in exI)
- apply (unfold cong_int_def, auto simp add: mod_pos_pos_trivial)
-done
-
-lemma cong_iff_lin_int: "([(a::int) = b] (mod m)) = (\<exists>k. b = a + m * k)"
- apply (auto simp add: cong_altdef_int dvd_def ring_simps)
- apply (rule_tac [!] x = "-k" in exI, auto)
-done
-
-lemma cong_iff_lin_nat: "([(a::nat) = b] (mod m)) =
- (\<exists>k1 k2. b + k1 * m = a + k2 * m)"
- apply (rule iffI)
- apply (case_tac "b <= a")
- apply (subst (asm) cong_altdef_nat, assumption)
- apply (unfold dvd_def, auto)
- apply (rule_tac x = k in exI)
- apply (rule_tac x = 0 in exI)
- apply (auto simp add: ring_simps)
- apply (subst (asm) cong_sym_eq_nat)
- apply (subst (asm) cong_altdef_nat)
- apply force
- apply (unfold dvd_def, auto)
- apply (rule_tac x = 0 in exI)
- apply (rule_tac x = k in exI)
- apply (auto simp add: ring_simps)
- apply (unfold cong_nat_def)
- apply (subgoal_tac "a mod m = (a + k2 * m) mod m")
- apply (erule ssubst)back
- apply (erule subst)
- apply auto
-done
-
-lemma cong_gcd_eq_int: "[(a::int) = b] (mod m) \<Longrightarrow> gcd a m = gcd b m"
- apply (subst (asm) cong_iff_lin_int, auto)
- apply (subst add_commute)
- apply (subst (2) gcd_commute_int)
- apply (subst mult_commute)
- apply (subst gcd_add_mult_int)
- apply (rule gcd_commute_int)
-done
-
-lemma cong_gcd_eq_nat:
- assumes "[(a::nat) = b] (mod m)"
- shows "gcd a m = gcd b m"
-
- apply (rule cong_gcd_eq_int [transferred])
- using prems apply auto
-done
-
-lemma cong_imp_coprime_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow>
- coprime b m"
- by (auto simp add: cong_gcd_eq_nat)
-
-lemma cong_imp_coprime_int: "[(a::int) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow>
- coprime b m"
- by (auto simp add: cong_gcd_eq_int)
-
-lemma cong_cong_mod_nat: "[(a::nat) = b] (mod m) =
- [a mod m = b mod m] (mod m)"
- by (auto simp add: cong_nat_def)
-
-lemma cong_cong_mod_int: "[(a::int) = b] (mod m) =
- [a mod m = b mod m] (mod m)"
- by (auto simp add: cong_int_def)
-
-lemma cong_minus_int [iff]: "[(a::int) = b] (mod -m) = [a = b] (mod m)"
- by (subst (1 2) cong_altdef_int, auto)
-
-lemma cong_zero_nat [iff]: "[(a::nat) = b] (mod 0) = (a = b)"
- by (auto simp add: cong_nat_def)
-
-lemma cong_zero_int [iff]: "[(a::int) = b] (mod 0) = (a = b)"
- by (auto simp add: cong_int_def)
-
-(*
-lemma mod_dvd_mod_int:
- "0 < (m::int) \<Longrightarrow> m dvd b \<Longrightarrow> (a mod b mod m) = (a mod m)"
- apply (unfold dvd_def, auto)
- apply (rule mod_mod_cancel)
- apply auto
-done
-
-lemma mod_dvd_mod:
- assumes "0 < (m::nat)" and "m dvd b"
- shows "(a mod b mod m) = (a mod m)"
-
- apply (rule mod_dvd_mod_int [transferred])
- using prems apply auto
-done
-*)
-
-lemma cong_add_lcancel_nat:
- "[(a::nat) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: cong_iff_lin_nat)
-
-lemma cong_add_lcancel_int:
- "[(a::int) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: cong_iff_lin_int)
-
-lemma cong_add_rcancel_nat: "[(x::nat) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: cong_iff_lin_nat)
-
-lemma cong_add_rcancel_int: "[(x::int) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
- by (simp add: cong_iff_lin_int)
-
-lemma cong_add_lcancel_0_nat: "[(a::nat) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: cong_iff_lin_nat)
-
-lemma cong_add_lcancel_0_int: "[(a::int) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: cong_iff_lin_int)
-
-lemma cong_add_rcancel_0_nat: "[x + (a::nat) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: cong_iff_lin_nat)
-
-lemma cong_add_rcancel_0_int: "[x + (a::int) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
- by (simp add: cong_iff_lin_int)
-
-lemma cong_dvd_modulus_nat: "[(x::nat) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow>
- [x = y] (mod n)"
- apply (auto simp add: cong_iff_lin_nat dvd_def)
- apply (rule_tac x="k1 * k" in exI)
- apply (rule_tac x="k2 * k" in exI)
- apply (simp add: ring_simps)
-done
-
-lemma cong_dvd_modulus_int: "[(x::int) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow>
- [x = y] (mod n)"
- by (auto simp add: cong_altdef_int dvd_def)
-
-lemma cong_dvd_eq_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
- by (unfold cong_nat_def, auto simp add: dvd_eq_mod_eq_0)
-
-lemma cong_dvd_eq_int: "[(x::int) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
- by (unfold cong_int_def, auto simp add: dvd_eq_mod_eq_0)
-
-lemma cong_mod_nat: "(n::nat) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
- by (simp add: cong_nat_def)
-
-lemma cong_mod_int: "(n::int) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
- by (simp add: cong_int_def)
-
-lemma mod_mult_cong_nat: "(a::nat) ~= 0 \<Longrightarrow> b ~= 0
- \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
- by (simp add: cong_nat_def mod_mult2_eq mod_add_left_eq)
-
-lemma neg_cong_int: "([(a::int) = b] (mod m)) = ([-a = -b] (mod m))"
- apply (simp add: cong_altdef_int)
- apply (subst dvd_minus_iff [symmetric])
- apply (simp add: ring_simps)
-done
-
-lemma cong_modulus_neg_int: "([(a::int) = b] (mod m)) = ([a = b] (mod -m))"
- by (auto simp add: cong_altdef_int)
-
-lemma mod_mult_cong_int: "(a::int) ~= 0 \<Longrightarrow> b ~= 0
- \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
- apply (case_tac "b > 0")
- apply (simp add: cong_int_def mod_mod_cancel mod_add_left_eq)
- apply (subst (1 2) cong_modulus_neg_int)
- apply (unfold cong_int_def)
- apply (subgoal_tac "a * b = (-a * -b)")
- apply (erule ssubst)
- apply (subst zmod_zmult2_eq)
- apply (auto simp add: mod_add_left_eq)
-done
-
-lemma cong_to_1_nat: "([(a::nat) = 1] (mod n)) \<Longrightarrow> (n dvd (a - 1))"
- apply (case_tac "a = 0")
- apply force
- apply (subst (asm) cong_altdef_nat)
- apply auto
-done
-
-lemma cong_0_1_nat: "[(0::nat) = 1] (mod n) = (n = 1)"
- by (unfold cong_nat_def, auto)
-
-lemma cong_0_1_int: "[(0::int) = 1] (mod n) = ((n = 1) | (n = -1))"
- by (unfold cong_int_def, auto simp add: zmult_eq_1_iff)
-
-lemma cong_to_1'_nat: "[(a::nat) = 1] (mod n) \<longleftrightarrow>
- a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
- apply (case_tac "n = 1")
- apply auto [1]
- apply (drule_tac x = "a - 1" in spec)
- apply force
- apply (case_tac "a = 0")
- apply (auto simp add: cong_0_1_nat) [1]
- apply (rule iffI)
- apply (drule cong_to_1_nat)
- apply (unfold dvd_def)
- apply auto [1]
- apply (rule_tac x = k in exI)
- apply (auto simp add: ring_simps) [1]
- apply (subst cong_altdef_nat)
- apply (auto simp add: dvd_def)
-done
-
-lemma cong_le_nat: "(y::nat) <= x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
- apply (subst cong_altdef_nat)
- apply assumption
- apply (unfold dvd_def, auto simp add: ring_simps)
- apply (rule_tac x = k in exI)
- apply auto
-done
-
-lemma cong_solve_nat: "(a::nat) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
- apply (case_tac "n = 0")
- apply force
- apply (frule bezout_nat [of a n], auto)
- apply (rule exI, erule ssubst)
- apply (rule cong_trans_nat)
- apply (rule cong_add_nat)
- apply (subst mult_commute)
- apply (rule cong_mult_self_nat)
- prefer 2
- apply simp
- apply (rule cong_refl_nat)
- apply (rule cong_refl_nat)
-done
-
-lemma cong_solve_int: "(a::int) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
- apply (case_tac "n = 0")
- apply (case_tac "a \<ge> 0")
- apply auto
- apply (rule_tac x = "-1" in exI)
- apply auto
- apply (insert bezout_int [of a n], auto)
- apply (rule exI)
- apply (erule subst)
- apply (rule cong_trans_int)
- prefer 2
- apply (rule cong_add_int)
- apply (rule cong_refl_int)
- apply (rule cong_sym_int)
- apply (rule cong_mult_self_int)
- apply simp
- apply (subst mult_commute)
- apply (rule cong_refl_int)
-done
-
-lemma cong_solve_dvd_nat:
- assumes a: "(a::nat) \<noteq> 0" and b: "gcd a n dvd d"
- shows "EX x. [a * x = d] (mod n)"
-proof -
- from cong_solve_nat [OF a] obtain x where
- "[a * x = gcd a n](mod n)"
- by auto
- hence "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
- by (elim cong_scalar2_nat)
- also from b have "(d div gcd a n) * gcd a n = d"
- by (rule dvd_div_mult_self)
- also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
- by auto
- finally show ?thesis
- by auto
-qed
-
-lemma cong_solve_dvd_int:
- assumes a: "(a::int) \<noteq> 0" and b: "gcd a n dvd d"
- shows "EX x. [a * x = d] (mod n)"
-proof -
- from cong_solve_int [OF a] obtain x where
- "[a * x = gcd a n](mod n)"
- by auto
- hence "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
- by (elim cong_scalar2_int)
- also from b have "(d div gcd a n) * gcd a n = d"
- by (rule dvd_div_mult_self)
- also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
- by auto
- finally show ?thesis
- by auto
-qed
-
-lemma cong_solve_coprime_nat: "coprime (a::nat) n \<Longrightarrow>
- EX x. [a * x = 1] (mod n)"
- apply (case_tac "a = 0")
- apply force
- apply (frule cong_solve_nat [of a n])
- apply auto
-done
-
-lemma cong_solve_coprime_int: "coprime (a::int) n \<Longrightarrow>
- EX x. [a * x = 1] (mod n)"
- apply (case_tac "a = 0")
- apply auto
- apply (case_tac "n \<ge> 0")
- apply auto
- apply (subst cong_int_def, auto)
- apply (frule cong_solve_int [of a n])
- apply auto
-done
-
-lemma coprime_iff_invertible_nat: "m > (1::nat) \<Longrightarrow> coprime a m =
- (EX x. [a * x = 1] (mod m))"
- apply (auto intro: cong_solve_coprime_nat)
- apply (unfold cong_nat_def, auto intro: invertible_coprime_nat)
-done
-
-lemma coprime_iff_invertible_int: "m > (1::int) \<Longrightarrow> coprime a m =
- (EX x. [a * x = 1] (mod m))"
- apply (auto intro: cong_solve_coprime_int)
- apply (unfold cong_int_def)
- apply (auto intro: invertible_coprime_int)
-done
-
-lemma coprime_iff_invertible'_int: "m > (1::int) \<Longrightarrow> coprime a m =
- (EX x. 0 <= x & x < m & [a * x = 1] (mod m))"
- apply (subst coprime_iff_invertible_int)
- apply auto
- apply (auto simp add: cong_int_def)
- apply (rule_tac x = "x mod m" in exI)
- apply (auto simp add: mod_mult_right_eq [symmetric])
-done
-
-
-lemma cong_cong_lcm_nat: "[(x::nat) = y] (mod a) \<Longrightarrow>
- [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
- apply (case_tac "y \<le> x")
- apply (auto simp add: cong_altdef_nat lcm_least_nat) [1]
- apply (rule cong_sym_nat)
- apply (subst (asm) (1 2) cong_sym_eq_nat)
- apply (auto simp add: cong_altdef_nat lcm_least_nat)
-done
-
-lemma cong_cong_lcm_int: "[(x::int) = y] (mod a) \<Longrightarrow>
- [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
- by (auto simp add: cong_altdef_int lcm_least_int) [1]
-
-lemma cong_cong_coprime_nat: "coprime a b \<Longrightarrow> [(x::nat) = y] (mod a) \<Longrightarrow>
- [x = y] (mod b) \<Longrightarrow> [x = y] (mod a * b)"
- apply (frule (1) cong_cong_lcm_nat)back
- apply (simp add: lcm_nat_def)
-done
-
-lemma cong_cong_coprime_int: "coprime a b \<Longrightarrow> [(x::int) = y] (mod a) \<Longrightarrow>
- [x = y] (mod b) \<Longrightarrow> [x = y] (mod a * b)"
- apply (frule (1) cong_cong_lcm_int)back
- apply (simp add: lcm_altdef_int cong_abs_int abs_mult [symmetric])
-done
-
-lemma cong_cong_setprod_coprime_nat [rule_format]: "finite A \<Longrightarrow>
- (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
- (ALL i:A. [(x::nat) = y] (mod m i)) \<longrightarrow>
- [x = y] (mod (PROD i:A. m i))"
- apply (induct set: finite)
- apply auto
- apply (rule cong_cong_coprime_nat)
- apply (subst gcd_commute_nat)
- apply (rule setprod_coprime_nat)
- apply auto
-done
-
-lemma cong_cong_setprod_coprime_int [rule_format]: "finite A \<Longrightarrow>
- (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
- (ALL i:A. [(x::int) = y] (mod m i)) \<longrightarrow>
- [x = y] (mod (PROD i:A. m i))"
- apply (induct set: finite)
- apply auto
- apply (rule cong_cong_coprime_int)
- apply (subst gcd_commute_int)
- apply (rule setprod_coprime_int)
- apply auto
-done
-
-lemma binary_chinese_remainder_aux_nat:
- assumes a: "coprime (m1::nat) m2"
- shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
- [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
-proof -
- from cong_solve_coprime_nat [OF a]
- obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
- by auto
- from a have b: "coprime m2 m1"
- by (subst gcd_commute_nat)
- from cong_solve_coprime_nat [OF b]
- obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
- by auto
- have "[m1 * x1 = 0] (mod m1)"
- by (subst mult_commute, rule cong_mult_self_nat)
- moreover have "[m2 * x2 = 0] (mod m2)"
- by (subst mult_commute, rule cong_mult_self_nat)
- moreover note one two
- ultimately show ?thesis by blast
-qed
-
-lemma binary_chinese_remainder_aux_int:
- assumes a: "coprime (m1::int) m2"
- shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
- [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
-proof -
- from cong_solve_coprime_int [OF a]
- obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
- by auto
- from a have b: "coprime m2 m1"
- by (subst gcd_commute_int)
- from cong_solve_coprime_int [OF b]
- obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
- by auto
- have "[m1 * x1 = 0] (mod m1)"
- by (subst mult_commute, rule cong_mult_self_int)
- moreover have "[m2 * x2 = 0] (mod m2)"
- by (subst mult_commute, rule cong_mult_self_int)
- moreover note one two
- ultimately show ?thesis by blast
-qed
-
-lemma binary_chinese_remainder_nat:
- assumes a: "coprime (m1::nat) m2"
- shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
-proof -
- from binary_chinese_remainder_aux_nat [OF a] obtain b1 b2
- where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
- "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
- by blast
- let ?x = "u1 * b1 + u2 * b2"
- have "[?x = u1 * 1 + u2 * 0] (mod m1)"
- apply (rule cong_add_nat)
- apply (rule cong_scalar2_nat)
- apply (rule `[b1 = 1] (mod m1)`)
- apply (rule cong_scalar2_nat)
- apply (rule `[b2 = 0] (mod m1)`)
- done
- hence "[?x = u1] (mod m1)" by simp
- have "[?x = u1 * 0 + u2 * 1] (mod m2)"
- apply (rule cong_add_nat)
- apply (rule cong_scalar2_nat)
- apply (rule `[b1 = 0] (mod m2)`)
- apply (rule cong_scalar2_nat)
- apply (rule `[b2 = 1] (mod m2)`)
- done
- hence "[?x = u2] (mod m2)" by simp
- with `[?x = u1] (mod m1)` show ?thesis by blast
-qed
-
-lemma binary_chinese_remainder_int:
- assumes a: "coprime (m1::int) m2"
- shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
-proof -
- from binary_chinese_remainder_aux_int [OF a] obtain b1 b2
- where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
- "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
- by blast
- let ?x = "u1 * b1 + u2 * b2"
- have "[?x = u1 * 1 + u2 * 0] (mod m1)"
- apply (rule cong_add_int)
- apply (rule cong_scalar2_int)
- apply (rule `[b1 = 1] (mod m1)`)
- apply (rule cong_scalar2_int)
- apply (rule `[b2 = 0] (mod m1)`)
- done
- hence "[?x = u1] (mod m1)" by simp
- have "[?x = u1 * 0 + u2 * 1] (mod m2)"
- apply (rule cong_add_int)
- apply (rule cong_scalar2_int)
- apply (rule `[b1 = 0] (mod m2)`)
- apply (rule cong_scalar2_int)
- apply (rule `[b2 = 1] (mod m2)`)
- done
- hence "[?x = u2] (mod m2)" by simp
- with `[?x = u1] (mod m1)` show ?thesis by blast
-qed
-
-lemma cong_modulus_mult_nat: "[(x::nat) = y] (mod m * n) \<Longrightarrow>
- [x = y] (mod m)"
- apply (case_tac "y \<le> x")
- apply (simp add: cong_altdef_nat)
- apply (erule dvd_mult_left)
- apply (rule cong_sym_nat)
- apply (subst (asm) cong_sym_eq_nat)
- apply (simp add: cong_altdef_nat)
- apply (erule dvd_mult_left)
-done
-
-lemma cong_modulus_mult_int: "[(x::int) = y] (mod m * n) \<Longrightarrow>
- [x = y] (mod m)"
- apply (simp add: cong_altdef_int)
- apply (erule dvd_mult_left)
-done
-
-lemma cong_less_modulus_unique_nat:
- "[(x::nat) = y] (mod m) \<Longrightarrow> x < m \<Longrightarrow> y < m \<Longrightarrow> x = y"
- by (simp add: cong_nat_def)
-
-lemma binary_chinese_remainder_unique_nat:
- assumes a: "coprime (m1::nat) m2" and
- nz: "m1 \<noteq> 0" "m2 \<noteq> 0"
- shows "EX! x. x < m1 * m2 \<and> [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
-proof -
- from binary_chinese_remainder_nat [OF a] obtain y where
- "[y = u1] (mod m1)" and "[y = u2] (mod m2)"
- by blast
- let ?x = "y mod (m1 * m2)"
- from nz have less: "?x < m1 * m2"
- by auto
- have one: "[?x = u1] (mod m1)"
- apply (rule cong_trans_nat)
- prefer 2
- apply (rule `[y = u1] (mod m1)`)
- apply (rule cong_modulus_mult_nat)
- apply (rule cong_mod_nat)
- using nz apply auto
- done
- have two: "[?x = u2] (mod m2)"
- apply (rule cong_trans_nat)
- prefer 2
- apply (rule `[y = u2] (mod m2)`)
- apply (subst mult_commute)
- apply (rule cong_modulus_mult_nat)
- apply (rule cong_mod_nat)
- using nz apply auto
- done
- have "ALL z. z < m1 * m2 \<and> [z = u1] (mod m1) \<and> [z = u2] (mod m2) \<longrightarrow>
- z = ?x"
- proof (clarify)
- fix z
- assume "z < m1 * m2"
- assume "[z = u1] (mod m1)" and "[z = u2] (mod m2)"
- have "[?x = z] (mod m1)"
- apply (rule cong_trans_nat)
- apply (rule `[?x = u1] (mod m1)`)
- apply (rule cong_sym_nat)
- apply (rule `[z = u1] (mod m1)`)
- done
- moreover have "[?x = z] (mod m2)"
- apply (rule cong_trans_nat)
- apply (rule `[?x = u2] (mod m2)`)
- apply (rule cong_sym_nat)
- apply (rule `[z = u2] (mod m2)`)
- done
- ultimately have "[?x = z] (mod m1 * m2)"
- by (auto intro: coprime_cong_mult_nat a)
- with `z < m1 * m2` `?x < m1 * m2` show "z = ?x"
- apply (intro cong_less_modulus_unique_nat)
- apply (auto, erule cong_sym_nat)
- done
- qed
- with less one two show ?thesis
- by auto
- qed
-
-lemma chinese_remainder_aux_nat:
- fixes A :: "'a set" and
- m :: "'a \<Rightarrow> nat"
- assumes fin: "finite A" and
- cop: "ALL i : A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
- shows "EX b. (ALL i : A.
- [b i = 1] (mod m i) \<and> [b i = 0] (mod (PROD j : A - {i}. m j)))"
-proof (rule finite_set_choice, rule fin, rule ballI)
- fix i
- assume "i : A"
- with cop have "coprime (PROD j : A - {i}. m j) (m i)"
- by (intro setprod_coprime_nat, auto)
- hence "EX x. [(PROD j : A - {i}. m j) * x = 1] (mod m i)"
- by (elim cong_solve_coprime_nat)
- then obtain x where "[(PROD j : A - {i}. m j) * x = 1] (mod m i)"
- by auto
- moreover have "[(PROD j : A - {i}. m j) * x = 0]
- (mod (PROD j : A - {i}. m j))"
- by (subst mult_commute, rule cong_mult_self_nat)
- ultimately show "\<exists>a. [a = 1] (mod m i) \<and> [a = 0]
- (mod setprod m (A - {i}))"
- by blast
-qed
-
-lemma chinese_remainder_nat:
- fixes A :: "'a set" and
- m :: "'a \<Rightarrow> nat" and
- u :: "'a \<Rightarrow> nat"
- assumes
- fin: "finite A" and
- cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
- shows "EX x. (ALL i:A. [x = u i] (mod m i))"
-proof -
- from chinese_remainder_aux_nat [OF fin cop] obtain b where
- bprop: "ALL i:A. [b i = 1] (mod m i) \<and>
- [b i = 0] (mod (PROD j : A - {i}. m j))"
- by blast
- let ?x = "SUM i:A. (u i) * (b i)"
- show "?thesis"
- proof (rule exI, clarify)
- fix i
- assume a: "i : A"
- show "[?x = u i] (mod m i)"
- proof -
- from fin a have "?x = (SUM j:{i}. u j * b j) +
- (SUM j:A-{i}. u j * b j)"
- by (subst setsum_Un_disjoint [symmetric], auto intro: setsum_cong)
- hence "[?x = u i * b i + (SUM j:A-{i}. u j * b j)] (mod m i)"
- by auto
- also have "[u i * b i + (SUM j:A-{i}. u j * b j) =
- u i * 1 + (SUM j:A-{i}. u j * 0)] (mod m i)"
- apply (rule cong_add_nat)
- apply (rule cong_scalar2_nat)
- using bprop a apply blast
- apply (rule cong_setsum_nat)
- apply (rule cong_scalar2_nat)
- using bprop apply auto
- apply (rule cong_dvd_modulus_nat)
- apply (drule (1) bspec)
- apply (erule conjE)
- apply assumption
- apply (rule dvd_setprod)
- using fin a apply auto
- done
- finally show ?thesis
- by simp
- qed
- qed
-qed
-
-lemma coprime_cong_prod_nat [rule_format]: "finite A \<Longrightarrow>
- (ALL i: A. (ALL j: A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
- (ALL i: A. [(x::nat) = y] (mod m i)) \<longrightarrow>
- [x = y] (mod (PROD i:A. m i))"
- apply (induct set: finite)
- apply auto
- apply (erule (1) coprime_cong_mult_nat)
- apply (subst gcd_commute_nat)
- apply (rule setprod_coprime_nat)
- apply auto
-done
-
-lemma chinese_remainder_unique_nat:
- fixes A :: "'a set" and
- m :: "'a \<Rightarrow> nat" and
- u :: "'a \<Rightarrow> nat"
- assumes
- fin: "finite A" and
- nz: "ALL i:A. m i \<noteq> 0" and
- cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
- shows "EX! x. x < (PROD i:A. m i) \<and> (ALL i:A. [x = u i] (mod m i))"
-proof -
- from chinese_remainder_nat [OF fin cop] obtain y where
- one: "(ALL i:A. [y = u i] (mod m i))"
- by blast
- let ?x = "y mod (PROD i:A. m i)"
- from fin nz have prodnz: "(PROD i:A. m i) \<noteq> 0"
- by auto
- hence less: "?x < (PROD i:A. m i)"
- by auto
- have cong: "ALL i:A. [?x = u i] (mod m i)"
- apply auto
- apply (rule cong_trans_nat)
- prefer 2
- using one apply auto
- apply (rule cong_dvd_modulus_nat)
- apply (rule cong_mod_nat)
- using prodnz apply auto
- apply (rule dvd_setprod)
- apply (rule fin)
- apply assumption
- done
- have unique: "ALL z. z < (PROD i:A. m i) \<and>
- (ALL i:A. [z = u i] (mod m i)) \<longrightarrow> z = ?x"
- proof (clarify)
- fix z
- assume zless: "z < (PROD i:A. m i)"
- assume zcong: "(ALL i:A. [z = u i] (mod m i))"
- have "ALL i:A. [?x = z] (mod m i)"
- apply clarify
- apply (rule cong_trans_nat)
- using cong apply (erule bspec)
- apply (rule cong_sym_nat)
- using zcong apply auto
- done
- with fin cop have "[?x = z] (mod (PROD i:A. m i))"
- by (intro coprime_cong_prod_nat, auto)
- with zless less show "z = ?x"
- apply (intro cong_less_modulus_unique_nat)
- apply (auto, erule cong_sym_nat)
- done
- qed
- from less cong unique show ?thesis
- by blast
-qed
-
-end
--- a/src/HOL/NewNumberTheory/Fib.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,319 +0,0 @@
-(* Title: Fib.thy
- Authors: Lawrence C. Paulson, Jeremy Avigad
-
-
-Defines the fibonacci function.
-
-The original "Fib" is due to Lawrence C. Paulson, and was adapted by
-Jeremy Avigad.
-*)
-
-
-header {* Fib *}
-
-theory Fib
-imports Binomial
-begin
-
-
-subsection {* Main definitions *}
-
-class fib =
-
-fixes
- fib :: "'a \<Rightarrow> 'a"
-
-
-(* definition for the natural numbers *)
-
-instantiation nat :: fib
-
-begin
-
-fun
- fib_nat :: "nat \<Rightarrow> nat"
-where
- "fib_nat n =
- (if n = 0 then 0 else
- (if n = 1 then 1 else
- fib (n - 1) + fib (n - 2)))"
-
-instance proof qed
-
-end
-
-(* definition for the integers *)
-
-instantiation int :: fib
-
-begin
-
-definition
- fib_int :: "int \<Rightarrow> int"
-where
- "fib_int n = (if n >= 0 then int (fib (nat n)) else 0)"
-
-instance proof qed
-
-end
-
-
-subsection {* Set up Transfer *}
-
-
-lemma transfer_nat_int_fib:
- "(x::int) >= 0 \<Longrightarrow> fib (nat x) = nat (fib x)"
- unfolding fib_int_def by auto
-
-lemma transfer_nat_int_fib_closure:
- "n >= (0::int) \<Longrightarrow> fib n >= 0"
- by (auto simp add: fib_int_def)
-
-declare TransferMorphism_nat_int[transfer add return:
- transfer_nat_int_fib transfer_nat_int_fib_closure]
-
-lemma transfer_int_nat_fib:
- "fib (int n) = int (fib n)"
- unfolding fib_int_def by auto
-
-lemma transfer_int_nat_fib_closure:
- "is_nat n \<Longrightarrow> fib n >= 0"
- unfolding fib_int_def by auto
-
-declare TransferMorphism_int_nat[transfer add return:
- transfer_int_nat_fib transfer_int_nat_fib_closure]
-
-
-subsection {* Fibonacci numbers *}
-
-lemma fib_0_nat [simp]: "fib (0::nat) = 0"
- by simp
-
-lemma fib_0_int [simp]: "fib (0::int) = 0"
- unfolding fib_int_def by simp
-
-lemma fib_1_nat [simp]: "fib (1::nat) = 1"
- by simp
-
-lemma fib_Suc_0_nat [simp]: "fib (Suc 0) = Suc 0"
- by simp
-
-lemma fib_1_int [simp]: "fib (1::int) = 1"
- unfolding fib_int_def by simp
-
-lemma fib_reduce_nat: "(n::nat) >= 2 \<Longrightarrow> fib n = fib (n - 1) + fib (n - 2)"
- by simp
-
-declare fib_nat.simps [simp del]
-
-lemma fib_reduce_int: "(n::int) >= 2 \<Longrightarrow> fib n = fib (n - 1) + fib (n - 2)"
- unfolding fib_int_def
- by (auto simp add: fib_reduce_nat nat_diff_distrib)
-
-lemma fib_neg_int [simp]: "(n::int) < 0 \<Longrightarrow> fib n = 0"
- unfolding fib_int_def by auto
-
-lemma fib_2_nat [simp]: "fib (2::nat) = 1"
- by (subst fib_reduce_nat, auto)
-
-lemma fib_2_int [simp]: "fib (2::int) = 1"
- by (subst fib_reduce_int, auto)
-
-lemma fib_plus_2_nat: "fib ((n::nat) + 2) = fib (n + 1) + fib n"
- by (subst fib_reduce_nat, auto simp add: One_nat_def)
-(* the need for One_nat_def is due to the natdiff_cancel_numerals
- procedure *)
-
-lemma fib_induct_nat: "P (0::nat) \<Longrightarrow> P (1::nat) \<Longrightarrow>
- (!!n. P n \<Longrightarrow> P (n + 1) \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
- apply (atomize, induct n rule: nat_less_induct)
- apply auto
- apply (case_tac "n = 0", force)
- apply (case_tac "n = 1", force)
- apply (subgoal_tac "n >= 2")
- apply (frule_tac x = "n - 1" in spec)
- apply (drule_tac x = "n - 2" in spec)
- apply (drule_tac x = "n - 2" in spec)
- apply auto
- apply (auto simp add: One_nat_def) (* again, natdiff_cancel *)
-done
-
-lemma fib_add_nat: "fib ((n::nat) + k + 1) = fib (k + 1) * fib (n + 1) +
- fib k * fib n"
- apply (induct n rule: fib_induct_nat)
- apply auto
- apply (subst fib_reduce_nat)
- apply (auto simp add: ring_simps)
- apply (subst (1 3 5) fib_reduce_nat)
- apply (auto simp add: ring_simps Suc_eq_plus1)
-(* hmmm. Why doesn't "n + (1 + (1 + k))" simplify to "n + k + 2"? *)
- apply (subgoal_tac "n + (k + 2) = n + (1 + (1 + k))")
- apply (erule ssubst) back back
- apply (erule ssubst) back
- apply auto
-done
-
-lemma fib_add'_nat: "fib (n + Suc k) = fib (Suc k) * fib (Suc n) +
- fib k * fib n"
- using fib_add_nat by (auto simp add: One_nat_def)
-
-
-(* transfer from nats to ints *)
-lemma fib_add_int [rule_format]: "(n::int) >= 0 \<Longrightarrow> k >= 0 \<Longrightarrow>
- fib (n + k + 1) = fib (k + 1) * fib (n + 1) +
- fib k * fib n "
-
- by (rule fib_add_nat [transferred])
-
-lemma fib_neq_0_nat: "(n::nat) > 0 \<Longrightarrow> fib n ~= 0"
- apply (induct n rule: fib_induct_nat)
- apply (auto simp add: fib_plus_2_nat)
-done
-
-lemma fib_gr_0_nat: "(n::nat) > 0 \<Longrightarrow> fib n > 0"
- by (frule fib_neq_0_nat, simp)
-
-lemma fib_gr_0_int: "(n::int) > 0 \<Longrightarrow> fib n > 0"
- unfolding fib_int_def by (simp add: fib_gr_0_nat)
-
-text {*
- \medskip Concrete Mathematics, page 278: Cassini's identity. The proof is
- much easier using integers, not natural numbers!
-*}
-
-lemma fib_Cassini_aux_int: "fib (int n + 2) * fib (int n) -
- (fib (int n + 1))^2 = (-1)^(n + 1)"
- apply (induct n)
- apply (auto simp add: ring_simps power2_eq_square fib_reduce_int
- power_add)
-done
-
-lemma fib_Cassini_int: "n >= 0 \<Longrightarrow> fib (n + 2) * fib n -
- (fib (n + 1))^2 = (-1)^(nat n + 1)"
- by (insert fib_Cassini_aux_int [of "nat n"], auto)
-
-(*
-lemma fib_Cassini'_int: "n >= 0 \<Longrightarrow> fib (n + 2) * fib n =
- (fib (n + 1))^2 + (-1)^(nat n + 1)"
- by (frule fib_Cassini_int, simp)
-*)
-
-lemma fib_Cassini'_int: "n >= 0 \<Longrightarrow> fib ((n::int) + 2) * fib n =
- (if even n then tsub ((fib (n + 1))^2) 1
- else (fib (n + 1))^2 + 1)"
- apply (frule fib_Cassini_int, auto simp add: pos_int_even_equiv_nat_even)
- apply (subst tsub_eq)
- apply (insert fib_gr_0_int [of "n + 1"], force)
- apply auto
-done
-
-lemma fib_Cassini_nat: "fib ((n::nat) + 2) * fib n =
- (if even n then (fib (n + 1))^2 - 1
- else (fib (n + 1))^2 + 1)"
-
- by (rule fib_Cassini'_int [transferred, of n], auto)
-
-
-text {* \medskip Toward Law 6.111 of Concrete Mathematics *}
-
-lemma coprime_fib_plus_1_nat: "coprime (fib (n::nat)) (fib (n + 1))"
- apply (induct n rule: fib_induct_nat)
- apply auto
- apply (subst (2) fib_reduce_nat)
- apply (auto simp add: Suc_eq_plus1) (* again, natdiff_cancel *)
- apply (subst add_commute, auto)
- apply (subst gcd_commute_nat, auto simp add: ring_simps)
-done
-
-lemma coprime_fib_Suc_nat: "coprime (fib n) (fib (Suc n))"
- using coprime_fib_plus_1_nat by (simp add: One_nat_def)
-
-lemma coprime_fib_plus_1_int:
- "n >= 0 \<Longrightarrow> coprime (fib (n::int)) (fib (n + 1))"
- by (erule coprime_fib_plus_1_nat [transferred])
-
-lemma gcd_fib_add_nat: "gcd (fib (m::nat)) (fib (n + m)) = gcd (fib m) (fib n)"
- apply (simp add: gcd_commute_nat [of "fib m"])
- apply (rule cases_nat [of _ m])
- apply simp
- apply (subst add_assoc [symmetric])
- apply (simp add: fib_add_nat)
- apply (subst gcd_commute_nat)
- apply (subst mult_commute)
- apply (subst gcd_add_mult_nat)
- apply (subst gcd_commute_nat)
- apply (rule gcd_mult_cancel_nat)
- apply (rule coprime_fib_plus_1_nat)
-done
-
-lemma gcd_fib_add_int [rule_format]: "m >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
- gcd (fib (m::int)) (fib (n + m)) = gcd (fib m) (fib n)"
- by (erule gcd_fib_add_nat [transferred])
-
-lemma gcd_fib_diff_nat: "(m::nat) \<le> n \<Longrightarrow>
- gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
- by (simp add: gcd_fib_add_nat [symmetric, of _ "n-m"])
-
-lemma gcd_fib_diff_int: "0 <= (m::int) \<Longrightarrow> m \<le> n \<Longrightarrow>
- gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
- by (simp add: gcd_fib_add_int [symmetric, of _ "n-m"])
-
-lemma gcd_fib_mod_nat: "0 < (m::nat) \<Longrightarrow>
- gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
-proof (induct n rule: less_induct)
- case (less n)
- from less.prems have pos_m: "0 < m" .
- show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
- proof (cases "m < n")
- case True note m_n = True
- then have m_n': "m \<le> n" by auto
- with pos_m have pos_n: "0 < n" by auto
- with pos_m m_n have diff: "n - m < n" by auto
- have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
- by (simp add: mod_if [of n]) (insert m_n, auto)
- also have "\<dots> = gcd (fib m) (fib (n - m))"
- by (simp add: less.hyps diff pos_m)
- also have "\<dots> = gcd (fib m) (fib n)" by (simp add: gcd_fib_diff_nat m_n')
- finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
- next
- case False then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
- by (cases "m = n") auto
- qed
-qed
-
-lemma gcd_fib_mod_int:
- assumes "0 < (m::int)" and "0 <= n"
- shows "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
-
- apply (rule gcd_fib_mod_nat [transferred])
- using prems apply auto
-done
-
-lemma fib_gcd_nat: "fib (gcd (m::nat) n) = gcd (fib m) (fib n)"
- -- {* Law 6.111 *}
- apply (induct m n rule: gcd_nat_induct)
- apply (simp_all add: gcd_non_0_nat gcd_commute_nat gcd_fib_mod_nat)
-done
-
-lemma fib_gcd_int: "m >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
- fib (gcd (m::int) n) = gcd (fib m) (fib n)"
- by (erule fib_gcd_nat [transferred])
-
-lemma atMost_plus_one_nat: "{..(k::nat) + 1} = insert (k + 1) {..k}"
- by auto
-
-theorem fib_mult_eq_setsum_nat:
- "fib ((n::nat) + 1) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
- apply (induct n)
- apply (auto simp add: atMost_plus_one_nat fib_plus_2_nat ring_simps)
-done
-
-theorem fib_mult_eq_setsum'_nat:
- "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
- using fib_mult_eq_setsum_nat by (simp add: One_nat_def)
-
-theorem fib_mult_eq_setsum_int [rule_format]:
- "n >= 0 \<Longrightarrow> fib ((n::int) + 1) * fib n = (\<Sum>k \<in> {0..n}. fib k * fib k)"
- by (erule fib_mult_eq_setsum_nat [transferred])
-
-end
--- a/src/HOL/NewNumberTheory/MiscAlgebra.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,355 +0,0 @@
-(* Title: MiscAlgebra.thy
- Author: Jeremy Avigad
-
-These are things that can be added to the Algebra library.
-*)
-
-theory MiscAlgebra
-imports
- "~~/src/HOL/Algebra/Ring"
- "~~/src/HOL/Algebra/FiniteProduct"
-begin;
-
-(* finiteness stuff *)
-
-lemma bounded_set1_int [intro]: "finite {(x::int). a < x & x < b & P x}"
- apply (subgoal_tac "{x. a < x & x < b & P x} <= {a<..<b}")
- apply (erule finite_subset)
- apply auto
-done
-
-
-(* The rest is for the algebra libraries *)
-
-(* These go in Group.thy. *)
-
-(*
- Show that the units in any monoid give rise to a group.
-
- The file Residues.thy provides some infrastructure to use
- facts about the unit group within the ring locale.
-*)
-
-
-constdefs
- units_of :: "('a, 'b) monoid_scheme => 'a monoid"
- "units_of G == (| carrier = Units G,
- Group.monoid.mult = Group.monoid.mult G,
- one = one G |)";
-
-(*
-
-lemma (in monoid) Units_mult_closed [intro]:
- "x : Units G ==> y : Units G ==> x \<otimes> y : Units G"
- apply (unfold Units_def)
- apply (clarsimp)
- apply (rule_tac x = "xaa \<otimes> xa" in bexI)
- apply auto
- apply (subst m_assoc)
- apply auto
- apply (subst (2) m_assoc [symmetric])
- apply auto
- apply (subst m_assoc)
- apply auto
- apply (subst (2) m_assoc [symmetric])
- apply auto
-done
-
-*)
-
-lemma (in monoid) units_group: "group(units_of G)"
- apply (unfold units_of_def)
- apply (rule groupI)
- apply auto
- apply (subst m_assoc)
- apply auto
- apply (rule_tac x = "inv x" in bexI)
- apply auto
-done
-
-lemma (in comm_monoid) units_comm_group: "comm_group(units_of G)"
- apply (rule group.group_comm_groupI)
- apply (rule units_group)
- apply (insert prems)
- apply (unfold units_of_def Units_def comm_monoid_def comm_monoid_axioms_def)
- apply auto;
-done;
-
-lemma units_of_carrier: "carrier (units_of G) = Units G"
- by (unfold units_of_def, auto)
-
-lemma units_of_mult: "mult(units_of G) = mult G"
- by (unfold units_of_def, auto)
-
-lemma units_of_one: "one(units_of G) = one G"
- by (unfold units_of_def, auto)
-
-lemma (in monoid) units_of_inv: "x : Units G ==>
- m_inv (units_of G) x = m_inv G x"
- apply (rule sym)
- apply (subst m_inv_def)
- apply (rule the1_equality)
- apply (rule ex_ex1I)
- apply (subst (asm) Units_def)
- apply auto
- apply (erule inv_unique)
- apply auto
- apply (rule Units_closed)
- apply (simp_all only: units_of_carrier [symmetric])
- apply (insert units_group)
- apply auto
- apply (subst units_of_mult [symmetric])
- apply (subst units_of_one [symmetric])
- apply (erule group.r_inv, assumption)
- apply (subst units_of_mult [symmetric])
- apply (subst units_of_one [symmetric])
- apply (erule group.l_inv, assumption)
-done
-
-lemma (in group) inj_on_const_mult: "a: (carrier G) ==>
- inj_on (%x. a \<otimes> x) (carrier G)"
- by (unfold inj_on_def, auto)
-
-lemma (in group) surj_const_mult: "a : (carrier G) ==>
- (%x. a \<otimes> x) ` (carrier G) = (carrier G)"
- apply (auto simp add: image_def)
- apply (rule_tac x = "(m_inv G a) \<otimes> x" in bexI)
- apply auto
-(* auto should get this. I suppose we need "comm_monoid_simprules"
- for mult_ac rewriting. *)
- apply (subst m_assoc [symmetric])
- apply auto
-done
-
-lemma (in group) l_cancel_one [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
- (x \<otimes> a = x) = (a = one G)"
- apply auto
- apply (subst l_cancel [symmetric])
- prefer 4
- apply (erule ssubst)
- apply auto
-done
-
-lemma (in group) r_cancel_one [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
- (a \<otimes> x = x) = (a = one G)"
- apply auto
- apply (subst r_cancel [symmetric])
- prefer 4
- apply (erule ssubst)
- apply auto
-done
-
-(* Is there a better way to do this? *)
-
-lemma (in group) l_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
- (x = x \<otimes> a) = (a = one G)"
- by (subst eq_commute, simp)
-
-lemma (in group) r_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
- (x = a \<otimes> x) = (a = one G)"
- by (subst eq_commute, simp)
-
-(* This should be generalized to arbitrary groups, not just commutative
- ones, using Lagrange's theorem. *)
-
-lemma (in comm_group) power_order_eq_one:
- assumes fin [simp]: "finite (carrier G)"
- and a [simp]: "a : carrier G"
- shows "a (^) card(carrier G) = one G"
-proof -
- have "(\<Otimes>x:carrier G. x) = (\<Otimes>x:carrier G. a \<otimes> x)"
- by (subst (2) finprod_reindex [symmetric],
- auto simp add: Pi_def inj_on_const_mult surj_const_mult)
- also have "\<dots> = (\<Otimes>x:carrier G. a) \<otimes> (\<Otimes>x:carrier G. x)"
- by (auto simp add: finprod_multf Pi_def)
- also have "(\<Otimes>x:carrier G. a) = a (^) card(carrier G)"
- by (auto simp add: finprod_const)
- finally show ?thesis
-(* uses the preceeding lemma *)
- by auto
-qed
-
-
-(* Miscellaneous *)
-
-lemma (in cring) field_intro2: "\<zero>\<^bsub>R\<^esub> ~= \<one>\<^bsub>R\<^esub> \<Longrightarrow> ALL x : carrier R - {\<zero>\<^bsub>R\<^esub>}.
- x : Units R \<Longrightarrow> field R"
- apply (unfold_locales)
- apply (insert prems, auto)
- apply (rule trans)
- apply (subgoal_tac "a = (a \<otimes> b) \<otimes> inv b")
- apply assumption
- apply (subst m_assoc)
- apply (auto simp add: Units_r_inv)
- apply (unfold Units_def)
- apply auto
-done
-
-lemma (in monoid) inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
- x \<otimes> y = \<one> \<Longrightarrow> y \<otimes> x = \<one> \<Longrightarrow> inv x = y"
- apply (subgoal_tac "x : Units G")
- apply (subgoal_tac "y = inv x \<otimes> \<one>")
- apply simp
- apply (erule subst)
- apply (subst m_assoc [symmetric])
- apply auto
- apply (unfold Units_def)
- apply auto
-done
-
-lemma (in comm_monoid) comm_inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
- x \<otimes> y = \<one> \<Longrightarrow> inv x = y"
- apply (rule inv_char)
- apply auto
- apply (subst m_comm, auto)
-done
-
-lemma (in ring) inv_neg_one [simp]: "inv (\<ominus> \<one>) = \<ominus> \<one>"
- apply (rule inv_char)
- apply (auto simp add: l_minus r_minus)
-done
-
-lemma (in monoid) inv_eq_imp_eq: "x : Units G \<Longrightarrow> y : Units G \<Longrightarrow>
- inv x = inv y \<Longrightarrow> x = y"
- apply (subgoal_tac "inv(inv x) = inv(inv y)")
- apply (subst (asm) Units_inv_inv)+
- apply auto
-done
-
-lemma (in ring) Units_minus_one_closed [intro]: "\<ominus> \<one> : Units R"
- apply (unfold Units_def)
- apply auto
- apply (rule_tac x = "\<ominus> \<one>" in bexI)
- apply auto
- apply (simp add: l_minus r_minus)
-done
-
-lemma (in monoid) inv_one [simp]: "inv \<one> = \<one>"
- apply (rule inv_char)
- apply auto
-done
-
-lemma (in ring) inv_eq_neg_one_eq: "x : Units R \<Longrightarrow> (inv x = \<ominus> \<one>) = (x = \<ominus> \<one>)"
- apply auto
- apply (subst Units_inv_inv [symmetric])
- apply auto
-done
-
-lemma (in monoid) inv_eq_one_eq: "x : Units G \<Longrightarrow> (inv x = \<one>) = (x = \<one>)"
- apply auto
- apply (subst Units_inv_inv [symmetric])
- apply auto
-done
-
-
-(* This goes in FiniteProduct *)
-
-lemma (in comm_monoid) finprod_UN_disjoint:
- "finite I \<Longrightarrow> (ALL i:I. finite (A i)) \<longrightarrow> (ALL i:I. ALL j:I. i ~= j \<longrightarrow>
- (A i) Int (A j) = {}) \<longrightarrow>
- (ALL i:I. ALL x: (A i). g x : carrier G) \<longrightarrow>
- finprod G g (UNION I A) = finprod G (%i. finprod G g (A i)) I"
- apply (induct set: finite)
- apply force
- apply clarsimp
- apply (subst finprod_Un_disjoint)
- apply blast
- apply (erule finite_UN_I)
- apply blast
- apply (fastsimp)
- apply (auto intro!: funcsetI finprod_closed)
-done
-
-lemma (in comm_monoid) finprod_Union_disjoint:
- "[| finite C; (ALL A:C. finite A & (ALL x:A. f x : carrier G));
- (ALL A:C. ALL B:C. A ~= B --> A Int B = {}) |]
- ==> finprod G f (Union C) = finprod G (finprod G f) C"
- apply (frule finprod_UN_disjoint [of C id f])
- apply (unfold Union_def id_def, auto)
-done
-
-lemma (in comm_monoid) finprod_one [rule_format]:
- "finite A \<Longrightarrow> (ALL x:A. f x = \<one>) \<longrightarrow>
- finprod G f A = \<one>"
-by (induct set: finite) auto
-
-
-(* need better simplification rules for rings *)
-(* the next one holds more generally for abelian groups *)
-
-lemma (in cring) sum_zero_eq_neg:
- "x : carrier R \<Longrightarrow> y : carrier R \<Longrightarrow> x \<oplus> y = \<zero> \<Longrightarrow> x = \<ominus> y"
- apply (subgoal_tac "\<ominus> y = \<zero> \<oplus> \<ominus> y")
- apply (erule ssubst)back
- apply (erule subst)
- apply (simp add: ring_simprules)+
-done
-
-(* there's a name conflict -- maybe "domain" should be
- "integral_domain" *)
-
-lemma (in Ring.domain) square_eq_one:
- fixes x
- assumes [simp]: "x : carrier R" and
- "x \<otimes> x = \<one>"
- shows "x = \<one> | x = \<ominus>\<one>"
-proof -
- have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = x \<otimes> x \<oplus> \<ominus> \<one>"
- by (simp add: ring_simprules)
- also with `x \<otimes> x = \<one>` have "\<dots> = \<zero>"
- by (simp add: ring_simprules)
- finally have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = \<zero>" .
- hence "(x \<oplus> \<one>) = \<zero> | (x \<oplus> \<ominus> \<one>) = \<zero>"
- by (intro integral, auto)
- thus ?thesis
- apply auto
- apply (erule notE)
- apply (rule sum_zero_eq_neg)
- apply auto
- apply (subgoal_tac "x = \<ominus> (\<ominus> \<one>)")
- apply (simp add: ring_simprules)
- apply (rule sum_zero_eq_neg)
- apply auto
- done
-qed
-
-lemma (in Ring.domain) inv_eq_self: "x : Units R \<Longrightarrow>
- x = inv x \<Longrightarrow> x = \<one> | x = \<ominus> \<one>"
- apply (rule square_eq_one)
- apply auto
- apply (erule ssubst)back
- apply (erule Units_r_inv)
-done
-
-
-(*
- The following translates theorems about groups to the facts about
- the units of a ring. (The list should be expanded as more things are
- needed.)
-*)
-
-lemma (in ring) finite_ring_finite_units [intro]: "finite (carrier R) \<Longrightarrow>
- finite (Units R)"
- by (rule finite_subset, auto)
-
-(* this belongs with MiscAlgebra.thy *)
-lemma (in monoid) units_of_pow:
- "x : Units G \<Longrightarrow> x (^)\<^bsub>units_of G\<^esub> (n::nat) = x (^)\<^bsub>G\<^esub> n"
- apply (induct n)
- apply (auto simp add: units_group group.is_monoid
- monoid.nat_pow_0 monoid.nat_pow_Suc units_of_one units_of_mult
- One_nat_def)
-done
-
-lemma (in cring) units_power_order_eq_one: "finite (Units R) \<Longrightarrow> a : Units R
- \<Longrightarrow> a (^) card(Units R) = \<one>"
- apply (subst units_of_carrier [symmetric])
- apply (subst units_of_one [symmetric])
- apply (subst units_of_pow [symmetric])
- apply assumption
- apply (rule comm_group.power_order_eq_one)
- apply (rule units_comm_group)
- apply (unfold units_of_def, auto)
-done
-
-end
--- a/src/HOL/NewNumberTheory/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1 +0,0 @@
-use_thys ["Fib","Residues"];
--- a/src/HOL/NewNumberTheory/Residues.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,466 +0,0 @@
-(* Title: HOL/Library/Residues.thy
- ID:
- Author: Jeremy Avigad
-
- An algebraic treatment of residue rings, and resulting proofs of
- Euler's theorem and Wilson's theorem.
-*)
-
-header {* Residue rings *}
-
-theory Residues
-imports
- UniqueFactorization
- Binomial
- MiscAlgebra
-begin
-
-
-(*
-
- A locale for residue rings
-
-*)
-
-constdefs
- residue_ring :: "int => int ring"
- "residue_ring m == (|
- carrier = {0..m - 1},
- mult = (%x y. (x * y) mod m),
- one = 1,
- zero = 0,
- add = (%x y. (x + y) mod m) |)"
-
-locale residues =
- fixes m :: int and R (structure)
- assumes m_gt_one: "m > 1"
- defines "R == residue_ring m"
-
-context residues begin
-
-lemma abelian_group: "abelian_group R"
- apply (insert m_gt_one)
- apply (rule abelian_groupI)
- apply (unfold R_def residue_ring_def)
- apply (auto simp add: mod_pos_pos_trivial mod_add_right_eq [symmetric]
- add_ac)
- apply (case_tac "x = 0")
- apply force
- apply (subgoal_tac "(x + (m - x)) mod m = 0")
- apply (erule bexI)
- apply auto
-done
-
-lemma comm_monoid: "comm_monoid R"
- apply (insert m_gt_one)
- apply (unfold R_def residue_ring_def)
- apply (rule comm_monoidI)
- apply auto
- apply (subgoal_tac "x * y mod m * z mod m = z * (x * y mod m) mod m")
- apply (erule ssubst)
- apply (subst zmod_zmult1_eq [symmetric])+
- apply (simp_all only: mult_ac)
-done
-
-lemma cring: "cring R"
- apply (rule cringI)
- apply (rule abelian_group)
- apply (rule comm_monoid)
- apply (unfold R_def residue_ring_def, auto)
- apply (subst mod_add_eq [symmetric])
- apply (subst mult_commute)
- apply (subst zmod_zmult1_eq [symmetric])
- apply (simp add: ring_simps)
-done
-
-end
-
-sublocale residues < cring
- by (rule cring)
-
-
-context residues begin
-
-(* These lemmas translate back and forth between internal and
- external concepts *)
-
-lemma res_carrier_eq: "carrier R = {0..m - 1}"
- by (unfold R_def residue_ring_def, auto)
-
-lemma res_add_eq: "x \<oplus> y = (x + y) mod m"
- by (unfold R_def residue_ring_def, auto)
-
-lemma res_mult_eq: "x \<otimes> y = (x * y) mod m"
- by (unfold R_def residue_ring_def, auto)
-
-lemma res_zero_eq: "\<zero> = 0"
- by (unfold R_def residue_ring_def, auto)
-
-lemma res_one_eq: "\<one> = 1"
- by (unfold R_def residue_ring_def units_of_def residue_ring_def, auto)
-
-lemma res_units_eq: "Units R = { x. 0 < x & x < m & coprime x m}"
- apply (insert m_gt_one)
- apply (unfold Units_def R_def residue_ring_def)
- apply auto
- apply (subgoal_tac "x ~= 0")
- apply auto
- apply (rule invertible_coprime_int)
- apply (subgoal_tac "x ~= 0")
- apply auto
- apply (subst (asm) coprime_iff_invertible'_int)
- apply (rule m_gt_one)
- apply (auto simp add: cong_int_def mult_commute)
-done
-
-lemma res_neg_eq: "\<ominus> x = (- x) mod m"
- apply (insert m_gt_one)
- apply (unfold R_def a_inv_def m_inv_def residue_ring_def)
- apply auto
- apply (rule the_equality)
- apply auto
- apply (subst mod_add_right_eq [symmetric])
- apply auto
- apply (subst mod_add_left_eq [symmetric])
- apply auto
- apply (subgoal_tac "y mod m = - x mod m")
- apply simp
- apply (subst zmod_eq_dvd_iff)
- apply auto
-done
-
-lemma finite [iff]: "finite(carrier R)"
- by (subst res_carrier_eq, auto)
-
-lemma finite_Units [iff]: "finite(Units R)"
- by (subst res_units_eq, auto)
-
-(* The function a -> a mod m maps the integers to the
- residue classes. The following lemmas show that this mapping
- respects addition and multiplication on the integers. *)
-
-lemma mod_in_carrier [iff]: "a mod m : carrier R"
- apply (unfold res_carrier_eq)
- apply (insert m_gt_one, auto)
-done
-
-lemma add_cong: "(x mod m) \<oplus> (y mod m) = (x + y) mod m"
- by (unfold R_def residue_ring_def, auto, arith)
-
-lemma mult_cong: "(x mod m) \<otimes> (y mod m) = (x * y) mod m"
- apply (unfold R_def residue_ring_def, auto)
- apply (subst zmod_zmult1_eq [symmetric])
- apply (subst mult_commute)
- apply (subst zmod_zmult1_eq [symmetric])
- apply (subst mult_commute)
- apply auto
-done
-
-lemma zero_cong: "\<zero> = 0"
- apply (unfold R_def residue_ring_def, auto)
-done
-
-lemma one_cong: "\<one> = 1 mod m"
- apply (insert m_gt_one)
- apply (unfold R_def residue_ring_def, auto)
-done
-
-(* revise algebra library to use 1? *)
-lemma pow_cong: "(x mod m) (^) n = x^n mod m"
- apply (insert m_gt_one)
- apply (induct n)
- apply (auto simp add: nat_pow_def one_cong One_nat_def)
- apply (subst mult_commute)
- apply (rule mult_cong)
-done
-
-lemma neg_cong: "\<ominus> (x mod m) = (- x) mod m"
- apply (rule sym)
- apply (rule sum_zero_eq_neg)
- apply auto
- apply (subst add_cong)
- apply (subst zero_cong)
- apply auto
-done
-
-lemma (in residues) prod_cong:
- "finite A \<Longrightarrow> (\<Otimes> i:A. (f i) mod m) = (PROD i:A. f i) mod m"
- apply (induct set: finite)
- apply (auto simp: one_cong mult_cong)
-done
-
-lemma (in residues) sum_cong:
- "finite A \<Longrightarrow> (\<Oplus> i:A. (f i) mod m) = (SUM i: A. f i) mod m"
- apply (induct set: finite)
- apply (auto simp: zero_cong add_cong)
-done
-
-lemma mod_in_res_units [simp]: "1 < m \<Longrightarrow> coprime a m \<Longrightarrow>
- a mod m : Units R"
- apply (subst res_units_eq, auto)
- apply (insert pos_mod_sign [of m a])
- apply (subgoal_tac "a mod m ~= 0")
- apply arith
- apply auto
- apply (subst (asm) gcd_red_int)
- apply (subst gcd_commute_int, assumption)
-done
-
-lemma res_eq_to_cong: "((a mod m) = (b mod m)) = [a = b] (mod (m::int))"
- unfolding cong_int_def by auto
-
-(* Simplifying with these will translate a ring equation in R to a
- congruence. *)
-
-lemmas res_to_cong_simps = add_cong mult_cong pow_cong one_cong
- prod_cong sum_cong neg_cong res_eq_to_cong
-
-(* Other useful facts about the residue ring *)
-
-lemma one_eq_neg_one: "\<one> = \<ominus> \<one> \<Longrightarrow> m = 2"
- apply (simp add: res_one_eq res_neg_eq)
- apply (insert m_gt_one)
- apply (subgoal_tac "~(m > 2)")
- apply arith
- apply (rule notI)
- apply (subgoal_tac "-1 mod m = m - 1")
- apply force
- apply (subst mod_add_self2 [symmetric])
- apply (subst mod_pos_pos_trivial)
- apply auto
-done
-
-end
-
-
-(* prime residues *)
-
-locale residues_prime =
- fixes p :: int and R (structure)
- assumes p_prime [intro]: "prime p"
- defines "R == residue_ring p"
-
-sublocale residues_prime < residues p
- apply (unfold R_def residues_def)
- using p_prime apply auto
-done
-
-context residues_prime begin
-
-lemma is_field: "field R"
- apply (rule cring.field_intro2)
- apply (rule cring)
- apply (auto simp add: res_carrier_eq res_one_eq res_zero_eq
- res_units_eq)
- apply (rule classical)
- apply (erule notE)
- apply (subst gcd_commute_int)
- apply (rule prime_imp_coprime_int)
- apply (rule p_prime)
- apply (rule notI)
- apply (frule zdvd_imp_le)
- apply auto
-done
-
-lemma res_prime_units_eq: "Units R = {1..p - 1}"
- apply (subst res_units_eq)
- apply auto
- apply (subst gcd_commute_int)
- apply (rule prime_imp_coprime_int)
- apply (rule p_prime)
- apply (rule zdvd_not_zless)
- apply auto
-done
-
-end
-
-sublocale residues_prime < field
- by (rule is_field)
-
-
-(*
- Test cases: Euler's theorem and Wilson's theorem.
-*)
-
-
-subsection{* Euler's theorem *}
-
-(* the definition of the phi function *)
-
-constdefs
- phi :: "int => nat"
- "phi m == card({ x. 0 < x & x < m & gcd x m = 1})"
-
-lemma phi_zero [simp]: "phi 0 = 0"
- apply (subst phi_def)
-(* Auto hangs here. Once again, where is the simplification rule
- 1 == Suc 0 coming from? *)
- apply (auto simp add: card_eq_0_iff)
-(* Add card_eq_0_iff as a simp rule? delete card_empty_imp? *)
-done
-
-lemma phi_one [simp]: "phi 1 = 0"
- apply (auto simp add: phi_def card_eq_0_iff)
-done
-
-lemma (in residues) phi_eq: "phi m = card(Units R)"
- by (simp add: phi_def res_units_eq)
-
-lemma (in residues) euler_theorem1:
- assumes a: "gcd a m = 1"
- shows "[a^phi m = 1] (mod m)"
-proof -
- from a m_gt_one have [simp]: "a mod m : Units R"
- by (intro mod_in_res_units)
- from phi_eq have "(a mod m) (^) (phi m) = (a mod m) (^) (card (Units R))"
- by simp
- also have "\<dots> = \<one>"
- by (intro units_power_order_eq_one, auto)
- finally show ?thesis
- by (simp add: res_to_cong_simps)
-qed
-
-(* In fact, there is a two line proof!
-
-lemma (in residues) euler_theorem1:
- assumes a: "gcd a m = 1"
- shows "[a^phi m = 1] (mod m)"
-proof -
- have "(a mod m) (^) (phi m) = \<one>"
- by (simp add: phi_eq units_power_order_eq_one a m_gt_one)
- thus ?thesis
- by (simp add: res_to_cong_simps)
-qed
-
-*)
-
-(* outside the locale, we can relax the restriction m > 1 *)
-
-lemma euler_theorem:
- assumes "m >= 0" and "gcd a m = 1"
- shows "[a^phi m = 1] (mod m)"
-proof (cases)
- assume "m = 0 | m = 1"
- thus ?thesis by auto
-next
- assume "~(m = 0 | m = 1)"
- with prems show ?thesis
- by (intro residues.euler_theorem1, unfold residues_def, auto)
-qed
-
-lemma (in residues_prime) phi_prime: "phi p = (nat p - 1)"
- apply (subst phi_eq)
- apply (subst res_prime_units_eq)
- apply auto
-done
-
-lemma phi_prime: "prime p \<Longrightarrow> phi p = (nat p - 1)"
- apply (rule residues_prime.phi_prime)
- apply (erule residues_prime.intro)
-done
-
-lemma fermat_theorem:
- assumes "prime p" and "~ (p dvd a)"
- shows "[a^(nat p - 1) = 1] (mod p)"
-proof -
- from prems have "[a^phi p = 1] (mod p)"
- apply (intro euler_theorem)
- (* auto should get this next part. matching across
- substitutions is needed. *)
- apply (frule prime_gt_1_int, arith)
- apply (subst gcd_commute_int, erule prime_imp_coprime_int, assumption)
- done
- also have "phi p = nat p - 1"
- by (rule phi_prime, rule prems)
- finally show ?thesis .
-qed
-
-
-subsection {* Wilson's theorem *}
-
-lemma (in field) inv_pair_lemma: "x : Units R \<Longrightarrow> y : Units R \<Longrightarrow>
- {x, inv x} ~= {y, inv y} \<Longrightarrow> {x, inv x} Int {y, inv y} = {}"
- apply auto
- apply (erule notE)
- apply (erule inv_eq_imp_eq)
- apply auto
- apply (erule notE)
- apply (erule inv_eq_imp_eq)
- apply auto
-done
-
-lemma (in residues_prime) wilson_theorem1:
- assumes a: "p > 2"
- shows "[fact (p - 1) = - 1] (mod p)"
-proof -
- let ?InversePairs = "{ {x, inv x} | x. x : Units R - {\<one>, \<ominus> \<one>}}"
- have UR: "Units R = {\<one>, \<ominus> \<one>} Un (Union ?InversePairs)"
- by auto
- have "(\<Otimes>i: Units R. i) =
- (\<Otimes>i: {\<one>, \<ominus> \<one>}. i) \<otimes> (\<Otimes>i: Union ?InversePairs. i)"
- apply (subst UR)
- apply (subst finprod_Un_disjoint)
- apply (auto intro:funcsetI)
- apply (drule sym, subst (asm) inv_eq_one_eq)
- apply auto
- apply (drule sym, subst (asm) inv_eq_neg_one_eq)
- apply auto
- done
- also have "(\<Otimes>i: {\<one>, \<ominus> \<one>}. i) = \<ominus> \<one>"
- apply (subst finprod_insert)
- apply auto
- apply (frule one_eq_neg_one)
- apply (insert a, force)
- done
- also have "(\<Otimes>i:(Union ?InversePairs). i) =
- (\<Otimes> A: ?InversePairs. (\<Otimes> y:A. y))"
- apply (subst finprod_Union_disjoint)
- apply force
- apply force
- apply clarify
- apply (rule inv_pair_lemma)
- apply auto
- done
- also have "\<dots> = \<one>"
- apply (rule finprod_one)
- apply auto
- apply (subst finprod_insert)
- apply auto
- apply (frule inv_eq_self)
- apply (auto)
- done
- finally have "(\<Otimes>i: Units R. i) = \<ominus> \<one>"
- by simp
- also have "(\<Otimes>i: Units R. i) = (\<Otimes>i: Units R. i mod p)"
- apply (rule finprod_cong')
- apply (auto)
- apply (subst (asm) res_prime_units_eq)
- apply auto
- done
- also have "\<dots> = (PROD i: Units R. i) mod p"
- apply (rule prod_cong)
- apply auto
- done
- also have "\<dots> = fact (p - 1) mod p"
- apply (subst fact_altdef_int)
- apply (insert prems, force)
- apply (subst res_prime_units_eq, rule refl)
- done
- finally have "fact (p - 1) mod p = \<ominus> \<one>".
- thus ?thesis
- by (simp add: res_to_cong_simps)
-qed
-
-lemma wilson_theorem: "prime (p::int) \<Longrightarrow> [fact (p - 1) = - 1] (mod p)"
- apply (frule prime_gt_1_int)
- apply (case_tac "p = 2")
- apply (subst fact_altdef_int, simp)
- apply (subst cong_int_def)
- apply simp
- apply (rule residues_prime.wilson_theorem1)
- apply (rule residues_prime.intro)
- apply auto
-done
-
-
-end
--- a/src/HOL/NewNumberTheory/UniqueFactorization.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,967 +0,0 @@
-(* Title: UniqueFactorization.thy
- ID:
- Author: Jeremy Avigad
-
-
- Unique factorization for the natural numbers and the integers.
-
- Note: there were previous Isabelle formalizations of unique
- factorization due to Thomas Marthedal Rasmussen, and, building on
- that, by Jeremy Avigad and David Gray.
-*)
-
-header {* UniqueFactorization *}
-
-theory UniqueFactorization
-imports Cong Multiset
-begin
-
-(* inherited from Multiset *)
-declare One_nat_def [simp del]
-
-(* As a simp or intro rule,
-
- prime p \<Longrightarrow> p > 0
-
- wreaks havoc here. When the premise includes ALL x :# M. prime x, it
- leads to the backchaining
-
- x > 0
- prime x
- x :# M which is, unfortunately,
- count M x > 0
-*)
-
-
-(* useful facts *)
-
-lemma setsum_Un2: "finite (A Un B) \<Longrightarrow>
- setsum f (A Un B) = setsum f (A - B) + setsum f (B - A) +
- setsum f (A Int B)"
- apply (subgoal_tac "A Un B = (A - B) Un (B - A) Un (A Int B)")
- apply (erule ssubst)
- apply (subst setsum_Un_disjoint)
- apply auto
- apply (subst setsum_Un_disjoint)
- apply auto
-done
-
-lemma setprod_Un2: "finite (A Un B) \<Longrightarrow>
- setprod f (A Un B) = setprod f (A - B) * setprod f (B - A) *
- setprod f (A Int B)"
- apply (subgoal_tac "A Un B = (A - B) Un (B - A) Un (A Int B)")
- apply (erule ssubst)
- apply (subst setprod_Un_disjoint)
- apply auto
- apply (subst setprod_Un_disjoint)
- apply auto
-done
-
-(* Should this go in Multiset.thy? *)
-(* TN: No longer an intro-rule; needed only once and might get in the way *)
-lemma multiset_eqI: "[| !!x. count M x = count N x |] ==> M = N"
- by (subst multiset_eq_conv_count_eq, blast)
-
-(* Here is a version of set product for multisets. Is it worth moving
- to multiset.thy? If so, one should similarly define msetsum for abelian
- semirings, using of_nat. Also, is it worth developing bounded quantifiers
- "ALL i :# M. P i"?
-*)
-
-constdefs
- msetprod :: "('a => ('b::{power,comm_monoid_mult})) => 'a multiset => 'b"
- "msetprod f M == setprod (%x. (f x)^(count M x)) (set_of M)"
-
-syntax
- "_msetprod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"
- ("(3PROD _:#_. _)" [0, 51, 10] 10)
-
-translations
- "PROD i :# A. b" == "msetprod (%i. b) A"
-
-lemma msetprod_Un: "msetprod f (A+B) = msetprod f A * msetprod f B"
- apply (simp add: msetprod_def power_add)
- apply (subst setprod_Un2)
- apply auto
- apply (subgoal_tac
- "(PROD x:set_of A - set_of B. f x ^ count A x * f x ^ count B x) =
- (PROD x:set_of A - set_of B. f x ^ count A x)")
- apply (erule ssubst)
- apply (subgoal_tac
- "(PROD x:set_of B - set_of A. f x ^ count A x * f x ^ count B x) =
- (PROD x:set_of B - set_of A. f x ^ count B x)")
- apply (erule ssubst)
- apply (subgoal_tac "(PROD x:set_of A. f x ^ count A x) =
- (PROD x:set_of A - set_of B. f x ^ count A x) *
- (PROD x:set_of A Int set_of B. f x ^ count A x)")
- apply (erule ssubst)
- apply (subgoal_tac "(PROD x:set_of B. f x ^ count B x) =
- (PROD x:set_of B - set_of A. f x ^ count B x) *
- (PROD x:set_of A Int set_of B. f x ^ count B x)")
- apply (erule ssubst)
- apply (subst setprod_timesf)
- apply (force simp add: mult_ac)
- apply (subst setprod_Un_disjoint [symmetric])
- apply (auto intro: setprod_cong)
- apply (subst setprod_Un_disjoint [symmetric])
- apply (auto intro: setprod_cong)
-done
-
-
-subsection {* unique factorization: multiset version *}
-
-lemma multiset_prime_factorization_exists [rule_format]: "n > 0 -->
- (EX M. (ALL (p::nat) : set_of M. prime p) & n = (PROD i :# M. i))"
-proof (rule nat_less_induct, clarify)
- fix n :: nat
- assume ih: "ALL m < n. 0 < m --> (EX M. (ALL p : set_of M. prime p) & m =
- (PROD i :# M. i))"
- assume "(n::nat) > 0"
- then have "n = 1 | (n > 1 & prime n) | (n > 1 & ~ prime n)"
- by arith
- moreover
- {
- assume "n = 1"
- then have "(ALL p : set_of {#}. prime p) & n = (PROD i :# {#}. i)"
- by (auto simp add: msetprod_def)
- }
- moreover
- {
- assume "n > 1" and "prime n"
- then have "(ALL p : set_of {# n #}. prime p) & n = (PROD i :# {# n #}. i)"
- by (auto simp add: msetprod_def)
- }
- moreover
- {
- assume "n > 1" and "~ prime n"
- from prems not_prime_eq_prod_nat
- obtain m k where "n = m * k & 1 < m & m < n & 1 < k & k < n"
- by blast
- with ih obtain Q R where "(ALL p : set_of Q. prime p) & m = (PROD i:#Q. i)"
- and "(ALL p: set_of R. prime p) & k = (PROD i:#R. i)"
- by blast
- hence "(ALL p: set_of (Q + R). prime p) & n = (PROD i :# Q + R. i)"
- by (auto simp add: prems msetprod_Un set_of_union)
- then have "EX M. (ALL p : set_of M. prime p) & n = (PROD i :# M. i)"..
- }
- ultimately show "EX M. (ALL p : set_of M. prime p) & n = (PROD i::nat:#M. i)"
- by blast
-qed
-
-lemma multiset_prime_factorization_unique_aux:
- fixes a :: nat
- assumes "(ALL p : set_of M. prime p)" and
- "(ALL p : set_of N. prime p)" and
- "(PROD i :# M. i) dvd (PROD i:# N. i)"
- shows
- "count M a <= count N a"
-proof cases
- assume "a : set_of M"
- with prems have a: "prime a"
- by auto
- with prems have "a ^ count M a dvd (PROD i :# M. i)"
- by (auto intro: dvd_setprod simp add: msetprod_def)
- also have "... dvd (PROD i :# N. i)"
- by (rule prems)
- also have "... = (PROD i : (set_of N). i ^ (count N i))"
- by (simp add: msetprod_def)
- also have "... =
- a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))"
- proof (cases)
- assume "a : set_of N"
- hence b: "set_of N = {a} Un (set_of N - {a})"
- by auto
- thus ?thesis
- by (subst (1) b, subst setprod_Un_disjoint, auto)
- next
- assume "a ~: set_of N"
- thus ?thesis
- by auto
- qed
- finally have "a ^ count M a dvd
- a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))".
- moreover have "coprime (a ^ count M a)
- (PROD i : (set_of N - {a}). i ^ (count N i))"
- apply (subst gcd_commute_nat)
- apply (rule setprod_coprime_nat)
- apply (rule primes_imp_powers_coprime_nat)
- apply (insert prems, auto)
- done
- ultimately have "a ^ count M a dvd a^(count N a)"
- by (elim coprime_dvd_mult_nat)
- with a show ?thesis
- by (intro power_dvd_imp_le, auto)
-next
- assume "a ~: set_of M"
- thus ?thesis by auto
-qed
-
-lemma multiset_prime_factorization_unique:
- assumes "(ALL (p::nat) : set_of M. prime p)" and
- "(ALL p : set_of N. prime p)" and
- "(PROD i :# M. i) = (PROD i:# N. i)"
- shows
- "M = N"
-proof -
- {
- fix a
- from prems have "count M a <= count N a"
- by (intro multiset_prime_factorization_unique_aux, auto)
- moreover from prems have "count N a <= count M a"
- by (intro multiset_prime_factorization_unique_aux, auto)
- ultimately have "count M a = count N a"
- by auto
- }
- thus ?thesis by (simp add:multiset_eq_conv_count_eq)
-qed
-
-constdefs
- multiset_prime_factorization :: "nat => nat multiset"
- "multiset_prime_factorization n ==
- if n > 0 then (THE M. ((ALL p : set_of M. prime p) &
- n = (PROD i :# M. i)))
- else {#}"
-
-lemma multiset_prime_factorization: "n > 0 ==>
- (ALL p : set_of (multiset_prime_factorization n). prime p) &
- n = (PROD i :# (multiset_prime_factorization n). i)"
- apply (unfold multiset_prime_factorization_def)
- apply clarsimp
- apply (frule multiset_prime_factorization_exists)
- apply clarify
- apply (rule theI)
- apply (insert multiset_prime_factorization_unique, blast)+
-done
-
-
-subsection {* Prime factors and multiplicity for nats and ints *}
-
-class unique_factorization =
-
-fixes
- multiplicity :: "'a \<Rightarrow> 'a \<Rightarrow> nat" and
- prime_factors :: "'a \<Rightarrow> 'a set"
-
-(* definitions for the natural numbers *)
-
-instantiation nat :: unique_factorization
-
-begin
-
-definition
- multiplicity_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
-where
- "multiplicity_nat p n = count (multiset_prime_factorization n) p"
-
-definition
- prime_factors_nat :: "nat \<Rightarrow> nat set"
-where
- "prime_factors_nat n = set_of (multiset_prime_factorization n)"
-
-instance proof qed
-
-end
-
-(* definitions for the integers *)
-
-instantiation int :: unique_factorization
-
-begin
-
-definition
- multiplicity_int :: "int \<Rightarrow> int \<Rightarrow> nat"
-where
- "multiplicity_int p n = multiplicity (nat p) (nat n)"
-
-definition
- prime_factors_int :: "int \<Rightarrow> int set"
-where
- "prime_factors_int n = int ` (prime_factors (nat n))"
-
-instance proof qed
-
-end
-
-
-subsection {* Set up transfer *}
-
-lemma transfer_nat_int_prime_factors:
- "prime_factors (nat n) = nat ` prime_factors n"
- unfolding prime_factors_int_def apply auto
- by (subst transfer_int_nat_set_return_embed, assumption)
-
-lemma transfer_nat_int_prime_factors_closure: "n >= 0 \<Longrightarrow>
- nat_set (prime_factors n)"
- by (auto simp add: nat_set_def prime_factors_int_def)
-
-lemma transfer_nat_int_multiplicity: "p >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
- multiplicity (nat p) (nat n) = multiplicity p n"
- by (auto simp add: multiplicity_int_def)
-
-declare TransferMorphism_nat_int[transfer add return:
- transfer_nat_int_prime_factors transfer_nat_int_prime_factors_closure
- transfer_nat_int_multiplicity]
-
-
-lemma transfer_int_nat_prime_factors:
- "prime_factors (int n) = int ` prime_factors n"
- unfolding prime_factors_int_def by auto
-
-lemma transfer_int_nat_prime_factors_closure: "is_nat n \<Longrightarrow>
- nat_set (prime_factors n)"
- by (simp only: transfer_nat_int_prime_factors_closure is_nat_def)
-
-lemma transfer_int_nat_multiplicity:
- "multiplicity (int p) (int n) = multiplicity p n"
- by (auto simp add: multiplicity_int_def)
-
-declare TransferMorphism_int_nat[transfer add return:
- transfer_int_nat_prime_factors transfer_int_nat_prime_factors_closure
- transfer_int_nat_multiplicity]
-
-
-subsection {* Properties of prime factors and multiplicity for nats and ints *}
-
-lemma prime_factors_ge_0_int [elim]: "p : prime_factors (n::int) \<Longrightarrow> p >= 0"
- by (unfold prime_factors_int_def, auto)
-
-lemma prime_factors_prime_nat [intro]: "p : prime_factors (n::nat) \<Longrightarrow> prime p"
- apply (case_tac "n = 0")
- apply (simp add: prime_factors_nat_def multiset_prime_factorization_def)
- apply (auto simp add: prime_factors_nat_def multiset_prime_factorization)
-done
-
-lemma prime_factors_prime_int [intro]:
- assumes "n >= 0" and "p : prime_factors (n::int)"
- shows "prime p"
-
- apply (rule prime_factors_prime_nat [transferred, of n p])
- using prems apply auto
-done
-
-lemma prime_factors_gt_0_nat [elim]: "p : prime_factors x \<Longrightarrow> p > (0::nat)"
- by (frule prime_factors_prime_nat, auto)
-
-lemma prime_factors_gt_0_int [elim]: "x >= 0 \<Longrightarrow> p : prime_factors x \<Longrightarrow>
- p > (0::int)"
- by (frule (1) prime_factors_prime_int, auto)
-
-lemma prime_factors_finite_nat [iff]: "finite (prime_factors (n::nat))"
- by (unfold prime_factors_nat_def, auto)
-
-lemma prime_factors_finite_int [iff]: "finite (prime_factors (n::int))"
- by (unfold prime_factors_int_def, auto)
-
-lemma prime_factors_altdef_nat: "prime_factors (n::nat) =
- {p. multiplicity p n > 0}"
- by (force simp add: prime_factors_nat_def multiplicity_nat_def)
-
-lemma prime_factors_altdef_int: "prime_factors (n::int) =
- {p. p >= 0 & multiplicity p n > 0}"
- apply (unfold prime_factors_int_def multiplicity_int_def)
- apply (subst prime_factors_altdef_nat)
- apply (auto simp add: image_def)
-done
-
-lemma prime_factorization_nat: "(n::nat) > 0 \<Longrightarrow>
- n = (PROD p : prime_factors n. p^(multiplicity p n))"
- by (frule multiset_prime_factorization,
- simp add: prime_factors_nat_def multiplicity_nat_def msetprod_def)
-
-thm prime_factorization_nat [transferred]
-
-lemma prime_factorization_int:
- assumes "(n::int) > 0"
- shows "n = (PROD p : prime_factors n. p^(multiplicity p n))"
-
- apply (rule prime_factorization_nat [transferred, of n])
- using prems apply auto
-done
-
-lemma neq_zero_eq_gt_zero_nat: "((x::nat) ~= 0) = (x > 0)"
- by auto
-
-lemma prime_factorization_unique_nat:
- "S = { (p::nat) . f p > 0} \<Longrightarrow> finite S \<Longrightarrow> (ALL p : S. prime p) \<Longrightarrow>
- n = (PROD p : S. p^(f p)) \<Longrightarrow>
- S = prime_factors n & (ALL p. f p = multiplicity p n)"
- apply (subgoal_tac "multiset_prime_factorization n = Abs_multiset
- f")
- apply (unfold prime_factors_nat_def multiplicity_nat_def)
- apply (simp add: set_of_def count_def Abs_multiset_inverse multiset_def)
- apply (unfold multiset_prime_factorization_def)
- apply (subgoal_tac "n > 0")
- prefer 2
- apply force
- apply (subst if_P, assumption)
- apply (rule the1_equality)
- apply (rule ex_ex1I)
- apply (rule multiset_prime_factorization_exists, assumption)
- apply (rule multiset_prime_factorization_unique)
- apply force
- apply force
- apply force
- unfolding set_of_def count_def msetprod_def
- apply (subgoal_tac "f : multiset")
- apply (auto simp only: Abs_multiset_inverse)
- unfolding multiset_def apply force
-done
-
-lemma prime_factors_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
- finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
- prime_factors n = S"
- by (rule prime_factorization_unique_nat [THEN conjunct1, symmetric],
- assumption+)
-
-lemma prime_factors_characterization'_nat:
- "finite {p. 0 < f (p::nat)} \<Longrightarrow>
- (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
- prime_factors (PROD p | 0 < f p . p ^ f p) = {p. 0 < f p}"
- apply (rule prime_factors_characterization_nat)
- apply auto
-done
-
-(* A minor glitch:*)
-
-thm prime_factors_characterization'_nat
- [where f = "%x. f (int (x::nat))",
- transferred direction: nat "op <= (0::int)", rule_format]
-
-(*
- Transfer isn't smart enough to know that the "0 < f p" should
- remain a comparison between nats. But the transfer still works.
-*)
-
-lemma primes_characterization'_int [rule_format]:
- "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
- (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
- prime_factors (PROD p | p >=0 & 0 < f p . p ^ f p) =
- {p. p >= 0 & 0 < f p}"
-
- apply (insert prime_factors_characterization'_nat
- [where f = "%x. f (int (x::nat))",
- transferred direction: nat "op <= (0::int)"])
- apply auto
-done
-
-lemma prime_factors_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
- finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
- prime_factors n = S"
- apply simp
- apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
- apply (simp only:)
- apply (subst primes_characterization'_int)
- apply auto
- apply (auto simp add: prime_ge_0_int)
-done
-
-lemma multiplicity_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
- finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
- multiplicity p n = f p"
- by (frule prime_factorization_unique_nat [THEN conjunct2, rule_format,
- symmetric], auto)
-
-lemma multiplicity_characterization'_nat: "finite {p. 0 < f (p::nat)} \<longrightarrow>
- (ALL p. 0 < f p \<longrightarrow> prime p) \<longrightarrow>
- multiplicity p (PROD p | 0 < f p . p ^ f p) = f p"
- apply (rule impI)+
- apply (rule multiplicity_characterization_nat)
- apply auto
-done
-
-lemma multiplicity_characterization'_int [rule_format]:
- "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
- (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow> p >= 0 \<Longrightarrow>
- multiplicity p (PROD p | p >= 0 & 0 < f p . p ^ f p) = f p"
-
- apply (insert multiplicity_characterization'_nat
- [where f = "%x. f (int (x::nat))",
- transferred direction: nat "op <= (0::int)", rule_format])
- apply auto
-done
-
-lemma multiplicity_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
- finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
- p >= 0 \<Longrightarrow> multiplicity p n = f p"
- apply simp
- apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
- apply (simp only:)
- apply (subst multiplicity_characterization'_int)
- apply auto
- apply (auto simp add: prime_ge_0_int)
-done
-
-lemma multiplicity_zero_nat [simp]: "multiplicity (p::nat) 0 = 0"
- by (simp add: multiplicity_nat_def multiset_prime_factorization_def)
-
-lemma multiplicity_zero_int [simp]: "multiplicity (p::int) 0 = 0"
- by (simp add: multiplicity_int_def)
-
-lemma multiplicity_one_nat [simp]: "multiplicity p (1::nat) = 0"
- by (subst multiplicity_characterization_nat [where f = "%x. 0"], auto)
-
-lemma multiplicity_one_int [simp]: "multiplicity p (1::int) = 0"
- by (simp add: multiplicity_int_def)
-
-lemma multiplicity_prime_nat [simp]: "prime (p::nat) \<Longrightarrow> multiplicity p p = 1"
- apply (subst multiplicity_characterization_nat
- [where f = "(%q. if q = p then 1 else 0)"])
- apply auto
- apply (case_tac "x = p")
- apply auto
-done
-
-lemma multiplicity_prime_int [simp]: "prime (p::int) \<Longrightarrow> multiplicity p p = 1"
- unfolding prime_int_def multiplicity_int_def by auto
-
-lemma multiplicity_prime_power_nat [simp]: "prime (p::nat) \<Longrightarrow>
- multiplicity p (p^n) = n"
- apply (case_tac "n = 0")
- apply auto
- apply (subst multiplicity_characterization_nat
- [where f = "(%q. if q = p then n else 0)"])
- apply auto
- apply (case_tac "x = p")
- apply auto
-done
-
-lemma multiplicity_prime_power_int [simp]: "prime (p::int) \<Longrightarrow>
- multiplicity p (p^n) = n"
- apply (frule prime_ge_0_int)
- apply (auto simp add: prime_int_def multiplicity_int_def nat_power_eq)
-done
-
-lemma multiplicity_nonprime_nat [simp]: "~ prime (p::nat) \<Longrightarrow>
- multiplicity p n = 0"
- apply (case_tac "n = 0")
- apply auto
- apply (frule multiset_prime_factorization)
- apply (auto simp add: set_of_def multiplicity_nat_def)
-done
-
-lemma multiplicity_nonprime_int [simp]: "~ prime (p::int) \<Longrightarrow> multiplicity p n = 0"
- by (unfold multiplicity_int_def prime_int_def, auto)
-
-lemma multiplicity_not_factor_nat [simp]:
- "p ~: prime_factors (n::nat) \<Longrightarrow> multiplicity p n = 0"
- by (subst (asm) prime_factors_altdef_nat, auto)
-
-lemma multiplicity_not_factor_int [simp]:
- "p >= 0 \<Longrightarrow> p ~: prime_factors (n::int) \<Longrightarrow> multiplicity p n = 0"
- by (subst (asm) prime_factors_altdef_int, auto)
-
-lemma multiplicity_product_aux_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow>
- (prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
- (ALL p. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
- apply (rule prime_factorization_unique_nat)
- apply (simp only: prime_factors_altdef_nat)
- apply auto
- apply (subst power_add)
- apply (subst setprod_timesf)
- apply (rule arg_cong2)back back
- apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors k Un
- (prime_factors l - prime_factors k)")
- apply (erule ssubst)
- apply (subst setprod_Un_disjoint)
- apply auto
- apply (subgoal_tac "(\<Prod>p\<in>prime_factors l - prime_factors k. p ^ multiplicity p k) =
- (\<Prod>p\<in>prime_factors l - prime_factors k. 1)")
- apply (erule ssubst)
- apply (simp add: setprod_1)
- apply (erule prime_factorization_nat)
- apply (rule setprod_cong, auto)
- apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors l Un
- (prime_factors k - prime_factors l)")
- apply (erule ssubst)
- apply (subst setprod_Un_disjoint)
- apply auto
- apply (subgoal_tac "(\<Prod>p\<in>prime_factors k - prime_factors l. p ^ multiplicity p l) =
- (\<Prod>p\<in>prime_factors k - prime_factors l. 1)")
- apply (erule ssubst)
- apply (simp add: setprod_1)
- apply (erule prime_factorization_nat)
- apply (rule setprod_cong, auto)
-done
-
-(* transfer doesn't have the same problem here with the right
- choice of rules. *)
-
-lemma multiplicity_product_aux_int:
- assumes "(k::int) > 0" and "l > 0"
- shows
- "(prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
- (ALL p >= 0. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
-
- apply (rule multiplicity_product_aux_nat [transferred, of l k])
- using prems apply auto
-done
-
-lemma prime_factors_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
- prime_factors k Un prime_factors l"
- by (rule multiplicity_product_aux_nat [THEN conjunct1, symmetric])
-
-lemma prime_factors_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
- prime_factors k Un prime_factors l"
- by (rule multiplicity_product_aux_int [THEN conjunct1, symmetric])
-
-lemma multiplicity_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> multiplicity p (k * l) =
- multiplicity p k + multiplicity p l"
- by (rule multiplicity_product_aux_nat [THEN conjunct2, rule_format,
- symmetric])
-
-lemma multiplicity_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> p >= 0 \<Longrightarrow>
- multiplicity p (k * l) = multiplicity p k + multiplicity p l"
- by (rule multiplicity_product_aux_int [THEN conjunct2, rule_format,
- symmetric])
-
-lemma multiplicity_setprod_nat: "finite S \<Longrightarrow> (ALL x : S. f x > 0) \<Longrightarrow>
- multiplicity (p::nat) (PROD x : S. f x) =
- (SUM x : S. multiplicity p (f x))"
- apply (induct set: finite)
- apply auto
- apply (subst multiplicity_product_nat)
- apply auto
-done
-
-(* Transfer is delicate here for two reasons: first, because there is
- an implicit quantifier over functions (f), and, second, because the
- product over the multiplicity should not be translated to an integer
- product.
-
- The way to handle the first is to use quantifier rules for functions.
- The way to handle the second is to turn off the offending rule.
-*)
-
-lemma transfer_nat_int_sum_prod_closure3:
- "(SUM x : A. int (f x)) >= 0"
- "(PROD x : A. int (f x)) >= 0"
- apply (rule setsum_nonneg, auto)
- apply (rule setprod_nonneg, auto)
-done
-
-declare TransferMorphism_nat_int[transfer
- add return: transfer_nat_int_sum_prod_closure3
- del: transfer_nat_int_sum_prod2 (1)]
-
-lemma multiplicity_setprod_int: "p >= 0 \<Longrightarrow> finite S \<Longrightarrow>
- (ALL x : S. f x > 0) \<Longrightarrow>
- multiplicity (p::int) (PROD x : S. f x) =
- (SUM x : S. multiplicity p (f x))"
-
- apply (frule multiplicity_setprod_nat
- [where f = "%x. nat(int(nat(f x)))",
- transferred direction: nat "op <= (0::int)"])
- apply auto
- apply (subst (asm) setprod_cong)
- apply (rule refl)
- apply (rule if_P)
- apply auto
- apply (rule setsum_cong)
- apply auto
-done
-
-declare TransferMorphism_nat_int[transfer
- add return: transfer_nat_int_sum_prod2 (1)]
-
-lemma multiplicity_prod_prime_powers_nat:
- "finite S \<Longrightarrow> (ALL p : S. prime (p::nat)) \<Longrightarrow>
- multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
- apply (subgoal_tac "(PROD p : S. p ^ f p) =
- (PROD p : S. p ^ (%x. if x : S then f x else 0) p)")
- apply (erule ssubst)
- apply (subst multiplicity_characterization_nat)
- prefer 5 apply (rule refl)
- apply (rule refl)
- apply auto
- apply (subst setprod_mono_one_right)
- apply assumption
- prefer 3
- apply (rule setprod_cong)
- apply (rule refl)
- apply auto
-done
-
-(* Here the issue with transfer is the implicit quantifier over S *)
-
-lemma multiplicity_prod_prime_powers_int:
- "(p::int) >= 0 \<Longrightarrow> finite S \<Longrightarrow> (ALL p : S. prime p) \<Longrightarrow>
- multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
-
- apply (subgoal_tac "int ` nat ` S = S")
- apply (frule multiplicity_prod_prime_powers_nat [where f = "%x. f(int x)"
- and S = "nat ` S", transferred])
- apply auto
- apply (subst prime_int_def [symmetric])
- apply auto
- apply (subgoal_tac "xb >= 0")
- apply force
- apply (rule prime_ge_0_int)
- apply force
- apply (subst transfer_nat_int_set_return_embed)
- apply (unfold nat_set_def, auto)
-done
-
-lemma multiplicity_distinct_prime_power_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow>
- p ~= q \<Longrightarrow> multiplicity p (q^n) = 0"
- apply (subgoal_tac "q^n = setprod (%x. x^n) {q}")
- apply (erule ssubst)
- apply (subst multiplicity_prod_prime_powers_nat)
- apply auto
-done
-
-lemma multiplicity_distinct_prime_power_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow>
- p ~= q \<Longrightarrow> multiplicity p (q^n) = 0"
- apply (frule prime_ge_0_int [of q])
- apply (frule multiplicity_distinct_prime_power_nat [transferred leaving: n])
- prefer 4
- apply assumption
- apply auto
-done
-
-lemma dvd_multiplicity_nat:
- "(0::nat) < y \<Longrightarrow> x dvd y \<Longrightarrow> multiplicity p x <= multiplicity p y"
- apply (case_tac "x = 0")
- apply (auto simp add: dvd_def multiplicity_product_nat)
-done
-
-lemma dvd_multiplicity_int:
- "(0::int) < y \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> p >= 0 \<Longrightarrow>
- multiplicity p x <= multiplicity p y"
- apply (case_tac "x = 0")
- apply (auto simp add: dvd_def)
- apply (subgoal_tac "0 < k")
- apply (auto simp add: multiplicity_product_int)
- apply (erule zero_less_mult_pos)
- apply arith
-done
-
-lemma dvd_prime_factors_nat [intro]:
- "0 < (y::nat) \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
- apply (simp only: prime_factors_altdef_nat)
- apply auto
- apply (frule dvd_multiplicity_nat)
- apply auto
-(* It is a shame that auto and arith don't get this. *)
- apply (erule order_less_le_trans)back
- apply assumption
-done
-
-lemma dvd_prime_factors_int [intro]:
- "0 < (y::int) \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
- apply (auto simp add: prime_factors_altdef_int)
- apply (erule order_less_le_trans)
- apply (rule dvd_multiplicity_int)
- apply auto
-done
-
-lemma multiplicity_dvd_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
- ALL p. multiplicity p x <= multiplicity p y \<Longrightarrow>
- x dvd y"
- apply (subst prime_factorization_nat [of x], assumption)
- apply (subst prime_factorization_nat [of y], assumption)
- apply (rule setprod_dvd_setprod_subset2)
- apply force
- apply (subst prime_factors_altdef_nat)+
- apply auto
-(* Again, a shame that auto and arith don't get this. *)
- apply (drule_tac x = xa in spec, auto)
- apply (rule le_imp_power_dvd)
- apply blast
-done
-
-lemma multiplicity_dvd_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
- ALL p >= 0. multiplicity p x <= multiplicity p y \<Longrightarrow>
- x dvd y"
- apply (subst prime_factorization_int [of x], assumption)
- apply (subst prime_factorization_int [of y], assumption)
- apply (rule setprod_dvd_setprod_subset2)
- apply force
- apply (subst prime_factors_altdef_int)+
- apply auto
- apply (rule dvd_power_le)
- apply auto
- apply (drule_tac x = xa in spec)
- apply (erule impE)
- apply auto
-done
-
-lemma multiplicity_dvd'_nat: "(0::nat) < x \<Longrightarrow>
- \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
- apply (cases "y = 0")
- apply auto
- apply (rule multiplicity_dvd_nat, auto)
- apply (case_tac "prime p")
- apply auto
-done
-
-lemma multiplicity_dvd'_int: "(0::int) < x \<Longrightarrow> 0 <= y \<Longrightarrow>
- \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
- apply (cases "y = 0")
- apply auto
- apply (rule multiplicity_dvd_int, auto)
- apply (case_tac "prime p")
- apply auto
-done
-
-lemma dvd_multiplicity_eq_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
- (x dvd y) = (ALL p. multiplicity p x <= multiplicity p y)"
- by (auto intro: dvd_multiplicity_nat multiplicity_dvd_nat)
-
-lemma dvd_multiplicity_eq_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
- (x dvd y) = (ALL p >= 0. multiplicity p x <= multiplicity p y)"
- by (auto intro: dvd_multiplicity_int multiplicity_dvd_int)
-
-lemma prime_factors_altdef2_nat: "(n::nat) > 0 \<Longrightarrow>
- (p : prime_factors n) = (prime p & p dvd n)"
- apply (case_tac "prime p")
- apply auto
- apply (subst prime_factorization_nat [where n = n], assumption)
- apply (rule dvd_trans)
- apply (rule dvd_power [where x = p and n = "multiplicity p n"])
- apply (subst (asm) prime_factors_altdef_nat, force)
- apply (rule dvd_setprod)
- apply auto
- apply (subst prime_factors_altdef_nat)
- apply (subst (asm) dvd_multiplicity_eq_nat)
- apply auto
- apply (drule spec [where x = p])
- apply auto
-done
-
-lemma prime_factors_altdef2_int:
- assumes "(n::int) > 0"
- shows "(p : prime_factors n) = (prime p & p dvd n)"
-
- apply (case_tac "p >= 0")
- apply (rule prime_factors_altdef2_nat [transferred])
- using prems apply auto
- apply (auto simp add: prime_ge_0_int prime_factors_ge_0_int)
-done
-
-lemma multiplicity_eq_nat:
- fixes x and y::nat
- assumes [arith]: "x > 0" "y > 0" and
- mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
- shows "x = y"
-
- apply (rule dvd_anti_sym)
- apply (auto intro: multiplicity_dvd'_nat)
-done
-
-lemma multiplicity_eq_int:
- fixes x and y::int
- assumes [arith]: "x > 0" "y > 0" and
- mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
- shows "x = y"
-
- apply (rule dvd_anti_sym [transferred])
- apply (auto intro: multiplicity_dvd'_int)
-done
-
-
-subsection {* An application *}
-
-lemma gcd_eq_nat:
- assumes pos [arith]: "x > 0" "y > 0"
- shows "gcd (x::nat) y =
- (PROD p: prime_factors x Un prime_factors y.
- p ^ (min (multiplicity p x) (multiplicity p y)))"
-proof -
- def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
- p ^ (min (multiplicity p x) (multiplicity p y)))"
- have [arith]: "z > 0"
- unfolding z_def by (rule setprod_pos_nat, auto)
- have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
- min (multiplicity p x) (multiplicity p y)"
- unfolding z_def
- apply (subst multiplicity_prod_prime_powers_nat)
- apply (auto simp add: multiplicity_not_factor_nat)
- done
- have "z dvd x"
- by (intro multiplicity_dvd'_nat, auto simp add: aux)
- moreover have "z dvd y"
- by (intro multiplicity_dvd'_nat, auto simp add: aux)
- moreover have "ALL w. w dvd x & w dvd y \<longrightarrow> w dvd z"
- apply auto
- apply (case_tac "w = 0", auto)
- apply (erule multiplicity_dvd'_nat)
- apply (auto intro: dvd_multiplicity_nat simp add: aux)
- done
- ultimately have "z = gcd x y"
- by (subst gcd_unique_nat [symmetric], blast)
- thus ?thesis
- unfolding z_def by auto
-qed
-
-lemma lcm_eq_nat:
- assumes pos [arith]: "x > 0" "y > 0"
- shows "lcm (x::nat) y =
- (PROD p: prime_factors x Un prime_factors y.
- p ^ (max (multiplicity p x) (multiplicity p y)))"
-proof -
- def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
- p ^ (max (multiplicity p x) (multiplicity p y)))"
- have [arith]: "z > 0"
- unfolding z_def by (rule setprod_pos_nat, auto)
- have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
- max (multiplicity p x) (multiplicity p y)"
- unfolding z_def
- apply (subst multiplicity_prod_prime_powers_nat)
- apply (auto simp add: multiplicity_not_factor_nat)
- done
- have "x dvd z"
- by (intro multiplicity_dvd'_nat, auto simp add: aux)
- moreover have "y dvd z"
- by (intro multiplicity_dvd'_nat, auto simp add: aux)
- moreover have "ALL w. x dvd w & y dvd w \<longrightarrow> z dvd w"
- apply auto
- apply (case_tac "w = 0", auto)
- apply (rule multiplicity_dvd'_nat)
- apply (auto intro: dvd_multiplicity_nat simp add: aux)
- done
- ultimately have "z = lcm x y"
- by (subst lcm_unique_nat [symmetric], blast)
- thus ?thesis
- unfolding z_def by auto
-qed
-
-lemma multiplicity_gcd_nat:
- assumes [arith]: "x > 0" "y > 0"
- shows "multiplicity (p::nat) (gcd x y) =
- min (multiplicity p x) (multiplicity p y)"
-
- apply (subst gcd_eq_nat)
- apply auto
- apply (subst multiplicity_prod_prime_powers_nat)
- apply auto
-done
-
-lemma multiplicity_lcm_nat:
- assumes [arith]: "x > 0" "y > 0"
- shows "multiplicity (p::nat) (lcm x y) =
- max (multiplicity p x) (multiplicity p y)"
-
- apply (subst lcm_eq_nat)
- apply auto
- apply (subst multiplicity_prod_prime_powers_nat)
- apply auto
-done
-
-lemma gcd_lcm_distrib_nat: "gcd (x::nat) (lcm y z) = lcm (gcd x y) (gcd x z)"
- apply (case_tac "x = 0 | y = 0 | z = 0")
- apply auto
- apply (rule multiplicity_eq_nat)
- apply (auto simp add: multiplicity_gcd_nat multiplicity_lcm_nat
- lcm_pos_nat)
-done
-
-lemma gcd_lcm_distrib_int: "gcd (x::int) (lcm y z) = lcm (gcd x y) (gcd x z)"
- apply (subst (1 2 3) gcd_abs_int)
- apply (subst lcm_abs_int)
- apply (subst (2) abs_of_nonneg)
- apply force
- apply (rule gcd_lcm_distrib_nat [transferred])
- apply auto
-done
-
-end
--- a/src/HOL/Nominal/Examples/Class.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/Examples/Class.thy Thu Oct 01 07:40:25 2009 +0200
@@ -11134,7 +11134,6 @@
shows "pi1\<bullet>(lfp f) = lfp (pi1\<bullet>f)"
and "pi2\<bullet>(lfp g) = lfp (pi2\<bullet>g)"
apply(simp add: lfp_def)
-apply(simp add: Inf_set_eq)
apply(simp add: big_inter_eqvt)
apply(simp add: pt_Collect_eqvt[OF pt_name_inst, OF at_name_inst])
apply(subgoal_tac "{u. (pi1\<bullet>f) u \<subseteq> u} = {u. ((rev pi1)\<bullet>((pi1\<bullet>f) u)) \<subseteq> ((rev pi1)\<bullet>u)}")
@@ -11146,7 +11145,6 @@
apply(drule subseteq_eqvt(1)[THEN iffD2])
apply(simp add: perm_bool)
apply(simp add: lfp_def)
-apply(simp add: Inf_set_eq)
apply(simp add: big_inter_eqvt)
apply(simp add: pt_Collect_eqvt[OF pt_coname_inst, OF at_coname_inst])
apply(subgoal_tac "{u. (pi2\<bullet>g) u \<subseteq> u} = {u. ((rev pi2)\<bullet>((pi2\<bullet>g) u)) \<subseteq> ((rev pi2)\<bullet>u)}")
--- a/src/HOL/Nominal/Examples/Crary.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/Examples/Crary.thy Thu Oct 01 07:40:25 2009 +0200
@@ -408,20 +408,7 @@
declare trm.inject[simp del]
-lemma whn_eqvt[eqvt]:
- fixes pi::"name prm"
- assumes a: "t \<Down> t'"
- shows "(pi\<bullet>t) \<Down> (pi\<bullet>t')"
-using a
-apply(induct)
-apply(rule QAN_Reduce)
-apply(rule whr_def.eqvt)
-apply(assumption)+
-apply(rule QAN_Normal)
-apply(auto)
-apply(drule_tac pi="rev pi" in whr_def.eqvt)
-apply(perm_simp)
-done
+equivariance whn_def
lemma red_unicity :
assumes a: "x \<leadsto> a"
@@ -631,6 +618,7 @@
apply (force)
apply (rule ty_cases)
done
+
termination by lexicographic_order
lemma logical_monotonicity:
@@ -968,7 +956,7 @@
then show "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T" using main_lemma(1) val by simp
qed
-text {* We leave soundness as an exercise - like in the book :-) \\
+text {* We leave soundness as an exercise - just like Crary in the ATS book :-) \\
@{prop[mode=IfThen] "\<lbrakk>\<Gamma> \<turnstile> s \<Leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"} \\
@{prop "\<lbrakk>\<Gamma> \<turnstile> s \<leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"}
*}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nominal/Examples/Nominal_Examples.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,25 @@
+(* Author: Christian Urban TU Muenchen *)
+
+header {* Various examples involving nominal datatypes. *}
+
+theory Nominal_Examples
+imports
+ CR
+ CR_Takahashi
+ Class
+ Compile
+ Fsub
+ Height
+ Lambda_mu
+ SN
+ Weakening
+ Crary
+ SOS
+ LocalWeakening
+ Support
+ Contexts
+ Standardization
+ W
+begin
+
+end
--- a/src/HOL/Nominal/Examples/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/Examples/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,27 +1,4 @@
-(* Title: HOL/Nominal/Examples/ROOT.ML
- ID: $Id$
- Author: Christian Urban, TU Muenchen
-
-Various examples involving nominal datatypes.
-*)
-use_thys [
- "CR",
- "CR_Takahashi",
- "Class",
- "Compile",
- "Fsub",
- "Height",
- "Lambda_mu",
- "SN",
- "Weakening",
- "Crary",
- "SOS",
- "LocalWeakening",
- "Support",
- "Contexts",
- "Standardization",
- "W"
-];
+use_thy "Nominal_Examples";
-setmp_noncritical quick_and_dirty true use_thy "VC_Condition";
+setmp_noncritical quick_and_dirty true use_thy "VC_Condition"; (*FIXME*)
--- a/src/HOL/Nominal/Nominal.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/Nominal.thy Thu Oct 01 07:40:25 2009 +0200
@@ -2623,74 +2623,77 @@
avoiding a finitely supported c and there is a permutation
which 'translates' between both sets.
*}
+
lemma at_set_avoiding_aux:
fixes Xs::"'a set"
and As::"'a set"
assumes at: "at TYPE('a)"
- and a: "finite Xs"
and b: "Xs \<subseteq> As"
and c: "finite As"
and d: "finite ((supp c)::'a set)"
- shows "\<exists>(Ys::'a set) (pi::'a prm). Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> (pi\<bullet>Xs=Ys) \<and>
- set pi \<subseteq> Xs \<times> Ys \<and> finite Ys"
-using a b c
-proof (induct)
- case empty
- have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
- moreover
- have "({}::'a set) \<inter> As = {}" by simp
- moreover
- have "([]::'a prm)\<bullet>{} = ({}::'a set)"
- by (rule pt1[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at])
- moreover
- have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
- moreover
- have "finite ({}::'a set)" by simp
- ultimately show ?case by blast
-next
- case (insert x Xs)
- then have ih: "\<exists>Ys pi. Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> pi\<bullet>Xs = Ys \<and> set pi \<subseteq> Xs \<times> Ys \<and> finite Ys" by simp
- then obtain Ys pi where a1: "Ys\<sharp>*c" and a2: "Ys \<inter> As = {}" and a3: "pi\<bullet>Xs = Ys" and
- a4: "set pi \<subseteq> Xs \<times> Ys" and a5: "finite Ys" by blast
- have b: "x\<notin>Xs" by fact
- have d1: "finite As" by fact
- have d2: "finite Xs" by fact
- have d3: "insert x Xs \<subseteq> As" by fact
- have "\<exists>y::'a. y\<sharp>(c,x,Ys,As)" using d d1 a5
- by (rule_tac at_exists_fresh'[OF at])
- (simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at])
- then obtain y::"'a" where e: "y\<sharp>(c,x,Ys,As)" by blast
- have "({y}\<union>Ys)\<sharp>*c" using a1 e by (simp add: fresh_star_def)
- moreover
- have "({y}\<union>Ys)\<inter>As = {}" using a2 d1 e by (simp add: fresh_prod at_fin_set_fresh[OF at])
- moreover
- have "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys"
- proof -
- have eq: "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
+ shows "\<exists>(pi::'a prm). (pi\<bullet>Xs)\<sharp>*c \<and> (pi\<bullet>Xs) \<inter> As = {} \<and> set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)"
+proof -
+ from b c have "finite Xs" by (simp add: finite_subset)
+ then show ?thesis using b
+ proof (induct)
+ case empty
+ have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
+ moreover
+ have "({}::'a set) \<inter> As = {}" by simp
+ moreover
+ have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
+ moreover
+ have "([]::'a prm)\<bullet>{} = ({}::'a set)"
+ by (rule pt1[OF pt_fun_inst, OF at_pt_inst[OF at] pt_bool_inst at])
+ ultimately show ?case by simp
+ next
+ case (insert x Xs)
+ then have ih: "\<exists>pi. (pi\<bullet>Xs)\<sharp>*c \<and> (pi\<bullet>Xs) \<inter> As = {} \<and> set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)" by simp
+ then obtain pi where a1: "(pi\<bullet>Xs)\<sharp>*c" and a2: "(pi\<bullet>Xs) \<inter> As = {}" and
+ a4: "set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)" by blast
+ have b: "x\<notin>Xs" by fact
+ have d1: "finite As" by fact
+ have d2: "finite Xs" by fact
+ have d3: "({x} \<union> Xs) \<subseteq> As" using insert(4) by simp
+ from d d1 d2
+ obtain y::"'a" where fr: "y\<sharp>(c,pi\<bullet>Xs,As)"
+ apply(rule_tac at_exists_fresh[OF at, where x="(c,pi\<bullet>Xs,As)"])
+ apply(auto simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at]
+ pt_supp_finite_pi[OF pt_fun_inst[OF at_pt_inst[OF at] pt_bool_inst at] at])
+ done
+ have "({y}\<union>(pi\<bullet>Xs))\<sharp>*c" using a1 fr by (simp add: fresh_star_def)
+ moreover
+ have "({y}\<union>(pi\<bullet>Xs))\<inter>As = {}" using a2 d1 fr
+ by (simp add: fresh_prod at_fin_set_fresh[OF at])
+ moreover
+ have "pi\<bullet>x=x" using a4 b a2 d3
+ by (rule_tac at_prm_fresh2[OF at]) (auto)
+ then have "set ((pi\<bullet>x,y)#pi) \<subseteq> ({x} \<union> Xs) \<times> ({y}\<union>(pi\<bullet>Xs))" using a4 by auto
+ moreover
+ have "(((pi\<bullet>x,y)#pi)\<bullet>({x} \<union> Xs)) = {y}\<union>(pi\<bullet>Xs)"
proof -
- have "(pi\<bullet>x)\<sharp>Ys" using a3[symmetric] b d2
- by(simp add: pt_fresh_bij[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at]
- at_fin_set_fresh[OF at])
- moreover
- have "y\<sharp>Ys" using e by simp
- ultimately show "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
- by (simp add: pt_fresh_fresh[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at])
+ have eq: "[(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs) = (pi\<bullet>Xs)"
+ proof -
+ have "(pi\<bullet>x)\<sharp>(pi\<bullet>Xs)" using b d2
+ by(simp add: pt_fresh_bij[OF pt_fun_inst, OF at_pt_inst[OF at],
+ OF pt_bool_inst, OF at, OF at]
+ at_fin_set_fresh[OF at])
+ moreover
+ have "y\<sharp>(pi\<bullet>Xs)" using fr by simp
+ ultimately show "[(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs) = (pi\<bullet>Xs)"
+ by (simp add: pt_fresh_fresh[OF pt_fun_inst,
+ OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at])
+ qed
+ have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
+ by (simp add: pt2[symmetric, OF pt_fun_inst, OF at_pt_inst[OF at],
+ OF pt_bool_inst, OF at])
+ also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
+ by (simp only: union_eqvt perm_set_eq[OF at_pt_inst[OF at], OF at] at_calc[OF at])(auto)
+ finally show "(((pi\<bullet>x,y)#pi)\<bullet>({x} \<union> Xs)) = {y}\<union>(pi\<bullet>Xs)" using eq by simp
qed
- have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
- by (simp add: pt2[symmetric, OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at])
- also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
- by (simp only: union_eqvt perm_set_eq[OF at_pt_inst[OF at], OF at] at_calc[OF at])(auto)
- also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>Ys)" using a3 by simp
- also have "\<dots> = {y}\<union>Ys" using eq by simp
- finally show "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys" by auto
+ ultimately
+ show ?case by (rule_tac x="(pi\<bullet>x,y)#pi" in exI) (auto)
qed
- moreover
- have "pi\<bullet>x=x" using a4 b a2 a3 d3 by (rule_tac at_prm_fresh2[OF at]) (auto)
- then have "set ((pi\<bullet>x,y)#pi) \<subseteq> (insert x Xs) \<times> ({y}\<union>Ys)" using a4 by auto
- moreover
- have "finite ({y}\<union>Ys)" using a5 by simp
- ultimately
- show ?case by blast
qed
lemma at_set_avoiding:
@@ -2698,10 +2701,10 @@
assumes at: "at TYPE('a)"
and a: "finite Xs"
and b: "finite ((supp c)::'a set)"
- obtains pi::"'a prm" where "(pi \<bullet> Xs) \<sharp>* c" and "set pi \<subseteq> Xs \<times> (pi \<bullet> Xs)"
- using a b
- by (frule_tac As="Xs" in at_set_avoiding_aux[OF at]) auto
-
+ obtains pi::"'a prm" where "(pi\<bullet>Xs)\<sharp>*c" and "set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)"
+using a b at_set_avoiding_aux[OF at, where Xs="Xs" and As="Xs" and c="c"]
+by (blast)
+
section {* composition instances *}
(* ============================= *)
--- a/src/HOL/Nominal/nominal_datatype.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/nominal_datatype.ML Thu Oct 01 07:40:25 2009 +0200
@@ -245,7 +245,7 @@
val (full_new_type_names',thy1) =
Datatype.add_datatype config new_type_names' dts'' thy;
- val {descr, induction, ...} =
+ val {descr, induct, ...} =
Datatype.the_info thy1 (hd full_new_type_names');
fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i);
@@ -322,7 +322,7 @@
Const ("Nominal.perm", T) $ pi $ Free (x, T2))
end)
(perm_names_types ~~ perm_indnames))))
- (fn _ => EVERY [indtac induction perm_indnames 1,
+ (fn _ => EVERY [indtac induct perm_indnames 1,
ALLGOALS (asm_full_simp_tac
(global_simpset_of thy2 addsimps [perm_fun_def]))])),
length new_type_names));
@@ -343,7 +343,7 @@
Free (x, T)))
(perm_names ~~
map body_type perm_types ~~ perm_indnames)))))
- (fn _ => EVERY [indtac induction perm_indnames 1,
+ (fn _ => EVERY [indtac induct perm_indnames 1,
ALLGOALS (asm_full_simp_tac (global_simpset_of thy2))])),
length new_type_names))
end)
@@ -378,7 +378,7 @@
end)
(perm_names ~~
map body_type perm_types ~~ perm_indnames)))))
- (fn _ => EVERY [indtac induction perm_indnames 1,
+ (fn _ => EVERY [indtac induct perm_indnames 1,
ALLGOALS (asm_full_simp_tac (global_simpset_of thy2 addsimps [pt2', pt2_ax]))]))),
length new_type_names)
end) atoms);
@@ -414,7 +414,7 @@
end)
(perm_names ~~
map body_type perm_types ~~ perm_indnames))))))
- (fn _ => EVERY [indtac induction perm_indnames 1,
+ (fn _ => EVERY [indtac induct perm_indnames 1,
ALLGOALS (asm_full_simp_tac (global_simpset_of thy2 addsimps [pt3', pt3_rev', pt3_ax]))]))),
length new_type_names)
end) atoms);
@@ -466,7 +466,7 @@
perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
end)
(perm_names ~~ Ts ~~ perm_indnames)))))
- (fn _ => EVERY [indtac induction perm_indnames 1,
+ (fn _ => EVERY [indtac induct perm_indnames 1,
ALLGOALS (asm_full_simp_tac simps)]))
in
fold (fn (s, tvs) => fn thy => AxClass.prove_arity
--- a/src/HOL/Nominal/nominal_permeq.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/nominal_permeq.ML Thu Oct 01 07:40:25 2009 +0200
@@ -228,11 +228,7 @@
addsimprocs [perm_compose_simproc]) i,
asm_full_simp_tac (HOL_basic_ss addsimps [perm_aux_fold]) i] st);
-
-(* applying Stefan's smart congruence tac *)
-fun apply_cong_tac i =
- ("application of congruence",
- (fn st => DatatypeAux.cong_tac i st handle Subscript => no_tac st));
+fun apply_cong_tac i = ("application of congruence", cong_tac i);
(* unfolds the definition of permutations *)
--- a/src/HOL/Nominal/nominal_thmdecls.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Nominal/nominal_thmdecls.ML Thu Oct 01 07:40:25 2009 +0200
@@ -18,7 +18,7 @@
val setup: theory -> theory
val get_eqvt_thms: Proof.context -> thm list
- val NOMINAL_EQVT_DEBUG : bool ref
+ val NOMINAL_EQVT_DEBUG : bool Unsynchronized.ref
end;
structure NominalThmDecls: NOMINAL_THMDECLS =
@@ -43,7 +43,7 @@
(* equality-lemma can be derived. *)
exception EQVT_FORM of string
-val NOMINAL_EQVT_DEBUG = ref false
+val NOMINAL_EQVT_DEBUG = Unsynchronized.ref false
fun tactic (msg, tac) =
if !NOMINAL_EQVT_DEBUG
@@ -74,7 +74,7 @@
val lhs = Const (@{const_name "perm"}, typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
val ([goal_term, pi''], ctxt') = Variable.import_terms false
[HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, concl)), pi'] ctxt
- val _ = Display.print_cterm (cterm_of thy goal_term)
+ val _ = writeln (Syntax.string_of_term ctxt' goal_term);
in
Goal.prove ctxt' [] [] goal_term
(fn _ => prove_eqvt_tac thy orig_thm pi' pi'') |>
--- a/src/HOL/NumberTheory/BijectionRel.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,231 +0,0 @@
-(* Title: HOL/NumberTheory/BijectionRel.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Bijections between sets *}
-
-theory BijectionRel imports Main begin
-
-text {*
- Inductive definitions of bijections between two different sets and
- between the same set. Theorem for relating the two definitions.
-
- \bigskip
-*}
-
-inductive_set
- bijR :: "('a => 'b => bool) => ('a set * 'b set) set"
- for P :: "'a => 'b => bool"
-where
- empty [simp]: "({}, {}) \<in> bijR P"
-| insert: "P a b ==> a \<notin> A ==> b \<notin> B ==> (A, B) \<in> bijR P
- ==> (insert a A, insert b B) \<in> bijR P"
-
-text {*
- Add extra condition to @{term insert}: @{term "\<forall>b \<in> B. \<not> P a b"}
- (and similar for @{term A}).
-*}
-
-definition
- bijP :: "('a => 'a => bool) => 'a set => bool" where
- "bijP P F = (\<forall>a b. a \<in> F \<and> P a b --> b \<in> F)"
-
-definition
- uniqP :: "('a => 'a => bool) => bool" where
- "uniqP P = (\<forall>a b c d. P a b \<and> P c d --> (a = c) = (b = d))"
-
-definition
- symP :: "('a => 'a => bool) => bool" where
- "symP P = (\<forall>a b. P a b = P b a)"
-
-inductive_set
- bijER :: "('a => 'a => bool) => 'a set set"
- for P :: "'a => 'a => bool"
-where
- empty [simp]: "{} \<in> bijER P"
-| insert1: "P a a ==> a \<notin> A ==> A \<in> bijER P ==> insert a A \<in> bijER P"
-| insert2: "P a b ==> a \<noteq> b ==> a \<notin> A ==> b \<notin> A ==> A \<in> bijER P
- ==> insert a (insert b A) \<in> bijER P"
-
-
-text {* \medskip @{term bijR} *}
-
-lemma fin_bijRl: "(A, B) \<in> bijR P ==> finite A"
- apply (erule bijR.induct)
- apply auto
- done
-
-lemma fin_bijRr: "(A, B) \<in> bijR P ==> finite B"
- apply (erule bijR.induct)
- apply auto
- done
-
-lemma aux_induct:
- assumes major: "finite F"
- and subs: "F \<subseteq> A"
- and cases: "P {}"
- "!!F a. F \<subseteq> A ==> a \<in> A ==> a \<notin> F ==> P F ==> P (insert a F)"
- shows "P F"
- using major subs
- apply (induct set: finite)
- apply (blast intro: cases)+
- done
-
-
-lemma inj_func_bijR_aux1:
- "A \<subseteq> B ==> a \<notin> A ==> a \<in> B ==> inj_on f B ==> f a \<notin> f ` A"
- apply (unfold inj_on_def)
- apply auto
- done
-
-lemma inj_func_bijR_aux2:
- "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A ==> F <= A
- ==> (F, f ` F) \<in> bijR P"
- apply (rule_tac F = F and A = A in aux_induct)
- apply (rule finite_subset)
- apply auto
- apply (rule bijR.insert)
- apply (rule_tac [3] inj_func_bijR_aux1)
- apply auto
- done
-
-lemma inj_func_bijR:
- "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A
- ==> (A, f ` A) \<in> bijR P"
- apply (rule inj_func_bijR_aux2)
- apply auto
- done
-
-
-text {* \medskip @{term bijER} *}
-
-lemma fin_bijER: "A \<in> bijER P ==> finite A"
- apply (erule bijER.induct)
- apply auto
- done
-
-lemma aux1:
- "a \<notin> A ==> a \<notin> B ==> F \<subseteq> insert a A ==> F \<subseteq> insert a B ==> a \<in> F
- ==> \<exists>C. F = insert a C \<and> a \<notin> C \<and> C <= A \<and> C <= B"
- apply (rule_tac x = "F - {a}" in exI)
- apply auto
- done
-
-lemma aux2: "a \<noteq> b ==> a \<notin> A ==> b \<notin> B ==> a \<in> F ==> b \<in> F
- ==> F \<subseteq> insert a A ==> F \<subseteq> insert b B
- ==> \<exists>C. F = insert a (insert b C) \<and> a \<notin> C \<and> b \<notin> C \<and> C \<subseteq> A \<and> C \<subseteq> B"
- apply (rule_tac x = "F - {a, b}" in exI)
- apply auto
- done
-
-lemma aux_uniq: "uniqP P ==> P a b ==> P c d ==> (a = c) = (b = d)"
- apply (unfold uniqP_def)
- apply auto
- done
-
-lemma aux_sym: "symP P ==> P a b = P b a"
- apply (unfold symP_def)
- apply auto
- done
-
-lemma aux_in1:
- "uniqP P ==> b \<notin> C ==> P b b ==> bijP P (insert b C) ==> bijP P C"
- apply (unfold bijP_def)
- apply auto
- apply (subgoal_tac "b \<noteq> a")
- prefer 2
- apply clarify
- apply (simp add: aux_uniq)
- apply auto
- done
-
-lemma aux_in2:
- "symP P ==> uniqP P ==> a \<notin> C ==> b \<notin> C ==> a \<noteq> b ==> P a b
- ==> bijP P (insert a (insert b C)) ==> bijP P C"
- apply (unfold bijP_def)
- apply auto
- apply (subgoal_tac "aa \<noteq> a")
- prefer 2
- apply clarify
- apply (subgoal_tac "aa \<noteq> b")
- prefer 2
- apply clarify
- apply (simp add: aux_uniq)
- apply (subgoal_tac "ba \<noteq> a")
- apply auto
- apply (subgoal_tac "P a aa")
- prefer 2
- apply (simp add: aux_sym)
- apply (subgoal_tac "b = aa")
- apply (rule_tac [2] iffD1)
- apply (rule_tac [2] a = a and c = a and P = P in aux_uniq)
- apply auto
- done
-
-lemma aux_foo: "\<forall>a b. Q a \<and> P a b --> R b ==> P a b ==> Q a ==> R b"
- apply auto
- done
-
-lemma aux_bij: "bijP P F ==> symP P ==> P a b ==> (a \<in> F) = (b \<in> F)"
- apply (unfold bijP_def)
- apply (rule iffI)
- apply (erule_tac [!] aux_foo)
- apply simp_all
- apply (rule iffD2)
- apply (rule_tac P = P in aux_sym)
- apply simp_all
- done
-
-
-lemma aux_bijRER:
- "(A, B) \<in> bijR P ==> uniqP P ==> symP P
- ==> \<forall>F. bijP P F \<and> F \<subseteq> A \<and> F \<subseteq> B --> F \<in> bijER P"
- apply (erule bijR.induct)
- apply simp
- apply (case_tac "a = b")
- apply clarify
- apply (case_tac "b \<in> F")
- prefer 2
- apply (simp add: subset_insert)
- apply (cut_tac F = F and a = b and A = A and B = B in aux1)
- prefer 6
- apply clarify
- apply (rule bijER.insert1)
- apply simp_all
- apply (subgoal_tac "bijP P C")
- apply simp
- apply (rule aux_in1)
- apply simp_all
- apply clarify
- apply (case_tac "a \<in> F")
- apply (case_tac [!] "b \<in> F")
- apply (cut_tac F = F and a = a and b = b and A = A and B = B
- in aux2)
- apply (simp_all add: subset_insert)
- apply clarify
- apply (rule bijER.insert2)
- apply simp_all
- apply (subgoal_tac "bijP P C")
- apply simp
- apply (rule aux_in2)
- apply simp_all
- apply (subgoal_tac "b \<in> F")
- apply (rule_tac [2] iffD1)
- apply (rule_tac [2] a = a and F = F and P = P in aux_bij)
- apply (simp_all (no_asm_simp))
- apply (subgoal_tac [2] "a \<in> F")
- apply (rule_tac [3] iffD2)
- apply (rule_tac [3] b = b and F = F and P = P in aux_bij)
- apply auto
- done
-
-lemma bijR_bijER:
- "(A, A) \<in> bijR P ==>
- bijP P A ==> uniqP P ==> symP P ==> A \<in> bijER P"
- apply (cut_tac A = A and B = A and P = P in aux_bijRER)
- apply auto
- done
-
-end
--- a/src/HOL/NumberTheory/Chinese.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,259 +0,0 @@
-(* Title: HOL/NumberTheory/Chinese.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* The Chinese Remainder Theorem *}
-
-theory Chinese
-imports IntPrimes
-begin
-
-text {*
- The Chinese Remainder Theorem for an arbitrary finite number of
- equations. (The one-equation case is included in theory @{text
- IntPrimes}. Uses functions for indexing.\footnote{Maybe @{term
- funprod} and @{term funsum} should be based on general @{term fold}
- on indices?}
-*}
-
-
-subsection {* Definitions *}
-
-consts
- funprod :: "(nat => int) => nat => nat => int"
- funsum :: "(nat => int) => nat => nat => int"
-
-primrec
- "funprod f i 0 = f i"
- "funprod f i (Suc n) = f (Suc (i + n)) * funprod f i n"
-
-primrec
- "funsum f i 0 = f i"
- "funsum f i (Suc n) = f (Suc (i + n)) + funsum f i n"
-
-definition
- m_cond :: "nat => (nat => int) => bool" where
- "m_cond n mf =
- ((\<forall>i. i \<le> n --> 0 < mf i) \<and>
- (\<forall>i j. i \<le> n \<and> j \<le> n \<and> i \<noteq> j --> zgcd (mf i) (mf j) = 1))"
-
-definition
- km_cond :: "nat => (nat => int) => (nat => int) => bool" where
- "km_cond n kf mf = (\<forall>i. i \<le> n --> zgcd (kf i) (mf i) = 1)"
-
-definition
- lincong_sol ::
- "nat => (nat => int) => (nat => int) => (nat => int) => int => bool" where
- "lincong_sol n kf bf mf x = (\<forall>i. i \<le> n --> zcong (kf i * x) (bf i) (mf i))"
-
-definition
- mhf :: "(nat => int) => nat => nat => int" where
- "mhf mf n i =
- (if i = 0 then funprod mf (Suc 0) (n - Suc 0)
- else if i = n then funprod mf 0 (n - Suc 0)
- else funprod mf 0 (i - Suc 0) * funprod mf (Suc i) (n - Suc 0 - i))"
-
-definition
- xilin_sol ::
- "nat => nat => (nat => int) => (nat => int) => (nat => int) => int" where
- "xilin_sol i n kf bf mf =
- (if 0 < n \<and> i \<le> n \<and> m_cond n mf \<and> km_cond n kf mf then
- (SOME x. 0 \<le> x \<and> x < mf i \<and> zcong (kf i * mhf mf n i * x) (bf i) (mf i))
- else 0)"
-
-definition
- x_sol :: "nat => (nat => int) => (nat => int) => (nat => int) => int" where
- "x_sol n kf bf mf = funsum (\<lambda>i. xilin_sol i n kf bf mf * mhf mf n i) 0 n"
-
-
-text {* \medskip @{term funprod} and @{term funsum} *}
-
-lemma funprod_pos: "(\<forall>i. i \<le> n --> 0 < mf i) ==> 0 < funprod mf 0 n"
- apply (induct n)
- apply auto
- apply (simp add: zero_less_mult_iff)
- done
-
-lemma funprod_zgcd [rule_format (no_asm)]:
- "(\<forall>i. k \<le> i \<and> i \<le> k + l --> zgcd (mf i) (mf m) = 1) -->
- zgcd (funprod mf k l) (mf m) = 1"
- apply (induct l)
- apply simp_all
- apply (rule impI)+
- apply (subst zgcd_zmult_cancel)
- apply auto
- done
-
-lemma funprod_zdvd [rule_format]:
- "k \<le> i --> i \<le> k + l --> mf i dvd funprod mf k l"
- apply (induct l)
- apply auto
- apply (subgoal_tac "i = Suc (k + l)")
- apply (simp_all (no_asm_simp))
- done
-
-lemma funsum_mod:
- "funsum f k l mod m = funsum (\<lambda>i. (f i) mod m) k l mod m"
- apply (induct l)
- apply auto
- apply (rule trans)
- apply (rule mod_add_eq)
- apply simp
- apply (rule mod_add_right_eq [symmetric])
- done
-
-lemma funsum_zero [rule_format (no_asm)]:
- "(\<forall>i. k \<le> i \<and> i \<le> k + l --> f i = 0) --> (funsum f k l) = 0"
- apply (induct l)
- apply auto
- done
-
-lemma funsum_oneelem [rule_format (no_asm)]:
- "k \<le> j --> j \<le> k + l -->
- (\<forall>i. k \<le> i \<and> i \<le> k + l \<and> i \<noteq> j --> f i = 0) -->
- funsum f k l = f j"
- apply (induct l)
- prefer 2
- apply clarify
- defer
- apply clarify
- apply (subgoal_tac "k = j")
- apply (simp_all (no_asm_simp))
- apply (case_tac "Suc (k + l) = j")
- apply (subgoal_tac "funsum f k l = 0")
- apply (rule_tac [2] funsum_zero)
- apply (subgoal_tac [3] "f (Suc (k + l)) = 0")
- apply (subgoal_tac [3] "j \<le> k + l")
- prefer 4
- apply arith
- apply auto
- done
-
-
-subsection {* Chinese: uniqueness *}
-
-lemma zcong_funprod_aux:
- "m_cond n mf ==> km_cond n kf mf
- ==> lincong_sol n kf bf mf x ==> lincong_sol n kf bf mf y
- ==> [x = y] (mod mf n)"
- apply (unfold m_cond_def km_cond_def lincong_sol_def)
- apply (rule iffD1)
- apply (rule_tac k = "kf n" in zcong_cancel2)
- apply (rule_tac [3] b = "bf n" in zcong_trans)
- prefer 4
- apply (subst zcong_sym)
- defer
- apply (rule order_less_imp_le)
- apply simp_all
- done
-
-lemma zcong_funprod [rule_format]:
- "m_cond n mf --> km_cond n kf mf -->
- lincong_sol n kf bf mf x --> lincong_sol n kf bf mf y -->
- [x = y] (mod funprod mf 0 n)"
- apply (induct n)
- apply (simp_all (no_asm))
- apply (blast intro: zcong_funprod_aux)
- apply (rule impI)+
- apply (rule zcong_zgcd_zmult_zmod)
- apply (blast intro: zcong_funprod_aux)
- prefer 2
- apply (subst zgcd_commute)
- apply (rule funprod_zgcd)
- apply (auto simp add: m_cond_def km_cond_def lincong_sol_def)
- done
-
-
-subsection {* Chinese: existence *}
-
-lemma unique_xi_sol:
- "0 < n ==> i \<le> n ==> m_cond n mf ==> km_cond n kf mf
- ==> \<exists>!x. 0 \<le> x \<and> x < mf i \<and> [kf i * mhf mf n i * x = bf i] (mod mf i)"
- apply (rule zcong_lineq_unique)
- apply (tactic {* stac (thm "zgcd_zmult_cancel") 2 *})
- apply (unfold m_cond_def km_cond_def mhf_def)
- apply (simp_all (no_asm_simp))
- apply safe
- apply (tactic {* stac (thm "zgcd_zmult_cancel") 3 *})
- apply (rule_tac [!] funprod_zgcd)
- apply safe
- apply simp_all
- apply (subgoal_tac "i<n")
- prefer 2
- apply arith
- apply (case_tac [2] i)
- apply simp_all
- done
-
-lemma x_sol_lin_aux:
- "0 < n ==> i \<le> n ==> j \<le> n ==> j \<noteq> i ==> mf j dvd mhf mf n i"
- apply (unfold mhf_def)
- apply (case_tac "i = 0")
- apply (case_tac [2] "i = n")
- apply (simp_all (no_asm_simp))
- apply (case_tac [3] "j < i")
- apply (rule_tac [3] dvd_mult2)
- apply (rule_tac [4] dvd_mult)
- apply (rule_tac [!] funprod_zdvd)
- apply arith
- apply arith
- apply arith
- apply arith
- apply arith
- apply arith
- apply arith
- apply arith
- done
-
-lemma x_sol_lin:
- "0 < n ==> i \<le> n
- ==> x_sol n kf bf mf mod mf i =
- xilin_sol i n kf bf mf * mhf mf n i mod mf i"
- apply (unfold x_sol_def)
- apply (subst funsum_mod)
- apply (subst funsum_oneelem)
- apply auto
- apply (subst dvd_eq_mod_eq_0 [symmetric])
- apply (rule dvd_mult)
- apply (rule x_sol_lin_aux)
- apply auto
- done
-
-
-subsection {* Chinese *}
-
-lemma chinese_remainder:
- "0 < n ==> m_cond n mf ==> km_cond n kf mf
- ==> \<exists>!x. 0 \<le> x \<and> x < funprod mf 0 n \<and> lincong_sol n kf bf mf x"
- apply safe
- apply (rule_tac [2] m = "funprod mf 0 n" in zcong_zless_imp_eq)
- apply (rule_tac [6] zcong_funprod)
- apply auto
- apply (rule_tac x = "x_sol n kf bf mf mod funprod mf 0 n" in exI)
- apply (unfold lincong_sol_def)
- apply safe
- apply (tactic {* stac (thm "zcong_zmod") 3 *})
- apply (tactic {* stac (thm "mod_mult_eq") 3 *})
- apply (tactic {* stac (thm "mod_mod_cancel") 3 *})
- apply (tactic {* stac (thm "x_sol_lin") 4 *})
- apply (tactic {* stac (thm "mod_mult_eq" RS sym) 6 *})
- apply (tactic {* stac (thm "zcong_zmod" RS sym) 6 *})
- apply (subgoal_tac [6]
- "0 \<le> xilin_sol i n kf bf mf \<and> xilin_sol i n kf bf mf < mf i
- \<and> [kf i * mhf mf n i * xilin_sol i n kf bf mf = bf i] (mod mf i)")
- prefer 6
- apply (simp add: zmult_ac)
- apply (unfold xilin_sol_def)
- apply (tactic {* asm_simp_tac @{simpset} 6 *})
- apply (rule_tac [6] ex1_implies_ex [THEN someI_ex])
- apply (rule_tac [6] unique_xi_sol)
- apply (rule_tac [3] funprod_zdvd)
- apply (unfold m_cond_def)
- apply (rule funprod_pos [THEN pos_mod_sign])
- apply (rule_tac [2] funprod_pos [THEN pos_mod_bound])
- apply auto
- done
-
-end
--- a/src/HOL/NumberTheory/Euler.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,304 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/Euler.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {* Euler's criterion *}
-
-theory Euler imports Residues EvenOdd begin
-
-definition
- MultInvPair :: "int => int => int => int set" where
- "MultInvPair a p j = {StandardRes p j, StandardRes p (a * (MultInv p j))}"
-
-definition
- SetS :: "int => int => int set set" where
- "SetS a p = (MultInvPair a p ` SRStar p)"
-
-
-subsection {* Property for MultInvPair *}
-
-lemma MultInvPair_prop1a:
- "[| zprime p; 2 < p; ~([a = 0](mod p));
- X \<in> (SetS a p); Y \<in> (SetS a p);
- ~((X \<inter> Y) = {}) |] ==> X = Y"
- apply (auto simp add: SetS_def)
- apply (drule StandardRes_SRStar_prop1a)+ defer 1
- apply (drule StandardRes_SRStar_prop1a)+
- apply (auto simp add: MultInvPair_def StandardRes_prop2 zcong_sym)
- apply (drule notE, rule MultInv_zcong_prop1, auto)[]
- apply (drule notE, rule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
- apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
- apply (drule MultInv_zcong_prop3, auto simp add: zcong_sym)[]
- apply (drule MultInv_zcong_prop1, auto)[]
- apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
- apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
- apply (drule MultInv_zcong_prop3, auto simp add: zcong_sym)[]
- done
-
-lemma MultInvPair_prop1b:
- "[| zprime p; 2 < p; ~([a = 0](mod p));
- X \<in> (SetS a p); Y \<in> (SetS a p);
- X \<noteq> Y |] ==> X \<inter> Y = {}"
- apply (rule notnotD)
- apply (rule notI)
- apply (drule MultInvPair_prop1a, auto)
- done
-
-lemma MultInvPair_prop1c: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
- \<forall>X \<in> SetS a p. \<forall>Y \<in> SetS a p. X \<noteq> Y --> X\<inter>Y = {}"
- by (auto simp add: MultInvPair_prop1b)
-
-lemma MultInvPair_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
- Union ( SetS a p) = SRStar p"
- apply (auto simp add: SetS_def MultInvPair_def StandardRes_SRStar_prop4
- SRStar_mult_prop2)
- apply (frule StandardRes_SRStar_prop3)
- apply (rule bexI, auto)
- done
-
-lemma MultInvPair_distinct: "[| zprime p; 2 < p; ~([a = 0] (mod p));
- ~([j = 0] (mod p));
- ~(QuadRes p a) |] ==>
- ~([j = a * MultInv p j] (mod p))"
-proof
- assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and
- "~([j = 0] (mod p))" and "~(QuadRes p a)"
- assume "[j = a * MultInv p j] (mod p)"
- then have "[j * j = (a * MultInv p j) * j] (mod p)"
- by (auto simp add: zcong_scalar)
- then have a:"[j * j = a * (MultInv p j * j)] (mod p)"
- by (auto simp add: zmult_ac)
- have "[j * j = a] (mod p)"
- proof -
- from prems have b: "[MultInv p j * j = 1] (mod p)"
- by (simp add: MultInv_prop2a)
- from b a show ?thesis
- by (auto simp add: zcong_zmult_prop2)
- qed
- then have "[j^2 = a] (mod p)"
- by (metis number_of_is_id power2_eq_square succ_bin_simps)
- with prems show False
- by (simp add: QuadRes_def)
-qed
-
-lemma MultInvPair_card_two: "[| zprime p; 2 < p; ~([a = 0] (mod p));
- ~(QuadRes p a); ~([j = 0] (mod p)) |] ==>
- card (MultInvPair a p j) = 2"
- apply (auto simp add: MultInvPair_def)
- apply (subgoal_tac "~ (StandardRes p j = StandardRes p (a * MultInv p j))")
- apply auto
- apply (metis MultInvPair_distinct Pls_def StandardRes_def aux number_of_is_id one_is_num_one)
- done
-
-
-subsection {* Properties of SetS *}
-
-lemma SetS_finite: "2 < p ==> finite (SetS a p)"
- by (auto simp add: SetS_def SRStar_finite [of p] finite_imageI)
-
-lemma SetS_elems_finite: "\<forall>X \<in> SetS a p. finite X"
- by (auto simp add: SetS_def MultInvPair_def)
-
-lemma SetS_elems_card: "[| zprime p; 2 < p; ~([a = 0] (mod p));
- ~(QuadRes p a) |] ==>
- \<forall>X \<in> SetS a p. card X = 2"
- apply (auto simp add: SetS_def)
- apply (frule StandardRes_SRStar_prop1a)
- apply (rule MultInvPair_card_two, auto)
- done
-
-lemma Union_SetS_finite: "2 < p ==> finite (Union (SetS a p))"
- by (auto simp add: SetS_finite SetS_elems_finite finite_Union)
-
-lemma card_setsum_aux: "[| finite S; \<forall>X \<in> S. finite (X::int set);
- \<forall>X \<in> S. card X = n |] ==> setsum card S = setsum (%x. n) S"
- by (induct set: finite) auto
-
-lemma SetS_card: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
- int(card(SetS a p)) = (p - 1) div 2"
-proof -
- assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and "~(QuadRes p a)"
- then have "(p - 1) = 2 * int(card(SetS a p))"
- proof -
- have "p - 1 = int(card(Union (SetS a p)))"
- by (auto simp add: prems MultInvPair_prop2 SRStar_card)
- also have "... = int (setsum card (SetS a p))"
- by (auto simp add: prems SetS_finite SetS_elems_finite
- MultInvPair_prop1c [of p a] card_Union_disjoint)
- also have "... = int(setsum (%x.2) (SetS a p))"
- using prems
- by (auto simp add: SetS_elems_card SetS_finite SetS_elems_finite
- card_setsum_aux simp del: setsum_constant)
- also have "... = 2 * int(card( SetS a p))"
- by (auto simp add: prems SetS_finite setsum_const2)
- finally show ?thesis .
- qed
- from this show ?thesis
- by auto
-qed
-
-lemma SetS_setprod_prop: "[| zprime p; 2 < p; ~([a = 0] (mod p));
- ~(QuadRes p a); x \<in> (SetS a p) |] ==>
- [\<Prod>x = a] (mod p)"
- apply (auto simp add: SetS_def MultInvPair_def)
- apply (frule StandardRes_SRStar_prop1a)
- apply (subgoal_tac "StandardRes p x \<noteq> StandardRes p (a * MultInv p x)")
- apply (auto simp add: StandardRes_prop2 MultInvPair_distinct)
- apply (frule_tac m = p and x = x and y = "(a * MultInv p x)" in
- StandardRes_prop4)
- apply (subgoal_tac "[x * (a * MultInv p x) = a * (x * MultInv p x)] (mod p)")
- apply (drule_tac a = "StandardRes p x * StandardRes p (a * MultInv p x)" and
- b = "x * (a * MultInv p x)" and
- c = "a * (x * MultInv p x)" in zcong_trans, force)
- apply (frule_tac p = p and x = x in MultInv_prop2, auto)
-apply (metis StandardRes_SRStar_prop3 mult_1_right mult_commute zcong_sym zcong_zmult_prop1)
- apply (auto simp add: zmult_ac)
- done
-
-lemma aux1: "[| 0 < x; (x::int) < a; x \<noteq> (a - 1) |] ==> x < a - 1"
- by arith
-
-lemma aux2: "[| (a::int) < c; b < c |] ==> (a \<le> b | b \<le> a)"
- by auto
-
-lemma SRStar_d22set_prop: "2 < p \<Longrightarrow> (SRStar p) = {1} \<union> (d22set (p - 1))"
- apply (induct p rule: d22set.induct)
- apply auto
- apply (simp add: SRStar_def d22set.simps)
- apply (simp add: SRStar_def d22set.simps, clarify)
- apply (frule aux1)
- apply (frule aux2, auto)
- apply (simp_all add: SRStar_def)
- apply (simp add: d22set.simps)
- apply (frule d22set_le)
- apply (frule d22set_g_1, auto)
- done
-
-lemma Union_SetS_setprod_prop1: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
- [\<Prod>(Union (SetS a p)) = a ^ nat ((p - 1) div 2)] (mod p)"
-proof -
- assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and "~(QuadRes p a)"
- then have "[\<Prod>(Union (SetS a p)) =
- setprod (setprod (%x. x)) (SetS a p)] (mod p)"
- by (auto simp add: SetS_finite SetS_elems_finite
- MultInvPair_prop1c setprod_Union_disjoint)
- also have "[setprod (setprod (%x. x)) (SetS a p) =
- setprod (%x. a) (SetS a p)] (mod p)"
- by (rule setprod_same_function_zcong)
- (auto simp add: prems SetS_setprod_prop SetS_finite)
- also (zcong_trans) have "[setprod (%x. a) (SetS a p) =
- a^(card (SetS a p))] (mod p)"
- by (auto simp add: prems SetS_finite setprod_constant)
- finally (zcong_trans) show ?thesis
- apply (rule zcong_trans)
- apply (subgoal_tac "card(SetS a p) = nat((p - 1) div 2)", auto)
- apply (subgoal_tac "nat(int(card(SetS a p))) = nat((p - 1) div 2)", force)
- apply (auto simp add: prems SetS_card)
- done
-qed
-
-lemma Union_SetS_setprod_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
- \<Prod>(Union (SetS a p)) = zfact (p - 1)"
-proof -
- assume "zprime p" and "2 < p" and "~([a = 0](mod p))"
- then have "\<Prod>(Union (SetS a p)) = \<Prod>(SRStar p)"
- by (auto simp add: MultInvPair_prop2)
- also have "... = \<Prod>({1} \<union> (d22set (p - 1)))"
- by (auto simp add: prems SRStar_d22set_prop)
- also have "... = zfact(p - 1)"
- proof -
- have "~(1 \<in> d22set (p - 1)) & finite( d22set (p - 1))"
- by (metis d22set_fin d22set_g_1 linorder_neq_iff)
- then have "\<Prod>({1} \<union> (d22set (p - 1))) = \<Prod>(d22set (p - 1))"
- by auto
- then show ?thesis
- by (auto simp add: d22set_prod_zfact)
- qed
- finally show ?thesis .
-qed
-
-lemma zfact_prop: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
- [zfact (p - 1) = a ^ nat ((p - 1) div 2)] (mod p)"
- apply (frule Union_SetS_setprod_prop1)
- apply (auto simp add: Union_SetS_setprod_prop2)
- done
-
-text {* \medskip Prove the first part of Euler's Criterion: *}
-
-lemma Euler_part1: "[| 2 < p; zprime p; ~([x = 0](mod p));
- ~(QuadRes p x) |] ==>
- [x^(nat (((p) - 1) div 2)) = -1](mod p)"
- by (metis Wilson_Russ number_of_is_id zcong_sym zcong_trans zfact_prop)
-
-text {* \medskip Prove another part of Euler Criterion: *}
-
-lemma aux_1: "0 < p ==> (a::int) ^ nat (p) = a * a ^ (nat (p) - 1)"
-proof -
- assume "0 < p"
- then have "a ^ (nat p) = a ^ (1 + (nat p - 1))"
- by (auto simp add: diff_add_assoc)
- also have "... = (a ^ 1) * a ^ (nat(p) - 1)"
- by (simp only: zpower_zadd_distrib)
- also have "... = a * a ^ (nat(p) - 1)"
- by auto
- finally show ?thesis .
-qed
-
-lemma aux_2: "[| (2::int) < p; p \<in> zOdd |] ==> 0 < ((p - 1) div 2)"
-proof -
- assume "2 < p" and "p \<in> zOdd"
- then have "(p - 1):zEven"
- by (auto simp add: zEven_def zOdd_def)
- then have aux_1: "2 * ((p - 1) div 2) = (p - 1)"
- by (auto simp add: even_div_2_prop2)
- with `2 < p` have "1 < (p - 1)"
- by auto
- then have " 1 < (2 * ((p - 1) div 2))"
- by (auto simp add: aux_1)
- then have "0 < (2 * ((p - 1) div 2)) div 2"
- by auto
- then show ?thesis by auto
-qed
-
-lemma Euler_part2:
- "[| 2 < p; zprime p; [a = 0] (mod p) |] ==> [0 = a ^ nat ((p - 1) div 2)] (mod p)"
- apply (frule zprime_zOdd_eq_grt_2)
- apply (frule aux_2, auto)
- apply (frule_tac a = a in aux_1, auto)
- apply (frule zcong_zmult_prop1, auto)
- done
-
-text {* \medskip Prove the final part of Euler's Criterion: *}
-
-lemma aux__1: "[| ~([x = 0] (mod p)); [y ^ 2 = x] (mod p)|] ==> ~(p dvd y)"
- by (metis dvdI power2_eq_square zcong_sym zcong_trans zcong_zero_equiv_div dvd_trans)
-
-lemma aux__2: "2 * nat((p - 1) div 2) = nat (2 * ((p - 1) div 2))"
- by (auto simp add: nat_mult_distrib)
-
-lemma Euler_part3: "[| 2 < p; zprime p; ~([x = 0](mod p)); QuadRes p x |] ==>
- [x^(nat (((p) - 1) div 2)) = 1](mod p)"
- apply (subgoal_tac "p \<in> zOdd")
- apply (auto simp add: QuadRes_def)
- prefer 2
- apply (metis number_of_is_id numeral_1_eq_1 zprime_zOdd_eq_grt_2)
- apply (frule aux__1, auto)
- apply (drule_tac z = "nat ((p - 1) div 2)" in zcong_zpower)
- apply (auto simp add: zpower_zpower)
- apply (rule zcong_trans)
- apply (auto simp add: zcong_sym [of "x ^ nat ((p - 1) div 2)"])
- apply (metis Little_Fermat even_div_2_prop2 mult_Bit0 number_of_is_id odd_minus_one_even one_is_num_one zmult_1 aux__2)
- done
-
-
-text {* \medskip Finally show Euler's Criterion: *}
-
-theorem Euler_Criterion: "[| 2 < p; zprime p |] ==> [(Legendre a p) =
- a^(nat (((p) - 1) div 2))] (mod p)"
- apply (auto simp add: Legendre_def Euler_part2)
- apply (frule Euler_part3, auto simp add: zcong_sym)[]
- apply (frule Euler_part1, auto simp add: zcong_sym)[]
- done
-
-end
--- a/src/HOL/NumberTheory/EulerFermat.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,348 +0,0 @@
-(* Title: HOL/NumberTheory/EulerFermat.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Fermat's Little Theorem extended to Euler's Totient function *}
-
-theory EulerFermat
-imports BijectionRel IntFact
-begin
-
-text {*
- Fermat's Little Theorem extended to Euler's Totient function. More
- abstract approach than Boyer-Moore (which seems necessary to achieve
- the extended version).
-*}
-
-
-subsection {* Definitions and lemmas *}
-
-inductive_set
- RsetR :: "int => int set set"
- for m :: int
- where
- empty [simp]: "{} \<in> RsetR m"
- | insert: "A \<in> RsetR m ==> zgcd a m = 1 ==>
- \<forall>a'. a' \<in> A --> \<not> zcong a a' m ==> insert a A \<in> RsetR m"
-
-consts
- BnorRset :: "int * int => int set"
-
-recdef BnorRset
- "measure ((\<lambda>(a, m). nat a) :: int * int => nat)"
- "BnorRset (a, m) =
- (if 0 < a then
- let na = BnorRset (a - 1, m)
- in (if zgcd a m = 1 then insert a na else na)
- else {})"
-
-definition
- norRRset :: "int => int set" where
- "norRRset m = BnorRset (m - 1, m)"
-
-definition
- noXRRset :: "int => int => int set" where
- "noXRRset m x = (\<lambda>a. a * x) ` norRRset m"
-
-definition
- phi :: "int => nat" where
- "phi m = card (norRRset m)"
-
-definition
- is_RRset :: "int set => int => bool" where
- "is_RRset A m = (A \<in> RsetR m \<and> card A = phi m)"
-
-definition
- RRset2norRR :: "int set => int => int => int" where
- "RRset2norRR A m a =
- (if 1 < m \<and> is_RRset A m \<and> a \<in> A then
- SOME b. zcong a b m \<and> b \<in> norRRset m
- else 0)"
-
-definition
- zcongm :: "int => int => int => bool" where
- "zcongm m = (\<lambda>a b. zcong a b m)"
-
-lemma abs_eq_1_iff [iff]: "(abs z = (1::int)) = (z = 1 \<or> z = -1)"
- -- {* LCP: not sure why this lemma is needed now *}
- by (auto simp add: abs_if)
-
-
-text {* \medskip @{text norRRset} *}
-
-declare BnorRset.simps [simp del]
-
-lemma BnorRset_induct:
- assumes "!!a m. P {} a m"
- and "!!a m. 0 < (a::int) ==> P (BnorRset (a - 1, m::int)) (a - 1) m
- ==> P (BnorRset(a,m)) a m"
- shows "P (BnorRset(u,v)) u v"
- apply (rule BnorRset.induct)
- apply safe
- apply (case_tac [2] "0 < a")
- apply (rule_tac [2] prems)
- apply simp_all
- apply (simp_all add: BnorRset.simps prems)
- done
-
-lemma Bnor_mem_zle [rule_format]: "b \<in> BnorRset (a, m) \<longrightarrow> b \<le> a"
- apply (induct a m rule: BnorRset_induct)
- apply simp
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma Bnor_mem_zle_swap: "a < b ==> b \<notin> BnorRset (a, m)"
- by (auto dest: Bnor_mem_zle)
-
-lemma Bnor_mem_zg [rule_format]: "b \<in> BnorRset (a, m) --> 0 < b"
- apply (induct a m rule: BnorRset_induct)
- prefer 2
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma Bnor_mem_if [rule_format]:
- "zgcd b m = 1 --> 0 < b --> b \<le> a --> b \<in> BnorRset (a, m)"
- apply (induct a m rule: BnorRset.induct, auto)
- apply (subst BnorRset.simps)
- defer
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma Bnor_in_RsetR [rule_format]: "a < m --> BnorRset (a, m) \<in> RsetR m"
- apply (induct a m rule: BnorRset_induct, simp)
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- apply (rule RsetR.insert)
- apply (rule_tac [3] allI)
- apply (rule_tac [3] impI)
- apply (rule_tac [3] zcong_not)
- apply (subgoal_tac [6] "a' \<le> a - 1")
- apply (rule_tac [7] Bnor_mem_zle)
- apply (rule_tac [5] Bnor_mem_zg, auto)
- done
-
-lemma Bnor_fin: "finite (BnorRset (a, m))"
- apply (induct a m rule: BnorRset_induct)
- prefer 2
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma norR_mem_unique_aux: "a \<le> b - 1 ==> a < (b::int)"
- apply auto
- done
-
-lemma norR_mem_unique:
- "1 < m ==>
- zgcd a m = 1 ==> \<exists>!b. [a = b] (mod m) \<and> b \<in> norRRset m"
- apply (unfold norRRset_def)
- apply (cut_tac a = a and m = m in zcong_zless_unique, auto)
- apply (rule_tac [2] m = m in zcong_zless_imp_eq)
- apply (auto intro: Bnor_mem_zle Bnor_mem_zg zcong_trans
- order_less_imp_le norR_mem_unique_aux simp add: zcong_sym)
- apply (rule_tac x = b in exI, safe)
- apply (rule Bnor_mem_if)
- apply (case_tac [2] "b = 0")
- apply (auto intro: order_less_le [THEN iffD2])
- prefer 2
- apply (simp only: zcong_def)
- apply (subgoal_tac "zgcd a m = m")
- prefer 2
- apply (subst zdvd_iff_zgcd [symmetric])
- apply (rule_tac [4] zgcd_zcong_zgcd)
- apply (simp_all add: zcong_sym)
- done
-
-
-text {* \medskip @{term noXRRset} *}
-
-lemma RRset_gcd [rule_format]:
- "is_RRset A m ==> a \<in> A --> zgcd a m = 1"
- apply (unfold is_RRset_def)
- apply (rule RsetR.induct [where P="%A. a \<in> A --> zgcd a m = 1"], auto)
- done
-
-lemma RsetR_zmult_mono:
- "A \<in> RsetR m ==>
- 0 < m ==> zgcd x m = 1 ==> (\<lambda>a. a * x) ` A \<in> RsetR m"
- apply (erule RsetR.induct, simp_all)
- apply (rule RsetR.insert, auto)
- apply (blast intro: zgcd_zgcd_zmult)
- apply (simp add: zcong_cancel)
- done
-
-lemma card_nor_eq_noX:
- "0 < m ==>
- zgcd x m = 1 ==> card (noXRRset m x) = card (norRRset m)"
- apply (unfold norRRset_def noXRRset_def)
- apply (rule card_image)
- apply (auto simp add: inj_on_def Bnor_fin)
- apply (simp add: BnorRset.simps)
- done
-
-lemma noX_is_RRset:
- "0 < m ==> zgcd x m = 1 ==> is_RRset (noXRRset m x) m"
- apply (unfold is_RRset_def phi_def)
- apply (auto simp add: card_nor_eq_noX)
- apply (unfold noXRRset_def norRRset_def)
- apply (rule RsetR_zmult_mono)
- apply (rule Bnor_in_RsetR, simp_all)
- done
-
-lemma aux_some:
- "1 < m ==> is_RRset A m ==> a \<in> A
- ==> zcong a (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) m \<and>
- (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) \<in> norRRset m"
- apply (rule norR_mem_unique [THEN ex1_implies_ex, THEN someI_ex])
- apply (rule_tac [2] RRset_gcd, simp_all)
- done
-
-lemma RRset2norRR_correct:
- "1 < m ==> is_RRset A m ==> a \<in> A ==>
- [a = RRset2norRR A m a] (mod m) \<and> RRset2norRR A m a \<in> norRRset m"
- apply (unfold RRset2norRR_def, simp)
- apply (rule aux_some, simp_all)
- done
-
-lemmas RRset2norRR_correct1 =
- RRset2norRR_correct [THEN conjunct1, standard]
-lemmas RRset2norRR_correct2 =
- RRset2norRR_correct [THEN conjunct2, standard]
-
-lemma RsetR_fin: "A \<in> RsetR m ==> finite A"
- by (induct set: RsetR) auto
-
-lemma RRset_zcong_eq [rule_format]:
- "1 < m ==>
- is_RRset A m ==> [a = b] (mod m) ==> a \<in> A --> b \<in> A --> a = b"
- apply (unfold is_RRset_def)
- apply (rule RsetR.induct [where P="%A. a \<in> A --> b \<in> A --> a = b"])
- apply (auto simp add: zcong_sym)
- done
-
-lemma aux:
- "P (SOME a. P a) ==> Q (SOME a. Q a) ==>
- (SOME a. P a) = (SOME a. Q a) ==> \<exists>a. P a \<and> Q a"
- apply auto
- done
-
-lemma RRset2norRR_inj:
- "1 < m ==> is_RRset A m ==> inj_on (RRset2norRR A m) A"
- apply (unfold RRset2norRR_def inj_on_def, auto)
- apply (subgoal_tac "\<exists>b. ([x = b] (mod m) \<and> b \<in> norRRset m) \<and>
- ([y = b] (mod m) \<and> b \<in> norRRset m)")
- apply (rule_tac [2] aux)
- apply (rule_tac [3] aux_some)
- apply (rule_tac [2] aux_some)
- apply (rule RRset_zcong_eq, auto)
- apply (rule_tac b = b in zcong_trans)
- apply (simp_all add: zcong_sym)
- done
-
-lemma RRset2norRR_eq_norR:
- "1 < m ==> is_RRset A m ==> RRset2norRR A m ` A = norRRset m"
- apply (rule card_seteq)
- prefer 3
- apply (subst card_image)
- apply (rule_tac RRset2norRR_inj, auto)
- apply (rule_tac [3] RRset2norRR_correct2, auto)
- apply (unfold is_RRset_def phi_def norRRset_def)
- apply (auto simp add: Bnor_fin)
- done
-
-
-lemma Bnor_prod_power_aux: "a \<notin> A ==> inj f ==> f a \<notin> f ` A"
-by (unfold inj_on_def, auto)
-
-lemma Bnor_prod_power [rule_format]:
- "x \<noteq> 0 ==> a < m --> \<Prod>((\<lambda>a. a * x) ` BnorRset (a, m)) =
- \<Prod>(BnorRset(a, m)) * x^card (BnorRset (a, m))"
- apply (induct a m rule: BnorRset_induct)
- prefer 2
- apply (simplesubst BnorRset.simps) --{*multiple redexes*}
- apply (unfold Let_def, auto)
- apply (simp add: Bnor_fin Bnor_mem_zle_swap)
- apply (subst setprod_insert)
- apply (rule_tac [2] Bnor_prod_power_aux)
- apply (unfold inj_on_def)
- apply (simp_all add: zmult_ac Bnor_fin finite_imageI
- Bnor_mem_zle_swap)
- done
-
-
-subsection {* Fermat *}
-
-lemma bijzcong_zcong_prod:
- "(A, B) \<in> bijR (zcongm m) ==> [\<Prod>A = \<Prod>B] (mod m)"
- apply (unfold zcongm_def)
- apply (erule bijR.induct)
- apply (subgoal_tac [2] "a \<notin> A \<and> b \<notin> B \<and> finite A \<and> finite B")
- apply (auto intro: fin_bijRl fin_bijRr zcong_zmult)
- done
-
-lemma Bnor_prod_zgcd [rule_format]:
- "a < m --> zgcd (\<Prod>(BnorRset(a, m))) m = 1"
- apply (induct a m rule: BnorRset_induct)
- prefer 2
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto)
- apply (simp add: Bnor_fin Bnor_mem_zle_swap)
- apply (blast intro: zgcd_zgcd_zmult)
- done
-
-theorem Euler_Fermat:
- "0 < m ==> zgcd x m = 1 ==> [x^(phi m) = 1] (mod m)"
- apply (unfold norRRset_def phi_def)
- apply (case_tac "x = 0")
- apply (case_tac [2] "m = 1")
- apply (rule_tac [3] iffD1)
- apply (rule_tac [3] k = "\<Prod>(BnorRset(m - 1, m))"
- in zcong_cancel2)
- prefer 5
- apply (subst Bnor_prod_power [symmetric])
- apply (rule_tac [7] Bnor_prod_zgcd, simp_all)
- apply (rule bijzcong_zcong_prod)
- apply (fold norRRset_def noXRRset_def)
- apply (subst RRset2norRR_eq_norR [symmetric])
- apply (rule_tac [3] inj_func_bijR, auto)
- apply (unfold zcongm_def)
- apply (rule_tac [2] RRset2norRR_correct1)
- apply (rule_tac [5] RRset2norRR_inj)
- apply (auto intro: order_less_le [THEN iffD2]
- simp add: noX_is_RRset)
- apply (unfold noXRRset_def norRRset_def)
- apply (rule finite_imageI)
- apply (rule Bnor_fin)
- done
-
-lemma Bnor_prime:
- "\<lbrakk> zprime p; a < p \<rbrakk> \<Longrightarrow> card (BnorRset (a, p)) = nat a"
- apply (induct a p rule: BnorRset.induct)
- apply (subst BnorRset.simps)
- apply (unfold Let_def, auto simp add:zless_zprime_imp_zrelprime)
- apply (subgoal_tac "finite (BnorRset (a - 1,m))")
- apply (subgoal_tac "a ~: BnorRset (a - 1,m)")
- apply (auto simp add: card_insert_disjoint Suc_nat_eq_nat_zadd1)
- apply (frule Bnor_mem_zle, arith)
- apply (frule Bnor_fin)
- done
-
-lemma phi_prime: "zprime p ==> phi p = nat (p - 1)"
- apply (unfold phi_def norRRset_def)
- apply (rule Bnor_prime, auto)
- done
-
-theorem Little_Fermat:
- "zprime p ==> \<not> p dvd x ==> [x^(nat (p - 1)) = 1] (mod p)"
- apply (subst phi_prime [symmetric])
- apply (rule_tac [2] Euler_Fermat)
- apply (erule_tac [3] zprime_imp_zrelprime)
- apply (unfold zprime_def, auto)
- done
-
-end
--- a/src/HOL/NumberTheory/EvenOdd.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,256 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/EvenOdd.thy
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {*Parity: Even and Odd Integers*}
-
-theory EvenOdd
-imports Int2
-begin
-
-definition
- zOdd :: "int set" where
- "zOdd = {x. \<exists>k. x = 2 * k + 1}"
-
-definition
- zEven :: "int set" where
- "zEven = {x. \<exists>k. x = 2 * k}"
-
-subsection {* Some useful properties about even and odd *}
-
-lemma zOddI [intro?]: "x = 2 * k + 1 \<Longrightarrow> x \<in> zOdd"
- and zOddE [elim?]: "x \<in> zOdd \<Longrightarrow> (!!k. x = 2 * k + 1 \<Longrightarrow> C) \<Longrightarrow> C"
- by (auto simp add: zOdd_def)
-
-lemma zEvenI [intro?]: "x = 2 * k \<Longrightarrow> x \<in> zEven"
- and zEvenE [elim?]: "x \<in> zEven \<Longrightarrow> (!!k. x = 2 * k \<Longrightarrow> C) \<Longrightarrow> C"
- by (auto simp add: zEven_def)
-
-lemma one_not_even: "~(1 \<in> zEven)"
-proof
- assume "1 \<in> zEven"
- then obtain k :: int where "1 = 2 * k" ..
- then show False by arith
-qed
-
-lemma even_odd_conj: "~(x \<in> zOdd & x \<in> zEven)"
-proof -
- {
- fix a b
- assume "2 * (a::int) = 2 * (b::int) + 1"
- then have "2 * (a::int) - 2 * (b :: int) = 1"
- by arith
- then have "2 * (a - b) = 1"
- by (auto simp add: zdiff_zmult_distrib)
- moreover have "(2 * (a - b)):zEven"
- by (auto simp only: zEven_def)
- ultimately have False
- by (auto simp add: one_not_even)
- }
- then show ?thesis
- by (auto simp add: zOdd_def zEven_def)
-qed
-
-lemma even_odd_disj: "(x \<in> zOdd | x \<in> zEven)"
- by (simp add: zOdd_def zEven_def) arith
-
-lemma not_odd_impl_even: "~(x \<in> zOdd) ==> x \<in> zEven"
- using even_odd_disj by auto
-
-lemma odd_mult_odd_prop: "(x*y):zOdd ==> x \<in> zOdd"
-proof (rule classical)
- assume "\<not> ?thesis"
- then have "x \<in> zEven" by (rule not_odd_impl_even)
- then obtain a where a: "x = 2 * a" ..
- assume "x * y : zOdd"
- then obtain b where "x * y = 2 * b + 1" ..
- with a have "2 * a * y = 2 * b + 1" by simp
- then have "2 * a * y - 2 * b = 1"
- by arith
- then have "2 * (a * y - b) = 1"
- by (auto simp add: zdiff_zmult_distrib)
- moreover have "(2 * (a * y - b)):zEven"
- by (auto simp only: zEven_def)
- ultimately have False
- by (auto simp add: one_not_even)
- then show ?thesis ..
-qed
-
-lemma odd_minus_one_even: "x \<in> zOdd ==> (x - 1):zEven"
- by (auto simp add: zOdd_def zEven_def)
-
-lemma even_div_2_prop1: "x \<in> zEven ==> (x mod 2) = 0"
- by (auto simp add: zEven_def)
-
-lemma even_div_2_prop2: "x \<in> zEven ==> (2 * (x div 2)) = x"
- by (auto simp add: zEven_def)
-
-lemma even_plus_even: "[| x \<in> zEven; y \<in> zEven |] ==> x + y \<in> zEven"
- apply (auto simp add: zEven_def)
- apply (auto simp only: zadd_zmult_distrib2 [symmetric])
- done
-
-lemma even_times_either: "x \<in> zEven ==> x * y \<in> zEven"
- by (auto simp add: zEven_def)
-
-lemma even_minus_even: "[| x \<in> zEven; y \<in> zEven |] ==> x - y \<in> zEven"
- apply (auto simp add: zEven_def)
- apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
- done
-
-lemma odd_minus_odd: "[| x \<in> zOdd; y \<in> zOdd |] ==> x - y \<in> zEven"
- apply (auto simp add: zOdd_def zEven_def)
- apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
- done
-
-lemma even_minus_odd: "[| x \<in> zEven; y \<in> zOdd |] ==> x - y \<in> zOdd"
- apply (auto simp add: zOdd_def zEven_def)
- apply (rule_tac x = "k - ka - 1" in exI)
- apply auto
- done
-
-lemma odd_minus_even: "[| x \<in> zOdd; y \<in> zEven |] ==> x - y \<in> zOdd"
- apply (auto simp add: zOdd_def zEven_def)
- apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
- done
-
-lemma odd_times_odd: "[| x \<in> zOdd; y \<in> zOdd |] ==> x * y \<in> zOdd"
- apply (auto simp add: zOdd_def zadd_zmult_distrib zadd_zmult_distrib2)
- apply (rule_tac x = "2 * ka * k + ka + k" in exI)
- apply (auto simp add: zadd_zmult_distrib)
- done
-
-lemma odd_iff_not_even: "(x \<in> zOdd) = (~ (x \<in> zEven))"
- using even_odd_conj even_odd_disj by auto
-
-lemma even_product: "x * y \<in> zEven ==> x \<in> zEven | y \<in> zEven"
- using odd_iff_not_even odd_times_odd by auto
-
-lemma even_diff: "x - y \<in> zEven = ((x \<in> zEven) = (y \<in> zEven))"
-proof
- assume xy: "x - y \<in> zEven"
- {
- assume x: "x \<in> zEven"
- have "y \<in> zEven"
- proof (rule classical)
- assume "\<not> ?thesis"
- then have "y \<in> zOdd"
- by (simp add: odd_iff_not_even)
- with x have "x - y \<in> zOdd"
- by (simp add: even_minus_odd)
- with xy have False
- by (auto simp add: odd_iff_not_even)
- then show ?thesis ..
- qed
- } moreover {
- assume y: "y \<in> zEven"
- have "x \<in> zEven"
- proof (rule classical)
- assume "\<not> ?thesis"
- then have "x \<in> zOdd"
- by (auto simp add: odd_iff_not_even)
- with y have "x - y \<in> zOdd"
- by (simp add: odd_minus_even)
- with xy have False
- by (auto simp add: odd_iff_not_even)
- then show ?thesis ..
- qed
- }
- ultimately show "(x \<in> zEven) = (y \<in> zEven)"
- by (auto simp add: odd_iff_not_even even_minus_even odd_minus_odd
- even_minus_odd odd_minus_even)
-next
- assume "(x \<in> zEven) = (y \<in> zEven)"
- then show "x - y \<in> zEven"
- by (auto simp add: odd_iff_not_even even_minus_even odd_minus_odd
- even_minus_odd odd_minus_even)
-qed
-
-lemma neg_one_even_power: "[| x \<in> zEven; 0 \<le> x |] ==> (-1::int)^(nat x) = 1"
-proof -
- assume "x \<in> zEven" and "0 \<le> x"
- from `x \<in> zEven` obtain a where "x = 2 * a" ..
- with `0 \<le> x` have "0 \<le> a" by simp
- from `0 \<le> x` and `x = 2 * a` have "nat x = nat (2 * a)"
- by simp
- also from `x = 2 * a` have "nat (2 * a) = 2 * nat a"
- by (simp add: nat_mult_distrib)
- finally have "(-1::int)^nat x = (-1)^(2 * nat a)"
- by simp
- also have "... = ((-1::int)^2)^ (nat a)"
- by (simp add: zpower_zpower [symmetric])
- also have "(-1::int)^2 = 1"
- by simp
- finally show ?thesis
- by simp
-qed
-
-lemma neg_one_odd_power: "[| x \<in> zOdd; 0 \<le> x |] ==> (-1::int)^(nat x) = -1"
-proof -
- assume "x \<in> zOdd" and "0 \<le> x"
- from `x \<in> zOdd` obtain a where "x = 2 * a + 1" ..
- with `0 \<le> x` have a: "0 \<le> a" by simp
- with `0 \<le> x` and `x = 2 * a + 1` have "nat x = nat (2 * a + 1)"
- by simp
- also from a have "nat (2 * a + 1) = 2 * nat a + 1"
- by (auto simp add: nat_mult_distrib nat_add_distrib)
- finally have "(-1::int)^nat x = (-1)^(2 * nat a + 1)"
- by simp
- also have "... = ((-1::int)^2)^ (nat a) * (-1)^1"
- by (auto simp add: zpower_zpower [symmetric] zpower_zadd_distrib)
- also have "(-1::int)^2 = 1"
- by simp
- finally show ?thesis
- by simp
-qed
-
-lemma neg_one_power_parity: "[| 0 \<le> x; 0 \<le> y; (x \<in> zEven) = (y \<in> zEven) |] ==>
- (-1::int)^(nat x) = (-1::int)^(nat y)"
- using even_odd_disj [of x] even_odd_disj [of y]
- by (auto simp add: neg_one_even_power neg_one_odd_power)
-
-
-lemma one_not_neg_one_mod_m: "2 < m ==> ~([1 = -1] (mod m))"
- by (auto simp add: zcong_def zdvd_not_zless)
-
-lemma even_div_2_l: "[| y \<in> zEven; x < y |] ==> x div 2 < y div 2"
-proof -
- assume "y \<in> zEven" and "x < y"
- from `y \<in> zEven` obtain k where k: "y = 2 * k" ..
- with `x < y` have "x < 2 * k" by simp
- then have "x div 2 < k" by (auto simp add: div_prop1)
- also have "k = (2 * k) div 2" by simp
- finally have "x div 2 < 2 * k div 2" by simp
- with k show ?thesis by simp
-qed
-
-lemma even_sum_div_2: "[| x \<in> zEven; y \<in> zEven |] ==> (x + y) div 2 = x div 2 + y div 2"
- by (auto simp add: zEven_def)
-
-lemma even_prod_div_2: "[| x \<in> zEven |] ==> (x * y) div 2 = (x div 2) * y"
- by (auto simp add: zEven_def)
-
-(* An odd prime is greater than 2 *)
-
-lemma zprime_zOdd_eq_grt_2: "zprime p ==> (p \<in> zOdd) = (2 < p)"
- apply (auto simp add: zOdd_def zprime_def)
- apply (drule_tac x = 2 in allE)
- using odd_iff_not_even [of p]
- apply (auto simp add: zOdd_def zEven_def)
- done
-
-(* Powers of -1 and parity *)
-
-lemma neg_one_special: "finite A ==>
- ((-1 :: int) ^ card A) * (-1 ^ card A) = 1"
- by (induct set: finite) auto
-
-lemma neg_one_power: "(-1::int)^n = 1 | (-1::int)^n = -1"
- by (induct n) auto
-
-lemma neg_one_power_eq_mod_m: "[| 2 < m; [(-1::int)^j = (-1::int)^k] (mod m) |]
- ==> ((-1::int)^j = (-1::int)^k)"
- using neg_one_power [of j] and ListMem.insert neg_one_power [of k]
- by (auto simp add: one_not_neg_one_mod_m zcong_sym)
-
-end
--- a/src/HOL/NumberTheory/Factorization.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,341 +0,0 @@
-(* Title: HOL/NumberTheory/Factorization.thy
- ID: $Id$
- Author: Thomas Marthedal Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Fundamental Theorem of Arithmetic (unique factorization into primes) *}
-
-theory Factorization
-imports Main Primes Permutation
-begin
-
-
-subsection {* Definitions *}
-
-definition
- primel :: "nat list => bool" where
- "primel xs = (\<forall>p \<in> set xs. prime p)"
-
-consts
- nondec :: "nat list => bool "
- prod :: "nat list => nat"
- oinsert :: "nat => nat list => nat list"
- sort :: "nat list => nat list"
-
-primrec
- "nondec [] = True"
- "nondec (x # xs) = (case xs of [] => True | y # ys => x \<le> y \<and> nondec xs)"
-
-primrec
- "prod [] = Suc 0"
- "prod (x # xs) = x * prod xs"
-
-primrec
- "oinsert x [] = [x]"
- "oinsert x (y # ys) = (if x \<le> y then x # y # ys else y # oinsert x ys)"
-
-primrec
- "sort [] = []"
- "sort (x # xs) = oinsert x (sort xs)"
-
-
-subsection {* Arithmetic *}
-
-lemma one_less_m: "(m::nat) \<noteq> m * k ==> m \<noteq> Suc 0 ==> Suc 0 < m"
- apply (cases m)
- apply auto
- done
-
-lemma one_less_k: "(m::nat) \<noteq> m * k ==> Suc 0 < m * k ==> Suc 0 < k"
- apply (cases k)
- apply auto
- done
-
-lemma mult_left_cancel: "(0::nat) < k ==> k * n = k * m ==> n = m"
- apply auto
- done
-
-lemma mn_eq_m_one: "(0::nat) < m ==> m * n = m ==> n = Suc 0"
- apply (cases n)
- apply auto
- done
-
-lemma prod_mn_less_k:
- "(0::nat) < n ==> 0 < k ==> Suc 0 < m ==> m * n = k ==> n < k"
- apply (induct m)
- apply auto
- done
-
-
-subsection {* Prime list and product *}
-
-lemma prod_append: "prod (xs @ ys) = prod xs * prod ys"
- apply (induct xs)
- apply (simp_all add: mult_assoc)
- done
-
-lemma prod_xy_prod:
- "prod (x # xs) = prod (y # ys) ==> x * prod xs = y * prod ys"
- apply auto
- done
-
-lemma primel_append: "primel (xs @ ys) = (primel xs \<and> primel ys)"
- apply (unfold primel_def)
- apply auto
- done
-
-lemma prime_primel: "prime n ==> primel [n] \<and> prod [n] = n"
- apply (unfold primel_def)
- apply auto
- done
-
-lemma prime_nd_one: "prime p ==> \<not> p dvd Suc 0"
- apply (unfold prime_def dvd_def)
- apply auto
- done
-
-lemma hd_dvd_prod: "prod (x # xs) = prod ys ==> x dvd (prod ys)"
- by (metis dvd_mult_left dvd_refl prod.simps(2))
-
-lemma primel_tl: "primel (x # xs) ==> primel xs"
- apply (unfold primel_def)
- apply auto
- done
-
-lemma primel_hd_tl: "(primel (x # xs)) = (prime x \<and> primel xs)"
- apply (unfold primel_def)
- apply auto
- done
-
-lemma primes_eq: "prime p ==> prime q ==> p dvd q ==> p = q"
- apply (unfold prime_def)
- apply auto
- done
-
-lemma primel_one_empty: "primel xs ==> prod xs = Suc 0 ==> xs = []"
- apply (cases xs)
- apply (simp_all add: primel_def prime_def)
- done
-
-lemma prime_g_one: "prime p ==> Suc 0 < p"
- apply (unfold prime_def)
- apply auto
- done
-
-lemma prime_g_zero: "prime p ==> 0 < p"
- apply (unfold prime_def)
- apply auto
- done
-
-lemma primel_nempty_g_one:
- "primel xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> Suc 0 < prod xs"
- apply (induct xs)
- apply simp
- apply (fastsimp simp: primel_def prime_def elim: one_less_mult)
- done
-
-lemma primel_prod_gz: "primel xs ==> 0 < prod xs"
- apply (induct xs)
- apply (auto simp: primel_def prime_def)
- done
-
-
-subsection {* Sorting *}
-
-lemma nondec_oinsert: "nondec xs \<Longrightarrow> nondec (oinsert x xs)"
- apply (induct xs)
- apply simp
- apply (case_tac xs)
- apply (simp_all cong del: list.weak_case_cong)
- done
-
-lemma nondec_sort: "nondec (sort xs)"
- apply (induct xs)
- apply simp_all
- apply (erule nondec_oinsert)
- done
-
-lemma x_less_y_oinsert: "x \<le> y ==> l = y # ys ==> x # l = oinsert x l"
- apply simp_all
- done
-
-lemma nondec_sort_eq [rule_format]: "nondec xs \<longrightarrow> xs = sort xs"
- apply (induct xs)
- apply safe
- apply simp_all
- apply (case_tac xs)
- apply simp_all
- apply (case_tac xs)
- apply simp
- apply (rule_tac y = aa and ys = list in x_less_y_oinsert)
- apply simp_all
- done
-
-lemma oinsert_x_y: "oinsert x (oinsert y l) = oinsert y (oinsert x l)"
- apply (induct l)
- apply auto
- done
-
-
-subsection {* Permutation *}
-
-lemma perm_primel [rule_format]: "xs <~~> ys ==> primel xs --> primel ys"
- apply (unfold primel_def)
- apply (induct set: perm)
- apply simp
- apply simp
- apply (simp (no_asm))
- apply blast
- apply blast
- done
-
-lemma perm_prod: "xs <~~> ys ==> prod xs = prod ys"
- apply (induct set: perm)
- apply (simp_all add: mult_ac)
- done
-
-lemma perm_subst_oinsert: "xs <~~> ys ==> oinsert a xs <~~> oinsert a ys"
- apply (induct set: perm)
- apply auto
- done
-
-lemma perm_oinsert: "x # xs <~~> oinsert x xs"
- apply (induct xs)
- apply auto
- done
-
-lemma perm_sort: "xs <~~> sort xs"
- apply (induct xs)
- apply (auto intro: perm_oinsert elim: perm_subst_oinsert)
- done
-
-lemma perm_sort_eq: "xs <~~> ys ==> sort xs = sort ys"
- apply (induct set: perm)
- apply (simp_all add: oinsert_x_y)
- done
-
-
-subsection {* Existence *}
-
-lemma ex_nondec_lemma:
- "primel xs ==> \<exists>ys. primel ys \<and> nondec ys \<and> prod ys = prod xs"
- apply (blast intro: nondec_sort perm_prod perm_primel perm_sort perm_sym)
- done
-
-lemma not_prime_ex_mk:
- "Suc 0 < n \<and> \<not> prime n ==>
- \<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
- apply (unfold prime_def dvd_def)
- apply (auto intro: n_less_m_mult_n n_less_n_mult_m one_less_m one_less_k)
- done
-
-lemma split_primel:
- "primel xs \<Longrightarrow> primel ys \<Longrightarrow> \<exists>l. primel l \<and> prod l = prod xs * prod ys"
- apply (rule exI)
- apply safe
- apply (rule_tac [2] prod_append)
- apply (simp add: primel_append)
- done
-
-lemma factor_exists [rule_format]: "Suc 0 < n --> (\<exists>l. primel l \<and> prod l = n)"
- apply (induct n rule: nat_less_induct)
- apply (rule impI)
- apply (case_tac "prime n")
- apply (rule exI)
- apply (erule prime_primel)
- apply (cut_tac n = n in not_prime_ex_mk)
- apply (auto intro!: split_primel)
- done
-
-lemma nondec_factor_exists: "Suc 0 < n ==> \<exists>l. primel l \<and> nondec l \<and> prod l = n"
- apply (erule factor_exists [THEN exE])
- apply (blast intro!: ex_nondec_lemma)
- done
-
-
-subsection {* Uniqueness *}
-
-lemma prime_dvd_mult_list [rule_format]:
- "prime p ==> p dvd (prod xs) --> (\<exists>m. m:set xs \<and> p dvd m)"
- apply (induct xs)
- apply (force simp add: prime_def)
- apply (force dest: prime_dvd_mult)
- done
-
-lemma hd_xs_dvd_prod:
- "primel (x # xs) ==> primel ys ==> prod (x # xs) = prod ys
- ==> \<exists>m. m \<in> set ys \<and> x dvd m"
- apply (rule prime_dvd_mult_list)
- apply (simp add: primel_hd_tl)
- apply (erule hd_dvd_prod)
- done
-
-lemma prime_dvd_eq: "primel (x # xs) ==> primel ys ==> m \<in> set ys ==> x dvd m ==> x = m"
- apply (rule primes_eq)
- apply (auto simp add: primel_def primel_hd_tl)
- done
-
-lemma hd_xs_eq_prod:
- "primel (x # xs) ==>
- primel ys ==> prod (x # xs) = prod ys ==> x \<in> set ys"
- apply (frule hd_xs_dvd_prod)
- apply auto
- apply (drule prime_dvd_eq)
- apply auto
- done
-
-lemma perm_primel_ex:
- "primel (x # xs) ==>
- primel ys ==> prod (x # xs) = prod ys ==> \<exists>l. ys <~~> (x # l)"
- apply (rule exI)
- apply (rule perm_remove)
- apply (erule hd_xs_eq_prod)
- apply simp_all
- done
-
-lemma primel_prod_less:
- "primel (x # xs) ==>
- primel ys ==> prod (x # xs) = prod ys ==> prod xs < prod ys"
- by (metis less_asym linorder_neqE_nat mult_less_cancel2 nat_0_less_mult_iff
- nat_less_le nat_mult_1 prime_def primel_hd_tl primel_prod_gz prod.simps(2))
-
-lemma prod_one_empty:
- "primel xs ==> p * prod xs = p ==> prime p ==> xs = []"
- apply (auto intro: primel_one_empty simp add: prime_def)
- done
-
-lemma uniq_ex_aux:
- "\<forall>m. m < prod ys --> (\<forall>xs ys. primel xs \<and> primel ys \<and>
- prod xs = prod ys \<and> prod xs = m --> xs <~~> ys) ==>
- primel list ==> primel x ==> prod list = prod x ==> prod x < prod ys
- ==> x <~~> list"
- apply simp
- done
-
-lemma factor_unique [rule_format]:
- "\<forall>xs ys. primel xs \<and> primel ys \<and> prod xs = prod ys \<and> prod xs = n
- --> xs <~~> ys"
- apply (induct n rule: nat_less_induct)
- apply safe
- apply (case_tac xs)
- apply (force intro: primel_one_empty)
- apply (rule perm_primel_ex [THEN exE])
- apply simp_all
- apply (rule perm.trans [THEN perm_sym])
- apply assumption
- apply (rule perm.Cons)
- apply (case_tac "x = []")
- apply (metis perm_prod perm_refl prime_primel primel_hd_tl primel_tl prod_one_empty)
- apply (metis nat_0_less_mult_iff nat_mult_eq_cancel1 perm_primel perm_prod primel_prod_gz primel_prod_less primel_tl prod.simps(2))
- done
-
-lemma perm_nondec_unique:
- "xs <~~> ys ==> nondec xs ==> nondec ys ==> xs = ys"
- by (metis nondec_sort_eq perm_sort_eq)
-
-theorem unique_prime_factorization [rule_format]:
- "\<forall>n. Suc 0 < n --> (\<exists>!l. primel l \<and> nondec l \<and> prod l = n)"
- by (metis factor_unique nondec_factor_exists perm_nondec_unique)
-
-end
--- a/src/HOL/NumberTheory/Fib.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,150 +0,0 @@
-(* ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1997 University of Cambridge
-*)
-
-header {* The Fibonacci function *}
-
-theory Fib
-imports Primes
-begin
-
-text {*
- Fibonacci numbers: proofs of laws taken from:
- R. L. Graham, D. E. Knuth, O. Patashnik. Concrete Mathematics.
- (Addison-Wesley, 1989)
-
- \bigskip
-*}
-
-fun fib :: "nat \<Rightarrow> nat"
-where
- "fib 0 = 0"
-| "fib (Suc 0) = 1"
-| fib_2: "fib (Suc (Suc n)) = fib n + fib (Suc n)"
-
-text {*
- \medskip The difficulty in these proofs is to ensure that the
- induction hypotheses are applied before the definition of @{term
- fib}. Towards this end, the @{term fib} equations are not declared
- to the Simplifier and are applied very selectively at first.
-*}
-
-text{*We disable @{text fib.fib_2fib_2} for simplification ...*}
-declare fib_2 [simp del]
-
-text{*...then prove a version that has a more restrictive pattern.*}
-lemma fib_Suc3: "fib (Suc (Suc (Suc n))) = fib (Suc n) + fib (Suc (Suc n))"
- by (rule fib_2)
-
-text {* \medskip Concrete Mathematics, page 280 *}
-
-lemma fib_add: "fib (Suc (n + k)) = fib (Suc k) * fib (Suc n) + fib k * fib n"
-proof (induct n rule: fib.induct)
- case 1 show ?case by simp
-next
- case 2 show ?case by (simp add: fib_2)
-next
- case 3 thus ?case by (simp add: fib_2 add_mult_distrib2)
-qed
-
-lemma fib_Suc_neq_0: "fib (Suc n) \<noteq> 0"
- apply (induct n rule: fib.induct)
- apply (simp_all add: fib_2)
- done
-
-lemma fib_Suc_gr_0: "0 < fib (Suc n)"
- by (insert fib_Suc_neq_0 [of n], simp)
-
-lemma fib_gr_0: "0 < n ==> 0 < fib n"
- by (case_tac n, auto simp add: fib_Suc_gr_0)
-
-
-text {*
- \medskip Concrete Mathematics, page 278: Cassini's identity. The proof is
- much easier using integers, not natural numbers!
-*}
-
-lemma fib_Cassini_int:
- "int (fib (Suc (Suc n)) * fib n) =
- (if n mod 2 = 0 then int (fib (Suc n) * fib (Suc n)) - 1
- else int (fib (Suc n) * fib (Suc n)) + 1)"
-proof(induct n rule: fib.induct)
- case 1 thus ?case by (simp add: fib_2)
-next
- case 2 thus ?case by (simp add: fib_2 mod_Suc)
-next
- case (3 x)
- have "Suc 0 \<noteq> x mod 2 \<longrightarrow> x mod 2 = 0" by presburger
- with "3.hyps" show ?case by (simp add: fib.simps add_mult_distrib add_mult_distrib2)
-qed
-
-text{*We now obtain a version for the natural numbers via the coercion
- function @{term int}.*}
-theorem fib_Cassini:
- "fib (Suc (Suc n)) * fib n =
- (if n mod 2 = 0 then fib (Suc n) * fib (Suc n) - 1
- else fib (Suc n) * fib (Suc n) + 1)"
- apply (rule int_int_eq [THEN iffD1])
- apply (simp add: fib_Cassini_int)
- apply (subst zdiff_int [symmetric])
- apply (insert fib_Suc_gr_0 [of n], simp_all)
- done
-
-
-text {* \medskip Toward Law 6.111 of Concrete Mathematics *}
-
-lemma gcd_fib_Suc_eq_1: "gcd (fib n) (fib (Suc n)) = Suc 0"
- apply (induct n rule: fib.induct)
- prefer 3
- apply (simp add: gcd_commute fib_Suc3)
- apply (simp_all add: fib_2)
- done
-
-lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
- apply (simp add: gcd_commute [of "fib m"])
- apply (case_tac m)
- apply simp
- apply (simp add: fib_add)
- apply (simp add: add_commute gcd_non_0 [OF fib_Suc_gr_0])
- apply (simp add: gcd_non_0 [OF fib_Suc_gr_0, symmetric])
- apply (simp add: gcd_fib_Suc_eq_1 gcd_mult_cancel)
- done
-
-lemma gcd_fib_diff: "m \<le> n ==> gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
- by (simp add: gcd_fib_add [symmetric, of _ "n-m"])
-
-lemma gcd_fib_mod: "0 < m ==> gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
-proof (induct n rule: less_induct)
- case (less n)
- from less.prems have pos_m: "0 < m" .
- show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
- proof (cases "m < n")
- case True note m_n = True
- then have m_n': "m \<le> n" by auto
- with pos_m have pos_n: "0 < n" by auto
- with pos_m m_n have diff: "n - m < n" by auto
- have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
- by (simp add: mod_if [of n]) (insert m_n, auto)
- also have "\<dots> = gcd (fib m) (fib (n - m))" by (simp add: less.hyps diff pos_m)
- also have "\<dots> = gcd (fib m) (fib n)" by (simp add: gcd_fib_diff m_n')
- finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
- next
- case False then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
- by (cases "m = n") auto
- qed
-qed
-
-lemma fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)" -- {* Law 6.111 *}
- apply (induct m n rule: gcd_induct)
- apply (simp_all add: gcd_non_0 gcd_commute gcd_fib_mod)
- done
-
-theorem fib_mult_eq_setsum:
- "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
- apply (induct n rule: fib.induct)
- apply (auto simp add: atMost_Suc fib_2)
- apply (simp add: add_mult_distrib add_mult_distrib2)
- done
-
-end
--- a/src/HOL/NumberTheory/Finite2.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,223 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/Finite2.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {*Finite Sets and Finite Sums*}
-
-theory Finite2
-imports Main IntFact Infinite_Set
-begin
-
-text{*
- These are useful for combinatorial and number-theoretic counting
- arguments.
-*}
-
-
-subsection {* Useful properties of sums and products *}
-
-lemma setsum_same_function_zcong:
- assumes a: "\<forall>x \<in> S. [f x = g x](mod m)"
- shows "[setsum f S = setsum g S] (mod m)"
-proof cases
- assume "finite S"
- thus ?thesis using a by induct (simp_all add: zcong_zadd)
-next
- assume "infinite S" thus ?thesis by(simp add:setsum_def)
-qed
-
-lemma setprod_same_function_zcong:
- assumes a: "\<forall>x \<in> S. [f x = g x](mod m)"
- shows "[setprod f S = setprod g S] (mod m)"
-proof cases
- assume "finite S"
- thus ?thesis using a by induct (simp_all add: zcong_zmult)
-next
- assume "infinite S" thus ?thesis by(simp add:setprod_def)
-qed
-
-lemma setsum_const: "finite X ==> setsum (%x. (c :: int)) X = c * int(card X)"
- apply (induct set: finite)
- apply (auto simp add: left_distrib right_distrib int_eq_of_nat)
- done
-
-lemma setsum_const2: "finite X ==> int (setsum (%x. (c :: nat)) X) =
- int(c) * int(card X)"
- apply (induct set: finite)
- apply (auto simp add: zadd_zmult_distrib2)
- done
-
-lemma setsum_const_mult: "finite A ==> setsum (%x. c * ((f x)::int)) A =
- c * setsum f A"
- by (induct set: finite) (auto simp add: zadd_zmult_distrib2)
-
-
-subsection {* Cardinality of explicit finite sets *}
-
-lemma finite_surjI: "[| B \<subseteq> f ` A; finite A |] ==> finite B"
- by (simp add: finite_subset finite_imageI)
-
-lemma bdd_nat_set_l_finite: "finite {y::nat . y < x}"
- by (rule bounded_nat_set_is_finite) blast
-
-lemma bdd_nat_set_le_finite: "finite {y::nat . y \<le> x}"
-proof -
- have "{y::nat . y \<le> x} = {y::nat . y < Suc x}" by auto
- then show ?thesis by (auto simp add: bdd_nat_set_l_finite)
-qed
-
-lemma bdd_int_set_l_finite: "finite {x::int. 0 \<le> x & x < n}"
- apply (subgoal_tac " {(x :: int). 0 \<le> x & x < n} \<subseteq>
- int ` {(x :: nat). x < nat n}")
- apply (erule finite_surjI)
- apply (auto simp add: bdd_nat_set_l_finite image_def)
- apply (rule_tac x = "nat x" in exI, simp)
- done
-
-lemma bdd_int_set_le_finite: "finite {x::int. 0 \<le> x & x \<le> n}"
- apply (subgoal_tac "{x. 0 \<le> x & x \<le> n} = {x. 0 \<le> x & x < n + 1}")
- apply (erule ssubst)
- apply (rule bdd_int_set_l_finite)
- apply auto
- done
-
-lemma bdd_int_set_l_l_finite: "finite {x::int. 0 < x & x < n}"
-proof -
- have "{x::int. 0 < x & x < n} \<subseteq> {x::int. 0 \<le> x & x < n}"
- by auto
- then show ?thesis by (auto simp add: bdd_int_set_l_finite finite_subset)
-qed
-
-lemma bdd_int_set_l_le_finite: "finite {x::int. 0 < x & x \<le> n}"
-proof -
- have "{x::int. 0 < x & x \<le> n} \<subseteq> {x::int. 0 \<le> x & x \<le> n}"
- by auto
- then show ?thesis by (auto simp add: bdd_int_set_le_finite finite_subset)
-qed
-
-lemma card_bdd_nat_set_l: "card {y::nat . y < x} = x"
-proof (induct x)
- case 0
- show "card {y::nat . y < 0} = 0" by simp
-next
- case (Suc n)
- have "{y. y < Suc n} = insert n {y. y < n}"
- by auto
- then have "card {y. y < Suc n} = card (insert n {y. y < n})"
- by auto
- also have "... = Suc (card {y. y < n})"
- by (rule card_insert_disjoint) (auto simp add: bdd_nat_set_l_finite)
- finally show "card {y. y < Suc n} = Suc n"
- using `card {y. y < n} = n` by simp
-qed
-
-lemma card_bdd_nat_set_le: "card { y::nat. y \<le> x} = Suc x"
-proof -
- have "{y::nat. y \<le> x} = { y::nat. y < Suc x}"
- by auto
- then show ?thesis by (auto simp add: card_bdd_nat_set_l)
-qed
-
-lemma card_bdd_int_set_l: "0 \<le> (n::int) ==> card {y. 0 \<le> y & y < n} = nat n"
-proof -
- assume "0 \<le> n"
- have "inj_on (%y. int y) {y. y < nat n}"
- by (auto simp add: inj_on_def)
- hence "card (int ` {y. y < nat n}) = card {y. y < nat n}"
- by (rule card_image)
- also from `0 \<le> n` have "int ` {y. y < nat n} = {y. 0 \<le> y & y < n}"
- apply (auto simp add: zless_nat_eq_int_zless image_def)
- apply (rule_tac x = "nat x" in exI)
- apply (auto simp add: nat_0_le)
- done
- also have "card {y. y < nat n} = nat n"
- by (rule card_bdd_nat_set_l)
- finally show "card {y. 0 \<le> y & y < n} = nat n" .
-qed
-
-lemma card_bdd_int_set_le: "0 \<le> (n::int) ==> card {y. 0 \<le> y & y \<le> n} =
- nat n + 1"
-proof -
- assume "0 \<le> n"
- moreover have "{y. 0 \<le> y & y \<le> n} = {y. 0 \<le> y & y < n+1}" by auto
- ultimately show ?thesis
- using card_bdd_int_set_l [of "n + 1"]
- by (auto simp add: nat_add_distrib)
-qed
-
-lemma card_bdd_int_set_l_le: "0 \<le> (n::int) ==>
- card {x. 0 < x & x \<le> n} = nat n"
-proof -
- assume "0 \<le> n"
- have "inj_on (%x. x+1) {x. 0 \<le> x & x < n}"
- by (auto simp add: inj_on_def)
- hence "card ((%x. x+1) ` {x. 0 \<le> x & x < n}) =
- card {x. 0 \<le> x & x < n}"
- by (rule card_image)
- also from `0 \<le> n` have "... = nat n"
- by (rule card_bdd_int_set_l)
- also have "(%x. x + 1) ` {x. 0 \<le> x & x < n} = {x. 0 < x & x<= n}"
- apply (auto simp add: image_def)
- apply (rule_tac x = "x - 1" in exI)
- apply arith
- done
- finally show "card {x. 0 < x & x \<le> n} = nat n" .
-qed
-
-lemma card_bdd_int_set_l_l: "0 < (n::int) ==>
- card {x. 0 < x & x < n} = nat n - 1"
-proof -
- assume "0 < n"
- moreover have "{x. 0 < x & x < n} = {x. 0 < x & x \<le> n - 1}"
- by simp
- ultimately show ?thesis
- using insert card_bdd_int_set_l_le [of "n - 1"]
- by (auto simp add: nat_diff_distrib)
-qed
-
-lemma int_card_bdd_int_set_l_l: "0 < n ==>
- int(card {x. 0 < x & x < n}) = n - 1"
- apply (auto simp add: card_bdd_int_set_l_l)
- done
-
-lemma int_card_bdd_int_set_l_le: "0 \<le> n ==>
- int(card {x. 0 < x & x \<le> n}) = n"
- by (auto simp add: card_bdd_int_set_l_le)
-
-
-subsection {* Cardinality of finite cartesian products *}
-
-(* FIXME could be useful in general but not needed here
-lemma insert_Sigma [simp]: "(insert x A) <*> B = ({ x } <*> B) \<union> (A <*> B)"
- by blast
- *)
-
-text {* Lemmas for counting arguments. *}
-
-lemma setsum_bij_eq: "[| finite A; finite B; f ` A \<subseteq> B; inj_on f A;
- g ` B \<subseteq> A; inj_on g B |] ==> setsum g B = setsum (g \<circ> f) A"
- apply (frule_tac h = g and f = f in setsum_reindex)
- apply (subgoal_tac "setsum g B = setsum g (f ` A)")
- apply (simp add: inj_on_def)
- apply (subgoal_tac "card A = card B")
- apply (drule_tac A = "f ` A" and B = B in card_seteq)
- apply (auto simp add: card_image)
- apply (frule_tac A = A and B = B and f = f in card_inj_on_le, auto)
- apply (frule_tac A = B and B = A and f = g in card_inj_on_le)
- apply auto
- done
-
-lemma setprod_bij_eq: "[| finite A; finite B; f ` A \<subseteq> B; inj_on f A;
- g ` B \<subseteq> A; inj_on g B |] ==> setprod g B = setprod (g \<circ> f) A"
- apply (frule_tac h = g and f = f in setprod_reindex)
- apply (subgoal_tac "setprod g B = setprod g (f ` A)")
- apply (simp add: inj_on_def)
- apply (subgoal_tac "card A = card B")
- apply (drule_tac A = "f ` A" and B = B in card_seteq)
- apply (auto simp add: card_image)
- apply (frule_tac A = A and B = B and f = f in card_inj_on_le, auto)
- apply (frule_tac A = B and B = A and f = g in card_inj_on_le, auto)
- done
-
-end
--- a/src/HOL/NumberTheory/Gauss.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,535 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/Gauss.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer)
-*)
-
-header {* Gauss' Lemma *}
-
-theory Gauss
-imports Euler
-begin
-
-locale GAUSS =
- fixes p :: "int"
- fixes a :: "int"
-
- assumes p_prime: "zprime p"
- assumes p_g_2: "2 < p"
- assumes p_a_relprime: "~[a = 0](mod p)"
- assumes a_nonzero: "0 < a"
-begin
-
-definition
- A :: "int set" where
- "A = {(x::int). 0 < x & x \<le> ((p - 1) div 2)}"
-
-definition
- B :: "int set" where
- "B = (%x. x * a) ` A"
-
-definition
- C :: "int set" where
- "C = StandardRes p ` B"
-
-definition
- D :: "int set" where
- "D = C \<inter> {x. x \<le> ((p - 1) div 2)}"
-
-definition
- E :: "int set" where
- "E = C \<inter> {x. ((p - 1) div 2) < x}"
-
-definition
- F :: "int set" where
- "F = (%x. (p - x)) ` E"
-
-
-subsection {* Basic properties of p *}
-
-lemma p_odd: "p \<in> zOdd"
- by (auto simp add: p_prime p_g_2 zprime_zOdd_eq_grt_2)
-
-lemma p_g_0: "0 < p"
- using p_g_2 by auto
-
-lemma int_nat: "int (nat ((p - 1) div 2)) = (p - 1) div 2"
- using ListMem.insert p_g_2 by (auto simp add: pos_imp_zdiv_nonneg_iff)
-
-lemma p_minus_one_l: "(p - 1) div 2 < p"
-proof -
- have "(p - 1) div 2 \<le> (p - 1) div 1"
- by (rule zdiv_mono2) (auto simp add: p_g_0)
- also have "\<dots> = p - 1" by simp
- finally show ?thesis by simp
-qed
-
-lemma p_eq: "p = (2 * (p - 1) div 2) + 1"
- using div_mult_self1_is_id [of 2 "p - 1"] by auto
-
-
-lemma (in -) zodd_imp_zdiv_eq: "x \<in> zOdd ==> 2 * (x - 1) div 2 = 2 * ((x - 1) div 2)"
- apply (frule odd_minus_one_even)
- apply (simp add: zEven_def)
- apply (subgoal_tac "2 \<noteq> 0")
- apply (frule_tac b = "2 :: int" and a = "x - 1" in div_mult_self1_is_id)
- apply (auto simp add: even_div_2_prop2)
- done
-
-
-lemma p_eq2: "p = (2 * ((p - 1) div 2)) + 1"
- apply (insert p_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 [of p], auto)
- apply (frule zodd_imp_zdiv_eq, auto)
- done
-
-
-subsection {* Basic Properties of the Gauss Sets *}
-
-lemma finite_A: "finite (A)"
- apply (auto simp add: A_def)
- apply (subgoal_tac "{x. 0 < x & x \<le> (p - 1) div 2} \<subseteq> {x. 0 \<le> x & x < 1 + (p - 1) div 2}")
- apply (auto simp add: bdd_int_set_l_finite finite_subset)
- done
-
-lemma finite_B: "finite (B)"
- by (auto simp add: B_def finite_A finite_imageI)
-
-lemma finite_C: "finite (C)"
- by (auto simp add: C_def finite_B finite_imageI)
-
-lemma finite_D: "finite (D)"
- by (auto simp add: D_def finite_Int finite_C)
-
-lemma finite_E: "finite (E)"
- by (auto simp add: E_def finite_Int finite_C)
-
-lemma finite_F: "finite (F)"
- by (auto simp add: F_def finite_E finite_imageI)
-
-lemma C_eq: "C = D \<union> E"
- by (auto simp add: C_def D_def E_def)
-
-lemma A_card_eq: "card A = nat ((p - 1) div 2)"
- apply (auto simp add: A_def)
- apply (insert int_nat)
- apply (erule subst)
- apply (auto simp add: card_bdd_int_set_l_le)
- done
-
-lemma inj_on_xa_A: "inj_on (%x. x * a) A"
- using a_nonzero by (simp add: A_def inj_on_def)
-
-lemma A_res: "ResSet p A"
- apply (auto simp add: A_def ResSet_def)
- apply (rule_tac m = p in zcong_less_eq)
- apply (insert p_g_2, auto)
- done
-
-lemma B_res: "ResSet p B"
- apply (insert p_g_2 p_a_relprime p_minus_one_l)
- apply (auto simp add: B_def)
- apply (rule ResSet_image)
- apply (auto simp add: A_res)
- apply (auto simp add: A_def)
-proof -
- fix x fix y
- assume a: "[x * a = y * a] (mod p)"
- assume b: "0 < x"
- assume c: "x \<le> (p - 1) div 2"
- assume d: "0 < y"
- assume e: "y \<le> (p - 1) div 2"
- from a p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
- have "[x = y](mod p)"
- by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
- with zcong_less_eq [of x y p] p_minus_one_l
- order_le_less_trans [of x "(p - 1) div 2" p]
- order_le_less_trans [of y "(p - 1) div 2" p] show "x = y"
- by (simp add: prems p_minus_one_l p_g_0)
-qed
-
-lemma SR_B_inj: "inj_on (StandardRes p) B"
- apply (auto simp add: B_def StandardRes_def inj_on_def A_def prems)
-proof -
- fix x fix y
- assume a: "x * a mod p = y * a mod p"
- assume b: "0 < x"
- assume c: "x \<le> (p - 1) div 2"
- assume d: "0 < y"
- assume e: "y \<le> (p - 1) div 2"
- assume f: "x \<noteq> y"
- from a have "[x * a = y * a](mod p)"
- by (simp add: zcong_zmod_eq p_g_0)
- with p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
- have "[x = y](mod p)"
- by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
- with zcong_less_eq [of x y p] p_minus_one_l
- order_le_less_trans [of x "(p - 1) div 2" p]
- order_le_less_trans [of y "(p - 1) div 2" p] have "x = y"
- by (simp add: prems p_minus_one_l p_g_0)
- then have False
- by (simp add: f)
- then show "a = 0"
- by simp
-qed
-
-lemma inj_on_pminusx_E: "inj_on (%x. p - x) E"
- apply (auto simp add: E_def C_def B_def A_def)
- apply (rule_tac g = "%x. -1 * (x - p)" in inj_on_inverseI)
- apply auto
- done
-
-lemma A_ncong_p: "x \<in> A ==> ~[x = 0](mod p)"
- apply (auto simp add: A_def)
- apply (frule_tac m = p in zcong_not_zero)
- apply (insert p_minus_one_l)
- apply auto
- done
-
-lemma A_greater_zero: "x \<in> A ==> 0 < x"
- by (auto simp add: A_def)
-
-lemma B_ncong_p: "x \<in> B ==> ~[x = 0](mod p)"
- apply (auto simp add: B_def)
- apply (frule A_ncong_p)
- apply (insert p_a_relprime p_prime a_nonzero)
- apply (frule_tac a = x and b = a in zcong_zprime_prod_zero_contra)
- apply (auto simp add: A_greater_zero)
- done
-
-lemma B_greater_zero: "x \<in> B ==> 0 < x"
- using a_nonzero by (auto simp add: B_def mult_pos_pos A_greater_zero)
-
-lemma C_ncong_p: "x \<in> C ==> ~[x = 0](mod p)"
- apply (auto simp add: C_def)
- apply (frule B_ncong_p)
- apply (subgoal_tac "[x = StandardRes p x](mod p)")
- defer apply (simp add: StandardRes_prop1)
- apply (frule_tac a = x and b = "StandardRes p x" and c = 0 in zcong_trans)
- apply auto
- done
-
-lemma C_greater_zero: "y \<in> C ==> 0 < y"
- apply (auto simp add: C_def)
-proof -
- fix x
- assume a: "x \<in> B"
- from p_g_0 have "0 \<le> StandardRes p x"
- by (simp add: StandardRes_lbound)
- moreover have "~[x = 0] (mod p)"
- by (simp add: a B_ncong_p)
- then have "StandardRes p x \<noteq> 0"
- by (simp add: StandardRes_prop3)
- ultimately show "0 < StandardRes p x"
- by (simp add: order_le_less)
-qed
-
-lemma D_ncong_p: "x \<in> D ==> ~[x = 0](mod p)"
- by (auto simp add: D_def C_ncong_p)
-
-lemma E_ncong_p: "x \<in> E ==> ~[x = 0](mod p)"
- by (auto simp add: E_def C_ncong_p)
-
-lemma F_ncong_p: "x \<in> F ==> ~[x = 0](mod p)"
- apply (auto simp add: F_def)
-proof -
- fix x assume a: "x \<in> E" assume b: "[p - x = 0] (mod p)"
- from E_ncong_p have "~[x = 0] (mod p)"
- by (simp add: a)
- moreover from a have "0 < x"
- by (simp add: a E_def C_greater_zero)
- moreover from a have "x < p"
- by (auto simp add: E_def C_def p_g_0 StandardRes_ubound)
- ultimately have "~[p - x = 0] (mod p)"
- by (simp add: zcong_not_zero)
- from this show False by (simp add: b)
-qed
-
-lemma F_subset: "F \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
- apply (auto simp add: F_def E_def)
- apply (insert p_g_0)
- apply (frule_tac x = xa in StandardRes_ubound)
- apply (frule_tac x = x in StandardRes_ubound)
- apply (subgoal_tac "xa = StandardRes p xa")
- apply (auto simp add: C_def StandardRes_prop2 StandardRes_prop1)
-proof -
- from zodd_imp_zdiv_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 have
- "2 * (p - 1) div 2 = 2 * ((p - 1) div 2)"
- by simp
- with p_eq2 show " !!x. [| (p - 1) div 2 < StandardRes p x; x \<in> B |]
- ==> p - StandardRes p x \<le> (p - 1) div 2"
- by simp
-qed
-
-lemma D_subset: "D \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
- by (auto simp add: D_def C_greater_zero)
-
-lemma F_eq: "F = {x. \<exists>y \<in> A. ( x = p - (StandardRes p (y*a)) & (p - 1) div 2 < StandardRes p (y*a))}"
- by (auto simp add: F_def E_def D_def C_def B_def A_def)
-
-lemma D_eq: "D = {x. \<exists>y \<in> A. ( x = StandardRes p (y*a) & StandardRes p (y*a) \<le> (p - 1) div 2)}"
- by (auto simp add: D_def C_def B_def A_def)
-
-lemma D_leq: "x \<in> D ==> x \<le> (p - 1) div 2"
- by (auto simp add: D_eq)
-
-lemma F_ge: "x \<in> F ==> x \<le> (p - 1) div 2"
- apply (auto simp add: F_eq A_def)
-proof -
- fix y
- assume "(p - 1) div 2 < StandardRes p (y * a)"
- then have "p - StandardRes p (y * a) < p - ((p - 1) div 2)"
- by arith
- also from p_eq2 have "... = 2 * ((p - 1) div 2) + 1 - ((p - 1) div 2)"
- by auto
- also have "2 * ((p - 1) div 2) + 1 - (p - 1) div 2 = (p - 1) div 2 + 1"
- by arith
- finally show "p - StandardRes p (y * a) \<le> (p - 1) div 2"
- using zless_add1_eq [of "p - StandardRes p (y * a)" "(p - 1) div 2"] by auto
-qed
-
-lemma all_A_relprime: "\<forall>x \<in> A. zgcd x p = 1"
- using p_prime p_minus_one_l by (auto simp add: A_def zless_zprime_imp_zrelprime)
-
-lemma A_prod_relprime: "zgcd (setprod id A) p = 1"
-by(rule all_relprime_prod_relprime[OF finite_A all_A_relprime])
-
-
-subsection {* Relationships Between Gauss Sets *}
-
-lemma B_card_eq_A: "card B = card A"
- using finite_A by (simp add: finite_A B_def inj_on_xa_A card_image)
-
-lemma B_card_eq: "card B = nat ((p - 1) div 2)"
- by (simp add: B_card_eq_A A_card_eq)
-
-lemma F_card_eq_E: "card F = card E"
- using finite_E by (simp add: F_def inj_on_pminusx_E card_image)
-
-lemma C_card_eq_B: "card C = card B"
- apply (insert finite_B)
- apply (subgoal_tac "inj_on (StandardRes p) B")
- apply (simp add: B_def C_def card_image)
- apply (rule StandardRes_inj_on_ResSet)
- apply (simp add: B_res)
- done
-
-lemma D_E_disj: "D \<inter> E = {}"
- by (auto simp add: D_def E_def)
-
-lemma C_card_eq_D_plus_E: "card C = card D + card E"
- by (auto simp add: C_eq card_Un_disjoint D_E_disj finite_D finite_E)
-
-lemma C_prod_eq_D_times_E: "setprod id E * setprod id D = setprod id C"
- apply (insert D_E_disj finite_D finite_E C_eq)
- apply (frule setprod_Un_disjoint [of D E id])
- apply auto
- done
-
-lemma C_B_zcong_prod: "[setprod id C = setprod id B] (mod p)"
- apply (auto simp add: C_def)
- apply (insert finite_B SR_B_inj)
- apply (frule_tac f = "StandardRes p" in setprod_reindex_id [symmetric], auto)
- apply (rule setprod_same_function_zcong)
- apply (auto simp add: StandardRes_prop1 zcong_sym p_g_0)
- done
-
-lemma F_Un_D_subset: "(F \<union> D) \<subseteq> A"
- apply (rule Un_least)
- apply (auto simp add: A_def F_subset D_subset)
- done
-
-lemma F_D_disj: "(F \<inter> D) = {}"
- apply (simp add: F_eq D_eq)
- apply (auto simp add: F_eq D_eq)
-proof -
- fix y fix ya
- assume "p - StandardRes p (y * a) = StandardRes p (ya * a)"
- then have "p = StandardRes p (y * a) + StandardRes p (ya * a)"
- by arith
- moreover have "p dvd p"
- by auto
- ultimately have "p dvd (StandardRes p (y * a) + StandardRes p (ya * a))"
- by auto
- then have a: "[StandardRes p (y * a) + StandardRes p (ya * a) = 0] (mod p)"
- by (auto simp add: zcong_def)
- have "[y * a = StandardRes p (y * a)] (mod p)"
- by (simp only: zcong_sym StandardRes_prop1)
- moreover have "[ya * a = StandardRes p (ya * a)] (mod p)"
- by (simp only: zcong_sym StandardRes_prop1)
- ultimately have "[y * a + ya * a =
- StandardRes p (y * a) + StandardRes p (ya * a)] (mod p)"
- by (rule zcong_zadd)
- with a have "[y * a + ya * a = 0] (mod p)"
- apply (elim zcong_trans)
- by (simp only: zcong_refl)
- also have "y * a + ya * a = a * (y + ya)"
- by (simp add: zadd_zmult_distrib2 zmult_commute)
- finally have "[a * (y + ya) = 0] (mod p)" .
- with p_prime a_nonzero zcong_zprime_prod_zero [of p a "y + ya"]
- p_a_relprime
- have a: "[y + ya = 0] (mod p)"
- by auto
- assume b: "y \<in> A" and c: "ya: A"
- with A_def have "0 < y + ya"
- by auto
- moreover from b c A_def have "y + ya \<le> (p - 1) div 2 + (p - 1) div 2"
- by auto
- moreover from b c p_eq2 A_def have "y + ya < p"
- by auto
- ultimately show False
- apply simp
- apply (frule_tac m = p in zcong_not_zero)
- apply (auto simp add: a)
- done
-qed
-
-lemma F_Un_D_card: "card (F \<union> D) = nat ((p - 1) div 2)"
-proof -
- have "card (F \<union> D) = card E + card D"
- by (auto simp add: finite_F finite_D F_D_disj
- card_Un_disjoint F_card_eq_E)
- then have "card (F \<union> D) = card C"
- by (simp add: C_card_eq_D_plus_E)
- from this show "card (F \<union> D) = nat ((p - 1) div 2)"
- by (simp add: C_card_eq_B B_card_eq)
-qed
-
-lemma F_Un_D_eq_A: "F \<union> D = A"
- using finite_A F_Un_D_subset A_card_eq F_Un_D_card by (auto simp add: card_seteq)
-
-lemma prod_D_F_eq_prod_A:
- "(setprod id D) * (setprod id F) = setprod id A"
- apply (insert F_D_disj finite_D finite_F)
- apply (frule setprod_Un_disjoint [of F D id])
- apply (auto simp add: F_Un_D_eq_A)
- done
-
-lemma prod_F_zcong:
- "[setprod id F = ((-1) ^ (card E)) * (setprod id E)] (mod p)"
-proof -
- have "setprod id F = setprod id (op - p ` E)"
- by (auto simp add: F_def)
- then have "setprod id F = setprod (op - p) E"
- apply simp
- apply (insert finite_E inj_on_pminusx_E)
- apply (frule_tac f = "op - p" in setprod_reindex_id, auto)
- done
- then have one:
- "[setprod id F = setprod (StandardRes p o (op - p)) E] (mod p)"
- apply simp
- apply (insert p_g_0 finite_E StandardRes_prod)
- by (auto)
- moreover have a: "\<forall>x \<in> E. [p - x = 0 - x] (mod p)"
- apply clarify
- apply (insert zcong_id [of p])
- apply (rule_tac a = p and m = p and c = x and d = x in zcong_zdiff, auto)
- done
- moreover have b: "\<forall>x \<in> E. [StandardRes p (p - x) = p - x](mod p)"
- apply clarify
- apply (simp add: StandardRes_prop1 zcong_sym)
- done
- moreover have "\<forall>x \<in> E. [StandardRes p (p - x) = - x](mod p)"
- apply clarify
- apply (insert a b)
- apply (rule_tac b = "p - x" in zcong_trans, auto)
- done
- ultimately have c:
- "[setprod (StandardRes p o (op - p)) E = setprod (uminus) E](mod p)"
- apply simp
- using finite_E p_g_0
- setprod_same_function_zcong [of E "StandardRes p o (op - p)" uminus p]
- by auto
- then have two: "[setprod id F = setprod (uminus) E](mod p)"
- apply (insert one c)
- apply (rule zcong_trans [of "setprod id F"
- "setprod (StandardRes p o op - p) E" p
- "setprod uminus E"], auto)
- done
- also have "setprod uminus E = (setprod id E) * (-1)^(card E)"
- using finite_E by (induct set: finite) auto
- then have "setprod uminus E = (-1) ^ (card E) * (setprod id E)"
- by (simp add: zmult_commute)
- with two show ?thesis
- by simp
-qed
-
-
-subsection {* Gauss' Lemma *}
-
-lemma aux: "setprod id A * -1 ^ card E * a ^ card A * -1 ^ card E = setprod id A * a ^ card A"
- by (auto simp add: finite_E neg_one_special)
-
-theorem pre_gauss_lemma:
- "[a ^ nat((p - 1) div 2) = (-1) ^ (card E)] (mod p)"
-proof -
- have "[setprod id A = setprod id F * setprod id D](mod p)"
- by (auto simp add: prod_D_F_eq_prod_A zmult_commute cong del:setprod_cong)
- then have "[setprod id A = ((-1)^(card E) * setprod id E) *
- setprod id D] (mod p)"
- apply (rule zcong_trans)
- apply (auto simp add: prod_F_zcong zcong_scalar cong del: setprod_cong)
- done
- then have "[setprod id A = ((-1)^(card E) * setprod id C)] (mod p)"
- apply (rule zcong_trans)
- apply (insert C_prod_eq_D_times_E, erule subst)
- apply (subst zmult_assoc, auto)
- done
- then have "[setprod id A = ((-1)^(card E) * setprod id B)] (mod p)"
- apply (rule zcong_trans)
- apply (simp add: C_B_zcong_prod zcong_scalar2 cong del:setprod_cong)
- done
- then have "[setprod id A = ((-1)^(card E) *
- (setprod id ((%x. x * a) ` A)))] (mod p)"
- by (simp add: B_def)
- then have "[setprod id A = ((-1)^(card E) * (setprod (%x. x * a) A))]
- (mod p)"
- by (simp add:finite_A inj_on_xa_A setprod_reindex_id[symmetric] cong del:setprod_cong)
- moreover have "setprod (%x. x * a) A =
- setprod (%x. a) A * setprod id A"
- using finite_A by (induct set: finite) auto
- ultimately have "[setprod id A = ((-1)^(card E) * (setprod (%x. a) A *
- setprod id A))] (mod p)"
- by simp
- then have "[setprod id A = ((-1)^(card E) * a^(card A) *
- setprod id A)](mod p)"
- apply (rule zcong_trans)
- apply (simp add: zcong_scalar2 zcong_scalar finite_A setprod_constant zmult_assoc)
- done
- then have a: "[setprod id A * (-1)^(card E) =
- ((-1)^(card E) * a^(card A) * setprod id A * (-1)^(card E))](mod p)"
- by (rule zcong_scalar)
- then have "[setprod id A * (-1)^(card E) = setprod id A *
- (-1)^(card E) * a^(card A) * (-1)^(card E)](mod p)"
- apply (rule zcong_trans)
- apply (simp add: a mult_commute mult_left_commute)
- done
- then have "[setprod id A * (-1)^(card E) = setprod id A *
- a^(card A)](mod p)"
- apply (rule zcong_trans)
- apply (simp add: aux cong del:setprod_cong)
- done
- with this zcong_cancel2 [of p "setprod id A" "-1 ^ card E" "a ^ card A"]
- p_g_0 A_prod_relprime have "[-1 ^ card E = a ^ card A](mod p)"
- by (simp add: order_less_imp_le)
- from this show ?thesis
- by (simp add: A_card_eq zcong_sym)
-qed
-
-theorem gauss_lemma: "(Legendre a p) = (-1) ^ (card E)"
-proof -
- from Euler_Criterion p_prime p_g_2 have
- "[(Legendre a p) = a^(nat (((p) - 1) div 2))] (mod p)"
- by auto
- moreover note pre_gauss_lemma
- ultimately have "[(Legendre a p) = (-1) ^ (card E)] (mod p)"
- by (rule zcong_trans)
- moreover from p_a_relprime have "(Legendre a p) = 1 | (Legendre a p) = (-1)"
- by (auto simp add: Legendre_def)
- moreover have "(-1::int) ^ (card E) = 1 | (-1::int) ^ (card E) = -1"
- by (rule neg_one_power)
- ultimately show ?thesis
- by (auto simp add: p_g_2 one_not_neg_one_mod_m zcong_sym)
-qed
-
-end
-
-end
--- a/src/HOL/NumberTheory/Int2.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,299 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/Gauss.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {*Integers: Divisibility and Congruences*}
-
-theory Int2
-imports Finite2 WilsonRuss
-begin
-
-definition
- MultInv :: "int => int => int" where
- "MultInv p x = x ^ nat (p - 2)"
-
-
-subsection {* Useful lemmas about dvd and powers *}
-
-lemma zpower_zdvd_prop1:
- "0 < n \<Longrightarrow> p dvd y \<Longrightarrow> p dvd ((y::int) ^ n)"
- by (induct n) (auto simp add: dvd_mult2 [of p y])
-
-lemma zdvd_bounds: "n dvd m ==> m \<le> (0::int) | n \<le> m"
-proof -
- assume "n dvd m"
- then have "~(0 < m & m < n)"
- using zdvd_not_zless [of m n] by auto
- then show ?thesis by auto
-qed
-
-lemma zprime_zdvd_zmult_better: "[| zprime p; p dvd (m * n) |] ==>
- (p dvd m) | (p dvd n)"
- apply (cases "0 \<le> m")
- apply (simp add: zprime_zdvd_zmult)
- apply (insert zprime_zdvd_zmult [of "-m" p n])
- apply auto
- done
-
-lemma zpower_zdvd_prop2:
- "zprime p \<Longrightarrow> p dvd ((y::int) ^ n) \<Longrightarrow> 0 < n \<Longrightarrow> p dvd y"
- apply (induct n)
- apply simp
- apply (frule zprime_zdvd_zmult_better)
- apply simp
- apply (force simp del:dvd_mult)
- done
-
-lemma div_prop1: "[| 0 < z; (x::int) < y * z |] ==> x div z < y"
-proof -
- assume "0 < z" then have modth: "x mod z \<ge> 0" by simp
- have "(x div z) * z \<le> (x div z) * z" by simp
- then have "(x div z) * z \<le> (x div z) * z + x mod z" using modth by arith
- also have "\<dots> = x"
- by (auto simp add: zmod_zdiv_equality [symmetric] zmult_ac)
- also assume "x < y * z"
- finally show ?thesis
- by (auto simp add: prems mult_less_cancel_right, insert prems, arith)
-qed
-
-lemma div_prop2: "[| 0 < z; (x::int) < (y * z) + z |] ==> x div z \<le> y"
-proof -
- assume "0 < z" and "x < (y * z) + z"
- then have "x < (y + 1) * z" by (auto simp add: int_distrib)
- then have "x div z < y + 1"
- apply -
- apply (rule_tac y = "y + 1" in div_prop1)
- apply (auto simp add: prems)
- done
- then show ?thesis by auto
-qed
-
-lemma zdiv_leq_prop: "[| 0 < y |] ==> y * (x div y) \<le> (x::int)"
-proof-
- assume "0 < y"
- from zmod_zdiv_equality have "x = y * (x div y) + x mod y" by auto
- moreover have "0 \<le> x mod y"
- by (auto simp add: prems pos_mod_sign)
- ultimately show ?thesis
- by arith
-qed
-
-
-subsection {* Useful properties of congruences *}
-
-lemma zcong_eq_zdvd_prop: "[x = 0](mod p) = (p dvd x)"
- by (auto simp add: zcong_def)
-
-lemma zcong_id: "[m = 0] (mod m)"
- by (auto simp add: zcong_def)
-
-lemma zcong_shift: "[a = b] (mod m) ==> [a + c = b + c] (mod m)"
- by (auto simp add: zcong_refl zcong_zadd)
-
-lemma zcong_zpower: "[x = y](mod m) ==> [x^z = y^z](mod m)"
- by (induct z) (auto simp add: zcong_zmult)
-
-lemma zcong_eq_trans: "[| [a = b](mod m); b = c; [c = d](mod m) |] ==>
- [a = d](mod m)"
- apply (erule zcong_trans)
- apply simp
- done
-
-lemma aux1: "a - b = (c::int) ==> a = c + b"
- by auto
-
-lemma zcong_zmult_prop1: "[a = b](mod m) ==> ([c = a * d](mod m) =
- [c = b * d] (mod m))"
- apply (auto simp add: zcong_def dvd_def)
- apply (rule_tac x = "ka + k * d" in exI)
- apply (drule aux1)+
- apply (auto simp add: int_distrib)
- apply (rule_tac x = "ka - k * d" in exI)
- apply (drule aux1)+
- apply (auto simp add: int_distrib)
- done
-
-lemma zcong_zmult_prop2: "[a = b](mod m) ==>
- ([c = d * a](mod m) = [c = d * b] (mod m))"
- by (auto simp add: zmult_ac zcong_zmult_prop1)
-
-lemma zcong_zmult_prop3: "[| zprime p; ~[x = 0] (mod p);
- ~[y = 0] (mod p) |] ==> ~[x * y = 0] (mod p)"
- apply (auto simp add: zcong_def)
- apply (drule zprime_zdvd_zmult_better, auto)
- done
-
-lemma zcong_less_eq: "[| 0 < x; 0 < y; 0 < m; [x = y] (mod m);
- x < m; y < m |] ==> x = y"
- by (metis zcong_not zcong_sym zless_linear)
-
-lemma zcong_neg_1_impl_ne_1: "[| 2 < p; [x = -1] (mod p) |] ==>
- ~([x = 1] (mod p))"
-proof
- assume "2 < p" and "[x = 1] (mod p)" and "[x = -1] (mod p)"
- then have "[1 = -1] (mod p)"
- apply (auto simp add: zcong_sym)
- apply (drule zcong_trans, auto)
- done
- then have "[1 + 1 = -1 + 1] (mod p)"
- by (simp only: zcong_shift)
- then have "[2 = 0] (mod p)"
- by auto
- then have "p dvd 2"
- by (auto simp add: dvd_def zcong_def)
- with prems show False
- by (auto simp add: zdvd_not_zless)
-qed
-
-lemma zcong_zero_equiv_div: "[a = 0] (mod m) = (m dvd a)"
- by (auto simp add: zcong_def)
-
-lemma zcong_zprime_prod_zero: "[| zprime p; 0 < a |] ==>
- [a * b = 0] (mod p) ==> [a = 0] (mod p) | [b = 0] (mod p)"
- by (auto simp add: zcong_zero_equiv_div zprime_zdvd_zmult)
-
-lemma zcong_zprime_prod_zero_contra: "[| zprime p; 0 < a |] ==>
- ~[a = 0](mod p) & ~[b = 0](mod p) ==> ~[a * b = 0] (mod p)"
- apply auto
- apply (frule_tac a = a and b = b and p = p in zcong_zprime_prod_zero)
- apply auto
- done
-
-lemma zcong_not_zero: "[| 0 < x; x < m |] ==> ~[x = 0] (mod m)"
- by (auto simp add: zcong_zero_equiv_div zdvd_not_zless)
-
-lemma zcong_zero: "[| 0 \<le> x; x < m; [x = 0](mod m) |] ==> x = 0"
- apply (drule order_le_imp_less_or_eq, auto)
- apply (frule_tac m = m in zcong_not_zero)
- apply auto
- done
-
-lemma all_relprime_prod_relprime: "[| finite A; \<forall>x \<in> A. zgcd x y = 1 |]
- ==> zgcd (setprod id A) y = 1"
- by (induct set: finite) (auto simp add: zgcd_zgcd_zmult)
-
-
-subsection {* Some properties of MultInv *}
-
-lemma MultInv_prop1: "[| 2 < p; [x = y] (mod p) |] ==>
- [(MultInv p x) = (MultInv p y)] (mod p)"
- by (auto simp add: MultInv_def zcong_zpower)
-
-lemma MultInv_prop2: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
- [(x * (MultInv p x)) = 1] (mod p)"
-proof (simp add: MultInv_def zcong_eq_zdvd_prop)
- assume "2 < p" and "zprime p" and "~ p dvd x"
- have "x * x ^ nat (p - 2) = x ^ (nat (p - 2) + 1)"
- by auto
- also from prems have "nat (p - 2) + 1 = nat (p - 2 + 1)"
- by (simp only: nat_add_distrib)
- also have "p - 2 + 1 = p - 1" by arith
- finally have "[x * x ^ nat (p - 2) = x ^ nat (p - 1)] (mod p)"
- by (rule ssubst, auto)
- also from prems have "[x ^ nat (p - 1) = 1] (mod p)"
- by (auto simp add: Little_Fermat)
- finally (zcong_trans) show "[x * x ^ nat (p - 2) = 1] (mod p)" .
-qed
-
-lemma MultInv_prop2a: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
- [(MultInv p x) * x = 1] (mod p)"
- by (auto simp add: MultInv_prop2 zmult_ac)
-
-lemma aux_1: "2 < p ==> ((nat p) - 2) = (nat (p - 2))"
- by (simp add: nat_diff_distrib)
-
-lemma aux_2: "2 < p ==> 0 < nat (p - 2)"
- by auto
-
-lemma MultInv_prop3: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
- ~([MultInv p x = 0](mod p))"
- apply (auto simp add: MultInv_def zcong_eq_zdvd_prop aux_1)
- apply (drule aux_2)
- apply (drule zpower_zdvd_prop2, auto)
- done
-
-lemma aux__1: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
- [(MultInv p (MultInv p x)) = (x * (MultInv p x) *
- (MultInv p (MultInv p x)))] (mod p)"
- apply (drule MultInv_prop2, auto)
- apply (drule_tac k = "MultInv p (MultInv p x)" in zcong_scalar, auto)
- apply (auto simp add: zcong_sym)
- done
-
-lemma aux__2: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
- [(x * (MultInv p x) * (MultInv p (MultInv p x))) = x] (mod p)"
- apply (frule MultInv_prop3, auto)
- apply (insert MultInv_prop2 [of p "MultInv p x"], auto)
- apply (drule MultInv_prop2, auto)
- apply (drule_tac k = x in zcong_scalar2, auto)
- apply (auto simp add: zmult_ac)
- done
-
-lemma MultInv_prop4: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
- [(MultInv p (MultInv p x)) = x] (mod p)"
- apply (frule aux__1, auto)
- apply (drule aux__2, auto)
- apply (drule zcong_trans, auto)
- done
-
-lemma MultInv_prop5: "[| 2 < p; zprime p; ~([x = 0](mod p));
- ~([y = 0](mod p)); [(MultInv p x) = (MultInv p y)] (mod p) |] ==>
- [x = y] (mod p)"
- apply (drule_tac a = "MultInv p x" and b = "MultInv p y" and
- m = p and k = x in zcong_scalar)
- apply (insert MultInv_prop2 [of p x], simp)
- apply (auto simp only: zcong_sym [of "MultInv p x * x"])
- apply (auto simp add: zmult_ac)
- apply (drule zcong_trans, auto)
- apply (drule_tac a = "x * MultInv p y" and k = y in zcong_scalar, auto)
- apply (insert MultInv_prop2a [of p y], auto simp add: zmult_ac)
- apply (insert zcong_zmult_prop2 [of "y * MultInv p y" 1 p y x])
- apply (auto simp add: zcong_sym)
- done
-
-lemma MultInv_zcong_prop1: "[| 2 < p; [j = k] (mod p) |] ==>
- [a * MultInv p j = a * MultInv p k] (mod p)"
- by (drule MultInv_prop1, auto simp add: zcong_scalar2)
-
-lemma aux___1: "[j = a * MultInv p k] (mod p) ==>
- [j * k = a * MultInv p k * k] (mod p)"
- by (auto simp add: zcong_scalar)
-
-lemma aux___2: "[|2 < p; zprime p; ~([k = 0](mod p));
- [j * k = a * MultInv p k * k] (mod p) |] ==> [j * k = a] (mod p)"
- apply (insert MultInv_prop2a [of p k] zcong_zmult_prop2
- [of "MultInv p k * k" 1 p "j * k" a])
- apply (auto simp add: zmult_ac)
- done
-
-lemma aux___3: "[j * k = a] (mod p) ==> [(MultInv p j) * j * k =
- (MultInv p j) * a] (mod p)"
- by (auto simp add: zmult_assoc zcong_scalar2)
-
-lemma aux___4: "[|2 < p; zprime p; ~([j = 0](mod p));
- [(MultInv p j) * j * k = (MultInv p j) * a] (mod p) |]
- ==> [k = a * (MultInv p j)] (mod p)"
- apply (insert MultInv_prop2a [of p j] zcong_zmult_prop1
- [of "MultInv p j * j" 1 p "MultInv p j * a" k])
- apply (auto simp add: zmult_ac zcong_sym)
- done
-
-lemma MultInv_zcong_prop2: "[| 2 < p; zprime p; ~([k = 0](mod p));
- ~([j = 0](mod p)); [j = a * MultInv p k] (mod p) |] ==>
- [k = a * MultInv p j] (mod p)"
- apply (drule aux___1)
- apply (frule aux___2, auto)
- by (drule aux___3, drule aux___4, auto)
-
-lemma MultInv_zcong_prop3: "[| 2 < p; zprime p; ~([a = 0](mod p));
- ~([k = 0](mod p)); ~([j = 0](mod p));
- [a * MultInv p j = a * MultInv p k] (mod p) |] ==>
- [j = k] (mod p)"
- apply (auto simp add: zcong_eq_zdvd_prop [of a p])
- apply (frule zprime_imp_zrelprime, auto)
- apply (insert zcong_cancel2 [of p a "MultInv p j" "MultInv p k"], auto)
- apply (drule MultInv_prop5, auto)
- done
-
-end
--- a/src/HOL/NumberTheory/IntFact.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,96 +0,0 @@
-(* Title: HOL/NumberTheory/IntFact.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Factorial on integers *}
-
-theory IntFact imports IntPrimes begin
-
-text {*
- Factorial on integers and recursively defined set including all
- Integers from @{text 2} up to @{text a}. Plus definition of product
- of finite set.
-
- \bigskip
-*}
-
-consts
- zfact :: "int => int"
- d22set :: "int => int set"
-
-recdef zfact "measure ((\<lambda>n. nat n) :: int => nat)"
- "zfact n = (if n \<le> 0 then 1 else n * zfact (n - 1))"
-
-recdef d22set "measure ((\<lambda>a. nat a) :: int => nat)"
- "d22set a = (if 1 < a then insert a (d22set (a - 1)) else {})"
-
-
-text {*
- \medskip @{term d22set} --- recursively defined set including all
- integers from @{text 2} up to @{text a}
-*}
-
-declare d22set.simps [simp del]
-
-
-lemma d22set_induct:
- assumes "!!a. P {} a"
- and "!!a. 1 < (a::int) ==> P (d22set (a - 1)) (a - 1) ==> P (d22set a) a"
- shows "P (d22set u) u"
- apply (rule d22set.induct)
- apply safe
- prefer 2
- apply (case_tac "1 < a")
- apply (rule_tac prems)
- apply (simp_all (no_asm_simp))
- apply (simp_all (no_asm_simp) add: d22set.simps prems)
- done
-
-lemma d22set_g_1 [rule_format]: "b \<in> d22set a --> 1 < b"
- apply (induct a rule: d22set_induct)
- apply simp
- apply (subst d22set.simps)
- apply auto
- done
-
-lemma d22set_le [rule_format]: "b \<in> d22set a --> b \<le> a"
- apply (induct a rule: d22set_induct)
- apply simp
- apply (subst d22set.simps)
- apply auto
- done
-
-lemma d22set_le_swap: "a < b ==> b \<notin> d22set a"
- by (auto dest: d22set_le)
-
-lemma d22set_mem: "1 < b \<Longrightarrow> b \<le> a \<Longrightarrow> b \<in> d22set a"
- apply (induct a rule: d22set.induct)
- apply auto
- apply (simp_all add: d22set.simps)
- done
-
-lemma d22set_fin: "finite (d22set a)"
- apply (induct a rule: d22set_induct)
- prefer 2
- apply (subst d22set.simps)
- apply auto
- done
-
-
-declare zfact.simps [simp del]
-
-lemma d22set_prod_zfact: "\<Prod>(d22set a) = zfact a"
- apply (induct a rule: d22set.induct)
- apply safe
- apply (simp add: d22set.simps zfact.simps)
- apply (subst d22set.simps)
- apply (subst zfact.simps)
- apply (case_tac "1 < a")
- prefer 2
- apply (simp add: d22set.simps zfact.simps)
- apply (simp add: d22set_fin d22set_le_swap)
- done
-
-end
--- a/src/HOL/NumberTheory/IntPrimes.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,423 +0,0 @@
-(* Title: HOL/NumberTheory/IntPrimes.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Divisibility and prime numbers (on integers) *}
-
-theory IntPrimes
-imports Main Primes
-begin
-
-text {*
- The @{text dvd} relation, GCD, Euclid's extended algorithm, primes,
- congruences (all on the Integers). Comparable to theory @{text
- Primes}, but @{text dvd} is included here as it is not present in
- main HOL. Also includes extended GCD and congruences not present in
- @{text Primes}.
-*}
-
-
-subsection {* Definitions *}
-
-consts
- xzgcda :: "int * int * int * int * int * int * int * int => int * int * int"
-
-recdef xzgcda
- "measure ((\<lambda>(m, n, r', r, s', s, t', t). nat r)
- :: int * int * int * int *int * int * int * int => nat)"
- "xzgcda (m, n, r', r, s', s, t', t) =
- (if r \<le> 0 then (r', s', t')
- else xzgcda (m, n, r, r' mod r,
- s, s' - (r' div r) * s,
- t, t' - (r' div r) * t))"
-
-definition
- zprime :: "int \<Rightarrow> bool" where
- "zprime p = (1 < p \<and> (\<forall>m. 0 <= m & m dvd p --> m = 1 \<or> m = p))"
-
-definition
- xzgcd :: "int => int => int * int * int" where
- "xzgcd m n = xzgcda (m, n, m, n, 1, 0, 0, 1)"
-
-definition
- zcong :: "int => int => int => bool" ("(1[_ = _] '(mod _'))") where
- "[a = b] (mod m) = (m dvd (a - b))"
-
-subsection {* Euclid's Algorithm and GCD *}
-
-
-lemma zrelprime_zdvd_zmult_aux:
- "zgcd n k = 1 ==> k dvd m * n ==> 0 \<le> m ==> k dvd m"
- by (metis abs_of_nonneg dvd_triv_right zgcd_greatest_iff zgcd_zmult_distrib2_abs zmult_1_right)
-
-lemma zrelprime_zdvd_zmult: "zgcd n k = 1 ==> k dvd m * n ==> k dvd m"
- apply (case_tac "0 \<le> m")
- apply (blast intro: zrelprime_zdvd_zmult_aux)
- apply (subgoal_tac "k dvd -m")
- apply (rule_tac [2] zrelprime_zdvd_zmult_aux, auto)
- done
-
-lemma zgcd_geq_zero: "0 <= zgcd x y"
- by (auto simp add: zgcd_def)
-
-text{*This is merely a sanity check on zprime, since the previous version
- denoted the empty set.*}
-lemma "zprime 2"
- apply (auto simp add: zprime_def)
- apply (frule zdvd_imp_le, simp)
- apply (auto simp add: order_le_less dvd_def)
- done
-
-lemma zprime_imp_zrelprime:
- "zprime p ==> \<not> p dvd n ==> zgcd n p = 1"
- apply (auto simp add: zprime_def)
- apply (metis zgcd_geq_zero zgcd_zdvd1 zgcd_zdvd2)
- done
-
-lemma zless_zprime_imp_zrelprime:
- "zprime p ==> 0 < n ==> n < p ==> zgcd n p = 1"
- apply (erule zprime_imp_zrelprime)
- apply (erule zdvd_not_zless, assumption)
- done
-
-lemma zprime_zdvd_zmult:
- "0 \<le> (m::int) ==> zprime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
- by (metis zgcd_zdvd1 zgcd_zdvd2 zgcd_pos zprime_def zrelprime_dvd_mult)
-
-lemma zgcd_zadd_zmult [simp]: "zgcd (m + n * k) n = zgcd m n"
- apply (rule zgcd_eq [THEN trans])
- apply (simp add: mod_add_eq)
- apply (rule zgcd_eq [symmetric])
- done
-
-lemma zgcd_zdvd_zgcd_zmult: "zgcd m n dvd zgcd (k * m) n"
-by (simp add: zgcd_greatest_iff)
-
-lemma zgcd_zmult_zdvd_zgcd:
- "zgcd k n = 1 ==> zgcd (k * m) n dvd zgcd m n"
- apply (simp add: zgcd_greatest_iff)
- apply (rule_tac n = k in zrelprime_zdvd_zmult)
- prefer 2
- apply (simp add: zmult_commute)
- apply (metis zgcd_1 zgcd_commute zgcd_left_commute)
- done
-
-lemma zgcd_zmult_cancel: "zgcd k n = 1 ==> zgcd (k * m) n = zgcd m n"
- by (simp add: zgcd_def nat_abs_mult_distrib gcd_mult_cancel)
-
-lemma zgcd_zgcd_zmult:
- "zgcd k m = 1 ==> zgcd n m = 1 ==> zgcd (k * n) m = 1"
- by (simp add: zgcd_zmult_cancel)
-
-lemma zdvd_iff_zgcd: "0 < m ==> m dvd n \<longleftrightarrow> zgcd n m = m"
- by (metis abs_of_pos zdvd_mult_div_cancel zgcd_0 zgcd_commute zgcd_geq_zero zgcd_zdvd2 zgcd_zmult_eq_self)
-
-
-
-subsection {* Congruences *}
-
-lemma zcong_1 [simp]: "[a = b] (mod 1)"
- by (unfold zcong_def, auto)
-
-lemma zcong_refl [simp]: "[k = k] (mod m)"
- by (unfold zcong_def, auto)
-
-lemma zcong_sym: "[a = b] (mod m) = [b = a] (mod m)"
- unfolding zcong_def minus_diff_eq [of a, symmetric] dvd_minus_iff ..
-
-lemma zcong_zadd:
- "[a = b] (mod m) ==> [c = d] (mod m) ==> [a + c = b + d] (mod m)"
- apply (unfold zcong_def)
- apply (rule_tac s = "(a - b) + (c - d)" in subst)
- apply (rule_tac [2] dvd_add, auto)
- done
-
-lemma zcong_zdiff:
- "[a = b] (mod m) ==> [c = d] (mod m) ==> [a - c = b - d] (mod m)"
- apply (unfold zcong_def)
- apply (rule_tac s = "(a - b) - (c - d)" in subst)
- apply (rule_tac [2] dvd_diff, auto)
- done
-
-lemma zcong_trans:
- "[a = b] (mod m) ==> [b = c] (mod m) ==> [a = c] (mod m)"
-unfolding zcong_def by (auto elim!: dvdE simp add: algebra_simps)
-
-lemma zcong_zmult:
- "[a = b] (mod m) ==> [c = d] (mod m) ==> [a * c = b * d] (mod m)"
- apply (rule_tac b = "b * c" in zcong_trans)
- apply (unfold zcong_def)
- apply (metis zdiff_zmult_distrib2 dvd_mult zmult_commute)
- apply (metis zdiff_zmult_distrib2 dvd_mult)
- done
-
-lemma zcong_scalar: "[a = b] (mod m) ==> [a * k = b * k] (mod m)"
- by (rule zcong_zmult, simp_all)
-
-lemma zcong_scalar2: "[a = b] (mod m) ==> [k * a = k * b] (mod m)"
- by (rule zcong_zmult, simp_all)
-
-lemma zcong_zmult_self: "[a * m = b * m] (mod m)"
- apply (unfold zcong_def)
- apply (rule dvd_diff, simp_all)
- done
-
-lemma zcong_square:
- "[| zprime p; 0 < a; [a * a = 1] (mod p)|]
- ==> [a = 1] (mod p) \<or> [a = p - 1] (mod p)"
- apply (unfold zcong_def)
- apply (rule zprime_zdvd_zmult)
- apply (rule_tac [3] s = "a * a - 1 + p * (1 - a)" in subst)
- prefer 4
- apply (simp add: zdvd_reduce)
- apply (simp_all add: zdiff_zmult_distrib zmult_commute zdiff_zmult_distrib2)
- done
-
-lemma zcong_cancel:
- "0 \<le> m ==>
- zgcd k m = 1 ==> [a * k = b * k] (mod m) = [a = b] (mod m)"
- apply safe
- prefer 2
- apply (blast intro: zcong_scalar)
- apply (case_tac "b < a")
- prefer 2
- apply (subst zcong_sym)
- apply (unfold zcong_def)
- apply (rule_tac [!] zrelprime_zdvd_zmult)
- apply (simp_all add: zdiff_zmult_distrib)
- apply (subgoal_tac "m dvd (-(a * k - b * k))")
- apply simp
- apply (subst dvd_minus_iff, assumption)
- done
-
-lemma zcong_cancel2:
- "0 \<le> m ==>
- zgcd k m = 1 ==> [k * a = k * b] (mod m) = [a = b] (mod m)"
- by (simp add: zmult_commute zcong_cancel)
-
-lemma zcong_zgcd_zmult_zmod:
- "[a = b] (mod m) ==> [a = b] (mod n) ==> zgcd m n = 1
- ==> [a = b] (mod m * n)"
- apply (auto simp add: zcong_def dvd_def)
- apply (subgoal_tac "m dvd n * ka")
- apply (subgoal_tac "m dvd ka")
- apply (case_tac [2] "0 \<le> ka")
- apply (metis zdvd_mult_div_cancel dvd_refl dvd_mult_left zmult_commute zrelprime_zdvd_zmult)
- apply (metis abs_dvd_iff abs_of_nonneg zadd_0 zgcd_0_left zgcd_commute zgcd_zadd_zmult zgcd_zdvd_zgcd_zmult zgcd_zmult_distrib2_abs zmult_1_right zmult_commute)
- apply (metis mult_le_0_iff zdvd_mono zdvd_mult_cancel dvd_triv_left zero_le_mult_iff zle_anti_sym zle_linear zle_refl zmult_commute zrelprime_zdvd_zmult)
- apply (metis dvd_triv_left)
- done
-
-lemma zcong_zless_imp_eq:
- "0 \<le> a ==>
- a < m ==> 0 \<le> b ==> b < m ==> [a = b] (mod m) ==> a = b"
- apply (unfold zcong_def dvd_def, auto)
- apply (drule_tac f = "\<lambda>z. z mod m" in arg_cong)
- apply (metis diff_add_cancel mod_pos_pos_trivial zadd_0 zadd_commute zmod_eq_0_iff mod_add_right_eq)
- done
-
-lemma zcong_square_zless:
- "zprime p ==> 0 < a ==> a < p ==>
- [a * a = 1] (mod p) ==> a = 1 \<or> a = p - 1"
- apply (cut_tac p = p and a = a in zcong_square)
- apply (simp add: zprime_def)
- apply (auto intro: zcong_zless_imp_eq)
- done
-
-lemma zcong_not:
- "0 < a ==> a < m ==> 0 < b ==> b < a ==> \<not> [a = b] (mod m)"
- apply (unfold zcong_def)
- apply (rule zdvd_not_zless, auto)
- done
-
-lemma zcong_zless_0:
- "0 \<le> a ==> a < m ==> [a = 0] (mod m) ==> a = 0"
- apply (unfold zcong_def dvd_def, auto)
- apply (metis div_pos_pos_trivial linorder_not_less div_mult_self1_is_id)
- done
-
-lemma zcong_zless_unique:
- "0 < m ==> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
- apply auto
- prefer 2 apply (metis zcong_sym zcong_trans zcong_zless_imp_eq)
- apply (unfold zcong_def dvd_def)
- apply (rule_tac x = "a mod m" in exI, auto)
- apply (metis zmult_div_cancel)
- done
-
-lemma zcong_iff_lin: "([a = b] (mod m)) = (\<exists>k. b = a + m * k)"
- unfolding zcong_def
- apply (auto elim!: dvdE simp add: algebra_simps)
- apply (rule_tac x = "-k" in exI) apply simp
- done
-
-lemma zgcd_zcong_zgcd:
- "0 < m ==>
- zgcd a m = 1 ==> [a = b] (mod m) ==> zgcd b m = 1"
- by (auto simp add: zcong_iff_lin)
-
-lemma zcong_zmod_aux:
- "a - b = (m::int) * (a div m - b div m) + (a mod m - b mod m)"
- by(simp add: zdiff_zmult_distrib2 add_diff_eq eq_diff_eq add_ac)
-
-lemma zcong_zmod: "[a = b] (mod m) = [a mod m = b mod m] (mod m)"
- apply (unfold zcong_def)
- apply (rule_tac t = "a - b" in ssubst)
- apply (rule_tac m = m in zcong_zmod_aux)
- apply (rule trans)
- apply (rule_tac [2] k = m and m = "a div m - b div m" in zdvd_reduce)
- apply (simp add: zadd_commute)
- done
-
-lemma zcong_zmod_eq: "0 < m ==> [a = b] (mod m) = (a mod m = b mod m)"
- apply auto
- apply (metis pos_mod_conj zcong_zless_imp_eq zcong_zmod)
- apply (metis zcong_refl zcong_zmod)
- done
-
-lemma zcong_zminus [iff]: "[a = b] (mod -m) = [a = b] (mod m)"
- by (auto simp add: zcong_def)
-
-lemma zcong_zero [iff]: "[a = b] (mod 0) = (a = b)"
- by (auto simp add: zcong_def)
-
-lemma "[a = b] (mod m) = (a mod m = b mod m)"
- apply (case_tac "m = 0", simp add: DIVISION_BY_ZERO)
- apply (simp add: linorder_neq_iff)
- apply (erule disjE)
- prefer 2 apply (simp add: zcong_zmod_eq)
- txt{*Remainding case: @{term "m<0"}*}
- apply (rule_tac t = m in zminus_zminus [THEN subst])
- apply (subst zcong_zminus)
- apply (subst zcong_zmod_eq, arith)
- apply (frule neg_mod_bound [of _ a], frule neg_mod_bound [of _ b])
- apply (simp add: zmod_zminus2_eq_if del: neg_mod_bound)
- done
-
-subsection {* Modulo *}
-
-lemma zmod_zdvd_zmod:
- "0 < (m::int) ==> m dvd b ==> (a mod b mod m) = (a mod m)"
- by (rule mod_mod_cancel)
-
-
-subsection {* Extended GCD *}
-
-declare xzgcda.simps [simp del]
-
-lemma xzgcd_correct_aux1:
- "zgcd r' r = k --> 0 < r -->
- (\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn))"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
- apply (subst zgcd_eq)
- apply (subst xzgcda.simps, auto)
- apply (case_tac "r' mod r = 0")
- prefer 2
- apply (frule_tac a = "r'" in pos_mod_sign, auto)
- apply (rule exI)
- apply (rule exI)
- apply (subst xzgcda.simps, auto)
- done
-
-lemma xzgcd_correct_aux2:
- "(\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn)) --> 0 < r -->
- zgcd r' r = k"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
- apply (subst zgcd_eq)
- apply (subst xzgcda.simps)
- apply (auto simp add: linorder_not_le)
- apply (case_tac "r' mod r = 0")
- prefer 2
- apply (frule_tac a = "r'" in pos_mod_sign, auto)
- apply (metis Pair_eq simps zle_refl)
- done
-
-lemma xzgcd_correct:
- "0 < n ==> (zgcd m n = k) = (\<exists>s t. xzgcd m n = (k, s, t))"
- apply (unfold xzgcd_def)
- apply (rule iffI)
- apply (rule_tac [2] xzgcd_correct_aux2 [THEN mp, THEN mp])
- apply (rule xzgcd_correct_aux1 [THEN mp, THEN mp], auto)
- done
-
-
-text {* \medskip @{term xzgcd} linear *}
-
-lemma xzgcda_linear_aux1:
- "(a - r * b) * m + (c - r * d) * (n::int) =
- (a * m + c * n) - r * (b * m + d * n)"
- by (simp add: zdiff_zmult_distrib zadd_zmult_distrib2 zmult_assoc)
-
-lemma xzgcda_linear_aux2:
- "r' = s' * m + t' * n ==> r = s * m + t * n
- ==> (r' mod r) = (s' - (r' div r) * s) * m + (t' - (r' div r) * t) * (n::int)"
- apply (rule trans)
- apply (rule_tac [2] xzgcda_linear_aux1 [symmetric])
- apply (simp add: eq_diff_eq mult_commute)
- done
-
-lemma order_le_neq_implies_less: "(x::'a::order) \<le> y ==> x \<noteq> y ==> x < y"
- by (rule iffD2 [OF order_less_le conjI])
-
-lemma xzgcda_linear [rule_format]:
- "0 < r --> xzgcda (m, n, r', r, s', s, t', t) = (rn, sn, tn) -->
- r' = s' * m + t' * n --> r = s * m + t * n --> rn = sn * m + tn * n"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
- apply (subst xzgcda.simps)
- apply (simp (no_asm))
- apply (rule impI)+
- apply (case_tac "r' mod r = 0")
- apply (simp add: xzgcda.simps, clarify)
- apply (subgoal_tac "0 < r' mod r")
- apply (rule_tac [2] order_le_neq_implies_less)
- apply (rule_tac [2] pos_mod_sign)
- apply (cut_tac m = m and n = n and r' = r' and r = r and s' = s' and
- s = s and t' = t' and t = t in xzgcda_linear_aux2, auto)
- done
-
-lemma xzgcd_linear:
- "0 < n ==> xzgcd m n = (r, s, t) ==> r = s * m + t * n"
- apply (unfold xzgcd_def)
- apply (erule xzgcda_linear, assumption, auto)
- done
-
-lemma zgcd_ex_linear:
- "0 < n ==> zgcd m n = k ==> (\<exists>s t. k = s * m + t * n)"
- apply (simp add: xzgcd_correct, safe)
- apply (rule exI)+
- apply (erule xzgcd_linear, auto)
- done
-
-lemma zcong_lineq_ex:
- "0 < n ==> zgcd a n = 1 ==> \<exists>x. [a * x = 1] (mod n)"
- apply (cut_tac m = a and n = n and k = 1 in zgcd_ex_linear, safe)
- apply (rule_tac x = s in exI)
- apply (rule_tac b = "s * a + t * n" in zcong_trans)
- prefer 2
- apply simp
- apply (unfold zcong_def)
- apply (simp (no_asm) add: zmult_commute)
- done
-
-lemma zcong_lineq_unique:
- "0 < n ==>
- zgcd a n = 1 ==> \<exists>!x. 0 \<le> x \<and> x < n \<and> [a * x = b] (mod n)"
- apply auto
- apply (rule_tac [2] zcong_zless_imp_eq)
- apply (tactic {* stac (thm "zcong_cancel2" RS sym) 6 *})
- apply (rule_tac [8] zcong_trans)
- apply (simp_all (no_asm_simp))
- prefer 2
- apply (simp add: zcong_sym)
- apply (cut_tac a = a and n = n in zcong_lineq_ex, auto)
- apply (rule_tac x = "x * b mod n" in exI, safe)
- apply (simp_all (no_asm_simp))
- apply (metis zcong_scalar zcong_zmod zmod_zmult1_eq zmult_1 zmult_assoc)
- done
-
-end
--- a/src/HOL/NumberTheory/Quadratic_Reciprocity.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,644 +0,0 @@
-(* Title: HOL/NumberTheory/Quadratic_Reciprocity.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {* The law of Quadratic reciprocity *}
-
-theory Quadratic_Reciprocity
-imports Gauss
-begin
-
-text {*
- Lemmas leading up to the proof of theorem 3.3 in Niven and
- Zuckerman's presentation.
-*}
-
-context GAUSS
-begin
-
-lemma QRLemma1: "a * setsum id A =
- p * setsum (%x. ((x * a) div p)) A + setsum id D + setsum id E"
-proof -
- from finite_A have "a * setsum id A = setsum (%x. a * x) A"
- by (auto simp add: setsum_const_mult id_def)
- also have "setsum (%x. a * x) = setsum (%x. x * a)"
- by (auto simp add: zmult_commute)
- also have "setsum (%x. x * a) A = setsum id B"
- by (simp add: B_def setsum_reindex_id[OF inj_on_xa_A])
- also have "... = setsum (%x. p * (x div p) + StandardRes p x) B"
- by (auto simp add: StandardRes_def zmod_zdiv_equality)
- also have "... = setsum (%x. p * (x div p)) B + setsum (StandardRes p) B"
- by (rule setsum_addf)
- also have "setsum (StandardRes p) B = setsum id C"
- by (auto simp add: C_def setsum_reindex_id[OF SR_B_inj])
- also from C_eq have "... = setsum id (D \<union> E)"
- by auto
- also from finite_D finite_E have "... = setsum id D + setsum id E"
- by (rule setsum_Un_disjoint) (auto simp add: D_def E_def)
- also have "setsum (%x. p * (x div p)) B =
- setsum ((%x. p * (x div p)) o (%x. (x * a))) A"
- by (auto simp add: B_def setsum_reindex inj_on_xa_A)
- also have "... = setsum (%x. p * ((x * a) div p)) A"
- by (auto simp add: o_def)
- also from finite_A have "setsum (%x. p * ((x * a) div p)) A =
- p * setsum (%x. ((x * a) div p)) A"
- by (auto simp add: setsum_const_mult)
- finally show ?thesis by arith
-qed
-
-lemma QRLemma2: "setsum id A = p * int (card E) - setsum id E +
- setsum id D"
-proof -
- from F_Un_D_eq_A have "setsum id A = setsum id (D \<union> F)"
- by (simp add: Un_commute)
- also from F_D_disj finite_D finite_F
- have "... = setsum id D + setsum id F"
- by (auto simp add: Int_commute intro: setsum_Un_disjoint)
- also from F_def have "F = (%x. (p - x)) ` E"
- by auto
- also from finite_E inj_on_pminusx_E have "setsum id ((%x. (p - x)) ` E) =
- setsum (%x. (p - x)) E"
- by (auto simp add: setsum_reindex)
- also from finite_E have "setsum (op - p) E = setsum (%x. p) E - setsum id E"
- by (auto simp add: setsum_subtractf id_def)
- also from finite_E have "setsum (%x. p) E = p * int(card E)"
- by (intro setsum_const)
- finally show ?thesis
- by arith
-qed
-
-lemma QRLemma3: "(a - 1) * setsum id A =
- p * (setsum (%x. ((x * a) div p)) A - int(card E)) + 2 * setsum id E"
-proof -
- have "(a - 1) * setsum id A = a * setsum id A - setsum id A"
- by (auto simp add: zdiff_zmult_distrib)
- also note QRLemma1
- also from QRLemma2 have "p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
- setsum id E - setsum id A =
- p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
- setsum id E - (p * int (card E) - setsum id E + setsum id D)"
- by auto
- also have "... = p * (\<Sum>x \<in> A. x * a div p) -
- p * int (card E) + 2 * setsum id E"
- by arith
- finally show ?thesis
- by (auto simp only: zdiff_zmult_distrib2)
-qed
-
-lemma QRLemma4: "a \<in> zOdd ==>
- (setsum (%x. ((x * a) div p)) A \<in> zEven) = (int(card E): zEven)"
-proof -
- assume a_odd: "a \<in> zOdd"
- from QRLemma3 have a: "p * (setsum (%x. ((x * a) div p)) A - int(card E)) =
- (a - 1) * setsum id A - 2 * setsum id E"
- by arith
- from a_odd have "a - 1 \<in> zEven"
- by (rule odd_minus_one_even)
- hence "(a - 1) * setsum id A \<in> zEven"
- by (rule even_times_either)
- moreover have "2 * setsum id E \<in> zEven"
- by (auto simp add: zEven_def)
- ultimately have "(a - 1) * setsum id A - 2 * setsum id E \<in> zEven"
- by (rule even_minus_even)
- with a have "p * (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
- by simp
- hence "p \<in> zEven | (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
- by (rule EvenOdd.even_product)
- with p_odd have "(setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
- by (auto simp add: odd_iff_not_even)
- thus ?thesis
- by (auto simp only: even_diff [symmetric])
-qed
-
-lemma QRLemma5: "a \<in> zOdd ==>
- (-1::int)^(card E) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
-proof -
- assume "a \<in> zOdd"
- from QRLemma4 [OF this] have
- "(int(card E): zEven) = (setsum (%x. ((x * a) div p)) A \<in> zEven)" ..
- moreover have "0 \<le> int(card E)"
- by auto
- moreover have "0 \<le> setsum (%x. ((x * a) div p)) A"
- proof (intro setsum_nonneg)
- show "\<forall>x \<in> A. 0 \<le> x * a div p"
- proof
- fix x
- assume "x \<in> A"
- then have "0 \<le> x"
- by (auto simp add: A_def)
- with a_nonzero have "0 \<le> x * a"
- by (auto simp add: zero_le_mult_iff)
- with p_g_2 show "0 \<le> x * a div p"
- by (auto simp add: pos_imp_zdiv_nonneg_iff)
- qed
- qed
- ultimately have "(-1::int)^nat((int (card E))) =
- (-1)^nat(((\<Sum>x \<in> A. x * a div p)))"
- by (intro neg_one_power_parity, auto)
- also have "nat (int(card E)) = card E"
- by auto
- finally show ?thesis .
-qed
-
-end
-
-lemma MainQRLemma: "[| a \<in> zOdd; 0 < a; ~([a = 0] (mod p)); zprime p; 2 < p;
- A = {x. 0 < x & x \<le> (p - 1) div 2} |] ==>
- (Legendre a p) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
- apply (subst GAUSS.gauss_lemma)
- apply (auto simp add: GAUSS_def)
- apply (subst GAUSS.QRLemma5)
- apply (auto simp add: GAUSS_def)
- apply (simp add: GAUSS.A_def [OF GAUSS.intro] GAUSS_def)
- done
-
-
-subsection {* Stuff about S, S1 and S2 *}
-
-locale QRTEMP =
- fixes p :: "int"
- fixes q :: "int"
-
- assumes p_prime: "zprime p"
- assumes p_g_2: "2 < p"
- assumes q_prime: "zprime q"
- assumes q_g_2: "2 < q"
- assumes p_neq_q: "p \<noteq> q"
-begin
-
-definition
- P_set :: "int set" where
- "P_set = {x. 0 < x & x \<le> ((p - 1) div 2) }"
-
-definition
- Q_set :: "int set" where
- "Q_set = {x. 0 < x & x \<le> ((q - 1) div 2) }"
-
-definition
- S :: "(int * int) set" where
- "S = P_set <*> Q_set"
-
-definition
- S1 :: "(int * int) set" where
- "S1 = { (x, y). (x, y):S & ((p * y) < (q * x)) }"
-
-definition
- S2 :: "(int * int) set" where
- "S2 = { (x, y). (x, y):S & ((q * x) < (p * y)) }"
-
-definition
- f1 :: "int => (int * int) set" where
- "f1 j = { (j1, y). (j1, y):S & j1 = j & (y \<le> (q * j) div p) }"
-
-definition
- f2 :: "int => (int * int) set" where
- "f2 j = { (x, j1). (x, j1):S & j1 = j & (x \<le> (p * j) div q) }"
-
-lemma p_fact: "0 < (p - 1) div 2"
-proof -
- from p_g_2 have "2 \<le> p - 1" by arith
- then have "2 div 2 \<le> (p - 1) div 2" by (rule zdiv_mono1, auto)
- then show ?thesis by auto
-qed
-
-lemma q_fact: "0 < (q - 1) div 2"
-proof -
- from q_g_2 have "2 \<le> q - 1" by arith
- then have "2 div 2 \<le> (q - 1) div 2" by (rule zdiv_mono1, auto)
- then show ?thesis by auto
-qed
-
-lemma pb_neq_qa: "[|1 \<le> b; b \<le> (q - 1) div 2 |] ==>
- (p * b \<noteq> q * a)"
-proof
- assume "p * b = q * a" and "1 \<le> b" and "b \<le> (q - 1) div 2"
- then have "q dvd (p * b)" by (auto simp add: dvd_def)
- with q_prime p_g_2 have "q dvd p | q dvd b"
- by (auto simp add: zprime_zdvd_zmult)
- moreover have "~ (q dvd p)"
- proof
- assume "q dvd p"
- with p_prime have "q = 1 | q = p"
- apply (auto simp add: zprime_def QRTEMP_def)
- apply (drule_tac x = q and R = False in allE)
- apply (simp add: QRTEMP_def)
- apply (subgoal_tac "0 \<le> q", simp add: QRTEMP_def)
- apply (insert prems)
- apply (auto simp add: QRTEMP_def)
- done
- with q_g_2 p_neq_q show False by auto
- qed
- ultimately have "q dvd b" by auto
- then have "q \<le> b"
- proof -
- assume "q dvd b"
- moreover from prems have "0 < b" by auto
- ultimately show ?thesis using zdvd_bounds [of q b] by auto
- qed
- with prems have "q \<le> (q - 1) div 2" by auto
- then have "2 * q \<le> 2 * ((q - 1) div 2)" by arith
- then have "2 * q \<le> q - 1"
- proof -
- assume "2 * q \<le> 2 * ((q - 1) div 2)"
- with prems have "q \<in> zOdd" by (auto simp add: QRTEMP_def zprime_zOdd_eq_grt_2)
- with odd_minus_one_even have "(q - 1):zEven" by auto
- with even_div_2_prop2 have "(q - 1) = 2 * ((q - 1) div 2)" by auto
- with prems show ?thesis by auto
- qed
- then have p1: "q \<le> -1" by arith
- with q_g_2 show False by auto
-qed
-
-lemma P_set_finite: "finite (P_set)"
- using p_fact by (auto simp add: P_set_def bdd_int_set_l_le_finite)
-
-lemma Q_set_finite: "finite (Q_set)"
- using q_fact by (auto simp add: Q_set_def bdd_int_set_l_le_finite)
-
-lemma S_finite: "finite S"
- by (auto simp add: S_def P_set_finite Q_set_finite finite_cartesian_product)
-
-lemma S1_finite: "finite S1"
-proof -
- have "finite S" by (auto simp add: S_finite)
- moreover have "S1 \<subseteq> S" by (auto simp add: S1_def S_def)
- ultimately show ?thesis by (auto simp add: finite_subset)
-qed
-
-lemma S2_finite: "finite S2"
-proof -
- have "finite S" by (auto simp add: S_finite)
- moreover have "S2 \<subseteq> S" by (auto simp add: S2_def S_def)
- ultimately show ?thesis by (auto simp add: finite_subset)
-qed
-
-lemma P_set_card: "(p - 1) div 2 = int (card (P_set))"
- using p_fact by (auto simp add: P_set_def card_bdd_int_set_l_le)
-
-lemma Q_set_card: "(q - 1) div 2 = int (card (Q_set))"
- using q_fact by (auto simp add: Q_set_def card_bdd_int_set_l_le)
-
-lemma S_card: "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
- using P_set_card Q_set_card P_set_finite Q_set_finite
- by (auto simp add: S_def zmult_int setsum_constant)
-
-lemma S1_Int_S2_prop: "S1 \<inter> S2 = {}"
- by (auto simp add: S1_def S2_def)
-
-lemma S1_Union_S2_prop: "S = S1 \<union> S2"
- apply (auto simp add: S_def P_set_def Q_set_def S1_def S2_def)
-proof -
- fix a and b
- assume "~ q * a < p * b" and b1: "0 < b" and b2: "b \<le> (q - 1) div 2"
- with zless_linear have "(p * b < q * a) | (p * b = q * a)" by auto
- moreover from pb_neq_qa b1 b2 have "(p * b \<noteq> q * a)" by auto
- ultimately show "p * b < q * a" by auto
-qed
-
-lemma card_sum_S1_S2: "((p - 1) div 2) * ((q - 1) div 2) =
- int(card(S1)) + int(card(S2))"
-proof -
- have "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
- by (auto simp add: S_card)
- also have "... = int( card(S1) + card(S2))"
- apply (insert S1_finite S2_finite S1_Int_S2_prop S1_Union_S2_prop)
- apply (drule card_Un_disjoint, auto)
- done
- also have "... = int(card(S1)) + int(card(S2))" by auto
- finally show ?thesis .
-qed
-
-lemma aux1a: "[| 0 < a; a \<le> (p - 1) div 2;
- 0 < b; b \<le> (q - 1) div 2 |] ==>
- (p * b < q * a) = (b \<le> q * a div p)"
-proof -
- assume "0 < a" and "a \<le> (p - 1) div 2" and "0 < b" and "b \<le> (q - 1) div 2"
- have "p * b < q * a ==> b \<le> q * a div p"
- proof -
- assume "p * b < q * a"
- then have "p * b \<le> q * a" by auto
- then have "(p * b) div p \<le> (q * a) div p"
- by (rule zdiv_mono1) (insert p_g_2, auto)
- then show "b \<le> (q * a) div p"
- apply (subgoal_tac "p \<noteq> 0")
- apply (frule div_mult_self1_is_id, force)
- apply (insert p_g_2, auto)
- done
- qed
- moreover have "b \<le> q * a div p ==> p * b < q * a"
- proof -
- assume "b \<le> q * a div p"
- then have "p * b \<le> p * ((q * a) div p)"
- using p_g_2 by (auto simp add: mult_le_cancel_left)
- also have "... \<le> q * a"
- by (rule zdiv_leq_prop) (insert p_g_2, auto)
- finally have "p * b \<le> q * a" .
- then have "p * b < q * a | p * b = q * a"
- by (simp only: order_le_imp_less_or_eq)
- moreover have "p * b \<noteq> q * a"
- by (rule pb_neq_qa) (insert prems, auto)
- ultimately show ?thesis by auto
- qed
- ultimately show ?thesis ..
-qed
-
-lemma aux1b: "[| 0 < a; a \<le> (p - 1) div 2;
- 0 < b; b \<le> (q - 1) div 2 |] ==>
- (q * a < p * b) = (a \<le> p * b div q)"
-proof -
- assume "0 < a" and "a \<le> (p - 1) div 2" and "0 < b" and "b \<le> (q - 1) div 2"
- have "q * a < p * b ==> a \<le> p * b div q"
- proof -
- assume "q * a < p * b"
- then have "q * a \<le> p * b" by auto
- then have "(q * a) div q \<le> (p * b) div q"
- by (rule zdiv_mono1) (insert q_g_2, auto)
- then show "a \<le> (p * b) div q"
- apply (subgoal_tac "q \<noteq> 0")
- apply (frule div_mult_self1_is_id, force)
- apply (insert q_g_2, auto)
- done
- qed
- moreover have "a \<le> p * b div q ==> q * a < p * b"
- proof -
- assume "a \<le> p * b div q"
- then have "q * a \<le> q * ((p * b) div q)"
- using q_g_2 by (auto simp add: mult_le_cancel_left)
- also have "... \<le> p * b"
- by (rule zdiv_leq_prop) (insert q_g_2, auto)
- finally have "q * a \<le> p * b" .
- then have "q * a < p * b | q * a = p * b"
- by (simp only: order_le_imp_less_or_eq)
- moreover have "p * b \<noteq> q * a"
- by (rule pb_neq_qa) (insert prems, auto)
- ultimately show ?thesis by auto
- qed
- ultimately show ?thesis ..
-qed
-
-lemma (in -) aux2: "[| zprime p; zprime q; 2 < p; 2 < q |] ==>
- (q * ((p - 1) div 2)) div p \<le> (q - 1) div 2"
-proof-
- assume "zprime p" and "zprime q" and "2 < p" and "2 < q"
- (* Set up what's even and odd *)
- then have "p \<in> zOdd & q \<in> zOdd"
- by (auto simp add: zprime_zOdd_eq_grt_2)
- then have even1: "(p - 1):zEven & (q - 1):zEven"
- by (auto simp add: odd_minus_one_even)
- then have even2: "(2 * p):zEven & ((q - 1) * p):zEven"
- by (auto simp add: zEven_def)
- then have even3: "(((q - 1) * p) + (2 * p)):zEven"
- by (auto simp: EvenOdd.even_plus_even)
- (* using these prove it *)
- from prems have "q * (p - 1) < ((q - 1) * p) + (2 * p)"
- by (auto simp add: int_distrib)
- then have "((p - 1) * q) div 2 < (((q - 1) * p) + (2 * p)) div 2"
- apply (rule_tac x = "((p - 1) * q)" in even_div_2_l)
- by (auto simp add: even3, auto simp add: zmult_ac)
- also have "((p - 1) * q) div 2 = q * ((p - 1) div 2)"
- by (auto simp add: even1 even_prod_div_2)
- also have "(((q - 1) * p) + (2 * p)) div 2 = (((q - 1) div 2) * p) + p"
- by (auto simp add: even1 even2 even_prod_div_2 even_sum_div_2)
- finally show ?thesis
- apply (rule_tac x = " q * ((p - 1) div 2)" and
- y = "(q - 1) div 2" in div_prop2)
- using prems by auto
-qed
-
-lemma aux3a: "\<forall>j \<in> P_set. int (card (f1 j)) = (q * j) div p"
-proof
- fix j
- assume j_fact: "j \<in> P_set"
- have "int (card (f1 j)) = int (card {y. y \<in> Q_set & y \<le> (q * j) div p})"
- proof -
- have "finite (f1 j)"
- proof -
- have "(f1 j) \<subseteq> S" by (auto simp add: f1_def)
- with S_finite show ?thesis by (auto simp add: finite_subset)
- qed
- moreover have "inj_on (%(x,y). y) (f1 j)"
- by (auto simp add: f1_def inj_on_def)
- ultimately have "card ((%(x,y). y) ` (f1 j)) = card (f1 j)"
- by (auto simp add: f1_def card_image)
- moreover have "((%(x,y). y) ` (f1 j)) = {y. y \<in> Q_set & y \<le> (q * j) div p}"
- using prems by (auto simp add: f1_def S_def Q_set_def P_set_def image_def)
- ultimately show ?thesis by (auto simp add: f1_def)
- qed
- also have "... = int (card {y. 0 < y & y \<le> (q * j) div p})"
- proof -
- have "{y. y \<in> Q_set & y \<le> (q * j) div p} =
- {y. 0 < y & y \<le> (q * j) div p}"
- apply (auto simp add: Q_set_def)
- proof -
- fix x
- assume "0 < x" and "x \<le> q * j div p"
- with j_fact P_set_def have "j \<le> (p - 1) div 2" by auto
- with q_g_2 have "q * j \<le> q * ((p - 1) div 2)"
- by (auto simp add: mult_le_cancel_left)
- with p_g_2 have "q * j div p \<le> q * ((p - 1) div 2) div p"
- by (auto simp add: zdiv_mono1)
- also from prems P_set_def have "... \<le> (q - 1) div 2"
- apply simp
- apply (insert aux2)
- apply (simp add: QRTEMP_def)
- done
- finally show "x \<le> (q - 1) div 2" using prems by auto
- qed
- then show ?thesis by auto
- qed
- also have "... = (q * j) div p"
- proof -
- from j_fact P_set_def have "0 \<le> j" by auto
- with q_g_2 have "q * 0 \<le> q * j" by (auto simp only: mult_left_mono)
- then have "0 \<le> q * j" by auto
- then have "0 div p \<le> (q * j) div p"
- apply (rule_tac a = 0 in zdiv_mono1)
- apply (insert p_g_2, auto)
- done
- also have "0 div p = 0" by auto
- finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
- qed
- finally show "int (card (f1 j)) = q * j div p" .
-qed
-
-lemma aux3b: "\<forall>j \<in> Q_set. int (card (f2 j)) = (p * j) div q"
-proof
- fix j
- assume j_fact: "j \<in> Q_set"
- have "int (card (f2 j)) = int (card {y. y \<in> P_set & y \<le> (p * j) div q})"
- proof -
- have "finite (f2 j)"
- proof -
- have "(f2 j) \<subseteq> S" by (auto simp add: f2_def)
- with S_finite show ?thesis by (auto simp add: finite_subset)
- qed
- moreover have "inj_on (%(x,y). x) (f2 j)"
- by (auto simp add: f2_def inj_on_def)
- ultimately have "card ((%(x,y). x) ` (f2 j)) = card (f2 j)"
- by (auto simp add: f2_def card_image)
- moreover have "((%(x,y). x) ` (f2 j)) = {y. y \<in> P_set & y \<le> (p * j) div q}"
- using prems by (auto simp add: f2_def S_def Q_set_def P_set_def image_def)
- ultimately show ?thesis by (auto simp add: f2_def)
- qed
- also have "... = int (card {y. 0 < y & y \<le> (p * j) div q})"
- proof -
- have "{y. y \<in> P_set & y \<le> (p * j) div q} =
- {y. 0 < y & y \<le> (p * j) div q}"
- apply (auto simp add: P_set_def)
- proof -
- fix x
- assume "0 < x" and "x \<le> p * j div q"
- with j_fact Q_set_def have "j \<le> (q - 1) div 2" by auto
- with p_g_2 have "p * j \<le> p * ((q - 1) div 2)"
- by (auto simp add: mult_le_cancel_left)
- with q_g_2 have "p * j div q \<le> p * ((q - 1) div 2) div q"
- by (auto simp add: zdiv_mono1)
- also from prems have "... \<le> (p - 1) div 2"
- by (auto simp add: aux2 QRTEMP_def)
- finally show "x \<le> (p - 1) div 2" using prems by auto
- qed
- then show ?thesis by auto
- qed
- also have "... = (p * j) div q"
- proof -
- from j_fact Q_set_def have "0 \<le> j" by auto
- with p_g_2 have "p * 0 \<le> p * j" by (auto simp only: mult_left_mono)
- then have "0 \<le> p * j" by auto
- then have "0 div q \<le> (p * j) div q"
- apply (rule_tac a = 0 in zdiv_mono1)
- apply (insert q_g_2, auto)
- done
- also have "0 div q = 0" by auto
- finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
- qed
- finally show "int (card (f2 j)) = p * j div q" .
-qed
-
-lemma S1_card: "int (card(S1)) = setsum (%j. (q * j) div p) P_set"
-proof -
- have "\<forall>x \<in> P_set. finite (f1 x)"
- proof
- fix x
- have "f1 x \<subseteq> S" by (auto simp add: f1_def)
- with S_finite show "finite (f1 x)" by (auto simp add: finite_subset)
- qed
- moreover have "(\<forall>x \<in> P_set. \<forall>y \<in> P_set. x \<noteq> y --> (f1 x) \<inter> (f1 y) = {})"
- by (auto simp add: f1_def)
- moreover note P_set_finite
- ultimately have "int(card (UNION P_set f1)) =
- setsum (%x. int(card (f1 x))) P_set"
- by(simp add:card_UN_disjoint int_setsum o_def)
- moreover have "S1 = UNION P_set f1"
- by (auto simp add: f1_def S_def S1_def S2_def P_set_def Q_set_def aux1a)
- ultimately have "int(card (S1)) = setsum (%j. int(card (f1 j))) P_set"
- by auto
- also have "... = setsum (%j. q * j div p) P_set"
- using aux3a by(fastsimp intro: setsum_cong)
- finally show ?thesis .
-qed
-
-lemma S2_card: "int (card(S2)) = setsum (%j. (p * j) div q) Q_set"
-proof -
- have "\<forall>x \<in> Q_set. finite (f2 x)"
- proof
- fix x
- have "f2 x \<subseteq> S" by (auto simp add: f2_def)
- with S_finite show "finite (f2 x)" by (auto simp add: finite_subset)
- qed
- moreover have "(\<forall>x \<in> Q_set. \<forall>y \<in> Q_set. x \<noteq> y -->
- (f2 x) \<inter> (f2 y) = {})"
- by (auto simp add: f2_def)
- moreover note Q_set_finite
- ultimately have "int(card (UNION Q_set f2)) =
- setsum (%x. int(card (f2 x))) Q_set"
- by(simp add:card_UN_disjoint int_setsum o_def)
- moreover have "S2 = UNION Q_set f2"
- by (auto simp add: f2_def S_def S1_def S2_def P_set_def Q_set_def aux1b)
- ultimately have "int(card (S2)) = setsum (%j. int(card (f2 j))) Q_set"
- by auto
- also have "... = setsum (%j. p * j div q) Q_set"
- using aux3b by(fastsimp intro: setsum_cong)
- finally show ?thesis .
-qed
-
-lemma S1_carda: "int (card(S1)) =
- setsum (%j. (j * q) div p) P_set"
- by (auto simp add: S1_card zmult_ac)
-
-lemma S2_carda: "int (card(S2)) =
- setsum (%j. (j * p) div q) Q_set"
- by (auto simp add: S2_card zmult_ac)
-
-lemma pq_sum_prop: "(setsum (%j. (j * p) div q) Q_set) +
- (setsum (%j. (j * q) div p) P_set) = ((p - 1) div 2) * ((q - 1) div 2)"
-proof -
- have "(setsum (%j. (j * p) div q) Q_set) +
- (setsum (%j. (j * q) div p) P_set) = int (card S2) + int (card S1)"
- by (auto simp add: S1_carda S2_carda)
- also have "... = int (card S1) + int (card S2)"
- by auto
- also have "... = ((p - 1) div 2) * ((q - 1) div 2)"
- by (auto simp add: card_sum_S1_S2)
- finally show ?thesis .
-qed
-
-
-lemma (in -) pq_prime_neq: "[| zprime p; zprime q; p \<noteq> q |] ==> (~[p = 0] (mod q))"
- apply (auto simp add: zcong_eq_zdvd_prop zprime_def)
- apply (drule_tac x = q in allE)
- apply (drule_tac x = p in allE)
- apply auto
- done
-
-
-lemma QR_short: "(Legendre p q) * (Legendre q p) =
- (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
-proof -
- from prems have "~([p = 0] (mod q))"
- by (auto simp add: pq_prime_neq QRTEMP_def)
- with prems Q_set_def have a1: "(Legendre p q) = (-1::int) ^
- nat(setsum (%x. ((x * p) div q)) Q_set)"
- apply (rule_tac p = q in MainQRLemma)
- apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
- done
- from prems have "~([q = 0] (mod p))"
- apply (rule_tac p = q and q = p in pq_prime_neq)
- apply (simp add: QRTEMP_def)+
- done
- with prems P_set_def have a2: "(Legendre q p) =
- (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
- apply (rule_tac p = p in MainQRLemma)
- apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
- done
- from a1 a2 have "(Legendre p q) * (Legendre q p) =
- (-1::int) ^ nat(setsum (%x. ((x * p) div q)) Q_set) *
- (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
- by auto
- also have "... = (-1::int) ^ (nat(setsum (%x. ((x * p) div q)) Q_set) +
- nat(setsum (%x. ((x * q) div p)) P_set))"
- by (auto simp add: zpower_zadd_distrib)
- also have "nat(setsum (%x. ((x * p) div q)) Q_set) +
- nat(setsum (%x. ((x * q) div p)) P_set) =
- nat((setsum (%x. ((x * p) div q)) Q_set) +
- (setsum (%x. ((x * q) div p)) P_set))"
- apply (rule_tac z = "setsum (%x. ((x * p) div q)) Q_set" in
- nat_add_distrib [symmetric])
- apply (auto simp add: S1_carda [symmetric] S2_carda [symmetric])
- done
- also have "... = nat(((p - 1) div 2) * ((q - 1) div 2))"
- by (auto simp add: pq_sum_prop)
- finally show ?thesis .
-qed
-
-end
-
-theorem Quadratic_Reciprocity:
- "[| p \<in> zOdd; zprime p; q \<in> zOdd; zprime q;
- p \<noteq> q |]
- ==> (Legendre p q) * (Legendre q p) =
- (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
- by (auto simp add: QRTEMP.QR_short zprime_zOdd_eq_grt_2 [symmetric]
- QRTEMP_def)
-
-end
--- a/src/HOL/NumberTheory/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,5 +0,0 @@
-(* $Id$ *)
-
-no_document use_thys ["Infinite_Set", "Permutation", "Primes"];
-use_thys ["Fib", "Factorization", "Chinese", "WilsonRuss",
- "WilsonBij", "Quadratic_Reciprocity"];
--- a/src/HOL/NumberTheory/Residues.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,172 +0,0 @@
-(* Title: HOL/Quadratic_Reciprocity/Residues.thy
- ID: $Id$
- Authors: Jeremy Avigad, David Gray, and Adam Kramer
-*)
-
-header {* Residue Sets *}
-
-theory Residues imports Int2 begin
-
-text {*
- \medskip Define the residue of a set, the standard residue,
- quadratic residues, and prove some basic properties. *}
-
-definition
- ResSet :: "int => int set => bool" where
- "ResSet m X = (\<forall>y1 y2. (y1 \<in> X & y2 \<in> X & [y1 = y2] (mod m) --> y1 = y2))"
-
-definition
- StandardRes :: "int => int => int" where
- "StandardRes m x = x mod m"
-
-definition
- QuadRes :: "int => int => bool" where
- "QuadRes m x = (\<exists>y. ([(y ^ 2) = x] (mod m)))"
-
-definition
- Legendre :: "int => int => int" where
- "Legendre a p = (if ([a = 0] (mod p)) then 0
- else if (QuadRes p a) then 1
- else -1)"
-
-definition
- SR :: "int => int set" where
- "SR p = {x. (0 \<le> x) & (x < p)}"
-
-definition
- SRStar :: "int => int set" where
- "SRStar p = {x. (0 < x) & (x < p)}"
-
-
-subsection {* Some useful properties of StandardRes *}
-
-lemma StandardRes_prop1: "[x = StandardRes m x] (mod m)"
- by (auto simp add: StandardRes_def zcong_zmod)
-
-lemma StandardRes_prop2: "0 < m ==> (StandardRes m x1 = StandardRes m x2)
- = ([x1 = x2] (mod m))"
- by (auto simp add: StandardRes_def zcong_zmod_eq)
-
-lemma StandardRes_prop3: "(~[x = 0] (mod p)) = (~(StandardRes p x = 0))"
- by (auto simp add: StandardRes_def zcong_def dvd_eq_mod_eq_0)
-
-lemma StandardRes_prop4: "2 < m
- ==> [StandardRes m x * StandardRes m y = (x * y)] (mod m)"
- by (auto simp add: StandardRes_def zcong_zmod_eq
- mod_mult_eq [of x y m])
-
-lemma StandardRes_lbound: "0 < p ==> 0 \<le> StandardRes p x"
- by (auto simp add: StandardRes_def pos_mod_sign)
-
-lemma StandardRes_ubound: "0 < p ==> StandardRes p x < p"
- by (auto simp add: StandardRes_def pos_mod_bound)
-
-lemma StandardRes_eq_zcong:
- "(StandardRes m x = 0) = ([x = 0](mod m))"
- by (auto simp add: StandardRes_def zcong_eq_zdvd_prop dvd_def)
-
-
-subsection {* Relations between StandardRes, SRStar, and SR *}
-
-lemma SRStar_SR_prop: "x \<in> SRStar p ==> x \<in> SR p"
- by (auto simp add: SRStar_def SR_def)
-
-lemma StandardRes_SR_prop: "x \<in> SR p ==> StandardRes p x = x"
- by (auto simp add: SR_def StandardRes_def mod_pos_pos_trivial)
-
-lemma StandardRes_SRStar_prop1: "2 < p ==> (StandardRes p x \<in> SRStar p)
- = (~[x = 0] (mod p))"
- apply (auto simp add: StandardRes_prop3 StandardRes_def
- SRStar_def pos_mod_bound)
- apply (subgoal_tac "0 < p")
- apply (drule_tac a = x in pos_mod_sign, arith, simp)
- done
-
-lemma StandardRes_SRStar_prop1a: "x \<in> SRStar p ==> ~([x = 0] (mod p))"
- by (auto simp add: SRStar_def zcong_def zdvd_not_zless)
-
-lemma StandardRes_SRStar_prop2: "[| 2 < p; zprime p; x \<in> SRStar p |]
- ==> StandardRes p (MultInv p x) \<in> SRStar p"
- apply (frule_tac x = "(MultInv p x)" in StandardRes_SRStar_prop1, simp)
- apply (rule MultInv_prop3)
- apply (auto simp add: SRStar_def zcong_def zdvd_not_zless)
- done
-
-lemma StandardRes_SRStar_prop3: "x \<in> SRStar p ==> StandardRes p x = x"
- by (auto simp add: SRStar_SR_prop StandardRes_SR_prop)
-
-lemma StandardRes_SRStar_prop4: "[| zprime p; 2 < p; x \<in> SRStar p |]
- ==> StandardRes p x \<in> SRStar p"
- by (frule StandardRes_SRStar_prop3, auto)
-
-lemma SRStar_mult_prop1: "[| zprime p; 2 < p; x \<in> SRStar p; y \<in> SRStar p|]
- ==> (StandardRes p (x * y)):SRStar p"
- apply (frule_tac x = x in StandardRes_SRStar_prop4, auto)
- apply (frule_tac x = y in StandardRes_SRStar_prop4, auto)
- apply (auto simp add: StandardRes_SRStar_prop1 zcong_zmult_prop3)
- done
-
-lemma SRStar_mult_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p));
- x \<in> SRStar p |]
- ==> StandardRes p (a * MultInv p x) \<in> SRStar p"
- apply (frule_tac x = x in StandardRes_SRStar_prop2, auto)
- apply (frule_tac x = "MultInv p x" in StandardRes_SRStar_prop1)
- apply (auto simp add: StandardRes_SRStar_prop1 zcong_zmult_prop3)
- done
-
-lemma SRStar_card: "2 < p ==> int(card(SRStar p)) = p - 1"
- by (auto simp add: SRStar_def int_card_bdd_int_set_l_l)
-
-lemma SRStar_finite: "2 < p ==> finite( SRStar p)"
- by (auto simp add: SRStar_def bdd_int_set_l_l_finite)
-
-
-subsection {* Properties relating ResSets with StandardRes *}
-
-lemma aux: "x mod m = y mod m ==> [x = y] (mod m)"
- apply (subgoal_tac "x = y ==> [x = y](mod m)")
- apply (subgoal_tac "[x mod m = y mod m] (mod m) ==> [x = y] (mod m)")
- apply (auto simp add: zcong_zmod [of x y m])
- done
-
-lemma StandardRes_inj_on_ResSet: "ResSet m X ==> (inj_on (StandardRes m) X)"
- apply (auto simp add: ResSet_def StandardRes_def inj_on_def)
- apply (drule_tac m = m in aux, auto)
- done
-
-lemma StandardRes_Sum: "[| finite X; 0 < m |]
- ==> [setsum f X = setsum (StandardRes m o f) X](mod m)"
- apply (rule_tac F = X in finite_induct)
- apply (auto intro!: zcong_zadd simp add: StandardRes_prop1)
- done
-
-lemma SR_pos: "0 < m ==> (StandardRes m ` X) \<subseteq> {x. 0 \<le> x & x < m}"
- by (auto simp add: StandardRes_ubound StandardRes_lbound)
-
-lemma ResSet_finite: "0 < m ==> ResSet m X ==> finite X"
- apply (rule_tac f = "StandardRes m" in finite_imageD)
- apply (rule_tac B = "{x. (0 :: int) \<le> x & x < m}" in finite_subset)
- apply (auto simp add: StandardRes_inj_on_ResSet bdd_int_set_l_finite SR_pos)
- done
-
-lemma mod_mod_is_mod: "[x = x mod m](mod m)"
- by (auto simp add: zcong_zmod)
-
-lemma StandardRes_prod: "[| finite X; 0 < m |]
- ==> [setprod f X = setprod (StandardRes m o f) X] (mod m)"
- apply (rule_tac F = X in finite_induct)
- apply (auto intro!: zcong_zmult simp add: StandardRes_prop1)
- done
-
-lemma ResSet_image:
- "[| 0 < m; ResSet m A; \<forall>x \<in> A. \<forall>y \<in> A. ([f x = f y](mod m) --> x = y) |] ==>
- ResSet m (f ` A)"
- by (auto simp add: ResSet_def)
-
-
-subsection {* Property for SRStar *}
-
-lemma ResSet_SRStar_prop: "ResSet p (SRStar p)"
- by (auto simp add: SRStar_def ResSet_def zcong_zless_imp_eq)
-
-end
--- a/src/HOL/NumberTheory/WilsonBij.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,263 +0,0 @@
-(* Title: HOL/NumberTheory/WilsonBij.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Wilson's Theorem using a more abstract approach *}
-
-theory WilsonBij imports BijectionRel IntFact begin
-
-text {*
- Wilson's Theorem using a more ``abstract'' approach based on
- bijections between sets. Does not use Fermat's Little Theorem
- (unlike Russinoff).
-*}
-
-
-subsection {* Definitions and lemmas *}
-
-definition
- reciR :: "int => int => int => bool" where
- "reciR p = (\<lambda>a b. zcong (a * b) 1 p \<and> 1 < a \<and> a < p - 1 \<and> 1 < b \<and> b < p - 1)"
-
-definition
- inv :: "int => int => int" where
- "inv p a =
- (if zprime p \<and> 0 < a \<and> a < p then
- (SOME x. 0 \<le> x \<and> x < p \<and> zcong (a * x) 1 p)
- else 0)"
-
-
-text {* \medskip Inverse *}
-
-lemma inv_correct:
- "zprime p ==> 0 < a ==> a < p
- ==> 0 \<le> inv p a \<and> inv p a < p \<and> [a * inv p a = 1] (mod p)"
- apply (unfold inv_def)
- apply (simp (no_asm_simp))
- apply (rule zcong_lineq_unique [THEN ex1_implies_ex, THEN someI_ex])
- apply (erule_tac [2] zless_zprime_imp_zrelprime)
- apply (unfold zprime_def)
- apply auto
- done
-
-lemmas inv_ge = inv_correct [THEN conjunct1, standard]
-lemmas inv_less = inv_correct [THEN conjunct2, THEN conjunct1, standard]
-lemmas inv_is_inv = inv_correct [THEN conjunct2, THEN conjunct2, standard]
-
-lemma inv_not_0:
- "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 0"
- -- {* same as @{text WilsonRuss} *}
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv)
- apply (unfold zcong_def)
- apply auto
- apply (subgoal_tac "\<not> p dvd 1")
- apply (rule_tac [2] zdvd_not_zless)
- apply (subgoal_tac "p dvd 1")
- prefer 2
- apply (subst dvd_minus_iff [symmetric])
- apply auto
- done
-
-lemma inv_not_1:
- "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 1"
- -- {* same as @{text WilsonRuss} *}
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv)
- prefer 4
- apply simp
- apply (subgoal_tac "a = 1")
- apply (rule_tac [2] zcong_zless_imp_eq)
- apply auto
- done
-
-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 (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
- apply (simp add: mult_commute)
- apply (subst dvd_minus_iff)
- apply (subst zdvd_reduce)
- apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
- apply (subst zdvd_reduce)
- apply auto
- done
-
-lemma inv_not_p_minus_1:
- "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> p - 1"
- -- {* same as @{text WilsonRuss} *}
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv)
- apply auto
- apply (simp add: aux)
- apply (subgoal_tac "a = p - 1")
- apply (rule_tac [2] zcong_zless_imp_eq)
- apply auto
- done
-
-text {*
- Below is slightly different as we don't expand @{term [source] inv}
- but use ``@{text correct}'' theorems.
-*}
-
-lemma inv_g_1: "zprime p ==> 1 < a ==> a < p - 1 ==> 1 < inv p a"
- apply (subgoal_tac "inv p a \<noteq> 1")
- apply (subgoal_tac "inv p a \<noteq> 0")
- apply (subst order_less_le)
- apply (subst zle_add1_eq_le [symmetric])
- apply (subst order_less_le)
- apply (rule_tac [2] inv_not_0)
- apply (rule_tac [5] inv_not_1)
- apply auto
- apply (rule inv_ge)
- apply auto
- done
-
-lemma inv_less_p_minus_1:
- "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a < p - 1"
- -- {* ditto *}
- apply (subst order_less_le)
- apply (simp add: inv_not_p_minus_1 inv_less)
- done
-
-
-text {* \medskip Bijection *}
-
-lemma aux1: "1 < x ==> 0 \<le> (x::int)"
- apply auto
- done
-
-lemma aux2: "1 < x ==> 0 < (x::int)"
- apply auto
- done
-
-lemma aux3: "x \<le> p - 2 ==> x < (p::int)"
- apply auto
- done
-
-lemma aux4: "x \<le> p - 2 ==> x < (p::int) - 1"
- apply auto
- done
-
-lemma inv_inj: "zprime p ==> inj_on (inv p) (d22set (p - 2))"
- apply (unfold inj_on_def)
- apply auto
- apply (rule zcong_zless_imp_eq)
- apply (tactic {* stac (thm "zcong_cancel" RS sym) 5 *})
- apply (rule_tac [7] zcong_trans)
- apply (tactic {* stac (thm "zcong_sym") 8 *})
- apply (erule_tac [7] inv_is_inv)
- apply (tactic "asm_simp_tac @{simpset} 9")
- apply (erule_tac [9] inv_is_inv)
- apply (rule_tac [6] zless_zprime_imp_zrelprime)
- apply (rule_tac [8] inv_less)
- apply (rule_tac [7] inv_g_1 [THEN aux2])
- apply (unfold zprime_def)
- apply (auto intro: d22set_g_1 d22set_le
- aux1 aux2 aux3 aux4)
- done
-
-lemma inv_d22set_d22set:
- "zprime p ==> inv p ` d22set (p - 2) = d22set (p - 2)"
- apply (rule endo_inj_surj)
- apply (rule d22set_fin)
- apply (erule_tac [2] inv_inj)
- apply auto
- apply (rule d22set_mem)
- apply (erule inv_g_1)
- apply (subgoal_tac [3] "inv p xa < p - 1")
- apply (erule_tac [4] inv_less_p_minus_1)
- apply (auto intro: d22set_g_1 d22set_le aux4)
- done
-
-lemma d22set_d22set_bij:
- "zprime p ==> (d22set (p - 2), d22set (p - 2)) \<in> bijR (reciR p)"
- apply (unfold reciR_def)
- apply (rule_tac s = "(d22set (p - 2), inv p ` d22set (p - 2))" in subst)
- apply (simp add: inv_d22set_d22set)
- apply (rule inj_func_bijR)
- apply (rule_tac [3] d22set_fin)
- apply (erule_tac [2] inv_inj)
- apply auto
- apply (erule inv_is_inv)
- apply (erule_tac [5] inv_g_1)
- apply (erule_tac [7] inv_less_p_minus_1)
- apply (auto intro: d22set_g_1 d22set_le aux2 aux3 aux4)
- done
-
-lemma reciP_bijP: "zprime p ==> bijP (reciR p) (d22set (p - 2))"
- apply (unfold reciR_def bijP_def)
- apply auto
- apply (rule d22set_mem)
- apply auto
- done
-
-lemma reciP_uniq: "zprime p ==> uniqP (reciR p)"
- apply (unfold reciR_def uniqP_def)
- apply auto
- apply (rule zcong_zless_imp_eq)
- apply (tactic {* stac (thm "zcong_cancel2" RS sym) 5 *})
- apply (rule_tac [7] zcong_trans)
- apply (tactic {* stac (thm "zcong_sym") 8 *})
- apply (rule_tac [6] zless_zprime_imp_zrelprime)
- apply auto
- apply (rule zcong_zless_imp_eq)
- apply (tactic {* stac (thm "zcong_cancel" RS sym) 5 *})
- apply (rule_tac [7] zcong_trans)
- apply (tactic {* stac (thm "zcong_sym") 8 *})
- apply (rule_tac [6] zless_zprime_imp_zrelprime)
- apply auto
- done
-
-lemma reciP_sym: "zprime p ==> symP (reciR p)"
- apply (unfold reciR_def symP_def)
- apply (simp add: zmult_commute)
- apply auto
- done
-
-lemma bijER_d22set: "zprime p ==> d22set (p - 2) \<in> bijER (reciR p)"
- apply (rule bijR_bijER)
- apply (erule d22set_d22set_bij)
- apply (erule reciP_bijP)
- apply (erule reciP_uniq)
- apply (erule reciP_sym)
- done
-
-
-subsection {* Wilson *}
-
-lemma bijER_zcong_prod_1:
- "zprime p ==> A \<in> bijER (reciR p) ==> [\<Prod>A = 1] (mod p)"
- apply (unfold reciR_def)
- apply (erule bijER.induct)
- apply (subgoal_tac [2] "a = 1 \<or> a = p - 1")
- apply (rule_tac [3] zcong_square_zless)
- apply auto
- apply (subst setprod_insert)
- prefer 3
- apply (subst setprod_insert)
- apply (auto simp add: fin_bijER)
- apply (subgoal_tac "zcong ((a * b) * \<Prod>A) (1 * 1) p")
- apply (simp add: zmult_assoc)
- apply (rule zcong_zmult)
- apply auto
- done
-
-theorem Wilson_Bij: "zprime p ==> [zfact (p - 1) = -1] (mod p)"
- apply (subgoal_tac "zcong ((p - 1) * zfact (p - 2)) (-1 * 1) p")
- apply (rule_tac [2] zcong_zmult)
- apply (simp add: zprime_def)
- apply (subst zfact.simps)
- apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst)
- apply auto
- apply (simp add: zcong_def)
- apply (subst d22set_prod_zfact [symmetric])
- apply (rule bijER_zcong_prod_1)
- apply (rule_tac [2] bijER_d22set)
- apply auto
- done
-
-end
--- a/src/HOL/NumberTheory/WilsonRuss.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,329 +0,0 @@
-(* Title: HOL/NumberTheory/WilsonRuss.thy
- ID: $Id$
- Author: Thomas M. Rasmussen
- Copyright 2000 University of Cambridge
-*)
-
-header {* Wilson's Theorem according to Russinoff *}
-
-theory WilsonRuss imports EulerFermat begin
-
-text {*
- Wilson's Theorem following quite closely Russinoff's approach
- using Boyer-Moore (using finite sets instead of lists, though).
-*}
-
-subsection {* Definitions and lemmas *}
-
-definition
- inv :: "int => int => int" where
- "inv p a = (a^(nat (p - 2))) mod p"
-
-consts
- wset :: "int * int => int set"
-
-recdef wset
- "measure ((\<lambda>(a, p). nat a) :: int * int => nat)"
- "wset (a, p) =
- (if 1 < a then
- let ws = wset (a - 1, p)
- in (if a \<in> ws then ws else insert a (insert (inv p a) ws)) else {})"
-
-
-text {* \medskip @{term [source] inv} *}
-
-lemma inv_is_inv_aux: "1 < m ==> Suc (nat (m - 2)) = nat (m - 1)"
-by (subst int_int_eq [symmetric], auto)
-
-lemma inv_is_inv:
- "zprime p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> [a * inv p a = 1] (mod p)"
- apply (unfold inv_def)
- apply (subst zcong_zmod)
- apply (subst zmod_zmult1_eq [symmetric])
- apply (subst zcong_zmod [symmetric])
- apply (subst power_Suc [symmetric])
- apply (subst inv_is_inv_aux)
- apply (erule_tac [2] Little_Fermat)
- apply (erule_tac [2] zdvd_not_zless)
- apply (unfold zprime_def, auto)
- done
-
-lemma inv_distinct:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> a \<noteq> inv p a"
- apply safe
- apply (cut_tac a = a and p = p in zcong_square)
- apply (cut_tac [3] a = a and p = p in inv_is_inv, auto)
- apply (subgoal_tac "a = 1")
- apply (rule_tac [2] m = p in zcong_zless_imp_eq)
- apply (subgoal_tac [7] "a = p - 1")
- apply (rule_tac [8] m = p in zcong_zless_imp_eq, auto)
- done
-
-lemma inv_not_0:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 0"
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv)
- apply (unfold zcong_def, auto)
- apply (subgoal_tac "\<not> p dvd 1")
- apply (rule_tac [2] zdvd_not_zless)
- apply (subgoal_tac "p dvd 1")
- prefer 2
- apply (subst dvd_minus_iff [symmetric], auto)
- done
-
-lemma inv_not_1:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 1"
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv)
- prefer 4
- apply simp
- apply (subgoal_tac "a = 1")
- apply (rule_tac [2] zcong_zless_imp_eq, auto)
- done
-
-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 (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
- apply (simp add: mult_commute)
- apply (subst dvd_minus_iff)
- apply (subst zdvd_reduce)
- apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
- apply (subst zdvd_reduce, auto)
- done
-
-lemma inv_not_p_minus_1:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> p - 1"
- apply safe
- apply (cut_tac a = a and p = p in inv_is_inv, auto)
- apply (simp add: inv_not_p_minus_1_aux)
- apply (subgoal_tac "a = p - 1")
- apply (rule_tac [2] zcong_zless_imp_eq, auto)
- done
-
-lemma inv_g_1:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> 1 < inv p a"
- apply (case_tac "0\<le> inv p a")
- apply (subgoal_tac "inv p a \<noteq> 1")
- apply (subgoal_tac "inv p a \<noteq> 0")
- apply (subst order_less_le)
- apply (subst zle_add1_eq_le [symmetric])
- apply (subst order_less_le)
- apply (rule_tac [2] inv_not_0)
- apply (rule_tac [5] inv_not_1, auto)
- apply (unfold inv_def zprime_def, simp)
- done
-
-lemma inv_less_p_minus_1:
- "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a < p - 1"
- apply (case_tac "inv p a < p")
- apply (subst order_less_le)
- apply (simp add: inv_not_p_minus_1, auto)
- apply (unfold inv_def zprime_def, simp)
- done
-
-lemma inv_inv_aux: "5 \<le> p ==>
- nat (p - 2) * nat (p - 2) = Suc (nat (p - 1) * nat (p - 3))"
- apply (subst int_int_eq [symmetric])
- apply (simp add: zmult_int [symmetric])
- apply (simp add: zdiff_zmult_distrib zdiff_zmult_distrib2)
- done
-
-lemma zcong_zpower_zmult:
- "[x^y = 1] (mod p) \<Longrightarrow> [x^(y * z) = 1] (mod p)"
- apply (induct z)
- apply (auto simp add: zpower_zadd_distrib)
- apply (subgoal_tac "zcong (x^y * x^(y * z)) (1 * 1) p")
- apply (rule_tac [2] zcong_zmult, simp_all)
- done
-
-lemma inv_inv: "zprime p \<Longrightarrow>
- 5 \<le> p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> inv p (inv p a) = a"
- apply (unfold inv_def)
- apply (subst zpower_zmod)
- apply (subst zpower_zpower)
- apply (rule zcong_zless_imp_eq)
- prefer 5
- apply (subst zcong_zmod)
- apply (subst mod_mod_trivial)
- apply (subst zcong_zmod [symmetric])
- apply (subst inv_inv_aux)
- apply (subgoal_tac [2]
- "zcong (a * a^(nat (p - 1) * nat (p - 3))) (a * 1) p")
- apply (rule_tac [3] zcong_zmult)
- apply (rule_tac [4] zcong_zpower_zmult)
- apply (erule_tac [4] Little_Fermat)
- apply (rule_tac [4] zdvd_not_zless, simp_all)
- done
-
-
-text {* \medskip @{term wset} *}
-
-declare wset.simps [simp del]
-
-lemma wset_induct:
- assumes "!!a p. P {} a p"
- and "!!a p. 1 < (a::int) \<Longrightarrow>
- P (wset (a - 1, p)) (a - 1) p ==> P (wset (a, p)) a p"
- shows "P (wset (u, v)) u v"
- apply (rule wset.induct, safe)
- prefer 2
- apply (case_tac "1 < a")
- apply (rule prems)
- apply simp_all
- apply (simp_all add: wset.simps prems)
- done
-
-lemma wset_mem_imp_or [rule_format]:
- "1 < a \<Longrightarrow> b \<notin> wset (a - 1, p)
- ==> b \<in> wset (a, p) --> b = a \<or> b = inv p a"
- apply (subst wset.simps)
- apply (unfold Let_def, simp)
- done
-
-lemma wset_mem_mem [simp]: "1 < a ==> a \<in> wset (a, p)"
- apply (subst wset.simps)
- apply (unfold Let_def, simp)
- done
-
-lemma wset_subset: "1 < a \<Longrightarrow> b \<in> wset (a - 1, p) ==> b \<in> wset (a, p)"
- apply (subst wset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma wset_g_1 [rule_format]:
- "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> 1 < b"
- apply (induct a p rule: wset_induct, auto)
- apply (case_tac "b = a")
- apply (case_tac [2] "b = inv p a")
- apply (subgoal_tac [3] "b = a \<or> b = inv p a")
- apply (rule_tac [4] wset_mem_imp_or)
- prefer 2
- apply simp
- apply (rule inv_g_1, auto)
- done
-
-lemma wset_less [rule_format]:
- "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> b < p - 1"
- apply (induct a p rule: wset_induct, auto)
- apply (case_tac "b = a")
- apply (case_tac [2] "b = inv p a")
- apply (subgoal_tac [3] "b = a \<or> b = inv p a")
- apply (rule_tac [4] wset_mem_imp_or)
- prefer 2
- apply simp
- apply (rule inv_less_p_minus_1, auto)
- done
-
-lemma wset_mem [rule_format]:
- "zprime p -->
- a < p - 1 --> 1 < b --> b \<le> a --> b \<in> wset (a, p)"
- apply (induct a p rule: wset.induct, auto)
- apply (rule_tac wset_subset)
- apply (simp (no_asm_simp))
- apply auto
- done
-
-lemma wset_mem_inv_mem [rule_format]:
- "zprime p --> 5 \<le> p --> a < p - 1 --> b \<in> wset (a, p)
- --> inv p b \<in> wset (a, p)"
- apply (induct a p rule: wset_induct, auto)
- apply (case_tac "b = a")
- apply (subst wset.simps)
- apply (unfold Let_def)
- apply (rule_tac [3] wset_subset, auto)
- apply (case_tac "b = inv p a")
- apply (simp (no_asm_simp))
- apply (subst inv_inv)
- apply (subgoal_tac [6] "b = a \<or> b = inv p a")
- apply (rule_tac [7] wset_mem_imp_or, auto)
- done
-
-lemma wset_inv_mem_mem:
- "zprime p \<Longrightarrow> 5 \<le> p \<Longrightarrow> a < p - 1 \<Longrightarrow> 1 < b \<Longrightarrow> b < p - 1
- \<Longrightarrow> inv p b \<in> wset (a, p) \<Longrightarrow> b \<in> wset (a, p)"
- apply (rule_tac s = "inv p (inv p b)" and t = b in subst)
- apply (rule_tac [2] wset_mem_inv_mem)
- apply (rule inv_inv, simp_all)
- done
-
-lemma wset_fin: "finite (wset (a, p))"
- apply (induct a p rule: wset_induct)
- prefer 2
- apply (subst wset.simps)
- apply (unfold Let_def, auto)
- done
-
-lemma wset_zcong_prod_1 [rule_format]:
- "zprime p -->
- 5 \<le> p --> a < p - 1 --> [(\<Prod>x\<in>wset(a, p). x) = 1] (mod p)"
- apply (induct a p rule: wset_induct)
- prefer 2
- apply (subst wset.simps)
- apply (unfold Let_def, auto)
- apply (subst setprod_insert)
- apply (tactic {* stac (thm "setprod_insert") 3 *})
- apply (subgoal_tac [5]
- "zcong (a * inv p a * (\<Prod>x\<in> wset(a - 1, p). x)) (1 * 1) p")
- prefer 5
- apply (simp add: zmult_assoc)
- apply (rule_tac [5] zcong_zmult)
- apply (rule_tac [5] inv_is_inv)
- apply (tactic "clarify_tac @{claset} 4")
- apply (subgoal_tac [4] "a \<in> wset (a - 1, p)")
- apply (rule_tac [5] wset_inv_mem_mem)
- apply (simp_all add: wset_fin)
- apply (rule inv_distinct, auto)
- done
-
-lemma d22set_eq_wset: "zprime p ==> d22set (p - 2) = wset (p - 2, p)"
- apply safe
- apply (erule wset_mem)
- apply (rule_tac [2] d22set_g_1)
- apply (rule_tac [3] d22set_le)
- apply (rule_tac [4] d22set_mem)
- apply (erule_tac [4] wset_g_1)
- prefer 6
- apply (subst zle_add1_eq_le [symmetric])
- apply (subgoal_tac "p - 2 + 1 = p - 1")
- apply (simp (no_asm_simp))
- apply (erule wset_less, auto)
- done
-
-
-subsection {* Wilson *}
-
-lemma prime_g_5: "zprime p \<Longrightarrow> p \<noteq> 2 \<Longrightarrow> p \<noteq> 3 ==> 5 \<le> p"
- apply (unfold zprime_def dvd_def)
- apply (case_tac "p = 4", auto)
- apply (rule notE)
- prefer 2
- apply assumption
- apply (simp (no_asm))
- apply (rule_tac x = 2 in exI)
- apply (safe, arith)
- apply (rule_tac x = 2 in exI, auto)
- done
-
-theorem Wilson_Russ:
- "zprime p ==> [zfact (p - 1) = -1] (mod p)"
- apply (subgoal_tac "[(p - 1) * zfact (p - 2) = -1 * 1] (mod p)")
- apply (rule_tac [2] zcong_zmult)
- apply (simp only: zprime_def)
- apply (subst zfact.simps)
- apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst, auto)
- apply (simp only: zcong_def)
- apply (simp (no_asm_simp))
- apply (case_tac "p = 2")
- apply (simp add: zfact.simps)
- apply (case_tac "p = 3")
- apply (simp add: zfact.simps)
- apply (subgoal_tac "5 \<le> p")
- apply (erule_tac [2] prime_g_5)
- apply (subst d22set_prod_zfact [symmetric])
- apply (subst d22set_eq_wset)
- apply (rule_tac [2] wset_zcong_prod_1, auto)
- done
-
-end
--- a/src/HOL/NumberTheory/document/root.tex Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,56 +0,0 @@
-
-\documentclass[11pt,a4paper]{article}
-\usepackage{graphicx}
-\usepackage{isabelle,isabellesym,pdfsetup}
-
-\urlstyle{rm}
-\isabellestyle{it}
-
-\begin{document}
-
-\title{Some results of number theory}
-\author{Jeremy Avigad\\
- David Gray\\
- Adam Kramer\\
- Thomas M Rasmussen}
-
-\maketitle
-
-\begin{abstract}
-This is a collection of formalized proofs of many results of number theory.
-The proofs of the Chinese Remainder Theorem and Wilson's Theorem are due to
-Rasmussen. The proof of Gauss's law of quadratic reciprocity is due to
-Avigad, Gray and Kramer. Proofs can be found in most introductory number
-theory textbooks; Goldman's \emph{The Queen of Mathematics: a Historically
-Motivated Guide to Number Theory} provides some historical context.
-
-Avigad, Gray and Kramer have also provided library theories dealing with
-finite sets and finite sums, divisibility and congruences, parity and
-residues. The authors are engaged in redesigning and polishing these theories
-for more serious use. For the latest information in this respect, please see
-the web page \url{http://www.andrew.cmu.edu/~avigad/isabelle}. Other theories
-contain proofs of Euler's criteria, Gauss' lemma, and the law of quadratic
-reciprocity. The formalization follows Eisenstein's proof, which is the one
-most commonly found in introductory textbooks; in particular, it follows the
-presentation in Niven and Zuckerman, \emph{The Theory of Numbers}.
-
-To avoid having to count roots of polynomials, however, we relied on a trick
-previously used by David Russinoff in formalizing quadratic reciprocity for
-the Boyer-Moore theorem prover; see Russinoff, David, ``A mechanical proof
-of quadratic reciprocity,'' \emph{Journal of Automated Reasoning} 8:3-21,
-1992. We are grateful to Larry Paulson for calling our attention to this
-reference.
-\end{abstract}
-
-\tableofcontents
-
-\begin{center}
- \includegraphics[scale=0.5]{session_graph}
-\end{center}
-
-\newpage
-
-\parindent 0pt\parskip 0.5ex
-\input{session}
-
-\end{document}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Binomial.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,373 @@
+(* Title: Binomial.thy
+ Authors: Lawrence C. Paulson, Jeremy Avigad, Tobias Nipkow
+
+
+Defines the "choose" function, and establishes basic properties.
+
+The original theory "Binomial" was by Lawrence C. Paulson, based on
+the work of Andy Gordon and Florian Kammueller. The approach here,
+which derives the definition of binomial coefficients in terms of the
+factorial function, is due to Jeremy Avigad. The binomial theorem was
+formalized by Tobias Nipkow.
+
+*)
+
+
+header {* Binomial *}
+
+theory Binomial
+imports Cong Fact
+begin
+
+
+subsection {* Main definitions *}
+
+class binomial =
+
+fixes
+ binomial :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "choose" 65)
+
+(* definitions for the natural numbers *)
+
+instantiation nat :: binomial
+
+begin
+
+fun
+ binomial_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+where
+ "binomial_nat n k =
+ (if k = 0 then 1 else
+ if n = 0 then 0 else
+ (binomial (n - 1) k) + (binomial (n - 1) (k - 1)))"
+
+instance proof qed
+
+end
+
+(* definitions for the integers *)
+
+instantiation int :: binomial
+
+begin
+
+definition
+ binomial_int :: "int => int \<Rightarrow> int"
+where
+ "binomial_int n k = (if n \<ge> 0 \<and> k \<ge> 0 then int (binomial (nat n) (nat k))
+ else 0)"
+instance proof qed
+
+end
+
+
+subsection {* Set up Transfer *}
+
+lemma transfer_nat_int_binomial:
+ "(n::int) >= 0 \<Longrightarrow> k >= 0 \<Longrightarrow> binomial (nat n) (nat k) =
+ nat (binomial n k)"
+ unfolding binomial_int_def
+ by auto
+
+lemma transfer_nat_int_binomial_closure:
+ "n >= (0::int) \<Longrightarrow> k >= 0 \<Longrightarrow> binomial n k >= 0"
+ by (auto simp add: binomial_int_def)
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_binomial transfer_nat_int_binomial_closure]
+
+lemma transfer_int_nat_binomial:
+ "binomial (int n) (int k) = int (binomial n k)"
+ unfolding fact_int_def binomial_int_def by auto
+
+lemma transfer_int_nat_binomial_closure:
+ "is_nat n \<Longrightarrow> is_nat k \<Longrightarrow> binomial n k >= 0"
+ by (auto simp add: binomial_int_def)
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_binomial transfer_int_nat_binomial_closure]
+
+
+subsection {* Binomial coefficients *}
+
+lemma choose_zero_nat [simp]: "(n::nat) choose 0 = 1"
+ by simp
+
+lemma choose_zero_int [simp]: "n \<ge> 0 \<Longrightarrow> (n::int) choose 0 = 1"
+ by (simp add: binomial_int_def)
+
+lemma zero_choose_nat [rule_format,simp]: "ALL (k::nat) > n. n choose k = 0"
+ by (induct n rule: induct'_nat, auto)
+
+lemma zero_choose_int [rule_format,simp]: "(k::int) > n \<Longrightarrow> n choose k = 0"
+ unfolding binomial_int_def apply (case_tac "n < 0")
+ apply force
+ apply (simp del: binomial_nat.simps)
+done
+
+lemma choose_reduce_nat: "(n::nat) > 0 \<Longrightarrow> 0 < k \<Longrightarrow>
+ (n choose k) = ((n - 1) choose k) + ((n - 1) choose (k - 1))"
+ by simp
+
+lemma choose_reduce_int: "(n::int) > 0 \<Longrightarrow> 0 < k \<Longrightarrow>
+ (n choose k) = ((n - 1) choose k) + ((n - 1) choose (k - 1))"
+ unfolding binomial_int_def apply (subst choose_reduce_nat)
+ apply (auto simp del: binomial_nat.simps
+ simp add: nat_diff_distrib)
+done
+
+lemma choose_plus_one_nat: "((n::nat) + 1) choose (k + 1) =
+ (n choose (k + 1)) + (n choose k)"
+ by (simp add: choose_reduce_nat)
+
+lemma choose_Suc_nat: "(Suc n) choose (Suc k) =
+ (n choose (Suc k)) + (n choose k)"
+ by (simp add: choose_reduce_nat One_nat_def)
+
+lemma choose_plus_one_int: "n \<ge> 0 \<Longrightarrow> k \<ge> 0 \<Longrightarrow> ((n::int) + 1) choose (k + 1) =
+ (n choose (k + 1)) + (n choose k)"
+ by (simp add: binomial_int_def choose_plus_one_nat nat_add_distrib del: binomial_nat.simps)
+
+declare binomial_nat.simps [simp del]
+
+lemma choose_self_nat [simp]: "((n::nat) choose n) = 1"
+ by (induct n rule: induct'_nat, auto simp add: choose_plus_one_nat)
+
+lemma choose_self_int [simp]: "n \<ge> 0 \<Longrightarrow> ((n::int) choose n) = 1"
+ by (auto simp add: binomial_int_def)
+
+lemma choose_one_nat [simp]: "(n::nat) choose 1 = n"
+ by (induct n rule: induct'_nat, auto simp add: choose_reduce_nat)
+
+lemma choose_one_int [simp]: "n \<ge> 0 \<Longrightarrow> (n::int) choose 1 = n"
+ by (auto simp add: binomial_int_def)
+
+lemma plus_one_choose_self_nat [simp]: "(n::nat) + 1 choose n = n + 1"
+ apply (induct n rule: induct'_nat, force)
+ apply (case_tac "n = 0")
+ apply auto
+ apply (subst choose_reduce_nat)
+ apply (auto simp add: One_nat_def)
+ (* natdiff_cancel_numerals introduces Suc *)
+done
+
+lemma Suc_choose_self_nat [simp]: "(Suc n) choose n = Suc n"
+ using plus_one_choose_self_nat by (simp add: One_nat_def)
+
+lemma plus_one_choose_self_int [rule_format, simp]:
+ "(n::int) \<ge> 0 \<longrightarrow> n + 1 choose n = n + 1"
+ by (auto simp add: binomial_int_def nat_add_distrib)
+
+(* bounded quantification doesn't work with the unicode characters? *)
+lemma choose_pos_nat [rule_format]: "ALL k <= (n::nat).
+ ((n::nat) choose k) > 0"
+ apply (induct n rule: induct'_nat)
+ apply force
+ apply clarify
+ apply (case_tac "k = 0")
+ apply force
+ apply (subst choose_reduce_nat)
+ apply auto
+done
+
+lemma choose_pos_int: "n \<ge> 0 \<Longrightarrow> k >= 0 \<Longrightarrow> k \<le> n \<Longrightarrow>
+ ((n::int) choose k) > 0"
+ by (auto simp add: binomial_int_def choose_pos_nat)
+
+lemma binomial_induct [rule_format]: "(ALL (n::nat). P n n) \<longrightarrow>
+ (ALL n. P (n + 1) 0) \<longrightarrow> (ALL n. (ALL k < n. P n k \<longrightarrow> P n (k + 1) \<longrightarrow>
+ P (n + 1) (k + 1))) \<longrightarrow> (ALL k <= n. P n k)"
+ apply (induct n rule: induct'_nat)
+ apply auto
+ apply (case_tac "k = 0")
+ apply auto
+ apply (case_tac "k = n + 1")
+ apply auto
+ apply (drule_tac x = n in spec) back back
+ apply (drule_tac x = "k - 1" in spec) back back back
+ apply auto
+done
+
+lemma choose_altdef_aux_nat: "(k::nat) \<le> n \<Longrightarrow>
+ fact k * fact (n - k) * (n choose k) = fact n"
+ apply (rule binomial_induct [of _ k n])
+ apply auto
+proof -
+ fix k :: nat and n
+ assume less: "k < n"
+ assume ih1: "fact k * fact (n - k) * (n choose k) = fact n"
+ hence one: "fact (k + 1) * fact (n - k) * (n choose k) = (k + 1) * fact n"
+ by (subst fact_plus_one_nat, auto)
+ assume ih2: "fact (k + 1) * fact (n - (k + 1)) * (n choose (k + 1)) =
+ fact n"
+ with less have "fact (k + 1) * fact ((n - (k + 1)) + 1) *
+ (n choose (k + 1)) = (n - k) * fact n"
+ by (subst (2) fact_plus_one_nat, auto)
+ with less have two: "fact (k + 1) * fact (n - k) * (n choose (k + 1)) =
+ (n - k) * fact n" by simp
+ have "fact (k + 1) * fact (n - k) * (n + 1 choose (k + 1)) =
+ fact (k + 1) * fact (n - k) * (n choose (k + 1)) +
+ fact (k + 1) * fact (n - k) * (n choose k)"
+ by (subst choose_reduce_nat, auto simp add: ring_simps)
+ also note one
+ also note two
+ also with less have "(n - k) * fact n + (k + 1) * fact n= fact (n + 1)"
+ apply (subst fact_plus_one_nat)
+ apply (subst left_distrib [symmetric])
+ apply simp
+ done
+ finally show "fact (k + 1) * fact (n - k) * (n + 1 choose (k + 1)) =
+ fact (n + 1)" .
+qed
+
+lemma choose_altdef_nat: "(k::nat) \<le> n \<Longrightarrow>
+ n choose k = fact n div (fact k * fact (n - k))"
+ apply (frule choose_altdef_aux_nat)
+ apply (erule subst)
+ apply (simp add: mult_ac)
+done
+
+
+lemma choose_altdef_int:
+ assumes "(0::int) <= k" and "k <= n"
+ shows "n choose k = fact n div (fact k * fact (n - k))"
+
+ apply (subst tsub_eq [symmetric], rule prems)
+ apply (rule choose_altdef_nat [transferred])
+ using prems apply auto
+done
+
+lemma choose_dvd_nat: "(k::nat) \<le> n \<Longrightarrow> fact k * fact (n - k) dvd fact n"
+ unfolding dvd_def apply (frule choose_altdef_aux_nat)
+ (* why don't blast and auto get this??? *)
+ apply (rule exI)
+ apply (erule sym)
+done
+
+lemma choose_dvd_int:
+ assumes "(0::int) <= k" and "k <= n"
+ shows "fact k * fact (n - k) dvd fact n"
+
+ apply (subst tsub_eq [symmetric], rule prems)
+ apply (rule choose_dvd_nat [transferred])
+ using prems apply auto
+done
+
+(* generalizes Tobias Nipkow's proof to any commutative semiring *)
+theorem binomial: "(a+b::'a::{comm_ring_1,power})^n =
+ (SUM k=0..n. (of_nat (n choose k)) * a^k * b^(n-k))" (is "?P n")
+proof (induct n rule: induct'_nat)
+ show "?P 0" by simp
+next
+ fix n
+ assume ih: "?P n"
+ have decomp: "{0..n+1} = {0} Un {n+1} Un {1..n}"
+ by auto
+ have decomp2: "{0..n} = {0} Un {1..n}"
+ by auto
+ have decomp3: "{1..n+1} = {n+1} Un {1..n}"
+ by auto
+ have "(a+b)^(n+1) =
+ (a+b) * (SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
+ using ih by (simp add: power_plus_one)
+ also have "... = a*(SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k)) +
+ b*(SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
+ by (rule distrib)
+ also have "... = (SUM k=0..n. of_nat (n choose k) * a^(k+1) * b^(n-k)) +
+ (SUM k=0..n. of_nat (n choose k) * a^k * b^(n-k+1))"
+ by (subst (1 2) power_plus_one, simp add: setsum_right_distrib mult_ac)
+ also have "... = (SUM k=0..n. of_nat (n choose k) * a^k * b^(n+1-k)) +
+ (SUM k=1..n+1. of_nat (n choose (k - 1)) * a^k * b^(n+1-k))"
+ by (simp add:setsum_shift_bounds_cl_Suc_ivl Suc_diff_le
+ power_Suc ring_simps One_nat_def del:setsum_cl_ivl_Suc)
+ also have "... = a^(n+1) + b^(n+1) +
+ (SUM k=1..n. of_nat (n choose (k - 1)) * a^k * b^(n+1-k)) +
+ (SUM k=1..n. of_nat (n choose k) * a^k * b^(n+1-k))"
+ by (simp add: decomp2 decomp3)
+ also have
+ "... = a^(n+1) + b^(n+1) +
+ (SUM k=1..n. of_nat(n+1 choose k) * a^k * b^(n+1-k))"
+ by (auto simp add: ring_simps setsum_addf [symmetric]
+ choose_reduce_nat)
+ also have "... = (SUM k=0..n+1. of_nat (n+1 choose k) * a^k * b^(n+1-k))"
+ using decomp by (simp add: ring_simps)
+ finally show "?P (n + 1)" by simp
+qed
+
+lemma set_explicit: "{S. S = T \<and> P S} = (if P T then {T} else {})"
+ by auto
+
+lemma card_subsets_nat [rule_format]:
+ fixes S :: "'a set"
+ assumes "finite S"
+ shows "ALL k. card {T. T \<le> S \<and> card T = k} = card S choose k"
+ (is "?P S")
+using `finite S`
+proof (induct set: finite)
+ show "?P {}" by (auto simp add: set_explicit)
+ next fix x :: "'a" and F
+ assume iassms: "finite F" "x ~: F"
+ assume ih: "?P F"
+ show "?P (insert x F)" (is "ALL k. ?Q k")
+ proof
+ fix k
+ show "card {T. T \<subseteq> (insert x F) \<and> card T = k} =
+ card (insert x F) choose k" (is "?Q k")
+ proof (induct k rule: induct'_nat)
+ from iassms have "{T. T \<le> (insert x F) \<and> card T = 0} = {{}}"
+ apply auto
+ apply (subst (asm) card_0_eq)
+ apply (auto elim: finite_subset)
+ done
+ thus "?Q 0"
+ by auto
+ next fix k
+ show "?Q (k + 1)"
+ proof -
+ from iassms have fin: "finite (insert x F)" by auto
+ hence "{ T. T \<subseteq> insert x F \<and> card T = k + 1} =
+ {T. T \<le> F & card T = k + 1} Un
+ {T. T \<le> insert x F & x : T & card T = k + 1}"
+ by (auto intro!: subsetI)
+ with iassms fin have "card ({T. T \<le> insert x F \<and> card T = k + 1}) =
+ card ({T. T \<subseteq> F \<and> card T = k + 1}) +
+ card ({T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1})"
+ apply (subst card_Un_disjoint [symmetric])
+ apply auto
+ (* note: nice! Didn't have to say anything here *)
+ done
+ also from ih have "card ({T. T \<subseteq> F \<and> card T = k + 1}) =
+ card F choose (k+1)" by auto
+ also have "card ({T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1}) =
+ card ({T. T <= F & card T = k})"
+ proof -
+ let ?f = "%T. T Un {x}"
+ from iassms have "inj_on ?f {T. T <= F & card T = k}"
+ unfolding inj_on_def by (auto intro!: subsetI)
+ hence "card ({T. T <= F & card T = k}) =
+ card(?f ` {T. T <= F & card T = k})"
+ by (rule card_image [symmetric])
+ also from iassms fin have "?f ` {T. T <= F & card T = k} =
+ {T. T \<subseteq> insert x F \<and> x : T \<and> card T = k + 1}"
+ unfolding image_def
+ (* I can't figure out why this next line takes so long *)
+ apply auto
+ apply (frule (1) finite_subset, force)
+ apply (rule_tac x = "xa - {x}" in exI)
+ apply (subst card_Diff_singleton)
+ apply (auto elim: finite_subset)
+ done
+ finally show ?thesis by (rule sym)
+ qed
+ also from ih have "card ({T. T <= F & card T = k}) = card F choose k"
+ by auto
+ finally have "card ({T. T \<le> insert x F \<and> card T = k + 1}) =
+ card F choose (k + 1) + (card F choose k)".
+ with iassms choose_plus_one_nat show ?thesis
+ by auto
+ qed
+ qed
+ qed
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Cong.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1091 @@
+(* Title: HOL/Library/Cong.thy
+ ID:
+ Authors: Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
+ Thomas M. Rasmussen, Jeremy Avigad
+
+
+Defines congruence (notation: [x = y] (mod z)) for natural numbers and
+integers.
+
+This file combines and revises a number of prior developments.
+
+The original theories "GCD" and "Primes" were by Christophe Tabacznyj
+and Lawrence C. Paulson, based on \cite{davenport92}. They introduced
+gcd, lcm, and prime for the natural numbers.
+
+The original theory "IntPrimes" was by Thomas M. Rasmussen, and
+extended gcd, lcm, primes to the integers. Amine Chaieb provided
+another extension of the notions to the integers, and added a number
+of results to "Primes" and "GCD".
+
+The original theory, "IntPrimes", by Thomas M. Rasmussen, defined and
+developed the congruence relations on the integers. The notion was
+extended to the natural numbers by Chiaeb. Jeremy Avigad combined
+these, revised and tidied them, made the development uniform for the
+natural numbers and the integers, and added a number of new theorems.
+
+*)
+
+
+header {* Congruence *}
+
+theory Cong
+imports GCD Primes
+begin
+
+subsection {* Turn off One_nat_def *}
+
+lemma induct'_nat [case_names zero plus1, induct type: nat]:
+ "\<lbrakk> P (0::nat); !!n. P n \<Longrightarrow> P (n + 1)\<rbrakk> \<Longrightarrow> P n"
+by (erule nat_induct) (simp add:One_nat_def)
+
+lemma cases_nat [case_names zero plus1, cases type: nat]:
+ "P (0::nat) \<Longrightarrow> (!!n. P (n + 1)) \<Longrightarrow> P n"
+by(metis induct'_nat)
+
+lemma power_plus_one [simp]: "(x::'a::power)^(n + 1) = x * x^n"
+by (simp add: One_nat_def)
+
+lemma power_eq_one_eq_nat [simp]:
+ "((x::nat)^m = 1) = (m = 0 | x = 1)"
+by (induct m, auto)
+
+lemma card_insert_if' [simp]: "finite A \<Longrightarrow>
+ card (insert x A) = (if x \<in> A then (card A) else (card A) + 1)"
+by (auto simp add: insert_absorb)
+
+(* why wasn't card_insert_if a simp rule? *)
+declare card_insert_disjoint [simp del]
+
+lemma nat_1' [simp]: "nat 1 = 1"
+by simp
+
+(* For those annoying moments where Suc reappears, use Suc_eq_plus1 *)
+
+declare nat_1 [simp del]
+declare add_2_eq_Suc [simp del]
+declare add_2_eq_Suc' [simp del]
+
+
+declare mod_pos_pos_trivial [simp]
+
+
+subsection {* Main definitions *}
+
+class cong =
+
+fixes
+ cong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(1[_ = _] '(mod _'))")
+
+begin
+
+abbreviation
+ notcong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(1[_ \<noteq> _] '(mod _'))")
+where
+ "notcong x y m == (~cong x y m)"
+
+end
+
+(* definitions for the natural numbers *)
+
+instantiation nat :: cong
+
+begin
+
+definition
+ cong_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
+where
+ "cong_nat x y m = ((x mod m) = (y mod m))"
+
+instance proof qed
+
+end
+
+
+(* definitions for the integers *)
+
+instantiation int :: cong
+
+begin
+
+definition
+ cong_int :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
+where
+ "cong_int x y m = ((x mod m) = (y mod m))"
+
+instance proof qed
+
+end
+
+
+subsection {* Set up Transfer *}
+
+
+lemma transfer_nat_int_cong:
+ "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> m >= 0 \<Longrightarrow>
+ ([(nat x) = (nat y)] (mod (nat m))) = ([x = y] (mod m))"
+ unfolding cong_int_def cong_nat_def
+ apply (auto simp add: nat_mod_distrib [symmetric])
+ apply (subst (asm) eq_nat_nat_iff)
+ apply (case_tac "m = 0", force, rule pos_mod_sign, force)+
+ apply assumption
+done
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_cong]
+
+lemma transfer_int_nat_cong:
+ "[(int x) = (int y)] (mod (int m)) = [x = y] (mod m)"
+ apply (auto simp add: cong_int_def cong_nat_def)
+ apply (auto simp add: zmod_int [symmetric])
+done
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_cong]
+
+
+subsection {* Congruence *}
+
+(* was zcong_0, etc. *)
+lemma cong_0_nat [simp, presburger]: "([(a::nat) = b] (mod 0)) = (a = b)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_0_int [simp, presburger]: "([(a::int) = b] (mod 0)) = (a = b)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_1_nat [simp, presburger]: "[(a::nat) = b] (mod 1)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_Suc_0_nat [simp, presburger]: "[(a::nat) = b] (mod Suc 0)"
+ by (unfold cong_nat_def, auto simp add: One_nat_def)
+
+lemma cong_1_int [simp, presburger]: "[(a::int) = b] (mod 1)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_refl_nat [simp]: "[(k::nat) = k] (mod m)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_refl_int [simp]: "[(k::int) = k] (mod m)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_sym_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_sym_int: "[(a::int) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_sym_eq_nat: "[(a::nat) = b] (mod m) = [b = a] (mod m)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_sym_eq_int: "[(a::int) = b] (mod m) = [b = a] (mod m)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_trans_nat [trans]:
+ "[(a::nat) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_trans_int [trans]:
+ "[(a::int) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_add_nat:
+ "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
+ apply (unfold cong_nat_def)
+ apply (subst (1 2) mod_add_eq)
+ apply simp
+done
+
+lemma cong_add_int:
+ "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
+ apply (unfold cong_int_def)
+ apply (subst (1 2) mod_add_left_eq)
+ apply (subst (1 2) mod_add_right_eq)
+ apply simp
+done
+
+lemma cong_diff_int:
+ "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a - c = b - d] (mod m)"
+ apply (unfold cong_int_def)
+ apply (subst (1 2) mod_diff_eq)
+ apply simp
+done
+
+lemma cong_diff_aux_int:
+ "(a::int) >= c \<Longrightarrow> b >= d \<Longrightarrow> [(a::int) = b] (mod m) \<Longrightarrow>
+ [c = d] (mod m) \<Longrightarrow> [tsub a c = tsub b d] (mod m)"
+ apply (subst (1 2) tsub_eq)
+ apply (auto intro: cong_diff_int)
+done;
+
+lemma cong_diff_nat:
+ assumes "(a::nat) >= c" and "b >= d" and "[a = b] (mod m)" and
+ "[c = d] (mod m)"
+ shows "[a - c = b - d] (mod m)"
+
+ using prems by (rule cong_diff_aux_int [transferred]);
+
+lemma cong_mult_nat:
+ "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
+ apply (unfold cong_nat_def)
+ apply (subst (1 2) mod_mult_eq)
+ apply simp
+done
+
+lemma cong_mult_int:
+ "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
+ apply (unfold cong_int_def)
+ apply (subst (1 2) zmod_zmult1_eq)
+ apply (subst (1 2) mult_commute)
+ apply (subst (1 2) zmod_zmult1_eq)
+ apply simp
+done
+
+lemma cong_exp_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
+ apply (induct k)
+ apply (auto simp add: cong_refl_nat cong_mult_nat)
+done
+
+lemma cong_exp_int: "[(x::int) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
+ apply (induct k)
+ apply (auto simp add: cong_refl_int cong_mult_int)
+done
+
+lemma cong_setsum_nat [rule_format]:
+ "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
+ [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
+ apply (case_tac "finite A")
+ apply (induct set: finite)
+ apply (auto intro: cong_add_nat)
+done
+
+lemma cong_setsum_int [rule_format]:
+ "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
+ [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
+ apply (case_tac "finite A")
+ apply (induct set: finite)
+ apply (auto intro: cong_add_int)
+done
+
+lemma cong_setprod_nat [rule_format]:
+ "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
+ [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
+ apply (case_tac "finite A")
+ apply (induct set: finite)
+ apply (auto intro: cong_mult_nat)
+done
+
+lemma cong_setprod_int [rule_format]:
+ "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
+ [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
+ apply (case_tac "finite A")
+ apply (induct set: finite)
+ apply (auto intro: cong_mult_int)
+done
+
+lemma cong_scalar_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
+ by (rule cong_mult_nat, simp_all)
+
+lemma cong_scalar_int: "[(a::int)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
+ by (rule cong_mult_int, simp_all)
+
+lemma cong_scalar2_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
+ by (rule cong_mult_nat, simp_all)
+
+lemma cong_scalar2_int: "[(a::int)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
+ by (rule cong_mult_int, simp_all)
+
+lemma cong_mult_self_nat: "[(a::nat) * m = 0] (mod m)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_mult_self_int: "[(a::int) * m = 0] (mod m)"
+ by (unfold cong_int_def, auto)
+
+lemma cong_eq_diff_cong_0_int: "[(a::int) = b] (mod m) = [a - b = 0] (mod m)"
+ apply (rule iffI)
+ apply (erule cong_diff_int [of a b m b b, simplified])
+ apply (erule cong_add_int [of "a - b" 0 m b b, simplified])
+done
+
+lemma cong_eq_diff_cong_0_aux_int: "a >= b \<Longrightarrow>
+ [(a::int) = b] (mod m) = [tsub a b = 0] (mod m)"
+ by (subst tsub_eq, assumption, rule cong_eq_diff_cong_0_int)
+
+lemma cong_eq_diff_cong_0_nat:
+ assumes "(a::nat) >= b"
+ shows "[a = b] (mod m) = [a - b = 0] (mod m)"
+
+ using prems by (rule cong_eq_diff_cong_0_aux_int [transferred])
+
+lemma cong_diff_cong_0'_nat:
+ "[(x::nat) = y] (mod n) \<longleftrightarrow>
+ (if x <= y then [y - x = 0] (mod n) else [x - y = 0] (mod n))"
+ apply (case_tac "y <= x")
+ apply (frule cong_eq_diff_cong_0_nat [where m = n])
+ apply auto [1]
+ apply (subgoal_tac "x <= y")
+ apply (frule cong_eq_diff_cong_0_nat [where m = n])
+ apply (subst cong_sym_eq_nat)
+ apply auto
+done
+
+lemma cong_altdef_nat: "(a::nat) >= b \<Longrightarrow> [a = b] (mod m) = (m dvd (a - b))"
+ apply (subst cong_eq_diff_cong_0_nat, assumption)
+ apply (unfold cong_nat_def)
+ apply (simp add: dvd_eq_mod_eq_0 [symmetric])
+done
+
+lemma cong_altdef_int: "[(a::int) = b] (mod m) = (m dvd (a - b))"
+ apply (subst cong_eq_diff_cong_0_int)
+ apply (unfold cong_int_def)
+ apply (simp add: dvd_eq_mod_eq_0 [symmetric])
+done
+
+lemma cong_abs_int: "[(x::int) = y] (mod abs m) = [x = y] (mod m)"
+ by (simp add: cong_altdef_int)
+
+lemma cong_square_int:
+ "\<lbrakk> prime (p::int); 0 < a; [a * a = 1] (mod p) \<rbrakk>
+ \<Longrightarrow> [a = 1] (mod p) \<or> [a = - 1] (mod p)"
+ apply (simp only: cong_altdef_int)
+ apply (subst prime_dvd_mult_eq_int [symmetric], assumption)
+ (* any way around this? *)
+ apply (subgoal_tac "a * a - 1 = (a - 1) * (a - -1)")
+ apply (auto simp add: ring_simps)
+done
+
+lemma cong_mult_rcancel_int:
+ "coprime k (m::int) \<Longrightarrow> [a * k = b * k] (mod m) = [a = b] (mod m)"
+ apply (subst (1 2) cong_altdef_int)
+ apply (subst left_diff_distrib [symmetric])
+ apply (rule coprime_dvd_mult_iff_int)
+ apply (subst gcd_commute_int, assumption)
+done
+
+lemma cong_mult_rcancel_nat:
+ assumes "coprime k (m::nat)"
+ shows "[a * k = b * k] (mod m) = [a = b] (mod m)"
+
+ apply (rule cong_mult_rcancel_int [transferred])
+ using prems apply auto
+done
+
+lemma cong_mult_lcancel_nat:
+ "coprime k (m::nat) \<Longrightarrow> [k * a = k * b ] (mod m) = [a = b] (mod m)"
+ by (simp add: mult_commute cong_mult_rcancel_nat)
+
+lemma cong_mult_lcancel_int:
+ "coprime k (m::int) \<Longrightarrow> [k * a = k * b] (mod m) = [a = b] (mod m)"
+ by (simp add: mult_commute cong_mult_rcancel_int)
+
+(* was zcong_zgcd_zmult_zmod *)
+lemma coprime_cong_mult_int:
+ "[(a::int) = b] (mod m) \<Longrightarrow> [a = b] (mod n) \<Longrightarrow> coprime m n
+ \<Longrightarrow> [a = b] (mod m * n)"
+ apply (simp only: cong_altdef_int)
+ apply (erule (2) divides_mult_int)
+done
+
+lemma coprime_cong_mult_nat:
+ assumes "[(a::nat) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
+ shows "[a = b] (mod m * n)"
+
+ apply (rule coprime_cong_mult_int [transferred])
+ using prems apply auto
+done
+
+lemma cong_less_imp_eq_nat: "0 \<le> (a::nat) \<Longrightarrow>
+ a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
+ by (auto simp add: cong_nat_def mod_pos_pos_trivial)
+
+lemma cong_less_imp_eq_int: "0 \<le> (a::int) \<Longrightarrow>
+ a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
+ by (auto simp add: cong_int_def mod_pos_pos_trivial)
+
+lemma cong_less_unique_nat:
+ "0 < (m::nat) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
+ apply auto
+ apply (rule_tac x = "a mod m" in exI)
+ apply (unfold cong_nat_def, auto)
+done
+
+lemma cong_less_unique_int:
+ "0 < (m::int) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
+ apply auto
+ apply (rule_tac x = "a mod m" in exI)
+ apply (unfold cong_int_def, auto simp add: mod_pos_pos_trivial)
+done
+
+lemma cong_iff_lin_int: "([(a::int) = b] (mod m)) = (\<exists>k. b = a + m * k)"
+ apply (auto simp add: cong_altdef_int dvd_def ring_simps)
+ apply (rule_tac [!] x = "-k" in exI, auto)
+done
+
+lemma cong_iff_lin_nat: "([(a::nat) = b] (mod m)) =
+ (\<exists>k1 k2. b + k1 * m = a + k2 * m)"
+ apply (rule iffI)
+ apply (case_tac "b <= a")
+ apply (subst (asm) cong_altdef_nat, assumption)
+ apply (unfold dvd_def, auto)
+ apply (rule_tac x = k in exI)
+ apply (rule_tac x = 0 in exI)
+ apply (auto simp add: ring_simps)
+ apply (subst (asm) cong_sym_eq_nat)
+ apply (subst (asm) cong_altdef_nat)
+ apply force
+ apply (unfold dvd_def, auto)
+ apply (rule_tac x = 0 in exI)
+ apply (rule_tac x = k in exI)
+ apply (auto simp add: ring_simps)
+ apply (unfold cong_nat_def)
+ apply (subgoal_tac "a mod m = (a + k2 * m) mod m")
+ apply (erule ssubst)back
+ apply (erule subst)
+ apply auto
+done
+
+lemma cong_gcd_eq_int: "[(a::int) = b] (mod m) \<Longrightarrow> gcd a m = gcd b m"
+ apply (subst (asm) cong_iff_lin_int, auto)
+ apply (subst add_commute)
+ apply (subst (2) gcd_commute_int)
+ apply (subst mult_commute)
+ apply (subst gcd_add_mult_int)
+ apply (rule gcd_commute_int)
+done
+
+lemma cong_gcd_eq_nat:
+ assumes "[(a::nat) = b] (mod m)"
+ shows "gcd a m = gcd b m"
+
+ apply (rule cong_gcd_eq_int [transferred])
+ using prems apply auto
+done
+
+lemma cong_imp_coprime_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow>
+ coprime b m"
+ by (auto simp add: cong_gcd_eq_nat)
+
+lemma cong_imp_coprime_int: "[(a::int) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow>
+ coprime b m"
+ by (auto simp add: cong_gcd_eq_int)
+
+lemma cong_cong_mod_nat: "[(a::nat) = b] (mod m) =
+ [a mod m = b mod m] (mod m)"
+ by (auto simp add: cong_nat_def)
+
+lemma cong_cong_mod_int: "[(a::int) = b] (mod m) =
+ [a mod m = b mod m] (mod m)"
+ by (auto simp add: cong_int_def)
+
+lemma cong_minus_int [iff]: "[(a::int) = b] (mod -m) = [a = b] (mod m)"
+ by (subst (1 2) cong_altdef_int, auto)
+
+lemma cong_zero_nat [iff]: "[(a::nat) = b] (mod 0) = (a = b)"
+ by (auto simp add: cong_nat_def)
+
+lemma cong_zero_int [iff]: "[(a::int) = b] (mod 0) = (a = b)"
+ by (auto simp add: cong_int_def)
+
+(*
+lemma mod_dvd_mod_int:
+ "0 < (m::int) \<Longrightarrow> m dvd b \<Longrightarrow> (a mod b mod m) = (a mod m)"
+ apply (unfold dvd_def, auto)
+ apply (rule mod_mod_cancel)
+ apply auto
+done
+
+lemma mod_dvd_mod:
+ assumes "0 < (m::nat)" and "m dvd b"
+ shows "(a mod b mod m) = (a mod m)"
+
+ apply (rule mod_dvd_mod_int [transferred])
+ using prems apply auto
+done
+*)
+
+lemma cong_add_lcancel_nat:
+ "[(a::nat) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: cong_iff_lin_nat)
+
+lemma cong_add_lcancel_int:
+ "[(a::int) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: cong_iff_lin_int)
+
+lemma cong_add_rcancel_nat: "[(x::nat) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: cong_iff_lin_nat)
+
+lemma cong_add_rcancel_int: "[(x::int) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: cong_iff_lin_int)
+
+lemma cong_add_lcancel_0_nat: "[(a::nat) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: cong_iff_lin_nat)
+
+lemma cong_add_lcancel_0_int: "[(a::int) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: cong_iff_lin_int)
+
+lemma cong_add_rcancel_0_nat: "[x + (a::nat) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: cong_iff_lin_nat)
+
+lemma cong_add_rcancel_0_int: "[x + (a::int) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: cong_iff_lin_int)
+
+lemma cong_dvd_modulus_nat: "[(x::nat) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow>
+ [x = y] (mod n)"
+ apply (auto simp add: cong_iff_lin_nat dvd_def)
+ apply (rule_tac x="k1 * k" in exI)
+ apply (rule_tac x="k2 * k" in exI)
+ apply (simp add: ring_simps)
+done
+
+lemma cong_dvd_modulus_int: "[(x::int) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow>
+ [x = y] (mod n)"
+ by (auto simp add: cong_altdef_int dvd_def)
+
+lemma cong_dvd_eq_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
+ by (unfold cong_nat_def, auto simp add: dvd_eq_mod_eq_0)
+
+lemma cong_dvd_eq_int: "[(x::int) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
+ by (unfold cong_int_def, auto simp add: dvd_eq_mod_eq_0)
+
+lemma cong_mod_nat: "(n::nat) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
+ by (simp add: cong_nat_def)
+
+lemma cong_mod_int: "(n::int) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
+ by (simp add: cong_int_def)
+
+lemma mod_mult_cong_nat: "(a::nat) ~= 0 \<Longrightarrow> b ~= 0
+ \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
+ by (simp add: cong_nat_def mod_mult2_eq mod_add_left_eq)
+
+lemma neg_cong_int: "([(a::int) = b] (mod m)) = ([-a = -b] (mod m))"
+ apply (simp add: cong_altdef_int)
+ apply (subst dvd_minus_iff [symmetric])
+ apply (simp add: ring_simps)
+done
+
+lemma cong_modulus_neg_int: "([(a::int) = b] (mod m)) = ([a = b] (mod -m))"
+ by (auto simp add: cong_altdef_int)
+
+lemma mod_mult_cong_int: "(a::int) ~= 0 \<Longrightarrow> b ~= 0
+ \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
+ apply (case_tac "b > 0")
+ apply (simp add: cong_int_def mod_mod_cancel mod_add_left_eq)
+ apply (subst (1 2) cong_modulus_neg_int)
+ apply (unfold cong_int_def)
+ apply (subgoal_tac "a * b = (-a * -b)")
+ apply (erule ssubst)
+ apply (subst zmod_zmult2_eq)
+ apply (auto simp add: mod_add_left_eq)
+done
+
+lemma cong_to_1_nat: "([(a::nat) = 1] (mod n)) \<Longrightarrow> (n dvd (a - 1))"
+ apply (case_tac "a = 0")
+ apply force
+ apply (subst (asm) cong_altdef_nat)
+ apply auto
+done
+
+lemma cong_0_1_nat: "[(0::nat) = 1] (mod n) = (n = 1)"
+ by (unfold cong_nat_def, auto)
+
+lemma cong_0_1_int: "[(0::int) = 1] (mod n) = ((n = 1) | (n = -1))"
+ by (unfold cong_int_def, auto simp add: zmult_eq_1_iff)
+
+lemma cong_to_1'_nat: "[(a::nat) = 1] (mod n) \<longleftrightarrow>
+ a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
+ apply (case_tac "n = 1")
+ apply auto [1]
+ apply (drule_tac x = "a - 1" in spec)
+ apply force
+ apply (case_tac "a = 0")
+ apply (auto simp add: cong_0_1_nat) [1]
+ apply (rule iffI)
+ apply (drule cong_to_1_nat)
+ apply (unfold dvd_def)
+ apply auto [1]
+ apply (rule_tac x = k in exI)
+ apply (auto simp add: ring_simps) [1]
+ apply (subst cong_altdef_nat)
+ apply (auto simp add: dvd_def)
+done
+
+lemma cong_le_nat: "(y::nat) <= x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
+ apply (subst cong_altdef_nat)
+ apply assumption
+ apply (unfold dvd_def, auto simp add: ring_simps)
+ apply (rule_tac x = k in exI)
+ apply auto
+done
+
+lemma cong_solve_nat: "(a::nat) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
+ apply (case_tac "n = 0")
+ apply force
+ apply (frule bezout_nat [of a n], auto)
+ apply (rule exI, erule ssubst)
+ apply (rule cong_trans_nat)
+ apply (rule cong_add_nat)
+ apply (subst mult_commute)
+ apply (rule cong_mult_self_nat)
+ prefer 2
+ apply simp
+ apply (rule cong_refl_nat)
+ apply (rule cong_refl_nat)
+done
+
+lemma cong_solve_int: "(a::int) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
+ apply (case_tac "n = 0")
+ apply (case_tac "a \<ge> 0")
+ apply auto
+ apply (rule_tac x = "-1" in exI)
+ apply auto
+ apply (insert bezout_int [of a n], auto)
+ apply (rule exI)
+ apply (erule subst)
+ apply (rule cong_trans_int)
+ prefer 2
+ apply (rule cong_add_int)
+ apply (rule cong_refl_int)
+ apply (rule cong_sym_int)
+ apply (rule cong_mult_self_int)
+ apply simp
+ apply (subst mult_commute)
+ apply (rule cong_refl_int)
+done
+
+lemma cong_solve_dvd_nat:
+ assumes a: "(a::nat) \<noteq> 0" and b: "gcd a n dvd d"
+ shows "EX x. [a * x = d] (mod n)"
+proof -
+ from cong_solve_nat [OF a] obtain x where
+ "[a * x = gcd a n](mod n)"
+ by auto
+ hence "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
+ by (elim cong_scalar2_nat)
+ also from b have "(d div gcd a n) * gcd a n = d"
+ by (rule dvd_div_mult_self)
+ also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
+ by auto
+ finally show ?thesis
+ by auto
+qed
+
+lemma cong_solve_dvd_int:
+ assumes a: "(a::int) \<noteq> 0" and b: "gcd a n dvd d"
+ shows "EX x. [a * x = d] (mod n)"
+proof -
+ from cong_solve_int [OF a] obtain x where
+ "[a * x = gcd a n](mod n)"
+ by auto
+ hence "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
+ by (elim cong_scalar2_int)
+ also from b have "(d div gcd a n) * gcd a n = d"
+ by (rule dvd_div_mult_self)
+ also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
+ by auto
+ finally show ?thesis
+ by auto
+qed
+
+lemma cong_solve_coprime_nat: "coprime (a::nat) n \<Longrightarrow>
+ EX x. [a * x = 1] (mod n)"
+ apply (case_tac "a = 0")
+ apply force
+ apply (frule cong_solve_nat [of a n])
+ apply auto
+done
+
+lemma cong_solve_coprime_int: "coprime (a::int) n \<Longrightarrow>
+ EX x. [a * x = 1] (mod n)"
+ apply (case_tac "a = 0")
+ apply auto
+ apply (case_tac "n \<ge> 0")
+ apply auto
+ apply (subst cong_int_def, auto)
+ apply (frule cong_solve_int [of a n])
+ apply auto
+done
+
+lemma coprime_iff_invertible_nat: "m > (1::nat) \<Longrightarrow> coprime a m =
+ (EX x. [a * x = 1] (mod m))"
+ apply (auto intro: cong_solve_coprime_nat)
+ apply (unfold cong_nat_def, auto intro: invertible_coprime_nat)
+done
+
+lemma coprime_iff_invertible_int: "m > (1::int) \<Longrightarrow> coprime a m =
+ (EX x. [a * x = 1] (mod m))"
+ apply (auto intro: cong_solve_coprime_int)
+ apply (unfold cong_int_def)
+ apply (auto intro: invertible_coprime_int)
+done
+
+lemma coprime_iff_invertible'_int: "m > (1::int) \<Longrightarrow> coprime a m =
+ (EX x. 0 <= x & x < m & [a * x = 1] (mod m))"
+ apply (subst coprime_iff_invertible_int)
+ apply auto
+ apply (auto simp add: cong_int_def)
+ apply (rule_tac x = "x mod m" in exI)
+ apply (auto simp add: mod_mult_right_eq [symmetric])
+done
+
+
+lemma cong_cong_lcm_nat: "[(x::nat) = y] (mod a) \<Longrightarrow>
+ [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
+ apply (case_tac "y \<le> x")
+ apply (auto simp add: cong_altdef_nat lcm_least_nat) [1]
+ apply (rule cong_sym_nat)
+ apply (subst (asm) (1 2) cong_sym_eq_nat)
+ apply (auto simp add: cong_altdef_nat lcm_least_nat)
+done
+
+lemma cong_cong_lcm_int: "[(x::int) = y] (mod a) \<Longrightarrow>
+ [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
+ by (auto simp add: cong_altdef_int lcm_least_int) [1]
+
+lemma cong_cong_coprime_nat: "coprime a b \<Longrightarrow> [(x::nat) = y] (mod a) \<Longrightarrow>
+ [x = y] (mod b) \<Longrightarrow> [x = y] (mod a * b)"
+ apply (frule (1) cong_cong_lcm_nat)back
+ apply (simp add: lcm_nat_def)
+done
+
+lemma cong_cong_coprime_int: "coprime a b \<Longrightarrow> [(x::int) = y] (mod a) \<Longrightarrow>
+ [x = y] (mod b) \<Longrightarrow> [x = y] (mod a * b)"
+ apply (frule (1) cong_cong_lcm_int)back
+ apply (simp add: lcm_altdef_int cong_abs_int abs_mult [symmetric])
+done
+
+lemma cong_cong_setprod_coprime_nat [rule_format]: "finite A \<Longrightarrow>
+ (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
+ (ALL i:A. [(x::nat) = y] (mod m i)) \<longrightarrow>
+ [x = y] (mod (PROD i:A. m i))"
+ apply (induct set: finite)
+ apply auto
+ apply (rule cong_cong_coprime_nat)
+ apply (subst gcd_commute_nat)
+ apply (rule setprod_coprime_nat)
+ apply auto
+done
+
+lemma cong_cong_setprod_coprime_int [rule_format]: "finite A \<Longrightarrow>
+ (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
+ (ALL i:A. [(x::int) = y] (mod m i)) \<longrightarrow>
+ [x = y] (mod (PROD i:A. m i))"
+ apply (induct set: finite)
+ apply auto
+ apply (rule cong_cong_coprime_int)
+ apply (subst gcd_commute_int)
+ apply (rule setprod_coprime_int)
+ apply auto
+done
+
+lemma binary_chinese_remainder_aux_nat:
+ assumes a: "coprime (m1::nat) m2"
+ shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
+ [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
+proof -
+ from cong_solve_coprime_nat [OF a]
+ obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
+ by auto
+ from a have b: "coprime m2 m1"
+ by (subst gcd_commute_nat)
+ from cong_solve_coprime_nat [OF b]
+ obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
+ by auto
+ have "[m1 * x1 = 0] (mod m1)"
+ by (subst mult_commute, rule cong_mult_self_nat)
+ moreover have "[m2 * x2 = 0] (mod m2)"
+ by (subst mult_commute, rule cong_mult_self_nat)
+ moreover note one two
+ ultimately show ?thesis by blast
+qed
+
+lemma binary_chinese_remainder_aux_int:
+ assumes a: "coprime (m1::int) m2"
+ shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
+ [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
+proof -
+ from cong_solve_coprime_int [OF a]
+ obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
+ by auto
+ from a have b: "coprime m2 m1"
+ by (subst gcd_commute_int)
+ from cong_solve_coprime_int [OF b]
+ obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
+ by auto
+ have "[m1 * x1 = 0] (mod m1)"
+ by (subst mult_commute, rule cong_mult_self_int)
+ moreover have "[m2 * x2 = 0] (mod m2)"
+ by (subst mult_commute, rule cong_mult_self_int)
+ moreover note one two
+ ultimately show ?thesis by blast
+qed
+
+lemma binary_chinese_remainder_nat:
+ assumes a: "coprime (m1::nat) m2"
+ shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
+proof -
+ from binary_chinese_remainder_aux_nat [OF a] obtain b1 b2
+ where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
+ "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
+ by blast
+ let ?x = "u1 * b1 + u2 * b2"
+ have "[?x = u1 * 1 + u2 * 0] (mod m1)"
+ apply (rule cong_add_nat)
+ apply (rule cong_scalar2_nat)
+ apply (rule `[b1 = 1] (mod m1)`)
+ apply (rule cong_scalar2_nat)
+ apply (rule `[b2 = 0] (mod m1)`)
+ done
+ hence "[?x = u1] (mod m1)" by simp
+ have "[?x = u1 * 0 + u2 * 1] (mod m2)"
+ apply (rule cong_add_nat)
+ apply (rule cong_scalar2_nat)
+ apply (rule `[b1 = 0] (mod m2)`)
+ apply (rule cong_scalar2_nat)
+ apply (rule `[b2 = 1] (mod m2)`)
+ done
+ hence "[?x = u2] (mod m2)" by simp
+ with `[?x = u1] (mod m1)` show ?thesis by blast
+qed
+
+lemma binary_chinese_remainder_int:
+ assumes a: "coprime (m1::int) m2"
+ shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
+proof -
+ from binary_chinese_remainder_aux_int [OF a] obtain b1 b2
+ where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
+ "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
+ by blast
+ let ?x = "u1 * b1 + u2 * b2"
+ have "[?x = u1 * 1 + u2 * 0] (mod m1)"
+ apply (rule cong_add_int)
+ apply (rule cong_scalar2_int)
+ apply (rule `[b1 = 1] (mod m1)`)
+ apply (rule cong_scalar2_int)
+ apply (rule `[b2 = 0] (mod m1)`)
+ done
+ hence "[?x = u1] (mod m1)" by simp
+ have "[?x = u1 * 0 + u2 * 1] (mod m2)"
+ apply (rule cong_add_int)
+ apply (rule cong_scalar2_int)
+ apply (rule `[b1 = 0] (mod m2)`)
+ apply (rule cong_scalar2_int)
+ apply (rule `[b2 = 1] (mod m2)`)
+ done
+ hence "[?x = u2] (mod m2)" by simp
+ with `[?x = u1] (mod m1)` show ?thesis by blast
+qed
+
+lemma cong_modulus_mult_nat: "[(x::nat) = y] (mod m * n) \<Longrightarrow>
+ [x = y] (mod m)"
+ apply (case_tac "y \<le> x")
+ apply (simp add: cong_altdef_nat)
+ apply (erule dvd_mult_left)
+ apply (rule cong_sym_nat)
+ apply (subst (asm) cong_sym_eq_nat)
+ apply (simp add: cong_altdef_nat)
+ apply (erule dvd_mult_left)
+done
+
+lemma cong_modulus_mult_int: "[(x::int) = y] (mod m * n) \<Longrightarrow>
+ [x = y] (mod m)"
+ apply (simp add: cong_altdef_int)
+ apply (erule dvd_mult_left)
+done
+
+lemma cong_less_modulus_unique_nat:
+ "[(x::nat) = y] (mod m) \<Longrightarrow> x < m \<Longrightarrow> y < m \<Longrightarrow> x = y"
+ by (simp add: cong_nat_def)
+
+lemma binary_chinese_remainder_unique_nat:
+ assumes a: "coprime (m1::nat) m2" and
+ nz: "m1 \<noteq> 0" "m2 \<noteq> 0"
+ shows "EX! x. x < m1 * m2 \<and> [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
+proof -
+ from binary_chinese_remainder_nat [OF a] obtain y where
+ "[y = u1] (mod m1)" and "[y = u2] (mod m2)"
+ by blast
+ let ?x = "y mod (m1 * m2)"
+ from nz have less: "?x < m1 * m2"
+ by auto
+ have one: "[?x = u1] (mod m1)"
+ apply (rule cong_trans_nat)
+ prefer 2
+ apply (rule `[y = u1] (mod m1)`)
+ apply (rule cong_modulus_mult_nat)
+ apply (rule cong_mod_nat)
+ using nz apply auto
+ done
+ have two: "[?x = u2] (mod m2)"
+ apply (rule cong_trans_nat)
+ prefer 2
+ apply (rule `[y = u2] (mod m2)`)
+ apply (subst mult_commute)
+ apply (rule cong_modulus_mult_nat)
+ apply (rule cong_mod_nat)
+ using nz apply auto
+ done
+ have "ALL z. z < m1 * m2 \<and> [z = u1] (mod m1) \<and> [z = u2] (mod m2) \<longrightarrow>
+ z = ?x"
+ proof (clarify)
+ fix z
+ assume "z < m1 * m2"
+ assume "[z = u1] (mod m1)" and "[z = u2] (mod m2)"
+ have "[?x = z] (mod m1)"
+ apply (rule cong_trans_nat)
+ apply (rule `[?x = u1] (mod m1)`)
+ apply (rule cong_sym_nat)
+ apply (rule `[z = u1] (mod m1)`)
+ done
+ moreover have "[?x = z] (mod m2)"
+ apply (rule cong_trans_nat)
+ apply (rule `[?x = u2] (mod m2)`)
+ apply (rule cong_sym_nat)
+ apply (rule `[z = u2] (mod m2)`)
+ done
+ ultimately have "[?x = z] (mod m1 * m2)"
+ by (auto intro: coprime_cong_mult_nat a)
+ with `z < m1 * m2` `?x < m1 * m2` show "z = ?x"
+ apply (intro cong_less_modulus_unique_nat)
+ apply (auto, erule cong_sym_nat)
+ done
+ qed
+ with less one two show ?thesis
+ by auto
+ qed
+
+lemma chinese_remainder_aux_nat:
+ fixes A :: "'a set" and
+ m :: "'a \<Rightarrow> nat"
+ assumes fin: "finite A" and
+ cop: "ALL i : A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
+ shows "EX b. (ALL i : A.
+ [b i = 1] (mod m i) \<and> [b i = 0] (mod (PROD j : A - {i}. m j)))"
+proof (rule finite_set_choice, rule fin, rule ballI)
+ fix i
+ assume "i : A"
+ with cop have "coprime (PROD j : A - {i}. m j) (m i)"
+ by (intro setprod_coprime_nat, auto)
+ hence "EX x. [(PROD j : A - {i}. m j) * x = 1] (mod m i)"
+ by (elim cong_solve_coprime_nat)
+ then obtain x where "[(PROD j : A - {i}. m j) * x = 1] (mod m i)"
+ by auto
+ moreover have "[(PROD j : A - {i}. m j) * x = 0]
+ (mod (PROD j : A - {i}. m j))"
+ by (subst mult_commute, rule cong_mult_self_nat)
+ ultimately show "\<exists>a. [a = 1] (mod m i) \<and> [a = 0]
+ (mod setprod m (A - {i}))"
+ by blast
+qed
+
+lemma chinese_remainder_nat:
+ fixes A :: "'a set" and
+ m :: "'a \<Rightarrow> nat" and
+ u :: "'a \<Rightarrow> nat"
+ assumes
+ fin: "finite A" and
+ cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
+ shows "EX x. (ALL i:A. [x = u i] (mod m i))"
+proof -
+ from chinese_remainder_aux_nat [OF fin cop] obtain b where
+ bprop: "ALL i:A. [b i = 1] (mod m i) \<and>
+ [b i = 0] (mod (PROD j : A - {i}. m j))"
+ by blast
+ let ?x = "SUM i:A. (u i) * (b i)"
+ show "?thesis"
+ proof (rule exI, clarify)
+ fix i
+ assume a: "i : A"
+ show "[?x = u i] (mod m i)"
+ proof -
+ from fin a have "?x = (SUM j:{i}. u j * b j) +
+ (SUM j:A-{i}. u j * b j)"
+ by (subst setsum_Un_disjoint [symmetric], auto intro: setsum_cong)
+ hence "[?x = u i * b i + (SUM j:A-{i}. u j * b j)] (mod m i)"
+ by auto
+ also have "[u i * b i + (SUM j:A-{i}. u j * b j) =
+ u i * 1 + (SUM j:A-{i}. u j * 0)] (mod m i)"
+ apply (rule cong_add_nat)
+ apply (rule cong_scalar2_nat)
+ using bprop a apply blast
+ apply (rule cong_setsum_nat)
+ apply (rule cong_scalar2_nat)
+ using bprop apply auto
+ apply (rule cong_dvd_modulus_nat)
+ apply (drule (1) bspec)
+ apply (erule conjE)
+ apply assumption
+ apply (rule dvd_setprod)
+ using fin a apply auto
+ done
+ finally show ?thesis
+ by simp
+ qed
+ qed
+qed
+
+lemma coprime_cong_prod_nat [rule_format]: "finite A \<Longrightarrow>
+ (ALL i: A. (ALL j: A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
+ (ALL i: A. [(x::nat) = y] (mod m i)) \<longrightarrow>
+ [x = y] (mod (PROD i:A. m i))"
+ apply (induct set: finite)
+ apply auto
+ apply (erule (1) coprime_cong_mult_nat)
+ apply (subst gcd_commute_nat)
+ apply (rule setprod_coprime_nat)
+ apply auto
+done
+
+lemma chinese_remainder_unique_nat:
+ fixes A :: "'a set" and
+ m :: "'a \<Rightarrow> nat" and
+ u :: "'a \<Rightarrow> nat"
+ assumes
+ fin: "finite A" and
+ nz: "ALL i:A. m i \<noteq> 0" and
+ cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
+ shows "EX! x. x < (PROD i:A. m i) \<and> (ALL i:A. [x = u i] (mod m i))"
+proof -
+ from chinese_remainder_nat [OF fin cop] obtain y where
+ one: "(ALL i:A. [y = u i] (mod m i))"
+ by blast
+ let ?x = "y mod (PROD i:A. m i)"
+ from fin nz have prodnz: "(PROD i:A. m i) \<noteq> 0"
+ by auto
+ hence less: "?x < (PROD i:A. m i)"
+ by auto
+ have cong: "ALL i:A. [?x = u i] (mod m i)"
+ apply auto
+ apply (rule cong_trans_nat)
+ prefer 2
+ using one apply auto
+ apply (rule cong_dvd_modulus_nat)
+ apply (rule cong_mod_nat)
+ using prodnz apply auto
+ apply (rule dvd_setprod)
+ apply (rule fin)
+ apply assumption
+ done
+ have unique: "ALL z. z < (PROD i:A. m i) \<and>
+ (ALL i:A. [z = u i] (mod m i)) \<longrightarrow> z = ?x"
+ proof (clarify)
+ fix z
+ assume zless: "z < (PROD i:A. m i)"
+ assume zcong: "(ALL i:A. [z = u i] (mod m i))"
+ have "ALL i:A. [?x = z] (mod m i)"
+ apply clarify
+ apply (rule cong_trans_nat)
+ using cong apply (erule bspec)
+ apply (rule cong_sym_nat)
+ using zcong apply auto
+ done
+ with fin cop have "[?x = z] (mod (PROD i:A. m i))"
+ by (intro coprime_cong_prod_nat, auto)
+ with zless less show "z = ?x"
+ apply (intro cong_less_modulus_unique_nat)
+ apply (auto, erule cong_sym_nat)
+ done
+ qed
+ from less cong unique show ?thesis
+ by blast
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Fib.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,319 @@
+(* Title: Fib.thy
+ Authors: Lawrence C. Paulson, Jeremy Avigad
+
+
+Defines the fibonacci function.
+
+The original "Fib" is due to Lawrence C. Paulson, and was adapted by
+Jeremy Avigad.
+*)
+
+
+header {* Fib *}
+
+theory Fib
+imports Binomial
+begin
+
+
+subsection {* Main definitions *}
+
+class fib =
+
+fixes
+ fib :: "'a \<Rightarrow> 'a"
+
+
+(* definition for the natural numbers *)
+
+instantiation nat :: fib
+
+begin
+
+fun
+ fib_nat :: "nat \<Rightarrow> nat"
+where
+ "fib_nat n =
+ (if n = 0 then 0 else
+ (if n = 1 then 1 else
+ fib (n - 1) + fib (n - 2)))"
+
+instance proof qed
+
+end
+
+(* definition for the integers *)
+
+instantiation int :: fib
+
+begin
+
+definition
+ fib_int :: "int \<Rightarrow> int"
+where
+ "fib_int n = (if n >= 0 then int (fib (nat n)) else 0)"
+
+instance proof qed
+
+end
+
+
+subsection {* Set up Transfer *}
+
+
+lemma transfer_nat_int_fib:
+ "(x::int) >= 0 \<Longrightarrow> fib (nat x) = nat (fib x)"
+ unfolding fib_int_def by auto
+
+lemma transfer_nat_int_fib_closure:
+ "n >= (0::int) \<Longrightarrow> fib n >= 0"
+ by (auto simp add: fib_int_def)
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_fib transfer_nat_int_fib_closure]
+
+lemma transfer_int_nat_fib:
+ "fib (int n) = int (fib n)"
+ unfolding fib_int_def by auto
+
+lemma transfer_int_nat_fib_closure:
+ "is_nat n \<Longrightarrow> fib n >= 0"
+ unfolding fib_int_def by auto
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_fib transfer_int_nat_fib_closure]
+
+
+subsection {* Fibonacci numbers *}
+
+lemma fib_0_nat [simp]: "fib (0::nat) = 0"
+ by simp
+
+lemma fib_0_int [simp]: "fib (0::int) = 0"
+ unfolding fib_int_def by simp
+
+lemma fib_1_nat [simp]: "fib (1::nat) = 1"
+ by simp
+
+lemma fib_Suc_0_nat [simp]: "fib (Suc 0) = Suc 0"
+ by simp
+
+lemma fib_1_int [simp]: "fib (1::int) = 1"
+ unfolding fib_int_def by simp
+
+lemma fib_reduce_nat: "(n::nat) >= 2 \<Longrightarrow> fib n = fib (n - 1) + fib (n - 2)"
+ by simp
+
+declare fib_nat.simps [simp del]
+
+lemma fib_reduce_int: "(n::int) >= 2 \<Longrightarrow> fib n = fib (n - 1) + fib (n - 2)"
+ unfolding fib_int_def
+ by (auto simp add: fib_reduce_nat nat_diff_distrib)
+
+lemma fib_neg_int [simp]: "(n::int) < 0 \<Longrightarrow> fib n = 0"
+ unfolding fib_int_def by auto
+
+lemma fib_2_nat [simp]: "fib (2::nat) = 1"
+ by (subst fib_reduce_nat, auto)
+
+lemma fib_2_int [simp]: "fib (2::int) = 1"
+ by (subst fib_reduce_int, auto)
+
+lemma fib_plus_2_nat: "fib ((n::nat) + 2) = fib (n + 1) + fib n"
+ by (subst fib_reduce_nat, auto simp add: One_nat_def)
+(* the need for One_nat_def is due to the natdiff_cancel_numerals
+ procedure *)
+
+lemma fib_induct_nat: "P (0::nat) \<Longrightarrow> P (1::nat) \<Longrightarrow>
+ (!!n. P n \<Longrightarrow> P (n + 1) \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
+ apply (atomize, induct n rule: nat_less_induct)
+ apply auto
+ apply (case_tac "n = 0", force)
+ apply (case_tac "n = 1", force)
+ apply (subgoal_tac "n >= 2")
+ apply (frule_tac x = "n - 1" in spec)
+ apply (drule_tac x = "n - 2" in spec)
+ apply (drule_tac x = "n - 2" in spec)
+ apply auto
+ apply (auto simp add: One_nat_def) (* again, natdiff_cancel *)
+done
+
+lemma fib_add_nat: "fib ((n::nat) + k + 1) = fib (k + 1) * fib (n + 1) +
+ fib k * fib n"
+ apply (induct n rule: fib_induct_nat)
+ apply auto
+ apply (subst fib_reduce_nat)
+ apply (auto simp add: ring_simps)
+ apply (subst (1 3 5) fib_reduce_nat)
+ apply (auto simp add: ring_simps Suc_eq_plus1)
+(* hmmm. Why doesn't "n + (1 + (1 + k))" simplify to "n + k + 2"? *)
+ apply (subgoal_tac "n + (k + 2) = n + (1 + (1 + k))")
+ apply (erule ssubst) back back
+ apply (erule ssubst) back
+ apply auto
+done
+
+lemma fib_add'_nat: "fib (n + Suc k) = fib (Suc k) * fib (Suc n) +
+ fib k * fib n"
+ using fib_add_nat by (auto simp add: One_nat_def)
+
+
+(* transfer from nats to ints *)
+lemma fib_add_int [rule_format]: "(n::int) >= 0 \<Longrightarrow> k >= 0 \<Longrightarrow>
+ fib (n + k + 1) = fib (k + 1) * fib (n + 1) +
+ fib k * fib n "
+
+ by (rule fib_add_nat [transferred])
+
+lemma fib_neq_0_nat: "(n::nat) > 0 \<Longrightarrow> fib n ~= 0"
+ apply (induct n rule: fib_induct_nat)
+ apply (auto simp add: fib_plus_2_nat)
+done
+
+lemma fib_gr_0_nat: "(n::nat) > 0 \<Longrightarrow> fib n > 0"
+ by (frule fib_neq_0_nat, simp)
+
+lemma fib_gr_0_int: "(n::int) > 0 \<Longrightarrow> fib n > 0"
+ unfolding fib_int_def by (simp add: fib_gr_0_nat)
+
+text {*
+ \medskip Concrete Mathematics, page 278: Cassini's identity. The proof is
+ much easier using integers, not natural numbers!
+*}
+
+lemma fib_Cassini_aux_int: "fib (int n + 2) * fib (int n) -
+ (fib (int n + 1))^2 = (-1)^(n + 1)"
+ apply (induct n)
+ apply (auto simp add: ring_simps power2_eq_square fib_reduce_int
+ power_add)
+done
+
+lemma fib_Cassini_int: "n >= 0 \<Longrightarrow> fib (n + 2) * fib n -
+ (fib (n + 1))^2 = (-1)^(nat n + 1)"
+ by (insert fib_Cassini_aux_int [of "nat n"], auto)
+
+(*
+lemma fib_Cassini'_int: "n >= 0 \<Longrightarrow> fib (n + 2) * fib n =
+ (fib (n + 1))^2 + (-1)^(nat n + 1)"
+ by (frule fib_Cassini_int, simp)
+*)
+
+lemma fib_Cassini'_int: "n >= 0 \<Longrightarrow> fib ((n::int) + 2) * fib n =
+ (if even n then tsub ((fib (n + 1))^2) 1
+ else (fib (n + 1))^2 + 1)"
+ apply (frule fib_Cassini_int, auto simp add: pos_int_even_equiv_nat_even)
+ apply (subst tsub_eq)
+ apply (insert fib_gr_0_int [of "n + 1"], force)
+ apply auto
+done
+
+lemma fib_Cassini_nat: "fib ((n::nat) + 2) * fib n =
+ (if even n then (fib (n + 1))^2 - 1
+ else (fib (n + 1))^2 + 1)"
+
+ by (rule fib_Cassini'_int [transferred, of n], auto)
+
+
+text {* \medskip Toward Law 6.111 of Concrete Mathematics *}
+
+lemma coprime_fib_plus_1_nat: "coprime (fib (n::nat)) (fib (n + 1))"
+ apply (induct n rule: fib_induct_nat)
+ apply auto
+ apply (subst (2) fib_reduce_nat)
+ apply (auto simp add: Suc_eq_plus1) (* again, natdiff_cancel *)
+ apply (subst add_commute, auto)
+ apply (subst gcd_commute_nat, auto simp add: ring_simps)
+done
+
+lemma coprime_fib_Suc_nat: "coprime (fib n) (fib (Suc n))"
+ using coprime_fib_plus_1_nat by (simp add: One_nat_def)
+
+lemma coprime_fib_plus_1_int:
+ "n >= 0 \<Longrightarrow> coprime (fib (n::int)) (fib (n + 1))"
+ by (erule coprime_fib_plus_1_nat [transferred])
+
+lemma gcd_fib_add_nat: "gcd (fib (m::nat)) (fib (n + m)) = gcd (fib m) (fib n)"
+ apply (simp add: gcd_commute_nat [of "fib m"])
+ apply (rule cases_nat [of _ m])
+ apply simp
+ apply (subst add_assoc [symmetric])
+ apply (simp add: fib_add_nat)
+ apply (subst gcd_commute_nat)
+ apply (subst mult_commute)
+ apply (subst gcd_add_mult_nat)
+ apply (subst gcd_commute_nat)
+ apply (rule gcd_mult_cancel_nat)
+ apply (rule coprime_fib_plus_1_nat)
+done
+
+lemma gcd_fib_add_int [rule_format]: "m >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
+ gcd (fib (m::int)) (fib (n + m)) = gcd (fib m) (fib n)"
+ by (erule gcd_fib_add_nat [transferred])
+
+lemma gcd_fib_diff_nat: "(m::nat) \<le> n \<Longrightarrow>
+ gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
+ by (simp add: gcd_fib_add_nat [symmetric, of _ "n-m"])
+
+lemma gcd_fib_diff_int: "0 <= (m::int) \<Longrightarrow> m \<le> n \<Longrightarrow>
+ gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
+ by (simp add: gcd_fib_add_int [symmetric, of _ "n-m"])
+
+lemma gcd_fib_mod_nat: "0 < (m::nat) \<Longrightarrow>
+ gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+proof (induct n rule: less_induct)
+ case (less n)
+ from less.prems have pos_m: "0 < m" .
+ show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+ proof (cases "m < n")
+ case True note m_n = True
+ then have m_n': "m \<le> n" by auto
+ with pos_m have pos_n: "0 < n" by auto
+ with pos_m m_n have diff: "n - m < n" by auto
+ have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
+ by (simp add: mod_if [of n]) (insert m_n, auto)
+ also have "\<dots> = gcd (fib m) (fib (n - m))"
+ by (simp add: less.hyps diff pos_m)
+ also have "\<dots> = gcd (fib m) (fib n)" by (simp add: gcd_fib_diff_nat m_n')
+ finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
+ next
+ case False then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+ by (cases "m = n") auto
+ qed
+qed
+
+lemma gcd_fib_mod_int:
+ assumes "0 < (m::int)" and "0 <= n"
+ shows "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+
+ apply (rule gcd_fib_mod_nat [transferred])
+ using prems apply auto
+done
+
+lemma fib_gcd_nat: "fib (gcd (m::nat) n) = gcd (fib m) (fib n)"
+ -- {* Law 6.111 *}
+ apply (induct m n rule: gcd_nat_induct)
+ apply (simp_all add: gcd_non_0_nat gcd_commute_nat gcd_fib_mod_nat)
+done
+
+lemma fib_gcd_int: "m >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
+ fib (gcd (m::int) n) = gcd (fib m) (fib n)"
+ by (erule fib_gcd_nat [transferred])
+
+lemma atMost_plus_one_nat: "{..(k::nat) + 1} = insert (k + 1) {..k}"
+ by auto
+
+theorem fib_mult_eq_setsum_nat:
+ "fib ((n::nat) + 1) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
+ apply (induct n)
+ apply (auto simp add: atMost_plus_one_nat fib_plus_2_nat ring_simps)
+done
+
+theorem fib_mult_eq_setsum'_nat:
+ "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
+ using fib_mult_eq_setsum_nat by (simp add: One_nat_def)
+
+theorem fib_mult_eq_setsum_int [rule_format]:
+ "n >= 0 \<Longrightarrow> fib ((n::int) + 1) * fib n = (\<Sum>k \<in> {0..n}. fib k * fib k)"
+ by (erule fib_mult_eq_setsum_nat [transferred])
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/MiscAlgebra.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,355 @@
+(* Title: MiscAlgebra.thy
+ Author: Jeremy Avigad
+
+These are things that can be added to the Algebra library.
+*)
+
+theory MiscAlgebra
+imports
+ "~~/src/HOL/Algebra/Ring"
+ "~~/src/HOL/Algebra/FiniteProduct"
+begin;
+
+(* finiteness stuff *)
+
+lemma bounded_set1_int [intro]: "finite {(x::int). a < x & x < b & P x}"
+ apply (subgoal_tac "{x. a < x & x < b & P x} <= {a<..<b}")
+ apply (erule finite_subset)
+ apply auto
+done
+
+
+(* The rest is for the algebra libraries *)
+
+(* These go in Group.thy. *)
+
+(*
+ Show that the units in any monoid give rise to a group.
+
+ The file Residues.thy provides some infrastructure to use
+ facts about the unit group within the ring locale.
+*)
+
+
+constdefs
+ units_of :: "('a, 'b) monoid_scheme => 'a monoid"
+ "units_of G == (| carrier = Units G,
+ Group.monoid.mult = Group.monoid.mult G,
+ one = one G |)";
+
+(*
+
+lemma (in monoid) Units_mult_closed [intro]:
+ "x : Units G ==> y : Units G ==> x \<otimes> y : Units G"
+ apply (unfold Units_def)
+ apply (clarsimp)
+ apply (rule_tac x = "xaa \<otimes> xa" in bexI)
+ apply auto
+ apply (subst m_assoc)
+ apply auto
+ apply (subst (2) m_assoc [symmetric])
+ apply auto
+ apply (subst m_assoc)
+ apply auto
+ apply (subst (2) m_assoc [symmetric])
+ apply auto
+done
+
+*)
+
+lemma (in monoid) units_group: "group(units_of G)"
+ apply (unfold units_of_def)
+ apply (rule groupI)
+ apply auto
+ apply (subst m_assoc)
+ apply auto
+ apply (rule_tac x = "inv x" in bexI)
+ apply auto
+done
+
+lemma (in comm_monoid) units_comm_group: "comm_group(units_of G)"
+ apply (rule group.group_comm_groupI)
+ apply (rule units_group)
+ apply (insert prems)
+ apply (unfold units_of_def Units_def comm_monoid_def comm_monoid_axioms_def)
+ apply auto;
+done;
+
+lemma units_of_carrier: "carrier (units_of G) = Units G"
+ by (unfold units_of_def, auto)
+
+lemma units_of_mult: "mult(units_of G) = mult G"
+ by (unfold units_of_def, auto)
+
+lemma units_of_one: "one(units_of G) = one G"
+ by (unfold units_of_def, auto)
+
+lemma (in monoid) units_of_inv: "x : Units G ==>
+ m_inv (units_of G) x = m_inv G x"
+ apply (rule sym)
+ apply (subst m_inv_def)
+ apply (rule the1_equality)
+ apply (rule ex_ex1I)
+ apply (subst (asm) Units_def)
+ apply auto
+ apply (erule inv_unique)
+ apply auto
+ apply (rule Units_closed)
+ apply (simp_all only: units_of_carrier [symmetric])
+ apply (insert units_group)
+ apply auto
+ apply (subst units_of_mult [symmetric])
+ apply (subst units_of_one [symmetric])
+ apply (erule group.r_inv, assumption)
+ apply (subst units_of_mult [symmetric])
+ apply (subst units_of_one [symmetric])
+ apply (erule group.l_inv, assumption)
+done
+
+lemma (in group) inj_on_const_mult: "a: (carrier G) ==>
+ inj_on (%x. a \<otimes> x) (carrier G)"
+ by (unfold inj_on_def, auto)
+
+lemma (in group) surj_const_mult: "a : (carrier G) ==>
+ (%x. a \<otimes> x) ` (carrier G) = (carrier G)"
+ apply (auto simp add: image_def)
+ apply (rule_tac x = "(m_inv G a) \<otimes> x" in bexI)
+ apply auto
+(* auto should get this. I suppose we need "comm_monoid_simprules"
+ for mult_ac rewriting. *)
+ apply (subst m_assoc [symmetric])
+ apply auto
+done
+
+lemma (in group) l_cancel_one [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
+ (x \<otimes> a = x) = (a = one G)"
+ apply auto
+ apply (subst l_cancel [symmetric])
+ prefer 4
+ apply (erule ssubst)
+ apply auto
+done
+
+lemma (in group) r_cancel_one [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
+ (a \<otimes> x = x) = (a = one G)"
+ apply auto
+ apply (subst r_cancel [symmetric])
+ prefer 4
+ apply (erule ssubst)
+ apply auto
+done
+
+(* Is there a better way to do this? *)
+
+lemma (in group) l_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
+ (x = x \<otimes> a) = (a = one G)"
+ by (subst eq_commute, simp)
+
+lemma (in group) r_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
+ (x = a \<otimes> x) = (a = one G)"
+ by (subst eq_commute, simp)
+
+(* This should be generalized to arbitrary groups, not just commutative
+ ones, using Lagrange's theorem. *)
+
+lemma (in comm_group) power_order_eq_one:
+ assumes fin [simp]: "finite (carrier G)"
+ and a [simp]: "a : carrier G"
+ shows "a (^) card(carrier G) = one G"
+proof -
+ have "(\<Otimes>x:carrier G. x) = (\<Otimes>x:carrier G. a \<otimes> x)"
+ by (subst (2) finprod_reindex [symmetric],
+ auto simp add: Pi_def inj_on_const_mult surj_const_mult)
+ also have "\<dots> = (\<Otimes>x:carrier G. a) \<otimes> (\<Otimes>x:carrier G. x)"
+ by (auto simp add: finprod_multf Pi_def)
+ also have "(\<Otimes>x:carrier G. a) = a (^) card(carrier G)"
+ by (auto simp add: finprod_const)
+ finally show ?thesis
+(* uses the preceeding lemma *)
+ by auto
+qed
+
+
+(* Miscellaneous *)
+
+lemma (in cring) field_intro2: "\<zero>\<^bsub>R\<^esub> ~= \<one>\<^bsub>R\<^esub> \<Longrightarrow> ALL x : carrier R - {\<zero>\<^bsub>R\<^esub>}.
+ x : Units R \<Longrightarrow> field R"
+ apply (unfold_locales)
+ apply (insert prems, auto)
+ apply (rule trans)
+ apply (subgoal_tac "a = (a \<otimes> b) \<otimes> inv b")
+ apply assumption
+ apply (subst m_assoc)
+ apply (auto simp add: Units_r_inv)
+ apply (unfold Units_def)
+ apply auto
+done
+
+lemma (in monoid) inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
+ x \<otimes> y = \<one> \<Longrightarrow> y \<otimes> x = \<one> \<Longrightarrow> inv x = y"
+ apply (subgoal_tac "x : Units G")
+ apply (subgoal_tac "y = inv x \<otimes> \<one>")
+ apply simp
+ apply (erule subst)
+ apply (subst m_assoc [symmetric])
+ apply auto
+ apply (unfold Units_def)
+ apply auto
+done
+
+lemma (in comm_monoid) comm_inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
+ x \<otimes> y = \<one> \<Longrightarrow> inv x = y"
+ apply (rule inv_char)
+ apply auto
+ apply (subst m_comm, auto)
+done
+
+lemma (in ring) inv_neg_one [simp]: "inv (\<ominus> \<one>) = \<ominus> \<one>"
+ apply (rule inv_char)
+ apply (auto simp add: l_minus r_minus)
+done
+
+lemma (in monoid) inv_eq_imp_eq: "x : Units G \<Longrightarrow> y : Units G \<Longrightarrow>
+ inv x = inv y \<Longrightarrow> x = y"
+ apply (subgoal_tac "inv(inv x) = inv(inv y)")
+ apply (subst (asm) Units_inv_inv)+
+ apply auto
+done
+
+lemma (in ring) Units_minus_one_closed [intro]: "\<ominus> \<one> : Units R"
+ apply (unfold Units_def)
+ apply auto
+ apply (rule_tac x = "\<ominus> \<one>" in bexI)
+ apply auto
+ apply (simp add: l_minus r_minus)
+done
+
+lemma (in monoid) inv_one [simp]: "inv \<one> = \<one>"
+ apply (rule inv_char)
+ apply auto
+done
+
+lemma (in ring) inv_eq_neg_one_eq: "x : Units R \<Longrightarrow> (inv x = \<ominus> \<one>) = (x = \<ominus> \<one>)"
+ apply auto
+ apply (subst Units_inv_inv [symmetric])
+ apply auto
+done
+
+lemma (in monoid) inv_eq_one_eq: "x : Units G \<Longrightarrow> (inv x = \<one>) = (x = \<one>)"
+ apply auto
+ apply (subst Units_inv_inv [symmetric])
+ apply auto
+done
+
+
+(* This goes in FiniteProduct *)
+
+lemma (in comm_monoid) finprod_UN_disjoint:
+ "finite I \<Longrightarrow> (ALL i:I. finite (A i)) \<longrightarrow> (ALL i:I. ALL j:I. i ~= j \<longrightarrow>
+ (A i) Int (A j) = {}) \<longrightarrow>
+ (ALL i:I. ALL x: (A i). g x : carrier G) \<longrightarrow>
+ finprod G g (UNION I A) = finprod G (%i. finprod G g (A i)) I"
+ apply (induct set: finite)
+ apply force
+ apply clarsimp
+ apply (subst finprod_Un_disjoint)
+ apply blast
+ apply (erule finite_UN_I)
+ apply blast
+ apply (fastsimp)
+ apply (auto intro!: funcsetI finprod_closed)
+done
+
+lemma (in comm_monoid) finprod_Union_disjoint:
+ "[| finite C; (ALL A:C. finite A & (ALL x:A. f x : carrier G));
+ (ALL A:C. ALL B:C. A ~= B --> A Int B = {}) |]
+ ==> finprod G f (Union C) = finprod G (finprod G f) C"
+ apply (frule finprod_UN_disjoint [of C id f])
+ apply (unfold Union_def id_def, auto)
+done
+
+lemma (in comm_monoid) finprod_one [rule_format]:
+ "finite A \<Longrightarrow> (ALL x:A. f x = \<one>) \<longrightarrow>
+ finprod G f A = \<one>"
+by (induct set: finite) auto
+
+
+(* need better simplification rules for rings *)
+(* the next one holds more generally for abelian groups *)
+
+lemma (in cring) sum_zero_eq_neg:
+ "x : carrier R \<Longrightarrow> y : carrier R \<Longrightarrow> x \<oplus> y = \<zero> \<Longrightarrow> x = \<ominus> y"
+ apply (subgoal_tac "\<ominus> y = \<zero> \<oplus> \<ominus> y")
+ apply (erule ssubst)back
+ apply (erule subst)
+ apply (simp add: ring_simprules)+
+done
+
+(* there's a name conflict -- maybe "domain" should be
+ "integral_domain" *)
+
+lemma (in Ring.domain) square_eq_one:
+ fixes x
+ assumes [simp]: "x : carrier R" and
+ "x \<otimes> x = \<one>"
+ shows "x = \<one> | x = \<ominus>\<one>"
+proof -
+ have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = x \<otimes> x \<oplus> \<ominus> \<one>"
+ by (simp add: ring_simprules)
+ also with `x \<otimes> x = \<one>` have "\<dots> = \<zero>"
+ by (simp add: ring_simprules)
+ finally have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = \<zero>" .
+ hence "(x \<oplus> \<one>) = \<zero> | (x \<oplus> \<ominus> \<one>) = \<zero>"
+ by (intro integral, auto)
+ thus ?thesis
+ apply auto
+ apply (erule notE)
+ apply (rule sum_zero_eq_neg)
+ apply auto
+ apply (subgoal_tac "x = \<ominus> (\<ominus> \<one>)")
+ apply (simp add: ring_simprules)
+ apply (rule sum_zero_eq_neg)
+ apply auto
+ done
+qed
+
+lemma (in Ring.domain) inv_eq_self: "x : Units R \<Longrightarrow>
+ x = inv x \<Longrightarrow> x = \<one> | x = \<ominus> \<one>"
+ apply (rule square_eq_one)
+ apply auto
+ apply (erule ssubst)back
+ apply (erule Units_r_inv)
+done
+
+
+(*
+ The following translates theorems about groups to the facts about
+ the units of a ring. (The list should be expanded as more things are
+ needed.)
+*)
+
+lemma (in ring) finite_ring_finite_units [intro]: "finite (carrier R) \<Longrightarrow>
+ finite (Units R)"
+ by (rule finite_subset, auto)
+
+(* this belongs with MiscAlgebra.thy *)
+lemma (in monoid) units_of_pow:
+ "x : Units G \<Longrightarrow> x (^)\<^bsub>units_of G\<^esub> (n::nat) = x (^)\<^bsub>G\<^esub> n"
+ apply (induct n)
+ apply (auto simp add: units_group group.is_monoid
+ monoid.nat_pow_0 monoid.nat_pow_Suc units_of_one units_of_mult
+ One_nat_def)
+done
+
+lemma (in cring) units_power_order_eq_one: "finite (Units R) \<Longrightarrow> a : Units R
+ \<Longrightarrow> a (^) card(Units R) = \<one>"
+ apply (subst units_of_carrier [symmetric])
+ apply (subst units_of_one [symmetric])
+ apply (subst units_of_pow [symmetric])
+ apply assumption
+ apply (rule comm_group.power_order_eq_one)
+ apply (rule units_comm_group)
+ apply (unfold units_of_def, auto)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Number_Theory.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,8 @@
+
+header {* Comprehensive number theory *}
+
+theory Number_Theory
+imports Fib Residues
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Primes.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,423 @@
+(* Authors: Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
+ Thomas M. Rasmussen, Jeremy Avigad, Tobias Nipkow
+
+
+This file deals with properties of primes. Definitions and lemmas are
+proved uniformly for the natural numbers and integers.
+
+This file combines and revises a number of prior developments.
+
+The original theories "GCD" and "Primes" were by Christophe Tabacznyj
+and Lawrence C. Paulson, based on \cite{davenport92}. They introduced
+gcd, lcm, and prime for the natural numbers.
+
+The original theory "IntPrimes" was by Thomas M. Rasmussen, and
+extended gcd, lcm, primes to the integers. Amine Chaieb provided
+another extension of the notions to the integers, and added a number
+of results to "Primes" and "GCD". IntPrimes also defined and developed
+the congruence relations on the integers. The notion was extended to
+the natural numbers by Chiaeb.
+
+Jeremy Avigad combined all of these, made everything uniform for the
+natural numbers and the integers, and added a number of new theorems.
+
+Tobias Nipkow cleaned up a lot.
+*)
+
+
+header {* Primes *}
+
+theory Primes
+imports GCD
+begin
+
+declare One_nat_def [simp del]
+
+class prime = one +
+
+fixes
+ prime :: "'a \<Rightarrow> bool"
+
+instantiation nat :: prime
+
+begin
+
+definition
+ prime_nat :: "nat \<Rightarrow> bool"
+where
+ [code del]: "prime_nat p = (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"
+
+instance proof qed
+
+end
+
+instantiation int :: prime
+
+begin
+
+definition
+ prime_int :: "int \<Rightarrow> bool"
+where
+ [code del]: "prime_int p = prime (nat p)"
+
+instance proof qed
+
+end
+
+
+subsection {* Set up Transfer *}
+
+
+lemma transfer_nat_int_prime:
+ "(x::int) >= 0 \<Longrightarrow> prime (nat x) = prime x"
+ unfolding gcd_int_def lcm_int_def prime_int_def
+ by auto
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_prime]
+
+lemma transfer_int_nat_prime:
+ "prime (int x) = prime x"
+ by (unfold gcd_int_def lcm_int_def prime_int_def, auto)
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_prime]
+
+
+subsection {* Primes *}
+
+lemma prime_odd_nat: "prime (p::nat) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
+ unfolding prime_nat_def
+ apply (subst even_mult_two_ex)
+ apply clarify
+ apply (drule_tac x = 2 in spec)
+ apply auto
+done
+
+lemma prime_odd_int: "prime (p::int) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
+ unfolding prime_int_def
+ apply (frule prime_odd_nat)
+ apply (auto simp add: even_nat_def)
+done
+
+(* FIXME Is there a better way to handle these, rather than making them elim rules? *)
+
+lemma prime_ge_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 0"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_gt_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p > 0"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_ge_1_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 1"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_gt_1_nat [elim]: "prime (p::nat) \<Longrightarrow> p > 1"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_ge_Suc_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= Suc 0"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_gt_Suc_0_nat [elim]: "prime (p::nat) \<Longrightarrow> p > Suc 0"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_ge_2_nat [elim]: "prime (p::nat) \<Longrightarrow> p >= 2"
+ by (unfold prime_nat_def, auto)
+
+lemma prime_ge_0_int [elim]: "prime (p::int) \<Longrightarrow> p >= 0"
+ by (unfold prime_int_def prime_nat_def) auto
+
+lemma prime_gt_0_int [elim]: "prime (p::int) \<Longrightarrow> p > 0"
+ by (unfold prime_int_def prime_nat_def, auto)
+
+lemma prime_ge_1_int [elim]: "prime (p::int) \<Longrightarrow> p >= 1"
+ by (unfold prime_int_def prime_nat_def, auto)
+
+lemma prime_gt_1_int [elim]: "prime (p::int) \<Longrightarrow> p > 1"
+ by (unfold prime_int_def prime_nat_def, auto)
+
+lemma prime_ge_2_int [elim]: "prime (p::int) \<Longrightarrow> p >= 2"
+ by (unfold prime_int_def prime_nat_def, auto)
+
+
+lemma prime_int_altdef: "prime (p::int) = (1 < p \<and> (\<forall>m \<ge> 0. m dvd p \<longrightarrow>
+ m = 1 \<or> m = p))"
+ using prime_nat_def [transferred]
+ apply (case_tac "p >= 0")
+ by (blast, auto simp add: prime_ge_0_int)
+
+lemma prime_imp_coprime_nat: "prime (p::nat) \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
+ apply (unfold prime_nat_def)
+ apply (metis gcd_dvd1_nat gcd_dvd2_nat)
+ done
+
+lemma prime_imp_coprime_int: "prime (p::int) \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
+ apply (unfold prime_int_altdef)
+ apply (metis gcd_dvd1_int gcd_dvd2_int gcd_ge_0_int)
+ done
+
+lemma prime_dvd_mult_nat: "prime (p::nat) \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
+ by (blast intro: coprime_dvd_mult_nat prime_imp_coprime_nat)
+
+lemma prime_dvd_mult_int: "prime (p::int) \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
+ by (blast intro: coprime_dvd_mult_int prime_imp_coprime_int)
+
+lemma prime_dvd_mult_eq_nat [simp]: "prime (p::nat) \<Longrightarrow>
+ p dvd m * n = (p dvd m \<or> p dvd n)"
+ by (rule iffI, rule prime_dvd_mult_nat, auto)
+
+lemma prime_dvd_mult_eq_int [simp]: "prime (p::int) \<Longrightarrow>
+ p dvd m * n = (p dvd m \<or> p dvd n)"
+ by (rule iffI, rule prime_dvd_mult_int, auto)
+
+lemma not_prime_eq_prod_nat: "(n::nat) > 1 \<Longrightarrow> ~ prime n \<Longrightarrow>
+ EX m k. n = m * k & 1 < m & m < n & 1 < k & k < n"
+ unfolding prime_nat_def dvd_def apply auto
+ by(metis mult_commute linorder_neq_iff linorder_not_le mult_1 n_less_n_mult_m one_le_mult_iff less_imp_le_nat)
+
+lemma not_prime_eq_prod_int: "(n::int) > 1 \<Longrightarrow> ~ prime n \<Longrightarrow>
+ EX m k. n = m * k & 1 < m & m < n & 1 < k & k < n"
+ unfolding prime_int_altdef dvd_def
+ apply auto
+ by(metis div_mult_self1_is_id div_mult_self2_is_id int_div_less_self int_one_le_iff_zero_less zero_less_mult_pos zless_le)
+
+lemma prime_dvd_power_nat [rule_format]: "prime (p::nat) -->
+ n > 0 --> (p dvd x^n --> p dvd x)"
+ by (induct n rule: nat_induct, auto)
+
+lemma prime_dvd_power_int [rule_format]: "prime (p::int) -->
+ n > 0 --> (p dvd x^n --> p dvd x)"
+ apply (induct n rule: nat_induct, auto)
+ apply (frule prime_ge_0_int)
+ apply auto
+done
+
+subsubsection{* Make prime naively executable *}
+
+lemma zero_not_prime_nat [simp]: "~prime (0::nat)"
+ by (simp add: prime_nat_def)
+
+lemma zero_not_prime_int [simp]: "~prime (0::int)"
+ by (simp add: prime_int_def)
+
+lemma one_not_prime_nat [simp]: "~prime (1::nat)"
+ by (simp add: prime_nat_def)
+
+lemma Suc_0_not_prime_nat [simp]: "~prime (Suc 0)"
+ by (simp add: prime_nat_def One_nat_def)
+
+lemma one_not_prime_int [simp]: "~prime (1::int)"
+ by (simp add: prime_int_def)
+
+lemma prime_nat_code[code]:
+ "prime(p::nat) = (p > 1 & (ALL n : {1<..<p}. ~(n dvd p)))"
+apply(simp add: Ball_def)
+apply (metis less_not_refl prime_nat_def dvd_triv_right not_prime_eq_prod_nat)
+done
+
+lemma prime_nat_simp:
+ "prime(p::nat) = (p > 1 & (list_all (%n. ~ n dvd p) [2..<p]))"
+apply(simp only:prime_nat_code list_ball_code greaterThanLessThan_upt)
+apply(simp add:nat_number One_nat_def)
+done
+
+lemmas prime_nat_simp_number_of[simp] = prime_nat_simp[of "number_of m", standard]
+
+lemma prime_int_code[code]:
+ "prime(p::int) = (p > 1 & (ALL n : {1<..<p}. ~(n dvd p)))" (is "?L = ?R")
+proof
+ assume "?L" thus "?R"
+ by (clarsimp simp: prime_gt_1_int) (metis int_one_le_iff_zero_less prime_int_altdef zless_le)
+next
+ assume "?R" thus "?L" by (clarsimp simp:Ball_def) (metis dvdI not_prime_eq_prod_int)
+qed
+
+lemma prime_int_simp:
+ "prime(p::int) = (p > 1 & (list_all (%n. ~ n dvd p) [2..p - 1]))"
+apply(simp only:prime_int_code list_ball_code greaterThanLessThan_upto)
+apply simp
+done
+
+lemmas prime_int_simp_number_of[simp] = prime_int_simp[of "number_of m", standard]
+
+lemma two_is_prime_nat [simp]: "prime (2::nat)"
+by simp
+
+lemma two_is_prime_int [simp]: "prime (2::int)"
+by simp
+
+text{* A bit of regression testing: *}
+
+lemma "prime(97::nat)"
+by simp
+
+lemma "prime(97::int)"
+by simp
+
+lemma "prime(997::nat)"
+by eval
+
+lemma "prime(997::int)"
+by eval
+
+
+lemma prime_imp_power_coprime_nat: "prime (p::nat) \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
+ apply (rule coprime_exp_nat)
+ apply (subst gcd_commute_nat)
+ apply (erule (1) prime_imp_coprime_nat)
+done
+
+lemma prime_imp_power_coprime_int: "prime (p::int) \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
+ apply (rule coprime_exp_int)
+ apply (subst gcd_commute_int)
+ apply (erule (1) prime_imp_coprime_int)
+done
+
+lemma primes_coprime_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
+ apply (rule prime_imp_coprime_nat, assumption)
+ apply (unfold prime_nat_def, auto)
+done
+
+lemma primes_coprime_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
+ apply (rule prime_imp_coprime_int, assumption)
+ apply (unfold prime_int_altdef, clarify)
+ apply (drule_tac x = q in spec)
+ apply (drule_tac x = p in spec)
+ apply auto
+done
+
+lemma primes_imp_powers_coprime_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow> p ~= q \<Longrightarrow> coprime (p^m) (q^n)"
+ by (rule coprime_exp2_nat, rule primes_coprime_nat)
+
+lemma primes_imp_powers_coprime_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow> p ~= q \<Longrightarrow> coprime (p^m) (q^n)"
+ by (rule coprime_exp2_int, rule primes_coprime_int)
+
+lemma prime_factor_nat: "n \<noteq> (1::nat) \<Longrightarrow> \<exists> p. prime p \<and> p dvd n"
+ apply (induct n rule: nat_less_induct)
+ apply (case_tac "n = 0")
+ using two_is_prime_nat apply blast
+ apply (case_tac "prime n")
+ apply blast
+ apply (subgoal_tac "n > 1")
+ apply (frule (1) not_prime_eq_prod_nat)
+ apply (auto intro: dvd_mult dvd_mult2)
+done
+
+(* An Isar version:
+
+lemma prime_factor_b_nat:
+ fixes n :: nat
+ assumes "n \<noteq> 1"
+ shows "\<exists>p. prime p \<and> p dvd n"
+
+using `n ~= 1`
+proof (induct n rule: less_induct_nat)
+ fix n :: nat
+ assume "n ~= 1" and
+ ih: "\<forall>m<n. m \<noteq> 1 \<longrightarrow> (\<exists>p. prime p \<and> p dvd m)"
+ thus "\<exists>p. prime p \<and> p dvd n"
+ proof -
+ {
+ assume "n = 0"
+ moreover note two_is_prime_nat
+ ultimately have ?thesis
+ by (auto simp del: two_is_prime_nat)
+ }
+ moreover
+ {
+ assume "prime n"
+ hence ?thesis by auto
+ }
+ moreover
+ {
+ assume "n ~= 0" and "~ prime n"
+ with `n ~= 1` have "n > 1" by auto
+ with `~ prime n` and not_prime_eq_prod_nat obtain m k where
+ "n = m * k" and "1 < m" and "m < n" by blast
+ with ih obtain p where "prime p" and "p dvd m" by blast
+ with `n = m * k` have ?thesis by auto
+ }
+ ultimately show ?thesis by blast
+ qed
+qed
+
+*)
+
+text {* One property of coprimality is easier to prove via prime factors. *}
+
+lemma prime_divprod_pow_nat:
+ assumes p: "prime (p::nat)" and ab: "coprime a b" and pab: "p^n dvd a * b"
+ shows "p^n dvd a \<or> p^n dvd b"
+proof-
+ {assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
+ apply (cases "n=0", simp_all)
+ apply (cases "a=1", simp_all) done}
+ moreover
+ {assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
+ then obtain m where m: "n = Suc m" by (cases n, auto)
+ from n have "p dvd p^n" by (intro dvd_power, auto)
+ also note pab
+ finally have pab': "p dvd a * b".
+ from prime_dvd_mult_nat[OF p pab']
+ have "p dvd a \<or> p dvd b" .
+ moreover
+ {assume pa: "p dvd a"
+ have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
+ from coprime_common_divisor_nat [OF ab, OF pa] p have "\<not> p dvd b" by auto
+ with p have "coprime b p"
+ by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
+ hence pnb: "coprime (p^n) b"
+ by (subst gcd_commute_nat, rule coprime_exp_nat)
+ from coprime_divprod_nat[OF pnba pnb] have ?thesis by blast }
+ moreover
+ {assume pb: "p dvd b"
+ have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
+ from coprime_common_divisor_nat [OF ab, of p] pb p have "\<not> p dvd a"
+ by auto
+ with p have "coprime a p"
+ by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
+ hence pna: "coprime (p^n) a"
+ by (subst gcd_commute_nat, rule coprime_exp_nat)
+ from coprime_divprod_nat[OF pab pna] have ?thesis by blast }
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+subsection {* Infinitely many primes *}
+
+lemma next_prime_bound: "\<exists>(p::nat). prime p \<and> n < p \<and> p <= fact n + 1"
+proof-
+ have f1: "fact n + 1 \<noteq> 1" using fact_ge_one_nat [of n] by arith
+ from prime_factor_nat [OF f1]
+ obtain p where "prime p" and "p dvd fact n + 1" by auto
+ hence "p \<le> fact n + 1"
+ by (intro dvd_imp_le, auto)
+ {assume "p \<le> n"
+ from `prime p` have "p \<ge> 1"
+ by (cases p, simp_all)
+ with `p <= n` have "p dvd fact n"
+ by (intro dvd_fact_nat)
+ with `p dvd fact n + 1` have "p dvd fact n + 1 - fact n"
+ by (rule dvd_diff_nat)
+ hence "p dvd 1" by simp
+ hence "p <= 1" by auto
+ moreover from `prime p` have "p > 1" by auto
+ ultimately have False by auto}
+ hence "n < p" by arith
+ with `prime p` and `p <= fact n + 1` show ?thesis by auto
+qed
+
+lemma bigger_prime: "\<exists>p. prime p \<and> p > (n::nat)"
+using next_prime_bound by auto
+
+lemma primes_infinite: "\<not> (finite {(p::nat). prime p})"
+proof
+ assume "finite {(p::nat). prime p}"
+ with Max_ge have "(EX b. (ALL x : {(p::nat). prime p}. x <= b))"
+ by auto
+ then obtain b where "ALL (x::nat). prime x \<longrightarrow> x <= b"
+ by auto
+ with bigger_prime [of b] show False by auto
+qed
+
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,2 @@
+
+use_thy "Number_Theory";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Residues.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,466 @@
+(* Title: HOL/Library/Residues.thy
+ ID:
+ Author: Jeremy Avigad
+
+ An algebraic treatment of residue rings, and resulting proofs of
+ Euler's theorem and Wilson's theorem.
+*)
+
+header {* Residue rings *}
+
+theory Residues
+imports
+ UniqueFactorization
+ Binomial
+ MiscAlgebra
+begin
+
+
+(*
+
+ A locale for residue rings
+
+*)
+
+constdefs
+ residue_ring :: "int => int ring"
+ "residue_ring m == (|
+ carrier = {0..m - 1},
+ mult = (%x y. (x * y) mod m),
+ one = 1,
+ zero = 0,
+ add = (%x y. (x + y) mod m) |)"
+
+locale residues =
+ fixes m :: int and R (structure)
+ assumes m_gt_one: "m > 1"
+ defines "R == residue_ring m"
+
+context residues begin
+
+lemma abelian_group: "abelian_group R"
+ apply (insert m_gt_one)
+ apply (rule abelian_groupI)
+ apply (unfold R_def residue_ring_def)
+ apply (auto simp add: mod_pos_pos_trivial mod_add_right_eq [symmetric]
+ add_ac)
+ apply (case_tac "x = 0")
+ apply force
+ apply (subgoal_tac "(x + (m - x)) mod m = 0")
+ apply (erule bexI)
+ apply auto
+done
+
+lemma comm_monoid: "comm_monoid R"
+ apply (insert m_gt_one)
+ apply (unfold R_def residue_ring_def)
+ apply (rule comm_monoidI)
+ apply auto
+ apply (subgoal_tac "x * y mod m * z mod m = z * (x * y mod m) mod m")
+ apply (erule ssubst)
+ apply (subst zmod_zmult1_eq [symmetric])+
+ apply (simp_all only: mult_ac)
+done
+
+lemma cring: "cring R"
+ apply (rule cringI)
+ apply (rule abelian_group)
+ apply (rule comm_monoid)
+ apply (unfold R_def residue_ring_def, auto)
+ apply (subst mod_add_eq [symmetric])
+ apply (subst mult_commute)
+ apply (subst zmod_zmult1_eq [symmetric])
+ apply (simp add: ring_simps)
+done
+
+end
+
+sublocale residues < cring
+ by (rule cring)
+
+
+context residues begin
+
+(* These lemmas translate back and forth between internal and
+ external concepts *)
+
+lemma res_carrier_eq: "carrier R = {0..m - 1}"
+ by (unfold R_def residue_ring_def, auto)
+
+lemma res_add_eq: "x \<oplus> y = (x + y) mod m"
+ by (unfold R_def residue_ring_def, auto)
+
+lemma res_mult_eq: "x \<otimes> y = (x * y) mod m"
+ by (unfold R_def residue_ring_def, auto)
+
+lemma res_zero_eq: "\<zero> = 0"
+ by (unfold R_def residue_ring_def, auto)
+
+lemma res_one_eq: "\<one> = 1"
+ by (unfold R_def residue_ring_def units_of_def residue_ring_def, auto)
+
+lemma res_units_eq: "Units R = { x. 0 < x & x < m & coprime x m}"
+ apply (insert m_gt_one)
+ apply (unfold Units_def R_def residue_ring_def)
+ apply auto
+ apply (subgoal_tac "x ~= 0")
+ apply auto
+ apply (rule invertible_coprime_int)
+ apply (subgoal_tac "x ~= 0")
+ apply auto
+ apply (subst (asm) coprime_iff_invertible'_int)
+ apply (rule m_gt_one)
+ apply (auto simp add: cong_int_def mult_commute)
+done
+
+lemma res_neg_eq: "\<ominus> x = (- x) mod m"
+ apply (insert m_gt_one)
+ apply (unfold R_def a_inv_def m_inv_def residue_ring_def)
+ apply auto
+ apply (rule the_equality)
+ apply auto
+ apply (subst mod_add_right_eq [symmetric])
+ apply auto
+ apply (subst mod_add_left_eq [symmetric])
+ apply auto
+ apply (subgoal_tac "y mod m = - x mod m")
+ apply simp
+ apply (subst zmod_eq_dvd_iff)
+ apply auto
+done
+
+lemma finite [iff]: "finite(carrier R)"
+ by (subst res_carrier_eq, auto)
+
+lemma finite_Units [iff]: "finite(Units R)"
+ by (subst res_units_eq, auto)
+
+(* The function a -> a mod m maps the integers to the
+ residue classes. The following lemmas show that this mapping
+ respects addition and multiplication on the integers. *)
+
+lemma mod_in_carrier [iff]: "a mod m : carrier R"
+ apply (unfold res_carrier_eq)
+ apply (insert m_gt_one, auto)
+done
+
+lemma add_cong: "(x mod m) \<oplus> (y mod m) = (x + y) mod m"
+ by (unfold R_def residue_ring_def, auto, arith)
+
+lemma mult_cong: "(x mod m) \<otimes> (y mod m) = (x * y) mod m"
+ apply (unfold R_def residue_ring_def, auto)
+ apply (subst zmod_zmult1_eq [symmetric])
+ apply (subst mult_commute)
+ apply (subst zmod_zmult1_eq [symmetric])
+ apply (subst mult_commute)
+ apply auto
+done
+
+lemma zero_cong: "\<zero> = 0"
+ apply (unfold R_def residue_ring_def, auto)
+done
+
+lemma one_cong: "\<one> = 1 mod m"
+ apply (insert m_gt_one)
+ apply (unfold R_def residue_ring_def, auto)
+done
+
+(* revise algebra library to use 1? *)
+lemma pow_cong: "(x mod m) (^) n = x^n mod m"
+ apply (insert m_gt_one)
+ apply (induct n)
+ apply (auto simp add: nat_pow_def one_cong One_nat_def)
+ apply (subst mult_commute)
+ apply (rule mult_cong)
+done
+
+lemma neg_cong: "\<ominus> (x mod m) = (- x) mod m"
+ apply (rule sym)
+ apply (rule sum_zero_eq_neg)
+ apply auto
+ apply (subst add_cong)
+ apply (subst zero_cong)
+ apply auto
+done
+
+lemma (in residues) prod_cong:
+ "finite A \<Longrightarrow> (\<Otimes> i:A. (f i) mod m) = (PROD i:A. f i) mod m"
+ apply (induct set: finite)
+ apply (auto simp: one_cong mult_cong)
+done
+
+lemma (in residues) sum_cong:
+ "finite A \<Longrightarrow> (\<Oplus> i:A. (f i) mod m) = (SUM i: A. f i) mod m"
+ apply (induct set: finite)
+ apply (auto simp: zero_cong add_cong)
+done
+
+lemma mod_in_res_units [simp]: "1 < m \<Longrightarrow> coprime a m \<Longrightarrow>
+ a mod m : Units R"
+ apply (subst res_units_eq, auto)
+ apply (insert pos_mod_sign [of m a])
+ apply (subgoal_tac "a mod m ~= 0")
+ apply arith
+ apply auto
+ apply (subst (asm) gcd_red_int)
+ apply (subst gcd_commute_int, assumption)
+done
+
+lemma res_eq_to_cong: "((a mod m) = (b mod m)) = [a = b] (mod (m::int))"
+ unfolding cong_int_def by auto
+
+(* Simplifying with these will translate a ring equation in R to a
+ congruence. *)
+
+lemmas res_to_cong_simps = add_cong mult_cong pow_cong one_cong
+ prod_cong sum_cong neg_cong res_eq_to_cong
+
+(* Other useful facts about the residue ring *)
+
+lemma one_eq_neg_one: "\<one> = \<ominus> \<one> \<Longrightarrow> m = 2"
+ apply (simp add: res_one_eq res_neg_eq)
+ apply (insert m_gt_one)
+ apply (subgoal_tac "~(m > 2)")
+ apply arith
+ apply (rule notI)
+ apply (subgoal_tac "-1 mod m = m - 1")
+ apply force
+ apply (subst mod_add_self2 [symmetric])
+ apply (subst mod_pos_pos_trivial)
+ apply auto
+done
+
+end
+
+
+(* prime residues *)
+
+locale residues_prime =
+ fixes p :: int and R (structure)
+ assumes p_prime [intro]: "prime p"
+ defines "R == residue_ring p"
+
+sublocale residues_prime < residues p
+ apply (unfold R_def residues_def)
+ using p_prime apply auto
+done
+
+context residues_prime begin
+
+lemma is_field: "field R"
+ apply (rule cring.field_intro2)
+ apply (rule cring)
+ apply (auto simp add: res_carrier_eq res_one_eq res_zero_eq
+ res_units_eq)
+ apply (rule classical)
+ apply (erule notE)
+ apply (subst gcd_commute_int)
+ apply (rule prime_imp_coprime_int)
+ apply (rule p_prime)
+ apply (rule notI)
+ apply (frule zdvd_imp_le)
+ apply auto
+done
+
+lemma res_prime_units_eq: "Units R = {1..p - 1}"
+ apply (subst res_units_eq)
+ apply auto
+ apply (subst gcd_commute_int)
+ apply (rule prime_imp_coprime_int)
+ apply (rule p_prime)
+ apply (rule zdvd_not_zless)
+ apply auto
+done
+
+end
+
+sublocale residues_prime < field
+ by (rule is_field)
+
+
+(*
+ Test cases: Euler's theorem and Wilson's theorem.
+*)
+
+
+subsection{* Euler's theorem *}
+
+(* the definition of the phi function *)
+
+constdefs
+ phi :: "int => nat"
+ "phi m == card({ x. 0 < x & x < m & gcd x m = 1})"
+
+lemma phi_zero [simp]: "phi 0 = 0"
+ apply (subst phi_def)
+(* Auto hangs here. Once again, where is the simplification rule
+ 1 == Suc 0 coming from? *)
+ apply (auto simp add: card_eq_0_iff)
+(* Add card_eq_0_iff as a simp rule? delete card_empty_imp? *)
+done
+
+lemma phi_one [simp]: "phi 1 = 0"
+ apply (auto simp add: phi_def card_eq_0_iff)
+done
+
+lemma (in residues) phi_eq: "phi m = card(Units R)"
+ by (simp add: phi_def res_units_eq)
+
+lemma (in residues) euler_theorem1:
+ assumes a: "gcd a m = 1"
+ shows "[a^phi m = 1] (mod m)"
+proof -
+ from a m_gt_one have [simp]: "a mod m : Units R"
+ by (intro mod_in_res_units)
+ from phi_eq have "(a mod m) (^) (phi m) = (a mod m) (^) (card (Units R))"
+ by simp
+ also have "\<dots> = \<one>"
+ by (intro units_power_order_eq_one, auto)
+ finally show ?thesis
+ by (simp add: res_to_cong_simps)
+qed
+
+(* In fact, there is a two line proof!
+
+lemma (in residues) euler_theorem1:
+ assumes a: "gcd a m = 1"
+ shows "[a^phi m = 1] (mod m)"
+proof -
+ have "(a mod m) (^) (phi m) = \<one>"
+ by (simp add: phi_eq units_power_order_eq_one a m_gt_one)
+ thus ?thesis
+ by (simp add: res_to_cong_simps)
+qed
+
+*)
+
+(* outside the locale, we can relax the restriction m > 1 *)
+
+lemma euler_theorem:
+ assumes "m >= 0" and "gcd a m = 1"
+ shows "[a^phi m = 1] (mod m)"
+proof (cases)
+ assume "m = 0 | m = 1"
+ thus ?thesis by auto
+next
+ assume "~(m = 0 | m = 1)"
+ with prems show ?thesis
+ by (intro residues.euler_theorem1, unfold residues_def, auto)
+qed
+
+lemma (in residues_prime) phi_prime: "phi p = (nat p - 1)"
+ apply (subst phi_eq)
+ apply (subst res_prime_units_eq)
+ apply auto
+done
+
+lemma phi_prime: "prime p \<Longrightarrow> phi p = (nat p - 1)"
+ apply (rule residues_prime.phi_prime)
+ apply (erule residues_prime.intro)
+done
+
+lemma fermat_theorem:
+ assumes "prime p" and "~ (p dvd a)"
+ shows "[a^(nat p - 1) = 1] (mod p)"
+proof -
+ from prems have "[a^phi p = 1] (mod p)"
+ apply (intro euler_theorem)
+ (* auto should get this next part. matching across
+ substitutions is needed. *)
+ apply (frule prime_gt_1_int, arith)
+ apply (subst gcd_commute_int, erule prime_imp_coprime_int, assumption)
+ done
+ also have "phi p = nat p - 1"
+ by (rule phi_prime, rule prems)
+ finally show ?thesis .
+qed
+
+
+subsection {* Wilson's theorem *}
+
+lemma (in field) inv_pair_lemma: "x : Units R \<Longrightarrow> y : Units R \<Longrightarrow>
+ {x, inv x} ~= {y, inv y} \<Longrightarrow> {x, inv x} Int {y, inv y} = {}"
+ apply auto
+ apply (erule notE)
+ apply (erule inv_eq_imp_eq)
+ apply auto
+ apply (erule notE)
+ apply (erule inv_eq_imp_eq)
+ apply auto
+done
+
+lemma (in residues_prime) wilson_theorem1:
+ assumes a: "p > 2"
+ shows "[fact (p - 1) = - 1] (mod p)"
+proof -
+ let ?InversePairs = "{ {x, inv x} | x. x : Units R - {\<one>, \<ominus> \<one>}}"
+ have UR: "Units R = {\<one>, \<ominus> \<one>} Un (Union ?InversePairs)"
+ by auto
+ have "(\<Otimes>i: Units R. i) =
+ (\<Otimes>i: {\<one>, \<ominus> \<one>}. i) \<otimes> (\<Otimes>i: Union ?InversePairs. i)"
+ apply (subst UR)
+ apply (subst finprod_Un_disjoint)
+ apply (auto intro:funcsetI)
+ apply (drule sym, subst (asm) inv_eq_one_eq)
+ apply auto
+ apply (drule sym, subst (asm) inv_eq_neg_one_eq)
+ apply auto
+ done
+ also have "(\<Otimes>i: {\<one>, \<ominus> \<one>}. i) = \<ominus> \<one>"
+ apply (subst finprod_insert)
+ apply auto
+ apply (frule one_eq_neg_one)
+ apply (insert a, force)
+ done
+ also have "(\<Otimes>i:(Union ?InversePairs). i) =
+ (\<Otimes> A: ?InversePairs. (\<Otimes> y:A. y))"
+ apply (subst finprod_Union_disjoint)
+ apply force
+ apply force
+ apply clarify
+ apply (rule inv_pair_lemma)
+ apply auto
+ done
+ also have "\<dots> = \<one>"
+ apply (rule finprod_one)
+ apply auto
+ apply (subst finprod_insert)
+ apply auto
+ apply (frule inv_eq_self)
+ apply (auto)
+ done
+ finally have "(\<Otimes>i: Units R. i) = \<ominus> \<one>"
+ by simp
+ also have "(\<Otimes>i: Units R. i) = (\<Otimes>i: Units R. i mod p)"
+ apply (rule finprod_cong')
+ apply (auto)
+ apply (subst (asm) res_prime_units_eq)
+ apply auto
+ done
+ also have "\<dots> = (PROD i: Units R. i) mod p"
+ apply (rule prod_cong)
+ apply auto
+ done
+ also have "\<dots> = fact (p - 1) mod p"
+ apply (subst fact_altdef_int)
+ apply (insert prems, force)
+ apply (subst res_prime_units_eq, rule refl)
+ done
+ finally have "fact (p - 1) mod p = \<ominus> \<one>".
+ thus ?thesis
+ by (simp add: res_to_cong_simps)
+qed
+
+lemma wilson_theorem: "prime (p::int) \<Longrightarrow> [fact (p - 1) = - 1] (mod p)"
+ apply (frule prime_gt_1_int)
+ apply (case_tac "p = 2")
+ apply (subst fact_altdef_int, simp)
+ apply (subst cong_int_def)
+ apply simp
+ apply (rule residues_prime.wilson_theorem1)
+ apply (rule residues_prime.intro)
+ apply auto
+done
+
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/UniqueFactorization.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,967 @@
+(* Title: UniqueFactorization.thy
+ ID:
+ Author: Jeremy Avigad
+
+
+ Unique factorization for the natural numbers and the integers.
+
+ Note: there were previous Isabelle formalizations of unique
+ factorization due to Thomas Marthedal Rasmussen, and, building on
+ that, by Jeremy Avigad and David Gray.
+*)
+
+header {* UniqueFactorization *}
+
+theory UniqueFactorization
+imports Cong Multiset
+begin
+
+(* inherited from Multiset *)
+declare One_nat_def [simp del]
+
+(* As a simp or intro rule,
+
+ prime p \<Longrightarrow> p > 0
+
+ wreaks havoc here. When the premise includes ALL x :# M. prime x, it
+ leads to the backchaining
+
+ x > 0
+ prime x
+ x :# M which is, unfortunately,
+ count M x > 0
+*)
+
+
+(* useful facts *)
+
+lemma setsum_Un2: "finite (A Un B) \<Longrightarrow>
+ setsum f (A Un B) = setsum f (A - B) + setsum f (B - A) +
+ setsum f (A Int B)"
+ apply (subgoal_tac "A Un B = (A - B) Un (B - A) Un (A Int B)")
+ apply (erule ssubst)
+ apply (subst setsum_Un_disjoint)
+ apply auto
+ apply (subst setsum_Un_disjoint)
+ apply auto
+done
+
+lemma setprod_Un2: "finite (A Un B) \<Longrightarrow>
+ setprod f (A Un B) = setprod f (A - B) * setprod f (B - A) *
+ setprod f (A Int B)"
+ apply (subgoal_tac "A Un B = (A - B) Un (B - A) Un (A Int B)")
+ apply (erule ssubst)
+ apply (subst setprod_Un_disjoint)
+ apply auto
+ apply (subst setprod_Un_disjoint)
+ apply auto
+done
+
+(* Should this go in Multiset.thy? *)
+(* TN: No longer an intro-rule; needed only once and might get in the way *)
+lemma multiset_eqI: "[| !!x. count M x = count N x |] ==> M = N"
+ by (subst multiset_eq_conv_count_eq, blast)
+
+(* Here is a version of set product for multisets. Is it worth moving
+ to multiset.thy? If so, one should similarly define msetsum for abelian
+ semirings, using of_nat. Also, is it worth developing bounded quantifiers
+ "ALL i :# M. P i"?
+*)
+
+constdefs
+ msetprod :: "('a => ('b::{power,comm_monoid_mult})) => 'a multiset => 'b"
+ "msetprod f M == setprod (%x. (f x)^(count M x)) (set_of M)"
+
+syntax
+ "_msetprod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"
+ ("(3PROD _:#_. _)" [0, 51, 10] 10)
+
+translations
+ "PROD i :# A. b" == "msetprod (%i. b) A"
+
+lemma msetprod_Un: "msetprod f (A+B) = msetprod f A * msetprod f B"
+ apply (simp add: msetprod_def power_add)
+ apply (subst setprod_Un2)
+ apply auto
+ apply (subgoal_tac
+ "(PROD x:set_of A - set_of B. f x ^ count A x * f x ^ count B x) =
+ (PROD x:set_of A - set_of B. f x ^ count A x)")
+ apply (erule ssubst)
+ apply (subgoal_tac
+ "(PROD x:set_of B - set_of A. f x ^ count A x * f x ^ count B x) =
+ (PROD x:set_of B - set_of A. f x ^ count B x)")
+ apply (erule ssubst)
+ apply (subgoal_tac "(PROD x:set_of A. f x ^ count A x) =
+ (PROD x:set_of A - set_of B. f x ^ count A x) *
+ (PROD x:set_of A Int set_of B. f x ^ count A x)")
+ apply (erule ssubst)
+ apply (subgoal_tac "(PROD x:set_of B. f x ^ count B x) =
+ (PROD x:set_of B - set_of A. f x ^ count B x) *
+ (PROD x:set_of A Int set_of B. f x ^ count B x)")
+ apply (erule ssubst)
+ apply (subst setprod_timesf)
+ apply (force simp add: mult_ac)
+ apply (subst setprod_Un_disjoint [symmetric])
+ apply (auto intro: setprod_cong)
+ apply (subst setprod_Un_disjoint [symmetric])
+ apply (auto intro: setprod_cong)
+done
+
+
+subsection {* unique factorization: multiset version *}
+
+lemma multiset_prime_factorization_exists [rule_format]: "n > 0 -->
+ (EX M. (ALL (p::nat) : set_of M. prime p) & n = (PROD i :# M. i))"
+proof (rule nat_less_induct, clarify)
+ fix n :: nat
+ assume ih: "ALL m < n. 0 < m --> (EX M. (ALL p : set_of M. prime p) & m =
+ (PROD i :# M. i))"
+ assume "(n::nat) > 0"
+ then have "n = 1 | (n > 1 & prime n) | (n > 1 & ~ prime n)"
+ by arith
+ moreover
+ {
+ assume "n = 1"
+ then have "(ALL p : set_of {#}. prime p) & n = (PROD i :# {#}. i)"
+ by (auto simp add: msetprod_def)
+ }
+ moreover
+ {
+ assume "n > 1" and "prime n"
+ then have "(ALL p : set_of {# n #}. prime p) & n = (PROD i :# {# n #}. i)"
+ by (auto simp add: msetprod_def)
+ }
+ moreover
+ {
+ assume "n > 1" and "~ prime n"
+ from prems not_prime_eq_prod_nat
+ obtain m k where "n = m * k & 1 < m & m < n & 1 < k & k < n"
+ by blast
+ with ih obtain Q R where "(ALL p : set_of Q. prime p) & m = (PROD i:#Q. i)"
+ and "(ALL p: set_of R. prime p) & k = (PROD i:#R. i)"
+ by blast
+ hence "(ALL p: set_of (Q + R). prime p) & n = (PROD i :# Q + R. i)"
+ by (auto simp add: prems msetprod_Un set_of_union)
+ then have "EX M. (ALL p : set_of M. prime p) & n = (PROD i :# M. i)"..
+ }
+ ultimately show "EX M. (ALL p : set_of M. prime p) & n = (PROD i::nat:#M. i)"
+ by blast
+qed
+
+lemma multiset_prime_factorization_unique_aux:
+ fixes a :: nat
+ assumes "(ALL p : set_of M. prime p)" and
+ "(ALL p : set_of N. prime p)" and
+ "(PROD i :# M. i) dvd (PROD i:# N. i)"
+ shows
+ "count M a <= count N a"
+proof cases
+ assume "a : set_of M"
+ with prems have a: "prime a"
+ by auto
+ with prems have "a ^ count M a dvd (PROD i :# M. i)"
+ by (auto intro: dvd_setprod simp add: msetprod_def)
+ also have "... dvd (PROD i :# N. i)"
+ by (rule prems)
+ also have "... = (PROD i : (set_of N). i ^ (count N i))"
+ by (simp add: msetprod_def)
+ also have "... =
+ a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))"
+ proof (cases)
+ assume "a : set_of N"
+ hence b: "set_of N = {a} Un (set_of N - {a})"
+ by auto
+ thus ?thesis
+ by (subst (1) b, subst setprod_Un_disjoint, auto)
+ next
+ assume "a ~: set_of N"
+ thus ?thesis
+ by auto
+ qed
+ finally have "a ^ count M a dvd
+ a^(count N a) * (PROD i : (set_of N - {a}). i ^ (count N i))".
+ moreover have "coprime (a ^ count M a)
+ (PROD i : (set_of N - {a}). i ^ (count N i))"
+ apply (subst gcd_commute_nat)
+ apply (rule setprod_coprime_nat)
+ apply (rule primes_imp_powers_coprime_nat)
+ apply (insert prems, auto)
+ done
+ ultimately have "a ^ count M a dvd a^(count N a)"
+ by (elim coprime_dvd_mult_nat)
+ with a show ?thesis
+ by (intro power_dvd_imp_le, auto)
+next
+ assume "a ~: set_of M"
+ thus ?thesis by auto
+qed
+
+lemma multiset_prime_factorization_unique:
+ assumes "(ALL (p::nat) : set_of M. prime p)" and
+ "(ALL p : set_of N. prime p)" and
+ "(PROD i :# M. i) = (PROD i:# N. i)"
+ shows
+ "M = N"
+proof -
+ {
+ fix a
+ from prems have "count M a <= count N a"
+ by (intro multiset_prime_factorization_unique_aux, auto)
+ moreover from prems have "count N a <= count M a"
+ by (intro multiset_prime_factorization_unique_aux, auto)
+ ultimately have "count M a = count N a"
+ by auto
+ }
+ thus ?thesis by (simp add:multiset_eq_conv_count_eq)
+qed
+
+constdefs
+ multiset_prime_factorization :: "nat => nat multiset"
+ "multiset_prime_factorization n ==
+ if n > 0 then (THE M. ((ALL p : set_of M. prime p) &
+ n = (PROD i :# M. i)))
+ else {#}"
+
+lemma multiset_prime_factorization: "n > 0 ==>
+ (ALL p : set_of (multiset_prime_factorization n). prime p) &
+ n = (PROD i :# (multiset_prime_factorization n). i)"
+ apply (unfold multiset_prime_factorization_def)
+ apply clarsimp
+ apply (frule multiset_prime_factorization_exists)
+ apply clarify
+ apply (rule theI)
+ apply (insert multiset_prime_factorization_unique, blast)+
+done
+
+
+subsection {* Prime factors and multiplicity for nats and ints *}
+
+class unique_factorization =
+
+fixes
+ multiplicity :: "'a \<Rightarrow> 'a \<Rightarrow> nat" and
+ prime_factors :: "'a \<Rightarrow> 'a set"
+
+(* definitions for the natural numbers *)
+
+instantiation nat :: unique_factorization
+
+begin
+
+definition
+ multiplicity_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+where
+ "multiplicity_nat p n = count (multiset_prime_factorization n) p"
+
+definition
+ prime_factors_nat :: "nat \<Rightarrow> nat set"
+where
+ "prime_factors_nat n = set_of (multiset_prime_factorization n)"
+
+instance proof qed
+
+end
+
+(* definitions for the integers *)
+
+instantiation int :: unique_factorization
+
+begin
+
+definition
+ multiplicity_int :: "int \<Rightarrow> int \<Rightarrow> nat"
+where
+ "multiplicity_int p n = multiplicity (nat p) (nat n)"
+
+definition
+ prime_factors_int :: "int \<Rightarrow> int set"
+where
+ "prime_factors_int n = int ` (prime_factors (nat n))"
+
+instance proof qed
+
+end
+
+
+subsection {* Set up transfer *}
+
+lemma transfer_nat_int_prime_factors:
+ "prime_factors (nat n) = nat ` prime_factors n"
+ unfolding prime_factors_int_def apply auto
+ by (subst transfer_int_nat_set_return_embed, assumption)
+
+lemma transfer_nat_int_prime_factors_closure: "n >= 0 \<Longrightarrow>
+ nat_set (prime_factors n)"
+ by (auto simp add: nat_set_def prime_factors_int_def)
+
+lemma transfer_nat_int_multiplicity: "p >= 0 \<Longrightarrow> n >= 0 \<Longrightarrow>
+ multiplicity (nat p) (nat n) = multiplicity p n"
+ by (auto simp add: multiplicity_int_def)
+
+declare TransferMorphism_nat_int[transfer add return:
+ transfer_nat_int_prime_factors transfer_nat_int_prime_factors_closure
+ transfer_nat_int_multiplicity]
+
+
+lemma transfer_int_nat_prime_factors:
+ "prime_factors (int n) = int ` prime_factors n"
+ unfolding prime_factors_int_def by auto
+
+lemma transfer_int_nat_prime_factors_closure: "is_nat n \<Longrightarrow>
+ nat_set (prime_factors n)"
+ by (simp only: transfer_nat_int_prime_factors_closure is_nat_def)
+
+lemma transfer_int_nat_multiplicity:
+ "multiplicity (int p) (int n) = multiplicity p n"
+ by (auto simp add: multiplicity_int_def)
+
+declare TransferMorphism_int_nat[transfer add return:
+ transfer_int_nat_prime_factors transfer_int_nat_prime_factors_closure
+ transfer_int_nat_multiplicity]
+
+
+subsection {* Properties of prime factors and multiplicity for nats and ints *}
+
+lemma prime_factors_ge_0_int [elim]: "p : prime_factors (n::int) \<Longrightarrow> p >= 0"
+ by (unfold prime_factors_int_def, auto)
+
+lemma prime_factors_prime_nat [intro]: "p : prime_factors (n::nat) \<Longrightarrow> prime p"
+ apply (case_tac "n = 0")
+ apply (simp add: prime_factors_nat_def multiset_prime_factorization_def)
+ apply (auto simp add: prime_factors_nat_def multiset_prime_factorization)
+done
+
+lemma prime_factors_prime_int [intro]:
+ assumes "n >= 0" and "p : prime_factors (n::int)"
+ shows "prime p"
+
+ apply (rule prime_factors_prime_nat [transferred, of n p])
+ using prems apply auto
+done
+
+lemma prime_factors_gt_0_nat [elim]: "p : prime_factors x \<Longrightarrow> p > (0::nat)"
+ by (frule prime_factors_prime_nat, auto)
+
+lemma prime_factors_gt_0_int [elim]: "x >= 0 \<Longrightarrow> p : prime_factors x \<Longrightarrow>
+ p > (0::int)"
+ by (frule (1) prime_factors_prime_int, auto)
+
+lemma prime_factors_finite_nat [iff]: "finite (prime_factors (n::nat))"
+ by (unfold prime_factors_nat_def, auto)
+
+lemma prime_factors_finite_int [iff]: "finite (prime_factors (n::int))"
+ by (unfold prime_factors_int_def, auto)
+
+lemma prime_factors_altdef_nat: "prime_factors (n::nat) =
+ {p. multiplicity p n > 0}"
+ by (force simp add: prime_factors_nat_def multiplicity_nat_def)
+
+lemma prime_factors_altdef_int: "prime_factors (n::int) =
+ {p. p >= 0 & multiplicity p n > 0}"
+ apply (unfold prime_factors_int_def multiplicity_int_def)
+ apply (subst prime_factors_altdef_nat)
+ apply (auto simp add: image_def)
+done
+
+lemma prime_factorization_nat: "(n::nat) > 0 \<Longrightarrow>
+ n = (PROD p : prime_factors n. p^(multiplicity p n))"
+ by (frule multiset_prime_factorization,
+ simp add: prime_factors_nat_def multiplicity_nat_def msetprod_def)
+
+thm prime_factorization_nat [transferred]
+
+lemma prime_factorization_int:
+ assumes "(n::int) > 0"
+ shows "n = (PROD p : prime_factors n. p^(multiplicity p n))"
+
+ apply (rule prime_factorization_nat [transferred, of n])
+ using prems apply auto
+done
+
+lemma neq_zero_eq_gt_zero_nat: "((x::nat) ~= 0) = (x > 0)"
+ by auto
+
+lemma prime_factorization_unique_nat:
+ "S = { (p::nat) . f p > 0} \<Longrightarrow> finite S \<Longrightarrow> (ALL p : S. prime p) \<Longrightarrow>
+ n = (PROD p : S. p^(f p)) \<Longrightarrow>
+ S = prime_factors n & (ALL p. f p = multiplicity p n)"
+ apply (subgoal_tac "multiset_prime_factorization n = Abs_multiset
+ f")
+ apply (unfold prime_factors_nat_def multiplicity_nat_def)
+ apply (simp add: set_of_def count_def Abs_multiset_inverse multiset_def)
+ apply (unfold multiset_prime_factorization_def)
+ apply (subgoal_tac "n > 0")
+ prefer 2
+ apply force
+ apply (subst if_P, assumption)
+ apply (rule the1_equality)
+ apply (rule ex_ex1I)
+ apply (rule multiset_prime_factorization_exists, assumption)
+ apply (rule multiset_prime_factorization_unique)
+ apply force
+ apply force
+ apply force
+ unfolding set_of_def count_def msetprod_def
+ apply (subgoal_tac "f : multiset")
+ apply (auto simp only: Abs_multiset_inverse)
+ unfolding multiset_def apply force
+done
+
+lemma prime_factors_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
+ finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
+ prime_factors n = S"
+ by (rule prime_factorization_unique_nat [THEN conjunct1, symmetric],
+ assumption+)
+
+lemma prime_factors_characterization'_nat:
+ "finite {p. 0 < f (p::nat)} \<Longrightarrow>
+ (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
+ prime_factors (PROD p | 0 < f p . p ^ f p) = {p. 0 < f p}"
+ apply (rule prime_factors_characterization_nat)
+ apply auto
+done
+
+(* A minor glitch:*)
+
+thm prime_factors_characterization'_nat
+ [where f = "%x. f (int (x::nat))",
+ transferred direction: nat "op <= (0::int)", rule_format]
+
+(*
+ Transfer isn't smart enough to know that the "0 < f p" should
+ remain a comparison between nats. But the transfer still works.
+*)
+
+lemma primes_characterization'_int [rule_format]:
+ "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
+ (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
+ prime_factors (PROD p | p >=0 & 0 < f p . p ^ f p) =
+ {p. p >= 0 & 0 < f p}"
+
+ apply (insert prime_factors_characterization'_nat
+ [where f = "%x. f (int (x::nat))",
+ transferred direction: nat "op <= (0::int)"])
+ apply auto
+done
+
+lemma prime_factors_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
+ finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
+ prime_factors n = S"
+ apply simp
+ apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
+ apply (simp only:)
+ apply (subst primes_characterization'_int)
+ apply auto
+ apply (auto simp add: prime_ge_0_int)
+done
+
+lemma multiplicity_characterization_nat: "S = {p. 0 < f (p::nat)} \<Longrightarrow>
+ finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
+ multiplicity p n = f p"
+ by (frule prime_factorization_unique_nat [THEN conjunct2, rule_format,
+ symmetric], auto)
+
+lemma multiplicity_characterization'_nat: "finite {p. 0 < f (p::nat)} \<longrightarrow>
+ (ALL p. 0 < f p \<longrightarrow> prime p) \<longrightarrow>
+ multiplicity p (PROD p | 0 < f p . p ^ f p) = f p"
+ apply (rule impI)+
+ apply (rule multiplicity_characterization_nat)
+ apply auto
+done
+
+lemma multiplicity_characterization'_int [rule_format]:
+ "finite {p. p >= 0 & 0 < f (p::int)} \<Longrightarrow>
+ (ALL p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow> p >= 0 \<Longrightarrow>
+ multiplicity p (PROD p | p >= 0 & 0 < f p . p ^ f p) = f p"
+
+ apply (insert multiplicity_characterization'_nat
+ [where f = "%x. f (int (x::nat))",
+ transferred direction: nat "op <= (0::int)", rule_format])
+ apply auto
+done
+
+lemma multiplicity_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
+ finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
+ p >= 0 \<Longrightarrow> multiplicity p n = f p"
+ apply simp
+ apply (subgoal_tac "{p. 0 < f p} = {p. 0 <= p & 0 < f p}")
+ apply (simp only:)
+ apply (subst multiplicity_characterization'_int)
+ apply auto
+ apply (auto simp add: prime_ge_0_int)
+done
+
+lemma multiplicity_zero_nat [simp]: "multiplicity (p::nat) 0 = 0"
+ by (simp add: multiplicity_nat_def multiset_prime_factorization_def)
+
+lemma multiplicity_zero_int [simp]: "multiplicity (p::int) 0 = 0"
+ by (simp add: multiplicity_int_def)
+
+lemma multiplicity_one_nat [simp]: "multiplicity p (1::nat) = 0"
+ by (subst multiplicity_characterization_nat [where f = "%x. 0"], auto)
+
+lemma multiplicity_one_int [simp]: "multiplicity p (1::int) = 0"
+ by (simp add: multiplicity_int_def)
+
+lemma multiplicity_prime_nat [simp]: "prime (p::nat) \<Longrightarrow> multiplicity p p = 1"
+ apply (subst multiplicity_characterization_nat
+ [where f = "(%q. if q = p then 1 else 0)"])
+ apply auto
+ apply (case_tac "x = p")
+ apply auto
+done
+
+lemma multiplicity_prime_int [simp]: "prime (p::int) \<Longrightarrow> multiplicity p p = 1"
+ unfolding prime_int_def multiplicity_int_def by auto
+
+lemma multiplicity_prime_power_nat [simp]: "prime (p::nat) \<Longrightarrow>
+ multiplicity p (p^n) = n"
+ apply (case_tac "n = 0")
+ apply auto
+ apply (subst multiplicity_characterization_nat
+ [where f = "(%q. if q = p then n else 0)"])
+ apply auto
+ apply (case_tac "x = p")
+ apply auto
+done
+
+lemma multiplicity_prime_power_int [simp]: "prime (p::int) \<Longrightarrow>
+ multiplicity p (p^n) = n"
+ apply (frule prime_ge_0_int)
+ apply (auto simp add: prime_int_def multiplicity_int_def nat_power_eq)
+done
+
+lemma multiplicity_nonprime_nat [simp]: "~ prime (p::nat) \<Longrightarrow>
+ multiplicity p n = 0"
+ apply (case_tac "n = 0")
+ apply auto
+ apply (frule multiset_prime_factorization)
+ apply (auto simp add: set_of_def multiplicity_nat_def)
+done
+
+lemma multiplicity_nonprime_int [simp]: "~ prime (p::int) \<Longrightarrow> multiplicity p n = 0"
+ by (unfold multiplicity_int_def prime_int_def, auto)
+
+lemma multiplicity_not_factor_nat [simp]:
+ "p ~: prime_factors (n::nat) \<Longrightarrow> multiplicity p n = 0"
+ by (subst (asm) prime_factors_altdef_nat, auto)
+
+lemma multiplicity_not_factor_int [simp]:
+ "p >= 0 \<Longrightarrow> p ~: prime_factors (n::int) \<Longrightarrow> multiplicity p n = 0"
+ by (subst (asm) prime_factors_altdef_int, auto)
+
+lemma multiplicity_product_aux_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow>
+ (prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
+ (ALL p. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
+ apply (rule prime_factorization_unique_nat)
+ apply (simp only: prime_factors_altdef_nat)
+ apply auto
+ apply (subst power_add)
+ apply (subst setprod_timesf)
+ apply (rule arg_cong2)back back
+ apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors k Un
+ (prime_factors l - prime_factors k)")
+ apply (erule ssubst)
+ apply (subst setprod_Un_disjoint)
+ apply auto
+ apply (subgoal_tac "(\<Prod>p\<in>prime_factors l - prime_factors k. p ^ multiplicity p k) =
+ (\<Prod>p\<in>prime_factors l - prime_factors k. 1)")
+ apply (erule ssubst)
+ apply (simp add: setprod_1)
+ apply (erule prime_factorization_nat)
+ apply (rule setprod_cong, auto)
+ apply (subgoal_tac "prime_factors k Un prime_factors l = prime_factors l Un
+ (prime_factors k - prime_factors l)")
+ apply (erule ssubst)
+ apply (subst setprod_Un_disjoint)
+ apply auto
+ apply (subgoal_tac "(\<Prod>p\<in>prime_factors k - prime_factors l. p ^ multiplicity p l) =
+ (\<Prod>p\<in>prime_factors k - prime_factors l. 1)")
+ apply (erule ssubst)
+ apply (simp add: setprod_1)
+ apply (erule prime_factorization_nat)
+ apply (rule setprod_cong, auto)
+done
+
+(* transfer doesn't have the same problem here with the right
+ choice of rules. *)
+
+lemma multiplicity_product_aux_int:
+ assumes "(k::int) > 0" and "l > 0"
+ shows
+ "(prime_factors k) Un (prime_factors l) = prime_factors (k * l) &
+ (ALL p >= 0. multiplicity p k + multiplicity p l = multiplicity p (k * l))"
+
+ apply (rule multiplicity_product_aux_nat [transferred, of l k])
+ using prems apply auto
+done
+
+lemma prime_factors_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
+ prime_factors k Un prime_factors l"
+ by (rule multiplicity_product_aux_nat [THEN conjunct1, symmetric])
+
+lemma prime_factors_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> prime_factors (k * l) =
+ prime_factors k Un prime_factors l"
+ by (rule multiplicity_product_aux_int [THEN conjunct1, symmetric])
+
+lemma multiplicity_product_nat: "(k::nat) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> multiplicity p (k * l) =
+ multiplicity p k + multiplicity p l"
+ by (rule multiplicity_product_aux_nat [THEN conjunct2, rule_format,
+ symmetric])
+
+lemma multiplicity_product_int: "(k::int) > 0 \<Longrightarrow> l > 0 \<Longrightarrow> p >= 0 \<Longrightarrow>
+ multiplicity p (k * l) = multiplicity p k + multiplicity p l"
+ by (rule multiplicity_product_aux_int [THEN conjunct2, rule_format,
+ symmetric])
+
+lemma multiplicity_setprod_nat: "finite S \<Longrightarrow> (ALL x : S. f x > 0) \<Longrightarrow>
+ multiplicity (p::nat) (PROD x : S. f x) =
+ (SUM x : S. multiplicity p (f x))"
+ apply (induct set: finite)
+ apply auto
+ apply (subst multiplicity_product_nat)
+ apply auto
+done
+
+(* Transfer is delicate here for two reasons: first, because there is
+ an implicit quantifier over functions (f), and, second, because the
+ product over the multiplicity should not be translated to an integer
+ product.
+
+ The way to handle the first is to use quantifier rules for functions.
+ The way to handle the second is to turn off the offending rule.
+*)
+
+lemma transfer_nat_int_sum_prod_closure3:
+ "(SUM x : A. int (f x)) >= 0"
+ "(PROD x : A. int (f x)) >= 0"
+ apply (rule setsum_nonneg, auto)
+ apply (rule setprod_nonneg, auto)
+done
+
+declare TransferMorphism_nat_int[transfer
+ add return: transfer_nat_int_sum_prod_closure3
+ del: transfer_nat_int_sum_prod2 (1)]
+
+lemma multiplicity_setprod_int: "p >= 0 \<Longrightarrow> finite S \<Longrightarrow>
+ (ALL x : S. f x > 0) \<Longrightarrow>
+ multiplicity (p::int) (PROD x : S. f x) =
+ (SUM x : S. multiplicity p (f x))"
+
+ apply (frule multiplicity_setprod_nat
+ [where f = "%x. nat(int(nat(f x)))",
+ transferred direction: nat "op <= (0::int)"])
+ apply auto
+ apply (subst (asm) setprod_cong)
+ apply (rule refl)
+ apply (rule if_P)
+ apply auto
+ apply (rule setsum_cong)
+ apply auto
+done
+
+declare TransferMorphism_nat_int[transfer
+ add return: transfer_nat_int_sum_prod2 (1)]
+
+lemma multiplicity_prod_prime_powers_nat:
+ "finite S \<Longrightarrow> (ALL p : S. prime (p::nat)) \<Longrightarrow>
+ multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
+ apply (subgoal_tac "(PROD p : S. p ^ f p) =
+ (PROD p : S. p ^ (%x. if x : S then f x else 0) p)")
+ apply (erule ssubst)
+ apply (subst multiplicity_characterization_nat)
+ prefer 5 apply (rule refl)
+ apply (rule refl)
+ apply auto
+ apply (subst setprod_mono_one_right)
+ apply assumption
+ prefer 3
+ apply (rule setprod_cong)
+ apply (rule refl)
+ apply auto
+done
+
+(* Here the issue with transfer is the implicit quantifier over S *)
+
+lemma multiplicity_prod_prime_powers_int:
+ "(p::int) >= 0 \<Longrightarrow> finite S \<Longrightarrow> (ALL p : S. prime p) \<Longrightarrow>
+ multiplicity p (PROD p : S. p ^ f p) = (if p : S then f p else 0)"
+
+ apply (subgoal_tac "int ` nat ` S = S")
+ apply (frule multiplicity_prod_prime_powers_nat [where f = "%x. f(int x)"
+ and S = "nat ` S", transferred])
+ apply auto
+ apply (subst prime_int_def [symmetric])
+ apply auto
+ apply (subgoal_tac "xb >= 0")
+ apply force
+ apply (rule prime_ge_0_int)
+ apply force
+ apply (subst transfer_nat_int_set_return_embed)
+ apply (unfold nat_set_def, auto)
+done
+
+lemma multiplicity_distinct_prime_power_nat: "prime (p::nat) \<Longrightarrow> prime q \<Longrightarrow>
+ p ~= q \<Longrightarrow> multiplicity p (q^n) = 0"
+ apply (subgoal_tac "q^n = setprod (%x. x^n) {q}")
+ apply (erule ssubst)
+ apply (subst multiplicity_prod_prime_powers_nat)
+ apply auto
+done
+
+lemma multiplicity_distinct_prime_power_int: "prime (p::int) \<Longrightarrow> prime q \<Longrightarrow>
+ p ~= q \<Longrightarrow> multiplicity p (q^n) = 0"
+ apply (frule prime_ge_0_int [of q])
+ apply (frule multiplicity_distinct_prime_power_nat [transferred leaving: n])
+ prefer 4
+ apply assumption
+ apply auto
+done
+
+lemma dvd_multiplicity_nat:
+ "(0::nat) < y \<Longrightarrow> x dvd y \<Longrightarrow> multiplicity p x <= multiplicity p y"
+ apply (case_tac "x = 0")
+ apply (auto simp add: dvd_def multiplicity_product_nat)
+done
+
+lemma dvd_multiplicity_int:
+ "(0::int) < y \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> p >= 0 \<Longrightarrow>
+ multiplicity p x <= multiplicity p y"
+ apply (case_tac "x = 0")
+ apply (auto simp add: dvd_def)
+ apply (subgoal_tac "0 < k")
+ apply (auto simp add: multiplicity_product_int)
+ apply (erule zero_less_mult_pos)
+ apply arith
+done
+
+lemma dvd_prime_factors_nat [intro]:
+ "0 < (y::nat) \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
+ apply (simp only: prime_factors_altdef_nat)
+ apply auto
+ apply (frule dvd_multiplicity_nat)
+ apply auto
+(* It is a shame that auto and arith don't get this. *)
+ apply (erule order_less_le_trans)back
+ apply assumption
+done
+
+lemma dvd_prime_factors_int [intro]:
+ "0 < (y::int) \<Longrightarrow> 0 <= x \<Longrightarrow> x dvd y \<Longrightarrow> prime_factors x <= prime_factors y"
+ apply (auto simp add: prime_factors_altdef_int)
+ apply (erule order_less_le_trans)
+ apply (rule dvd_multiplicity_int)
+ apply auto
+done
+
+lemma multiplicity_dvd_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
+ ALL p. multiplicity p x <= multiplicity p y \<Longrightarrow>
+ x dvd y"
+ apply (subst prime_factorization_nat [of x], assumption)
+ apply (subst prime_factorization_nat [of y], assumption)
+ apply (rule setprod_dvd_setprod_subset2)
+ apply force
+ apply (subst prime_factors_altdef_nat)+
+ apply auto
+(* Again, a shame that auto and arith don't get this. *)
+ apply (drule_tac x = xa in spec, auto)
+ apply (rule le_imp_power_dvd)
+ apply blast
+done
+
+lemma multiplicity_dvd_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
+ ALL p >= 0. multiplicity p x <= multiplicity p y \<Longrightarrow>
+ x dvd y"
+ apply (subst prime_factorization_int [of x], assumption)
+ apply (subst prime_factorization_int [of y], assumption)
+ apply (rule setprod_dvd_setprod_subset2)
+ apply force
+ apply (subst prime_factors_altdef_int)+
+ apply auto
+ apply (rule dvd_power_le)
+ apply auto
+ apply (drule_tac x = xa in spec)
+ apply (erule impE)
+ apply auto
+done
+
+lemma multiplicity_dvd'_nat: "(0::nat) < x \<Longrightarrow>
+ \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
+ apply (cases "y = 0")
+ apply auto
+ apply (rule multiplicity_dvd_nat, auto)
+ apply (case_tac "prime p")
+ apply auto
+done
+
+lemma multiplicity_dvd'_int: "(0::int) < x \<Longrightarrow> 0 <= y \<Longrightarrow>
+ \<forall>p. prime p \<longrightarrow> multiplicity p x \<le> multiplicity p y \<Longrightarrow> x dvd y"
+ apply (cases "y = 0")
+ apply auto
+ apply (rule multiplicity_dvd_int, auto)
+ apply (case_tac "prime p")
+ apply auto
+done
+
+lemma dvd_multiplicity_eq_nat: "0 < (x::nat) \<Longrightarrow> 0 < y \<Longrightarrow>
+ (x dvd y) = (ALL p. multiplicity p x <= multiplicity p y)"
+ by (auto intro: dvd_multiplicity_nat multiplicity_dvd_nat)
+
+lemma dvd_multiplicity_eq_int: "0 < (x::int) \<Longrightarrow> 0 < y \<Longrightarrow>
+ (x dvd y) = (ALL p >= 0. multiplicity p x <= multiplicity p y)"
+ by (auto intro: dvd_multiplicity_int multiplicity_dvd_int)
+
+lemma prime_factors_altdef2_nat: "(n::nat) > 0 \<Longrightarrow>
+ (p : prime_factors n) = (prime p & p dvd n)"
+ apply (case_tac "prime p")
+ apply auto
+ apply (subst prime_factorization_nat [where n = n], assumption)
+ apply (rule dvd_trans)
+ apply (rule dvd_power [where x = p and n = "multiplicity p n"])
+ apply (subst (asm) prime_factors_altdef_nat, force)
+ apply (rule dvd_setprod)
+ apply auto
+ apply (subst prime_factors_altdef_nat)
+ apply (subst (asm) dvd_multiplicity_eq_nat)
+ apply auto
+ apply (drule spec [where x = p])
+ apply auto
+done
+
+lemma prime_factors_altdef2_int:
+ assumes "(n::int) > 0"
+ shows "(p : prime_factors n) = (prime p & p dvd n)"
+
+ apply (case_tac "p >= 0")
+ apply (rule prime_factors_altdef2_nat [transferred])
+ using prems apply auto
+ apply (auto simp add: prime_ge_0_int prime_factors_ge_0_int)
+done
+
+lemma multiplicity_eq_nat:
+ fixes x and y::nat
+ assumes [arith]: "x > 0" "y > 0" and
+ mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
+ shows "x = y"
+
+ apply (rule dvd_anti_sym)
+ apply (auto intro: multiplicity_dvd'_nat)
+done
+
+lemma multiplicity_eq_int:
+ fixes x and y::int
+ assumes [arith]: "x > 0" "y > 0" and
+ mult_eq [simp]: "!!p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
+ shows "x = y"
+
+ apply (rule dvd_anti_sym [transferred])
+ apply (auto intro: multiplicity_dvd'_int)
+done
+
+
+subsection {* An application *}
+
+lemma gcd_eq_nat:
+ assumes pos [arith]: "x > 0" "y > 0"
+ shows "gcd (x::nat) y =
+ (PROD p: prime_factors x Un prime_factors y.
+ p ^ (min (multiplicity p x) (multiplicity p y)))"
+proof -
+ def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
+ p ^ (min (multiplicity p x) (multiplicity p y)))"
+ have [arith]: "z > 0"
+ unfolding z_def by (rule setprod_pos_nat, auto)
+ have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
+ min (multiplicity p x) (multiplicity p y)"
+ unfolding z_def
+ apply (subst multiplicity_prod_prime_powers_nat)
+ apply (auto simp add: multiplicity_not_factor_nat)
+ done
+ have "z dvd x"
+ by (intro multiplicity_dvd'_nat, auto simp add: aux)
+ moreover have "z dvd y"
+ by (intro multiplicity_dvd'_nat, auto simp add: aux)
+ moreover have "ALL w. w dvd x & w dvd y \<longrightarrow> w dvd z"
+ apply auto
+ apply (case_tac "w = 0", auto)
+ apply (erule multiplicity_dvd'_nat)
+ apply (auto intro: dvd_multiplicity_nat simp add: aux)
+ done
+ ultimately have "z = gcd x y"
+ by (subst gcd_unique_nat [symmetric], blast)
+ thus ?thesis
+ unfolding z_def by auto
+qed
+
+lemma lcm_eq_nat:
+ assumes pos [arith]: "x > 0" "y > 0"
+ shows "lcm (x::nat) y =
+ (PROD p: prime_factors x Un prime_factors y.
+ p ^ (max (multiplicity p x) (multiplicity p y)))"
+proof -
+ def z == "(PROD p: prime_factors (x::nat) Un prime_factors y.
+ p ^ (max (multiplicity p x) (multiplicity p y)))"
+ have [arith]: "z > 0"
+ unfolding z_def by (rule setprod_pos_nat, auto)
+ have aux: "!!p. prime p \<Longrightarrow> multiplicity p z =
+ max (multiplicity p x) (multiplicity p y)"
+ unfolding z_def
+ apply (subst multiplicity_prod_prime_powers_nat)
+ apply (auto simp add: multiplicity_not_factor_nat)
+ done
+ have "x dvd z"
+ by (intro multiplicity_dvd'_nat, auto simp add: aux)
+ moreover have "y dvd z"
+ by (intro multiplicity_dvd'_nat, auto simp add: aux)
+ moreover have "ALL w. x dvd w & y dvd w \<longrightarrow> z dvd w"
+ apply auto
+ apply (case_tac "w = 0", auto)
+ apply (rule multiplicity_dvd'_nat)
+ apply (auto intro: dvd_multiplicity_nat simp add: aux)
+ done
+ ultimately have "z = lcm x y"
+ by (subst lcm_unique_nat [symmetric], blast)
+ thus ?thesis
+ unfolding z_def by auto
+qed
+
+lemma multiplicity_gcd_nat:
+ assumes [arith]: "x > 0" "y > 0"
+ shows "multiplicity (p::nat) (gcd x y) =
+ min (multiplicity p x) (multiplicity p y)"
+
+ apply (subst gcd_eq_nat)
+ apply auto
+ apply (subst multiplicity_prod_prime_powers_nat)
+ apply auto
+done
+
+lemma multiplicity_lcm_nat:
+ assumes [arith]: "x > 0" "y > 0"
+ shows "multiplicity (p::nat) (lcm x y) =
+ max (multiplicity p x) (multiplicity p y)"
+
+ apply (subst lcm_eq_nat)
+ apply auto
+ apply (subst multiplicity_prod_prime_powers_nat)
+ apply auto
+done
+
+lemma gcd_lcm_distrib_nat: "gcd (x::nat) (lcm y z) = lcm (gcd x y) (gcd x z)"
+ apply (case_tac "x = 0 | y = 0 | z = 0")
+ apply auto
+ apply (rule multiplicity_eq_nat)
+ apply (auto simp add: multiplicity_gcd_nat multiplicity_lcm_nat
+ lcm_pos_nat)
+done
+
+lemma gcd_lcm_distrib_int: "gcd (x::int) (lcm y z) = lcm (gcd x y) (gcd x z)"
+ apply (subst (1 2 3) gcd_abs_int)
+ apply (subst lcm_abs_int)
+ apply (subst (2) abs_of_nonneg)
+ apply force
+ apply (rule gcd_lcm_distrib_nat [transferred])
+ apply auto
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/BijectionRel.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,229 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Bijections between sets *}
+
+theory BijectionRel imports Main begin
+
+text {*
+ Inductive definitions of bijections between two different sets and
+ between the same set. Theorem for relating the two definitions.
+
+ \bigskip
+*}
+
+inductive_set
+ bijR :: "('a => 'b => bool) => ('a set * 'b set) set"
+ for P :: "'a => 'b => bool"
+where
+ empty [simp]: "({}, {}) \<in> bijR P"
+| insert: "P a b ==> a \<notin> A ==> b \<notin> B ==> (A, B) \<in> bijR P
+ ==> (insert a A, insert b B) \<in> bijR P"
+
+text {*
+ Add extra condition to @{term insert}: @{term "\<forall>b \<in> B. \<not> P a b"}
+ (and similar for @{term A}).
+*}
+
+definition
+ bijP :: "('a => 'a => bool) => 'a set => bool" where
+ "bijP P F = (\<forall>a b. a \<in> F \<and> P a b --> b \<in> F)"
+
+definition
+ uniqP :: "('a => 'a => bool) => bool" where
+ "uniqP P = (\<forall>a b c d. P a b \<and> P c d --> (a = c) = (b = d))"
+
+definition
+ symP :: "('a => 'a => bool) => bool" where
+ "symP P = (\<forall>a b. P a b = P b a)"
+
+inductive_set
+ bijER :: "('a => 'a => bool) => 'a set set"
+ for P :: "'a => 'a => bool"
+where
+ empty [simp]: "{} \<in> bijER P"
+| insert1: "P a a ==> a \<notin> A ==> A \<in> bijER P ==> insert a A \<in> bijER P"
+| insert2: "P a b ==> a \<noteq> b ==> a \<notin> A ==> b \<notin> A ==> A \<in> bijER P
+ ==> insert a (insert b A) \<in> bijER P"
+
+
+text {* \medskip @{term bijR} *}
+
+lemma fin_bijRl: "(A, B) \<in> bijR P ==> finite A"
+ apply (erule bijR.induct)
+ apply auto
+ done
+
+lemma fin_bijRr: "(A, B) \<in> bijR P ==> finite B"
+ apply (erule bijR.induct)
+ apply auto
+ done
+
+lemma aux_induct:
+ assumes major: "finite F"
+ and subs: "F \<subseteq> A"
+ and cases: "P {}"
+ "!!F a. F \<subseteq> A ==> a \<in> A ==> a \<notin> F ==> P F ==> P (insert a F)"
+ shows "P F"
+ using major subs
+ apply (induct set: finite)
+ apply (blast intro: cases)+
+ done
+
+
+lemma inj_func_bijR_aux1:
+ "A \<subseteq> B ==> a \<notin> A ==> a \<in> B ==> inj_on f B ==> f a \<notin> f ` A"
+ apply (unfold inj_on_def)
+ apply auto
+ done
+
+lemma inj_func_bijR_aux2:
+ "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A ==> F <= A
+ ==> (F, f ` F) \<in> bijR P"
+ apply (rule_tac F = F and A = A in aux_induct)
+ apply (rule finite_subset)
+ apply auto
+ apply (rule bijR.insert)
+ apply (rule_tac [3] inj_func_bijR_aux1)
+ apply auto
+ done
+
+lemma inj_func_bijR:
+ "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A
+ ==> (A, f ` A) \<in> bijR P"
+ apply (rule inj_func_bijR_aux2)
+ apply auto
+ done
+
+
+text {* \medskip @{term bijER} *}
+
+lemma fin_bijER: "A \<in> bijER P ==> finite A"
+ apply (erule bijER.induct)
+ apply auto
+ done
+
+lemma aux1:
+ "a \<notin> A ==> a \<notin> B ==> F \<subseteq> insert a A ==> F \<subseteq> insert a B ==> a \<in> F
+ ==> \<exists>C. F = insert a C \<and> a \<notin> C \<and> C <= A \<and> C <= B"
+ apply (rule_tac x = "F - {a}" in exI)
+ apply auto
+ done
+
+lemma aux2: "a \<noteq> b ==> a \<notin> A ==> b \<notin> B ==> a \<in> F ==> b \<in> F
+ ==> F \<subseteq> insert a A ==> F \<subseteq> insert b B
+ ==> \<exists>C. F = insert a (insert b C) \<and> a \<notin> C \<and> b \<notin> C \<and> C \<subseteq> A \<and> C \<subseteq> B"
+ apply (rule_tac x = "F - {a, b}" in exI)
+ apply auto
+ done
+
+lemma aux_uniq: "uniqP P ==> P a b ==> P c d ==> (a = c) = (b = d)"
+ apply (unfold uniqP_def)
+ apply auto
+ done
+
+lemma aux_sym: "symP P ==> P a b = P b a"
+ apply (unfold symP_def)
+ apply auto
+ done
+
+lemma aux_in1:
+ "uniqP P ==> b \<notin> C ==> P b b ==> bijP P (insert b C) ==> bijP P C"
+ apply (unfold bijP_def)
+ apply auto
+ apply (subgoal_tac "b \<noteq> a")
+ prefer 2
+ apply clarify
+ apply (simp add: aux_uniq)
+ apply auto
+ done
+
+lemma aux_in2:
+ "symP P ==> uniqP P ==> a \<notin> C ==> b \<notin> C ==> a \<noteq> b ==> P a b
+ ==> bijP P (insert a (insert b C)) ==> bijP P C"
+ apply (unfold bijP_def)
+ apply auto
+ apply (subgoal_tac "aa \<noteq> a")
+ prefer 2
+ apply clarify
+ apply (subgoal_tac "aa \<noteq> b")
+ prefer 2
+ apply clarify
+ apply (simp add: aux_uniq)
+ apply (subgoal_tac "ba \<noteq> a")
+ apply auto
+ apply (subgoal_tac "P a aa")
+ prefer 2
+ apply (simp add: aux_sym)
+ apply (subgoal_tac "b = aa")
+ apply (rule_tac [2] iffD1)
+ apply (rule_tac [2] a = a and c = a and P = P in aux_uniq)
+ apply auto
+ done
+
+lemma aux_foo: "\<forall>a b. Q a \<and> P a b --> R b ==> P a b ==> Q a ==> R b"
+ apply auto
+ done
+
+lemma aux_bij: "bijP P F ==> symP P ==> P a b ==> (a \<in> F) = (b \<in> F)"
+ apply (unfold bijP_def)
+ apply (rule iffI)
+ apply (erule_tac [!] aux_foo)
+ apply simp_all
+ apply (rule iffD2)
+ apply (rule_tac P = P in aux_sym)
+ apply simp_all
+ done
+
+
+lemma aux_bijRER:
+ "(A, B) \<in> bijR P ==> uniqP P ==> symP P
+ ==> \<forall>F. bijP P F \<and> F \<subseteq> A \<and> F \<subseteq> B --> F \<in> bijER P"
+ apply (erule bijR.induct)
+ apply simp
+ apply (case_tac "a = b")
+ apply clarify
+ apply (case_tac "b \<in> F")
+ prefer 2
+ apply (simp add: subset_insert)
+ apply (cut_tac F = F and a = b and A = A and B = B in aux1)
+ prefer 6
+ apply clarify
+ apply (rule bijER.insert1)
+ apply simp_all
+ apply (subgoal_tac "bijP P C")
+ apply simp
+ apply (rule aux_in1)
+ apply simp_all
+ apply clarify
+ apply (case_tac "a \<in> F")
+ apply (case_tac [!] "b \<in> F")
+ apply (cut_tac F = F and a = a and b = b and A = A and B = B
+ in aux2)
+ apply (simp_all add: subset_insert)
+ apply clarify
+ apply (rule bijER.insert2)
+ apply simp_all
+ apply (subgoal_tac "bijP P C")
+ apply simp
+ apply (rule aux_in2)
+ apply simp_all
+ apply (subgoal_tac "b \<in> F")
+ apply (rule_tac [2] iffD1)
+ apply (rule_tac [2] a = a and F = F and P = P in aux_bij)
+ apply (simp_all (no_asm_simp))
+ apply (subgoal_tac [2] "a \<in> F")
+ apply (rule_tac [3] iffD2)
+ apply (rule_tac [3] b = b and F = F and P = P in aux_bij)
+ apply auto
+ done
+
+lemma bijR_bijER:
+ "(A, A) \<in> bijR P ==>
+ bijP P A ==> uniqP P ==> symP P ==> A \<in> bijER P"
+ apply (cut_tac A = A and B = A and P = P in aux_bijRER)
+ apply auto
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Chinese.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,257 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* The Chinese Remainder Theorem *}
+
+theory Chinese
+imports IntPrimes
+begin
+
+text {*
+ The Chinese Remainder Theorem for an arbitrary finite number of
+ equations. (The one-equation case is included in theory @{text
+ IntPrimes}. Uses functions for indexing.\footnote{Maybe @{term
+ funprod} and @{term funsum} should be based on general @{term fold}
+ on indices?}
+*}
+
+
+subsection {* Definitions *}
+
+consts
+ funprod :: "(nat => int) => nat => nat => int"
+ funsum :: "(nat => int) => nat => nat => int"
+
+primrec
+ "funprod f i 0 = f i"
+ "funprod f i (Suc n) = f (Suc (i + n)) * funprod f i n"
+
+primrec
+ "funsum f i 0 = f i"
+ "funsum f i (Suc n) = f (Suc (i + n)) + funsum f i n"
+
+definition
+ m_cond :: "nat => (nat => int) => bool" where
+ "m_cond n mf =
+ ((\<forall>i. i \<le> n --> 0 < mf i) \<and>
+ (\<forall>i j. i \<le> n \<and> j \<le> n \<and> i \<noteq> j --> zgcd (mf i) (mf j) = 1))"
+
+definition
+ km_cond :: "nat => (nat => int) => (nat => int) => bool" where
+ "km_cond n kf mf = (\<forall>i. i \<le> n --> zgcd (kf i) (mf i) = 1)"
+
+definition
+ lincong_sol ::
+ "nat => (nat => int) => (nat => int) => (nat => int) => int => bool" where
+ "lincong_sol n kf bf mf x = (\<forall>i. i \<le> n --> zcong (kf i * x) (bf i) (mf i))"
+
+definition
+ mhf :: "(nat => int) => nat => nat => int" where
+ "mhf mf n i =
+ (if i = 0 then funprod mf (Suc 0) (n - Suc 0)
+ else if i = n then funprod mf 0 (n - Suc 0)
+ else funprod mf 0 (i - Suc 0) * funprod mf (Suc i) (n - Suc 0 - i))"
+
+definition
+ xilin_sol ::
+ "nat => nat => (nat => int) => (nat => int) => (nat => int) => int" where
+ "xilin_sol i n kf bf mf =
+ (if 0 < n \<and> i \<le> n \<and> m_cond n mf \<and> km_cond n kf mf then
+ (SOME x. 0 \<le> x \<and> x < mf i \<and> zcong (kf i * mhf mf n i * x) (bf i) (mf i))
+ else 0)"
+
+definition
+ x_sol :: "nat => (nat => int) => (nat => int) => (nat => int) => int" where
+ "x_sol n kf bf mf = funsum (\<lambda>i. xilin_sol i n kf bf mf * mhf mf n i) 0 n"
+
+
+text {* \medskip @{term funprod} and @{term funsum} *}
+
+lemma funprod_pos: "(\<forall>i. i \<le> n --> 0 < mf i) ==> 0 < funprod mf 0 n"
+ apply (induct n)
+ apply auto
+ apply (simp add: zero_less_mult_iff)
+ done
+
+lemma funprod_zgcd [rule_format (no_asm)]:
+ "(\<forall>i. k \<le> i \<and> i \<le> k + l --> zgcd (mf i) (mf m) = 1) -->
+ zgcd (funprod mf k l) (mf m) = 1"
+ apply (induct l)
+ apply simp_all
+ apply (rule impI)+
+ apply (subst zgcd_zmult_cancel)
+ apply auto
+ done
+
+lemma funprod_zdvd [rule_format]:
+ "k \<le> i --> i \<le> k + l --> mf i dvd funprod mf k l"
+ apply (induct l)
+ apply auto
+ apply (subgoal_tac "i = Suc (k + l)")
+ apply (simp_all (no_asm_simp))
+ done
+
+lemma funsum_mod:
+ "funsum f k l mod m = funsum (\<lambda>i. (f i) mod m) k l mod m"
+ apply (induct l)
+ apply auto
+ apply (rule trans)
+ apply (rule mod_add_eq)
+ apply simp
+ apply (rule mod_add_right_eq [symmetric])
+ done
+
+lemma funsum_zero [rule_format (no_asm)]:
+ "(\<forall>i. k \<le> i \<and> i \<le> k + l --> f i = 0) --> (funsum f k l) = 0"
+ apply (induct l)
+ apply auto
+ done
+
+lemma funsum_oneelem [rule_format (no_asm)]:
+ "k \<le> j --> j \<le> k + l -->
+ (\<forall>i. k \<le> i \<and> i \<le> k + l \<and> i \<noteq> j --> f i = 0) -->
+ funsum f k l = f j"
+ apply (induct l)
+ prefer 2
+ apply clarify
+ defer
+ apply clarify
+ apply (subgoal_tac "k = j")
+ apply (simp_all (no_asm_simp))
+ apply (case_tac "Suc (k + l) = j")
+ apply (subgoal_tac "funsum f k l = 0")
+ apply (rule_tac [2] funsum_zero)
+ apply (subgoal_tac [3] "f (Suc (k + l)) = 0")
+ apply (subgoal_tac [3] "j \<le> k + l")
+ prefer 4
+ apply arith
+ apply auto
+ done
+
+
+subsection {* Chinese: uniqueness *}
+
+lemma zcong_funprod_aux:
+ "m_cond n mf ==> km_cond n kf mf
+ ==> lincong_sol n kf bf mf x ==> lincong_sol n kf bf mf y
+ ==> [x = y] (mod mf n)"
+ apply (unfold m_cond_def km_cond_def lincong_sol_def)
+ apply (rule iffD1)
+ apply (rule_tac k = "kf n" in zcong_cancel2)
+ apply (rule_tac [3] b = "bf n" in zcong_trans)
+ prefer 4
+ apply (subst zcong_sym)
+ defer
+ apply (rule order_less_imp_le)
+ apply simp_all
+ done
+
+lemma zcong_funprod [rule_format]:
+ "m_cond n mf --> km_cond n kf mf -->
+ lincong_sol n kf bf mf x --> lincong_sol n kf bf mf y -->
+ [x = y] (mod funprod mf 0 n)"
+ apply (induct n)
+ apply (simp_all (no_asm))
+ apply (blast intro: zcong_funprod_aux)
+ apply (rule impI)+
+ apply (rule zcong_zgcd_zmult_zmod)
+ apply (blast intro: zcong_funprod_aux)
+ prefer 2
+ apply (subst zgcd_commute)
+ apply (rule funprod_zgcd)
+ apply (auto simp add: m_cond_def km_cond_def lincong_sol_def)
+ done
+
+
+subsection {* Chinese: existence *}
+
+lemma unique_xi_sol:
+ "0 < n ==> i \<le> n ==> m_cond n mf ==> km_cond n kf mf
+ ==> \<exists>!x. 0 \<le> x \<and> x < mf i \<and> [kf i * mhf mf n i * x = bf i] (mod mf i)"
+ apply (rule zcong_lineq_unique)
+ apply (tactic {* stac (thm "zgcd_zmult_cancel") 2 *})
+ apply (unfold m_cond_def km_cond_def mhf_def)
+ apply (simp_all (no_asm_simp))
+ apply safe
+ apply (tactic {* stac (thm "zgcd_zmult_cancel") 3 *})
+ apply (rule_tac [!] funprod_zgcd)
+ apply safe
+ apply simp_all
+ apply (subgoal_tac "i<n")
+ prefer 2
+ apply arith
+ apply (case_tac [2] i)
+ apply simp_all
+ done
+
+lemma x_sol_lin_aux:
+ "0 < n ==> i \<le> n ==> j \<le> n ==> j \<noteq> i ==> mf j dvd mhf mf n i"
+ apply (unfold mhf_def)
+ apply (case_tac "i = 0")
+ apply (case_tac [2] "i = n")
+ apply (simp_all (no_asm_simp))
+ apply (case_tac [3] "j < i")
+ apply (rule_tac [3] dvd_mult2)
+ apply (rule_tac [4] dvd_mult)
+ apply (rule_tac [!] funprod_zdvd)
+ apply arith
+ apply arith
+ apply arith
+ apply arith
+ apply arith
+ apply arith
+ apply arith
+ apply arith
+ done
+
+lemma x_sol_lin:
+ "0 < n ==> i \<le> n
+ ==> x_sol n kf bf mf mod mf i =
+ xilin_sol i n kf bf mf * mhf mf n i mod mf i"
+ apply (unfold x_sol_def)
+ apply (subst funsum_mod)
+ apply (subst funsum_oneelem)
+ apply auto
+ apply (subst dvd_eq_mod_eq_0 [symmetric])
+ apply (rule dvd_mult)
+ apply (rule x_sol_lin_aux)
+ apply auto
+ done
+
+
+subsection {* Chinese *}
+
+lemma chinese_remainder:
+ "0 < n ==> m_cond n mf ==> km_cond n kf mf
+ ==> \<exists>!x. 0 \<le> x \<and> x < funprod mf 0 n \<and> lincong_sol n kf bf mf x"
+ apply safe
+ apply (rule_tac [2] m = "funprod mf 0 n" in zcong_zless_imp_eq)
+ apply (rule_tac [6] zcong_funprod)
+ apply auto
+ apply (rule_tac x = "x_sol n kf bf mf mod funprod mf 0 n" in exI)
+ apply (unfold lincong_sol_def)
+ apply safe
+ apply (tactic {* stac (thm "zcong_zmod") 3 *})
+ apply (tactic {* stac (thm "mod_mult_eq") 3 *})
+ apply (tactic {* stac (thm "mod_mod_cancel") 3 *})
+ apply (tactic {* stac (thm "x_sol_lin") 4 *})
+ apply (tactic {* stac (thm "mod_mult_eq" RS sym) 6 *})
+ apply (tactic {* stac (thm "zcong_zmod" RS sym) 6 *})
+ apply (subgoal_tac [6]
+ "0 \<le> xilin_sol i n kf bf mf \<and> xilin_sol i n kf bf mf < mf i
+ \<and> [kf i * mhf mf n i * xilin_sol i n kf bf mf = bf i] (mod mf i)")
+ prefer 6
+ apply (simp add: zmult_ac)
+ apply (unfold xilin_sol_def)
+ apply (tactic {* asm_simp_tac @{simpset} 6 *})
+ apply (rule_tac [6] ex1_implies_ex [THEN someI_ex])
+ apply (rule_tac [6] unique_xi_sol)
+ apply (rule_tac [3] funprod_zdvd)
+ apply (unfold m_cond_def)
+ apply (rule funprod_pos [THEN pos_mod_sign])
+ apply (rule_tac [2] funprod_pos [THEN pos_mod_bound])
+ apply auto
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Euler.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,304 @@
+(* Title: HOL/Quadratic_Reciprocity/Euler.thy
+ ID: $Id$
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {* Euler's criterion *}
+
+theory Euler imports Residues EvenOdd begin
+
+definition
+ MultInvPair :: "int => int => int => int set" where
+ "MultInvPair a p j = {StandardRes p j, StandardRes p (a * (MultInv p j))}"
+
+definition
+ SetS :: "int => int => int set set" where
+ "SetS a p = (MultInvPair a p ` SRStar p)"
+
+
+subsection {* Property for MultInvPair *}
+
+lemma MultInvPair_prop1a:
+ "[| zprime p; 2 < p; ~([a = 0](mod p));
+ X \<in> (SetS a p); Y \<in> (SetS a p);
+ ~((X \<inter> Y) = {}) |] ==> X = Y"
+ apply (auto simp add: SetS_def)
+ apply (drule StandardRes_SRStar_prop1a)+ defer 1
+ apply (drule StandardRes_SRStar_prop1a)+
+ apply (auto simp add: MultInvPair_def StandardRes_prop2 zcong_sym)
+ apply (drule notE, rule MultInv_zcong_prop1, auto)[]
+ apply (drule notE, rule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
+ apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
+ apply (drule MultInv_zcong_prop3, auto simp add: zcong_sym)[]
+ apply (drule MultInv_zcong_prop1, auto)[]
+ apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
+ apply (drule MultInv_zcong_prop2, auto simp add: zcong_sym)[]
+ apply (drule MultInv_zcong_prop3, auto simp add: zcong_sym)[]
+ done
+
+lemma MultInvPair_prop1b:
+ "[| zprime p; 2 < p; ~([a = 0](mod p));
+ X \<in> (SetS a p); Y \<in> (SetS a p);
+ X \<noteq> Y |] ==> X \<inter> Y = {}"
+ apply (rule notnotD)
+ apply (rule notI)
+ apply (drule MultInvPair_prop1a, auto)
+ done
+
+lemma MultInvPair_prop1c: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
+ \<forall>X \<in> SetS a p. \<forall>Y \<in> SetS a p. X \<noteq> Y --> X\<inter>Y = {}"
+ by (auto simp add: MultInvPair_prop1b)
+
+lemma MultInvPair_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
+ Union ( SetS a p) = SRStar p"
+ apply (auto simp add: SetS_def MultInvPair_def StandardRes_SRStar_prop4
+ SRStar_mult_prop2)
+ apply (frule StandardRes_SRStar_prop3)
+ apply (rule bexI, auto)
+ done
+
+lemma MultInvPair_distinct: "[| zprime p; 2 < p; ~([a = 0] (mod p));
+ ~([j = 0] (mod p));
+ ~(QuadRes p a) |] ==>
+ ~([j = a * MultInv p j] (mod p))"
+proof
+ assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and
+ "~([j = 0] (mod p))" and "~(QuadRes p a)"
+ assume "[j = a * MultInv p j] (mod p)"
+ then have "[j * j = (a * MultInv p j) * j] (mod p)"
+ by (auto simp add: zcong_scalar)
+ then have a:"[j * j = a * (MultInv p j * j)] (mod p)"
+ by (auto simp add: zmult_ac)
+ have "[j * j = a] (mod p)"
+ proof -
+ from prems have b: "[MultInv p j * j = 1] (mod p)"
+ by (simp add: MultInv_prop2a)
+ from b a show ?thesis
+ by (auto simp add: zcong_zmult_prop2)
+ qed
+ then have "[j^2 = a] (mod p)"
+ by (metis number_of_is_id power2_eq_square succ_bin_simps)
+ with prems show False
+ by (simp add: QuadRes_def)
+qed
+
+lemma MultInvPair_card_two: "[| zprime p; 2 < p; ~([a = 0] (mod p));
+ ~(QuadRes p a); ~([j = 0] (mod p)) |] ==>
+ card (MultInvPair a p j) = 2"
+ apply (auto simp add: MultInvPair_def)
+ apply (subgoal_tac "~ (StandardRes p j = StandardRes p (a * MultInv p j))")
+ apply auto
+ apply (metis MultInvPair_distinct Pls_def StandardRes_def aux number_of_is_id one_is_num_one)
+ done
+
+
+subsection {* Properties of SetS *}
+
+lemma SetS_finite: "2 < p ==> finite (SetS a p)"
+ by (auto simp add: SetS_def SRStar_finite [of p] finite_imageI)
+
+lemma SetS_elems_finite: "\<forall>X \<in> SetS a p. finite X"
+ by (auto simp add: SetS_def MultInvPair_def)
+
+lemma SetS_elems_card: "[| zprime p; 2 < p; ~([a = 0] (mod p));
+ ~(QuadRes p a) |] ==>
+ \<forall>X \<in> SetS a p. card X = 2"
+ apply (auto simp add: SetS_def)
+ apply (frule StandardRes_SRStar_prop1a)
+ apply (rule MultInvPair_card_two, auto)
+ done
+
+lemma Union_SetS_finite: "2 < p ==> finite (Union (SetS a p))"
+ by (auto simp add: SetS_finite SetS_elems_finite finite_Union)
+
+lemma card_setsum_aux: "[| finite S; \<forall>X \<in> S. finite (X::int set);
+ \<forall>X \<in> S. card X = n |] ==> setsum card S = setsum (%x. n) S"
+ by (induct set: finite) auto
+
+lemma SetS_card: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
+ int(card(SetS a p)) = (p - 1) div 2"
+proof -
+ assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and "~(QuadRes p a)"
+ then have "(p - 1) = 2 * int(card(SetS a p))"
+ proof -
+ have "p - 1 = int(card(Union (SetS a p)))"
+ by (auto simp add: prems MultInvPair_prop2 SRStar_card)
+ also have "... = int (setsum card (SetS a p))"
+ by (auto simp add: prems SetS_finite SetS_elems_finite
+ MultInvPair_prop1c [of p a] card_Union_disjoint)
+ also have "... = int(setsum (%x.2) (SetS a p))"
+ using prems
+ by (auto simp add: SetS_elems_card SetS_finite SetS_elems_finite
+ card_setsum_aux simp del: setsum_constant)
+ also have "... = 2 * int(card( SetS a p))"
+ by (auto simp add: prems SetS_finite setsum_const2)
+ finally show ?thesis .
+ qed
+ from this show ?thesis
+ by auto
+qed
+
+lemma SetS_setprod_prop: "[| zprime p; 2 < p; ~([a = 0] (mod p));
+ ~(QuadRes p a); x \<in> (SetS a p) |] ==>
+ [\<Prod>x = a] (mod p)"
+ apply (auto simp add: SetS_def MultInvPair_def)
+ apply (frule StandardRes_SRStar_prop1a)
+ apply (subgoal_tac "StandardRes p x \<noteq> StandardRes p (a * MultInv p x)")
+ apply (auto simp add: StandardRes_prop2 MultInvPair_distinct)
+ apply (frule_tac m = p and x = x and y = "(a * MultInv p x)" in
+ StandardRes_prop4)
+ apply (subgoal_tac "[x * (a * MultInv p x) = a * (x * MultInv p x)] (mod p)")
+ apply (drule_tac a = "StandardRes p x * StandardRes p (a * MultInv p x)" and
+ b = "x * (a * MultInv p x)" and
+ c = "a * (x * MultInv p x)" in zcong_trans, force)
+ apply (frule_tac p = p and x = x in MultInv_prop2, auto)
+apply (metis StandardRes_SRStar_prop3 mult_1_right mult_commute zcong_sym zcong_zmult_prop1)
+ apply (auto simp add: zmult_ac)
+ done
+
+lemma aux1: "[| 0 < x; (x::int) < a; x \<noteq> (a - 1) |] ==> x < a - 1"
+ by arith
+
+lemma aux2: "[| (a::int) < c; b < c |] ==> (a \<le> b | b \<le> a)"
+ by auto
+
+lemma SRStar_d22set_prop: "2 < p \<Longrightarrow> (SRStar p) = {1} \<union> (d22set (p - 1))"
+ apply (induct p rule: d22set.induct)
+ apply auto
+ apply (simp add: SRStar_def d22set.simps)
+ apply (simp add: SRStar_def d22set.simps, clarify)
+ apply (frule aux1)
+ apply (frule aux2, auto)
+ apply (simp_all add: SRStar_def)
+ apply (simp add: d22set.simps)
+ apply (frule d22set_le)
+ apply (frule d22set_g_1, auto)
+ done
+
+lemma Union_SetS_setprod_prop1: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
+ [\<Prod>(Union (SetS a p)) = a ^ nat ((p - 1) div 2)] (mod p)"
+proof -
+ assume "zprime p" and "2 < p" and "~([a = 0] (mod p))" and "~(QuadRes p a)"
+ then have "[\<Prod>(Union (SetS a p)) =
+ setprod (setprod (%x. x)) (SetS a p)] (mod p)"
+ by (auto simp add: SetS_finite SetS_elems_finite
+ MultInvPair_prop1c setprod_Union_disjoint)
+ also have "[setprod (setprod (%x. x)) (SetS a p) =
+ setprod (%x. a) (SetS a p)] (mod p)"
+ by (rule setprod_same_function_zcong)
+ (auto simp add: prems SetS_setprod_prop SetS_finite)
+ also (zcong_trans) have "[setprod (%x. a) (SetS a p) =
+ a^(card (SetS a p))] (mod p)"
+ by (auto simp add: prems SetS_finite setprod_constant)
+ finally (zcong_trans) show ?thesis
+ apply (rule zcong_trans)
+ apply (subgoal_tac "card(SetS a p) = nat((p - 1) div 2)", auto)
+ apply (subgoal_tac "nat(int(card(SetS a p))) = nat((p - 1) div 2)", force)
+ apply (auto simp add: prems SetS_card)
+ done
+qed
+
+lemma Union_SetS_setprod_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p)) |] ==>
+ \<Prod>(Union (SetS a p)) = zfact (p - 1)"
+proof -
+ assume "zprime p" and "2 < p" and "~([a = 0](mod p))"
+ then have "\<Prod>(Union (SetS a p)) = \<Prod>(SRStar p)"
+ by (auto simp add: MultInvPair_prop2)
+ also have "... = \<Prod>({1} \<union> (d22set (p - 1)))"
+ by (auto simp add: prems SRStar_d22set_prop)
+ also have "... = zfact(p - 1)"
+ proof -
+ have "~(1 \<in> d22set (p - 1)) & finite( d22set (p - 1))"
+ by (metis d22set_fin d22set_g_1 linorder_neq_iff)
+ then have "\<Prod>({1} \<union> (d22set (p - 1))) = \<Prod>(d22set (p - 1))"
+ by auto
+ then show ?thesis
+ by (auto simp add: d22set_prod_zfact)
+ qed
+ finally show ?thesis .
+qed
+
+lemma zfact_prop: "[| zprime p; 2 < p; ~([a = 0] (mod p)); ~(QuadRes p a) |] ==>
+ [zfact (p - 1) = a ^ nat ((p - 1) div 2)] (mod p)"
+ apply (frule Union_SetS_setprod_prop1)
+ apply (auto simp add: Union_SetS_setprod_prop2)
+ done
+
+text {* \medskip Prove the first part of Euler's Criterion: *}
+
+lemma Euler_part1: "[| 2 < p; zprime p; ~([x = 0](mod p));
+ ~(QuadRes p x) |] ==>
+ [x^(nat (((p) - 1) div 2)) = -1](mod p)"
+ by (metis Wilson_Russ number_of_is_id zcong_sym zcong_trans zfact_prop)
+
+text {* \medskip Prove another part of Euler Criterion: *}
+
+lemma aux_1: "0 < p ==> (a::int) ^ nat (p) = a * a ^ (nat (p) - 1)"
+proof -
+ assume "0 < p"
+ then have "a ^ (nat p) = a ^ (1 + (nat p - 1))"
+ by (auto simp add: diff_add_assoc)
+ also have "... = (a ^ 1) * a ^ (nat(p) - 1)"
+ by (simp only: zpower_zadd_distrib)
+ also have "... = a * a ^ (nat(p) - 1)"
+ by auto
+ finally show ?thesis .
+qed
+
+lemma aux_2: "[| (2::int) < p; p \<in> zOdd |] ==> 0 < ((p - 1) div 2)"
+proof -
+ assume "2 < p" and "p \<in> zOdd"
+ then have "(p - 1):zEven"
+ by (auto simp add: zEven_def zOdd_def)
+ then have aux_1: "2 * ((p - 1) div 2) = (p - 1)"
+ by (auto simp add: even_div_2_prop2)
+ with `2 < p` have "1 < (p - 1)"
+ by auto
+ then have " 1 < (2 * ((p - 1) div 2))"
+ by (auto simp add: aux_1)
+ then have "0 < (2 * ((p - 1) div 2)) div 2"
+ by auto
+ then show ?thesis by auto
+qed
+
+lemma Euler_part2:
+ "[| 2 < p; zprime p; [a = 0] (mod p) |] ==> [0 = a ^ nat ((p - 1) div 2)] (mod p)"
+ apply (frule zprime_zOdd_eq_grt_2)
+ apply (frule aux_2, auto)
+ apply (frule_tac a = a in aux_1, auto)
+ apply (frule zcong_zmult_prop1, auto)
+ done
+
+text {* \medskip Prove the final part of Euler's Criterion: *}
+
+lemma aux__1: "[| ~([x = 0] (mod p)); [y ^ 2 = x] (mod p)|] ==> ~(p dvd y)"
+ by (metis dvdI power2_eq_square zcong_sym zcong_trans zcong_zero_equiv_div dvd_trans)
+
+lemma aux__2: "2 * nat((p - 1) div 2) = nat (2 * ((p - 1) div 2))"
+ by (auto simp add: nat_mult_distrib)
+
+lemma Euler_part3: "[| 2 < p; zprime p; ~([x = 0](mod p)); QuadRes p x |] ==>
+ [x^(nat (((p) - 1) div 2)) = 1](mod p)"
+ apply (subgoal_tac "p \<in> zOdd")
+ apply (auto simp add: QuadRes_def)
+ prefer 2
+ apply (metis number_of_is_id numeral_1_eq_1 zprime_zOdd_eq_grt_2)
+ apply (frule aux__1, auto)
+ apply (drule_tac z = "nat ((p - 1) div 2)" in zcong_zpower)
+ apply (auto simp add: zpower_zpower)
+ apply (rule zcong_trans)
+ apply (auto simp add: zcong_sym [of "x ^ nat ((p - 1) div 2)"])
+ apply (metis Little_Fermat even_div_2_prop2 mult_Bit0 number_of_is_id odd_minus_one_even one_is_num_one zmult_1 aux__2)
+ done
+
+
+text {* \medskip Finally show Euler's Criterion: *}
+
+theorem Euler_Criterion: "[| 2 < p; zprime p |] ==> [(Legendre a p) =
+ a^(nat (((p) - 1) div 2))] (mod p)"
+ apply (auto simp add: Legendre_def Euler_part2)
+ apply (frule Euler_part3, auto simp add: zcong_sym)[]
+ apply (frule Euler_part1, auto simp add: zcong_sym)[]
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/EulerFermat.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,346 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Fermat's Little Theorem extended to Euler's Totient function *}
+
+theory EulerFermat
+imports BijectionRel IntFact
+begin
+
+text {*
+ Fermat's Little Theorem extended to Euler's Totient function. More
+ abstract approach than Boyer-Moore (which seems necessary to achieve
+ the extended version).
+*}
+
+
+subsection {* Definitions and lemmas *}
+
+inductive_set
+ RsetR :: "int => int set set"
+ for m :: int
+ where
+ empty [simp]: "{} \<in> RsetR m"
+ | insert: "A \<in> RsetR m ==> zgcd a m = 1 ==>
+ \<forall>a'. a' \<in> A --> \<not> zcong a a' m ==> insert a A \<in> RsetR m"
+
+consts
+ BnorRset :: "int * int => int set"
+
+recdef BnorRset
+ "measure ((\<lambda>(a, m). nat a) :: int * int => nat)"
+ "BnorRset (a, m) =
+ (if 0 < a then
+ let na = BnorRset (a - 1, m)
+ in (if zgcd a m = 1 then insert a na else na)
+ else {})"
+
+definition
+ norRRset :: "int => int set" where
+ "norRRset m = BnorRset (m - 1, m)"
+
+definition
+ noXRRset :: "int => int => int set" where
+ "noXRRset m x = (\<lambda>a. a * x) ` norRRset m"
+
+definition
+ phi :: "int => nat" where
+ "phi m = card (norRRset m)"
+
+definition
+ is_RRset :: "int set => int => bool" where
+ "is_RRset A m = (A \<in> RsetR m \<and> card A = phi m)"
+
+definition
+ RRset2norRR :: "int set => int => int => int" where
+ "RRset2norRR A m a =
+ (if 1 < m \<and> is_RRset A m \<and> a \<in> A then
+ SOME b. zcong a b m \<and> b \<in> norRRset m
+ else 0)"
+
+definition
+ zcongm :: "int => int => int => bool" where
+ "zcongm m = (\<lambda>a b. zcong a b m)"
+
+lemma abs_eq_1_iff [iff]: "(abs z = (1::int)) = (z = 1 \<or> z = -1)"
+ -- {* LCP: not sure why this lemma is needed now *}
+ by (auto simp add: abs_if)
+
+
+text {* \medskip @{text norRRset} *}
+
+declare BnorRset.simps [simp del]
+
+lemma BnorRset_induct:
+ assumes "!!a m. P {} a m"
+ and "!!a m. 0 < (a::int) ==> P (BnorRset (a - 1, m::int)) (a - 1) m
+ ==> P (BnorRset(a,m)) a m"
+ shows "P (BnorRset(u,v)) u v"
+ apply (rule BnorRset.induct)
+ apply safe
+ apply (case_tac [2] "0 < a")
+ apply (rule_tac [2] prems)
+ apply simp_all
+ apply (simp_all add: BnorRset.simps prems)
+ done
+
+lemma Bnor_mem_zle [rule_format]: "b \<in> BnorRset (a, m) \<longrightarrow> b \<le> a"
+ apply (induct a m rule: BnorRset_induct)
+ apply simp
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma Bnor_mem_zle_swap: "a < b ==> b \<notin> BnorRset (a, m)"
+ by (auto dest: Bnor_mem_zle)
+
+lemma Bnor_mem_zg [rule_format]: "b \<in> BnorRset (a, m) --> 0 < b"
+ apply (induct a m rule: BnorRset_induct)
+ prefer 2
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma Bnor_mem_if [rule_format]:
+ "zgcd b m = 1 --> 0 < b --> b \<le> a --> b \<in> BnorRset (a, m)"
+ apply (induct a m rule: BnorRset.induct, auto)
+ apply (subst BnorRset.simps)
+ defer
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma Bnor_in_RsetR [rule_format]: "a < m --> BnorRset (a, m) \<in> RsetR m"
+ apply (induct a m rule: BnorRset_induct, simp)
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ apply (rule RsetR.insert)
+ apply (rule_tac [3] allI)
+ apply (rule_tac [3] impI)
+ apply (rule_tac [3] zcong_not)
+ apply (subgoal_tac [6] "a' \<le> a - 1")
+ apply (rule_tac [7] Bnor_mem_zle)
+ apply (rule_tac [5] Bnor_mem_zg, auto)
+ done
+
+lemma Bnor_fin: "finite (BnorRset (a, m))"
+ apply (induct a m rule: BnorRset_induct)
+ prefer 2
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma norR_mem_unique_aux: "a \<le> b - 1 ==> a < (b::int)"
+ apply auto
+ done
+
+lemma norR_mem_unique:
+ "1 < m ==>
+ zgcd a m = 1 ==> \<exists>!b. [a = b] (mod m) \<and> b \<in> norRRset m"
+ apply (unfold norRRset_def)
+ apply (cut_tac a = a and m = m in zcong_zless_unique, auto)
+ apply (rule_tac [2] m = m in zcong_zless_imp_eq)
+ apply (auto intro: Bnor_mem_zle Bnor_mem_zg zcong_trans
+ order_less_imp_le norR_mem_unique_aux simp add: zcong_sym)
+ apply (rule_tac x = b in exI, safe)
+ apply (rule Bnor_mem_if)
+ apply (case_tac [2] "b = 0")
+ apply (auto intro: order_less_le [THEN iffD2])
+ prefer 2
+ apply (simp only: zcong_def)
+ apply (subgoal_tac "zgcd a m = m")
+ prefer 2
+ apply (subst zdvd_iff_zgcd [symmetric])
+ apply (rule_tac [4] zgcd_zcong_zgcd)
+ apply (simp_all add: zcong_sym)
+ done
+
+
+text {* \medskip @{term noXRRset} *}
+
+lemma RRset_gcd [rule_format]:
+ "is_RRset A m ==> a \<in> A --> zgcd a m = 1"
+ apply (unfold is_RRset_def)
+ apply (rule RsetR.induct [where P="%A. a \<in> A --> zgcd a m = 1"], auto)
+ done
+
+lemma RsetR_zmult_mono:
+ "A \<in> RsetR m ==>
+ 0 < m ==> zgcd x m = 1 ==> (\<lambda>a. a * x) ` A \<in> RsetR m"
+ apply (erule RsetR.induct, simp_all)
+ apply (rule RsetR.insert, auto)
+ apply (blast intro: zgcd_zgcd_zmult)
+ apply (simp add: zcong_cancel)
+ done
+
+lemma card_nor_eq_noX:
+ "0 < m ==>
+ zgcd x m = 1 ==> card (noXRRset m x) = card (norRRset m)"
+ apply (unfold norRRset_def noXRRset_def)
+ apply (rule card_image)
+ apply (auto simp add: inj_on_def Bnor_fin)
+ apply (simp add: BnorRset.simps)
+ done
+
+lemma noX_is_RRset:
+ "0 < m ==> zgcd x m = 1 ==> is_RRset (noXRRset m x) m"
+ apply (unfold is_RRset_def phi_def)
+ apply (auto simp add: card_nor_eq_noX)
+ apply (unfold noXRRset_def norRRset_def)
+ apply (rule RsetR_zmult_mono)
+ apply (rule Bnor_in_RsetR, simp_all)
+ done
+
+lemma aux_some:
+ "1 < m ==> is_RRset A m ==> a \<in> A
+ ==> zcong a (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) m \<and>
+ (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) \<in> norRRset m"
+ apply (rule norR_mem_unique [THEN ex1_implies_ex, THEN someI_ex])
+ apply (rule_tac [2] RRset_gcd, simp_all)
+ done
+
+lemma RRset2norRR_correct:
+ "1 < m ==> is_RRset A m ==> a \<in> A ==>
+ [a = RRset2norRR A m a] (mod m) \<and> RRset2norRR A m a \<in> norRRset m"
+ apply (unfold RRset2norRR_def, simp)
+ apply (rule aux_some, simp_all)
+ done
+
+lemmas RRset2norRR_correct1 =
+ RRset2norRR_correct [THEN conjunct1, standard]
+lemmas RRset2norRR_correct2 =
+ RRset2norRR_correct [THEN conjunct2, standard]
+
+lemma RsetR_fin: "A \<in> RsetR m ==> finite A"
+ by (induct set: RsetR) auto
+
+lemma RRset_zcong_eq [rule_format]:
+ "1 < m ==>
+ is_RRset A m ==> [a = b] (mod m) ==> a \<in> A --> b \<in> A --> a = b"
+ apply (unfold is_RRset_def)
+ apply (rule RsetR.induct [where P="%A. a \<in> A --> b \<in> A --> a = b"])
+ apply (auto simp add: zcong_sym)
+ done
+
+lemma aux:
+ "P (SOME a. P a) ==> Q (SOME a. Q a) ==>
+ (SOME a. P a) = (SOME a. Q a) ==> \<exists>a. P a \<and> Q a"
+ apply auto
+ done
+
+lemma RRset2norRR_inj:
+ "1 < m ==> is_RRset A m ==> inj_on (RRset2norRR A m) A"
+ apply (unfold RRset2norRR_def inj_on_def, auto)
+ apply (subgoal_tac "\<exists>b. ([x = b] (mod m) \<and> b \<in> norRRset m) \<and>
+ ([y = b] (mod m) \<and> b \<in> norRRset m)")
+ apply (rule_tac [2] aux)
+ apply (rule_tac [3] aux_some)
+ apply (rule_tac [2] aux_some)
+ apply (rule RRset_zcong_eq, auto)
+ apply (rule_tac b = b in zcong_trans)
+ apply (simp_all add: zcong_sym)
+ done
+
+lemma RRset2norRR_eq_norR:
+ "1 < m ==> is_RRset A m ==> RRset2norRR A m ` A = norRRset m"
+ apply (rule card_seteq)
+ prefer 3
+ apply (subst card_image)
+ apply (rule_tac RRset2norRR_inj, auto)
+ apply (rule_tac [3] RRset2norRR_correct2, auto)
+ apply (unfold is_RRset_def phi_def norRRset_def)
+ apply (auto simp add: Bnor_fin)
+ done
+
+
+lemma Bnor_prod_power_aux: "a \<notin> A ==> inj f ==> f a \<notin> f ` A"
+by (unfold inj_on_def, auto)
+
+lemma Bnor_prod_power [rule_format]:
+ "x \<noteq> 0 ==> a < m --> \<Prod>((\<lambda>a. a * x) ` BnorRset (a, m)) =
+ \<Prod>(BnorRset(a, m)) * x^card (BnorRset (a, m))"
+ apply (induct a m rule: BnorRset_induct)
+ prefer 2
+ apply (simplesubst BnorRset.simps) --{*multiple redexes*}
+ apply (unfold Let_def, auto)
+ apply (simp add: Bnor_fin Bnor_mem_zle_swap)
+ apply (subst setprod_insert)
+ apply (rule_tac [2] Bnor_prod_power_aux)
+ apply (unfold inj_on_def)
+ apply (simp_all add: zmult_ac Bnor_fin finite_imageI
+ Bnor_mem_zle_swap)
+ done
+
+
+subsection {* Fermat *}
+
+lemma bijzcong_zcong_prod:
+ "(A, B) \<in> bijR (zcongm m) ==> [\<Prod>A = \<Prod>B] (mod m)"
+ apply (unfold zcongm_def)
+ apply (erule bijR.induct)
+ apply (subgoal_tac [2] "a \<notin> A \<and> b \<notin> B \<and> finite A \<and> finite B")
+ apply (auto intro: fin_bijRl fin_bijRr zcong_zmult)
+ done
+
+lemma Bnor_prod_zgcd [rule_format]:
+ "a < m --> zgcd (\<Prod>(BnorRset(a, m))) m = 1"
+ apply (induct a m rule: BnorRset_induct)
+ prefer 2
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto)
+ apply (simp add: Bnor_fin Bnor_mem_zle_swap)
+ apply (blast intro: zgcd_zgcd_zmult)
+ done
+
+theorem Euler_Fermat:
+ "0 < m ==> zgcd x m = 1 ==> [x^(phi m) = 1] (mod m)"
+ apply (unfold norRRset_def phi_def)
+ apply (case_tac "x = 0")
+ apply (case_tac [2] "m = 1")
+ apply (rule_tac [3] iffD1)
+ apply (rule_tac [3] k = "\<Prod>(BnorRset(m - 1, m))"
+ in zcong_cancel2)
+ prefer 5
+ apply (subst Bnor_prod_power [symmetric])
+ apply (rule_tac [7] Bnor_prod_zgcd, simp_all)
+ apply (rule bijzcong_zcong_prod)
+ apply (fold norRRset_def noXRRset_def)
+ apply (subst RRset2norRR_eq_norR [symmetric])
+ apply (rule_tac [3] inj_func_bijR, auto)
+ apply (unfold zcongm_def)
+ apply (rule_tac [2] RRset2norRR_correct1)
+ apply (rule_tac [5] RRset2norRR_inj)
+ apply (auto intro: order_less_le [THEN iffD2]
+ simp add: noX_is_RRset)
+ apply (unfold noXRRset_def norRRset_def)
+ apply (rule finite_imageI)
+ apply (rule Bnor_fin)
+ done
+
+lemma Bnor_prime:
+ "\<lbrakk> zprime p; a < p \<rbrakk> \<Longrightarrow> card (BnorRset (a, p)) = nat a"
+ apply (induct a p rule: BnorRset.induct)
+ apply (subst BnorRset.simps)
+ apply (unfold Let_def, auto simp add:zless_zprime_imp_zrelprime)
+ apply (subgoal_tac "finite (BnorRset (a - 1,m))")
+ apply (subgoal_tac "a ~: BnorRset (a - 1,m)")
+ apply (auto simp add: card_insert_disjoint Suc_nat_eq_nat_zadd1)
+ apply (frule Bnor_mem_zle, arith)
+ apply (frule Bnor_fin)
+ done
+
+lemma phi_prime: "zprime p ==> phi p = nat (p - 1)"
+ apply (unfold phi_def norRRset_def)
+ apply (rule Bnor_prime, auto)
+ done
+
+theorem Little_Fermat:
+ "zprime p ==> \<not> p dvd x ==> [x^(nat (p - 1)) = 1] (mod p)"
+ apply (subst phi_prime [symmetric])
+ apply (rule_tac [2] Euler_Fermat)
+ apply (erule_tac [3] zprime_imp_zrelprime)
+ apply (unfold zprime_def, auto)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/EvenOdd.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,256 @@
+(* Title: HOL/Quadratic_Reciprocity/EvenOdd.thy
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {*Parity: Even and Odd Integers*}
+
+theory EvenOdd
+imports Int2
+begin
+
+definition
+ zOdd :: "int set" where
+ "zOdd = {x. \<exists>k. x = 2 * k + 1}"
+
+definition
+ zEven :: "int set" where
+ "zEven = {x. \<exists>k. x = 2 * k}"
+
+subsection {* Some useful properties about even and odd *}
+
+lemma zOddI [intro?]: "x = 2 * k + 1 \<Longrightarrow> x \<in> zOdd"
+ and zOddE [elim?]: "x \<in> zOdd \<Longrightarrow> (!!k. x = 2 * k + 1 \<Longrightarrow> C) \<Longrightarrow> C"
+ by (auto simp add: zOdd_def)
+
+lemma zEvenI [intro?]: "x = 2 * k \<Longrightarrow> x \<in> zEven"
+ and zEvenE [elim?]: "x \<in> zEven \<Longrightarrow> (!!k. x = 2 * k \<Longrightarrow> C) \<Longrightarrow> C"
+ by (auto simp add: zEven_def)
+
+lemma one_not_even: "~(1 \<in> zEven)"
+proof
+ assume "1 \<in> zEven"
+ then obtain k :: int where "1 = 2 * k" ..
+ then show False by arith
+qed
+
+lemma even_odd_conj: "~(x \<in> zOdd & x \<in> zEven)"
+proof -
+ {
+ fix a b
+ assume "2 * (a::int) = 2 * (b::int) + 1"
+ then have "2 * (a::int) - 2 * (b :: int) = 1"
+ by arith
+ then have "2 * (a - b) = 1"
+ by (auto simp add: zdiff_zmult_distrib)
+ moreover have "(2 * (a - b)):zEven"
+ by (auto simp only: zEven_def)
+ ultimately have False
+ by (auto simp add: one_not_even)
+ }
+ then show ?thesis
+ by (auto simp add: zOdd_def zEven_def)
+qed
+
+lemma even_odd_disj: "(x \<in> zOdd | x \<in> zEven)"
+ by (simp add: zOdd_def zEven_def) arith
+
+lemma not_odd_impl_even: "~(x \<in> zOdd) ==> x \<in> zEven"
+ using even_odd_disj by auto
+
+lemma odd_mult_odd_prop: "(x*y):zOdd ==> x \<in> zOdd"
+proof (rule classical)
+ assume "\<not> ?thesis"
+ then have "x \<in> zEven" by (rule not_odd_impl_even)
+ then obtain a where a: "x = 2 * a" ..
+ assume "x * y : zOdd"
+ then obtain b where "x * y = 2 * b + 1" ..
+ with a have "2 * a * y = 2 * b + 1" by simp
+ then have "2 * a * y - 2 * b = 1"
+ by arith
+ then have "2 * (a * y - b) = 1"
+ by (auto simp add: zdiff_zmult_distrib)
+ moreover have "(2 * (a * y - b)):zEven"
+ by (auto simp only: zEven_def)
+ ultimately have False
+ by (auto simp add: one_not_even)
+ then show ?thesis ..
+qed
+
+lemma odd_minus_one_even: "x \<in> zOdd ==> (x - 1):zEven"
+ by (auto simp add: zOdd_def zEven_def)
+
+lemma even_div_2_prop1: "x \<in> zEven ==> (x mod 2) = 0"
+ by (auto simp add: zEven_def)
+
+lemma even_div_2_prop2: "x \<in> zEven ==> (2 * (x div 2)) = x"
+ by (auto simp add: zEven_def)
+
+lemma even_plus_even: "[| x \<in> zEven; y \<in> zEven |] ==> x + y \<in> zEven"
+ apply (auto simp add: zEven_def)
+ apply (auto simp only: zadd_zmult_distrib2 [symmetric])
+ done
+
+lemma even_times_either: "x \<in> zEven ==> x * y \<in> zEven"
+ by (auto simp add: zEven_def)
+
+lemma even_minus_even: "[| x \<in> zEven; y \<in> zEven |] ==> x - y \<in> zEven"
+ apply (auto simp add: zEven_def)
+ apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
+ done
+
+lemma odd_minus_odd: "[| x \<in> zOdd; y \<in> zOdd |] ==> x - y \<in> zEven"
+ apply (auto simp add: zOdd_def zEven_def)
+ apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
+ done
+
+lemma even_minus_odd: "[| x \<in> zEven; y \<in> zOdd |] ==> x - y \<in> zOdd"
+ apply (auto simp add: zOdd_def zEven_def)
+ apply (rule_tac x = "k - ka - 1" in exI)
+ apply auto
+ done
+
+lemma odd_minus_even: "[| x \<in> zOdd; y \<in> zEven |] ==> x - y \<in> zOdd"
+ apply (auto simp add: zOdd_def zEven_def)
+ apply (auto simp only: zdiff_zmult_distrib2 [symmetric])
+ done
+
+lemma odd_times_odd: "[| x \<in> zOdd; y \<in> zOdd |] ==> x * y \<in> zOdd"
+ apply (auto simp add: zOdd_def zadd_zmult_distrib zadd_zmult_distrib2)
+ apply (rule_tac x = "2 * ka * k + ka + k" in exI)
+ apply (auto simp add: zadd_zmult_distrib)
+ done
+
+lemma odd_iff_not_even: "(x \<in> zOdd) = (~ (x \<in> zEven))"
+ using even_odd_conj even_odd_disj by auto
+
+lemma even_product: "x * y \<in> zEven ==> x \<in> zEven | y \<in> zEven"
+ using odd_iff_not_even odd_times_odd by auto
+
+lemma even_diff: "x - y \<in> zEven = ((x \<in> zEven) = (y \<in> zEven))"
+proof
+ assume xy: "x - y \<in> zEven"
+ {
+ assume x: "x \<in> zEven"
+ have "y \<in> zEven"
+ proof (rule classical)
+ assume "\<not> ?thesis"
+ then have "y \<in> zOdd"
+ by (simp add: odd_iff_not_even)
+ with x have "x - y \<in> zOdd"
+ by (simp add: even_minus_odd)
+ with xy have False
+ by (auto simp add: odd_iff_not_even)
+ then show ?thesis ..
+ qed
+ } moreover {
+ assume y: "y \<in> zEven"
+ have "x \<in> zEven"
+ proof (rule classical)
+ assume "\<not> ?thesis"
+ then have "x \<in> zOdd"
+ by (auto simp add: odd_iff_not_even)
+ with y have "x - y \<in> zOdd"
+ by (simp add: odd_minus_even)
+ with xy have False
+ by (auto simp add: odd_iff_not_even)
+ then show ?thesis ..
+ qed
+ }
+ ultimately show "(x \<in> zEven) = (y \<in> zEven)"
+ by (auto simp add: odd_iff_not_even even_minus_even odd_minus_odd
+ even_minus_odd odd_minus_even)
+next
+ assume "(x \<in> zEven) = (y \<in> zEven)"
+ then show "x - y \<in> zEven"
+ by (auto simp add: odd_iff_not_even even_minus_even odd_minus_odd
+ even_minus_odd odd_minus_even)
+qed
+
+lemma neg_one_even_power: "[| x \<in> zEven; 0 \<le> x |] ==> (-1::int)^(nat x) = 1"
+proof -
+ assume "x \<in> zEven" and "0 \<le> x"
+ from `x \<in> zEven` obtain a where "x = 2 * a" ..
+ with `0 \<le> x` have "0 \<le> a" by simp
+ from `0 \<le> x` and `x = 2 * a` have "nat x = nat (2 * a)"
+ by simp
+ also from `x = 2 * a` have "nat (2 * a) = 2 * nat a"
+ by (simp add: nat_mult_distrib)
+ finally have "(-1::int)^nat x = (-1)^(2 * nat a)"
+ by simp
+ also have "... = ((-1::int)^2)^ (nat a)"
+ by (simp add: zpower_zpower [symmetric])
+ also have "(-1::int)^2 = 1"
+ by simp
+ finally show ?thesis
+ by simp
+qed
+
+lemma neg_one_odd_power: "[| x \<in> zOdd; 0 \<le> x |] ==> (-1::int)^(nat x) = -1"
+proof -
+ assume "x \<in> zOdd" and "0 \<le> x"
+ from `x \<in> zOdd` obtain a where "x = 2 * a + 1" ..
+ with `0 \<le> x` have a: "0 \<le> a" by simp
+ with `0 \<le> x` and `x = 2 * a + 1` have "nat x = nat (2 * a + 1)"
+ by simp
+ also from a have "nat (2 * a + 1) = 2 * nat a + 1"
+ by (auto simp add: nat_mult_distrib nat_add_distrib)
+ finally have "(-1::int)^nat x = (-1)^(2 * nat a + 1)"
+ by simp
+ also have "... = ((-1::int)^2)^ (nat a) * (-1)^1"
+ by (auto simp add: zpower_zpower [symmetric] zpower_zadd_distrib)
+ also have "(-1::int)^2 = 1"
+ by simp
+ finally show ?thesis
+ by simp
+qed
+
+lemma neg_one_power_parity: "[| 0 \<le> x; 0 \<le> y; (x \<in> zEven) = (y \<in> zEven) |] ==>
+ (-1::int)^(nat x) = (-1::int)^(nat y)"
+ using even_odd_disj [of x] even_odd_disj [of y]
+ by (auto simp add: neg_one_even_power neg_one_odd_power)
+
+
+lemma one_not_neg_one_mod_m: "2 < m ==> ~([1 = -1] (mod m))"
+ by (auto simp add: zcong_def zdvd_not_zless)
+
+lemma even_div_2_l: "[| y \<in> zEven; x < y |] ==> x div 2 < y div 2"
+proof -
+ assume "y \<in> zEven" and "x < y"
+ from `y \<in> zEven` obtain k where k: "y = 2 * k" ..
+ with `x < y` have "x < 2 * k" by simp
+ then have "x div 2 < k" by (auto simp add: div_prop1)
+ also have "k = (2 * k) div 2" by simp
+ finally have "x div 2 < 2 * k div 2" by simp
+ with k show ?thesis by simp
+qed
+
+lemma even_sum_div_2: "[| x \<in> zEven; y \<in> zEven |] ==> (x + y) div 2 = x div 2 + y div 2"
+ by (auto simp add: zEven_def)
+
+lemma even_prod_div_2: "[| x \<in> zEven |] ==> (x * y) div 2 = (x div 2) * y"
+ by (auto simp add: zEven_def)
+
+(* An odd prime is greater than 2 *)
+
+lemma zprime_zOdd_eq_grt_2: "zprime p ==> (p \<in> zOdd) = (2 < p)"
+ apply (auto simp add: zOdd_def zprime_def)
+ apply (drule_tac x = 2 in allE)
+ using odd_iff_not_even [of p]
+ apply (auto simp add: zOdd_def zEven_def)
+ done
+
+(* Powers of -1 and parity *)
+
+lemma neg_one_special: "finite A ==>
+ ((-1 :: int) ^ card A) * (-1 ^ card A) = 1"
+ by (induct set: finite) auto
+
+lemma neg_one_power: "(-1::int)^n = 1 | (-1::int)^n = -1"
+ by (induct n) auto
+
+lemma neg_one_power_eq_mod_m: "[| 2 < m; [(-1::int)^j = (-1::int)^k] (mod m) |]
+ ==> ((-1::int)^j = (-1::int)^k)"
+ using neg_one_power [of j] and ListMem.insert neg_one_power [of k]
+ by (auto simp add: one_not_neg_one_mod_m zcong_sym)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Factorization.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,339 @@
+(* Author: Thomas Marthedal Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Fundamental Theorem of Arithmetic (unique factorization into primes) *}
+
+theory Factorization
+imports Main "~~/src/HOL/Old_Number_Theory/Primes" Permutation
+begin
+
+
+subsection {* Definitions *}
+
+definition
+ primel :: "nat list => bool" where
+ "primel xs = (\<forall>p \<in> set xs. prime p)"
+
+consts
+ nondec :: "nat list => bool "
+ prod :: "nat list => nat"
+ oinsert :: "nat => nat list => nat list"
+ sort :: "nat list => nat list"
+
+primrec
+ "nondec [] = True"
+ "nondec (x # xs) = (case xs of [] => True | y # ys => x \<le> y \<and> nondec xs)"
+
+primrec
+ "prod [] = Suc 0"
+ "prod (x # xs) = x * prod xs"
+
+primrec
+ "oinsert x [] = [x]"
+ "oinsert x (y # ys) = (if x \<le> y then x # y # ys else y # oinsert x ys)"
+
+primrec
+ "sort [] = []"
+ "sort (x # xs) = oinsert x (sort xs)"
+
+
+subsection {* Arithmetic *}
+
+lemma one_less_m: "(m::nat) \<noteq> m * k ==> m \<noteq> Suc 0 ==> Suc 0 < m"
+ apply (cases m)
+ apply auto
+ done
+
+lemma one_less_k: "(m::nat) \<noteq> m * k ==> Suc 0 < m * k ==> Suc 0 < k"
+ apply (cases k)
+ apply auto
+ done
+
+lemma mult_left_cancel: "(0::nat) < k ==> k * n = k * m ==> n = m"
+ apply auto
+ done
+
+lemma mn_eq_m_one: "(0::nat) < m ==> m * n = m ==> n = Suc 0"
+ apply (cases n)
+ apply auto
+ done
+
+lemma prod_mn_less_k:
+ "(0::nat) < n ==> 0 < k ==> Suc 0 < m ==> m * n = k ==> n < k"
+ apply (induct m)
+ apply auto
+ done
+
+
+subsection {* Prime list and product *}
+
+lemma prod_append: "prod (xs @ ys) = prod xs * prod ys"
+ apply (induct xs)
+ apply (simp_all add: mult_assoc)
+ done
+
+lemma prod_xy_prod:
+ "prod (x # xs) = prod (y # ys) ==> x * prod xs = y * prod ys"
+ apply auto
+ done
+
+lemma primel_append: "primel (xs @ ys) = (primel xs \<and> primel ys)"
+ apply (unfold primel_def)
+ apply auto
+ done
+
+lemma prime_primel: "prime n ==> primel [n] \<and> prod [n] = n"
+ apply (unfold primel_def)
+ apply auto
+ done
+
+lemma prime_nd_one: "prime p ==> \<not> p dvd Suc 0"
+ apply (unfold prime_def dvd_def)
+ apply auto
+ done
+
+lemma hd_dvd_prod: "prod (x # xs) = prod ys ==> x dvd (prod ys)"
+ by (metis dvd_mult_left dvd_refl prod.simps(2))
+
+lemma primel_tl: "primel (x # xs) ==> primel xs"
+ apply (unfold primel_def)
+ apply auto
+ done
+
+lemma primel_hd_tl: "(primel (x # xs)) = (prime x \<and> primel xs)"
+ apply (unfold primel_def)
+ apply auto
+ done
+
+lemma primes_eq: "prime p ==> prime q ==> p dvd q ==> p = q"
+ apply (unfold prime_def)
+ apply auto
+ done
+
+lemma primel_one_empty: "primel xs ==> prod xs = Suc 0 ==> xs = []"
+ apply (cases xs)
+ apply (simp_all add: primel_def prime_def)
+ done
+
+lemma prime_g_one: "prime p ==> Suc 0 < p"
+ apply (unfold prime_def)
+ apply auto
+ done
+
+lemma prime_g_zero: "prime p ==> 0 < p"
+ apply (unfold prime_def)
+ apply auto
+ done
+
+lemma primel_nempty_g_one:
+ "primel xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> Suc 0 < prod xs"
+ apply (induct xs)
+ apply simp
+ apply (fastsimp simp: primel_def prime_def elim: one_less_mult)
+ done
+
+lemma primel_prod_gz: "primel xs ==> 0 < prod xs"
+ apply (induct xs)
+ apply (auto simp: primel_def prime_def)
+ done
+
+
+subsection {* Sorting *}
+
+lemma nondec_oinsert: "nondec xs \<Longrightarrow> nondec (oinsert x xs)"
+ apply (induct xs)
+ apply simp
+ apply (case_tac xs)
+ apply (simp_all cong del: list.weak_case_cong)
+ done
+
+lemma nondec_sort: "nondec (sort xs)"
+ apply (induct xs)
+ apply simp_all
+ apply (erule nondec_oinsert)
+ done
+
+lemma x_less_y_oinsert: "x \<le> y ==> l = y # ys ==> x # l = oinsert x l"
+ apply simp_all
+ done
+
+lemma nondec_sort_eq [rule_format]: "nondec xs \<longrightarrow> xs = sort xs"
+ apply (induct xs)
+ apply safe
+ apply simp_all
+ apply (case_tac xs)
+ apply simp_all
+ apply (case_tac xs)
+ apply simp
+ apply (rule_tac y = aa and ys = list in x_less_y_oinsert)
+ apply simp_all
+ done
+
+lemma oinsert_x_y: "oinsert x (oinsert y l) = oinsert y (oinsert x l)"
+ apply (induct l)
+ apply auto
+ done
+
+
+subsection {* Permutation *}
+
+lemma perm_primel [rule_format]: "xs <~~> ys ==> primel xs --> primel ys"
+ apply (unfold primel_def)
+ apply (induct set: perm)
+ apply simp
+ apply simp
+ apply (simp (no_asm))
+ apply blast
+ apply blast
+ done
+
+lemma perm_prod: "xs <~~> ys ==> prod xs = prod ys"
+ apply (induct set: perm)
+ apply (simp_all add: mult_ac)
+ done
+
+lemma perm_subst_oinsert: "xs <~~> ys ==> oinsert a xs <~~> oinsert a ys"
+ apply (induct set: perm)
+ apply auto
+ done
+
+lemma perm_oinsert: "x # xs <~~> oinsert x xs"
+ apply (induct xs)
+ apply auto
+ done
+
+lemma perm_sort: "xs <~~> sort xs"
+ apply (induct xs)
+ apply (auto intro: perm_oinsert elim: perm_subst_oinsert)
+ done
+
+lemma perm_sort_eq: "xs <~~> ys ==> sort xs = sort ys"
+ apply (induct set: perm)
+ apply (simp_all add: oinsert_x_y)
+ done
+
+
+subsection {* Existence *}
+
+lemma ex_nondec_lemma:
+ "primel xs ==> \<exists>ys. primel ys \<and> nondec ys \<and> prod ys = prod xs"
+ apply (blast intro: nondec_sort perm_prod perm_primel perm_sort perm_sym)
+ done
+
+lemma not_prime_ex_mk:
+ "Suc 0 < n \<and> \<not> prime n ==>
+ \<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
+ apply (unfold prime_def dvd_def)
+ apply (auto intro: n_less_m_mult_n n_less_n_mult_m one_less_m one_less_k)
+ done
+
+lemma split_primel:
+ "primel xs \<Longrightarrow> primel ys \<Longrightarrow> \<exists>l. primel l \<and> prod l = prod xs * prod ys"
+ apply (rule exI)
+ apply safe
+ apply (rule_tac [2] prod_append)
+ apply (simp add: primel_append)
+ done
+
+lemma factor_exists [rule_format]: "Suc 0 < n --> (\<exists>l. primel l \<and> prod l = n)"
+ apply (induct n rule: nat_less_induct)
+ apply (rule impI)
+ apply (case_tac "prime n")
+ apply (rule exI)
+ apply (erule prime_primel)
+ apply (cut_tac n = n in not_prime_ex_mk)
+ apply (auto intro!: split_primel)
+ done
+
+lemma nondec_factor_exists: "Suc 0 < n ==> \<exists>l. primel l \<and> nondec l \<and> prod l = n"
+ apply (erule factor_exists [THEN exE])
+ apply (blast intro!: ex_nondec_lemma)
+ done
+
+
+subsection {* Uniqueness *}
+
+lemma prime_dvd_mult_list [rule_format]:
+ "prime p ==> p dvd (prod xs) --> (\<exists>m. m:set xs \<and> p dvd m)"
+ apply (induct xs)
+ apply (force simp add: prime_def)
+ apply (force dest: prime_dvd_mult)
+ done
+
+lemma hd_xs_dvd_prod:
+ "primel (x # xs) ==> primel ys ==> prod (x # xs) = prod ys
+ ==> \<exists>m. m \<in> set ys \<and> x dvd m"
+ apply (rule prime_dvd_mult_list)
+ apply (simp add: primel_hd_tl)
+ apply (erule hd_dvd_prod)
+ done
+
+lemma prime_dvd_eq: "primel (x # xs) ==> primel ys ==> m \<in> set ys ==> x dvd m ==> x = m"
+ apply (rule primes_eq)
+ apply (auto simp add: primel_def primel_hd_tl)
+ done
+
+lemma hd_xs_eq_prod:
+ "primel (x # xs) ==>
+ primel ys ==> prod (x # xs) = prod ys ==> x \<in> set ys"
+ apply (frule hd_xs_dvd_prod)
+ apply auto
+ apply (drule prime_dvd_eq)
+ apply auto
+ done
+
+lemma perm_primel_ex:
+ "primel (x # xs) ==>
+ primel ys ==> prod (x # xs) = prod ys ==> \<exists>l. ys <~~> (x # l)"
+ apply (rule exI)
+ apply (rule perm_remove)
+ apply (erule hd_xs_eq_prod)
+ apply simp_all
+ done
+
+lemma primel_prod_less:
+ "primel (x # xs) ==>
+ primel ys ==> prod (x # xs) = prod ys ==> prod xs < prod ys"
+ by (metis less_asym linorder_neqE_nat mult_less_cancel2 nat_0_less_mult_iff
+ nat_less_le nat_mult_1 prime_def primel_hd_tl primel_prod_gz prod.simps(2))
+
+lemma prod_one_empty:
+ "primel xs ==> p * prod xs = p ==> prime p ==> xs = []"
+ apply (auto intro: primel_one_empty simp add: prime_def)
+ done
+
+lemma uniq_ex_aux:
+ "\<forall>m. m < prod ys --> (\<forall>xs ys. primel xs \<and> primel ys \<and>
+ prod xs = prod ys \<and> prod xs = m --> xs <~~> ys) ==>
+ primel list ==> primel x ==> prod list = prod x ==> prod x < prod ys
+ ==> x <~~> list"
+ apply simp
+ done
+
+lemma factor_unique [rule_format]:
+ "\<forall>xs ys. primel xs \<and> primel ys \<and> prod xs = prod ys \<and> prod xs = n
+ --> xs <~~> ys"
+ apply (induct n rule: nat_less_induct)
+ apply safe
+ apply (case_tac xs)
+ apply (force intro: primel_one_empty)
+ apply (rule perm_primel_ex [THEN exE])
+ apply simp_all
+ apply (rule perm.trans [THEN perm_sym])
+ apply assumption
+ apply (rule perm.Cons)
+ apply (case_tac "x = []")
+ apply (metis perm_prod perm_refl prime_primel primel_hd_tl primel_tl prod_one_empty)
+ apply (metis nat_0_less_mult_iff nat_mult_eq_cancel1 perm_primel perm_prod primel_prod_gz primel_prod_less primel_tl prod.simps(2))
+ done
+
+lemma perm_nondec_unique:
+ "xs <~~> ys ==> nondec xs ==> nondec ys ==> xs = ys"
+ by (metis nondec_sort_eq perm_sort_eq)
+
+theorem unique_prime_factorization [rule_format]:
+ "\<forall>n. Suc 0 < n --> (\<exists>!l. primel l \<and> nondec l \<and> prod l = n)"
+ by (metis factor_unique nondec_factor_exists perm_nondec_unique)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Fib.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,150 @@
+(* ID: $Id$
+ Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1997 University of Cambridge
+*)
+
+header {* The Fibonacci function *}
+
+theory Fib
+imports Primes
+begin
+
+text {*
+ Fibonacci numbers: proofs of laws taken from:
+ R. L. Graham, D. E. Knuth, O. Patashnik. Concrete Mathematics.
+ (Addison-Wesley, 1989)
+
+ \bigskip
+*}
+
+fun fib :: "nat \<Rightarrow> nat"
+where
+ "fib 0 = 0"
+| "fib (Suc 0) = 1"
+| fib_2: "fib (Suc (Suc n)) = fib n + fib (Suc n)"
+
+text {*
+ \medskip The difficulty in these proofs is to ensure that the
+ induction hypotheses are applied before the definition of @{term
+ fib}. Towards this end, the @{term fib} equations are not declared
+ to the Simplifier and are applied very selectively at first.
+*}
+
+text{*We disable @{text fib.fib_2fib_2} for simplification ...*}
+declare fib_2 [simp del]
+
+text{*...then prove a version that has a more restrictive pattern.*}
+lemma fib_Suc3: "fib (Suc (Suc (Suc n))) = fib (Suc n) + fib (Suc (Suc n))"
+ by (rule fib_2)
+
+text {* \medskip Concrete Mathematics, page 280 *}
+
+lemma fib_add: "fib (Suc (n + k)) = fib (Suc k) * fib (Suc n) + fib k * fib n"
+proof (induct n rule: fib.induct)
+ case 1 show ?case by simp
+next
+ case 2 show ?case by (simp add: fib_2)
+next
+ case 3 thus ?case by (simp add: fib_2 add_mult_distrib2)
+qed
+
+lemma fib_Suc_neq_0: "fib (Suc n) \<noteq> 0"
+ apply (induct n rule: fib.induct)
+ apply (simp_all add: fib_2)
+ done
+
+lemma fib_Suc_gr_0: "0 < fib (Suc n)"
+ by (insert fib_Suc_neq_0 [of n], simp)
+
+lemma fib_gr_0: "0 < n ==> 0 < fib n"
+ by (case_tac n, auto simp add: fib_Suc_gr_0)
+
+
+text {*
+ \medskip Concrete Mathematics, page 278: Cassini's identity. The proof is
+ much easier using integers, not natural numbers!
+*}
+
+lemma fib_Cassini_int:
+ "int (fib (Suc (Suc n)) * fib n) =
+ (if n mod 2 = 0 then int (fib (Suc n) * fib (Suc n)) - 1
+ else int (fib (Suc n) * fib (Suc n)) + 1)"
+proof(induct n rule: fib.induct)
+ case 1 thus ?case by (simp add: fib_2)
+next
+ case 2 thus ?case by (simp add: fib_2 mod_Suc)
+next
+ case (3 x)
+ have "Suc 0 \<noteq> x mod 2 \<longrightarrow> x mod 2 = 0" by presburger
+ with "3.hyps" show ?case by (simp add: fib.simps add_mult_distrib add_mult_distrib2)
+qed
+
+text{*We now obtain a version for the natural numbers via the coercion
+ function @{term int}.*}
+theorem fib_Cassini:
+ "fib (Suc (Suc n)) * fib n =
+ (if n mod 2 = 0 then fib (Suc n) * fib (Suc n) - 1
+ else fib (Suc n) * fib (Suc n) + 1)"
+ apply (rule int_int_eq [THEN iffD1])
+ apply (simp add: fib_Cassini_int)
+ apply (subst zdiff_int [symmetric])
+ apply (insert fib_Suc_gr_0 [of n], simp_all)
+ done
+
+
+text {* \medskip Toward Law 6.111 of Concrete Mathematics *}
+
+lemma gcd_fib_Suc_eq_1: "gcd (fib n) (fib (Suc n)) = Suc 0"
+ apply (induct n rule: fib.induct)
+ prefer 3
+ apply (simp add: gcd_commute fib_Suc3)
+ apply (simp_all add: fib_2)
+ done
+
+lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
+ apply (simp add: gcd_commute [of "fib m"])
+ apply (case_tac m)
+ apply simp
+ apply (simp add: fib_add)
+ apply (simp add: add_commute gcd_non_0 [OF fib_Suc_gr_0])
+ apply (simp add: gcd_non_0 [OF fib_Suc_gr_0, symmetric])
+ apply (simp add: gcd_fib_Suc_eq_1 gcd_mult_cancel)
+ done
+
+lemma gcd_fib_diff: "m \<le> n ==> gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
+ by (simp add: gcd_fib_add [symmetric, of _ "n-m"])
+
+lemma gcd_fib_mod: "0 < m ==> gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+proof (induct n rule: less_induct)
+ case (less n)
+ from less.prems have pos_m: "0 < m" .
+ show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+ proof (cases "m < n")
+ case True note m_n = True
+ then have m_n': "m \<le> n" by auto
+ with pos_m have pos_n: "0 < n" by auto
+ with pos_m m_n have diff: "n - m < n" by auto
+ have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
+ by (simp add: mod_if [of n]) (insert m_n, auto)
+ also have "\<dots> = gcd (fib m) (fib (n - m))" by (simp add: less.hyps diff pos_m)
+ also have "\<dots> = gcd (fib m) (fib n)" by (simp add: gcd_fib_diff m_n')
+ finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
+ next
+ case False then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
+ by (cases "m = n") auto
+ qed
+qed
+
+lemma fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)" -- {* Law 6.111 *}
+ apply (induct m n rule: gcd_induct)
+ apply (simp_all add: gcd_non_0 gcd_commute gcd_fib_mod)
+ done
+
+theorem fib_mult_eq_setsum:
+ "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
+ apply (induct n rule: fib.induct)
+ apply (auto simp add: atMost_Suc fib_2)
+ apply (simp add: add_mult_distrib add_mult_distrib2)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Finite2.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,223 @@
+(* Title: HOL/Quadratic_Reciprocity/Finite2.thy
+ ID: $Id$
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {*Finite Sets and Finite Sums*}
+
+theory Finite2
+imports Main IntFact Infinite_Set
+begin
+
+text{*
+ These are useful for combinatorial and number-theoretic counting
+ arguments.
+*}
+
+
+subsection {* Useful properties of sums and products *}
+
+lemma setsum_same_function_zcong:
+ assumes a: "\<forall>x \<in> S. [f x = g x](mod m)"
+ shows "[setsum f S = setsum g S] (mod m)"
+proof cases
+ assume "finite S"
+ thus ?thesis using a by induct (simp_all add: zcong_zadd)
+next
+ assume "infinite S" thus ?thesis by(simp add:setsum_def)
+qed
+
+lemma setprod_same_function_zcong:
+ assumes a: "\<forall>x \<in> S. [f x = g x](mod m)"
+ shows "[setprod f S = setprod g S] (mod m)"
+proof cases
+ assume "finite S"
+ thus ?thesis using a by induct (simp_all add: zcong_zmult)
+next
+ assume "infinite S" thus ?thesis by(simp add:setprod_def)
+qed
+
+lemma setsum_const: "finite X ==> setsum (%x. (c :: int)) X = c * int(card X)"
+ apply (induct set: finite)
+ apply (auto simp add: left_distrib right_distrib int_eq_of_nat)
+ done
+
+lemma setsum_const2: "finite X ==> int (setsum (%x. (c :: nat)) X) =
+ int(c) * int(card X)"
+ apply (induct set: finite)
+ apply (auto simp add: zadd_zmult_distrib2)
+ done
+
+lemma setsum_const_mult: "finite A ==> setsum (%x. c * ((f x)::int)) A =
+ c * setsum f A"
+ by (induct set: finite) (auto simp add: zadd_zmult_distrib2)
+
+
+subsection {* Cardinality of explicit finite sets *}
+
+lemma finite_surjI: "[| B \<subseteq> f ` A; finite A |] ==> finite B"
+ by (simp add: finite_subset finite_imageI)
+
+lemma bdd_nat_set_l_finite: "finite {y::nat . y < x}"
+ by (rule bounded_nat_set_is_finite) blast
+
+lemma bdd_nat_set_le_finite: "finite {y::nat . y \<le> x}"
+proof -
+ have "{y::nat . y \<le> x} = {y::nat . y < Suc x}" by auto
+ then show ?thesis by (auto simp add: bdd_nat_set_l_finite)
+qed
+
+lemma bdd_int_set_l_finite: "finite {x::int. 0 \<le> x & x < n}"
+ apply (subgoal_tac " {(x :: int). 0 \<le> x & x < n} \<subseteq>
+ int ` {(x :: nat). x < nat n}")
+ apply (erule finite_surjI)
+ apply (auto simp add: bdd_nat_set_l_finite image_def)
+ apply (rule_tac x = "nat x" in exI, simp)
+ done
+
+lemma bdd_int_set_le_finite: "finite {x::int. 0 \<le> x & x \<le> n}"
+ apply (subgoal_tac "{x. 0 \<le> x & x \<le> n} = {x. 0 \<le> x & x < n + 1}")
+ apply (erule ssubst)
+ apply (rule bdd_int_set_l_finite)
+ apply auto
+ done
+
+lemma bdd_int_set_l_l_finite: "finite {x::int. 0 < x & x < n}"
+proof -
+ have "{x::int. 0 < x & x < n} \<subseteq> {x::int. 0 \<le> x & x < n}"
+ by auto
+ then show ?thesis by (auto simp add: bdd_int_set_l_finite finite_subset)
+qed
+
+lemma bdd_int_set_l_le_finite: "finite {x::int. 0 < x & x \<le> n}"
+proof -
+ have "{x::int. 0 < x & x \<le> n} \<subseteq> {x::int. 0 \<le> x & x \<le> n}"
+ by auto
+ then show ?thesis by (auto simp add: bdd_int_set_le_finite finite_subset)
+qed
+
+lemma card_bdd_nat_set_l: "card {y::nat . y < x} = x"
+proof (induct x)
+ case 0
+ show "card {y::nat . y < 0} = 0" by simp
+next
+ case (Suc n)
+ have "{y. y < Suc n} = insert n {y. y < n}"
+ by auto
+ then have "card {y. y < Suc n} = card (insert n {y. y < n})"
+ by auto
+ also have "... = Suc (card {y. y < n})"
+ by (rule card_insert_disjoint) (auto simp add: bdd_nat_set_l_finite)
+ finally show "card {y. y < Suc n} = Suc n"
+ using `card {y. y < n} = n` by simp
+qed
+
+lemma card_bdd_nat_set_le: "card { y::nat. y \<le> x} = Suc x"
+proof -
+ have "{y::nat. y \<le> x} = { y::nat. y < Suc x}"
+ by auto
+ then show ?thesis by (auto simp add: card_bdd_nat_set_l)
+qed
+
+lemma card_bdd_int_set_l: "0 \<le> (n::int) ==> card {y. 0 \<le> y & y < n} = nat n"
+proof -
+ assume "0 \<le> n"
+ have "inj_on (%y. int y) {y. y < nat n}"
+ by (auto simp add: inj_on_def)
+ hence "card (int ` {y. y < nat n}) = card {y. y < nat n}"
+ by (rule card_image)
+ also from `0 \<le> n` have "int ` {y. y < nat n} = {y. 0 \<le> y & y < n}"
+ apply (auto simp add: zless_nat_eq_int_zless image_def)
+ apply (rule_tac x = "nat x" in exI)
+ apply (auto simp add: nat_0_le)
+ done
+ also have "card {y. y < nat n} = nat n"
+ by (rule card_bdd_nat_set_l)
+ finally show "card {y. 0 \<le> y & y < n} = nat n" .
+qed
+
+lemma card_bdd_int_set_le: "0 \<le> (n::int) ==> card {y. 0 \<le> y & y \<le> n} =
+ nat n + 1"
+proof -
+ assume "0 \<le> n"
+ moreover have "{y. 0 \<le> y & y \<le> n} = {y. 0 \<le> y & y < n+1}" by auto
+ ultimately show ?thesis
+ using card_bdd_int_set_l [of "n + 1"]
+ by (auto simp add: nat_add_distrib)
+qed
+
+lemma card_bdd_int_set_l_le: "0 \<le> (n::int) ==>
+ card {x. 0 < x & x \<le> n} = nat n"
+proof -
+ assume "0 \<le> n"
+ have "inj_on (%x. x+1) {x. 0 \<le> x & x < n}"
+ by (auto simp add: inj_on_def)
+ hence "card ((%x. x+1) ` {x. 0 \<le> x & x < n}) =
+ card {x. 0 \<le> x & x < n}"
+ by (rule card_image)
+ also from `0 \<le> n` have "... = nat n"
+ by (rule card_bdd_int_set_l)
+ also have "(%x. x + 1) ` {x. 0 \<le> x & x < n} = {x. 0 < x & x<= n}"
+ apply (auto simp add: image_def)
+ apply (rule_tac x = "x - 1" in exI)
+ apply arith
+ done
+ finally show "card {x. 0 < x & x \<le> n} = nat n" .
+qed
+
+lemma card_bdd_int_set_l_l: "0 < (n::int) ==>
+ card {x. 0 < x & x < n} = nat n - 1"
+proof -
+ assume "0 < n"
+ moreover have "{x. 0 < x & x < n} = {x. 0 < x & x \<le> n - 1}"
+ by simp
+ ultimately show ?thesis
+ using insert card_bdd_int_set_l_le [of "n - 1"]
+ by (auto simp add: nat_diff_distrib)
+qed
+
+lemma int_card_bdd_int_set_l_l: "0 < n ==>
+ int(card {x. 0 < x & x < n}) = n - 1"
+ apply (auto simp add: card_bdd_int_set_l_l)
+ done
+
+lemma int_card_bdd_int_set_l_le: "0 \<le> n ==>
+ int(card {x. 0 < x & x \<le> n}) = n"
+ by (auto simp add: card_bdd_int_set_l_le)
+
+
+subsection {* Cardinality of finite cartesian products *}
+
+(* FIXME could be useful in general but not needed here
+lemma insert_Sigma [simp]: "(insert x A) <*> B = ({ x } <*> B) \<union> (A <*> B)"
+ by blast
+ *)
+
+text {* Lemmas for counting arguments. *}
+
+lemma setsum_bij_eq: "[| finite A; finite B; f ` A \<subseteq> B; inj_on f A;
+ g ` B \<subseteq> A; inj_on g B |] ==> setsum g B = setsum (g \<circ> f) A"
+ apply (frule_tac h = g and f = f in setsum_reindex)
+ apply (subgoal_tac "setsum g B = setsum g (f ` A)")
+ apply (simp add: inj_on_def)
+ apply (subgoal_tac "card A = card B")
+ apply (drule_tac A = "f ` A" and B = B in card_seteq)
+ apply (auto simp add: card_image)
+ apply (frule_tac A = A and B = B and f = f in card_inj_on_le, auto)
+ apply (frule_tac A = B and B = A and f = g in card_inj_on_le)
+ apply auto
+ done
+
+lemma setprod_bij_eq: "[| finite A; finite B; f ` A \<subseteq> B; inj_on f A;
+ g ` B \<subseteq> A; inj_on g B |] ==> setprod g B = setprod (g \<circ> f) A"
+ apply (frule_tac h = g and f = f in setprod_reindex)
+ apply (subgoal_tac "setprod g B = setprod g (f ` A)")
+ apply (simp add: inj_on_def)
+ apply (subgoal_tac "card A = card B")
+ apply (drule_tac A = "f ` A" and B = B in card_seteq)
+ apply (auto simp add: card_image)
+ apply (frule_tac A = A and B = B and f = f in card_inj_on_le, auto)
+ apply (frule_tac A = B and B = A and f = g in card_inj_on_le, auto)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Gauss.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,535 @@
+(* Title: HOL/Quadratic_Reciprocity/Gauss.thy
+ ID: $Id$
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer)
+*)
+
+header {* Gauss' Lemma *}
+
+theory Gauss
+imports Euler
+begin
+
+locale GAUSS =
+ fixes p :: "int"
+ fixes a :: "int"
+
+ assumes p_prime: "zprime p"
+ assumes p_g_2: "2 < p"
+ assumes p_a_relprime: "~[a = 0](mod p)"
+ assumes a_nonzero: "0 < a"
+begin
+
+definition
+ A :: "int set" where
+ "A = {(x::int). 0 < x & x \<le> ((p - 1) div 2)}"
+
+definition
+ B :: "int set" where
+ "B = (%x. x * a) ` A"
+
+definition
+ C :: "int set" where
+ "C = StandardRes p ` B"
+
+definition
+ D :: "int set" where
+ "D = C \<inter> {x. x \<le> ((p - 1) div 2)}"
+
+definition
+ E :: "int set" where
+ "E = C \<inter> {x. ((p - 1) div 2) < x}"
+
+definition
+ F :: "int set" where
+ "F = (%x. (p - x)) ` E"
+
+
+subsection {* Basic properties of p *}
+
+lemma p_odd: "p \<in> zOdd"
+ by (auto simp add: p_prime p_g_2 zprime_zOdd_eq_grt_2)
+
+lemma p_g_0: "0 < p"
+ using p_g_2 by auto
+
+lemma int_nat: "int (nat ((p - 1) div 2)) = (p - 1) div 2"
+ using ListMem.insert p_g_2 by (auto simp add: pos_imp_zdiv_nonneg_iff)
+
+lemma p_minus_one_l: "(p - 1) div 2 < p"
+proof -
+ have "(p - 1) div 2 \<le> (p - 1) div 1"
+ by (rule zdiv_mono2) (auto simp add: p_g_0)
+ also have "\<dots> = p - 1" by simp
+ finally show ?thesis by simp
+qed
+
+lemma p_eq: "p = (2 * (p - 1) div 2) + 1"
+ using div_mult_self1_is_id [of 2 "p - 1"] by auto
+
+
+lemma (in -) zodd_imp_zdiv_eq: "x \<in> zOdd ==> 2 * (x - 1) div 2 = 2 * ((x - 1) div 2)"
+ apply (frule odd_minus_one_even)
+ apply (simp add: zEven_def)
+ apply (subgoal_tac "2 \<noteq> 0")
+ apply (frule_tac b = "2 :: int" and a = "x - 1" in div_mult_self1_is_id)
+ apply (auto simp add: even_div_2_prop2)
+ done
+
+
+lemma p_eq2: "p = (2 * ((p - 1) div 2)) + 1"
+ apply (insert p_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 [of p], auto)
+ apply (frule zodd_imp_zdiv_eq, auto)
+ done
+
+
+subsection {* Basic Properties of the Gauss Sets *}
+
+lemma finite_A: "finite (A)"
+ apply (auto simp add: A_def)
+ apply (subgoal_tac "{x. 0 < x & x \<le> (p - 1) div 2} \<subseteq> {x. 0 \<le> x & x < 1 + (p - 1) div 2}")
+ apply (auto simp add: bdd_int_set_l_finite finite_subset)
+ done
+
+lemma finite_B: "finite (B)"
+ by (auto simp add: B_def finite_A finite_imageI)
+
+lemma finite_C: "finite (C)"
+ by (auto simp add: C_def finite_B finite_imageI)
+
+lemma finite_D: "finite (D)"
+ by (auto simp add: D_def finite_Int finite_C)
+
+lemma finite_E: "finite (E)"
+ by (auto simp add: E_def finite_Int finite_C)
+
+lemma finite_F: "finite (F)"
+ by (auto simp add: F_def finite_E finite_imageI)
+
+lemma C_eq: "C = D \<union> E"
+ by (auto simp add: C_def D_def E_def)
+
+lemma A_card_eq: "card A = nat ((p - 1) div 2)"
+ apply (auto simp add: A_def)
+ apply (insert int_nat)
+ apply (erule subst)
+ apply (auto simp add: card_bdd_int_set_l_le)
+ done
+
+lemma inj_on_xa_A: "inj_on (%x. x * a) A"
+ using a_nonzero by (simp add: A_def inj_on_def)
+
+lemma A_res: "ResSet p A"
+ apply (auto simp add: A_def ResSet_def)
+ apply (rule_tac m = p in zcong_less_eq)
+ apply (insert p_g_2, auto)
+ done
+
+lemma B_res: "ResSet p B"
+ apply (insert p_g_2 p_a_relprime p_minus_one_l)
+ apply (auto simp add: B_def)
+ apply (rule ResSet_image)
+ apply (auto simp add: A_res)
+ apply (auto simp add: A_def)
+proof -
+ fix x fix y
+ assume a: "[x * a = y * a] (mod p)"
+ assume b: "0 < x"
+ assume c: "x \<le> (p - 1) div 2"
+ assume d: "0 < y"
+ assume e: "y \<le> (p - 1) div 2"
+ from a p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
+ have "[x = y](mod p)"
+ by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
+ with zcong_less_eq [of x y p] p_minus_one_l
+ order_le_less_trans [of x "(p - 1) div 2" p]
+ order_le_less_trans [of y "(p - 1) div 2" p] show "x = y"
+ by (simp add: prems p_minus_one_l p_g_0)
+qed
+
+lemma SR_B_inj: "inj_on (StandardRes p) B"
+ apply (auto simp add: B_def StandardRes_def inj_on_def A_def prems)
+proof -
+ fix x fix y
+ assume a: "x * a mod p = y * a mod p"
+ assume b: "0 < x"
+ assume c: "x \<le> (p - 1) div 2"
+ assume d: "0 < y"
+ assume e: "y \<le> (p - 1) div 2"
+ assume f: "x \<noteq> y"
+ from a have "[x * a = y * a](mod p)"
+ by (simp add: zcong_zmod_eq p_g_0)
+ with p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
+ have "[x = y](mod p)"
+ by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
+ with zcong_less_eq [of x y p] p_minus_one_l
+ order_le_less_trans [of x "(p - 1) div 2" p]
+ order_le_less_trans [of y "(p - 1) div 2" p] have "x = y"
+ by (simp add: prems p_minus_one_l p_g_0)
+ then have False
+ by (simp add: f)
+ then show "a = 0"
+ by simp
+qed
+
+lemma inj_on_pminusx_E: "inj_on (%x. p - x) E"
+ apply (auto simp add: E_def C_def B_def A_def)
+ apply (rule_tac g = "%x. -1 * (x - p)" in inj_on_inverseI)
+ apply auto
+ done
+
+lemma A_ncong_p: "x \<in> A ==> ~[x = 0](mod p)"
+ apply (auto simp add: A_def)
+ apply (frule_tac m = p in zcong_not_zero)
+ apply (insert p_minus_one_l)
+ apply auto
+ done
+
+lemma A_greater_zero: "x \<in> A ==> 0 < x"
+ by (auto simp add: A_def)
+
+lemma B_ncong_p: "x \<in> B ==> ~[x = 0](mod p)"
+ apply (auto simp add: B_def)
+ apply (frule A_ncong_p)
+ apply (insert p_a_relprime p_prime a_nonzero)
+ apply (frule_tac a = x and b = a in zcong_zprime_prod_zero_contra)
+ apply (auto simp add: A_greater_zero)
+ done
+
+lemma B_greater_zero: "x \<in> B ==> 0 < x"
+ using a_nonzero by (auto simp add: B_def mult_pos_pos A_greater_zero)
+
+lemma C_ncong_p: "x \<in> C ==> ~[x = 0](mod p)"
+ apply (auto simp add: C_def)
+ apply (frule B_ncong_p)
+ apply (subgoal_tac "[x = StandardRes p x](mod p)")
+ defer apply (simp add: StandardRes_prop1)
+ apply (frule_tac a = x and b = "StandardRes p x" and c = 0 in zcong_trans)
+ apply auto
+ done
+
+lemma C_greater_zero: "y \<in> C ==> 0 < y"
+ apply (auto simp add: C_def)
+proof -
+ fix x
+ assume a: "x \<in> B"
+ from p_g_0 have "0 \<le> StandardRes p x"
+ by (simp add: StandardRes_lbound)
+ moreover have "~[x = 0] (mod p)"
+ by (simp add: a B_ncong_p)
+ then have "StandardRes p x \<noteq> 0"
+ by (simp add: StandardRes_prop3)
+ ultimately show "0 < StandardRes p x"
+ by (simp add: order_le_less)
+qed
+
+lemma D_ncong_p: "x \<in> D ==> ~[x = 0](mod p)"
+ by (auto simp add: D_def C_ncong_p)
+
+lemma E_ncong_p: "x \<in> E ==> ~[x = 0](mod p)"
+ by (auto simp add: E_def C_ncong_p)
+
+lemma F_ncong_p: "x \<in> F ==> ~[x = 0](mod p)"
+ apply (auto simp add: F_def)
+proof -
+ fix x assume a: "x \<in> E" assume b: "[p - x = 0] (mod p)"
+ from E_ncong_p have "~[x = 0] (mod p)"
+ by (simp add: a)
+ moreover from a have "0 < x"
+ by (simp add: a E_def C_greater_zero)
+ moreover from a have "x < p"
+ by (auto simp add: E_def C_def p_g_0 StandardRes_ubound)
+ ultimately have "~[p - x = 0] (mod p)"
+ by (simp add: zcong_not_zero)
+ from this show False by (simp add: b)
+qed
+
+lemma F_subset: "F \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
+ apply (auto simp add: F_def E_def)
+ apply (insert p_g_0)
+ apply (frule_tac x = xa in StandardRes_ubound)
+ apply (frule_tac x = x in StandardRes_ubound)
+ apply (subgoal_tac "xa = StandardRes p xa")
+ apply (auto simp add: C_def StandardRes_prop2 StandardRes_prop1)
+proof -
+ from zodd_imp_zdiv_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 have
+ "2 * (p - 1) div 2 = 2 * ((p - 1) div 2)"
+ by simp
+ with p_eq2 show " !!x. [| (p - 1) div 2 < StandardRes p x; x \<in> B |]
+ ==> p - StandardRes p x \<le> (p - 1) div 2"
+ by simp
+qed
+
+lemma D_subset: "D \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
+ by (auto simp add: D_def C_greater_zero)
+
+lemma F_eq: "F = {x. \<exists>y \<in> A. ( x = p - (StandardRes p (y*a)) & (p - 1) div 2 < StandardRes p (y*a))}"
+ by (auto simp add: F_def E_def D_def C_def B_def A_def)
+
+lemma D_eq: "D = {x. \<exists>y \<in> A. ( x = StandardRes p (y*a) & StandardRes p (y*a) \<le> (p - 1) div 2)}"
+ by (auto simp add: D_def C_def B_def A_def)
+
+lemma D_leq: "x \<in> D ==> x \<le> (p - 1) div 2"
+ by (auto simp add: D_eq)
+
+lemma F_ge: "x \<in> F ==> x \<le> (p - 1) div 2"
+ apply (auto simp add: F_eq A_def)
+proof -
+ fix y
+ assume "(p - 1) div 2 < StandardRes p (y * a)"
+ then have "p - StandardRes p (y * a) < p - ((p - 1) div 2)"
+ by arith
+ also from p_eq2 have "... = 2 * ((p - 1) div 2) + 1 - ((p - 1) div 2)"
+ by auto
+ also have "2 * ((p - 1) div 2) + 1 - (p - 1) div 2 = (p - 1) div 2 + 1"
+ by arith
+ finally show "p - StandardRes p (y * a) \<le> (p - 1) div 2"
+ using zless_add1_eq [of "p - StandardRes p (y * a)" "(p - 1) div 2"] by auto
+qed
+
+lemma all_A_relprime: "\<forall>x \<in> A. zgcd x p = 1"
+ using p_prime p_minus_one_l by (auto simp add: A_def zless_zprime_imp_zrelprime)
+
+lemma A_prod_relprime: "zgcd (setprod id A) p = 1"
+by(rule all_relprime_prod_relprime[OF finite_A all_A_relprime])
+
+
+subsection {* Relationships Between Gauss Sets *}
+
+lemma B_card_eq_A: "card B = card A"
+ using finite_A by (simp add: finite_A B_def inj_on_xa_A card_image)
+
+lemma B_card_eq: "card B = nat ((p - 1) div 2)"
+ by (simp add: B_card_eq_A A_card_eq)
+
+lemma F_card_eq_E: "card F = card E"
+ using finite_E by (simp add: F_def inj_on_pminusx_E card_image)
+
+lemma C_card_eq_B: "card C = card B"
+ apply (insert finite_B)
+ apply (subgoal_tac "inj_on (StandardRes p) B")
+ apply (simp add: B_def C_def card_image)
+ apply (rule StandardRes_inj_on_ResSet)
+ apply (simp add: B_res)
+ done
+
+lemma D_E_disj: "D \<inter> E = {}"
+ by (auto simp add: D_def E_def)
+
+lemma C_card_eq_D_plus_E: "card C = card D + card E"
+ by (auto simp add: C_eq card_Un_disjoint D_E_disj finite_D finite_E)
+
+lemma C_prod_eq_D_times_E: "setprod id E * setprod id D = setprod id C"
+ apply (insert D_E_disj finite_D finite_E C_eq)
+ apply (frule setprod_Un_disjoint [of D E id])
+ apply auto
+ done
+
+lemma C_B_zcong_prod: "[setprod id C = setprod id B] (mod p)"
+ apply (auto simp add: C_def)
+ apply (insert finite_B SR_B_inj)
+ apply (frule_tac f = "StandardRes p" in setprod_reindex_id [symmetric], auto)
+ apply (rule setprod_same_function_zcong)
+ apply (auto simp add: StandardRes_prop1 zcong_sym p_g_0)
+ done
+
+lemma F_Un_D_subset: "(F \<union> D) \<subseteq> A"
+ apply (rule Un_least)
+ apply (auto simp add: A_def F_subset D_subset)
+ done
+
+lemma F_D_disj: "(F \<inter> D) = {}"
+ apply (simp add: F_eq D_eq)
+ apply (auto simp add: F_eq D_eq)
+proof -
+ fix y fix ya
+ assume "p - StandardRes p (y * a) = StandardRes p (ya * a)"
+ then have "p = StandardRes p (y * a) + StandardRes p (ya * a)"
+ by arith
+ moreover have "p dvd p"
+ by auto
+ ultimately have "p dvd (StandardRes p (y * a) + StandardRes p (ya * a))"
+ by auto
+ then have a: "[StandardRes p (y * a) + StandardRes p (ya * a) = 0] (mod p)"
+ by (auto simp add: zcong_def)
+ have "[y * a = StandardRes p (y * a)] (mod p)"
+ by (simp only: zcong_sym StandardRes_prop1)
+ moreover have "[ya * a = StandardRes p (ya * a)] (mod p)"
+ by (simp only: zcong_sym StandardRes_prop1)
+ ultimately have "[y * a + ya * a =
+ StandardRes p (y * a) + StandardRes p (ya * a)] (mod p)"
+ by (rule zcong_zadd)
+ with a have "[y * a + ya * a = 0] (mod p)"
+ apply (elim zcong_trans)
+ by (simp only: zcong_refl)
+ also have "y * a + ya * a = a * (y + ya)"
+ by (simp add: zadd_zmult_distrib2 zmult_commute)
+ finally have "[a * (y + ya) = 0] (mod p)" .
+ with p_prime a_nonzero zcong_zprime_prod_zero [of p a "y + ya"]
+ p_a_relprime
+ have a: "[y + ya = 0] (mod p)"
+ by auto
+ assume b: "y \<in> A" and c: "ya: A"
+ with A_def have "0 < y + ya"
+ by auto
+ moreover from b c A_def have "y + ya \<le> (p - 1) div 2 + (p - 1) div 2"
+ by auto
+ moreover from b c p_eq2 A_def have "y + ya < p"
+ by auto
+ ultimately show False
+ apply simp
+ apply (frule_tac m = p in zcong_not_zero)
+ apply (auto simp add: a)
+ done
+qed
+
+lemma F_Un_D_card: "card (F \<union> D) = nat ((p - 1) div 2)"
+proof -
+ have "card (F \<union> D) = card E + card D"
+ by (auto simp add: finite_F finite_D F_D_disj
+ card_Un_disjoint F_card_eq_E)
+ then have "card (F \<union> D) = card C"
+ by (simp add: C_card_eq_D_plus_E)
+ from this show "card (F \<union> D) = nat ((p - 1) div 2)"
+ by (simp add: C_card_eq_B B_card_eq)
+qed
+
+lemma F_Un_D_eq_A: "F \<union> D = A"
+ using finite_A F_Un_D_subset A_card_eq F_Un_D_card by (auto simp add: card_seteq)
+
+lemma prod_D_F_eq_prod_A:
+ "(setprod id D) * (setprod id F) = setprod id A"
+ apply (insert F_D_disj finite_D finite_F)
+ apply (frule setprod_Un_disjoint [of F D id])
+ apply (auto simp add: F_Un_D_eq_A)
+ done
+
+lemma prod_F_zcong:
+ "[setprod id F = ((-1) ^ (card E)) * (setprod id E)] (mod p)"
+proof -
+ have "setprod id F = setprod id (op - p ` E)"
+ by (auto simp add: F_def)
+ then have "setprod id F = setprod (op - p) E"
+ apply simp
+ apply (insert finite_E inj_on_pminusx_E)
+ apply (frule_tac f = "op - p" in setprod_reindex_id, auto)
+ done
+ then have one:
+ "[setprod id F = setprod (StandardRes p o (op - p)) E] (mod p)"
+ apply simp
+ apply (insert p_g_0 finite_E StandardRes_prod)
+ by (auto)
+ moreover have a: "\<forall>x \<in> E. [p - x = 0 - x] (mod p)"
+ apply clarify
+ apply (insert zcong_id [of p])
+ apply (rule_tac a = p and m = p and c = x and d = x in zcong_zdiff, auto)
+ done
+ moreover have b: "\<forall>x \<in> E. [StandardRes p (p - x) = p - x](mod p)"
+ apply clarify
+ apply (simp add: StandardRes_prop1 zcong_sym)
+ done
+ moreover have "\<forall>x \<in> E. [StandardRes p (p - x) = - x](mod p)"
+ apply clarify
+ apply (insert a b)
+ apply (rule_tac b = "p - x" in zcong_trans, auto)
+ done
+ ultimately have c:
+ "[setprod (StandardRes p o (op - p)) E = setprod (uminus) E](mod p)"
+ apply simp
+ using finite_E p_g_0
+ setprod_same_function_zcong [of E "StandardRes p o (op - p)" uminus p]
+ by auto
+ then have two: "[setprod id F = setprod (uminus) E](mod p)"
+ apply (insert one c)
+ apply (rule zcong_trans [of "setprod id F"
+ "setprod (StandardRes p o op - p) E" p
+ "setprod uminus E"], auto)
+ done
+ also have "setprod uminus E = (setprod id E) * (-1)^(card E)"
+ using finite_E by (induct set: finite) auto
+ then have "setprod uminus E = (-1) ^ (card E) * (setprod id E)"
+ by (simp add: zmult_commute)
+ with two show ?thesis
+ by simp
+qed
+
+
+subsection {* Gauss' Lemma *}
+
+lemma aux: "setprod id A * -1 ^ card E * a ^ card A * -1 ^ card E = setprod id A * a ^ card A"
+ by (auto simp add: finite_E neg_one_special)
+
+theorem pre_gauss_lemma:
+ "[a ^ nat((p - 1) div 2) = (-1) ^ (card E)] (mod p)"
+proof -
+ have "[setprod id A = setprod id F * setprod id D](mod p)"
+ by (auto simp add: prod_D_F_eq_prod_A zmult_commute cong del:setprod_cong)
+ then have "[setprod id A = ((-1)^(card E) * setprod id E) *
+ setprod id D] (mod p)"
+ apply (rule zcong_trans)
+ apply (auto simp add: prod_F_zcong zcong_scalar cong del: setprod_cong)
+ done
+ then have "[setprod id A = ((-1)^(card E) * setprod id C)] (mod p)"
+ apply (rule zcong_trans)
+ apply (insert C_prod_eq_D_times_E, erule subst)
+ apply (subst zmult_assoc, auto)
+ done
+ then have "[setprod id A = ((-1)^(card E) * setprod id B)] (mod p)"
+ apply (rule zcong_trans)
+ apply (simp add: C_B_zcong_prod zcong_scalar2 cong del:setprod_cong)
+ done
+ then have "[setprod id A = ((-1)^(card E) *
+ (setprod id ((%x. x * a) ` A)))] (mod p)"
+ by (simp add: B_def)
+ then have "[setprod id A = ((-1)^(card E) * (setprod (%x. x * a) A))]
+ (mod p)"
+ by (simp add:finite_A inj_on_xa_A setprod_reindex_id[symmetric] cong del:setprod_cong)
+ moreover have "setprod (%x. x * a) A =
+ setprod (%x. a) A * setprod id A"
+ using finite_A by (induct set: finite) auto
+ ultimately have "[setprod id A = ((-1)^(card E) * (setprod (%x. a) A *
+ setprod id A))] (mod p)"
+ by simp
+ then have "[setprod id A = ((-1)^(card E) * a^(card A) *
+ setprod id A)](mod p)"
+ apply (rule zcong_trans)
+ apply (simp add: zcong_scalar2 zcong_scalar finite_A setprod_constant zmult_assoc)
+ done
+ then have a: "[setprod id A * (-1)^(card E) =
+ ((-1)^(card E) * a^(card A) * setprod id A * (-1)^(card E))](mod p)"
+ by (rule zcong_scalar)
+ then have "[setprod id A * (-1)^(card E) = setprod id A *
+ (-1)^(card E) * a^(card A) * (-1)^(card E)](mod p)"
+ apply (rule zcong_trans)
+ apply (simp add: a mult_commute mult_left_commute)
+ done
+ then have "[setprod id A * (-1)^(card E) = setprod id A *
+ a^(card A)](mod p)"
+ apply (rule zcong_trans)
+ apply (simp add: aux cong del:setprod_cong)
+ done
+ with this zcong_cancel2 [of p "setprod id A" "-1 ^ card E" "a ^ card A"]
+ p_g_0 A_prod_relprime have "[-1 ^ card E = a ^ card A](mod p)"
+ by (simp add: order_less_imp_le)
+ from this show ?thesis
+ by (simp add: A_card_eq zcong_sym)
+qed
+
+theorem gauss_lemma: "(Legendre a p) = (-1) ^ (card E)"
+proof -
+ from Euler_Criterion p_prime p_g_2 have
+ "[(Legendre a p) = a^(nat (((p) - 1) div 2))] (mod p)"
+ by auto
+ moreover note pre_gauss_lemma
+ ultimately have "[(Legendre a p) = (-1) ^ (card E)] (mod p)"
+ by (rule zcong_trans)
+ moreover from p_a_relprime have "(Legendre a p) = 1 | (Legendre a p) = (-1)"
+ by (auto simp add: Legendre_def)
+ moreover have "(-1::int) ^ (card E) = 1 | (-1::int) ^ (card E) = -1"
+ by (rule neg_one_power)
+ ultimately show ?thesis
+ by (auto simp add: p_g_2 one_not_neg_one_mod_m zcong_sym)
+qed
+
+end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Int2.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,299 @@
+(* Title: HOL/Quadratic_Reciprocity/Gauss.thy
+ ID: $Id$
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {*Integers: Divisibility and Congruences*}
+
+theory Int2
+imports Finite2 WilsonRuss
+begin
+
+definition
+ MultInv :: "int => int => int" where
+ "MultInv p x = x ^ nat (p - 2)"
+
+
+subsection {* Useful lemmas about dvd and powers *}
+
+lemma zpower_zdvd_prop1:
+ "0 < n \<Longrightarrow> p dvd y \<Longrightarrow> p dvd ((y::int) ^ n)"
+ by (induct n) (auto simp add: dvd_mult2 [of p y])
+
+lemma zdvd_bounds: "n dvd m ==> m \<le> (0::int) | n \<le> m"
+proof -
+ assume "n dvd m"
+ then have "~(0 < m & m < n)"
+ using zdvd_not_zless [of m n] by auto
+ then show ?thesis by auto
+qed
+
+lemma zprime_zdvd_zmult_better: "[| zprime p; p dvd (m * n) |] ==>
+ (p dvd m) | (p dvd n)"
+ apply (cases "0 \<le> m")
+ apply (simp add: zprime_zdvd_zmult)
+ apply (insert zprime_zdvd_zmult [of "-m" p n])
+ apply auto
+ done
+
+lemma zpower_zdvd_prop2:
+ "zprime p \<Longrightarrow> p dvd ((y::int) ^ n) \<Longrightarrow> 0 < n \<Longrightarrow> p dvd y"
+ apply (induct n)
+ apply simp
+ apply (frule zprime_zdvd_zmult_better)
+ apply simp
+ apply (force simp del:dvd_mult)
+ done
+
+lemma div_prop1: "[| 0 < z; (x::int) < y * z |] ==> x div z < y"
+proof -
+ assume "0 < z" then have modth: "x mod z \<ge> 0" by simp
+ have "(x div z) * z \<le> (x div z) * z" by simp
+ then have "(x div z) * z \<le> (x div z) * z + x mod z" using modth by arith
+ also have "\<dots> = x"
+ by (auto simp add: zmod_zdiv_equality [symmetric] zmult_ac)
+ also assume "x < y * z"
+ finally show ?thesis
+ by (auto simp add: prems mult_less_cancel_right, insert prems, arith)
+qed
+
+lemma div_prop2: "[| 0 < z; (x::int) < (y * z) + z |] ==> x div z \<le> y"
+proof -
+ assume "0 < z" and "x < (y * z) + z"
+ then have "x < (y + 1) * z" by (auto simp add: int_distrib)
+ then have "x div z < y + 1"
+ apply -
+ apply (rule_tac y = "y + 1" in div_prop1)
+ apply (auto simp add: prems)
+ done
+ then show ?thesis by auto
+qed
+
+lemma zdiv_leq_prop: "[| 0 < y |] ==> y * (x div y) \<le> (x::int)"
+proof-
+ assume "0 < y"
+ from zmod_zdiv_equality have "x = y * (x div y) + x mod y" by auto
+ moreover have "0 \<le> x mod y"
+ by (auto simp add: prems pos_mod_sign)
+ ultimately show ?thesis
+ by arith
+qed
+
+
+subsection {* Useful properties of congruences *}
+
+lemma zcong_eq_zdvd_prop: "[x = 0](mod p) = (p dvd x)"
+ by (auto simp add: zcong_def)
+
+lemma zcong_id: "[m = 0] (mod m)"
+ by (auto simp add: zcong_def)
+
+lemma zcong_shift: "[a = b] (mod m) ==> [a + c = b + c] (mod m)"
+ by (auto simp add: zcong_refl zcong_zadd)
+
+lemma zcong_zpower: "[x = y](mod m) ==> [x^z = y^z](mod m)"
+ by (induct z) (auto simp add: zcong_zmult)
+
+lemma zcong_eq_trans: "[| [a = b](mod m); b = c; [c = d](mod m) |] ==>
+ [a = d](mod m)"
+ apply (erule zcong_trans)
+ apply simp
+ done
+
+lemma aux1: "a - b = (c::int) ==> a = c + b"
+ by auto
+
+lemma zcong_zmult_prop1: "[a = b](mod m) ==> ([c = a * d](mod m) =
+ [c = b * d] (mod m))"
+ apply (auto simp add: zcong_def dvd_def)
+ apply (rule_tac x = "ka + k * d" in exI)
+ apply (drule aux1)+
+ apply (auto simp add: int_distrib)
+ apply (rule_tac x = "ka - k * d" in exI)
+ apply (drule aux1)+
+ apply (auto simp add: int_distrib)
+ done
+
+lemma zcong_zmult_prop2: "[a = b](mod m) ==>
+ ([c = d * a](mod m) = [c = d * b] (mod m))"
+ by (auto simp add: zmult_ac zcong_zmult_prop1)
+
+lemma zcong_zmult_prop3: "[| zprime p; ~[x = 0] (mod p);
+ ~[y = 0] (mod p) |] ==> ~[x * y = 0] (mod p)"
+ apply (auto simp add: zcong_def)
+ apply (drule zprime_zdvd_zmult_better, auto)
+ done
+
+lemma zcong_less_eq: "[| 0 < x; 0 < y; 0 < m; [x = y] (mod m);
+ x < m; y < m |] ==> x = y"
+ by (metis zcong_not zcong_sym zless_linear)
+
+lemma zcong_neg_1_impl_ne_1: "[| 2 < p; [x = -1] (mod p) |] ==>
+ ~([x = 1] (mod p))"
+proof
+ assume "2 < p" and "[x = 1] (mod p)" and "[x = -1] (mod p)"
+ then have "[1 = -1] (mod p)"
+ apply (auto simp add: zcong_sym)
+ apply (drule zcong_trans, auto)
+ done
+ then have "[1 + 1 = -1 + 1] (mod p)"
+ by (simp only: zcong_shift)
+ then have "[2 = 0] (mod p)"
+ by auto
+ then have "p dvd 2"
+ by (auto simp add: dvd_def zcong_def)
+ with prems show False
+ by (auto simp add: zdvd_not_zless)
+qed
+
+lemma zcong_zero_equiv_div: "[a = 0] (mod m) = (m dvd a)"
+ by (auto simp add: zcong_def)
+
+lemma zcong_zprime_prod_zero: "[| zprime p; 0 < a |] ==>
+ [a * b = 0] (mod p) ==> [a = 0] (mod p) | [b = 0] (mod p)"
+ by (auto simp add: zcong_zero_equiv_div zprime_zdvd_zmult)
+
+lemma zcong_zprime_prod_zero_contra: "[| zprime p; 0 < a |] ==>
+ ~[a = 0](mod p) & ~[b = 0](mod p) ==> ~[a * b = 0] (mod p)"
+ apply auto
+ apply (frule_tac a = a and b = b and p = p in zcong_zprime_prod_zero)
+ apply auto
+ done
+
+lemma zcong_not_zero: "[| 0 < x; x < m |] ==> ~[x = 0] (mod m)"
+ by (auto simp add: zcong_zero_equiv_div zdvd_not_zless)
+
+lemma zcong_zero: "[| 0 \<le> x; x < m; [x = 0](mod m) |] ==> x = 0"
+ apply (drule order_le_imp_less_or_eq, auto)
+ apply (frule_tac m = m in zcong_not_zero)
+ apply auto
+ done
+
+lemma all_relprime_prod_relprime: "[| finite A; \<forall>x \<in> A. zgcd x y = 1 |]
+ ==> zgcd (setprod id A) y = 1"
+ by (induct set: finite) (auto simp add: zgcd_zgcd_zmult)
+
+
+subsection {* Some properties of MultInv *}
+
+lemma MultInv_prop1: "[| 2 < p; [x = y] (mod p) |] ==>
+ [(MultInv p x) = (MultInv p y)] (mod p)"
+ by (auto simp add: MultInv_def zcong_zpower)
+
+lemma MultInv_prop2: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
+ [(x * (MultInv p x)) = 1] (mod p)"
+proof (simp add: MultInv_def zcong_eq_zdvd_prop)
+ assume "2 < p" and "zprime p" and "~ p dvd x"
+ have "x * x ^ nat (p - 2) = x ^ (nat (p - 2) + 1)"
+ by auto
+ also from prems have "nat (p - 2) + 1 = nat (p - 2 + 1)"
+ by (simp only: nat_add_distrib)
+ also have "p - 2 + 1 = p - 1" by arith
+ finally have "[x * x ^ nat (p - 2) = x ^ nat (p - 1)] (mod p)"
+ by (rule ssubst, auto)
+ also from prems have "[x ^ nat (p - 1) = 1] (mod p)"
+ by (auto simp add: Little_Fermat)
+ finally (zcong_trans) show "[x * x ^ nat (p - 2) = 1] (mod p)" .
+qed
+
+lemma MultInv_prop2a: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
+ [(MultInv p x) * x = 1] (mod p)"
+ by (auto simp add: MultInv_prop2 zmult_ac)
+
+lemma aux_1: "2 < p ==> ((nat p) - 2) = (nat (p - 2))"
+ by (simp add: nat_diff_distrib)
+
+lemma aux_2: "2 < p ==> 0 < nat (p - 2)"
+ by auto
+
+lemma MultInv_prop3: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
+ ~([MultInv p x = 0](mod p))"
+ apply (auto simp add: MultInv_def zcong_eq_zdvd_prop aux_1)
+ apply (drule aux_2)
+ apply (drule zpower_zdvd_prop2, auto)
+ done
+
+lemma aux__1: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
+ [(MultInv p (MultInv p x)) = (x * (MultInv p x) *
+ (MultInv p (MultInv p x)))] (mod p)"
+ apply (drule MultInv_prop2, auto)
+ apply (drule_tac k = "MultInv p (MultInv p x)" in zcong_scalar, auto)
+ apply (auto simp add: zcong_sym)
+ done
+
+lemma aux__2: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
+ [(x * (MultInv p x) * (MultInv p (MultInv p x))) = x] (mod p)"
+ apply (frule MultInv_prop3, auto)
+ apply (insert MultInv_prop2 [of p "MultInv p x"], auto)
+ apply (drule MultInv_prop2, auto)
+ apply (drule_tac k = x in zcong_scalar2, auto)
+ apply (auto simp add: zmult_ac)
+ done
+
+lemma MultInv_prop4: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
+ [(MultInv p (MultInv p x)) = x] (mod p)"
+ apply (frule aux__1, auto)
+ apply (drule aux__2, auto)
+ apply (drule zcong_trans, auto)
+ done
+
+lemma MultInv_prop5: "[| 2 < p; zprime p; ~([x = 0](mod p));
+ ~([y = 0](mod p)); [(MultInv p x) = (MultInv p y)] (mod p) |] ==>
+ [x = y] (mod p)"
+ apply (drule_tac a = "MultInv p x" and b = "MultInv p y" and
+ m = p and k = x in zcong_scalar)
+ apply (insert MultInv_prop2 [of p x], simp)
+ apply (auto simp only: zcong_sym [of "MultInv p x * x"])
+ apply (auto simp add: zmult_ac)
+ apply (drule zcong_trans, auto)
+ apply (drule_tac a = "x * MultInv p y" and k = y in zcong_scalar, auto)
+ apply (insert MultInv_prop2a [of p y], auto simp add: zmult_ac)
+ apply (insert zcong_zmult_prop2 [of "y * MultInv p y" 1 p y x])
+ apply (auto simp add: zcong_sym)
+ done
+
+lemma MultInv_zcong_prop1: "[| 2 < p; [j = k] (mod p) |] ==>
+ [a * MultInv p j = a * MultInv p k] (mod p)"
+ by (drule MultInv_prop1, auto simp add: zcong_scalar2)
+
+lemma aux___1: "[j = a * MultInv p k] (mod p) ==>
+ [j * k = a * MultInv p k * k] (mod p)"
+ by (auto simp add: zcong_scalar)
+
+lemma aux___2: "[|2 < p; zprime p; ~([k = 0](mod p));
+ [j * k = a * MultInv p k * k] (mod p) |] ==> [j * k = a] (mod p)"
+ apply (insert MultInv_prop2a [of p k] zcong_zmult_prop2
+ [of "MultInv p k * k" 1 p "j * k" a])
+ apply (auto simp add: zmult_ac)
+ done
+
+lemma aux___3: "[j * k = a] (mod p) ==> [(MultInv p j) * j * k =
+ (MultInv p j) * a] (mod p)"
+ by (auto simp add: zmult_assoc zcong_scalar2)
+
+lemma aux___4: "[|2 < p; zprime p; ~([j = 0](mod p));
+ [(MultInv p j) * j * k = (MultInv p j) * a] (mod p) |]
+ ==> [k = a * (MultInv p j)] (mod p)"
+ apply (insert MultInv_prop2a [of p j] zcong_zmult_prop1
+ [of "MultInv p j * j" 1 p "MultInv p j * a" k])
+ apply (auto simp add: zmult_ac zcong_sym)
+ done
+
+lemma MultInv_zcong_prop2: "[| 2 < p; zprime p; ~([k = 0](mod p));
+ ~([j = 0](mod p)); [j = a * MultInv p k] (mod p) |] ==>
+ [k = a * MultInv p j] (mod p)"
+ apply (drule aux___1)
+ apply (frule aux___2, auto)
+ by (drule aux___3, drule aux___4, auto)
+
+lemma MultInv_zcong_prop3: "[| 2 < p; zprime p; ~([a = 0](mod p));
+ ~([k = 0](mod p)); ~([j = 0](mod p));
+ [a * MultInv p j = a * MultInv p k] (mod p) |] ==>
+ [j = k] (mod p)"
+ apply (auto simp add: zcong_eq_zdvd_prop [of a p])
+ apply (frule zprime_imp_zrelprime, auto)
+ apply (insert zcong_cancel2 [of p a "MultInv p j" "MultInv p k"], auto)
+ apply (drule MultInv_prop5, auto)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/IntFact.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,94 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Factorial on integers *}
+
+theory IntFact imports IntPrimes begin
+
+text {*
+ Factorial on integers and recursively defined set including all
+ Integers from @{text 2} up to @{text a}. Plus definition of product
+ of finite set.
+
+ \bigskip
+*}
+
+consts
+ zfact :: "int => int"
+ d22set :: "int => int set"
+
+recdef zfact "measure ((\<lambda>n. nat n) :: int => nat)"
+ "zfact n = (if n \<le> 0 then 1 else n * zfact (n - 1))"
+
+recdef d22set "measure ((\<lambda>a. nat a) :: int => nat)"
+ "d22set a = (if 1 < a then insert a (d22set (a - 1)) else {})"
+
+
+text {*
+ \medskip @{term d22set} --- recursively defined set including all
+ integers from @{text 2} up to @{text a}
+*}
+
+declare d22set.simps [simp del]
+
+
+lemma d22set_induct:
+ assumes "!!a. P {} a"
+ and "!!a. 1 < (a::int) ==> P (d22set (a - 1)) (a - 1) ==> P (d22set a) a"
+ shows "P (d22set u) u"
+ apply (rule d22set.induct)
+ apply safe
+ prefer 2
+ apply (case_tac "1 < a")
+ apply (rule_tac prems)
+ apply (simp_all (no_asm_simp))
+ apply (simp_all (no_asm_simp) add: d22set.simps prems)
+ done
+
+lemma d22set_g_1 [rule_format]: "b \<in> d22set a --> 1 < b"
+ apply (induct a rule: d22set_induct)
+ apply simp
+ apply (subst d22set.simps)
+ apply auto
+ done
+
+lemma d22set_le [rule_format]: "b \<in> d22set a --> b \<le> a"
+ apply (induct a rule: d22set_induct)
+ apply simp
+ apply (subst d22set.simps)
+ apply auto
+ done
+
+lemma d22set_le_swap: "a < b ==> b \<notin> d22set a"
+ by (auto dest: d22set_le)
+
+lemma d22set_mem: "1 < b \<Longrightarrow> b \<le> a \<Longrightarrow> b \<in> d22set a"
+ apply (induct a rule: d22set.induct)
+ apply auto
+ apply (simp_all add: d22set.simps)
+ done
+
+lemma d22set_fin: "finite (d22set a)"
+ apply (induct a rule: d22set_induct)
+ prefer 2
+ apply (subst d22set.simps)
+ apply auto
+ done
+
+
+declare zfact.simps [simp del]
+
+lemma d22set_prod_zfact: "\<Prod>(d22set a) = zfact a"
+ apply (induct a rule: d22set.induct)
+ apply safe
+ apply (simp add: d22set.simps zfact.simps)
+ apply (subst d22set.simps)
+ apply (subst zfact.simps)
+ apply (case_tac "1 < a")
+ prefer 2
+ apply (simp add: d22set.simps zfact.simps)
+ apply (simp add: d22set_fin d22set_le_swap)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/IntPrimes.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,421 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Divisibility and prime numbers (on integers) *}
+
+theory IntPrimes
+imports Main Primes
+begin
+
+text {*
+ The @{text dvd} relation, GCD, Euclid's extended algorithm, primes,
+ congruences (all on the Integers). Comparable to theory @{text
+ Primes}, but @{text dvd} is included here as it is not present in
+ main HOL. Also includes extended GCD and congruences not present in
+ @{text Primes}.
+*}
+
+
+subsection {* Definitions *}
+
+consts
+ xzgcda :: "int * int * int * int * int * int * int * int => int * int * int"
+
+recdef xzgcda
+ "measure ((\<lambda>(m, n, r', r, s', s, t', t). nat r)
+ :: int * int * int * int *int * int * int * int => nat)"
+ "xzgcda (m, n, r', r, s', s, t', t) =
+ (if r \<le> 0 then (r', s', t')
+ else xzgcda (m, n, r, r' mod r,
+ s, s' - (r' div r) * s,
+ t, t' - (r' div r) * t))"
+
+definition
+ zprime :: "int \<Rightarrow> bool" where
+ "zprime p = (1 < p \<and> (\<forall>m. 0 <= m & m dvd p --> m = 1 \<or> m = p))"
+
+definition
+ xzgcd :: "int => int => int * int * int" where
+ "xzgcd m n = xzgcda (m, n, m, n, 1, 0, 0, 1)"
+
+definition
+ zcong :: "int => int => int => bool" ("(1[_ = _] '(mod _'))") where
+ "[a = b] (mod m) = (m dvd (a - b))"
+
+subsection {* Euclid's Algorithm and GCD *}
+
+
+lemma zrelprime_zdvd_zmult_aux:
+ "zgcd n k = 1 ==> k dvd m * n ==> 0 \<le> m ==> k dvd m"
+ by (metis abs_of_nonneg dvd_triv_right zgcd_greatest_iff zgcd_zmult_distrib2_abs zmult_1_right)
+
+lemma zrelprime_zdvd_zmult: "zgcd n k = 1 ==> k dvd m * n ==> k dvd m"
+ apply (case_tac "0 \<le> m")
+ apply (blast intro: zrelprime_zdvd_zmult_aux)
+ apply (subgoal_tac "k dvd -m")
+ apply (rule_tac [2] zrelprime_zdvd_zmult_aux, auto)
+ done
+
+lemma zgcd_geq_zero: "0 <= zgcd x y"
+ by (auto simp add: zgcd_def)
+
+text{*This is merely a sanity check on zprime, since the previous version
+ denoted the empty set.*}
+lemma "zprime 2"
+ apply (auto simp add: zprime_def)
+ apply (frule zdvd_imp_le, simp)
+ apply (auto simp add: order_le_less dvd_def)
+ done
+
+lemma zprime_imp_zrelprime:
+ "zprime p ==> \<not> p dvd n ==> zgcd n p = 1"
+ apply (auto simp add: zprime_def)
+ apply (metis zgcd_geq_zero zgcd_zdvd1 zgcd_zdvd2)
+ done
+
+lemma zless_zprime_imp_zrelprime:
+ "zprime p ==> 0 < n ==> n < p ==> zgcd n p = 1"
+ apply (erule zprime_imp_zrelprime)
+ apply (erule zdvd_not_zless, assumption)
+ done
+
+lemma zprime_zdvd_zmult:
+ "0 \<le> (m::int) ==> zprime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
+ by (metis zgcd_zdvd1 zgcd_zdvd2 zgcd_pos zprime_def zrelprime_dvd_mult)
+
+lemma zgcd_zadd_zmult [simp]: "zgcd (m + n * k) n = zgcd m n"
+ apply (rule zgcd_eq [THEN trans])
+ apply (simp add: mod_add_eq)
+ apply (rule zgcd_eq [symmetric])
+ done
+
+lemma zgcd_zdvd_zgcd_zmult: "zgcd m n dvd zgcd (k * m) n"
+by (simp add: zgcd_greatest_iff)
+
+lemma zgcd_zmult_zdvd_zgcd:
+ "zgcd k n = 1 ==> zgcd (k * m) n dvd zgcd m n"
+ apply (simp add: zgcd_greatest_iff)
+ apply (rule_tac n = k in zrelprime_zdvd_zmult)
+ prefer 2
+ apply (simp add: zmult_commute)
+ apply (metis zgcd_1 zgcd_commute zgcd_left_commute)
+ done
+
+lemma zgcd_zmult_cancel: "zgcd k n = 1 ==> zgcd (k * m) n = zgcd m n"
+ by (simp add: zgcd_def nat_abs_mult_distrib gcd_mult_cancel)
+
+lemma zgcd_zgcd_zmult:
+ "zgcd k m = 1 ==> zgcd n m = 1 ==> zgcd (k * n) m = 1"
+ by (simp add: zgcd_zmult_cancel)
+
+lemma zdvd_iff_zgcd: "0 < m ==> m dvd n \<longleftrightarrow> zgcd n m = m"
+ by (metis abs_of_pos zdvd_mult_div_cancel zgcd_0 zgcd_commute zgcd_geq_zero zgcd_zdvd2 zgcd_zmult_eq_self)
+
+
+
+subsection {* Congruences *}
+
+lemma zcong_1 [simp]: "[a = b] (mod 1)"
+ by (unfold zcong_def, auto)
+
+lemma zcong_refl [simp]: "[k = k] (mod m)"
+ by (unfold zcong_def, auto)
+
+lemma zcong_sym: "[a = b] (mod m) = [b = a] (mod m)"
+ unfolding zcong_def minus_diff_eq [of a, symmetric] dvd_minus_iff ..
+
+lemma zcong_zadd:
+ "[a = b] (mod m) ==> [c = d] (mod m) ==> [a + c = b + d] (mod m)"
+ apply (unfold zcong_def)
+ apply (rule_tac s = "(a - b) + (c - d)" in subst)
+ apply (rule_tac [2] dvd_add, auto)
+ done
+
+lemma zcong_zdiff:
+ "[a = b] (mod m) ==> [c = d] (mod m) ==> [a - c = b - d] (mod m)"
+ apply (unfold zcong_def)
+ apply (rule_tac s = "(a - b) - (c - d)" in subst)
+ apply (rule_tac [2] dvd_diff, auto)
+ done
+
+lemma zcong_trans:
+ "[a = b] (mod m) ==> [b = c] (mod m) ==> [a = c] (mod m)"
+unfolding zcong_def by (auto elim!: dvdE simp add: algebra_simps)
+
+lemma zcong_zmult:
+ "[a = b] (mod m) ==> [c = d] (mod m) ==> [a * c = b * d] (mod m)"
+ apply (rule_tac b = "b * c" in zcong_trans)
+ apply (unfold zcong_def)
+ apply (metis zdiff_zmult_distrib2 dvd_mult zmult_commute)
+ apply (metis zdiff_zmult_distrib2 dvd_mult)
+ done
+
+lemma zcong_scalar: "[a = b] (mod m) ==> [a * k = b * k] (mod m)"
+ by (rule zcong_zmult, simp_all)
+
+lemma zcong_scalar2: "[a = b] (mod m) ==> [k * a = k * b] (mod m)"
+ by (rule zcong_zmult, simp_all)
+
+lemma zcong_zmult_self: "[a * m = b * m] (mod m)"
+ apply (unfold zcong_def)
+ apply (rule dvd_diff, simp_all)
+ done
+
+lemma zcong_square:
+ "[| zprime p; 0 < a; [a * a = 1] (mod p)|]
+ ==> [a = 1] (mod p) \<or> [a = p - 1] (mod p)"
+ apply (unfold zcong_def)
+ apply (rule zprime_zdvd_zmult)
+ apply (rule_tac [3] s = "a * a - 1 + p * (1 - a)" in subst)
+ prefer 4
+ apply (simp add: zdvd_reduce)
+ apply (simp_all add: zdiff_zmult_distrib zmult_commute zdiff_zmult_distrib2)
+ done
+
+lemma zcong_cancel:
+ "0 \<le> m ==>
+ zgcd k m = 1 ==> [a * k = b * k] (mod m) = [a = b] (mod m)"
+ apply safe
+ prefer 2
+ apply (blast intro: zcong_scalar)
+ apply (case_tac "b < a")
+ prefer 2
+ apply (subst zcong_sym)
+ apply (unfold zcong_def)
+ apply (rule_tac [!] zrelprime_zdvd_zmult)
+ apply (simp_all add: zdiff_zmult_distrib)
+ apply (subgoal_tac "m dvd (-(a * k - b * k))")
+ apply simp
+ apply (subst dvd_minus_iff, assumption)
+ done
+
+lemma zcong_cancel2:
+ "0 \<le> m ==>
+ zgcd k m = 1 ==> [k * a = k * b] (mod m) = [a = b] (mod m)"
+ by (simp add: zmult_commute zcong_cancel)
+
+lemma zcong_zgcd_zmult_zmod:
+ "[a = b] (mod m) ==> [a = b] (mod n) ==> zgcd m n = 1
+ ==> [a = b] (mod m * n)"
+ apply (auto simp add: zcong_def dvd_def)
+ apply (subgoal_tac "m dvd n * ka")
+ apply (subgoal_tac "m dvd ka")
+ apply (case_tac [2] "0 \<le> ka")
+ apply (metis zdvd_mult_div_cancel dvd_refl dvd_mult_left zmult_commute zrelprime_zdvd_zmult)
+ apply (metis abs_dvd_iff abs_of_nonneg zadd_0 zgcd_0_left zgcd_commute zgcd_zadd_zmult zgcd_zdvd_zgcd_zmult zgcd_zmult_distrib2_abs zmult_1_right zmult_commute)
+ apply (metis mult_le_0_iff zdvd_mono zdvd_mult_cancel dvd_triv_left zero_le_mult_iff zle_anti_sym zle_linear zle_refl zmult_commute zrelprime_zdvd_zmult)
+ apply (metis dvd_triv_left)
+ done
+
+lemma zcong_zless_imp_eq:
+ "0 \<le> a ==>
+ a < m ==> 0 \<le> b ==> b < m ==> [a = b] (mod m) ==> a = b"
+ apply (unfold zcong_def dvd_def, auto)
+ apply (drule_tac f = "\<lambda>z. z mod m" in arg_cong)
+ apply (metis diff_add_cancel mod_pos_pos_trivial zadd_0 zadd_commute zmod_eq_0_iff mod_add_right_eq)
+ done
+
+lemma zcong_square_zless:
+ "zprime p ==> 0 < a ==> a < p ==>
+ [a * a = 1] (mod p) ==> a = 1 \<or> a = p - 1"
+ apply (cut_tac p = p and a = a in zcong_square)
+ apply (simp add: zprime_def)
+ apply (auto intro: zcong_zless_imp_eq)
+ done
+
+lemma zcong_not:
+ "0 < a ==> a < m ==> 0 < b ==> b < a ==> \<not> [a = b] (mod m)"
+ apply (unfold zcong_def)
+ apply (rule zdvd_not_zless, auto)
+ done
+
+lemma zcong_zless_0:
+ "0 \<le> a ==> a < m ==> [a = 0] (mod m) ==> a = 0"
+ apply (unfold zcong_def dvd_def, auto)
+ apply (metis div_pos_pos_trivial linorder_not_less div_mult_self1_is_id)
+ done
+
+lemma zcong_zless_unique:
+ "0 < m ==> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
+ apply auto
+ prefer 2 apply (metis zcong_sym zcong_trans zcong_zless_imp_eq)
+ apply (unfold zcong_def dvd_def)
+ apply (rule_tac x = "a mod m" in exI, auto)
+ apply (metis zmult_div_cancel)
+ done
+
+lemma zcong_iff_lin: "([a = b] (mod m)) = (\<exists>k. b = a + m * k)"
+ unfolding zcong_def
+ apply (auto elim!: dvdE simp add: algebra_simps)
+ apply (rule_tac x = "-k" in exI) apply simp
+ done
+
+lemma zgcd_zcong_zgcd:
+ "0 < m ==>
+ zgcd a m = 1 ==> [a = b] (mod m) ==> zgcd b m = 1"
+ by (auto simp add: zcong_iff_lin)
+
+lemma zcong_zmod_aux:
+ "a - b = (m::int) * (a div m - b div m) + (a mod m - b mod m)"
+ by(simp add: zdiff_zmult_distrib2 add_diff_eq eq_diff_eq add_ac)
+
+lemma zcong_zmod: "[a = b] (mod m) = [a mod m = b mod m] (mod m)"
+ apply (unfold zcong_def)
+ apply (rule_tac t = "a - b" in ssubst)
+ apply (rule_tac m = m in zcong_zmod_aux)
+ apply (rule trans)
+ apply (rule_tac [2] k = m and m = "a div m - b div m" in zdvd_reduce)
+ apply (simp add: zadd_commute)
+ done
+
+lemma zcong_zmod_eq: "0 < m ==> [a = b] (mod m) = (a mod m = b mod m)"
+ apply auto
+ apply (metis pos_mod_conj zcong_zless_imp_eq zcong_zmod)
+ apply (metis zcong_refl zcong_zmod)
+ done
+
+lemma zcong_zminus [iff]: "[a = b] (mod -m) = [a = b] (mod m)"
+ by (auto simp add: zcong_def)
+
+lemma zcong_zero [iff]: "[a = b] (mod 0) = (a = b)"
+ by (auto simp add: zcong_def)
+
+lemma "[a = b] (mod m) = (a mod m = b mod m)"
+ apply (case_tac "m = 0", simp add: DIVISION_BY_ZERO)
+ apply (simp add: linorder_neq_iff)
+ apply (erule disjE)
+ prefer 2 apply (simp add: zcong_zmod_eq)
+ txt{*Remainding case: @{term "m<0"}*}
+ apply (rule_tac t = m in zminus_zminus [THEN subst])
+ apply (subst zcong_zminus)
+ apply (subst zcong_zmod_eq, arith)
+ apply (frule neg_mod_bound [of _ a], frule neg_mod_bound [of _ b])
+ apply (simp add: zmod_zminus2_eq_if del: neg_mod_bound)
+ done
+
+subsection {* Modulo *}
+
+lemma zmod_zdvd_zmod:
+ "0 < (m::int) ==> m dvd b ==> (a mod b mod m) = (a mod m)"
+ by (rule mod_mod_cancel)
+
+
+subsection {* Extended GCD *}
+
+declare xzgcda.simps [simp del]
+
+lemma xzgcd_correct_aux1:
+ "zgcd r' r = k --> 0 < r -->
+ (\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn))"
+ apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
+ z = s and aa = t' and ab = t in xzgcda.induct)
+ apply (subst zgcd_eq)
+ apply (subst xzgcda.simps, auto)
+ apply (case_tac "r' mod r = 0")
+ prefer 2
+ apply (frule_tac a = "r'" in pos_mod_sign, auto)
+ apply (rule exI)
+ apply (rule exI)
+ apply (subst xzgcda.simps, auto)
+ done
+
+lemma xzgcd_correct_aux2:
+ "(\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn)) --> 0 < r -->
+ zgcd r' r = k"
+ apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
+ z = s and aa = t' and ab = t in xzgcda.induct)
+ apply (subst zgcd_eq)
+ apply (subst xzgcda.simps)
+ apply (auto simp add: linorder_not_le)
+ apply (case_tac "r' mod r = 0")
+ prefer 2
+ apply (frule_tac a = "r'" in pos_mod_sign, auto)
+ apply (metis Pair_eq simps zle_refl)
+ done
+
+lemma xzgcd_correct:
+ "0 < n ==> (zgcd m n = k) = (\<exists>s t. xzgcd m n = (k, s, t))"
+ apply (unfold xzgcd_def)
+ apply (rule iffI)
+ apply (rule_tac [2] xzgcd_correct_aux2 [THEN mp, THEN mp])
+ apply (rule xzgcd_correct_aux1 [THEN mp, THEN mp], auto)
+ done
+
+
+text {* \medskip @{term xzgcd} linear *}
+
+lemma xzgcda_linear_aux1:
+ "(a - r * b) * m + (c - r * d) * (n::int) =
+ (a * m + c * n) - r * (b * m + d * n)"
+ by (simp add: zdiff_zmult_distrib zadd_zmult_distrib2 zmult_assoc)
+
+lemma xzgcda_linear_aux2:
+ "r' = s' * m + t' * n ==> r = s * m + t * n
+ ==> (r' mod r) = (s' - (r' div r) * s) * m + (t' - (r' div r) * t) * (n::int)"
+ apply (rule trans)
+ apply (rule_tac [2] xzgcda_linear_aux1 [symmetric])
+ apply (simp add: eq_diff_eq mult_commute)
+ done
+
+lemma order_le_neq_implies_less: "(x::'a::order) \<le> y ==> x \<noteq> y ==> x < y"
+ by (rule iffD2 [OF order_less_le conjI])
+
+lemma xzgcda_linear [rule_format]:
+ "0 < r --> xzgcda (m, n, r', r, s', s, t', t) = (rn, sn, tn) -->
+ r' = s' * m + t' * n --> r = s * m + t * n --> rn = sn * m + tn * n"
+ apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
+ z = s and aa = t' and ab = t in xzgcda.induct)
+ apply (subst xzgcda.simps)
+ apply (simp (no_asm))
+ apply (rule impI)+
+ apply (case_tac "r' mod r = 0")
+ apply (simp add: xzgcda.simps, clarify)
+ apply (subgoal_tac "0 < r' mod r")
+ apply (rule_tac [2] order_le_neq_implies_less)
+ apply (rule_tac [2] pos_mod_sign)
+ apply (cut_tac m = m and n = n and r' = r' and r = r and s' = s' and
+ s = s and t' = t' and t = t in xzgcda_linear_aux2, auto)
+ done
+
+lemma xzgcd_linear:
+ "0 < n ==> xzgcd m n = (r, s, t) ==> r = s * m + t * n"
+ apply (unfold xzgcd_def)
+ apply (erule xzgcda_linear, assumption, auto)
+ done
+
+lemma zgcd_ex_linear:
+ "0 < n ==> zgcd m n = k ==> (\<exists>s t. k = s * m + t * n)"
+ apply (simp add: xzgcd_correct, safe)
+ apply (rule exI)+
+ apply (erule xzgcd_linear, auto)
+ done
+
+lemma zcong_lineq_ex:
+ "0 < n ==> zgcd a n = 1 ==> \<exists>x. [a * x = 1] (mod n)"
+ apply (cut_tac m = a and n = n and k = 1 in zgcd_ex_linear, safe)
+ apply (rule_tac x = s in exI)
+ apply (rule_tac b = "s * a + t * n" in zcong_trans)
+ prefer 2
+ apply simp
+ apply (unfold zcong_def)
+ apply (simp (no_asm) add: zmult_commute)
+ done
+
+lemma zcong_lineq_unique:
+ "0 < n ==>
+ zgcd a n = 1 ==> \<exists>!x. 0 \<le> x \<and> x < n \<and> [a * x = b] (mod n)"
+ apply auto
+ apply (rule_tac [2] zcong_zless_imp_eq)
+ apply (tactic {* stac (thm "zcong_cancel2" RS sym) 6 *})
+ apply (rule_tac [8] zcong_trans)
+ apply (simp_all (no_asm_simp))
+ prefer 2
+ apply (simp add: zcong_sym)
+ apply (cut_tac a = a and n = n in zcong_lineq_ex, auto)
+ apply (rule_tac x = "x * b mod n" in exI, safe)
+ apply (simp_all (no_asm_simp))
+ apply (metis zcong_scalar zcong_zmod zmod_zmult1_eq zmult_1 zmult_assoc)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Legacy_GCD.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,787 @@
+(* Title: HOL/GCD.thy
+ Author: Christophe Tabacznyj and Lawrence C Paulson
+ Copyright 1996 University of Cambridge
+*)
+
+header {* The Greatest Common Divisor *}
+
+theory Legacy_GCD
+imports Main
+begin
+
+text {*
+ See \cite{davenport92}. \bigskip
+*}
+
+subsection {* Specification of GCD on nats *}
+
+definition
+ is_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where -- {* @{term gcd} as a relation *}
+ [code del]: "is_gcd m n p \<longleftrightarrow> p dvd m \<and> p dvd n \<and>
+ (\<forall>d. d dvd m \<longrightarrow> d dvd n \<longrightarrow> d dvd p)"
+
+text {* Uniqueness *}
+
+lemma is_gcd_unique: "is_gcd a b m \<Longrightarrow> is_gcd a b n \<Longrightarrow> m = n"
+ by (simp add: is_gcd_def) (blast intro: dvd_anti_sym)
+
+text {* Connection to divides relation *}
+
+lemma is_gcd_dvd: "is_gcd a b m \<Longrightarrow> k dvd a \<Longrightarrow> k dvd b \<Longrightarrow> k dvd m"
+ by (auto simp add: is_gcd_def)
+
+text {* Commutativity *}
+
+lemma is_gcd_commute: "is_gcd m n k = is_gcd n m k"
+ by (auto simp add: is_gcd_def)
+
+
+subsection {* GCD on nat by Euclid's algorithm *}
+
+fun
+ gcd :: "nat => nat => nat"
+where
+ "gcd m n = (if n = 0 then m else gcd n (m mod n))"
+lemma gcd_induct [case_names "0" rec]:
+ fixes m n :: nat
+ assumes "\<And>m. P m 0"
+ and "\<And>m n. 0 < n \<Longrightarrow> P n (m mod n) \<Longrightarrow> P m n"
+ shows "P m n"
+proof (induct m n rule: gcd.induct)
+ case (1 m n) with assms show ?case by (cases "n = 0") simp_all
+qed
+
+lemma gcd_0 [simp, algebra]: "gcd m 0 = m"
+ by simp
+
+lemma gcd_0_left [simp,algebra]: "gcd 0 m = m"
+ by simp
+
+lemma gcd_non_0: "n > 0 \<Longrightarrow> gcd m n = gcd n (m mod n)"
+ by simp
+
+lemma gcd_1 [simp, algebra]: "gcd m (Suc 0) = Suc 0"
+ by simp
+
+lemma nat_gcd_1_right [simp, algebra]: "gcd m 1 = 1"
+ unfolding One_nat_def by (rule gcd_1)
+
+declare gcd.simps [simp del]
+
+text {*
+ \medskip @{term "gcd m n"} divides @{text m} and @{text n}. The
+ conjunctions don't seem provable separately.
+*}
+
+lemma gcd_dvd1 [iff, algebra]: "gcd m n dvd m"
+ and gcd_dvd2 [iff, algebra]: "gcd m n dvd n"
+ apply (induct m n rule: gcd_induct)
+ apply (simp_all add: gcd_non_0)
+ apply (blast dest: dvd_mod_imp_dvd)
+ done
+
+text {*
+ \medskip Maximality: for all @{term m}, @{term n}, @{term k}
+ naturals, if @{term k} divides @{term m} and @{term k} divides
+ @{term n} then @{term k} divides @{term "gcd m n"}.
+*}
+
+lemma gcd_greatest: "k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd gcd m n"
+ by (induct m n rule: gcd_induct) (simp_all add: gcd_non_0 dvd_mod)
+
+text {*
+ \medskip Function gcd yields the Greatest Common Divisor.
+*}
+
+lemma is_gcd: "is_gcd m n (gcd m n) "
+ by (simp add: is_gcd_def gcd_greatest)
+
+
+subsection {* Derived laws for GCD *}
+
+lemma gcd_greatest_iff [iff, algebra]: "k dvd gcd m n \<longleftrightarrow> k dvd m \<and> k dvd n"
+ by (blast intro!: gcd_greatest intro: dvd_trans)
+
+lemma gcd_zero[algebra]: "gcd m n = 0 \<longleftrightarrow> m = 0 \<and> n = 0"
+ by (simp only: dvd_0_left_iff [symmetric] gcd_greatest_iff)
+
+lemma gcd_commute: "gcd m n = gcd n m"
+ apply (rule is_gcd_unique)
+ apply (rule is_gcd)
+ apply (subst is_gcd_commute)
+ apply (simp add: is_gcd)
+ done
+
+lemma gcd_assoc: "gcd (gcd k m) n = gcd k (gcd m n)"
+ apply (rule is_gcd_unique)
+ apply (rule is_gcd)
+ apply (simp add: is_gcd_def)
+ apply (blast intro: dvd_trans)
+ done
+
+lemma gcd_1_left [simp, algebra]: "gcd (Suc 0) m = Suc 0"
+ by (simp add: gcd_commute)
+
+lemma nat_gcd_1_left [simp, algebra]: "gcd 1 m = 1"
+ unfolding One_nat_def by (rule gcd_1_left)
+
+text {*
+ \medskip Multiplication laws
+*}
+
+lemma gcd_mult_distrib2: "k * gcd m n = gcd (k * m) (k * n)"
+ -- {* \cite[page 27]{davenport92} *}
+ apply (induct m n rule: gcd_induct)
+ apply simp
+ apply (case_tac "k = 0")
+ apply (simp_all add: mod_geq gcd_non_0 mod_mult_distrib2)
+ done
+
+lemma gcd_mult [simp, algebra]: "gcd k (k * n) = k"
+ apply (rule gcd_mult_distrib2 [of k 1 n, simplified, symmetric])
+ done
+
+lemma gcd_self [simp, algebra]: "gcd k k = k"
+ apply (rule gcd_mult [of k 1, simplified])
+ done
+
+lemma relprime_dvd_mult: "gcd k n = 1 ==> k dvd m * n ==> k dvd m"
+ apply (insert gcd_mult_distrib2 [of m k n])
+ apply simp
+ apply (erule_tac t = m in ssubst)
+ apply simp
+ done
+
+lemma relprime_dvd_mult_iff: "gcd k n = 1 ==> (k dvd m * n) = (k dvd m)"
+ by (auto intro: relprime_dvd_mult dvd_mult2)
+
+lemma gcd_mult_cancel: "gcd k n = 1 ==> gcd (k * m) n = gcd m n"
+ apply (rule dvd_anti_sym)
+ apply (rule gcd_greatest)
+ apply (rule_tac n = k in relprime_dvd_mult)
+ apply (simp add: gcd_assoc)
+ apply (simp add: gcd_commute)
+ apply (simp_all add: mult_commute)
+ done
+
+
+text {* \medskip Addition laws *}
+
+lemma gcd_add1 [simp, algebra]: "gcd (m + n) n = gcd m n"
+ by (cases "n = 0") (auto simp add: gcd_non_0)
+
+lemma gcd_add2 [simp, algebra]: "gcd m (m + n) = gcd m n"
+proof -
+ have "gcd m (m + n) = gcd (m + n) m" by (rule gcd_commute)
+ also have "... = gcd (n + m) m" by (simp add: add_commute)
+ also have "... = gcd n m" by simp
+ also have "... = gcd m n" by (rule gcd_commute)
+ finally show ?thesis .
+qed
+
+lemma gcd_add2' [simp, algebra]: "gcd m (n + m) = gcd m n"
+ apply (subst add_commute)
+ apply (rule gcd_add2)
+ done
+
+lemma gcd_add_mult[algebra]: "gcd m (k * m + n) = gcd m n"
+ by (induct k) (simp_all add: add_assoc)
+
+lemma gcd_dvd_prod: "gcd m n dvd m * n"
+ using mult_dvd_mono [of 1] by auto
+
+text {*
+ \medskip Division by gcd yields rrelatively primes.
+*}
+
+lemma div_gcd_relprime:
+ assumes nz: "a \<noteq> 0 \<or> b \<noteq> 0"
+ shows "gcd (a div gcd a b) (b div gcd a b) = 1"
+proof -
+ let ?g = "gcd a b"
+ let ?a' = "a div ?g"
+ let ?b' = "b div ?g"
+ let ?g' = "gcd ?a' ?b'"
+ have dvdg: "?g dvd a" "?g dvd b" by simp_all
+ have dvdg': "?g' dvd ?a'" "?g' dvd ?b'" by simp_all
+ from dvdg dvdg' obtain ka kb ka' kb' where
+ kab: "a = ?g * ka" "b = ?g * kb" "?a' = ?g' * ka'" "?b' = ?g' * kb'"
+ unfolding dvd_def by blast
+ then have "?g * ?a' = (?g * ?g') * ka'" "?g * ?b' = (?g * ?g') * kb'" by simp_all
+ 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)
+ then have gp: "?g > 0" by simp
+ from gcd_greatest [OF dvdgg'] have "?g * ?g' dvd ?g" .
+ with dvd_mult_cancel1 [OF gp] show "?g' = 1" by simp
+qed
+
+
+lemma gcd_unique: "d dvd a\<and>d dvd b \<and> (\<forall>e. e dvd a \<and> e dvd b \<longrightarrow> e dvd d) \<longleftrightarrow> d = gcd a b"
+proof(auto)
+ assume H: "d dvd a" "d dvd b" "\<forall>e. e dvd a \<and> e dvd b \<longrightarrow> e dvd d"
+ from H(3)[rule_format] gcd_dvd1[of a b] gcd_dvd2[of a b]
+ have th: "gcd a b dvd d" by blast
+ from dvd_anti_sym[OF th gcd_greatest[OF H(1,2)]] show "d = gcd a b" by blast
+qed
+
+lemma gcd_eq: assumes H: "\<forall>d. d dvd x \<and> d dvd y \<longleftrightarrow> d dvd u \<and> d dvd v"
+ shows "gcd x y = gcd u v"
+proof-
+ from H have "\<forall>d. d dvd x \<and> d dvd y \<longleftrightarrow> d dvd gcd u v" by simp
+ with gcd_unique[of "gcd u v" x y] show ?thesis by auto
+qed
+
+lemma ind_euclid:
+ assumes c: " \<forall>a b. P (a::nat) b \<longleftrightarrow> P b a" and z: "\<forall>a. P a 0"
+ and add: "\<forall>a b. P a b \<longrightarrow> P a (a + b)"
+ shows "P a b"
+proof(induct n\<equiv>"a+b" arbitrary: a b rule: nat_less_induct)
+ fix n a b
+ assume H: "\<forall>m < n. \<forall>a b. m = a + b \<longrightarrow> P a b" "n = a + b"
+ have "a = b \<or> a < b \<or> b < a" by arith
+ moreover {assume eq: "a= b"
+ from add[rule_format, OF z[rule_format, of a]] have "P a b" using eq by simp}
+ moreover
+ {assume lt: "a < b"
+ hence "a + b - a < n \<or> a = 0" using H(2) by arith
+ moreover
+ {assume "a =0" with z c have "P a b" by blast }
+ moreover
+ {assume ab: "a + b - a < n"
+ have th0: "a + b - a = a + (b - a)" using lt by arith
+ from add[rule_format, OF H(1)[rule_format, OF ab th0]]
+ have "P a b" by (simp add: th0[symmetric])}
+ ultimately have "P a b" by blast}
+ moreover
+ {assume lt: "a > b"
+ hence "b + a - b < n \<or> b = 0" using H(2) by arith
+ moreover
+ {assume "b =0" with z c have "P a b" by blast }
+ moreover
+ {assume ab: "b + a - b < n"
+ have th0: "b + a - b = b + (a - b)" using lt by arith
+ from add[rule_format, OF H(1)[rule_format, OF ab th0]]
+ have "P b a" by (simp add: th0[symmetric])
+ hence "P a b" using c by blast }
+ ultimately have "P a b" by blast}
+ultimately show "P a b" by blast
+qed
+
+lemma bezout_lemma:
+ assumes ex: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x = b * y + d \<or> b * x = a * y + d)"
+ shows "\<exists>d x y. d dvd a \<and> d dvd a + b \<and> (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 (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
+apply (rule_tac x="x" in exI)
+apply (rule_tac x="x + y" in exI)
+apply algebra
+done
+
+lemma bezout_add: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x = b * y + d \<or> b * x = a * y + d)"
+apply(induct a b rule: ind_euclid)
+apply blast
+apply clarify
+apply (rule_tac x="a" in exI, simp add: dvd_add)
+apply clarsimp
+apply (rule_tac x="d" in exI)
+apply (case_tac "a * x = b * y + d", simp_all add: dvd_add)
+apply (rule_tac x="x+y" in exI)
+apply (rule_tac x="y" in exI)
+apply algebra
+apply (rule_tac x="x" in exI)
+apply (rule_tac x="x+y" in exI)
+apply algebra
+done
+
+lemma bezout: "\<exists>(d::nat) x y. d dvd a \<and> d dvd b \<and> (a * x - b * y = d \<or> b * x - a * y = d)"
+using bezout_add[of a b]
+apply clarsimp
+apply (rule_tac x="d" in exI, simp)
+apply (rule_tac x="x" in exI)
+apply (rule_tac x="y" in exI)
+apply auto
+done
+
+
+text {* We can get a stronger version with a nonzeroness assumption. *}
+lemma divides_le: "m dvd n ==> m <= n \<or> n = (0::nat)" by (auto simp add: dvd_def)
+
+lemma bezout_add_strong: assumes nz: "a \<noteq> (0::nat)"
+ shows "\<exists>d x y. d dvd a \<and> d dvd b \<and> a * x = b * y + d"
+proof-
+ from nz have ap: "a > 0" by simp
+ from bezout_add[of a b]
+ have "(\<exists>d x y. d dvd a \<and> d dvd b \<and> a * x = b * y + d) \<or> (\<exists>d x y. d dvd a \<and> d dvd b \<and> b * x = a * y + d)" by blast
+ moreover
+ {fix d x y assume H: "d dvd a" "d dvd b" "a * x = b * y + d"
+ from H have ?thesis by blast }
+ moreover
+ {fix d x y assume H: "d dvd a" "d dvd b" "b * x = a * y + d"
+ {assume b0: "b = 0" with H have ?thesis by simp}
+ moreover
+ {assume b: "b \<noteq> 0" hence bp: "b > 0" by simp
+ from divides_le[OF H(2)] b have "d < b \<or> d = b" using le_less by blast
+ moreover
+ {assume db: "d=b"
+ from prems have ?thesis apply simp
+ apply (rule exI[where x = b], simp)
+ apply (rule exI[where x = b])
+ by (rule exI[where x = "a - 1"], simp add: diff_mult_distrib2)}
+ moreover
+ {assume db: "d < b"
+ {assume "x=0" hence ?thesis using prems by simp }
+ moreover
+ {assume x0: "x \<noteq> 0" hence xp: "x > 0" by simp
+
+ from db have "d \<le> b - 1" by simp
+ hence "d*b \<le> b*(b - 1)" by simp
+ with xp mult_mono[of "1" "x" "d*b" "b*(b - 1)"]
+ have dble: "d*b \<le> x*b*(b - 1)" using bp by simp
+ from H (3) have "a * ((b - 1) * y) + d * (b - 1 + 1) = d + x*b*(b - 1)" by algebra
+ hence "a * ((b - 1) * y) = d + x*b*(b - 1) - d*b" using bp by simp
+ hence "a * ((b - 1) * y) = d + (x*b*(b - 1) - d*b)"
+ by (simp only: diff_add_assoc[OF dble, of d, symmetric])
+ hence "a * ((b - 1) * y) = b*(x*(b - 1) - d) + d"
+ by (simp only: diff_mult_distrib2 add_commute mult_ac)
+ hence ?thesis using H(1,2)
+ apply -
+ apply (rule exI[where x=d], simp)
+ apply (rule exI[where x="(b - 1) * y"])
+ by (rule exI[where x="x*(b - 1) - d"], simp)}
+ ultimately have ?thesis by blast}
+ ultimately have ?thesis by blast}
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+
+lemma bezout_gcd: "\<exists>x y. a * x - b * y = gcd a b \<or> b * x - a * y = gcd a b"
+proof-
+ let ?g = "gcd a b"
+ from bezout[of a b] obtain d x y where d: "d dvd a" "d dvd b" "a * x - b * y = d \<or> b * x - a * y = d" by blast
+ from d(1,2) have "d dvd ?g" by simp
+ then obtain k where k: "?g = d*k" unfolding dvd_def by blast
+ from d(3) have "(a * x - b * y)*k = d*k \<or> (b * x - a * y)*k = d*k" by blast
+ hence "a * x * k - b * y*k = d*k \<or> b * x * k - a * y*k = d*k"
+ by (algebra add: diff_mult_distrib)
+ hence "a * (x * k) - b * (y*k) = ?g \<or> b * (x * k) - a * (y*k) = ?g"
+ by (simp add: k mult_assoc)
+ thus ?thesis by blast
+qed
+
+lemma bezout_gcd_strong: assumes a: "a \<noteq> 0"
+ shows "\<exists>x y. a * x = b * y + gcd a b"
+proof-
+ let ?g = "gcd a b"
+ from bezout_add_strong[OF a, of b]
+ obtain d x y where d: "d dvd a" "d dvd b" "a * x = b * y + d" by blast
+ from d(1,2) have "d dvd ?g" by simp
+ then obtain k where k: "?g = d*k" unfolding dvd_def by blast
+ from d(3) have "a * x * k = (b * y + d) *k " by algebra
+ hence "a * (x * k) = b * (y*k) + ?g" by (algebra add: k)
+ thus ?thesis by blast
+qed
+
+lemma gcd_mult_distrib: "gcd(a * c) (b * c) = c * gcd a b"
+by(simp add: gcd_mult_distrib2 mult_commute)
+
+lemma gcd_bezout: "(\<exists>x y. a * x - b * y = d \<or> b * x - a * y = d) \<longleftrightarrow> gcd a b dvd d"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ let ?g = "gcd a b"
+ {assume H: ?rhs then obtain k where k: "d = ?g*k" unfolding dvd_def by blast
+ from bezout_gcd[of a b] obtain x y where xy: "a * x - b * y = ?g \<or> b * x - a * y = ?g"
+ by blast
+ hence "(a * x - b * y)*k = ?g*k \<or> (b * x - a * y)*k = ?g*k" by auto
+ hence "a * x*k - b * y*k = ?g*k \<or> b * x * k - a * y*k = ?g*k"
+ by (simp only: diff_mult_distrib)
+ hence "a * (x*k) - b * (y*k) = d \<or> b * (x * k) - a * (y*k) = d"
+ by (simp add: k[symmetric] mult_assoc)
+ hence ?lhs by blast}
+ moreover
+ {fix x y assume H: "a * x - b * y = d \<or> b * x - a * y = d"
+ have dv: "?g dvd a*x" "?g dvd b * y" "?g dvd b*x" "?g dvd a * y"
+ using dvd_mult2[OF gcd_dvd1[of a b]] dvd_mult2[OF gcd_dvd2[of a b]] by simp_all
+ from dvd_diff_nat[OF dv(1,2)] dvd_diff_nat[OF dv(3,4)] H
+ have ?rhs by auto}
+ ultimately show ?thesis by blast
+qed
+
+lemma gcd_bezout_sum: assumes H:"a * x + b * y = d" shows "gcd a b dvd d"
+proof-
+ let ?g = "gcd a b"
+ have dv: "?g dvd a*x" "?g dvd b * y"
+ using dvd_mult2[OF gcd_dvd1[of a b]] dvd_mult2[OF gcd_dvd2[of a b]] by simp_all
+ from dvd_add[OF dv] H
+ show ?thesis by auto
+qed
+
+lemma gcd_mult': "gcd b (a * b) = b"
+by (simp add: gcd_mult mult_commute[of a b])
+
+lemma gcd_add: "gcd(a + b) b = gcd a b"
+ "gcd(b + a) b = gcd a b" "gcd a (a + b) = gcd a b" "gcd a (b + a) = gcd a b"
+apply (simp_all add: gcd_add1)
+by (simp add: gcd_commute gcd_add1)
+
+lemma gcd_sub: "b <= a ==> gcd(a - b) b = gcd a b" "a <= b ==> gcd a (b - a) = gcd a b"
+proof-
+ {fix a b assume H: "b \<le> (a::nat)"
+ hence th: "a - b + b = a" by arith
+ from gcd_add(1)[of "a - b" b] th have "gcd(a - b) b = gcd a b" by simp}
+ note th = this
+{
+ assume ab: "b \<le> a"
+ from th[OF ab] show "gcd (a - b) b = gcd a b" by blast
+next
+ assume ab: "a \<le> b"
+ from th[OF ab] show "gcd a (b - a) = gcd a b"
+ by (simp add: gcd_commute)}
+qed
+
+
+subsection {* LCM defined by GCD *}
+
+
+definition
+ lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+where
+ lcm_def: "lcm m n = m * n div gcd m n"
+
+lemma prod_gcd_lcm:
+ "m * n = gcd m n * lcm m n"
+ unfolding lcm_def by (simp add: dvd_mult_div_cancel [OF gcd_dvd_prod])
+
+lemma lcm_0 [simp]: "lcm m 0 = 0"
+ unfolding lcm_def by simp
+
+lemma lcm_1 [simp]: "lcm m 1 = m"
+ unfolding lcm_def by simp
+
+lemma lcm_0_left [simp]: "lcm 0 n = 0"
+ unfolding lcm_def by simp
+
+lemma lcm_1_left [simp]: "lcm 1 m = m"
+ unfolding lcm_def by simp
+
+lemma dvd_pos:
+ fixes n m :: nat
+ assumes "n > 0" and "m dvd n"
+ shows "m > 0"
+using assms by (cases m) auto
+
+lemma lcm_least:
+ assumes "m dvd k" and "n dvd k"
+ shows "lcm m n dvd k"
+proof (cases k)
+ case 0 then show ?thesis by auto
+next
+ case (Suc _) then have pos_k: "k > 0" by auto
+ from assms dvd_pos [OF this] have pos_mn: "m > 0" "n > 0" by auto
+ with gcd_zero [of m n] have pos_gcd: "gcd m n > 0" by simp
+ from assms obtain p where k_m: "k = m * p" using dvd_def by blast
+ from assms obtain q where k_n: "k = n * q" using dvd_def by blast
+ from pos_k k_m have pos_p: "p > 0" by auto
+ from pos_k k_n have pos_q: "q > 0" by auto
+ have "k * k * gcd q p = k * gcd (k * q) (k * p)"
+ by (simp add: mult_ac gcd_mult_distrib2)
+ also have "\<dots> = k * gcd (m * p * q) (n * q * p)"
+ by (simp add: k_m [symmetric] k_n [symmetric])
+ also have "\<dots> = k * p * q * gcd m n"
+ by (simp add: mult_ac gcd_mult_distrib2)
+ finally have "(m * p) * (n * q) * gcd q p = k * p * q * gcd m n"
+ by (simp only: k_m [symmetric] k_n [symmetric])
+ then have "p * q * m * n * gcd q p = p * q * k * gcd m n"
+ by (simp add: mult_ac)
+ with pos_p pos_q have "m * n * gcd q p = k * gcd m n"
+ by simp
+ with prod_gcd_lcm [of m n]
+ have "lcm m n * gcd q p * gcd m n = k * gcd m n"
+ by (simp add: mult_ac)
+ with pos_gcd have "lcm m n * gcd q p = k" by simp
+ then show ?thesis using dvd_def by auto
+qed
+
+lemma lcm_dvd1 [iff]:
+ "m dvd lcm m n"
+proof (cases m)
+ case 0 then show ?thesis by simp
+next
+ case (Suc _)
+ then have mpos: "m > 0" by simp
+ show ?thesis
+ proof (cases n)
+ case 0 then show ?thesis by simp
+ next
+ case (Suc _)
+ then have npos: "n > 0" by simp
+ have "gcd m n dvd n" by simp
+ then obtain k where "n = gcd m n * k" using dvd_def by auto
+ then have "m * n div gcd m n = m * (gcd m n * k) div gcd m n" by (simp add: mult_ac)
+ also have "\<dots> = m * k" using mpos npos gcd_zero by simp
+ finally show ?thesis by (simp add: lcm_def)
+ qed
+qed
+
+lemma lcm_dvd2 [iff]:
+ "n dvd lcm m n"
+proof (cases n)
+ case 0 then show ?thesis by simp
+next
+ case (Suc _)
+ then have npos: "n > 0" by simp
+ show ?thesis
+ proof (cases m)
+ case 0 then show ?thesis by simp
+ next
+ case (Suc _)
+ then have mpos: "m > 0" by simp
+ have "gcd m n dvd m" by simp
+ then obtain k where "m = gcd m n * k" using dvd_def by auto
+ then have "m * n div gcd m n = (gcd m n * k) * n div gcd m n" by (simp add: mult_ac)
+ also have "\<dots> = n * k" using mpos npos gcd_zero by simp
+ finally show ?thesis by (simp add: lcm_def)
+ qed
+qed
+
+lemma gcd_add1_eq: "gcd (m + k) k = gcd (m + k) m"
+ by (simp add: gcd_commute)
+
+lemma gcd_diff2: "m \<le> n ==> gcd n (n - m) = gcd n m"
+ apply (subgoal_tac "n = m + (n - m)")
+ apply (erule ssubst, rule gcd_add1_eq, simp)
+ done
+
+
+subsection {* GCD and LCM on integers *}
+
+definition
+ zgcd :: "int \<Rightarrow> int \<Rightarrow> int" where
+ "zgcd i j = int (gcd (nat (abs i)) (nat (abs j)))"
+
+lemma zgcd_zdvd1 [iff,simp, algebra]: "zgcd i j dvd i"
+by (simp add: zgcd_def int_dvd_iff)
+
+lemma zgcd_zdvd2 [iff,simp, algebra]: "zgcd i j dvd j"
+by (simp add: zgcd_def int_dvd_iff)
+
+lemma zgcd_pos: "zgcd i j \<ge> 0"
+by (simp add: zgcd_def)
+
+lemma zgcd0 [simp,algebra]: "(zgcd i j = 0) = (i = 0 \<and> j = 0)"
+by (simp add: zgcd_def gcd_zero)
+
+lemma zgcd_commute: "zgcd i j = zgcd j i"
+unfolding zgcd_def by (simp add: gcd_commute)
+
+lemma zgcd_zminus [simp, algebra]: "zgcd (- i) j = zgcd i j"
+unfolding zgcd_def by simp
+
+lemma zgcd_zminus2 [simp, algebra]: "zgcd i (- j) = zgcd i j"
+unfolding zgcd_def by simp
+
+ (* should be solved by algebra*)
+lemma zrelprime_dvd_mult: "zgcd i j = 1 \<Longrightarrow> i dvd k * j \<Longrightarrow> i dvd k"
+ unfolding zgcd_def
+proof -
+ assume "int (gcd (nat \<bar>i\<bar>) (nat \<bar>j\<bar>)) = 1" "i dvd k * j"
+ then have g: "gcd (nat \<bar>i\<bar>) (nat \<bar>j\<bar>) = 1" by simp
+ from `i dvd k * j` obtain h where h: "k*j = i*h" unfolding dvd_def by blast
+ have th: "nat \<bar>i\<bar> dvd nat \<bar>k\<bar> * nat \<bar>j\<bar>"
+ unfolding dvd_def
+ by (rule_tac x= "nat \<bar>h\<bar>" in exI, simp add: h nat_abs_mult_distrib [symmetric])
+ from relprime_dvd_mult [OF g th] obtain h' where h': "nat \<bar>k\<bar> = nat \<bar>i\<bar> * h'"
+ unfolding dvd_def by blast
+ from h' have "int (nat \<bar>k\<bar>) = int (nat \<bar>i\<bar> * h')" by simp
+ then have "\<bar>k\<bar> = \<bar>i\<bar> * int h'" by (simp add: int_mult)
+ then show ?thesis
+ apply (subst abs_dvd_iff [symmetric])
+ apply (subst dvd_abs_iff [symmetric])
+ apply (unfold dvd_def)
+ apply (rule_tac x = "int h'" in exI, simp)
+ done
+qed
+
+lemma int_nat_abs: "int (nat (abs x)) = abs x" by arith
+
+lemma zgcd_greatest:
+ assumes "k dvd m" and "k dvd n"
+ shows "k dvd zgcd m n"
+proof -
+ let ?k' = "nat \<bar>k\<bar>"
+ let ?m' = "nat \<bar>m\<bar>"
+ let ?n' = "nat \<bar>n\<bar>"
+ from `k dvd m` and `k dvd n` have dvd': "?k' dvd ?m'" "?k' dvd ?n'"
+ unfolding zdvd_int by (simp_all only: int_nat_abs abs_dvd_iff dvd_abs_iff)
+ from gcd_greatest [OF dvd'] have "int (nat \<bar>k\<bar>) dvd zgcd m n"
+ unfolding zgcd_def by (simp only: zdvd_int)
+ then have "\<bar>k\<bar> dvd zgcd m n" by (simp only: int_nat_abs)
+ then show "k dvd zgcd m n" by simp
+qed
+
+lemma div_zgcd_relprime:
+ assumes nz: "a \<noteq> 0 \<or> b \<noteq> 0"
+ shows "zgcd (a div (zgcd a b)) (b div (zgcd a b)) = 1"
+proof -
+ from nz have nz': "nat \<bar>a\<bar> \<noteq> 0 \<or> nat \<bar>b\<bar> \<noteq> 0" by arith
+ let ?g = "zgcd a b"
+ let ?a' = "a div ?g"
+ let ?b' = "b div ?g"
+ let ?g' = "zgcd ?a' ?b'"
+ have dvdg: "?g dvd a" "?g dvd b" by (simp_all add: zgcd_zdvd1 zgcd_zdvd2)
+ have dvdg': "?g' dvd ?a'" "?g' dvd ?b'" by (simp_all add: zgcd_zdvd1 zgcd_zdvd2)
+ from dvdg dvdg' obtain ka kb ka' kb' where
+ kab: "a = ?g*ka" "b = ?g*kb" "?a' = ?g'*ka'" "?b' = ?g' * kb'"
+ unfolding dvd_def by blast
+ then have "?g* ?a' = (?g * ?g') * ka'" "?g* ?b' = (?g * ?g') * kb'" by simp_all
+ then have dvdgg':"?g * ?g' dvd a" "?g* ?g' dvd b"
+ by (auto simp add: zdvd_mult_div_cancel [OF dvdg(1)]
+ zdvd_mult_div_cancel [OF dvdg(2)] dvd_def)
+ have "?g \<noteq> 0" using nz by simp
+ then have gp: "?g \<noteq> 0" using zgcd_pos[where i="a" and j="b"] by arith
+ from zgcd_greatest [OF dvdgg'] have "?g * ?g' dvd ?g" .
+ with zdvd_mult_cancel1 [OF gp] have "\<bar>?g'\<bar> = 1" by simp
+ with zgcd_pos show "?g' = 1" by simp
+qed
+
+lemma zgcd_0 [simp, algebra]: "zgcd m 0 = abs m"
+ by (simp add: zgcd_def abs_if)
+
+lemma zgcd_0_left [simp, algebra]: "zgcd 0 m = abs m"
+ by (simp add: zgcd_def abs_if)
+
+lemma zgcd_non_0: "0 < n ==> zgcd m n = zgcd n (m mod n)"
+ apply (frule_tac b = n and a = m in pos_mod_sign)
+ apply (simp del: pos_mod_sign add: zgcd_def abs_if nat_mod_distrib)
+ apply (auto simp add: gcd_non_0 nat_mod_distrib [symmetric] zmod_zminus1_eq_if)
+ apply (frule_tac a = m in pos_mod_bound)
+ apply (simp del: pos_mod_bound add: nat_diff_distrib gcd_diff2 nat_le_eq_zle)
+ done
+
+lemma zgcd_eq: "zgcd m n = zgcd n (m mod n)"
+ apply (case_tac "n = 0", simp add: DIVISION_BY_ZERO)
+ apply (auto simp add: linorder_neq_iff zgcd_non_0)
+ apply (cut_tac m = "-m" and n = "-n" in zgcd_non_0, auto)
+ done
+
+lemma zgcd_1 [simp, algebra]: "zgcd m 1 = 1"
+ by (simp add: zgcd_def abs_if)
+
+lemma zgcd_0_1_iff [simp, algebra]: "zgcd 0 m = 1 \<longleftrightarrow> \<bar>m\<bar> = 1"
+ by (simp add: zgcd_def abs_if)
+
+lemma zgcd_greatest_iff[algebra]: "k dvd zgcd m n = (k dvd m \<and> k dvd n)"
+ by (simp add: zgcd_def abs_if int_dvd_iff dvd_int_iff nat_dvd_iff)
+
+lemma zgcd_1_left [simp, algebra]: "zgcd 1 m = 1"
+ by (simp add: zgcd_def gcd_1_left)
+
+lemma zgcd_assoc: "zgcd (zgcd k m) n = zgcd k (zgcd m n)"
+ by (simp add: zgcd_def gcd_assoc)
+
+lemma zgcd_left_commute: "zgcd k (zgcd m n) = zgcd m (zgcd k n)"
+ apply (rule zgcd_commute [THEN trans])
+ apply (rule zgcd_assoc [THEN trans])
+ apply (rule zgcd_commute [THEN arg_cong])
+ done
+
+lemmas zgcd_ac = zgcd_assoc zgcd_commute zgcd_left_commute
+ -- {* addition is an AC-operator *}
+
+lemma zgcd_zmult_distrib2: "0 \<le> k ==> k * zgcd m n = zgcd (k * m) (k * n)"
+ by (simp del: minus_mult_right [symmetric]
+ add: minus_mult_right nat_mult_distrib zgcd_def abs_if
+ mult_less_0_iff gcd_mult_distrib2 [symmetric] zmult_int [symmetric])
+
+lemma zgcd_zmult_distrib2_abs: "zgcd (k * m) (k * n) = abs k * zgcd m n"
+ by (simp add: abs_if zgcd_zmult_distrib2)
+
+lemma zgcd_self [simp]: "0 \<le> m ==> zgcd m m = m"
+ by (cut_tac k = m and m = 1 and n = 1 in zgcd_zmult_distrib2, simp_all)
+
+lemma zgcd_zmult_eq_self [simp]: "0 \<le> k ==> zgcd k (k * n) = k"
+ by (cut_tac k = k and m = 1 and n = n in zgcd_zmult_distrib2, simp_all)
+
+lemma zgcd_zmult_eq_self2 [simp]: "0 \<le> k ==> zgcd (k * n) k = k"
+ by (cut_tac k = k and m = n and n = 1 in zgcd_zmult_distrib2, simp_all)
+
+
+definition "zlcm i j = int (lcm(nat(abs i)) (nat(abs j)))"
+
+lemma dvd_zlcm_self1[simp, algebra]: "i dvd zlcm i j"
+by(simp add:zlcm_def dvd_int_iff)
+
+lemma dvd_zlcm_self2[simp, algebra]: "j dvd zlcm i j"
+by(simp add:zlcm_def dvd_int_iff)
+
+
+lemma dvd_imp_dvd_zlcm1:
+ assumes "k dvd i" shows "k dvd (zlcm i j)"
+proof -
+ have "nat(abs k) dvd nat(abs i)" using `k dvd i`
+ by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
+ thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
+qed
+
+lemma dvd_imp_dvd_zlcm2:
+ assumes "k dvd j" shows "k dvd (zlcm i j)"
+proof -
+ have "nat(abs k) dvd nat(abs j)" using `k dvd j`
+ by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
+ thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
+qed
+
+
+lemma zdvd_self_abs1: "(d::int) dvd (abs d)"
+by (case_tac "d <0", simp_all)
+
+lemma zdvd_self_abs2: "(abs (d::int)) dvd d"
+by (case_tac "d<0", simp_all)
+
+(* lcm a b is positive for positive a and b *)
+
+lemma lcm_pos:
+ assumes mpos: "m > 0"
+ and npos: "n>0"
+ shows "lcm m n > 0"
+proof(rule ccontr, simp add: lcm_def gcd_zero)
+assume h:"m*n div gcd m n = 0"
+from mpos npos have "gcd m n \<noteq> 0" using gcd_zero by simp
+hence gcdp: "gcd m n > 0" by simp
+with h
+have "m*n < gcd m n"
+ by (cases "m * n < gcd m n") (auto simp add: div_if[OF gcdp, where m="m*n"])
+moreover
+have "gcd m n dvd m" by simp
+ with mpos dvd_imp_le have t1:"gcd m n \<le> m" by simp
+ with npos have t1:"gcd m n *n \<le> m*n" by simp
+ have "gcd m n \<le> gcd m n*n" using npos by simp
+ with t1 have "gcd m n \<le> m*n" by arith
+ultimately show "False" by simp
+qed
+
+lemma zlcm_pos:
+ assumes anz: "a \<noteq> 0"
+ and bnz: "b \<noteq> 0"
+ shows "0 < zlcm a b"
+proof-
+ let ?na = "nat (abs a)"
+ let ?nb = "nat (abs b)"
+ have nap: "?na >0" using anz by simp
+ have nbp: "?nb >0" using bnz by simp
+ have "0 < lcm ?na ?nb" by (rule lcm_pos[OF nap nbp])
+ thus ?thesis by (simp add: zlcm_def)
+qed
+
+lemma zgcd_code [code]:
+ "zgcd k l = \<bar>if l = 0 then k else zgcd l (\<bar>k\<bar> mod \<bar>l\<bar>)\<bar>"
+ by (simp add: zgcd_def gcd.simps [of "nat \<bar>k\<bar>"] nat_mod_distrib)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Pocklington.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1263 @@
+(* Title: HOL/Library/Pocklington.thy
+ Author: Amine Chaieb
+*)
+
+header {* Pocklington's Theorem for Primes *}
+
+theory Pocklington
+imports Main Primes
+begin
+
+definition modeq:: "nat => nat => nat => bool" ("(1[_ = _] '(mod _'))")
+ where "[a = b] (mod p) == ((a mod p) = (b mod p))"
+
+definition modneq:: "nat => nat => nat => bool" ("(1[_ \<noteq> _] '(mod _'))")
+ where "[a \<noteq> b] (mod p) == ((a mod p) \<noteq> (b mod p))"
+
+lemma modeq_trans:
+ "\<lbrakk> [a = b] (mod p); [b = c] (mod p) \<rbrakk> \<Longrightarrow> [a = c] (mod p)"
+ by (simp add:modeq_def)
+
+
+lemma nat_mod_lemma: assumes xyn: "[x = y] (mod n)" and xy:"y \<le> x"
+ shows "\<exists>q. x = y + n * q"
+using xyn xy unfolding modeq_def using nat_mod_eq_lemma by blast
+
+lemma nat_mod[algebra]: "[x = y] (mod n) \<longleftrightarrow> (\<exists>q1 q2. x + n * q1 = y + n * q2)"
+unfolding modeq_def nat_mod_eq_iff ..
+
+(* Lemmas about previously defined terms. *)
+
+lemma prime: "prime p \<longleftrightarrow> p \<noteq> 0 \<and> p\<noteq>1 \<and> (\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m)"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume "p=0 \<or> p=1" hence ?thesis using prime_0 prime_1 by (cases "p=0", simp_all)}
+ moreover
+ {assume p0: "p\<noteq>0" "p\<noteq>1"
+ {assume H: "?lhs"
+ {fix m assume m: "m > 0" "m < p"
+ {assume "m=1" hence "coprime p m" by simp}
+ moreover
+ {assume "p dvd m" hence "p \<le> m" using dvd_imp_le m by blast with m(2)
+ have "coprime p m" by simp}
+ ultimately have "coprime p m" using prime_coprime[OF H, of m] by blast}
+ hence ?rhs using p0 by auto}
+ moreover
+ { assume H: "\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m"
+ from prime_factor[OF p0(2)] obtain q where q: "prime q" "q dvd p" by blast
+ from prime_ge_2[OF q(1)] have q0: "q > 0" by arith
+ from dvd_imp_le[OF q(2)] p0 have qp: "q \<le> p" by arith
+ {assume "q = p" hence ?lhs using q(1) by blast}
+ moreover
+ {assume "q\<noteq>p" with qp have qplt: "q < p" by arith
+ from H[rule_format, of q] qplt q0 have "coprime p q" by arith
+ with coprime_prime[of p q q] q have False by simp hence ?lhs by blast}
+ ultimately have ?lhs by blast}
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by (cases"p=0 \<or> p=1", auto)
+qed
+
+lemma finite_number_segment: "card { m. 0 < m \<and> m < n } = n - 1"
+proof-
+ have "{ m. 0 < m \<and> m < n } = {1..<n}" by auto
+ thus ?thesis by simp
+qed
+
+lemma coprime_mod: assumes n: "n \<noteq> 0" shows "coprime (a mod n) n \<longleftrightarrow> coprime a n"
+ using n dvd_mod_iff[of _ n a] by (auto simp add: coprime)
+
+(* Congruences. *)
+
+lemma cong_mod_01[simp,presburger]:
+ "[x = y] (mod 0) \<longleftrightarrow> x = y" "[x = y] (mod 1)" "[x = 0] (mod n) \<longleftrightarrow> n dvd x"
+ by (simp_all add: modeq_def, presburger)
+
+lemma cong_sub_cases:
+ "[x = y] (mod n) \<longleftrightarrow> (if x <= y then [y - x = 0] (mod n) else [x - y = 0] (mod n))"
+apply (auto simp add: nat_mod)
+apply (rule_tac x="q2" in exI)
+apply (rule_tac x="q1" in exI, simp)
+apply (rule_tac x="q2" in exI)
+apply (rule_tac x="q1" in exI, simp)
+apply (rule_tac x="q1" in exI)
+apply (rule_tac x="q2" in exI, simp)
+apply (rule_tac x="q1" in exI)
+apply (rule_tac x="q2" in exI, simp)
+done
+
+lemma cong_mult_lcancel: assumes an: "coprime a n" and axy:"[a * x = a * y] (mod n)"
+ shows "[x = y] (mod n)"
+proof-
+ {assume "a = 0" with an axy coprime_0'[of n] have ?thesis by (simp add: modeq_def) }
+ moreover
+ {assume az: "a\<noteq>0"
+ {assume xy: "x \<le> y" hence axy': "a*x \<le> a*y" by simp
+ with axy cong_sub_cases[of "a*x" "a*y" n] have "[a*(y - x) = 0] (mod n)"
+ by (simp only: if_True diff_mult_distrib2)
+ hence th: "n dvd a*(y -x)" by simp
+ from coprime_divprod[OF th] an have "n dvd y - x"
+ by (simp add: coprime_commute)
+ hence ?thesis using xy cong_sub_cases[of x y n] by simp}
+ moreover
+ {assume H: "\<not>x \<le> y" hence xy: "y \<le> x" by arith
+ from H az have axy': "\<not> a*x \<le> a*y" by auto
+ with axy H cong_sub_cases[of "a*x" "a*y" n] have "[a*(x - y) = 0] (mod n)"
+ by (simp only: if_False diff_mult_distrib2)
+ hence th: "n dvd a*(x - y)" by simp
+ from coprime_divprod[OF th] an have "n dvd x - y"
+ by (simp add: coprime_commute)
+ hence ?thesis using xy cong_sub_cases[of x y n] by simp}
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma cong_mult_rcancel: assumes an: "coprime a n" and axy:"[x*a = y*a] (mod n)"
+ shows "[x = y] (mod n)"
+ using cong_mult_lcancel[OF an axy[unfolded mult_commute[of _a]]] .
+
+lemma cong_refl: "[x = x] (mod n)" by (simp add: modeq_def)
+
+lemma eq_imp_cong: "a = b \<Longrightarrow> [a = b] (mod n)" by (simp add: cong_refl)
+
+lemma cong_commute: "[x = y] (mod n) \<longleftrightarrow> [y = x] (mod n)"
+ by (auto simp add: modeq_def)
+
+lemma cong_trans[trans]: "[x = y] (mod n) \<Longrightarrow> [y = z] (mod n) \<Longrightarrow> [x = z] (mod n)"
+ by (simp add: modeq_def)
+
+lemma cong_add: assumes xx': "[x = x'] (mod n)" and yy':"[y = y'] (mod n)"
+ shows "[x + y = x' + y'] (mod n)"
+proof-
+ have "(x + y) mod n = (x mod n + y mod n) mod n"
+ by (simp add: mod_add_left_eq[of x y n] mod_add_right_eq[of "x mod n" y n])
+ also have "\<dots> = (x' mod n + y' mod n) mod n" using xx' yy' modeq_def by simp
+ also have "\<dots> = (x' + y') mod n"
+ by (simp add: mod_add_left_eq[of x' y' n] mod_add_right_eq[of "x' mod n" y' n])
+ finally show ?thesis unfolding modeq_def .
+qed
+
+lemma cong_mult: assumes xx': "[x = x'] (mod n)" and yy':"[y = y'] (mod n)"
+ shows "[x * y = x' * y'] (mod n)"
+proof-
+ have "(x * y) mod n = (x mod n) * (y mod n) mod n"
+ by (simp add: mod_mult_left_eq[of x y n] mod_mult_right_eq[of "x mod n" y n])
+ also have "\<dots> = (x' mod n) * (y' mod n) mod n" using xx'[unfolded modeq_def] yy'[unfolded modeq_def] by simp
+ also have "\<dots> = (x' * y') mod n"
+ by (simp add: mod_mult_left_eq[of x' y' n] mod_mult_right_eq[of "x' mod n" y' n])
+ finally show ?thesis unfolding modeq_def .
+qed
+
+lemma cong_exp: "[x = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
+ by (induct k, auto simp add: cong_refl cong_mult)
+lemma cong_sub: assumes xx': "[x = x'] (mod n)" and yy': "[y = y'] (mod n)"
+ and yx: "y <= x" and yx': "y' <= x'"
+ shows "[x - y = x' - y'] (mod n)"
+proof-
+ { fix x a x' a' y b y' b'
+ have "(x::nat) + a = x' + a' \<Longrightarrow> y + b = y' + b' \<Longrightarrow> y <= x \<Longrightarrow> y' <= x'
+ \<Longrightarrow> (x - y) + (a + b') = (x' - y') + (a' + b)" by arith}
+ note th = this
+ from xx' yy' obtain q1 q2 q1' q2' where q12: "x + n*q1 = x'+n*q2"
+ and q12': "y + n*q1' = y'+n*q2'" unfolding nat_mod by blast+
+ from th[OF q12 q12' yx yx']
+ have "(x - y) + n*(q1 + q2') = (x' - y') + n*(q2 + q1')"
+ by (simp add: right_distrib)
+ thus ?thesis unfolding nat_mod by blast
+qed
+
+lemma cong_mult_lcancel_eq: assumes an: "coprime a n"
+ shows "[a * x = a * y] (mod n) \<longleftrightarrow> [x = y] (mod n)" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume H: "?rhs" from cong_mult[OF cong_refl[of a n] H] show ?lhs .
+next
+ assume H: "?lhs" hence H': "[x*a = y*a] (mod n)" by (simp add: mult_commute)
+ from cong_mult_rcancel[OF an H'] show ?rhs .
+qed
+
+lemma cong_mult_rcancel_eq: assumes an: "coprime a n"
+ shows "[x * a = y * a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+using cong_mult_lcancel_eq[OF an, of x y] by (simp add: mult_commute)
+
+lemma cong_add_lcancel_eq: "[a + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_add_rcancel_eq: "[x + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_add_rcancel: "[x + a = y + a] (mod n) \<Longrightarrow> [x = y] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_add_lcancel: "[a + x = a + y] (mod n) \<Longrightarrow> [x = y] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_add_lcancel_eq_0: "[a + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_add_rcancel_eq_0: "[x + a = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
+ by (simp add: nat_mod)
+
+lemma cong_imp_eq: assumes xn: "x < n" and yn: "y < n" and xy: "[x = y] (mod n)"
+ shows "x = y"
+ using xy[unfolded modeq_def mod_less[OF xn] mod_less[OF yn]] .
+
+lemma cong_divides_modulus: "[x = y] (mod m) \<Longrightarrow> n dvd m ==> [x = y] (mod n)"
+ apply (auto simp add: nat_mod dvd_def)
+ apply (rule_tac x="k*q1" in exI)
+ apply (rule_tac x="k*q2" in exI)
+ by simp
+
+lemma cong_0_divides: "[x = 0] (mod n) \<longleftrightarrow> n dvd x" by simp
+
+lemma cong_1_divides:"[x = 1] (mod n) ==> n dvd x - 1"
+ apply (cases "x\<le>1", simp_all)
+ using cong_sub_cases[of x 1 n] by auto
+
+lemma cong_divides: "[x = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
+apply (auto simp add: nat_mod dvd_def)
+apply (rule_tac x="k + q1 - q2" in exI, simp add: add_mult_distrib2 diff_mult_distrib2)
+apply (rule_tac x="k + q2 - q1" in exI, simp add: add_mult_distrib2 diff_mult_distrib2)
+done
+
+lemma cong_coprime: assumes xy: "[x = y] (mod n)"
+ shows "coprime n x \<longleftrightarrow> coprime n y"
+proof-
+ {assume "n=0" hence ?thesis using xy by simp}
+ moreover
+ {assume nz: "n \<noteq> 0"
+ have "coprime n x \<longleftrightarrow> coprime (x mod n) n"
+ by (simp add: coprime_mod[OF nz, of x] coprime_commute[of n x])
+ also have "\<dots> \<longleftrightarrow> coprime (y mod n) n" using xy[unfolded modeq_def] by simp
+ also have "\<dots> \<longleftrightarrow> coprime y n" by (simp add: coprime_mod[OF nz, of y])
+ finally have ?thesis by (simp add: coprime_commute) }
+ultimately show ?thesis by blast
+qed
+
+lemma cong_mod: "~(n = 0) \<Longrightarrow> [a mod n = a] (mod n)" by (simp add: modeq_def)
+
+lemma mod_mult_cong: "~(a = 0) \<Longrightarrow> ~(b = 0)
+ \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
+ by (simp add: modeq_def mod_mult2_eq mod_add_left_eq)
+
+lemma cong_mod_mult: "[x = y] (mod n) \<Longrightarrow> m dvd n \<Longrightarrow> [x = y] (mod m)"
+ apply (auto simp add: nat_mod dvd_def)
+ apply (rule_tac x="k*q1" in exI)
+ apply (rule_tac x="k*q2" in exI, simp)
+ done
+
+(* Some things when we know more about the order. *)
+
+lemma cong_le: "y <= x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
+ using nat_mod_lemma[of x y n]
+ apply auto
+ apply (simp add: nat_mod)
+ apply (rule_tac x="q" in exI)
+ apply (rule_tac x="q + q" in exI)
+ by (auto simp: algebra_simps)
+
+lemma cong_to_1: "[a = 1] (mod n) \<longleftrightarrow> a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
+proof-
+ {assume "n = 0 \<or> n = 1\<or> a = 0 \<or> a = 1" hence ?thesis
+ apply (cases "n=0", simp_all add: cong_commute)
+ apply (cases "n=1", simp_all add: cong_commute modeq_def)
+ apply arith
+ by (cases "a=1", simp_all add: modeq_def cong_commute)}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1" and a:"a\<noteq>0" "a \<noteq> 1" hence a': "a \<ge> 1" by simp
+ hence ?thesis using cong_le[OF a', of n] by auto }
+ ultimately show ?thesis by auto
+qed
+
+(* Some basic theorems about solving congruences. *)
+
+
+lemma cong_solve: assumes an: "coprime a n" shows "\<exists>x. [a * x = b] (mod n)"
+proof-
+ {assume "a=0" hence ?thesis using an by (simp add: modeq_def)}
+ moreover
+ {assume az: "a\<noteq>0"
+ from bezout_add_strong[OF az, of n]
+ obtain d x y where dxy: "d dvd a" "d dvd n" "a*x = n*y + d" by blast
+ from an[unfolded coprime, rule_format, of d] dxy(1,2) have d1: "d = 1" by blast
+ hence "a*x*b = (n*y + 1)*b" using dxy(3) by simp
+ hence "a*(x*b) = n*(y*b) + b" by algebra
+ hence "a*(x*b) mod n = (n*(y*b) + b) mod n" by simp
+ hence "a*(x*b) mod n = b mod n" by (simp add: mod_add_left_eq)
+ hence "[a*(x*b) = b] (mod n)" unfolding modeq_def .
+ hence ?thesis by blast}
+ultimately show ?thesis by blast
+qed
+
+lemma cong_solve_unique: assumes an: "coprime a n" and nz: "n \<noteq> 0"
+ shows "\<exists>!x. x < n \<and> [a * x = b] (mod n)"
+proof-
+ let ?P = "\<lambda>x. x < n \<and> [a * x = b] (mod n)"
+ from cong_solve[OF an] obtain x where x: "[a*x = b] (mod n)" by blast
+ let ?x = "x mod n"
+ from x have th: "[a * ?x = b] (mod n)"
+ by (simp add: modeq_def mod_mult_right_eq[of a x n])
+ from mod_less_divisor[ of n x] nz th have Px: "?P ?x" by simp
+ {fix y assume Py: "y < n" "[a * y = b] (mod n)"
+ from Py(2) th have "[a * y = a*?x] (mod n)" by (simp add: modeq_def)
+ hence "[y = ?x] (mod n)" by (simp add: cong_mult_lcancel_eq[OF an])
+ with mod_less[OF Py(1)] mod_less_divisor[ of n x] nz
+ have "y = ?x" by (simp add: modeq_def)}
+ with Px show ?thesis by blast
+qed
+
+lemma cong_solve_unique_nontrivial:
+ assumes p: "prime p" and pa: "coprime p a" and x0: "0 < x" and xp: "x < p"
+ shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = a] (mod p)"
+proof-
+ from p have p1: "p > 1" using prime_ge_2[OF p] by arith
+ hence p01: "p \<noteq> 0" "p \<noteq> 1" by arith+
+ from pa have ap: "coprime a p" by (simp add: coprime_commute)
+ from prime_coprime[OF p, of x] dvd_imp_le[of p x] x0 xp have px:"coprime x p"
+ by (auto simp add: coprime_commute)
+ from cong_solve_unique[OF px p01(1)]
+ obtain y where y: "y < p" "[x * y = a] (mod p)" "\<forall>z. z < p \<and> [x * z = a] (mod p) \<longrightarrow> z = y" by blast
+ {assume y0: "y = 0"
+ with y(2) have th: "p dvd a" by (simp add: cong_commute[of 0 a p])
+ with p coprime_prime[OF pa, of p] have False by simp}
+ with y show ?thesis unfolding Ex1_def using neq0_conv by blast
+qed
+lemma cong_unique_inverse_prime:
+ assumes p: "prime p" and x0: "0 < x" and xp: "x < p"
+ shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = 1] (mod p)"
+ using cong_solve_unique_nontrivial[OF p coprime_1[of p] x0 xp] .
+
+(* Forms of the Chinese remainder theorem. *)
+
+lemma cong_chinese:
+ assumes ab: "coprime a b" and xya: "[x = y] (mod a)"
+ and xyb: "[x = y] (mod b)"
+ shows "[x = y] (mod a*b)"
+ using ab xya xyb
+ by (simp add: cong_sub_cases[of x y a] cong_sub_cases[of x y b]
+ cong_sub_cases[of x y "a*b"])
+(cases "x \<le> y", simp_all add: divides_mul[of a _ b])
+
+lemma chinese_remainder_unique:
+ assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b\<noteq>0"
+ shows "\<exists>!x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
+proof-
+ from az bz have abpos: "a*b > 0" by simp
+ from chinese_remainder[OF ab az bz] obtain x q1 q2 where
+ xq12: "x = m + q1 * a" "x = n + q2 * b" by blast
+ let ?w = "x mod (a*b)"
+ have wab: "?w < a*b" by (simp add: mod_less_divisor[OF abpos])
+ from xq12(1) have "?w mod a = ((m + q1 * a) mod (a*b)) mod a" by simp
+ also have "\<dots> = m mod a" apply (simp add: mod_mult2_eq)
+ apply (subst mod_add_left_eq)
+ by simp
+ finally have th1: "[?w = m] (mod a)" by (simp add: modeq_def)
+ from xq12(2) have "?w mod b = ((n + q2 * b) mod (a*b)) mod b" by simp
+ also have "\<dots> = ((n + q2 * b) mod (b*a)) mod b" by (simp add: mult_commute)
+ also have "\<dots> = n mod b" apply (simp add: mod_mult2_eq)
+ apply (subst mod_add_left_eq)
+ by simp
+ finally have th2: "[?w = n] (mod b)" by (simp add: modeq_def)
+ {fix y assume H: "y < a*b" "[y = m] (mod a)" "[y = n] (mod b)"
+ with th1 th2 have H': "[y = ?w] (mod a)" "[y = ?w] (mod b)"
+ by (simp_all add: modeq_def)
+ from cong_chinese[OF ab H'] mod_less[OF H(1)] mod_less[OF wab]
+ have "y = ?w" by (simp add: modeq_def)}
+ with th1 th2 wab show ?thesis by blast
+qed
+
+lemma chinese_remainder_coprime_unique:
+ assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b \<noteq> 0"
+ and ma: "coprime m a" and nb: "coprime n b"
+ shows "\<exists>!x. coprime x (a * b) \<and> x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
+proof-
+ let ?P = "\<lambda>x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
+ from chinese_remainder_unique[OF ab az bz]
+ obtain x where x: "x < a * b" "[x = m] (mod a)" "[x = n] (mod b)"
+ "\<forall>y. ?P y \<longrightarrow> y = x" by blast
+ from ma nb cong_coprime[OF x(2)] cong_coprime[OF x(3)]
+ have "coprime x a" "coprime x b" by (simp_all add: coprime_commute)
+ with coprime_mul[of x a b] have "coprime x (a*b)" by simp
+ with x show ?thesis by blast
+qed
+
+(* Euler totient function. *)
+
+definition phi_def: "\<phi> n = card { m. 0 < m \<and> m <= n \<and> coprime m n }"
+
+lemma phi_0[simp]: "\<phi> 0 = 0"
+ unfolding phi_def by auto
+
+lemma phi_finite[simp]: "finite ({ m. 0 < m \<and> m <= n \<and> coprime m n })"
+proof-
+ have "{ m. 0 < m \<and> m <= n \<and> coprime m n } \<subseteq> {0..n}" by auto
+ thus ?thesis by (auto intro: finite_subset)
+qed
+
+declare coprime_1[presburger]
+lemma phi_1[simp]: "\<phi> 1 = 1"
+proof-
+ {fix m
+ have "0 < m \<and> m <= 1 \<and> coprime m 1 \<longleftrightarrow> m = 1" by presburger }
+ thus ?thesis by (simp add: phi_def)
+qed
+
+lemma [simp]: "\<phi> (Suc 0) = Suc 0" using phi_1 by simp
+
+lemma phi_alt: "\<phi>(n) = card { m. coprime m n \<and> m < n}"
+proof-
+ {assume "n=0 \<or> n=1" hence ?thesis by (cases "n=0", simp_all)}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ {fix m
+ from n have "0 < m \<and> m <= n \<and> coprime m n \<longleftrightarrow> coprime m n \<and> m < n"
+ apply (cases "m = 0", simp_all)
+ apply (cases "m = 1", simp_all)
+ apply (cases "m = n", auto)
+ done }
+ hence ?thesis unfolding phi_def by simp}
+ ultimately show ?thesis by auto
+qed
+
+lemma phi_finite_lemma[simp]: "finite {m. coprime m n \<and> m < n}" (is "finite ?S")
+ by (rule finite_subset[of "?S" "{0..n}"], auto)
+
+lemma phi_another: assumes n: "n\<noteq>1"
+ shows "\<phi> n = card {m. 0 < m \<and> m < n \<and> coprime m n }"
+proof-
+ {fix m
+ from n have "0 < m \<and> m < n \<and> coprime m n \<longleftrightarrow> coprime m n \<and> m < n"
+ by (cases "m=0", auto)}
+ thus ?thesis unfolding phi_alt by auto
+qed
+
+lemma phi_limit: "\<phi> n \<le> n"
+proof-
+ have "{ m. coprime m n \<and> m < n} \<subseteq> {0 ..<n}" by auto
+ with card_mono[of "{0 ..<n}" "{ m. coprime m n \<and> m < n}"]
+ show ?thesis unfolding phi_alt by auto
+qed
+
+lemma stupid[simp]: "{m. (0::nat) < m \<and> m < n} = {1..<n}"
+ by auto
+
+lemma phi_limit_strong: assumes n: "n\<noteq>1"
+ shows "\<phi>(n) \<le> n - 1"
+proof-
+ show ?thesis
+ unfolding phi_another[OF n] finite_number_segment[of n, symmetric]
+ by (rule card_mono[of "{m. 0 < m \<and> m < n}" "{m. 0 < m \<and> m < n \<and> coprime m n}"], auto)
+qed
+
+lemma phi_lowerbound_1_strong: assumes n: "n \<ge> 1"
+ shows "\<phi>(n) \<ge> 1"
+proof-
+ let ?S = "{ m. 0 < m \<and> m <= n \<and> coprime m n }"
+ from card_0_eq[of ?S] n have "\<phi> n \<noteq> 0" unfolding phi_alt
+ apply auto
+ apply (cases "n=1", simp_all)
+ apply (rule exI[where x=1], simp)
+ done
+ thus ?thesis by arith
+qed
+
+lemma phi_lowerbound_1: "2 <= n ==> 1 <= \<phi>(n)"
+ using phi_lowerbound_1_strong[of n] by auto
+
+lemma phi_lowerbound_2: assumes n: "3 <= n" shows "2 <= \<phi> (n)"
+proof-
+ let ?S = "{ m. 0 < m \<and> m <= n \<and> coprime m n }"
+ have inS: "{1, n - 1} \<subseteq> ?S" using n coprime_plus1[of "n - 1"]
+ by (auto simp add: coprime_commute)
+ from n have c2: "card {1, n - 1} = 2" by (auto simp add: card_insert_if)
+ from card_mono[of ?S "{1, n - 1}", simplified inS c2] show ?thesis
+ unfolding phi_def by auto
+qed
+
+lemma phi_prime: "\<phi> n = n - 1 \<and> n\<noteq>0 \<and> n\<noteq>1 \<longleftrightarrow> prime n"
+proof-
+ {assume "n=0 \<or> n=1" hence ?thesis by (cases "n=1", simp_all)}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ let ?S = "{m. 0 < m \<and> m < n}"
+ have fS: "finite ?S" by simp
+ let ?S' = "{m. 0 < m \<and> m < n \<and> coprime m n}"
+ have fS':"finite ?S'" apply (rule finite_subset[of ?S' ?S]) by auto
+ {assume H: "\<phi> n = n - 1 \<and> n\<noteq>0 \<and> n\<noteq>1"
+ hence ceq: "card ?S' = card ?S"
+ using n finite_number_segment[of n] phi_another[OF n(2)] by simp
+ {fix m assume m: "0 < m" "m < n" "\<not> coprime m n"
+ hence mS': "m \<notin> ?S'" by auto
+ have "insert m ?S' \<le> ?S" using m by auto
+ from m have "card (insert m ?S') \<le> card ?S"
+ by - (rule card_mono[of ?S "insert m ?S'"], auto)
+ hence False
+ unfolding card_insert_disjoint[of "?S'" m, OF fS' mS'] ceq
+ by simp }
+ hence "\<forall>m. 0 <m \<and> m < n \<longrightarrow> coprime m n" by blast
+ hence "prime n" unfolding prime using n by (simp add: coprime_commute)}
+ moreover
+ {assume H: "prime n"
+ hence "?S = ?S'" unfolding prime using n
+ by (auto simp add: coprime_commute)
+ hence "card ?S = card ?S'" by simp
+ hence "\<phi> n = n - 1" unfolding phi_another[OF n(2)] by simp}
+ ultimately have ?thesis using n by blast}
+ ultimately show ?thesis by (cases "n=0") blast+
+qed
+
+(* Multiplicativity property. *)
+
+lemma phi_multiplicative: assumes ab: "coprime a b"
+ shows "\<phi> (a * b) = \<phi> a * \<phi> b"
+proof-
+ {assume "a = 0 \<or> b = 0 \<or> a = 1 \<or> b = 1"
+ hence ?thesis
+ by (cases "a=0", simp, cases "b=0", simp, cases"a=1", simp_all) }
+ moreover
+ {assume a: "a\<noteq>0" "a\<noteq>1" and b: "b\<noteq>0" "b\<noteq>1"
+ hence ab0: "a*b \<noteq> 0" by simp
+ let ?S = "\<lambda>k. {m. coprime m k \<and> m < k}"
+ let ?f = "\<lambda>x. (x mod a, x mod b)"
+ have eq: "?f ` (?S (a*b)) = (?S a \<times> ?S b)"
+ proof-
+ {fix x assume x:"x \<in> ?S (a*b)"
+ hence x': "coprime x (a*b)" "x < a*b" by simp_all
+ hence xab: "coprime x a" "coprime x b" by (simp_all add: coprime_mul_eq)
+ from mod_less_divisor a b have xab':"x mod a < a" "x mod b < b" by auto
+ from xab xab' have "?f x \<in> (?S a \<times> ?S b)"
+ by (simp add: coprime_mod[OF a(1)] coprime_mod[OF b(1)])}
+ moreover
+ {fix x y assume x: "x \<in> ?S a" and y: "y \<in> ?S b"
+ hence x': "coprime x a" "x < a" and y': "coprime y b" "y < b" by simp_all
+ from chinese_remainder_coprime_unique[OF ab a(1) b(1) x'(1) y'(1)]
+ obtain z where z: "coprime z (a * b)" "z < a * b" "[z = x] (mod a)"
+ "[z = y] (mod b)" by blast
+ hence "(x,y) \<in> ?f ` (?S (a*b))"
+ using y'(2) mod_less_divisor[of b y] x'(2) mod_less_divisor[of a x]
+ by (auto simp add: image_iff modeq_def)}
+ ultimately show ?thesis by auto
+ qed
+ have finj: "inj_on ?f (?S (a*b))"
+ unfolding inj_on_def
+ proof(clarify)
+ fix x y assume H: "coprime x (a * b)" "x < a * b" "coprime y (a * b)"
+ "y < a * b" "x mod a = y mod a" "x mod b = y mod b"
+ hence cp: "coprime x a" "coprime x b" "coprime y a" "coprime y b"
+ by (simp_all add: coprime_mul_eq)
+ from chinese_remainder_coprime_unique[OF ab a(1) b(1) cp(3,4)] H
+ show "x = y" unfolding modeq_def by blast
+ qed
+ from card_image[OF finj, unfolded eq] have ?thesis
+ unfolding phi_alt by simp }
+ ultimately show ?thesis by auto
+qed
+
+(* Fermat's Little theorem / Fermat-Euler theorem. *)
+
+
+lemma nproduct_mod:
+ assumes fS: "finite S" and n0: "n \<noteq> 0"
+ shows "[setprod (\<lambda>m. a(m) mod n) S = setprod a S] (mod n)"
+proof-
+ have th1:"[1 = 1] (mod n)" by (simp add: modeq_def)
+ from cong_mult
+ have th3:"\<forall>x1 y1 x2 y2.
+ [x1 = x2] (mod n) \<and> [y1 = y2] (mod n) \<longrightarrow> [x1 * y1 = x2 * y2] (mod n)"
+ by blast
+ have th4:"\<forall>x\<in>S. [a x mod n = a x] (mod n)" by (simp add: modeq_def)
+ from fold_image_related[where h="(\<lambda>m. a(m) mod n)" and g=a, OF th1 th3 fS, OF th4] show ?thesis unfolding setprod_def by (simp add: fS)
+qed
+
+lemma nproduct_cmul:
+ assumes fS:"finite S"
+ shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult})* a(m)) S = c ^ (card S) * setprod a S"
+unfolding setprod_timesf setprod_constant[OF fS, of c] ..
+
+lemma coprime_nproduct:
+ assumes fS: "finite S" and Sn: "\<forall>x\<in>S. coprime n (a x)"
+ shows "coprime n (setprod a S)"
+ using fS unfolding setprod_def by (rule finite_subset_induct)
+ (insert Sn, auto simp add: coprime_mul)
+
+lemma fermat_little: assumes an: "coprime a n"
+ shows "[a ^ (\<phi> n) = 1] (mod n)"
+proof-
+ {assume "n=0" hence ?thesis by simp}
+ moreover
+ {assume "n=1" hence ?thesis by (simp add: modeq_def)}
+ moreover
+ {assume nz: "n \<noteq> 0" and n1: "n \<noteq> 1"
+ let ?S = "{m. coprime m n \<and> m < n}"
+ let ?P = "\<Prod> ?S"
+ have fS: "finite ?S" by simp
+ have cardfS: "\<phi> n = card ?S" unfolding phi_alt ..
+ {fix m assume m: "m \<in> ?S"
+ hence "coprime m n" by simp
+ with coprime_mul[of n a m] an have "coprime (a*m) n"
+ by (simp add: coprime_commute)}
+ hence Sn: "\<forall>m\<in> ?S. coprime (a*m) n " by blast
+ from coprime_nproduct[OF fS, of n "\<lambda>m. m"] have nP:"coprime ?P n"
+ by (simp add: coprime_commute)
+ have Paphi: "[?P*a^ (\<phi> n) = ?P*1] (mod n)"
+ proof-
+ let ?h = "\<lambda>m. m mod n"
+ {fix m assume mS: "m\<in> ?S"
+ hence "?h m \<in> ?S" by simp}
+ hence hS: "?h ` ?S = ?S"by (auto simp add: image_iff)
+ have "a\<noteq>0" using an n1 nz apply- apply (rule ccontr) by simp
+ hence inj: "inj_on (op * a) ?S" unfolding inj_on_def by simp
+
+ have eq0: "fold_image op * (?h \<circ> op * a) 1 {m. coprime m n \<and> m < n} =
+ fold_image op * (\<lambda>m. m) 1 {m. coprime m n \<and> m < n}"
+ proof (rule fold_image_eq_general[where h="?h o (op * a)"])
+ show "finite ?S" using fS .
+ next
+ {fix y assume yS: "y \<in> ?S" hence y: "coprime y n" "y < n" by simp_all
+ from cong_solve_unique[OF an nz, of y]
+ obtain x where x:"x < n" "[a * x = y] (mod n)" "\<forall>z. z < n \<and> [a * z = y] (mod n) \<longrightarrow> z=x" by blast
+ from cong_coprime[OF x(2)] y(1)
+ have xm: "coprime x n" by (simp add: coprime_mul_eq coprime_commute)
+ {fix z assume "z \<in> ?S" "(?h \<circ> op * a) z = y"
+ hence z: "coprime z n" "z < n" "(?h \<circ> op * a) z = y" by simp_all
+ from x(3)[rule_format, of z] z(2,3) have "z=x"
+ unfolding modeq_def mod_less[OF y(2)] by simp}
+ with xm x(1,2) have "\<exists>!x. x \<in> ?S \<and> (?h \<circ> op * a) x = y"
+ unfolding modeq_def mod_less[OF y(2)] by auto }
+ thus "\<forall>y\<in>{m. coprime m n \<and> m < n}.
+ \<exists>!x. x \<in> {m. coprime m n \<and> m < n} \<and> ((\<lambda>m. m mod n) \<circ> op * a) x = y" by blast
+ next
+ {fix x assume xS: "x\<in> ?S"
+ hence x: "coprime x n" "x < n" by simp_all
+ with an have "coprime (a*x) n"
+ by (simp add: coprime_mul_eq[of n a x] coprime_commute)
+ hence "?h (a*x) \<in> ?S" using nz
+ by (simp add: coprime_mod[OF nz] mod_less_divisor)}
+ thus " \<forall>x\<in>{m. coprime m n \<and> m < n}.
+ ((\<lambda>m. m mod n) \<circ> op * a) x \<in> {m. coprime m n \<and> m < n} \<and>
+ ((\<lambda>m. m mod n) \<circ> op * a) x = ((\<lambda>m. m mod n) \<circ> op * a) x" by simp
+ qed
+ from nproduct_mod[OF fS nz, of "op * a"]
+ have "[(setprod (op *a) ?S) = (setprod (?h o (op * a)) ?S)] (mod n)"
+ unfolding o_def
+ by (simp add: cong_commute)
+ also have "[setprod (?h o (op * a)) ?S = ?P ] (mod n)"
+ using eq0 fS an by (simp add: setprod_def modeq_def o_def)
+ finally show "[?P*a^ (\<phi> n) = ?P*1] (mod n)"
+ unfolding cardfS mult_commute[of ?P "a^ (card ?S)"]
+ nproduct_cmul[OF fS, symmetric] mult_1_right by simp
+ qed
+ from cong_mult_lcancel[OF nP Paphi] have ?thesis . }
+ ultimately show ?thesis by blast
+qed
+
+lemma fermat_little_prime: assumes p: "prime p" and ap: "coprime a p"
+ shows "[a^ (p - 1) = 1] (mod p)"
+ using fermat_little[OF ap] p[unfolded phi_prime[symmetric]]
+by simp
+
+
+(* Lucas's theorem. *)
+
+lemma lucas_coprime_lemma:
+ assumes m: "m\<noteq>0" and am: "[a^m = 1] (mod n)"
+ shows "coprime a n"
+proof-
+ {assume "n=1" hence ?thesis by simp}
+ moreover
+ {assume "n = 0" hence ?thesis using am m exp_eq_1[of a m] by simp}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ from m obtain m' where m': "m = Suc m'" by (cases m, blast+)
+ {fix d
+ assume d: "d dvd a" "d dvd n"
+ from n have n1: "1 < n" by arith
+ from am mod_less[OF n1] have am1: "a^m mod n = 1" unfolding modeq_def by simp
+ from dvd_mult2[OF d(1), of "a^m'"] have dam:"d dvd a^m" by (simp add: m')
+ from dvd_mod_iff[OF d(2), of "a^m"] dam am1
+ have "d = 1" by simp }
+ hence ?thesis unfolding coprime by auto
+ }
+ ultimately show ?thesis by blast
+qed
+
+lemma lucas_weak:
+ assumes n: "n \<ge> 2" and an:"[a^(n - 1) = 1] (mod n)"
+ and nm: "\<forall>m. 0 <m \<and> m < n - 1 \<longrightarrow> \<not> [a^m = 1] (mod n)"
+ shows "prime n"
+proof-
+ from n have n1: "n \<noteq> 1" "n\<noteq>0" "n - 1 \<noteq> 0" "n - 1 > 0" "n - 1 < n" by arith+
+ from lucas_coprime_lemma[OF n1(3) an] have can: "coprime a n" .
+ from fermat_little[OF can] have afn: "[a ^ \<phi> n = 1] (mod n)" .
+ {assume "\<phi> n \<noteq> n - 1"
+ with phi_limit_strong[OF n1(1)] phi_lowerbound_1[OF n]
+ have c:"\<phi> n > 0 \<and> \<phi> n < n - 1" by arith
+ from nm[rule_format, OF c] afn have False ..}
+ hence "\<phi> n = n - 1" by blast
+ with phi_prime[of n] n1(1,2) show ?thesis by simp
+qed
+
+lemma nat_exists_least_iff: "(\<exists>(n::nat). P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume ?rhs thus ?lhs by blast
+next
+ assume H: ?lhs then obtain n where n: "P n" by blast
+ let ?x = "Least P"
+ {fix m assume m: "m < ?x"
+ from not_less_Least[OF m] have "\<not> P m" .}
+ with LeastI_ex[OF H] show ?rhs by blast
+qed
+
+lemma nat_exists_least_iff': "(\<exists>(n::nat). P n) \<longleftrightarrow> (P (Least P) \<and> (\<forall>m < (Least P). \<not> P m))"
+ (is "?lhs \<longleftrightarrow> ?rhs")
+proof-
+ {assume ?rhs hence ?lhs by blast}
+ moreover
+ { assume H: ?lhs then obtain n where n: "P n" by blast
+ let ?x = "Least P"
+ {fix m assume m: "m < ?x"
+ from not_less_Least[OF m] have "\<not> P m" .}
+ with LeastI_ex[OF H] have ?rhs by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma power_mod: "((x::nat) mod m)^n mod m = x^n mod m"
+proof(induct n)
+ case 0 thus ?case by simp
+next
+ case (Suc n)
+ have "(x mod m)^(Suc n) mod m = ((x mod m) * (((x mod m) ^ n) mod m)) mod m"
+ by (simp add: mod_mult_right_eq[symmetric])
+ also have "\<dots> = ((x mod m) * (x^n mod m)) mod m" using Suc.hyps by simp
+ also have "\<dots> = x^(Suc n) mod m"
+ by (simp add: mod_mult_left_eq[symmetric] mod_mult_right_eq[symmetric])
+ finally show ?case .
+qed
+
+lemma lucas:
+ assumes n2: "n \<ge> 2" and an1: "[a^(n - 1) = 1] (mod n)"
+ and pn: "\<forall>p. prime p \<and> p dvd n - 1 \<longrightarrow> \<not> [a^((n - 1) div p) = 1] (mod n)"
+ shows "prime n"
+proof-
+ from n2 have n01: "n\<noteq>0" "n\<noteq>1" "n - 1 \<noteq> 0" by arith+
+ from mod_less_divisor[of n 1] n01 have onen: "1 mod n = 1" by simp
+ from lucas_coprime_lemma[OF n01(3) an1] cong_coprime[OF an1]
+ have an: "coprime a n" "coprime (a^(n - 1)) n" by (simp_all add: coprime_commute)
+ {assume H0: "\<exists>m. 0 < m \<and> m < n - 1 \<and> [a ^ m = 1] (mod n)" (is "EX m. ?P m")
+ from H0[unfolded nat_exists_least_iff[of ?P]] obtain m where
+ m: "0 < m" "m < n - 1" "[a ^ m = 1] (mod n)" "\<forall>k <m. \<not>?P k" by blast
+ {assume nm1: "(n - 1) mod m > 0"
+ from mod_less_divisor[OF m(1)] have th0:"(n - 1) mod m < m" by blast
+ let ?y = "a^ ((n - 1) div m * m)"
+ note mdeq = mod_div_equality[of "(n - 1)" m]
+ from coprime_exp[OF an(1)[unfolded coprime_commute[of a n]],
+ of "(n - 1) div m * m"]
+ have yn: "coprime ?y n" by (simp add: coprime_commute)
+ have "?y mod n = (a^m)^((n - 1) div m) mod n"
+ by (simp add: algebra_simps power_mult)
+ also have "\<dots> = (a^m mod n)^((n - 1) div m) mod n"
+ using power_mod[of "a^m" n "(n - 1) div m"] by simp
+ also have "\<dots> = 1" using m(3)[unfolded modeq_def onen] onen
+ by (simp add: power_Suc0)
+ finally have th3: "?y mod n = 1" .
+ have th2: "[?y * a ^ ((n - 1) mod m) = ?y* 1] (mod n)"
+ using an1[unfolded modeq_def onen] onen
+ mod_div_equality[of "(n - 1)" m, symmetric]
+ by (simp add:power_add[symmetric] modeq_def th3 del: One_nat_def)
+ from cong_mult_lcancel[of ?y n "a^((n - 1) mod m)" 1, OF yn th2]
+ have th1: "[a ^ ((n - 1) mod m) = 1] (mod n)" .
+ from m(4)[rule_format, OF th0] nm1
+ less_trans[OF mod_less_divisor[OF m(1), of "n - 1"] m(2)] th1
+ have False by blast }
+ hence "(n - 1) mod m = 0" by auto
+ then have mn: "m dvd n - 1" by presburger
+ then obtain r where r: "n - 1 = m*r" unfolding dvd_def by blast
+ from n01 r m(2) have r01: "r\<noteq>0" "r\<noteq>1" by - (rule ccontr, simp)+
+ from prime_factor[OF r01(2)] obtain p where p: "prime p" "p dvd r" by blast
+ hence th: "prime p \<and> p dvd n - 1" unfolding r by (auto intro: dvd_mult)
+ have "(a ^ ((n - 1) div p)) mod n = (a^(m*r div p)) mod n" using r
+ by (simp add: power_mult)
+ also have "\<dots> = (a^(m*(r div p))) mod n" using div_mult1_eq[of m r p] p(2)[unfolded dvd_eq_mod_eq_0] by simp
+ also have "\<dots> = ((a^m)^(r div p)) mod n" by (simp add: power_mult)
+ also have "\<dots> = ((a^m mod n)^(r div p)) mod n" using power_mod[of "a^m" "n" "r div p" ] ..
+ also have "\<dots> = 1" using m(3) onen by (simp add: modeq_def power_Suc0)
+ finally have "[(a ^ ((n - 1) div p))= 1] (mod n)"
+ using onen by (simp add: modeq_def)
+ with pn[rule_format, OF th] have False by blast}
+ hence th: "\<forall>m. 0 < m \<and> m < n - 1 \<longrightarrow> \<not> [a ^ m = 1] (mod n)" by blast
+ from lucas_weak[OF n2 an1 th] show ?thesis .
+qed
+
+(* Definition of the order of a number mod n (0 in non-coprime case). *)
+
+definition "ord n a = (if coprime n a then Least (\<lambda>d. d > 0 \<and> [a ^d = 1] (mod n)) else 0)"
+
+(* This has the expected properties. *)
+
+lemma coprime_ord:
+ assumes na: "coprime n a"
+ shows "ord n a > 0 \<and> [a ^(ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> \<not> [a^ m = 1] (mod n))"
+proof-
+ let ?P = "\<lambda>d. 0 < d \<and> [a ^ d = 1] (mod n)"
+ from euclid[of a] obtain p where p: "prime p" "a < p" by blast
+ from na have o: "ord n a = Least ?P" by (simp add: ord_def)
+ {assume "n=0 \<or> n=1" with na have "\<exists>m>0. ?P m" apply auto apply (rule exI[where x=1]) by (simp add: modeq_def)}
+ moreover
+ {assume "n\<noteq>0 \<and> n\<noteq>1" hence n2:"n \<ge> 2" by arith
+ from na have na': "coprime a n" by (simp add: coprime_commute)
+ from phi_lowerbound_1[OF n2] fermat_little[OF na']
+ have ex: "\<exists>m>0. ?P m" by - (rule exI[where x="\<phi> n"], auto) }
+ ultimately have ex: "\<exists>m>0. ?P m" by blast
+ from nat_exists_least_iff'[of ?P] ex na show ?thesis
+ unfolding o[symmetric] by auto
+qed
+(* With the special value 0 for non-coprime case, it's more convenient. *)
+lemma ord_works:
+ "[a ^ (ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> ~[a^ m = 1] (mod n))"
+apply (cases "coprime n a")
+using coprime_ord[of n a]
+by (blast, simp add: ord_def modeq_def)
+
+lemma ord: "[a^(ord n a) = 1] (mod n)" using ord_works by blast
+lemma ord_minimal: "0 < m \<Longrightarrow> m < ord n a \<Longrightarrow> ~[a^m = 1] (mod n)"
+ using ord_works by blast
+lemma ord_eq_0: "ord n a = 0 \<longleftrightarrow> ~coprime n a"
+by (cases "coprime n a", simp add: neq0_conv coprime_ord, simp add: neq0_conv ord_def)
+
+lemma ord_divides:
+ "[a ^ d = 1] (mod n) \<longleftrightarrow> ord n a dvd d" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume rh: ?rhs
+ then obtain k where "d = ord n a * k" unfolding dvd_def by blast
+ hence "[a ^ d = (a ^ (ord n a) mod n)^k] (mod n)"
+ by (simp add : modeq_def power_mult power_mod)
+ also have "[(a ^ (ord n a) mod n)^k = 1] (mod n)"
+ using ord[of a n, unfolded modeq_def]
+ by (simp add: modeq_def power_mod power_Suc0)
+ finally show ?lhs .
+next
+ assume lh: ?lhs
+ { assume H: "\<not> coprime n a"
+ hence o: "ord n a = 0" by (simp add: ord_def)
+ {assume d: "d=0" with o H have ?rhs by (simp add: modeq_def)}
+ moreover
+ {assume d0: "d\<noteq>0" then obtain d' where d': "d = Suc d'" by (cases d, auto)
+ from H[unfolded coprime]
+ obtain p where p: "p dvd n" "p dvd a" "p \<noteq> 1" by auto
+ from lh[unfolded nat_mod]
+ obtain q1 q2 where q12:"a ^ d + n * q1 = 1 + n * q2" by blast
+ hence "a ^ d + n * q1 - n * q2 = 1" by simp
+ with dvd_diff_nat [OF dvd_add [OF divides_rexp[OF p(2), of d'] dvd_mult2[OF p(1), of q1]] dvd_mult2[OF p(1), of q2]] d' have "p dvd 1" by simp
+ with p(3) have False by simp
+ hence ?rhs ..}
+ ultimately have ?rhs by blast}
+ moreover
+ {assume H: "coprime n a"
+ let ?o = "ord n a"
+ let ?q = "d div ord n a"
+ let ?r = "d mod ord n a"
+ from cong_exp[OF ord[of a n], of ?q]
+ have eqo: "[(a^?o)^?q = 1] (mod n)" by (simp add: modeq_def power_Suc0)
+ from H have onz: "?o \<noteq> 0" by (simp add: ord_eq_0)
+ hence op: "?o > 0" by simp
+ from mod_div_equality[of d "ord n a"] lh
+ have "[a^(?o*?q + ?r) = 1] (mod n)" by (simp add: modeq_def mult_commute)
+ hence "[(a^?o)^?q * (a^?r) = 1] (mod n)"
+ by (simp add: modeq_def power_mult[symmetric] power_add[symmetric])
+ hence th: "[a^?r = 1] (mod n)"
+ using eqo mod_mult_left_eq[of "(a^?o)^?q" "a^?r" n]
+ apply (simp add: modeq_def del: One_nat_def)
+ by (simp add: mod_mult_left_eq[symmetric])
+ {assume r: "?r = 0" hence ?rhs by (simp add: dvd_eq_mod_eq_0)}
+ moreover
+ {assume r: "?r \<noteq> 0"
+ with mod_less_divisor[OF op, of d] have r0o:"?r >0 \<and> ?r < ?o" by simp
+ from conjunct2[OF ord_works[of a n], rule_format, OF r0o] th
+ have ?rhs by blast}
+ ultimately have ?rhs by blast}
+ ultimately show ?rhs by blast
+qed
+
+lemma order_divides_phi: "coprime n a \<Longrightarrow> ord n a dvd \<phi> n"
+using ord_divides fermat_little coprime_commute by simp
+lemma order_divides_expdiff:
+ assumes na: "coprime n a"
+ shows "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
+proof-
+ {fix n a d e
+ assume na: "coprime n a" and ed: "(e::nat) \<le> d"
+ hence "\<exists>c. d = e + c" by arith
+ then obtain c where c: "d = e + c" by arith
+ from na have an: "coprime a n" by (simp add: coprime_commute)
+ from coprime_exp[OF na, of e]
+ have aen: "coprime (a^e) n" by (simp add: coprime_commute)
+ from coprime_exp[OF na, of c]
+ have acn: "coprime (a^c) n" by (simp add: coprime_commute)
+ have "[a^d = a^e] (mod n) \<longleftrightarrow> [a^(e + c) = a^(e + 0)] (mod n)"
+ using c by simp
+ also have "\<dots> \<longleftrightarrow> [a^e* a^c = a^e *a^0] (mod n)" by (simp add: power_add)
+ also have "\<dots> \<longleftrightarrow> [a ^ c = 1] (mod n)"
+ using cong_mult_lcancel_eq[OF aen, of "a^c" "a^0"] by simp
+ also have "\<dots> \<longleftrightarrow> ord n a dvd c" by (simp only: ord_divides)
+ also have "\<dots> \<longleftrightarrow> [e + c = e + 0] (mod ord n a)"
+ using cong_add_lcancel_eq[of e c 0 "ord n a", simplified cong_0_divides]
+ by simp
+ finally have "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
+ using c by simp }
+ note th = this
+ have "e \<le> d \<or> d \<le> e" by arith
+ moreover
+ {assume ed: "e \<le> d" from th[OF na ed] have ?thesis .}
+ moreover
+ {assume de: "d \<le> e"
+ from th[OF na de] have ?thesis by (simp add: cong_commute) }
+ ultimately show ?thesis by blast
+qed
+
+(* Another trivial primality characterization. *)
+
+lemma prime_prime_factor:
+ "prime n \<longleftrightarrow> n \<noteq> 1\<and> (\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n)"
+proof-
+ {assume n: "n=0 \<or> n=1" hence ?thesis using prime_0 two_is_prime by auto}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ {assume pn: "prime n"
+
+ from pn[unfolded prime_def] have "\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n"
+ using n
+ apply (cases "n = 0 \<or> n=1",simp)
+ by (clarsimp, erule_tac x="p" in allE, auto)}
+ moreover
+ {assume H: "\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n"
+ from n have n1: "n > 1" by arith
+ {fix m assume m: "m dvd n" "m\<noteq>1"
+ from prime_factor[OF m(2)] obtain p where
+ p: "prime p" "p dvd m" by blast
+ from dvd_trans[OF p(2) m(1)] p(1) H have "p = n" by blast
+ with p(2) have "n dvd m" by simp
+ hence "m=n" using dvd_anti_sym[OF m(1)] by simp }
+ with n1 have "prime n" unfolding prime_def by auto }
+ ultimately have ?thesis using n by blast}
+ ultimately show ?thesis by auto
+qed
+
+lemma prime_divisor_sqrt:
+ "prime n \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>d. d dvd n \<and> d^2 \<le> n \<longrightarrow> d = 1)"
+proof-
+ {assume "n=0 \<or> n=1" hence ?thesis using prime_0 prime_1
+ by (auto simp add: nat_power_eq_0_iff)}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ hence np: "n > 1" by arith
+ {fix d assume d: "d dvd n" "d^2 \<le> n" and H: "\<forall>m. m dvd n \<longrightarrow> m=1 \<or> m=n"
+ from H d have d1n: "d = 1 \<or> d=n" by blast
+ {assume dn: "d=n"
+ have "n^2 > n*1" using n
+ by (simp add: power2_eq_square mult_less_cancel1)
+ with dn d(2) have "d=1" by simp}
+ with d1n have "d = 1" by blast }
+ moreover
+ {fix d assume d: "d dvd n" and H: "\<forall>d'. d' dvd n \<and> d'^2 \<le> n \<longrightarrow> d' = 1"
+ from d n have "d \<noteq> 0" apply - apply (rule ccontr) by simp
+ hence dp: "d > 0" by simp
+ from d[unfolded dvd_def] obtain e where e: "n= d*e" by blast
+ from n dp e have ep:"e > 0" by simp
+ have "d^2 \<le> n \<or> e^2 \<le> n" using dp ep
+ by (auto simp add: e power2_eq_square mult_le_cancel_left)
+ moreover
+ {assume h: "d^2 \<le> n"
+ from H[rule_format, of d] h d have "d = 1" by blast}
+ moreover
+ {assume h: "e^2 \<le> n"
+ from e have "e dvd n" unfolding dvd_def by (simp add: mult_commute)
+ with H[rule_format, of e] h have "e=1" by simp
+ with e have "d = n" by simp}
+ ultimately have "d=1 \<or> d=n" by blast}
+ ultimately have ?thesis unfolding prime_def using np n(2) by blast}
+ ultimately show ?thesis by auto
+qed
+lemma prime_prime_factor_sqrt:
+ "prime n \<longleftrightarrow> n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p^2 \<le> n)"
+ (is "?lhs \<longleftrightarrow>?rhs")
+proof-
+ {assume "n=0 \<or> n=1" hence ?thesis using prime_0 prime_1 by auto}
+ moreover
+ {assume n: "n\<noteq>0" "n\<noteq>1"
+ {assume H: ?lhs
+ from H[unfolded prime_divisor_sqrt] n
+ have ?rhs apply clarsimp by (erule_tac x="p" in allE, simp add: prime_1)
+ }
+ moreover
+ {assume H: ?rhs
+ {fix d assume d: "d dvd n" "d^2 \<le> n" "d\<noteq>1"
+ from prime_factor[OF d(3)]
+ obtain p where p: "prime p" "p dvd d" by blast
+ from n have np: "n > 0" by arith
+ from d(1) n have "d \<noteq> 0" by - (rule ccontr, auto)
+ hence dp: "d > 0" by arith
+ from mult_mono[OF dvd_imp_le[OF p(2) dp] dvd_imp_le[OF p(2) dp]] d(2)
+ have "p^2 \<le> n" unfolding power2_eq_square by arith
+ with H n p(1) dvd_trans[OF p(2) d(1)] have False by blast}
+ with n prime_divisor_sqrt have ?lhs by auto}
+ ultimately have ?thesis by blast }
+ ultimately show ?thesis by (cases "n=0 \<or> n=1", auto)
+qed
+(* Pocklington theorem. *)
+
+lemma pocklington_lemma:
+ assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and an: "[a^ (n - 1) = 1] (mod n)"
+ and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
+ and pp: "prime p" and pn: "p dvd n"
+ shows "[p = 1] (mod q)"
+proof-
+ from pp prime_0 prime_1 have p01: "p \<noteq> 0" "p \<noteq> 1" by - (rule ccontr, simp)+
+ from cong_1_divides[OF an, unfolded nqr, unfolded dvd_def]
+ obtain k where k: "a ^ (q * r) - 1 = n*k" by blast
+ from pn[unfolded dvd_def] obtain l where l: "n = p*l" by blast
+ {assume a0: "a = 0"
+ hence "a^ (n - 1) = 0" using n by (simp add: power_0_left)
+ with n an mod_less[of 1 n] have False by (simp add: power_0_left modeq_def)}
+ hence a0: "a\<noteq>0" ..
+ from n nqr have aqr0: "a ^ (q * r) \<noteq> 0" using a0 by (simp add: neq0_conv)
+ hence "(a ^ (q * r) - 1) + 1 = a ^ (q * r)" by simp
+ with k l have "a ^ (q * r) = p*l*k + 1" by simp
+ hence "a ^ (r * q) + p * 0 = 1 + p * (l*k)" by (simp add: mult_ac)
+ hence odq: "ord p (a^r) dvd q"
+ unfolding ord_divides[symmetric] power_mult[symmetric] nat_mod by blast
+ from odq[unfolded dvd_def] obtain d where d: "q = ord p (a^r) * d" by blast
+ {assume d1: "d \<noteq> 1"
+ from prime_factor[OF d1] obtain P where P: "prime P" "P dvd d" by blast
+ from d dvd_mult[OF P(2), of "ord p (a^r)"] have Pq: "P dvd q" by simp
+ from aq P(1) Pq have caP:"coprime (a^ ((n - 1) div P) - 1) n" by blast
+ from Pq obtain s where s: "q = P*s" unfolding dvd_def by blast
+ have P0: "P \<noteq> 0" using P(1) prime_0 by - (rule ccontr, simp)
+ from P(2) obtain t where t: "d = P*t" unfolding dvd_def by blast
+ from d s t P0 have s': "ord p (a^r) * t = s" by algebra
+ have "ord p (a^r) * t*r = r * ord p (a^r) * t" by algebra
+ hence exps: "a^(ord p (a^r) * t*r) = ((a ^ r) ^ ord p (a^r)) ^ t"
+ by (simp only: power_mult)
+ have "[((a ^ r) ^ ord p (a^r)) ^ t= 1^t] (mod p)"
+ by (rule cong_exp, rule ord)
+ then have th: "[((a ^ r) ^ ord p (a^r)) ^ t= 1] (mod p)"
+ by (simp add: power_Suc0)
+ from cong_1_divides[OF th] exps have pd0: "p dvd a^(ord p (a^r) * t*r) - 1" by simp
+ from nqr s s' have "(n - 1) div P = ord p (a^r) * t*r" using P0 by simp
+ with caP have "coprime (a^(ord p (a^r) * t*r) - 1) n" by simp
+ with p01 pn pd0 have False unfolding coprime by auto}
+ hence d1: "d = 1" by blast
+ hence o: "ord p (a^r) = q" using d by simp
+ from pp phi_prime[of p] have phip: " \<phi> p = p - 1" by simp
+ {fix d assume d: "d dvd p" "d dvd a" "d \<noteq> 1"
+ from pp[unfolded prime_def] d have dp: "d = p" by blast
+ from n have n12:"Suc (n - 2) = n - 1" by arith
+ with divides_rexp[OF d(2)[unfolded dp], of "n - 2"]
+ have th0: "p dvd a ^ (n - 1)" by simp
+ from n have n0: "n \<noteq> 0" by simp
+ from d(2) an n12[symmetric] have a0: "a \<noteq> 0"
+ by - (rule ccontr, simp add: modeq_def)
+ have th1: "a^ (n - 1) \<noteq> 0" using n d(2) dp a0 by (auto simp add: neq0_conv)
+ from coprime_minus1[OF th1, unfolded coprime]
+ dvd_trans[OF pn cong_1_divides[OF an]] th0 d(3) dp
+ have False by auto}
+ hence cpa: "coprime p a" using coprime by auto
+ from coprime_exp[OF cpa, of r] coprime_commute
+ have arp: "coprime (a^r) p" by blast
+ from fermat_little[OF arp, simplified ord_divides] o phip
+ have "q dvd (p - 1)" by simp
+ then obtain d where d:"p - 1 = q * d" unfolding dvd_def by blast
+ from prime_0 pp have p0:"p \<noteq> 0" by - (rule ccontr, auto)
+ from p0 d have "p + q * 0 = 1 + q * d" by simp
+ with nat_mod[of p 1 q, symmetric]
+ show ?thesis by blast
+qed
+
+lemma pocklington:
+ assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q^2"
+ and an: "[a^ (n - 1) = 1] (mod n)"
+ and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
+ shows "prime n"
+unfolding prime_prime_factor_sqrt[of n]
+proof-
+ let ?ths = "n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<twosuperior> \<le> n)"
+ from n have n01: "n\<noteq>0" "n\<noteq>1" by arith+
+ {fix p assume p: "prime p" "p dvd n" "p^2 \<le> n"
+ from p(3) sqr have "p^(Suc 1) \<le> q^(Suc 1)" by (simp add: power2_eq_square)
+ hence pq: "p \<le> q" unfolding exp_mono_le .
+ from pocklington_lemma[OF n nqr an aq p(1,2)] cong_1_divides
+ have th: "q dvd p - 1" by blast
+ have "p - 1 \<noteq> 0"using prime_ge_2[OF p(1)] by arith
+ with divides_ge[OF th] pq have False by arith }
+ with n01 show ?ths by blast
+qed
+
+(* Variant for application, to separate the exponentiation. *)
+lemma pocklington_alt:
+ assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q^2"
+ and an: "[a^ (n - 1) = 1] (mod n)"
+ and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> (\<exists>b. [a^((n - 1) div p) = b] (mod n) \<and> coprime (b - 1) n)"
+ shows "prime n"
+proof-
+ {fix p assume p: "prime p" "p dvd q"
+ from aq[rule_format] p obtain b where
+ b: "[a^((n - 1) div p) = b] (mod n)" "coprime (b - 1) n" by blast
+ {assume a0: "a=0"
+ from n an have "[0 = 1] (mod n)" unfolding a0 power_0_left by auto
+ hence False using n by (simp add: modeq_def dvd_eq_mod_eq_0[symmetric])}
+ hence a0: "a\<noteq> 0" ..
+ hence a1: "a \<ge> 1" by arith
+ from one_le_power[OF a1] have ath: "1 \<le> a ^ ((n - 1) div p)" .
+ {assume b0: "b = 0"
+ from p(2) nqr have "(n - 1) mod p = 0"
+ apply (simp only: dvd_eq_mod_eq_0[symmetric]) by (rule dvd_mult2, simp)
+ with mod_div_equality[of "n - 1" p]
+ have "(n - 1) div p * p= n - 1" by auto
+ hence eq: "(a^((n - 1) div p))^p = a^(n - 1)"
+ by (simp only: power_mult[symmetric])
+ from prime_ge_2[OF p(1)] have pS: "Suc (p - 1) = p" by arith
+ from b(1) have d: "n dvd a^((n - 1) div p)" unfolding b0 cong_0_divides .
+ from divides_rexp[OF d, of "p - 1"] pS eq cong_divides[OF an] n
+ have False by simp}
+ then have b0: "b \<noteq> 0" ..
+ hence b1: "b \<ge> 1" by arith
+ from cong_coprime[OF cong_sub[OF b(1) cong_refl[of 1] ath b1]] b(2) nqr
+ have "coprime (a ^ ((n - 1) div p) - 1) n" by (simp add: coprime_commute)}
+ hence th: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a ^ ((n - 1) div p) - 1) n "
+ by blast
+ from pocklington[OF n nqr sqr an th] show ?thesis .
+qed
+
+(* Prime factorizations. *)
+
+definition "primefact ps n = (foldr op * ps 1 = n \<and> (\<forall>p\<in> set ps. prime p))"
+
+lemma primefact: assumes n: "n \<noteq> 0"
+ shows "\<exists>ps. primefact ps n"
+using n
+proof(induct n rule: nat_less_induct)
+ fix n assume H: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>ps. primefact ps m)" and n: "n\<noteq>0"
+ let ?ths = "\<exists>ps. primefact ps n"
+ {assume "n = 1"
+ hence "primefact [] n" by (simp add: primefact_def)
+ hence ?ths by blast }
+ moreover
+ {assume n1: "n \<noteq> 1"
+ with n have n2: "n \<ge> 2" by arith
+ from prime_factor[OF n1] obtain p where p: "prime p" "p dvd n" by blast
+ from p(2) obtain m where m: "n = p*m" unfolding dvd_def by blast
+ from n m have m0: "m > 0" "m\<noteq>0" by auto
+ from prime_ge_2[OF p(1)] have "1 < p" by arith
+ with m0 m have mn: "m < n" by auto
+ from H[rule_format, OF mn m0(2)] obtain ps where ps: "primefact ps m" ..
+ from ps m p(1) have "primefact (p#ps) n" by (simp add: primefact_def)
+ hence ?ths by blast}
+ ultimately show ?ths by blast
+qed
+
+lemma primefact_contains:
+ assumes pf: "primefact ps n" and p: "prime p" and pn: "p dvd n"
+ shows "p \<in> set ps"
+ using pf p pn
+proof(induct ps arbitrary: p n)
+ case Nil thus ?case by (auto simp add: primefact_def)
+next
+ case (Cons q qs p n)
+ from Cons.prems[unfolded primefact_def]
+ have q: "prime q" "q * foldr op * qs 1 = n" "\<forall>p \<in>set qs. prime p" and p: "prime p" "p dvd q * foldr op * qs 1" by simp_all
+ {assume "p dvd q"
+ with p(1) q(1) have "p = q" unfolding prime_def by auto
+ hence ?case by simp}
+ moreover
+ { assume h: "p dvd foldr op * qs 1"
+ from q(3) have pqs: "primefact qs (foldr op * qs 1)"
+ by (simp add: primefact_def)
+ from Cons.hyps[OF pqs p(1) h] have ?case by simp}
+ ultimately show ?case using prime_divprod[OF p] by blast
+qed
+
+lemma primefact_variant: "primefact ps n \<longleftrightarrow> foldr op * ps 1 = n \<and> list_all prime ps" by (auto simp add: primefact_def list_all_iff)
+
+(* Variant of Lucas theorem. *)
+
+lemma lucas_primefact:
+ assumes n: "n \<ge> 2" and an: "[a^(n - 1) = 1] (mod n)"
+ and psn: "foldr op * ps 1 = n - 1"
+ and psp: "list_all (\<lambda>p. prime p \<and> \<not> [a^((n - 1) div p) = 1] (mod n)) ps"
+ shows "prime n"
+proof-
+ {fix p assume p: "prime p" "p dvd n - 1" "[a ^ ((n - 1) div p) = 1] (mod n)"
+ from psn psp have psn1: "primefact ps (n - 1)"
+ by (auto simp add: list_all_iff primefact_variant)
+ from p(3) primefact_contains[OF psn1 p(1,2)] psp
+ have False by (induct ps, auto)}
+ with lucas[OF n an] show ?thesis by blast
+qed
+
+(* Variant of Pocklington theorem. *)
+
+lemma mod_le: assumes n: "n \<noteq> (0::nat)" shows "m mod n \<le> m"
+proof-
+ from mod_div_equality[of m n]
+ have "\<exists>x. x + m mod n = m" by blast
+ then show ?thesis by auto
+qed
+
+
+lemma pocklington_primefact:
+ assumes n: "n \<ge> 2" and qrn: "q*r = n - 1" and nq2: "n \<le> q^2"
+ and arnb: "(a^r) mod n = b" and psq: "foldr op * ps 1 = q"
+ and bqn: "(b^q) mod n = 1"
+ and psp: "list_all (\<lambda>p. prime p \<and> coprime ((b^(q div p)) mod n - 1) n) ps"
+ shows "prime n"
+proof-
+ from bqn psp qrn
+ have bqn: "a ^ (n - 1) mod n = 1"
+ and psp: "list_all (\<lambda>p. prime p \<and> coprime (a^(r *(q div p)) mod n - 1) n) ps" unfolding arnb[symmetric] power_mod
+ by (simp_all add: power_mult[symmetric] algebra_simps)
+ from n have n0: "n > 0" by arith
+ from mod_div_equality[of "a^(n - 1)" n]
+ mod_less_divisor[OF n0, of "a^(n - 1)"]
+ have an1: "[a ^ (n - 1) = 1] (mod n)"
+ unfolding nat_mod bqn
+ apply -
+ apply (rule exI[where x="0"])
+ apply (rule exI[where x="a^(n - 1) div n"])
+ by (simp add: algebra_simps)
+ {fix p assume p: "prime p" "p dvd q"
+ from psp psq have pfpsq: "primefact ps q"
+ by (auto simp add: primefact_variant list_all_iff)
+ from psp primefact_contains[OF pfpsq p]
+ have p': "coprime (a ^ (r * (q div p)) mod n - 1) n"
+ by (simp add: list_all_iff)
+ from prime_ge_2[OF p(1)] have p01: "p \<noteq> 0" "p \<noteq> 1" "p =Suc(p - 1)" by arith+
+ from div_mult1_eq[of r q p] p(2)
+ have eq1: "r* (q div p) = (n - 1) div p"
+ unfolding qrn[symmetric] dvd_eq_mod_eq_0 by (simp add: mult_commute)
+ have ath: "\<And>a (b::nat). a <= b \<Longrightarrow> a \<noteq> 0 ==> 1 <= a \<and> 1 <= b" by arith
+ from n0 have n00: "n \<noteq> 0" by arith
+ from mod_le[OF n00]
+ have th10: "a ^ ((n - 1) div p) mod n \<le> a ^ ((n - 1) div p)" .
+ {assume "a ^ ((n - 1) div p) mod n = 0"
+ then obtain s where s: "a ^ ((n - 1) div p) = n*s"
+ unfolding mod_eq_0_iff by blast
+ hence eq0: "(a^((n - 1) div p))^p = (n*s)^p" by simp
+ from qrn[symmetric] have qn1: "q dvd n - 1" unfolding dvd_def by auto
+ from dvd_trans[OF p(2) qn1] div_mod_equality'[of "n - 1" p]
+ have npp: "(n - 1) div p * p = n - 1" by (simp add: dvd_eq_mod_eq_0)
+ with eq0 have "a^ (n - 1) = (n*s)^p"
+ by (simp add: power_mult[symmetric])
+ hence "1 = (n*s)^(Suc (p - 1)) mod n" using bqn p01 by simp
+ also have "\<dots> = 0" by (simp add: mult_assoc)
+ finally have False by simp }
+ then have th11: "a ^ ((n - 1) div p) mod n \<noteq> 0" by auto
+ have th1: "[a ^ ((n - 1) div p) mod n = a ^ ((n - 1) div p)] (mod n)"
+ unfolding modeq_def by simp
+ from cong_sub[OF th1 cong_refl[of 1]] ath[OF th10 th11]
+ have th: "[a ^ ((n - 1) div p) mod n - 1 = a ^ ((n - 1) div p) - 1] (mod n)"
+ by blast
+ from cong_coprime[OF th] p'[unfolded eq1]
+ have "coprime (a ^ ((n - 1) div p) - 1) n" by (simp add: coprime_commute) }
+ with pocklington[OF n qrn[symmetric] nq2 an1]
+ show ?thesis by blast
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Primes.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,826 @@
+(* Title: HOL/Library/Primes.thy
+ Author: Amine Chaieb, Christophe Tabacznyj and Lawrence C Paulson
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Primality on nat *}
+
+theory Primes
+imports Complex_Main Legacy_GCD
+begin
+
+definition
+ coprime :: "nat => nat => bool" where
+ "coprime m n \<longleftrightarrow> gcd m n = 1"
+
+definition
+ prime :: "nat \<Rightarrow> bool" where
+ [code del]: "prime p \<longleftrightarrow> (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"
+
+
+lemma two_is_prime: "prime 2"
+ apply (auto simp add: prime_def)
+ apply (case_tac m)
+ apply (auto dest!: dvd_imp_le)
+ done
+
+lemma prime_imp_relprime: "prime p ==> \<not> p dvd n ==> gcd p n = 1"
+ apply (auto simp add: prime_def)
+ apply (metis One_nat_def gcd_dvd1 gcd_dvd2)
+ done
+
+text {*
+ This theorem leads immediately to a proof of the uniqueness of
+ factorization. If @{term p} divides a product of primes then it is
+ one of those primes.
+*}
+
+lemma prime_dvd_mult: "prime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
+ by (blast intro: relprime_dvd_mult prime_imp_relprime)
+
+lemma prime_dvd_square: "prime p ==> p dvd m^Suc (Suc 0) ==> p dvd m"
+ by (auto dest: prime_dvd_mult)
+
+lemma prime_dvd_power_two: "prime p ==> p dvd m\<twosuperior> ==> p dvd m"
+ by (rule prime_dvd_square) (simp_all add: power2_eq_square)
+
+
+lemma exp_eq_1:"(x::nat)^n = 1 \<longleftrightarrow> x = 1 \<or> n = 0"
+by (induct n, auto)
+
+lemma exp_mono_lt: "(x::nat) ^ (Suc n) < y ^ (Suc n) \<longleftrightarrow> x < y"
+by(metis linorder_not_less not_less0 power_le_imp_le_base power_less_imp_less_base)
+
+lemma exp_mono_le: "(x::nat) ^ (Suc n) \<le> y ^ (Suc n) \<longleftrightarrow> x \<le> y"
+by (simp only: linorder_not_less[symmetric] exp_mono_lt)
+
+lemma exp_mono_eq: "(x::nat) ^ Suc n = y ^ Suc n \<longleftrightarrow> x = y"
+using power_inject_base[of x n y] by auto
+
+
+lemma even_square: assumes e: "even (n::nat)" shows "\<exists>x. n ^ 2 = 4*x"
+proof-
+ from e have "2 dvd n" by presburger
+ then obtain k where k: "n = 2*k" using dvd_def by auto
+ hence "n^2 = 4* (k^2)" by (simp add: power2_eq_square)
+ thus ?thesis by blast
+qed
+
+lemma odd_square: assumes e: "odd (n::nat)" shows "\<exists>x. n ^ 2 = 4*x + 1"
+proof-
+ from e have np: "n > 0" by presburger
+ from e have "2 dvd (n - 1)" by presburger
+ then obtain k where "n - 1 = 2*k" using dvd_def by auto
+ hence k: "n = 2*k + 1" using e by presburger
+ hence "n^2 = 4* (k^2 + k) + 1" by algebra
+ thus ?thesis by blast
+qed
+
+lemma diff_square: "(x::nat)^2 - y^2 = (x+y)*(x - y)"
+proof-
+ have "x \<le> y \<or> y \<le> x" by (rule nat_le_linear)
+ moreover
+ {assume le: "x \<le> y"
+ hence "x ^2 \<le> y^2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
+ with le have ?thesis by simp }
+ moreover
+ {assume le: "y \<le> x"
+ hence le2: "y ^2 \<le> x^2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
+ from le have "\<exists>z. y + z = x" by presburger
+ then obtain z where z: "x = y + z" by blast
+ from le2 have "\<exists>z. x^2 = y^2 + z" by presburger
+ then obtain z2 where z2: "x^2 = y^2 + z2" by blast
+ from z z2 have ?thesis apply simp by algebra }
+ ultimately show ?thesis by blast
+qed
+
+text {* Elementary theory of divisibility *}
+lemma divides_ge: "(a::nat) dvd b \<Longrightarrow> b = 0 \<or> a \<le> b" unfolding dvd_def by auto
+lemma divides_antisym: "(x::nat) dvd y \<and> y dvd x \<longleftrightarrow> x = y"
+ using dvd_anti_sym[of x y] by auto
+
+lemma divides_add_revr: assumes da: "(d::nat) dvd a" and dab:"d dvd (a + b)"
+ shows "d dvd b"
+proof-
+ from da obtain k where k:"a = d*k" by (auto simp add: dvd_def)
+ from dab obtain k' where k': "a + b = d*k'" by (auto simp add: dvd_def)
+ from k k' have "b = d *(k' - k)" by (simp add : diff_mult_distrib2)
+ thus ?thesis unfolding dvd_def by blast
+qed
+
+declare nat_mult_dvd_cancel_disj[presburger]
+lemma nat_mult_dvd_cancel_disj'[presburger]:
+ "(m\<Colon>nat)*k dvd n*k \<longleftrightarrow> k = 0 \<or> m dvd n" unfolding mult_commute[of m k] mult_commute[of n k] by presburger
+
+lemma divides_mul_l: "(a::nat) dvd b ==> (c * a) dvd (c * b)"
+ by presburger
+
+lemma divides_mul_r: "(a::nat) dvd b ==> (a * c) dvd (b * c)" by presburger
+lemma divides_cases: "(n::nat) dvd m ==> m = 0 \<or> m = n \<or> 2 * n <= m"
+ by (auto simp add: dvd_def)
+
+lemma divides_div_not: "(x::nat) = (q * n) + r \<Longrightarrow> 0 < r \<Longrightarrow> r < n ==> ~(n dvd x)"
+proof(auto simp add: dvd_def)
+ fix k assume H: "0 < r" "r < n" "q * n + r = n * k"
+ from H(3) have r: "r = n* (k -q)" by(simp add: diff_mult_distrib2 mult_commute)
+ {assume "k - q = 0" with r H(1) have False by simp}
+ moreover
+ {assume "k - q \<noteq> 0" with r have "r \<ge> n" by auto
+ with H(2) have False by simp}
+ ultimately show False by blast
+qed
+lemma divides_exp: "(x::nat) dvd y ==> x ^ n dvd y ^ n"
+ by (auto simp add: power_mult_distrib dvd_def)
+
+lemma divides_exp2: "n \<noteq> 0 \<Longrightarrow> (x::nat) ^ n dvd y \<Longrightarrow> x dvd y"
+ by (induct n ,auto simp add: dvd_def)
+
+fun fact :: "nat \<Rightarrow> nat" where
+ "fact 0 = 1"
+| "fact (Suc n) = Suc n * fact n"
+
+lemma fact_lt: "0 < fact n" by(induct n, simp_all)
+lemma fact_le: "fact n \<ge> 1" using fact_lt[of n] by simp
+lemma fact_mono: assumes le: "m \<le> n" shows "fact m \<le> fact n"
+proof-
+ from le have "\<exists>i. n = m+i" by presburger
+ then obtain i where i: "n = m+i" by blast
+ have "fact m \<le> fact (m + i)"
+ proof(induct m)
+ case 0 thus ?case using fact_le[of i] by simp
+ next
+ case (Suc m)
+ have "fact (Suc m) = Suc m * fact m" by simp
+ have th1: "Suc m \<le> Suc (m + i)" by simp
+ from mult_le_mono[of "Suc m" "Suc (m+i)" "fact m" "fact (m+i)", OF th1 Suc.hyps]
+ show ?case by simp
+ qed
+ thus ?thesis using i by simp
+qed
+
+lemma divides_fact: "1 <= p \<Longrightarrow> p <= n ==> p dvd fact n"
+proof(induct n arbitrary: p)
+ case 0 thus ?case by simp
+next
+ case (Suc n p)
+ from Suc.prems have "p = Suc n \<or> p \<le> n" by presburger
+ moreover
+ {assume "p = Suc n" hence ?case by (simp only: fact.simps dvd_triv_left)}
+ moreover
+ {assume "p \<le> n"
+ with Suc.prems(1) Suc.hyps have th: "p dvd fact n" by simp
+ from dvd_mult[OF th] have ?case by (simp only: fact.simps) }
+ ultimately show ?case by blast
+qed
+
+declare dvd_triv_left[presburger]
+declare dvd_triv_right[presburger]
+lemma divides_rexp:
+ "x dvd y \<Longrightarrow> (x::nat) dvd (y^(Suc n))" by (simp add: dvd_mult2[of x y])
+
+text {* Coprimality *}
+
+lemma coprime: "coprime a b \<longleftrightarrow> (\<forall>d. d dvd a \<and> d dvd b \<longleftrightarrow> d = 1)"
+using gcd_unique[of 1 a b, simplified] by (auto simp add: coprime_def)
+lemma coprime_commute: "coprime a b \<longleftrightarrow> coprime b a" by (simp add: coprime_def gcd_commute)
+
+lemma coprime_bezout: "coprime a b \<longleftrightarrow> (\<exists>x y. a * x - b * y = 1 \<or> b * x - a * y = 1)"
+using coprime_def gcd_bezout by auto
+
+lemma coprime_divprod: "d dvd a * b \<Longrightarrow> coprime d a \<Longrightarrow> d dvd b"
+ using relprime_dvd_mult_iff[of d a b] by (auto simp add: coprime_def mult_commute)
+
+lemma coprime_1[simp]: "coprime a 1" by (simp add: coprime_def)
+lemma coprime_1'[simp]: "coprime 1 a" by (simp add: coprime_def)
+lemma coprime_Suc0[simp]: "coprime a (Suc 0)" by (simp add: coprime_def)
+lemma coprime_Suc0'[simp]: "coprime (Suc 0) a" by (simp add: coprime_def)
+
+lemma gcd_coprime:
+ assumes z: "gcd a b \<noteq> 0" and a: "a = a' * gcd a b" and b: "b = b' * gcd a b"
+ shows "coprime a' b'"
+proof-
+ let ?g = "gcd a b"
+ {assume bz: "a = 0" from b bz z a have ?thesis by (simp add: gcd_zero coprime_def)}
+ moreover
+ {assume az: "a\<noteq> 0"
+ from z have z': "?g > 0" by simp
+ from bezout_gcd_strong[OF az, of b]
+ obtain x y where xy: "a*x = b*y + ?g" by blast
+ from xy a b have "?g * a'*x = ?g * (b'*y + 1)" by (simp add: algebra_simps)
+ hence "?g * (a'*x) = ?g * (b'*y + 1)" by (simp add: mult_assoc)
+ hence "a'*x = (b'*y + 1)"
+ by (simp only: nat_mult_eq_cancel1[OF z'])
+ hence "a'*x - b'*y = 1" by simp
+ with coprime_bezout[of a' b'] have ?thesis by auto}
+ ultimately show ?thesis by blast
+qed
+lemma coprime_0: "coprime d 0 \<longleftrightarrow> d = 1" by (simp add: coprime_def)
+lemma coprime_mul: assumes da: "coprime d a" and db: "coprime d b"
+ shows "coprime d (a * b)"
+proof-
+ from da have th: "gcd a d = 1" by (simp add: coprime_def gcd_commute)
+ from gcd_mult_cancel[of a d b, OF th] db[unfolded coprime_def] have "gcd d (a*b) = 1"
+ by (simp add: gcd_commute)
+ thus ?thesis unfolding coprime_def .
+qed
+lemma coprime_lmul2: assumes dab: "coprime d (a * b)" shows "coprime d b"
+using prems unfolding coprime_bezout
+apply clarsimp
+apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
+apply (rule_tac x="x" in exI)
+apply (rule_tac x="a*y" in exI)
+apply (simp add: mult_ac)
+apply (rule_tac x="a*x" in exI)
+apply (rule_tac x="y" in exI)
+apply (simp add: mult_ac)
+done
+
+lemma coprime_rmul2: "coprime d (a * b) \<Longrightarrow> coprime d a"
+unfolding coprime_bezout
+apply clarsimp
+apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
+apply (rule_tac x="x" in exI)
+apply (rule_tac x="b*y" in exI)
+apply (simp add: mult_ac)
+apply (rule_tac x="b*x" in exI)
+apply (rule_tac x="y" in exI)
+apply (simp add: mult_ac)
+done
+lemma coprime_mul_eq: "coprime d (a * b) \<longleftrightarrow> coprime d a \<and> coprime d b"
+ using coprime_rmul2[of d a b] coprime_lmul2[of d a b] coprime_mul[of d a b]
+ by blast
+
+lemma gcd_coprime_exists:
+ assumes nz: "gcd a b \<noteq> 0"
+ shows "\<exists>a' b'. a = a' * gcd a b \<and> b = b' * gcd a b \<and> coprime a' b'"
+proof-
+ let ?g = "gcd a b"
+ from gcd_dvd1[of a b] gcd_dvd2[of a b]
+ obtain a' b' where "a = ?g*a'" "b = ?g*b'" unfolding dvd_def by blast
+ hence ab': "a = a'*?g" "b = b'*?g" by algebra+
+ from ab' gcd_coprime[OF nz ab'] show ?thesis by blast
+qed
+
+lemma coprime_exp: "coprime d a ==> coprime d (a^n)"
+ by(induct n, simp_all add: coprime_mul)
+
+lemma coprime_exp_imp: "coprime a b ==> coprime (a ^n) (b ^n)"
+ by (induct n, simp_all add: coprime_mul_eq coprime_commute coprime_exp)
+lemma coprime_refl[simp]: "coprime n n \<longleftrightarrow> n = 1" by (simp add: coprime_def)
+lemma coprime_plus1[simp]: "coprime (n + 1) n"
+ apply (simp add: coprime_bezout)
+ apply (rule exI[where x=1])
+ apply (rule exI[where x=1])
+ apply simp
+ done
+lemma coprime_minus1: "n \<noteq> 0 ==> coprime (n - 1) n"
+ using coprime_plus1[of "n - 1"] coprime_commute[of "n - 1" n] by auto
+
+lemma bezout_gcd_pow: "\<exists>x y. a ^n * x - b ^ n * y = gcd a b ^ n \<or> b ^ n * x - a ^ n * y = gcd a b ^ n"
+proof-
+ let ?g = "gcd a b"
+ {assume z: "?g = 0" hence ?thesis
+ apply (cases n, simp)
+ apply arith
+ apply (simp only: z power_0_Suc)
+ apply (rule exI[where x=0])
+ apply (rule exI[where x=0])
+ by simp}
+ moreover
+ {assume z: "?g \<noteq> 0"
+ from gcd_dvd1[of a b] gcd_dvd2[of a b] obtain a' b' where
+ ab': "a = a'*?g" "b = b'*?g" unfolding dvd_def by (auto simp add: mult_ac)
+ hence ab'': "?g*a' = a" "?g * b' = b" by algebra+
+ from coprime_exp_imp[OF gcd_coprime[OF z ab'], unfolded coprime_bezout, of n]
+ obtain x y where "a'^n * x - b'^n * y = 1 \<or> b'^n * x - a'^n * y = 1" by blast
+ hence "?g^n * (a'^n * x - b'^n * y) = ?g^n \<or> ?g^n*(b'^n * x - a'^n * y) = ?g^n"
+ using z by auto
+ then have "a^n * x - b^n * y = ?g^n \<or> b^n * x - a^n * y = ?g^n"
+ using z ab'' by (simp only: power_mult_distrib[symmetric]
+ diff_mult_distrib2 mult_assoc[symmetric])
+ hence ?thesis by blast }
+ ultimately show ?thesis by blast
+qed
+
+lemma gcd_exp: "gcd (a^n) (b^n) = gcd a b^n"
+proof-
+ let ?g = "gcd (a^n) (b^n)"
+ let ?gn = "gcd a b^n"
+ {fix e assume H: "e dvd a^n" "e dvd b^n"
+ from bezout_gcd_pow[of a n b] obtain x y
+ where xy: "a ^ n * x - b ^ n * y = ?gn \<or> b ^ n * x - a ^ n * y = ?gn" by blast
+ from dvd_diff_nat [OF dvd_mult2[OF H(1), of x] dvd_mult2[OF H(2), of y]]
+ dvd_diff_nat [OF dvd_mult2[OF H(2), of x] dvd_mult2[OF H(1), of y]] xy
+ have "e dvd ?gn" by (cases "a ^ n * x - b ^ n * y = gcd a b ^ n", simp_all)}
+ hence th: "\<forall>e. e dvd a^n \<and> e dvd b^n \<longrightarrow> e dvd ?gn" by blast
+ from divides_exp[OF gcd_dvd1[of a b], of n] divides_exp[OF gcd_dvd2[of a b], of n] th
+ gcd_unique have "?gn = ?g" by blast thus ?thesis by simp
+qed
+
+lemma coprime_exp2: "coprime (a ^ Suc n) (b^ Suc n) \<longleftrightarrow> coprime a b"
+by (simp only: coprime_def gcd_exp exp_eq_1) simp
+
+lemma division_decomp: assumes dc: "(a::nat) dvd b * c"
+ shows "\<exists>b' c'. a = b' * c' \<and> b' dvd b \<and> c' dvd c"
+proof-
+ let ?g = "gcd a b"
+ {assume "?g = 0" with dc have ?thesis apply (simp add: gcd_zero)
+ apply (rule exI[where x="0"])
+ by (rule exI[where x="c"], simp)}
+ moreover
+ {assume z: "?g \<noteq> 0"
+ from gcd_coprime_exists[OF z]
+ obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
+ from gcd_dvd2[of a b] have thb: "?g dvd b" .
+ from ab'(1) have "a' dvd a" unfolding dvd_def by blast
+ with dc have th0: "a' dvd b*c" using dvd_trans[of a' a "b*c"] by simp
+ from dc ab'(1,2) have "a'*?g dvd (b'*?g) *c" by auto
+ hence "?g*a' dvd ?g * (b' * c)" by (simp add: mult_assoc)
+ with z have th_1: "a' dvd b'*c" by simp
+ from coprime_divprod[OF th_1 ab'(3)] have thc: "a' dvd c" .
+ from ab' have "a = ?g*a'" by algebra
+ with thb thc have ?thesis by blast }
+ ultimately show ?thesis by blast
+qed
+
+lemma nat_power_eq_0_iff: "(m::nat) ^ n = 0 \<longleftrightarrow> n \<noteq> 0 \<and> m = 0" by (induct n, auto)
+
+lemma divides_rev: assumes ab: "(a::nat) ^ n dvd b ^n" and n:"n \<noteq> 0" shows "a dvd b"
+proof-
+ let ?g = "gcd a b"
+ from n obtain m where m: "n = Suc m" by (cases n, simp_all)
+ {assume "?g = 0" with ab n have ?thesis by (simp add: gcd_zero)}
+ moreover
+ {assume z: "?g \<noteq> 0"
+ hence zn: "?g ^ n \<noteq> 0" using n by (simp add: neq0_conv)
+ from gcd_coprime_exists[OF z]
+ obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
+ from ab have "(a' * ?g) ^ n dvd (b' * ?g)^n" by (simp add: ab'(1,2)[symmetric])
+ hence "?g^n*a'^n dvd ?g^n *b'^n" by (simp only: power_mult_distrib mult_commute)
+ with zn z n have th0:"a'^n dvd b'^n" by (auto simp add: nat_power_eq_0_iff)
+ have "a' dvd a'^n" by (simp add: m)
+ with th0 have "a' dvd b'^n" using dvd_trans[of a' "a'^n" "b'^n"] by simp
+ hence th1: "a' dvd b'^m * b'" by (simp add: m mult_commute)
+ from coprime_divprod[OF th1 coprime_exp[OF ab'(3), of m]]
+ have "a' dvd b'" .
+ hence "a'*?g dvd b'*?g" by simp
+ with ab'(1,2) have ?thesis by simp }
+ ultimately show ?thesis by blast
+qed
+
+lemma divides_mul: assumes mr: "m dvd r" and nr: "n dvd r" and mn:"coprime m n"
+ shows "m * n dvd r"
+proof-
+ from mr nr obtain m' n' where m': "r = m*m'" and n': "r = n*n'"
+ unfolding dvd_def by blast
+ from mr n' have "m dvd n'*n" by (simp add: mult_commute)
+ hence "m dvd n'" using relprime_dvd_mult_iff[OF mn[unfolded coprime_def]] by simp
+ then obtain k where k: "n' = m*k" unfolding dvd_def by blast
+ from n' k show ?thesis unfolding dvd_def by auto
+qed
+
+
+text {* A binary form of the Chinese Remainder Theorem. *}
+
+lemma chinese_remainder: assumes ab: "coprime a b" and a:"a \<noteq> 0" and b:"b \<noteq> 0"
+ shows "\<exists>x q1 q2. x = u + q1 * a \<and> x = v + q2 * b"
+proof-
+ from bezout_add_strong[OF a, of b] bezout_add_strong[OF b, of a]
+ obtain d1 x1 y1 d2 x2 y2 where dxy1: "d1 dvd a" "d1 dvd b" "a * x1 = b * y1 + d1"
+ and dxy2: "d2 dvd b" "d2 dvd a" "b * x2 = a * y2 + d2" by blast
+ from gcd_unique[of 1 a b, simplified ab[unfolded coprime_def], simplified]
+ dxy1(1,2) dxy2(1,2) have d12: "d1 = 1" "d2 =1" by auto
+ let ?x = "v * a * x1 + u * b * x2"
+ let ?q1 = "v * x1 + u * y2"
+ let ?q2 = "v * y1 + u * x2"
+ from dxy2(3)[simplified d12] dxy1(3)[simplified d12]
+ have "?x = u + ?q1 * a" "?x = v + ?q2 * b" by algebra+
+ thus ?thesis by blast
+qed
+
+text {* Primality *}
+
+text {* A few useful theorems about primes *}
+
+lemma prime_0[simp]: "~prime 0" by (simp add: prime_def)
+lemma prime_1[simp]: "~ prime 1" by (simp add: prime_def)
+lemma prime_Suc0[simp]: "~ prime (Suc 0)" by (simp add: prime_def)
+
+lemma prime_ge_2: "prime p ==> p \<ge> 2" by (simp add: prime_def)
+lemma prime_factor: assumes n: "n \<noteq> 1" shows "\<exists> p. prime p \<and> p dvd n"
+using n
+proof(induct n rule: nat_less_induct)
+ fix n
+ assume H: "\<forall>m<n. m \<noteq> 1 \<longrightarrow> (\<exists>p. prime p \<and> p dvd m)" "n \<noteq> 1"
+ let ?ths = "\<exists>p. prime p \<and> p dvd n"
+ {assume "n=0" hence ?ths using two_is_prime by auto}
+ moreover
+ {assume nz: "n\<noteq>0"
+ {assume "prime n" hence ?ths by - (rule exI[where x="n"], simp)}
+ moreover
+ {assume n: "\<not> prime n"
+ with nz H(2)
+ obtain k where k:"k dvd n" "k \<noteq> 1" "k \<noteq> n" by (auto simp add: prime_def)
+ from dvd_imp_le[OF k(1)] nz k(3) have kn: "k < n" by simp
+ from H(1)[rule_format, OF kn k(2)] obtain p where p: "prime p" "p dvd k" by blast
+ from dvd_trans[OF p(2) k(1)] p(1) have ?ths by blast}
+ ultimately have ?ths by blast}
+ ultimately show ?ths by blast
+qed
+
+lemma prime_factor_lt: assumes p: "prime p" and n: "n \<noteq> 0" and npm:"n = p * m"
+ shows "m < n"
+proof-
+ {assume "m=0" with n have ?thesis by simp}
+ moreover
+ {assume m: "m \<noteq> 0"
+ from npm have mn: "m dvd n" unfolding dvd_def by auto
+ from npm m have "n \<noteq> m" using p by auto
+ with dvd_imp_le[OF mn] n have ?thesis by simp}
+ ultimately show ?thesis by blast
+qed
+
+lemma euclid_bound: "\<exists>p. prime p \<and> n < p \<and> p <= Suc (fact n)"
+proof-
+ have f1: "fact n + 1 \<noteq> 1" using fact_le[of n] by arith
+ from prime_factor[OF f1] obtain p where p: "prime p" "p dvd fact n + 1" by blast
+ from dvd_imp_le[OF p(2)] have pfn: "p \<le> fact n + 1" by simp
+ {assume np: "p \<le> n"
+ from p(1) have p1: "p \<ge> 1" by (cases p, simp_all)
+ from divides_fact[OF p1 np] have pfn': "p dvd fact n" .
+ from divides_add_revr[OF pfn' p(2)] p(1) have False by simp}
+ hence "n < p" by arith
+ with p(1) pfn show ?thesis by auto
+qed
+
+lemma euclid: "\<exists>p. prime p \<and> p > n" using euclid_bound by auto
+
+lemma primes_infinite: "\<not> (finite {p. prime p})"
+apply(simp add: finite_nat_set_iff_bounded_le)
+apply (metis euclid linorder_not_le)
+done
+
+lemma coprime_prime: assumes ab: "coprime a b"
+ shows "~(prime p \<and> p dvd a \<and> p dvd b)"
+proof
+ assume "prime p \<and> p dvd a \<and> p dvd b"
+ thus False using ab gcd_greatest[of p a b] by (simp add: coprime_def)
+qed
+lemma coprime_prime_eq: "coprime a b \<longleftrightarrow> (\<forall>p. ~(prime p \<and> p dvd a \<and> p dvd b))"
+ (is "?lhs = ?rhs")
+proof-
+ {assume "?lhs" with coprime_prime have ?rhs by blast}
+ moreover
+ {assume r: "?rhs" and c: "\<not> ?lhs"
+ then obtain g where g: "g\<noteq>1" "g dvd a" "g dvd b" unfolding coprime_def by blast
+ from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
+ from dvd_trans [OF p(2) g(2)] dvd_trans [OF p(2) g(3)]
+ have "p dvd a" "p dvd b" . with p(1) r have False by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma prime_coprime: assumes p: "prime p"
+ shows "n = 1 \<or> p dvd n \<or> coprime p n"
+using p prime_imp_relprime[of p n] by (auto simp add: coprime_def)
+
+lemma prime_coprime_strong: "prime p \<Longrightarrow> p dvd n \<or> coprime p n"
+ using prime_coprime[of p n] by auto
+
+declare coprime_0[simp]
+
+lemma coprime_0'[simp]: "coprime 0 d \<longleftrightarrow> d = 1" by (simp add: coprime_commute[of 0 d])
+lemma coprime_bezout_strong: assumes ab: "coprime a b" and b: "b \<noteq> 1"
+ shows "\<exists>x y. a * x = b * y + 1"
+proof-
+ from ab b have az: "a \<noteq> 0" by - (rule ccontr, auto)
+ from bezout_gcd_strong[OF az, of b] ab[unfolded coprime_def]
+ show ?thesis by auto
+qed
+
+lemma bezout_prime: assumes p: "prime p" and pa: "\<not> p dvd a"
+ shows "\<exists>x y. a*x = p*y + 1"
+proof-
+ from p have p1: "p \<noteq> 1" using prime_1 by blast
+ from prime_coprime[OF p, of a] p1 pa have ap: "coprime a p"
+ by (auto simp add: coprime_commute)
+ from coprime_bezout_strong[OF ap p1] show ?thesis .
+qed
+lemma prime_divprod: assumes p: "prime p" and pab: "p dvd a*b"
+ shows "p dvd a \<or> p dvd b"
+proof-
+ {assume "a=1" hence ?thesis using pab by simp }
+ moreover
+ {assume "p dvd a" hence ?thesis by blast}
+ moreover
+ {assume pa: "coprime p a" from coprime_divprod[OF pab pa] have ?thesis .. }
+ ultimately show ?thesis using prime_coprime[OF p, of a] by blast
+qed
+
+lemma prime_divprod_eq: assumes p: "prime p"
+ shows "p dvd a*b \<longleftrightarrow> p dvd a \<or> p dvd b"
+using p prime_divprod dvd_mult dvd_mult2 by auto
+
+lemma prime_divexp: assumes p:"prime p" and px: "p dvd x^n"
+ shows "p dvd x"
+using px
+proof(induct n)
+ case 0 thus ?case by simp
+next
+ case (Suc n)
+ hence th: "p dvd x*x^n" by simp
+ {assume H: "p dvd x^n"
+ from Suc.hyps[OF H] have ?case .}
+ with prime_divprod[OF p th] show ?case by blast
+qed
+
+lemma prime_divexp_n: "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p^n dvd x^n"
+ using prime_divexp[of p x n] divides_exp[of p x n] by blast
+
+lemma coprime_prime_dvd_ex: assumes xy: "\<not>coprime x y"
+ shows "\<exists>p. prime p \<and> p dvd x \<and> p dvd y"
+proof-
+ from xy[unfolded coprime_def] obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd y"
+ by blast
+ from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
+ from g(2,3) dvd_trans[OF p(2)] p(1) show ?thesis by auto
+qed
+lemma coprime_sos: assumes xy: "coprime x y"
+ shows "coprime (x * y) (x^2 + y^2)"
+proof-
+ {assume c: "\<not> coprime (x * y) (x^2 + y^2)"
+ from coprime_prime_dvd_ex[OF c] obtain p
+ where p: "prime p" "p dvd x*y" "p dvd x^2 + y^2" by blast
+ {assume px: "p dvd x"
+ from dvd_mult[OF px, of x] p(3)
+ obtain r s where "x * x = p * r" and "x^2 + y^2 = p * s"
+ by (auto elim!: dvdE)
+ then have "y^2 = p * (s - r)"
+ by (auto simp add: power2_eq_square diff_mult_distrib2)
+ then have "p dvd y^2" ..
+ with prime_divexp[OF p(1), of y 2] have py: "p dvd y" .
+ from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
+ have False by simp }
+ moreover
+ {assume py: "p dvd y"
+ from dvd_mult[OF py, of y] p(3)
+ obtain r s where "y * y = p * r" and "x^2 + y^2 = p * s"
+ by (auto elim!: dvdE)
+ then have "x^2 = p * (s - r)"
+ by (auto simp add: power2_eq_square diff_mult_distrib2)
+ then have "p dvd x^2" ..
+ with prime_divexp[OF p(1), of x 2] have px: "p dvd x" .
+ from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
+ have False by simp }
+ ultimately have False using prime_divprod[OF p(1,2)] by blast}
+ thus ?thesis by blast
+qed
+
+lemma distinct_prime_coprime: "prime p \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
+ unfolding prime_def coprime_prime_eq by blast
+
+lemma prime_coprime_lt: assumes p: "prime p" and x: "0 < x" and xp: "x < p"
+ shows "coprime x p"
+proof-
+ {assume c: "\<not> coprime x p"
+ then obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd p" unfolding coprime_def by blast
+ from dvd_imp_le[OF g(2)] x xp have gp: "g < p" by arith
+ from g(2) x have "g \<noteq> 0" by - (rule ccontr, simp)
+ with g gp p[unfolded prime_def] have False by blast}
+thus ?thesis by blast
+qed
+
+lemma even_dvd[simp]: "even (n::nat) \<longleftrightarrow> 2 dvd n" by presburger
+lemma prime_odd: "prime p \<Longrightarrow> p = 2 \<or> odd p" unfolding prime_def by auto
+
+
+text {* One property of coprimality is easier to prove via prime factors. *}
+
+lemma prime_divprod_pow:
+ assumes p: "prime p" and ab: "coprime a b" and pab: "p^n dvd a * b"
+ shows "p^n dvd a \<or> p^n dvd b"
+proof-
+ {assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
+ apply (cases "n=0", simp_all)
+ apply (cases "a=1", simp_all) done}
+ moreover
+ {assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
+ then obtain m where m: "n = Suc m" by (cases n, auto)
+ from divides_exp2[OF n pab] have pab': "p dvd a*b" .
+ from prime_divprod[OF p pab']
+ have "p dvd a \<or> p dvd b" .
+ moreover
+ {assume pa: "p dvd a"
+ have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
+ from coprime_prime[OF ab, of p] p pa have "\<not> p dvd b" by blast
+ with prime_coprime[OF p, of b] b
+ have cpb: "coprime b p" using coprime_commute by blast
+ from coprime_exp[OF cpb] have pnb: "coprime (p^n) b"
+ by (simp add: coprime_commute)
+ from coprime_divprod[OF pnba pnb] have ?thesis by blast }
+ moreover
+ {assume pb: "p dvd b"
+ have pnba: "p^n dvd b*a" using pab by (simp add: mult_commute)
+ from coprime_prime[OF ab, of p] p pb have "\<not> p dvd a" by blast
+ with prime_coprime[OF p, of a] a
+ have cpb: "coprime a p" using coprime_commute by blast
+ from coprime_exp[OF cpb] have pnb: "coprime (p^n) a"
+ by (simp add: coprime_commute)
+ from coprime_divprod[OF pab pnb] have ?thesis by blast }
+ ultimately have ?thesis by blast}
+ ultimately show ?thesis by blast
+qed
+
+lemma nat_mult_eq_one: "(n::nat) * m = 1 \<longleftrightarrow> n = 1 \<and> m = 1" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+ assume H: "?lhs"
+ hence "n dvd 1" "m dvd 1" unfolding dvd_def by (auto simp add: mult_commute)
+ thus ?rhs by auto
+next
+ assume ?rhs then show ?lhs by auto
+qed
+
+lemma power_Suc0[simp]: "Suc 0 ^ n = Suc 0"
+ unfolding One_nat_def[symmetric] power_one ..
+lemma coprime_pow: assumes ab: "coprime a b" and abcn: "a * b = c ^n"
+ shows "\<exists>r s. a = r^n \<and> b = s ^n"
+ using ab abcn
+proof(induct c arbitrary: a b rule: nat_less_induct)
+ fix c a b
+ assume H: "\<forall>m<c. \<forall>a b. coprime a b \<longrightarrow> a * b = m ^ n \<longrightarrow> (\<exists>r s. a = r ^ n \<and> b = s ^ n)" "coprime a b" "a * b = c ^ n"
+ let ?ths = "\<exists>r s. a = r^n \<and> b = s ^n"
+ {assume n: "n = 0"
+ with H(3) power_one have "a*b = 1" by simp
+ hence "a = 1 \<and> b = 1" by simp
+ hence ?ths
+ apply -
+ apply (rule exI[where x=1])
+ apply (rule exI[where x=1])
+ using power_one[of n]
+ by simp}
+ moreover
+ {assume n: "n \<noteq> 0" then obtain m where m: "n = Suc m" by (cases n, auto)
+ {assume c: "c = 0"
+ with H(3) m H(2) have ?ths apply simp
+ apply (cases "a=0", simp_all)
+ apply (rule exI[where x="0"], simp)
+ apply (rule exI[where x="0"], simp)
+ done}
+ moreover
+ {assume "c=1" with H(3) power_one have "a*b = 1" by simp
+ hence "a = 1 \<and> b = 1" by simp
+ hence ?ths
+ apply -
+ apply (rule exI[where x=1])
+ apply (rule exI[where x=1])
+ using power_one[of n]
+ by simp}
+ moreover
+ {assume c: "c\<noteq>1" "c \<noteq> 0"
+ from prime_factor[OF c(1)] obtain p where p: "prime p" "p dvd c" by blast
+ from prime_divprod_pow[OF p(1) H(2), unfolded H(3), OF divides_exp[OF p(2), of n]]
+ have pnab: "p ^ n dvd a \<or> p^n dvd b" .
+ from p(2) obtain l where l: "c = p*l" unfolding dvd_def by blast
+ have pn0: "p^n \<noteq> 0" using n prime_ge_2 [OF p(1)] by (simp add: neq0_conv)
+ {assume pa: "p^n dvd a"
+ then obtain k where k: "a = p^n * k" unfolding dvd_def by blast
+ from l have "l dvd c" by auto
+ with dvd_imp_le[of l c] c have "l \<le> c" by auto
+ moreover {assume "l = c" with l c have "p = 1" by simp with p have False by simp}
+ ultimately have lc: "l < c" by arith
+ from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" b]]]
+ have kb: "coprime k b" by (simp add: coprime_commute)
+ from H(3) l k pn0 have kbln: "k * b = l ^ n"
+ by (auto simp add: power_mult_distrib)
+ from H(1)[rule_format, OF lc kb kbln]
+ obtain r s where rs: "k = r ^n" "b = s^n" by blast
+ from k rs(1) have "a = (p*r)^n" by (simp add: power_mult_distrib)
+ with rs(2) have ?ths by blast }
+ moreover
+ {assume pb: "p^n dvd b"
+ then obtain k where k: "b = p^n * k" unfolding dvd_def by blast
+ from l have "l dvd c" by auto
+ with dvd_imp_le[of l c] c have "l \<le> c" by auto
+ moreover {assume "l = c" with l c have "p = 1" by simp with p have False by simp}
+ ultimately have lc: "l < c" by arith
+ from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" a]]]
+ have kb: "coprime k a" by (simp add: coprime_commute)
+ from H(3) l k pn0 n have kbln: "k * a = l ^ n"
+ by (simp add: power_mult_distrib mult_commute)
+ from H(1)[rule_format, OF lc kb kbln]
+ obtain r s where rs: "k = r ^n" "a = s^n" by blast
+ from k rs(1) have "b = (p*r)^n" by (simp add: power_mult_distrib)
+ with rs(2) have ?ths by blast }
+ ultimately have ?ths using pnab by blast}
+ ultimately have ?ths by blast}
+ultimately show ?ths by blast
+qed
+
+text {* More useful lemmas. *}
+lemma prime_product:
+ assumes "prime (p * q)"
+ shows "p = 1 \<or> q = 1"
+proof -
+ from assms have
+ "1 < p * q" and P: "\<And>m. m dvd p * q \<Longrightarrow> m = 1 \<or> m = p * q"
+ unfolding prime_def by auto
+ from `1 < p * q` have "p \<noteq> 0" by (cases p) auto
+ then have Q: "p = p * q \<longleftrightarrow> q = 1" by auto
+ have "p dvd p * q" by simp
+ then have "p = 1 \<or> p = p * q" by (rule P)
+ then show ?thesis by (simp add: Q)
+qed
+
+lemma prime_exp: "prime (p^n) \<longleftrightarrow> prime p \<and> n = 1"
+proof(induct n)
+ case 0 thus ?case by simp
+next
+ case (Suc n)
+ {assume "p = 0" hence ?case by simp}
+ moreover
+ {assume "p=1" hence ?case by simp}
+ moreover
+ {assume p: "p \<noteq> 0" "p\<noteq>1"
+ {assume pp: "prime (p^Suc n)"
+ hence "p = 1 \<or> p^n = 1" using prime_product[of p "p^n"] by simp
+ with p have n: "n = 0"
+ by (simp only: exp_eq_1 ) simp
+ with pp have "prime p \<and> Suc n = 1" by simp}
+ moreover
+ {assume n: "prime p \<and> Suc n = 1" hence "prime (p^Suc n)" by simp}
+ ultimately have ?case by blast}
+ ultimately show ?case by blast
+qed
+
+lemma prime_power_mult:
+ assumes p: "prime p" and xy: "x * y = p ^ k"
+ shows "\<exists>i j. x = p ^i \<and> y = p^ j"
+ using xy
+proof(induct k arbitrary: x y)
+ case 0 thus ?case apply simp by (rule exI[where x="0"], simp)
+next
+ case (Suc k x y)
+ from Suc.prems have pxy: "p dvd x*y" by auto
+ from prime_divprod[OF p pxy] have pxyc: "p dvd x \<or> p dvd y" .
+ from p have p0: "p \<noteq> 0" by - (rule ccontr, simp)
+ {assume px: "p dvd x"
+ then obtain d where d: "x = p*d" unfolding dvd_def by blast
+ from Suc.prems d have "p*d*y = p^Suc k" by simp
+ hence th: "d*y = p^k" using p0 by simp
+ from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "y = p^j" by blast
+ with d have "x = p^Suc i" by simp
+ with ij(2) have ?case by blast}
+ moreover
+ {assume px: "p dvd y"
+ then obtain d where d: "y = p*d" unfolding dvd_def by blast
+ from Suc.prems d have "p*d*x = p^Suc k" by (simp add: mult_commute)
+ hence th: "d*x = p^k" using p0 by simp
+ from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "x = p^j" by blast
+ with d have "y = p^Suc i" by simp
+ with ij(2) have ?case by blast}
+ ultimately show ?case using pxyc by blast
+qed
+
+lemma prime_power_exp: assumes p: "prime p" and n:"n \<noteq> 0"
+ and xn: "x^n = p^k" shows "\<exists>i. x = p^i"
+ using n xn
+proof(induct n arbitrary: k)
+ case 0 thus ?case by simp
+next
+ case (Suc n k) hence th: "x*x^n = p^k" by simp
+ {assume "n = 0" with prems have ?case apply simp
+ by (rule exI[where x="k"],simp)}
+ moreover
+ {assume n: "n \<noteq> 0"
+ from prime_power_mult[OF p th]
+ obtain i j where ij: "x = p^i" "x^n = p^j"by blast
+ from Suc.hyps[OF n ij(2)] have ?case .}
+ ultimately show ?case by blast
+qed
+
+lemma divides_primepow: assumes p: "prime p"
+ shows "d dvd p^k \<longleftrightarrow> (\<exists> i. i \<le> k \<and> d = p ^i)"
+proof
+ assume H: "d dvd p^k" then obtain e where e: "d*e = p^k"
+ unfolding dvd_def apply (auto simp add: mult_commute) by blast
+ from prime_power_mult[OF p e] obtain i j where ij: "d = p^i" "e=p^j" by blast
+ from prime_ge_2[OF p] have p1: "p > 1" by arith
+ from e ij have "p^(i + j) = p^k" by (simp add: power_add)
+ hence "i + j = k" using power_inject_exp[of p "i+j" k, OF p1] by simp
+ hence "i \<le> k" by arith
+ with ij(1) show "\<exists>i\<le>k. d = p ^ i" by blast
+next
+ {fix i assume H: "i \<le> k" "d = p^i"
+ hence "\<exists>j. k = i + j" by arith
+ then obtain j where j: "k = i + j" by blast
+ hence "p^k = p^j*d" using H(2) by (simp add: power_add)
+ hence "d dvd p^k" unfolding dvd_def by auto}
+ thus "\<exists>i\<le>k. d = p ^ i \<Longrightarrow> d dvd p ^ k" by blast
+qed
+
+lemma coprime_divisors: "d dvd a \<Longrightarrow> e dvd b \<Longrightarrow> coprime a b \<Longrightarrow> coprime d e"
+ by (auto simp add: dvd_def coprime)
+
+declare power_Suc0[simp del]
+declare even_dvd[simp del]
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Quadratic_Reciprocity.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,642 @@
+(* Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {* The law of Quadratic reciprocity *}
+
+theory Quadratic_Reciprocity
+imports Gauss
+begin
+
+text {*
+ Lemmas leading up to the proof of theorem 3.3 in Niven and
+ Zuckerman's presentation.
+*}
+
+context GAUSS
+begin
+
+lemma QRLemma1: "a * setsum id A =
+ p * setsum (%x. ((x * a) div p)) A + setsum id D + setsum id E"
+proof -
+ from finite_A have "a * setsum id A = setsum (%x. a * x) A"
+ by (auto simp add: setsum_const_mult id_def)
+ also have "setsum (%x. a * x) = setsum (%x. x * a)"
+ by (auto simp add: zmult_commute)
+ also have "setsum (%x. x * a) A = setsum id B"
+ by (simp add: B_def setsum_reindex_id[OF inj_on_xa_A])
+ also have "... = setsum (%x. p * (x div p) + StandardRes p x) B"
+ by (auto simp add: StandardRes_def zmod_zdiv_equality)
+ also have "... = setsum (%x. p * (x div p)) B + setsum (StandardRes p) B"
+ by (rule setsum_addf)
+ also have "setsum (StandardRes p) B = setsum id C"
+ by (auto simp add: C_def setsum_reindex_id[OF SR_B_inj])
+ also from C_eq have "... = setsum id (D \<union> E)"
+ by auto
+ also from finite_D finite_E have "... = setsum id D + setsum id E"
+ by (rule setsum_Un_disjoint) (auto simp add: D_def E_def)
+ also have "setsum (%x. p * (x div p)) B =
+ setsum ((%x. p * (x div p)) o (%x. (x * a))) A"
+ by (auto simp add: B_def setsum_reindex inj_on_xa_A)
+ also have "... = setsum (%x. p * ((x * a) div p)) A"
+ by (auto simp add: o_def)
+ also from finite_A have "setsum (%x. p * ((x * a) div p)) A =
+ p * setsum (%x. ((x * a) div p)) A"
+ by (auto simp add: setsum_const_mult)
+ finally show ?thesis by arith
+qed
+
+lemma QRLemma2: "setsum id A = p * int (card E) - setsum id E +
+ setsum id D"
+proof -
+ from F_Un_D_eq_A have "setsum id A = setsum id (D \<union> F)"
+ by (simp add: Un_commute)
+ also from F_D_disj finite_D finite_F
+ have "... = setsum id D + setsum id F"
+ by (auto simp add: Int_commute intro: setsum_Un_disjoint)
+ also from F_def have "F = (%x. (p - x)) ` E"
+ by auto
+ also from finite_E inj_on_pminusx_E have "setsum id ((%x. (p - x)) ` E) =
+ setsum (%x. (p - x)) E"
+ by (auto simp add: setsum_reindex)
+ also from finite_E have "setsum (op - p) E = setsum (%x. p) E - setsum id E"
+ by (auto simp add: setsum_subtractf id_def)
+ also from finite_E have "setsum (%x. p) E = p * int(card E)"
+ by (intro setsum_const)
+ finally show ?thesis
+ by arith
+qed
+
+lemma QRLemma3: "(a - 1) * setsum id A =
+ p * (setsum (%x. ((x * a) div p)) A - int(card E)) + 2 * setsum id E"
+proof -
+ have "(a - 1) * setsum id A = a * setsum id A - setsum id A"
+ by (auto simp add: zdiff_zmult_distrib)
+ also note QRLemma1
+ also from QRLemma2 have "p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
+ setsum id E - setsum id A =
+ p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
+ setsum id E - (p * int (card E) - setsum id E + setsum id D)"
+ by auto
+ also have "... = p * (\<Sum>x \<in> A. x * a div p) -
+ p * int (card E) + 2 * setsum id E"
+ by arith
+ finally show ?thesis
+ by (auto simp only: zdiff_zmult_distrib2)
+qed
+
+lemma QRLemma4: "a \<in> zOdd ==>
+ (setsum (%x. ((x * a) div p)) A \<in> zEven) = (int(card E): zEven)"
+proof -
+ assume a_odd: "a \<in> zOdd"
+ from QRLemma3 have a: "p * (setsum (%x. ((x * a) div p)) A - int(card E)) =
+ (a - 1) * setsum id A - 2 * setsum id E"
+ by arith
+ from a_odd have "a - 1 \<in> zEven"
+ by (rule odd_minus_one_even)
+ hence "(a - 1) * setsum id A \<in> zEven"
+ by (rule even_times_either)
+ moreover have "2 * setsum id E \<in> zEven"
+ by (auto simp add: zEven_def)
+ ultimately have "(a - 1) * setsum id A - 2 * setsum id E \<in> zEven"
+ by (rule even_minus_even)
+ with a have "p * (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
+ by simp
+ hence "p \<in> zEven | (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
+ by (rule EvenOdd.even_product)
+ with p_odd have "(setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
+ by (auto simp add: odd_iff_not_even)
+ thus ?thesis
+ by (auto simp only: even_diff [symmetric])
+qed
+
+lemma QRLemma5: "a \<in> zOdd ==>
+ (-1::int)^(card E) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
+proof -
+ assume "a \<in> zOdd"
+ from QRLemma4 [OF this] have
+ "(int(card E): zEven) = (setsum (%x. ((x * a) div p)) A \<in> zEven)" ..
+ moreover have "0 \<le> int(card E)"
+ by auto
+ moreover have "0 \<le> setsum (%x. ((x * a) div p)) A"
+ proof (intro setsum_nonneg)
+ show "\<forall>x \<in> A. 0 \<le> x * a div p"
+ proof
+ fix x
+ assume "x \<in> A"
+ then have "0 \<le> x"
+ by (auto simp add: A_def)
+ with a_nonzero have "0 \<le> x * a"
+ by (auto simp add: zero_le_mult_iff)
+ with p_g_2 show "0 \<le> x * a div p"
+ by (auto simp add: pos_imp_zdiv_nonneg_iff)
+ qed
+ qed
+ ultimately have "(-1::int)^nat((int (card E))) =
+ (-1)^nat(((\<Sum>x \<in> A. x * a div p)))"
+ by (intro neg_one_power_parity, auto)
+ also have "nat (int(card E)) = card E"
+ by auto
+ finally show ?thesis .
+qed
+
+end
+
+lemma MainQRLemma: "[| a \<in> zOdd; 0 < a; ~([a = 0] (mod p)); zprime p; 2 < p;
+ A = {x. 0 < x & x \<le> (p - 1) div 2} |] ==>
+ (Legendre a p) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
+ apply (subst GAUSS.gauss_lemma)
+ apply (auto simp add: GAUSS_def)
+ apply (subst GAUSS.QRLemma5)
+ apply (auto simp add: GAUSS_def)
+ apply (simp add: GAUSS.A_def [OF GAUSS.intro] GAUSS_def)
+ done
+
+
+subsection {* Stuff about S, S1 and S2 *}
+
+locale QRTEMP =
+ fixes p :: "int"
+ fixes q :: "int"
+
+ assumes p_prime: "zprime p"
+ assumes p_g_2: "2 < p"
+ assumes q_prime: "zprime q"
+ assumes q_g_2: "2 < q"
+ assumes p_neq_q: "p \<noteq> q"
+begin
+
+definition
+ P_set :: "int set" where
+ "P_set = {x. 0 < x & x \<le> ((p - 1) div 2) }"
+
+definition
+ Q_set :: "int set" where
+ "Q_set = {x. 0 < x & x \<le> ((q - 1) div 2) }"
+
+definition
+ S :: "(int * int) set" where
+ "S = P_set <*> Q_set"
+
+definition
+ S1 :: "(int * int) set" where
+ "S1 = { (x, y). (x, y):S & ((p * y) < (q * x)) }"
+
+definition
+ S2 :: "(int * int) set" where
+ "S2 = { (x, y). (x, y):S & ((q * x) < (p * y)) }"
+
+definition
+ f1 :: "int => (int * int) set" where
+ "f1 j = { (j1, y). (j1, y):S & j1 = j & (y \<le> (q * j) div p) }"
+
+definition
+ f2 :: "int => (int * int) set" where
+ "f2 j = { (x, j1). (x, j1):S & j1 = j & (x \<le> (p * j) div q) }"
+
+lemma p_fact: "0 < (p - 1) div 2"
+proof -
+ from p_g_2 have "2 \<le> p - 1" by arith
+ then have "2 div 2 \<le> (p - 1) div 2" by (rule zdiv_mono1, auto)
+ then show ?thesis by auto
+qed
+
+lemma q_fact: "0 < (q - 1) div 2"
+proof -
+ from q_g_2 have "2 \<le> q - 1" by arith
+ then have "2 div 2 \<le> (q - 1) div 2" by (rule zdiv_mono1, auto)
+ then show ?thesis by auto
+qed
+
+lemma pb_neq_qa: "[|1 \<le> b; b \<le> (q - 1) div 2 |] ==>
+ (p * b \<noteq> q * a)"
+proof
+ assume "p * b = q * a" and "1 \<le> b" and "b \<le> (q - 1) div 2"
+ then have "q dvd (p * b)" by (auto simp add: dvd_def)
+ with q_prime p_g_2 have "q dvd p | q dvd b"
+ by (auto simp add: zprime_zdvd_zmult)
+ moreover have "~ (q dvd p)"
+ proof
+ assume "q dvd p"
+ with p_prime have "q = 1 | q = p"
+ apply (auto simp add: zprime_def QRTEMP_def)
+ apply (drule_tac x = q and R = False in allE)
+ apply (simp add: QRTEMP_def)
+ apply (subgoal_tac "0 \<le> q", simp add: QRTEMP_def)
+ apply (insert prems)
+ apply (auto simp add: QRTEMP_def)
+ done
+ with q_g_2 p_neq_q show False by auto
+ qed
+ ultimately have "q dvd b" by auto
+ then have "q \<le> b"
+ proof -
+ assume "q dvd b"
+ moreover from prems have "0 < b" by auto
+ ultimately show ?thesis using zdvd_bounds [of q b] by auto
+ qed
+ with prems have "q \<le> (q - 1) div 2" by auto
+ then have "2 * q \<le> 2 * ((q - 1) div 2)" by arith
+ then have "2 * q \<le> q - 1"
+ proof -
+ assume "2 * q \<le> 2 * ((q - 1) div 2)"
+ with prems have "q \<in> zOdd" by (auto simp add: QRTEMP_def zprime_zOdd_eq_grt_2)
+ with odd_minus_one_even have "(q - 1):zEven" by auto
+ with even_div_2_prop2 have "(q - 1) = 2 * ((q - 1) div 2)" by auto
+ with prems show ?thesis by auto
+ qed
+ then have p1: "q \<le> -1" by arith
+ with q_g_2 show False by auto
+qed
+
+lemma P_set_finite: "finite (P_set)"
+ using p_fact by (auto simp add: P_set_def bdd_int_set_l_le_finite)
+
+lemma Q_set_finite: "finite (Q_set)"
+ using q_fact by (auto simp add: Q_set_def bdd_int_set_l_le_finite)
+
+lemma S_finite: "finite S"
+ by (auto simp add: S_def P_set_finite Q_set_finite finite_cartesian_product)
+
+lemma S1_finite: "finite S1"
+proof -
+ have "finite S" by (auto simp add: S_finite)
+ moreover have "S1 \<subseteq> S" by (auto simp add: S1_def S_def)
+ ultimately show ?thesis by (auto simp add: finite_subset)
+qed
+
+lemma S2_finite: "finite S2"
+proof -
+ have "finite S" by (auto simp add: S_finite)
+ moreover have "S2 \<subseteq> S" by (auto simp add: S2_def S_def)
+ ultimately show ?thesis by (auto simp add: finite_subset)
+qed
+
+lemma P_set_card: "(p - 1) div 2 = int (card (P_set))"
+ using p_fact by (auto simp add: P_set_def card_bdd_int_set_l_le)
+
+lemma Q_set_card: "(q - 1) div 2 = int (card (Q_set))"
+ using q_fact by (auto simp add: Q_set_def card_bdd_int_set_l_le)
+
+lemma S_card: "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
+ using P_set_card Q_set_card P_set_finite Q_set_finite
+ by (auto simp add: S_def zmult_int setsum_constant)
+
+lemma S1_Int_S2_prop: "S1 \<inter> S2 = {}"
+ by (auto simp add: S1_def S2_def)
+
+lemma S1_Union_S2_prop: "S = S1 \<union> S2"
+ apply (auto simp add: S_def P_set_def Q_set_def S1_def S2_def)
+proof -
+ fix a and b
+ assume "~ q * a < p * b" and b1: "0 < b" and b2: "b \<le> (q - 1) div 2"
+ with zless_linear have "(p * b < q * a) | (p * b = q * a)" by auto
+ moreover from pb_neq_qa b1 b2 have "(p * b \<noteq> q * a)" by auto
+ ultimately show "p * b < q * a" by auto
+qed
+
+lemma card_sum_S1_S2: "((p - 1) div 2) * ((q - 1) div 2) =
+ int(card(S1)) + int(card(S2))"
+proof -
+ have "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
+ by (auto simp add: S_card)
+ also have "... = int( card(S1) + card(S2))"
+ apply (insert S1_finite S2_finite S1_Int_S2_prop S1_Union_S2_prop)
+ apply (drule card_Un_disjoint, auto)
+ done
+ also have "... = int(card(S1)) + int(card(S2))" by auto
+ finally show ?thesis .
+qed
+
+lemma aux1a: "[| 0 < a; a \<le> (p - 1) div 2;
+ 0 < b; b \<le> (q - 1) div 2 |] ==>
+ (p * b < q * a) = (b \<le> q * a div p)"
+proof -
+ assume "0 < a" and "a \<le> (p - 1) div 2" and "0 < b" and "b \<le> (q - 1) div 2"
+ have "p * b < q * a ==> b \<le> q * a div p"
+ proof -
+ assume "p * b < q * a"
+ then have "p * b \<le> q * a" by auto
+ then have "(p * b) div p \<le> (q * a) div p"
+ by (rule zdiv_mono1) (insert p_g_2, auto)
+ then show "b \<le> (q * a) div p"
+ apply (subgoal_tac "p \<noteq> 0")
+ apply (frule div_mult_self1_is_id, force)
+ apply (insert p_g_2, auto)
+ done
+ qed
+ moreover have "b \<le> q * a div p ==> p * b < q * a"
+ proof -
+ assume "b \<le> q * a div p"
+ then have "p * b \<le> p * ((q * a) div p)"
+ using p_g_2 by (auto simp add: mult_le_cancel_left)
+ also have "... \<le> q * a"
+ by (rule zdiv_leq_prop) (insert p_g_2, auto)
+ finally have "p * b \<le> q * a" .
+ then have "p * b < q * a | p * b = q * a"
+ by (simp only: order_le_imp_less_or_eq)
+ moreover have "p * b \<noteq> q * a"
+ by (rule pb_neq_qa) (insert prems, auto)
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis ..
+qed
+
+lemma aux1b: "[| 0 < a; a \<le> (p - 1) div 2;
+ 0 < b; b \<le> (q - 1) div 2 |] ==>
+ (q * a < p * b) = (a \<le> p * b div q)"
+proof -
+ assume "0 < a" and "a \<le> (p - 1) div 2" and "0 < b" and "b \<le> (q - 1) div 2"
+ have "q * a < p * b ==> a \<le> p * b div q"
+ proof -
+ assume "q * a < p * b"
+ then have "q * a \<le> p * b" by auto
+ then have "(q * a) div q \<le> (p * b) div q"
+ by (rule zdiv_mono1) (insert q_g_2, auto)
+ then show "a \<le> (p * b) div q"
+ apply (subgoal_tac "q \<noteq> 0")
+ apply (frule div_mult_self1_is_id, force)
+ apply (insert q_g_2, auto)
+ done
+ qed
+ moreover have "a \<le> p * b div q ==> q * a < p * b"
+ proof -
+ assume "a \<le> p * b div q"
+ then have "q * a \<le> q * ((p * b) div q)"
+ using q_g_2 by (auto simp add: mult_le_cancel_left)
+ also have "... \<le> p * b"
+ by (rule zdiv_leq_prop) (insert q_g_2, auto)
+ finally have "q * a \<le> p * b" .
+ then have "q * a < p * b | q * a = p * b"
+ by (simp only: order_le_imp_less_or_eq)
+ moreover have "p * b \<noteq> q * a"
+ by (rule pb_neq_qa) (insert prems, auto)
+ ultimately show ?thesis by auto
+ qed
+ ultimately show ?thesis ..
+qed
+
+lemma (in -) aux2: "[| zprime p; zprime q; 2 < p; 2 < q |] ==>
+ (q * ((p - 1) div 2)) div p \<le> (q - 1) div 2"
+proof-
+ assume "zprime p" and "zprime q" and "2 < p" and "2 < q"
+ (* Set up what's even and odd *)
+ then have "p \<in> zOdd & q \<in> zOdd"
+ by (auto simp add: zprime_zOdd_eq_grt_2)
+ then have even1: "(p - 1):zEven & (q - 1):zEven"
+ by (auto simp add: odd_minus_one_even)
+ then have even2: "(2 * p):zEven & ((q - 1) * p):zEven"
+ by (auto simp add: zEven_def)
+ then have even3: "(((q - 1) * p) + (2 * p)):zEven"
+ by (auto simp: EvenOdd.even_plus_even)
+ (* using these prove it *)
+ from prems have "q * (p - 1) < ((q - 1) * p) + (2 * p)"
+ by (auto simp add: int_distrib)
+ then have "((p - 1) * q) div 2 < (((q - 1) * p) + (2 * p)) div 2"
+ apply (rule_tac x = "((p - 1) * q)" in even_div_2_l)
+ by (auto simp add: even3, auto simp add: zmult_ac)
+ also have "((p - 1) * q) div 2 = q * ((p - 1) div 2)"
+ by (auto simp add: even1 even_prod_div_2)
+ also have "(((q - 1) * p) + (2 * p)) div 2 = (((q - 1) div 2) * p) + p"
+ by (auto simp add: even1 even2 even_prod_div_2 even_sum_div_2)
+ finally show ?thesis
+ apply (rule_tac x = " q * ((p - 1) div 2)" and
+ y = "(q - 1) div 2" in div_prop2)
+ using prems by auto
+qed
+
+lemma aux3a: "\<forall>j \<in> P_set. int (card (f1 j)) = (q * j) div p"
+proof
+ fix j
+ assume j_fact: "j \<in> P_set"
+ have "int (card (f1 j)) = int (card {y. y \<in> Q_set & y \<le> (q * j) div p})"
+ proof -
+ have "finite (f1 j)"
+ proof -
+ have "(f1 j) \<subseteq> S" by (auto simp add: f1_def)
+ with S_finite show ?thesis by (auto simp add: finite_subset)
+ qed
+ moreover have "inj_on (%(x,y). y) (f1 j)"
+ by (auto simp add: f1_def inj_on_def)
+ ultimately have "card ((%(x,y). y) ` (f1 j)) = card (f1 j)"
+ by (auto simp add: f1_def card_image)
+ moreover have "((%(x,y). y) ` (f1 j)) = {y. y \<in> Q_set & y \<le> (q * j) div p}"
+ using prems by (auto simp add: f1_def S_def Q_set_def P_set_def image_def)
+ ultimately show ?thesis by (auto simp add: f1_def)
+ qed
+ also have "... = int (card {y. 0 < y & y \<le> (q * j) div p})"
+ proof -
+ have "{y. y \<in> Q_set & y \<le> (q * j) div p} =
+ {y. 0 < y & y \<le> (q * j) div p}"
+ apply (auto simp add: Q_set_def)
+ proof -
+ fix x
+ assume "0 < x" and "x \<le> q * j div p"
+ with j_fact P_set_def have "j \<le> (p - 1) div 2" by auto
+ with q_g_2 have "q * j \<le> q * ((p - 1) div 2)"
+ by (auto simp add: mult_le_cancel_left)
+ with p_g_2 have "q * j div p \<le> q * ((p - 1) div 2) div p"
+ by (auto simp add: zdiv_mono1)
+ also from prems P_set_def have "... \<le> (q - 1) div 2"
+ apply simp
+ apply (insert aux2)
+ apply (simp add: QRTEMP_def)
+ done
+ finally show "x \<le> (q - 1) div 2" using prems by auto
+ qed
+ then show ?thesis by auto
+ qed
+ also have "... = (q * j) div p"
+ proof -
+ from j_fact P_set_def have "0 \<le> j" by auto
+ with q_g_2 have "q * 0 \<le> q * j" by (auto simp only: mult_left_mono)
+ then have "0 \<le> q * j" by auto
+ then have "0 div p \<le> (q * j) div p"
+ apply (rule_tac a = 0 in zdiv_mono1)
+ apply (insert p_g_2, auto)
+ done
+ also have "0 div p = 0" by auto
+ finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
+ qed
+ finally show "int (card (f1 j)) = q * j div p" .
+qed
+
+lemma aux3b: "\<forall>j \<in> Q_set. int (card (f2 j)) = (p * j) div q"
+proof
+ fix j
+ assume j_fact: "j \<in> Q_set"
+ have "int (card (f2 j)) = int (card {y. y \<in> P_set & y \<le> (p * j) div q})"
+ proof -
+ have "finite (f2 j)"
+ proof -
+ have "(f2 j) \<subseteq> S" by (auto simp add: f2_def)
+ with S_finite show ?thesis by (auto simp add: finite_subset)
+ qed
+ moreover have "inj_on (%(x,y). x) (f2 j)"
+ by (auto simp add: f2_def inj_on_def)
+ ultimately have "card ((%(x,y). x) ` (f2 j)) = card (f2 j)"
+ by (auto simp add: f2_def card_image)
+ moreover have "((%(x,y). x) ` (f2 j)) = {y. y \<in> P_set & y \<le> (p * j) div q}"
+ using prems by (auto simp add: f2_def S_def Q_set_def P_set_def image_def)
+ ultimately show ?thesis by (auto simp add: f2_def)
+ qed
+ also have "... = int (card {y. 0 < y & y \<le> (p * j) div q})"
+ proof -
+ have "{y. y \<in> P_set & y \<le> (p * j) div q} =
+ {y. 0 < y & y \<le> (p * j) div q}"
+ apply (auto simp add: P_set_def)
+ proof -
+ fix x
+ assume "0 < x" and "x \<le> p * j div q"
+ with j_fact Q_set_def have "j \<le> (q - 1) div 2" by auto
+ with p_g_2 have "p * j \<le> p * ((q - 1) div 2)"
+ by (auto simp add: mult_le_cancel_left)
+ with q_g_2 have "p * j div q \<le> p * ((q - 1) div 2) div q"
+ by (auto simp add: zdiv_mono1)
+ also from prems have "... \<le> (p - 1) div 2"
+ by (auto simp add: aux2 QRTEMP_def)
+ finally show "x \<le> (p - 1) div 2" using prems by auto
+ qed
+ then show ?thesis by auto
+ qed
+ also have "... = (p * j) div q"
+ proof -
+ from j_fact Q_set_def have "0 \<le> j" by auto
+ with p_g_2 have "p * 0 \<le> p * j" by (auto simp only: mult_left_mono)
+ then have "0 \<le> p * j" by auto
+ then have "0 div q \<le> (p * j) div q"
+ apply (rule_tac a = 0 in zdiv_mono1)
+ apply (insert q_g_2, auto)
+ done
+ also have "0 div q = 0" by auto
+ finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
+ qed
+ finally show "int (card (f2 j)) = p * j div q" .
+qed
+
+lemma S1_card: "int (card(S1)) = setsum (%j. (q * j) div p) P_set"
+proof -
+ have "\<forall>x \<in> P_set. finite (f1 x)"
+ proof
+ fix x
+ have "f1 x \<subseteq> S" by (auto simp add: f1_def)
+ with S_finite show "finite (f1 x)" by (auto simp add: finite_subset)
+ qed
+ moreover have "(\<forall>x \<in> P_set. \<forall>y \<in> P_set. x \<noteq> y --> (f1 x) \<inter> (f1 y) = {})"
+ by (auto simp add: f1_def)
+ moreover note P_set_finite
+ ultimately have "int(card (UNION P_set f1)) =
+ setsum (%x. int(card (f1 x))) P_set"
+ by(simp add:card_UN_disjoint int_setsum o_def)
+ moreover have "S1 = UNION P_set f1"
+ by (auto simp add: f1_def S_def S1_def S2_def P_set_def Q_set_def aux1a)
+ ultimately have "int(card (S1)) = setsum (%j. int(card (f1 j))) P_set"
+ by auto
+ also have "... = setsum (%j. q * j div p) P_set"
+ using aux3a by(fastsimp intro: setsum_cong)
+ finally show ?thesis .
+qed
+
+lemma S2_card: "int (card(S2)) = setsum (%j. (p * j) div q) Q_set"
+proof -
+ have "\<forall>x \<in> Q_set. finite (f2 x)"
+ proof
+ fix x
+ have "f2 x \<subseteq> S" by (auto simp add: f2_def)
+ with S_finite show "finite (f2 x)" by (auto simp add: finite_subset)
+ qed
+ moreover have "(\<forall>x \<in> Q_set. \<forall>y \<in> Q_set. x \<noteq> y -->
+ (f2 x) \<inter> (f2 y) = {})"
+ by (auto simp add: f2_def)
+ moreover note Q_set_finite
+ ultimately have "int(card (UNION Q_set f2)) =
+ setsum (%x. int(card (f2 x))) Q_set"
+ by(simp add:card_UN_disjoint int_setsum o_def)
+ moreover have "S2 = UNION Q_set f2"
+ by (auto simp add: f2_def S_def S1_def S2_def P_set_def Q_set_def aux1b)
+ ultimately have "int(card (S2)) = setsum (%j. int(card (f2 j))) Q_set"
+ by auto
+ also have "... = setsum (%j. p * j div q) Q_set"
+ using aux3b by(fastsimp intro: setsum_cong)
+ finally show ?thesis .
+qed
+
+lemma S1_carda: "int (card(S1)) =
+ setsum (%j. (j * q) div p) P_set"
+ by (auto simp add: S1_card zmult_ac)
+
+lemma S2_carda: "int (card(S2)) =
+ setsum (%j. (j * p) div q) Q_set"
+ by (auto simp add: S2_card zmult_ac)
+
+lemma pq_sum_prop: "(setsum (%j. (j * p) div q) Q_set) +
+ (setsum (%j. (j * q) div p) P_set) = ((p - 1) div 2) * ((q - 1) div 2)"
+proof -
+ have "(setsum (%j. (j * p) div q) Q_set) +
+ (setsum (%j. (j * q) div p) P_set) = int (card S2) + int (card S1)"
+ by (auto simp add: S1_carda S2_carda)
+ also have "... = int (card S1) + int (card S2)"
+ by auto
+ also have "... = ((p - 1) div 2) * ((q - 1) div 2)"
+ by (auto simp add: card_sum_S1_S2)
+ finally show ?thesis .
+qed
+
+
+lemma (in -) pq_prime_neq: "[| zprime p; zprime q; p \<noteq> q |] ==> (~[p = 0] (mod q))"
+ apply (auto simp add: zcong_eq_zdvd_prop zprime_def)
+ apply (drule_tac x = q in allE)
+ apply (drule_tac x = p in allE)
+ apply auto
+ done
+
+
+lemma QR_short: "(Legendre p q) * (Legendre q p) =
+ (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
+proof -
+ from prems have "~([p = 0] (mod q))"
+ by (auto simp add: pq_prime_neq QRTEMP_def)
+ with prems Q_set_def have a1: "(Legendre p q) = (-1::int) ^
+ nat(setsum (%x. ((x * p) div q)) Q_set)"
+ apply (rule_tac p = q in MainQRLemma)
+ apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
+ done
+ from prems have "~([q = 0] (mod p))"
+ apply (rule_tac p = q and q = p in pq_prime_neq)
+ apply (simp add: QRTEMP_def)+
+ done
+ with prems P_set_def have a2: "(Legendre q p) =
+ (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
+ apply (rule_tac p = p in MainQRLemma)
+ apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
+ done
+ from a1 a2 have "(Legendre p q) * (Legendre q p) =
+ (-1::int) ^ nat(setsum (%x. ((x * p) div q)) Q_set) *
+ (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
+ by auto
+ also have "... = (-1::int) ^ (nat(setsum (%x. ((x * p) div q)) Q_set) +
+ nat(setsum (%x. ((x * q) div p)) P_set))"
+ by (auto simp add: zpower_zadd_distrib)
+ also have "nat(setsum (%x. ((x * p) div q)) Q_set) +
+ nat(setsum (%x. ((x * q) div p)) P_set) =
+ nat((setsum (%x. ((x * p) div q)) Q_set) +
+ (setsum (%x. ((x * q) div p)) P_set))"
+ apply (rule_tac z = "setsum (%x. ((x * p) div q)) Q_set" in
+ nat_add_distrib [symmetric])
+ apply (auto simp add: S1_carda [symmetric] S2_carda [symmetric])
+ done
+ also have "... = nat(((p - 1) div 2) * ((q - 1) div 2))"
+ by (auto simp add: pq_sum_prop)
+ finally show ?thesis .
+qed
+
+end
+
+theorem Quadratic_Reciprocity:
+ "[| p \<in> zOdd; zprime p; q \<in> zOdd; zprime q;
+ p \<noteq> q |]
+ ==> (Legendre p q) * (Legendre q p) =
+ (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
+ by (auto simp add: QRTEMP.QR_short zprime_zOdd_eq_grt_2 [symmetric]
+ QRTEMP_def)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,4 @@
+
+no_document use_thys ["Infinite_Set", "Permutation"];
+use_thys ["Fib", "Factorization", "Chinese", "WilsonRuss",
+ "WilsonBij", "Quadratic_Reciprocity", "Primes", "Pocklington"];
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/Residues.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,172 @@
+(* Title: HOL/Quadratic_Reciprocity/Residues.thy
+ ID: $Id$
+ Authors: Jeremy Avigad, David Gray, and Adam Kramer
+*)
+
+header {* Residue Sets *}
+
+theory Residues imports Int2 begin
+
+text {*
+ \medskip Define the residue of a set, the standard residue,
+ quadratic residues, and prove some basic properties. *}
+
+definition
+ ResSet :: "int => int set => bool" where
+ "ResSet m X = (\<forall>y1 y2. (y1 \<in> X & y2 \<in> X & [y1 = y2] (mod m) --> y1 = y2))"
+
+definition
+ StandardRes :: "int => int => int" where
+ "StandardRes m x = x mod m"
+
+definition
+ QuadRes :: "int => int => bool" where
+ "QuadRes m x = (\<exists>y. ([(y ^ 2) = x] (mod m)))"
+
+definition
+ Legendre :: "int => int => int" where
+ "Legendre a p = (if ([a = 0] (mod p)) then 0
+ else if (QuadRes p a) then 1
+ else -1)"
+
+definition
+ SR :: "int => int set" where
+ "SR p = {x. (0 \<le> x) & (x < p)}"
+
+definition
+ SRStar :: "int => int set" where
+ "SRStar p = {x. (0 < x) & (x < p)}"
+
+
+subsection {* Some useful properties of StandardRes *}
+
+lemma StandardRes_prop1: "[x = StandardRes m x] (mod m)"
+ by (auto simp add: StandardRes_def zcong_zmod)
+
+lemma StandardRes_prop2: "0 < m ==> (StandardRes m x1 = StandardRes m x2)
+ = ([x1 = x2] (mod m))"
+ by (auto simp add: StandardRes_def zcong_zmod_eq)
+
+lemma StandardRes_prop3: "(~[x = 0] (mod p)) = (~(StandardRes p x = 0))"
+ by (auto simp add: StandardRes_def zcong_def dvd_eq_mod_eq_0)
+
+lemma StandardRes_prop4: "2 < m
+ ==> [StandardRes m x * StandardRes m y = (x * y)] (mod m)"
+ by (auto simp add: StandardRes_def zcong_zmod_eq
+ mod_mult_eq [of x y m])
+
+lemma StandardRes_lbound: "0 < p ==> 0 \<le> StandardRes p x"
+ by (auto simp add: StandardRes_def pos_mod_sign)
+
+lemma StandardRes_ubound: "0 < p ==> StandardRes p x < p"
+ by (auto simp add: StandardRes_def pos_mod_bound)
+
+lemma StandardRes_eq_zcong:
+ "(StandardRes m x = 0) = ([x = 0](mod m))"
+ by (auto simp add: StandardRes_def zcong_eq_zdvd_prop dvd_def)
+
+
+subsection {* Relations between StandardRes, SRStar, and SR *}
+
+lemma SRStar_SR_prop: "x \<in> SRStar p ==> x \<in> SR p"
+ by (auto simp add: SRStar_def SR_def)
+
+lemma StandardRes_SR_prop: "x \<in> SR p ==> StandardRes p x = x"
+ by (auto simp add: SR_def StandardRes_def mod_pos_pos_trivial)
+
+lemma StandardRes_SRStar_prop1: "2 < p ==> (StandardRes p x \<in> SRStar p)
+ = (~[x = 0] (mod p))"
+ apply (auto simp add: StandardRes_prop3 StandardRes_def
+ SRStar_def pos_mod_bound)
+ apply (subgoal_tac "0 < p")
+ apply (drule_tac a = x in pos_mod_sign, arith, simp)
+ done
+
+lemma StandardRes_SRStar_prop1a: "x \<in> SRStar p ==> ~([x = 0] (mod p))"
+ by (auto simp add: SRStar_def zcong_def zdvd_not_zless)
+
+lemma StandardRes_SRStar_prop2: "[| 2 < p; zprime p; x \<in> SRStar p |]
+ ==> StandardRes p (MultInv p x) \<in> SRStar p"
+ apply (frule_tac x = "(MultInv p x)" in StandardRes_SRStar_prop1, simp)
+ apply (rule MultInv_prop3)
+ apply (auto simp add: SRStar_def zcong_def zdvd_not_zless)
+ done
+
+lemma StandardRes_SRStar_prop3: "x \<in> SRStar p ==> StandardRes p x = x"
+ by (auto simp add: SRStar_SR_prop StandardRes_SR_prop)
+
+lemma StandardRes_SRStar_prop4: "[| zprime p; 2 < p; x \<in> SRStar p |]
+ ==> StandardRes p x \<in> SRStar p"
+ by (frule StandardRes_SRStar_prop3, auto)
+
+lemma SRStar_mult_prop1: "[| zprime p; 2 < p; x \<in> SRStar p; y \<in> SRStar p|]
+ ==> (StandardRes p (x * y)):SRStar p"
+ apply (frule_tac x = x in StandardRes_SRStar_prop4, auto)
+ apply (frule_tac x = y in StandardRes_SRStar_prop4, auto)
+ apply (auto simp add: StandardRes_SRStar_prop1 zcong_zmult_prop3)
+ done
+
+lemma SRStar_mult_prop2: "[| zprime p; 2 < p; ~([a = 0](mod p));
+ x \<in> SRStar p |]
+ ==> StandardRes p (a * MultInv p x) \<in> SRStar p"
+ apply (frule_tac x = x in StandardRes_SRStar_prop2, auto)
+ apply (frule_tac x = "MultInv p x" in StandardRes_SRStar_prop1)
+ apply (auto simp add: StandardRes_SRStar_prop1 zcong_zmult_prop3)
+ done
+
+lemma SRStar_card: "2 < p ==> int(card(SRStar p)) = p - 1"
+ by (auto simp add: SRStar_def int_card_bdd_int_set_l_l)
+
+lemma SRStar_finite: "2 < p ==> finite( SRStar p)"
+ by (auto simp add: SRStar_def bdd_int_set_l_l_finite)
+
+
+subsection {* Properties relating ResSets with StandardRes *}
+
+lemma aux: "x mod m = y mod m ==> [x = y] (mod m)"
+ apply (subgoal_tac "x = y ==> [x = y](mod m)")
+ apply (subgoal_tac "[x mod m = y mod m] (mod m) ==> [x = y] (mod m)")
+ apply (auto simp add: zcong_zmod [of x y m])
+ done
+
+lemma StandardRes_inj_on_ResSet: "ResSet m X ==> (inj_on (StandardRes m) X)"
+ apply (auto simp add: ResSet_def StandardRes_def inj_on_def)
+ apply (drule_tac m = m in aux, auto)
+ done
+
+lemma StandardRes_Sum: "[| finite X; 0 < m |]
+ ==> [setsum f X = setsum (StandardRes m o f) X](mod m)"
+ apply (rule_tac F = X in finite_induct)
+ apply (auto intro!: zcong_zadd simp add: StandardRes_prop1)
+ done
+
+lemma SR_pos: "0 < m ==> (StandardRes m ` X) \<subseteq> {x. 0 \<le> x & x < m}"
+ by (auto simp add: StandardRes_ubound StandardRes_lbound)
+
+lemma ResSet_finite: "0 < m ==> ResSet m X ==> finite X"
+ apply (rule_tac f = "StandardRes m" in finite_imageD)
+ apply (rule_tac B = "{x. (0 :: int) \<le> x & x < m}" in finite_subset)
+ apply (auto simp add: StandardRes_inj_on_ResSet bdd_int_set_l_finite SR_pos)
+ done
+
+lemma mod_mod_is_mod: "[x = x mod m](mod m)"
+ by (auto simp add: zcong_zmod)
+
+lemma StandardRes_prod: "[| finite X; 0 < m |]
+ ==> [setprod f X = setprod (StandardRes m o f) X] (mod m)"
+ apply (rule_tac F = X in finite_induct)
+ apply (auto intro!: zcong_zmult simp add: StandardRes_prop1)
+ done
+
+lemma ResSet_image:
+ "[| 0 < m; ResSet m A; \<forall>x \<in> A. \<forall>y \<in> A. ([f x = f y](mod m) --> x = y) |] ==>
+ ResSet m (f ` A)"
+ by (auto simp add: ResSet_def)
+
+
+subsection {* Property for SRStar *}
+
+lemma ResSet_SRStar_prop: "ResSet p (SRStar p)"
+ by (auto simp add: SRStar_def ResSet_def zcong_zless_imp_eq)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/WilsonBij.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,261 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Wilson's Theorem using a more abstract approach *}
+
+theory WilsonBij imports BijectionRel IntFact begin
+
+text {*
+ Wilson's Theorem using a more ``abstract'' approach based on
+ bijections between sets. Does not use Fermat's Little Theorem
+ (unlike Russinoff).
+*}
+
+
+subsection {* Definitions and lemmas *}
+
+definition
+ reciR :: "int => int => int => bool" where
+ "reciR p = (\<lambda>a b. zcong (a * b) 1 p \<and> 1 < a \<and> a < p - 1 \<and> 1 < b \<and> b < p - 1)"
+
+definition
+ inv :: "int => int => int" where
+ "inv p a =
+ (if zprime p \<and> 0 < a \<and> a < p then
+ (SOME x. 0 \<le> x \<and> x < p \<and> zcong (a * x) 1 p)
+ else 0)"
+
+
+text {* \medskip Inverse *}
+
+lemma inv_correct:
+ "zprime p ==> 0 < a ==> a < p
+ ==> 0 \<le> inv p a \<and> inv p a < p \<and> [a * inv p a = 1] (mod p)"
+ apply (unfold inv_def)
+ apply (simp (no_asm_simp))
+ apply (rule zcong_lineq_unique [THEN ex1_implies_ex, THEN someI_ex])
+ apply (erule_tac [2] zless_zprime_imp_zrelprime)
+ apply (unfold zprime_def)
+ apply auto
+ done
+
+lemmas inv_ge = inv_correct [THEN conjunct1, standard]
+lemmas inv_less = inv_correct [THEN conjunct2, THEN conjunct1, standard]
+lemmas inv_is_inv = inv_correct [THEN conjunct2, THEN conjunct2, standard]
+
+lemma inv_not_0:
+ "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 0"
+ -- {* same as @{text WilsonRuss} *}
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv)
+ apply (unfold zcong_def)
+ apply auto
+ apply (subgoal_tac "\<not> p dvd 1")
+ apply (rule_tac [2] zdvd_not_zless)
+ apply (subgoal_tac "p dvd 1")
+ prefer 2
+ apply (subst dvd_minus_iff [symmetric])
+ apply auto
+ done
+
+lemma inv_not_1:
+ "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 1"
+ -- {* same as @{text WilsonRuss} *}
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv)
+ prefer 4
+ apply simp
+ apply (subgoal_tac "a = 1")
+ apply (rule_tac [2] zcong_zless_imp_eq)
+ apply auto
+ done
+
+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 (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
+ apply (simp add: mult_commute)
+ apply (subst dvd_minus_iff)
+ apply (subst zdvd_reduce)
+ apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
+ apply (subst zdvd_reduce)
+ apply auto
+ done
+
+lemma inv_not_p_minus_1:
+ "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> p - 1"
+ -- {* same as @{text WilsonRuss} *}
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv)
+ apply auto
+ apply (simp add: aux)
+ apply (subgoal_tac "a = p - 1")
+ apply (rule_tac [2] zcong_zless_imp_eq)
+ apply auto
+ done
+
+text {*
+ Below is slightly different as we don't expand @{term [source] inv}
+ but use ``@{text correct}'' theorems.
+*}
+
+lemma inv_g_1: "zprime p ==> 1 < a ==> a < p - 1 ==> 1 < inv p a"
+ apply (subgoal_tac "inv p a \<noteq> 1")
+ apply (subgoal_tac "inv p a \<noteq> 0")
+ apply (subst order_less_le)
+ apply (subst zle_add1_eq_le [symmetric])
+ apply (subst order_less_le)
+ apply (rule_tac [2] inv_not_0)
+ apply (rule_tac [5] inv_not_1)
+ apply auto
+ apply (rule inv_ge)
+ apply auto
+ done
+
+lemma inv_less_p_minus_1:
+ "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a < p - 1"
+ -- {* ditto *}
+ apply (subst order_less_le)
+ apply (simp add: inv_not_p_minus_1 inv_less)
+ done
+
+
+text {* \medskip Bijection *}
+
+lemma aux1: "1 < x ==> 0 \<le> (x::int)"
+ apply auto
+ done
+
+lemma aux2: "1 < x ==> 0 < (x::int)"
+ apply auto
+ done
+
+lemma aux3: "x \<le> p - 2 ==> x < (p::int)"
+ apply auto
+ done
+
+lemma aux4: "x \<le> p - 2 ==> x < (p::int) - 1"
+ apply auto
+ done
+
+lemma inv_inj: "zprime p ==> inj_on (inv p) (d22set (p - 2))"
+ apply (unfold inj_on_def)
+ apply auto
+ apply (rule zcong_zless_imp_eq)
+ apply (tactic {* stac (thm "zcong_cancel" RS sym) 5 *})
+ apply (rule_tac [7] zcong_trans)
+ apply (tactic {* stac (thm "zcong_sym") 8 *})
+ apply (erule_tac [7] inv_is_inv)
+ apply (tactic "asm_simp_tac @{simpset} 9")
+ apply (erule_tac [9] inv_is_inv)
+ apply (rule_tac [6] zless_zprime_imp_zrelprime)
+ apply (rule_tac [8] inv_less)
+ apply (rule_tac [7] inv_g_1 [THEN aux2])
+ apply (unfold zprime_def)
+ apply (auto intro: d22set_g_1 d22set_le
+ aux1 aux2 aux3 aux4)
+ done
+
+lemma inv_d22set_d22set:
+ "zprime p ==> inv p ` d22set (p - 2) = d22set (p - 2)"
+ apply (rule endo_inj_surj)
+ apply (rule d22set_fin)
+ apply (erule_tac [2] inv_inj)
+ apply auto
+ apply (rule d22set_mem)
+ apply (erule inv_g_1)
+ apply (subgoal_tac [3] "inv p xa < p - 1")
+ apply (erule_tac [4] inv_less_p_minus_1)
+ apply (auto intro: d22set_g_1 d22set_le aux4)
+ done
+
+lemma d22set_d22set_bij:
+ "zprime p ==> (d22set (p - 2), d22set (p - 2)) \<in> bijR (reciR p)"
+ apply (unfold reciR_def)
+ apply (rule_tac s = "(d22set (p - 2), inv p ` d22set (p - 2))" in subst)
+ apply (simp add: inv_d22set_d22set)
+ apply (rule inj_func_bijR)
+ apply (rule_tac [3] d22set_fin)
+ apply (erule_tac [2] inv_inj)
+ apply auto
+ apply (erule inv_is_inv)
+ apply (erule_tac [5] inv_g_1)
+ apply (erule_tac [7] inv_less_p_minus_1)
+ apply (auto intro: d22set_g_1 d22set_le aux2 aux3 aux4)
+ done
+
+lemma reciP_bijP: "zprime p ==> bijP (reciR p) (d22set (p - 2))"
+ apply (unfold reciR_def bijP_def)
+ apply auto
+ apply (rule d22set_mem)
+ apply auto
+ done
+
+lemma reciP_uniq: "zprime p ==> uniqP (reciR p)"
+ apply (unfold reciR_def uniqP_def)
+ apply auto
+ apply (rule zcong_zless_imp_eq)
+ apply (tactic {* stac (thm "zcong_cancel2" RS sym) 5 *})
+ apply (rule_tac [7] zcong_trans)
+ apply (tactic {* stac (thm "zcong_sym") 8 *})
+ apply (rule_tac [6] zless_zprime_imp_zrelprime)
+ apply auto
+ apply (rule zcong_zless_imp_eq)
+ apply (tactic {* stac (thm "zcong_cancel" RS sym) 5 *})
+ apply (rule_tac [7] zcong_trans)
+ apply (tactic {* stac (thm "zcong_sym") 8 *})
+ apply (rule_tac [6] zless_zprime_imp_zrelprime)
+ apply auto
+ done
+
+lemma reciP_sym: "zprime p ==> symP (reciR p)"
+ apply (unfold reciR_def symP_def)
+ apply (simp add: zmult_commute)
+ apply auto
+ done
+
+lemma bijER_d22set: "zprime p ==> d22set (p - 2) \<in> bijER (reciR p)"
+ apply (rule bijR_bijER)
+ apply (erule d22set_d22set_bij)
+ apply (erule reciP_bijP)
+ apply (erule reciP_uniq)
+ apply (erule reciP_sym)
+ done
+
+
+subsection {* Wilson *}
+
+lemma bijER_zcong_prod_1:
+ "zprime p ==> A \<in> bijER (reciR p) ==> [\<Prod>A = 1] (mod p)"
+ apply (unfold reciR_def)
+ apply (erule bijER.induct)
+ apply (subgoal_tac [2] "a = 1 \<or> a = p - 1")
+ apply (rule_tac [3] zcong_square_zless)
+ apply auto
+ apply (subst setprod_insert)
+ prefer 3
+ apply (subst setprod_insert)
+ apply (auto simp add: fin_bijER)
+ apply (subgoal_tac "zcong ((a * b) * \<Prod>A) (1 * 1) p")
+ apply (simp add: zmult_assoc)
+ apply (rule zcong_zmult)
+ apply auto
+ done
+
+theorem Wilson_Bij: "zprime p ==> [zfact (p - 1) = -1] (mod p)"
+ apply (subgoal_tac "zcong ((p - 1) * zfact (p - 2)) (-1 * 1) p")
+ apply (rule_tac [2] zcong_zmult)
+ apply (simp add: zprime_def)
+ apply (subst zfact.simps)
+ apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst)
+ apply auto
+ apply (simp add: zcong_def)
+ apply (subst d22set_prod_zfact [symmetric])
+ apply (rule bijER_zcong_prod_1)
+ apply (rule_tac [2] bijER_d22set)
+ apply auto
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/WilsonRuss.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,327 @@
+(* Author: Thomas M. Rasmussen
+ Copyright 2000 University of Cambridge
+*)
+
+header {* Wilson's Theorem according to Russinoff *}
+
+theory WilsonRuss imports EulerFermat begin
+
+text {*
+ Wilson's Theorem following quite closely Russinoff's approach
+ using Boyer-Moore (using finite sets instead of lists, though).
+*}
+
+subsection {* Definitions and lemmas *}
+
+definition
+ inv :: "int => int => int" where
+ "inv p a = (a^(nat (p - 2))) mod p"
+
+consts
+ wset :: "int * int => int set"
+
+recdef wset
+ "measure ((\<lambda>(a, p). nat a) :: int * int => nat)"
+ "wset (a, p) =
+ (if 1 < a then
+ let ws = wset (a - 1, p)
+ in (if a \<in> ws then ws else insert a (insert (inv p a) ws)) else {})"
+
+
+text {* \medskip @{term [source] inv} *}
+
+lemma inv_is_inv_aux: "1 < m ==> Suc (nat (m - 2)) = nat (m - 1)"
+by (subst int_int_eq [symmetric], auto)
+
+lemma inv_is_inv:
+ "zprime p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> [a * inv p a = 1] (mod p)"
+ apply (unfold inv_def)
+ apply (subst zcong_zmod)
+ apply (subst zmod_zmult1_eq [symmetric])
+ apply (subst zcong_zmod [symmetric])
+ apply (subst power_Suc [symmetric])
+ apply (subst inv_is_inv_aux)
+ apply (erule_tac [2] Little_Fermat)
+ apply (erule_tac [2] zdvd_not_zless)
+ apply (unfold zprime_def, auto)
+ done
+
+lemma inv_distinct:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> a \<noteq> inv p a"
+ apply safe
+ apply (cut_tac a = a and p = p in zcong_square)
+ apply (cut_tac [3] a = a and p = p in inv_is_inv, auto)
+ apply (subgoal_tac "a = 1")
+ apply (rule_tac [2] m = p in zcong_zless_imp_eq)
+ apply (subgoal_tac [7] "a = p - 1")
+ apply (rule_tac [8] m = p in zcong_zless_imp_eq, auto)
+ done
+
+lemma inv_not_0:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 0"
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv)
+ apply (unfold zcong_def, auto)
+ apply (subgoal_tac "\<not> p dvd 1")
+ apply (rule_tac [2] zdvd_not_zless)
+ apply (subgoal_tac "p dvd 1")
+ prefer 2
+ apply (subst dvd_minus_iff [symmetric], auto)
+ done
+
+lemma inv_not_1:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 1"
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv)
+ prefer 4
+ apply simp
+ apply (subgoal_tac "a = 1")
+ apply (rule_tac [2] zcong_zless_imp_eq, auto)
+ done
+
+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 (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
+ apply (simp add: mult_commute)
+ apply (subst dvd_minus_iff)
+ apply (subst zdvd_reduce)
+ apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
+ apply (subst zdvd_reduce, auto)
+ done
+
+lemma inv_not_p_minus_1:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> p - 1"
+ apply safe
+ apply (cut_tac a = a and p = p in inv_is_inv, auto)
+ apply (simp add: inv_not_p_minus_1_aux)
+ apply (subgoal_tac "a = p - 1")
+ apply (rule_tac [2] zcong_zless_imp_eq, auto)
+ done
+
+lemma inv_g_1:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> 1 < inv p a"
+ apply (case_tac "0\<le> inv p a")
+ apply (subgoal_tac "inv p a \<noteq> 1")
+ apply (subgoal_tac "inv p a \<noteq> 0")
+ apply (subst order_less_le)
+ apply (subst zle_add1_eq_le [symmetric])
+ apply (subst order_less_le)
+ apply (rule_tac [2] inv_not_0)
+ apply (rule_tac [5] inv_not_1, auto)
+ apply (unfold inv_def zprime_def, simp)
+ done
+
+lemma inv_less_p_minus_1:
+ "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a < p - 1"
+ apply (case_tac "inv p a < p")
+ apply (subst order_less_le)
+ apply (simp add: inv_not_p_minus_1, auto)
+ apply (unfold inv_def zprime_def, simp)
+ done
+
+lemma inv_inv_aux: "5 \<le> p ==>
+ nat (p - 2) * nat (p - 2) = Suc (nat (p - 1) * nat (p - 3))"
+ apply (subst int_int_eq [symmetric])
+ apply (simp add: zmult_int [symmetric])
+ apply (simp add: zdiff_zmult_distrib zdiff_zmult_distrib2)
+ done
+
+lemma zcong_zpower_zmult:
+ "[x^y = 1] (mod p) \<Longrightarrow> [x^(y * z) = 1] (mod p)"
+ apply (induct z)
+ apply (auto simp add: zpower_zadd_distrib)
+ apply (subgoal_tac "zcong (x^y * x^(y * z)) (1 * 1) p")
+ apply (rule_tac [2] zcong_zmult, simp_all)
+ done
+
+lemma inv_inv: "zprime p \<Longrightarrow>
+ 5 \<le> p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> inv p (inv p a) = a"
+ apply (unfold inv_def)
+ apply (subst zpower_zmod)
+ apply (subst zpower_zpower)
+ apply (rule zcong_zless_imp_eq)
+ prefer 5
+ apply (subst zcong_zmod)
+ apply (subst mod_mod_trivial)
+ apply (subst zcong_zmod [symmetric])
+ apply (subst inv_inv_aux)
+ apply (subgoal_tac [2]
+ "zcong (a * a^(nat (p - 1) * nat (p - 3))) (a * 1) p")
+ apply (rule_tac [3] zcong_zmult)
+ apply (rule_tac [4] zcong_zpower_zmult)
+ apply (erule_tac [4] Little_Fermat)
+ apply (rule_tac [4] zdvd_not_zless, simp_all)
+ done
+
+
+text {* \medskip @{term wset} *}
+
+declare wset.simps [simp del]
+
+lemma wset_induct:
+ assumes "!!a p. P {} a p"
+ and "!!a p. 1 < (a::int) \<Longrightarrow>
+ P (wset (a - 1, p)) (a - 1) p ==> P (wset (a, p)) a p"
+ shows "P (wset (u, v)) u v"
+ apply (rule wset.induct, safe)
+ prefer 2
+ apply (case_tac "1 < a")
+ apply (rule prems)
+ apply simp_all
+ apply (simp_all add: wset.simps prems)
+ done
+
+lemma wset_mem_imp_or [rule_format]:
+ "1 < a \<Longrightarrow> b \<notin> wset (a - 1, p)
+ ==> b \<in> wset (a, p) --> b = a \<or> b = inv p a"
+ apply (subst wset.simps)
+ apply (unfold Let_def, simp)
+ done
+
+lemma wset_mem_mem [simp]: "1 < a ==> a \<in> wset (a, p)"
+ apply (subst wset.simps)
+ apply (unfold Let_def, simp)
+ done
+
+lemma wset_subset: "1 < a \<Longrightarrow> b \<in> wset (a - 1, p) ==> b \<in> wset (a, p)"
+ apply (subst wset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma wset_g_1 [rule_format]:
+ "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> 1 < b"
+ apply (induct a p rule: wset_induct, auto)
+ apply (case_tac "b = a")
+ apply (case_tac [2] "b = inv p a")
+ apply (subgoal_tac [3] "b = a \<or> b = inv p a")
+ apply (rule_tac [4] wset_mem_imp_or)
+ prefer 2
+ apply simp
+ apply (rule inv_g_1, auto)
+ done
+
+lemma wset_less [rule_format]:
+ "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> b < p - 1"
+ apply (induct a p rule: wset_induct, auto)
+ apply (case_tac "b = a")
+ apply (case_tac [2] "b = inv p a")
+ apply (subgoal_tac [3] "b = a \<or> b = inv p a")
+ apply (rule_tac [4] wset_mem_imp_or)
+ prefer 2
+ apply simp
+ apply (rule inv_less_p_minus_1, auto)
+ done
+
+lemma wset_mem [rule_format]:
+ "zprime p -->
+ a < p - 1 --> 1 < b --> b \<le> a --> b \<in> wset (a, p)"
+ apply (induct a p rule: wset.induct, auto)
+ apply (rule_tac wset_subset)
+ apply (simp (no_asm_simp))
+ apply auto
+ done
+
+lemma wset_mem_inv_mem [rule_format]:
+ "zprime p --> 5 \<le> p --> a < p - 1 --> b \<in> wset (a, p)
+ --> inv p b \<in> wset (a, p)"
+ apply (induct a p rule: wset_induct, auto)
+ apply (case_tac "b = a")
+ apply (subst wset.simps)
+ apply (unfold Let_def)
+ apply (rule_tac [3] wset_subset, auto)
+ apply (case_tac "b = inv p a")
+ apply (simp (no_asm_simp))
+ apply (subst inv_inv)
+ apply (subgoal_tac [6] "b = a \<or> b = inv p a")
+ apply (rule_tac [7] wset_mem_imp_or, auto)
+ done
+
+lemma wset_inv_mem_mem:
+ "zprime p \<Longrightarrow> 5 \<le> p \<Longrightarrow> a < p - 1 \<Longrightarrow> 1 < b \<Longrightarrow> b < p - 1
+ \<Longrightarrow> inv p b \<in> wset (a, p) \<Longrightarrow> b \<in> wset (a, p)"
+ apply (rule_tac s = "inv p (inv p b)" and t = b in subst)
+ apply (rule_tac [2] wset_mem_inv_mem)
+ apply (rule inv_inv, simp_all)
+ done
+
+lemma wset_fin: "finite (wset (a, p))"
+ apply (induct a p rule: wset_induct)
+ prefer 2
+ apply (subst wset.simps)
+ apply (unfold Let_def, auto)
+ done
+
+lemma wset_zcong_prod_1 [rule_format]:
+ "zprime p -->
+ 5 \<le> p --> a < p - 1 --> [(\<Prod>x\<in>wset(a, p). x) = 1] (mod p)"
+ apply (induct a p rule: wset_induct)
+ prefer 2
+ apply (subst wset.simps)
+ apply (unfold Let_def, auto)
+ apply (subst setprod_insert)
+ apply (tactic {* stac (thm "setprod_insert") 3 *})
+ apply (subgoal_tac [5]
+ "zcong (a * inv p a * (\<Prod>x\<in> wset(a - 1, p). x)) (1 * 1) p")
+ prefer 5
+ apply (simp add: zmult_assoc)
+ apply (rule_tac [5] zcong_zmult)
+ apply (rule_tac [5] inv_is_inv)
+ apply (tactic "clarify_tac @{claset} 4")
+ apply (subgoal_tac [4] "a \<in> wset (a - 1, p)")
+ apply (rule_tac [5] wset_inv_mem_mem)
+ apply (simp_all add: wset_fin)
+ apply (rule inv_distinct, auto)
+ done
+
+lemma d22set_eq_wset: "zprime p ==> d22set (p - 2) = wset (p - 2, p)"
+ apply safe
+ apply (erule wset_mem)
+ apply (rule_tac [2] d22set_g_1)
+ apply (rule_tac [3] d22set_le)
+ apply (rule_tac [4] d22set_mem)
+ apply (erule_tac [4] wset_g_1)
+ prefer 6
+ apply (subst zle_add1_eq_le [symmetric])
+ apply (subgoal_tac "p - 2 + 1 = p - 1")
+ apply (simp (no_asm_simp))
+ apply (erule wset_less, auto)
+ done
+
+
+subsection {* Wilson *}
+
+lemma prime_g_5: "zprime p \<Longrightarrow> p \<noteq> 2 \<Longrightarrow> p \<noteq> 3 ==> 5 \<le> p"
+ apply (unfold zprime_def dvd_def)
+ apply (case_tac "p = 4", auto)
+ apply (rule notE)
+ prefer 2
+ apply assumption
+ apply (simp (no_asm))
+ apply (rule_tac x = 2 in exI)
+ apply (safe, arith)
+ apply (rule_tac x = 2 in exI, auto)
+ done
+
+theorem Wilson_Russ:
+ "zprime p ==> [zfact (p - 1) = -1] (mod p)"
+ apply (subgoal_tac "[(p - 1) * zfact (p - 2) = -1 * 1] (mod p)")
+ apply (rule_tac [2] zcong_zmult)
+ apply (simp only: zprime_def)
+ apply (subst zfact.simps)
+ apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst, auto)
+ apply (simp only: zcong_def)
+ apply (simp (no_asm_simp))
+ apply (case_tac "p = 2")
+ apply (simp add: zfact.simps)
+ apply (case_tac "p = 3")
+ apply (simp add: zfact.simps)
+ apply (subgoal_tac "5 \<le> p")
+ apply (erule_tac [2] prime_g_5)
+ apply (subst d22set_prod_zfact [symmetric])
+ apply (subst d22set_eq_wset)
+ apply (rule_tac [2] wset_zcong_prod_1, auto)
+ done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Old_Number_Theory/document/root.tex Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,57 @@
+
+\documentclass[11pt,a4paper]{article}
+\usepackage{graphicx}
+\usepackage{isabelle,isabellesym,pdfsetup}
+\usepackage[latin1]{inputenc}
+
+\urlstyle{rm}
+\isabellestyle{it}
+
+\begin{document}
+
+\title{Some results of number theory}
+\author{Jeremy Avigad\\
+ David Gray\\
+ Adam Kramer\\
+ Thomas M Rasmussen}
+
+\maketitle
+
+\begin{abstract}
+This is a collection of formalized proofs of many results of number theory.
+The proofs of the Chinese Remainder Theorem and Wilson's Theorem are due to
+Rasmussen. The proof of Gauss's law of quadratic reciprocity is due to
+Avigad, Gray and Kramer. Proofs can be found in most introductory number
+theory textbooks; Goldman's \emph{The Queen of Mathematics: a Historically
+Motivated Guide to Number Theory} provides some historical context.
+
+Avigad, Gray and Kramer have also provided library theories dealing with
+finite sets and finite sums, divisibility and congruences, parity and
+residues. The authors are engaged in redesigning and polishing these theories
+for more serious use. For the latest information in this respect, please see
+the web page \url{http://www.andrew.cmu.edu/~avigad/isabelle}. Other theories
+contain proofs of Euler's criteria, Gauss' lemma, and the law of quadratic
+reciprocity. The formalization follows Eisenstein's proof, which is the one
+most commonly found in introductory textbooks; in particular, it follows the
+presentation in Niven and Zuckerman, \emph{The Theory of Numbers}.
+
+To avoid having to count roots of polynomials, however, we relied on a trick
+previously used by David Russinoff in formalizing quadratic reciprocity for
+the Boyer-Moore theorem prover; see Russinoff, David, ``A mechanical proof
+of quadratic reciprocity,'' \emph{Journal of Automated Reasoning} 8:3-21,
+1992. We are grateful to Larry Paulson for calling our attention to this
+reference.
+\end{abstract}
+
+\tableofcontents
+
+\begin{center}
+ \includegraphics[scale=0.5]{session_graph}
+\end{center}
+
+\newpage
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\end{document}
--- a/src/HOL/OrderedGroup.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/OrderedGroup.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1075,16 +1075,16 @@
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 le_iff_sup sup_aci)
+ 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 le_iff_inf inf_aci)
+ 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 le_iff_sup sup_aci)
+ 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 le_iff_inf inf_aci)
+ by (simp add: nprt_def inf_aci inf_absorb2)
lemma sup_0_imp_0: "sup a (- a) = 0 \<Longrightarrow> a = 0"
proof -
@@ -1118,13 +1118,13 @@
"0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
proof
assume "0 <= a + a"
- hence a:"inf (a+a) 0 = 0" by (simp add: le_iff_inf inf_commute)
+ 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" by (simp add: le_iff_inf inf_commute)
-next
+ 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
@@ -1134,7 +1134,7 @@
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 (*FIXME tune proof*)
+ 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
@@ -1194,22 +1194,22 @@
qed
lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
-by (simp add: le_iff_inf nprt_def inf_commute)
+unfolding le_iff_inf by (simp add: nprt_def inf_commute)
lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
-by (simp add: le_iff_sup pprt_def sup_commute)
+unfolding le_iff_sup by (simp add: pprt_def sup_commute)
lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
-by (simp add: le_iff_sup pprt_def sup_commute)
+unfolding le_iff_sup by (simp add: pprt_def sup_commute)
lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
-by (simp add: le_iff_inf nprt_def inf_commute)
+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"
-by (simp add: le_iff_sup pprt_def sup_aci sup_assoc [symmetric, of a])
+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"
-by (simp add: le_iff_inf nprt_def inf_aci inf_assoc [symmetric, of a])
+unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])
end
@@ -1274,7 +1274,7 @@
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 max_def)
+ then show ?thesis by (auto simp: sup_max min_max.sup_absorb1 min_max.sup_absorb2)
qed
lemma abs_if_lattice:
--- a/src/HOL/Predicate.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Predicate.thy Thu Oct 01 07:40:25 2009 +0200
@@ -19,22 +19,7 @@
subsection {* Predicates as (complete) lattices *}
-subsubsection {* @{const sup} on @{typ bool} *}
-
-lemma sup_boolI1:
- "P \<Longrightarrow> P \<squnion> Q"
- by (simp add: sup_bool_eq)
-
-lemma sup_boolI2:
- "Q \<Longrightarrow> P \<squnion> Q"
- by (simp add: sup_bool_eq)
-
-lemma sup_boolE:
- "P \<squnion> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
- by (auto simp add: sup_bool_eq)
-
-
-subsubsection {* Equality and Subsets *}
+subsubsection {* Equality *}
lemma pred_equals_eq: "((\<lambda>x. x \<in> R) = (\<lambda>x. x \<in> S)) = (R = S)"
by (simp add: mem_def)
@@ -42,6 +27,9 @@
lemma pred_equals_eq2 [pred_set_conv]: "((\<lambda>x y. (x, y) \<in> R) = (\<lambda>x y. (x, y) \<in> S)) = (R = S)"
by (simp add: expand_fun_eq mem_def)
+
+subsubsection {* Order relation *}
+
lemma pred_subset_eq: "((\<lambda>x. x \<in> R) <= (\<lambda>x. x \<in> S)) = (R <= S)"
by (simp add: mem_def)
@@ -63,9 +51,6 @@
lemma bot2E [elim!]: "bot x y \<Longrightarrow> P"
by (simp add: bot_fun_eq bot_bool_eq)
-
-subsubsection {* The empty set *}
-
lemma bot_empty_eq: "bot = (\<lambda>x. x \<in> {})"
by (auto simp add: expand_fun_eq)
@@ -75,29 +60,29 @@
subsubsection {* Binary union *}
-lemma sup1_iff [simp]: "sup A B x \<longleftrightarrow> A x | B x"
+lemma sup1_iff: "sup A B x \<longleftrightarrow> A x | B x"
by (simp add: sup_fun_eq sup_bool_eq)
-lemma sup2_iff [simp]: "sup A B x y \<longleftrightarrow> A x y | B x y"
+lemma sup2_iff: "sup A B x y \<longleftrightarrow> A x y | B x y"
by (simp add: sup_fun_eq sup_bool_eq)
-lemma sup_Un_eq [pred_set_conv]: "sup (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<union> S)"
- by (simp add: expand_fun_eq)
+lemma sup_Un_eq: "sup (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<union> S)"
+ by (simp add: sup1_iff expand_fun_eq)
lemma sup_Un_eq2 [pred_set_conv]: "sup (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<union> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: sup2_iff expand_fun_eq)
lemma sup1I1 [elim?]: "A x \<Longrightarrow> sup A B x"
- by simp
+ by (simp add: sup1_iff)
lemma sup2I1 [elim?]: "A x y \<Longrightarrow> sup A B x y"
- by simp
+ by (simp add: sup2_iff)
lemma sup1I2 [elim?]: "B x \<Longrightarrow> sup A B x"
- by simp
+ by (simp add: sup1_iff)
lemma sup2I2 [elim?]: "B x y \<Longrightarrow> sup A B x y"
- by simp
+ by (simp add: sup2_iff)
text {*
\medskip Classical introduction rule: no commitment to @{text A} vs
@@ -105,115 +90,115 @@
*}
lemma sup1CI [intro!]: "(~ B x ==> A x) ==> sup A B x"
- by auto
+ by (auto simp add: sup1_iff)
lemma sup2CI [intro!]: "(~ B x y ==> A x y) ==> sup A B x y"
- by auto
+ by (auto simp add: sup2_iff)
lemma sup1E [elim!]: "sup A B x ==> (A x ==> P) ==> (B x ==> P) ==> P"
- by simp iprover
+ by (simp add: sup1_iff) iprover
lemma sup2E [elim!]: "sup A B x y ==> (A x y ==> P) ==> (B x y ==> P) ==> P"
- by simp iprover
+ by (simp add: sup2_iff) iprover
subsubsection {* Binary intersection *}
-lemma inf1_iff [simp]: "inf A B x \<longleftrightarrow> A x \<and> B x"
+lemma inf1_iff: "inf A B x \<longleftrightarrow> A x \<and> B x"
by (simp add: inf_fun_eq inf_bool_eq)
-lemma inf2_iff [simp]: "inf A B x y \<longleftrightarrow> A x y \<and> B x y"
+lemma inf2_iff: "inf A B x y \<longleftrightarrow> A x y \<and> B x y"
by (simp add: inf_fun_eq inf_bool_eq)
-lemma inf_Int_eq [pred_set_conv]: "inf (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<inter> S)"
- by (simp add: expand_fun_eq)
+lemma inf_Int_eq: "inf (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<inter> S)"
+ by (simp add: inf1_iff expand_fun_eq)
lemma inf_Int_eq2 [pred_set_conv]: "inf (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<inter> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: inf2_iff expand_fun_eq)
lemma inf1I [intro!]: "A x ==> B x ==> inf A B x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2I [intro!]: "A x y ==> B x y ==> inf A B x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1D1: "inf A B x ==> A x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2D1: "inf A B x y ==> A x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1D2: "inf A B x ==> B x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2D2: "inf A B x y ==> B x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1E [elim!]: "inf A B x ==> (A x ==> B x ==> P) ==> P"
- by simp
+ by (simp add: inf1_iff)
lemma inf2E [elim!]: "inf A B x y ==> (A x y ==> B x y ==> P) ==> P"
- by simp
+ by (simp add: inf2_iff)
subsubsection {* Unions of families *}
-lemma SUP1_iff [simp]: "(SUP x:A. B x) b = (EX x:A. B x b)"
+lemma SUP1_iff: "(SUP x:A. B x) b = (EX x:A. B x b)"
by (simp add: SUPR_def Sup_fun_def Sup_bool_def) blast
-lemma SUP2_iff [simp]: "(SUP x:A. B x) b c = (EX x:A. B x b c)"
+lemma SUP2_iff: "(SUP x:A. B x) b c = (EX x:A. B x b c)"
by (simp add: SUPR_def Sup_fun_def Sup_bool_def) blast
lemma SUP1_I [intro]: "a : A ==> B a b ==> (SUP x:A. B x) b"
- by auto
+ by (auto simp add: SUP1_iff)
lemma SUP2_I [intro]: "a : A ==> B a b c ==> (SUP x:A. B x) b c"
- by auto
+ by (auto simp add: SUP2_iff)
lemma SUP1_E [elim!]: "(SUP x:A. B x) b ==> (!!x. x : A ==> B x b ==> R) ==> R"
- by auto
+ by (auto simp add: SUP1_iff)
lemma SUP2_E [elim!]: "(SUP x:A. B x) b c ==> (!!x. x : A ==> B x b c ==> R) ==> R"
- by auto
+ by (auto simp add: SUP2_iff)
lemma SUP_UN_eq: "(SUP i. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (UN i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: SUP1_iff expand_fun_eq)
lemma SUP_UN_eq2: "(SUP i. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (UN i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: SUP2_iff expand_fun_eq)
subsubsection {* Intersections of families *}
-lemma INF1_iff [simp]: "(INF x:A. B x) b = (ALL x:A. B x b)"
+lemma INF1_iff: "(INF x:A. B x) b = (ALL x:A. B x b)"
by (simp add: INFI_def Inf_fun_def Inf_bool_def) blast
-lemma INF2_iff [simp]: "(INF x:A. B x) b c = (ALL x:A. B x b c)"
+lemma INF2_iff: "(INF x:A. B x) b c = (ALL x:A. B x b c)"
by (simp add: INFI_def Inf_fun_def Inf_bool_def) blast
lemma INF1_I [intro!]: "(!!x. x : A ==> B x b) ==> (INF x:A. B x) b"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_I [intro!]: "(!!x. x : A ==> B x b c) ==> (INF x:A. B x) b c"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF1_D [elim]: "(INF x:A. B x) b ==> a : A ==> B a b"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_D [elim]: "(INF x:A. B x) b c ==> a : A ==> B a b c"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF1_E [elim]: "(INF x:A. B x) b ==> (B a b ==> R) ==> (a ~: A ==> R) ==> R"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_E [elim]: "(INF x:A. B x) b c ==> (B a b c ==> R) ==> (a ~: A ==> R) ==> R"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF_INT_eq: "(INF i. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (INT i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: INF1_iff expand_fun_eq)
lemma INF_INT_eq2: "(INF i. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (INT i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: INF2_iff expand_fun_eq)
subsection {* Predicates as relations *}
@@ -366,7 +351,7 @@
definition bind :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b pred) \<Rightarrow> 'b pred" (infixl "\<guillemotright>=" 70) where
"P \<guillemotright>= f = Pred (\<lambda>x. (\<exists>y. eval P y \<and> eval (f y) x))"
-instantiation pred :: (type) complete_lattice
+instantiation pred :: (type) "{complete_lattice, boolean_algebra}"
begin
definition
@@ -393,10 +378,16 @@
definition
[code del]: "\<Squnion>A = Pred (SUPR A eval)"
-instance by default
- (auto simp add: less_eq_pred_def less_pred_def
+definition
+ "- P = Pred (- eval P)"
+
+definition
+ "P - Q = Pred (eval P - eval Q)"
+
+instance proof
+qed (auto simp add: less_eq_pred_def less_pred_def
inf_pred_def sup_pred_def bot_pred_def top_pred_def
- Inf_pred_def Sup_pred_def,
+ Inf_pred_def Sup_pred_def uminus_pred_def minus_pred_def fun_Compl_def bool_Compl_def,
auto simp add: le_fun_def less_fun_def le_bool_def less_bool_def
eval_inject mem_def)
@@ -423,7 +414,7 @@
by (auto simp add: bind_def sup_pred_def expand_fun_eq)
lemma Sup_bind: "(\<Squnion>A \<guillemotright>= f) = \<Squnion>((\<lambda>x. x \<guillemotright>= f) ` A)"
- by (auto simp add: bind_def Sup_pred_def expand_fun_eq)
+ by (auto simp add: bind_def Sup_pred_def SUP1_iff expand_fun_eq)
lemma pred_iffI:
assumes "\<And>x. eval A x \<Longrightarrow> eval B x"
@@ -456,14 +447,135 @@
unfolding bot_pred_def by auto
lemma supI1: "eval A x \<Longrightarrow> eval (A \<squnion> B) x"
- unfolding sup_pred_def by simp
+ unfolding sup_pred_def by (simp add: sup1_iff)
lemma supI2: "eval B x \<Longrightarrow> eval (A \<squnion> B) x"
- unfolding sup_pred_def by simp
+ unfolding sup_pred_def by (simp add: sup1_iff)
lemma supE: "eval (A \<squnion> B) x \<Longrightarrow> (eval A x \<Longrightarrow> P) \<Longrightarrow> (eval B x \<Longrightarrow> P) \<Longrightarrow> P"
unfolding sup_pred_def by auto
+lemma single_not_bot [simp]:
+ "single x \<noteq> \<bottom>"
+ by (auto simp add: single_def bot_pred_def expand_fun_eq)
+
+lemma not_bot:
+ assumes "A \<noteq> \<bottom>"
+ obtains x where "eval A x"
+using assms by (cases A)
+ (auto simp add: bot_pred_def, auto simp add: mem_def)
+
+
+subsubsection {* Emptiness check and definite choice *}
+
+definition is_empty :: "'a pred \<Rightarrow> bool" where
+ "is_empty A \<longleftrightarrow> A = \<bottom>"
+
+lemma is_empty_bot:
+ "is_empty \<bottom>"
+ by (simp add: is_empty_def)
+
+lemma not_is_empty_single:
+ "\<not> is_empty (single x)"
+ by (auto simp add: is_empty_def single_def bot_pred_def expand_fun_eq)
+
+lemma is_empty_sup:
+ "is_empty (A \<squnion> B) \<longleftrightarrow> is_empty A \<and> is_empty B"
+ by (auto simp add: is_empty_def intro: sup_eq_bot_eq1 sup_eq_bot_eq2)
+
+definition singleton :: "'a pred \<Rightarrow> 'a" where
+ "singleton A = (if \<exists>!x. eval A x then THE x. eval A x else undefined)"
+
+lemma singleton_eqI:
+ "\<exists>!x. eval A x \<Longrightarrow> eval A x \<Longrightarrow> singleton A = x"
+ by (auto simp add: singleton_def)
+
+lemma eval_singletonI:
+ "\<exists>!x. eval A x \<Longrightarrow> eval A (singleton A)"
+proof -
+ assume assm: "\<exists>!x. eval A x"
+ then obtain x where "eval A x" ..
+ moreover with assm have "singleton A = x" by (rule singleton_eqI)
+ ultimately show ?thesis by simp
+qed
+
+lemma single_singleton:
+ "\<exists>!x. eval A x \<Longrightarrow> single (singleton A) = A"
+proof -
+ assume assm: "\<exists>!x. eval A x"
+ then have "eval A (singleton A)"
+ by (rule eval_singletonI)
+ moreover from assm have "\<And>x. eval A x \<Longrightarrow> singleton A = x"
+ by (rule singleton_eqI)
+ ultimately have "eval (single (singleton A)) = eval A"
+ by (simp (no_asm_use) add: single_def expand_fun_eq) blast
+ then show ?thesis by (simp add: eval_inject)
+qed
+
+lemma singleton_undefinedI:
+ "\<not> (\<exists>!x. eval A x) \<Longrightarrow> singleton A = undefined"
+ by (simp add: singleton_def)
+
+lemma singleton_bot:
+ "singleton \<bottom> = undefined"
+ by (auto simp add: bot_pred_def intro: singleton_undefinedI)
+
+lemma singleton_single:
+ "singleton (single x) = x"
+ by (auto simp add: intro: singleton_eqI singleI elim: singleE)
+
+lemma singleton_sup_single_single:
+ "singleton (single x \<squnion> single y) = (if x = y then x else undefined)"
+proof (cases "x = y")
+ case True then show ?thesis by (simp add: singleton_single)
+next
+ case False
+ have "eval (single x \<squnion> single y) x"
+ and "eval (single x \<squnion> single y) y"
+ by (auto intro: supI1 supI2 singleI)
+ with False have "\<not> (\<exists>!z. eval (single x \<squnion> single y) z)"
+ by blast
+ then have "singleton (single x \<squnion> single y) = undefined"
+ by (rule singleton_undefinedI)
+ with False show ?thesis by simp
+qed
+
+lemma singleton_sup_aux:
+ "singleton (A \<squnion> B) = (if A = \<bottom> then singleton B
+ else if B = \<bottom> then singleton A
+ else singleton
+ (single (singleton A) \<squnion> single (singleton B)))"
+proof (cases "(\<exists>!x. eval A x) \<and> (\<exists>!y. eval B y)")
+ case True then show ?thesis by (simp add: single_singleton)
+next
+ case False
+ from False have A_or_B:
+ "singleton A = undefined \<or> singleton B = undefined"
+ by (auto intro!: singleton_undefinedI)
+ then have rhs: "singleton
+ (single (singleton A) \<squnion> single (singleton B)) = undefined"
+ by (auto simp add: singleton_sup_single_single singleton_single)
+ from False have not_unique:
+ "\<not> (\<exists>!x. eval A x) \<or> \<not> (\<exists>!y. eval B y)" by simp
+ show ?thesis proof (cases "A \<noteq> \<bottom> \<and> B \<noteq> \<bottom>")
+ case True
+ then obtain a b where a: "eval A a" and b: "eval B b"
+ by (blast elim: not_bot)
+ with True not_unique have "\<not> (\<exists>!x. eval (A \<squnion> B) x)"
+ by (auto simp add: sup_pred_def bot_pred_def)
+ then have "singleton (A \<squnion> B) = undefined" by (rule singleton_undefinedI)
+ with True rhs show ?thesis by simp
+ next
+ case False then show ?thesis by auto
+ qed
+qed
+
+lemma singleton_sup:
+ "singleton (A \<squnion> B) = (if A = \<bottom> then singleton B
+ else if B = \<bottom> then singleton A
+ else if singleton A = singleton B then singleton A else undefined)"
+using singleton_sup_aux [of A B] by (simp only: singleton_sup_single_single)
+
subsubsection {* Derived operations *}
@@ -630,6 +742,50 @@
definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a pred \<Rightarrow> 'b pred" where
"map f P = P \<guillemotright>= (single o f)"
+primrec null :: "'a seq \<Rightarrow> bool" where
+ "null Empty \<longleftrightarrow> True"
+ | "null (Insert x P) \<longleftrightarrow> False"
+ | "null (Join P xq) \<longleftrightarrow> is_empty P \<and> null xq"
+
+lemma null_is_empty:
+ "null xq \<longleftrightarrow> is_empty (pred_of_seq xq)"
+ by (induct xq) (simp_all add: is_empty_bot not_is_empty_single is_empty_sup)
+
+lemma is_empty_code [code]:
+ "is_empty (Seq f) \<longleftrightarrow> null (f ())"
+ by (simp add: null_is_empty Seq_def)
+
+primrec the_only :: "'a seq \<Rightarrow> 'a" where
+ [code del]: "the_only Empty = undefined"
+ | "the_only (Insert x P) = (if is_empty P then x else let y = singleton P in if x = y then x else undefined)"
+ | "the_only (Join P xq) = (if is_empty P then the_only xq else if null xq then singleton P
+ else let x = singleton P; y = the_only xq in
+ if x = y then x else undefined)"
+
+lemma the_only_singleton:
+ "the_only xq = singleton (pred_of_seq xq)"
+ by (induct xq)
+ (auto simp add: singleton_bot singleton_single is_empty_def
+ null_is_empty Let_def singleton_sup)
+
+lemma singleton_code [code]:
+ "singleton (Seq f) = (case f ()
+ of Empty \<Rightarrow> undefined
+ | Insert x P \<Rightarrow> if is_empty P then x
+ else let y = singleton P in
+ if x = y then x else undefined
+ | Join P xq \<Rightarrow> if is_empty P then the_only xq
+ else if null xq then singleton P
+ else let x = singleton P; y = the_only xq in
+ if x = y then x else undefined)"
+ by (cases "f ()")
+ (auto simp add: Seq_def the_only_singleton is_empty_def
+ null_is_empty singleton_bot singleton_single singleton_sup Let_def)
+
+lemma meta_fun_cong:
+"f == g ==> f x == g x"
+by simp
+
ML {*
signature PREDICATE =
sig
@@ -707,7 +863,7 @@
bind (infixl "\<guillemotright>=" 70)
hide (open) type pred seq
-hide (open) const Pred eval single bind if_pred not_pred
- Empty Insert Join Seq member pred_of_seq "apply" adjunct eq map
+hide (open) const Pred eval single bind is_empty singleton if_pred not_pred
+ Empty Insert Join Seq member pred_of_seq "apply" adjunct null the_only eq map
end
--- a/src/HOL/Presburger.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Presburger.thy Thu Oct 01 07:40:25 2009 +0200
@@ -382,15 +382,22 @@
lemma uminus_dvd_conv: "(d dvd (t::int)) \<equiv> (-d dvd t)" "(d dvd (t::int)) \<equiv> (d dvd -t)"
by simp_all
+
text {* \bigskip Theorems for transforming predicates on nat to predicates on @{text int}*}
-lemma all_nat: "(\<forall>x::nat. P x) = (\<forall>x::int. 0 <= x \<longrightarrow> P (nat x))"
+
+lemma all_nat: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x\<ge>0. P (nat x))"
by (simp split add: split_nat)
-lemma ex_nat: "(\<exists>x::nat. P x) = (\<exists>x::int. 0 <= x \<and> P (nat x))"
- apply (auto split add: split_nat)
- apply (rule_tac x="int x" in exI, simp)
- apply (rule_tac x = "nat x" in exI,erule_tac x = "nat x" in allE, simp)
- done
+lemma ex_nat: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. 0 \<le> x \<and> P (nat x))"
+proof
+ assume "\<exists>x. P x"
+ then obtain x where "P x" ..
+ then have "int x \<ge> 0 \<and> P (nat (int x))" by simp
+ then show "\<exists>x\<ge>0. P (nat x)" ..
+next
+ assume "\<exists>x\<ge>0. P (nat x)"
+ then show "\<exists>x. P x" by auto
+qed
lemma zdiff_int_split: "P (int (x - y)) =
((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
--- a/src/HOL/Prolog/prolog.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Prolog/prolog.ML Thu Oct 01 07:40:25 2009 +0200
@@ -2,7 +2,7 @@
Author: David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
*)
-set Proof.show_main_goal;
+Unsynchronized.set Proof.show_main_goal;
structure Prolog =
struct
--- a/src/HOL/Quickcheck.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Quickcheck.thy Thu Oct 01 07:40:25 2009 +0200
@@ -3,7 +3,7 @@
header {* A simple counterexample generator *}
theory Quickcheck
-imports Random Code_Eval
+imports Random Code_Evaluation
uses ("Tools/quickcheck_generators.ML")
begin
@@ -24,7 +24,7 @@
definition
"random i = Random.range 2 o\<rightarrow>
- (\<lambda>k. Pair (if k = 0 then Code_Eval.valtermify False else Code_Eval.valtermify True))"
+ (\<lambda>k. Pair (if k = 0 then Code_Evaluation.valtermify False else Code_Evaluation.valtermify True))"
instance ..
@@ -34,7 +34,7 @@
begin
definition random_itself :: "code_numeral \<Rightarrow> Random.seed \<Rightarrow> ('a itself \<times> (unit \<Rightarrow> term)) \<times> Random.seed" where
- "random_itself _ = Pair (Code_Eval.valtermify TYPE('a))"
+ "random_itself _ = Pair (Code_Evaluation.valtermify TYPE('a))"
instance ..
@@ -44,7 +44,7 @@
begin
definition
- "random _ = Random.select chars o\<rightarrow> (\<lambda>c. Pair (c, \<lambda>u. Code_Eval.term_of c))"
+ "random _ = Random.select chars o\<rightarrow> (\<lambda>c. Pair (c, \<lambda>u. Code_Evaluation.term_of c))"
instance ..
@@ -54,7 +54,7 @@
begin
definition
- "random _ = Pair (STR '''', \<lambda>u. Code_Eval.term_of (STR ''''))"
+ "random _ = Pair (STR '''', \<lambda>u. Code_Evaluation.term_of (STR ''''))"
instance ..
@@ -63,10 +63,10 @@
instantiation nat :: random
begin
-definition random_nat :: "code_numeral \<Rightarrow> Random.seed \<Rightarrow> (nat \<times> (unit \<Rightarrow> Code_Eval.term)) \<times> Random.seed" where
+definition random_nat :: "code_numeral \<Rightarrow> Random.seed \<Rightarrow> (nat \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed" where
"random_nat i = Random.range (i + 1) o\<rightarrow> (\<lambda>k. Pair (
let n = Code_Numeral.nat_of k
- in (n, \<lambda>_. Code_Eval.term_of n)))"
+ in (n, \<lambda>_. Code_Evaluation.term_of n)))"
instance ..
@@ -78,7 +78,7 @@
definition
"random i = Random.range (2 * i + 1) o\<rightarrow> (\<lambda>k. Pair (
let j = (if k \<ge> i then Code_Numeral.int_of (k - i) else - Code_Numeral.int_of (i - k))
- in (j, \<lambda>_. Code_Eval.term_of j)))"
+ in (j, \<lambda>_. Code_Evaluation.term_of j)))"
instance ..
@@ -95,7 +95,7 @@
definition random_fun_lift :: "(Random.seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> Random.seed)
\<Rightarrow> Random.seed \<Rightarrow> (('a\<Colon>term_of \<Rightarrow> 'b\<Colon>typerep) \<times> (unit \<Rightarrow> term)) \<times> Random.seed" where
- "random_fun_lift f = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of f Random.split_seed"
+ "random_fun_lift f = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Evaluation.term_of f Random.split_seed"
instantiation "fun" :: ("{eq, term_of}", random) random
begin
--- a/src/HOL/RComplete.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/RComplete.thy Thu Oct 01 07:40:25 2009 +0200
@@ -14,6 +14,9 @@
lemma real_sum_of_halves: "x/2 + x/2 = (x::real)"
by simp
+lemma abs_diff_less_iff:
+ "(\<bar>x - a\<bar> < (r::'a::ordered_idom)) = (a - r < x \<and> x < a + r)"
+ by auto
subsection {* Completeness of Positive Reals *}
@@ -301,6 +304,20 @@
qed
qed
+text{*A version of the same theorem without all those predicates!*}
+lemma reals_complete2:
+ fixes S :: "(real set)"
+ assumes "\<exists>y. y\<in>S" and "\<exists>(x::real). \<forall>y\<in>S. y \<le> x"
+ shows "\<exists>x. (\<forall>y\<in>S. y \<le> x) &
+ (\<forall>z. ((\<forall>y\<in>S. y \<le> z) --> x \<le> z))"
+proof -
+ have "\<exists>x. isLub UNIV S x"
+ by (rule reals_complete)
+ (auto simp add: isLub_def isUb_def leastP_def setle_def setge_def prems)
+ thus ?thesis
+ by (metis UNIV_I isLub_isUb isLub_le_isUb isUbD isUb_def setleI)
+qed
+
subsection {* The Archimedean Property of the Reals *}
--- a/src/HOL/Random.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Random.thy Thu Oct 01 07:40:25 2009 +0200
@@ -154,7 +154,7 @@
local
-val seed = ref
+val seed = Unsynchronized.ref
(let
val now = Time.toMilliseconds (Time.now ());
val (q, s1) = IntInf.divMod (now, 2147483562);
--- a/src/HOL/Rational.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Rational.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1002,8 +1002,8 @@
by simp
definition (in term_syntax)
- valterm_fract :: "int \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> int \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> rat \<times> (unit \<Rightarrow> Code_Eval.term)" where
- [code_unfold]: "valterm_fract k l = Code_Eval.valtermify Fract {\<cdot>} k {\<cdot>} l"
+ valterm_fract :: "int \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> int \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> rat \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
+ [code_unfold]: "valterm_fract k l = Code_Evaluation.valtermify Fract {\<cdot>} k {\<cdot>} l"
notation fcomp (infixl "o>" 60)
notation scomp (infixl "o\<rightarrow>" 60)
@@ -1014,7 +1014,7 @@
definition
"Quickcheck.random i = Quickcheck.random i o\<rightarrow> (\<lambda>num. Random.range i o\<rightarrow> (\<lambda>denom. Pair (
let j = Code_Numeral.int_of (denom + 1)
- in valterm_fract num (j, \<lambda>u. Code_Eval.term_of j))))"
+ in valterm_fract num (j, \<lambda>u. Code_Evaluation.term_of j))))"
instance ..
--- a/src/HOL/RealDef.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/RealDef.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1128,8 +1128,8 @@
by (simp add: of_rat_divide)
definition (in term_syntax)
- valterm_ratreal :: "rat \<times> (unit \<Rightarrow> Code_Eval.term) \<Rightarrow> real \<times> (unit \<Rightarrow> Code_Eval.term)" where
- [code_unfold]: "valterm_ratreal k = Code_Eval.valtermify Ratreal {\<cdot>} k"
+ valterm_ratreal :: "rat \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> real \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
+ [code_unfold]: "valterm_ratreal k = Code_Evaluation.valtermify Ratreal {\<cdot>} k"
notation fcomp (infixl "o>" 60)
notation scomp (infixl "o\<rightarrow>" 60)
--- a/src/HOL/Recdef.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Recdef.thy Thu Oct 01 07:40:25 2009 +0200
@@ -19,6 +19,65 @@
("Tools/recdef.ML")
begin
+inductive
+ wfrec_rel :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => 'a => 'b => bool"
+ for R :: "('a * 'a) set"
+ and F :: "('a => 'b) => 'a => 'b"
+where
+ wfrecI: "ALL z. (z, x) : R --> wfrec_rel R F z (g z) ==>
+ wfrec_rel R F x (F g x)"
+
+constdefs
+ cut :: "('a => 'b) => ('a * 'a)set => 'a => 'a => 'b"
+ "cut f r x == (%y. if (y,x):r then f y else undefined)"
+
+ adm_wf :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => bool"
+ "adm_wf R F == ALL f g x.
+ (ALL z. (z, x) : R --> f z = g z) --> F f x = F g x"
+
+ wfrec :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => 'a => 'b"
+ [code del]: "wfrec R F == %x. THE y. wfrec_rel R (%f x. F (cut f R x) x) x y"
+
+subsection{*Well-Founded Recursion*}
+
+text{*cut*}
+
+lemma cuts_eq: "(cut f r x = cut g r x) = (ALL y. (y,x):r --> f(y)=g(y))"
+by (simp add: expand_fun_eq cut_def)
+
+lemma cut_apply: "(x,a):r ==> (cut f r a)(x) = f(x)"
+by (simp add: cut_def)
+
+text{*Inductive characterization of wfrec combinator; for details see:
+John Harrison, "Inductive definitions: automation and application"*}
+
+lemma wfrec_unique: "[| adm_wf R F; wf R |] ==> EX! y. wfrec_rel R F x y"
+apply (simp add: adm_wf_def)
+apply (erule_tac a=x in wf_induct)
+apply (rule ex1I)
+apply (rule_tac g = "%x. THE y. wfrec_rel R F x y" in wfrec_rel.wfrecI)
+apply (fast dest!: theI')
+apply (erule wfrec_rel.cases, simp)
+apply (erule allE, erule allE, erule allE, erule mp)
+apply (fast intro: the_equality [symmetric])
+done
+
+lemma adm_lemma: "adm_wf R (%f x. F (cut f R x) x)"
+apply (simp add: adm_wf_def)
+apply (intro strip)
+apply (rule cuts_eq [THEN iffD2, THEN subst], assumption)
+apply (rule refl)
+done
+
+lemma wfrec: "wf(r) ==> wfrec r H a = H (cut (wfrec r H) r a) a"
+apply (simp add: wfrec_def)
+apply (rule adm_lemma [THEN wfrec_unique, THEN the1_equality], assumption)
+apply (rule wfrec_rel.wfrecI)
+apply (intro strip)
+apply (erule adm_lemma [THEN wfrec_unique, THEN theI'])
+done
+
+
text{** This form avoids giant explosions in proofs. NOTE USE OF ==*}
lemma def_wfrec: "[| f==wfrec r H; wf(r) |] ==> f(a) = H (cut f r a) a"
apply auto
--- a/src/HOL/Record.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Record.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,8 @@
(* Title: HOL/Record.thy
- Author: Wolfgang Naraschewski, Norbert Schirmer and Markus Wenzel, TU Muenchen
+ Author: Wolfgang Naraschewski, TU Muenchen
+ Author: Markus Wenzel, TU Muenchen
+ Author: Norbert Schirmer, TU Muenchen
+ Author: Thomas Sewell, NICTA
*)
header {* Extensible records with structural subtyping *}
@@ -12,15 +15,20 @@
lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
by simp
-lemma rec_UNIV_I: "\<And>x. x\<in>UNIV \<equiv> True"
- by simp
-
-lemma rec_True_simp: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
- by simp
-
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"
+ by clarsimp
+
+lemma id_o_refl:
+ "id o f = f o id"
+ by simp
+
+lemma o_eq_id_dest:
+ "a o b = id o c \<Longrightarrow> a (b v) = c v"
+ by clarsimp
subsection {* Concrete record syntax *}
@@ -55,6 +63,403 @@
"_record_scheme" :: "[fields, 'a] => 'a" ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
"_record_update" :: "['a, updates] => 'b" ("_/(3\<lparr>_\<rparr>)" [900,0] 900)
+subsection {* Operators and lemmas for types isomorphic to tuples *}
+
+text {*
+Records are isomorphic to compound tuple types. To implement efficient
+records, we make this isomorphism explicit. Consider the record
+access/update simplification @{text "alpha (beta_update f rec) = alpha rec"} for
+distinct fields alpha and beta of some record rec with n fields. There
+are @{text "n ^ 2"} such theorems, which prohibits storage of all of them for
+large n. The rules can be proved on the fly by case decomposition and
+simplification in O(n) time. By creating O(n) isomorphic-tuple types
+while defining the record, however, we can prove the access/update
+simplification in @{text "O(log(n)^2)"} time.
+
+The O(n) cost of case decomposition is not because O(n) steps are taken,
+but rather because the resulting rule must contain O(n) new variables and
+an O(n) size concrete record construction. To sidestep this cost, we would
+like to avoid case decomposition in proving access/update theorems.
+
+Record types are defined as isomorphic to tuple types. For instance, a
+record type with fields 'a, 'b, 'c and 'd might be introduced as
+isomorphic to @{text "'a \<times> ('b \<times> ('c \<times> 'd))"}. If we balance the tuple tree to
+@{text "('a \<times> 'b) \<times> ('c \<times> 'd)"} then accessors can be defined by converting to
+the underlying type then using O(log(n)) fst or snd operations.
+Updators can be defined similarly, if we introduce a @{text "fst_update"} and
+@{text "snd_update"} function. Furthermore, we can prove the access/update
+theorem in O(log(n)) steps by using simple rewrites on fst, snd,
+@{text "fst_update"} and @{text "snd_update"}.
+
+The catch is that, although O(log(n)) steps were taken, the underlying
+type we converted to is a tuple tree of size O(n). Processing this term
+type wastes performance. We avoid this for large n by taking each
+subtree of size K and defining a new type isomorphic to that tuple
+subtree. A record can now be defined as isomorphic to a tuple tree
+of these O(n/K) new types, or, if @{text "n > K*K"}, we can repeat the process,
+until the record can be defined in terms of a tuple tree of complexity
+less than the constant K.
+
+If we prove the access/update theorem on this type with the analagous
+steps to the tuple tree, we consume @{text "O(log(n)^2)"} time as the intermediate
+terms are O(log(n)) in size and the types needed have size bounded by K.
+To enable this analagous traversal, we define the functions seen below:
+@{text "istuple_fst"}, @{text "istuple_snd"}, @{text "istuple_fst_update"}
+and @{text "istuple_snd_update"}. These functions generalise tuple
+operations by taking a parameter that encapsulates a tuple isomorphism.
+The rewrites needed on these functions now need an additional assumption
+which is that the isomorphism works.
+
+These rewrites are typically used in a structured way. They are here
+presented as the introduction rule @{text "isomorphic_tuple.intros"} rather than
+as a rewrite rule set. The introduction form is an optimisation, as net
+matching can be performed at one term location for each step rather than
+the simplifier searching the term for possible pattern matches. The rule
+set is used as it is viewed outside the locale, with the locale assumption
+(that the isomorphism is valid) left as a rule assumption. All rules are
+structured to aid net matching, using either a point-free form or an
+encapsulating predicate.
+*}
+
+typedef ('a, 'b, 'c) tuple_isomorphism
+ = "UNIV :: (('a \<Rightarrow> ('b \<times> 'c)) \<times> (('b \<times> 'c) \<Rightarrow> 'a)) set"
+ by simp
+
+definition
+ "TupleIsomorphism repr abst = Abs_tuple_isomorphism (repr, abst)"
+
+definition
+ istuple_fst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b"
+where
+ "istuple_fst isom \<equiv> let (repr, abst) = Rep_tuple_isomorphism isom in fst \<circ> repr"
+
+definition
+ istuple_snd :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'c"
+where
+ "istuple_snd isom \<equiv> let (repr, abst) = Rep_tuple_isomorphism isom in snd \<circ> repr"
+
+definition
+ istuple_fst_update :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)"
+where
+ "istuple_fst_update isom \<equiv>
+ let (repr, abst) = Rep_tuple_isomorphism isom in
+ (\<lambda>f v. abst (f (fst (repr v)), snd (repr v)))"
+
+definition
+ istuple_snd_update :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a)"
+where
+ "istuple_snd_update isom \<equiv>
+ let (repr, abst) = Rep_tuple_isomorphism isom in
+ (\<lambda>f v. abst (fst (repr v), f (snd (repr v))))"
+
+definition
+ istuple_cons :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a"
+where
+ "istuple_cons isom \<equiv> let (repr, abst) = Rep_tuple_isomorphism isom in curry abst"
+
+text {*
+These predicates are used in the introduction rule set to constrain
+matching appropriately. The elimination rules for them produce the
+desired theorems once they are proven. The final introduction rules are
+used when no further rules from the introduction rule set can apply.
+*}
+
+definition
+ istuple_surjective_proof_assist :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
+where
+ "istuple_surjective_proof_assist x y f \<equiv> (f x = y)"
+
+definition
+ istuple_update_accessor_cong_assist :: "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a))
+ \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
+where
+ "istuple_update_accessor_cong_assist upd acc
+ \<equiv> (\<forall>f v. upd (\<lambda>x. f (acc v)) v = upd f v)
+ \<and> (\<forall>v. upd id v = v)"
+
+definition
+ istuple_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
+ "istuple_update_accessor_eq_assist upd acc v f v' x
+ \<equiv> upd f v = v' \<and> acc v = x
+ \<and> istuple_update_accessor_cong_assist upd acc"
+
+lemma update_accessor_congruence_foldE:
+ assumes uac: "istuple_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'"
+ 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: istuple_update_accessor_cong_assist_def)
+ apply (simp add: f)
+ done
+
+lemma update_accessor_congruence_unfoldE:
+ "\<lbrakk> istuple_update_accessor_cong_assist upd acc;
+ r = r'; acc r' = v'; \<And>v. v = v' \<Longrightarrow> f v = f' v \<rbrakk>
+ \<Longrightarrow> upd f r = upd f' r'"
+ apply (erule(2) update_accessor_congruence_foldE)
+ apply simp
+ done
+
+lemma istuple_update_accessor_cong_assist_id:
+ "istuple_update_accessor_cong_assist upd acc \<Longrightarrow> upd id = id"
+ by (rule ext, simp add: istuple_update_accessor_cong_assist_def)
+
+lemma update_accessor_noopE:
+ assumes uac: "istuple_update_accessor_cong_assist upd acc"
+ and acc: "f (acc x) = acc x"
+ shows "upd f x = x"
+ using uac
+ by (simp add: acc istuple_update_accessor_cong_assist_id[OF uac, unfolded id_def]
+ cong: update_accessor_congruence_unfoldE[OF uac])
+
+lemma update_accessor_noop_compE:
+ assumes uac: "istuple_update_accessor_cong_assist upd acc"
+ assumes 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:
+ "istuple_update_accessor_cong_assist id id"
+ by (simp add: istuple_update_accessor_cong_assist_def)
+
+lemma update_accessor_cong_assist_triv:
+ "istuple_update_accessor_cong_assist upd acc
+ \<Longrightarrow> istuple_update_accessor_cong_assist upd acc"
+ by assumption
+
+lemma update_accessor_accessor_eqE:
+ "\<lbrakk> istuple_update_accessor_eq_assist upd acc v f v' x \<rbrakk> \<Longrightarrow> acc v = x"
+ by (simp add: istuple_update_accessor_eq_assist_def)
+
+lemma update_accessor_updator_eqE:
+ "\<lbrakk> istuple_update_accessor_eq_assist upd acc v f v' x \<rbrakk> \<Longrightarrow> upd f v = v'"
+ by (simp add: istuple_update_accessor_eq_assist_def)
+
+lemma istuple_update_accessor_eq_assist_idI:
+ "v' = f v \<Longrightarrow> istuple_update_accessor_eq_assist id id v f v' v"
+ by (simp add: istuple_update_accessor_eq_assist_def
+ update_accessor_cong_assist_idI)
+
+lemma istuple_update_accessor_eq_assist_triv:
+ "istuple_update_accessor_eq_assist upd acc v f v' x
+ \<Longrightarrow> istuple_update_accessor_eq_assist upd acc v f v' x"
+ by assumption
+
+lemma istuple_update_accessor_cong_from_eq:
+ "istuple_update_accessor_eq_assist upd acc v f v' x
+ \<Longrightarrow> istuple_update_accessor_cong_assist upd acc"
+ by (simp add: istuple_update_accessor_eq_assist_def)
+
+lemma o_eq_dest:
+ "a o b = c o d \<Longrightarrow> a (b v) = c (d v)"
+ apply (clarsimp simp: o_def)
+ apply (erule fun_cong)
+ done
+
+lemma o_eq_elim:
+ "\<lbrakk> a o b = c o d; \<lbrakk> \<And>v. a (b v) = c (d v) \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
+ apply (erule meta_mp)
+ apply (erule o_eq_dest)
+ done
+
+lemma istuple_surjective_proof_assistI:
+ "f x = y \<Longrightarrow>
+ istuple_surjective_proof_assist x y f"
+ by (simp add: istuple_surjective_proof_assist_def)
+
+lemma istuple_surjective_proof_assist_idE:
+ "istuple_surjective_proof_assist x y id \<Longrightarrow> x = y"
+ by (simp add: istuple_surjective_proof_assist_def)
+
+locale isomorphic_tuple =
+ fixes isom :: "('a, 'b, 'c) tuple_isomorphism"
+ and repr and abst
+ defines "repr \<equiv> fst (Rep_tuple_isomorphism isom)"
+ defines "abst \<equiv> snd (Rep_tuple_isomorphism isom)"
+ assumes repr_inv: "\<And>x. abst (repr x) = x"
+ assumes abst_inv: "\<And>y. repr (abst y) = y"
+
+begin
+
+lemma repr_inj:
+ "(repr x = repr y) = (x = y)"
+ apply (rule iffI, simp_all)
+ apply (drule_tac f=abst in arg_cong, simp add: repr_inv)
+ done
+
+lemma abst_inj:
+ "(abst x = abst y) = (x = y)"
+ apply (rule iffI, simp_all)
+ apply (drule_tac f=repr in arg_cong, simp add: abst_inv)
+ done
+
+lemma split_Rep:
+ "split f (Rep_tuple_isomorphism isom)
+ = f repr abst"
+ by (simp add: split_def repr_def abst_def)
+
+lemmas simps = Let_def split_Rep repr_inv abst_inv repr_inj abst_inj
+
+lemma istuple_access_update_fst_fst:
+ "\<lbrakk> f o h g = j o f \<rbrakk> \<Longrightarrow>
+ (f o istuple_fst isom) o (istuple_fst_update isom o h) g
+ = j o (f o istuple_fst isom)"
+ by (clarsimp simp: istuple_fst_update_def istuple_fst_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_access_update_snd_snd:
+ "\<lbrakk> f o h g = j o f \<rbrakk> \<Longrightarrow>
+ (f o istuple_snd isom) o (istuple_snd_update isom o h) g
+ = j o (f o istuple_snd isom)"
+ by (clarsimp simp: istuple_snd_update_def istuple_snd_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_access_update_fst_snd:
+ "(f o istuple_fst isom) o (istuple_snd_update isom o h) g
+ = id o (f o istuple_fst isom)"
+ by (clarsimp simp: istuple_snd_update_def istuple_fst_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_access_update_snd_fst:
+ "(f o istuple_snd isom) o (istuple_fst_update isom o h) g
+ = id o (f o istuple_snd isom)"
+ by (clarsimp simp: istuple_fst_update_def istuple_snd_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_update_swap_fst_fst:
+ "\<lbrakk> h f o j g = j g o h f \<rbrakk> \<Longrightarrow>
+ (istuple_fst_update isom o h) f o (istuple_fst_update isom o j) g
+ = (istuple_fst_update isom o j) g o (istuple_fst_update isom o h) f"
+ by (clarsimp simp: istuple_fst_update_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_update_swap_snd_snd:
+ "\<lbrakk> h f o j g = j g o h f \<rbrakk> \<Longrightarrow>
+ (istuple_snd_update isom o h) f o (istuple_snd_update isom o j) g
+ = (istuple_snd_update isom o j) g o (istuple_snd_update isom o h) f"
+ by (clarsimp simp: istuple_snd_update_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_update_swap_fst_snd:
+ "(istuple_snd_update isom o h) f o (istuple_fst_update isom o j) g
+ = (istuple_fst_update isom o j) g o (istuple_snd_update isom o h) f"
+ by (clarsimp simp: istuple_fst_update_def istuple_snd_update_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_update_swap_snd_fst:
+ "(istuple_fst_update isom o h) f o (istuple_snd_update isom o j) g
+ = (istuple_snd_update isom o j) g o (istuple_fst_update isom o h) f"
+ by (clarsimp simp: istuple_fst_update_def istuple_snd_update_def simps
+ intro!: ext elim!: o_eq_elim)
+
+lemma istuple_update_compose_fst_fst:
+ "\<lbrakk> h f o j g = k (f o g) \<rbrakk> \<Longrightarrow>
+ (istuple_fst_update isom o h) f o (istuple_fst_update isom o j) g
+ = (istuple_fst_update isom o k) (f o g)"
+ by (fastsimp simp: istuple_fst_update_def simps
+ intro!: ext elim!: o_eq_elim dest: fun_cong)
+
+lemma istuple_update_compose_snd_snd:
+ "\<lbrakk> h f o j g = k (f o g) \<rbrakk> \<Longrightarrow>
+ (istuple_snd_update isom o h) f o (istuple_snd_update isom o j) g
+ = (istuple_snd_update isom o k) (f o g)"
+ by (fastsimp simp: istuple_snd_update_def simps
+ intro!: ext elim!: o_eq_elim dest: fun_cong)
+
+lemma istuple_surjective_proof_assist_step:
+ "\<lbrakk> istuple_surjective_proof_assist v a (istuple_fst isom o f);
+ istuple_surjective_proof_assist v b (istuple_snd isom o f) \<rbrakk>
+ \<Longrightarrow> istuple_surjective_proof_assist v (istuple_cons isom a b) f"
+ by (clarsimp simp: istuple_surjective_proof_assist_def simps
+ istuple_fst_def istuple_snd_def istuple_cons_def)
+
+lemma istuple_fst_update_accessor_cong_assist:
+ "istuple_update_accessor_cong_assist f g \<Longrightarrow>
+ istuple_update_accessor_cong_assist (istuple_fst_update isom o f) (g o istuple_fst isom)"
+ by (clarsimp simp: istuple_update_accessor_cong_assist_def simps
+ istuple_fst_update_def istuple_fst_def)
+
+lemma istuple_snd_update_accessor_cong_assist:
+ "istuple_update_accessor_cong_assist f g \<Longrightarrow>
+ istuple_update_accessor_cong_assist (istuple_snd_update isom o f) (g o istuple_snd isom)"
+ by (clarsimp simp: istuple_update_accessor_cong_assist_def simps
+ istuple_snd_update_def istuple_snd_def)
+
+lemma istuple_fst_update_accessor_eq_assist:
+ "istuple_update_accessor_eq_assist f g a u a' v \<Longrightarrow>
+ istuple_update_accessor_eq_assist (istuple_fst_update isom o f) (g o istuple_fst isom)
+ (istuple_cons isom a b) u (istuple_cons isom a' b) v"
+ by (clarsimp simp: istuple_update_accessor_eq_assist_def istuple_fst_update_def istuple_fst_def
+ istuple_update_accessor_cong_assist_def istuple_cons_def simps)
+
+lemma istuple_snd_update_accessor_eq_assist:
+ "istuple_update_accessor_eq_assist f g b u b' v \<Longrightarrow>
+ istuple_update_accessor_eq_assist (istuple_snd_update isom o f) (g o istuple_snd isom)
+ (istuple_cons isom a b) u (istuple_cons isom a b') v"
+ by (clarsimp simp: istuple_update_accessor_eq_assist_def istuple_snd_update_def istuple_snd_def
+ istuple_update_accessor_cong_assist_def istuple_cons_def simps)
+
+lemma istuple_cons_conj_eqI:
+ "\<lbrakk> (a = c \<and> b = d \<and> P) = Q \<rbrakk> \<Longrightarrow>
+ (istuple_cons isom a b = istuple_cons isom c d \<and> P) = Q"
+ by (clarsimp simp: istuple_cons_def simps)
+
+lemmas intros =
+ istuple_access_update_fst_fst
+ istuple_access_update_snd_snd
+ istuple_access_update_fst_snd
+ istuple_access_update_snd_fst
+ istuple_update_swap_fst_fst
+ istuple_update_swap_snd_snd
+ istuple_update_swap_fst_snd
+ istuple_update_swap_snd_fst
+ istuple_update_compose_fst_fst
+ istuple_update_compose_snd_snd
+ istuple_surjective_proof_assist_step
+ istuple_fst_update_accessor_eq_assist
+ istuple_snd_update_accessor_eq_assist
+ istuple_fst_update_accessor_cong_assist
+ istuple_snd_update_accessor_cong_assist
+ istuple_cons_conj_eqI
+
+end
+
+lemma isomorphic_tuple_intro:
+ assumes repr_inj: "\<And>x y. (repr x = repr y) = (x = y)"
+ and abst_inv: "\<And>z. repr (abst z) = z"
+ shows "v \<equiv> TupleIsomorphism repr abst \<Longrightarrow> isomorphic_tuple v"
+ apply (rule isomorphic_tuple.intro,
+ simp_all add: TupleIsomorphism_def Abs_tuple_isomorphism_inverse
+ tuple_isomorphism_def abst_inv)
+ apply (cut_tac x="abst (repr x)" and y="x" in repr_inj)
+ apply (simp add: abst_inv)
+ done
+
+definition
+ "tuple_istuple \<equiv> TupleIsomorphism id id"
+
+lemma tuple_istuple:
+ "isomorphic_tuple tuple_istuple"
+ by (simp add: isomorphic_tuple_intro[OF _ _ reflexive] tuple_istuple_def)
+
+lemma refl_conj_eq:
+ "Q = R \<Longrightarrow> (P \<and> Q) = (P \<and> R)"
+ by simp
+
+lemma meta_all_sameI:
+ "(\<And>x. PROP P x \<equiv> PROP Q x) \<Longrightarrow> (\<And>x. PROP P x) \<equiv> (\<And>x. PROP Q x)"
+ by simp
+
+lemma istuple_UNIV_I: "\<And>x. x\<in>UNIV \<equiv> True"
+ by simp
+
+lemma istuple_True_simp: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
+ by simp
+
use "Tools/record.ML"
setup Record.setup
--- a/src/HOL/Relation.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Relation.thy Thu Oct 01 07:40:25 2009 +0200
@@ -599,6 +599,9 @@
apply blast
done
+lemma in_inv_image[simp]: "((x,y) : inv_image r f) = ((f x, f y) : r)"
+ by (auto simp:inv_image_def)
+
subsection {* Finiteness *}
--- a/src/HOL/SEQ.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/SEQ.thy Thu Oct 01 07:40:25 2009 +0200
@@ -500,6 +500,28 @@
apply (drule LIMSEQ_minus, auto)
done
+lemma lim_le:
+ fixes x :: real
+ assumes f: "convergent f" and fn_le: "!!n. f n \<le> x"
+ shows "lim f \<le> x"
+proof (rule classical)
+ assume "\<not> lim f \<le> x"
+ hence 0: "0 < lim f - x" by arith
+ have 1: "f----> lim f"
+ by (metis convergent_LIMSEQ_iff f)
+ thus ?thesis
+ proof (simp add: LIMSEQ_iff)
+ assume "\<forall>r>0. \<exists>no. \<forall>n\<ge>no. \<bar>f n - lim f\<bar> < r"
+ hence "\<exists>no. \<forall>n\<ge>no. \<bar>f n - lim f\<bar> < lim f - x"
+ by (metis 0)
+ from this obtain no where "\<forall>n\<ge>no. \<bar>f n - lim f\<bar> < lim f - x"
+ by blast
+ thus "lim f \<le> x"
+ by (metis add_cancel_end add_minus_cancel diff_def linorder_linear
+ linorder_not_le minus_diff_eq abs_diff_less_iff fn_le)
+ qed
+qed
+
text{* Given a binary function @{text "f:: nat \<Rightarrow> 'a \<Rightarrow> 'a"}, its values are uniquely determined by a function g *}
lemma nat_function_unique: "EX! g. g 0 = e \<and> (\<forall>n. g (Suc n) = f n (g n))"
@@ -582,7 +604,7 @@
ultimately
have "a (max no n) < a n" by auto
with monotone[where m=n and n="max no n"]
- show False by auto
+ show False by (auto simp:max_def split:split_if_asm)
qed
} note top_down = this
{ fix x n m fix a :: "nat \<Rightarrow> real"
@@ -1082,10 +1104,6 @@
lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
by (simp add: isUbI setleI)
-lemma real_abs_diff_less_iff:
- "(\<bar>x - a\<bar> < (r::real)) = (a - r < x \<and> x < a + r)"
-by auto
-
locale real_Cauchy =
fixes X :: "nat \<Rightarrow> real"
assumes X: "Cauchy X"
@@ -1122,13 +1140,13 @@
show "\<exists>x. x \<in> S"
proof
from N have "\<forall>n\<ge>N. X N - 1 < X n"
- by (simp add: real_abs_diff_less_iff)
+ by (simp add: abs_diff_less_iff)
thus "X N - 1 \<in> S" by (rule mem_S)
qed
show "\<exists>u. isUb UNIV S u"
proof
from N have "\<forall>n\<ge>N. X n < X N + 1"
- by (simp add: real_abs_diff_less_iff)
+ by (simp add: abs_diff_less_iff)
thus "isUb UNIV S (X N + 1)"
by (rule bound_isUb)
qed
@@ -1144,7 +1162,7 @@
using CauchyD [OF X r] by auto
hence "\<forall>n\<ge>N. norm (X n - X N) < r/2" by simp
hence N: "\<forall>n\<ge>N. X N - r/2 < X n \<and> X n < X N + r/2"
- by (simp only: real_norm_def real_abs_diff_less_iff)
+ by (simp only: real_norm_def abs_diff_less_iff)
from N have "\<forall>n\<ge>N. X N - r/2 < X n" by fast
hence "X N - r/2 \<in> S" by (rule mem_S)
@@ -1159,7 +1177,7 @@
fix n assume n: "N \<le> n"
from N n have "X n < X N + r/2" and "X N - r/2 < X n" by simp+
thus "norm (X n - x) < r" using 1 2
- by (simp add: real_abs_diff_less_iff)
+ by (simp add: abs_diff_less_iff)
qed
qed
--- a/src/HOL/SET-Protocol/Cardholder_Registration.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/SET-Protocol/Cardholder_Registration.thy Thu Oct 01 07:40:25 2009 +0200
@@ -715,6 +715,7 @@
==> P --> (Nonce N \<in> analz (Key`KK Un H)) = (Nonce N \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])
+
text{*The @{text "(no_asm)"} attribute is essential, since it retains
the quantifier and allows the simprule's condition to itself be simplified.*}
lemma Nonce_compromise [rule_format (no_asm)]:
@@ -741,12 +742,11 @@
apply blast --{*3*}
apply blast --{*5*}
txt{*Message 6*}
-apply (force del: allE ballE impCE simp add: symKey_compromise)
+apply (metis symKey_compromise)
--{*cardSK compromised*}
txt{*Simplify again--necessary because the previous simplification introduces
- some logical connectives*}
-apply (force del: allE ballE impCE
- simp del: image_insert image_Un imp_disjL
+ some logical connectives*}
+apply (force simp del: image_insert image_Un imp_disjL
simp add: analz_image_keys_simps symKey_compromise)
done
--- a/src/HOL/SET-Protocol/Purchase.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/SET-Protocol/Purchase.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1040,9 +1040,8 @@
apply (frule_tac [9] AuthReq_msg_in_parts_spies) --{*AuthReq*}
apply simp_all
apply blast
-apply (force dest!: signed_Hash_imp_used)
-apply (clarify) --{*speeds next step*}
-apply (blast dest: unique_LID_M)
+apply (metis subsetD insert_subset parts.Fst parts_increasing signed_Hash_imp_used)
+apply (metis unique_LID_M)
apply (blast dest!: Notes_Cardholder_self_False)
done
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Examples/SMT_Examples.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,183 @@
+(* Title: SMT_Examples.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* Examples for the 'smt' tactic. *}
+
+theory SMT_Examples
+imports "../SMT"
+begin
+
+declare [[smt_solver=z3, z3_proofs=false]]
+declare [[smt_trace=false]]
+
+
+section {* Propositional and first-order logic *}
+
+lemma "True" by smt
+lemma "p \<or> \<not>p" by smt
+lemma "(p \<and> True) = p" by smt
+lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by smt
+lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by smt
+lemma "P=P=P=P=P=P=P=P=P=P" by smt
+
+axiomatization symm_f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
+ symm_f: "symm_f x y = symm_f y x"
+lemma "a = a \<and> symm_f a b = symm_f b a" by (smt add: symm_f)
+
+
+section {* Linear arithmetic *}
+
+lemma "(3::int) = 3" by smt
+lemma "(3::real) = 3" by smt
+lemma "(3 :: int) + 1 = 4" by smt
+lemma "max (3::int) 8 > 5" by smt
+lemma "abs (x :: real) + abs y \<ge> abs (x + y)" by smt
+lemma "let x = (2 :: int) in x + x \<noteq> 5" by smt
+
+text{*
+The following example was taken from HOL/ex/PresburgerEx.thy, where it says:
+
+ This following theorem proves that all solutions to the
+ recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
+ period 9. The example was brought to our attention by John
+ Harrison. It does does not require Presburger arithmetic but merely
+ quantifier-free linear arithmetic and holds for the rationals as well.
+
+ Warning: it takes (in 2006) over 4.2 minutes!
+
+There, it is proved by "arith". SMT is able to prove this within a fraction
+of one second.
+*}
+
+lemma "\<lbrakk> x3 = abs x2 - x1; x4 = abs x3 - x2; x5 = abs x4 - x3;
+ x6 = abs x5 - x4; x7 = abs x6 - x5; x8 = abs x7 - x6;
+ x9 = abs x8 - x7; x10 = abs x9 - x8; x11 = abs x10 - x9 \<rbrakk>
+ \<Longrightarrow> x1 = x10 & x2 = (x11::int)"
+ by smt
+
+lemma "\<exists>x::int. 0 < x" by smt
+lemma "\<exists>x::real. 0 < x" by smt
+lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by smt
+lemma "\<forall>x y::int. (2 * x + 1) \<noteq> (2 * y)" by smt
+lemma "~ (\<exists>x y z::int. 4 * x + -6 * y = (1::int))" by smt
+lemma "~ (\<exists>x::int. False)" by smt
+
+
+section {* Non-linear arithmetic *}
+
+lemma "((x::int) * (1 + y) - x * (1 - y)) = (2 * x * y)" by smt
+lemma
+ "(U::int) + (1 + p) * (b + e) + p * d =
+ U + (2 * (1 + p) * (b + e) + (1 + p) * d + d * p) - (1 + p) * (b + d + e)"
+ by smt
+
+
+section {* Linear arithmetic for natural numbers *}
+
+lemma "a < 3 \<Longrightarrow> (7::nat) > 2 * a" by smt
+lemma "let x = (1::nat) + y in x - y > 0 * x" by smt
+lemma
+ "let x = (1::nat) + y in
+ let P = (if x > 0 then True else False) in
+ False \<or> P = (x - 1 = y) \<or> (\<not>P \<longrightarrow> False)"
+ by smt
+
+
+section {* Bitvectors *}
+
+locale bv
+begin
+
+declare [[smt_solver=z3]]
+
+lemma "(27 :: 4 word) = -5" by smt
+lemma "(27 :: 4 word) = 11" by smt
+lemma "23 < (27::8 word)" by smt
+lemma "27 + 11 = (6::5 word)" by smt
+lemma "7 * 3 = (21::8 word)" by smt
+lemma "11 - 27 = (-16::8 word)" by smt
+lemma "- -11 = (11::5 word)" by smt
+lemma "-40 + 1 = (-39::7 word)" by smt
+lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by smt
+
+lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by smt
+lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by smt
+lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by smt
+lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by smt
+
+lemma "word_cat (27::4 word) (27::8 word) = (2843::12 word)" by smt
+lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
+ by smt
+
+lemma "slice 1 (0b10110 :: 4 word) = (0b11 :: 2 word)" by smt
+
+lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by smt
+lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by smt
+
+lemma "bv_lshr 0b10011 2 = (0b100::8 word)" by smt
+lemma "bv_ashr 0b10011 2 = (0b100::8 word)" by smt
+
+lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by smt
+lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by smt
+
+lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)" by smt
+
+lemma "w < 256 \<Longrightarrow> (w :: 16 word) AND 0x00FF = w" by smt
+
+end
+
+
+section {* Pairs *}
+
+lemma "fst (x, y) = a \<Longrightarrow> x = a" by smt
+lemma "p1 = (x, y) \<and> p2 = (y, x) \<Longrightarrow> fst p1 = snd p2" by smt
+
+
+section {* Higher-order problems and recursion *}
+
+lemma "(f g x = (g x \<and> True)) \<or> (f g x = True) \<or> (g x = True)" by smt
+lemma "P ((2::int) < 3) = P True" by smt
+lemma "P ((2::int) < 3) = (P True :: bool)" by smt
+lemma "P (0 \<le> (a :: 4 word)) = P True" using [[smt_solver=z3]] by smt
+lemma "id 3 = 3 \<and> id True = True" by (smt add: id_def)
+lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> ((f (i1 := v1)) (i2 := v2)) i = f i" by smt
+lemma "map (\<lambda>i::nat. i + 1) [0, 1] = [1, 2]" by (smt add: map.simps)
+lemma "(ALL x. P x) | ~ All P" by smt
+
+fun dec_10 :: "nat \<Rightarrow> nat" where
+ "dec_10 n = (if n < 10 then n else dec_10 (n - 10))"
+lemma "dec_10 (4 * dec_10 4) = 6" by (smt add: dec_10.simps)
+
+axiomatization
+ eval_dioph :: "int list \<Rightarrow> nat list \<Rightarrow> int"
+ where
+ eval_dioph_mod:
+ "eval_dioph ks xs mod int n = eval_dioph ks (map (\<lambda>x. x mod n) xs) mod int n"
+ and
+ eval_dioph_div_mult:
+ "eval_dioph ks (map (\<lambda>x. x div n) xs) * int n +
+ eval_dioph ks (map (\<lambda>x. x mod n) xs) = eval_dioph ks xs"
+lemma
+ "(eval_dioph ks xs = l) =
+ (eval_dioph ks (map (\<lambda>x. x mod 2) xs) mod 2 = l mod 2 \<and>
+ eval_dioph ks (map (\<lambda>x. x div 2) xs) =
+ (l - eval_dioph ks (map (\<lambda>x. x mod 2) xs)) div 2)"
+ using [[smt_solver=z3]]
+ by (smt add: eval_dioph_mod[where n=2] eval_dioph_div_mult[where n=2])
+
+
+section {* Monomorphization examples *}
+
+definition P :: "'a \<Rightarrow> bool" where "P x = True"
+lemma poly_P: "P x \<and> (P [x] \<or> \<not>P[x])" by (simp add: P_def)
+lemma "P (1::int)" by (smt add: poly_P)
+
+consts g :: "'a \<Rightarrow> nat"
+axioms
+ g1: "g (Some x) = g [x]"
+ g2: "g None = g []"
+ g3: "g xs = length xs"
+lemma "g (Some (3::int)) = g (Some True)" by (smt add: g1 g2 g3 list.size)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,1 @@
+use_thy "SMT";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/SMT.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,51 @@
+(* Title: HOL/SMT/SMT.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* SMT method using external SMT solvers (CVC3, Yices, Z3) *}
+
+theory SMT
+imports SMT_Definitions
+uses
+ "Tools/smt_normalize.ML"
+ "Tools/smt_monomorph.ML"
+ "Tools/smt_translate.ML"
+ "Tools/smt_solver.ML"
+ "Tools/smtlib_interface.ML"
+ "Tools/cvc3_solver.ML"
+ "Tools/yices_solver.ML"
+ "Tools/z3_model.ML"
+ "Tools/z3_interface.ML"
+ "Tools/z3_solver.ML"
+begin
+
+setup {*
+ SMT_Normalize.setup #>
+ SMT_Solver.setup #>
+ CVC3_Solver.setup #>
+ Yices_Solver.setup #>
+ Z3_Solver.setup
+*}
+
+ML {*
+OuterSyntax.improper_command "smt_status"
+ "Show the available SMT solvers and the currently selected solver."
+ OuterKeyword.diag
+ (Scan.succeed (Toplevel.no_timing o Toplevel.keep (fn state =>
+ SMT_Solver.print_setup (Context.Proof (Toplevel.context_of state)))))
+*}
+
+method_setup smt = {*
+ let fun solver thms ctxt = SMT_Solver.smt_tac ctxt thms
+ in
+ Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) [] >>
+ (Method.SIMPLE_METHOD' oo solver)
+ end
+*} "Applies an SMT solver to the current goal."
+
+declare [[ smt_solver = z3, smt_timeout = 20, smt_trace = false ]]
+declare [[ smt_unfold_defs = true ]]
+declare [[ z3_proofs = false ]]
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/SMT_Definitions.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,113 @@
+(* Title: HOL/SMT/SMT_Definitions.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* SMT-specific definitions *}
+
+theory SMT_Definitions
+imports Real Word "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+begin
+
+section {* Triggers for quantifier instantiation *}
+
+text {*
+Some SMT solvers support triggers for quantifier instantiation. Each trigger
+consists of one ore more patterns. A pattern may either be a list of positive
+subterms (the first being tagged by "pat" and the consecutive subterms tagged
+by "andpat"), or a list of negative subterms (the first being tagged by "nopat"
+and the consecutive subterms tagged by "andpat").
+*}
+
+datatype pattern = Pattern
+
+definition pat :: "'a \<Rightarrow> pattern"
+where "pat _ = Pattern"
+
+definition nopat :: "bool \<Rightarrow> pattern"
+where "nopat _ = Pattern"
+
+definition andpat :: "pattern \<Rightarrow> 'a \<Rightarrow> pattern" (infixl "andpat" 60)
+where "_ andpat _ = Pattern"
+
+definition trigger :: "pattern list \<Rightarrow> bool \<Rightarrow> bool"
+where "trigger _ P = P"
+
+
+section {* Arithmetic *}
+
+text {*
+The sign of @{term "op mod :: int \<Rightarrow> int \<Rightarrow> int"} follows the sign of the
+divisor. In contrast to that, the sign of the following operation is that of
+the dividend.
+*}
+
+definition rem :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "rem" 70)
+where "a rem b =
+ (if (a \<ge> 0 \<and> b < 0) \<or> (a < 0 \<and> b \<ge> 0) then - (a mod b) else a mod b)"
+
+text {* A decision procedure for linear real arithmetic: *}
+
+setup {*
+ Arith_Data.add_tactic "Ferrante-Rackoff" (K FerranteRackoff.dlo_tac)
+*}
+
+
+section {* Bitvectors *}
+
+text {*
+The following definitions provide additional functions not found in HOL-Word.
+*}
+
+definition sdiv :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "sdiv" 70)
+where "w1 sdiv w2 = word_of_int (sint w1 div sint w2)"
+
+definition smod :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "smod" 70)
+ (* sign follows divisor *)
+where "w1 smod w2 = word_of_int (sint w1 mod sint w2)"
+
+definition srem :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "srem" 70)
+ (* sign follows dividend *)
+where "w1 srem w2 = word_of_int (sint w1 rem sint w2)"
+
+definition bv_shl :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_shl w1 w2 = (w1 << unat w2)"
+
+definition bv_lshr :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_lshr w1 w2 = (w1 >> unat w2)"
+
+definition bv_ashr :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_ashr w1 w2 = (w1 >>> unat w2)"
+
+
+section {* Higher-order encoding *}
+
+definition "apply" where "apply f x = f x"
+
+
+section {* First-order logic *}
+
+text {*
+Some SMT solver formats require a strict separation between formulas and terms.
+The following marker symbols are used internally to separate those categories:
+*}
+
+definition formula :: "bool \<Rightarrow> bool" where "formula x = x"
+definition "term" where "term x = x"
+
+text {*
+Predicate symbols also occurring as function symbols are turned into function
+symbols by translating atomic formulas into terms:
+*}
+
+abbreviation holds :: "bool \<Rightarrow> bool" where "holds \<equiv> (\<lambda>P. term P = term True)"
+
+text {*
+The following constant represents equivalence, to be treated differently than
+the (polymorphic) equality predicate:
+*}
+
+definition iff :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infix "iff" 50) where
+ "(x iff y) = (x = y)"
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/cvc3_solver.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,59 @@
+(* Title: HOL/SMT/Tools/cvc3_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver CVC3.
+*)
+
+signature CVC3_SOLVER =
+sig
+ val setup: theory -> theory
+end
+
+structure CVC3_Solver: CVC3_SOLVER =
+struct
+
+val solver_name = "cvc3"
+val env_var = "CVC3_SOLVER"
+
+val options =
+ ["+counterexample", "-lang", "smtlib", "-output-lang", "presentation"]
+
+val is_sat = String.isPrefix "Satisfiable."
+val is_unsat = String.isPrefix "Unsatisfiable."
+val is_unknown = String.isPrefix "Unknown."
+
+fun cex_kind true = "Counterexample"
+ | cex_kind false = "Possible counterexample"
+
+fun raise_cex real ctxt recon ls =
+ let
+ val start = String.isPrefix "%Satisfiable Variable Assignment: %"
+ val index = find_index start ls
+ val ls = if index > 0 then Library.drop (index + 1, ls) else []
+ val p = Pretty.big_list (cex_kind real ^ " found:") (map Pretty.str ls)
+ in error (Pretty.string_of p) end
+
+fun core_oracle (SMT_Solver.ProofData {context, output, recon, ...}) =
+ let
+ val empty_line = (fn "" => true | _ => false)
+ val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
+ val (l, ls) = split_first (dropwhile empty_line output)
+ in
+ if is_unsat l then @{cprop False}
+ else if is_sat l then raise_cex true context recon ls
+ else if is_unknown l then raise_cex false context recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun smtlib_solver oracle _ =
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = SMTLIB_Interface.interface,
+ arguments = options,
+ reconstruct = oracle }
+
+val setup =
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, smtlib_solver oracle))
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_builtin.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,78 @@
+(* Title: HOL/SMT/Tools/smt_builtin.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Tables for built-in symbols.
+*)
+
+signature SMT_BUILTIN =
+sig
+ type sterm = (SMT_Translate.sym, typ) sterm
+ type builtin_fun = typ -> sterm list -> (string * sterm list) option
+ type table = (typ * builtin_fun) list Symtab.table
+
+ val make: (term * string) list -> table
+ val add: term * builtin_fun -> table -> table
+ val lookup: table -> theory -> string * typ -> sterm list ->
+ (string * sterm list) option
+
+ val bv_rotate: (int -> string) -> builtin_fun
+ val bv_extend: (int -> string) -> builtin_fun
+ val bv_extract: (int -> int -> string) -> builtin_fun
+end
+
+structure SMT_Builtin: SMT_BUILTIN =
+struct
+
+structure T = SMT_Translate
+
+type sterm = (SMT_Translate.sym, typ) sterm
+type builtin_fun = typ -> sterm list -> (string * sterm list) option
+type table = (typ * builtin_fun) list Symtab.table
+
+fun make entries =
+ let
+ fun dest (t, bn) =
+ let val (n, T) = Term.dest_Const t
+ in (n, (Logic.varifyT T, K (pair bn))) end
+ in Symtab.make (AList.group (op =) (map dest entries)) end
+
+fun add (t, f) tab =
+ let val (n, T) = apsnd Logic.varifyT (Term.dest_Const t)
+ in Symtab.map_default (n, []) (AList.update (op =) (T, f)) tab end
+
+fun lookup tab thy (n, T) =
+ AList.lookup (Sign.typ_instance thy) (Symtab.lookup_list tab n) T T
+
+
+fun dest_binT T =
+ (case T of
+ Type (@{type_name "Numeral_Type.num0"}, _) => 0
+ | Type (@{type_name "Numeral_Type.num1"}, _) => 1
+ | Type (@{type_name "Numeral_Type.bit0"}, [T]) => 2 * dest_binT T
+ | Type (@{type_name "Numeral_Type.bit1"}, [T]) => 1 + 2 * dest_binT T
+ | _ => raise TYPE ("dest_binT", [T], []))
+
+fun dest_wordT T =
+ (case T of
+ Type (@{type_name "word"}, [T]) => dest_binT T
+ | _ => raise TYPE ("dest_wordT", [T], []))
+
+
+val dest_nat = (fn
+ SApp (SConst (@{const_name nat}, _), [SApp (SNum (i, _), _)]) => SOME i
+ | _ => NONE)
+
+fun bv_rotate mk_name T ts =
+ dest_nat (hd ts) |> Option.map (fn i => (mk_name i, tl ts))
+
+fun bv_extend mk_name T ts =
+ (case (try dest_wordT (domain_type T), try dest_wordT (range_type T)) of
+ (SOME i, SOME j) => if j - i >= 0 then SOME (mk_name (j - i), ts) else NONE
+ | _ => NONE)
+
+fun bv_extract mk_name T ts =
+ (case (try dest_wordT (body_type T), dest_nat (hd ts)) of
+ (SOME i, SOME lb) => SOME (mk_name (i + lb - 1) lb, tl ts)
+ | _ => NONE)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_monomorph.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,120 @@
+(* Title: HOL/SMT/Tools/smt_monomorph.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Monomorphization of terms, i.e., computation of all (necessary) instances.
+*)
+
+signature SMT_MONOMORPH =
+sig
+ val monomorph: theory -> term list -> term list
+end
+
+structure SMT_Monomorph: SMT_MONOMORPH =
+struct
+
+fun selection [] = []
+ | selection (x :: xs) = (x, xs) :: map (apsnd (cons x)) (selection xs)
+
+fun permute [] = []
+ | permute [x] = [[x]]
+ | permute xs = maps (fn (y, ys) => map (cons y) (permute ys)) (selection xs)
+
+fun fold_all f = fold (fn x => maps (f x))
+
+
+val typ_has_tvars = Term.exists_subtype (fn TVar _ => true | _ => false)
+val term_has_tvars = Term.exists_type typ_has_tvars
+
+val ignored = member (op =) [
+ @{const_name All}, @{const_name Ex}, @{const_name Let}, @{const_name If},
+ @{const_name "op ="}, @{const_name zero_class.zero},
+ @{const_name one_class.one}, @{const_name number_of}]
+fun consts_of ts = AList.group (op =) (fold Term.add_consts ts [])
+ |> filter_out (ignored o fst)
+
+val join_consts = curry (AList.join (op =) (K (merge (op =))))
+fun diff_consts cs ds =
+ let fun diff (n, Ts) =
+ (case AList.lookup (op =) cs n of
+ NONE => SOME (n, Ts)
+ | SOME Us =>
+ let val Ts' = fold (remove (op =)) Us Ts
+ in if null Ts' then NONE else SOME (n, Ts') end)
+ in map_filter diff ds end
+
+fun instances thy is (n, Ts) env =
+ let
+ val Us = these (AList.lookup (op =) is n)
+ val Ts' = filter typ_has_tvars (map (Envir.subst_type env) Ts)
+ in
+ (case map_product pair Ts' Us of
+ [] => [env]
+ | TUs => map_filter (try (fn TU => Sign.typ_match thy TU env)) TUs)
+ end
+
+fun proper_match ps env =
+ forall (forall (not o typ_has_tvars o Envir.subst_type env) o snd) ps
+
+val eq_tab = gen_eq_set (op =) o pairself Vartab.dest
+
+fun specialize thy cs is ((r, ps), ces) (ts, ns) =
+ let
+ val ps' = filter (AList.defined (op =) is o fst) ps
+
+ val envs = permute ps'
+ |> maps (fn ps => fold_all (instances thy is) ps [Vartab.empty])
+ |> filter (proper_match ps')
+ |> filter_out (member eq_tab ces)
+ |> distinct eq_tab
+
+ val us = map (fn env => Envir.subst_term_types env r) envs
+ val ns' = join_consts (diff_consts is (diff_consts cs (consts_of us))) ns
+ in (envs @ ces, (fold (insert (op aconv)) us ts, ns')) end
+
+
+fun incr_tvar_indices i t =
+ let
+ val incrT = Logic.incr_tvar i
+
+ fun incr t =
+ (case t of
+ Const (n, T) => Const (n, incrT T)
+ | Free (n, T) => Free (n, incrT T)
+ | Abs (n, T, t1) => Abs (n, incrT T, incr t1)
+ | t1 $ t2 => incr t1 $ incr t2
+ | _ => t)
+ in incr t end
+
+
+val monomorph_limit = 10
+
+(* Instantiate all polymorphic constants (i.e., constants occurring both with
+ ground types and type variables) with all (necessary) ground types; thereby
+ create copies of terms containing those constants.
+ To prevent non-termination, there is an upper limit for the number of
+ recursions involved in the fixpoint construction. *)
+fun monomorph thy ts =
+ let
+ val (ps, ms) = List.partition term_has_tvars ts
+
+ fun with_tvar (n, Ts) =
+ let val Ts' = filter typ_has_tvars Ts
+ in if null Ts' then NONE else SOME (n, Ts') end
+ fun incr t idx = (incr_tvar_indices idx t, idx + Term.maxidx_of_term t + 1)
+ val rps = fst (fold_map incr ps 0)
+ |> map (fn r => (r, map_filter with_tvar (consts_of [r])))
+
+ fun mono count is ces cs ts =
+ let
+ val spec = specialize thy cs is
+ val (ces', (ts', is')) = fold_map spec (rps ~~ ces) (ts, [])
+ val cs' = join_consts is cs
+ in
+ if null is' then ts'
+ else if count > monomorph_limit then
+ (Output.warning "monomorphization limit reached"; ts')
+ else mono (count + 1) is' ces' cs' ts'
+ end
+ in mono 0 (consts_of ms) (map (K []) rps) [] ms end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_normalize.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,408 @@
+(* Title: HOL/SMT/Tools/smt_normalize.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Normalization steps on theorems required by SMT solvers:
+ * unfold trivial let expressions,
+ * replace negative numerals by negated positive numerals,
+ * embed natural numbers into integers,
+ * add extra rules specifying types and constants which occur frequently,
+ * lift lambda terms,
+ * make applications explicit for functions with varying number of arguments,
+ * fully translate into object logic, add universal closure.
+*)
+
+signature SMT_NORMALIZE =
+sig
+ val normalize_rule: Proof.context -> thm -> thm
+ val instantiate_free: Thm.cterm * Thm.cterm -> thm -> thm
+ val discharge_definition: Thm.cterm -> thm -> thm
+
+ val trivial_let: Proof.context -> thm list -> thm list
+ val positive_numerals: Proof.context -> thm list -> thm list
+ val nat_as_int: Proof.context -> thm list -> thm list
+ val unfold_defs: bool Config.T
+ val add_pair_rules: Proof.context -> thm list -> thm list
+ val add_fun_upd_rules: Proof.context -> thm list -> thm list
+ val add_abs_min_max_rules: Proof.context -> thm list -> thm list
+
+ datatype config =
+ RewriteTrivialLets |
+ RewriteNegativeNumerals |
+ RewriteNaturalNumbers |
+ AddPairRules |
+ AddFunUpdRules |
+ AddAbsMinMaxRules
+
+ val normalize: config list -> Proof.context -> thm list ->
+ Thm.cterm list * thm list
+
+ val setup: theory -> theory
+end
+
+structure SMT_Normalize: SMT_NORMALIZE =
+struct
+
+val norm_binder_conv = Conv.try_conv (More_Conv.rewrs_conv [
+ @{lemma "All P == ALL x. P x" by (rule reflexive)},
+ @{lemma "Ex P == EX x. P x" by (rule reflexive)},
+ @{lemma "Let c P == let x = c in P x" by (rule reflexive)}])
+
+fun cert ctxt = Thm.cterm_of (ProofContext.theory_of ctxt)
+
+fun norm_meta_def cv thm =
+ let val thm' = Thm.combination thm (Thm.reflexive cv)
+ in Thm.transitive thm' (Thm.beta_conversion false (Thm.rhs_of thm')) end
+
+fun norm_def ctxt thm =
+ (case Thm.prop_of thm of
+ Const (@{const_name "=="}, _) $ _ $ Abs (_, T, _) =>
+ let val v = Var ((Name.uu, #maxidx (Thm.rep_thm thm) + 1), T)
+ in norm_def ctxt (norm_meta_def (cert ctxt v) thm) end
+ | @{term Trueprop} $ (Const (@{const_name "op ="}, _) $ _ $ Abs _) =>
+ norm_def ctxt (thm RS @{thm fun_cong})
+ | _ => thm)
+
+fun normalize_rule ctxt =
+ Conv.fconv_rule (
+ Thm.beta_conversion true then_conv
+ Thm.eta_conversion then_conv
+ More_Conv.bottom_conv (K norm_binder_conv) ctxt) #>
+ norm_def ctxt #>
+ Drule.forall_intr_vars #>
+ Conv.fconv_rule ObjectLogic.atomize
+
+fun instantiate_free (cv, ct) thm =
+ if Term.exists_subterm (equal (Thm.term_of cv)) (Thm.prop_of thm)
+ then Thm.forall_elim ct (Thm.forall_intr cv thm)
+ else thm
+
+fun discharge_definition ct thm =
+ let val (cv, cu) = Thm.dest_equals ct
+ in
+ Thm.implies_intr ct thm
+ |> instantiate_free (cv, cu)
+ |> (fn thm => Thm.implies_elim thm (Thm.reflexive cu))
+ end
+
+fun if_conv c cv1 cv2 ct = (if c (Thm.term_of ct) then cv1 else cv2) ct
+fun if_true_conv c cv = if_conv c cv Conv.all_conv
+
+
+(* simplification of trivial let expressions (whose bound variables occur at
+ most once) *)
+
+local
+ fun count i (Bound j) = if j = i then 1 else 0
+ | count i (t $ u) = count i t + count i u
+ | count i (Abs (_, _, t)) = count (i + 1) t
+ | count _ _ = 0
+
+ fun is_trivial_let (Const (@{const_name Let}, _) $ _ $ Abs (_, _, t)) =
+ (count 0 t <= 1)
+ | is_trivial_let _ = false
+
+ fun let_conv _ = if_true_conv is_trivial_let (Conv.rewr_conv @{thm Let_def})
+
+ fun cond_let_conv ctxt = if_true_conv (Term.exists_subterm is_trivial_let)
+ (More_Conv.top_conv let_conv ctxt)
+in
+fun trivial_let ctxt = map (Conv.fconv_rule (cond_let_conv ctxt))
+end
+
+
+(* rewriting of negative integer numerals into positive numerals *)
+
+local
+ fun neg_numeral @{term Int.Min} = true
+ | neg_numeral _ = false
+ fun is_number_sort thy T = Sign.of_sort thy (T, @{sort number_ring})
+ fun is_neg_number ctxt (Const (@{const_name number_of}, T) $ t) =
+ Term.exists_subterm neg_numeral t andalso
+ is_number_sort (ProofContext.theory_of ctxt) (Term.body_type T)
+ | is_neg_number _ _ = false
+ fun has_neg_number ctxt = Term.exists_subterm (is_neg_number ctxt)
+
+ val pos_numeral_ss = HOL_ss
+ addsimps [@{thm Int.number_of_minus}, @{thm Int.number_of_Min}]
+ addsimps [@{thm Int.numeral_1_eq_1}]
+ addsimps @{thms Int.pred_bin_simps}
+ addsimps @{thms Int.normalize_bin_simps}
+ addsimps @{lemma
+ "Int.Min = - Int.Bit1 Int.Pls"
+ "Int.Bit0 (- Int.Pls) = - Int.Pls"
+ "Int.Bit0 (- k) = - Int.Bit0 k"
+ "Int.Bit1 (- k) = - Int.Bit1 (Int.pred k)"
+ by simp_all (simp add: pred_def)}
+
+ fun pos_conv ctxt = if_conv (is_neg_number ctxt)
+ (Simplifier.rewrite (Simplifier.context ctxt pos_numeral_ss))
+ Conv.no_conv
+
+ fun cond_pos_conv ctxt = if_true_conv (has_neg_number ctxt)
+ (More_Conv.top_sweep_conv pos_conv ctxt)
+in
+fun positive_numerals ctxt = map (Conv.fconv_rule (cond_pos_conv ctxt))
+end
+
+
+(* embedding of standard natural number operations into integer operations *)
+
+local
+ val nat_embedding = @{lemma
+ "nat (int n) = n"
+ "i >= 0 --> int (nat i) = i"
+ "i < 0 --> int (nat i) = 0"
+ by simp_all}
+
+ val nat_rewriting = @{lemma
+ "0 = nat 0"
+ "1 = nat 1"
+ "number_of i = nat (number_of i)"
+ "int (nat 0) = 0"
+ "int (nat 1) = 1"
+ "a < b = (int a < int b)"
+ "a <= b = (int a <= int b)"
+ "Suc a = nat (int a + 1)"
+ "a + b = nat (int a + int b)"
+ "a - b = nat (int a - int b)"
+ "a * b = nat (int a * int b)"
+ "a div b = nat (int a div int b)"
+ "a mod b = nat (int a mod int b)"
+ "int (nat (int a + int b)) = int a + int b"
+ "int (nat (int a * int b)) = int a * int b"
+ "int (nat (int a div int b)) = int a div int b"
+ "int (nat (int a mod int b)) = int a mod int b"
+ by (simp add: nat_mult_distrib nat_div_distrib nat_mod_distrib
+ int_mult[symmetric] zdiv_int[symmetric] zmod_int[symmetric])+}
+
+ fun on_positive num f x =
+ (case try HOLogic.dest_number (Thm.term_of num) of
+ SOME (_, i) => if i >= 0 then SOME (f x) else NONE
+ | NONE => NONE)
+
+ val cancel_int_nat_ss = HOL_ss
+ addsimps [@{thm Nat_Numeral.nat_number_of}]
+ addsimps [@{thm Nat_Numeral.int_nat_number_of}]
+ addsimps @{thms neg_simps}
+
+ fun cancel_int_nat_simproc _ ss ct =
+ let
+ val num = Thm.dest_arg (Thm.dest_arg ct)
+ val goal = Thm.mk_binop @{cterm "op == :: int => _"} ct num
+ val simpset = Simplifier.inherit_context ss cancel_int_nat_ss
+ fun tac _ = Simplifier.simp_tac simpset 1
+ in on_positive num (Goal.prove_internal [] goal) tac end
+
+ val nat_ss = HOL_ss
+ addsimps nat_rewriting
+ addsimprocs [Simplifier.make_simproc {
+ name = "cancel_int_nat_num", lhss = [@{cpat "int (nat _)"}],
+ proc = cancel_int_nat_simproc, identifier = [] }]
+
+ fun conv ctxt = Simplifier.rewrite (Simplifier.context ctxt nat_ss)
+
+ val uses_nat_type = Term.exists_type (Term.exists_subtype (equal @{typ nat}))
+in
+fun nat_as_int ctxt thms =
+ let
+ fun norm thm uses_nat =
+ if not (uses_nat_type (Thm.prop_of thm)) then (thm, uses_nat)
+ else (Conv.fconv_rule (conv ctxt) thm, true)
+ val (thms', uses_nat) = fold_map norm thms false
+ in if uses_nat then nat_embedding @ thms' else thms' end
+end
+
+
+(* include additional rules *)
+
+val (unfold_defs, unfold_defs_setup) =
+ Attrib.config_bool "smt_unfold_defs" true
+
+local
+ val pair_rules = [@{thm fst_conv}, @{thm snd_conv}, @{thm pair_collapse}]
+
+ val pair_type = (fn Type (@{type_name "*"}, _) => true | _ => false)
+ val exists_pair_type = Term.exists_type (Term.exists_subtype pair_type)
+
+ val fun_upd_rules = [@{thm fun_upd_same}, @{thm fun_upd_apply}]
+ val is_fun_upd = (fn Const (@{const_name fun_upd}, _) => true | _ => false)
+ val exists_fun_upd = Term.exists_subterm is_fun_upd
+in
+fun add_pair_rules _ thms =
+ thms
+ |> exists (exists_pair_type o Thm.prop_of) thms ? append pair_rules
+
+fun add_fun_upd_rules _ thms =
+ thms
+ |> exists (exists_fun_upd o Thm.prop_of) thms ? append fun_upd_rules
+end
+
+
+local
+ fun mk_entry t thm = (Term.head_of t, (thm, thm RS @{thm eq_reflection}))
+ fun prepare_def thm =
+ (case HOLogic.dest_Trueprop (Thm.prop_of thm) of
+ Const (@{const_name "op ="}, _) $ t $ _ => mk_entry t thm
+ | t => raise TERM ("prepare_def", [t]))
+
+ val defs = map prepare_def [
+ @{thm abs_if[where 'a = int]}, @{thm abs_if[where 'a = real]},
+ @{thm min_def[where 'a = int]}, @{thm min_def[where 'a = real]},
+ @{thm max_def[where 'a = int]}, @{thm max_def[where 'a = real]}]
+
+ fun add_sym t = if AList.defined (op =) defs t then insert (op =) t else I
+ fun add_syms thms = fold (Term.fold_aterms add_sym o Thm.prop_of) thms []
+
+ fun unfold_conv ctxt ct =
+ (case AList.lookup (op =) defs (Term.head_of (Thm.term_of ct)) of
+ SOME (_, eq) => Conv.rewr_conv eq
+ | NONE => Conv.all_conv) ct
+in
+fun add_abs_min_max_rules ctxt thms =
+ if Config.get ctxt unfold_defs
+ then map (Conv.fconv_rule (More_Conv.bottom_conv unfold_conv ctxt)) thms
+ else map fst (map_filter (AList.lookup (op =) defs) (add_syms thms)) @ thms
+end
+
+
+(* lift lambda terms into additional rules *)
+
+local
+ val meta_eq = @{cpat "op =="}
+ val meta_eqT = hd (Thm.dest_ctyp (Thm.ctyp_of_term meta_eq))
+ fun inst_meta cT = Thm.instantiate_cterm ([(meta_eqT, cT)], []) meta_eq
+ fun mk_meta_eq ct cu = Thm.mk_binop (inst_meta (Thm.ctyp_of_term ct)) ct cu
+
+ fun lambda_conv conv =
+ let
+ fun sub_conv cvs ctxt ct =
+ (case Thm.term_of ct of
+ Const (@{const_name All}, _) $ Abs _ => quant_conv cvs ctxt
+ | Const (@{const_name Ex}, _) $ Abs _ => quant_conv cvs ctxt
+ | Const _ $ Abs _ => Conv.arg_conv (at_lambda_conv cvs ctxt)
+ | Const (@{const_name Let}, _) $ _ $ Abs _ => Conv.combination_conv
+ (Conv.arg_conv (sub_conv cvs ctxt)) (abs_conv cvs ctxt)
+ | Abs _ => at_lambda_conv cvs ctxt
+ | _ $ _ => Conv.comb_conv (sub_conv cvs ctxt)
+ | _ => Conv.all_conv) ct
+ and abs_conv cvs = Conv.abs_conv (fn (cv, cx) => sub_conv (cv::cvs) cx)
+ and quant_conv cvs ctxt = Conv.arg_conv (abs_conv cvs ctxt)
+ and at_lambda_conv cvs ctxt = abs_conv cvs ctxt then_conv conv cvs ctxt
+ in sub_conv [] end
+
+ fun used_vars cvs ct =
+ let
+ val lookup = AList.lookup (op aconv) (map (` Thm.term_of) cvs)
+ val add = (fn (SOME ct) => insert (op aconvc) ct | _ => I)
+ in Term.fold_aterms (add o lookup) (Thm.term_of ct) [] end
+
+ val rev_int_fst_ord = rev_order o int_ord o pairself fst
+ fun ordered_values tab =
+ Termtab.fold (fn (_, x) => OrdList.insert rev_int_fst_ord x) tab []
+ |> map snd
+in
+fun lift_lambdas ctxt thms =
+ let
+ val declare_frees = fold (Thm.fold_terms Term.declare_term_frees)
+ val names = Unsynchronized.ref (declare_frees thms (Name.make_context []))
+ val fresh_name = Unsynchronized.change_result names o yield_singleton Name.variants
+
+ val defs = Unsynchronized.ref (Termtab.empty : (int * thm) Termtab.table)
+ fun add_def t thm = Unsynchronized.change defs (Termtab.update (t, (serial (), thm)))
+ fun make_def cvs eq = Thm.symmetric (fold norm_meta_def cvs eq)
+ fun def_conv cvs ctxt ct =
+ let
+ val cvs' = used_vars cvs ct
+ val ct' = fold Thm.cabs cvs' ct
+ in
+ (case Termtab.lookup (!defs) (Thm.term_of ct') of
+ SOME (_, eq) => make_def cvs' eq
+ | NONE =>
+ let
+ val {t, T, ...} = Thm.rep_cterm ct'
+ val eq = mk_meta_eq (cert ctxt (Free (fresh_name "", T))) ct'
+ val thm = Thm.assume eq
+ in (add_def t thm; make_def cvs' thm) end)
+ end
+ val thms' = map (Conv.fconv_rule (lambda_conv def_conv ctxt)) thms
+ val eqs = ordered_values (!defs)
+ in
+ (maps (#hyps o Thm.crep_thm) eqs, map (normalize_rule ctxt) eqs @ thms')
+ end
+end
+
+
+(* make application explicit for functions with varying number of arguments *)
+
+local
+ val const = prefix "c" and free = prefix "f"
+ fun min i (e as (_, j)) = if i <> j then (true, Int.min (i, j)) else e
+ fun add t i = Symtab.map_default (t, (false, i)) (min i)
+ fun traverse t =
+ (case Term.strip_comb t of
+ (Const (n, _), ts) => add (const n) (length ts) #> fold traverse ts
+ | (Free (n, _), ts) => add (free n) (length ts) #> fold traverse ts
+ | (Abs (_, _, u), ts) => fold traverse (u :: ts)
+ | (_, ts) => fold traverse ts)
+ val prune = (fn (n, (true, i)) => Symtab.update (n, i) | _ => I)
+ fun prune_tab tab = Symtab.fold prune tab Symtab.empty
+
+ fun binop_conv cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
+ fun nary_conv conv1 conv2 ct =
+ (Conv.combination_conv (nary_conv conv1 conv2) conv2 else_conv conv1) ct
+ fun abs_conv conv tb = Conv.abs_conv (fn (cv, cx) =>
+ let val n = fst (Term.dest_Free (Thm.term_of cv))
+ in conv (Symtab.update (free n, 0) tb) cx end)
+ val apply_rule = @{lemma "f x == apply f x" by (simp add: apply_def)}
+in
+fun explicit_application ctxt thms =
+ let
+ fun sub_conv tb ctxt ct =
+ (case Term.strip_comb (Thm.term_of ct) of
+ (Const (n, _), ts) => app_conv tb (const n) (length ts) ctxt
+ | (Free (n, _), ts) => app_conv tb (free n) (length ts) ctxt
+ | (Abs _, ts) => nary_conv (abs_conv sub_conv tb ctxt) (sub_conv tb ctxt)
+ | (_, ts) => nary_conv Conv.all_conv (sub_conv tb ctxt)) ct
+ and app_conv tb n i ctxt =
+ (case Symtab.lookup tb n of
+ NONE => nary_conv Conv.all_conv (sub_conv tb ctxt)
+ | SOME j => apply_conv tb ctxt (i - j))
+ and apply_conv tb ctxt i ct = (
+ if i = 0 then nary_conv Conv.all_conv (sub_conv tb ctxt)
+ else
+ Conv.rewr_conv apply_rule then_conv
+ binop_conv (apply_conv tb ctxt (i-1)) (sub_conv tb ctxt)) ct
+
+ val tab = prune_tab (fold (traverse o Thm.prop_of) thms Symtab.empty)
+ in map (Conv.fconv_rule (sub_conv tab ctxt)) thms end
+end
+
+
+(* combined normalization *)
+
+datatype config =
+ RewriteTrivialLets |
+ RewriteNegativeNumerals |
+ RewriteNaturalNumbers |
+ AddPairRules |
+ AddFunUpdRules |
+ AddAbsMinMaxRules
+
+fun normalize config ctxt thms =
+ let fun if_enabled c f = member (op =) config c ? f ctxt
+ in
+ thms
+ |> if_enabled RewriteTrivialLets trivial_let
+ |> if_enabled RewriteNegativeNumerals positive_numerals
+ |> if_enabled RewriteNaturalNumbers nat_as_int
+ |> if_enabled AddPairRules add_pair_rules
+ |> if_enabled AddFunUpdRules add_fun_upd_rules
+ |> if_enabled AddAbsMinMaxRules add_abs_min_max_rules
+ |> map (normalize_rule ctxt)
+ |> lift_lambdas ctxt
+ |> apsnd (explicit_application ctxt)
+ end
+
+val setup = unfold_defs_setup
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_solver.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,246 @@
+(* Title: HOL/SMT/Tools/smt_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+SMT solvers registry and SMT tactic.
+*)
+
+signature SMT_SOLVER =
+sig
+ exception SMT_COUNTEREXAMPLE of bool * term list
+
+ datatype interface = Interface of {
+ normalize: SMT_Normalize.config list,
+ translate: SMT_Translate.config }
+
+ datatype proof_data = ProofData of {
+ context: Proof.context,
+ output: string list,
+ recon: SMT_Translate.recon,
+ assms: thm list option }
+
+ datatype solver_config = SolverConfig of {
+ name: {env_var: string, remote_name: string},
+ interface: interface,
+ arguments: string list,
+ reconstruct: proof_data -> thm }
+
+ (*options*)
+ val timeout: int Config.T
+ val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
+ val trace: bool Config.T
+ val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
+
+ (*solvers*)
+ type solver = Proof.context -> thm list -> thm
+ type solver_info = Context.generic -> Pretty.T list
+ val add_solver: string * (Proof.context -> solver_config) -> theory ->
+ theory
+ val all_solver_names_of: theory -> string list
+ val add_solver_info: string * solver_info -> theory -> theory
+ val solver_name_of: Context.generic -> string
+ val select_solver: string -> Context.generic -> Context.generic
+ val solver_of: Context.generic -> solver
+
+ (*tactic*)
+ val smt_tac': bool -> Proof.context -> thm list -> int -> Tactical.tactic
+ val smt_tac: Proof.context -> thm list -> int -> Tactical.tactic
+
+ (*setup*)
+ val setup: theory -> theory
+ val print_setup: Context.generic -> unit
+end
+
+structure SMT_Solver: SMT_SOLVER =
+struct
+
+exception SMT_COUNTEREXAMPLE of bool * term list
+
+
+datatype interface = Interface of {
+ normalize: SMT_Normalize.config list,
+ translate: SMT_Translate.config }
+
+datatype proof_data = ProofData of {
+ context: Proof.context,
+ output: string list,
+ recon: SMT_Translate.recon,
+ assms: thm list option }
+
+datatype solver_config = SolverConfig of {
+ name: {env_var: string, remote_name: string},
+ interface: interface,
+ arguments: string list,
+ reconstruct: proof_data -> thm }
+
+
+(* SMT options *)
+
+val (timeout, setup_timeout) = Attrib.config_int "smt_timeout" 30
+
+fun with_timeout ctxt f x =
+ TimeLimit.timeLimit (Time.fromSeconds (Config.get ctxt timeout)) f x
+ handle TimeLimit.TimeOut => error ("SMT: timeout")
+
+val (trace, setup_trace) = Attrib.config_bool "smt_trace" false
+
+fun trace_msg ctxt f x =
+ if Config.get ctxt trace then Output.tracing (f x) else ()
+
+
+(* interface to external solvers *)
+
+local
+
+fun with_tmp_files f x =
+ let
+ fun tmp_path () = File.tmp_path (Path.explode ("smt-" ^ serial_string ()))
+ val in_path = tmp_path () and out_path = tmp_path ()
+ val y = Exn.capture (f in_path out_path) x
+ val _ = try File.rm in_path and _ = try File.rm out_path
+ in Exn.release y end
+
+fun run in_path out_path (ctxt, cmd, output) =
+ let
+ val x = File.open_output output in_path
+ val _ = trace_msg ctxt File.read in_path
+
+ val _ = with_timeout ctxt system_out (cmd in_path out_path)
+ fun lines_of path = the_default [] (try (File.fold_lines cons out_path) [])
+ val ls = rev (dropwhile (equal "") (lines_of out_path))
+ val _ = trace_msg ctxt cat_lines ls
+ in (x, ls) end
+
+in
+
+fun run_solver ctxt {env_var, remote_name} args output =
+ let
+ val qf = File.shell_path and qq = enclose "'" "'"
+ val path = getenv env_var and remote = getenv "REMOTE_SMT_SOLVER"
+ fun cmd f1 f2 =
+ if path <> ""
+ then map qq (path :: args) @ [qf f1, ">", qf f2]
+ else "perl -w" :: map qq (remote :: remote_name :: args) @ [qf f1, qf f2]
+ in with_tmp_files run (ctxt, space_implode " " oo cmd, output) end
+
+end
+
+fun make_proof_data ctxt ((recon, thms), ls) =
+ ProofData {context=ctxt, output=ls, recon=recon, assms=SOME thms}
+
+fun gen_solver solver ctxt prems =
+ let
+ val SolverConfig {name, interface, arguments, reconstruct} = solver ctxt
+ val Interface {normalize=nc, translate=tc} = interface
+ val thy = ProofContext.theory_of ctxt
+ in
+ SMT_Normalize.normalize nc ctxt prems
+ ||> run_solver ctxt name arguments o SMT_Translate.translate tc thy
+ ||> reconstruct o make_proof_data ctxt
+ |-> fold SMT_Normalize.discharge_definition
+ end
+
+
+(* solver store *)
+
+type solver = Proof.context -> thm list -> thm
+type solver_info = Context.generic -> Pretty.T list
+
+structure Solvers = TheoryDataFun
+(
+ type T = ((Proof.context -> solver_config) * solver_info) Symtab.table
+ val empty = Symtab.empty
+ val copy = I
+ val extend = I
+ fun merge _ = Symtab.merge (K true)
+ handle Symtab.DUP name => error ("Duplicate SMT solver: " ^ quote name)
+)
+
+val no_solver = "(none)"
+val add_solver = Solvers.map o Symtab.update_new o apsnd (rpair (K []))
+val all_solver_names_of = Symtab.keys o Solvers.get
+val lookup_solver = Symtab.lookup o Solvers.get
+fun add_solver_info (n, i) = Solvers.map (Symtab.map_entry n (apsnd (K i)))
+
+
+(* selected solver *)
+
+structure SelectedSolver = GenericDataFun
+(
+ type T = serial * string
+ val empty = (serial (), no_solver)
+ val extend = I
+ fun merge _ (sl1 as (s1, _), sl2 as (s2, _)) = if s1 > s2 then sl1 else sl2
+)
+
+val solver_name_of = snd o SelectedSolver.get
+
+fun select_solver name gen =
+ if is_none (lookup_solver (Context.theory_of gen) name)
+ then error ("SMT solver not registered: " ^ quote name)
+ else SelectedSolver.map (K (serial (), name)) gen
+
+fun raw_solver_of gen =
+ (case lookup_solver (Context.theory_of gen) (solver_name_of gen) of
+ NONE => error "No SMT solver selected"
+ | SOME (s, _) => s)
+
+val solver_of = gen_solver o raw_solver_of
+
+
+(* SMT tactic *)
+
+fun smt_unsat_tac solver ctxt rules =
+ Tactic.rtac @{thm ccontr} THEN'
+ SUBPROOF (fn {context, prems, ...} =>
+ Tactic.rtac (solver context (rules @ prems)) 1) ctxt
+
+fun pretty_counterex ctxt (real, ex) =
+ let
+ val msg = if real then "Counterexample found:"
+ else "Potential counterexample found:"
+ val cex = if null ex then [Pretty.str "(no assignments)"]
+ else map (Syntax.pretty_term ctxt) ex
+ in Pretty.string_of (Pretty.big_list msg cex) end
+
+fun smt_tac' pass_smt_exns ctxt =
+ let
+ val solver = solver_of (Context.Proof ctxt)
+ fun safe_solver ctxt thms = solver ctxt thms
+ handle SMT_COUNTEREXAMPLE cex => error (pretty_counterex ctxt cex)
+ val solver' = if pass_smt_exns then solver else safe_solver
+ in smt_unsat_tac solver' ctxt end
+
+val smt_tac = smt_tac' false
+
+
+(* setup *)
+
+val setup =
+ Attrib.setup (Binding.name "smt_solver")
+ (Scan.lift (OuterParse.$$$ "=" |-- Args.name) >>
+ (Thm.declaration_attribute o K o select_solver))
+ "SMT solver configuration" #>
+ setup_timeout #>
+ setup_trace
+
+fun print_setup gen =
+ let
+ val t = string_of_int (Config.get_generic gen timeout)
+ val names = sort string_ord (all_solver_names_of (Context.theory_of gen))
+ val ns = if null names then [no_solver] else names
+ val take_info = (fn (_, []) => NONE | info => SOME info)
+ val infos =
+ Context.theory_of gen
+ |> Symtab.dest o Solvers.get
+ |> map_filter (fn (n, (_, info)) => take_info (n, info gen))
+ |> sort (prod_ord string_ord (K EQUAL))
+ |> map (fn (n, ps) => Pretty.big_list (n ^ ":") ps)
+ in
+ Pretty.writeln (Pretty.big_list "SMT setup:" [
+ Pretty.str ("Current SMT solver: " ^ solver_name_of gen),
+ Pretty.str_list "Available SMT solvers: " "" ns,
+ Pretty.str ("Current timeout: " ^ t ^ " seconds"),
+ Pretty.big_list "Solver-specific settings:" infos])
+ end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_translate.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,507 @@
+(* Title: HOL/SMT/Tools/smt_translate.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Translate theorems into an SMT intermediate format and serialize them,
+depending on an SMT interface.
+*)
+
+signature SMT_TRANSLATE =
+sig
+ (* intermediate term structure *)
+ datatype sym =
+ SConst of string * typ |
+ SFree of string * typ |
+ SNum of int * typ
+ datatype squant = SForall | SExists
+ datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
+ datatype ('a, 'b) sterm =
+ SVar of int |
+ SApp of 'a * ('a, 'b) sterm list |
+ SLet of (string * 'b) * ('a, 'b) sterm * ('a, 'b) sterm |
+ SQuant of squant * (string * 'b) list * ('a, 'b) sterm spattern list *
+ ('a, 'b) sterm
+
+ (* table for built-in symbols *)
+ type builtin_fun = typ -> (sym, typ) sterm list ->
+ (string * (sym, typ) sterm list) option
+ type builtin_table = (typ * builtin_fun) list Symtab.table
+ val builtin_make: (term * string) list -> builtin_table
+ val builtin_add: term * builtin_fun -> builtin_table -> builtin_table
+ val builtin_lookup: builtin_table -> theory -> string * typ ->
+ (sym, typ) sterm list -> (string * (sym, typ) sterm list) option
+ val bv_rotate: (int -> string) -> builtin_fun
+ val bv_extend: (int -> string) -> builtin_fun
+ val bv_extract: (int -> int -> string) -> builtin_fun
+
+ (* configuration options *)
+ datatype prefixes = Prefixes of {
+ var_prefix: string,
+ typ_prefix: string,
+ fun_prefix: string,
+ pred_prefix: string }
+ datatype markers = Markers of {
+ term_marker: string,
+ formula_marker: string }
+ datatype builtins = Builtins of {
+ builtin_typ: typ -> string option,
+ builtin_num: int * typ -> string option,
+ builtin_fun: bool -> builtin_table }
+ datatype sign = Sign of {
+ typs: string list,
+ funs: (string * (string list * string)) list,
+ preds: (string * string list) list }
+ datatype config = Config of {
+ strict: bool,
+ prefixes: prefixes,
+ markers: markers,
+ builtins: builtins,
+ serialize: sign -> (string, string) sterm list -> TextIO.outstream -> unit}
+ datatype recon = Recon of {typs: typ Symtab.table, terms: term Symtab.table}
+
+ val translate: config -> theory -> thm list -> TextIO.outstream ->
+ recon * thm list
+
+ val dest_binT: typ -> int
+ val dest_funT: int -> typ -> typ list * typ
+end
+
+structure SMT_Translate: SMT_TRANSLATE =
+struct
+
+(* Intermediate term structure *)
+
+datatype sym =
+ SConst of string * typ |
+ SFree of string * typ |
+ SNum of int * typ
+datatype squant = SForall | SExists
+datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
+datatype ('a, 'b) sterm =
+ SVar of int |
+ SApp of 'a * ('a, 'b) sterm list |
+ SLet of (string * 'b) * ('a, 'b) sterm * ('a, 'b) sterm |
+ SQuant of squant * (string * 'b) list * ('a, 'b) sterm spattern list *
+ ('a, 'b) sterm
+
+fun app c ts = SApp (c, ts)
+
+fun map_pat f (SPat ps) = SPat (map f ps)
+ | map_pat f (SNoPat ps) = SNoPat (map f ps)
+
+fun fold_map_pat f (SPat ps) = fold_map f ps #>> SPat
+ | fold_map_pat f (SNoPat ps) = fold_map f ps #>> SNoPat
+
+val make_sconst = SConst o Term.dest_Const
+
+
+(* General type destructors. *)
+
+fun dest_binT T =
+ (case T of
+ Type (@{type_name "Numeral_Type.num0"}, _) => 0
+ | Type (@{type_name "Numeral_Type.num1"}, _) => 1
+ | Type (@{type_name "Numeral_Type.bit0"}, [T]) => 2 * dest_binT T
+ | Type (@{type_name "Numeral_Type.bit1"}, [T]) => 1 + 2 * dest_binT T
+ | _ => raise TYPE ("dest_binT", [T], []))
+
+val dest_wordT = (fn
+ Type (@{type_name "word"}, [T]) => dest_binT T
+ | T => raise TYPE ("dest_wordT", [T], []))
+
+val dest_funT =
+ let
+ fun dest Ts 0 T = (rev Ts, T)
+ | dest Ts i (Type ("fun", [T, U])) = dest (T::Ts) (i-1) U
+ | dest _ _ T = raise TYPE ("dest_funT", [T], [])
+ in dest [] end
+
+
+(* Table for built-in symbols *)
+
+type builtin_fun = typ -> (sym, typ) sterm list ->
+ (string * (sym, typ) sterm list) option
+type builtin_table = (typ * builtin_fun) list Symtab.table
+
+fun builtin_make entries =
+ let
+ fun dest (t, bn) =
+ let val (n, T) = Term.dest_Const t
+ in (n, (Logic.varifyT T, K (SOME o pair bn))) end
+ in Symtab.make (AList.group (op =) (map dest entries)) end
+
+fun builtin_add (t, f) tab =
+ let val (n, T) = apsnd Logic.varifyT (Term.dest_Const t)
+ in Symtab.map_default (n, []) (AList.update (op =) (T, f)) tab end
+
+fun builtin_lookup tab thy (n, T) ts =
+ AList.lookup (Sign.typ_instance thy) (Symtab.lookup_list tab n) T
+ |> (fn SOME f => f T ts | NONE => NONE)
+
+local
+ val dest_nat = (fn
+ SApp (SConst (@{const_name nat}, _), [SApp (SNum (i, _), _)]) => SOME i
+ | _ => NONE)
+in
+fun bv_rotate mk_name T ts =
+ dest_nat (hd ts) |> Option.map (fn i => (mk_name i, tl ts))
+
+fun bv_extend mk_name T ts =
+ (case (try dest_wordT (domain_type T), try dest_wordT (range_type T)) of
+ (SOME i, SOME j) => if j - i >= 0 then SOME (mk_name (j - i), ts) else NONE
+ | _ => NONE)
+
+fun bv_extract mk_name T ts =
+ (case (try dest_wordT (body_type T), dest_nat (hd ts)) of
+ (SOME i, SOME lb) => SOME (mk_name (i + lb - 1) lb, tl ts)
+ | _ => NONE)
+end
+
+
+(* Configuration options *)
+
+datatype prefixes = Prefixes of {
+ var_prefix: string,
+ typ_prefix: string,
+ fun_prefix: string,
+ pred_prefix: string }
+datatype markers = Markers of {
+ term_marker: string,
+ formula_marker: string }
+datatype builtins = Builtins of {
+ builtin_typ: typ -> string option,
+ builtin_num: int * typ -> string option,
+ builtin_fun: bool -> builtin_table }
+datatype sign = Sign of {
+ typs: string list,
+ funs: (string * (string list * string)) list,
+ preds: (string * string list) list }
+datatype config = Config of {
+ strict: bool,
+ prefixes: prefixes,
+ markers: markers,
+ builtins: builtins,
+ serialize: sign -> (string, string) sterm list -> TextIO.outstream -> unit}
+datatype recon = Recon of {typs: typ Symtab.table, terms: term Symtab.table}
+
+
+(* Translate Isabelle/HOL terms into SMT intermediate terms.
+ We assume that lambda-lifting has been performed before, i.e., lambda
+ abstractions occur only at quantifiers and let expressions.
+*)
+local
+ val quantifier = (fn
+ @{const_name All} => SOME SForall
+ | @{const_name Ex} => SOME SExists
+ | _ => NONE)
+
+ fun group_quant qname vs (t as Const (q, _) $ Abs (n, T, u)) =
+ if q = qname then group_quant qname ((n, T) :: vs) u else (vs, t)
+ | group_quant qname vs t = (vs, t)
+
+ fun dest_trigger (@{term trigger} $ tl $ t) = (HOLogic.dest_list tl, t)
+ | dest_trigger t = ([], t)
+
+ fun pat f ps (Const (@{const_name pat}, _) $ p) = SPat (rev (f p :: ps))
+ | pat f ps (Const (@{const_name nopat}, _) $ p) = SNoPat (rev (f p :: ps))
+ | pat f ps (Const (@{const_name andpat}, _) $ p $ t) = pat f (f p :: ps) t
+ | pat _ _ t = raise TERM ("pat", [t])
+
+ fun trans Ts t =
+ (case Term.strip_comb t of
+ (t1 as Const (qn, qT), [t2 as Abs (n, T, t3)]) =>
+ (case quantifier qn of
+ SOME q =>
+ let
+ val (vs, u) = group_quant qn [(n, T)] t3
+ val Us = map snd vs @ Ts
+ val (ps, b) = dest_trigger u
+ in SQuant (q, rev vs, map (pat (trans Us) []) ps, trans Us b) end
+ | NONE => raise TERM ("intermediate", [t]))
+ | (Const (@{const_name Let}, _), [t1, Abs (n, T, t2)]) =>
+ SLet ((n, T), trans Ts t1, trans (T :: Ts) t2)
+ | (Const (c as (@{const_name distinct}, _)), [t1]) =>
+ (* this is not type-correct, but will be corrected at a later stage *)
+ SApp (SConst c, map (trans Ts) (HOLogic.dest_list t1))
+ | (Const c, ts) =>
+ (case try HOLogic.dest_number t of
+ SOME (T, i) => SApp (SNum (i, T), [])
+ | NONE => SApp (SConst c, map (trans Ts) ts))
+ | (Free c, ts) => SApp (SFree c, map (trans Ts) ts)
+ | (Bound i, []) => SVar i
+ | _ => raise TERM ("intermediate", [t]))
+in
+fun intermediate ts = map (trans [] o HOLogic.dest_Trueprop) ts
+end
+
+
+(* Separate formulas from terms by adding special marker symbols ("term",
+ "formula"). Atoms "P" whose head symbol also occurs as function symbol are
+ rewritten to "term P = term True". Connectives and built-in predicates
+ occurring at term level are replaced by new constants, and theorems
+ specifying their meaning are added.
+*)
+local
+ (** Add the marker symbols "term" and "formulas" to separate formulas and
+ terms. **)
+
+ val connectives = map make_sconst [@{term True}, @{term False},
+ @{term Not}, @{term "op &"}, @{term "op |"}, @{term "op -->"},
+ @{term "op = :: bool => _"}]
+
+ fun note false c (ps, fs) = (insert (op =) c ps, fs)
+ | note true c (ps, fs) = (ps, insert (op =) c fs)
+
+ val term_marker = SConst (@{const_name term}, Term.dummyT)
+ val formula_marker = SConst (@{const_name formula}, Term.dummyT)
+ fun mark f true t = f true t #>> app term_marker o single
+ | mark f false t = f false t #>> app formula_marker o single
+ fun mark' f false t = f true t #>> app term_marker o single
+ | mark' f true t = f true t
+ val mark_term = app term_marker o single
+ fun lift_term_marker c ts =
+ let val rem = (fn SApp (SConst (@{const_name term}, _), [t]) => t | t => t)
+ in mark_term (SApp (c, map rem ts)) end
+ fun is_term (SApp (SConst (@{const_name term}, _), _)) = true
+ | is_term _ = false
+
+ fun either x = (fn y as SOME _ => y | _ => x)
+ fun get_loc loc i t =
+ (case t of
+ SVar j => if i = j then SOME loc else NONE
+ | SApp (SConst (@{const_name term}, _), us) => get_locs true i us
+ | SApp (SConst (@{const_name formula}, _), us) => get_locs false i us
+ | SApp (_, us) => get_locs loc i us
+ | SLet (_, u1, u2) => either (get_loc true i u1) (get_loc loc (i+1) u2)
+ | SQuant (_, vs, _, u) => get_loc loc (i + length vs) u)
+ and get_locs loc i ts = fold (either o get_loc loc i) ts NONE
+
+ fun sep loc t =
+ (case t of
+ SVar i => pair t
+ | SApp (c as SConst (@{const_name If}, _), u :: us) =>
+ mark sep false u ##>> fold_map (sep loc) us #>> app c o (op ::)
+ | SApp (c, us) =>
+ if not loc andalso member (op =) connectives c
+ then fold_map (sep loc) us #>> app c
+ else note loc c #> fold_map (mark' sep loc) us #>> app c
+ | SLet (v, u1, u2) =>
+ sep loc u2 #-> (fn u2' =>
+ mark sep (the (get_loc loc 0 u2')) u1 #>> (fn u1' =>
+ SLet (v, u1', u2')))
+ | SQuant (q, vs, ps, u) =>
+ fold_map (fold_map_pat (mark sep true)) ps ##>>
+ sep loc u #>> (fn (ps', u') =>
+ SQuant (q, vs, ps', u')))
+
+ (** Rewrite atoms. **)
+
+ val unterm_rule = @{lemma "term x == x" by (simp add: term_def)}
+ val unterm_conv = More_Conv.top_sweep_conv (K (Conv.rewr_conv unterm_rule))
+
+ val dest_word_type = (fn Type (@{type_name word}, [T]) => T | T => T)
+ fun instantiate [] _ = I
+ | instantiate (v :: _) T =
+ Term.subst_TVars [(v, dest_word_type (Term.domain_type T))]
+
+ fun dest_alls (Const (@{const_name All}, _) $ Abs (_, _, t)) = dest_alls t
+ | dest_alls t = t
+ val dest_iff = (fn (Const (@{const_name iff}, _) $ t $ _ ) => t | t => t)
+ val dest_eq = (fn (Const (@{const_name "op ="}, _) $ t $ _ ) => t | t => t)
+ val dest_not = (fn (@{term Not} $ t) => t | t => t)
+ val head_of = HOLogic.dest_Trueprop #> dest_alls #> dest_iff #> dest_not #>
+ dest_eq #> Term.head_of
+
+ fun prepare ctxt thm =
+ let
+ val rule = Conv.fconv_rule (unterm_conv ctxt) thm
+ val prop = Thm.prop_of thm
+ val inst = instantiate (Term.add_tvar_names prop [])
+ fun inst_for T = (singleton intermediate (inst T prop), rule)
+ in (make_sconst (head_of (Thm.prop_of rule)), inst_for) end
+
+ val logicals = map (prepare @{context})
+ @{lemma
+ "~ holds False"
+ "ALL p. holds (~ p) iff (~ holds p)"
+ "ALL p q. holds (p & q) iff (holds p & holds q)"
+ "ALL p q. holds (p | q) iff (holds p | holds q)"
+ "ALL p q. holds (p --> q) iff (holds p --> holds q)"
+ "ALL p q. holds (p iff q) iff (holds p iff holds q)"
+ "ALL p q. holds (p = q) iff (p = q)"
+ "ALL (a::int) b. holds (a < b) iff (a < b)"
+ "ALL (a::int) b. holds (a <= b) iff (a <= b)"
+ "ALL (a::real) b. holds (a < b) iff (a < b)"
+ "ALL (a::real) b. holds (a <= b) iff (a <= b)"
+ "ALL (a::'a::len0 word) b. holds (a < b) iff (a < b)"
+ "ALL (a::'a::len0 word) b. holds (a <= b) iff (a <= b)"
+ "ALL a b. holds (a <s b) iff (a <s b)"
+ "ALL a b. holds (a <=s b) iff (a <=s b)"
+ by (simp_all add: term_def iff_def)}
+
+ fun is_instance thy (SConst (n, T), SConst (m, U)) =
+ (n = m) andalso Sign.typ_instance thy (T, U)
+ | is_instance _ _ = false
+
+ fun lookup_logical thy (c as SConst (_, T)) =
+ AList.lookup (is_instance thy) logicals c
+ |> Option.map (fn inst_for => inst_for T)
+ | lookup_logical _ _ = NONE
+
+ val s_eq = make_sconst @{term "op = :: bool => _"}
+ val s_True = mark_term (SApp (make_sconst @{term True}, []))
+ fun holds (SApp (c, ts)) = SApp (s_eq, [lift_term_marker c ts, s_True])
+ | holds t = SApp (s_eq, [mark_term t, s_True])
+
+ val rewr_iff = (fn
+ SConst (@{const_name "op ="}, T as @{typ "bool => bool => bool"}) =>
+ SConst (@{const_name iff}, T)
+ | c => c)
+
+ fun rewrite ls =
+ let
+ fun rewr env loc t =
+ (case t of
+ SVar i => if not loc andalso nth env i then holds t else t
+ | SApp (c as SConst (@{const_name term}, _), [u]) =>
+ SApp (c, [rewr env true u])
+ | SApp (c as SConst (@{const_name formula}, _), [u]) =>
+ SApp (c, [rewr env false u])
+ | SApp (c, us) =>
+ let val f = if not loc andalso member (op =) ls c then holds else I
+ in f (SApp (rewr_iff c, map (rewr env loc) us)) end
+ | SLet (v, u1, u2) =>
+ SLet (v, rewr env loc u1, rewr (is_term u1 :: env) loc u2)
+ | SQuant (q, vs, ps, u) =>
+ let val e = replicate (length vs) true @ env
+ in SQuant (q, vs, map (map_pat (rewr e loc)) ps, rewr e loc u) end)
+ in map (rewr [] false) end
+in
+fun separate thy ts =
+ let
+ val (ts', (ps, fs)) = fold_map (sep false) ts ([], [])
+ val eq_name = (fn
+ (SConst (n, _), SConst (m, _)) => n = m
+ | (SFree (n, _), SFree (m, _)) => n = m
+ | _ => false)
+ val ls = filter (member eq_name fs) ps
+ val (us, thms) = split_list (map_filter (lookup_logical thy) fs)
+ in (thms, us @ rewrite ls ts') end
+end
+
+
+(* Collect the signature of intermediate terms, identify built-in symbols,
+ rename uninterpreted symbols and types, make bound variables unique.
+ We require @{term distinct} to be a built-in constant of the SMT solver.
+*)
+local
+ fun empty_nctxt p = (p, 1)
+ fun make_nctxt (pT, pf, pp) = (empty_nctxt pT, empty_nctxt (pf, pp))
+ fun fresh_name (p, i) = (p ^ string_of_int i, (p, i+1))
+ fun fresh_typ (nT, nfp) = fresh_name nT ||> (fn nT' => (nT', nfp))
+ fun fresh_fun loc (nT, ((pf, pp), i)) =
+ let val p = if loc then pf else pp
+ in fresh_name (p, i) ||> (fn (_, i') => (nT, ((pf, pp), i'))) end
+
+ val empty_sign = (Typtab.empty, Termtab.empty, Termtab.empty)
+ fun lookup_typ (typs, _, _) = Typtab.lookup typs
+ fun lookup_fun true (_, funs, _) = Termtab.lookup funs
+ | lookup_fun false (_, _, preds) = Termtab.lookup preds
+ fun add_typ x (typs, funs, preds) = (Typtab.update x typs, funs, preds)
+ fun add_fun true x (typs, funs, preds) = (typs, Termtab.update x funs, preds)
+ | add_fun false x (typs, funs, preds) = (typs, funs, Termtab.update x preds)
+ fun make_sign (typs, funs, preds) = Sign {
+ typs = map snd (Typtab.dest typs),
+ funs = map snd (Termtab.dest funs),
+ preds = map (apsnd fst o snd) (Termtab.dest preds) }
+ fun make_rtab (typs, funs, preds) =
+ let
+ val rTs = Typtab.dest typs |> map swap |> Symtab.make
+ val rts = Termtab.dest funs @ Termtab.dest preds
+ |> map (apfst fst o swap) |> Symtab.make
+ in Recon {typs=rTs, terms=rts} end
+
+ fun either f g x = (case f x of NONE => g x | y => y)
+
+ fun rep_typ (Builtins {builtin_typ, ...}) T (st as (vars, ns, sgn)) =
+ (case either builtin_typ (lookup_typ sgn) T of
+ SOME n => (n, st)
+ | NONE =>
+ let val (n, ns') = fresh_typ ns
+ in (n, (vars, ns', add_typ (T, n) sgn)) end)
+
+ fun rep_var bs (n, T) (vars, ns, sgn) =
+ let val (n', vars') = fresh_name vars
+ in (vars', ns, sgn) |> rep_typ bs T |>> pair n' end
+
+ fun rep_fun bs loc t T i (st as (_, _, sgn0)) =
+ (case lookup_fun loc sgn0 t of
+ SOME (n, _) => (n, st)
+ | NONE =>
+ let
+ val (Us, U) = dest_funT i T
+ val (uns, (vars, ns, sgn)) =
+ st |> fold_map (rep_typ bs) Us ||>> rep_typ bs U
+ val (n, ns') = fresh_fun loc ns
+ in (n, (vars, ns', add_fun loc (t, (n, uns)) sgn)) end)
+
+ fun rep_num (bs as Builtins {builtin_num, ...}) (i, T) st =
+ (case builtin_num (i, T) of
+ SOME n => (n, st)
+ | NONE => rep_fun bs true (HOLogic.mk_number T i) T 0 st)
+in
+fun signature_of prefixes markers builtins thy ts =
+ let
+ val Prefixes {var_prefix, typ_prefix, fun_prefix, pred_prefix} = prefixes
+ val Markers {formula_marker, term_marker} = markers
+ val Builtins {builtin_fun, ...} = builtins
+
+ fun sign loc t =
+ (case t of
+ SVar i => pair (SVar i)
+ | SApp (c as SConst (@{const_name term}, _), [u]) =>
+ sign true u #>> app term_marker o single
+ | SApp (c as SConst (@{const_name formula}, _), [u]) =>
+ sign false u #>> app formula_marker o single
+ | SApp (SConst (c as (_, T)), ts) =>
+ (case builtin_lookup (builtin_fun loc) thy c ts of
+ SOME (n, ts') => fold_map (sign loc) ts' #>> app n
+ | NONE =>
+ rep_fun builtins loc (Const c) T (length ts) ##>>
+ fold_map (sign loc) ts #>> SApp)
+ | SApp (SFree (c as (_, T)), ts) =>
+ rep_fun builtins loc (Free c) T (length ts) ##>>
+ fold_map (sign loc) ts #>> SApp
+ | SApp (SNum n, _) => rep_num builtins n #>> (fn n => SApp (n, []))
+ | SLet (v, u1, u2) =>
+ rep_var builtins v #-> (fn v' =>
+ sign loc u1 ##>> sign loc u2 #>> (fn (u1', u2') =>
+ SLet (v', u1', u2')))
+ | SQuant (q, vs, ps, u) =>
+ fold_map (rep_var builtins) vs ##>>
+ fold_map (fold_map_pat (sign loc)) ps ##>>
+ sign loc u #>> (fn ((vs', ps'), u') =>
+ SQuant (q, vs', ps', u')))
+ in
+ (empty_nctxt var_prefix, make_nctxt (typ_prefix, fun_prefix, pred_prefix),
+ empty_sign)
+ |> fold_map (sign false) ts
+ |> (fn (us, (_, _, sgn)) => (make_rtab sgn, (make_sign sgn, us)))
+ end
+end
+
+
+(* Combination of all translation functions and invocation of serialization. *)
+
+fun translate config thy thms stream =
+ let val Config {strict, prefixes, markers, builtins, serialize} = config
+ in
+ map Thm.prop_of thms
+ |> SMT_Monomorph.monomorph thy
+ |> intermediate
+ |> (if strict then separate thy else pair [])
+ ||>> signature_of prefixes markers builtins thy
+ ||> (fn (sgn, ts) => serialize sgn ts stream)
+ |> (fn ((thms', rtab), _) => (rtab, thms' @ thms))
+ end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smtlib_interface.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,168 @@
+(* Title: HOL/SMT/Tools/smtlib_interface.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface to SMT solvers based on the SMT-LIB format.
+*)
+
+signature SMTLIB_INTERFACE =
+sig
+ val basic_builtins: SMT_Translate.builtins
+ val default_attributes: string list
+ val gen_interface: SMT_Translate.builtins -> string list ->
+ SMT_Solver.interface
+ val interface: SMT_Solver.interface
+end
+
+structure SMTLIB_Interface: SMTLIB_INTERFACE =
+struct
+
+structure T = SMT_Translate
+
+
+(* built-in types, functions and predicates *)
+
+val builtin_typ = (fn
+ @{typ int} => SOME "Int"
+ | @{typ real} => SOME "Real"
+ | _ => NONE)
+
+val builtin_num = (fn
+ (i, @{typ int}) => SOME (string_of_int i)
+ | (i, @{typ real}) => SOME (string_of_int i ^ ".0")
+ | _ => NONE)
+
+val builtin_funcs = T.builtin_make [
+ (@{term If}, "ite"),
+ (@{term "uminus :: int => _"}, "~"),
+ (@{term "plus :: int => _"}, "+"),
+ (@{term "minus :: int => _"}, "-"),
+ (@{term "times :: int => _"}, "*"),
+ (@{term "uminus :: real => _"}, "~"),
+ (@{term "plus :: real => _"}, "+"),
+ (@{term "minus :: real => _"}, "-"),
+ (@{term "times :: real => _"}, "*") ]
+
+val builtin_preds = T.builtin_make [
+ (@{term True}, "true"),
+ (@{term False}, "false"),
+ (@{term Not}, "not"),
+ (@{term "op &"}, "and"),
+ (@{term "op |"}, "or"),
+ (@{term "op -->"}, "implies"),
+ (@{term "op iff"}, "iff"),
+ (@{term If}, "if_then_else"),
+ (@{term distinct}, "distinct"),
+ (@{term "op ="}, "="),
+ (@{term "op < :: int => _"}, "<"),
+ (@{term "op <= :: int => _"}, "<="),
+ (@{term "op < :: real => _"}, "<"),
+ (@{term "op <= :: real => _"}, "<=") ]
+
+
+(* serialization *)
+
+fun wr s stream = (TextIO.output (stream, s); stream)
+fun wr_line f = f #> wr "\n"
+
+fun sep f = wr " " #> f
+fun par f = sep (wr "(" #> f #> wr ")")
+
+fun wr1 s = sep (wr s)
+fun wrn f n = (fn [] => wr1 n | ts => par (wr n #> fold f ts))
+fun ins s f = (fn [] => I | x::xs => f x #> fold (fn x => wr1 s #> f x) xs)
+
+val term_marker = "__term"
+val formula_marker = "__form"
+fun dest_marker (T.SApp ("__term", [t])) = SOME (true, t)
+ | dest_marker (T.SApp ("__form", [t])) = SOME (false, t)
+ | dest_marker _ = NONE
+
+val tvar = prefix "?"
+val fvar = prefix "$"
+
+fun wr_expr loc env t =
+ (case t of
+ T.SVar i => wr1 (nth env i)
+ | T.SApp (n, ts) =>
+ (case dest_marker t of
+ SOME (loc', t') => wr_expr loc' env t'
+ | NONE => wrn (wr_expr loc env) n ts)
+ | T.SLet ((v, _), t1, t2) =>
+ if loc then raise TERM ("SMTLIB: let expression in term", [])
+ else
+ let
+ val (loc', t1') = the (dest_marker t1)
+ val (kind, v') = if loc' then ("let", tvar v) else ("flet", fvar v)
+ in
+ par (wr kind #> par (wr v' #> wr_expr loc' env t1') #>
+ wr_expr loc (v' :: env) t2)
+ end
+ | T.SQuant (q, vs, ps, b) =>
+ let
+ val wr_quant = wr o (fn T.SForall => "forall" | T.SExists => "exists")
+ fun wr_var (n, s) = par (wr (tvar n) #> wr1 s)
+
+ val wre = wr_expr loc (map (tvar o fst) (rev vs) @ env)
+
+ fun wrp s ts = wr1 (":" ^ s ^ "{") #> ins "," wre ts #> wr1 "}"
+ fun wr_pat (T.SPat ts) = wrp "pat" ts
+ | 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 (T.Sign {typs, funs, preds}) ts stream =
+ let
+ fun wr_decl (n, Ts) = wr_line (sep (par (wr n #> fold wr1 Ts)))
+ in
+ stream
+ |> wr_line (wr "(benchmark Isabelle")
+ |> fold (wr_line o wr) attributes
+ |> length typs > 0 ?
+ wr_line (wr ":extrasorts" #> par (fold wr1 typs))
+ |> length funs > 0 ? (
+ wr_line (wr ":extrafuns (") #>
+ fold (wr_decl o apsnd (fn (Ts, T) => Ts @ [T])) funs #>
+ wr_line (wr " )"))
+ |> length preds > 0 ? (
+ wr_line (wr ":extrapreds (") #>
+ fold wr_decl preds #>
+ wr_line (wr " )"))
+ |> fold (fn t => wr ":assumption" #> wr_line (wr_expr false [] t)) ts
+ |> wr_line (wr ":formula true")
+ |> wr_line (wr ")")
+ |> K ()
+ end
+
+
+(* SMT solver interface using the SMT-LIB input format *)
+
+val basic_builtins = T.Builtins {
+ builtin_typ = builtin_typ,
+ builtin_num = builtin_num,
+ builtin_fun = (fn true => builtin_funcs | false => builtin_preds) }
+
+val default_attributes = [":logic AUFLIRA", ":status unknown"]
+
+fun gen_interface builtins attributes = SMT_Solver.Interface {
+ normalize = [
+ SMT_Normalize.RewriteTrivialLets,
+ SMT_Normalize.RewriteNegativeNumerals,
+ SMT_Normalize.RewriteNaturalNumbers,
+ SMT_Normalize.AddAbsMinMaxRules,
+ SMT_Normalize.AddPairRules,
+ SMT_Normalize.AddFunUpdRules ],
+ translate = T.Config {
+ strict = true,
+ prefixes = T.Prefixes {
+ var_prefix = "x",
+ typ_prefix = "T",
+ fun_prefix = "uf_",
+ pred_prefix = "up_" },
+ markers = T.Markers {
+ term_marker = term_marker,
+ formula_marker = formula_marker },
+ builtins = builtins,
+ serialize = serialize attributes }}
+
+val interface = gen_interface basic_builtins default_attributes
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/yices_solver.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,52 @@
+(* Title: HOL/SMT/Tools/yices_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver Yices.
+*)
+
+signature YICES_SOLVER =
+sig
+ val setup: theory -> theory
+end
+
+structure Yices_Solver: YICES_SOLVER =
+struct
+
+val solver_name = "yices"
+val env_var = "YICES_SOLVER"
+
+val options = ["--evidence", "--smtlib"]
+
+fun cex_kind true = "Counterexample"
+ | cex_kind false = "Possible counterexample"
+
+fun raise_cex real ctxt rtab ls =
+ let val p = Pretty.big_list (cex_kind real ^ " found:") (map Pretty.str ls)
+ in error (Pretty.string_of p) end
+
+structure S = SMT_Solver
+
+fun core_oracle (SMT_Solver.ProofData {context, output, recon, ...}) =
+ let
+ val empty_line = (fn "" => true | _ => false)
+ val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
+ val (l, ls) = split_first (dropwhile empty_line output)
+ in
+ if String.isPrefix "unsat" l then @{cprop False}
+ else if String.isPrefix "sat" l then raise_cex true context recon ls
+ else if String.isPrefix "unknown" l then raise_cex false context recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun smtlib_solver oracle _ =
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = SMTLIB_Interface.interface,
+ arguments = options,
+ reconstruct = oracle }
+
+val setup =
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, smtlib_solver oracle))
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_interface.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,98 @@
+(* Title: HOL/SMT/Tools/z3_interface.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface to Z3 based on a relaxed version of SMT-LIB.
+*)
+
+signature Z3_INTERFACE =
+sig
+ val interface: SMT_Solver.interface
+end
+
+structure Z3_Interface: Z3_INTERFACE =
+struct
+
+structure T = SMT_Translate
+
+fun mk_name1 n i = n ^ "[" ^ string_of_int i ^ "]"
+fun mk_name2 n i j = n ^ "[" ^ string_of_int i ^ ":" ^ string_of_int j ^ "]"
+
+val builtin_typ = (fn
+ @{typ int} => SOME "Int"
+ | @{typ real} => SOME "Real"
+ | Type (@{type_name word}, [T]) =>
+ Option.map (mk_name1 "BitVec") (try T.dest_binT T)
+ | _ => NONE)
+
+val builtin_num = (fn
+ (i, @{typ int}) => SOME (string_of_int i)
+ | (i, @{typ real}) => SOME (string_of_int i ^ ".0")
+ | (i, Type (@{type_name word}, [T])) =>
+ Option.map (mk_name1 ("bv" ^ string_of_int i)) (try T.dest_binT T)
+ | _ => NONE)
+
+val builtin_funcs = T.builtin_make [
+ (@{term If}, "ite"),
+ (@{term "uminus :: int => _"}, "~"),
+ (@{term "plus :: int => _"}, "+"),
+ (@{term "minus :: int => _"}, "-"),
+ (@{term "times :: int => _"}, "*"),
+ (@{term "op div :: int => _"}, "div"),
+ (@{term "op mod :: int => _"}, "mod"),
+ (@{term "op rem"}, "rem"),
+ (@{term "uminus :: real => _"}, "~"),
+ (@{term "plus :: real => _"}, "+"),
+ (@{term "minus :: real => _"}, "-"),
+ (@{term "times :: real => _"}, "*"),
+ (@{term "op / :: real => _"}, "/"),
+ (@{term "bitNOT :: 'a::len0 word => _"}, "bvnot"),
+ (@{term "op AND :: 'a::len0 word => _"}, "bvand"),
+ (@{term "op OR :: 'a::len0 word => _"}, "bvor"),
+ (@{term "op XOR :: 'a::len0 word => _"}, "bvxor"),
+ (@{term "uminus :: 'a::len0 word => _"}, "bvneg"),
+ (@{term "op + :: 'a::len0 word => _"}, "bvadd"),
+ (@{term "op - :: 'a::len0 word => _"}, "bvsub"),
+ (@{term "op * :: 'a::len0 word => _"}, "bvmul"),
+ (@{term "op div :: 'a::len0 word => _"}, "bvudiv"),
+ (@{term "op mod :: 'a::len0 word => _"}, "bvurem"),
+ (@{term "op sdiv"}, "bvsdiv"),
+ (@{term "op smod"}, "bvsmod"),
+ (@{term "op srem"}, "bvsrem"),
+ (@{term word_cat}, "concat"),
+ (@{term bv_shl}, "bvshl"),
+ (@{term bv_lshr}, "bvlshr"),
+ (@{term bv_ashr}, "bvashr")]
+ |> T.builtin_add (@{term slice}, T.bv_extract (mk_name2 "extract"))
+ |> T.builtin_add (@{term ucast}, T.bv_extend (mk_name1 "zero_extend"))
+ |> T.builtin_add (@{term scast}, T.bv_extend (mk_name1 "sign_extend"))
+ |> T.builtin_add (@{term word_rotl}, T.bv_rotate (mk_name1 "rotate_left"))
+ |> T.builtin_add (@{term word_rotr}, T.bv_rotate (mk_name1 "rotate_right"))
+
+val builtin_preds = T.builtin_make [
+ (@{term True}, "true"),
+ (@{term False}, "false"),
+ (@{term Not}, "not"),
+ (@{term "op &"}, "and"),
+ (@{term "op |"}, "or"),
+ (@{term "op -->"}, "implies"),
+ (@{term "op iff"}, "iff"),
+ (@{term If}, "if_then_else"),
+ (@{term distinct}, "distinct"),
+ (@{term "op ="}, "="),
+ (@{term "op < :: int => _"}, "<"),
+ (@{term "op <= :: int => _"}, "<="),
+ (@{term "op < :: real => _"}, "<"),
+ (@{term "op <= :: real => _"}, "<="),
+ (@{term "op < :: 'a::len0 word => _"}, "bvult"),
+ (@{term "op <= :: 'a::len0 word => _"}, "bvule"),
+ (@{term word_sless}, "bvslt"),
+ (@{term word_sle}, "bvsle")]
+
+val builtins = T.Builtins {
+ builtin_typ = builtin_typ,
+ builtin_num = builtin_num,
+ builtin_fun = (fn true => builtin_funcs | false => builtin_preds) }
+
+val interface = SMTLIB_Interface.gen_interface builtins []
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_model.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,159 @@
+(* Title: HOL/SMT/Tools/z3_model.ML
+ Author: Sascha Boehme and Philipp Meyer, TU Muenchen
+
+Parser for counterexamples generated by Z3.
+*)
+
+signature Z3_MODEL =
+sig
+ val parse_counterex: SMT_Translate.recon -> string list -> term list
+end
+
+structure Z3_Model: Z3_MODEL =
+struct
+
+(* parsing primitives *)
+
+fun lift f (x, y) = apsnd (pair x) (f y)
+fun lift' f v (x, y) = apsnd (rpair y) (f v x)
+
+fun $$ s = lift (Scan.$$ s)
+fun this s = lift (Scan.this_string s)
+
+fun par scan = $$ "(" |-- scan --| $$ ")"
+
+val digit = (fn
+ "0" => SOME 0 | "1" => SOME 1 | "2" => SOME 2 | "3" => SOME 3 |
+ "4" => SOME 4 | "5" => SOME 5 | "6" => SOME 6 | "7" => SOME 7 |
+ "8" => SOME 8 | "9" => SOME 9 | _ => NONE)
+
+val nat_num = Scan.repeat1 (Scan.some digit) >>
+ (fn ds => fold (fn d => fn i => i * 10 + d) ds 0)
+val int_num = Scan.optional (Scan.$$ "-" >> K (fn i => ~i)) I :|--
+ (fn sign => nat_num >> sign)
+
+val is_char = Symbol.is_ascii_letter orf Symbol.is_ascii_digit orf
+ member (op =) (explode "_+*-/%~=<>$&|?!.@^#")
+val name = Scan.many1 is_char >> implode
+
+
+(* parsing counterexamples *)
+
+datatype context = Context of {
+ ttab: term Symtab.table,
+ nctxt: Name.context,
+ vtab: term Inttab.table }
+
+fun make_context (ttab, nctxt, vtab) =
+ Context {ttab=ttab, nctxt=nctxt, vtab=vtab}
+
+fun empty_context (SMT_Translate.Recon {terms, ...}) =
+ let
+ val ns = Symtab.fold (Term.add_free_names o snd) terms []
+ val nctxt = Name.make_context ns
+ in make_context (terms, nctxt, Inttab.empty) end
+
+fun map_context f (Context {ttab, nctxt, vtab}) =
+ make_context (f (ttab, nctxt, vtab))
+
+fun fresh_name (cx as Context {nctxt, ...}) =
+ let val (n, nctxt') = yield_singleton Name.variants "" nctxt
+ in (n, map_context (fn (ttab, _, vtab) => (ttab, nctxt', vtab)) cx) end
+
+fun ident name (cx as Context {ttab, ...}) =
+ (case Symtab.lookup ttab name of
+ SOME t => (t, cx)
+ | NONE =>
+ let val (n, cx') = fresh_name cx
+ in (Free (n, Term.dummyT), cx) end)
+
+fun set_value t i = map_context (fn (ttab, nctxt, vtab) =>
+ (ttab, nctxt, Inttab.update (i, t) vtab))
+
+fun get_value T i (cx as Context {vtab, ...}) =
+ (case Inttab.lookup vtab i of
+ SOME t => (t, cx)
+ | _ => cx |> fresh_name |-> (fn n =>
+ let val t = Free (n, T)
+ in set_value t i #> pair t end))
+
+
+fun space s = lift (Scan.many Symbol.is_ascii_blank) s
+fun spaced p = p --| space
+
+val key = spaced (lift name) #-> lift' ident
+val mapping = spaced (this "->")
+fun in_braces p = spaced ($$ "{") |-- p --| spaced ($$ "}")
+
+val bool_expr =
+ this "true" >> K @{term True} ||
+ this "false" >> K @{term False}
+
+fun number_expr T =
+ let
+ val num = lift int_num >> HOLogic.mk_number T
+ fun frac n d = Const (@{const_name divide}, T --> T --> T) $ n $ d
+ in num :|-- (fn n => Scan.optional ($$ "/" |-- num >> frac n) n) end
+
+val value = this "val!" |-- lift nat_num
+fun value_expr T = value #-> lift' (get_value T)
+
+val domT = Term.domain_type
+val ranT = Term.range_type
+fun const_array T t = Abs ("x", T, t)
+fun upd_array T ((a, t), u) =
+ Const (@{const_name fun_upd}, [T, domT T, ranT T] ---> T) $ a $ t $ u
+fun array_expr T st = if not (can domT T) then Scan.fail st else st |> (
+ par (spaced (this "const") |-- expr (ranT T)) >> const_array (domT T) ||
+ par (spaced (this "store") |-- spaced (array_expr T) --
+ expr (Term.domain_type T) -- expr (Term.range_type T)) >> upd_array T)
+
+and expr T st =
+ spaced (bool_expr || number_expr T || value_expr T || array_expr T) st
+
+fun const_val t =
+ let fun rep u = spaced value #-> apfst o set_value u #> pair []
+ in
+ if can HOLogic.dest_number t then rep t
+ else if t = @{term TT} then rep @{term True}
+ else expr (Term.fastype_of t) >> (fn u => [HOLogic.mk_eq (t, u)])
+ end
+
+fun func_value T = mapping |-- expr T
+
+fun first_pat T =
+ let
+ fun args T = if not (can domT T) then Scan.succeed [] else
+ expr (domT T) ::: args (ranT T)
+ fun value ts = func_value (snd (SMT_Translate.dest_funT (length ts) T))
+ in args T :-- value end
+
+fun func_pat (Ts, T) = fold_map expr Ts -- func_value T
+fun else_pat (Ts, T) =
+ let fun else_arg T cx = cx |> fresh_name |>> (fn n => Free (n, T))
+ in
+ fold_map (lift' else_arg) Ts ##>>
+ spaced (this "else") |-- func_value T
+ end
+fun next_pats T (fts as (ts, _)) =
+ let val Tps = SMT_Translate.dest_funT (length ts) T
+ in Scan.repeat (func_pat Tps) @@@ (else_pat Tps >> single) >> cons fts end
+
+fun mk_def' f (ts, t) = HOLogic.mk_eq (Term.list_comb (f, ts), t)
+fun mk_def (Const (@{const_name apply}, _)) (u :: us, t) = mk_def' u (us, t)
+ | mk_def f (ts, t) = mk_def' f (ts, t)
+fun func_pats t =
+ let val T = Term.fastype_of t
+ in first_pat T :|-- next_pats T >> map (mk_def t) end
+
+val assign =
+ key --| mapping :|-- (fn t => in_braces (func_pats t) || const_val t)
+
+val cex = space |-- Scan.repeat assign
+
+fun parse_counterex recon ls =
+ (empty_context recon, explode (cat_lines ls))
+ |> Scan.catch (Scan.finite' Symbol.stopper (Scan.error cex))
+ |> flat o fst
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_solver.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,83 @@
+(* Title: HOL/SMT/Tools/z3_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver Z3.
+*)
+
+signature Z3_SOLVER =
+sig
+ val proofs: bool Config.T
+ val options: string Config.T
+
+ val setup: theory -> theory
+end
+
+structure Z3_Solver: Z3_SOLVER =
+struct
+
+val solver_name = "z3"
+val env_var = "Z3_SOLVER"
+
+val (proofs, proofs_setup) = Attrib.config_bool "z3_proofs" false
+val (options, options_setup) = Attrib.config_string "z3_options" ""
+
+fun add xs ys = ys @ xs
+
+fun get_options ctxt =
+ ["MODEL=true", "PRE_SIMPLIFY_EXPR=false", "CONTEXT_SIMPLIFIER=false"]
+ |> Config.get ctxt proofs ? add ["DISPLAY_PROOF=true", "PROOF_MODE=2"]
+ |> add (space_explode " " (Config.get ctxt options))
+
+fun pretty_config context = [
+ Pretty.str ("With proofs: " ^
+ (if Config.get_generic context proofs then "true" else "false")),
+ Pretty.str ("Options: " ^
+ space_implode " " (get_options (Context.proof_of context))) ]
+
+fun cmdline_options ctxt =
+ get_options ctxt
+ |> add ["-smt"]
+
+fun raise_cex real recon ls =
+ let val cex = Z3_Model.parse_counterex recon ls
+ in raise SMT_Solver.SMT_COUNTEREXAMPLE (real, cex) end
+
+fun check_unsat recon output =
+ let
+ val raw = not o String.isPrefix "WARNING" orf String.isPrefix "ERROR"
+ val (ls, l) = the_default ([], "") (try split_last (filter raw output))
+ in
+ if String.isPrefix "unsat" l then ls
+ else if String.isPrefix "sat" l then raise_cex true recon ls
+ else if String.isPrefix "unknown" l then raise_cex false recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun core_oracle (SMT_Solver.ProofData {output, recon, ...}) =
+ check_unsat recon output
+ |> K @{cprop False}
+
+(* FIXME
+fun prover (SMT_Solver.ProofData {context, output, recon, assms}) =
+ check_unsat recon output
+ |> Z3_Proof.reconstruct context assms recon
+*)
+
+fun solver oracle ctxt =
+ let val with_proof = Config.get ctxt proofs
+ in
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = Z3_Interface.interface,
+ arguments = cmdline_options ctxt,
+ reconstruct = (*FIXME:if with_proof then prover else*) oracle }
+ end
+
+val setup =
+ proofs_setup #>
+ options_setup #>
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, solver oracle)) #>
+ SMT_Solver.add_solver_info (solver_name, pretty_config)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/etc/settings Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,13 @@
+ISABELLE_SMT="$COMPONENT"
+
+REMOTE_SMT_SOLVER="$ISABELLE_SMT/lib/scripts/remote_smt.pl"
+
+REMOTE_SMT_URL="http://www4.in.tum.de/smt/smt"
+
+#
+# Paths to local SMT solvers:
+#
+# CVC_SOLVER=PATH
+# YICES_SOLVER=PATH
+# Z3_SOLVER=PATH
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/lib/scripts/remote_smt.pl Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,42 @@
+#
+# Script to invoke remote SMT solvers.
+# Author: Sascha Boehme, TU Muenchen
+#
+
+use strict;
+use LWP;
+
+
+# environment
+
+my $remote_smt_url = $ENV{"REMOTE_SMT_URL"};
+
+
+# arguments
+
+my $solver = $ARGV[0];
+my @options = @ARGV[1 .. ($#ARGV - 2)];
+my $problem_file = $ARGV[-2];
+my $output_file = $ARGV[-1];
+
+
+# call solver
+
+my $agent = LWP::UserAgent->new;
+$agent->agent("SMT-Request");
+$agent->timeout(180);
+my $response = $agent->post($remote_smt_url, [
+ "Solver" => $solver,
+ "Options" => join(" ", @options),
+ "Problem" => [$problem_file] ],
+ "Content_Type" => "form-data");
+if (not $response->is_success) {
+ print "HTTP-Error: " . $response->message . "\n";
+ exit 1;
+}
+else {
+ open(FILE, ">$output_file");
+ print FILE $response->content;
+ close(FILE);
+}
+
--- a/src/HOL/Series.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Series.thy Thu Oct 01 07:40:25 2009 +0200
@@ -104,6 +104,9 @@
"summable f ==> (%n. setsum f {0..<n}) ----> (suminf f)"
by (rule summable_sums [unfolded sums_def])
+lemma suminf_eq_lim: "suminf f = lim (%n. setsum f {0..<n})"
+ by (simp add: suminf_def sums_def lim_def)
+
(*-------------------
sum is unique
------------------*)
@@ -112,6 +115,9 @@
apply (auto intro!: LIMSEQ_unique simp add: sums_def)
done
+lemma sums_iff: "f sums x \<longleftrightarrow> summable f \<and> (suminf f = x)"
+ by (metis summable_sums sums_summable sums_unique)
+
lemma sums_split_initial_segment: "f sums s ==>
(%n. f(n + k)) sums (s - (SUM i = 0..< k. f i))"
apply (unfold sums_def);
@@ -368,6 +374,11 @@
apply (drule_tac x="n" in spec, simp)
done
+lemma suminf_le:
+ fixes x :: real
+ shows "summable f \<Longrightarrow> (!!n. setsum f {0..<n} \<le> x) \<Longrightarrow> suminf f \<le> x"
+ by (simp add: summable_convergent_sumr_iff suminf_eq_lim lim_le)
+
lemma summable_Cauchy:
"summable (f::nat \<Rightarrow> 'a::banach) =
(\<forall>e > 0. \<exists>N. \<forall>m \<ge> N. \<forall>n. norm (setsum f {m..<n}) < e)"
--- a/src/HOL/Set.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Set.thy Thu Oct 01 07:40:25 2009 +0200
@@ -652,8 +652,8 @@
subsubsection {* Binary union -- Un *}
-definition union :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "Un" 65) where
- sup_set_eq [symmetric]: "A Un B = sup A B"
+abbreviation union :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "Un" 65) where
+ "op Un \<equiv> sup"
notation (xsymbols)
union (infixl "\<union>" 65)
@@ -663,7 +663,7 @@
lemma Un_def:
"A \<union> B = {x. x \<in> A \<or> x \<in> B}"
- by (simp add: sup_fun_eq sup_bool_eq sup_set_eq [symmetric] Collect_def mem_def)
+ by (simp add: sup_fun_eq sup_bool_eq Collect_def mem_def)
lemma Un_iff [simp]: "(c : A Un B) = (c:A | c:B)"
by (unfold Un_def) blast
@@ -689,15 +689,13 @@
by (simp add: Collect_def mem_def insert_compr Un_def)
lemma mono_Un: "mono f \<Longrightarrow> f A \<union> f B \<subseteq> f (A \<union> B)"
- apply (fold sup_set_eq)
- apply (erule mono_sup)
- done
+ by (fact mono_sup)
subsubsection {* Binary intersection -- Int *}
-definition inter :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "Int" 70) where
- inf_set_eq [symmetric]: "A Int B = inf A B"
+abbreviation inter :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "Int" 70) where
+ "op Int \<equiv> inf"
notation (xsymbols)
inter (infixl "\<inter>" 70)
@@ -707,7 +705,7 @@
lemma Int_def:
"A \<inter> B = {x. x \<in> A \<and> x \<in> B}"
- by (simp add: inf_fun_eq inf_bool_eq inf_set_eq [symmetric] Collect_def mem_def)
+ by (simp add: inf_fun_eq inf_bool_eq Collect_def mem_def)
lemma Int_iff [simp]: "(c : A Int B) = (c:A & c:B)"
by (unfold Int_def) blast
@@ -725,9 +723,7 @@
by simp
lemma mono_Int: "mono f \<Longrightarrow> f (A \<inter> B) \<subseteq> f A \<inter> f B"
- apply (fold inf_set_eq)
- apply (erule mono_inf)
- done
+ by (fact mono_inf)
subsubsection {* Set difference *}
@@ -1268,10 +1264,26 @@
"(insert a B) Int C = (if a \<in> C then insert a (B \<inter> C) else B \<inter> C)"
by auto
+lemma Int_insert_left_if0[simp]:
+ "a \<notin> C \<Longrightarrow> (insert a B) Int C = B \<inter> C"
+ by auto
+
+lemma Int_insert_left_if1[simp]:
+ "a \<in> C \<Longrightarrow> (insert a B) Int C = insert a (B Int C)"
+ by auto
+
lemma Int_insert_right:
"A \<inter> (insert a B) = (if a \<in> A then insert a (A \<inter> B) else A \<inter> B)"
by auto
+lemma Int_insert_right_if0[simp]:
+ "a \<notin> A \<Longrightarrow> A Int (insert a B) = A Int B"
+ by auto
+
+lemma Int_insert_right_if1[simp]:
+ "a \<in> A \<Longrightarrow> A Int (insert a B) = insert a (A Int B)"
+ by auto
+
lemma Un_Int_distrib: "A \<union> (B \<inter> C) = (A \<union> B) \<inter> (A \<union> C)"
by blast
--- a/src/HOL/SetInterval.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/SetInterval.thy Thu Oct 01 07:40:25 2009 +0200
@@ -181,33 +181,108 @@
"(i : {l..u}) = (l <= i & i <= u)"
by (simp add: atLeastAtMost_def)
-text {* The above four lemmas could be declared as iffs.
- If we do so, a call to blast in Hyperreal/Star.ML, lemma @{text STAR_Int}
- seems to take forever (more than one hour). *}
+text {* The above four lemmas could be declared as iffs. Unfortunately this
+breaks many proofs. Since it only helps blast, it is better to leave well
+alone *}
+
end
-subsubsection{* Emptyness and singletons *}
+subsubsection{* Emptyness, singletons, subset *}
context order
begin
-lemma atLeastAtMost_empty [simp]: "n < m ==> {m..n} = {}";
-by (auto simp add: atLeastAtMost_def atMost_def atLeast_def)
+lemma atLeastatMost_empty[simp]:
+ "b < a \<Longrightarrow> {a..b} = {}"
+by(auto simp: atLeastAtMost_def atLeast_def atMost_def)
+
+lemma atLeastatMost_empty_iff[simp]:
+ "{a..b} = {} \<longleftrightarrow> (~ a <= b)"
+by auto (blast intro: order_trans)
+
+lemma atLeastatMost_empty_iff2[simp]:
+ "{} = {a..b} \<longleftrightarrow> (~ a <= b)"
+by auto (blast intro: order_trans)
+
+lemma atLeastLessThan_empty[simp]:
+ "b <= a \<Longrightarrow> {a..<b} = {}"
+by(auto simp: atLeastLessThan_def)
-lemma atLeastLessThan_empty[simp]: "n \<le> m ==> {m..<n} = {}"
-by (auto simp add: atLeastLessThan_def)
+lemma atLeastLessThan_empty_iff[simp]:
+ "{a..<b} = {} \<longleftrightarrow> (~ a < b)"
+by auto (blast intro: le_less_trans)
+
+lemma atLeastLessThan_empty_iff2[simp]:
+ "{} = {a..<b} \<longleftrightarrow> (~ a < b)"
+by auto (blast intro: le_less_trans)
-lemma greaterThanAtMost_empty[simp]:"l \<le> k ==> {k<..l} = {}"
+lemma greaterThanAtMost_empty[simp]: "l \<le> k ==> {k<..l} = {}"
by(auto simp:greaterThanAtMost_def greaterThan_def atMost_def)
+lemma greaterThanAtMost_empty_iff[simp]: "{k<..l} = {} \<longleftrightarrow> ~ k < l"
+by auto (blast intro: less_le_trans)
+
+lemma greaterThanAtMost_empty_iff2[simp]: "{} = {k<..l} \<longleftrightarrow> ~ k < l"
+by auto (blast intro: less_le_trans)
+
lemma greaterThanLessThan_empty[simp]:"l \<le> k ==> {k<..<l} = {}"
by(auto simp:greaterThanLessThan_def greaterThan_def lessThan_def)
lemma atLeastAtMost_singleton [simp]: "{a..a} = {a}"
by (auto simp add: atLeastAtMost_def atMost_def atLeast_def)
+lemma atLeastatMost_subset_iff[simp]:
+ "{a..b} <= {c..d} \<longleftrightarrow> (~ a <= b) | c <= a & b <= d"
+unfolding atLeastAtMost_def atLeast_def atMost_def
+by (blast intro: order_trans)
+
+lemma atLeastatMost_psubset_iff:
+ "{a..b} < {c..d} \<longleftrightarrow>
+ ((~ a <= b) | c <= a & b <= d & (c < a | b < d)) & c <= d"
+by(simp add: psubset_eq expand_set_eq less_le_not_le)(blast intro: order_trans)
+
end
+lemma (in linorder) atLeastLessThan_subset_iff:
+ "{a..<b} <= {c..<d} \<Longrightarrow> b <= a | c<=a & b<=d"
+apply (auto simp:subset_eq Ball_def)
+apply(frule_tac x=a in spec)
+apply(erule_tac x=d in allE)
+apply (simp add: less_imp_le)
+done
+
+subsubsection {* Intersection *}
+
+context linorder
+begin
+
+lemma Int_atLeastAtMost[simp]: "{a..b} Int {c..d} = {max a c .. min b d}"
+by auto
+
+lemma Int_atLeastAtMostR1[simp]: "{..b} Int {c..d} = {c .. min b d}"
+by auto
+
+lemma Int_atLeastAtMostR2[simp]: "{a..} Int {c..d} = {max a c .. d}"
+by auto
+
+lemma Int_atLeastAtMostL1[simp]: "{a..b} Int {..d} = {a .. min b d}"
+by auto
+
+lemma Int_atLeastAtMostL2[simp]: "{a..b} Int {c..} = {max a c .. b}"
+by auto
+
+lemma Int_atLeastLessThan[simp]: "{a..<b} Int {c..<d} = {max a c ..< min b d}"
+by auto
+
+lemma Int_greaterThanAtMost[simp]: "{a<..b} Int {c<..d} = {max a c <.. min b d}"
+by auto
+
+lemma Int_greaterThanLessThan[simp]: "{a<..<b} Int {c<..<d} = {max a c <..< min b d}"
+by auto
+
+end
+
+
subsection {* Intervals of natural numbers *}
subsubsection {* The Constant @{term lessThan} *}
@@ -439,6 +514,30 @@
qed
+subsubsection {* Proving Inclusions and Equalities between Unions *}
+
+lemma UN_UN_finite_eq: "(\<Union>n::nat. \<Union>i\<in>{0..<n}. A i) = (\<Union>n. A n)"
+ by (auto simp add: atLeast0LessThan)
+
+lemma UN_finite_subset: "(!!n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> C) \<Longrightarrow> (\<Union>n. A n) \<subseteq> C"
+ by (subst UN_UN_finite_eq [symmetric]) blast
+
+lemma UN_finite2_subset:
+ assumes sb: "!!n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n}. B i)"
+ shows "(\<Union>n. A n) \<subseteq> (\<Union>n. B n)"
+proof (rule UN_finite_subset)
+ fix n
+ have "(\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n}. B i)" by (rule sb)
+ also have "... \<subseteq> (\<Union>n::nat. \<Union>i\<in>{0..<n}. B i)" by blast
+ also have "... = (\<Union>n. B n)" by (simp add: UN_UN_finite_eq)
+ finally show "(\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>n. B n)" .
+qed
+
+lemma UN_finite2_eq:
+ "(!!n::nat. (\<Union>i\<in>{0..<n}. A i) = (\<Union>i\<in>{0..<n}. B i)) \<Longrightarrow> (\<Union>n. A n) = (\<Union>n. B n)"
+ by (iprover intro: subset_antisym UN_finite2_subset elim: equalityE)
+
+
subsubsection {* Cardinality *}
lemma card_lessThan [simp]: "card {..<u} = u"
@@ -662,17 +761,6 @@
subsubsection {* Disjoint Intersections *}
-text {* Singletons and open intervals *}
-
-lemma ivl_disj_int_singleton:
- "{l::'a::order} Int {l<..} = {}"
- "{..<u} Int {u} = {}"
- "{l} Int {l<..<u} = {}"
- "{l<..<u} Int {u} = {}"
- "{l} Int {l<..u} = {}"
- "{l..<u} Int {u} = {}"
- by simp+
-
text {* One- and two-sided intervals *}
lemma ivl_disj_int_one:
@@ -699,7 +787,7 @@
"{l..m} Int {m<..u} = {}"
by auto
-lemmas ivl_disj_int = ivl_disj_int_singleton ivl_disj_int_one ivl_disj_int_two
+lemmas ivl_disj_int = ivl_disj_int_one ivl_disj_int_two
subsubsection {* Some Differences *}
--- a/src/HOL/Statespace/DistinctTreeProver.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Statespace/DistinctTreeProver.thy Thu Oct 01 07:40:25 2009 +0200
@@ -664,7 +664,7 @@
HOLogic.Trueprop$
(Const ("DistinctTreeProver.all_distinct",DistinctTreeProver.treeT (Type ("nat",[])) --> HOLogic.boolT)$t')
-val da = ref refl;
+val da = Unsynchronized.ref refl;
*}
--- a/src/HOL/Statespace/state_space.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Statespace/state_space.ML Thu Oct 01 07:40:25 2009 +0200
@@ -567,8 +567,8 @@
(case distinct (snd_eq) (filter (curry fst_eq (n,T)) raw_parent_comps) of
[] => []
| [_] => []
- | rs => ["Different types for component " ^ n ^": " ^ commas
- (map (Pretty.string_of o Display.pretty_ctyp o ctyp_of thy o snd) rs)])
+ | rs => ["Different types for component " ^ n ^": " ^
+ commas (map (Syntax.string_of_typ ctxt o snd) rs)])
val err_dup_types = List.concat (map check_type (duplicates fst_eq raw_parent_comps))
--- a/src/HOL/Tools/ATP_Manager/SystemOnTPTP Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/ATP_Manager/SystemOnTPTP Thu Oct 01 07:40:25 2009 +0200
@@ -19,6 +19,7 @@
"QuietFlag" => "-q01",
"SubmitButton" => "RunSelectedSystems",
"ProblemSource" => "UPLOAD",
+ "ForceSystem" => "-force",
);
#----Get format and transform options if specified
--- a/src/HOL/Tools/ATP_Manager/atp_manager.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/ATP_Manager/atp_manager.ML Thu Oct 01 07:40:25 2009 +0200
@@ -24,7 +24,7 @@
type prover = int -> (thm * (string * int)) list option ->
(thm * (string * int)) list option -> string -> int ->
Proof.context * (thm list * thm) ->
- bool * string * string * string vector * (thm * (string * int)) list
+ bool * (string * string list) * int * string * string vector * (thm * (string * int)) list
val add_prover: string -> prover -> theory -> theory
val print_provers: theory -> unit
val get_prover: string -> theory -> prover option
@@ -41,10 +41,10 @@
local
-val atps = ref "e remote_vampire";
-val max_atps = ref 5; (* ~1 means infinite number of atps *)
-val timeout = ref 60;
-val full_types = ref false;
+val atps = Unsynchronized.ref "e remote_vampire";
+val max_atps = Unsynchronized.ref 5; (* ~1 means infinite number of atps *)
+val timeout = Unsynchronized.ref 60;
+val full_types = Unsynchronized.ref false;
in
@@ -305,7 +305,7 @@
type prover = int -> (thm * (string * int)) list option ->
(thm * (string * int)) list option -> string -> int ->
Proof.context * (thm list * thm) ->
- bool * string * string * string vector * (thm * (string * int)) list
+ bool * (string * string list) * int * string * string vector * (thm * (string * int)) list
fun err_dup_prover name = error ("Duplicate prover: " ^ quote name);
@@ -345,7 +345,7 @@
let
val _ = register birthtime deadtime (Thread.self (), desc)
val result =
- let val (success, message, _, _, _) =
+ let val (success, (message, _), _, _, _, _) =
prover (get_timeout ()) NONE NONE name i (Proof.get_goal proof_state)
in (success, message) end
handle ResHolClause.TOO_TRIVIAL
--- a/src/HOL/Tools/ATP_Manager/atp_minimal.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/ATP_Manager/atp_minimal.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,13 @@
Minimalization of theorem list for metis by using an external automated theorem prover
*)
-structure AtpMinimal: sig end =
+signature ATP_MINIMAL =
+sig
+ val minimalize: AtpManager.prover -> string -> int -> Proof.state ->
+ (string * thm list) list -> ((string * thm list) list * int) option * string
+end
+
+structure AtpMinimal: ATP_MINIMAL =
struct
(* output control *)
@@ -62,7 +68,15 @@
@post v subset s & p(v) &
forall e in v. ~p(v \ e)
*)
- fun minimal p s = min p [] s
+ fun minimal p s =
+ let val c = Unsynchronized.ref 0
+ fun pc xs = (c := !c + 1; p xs)
+ in
+ (case min pc [] s of
+ [x] => if pc [] then [] else [x]
+ | m => m,
+ !c)
+ end
end
@@ -83,7 +97,7 @@
("# Cannot determine problem status within resource limit", Timeout),
("Error", Error)]
-fun produce_answer (success, message, result_string, thm_name_vec, filtered) =
+fun produce_answer (success, message, _, result_string, thm_name_vec, filtered) =
if success then
(Success (Vector.foldr op:: [] thm_name_vec, filtered), result_string)
else
@@ -103,8 +117,7 @@
fun sh_test_thms prover prover_name time_limit subgoalno state filtered name_thms_pairs =
let
val _ = println ("Testing " ^ (length_string name_thms_pairs) ^ " theorems... ")
- val name_thm_pairs =
- flat (map (fn (n, ths) => map_index (fn (i, th) => (n, th)) ths) name_thms_pairs)
+ val name_thm_pairs = maps (fn (n, ths) => map (pair n) ths) name_thms_pairs
val _ = debug_fn (fn () => print_names name_thm_pairs)
val axclauses = ResAxioms.cnf_rules_pairs (Proof.theory_of state) name_thm_pairs
val (result, proof) =
@@ -130,6 +143,7 @@
val test_thms_fun = sh_test_thms prover prover_name time_limit 1 state
fun test_thms filtered thms =
case test_thms_fun filtered thms of (Success _, _) => true | _ => false
+ val answer' = pair and answer'' = pair NONE
in
(* try prove first to check result and get used theorems *)
(case test_thms_fun NONE name_thms_pairs of
@@ -141,25 +155,27 @@
filter (fn (name1, _) => List.exists (equal name1) ordered_used) name_thms_pairs
else
name_thms_pairs
- val min_thms = (minimal (test_thms (SOME filtered)) to_use)
+ val (min_thms, n) = if null to_use then ([], 0)
+ else minimal (test_thms (SOME filtered)) to_use
val min_names = order_unique (map fst min_thms)
+ val _ = println ("Interations: " ^ string_of_int n)
val _ = println ("Minimal " ^ (length_string min_thms) ^ " theorems")
val _ = debug_fn (fn () => print_names min_thms)
in
- answer ("Try this command: " ^
+ answer' (SOME(min_thms,n)) ("Try this command: " ^
Markup.markup Markup.sendback ("apply (metis " ^ space_implode " " min_names ^ ")"))
end
| (Timeout, _) =>
- answer ("Timeout: You may need to increase the time limit of " ^
+ answer'' ("Timeout: You may need to increase the time limit of " ^
Int.toString time_limit ^ " seconds. Call atp_minimize [time=...] ")
| (Error, msg) =>
- answer ("Error in prover: " ^ msg)
+ answer'' ("Error in prover: " ^ msg)
| (Failure, _) =>
- answer "Failure: No proof with the theorems supplied")
+ answer'' "Failure: No proof with the theorems supplied")
handle ResHolClause.TOO_TRIVIAL =>
- answer ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
+ answer' (SOME ([],0)) ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
| ERROR msg =>
- answer ("Error: " ^ msg)
+ answer'' ("Error: " ^ msg)
end
@@ -204,8 +220,9 @@
SOME prover => prover
| NONE => error ("Unknown prover: " ^ quote prover_name)
val name_thms_pairs = get_thms (Proof.context_of state) thm_names
+ fun print_answer (_, msg) = answer msg
in
- minimalize prover prover_name time_limit state name_thms_pairs
+ print_answer (minimalize prover prover_name time_limit state name_thms_pairs)
end
val parse_args = Scan.optional (Args.bracks (P.list (P.xname --| P.$$$ "=" -- P.xname))) []
--- a/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,8 +6,8 @@
signature ATP_WRAPPER =
sig
- val destdir: string ref
- val problem_name: string ref
+ val destdir: string Unsynchronized.ref
+ val problem_name: string Unsynchronized.ref
val tptp_prover_opts_full: int -> bool -> bool -> Path.T * string -> AtpManager.prover
val tptp_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover
val tptp_prover: Path.T * string -> AtpManager.prover
@@ -35,12 +35,18 @@
(* global hooks for writing problemfiles *)
-val destdir = ref ""; (*Empty means write files to /tmp*)
-val problem_name = ref "prob";
+val destdir = Unsynchronized.ref ""; (*Empty means write files to /tmp*)
+val problem_name = Unsynchronized.ref "prob";
(* basic template *)
+fun with_path cleanup after f path =
+ Exn.capture f path
+ |> tap (fn _ => cleanup path)
+ |> Exn.release
+ |> tap (after path)
+
fun external_prover relevance_filter preparer writer (cmd, args) find_failure produce_answer
timeout axiom_clauses filtered_clauses name subgoalno goal =
let
@@ -73,28 +79,44 @@
preparer goal_cls chain_ths the_axiom_clauses the_filtered_clauses thy
(* write out problem file and call prover *)
- val probfile = prob_pathname subgoalno
- val conj_pos = writer probfile clauses
- val (proof, rc) = system_out (
- if File.exists cmd then
- space_implode " " ["exec", File.shell_path cmd, args, File.platform_path probfile]
- else error ("Bad executable: " ^ Path.implode cmd))
+ fun cmd_line probfile = "TIMEFORMAT='%3U'; { time " ^ space_implode " "
+ [File.shell_path cmd, args, File.platform_path probfile] ^ " ; } 2>&1"
+ fun split_time s =
+ let
+ val split = String.tokens (fn c => str c = "\n")
+ val (proof, t) = s |> split |> split_last |> apfst cat_lines
+ fun as_num f = f >> (fst o read_int)
+ val num = as_num (Scan.many1 Symbol.is_ascii_digit)
+ val digit = Scan.one Symbol.is_ascii_digit
+ val num3 = as_num (digit ::: digit ::: (digit >> single))
+ val time = num --| Scan.$$ "." -- num3 >> (fn (a, b) => a * 1000 + b)
+ val as_time = the_default 0 o Scan.read Symbol.stopper time o explode
+ in (proof, as_time t) end
+ fun run_on probfile =
+ if File.exists cmd
+ then
+ writer probfile clauses
+ |> pair (apfst split_time (system_out (cmd_line probfile)))
+ else error ("Bad executable: " ^ Path.implode cmd)
(* if problemfile has not been exported, delete problemfile; otherwise export proof, too *)
- val _ =
- if destdir' = "" then File.rm probfile
+ fun cleanup probfile = if destdir' = "" then try File.rm probfile else NONE
+ fun export probfile (((proof, _), _), _) = if destdir' = "" then ()
else File.write (Path.explode (Path.implode probfile ^ "_proof")) proof
+ val (((proof, time), rc), conj_pos) = with_path cleanup export run_on
+ (prob_pathname subgoalno)
+
(* check for success and print out some information on failure *)
val failure = find_failure proof
val success = rc = 0 andalso is_none failure
val message =
- if is_some failure then "External prover failed."
- else if rc <> 0 then "External prover failed: " ^ proof
- else "Try this command: " ^
- produce_answer name (proof, thm_names, conj_pos, ctxt, th, subgoalno)
+ if is_some failure then ("External prover failed.", [])
+ else if rc <> 0 then ("External prover failed: " ^ proof, [])
+ else apfst (fn s => "Try this command: " ^ s)
+ (produce_answer name (proof, thm_names, conj_pos, ctxt, th, subgoalno))
val _ = Output.debug (fn () => "Sledgehammer response (rc = " ^ string_of_int rc ^ "):\n" ^ proof)
- in (success, message, proof, thm_names, the_filtered_clauses) end;
+ in (success, message, time, proof, thm_names, the_filtered_clauses) end;
--- a/src/HOL/Tools/ComputeFloat.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,568 +0,0 @@
-(* Title: HOL/Tools/ComputeFloat.thy
- Author: Steven Obua
-*)
-
-header {* Floating Point Representation of the Reals *}
-
-theory ComputeFloat
-imports Complex_Main
-uses "~~/src/Tools/float.ML" ("~~/src/HOL/Tools/float_arith.ML")
-begin
-
-definition
- pow2 :: "int \<Rightarrow> real" where
- "pow2 a = (if (0 <= a) then (2^(nat a)) else (inverse (2^(nat (-a)))))"
-
-definition
- float :: "int * int \<Rightarrow> real" where
- "float x = real (fst x) * pow2 (snd x)"
-
-lemma pow2_0[simp]: "pow2 0 = 1"
-by (simp add: pow2_def)
-
-lemma pow2_1[simp]: "pow2 1 = 2"
-by (simp add: pow2_def)
-
-lemma pow2_neg: "pow2 x = inverse (pow2 (-x))"
-by (simp add: pow2_def)
-
-lemma pow2_add1: "pow2 (1 + a) = 2 * (pow2 a)"
-proof -
- have h: "! n. nat (2 + int n) - Suc 0 = nat (1 + int n)" by arith
- have g: "! a b. a - -1 = a + (1::int)" by arith
- have pos: "! n. pow2 (int n + 1) = 2 * pow2 (int n)"
- apply (auto, induct_tac n)
- apply (simp_all add: pow2_def)
- apply (rule_tac m1="2" and n1="nat (2 + int na)" in ssubst[OF realpow_num_eq_if])
- by (auto simp add: h)
- show ?thesis
- proof (induct a)
- case (1 n)
- from pos show ?case by (simp add: algebra_simps)
- next
- case (2 n)
- show ?case
- apply (auto)
- apply (subst pow2_neg[of "- int n"])
- apply (subst pow2_neg[of "-1 - int n"])
- apply (auto simp add: g pos)
- done
- qed
-qed
-
-lemma pow2_add: "pow2 (a+b) = (pow2 a) * (pow2 b)"
-proof (induct b)
- case (1 n)
- show ?case
- proof (induct n)
- case 0
- show ?case by simp
- next
- case (Suc m)
- show ?case by (auto simp add: algebra_simps pow2_add1 prems)
- qed
-next
- case (2 n)
- show ?case
- proof (induct n)
- case 0
- show ?case
- apply (auto)
- apply (subst pow2_neg[of "a + -1"])
- apply (subst pow2_neg[of "-1"])
- apply (simp)
- apply (insert pow2_add1[of "-a"])
- apply (simp add: algebra_simps)
- apply (subst pow2_neg[of "-a"])
- apply (simp)
- done
- case (Suc m)
- have a: "int m - (a + -2) = 1 + (int m - a + 1)" by arith
- have b: "int m - -2 = 1 + (int m + 1)" by arith
- show ?case
- apply (auto)
- apply (subst pow2_neg[of "a + (-2 - int m)"])
- apply (subst pow2_neg[of "-2 - int m"])
- apply (auto simp add: algebra_simps)
- apply (subst a)
- apply (subst b)
- apply (simp only: pow2_add1)
- apply (subst pow2_neg[of "int m - a + 1"])
- apply (subst pow2_neg[of "int m + 1"])
- apply auto
- apply (insert prems)
- apply (auto simp add: algebra_simps)
- done
- qed
-qed
-
-lemma "float (a, e) + float (b, e) = float (a + b, e)"
-by (simp add: float_def algebra_simps)
-
-definition
- int_of_real :: "real \<Rightarrow> int" where
- "int_of_real x = (SOME y. real y = x)"
-
-definition
- real_is_int :: "real \<Rightarrow> bool" where
- "real_is_int x = (EX (u::int). x = real u)"
-
-lemma real_is_int_def2: "real_is_int x = (x = real (int_of_real x))"
-by (auto simp add: real_is_int_def int_of_real_def)
-
-lemma float_transfer: "real_is_int ((real a)*(pow2 c)) \<Longrightarrow> float (a, b) = float (int_of_real ((real a)*(pow2 c)), b - c)"
-by (simp add: float_def real_is_int_def2 pow2_add[symmetric])
-
-lemma pow2_int: "pow2 (int c) = 2^c"
-by (simp add: pow2_def)
-
-lemma float_transfer_nat: "float (a, b) = float (a * 2^c, b - int c)"
-by (simp add: float_def pow2_int[symmetric] pow2_add[symmetric])
-
-lemma real_is_int_real[simp]: "real_is_int (real (x::int))"
-by (auto simp add: real_is_int_def int_of_real_def)
-
-lemma int_of_real_real[simp]: "int_of_real (real x) = x"
-by (simp add: int_of_real_def)
-
-lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real (int_of_real x) = x"
-by (auto simp add: int_of_real_def real_is_int_def)
-
-lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
-by (auto simp add: int_of_real_def real_is_int_def)
-
-lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
-apply (subst real_is_int_def2)
-apply (simp add: real_is_int_add_int_of_real real_int_of_real)
-done
-
-lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
-by (auto simp add: int_of_real_def real_is_int_def)
-
-lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
-apply (subst real_is_int_def2)
-apply (simp add: int_of_real_sub real_int_of_real)
-done
-
-lemma real_is_int_rep: "real_is_int x \<Longrightarrow> ?! (a::int). real a = x"
-by (auto simp add: real_is_int_def)
-
-lemma int_of_real_mult:
- assumes "real_is_int a" "real_is_int b"
- shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
-proof -
- from prems have a: "?! (a'::int). real a' = a" by (rule_tac real_is_int_rep, auto)
- from prems have b: "?! (b'::int). real b' = b" by (rule_tac real_is_int_rep, auto)
- from a obtain a'::int where a':"a = real a'" by auto
- from b obtain b'::int where b':"b = real b'" by auto
- have r: "real a' * real b' = real (a' * b')" by auto
- show ?thesis
- apply (simp add: a' b')
- apply (subst r)
- apply (simp only: int_of_real_real)
- done
-qed
-
-lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
-apply (subst real_is_int_def2)
-apply (simp add: int_of_real_mult)
-done
-
-lemma real_is_int_0[simp]: "real_is_int (0::real)"
-by (simp add: real_is_int_def int_of_real_def)
-
-lemma real_is_int_1[simp]: "real_is_int (1::real)"
-proof -
- have "real_is_int (1::real) = real_is_int(real (1::int))" by auto
- also have "\<dots> = True" by (simp only: real_is_int_real)
- ultimately show ?thesis by auto
-qed
-
-lemma real_is_int_n1: "real_is_int (-1::real)"
-proof -
- have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
- also have "\<dots> = True" by (simp only: real_is_int_real)
- ultimately show ?thesis by auto
-qed
-
-lemma real_is_int_number_of[simp]: "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
-proof -
- have neg1: "real_is_int (-1::real)"
- proof -
- have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
- also have "\<dots> = True" by (simp only: real_is_int_real)
- ultimately show ?thesis by auto
- qed
-
- {
- fix x :: int
- have "real_is_int ((number_of \<Colon> int \<Rightarrow> real) x)"
- unfolding number_of_eq
- apply (induct x)
- apply (induct_tac n)
- apply (simp)
- apply (simp)
- apply (induct_tac n)
- apply (simp add: neg1)
- proof -
- fix n :: nat
- assume rn: "(real_is_int (of_int (- (int (Suc n)))))"
- have s: "-(int (Suc (Suc n))) = -1 + - (int (Suc n))" by simp
- show "real_is_int (of_int (- (int (Suc (Suc n)))))"
- apply (simp only: s of_int_add)
- apply (rule real_is_int_add)
- apply (simp add: neg1)
- apply (simp only: rn)
- done
- qed
- }
- note Abs_Bin = this
- {
- fix x :: int
- have "? u. x = u"
- apply (rule exI[where x = "x"])
- apply (simp)
- done
- }
- then obtain u::int where "x = u" by auto
- with Abs_Bin show ?thesis by auto
-qed
-
-lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
-by (simp add: int_of_real_def)
-
-lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
-proof -
- have 1: "(1::real) = real (1::int)" by auto
- show ?thesis by (simp only: 1 int_of_real_real)
-qed
-
-lemma int_of_real_number_of[simp]: "int_of_real (number_of b) = number_of b"
-proof -
- have "real_is_int (number_of b)" by simp
- then have uu: "?! u::int. number_of b = real u" by (auto simp add: real_is_int_rep)
- then obtain u::int where u:"number_of b = real u" by auto
- have "number_of b = real ((number_of b)::int)"
- by (simp add: number_of_eq real_of_int_def)
- have ub: "number_of b = real ((number_of b)::int)"
- by (simp add: number_of_eq real_of_int_def)
- from uu u ub have unb: "u = number_of b"
- by blast
- have "int_of_real (number_of b) = u" by (simp add: u)
- with unb show ?thesis by simp
-qed
-
-lemma float_transfer_even: "even a \<Longrightarrow> float (a, b) = float (a div 2, b+1)"
- apply (subst float_transfer[where a="a" and b="b" and c="-1", simplified])
- apply (simp_all add: pow2_def even_def real_is_int_def algebra_simps)
- apply (auto)
-proof -
- fix q::int
- have a:"b - (-1\<Colon>int) = (1\<Colon>int) + b" by arith
- show "(float (q, (b - (-1\<Colon>int)))) = (float (q, ((1\<Colon>int) + b)))"
- by (simp add: a)
-qed
-
-lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
-by (rule zdiv_int)
-
-lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
-by (rule zmod_int)
-
-lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
-by arith
-
-function norm_float :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
- "norm_float a b = (if a \<noteq> 0 \<and> even a then norm_float (a div 2) (b + 1)
- else if a = 0 then (0, 0) else (a, b))"
-by auto
-
-termination by (relation "measure (nat o abs o fst)")
- (auto intro: abs_div_2_less)
-
-lemma norm_float: "float x = float (split norm_float x)"
-proof -
- {
- fix a b :: int
- have norm_float_pair: "float (a, b) = float (norm_float a b)"
- proof (induct a b rule: norm_float.induct)
- case (1 u v)
- show ?case
- proof cases
- assume u: "u \<noteq> 0 \<and> even u"
- with prems have ind: "float (u div 2, v + 1) = float (norm_float (u div 2) (v + 1))" by auto
- with u have "float (u,v) = float (u div 2, v+1)" by (simp add: float_transfer_even)
- then show ?thesis
- apply (subst norm_float.simps)
- apply (simp add: ind)
- done
- next
- assume "~(u \<noteq> 0 \<and> even u)"
- then show ?thesis
- by (simp add: prems float_def)
- qed
- qed
- }
- note helper = this
- have "? a b. x = (a,b)" by auto
- then obtain a b where "x = (a, b)" by blast
- then show ?thesis by (simp add: helper)
-qed
-
-lemma float_add_l0: "float (0, e) + x = x"
- by (simp add: float_def)
-
-lemma float_add_r0: "x + float (0, e) = x"
- by (simp add: float_def)
-
-lemma float_add:
- "float (a1, e1) + float (a2, e2) =
- (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1)
- else float (a1*2^(nat (e1-e2))+a2, e2))"
- apply (simp add: float_def algebra_simps)
- apply (auto simp add: pow2_int[symmetric] pow2_add[symmetric])
- done
-
-lemma float_add_assoc1:
- "(x + float (y1, e1)) + float (y2, e2) = (float (y1, e1) + float (y2, e2)) + x"
- by simp
-
-lemma float_add_assoc2:
- "(float (y1, e1) + x) + float (y2, e2) = (float (y1, e1) + float (y2, e2)) + x"
- by simp
-
-lemma float_add_assoc3:
- "float (y1, e1) + (x + float (y2, e2)) = (float (y1, e1) + float (y2, e2)) + x"
- by simp
-
-lemma float_add_assoc4:
- "float (y1, e1) + (float (y2, e2) + x) = (float (y1, e1) + float (y2, e2)) + x"
- by simp
-
-lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
- by (simp add: float_def)
-
-lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
- by (simp add: float_def)
-
-definition
- lbound :: "real \<Rightarrow> real"
-where
- "lbound x = min 0 x"
-
-definition
- ubound :: "real \<Rightarrow> real"
-where
- "ubound x = max 0 x"
-
-lemma lbound: "lbound x \<le> x"
- by (simp add: lbound_def)
-
-lemma ubound: "x \<le> ubound x"
- by (simp add: ubound_def)
-
-lemma float_mult:
- "float (a1, e1) * float (a2, e2) =
- (float (a1 * a2, e1 + e2))"
- by (simp add: float_def pow2_add)
-
-lemma float_minus:
- "- (float (a,b)) = float (-a, b)"
- by (simp add: float_def)
-
-lemma zero_less_pow2:
- "0 < pow2 x"
-proof -
- {
- fix y
- have "0 <= y \<Longrightarrow> 0 < pow2 y"
- by (induct y, induct_tac n, simp_all add: pow2_add)
- }
- note helper=this
- show ?thesis
- apply (case_tac "0 <= x")
- apply (simp add: helper)
- apply (subst pow2_neg)
- apply (simp add: helper)
- done
-qed
-
-lemma zero_le_float:
- "(0 <= float (a,b)) = (0 <= a)"
- apply (auto simp add: float_def)
- apply (auto simp add: zero_le_mult_iff zero_less_pow2)
- apply (insert zero_less_pow2[of b])
- apply (simp_all)
- done
-
-lemma float_le_zero:
- "(float (a,b) <= 0) = (a <= 0)"
- apply (auto simp add: float_def)
- apply (auto simp add: mult_le_0_iff)
- apply (insert zero_less_pow2[of b])
- apply auto
- done
-
-lemma float_abs:
- "abs (float (a,b)) = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
- apply (auto simp add: abs_if)
- apply (simp_all add: zero_le_float[symmetric, of a b] float_minus)
- done
-
-lemma float_zero:
- "float (0, b) = 0"
- by (simp add: float_def)
-
-lemma float_pprt:
- "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
- by (auto simp add: zero_le_float float_le_zero float_zero)
-
-lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
- apply (simp add: float_def)
- apply (rule pprt_eq_0)
- apply (simp add: lbound_def)
- done
-
-lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
- apply (simp add: float_def)
- apply (rule nprt_eq_0)
- apply (simp add: ubound_def)
- done
-
-lemma float_nprt:
- "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
- by (auto simp add: zero_le_float float_le_zero float_zero)
-
-lemma norm_0_1: "(0::_::number_ring) = Numeral0 & (1::_::number_ring) = Numeral1"
- by auto
-
-lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
- by simp
-
-lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
- by simp
-
-lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
- by simp
-
-lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
- by simp
-
-lemma int_pow_0: "(a::int)^(Numeral0) = 1"
- by simp
-
-lemma int_pow_1: "(a::int)^(Numeral1) = a"
- by simp
-
-lemma zero_eq_Numeral0_nring: "(0::'a::number_ring) = Numeral0"
- by simp
-
-lemma one_eq_Numeral1_nring: "(1::'a::number_ring) = Numeral1"
- by simp
-
-lemma zero_eq_Numeral0_nat: "(0::nat) = Numeral0"
- by simp
-
-lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
- by simp
-
-lemma zpower_Pls: "(z::int)^Numeral0 = Numeral1"
- by simp
-
-lemma zpower_Min: "(z::int)^((-1)::nat) = Numeral1"
-proof -
- have 1:"((-1)::nat) = 0"
- by simp
- show ?thesis by (simp add: 1)
-qed
-
-lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
- by simp
-
-lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
- by simp
-
-lemma lift_bool: "x \<Longrightarrow> x=True"
- by simp
-
-lemma nlift_bool: "~x \<Longrightarrow> x=False"
- by simp
-
-lemma not_false_eq_true: "(~ False) = True" by simp
-
-lemma not_true_eq_false: "(~ True) = False" by simp
-
-lemmas binarith =
- normalize_bin_simps
- pred_bin_simps succ_bin_simps
- add_bin_simps minus_bin_simps mult_bin_simps
-
-lemma int_eq_number_of_eq:
- "(((number_of v)::int)=(number_of w)) = iszero ((number_of (v + uminus w))::int)"
- by (rule eq_number_of_eq)
-
-lemma int_iszero_number_of_Pls: "iszero (Numeral0::int)"
- by (simp only: iszero_number_of_Pls)
-
-lemma int_nonzero_number_of_Min: "~(iszero ((-1)::int))"
- by simp
-
-lemma int_iszero_number_of_Bit0: "iszero ((number_of (Int.Bit0 w))::int) = iszero ((number_of w)::int)"
- by simp
-
-lemma int_iszero_number_of_Bit1: "\<not> iszero ((number_of (Int.Bit1 w))::int)"
- by simp
-
-lemma int_less_number_of_eq_neg: "(((number_of x)::int) < number_of y) = neg ((number_of (x + (uminus y)))::int)"
- unfolding neg_def number_of_is_id by simp
-
-lemma int_not_neg_number_of_Pls: "\<not> (neg (Numeral0::int))"
- by simp
-
-lemma int_neg_number_of_Min: "neg (-1::int)"
- by simp
-
-lemma int_neg_number_of_Bit0: "neg ((number_of (Int.Bit0 w))::int) = neg ((number_of w)::int)"
- by simp
-
-lemma int_neg_number_of_Bit1: "neg ((number_of (Int.Bit1 w))::int) = neg ((number_of w)::int)"
- by simp
-
-lemma int_le_number_of_eq: "(((number_of x)::int) \<le> number_of y) = (\<not> neg ((number_of (y + (uminus x)))::int))"
- unfolding neg_def number_of_is_id by (simp add: not_less)
-
-lemmas intarithrel =
- int_eq_number_of_eq
- lift_bool[OF int_iszero_number_of_Pls] nlift_bool[OF int_nonzero_number_of_Min] int_iszero_number_of_Bit0
- lift_bool[OF int_iszero_number_of_Bit1] int_less_number_of_eq_neg nlift_bool[OF int_not_neg_number_of_Pls] lift_bool[OF int_neg_number_of_Min]
- int_neg_number_of_Bit0 int_neg_number_of_Bit1 int_le_number_of_eq
-
-lemma int_number_of_add_sym: "((number_of v)::int) + number_of w = number_of (v + w)"
- by simp
-
-lemma int_number_of_diff_sym: "((number_of v)::int) - number_of w = number_of (v + (uminus w))"
- by simp
-
-lemma int_number_of_mult_sym: "((number_of v)::int) * number_of w = number_of (v * w)"
- by simp
-
-lemma int_number_of_minus_sym: "- ((number_of v)::int) = number_of (uminus v)"
- by simp
-
-lemmas intarith = int_number_of_add_sym int_number_of_minus_sym int_number_of_diff_sym int_number_of_mult_sym
-
-lemmas natarith = add_nat_number_of diff_nat_number_of mult_nat_number_of eq_nat_number_of less_nat_number_of
-
-lemmas powerarith = nat_number_of zpower_number_of_even
- zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
- zpower_Pls zpower_Min
-
-lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
- float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound
-
-(* for use with the compute oracle *)
-lemmas arith = binarith intarith intarithrel natarith powerarith floatarith not_false_eq_true not_true_eq_false
-
-use "~~/src/HOL/Tools/float_arith.ML"
-
-end
--- a/src/HOL/Tools/ComputeHOL.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,191 +0,0 @@
-theory ComputeHOL
-imports Complex_Main "~~/src/Tools/Compute_Oracle/Compute_Oracle"
-begin
-
-lemma Trueprop_eq_eq: "Trueprop X == (X == True)" by (simp add: atomize_eq)
-lemma meta_eq_trivial: "x == y \<Longrightarrow> x == y" by simp
-lemma meta_eq_imp_eq: "x == y \<Longrightarrow> x = y" by auto
-lemma eq_trivial: "x = y \<Longrightarrow> x = y" by auto
-lemma bool_to_true: "x :: bool \<Longrightarrow> x == True" by simp
-lemma transmeta_1: "x = y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
-lemma transmeta_2: "x == y \<Longrightarrow> y = z \<Longrightarrow> x = z" by simp
-lemma transmeta_3: "x == y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
-
-
-(**** compute_if ****)
-
-lemma If_True: "If True = (\<lambda> x y. x)" by ((rule ext)+,auto)
-lemma If_False: "If False = (\<lambda> x y. y)" by ((rule ext)+, auto)
-
-lemmas compute_if = If_True If_False
-
-(**** compute_bool ****)
-
-lemma bool1: "(\<not> True) = False" by blast
-lemma bool2: "(\<not> False) = True" by blast
-lemma bool3: "(P \<and> True) = P" by blast
-lemma bool4: "(True \<and> P) = P" by blast
-lemma bool5: "(P \<and> False) = False" by blast
-lemma bool6: "(False \<and> P) = False" by blast
-lemma bool7: "(P \<or> True) = True" by blast
-lemma bool8: "(True \<or> P) = True" by blast
-lemma bool9: "(P \<or> False) = P" by blast
-lemma bool10: "(False \<or> P) = P" by blast
-lemma bool11: "(True \<longrightarrow> P) = P" by blast
-lemma bool12: "(P \<longrightarrow> True) = True" by blast
-lemma bool13: "(True \<longrightarrow> P) = P" by blast
-lemma bool14: "(P \<longrightarrow> False) = (\<not> P)" by blast
-lemma bool15: "(False \<longrightarrow> P) = True" by blast
-lemma bool16: "(False = False) = True" by blast
-lemma bool17: "(True = True) = True" by blast
-lemma bool18: "(False = True) = False" by blast
-lemma bool19: "(True = False) = False" by blast
-
-lemmas compute_bool = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10 bool11 bool12 bool13 bool14 bool15 bool16 bool17 bool18 bool19
-
-
-(*** compute_pair ***)
-
-lemma compute_fst: "fst (x,y) = x" by simp
-lemma compute_snd: "snd (x,y) = y" by simp
-lemma compute_pair_eq: "((a, b) = (c, d)) = (a = c \<and> b = d)" by auto
-
-lemma prod_case_simp: "prod_case f (x,y) = f x y" by simp
-
-lemmas compute_pair = compute_fst compute_snd compute_pair_eq prod_case_simp
-
-(*** compute_option ***)
-
-lemma compute_the: "the (Some x) = x" by simp
-lemma compute_None_Some_eq: "(None = Some x) = False" by auto
-lemma compute_Some_None_eq: "(Some x = None) = False" by auto
-lemma compute_None_None_eq: "(None = None) = True" by auto
-lemma compute_Some_Some_eq: "(Some x = Some y) = (x = y)" by auto
-
-definition
- option_case_compute :: "'b option \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
-where
- "option_case_compute opt a f = option_case a f opt"
-
-lemma option_case_compute: "option_case = (\<lambda> a f opt. option_case_compute opt a f)"
- by (simp add: option_case_compute_def)
-
-lemma option_case_compute_None: "option_case_compute None = (\<lambda> a f. a)"
- apply (rule ext)+
- apply (simp add: option_case_compute_def)
- done
-
-lemma option_case_compute_Some: "option_case_compute (Some x) = (\<lambda> a f. f x)"
- apply (rule ext)+
- apply (simp add: option_case_compute_def)
- done
-
-lemmas compute_option_case = option_case_compute option_case_compute_None option_case_compute_Some
-
-lemmas compute_option = compute_the compute_None_Some_eq compute_Some_None_eq compute_None_None_eq compute_Some_Some_eq compute_option_case
-
-(**** compute_list_length ****)
-
-lemma length_cons:"length (x#xs) = 1 + (length xs)"
- by simp
-
-lemma length_nil: "length [] = 0"
- by simp
-
-lemmas compute_list_length = length_nil length_cons
-
-(*** compute_list_case ***)
-
-definition
- list_case_compute :: "'b list \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a"
-where
- "list_case_compute l a f = list_case a f l"
-
-lemma list_case_compute: "list_case = (\<lambda> (a::'a) f (l::'b list). list_case_compute l a f)"
- apply (rule ext)+
- apply (simp add: list_case_compute_def)
- done
-
-lemma list_case_compute_empty: "list_case_compute ([]::'b list) = (\<lambda> (a::'a) f. a)"
- apply (rule ext)+
- apply (simp add: list_case_compute_def)
- done
-
-lemma list_case_compute_cons: "list_case_compute (u#v) = (\<lambda> (a::'a) f. (f (u::'b) v))"
- apply (rule ext)+
- apply (simp add: list_case_compute_def)
- done
-
-lemmas compute_list_case = list_case_compute list_case_compute_empty list_case_compute_cons
-
-(*** compute_list_nth ***)
-(* Of course, you will need computation with nats for this to work \<dots> *)
-
-lemma compute_list_nth: "((x#xs) ! n) = (if n = 0 then x else (xs ! (n - 1)))"
- by (cases n, auto)
-
-(*** compute_list ***)
-
-lemmas compute_list = compute_list_case compute_list_length compute_list_nth
-
-(*** compute_let ***)
-
-lemmas compute_let = Let_def
-
-(***********************)
-(* Everything together *)
-(***********************)
-
-lemmas compute_hol = compute_if compute_bool compute_pair compute_option compute_list compute_let
-
-ML {*
-signature ComputeHOL =
-sig
- val prep_thms : thm list -> thm list
- val to_meta_eq : thm -> thm
- val to_hol_eq : thm -> thm
- val symmetric : thm -> thm
- val trans : thm -> thm -> thm
-end
-
-structure ComputeHOL : ComputeHOL =
-struct
-
-local
-fun lhs_of eq = fst (Thm.dest_equals (cprop_of eq));
-in
-fun rewrite_conv [] ct = raise CTERM ("rewrite_conv", [])
- | rewrite_conv (eq :: eqs) ct =
- Thm.instantiate (Thm.match (lhs_of eq, ct)) eq
- handle Pattern.MATCH => rewrite_conv eqs ct;
-end
-
-val convert_conditions = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.try_conv (rewrite_conv [@{thm "Trueprop_eq_eq"}])))
-
-val eq_th = @{thm "HOL.eq_reflection"}
-val meta_eq_trivial = @{thm "ComputeHOL.meta_eq_trivial"}
-val bool_to_true = @{thm "ComputeHOL.bool_to_true"}
-
-fun to_meta_eq th = eq_th OF [th] handle THM _ => meta_eq_trivial OF [th] handle THM _ => bool_to_true OF [th]
-
-fun to_hol_eq th = @{thm "meta_eq_imp_eq"} OF [th] handle THM _ => @{thm "eq_trivial"} OF [th]
-
-fun prep_thms ths = map (convert_conditions o to_meta_eq) ths
-
-fun symmetric th = @{thm "HOL.sym"} OF [th] handle THM _ => @{thm "Pure.symmetric"} OF [th]
-
-local
- val trans_HOL = @{thm "HOL.trans"}
- val trans_HOL_1 = @{thm "ComputeHOL.transmeta_1"}
- val trans_HOL_2 = @{thm "ComputeHOL.transmeta_2"}
- val trans_HOL_3 = @{thm "ComputeHOL.transmeta_3"}
- fun tr [] th1 th2 = trans_HOL OF [th1, th2]
- | tr (t::ts) th1 th2 = (t OF [th1, th2] handle THM _ => tr ts th1 th2)
-in
- fun trans th1 th2 = tr [trans_HOL, trans_HOL_1, trans_HOL_2, trans_HOL_3] th1 th2
-end
-
-end
-*}
-
-end
--- a/src/HOL/Tools/ComputeNumeral.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,195 +0,0 @@
-theory ComputeNumeral
-imports ComputeHOL ComputeFloat
-begin
-
-(* normalization of bit strings *)
-lemmas bitnorm = normalize_bin_simps
-
-(* neg for bit strings *)
-lemma neg1: "neg Int.Pls = False" by (simp add: Int.Pls_def)
-lemma neg2: "neg Int.Min = True" apply (subst Int.Min_def) by auto
-lemma neg3: "neg (Int.Bit0 x) = neg x" apply (simp add: neg_def) apply (subst Bit0_def) by auto
-lemma neg4: "neg (Int.Bit1 x) = neg x" apply (simp add: neg_def) apply (subst Bit1_def) by auto
-lemmas bitneg = neg1 neg2 neg3 neg4
-
-(* iszero for bit strings *)
-lemma iszero1: "iszero Int.Pls = True" by (simp add: Int.Pls_def iszero_def)
-lemma iszero2: "iszero Int.Min = False" apply (subst Int.Min_def) apply (subst iszero_def) by simp
-lemma iszero3: "iszero (Int.Bit0 x) = iszero x" apply (subst Int.Bit0_def) apply (subst iszero_def)+ by auto
-lemma iszero4: "iszero (Int.Bit1 x) = False" apply (subst Int.Bit1_def) apply (subst iszero_def)+ apply simp by arith
-lemmas bitiszero = iszero1 iszero2 iszero3 iszero4
-
-(* lezero for bit strings *)
-constdefs
- "lezero x == (x \<le> 0)"
-lemma lezero1: "lezero Int.Pls = True" unfolding Int.Pls_def lezero_def by auto
-lemma lezero2: "lezero Int.Min = True" unfolding Int.Min_def lezero_def by auto
-lemma lezero3: "lezero (Int.Bit0 x) = lezero x" unfolding Int.Bit0_def lezero_def by auto
-lemma lezero4: "lezero (Int.Bit1 x) = neg x" unfolding Int.Bit1_def lezero_def neg_def by auto
-lemmas bitlezero = lezero1 lezero2 lezero3 lezero4
-
-(* equality for bit strings *)
-lemmas biteq = eq_bin_simps
-
-(* x < y for bit strings *)
-lemmas bitless = less_bin_simps
-
-(* x \<le> y for bit strings *)
-lemmas bitle = le_bin_simps
-
-(* succ for bit strings *)
-lemmas bitsucc = succ_bin_simps
-
-(* pred for bit strings *)
-lemmas bitpred = pred_bin_simps
-
-(* unary minus for bit strings *)
-lemmas bituminus = minus_bin_simps
-
-(* addition for bit strings *)
-lemmas bitadd = add_bin_simps
-
-(* multiplication for bit strings *)
-lemma mult_Pls_right: "x * Int.Pls = Int.Pls" by (simp add: Pls_def)
-lemma mult_Min_right: "x * Int.Min = - x" by (subst mult_commute, simp add: mult_Min)
-lemma multb0x: "(Int.Bit0 x) * y = Int.Bit0 (x * y)" by (rule mult_Bit0)
-lemma multxb0: "x * (Int.Bit0 y) = Int.Bit0 (x * y)" unfolding Bit0_def by simp
-lemma multb1: "(Int.Bit1 x) * (Int.Bit1 y) = Int.Bit1 (Int.Bit0 (x * y) + x + y)"
- unfolding Bit0_def Bit1_def by (simp add: algebra_simps)
-lemmas bitmul = mult_Pls mult_Min mult_Pls_right mult_Min_right multb0x multxb0 multb1
-
-lemmas bitarith = bitnorm bitiszero bitneg bitlezero biteq bitless bitle bitsucc bitpred bituminus bitadd bitmul
-
-constdefs
- "nat_norm_number_of (x::nat) == x"
-
-lemma nat_norm_number_of: "nat_norm_number_of (number_of w) = (if lezero w then 0 else number_of w)"
- apply (simp add: nat_norm_number_of_def)
- unfolding lezero_def iszero_def neg_def
- apply (simp add: numeral_simps)
- done
-
-(* Normalization of nat literals *)
-lemma natnorm0: "(0::nat) = number_of (Int.Pls)" by auto
-lemma natnorm1: "(1 :: nat) = number_of (Int.Bit1 Int.Pls)" by auto
-lemmas natnorm = natnorm0 natnorm1 nat_norm_number_of
-
-(* Suc *)
-lemma natsuc: "Suc (number_of x) = (if neg x then 1 else number_of (Int.succ x))" by (auto simp add: number_of_is_id)
-
-(* Addition for nat *)
-lemma natadd: "number_of x + ((number_of y)::nat) = (if neg x then (number_of y) else (if neg y then number_of x else (number_of (x + y))))"
- unfolding nat_number_of_def number_of_is_id neg_def
- by auto
-
-(* Subtraction for nat *)
-lemma natsub: "(number_of x) - ((number_of y)::nat) =
- (if neg x then 0 else (if neg y then number_of x else (nat_norm_number_of (number_of (x + (- y))))))"
- unfolding nat_norm_number_of
- by (auto simp add: number_of_is_id neg_def lezero_def iszero_def Let_def nat_number_of_def)
-
-(* Multiplication for nat *)
-lemma natmul: "(number_of x) * ((number_of y)::nat) =
- (if neg x then 0 else (if neg y then 0 else number_of (x * y)))"
- unfolding nat_number_of_def number_of_is_id neg_def
- by (simp add: nat_mult_distrib)
-
-lemma nateq: "(((number_of x)::nat) = (number_of y)) = ((lezero x \<and> lezero y) \<or> (x = y))"
- by (auto simp add: iszero_def lezero_def neg_def number_of_is_id)
-
-lemma natless: "(((number_of x)::nat) < (number_of y)) = ((x < y) \<and> (\<not> (lezero y)))"
- by (simp add: lezero_def numeral_simps not_le)
-
-lemma natle: "(((number_of x)::nat) \<le> (number_of y)) = (y < x \<longrightarrow> lezero x)"
- by (auto simp add: number_of_is_id lezero_def nat_number_of_def)
-
-fun natfac :: "nat \<Rightarrow> nat"
-where
- "natfac n = (if n = 0 then 1 else n * (natfac (n - 1)))"
-
-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)"
- 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)"
- unfolding number_of_eq
- apply simp
- done
-
-lemma number_less: "(((number_of x)::'a::{number_ring, ordered_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))"
- apply (subst diff_number_of_eq)
- apply simp
- done
-
-lemmas number_norm = number_of_Pls[symmetric] numeral_1_eq_1[symmetric]
-
-lemmas compute_numberarith = number_of_minus[symmetric] number_of_add[symmetric] number_diff number_of_mult[symmetric] number_norm number_eq number_le number_less
-
-lemma compute_real_of_nat_number_of: "real ((number_of v)::nat) = (if neg v then 0 else number_of v)"
- by (simp only: real_of_nat_number_of number_of_is_id)
-
-lemma compute_nat_of_int_number_of: "nat ((number_of v)::int) = (number_of v)"
- by simp
-
-lemmas compute_num_conversions = compute_real_of_nat_number_of compute_nat_of_int_number_of real_number_of
-
-lemmas zpowerarith = zpower_number_of_even
- zpower_number_of_odd[simplified zero_eq_Numeral0_nring one_eq_Numeral1_nring]
- zpower_Pls zpower_Min
-
-(* div, mod *)
-
-lemma adjust: "adjust b (q, r) = (if 0 \<le> r - b then (2 * q + 1, r - b) else (2 * q, r))"
- by (auto simp only: adjust_def)
-
-lemma negateSnd: "negateSnd (q, r) = (q, -r)"
- by (simp add: negateSnd_def)
-
-lemma divmod: "IntDiv.divmod a b = (if 0\<le>a then
- if 0\<le>b then posDivAlg a b
- else if a=0 then (0, 0)
- else negateSnd (negDivAlg (-a) (-b))
- else
- if 0<b then negDivAlg a b
- else negateSnd (posDivAlg (-a) (-b)))"
- by (auto simp only: IntDiv.divmod_def)
-
-lemmas compute_div_mod = div_def mod_def divmod adjust negateSnd posDivAlg.simps negDivAlg.simps
-
-
-
-(* collecting all the theorems *)
-
-lemma even_Pls: "even (Int.Pls) = True"
- apply (unfold Pls_def even_def)
- by simp
-
-lemma even_Min: "even (Int.Min) = False"
- apply (unfold Min_def even_def)
- by simp
-
-lemma even_B0: "even (Int.Bit0 x) = True"
- apply (unfold Bit0_def)
- by simp
-
-lemma even_B1: "even (Int.Bit1 x) = False"
- apply (unfold Bit1_def)
- by simp
-
-lemma even_number_of: "even ((number_of w)::int) = even w"
- by (simp only: number_of_is_id)
-
-lemmas compute_even = even_Pls even_Min even_B0 even_B1 even_number_of
-
-lemmas compute_numeral = compute_if compute_let compute_pair compute_bool
- compute_natarith compute_numberarith max_def min_def compute_num_conversions zpowerarith compute_div_mod compute_even
-
-end
--- a/src/HOL/Tools/Datatype/datatype.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype.ML Thu Oct 01 07:40:25 2009 +0200
@@ -26,7 +26,7 @@
val info_of_case : theory -> string -> info option
val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
val distinct_simproc : simproc
- val make_case : Proof.context -> bool -> string list -> term ->
+ val make_case : Proof.context -> DatatypeCase.config -> string list -> term ->
(term * term) list -> term * (term * (int * bool)) list
val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
val read_typ: theory ->
@@ -39,8 +39,9 @@
open DatatypeAux;
+(** theory data **)
-(* theory data *)
+(* data management *)
structure DatatypesData = TheoryDataFun
(
@@ -62,13 +63,16 @@
);
val get_all = #types o DatatypesData.get;
-val map_datatypes = DatatypesData.map;
-
+val get_info = Symtab.lookup o get_all;
+fun the_info thy name = (case get_info thy name of
+ SOME info => info
+ | NONE => error ("Unknown datatype " ^ quote name));
-(** theory information about datatypes **)
+val info_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
+val info_of_case = Symtab.lookup o #cases o DatatypesData.get;
-fun put_dt_infos (dt_infos : (string * info) list) =
- map_datatypes (fn {types, constrs, cases} =>
+fun register (dt_infos : (string * info) list) =
+ DatatypesData.map (fn {types, constrs, cases} =>
{types = fold Symtab.update dt_infos types,
constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
(maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
@@ -77,19 +81,7 @@
(map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
cases});
-val get_info = Symtab.lookup o get_all;
-
-fun the_info thy name = (case get_info thy name of
- SOME info => info
- | NONE => error ("Unknown datatype " ^ quote name));
-
-val info_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
-val info_of_case = Symtab.lookup o #cases o DatatypesData.get;
-
-fun get_info_descr thy dtco =
- get_info thy dtco
- |> Option.map (fn info as { descr, index, ... } =>
- (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
+(* complex queries *)
fun the_spec thy dtco =
let
@@ -143,71 +135,9 @@
| NONE => NONE;
-(** induct method setup **)
-
-(* case names *)
-
-local
-
-fun dt_recs (DtTFree _) = []
- | dt_recs (DtType (_, dts)) = maps dt_recs dts
- | dt_recs (DtRec i) = [i];
-
-fun dt_cases (descr: descr) (_, args, constrs) =
- let
- fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
- val bnames = map the_bname (distinct (op =) (maps dt_recs args));
- in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
-
-
-fun induct_cases descr =
- DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
-
-fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
-
-in
-
-fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
-
-fun mk_case_names_exhausts descr new =
- map (RuleCases.case_names o exhaust_cases descr o #1)
- (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
-
-end;
+(** various auxiliary **)
-fun add_rules simps case_thms rec_thms inject distinct
- weak_case_congs cong_att =
- PureThy.add_thmss [((Binding.name "simps", simps), []),
- ((Binding.empty, flat case_thms @
- flat distinct @ rec_thms), [Simplifier.simp_add]),
- ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
- ((Binding.empty, flat inject), [iff_add]),
- ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
- ((Binding.empty, weak_case_congs), [cong_att])]
- #> snd;
-
-
-(* add_cases_induct *)
-
-fun add_cases_induct infos induction thy =
- let
- val inducts = Project_Rule.projections (ProofContext.init thy) induction;
-
- fun named_rules (name, {index, exhaustion, ...}: info) =
- [((Binding.empty, nth inducts index), [Induct.induct_type name]),
- ((Binding.empty, exhaustion), [Induct.cases_type name])];
- fun unnamed_rule i =
- ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
- in
- thy |> PureThy.add_thms
- (maps named_rules infos @
- map unnamed_rule (length infos upto length inducts - 1)) |> snd
- |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
- end;
-
-
-
-(**** simplification procedure for showing distinctness of constructors ****)
+(* simplification procedure for showing distinctness of constructors *)
fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
| stripT p = p;
@@ -235,17 +165,21 @@
etac FalseE 1]))
end;
+fun get_constr thy dtco =
+ get_info thy dtco
+ |> Option.map (fn { descr, index, ... } => (#3 o the o AList.lookup (op =) descr) index);
+
fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
(case (stripC (0, t1), stripC (0, t2)) of
((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
(case (stripT (0, T1), stripT (0, T2)) of
((i', Type (tname1, _)), (j', Type (tname2, _))) =>
if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
- (case (get_info_descr thy) tname1 of
- SOME (_, (_, constrs)) => let val cnames = map fst constrs
+ (case get_constr thy tname1 of
+ SOME constrs => let val cnames = map fst constrs
in if cname1 mem cnames andalso cname2 mem cnames then
SOME (distinct_rule thy ss tname1
- (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
+ (Logic.mk_equals (t, HOLogic.false_const)))
else NONE
end
| NONE => NONE)
@@ -262,29 +196,7 @@
val simproc_setup =
Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
-
-(**** translation rules for case ****)
-
-fun make_case ctxt = DatatypeCase.make_case
- (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
-
-fun strip_case ctxt = DatatypeCase.strip_case
- (info_of_case (ProofContext.theory_of ctxt));
-
-fun add_case_tr' case_names thy =
- Sign.add_advanced_trfuns ([], [],
- map (fn case_name =>
- let val case_name' = Sign.const_syntax_name thy case_name
- in (case_name', DatatypeCase.case_tr' info_of_case case_name')
- end) case_names, []) thy;
-
-val trfun_setup =
- Sign.add_advanced_trfuns ([],
- [("_case_syntax", DatatypeCase.case_tr true info_of_constr)],
- [], []);
-
-
-(* prepare types *)
+(* prepare datatype specifications *)
fun read_typ thy ((Ts, sorts), str) =
let
@@ -304,151 +216,188 @@
| dups => error ("Inconsistent sort constraints for " ^ commas dups))
end;
+(* case names *)
-(**** make datatype info ****)
+local
+
+fun dt_recs (DtTFree _) = []
+ | dt_recs (DtType (_, dts)) = maps dt_recs dts
+ | dt_recs (DtRec i) = [i];
+
+fun dt_cases (descr: descr) (_, args, constrs) =
+ let
+ fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
+ val bnames = map the_bname (distinct (op =) (maps dt_recs args));
+ in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
+
+fun induct_cases descr =
+ DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
+
+fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
+
+in
+
+fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
+
+fun mk_case_names_exhausts descr new =
+ map (RuleCases.case_names o exhaust_cases descr o #1)
+ (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
+
+end;
+
+(* translation rules for case *)
+
+fun make_case ctxt = DatatypeCase.make_case
+ (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
+
+fun strip_case ctxt = DatatypeCase.strip_case
+ (info_of_case (ProofContext.theory_of ctxt));
-fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
- (((((((((i, (_, (tname, _, _))), case_name), case_thms),
- exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
- (tname,
- {index = i,
- alt_names = alt_names,
- descr = descr,
- sorts = sorts,
- rec_names = reccomb_names,
- rec_rewrites = rec_thms,
- case_name = case_name,
- case_rewrites = case_thms,
- induction = induct,
- exhaustion = exhaustion_thm,
- distinct = distinct_thm,
- inject = inject,
- nchotomy = nchotomy,
- case_cong = case_cong,
- weak_case_cong = weak_case_cong});
+fun add_case_tr' case_names thy =
+ Sign.add_advanced_trfuns ([], [],
+ map (fn case_name =>
+ let val case_name' = Sign.const_syntax_name thy case_name
+ in (case_name', DatatypeCase.case_tr' info_of_case case_name')
+ end) case_names, []) thy;
+
+val trfun_setup =
+ Sign.add_advanced_trfuns ([],
+ [("_case_syntax", DatatypeCase.case_tr true info_of_constr)],
+ [], []);
+
+(* document antiquotation *)
+
+val _ = ThyOutput.antiquotation "datatype" Args.tyname
+ (fn {source = src, context = ctxt, ...} => fn dtco =>
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val (vs, cos) = the_spec thy dtco;
+ val ty = Type (dtco, map TFree vs);
+ fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
+ Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
+ | pretty_typ_bracket ty =
+ Syntax.pretty_typ ctxt ty;
+ fun pretty_constr (co, tys) =
+ (Pretty.block o Pretty.breaks)
+ (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
+ map pretty_typ_bracket tys);
+ val pretty_datatype =
+ Pretty.block
+ (Pretty.command "datatype" :: Pretty.brk 1 ::
+ Syntax.pretty_typ ctxt ty ::
+ Pretty.str " =" :: Pretty.brk 1 ::
+ flat (separate [Pretty.brk 1, Pretty.str "| "]
+ (map (single o pretty_constr) cos)));
+ in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
+
+
+(** abstract theory extensions relative to a datatype characterisation **)
structure DatatypeInterpretation = InterpretationFun
(type T = config * string list val eq: T * T -> bool = eq_snd op =);
fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
-
-(******************* definitional introduction of datatypes *******************)
+fun make_dt_info alt_names descr sorts induct inducts rec_names rec_rewrites
+ (index, (((((((((((_, (tname, _, _))), inject), distinct),
+ exhaust), nchotomy), case_name), case_rewrites), case_cong), weak_case_cong), (split, split_asm))) =
+ (tname,
+ {index = index,
+ alt_names = alt_names,
+ descr = descr,
+ sorts = sorts,
+ inject = inject,
+ distinct = distinct,
+ induct = induct,
+ inducts = inducts,
+ exhaust = exhaust,
+ nchotomy = nchotomy,
+ rec_names = rec_names,
+ rec_rewrites = rec_rewrites,
+ case_name = case_name,
+ case_rewrites = case_rewrites,
+ case_cong = case_cong,
+ weak_case_cong = weak_case_cong,
+ split = split,
+ split_asm = split_asm});
-fun add_datatype_def (config : config) new_type_names descr sorts types_syntax constr_syntax dt_info
- case_names_induct case_names_exhausts thy =
+fun derive_datatype_props config dt_names alt_names descr sorts
+ induct inject (distinct_rules, distinct_rewrites, distinct_entry) thy1 =
let
- val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
-
- val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
- DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
- types_syntax constr_syntax case_names_induct;
+ val thy2 = thy1 |> Theory.checkpoint;
+ val flat_descr = flat descr;
+ val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
+ val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
- val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
- sorts induct case_names_exhausts thy2;
- val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
- config new_type_names descr sorts dt_info inject dist_rewrites
- (Simplifier.theory_context thy3 dist_ss) induct thy3;
- val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
- config new_type_names descr sorts reccomb_names rec_thms thy4;
- val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
- descr sorts inject dist_rewrites casedist_thms case_thms thy6;
- val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
- descr sorts casedist_thms thy7;
- val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
- descr sorts nchotomys case_thms thy8;
- val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
- descr sorts thy9;
+ val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names
+ descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
+ val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names
+ descr sorts exhaust thy3;
+ val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms
+ config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
+ inject distinct_rewrites (Simplifier.theory_context thy4 dist_ss) induct thy4;
+ val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
+ config new_type_names descr sorts rec_names rec_rewrites thy5;
+ val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
+ descr sorts nchotomys case_rewrites thy6;
+ val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
+ descr sorts thy7;
+ val (splits, thy9) = DatatypeAbsProofs.prove_split_thms
+ config new_type_names descr sorts inject distinct_rewrites exhaust case_rewrites thy8;
- val dt_infos = map
- (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
- ((0 upto length (hd descr) - 1) ~~ hd descr ~~ case_names ~~ case_thms ~~
- casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
-
- val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
+ val inducts = Project_Rule.projections (ProofContext.init thy2) induct;
+ val dt_infos = map_index (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites)
+ (hd descr ~~ inject ~~ distinct_entry ~~ exhaust ~~ nchotomys ~~
+ case_names ~~ case_rewrites ~~ case_congs ~~ weak_case_congs ~~ splits);
val dt_names = map fst dt_infos;
-
- val thy12 =
- thy10
- |> add_case_tr' case_names
- |> Sign.add_path (space_implode "_" new_type_names)
- |> add_rules simps case_thms rec_thms inject distinct
- weak_case_congs (Simplifier.attrib (op addcongs))
- |> put_dt_infos dt_infos
- |> add_cases_induct dt_infos induct
- |> Sign.parent_path
- |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
- |> DatatypeInterpretation.data (config, map fst dt_infos);
- in (dt_names, thy12) end;
+ val prfx = Binding.qualify true (space_implode "_" new_type_names);
+ val simps = flat (inject @ distinct_rules @ case_rewrites) @ rec_rewrites;
+ val named_rules = flat (map_index (fn (index, tname) =>
+ [((Binding.empty, [nth inducts index]), [Induct.induct_type tname]),
+ ((Binding.empty, [nth exhaust index]), [Induct.cases_type tname])]) dt_names);
+ val unnamed_rules = map (fn induct =>
+ ((Binding.empty, [induct]), [Thm.kind_internal, Induct.induct_type ""]))
+ (Library.drop (length dt_names, inducts));
+ in
+ thy9
+ |> PureThy.add_thmss ([((prfx (Binding.name "simps"), simps), []),
+ ((prfx (Binding.name "inducts"), inducts), []),
+ ((prfx (Binding.name "splits"), maps (fn (x, y) => [x, y]) splits), []),
+ ((Binding.empty, flat case_rewrites @ flat distinct_rules @ rec_rewrites),
+ [Simplifier.simp_add]),
+ ((Binding.empty, rec_rewrites), [Code.add_default_eqn_attribute]),
+ ((Binding.empty, flat inject), [iff_add]),
+ ((Binding.empty, map (fn th => th RS notE) (flat distinct_rules)),
+ [Classical.safe_elim NONE]),
+ ((Binding.empty, weak_case_congs), [Simplifier.attrib (op addcongs)])]
+ @ named_rules @ unnamed_rules)
+ |> snd
+ |> add_case_tr' case_names
+ |> register dt_infos
+ |> DatatypeInterpretation.data (config, dt_names)
+ |> pair dt_names
+ end;
-(*********************** declare existing type as datatype *********************)
-
-fun prove_rep_datatype (config : config) alt_names new_type_names descr sorts induct inject half_distinct thy =
- let
- val ((_, [induct']), _) =
- Variable.importT [induct] (Variable.thm_context induct);
-
- fun err t = error ("Ill-formed predicate in induction rule: " ^
- Syntax.string_of_term_global thy t);
-
- fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
- ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
- | get_typ t = err t;
- val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
-
- val dt_info = get_all thy;
-
- val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
- val (case_names_induct, case_names_exhausts) =
- (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
-
- val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
+(** declare existing type as datatype **)
- val (casedist_thms, thy2) = thy |>
- DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
- case_names_exhausts;
- val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
- config new_type_names [descr] sorts dt_info inject distinct
- (Simplifier.theory_context thy2 dist_ss) induct thy2;
- val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
- config new_type_names [descr] sorts reccomb_names rec_thms thy3;
- val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
- config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
- val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
- [descr] sorts casedist_thms thy5;
- val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
- [descr] sorts nchotomys case_thms thy6;
- val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
- [descr] sorts thy7;
-
- val ((_, [induct']), thy10) =
- thy8
- |> store_thmss "inject" new_type_names inject
- ||>> store_thmss "distinct" new_type_names distinct
+fun prove_rep_datatype config dt_names alt_names descr sorts raw_inject half_distinct raw_induct thy1 =
+ let
+ val raw_distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
+ val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
+ val (((inject, distinct), [induct]), thy2) =
+ thy1
+ |> store_thmss "inject" new_type_names raw_inject
+ ||>> store_thmss "distinct" new_type_names raw_distinct
||> Sign.add_path (space_implode "_" new_type_names)
- ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
-
- val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
- ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
- map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
-
- val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
- val dt_names = map fst dt_infos;
+ ||>> PureThy.add_thms [((Binding.name "induct", raw_induct), [mk_case_names_induct descr])]
+ ||> Sign.restore_naming thy1;
+ in
+ thy2
+ |> derive_datatype_props config dt_names alt_names [descr] sorts
+ induct inject (distinct, distinct, map FewConstrs distinct)
+ end;
- val thy11 =
- thy10
- |> add_case_tr' case_names
- |> add_rules simps case_thms rec_thms inject distinct
- weak_case_congs (Simplifier.attrib (op addcongs))
- |> put_dt_infos dt_infos
- |> add_cases_induct dt_infos induct'
- |> Sign.parent_path
- |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
- |> snd
- |> DatatypeInterpretation.data (config, dt_names);
- in (dt_names, thy11) end;
-
-fun gen_rep_datatype prep_term (config : config) after_qed alt_names raw_ts thy =
+fun gen_rep_datatype prep_term config after_qed alt_names raw_ts thy =
let
fun constr_of_term (Const (c, T)) = (c, T)
| constr_of_term t =
@@ -486,7 +435,7 @@
val cs = map (apsnd (map norm_constr)) raw_cs;
val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
o fst o strip_type;
- val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
+ val dt_names = map fst cs;
fun mk_spec (i, (tyco, constr)) = (i, (tyco,
map (DtTFree o fst) vs,
@@ -499,12 +448,12 @@
fun after_qed' raw_thms =
let
- val [[[induct]], injs, half_distincts] =
+ val [[[raw_induct]], raw_inject, half_distinct] =
unflat rules (map Drule.zero_var_indexes_list raw_thms);
(*FIXME somehow dubious*)
in
ProofContext.theory_result
- (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
+ (prove_rep_datatype config dt_names alt_names descr vs raw_inject half_distinct raw_induct)
#-> after_qed
end;
in
@@ -517,15 +466,13 @@
val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_config (K I);
+(** definitional introduction of datatypes **)
-(******************************** add datatype ********************************)
-
-fun gen_add_datatype prep_typ (config : config) new_type_names dts thy =
+fun gen_add_datatype prep_typ config new_type_names dts thy =
let
val _ = Theory.requires thy "Datatype" "datatype definitions";
(* this theory is used just for parsing *)
-
val tmp_thy = thy |>
Theory.copy |>
Sign.add_types (map (fn (tvs, tname, mx, _) =>
@@ -540,6 +487,7 @@
| dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
" : " ^ commas dups))
end) dts);
+ val dt_names = map fst new_dts;
val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
[] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
@@ -582,20 +530,19 @@
if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
else raise exn;
- val descr' = flat descr;
- val case_names_induct = mk_case_names_induct descr';
- val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
+ val _ = message config ("Constructing datatype(s) " ^ commas_quote new_type_names);
+ val ((inject, distinct_rules, distinct_rewrites, distinct_entry, induct), thy') = thy |>
+ DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
+ types_syntax constr_syntax (mk_case_names_induct (flat descr));
in
- add_datatype_def
- (config : config) new_type_names descr sorts types_syntax constr_syntax dt_info
- case_names_induct case_names_exhausts thy
+ derive_datatype_props config dt_names (SOME new_type_names) descr sorts
+ induct inject (distinct_rules, distinct_rewrites, distinct_entry) thy'
end;
val add_datatype = gen_add_datatype cert_typ;
val datatype_cmd = snd ooo gen_add_datatype read_typ default_config;
-
(** package setup **)
(* setup theory *)
@@ -606,7 +553,6 @@
trfun_setup #>
DatatypeInterpretation.init;
-
(* outer syntax *)
local
@@ -641,31 +587,5 @@
end;
-
-(* document antiquotation *)
-
-val _ = ThyOutput.antiquotation "datatype" Args.tyname
- (fn {source = src, context = ctxt, ...} => fn dtco =>
- let
- val thy = ProofContext.theory_of ctxt;
- val (vs, cos) = the_spec thy dtco;
- val ty = Type (dtco, map TFree vs);
- fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
- Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
- | pretty_typ_bracket ty =
- Syntax.pretty_typ ctxt ty;
- fun pretty_constr (co, tys) =
- (Pretty.block o Pretty.breaks)
- (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
- map pretty_typ_bracket tys);
- val pretty_datatype =
- Pretty.block
- (Pretty.command "datatype" :: Pretty.brk 1 ::
- Syntax.pretty_typ ctxt ty ::
- Pretty.str " =" :: Pretty.brk 1 ::
- flat (separate [Pretty.brk 1, Pretty.str "| "]
- (map (single o pretty_constr) cos)));
- in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
-
end;
--- a/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -20,7 +20,7 @@
attribute list -> theory -> thm list * theory
val prove_primrec_thms : config -> string list ->
descr list -> (string * sort) list ->
- info Symtab.table -> thm list list -> thm list list ->
+ (string -> thm list) -> thm list list -> thm list list ->
simpset -> thm -> theory -> (string list * thm list) * theory
val prove_case_thms : config -> string list ->
descr list -> (string * sort) list ->
@@ -88,7 +88,7 @@
(*************************** primrec combinators ******************************)
fun prove_primrec_thms (config : config) new_type_names descr sorts
- (dt_info : info Symtab.table) constr_inject dist_rewrites dist_ss induct thy =
+ injects_of constr_inject dist_rewrites dist_ss induct thy =
let
val _ = message config "Constructing primrec combinators ...";
@@ -174,11 +174,11 @@
val inject = map (fn r => r RS iffD1)
(if i < length newTs then List.nth (constr_inject, i)
- else #inject (the (Symtab.lookup dt_info tname)));
+ else injects_of tname);
fun mk_unique_constr_tac n ((tac, intr::intrs, j), (cname, cargs)) =
let
- val k = length (List.filter is_rec_type cargs)
+ val k = length (filter is_rec_type cargs)
in (EVERY [DETERM tac,
REPEAT (etac ex1E 1), rtac ex1I 1,
--- a/src/HOL/Tools/Datatype/datatype_aux.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype_aux.ML Thu Oct 01 07:40:25 2009 +0200
@@ -35,7 +35,6 @@
val app_bnds : term -> int -> term
- val cong_tac : int -> tactic
val indtac : thm -> string list -> int -> tactic
val exh_tac : (string -> thm) -> int -> tactic
@@ -112,21 +111,6 @@
fun app_bnds t i = list_comb (t, map Bound (i - 1 downto 0));
-fun cong_tac i st = (case Logic.strip_assums_concl
- (List.nth (prems_of st, i - 1)) of
- _ $ (_ $ (f $ x) $ (g $ y)) =>
- let
- val cong' = Thm.lift_rule (Thm.cprem_of st i) cong;
- val _ $ (_ $ (f' $ x') $ (g' $ y')) =
- Logic.strip_assums_concl (prop_of cong');
- val insts = map (pairself (cterm_of (Thm.theory_of_thm st)) o
- apsnd (curry list_abs (Logic.strip_params (concl_of cong'))) o
- apfst head_of) [(f', f), (g', g), (x', x), (y', y)]
- in compose_tac (false, cterm_instantiate insts cong', 2) i st
- handle THM _ => no_tac st
- end
- | _ => no_tac st);
-
(* instantiate induction rule *)
fun indtac indrule indnames i st =
@@ -191,17 +175,20 @@
alt_names : string list option,
descr : descr,
sorts : (string * sort) list,
+ inject : thm list,
+ distinct : simproc_dist,
+ induct : thm,
+ inducts : thm list,
+ exhaust : thm,
+ nchotomy : thm,
rec_names : string list,
rec_rewrites : thm list,
case_name : string,
case_rewrites : thm list,
- induction : thm,
- exhaustion : thm,
- distinct : simproc_dist,
- inject : thm list,
- nchotomy : thm,
case_cong : thm,
- weak_case_cong : thm};
+ weak_case_cong : thm,
+ split : thm,
+ split_asm: thm};
fun mk_Free s T i = Free (s ^ (string_of_int i), T);
--- a/src/HOL/Tools/Datatype/datatype_case.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype_case.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,8 +7,9 @@
signature DATATYPE_CASE =
sig
+ datatype config = Error | Warning | Quiet;
val make_case: (string -> DatatypeAux.info option) ->
- Proof.context -> bool -> string list -> term -> (term * term) list ->
+ Proof.context -> config -> string list -> term -> (term * term) list ->
term * (term * (int * bool)) list
val dest_case: (string -> DatatypeAux.info option) -> bool ->
string list -> term -> (term * (term * term) list) option
@@ -23,6 +24,8 @@
structure DatatypeCase : DATATYPE_CASE =
struct
+datatype config = Error | Warning | Quiet;
+
exception CASE_ERROR of string * int;
fun match_type thy pat ob = Sign.typ_match thy (pat, ob) Vartab.empty;
@@ -260,7 +263,7 @@
else x :: xs)
| _ => I) pat [];
-fun gen_make_case ty_match ty_inst type_of tab ctxt err used x clauses =
+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);
@@ -285,7 +288,7 @@
val originals = map (row_of_pat o #2) rows
val _ = case originals \\ finals of
[] => ()
- | is => (if err then case_error else warning)
+ | 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
@@ -338,7 +341,8 @@
fun dest_case2 (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 err []
+ 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)
(flat cnstrts) t) cases;
in case_tm end
--- a/src/HOL/Tools/Datatype/datatype_realizer.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype_realizer.ML Thu Oct 01 07:40:25 2009 +0200
@@ -38,7 +38,7 @@
fun mk_realizes T = Const ("realizes", T --> HOLogic.boolT --> HOLogic.boolT);
-fun make_ind sorts ({descr, rec_names, rec_rewrites, induction, ...} : info) is thy =
+fun make_ind sorts ({descr, rec_names, rec_rewrites, induct, ...} : info) is thy =
let
val recTs = get_rec_types descr sorts;
val pnames = if length descr = 1 then ["P"]
@@ -113,18 +113,18 @@
(descr ~~ recTs ~~ rec_result_Ts ~~ tnames)));
val cert = cterm_of thy;
val inst = map (pairself cert) (map head_of (HOLogic.dest_conj
- (HOLogic.dest_Trueprop (concl_of induction))) ~~ ps);
+ (HOLogic.dest_Trueprop (concl_of induct))) ~~ ps);
val thm = OldGoals.simple_prove_goal_cterm (cert (Logic.list_implies (prems, concl)))
(fn prems =>
[rewrite_goals_tac (map mk_meta_eq [fst_conv, snd_conv]),
- rtac (cterm_instantiate inst induction) 1,
+ rtac (cterm_instantiate inst induct) 1,
ALLGOALS ObjectLogic.atomize_prems_tac,
rewrite_goals_tac (@{thm o_def} :: map mk_meta_eq rec_rewrites),
REPEAT ((resolve_tac prems THEN_ALL_NEW (fn i =>
REPEAT (etac allE i) THEN atac i)) 1)]);
- val ind_name = Thm.get_name induction;
+ val ind_name = Thm.get_name induct;
val vs = map (fn i => List.nth (pnames, i)) is;
val (thm', thy') = thy
|> Sign.root_path
@@ -157,7 +157,7 @@
in Extraction.add_realizers_i [(ind_name, (vs, r', prf))] thy' end;
-fun make_casedists sorts ({index, descr, case_name, case_rewrites, exhaustion, ...} : info) thy =
+fun make_casedists sorts ({index, descr, case_name, case_rewrites, exhaust, ...} : info) thy =
let
val cert = cterm_of thy;
val rT = TFree ("'P", HOLogic.typeS);
@@ -187,12 +187,12 @@
HOLogic.mk_Trueprop (Free ("P", rT --> HOLogic.boolT) $
list_comb (r, rs @ [y'])))))
(fn prems =>
- [rtac (cterm_instantiate [(cert y, cert y')] exhaustion) 1,
+ [rtac (cterm_instantiate [(cert y, cert y')] exhaust) 1,
ALLGOALS (EVERY'
[asm_simp_tac (HOL_basic_ss addsimps case_rewrites),
resolve_tac prems, asm_simp_tac HOL_basic_ss])]);
- val exh_name = Thm.get_name exhaustion;
+ val exh_name = Thm.get_name exhaust;
val (thm', thy') = thy
|> Sign.root_path
|> PureThy.store_thm (Binding.qualified_name (exh_name ^ "_P_correctness"), thm)
@@ -210,7 +210,7 @@
in Extraction.add_realizers_i
[(exh_name, (["P"], r', prf)),
- (exh_name, ([], Extraction.nullt, prf_of exhaustion))] thy'
+ (exh_name, ([], Extraction.nullt, prf_of exhaust))] thy'
end;
fun add_dt_realizers config names thy =
--- a/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -38,7 +38,7 @@
(** theory context references **)
fun exh_thm_of (dt_info : info Symtab.table) tname =
- #exhaustion (the (Symtab.lookup dt_info tname));
+ #exhaust (the (Symtab.lookup dt_info tname));
(******************************************************************************)
@@ -78,7 +78,7 @@
val leafTs' = get_nonrec_types descr' sorts;
val branchTs = get_branching_types descr' sorts;
val branchT = if null branchTs then HOLogic.unitT
- else BalancedTree.make (fn (T, U) => Type ("+", [T, U])) branchTs;
+ else Balanced_Tree.make (fn (T, U) => Type ("+", [T, U])) branchTs;
val arities = get_arities descr' \ 0;
val unneeded_vars = hd tyvars \\ List.foldr OldTerm.add_typ_tfree_names [] (leafTs' @ branchTs);
val leafTs = leafTs' @ (map (fn n => TFree (n, (the o AList.lookup (op =) sorts) n)) unneeded_vars);
@@ -86,7 +86,7 @@
val newTs = Library.take (length (hd descr), recTs);
val oldTs = Library.drop (length (hd descr), recTs);
val sumT = if null leafTs then HOLogic.unitT
- else BalancedTree.make (fn (T, U) => Type ("+", [T, U])) leafTs;
+ else Balanced_Tree.make (fn (T, U) => Type ("+", [T, U])) leafTs;
val Univ_elT = HOLogic.mk_setT (Type (node_name, [sumT, branchT]));
val UnivT = HOLogic.mk_setT Univ_elT;
val UnivT' = Univ_elT --> HOLogic.boolT;
@@ -116,7 +116,7 @@
(* make injections for constructors *)
- fun mk_univ_inj ts = BalancedTree.access
+ fun mk_univ_inj ts = Balanced_Tree.access
{left = fn t => In0 $ t,
right = fn t => In1 $ t,
init =
@@ -389,7 +389,7 @@
fun prove_iso_thms (ds, (inj_thms, elem_thms)) =
let
val (_, (tname, _, _)) = hd ds;
- val {induction, ...} = the (Symtab.lookup dt_info tname);
+ val induct = (#induct o the o Symtab.lookup dt_info) tname;
fun mk_ind_concl (i, _) =
let
@@ -410,7 +410,7 @@
val inj_thm = SkipProof.prove_global thy5 [] []
(HOLogic.mk_Trueprop (mk_conj ind_concl1)) (fn _ => EVERY
- [(indtac induction [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
+ [(indtac induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
REPEAT (EVERY
[rtac allI 1, rtac impI 1,
exh_tac (exh_thm_of dt_info) 1,
@@ -436,7 +436,7 @@
val elem_thm =
SkipProof.prove_global thy5 [] [] (HOLogic.mk_Trueprop (mk_conj ind_concl2))
(fn _ =>
- EVERY [(indtac induction [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
+ EVERY [(indtac induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
rewrite_goals_tac rewrites,
REPEAT ((resolve_tac rep_intrs THEN_ALL_NEW
((REPEAT o etac allE) THEN' ares_tac elem_thms)) 1)]);
--- a/src/HOL/Tools/Function/decompose.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/decompose.ML Thu Oct 01 07:40:25 2009 +0200
@@ -29,7 +29,7 @@
fun prove_chain c1 c2 D =
if is_some (Termination.get_chain D c1 c2) then D else
let
- val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name "Relation.rel_comp"} (c1, c2),
+ val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name Relation.rel_comp} (c1, c2),
Const (@{const_name Set.empty}, fastype_of c1))
|> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *)
--- a/src/HOL/Tools/Function/fundef_common.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/fundef_common.ML Thu Oct 01 07:40:25 2009 +0200
@@ -11,12 +11,12 @@
local open FundefLib in
(* Profiling *)
-val profile = ref false;
+val profile = Unsynchronized.ref false;
fun PROFILE msg = if !profile then timeap_msg msg else I
-val acc_const_name = @{const_name "accp"}
+val acc_const_name = @{const_name accp}
fun mk_acc domT R =
Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R
--- a/src/HOL/Tools/Function/fundef_core.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/fundef_core.ML Thu Oct 01 07:40:25 2009 +0200
@@ -478,7 +478,7 @@
fun define_function fdefname (fname, mixfix) domT ranT G default lthy =
let
val f_def =
- Abs ("x", domT, Const ("FunDef.THE_default", ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $
+ Abs ("x", domT, Const (@{const_name FunDef.THE_default}, ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $
Abs ("y", ranT, G $ Bound 1 $ Bound 0))
|> Syntax.check_term lthy
@@ -577,8 +577,6 @@
val acc_subset_induct = @{thm Orderings.predicate1I} RS @{thm accp_subset_induct}
-fun binder_conv cv ctxt = Conv.arg_conv (Conv.abs_conv (K cv) ctxt);
-
fun mk_partial_induct_rule thy globals R complete_thm clauses =
let
val Globals {domT, x, z, a, P, D, ...} = globals
@@ -614,7 +612,7 @@
val case_hyp_conv = K (case_hyp RS eq_reflection)
local open Conv in
val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
- val sih = fconv_rule (binder_conv (arg1_conv (arg_conv (arg_conv case_hyp_conv))) ctxt) aihyp
+ val sih = fconv_rule (More_Conv.binder_conv (K (arg1_conv (arg_conv (arg_conv case_hyp_conv)))) ctxt) aihyp
end
fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) =
@@ -769,9 +767,9 @@
val R' = Free ("R", fastype_of R)
val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
- val inrel_R = Const ("FunDef.in_rel", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
+ val inrel_R = Const (@{const_name FunDef.in_rel}, HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
- val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name "Wellfounded.wfP"}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
+ val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
(* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
val ihyp = Term.all domT $ Abs ("z", domT,
--- a/src/HOL/Tools/Function/fundef_datatype.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/fundef_datatype.ML Thu Oct 01 07:40:25 2009 +0200
@@ -145,7 +145,7 @@
let
val T = fastype_of v
val (tname, _) = dest_Type T
- val {exhaustion=case_thm, ...} = Datatype.the_info thy tname
+ val {exhaust=case_thm, ...} = Datatype.the_info thy tname
val constrs = inst_constrs_of thy T
val c_cases = map (constr_case thy P idx (v :: vs) pts) constrs
in
--- a/src/HOL/Tools/Function/fundef_lib.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/fundef_lib.ML Thu Oct 01 07:40:25 2009 +0200
@@ -170,7 +170,7 @@
end
(* instance for unions *)
-fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Set.union}
+fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Lattices.sup}
(map (fn t => t RS eq_reflection) (@{thms Un_ac} @
@{thms Un_empty_right} @
@{thms Un_empty_left})) t
--- a/src/HOL/Tools/Function/induction_scheme.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/induction_scheme.ML Thu Oct 01 07:40:25 2009 +0200
@@ -120,7 +120,7 @@
fun PT_of (SchemeBranch { xs, ...}) =
foldr1 HOLogic.mk_prodT (map snd xs)
- val ST = BalancedTree.make (uncurry SumTree.mk_sumT) (map PT_of branches)
+ val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) (map PT_of branches)
in
IndScheme {T=ST, cases=map mk_case cases', branches=branches }
end
@@ -152,7 +152,7 @@
end
fun mk_wf ctxt R (IndScheme {T, ...}) =
- HOLogic.Trueprop $ (Const (@{const_name "wf"}, mk_relT T --> HOLogic.boolT) $ R)
+ HOLogic.Trueprop $ (Const (@{const_name wf}, mk_relT T --> HOLogic.boolT) $ R)
fun mk_ineqs R (IndScheme {T, cases, branches}) =
let
--- a/src/HOL/Tools/Function/lexicographic_order.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/lexicographic_order.ML Thu Oct 01 07:40:25 2009 +0200
@@ -26,7 +26,7 @@
val mlexT = (domT --> HOLogic.natT) --> relT --> relT
fun mk_ms [] = Const (@{const_name Set.empty}, relT)
| mk_ms (f::fs) =
- Const (@{const_name "mlex_prod"}, mlexT) $ f $ mk_ms fs
+ Const (@{const_name mlex_prod}, mlexT) $ f $ mk_ms fs
in
mk_ms mfuns
end
--- a/src/HOL/Tools/Function/measure_functions.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/measure_functions.ML Thu Oct 01 07:40:25 2009 +0200
@@ -22,7 +22,7 @@
val description = "Rules that guide the heuristic generation of measure functions"
);
-fun mk_is_measures t = Const (@{const_name "is_measure"}, fastype_of t --> HOLogic.boolT) $ t
+fun mk_is_measures t = Const (@{const_name is_measure}, fastype_of t --> HOLogic.boolT) $ t
fun find_measures ctxt T =
DEPTH_SOLVE (resolve_tac (Measure_Heuristic_Rules.get ctxt) 1)
--- a/src/HOL/Tools/Function/mutual.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/mutual.ML Thu Oct 01 07:40:25 2009 +0200
@@ -103,8 +103,8 @@
val dresultTs = distinct (op =) resultTs
val n' = length dresultTs
- val RST = BalancedTree.make (uncurry SumTree.mk_sumT) dresultTs
- val ST = BalancedTree.make (uncurry SumTree.mk_sumT) argTs
+ val RST = Balanced_Tree.make (uncurry SumTree.mk_sumT) dresultTs
+ val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) argTs
val fsum_type = ST --> RST
--- a/src/HOL/Tools/Function/scnp_solve.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/scnp_solve.ML Thu Oct 01 07:40:25 2009 +0200
@@ -23,7 +23,7 @@
val generate_certificate : bool -> label list -> graph_problem -> certificate option
- val solver : string ref
+ val solver : string Unsynchronized.ref
end
structure ScnpSolve : SCNP_SOLVE =
@@ -71,7 +71,7 @@
fun exactly_one n f = iexists n (the_one f n)
(* SAT solving *)
-val solver = ref "auto";
+val solver = Unsynchronized.ref "auto";
fun sat_solver x =
FundefCommon.PROFILE "sat_solving..." (SatSolver.invoke_solver (!solver)) x
--- a/src/HOL/Tools/Function/size.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/size.ML Thu Oct 01 07:40:25 2009 +0200
@@ -59,7 +59,7 @@
fun prove_size_thms (info : info) new_type_names thy =
let
- val {descr, alt_names, sorts, rec_names, rec_rewrites, induction, ...} = info;
+ val {descr, alt_names, sorts, rec_names, rec_rewrites, induct, ...} = info;
val l = length new_type_names;
val alt_names' = (case alt_names of
NONE => replicate l NONE | SOME names => map SOME names);
@@ -169,7 +169,7 @@
map (mk_unfolded_size_eq (AList.lookup op =
(new_type_names ~~ map (app fs) rec_combs1)) size_ofp fs)
(xs ~~ recTs2 ~~ rec_combs2))))
- (fn _ => (indtac induction xs THEN_ALL_NEW asm_simp_tac simpset1) 1));
+ (fn _ => (indtac induct xs THEN_ALL_NEW asm_simp_tac simpset1) 1));
val unfolded_size_eqs1 = prove_unfolded_size_eqs param_size fs;
val unfolded_size_eqs2 = prove_unfolded_size_eqs (K NONE) fs';
--- a/src/HOL/Tools/Function/sum_tree.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/sum_tree.ML Thu Oct 01 07:40:25 2009 +0200
@@ -13,30 +13,30 @@
(* top-down access in balanced tree *)
fun access_top_down {left, right, init} len i =
- BalancedTree.access {left = (fn f => f o left), right = (fn f => f o right), init = I} len i init
+ Balanced_Tree.access {left = (fn f => f o left), right = (fn f => f o right), init = I} len i init
(* Sum types *)
fun mk_sumT LT RT = Type ("+", [LT, RT])
-fun mk_sumcase TL TR T l r = Const (@{const_name "sum.sum_case"}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
+fun mk_sumcase TL TR T l r = Const (@{const_name sum.sum_case}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
val App = curry op $
fun mk_inj ST n i =
access_top_down
{ init = (ST, I : term -> term),
- left = (fn (T as Type ("+", [LT, RT]), inj) => (LT, inj o App (Const (@{const_name "Inl"}, LT --> T)))),
- right =(fn (T as Type ("+", [LT, RT]), inj) => (RT, inj o App (Const (@{const_name "Inr"}, RT --> T))))} n i
+ left = (fn (T as Type ("+", [LT, RT]), inj) => (LT, inj o App (Const (@{const_name Inl}, LT --> T)))),
+ right =(fn (T as Type ("+", [LT, RT]), inj) => (RT, inj o App (Const (@{const_name Inr}, RT --> T))))} n i
|> snd
fun mk_proj ST n i =
access_top_down
{ init = (ST, I : term -> term),
- left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name "Datatype.Projl"}, T --> LT)) o proj)),
- right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name "Datatype.Projr"}, T --> RT)) o proj))} n i
+ left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name Datatype.Projl}, T --> LT)) o proj)),
+ right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name Datatype.Projr}, T --> RT)) o proj))} n i
|> snd
fun mk_sumcases T fs =
- BalancedTree.make (fn ((f, fT), (g, gT)) => (mk_sumcase fT gT T f g, mk_sumT fT gT))
+ Balanced_Tree.make (fn ((f, fT), (g, gT)) => (mk_sumcase fT gT T f g, mk_sumT fT gT))
(map (fn f => (f, domain_type (fastype_of f))) fs)
|> fst
--- a/src/HOL/Tools/Function/termination.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Function/termination.ML Thu Oct 01 07:40:25 2009 +0200
@@ -79,14 +79,14 @@
(* concrete versions for sum types *)
-fun is_inj (Const ("Sum_Type.Inl", _) $ _) = true
- | is_inj (Const ("Sum_Type.Inr", _) $ _) = true
+fun is_inj (Const (@{const_name Sum_Type.Inl}, _) $ _) = true
+ | is_inj (Const (@{const_name Sum_Type.Inr}, _) $ _) = true
| is_inj _ = false
-fun dest_inl (Const ("Sum_Type.Inl", _) $ t) = SOME t
+fun dest_inl (Const (@{const_name Sum_Type.Inl}, _) $ t) = SOME t
| dest_inl _ = NONE
-fun dest_inr (Const ("Sum_Type.Inr", _) $ t) = SOME t
+fun dest_inr (Const (@{const_name Sum_Type.Inr}, _) $ t) = SOME t
| dest_inr _ = NONE
@@ -145,8 +145,8 @@
fun mk_sum_skel rel =
let
- val cs = FundefLib.dest_binop_list @{const_name union} rel
- fun collect_pats (Const ("Collect", _) $ Abs (_, _, c)) =
+ val cs = FundefLib.dest_binop_list @{const_name Lattices.sup} rel
+ fun collect_pats (Const (@{const_name Collect}, _) $ Abs (_, _, c)) =
let
val (Const ("op &", _) $ (Const ("op =", _) $ _ $ (Const ("Pair", _) $ r $ l)) $ Gam)
= Term.strip_qnt_body "Ex" c
@@ -179,7 +179,7 @@
fun get_descent (_, _, _, _, D) c m1 m2 =
Term3tab.lookup D (c, (m1, m2))
-fun dest_call D (Const ("Collect", _) $ Abs (_, _, c)) =
+fun dest_call D (Const (@{const_name Collect}, _) $ Abs (_, _, c)) =
let
val n = get_num_points D
val (sk, _, _, _, _) = D
@@ -233,13 +233,13 @@
fun CALLS tac i st =
if Thm.no_prems st then all_tac st
else case Thm.term_of (Thm.cprem_of st i) of
- (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name union} rel, i) st
+ (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name Lattices.sup} rel, i) st
|_ => no_tac st
type ttac = (data -> int -> tactic) -> (data -> int -> tactic) -> data -> int -> tactic
fun TERMINATION ctxt tac =
- SUBGOAL (fn (_ $ (Const (@{const_name "wf"}, wfT) $ rel), i) =>
+ SUBGOAL (fn (_ $ (Const (@{const_name wf}, wfT) $ rel), i) =>
let
val (T, _) = HOLogic.dest_prodT (HOLogic.dest_setT (domain_type wfT))
in
@@ -293,7 +293,7 @@
if null ineqs then
Const (@{const_name Set.empty}, fastype_of rel)
else
- foldr1 (HOLogic.mk_binop @{const_name union}) (map mk_compr ineqs)
+ foldr1 (HOLogic.mk_binop @{const_name Lattices.sup}) (map mk_compr ineqs)
fun solve_membership_tac i =
(EVERY' (replicate (i - 2) (rtac @{thm UnI2})) (* pick the right component of the union *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_aux.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,100 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+Auxilary functions for predicate compiler
+*)
+
+structure Predicate_Compile_Aux =
+struct
+
+(* syntactic functions *)
+
+fun is_equationlike_term (Const ("==", _) $ _ $ _) = true
+ | is_equationlike_term (Const ("Trueprop", _) $ (Const ("op =", _) $ _ $ _)) = true
+ | is_equationlike_term _ = false
+
+val is_equationlike = is_equationlike_term o prop_of
+
+fun is_pred_equation_term (Const ("==", _) $ u $ v) =
+ (fastype_of u = @{typ bool}) andalso (fastype_of v = @{typ bool})
+ | is_pred_equation_term _ = false
+
+val is_pred_equation = is_pred_equation_term o prop_of
+
+fun is_intro_term constname t =
+ case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
+ Const (c, _) => c = constname
+ | _ => false
+
+fun is_intro constname t = is_intro_term constname (prop_of t)
+
+fun is_pred thy constname =
+ let
+ val T = (Sign.the_const_type thy constname)
+ in body_type T = @{typ "bool"} end;
+
+
+fun is_predT (T as Type("fun", [_, _])) = (snd (strip_type T) = HOLogic.boolT)
+ | is_predT _ = false
+
+
+(*** check if a term contains only constructor functions ***)
+fun is_constrt thy =
+ let
+ val cnstrs = flat (maps
+ (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
+ (Symtab.dest (Datatype.get_all thy)));
+ fun check t = (case strip_comb t of
+ (Free _, []) => true
+ | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
+ (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
+ | _ => false)
+ | _ => false)
+ in check end;
+
+fun strip_ex (Const ("Ex", _) $ Abs (x, T, t)) =
+ let
+ val (xTs, t') = strip_ex t
+ in
+ ((x, T) :: xTs, t')
+ end
+ | strip_ex t = ([], t)
+
+fun focus_ex t nctxt =
+ let
+ val ((xs, Ts), t') = apfst split_list (strip_ex t)
+ val (xs', nctxt') = Name.variants xs nctxt;
+ val ps' = xs' ~~ Ts;
+ val vs = map Free ps';
+ val t'' = Term.subst_bounds (rev vs, t');
+ in ((ps', t''), nctxt') end;
+
+
+
+
+(*
+fun map_atoms f intro =
+fun fold_atoms f intro =
+*)
+fun fold_map_atoms f intro s =
+ let
+ val (literals, head) = Logic.strip_horn intro
+ fun appl t s = (case t of
+ (@{term "Not"} $ t') =>
+ let
+ val (t'', s') = f t' s
+ in (@{term "Not"} $ t'', s') end
+ | _ => f t s)
+ val (literals', s') = fold_map appl (map HOLogic.dest_Trueprop literals) s
+ in
+ (Logic.list_implies (map HOLogic.mk_Trueprop literals', head), s')
+ end;
+
+(*
+fun equals_conv lhs_cv rhs_cv ct =
+ case Thm.term_of ct of
+ Const ("==", _) $ _ $ _ => Conv.arg_conv cv ct
+ | _ => error "equals_conv"
+*)
+
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_data.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,223 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+Book-keeping datastructure for the predicate compiler
+
+*)
+signature PRED_COMPILE_DATA =
+sig
+ type specification_table;
+ val make_const_spec_table : theory -> specification_table
+ val get_specification : specification_table -> string -> thm list
+ val obtain_specification_graph : specification_table -> string -> thm list Graph.T
+ val normalize_equation : theory -> thm -> thm
+end;
+
+structure Pred_Compile_Data : PRED_COMPILE_DATA =
+struct
+
+open Predicate_Compile_Aux;
+
+structure Data = TheoryDataFun
+(
+ type T =
+ {const_spec_table : thm list Symtab.table};
+ val empty =
+ {const_spec_table = Symtab.empty};
+ val copy = I;
+ val extend = I;
+ fun merge _
+ ({const_spec_table = const_spec_table1},
+ {const_spec_table = const_spec_table2}) =
+ {const_spec_table = Symtab.merge (K true) (const_spec_table1, const_spec_table2)}
+);
+
+fun mk_data c = {const_spec_table = c}
+fun map_data f {const_spec_table = c} = mk_data (f c)
+
+type specification_table = thm list Symtab.table
+
+fun defining_const_of_introrule_term t =
+ let
+ val _ $ u = Logic.strip_imp_concl t
+ val (pred, all_args) = strip_comb u
+ in case pred of
+ Const (c, T) => c
+ | _ => raise TERM ("defining_const_of_introrule_term failed: Not a constant", [t])
+ end
+
+val defining_const_of_introrule = defining_const_of_introrule_term o prop_of
+
+(*TODO*)
+fun is_introlike_term t = true
+
+val is_introlike = is_introlike_term o prop_of
+
+fun check_equation_format_term (t as (Const ("==", _) $ u $ v)) =
+ (case strip_comb u of
+ (Const (c, T), args) =>
+ if (length (binder_types T) = length args) then
+ true
+ else
+ raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t])
+ | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t]))
+ | check_equation_format_term t =
+ raise TERM ("check_equation_format_term failed: Not an equation", [t])
+
+val check_equation_format = check_equation_format_term o prop_of
+
+fun defining_const_of_equation_term (t as (Const ("==", _) $ u $ v)) =
+ (case fst (strip_comb u) of
+ Const (c, _) => c
+ | _ => raise TERM ("defining_const_of_equation_term failed: Not a constant", [t]))
+ | defining_const_of_equation_term t =
+ raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
+
+val defining_const_of_equation = defining_const_of_equation_term o prop_of
+
+(* Normalizing equations *)
+
+fun mk_meta_equation th =
+ case prop_of th of
+ Const ("Trueprop", _) $ (Const ("op =", _) $ _ $ _) => th RS @{thm eq_reflection}
+ | _ => th
+
+fun full_fun_cong_expand th =
+ let
+ val (f, args) = strip_comb (fst (Logic.dest_equals (prop_of th)))
+ val i = length (binder_types (fastype_of f)) - length args
+ in funpow i (fn th => th RS @{thm meta_fun_cong}) th end;
+
+fun declare_names s xs ctxt =
+ let
+ val res = Name.names ctxt s xs
+ in (res, fold Name.declare (map fst res) ctxt) end
+
+fun split_all_pairs thy th =
+ let
+ val ctxt = ProofContext.init thy
+ val ((_, [th']), ctxt') = Variable.import true [th] ctxt
+ val t = prop_of th'
+ val frees = Term.add_frees t []
+ val freenames = Term.add_free_names t []
+ val nctxt = Name.make_context freenames
+ fun mk_tuple_rewrites (x, T) nctxt =
+ let
+ val Ts = HOLogic.flatten_tupleT T
+ val (xTs, nctxt') = declare_names x Ts nctxt
+ val paths = HOLogic.flat_tupleT_paths T
+ in ((Free (x, T), HOLogic.mk_ptuple paths T (map Free xTs)), nctxt') end
+ val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt
+ val t' = Pattern.rewrite_term thy rewr [] t
+ val tac = setmp quick_and_dirty true (SkipProof.cheat_tac thy)
+ val th'' = Goal.prove ctxt (Term.add_free_names t' []) [] t' (fn {...} => tac)
+ val th''' = LocalDefs.unfold ctxt [@{thm split_conv}] th''
+ in
+ th'''
+ end;
+
+fun normalize_equation thy th =
+ mk_meta_equation th
+ |> Pred_Compile_Set.unfold_set_notation
+ |> full_fun_cong_expand
+ |> split_all_pairs thy
+ |> tap check_equation_format
+
+fun inline_equations thy th = Conv.fconv_rule (Simplifier.rewrite
+((Simplifier.theory_context thy Simplifier.empty_ss) addsimps (Predicate_Compile_Inline_Defs.get (ProofContext.init thy)))) th
+
+fun store_thm_in_table ignore_consts thy th=
+ let
+ val th = AxClass.unoverload thy th
+ |> inline_equations thy
+ val (const, th) =
+ if is_equationlike th then
+ let
+ val _ = priority "Normalizing definition..."
+ val eq = normalize_equation thy th
+ in
+ (defining_const_of_equation eq, eq)
+ end
+ else if (is_introlike th) then
+ let val th = Pred_Compile_Set.unfold_set_notation th
+ in (defining_const_of_introrule th, th) end
+ else error "store_thm: unexpected definition format"
+ in
+ if not (member (op =) ignore_consts const) then
+ Symtab.cons_list (const, th)
+ else I
+ end
+
+(*
+fun make_const_spec_table_warning thy =
+ fold
+ (fn th => fn thy => case try (store_thm th) thy of
+ SOME thy => thy
+ | NONE => (warning ("store_thm fails for " ^ Display.string_of_thm_global thy th) ; thy))
+ (Predicate_Compile_Preproc_Const_Defs.get (ProofContext.init thy)) thy
+
+fun make_const_spec_table thy =
+ fold store_thm (Predicate_Compile_Preproc_Const_Defs.get (ProofContext.init thy)) thy
+ |> (fn thy => fold store_thm (Nitpick_Const_Simps.get (ProofContext.init thy)) thy)
+*)
+fun make_const_spec_table thy =
+ let
+ fun store ignore_const f = fold (store_thm_in_table ignore_const thy) (map (Thm.transfer thy) (f (ProofContext.init thy)))
+ val table = Symtab.empty
+ |> store [] Predicate_Compile_Alternative_Defs.get
+ val ignore_consts = Symtab.keys table
+ in
+ table
+ |> store ignore_consts Predicate_Compile_Preproc_Const_Defs.get
+ |> store ignore_consts Nitpick_Const_Simps.get
+ |> store ignore_consts Nitpick_Ind_Intros.get
+ end
+ (*
+fun get_specification thy constname =
+ case Symtab.lookup (#const_spec_table (Data.get thy)) constname of
+ SOME thms => thms
+ | NONE => error ("get_specification: lookup of constant " ^ quote constname ^ " failed")
+ *)
+fun get_specification table constname =
+ case Symtab.lookup table constname of
+ SOME thms =>
+ let
+ val _ = tracing ("Looking up specification of " ^ constname ^ ": "
+ ^ (commas (map Display.string_of_thm_without_context thms)))
+ in thms end
+ | NONE => error ("get_specification: lookup of constant " ^ quote constname ^ " failed")
+
+val logic_operator_names =
+ [@{const_name "=="}, @{const_name "op ="}, @{const_name "op -->"}, @{const_name "All"}, @{const_name "op &"}]
+
+val special_cases = member (op =) [@{const_name "Suc"}, @{const_name Nat.zero_nat_inst.zero_nat},
+ @{const_name Nat.one_nat_inst.one_nat},
+@{const_name "HOL.ord_class.less"}, @{const_name "HOL.ord_class.less_eq"}, @{const_name "HOL.zero_class.zero"},
+@{const_name "HOL.one_class.one"}, @{const_name HOL.plus_class.plus},
+@{const_name "Nat.nat.nat_case"}, @{const_name "List.list.list_case"},
+@{const_name "Option.option.option_case"},
+@{const_name Nat.ord_nat_inst.less_eq_nat},
+@{const_name number_nat_inst.number_of_nat},
+ @{const_name Int.Bit0},
+ @{const_name Int.Bit1},
+ @{const_name Int.Pls},
+@{const_name "Int.zero_int_inst.zero_int"},
+@{const_name "List.filter"}]
+
+fun obtain_specification_graph table constname =
+ let
+ fun is_nondefining_constname c = member (op =) logic_operator_names c
+ val is_defining_constname = member (op =) (Symtab.keys table)
+ fun defiants_of specs =
+ fold (Term.add_const_names o prop_of) specs []
+ |> filter is_defining_constname
+ |> filter_out special_cases
+ fun extend constname =
+ let
+ val specs = get_specification table constname
+ in (specs, defiants_of specs) end;
+ in
+ Graph.extend extend constname Graph.empty
+ end;
+
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_fun.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,424 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+Preprocessing functions to predicates
+*)
+
+signature PREDICATE_COMPILE_FUN =
+sig
+ val define_predicates : (string * thm list) list -> theory -> theory
+ val rewrite_intro : theory -> thm -> thm list
+ val setup_oracle : theory -> theory
+end;
+
+structure Predicate_Compile_Fun : PREDICATE_COMPILE_FUN =
+struct
+
+
+(* Oracle for preprocessing *)
+
+val (oracle : (string * (cterm -> thm)) option Unsynchronized.ref) = Unsynchronized.ref NONE;
+
+fun the_oracle () =
+ case !oracle of
+ NONE => error "Oracle is not setup"
+ | SOME (_, oracle) => oracle
+
+val setup_oracle = Thm.add_oracle (Binding.name "pred_compile_preprocessing", I) #->
+ (fn ora => fn thy => let val _ = (oracle := SOME ora) in thy end)
+
+
+fun is_funtype (Type ("fun", [_, _])) = true
+ | is_funtype _ = false;
+
+fun is_Type (Type _) = true
+ | is_Type _ = false
+
+(* returns true if t is an application of an datatype constructor *)
+(* which then consequently would be splitted *)
+(* else false *)
+(*
+fun is_constructor thy t =
+ if (is_Type (fastype_of t)) then
+ (case DatatypePackage.get_datatype thy ((fst o dest_Type o fastype_of) t) of
+ NONE => false
+ | SOME info => (let
+ val constr_consts = flat (map (fn (_, (_, _, constrs)) => map fst constrs) (#descr info))
+ val (c, _) = strip_comb t
+ in (case c of
+ Const (name, _) => name mem_string constr_consts
+ | _ => false) end))
+ else false
+*)
+
+(* must be exported in code.ML *)
+fun is_constr thy = is_some o Code.get_datatype_of_constr thy;
+
+(* Table from constant name (string) to term of inductive predicate *)
+structure Pred_Compile_Preproc = TheoryDataFun
+(
+ type T = string Symtab.table;
+ val empty = Symtab.empty;
+ val copy = I;
+ val extend = I;
+ fun merge _ = Symtab.merge (op =);
+)
+
+fun defined thy = Symtab.defined (Pred_Compile_Preproc.get thy)
+
+
+fun transform_ho_typ (T as Type ("fun", _)) =
+ let
+ val (Ts, T') = strip_type T
+ in if T' = @{typ "bool"} then T else (Ts @ [T']) ---> HOLogic.boolT end
+| transform_ho_typ t = t
+
+fun transform_ho_arg arg =
+ case (fastype_of arg) of
+ (T as Type ("fun", _)) =>
+ (case arg of
+ Free (name, _) => Free (name, transform_ho_typ T)
+ | _ => error "I am surprised")
+| _ => arg
+
+fun pred_type T =
+ let
+ val (Ts, T') = strip_type T
+ val Ts' = map transform_ho_typ Ts
+ in
+ (Ts' @ [T']) ---> HOLogic.boolT
+ end;
+
+(* FIXME: create new predicate name -- does not avoid nameclashing *)
+fun pred_of f =
+ let
+ val (name, T) = dest_Const f
+ in
+ if (body_type T = @{typ bool}) then
+ (Free (Long_Name.base_name name ^ "P", T))
+ else
+ (Free (Long_Name.base_name name ^ "P", pred_type T))
+ end
+
+fun mk_param lookup_pred (t as Free (v, _)) = lookup_pred t
+ | mk_param lookup_pred t =
+ let
+ val (vs, body) = strip_abs t
+ val names = Term.add_free_names body []
+ val vs_names = Name.variant_list names (map fst vs)
+ val vs' = map2 (curry Free) vs_names (map snd vs)
+ val body' = subst_bounds (rev vs', body)
+ val (f, args) = strip_comb body'
+ val resname = Name.variant (vs_names @ names) "res"
+ val resvar = Free (resname, body_type (fastype_of body'))
+ val P = lookup_pred f
+ val pred_body = list_comb (P, args @ [resvar])
+ val param = fold_rev lambda (vs' @ [resvar]) pred_body
+ in param end;
+
+
+(* creates the list of premises for every intro rule *)
+(* theory -> term -> (string list, term list list) *)
+
+fun dest_code_eqn eqn = let
+ val (lhs, rhs) = Logic.dest_equals (Logic.unvarify (Thm.prop_of eqn))
+ val (func, args) = strip_comb lhs
+in ((func, args), rhs) end;
+
+fun string_of_typ T = Syntax.string_of_typ_global @{theory} T
+
+fun string_of_term t =
+ case t of
+ Const (c, T) => "Const (" ^ c ^ ", " ^ string_of_typ T ^ ")"
+ | Free (c, T) => "Free (" ^ c ^ ", " ^ string_of_typ T ^ ")"
+ | Var ((c, i), T) => "Var ((" ^ c ^ ", " ^ string_of_int i ^ "), " ^ string_of_typ T ^ ")"
+ | Bound i => "Bound " ^ string_of_int i
+ | Abs (x, T, t) => "Abs (" ^ x ^ ", " ^ string_of_typ T ^ ", " ^ string_of_term t ^ ")"
+ | t1 $ t2 => "(" ^ string_of_term t1 ^ ") $ (" ^ string_of_term t2 ^ ")"
+
+fun ind_package_get_nparams thy name =
+ case try (Inductive.the_inductive (ProofContext.init thy)) name of
+ SOME (_, result) => length (Inductive.params_of (#raw_induct result))
+ | NONE => error ("No such predicate: " ^ quote name)
+
+(* TODO: does not work with higher order functions yet *)
+fun mk_rewr_eq (func, pred) =
+ let
+ val (argTs, resT) = (strip_type (fastype_of func))
+ val nctxt =
+ Name.make_context (Term.fold_aterms (fn Free (x, _) => insert (op =) x | _ => I) (func $ pred) [])
+ val (argnames, nctxt') = Name.variants (replicate (length argTs) "a") nctxt
+ val ([resname], nctxt'') = Name.variants ["r"] nctxt'
+ val args = map Free (argnames ~~ argTs)
+ val res = Free (resname, resT)
+ in Logic.mk_equals
+ (HOLogic.mk_eq (res, list_comb (func, args)), list_comb (pred, args @ [res]))
+ end;
+
+fun has_split_rule_cname @{const_name "nat_case"} = true
+ | has_split_rule_cname @{const_name "list_case"} = true
+ | has_split_rule_cname _ = false
+
+fun has_split_rule_term thy (Const (@{const_name "nat_case"}, _)) = true
+ | has_split_rule_term thy (Const (@{const_name "list_case"}, _)) = true
+ | has_split_rule_term thy _ = false
+
+fun has_split_rule_term' thy (Const (@{const_name "If"}, _)) = true
+ | has_split_rule_term' thy (Const (@{const_name "Let"}, _)) = true
+ | has_split_rule_term' thy c = has_split_rule_term thy c
+
+fun prepare_split_thm ctxt split_thm =
+ (split_thm RS @{thm iffD2})
+ |> LocalDefs.unfold ctxt [@{thm atomize_conjL[symmetric]},
+ @{thm atomize_all[symmetric]}, @{thm atomize_imp[symmetric]}]
+
+fun find_split_thm thy (Const (name, typ)) =
+ let
+ fun split_name str =
+ case first_field "." str
+ of (SOME (field, rest)) => field :: split_name rest
+ | NONE => [str]
+ val splitted_name = split_name name
+ in
+ if length splitted_name > 0 andalso
+ String.isSuffix "_case" (List.last splitted_name)
+ then
+ (List.take (splitted_name, length splitted_name - 1)) @ ["split"]
+ |> String.concatWith "."
+ |> PureThy.get_thm thy
+ |> SOME
+ handle ERROR msg => NONE
+ else NONE
+ end
+ | find_split_thm _ _ = NONE
+
+fun find_split_thm' thy (Const (@{const_name "If"}, _)) = SOME @{thm split_if}
+ | find_split_thm' thy (Const (@{const_name "Let"}, _)) = SOME @{thm refl} (* TODO *)
+ | find_split_thm' thy c = find_split_thm thy c
+
+fun strip_all t = (Term.strip_all_vars t, Term.strip_all_body t)
+
+fun folds_map f xs y =
+ let
+ fun folds_map' acc [] y = [(rev acc, y)]
+ | folds_map' acc (x :: xs) y =
+ maps (fn (x, y) => folds_map' (x :: acc) xs y) (f x y)
+ in
+ folds_map' [] xs y
+ end;
+
+fun mk_prems thy (lookup_pred, get_nparams) t (names, prems) =
+ let
+ fun mk_prems' (t as Const (name, T)) (names, prems) =
+ if is_constr thy name orelse (is_none (try lookup_pred t)) then
+ [(t ,(names, prems))]
+ else [(lookup_pred t, (names, prems))]
+ | mk_prems' (t as Free (f, T)) (names, prems) =
+ [(lookup_pred t, (names, prems))]
+ | mk_prems' t (names, prems) =
+ if Predicate_Compile_Aux.is_constrt thy t then
+ [(t, (names, prems))]
+ else
+ if has_split_rule_term' thy (fst (strip_comb t)) then
+ let
+ val (f, args) = strip_comb t
+ val split_thm = prepare_split_thm (ProofContext.init thy) (the (find_split_thm' thy f))
+ (* TODO: contextify things - this line is to unvarify the split_thm *)
+ (*val ((_, [isplit_thm]), _) = Variable.import true [split_thm] (ProofContext.init thy)*)
+ val (assms, concl) = Logic.strip_horn (Thm.prop_of split_thm)
+ val (P, [split_t]) = strip_comb (HOLogic.dest_Trueprop concl)
+ val subst = Pattern.match thy (split_t, t) (Vartab.empty, Vartab.empty)
+ val (_, split_args) = strip_comb split_t
+ val match = split_args ~~ args
+ fun mk_prems_of_assm assm =
+ let
+ val (vTs, assm') = strip_all (Envir.beta_norm (Envir.subst_term subst assm))
+ val var_names = Name.variant_list names (map fst vTs)
+ val vars = map Free (var_names ~~ (map snd vTs))
+ val (prems', pre_res) = Logic.strip_horn (subst_bounds (rev vars, assm'))
+ val (_, [inner_t]) = strip_comb (HOLogic.dest_Trueprop pre_res)
+ in
+ mk_prems' inner_t (var_names @ names, prems' @ prems)
+ end
+ in
+ maps mk_prems_of_assm assms
+ end
+ else
+ let
+ val (f, args) = strip_comb t
+ val resname = Name.variant names "res"
+ val resvar = Free (resname, body_type (fastype_of t))
+ val names' = resname :: names
+ fun mk_prems'' (t as Const (c, _)) =
+ if is_constr thy c orelse (is_none (try lookup_pred t)) then
+ folds_map mk_prems' args (names', prems) |>
+ map
+ (fn (argvs, (names'', prems')) =>
+ let
+ val prem = HOLogic.mk_Trueprop (HOLogic.mk_eq (resvar, list_comb (f, argvs)))
+ in (names'', prem :: prems') end)
+ else
+ let
+ val pred = lookup_pred t
+ val nparams = get_nparams pred
+ val (params, args) = chop nparams args
+ val _ = tracing ("mk_prems'': " ^ (Syntax.string_of_term_global thy t) ^ " has " ^ string_of_int nparams ^ " parameters.")
+ val params' = map (mk_param lookup_pred) params
+ in
+ folds_map mk_prems' args (names', prems)
+ |> map (fn (argvs, (names'', prems')) =>
+ let
+ val prem = HOLogic.mk_Trueprop (list_comb (pred, params' @ argvs @ [resvar]))
+ in (names'', prem :: prems') end)
+ end
+ | mk_prems'' (t as Free (_, _)) =
+ let
+ (* higher order argument call *)
+ val pred = lookup_pred t
+ in
+ folds_map mk_prems' args (resname :: names, prems)
+ |> map (fn (argvs, (names', prems')) =>
+ let
+ val prem = HOLogic.mk_Trueprop (list_comb (pred, argvs @ [resvar]))
+ in (names', prem :: prems') end)
+ end
+ | mk_prems'' t = error ("Invalid term: " ^ Syntax.string_of_term_global thy t)
+ in
+ map (pair resvar) (mk_prems'' f)
+ end
+ in
+ mk_prems' t (names, prems)
+ end;
+
+(* assumption: mutual recursive predicates all have the same parameters. *)
+fun define_predicates specs thy =
+ if forall (fn (const, _) => member (op =) (Symtab.keys (Pred_Compile_Preproc.get thy)) const) specs then
+ thy
+ else
+ let
+ val consts = map fst specs
+ val eqns = maps snd specs
+ (*val eqns = maps (Predicate_Compile_Preproc_Data.get_specification thy) consts*)
+ (* create prednames *)
+ val ((funs, argss), rhss) = map_split dest_code_eqn eqns |>> split_list
+ val argss' = map (map transform_ho_arg) argss
+ val pnames = map dest_Free (distinct (op =) (maps (filter (is_funtype o fastype_of)) argss'))
+ val preds = map pred_of funs
+ val prednames = map (fst o dest_Free) preds
+ val funnames = map (fst o dest_Const) funs
+ val fun_pred_names = (funnames ~~ prednames)
+ (* mapping from term (Free or Const) to term *)
+ fun lookup_pred (Const (@{const_name Cons}, T)) =
+ Const ("Preprocessing.ConsP", pred_type T) (* FIXME: temporary - Cons lookup *)
+ | lookup_pred (Const (name, T)) =
+ (case (Symtab.lookup (Pred_Compile_Preproc.get thy) name) of
+ SOME c => Const (c, pred_type T)
+ | NONE =>
+ (case AList.lookup op = fun_pred_names name of
+ SOME f => Free (f, pred_type T)
+ | NONE => Const (name, T)))
+ | lookup_pred (Free (name, T)) =
+ if member op = (map fst pnames) name then
+ Free (name, transform_ho_typ T)
+ else
+ Free (name, T)
+ | lookup_pred t =
+ error ("lookup function is not defined for " ^ Syntax.string_of_term_global thy t)
+
+ (* mapping from term (predicate term, not function term!) to int *)
+ fun get_nparams (Const (name, _)) =
+ the_default 0 (try (ind_package_get_nparams thy) name)
+ | get_nparams (Free (name, _)) =
+ (if member op = prednames name then
+ length pnames
+ else 0)
+ | get_nparams t = error ("No parameters for " ^ (Syntax.string_of_term_global thy t))
+
+ (* create intro rules *)
+
+ fun mk_intros ((func, pred), (args, rhs)) =
+ if (body_type (fastype_of func) = @{typ bool}) then
+ (*TODO: preprocess predicate definition of rhs *)
+ [Logic.list_implies ([HOLogic.mk_Trueprop rhs], HOLogic.mk_Trueprop (list_comb (pred, args)))]
+ else
+ let
+ val names = Term.add_free_names rhs []
+ in mk_prems thy (lookup_pred, get_nparams) rhs (names, [])
+ |> map (fn (resultt, (names', prems)) =>
+ Logic.list_implies (prems, HOLogic.mk_Trueprop (list_comb (pred, args @ [resultt]))))
+ end
+ fun mk_rewr_thm (func, pred) = @{thm refl}
+ in
+ case try (maps mk_intros) ((funs ~~ preds) ~~ (argss' ~~ rhss)) of
+ NONE => thy
+ | SOME intr_ts => let
+ val _ = map (tracing o (Syntax.string_of_term_global thy)) intr_ts
+ in
+ if is_some (try (map (cterm_of thy)) intr_ts) then
+ let
+ val (ind_result, thy') =
+ Inductive.add_inductive_global (serial_string ())
+ {quiet_mode = false, verbose = false, kind = Thm.internalK,
+ alt_name = Binding.empty, coind = false, no_elim = false,
+ no_ind = false, skip_mono = false, fork_mono = false}
+ (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (distinct (op =) (map dest_Free preds)))
+ pnames
+ (map (fn x => (Attrib.empty_binding, x)) intr_ts)
+ [] thy
+ val prednames = map (fst o dest_Const) (#preds ind_result)
+ (* val rewr_thms = map mk_rewr_eq ((distinct (op =) funs) ~~ (#preds ind_result)) *)
+ (* add constants to my table *)
+ in Pred_Compile_Preproc.map (fold Symtab.update_new (consts ~~ prednames)) thy' end
+ else
+ thy
+ end
+ end
+
+(* preprocessing intro rules - uses oracle *)
+
+(* theory -> thm -> thm *)
+fun rewrite_intro thy intro =
+ let
+ fun lookup_pred (Const (name, T)) =
+ (case (Symtab.lookup (Pred_Compile_Preproc.get thy) name) of
+ SOME c => Const (c, pred_type T)
+ | NONE => error ("Function " ^ name ^ " is not inductified"))
+ | lookup_pred (Free (name, T)) = Free (name, T)
+ | lookup_pred _ = error "lookup function is not defined!"
+
+ fun get_nparams (Const (name, _)) =
+ the_default 0 (try (ind_package_get_nparams thy) name)
+ | get_nparams (Free _) = 0
+ | get_nparams t = error ("No parameters for " ^ (Syntax.string_of_term_global thy t))
+
+ val intro_t = (Logic.unvarify o prop_of) intro
+ val _ = tracing (Syntax.string_of_term_global thy intro_t)
+ val (prems, concl) = Logic.strip_horn intro_t
+ val frees = map fst (Term.add_frees intro_t [])
+ fun rewrite prem names =
+ let
+ val t = (HOLogic.dest_Trueprop prem)
+ val (lit, mk_lit) = case try HOLogic.dest_not t of
+ SOME t => (t, HOLogic.mk_not)
+ | NONE => (t, I)
+ val (P, args) = (strip_comb lit)
+ in
+ folds_map (
+ fn t => if (is_funtype (fastype_of t)) then (fn x => [(t, x)])
+ else mk_prems thy (lookup_pred, get_nparams) t) args (names, [])
+ |> map (fn (resargs, (names', prems')) =>
+ let
+ val prem' = HOLogic.mk_Trueprop (mk_lit (list_comb (P, resargs)))
+ in (prem'::prems', names') end)
+ end
+ val intro_ts' = folds_map rewrite prems frees
+ |> maps (fn (prems', frees') =>
+ rewrite concl frees'
+ |> map (fn (concl'::conclprems, _) =>
+ Logic.list_implies ((flat prems') @ conclprems, concl')))
+ val _ = Output.tracing ("intro_ts': " ^
+ commas (map (Syntax.string_of_term_global thy) intro_ts'))
+ in
+ map (Drule.standard o the_oracle () o cterm_of thy) intro_ts'
+ end;
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_pred.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,138 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+Preprocessing definitions of predicates to introduction rules
+*)
+
+signature PREDICATE_COMPILE_PRED =
+sig
+ (* preprocesses an equation to a set of intro rules; defines new constants *)
+ (*
+ val preprocess_pred_equation : thm -> theory -> thm list * theory
+ *)
+ val preprocess : string -> theory -> (thm list list * theory)
+ (* output is the term list of clauses of an unknown predicate *)
+ val preprocess_term : term -> theory -> (term list * theory)
+
+ (*val rewrite : thm -> thm*)
+
+end;
+(* : PREDICATE_COMPILE_PREPROC_PRED *)
+structure Predicate_Compile_Pred =
+struct
+
+open Predicate_Compile_Aux
+
+fun is_compound ((Const ("Not", _)) $ t) =
+ error "is_compound: Negation should not occur; preprocessing is defect"
+ | is_compound ((Const ("Ex", _)) $ _) = true
+ | is_compound ((Const (@{const_name "op |"}, _)) $ _ $ _) = true
+ | is_compound ((Const ("op &", _)) $ _ $ _) =
+ error "is_compound: Conjunction should not occur; preprocessing is defect"
+ | is_compound _ = false
+
+fun flatten constname atom (defs, thy) =
+ if is_compound atom then
+ let
+ val constname = Name.variant (map (Long_Name.base_name o fst) defs)
+ ((Long_Name.base_name constname) ^ "_aux")
+ val full_constname = Sign.full_bname thy constname
+ val (params, args) = List.partition (is_predT o fastype_of)
+ (map Free (Term.add_frees atom []))
+ val constT = map fastype_of (params @ args) ---> HOLogic.boolT
+ val lhs = list_comb (Const (full_constname, constT), params @ args)
+ val def = Logic.mk_equals (lhs, atom)
+ val ([definition], thy') = thy
+ |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
+ |> PureThy.add_defs false [((Binding.name (constname ^ "_def"), def), [])]
+ in
+ (lhs, ((full_constname, [definition]) :: defs, thy'))
+ end
+ else
+ (atom, (defs, thy))
+
+fun flatten_intros constname intros thy =
+ let
+ val ctxt = ProofContext.init thy
+ val ((_, intros), ctxt') = Variable.import true intros ctxt
+ val (intros', (local_defs, thy')) = (fold_map o fold_map_atoms)
+ (flatten constname) (map prop_of intros) ([], thy)
+ val tac = fn {...} => setmp quick_and_dirty true (SkipProof.cheat_tac thy')
+ val intros'' = map (fn t => Goal.prove ctxt' [] [] t tac) intros'
+ |> Variable.export ctxt' ctxt
+ in
+ (intros'', (local_defs, thy'))
+ end
+
+(* TODO: same function occurs in inductive package *)
+fun select_disj 1 1 = []
+ | select_disj _ 1 = [rtac @{thm disjI1}]
+ | select_disj n i = (rtac @{thm disjI2})::(select_disj (n - 1) (i - 1));
+
+fun introrulify thy ths =
+ let
+ val ctxt = ProofContext.init thy
+ val ((_, ths'), ctxt') = Variable.import true ths ctxt
+ fun introrulify' th =
+ let
+ val (lhs, rhs) = Logic.dest_equals (prop_of th)
+ val frees = Term.add_free_names rhs []
+ val disjuncts = HOLogic.dest_disj rhs
+ val nctxt = Name.make_context frees
+ fun mk_introrule t =
+ let
+ val ((ps, t'), nctxt') = focus_ex t nctxt
+ val prems = map HOLogic.mk_Trueprop (HOLogic.dest_conj t')
+ in
+ (ps, Logic.list_implies (prems, HOLogic.mk_Trueprop lhs))
+ end
+ val x = ((cterm_of thy) o the_single o snd o strip_comb o HOLogic.dest_Trueprop o fst o
+ Logic.dest_implies o prop_of) @{thm exI}
+ fun prove_introrule (index, (ps, introrule)) =
+ let
+ val tac = Simplifier.simp_tac (HOL_basic_ss addsimps [th]) 1
+ THEN EVERY1 (select_disj (length disjuncts) (index + 1))
+ THEN (EVERY (map (fn y =>
+ rtac (Drule.cterm_instantiate [(x, cterm_of thy (Free y))] @{thm exI}) 1) ps))
+ THEN REPEAT_DETERM (rtac @{thm conjI} 1 THEN atac 1)
+ THEN TRY (atac 1)
+ in
+ Goal.prove ctxt' (map fst ps) [] introrule (fn {...} => tac)
+ end
+ in
+ map_index prove_introrule (map mk_introrule disjuncts)
+ end
+ in maps introrulify' ths' |> Variable.export ctxt' ctxt end
+
+val rewrite =
+ Simplifier.simplify (HOL_basic_ss addsimps [@{thm Ball_def}, @{thm Bex_def}])
+ #> Simplifier.simplify (HOL_basic_ss addsimps [@{thm all_not_ex}])
+ #> Conv.fconv_rule nnf_conv
+ #> Simplifier.simplify (HOL_basic_ss addsimps [@{thm ex_disj_distrib}])
+
+val rewrite_intros =
+ Simplifier.simplify (HOL_basic_ss addsimps @{thms HOL.simp_thms(9)})
+
+fun preprocess (constname, specs) thy =
+ let
+ val ctxt = ProofContext.init thy
+ val intros =
+ if forall is_pred_equation specs then
+ introrulify thy (map rewrite specs)
+ else if forall (is_intro constname) specs then
+ map rewrite_intros specs
+ else
+ error ("unexpected specification for constant " ^ quote constname ^ ":\n"
+ ^ commas (map (quote o Display.string_of_thm_global thy) specs))
+ val _ = tracing ("Introduction rules of definitions before flattening: "
+ ^ commas (map (Display.string_of_thm ctxt) intros))
+ val _ = tracing "Defining local predicates and their intro rules..."
+ val (intros', (local_defs, thy')) = flatten_intros constname intros thy
+ val (intross, thy'') = fold_map preprocess local_defs thy'
+ in
+ (intros' :: flat intross,thy'')
+ end;
+
+fun preprocess_term t thy = error "preprocess_pred_term: to implement"
+
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_quickcheck.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,95 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+A quickcheck generator based on the predicate compiler
+*)
+
+signature PRED_COMPILE_QUICKCHECK =
+sig
+ val quickcheck : Proof.context -> term -> int -> term list option
+ val test_ref :
+ ((unit -> int -> int * int -> term list Predicate.pred * (int * int)) option) Unsynchronized.ref
+end;
+
+structure Pred_Compile_Quickcheck : PRED_COMPILE_QUICKCHECK =
+struct
+
+val test_ref =
+ Unsynchronized.ref (NONE : (unit -> int -> int * int -> term list Predicate.pred * (int * int)) option)
+val target = "Quickcheck"
+
+fun dest_compfuns (Predicate_Compile_Core.CompilationFuns funs) = funs
+val mk_predT = #mk_predT (dest_compfuns Predicate_Compile_Core.pred_compfuns)
+val mk_rpredT = #mk_predT (dest_compfuns Predicate_Compile_Core.rpred_compfuns)
+val mk_return = #mk_single (dest_compfuns Predicate_Compile_Core.rpred_compfuns)
+val mk_bind = #mk_bind (dest_compfuns Predicate_Compile_Core.rpred_compfuns)
+val lift_pred = #lift_pred (dest_compfuns Predicate_Compile_Core.rpred_compfuns)
+
+fun mk_split_lambda [] t = Abs ("u", HOLogic.unitT, t)
+ | mk_split_lambda [x] t = lambda x t
+ | mk_split_lambda xs t =
+ let
+ fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
+ | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
+ in
+ mk_split_lambda' xs t
+ end;
+
+fun strip_imp_prems (Const("op -->", _) $ A $ B) = A :: strip_imp_prems B
+ | strip_imp_prems _ = [];
+
+fun strip_imp_concl (Const("op -->", _) $ A $ B) = strip_imp_concl B
+ | strip_imp_concl A = A : term;
+
+fun strip_horn A = (strip_imp_prems A, strip_imp_concl A);
+
+fun quickcheck ctxt t =
+ let
+ val _ = tracing ("Starting quickcheck with " ^ (Syntax.string_of_term ctxt t))
+ val ctxt' = ProofContext.theory (Context.copy_thy) ctxt
+ val thy = (ProofContext.theory_of ctxt')
+ val (vs, t') = strip_abs t
+ val vs' = Variable.variant_frees ctxt' [] vs
+ val t'' = subst_bounds (map Free (rev vs'), t')
+ val (prems, concl) = strip_horn t''
+ val constname = "pred_compile_quickcheck"
+ val full_constname = Sign.full_bname thy constname
+ val constT = map snd vs' ---> @{typ bool}
+ val thy' = Sign.add_consts_i [(Binding.name constname, constT, NoSyn)] thy
+ val t = Logic.list_implies
+ (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
+ HOLogic.mk_Trueprop (list_comb (Const (full_constname, constT), map Free vs')))
+ val tac = fn {...} => setmp quick_and_dirty true (SkipProof.cheat_tac thy')
+ val intro = Goal.prove (ProofContext.init thy') (map fst vs') [] t tac
+ val _ = tracing (Display.string_of_thm ctxt' intro)
+ val thy'' = thy'
+ |> Context.theory_map (Predicate_Compile_Preproc_Const_Defs.add_thm intro)
+ |> Predicate_Compile.preprocess full_constname
+ |> Predicate_Compile_Core.add_equations [full_constname]
+ |> Predicate_Compile_Core.add_sizelim_equations [full_constname]
+ |> Predicate_Compile_Core.add_quickcheck_equations [full_constname]
+ val sizelim_modes = Predicate_Compile_Core.sizelim_modes_of thy'' full_constname
+ val modes = Predicate_Compile_Core.generator_modes_of thy'' full_constname
+ val prog =
+ if member (op =) modes ([], []) then
+ let
+ val name = Predicate_Compile_Core.generator_name_of thy'' full_constname ([], [])
+ val T = @{typ code_numeral} --> (mk_rpredT (HOLogic.mk_tupleT (map snd vs')))
+ in Const (name, T) $ Bound 0 end
+ else if member (op =) sizelim_modes ([], []) then
+ let
+ val name = Predicate_Compile_Core.sizelim_function_name_of thy'' full_constname ([], [])
+ val T = @{typ code_numeral} --> (mk_predT (HOLogic.mk_tupleT (map snd vs')))
+ in lift_pred (Const (name, T) $ Bound 0) end
+ else error "Predicate Compile Quickcheck failed"
+ val qc_term = Abs ("size", @{typ code_numeral}, mk_bind (prog,
+ mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
+ (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))
+ val _ = tracing (Syntax.string_of_term ctxt' qc_term)
+ val compile = Code_ML.eval (SOME target) ("Pred_Compile_Quickcheck.test_ref", test_ref)
+ (fn proc => fn g => fn s => g s #>> (Predicate.map o map) proc)
+ thy'' qc_term []
+ in
+ ((compile #> Random_Engine.run) #> (Option.map fst o Predicate.yield))
+ end
+
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/pred_compile_set.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,51 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+Preprocessing sets to predicates
+*)
+
+signature PRED_COMPILE_SET =
+sig
+(*
+ val preprocess_intro : thm -> theory -> thm * theory
+ val preprocess_clause : term -> theory -> term * theory
+*)
+ val unfold_set_notation : thm -> thm;
+end;
+
+structure Pred_Compile_Set : PRED_COMPILE_SET =
+struct
+(*FIXME: unfolding Ball in pretty adhoc here *)
+val unfold_set_lemmas = [@{thm Collect_def}, @{thm mem_def}, @{thm Ball_def}]
+
+val unfold_set_notation = Simplifier.rewrite_rule unfold_set_lemmas
+
+(*
+fun find_set_theorems ctxt cname =
+ let
+ val _ = cname
+*)
+
+(*
+fun preprocess_term t ctxt =
+ case t of
+ Const ("op :", _) $ x $ A =>
+ case strip_comb A of
+ (Const (cname, T), params) =>
+ let
+ val _ = find_set_theorems
+ in
+ (t, ctxt)
+ end
+ | _ => (t, ctxt)
+ | _ => (t, ctxt)
+*)
+(*
+fun preprocess_intro th thy =
+ let
+ val cnames = find_heads_of_prems
+ val set_cname = filter (has_set_definition
+ val _ = define_preds
+ val _ = prep_pred_def
+ in
+*)
+end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,91 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+*)
+signature PREDICATE_COMPILE =
+sig
+ val setup : theory -> theory
+ val preprocess : string -> theory -> theory
+end;
+
+structure Predicate_Compile : PREDICATE_COMPILE =
+struct
+
+open Predicate_Compile_Aux;
+
+val priority = tracing;
+
+(* Some last processing *)
+fun remove_pointless_clauses intro =
+ if Logic.strip_imp_prems (prop_of intro) = [@{prop "False"}] then
+ []
+ else [intro]
+
+fun preprocess_strong_conn_constnames gr constnames thy =
+ let
+ val get_specs = map (fn k => (k, Graph.get_node gr k))
+ val _ = priority ("Preprocessing scc of " ^ commas constnames)
+ val (prednames, funnames) = List.partition (is_pred thy) constnames
+ (* untangle recursion by defining predicates for all functions *)
+ val _ = priority "Compiling functions to predicates..."
+ val _ = Output.tracing ("funnames: " ^ commas funnames)
+ val thy' =
+ thy |> not (null funnames) ? Predicate_Compile_Fun.define_predicates
+ (get_specs funnames)
+ val _ = priority "Compiling predicates to flat introrules..."
+ val (intross, thy'') = apfst flat (fold_map Predicate_Compile_Pred.preprocess
+ (get_specs prednames) thy')
+ val _ = tracing ("Flattened introduction rules: " ^
+ commas (map (Display.string_of_thm_global thy'') (flat intross)))
+ val _ = priority "Replacing functions in introrules..."
+ (* val _ = burrow (maps (Predicate_Compile_Fun.rewrite_intro thy'')) intross *)
+ val intross' =
+ case try (burrow (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross of
+ SOME intross' => intross'
+ | NONE => let val _ = warning "Function replacement failed!" in intross end
+ val _ = tracing ("Introduction rules with replaced functions: " ^
+ commas (map (Display.string_of_thm_global thy'') (flat intross')))
+ val intross'' = burrow (maps remove_pointless_clauses) intross'
+ val intross'' = burrow (map (AxClass.overload thy'')) intross''
+ val _ = priority "Registering intro rules..."
+ val thy''' = fold Predicate_Compile_Core.register_intros intross'' thy''
+ in
+ thy'''
+ end;
+
+fun preprocess const thy =
+ let
+ val _ = Output.tracing ("Fetching definitions from theory...")
+ val table = Pred_Compile_Data.make_const_spec_table thy
+ val gr = Pred_Compile_Data.obtain_specification_graph table const
+ val _ = Output.tracing (commas (Graph.all_succs gr [const]))
+ val gr = Graph.subgraph (member (op =) (Graph.all_succs gr [const])) gr
+ in fold_rev (preprocess_strong_conn_constnames gr)
+ (Graph.strong_conn gr) thy
+ end
+
+fun code_pred_cmd ((inductify_all, rpred), raw_const) lthy =
+ if inductify_all then
+ let
+ val thy = ProofContext.theory_of lthy
+ val const = Code.read_const thy raw_const
+ val lthy' = LocalTheory.theory (preprocess const) lthy
+ |> LocalTheory.checkpoint
+ val _ = tracing "Starting Predicate Compile Core..."
+ in Predicate_Compile_Core.code_pred_cmd rpred raw_const lthy' end
+ else
+ Predicate_Compile_Core.code_pred_cmd rpred raw_const lthy
+
+val setup = Predicate_Compile_Fun.setup_oracle #> Predicate_Compile_Core.setup
+
+val _ = List.app OuterKeyword.keyword ["inductify_all", "rpred"]
+
+local structure P = OuterParse
+in
+
+val _ = OuterSyntax.local_theory_to_proof "code_pred"
+ "prove equations for predicate specified by intro/elim rules"
+ OuterKeyword.thy_goal (P.opt_keyword "inductify_all" -- P.opt_keyword "rpred" -- P.term_group >> code_pred_cmd)
+
+end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,2425 @@
+(* Author: Lukas Bulwahn, TU Muenchen
+
+(Prototype of) A compiler from predicates specified by intro/elim rules
+to equations.
+*)
+
+signature PREDICATE_COMPILE_CORE =
+sig
+ val setup: theory -> theory
+ val code_pred: bool -> string -> Proof.context -> Proof.state
+ val code_pred_cmd: bool -> string -> Proof.context -> Proof.state
+ type smode = (int * int list option) list
+ type mode = smode option list * smode
+ datatype tmode = Mode of mode * smode * tmode option list;
+ (*val add_equations_of: bool -> string list -> theory -> theory *)
+ val register_predicate : (thm list * thm * int) -> theory -> theory
+ val register_intros : thm list -> theory -> theory
+ val is_registered : theory -> string -> bool
+ (* val fetch_pred_data : theory -> string -> (thm list * thm * int) *)
+ val predfun_intro_of: theory -> string -> mode -> thm
+ val predfun_elim_of: theory -> string -> mode -> thm
+ val strip_intro_concl: int -> term -> term * (term list * term list)
+ val predfun_name_of: theory -> string -> mode -> string
+ val all_preds_of : theory -> string list
+ val modes_of: theory -> string -> mode list
+ val sizelim_modes_of: theory -> string -> mode list
+ val sizelim_function_name_of : theory -> string -> mode -> string
+ val generator_modes_of: theory -> string -> mode list
+ val generator_name_of : theory -> string -> mode -> string
+ val string_of_mode : mode -> string
+ val intros_of: theory -> string -> thm list
+ val nparams_of: theory -> string -> int
+ val add_intro: thm -> theory -> theory
+ val set_elim: thm -> theory -> theory
+ val set_nparams : string -> int -> theory -> theory
+ val print_stored_rules: theory -> unit
+ val print_all_modes: theory -> unit
+ val do_proofs: bool Unsynchronized.ref
+ val mk_casesrule : Proof.context -> int -> thm list -> term
+ val analyze_compr: theory -> term -> term
+ val eval_ref: (unit -> term Predicate.pred) option Unsynchronized.ref
+ val add_equations : string list -> theory -> theory
+ val code_pred_intros_attrib : attribute
+ (* used by Quickcheck_Generator *)
+ (*val funT_of : mode -> typ -> typ
+ val mk_if_pred : term -> term
+ val mk_Eval : term * term -> term*)
+ val mk_tupleT : typ list -> typ
+(* val mk_predT : typ -> typ *)
+ (* temporary for testing of the compilation *)
+ datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
+ GeneratorPrem of term list * term | Generator of (string * typ);
+ (* val prepare_intrs: theory -> string list ->
+ (string * typ) list * int * string list * string list * (string * mode list) list *
+ (string * (term list * indprem list) list) list * (string * (int option list * int)) list*)
+ datatype compilation_funs = CompilationFuns of {
+ mk_predT : typ -> typ,
+ dest_predT : typ -> typ,
+ mk_bot : typ -> term,
+ mk_single : term -> term,
+ mk_bind : term * term -> term,
+ mk_sup : term * term -> term,
+ mk_if : term -> term,
+ mk_not : term -> term,
+ mk_map : typ -> typ -> term -> term -> term,
+ lift_pred : term -> term
+ };
+ type moded_clause = term list * (indprem * tmode) list
+ type 'a pred_mode_table = (string * (mode * 'a) list) list
+ val infer_modes : theory -> (string * mode list) list
+ -> (string * mode list) list
+ -> string list
+ -> (string * (term list * indprem list) list) list
+ -> (moded_clause list) pred_mode_table
+ val infer_modes_with_generator : theory -> (string * mode list) list
+ -> (string * mode list) list
+ -> string list
+ -> (string * (term list * indprem list) list) list
+ -> (moded_clause list) pred_mode_table
+ (*val compile_preds : theory -> compilation_funs -> string list -> string list
+ -> (string * typ) list -> (moded_clause list) pred_mode_table -> term pred_mode_table
+ val rpred_create_definitions :(string * typ) list -> string * mode list
+ -> theory -> theory
+ val split_smode : int list -> term list -> (term list * term list) *)
+ val print_moded_clauses :
+ theory -> (moded_clause list) pred_mode_table -> unit
+ val print_compiled_terms : theory -> term pred_mode_table -> unit
+ (*val rpred_prove_preds : theory -> term pred_mode_table -> thm pred_mode_table*)
+ val pred_compfuns : compilation_funs
+ val rpred_compfuns : compilation_funs
+ val dest_funT : typ -> typ * typ
+ (* val depending_preds_of : theory -> thm list -> string list *)
+ val add_quickcheck_equations : string list -> theory -> theory
+ val add_sizelim_equations : string list -> theory -> theory
+ val is_inductive_predicate : theory -> string -> bool
+ val terms_vs : term list -> string list
+ val subsets : int -> int -> int list list
+ val check_mode_clause : bool -> theory -> string list ->
+ (string * mode list) list -> (string * mode list) list -> mode -> (term list * indprem list)
+ -> (term list * (indprem * tmode) list) option
+ val string_of_moded_prem : theory -> (indprem * tmode) -> string
+ val all_modes_of : theory -> (string * mode list) list
+ val all_generator_modes_of : theory -> (string * mode list) list
+ val compile_clause : compilation_funs -> term option -> (term list -> term) ->
+ theory -> string list -> string list -> mode -> term -> moded_clause -> term
+ val preprocess_intro : theory -> thm -> thm
+ val is_constrt : theory -> term -> bool
+ val is_predT : typ -> bool
+ val guess_nparams : typ -> int
+ val cprods_subset : 'a list list -> 'a list list
+end;
+
+structure Predicate_Compile_Core : PREDICATE_COMPILE_CORE =
+struct
+
+open Predicate_Compile_Aux;
+(** auxiliary **)
+
+(* debug stuff *)
+
+fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
+
+fun print_tac s = Seq.single; (*Tactical.print_tac s;*) (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *)
+fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
+
+val do_proofs = Unsynchronized.ref true;
+
+(* reference to preprocessing of InductiveSet package *)
+
+val ind_set_codegen_preproc = (fn thy => I) (*Inductive_Set.codegen_preproc;*)
+
+(** fundamentals **)
+
+(* syntactic operations *)
+
+fun mk_eq (x, xs) =
+ let fun mk_eqs _ [] = []
+ | mk_eqs a (b::cs) =
+ HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
+ in mk_eqs x xs end;
+
+fun mk_tupleT [] = HOLogic.unitT
+ | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
+
+fun dest_tupleT (Type (@{type_name Product_Type.unit}, [])) = []
+ | dest_tupleT (Type (@{type_name "*"}, [T1, T2])) = T1 :: (dest_tupleT T2)
+ | dest_tupleT t = [t]
+
+fun mk_tuple [] = HOLogic.unit
+ | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
+
+fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
+ | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
+ | dest_tuple t = [t]
+
+fun mk_scomp (t, u) =
+ let
+ val T = fastype_of t
+ val U = fastype_of u
+ val [A] = binder_types T
+ val D = body_type U
+ in
+ Const (@{const_name "scomp"}, T --> U --> A --> D) $ t $ u
+ end;
+
+fun dest_funT (Type ("fun",[S, T])) = (S, T)
+ | dest_funT T = raise TYPE ("dest_funT", [T], [])
+
+fun mk_fun_comp (t, u) =
+ let
+ val (_, B) = dest_funT (fastype_of t)
+ val (C, A) = dest_funT (fastype_of u)
+ in
+ Const(@{const_name "Fun.comp"}, (A --> B) --> (C --> A) --> C --> B) $ t $ u
+ end;
+
+fun dest_randomT (Type ("fun", [@{typ Random.seed},
+ Type ("*", [Type ("*", [T, @{typ "unit => Code_Evaluation.term"}]) ,@{typ Random.seed}])])) = T
+ | dest_randomT T = raise TYPE ("dest_randomT", [T], [])
+
+(* destruction of intro rules *)
+
+(* FIXME: look for other place where this functionality was used before *)
+fun strip_intro_concl nparams intro = let
+ val _ $ u = Logic.strip_imp_concl intro
+ val (pred, all_args) = strip_comb u
+ val (params, args) = chop nparams all_args
+in (pred, (params, args)) end
+
+(** data structures **)
+
+type smode = (int * int list option) list
+type mode = smode option list * smode;
+datatype tmode = Mode of mode * smode * tmode option list;
+
+fun gen_split_smode (mk_tuple, strip_tuple) smode ts =
+ let
+ fun split_tuple' _ _ [] = ([], [])
+ | split_tuple' is i (t::ts) =
+ (if i mem is then apfst else apsnd) (cons t)
+ (split_tuple' is (i+1) ts)
+ fun split_tuple is t = split_tuple' is 1 (strip_tuple t)
+ fun split_smode' _ _ [] = ([], [])
+ | split_smode' smode i (t::ts) =
+ (if i mem (map fst smode) then
+ case (the (AList.lookup (op =) smode i)) of
+ NONE => apfst (cons t)
+ | SOME is =>
+ let
+ val (ts1, ts2) = split_tuple is t
+ fun cons_tuple ts = if null ts then I else cons (mk_tuple ts)
+ in (apfst (cons_tuple ts1)) o (apsnd (cons_tuple ts2)) end
+ else apsnd (cons t))
+ (split_smode' smode (i+1) ts)
+ in split_smode' smode 1 ts end
+
+val split_smode = gen_split_smode (HOLogic.mk_tuple, HOLogic.strip_tuple)
+val split_smodeT = gen_split_smode (HOLogic.mk_tupleT, HOLogic.strip_tupleT)
+
+fun gen_split_mode split_smode (iss, is) ts =
+ let
+ val (t1, t2) = chop (length iss) ts
+ in (t1, split_smode is t2) end
+
+val split_mode = gen_split_mode split_smode
+val split_modeT = gen_split_mode split_smodeT
+
+fun string_of_smode js =
+ commas (map
+ (fn (i, is) =>
+ string_of_int i ^ (case is of NONE => ""
+ | SOME is => "p" ^ enclose "[" "]" (commas (map string_of_int is)))) js)
+
+fun string_of_mode (iss, is) = space_implode " -> " (map
+ (fn NONE => "X"
+ | SOME js => enclose "[" "]" (string_of_smode js))
+ (iss @ [SOME is]));
+
+fun string_of_tmode (Mode (predmode, termmode, param_modes)) =
+ "predmode: " ^ (string_of_mode predmode) ^
+ (if null param_modes then "" else
+ "; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes))
+
+(* generation of case rules from user-given introduction rules *)
+
+fun mk_casesrule ctxt nparams introrules =
+ let
+ val ((_, intros_th), ctxt1) = Variable.import false introrules ctxt
+ val intros = map prop_of intros_th
+ val (pred, (params, args)) = strip_intro_concl nparams (hd intros)
+ val ([propname], ctxt2) = Variable.variant_fixes ["thesis"] ctxt1
+ val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
+ val (argnames, ctxt3) = Variable.variant_fixes
+ (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt2
+ val argvs = map2 (curry Free) argnames (map fastype_of args)
+ fun mk_case intro =
+ let
+ val (_, (_, args)) = strip_intro_concl nparams intro
+ val prems = Logic.strip_imp_prems intro
+ val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args)
+ val frees = (fold o fold_aterms)
+ (fn t as Free _ =>
+ if member (op aconv) params t then I else insert (op aconv) t
+ | _ => I) (args @ prems) []
+ in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
+ val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
+ val cases = map mk_case intros
+ in Logic.list_implies (assm :: cases, prop) end;
+
+
+datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
+ GeneratorPrem of term list * term | Generator of (string * typ);
+
+type moded_clause = term list * (indprem * tmode) list
+type 'a pred_mode_table = (string * (mode * 'a) list) list
+
+datatype predfun_data = PredfunData of {
+ name : string,
+ definition : thm,
+ intro : thm,
+ elim : thm
+};
+
+fun rep_predfun_data (PredfunData data) = data;
+fun mk_predfun_data (name, definition, intro, elim) =
+ PredfunData {name = name, definition = definition, intro = intro, elim = elim}
+
+datatype function_data = FunctionData of {
+ name : string,
+ equation : thm option (* is not used at all? *)
+};
+
+fun rep_function_data (FunctionData data) = data;
+fun mk_function_data (name, equation) =
+ FunctionData {name = name, equation = equation}
+
+datatype pred_data = PredData of {
+ intros : thm list,
+ elim : thm option,
+ nparams : int,
+ functions : (mode * predfun_data) list,
+ generators : (mode * function_data) list,
+ sizelim_functions : (mode * function_data) list
+};
+
+fun rep_pred_data (PredData data) = data;
+fun mk_pred_data ((intros, elim, nparams), (functions, generators, sizelim_functions)) =
+ PredData {intros = intros, elim = elim, nparams = nparams,
+ functions = functions, generators = generators, sizelim_functions = sizelim_functions}
+fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, sizelim_functions}) =
+ mk_pred_data (f ((intros, elim, nparams), (functions, generators, sizelim_functions)))
+
+fun eq_option eq (NONE, NONE) = true
+ | eq_option eq (SOME x, SOME y) = eq (x, y)
+ | eq_option eq _ = false
+
+fun eq_pred_data (PredData d1, PredData d2) =
+ eq_list (Thm.eq_thm) (#intros d1, #intros d2) andalso
+ eq_option (Thm.eq_thm) (#elim d1, #elim d2) andalso
+ #nparams d1 = #nparams d2
+
+structure PredData = TheoryDataFun
+(
+ type T = pred_data Graph.T;
+ val empty = Graph.empty;
+ val copy = I;
+ val extend = I;
+ fun merge _ = Graph.merge eq_pred_data;
+);
+
+(* queries *)
+
+fun lookup_pred_data thy name =
+ Option.map rep_pred_data (try (Graph.get_node (PredData.get thy)) name)
+
+fun the_pred_data thy name = case lookup_pred_data thy name
+ of NONE => error ("No such predicate " ^ quote name)
+ | SOME data => data;
+
+val is_registered = is_some oo lookup_pred_data
+
+val all_preds_of = Graph.keys o PredData.get
+
+fun intros_of thy = map (Thm.transfer thy) o #intros o the_pred_data thy
+
+fun the_elim_of thy name = case #elim (the_pred_data thy name)
+ of NONE => error ("No elimination rule for predicate " ^ quote name)
+ | SOME thm => Thm.transfer thy thm
+
+val has_elim = is_some o #elim oo the_pred_data;
+
+val nparams_of = #nparams oo the_pred_data
+
+val modes_of = (map fst) o #functions oo the_pred_data
+
+val sizelim_modes_of = (map fst) o #sizelim_functions oo the_pred_data
+
+val rpred_modes_of = (map fst) o #generators oo the_pred_data
+
+fun all_modes_of thy = map (fn name => (name, modes_of thy name)) (all_preds_of thy)
+
+val is_compiled = not o null o #functions oo the_pred_data
+
+fun lookup_predfun_data thy name mode =
+ Option.map rep_predfun_data (AList.lookup (op =)
+ (#functions (the_pred_data thy name)) mode)
+
+fun the_predfun_data thy name mode = case lookup_predfun_data thy name mode
+ of NONE => error ("No function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
+ | SOME data => data;
+
+val predfun_name_of = #name ooo the_predfun_data
+
+val predfun_definition_of = #definition ooo the_predfun_data
+
+val predfun_intro_of = #intro ooo the_predfun_data
+
+val predfun_elim_of = #elim ooo the_predfun_data
+
+fun lookup_generator_data thy name mode =
+ Option.map rep_function_data (AList.lookup (op =)
+ (#generators (the_pred_data thy name)) mode)
+
+fun the_generator_data thy name mode = case lookup_generator_data thy name mode
+ of NONE => error ("No generator defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
+ | SOME data => data
+
+val generator_name_of = #name ooo the_generator_data
+
+val generator_modes_of = (map fst) o #generators oo the_pred_data
+
+fun all_generator_modes_of thy =
+ map (fn name => (name, generator_modes_of thy name)) (all_preds_of thy)
+
+fun lookup_sizelim_function_data thy name mode =
+ Option.map rep_function_data (AList.lookup (op =)
+ (#sizelim_functions (the_pred_data thy name)) mode)
+
+fun the_sizelim_function_data thy name mode = case lookup_sizelim_function_data thy name mode
+ of NONE => error ("No size-limited function defined for mode " ^ string_of_mode mode
+ ^ " of predicate " ^ name)
+ | SOME data => data
+
+val sizelim_function_name_of = #name ooo the_sizelim_function_data
+
+(*val generator_modes_of = (map fst) o #generators oo the_pred_data*)
+
+(* diagnostic display functions *)
+
+fun print_modes modes = Output.tracing ("Inferred modes:\n" ^
+ cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
+ string_of_mode ms)) modes));
+
+fun print_pred_mode_table string_of_entry thy pred_mode_table =
+ let
+ fun print_mode pred (mode, entry) = "mode : " ^ (string_of_mode mode)
+ ^ (string_of_entry pred mode entry)
+ fun print_pred (pred, modes) =
+ "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
+ val _ = Output.tracing (cat_lines (map print_pred pred_mode_table))
+ in () end;
+
+fun string_of_moded_prem thy (Prem (ts, p), tmode) =
+ (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
+ "(" ^ (string_of_tmode tmode) ^ ")"
+ | string_of_moded_prem thy (GeneratorPrem (ts, p), Mode (predmode, is, _)) =
+ (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
+ "(generator_mode: " ^ (string_of_mode predmode) ^ ")"
+ | string_of_moded_prem thy (Generator (v, T), _) =
+ "Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T)
+ | string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) =
+ (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
+ "(negative mode: " ^ string_of_smode is ^ ")"
+ | string_of_moded_prem thy (Sidecond t, Mode (_, is, _)) =
+ (Syntax.string_of_term_global thy t) ^
+ "(sidecond mode: " ^ string_of_smode is ^ ")"
+ | string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented"
+
+fun print_moded_clauses thy =
+ let
+ fun string_of_clause pred mode clauses =
+ cat_lines (map (fn (ts, prems) => (space_implode " --> "
+ (map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " "
+ ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses)
+ in print_pred_mode_table string_of_clause thy end;
+
+fun print_compiled_terms thy =
+ print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy
+
+fun print_stored_rules thy =
+ let
+ val preds = (Graph.keys o PredData.get) thy
+ fun print pred () = let
+ val _ = writeln ("predicate: " ^ pred)
+ val _ = writeln ("number of parameters: " ^ string_of_int (nparams_of thy pred))
+ val _ = writeln ("introrules: ")
+ val _ = fold (fn thm => fn u => writeln (Display.string_of_thm_global thy thm))
+ (rev (intros_of thy pred)) ()
+ in
+ if (has_elim thy pred) then
+ writeln ("elimrule: " ^ Display.string_of_thm_global thy (the_elim_of thy pred))
+ else
+ writeln ("no elimrule defined")
+ end
+ in
+ fold print preds ()
+ end;
+
+fun print_all_modes thy =
+ let
+ val _ = writeln ("Inferred modes:")
+ fun print (pred, modes) u =
+ let
+ val _ = writeln ("predicate: " ^ pred)
+ val _ = writeln ("modes: " ^ (commas (map string_of_mode modes)))
+ in u end
+ in
+ fold print (all_modes_of thy) ()
+ end
+
+(** preprocessing rules **)
+
+fun imp_prems_conv cv ct =
+ case Thm.term_of ct of
+ Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
+ | _ => Conv.all_conv ct
+
+fun Trueprop_conv cv ct =
+ case Thm.term_of ct of
+ Const ("Trueprop", _) $ _ => Conv.arg_conv cv ct
+ | _ => error "Trueprop_conv"
+
+fun preprocess_intro thy rule =
+ Conv.fconv_rule
+ (imp_prems_conv
+ (Trueprop_conv (Conv.try_conv (Conv.rewr_conv (Thm.symmetric @{thm Predicate.eq_is_eq})))))
+ (Thm.transfer thy rule)
+
+fun preprocess_elim thy nparams elimrule =
+ let
+ val _ = Output.tracing ("Preprocessing elimination rule "
+ ^ (Display.string_of_thm_global thy elimrule))
+ fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) =
+ HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs)
+ | replace_eqs t = t
+ val prems = Thm.prems_of elimrule
+ val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams
+ fun preprocess_case t =
+ let
+ val params = Logic.strip_params t
+ val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t)
+ val assums_hyp' = assums1 @ (map replace_eqs assums2)
+ in
+ list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t))
+ end
+ val cases' = map preprocess_case (tl prems)
+ val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule)
+ (*val _ = Output.tracing ("elimrule': "^ (Syntax.string_of_term_global thy elimrule'))*)
+ val bigeq = (Thm.symmetric (Conv.implies_concl_conv
+ (MetaSimplifier.rewrite true [@{thm Predicate.eq_is_eq}])
+ (cterm_of thy elimrule')))
+ (*
+ val _ = Output.tracing ("bigeq:" ^ (Display.string_of_thm_global thy bigeq))
+ val res =
+ Thm.equal_elim bigeq elimrule
+ *)
+ (*
+ val t = (fn {...} => mycheat_tac thy 1)
+ val eq = Goal.prove (ProofContext.init thy) [] [] (Logic.mk_equals ((Thm.prop_of elimrule), elimrule')) t
+ *)
+ val _ = Output.tracing "Preprocessed elimination rule"
+ in
+ Thm.equal_elim bigeq elimrule
+ end;
+
+(* special case: predicate with no introduction rule *)
+fun noclause thy predname elim = let
+ val T = (Logic.unvarifyT o Sign.the_const_type thy) predname
+ val Ts = binder_types T
+ val names = Name.variant_list []
+ (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts)))
+ val vs = map2 (curry Free) names Ts
+ val clausehd = HOLogic.mk_Trueprop (list_comb (Const (predname, T), vs))
+ val intro_t = Logic.mk_implies (@{prop False}, clausehd)
+ val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))
+ val elim_t = Logic.list_implies ([clausehd, Logic.mk_implies (@{prop False}, P)], P)
+ val intro = Goal.prove (ProofContext.init thy) names [] intro_t
+ (fn {...} => etac @{thm FalseE} 1)
+ val elim = Goal.prove (ProofContext.init thy) ("P" :: names) [] elim_t
+ (fn {...} => etac elim 1)
+in
+ ([intro], elim)
+end
+
+fun fetch_pred_data thy name =
+ case try (Inductive.the_inductive (ProofContext.init thy)) name of
+ SOME (info as (_, result)) =>
+ let
+ fun is_intro_of intro =
+ let
+ val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro))
+ in (fst (dest_Const const) = name) end;
+ val intros = ind_set_codegen_preproc thy ((map (preprocess_intro thy))
+ (filter is_intro_of (#intrs result)))
+ val pre_elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info)))
+ val nparams = length (Inductive.params_of (#raw_induct result))
+ val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
+ val (intros, elim) = if null intros then noclause thy name elim else (intros, elim)
+ in
+ mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
+ end
+ | NONE => error ("No such predicate: " ^ quote name)
+
+(* updaters *)
+
+fun apfst3 f (x, y, z) = (f x, y, z)
+fun apsnd3 f (x, y, z) = (x, f y, z)
+fun aptrd3 f (x, y, z) = (x, y, f z)
+
+fun add_predfun name mode data =
+ let
+ val add = (apsnd o apfst3 o cons) (mode, mk_predfun_data data)
+ in PredData.map (Graph.map_node name (map_pred_data add)) end
+
+fun is_inductive_predicate thy name =
+ is_some (try (Inductive.the_inductive (ProofContext.init thy)) name)
+
+fun depending_preds_of thy (key, value) =
+ let
+ val intros = (#intros o rep_pred_data) value
+ in
+ fold Term.add_const_names (map Thm.prop_of intros) []
+ |> filter (fn c => (not (c = key)) andalso (is_inductive_predicate thy c orelse is_registered thy c))
+ end;
+
+
+(* code dependency graph *)
+(*
+fun dependencies_of thy name =
+ let
+ val (intros, elim, nparams) = fetch_pred_data thy name
+ val data = mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
+ val keys = depending_preds_of thy intros
+ in
+ (data, keys)
+ end;
+*)
+(* guessing number of parameters *)
+fun find_indexes pred xs =
+ let
+ fun find is n [] = is
+ | find is n (x :: xs) = find (if pred x then (n :: is) else is) (n + 1) xs;
+ in rev (find [] 0 xs) end;
+
+fun guess_nparams T =
+ let
+ val argTs = binder_types T
+ val nparams = fold (curry Int.max)
+ (map (fn x => x + 1) (find_indexes is_predT argTs)) 0
+ in nparams end;
+
+fun add_intro thm thy = let
+ val (name, T) = dest_Const (fst (strip_intro_concl 0 (prop_of thm)))
+ fun cons_intro gr =
+ case try (Graph.get_node gr) name of
+ SOME pred_data => Graph.map_node name (map_pred_data
+ (apfst (fn (intro, elim, nparams) => (thm::intro, elim, nparams)))) gr
+ | NONE =>
+ let
+ val nparams = the_default (guess_nparams T) (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name)
+ in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), ([], [], []))) gr end;
+ in PredData.map cons_intro thy end
+
+fun set_elim thm = let
+ val (name, _) = dest_Const (fst
+ (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
+ fun set (intros, _, nparams) = (intros, SOME thm, nparams)
+ in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
+
+fun set_nparams name nparams = let
+ fun set (intros, elim, _ ) = (intros, elim, nparams)
+ in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
+
+fun register_predicate (pre_intros, pre_elim, nparams) thy =
+ let
+ val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd pre_intros))))
+ (* preprocessing *)
+ val intros = ind_set_codegen_preproc thy (map (preprocess_intro thy) pre_intros)
+ val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
+ in
+ if not (member (op =) (Graph.keys (PredData.get thy)) name) then
+ PredData.map
+ (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy
+ else thy
+ end
+
+fun register_intros pre_intros thy =
+ let
+ val (c, T) = dest_Const (fst (strip_intro_concl 0 (prop_of (hd pre_intros))))
+ val _ = Output.tracing ("Registering introduction rules of " ^ c)
+ val _ = Output.tracing (commas (map (Display.string_of_thm_global thy) pre_intros))
+ val nparams = guess_nparams T
+ val pre_elim =
+ (Drule.standard o (setmp quick_and_dirty true (SkipProof.make_thm thy)))
+ (mk_casesrule (ProofContext.init thy) nparams pre_intros)
+ in register_predicate (pre_intros, pre_elim, nparams) thy end
+
+fun set_generator_name pred mode name =
+ let
+ val set = (apsnd o apsnd3 o cons) (mode, mk_function_data (name, NONE))
+ in
+ PredData.map (Graph.map_node pred (map_pred_data set))
+ end
+
+fun set_sizelim_function_name pred mode name =
+ let
+ val set = (apsnd o aptrd3 o cons) (mode, mk_function_data (name, NONE))
+ in
+ PredData.map (Graph.map_node pred (map_pred_data set))
+ end
+
+(** data structures for generic compilation for different monads **)
+
+(* maybe rename functions more generic:
+ mk_predT -> mk_monadT; dest_predT -> dest_monadT
+ mk_single -> mk_return (?)
+*)
+datatype compilation_funs = CompilationFuns of {
+ mk_predT : typ -> typ,
+ dest_predT : typ -> typ,
+ mk_bot : typ -> term,
+ mk_single : term -> term,
+ mk_bind : term * term -> term,
+ mk_sup : term * term -> term,
+ mk_if : term -> term,
+ mk_not : term -> term,
+(* funT_of : mode -> typ -> typ, *)
+(* mk_fun_of : theory -> (string * typ) -> mode -> term, *)
+ mk_map : typ -> typ -> term -> term -> term,
+ lift_pred : term -> term
+};
+
+fun mk_predT (CompilationFuns funs) = #mk_predT funs
+fun dest_predT (CompilationFuns funs) = #dest_predT funs
+fun mk_bot (CompilationFuns funs) = #mk_bot funs
+fun mk_single (CompilationFuns funs) = #mk_single funs
+fun mk_bind (CompilationFuns funs) = #mk_bind funs
+fun mk_sup (CompilationFuns funs) = #mk_sup funs
+fun mk_if (CompilationFuns funs) = #mk_if funs
+fun mk_not (CompilationFuns funs) = #mk_not funs
+(*fun funT_of (CompilationFuns funs) = #funT_of funs*)
+(*fun mk_fun_of (CompilationFuns funs) = #mk_fun_of funs*)
+fun mk_map (CompilationFuns funs) = #mk_map funs
+fun lift_pred (CompilationFuns funs) = #lift_pred funs
+
+fun funT_of compfuns (iss, is) T =
+ let
+ val Ts = binder_types T
+ val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
+ val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs
+ in
+ (paramTs' @ inargTs) ---> (mk_predT compfuns (mk_tupleT outargTs))
+ end;
+
+fun mk_fun_of compfuns thy (name, T) mode =
+ Const (predfun_name_of thy name mode, funT_of compfuns mode T)
+
+
+structure PredicateCompFuns =
+struct
+
+fun mk_predT T = Type (@{type_name "Predicate.pred"}, [T])
+
+fun dest_predT (Type (@{type_name "Predicate.pred"}, [T])) = T
+ | dest_predT T = raise TYPE ("dest_predT", [T], []);
+
+fun mk_bot T = Const (@{const_name Orderings.bot}, mk_predT T);
+
+fun mk_single t =
+ let val T = fastype_of t
+ in Const(@{const_name Predicate.single}, T --> mk_predT T) $ t end;
+
+fun mk_bind (x, f) =
+ let val T as Type ("fun", [_, U]) = fastype_of f
+ in
+ Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
+ end;
+
+val mk_sup = HOLogic.mk_binop @{const_name sup};
+
+fun mk_if cond = Const (@{const_name Predicate.if_pred},
+ HOLogic.boolT --> mk_predT HOLogic.unitT) $ cond;
+
+fun mk_not t = let val T = mk_predT HOLogic.unitT
+ in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
+
+fun mk_Enum f =
+ let val T as Type ("fun", [T', _]) = fastype_of f
+ in
+ Const (@{const_name Predicate.Pred}, T --> mk_predT T') $ f
+ end;
+
+fun mk_Eval (f, x) =
+ let
+ val T = fastype_of x
+ in
+ Const (@{const_name Predicate.eval}, mk_predT T --> T --> HOLogic.boolT) $ f $ x
+ end;
+
+fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
+ (T1 --> T2) --> mk_predT T1 --> mk_predT T2) $ tf $ tp;
+
+val lift_pred = I
+
+val compfuns = CompilationFuns {mk_predT = mk_predT, dest_predT = dest_predT, mk_bot = mk_bot,
+ mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
+ mk_map = mk_map, lift_pred = lift_pred};
+
+end;
+
+structure RPredCompFuns =
+struct
+
+fun mk_rpredT T =
+ @{typ "Random.seed"} --> HOLogic.mk_prodT (PredicateCompFuns.mk_predT T, @{typ "Random.seed"})
+
+fun dest_rpredT (Type ("fun", [_,
+ Type (@{type_name "*"}, [Type (@{type_name "Predicate.pred"}, [T]), _])])) = T
+ | dest_rpredT T = raise TYPE ("dest_rpredT", [T], []);
+
+fun mk_bot T = Const(@{const_name RPred.bot}, mk_rpredT T)
+
+fun mk_single t =
+ let
+ val T = fastype_of t
+ in
+ Const (@{const_name RPred.return}, T --> mk_rpredT T) $ t
+ end;
+
+fun mk_bind (x, f) =
+ let
+ val T as (Type ("fun", [_, U])) = fastype_of f
+ in
+ Const (@{const_name RPred.bind}, fastype_of x --> T --> U) $ x $ f
+ end
+
+val mk_sup = HOLogic.mk_binop @{const_name RPred.supp}
+
+fun mk_if cond = Const (@{const_name RPred.if_rpred},
+ HOLogic.boolT --> mk_rpredT HOLogic.unitT) $ cond;
+
+fun mk_not t = error "Negation is not defined for RPred"
+
+fun mk_map t = error "FIXME" (*FIXME*)
+
+fun lift_pred t =
+ let
+ val T = PredicateCompFuns.dest_predT (fastype_of t)
+ val lift_predT = PredicateCompFuns.mk_predT T --> mk_rpredT T
+ in
+ Const (@{const_name "RPred.lift_pred"}, lift_predT) $ t
+ end;
+
+val compfuns = CompilationFuns {mk_predT = mk_rpredT, dest_predT = dest_rpredT, mk_bot = mk_bot,
+ mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
+ mk_map = mk_map, lift_pred = lift_pred};
+
+end;
+(* for external use with interactive mode *)
+val pred_compfuns = PredicateCompFuns.compfuns
+val rpred_compfuns = RPredCompFuns.compfuns;
+
+fun lift_random random =
+ let
+ val T = dest_randomT (fastype_of random)
+ in
+ Const (@{const_name lift_random}, (@{typ Random.seed} -->
+ HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) -->
+ RPredCompFuns.mk_rpredT T) $ random
+ end;
+
+fun sizelim_funT_of compfuns (iss, is) T =
+ let
+ val Ts = binder_types T
+ val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
+ val paramTs' = map2 (fn SOME is => sizelim_funT_of PredicateCompFuns.compfuns ([], is) | NONE => I) iss paramTs
+ in
+ (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT compfuns (mk_tupleT outargTs))
+ end;
+
+fun mk_sizelim_fun_of compfuns thy (name, T) mode =
+ Const (sizelim_function_name_of thy name mode, sizelim_funT_of compfuns mode T)
+
+fun mk_generator_of compfuns thy (name, T) mode =
+ Const (generator_name_of thy name mode, sizelim_funT_of compfuns mode T)
+
+(* Mode analysis *)
+
+(*** check if a term contains only constructor functions ***)
+fun is_constrt thy =
+ let
+ val cnstrs = flat (maps
+ (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
+ (Symtab.dest (Datatype.get_all thy)));
+ fun check t = (case strip_comb t of
+ (Free _, []) => true
+ | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
+ (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
+ | _ => false)
+ | _ => false)
+ in check end;
+
+(*** check if a type is an equality type (i.e. doesn't contain fun)
+ FIXME this is only an approximation ***)
+fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
+ | is_eqT _ = true;
+
+fun term_vs tm = fold_aterms (fn Free (x, T) => cons x | _ => I) tm [];
+val terms_vs = distinct (op =) o maps term_vs;
+
+(** collect all Frees in a term (with duplicates!) **)
+fun term_vTs tm =
+ fold_aterms (fn Free xT => cons xT | _ => I) tm [];
+
+(*FIXME this function should not be named merge... make it local instead*)
+fun merge xs [] = xs
+ | merge [] ys = ys
+ | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
+ else y::merge (x::xs) ys;
+
+fun subsets i j = if i <= j then
+ let val is = subsets (i+1) j
+ in merge (map (fn ks => i::ks) is) is end
+ else [[]];
+
+(* FIXME: should be in library - cprod = map_prod I *)
+fun cprod ([], ys) = []
+ | cprod (x :: xs, ys) = map (pair x) ys @ cprod (xs, ys);
+
+fun cprods xss = foldr (map op :: o cprod) [[]] xss;
+
+fun cprods_subset [] = [[]]
+ | cprods_subset (xs :: xss) =
+ let
+ val yss = (cprods_subset xss)
+ in maps (fn ys => map (fn x => cons x ys) xs) yss @ yss end
+
+(*TODO: cleanup function and put together with modes_of_term *)
+(*
+fun modes_of_param default modes t = let
+ val (vs, t') = strip_abs t
+ val b = length vs
+ fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
+ let
+ val (args1, args2) =
+ if length args < length iss then
+ error ("Too few arguments for inductive predicate " ^ name)
+ else chop (length iss) args;
+ val k = length args2;
+ val perm = map (fn i => (find_index_eq (Bound (b - i)) args2) + 1)
+ (1 upto b)
+ val partial_mode = (1 upto k) \\ perm
+ in
+ if not (partial_mode subset is) then [] else
+ let
+ val is' =
+ (fold_index (fn (i, j) => if j mem is then cons (i + 1) else I) perm [])
+ |> fold (fn i => if i > k then cons (i - k + b) else I) is
+
+ val res = map (fn x => Mode (m, is', x)) (cprods (map
+ (fn (NONE, _) => [NONE]
+ | (SOME js, arg) => map SOME (filter
+ (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
+ (iss ~~ args1)))
+ in res end
+ end)) (AList.lookup op = modes name)
+ in case strip_comb t' of
+ (Const (name, _), args) => the_default default (mk_modes name args)
+ | (Var ((name, _), _), args) => the (mk_modes name args)
+ | (Free (name, _), args) => the (mk_modes name args)
+ | _ => default end
+
+and
+*)
+fun modes_of_term modes t =
+ let
+ val ks = map_index (fn (i, T) => (i, NONE)) (binder_types (fastype_of t));
+ val default = [Mode (([], ks), ks, [])];
+ fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
+ let
+ val (args1, args2) =
+ if length args < length iss then
+ error ("Too few arguments for inductive predicate " ^ name)
+ else chop (length iss) args;
+ val k = length args2;
+ val prfx = map (rpair NONE) (1 upto k)
+ in
+ if not (is_prefix op = prfx is) then [] else
+ let val is' = List.drop (is, k)
+ in map (fn x => Mode (m, is', x)) (cprods (map
+ (fn (NONE, _) => [NONE]
+ | (SOME js, arg) => map SOME (filter
+ (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
+ (iss ~~ args1)))
+ end
+ end)) (AList.lookup op = modes name)
+
+ in
+ case strip_comb (Envir.eta_contract t) of
+ (Const (name, _), args) => the_default default (mk_modes name args)
+ | (Var ((name, _), _), args) => the (mk_modes name args)
+ | (Free (name, _), args) => the (mk_modes name args)
+ | (Abs _, []) => error "Abs at param position" (* modes_of_param default modes t *)
+ | _ => default
+ end
+
+fun select_mode_prem thy modes vs ps =
+ find_first (is_some o snd) (ps ~~ map
+ (fn Prem (us, t) => find_first (fn Mode (_, is, _) =>
+ let
+ val (in_ts, out_ts) = split_smode is us;
+ val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts;
+ val vTs = maps term_vTs out_ts';
+ val dupTs = map snd (duplicates (op =) vTs) @
+ List.mapPartial (AList.lookup (op =) vTs) vs;
+ in
+ terms_vs (in_ts @ in_ts') subset vs andalso
+ forall (is_eqT o fastype_of) in_ts' andalso
+ term_vs t subset vs andalso
+ forall is_eqT dupTs
+ end)
+ (modes_of_term modes t handle Option =>
+ error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
+ | Negprem (us, t) => find_first (fn Mode (_, is, _) =>
+ length us = length is andalso
+ terms_vs us subset vs andalso
+ term_vs t subset vs)
+ (modes_of_term modes t handle Option =>
+ error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
+ | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], []))
+ else NONE
+ ) ps);
+
+fun fold_prem f (Prem (args, _)) = fold f args
+ | fold_prem f (Negprem (args, _)) = fold f args
+ | fold_prem f (Sidecond t) = f t
+
+fun all_subsets [] = [[]]
+ | all_subsets (x::xs) = let val xss' = all_subsets xs in xss' @ (map (cons x) xss') end
+
+fun generator vTs v =
+ let
+ val T = the (AList.lookup (op =) vTs v)
+ in
+ (Generator (v, T), Mode (([], []), [], []))
+ end;
+
+fun gen_prem (Prem (us, t)) = GeneratorPrem (us, t)
+ | gen_prem (Negprem (us, t)) = error "it is a negated prem"
+ | gen_prem (Sidecond t) = error "it is a sidecond"
+ | gen_prem _ = error "gen_prem : invalid input for gen_prem"
+
+fun param_gen_prem param_vs (p as Prem (us, t as Free (v, _))) =
+ if member (op =) param_vs v then
+ GeneratorPrem (us, t)
+ else p
+ | param_gen_prem param_vs p = p
+
+fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) =
+ let
+ (*
+ val _ = Output.tracing ("param_vs:" ^ commas param_vs)
+ val _ = Output.tracing ("iss:" ^
+ commas (map (fn is => case is of SOME is => string_of_smode is | NONE => "NONE") iss))
+ *)
+ val modes' = modes @ List.mapPartial
+ (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
+ (param_vs ~~ iss);
+ val gen_modes' = gen_modes @ List.mapPartial
+ (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
+ (param_vs ~~ iss);
+ val vTs = distinct (op =) ((fold o fold_prem) Term.add_frees ps (fold Term.add_frees ts []))
+ val prem_vs = distinct (op =) ((fold o fold_prem) Term.add_free_names ps [])
+ fun check_mode_prems acc_ps vs [] = SOME (acc_ps, vs)
+ | check_mode_prems acc_ps vs ps = (case select_mode_prem thy modes' vs ps of
+ NONE =>
+ (if with_generator then
+ (case select_mode_prem thy gen_modes' vs ps of
+ SOME (p as Prem _, SOME mode) => check_mode_prems ((gen_prem p, mode) :: acc_ps)
+ (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
+ (filter_out (equal p) ps)
+ | _ =>
+ let
+ val all_generator_vs = all_subsets (prem_vs \\ vs) |> sort (int_ord o (pairself length))
+ in
+ case (find_first (fn generator_vs => is_some
+ (select_mode_prem thy modes' (vs union generator_vs) ps)) all_generator_vs) of
+ SOME generator_vs => check_mode_prems ((map (generator vTs) generator_vs) @ acc_ps)
+ (vs union generator_vs) ps
+ | NONE => let
+ val _ = Output.tracing ("ps:" ^ (commas
+ (map (fn p => string_of_moded_prem thy (p, Mode (([], []), [], []))) ps)))
+ in (*error "mode analysis failed"*)NONE end
+ end)
+ else
+ NONE)
+ | SOME (p, SOME mode) => check_mode_prems ((if with_generator then param_gen_prem param_vs p else p, mode) :: acc_ps)
+ (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
+ (filter_out (equal p) ps))
+ val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts));
+ val in_vs = terms_vs in_ts;
+ val concl_vs = terms_vs ts
+ in
+ if forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso
+ forall (is_eqT o fastype_of) in_ts' then
+ case check_mode_prems [] (param_vs union in_vs) ps of
+ NONE => NONE
+ | SOME (acc_ps, vs) =>
+ if with_generator then
+ SOME (ts, (rev acc_ps) @ (map (generator vTs) (concl_vs \\ vs)))
+ else
+ if concl_vs subset vs then SOME (ts, rev acc_ps) else NONE
+ else NONE
+ end;
+
+fun check_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
+ let val SOME rs = AList.lookup (op =) clauses p
+ in (p, List.filter (fn m => case find_index
+ (is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of
+ ~1 => true
+ | i => (Output.tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^
+ p ^ " violates mode " ^ string_of_mode m);
+ Output.tracing (commas (map (Syntax.string_of_term_global thy) (fst (nth rs i)))); false)) ms)
+ end;
+
+fun get_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
+ let
+ val SOME rs = AList.lookup (op =) clauses p
+ in
+ (p, map (fn m =>
+ (m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms)
+ end;
+
+fun fixp f (x : (string * mode list) list) =
+ let val y = f x
+ in if x = y then x else fixp f y end;
+
+fun infer_modes thy extra_modes all_modes param_vs clauses =
+ let
+ val modes =
+ fixp (fn modes =>
+ map (check_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes)
+ all_modes
+ in
+ map (get_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes
+ end;
+
+fun remove_from rem [] = []
+ | remove_from rem ((k, vs) :: xs) =
+ (case AList.lookup (op =) rem k of
+ NONE => (k, vs)
+ | SOME vs' => (k, vs \\ vs'))
+ :: remove_from rem xs
+
+fun infer_modes_with_generator thy extra_modes all_modes param_vs clauses =
+ let
+ val prednames = map fst clauses
+ val extra_modes = all_modes_of thy
+ val gen_modes = all_generator_modes_of thy
+ |> filter_out (fn (name, _) => member (op =) prednames name)
+ val starting_modes = remove_from extra_modes all_modes
+ val modes =
+ fixp (fn modes =>
+ map (check_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes)
+ starting_modes
+ in
+ map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes
+ end;
+
+(* term construction *)
+
+fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
+ NONE => (Free (s, T), (names, (s, [])::vs))
+ | SOME xs =>
+ let
+ val s' = Name.variant names s;
+ val v = Free (s', T)
+ in
+ (v, (s'::names, AList.update (op =) (s, v::xs) vs))
+ end);
+
+fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
+ | distinct_v (t $ u) nvs =
+ let
+ val (t', nvs') = distinct_v t nvs;
+ val (u', nvs'') = distinct_v u nvs';
+ in (t' $ u', nvs'') end
+ | distinct_v x nvs = (x, nvs);
+
+fun compile_match thy compfuns eqs eqs' out_ts success_t =
+ let
+ val eqs'' = maps mk_eq eqs @ eqs'
+ val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
+ val name = Name.variant names "x";
+ val name' = Name.variant (name :: names) "y";
+ val T = mk_tupleT (map fastype_of out_ts);
+ val U = fastype_of success_t;
+ val U' = dest_predT compfuns U;
+ val v = Free (name, T);
+ val v' = Free (name', T);
+ in
+ lambda v (fst (Datatype.make_case
+ (ProofContext.init thy) DatatypeCase.Quiet [] v
+ [(mk_tuple out_ts,
+ if null eqs'' then success_t
+ else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
+ foldr1 HOLogic.mk_conj eqs'' $ success_t $
+ mk_bot compfuns U'),
+ (v', mk_bot compfuns U')]))
+ end;
+
+(*FIXME function can be removed*)
+fun mk_funcomp f t =
+ let
+ val names = Term.add_free_names t [];
+ val Ts = binder_types (fastype_of t);
+ val vs = map Free
+ (Name.variant_list names (replicate (length Ts) "x") ~~ Ts)
+ in
+ fold_rev lambda vs (f (list_comb (t, vs)))
+ end;
+(*
+fun compile_param_ext thy compfuns modes (NONE, t) = t
+ | compile_param_ext thy compfuns modes (m as SOME (Mode ((iss, is'), is, ms)), t) =
+ let
+ val (vs, u) = strip_abs t
+ val (ivs, ovs) = split_mode is vs
+ val (f, args) = strip_comb u
+ val (params, args') = chop (length ms) args
+ val (inargs, outargs) = split_mode is' args'
+ val b = length vs
+ val perm = map (fn i => (find_index_eq (Bound (b - i)) args') + 1) (1 upto b)
+ val outp_perm =
+ snd (split_mode is perm)
+ |> map (fn i => i - length (filter (fn x => x < i) is'))
+ val names = [] -- TODO
+ val out_names = Name.variant_list names (replicate (length outargs) "x")
+ val f' = case f of
+ Const (name, T) =>
+ if AList.defined op = modes name then
+ mk_predfun_of thy compfuns (name, T) (iss, is')
+ else error "compile param: Not an inductive predicate with correct mode"
+ | Free (name, T) => Free (name, param_funT_of compfuns T (SOME is'))
+ val outTs = dest_tupleT (dest_predT compfuns (body_type (fastype_of f')))
+ val out_vs = map Free (out_names ~~ outTs)
+ val params' = map (compile_param thy modes) (ms ~~ params)
+ val f_app = list_comb (f', params' @ inargs)
+ val single_t = (mk_single compfuns (mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm)))
+ val match_t = compile_match thy compfuns [] [] out_vs single_t
+ in list_abs (ivs,
+ mk_bind compfuns (f_app, match_t))
+ end
+ | compile_param_ext _ _ _ _ = error "compile params"
+*)
+
+fun compile_param neg_in_sizelim size thy compfuns (NONE, t) = t
+ | compile_param neg_in_sizelim size thy compfuns (m as SOME (Mode ((iss, is'), is, ms)), t) =
+ let
+ val (f, args) = strip_comb (Envir.eta_contract t)
+ val (params, args') = chop (length ms) args
+ val params' = map (compile_param neg_in_sizelim size thy compfuns) (ms ~~ params)
+ val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
+ val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
+ val f' =
+ case f of
+ Const (name, T) =>
+ mk_fun_of compfuns thy (name, T) (iss, is')
+ | Free (name, T) =>
+ case neg_in_sizelim of
+ SOME _ => Free (name, sizelim_funT_of compfuns (iss, is') T)
+ | NONE => Free (name, funT_of compfuns (iss, is') T)
+
+ | _ => error ("PredicateCompiler: illegal parameter term")
+ in
+ (case neg_in_sizelim of SOME size_t =>
+ (fn t =>
+ let
+ val Ts = fst (split_last (binder_types (fastype_of t)))
+ val names = map (fn i => "x" ^ string_of_int i) (1 upto length Ts)
+ in
+ list_abs (names ~~ Ts, list_comb (t, (map Bound ((length Ts) - 1 downto 0)) @ [size_t]))
+ end)
+ | NONE => I)
+ (list_comb (f', params' @ args'))
+ end
+
+fun compile_expr neg_in_sizelim size thy ((Mode (mode, is, ms)), t) =
+ case strip_comb t of
+ (Const (name, T), params) =>
+ let
+ val params' = map (compile_param neg_in_sizelim size thy PredicateCompFuns.compfuns) (ms ~~ params)
+ val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
+ in
+ list_comb (mk_fun_of PredicateCompFuns.compfuns thy (name, T) mode, params')
+ end
+ | (Free (name, T), args) =>
+ let
+ val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
+ in
+ list_comb (Free (name, funT_of PredicateCompFuns.compfuns ([], is) T), args)
+ end;
+
+fun compile_gen_expr size thy compfuns ((Mode (mode, is, ms)), t) inargs =
+ case strip_comb t of
+ (Const (name, T), params) =>
+ let
+ val params' = map (compile_param NONE size thy PredicateCompFuns.compfuns) (ms ~~ params)
+ in
+ list_comb (mk_generator_of compfuns thy (name, T) mode, params' @ inargs)
+ end
+ | (Free (name, T), params) =>
+ lift_pred compfuns
+ (list_comb (Free (name, sizelim_funT_of PredicateCompFuns.compfuns ([], is) T), params @ inargs))
+
+
+(** specific rpred functions -- move them to the correct place in this file *)
+
+fun mk_Eval_of size ((x, T), NONE) names = (x, names)
+ | mk_Eval_of size ((x, T), SOME mode) names =
+ let
+ val Ts = binder_types T
+ (*val argnames = Name.variant_list names
+ (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
+ val args = map Free (argnames ~~ Ts)
+ val (inargs, outargs) = split_smode mode args*)
+ fun mk_split_lambda [] t = lambda (Free (Name.variant names "x", HOLogic.unitT)) t
+ | mk_split_lambda [x] t = lambda x t
+ | mk_split_lambda xs t =
+ let
+ fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
+ | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
+ in
+ mk_split_lambda' xs t
+ end;
+ fun mk_arg (i, T) =
+ let
+ val vname = Name.variant names ("x" ^ string_of_int i)
+ val default = Free (vname, T)
+ in
+ case AList.lookup (op =) mode i of
+ NONE => (([], [default]), [default])
+ | SOME NONE => (([default], []), [default])
+ | SOME (SOME pis) =>
+ case HOLogic.strip_tupleT T of
+ [] => error "pair mode but unit tuple" (*(([default], []), [default])*)
+ | [_] => error "pair mode but not a tuple" (*(([default], []), [default])*)
+ | Ts =>
+ let
+ val vnames = Name.variant_list names
+ (map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
+ (1 upto length Ts))
+ val args = map Free (vnames ~~ Ts)
+ fun split_args (i, arg) (ins, outs) =
+ if member (op =) pis i then
+ (arg::ins, outs)
+ else
+ (ins, arg::outs)
+ val (inargs, outargs) = fold_rev split_args ((1 upto length Ts) ~~ args) ([], [])
+ fun tuple args = if null args then [] else [HOLogic.mk_tuple args]
+ in ((tuple inargs, tuple outargs), args) end
+ end
+ val (inoutargs, args) = split_list (map mk_arg (1 upto (length Ts) ~~ Ts))
+ val (inargs, outargs) = pairself flat (split_list inoutargs)
+ val size_t = case size of NONE => [] | SOME size_t => [size_t]
+ val r = PredicateCompFuns.mk_Eval (list_comb (x, inargs @ size_t), mk_tuple outargs)
+ val t = fold_rev mk_split_lambda args r
+ in
+ (t, names)
+ end;
+
+fun compile_arg size thy param_vs iss arg =
+ let
+ val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
+ fun map_params (t as Free (f, T)) =
+ if member (op =) param_vs f then
+ case (the (AList.lookup (op =) (param_vs ~~ iss) f)) of
+ SOME is => let val T' = funT_of PredicateCompFuns.compfuns ([], is) T
+ in fst (mk_Eval_of size ((Free (f, T'), T), SOME is) []) end
+ | NONE => t
+ else t
+ | map_params t = t
+ in map_aterms map_params arg end
+
+fun compile_clause compfuns size final_term thy all_vs param_vs (iss, is) inp (ts, moded_ps) =
+ let
+ fun check_constrt t (names, eqs) =
+ if is_constrt thy t then (t, (names, eqs)) else
+ let
+ val s = Name.variant names "x";
+ val v = Free (s, fastype_of t)
+ in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
+
+ val (in_ts, out_ts) = split_smode is ts;
+ val (in_ts', (all_vs', eqs)) =
+ fold_map check_constrt in_ts (all_vs, []);
+
+ fun compile_prems out_ts' vs names [] =
+ let
+ val (out_ts'', (names', eqs')) =
+ fold_map check_constrt out_ts' (names, []);
+ val (out_ts''', (names'', constr_vs)) = fold_map distinct_v
+ out_ts'' (names', map (rpair []) vs);
+ in
+ (* termify code:
+ compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
+ (mk_single compfuns (mk_tuple (map mk_valtermify_term out_ts)))
+ *)
+ compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
+ (final_term out_ts)
+ end
+ | compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) =
+ let
+ val vs' = distinct (op =) (flat (vs :: map term_vs out_ts));
+ val (out_ts', (names', eqs)) =
+ fold_map check_constrt out_ts (names, [])
+ val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
+ out_ts' ((names', map (rpair []) vs))
+ val (compiled_clause, rest) = case p of
+ Prem (us, t) =>
+ let
+ val (in_ts, out_ts''') = split_smode is us;
+ val in_ts = map (compile_arg size thy param_vs iss) in_ts
+ val args = case size of
+ NONE => in_ts
+ | SOME size_t => in_ts @ [size_t]
+ val u = lift_pred compfuns
+ (list_comb (compile_expr NONE size thy (mode, t), args))
+ val rest = compile_prems out_ts''' vs' names'' ps
+ in
+ (u, rest)
+ end
+ | Negprem (us, t) =>
+ let
+ val (in_ts, out_ts''') = split_smode is us
+ val u = lift_pred compfuns
+ (mk_not PredicateCompFuns.compfuns (list_comb (compile_expr size NONE thy (mode, t), in_ts)))
+ val rest = compile_prems out_ts''' vs' names'' ps
+ in
+ (u, rest)
+ end
+ | Sidecond t =>
+ let
+ val rest = compile_prems [] vs' names'' ps;
+ in
+ (mk_if compfuns t, rest)
+ end
+ | GeneratorPrem (us, t) =>
+ let
+ val (in_ts, out_ts''') = split_smode is us;
+ val args = case size of
+ NONE => in_ts
+ | SOME size_t => in_ts @ [size_t]
+ val u = compile_gen_expr size thy compfuns (mode, t) args
+ val rest = compile_prems out_ts''' vs' names'' ps
+ in
+ (u, rest)
+ end
+ | Generator (v, T) =>
+ let
+ val u = lift_random (HOLogic.mk_random T (the size))
+ val rest = compile_prems [Free (v, T)] vs' names'' ps;
+ in
+ (u, rest)
+ end
+ in
+ compile_match thy compfuns constr_vs' eqs out_ts''
+ (mk_bind compfuns (compiled_clause, rest))
+ end
+ val prem_t = compile_prems in_ts' param_vs all_vs' moded_ps;
+ in
+ mk_bind compfuns (mk_single compfuns inp, prem_t)
+ end
+
+fun compile_pred compfuns mk_fun_of use_size thy all_vs param_vs s T mode moded_cls =
+ let
+ val (Ts1, Ts2) = chop (length (fst mode)) (binder_types T)
+ val (Us1, Us2) = split_smodeT (snd mode) Ts2
+ val funT_of = if use_size then sizelim_funT_of else funT_of
+ val Ts1' = map2 (fn NONE => I | SOME is => funT_of PredicateCompFuns.compfuns ([], is)) (fst mode) Ts1
+ val size_name = Name.variant (all_vs @ param_vs) "size"
+ fun mk_input_term (i, NONE) =
+ [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
+ | mk_input_term (i, SOME pis) = case HOLogic.strip_tupleT (nth Ts2 (i - 1)) of
+ [] => error "strange unit input"
+ | [T] => [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
+ | Ts => let
+ val vnames = Name.variant_list (all_vs @ param_vs)
+ (map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
+ pis)
+ in if null pis then []
+ else [HOLogic.mk_tuple (map Free (vnames ~~ map (fn j => nth Ts (j - 1)) pis))] end
+ val in_ts = maps mk_input_term (snd mode)
+ val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1'
+ val size = Free (size_name, @{typ "code_numeral"})
+ val decr_size =
+ if use_size then
+ SOME (Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"})
+ $ size $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"}))
+ else
+ NONE
+ val cl_ts =
+ map (compile_clause compfuns decr_size (fn out_ts => mk_single compfuns (mk_tuple out_ts))
+ thy all_vs param_vs mode (mk_tuple in_ts)) moded_cls;
+ val t = foldr1 (mk_sup compfuns) cl_ts
+ val T' = mk_predT compfuns (mk_tupleT Us2)
+ val size_t = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
+ $ HOLogic.mk_eq (size, @{term "0 :: code_numeral"})
+ $ mk_bot compfuns (dest_predT compfuns T') $ t
+ val fun_const = mk_fun_of compfuns thy (s, T) mode
+ val eq = if use_size then
+ (list_comb (fun_const, params @ in_ts @ [size]), size_t)
+ else
+ (list_comb (fun_const, params @ in_ts), t)
+ in
+ HOLogic.mk_Trueprop (HOLogic.mk_eq eq)
+ end;
+
+(* special setup for simpset *)
+val HOL_basic_ss' = HOL_basic_ss addsimps (@{thms "HOL.simp_thms"} @ [@{thm Pair_eq}])
+ setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
+ setSolver (mk_solver "True_solver" (fn _ => rtac @{thm TrueI}))
+
+(* Definition of executable functions and their intro and elim rules *)
+
+fun print_arities arities = tracing ("Arities:\n" ^
+ cat_lines (map (fn (s, (ks, k)) => s ^ ": " ^
+ space_implode " -> " (map
+ (fn NONE => "X" | SOME k' => string_of_int k')
+ (ks @ [SOME k]))) arities));
+
+fun create_intro_elim_rule (mode as (iss, is)) defthm mode_id funT pred thy =
+let
+ val Ts = binder_types (fastype_of pred)
+ val funtrm = Const (mode_id, funT)
+ val (Ts1, Ts2) = chop (length iss) Ts;
+ val Ts1' = map2 (fn NONE => I | SOME is => funT_of (PredicateCompFuns.compfuns) ([], is)) iss Ts1
+ val param_names = Name.variant_list []
+ (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1)));
+ val params = map Free (param_names ~~ Ts1')
+ fun mk_args (i, T) argnames =
+ let
+ val vname = Name.variant (param_names @ argnames) ("x" ^ string_of_int (length Ts1' + i))
+ val default = (Free (vname, T), vname :: argnames)
+ in
+ case AList.lookup (op =) is i of
+ NONE => default
+ | SOME NONE => default
+ | SOME (SOME pis) =>
+ case HOLogic.strip_tupleT T of
+ [] => default
+ | [_] => default
+ | Ts =>
+ let
+ val vnames = Name.variant_list (param_names @ argnames)
+ (map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
+ (1 upto (length Ts)))
+ in (HOLogic.mk_tuple (map Free (vnames ~~ Ts)), vnames @ argnames) end
+ end
+ val (args, argnames) = fold_map mk_args (1 upto (length Ts2) ~~ Ts2) []
+ val (inargs, outargs) = split_smode is args
+ val param_names' = Name.variant_list (param_names @ argnames)
+ (map (fn i => "p" ^ string_of_int i) (1 upto (length iss)))
+ val param_vs = map Free (param_names' ~~ Ts1)
+ val (params', names) = fold_map (mk_Eval_of NONE) ((params ~~ Ts1) ~~ iss) []
+ val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ args))
+ val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ args))
+ val param_eqs = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (param_vs ~~ params')
+ val funargs = params @ inargs
+ val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
+ if null outargs then Free("y", HOLogic.unitT) else mk_tuple outargs))
+ val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
+ mk_tuple outargs))
+ val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
+ val simprules = [defthm, @{thm eval_pred},
+ @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
+ val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1
+ val introthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y"]) [] introtrm (fn {...} => unfolddef_tac)
+ val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
+ val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
+ val elimthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y", "P"]) [] elimtrm (fn {...} => unfolddef_tac)
+in
+ (introthm, elimthm)
+end;
+
+fun create_constname_of_mode thy prefix name mode =
+ let
+ fun string_of_mode mode = if null mode then "0"
+ else space_implode "_" (map (fn (i, NONE) => string_of_int i | (i, SOME pis) => string_of_int i ^ "p"
+ ^ space_implode "p" (map string_of_int pis)) mode)
+ val HOmode = space_implode "_and_"
+ (fold (fn NONE => I | SOME mode => cons (string_of_mode mode)) (fst mode) [])
+ in
+ (Sign.full_bname thy (prefix ^ (Long_Name.base_name name))) ^
+ (if HOmode = "" then "_" else "_for_" ^ HOmode ^ "_yields_") ^ (string_of_mode (snd mode))
+ end;
+
+fun split_tupleT is T =
+ let
+ fun split_tuple' _ _ [] = ([], [])
+ | split_tuple' is i (T::Ts) =
+ (if i mem is then apfst else apsnd) (cons T)
+ (split_tuple' is (i+1) Ts)
+ in
+ split_tuple' is 1 (HOLogic.strip_tupleT T)
+ end
+
+fun mk_arg xin xout pis T =
+ let
+ val n = length (HOLogic.strip_tupleT T)
+ val ni = length pis
+ fun mk_proj i j t =
+ (if i = j then I else HOLogic.mk_fst)
+ (funpow (i - 1) HOLogic.mk_snd t)
+ fun mk_arg' i (si, so) = if i mem pis then
+ (mk_proj si ni xin, (si+1, so))
+ else
+ (mk_proj so (n - ni) xout, (si, so+1))
+ val (args, _) = fold_map mk_arg' (1 upto n) (1, 1)
+ in
+ HOLogic.mk_tuple args
+ end
+
+fun create_definitions preds (name, modes) thy =
+ let
+ val compfuns = PredicateCompFuns.compfuns
+ val T = AList.lookup (op =) preds name |> the
+ fun create_definition (mode as (iss, is)) thy = let
+ val mode_cname = create_constname_of_mode thy "" name mode
+ val mode_cbasename = Long_Name.base_name mode_cname
+ val Ts = binder_types T
+ val (Ts1, Ts2) = chop (length iss) Ts
+ val (Us1, Us2) = split_smodeT is Ts2
+ val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1
+ val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (mk_tupleT Us2))
+ val names = Name.variant_list []
+ (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
+ (* old *)
+ (*
+ val xs = map Free (names ~~ (Ts1' @ Ts2))
+ val (xparams, xargs) = chop (length iss) xs
+ val (xins, xouts) = split_smode is xargs
+ *)
+ (* new *)
+ val param_names = Name.variant_list []
+ (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1')))
+ val xparams = map Free (param_names ~~ Ts1')
+ fun mk_vars (i, T) names =
+ let
+ val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
+ in
+ case AList.lookup (op =) is i of
+ NONE => ((([], [Free (vname, T)]), Free (vname, T)), vname :: names)
+ | SOME NONE => ((([Free (vname, T)], []), Free (vname, T)), vname :: names)
+ | SOME (SOME pis) =>
+ let
+ val (Tins, Touts) = split_tupleT pis T
+ val name_in = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "in")
+ val name_out = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "out")
+ val xin = Free (name_in, HOLogic.mk_tupleT Tins)
+ val xout = Free (name_out, HOLogic.mk_tupleT Touts)
+ val xarg = mk_arg xin xout pis T
+ in (((if null Tins then [] else [xin], if null Touts then [] else [xout]), xarg), name_in :: name_out :: names) end
+ end
+ val (xinoutargs, names) = fold_map mk_vars ((1 upto (length Ts2)) ~~ Ts2) param_names
+ val (xinout, xargs) = split_list xinoutargs
+ val (xins, xouts) = pairself flat (split_list xinout)
+ val (xparams', names') = fold_map (mk_Eval_of NONE) ((xparams ~~ Ts1) ~~ iss) names
+ fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t
+ | mk_split_lambda [x] t = lambda x t
+ | mk_split_lambda xs t =
+ let
+ fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
+ | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
+ in
+ mk_split_lambda' xs t
+ end;
+ val predterm = PredicateCompFuns.mk_Enum (mk_split_lambda xouts
+ (list_comb (Const (name, T), xparams' @ xargs)))
+ val lhs = list_comb (Const (mode_cname, funT), xparams @ xins)
+ val def = Logic.mk_equals (lhs, predterm)
+ val ([definition], thy') = thy |>
+ Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |>
+ PureThy.add_defs false [((Binding.name (mode_cbasename ^ "_def"), def), [])]
+ val (intro, elim) =
+ create_intro_elim_rule mode definition mode_cname funT (Const (name, T)) thy'
+ in thy'
+ |> add_predfun name mode (mode_cname, definition, intro, elim)
+ |> PureThy.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd
+ |> PureThy.store_thm (Binding.name (mode_cbasename ^ "E"), elim) |> snd
+ |> Theory.checkpoint
+ end;
+ in
+ fold create_definition modes thy
+ end;
+
+fun sizelim_create_definitions preds (name, modes) thy =
+ let
+ val T = AList.lookup (op =) preds name |> the
+ fun create_definition mode thy =
+ let
+ val mode_cname = create_constname_of_mode thy "sizelim_" name mode
+ val funT = sizelim_funT_of PredicateCompFuns.compfuns mode T
+ in
+ thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
+ |> set_sizelim_function_name name mode mode_cname
+ end;
+ in
+ fold create_definition modes thy
+ end;
+
+fun generator_funT_of (iss, is) T =
+ let
+ val Ts = binder_types T
+ val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
+ val paramTs' = map2 (fn SOME is => sizelim_funT_of PredicateCompFuns.compfuns ([], is) | NONE => I) iss paramTs
+ in
+ (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT RPredCompFuns.compfuns (mk_tupleT outargTs))
+ end
+
+fun rpred_create_definitions preds (name, modes) thy =
+ let
+ val T = AList.lookup (op =) preds name |> the
+ fun create_definition mode thy =
+ let
+ val mode_cname = create_constname_of_mode thy "gen_" name mode
+ val funT = generator_funT_of mode T
+ in
+ thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
+ |> set_generator_name name mode mode_cname
+ end;
+ in
+ fold create_definition modes thy
+ end;
+
+(* Proving equivalence of term *)
+
+fun is_Type (Type _) = true
+ | is_Type _ = false
+
+(* returns true if t is an application of an datatype constructor *)
+(* which then consequently would be splitted *)
+(* else false *)
+fun is_constructor thy t =
+ if (is_Type (fastype_of t)) then
+ (case Datatype.get_info thy ((fst o dest_Type o fastype_of) t) of
+ NONE => false
+ | SOME info => (let
+ val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
+ val (c, _) = strip_comb t
+ in (case c of
+ Const (name, _) => name mem_string constr_consts
+ | _ => false) end))
+ else false
+
+(* MAJOR FIXME: prove_params should be simple
+ - different form of introrule for parameters ? *)
+fun prove_param thy (NONE, t) = TRY (rtac @{thm refl} 1)
+ | prove_param thy (m as SOME (Mode (mode, is, ms)), t) =
+ let
+ val (f, args) = strip_comb (Envir.eta_contract t)
+ val (params, _) = chop (length ms) args
+ val f_tac = case f of
+ Const (name, T) => simp_tac (HOL_basic_ss addsimps
+ ([@{thm eval_pred}, (predfun_definition_of thy name mode),
+ @{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
+ @{thm "snd_conv"}, @{thm pair_collapse}, @{thm "Product_Type.split_conv"}])) 1
+ | Free _ => TRY (rtac @{thm refl} 1)
+ | Abs _ => error "prove_param: No valid parameter term"
+ in
+ REPEAT_DETERM (etac @{thm thin_rl} 1)
+ THEN REPEAT_DETERM (rtac @{thm ext} 1)
+ THEN print_tac "prove_param"
+ THEN f_tac
+ THEN print_tac "after simplification in prove_args"
+ THEN (EVERY (map (prove_param thy) (ms ~~ params)))
+ THEN (REPEAT_DETERM (atac 1))
+ end
+
+fun prove_expr thy (Mode (mode, is, ms), t, us) (premposition : int) =
+ case strip_comb t of
+ (Const (name, T), args) =>
+ let
+ val introrule = predfun_intro_of thy name mode
+ val (args1, args2) = chop (length ms) args
+ in
+ rtac @{thm bindI} 1
+ THEN print_tac "before intro rule:"
+ (* for the right assumption in first position *)
+ THEN rotate_tac premposition 1
+ THEN debug_tac (Display.string_of_thm (ProofContext.init thy) introrule)
+ THEN rtac introrule 1
+ THEN print_tac "after intro rule"
+ (* work with parameter arguments *)
+ THEN (atac 1)
+ THEN (print_tac "parameter goal")
+ THEN (EVERY (map (prove_param thy) (ms ~~ args1)))
+ THEN (REPEAT_DETERM (atac 1))
+ end
+ | _ => rtac @{thm bindI} 1
+ THEN asm_full_simp_tac
+ (HOL_basic_ss' addsimps [@{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
+ @{thm "snd_conv"}, @{thm pair_collapse}]) 1
+ THEN (atac 1)
+ THEN print_tac "after prove parameter call"
+
+
+fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st;
+
+fun SOLVEDALL tac st = FILTER (fn st' => nprems_of st' = 0) tac st
+
+fun prove_match thy (out_ts : term list) = let
+ fun get_case_rewrite t =
+ if (is_constructor thy t) then let
+ val case_rewrites = (#case_rewrites (Datatype.the_info thy
+ ((fst o dest_Type o fastype_of) t)))
+ in case_rewrites @ (flat (map get_case_rewrite (snd (strip_comb t)))) end
+ else []
+ val simprules = @{thm "unit.cases"} :: @{thm "prod.cases"} :: (flat (map get_case_rewrite out_ts))
+(* replace TRY by determining if it necessary - are there equations when calling compile match? *)
+in
+ (* make this simpset better! *)
+ asm_full_simp_tac (HOL_basic_ss' addsimps simprules) 1
+ THEN print_tac "after prove_match:"
+ THEN (DETERM (TRY (EqSubst.eqsubst_tac (ProofContext.init thy) [0] [@{thm "HOL.if_P"}] 1
+ THEN (REPEAT_DETERM (rtac @{thm conjI} 1 THEN (SOLVED (asm_simp_tac HOL_basic_ss 1))))
+ THEN (SOLVED (asm_simp_tac HOL_basic_ss 1)))))
+ THEN print_tac "after if simplification"
+end;
+
+(* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
+
+fun prove_sidecond thy modes t =
+ let
+ fun preds_of t nameTs = case strip_comb t of
+ (f as Const (name, T), args) =>
+ if AList.defined (op =) modes name then (name, T) :: nameTs
+ else fold preds_of args nameTs
+ | _ => nameTs
+ val preds = preds_of t []
+ val defs = map
+ (fn (pred, T) => predfun_definition_of thy pred
+ ([], map (rpair NONE) (1 upto (length (binder_types T)))))
+ preds
+ in
+ (* remove not_False_eq_True when simpset in prove_match is better *)
+ simp_tac (HOL_basic_ss addsimps
+ (@{thms "HOL.simp_thms"} @ (@{thm not_False_eq_True} :: @{thm eval_pred} :: defs))) 1
+ (* need better control here! *)
+ end
+
+fun prove_clause thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
+ let
+ val (in_ts, clause_out_ts) = split_smode is ts;
+ fun prove_prems out_ts [] =
+ (prove_match thy out_ts)
+ THEN print_tac "before simplifying assumptions"
+ THEN asm_full_simp_tac HOL_basic_ss' 1
+ THEN print_tac "before single intro rule"
+ THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
+ | prove_prems out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
+ let
+ val premposition = (find_index (equal p) clauses) + nargs
+ val rest_tac = (case p of Prem (us, t) =>
+ let
+ val (_, out_ts''') = split_smode is us
+ val rec_tac = prove_prems out_ts''' ps
+ in
+ print_tac "before clause:"
+ THEN asm_simp_tac HOL_basic_ss 1
+ THEN print_tac "before prove_expr:"
+ THEN prove_expr thy (mode, t, us) premposition
+ THEN print_tac "after prove_expr:"
+ THEN rec_tac
+ end
+ | Negprem (us, t) =>
+ let
+ val (_, out_ts''') = split_smode is us
+ val rec_tac = prove_prems out_ts''' ps
+ val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
+ val (_, params) = strip_comb t
+ in
+ rtac @{thm bindI} 1
+ THEN (if (is_some name) then
+ simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1
+ THEN rtac @{thm not_predI} 1
+ THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
+ THEN (REPEAT_DETERM (atac 1))
+ (* FIXME: work with parameter arguments *)
+ THEN (EVERY (map (prove_param thy) (param_modes ~~ params)))
+ else
+ rtac @{thm not_predI'} 1)
+ THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
+ THEN rec_tac
+ end
+ | Sidecond t =>
+ rtac @{thm bindI} 1
+ THEN rtac @{thm if_predI} 1
+ THEN print_tac "before sidecond:"
+ THEN prove_sidecond thy modes t
+ THEN print_tac "after sidecond:"
+ THEN prove_prems [] ps)
+ in (prove_match thy out_ts)
+ THEN rest_tac
+ end;
+ val prems_tac = prove_prems in_ts moded_ps
+ in
+ rtac @{thm bindI} 1
+ THEN rtac @{thm singleI} 1
+ THEN prems_tac
+ end;
+
+fun select_sup 1 1 = []
+ | select_sup _ 1 = [rtac @{thm supI1}]
+ | select_sup n i = (rtac @{thm supI2})::(select_sup (n - 1) (i - 1));
+
+fun prove_one_direction thy clauses preds modes pred mode moded_clauses =
+ let
+ val T = the (AList.lookup (op =) preds pred)
+ val nargs = length (binder_types T) - nparams_of thy pred
+ val pred_case_rule = the_elim_of thy pred
+ in
+ REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))
+ THEN print_tac "before applying elim rule"
+ THEN etac (predfun_elim_of thy pred mode) 1
+ THEN etac pred_case_rule 1
+ THEN (EVERY (map
+ (fn i => EVERY' (select_sup (length moded_clauses) i) i)
+ (1 upto (length moded_clauses))))
+ THEN (EVERY (map2 (prove_clause thy nargs modes mode) clauses moded_clauses))
+ THEN print_tac "proved one direction"
+ end;
+
+(** Proof in the other direction **)
+
+fun prove_match2 thy out_ts = let
+ fun split_term_tac (Free _) = all_tac
+ | split_term_tac t =
+ if (is_constructor thy t) then let
+ val info = Datatype.the_info thy ((fst o dest_Type o fastype_of) t)
+ val num_of_constrs = length (#case_rewrites info)
+ (* special treatment of pairs -- because of fishing *)
+ val split_rules = case (fst o dest_Type o fastype_of) t of
+ "*" => [@{thm prod.split_asm}]
+ | _ => PureThy.get_thms thy (((fst o dest_Type o fastype_of) t) ^ ".split_asm")
+ val (_, ts) = strip_comb t
+ in
+ (Splitter.split_asm_tac split_rules 1)
+(* THEN (Simplifier.asm_full_simp_tac HOL_basic_ss 1)
+ THEN (DETERM (TRY (etac @{thm Pair_inject} 1))) *)
+ THEN (REPEAT_DETERM_N (num_of_constrs - 1) (etac @{thm botE} 1 ORELSE etac @{thm botE} 2))
+ THEN (EVERY (map split_term_tac ts))
+ end
+ else all_tac
+ in
+ split_term_tac (mk_tuple out_ts)
+ THEN (DETERM (TRY ((Splitter.split_asm_tac [@{thm "split_if_asm"}] 1) THEN (etac @{thm botE} 2))))
+ end
+
+(* VERY LARGE SIMILIRATIY to function prove_param
+-- join both functions
+*)
+(* TODO: remove function *)
+
+fun prove_param2 thy (NONE, t) = all_tac
+ | prove_param2 thy (m as SOME (Mode (mode, is, ms)), t) = let
+ val (f, args) = strip_comb (Envir.eta_contract t)
+ val (params, _) = chop (length ms) args
+ val f_tac = case f of
+ Const (name, T) => full_simp_tac (HOL_basic_ss addsimps
+ (@{thm eval_pred}::(predfun_definition_of thy name mode)
+ :: @{thm "Product_Type.split_conv"}::[])) 1
+ | Free _ => all_tac
+ | _ => error "prove_param2: illegal parameter term"
+ in
+ print_tac "before simplification in prove_args:"
+ THEN f_tac
+ THEN print_tac "after simplification in prove_args"
+ THEN (EVERY (map (prove_param2 thy) (ms ~~ params)))
+ end
+
+
+fun prove_expr2 thy (Mode (mode, is, ms), t) =
+ (case strip_comb t of
+ (Const (name, T), args) =>
+ etac @{thm bindE} 1
+ THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})))
+ THEN print_tac "prove_expr2-before"
+ THEN (debug_tac (Syntax.string_of_term_global thy
+ (prop_of (predfun_elim_of thy name mode))))
+ THEN (etac (predfun_elim_of thy name mode) 1)
+ THEN print_tac "prove_expr2"
+ THEN (EVERY (map (prove_param2 thy) (ms ~~ args)))
+ THEN print_tac "finished prove_expr2"
+ | _ => etac @{thm bindE} 1)
+
+(* FIXME: what is this for? *)
+(* replace defined by has_mode thy pred *)
+(* TODO: rewrite function *)
+fun prove_sidecond2 thy modes t = let
+ fun preds_of t nameTs = case strip_comb t of
+ (f as Const (name, T), args) =>
+ if AList.defined (op =) modes name then (name, T) :: nameTs
+ else fold preds_of args nameTs
+ | _ => nameTs
+ val preds = preds_of t []
+ val defs = map
+ (fn (pred, T) => predfun_definition_of thy pred
+ ([], map (rpair NONE) (1 upto (length (binder_types T)))))
+ preds
+ in
+ (* only simplify the one assumption *)
+ full_simp_tac (HOL_basic_ss' addsimps @{thm eval_pred} :: defs) 1
+ (* need better control here! *)
+ THEN print_tac "after sidecond2 simplification"
+ end
+
+fun prove_clause2 thy modes pred (iss, is) (ts, ps) i =
+ let
+ val pred_intro_rule = nth (intros_of thy pred) (i - 1)
+ val (in_ts, clause_out_ts) = split_smode is ts;
+ fun prove_prems2 out_ts [] =
+ print_tac "before prove_match2 - last call:"
+ THEN prove_match2 thy out_ts
+ THEN print_tac "after prove_match2 - last call:"
+ THEN (etac @{thm singleE} 1)
+ THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
+ THEN (asm_full_simp_tac HOL_basic_ss' 1)
+ THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
+ THEN (asm_full_simp_tac HOL_basic_ss' 1)
+ THEN SOLVED (print_tac "state before applying intro rule:"
+ THEN (rtac pred_intro_rule 1)
+ (* How to handle equality correctly? *)
+ THEN (print_tac "state before assumption matching")
+ THEN (REPEAT (atac 1 ORELSE
+ (CHANGED (asm_full_simp_tac (HOL_basic_ss' addsimps
+ [@{thm split_eta}, @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]) 1)
+ THEN print_tac "state after simp_tac:"))))
+ | prove_prems2 out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
+ let
+ val rest_tac = (case p of
+ Prem (us, t) =>
+ let
+ val (_, out_ts''') = split_smode is us
+ val rec_tac = prove_prems2 out_ts''' ps
+ in
+ (prove_expr2 thy (mode, t)) THEN rec_tac
+ end
+ | Negprem (us, t) =>
+ let
+ val (_, out_ts''') = split_smode is us
+ val rec_tac = prove_prems2 out_ts''' ps
+ val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
+ val (_, params) = strip_comb t
+ in
+ print_tac "before neg prem 2"
+ THEN etac @{thm bindE} 1
+ THEN (if is_some name then
+ full_simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1
+ THEN etac @{thm not_predE} 1
+ THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
+ THEN (EVERY (map (prove_param2 thy) (param_modes ~~ params)))
+ else
+ etac @{thm not_predE'} 1)
+ THEN rec_tac
+ end
+ | Sidecond t =>
+ etac @{thm bindE} 1
+ THEN etac @{thm if_predE} 1
+ THEN prove_sidecond2 thy modes t
+ THEN prove_prems2 [] ps)
+ in print_tac "before prove_match2:"
+ THEN prove_match2 thy out_ts
+ THEN print_tac "after prove_match2:"
+ THEN rest_tac
+ end;
+ val prems_tac = prove_prems2 in_ts ps
+ in
+ print_tac "starting prove_clause2"
+ THEN etac @{thm bindE} 1
+ THEN (etac @{thm singleE'} 1)
+ THEN (TRY (etac @{thm Pair_inject} 1))
+ THEN print_tac "after singleE':"
+ THEN prems_tac
+ end;
+
+fun prove_other_direction thy modes pred mode moded_clauses =
+ let
+ fun prove_clause clause i =
+ (if i < length moded_clauses then etac @{thm supE} 1 else all_tac)
+ THEN (prove_clause2 thy modes pred mode clause i)
+ in
+ (DETERM (TRY (rtac @{thm unit.induct} 1)))
+ THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all})))
+ THEN (rtac (predfun_intro_of thy pred mode) 1)
+ THEN (REPEAT_DETERM (rtac @{thm refl} 2))
+ THEN (EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
+ end;
+
+(** proof procedure **)
+
+fun prove_pred thy clauses preds modes pred mode (moded_clauses, compiled_term) =
+ let
+ val ctxt = ProofContext.init thy
+ val clauses = the (AList.lookup (op =) clauses pred)
+ in
+ Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
+ (if !do_proofs then
+ (fn _ =>
+ rtac @{thm pred_iffI} 1
+ THEN print_tac "after pred_iffI"
+ THEN prove_one_direction thy clauses preds modes pred mode moded_clauses
+ THEN print_tac "proved one direction"
+ THEN prove_other_direction thy modes pred mode moded_clauses
+ THEN print_tac "proved other direction")
+ else (fn _ => setmp quick_and_dirty true SkipProof.cheat_tac thy))
+ end;
+
+(* composition of mode inference, definition, compilation and proof *)
+
+(** auxillary combinators for table of preds and modes **)
+
+fun map_preds_modes f preds_modes_table =
+ map (fn (pred, modes) =>
+ (pred, map (fn (mode, value) => (mode, f pred mode value)) modes)) preds_modes_table
+
+fun join_preds_modes table1 table2 =
+ map_preds_modes (fn pred => fn mode => fn value =>
+ (value, the (AList.lookup (op =) (the (AList.lookup (op =) table2 pred)) mode))) table1
+
+fun maps_modes preds_modes_table =
+ map (fn (pred, modes) =>
+ (pred, map (fn (mode, value) => value) modes)) preds_modes_table
+
+fun compile_preds compfuns mk_fun_of use_size thy all_vs param_vs preds moded_clauses =
+ map_preds_modes (fn pred => compile_pred compfuns mk_fun_of use_size thy all_vs param_vs pred
+ (the (AList.lookup (op =) preds pred))) moded_clauses
+
+fun prove thy clauses preds modes moded_clauses compiled_terms =
+ map_preds_modes (prove_pred thy clauses preds modes)
+ (join_preds_modes moded_clauses compiled_terms)
+
+fun prove_by_skip thy _ _ _ _ compiled_terms =
+ map_preds_modes (fn pred => fn mode => fn t => Drule.standard (setmp quick_and_dirty true (SkipProof.make_thm thy) t))
+ compiled_terms
+
+fun prepare_intrs thy prednames =
+ let
+ val intrs = maps (intros_of thy) prednames
+ |> map (Logic.unvarify o prop_of)
+ val nparams = nparams_of thy (hd prednames)
+ val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name)
+ val preds = distinct (op =) (map (dest_Const o fst o (strip_intro_concl nparams)) intrs)
+ val _ $ u = Logic.strip_imp_concl (hd intrs);
+ val params = List.take (snd (strip_comb u), nparams);
+ val param_vs = maps term_vs params
+ val all_vs = terms_vs intrs
+ fun dest_prem t =
+ (case strip_comb t of
+ (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t
+ | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of
+ Prem (ts, t) => Negprem (ts, t)
+ | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t)))
+ | Sidecond t => Sidecond (c $ t))
+ | (c as Const (s, _), ts) =>
+ if is_registered thy s then
+ let val (ts1, ts2) = chop (nparams_of thy s) ts
+ in Prem (ts2, list_comb (c, ts1)) end
+ else Sidecond t
+ | _ => Sidecond t)
+ fun add_clause intr (clauses, arities) =
+ let
+ val _ $ t = Logic.strip_imp_concl intr;
+ val (Const (name, T), ts) = strip_comb t;
+ val (ts1, ts2) = chop nparams ts;
+ val prems = map (dest_prem o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
+ val (Ts, Us) = chop nparams (binder_types T)
+ in
+ (AList.update op = (name, these (AList.lookup op = clauses name) @
+ [(ts2, prems)]) clauses,
+ AList.update op = (name, (map (fn U => (case strip_type U of
+ (Rs as _ :: _, Type ("bool", [])) => SOME (length Rs)
+ | _ => NONE)) Ts,
+ length Us)) arities)
+ end;
+ val (clauses, arities) = fold add_clause intrs ([], []);
+ fun modes_of_arities arities =
+ (map (fn (s, (ks, k)) => (s, cprod (cprods (map
+ (fn NONE => [NONE]
+ | SOME k' => map SOME (map (map (rpair NONE)) (subsets 1 k'))) ks),
+ map (map (rpair NONE)) (subsets 1 k)))) arities)
+ fun modes_of_typ T =
+ let
+ val (Ts, Us) = chop nparams (binder_types T)
+ fun all_smodes_of_typs Ts = cprods_subset (
+ map_index (fn (i, U) =>
+ case HOLogic.strip_tupleT U of
+ [] => [(i + 1, NONE)]
+ | [U] => [(i + 1, NONE)]
+ | Us => (i + 1, NONE) ::
+ (map (pair (i + 1) o SOME) ((subsets 1 (length Us)) \\ [[], 1 upto (length Us)])))
+ Ts)
+ in
+ cprod (cprods (map (fn T => case strip_type T of
+ (Rs as _ :: _, Type ("bool", [])) => map SOME (all_smodes_of_typs Rs) | _ => [NONE]) Ts),
+ all_smodes_of_typs Us)
+ end
+ val all_modes = map (fn (s, T) => (s, modes_of_typ T)) preds
+ in (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) end;
+
+(** main function of predicate compiler **)
+
+fun add_equations_of steps prednames thy =
+ let
+ val _ = Output.tracing ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
+ val _ = Output.tracing (commas (map (Display.string_of_thm_global thy) (maps (intros_of thy) prednames)))
+ val (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) =
+ prepare_intrs thy prednames
+ val _ = Output.tracing "Infering modes..."
+ val moded_clauses = #infer_modes steps thy extra_modes all_modes param_vs clauses
+ val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
+ val _ = print_modes modes
+ val _ = print_moded_clauses thy moded_clauses
+ val _ = Output.tracing "Defining executable functions..."
+ val thy' = fold (#create_definitions steps preds) modes thy
+ |> Theory.checkpoint
+ val _ = Output.tracing "Compiling equations..."
+ val compiled_terms =
+ (#compile_preds steps) thy' all_vs param_vs preds moded_clauses
+ val _ = print_compiled_terms thy' compiled_terms
+ val _ = Output.tracing "Proving equations..."
+ val result_thms = #prove steps thy' clauses preds (extra_modes @ modes)
+ moded_clauses compiled_terms
+ val qname = #qname steps
+ (* val attrib = gn thy => Attrib.attribute_i thy Code.add_eqn_attrib *)
+ val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute
+ (fn thm => Context.mapping (Code.add_eqn thm) I))))
+ val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
+ [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms),
+ [attrib thy ])] thy))
+ (maps_modes result_thms) thy'
+ |> Theory.checkpoint
+ in
+ thy''
+ end
+
+fun extend' value_of edges_of key (G, visited) =
+ let
+ val (G', v) = case try (Graph.get_node G) key of
+ SOME v => (G, v)
+ | NONE => (Graph.new_node (key, value_of key) G, value_of key)
+ val (G'', visited') = fold (extend' value_of edges_of) (edges_of (key, v) \\ visited)
+ (G', key :: visited)
+ in
+ (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited')
+ end;
+
+fun extend value_of edges_of key G = fst (extend' value_of edges_of key (G, []))
+
+fun gen_add_equations steps names thy =
+ let
+ val thy' = PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names) thy
+ |> Theory.checkpoint;
+ fun strong_conn_of gr keys =
+ Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr)
+ val scc = strong_conn_of (PredData.get thy') names
+ val thy'' = fold_rev
+ (fn preds => fn thy =>
+ if #are_not_defined steps thy preds then add_equations_of steps preds thy else thy)
+ scc thy' |> Theory.checkpoint
+ in thy'' end
+
+(* different instantiantions of the predicate compiler *)
+
+val add_equations = gen_add_equations
+ {infer_modes = infer_modes,
+ create_definitions = create_definitions,
+ compile_preds = compile_preds PredicateCompFuns.compfuns mk_fun_of false,
+ prove = prove,
+ are_not_defined = fn thy => forall (null o modes_of thy),
+ qname = "equation"}
+
+val add_sizelim_equations = gen_add_equations
+ {infer_modes = infer_modes,
+ create_definitions = sizelim_create_definitions,
+ compile_preds = compile_preds PredicateCompFuns.compfuns mk_sizelim_fun_of true,
+ prove = prove_by_skip,
+ are_not_defined = fn thy => forall (null o sizelim_modes_of thy),
+ qname = "sizelim_equation"
+ }
+
+val add_quickcheck_equations = gen_add_equations
+ {infer_modes = infer_modes_with_generator,
+ create_definitions = rpred_create_definitions,
+ compile_preds = compile_preds RPredCompFuns.compfuns mk_generator_of true,
+ prove = prove_by_skip,
+ are_not_defined = fn thy => forall (null o rpred_modes_of thy),
+ qname = "rpred_equation"}
+
+(** user interface **)
+
+(* code_pred_intro attribute *)
+
+fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
+
+val code_pred_intros_attrib = attrib add_intro;
+
+
+(*FIXME
+- Naming of auxiliary rules necessary?
+- add default code equations P x y z = P_i_i_i x y z
+*)
+
+val setup = PredData.put (Graph.empty) #>
+ Attrib.setup @{binding code_pred_intros} (Scan.succeed (attrib add_intro))
+ "adding alternative introduction rules for code generation of inductive predicates"
+(* Attrib.setup @{binding code_ind_cases} (Scan.succeed add_elim_attrib)
+ "adding alternative elimination rules for code generation of inductive predicates";
+ *)
+ (*FIXME name discrepancy in attribs and ML code*)
+ (*FIXME intros should be better named intro*)
+ (*FIXME why distinguished attribute for cases?*)
+
+(* TODO: make TheoryDataFun to GenericDataFun & remove duplication of local theory and theory *)
+fun generic_code_pred prep_const rpred raw_const lthy =
+ let
+ val thy = ProofContext.theory_of lthy
+ val const = prep_const thy raw_const
+ val lthy' = LocalTheory.theory (PredData.map
+ (extend (fetch_pred_data thy) (depending_preds_of thy) const)) lthy
+ |> LocalTheory.checkpoint
+ val thy' = ProofContext.theory_of lthy'
+ val preds = Graph.all_preds (PredData.get thy') [const] |> filter_out (has_elim thy')
+ fun mk_cases const =
+ let
+ val nparams = nparams_of thy' const
+ val intros = intros_of thy' const
+ in mk_casesrule lthy' nparams intros end
+ val cases_rules = map mk_cases preds
+ val cases =
+ map (fn case_rule => RuleCases.Case {fixes = [],
+ assumes = [("", Logic.strip_imp_prems case_rule)],
+ binds = [], cases = []}) cases_rules
+ val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases
+ val lthy'' = lthy'
+ |> fold Variable.auto_fixes cases_rules
+ |> ProofContext.add_cases true case_env
+ fun after_qed thms goal_ctxt =
+ let
+ val global_thms = ProofContext.export goal_ctxt
+ (ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms)
+ in
+ goal_ctxt |> LocalTheory.theory (fold set_elim global_thms #>
+ (if rpred then
+ (add_equations [const] #>
+ add_sizelim_equations [const] #> add_quickcheck_equations [const])
+ else add_equations [const]))
+ end
+ in
+ Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
+ end;
+
+val code_pred = generic_code_pred (K I);
+val code_pred_cmd = generic_code_pred Code.read_const
+
+(* transformation for code generation *)
+
+val eval_ref = Unsynchronized.ref (NONE : (unit -> term Predicate.pred) option);
+
+(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
+fun analyze_compr thy t_compr =
+ let
+ val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
+ | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t_compr);
+ val (body, Ts, fp) = HOLogic.strip_psplits split;
+ val (pred as Const (name, T), all_args) = strip_comb body;
+ val (params, args) = chop (nparams_of thy name) all_args;
+ val user_mode = map_filter I (map_index
+ (fn (i, t) => case t of Bound j => if j < length Ts then NONE
+ else SOME (i+1) | _ => SOME (i+1)) args); (*FIXME dangling bounds should not occur*)
+ val user_mode' = map (rpair NONE) user_mode
+ val modes = filter (fn Mode (_, is, _) => is = user_mode')
+ (modes_of_term (all_modes_of thy) (list_comb (pred, params)));
+ val m = case modes
+ of [] => error ("No mode possible for comprehension "
+ ^ Syntax.string_of_term_global thy t_compr)
+ | [m] => m
+ | m :: _ :: _ => (warning ("Multiple modes possible for comprehension "
+ ^ Syntax.string_of_term_global thy t_compr); m);
+ val (inargs, outargs) = split_smode user_mode' args;
+ val t_pred = list_comb (compile_expr NONE NONE thy (m, list_comb (pred, params)), inargs);
+ val t_eval = if null outargs then t_pred else
+ let
+ val outargs_bounds = map (fn Bound i => i) outargs;
+ val outargsTs = map (nth Ts) outargs_bounds;
+ val T_pred = HOLogic.mk_tupleT outargsTs;
+ val T_compr = HOLogic.mk_ptupleT fp Ts;
+ val arrange_bounds = map_index I outargs_bounds
+ |> sort (prod_ord (K EQUAL) int_ord)
+ |> map fst;
+ val arrange = funpow (length outargs_bounds - 1) HOLogic.mk_split
+ (Term.list_abs (map (pair "") outargsTs,
+ HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds)))
+ in mk_map PredicateCompFuns.compfuns T_pred T_compr arrange t_pred end
+ in t_eval end;
+
+fun eval thy t_compr =
+ let
+ val t = analyze_compr thy t_compr;
+ val T = dest_predT PredicateCompFuns.compfuns (fastype_of t);
+ val t' = mk_map PredicateCompFuns.compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
+ in (T, Code_ML.eval NONE ("Predicate_Compile_Core.eval_ref", eval_ref) Predicate.map thy t' []) end;
+
+fun values ctxt k t_compr =
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val (T, t) = eval thy t_compr;
+ val setT = HOLogic.mk_setT T;
+ val (ts, _) = Predicate.yieldn k t;
+ val elemsT = HOLogic.mk_set T ts;
+ in if k = ~1 orelse length ts < k then elemsT
+ else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ t_compr
+ end;
+ (*
+fun random_values ctxt k t =
+ let
+ val thy = ProofContext.theory_of ctxt
+ val _ =
+ in
+ end;
+ *)
+fun values_cmd modes k raw_t state =
+ let
+ val ctxt = Toplevel.context_of state;
+ val t = Syntax.read_term ctxt raw_t;
+ val t' = values ctxt k t;
+ val ty' = Term.type_of t';
+ val ctxt' = Variable.auto_fixes t' ctxt;
+ val p = PrintMode.with_modes modes (fn () =>
+ Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
+ Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
+ in Pretty.writeln p end;
+
+
+local structure P = OuterParse in
+
+val opt_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
+
+val _ = OuterSyntax.improper_command "values" "enumerate and print comprehensions" OuterKeyword.diag
+ (opt_modes -- Scan.optional P.nat ~1 -- P.term
+ >> (fn ((modes, k), t) => Toplevel.no_timing o Toplevel.keep
+ (values_cmd modes k t)));
+
+end;
+
+end;
--- a/src/HOL/Tools/Qelim/cooper.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Qelim/cooper.ML Thu Oct 01 07:40:25 2009 +0200
@@ -29,30 +29,30 @@
val bT = HOLogic.boolT;
val dest_numeral = HOLogic.dest_number #> snd;
-val [miconj, midisj, mieq, mineq, milt, mile, migt, mige, midvd, mindvd, miP] =
+val [miconj, midisj, mieq, mineq, milt, mile, migt, mige, midvd, mindvd, miP] =
map(instantiate' [SOME @{ctyp "int"}] []) @{thms "minf"};
-val [infDconj, infDdisj, infDdvd,infDndvd,infDP] =
+val [infDconj, infDdisj, infDdvd,infDndvd,infDP] =
map(instantiate' [SOME @{ctyp "int"}] []) @{thms "inf_period"};
-val [piconj, pidisj, pieq,pineq,pilt,pile,pigt,pige,pidvd,pindvd,piP] =
+val [piconj, pidisj, pieq,pineq,pilt,pile,pigt,pige,pidvd,pindvd,piP] =
map (instantiate' [SOME @{ctyp "int"}] []) @{thms "pinf"};
val [miP, piP] = map (instantiate' [SOME @{ctyp "bool"}] []) [miP, piP];
val infDP = instantiate' (map SOME [@{ctyp "int"}, @{ctyp "bool"}]) [] infDP;
-val [[asetconj, asetdisj, aseteq, asetneq, asetlt, asetle,
+val [[asetconj, asetdisj, aseteq, asetneq, asetlt, asetle,
asetgt, asetge, asetdvd, asetndvd,asetP],
- [bsetconj, bsetdisj, bseteq, bsetneq, bsetlt, bsetle,
+ [bsetconj, bsetdisj, bseteq, bsetneq, bsetlt, bsetle,
bsetgt, bsetge, bsetdvd, bsetndvd,bsetP]] = [@{thms "aset"}, @{thms "bset"}];
-val [miex, cpmi, piex, cppi] = [@{thm "minusinfinity"}, @{thm "cpmi"},
+val [miex, cpmi, piex, cppi] = [@{thm "minusinfinity"}, @{thm "cpmi"},
@{thm "plusinfinity"}, @{thm "cppi"}];
val unity_coeff_ex = instantiate' [SOME @{ctyp "int"}] [] @{thm "unity_coeff_ex"};
-val [zdvd_mono,simp_from_to,all_not_ex] =
+val [zdvd_mono,simp_from_to,all_not_ex] =
[@{thm "zdvd_mono"}, @{thm "simp_from_to"}, @{thm "all_not_ex"}];
val [dvd_uminus, dvd_uminus'] = @{thms "uminus_dvd_conv"};
@@ -62,49 +62,49 @@
(* recognising cterm without moving to terms *)
-datatype fm = And of cterm*cterm| Or of cterm*cterm| Eq of cterm | NEq of cterm
+datatype fm = And of cterm*cterm| Or of cterm*cterm| Eq of cterm | NEq of cterm
| Lt of cterm | Le of cterm | Gt of cterm | Ge of cterm
| Dvd of cterm*cterm | NDvd of cterm*cterm | Nox
-fun whatis x ct =
-( case (term_of ct) of
+fun whatis x ct =
+( case (term_of ct) of
Const("op &",_)$_$_ => And (Thm.dest_binop ct)
| Const ("op |",_)$_$_ => Or (Thm.dest_binop ct)
| 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$_) =>
+| 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 HOL.less}, _) $ y$ z =>
- if term_of x aconv y then Lt (Thm.dest_arg ct)
+ 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 HOL.less_eq}, _) $ y $ z =>
- if term_of x aconv y then Le (Thm.dest_arg ct)
+| Const (@{const_name HOL.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 HOL.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 "HOL.plus"},_)$y$_)) =>
- if term_of x aconv y then
- NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox
+ 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 HOL.plus},_)$y$_)) =>
+ if term_of x aconv y then
+ NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox
| _ => Nox)
- handle CTERM _ => Nox;
+ handle CTERM _ => Nox;
-fun get_pmi_term t =
- let val (x,eq) =
+fun get_pmi_term t =
+ let val (x,eq) =
(Thm.dest_abs NONE o Thm.dest_arg o snd o Thm.dest_abs NONE o Thm.dest_arg)
(Thm.dest_arg t)
in (Thm.cabs x o Thm.dest_arg o Thm.dest_arg) eq end;
val get_pmi = get_pmi_term o cprop_of;
-val p_v' = @{cpat "?P' :: int => bool"};
+val p_v' = @{cpat "?P' :: int => bool"};
val q_v' = @{cpat "?Q' :: int => bool"};
val p_v = @{cpat "?P:: int => bool"};
val q_v = @{cpat "?Q:: int => bool"};
-fun myfwd (th1, th2, th3) p q
- [(th_1,th_2,th_3), (th_1',th_2',th_3')] =
- let
+fun myfwd (th1, th2, th3) p q
+ [(th_1,th_2,th_3), (th_1',th_2',th_3')] =
+ let
val (mp', mq') = (get_pmi th_1, get_pmi th_1')
- val mi_th = FWD (instantiate ([],[(p_v,p),(q_v,q), (p_v',mp'),(q_v',mq')]) th1)
+ val mi_th = FWD (instantiate ([],[(p_v,p),(q_v,q), (p_v',mp'),(q_v',mq')]) th1)
[th_1, th_1']
val infD_th = FWD (instantiate ([],[(p_v,mp'), (q_v, mq')]) th3) [th_3,th_3']
val set_th = FWD (instantiate ([],[(p_v,p), (q_v,q)]) th2) [th_2, th_2']
@@ -123,15 +123,15 @@
val [addC, mulC, subC, negC] = map term_of [cadd, cmulC, cminus, cneg]
val [zero, one] = [@{term "0 :: int"}, @{term "1 :: int"}];
-val is_numeral = can dest_numeral;
+val is_numeral = can dest_numeral;
-fun numeral1 f n = HOLogic.mk_number iT (f (dest_numeral n));
+fun numeral1 f n = HOLogic.mk_number iT (f (dest_numeral n));
fun numeral2 f m n = HOLogic.mk_number iT (f (dest_numeral m) (dest_numeral n));
-val [minus1,plus1] =
+val [minus1,plus1] =
map (fn c => fn t => Thm.capply (Thm.capply c t) cone) [cminus,cadd];
-fun decomp_pinf x dvd inS [aseteq, asetneq, asetlt, asetle,
+fun decomp_pinf x dvd inS [aseteq, asetneq, asetlt, asetle,
asetgt, asetge,asetdvd,asetndvd,asetP,
infDdvd, infDndvd, asetconj,
asetdisj, infDconj, infDdisj] cp =
@@ -144,11 +144,11 @@
| Le t => ([], K (inst' [t] pile, FWD (inst' [t] asetle) [inS (plus1 t)], infDFalse))
| Gt t => ([], K (inst' [t] pigt, (inst' [t] asetgt), infDTrue))
| Ge t => ([], K (inst' [t] pige, (inst' [t] asetge), infDTrue))
-| Dvd (d,s) =>
+| Dvd (d,s) =>
([],let val dd = dvd d
- in K (inst' [d,s] pidvd, FWD (inst' [d,s] asetdvd) [dd],FWD (inst' [d,s] infDdvd) [dd]) end)
+ in K (inst' [d,s] pidvd, FWD (inst' [d,s] asetdvd) [dd],FWD (inst' [d,s] infDdvd) [dd]) end)
| NDvd(d,s) => ([],let val dd = dvd d
- in K (inst' [d,s] pindvd, FWD (inst' [d,s] asetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
+ in K (inst' [d,s] pindvd, FWD (inst' [d,s] asetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
| _ => ([], K (inst' [cp] piP, inst' [cp] asetP, inst' [cp] infDP));
fun decomp_minf x dvd inS [bseteq,bsetneq,bsetlt, bsetle, bsetgt,
@@ -165,110 +165,112 @@
| Gt t => ([], K (inst' [t] migt, FWD (inst' [t] bsetgt) [inS t], infDFalse))
| Ge t => ([], K (inst' [t] mige,FWD (inst' [t] bsetge) [inS (minus1 t)], infDFalse))
| Dvd (d,s) => ([],let val dd = dvd d
- in K (inst' [d,s] midvd, FWD (inst' [d,s] bsetdvd) [dd] , FWD (inst' [d,s] infDdvd) [dd]) end)
+ in K (inst' [d,s] midvd, FWD (inst' [d,s] bsetdvd) [dd] , FWD (inst' [d,s] infDdvd) [dd]) end)
| NDvd (d,s) => ([],let val dd = dvd d
- in K (inst' [d,s] mindvd, FWD (inst' [d,s] bsetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
+ in K (inst' [d,s] mindvd, FWD (inst' [d,s] bsetndvd) [dd], FWD (inst' [d,s] infDndvd) [dd]) end)
| _ => ([], K (inst' [cp] miP, inst' [cp] bsetP, inst' [cp] infDP))
(* Canonical linear form for terms, formulae etc.. *)
-fun provelin ctxt t = Goal.prove ctxt [] [] t
+fun provelin ctxt t = Goal.prove ctxt [] [] t
(fn _ => EVERY [simp_tac lin_ss 1, TRY (Lin_Arith.tac ctxt 1)]);
-fun linear_cmul 0 tm = zero
- | linear_cmul n tm = case tm of
+fun linear_cmul 0 tm = zero
+ | linear_cmul n tm = case tm of
Const (@{const_name HOL.plus}, _) $ a $ b => addC $ linear_cmul n a $ linear_cmul n b
| Const (@{const_name HOL.times}, _) $ c $ x => mulC $ numeral1 (fn m => n * m) c $ x
| Const (@{const_name HOL.minus}, _) $ a $ b => subC $ linear_cmul n a $ linear_cmul n b
| (m as Const (@{const_name HOL.uminus}, _)) $ a => m $ linear_cmul n a
| _ => numeral1 (fn m => n * m) tm;
-fun earlier [] x y = false
- | earlier (h::t) x y =
- if h aconv y then false else if h aconv x then true else earlier t x y;
+fun earlier [] x y = false
+ | earlier (h::t) x y =
+ if h aconv y then false else if h aconv x then true else earlier t x y;
-fun linear_add vars tm1 tm2 = case (tm1, tm2) of
+fun linear_add vars tm1 tm2 = case (tm1, tm2) of
(Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c1 $ x1) $ r1,
Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c2 $ x2) $ r2) =>
- if x1 = x2 then
+ if x1 = x2 then
let val c = numeral2 (curry op +) c1 c2
in if c = zero then linear_add vars r1 r2
else addC$(mulC$c$x1)$(linear_add vars r1 r2)
- end
+ end
else if earlier vars x1 x2 then addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2
else addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2
| (Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c1 $ x1) $ r1, _) =>
addC $ (mulC $ c1 $ x1) $ linear_add vars r1 tm2
- | (_, Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c2 $ x2) $ r2) =>
+ | (_, Const (@{const_name HOL.plus}, _) $ (Const (@{const_name HOL.times}, _) $ c2 $ x2) $ r2) =>
addC $ (mulC $ c2 $ x2) $ linear_add vars tm1 r2
| (_, _) => numeral2 (curry op +) tm1 tm2;
-
-fun linear_neg tm = linear_cmul ~1 tm;
-fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2);
+
+fun linear_neg tm = linear_cmul ~1 tm;
+fun linear_sub vars tm1 tm2 = linear_add vars tm1 (linear_neg tm2);
-fun lint vars tm = if is_numeral tm then tm else case tm of
+fun lint vars tm = if is_numeral tm then tm else case tm of
Const (@{const_name HOL.uminus}, _) $ t => linear_neg (lint vars t)
| Const (@{const_name HOL.plus}, _) $ s $ t => linear_add vars (lint vars s) (lint vars t)
| Const (@{const_name HOL.minus}, _) $ s $ t => linear_sub vars (lint vars s) (lint vars t)
| Const (@{const_name HOL.times}, _) $ s $ t =>
- let val s' = lint vars s
- val t' = lint vars t
- in if is_numeral s' then (linear_cmul (dest_numeral s') t')
- else if is_numeral t' then (linear_cmul (dest_numeral t') s')
+ let val s' = lint vars s
+ val t' = lint vars t
+ in if is_numeral s' then (linear_cmul (dest_numeral s') t')
+ else if is_numeral t' then (linear_cmul (dest_numeral t') s')
else raise COOPER ("Cooper Failed", TERM ("lint: not linear",[tm]))
- end
+ end
| _ => addC $ (mulC $ one $ tm) $ zero;
-fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name HOL.less}, T) $ s $ t)) =
+fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name HOL.less}, T) $ s $ t)) =
lin vs (Const (@{const_name HOL.less_eq}, T) $ t $ s)
- | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name HOL.less_eq}, T) $ s $ t)) =
+ | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name HOL.less_eq}, T) $ s $ t)) =
lin vs (Const (@{const_name HOL.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) =
+ | 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::_) ((b as Const("op =",_))$s$t) =
- (case lint vs (subC$t$s) of
- (t as a$(m$c$y)$r) =>
+ | lin (vs as x::_) ((b as Const("op =",_))$s$t) =
+ (case lint vs (subC$t$s) of
+ (t as a$(m$c$y)$r) =>
if x <> y then b$zero$t
else if dest_numeral c < 0 then b$(m$(numeral1 ~ c)$y)$r
else b$(m$c$y)$(linear_neg r)
| t => b$zero$t)
- | lin (vs as x::_) (b$s$t) =
- (case lint vs (subC$t$s) of
- (t as a$(m$c$y)$r) =>
+ | lin (vs as x::_) (b$s$t) =
+ (case lint vs (subC$t$s) of
+ (t as a$(m$c$y)$r) =>
if x <> y then b$zero$t
else if dest_numeral c < 0 then b$(m$(numeral1 ~ c)$y)$r
else b$(linear_neg r)$(m$c$y)
| t => b$zero$t)
| lin vs fm = fm;
-fun lint_conv ctxt vs ct =
+fun lint_conv ctxt vs ct =
let val t = term_of ct
in (provelin ctxt ((HOLogic.eq_const iT)$t$(lint vs t) |> HOLogic.mk_Trueprop))
RS eq_reflection
end;
-fun is_intrel (b$_$_) = domain_type (fastype_of b) = HOLogic.intT
- | is_intrel (@{term "Not"}$(b$_$_)) = domain_type (fastype_of b) = HOLogic.intT
+fun is_intrel_type T = T = @{typ "int => int => bool"};
+
+fun is_intrel (b$_$_) = is_intrel_type (fastype_of b)
+ | is_intrel (@{term "Not"}$(b$_$_)) = is_intrel_type (fastype_of b)
| is_intrel _ = false;
-
+
fun linearize_conv ctxt vs ct = case term_of ct of
- Const(@{const_name Ring_and_Field.dvd},_)$d$t =>
- let
+ Const(@{const_name Ring_and_Field.dvd},_)$d$t =>
+ let
val th = binop_conv (lint_conv ctxt vs) ct
val (d',t') = Thm.dest_binop (Thm.rhs_of th)
val (dt',tt') = (term_of d', term_of t')
- in if is_numeral dt' andalso is_numeral tt'
+ in if is_numeral dt' andalso is_numeral tt'
then Conv.fconv_rule (arg_conv (Simplifier.rewrite presburger_ss)) th
- else
- let
- val dth =
- ((if dest_numeral (term_of d') < 0 then
+ else
+ let
+ val dth =
+ ((if dest_numeral (term_of d') < 0 then
Conv.fconv_rule (arg_conv (arg1_conv (lint_conv ctxt vs)))
(Thm.transitive th (inst' [d',t'] dvd_uminus))
else th) handle TERM _ => th)
val d'' = Thm.rhs_of dth |> Thm.dest_arg1
in
- case tt' of
- Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$_)$_ =>
+ case tt' of
+ Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$_)$_ =>
let val x = dest_numeral c
in if x < 0 then Conv.fconv_rule (arg_conv (arg_conv (lint_conv ctxt vs)))
(Thm.transitive dth (inst' [d'',t'] dvd_uminus'))
@@ -277,29 +279,29 @@
end
end
| Const (@{const_name Not},_)$(Const(@{const_name Ring_and_Field.dvd},_)$_$_) => arg_conv (linearize_conv ctxt vs) ct
-| t => if is_intrel t
+| t => if is_intrel t
then (provelin ctxt ((HOLogic.eq_const bT)$t$(lin vs t) |> HOLogic.mk_Trueprop))
RS eq_reflection
else reflexive ct;
val dvdc = @{cterm "op dvd :: int => _"};
-fun unify ctxt q =
+fun unify ctxt q =
let
val (e,(cx,p)) = q |> Thm.dest_comb ||> Thm.dest_abs NONE
- val x = term_of cx
+ val x = term_of cx
val ins = insert (op = : int * int -> bool)
- fun h (acc,dacc) t =
+ fun h (acc,dacc) t =
case (term_of t) of
- Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ =>
+ Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ =>
if x aconv y andalso member (op =)
["op =", @{const_name HOL.less}, @{const_name HOL.less_eq}] s
then (ins (dest_numeral c) acc,dacc) else (acc,dacc)
- | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) =>
+ | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) =>
if x aconv y andalso member (op =)
- [@{const_name HOL.less}, @{const_name HOL.less_eq}] s
+ [@{const_name HOL.less}, @{const_name HOL.less_eq}] s
then (ins (dest_numeral c) acc, dacc) else (acc,dacc)
- | Const(@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$y)$_) =>
+ | Const(@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.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)
@@ -307,51 +309,53 @@
| _ => (acc, dacc)
val (cs,ds) = h ([],[]) p
val l = Integer.lcms (cs union ds)
- fun cv k ct =
- let val (tm as b$s$t) = term_of ct
+ fun cv k ct =
+ let val (tm as b$s$t) = term_of ct
in ((HOLogic.eq_const bT)$tm$(b$(linear_cmul k s)$(linear_cmul k t))
|> HOLogic.mk_Trueprop |> provelin ctxt) RS eq_reflection end
- fun nzprop x =
- let
- val th =
- Simplifier.rewrite lin_ss
- (Thm.capply @{cterm Trueprop} (Thm.capply @{cterm "Not"}
- (Thm.capply (Thm.capply @{cterm "op = :: int => _"} (Numeral.mk_cnumber @{ctyp "int"} x))
+ fun nzprop x =
+ let
+ val th =
+ Simplifier.rewrite lin_ss
+ (Thm.capply @{cterm Trueprop} (Thm.capply @{cterm "Not"}
+ (Thm.capply (Thm.capply @{cterm "op = :: int => _"} (Numeral.mk_cnumber @{ctyp "int"} x))
@{cterm "0::int"})))
in equal_elim (Thm.symmetric th) TrueI end;
- val notz = let val tab = fold Inttab.update
- (ds ~~ (map (fn x => nzprop (l div x)) ds)) Inttab.empty
- in
- (fn ct => (valOf (Inttab.lookup tab (ct |> term_of |> dest_numeral))
- handle Option => (writeln "noz: Theorems-Table contains no entry for";
- Display.print_cterm ct ; raise Option)))
- end
- fun unit_conv t =
+ val notz =
+ let val tab = fold Inttab.update
+ (ds ~~ (map (fn x => nzprop (l div x)) ds)) Inttab.empty
+ in
+ fn ct => valOf (Inttab.lookup tab (ct |> term_of |> dest_numeral))
+ handle Option =>
+ (writeln ("noz: Theorems-Table contains no entry for " ^
+ Syntax.string_of_term ctxt (Thm.term_of ct)); raise Option)
+ end
+ fun unit_conv t =
case (term_of t) of
Const("op &",_)$_$_ => binop_conv unit_conv t
| Const("op |",_)$_$_ => binop_conv unit_conv t
| Const (@{const_name Not},_)$_ => arg_conv unit_conv t
- | Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ =>
+ | Const(s,_)$(Const(@{const_name HOL.times},_)$c$y)$ _ =>
if x=y andalso member (op =)
["op =", @{const_name HOL.less}, @{const_name HOL.less_eq}] s
then cv (l div dest_numeral c) t else Thm.reflexive t
- | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) =>
+ | Const(s,_)$_$(Const(@{const_name HOL.times},_)$c$y) =>
if x=y andalso member (op =)
[@{const_name HOL.less}, @{const_name HOL.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 HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$y)$_)) =>
- if x=y then
- let
+ | Const(@{const_name Ring_and_Field.dvd},_)$d$(r as (Const(@{const_name HOL.plus},_)$(Const(@{const_name HOL.times},_)$c$y)$_)) =>
+ if x=y then
+ let
val k = l div dest_numeral c
val kt = HOLogic.mk_number iT k
- val th1 = inst' [Thm.dest_arg1 t, Thm.dest_arg t]
+ val th1 = inst' [Thm.dest_arg1 t, Thm.dest_arg t]
((Thm.dest_arg t |> funpow 2 Thm.dest_arg1 |> notz) RS zdvd_mono)
val (d',t') = (mulC$kt$d, mulC$kt$r)
val thc = (provelin ctxt ((HOLogic.eq_const iT)$d'$(lint [] d') |> HOLogic.mk_Trueprop))
RS eq_reflection
val tht = (provelin ctxt ((HOLogic.eq_const iT)$t'$(linear_cmul k r) |> HOLogic.mk_Trueprop))
RS eq_reflection
- in Thm.transitive th1 (Thm.combination (Drule.arg_cong_rule dvdc thc) tht) end
+ in Thm.transitive th1 (Thm.combination (Drule.arg_cong_rule dvdc thc) tht) end
else Thm.reflexive t
| _ => Thm.reflexive t
val uth = unit_conv p
@@ -359,7 +363,7 @@
val ltx = Thm.capply (Thm.capply cmulC clt) cx
val th = Drule.arg_cong_rule e (Thm.abstract_rule (fst (dest_Free x )) cx uth)
val th' = inst' [Thm.cabs ltx (Thm.rhs_of uth), clt] unity_coeff_ex
- val thf = transitive th
+ val thf = transitive th
(transitive (symmetric (beta_conversion true (cprop_of th' |> Thm.dest_arg1))) th')
val (lth,rth) = Thm.dest_comb (cprop_of thf) |>> Thm.dest_arg |>> Thm.beta_conversion true
||> beta_conversion true |>> Thm.symmetric
@@ -372,25 +376,25 @@
fun mkISet cts = fold_rev (Thm.capply insert_tm #> Thm.capply) cts emptyIS;
val cTrp = @{cterm "Trueprop"};
val eqelem_imp_imp = (thm"eqelem_imp_iff") RS iffD1;
-val [A_tm,B_tm] = map (fn th => cprop_of th |> funpow 2 Thm.dest_arg |> Thm.dest_abs NONE |> snd |> Thm.dest_arg1 |> Thm.dest_arg
+val [A_tm,B_tm] = map (fn th => cprop_of th |> funpow 2 Thm.dest_arg |> Thm.dest_abs NONE |> snd |> Thm.dest_arg1 |> Thm.dest_arg
|> Thm.dest_abs NONE |> snd |> Thm.dest_fun |> Thm.dest_arg)
[asetP,bsetP];
val D_tm = @{cpat "?D::int"};
-fun cooperex_conv ctxt vs q =
-let
+fun cooperex_conv ctxt vs q =
+let
val uth = unify ctxt q
val (x,p) = Thm.dest_abs NONE (Thm.dest_arg (Thm.rhs_of uth))
val ins = insert (op aconvc)
- fun h t (bacc,aacc,dacc) =
+ fun h t (bacc,aacc,dacc) =
case (whatis x t) of
And (p,q) => h q (h p (bacc,aacc,dacc))
| Or (p,q) => h q (h p (bacc,aacc,dacc))
- | Eq t => (ins (minus1 t) bacc,
+ | Eq t => (ins (minus1 t) bacc,
ins (plus1 t) aacc,dacc)
- | NEq t => (ins t bacc,
+ | NEq t => (ins t bacc,
ins t aacc, dacc)
| Lt t => (bacc, ins t aacc, dacc)
| Le t => (bacc, ins (plus1 t) aacc,dacc)
@@ -403,89 +407,92 @@
val d = Integer.lcms ds
val cd = Numeral.mk_cnumber @{ctyp "int"} d
val dt = term_of cd
- fun divprop x =
- let
- val th =
- Simplifier.rewrite lin_ss
- (Thm.capply @{cterm Trueprop}
+ fun divprop x =
+ let
+ val th =
+ Simplifier.rewrite lin_ss
+ (Thm.capply @{cterm Trueprop}
(Thm.capply (Thm.capply dvdc (Numeral.mk_cnumber @{ctyp "int"} x)) cd))
in equal_elim (Thm.symmetric th) TrueI end;
- val dvd = let val tab = fold Inttab.update
- (ds ~~ (map divprop ds)) Inttab.empty in
- (fn ct => (valOf (Inttab.lookup tab (term_of ct |> dest_numeral))
- handle Option => (writeln "dvd: Theorems-Table contains no entry for";
- Display.print_cterm ct ; raise Option)))
- end
- val dp =
- let val th = Simplifier.rewrite lin_ss
- (Thm.capply @{cterm Trueprop}
+ val dvd =
+ let val tab = fold Inttab.update (ds ~~ (map divprop ds)) Inttab.empty in
+ fn ct => valOf (Inttab.lookup tab (term_of ct |> dest_numeral))
+ handle Option =>
+ (writeln ("dvd: Theorems-Table contains no entry for" ^
+ Syntax.string_of_term ctxt (Thm.term_of ct)); raise Option)
+ end
+ val dp =
+ let val th = Simplifier.rewrite lin_ss
+ (Thm.capply @{cterm Trueprop}
(Thm.capply (Thm.capply @{cterm "op < :: int => _"} @{cterm "0::int"}) cd))
in equal_elim (Thm.symmetric th) TrueI end;
(* A and B set *)
- local
+ local
val insI1 = instantiate' [SOME @{ctyp "int"}] [] @{thm "insertI1"}
val insI2 = instantiate' [SOME @{ctyp "int"}] [] @{thm "insertI2"}
in
- fun provein x S =
+ fun provein x S =
case term_of S of
Const(@{const_name Orderings.bot}, _) => error "Unexpected error in Cooper, please email Amine Chaieb"
- | Const(@{const_name insert}, _) $ y $ _ =>
+ | Const(@{const_name insert}, _) $ y $ _ =>
let val (cy,S') = Thm.dest_binop S
in if term_of x aconv y then instantiate' [] [SOME x, SOME S'] insI1
- else implies_elim (instantiate' [] [SOME x, SOME S', SOME cy] insI2)
+ else implies_elim (instantiate' [] [SOME x, SOME S', SOME cy] insI2)
(provein x S')
end
end
-
+
val al = map (lint vs o term_of) a0
val bl = map (lint vs o term_of) b0
- val (sl,s0,f,abths,cpth) =
- if length (distinct (op aconv) bl) <= length (distinct (op aconv) al)
- then
+ val (sl,s0,f,abths,cpth) =
+ if length (distinct (op aconv) bl) <= length (distinct (op aconv) al)
+ then
(bl,b0,decomp_minf,
- fn B => (map (fn th => implies_elim (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)]) th) dp)
+ fn B => (map (fn th => implies_elim (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)]) th) dp)
[bseteq,bsetneq,bsetlt, bsetle, bsetgt,bsetge])@
- (map (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)]))
+ (map (Thm.instantiate ([],[(B_tm,B), (D_tm,cd)]))
[bsetdvd,bsetndvd,bsetP,infDdvd, infDndvd,bsetconj,
bsetdisj,infDconj, infDdisj]),
- cpmi)
- else (al,a0,decomp_pinf,fn A =>
+ cpmi)
+ else (al,a0,decomp_pinf,fn A =>
(map (fn th => implies_elim (Thm.instantiate ([],[(A_tm,A), (D_tm,cd)]) th) dp)
[aseteq,asetneq,asetlt, asetle, asetgt,asetge])@
- (map (Thm.instantiate ([],[(A_tm,A), (D_tm,cd)]))
+ (map (Thm.instantiate ([],[(A_tm,A), (D_tm,cd)]))
[asetdvd,asetndvd, asetP, infDdvd, infDndvd,asetconj,
asetdisj,infDconj, infDdisj]),cppi)
- val cpth =
+ val cpth =
let
- val sths = map (fn (tl,t0) =>
- if tl = term_of t0
+ val sths = map (fn (tl,t0) =>
+ if tl = term_of t0
then instantiate' [SOME @{ctyp "int"}] [SOME t0] refl
- else provelin ctxt ((HOLogic.eq_const iT)$tl$(term_of t0)
- |> HOLogic.mk_Trueprop))
+ else provelin ctxt ((HOLogic.eq_const iT)$tl$(term_of t0)
+ |> HOLogic.mk_Trueprop))
(sl ~~ s0)
val csl = distinct (op aconvc) (map (cprop_of #> Thm.dest_arg #> Thm.dest_arg1) sths)
val S = mkISet csl
- val inStab = fold (fn ct => fn tab => Termtab.update (term_of ct, provein ct S) tab)
+ val inStab = fold (fn ct => fn tab => Termtab.update (term_of ct, provein ct S) tab)
csl Termtab.empty
val eqelem_th = instantiate' [SOME @{ctyp "int"}] [NONE,NONE, SOME S] eqelem_imp_imp
- val inS =
- let
- fun transmem th0 th1 =
- Thm.equal_elim
- (Drule.arg_cong_rule cTrp (Drule.fun_cong_rule (Drule.arg_cong_rule
+ val inS =
+ let
+ fun transmem th0 th1 =
+ Thm.equal_elim
+ (Drule.arg_cong_rule cTrp (Drule.fun_cong_rule (Drule.arg_cong_rule
((Thm.dest_fun o Thm.dest_fun o Thm.dest_arg o cprop_of) th1) th0) S)) th1
val tab = fold Termtab.update
- (map (fn eq =>
- let val (s,t) = cprop_of eq |> Thm.dest_arg |> Thm.dest_binop
- val th = if term_of s = term_of t
+ (map (fn eq =>
+ let val (s,t) = cprop_of eq |> Thm.dest_arg |> Thm.dest_binop
+ val th = if term_of s = term_of t
then valOf(Termtab.lookup inStab (term_of s))
- else FWD (instantiate' [] [SOME s, SOME t] eqelem_th)
+ else FWD (instantiate' [] [SOME s, SOME t] eqelem_th)
[eq, valOf(Termtab.lookup inStab (term_of s))]
in (term_of t, th) end)
sths) Termtab.empty
- in fn ct =>
- (valOf (Termtab.lookup tab (term_of ct))
- handle Option => (writeln "inS: No theorem for " ; Display.print_cterm ct ; raise Option))
+ in
+ fn ct => valOf (Termtab.lookup tab (term_of ct))
+ handle Option =>
+ (writeln ("inS: No theorem for " ^ Syntax.string_of_term ctxt (Thm.term_of ct));
+ raise Option)
end
val (inf, nb, pd) = divide_and_conquer (f x dvd inS (abths S)) p
in [dp, inf, nb, pd] MRS cpth
@@ -494,9 +501,9 @@
in Thm.transitive cpth' ((simp_thms_conv ctxt then_conv eval_conv) (Thm.rhs_of cpth'))
end;
-fun literals_conv bops uops env cv =
+fun literals_conv bops uops env cv =
let fun h t =
- case (term_of t) of
+ case (term_of t) of
b$_$_ => if member (op aconv) bops b then binop_conv h t else cv env t
| u$_ => if member (op aconv) uops u then arg_conv h t else cv env t
| _ => cv env t
@@ -506,21 +513,21 @@
nnf_conv then_conv literals_conv [HOLogic.conj, HOLogic.disj] [] env (linearize_conv ctxt);
local
- val pcv = Simplifier.rewrite
- (HOL_basic_ss addsimps (simp_thms @ (List.take(ex_simps,4))
+ val pcv = Simplifier.rewrite
+ (HOL_basic_ss addsimps (simp_thms @ (List.take(ex_simps,4))
@ [not_all,all_not_ex, ex_disj_distrib]))
val postcv = Simplifier.rewrite presburger_ss
- fun conv ctxt p =
+ fun conv ctxt p =
let val _ = ()
in
- Qelim.gen_qelim_conv pcv postcv pcv (cons o term_of)
- (OldTerm.term_frees (term_of p)) (linearize_conv ctxt) (integer_nnf_conv ctxt)
- (cooperex_conv ctxt) p
+ Qelim.gen_qelim_conv pcv postcv pcv (cons o term_of)
+ (OldTerm.term_frees (term_of p)) (linearize_conv ctxt) (integer_nnf_conv ctxt)
+ (cooperex_conv ctxt) p
end
handle CTERM s => raise COOPER ("Cooper Failed", CTERM s)
- | THM s => raise COOPER ("Cooper Failed", THM s)
- | TYPE s => raise COOPER ("Cooper Failed", TYPE s)
-in val cooper_conv = conv
+ | THM s => raise COOPER ("Cooper Failed", THM s)
+ | TYPE s => raise COOPER ("Cooper Failed", TYPE s)
+in val cooper_conv = conv
end;
end;
@@ -542,12 +549,12 @@
| Const(@{const_name HOL.uminus},_)$t' => Neg (i_of_term vs t')
| Const(@{const_name HOL.plus},_)$t1$t2 => Add (i_of_term vs t1,i_of_term vs t2)
| Const(@{const_name HOL.minus},_)$t1$t2 => Sub (i_of_term vs t1,i_of_term vs t2)
- | Const(@{const_name HOL.times},_)$t1$t2 =>
+ | Const(@{const_name HOL.times},_)$t1$t2 =>
(Mul (HOLogic.dest_number t1 |> snd, i_of_term vs t2)
- handle TERM _ =>
+ handle TERM _ =>
(Mul (HOLogic.dest_number t2 |> snd, i_of_term vs t1)
handle TERM _ => cooper "Reification: Unsupported kind of multiplication"))
- | _ => (C (HOLogic.dest_number t |> snd)
+ | _ => (C (HOLogic.dest_number t |> snd)
handle TERM _ => cooper "Reification: unknown term");
fun qf_of_term ps vs t = case t
@@ -555,7 +562,7 @@
| Const("False",_) => F
| Const(@{const_name HOL.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
| Const(@{const_name HOL.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 Ring_and_Field.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)
@@ -563,42 +570,42 @@
| Const("op |",_)$t1$t2 => Or(qf_of_term ps vs t1,qf_of_term ps vs t2)
| Const("op -->",_)$t1$t2 => Imp(qf_of_term ps vs t1,qf_of_term ps vs t2)
| Const (@{const_name Not},_)$t' => Not(qf_of_term ps vs t')
- | Const("Ex",_)$Abs(xn,xT,p) =>
+ | Const("Ex",_)$Abs(xn,xT,p) =>
let val (xn',p') = variant_abs (xn,xT,p)
val vs' = (Free (xn',xT), 0) :: (map (fn(v,n) => (v,1+ n)) vs)
in E (qf_of_term ps vs' p')
end
- | Const("All",_)$Abs(xn,xT,p) =>
+ | Const("All",_)$Abs(xn,xT,p) =>
let val (xn',p') = variant_abs (xn,xT,p)
val vs' = (Free (xn',xT), 0) :: (map (fn(v,n) => (v,1+ n)) vs)
in A (qf_of_term ps vs' p')
end
- | _ =>(case AList.lookup (op aconv) ps t of
+ | _ =>(case AList.lookup (op aconv) ps t of
NONE => cooper "Reification: unknown term!"
| SOME n => Closed n);
local
val ops = [@{term "op &"}, @{term "op |"}, @{term "op -->"}, @{term "op = :: bool => _"},
- @{term "op = :: int => _"}, @{term "op < :: int => _"},
- @{term "op <= :: int => _"}, @{term "Not"}, @{term "All:: (int => _) => _"},
+ @{term "op = :: int => _"}, @{term "op < :: int => _"},
+ @{term "op <= :: int => _"}, @{term "Not"}, @{term "All:: (int => _) => _"},
@{term "Ex:: (int => _) => _"}, @{term "True"}, @{term "False"}]
fun ty t = Bool.not (fastype_of t = HOLogic.boolT)
in
fun term_bools acc t =
-case t of
- (l as f $ a) $ b => if ty t orelse f mem ops then term_bools (term_bools acc l)b
+case t of
+ (l as f $ a) $ b => if ty t orelse f mem ops then term_bools (term_bools acc l)b
else insert (op aconv) t acc
- | f $ a => if ty t orelse f mem ops then term_bools (term_bools acc f) a
+ | f $ a => if ty t orelse f mem ops then term_bools (term_bools acc f) a
else insert (op aconv) t acc
| Abs p => term_bools acc (snd (variant_abs p))
| _ => if ty t orelse t mem ops then acc else insert (op aconv) t acc
end;
-
+
fun myassoc2 l v =
case l of
- [] => NONE
+ [] => NONE
| (x,v')::xs => if v = v' then SOME x
- else myassoc2 xs v;
+ else myassoc2 xs v;
fun term_of_i vs t = case t
of C i => HOLogic.mk_number HOLogic.intT i
@@ -610,9 +617,9 @@
HOLogic.mk_number HOLogic.intT i $ term_of_i vs t2
| Cn (n, i, t') => term_of_i vs (Add (Mul (i, Bound n), t'));
-fun term_of_qf ps vs t =
- case t of
- T => HOLogic.true_const
+fun term_of_qf ps vs t =
+ case t of
+ T => HOLogic.true_const
| F => HOLogic.false_const
| Lt t' => @{term "op < :: int => _ "}$ term_of_i vs t'$ @{term "0::int"}
| Le t' => @{term "op <= :: int => _ "}$ term_of_i vs t' $ @{term "0::int"}
@@ -620,7 +627,7 @@
| Ge t' => @{term "op <= :: int => _ "}$ @{term "0::int"}$ term_of_i vs t'
| Eq t' => @{term "op = :: int => _ "}$ term_of_i vs t'$ @{term "0::int"}
| NEq t' => term_of_qf ps vs (Not (Eq t'))
- | Dvd(i,t') => @{term "op dvd :: int => _ "} $
+ | Dvd(i,t') => @{term "op dvd :: int => _ "} $
HOLogic.mk_number HOLogic.intT i $ term_of_i vs t'
| NDvd(i,t')=> term_of_qf ps vs (Not(Dvd(i,t')))
| Not t' => HOLogic.Not$(term_of_qf ps vs t')
--- a/src/HOL/Tools/Qelim/presburger.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Qelim/presburger.ML Thu Oct 01 07:40:25 2009 +0200
@@ -52,18 +52,18 @@
local
fun isnum t = case t of
- Const(@{const_name "HOL.zero"},_) => true
- | Const(@{const_name "HOL.one"},_) => true
+ Const(@{const_name HOL.zero},_) => true
+ | Const(@{const_name HOL.one},_) => true
| @{term "Suc"}$s => isnum s
| @{term "nat"}$s => isnum s
| @{term "int"}$s => isnum s
- | Const(@{const_name "HOL.uminus"},_)$s => isnum s
- | Const(@{const_name "HOL.plus"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "HOL.times"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "HOL.minus"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Power.power"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Divides.mod"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Divides.div"},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.uminus},_)$s => isnum s
+ | Const(@{const_name HOL.plus},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.times},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.minus},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Power.power},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Divides.mod},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Divides.div},_)$l$r => isnum l andalso isnum r
| _ => can HOLogic.dest_number t orelse can HOLogic.dest_nat t
fun ty cts t =
--- a/src/HOL/Tools/Qelim/qelim.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/Qelim/qelim.ML Thu Oct 01 07:40:25 2009 +0200
@@ -29,8 +29,8 @@
@{const_name "op -->"}, @{const_name "op ="}] s
then binop_conv (conv env) p
else atcv env p
- | Const(@{const_name "Not"},_)$_ => arg_conv (conv env) p
- | Const(@{const_name "Ex"},_)$Abs(s,_,_) =>
+ | Const(@{const_name Not},_)$_ => arg_conv (conv env) p
+ | Const(@{const_name Ex},_)$Abs(s,_,_) =>
let
val (e,p0) = Thm.dest_comb p
val (x,p') = Thm.dest_abs (SOME s) p0
@@ -41,8 +41,8 @@
val (l,r) = Thm.dest_equals (cprop_of th')
in if Thm.is_reflexive th' then Thm.transitive th (qcv env (Thm.rhs_of th))
else Thm.transitive (Thm.transitive th th') (conv env r) end
- | Const(@{const_name "Ex"},_)$ _ => (Thm.eta_long_conversion then_conv conv env) p
- | Const(@{const_name "All"},_)$_ =>
+ | Const(@{const_name Ex},_)$ _ => (Thm.eta_long_conversion then_conv conv env) p
+ | Const(@{const_name All},_)$_ =>
let
val p = Thm.dest_arg p
val ([(_,T)],[]) = Thm.match (@{cpat "All"}, Thm.dest_fun p)
--- a/src/HOL/Tools/TFL/casesplit.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/TFL/casesplit.ML Thu Oct 01 07:40:25 2009 +0200
@@ -96,7 +96,7 @@
| TVar((s,i),_) => error ("Free variable: " ^ s)
val dt = Datatype.the_info thy ty_str
in
- cases_thm_of_induct_thm (#induction dt)
+ cases_thm_of_induct_thm (#induct dt)
end;
(*
--- a/src/HOL/Tools/TFL/rules.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/TFL/rules.ML Thu Oct 01 07:40:25 2009 +0200
@@ -47,10 +47,10 @@
val rbeta: thm -> thm
(* For debugging my isabelle solver in the conditional rewriter *)
- val term_ref: term list ref
- val thm_ref: thm list ref
- val ss_ref: simpset list ref
- val tracing: bool ref
+ val term_ref: term list Unsynchronized.ref
+ val thm_ref: thm list Unsynchronized.ref
+ val ss_ref: simpset list Unsynchronized.ref
+ val tracing: bool Unsynchronized.ref
val CONTEXT_REWRITE_RULE: term * term list * thm * thm list
-> thm -> thm * term list
val RIGHT_ASSOC: thm -> thm
@@ -456,7 +456,7 @@
fun is_cong thm =
case (Thm.prop_of thm)
of (Const("==>",_)$(Const("Trueprop",_)$ _) $
- (Const("==",_) $ (Const (@{const_name "Wellfounded.cut"},_) $ f $ R $ a $ x) $ _)) => false
+ (Const("==",_) $ (Const (@{const_name Recdef.cut},_) $ f $ R $ a $ x) $ _)) => false
| _ => true;
@@ -544,18 +544,18 @@
(*---------------------------------------------------------------------------
* Trace information for the rewriter
*---------------------------------------------------------------------------*)
-val term_ref = ref[] : term list ref
-val ss_ref = ref [] : simpset list ref;
-val thm_ref = ref [] : thm list ref;
-val tracing = ref false;
+val term_ref = Unsynchronized.ref [] : term list Unsynchronized.ref
+val ss_ref = Unsynchronized.ref [] : simpset list Unsynchronized.ref;
+val thm_ref = Unsynchronized.ref [] : thm list Unsynchronized.ref;
+val tracing = Unsynchronized.ref false;
fun say s = if !tracing then writeln s else ();
fun print_thms s L =
say (cat_lines (s :: map Display.string_of_thm_without_context L));
-fun print_cterms s L =
- say (cat_lines (s :: map Display.string_of_cterm L));
+fun print_cterm s ct =
+ say (cat_lines [s, Syntax.string_of_term_global (Thm.theory_of_cterm ct) (Thm.term_of ct)]);
(*---------------------------------------------------------------------------
@@ -659,14 +659,14 @@
end;
fun restricted t = isSome (S.find_term
- (fn (Const(@{const_name "Wellfounded.cut"},_)) =>true | _ => false)
+ (fn (Const(@{const_name Recdef.cut},_)) =>true | _ => false)
t)
fun CONTEXT_REWRITE_RULE (func, G, cut_lemma, congs) th =
let val globals = func::G
val ss0 = Simplifier.theory_context (Thm.theory_of_thm th) empty_ss
val pbeta_reduce = simpl_conv ss0 [split_conv RS eq_reflection];
- val tc_list = ref[]: term list ref
+ val tc_list = Unsynchronized.ref []: term list Unsynchronized.ref
val dummy = term_ref := []
val dummy = thm_ref := []
val dummy = ss_ref := []
@@ -683,7 +683,7 @@
(* Unquantified eliminate *)
fun uq_eliminate (thm,imp,thy) =
let val tych = cterm_of thy
- val dummy = print_cterms "To eliminate:" [tych imp]
+ val dummy = print_cterm "To eliminate:" (tych imp)
val ants = map tych (Logic.strip_imp_prems imp)
val eq = Logic.strip_imp_concl imp
val lhs = tych(get_lhs eq)
@@ -781,9 +781,8 @@
val antl = case rcontext of [] => []
| _ => [S.list_mk_conj(map cncl rcontext)]
val TC = genl(S.list_mk_imp(antl, A))
- val dummy = print_cterms "func:" [cterm_of thy func]
- val dummy = print_cterms "TC:"
- [cterm_of thy (HOLogic.mk_Trueprop TC)]
+ val dummy = print_cterm "func:" (cterm_of thy func)
+ val dummy = print_cterm "TC:" (cterm_of thy (HOLogic.mk_Trueprop TC))
val dummy = tc_list := (TC :: !tc_list)
val nestedp = isSome (S.find_term is_func TC)
val dummy = if nestedp then say "nested" else say "not_nested"
--- a/src/HOL/Tools/TFL/tfl.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/TFL/tfl.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,9 +6,9 @@
signature PRIM =
sig
- val trace: bool ref
+ val trace: bool Unsynchronized.ref
val trace_thms: string -> thm list -> unit
- val trace_cterms: string -> cterm list -> unit
+ val trace_cterm: string -> cterm -> unit
type pattern
val mk_functional: theory -> term list -> {functional: term, pats: pattern list}
val wfrec_definition0: theory -> string -> term -> term -> theory * thm
@@ -40,7 +40,7 @@
structure Prim: PRIM =
struct
-val trace = ref false;
+val trace = Unsynchronized.ref false;
structure R = Rules;
structure S = USyntax;
@@ -75,8 +75,8 @@
* function contains embedded refs!
*---------------------------------------------------------------------------*)
fun gvvariant names =
- let val slist = ref names
- val vname = ref "u"
+ let val slist = Unsynchronized.ref names
+ val vname = Unsynchronized.ref "u"
fun new() =
if !vname mem_string (!slist)
then (vname := Symbol.bump_string (!vname); new())
@@ -296,7 +296,7 @@
raise TFL_ERR "no_repeat_vars"
(quote (#1 (dest_Free v)) ^
" occurs repeatedly in the pattern " ^
- quote (Display.string_of_cterm (Thry.typecheck thy pat)))
+ quote (Syntax.string_of_term_global thy pat))
else check rst
in check (FV_multiset pat)
end;
@@ -912,9 +912,10 @@
if !trace then writeln (cat_lines (s :: map Display.string_of_thm_without_context L))
else ();
-fun trace_cterms s L =
- if !trace then writeln (cat_lines (s :: map Display.string_of_cterm L))
- else ();;
+fun trace_cterm s ct =
+ if !trace then
+ writeln (cat_lines [s, Syntax.string_of_term_global (Thm.theory_of_cterm ct) (Thm.term_of ct)])
+ else ();
fun postprocess strict {wf_tac, terminator, simplifier} theory {rules,induction,TCs} =
@@ -942,7 +943,7 @@
fun simplify_tc tc (r,ind) =
let val tc1 = tych tc
- val _ = trace_cterms "TC before simplification: " [tc1]
+ val _ = trace_cterm "TC before simplification: " tc1
val tc_eq = simplifier tc1
val _ = trace_thms "result: " [tc_eq]
in
--- a/src/HOL/Tools/TFL/usyntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/TFL/usyntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -398,7 +398,7 @@
end handle Bind => raise USYN_ERR "dest_relation" "unexpected term structure"
else raise USYN_ERR "dest_relation" "not a boolean term";
-fun is_WFR (Const(@{const_name "Wellfounded.wf"},_)$_) = true
+fun is_WFR (Const(@{const_name Wellfounded.wf},_)$_) = true
| is_WFR _ = false;
fun ARB ty = mk_select{Bvar=Free("v",ty),
--- a/src/HOL/Tools/cnf_funcs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/cnf_funcs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -399,12 +399,10 @@
fun make_cnfx_thm thy t =
let
- val var_id = ref 0 (* properly initialized below *)
- (* unit -> Term.term *)
+ val var_id = Unsynchronized.ref 0 (* properly initialized below *)
fun new_free () =
- Free ("cnfx_" ^ string_of_int (inc var_id), HOLogic.boolT)
- (* Term.term -> Thm.thm *)
- fun make_cnfx_thm_from_nnf (Const ("op &", _) $ x $ y) =
+ Free ("cnfx_" ^ string_of_int (Unsynchronized.inc var_id), HOLogic.boolT)
+ fun make_cnfx_thm_from_nnf (Const ("op &", _) $ x $ y) : thm =
let
val thm1 = make_cnfx_thm_from_nnf x
val thm2 = make_cnfx_thm_from_nnf y
--- a/src/HOL/Tools/float_syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/float_syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -27,10 +27,10 @@
fun mk_frac str =
let
val {mant=i, exp = n} = Syntax.read_float str;
- val exp = Syntax.const @{const_name "Power.power"};
+ val exp = Syntax.const @{const_name 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
+ in (Syntax.const @{const_name divide}) $ (mk_number i) $ exp10 end
in
fun float_tr (*"_Float"*) [t as Const (str, _)] = mk_frac str
--- a/src/HOL/Tools/hologic.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/hologic.ML Thu Oct 01 07:40:25 2009 +0200
@@ -586,7 +586,7 @@
(* string *)
-val stringT = Type ("String.string", []);
+val stringT = listT charT;
val mk_string = mk_list charT o map (mk_char o ord) o explode;
val dest_string = implode o map (chr o dest_char) o dest_list;
@@ -613,17 +613,17 @@
| mk_typerep (T as TFree _) = Const ("Typerep.typerep_class.typerep",
Term.itselfT T --> typerepT) $ Logic.mk_type T;
-val termT = Type ("Code_Eval.term", []);
+val termT = Type ("Code_Evaluation.term", []);
-fun term_of_const T = Const ("Code_Eval.term_of_class.term_of", T --> termT);
+fun term_of_const T = Const ("Code_Evaluation.term_of_class.term_of", T --> termT);
fun mk_term_of T t = term_of_const T $ t;
fun reflect_term (Const (c, T)) =
- Const ("Code_Eval.Const", literalT --> typerepT --> termT)
+ Const ("Code_Evaluation.Const", literalT --> typerepT --> termT)
$ mk_literal c $ mk_typerep T
| reflect_term (t1 $ t2) =
- Const ("Code_Eval.App", termT --> termT --> termT)
+ Const ("Code_Evaluation.App", termT --> termT --> termT)
$ reflect_term t1 $ reflect_term t2
| reflect_term (Abs (v, _, t)) = Abs (v, termT, reflect_term t)
| reflect_term t = t;
@@ -631,7 +631,7 @@
fun mk_valtermify_app c vs T =
let
fun termifyT T = mk_prodT (T, unitT --> termT);
- fun valapp T T' = Const ("Code_Eval.valapp",
+ fun valapp T T' = Const ("Code_Evaluation.valapp",
termifyT (T --> T') --> termifyT T --> termifyT T');
fun mk_fTs [] _ = []
| mk_fTs (_ :: Ts) T = (Ts ---> T) :: mk_fTs Ts T;
--- a/src/HOL/Tools/inductive.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/inductive.ML Thu Oct 01 07:40:25 2009 +0200
@@ -86,13 +86,13 @@
(** theory context references **)
val inductive_forall_name = "HOL.induct_forall";
-val inductive_forall_def = thm "induct_forall_def";
+val inductive_forall_def = @{thm induct_forall_def};
val inductive_conj_name = "HOL.induct_conj";
-val inductive_conj_def = thm "induct_conj_def";
-val inductive_conj = thms "induct_conj";
-val inductive_atomize = thms "induct_atomize";
-val inductive_rulify = thms "induct_rulify";
-val inductive_rulify_fallback = thms "induct_rulify_fallback";
+val inductive_conj_def = @{thm induct_conj_def};
+val inductive_conj = @{thms induct_conj};
+val inductive_atomize = @{thms induct_atomize};
+val inductive_rulify = @{thms induct_rulify};
+val inductive_rulify_fallback = @{thms induct_rulify_fallback};
val notTrueE = TrueI RSN (2, notE);
val notFalseI = Seq.hd (atac 1 notI);
@@ -103,6 +103,10 @@
"(P & True) = P" "(True & P) = P"
by (fact simp_thms)+};
+val simp_thms'' = map mk_meta_eq [@{thm inf_fun_eq}, @{thm inf_bool_eq}] @ simp_thms';
+
+val simp_thms''' = map mk_meta_eq
+ [@{thm le_fun_def}, @{thm le_bool_def}, @{thm sup_fun_eq}, @{thm sup_bool_eq}];
(** context data **)
@@ -170,15 +174,15 @@
(case concl of
(_ $ (_ $ (Const ("Not", _) $ _) $ _)) => []
| _ => [thm' RS (thm' RS eq_to_mono2)]);
- fun dest_less_concl thm = dest_less_concl (thm RS le_funD)
- handle THM _ => thm RS le_boolD
+ fun dest_less_concl thm = dest_less_concl (thm RS @{thm le_funD})
+ handle THM _ => thm RS @{thm le_boolD}
in
case concl of
Const ("==", _) $ _ $ _ => eq2mono (thm RS meta_eq_to_obj_eq)
| _ $ (Const ("op =", _) $ _ $ _) => eq2mono thm
- | _ $ (Const ("HOL.ord_class.less_eq", _) $ _ $ _) =>
+ | _ $ (Const (@{const_name HOL.less_eq}, _) $ _ $ _) =>
[dest_less_concl (Seq.hd (REPEAT (FIRSTGOAL
- (resolve_tac [le_funI, le_boolI'])) thm))]
+ (resolve_tac [@{thm le_funI}, @{thm le_boolI'}])) thm))]
| _ => [thm]
end handle THM _ =>
error ("Bad monotonicity theorem:\n" ^ Display.string_of_thm_without_context thm);
@@ -322,11 +326,11 @@
(HOLogic.mk_Trueprop
(Const (@{const_name Orderings.mono}, (predT --> predT) --> HOLogic.boolT) $ fp_fun))
(fn _ => EVERY [rtac @{thm monoI} 1,
- REPEAT (resolve_tac [le_funI, le_boolI'] 1),
+ REPEAT (resolve_tac [@{thm le_funI}, @{thm le_boolI'}] 1),
REPEAT (FIRST
[atac 1,
resolve_tac (List.concat (map mk_mono monos) @ get_monos ctxt) 1,
- etac le_funE 1, dtac le_boolD 1])]));
+ etac @{thm le_funE} 1, dtac @{thm le_boolD} 1])]));
(* prove introduction rules *)
@@ -337,7 +341,7 @@
val unfold = funpow k (fn th => th RS fun_cong)
(mono RS (fp_def RS
- (if coind then def_gfp_unfold else def_lfp_unfold)));
+ (if coind then @{thm def_gfp_unfold} else @{thm def_lfp_unfold})));
fun select_disj 1 1 = []
| select_disj _ 1 = [rtac disjI1]
@@ -552,14 +556,14 @@
val ind_concl = HOLogic.mk_Trueprop
(HOLogic.mk_binrel "HOL.ord_class.less_eq" (rec_const, ind_pred));
- val raw_fp_induct = (mono RS (fp_def RS def_lfp_induct));
+ val raw_fp_induct = (mono RS (fp_def RS @{thm def_lfp_induct}));
val induct = SkipProof.prove ctxt'' [] ind_prems ind_concl
(fn {prems, ...} => EVERY
[rewrite_goals_tac [inductive_conj_def],
DETERM (rtac raw_fp_induct 1),
- REPEAT (resolve_tac [le_funI, le_boolI] 1),
- rewrite_goals_tac (inf_fun_eq :: inf_bool_eq :: simp_thms'),
+ REPEAT (resolve_tac [@{thm le_funI}, @{thm le_boolI}] 1),
+ rewrite_goals_tac simp_thms'',
(*This disjE separates out the introduction rules*)
REPEAT (FIRSTGOAL (eresolve_tac [disjE, exE, FalseE])),
(*Now break down the individual cases. No disjE here in case
@@ -568,7 +572,7 @@
REPEAT (FIRSTGOAL
(resolve_tac [conjI, impI] ORELSE' (etac notE THEN' atac))),
EVERY (map (fn prem => DEPTH_SOLVE_1 (ares_tac [rewrite_rule
- (inductive_conj_def :: rec_preds_defs @ simp_thms') prem,
+ (inductive_conj_def :: rec_preds_defs @ simp_thms'') prem,
conjI, refl] 1)) prems)]);
val lemma = SkipProof.prove ctxt'' [] []
@@ -576,7 +580,7 @@
[rewrite_goals_tac rec_preds_defs,
REPEAT (EVERY
[REPEAT (resolve_tac [conjI, impI] 1),
- REPEAT (eresolve_tac [le_funE, le_boolE] 1),
+ REPEAT (eresolve_tac [@{thm le_funE}, @{thm le_boolE}] 1),
atac 1,
rewrite_goals_tac simp_thms',
atac 1])])
@@ -679,7 +683,7 @@
elims raw_induct ctxt =
let
val rec_name = Binding.name_of rec_binding;
- val rec_qualified = Binding.qualify false rec_name;
+ fun rec_qualified qualified = Binding.qualify qualified rec_name;
val intr_names = map Binding.name_of intr_bindings;
val ind_case_names = RuleCases.case_names intr_names;
val induct =
@@ -694,29 +698,29 @@
val (intrs', ctxt1) =
ctxt |>
LocalTheory.notes kind
- (map rec_qualified intr_bindings ~~ intr_atts ~~ map (fn th => [([th],
+ (map (rec_qualified false) intr_bindings ~~ intr_atts ~~ map (fn th => [([th],
[Attrib.internal (K (ContextRules.intro_query NONE)),
Attrib.internal (K Nitpick_Ind_Intros.add)])]) intrs) |>>
map (hd o snd);
val (((_, elims'), (_, [induct'])), ctxt2) =
ctxt1 |>
- LocalTheory.note kind ((rec_qualified (Binding.name "intros"), []), intrs') ||>>
+ LocalTheory.note kind ((rec_qualified true (Binding.name "intros"), []), intrs') ||>>
fold_map (fn (name, (elim, cases)) =>
- LocalTheory.note kind ((Binding.qualified_name (Long_Name.qualify (Long_Name.base_name name) "cases"),
+ LocalTheory.note kind ((Binding.qualify true (Long_Name.base_name name) (Binding.name "cases"),
[Attrib.internal (K (RuleCases.case_names cases)),
Attrib.internal (K (RuleCases.consumes 1)),
Attrib.internal (K (Induct.cases_pred name)),
Attrib.internal (K (ContextRules.elim_query NONE))]), [elim]) #>
apfst (hd o snd)) (if null elims then [] else cnames ~~ elims) ||>>
LocalTheory.note kind
- ((rec_qualified (Binding.name (coind_prefix coind ^ "induct")),
+ ((rec_qualified true (Binding.name (coind_prefix coind ^ "induct")),
map (Attrib.internal o K) (#2 induct)), [rulify (#1 induct)]);
val ctxt3 = if no_ind orelse coind then ctxt2 else
let val inducts = cnames ~~ Project_Rule.projects ctxt2 (1 upto length cnames) induct'
in
ctxt2 |>
- LocalTheory.notes kind [((rec_qualified (Binding.name "inducts"), []),
+ LocalTheory.notes kind [((rec_qualified true (Binding.name "inducts"), []),
inducts |> map (fn (name, th) => ([th],
[Attrib.internal (K ind_case_names),
Attrib.internal (K (RuleCases.consumes 1)),
@@ -762,8 +766,8 @@
(snd (Variable.add_fixes (map (fst o dest_Free) params) ctxt1)) ctxt1)
(rotate_prems ~1 (ObjectLogic.rulify
(fold_rule rec_preds_defs
- (rewrite_rule [le_fun_def, le_bool_def, sup_fun_eq, sup_bool_eq]
- (mono RS (fp_def RS def_coinduct))))))
+ (rewrite_rule simp_thms'''
+ (mono RS (fp_def RS @{thm def_coinduct}))))))
else
prove_indrule quiet_mode cs argTs bs xs rec_const params intr_ts mono fp_def
rec_preds_defs ctxt1);
--- a/src/HOL/Tools/inductive_set.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/inductive_set.ML Thu Oct 01 07:40:25 2009 +0200
@@ -74,8 +74,8 @@
in Drule.instantiate' [] (rev (map (SOME o cterm_of thy o Var) vs))
(p (fold (Logic.all o Var) vs t) f)
end;
- fun mkop "op &" T x = SOME (Const (@{const_name inter}, T --> T --> T), x)
- | mkop "op |" T x = SOME (Const (@{const_name union}, T --> T --> T), x)
+ fun mkop "op &" T x = SOME (Const (@{const_name Lattices.inf}, T --> T --> T), x)
+ | mkop "op |" T x = SOME (Const (@{const_name Lattices.sup}, T --> T --> T), x)
| mkop _ _ _ = NONE;
fun mk_collect p T t =
let val U = HOLogic.dest_setT T
--- a/src/HOL/Tools/int_arith.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/int_arith.ML Thu Oct 01 07:40:25 2009 +0200
@@ -49,13 +49,13 @@
make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc",
proc = proc1, identifier = []};
-fun check (Const (@{const_name "HOL.one"}, @{typ int})) = false
- | check (Const (@{const_name "HOL.one"}, _)) = true
+fun check (Const (@{const_name HOL.one}, @{typ int})) = false
+ | check (Const (@{const_name HOL.one}, _)) = true
| check (Const (s, _)) = member (op =) [@{const_name "op ="},
- @{const_name "HOL.times"}, @{const_name "HOL.uminus"},
- @{const_name "HOL.minus"}, @{const_name "HOL.plus"},
- @{const_name "HOL.zero"},
- @{const_name "HOL.less"}, @{const_name "HOL.less_eq"}] s
+ @{const_name HOL.times}, @{const_name HOL.uminus},
+ @{const_name HOL.minus}, @{const_name HOL.plus},
+ @{const_name HOL.zero},
+ @{const_name HOL.less}, @{const_name HOL.less_eq}] s
| check (a $ b) = check a andalso check b
| check _ = false;
--- a/src/HOL/Tools/lin_arith.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/lin_arith.ML Thu Oct 01 07:40:25 2009 +0200
@@ -22,8 +22,8 @@
val global_setup: theory -> theory
val split_limit: int Config.T
val neq_limit: int Config.T
- val warning_count: int ref
- val trace: bool ref
+ val warning_count: int Unsynchronized.ref
+ val trace: bool Unsynchronized.ref
end;
structure Lin_Arith: LIN_ARITH =
@@ -51,7 +51,7 @@
atomize (thm RS conjunct1) @ atomize (thm RS conjunct2)
| _ => [thm];
-fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name "Not"}, _) $ t)) = TP $ t
+fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name Not}, _) $ t)) = TP $ t
| neg_prop ((TP as Const("Trueprop", _)) $ t) = TP $ (HOLogic.Not $t)
| neg_prop t = raise TERM ("neg_prop", [t]);
--- a/src/HOL/Tools/meson.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/meson.ML Thu Oct 01 07:40:25 2009 +0200
@@ -319,7 +319,7 @@
Strips universal quantifiers and breaks up conjunctions.
Eliminates existential quantifiers using skoths: Skolemization theorems.*)
fun cnf skoths ctxt (th,ths) =
- let val ctxtr = ref ctxt
+ let val ctxtr = Unsynchronized.ref ctxt
fun cnf_aux (th,ths) =
if not (can HOLogic.dest_Trueprop (prop_of th)) then ths (*meta-level: ignore*)
else if not (has_conns ["All","Ex","op &"] (prop_of th))
--- a/src/HOL/Tools/metis_tools.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/metis_tools.ML Thu Oct 01 07:40:25 2009 +0200
@@ -10,7 +10,7 @@
val type_lits: bool Config.T
val metis_tac: Proof.context -> thm list -> int -> tactic
val metisF_tac: Proof.context -> thm list -> int -> tactic
- val metisH_tac: Proof.context -> thm list -> int -> tactic
+ val metisFT_tac: Proof.context -> thm list -> int -> tactic
val setup: theory -> theory
end
@@ -21,6 +21,8 @@
val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" true;
+ datatype mode = FO | HO | FT (*first-order, higher-order, fully-typed*)
+
(* ------------------------------------------------------------------------- *)
(* Useful Theorems *)
(* ------------------------------------------------------------------------- *)
@@ -81,20 +83,36 @@
| hol_term_to_fol_HO (ResHolClause.CombApp(tm1,tm2)) =
Metis.Term.Fn(".", map hol_term_to_fol_HO [tm1,tm2]);
- fun hol_literal_to_fol true (ResHolClause.Literal (pol, tm)) = (*first-order*)
+ (*The fully-typed translation, to avoid type errors*)
+ fun wrap_type (tm, ty) = Metis.Term.Fn("ti", [tm, hol_type_to_fol ty]);
+
+ fun hol_term_to_fol_FT (ResHolClause.CombVar(a, ty)) =
+ wrap_type (Metis.Term.Var a, ty)
+ | hol_term_to_fol_FT (ResHolClause.CombConst(a, ty, _)) =
+ wrap_type (Metis.Term.Fn(fn_isa_to_met a, []), ty)
+ | hol_term_to_fol_FT (tm as ResHolClause.CombApp(tm1,tm2)) =
+ wrap_type (Metis.Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]),
+ ResHolClause.type_of_combterm tm);
+
+ fun hol_literal_to_fol FO (ResHolClause.Literal (pol, tm)) =
let val (ResHolClause.CombConst(p,_,tys), tms) = ResHolClause.strip_comb tm
val tylits = if p = "equal" then [] else map hol_type_to_fol tys
val lits = map hol_term_to_fol_FO tms
in metis_lit pol (fn_isa_to_met p) (tylits @ lits) end
- | hol_literal_to_fol false (ResHolClause.Literal (pol, tm)) = (*higher-order*)
- case ResHolClause.strip_comb tm of
+ | hol_literal_to_fol HO (ResHolClause.Literal (pol, tm)) =
+ (case ResHolClause.strip_comb tm of
(ResHolClause.CombConst("equal",_,_), tms) =>
metis_lit pol "=" (map hol_term_to_fol_HO tms)
- | _ => metis_lit pol "{}" [hol_term_to_fol_HO tm];
+ | _ => metis_lit pol "{}" [hol_term_to_fol_HO tm]) (*hBOOL*)
+ | hol_literal_to_fol FT (ResHolClause.Literal (pol, tm)) =
+ (case ResHolClause.strip_comb tm of
+ (ResHolClause.CombConst("equal",_,_), tms) =>
+ metis_lit pol "=" (map hol_term_to_fol_FT tms)
+ | _ => metis_lit pol "{}" [hol_term_to_fol_FT tm]) (*hBOOL*);
- fun literals_of_hol_thm thy isFO t =
+ fun literals_of_hol_thm thy mode t =
let val (lits, types_sorts) = ResHolClause.literals_of_term thy t
- in (map (hol_literal_to_fol isFO) lits, types_sorts) end;
+ in (map (hol_literal_to_fol mode) lits, types_sorts) end;
(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*)
fun metis_of_typeLit pos (ResClause.LTVar (s,x)) = metis_lit pos s [Metis.Term.Var x]
@@ -106,10 +124,10 @@
fun metis_of_tfree tf =
Metis.Thm.axiom (Metis.LiteralSet.singleton (metis_of_typeLit true tf));
- fun hol_thm_to_fol is_conjecture ctxt isFO th =
+ fun hol_thm_to_fol is_conjecture ctxt mode th =
let val thy = ProofContext.theory_of ctxt
val (mlits, types_sorts) =
- (literals_of_hol_thm thy isFO o HOLogic.dest_Trueprop o prop_of) th
+ (literals_of_hol_thm thy mode o HOLogic.dest_Trueprop o prop_of) th
in
if is_conjecture then
(Metis.Thm.axiom (Metis.LiteralSet.fromList mlits), ResClause.add_typs types_sorts)
@@ -171,17 +189,13 @@
" received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands))
end;
-(*Instantiate constant c with the supplied types, but if they don't match its declared
- sort constraints, replace by a general type.*)
-fun const_of ctxt (c,Ts) = Const (c, dummyT)
-
fun infer_types ctxt =
Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt);
(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
with variable constraints in the goal...at least, type inference often fails otherwise.
SEE ALSO axiom_inf below.*)
- fun mk_var w = Term.Var((w,1), HOLogic.typeT);
+ fun mk_var (w,T) = Term.Var((w,1), T);
(*include the default sort, if available*)
fun mk_tfree ctxt w =
@@ -192,6 +206,18 @@
fun strip_happ args (Metis.Term.Fn(".",[t,u])) = strip_happ (u::args) t
| strip_happ args x = (x, args);
+ fun fol_type_to_isa ctxt (Metis.Term.Var v) =
+ (case Recon.strip_prefix ResClause.tvar_prefix v of
+ SOME w => Recon.make_tvar w
+ | NONE => Recon.make_tvar v)
+ | fol_type_to_isa ctxt (Metis.Term.Fn(x, tys)) =
+ (case Recon.strip_prefix ResClause.tconst_prefix x of
+ SOME tc => Term.Type (Recon.invert_type_const tc, map (fol_type_to_isa ctxt) tys)
+ | NONE =>
+ case Recon.strip_prefix ResClause.tfree_prefix x of
+ SOME tf => mk_tfree ctxt tf
+ | NONE => error ("fol_type_to_isa: " ^ x));
+
(*Maps metis terms to isabelle terms*)
fun fol_term_to_hol_RAW ctxt fol_tm =
let val thy = ProofContext.theory_of ctxt
@@ -201,8 +227,8 @@
SOME w => Type (Recon.make_tvar w)
| NONE =>
case Recon.strip_prefix ResClause.schematic_var_prefix v of
- SOME w => Term (mk_var w)
- | NONE => Term (mk_var v) )
+ SOME w => Term (mk_var (w, HOLogic.typeT))
+ | NONE => Term (mk_var (v, HOLogic.typeT)) )
(*Var from Metis with a name like _nnn; possibly a type variable*)
| tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg (*hBOOL*)
| tm_to_tt (t as Metis.Term.Fn (".",_)) =
@@ -226,7 +252,7 @@
val tys = types_of (List.take(tts,ntypes))
val ntyargs = Recon.num_typargs thy c
in if length tys = ntyargs then
- apply_list (const_of ctxt (c, tys)) nterms (List.drop(tts,ntypes))
+ apply_list (Const (c, dummyT)) nterms (List.drop(tts,ntypes))
else error ("Constant " ^ c ^ " expects " ^ Int.toString ntyargs ^
" but gets " ^ Int.toString (length tys) ^
" type arguments\n" ^
@@ -248,8 +274,45 @@
| NONE => error ("unexpected metis function: " ^ a)
in case tm_to_tt fol_tm of Term t => t | _ => error "fol_tm_to_tt: Term expected" end;
- fun fol_terms_to_hol ctxt fol_tms =
- let val ts = map (fol_term_to_hol_RAW ctxt) fol_tms
+ (*Maps fully-typed metis terms to isabelle terms*)
+ fun fol_term_to_hol_FT ctxt fol_tm =
+ let val _ = Output.debug (fn () => "fol_term_to_hol_FT: " ^ Metis.Term.toString fol_tm)
+ fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, ty])) =
+ (case Recon.strip_prefix ResClause.schematic_var_prefix v of
+ SOME w => mk_var(w, dummyT)
+ | NONE => mk_var(v, dummyT))
+ | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), ty])) =
+ Const ("op =", HOLogic.typeT)
+ | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) =
+ (case Recon.strip_prefix ResClause.const_prefix x of
+ SOME c => Const (Recon.invert_const c, dummyT)
+ | NONE => (*Not a constant. Is it a fixed variable??*)
+ case Recon.strip_prefix ResClause.fixed_var_prefix x of
+ SOME v => Free (v, fol_type_to_isa ctxt ty)
+ | NONE => error ("fol_term_to_hol_FT bad constant: " ^ x))
+ | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) =
+ cvt tm1 $ cvt tm2
+ | cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*)
+ cvt tm1 $ cvt tm2
+ | cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg (*hBOOL*)
+ | cvt (Metis.Term.Fn ("=", [tm1,tm2])) =
+ list_comb(Const ("op =", HOLogic.typeT), map cvt [tm1,tm2])
+ | cvt (t as Metis.Term.Fn (x, [])) =
+ (case Recon.strip_prefix ResClause.const_prefix x of
+ SOME c => Const (Recon.invert_const c, dummyT)
+ | NONE => (*Not a constant. Is it a fixed variable??*)
+ case Recon.strip_prefix ResClause.fixed_var_prefix x of
+ SOME v => Free (v, dummyT)
+ | NONE => (Output.debug (fn () => "fol_term_to_hol_FT bad const: " ^ x); fol_term_to_hol_RAW ctxt t))
+ | cvt t = (Output.debug (fn () => "fol_term_to_hol_FT bad term: " ^ Metis.Term.toString t); fol_term_to_hol_RAW ctxt t)
+ in cvt fol_tm end;
+
+ fun fol_term_to_hol ctxt FO = fol_term_to_hol_RAW ctxt
+ | fol_term_to_hol ctxt HO = fol_term_to_hol_RAW ctxt
+ | fol_term_to_hol ctxt FT = fol_term_to_hol_FT ctxt;
+
+ fun fol_terms_to_hol ctxt mode fol_tms =
+ let val ts = map (fol_term_to_hol ctxt mode) fol_tms
val _ = Output.debug (fn () => " calling type inference:")
val _ = app (fn t => Output.debug (fn () => Syntax.string_of_term ctxt t)) ts
val ts' = infer_types ctxt ts;
@@ -262,6 +325,8 @@
fun mk_not (Const ("Not", _) $ b) = b
| mk_not b = HOLogic.mk_not b;
+ val metis_eq = Metis.Term.Fn ("=", []);
+
(* ------------------------------------------------------------------------- *)
(* FOL step Inference Rules *)
(* ------------------------------------------------------------------------- *)
@@ -291,22 +356,22 @@
(*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
(* INFERENCE RULE: ASSUME *)
- fun assume_inf ctxt atm =
+ fun assume_inf ctxt mode atm =
inst_excluded_middle
(ProofContext.theory_of ctxt)
- (singleton (fol_terms_to_hol ctxt) (Metis.Term.Fn atm));
+ (singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm));
(* INFERENCE RULE: INSTANTIATE (Subst). Type instantiations are ignored. Trying to reconstruct
them admits new possibilities of errors, e.g. concerning sorts. Instead we try to arrange
that new TVars are distinct and that types can be inferred from terms.*)
- fun inst_inf ctxt thpairs fsubst th =
+ fun inst_inf ctxt mode thpairs fsubst th =
let val thy = ProofContext.theory_of ctxt
val i_th = lookth thpairs th
val i_th_vars = Term.add_vars (prop_of i_th) []
fun find_var x = valOf (List.find (fn ((a,_),_) => a=x) i_th_vars)
fun subst_translation (x,y) =
let val v = find_var x
- val t = fol_term_to_hol_RAW ctxt y (*we call infer_types below*)
+ val t = fol_term_to_hol ctxt mode y (*we call infer_types below*)
in SOME (cterm_of thy (Var v), t) end
handle Option =>
(Output.debug (fn() => "List.find failed for the variable " ^ x ^
@@ -324,10 +389,11 @@
val tms = infer_types ctxt rawtms;
val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th)
val substs' = ListPair.zip (vars, map ctm_of tms)
- val _ = Output.debug (fn() => "subst_translations:")
- val _ = app (fn (x,y) => Output.debug (fn () => Display.string_of_cterm x ^ " |-> " ^
- Display.string_of_cterm y))
- substs'
+ val _ = Output.debug (fn () =>
+ cat_lines ("subst_translations:" ::
+ (substs' |> map (fn (x, y) =>
+ Syntax.string_of_term ctxt (term_of x) ^ " |-> " ^
+ Syntax.string_of_term ctxt (term_of y)))));
in cterm_instantiate substs' i_th
handle THM (msg, _, _) => error ("metis error (inst_inf): " ^ msg)
end;
@@ -346,7 +412,7 @@
| _ => raise THM ("resolve_inc_tyvars: unique result expected", i, [tha,thb])
end;
- fun resolve_inf ctxt thpairs atm th1 th2 =
+ fun resolve_inf ctxt mode thpairs atm th1 th2 =
let
val thy = ProofContext.theory_of ctxt
val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
@@ -357,7 +423,7 @@
else if is_TrueI i_th2 then i_th1
else
let
- val i_atm = singleton (fol_terms_to_hol ctxt) (Metis.Term.Fn atm)
+ val i_atm = singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm)
val _ = Output.debug (fn () => " atom: " ^ Syntax.string_of_term ctxt i_atm)
val prems_th1 = prems_of i_th1
val prems_th2 = prems_of i_th2
@@ -374,9 +440,9 @@
val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
val refl_idx = 1 + Thm.maxidx_of REFL_THM;
- fun refl_inf ctxt t =
+ fun refl_inf ctxt mode t =
let val thy = ProofContext.theory_of ctxt
- val i_t = singleton (fol_terms_to_hol ctxt) t
+ val i_t = singleton (fol_terms_to_hol ctxt mode) t
val _ = Output.debug (fn () => " term: " ^ Syntax.string_of_term ctxt i_t)
val c_t = cterm_incr_types thy refl_idx i_t
in cterm_instantiate [(refl_x, c_t)] REFL_THM end;
@@ -386,41 +452,64 @@
| get_ty_arg_size thy _ = 0;
(* INFERENCE RULE: EQUALITY *)
- fun equality_inf ctxt isFO thpairs (pos,atm) fp fr =
+ fun equality_inf ctxt mode thpairs (pos,atm) fp fr =
let val thy = ProofContext.theory_of ctxt
- val [i_atm,i_tm] = fol_terms_to_hol ctxt [Metis.Term.Fn atm, fr]
+ val m_tm = Metis.Term.Fn atm
+ val [i_atm,i_tm] = fol_terms_to_hol ctxt mode [m_tm, fr]
val _ = Output.debug (fn () => "sign of the literal: " ^ Bool.toString pos)
fun replace_item_list lx 0 (l::ls) = lx::ls
| replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
- fun path_finder_FO tm (p::ps) =
+ fun path_finder_FO tm [] = (tm, Term.Bound 0)
+ | path_finder_FO tm (p::ps) =
let val (tm1,args) = Term.strip_comb tm
val adjustment = get_ty_arg_size thy tm1
val p' = if adjustment > p then p else p-adjustment
val tm_p = List.nth(args,p')
handle Subscript => error ("equality_inf: " ^ Int.toString p ^ " adj " ^
Int.toString adjustment ^ " term " ^ Syntax.string_of_term ctxt tm)
+ val _ = Output.debug (fn () => "path_finder: " ^ Int.toString p ^
+ " " ^ Syntax.string_of_term ctxt tm_p)
+ val (r,t) = path_finder_FO tm_p ps
in
- Output.debug (fn () => "path_finder: " ^ Int.toString p ^
- " " ^ Syntax.string_of_term ctxt tm_p);
- if null ps (*FIXME: why not use pattern-matching and avoid repetition*)
- then (tm_p, list_comb (tm1, replace_item_list (Term.Bound 0) p' args))
- else let val (r,t) = path_finder_FO tm_p ps
- in (r, list_comb (tm1, replace_item_list t p' args)) end
+ (r, list_comb (tm1, replace_item_list t p' args))
end
fun path_finder_HO tm [] = (tm, Term.Bound 0)
| path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
| path_finder_HO (t$u) (p::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
- fun path_finder true tm ps = path_finder_FO tm ps
- | path_finder false (tm as Const("op =",_) $ _ $ _) (p::ps) =
+ fun path_finder_FT tm [] _ = (tm, Term.Bound 0)
+ | path_finder_FT tm (0::ps) (Metis.Term.Fn ("ti", [t1,t2])) =
+ path_finder_FT tm ps t1
+ | path_finder_FT (t$u) (0::ps) (Metis.Term.Fn (".", [t1,t2])) =
+ (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
+ | path_finder_FT (t$u) (1::ps) (Metis.Term.Fn (".", [t1,t2])) =
+ (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
+ | path_finder_FT tm ps t = error ("equality_inf, path_finder_FT: path = " ^
+ space_implode " " (map Int.toString ps) ^
+ " isa-term: " ^ Syntax.string_of_term ctxt tm ^
+ " fol-term: " ^ Metis.Term.toString t)
+ fun path_finder FO tm ps _ = path_finder_FO tm ps
+ | path_finder HO (tm as Const("op =",_) $ _ $ _) (p::ps) _ =
(*equality: not curried, as other predicates are*)
if p=0 then path_finder_HO tm (0::1::ps) (*select first operand*)
else path_finder_HO tm (p::ps) (*1 selects second operand*)
- | path_finder false tm (p::ps) =
+ | path_finder HO tm (p::ps) (Metis.Term.Fn ("{}", [t1])) =
path_finder_HO tm ps (*if not equality, ignore head to skip hBOOL*)
+ | path_finder FT (tm as Const("op =",_) $ _ $ _) (p::ps)
+ (Metis.Term.Fn ("=", [t1,t2])) =
+ (*equality: not curried, as other predicates are*)
+ if p=0 then path_finder_FT tm (0::1::ps)
+ (Metis.Term.Fn (".", [Metis.Term.Fn (".", [metis_eq,t1]), t2]))
+ (*select first operand*)
+ else path_finder_FT tm (p::ps)
+ (Metis.Term.Fn (".", [metis_eq,t2]))
+ (*1 selects second operand*)
+ | path_finder FT tm (p::ps) (Metis.Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
+ (*if not equality, ignore head to skip the hBOOL predicate*)
+ | path_finder FT tm ps t = path_finder_FT tm ps t (*really an error case!*)
fun path_finder_lit ((nt as Term.Const ("Not", _)) $ tm_a) idx =
- let val (tm, tm_rslt) = path_finder isFO tm_a idx
+ let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
in (tm, nt $ tm_rslt) end
- | path_finder_lit tm_a idx = path_finder isFO tm_a idx
+ | path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm
val (tm_subst, body) = path_finder_lit i_atm fp
val tm_abs = Term.Abs("x", Term.type_of tm_subst, body)
val _ = Output.debug (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
@@ -435,34 +524,34 @@
val factor = Seq.hd o distinct_subgoals_tac;
- fun step ctxt isFO thpairs (fol_th, Metis.Proof.Axiom _) =
+ fun step ctxt mode thpairs (fol_th, Metis.Proof.Axiom _) =
factor (axiom_inf ctxt thpairs fol_th)
- | step ctxt isFO thpairs (_, Metis.Proof.Assume f_atm) =
- assume_inf ctxt f_atm
- | step ctxt isFO thpairs (_, Metis.Proof.Subst(f_subst, f_th1)) =
- factor (inst_inf ctxt thpairs f_subst f_th1)
- | step ctxt isFO thpairs (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) =
- factor (resolve_inf ctxt thpairs f_atm f_th1 f_th2)
- | step ctxt isFO thpairs (_, Metis.Proof.Refl f_tm) =
- refl_inf ctxt f_tm
- | step ctxt isFO thpairs (_, Metis.Proof.Equality(f_lit, f_p, f_r)) =
- equality_inf ctxt isFO thpairs f_lit f_p f_r;
+ | step ctxt mode thpairs (_, Metis.Proof.Assume f_atm) =
+ assume_inf ctxt mode f_atm
+ | step ctxt mode thpairs (_, Metis.Proof.Subst(f_subst, f_th1)) =
+ factor (inst_inf ctxt mode thpairs f_subst f_th1)
+ | step ctxt mode thpairs (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) =
+ factor (resolve_inf ctxt mode thpairs f_atm f_th1 f_th2)
+ | step ctxt mode thpairs (_, Metis.Proof.Refl f_tm) =
+ refl_inf ctxt mode f_tm
+ | step ctxt mode thpairs (_, Metis.Proof.Equality(f_lit, f_p, f_r)) =
+ equality_inf ctxt mode thpairs f_lit f_p f_r;
fun real_literal (b, (c, _)) = not (String.isPrefix ResClause.class_prefix c);
- fun translate isFO _ thpairs [] = thpairs
- | translate isFO ctxt thpairs ((fol_th, inf) :: infpairs) =
+ fun translate mode _ thpairs [] = thpairs
+ | translate mode ctxt thpairs ((fol_th, inf) :: infpairs) =
let val _ = Output.debug (fn () => "=============================================")
val _ = Output.debug (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th)
val _ = Output.debug (fn () => "INFERENCE: " ^ Metis.Proof.inferenceToString inf)
- val th = Meson.flexflex_first_order (step ctxt isFO thpairs (fol_th, inf))
+ val th = Meson.flexflex_first_order (step ctxt mode thpairs (fol_th, inf))
val _ = Output.debug (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
val _ = Output.debug (fn () => "=============================================")
val n_metis_lits = length (filter real_literal (Metis.LiteralSet.toList (Metis.Thm.clause fol_th)))
in
if nprems_of th = n_metis_lits then ()
else error "Metis: proof reconstruction has gone wrong";
- translate isFO ctxt ((fol_th, th) :: thpairs) infpairs
+ translate mode ctxt ((fol_th, th) :: thpairs) infpairs
end;
(*Determining which axiom clauses are actually used*)
@@ -499,8 +588,7 @@
(* ------------------------------------------------------------------------- *)
type logic_map =
- {isFO : bool,
- axioms : (Metis.Thm.thm * Thm.thm) list,
+ {axioms : (Metis.Thm.thm * Thm.thm) list,
tfrees : ResClause.type_literal list};
fun const_in_metis c (pol,(pred,tm_list)) =
@@ -515,37 +603,39 @@
let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts
in ResClause.add_typs (Vartab.fold add (#2 (Variable.constraints_of ctxt)) []) end;
- (*transform isabelle clause to metis clause *)
- fun add_thm is_conjecture ctxt (ith, {isFO, axioms, tfrees}) : logic_map =
- let val (mth, tfree_lits) = hol_thm_to_fol is_conjecture ctxt isFO ith
- in
- {isFO = isFO,
- axioms = (mth, Meson.make_meta_clause ith) :: axioms,
- tfrees = tfree_lits union tfrees}
- end;
-
(*transform isabelle type / arity clause to metis clause *)
fun add_type_thm [] lmap = lmap
- | add_type_thm ((ith, mth) :: cls) {isFO, axioms, tfrees} =
- add_type_thm cls {isFO = isFO,
- axioms = (mth, ith) :: axioms,
+ | add_type_thm ((ith, mth) :: cls) {axioms, tfrees} =
+ add_type_thm cls {axioms = (mth, ith) :: axioms,
tfrees = tfrees}
(*Insert non-logical axioms corresponding to all accumulated TFrees*)
- fun add_tfrees {isFO, axioms, tfrees} : logic_map =
- {isFO = isFO,
- axioms = (map (fn tf => (metis_of_tfree tf, TrueI)) (distinct op= tfrees)) @ axioms,
+ fun add_tfrees {axioms, tfrees} : logic_map =
+ {axioms = (map (fn tf => (metis_of_tfree tf, TrueI)) (distinct op= tfrees)) @ axioms,
tfrees = tfrees};
+ fun string_of_mode FO = "FO"
+ | string_of_mode HO = "HO"
+ | string_of_mode FT = "FT"
+
(* Function to generate metis clauses, including comb and type clauses *)
- fun build_map mode ctxt cls ths =
+ fun build_map mode0 ctxt cls ths =
let val thy = ProofContext.theory_of ctxt
- val all_thms_FO = forall (Meson.is_fol_term thy o prop_of)
- val isFO = (mode = ResAtp.Fol) orelse
- (mode <> ResAtp.Hol andalso all_thms_FO (cls @ ths))
- val lmap0 = List.foldl (add_thm true ctxt)
- {isFO = isFO, axioms = [], tfrees = init_tfrees ctxt} cls
- val lmap = List.foldl (add_thm false ctxt) (add_tfrees lmap0) ths
+ (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
+ fun set_mode FO = FO
+ | set_mode HO = if forall (Meson.is_fol_term thy o prop_of) (cls@ths) then FO else HO
+ | set_mode FT = FT
+ val mode = set_mode mode0
+ (*transform isabelle clause to metis clause *)
+ fun add_thm is_conjecture (ith, {axioms, tfrees}) : logic_map =
+ let val (mth, tfree_lits) = hol_thm_to_fol is_conjecture ctxt mode ith
+ in
+ {axioms = (mth, Meson.make_meta_clause ith) :: axioms,
+ tfrees = tfree_lits union tfrees}
+ end;
+ val lmap0 = List.foldl (add_thm true)
+ {axioms = [], tfrees = init_tfrees ctxt} cls
+ val lmap = List.foldl (add_thm false) (add_tfrees lmap0) ths
val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap)
fun used c = exists (Metis.LiteralSet.exists (const_in_metis c)) clause_lists
(*Now check for the existence of certain combinators*)
@@ -555,10 +645,10 @@
val thC = if used "c_COMBC" then [comb_C] else []
val thS = if used "c_COMBS" then [comb_S] else []
val thEQ = if used "c_fequal" then [fequal_imp_equal', equal_imp_fequal'] else []
- val lmap' = if isFO then lmap
- else List.foldl (add_thm false ctxt) lmap (thEQ @ thS @ thC @ thB @ thK @ thI)
+ val lmap' = if mode=FO then lmap
+ else List.foldl (add_thm false) lmap (thEQ @ thS @ thC @ thB @ thK @ thI)
in
- add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap'
+ (mode, add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap')
end;
fun refute cls =
@@ -579,16 +669,14 @@
val _ = app (fn th => Output.debug (fn () => Display.string_of_thm ctxt th)) cls
val _ = Output.debug (fn () => "THEOREM CLAUSES")
val _ = app (fn th => Output.debug (fn () => Display.string_of_thm ctxt th)) ths
- val {isFO,axioms,tfrees} = build_map mode ctxt cls ths
+ val (mode, {axioms,tfrees}) = build_map mode ctxt cls ths
val _ = if null tfrees then ()
else (Output.debug (fn () => "TFREE CLAUSES");
app (fn tf => Output.debug (fn _ => ResClause.tptp_of_typeLit true tf)) tfrees)
val _ = Output.debug (fn () => "CLAUSES GIVEN TO METIS")
val thms = map #1 axioms
val _ = app (fn th => Output.debug (fn () => Metis.Thm.toString th)) thms
- val _ = if isFO
- then Output.debug (fn () => "goal is first-order")
- else Output.debug (fn () => "goal is higher-order")
+ val _ = Output.debug (fn () => "mode = " ^ string_of_mode mode)
val _ = Output.debug (fn () => "START METIS PROVE PROCESS")
in
case List.filter (is_false o prop_of) cls of
@@ -601,7 +689,7 @@
val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
(*add constraints arising from converting goal to clause form*)
val proof = Metis.Proof.proof mth
- val result = translate isFO ctxt' axioms proof
+ val result = translate mode ctxt' axioms proof
and used = List.mapPartial (used_axioms axioms) proof
val _ = Output.debug (fn () => "METIS COMPLETED...clauses actually used:")
val _ = app (fn th => Output.debug (fn () => Display.string_of_thm ctxt th)) used
@@ -634,18 +722,18 @@
end
handle METIS s => (warning ("Metis: " ^ s); Seq.empty);
- val metis_tac = metis_general_tac ResAtp.Auto;
- val metisF_tac = metis_general_tac ResAtp.Fol;
- val metisH_tac = metis_general_tac ResAtp.Hol;
+ val metis_tac = metis_general_tac HO;
+ val metisF_tac = metis_general_tac FO;
+ val metisFT_tac = metis_general_tac FT;
fun method name mode comment = Method.setup name (Attrib.thms >> (fn ths => fn ctxt =>
SIMPLE_METHOD' (CHANGED_PROP o metis_general_tac mode ctxt ths))) comment;
val setup =
type_lits_setup #>
- method @{binding metis} ResAtp.Auto "METIS for FOL & HOL problems" #>
- method @{binding metisF} ResAtp.Fol "METIS for FOL problems" #>
- method @{binding metisH} ResAtp.Hol "METIS for HOL problems" #>
+ method @{binding metis} HO "METIS for FOL & HOL problems" #>
+ method @{binding metisF} FO "METIS for FOL problems" #>
+ method @{binding metisFT} FT "METIS With-fully typed translation" #>
Method.setup @{binding finish_clausify}
(Scan.succeed (K (SIMPLE_METHOD (ResAxioms.expand_defs_tac refl))))
"cleanup after conversion to clauses";
--- a/src/HOL/Tools/old_primrec.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/old_primrec.ML Thu Oct 01 07:40:25 2009 +0200
@@ -230,15 +230,15 @@
(tname, dt)::(find_dts dt_info tnames' tnames)
else find_dts dt_info tnames' tnames);
-fun prepare_induct ({descr, induction, ...}: info) rec_eqns =
+fun prepare_induct ({descr, induct, ...}: info) rec_eqns =
let
fun constrs_of (_, (_, _, cs)) =
map (fn (cname:string, (_, cargs, _, _, _)) => (cname, map fst cargs)) cs;
- val params_of = these o AList.lookup (op =) (List.concat (map constrs_of rec_eqns));
+ val params_of = these o AList.lookup (op =) (maps constrs_of rec_eqns);
in
- induction
- |> RuleCases.rename_params (map params_of (List.concat (map (map #1 o #3 o #2) descr)))
- |> RuleCases.save induction
+ induct
+ |> RuleCases.rename_params (map params_of (maps (map #1 o #3 o #2) descr))
+ |> RuleCases.save induct
end;
local
--- a/src/HOL/Tools/polyhash.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/polyhash.ML Thu Oct 01 07:40:25 2009 +0200
@@ -108,8 +108,8 @@
HT of {hashVal : 'key -> int,
sameKey : 'key * 'key -> bool,
not_found : exn,
- table : ('key, 'data) bucket_t Array.array ref,
- n_items : int ref}
+ table : ('key, 'data) bucket_t Array.array Unsynchronized.ref,
+ n_items : int Unsynchronized.ref}
local
(*
@@ -134,8 +134,8 @@
hashVal=hashVal,
sameKey=sameKey,
not_found = notFound,
- table = ref (Array.array(roundUp sizeHint, NIL)),
- n_items = ref 0
+ table = Unsynchronized.ref (Array.array(roundUp sizeHint, NIL)),
+ n_items = Unsynchronized.ref 0
};
(* conditionally grow a table *)
@@ -174,7 +174,7 @@
val indx = index (hash, sz)
fun look NIL = (
Array.update(arr, indx, B(hash, key, item, Array.sub(arr, indx)));
- inc n_items;
+ Unsynchronized.inc n_items;
growTable tbl;
NIL)
| look (B(h, k, v, r)) = if ((hash = h) andalso sameKey(key, k))
@@ -200,7 +200,7 @@
fun look NIL =
(Array.update(arr, indx, B(hash, key, item,
Array.sub(arr, indx)));
- inc n_items;
+ Unsynchronized.inc n_items;
growTable tbl;
NONE)
| look (B(h, k, v, r)) =
@@ -261,7 +261,7 @@
fun numItems (HT{n_items, ...}) = !n_items
(* return a list of the items in the table *)
- fun listItems (HT{table = ref arr, n_items, ...}) = let
+ fun listItems (HT{table = Unsynchronized.ref arr, n_items, ...}) = let
fun f (_, l, 0) = l
| f (~1, l, _) = l
| f (i, l, n) = let
@@ -306,8 +306,8 @@
mapTbl 0;
HT{hashVal=hashVal,
sameKey=sameKey,
- table = ref newArr,
- n_items = ref(!n_items),
+ table = Unsynchronized.ref newArr,
+ n_items = Unsynchronized.ref(!n_items),
not_found = not_found}
end (* transform *);
@@ -348,8 +348,8 @@
mapTbl 0;
HT{hashVal=hashVal,
sameKey=sameKey,
- table = ref newArr,
- n_items = ref(!n_items),
+ table = Unsynchronized.ref newArr,
+ n_items = Unsynchronized.ref(!n_items),
not_found = not_found}
end (* transform *);
@@ -365,15 +365,15 @@
(mapTbl 0) handle _ => (); (* FIXME avoid handle _ *)
HT{hashVal=hashVal,
sameKey=sameKey,
- table = ref newArr,
- n_items = ref(!n_items),
+ table = Unsynchronized.ref newArr,
+ n_items = Unsynchronized.ref(!n_items),
not_found = not_found}
end (* copy *);
(* returns a list of the sizes of the various buckets. This is to
* allow users to gauge the quality of their hashing function.
*)
- fun bucketSizes (HT{table = ref arr, ...}) = let
+ fun bucketSizes (HT{table = Unsynchronized.ref arr, ...}) = let
fun len (NIL, n) = n
| len (B(_, _, _, r), n) = len(r, n+1)
fun f (~1, l) = l
--- a/src/HOL/Tools/prop_logic.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/prop_logic.ML Thu Oct 01 07:40:25 2009 +0200
@@ -292,7 +292,7 @@
val fm' = nnf fm
(* 'new' specifies the next index that is available to introduce an auxiliary variable *)
(* int ref *)
- val new = ref (maxidx fm' + 1)
+ val new = Unsynchronized.ref (maxidx fm' + 1)
(* unit -> int *)
fun new_idx () = let val idx = !new in new := idx+1; idx end
(* replaces 'And' by an auxiliary variable (and its definition) *)
@@ -381,15 +381,15 @@
(* Term.term -> int Termtab.table -> prop_formula * int Termtab.table *)
fun prop_formula_of_term t table =
let
- val next_idx_is_valid = ref false
- val next_idx = ref 0
+ val next_idx_is_valid = Unsynchronized.ref false
+ val next_idx = Unsynchronized.ref 0
fun get_next_idx () =
if !next_idx_is_valid then
- inc next_idx
+ Unsynchronized.inc next_idx
else (
next_idx := Termtab.fold (curry Int.max o snd) table 0;
next_idx_is_valid := true;
- inc next_idx
+ Unsynchronized.inc next_idx
)
fun aux (Const ("True", _)) table =
(True, table)
--- a/src/HOL/Tools/quickcheck_generators.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/quickcheck_generators.ML Thu Oct 01 07:40:25 2009 +0200
@@ -16,7 +16,7 @@
-> term list * (term * term) list
val ensure_random_datatype: Datatype.config -> string list -> theory -> theory
val compile_generator_expr: theory -> term -> int -> term list option
- val eval_ref: (unit -> int -> seed -> term list option * seed) option ref
+ val eval_ref: (unit -> int -> seed -> term list option * seed) option Unsynchronized.ref
val setup: theory -> theory
end;
@@ -43,7 +43,7 @@
val ((y, t2), seed') = random seed;
val (seed'', seed''') = random_split seed';
- val state = ref (seed'', [], fn () => Abs ("x", T1, t2 ()));
+ val state = Unsynchronized.ref (seed'', [], fn () => Abs ("x", T1, t2 ()));
fun random_fun' x =
let
val (seed, fun_map, f_t) = ! state;
@@ -76,7 +76,7 @@
val lhs = HOLogic.mk_random T size;
val rhs = HOLogic.mk_ST [((HOLogic.mk_random T' size, @{typ Random.seed}), SOME (v, Tm'))]
(HOLogic.mk_return Tm @{typ Random.seed}
- (mk_const "Code_Eval.valapp" [T', T]
+ (mk_const "Code_Evaluation.valapp" [T', T]
$ HOLogic.mk_prod (t_constr, Abs ("u", @{typ unit}, HOLogic.reflect_term t_constr)) $ t_v))
@{typ Random.seed} (SOME Tm, @{typ Random.seed});
val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
@@ -321,24 +321,23 @@
fun ensure_random_datatype config raw_tycos thy =
let
- val pp = Syntax.pp_global thy;
val algebra = Sign.classes_of thy;
val (descr, raw_vs, tycos, prfx, (names, auxnames), raw_TUs) =
Datatype.the_descr thy raw_tycos;
- val typrep_vs = (map o apsnd)
+ val typerep_vs = (map o apsnd)
(curry (Sorts.inter_sort algebra) @{sort typerep}) raw_vs;
val random_insts = (map (rpair @{sort random}) o flat o maps snd o maps snd)
- (DatatypeAux.interpret_construction descr typrep_vs
+ (DatatypeAux.interpret_construction descr typerep_vs
{ atyp = single, dtyp = (K o K o K) [] });
val term_of_insts = (map (rpair @{sort term_of}) o flat o maps snd o maps snd)
- (DatatypeAux.interpret_construction descr typrep_vs
+ (DatatypeAux.interpret_construction descr typerep_vs
{ atyp = K [], dtyp = K o K });
val has_inst = exists (fn tyco =>
can (Sorts.mg_domain algebra tyco) @{sort random}) tycos;
in if has_inst then thy
- else case perhaps_constrain thy (random_insts @ term_of_insts) typrep_vs
+ else case perhaps_constrain thy (random_insts @ term_of_insts) typerep_vs
of SOME constrain => mk_random_datatype config descr
- (map constrain typrep_vs) tycos prfx (names, auxnames)
+ (map constrain typerep_vs) tycos prfx (names, auxnames)
((pairself o map o map_atyps) (fn TFree v => TFree (constrain v)) raw_TUs) thy
| NONE => thy
end;
@@ -346,7 +345,9 @@
(** building and compiling generator expressions **)
-val eval_ref : (unit -> int -> int * int -> term list option * (int * int)) option ref = ref NONE;
+val eval_ref :
+ (unit -> int -> int * int -> term list option * (int * int)) option Unsynchronized.ref =
+ Unsynchronized.ref NONE;
val target = "Quickcheck";
--- a/src/HOL/Tools/record.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/record.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,7 +1,10 @@
(* Title: HOL/Tools/record.ML
- Author: Wolfgang Naraschewski, Norbert Schirmer and Markus Wenzel, TU Muenchen
-
-Extensible records with structural subtyping in HOL.
+ Author: Wolfgang Naraschewski, TU Muenchen
+ Author: Markus Wenzel, TU Muenchen
+ Author: Norbert Schirmer, TU Muenchen
+ Author: Thomas Sewell, NICTA
+
+Extensible records with structural subtyping.
*)
signature BASIC_RECORD =
@@ -15,15 +18,15 @@
val record_split_simp_tac: thm list -> (term -> int) -> int -> tactic
val record_split_name: string
val record_split_wrapper: string * wrapper
- val print_record_type_abbr: bool ref
- val print_record_type_as_fields: bool ref
+ val print_record_type_abbr: bool Unsynchronized.ref
+ val print_record_type_as_fields: bool Unsynchronized.ref
end;
signature RECORD =
sig
include BASIC_RECORD
- val timing: bool ref
- val record_quick_and_dirty_sensitive: bool ref
+ val timing: bool Unsynchronized.ref
+ val record_quick_and_dirty_sensitive: bool Unsynchronized.ref
val updateN: string
val updN: string
val ext_typeN: string
@@ -34,8 +37,8 @@
val last_extT: typ -> (string * typ list) option
val dest_recTs : typ -> (string * typ list) list
- val get_extT_fields: theory -> typ -> (string * typ) list * (string * typ)
- val get_recT_fields: theory -> typ -> (string * typ) list * (string * typ)
+ val get_extT_fields: theory -> typ -> (string * typ) list * (string * typ)
+ val get_recT_fields: theory -> typ -> (string * typ) list * (string * typ)
val get_parent: theory -> string -> (typ list * string) option
val get_extension: theory -> string -> (string * typ list) option
val get_extinjects: theory -> thm list
@@ -51,20 +54,192 @@
end;
+signature ISTUPLE_SUPPORT =
+sig
+ val add_istuple_type: bstring * string list -> (typ * typ) -> theory -> term * term * theory
+
+ val mk_cons_tuple: term * term -> term
+ val dest_cons_tuple: term -> term * term
+
+ val istuple_intros_tac: theory -> int -> tactic
+
+ val named_cterm_instantiate: (string * cterm) list -> thm -> thm
+end;
+
+structure IsTupleSupport: ISTUPLE_SUPPORT =
+struct
+
+val isomN = "_TupleIsom";
+val defN = "_def";
+
+val istuple_UNIV_I = @{thm "istuple_UNIV_I"};
+val istuple_True_simp = @{thm "istuple_True_simp"};
+
+val istuple_intro = @{thm "isomorphic_tuple_intro"};
+val istuple_intros = build_net (@{thms "isomorphic_tuple.intros"});
+
+val constname = fst o dest_Const;
+val tuple_istuple = (constname @{term tuple_istuple}, @{thm tuple_istuple});
+
+val istuple_constN = constname @{term isomorphic_tuple};
+val istuple_consN = constname @{term istuple_cons};
+
+val tup_isom_typeN = fst (dest_Type @{typ "('a, 'b, 'c) tuple_isomorphism"});
+
+fun named_cterm_instantiate values thm =
+ let
+ fun match name ((name', _), _) = name = name'
+ | match name _ = false;
+ 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)
+ | NONE => raise THM ("named_cterm_instantiate: " ^ name, 0, [thm]));
+ in
+ cterm_instantiate (map (apfst getvar) values) thm
+ end;
+
+structure IsTupleThms = TheoryDataFun
+(
+ type T = thm Symtab.table;
+ val empty = Symtab.make [tuple_istuple];
+ val copy = I;
+ val extend = I;
+ fun merge _ = Symtab.merge Thm.eq_thm_prop;
+);
+
+fun do_typedef name repT alphas thy =
+ 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 rewrite_rule = MetaSimplifier.rewrite_rule [istuple_UNIV_I, istuple_True_simp];
+ in (map rewrite_rule [rep_inject, abs_inverse],
+ Const (absN, repT --> absT), absT) end;
+ in
+ thy
+ |> Typecopy.typecopy (Binding.name name, alphas) repT NONE
+ |-> (fn (name, _) => `(fn thy => get_thms thy name))
+ end;
+
+fun mk_cons_tuple (left, right) =
+ let
+ val (leftT, rightT) = (fastype_of left, fastype_of right);
+ val prodT = HOLogic.mk_prodT (leftT, rightT);
+ val isomT = Type (tup_isom_typeN, [prodT, leftT, rightT]);
+ in
+ Const (istuple_consN, isomT --> leftT --> rightT --> prodT) $
+ Const (fst tuple_istuple, isomT) $ left $ right
+ end;
+
+fun dest_cons_tuple (v as Const (ic, _) $ Const _ $ left $ right) =
+ if ic = istuple_consN then (left, right)
+ else raise TERM ("dest_cons_tuple", [v])
+ | dest_cons_tuple v = raise TERM ("dest_cons_tuple", [v]);
+
+fun add_istuple_type (name, alphas) (leftT, rightT) thy =
+ let
+ val repT = HOLogic.mk_prodT (leftT, rightT);
+
+ val (([rep_inject, abs_inverse], absC, absT), typ_thy) =
+ thy
+ |> do_typedef name repT alphas
+ ||> Sign.add_path name;
+
+ (*construct a type and body for the isomorphism constant by
+ instantiating the theorem to which the definition will be applied*)
+ val intro_inst =
+ rep_inject RS named_cterm_instantiate [("abst", cterm_of typ_thy absC)] istuple_intro;
+ val (_, body) = Logic.dest_equals (List.last (prems_of intro_inst));
+ val isomT = fastype_of body;
+ val isom_bind = Binding.name (name ^ isomN);
+ val isom = Const (Sign.full_name typ_thy isom_bind, isomT);
+ val isom_spec = (name ^ isomN ^ defN, Logic.mk_equals (isom, body));
+
+ 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)];
+
+ val istuple = isom_def RS (abs_inverse RS (rep_inject RS istuple_intro));
+ val cons = Const (istuple_consN, isomT --> leftT --> rightT --> absT);
+
+ val thm_thy =
+ cdef_thy
+ |> IsTupleThms.map (Symtab.insert Thm.eq_thm_prop (constname isom, istuple))
+ |> Sign.parent_path;
+ in
+ (isom, cons $ isom, thm_thy)
+ end;
+
+fun istuple_intros_tac thy =
+ let
+ val isthms = IsTupleThms.get thy;
+ fun err s t = raise TERM ("istuple_intros_tac: " ^ s, [t]);
+ val use_istuple_thm_tac = SUBGOAL (fn (goal, n) =>
+ let
+ val goal' = Envir.beta_eta_contract goal;
+ val isom =
+ (case goal' of
+ Const tp $ (Const pr $ Const is) =>
+ if fst tp = "Trueprop" andalso fst pr = istuple_constN
+ then Const is
+ else err "unexpected goal predicate" goal'
+ | _ => err "unexpected goal format" goal');
+ val isthm =
+ (case Symtab.lookup isthms (constname isom) of
+ SOME isthm => isthm
+ | NONE => err "no thm found for constant" isom);
+ in rtac isthm n end);
+ in
+ fn n => resolve_from_net_tac istuple_intros n THEN use_istuple_thm_tac n
+ end;
+
+end;
+
+
structure Record: RECORD =
struct
-val eq_reflection = thm "eq_reflection";
-val rec_UNIV_I = thm "rec_UNIV_I";
-val rec_True_simp = thm "rec_True_simp";
-val Pair_eq = thm "Product_Type.prod.inject";
-val atomize_all = thm "HOL.atomize_all";
-val atomize_imp = thm "HOL.atomize_imp";
-val meta_allE = thm "Pure.meta_allE";
-val prop_subst = thm "prop_subst";
-val Pair_sel_convs = [fst_conv,snd_conv];
-val K_record_comp = @{thm "K_record_comp"};
+val eq_reflection = @{thm eq_reflection};
+val Pair_eq = @{thm Product_Type.prod.inject};
+val atomize_all = @{thm HOL.atomize_all};
+val atomize_imp = @{thm HOL.atomize_imp};
+val meta_allE = @{thm Pure.meta_allE};
+val prop_subst = @{thm prop_subst};
+val Pair_sel_convs = [fst_conv, snd_conv];
+val K_record_comp = @{thm K_record_comp};
val K_comp_convs = [@{thm o_apply}, K_record_comp]
+val transitive_thm = @{thm transitive};
+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}];
+val Not_eq_iff = @{thm Not_eq_iff};
+
+val refl_conj_eq = @{thm refl_conj_eq};
+val meta_all_sameI = @{thm meta_all_sameI};
+
+val surject_assistI = @{thm "istuple_surjective_proof_assistI"};
+val surject_assist_idE = @{thm "istuple_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 "istuple_update_accessor_eq_assist_idI"};
+val updacc_eq_triv = @{thm "istuple_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 "istuple_update_accessor_cong_from_eq"};
+
+val o_eq_dest = @{thm o_eq_dest};
+val o_eq_id_dest = @{thm o_eq_id_dest};
+val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
+
+
(** name components **)
@@ -73,6 +248,7 @@
val moreN = "more";
val schemeN = "_scheme";
val ext_typeN = "_ext_type";
+val inner_typeN = "_inner_type";
val extN ="_ext";
val casesN = "_cases";
val ext_dest = "_sel";
@@ -98,29 +274,29 @@
in map_type_tfree varify end;
fun domain_type' T =
- domain_type T handle Match => T;
+ domain_type T handle Match => T;
fun range_type' T =
- range_type T handle Match => T;
-
-
-(* messages *)
+ range_type T handle Match => T;
+
+
+(* messages *) (* FIXME proper context *)
fun trace_thm str thm =
- tracing (str ^ (Pretty.string_of (Display.pretty_thm_without_context thm)));
+ tracing (str ^ Pretty.string_of (Display.pretty_thm_without_context thm));
fun trace_thms str thms =
- (tracing str; map (trace_thm "") thms);
+ (tracing str; map (trace_thm "") thms);
fun trace_term str t =
- tracing (str ^ Syntax.string_of_term_global Pure.thy t);
+ tracing (str ^ Syntax.string_of_term_global Pure.thy t);
(* timing *)
-val timing = ref false;
-fun timeit_msg s x = if !timing then (warning s; timeit x) else x ();
-fun timing_msg s = if !timing then warning s else ();
+val timing = Unsynchronized.ref false;
+fun timeit_msg s x = if ! timing then (warning s; timeit x) else x ();
+fun timing_msg s = if ! timing then warning s else ();
(* syntax *)
@@ -146,54 +322,54 @@
fun mk_RepN name = suffix ext_typeN (prefix_base RepN name);
fun mk_AbsN name = suffix ext_typeN (prefix_base AbsN name);
-fun mk_Rep name repT absT =
- Const (suffix ext_typeN (prefix_base RepN name),absT --> repT);
+fun mk_Rep name repT absT =
+ Const (suffix ext_typeN (prefix_base RepN name), absT --> repT);
fun mk_Abs name repT absT =
- Const (mk_AbsN name,repT --> absT);
+ Const (mk_AbsN name, repT --> absT);
(* constructor *)
-fun mk_extC (name,T) Ts = (suffix extN name, Ts ---> T);
-
-fun mk_ext (name,T) ts =
+fun mk_extC (name, T) Ts = (suffix extN name, Ts ---> T);
+
+fun mk_ext (name, T) ts =
let val Ts = map fastype_of ts
- in list_comb (Const (mk_extC (name,T) Ts),ts) end;
+ in list_comb (Const (mk_extC (name, T) Ts), ts) end;
(* cases *)
-fun mk_casesC (name,T,vT) Ts = (suffix casesN name, (Ts ---> vT) --> T --> vT)
-
-fun mk_cases (name,T,vT) f =
+fun mk_casesC (name, T, vT) Ts = (suffix casesN name, (Ts ---> vT) --> T --> vT);
+
+fun mk_cases (name, T, vT) f =
let val Ts = binder_types (fastype_of f)
- in Const (mk_casesC (name,T,vT) Ts) $ f end;
+ in Const (mk_casesC (name, T, vT) Ts) $ f end;
(* selector *)
-fun mk_selC sT (c,T) = (c,sT --> T);
-
-fun mk_sel s (c,T) =
+fun mk_selC sT (c, T) = (c, sT --> T);
+
+fun mk_sel s (c, T) =
let val sT = fastype_of s
- in Const (mk_selC sT (c,T)) $ s end;
+ in Const (mk_selC sT (c, T)) $ s end;
(* updates *)
-fun mk_updC sfx sT (c,T) = (suffix sfx c, (T --> T) --> sT --> sT);
+fun mk_updC sfx sT (c, T) = (suffix sfx c, (T --> T) --> sT --> sT);
fun mk_upd' sfx c v sT =
let val vT = domain_type (fastype_of v);
- in Const (mk_updC sfx sT (c, vT)) $ v end;
-
-fun mk_upd sfx c v s = mk_upd' sfx c v (fastype_of s) $ s
+ in Const (mk_updC sfx sT (c, vT)) $ v end;
+
+fun mk_upd sfx c v s = mk_upd' sfx c v (fastype_of s) $ s;
(* types *)
-fun dest_recT (typ as Type (c_ext_type, Ts as (T::_))) =
+fun dest_recT (typ as Type (c_ext_type, Ts as (T :: _))) =
(case try (unsuffix ext_typeN) c_ext_type of
NONE => raise TYPE ("Record.dest_recT", [typ], [])
| SOME c => ((c, Ts), List.last Ts))
@@ -208,16 +384,17 @@
end handle TYPE _ => [];
fun last_extT T =
- let val ((c, Ts), U) = dest_recT T
- in (case last_extT U of
- NONE => SOME (c,Ts)
- | SOME l => SOME l)
- end handle TYPE _ => NONE
+ let val ((c, Ts), U) = dest_recT T in
+ (case last_extT U of
+ NONE => SOME (c, Ts)
+ | SOME l => SOME l)
+ end handle TYPE _ => NONE;
fun rec_id i T =
- let val rTs = dest_recTs T
- val rTs' = if i < 0 then rTs else Library.take (i,rTs)
- in Library.foldl (fn (s,(c,T)) => s ^ c) ("",rTs') end;
+ let
+ val rTs = dest_recTs T;
+ val rTs' = if i < 0 then rTs else Library.take (i, rTs);
+ in implode (map #1 rTs') end;
@@ -225,30 +402,31 @@
(** record info **)
-(* type record_info and parent_info *)
+(* type record_info and parent_info *)
type record_info =
{args: (string * sort) list,
parent: (typ list * string) option,
fields: (string * typ) list,
extension: (string * typ list),
- induct: thm
- };
-
-fun make_record_info args parent fields extension induct =
+ induct: thm,
+ extdef: thm};
+
+fun make_record_info args parent fields extension induct extdef =
{args = args, parent = parent, fields = fields, extension = extension,
- induct = induct}: record_info;
+ induct = induct, extdef = extdef}: record_info;
type parent_info =
{name: string,
fields: (string * typ) list,
extension: (string * typ list),
- induct: thm
-};
-
-fun make_parent_info name fields extension induct =
- {name = name, fields = fields, extension = extension, induct = induct}: parent_info;
+ induct: thm,
+ extdef: thm};
+
+fun make_parent_info name fields extension induct extdef =
+ {name = name, fields = fields, extension = extension,
+ induct = induct, extdef = extdef}: parent_info;
(* theory data *)
@@ -256,19 +434,21 @@
type record_data =
{records: record_info Symtab.table,
sel_upd:
- {selectors: unit Symtab.table,
+ {selectors: (int * bool) Symtab.table,
updates: string Symtab.table,
- simpset: Simplifier.simpset},
+ simpset: Simplifier.simpset,
+ defset: Simplifier.simpset,
+ foldcong: Simplifier.simpset,
+ unfoldcong: Simplifier.simpset},
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 *)
- extfields: (string*typ) list Symtab.table, (* maps extension to its fields *)
- fieldext: (string*typ list) Symtab.table (* maps field to its extension *)
-};
+ extsplit: thm Symtab.table, (*maps extension name to split rule*)
+ splits: (thm * thm * thm * thm) Symtab.table, (*!!, !, 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*)
fun make_record_data
- records sel_upd equalities extinjects extsplit splits extfields fieldext =
+ records sel_upd equalities extinjects extsplit splits extfields fieldext =
{records = records, sel_upd = sel_upd,
equalities = equalities, extinjects=extinjects, extsplit = extsplit, splits = splits,
extfields = extfields, fieldext = fieldext }: record_data;
@@ -278,14 +458,19 @@
type T = record_data;
val empty =
make_record_data Symtab.empty
- {selectors = Symtab.empty, updates = Symtab.empty, simpset = HOL_basic_ss}
+ {selectors = Symtab.empty, updates = Symtab.empty,
+ simpset = HOL_basic_ss, defset = HOL_basic_ss,
+ foldcong = HOL_basic_ss, unfoldcong = HOL_basic_ss}
Symtab.empty [] Symtab.empty Symtab.empty Symtab.empty Symtab.empty;
val copy = I;
val extend = I;
fun merge _
({records = recs1,
- sel_upd = {selectors = sels1, updates = upds1, simpset = ss1},
+ sel_upd =
+ {selectors = sels1, updates = upds1,
+ simpset = ss1, defset = ds1,
+ foldcong = fc1, unfoldcong = uc1},
equalities = equalities1,
extinjects = extinjects1,
extsplit = extsplit1,
@@ -293,7 +478,10 @@
extfields = extfields1,
fieldext = fieldext1},
{records = recs2,
- sel_upd = {selectors = sels2, updates = upds2, simpset = ss2},
+ sel_upd =
+ {selectors = sels2, updates = upds2,
+ simpset = ss2, defset = ds2,
+ foldcong = fc2, unfoldcong = uc2},
equalities = equalities2,
extinjects = extinjects2,
extsplit = extsplit2,
@@ -304,16 +492,18 @@
(Symtab.merge (K true) (recs1, recs2))
{selectors = Symtab.merge (K true) (sels1, sels2),
updates = Symtab.merge (K true) (upds1, upds2),
- simpset = Simplifier.merge_ss (ss1, ss2)}
+ simpset = Simplifier.merge_ss (ss1, ss2),
+ defset = Simplifier.merge_ss (ds1, ds2),
+ foldcong = Simplifier.merge_ss (fc1, fc2),
+ unfoldcong = Simplifier.merge_ss (uc1, uc2)}
(Symtab.merge Thm.eq_thm_prop (equalities1, equalities2))
(Library.merge Thm.eq_thm_prop (extinjects1, extinjects2))
- (Symtab.merge Thm.eq_thm_prop (extsplit1,extsplit2))
- (Symtab.merge (fn ((a,b,c,d),(w,x,y,z))
- => Thm.eq_thm (a,w) andalso Thm.eq_thm (b,x) andalso
- Thm.eq_thm (c,y) andalso Thm.eq_thm (d,z))
- (splits1, splits2))
- (Symtab.merge (K true) (extfields1,extfields2))
- (Symtab.merge (K true) (fieldext1,fieldext2));
+ (Symtab.merge Thm.eq_thm_prop (extsplit1, extsplit2))
+ (Symtab.merge (fn ((a, b, c, d), (w, x, y, z)) =>
+ Thm.eq_thm (a, w) andalso Thm.eq_thm (b, x) andalso
+ Thm.eq_thm (c, y) andalso Thm.eq_thm (d, z)) (splits1, splits2))
+ (Symtab.merge (K true) (extfields1, extfields2))
+ (Symtab.merge (K true) (fieldext1, fieldext2));
);
fun print_records thy =
@@ -342,8 +532,8 @@
fun put_record name info thy =
let
- val {records, sel_upd, equalities, extinjects,extsplit,splits,extfields,fieldext} =
- RecordsData.get thy;
+ val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
+ RecordsData.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;
@@ -355,41 +545,63 @@
val is_selector = Symtab.defined o #selectors o get_sel_upd;
val get_updates = Symtab.lookup o #updates o get_sel_upd;
-fun get_simpset thy = Simplifier.theory_context thy (#simpset (get_sel_upd thy));
-
-fun put_sel_upd names simps = RecordsData.map (fn {records,
- sel_upd = {selectors, updates, simpset},
- equalities, extinjects, extsplit, splits, extfields, fieldext} =>
- make_record_data records
- {selectors = fold (fn name => Symtab.update (name, ())) names selectors,
- updates = fold (fn name => Symtab.update ((suffix updateN) name, name)) names updates,
- simpset = Simplifier.addsimps (simpset, simps)}
- equalities extinjects extsplit splits extfields fieldext);
+fun get_ss_with_context getss thy = Simplifier.theory_context thy (getss (get_sel_upd thy));
+
+val get_simpset = get_ss_with_context #simpset;
+val get_sel_upd_defs = get_ss_with_context #defset;
+val get_foldcong_ss = get_ss_with_context #foldcong;
+val get_unfoldcong_ss = get_ss_with_context #unfoldcong;
+
+fun get_update_details u thy =
+ let val sel_upd = get_sel_upd thy in
+ (case Symtab.lookup (#updates sel_upd) u of
+ SOME s =>
+ let val SOME (dep, ismore) = Symtab.lookup (#selectors sel_upd) s
+ in SOME (s, dep, ismore) end
+ | NONE => NONE)
+ end;
+
+fun put_sel_upd names more depth simps defs (folds, unfolds) thy =
+ let
+ val all = names @ [more];
+ val sels = map (rpair (depth, false)) names @ [(more, (depth, true))];
+ 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;
+ val data = make_record_data records
+ {selectors = fold Symtab.update_new sels selectors,
+ updates = fold Symtab.update_new upds updates,
+ simpset = Simplifier.addsimps (simpset, simps),
+ defset = Simplifier.addsimps (defset, defs),
+ foldcong = foldcong addcongs folds,
+ unfoldcong = unfoldcong addcongs unfolds}
+ equalities extinjects extsplit splits extfields fieldext;
+ in RecordsData.put data thy end;
(* access 'equalities' *)
fun add_record_equalities name thm thy =
let
- val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields,fieldext} =
- RecordsData.get thy;
+ val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
+ RecordsData.get thy;
val data = make_record_data records sel_upd
- (Symtab.update_new (name, thm) equalities) extinjects extsplit
- splits extfields fieldext;
+ (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;
+val get_equalities = Symtab.lookup o #equalities o RecordsData.get;
(* access 'extinjects' *)
fun add_extinjects thm thy =
let
- val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields,fieldext} =
- RecordsData.get thy;
+ val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
+ RecordsData.get thy;
val data =
- make_record_data records sel_upd equalities (insert Thm.eq_thm_prop thm extinjects) extsplit
- splits extfields fieldext;
+ 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;
@@ -399,8 +611,8 @@
fun add_extsplit name thm thy =
let
- val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields,fieldext} =
- RecordsData.get thy;
+ 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;
@@ -413,8 +625,8 @@
fun add_record_splits name thmP thy =
let
- val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields,fieldext} =
- RecordsData.get thy;
+ 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;
@@ -433,37 +645,39 @@
fun add_extfields name fields 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 splits
- (Symtab.update_new (name, fields) extfields) fieldext;
+ val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
+ RecordsData.get thy;
+ val data =
+ 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;
fun get_extT_fields thy T =
let
- val ((name,Ts),moreT) = dest_recT T;
- val recname = let val (nm::recn::rst) = rev (Long_Name.explode name)
- in Long_Name.implode (rev (nm::rst)) end;
- val midx = maxidx_of_typs (moreT::Ts);
+ val ((name, Ts), moreT) = dest_recT T;
+ val recname =
+ let val (nm :: recn :: rst) = rev (Long_Name.explode name)
+ 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, ...} = RecordsData.get thy;
+ val (flds, (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;
+ in (flds', (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) =
- 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;
+ val (root_flds, (root_more, root_moreT)) = get_extT_fields thy T;
+ val (rest_flds, 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;
(* access 'fieldext' *)
@@ -471,14 +685,14 @@
fun add_fieldext extname_types fields thy =
let
val {records, sel_upd, equalities, extinjects, extsplit, splits, extfields, fieldext} =
- RecordsData.get thy;
+ RecordsData.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';
+ 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;
@@ -489,7 +703,7 @@
let
fun err msg = error (msg ^ " parent record " ^ quote name);
- val {args, parent, fields, extension, induct} =
+ val {args, parent, fields, extension, induct, extdef} =
(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 ();
@@ -505,7 +719,7 @@
val extension' = apsnd (map subst) extension;
in
add_parents thy parent'
- (make_parent_info name fields' extension' induct :: parents)
+ (make_parent_info name fields' extension' induct extdef :: parents)
end;
@@ -527,7 +741,7 @@
(* 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))
+ 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]);
@@ -547,87 +761,88 @@
(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 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 =
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) =
+ 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
+ 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 _ _ = ([],[]);
-
- fun mk_ext (fargs as (name,arg)::_) =
- (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
-
+ | splitargs [] (fargs as (_ :: _)) = ([], fargs)
+ | splitargs (_ :: _) [] = raise TERM (msg ^ "expecting more fields", [t])
+ | splitargs _ _ = ([], []);
+
+ fun mk_ext (fargs as (name, arg) :: _) =
+ (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
+ 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 _ _ = ([],[]);
-
- fun mk_ext (fargs as (name,arg)::_) =
- (case get_fieldext thy (Sign.intern_const thy name) of
- SOME (ext,alphas) =>
+ | splitargs [] (fargs as (_ :: _)) = ([], fargs)
+ | splitargs (_ :: _) [] = raise TERM (msg ^ "expecting more fields", [t])
+ | splitargs _ _ = ([], []);
+
+ fun mk_ext (fargs as (name, arg) :: _) =
+ (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;
- val argtypes = map (Sign.certify_typ thy o decode_type thy) args;
- val midx = fold (fn T => fn i => Int.max (maxidx_of_typ T, i))
- argtypes 0;
- val varifyT = varifyT midx;
- val vartypes = map varifyT types;
-
- val subst = fold (Sign.typ_match thy) (vartypes ~~ argtypes)
- Vartab.empty;
- 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_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]))
- | mk_ext [] = more
+ SOME flds =>
+ (let
+ val flds' = but_last flds;
+ val types = map snd flds';
+ val (args, rest) = splitargs (map fst flds') fargs;
+ val argtypes = map (Sign.certify_typ thy o decode_type thy) args;
+ val midx = fold (fn T => fn i => Int.max (maxidx_of_typ T, i)) argtypes 0;
+ val varifyT = varifyT midx;
+ val vartypes = map varifyT types;
+
+ val subst = fold (Sign.typ_match thy) (vartypes ~~ argtypes) Vartab.empty;
+ 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_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]))
+ | mk_ext [] = more;
in mk_ext fieldargs end;
@@ -648,54 +863,61 @@
| 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));
+ 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;
+ gen_adv_record_type_scheme_tr "_field_types" "_field_type" ext_typeN;
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)];
+ [("_record", adv_record_tr),
+ ("_record_scheme", adv_record_scheme_tr),
+ ("_record_type", adv_record_type_tr),
+ ("_record_type_scheme", adv_record_type_scheme_tr)];
(* print translations *)
-val print_record_type_abbr = ref true;
-val print_record_type_as_fields = ref true;
+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) =
- let val t = (case k of (Abs (_,_,(Abs (_,_,t)$Bound 0)))
- => if null (loose_bnos t) then t else raise Match
- | Abs (x,_,t) => if null (loose_bnos t) then t else raise Match
- | _ => raise Match)
-
- (* (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
- SOME name =>
- apfst (cons (Syntax.const mark $ Syntax.free name $ t)) (gen_field_upds_tr' mark sfx u)
- | NONE => ([], tm))
- end
+ let
+ val t =
+ (case k of
+ Abs (_, _, Abs (_, _, t) $ Bound 0) =>
+ if null (loose_bnos t) then t else raise Match
+ | Abs (x, _, 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
+ SOME name =>
+ apfst (cons (Syntax.const mark $ Syntax.free name $ t)) (gen_field_upds_tr' mark sfx u)
+ | NONE => ([], tm))
+ end
| gen_field_upds_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)
+ 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 =
@@ -705,95 +927,96 @@
fun record_tr' sep mark record record_scheme unit ctxt t =
let
val thy = ProofContext.theory_of ctxt;
+
fun field_lst t =
(case strip_comb t of
- (Const (ext,_),args as (_::_))
- => (case try (unsuffix extN) (Sign.intern_const thy ext) of
- SOME ext'
- => (case get_extfields thy ext' of
- SOME flds
- => (let
- val (f::fs) = but_last (map fst flds);
- val flds' = Sign.extern_const thy f :: map Long_Name.base_name fs;
- val (args',more) = split_last args;
- in (flds'~~args')@field_lst more end
- handle Library.UnequalLengths => [("",t)])
- | NONE => [("",t)])
- | NONE => [("",t)])
- | _ => [("",t)])
-
- val (flds,(_,more)) = split_last (field_lst t);
+ (Const (ext, _), args as (_ :: _)) =>
+ (case try (unsuffix extN) (Sign.intern_const thy ext) of
+ SOME ext' =>
+ (case get_extfields thy ext' of
+ SOME flds =>
+ (let
+ val f :: fs = but_last (map fst flds);
+ val flds' = Sign.extern_const thy f :: map Long_Name.base_name fs;
+ val (args', more) = split_last args;
+ in (flds' ~~ args') @ field_lst 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';
-
- in if unit more
- then Syntax.const record$flds''
- else Syntax.const record_scheme$flds''$more
- end
+ 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';
+ in
+ if unit more
+ then Syntax.const record $ flds''
+ else Syntax.const record_scheme $ flds'' $ more
+ end;
fun gen_record_tr' name =
- 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
+ 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' tries to reconstruct the record name type abbreviation from *)
-(* the (nested) extension types. *)
+(* record_type_abbr_tr' *)
+
+(*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 =
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.*)
-
- (* WORKAROUND:
- * If a record type occurs in an error message of type inference there
- * may be some internal frees donoted by ??:
- * (Const "_tfree",_)$Free ("??'a",_).
-
- * This will unfortunately be translated to Type ("??'a",[]) instead of
- * TFree ("??'a",_) by typ_of_term, which will confuse unify below.
- * fixT works around.
- *)
- fun fixT (T as Type (x,[])) =
- if String.isPrefix "??'" x then TFree (x,Sign.defaultS thy) else T
- | fixT (Type (x,xs)) = Type (x,map fixT xs)
- | fixT T = T;
-
- val T = fixT (decode_type thy tm);
- val midx = maxidx_of_typ T;
- val varifyT = varifyT midx;
-
- fun mk_type_abbr subst name alphas =
- let val abbrT = Type (name, map (fn a => varifyT (TFree (a, Sign.defaultS thy))) alphas);
- in Syntax.term_of_typ (! Syntax.show_sorts)
- (Sign.extern_typ thy (Envir.norm_type subst abbrT)) end;
-
- fun match rT T = (Sign.typ_match thy (varifyT rT,T)
- Vartab.empty);
-
- in
- if !print_record_type_abbr then
- (case last_extT T of
- SOME (name, _) =>
+ 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*)
+
+ (*WORKAROUND:
+ If a record type occurs in an error message of type inference there
+ may be some internal frees donoted by ??:
+ (Const "_tfree",_) $ Free ("??'a", _).
+
+ This will unfortunately be translated to Type ("??'a", []) instead of
+ TFree ("??'a", _) by typ_of_term, which will confuse unify below.
+ fixT works around.*)
+ fun fixT (T as Type (x, [])) =
+ if String.isPrefix "??'" x then TFree (x, Sign.defaultS thy) else T
+ | fixT (Type (x, xs)) = Type (x, map fixT xs)
+ | fixT T = T;
+
+ val T = fixT (decode_type thy tm);
+ val midx = maxidx_of_typ T;
+ val varifyT = varifyT midx;
+
+ fun mk_type_abbr subst name alphas =
+ let val abbrT = Type (name, map (fn a => varifyT (TFree (a, Sign.defaultS thy))) alphas) in
+ Syntax.term_of_typ (! Syntax.show_sorts)
+ (Sign.extern_typ thy (Envir.norm_type subst abbrT))
+ end;
+
+ fun match rT T = Sign.typ_match thy (varifyT rT, T) Vartab.empty;
+ in
+ if ! print_record_type_abbr then
+ (case last_extT T of
+ SOME (name, _) =>
if name = lastExt then
- (let
- val subst = match schemeT T
- in
+ (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_MATCH => default_tr' ctxt tm)
- else raise Match (* give print translation of specialised record a chance *)
- | _ => raise Match)
- else default_tr' ctxt tm
- end
+ end handle TYPE_MATCH => default_tr' ctxt tm)
+ else raise Match (*give print translation of specialised record a chance*)
+ | _ => raise Match)
+ else default_tr' ctxt tm
+ end;
fun record_type_tr' sep mark record record_scheme ctxt t =
let
@@ -802,510 +1025,524 @@
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 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_MATCH => [("", T)]
- | Library.UnequalLengths => [("", T)])
- | NONE => [("", T)])
- | NONE => [("", T)])
- | NONE => [("", T)])
- | _ => [("", T)])
+ 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_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
+ 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 =
- let val name_sfx = 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
+ let
+ val name_sfx = 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))
+ 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 simprocs **)
-val record_quick_and_dirty_sensitive = ref false;
+val record_quick_and_dirty_sensitive = Unsynchronized.ref false;
fun quick_and_dirty_prove stndrd thy asms prop tac =
- if !record_quick_and_dirty_sensitive andalso !quick_and_dirty
- then Goal.prove (ProofContext.init thy) [] []
- (Logic.list_implies (map Logic.varify asms,Logic.varify prop))
- (K (SkipProof.cheat_tac @{theory HOL}))
- (* standard can take quite a while for large records, thats why
- * we varify the proposition manually here.*)
- else let val prf = Goal.prove (ProofContext.init thy) [] asms prop tac;
- in if stndrd then standard prf else prf end;
+ if ! record_quick_and_dirty_sensitive andalso ! quick_and_dirty then
+ Goal.prove (ProofContext.init thy) [] []
+ (Logic.list_implies (map Logic.varify asms, Logic.varify prop))
+ (K (SkipProof.cheat_tac @{theory HOL}))
+ (*Drule.standard can take quite a while for large records, thats why
+ we varify the proposition manually here.*)
+ else
+ let val prf = Goal.prove (ProofContext.init thy) [] asms prop tac
+ in if stndrd then standard prf else prf end;
fun quick_and_dirty_prf noopt opt () =
- if !record_quick_and_dirty_sensitive andalso !quick_and_dirty
- then noopt ()
- else opt ();
-
-local
-fun abstract_over_fun_app (Abs (f,fT,t)) =
+ if ! record_quick_and_dirty_sensitive andalso ! quick_and_dirty
+ then noopt ()
+ else opt ();
+
+fun is_sel_upd_pair thy (Const (s, t)) (Const (u, t')) =
+ (case get_updates thy u of
+ SOME u_name => u_name = s
+ | NONE => raise TERM ("is_sel_upd_pair: not update", [Const (u, t')]));
+
+fun mk_comp f g =
+ let
+ val x = fastype_of g;
+ val a = domain_type x;
+ 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;
+
+fun mk_comp_id f =
+ let val T = range_type (fastype_of f)
+ in mk_comp (Const ("Fun.id", T --> T)) f end;
+
+fun get_upd_funs (upd $ _ $ t) = upd :: get_upd_funs t
+ | get_upd_funs _ = [];
+
+fun get_accupd_simps thy term defset intros_tac =
let
- val (f',t') = Term.dest_abs (f,fT,t);
- val T = domain_type fT;
- val (x,T') = hd (Term.variant_frees t' [("x",T)]);
- val f_x = Free (f',fT)$(Free (x,T'));
- fun is_constr (Const (c,_)$_) = can (unsuffix extN) c
- | is_constr _ = false;
- fun subst (t as u$w) = if Free (f',fT)=u
- then if is_constr w then f_x
- else raise TERM ("abstract_over_fun_app",[t])
- else subst u$subst w
- | subst (Abs (x,T,t)) = (Abs (x,T,subst t))
- | subst t = t
- val t'' = abstract_over (f_x,subst t');
- val vars = strip_qnt_vars "all" t'';
- val bdy = strip_qnt_body "all" t'';
-
- in list_abs ((x,T')::vars,bdy) end
- | abstract_over_fun_app t = raise TERM ("abstract_over_fun_app",[t]);
-(* Generates a theorem of the kind:
- * !!f x*. PROP P (f ( r x* ) x* == !!r x*. PROP P r x*
- *)
-fun mk_fun_apply_eq (Abs (f, fT, t)) thy =
+ val (acc, [body]) = strip_comb term;
+ val recT = domain_type (fastype_of acc);
+ val upd_funs = sort_distinct TermOrd.fast_term_ord (get_upd_funs body);
+ fun get_simp upd =
+ let
+ val T = domain_type (fastype_of upd);
+ val lhs = mk_comp acc (upd $ Free ("f", T));
+ val rhs =
+ if is_sel_upd_pair thy acc upd
+ then mk_comp (Free ("f", T)) acc
+ else mk_comp_id acc;
+ val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
+ val othm =
+ Goal.prove (ProofContext.init thy) [] [] prop
+ (fn prems =>
+ EVERY
+ [simp_tac defset 1,
+ REPEAT_DETERM (intros_tac 1),
+ TRY (simp_tac (HOL_ss addsimps id_o_apps) 1)]);
+ val dest =
+ if is_sel_upd_pair thy acc upd
+ then o_eq_dest
+ else o_eq_id_dest;
+ in standard (othm RS dest) end;
+ in map get_simp upd_funs end;
+
+fun get_updupd_simp thy defset intros_tac u u' comp =
let
- val rT = domain_type fT;
- val vars = Term.strip_qnt_vars "all" t;
- val Ts = map snd vars;
- val n = length vars;
- fun app_bounds 0 t = t$Bound 0
- | app_bounds n t = if n > 0 then app_bounds (n-1) (t$Bound n) else t
-
-
- val [P,r] = Term.variant_frees t [("P",rT::Ts--->Term.propT),("r",Ts--->rT)];
- val prop = Logic.mk_equals
- (list_all ((f,fT)::vars,
- app_bounds (n - 1) ((Free P)$(Bound n$app_bounds (n-1) (Free r)))),
- list_all ((fst r,rT)::vars,
- app_bounds (n - 1) ((Free P)$Bound n)));
- val prove_standard = quick_and_dirty_prove true thy;
- val thm = prove_standard [] prop (fn _ =>
- EVERY [rtac equal_intr_rule 1,
- Goal.norm_hhf_tac 1,REPEAT (etac meta_allE 1), atac 1,
- Goal.norm_hhf_tac 1,REPEAT (etac meta_allE 1), atac 1]);
- in thm end
- | mk_fun_apply_eq t thy = raise TERM ("mk_fun_apply_eq",[t]);
-
-in
-(* During proof of theorems produced by record_simproc you can end up in
- * situations like "!!f ... . ... f r ..." where f is an extension update function.
- * In order to split "f r" we transform this to "!!r ... . ... r ..." so that the
- * usual split rules for extensions can apply.
- *)
-val record_split_f_more_simproc =
- Simplifier.simproc @{theory HOL} "record_split_f_more_simp" ["x"]
- (fn thy => fn _ => fn t =>
- (case t of (Const ("all", Type (_, [Type (_, [Type("fun",[T,T']), _]), _])))$
- (trm as Abs _) =>
- (case rec_id (~1) T of
- "" => NONE
- | n => if T=T'
- then (let
- val P=cterm_of thy (abstract_over_fun_app trm);
- val thm = mk_fun_apply_eq trm thy;
- val PV = cterm_of thy (hd (OldTerm.term_vars (prop_of thm)));
- val thm' = cterm_instantiate [(PV,P)] thm;
- in SOME thm' end handle TERM _ => NONE)
- else NONE)
- | _ => NONE))
-end
-
-fun prove_split_simp thy ss T prop =
+ 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');
+ val rhs =
+ if comp
+ then u $ mk_comp f f'
+ else mk_comp (u' $ f') (u $ f);
+ val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
+ val othm =
+ Goal.prove (ProofContext.init thy) [] [] prop
+ (fn prems =>
+ EVERY
+ [simp_tac defset 1,
+ REPEAT_DETERM (intros_tac 1),
+ TRY (simp_tac (HOL_ss addsimps [id_apply]) 1)]);
+ val dest = if comp then o_eq_dest_lhs else o_eq_dest;
+ in standard (othm RS dest) end;
+
+fun get_updupd_simps thy term defset intros_tac =
let
- val {sel_upd={simpset,...},extsplit,...} = RecordsData.get thy;
- val extsplits =
- Library.foldl (fn (thms,(n,_)) => the_list (Symtab.lookup extsplit n) @ thms)
- ([],dest_recTs T);
- val thms = (case get_splits thy (rec_id (~1) T) of
- SOME (all_thm,_,_,_) =>
- all_thm::(case extsplits of [thm] => [] | _ => extsplits)
- (* [thm] is the same as all_thm *)
- | NONE => extsplits)
- val thms'=K_comp_convs@thms;
- val ss' = (Simplifier.inherit_context ss simpset
- addsimps thms'
- addsimprocs [record_split_f_more_simproc]);
+ val recT = fastype_of term;
+ val upd_funs = get_upd_funs term;
+ val cname = fst o dest_Const;
+ fun getswap u u' = get_updupd_simp thy defset intros_tac u u' (cname u = cname u');
+ fun build_swaps_to_eq upd [] swaps = swaps
+ | build_swaps_to_eq upd (u :: us) swaps =
+ let
+ val key = (cname u, cname upd);
+ val newswaps =
+ if Symreltab.defined swaps key then swaps
+ else Symreltab.insert (K true) (key, getswap u upd) swaps;
+ in
+ if cname u = cname upd then newswaps
+ else build_swaps_to_eq upd us newswaps
+ end;
+ fun swaps_needed [] prev seen swaps = map snd (Symreltab.dest swaps)
+ | swaps_needed (u :: us) prev seen swaps =
+ if Symtab.defined seen (cname u)
+ then swaps_needed us prev seen (build_swaps_to_eq u prev swaps)
+ else swaps_needed us (u :: prev) (Symtab.insert (K true) (cname u, ()) seen) swaps;
+ in swaps_needed upd_funs [] Symtab.empty Symreltab.empty end;
+
+val named_cterm_instantiate = IsTupleSupport.named_cterm_instantiate;
+
+fun prove_unfold_defs thy ss T ex_simps ex_simprs prop =
+ let
+ val defset = get_sel_upd_defs thy;
+ val in_tac = IsTupleSupport.istuple_intros_tac thy;
+ val prop' = Envir.beta_eta_contract prop;
+ val (lhs, rhs) = Logic.dest_equals (Logic.strip_assums_concl prop');
+ val (head, args) = strip_comb lhs;
+ val simps =
+ if length args = 1
+ then get_accupd_simps thy lhs defset in_tac
+ else get_updupd_simps thy lhs defset in_tac;
in
- quick_and_dirty_prove true thy [] prop (fn _ => simp_tac ss' 1)
+ Goal.prove (ProofContext.init thy) [] [] prop'
+ (fn prems =>
+ simp_tac (HOL_basic_ss addsimps (simps @ [K_record_comp])) 1 THEN
+ TRY (simp_tac (HOL_basic_ss addsimps ex_simps addsimprocs ex_simprs) 1))
end;
local
-fun eq (s1:string) (s2:string) = (s1 = s2);
+
+fun eq (s1: string) (s2: string) = (s1 = s2);
+
fun has_field extfields f T =
- exists (fn (eN,_) => exists (eq f o fst) (Symtab.lookup_list extfields eN))
- (dest_recTs T);
-
-fun K_skeleton n (T as Type (_,[_,kT])) (b as Bound i) (Abs (x,xT,t)) =
- if null (loose_bnos t) then ((n,kT),(Abs (x,xT,Bound (i+1)))) else ((n,T),b)
- | K_skeleton n T b _ = ((n,T),b);
+ exists (fn (eN, _) => exists (eq f o fst) (Symtab.lookup_list extfields eN)) (dest_recTs T);
+
+fun K_skeleton n (T as Type (_, [_, kT])) (b as Bound i) (Abs (x, xT, t)) =
+ if null (loose_bnos t) then ((n, kT), (Abs (x, xT, Bound (i + 1)))) else ((n, T), b)
+ | K_skeleton n T b _ = ((n, T), b);
+
+in
+
+(* record_simproc *)
(*
-fun K_skeleton n _ b ((K_rec as Const ("Record.K_record",Type (_,[kT,_])))$_) =
- ((n,kT),K_rec$b)
- | K_skeleton n _ (Bound i)
- (Abs (x,T,(K_rec as Const ("Record.K_record",Type (_,[kT,_])))$_$Bound 0)) =
- ((n,kT),Abs (x,T,(K_rec$Bound (i+1)$Bound 0)))
- | K_skeleton n T b _ = ((n,T),b);
- *)
-
-fun normalize_rhs thm =
- let
- val ss = HOL_basic_ss addsimps K_comp_convs;
- val rhs = thm |> Thm.cprop_of |> Thm.dest_comb |> snd;
- val rhs' = (Simplifier.rewrite ss rhs);
- in Thm.transitive thm rhs' end;
-in
-(* record_simproc *)
-(* Simplifies selections of an record update:
- * (1) S (S_update k r) = k (S r)
- * (2) S (X_update k r) = S r
- * The simproc skips multiple updates at once, eg:
- * S (X_update x (Y_update y (S_update k r))) = k (S r)
- * But be careful in (2) because of the extendibility of records.
- * - If S is a more-selector we have to make sure that the update on component
- * X does not affect the selected subrecord.
- * - If X is a more-selector we have to make sure that S is not in the updated
- * subrecord.
- *)
+ Simplify selections of an record update:
+ (1) S (S_update k r) = k (S r)
+ (2) S (X_update k r) = S r
+
+ The simproc skips multiple updates at once, eg:
+ S (X_update x (Y_update y (S_update k r))) = k (S r)
+
+ But be careful in (2) because of the extensibility of records.
+ - If S is a more-selector we have to make sure that the update on component
+ X does not affect the selected subrecord.
+ - If X is a more-selector we have to make sure that S is not in the updated
+ subrecord.
+*)
val record_simproc =
Simplifier.simproc @{theory HOL} "record_simp" ["x"]
(fn thy => fn ss => fn t =>
- (case t of (sel as Const (s, Type (_,[domS,rangeS])))$
- ((upd as Const (u,Type(_,[_,Type (_,[rT,_])]))) $ k $ r)=>
- if is_selector thy s then
- (case get_updates thy u of SOME u_name =>
- let
- val {sel_upd={updates,...},extfields,...} = RecordsData.get thy;
-
- fun mk_eq_terms ((upd as Const (u,Type(_,[kT,_]))) $ k $ r) =
- (case Symtab.lookup updates u of
- NONE => NONE
- | SOME u_name
- => if u_name = s
- then (case mk_eq_terms r of
- NONE =>
- let
- val rv = ("r",rT)
- val rb = Bound 0
- val (kv,kb) = K_skeleton "k" kT (Bound 1) k;
- in SOME (upd$kb$rb,kb$(sel$rb),[kv,rv]) end
- | SOME (trm,trm',vars) =>
- let
- val (kv,kb) = K_skeleton "k" kT (Bound (length vars)) k;
- in SOME (upd$kb$trm,kb$trm',kv::vars) end)
- else if has_field extfields u_name rangeS
- orelse has_field extfields s (domain_type kT)
- then NONE
- else (case mk_eq_terms r of
- SOME (trm,trm',vars)
- => let
- val (kv,kb) =
- K_skeleton "k" kT (Bound (length vars)) k;
- in SOME (upd$kb$trm,trm',kv::vars) end
- | NONE
- => let
- val rv = ("r",rT)
- val rb = Bound 0
- val (kv,kb) = K_skeleton "k" kT (Bound 1) k;
- in SOME (upd$kb$rb,sel$rb,[kv,rv]) end))
- | mk_eq_terms r = NONE
- in
- (case mk_eq_terms (upd$k$r) of
- SOME (trm,trm',vars)
- => SOME (prove_split_simp thy ss domS
- (list_all(vars, Logic.mk_equals (sel $ trm, trm'))))
- | NONE => NONE)
- end
- | NONE => NONE)
- else NONE
+ (case t of
+ (sel as Const (s, Type (_, [domS, rangeS]))) $
+ ((upd as Const (u, Type (_, [_, Type (_, [rT, _])]))) $ k $ r) =>
+ if is_selector thy s then
+ (case get_updates thy u of
+ SOME u_name =>
+ let
+ val {sel_upd = {updates, ...}, extfields, ...} = RecordsData.get thy;
+
+ fun mk_eq_terms ((upd as Const (u, Type(_, [kT, _]))) $ k $ r) =
+ (case Symtab.lookup updates u of
+ NONE => NONE
+ | SOME u_name =>
+ if u_name = s then
+ (case mk_eq_terms r of
+ NONE =>
+ let
+ val rv = ("r", rT);
+ val rb = Bound 0;
+ val (kv, kb) = K_skeleton "k" kT (Bound 1) k;
+ in SOME (upd $ kb $ rb, kb $ (sel $ rb), [kv, rv]) end
+ | SOME (trm, trm', vars) =>
+ let
+ val (kv, kb) = K_skeleton "k" kT (Bound (length vars)) k;
+ in SOME (upd $ kb $ trm, kb $ trm', kv :: vars) end)
+ else if has_field extfields u_name rangeS orelse
+ has_field extfields s (domain_type kT) then NONE
+ else
+ (case mk_eq_terms r of
+ SOME (trm, trm', vars) =>
+ let val (kv, kb) = K_skeleton "k" kT (Bound (length vars)) k
+ in SOME (upd $ kb $ trm, trm', kv :: vars) end
+ | NONE =>
+ let
+ val rv = ("r", rT);
+ val rb = Bound 0;
+ val (kv, kb) = K_skeleton "k" kT (Bound 1) k;
+ in SOME (upd $ kb $ rb, sel $ rb, [kv, rv]) end))
+ | mk_eq_terms r = NONE;
+ in
+ (case mk_eq_terms (upd $ k $ r) of
+ SOME (trm, trm', vars) =>
+ SOME
+ (prove_unfold_defs thy ss domS [] []
+ (list_all (vars, Logic.mk_equals (sel $ trm, trm'))))
+ | NONE => NONE)
+ end
+ | NONE => NONE)
+ else NONE
| _ => NONE));
+fun get_upd_acc_cong_thm upd acc thy simpset =
+ let
+ val in_tac = IsTupleSupport.istuple_intros_tac thy;
+
+ val insts = [("upd", cterm_of thy upd), ("acc", cterm_of thy acc)]
+ val prop = concl_of (named_cterm_instantiate insts updacc_cong_triv);
+ in
+ Goal.prove (ProofContext.init thy) [] [] prop
+ (fn prems =>
+ EVERY
+ [simp_tac simpset 1,
+ REPEAT_DETERM (in_tac 1),
+ TRY (resolve_tac [updacc_cong_idI] 1)])
+ end;
+
+
(* record_upd_simproc *)
-(* simplify multiple updates:
- * (1) "N_update y (M_update g (N_update x (M_update f r))) =
+
+(*Simplify multiple updates:
+ (1) "N_update y (M_update g (N_update x (M_update f r))) =
(N_update (y o x) (M_update (g o f) r))"
- * (2) "r(|M:= M r|) = r"
- * For (2) special care of "more" updates has to be taken:
- * r(|more := m; A := A r|)
- * If A is contained in the fields of m we cannot remove the update A := A r!
- * (But r(|more := r; A := A (r(|more := r|))|) = r(|more := r|)
-*)
+ (2) "r(|M:= M r|) = r"
+
+ In both cases "more" updates complicate matters: for this reason
+ we omit considering further updates if doing so would introduce
+ both a more update and an update to a field within it.*)
val record_upd_simproc =
Simplifier.simproc @{theory HOL} "record_upd_simp" ["x"]
(fn thy => fn ss => fn t =>
- (case t of ((upd as Const (u, Type(_,[_,Type(_,[rT,_])]))) $ k $ r) =>
- let datatype ('a,'b) calc = Init of 'b | Inter of 'a
- val {sel_upd={selectors,updates,...},extfields,...} = RecordsData.get thy;
-
- (*fun mk_abs_var x t = (x, fastype_of t);*)
- fun sel_name u = Long_Name.base_name (unsuffix updateN u);
-
- fun seed s (upd as Const (more,Type(_,[mT,_]))$ k $ r) =
- if has_field extfields s (domain_type' mT) then upd else seed s r
- | seed _ r = r;
-
- fun grow u uT k kT vars (sprout,skeleton) =
- if sel_name u = moreN
- then let val (kv,kb) = K_skeleton "k" kT (Bound (length vars)) k;
- in ((Const (u,uT)$k$sprout,Const (u,uT)$kb$skeleton),kv::vars) end
- else ((sprout,skeleton),vars);
-
-
- fun dest_k (Abs (x,T,((sel as Const (s,_))$r))) =
- if null (loose_bnos r) then SOME (x,T,sel,s,r) else NONE
- | dest_k (Abs (_,_,(Abs (x,T,((sel as Const (s,_))$r)))$Bound 0)) =
- (* eta expanded variant *)
- if null (loose_bnos r) then SOME (x,T,sel,s,r) else NONE
- | dest_k _ = NONE;
-
- fun is_upd_same (sprout,skeleton) u k =
- (case dest_k k of SOME (x,T,sel,s,r) =>
- if (unsuffix updateN u) = s andalso (seed s sprout) = r
- then SOME (fn t => Abs (x,T,incr_boundvars 1 t),sel,seed s skeleton)
- else NONE
- | NONE => NONE);
-
- fun init_seed r = ((r,Bound 0), [("r", rT)]);
-
- fun add (n:string) f fmaps =
- (case AList.lookup (op =) fmaps n of
- NONE => AList.update (op =) (n,[f]) fmaps
- | SOME fs => AList.update (op =) (n,f::fs) fmaps)
-
- fun comps (n:string) T fmaps =
- (case AList.lookup (op =) fmaps n of
- SOME fs =>
- foldr1 (fn (f,g) => Const ("Fun.comp",(T-->T)-->(T-->T)-->(T-->T))$f$g) fs
- | NONE => error ("record_upd_simproc.comps"))
-
- (* mk_updterm returns either
- * - Init (orig-term, orig-term-skeleton, vars) if no optimisation can be made,
- * where vars are the bound variables in the skeleton
- * - Inter (orig-term-skeleton,simplified-term-skeleton,
- * vars, (term-sprout, skeleton-sprout))
- * where "All vars. orig-term-skeleton = simplified-term-skeleton" is
- * the desired simplification rule,
- * the sprouts accumulate the "more-updates" on the way from the seed
- * to the outermost update. It is only relevant to calculate the
- * possible simplification for (2)
- * The algorithm first walks down the updates to the seed-record while
- * memorising the updates in the already-table. While walking up the
- * updates again, the optimised term is constructed.
- *)
- fun mk_updterm upds already
- (t as ((upd as Const (u,uT as (Type (_,[kT,_])))) $ k $ r)) =
- if Symtab.defined upds u
- then let
- fun rest already = mk_updterm upds already
- in if u mem_string already
- then (case (rest already r) of
- Init ((sprout,skel),vars) =>
- let
- val n = sel_name u;
- val (kv,kb) = K_skeleton n kT (Bound (length vars)) k;
- val (sprout',vars')= grow u uT k kT (kv::vars) (sprout,skel);
- in Inter (upd$kb$skel,skel,vars',add n kb [],sprout') end
- | Inter (trm,trm',vars,fmaps,sprout) =>
- let
- val n = sel_name u;
- val (kv,kb) = K_skeleton n kT (Bound (length vars)) k;
- val (sprout',vars') = grow u uT k kT (kv::vars) sprout;
- in Inter(upd$kb$trm,trm',kv::vars',add n kb fmaps,sprout')
- end)
- else
- (case rest (u::already) r of
- Init ((sprout,skel),vars) =>
- (case is_upd_same (sprout,skel) u k of
- SOME (K_rec,sel,skel') =>
- let
- val (sprout',vars') = grow u uT k kT vars (sprout,skel);
- in Inter(upd$(K_rec (sel$skel'))$skel,skel,vars',[],sprout')
- end
- | NONE =>
- let
- val n = sel_name u;
- val (kv,kb) = K_skeleton n kT (Bound (length vars)) k;
- in Init ((upd$k$sprout,upd$kb$skel),kv::vars) end)
- | Inter (trm,trm',vars,fmaps,sprout) =>
- (case is_upd_same sprout u k of
- SOME (K_rec,sel,skel) =>
- let
- val (sprout',vars') = grow u uT k kT vars sprout
- in Inter(upd$(K_rec (sel$skel))$trm,trm',vars',fmaps,sprout')
- end
- | NONE =>
- let
- val n = sel_name u
- val T = domain_type kT
- val (kv,kb) = K_skeleton n kT (Bound (length vars)) k;
- val (sprout',vars') = grow u uT k kT (kv::vars) sprout
- val fmaps' = add n kb fmaps
- in Inter (upd$kb$trm,upd$comps n T fmaps'$trm'
- ,vars',fmaps',sprout') end))
- end
- else Init (init_seed t)
- | mk_updterm _ _ t = Init (init_seed t);
-
- in (case mk_updterm updates [] t of
- Inter (trm,trm',vars,_,_)
- => SOME (normalize_rhs
- (prove_split_simp thy ss rT
- (list_all(vars, Logic.mk_equals (trm, trm')))))
- | _ => NONE)
- end
- | _ => NONE))
-end
+ let
+ (*We can use more-updators with other updators as long
+ as none of the other updators go deeper than any more
+ updator. min here is the depth of the deepest other
+ updator, max the depth of the shallowest more updator.*)
+ fun include_depth (dep, true) (min, max) =
+ if min <= dep
+ then SOME (min, if dep <= max orelse max = ~1 then dep else max)
+ else NONE
+ | include_depth (dep, false) (min, max) =
+ if dep <= max orelse max = ~1
+ then SOME (if min <= dep then dep else min, max)
+ else NONE;
+
+ fun getupdseq (term as (upd as Const (u, T)) $ f $ tm) min max =
+ (case get_update_details u thy of
+ SOME (s, dep, ismore) =>
+ (case include_depth (dep, ismore) (min, max) of
+ SOME (min', max') =>
+ let val (us, bs, _) = getupdseq tm min' max'
+ in ((upd, s, f) :: us, bs, fastype_of term) end
+ | NONE => ([], term, HOLogic.unitT))
+ | NONE => ([], term, HOLogic.unitT))
+ | getupdseq term _ _ = ([], term, HOLogic.unitT);
+
+ val (upds, base, baseT) = getupdseq t 0 ~1;
+
+ fun is_upd_noop s (f as Abs (n, T, Const (s', T') $ tm')) tm =
+ if s = s' andalso null (loose_bnos tm')
+ andalso subst_bound (HOLogic.unit, tm') = tm
+ then (true, Abs (n, T, Const (s', T') $ Bound 1))
+ else (false, HOLogic.unit)
+ | is_upd_noop s f tm = (false, HOLogic.unit);
+
+ fun get_noop_simps (upd as Const (u, T))
+ (f as Abs (n, T', (acc as Const (s, T'')) $ _)) =
+ let
+ val ss = get_sel_upd_defs thy;
+ val uathm = get_upd_acc_cong_thm upd acc thy ss;
+ in
+ [standard (uathm RS updacc_noopE), standard (uathm RS updacc_noop_compE)]
+ end;
+
+ (*If f is constant then (f o g) = f. we know that K_skeleton
+ only returns constant abstractions thus when we see an
+ abstraction we can discard inner updates.*)
+ fun add_upd (f as Abs _) fs = [f]
+ | add_upd f fs = (f :: fs);
+
+ (*mk_updterm returns
+ (orig-term-skeleton, simplified-skeleton,
+ variables, duplicate-updates, simp-flag, noop-simps)
+
+ where duplicate-updates is a table used to pass upward
+ the list of update functions which can be composed
+ into an update above them, simp-flag indicates whether
+ any simplification was achieved, and noop-simps are
+ used for eliminating case (2) defined above*)
+ fun mk_updterm ((upd as Const (u, T), s, f) :: upds) above term =
+ let
+ val (lhs, rhs, vars, dups, simp, noops) =
+ mk_updterm upds (Symtab.update (u, ()) above) term;
+ val (fvar, skelf) =
+ 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';
+ in
+ if isnoop then
+ (upd $ skelf' $ lhs, rhs, vars,
+ Symtab.update (u, []) dups, true,
+ if Symtab.defined noops u then noops
+ else Symtab.update (u, get_noop_simps upd skelf') noops)
+ else if Symtab.defined above u then
+ (upd $ skelf $ lhs, rhs, fvar :: vars,
+ Symtab.map_default (u, []) (add_upd skelf) dups,
+ true, noops)
+ else
+ (case Symtab.lookup dups u of
+ SOME fs =>
+ (upd $ skelf $ lhs,
+ upd $ foldr1 mk_comp_local (add_upd skelf fs) $ rhs,
+ fvar :: vars, dups, true, noops)
+ | NONE => (upd $ skelf $ lhs, upd $ skelf $ rhs, fvar :: vars, dups, simp, noops))
+ end
+ | mk_updterm [] above term =
+ (Bound 0, Bound 0, [("r", baseT)], Symtab.empty, false, Symtab.empty)
+ | mk_updterm us above term =
+ raise TERM ("mk_updterm match", map (fn (x, y, z) => x) us);
+
+ val (lhs, rhs, vars, dups, simp, noops) = mk_updterm upds Symtab.empty base;
+ val noops' = flat (map snd (Symtab.dest noops));
+ in
+ if simp then
+ SOME
+ (prove_unfold_defs thy ss baseT noops' [record_simproc]
+ (list_all (vars, Logic.mk_equals (lhs, rhs))))
+ else NONE
+ end);
+
+end;
+
(* record_eq_simproc *)
-(* looks up the most specific record-equality.
- * Note on efficiency:
- * Testing equality of records boils down to the test of equality of all components.
- * Therefore the complexity is: #components * complexity for single component.
- * Especially if a record has a lot of components it may be better to split up
- * the record first and do simplification on that (record_split_simp_tac).
- * e.g. r(|lots of updates|) = x
- *
- * record_eq_simproc record_split_simp_tac
- * Complexity: #components * #updates #updates
- *
- *)
+
+(*Looks up the most specific record-equality.
+
+ Note on efficiency:
+ Testing equality of records boils down to the test of equality of all components.
+ Therefore the complexity is: #components * complexity for single component.
+ Especially if a record has a lot of components it may be better to split up
+ the record first and do simplification on that (record_split_simp_tac).
+ e.g. r(|lots of updates|) = x
+
+ record_eq_simproc record_split_simp_tac
+ Complexity: #components * #updates #updates
+*)
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 rec_id (~1) T of
- "" => NONE
- | name => (case get_equalities thy name of
- NONE => NONE
- | SOME thm => SOME (thm RS Eq_TrueI)))
- | _ => NONE));
+ (case rec_id ~1 T of
+ "" => NONE
+ | name =>
+ (case get_equalities thy name of
+ NONE => NONE
+ | SOME thm => SOME (thm RS Eq_TrueI)))
+ | _ => NONE));
+
(* record_split_simproc *)
-(* splits quantified occurrences of records, for which P holds. P can peek on the
- * subterm starting at the quantified occurrence of the record (including the quantifier)
- * P t = 0: do not split
- * P t = ~1: completely split
- * P t > 0: split up to given bound of record extensions
- *)
+
+(*Split quantified occurrences of records, for which P holds. P can peek on the
+ subterm starting at the quantified occurrence of the record (including the quantifier):
+ P t = 0: do not split
+ P t = ~1: completely split
+ P t > 0: split up to given bound of record extensions.*)
fun record_split_simproc P =
Simplifier.simproc @{theory HOL} "record_split_simp" ["x"]
(fn thy => fn _ => fn t =>
- (case t of (Const (quantifier, Type (_, [Type (_, [T, _]), _])))$trm =>
- if quantifier = "All" orelse quantifier = "all" orelse quantifier = "Ex"
- then (case rec_id (~1) T of
- "" => NONE
- | name
- => let val split = P t
- in if split <> 0 then
- (case get_splits thy (rec_id split T) of
- NONE => NONE
- | 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
- | _ => error "record_split_simproc"))
- else NONE
- end)
- else NONE
- | _ => NONE))
+ (case t of
+ Const (quantifier, Type (_, [Type (_, [T, _]), _])) $ trm =>
+ if quantifier = "All" orelse quantifier = "all" orelse quantifier = "Ex" then
+ (case rec_id ~1 T of
+ "" => NONE
+ | name =>
+ let val split = P t in
+ if split <> 0 then
+ (case get_splits thy (rec_id split T) of
+ NONE => NONE
+ | 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
+ | _ => error "record_split_simproc"))
+ else NONE
+ end)
+ else NONE
+ | _ => NONE));
val record_ex_sel_eq_simproc =
Simplifier.simproc @{theory HOL} "record_ex_sel_eq_simproc" ["Ex t"]
(fn thy => fn ss => fn t =>
- let
- fun prove prop =
- quick_and_dirty_prove true thy [] prop
- (fn _ => simp_tac (Simplifier.inherit_context ss (get_simpset thy)
- addsimps simp_thms addsimprocs [record_split_simproc (K ~1)]) 1);
-
- fun mkeq (lr,Teq,(sel,Tsel),x) i =
- if is_selector thy sel then
- let val x' = if not (loose_bvar1 (x,0))
- then Free ("x" ^ string_of_int i, range_type Tsel)
- 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
- else raise TERM ("",[Const (sel,Tsel)]);
-
- fun dest_sel_eq (Const ("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)) =
- (false,Teq,(sel,Tsel),X)
- | dest_sel_eq _ = raise TERM ("",[]);
-
- in
- (case t of
- (Const ("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));
- in SOME (prove prop) end
- handle TERM _ => NONE)
- | _ => NONE)
- end)
-
-
-local
-val inductive_atomize = thms "induct_atomize";
-val inductive_rulify = thms "induct_rulify";
-in
+ let
+ fun prove prop =
+ quick_and_dirty_prove true thy [] prop
+ (fn _ => simp_tac (Simplifier.inherit_context ss (get_simpset thy)
+ addsimps simp_thms addsimprocs [record_split_simproc (K ~1)]) 1);
+
+ fun mkeq (lr, Teq, (sel, Tsel), x) i =
+ if is_selector thy sel then
+ let
+ val x' =
+ if not (loose_bvar1 (x, 0))
+ then Free ("x" ^ string_of_int i, range_type Tsel)
+ 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
+ else raise TERM ("", [Const (sel, Tsel)]);
+
+ fun dest_sel_eq (Const ("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)) =
+ (false, Teq, (sel, Tsel), X)
+ | dest_sel_eq _ = raise TERM ("", []);
+ in
+ (case t of
+ Const ("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));
+ in SOME (prove prop) end
+ handle TERM _ => NONE)
+ | _ => NONE)
+ end);
+
+
(* record_split_simp_tac *)
-(* splits (and simplifies) all records in the goal for which P holds.
- * For quantified occurrences of a record
- * P can peek on the whole subterm (including the quantifier); for free variables P
- * can only peek on the variable itself.
- * P t = 0: do not split
- * P t = ~1: completely split
- * P t > 0: split up to given bound of record extensions
- *)
+
+(*Split (and simplify) all records in the goal for which P holds.
+ For quantified occurrences of a record
+ P can peek on the whole subterm (including the quantifier); for free variables P
+ can only peek on the variable itself.
+ P t = 0: do not split
+ P t = ~1: completely split
+ P t > 0: split up to given bound of record extensions.*)
fun record_split_simp_tac thms P i st =
let
val thy = Thm.theory_of_thm st;
@@ -1315,44 +1552,50 @@
(s = "all" orelse s = "All" orelse s = "Ex") andalso is_recT T
| _ => false);
- val goal = nth (Thm.prems_of st) (i - 1);
- val frees = List.filter (is_recT o type_of) (OldTerm.term_frees goal);
+ val goal = nth (Thm.prems_of st) (i - 1); (* FIXME SUBGOAL *)
+ val frees = filter (is_recT o type_of) (OldTerm.term_frees goal);
fun mk_split_free_tac free induct_thm i =
- let val cfree = cterm_of thy free;
- val (_$(_$r)) = concl_of induct_thm;
- val crec = cterm_of thy r;
- val thm = cterm_instantiate [(crec,cfree)] induct_thm;
- in EVERY [simp_tac (HOL_basic_ss addsimps inductive_atomize) i,
- rtac thm i,
- simp_tac (HOL_basic_ss addsimps inductive_rulify) i]
- end;
-
- fun split_free_tac P i (free as Free (n,T)) =
- (case rec_id (~1) T of
- "" => NONE
- | name => let val split = P free
- in if split <> 0 then
- (case get_splits thy (rec_id split T) of
- NONE => NONE
- | SOME (_,_,_,induct_thm)
- => SOME (mk_split_free_tac free induct_thm i))
- else NONE
- end)
- | split_free_tac _ _ _ = NONE;
+ let
+ val cfree = cterm_of thy free;
+ val _$ (_ $ r) = concl_of induct_thm;
+ val crec = cterm_of thy r;
+ val thm = cterm_instantiate [(crec, cfree)] induct_thm;
+ in
+ EVERY
+ [simp_tac (HOL_basic_ss addsimps @{thms induct_atomize}) i,
+ rtac thm i,
+ simp_tac (HOL_basic_ss addsimps @{thms induct_rulify}) i]
+ end;
+
+ fun split_free_tac P i (free as Free (n, T)) =
+ (case rec_id ~1 T of
+ "" => NONE
+ | name =>
+ let val split = P free in
+ if split <> 0 then
+ (case get_splits thy (rec_id split T) of
+ NONE => NONE
+ | SOME (_, _, _, induct_thm) =>
+ SOME (mk_split_free_tac free induct_thm i))
+ else NONE
+ end)
+ | split_free_tac _ _ _ = NONE;
val split_frees_tacs = List.mapPartial (split_free_tac P i) frees;
val simprocs = if has_rec goal then [record_split_simproc P] else [];
- val thms' = K_comp_convs@thms
- in st |> ((EVERY split_frees_tacs)
- THEN (Simplifier.full_simp_tac (get_simpset thy addsimps thms' addsimprocs simprocs) i))
+ val thms' = K_comp_convs @ thms;
+ in
+ st |>
+ (EVERY split_frees_tacs THEN
+ Simplifier.full_simp_tac (get_simpset thy addsimps thms' addsimprocs simprocs) i)
end handle Empty => Seq.empty;
-end;
(* record_split_tac *)
-(* splits all records in the goal, which are quantified by ! or !!. *)
+
+(*Split all records in the goal, which are quantified by ! or !!.*)
fun record_split_tac i st =
let
val thy = Thm.theory_of_thm st;
@@ -1362,18 +1605,20 @@
(s = "all" orelse s = "All") andalso is_recT T
| _ => false);
- val goal = nth (Thm.prems_of st) (i - 1);
+ val goal = nth (Thm.prems_of st) (i - 1); (* FIXME SUBGOAL *)
fun is_all t =
- (case t of (Const (quantifier, _)$_) =>
- if quantifier = "All" orelse quantifier = "all" then ~1 else 0
- | _ => 0);
-
- in if has_rec goal
- then Simplifier.full_simp_tac
- (HOL_basic_ss addsimprocs [record_split_simproc is_all]) i st
- else Seq.empty
- end handle Subscript => Seq.empty;
+ (case t of
+ Const (quantifier, _) $ _ =>
+ if quantifier = "All" orelse quantifier = "all" then ~1 else 0
+ | _ => 0);
+
+ in
+ if has_rec goal then
+ Simplifier.full_simp_tac
+ (HOL_basic_ss addsimprocs [record_split_simproc is_all]) i st
+ else Seq.empty
+ end handle Subscript => Seq.empty; (* FIXME SUBGOAL *)
(* wrapper *)
@@ -1402,7 +1647,8 @@
fun cert_typ ctxt raw_T env =
let
val thy = ProofContext.theory_of ctxt;
- val T = Type.no_tvars (Sign.certify_typ thy raw_T) handle TYPE (msg, _, _) => error msg;
+ val T = Type.no_tvars (Sign.certify_typ thy raw_T)
+ handle TYPE (msg, _, _) => error msg;
val env' = OldTerm.add_typ_tfrees (T, env);
in (T, env') end;
@@ -1418,194 +1664,166 @@
fun simp_all_tac ss simps = ALLGOALS (Simplifier.asm_full_simp_tac (ss addsimps simps));
-(* do case analysis / induction according to rule on last parameter of ith subgoal
- * (or on s if there are no parameters);
- * Instatiation of record variable (and predicate) in rule is calculated to
- * avoid problems with higher order unification.
- *)
-
+(*Do case analysis / induction according to rule on last parameter of ith subgoal
+ (or on s if there are no parameters).
+ Instatiation of record variable (and predicate) in rule is calculated to
+ avoid problems with higher order unification.*)
fun try_param_tac s rule i st =
let
val cert = cterm_of (Thm.theory_of_thm st);
- val g = nth (prems_of st) (i - 1);
+ val g = nth (prems_of st) (i - 1); (* FIXME SUBGOAL *)
val params = Logic.strip_params g;
val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl g);
val rule' = Thm.lift_rule (Thm.cprem_of st i) rule;
val (P, ys) = strip_comb (HOLogic.dest_Trueprop
(Logic.strip_assums_concl (prop_of rule')));
- (* ca indicates if rule is a case analysis or induction rule *)
- val (x, ca) = (case rev (Library.drop (length params, ys)) of
+ (*ca indicates if rule is a case analysis or induction rule*)
+ val (x, ca) =
+ (case rev (Library.drop (length params, ys)) of
[] => (head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop
(hd (rev (Logic.strip_assums_hyp (hd (prems_of rule')))))))), true)
| [x] => (head_of x, false));
- val rule'' = cterm_instantiate (map (pairself cert) (case (rev params) of
- [] => (case AList.lookup (op =) (map dest_Free (OldTerm.term_frees (prop_of st))) s of
- NONE => sys_error "try_param_tac: no such variable"
- | SOME T => [(P, if ca then concl else lambda (Free (s, T)) concl),
- (x, Free (s, T))])
- | (_, T) :: _ => [(P, list_abs (params, if ca then concl
- else incr_boundvars 1 (Abs (s, T, concl)))),
- (x, list_abs (params, Bound 0))])) rule'
+ val rule'' = cterm_instantiate (map (pairself cert)
+ (case (rev params) of
+ [] =>
+ (case AList.lookup (op =) (map dest_Free (OldTerm.term_frees (prop_of st))) s of
+ NONE => sys_error "try_param_tac: no such variable"
+ | SOME T => [(P, if ca then concl else lambda (Free (s, T)) concl), (x, Free (s, T))])
+ | (_, T) :: _ =>
+ [(P, list_abs (params, if ca then concl else incr_boundvars 1 (Abs (s, T, concl)))),
+ (x, list_abs (params, Bound 0))])) rule';
in compose_tac (false, rule'', nprems_of rule) i st end;
-(* !!x1 ... xn. ... ==> EX x1 ... xn. P x1 ... xn;
- instantiates x1 ... xn with parameters x1 ... xn *)
+(*!!x1 ... xn. ... ==> EX x1 ... xn. P x1 ... xn;
+ instantiates x1 ... xn with parameters x1 ... xn*)
fun ex_inst_tac i st =
let
val thy = Thm.theory_of_thm st;
- val g = nth (prems_of st) (i - 1);
+ val g = nth (prems_of st) (i - 1); (* FIXME SUBGOAL *)
val params = Logic.strip_params g;
val exI' = Thm.lift_rule (Thm.cprem_of st i) exI;
- val (_$(_$x)) = Logic.strip_assums_concl (hd (prems_of exI'));
+ val _ $ (_ $ x) = Logic.strip_assums_concl (hd (prems_of exI'));
val cx = cterm_of thy (fst (strip_comb x));
-
- in Seq.single (Library.foldl (fn (st,v) =>
- Seq.hd
- (compose_tac (false, cterm_instantiate
- [(cx,cterm_of thy (list_abs (params,Bound v)))] exI',1)
- i st)) (st,((length params) - 1) downto 0))
+ in
+ Seq.single (Library.foldl (fn (st, v) =>
+ Seq.hd
+ (compose_tac
+ (false,
+ cterm_instantiate [(cx, cterm_of thy (list_abs (params, Bound v)))] exI', 1) i st))
+ (st, (length params - 1) downto 0))
end;
-fun extension_typedef name repT alphas thy =
- let
- fun get_thms thy name =
- let
- val SOME { Abs_induct = abs_induct,
- Abs_inject=abs_inject, Abs_inverse = abs_inverse, ...} = Typedef.get_info thy name;
- val rewrite_rule = MetaSimplifier.rewrite_rule [rec_UNIV_I, rec_True_simp];
- in map rewrite_rule [abs_inject, abs_inverse, abs_induct] end;
- val tname = Binding.name (Long_Name.base_name name);
- in
- thy
- |> Typecopy.typecopy (Binding.suffix_name ext_typeN tname, alphas) repT NONE
- |-> (fn (name, _) => `(fn thy => get_thms thy name))
- end;
-
-fun mixit convs refls =
- let
- fun f ((res,lhs,rhs),refl) =
- ((refl,List.revAppend (lhs,refl::tl rhs))::res,hd rhs::lhs,tl rhs);
- in #1 (Library.foldl f (([],[],convs),refls)) end;
-
-
fun extension_definition full name fields names alphas zeta moreT more vars thy =
let
val base = Long_Name.base_name;
val fieldTs = (map snd fields);
- val alphas_zeta = alphas@[zeta];
+ val alphas_zeta = alphas @ [zeta];
val alphas_zetaTs = map (fn n => TFree (n, HOLogic.typeS)) alphas_zeta;
val vT = TFree (Name.variant alphas_zeta "'v", HOLogic.typeS);
val extT_name = suffix ext_typeN name
val extT = Type (extT_name, alphas_zetaTs);
- val repT = foldr1 HOLogic.mk_prodT (fieldTs@[moreT]);
- val fields_more = fields@[(full moreN,moreT)];
- val fields_moreTs = fieldTs@[moreT];
+ val fields_more = fields @ [(full moreN, moreT)];
+ val fields_moreTs = fieldTs @ [moreT];
val bfields_more = map (apfst base) fields_more;
- val r = Free (rN,extT)
+ val r = Free (rN, extT);
val len = length fields;
val idxms = 0 upto len;
+ (*before doing anything else, create the tree of new types
+ that will back the record extension*)
+
+ val mktreeV = Balanced_Tree.make IsTupleSupport.mk_cons_tuple;
+
+ fun mk_istuple (left, right) (thy, i) =
+ let
+ val suff = if i = 0 then ext_typeN else inner_typeN ^ string_of_int i;
+ val nm = suffix suff (Long_Name.base_name name);
+ val (isom, cons, thy') =
+ IsTupleSupport.add_istuple_type
+ (nm, alphas_zeta) (fastype_of left, fastype_of right) thy;
+ in
+ (cons $ left $ right, (thy', i + 1))
+ end;
+
+ (*trying to create a 1-element istuple will fail, and is pointless anyway*)
+ fun mk_even_istuple [arg] = pair arg
+ | mk_even_istuple args = mk_istuple (IsTupleSupport.dest_cons_tuple (mktreeV args));
+
+ fun build_meta_tree_type i thy vars more =
+ let val len = length vars in
+ if len < 1 then raise TYPE ("meta_tree_type args too short", [], vars)
+ else if len > 16 then
+ let
+ fun group16 [] = []
+ | group16 xs = Library.take (16, xs) :: group16 (Library.drop (16, xs));
+ val vars' = group16 vars;
+ val (composites, (thy', i')) = fold_map mk_even_istuple vars' (thy, i);
+ in
+ build_meta_tree_type i' thy' composites more
+ end
+ else
+ let val (term, (thy', i')) = mk_istuple (mktreeV vars, more) (thy, 0)
+ in (term, thy') end
+ end;
+
+ val _ = timing_msg "record extension preparing definitions";
+
+
+ (* 1st stage part 1: introduce the tree of new types *)
+
+ fun get_meta_tree () = build_meta_tree_type 1 thy vars more;
+ val (ext_body, typ_thy) =
+ timeit_msg "record extension nested type def:" get_meta_tree;
+
+
(* prepare declarations and definitions *)
(*fields constructor*)
- val ext_decl = (mk_extC (name,extT) fields_moreTs);
- (*
- val ext_spec = Const ext_decl :==
- (foldr (uncurry lambda)
- (mk_Abs name repT extT $ (foldr1 HOLogic.mk_prod (vars@[more]))) (vars@[more]))
- *)
- val ext_spec = list_comb (Const ext_decl,vars@[more]) :==
- (mk_Abs name repT extT $ (foldr1 HOLogic.mk_prod (vars@[more])));
+ val ext_decl = mk_extC (name, extT) fields_moreTs;
+ val ext_spec = list_comb (Const ext_decl, vars @ [more]) :== ext_body;
fun mk_ext args = list_comb (Const ext_decl, args);
- (*destructors*)
- val _ = timing_msg "record extension preparing definitions";
- val dest_decls = map (mk_selC extT o (apfst (suffix ext_dest))) bfields_more;
-
- fun mk_dest_spec (i, (c,T)) =
- let val snds = (funpow i HOLogic.mk_snd (mk_Rep name repT extT $ r))
- in Const (mk_selC extT (suffix ext_dest c,T))
- :== (lambda r (if i=len then snds else HOLogic.mk_fst snds))
- end;
- val dest_specs =
- ListPair.map mk_dest_spec (idxms, fields_more);
-
- (*updates*)
- val upd_decls = map (mk_updC updN extT) bfields_more;
- fun mk_upd_spec (c,T) =
- let
- val args = map (fn (n,nT) => if n=c then Free (base c,T --> T)$
- (mk_sel r (suffix ext_dest n,nT))
- else (mk_sel r (suffix ext_dest n,nT)))
- fields_more;
- in Const (mk_updC updN extT (c,T))$(Free (base c,T --> T))$r
- :== mk_ext args
- end;
- val upd_specs = map mk_upd_spec fields_more;
-
- (* 1st stage: defs_thy *)
+
+ (* 1st stage part 2: define the ext constant *)
+
fun mk_defs () =
- thy
- |> extension_typedef name repT (alphas @ [zeta])
- ||> Sign.add_consts_i
- (map (Syntax.no_syn o apfst Binding.name) (apfst base ext_decl :: dest_decls @ upd_decls))
- ||>> PureThy.add_defs false
- (map (Thm.no_attributes o apfst Binding.name) (ext_spec :: dest_specs))
- ||>> PureThy.add_defs false
- (map (Thm.no_attributes o apfst Binding.name) upd_specs)
- |-> (fn args as ((_, dest_defs), upd_defs) =>
- fold Code.add_default_eqn dest_defs
- #> fold Code.add_default_eqn upd_defs
- #> pair args);
- val ((([abs_inject, abs_inverse, abs_induct], ext_def :: dest_defs), upd_defs), defs_thy) =
- timeit_msg "record extension type/selector/update defs:" mk_defs;
+ typ_thy
+ |> Sign.add_consts_i [Syntax.no_syn (apfst (Binding.name o base) ext_decl)]
+ |> PureThy.add_defs false [Thm.no_attributes (apfst Binding.name ext_spec)]
+ val ([ext_def], defs_thy) =
+ timeit_msg "record extension constructor def:" mk_defs;
(* prepare propositions *)
val _ = timing_msg "record extension preparing propositions";
- val vars_more = vars@[more];
- val named_vars_more = (names@[full moreN])~~vars_more;
- val variants = map (fn (Free (x,_))=>x) vars_more;
+ val vars_more = vars @ [more];
+ val named_vars_more = (names @ [full moreN]) ~~ vars_more;
+ val variants = map (fn Free (x, _) => x) vars_more;
val ext = mk_ext vars_more;
- val s = Free (rN, extT);
- val w = Free (wN, extT);
- val P = Free (Name.variant variants "P", extT-->HOLogic.boolT);
+ val s = Free (rN, extT);
+ val w = Free (wN, extT);
+ val P = Free (Name.variant variants "P", extT --> HOLogic.boolT);
val C = Free (Name.variant variants "C", HOLogic.boolT);
+ val intros_tac = IsTupleSupport.istuple_intros_tac defs_thy;
val inject_prop =
- let val vars_more' = map (fn (Free (x,T)) => Free (x ^ "'",T)) vars_more;
- in All (map dest_Free (vars_more@vars_more'))
- ((HOLogic.eq_const extT $
- mk_ext vars_more$mk_ext vars_more')
- ===
- foldr1 HOLogic.mk_conj (map HOLogic.mk_eq (vars_more ~~ vars_more')))
+ let val vars_more' = map (fn (Free (x, T)) => Free (x ^ "'", T)) vars_more in
+ HOLogic.mk_conj (HOLogic.eq_const extT $
+ mk_ext vars_more $ mk_ext vars_more', HOLogic.true_const)
+ ===
+ foldr1 HOLogic.mk_conj
+ (map HOLogic.mk_eq (vars_more ~~ vars_more') @ [HOLogic.true_const])
end;
val induct_prop =
(All (map dest_Free vars_more) (Trueprop (P $ ext)), Trueprop (P $ s));
val cases_prop =
- (All (map dest_Free vars_more)
- (Trueprop (HOLogic.mk_eq (s,ext)) ==> Trueprop C))
+ All (map dest_Free vars_more)
+ (Trueprop (HOLogic.mk_eq (s, ext)) ==> Trueprop C)
==> Trueprop C;
- (*destructors*)
- val dest_conv_props =
- map (fn (c, x as Free (_,T)) => mk_sel ext (suffix ext_dest c,T) === x) named_vars_more;
-
- (*updates*)
- fun mk_upd_prop (i,(c,T)) =
- let val x' = Free (Name.variant variants (base c ^ "'"),T --> T)
- val args' = nth_map i (K (x'$nth vars_more i)) vars_more
- in mk_upd updN c x' ext === mk_ext args' end;
- val upd_conv_props = ListPair.map mk_upd_prop (idxms, fields_more);
-
- val surjective_prop =
- let val args =
- map (fn (c, Free (_,T)) => mk_sel s (suffix ext_dest c,T)) named_vars_more;
- in s === mk_ext args end;
-
val split_meta_prop =
let val P = Free (Name.variant variants "P", extT-->Term.propT) in
Logic.mk_equals
@@ -1618,137 +1836,98 @@
let val tac = simp_all_tac HOL_ss simps
in fn prop => prove stndrd [] prop (K tac) end;
- fun inject_prf () = (prove_simp true [ext_def,abs_inject,Pair_eq] inject_prop);
+ fun inject_prf () =
+ simplify HOL_ss
+ (prove_standard [] inject_prop
+ (fn prems =>
+ EVERY
+ [simp_tac (HOL_basic_ss addsimps [ext_def]) 1,
+ REPEAT_DETERM (resolve_tac [refl_conj_eq] 1 ORELSE
+ intros_tac 1 ORELSE
+ resolve_tac [refl] 1)]));
+
val inject = timeit_msg "record extension inject proof:" inject_prf;
+ (*We need a surjection property r = (| f = f r, g = g r ... |)
+ 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 standard to convert
+ the free variables into unifiable variables and unify them with
+ (roughly) the definition of the accessor.*)
+ fun surject_prf () =
+ let
+ val cterm_ext = cterm_of defs_thy ext;
+ val start = named_cterm_instantiate [("y", cterm_ext)] surject_assist_idE;
+ val tactic1 =
+ simp_tac (HOL_basic_ss addsimps [ext_def]) 1 THEN
+ REPEAT_ALL_NEW intros_tac 1;
+ val tactic2 = REPEAT (rtac surject_assistI 1 THEN rtac refl 1);
+ val [halfway] = Seq.list_of (tactic1 start); (* FIXME Seq.lift_of ?? *)
+ val [surject] = Seq.list_of (tactic2 (standard halfway)); (* FIXME Seq.lift_of ?? *)
+ in
+ surject
+ end;
+ val surject = timeit_msg "record extension surjective proof:" surject_prf;
+
+ fun split_meta_prf () =
+ prove_standard [] split_meta_prop
+ (fn prems =>
+ EVERY
+ [rtac equal_intr_rule 1, Goal.norm_hhf_tac 1,
+ etac meta_allE 1, atac 1,
+ rtac (prop_subst OF [surject]) 1,
+ REPEAT (etac meta_allE 1), atac 1]);
+ val split_meta = timeit_msg "record extension split_meta proof:" split_meta_prf;
+
fun induct_prf () =
- let val (assm, concl) = induct_prop
- in prove_standard [assm] concl (fn {prems, ...} =>
- EVERY [try_param_tac rN abs_induct 1,
- simp_tac (HOL_ss addsimps [split_paired_all]) 1,
- resolve_tac (map (rewrite_rule [ext_def]) prems) 1])
+ let val (assm, concl) = induct_prop in
+ prove_standard [assm] concl
+ (fn {prems, ...} =>
+ EVERY
+ [cut_rules_tac [split_meta RS Drule.equal_elim_rule2] 1,
+ resolve_tac prems 2,
+ asm_simp_tac HOL_ss 1])
end;
val induct = timeit_msg "record extension induct proof:" induct_prf;
- fun cases_prf_opt () =
- let
- val (_$(Pvar$_)) = concl_of induct;
- val ind = cterm_instantiate
- [(cterm_of defs_thy Pvar, cterm_of defs_thy
- (lambda w (HOLogic.imp$HOLogic.mk_eq(r,w)$C)))]
- induct;
- in standard (ObjectLogic.rulify (mp OF [ind, refl])) end;
-
- fun cases_prf_noopt () =
- prove_standard [] cases_prop (fn _ =>
- EVERY [asm_full_simp_tac (HOL_basic_ss addsimps [atomize_all, atomize_imp]) 1,
- try_param_tac rN induct 1,
- rtac impI 1,
- REPEAT (etac allE 1),
- etac mp 1,
- rtac refl 1])
-
- val cases_prf = quick_and_dirty_prf cases_prf_noopt cases_prf_opt;
- val cases = timeit_msg "record extension cases proof:" cases_prf;
-
- fun dest_convs_prf () = map (prove_simp false
- ([ext_def,abs_inverse]@Pair_sel_convs@dest_defs)) dest_conv_props;
- val dest_convs = timeit_msg "record extension dest_convs proof:" dest_convs_prf;
- fun dest_convs_standard_prf () = map standard dest_convs;
-
- val dest_convs_standard =
- timeit_msg "record extension dest_convs_standard proof:" dest_convs_standard_prf;
-
- fun upd_convs_prf_noopt () = map (prove_simp true (dest_convs_standard@upd_defs))
- upd_conv_props;
- fun upd_convs_prf_opt () =
- let
-
- fun mkrefl (c,T) = Thm.reflexive
- (cterm_of defs_thy (Free (Name.variant variants (base c ^ "'"),T-->T)));
- val refls = map mkrefl fields_more;
- val dest_convs' = map mk_meta_eq dest_convs;
- val map_eqs = map (uncurry Thm.combination) (refls ~~ dest_convs');
-
- val constr_refl = Thm.reflexive (cterm_of defs_thy (head_of ext));
-
- fun mkthm (udef,(fld_refl,thms)) =
- let val bdyeq = Library.foldl (uncurry Thm.combination) (constr_refl,thms);
- (* (|N=N (|N=N,M=M,K=K,more=more|)
- M=M (|N=N,M=M,K=K,more=more|)
- K=K'
- more = more (|N=N,M=M,K=K,more=more|) =
- (|N=N,M=M,K=K',more=more|)
- *)
- val (_$(_$v$r)$_) = prop_of udef;
- val (_$(v'$_)$_) = prop_of fld_refl;
- val udef' = cterm_instantiate
- [(cterm_of defs_thy v,cterm_of defs_thy v'),
- (cterm_of defs_thy r,cterm_of defs_thy ext)] udef;
- in standard (Thm.transitive udef' bdyeq) end;
- in map mkthm (rev upd_defs ~~ (mixit dest_convs' map_eqs)) end;
-
- val upd_convs_prf = quick_and_dirty_prf upd_convs_prf_noopt upd_convs_prf_opt;
-
- val upd_convs =
- timeit_msg "record extension upd_convs proof:" upd_convs_prf;
-
- fun surjective_prf () =
- prove_standard [] surjective_prop (fn _ =>
- (EVERY [try_param_tac rN induct 1,
- simp_tac (HOL_basic_ss addsimps dest_convs_standard) 1]));
- val surjective = timeit_msg "record extension surjective proof:" surjective_prf;
-
- fun split_meta_prf () =
- prove_standard [] split_meta_prop (fn _ =>
- EVERY [rtac equal_intr_rule 1, Goal.norm_hhf_tac 1,
- etac meta_allE 1, atac 1,
- rtac (prop_subst OF [surjective]) 1,
- REPEAT (etac meta_allE 1), atac 1]);
- val split_meta = timeit_msg "record extension split_meta proof:" split_meta_prf;
-
-
- val (([inject',induct',cases',surjective',split_meta'],
- [dest_convs',upd_convs']),
- thm_thy) =
+ val ([inject', induct', surjective', split_meta'], thm_thy) =
defs_thy
|> (PureThy.add_thms o map (Thm.no_attributes o apfst Binding.name))
[("ext_inject", inject),
("ext_induct", induct),
- ("ext_cases", cases),
- ("ext_surjective", surjective),
- ("ext_split", split_meta)]
- ||>> (PureThy.add_thmss o map (Thm.no_attributes o apfst Binding.name))
- [("dest_convs", dest_convs_standard), ("upd_convs", upd_convs)]
-
- in (thm_thy,extT,induct',inject',dest_convs',split_meta',upd_convs')
- end;
-
-fun chunks [] [] = []
- | chunks [] xs = [xs]
- | chunks (l::ls) xs = Library.take (l,xs)::chunks ls (Library.drop (l,xs));
-
-fun chop_last [] = error "last: list should not be empty"
- | chop_last [x] = ([],x)
- | chop_last (x::xs) = let val (tl,l) = chop_last xs in (x::tl,l) end;
-
-fun subst_last s [] = error "subst_last: list should not be empty"
- | subst_last s ([x]) = [s]
- | subst_last s (x::xs) = (x::subst_last s xs);
-
-(* mk_recordT builds up the record type from the current extension tpye extT and a list
- * of parent extensions, starting with the root of the record hierarchy
-*)
+ ("ext_surjective", surject),
+ ("ext_split", split_meta)];
+
+ in (thm_thy, extT, induct', inject', split_meta', ext_def) end;
+
+fun chunks [] [] = []
+ | chunks [] xs = [xs]
+ | chunks (l :: ls) xs = Library.take (l, xs) :: chunks ls (Library.drop (l, xs));
+
+fun chop_last [] = error "chop_last: list should not be empty"
+ | chop_last [x] = ([], x)
+ | chop_last (x :: xs) = let val (tl, l) = chop_last xs in (x :: tl, l) end;
+
+fun subst_last s [] = error "subst_last: list should not be empty"
+ | subst_last s [x] = [s]
+ | subst_last s (x :: xs) = x :: subst_last s xs;
+
+
+(* mk_recordT *)
+
+(*builds up the record type from the current extension tpye extT and a list
+ of parent extensions, starting with the root of the record hierarchy*)
fun mk_recordT extT =
- fold_rev (fn (parent, Ts) => fn T => Type (parent, subst_last T Ts)) extT;
-
+ fold_rev (fn (parent, Ts) => fn T => Type (parent, subst_last T Ts)) extT;
fun obj_to_meta_all thm =
let
- fun E thm = case (SOME (spec OF [thm]) handle THM _ => NONE) of
- SOME thm' => E thm'
- | NONE => thm;
+ fun E thm = (* FIXME proper name *)
+ (case (SOME (spec OF [thm]) handle THM _ => NONE) of
+ SOME thm' => E thm'
+ | NONE => thm);
val th1 = E thm;
val th2 = Drule.forall_intr_vars th1;
in th2 end;
@@ -1759,13 +1938,9 @@
val prop = Thm.prop_of thm;
val params = Logic.strip_params prop;
val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl prop);
- val ct = cterm_of thy
- (HOLogic.mk_Trueprop (HOLogic.list_all (params, concl)));
+ val ct = cterm_of thy (HOLogic.mk_Trueprop (HOLogic.list_all (params, concl)));
val thm' = Seq.hd (REPEAT (rtac allI 1) (Thm.trivial ct));
- in
- Thm.implies_elim thm' thm
- end;
-
+ in Thm.implies_elim thm' thm end;
(* record_definition *)
@@ -1779,7 +1954,8 @@
val full = Sign.full_bname_path thy bname;
val base = Long_Name.base_name;
- val (bfields, field_syntax) = split_list (map (fn (x, T, mx) => ((x, T), mx)) raw_fields);
+ val (bfields, field_syntax) =
+ split_list (map (fn (x, T, mx) => ((x, T), mx)) raw_fields);
val parent_fields = List.concat (map #fields parents);
val parent_chunks = map (length o #fields) parents;
@@ -1799,7 +1975,8 @@
val alphas_ext = alphas inter alphas_fields;
val len = length fields;
val variants =
- Name.variant_list (moreN :: rN :: (rN ^ "'") :: wN :: parent_variants) (map fst bfields);
+ Name.variant_list (moreN :: rN :: (rN ^ "'") :: wN :: parent_variants)
+ (map fst bfields);
val vars = ListPair.map Free (variants, types);
val named_vars = names ~~ vars;
val idxs = 0 upto (len - 1);
@@ -1818,15 +1995,17 @@
val moreT = TFree (zeta, HOLogic.typeS);
val more = Free (moreN, moreT);
val full_moreN = full moreN;
- val bfields_more = bfields @ [(moreN,moreT)];
- val fields_more = fields @ [(full_moreN,moreT)];
+ val bfields_more = bfields @ [(moreN, moreT)];
+ val fields_more = fields @ [(full_moreN, moreT)];
val vars_more = vars @ [more];
- val named_vars_more = named_vars @[(full_moreN,more)];
+ val named_vars_more = named_vars @ [(full_moreN, more)];
val all_vars_more = all_vars @ [more];
- val all_named_vars_more = all_named_vars @ [(full_moreN,more)];
+ val all_named_vars_more = all_named_vars @ [(full_moreN, more)];
+
(* 1st stage: extension_thy *)
- val (extension_thy,extT,ext_induct,ext_inject,ext_dest_convs,ext_split,u_convs) =
+
+ val (extension_thy, extT, ext_induct, ext_inject, ext_split, ext_def) =
thy
|> Sign.add_path bname
|> extension_definition full extN fields names alphas_ext zeta moreT more vars;
@@ -1834,26 +2013,24 @@
val _ = timing_msg "record preparing definitions";
val Type extension_scheme = extT;
val extension_name = unsuffix ext_typeN (fst extension_scheme);
- val extension = let val (n,Ts) = extension_scheme in (n,subst_last HOLogic.unitT Ts) end;
- val extension_names =
- (map ((unsuffix ext_typeN) o fst o #extension) parents) @ [extN];
- val extension_id = Library.foldl (op ^) ("",extension_names);
-
+ val extension = let val (n, Ts) = extension_scheme in (n, subst_last HOLogic.unitT Ts) end;
+ val extension_names = map (unsuffix ext_typeN o fst o #extension) parents @ [extN];
+ val extension_id = implode extension_names;
fun rec_schemeT n = mk_recordT (map #extension (prune n parents)) extT;
val rec_schemeT0 = rec_schemeT 0;
fun recT n =
- let val (c,Ts) = extension
- in mk_recordT (map #extension (prune n parents)) (Type (c,subst_last HOLogic.unitT Ts))
- end;
+ let val (c, Ts) = extension
+ in mk_recordT (map #extension (prune n parents)) (Type (c, subst_last HOLogic.unitT Ts)) end;
val recT0 = recT 0;
fun mk_rec args n =
- let val (args',more) = chop_last args;
- fun mk_ext' (((name,T),args),more) = mk_ext (name,T) (args@[more]);
- fun build Ts =
- List.foldr mk_ext' more (prune n (extension_names ~~ Ts ~~ (chunks parent_chunks args')))
+ let
+ val (args', more) = chop_last args;
+ fun mk_ext' (((name, T), args), more) = mk_ext (name, T) (args @ [more]);
+ fun build Ts =
+ List.foldr mk_ext' more (prune n (extension_names ~~ Ts ~~ (chunks parent_chunks args')));
in
if more = HOLogic.unit
then build (map recT (0 upto parent_len))
@@ -1861,7 +2038,7 @@
end;
val r_rec0 = mk_rec all_vars_more 0;
- val r_rec_unit0 = mk_rec (all_vars@[HOLogic.unit]) 0;
+ val r_rec_unit0 = mk_rec (all_vars @ [HOLogic.unit]) 0;
fun r n = Free (rN, rec_schemeT n)
val r0 = r 0;
@@ -1869,26 +2046,27 @@
val r_unit0 = r_unit 0;
val w = Free (wN, rec_schemeT 0)
+
(* 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;
+ let val trnames = external_names extN
+ in map (gen_record_tr') trnames end;
val adv_record_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;
+ 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 =
- let 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;
+ let
+ 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;
(* prepare declarations *)
@@ -1903,34 +2081,83 @@
(* prepare definitions *)
fun parent_more s =
- if null parents then s
- else mk_sel s (Long_Name.qualify (#name (List.last parents)) moreN, extT);
+ if null parents then s
+ else mk_sel s (Long_Name.qualify (#name (List.last parents)) moreN, extT);
fun parent_more_upd v s =
- if null parents then v$s
- else let val mp = Long_Name.qualify (#name (List.last parents)) moreN;
- in mk_upd updateN mp v s end;
+ if null parents then v $ s
+ else
+ let val mp = Long_Name.qualify (#name (List.last parents)) moreN;
+ in mk_upd updateN mp v s end;
(*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;
+ val intros_tac = IsTupleSupport.istuple_intros_tac extension_thy;
+
+ (*Theorems from the istuple 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
+ on these constructors. If we take the complete result sequence of
+ running a the introduction tactic, we get one theorem for each upd/acc
+ pair, from which we can derive the bodies of our selector and
+ updator and their convs.*)
+ fun get_access_update_thms () =
+ let
+ val r_rec0_Vars =
+ let
+ (*pick variable indices of 1 to avoid possible variable
+ collisions with existing variables in updacc_eq_triv*)
+ fun to_Var (Free (c, T)) = Var ((c, 1), T);
+ in mk_rec (map to_Var all_vars_more) 0 end;
+
+ val cterm_rec = cterm_of extension_thy r_rec0;
+ val cterm_vrs = cterm_of extension_thy r_rec0_Vars;
+ val insts = [("v", cterm_rec), ("v'", cterm_vrs)];
+ val init_thm = named_cterm_instantiate insts updacc_eq_triv;
+ val terminal = rtac updacc_eq_idI 1 THEN rtac refl 1;
+ val tactic =
+ simp_tac (HOL_basic_ss addsimps ext_defs) 1 THEN
+ REPEAT (intros_tac 1 ORELSE terminal);
+ val updaccs = Seq.list_of (tactic init_thm); (* FIXME Seq.lift_of *)
+ in
+ (updaccs RL [updacc_accessor_eqE],
+ updaccs RL [updacc_updator_eqE],
+ updaccs RL [updacc_cong_from_eq])
+ end;
+ val (accessor_thms, updator_thms, upd_acc_cong_assists) =
+ timeit_msg "record getting tree access/updates:" get_access_update_thms;
+
+ fun lastN xs = List.drop (xs, parent_fields_len);
+
(*selectors*)
- fun mk_sel_spec (c,T) =
- Const (mk_selC rec_schemeT0 (c,T))
- :== (lambda r0 (Const (mk_selC extT (suffix ext_dest c,T))$parent_more r0));
- val sel_specs = map mk_sel_spec fields_more;
+ fun mk_sel_spec ((c, T), thm) =
+ let
+ val acc $ arg =
+ (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Envir.beta_eta_contract o concl_of) thm;
+ val _ =
+ if (arg aconv r_rec0) then ()
+ else raise TERM ("mk_sel_spec: different arg", [arg]);
+ in
+ Const (mk_selC rec_schemeT0 (c, T)) :== acc
+ end;
+ val sel_specs = map mk_sel_spec (fields_more ~~ lastN accessor_thms);
(*updates*)
-
- fun mk_upd_spec (c,T) =
+ fun mk_upd_spec ((c, T), thm) =
let
- val new = mk_upd' updN c (Free (base c,T-->T)) extT(*(parent_more r0)*);
- in Const (mk_updC updateN rec_schemeT0 (c,T))$(Free (base c,T-->T))$r0
- :== (parent_more_upd new r0)
- end;
- val upd_specs = map mk_upd_spec fields_more;
+ val (upd $ _ $ arg) =
+ (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Envir.beta_eta_contract o concl_of) thm;
+ val _ =
+ 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 :==
@@ -1943,14 +2170,14 @@
val truncate_spec = Const (full 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_tr's, [])
|> Sign.add_advanced_trfuns
- ([],[],adv_ext_tr's @ adv_record_type_tr's @ adv_record_type_abbr_tr's,[])
+ ([], [], adv_ext_tr's @ adv_record_type_tr's @ adv_record_type_abbr_tr's, [])
|> Sign.parent_path
|> Sign.add_tyabbrs_i recordT_specs
|> Sign.add_path bname
@@ -1963,7 +2190,8 @@
||>> ((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])
- |-> (fn defs as ((sel_defs, upd_defs), derived_defs) =>
+ |->
+ (fn defs as ((sel_defs, upd_defs), derived_defs) =>
fold Code.add_default_eqn sel_defs
#> fold Code.add_default_eqn upd_defs
#> fold Code.add_default_eqn derived_defs
@@ -1972,23 +2200,23 @@
timeit_msg "record trfuns/tyabbrs/selectors/updates/make/fields/extend/truncate defs:"
mk_defs;
-
(* prepare propositions *)
val _ = timing_msg "record preparing propositions";
- val P = Free (Name.variant all_variants "P", rec_schemeT0-->HOLogic.boolT);
+ val P = Free (Name.variant all_variants "P", rec_schemeT0 --> HOLogic.boolT);
val C = Free (Name.variant all_variants "C", HOLogic.boolT);
- val P_unit = Free (Name.variant all_variants "P", recT0-->HOLogic.boolT);
+ val P_unit = Free (Name.variant all_variants "P", recT0 --> HOLogic.boolT);
(*selectors*)
val sel_conv_props =
- map (fn (c, x as Free (_,T)) => mk_sel r_rec0 (c,T) === x) named_vars_more;
+ map (fn (c, x as Free (_, T)) => mk_sel r_rec0 (c, T) === x) named_vars_more;
(*updates*)
- fun mk_upd_prop (i,(c,T)) =
- let val x' = Free (Name.variant all_variants (base c ^ "'"),T-->T);
- val n = parent_fields_len + i;
- val args' = nth_map n (K (x'$nth all_vars_more n)) all_vars_more
- in mk_upd updateN c x' r_rec0 === mk_rec args' 0 end;
+ fun mk_upd_prop (i, (c, T)) =
+ let
+ val x' = Free (Name.variant all_variants (base c ^ "'"), T --> T);
+ val n = parent_fields_len + i;
+ val args' = nth_map n (K (x' $ nth all_vars_more n)) all_vars_more
+ in mk_upd updateN c x' r_rec0 === mk_rec args' 0 end;
val upd_conv_props = ListPair.map mk_upd_prop (idxms, fields_more);
(*induct*)
@@ -1996,22 +2224,22 @@
All (map dest_Free all_vars_more) (Trueprop (P $ r_rec0)) ==> Trueprop (P $ r0);
val induct_prop =
(All (map dest_Free all_vars) (Trueprop (P_unit $ r_rec_unit0)),
- Trueprop (P_unit $ r_unit0));
+ Trueprop (P_unit $ r_unit0));
(*surjective*)
val surjective_prop =
- let val args = map (fn (c,Free (_,T)) => mk_sel r0 (c,T)) all_named_vars_more
+ let val args = map (fn (c, Free (_, T)) => mk_sel r0 (c, T)) all_named_vars_more
in r0 === mk_rec args 0 end;
(*cases*)
val cases_scheme_prop =
(All (map dest_Free all_vars_more)
- (Trueprop (HOLogic.mk_eq (r0,r_rec0)) ==> Trueprop C))
+ (Trueprop (HOLogic.mk_eq (r0, r_rec0)) ==> Trueprop C))
==> Trueprop C;
val cases_prop =
(All (map dest_Free all_vars)
- (Trueprop (HOLogic.mk_eq (r_unit0,r_rec_unit0)) ==> Trueprop C))
+ (Trueprop (HOLogic.mk_eq (r_unit0, r_rec_unit0)) ==> Trueprop C))
==> Trueprop C;
(*split*)
@@ -2021,24 +2249,24 @@
(All [dest_Free r0] (P $ r0), All (map dest_Free all_vars_more) (P $ r_rec0))
end;
+ (* FIXME eliminate old List.foldr *)
+
val split_object_prop =
- let fun ALL vs t = List.foldr (fn ((v,T),t) => HOLogic.mk_all (v,T,t)) t vs
- in (ALL [dest_Free r0] (P $ r0)) === (ALL (map dest_Free all_vars_more) (P $ r_rec0))
- end;
-
+ let fun ALL vs t = List.foldr (fn ((v, T), t) => HOLogic.mk_all (v, T, t)) t vs
+ in (ALL [dest_Free r0] (P $ r0)) === (ALL (map dest_Free all_vars_more) (P $ r_rec0)) end;
val split_ex_prop =
- let fun EX vs t = List.foldr (fn ((v,T),t) => HOLogic.mk_exists (v,T,t)) t vs
- in (EX [dest_Free r0] (P $ r0)) === (EX (map dest_Free all_vars_more) (P $ r_rec0))
- end;
+ let fun EX vs t = List.foldr (fn ((v, T), t) => HOLogic.mk_exists (v, T, t)) t vs
+ in (EX [dest_Free r0] (P $ r0)) === (EX (map dest_Free all_vars_more) (P $ r_rec0)) end;
(*equality*)
val equality_prop =
let
- val s' = Free (rN ^ "'", rec_schemeT0)
- fun mk_sel_eq (c,Free (_,T)) = mk_sel r0 (c,T) === mk_sel s' (c,T)
- val seleqs = map mk_sel_eq all_named_vars_more
- in All (map dest_Free [r0,s']) (Logic.list_implies (seleqs,r0 === s')) end;
+ val s' = Free (rN ^ "'", rec_schemeT0);
+ fun mk_sel_eq (c, Free (_, T)) = mk_sel r0 (c, T) === mk_sel s' (c, T);
+ val seleqs = map mk_sel_eq all_named_vars_more;
+ in All (map dest_Free [r0, s']) (Logic.list_implies (seleqs, r0 === s')) end;
+
(* 3rd stage: thms_thy *)
@@ -2051,30 +2279,43 @@
val ss = get_simpset defs_thy;
- fun sel_convs_prf () = map (prove_simp false ss
- (sel_defs@ext_dest_convs)) sel_conv_props;
+ 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 standard sel_convs
val sel_convs_standard =
- timeit_msg "record sel_convs_standard proof:" sel_convs_standard_prf;
+ timeit_msg "record sel_convs_standard proof:" sel_convs_standard_prf;
fun upd_convs_prf () =
- map (prove_simp true ss (upd_defs@u_convs)) upd_conv_props;
-
+ 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 standard upd_convs
+ val upd_convs_standard =
+ timeit_msg "record upd_convs_standard proof:" upd_convs_standard_prf;
+
+ fun get_upd_acc_congs () =
+ let
+ val symdefs = map symmetric (sel_defs @ upd_defs);
+ val fold_ss = HOL_basic_ss addsimps symdefs;
+ val ua_congs = map (standard 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))];
- 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,
- try_param_tac rN ext_induct 1,
- asm_simp_tac HOL_basic_ss 1]));
+ 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,
+ 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;
fun induct_prf () =
- let val (assm, concl) = induct_prop;
- in
+ let val (assm, concl) = induct_prop in
prove_standard [assm] concl (fn {prems, ...} =>
try_param_tac rN induct_scheme 1
THEN try_param_tac "more" @{thm unit.induct} 1
@@ -2082,117 +2323,142 @@
end;
val induct = timeit_msg "record induct proof:" induct_prf;
- fun surjective_prf () =
- prove_standard [] surjective_prop (fn prems =>
- (EVERY [try_param_tac rN induct_scheme 1,
- simp_tac (ss addsimps sel_convs_standard) 1]))
- val surjective = timeit_msg "record surjective proof:" surjective_prf;
-
fun cases_scheme_prf_opt () =
let
- val (_$(Pvar$_)) = concl_of induct_scheme;
- val ind = cterm_instantiate
- [(cterm_of defs_thy Pvar, cterm_of defs_thy
- (lambda w (HOLogic.imp$HOLogic.mk_eq(r0,w)$C)))]
- induct_scheme;
+ val _ $ (Pvar $ _) = concl_of induct_scheme;
+ val ind =
+ cterm_instantiate
+ [(cterm_of defs_thy Pvar, cterm_of defs_thy
+ (lambda w (HOLogic.imp $ HOLogic.mk_eq (r0, w) $ C)))]
+ induct_scheme;
in standard (ObjectLogic.rulify (mp OF [ind, refl])) end;
fun cases_scheme_prf_noopt () =
- prove_standard [] cases_scheme_prop (fn _ =>
- EVERY [asm_full_simp_tac (HOL_basic_ss addsimps [atomize_all, atomize_imp]) 1,
- try_param_tac rN induct_scheme 1,
- rtac impI 1,
- REPEAT (etac allE 1),
- etac mp 1,
- rtac refl 1])
+ prove_standard [] cases_scheme_prop
+ (fn _ =>
+ EVERY
+ [asm_full_simp_tac (HOL_basic_ss addsimps [atomize_all, atomize_imp]) 1,
+ try_param_tac rN induct_scheme 1,
+ rtac impI 1,
+ REPEAT (etac allE 1),
+ etac mp 1,
+ rtac refl 1]);
val cases_scheme_prf = quick_and_dirty_prf cases_scheme_prf_noopt cases_scheme_prf_opt;
val cases_scheme = timeit_msg "record cases_scheme proof:" cases_scheme_prf;
fun cases_prf () =
- prove_standard [] cases_prop (fn _ =>
- try_param_tac rN cases_scheme 1
- THEN simp_all_tac HOL_basic_ss [unit_all_eq1]);
+ prove_standard [] cases_prop
+ (fn _ =>
+ try_param_tac rN cases_scheme 1 THEN
+ simp_all_tac HOL_basic_ss [unit_all_eq1]);
val cases = timeit_msg "record cases proof:" cases_prf;
+ fun surjective_prf () =
+ let
+ val leaf_ss = get_sel_upd_defs defs_thy addsimps (sel_defs @ (o_assoc :: id_o_apps));
+ val init_ss = HOL_basic_ss addsimps ext_defs;
+ in
+ prove_standard [] surjective_prop
+ (fn prems =>
+ EVERY
+ [rtac surject_assist_idE 1,
+ simp_tac init_ss 1,
+ REPEAT (intros_tac 1 ORELSE (rtac surject_assistI 1 THEN simp_tac leaf_ss 1))])
+ end;
+ val surjective = timeit_msg "record surjective proof:" surjective_prf;
+
fun split_meta_prf () =
- prove false [] split_meta_prop (fn _ =>
- EVERY [rtac equal_intr_rule 1, Goal.norm_hhf_tac 1,
- etac meta_allE 1, atac 1,
- rtac (prop_subst OF [surjective]) 1,
- REPEAT (etac meta_allE 1), atac 1]);
+ prove false [] split_meta_prop
+ (fn prems =>
+ EVERY
+ [rtac equal_intr_rule 1, Goal.norm_hhf_tac 1,
+ etac meta_allE 1, atac 1,
+ rtac (prop_subst OF [surjective]) 1,
+ REPEAT (etac meta_allE 1), atac 1]);
val split_meta = timeit_msg "record split_meta proof:" split_meta_prf;
- val split_meta_standard = standard split_meta;
+ fun split_meta_standardise () = standard split_meta;
+ val split_meta_standard =
+ timeit_msg "record split_meta standard:" split_meta_standardise;
fun split_object_prf_opt () =
let
- val cPI= cterm_of defs_thy (lambda r0 (Trueprop (P$r0)));
- val (_$Abs(_,_,P$_)) = fst (Logic.dest_equals (concl_of split_meta_standard));
+ val cPI= cterm_of defs_thy (lambda r0 (Trueprop (P $ r0)));
+ val _ $ Abs (_, _, P $ _) = fst (Logic.dest_equals (concl_of split_meta_standard));
val cP = cterm_of defs_thy P;
- val split_meta' = cterm_instantiate [(cP,cPI)] split_meta_standard;
- val (l,r) = HOLogic.dest_eq (HOLogic.dest_Trueprop split_object_prop);
+ val split_meta' = cterm_instantiate [(cP, cPI)] split_meta_standard;
+ val (l, r) = HOLogic.dest_eq (HOLogic.dest_Trueprop split_object_prop);
val cl = cterm_of defs_thy (HOLogic.mk_Trueprop l);
val cr = cterm_of defs_thy (HOLogic.mk_Trueprop r);
- val thl = assume cl (*All r. P r*) (* 1 *)
- |> obj_to_meta_all (*!!r. P r*)
- |> equal_elim split_meta' (*!!n m more. P (ext n m more)*)
- |> meta_to_obj_all (*All n m more. P (ext n m more)*) (* 2*)
- |> implies_intr cl (* 1 ==> 2 *)
- val thr = assume cr (*All n m more. P (ext n m more)*)
- |> obj_to_meta_all (*!!n m more. P (ext n m more)*)
- |> equal_elim (symmetric split_meta') (*!!r. P r*)
- |> meta_to_obj_all (*All r. P r*)
- |> implies_intr cr (* 2 ==> 1 *)
+ val thl =
+ assume cl (*All r. P r*) (* 1 *)
+ |> obj_to_meta_all (*!!r. P r*)
+ |> equal_elim split_meta' (*!!n m more. P (ext n m more)*)
+ |> meta_to_obj_all (*All n m more. P (ext n m more)*) (* 2*)
+ |> implies_intr cl (* 1 ==> 2 *)
+ val thr =
+ assume cr (*All n m more. P (ext n m more)*)
+ |> obj_to_meta_all (*!!n m more. P (ext n m more)*)
+ |> equal_elim (symmetric split_meta') (*!!r. P r*)
+ |> meta_to_obj_all (*All r. P r*)
+ |> implies_intr cr (* 2 ==> 1 *)
in standard (thr COMP (thl COMP iffI)) end;
fun split_object_prf_noopt () =
- prove_standard [] split_object_prop (fn _ =>
- EVERY [rtac iffI 1,
- REPEAT (rtac allI 1), etac allE 1, atac 1,
- rtac allI 1, rtac induct_scheme 1,REPEAT (etac allE 1),atac 1]);
+ prove_standard [] split_object_prop
+ (fn _ =>
+ EVERY
+ [rtac iffI 1,
+ REPEAT (rtac allI 1), etac allE 1, atac 1,
+ rtac allI 1, rtac induct_scheme 1, REPEAT (etac allE 1), atac 1]);
val split_object_prf = quick_and_dirty_prf split_object_prf_noopt split_object_prf_opt;
val split_object = timeit_msg "record split_object proof:" split_object_prf;
fun split_ex_prf () =
- prove_standard [] split_ex_prop (fn _ =>
- EVERY [rtac iffI 1,
- etac exE 1,
- simp_tac (HOL_basic_ss addsimps [split_meta_standard]) 1,
- ex_inst_tac 1,
- (*REPEAT (rtac exI 1),*)
- atac 1,
- REPEAT (etac exE 1),
- rtac exI 1,
- atac 1]);
+ let
+ val ss = HOL_basic_ss addsimps [not_ex RS sym, Not_eq_iff];
+ val P_nm = fst (dest_Free P);
+ val not_P = cterm_of defs_thy (lambda r0 (HOLogic.mk_not (P $ r0)));
+ val so' = named_cterm_instantiate ([(P_nm, not_P)]) split_object;
+ val so'' = simplify ss so';
+ in
+ prove_standard [] split_ex_prop (fn prems => resolve_tac [so''] 1)
+ end;
val split_ex = timeit_msg "record split_ex proof:" split_ex_prf;
fun equality_tac thms =
- let val (s'::s::eqs) = rev thms;
- val ss' = ss addsimps (s'::s::sel_convs_standard);
- val eqs' = map (simplify ss') eqs;
- in simp_tac (HOL_basic_ss addsimps (s'::s::eqs')) 1 end;
-
- fun equality_prf () = prove_standard [] equality_prop (fn {context, ...} =>
- fn st => let val [s, s'] = map #1 (rev (Tactic.innermost_params 1 st)) in
- st |> (res_inst_tac context [((rN, 0), s)] cases_scheme 1
- THEN res_inst_tac context [((rN, 0), s')] cases_scheme 1
- THEN (Subgoal.FOCUS (fn {prems, ...} => equality_tac prems) context 1))
- (* simp_all_tac ss (sel_convs) would also work but is less efficient *)
- end);
- val equality = timeit_msg "record equality proof:" equality_prf;
+ let
+ val s' :: s :: eqs = rev thms;
+ val ss' = ss addsimps (s' :: s :: sel_convs_standard);
+ val eqs' = map (simplify ss') eqs;
+ in simp_tac (HOL_basic_ss addsimps (s' :: s :: eqs')) 1 end;
+
+ fun equality_prf () =
+ prove_standard [] equality_prop (fn {context, ...} =>
+ fn st =>
+ let val [s, s'] = map #1 (rev (Tactic.innermost_params 1 st)) in
+ st |> (res_inst_tac context [((rN, 0), s)] cases_scheme 1 THEN
+ res_inst_tac context [((rN, 0), s')] cases_scheme 1 THEN
+ Subgoal.FOCUS (fn {prems, ...} => equality_tac prems) context 1)
+ (*simp_all_tac ss (sel_convs) would also work but is less efficient*)
+ end);
+ val equality = timeit_msg "record equality proof:" equality_prf;
val ((([sel_convs', upd_convs', sel_defs', upd_defs',
+ fold_congs', unfold_congs',
[split_meta', split_object', split_ex'], derived_defs'],
[surjective', equality']),
[induct_scheme', induct', cases_scheme', cases']), thms_thy) =
defs_thy
|> (PureThy.add_thmss o map (Thm.no_attributes o apfst Binding.name))
[("select_convs", sel_convs_standard),
- ("update_convs", upd_convs),
+ ("update_convs", upd_convs_standard),
("select_defs", sel_defs),
("update_defs", upd_defs),
- ("splits", [split_meta_standard,split_object,split_ex]),
+ ("fold_congs", fold_congs),
+ ("unfold_congs", unfold_congs),
+ ("splits", [split_meta_standard, split_object, split_ex]),
("defs", derived_defs)]
||>> (PureThy.add_thms o map (Thm.no_attributes o apfst Binding.name))
[("surjective", surjective),
@@ -2203,33 +2469,33 @@
(("cases_scheme", cases_scheme), cases_type_global (suffix schemeN name)),
(("cases", cases), cases_type_global name)];
-
val sel_upd_simps = sel_convs' @ upd_convs';
+ val sel_upd_defs = sel_defs' @ upd_defs';
val iffs = [ext_inject]
+ val depth = parent_len + 1;
val final_thy =
thms_thy
|> (snd oo PureThy.add_thmss)
[((Binding.name "simps", sel_upd_simps),
[Simplifier.simp_add, Nitpick_Const_Simps.add]),
((Binding.name "iffs", iffs), [iff_add])]
- |> put_record name (make_record_info args parent fields extension induct_scheme')
- |> put_sel_upd (names @ [full_moreN]) sel_upd_simps
+ |> put_record name (make_record_info args parent fields extension induct_scheme' ext_def)
+ |> 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
|> add_extsplit extension_name ext_split
- |> add_record_splits extension_id (split_meta',split_object',split_ex',induct_scheme')
- |> add_extfields extension_name (fields @ [(full_moreN,moreT)])
- |> add_fieldext (extension_name,snd extension) (names @ [full_moreN])
+ |> add_record_splits extension_id (split_meta', split_object', split_ex', induct_scheme')
+ |> add_extfields extension_name (fields @ [(full_moreN, moreT)])
+ |> add_fieldext (extension_name, snd extension) (names @ [full_moreN])
|> Sign.parent_path;
- in final_thy
- end;
+ in final_thy end;
(* add_record *)
-(*we do all preparations and error checks here, deferring the real
- work to record_definition*)
+(*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 =
let
val _ = Theory.requires thy "Record" "record definitions";
@@ -2305,8 +2571,9 @@
val errs =
err_dup_record @ err_dup_parms @ err_extra_frees @ err_no_fields @
err_dup_fields @ err_bad_fields @ err_dup_sorts;
+
+ val _ = if null errs then () else error (cat_lines errs);
in
- if null errs then () else error (cat_lines errs) ;
thy |> record_definition (args, bname) parent parents bfields
end
handle ERROR msg => cat_error msg ("Failed to define record " ^ quote bname);
--- a/src/HOL/Tools/res_atp.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/res_atp.ML Thu Oct 01 07:40:25 2009 +0200
@@ -520,12 +520,17 @@
fun get_relevant max_new theory_const (ctxt, (chain_ths, th)) goal_cls =
let
val thy = ProofContext.theory_of ctxt
+ val isFO = isFO thy goal_cls
val included_thms = get_clasimp_atp_lemmas ctxt
val included_cls = included_thms |> ResAxioms.cnf_rules_pairs thy |> make_unique
- |> restrict_to_logic thy (isFO thy goal_cls)
+ |> restrict_to_logic thy isFO
|> remove_unwanted_clauses
+ val axcls = relevance_filter max_new theory_const thy included_cls (map prop_of goal_cls)
+ val white_thms = filter check_named (map ResAxioms.pairname
+ (whitelist_fo @ (if isFO then [] else whitelist_ho) @ chain_ths))
+ val white_cls = ResAxioms.cnf_rules_pairs thy white_thms
in
- relevance_filter max_new theory_const thy included_cls (map prop_of goal_cls)
+ white_cls @ axcls
end;
(* prepare for passing to writer,
@@ -533,11 +538,6 @@
fun prepare_clauses dfg goal_cls chain_ths axcls extra_cls thy =
let
val isFO = isFO thy goal_cls
- val white_thms = filter check_named (map ResAxioms.pairname
- (whitelist_fo @ (if isFO then [] else whitelist_ho) @ chain_ths))
- val white_cls = ResAxioms.cnf_rules_pairs thy white_thms
- val extra_cls = white_cls @ extra_cls
- val axcls = white_cls @ axcls
val ccls = subtract_cls goal_cls extra_cls
val _ = app (fn th => Output.debug (fn _ => Display.string_of_thm_global thy th)) ccls
val ccltms = map prop_of ccls
--- a/src/HOL/Tools/res_axioms.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/res_axioms.ML Thu Oct 01 07:40:25 2009 +0200
@@ -16,7 +16,8 @@
val combinators: thm -> thm
val neg_conjecture_clauses: Proof.context -> thm -> int -> thm list * (string * typ) list
val atpset_rules_of: Proof.context -> (string * thm) list
- val suppress_endtheory: bool ref (*for emergency use where endtheory causes problems*)
+ val suppress_endtheory: bool Unsynchronized.ref
+ (*for emergency use where endtheory causes problems*)
val setup: theory -> theory
end;
@@ -66,11 +67,11 @@
prefix for the Skolem constant.*)
fun declare_skofuns s th =
let
- val nref = ref 0
+ val nref = Unsynchronized.ref 0
fun dec_sko (Const ("Ex",_) $ (xtp as Abs (_, T, p))) (axs, thy) =
(*Existential: declare a Skolem function, then insert into body and continue*)
let
- val cname = "sko_" ^ s ^ "_" ^ Int.toString (inc nref)
+ val cname = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc nref)
val args0 = OldTerm.term_frees xtp (*get the formal parameter list*)
val Ts = map type_of args0
val extraTs = rhs_extra_types (Ts ---> T) xtp
@@ -97,14 +98,14 @@
(*Traverse a theorem, accumulating Skolem function definitions.*)
fun assume_skofuns s th =
- let val sko_count = ref 0
+ let val sko_count = Unsynchronized.ref 0
fun dec_sko (Const ("Ex",_) $ (xtp as Abs(_,T,p))) defs =
(*Existential: declare a Skolem function, then insert into body and continue*)
let val skos = map (#1 o Logic.dest_equals) defs (*existing sko fns*)
val args = OldTerm.term_frees xtp \\ skos (*the formal parameters*)
val Ts = map type_of args
val cT = Ts ---> T
- val id = "sko_" ^ s ^ "_" ^ Int.toString (inc sko_count)
+ val id = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc sko_count)
val c = Free (id, cT)
val rhs = list_abs_free (map dest_Free args,
HOLogic.choice_const T $ xtp)
@@ -449,7 +450,7 @@
end;
-val suppress_endtheory = ref false;
+val suppress_endtheory = Unsynchronized.ref false;
fun clause_cache_endtheory thy =
if ! suppress_endtheory then NONE
--- a/src/HOL/Tools/res_hol_clause.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/res_hol_clause.ML Thu Oct 01 07:40:25 2009 +0200
@@ -23,6 +23,7 @@
datatype literal = Literal of polarity * combterm
datatype clause = Clause of {clause_id: clause_id, axiom_name: axiom_name, th: thm,
kind: ResClause.kind,literals: literal list, ctypes_sorts: typ list}
+ val type_of_combterm: combterm -> ResClause.fol_type
val strip_comb: combterm -> combterm * combterm list
val literals_of_term: theory -> term -> literal list * typ list
exception TOO_TRIVIAL
--- a/src/HOL/Tools/res_reconstruct.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/res_reconstruct.ML Thu Oct 01 07:40:25 2009 +0200
@@ -17,10 +17,10 @@
(* extracting lemma list*)
val find_failure: string -> string option
val lemma_list: bool -> string ->
- string * string vector * (int * int) * Proof.context * Thm.thm * int -> string
+ string * string vector * (int * int) * Proof.context * Thm.thm * int -> string * string list
(* structured proofs *)
val structured_proof: string ->
- string * string vector * (int * int) * Proof.context * Thm.thm * int -> string
+ string * string vector * (int * int) * Proof.context * Thm.thm * int -> string * string list
end;
structure ResReconstruct : RES_RECONSTRUCT =
@@ -523,7 +523,7 @@
let
val last_axiom = Vector.length thm_names
fun is_axiom n = n <= last_axiom
- fun is_conj n = n >= #1 conj_count andalso n < #1 conj_count + #2 conj_count
+ fun is_conj n = n >= fst conj_count andalso n < fst conj_count + snd conj_count
fun getname i = Vector.sub(thm_names, i-1)
in
(sort_distinct string_ord (filter (fn x => x <> "??.unknown")
@@ -554,9 +554,10 @@
fun lemma_list dfg name result =
let val (lemmas, used_conj) = extract_lemmas (get_step_nums dfg) result
- in sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas ^
+ in (sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas ^
(if used_conj then ""
- else "\nWarning: Goal is provable because context is inconsistent.")
+ else "\nWarning: Goal is provable because context is inconsistent."),
+ nochained lemmas)
end;
(* === Extracting structured Isar-proof === *)
@@ -567,11 +568,11 @@
val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
val proofextract = get_proof_extract proof
val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
- val one_line_proof = lemma_list false name result
+ val (one_line_proof, lemma_names) = lemma_list false name result
val structured = if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
else decode_tstp_file cnfs ctxt goal subgoalno thm_names
in
- one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured
+ (one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured, lemma_names)
end
end;
--- a/src/HOL/Tools/sat_funcs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/sat_funcs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -48,10 +48,10 @@
signature SAT =
sig
- val trace_sat: bool ref (* input: print trace messages *)
- val solver: string ref (* input: name of SAT solver to be used *)
- val counter: int ref (* output: number of resolution steps during last proof replay *)
- val rawsat_thm: cterm list -> thm
+ val trace_sat: bool Unsynchronized.ref (* input: print trace messages *)
+ val solver: string Unsynchronized.ref (* input: name of SAT solver to be used *)
+ val counter: int Unsynchronized.ref (* output: number of resolution steps during last proof replay *)
+ val rawsat_thm: Proof.context -> cterm list -> thm
val rawsat_tac: Proof.context -> int -> tactic
val sat_tac: Proof.context -> int -> tactic
val satx_tac: Proof.context -> int -> tactic
@@ -60,11 +60,12 @@
functor SATFunc(cnf : CNF) : SAT =
struct
-val trace_sat = ref false;
+val trace_sat = Unsynchronized.ref false;
-val solver = ref "zchaff_with_proofs"; (* see HOL/Tools/sat_solver.ML for possible values *)
+val solver = Unsynchronized.ref "zchaff_with_proofs";
+ (*see HOL/Tools/sat_solver.ML for possible values*)
-val counter = ref 0;
+val counter = Unsynchronized.ref 0;
val resolution_thm =
@{lemma "(P ==> False) ==> (~ P ==> False) ==> False" by (rule case_split)}
@@ -191,7 +192,7 @@
" (hyps: " ^ ML_Syntax.print_list
(Syntax.string_of_term_global (theory_of_thm c_new)) (#hyps (rep_thm c_new)) ^ ")")
else ()
- val _ = inc counter
+ val _ = Unsynchronized.inc counter
in
(c_new, new_hyps)
end
@@ -295,9 +296,7 @@
(* hyps). *)
(* ------------------------------------------------------------------------- *)
-(* Thm.cterm list -> Thm.thm *)
-
-fun rawsat_thm clauses =
+fun rawsat_thm ctxt clauses =
let
(* remove premises that equal "True" *)
val clauses' = filter (fn clause =>
@@ -310,7 +309,7 @@
((cnf.is_clause o HOLogic.dest_Trueprop o Thm.term_of) clause
handle TERM ("dest_Trueprop", _) => false)
orelse (
- warning ("Ignoring non-clausal premise " ^ Display.string_of_cterm clause);
+ warning ("Ignoring non-clausal premise " ^ Syntax.string_of_term ctxt (Thm.term_of clause));
false)) clauses'
(* remove trivial clauses -- this is necessary because zChaff removes *)
(* trivial clauses during preprocessing, and otherwise our clause *)
@@ -323,7 +322,8 @@
(* sorted in ascending order *)
val sorted_clauses = sort (TermOrd.fast_term_ord o pairself Thm.term_of) nontrivial_clauses
val _ = if !trace_sat then
- tracing ("Sorted non-trivial clauses:\n" ^ cat_lines (map Display.string_of_cterm sorted_clauses))
+ tracing ("Sorted non-trivial clauses:\n" ^
+ cat_lines (map (Syntax.string_of_term ctxt o Thm.term_of) sorted_clauses))
else ()
(* translate clauses from HOL terms to PropLogic.prop_formula *)
val (fms, atom_table) = fold_map (PropLogic.prop_formula_of_term o HOLogic.dest_Trueprop o Thm.term_of) sorted_clauses Termtab.empty
@@ -411,7 +411,8 @@
(* ------------------------------------------------------------------------- *)
fun rawsat_tac ctxt i =
- Subgoal.FOCUS (fn {prems, ...} => rtac (rawsat_thm (map cprop_of prems)) 1) ctxt i;
+ Subgoal.FOCUS (fn {context = ctxt', prems, ...} =>
+ rtac (rawsat_thm ctxt' (map cprop_of prems)) 1) ctxt i;
(* ------------------------------------------------------------------------- *)
(* pre_cnf_tac: converts the i-th subgoal *)
--- a/src/HOL/Tools/sat_solver.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/sat_solver.ML Thu Oct 01 07:40:25 2009 +0200
@@ -26,7 +26,7 @@
val read_dimacs_cnf_file : Path.T -> PropLogic.prop_formula
(* generic solver interface *)
- val solvers : (string * solver) list ref
+ val solvers : (string * solver) list Unsynchronized.ref
val add_solver : string * solver -> unit
val invoke_solver : string -> solver (* exception Option *)
end;
@@ -363,7 +363,7 @@
(* solvers: a (reference to a) table of all registered SAT solvers *)
(* ------------------------------------------------------------------------- *)
- val solvers = ref ([] : (string * solver) list);
+ val solvers = Unsynchronized.ref ([] : (string * solver) list);
(* ------------------------------------------------------------------------- *)
(* add_solver: updates 'solvers' by adding a new solver *)
@@ -629,7 +629,7 @@
val _ = init_array (cnf, 0)
(* optimization for the common case where MiniSat "R"s clauses in their *)
(* original order: *)
- val last_ref_clause = ref (number_of_clauses - 1)
+ val last_ref_clause = Unsynchronized.ref (number_of_clauses - 1)
(* search the 'clauses' array for the given list of literals 'lits', *)
(* starting at index '!last_ref_clause + 1' *)
(* int list -> int option *)
@@ -661,17 +661,17 @@
| NONE => raise INVALID_PROOF ("File format error: number expected (" ^ quote s ^ " encountered).")
)
(* parse the proof file *)
- val clause_table = ref (Inttab.empty : int list Inttab.table)
- val empty_id = ref ~1
+ val clause_table = Unsynchronized.ref (Inttab.empty : int list Inttab.table)
+ val empty_id = Unsynchronized.ref ~1
(* contains a mapping from clause IDs as used by MiniSat to clause IDs in *)
(* our proof format, where original clauses are numbered starting from 0 *)
- val clause_id_map = ref (Inttab.empty : int Inttab.table)
+ val clause_id_map = Unsynchronized.ref (Inttab.empty : int Inttab.table)
fun sat_to_proof id = (
case Inttab.lookup (!clause_id_map) id of
SOME id' => id'
| NONE => raise INVALID_PROOF ("Clause ID " ^ Int.toString id ^ " used, but not defined.")
)
- val next_id = ref (number_of_clauses - 1)
+ val next_id = Unsynchronized.ref (number_of_clauses - 1)
(* string list -> unit *)
fun process_tokens [] =
()
@@ -708,7 +708,7 @@
| unevens (x :: _ :: xs) = x :: unevens xs
val rs = (map sat_to_proof o unevens o map int_from_string) ids
(* extend the mapping of clause IDs with this newly defined ID *)
- val proof_id = inc next_id
+ val proof_id = Unsynchronized.inc next_id
val _ = clause_id_map := Inttab.update_new (cid, proof_id) (!clause_id_map)
handle Inttab.DUP _ => raise INVALID_PROOF ("File format error: clause " ^ id ^ " defined more than once (in \"C\").")
in
@@ -821,9 +821,9 @@
| NONE => raise INVALID_PROOF ("File format error: number expected (" ^ quote s ^ " encountered).")
)
(* parse the "resolve_trace" file *)
- val clause_offset = ref ~1
- val clause_table = ref (Inttab.empty : int list Inttab.table)
- val empty_id = ref ~1
+ val clause_offset = Unsynchronized.ref ~1
+ val clause_table = Unsynchronized.ref (Inttab.empty : int list Inttab.table)
+ val empty_id = Unsynchronized.ref ~1
(* string list -> unit *)
fun process_tokens [] =
()
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/transfer.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,241 @@
+(* Author: Amine Chaieb, University of Cambridge, 2009
+ Jeremy Avigad, Carnegie Mellon University
+*)
+
+signature TRANSFER =
+sig
+ type data
+ type entry
+ val get: Proof.context -> data
+ val del: attribute
+ val setup: theory -> theory
+end;
+
+structure Transfer : TRANSFER =
+struct
+
+val eq_thm = Thm.eq_thm;
+
+type entry = {inj : thm list, emb : thm list, ret : thm list, cong : thm list,
+ guess : bool, hints : string list};
+type data = simpset * (thm * entry) list;
+
+structure Data = GenericDataFun
+(
+ type T = data;
+ val empty = (HOL_ss, []);
+ val extend = I;
+ fun merge _ ((ss1, e1), (ss2, e2)) =
+ (merge_ss (ss1, ss2), AList.merge eq_thm (K true) (e1, e2));
+);
+
+val get = Data.get o Context.Proof;
+
+fun del_data key = apsnd (remove (eq_fst eq_thm) (key, []));
+
+val del = Thm.declaration_attribute (Data.map o del_data);
+val add_ss = Thm.declaration_attribute
+ (fn th => Data.map (fn (ss,data) => (ss addsimps [th], data)));
+
+val del_ss = Thm.declaration_attribute
+ (fn th => Data.map (fn (ss,data) => (ss delsimps [th], data)));
+
+val transM_pat = (Thm.dest_arg1 o Thm.dest_arg o cprop_of) @{thm TransferMorphism_def};
+
+fun merge_update eq m (k,v) [] = [(k,v)]
+ | merge_update eq m (k,v) ((k',v')::al) =
+ if eq (k,k') then (k',m (v,v')):: al else (k',v') :: merge_update eq m (k,v) al
+
+fun C f x y = f y x
+
+fun simpset_of_entry injonly {inj = inj, emb = emb, ret = ret, cong = cg, guess = g, hints = hints} =
+ HOL_ss addsimps inj addsimps (if injonly then [] else emb@ret) addcongs cg;
+
+fun basic_transfer_rule injonly a0 D0 e leave ctxt0 th =
+ let
+ val ([a,D], ctxt) = apfst (map Drule.dest_term o snd) (Variable.import true (map Drule.mk_term [a0, D0]) ctxt0)
+ val (aT,bT) =
+ let val T = typ_of (ctyp_of_term a)
+ in (Term.range_type T, Term.domain_type T)
+ end
+ val ctxt' = (Variable.declare_term (term_of a) o Variable.declare_term (term_of D) o Variable.declare_thm th) ctxt
+ val ns = filter (fn i => Type.could_unify (snd i, aT) andalso not (fst (fst i) mem_string leave)) (Term.add_vars (prop_of th) [])
+ val (ins, ctxt'') = Variable.variant_fixes (map (fst o fst) ns) ctxt'
+ val cns = map ((cterm_of o ProofContext.theory_of) ctxt'' o Var) ns
+ val cfis = map ((cterm_of o ProofContext.theory_of) ctxt'' o (fn n => Free (n, bT))) ins
+ val cis = map (Thm.capply a) cfis
+ val (hs,ctxt''') = Assumption.add_assumes (map (fn ct => Thm.capply @{cterm "Trueprop"} (Thm.capply D ct)) cfis) ctxt''
+ val th1 = Drule.cterm_instantiate (cns~~ cis) th
+ val th2 = fold (C implies_elim) hs (fold_rev implies_intr (map cprop_of hs) th1)
+ val th3 = Simplifier.asm_full_simplify (Simplifier.context ctxt''' (simpset_of_entry injonly e))
+ (fold_rev implies_intr (map cprop_of hs) th2)
+in hd (Variable.export ctxt''' ctxt0 [th3]) end;
+
+local
+fun transfer_ruleh a D leave ctxt th =
+ let val (ss,al) = get ctxt
+ val a0 = cterm_of (ProofContext.theory_of ctxt) a
+ val D0 = cterm_of (ProofContext.theory_of ctxt) D
+ fun h (th', e) = let val (a',D') = (Thm.dest_binop o Thm.dest_arg o cprop_of) th'
+ in if a0 aconvc a' andalso D0 aconvc D' then SOME e else NONE
+ end
+ in case get_first h al of
+ SOME e => basic_transfer_rule false a0 D0 e leave ctxt th
+ | NONE => error "Transfer: corresponding instance not found in context-data"
+ end
+in fun transfer_rule (a,D) leave (gctxt,th) =
+ (gctxt, transfer_ruleh a D leave (Context.proof_of gctxt) th)
+end;
+
+fun splits P [] = []
+ | splits P (xxs as (x::xs)) =
+ let val pss = filter (P x) xxs
+ val qss = filter_out (P x) xxs
+ in if null pss then [qss] else if null qss then [pss] else pss:: splits P qss
+ end
+
+fun all_transfers leave (gctxt,th) =
+ let
+ val ctxt = Context.proof_of gctxt
+ val tys = map snd (Term.add_vars (prop_of th) [])
+ val _ = if null tys then error "transfer: Unable to guess instance" else ()
+ val tyss = splits (curry Type.could_unify) tys
+ val get_ty = typ_of o ctyp_of_term o fst o Thm.dest_binop o Thm.dest_arg o cprop_of
+ val get_aD = Thm.dest_binop o Thm.dest_arg o cprop_of
+ val insts =
+ map_filter (fn tys =>
+ get_first (fn (k,ss) => if Type.could_unify (hd tys, range_type (get_ty k))
+ then SOME (get_aD k, ss)
+ else NONE) (snd (get ctxt))) tyss
+ val _ = if null insts then error "Transfer guesser: there were no possible instances, use direction: in order to provide a direction" else ()
+ val ths = map (fn ((a,D),e) => basic_transfer_rule false a D e leave ctxt th) insts
+ val cth = Conjunction.intr_balanced ths
+ in (gctxt, cth)
+ end;
+
+fun transfer_rule_by_hint ls leave (gctxt,th) =
+ let
+ val ctxt = Context.proof_of gctxt
+ val get_aD = Thm.dest_binop o Thm.dest_arg o cprop_of
+ val insts =
+ map_filter (fn (k,e) => if exists (fn l => l mem_string (#hints e)) ls
+ then SOME (get_aD k, e) else NONE)
+ (snd (get ctxt))
+ val _ = if null insts then error "Transfer: No labels provided are stored in the context" else ()
+ val ths = map (fn ((a,D),e) => basic_transfer_rule false a D e leave ctxt th) insts
+ val cth = Conjunction.intr_balanced ths
+ in (gctxt, cth)
+ end;
+
+
+fun transferred_attribute ls NONE leave =
+ if null ls then all_transfers leave else transfer_rule_by_hint ls leave
+ | transferred_attribute _ (SOME (a,D)) leave = transfer_rule (a,D) leave
+
+ (* Add data to the context *)
+fun gen_merge_entries {inj = inj0, emb = emb0, ret = ret0, cong = cg0, guess = g0, hints = hints0}
+ ({inj = inj1, emb = emb1, ret = ret1, cong = cg1, guess = g1, hints = hints1},
+ {inj = inj2, emb = emb2, ret = ret2, cong = cg2, guess = g2, hints = hints2})
+ =
+ let fun h xs0 xs ys = subtract Thm.eq_thm xs0 (merge Thm.eq_thm (xs,ys)) in
+ {inj = h inj0 inj1 inj2, emb = h emb0 emb1 emb2,
+ ret = h ret0 ret1 ret2, cong = h cg0 cg1 cg2, guess = g1 andalso g2,
+ hints = subtract (op = : string*string -> bool) hints0
+ (hints1 union_string hints2)}
+ end;
+
+local
+ val h = curry (merge Thm.eq_thm)
+in
+fun merge_entries ({inj = inj1, emb = emb1, ret = ret1, cong = cg1, guess = g1, hints = hints1},
+ {inj = inj2, emb = emb2, ret = ret2, cong = cg2, guess = g2, hints = hints2}) =
+ {inj = h inj1 inj2, emb = h emb1 emb2, ret = h ret1 ret2, cong = h cg1 cg2, guess = g1 andalso g2, hints = hints1 union_string hints2}
+end;
+
+fun add ((inja,injd), (emba,embd), (reta,retd), (cga,cgd), g, (hintsa, hintsd)) =
+ Thm.declaration_attribute (fn key => fn context => context |> Data.map
+ (fn (ss, al) =>
+ let
+ val _ = ((let val _ = Thm.match (transM_pat, (Thm.dest_arg o cprop_of) key)
+ in 0 end)
+ handle MATCH => error "Attribute expected Theorem of the form : TransferMorphism A a B b")
+ val e0 = {inj = inja, emb = emba, ret = reta, cong = cga, guess = g, hints = hintsa}
+ val ed = {inj = injd, emb = embd, ret = retd, cong = cgd, guess = g, hints = hintsd}
+ val entry =
+ if g then
+ let val (a0,D0) = (Thm.dest_binop o Thm.dest_arg o cprop_of) key
+ val ctxt0 = ProofContext.init (Thm.theory_of_thm key)
+ val inj' = if null inja then #inj (case AList.lookup eq_thm al key of SOME e => e | NONE => error "Transfer: can not generate return rules on the fly, either add injectivity axiom or force manual mode with mode: manual")
+ else inja
+ val ret' = merge Thm.eq_thm (reta, map (fn th => basic_transfer_rule true a0 D0 {inj = inj', emb = [], ret = [], cong = cga, guess = g, hints = hintsa} [] ctxt0 th RS sym) emba)
+ in {inj = inja, emb = emba, ret = ret', cong = cga, guess = g, hints = hintsa} end
+ else e0
+ in (ss, merge_update eq_thm (gen_merge_entries ed) (key, entry) al)
+ end));
+
+
+
+(* concrete syntax *)
+
+local
+
+fun keyword k = Scan.lift (Args.$$$ k) >> K ()
+fun keywordC k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
+
+val congN = "cong"
+val injN = "inj"
+val embedN = "embed"
+val returnN = "return"
+val addN = "add"
+val delN = "del"
+val modeN = "mode"
+val automaticN = "automatic"
+val manualN = "manual"
+val directionN = "direction"
+val labelsN = "labels"
+val leavingN = "leaving"
+
+val any_keyword = keywordC congN || keywordC injN || keywordC embedN || keywordC returnN || keywordC directionN || keywordC modeN || keywordC delN || keywordC labelsN || keywordC leavingN
+
+val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat
+val terms = thms >> map Drule.dest_term
+val types = thms >> (Logic.dest_type o HOLogic.dest_Trueprop o prop_of o hd)
+val name = Scan.lift Args.name
+val names = Scan.repeat (Scan.unless any_keyword name)
+fun optional scan = Scan.optional scan []
+fun optional2 scan = Scan.optional scan ([],[])
+
+val mode = keywordC modeN |-- ((Scan.lift (Args.$$$ manualN) >> K false) || (Scan.lift (Args.$$$ automaticN) >> K true))
+val inj = (keywordC injN |-- thms) -- optional (keywordC delN |-- thms)
+val embed = (keywordC embedN |-- thms) -- optional (keywordC delN |-- thms)
+val return = (keywordC returnN |-- thms) -- optional (keywordC delN |-- thms)
+val cong = (keywordC congN |-- thms) -- optional (keywordC delN |-- thms)
+val addscan = Scan.unless any_keyword (keyword addN)
+val labels = (keywordC labelsN |-- names) -- optional (keywordC delN |-- names)
+val entry = Scan.optional mode true -- optional2 inj -- optional2 embed -- optional2 return -- optional2 cong -- optional2 labels
+
+val transf_add = addscan |-- entry
+in
+
+val install_att_syntax =
+ (Scan.lift (Args.$$$ delN >> K del) ||
+ transf_add
+ >> (fn (((((g, inj), embed), ret), cg), hints) => add (inj, embed, ret, cg, g, hints)))
+
+val transferred_att_syntax = (optional names -- Scan.option (keywordC directionN |-- (Args.term -- Args.term))
+ -- optional (keywordC leavingN |-- names) >> (fn ((hints, aD),leave) => transferred_attribute hints aD leave));
+
+end;
+
+
+(* theory setup *)
+
+val setup =
+ Attrib.setup @{binding transfer} install_att_syntax
+ "Installs transfer data" #>
+ Attrib.setup @{binding transfer_simps} (Attrib.add_del add_ss del_ss)
+ "simp rules for transfer" #>
+ Attrib.setup @{binding transferred} transferred_att_syntax
+ "Transfers theorems";
+
+end;
--- a/src/HOL/Tools/transfer_data.ML Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,242 +0,0 @@
-(* Title: Tools/transfer.ML
- Author: Amine Chaieb, University of Cambridge, 2009
- Jeremy Avigad, Carnegie Mellon University
-*)
-
-signature TRANSFER_DATA =
-sig
- type data
- type entry
- val get: Proof.context -> data
- val del: attribute
- val add: attribute
- val setup: theory -> theory
-end;
-
-structure TransferData (* : TRANSFER_DATA*) =
-struct
-type entry = {inj : thm list , emb : thm list , ret : thm list , cong : thm list, guess : bool, hints : string list};
-type data = simpset * (thm * entry) list;
-
-val eq_key = Thm.eq_thm;
-fun eq_data arg = eq_fst eq_key arg;
-
-structure Data = GenericDataFun
-(
- type T = data;
- val empty = (HOL_ss, []);
- val extend = I;
- fun merge _ ((ss, e), (ss', e')) =
- (merge_ss (ss, ss'), AList.merge eq_key (K true) (e, e'));
-);
-
-val get = Data.get o Context.Proof;
-
-fun del_data key = apsnd (remove eq_data (key, []));
-
-val del = Thm.declaration_attribute (Data.map o del_data);
-val add_ss = Thm.declaration_attribute
- (fn th => Data.map (fn (ss,data) => (ss addsimps [th], data)));
-
-val del_ss = Thm.declaration_attribute
- (fn th => Data.map (fn (ss,data) => (ss delsimps [th], data)));
-
-val transM_pat = (Thm.dest_arg1 o Thm.dest_arg o cprop_of) @{thm TransferMorphism_def};
-
-fun merge_update eq m (k,v) [] = [(k,v)]
- | merge_update eq m (k,v) ((k',v')::al) =
- if eq (k,k') then (k',m (v,v')):: al else (k',v') :: merge_update eq m (k,v) al
-
-fun C f x y = f y x
-
-fun simpset_of_entry injonly {inj = inj, emb = emb, ret = ret, cong = cg, guess = g, hints = hints} =
- HOL_ss addsimps inj addsimps (if injonly then [] else emb@ret) addcongs cg;
-
-fun basic_transfer_rule injonly a0 D0 e leave ctxt0 th =
- let
- val ([a,D], ctxt) = apfst (map Drule.dest_term o snd) (Variable.import true (map Drule.mk_term [a0, D0]) ctxt0)
- val (aT,bT) =
- let val T = typ_of (ctyp_of_term a)
- in (Term.range_type T, Term.domain_type T)
- end
- val ctxt' = (Variable.declare_term (term_of a) o Variable.declare_term (term_of D) o Variable.declare_thm th) ctxt
- val ns = filter (fn i => Type.could_unify (snd i, aT) andalso not (fst (fst i) mem_string leave)) (Term.add_vars (prop_of th) [])
- val (ins, ctxt'') = Variable.variant_fixes (map (fst o fst) ns) ctxt'
- val cns = map ((cterm_of o ProofContext.theory_of) ctxt'' o Var) ns
- val cfis = map ((cterm_of o ProofContext.theory_of) ctxt'' o (fn n => Free (n, bT))) ins
- val cis = map (Thm.capply a) cfis
- val (hs,ctxt''') = Assumption.add_assumes (map (fn ct => Thm.capply @{cterm "Trueprop"} (Thm.capply D ct)) cfis) ctxt''
- val th1 = Drule.cterm_instantiate (cns~~ cis) th
- val th2 = fold (C implies_elim) hs (fold_rev implies_intr (map cprop_of hs) th1)
- val th3 = Simplifier.asm_full_simplify (Simplifier.context ctxt''' (simpset_of_entry injonly e))
- (fold_rev implies_intr (map cprop_of hs) th2)
-in hd (Variable.export ctxt''' ctxt0 [th3]) end;
-
-local
-fun transfer_ruleh a D leave ctxt th =
- let val (ss,al) = get ctxt
- val a0 = cterm_of (ProofContext.theory_of ctxt) a
- val D0 = cterm_of (ProofContext.theory_of ctxt) D
- fun h (th', e) = let val (a',D') = (Thm.dest_binop o Thm.dest_arg o cprop_of) th'
- in if a0 aconvc a' andalso D0 aconvc D' then SOME e else NONE
- end
- in case get_first h al of
- SOME e => basic_transfer_rule false a0 D0 e leave ctxt th
- | NONE => error "Transfer: corresponding instance not found in context-data"
- end
-in fun transfer_rule (a,D) leave (gctxt,th) =
- (gctxt, transfer_ruleh a D leave (Context.proof_of gctxt) th)
-end;
-
-fun splits P [] = []
- | splits P (xxs as (x::xs)) =
- let val pss = filter (P x) xxs
- val qss = filter_out (P x) xxs
- in if null pss then [qss] else if null qss then [pss] else pss:: splits P qss
- end
-
-fun all_transfers leave (gctxt,th) =
- let
- val ctxt = Context.proof_of gctxt
- val tys = map snd (Term.add_vars (prop_of th) [])
- val _ = if null tys then error "transfer: Unable to guess instance" else ()
- val tyss = splits (curry Type.could_unify) tys
- val get_ty = typ_of o ctyp_of_term o fst o Thm.dest_binop o Thm.dest_arg o cprop_of
- val get_aD = Thm.dest_binop o Thm.dest_arg o cprop_of
- val insts =
- map_filter (fn tys =>
- get_first (fn (k,ss) => if Type.could_unify (hd tys, range_type (get_ty k))
- then SOME (get_aD k, ss)
- else NONE) (snd (get ctxt))) tyss
- val _ = if null insts then error "Transfer guesser: there were no possible instances, use direction: in order to provide a direction" else ()
- val ths = map (fn ((a,D),e) => basic_transfer_rule false a D e leave ctxt th) insts
- val cth = Conjunction.intr_balanced ths
- in (gctxt, cth)
- end;
-
-fun transfer_rule_by_hint ls leave (gctxt,th) =
- let
- val ctxt = Context.proof_of gctxt
- val get_aD = Thm.dest_binop o Thm.dest_arg o cprop_of
- val insts =
- map_filter (fn (k,e) => if exists (fn l => l mem_string (#hints e)) ls
- then SOME (get_aD k, e) else NONE)
- (snd (get ctxt))
- val _ = if null insts then error "Transfer: No labels provided are stored in the context" else ()
- val ths = map (fn ((a,D),e) => basic_transfer_rule false a D e leave ctxt th) insts
- val cth = Conjunction.intr_balanced ths
- in (gctxt, cth)
- end;
-
-
-fun transferred_attribute ls NONE leave =
- if null ls then all_transfers leave else transfer_rule_by_hint ls leave
- | transferred_attribute _ (SOME (a,D)) leave = transfer_rule (a,D) leave
-
- (* Add data to the context *)
-fun gen_merge_entries {inj = inj0, emb = emb0, ret = ret0, cong = cg0, guess = g0, hints = hints0}
- ({inj = inj1, emb = emb1, ret = ret1, cong = cg1, guess = g1, hints = hints1},
- {inj = inj2, emb = emb2, ret = ret2, cong = cg2, guess = g2, hints = hints2})
- =
- let fun h xs0 xs ys = subtract Thm.eq_thm xs0 (merge Thm.eq_thm (xs,ys)) in
- {inj = h inj0 inj1 inj2, emb = h emb0 emb1 emb2,
- ret = h ret0 ret1 ret2, cong = h cg0 cg1 cg2, guess = g1 andalso g2,
- hints = subtract (op = : string*string -> bool) hints0
- (hints1 union_string hints2)}
- end;
-
-local
- val h = curry (merge Thm.eq_thm)
-in
-fun merge_entries ({inj = inj1, emb = emb1, ret = ret1, cong = cg1, guess = g1, hints = hints1},
- {inj = inj2, emb = emb2, ret = ret2, cong = cg2, guess = g2, hints = hints2}) =
- {inj = h inj1 inj2, emb = h emb1 emb2, ret = h ret1 ret2, cong = h cg1 cg2, guess = g1 andalso g2, hints = hints1 union_string hints2}
-end;
-
-fun add ((inja,injd), (emba,embd), (reta,retd), (cga,cgd), g, (hintsa, hintsd)) =
- Thm.declaration_attribute (fn key => fn context => context |> Data.map
- (fn (ss, al) =>
- let
- val _ = ((let val _ = Thm.match (transM_pat, (Thm.dest_arg o cprop_of) key)
- in 0 end)
- handle MATCH => error "Attribute expected Theorem of the form : TransferMorphism A a B b")
- val e0 = {inj = inja, emb = emba, ret = reta, cong = cga, guess = g, hints = hintsa}
- val ed = {inj = injd, emb = embd, ret = retd, cong = cgd, guess = g, hints = hintsd}
- val entry =
- if g then
- let val (a0,D0) = (Thm.dest_binop o Thm.dest_arg o cprop_of) key
- val ctxt0 = ProofContext.init (Thm.theory_of_thm key)
- val inj' = if null inja then #inj (case AList.lookup eq_key al key of SOME e => e | NONE => error "Transfer: can not generate return rules on the fly, either add injectivity axiom or force manual mode with mode: manual")
- else inja
- val ret' = merge Thm.eq_thm (reta, map (fn th => basic_transfer_rule true a0 D0 {inj = inj', emb = [], ret = [], cong = cga, guess = g, hints = hintsa} [] ctxt0 th RS sym) emba)
- in {inj = inja, emb = emba, ret = ret', cong = cga, guess = g, hints = hintsa} end
- else e0
- in (ss, merge_update eq_key (gen_merge_entries ed) (key, entry) al)
- end));
-
-
-
-(* concrete syntax *)
-
-local
-
-fun keyword k = Scan.lift (Args.$$$ k) >> K ()
-fun keywordC k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
-
-val congN = "cong"
-val injN = "inj"
-val embedN = "embed"
-val returnN = "return"
-val addN = "add"
-val delN = "del"
-val modeN = "mode"
-val automaticN = "automatic"
-val manualN = "manual"
-val directionN = "direction"
-val labelsN = "labels"
-val leavingN = "leaving"
-
-val any_keyword = keywordC congN || keywordC injN || keywordC embedN || keywordC returnN || keywordC directionN || keywordC modeN || keywordC delN || keywordC labelsN || keywordC leavingN
-
-val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat
-val terms = thms >> map Drule.dest_term
-val types = thms >> (Logic.dest_type o HOLogic.dest_Trueprop o prop_of o hd)
-val name = Scan.lift Args.name
-val names = Scan.repeat (Scan.unless any_keyword name)
-fun optional scan = Scan.optional scan []
-fun optional2 scan = Scan.optional scan ([],[])
-
-val mode = keywordC modeN |-- ((Scan.lift (Args.$$$ manualN) >> K false) || (Scan.lift (Args.$$$ automaticN) >> K true))
-val inj = (keywordC injN |-- thms) -- optional (keywordC delN |-- thms)
-val embed = (keywordC embedN |-- thms) -- optional (keywordC delN |-- thms)
-val return = (keywordC returnN |-- thms) -- optional (keywordC delN |-- thms)
-val cong = (keywordC congN |-- thms) -- optional (keywordC delN |-- thms)
-val addscan = Scan.unless any_keyword (keyword addN)
-val labels = (keywordC labelsN |-- names) -- optional (keywordC delN |-- names)
-val entry = Scan.optional mode true -- optional2 inj -- optional2 embed -- optional2 return -- optional2 cong -- optional2 labels
-
-val transf_add = addscan |-- entry
-in
-
-val install_att_syntax =
- (Scan.lift (Args.$$$ delN >> K del) ||
- transf_add
- >> (fn (((((g, inj), embed), ret), cg), hints) => add (inj, embed, ret, cg, g, hints)))
-
-val transferred_att_syntax = (optional names -- Scan.option (keywordC directionN |-- (Args.term -- Args.term)) -- optional (keywordC leavingN |-- names) >> (fn ((hints, aD),leave) => transferred_attribute hints aD leave));
-
-end;
-
-
-(* theory setup *)
-
-
-val setup =
- Attrib.setup @{binding transfer} install_att_syntax
- "Installs transfer data" #>
- Attrib.setup @{binding transfer_simps} (Attrib.add_del add_ss del_ss)
- "simp rules for transfer" #>
- Attrib.setup @{binding transferred} transferred_att_syntax
- "Transfers theorems";
-
-end;
--- a/src/HOL/Tools/typecopy.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Tools/typecopy.ML Thu Oct 01 07:40:25 2009 +0200
@@ -91,11 +91,10 @@
fun add_default_code tyco thy =
let
- val SOME { constr = constr_name, proj = (proj, _), proj_def = proj_eq, vs = raw_vs,
+ val SOME { constr = c, proj = (proj, _), proj_def = proj_eq, vs = vs,
typ = ty_rep, ... } = get_info thy tyco;
val SOME { Rep_inject = proj_inject, ... } = Typedef.get_info thy tyco;
- val constr = (constr_name, Logic.unvarifyT (Sign.the_const_type thy constr_name));
- val vs = (map dest_TFree o snd o dest_Type) (Type (tyco, map TFree raw_vs));
+ val constr = (c, Logic.unvarifyT (Sign.the_const_type thy c));
val ty = Type (tyco, map TFree vs);
val proj = Const (proj, ty --> ty_rep);
val (t_x, t_y) = (Free ("x", ty), Free ("y", ty));
--- a/src/HOL/Transitive_Closure.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Transitive_Closure.thy Thu Oct 01 07:40:25 2009 +0200
@@ -77,7 +77,7 @@
subsection {* Reflexive-transitive closure *}
lemma reflcl_set_eq [pred_set_conv]: "(sup (\<lambda>x y. (x, y) \<in> r) op =) = (\<lambda>x y. (x, y) \<in> r Un Id)"
- by (simp add: expand_fun_eq)
+ by (simp add: expand_fun_eq sup2_iff)
lemma r_into_rtrancl [intro]: "!!p. p \<in> r ==> p \<in> r^*"
-- {* @{text rtrancl} of @{text r} contains @{text r} *}
--- a/src/HOL/UNITY/Follows.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/Follows.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/UNITY/Follows
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1998 University of Cambridge
*)
@@ -160,7 +159,7 @@
lemma Follows_Un:
"[| F \<in> f' Fols f; F \<in> g' Fols g |]
==> F \<in> (%s. (f' s) \<union> (g' s)) Fols (%s. (f s) \<union> (g s))"
-apply (simp add: Follows_def Increasing_Un Always_Un del: Un_subset_iff, auto)
+apply (simp add: Follows_def Increasing_Un Always_Un del: Un_subset_iff le_sup_iff, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_Un_lemma)
(*Weakening is used to exchange Un's arguments*)
--- a/src/HOL/UNITY/ProgressSets.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/ProgressSets.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/UNITY/ProgressSets
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 2003 University of Cambridge
@@ -245,7 +244,7 @@
then have "cl C (T\<inter>?r) \<subseteq> ?r"
by (blast intro!: subset_wens)
then have cl_subset: "cl C (T\<inter>?r) \<subseteq> T\<inter>?r"
- by (simp add: Int_subset_iff cl_ident TC
+ by (simp add: cl_ident TC
subset_trans [OF cl_mono [OF Int_lower1]])
show ?thesis
by (rule cl_subset_in_lattice [OF cl_subset latt])
@@ -486,7 +485,7 @@
shows "closed F T B L"
apply (simp add: closed_def, clarify)
apply (rule ProgressSets.cl_subset_in_lattice [OF _ lattice])
-apply (simp add: Int_Un_distrib cl_Un [OF lattice] Un_subset_iff
+apply (simp add: Int_Un_distrib cl_Un [OF lattice]
cl_ident Int_in_lattice [OF TL BL lattice] Un_upper1)
apply (subgoal_tac "cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))")
prefer 2
@@ -534,7 +533,7 @@
subsubsection{*Commutativity of Functions and Relation*}
text{*Thesis, page 109*}
-(*FIXME: this proof is an ungodly mess*)
+(*FIXME: this proof is still an ungodly mess*)
text{*From Meier's thesis, section 4.5.6*}
lemma commutativity2_lemma:
assumes dcommutes:
@@ -548,36 +547,35 @@
and TL: "T \<in> L"
and Fstable: "F \<in> stable T"
shows "commutes F T B L"
-apply (simp add: commutes_def del: Int_subset_iff, clarify)
-apply (rename_tac t)
-apply (subgoal_tac "\<exists>s. (s,t) \<in> relcl L & s \<in> T \<inter> wp act M")
- prefer 2
- apply (force simp add: cl_eq_Collect_relcl [OF lattice], simp, clarify)
-apply (subgoal_tac "\<forall>u\<in>L. s \<in> u --> t \<in> u")
- prefer 2
- apply (intro ballI impI)
- apply (subst cl_ident [symmetric], assumption)
- apply (simp add: relcl_def)
- apply (blast intro: cl_mono [THEN [2] rev_subsetD])
-apply (subgoal_tac "funof act s \<in> T\<inter>M")
- prefer 2
- apply (cut_tac Fstable)
- apply (force intro!: funof_in
- simp add: wp_def stable_def constrains_def determ total)
-apply (subgoal_tac "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L")
- prefer 2
- apply (rule dcommutes [rule_format], assumption+)
-apply (subgoal_tac "t \<in> B | funof act t \<in> cl L (T\<inter>M)")
- prefer 2
- apply (simp add: relcl_def)
- apply (blast intro: BL cl_mono [THEN [2] rev_subsetD])
-apply (subgoal_tac "t \<in> B | t \<in> wp act (cl L (T\<inter>M))")
- prefer 2
- apply (blast intro: funof_imp_wp determ)
-apply (blast intro: TL cl_mono [THEN [2] rev_subsetD])
-done
-
-
+apply (simp add: commutes_def del: Int_subset_iff le_inf_iff, clarify)
+proof -
+ fix M and act and t
+ assume 1: "B \<subseteq> M" "act \<in> Acts F" "t \<in> cl L (T \<inter> wp act M)"
+ then have "\<exists>s. (s,t) \<in> relcl L \<and> s \<in> T \<inter> wp act M"
+ by (force simp add: cl_eq_Collect_relcl [OF lattice])
+ then obtain s where 2: "(s, t) \<in> relcl L" "s \<in> T" "s \<in> wp act M"
+ by blast
+ then have 3: "\<forall>u\<in>L. s \<in> u --> t \<in> u"
+ apply (intro ballI impI)
+ apply (subst cl_ident [symmetric], assumption)
+ apply (simp add: relcl_def)
+ apply (blast intro: cl_mono [THEN [2] rev_subsetD])
+ done
+ with 1 2 Fstable have 4: "funof act s \<in> T\<inter>M"
+ by (force intro!: funof_in
+ simp add: wp_def stable_def constrains_def determ total)
+ with 1 2 3 have 5: "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
+ by (intro dcommutes [rule_format]) assumption+
+ with 1 2 3 4 have "t \<in> B | funof act t \<in> cl L (T\<inter>M)"
+ by (simp add: relcl_def) (blast intro: BL cl_mono [THEN [2] rev_subsetD])
+ with 1 2 3 4 5 have "t \<in> B | t \<in> wp act (cl L (T\<inter>M))"
+ by (blast intro: funof_imp_wp determ)
+ with 2 3 have "t \<in> T \<and> (t \<in> B \<or> t \<in> wp act (cl L (T \<inter> M)))"
+ by (blast intro: TL cl_mono [THEN [2] rev_subsetD])
+ then show "t \<in> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))"
+ by simp
+qed
+
text{*Version packaged with @{thm progress_set_Union}*}
lemma commutativity2:
assumes leadsTo: "F \<in> A leadsTo B"
--- a/src/HOL/UNITY/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,50 +1,13 @@
-(* Title: HOL/UNITY/ROOT
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1998 University of Cambridge
-Root file for UNITY proofs.
*)
(*Verifying security protocols using UNITY*)
no_document use_thy "../Auth/Public";
-use_thys [
- (*Basic meta-theory*)
- "UNITY_Main",
-
- (*Simple examples: no composition*)
- "Simple/Deadlock",
- "Simple/Common",
- "Simple/Network",
- "Simple/Token",
- "Simple/Channel",
- "Simple/Lift",
- "Simple/Mutex",
- "Simple/Reach",
- "Simple/Reachability",
-
- (*Verifying security protocols using UNITY*)
- "Simple/NSP_Bad",
+(*Basic meta-theory*)
+use_thy "UNITY_Main";
- (*Example of composition*)
- "Comp/Handshake",
-
- (*Universal properties examples*)
- "Comp/Counter",
- "Comp/Counterc",
- "Comp/Priority",
-
- "Comp/TimerArray",
- "Comp/Progress",
-
- (*obsolete*)
- "ELT"
-];
-
-(*Allocator example*)
-(* FIXME some parts no longer work -- had been commented out for a long time *)
-setmp_noncritical quick_and_dirty true
- use_thy "Comp/Alloc";
-
-use_thys ["Comp/AllocImpl", "Comp/Client"];
+(*Examples*)
+use_thy "UNITY_Examples";
--- a/src/HOL/UNITY/Simple/Common.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/Simple/Common.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/UNITY/Common
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1998 University of Cambridge
@@ -10,7 +9,9 @@
From Misra, "A Logic for Concurrent Programming" (1994), sections 5.1 and 13.1.
*)
-theory Common imports "../UNITY_Main" begin
+theory Common
+imports "../UNITY_Main"
+begin
consts
ftime :: "nat=>nat"
@@ -65,7 +66,7 @@
lemma "mk_total_program (UNIV, {range(%t.(t, max (ftime t) (gtime t)))}, UNIV)
\<in> {m} co (maxfg m)"
apply (simp add: mk_total_program_def)
-apply (simp add: constrains_def maxfg_def max_def gasc)
+apply (simp add: constrains_def maxfg_def gasc min_max.sup_absorb2)
done
(*This one is t := t+1 if t <max (ftime t) (gtime t) *)
@@ -73,7 +74,7 @@
(UNIV, { {(t, Suc t) | t. t < max (ftime t) (gtime t)} }, UNIV)
\<in> {m} co (maxfg m)"
apply (simp add: mk_total_program_def)
-apply (simp add: constrains_def maxfg_def max_def gasc)
+apply (simp add: constrains_def maxfg_def gasc min_max.sup_absorb2)
done
@@ -83,19 +84,24 @@
(*** Progress under weak fairness ***)
-declare atMost_Int_atLeast [simp]
-
lemma leadsTo_common_lemma:
- "[| \<forall>m. F \<in> {m} Co (maxfg m);
- \<forall>m \<in> lessThan n. F \<in> {m} LeadsTo (greaterThan m);
- n \<in> common |]
- ==> F \<in> (atMost n) LeadsTo common"
-apply (rule LeadsTo_weaken_R)
-apply (rule_tac f = id and l = n in GreaterThan_bounded_induct)
-apply (simp_all (no_asm_simp))
-apply (rule_tac [2] subset_refl)
-apply (blast dest: PSP_Stable2 intro: common_stable LeadsTo_weaken_R)
-done
+ assumes "\<forall>m. F \<in> {m} Co (maxfg m)"
+ and "\<forall>m \<in> lessThan n. F \<in> {m} LeadsTo (greaterThan m)"
+ and "n \<in> common"
+ shows "F \<in> (atMost n) LeadsTo common"
+proof (rule LeadsTo_weaken_R)
+ show "F \<in> {..n} LeadsTo {..n} \<inter> id -` {n..} \<union> common"
+ proof (induct rule: GreaterThan_bounded_induct [of n _ _ id])
+ case 1
+ from assms have "\<forall>m\<in>{..<n}. F \<in> {..n} \<inter> {m} LeadsTo {..n} \<inter> {m<..} \<union> common"
+ by (blast dest: PSP_Stable2 intro: common_stable LeadsTo_weaken_R)
+ then show ?case by simp
+ qed
+next
+ from `n \<in> common`
+ show "{..n} \<inter> id -` {n..} \<union> common \<subseteq> common"
+ by (simp add: atMost_Int_atLeast)
+qed
(*The "\<forall>m \<in> -common" form echoes CMT6.*)
lemma leadsTo_common:
--- a/src/HOL/UNITY/Transformers.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/Transformers.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/UNITY/Transformers
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 2003 University of Cambridge
@@ -88,7 +87,7 @@
done
lemma wens_Id [simp]: "wens F Id B = B"
-by (simp add: wens_def gfp_def wp_def awp_def Sup_set_eq, blast)
+by (simp add: wens_def gfp_def wp_def awp_def, blast)
text{*These two theorems justify the claim that @{term wens} returns the
weakest assertion satisfying the ensures property*}
@@ -101,7 +100,7 @@
lemma wens_ensures: "act \<in> Acts F ==> F \<in> (wens F act B) ensures B"
by (simp add: wens_def gfp_def constrains_def awp_def wp_def
- ensures_def transient_def Sup_set_eq, blast)
+ ensures_def transient_def, blast)
text{*These two results constitute assertion (4.13) of the thesis*}
lemma wens_mono: "(A \<subseteq> B) ==> wens F act A \<subseteq> wens F act B"
@@ -110,7 +109,7 @@
done
lemma wens_weakening: "B \<subseteq> wens F act B"
-by (simp add: wens_def gfp_def Sup_set_eq, blast)
+by (simp add: wens_def gfp_def, blast)
text{*Assertion (6), or 4.16 in the thesis*}
lemma subset_wens: "A-B \<subseteq> wp act B \<inter> awp F (B \<union> A) ==> A \<subseteq> wens F act B"
@@ -120,7 +119,7 @@
text{*Assertion 4.17 in the thesis*}
lemma Diff_wens_constrains: "F \<in> (wens F act A - A) co wens F act A"
-by (simp add: wens_def gfp_def wp_def awp_def constrains_def Sup_set_eq, blast)
+by (simp add: wens_def gfp_def wp_def awp_def constrains_def, blast)
--{*Proved instantly, yet remarkably fragile. If @{text Un_subset_iff}
is declared as an iff-rule, then it's almost impossible to prove.
One proof is via @{text meson} after expanding all definitions, but it's
@@ -133,7 +132,7 @@
apply (drule constrains_Un [OF Diff_wens_constrains [of F act A]])
apply (simp add: Un_Int_distrib2 Compl_partition2)
apply (erule constrains_weaken, blast)
-apply (simp add: Un_subset_iff wens_weakening)
+apply (simp add: wens_weakening)
done
text{*Assertion 4.20 in the thesis.*}
@@ -151,7 +150,7 @@
"[|T-B \<subseteq> awp F T; act \<in> Acts F|]
==> T \<inter> wens F act B = T \<inter> wens F act (T\<inter>B)"
apply (rule equalityI)
- apply (simp_all add: Int_lower1 Int_subset_iff)
+ apply (simp_all add: Int_lower1)
apply (rule wens_Int_eq_lemma, assumption+)
apply (rule subset_trans [OF _ wens_mono [of "T\<inter>B" B]], auto)
done
@@ -176,7 +175,7 @@
apply (drule_tac act1=act and A1=X
in constrains_Un [OF Diff_wens_constrains])
apply (erule constrains_weaken, blast)
- apply (simp add: Un_subset_iff wens_weakening)
+ apply (simp add: wens_weakening)
apply (rule constrains_weaken)
apply (rule_tac I=W and A="\<lambda>v. v-B" and A'="\<lambda>v. v" in constrains_UN, blast+)
done
@@ -229,7 +228,7 @@
apply (subgoal_tac "(T \<inter> wens F act B) - B \<subseteq>
wp act B \<inter> awp F (B \<union> wens F act B) \<inter> awp F T")
apply (rule subset_wens)
- apply (simp add: awp_Join_eq awp_Int_eq Int_subset_iff Un_commute)
+ apply (simp add: awp_Join_eq awp_Int_eq Un_commute)
apply (simp add: awp_def wp_def, blast)
apply (insert wens_subset [of F act B], blast)
done
@@ -253,7 +252,7 @@
apply (blast dest: wens_mono intro: wens_Join_subset [THEN subsetD], simp)
apply (rule equalityI)
prefer 2 apply blast
-apply (simp add: Int_lower1 Int_subset_iff)
+apply (simp add: Int_lower1)
apply (frule wens_set_imp_subset)
apply (subgoal_tac "T-X \<subseteq> awp F T")
prefer 2 apply (blast intro: awpF [THEN subsetD])
@@ -331,7 +330,7 @@
lemma wens_single_eq:
"wens (mk_program (init, {act}, allowed)) act B = B \<union> wp act B"
-by (simp add: wens_def gfp_def wp_def Sup_set_eq, blast)
+by (simp add: wens_def gfp_def wp_def, blast)
text{*Next, we express the @{term "wens_set"} for single-assignment programs*}
@@ -347,7 +346,7 @@
"single_valued act
==> wens_single act B \<union> wp act (wens_single act B) = wens_single act B"
apply (rule equalityI)
- apply (simp_all add: Un_upper1 Un_subset_iff)
+ apply (simp_all add: Un_upper1)
apply (simp add: wens_single_def wp_UN_eq, clarify)
apply (rule_tac a="Suc(i)" in UN_I, auto)
done
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/UNITY/UNITY_Examples.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,45 @@
+(* Author: Lawrence C Paulson Cambridge University Computer Laboratory
+ Copyright 1998 University of Cambridge
+*)
+
+header {* Various examples for UNITY *}
+
+theory UNITY_Examples
+imports
+ UNITY_Main
+
+ (*Simple examples: no composition*)
+ "Simple/Deadlock"
+ "Simple/Common"
+ "Simple/Network"
+ "Simple/Token"
+ "Simple/Channel"
+ "Simple/Lift"
+ "Simple/Mutex"
+ "Simple/Reach"
+ "Simple/Reachability"
+
+ (*Verifying security protocols using UNITY*)
+ "Simple/NSP_Bad"
+
+ (*Example of composition*)
+ "Comp/Handshake"
+
+ (*Universal properties examples*)
+ "Comp/Counter"
+ "Comp/Counterc"
+ "Comp/Priority"
+
+ "Comp/TimerArray"
+ "Comp/Progress"
+
+ "Comp/Alloc"
+ "Comp/AllocImpl"
+ "Comp/Client"
+
+ (*obsolete*)
+ "ELT"
+
+begin
+
+end
--- a/src/HOL/UNITY/UNITY_Main.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/UNITY_Main.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,13 +1,14 @@
(* Title: HOL/UNITY/UNITY_Main.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 2003 University of Cambridge
*)
header{*Comprehensive UNITY Theory*}
-theory UNITY_Main imports Detects PPROD Follows ProgressSets
-uses "UNITY_tactics.ML" begin
+theory UNITY_Main
+imports Detects PPROD Follows ProgressSets
+uses "UNITY_tactics.ML"
+begin
method_setup safety = {*
Scan.succeed (fn ctxt =>
--- a/src/HOL/UNITY/WFair.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/UNITY/WFair.thy Thu Oct 01 07:40:25 2009 +0200
@@ -113,7 +113,7 @@
lemma totalize_transient_iff:
"(totalize F \<in> transient A) = (\<exists>act\<in>Acts F. A \<subseteq> Domain act & act``A \<subseteq> -A)"
apply (simp add: totalize_def totalize_act_def transient_def
- Un_Image Un_subset_iff, safe)
+ Un_Image, safe)
apply (blast intro!: rev_bexI)+
done
--- a/src/HOL/Wellfounded.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Wellfounded.thy Thu Oct 01 07:40:25 2009 +0200
@@ -13,14 +13,6 @@
subsection {* Basic Definitions *}
-inductive
- wfrec_rel :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => 'a => 'b => bool"
- for R :: "('a * 'a) set"
- and F :: "('a => 'b) => 'a => 'b"
-where
- wfrecI: "ALL z. (z, x) : R --> wfrec_rel R F z (g z) ==>
- wfrec_rel R F x (F g x)"
-
constdefs
wf :: "('a * 'a)set => bool"
"wf(r) == (!P. (!x. (!y. (y,x):r --> P(y)) --> P(x)) --> (!x. P(x)))"
@@ -31,16 +23,6 @@
acyclic :: "('a*'a)set => bool"
"acyclic r == !x. (x,x) ~: r^+"
- cut :: "('a => 'b) => ('a * 'a)set => 'a => 'a => 'b"
- "cut f r x == (%y. if (y,x):r then f y else undefined)"
-
- adm_wf :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => bool"
- "adm_wf R F == ALL f g x.
- (ALL z. (z, x) : R --> f z = g z) --> F f x = F g x"
-
- wfrec :: "('a * 'a) set => (('a => 'b) => 'a => 'b) => 'a => 'b"
- [code del]: "wfrec R F == %x. THE y. wfrec_rel R (%f x. F (cut f R x) x) x y"
-
abbreviation acyclicP :: "('a => 'a => bool) => bool" where
"acyclicP r == acyclic {(x, y). r x y}"
@@ -285,8 +267,8 @@
lemma wfP_SUP:
"\<forall>i. wfP (r i) \<Longrightarrow> \<forall>i j. r i \<noteq> r j \<longrightarrow> inf (DomainP (r i)) (RangeP (r j)) = bot \<Longrightarrow> wfP (SUPR UNIV r)"
- by (rule wf_UN [where I=UNIV and r="\<lambda>i. {(x, y). r i x y}", to_pred SUP_UN_eq2 pred_equals_eq])
- (simp_all add: bot_fun_eq bot_bool_eq)
+ by (rule wf_UN [where I=UNIV and r="\<lambda>i. {(x, y). r i x y}", to_pred SUP_UN_eq2])
+ (simp_all add: Collect_def)
lemma wf_Union:
"[| ALL r:R. wf r;
@@ -425,54 +407,6 @@
by (blast intro: finite_acyclic_wf wf_acyclic)
-subsection{*Well-Founded Recursion*}
-
-text{*cut*}
-
-lemma cuts_eq: "(cut f r x = cut g r x) = (ALL y. (y,x):r --> f(y)=g(y))"
-by (simp add: expand_fun_eq cut_def)
-
-lemma cut_apply: "(x,a):r ==> (cut f r a)(x) = f(x)"
-by (simp add: cut_def)
-
-text{*Inductive characterization of wfrec combinator; for details see:
-John Harrison, "Inductive definitions: automation and application"*}
-
-lemma wfrec_unique: "[| adm_wf R F; wf R |] ==> EX! y. wfrec_rel R F x y"
-apply (simp add: adm_wf_def)
-apply (erule_tac a=x in wf_induct)
-apply (rule ex1I)
-apply (rule_tac g = "%x. THE y. wfrec_rel R F x y" in wfrec_rel.wfrecI)
-apply (fast dest!: theI')
-apply (erule wfrec_rel.cases, simp)
-apply (erule allE, erule allE, erule allE, erule mp)
-apply (fast intro: the_equality [symmetric])
-done
-
-lemma adm_lemma: "adm_wf R (%f x. F (cut f R x) x)"
-apply (simp add: adm_wf_def)
-apply (intro strip)
-apply (rule cuts_eq [THEN iffD2, THEN subst], assumption)
-apply (rule refl)
-done
-
-lemma wfrec: "wf(r) ==> wfrec r H a = H (cut (wfrec r H) r a) a"
-apply (simp add: wfrec_def)
-apply (rule adm_lemma [THEN wfrec_unique, THEN the1_equality], assumption)
-apply (rule wfrec_rel.wfrecI)
-apply (intro strip)
-apply (erule adm_lemma [THEN wfrec_unique, THEN theI'])
-done
-
-subsection {* Code generator setup *}
-
-consts_code
- "wfrec" ("\<module>wfrec?")
-attach {*
-fun wfrec f x = f (wfrec f) x;
-*}
-
-
subsection {* @{typ nat} is well-founded *}
lemma less_nat_rel: "op < = (\<lambda>m n. n = Suc m)^++"
@@ -696,9 +630,6 @@
apply blast
done
-lemma in_inv_image[simp]: "((x,y) : inv_image r f) = ((f x, f y) : r)"
- by (auto simp:inv_image_def)
-
text {* Measure Datatypes into @{typ nat} *}
definition measure :: "('a => nat) => ('a * 'a)set"
--- a/src/HOL/Word/BinBoolList.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Word/BinBoolList.thy Thu Oct 01 07:40:25 2009 +0200
@@ -918,8 +918,8 @@
apply (frule asm_rl)
apply (drule spec)
apply (erule trans)
- apply (drule_tac x = "bin_cat y n a" in spec)
- apply (simp add : bin_cat_assoc_sym min_def)
+ apply (drule_tac x = "bin_cat y n a" in spec)
+ apply (simp add : bin_cat_assoc_sym min_max.inf_absorb2)
done
lemma bin_rcat_bl:
--- a/src/HOL/Word/BinGeneral.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Word/BinGeneral.thy Thu Oct 01 07:40:25 2009 +0200
@@ -493,7 +493,7 @@
lemma sbintrunc_sbintrunc_l:
"n <= m ==> (sbintrunc m (sbintrunc n w) = sbintrunc n w)"
- by (rule bin_eqI) (auto simp: nth_sbintr min_def)
+ by (rule bin_eqI) (auto simp: nth_sbintr)
lemma bintrunc_bintrunc_ge:
"n <= m ==> (bintrunc n (bintrunc m w) = bintrunc n w)"
@@ -501,16 +501,14 @@
lemma bintrunc_bintrunc_min [simp]:
"bintrunc m (bintrunc n w) = bintrunc (min m n) w"
- apply (unfold min_def)
apply (rule bin_eqI)
apply (auto simp: nth_bintr)
done
lemma sbintrunc_sbintrunc_min [simp]:
"sbintrunc m (sbintrunc n w) = sbintrunc (min m n) w"
- apply (unfold min_def)
apply (rule bin_eqI)
- apply (auto simp: nth_sbintr)
+ apply (auto simp: nth_sbintr min_max.inf_absorb1 min_max.inf_absorb2)
done
lemmas bintrunc_Pls =
--- a/src/HOL/Word/WordDefinition.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Word/WordDefinition.thy Thu Oct 01 07:40:25 2009 +0200
@@ -380,15 +380,15 @@
"n >= size w ==> bintrunc n (uint w) = uint w"
apply (unfold word_size)
apply (subst word_ubin.norm_Rep [symmetric])
- apply (simp only: bintrunc_bintrunc_min word_size min_def)
- apply simp
+ apply (simp only: bintrunc_bintrunc_min word_size)
+ apply (simp add: min_max.inf_absorb2)
done
lemma wi_bintr':
"wb = word_of_int bin ==> n >= size wb ==>
word_of_int (bintrunc n bin) = wb"
unfolding word_size
- by (clarsimp simp add : word_ubin.norm_eq_iff [symmetric] min_def)
+ by (clarsimp simp add: word_ubin.norm_eq_iff [symmetric] min_max.inf_absorb1)
lemmas bintr_uint = bintr_uint' [unfolded word_size]
lemmas wi_bintr = wi_bintr' [unfolded word_size]
--- a/src/HOL/Word/WordShift.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/Word/WordShift.thy Thu Oct 01 07:40:25 2009 +0200
@@ -319,7 +319,7 @@
lemma bl_shiftl:
"to_bl (w << n) = drop n (to_bl w) @ replicate (min (size w) n) False"
- by (simp add: shiftl_bl word_rep_drop word_size min_def)
+ by (simp add: shiftl_bl word_rep_drop word_size)
lemma shiftl_zero_size:
fixes x :: "'a::len0 word"
@@ -1017,9 +1017,8 @@
(word_cat (word_of_int w :: 'b word) (b :: 'c word) :: 'a word) =
word_of_int (bin_cat w (size b) (uint b))"
apply (unfold word_cat_def word_size)
- apply (clarsimp simp add : word_ubin.norm_eq_iff [symmetric]
- word_ubin.eq_norm bintr_cat min_def)
- apply arith
+ apply (clarsimp simp add: word_ubin.norm_eq_iff [symmetric]
+ word_ubin.eq_norm bintr_cat min_max.inf_absorb1)
done
lemma word_cat_split_alt:
--- a/src/HOL/ex/CTL.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/CTL.thy Thu Oct 01 07:40:25 2009 +0200
@@ -95,7 +95,7 @@
proof
assume "x \<in> gfp (\<lambda>s. - f (- s))"
then obtain u where "x \<in> u" and "u \<subseteq> - f (- u)"
- by (auto simp add: gfp_def Sup_set_eq)
+ by (auto simp add: gfp_def)
then have "f (- u) \<subseteq> - u" by auto
then have "lfp f \<subseteq> - u" by (rule lfp_lowerbound)
from l and this have "x \<notin> u" by auto
--- a/src/HOL/ex/Codegenerator_Candidates.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Codegenerator_Candidates.thy Thu Oct 01 07:40:25 2009 +0200
@@ -16,7 +16,7 @@
Nested_Environment
Option_ord
Permutation
- Primes
+ "~~/src/HOL/Number_Theory/Primes"
Product_ord
SetsAndFunctions
Tree
--- a/src/HOL/ex/Coherent.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Coherent.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,14 +1,15 @@
-(* Title: HOL/ex/Coherent
- ID: $Id$
+(* Title: HOL/ex/Coherent.thy
Author: Stefan Berghofer, TU Muenchen
- Marc Bezem, Institutt for Informatikk, Universitetet i Bergen
+ Author: Marc Bezem, Institutt for Informatikk, Universitetet i Bergen
*)
-header{* Coherent Logic Problems *}
+header {* Coherent Logic Problems *}
-theory Coherent imports Main begin
+theory Coherent
+imports Main
+begin
-subsection{* Equivalence of two versions of Pappus' Axiom *}
+subsection {* Equivalence of two versions of Pappus' Axiom *}
no_notation
comp (infixl "o" 55) and
--- a/src/HOL/ex/Mirabelle.thy Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Title: Mirabelle.thy
- Author: Jasmin Blanchette and Sascha Boehme
-*)
-
-theory Mirabelle
-imports Main
-uses "mirabelle.ML"
-begin
-
-(* FIXME: use a logfile for each theory file *)
-
-setup Mirabelle.setup
-
-end
--- a/src/HOL/ex/NormalForm.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/NormalForm.thy Thu Oct 01 07:40:25 2009 +0200
@@ -120,4 +120,12 @@
normal_form "(%m n f x. m (n f) x) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
normal_form "(%m n. n m) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
+(* handling of type classes in connection with equality *)
+
+lemma "map f [x, y] = [f x, f y]" by normalization
+lemma "(map f [x, y], w) = ([f x, f y], w)" by normalization
+lemma "map f [x, y] = [f x \<Colon> 'a\<Colon>semigroup_add, f y]" by normalization
+lemma "map f [x \<Colon> 'a\<Colon>semigroup_add, y] = [f x, f y]" by normalization
+lemma "(map f [x \<Colon> 'a\<Colon>semigroup_add, y], w \<Colon> 'b\<Colon>finite) = ([f x, f y], w)" by normalization
+
end
--- a/src/HOL/ex/Predicate_Compile.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Predicate_Compile.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,8 +1,17 @@
theory Predicate_Compile
imports Complex_Main RPred
-uses "predicate_compile.ML"
+uses
+ "../Tools/Predicate_Compile/pred_compile_aux.ML"
+ "../Tools/Predicate_Compile/predicate_compile_core.ML"
+ "../Tools/Predicate_Compile/pred_compile_set.ML"
+ "../Tools/Predicate_Compile/pred_compile_data.ML"
+ "../Tools/Predicate_Compile/pred_compile_fun.ML"
+ "../Tools/Predicate_Compile/pred_compile_pred.ML"
+ "../Tools/Predicate_Compile/predicate_compile.ML"
+ "../Tools/Predicate_Compile/pred_compile_quickcheck.ML"
begin
setup {* Predicate_Compile.setup *}
+setup {* Quickcheck.add_generator ("pred_compile", Pred_Compile_Quickcheck.quickcheck) *}
end
\ No newline at end of file
--- a/src/HOL/ex/Predicate_Compile_ex.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Predicate_Compile_ex.thy Thu Oct 01 07:40:25 2009 +0200
@@ -22,8 +22,10 @@
| "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"
code_pred append .
+code_pred (inductify_all) (rpred) append .
thm append.equation
+thm append.rpred_equation
values "{(ys, xs). append xs ys [0, Suc 0, 2]}"
values "{zs. append [0, Suc 0, 2] [17, 8] zs}"
@@ -49,6 +51,22 @@
thm partition.equation
+
+inductive member
+for xs
+where "x \<in> set xs ==> member xs x"
+
+lemma [code_pred_intros]:
+ "member (x#xs') x"
+by (auto intro: member.intros)
+
+lemma [code_pred_intros]:
+"member xs x ==> member (x'#xs) x"
+by (auto intro: member.intros elim!: member.cases)
+(* strange bug must be repaired! *)
+(*
+code_pred member sorry
+*)
inductive is_even :: "nat \<Rightarrow> bool"
where
"n mod 2 = 0 \<Longrightarrow> is_even n"
@@ -70,15 +88,11 @@
case tranclp
from this converse_tranclpE[OF this(1)] show thesis by metis
qed
-
+(*
+code_pred (inductify_all) (rpred) tranclp .
thm tranclp.equation
-(*
-setup {* Predicate_Compile.add_sizelim_equations [@{const_name tranclp}] *}
-setup {* fn thy => exception_trace (fn () => Predicate_Compile.add_quickcheck_equations [@{const_name tranclp}] thy) *}
-
thm tranclp.rpred_equation
*)
-
inductive succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"succ 0 1"
| "succ m n \<Longrightarrow> succ (Suc m) (Suc n)"
@@ -99,4 +113,329 @@
values 20 "{(n, m). tranclp succ n m}"
*)
+subsection{* IMP *}
+
+types
+ var = nat
+ state = "int list"
+
+datatype com =
+ Skip |
+ Ass var "state => int" |
+ Seq com com |
+ IF "state => bool" com com |
+ While "state => bool" com
+
+inductive exec :: "com => state => state => bool" where
+"exec Skip s s" |
+"exec (Ass x e) s (s[x := e(s)])" |
+"exec c1 s1 s2 ==> exec c2 s2 s3 ==> exec (Seq c1 c2) s1 s3" |
+"b s ==> exec c1 s t ==> exec (IF b c1 c2) s t" |
+"~b s ==> exec c2 s t ==> exec (IF b c1 c2) s t" |
+"~b s ==> exec (While b c) s s" |
+"b s1 ==> exec c s1 s2 ==> exec (While b c) s2 s3 ==> exec (While b c) s1 s3"
+
+code_pred exec .
+
+values "{t. exec
+ (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))))
+ [3,5] t}"
+
+
+subsection{* CCS *}
+
+text{* This example formalizes finite CCS processes without communication or
+recursion. For simplicity, labels are natural numbers. *}
+
+datatype proc = nil | pre nat proc | or proc proc | par proc proc
+
+inductive step :: "proc \<Rightarrow> nat \<Rightarrow> proc \<Rightarrow> bool" where
+"step (pre n p) n p" |
+"step p1 a q \<Longrightarrow> step (or p1 p2) a q" |
+"step p2 a q \<Longrightarrow> step (or p1 p2) a q" |
+"step p1 a q \<Longrightarrow> step (par p1 p2) a (par q p2)" |
+"step p2 a q \<Longrightarrow> step (par p1 p2) a (par p1 q)"
+
+code_pred step .
+
+inductive steps where
+"steps p [] p" |
+"step p a q \<Longrightarrow> steps q as r \<Longrightarrow> steps p (a#as) r"
+
+code_pred steps .
+
+values 5
+ "{as . steps (par (or (pre 0 nil) (pre 1 nil)) (pre 2 nil)) as (par nil nil)}"
+
+(* FIXME
+values 3 "{(a,q). step (par nil nil) a q}"
+*)
+
+subsection {* divmod *}
+
+inductive divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
+ "k < l \<Longrightarrow> divmod_rel k l 0 k"
+ | "k \<ge> l \<Longrightarrow> divmod_rel (k - l) l q r \<Longrightarrow> divmod_rel k l (Suc q) r"
+
+code_pred divmod_rel ..
+
+value [code] "Predicate.singleton (divmod_rel_1_2 1705 42)"
+
+section {* Executing definitions *}
+
+definition Min
+where "Min s r x \<equiv> s x \<and> (\<forall>y. r x y \<longrightarrow> x = y)"
+
+code_pred (inductify_all) Min .
+
+subsection {* Examples with lists *}
+
+inductive filterP for Pa where
+"(filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) [] []"
+| "[| (res::'a list) = (y::'a) # (resa::'a list); (filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) (xt::'a list) resa; Pa y |]
+==> filterP Pa (y # xt) res"
+| "[| (filterP::('a => bool) => 'a list => 'a list => bool) (Pa::'a => bool) (xt::'a list) (res::'a list); ~ Pa (y::'a) |] ==> filterP Pa (y # xt) res"
+
+(*
+code_pred (inductify_all) (rpred) filterP .
+thm filterP.rpred_equation
+*)
+
+code_pred (inductify_all) lexord .
+
+thm lexord.equation
+
+lemma "(u, v) : lexord r ==> (x @ u, y @ v) : lexord r"
+(*quickcheck[generator=pred_compile]*)
+oops
+
+lemmas [code_pred_def] = lexn_conv lex_conv lenlex_conv
+
+code_pred (inductify_all) lexn .
+thm lexn.equation
+
+code_pred (inductify_all) lenlex .
+thm lenlex.equation
+(*
+code_pred (inductify_all) (rpred) lenlex .
+thm lenlex.rpred_equation
+*)
+thm lists.intros
+code_pred (inductify_all) lists .
+
+thm lists.equation
+
+datatype 'a tree = ET | MKT 'a "'a tree" "'a tree" nat
+fun height :: "'a tree => nat" where
+"height ET = 0"
+| "height (MKT x l r h) = max (height l) (height r) + 1"
+
+consts avl :: "'a tree => bool"
+primrec
+ "avl ET = True"
+ "avl (MKT x l r h) = ((height l = height r \<or> height l = 1 + height r \<or> height r = 1+height l) \<and>
+ h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"
+
+code_pred (inductify_all) avl .
+thm avl.equation
+
+lemma [code_pred_inline]: "bot_fun_inst.bot_fun == (\<lambda>(y::'a::type). False)"
+unfolding bot_fun_inst.bot_fun[symmetric] bot_bool_eq[symmetric] bot_fun_eq by simp
+
+fun set_of
+where
+"set_of ET = {}"
+| "set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"
+
+fun is_ord
+where
+"is_ord ET = True"
+| "is_ord (MKT n l r h) =
+ ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"
+
+declare Un_def[code_pred_def]
+
+code_pred (inductify_all) set_of .
+thm set_of.equation
+(* FIXME *)
+(*
+code_pred (inductify_all) is_ord .
+thm is_ord.equation
+*)
+section {* Definitions about Relations *}
+
+code_pred (inductify_all) converse .
+thm converse.equation
+
+code_pred (inductify_all) Domain .
+thm Domain.equation
+
+
+section {* Context Free Grammar *}
+
+datatype alphabet = a | b
+
+inductive_set S\<^isub>1 and A\<^isub>1 and B\<^isub>1 where
+ "[] \<in> S\<^isub>1"
+| "w \<in> A\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
+| "w \<in> B\<^isub>1 \<Longrightarrow> a # w \<in> S\<^isub>1"
+| "w \<in> S\<^isub>1 \<Longrightarrow> a # w \<in> A\<^isub>1"
+| "w \<in> S\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
+| "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
+
+code_pred (inductify_all) S\<^isub>1p .
+
+thm S\<^isub>1p.equation
+
+theorem S\<^isub>1_sound:
+"w \<in> S\<^isub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+quickcheck[generator=pred_compile]
+oops
+
+inductive_set S\<^isub>2 and A\<^isub>2 and B\<^isub>2 where
+ "[] \<in> S\<^isub>2"
+| "w \<in> A\<^isub>2 \<Longrightarrow> b # w \<in> S\<^isub>2"
+| "w \<in> B\<^isub>2 \<Longrightarrow> a # w \<in> S\<^isub>2"
+| "w \<in> S\<^isub>2 \<Longrightarrow> a # w \<in> A\<^isub>2"
+| "w \<in> S\<^isub>2 \<Longrightarrow> b # w \<in> B\<^isub>2"
+| "\<lbrakk>v \<in> B\<^isub>2; v \<in> B\<^isub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>2"
+(*
+code_pred (inductify_all) (rpred) S\<^isub>2 .
+ML {* Predicate_Compile_Core.intros_of @{theory} @{const_name "B\<^isub>2"} *}
+*)
+theorem S\<^isub>2_sound:
+"w \<in> S\<^isub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+(*quickcheck[generator=SML]*)
+quickcheck[generator=pred_compile, size=15, iterations=100]
+oops
+
+inductive_set S\<^isub>3 and A\<^isub>3 and B\<^isub>3 where
+ "[] \<in> S\<^isub>3"
+| "w \<in> A\<^isub>3 \<Longrightarrow> b # w \<in> S\<^isub>3"
+| "w \<in> B\<^isub>3 \<Longrightarrow> a # w \<in> S\<^isub>3"
+| "w \<in> S\<^isub>3 \<Longrightarrow> a # w \<in> A\<^isub>3"
+| "w \<in> S\<^isub>3 \<Longrightarrow> b # w \<in> B\<^isub>3"
+| "\<lbrakk>v \<in> B\<^isub>3; w \<in> B\<^isub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>3"
+
+(*
+code_pred (inductify_all) S\<^isub>3 .
+*)
+theorem S\<^isub>3_sound:
+"w \<in> S\<^isub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+quickcheck[generator=pred_compile, size=10, iterations=1]
+oops
+
+lemma "\<not> (length w > 2) \<or> \<not> (length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b])"
+quickcheck[size=10, generator = pred_compile]
+oops
+
+theorem S\<^isub>3_complete:
+"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>3"
+(*quickcheck[generator=SML]*)
+quickcheck[generator=pred_compile, size=10, iterations=100]
+oops
+
+inductive_set S\<^isub>4 and A\<^isub>4 and B\<^isub>4 where
+ "[] \<in> S\<^isub>4"
+| "w \<in> A\<^isub>4 \<Longrightarrow> b # w \<in> S\<^isub>4"
+| "w \<in> B\<^isub>4 \<Longrightarrow> a # w \<in> S\<^isub>4"
+| "w \<in> S\<^isub>4 \<Longrightarrow> a # w \<in> A\<^isub>4"
+| "\<lbrakk>v \<in> A\<^isub>4; w \<in> A\<^isub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^isub>4"
+| "w \<in> S\<^isub>4 \<Longrightarrow> b # w \<in> B\<^isub>4"
+| "\<lbrakk>v \<in> B\<^isub>4; w \<in> B\<^isub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>4"
+
+theorem S\<^isub>4_sound:
+"w \<in> S\<^isub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+quickcheck[generator = pred_compile, size=2, iterations=1]
+oops
+
+theorem S\<^isub>4_complete:
+"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>4"
+quickcheck[generator = pred_compile, size=5, iterations=1]
+oops
+
+theorem S\<^isub>4_A\<^isub>4_B\<^isub>4_sound_and_complete:
+"w \<in> S\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
+"w \<in> A\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] + 1"
+"w \<in> B\<^isub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = b] = length [x \<leftarrow> w. x = a] + 1"
+(*quickcheck[generator = pred_compile, size=5, iterations=1]*)
+oops
+
+
+section {* Lambda *}
+datatype type =
+ Atom nat
+ | Fun type type (infixr "\<Rightarrow>" 200)
+
+datatype dB =
+ Var nat
+ | App dB dB (infixl "\<degree>" 200)
+ | Abs type dB
+
+primrec
+ nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
+where
+ "[]\<langle>i\<rangle> = None"
+| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"
+
+(*
+inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
+where
+ "nth_el' (x # xs) 0 x"
+| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"
+*)
+inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ : _" [50, 50, 50] 50)
+ where
+ Var [intro!]: "nth_el env x = Some T \<Longrightarrow> env \<turnstile> Var x : T"
+ | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
+(* | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U" *)
+ | App [intro!]: "env \<turnstile> s : U \<Rightarrow> T \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"
+
+primrec
+ lift :: "[dB, nat] => dB"
+where
+ "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
+ | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
+ | "lift (Abs T s) k = Abs T (lift s (k + 1))"
+
+primrec
+ subst :: "[dB, dB, nat] => dB" ("_[_'/_]" [300, 0, 0] 300)
+where
+ subst_Var: "(Var i)[s/k] =
+ (if k < i then Var (i - 1) else if i = k then s else Var i)"
+ | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
+ | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"
+
+inductive beta :: "[dB, dB] => bool" (infixl "\<rightarrow>\<^sub>\<beta>" 50)
+ where
+ beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
+ | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
+ | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
+ | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"
+
+lemma "Gamma \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> Gamma \<turnstile> t' : T"
+quickcheck[generator = pred_compile, size = 10, iterations = 1000]
+oops
+(* FIXME *)
+(*
+inductive test for P where
+"[| filter P vs = res |]
+==> test P vs res"
+
+code_pred test .
+*)
+(*
+export_code test_for_1_yields_1_2 in SML file -
+code_pred (inductify_all) (rpred) test .
+
+thm test.equation
+*)
+
+lemma filter_eq_ConsD:
+ "filter P ys = x#xs \<Longrightarrow>
+ \<exists>us vs. ys = ts @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
+(*quickcheck[generator = pred_compile]*)
+oops
+
+
end
\ No newline at end of file
--- a/src/HOL/ex/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -12,7 +12,6 @@
"Codegenerator_Test",
"Codegenerator_Pretty_Test",
"NormalForm",
- "../NumberTheory/Factorization",
"Predicate_Compile",
"Predicate_Compile_ex"
];
@@ -61,6 +60,7 @@
"BinEx",
"Sqrt",
"Sqrt_Script",
+ "Transfer_Ex",
"Arithmetic_Series_Complex",
"HarmonicSeries",
"Refute_Examples",
@@ -68,29 +68,19 @@
"Landau"
];
-Future.shutdown ();
-(setmp_noncritical proofs 2 (setmp_noncritical Multithreading.max_threads 1 use_thy))
+(setmp_noncritical proofs 2 (setmp_noncritical Goal.parallel_proofs 0 use_thy))
"Hilbert_Classical";
-
use_thy "SVC_Oracle";
-
-fun svc_enabled () = getenv "SVC_HOME" <> "";
-fun if_svc_enabled f x = if svc_enabled () then f x else ();
-
-if_svc_enabled use_thy "svc_test";
-
+if getenv "SVC_HOME" = "" then ()
+else use_thy "svc_test";
-(* requires a proof-generating SAT solver (zChaff or MiniSAT) to be *)
-(* installed: *)
+(*requires a proof-generating SAT solver (zChaff or MiniSAT)*)
try use_thy "SAT_Examples";
-Future.shutdown ();
-(* requires zChaff (or some other reasonably fast SAT solver) to be *)
-(* installed: *)
-if getenv "ZCHAFF_HOME" <> "" then
- use_thy "Sudoku"
-else ();
+(*requires zChaff (or some other reasonably fast SAT solver)*)
+if getenv "ZCHAFF_HOME" = "" then ()
+else use_thy "Sudoku";
HTML.with_charset "utf-8" (no_document use_thys)
["Hebrew", "Chinese", "Serbian"];
--- a/src/HOL/ex/RPred.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/RPred.thy Thu Oct 01 07:40:25 2009 +0200
@@ -14,13 +14,15 @@
definition return :: "'a => 'a rpred"
where "return x = Pair (Predicate.single x)"
-definition bind :: "'a rpred \<Rightarrow> ('a \<Rightarrow> 'b rpred) \<Rightarrow> 'b rpred" (infixl "\<guillemotright>=" 60)
+definition bind :: "'a rpred \<Rightarrow> ('a \<Rightarrow> 'b rpred) \<Rightarrow> 'b rpred"
+(* (infixl "\<guillemotright>=" 60) *)
where "bind RP f =
(\<lambda>s. let (P, s') = RP s;
(s1, s2) = Random.split_seed s'
in (Predicate.bind P (%a. fst (f a s1)), s2))"
-definition supp :: "'a rpred \<Rightarrow> 'a rpred \<Rightarrow> 'a rpred" (infixl "\<squnion>" 80)
+definition supp :: "'a rpred \<Rightarrow> 'a rpred \<Rightarrow> 'a rpred"
+(* (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''))"
@@ -43,6 +45,8 @@
where "lift_random g = scomp g (Pair o (Predicate.single o fst))"
definition map_rpred :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a rpred \<Rightarrow> 'b rpred)"
-where "map_rpred f P = P \<guillemotright>= (return o f)"
+where "map_rpred f P = bind P (return o f)"
+
+hide (open) const return bind supp
end
\ No newline at end of file
--- a/src/HOL/ex/SVC_Oracle.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/SVC_Oracle.thy Thu Oct 01 07:40:25 2009 +0200
@@ -44,8 +44,8 @@
and body = Term.strip_all_body t
val Us = map #2 params
val nPar = length params
- val vname = ref "V_a"
- val pairs = ref ([] : (term*term) list)
+ val vname = Unsynchronized.ref "V_a"
+ val pairs = Unsynchronized.ref ([] : (term*term) list)
fun insert t =
let val T = fastype_of t
val v = Logic.combound (Var ((!vname,0), Us--->T), 0, nPar)
--- a/src/HOL/ex/Sqrt.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Sqrt.thy Thu Oct 01 07:40:25 2009 +0200
@@ -5,7 +5,7 @@
header {* Square roots of primes are irrational *}
theory Sqrt
-imports Complex_Main
+imports Complex_Main "~~/src/HOL/Number_Theory/Primes"
begin
text {*
--- a/src/HOL/ex/Sqrt_Script.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Sqrt_Script.thy Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
header {* Square roots of primes are irrational (script version) *}
theory Sqrt_Script
-imports Complex_Main Primes
+imports Complex_Main "~~/src/HOL/Number_Theory/Primes"
begin
text {*
@@ -16,30 +16,30 @@
subsection {* Preliminaries *}
-lemma prime_nonzero: "prime p \<Longrightarrow> p \<noteq> 0"
- by (force simp add: prime_def)
+lemma prime_nonzero: "prime (p::nat) \<Longrightarrow> p \<noteq> 0"
+ by (force simp add: prime_nat_def)
lemma prime_dvd_other_side:
- "n * n = p * (k * k) \<Longrightarrow> prime p \<Longrightarrow> p dvd n"
- apply (subgoal_tac "p dvd n * n", blast dest: prime_dvd_mult)
+ "(n::nat) * n = p * (k * k) \<Longrightarrow> prime p \<Longrightarrow> p dvd n"
+ apply (subgoal_tac "p dvd n * n", blast dest: prime_dvd_mult_nat)
apply auto
done
-lemma reduction: "prime p \<Longrightarrow>
+lemma reduction: "prime (p::nat) \<Longrightarrow>
0 < k \<Longrightarrow> k * k = p * (j * j) \<Longrightarrow> k < p * j \<and> 0 < j"
apply (rule ccontr)
apply (simp add: linorder_not_less)
apply (erule disjE)
apply (frule mult_le_mono, assumption)
apply auto
- apply (force simp add: prime_def)
+ apply (force simp add: prime_nat_def)
done
lemma rearrange: "(j::nat) * (p * j) = k * k \<Longrightarrow> k * k = p * (j * j)"
by (simp add: mult_ac)
lemma prime_not_square:
- "prime p \<Longrightarrow> (\<And>k. 0 < k \<Longrightarrow> m * m \<noteq> p * (k * k))"
+ "prime (p::nat) \<Longrightarrow> (\<And>k. 0 < k \<Longrightarrow> m * m \<noteq> p * (k * k))"
apply (induct m rule: nat_less_induct)
apply clarify
apply (frule prime_dvd_other_side, assumption)
@@ -57,7 +57,7 @@
*}
theorem prime_sqrt_irrational:
- "prime p \<Longrightarrow> x * x = real p \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<notin> \<rat>"
+ "prime (p::nat) \<Longrightarrow> x * x = real p \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<notin> \<rat>"
apply (rule notI)
apply (erule Rats_abs_nat_div_natE)
apply (simp del: real_of_nat_mult
@@ -65,6 +65,6 @@
done
lemmas two_sqrt_irrational =
- prime_sqrt_irrational [OF two_is_prime]
+ prime_sqrt_irrational [OF two_is_prime_nat]
end
--- a/src/HOL/ex/Termination.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/Termination.thy Thu Oct 01 07:40:25 2009 +0200
@@ -1,5 +1,4 @@
(* Title: HOL/ex/Termination.thy
- ID: $Id$
Author: Lukas Bulwahn, TU Muenchen
Author: Alexander Krauss, TU Muenchen
*)
@@ -10,12 +9,33 @@
imports Main Multiset
begin
+subsection {* Manually giving termination relations using @{text relation} and
+@{term measure} *}
+
+function sum :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+where
+ "sum i N = (if i > N then 0 else i + sum (Suc i) N)"
+by pat_completeness auto
+
+termination by (relation "measure (\<lambda>(i,N). N + 1 - i)") auto
+
+function foo :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+where
+ "foo i N = (if i > N
+ then (if N = 0 then 0 else foo 0 (N - 1))
+ else i + foo (Suc i) N)"
+by pat_completeness auto
+
+termination by (relation "measures [\<lambda>(i, N). N, \<lambda>(i,N). N + 1 - i]") auto
+
+
+subsection {* @{text lexicographic_order}: Trivial examples *}
+
text {*
- The @{text fun} command uses the method @{text lexicographic_order} by default.
+ The @{text fun} command uses the method @{text lexicographic_order} by default,
+ so it is not explicitly invoked.
*}
-subsection {* Trivial examples *}
-
fun identity :: "nat \<Rightarrow> nat"
where
"identity n = n"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/ex/Transfer_Ex.thy Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,42 @@
+
+header {* Various examples for transfer procedure *}
+
+theory Transfer_Ex
+imports Complex_Main
+begin
+
+(* nat to int *)
+
+lemma ex1: "(x::nat) + y = y + x"
+ by auto
+
+thm ex1 [transferred]
+
+lemma ex2: "(a::nat) div b * b + a mod b = a"
+ by (rule mod_div_equality)
+
+thm ex2 [transferred]
+
+lemma ex3: "ALL (x::nat). ALL y. EX z. z >= x + y"
+ by auto
+
+thm ex3 [transferred natint]
+
+lemma ex4: "(x::nat) >= y \<Longrightarrow> (x - y) + y = x"
+ by auto
+
+thm ex4 [transferred]
+
+lemma ex5: "(2::nat) * (SUM i <= n. i) = n * (n + 1)"
+ by (induct n rule: nat_induct, auto)
+
+thm ex5 [transferred]
+
+theorem ex6: "0 <= (n::int) \<Longrightarrow> 2 * \<Sum>{0..n} = n * (n + 1)"
+ by (rule ex5 [transferred])
+
+thm ex6 [transferred]
+
+thm ex5 [transferred, transferred]
+
+end
\ No newline at end of file
--- a/src/HOL/ex/mirabelle.ML Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,318 +0,0 @@
-(* Title: mirabelle.ML
- Author: Jasmin Blanchette and Sascha Boehme
-*)
-
-signature MIRABELLE =
-sig
- type action
- type settings
- val register : string -> action -> theory -> theory
- val invoke : string -> settings -> theory -> theory
-
- val timeout : int Config.T
- val verbose : bool Config.T
- val set_logfile : string -> theory -> theory
-
- val setup : theory -> theory
-
- val step_hook : Toplevel.transition -> Toplevel.state -> Toplevel.state ->
- unit
-
- val goal_thm_of : Proof.state -> thm
- val can_apply : (Proof.context -> int -> tactic) -> Proof.state -> bool
- val theorems_in_proof_term : Thm.thm -> Thm.thm list
- val theorems_of_sucessful_proof : Toplevel.state -> Thm.thm list
- val get_setting : settings -> string * string -> string
- val get_int_setting : settings -> string * int -> int
-
-(* FIXME val refute_action : action *)
- val quickcheck_action : action
- val arith_action : action
- val sledgehammer_action : action
- val metis_action : action
-end
-
-
-
-structure Mirabelle (*: MIRABELLE*) =
-struct
-
-(* Mirabelle core *)
-
-type settings = (string * string) list
-type invoked = {pre: Proof.state, post: Toplevel.state option} -> string option
-type action = settings -> invoked
-
-structure Registered = TheoryDataFun
-(
- type T = action Symtab.table
- val empty = Symtab.empty
- val copy = I
- val extend = I
- fun merge _ = Symtab.merge (K true)
-)
-
-fun register name act = Registered.map (Symtab.update_new (name, act))
-
-
-structure Invoked = TheoryDataFun
-(
- type T = (string * invoked) list
- val empty = []
- val copy = I
- val extend = I
- fun merge _ = Library.merge (K true)
-)
-
-fun invoke name sts thy =
- let
- val act =
- (case Symtab.lookup (Registered.get thy) name of
- SOME act => act
- | NONE => error ("The invoked action " ^ quote name ^
- " is not registered."))
- in Invoked.map (cons (name, act sts)) thy end
-
-val (logfile, setup1) = Attrib.config_string "mirabelle_logfile" ""
-val (timeout, setup2) = Attrib.config_int "mirabelle_timeout" 30
-val (verbose, setup3) = Attrib.config_bool "mirabelle_verbose" true
-val (start_line, setup4) = Attrib.config_int "mirabelle_start_line" 0
-val (end_line, setup5) = Attrib.config_int "mirabelle_end_line" ~1
-
-val setup_config = setup1 #> setup2 #> setup3 #> setup4 #> setup5
-
-fun set_logfile name =
- let val _ = File.write (Path.explode name) "" (* erase file content *)
- in Config.put_thy logfile name end
-
-local
-
-fun log thy s =
- let fun append_to n = if n = "" then K () else File.append (Path.explode n)
- in append_to (Config.get_thy thy logfile) (s ^ "\n") end
- (* FIXME: with multithreading and parallel proofs enabled, we might need to
- encapsulate this inside a critical section *)
-
-fun verbose_msg verbose msg = if verbose then SOME msg else NONE
-
-fun with_time_limit (verb, secs) f x = TimeLimit.timeLimit secs f x
- handle TimeLimit.TimeOut => verbose_msg verb "time out"
- | ERROR msg => verbose_msg verb ("error: " ^ msg)
-
-fun capture_exns verb f x =
- (case try f x of NONE => verbose_msg verb "exception" | SOME msg => msg)
-
-fun apply_action (c as (verb, _)) st (name, invoked) =
- Option.map (pair name) (capture_exns verb (with_time_limit c invoked) st)
-
-fun in_range _ _ NONE = true
- | in_range l r (SOME i) = (l <= i andalso (r < 0 orelse i <= r))
-
-fun only_within_range thy pos f x =
- let val l = Config.get_thy thy start_line and r = Config.get_thy thy end_line
- in if in_range l r (Position.line_of pos) then f x else [] end
-
-fun pretty_print verbose pos name msgs =
- let
- val file = the_default "unknown file" (Position.file_of pos)
-
- val str0 = string_of_int o the_default 0
- val loc = str0 (Position.line_of pos) ^ ":" ^ str0 (Position.column_of pos)
-
- val full_loc = if verbose then file ^ ":" ^ loc else "at " ^ loc
- val head = full_loc ^ " (" ^ name ^ "):"
-
- fun pretty_msg (name, msg) = Pretty.block (map Pretty.str [name, ": ", msg])
- in
- Pretty.string_of (Pretty.big_list head (map pretty_msg msgs))
- end
-
-in
-
-fun basic_hook tr pre post =
- let
- val thy = Proof.theory_of pre
- val pos = Toplevel.pos_of tr
- val name = Toplevel.name_of tr
- val verb = Config.get_thy thy verbose
- val secs = Time.fromSeconds (Config.get_thy thy timeout)
- val st = {pre=pre, post=post}
- in
- Invoked.get thy
- |> only_within_range thy pos (map_filter (apply_action (verb, secs) st))
- |> (fn [] => () | msgs => log thy (pretty_print verb pos name msgs))
- end
-
-end
-
-fun step_hook tr pre post =
- (* FIXME: might require wrapping into "interruptible" *)
- if can (Proof.assert_backward o Toplevel.proof_of) pre andalso
- not (member (op =) ["disable_pr", "enable_pr"] (Toplevel.name_of tr))
- then basic_hook tr (Toplevel.proof_of pre) (SOME post)
- else () (* FIXME: add theory_hook here *)
-
-
-
-(* Mirabelle utility functions *)
-
-val goal_thm_of = snd o snd o Proof.get_goal
-
-fun can_apply tac st =
- let val (ctxt, (facts, goal)) = Proof.get_goal st
- in
- (case Seq.pull (HEADGOAL (Method.insert_tac facts THEN' tac ctxt) goal) of
- SOME (thm, _) => true
- | NONE => false)
- end
-
-local
-
-fun fold_body_thms f =
- let
- fun app n (PBody {thms, ...}) = thms |> fold (fn (i, (name, prop, body)) =>
- fn (x, seen) =>
- if Inttab.defined seen i then (x, seen)
- else
- let
- val body' = Future.join body
- val (x', seen') = app (n + (if name = "" then 0 else 1)) body'
- (x, Inttab.update (i, ()) seen)
- in (x' |> n = 0 ? f (name, prop, body'), seen') end)
- in fn bodies => fn x => #1 (fold (app 0) bodies (x, Inttab.empty)) end
-
-in
-
-fun theorems_in_proof_term thm =
- let
- val all_thms = PureThy.all_thms_of (Thm.theory_of_thm thm)
- fun collect (s, _, _) = if s <> "" then insert (op =) s else I
- fun member_of xs (x, y) = if member (op =) xs x then SOME y else NONE
- fun resolve_thms names = map_filter (member_of names) all_thms
- in
- resolve_thms (fold_body_thms collect [Thm.proof_body_of thm] [])
- end
-
-end
-
-fun theorems_of_sucessful_proof state =
- (case state of
- NONE => []
- | SOME st =>
- if not (Toplevel.is_proof st) then []
- else theorems_in_proof_term (goal_thm_of (Toplevel.proof_of st)))
-
-fun get_setting settings (key, default) =
- the_default default (AList.lookup (op =) settings key)
-
-fun get_int_setting settings (key, default) =
- (case Option.map Int.fromString (AList.lookup (op =) settings key) of
- SOME (SOME i) => i
- | SOME NONE => error ("bad option: " ^ key)
- | NONE => default)
-
-
-
-(* Mirabelle actions *)
-
-(* FIXME
-fun refute_action settings {pre=st, ...} =
- let
- val params = [("minsize", "2") (*"maxsize", "2"*)]
- val subgoal = 0
- val thy = Proof.theory_of st
- val thm = goal_thm_of st
-
- val _ = Refute.refute_subgoal thy parms thm subgoal
- in
- val writ_log = Substring.full (the (Symtab.lookup tab "writeln"))
- val warn_log = Substring.full (the (Symtab.lookup tab "warning"))
-
- val r =
- if Substring.isSubstring "model found" writ_log
- then
- if Substring.isSubstring "spurious" warn_log
- then SOME "potential counterexample"
- else SOME "real counterexample (bug?)"
- else
- if Substring.isSubstring "time limit" writ_log
- then SOME "no counterexample (time out)"
- else if Substring.isSubstring "Search terminated" writ_log
- then SOME "no counterexample (normal termination)"
- else SOME "no counterexample (unknown)"
- in r end
-*)
-
-fun quickcheck_action settings {pre=st, ...} =
- let
- val has_valid_key = member (op =) ["iterations", "size", "generator"] o fst
- val args = filter has_valid_key settings
- in
- (case Quickcheck.quickcheck args 1 st of
- NONE => SOME "no counterexample"
- | SOME _ => SOME "counterexample found")
- end
-
-
-fun arith_action _ {pre=st, ...} =
- if can_apply Arith_Data.arith_tac st
- then SOME "succeeded"
- else NONE
-
-
-fun sledgehammer_action settings {pre=st, ...} =
- let
- val prover_name = hd (space_explode " " (AtpManager.get_atps ()))
- val thy = Proof.theory_of st
-
- val prover = the (AtpManager.get_prover prover_name thy)
- val timeout = AtpManager.get_timeout ()
-
- val (success, message) =
- let
- val (success, message, _, _, _) =
- prover timeout NONE NONE prover_name 1 (Proof.get_goal st)
- in (success, message) end
- handle ResHolClause.TOO_TRIVIAL => (true, "trivial")
- | ERROR msg => (false, "error: " ^ msg)
- in
- if success
- then SOME ("success (" ^ prover_name ^ ": " ^ message ^ ")")
- else NONE
- end
-
-
-fun metis_action settings {pre, post} =
- let
- val thms = theorems_of_sucessful_proof post
- val names = map Thm.get_name thms
-
- val facts = Facts.props (ProofContext.facts_of (Proof.context_of pre))
-
- fun metis ctxt = MetisTools.metis_tac ctxt (thms @ facts)
- in
- (if can_apply metis pre then "succeeded" else "failed")
- |> suffix (" (" ^ commas names ^ ")")
- |> SOME
- end
-
-
-
-(* Mirabelle setup *)
-
-val setup =
- setup_config #>
-(* FIXME register "refute" refute_action #> *)
- register "quickcheck" quickcheck_action #>
- register "arith" arith_action #>
- register "sledgehammer" sledgehammer_action #>
- register "metis" metis_action (* #> FIXME:
- Context.theory_map (Specification.add_theorem_hook theorem_hook) *)
-
-end
-
-val _ = Toplevel.add_hook Mirabelle.step_hook
-
-(* no multithreading, no parallel proofs *)
-val _ = Multithreading.max_threads := 1
-val _ = Goal.parallel_proofs := 0
--- a/src/HOL/ex/predicate_compile.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/predicate_compile.ML Thu Oct 01 07:40:25 2009 +0200
@@ -27,10 +27,10 @@
val code_pred_cmd: string -> Proof.context -> Proof.state
val print_stored_rules: theory -> unit
val print_all_modes: theory -> unit
- val do_proofs: bool ref
+ val do_proofs: bool Unsynchronized.ref
val mk_casesrule : Proof.context -> int -> thm list -> term
val analyze_compr: theory -> term -> term
- val eval_ref: (unit -> term Predicate.pred) option ref
+ val eval_ref: (unit -> term Predicate.pred) option Unsynchronized.ref
val add_equations : string list -> theory -> theory
val code_pred_intros_attrib : attribute
(* used by Quickcheck_Generator *)
@@ -111,7 +111,7 @@
fun print_tac s = Seq.single; (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *)
fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
-val do_proofs = ref true;
+val do_proofs = Unsynchronized.ref true;
fun mycheat_tac thy i st =
(Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) i) st
@@ -169,7 +169,7 @@
end;
fun dest_randomT (Type ("fun", [@{typ Random.seed},
- Type ("*", [Type ("*", [T, @{typ "unit => Code_Eval.term"}]) ,@{typ Random.seed}])])) = T
+ Type ("*", [Type ("*", [T, @{typ "unit => Code_Evaluation.term"}]) ,@{typ Random.seed}])])) = T
| dest_randomT T = raise TYPE ("dest_randomT", [T], [])
(* destruction of intro rules *)
@@ -707,7 +707,7 @@
end;
(* termify_code:
-val termT = Type ("Code_Eval.term", []);
+val termT = Type ("Code_Evaluation.term", []);
fun termifyT T = HOLogic.mk_prodT (T, HOLogic.unitT --> termT)
*)
(*
@@ -1198,7 +1198,7 @@
val t1' = mk_valtermify_term t1
val t2' = mk_valtermify_term t2
in
- Const ("Code_Eval.valapp", termifyT T --> termifyT T1 --> termifyT T2) $ t1' $ t2'
+ Const ("Code_Evaluation.valapp", termifyT T --> termifyT T1 --> termifyT T2) $ t1' $ t2'
end
| mk_valtermify_term _ = error "Not a valid term for mk_valtermify_term"
*)
@@ -2100,7 +2100,7 @@
(* transformation for code generation *)
-val eval_ref = ref (NONE : (unit -> term Predicate.pred) option);
+val eval_ref = Unsynchronized.ref (NONE : (unit -> term Predicate.pred) option);
(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
fun analyze_compr thy t_compr =
@@ -2152,7 +2152,7 @@
val (ts, _) = Predicate.yieldn k t;
val elemsT = HOLogic.mk_set T ts;
in if k = ~1 orelse length ts < k then elemsT
- else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ t_compr
+ else Const (@{const_name Lattices.sup}, setT --> setT --> setT) $ elemsT $ t_compr
end;
fun values_cmd modes k raw_t state =
--- a/src/HOL/ex/svc_funcs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOL/ex/svc_funcs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -18,7 +18,7 @@
structure Svc =
struct
- val trace = ref false;
+ val trace = Unsynchronized.ref false;
datatype expr =
Buildin of string * expr list
@@ -127,7 +127,7 @@
let
val params = rev (Term.rename_wrt_term t (Term.strip_all_vars t))
and body = Term.strip_all_body t
- val nat_vars = ref ([] : string list)
+ val nat_vars = Unsynchronized.ref ([] : string list)
(*translation of a variable: record all natural numbers*)
fun trans_var (a,T,is) =
(if T = HOLogic.natT then nat_vars := (insert (op =) a (!nat_vars))
--- a/src/HOLCF/Tools/Domain/domain_theorems.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/HOLCF/Tools/Domain/domain_theorems.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,6 +1,6 @@
(* Title: HOLCF/Tools/Domain/domain_theorems.ML
Author: David von Oheimb
- New proofs/tactics by Brian Huffman
+ Author: Brian Huffman
Proof generator for domain command.
*)
@@ -11,15 +11,15 @@
sig
val theorems: Domain_Library.eq * Domain_Library.eq list -> theory -> thm list * theory;
val comp_theorems: bstring * Domain_Library.eq list -> theory -> thm list * theory;
- val quiet_mode: bool ref;
- val trace_domain: bool ref;
+ val quiet_mode: bool Unsynchronized.ref;
+ val trace_domain: bool Unsynchronized.ref;
end;
structure Domain_Theorems :> DOMAIN_THEOREMS =
struct
-val quiet_mode = ref false;
-val trace_domain = ref false;
+val quiet_mode = Unsynchronized.ref false;
+val trace_domain = Unsynchronized.ref false;
fun message s = if !quiet_mode then () else writeln s;
fun trace s = if !trace_domain then tracing s else ();
--- a/src/Provers/Arith/fast_lin_arith.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/Arith/fast_lin_arith.ML Thu Oct 01 07:40:25 2009 +0200
@@ -96,8 +96,8 @@
lessD: thm list, neqE: thm list, simpset: Simplifier.simpset,
number_of : serial * (theory -> typ -> int -> cterm)})
-> Context.generic -> Context.generic
- val trace: bool ref
- val warning_count: int ref;
+ val trace: bool Unsynchronized.ref
+ val warning_count: int Unsynchronized.ref;
end;
functor Fast_Lin_Arith
@@ -152,7 +152,7 @@
treat non-negative atoms separately rather than adding 0 <= atom
*)
-val trace = ref false;
+val trace = Unsynchronized.ref false;
datatype lineq_type = Eq | Le | Lt;
@@ -426,7 +426,7 @@
fun trace_msg msg =
if !trace then tracing msg else ();
-val warning_count = ref 0;
+val warning_count = Unsynchronized.ref 0;
val warning_count_max = 10;
val union_term = curry (gen_union Pattern.aeconv);
@@ -533,7 +533,7 @@
val _ =
if LA_Logic.is_False fls then ()
else
- let val count = CRITICAL (fn () => inc warning_count) in
+ let val count = CRITICAL (fn () => Unsynchronized.inc warning_count) in
if count > warning_count_max then ()
else
(tracing (cat_lines
--- a/src/Provers/blast.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/blast.ML Thu Oct 01 07:40:25 2009 +0200
@@ -66,9 +66,9 @@
exception TRANS of string (*reports translation errors*)
datatype term =
Const of string * term list
- | Skolem of string * term option ref list
+ | Skolem of string * term option Unsynchronized.ref list
| Free of string
- | Var of term option ref
+ | Var of term option Unsynchronized.ref
| Bound of int
| Abs of string*term
| $ of term*term;
@@ -78,10 +78,10 @@
val blast_tac : claset -> int -> tactic
val setup : theory -> theory
(*debugging tools*)
- val stats : bool ref
- val trace : bool ref
- val fullTrace : branch list list ref
- val fromType : (indexname * term) list ref -> Term.typ -> term
+ val stats : bool Unsynchronized.ref
+ val trace : bool Unsynchronized.ref
+ val fullTrace : branch list list Unsynchronized.ref
+ val fromType : (indexname * term) list Unsynchronized.ref -> Term.typ -> term
val fromTerm : theory -> Term.term -> term
val fromSubgoal : theory -> Term.term -> term
val instVars : term -> (unit -> unit)
@@ -98,14 +98,14 @@
type claset = Data.claset;
-val trace = ref false
-and stats = ref false; (*for runtime and search statistics*)
+val trace = Unsynchronized.ref false
+and stats = Unsynchronized.ref false; (*for runtime and search statistics*)
datatype term =
Const of string * term list (*typargs constant--as a terms!*)
- | Skolem of string * term option ref list
+ | Skolem of string * term option Unsynchronized.ref list
| Free of string
- | Var of term option ref
+ | Var of term option Unsynchronized.ref
| Bound of int
| Abs of string*term
| op $ of term*term;
@@ -115,7 +115,7 @@
{pairs: ((term*bool) list * (*safe formulae on this level*)
(term*bool) list) list, (*haz formulae on this level*)
lits: term list, (*literals: irreducible formulae*)
- vars: term option ref list, (*variables occurring in branch*)
+ vars: term option Unsynchronized.ref list, (*variables occurring in branch*)
lim: int}; (*resource limit*)
@@ -123,11 +123,11 @@
datatype state = State of
{thy: theory,
- fullTrace: branch list list ref,
- trail: term option ref list ref,
- ntrail: int ref,
- nclosed: int ref,
- ntried: int ref}
+ fullTrace: branch list list Unsynchronized.ref,
+ trail: term option Unsynchronized.ref list Unsynchronized.ref,
+ ntrail: int Unsynchronized.ref,
+ nclosed: int Unsynchronized.ref,
+ ntried: int Unsynchronized.ref}
fun reject_const thy c =
is_some (Sign.const_type thy c) andalso
@@ -138,11 +138,11 @@
reject_const thy "*False*";
State
{thy = thy,
- fullTrace = ref [],
- trail = ref [],
- ntrail = ref 0,
- nclosed = ref 0, (*branches closed: number of branches closed during the search*)
- ntried = ref 1}); (*branches tried: number of branches created by splitting (counting from 1)*)
+ fullTrace = Unsynchronized.ref [],
+ trail = Unsynchronized.ref [],
+ ntrail = Unsynchronized.ref 0,
+ nclosed = Unsynchronized.ref 0, (*branches closed: number of branches closed during the search*)
+ ntried = Unsynchronized.ref 1}); (*branches tried: number of branches created by splitting (counting from 1)*)
@@ -199,7 +199,7 @@
| fromType alist (Term.TFree(a,_)) = Free a
| fromType alist (Term.TVar (ixn,_)) =
(case (AList.lookup (op =) (!alist) ixn) of
- NONE => let val t' = Var(ref NONE)
+ NONE => let val t' = Var (Unsynchronized.ref NONE)
in alist := (ixn, t') :: !alist; t'
end
| SOME v => v)
@@ -209,11 +209,11 @@
(*Tests whether 2 terms are alpha-convertible; chases instantiations*)
-fun (Const (a, ts)) aconv (Const (b, us)) = a=b andalso aconvs (ts, us)
- | (Skolem (a,_)) aconv (Skolem (b,_)) = a=b (*arglists must then be equal*)
- | (Free a) aconv (Free b) = a=b
- | (Var(ref(SOME t))) aconv u = t aconv u
- | t aconv (Var(ref(SOME u))) = t aconv u
+fun (Const (a, ts)) aconv (Const (b, us)) = a = b andalso aconvs (ts, us)
+ | (Skolem (a,_)) aconv (Skolem (b,_)) = a = b (*arglists must then be equal*)
+ | (Free a) aconv (Free b) = a = b
+ | (Var (Unsynchronized.ref(SOME t))) aconv u = t aconv u
+ | t aconv (Var (Unsynchronized.ref (SOME u))) = t aconv u
| (Var v) aconv (Var w) = v=w (*both Vars are un-assigned*)
| (Bound i) aconv (Bound j) = i=j
| (Abs(_,t)) aconv (Abs(_,u)) = t aconv u
@@ -229,7 +229,7 @@
fun ins_term(t,ts) = if mem_term(t,ts) then ts else t :: ts;
-fun mem_var (v: term option ref, []) = false
+fun mem_var (v: term option Unsynchronized.ref, []) = false
| mem_var (v, v'::vs) = v=v' orelse mem_var(v,vs);
fun ins_var(v,vs) = if mem_var(v,vs) then vs else v :: vs;
@@ -238,19 +238,19 @@
(** Vars **)
(*Accumulates the Vars in the term, suppressing duplicates*)
-fun add_term_vars (Skolem(a,args), vars) = add_vars_vars(args,vars)
- | add_term_vars (Var (v as ref NONE), vars) = ins_var (v, vars)
- | add_term_vars (Var (ref (SOME u)), vars) = add_term_vars(u,vars)
- | add_term_vars (Const (_,ts), vars) = add_terms_vars(ts,vars)
- | add_term_vars (Abs (_,body), vars) = add_term_vars(body,vars)
- | add_term_vars (f$t, vars) = add_term_vars (f, add_term_vars(t, vars))
- | add_term_vars (_, vars) = vars
+fun add_term_vars (Skolem(a,args), vars) = add_vars_vars(args,vars)
+ | add_term_vars (Var (v as Unsynchronized.ref NONE), vars) = ins_var (v, vars)
+ | add_term_vars (Var (Unsynchronized.ref (SOME u)), vars) = add_term_vars (u, vars)
+ | add_term_vars (Const (_, ts), vars) = add_terms_vars (ts, vars)
+ | add_term_vars (Abs (_, body), vars) = add_term_vars (body, vars)
+ | add_term_vars (f $ t, vars) = add_term_vars (f, add_term_vars (t, vars))
+ | add_term_vars (_, vars) = vars
(*Term list version. [The fold functionals are slow]*)
and add_terms_vars ([], vars) = vars
| add_terms_vars (t::ts, vars) = add_terms_vars (ts, add_term_vars(t,vars))
(*Var list version.*)
-and add_vars_vars ([], vars) = vars
- | add_vars_vars (ref (SOME u) :: vs, vars) =
+and add_vars_vars ([], vars) = vars
+ | add_vars_vars (Unsynchronized.ref (SOME u) :: vs, vars) =
add_vars_vars (vs, add_term_vars(u,vars))
| add_vars_vars (v::vs, vars) = (*v must be a ref NONE*)
add_vars_vars (vs, ins_var (v, vars));
@@ -297,10 +297,10 @@
(*Normalize...but not the bodies of ABSTRACTIONS*)
fun norm t = case t of
- Skolem (a,args) => Skolem(a, vars_in_vars args)
- | Const(a,ts) => Const(a, map norm ts)
- | (Var (ref NONE)) => t
- | (Var (ref (SOME u))) => norm u
+ Skolem (a, args) => Skolem (a, vars_in_vars args)
+ | Const (a, ts) => Const (a, map norm ts)
+ | (Var (Unsynchronized.ref NONE)) => t
+ | (Var (Unsynchronized.ref (SOME u))) => norm u
| (f $ u) => (case norm f of
Abs(_,body) => norm (subst_bound (u, body))
| nf => nf $ norm u)
@@ -394,14 +394,14 @@
(*Convert from "real" terms to prototerms; eta-contract.
Code is similar to fromSubgoal.*)
fun fromTerm thy t =
- let val alistVar = ref []
- and alistTVar = ref []
+ let val alistVar = Unsynchronized.ref []
+ and alistTVar = Unsynchronized.ref []
fun from (Term.Const aT) = fromConst thy alistTVar aT
| from (Term.Free (a,_)) = Free a
| from (Term.Bound i) = Bound i
| from (Term.Var (ixn,T)) =
(case (AList.lookup (op =) (!alistVar) ixn) of
- NONE => let val t' = Var(ref NONE)
+ NONE => let val t' = Var (Unsynchronized.ref NONE)
in alistVar := (ixn, t') :: !alistVar; t'
end
| SOME v => v)
@@ -417,10 +417,10 @@
(*A debugging function: replaces all Vars by dummy Frees for visual inspection
of whether they are distinct. Function revert undoes the assignments.*)
fun instVars t =
- let val name = ref "a"
- val updated = ref []
+ let val name = Unsynchronized.ref "a"
+ val updated = Unsynchronized.ref []
fun inst (Const(a,ts)) = List.app inst ts
- | inst (Var(v as ref NONE)) = (updated := v :: (!updated);
+ | inst (Var(v as Unsynchronized.ref NONE)) = (updated := v :: (!updated);
v := SOME (Free ("?" ^ !name));
name := Symbol.bump_string (!name))
| inst (Abs(a,t)) = inst t
@@ -450,7 +450,7 @@
fun delete_concl [] = raise ElimBadPrem
| delete_concl (P :: Ps) =
(case P of
- Const (c, _) $ Var (ref (SOME (Const ("*False*", _)))) =>
+ Const (c, _) $ Var (Unsynchronized.ref (SOME (Const ("*False*", _)))) =>
if c = "*Goal*" orelse c = Data.not_name then Ps
else P :: delete_concl Ps
| _ => P :: delete_concl Ps);
@@ -606,10 +606,10 @@
(*Convert from prototerms to ordinary terms with dummy types for tracing*)
fun showTerm d (Const (a,_)) = Term.Const (a,dummyT)
| showTerm d (Skolem(a,_)) = Term.Const (a,dummyT)
- | showTerm d (Free a) = Term.Free (a,dummyT)
- | showTerm d (Bound i) = Term.Bound i
- | showTerm d (Var(ref(SOME u))) = showTerm d u
- | showTerm d (Var(ref NONE)) = dummyVar2
+ | showTerm d (Free a) = Term.Free (a,dummyT)
+ | showTerm d (Bound i) = Term.Bound i
+ | showTerm d (Var (Unsynchronized.ref(SOME u))) = showTerm d u
+ | showTerm d (Var (Unsynchronized.ref NONE)) = dummyVar2
| showTerm d (Abs(a,t)) = if d=0 then dummyVar
else Term.Abs(a, dummyT, showTerm (d-1) t)
| showTerm d (f $ u) = if d=0 then dummyVar
@@ -687,10 +687,10 @@
(*Replace the ATOMIC term "old" by "new" in t*)
fun subst_atomic (old,new) t =
- let fun subst (Var(ref(SOME u))) = subst u
- | subst (Abs(a,body)) = Abs(a, subst body)
- | subst (f$t) = subst f $ subst t
- | subst t = if t aconv old then new else t
+ let fun subst (Var(Unsynchronized.ref(SOME u))) = subst u
+ | subst (Abs(a,body)) = Abs(a, subst body)
+ | subst (f$t) = subst f $ subst t
+ | subst t = if t aconv old then new else t
in subst t end;
(*Eta-contract a term from outside: just enough to reduce it to an atom*)
@@ -723,11 +723,11 @@
Skolem(_,vars) => vars
| _ => []
fun occEq u = (t aconv u) orelse occ u
- and occ (Var(ref(SOME u))) = occEq u
- | occ (Var v) = not (mem_var (v, vars))
- | occ (Abs(_,u)) = occEq u
- | occ (f$u) = occEq u orelse occEq f
- | occ (_) = false;
+ and occ (Var(Unsynchronized.ref(SOME u))) = occEq u
+ | occ (Var v) = not (mem_var (v, vars))
+ | occ (Abs(_,u)) = occEq u
+ | occ (f$u) = occEq u orelse occEq f
+ | occ _ = false;
in occEq end;
exception DEST_EQ;
@@ -1199,8 +1199,8 @@
(*Translation of a subgoal: Skolemize all parameters*)
fun fromSubgoal thy t =
- let val alistVar = ref []
- and alistTVar = ref []
+ let val alistVar = Unsynchronized.ref []
+ and alistTVar = Unsynchronized.ref []
fun hdvar ((ix,(v,is))::_) = v
fun from lev t =
let val (ht,ts) = Term.strip_comb t
@@ -1219,7 +1219,7 @@
| Term.Bound i => apply (Bound i)
| Term.Var (ix,_) =>
(case (AList.lookup (op =) (!alistVar) ix) of
- NONE => (alistVar := (ix, (ref NONE, bounds ts))
+ NONE => (alistVar := (ix, (Unsynchronized.ref NONE, bounds ts))
:: !alistVar;
Var (hdvar(!alistVar)))
| SOME(v,is) => if is=bounds ts then Var v
@@ -1290,7 +1290,7 @@
(*** For debugging: these apply the prover to a subgoal and return
the resulting tactics, trace, etc. ***)
-val fullTrace = ref ([]: branch list list);
+val fullTrace = Unsynchronized.ref ([]: branch list list);
(*Read a string to make an initial, singleton branch*)
fun readGoal thy s = Syntax.read_prop_global thy s |> fromTerm thy |> rand |> mkGoal;
--- a/src/Provers/classical.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/classical.ML Thu Oct 01 07:40:25 2009 +0200
@@ -74,7 +74,7 @@
val fast_tac : claset -> int -> tactic
val slow_tac : claset -> int -> tactic
- val weight_ASTAR : int ref
+ val weight_ASTAR : int Unsynchronized.ref
val astar_tac : claset -> int -> tactic
val slow_astar_tac : claset -> int -> tactic
val best_tac : claset -> int -> tactic
@@ -746,7 +746,7 @@
(***ASTAR with weight weight_ASTAR, by Norbert Voelker*)
-val weight_ASTAR = ref 5;
+val weight_ASTAR = Unsynchronized.ref 5;
fun astar_tac cs =
ObjectLogic.atomize_prems_tac THEN'
--- a/src/Provers/order.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/order.ML Thu Oct 01 07:40:25 2009 +0200
@@ -611,7 +611,7 @@
let
(* Compute list of reversed edges for each adjacency list *)
fun flip (u,(v,l)::el) = (v,(u,l)) :: flip (u,el)
- | flip (_,nil) = nil
+ | flip (_,[]) = []
(* Compute adjacency list for node u from the list of edges
and return a likewise reduced list of edges. The list of edges
@@ -623,7 +623,7 @@
if eq_comp (u, v) then (w::adj,edges)
else (adj,(v,w)::edges)
end
- | gather (_,nil) = (nil,nil)
+ | gather (_,[]) = ([],[])
(* For every node in the input graph, call gather to find all reachable
nodes in the list of edges *)
@@ -631,11 +631,11 @@
let val (adj,edges) = gather (u,edges)
in (u,adj) :: assemble el edges
end
- | assemble nil _ = nil
+ | assemble [] _ = []
(* Compute, for each adjacency list, the list with reversed edges,
and concatenate these lists. *)
- val flipped = List.foldr (op @) nil (map flip g)
+ val flipped = maps flip g
in assemble g flipped end
@@ -656,10 +656,10 @@
let
(* Ordered list of the vertices that DFS has finished with;
most recently finished goes at the head. *)
- val finish : term list ref = ref nil
+ val finish : term list Unsynchronized.ref = Unsynchronized.ref []
(* List of vertices which have been visited. *)
- val visited : term list ref = ref nil
+ val visited : term list Unsynchronized.ref = Unsynchronized.ref []
fun been_visited v = exists (fn w => w aconv v) (!visited)
@@ -675,7 +675,7 @@
val descendents =
List.foldr (fn ((v,l),ds) => if been_visited v then ds
else v :: dfs_visit g v @ ds)
- nil (adjacent (op aconv) g u)
+ [] (adjacent (op aconv) g u)
in
finish := u :: !finish;
descendents
@@ -687,7 +687,7 @@
as yet unvisited. *)
app (fn u => if been_visited u then ()
else (dfs_visit G u; ())) (members G);
- visited := nil;
+ visited := [];
(* We don't reset finish because its value is used by
foldl below, and it will never be used again (even
@@ -699,7 +699,7 @@
list, which is what is returned. *)
Library.foldl (fn (comps,u) =>
if been_visited u then comps
- else ((u :: dfs_visit (transpose (op aconv) G) u) :: comps)) (nil,(!finish))
+ else ((u :: dfs_visit (transpose (op aconv) G) u) :: comps)) ([],(!finish))
end;
@@ -715,7 +715,7 @@
fun dfs_int_reachable g u =
let
(* List of vertices which have been visited. *)
- val visited : int list ref = ref nil
+ val visited : int list Unsynchronized.ref = Unsynchronized.ref []
fun been_visited v = exists (fn w => w = v) (!visited)
@@ -725,7 +725,7 @@
val descendents =
List.foldr (fn ((v,l),ds) => if been_visited v then ds
else v :: dfs_visit g v @ ds)
- nil (adjacent (op =) g u)
+ [] (adjacent (op =) g u)
in descendents end
in u :: dfs_visit g u end;
@@ -755,8 +755,8 @@
fun dfs eq_comp g u v =
let
- val pred = ref nil;
- val visited = ref nil;
+ val pred = Unsynchronized.ref [];
+ val visited = Unsynchronized.ref [];
fun been_visited v = exists (fn w => eq_comp (w, v)) (!visited)
--- a/src/Provers/quasi.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/quasi.ML Thu Oct 01 07:40:25 2009 +0200
@@ -348,8 +348,8 @@
fun dfs eq_comp g u v =
let
- val pred = ref nil;
- val visited = ref nil;
+ val pred = Unsynchronized.ref [];
+ val visited = Unsynchronized.ref [];
fun been_visited v = exists (fn w => eq_comp (w, v)) (!visited)
--- a/src/Provers/trancl.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Provers/trancl.ML Thu Oct 01 07:40:25 2009 +0200
@@ -275,8 +275,8 @@
fun dfs eq_comp g u v =
let
- val pred = ref nil;
- val visited = ref nil;
+ val pred = Unsynchronized.ref [];
+ val visited = Unsynchronized.ref [];
fun been_visited v = exists (fn w => eq_comp (w, v)) (!visited)
@@ -309,7 +309,7 @@
let
(* Compute list of reversed edges for each adjacency list *)
fun flip (u,(v,l)::el) = (v,(u,l)) :: flip (u,el)
- | flip (_,nil) = nil
+ | flip (_,[]) = []
(* Compute adjacency list for node u from the list of edges
and return a likewise reduced list of edges. The list of edges
@@ -321,7 +321,7 @@
if eq_comp (u, v) then (w::adj,edges)
else (adj,(v,w)::edges)
end
- | gather (_,nil) = (nil,nil)
+ | gather (_,[]) = ([],[])
(* For every node in the input graph, call gather to find all reachable
nodes in the list of edges *)
@@ -329,11 +329,11 @@
let val (adj,edges) = gather (u,edges)
in (u,adj) :: assemble el edges
end
- | assemble nil _ = nil
+ | assemble [] _ = []
(* Compute, for each adjacency list, the list with reversed edges,
and concatenate these lists. *)
- val flipped = List.foldr (op @) nil (map flip g)
+ val flipped = maps flip g
in assemble g flipped end
@@ -349,7 +349,7 @@
fun dfs_reachable eq_comp g u =
let
(* List of vertices which have been visited. *)
- val visited = ref nil;
+ val visited = Unsynchronized.ref [];
fun been_visited v = exists (fn w => eq_comp (w, v)) (!visited)
@@ -359,7 +359,7 @@
val descendents =
List.foldr (fn ((v,l),ds) => if been_visited v then ds
else v :: dfs_visit g v @ ds)
- nil (adjacent eq_comp g u)
+ [] (adjacent eq_comp g u)
in descendents end
in u :: dfs_visit g u end;
--- a/src/Pure/Concurrent/future.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Concurrent/future.ML Thu Oct 01 07:40:25 2009 +0200
@@ -37,10 +37,11 @@
val peek: 'a future -> 'a Exn.result option
val is_finished: 'a future -> bool
val value: 'a -> 'a future
- val fork: (unit -> 'a) -> 'a future
val fork_group: group -> (unit -> 'a) -> 'a future
+ val fork_deps_pri: 'b future list -> int -> (unit -> 'a) -> 'a future
val fork_deps: 'b future list -> (unit -> 'a) -> 'a future
val fork_pri: int -> (unit -> 'a) -> 'a future
+ val fork: (unit -> 'a) -> 'a future
val join_results: 'a future list -> 'a Exn.result list
val join_result: 'a future -> 'a Exn.result
val join: 'a future -> 'a
@@ -84,7 +85,7 @@
fun group_of (Future {group, ...}) = group;
fun result_of (Future {result, ...}) = result;
-fun peek x = Synchronized.peek (result_of x);
+fun peek x = Synchronized.value (result_of x);
fun is_finished x = is_some (peek x);
fun value x = Future
@@ -98,13 +99,13 @@
(* global state *)
-val queue = ref Task_Queue.empty;
-val next = ref 0;
-val workers = ref ([]: (Thread.thread * bool) list);
-val scheduler = ref (NONE: Thread.thread option);
-val excessive = ref 0;
-val canceled = ref ([]: Task_Queue.group list);
-val do_shutdown = ref false;
+val queue = Unsynchronized.ref Task_Queue.empty;
+val next = Unsynchronized.ref 0;
+val workers = Unsynchronized.ref ([]: (Thread.thread * bool) list);
+val scheduler = Unsynchronized.ref (NONE: Thread.thread option);
+val excessive = Unsynchronized.ref 0;
+val canceled = Unsynchronized.ref ([]: Task_Queue.group list);
+val do_shutdown = Unsynchronized.ref false;
(* synchronization *)
@@ -161,7 +162,8 @@
in (result, job) end;
fun do_cancel group = (*requires SYNCHRONIZED*)
- (change canceled (insert Task_Queue.eq_group group); broadcast scheduler_event);
+ (Unsynchronized.change canceled (insert Task_Queue.eq_group group);
+ broadcast scheduler_event);
fun execute name (task, group, jobs) =
let
@@ -170,7 +172,7 @@
fold (fn job => fn ok => job valid andalso ok) jobs true) ();
val _ = SYNCHRONIZED "finish" (fn () =>
let
- val maximal = change_result queue (Task_Queue.finish task);
+ val maximal = Unsynchronized.change_result queue (Task_Queue.finish task);
val _ =
if ok then ()
else if Task_Queue.cancel (! queue) group then ()
@@ -187,7 +189,8 @@
fold (fn (_, active) => fn i => if active then i + 1 else i) (! workers) 0;
fun change_active active = (*requires SYNCHRONIZED*)
- change workers (AList.update Thread.equal (Thread.self (), active));
+ Unsynchronized.change workers
+ (AList.update Thread.equal (Thread.self (), active));
(* worker threads *)
@@ -197,14 +200,15 @@
fun worker_next () = (*requires SYNCHRONIZED*)
if ! excessive > 0 then
- (dec excessive;
- change workers (filter_out (fn (thread, _) => Thread.equal (thread, Thread.self ())));
+ (Unsynchronized.dec excessive;
+ Unsynchronized.change workers
+ (filter_out (fn (thread, _) => Thread.equal (thread, Thread.self ())));
broadcast scheduler_event;
NONE)
else if count_active () > Multithreading.max_threads_value () then
(worker_wait scheduler_event; worker_next ())
else
- (case change_result queue (Task_Queue.dequeue (Thread.self ())) of
+ (case Unsynchronized.change_result queue (Task_Queue.dequeue (Thread.self ())) of
NONE => (worker_wait work_available; worker_next ())
| some => some);
@@ -214,13 +218,13 @@
| SOME work => (execute name work; worker_loop name));
fun worker_start name = (*requires SYNCHRONIZED*)
- change workers (cons (SimpleThread.fork false (fn () =>
+ Unsynchronized.change workers (cons (SimpleThread.fork false (fn () =>
(broadcast scheduler_event; worker_loop name)), true));
(* scheduler *)
-val last_status = ref Time.zeroTime;
+val last_status = Unsynchronized.ref Time.zeroTime;
val next_status = Time.fromMilliseconds 500;
val next_round = Time.fromMilliseconds 50;
@@ -237,7 +241,7 @@
val total = length (! workers);
val active = count_active ();
in
- "SCHEDULE: " ^
+ "SCHEDULE " ^ Time.toString now ^ ": " ^
string_of_int ready ^ " ready, " ^
string_of_int pending ^ " pending, " ^
string_of_int running ^ " running; " ^
@@ -257,12 +261,13 @@
"SCHEDULE: disposed " ^ string_of_int (length dead) ^ " dead worker threads")));
val m = if ! do_shutdown then 0 else Multithreading.max_threads_value ();
- val mm = (m * 3) div 2;
+ val mm = if m = 9999 then 1 else m * 2;
val l = length (! workers);
val _ = excessive := l - mm;
val _ =
if mm > l then
- funpow (mm - l) (fn () => worker_start ("worker " ^ string_of_int (inc next))) ()
+ funpow (mm - l) (fn () =>
+ worker_start ("worker " ^ string_of_int (Unsynchronized.inc next))) ()
else ();
(*canceled groups*)
@@ -271,7 +276,7 @@
else
(Multithreading.tracing 1 (fn () =>
string_of_int (length (! canceled)) ^ " canceled groups");
- change canceled (filter_out (Task_Queue.cancel (! queue)));
+ Unsynchronized.change canceled (filter_out (Task_Queue.cancel (! queue)));
broadcast_work ());
(*delay loop*)
@@ -316,16 +321,18 @@
val (result, job) = future_job group e;
val task = SYNCHRONIZED "enqueue" (fn () =>
let
- val (task, minimal) = change_result queue (Task_Queue.enqueue group deps pri job);
+ val (task, minimal) =
+ Unsynchronized.change_result queue (Task_Queue.enqueue group deps pri job);
val _ = if minimal then signal work_available else ();
val _ = scheduler_check ();
in task end);
in Future {task = task, group = group, result = result} end;
-fun fork e = fork_future NONE [] 0 e;
fun fork_group group e = fork_future (SOME group) [] 0 e;
-fun fork_deps deps e = fork_future NONE (map task_of deps) 0 e;
-fun fork_pri pri e = fork_future NONE [] pri e;
+fun fork_deps_pri deps pri e = fork_future NONE (map task_of deps) pri e;
+fun fork_deps deps e = fork_deps_pri deps 0 e;
+fun fork_pri pri e = fork_deps_pri [] pri e;
+fun fork e = fork_deps [] e;
(* join *)
@@ -345,7 +352,7 @@
fun join_next deps = (*requires SYNCHRONIZED*)
if null deps then NONE
else
- (case change_result queue (Task_Queue.dequeue_towards (Thread.self ()) deps) of
+ (case Unsynchronized.change_result queue (Task_Queue.dequeue_towards (Thread.self ()) deps) of
(NONE, []) => NONE
| (NONE, deps') => (worker_wait work_finished; join_next deps')
| (SOME work, deps') => SOME (work, deps'));
--- a/src/Pure/Concurrent/par_list.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Concurrent/par_list.ML Thu Oct 01 07:40:25 2009 +0200
@@ -27,8 +27,10 @@
struct
fun raw_map f xs =
- let val group = Task_Queue.new_group (Future.worker_group ())
- in Future.join_results (map (fn x => Future.fork_group group (fn () => f x)) xs) end;
+ if Multithreading.enabled () then
+ let val group = Task_Queue.new_group (Future.worker_group ())
+ in Future.join_results (map (fn x => Future.fork_group group (fn () => f x)) xs) end
+ else map (Exn.capture f) xs;
fun map f xs = Exn.release_first (raw_map f xs);
--- a/src/Pure/Concurrent/synchronized.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Concurrent/synchronized.ML Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,6 @@
sig
type 'a var
val var: string -> 'a -> 'a var
- val peek: 'a var -> 'a
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
@@ -25,17 +24,15 @@
{name: string,
lock: Mutex.mutex,
cond: ConditionVar.conditionVar,
- var: 'a ref};
+ var: 'a Unsynchronized.ref};
fun var name x = Var
{name = name,
lock = Mutex.mutex (),
cond = ConditionVar.conditionVar (),
- var = ref x};
+ var = Unsynchronized.ref x};
-fun peek (Var {var, ...}) = ! var; (*unsynchronized!*)
-
-fun value (Var {name, lock, cond, var}) = SimpleThread.synchronized name lock (fn () => ! var);
+fun value (Var {var, ...}) = ! var;
(* synchronized access *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/Concurrent/synchronized_dummy.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,25 @@
+(* Title: Pure/Concurrent/synchronized_dummy.ML
+ Author: Makarius
+
+Dummy version of state variables -- plain refs for sequential access.
+*)
+
+structure Synchronized: SYNCHRONIZED =
+struct
+
+datatype 'a var = Var of 'a Unsynchronized.ref;
+
+fun var _ x = Var (Unsynchronized.ref x);
+fun value (Var var) = ! var;
+
+fun timed_access (Var var) _ f =
+ (case f (! var) of
+ SOME (y, x') => (var := x'; SOME y)
+ | NONE => Thread.unavailable ());
+
+fun guarded_access var f = the (timed_access var (K NONE) f);
+
+fun change_result var f = guarded_access var (SOME o f);
+fun change var f = change_result var (fn x => ((), f x));
+
+end;
--- a/src/Pure/General/alist.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/alist.ML Thu Oct 01 07:40:25 2009 +0200
@@ -122,6 +122,6 @@
in coal end;
fun group eq xs =
- fold_rev (fn (k, v) => default eq (k, []) #> map_entry eq k (cons v)) xs [];
+ fold_rev (fn (k, v) => map_default eq (k, []) (cons v)) xs [];
end;
--- a/src/Pure/General/balanced_tree.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/balanced_tree.ML Thu Oct 01 07:40:25 2009 +0200
@@ -12,7 +12,7 @@
val accesses: {left: 'a -> 'a, right: 'a -> 'a, init: 'a} -> int -> 'a list
end;
-structure BalancedTree: BALANCED_TREE =
+structure Balanced_Tree: BALANCED_TREE =
struct
fun make _ [] = raise Empty
--- a/src/Pure/General/binding.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/binding.ML Thu Oct 01 07:40:25 2009 +0200
@@ -30,18 +30,19 @@
val str_of: binding -> string
end;
-structure Binding:> BINDING =
+structure Binding: BINDING =
struct
(** representation **)
(* datatype *)
-datatype binding = Binding of
+abstype binding = Binding of
{prefix: (string * bool) list, (*system prefix*)
qualifier: (string * bool) list, (*user qualifier*)
name: bstring, (*base name*)
- pos: Position.T}; (*source position*)
+ pos: Position.T} (*source position*)
+with
fun make_binding (prefix, qualifier, name, pos) =
Binding {prefix = prefix, qualifier = qualifier, name = name, pos = pos};
@@ -109,6 +110,7 @@
in Markup.markup (Markup.properties props (Markup.binding (name_of binding))) text end;
end;
+end;
type binding = Binding.binding;
--- a/src/Pure/General/event_bus.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/event_bus.scala Thu Oct 01 07:40:25 2009 +0200
@@ -1,38 +1,35 @@
/* Title: Pure/General/event_bus.scala
Author: Makarius
-Generic event bus with multiple handlers and optional exception
-logging.
+Generic event bus with multiple receiving actors.
*/
package isabelle
+import scala.actors.Actor, Actor._
import scala.collection.mutable.ListBuffer
-class EventBus[Event]
+class Event_Bus[Event]
{
- /* event handlers */
+ /* receivers */
+
+ private val receivers = new ListBuffer[Actor]
+
+ def += (r: Actor) { synchronized { receivers += r } }
+ def + (r: Actor): Event_Bus[Event] = { this += r; this }
- type Handler = Event => Unit
- private val handlers = new ListBuffer[Handler]
+ def += (f: Event => Unit) {
+ this += actor { loop { react { case x: Event => f(x) } } }
+ }
- def += (h: Handler) = synchronized { handlers += h }
- def + (h: Handler) = { this += h; this }
+ def + (f: Event => Unit): Event_Bus[Event] = { this += f; this }
- def -= (h: Handler) = synchronized { handlers -= h }
- def - (h: Handler) = { this -= h; this }
+ def -= (r: Actor) { synchronized { receivers -= r } }
+ def - (r: Actor) = { this -= r; this }
/* event invocation */
- var logger: Throwable => Unit = throw _
-
- def event(x: Event) = {
- val log = logger
- for (h <- synchronized { handlers.toList }) {
- try { h(x) }
- catch { case e: Throwable => log(e) }
- }
- }
+ def event(x: Event) { synchronized { receivers.foreach(_ ! x) } }
}
--- a/src/Pure/General/file.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/file.ML Thu Oct 01 07:40:25 2009 +0200
@@ -85,7 +85,8 @@
(* file identification *)
local
- val ident_cache = ref (Symtab.empty: {time_stamp: string, id: string} Symtab.table);
+ val ident_cache =
+ Unsynchronized.ref (Symtab.empty: {time_stamp: string, id: string} Symtab.table);
in
fun check_cache (path, time) = CRITICAL (fn () =>
@@ -94,7 +95,8 @@
| SOME {time_stamp, id} => if time_stamp = time then SOME id else NONE));
fun update_cache (path, (time, id)) = CRITICAL (fn () =>
- change ident_cache (Symtab.update (path, {time_stamp = time, id = id})));
+ Unsynchronized.change ident_cache
+ (Symtab.update (path, {time_stamp = time, id = id})));
end;
--- a/src/Pure/General/graph.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/graph.ML Thu Oct 01 07:40:25 2009 +0200
@@ -132,21 +132,23 @@
let
fun reach x (rs, R) =
if member_keys R x then (rs, R)
- else apfst (cons x) (fold reach (next x) (rs, insert_keys x R))
- in fold_map (fn x => fn X => reach x ([], X)) xs empty_keys end;
+ else fold reach (next x) (rs, insert_keys x R) |>> cons x;
+ fun reachs x (rss, R) =
+ reach x ([], R) |>> (fn rs => rs :: rss);
+ in fold reachs xs ([], empty_keys) end;
(*immediate*)
fun imm_preds G = #1 o #2 o get_entry G;
fun imm_succs G = #2 o #2 o get_entry G;
(*transitive*)
-fun all_preds G = flat o fst o reachable (imm_preds G);
-fun all_succs G = flat o fst o reachable (imm_succs G);
+fun all_preds G = flat o #1 o reachable (imm_preds G);
+fun all_succs G = flat o #1 o reachable (imm_succs G);
(*strongly connected components; see: David King and John Launchbury,
"Structuring Depth First Search Algorithms in Haskell"*)
-fun strong_conn G = filter_out null (fst (reachable (imm_preds G)
- (flat (rev (fst (reachable (imm_succs G) (keys G)))))));
+fun strong_conn G =
+ rev (filter_out null (#1 (reachable (imm_preds G) (all_succs G (keys G)))));
(* nodes *)
--- a/src/Pure/General/lazy.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/lazy.ML Thu Oct 01 07:40:25 2009 +0200
@@ -26,12 +26,12 @@
Lazy of unit -> 'a |
Result of 'a Exn.result;
-type 'a lazy = 'a T ref;
+type 'a lazy = 'a T Unsynchronized.ref;
fun same (r1: 'a lazy, r2) = r1 = r2;
-fun lazy e = ref (Lazy e);
-fun value x = ref (Result (Exn.Result x));
+fun lazy e = Unsynchronized.ref (Lazy e);
+fun value x = Unsynchronized.ref (Result (Exn.Result x));
fun peek r =
(case ! r of
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/General/linear_set.scala Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,144 @@
+/* Title: Pure/General/linear_set.scala
+ Author: Makarius
+ Author: Fabian Immler, TU Munich
+
+Sets with canonical linear order, or immutable linked-lists.
+*/
+
+package isabelle
+
+
+object Linear_Set
+{
+ private case class Rep[A](
+ val first: Option[A], val last: Option[A], val nexts: Map[A, A], prevs: Map[A, A])
+
+ private def empty_rep[A] = Rep[A](None, None, Map(), Map())
+
+ private def make[A](first: Option[A], last: Option[A], nexts: Map[A, A], prevs: Map[A, A])
+ : Linear_Set[A] = new Linear_Set[A] { override val rep = Rep(first, last, nexts, prevs) }
+
+ def empty[A]: Linear_Set[A] = new Linear_Set
+ def apply[A](elems: A*): Linear_Set[A] = empty[A] ++ elems
+
+ class Duplicate(s: String) extends Exception(s)
+ class Undefined(s: String) extends Exception(s)
+}
+
+
+class Linear_Set[A] extends scala.collection.immutable.Set[A]
+{
+ /* representation */
+
+ protected val rep = Linear_Set.empty_rep[A]
+
+
+ /* auxiliary operations */
+
+ def next(elem: A): Option[A] = rep.nexts.get(elem)
+ def prev(elem: A): Option[A] = rep.prevs.get(elem)
+
+ def insert_after(hook: Option[A], elem: A): Linear_Set[A] =
+ if (contains(elem)) throw new Linear_Set.Duplicate(elem.toString)
+ else
+ hook match {
+ case None =>
+ rep.first match {
+ case None => Linear_Set.make(Some(elem), Some(elem), Map(), Map())
+ case Some(elem1) =>
+ Linear_Set.make(Some(elem), rep.last,
+ rep.nexts + (elem -> elem1), rep.prevs + (elem1 -> elem))
+ }
+ case Some(elem1) =>
+ if (!contains(elem1)) throw new Linear_Set.Undefined(elem1.toString)
+ else
+ rep.nexts.get(elem1) match {
+ case None =>
+ Linear_Set.make(rep.first, Some(elem),
+ rep.nexts + (elem1 -> elem), rep.prevs + (elem -> elem1))
+ case Some(elem2) =>
+ Linear_Set.make(rep.first, rep.last,
+ rep.nexts + (elem1 -> elem) + (elem -> elem2),
+ rep.prevs + (elem2 -> elem) + (elem -> elem1))
+ }
+ }
+
+ def delete_after(hook: Option[A]): Linear_Set[A] =
+ hook match {
+ case None =>
+ rep.first match {
+ case None => throw new Linear_Set.Undefined("")
+ case Some(elem1) =>
+ rep.nexts.get(elem1) match {
+ case None => empty
+ case Some(elem2) =>
+ Linear_Set.make(Some(elem2), rep.last, rep.nexts - elem1, rep.prevs - elem2)
+ }
+ }
+ case Some(elem1) =>
+ if (!contains(elem1)) throw new Linear_Set.Undefined(elem1.toString)
+ else
+ rep.nexts.get(elem1) match {
+ case None => throw new Linear_Set.Undefined("")
+ case Some(elem2) =>
+ rep.nexts.get(elem2) match {
+ case None =>
+ Linear_Set.make(rep.first, Some(elem1), rep.nexts - elem1, rep.prevs - elem2)
+ case Some(elem3) =>
+ Linear_Set.make(rep.first, rep.last,
+ rep.nexts - elem2 + (elem1 -> elem3),
+ rep.prevs - elem2 + (elem3 -> elem1))
+ }
+ }
+ }
+
+ def append_after(hook: Option[A], elems: Seq[A]): Linear_Set[A] =
+ (elems :\ this)((elem, set) => set.insert_after(hook, elem))
+
+ def delete_between(from: Option[A], to: Option[A]): Linear_Set[A] =
+ {
+ if (isEmpty) this
+ else {
+ val next =
+ if (from == rep.last) None
+ else if (from == None) rep.first
+ else from.map(rep.nexts(_))
+ if (next == to) this
+ else delete_after(from).delete_between(from, to)
+ }
+ }
+
+
+ /* Set methods */
+
+ override def stringPrefix = "Linear_Set"
+
+ def empty[B]: Linear_Set[B] = Linear_Set.empty
+
+ override def isEmpty: Boolean = !rep.first.isDefined
+ def size: Int = if (isEmpty) 0 else rep.nexts.size + 1
+
+ def elements = new Iterator[A] {
+ private var next_elem = rep.first
+ def hasNext = next_elem.isDefined
+ def next = {
+ val elem = next_elem.get
+ next_elem = rep.nexts.get(elem)
+ elem
+ }
+ }
+
+ def contains(elem: A): Boolean =
+ !isEmpty && (rep.last.get == elem || rep.nexts.isDefinedAt(elem))
+
+ def + (elem: A): Linear_Set[A] = insert_after(rep.last, elem)
+
+ override def + (elem1: A, elem2: A, elems: A*): Linear_Set[A] =
+ this + elem1 + elem2 ++ elems
+ override def ++ (elems: Iterable[A]): Linear_Set[A] = (this /: elems) ((s, elem) => s + elem)
+ override def ++ (elems: Iterator[A]): Linear_Set[A] = (this /: elems) ((s, elem) => s + elem)
+
+ def - (elem: A): Linear_Set[A] =
+ if (!contains(elem)) throw new Linear_Set.Undefined(elem.toString)
+ else delete_after(prev(elem))
+}
\ No newline at end of file
--- a/src/Pure/General/markup.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/markup.ML Thu Oct 01 07:40:25 2009 +0200
@@ -323,10 +323,10 @@
local
val default = {output = default_output};
- val modes = ref (Symtab.make [("", default)]);
+ val modes = Unsynchronized.ref (Symtab.make [("", default)]);
in
fun add_mode name output = CRITICAL (fn () =>
- change modes (Symtab.update_new (name, {output = output})));
+ Unsynchronized.change modes (Symtab.update_new (name, {output = output})));
fun get_mode () =
the_default default (Library.get_first (Symtab.lookup (! modes)) (print_mode_value ()));
end;
--- a/src/Pure/General/markup.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/markup.scala Thu Oct 01 07:40:25 2009 +0200
@@ -6,8 +6,9 @@
package isabelle
-object Markup {
+object Markup
+{
/* name */
val NAME = "name"
@@ -25,7 +26,8 @@
val FILE = "file"
val ID = "id"
- val POSITION_PROPERTIES = Set(LINE, COLUMN, OFFSET, END_LINE, END_COLUMN, END_OFFSET, FILE, ID)
+ val POSITION_PROPERTIES =
+ Set(LINE, COLUMN, OFFSET, END_LINE, END_COLUMN, END_OFFSET, FILE, ID)
val POSITION = "position"
val LOCATION = "location"
--- a/src/Pure/General/name_space.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/name_space.ML Thu Oct 01 07:40:25 2009 +0200
@@ -9,9 +9,9 @@
signature BASIC_NAME_SPACE =
sig
- val long_names: bool ref
- val short_names: bool ref
- val unique_names: bool ref
+ val long_names: bool Unsynchronized.ref
+ val short_names: bool Unsynchronized.ref
+ val unique_names: bool Unsynchronized.ref
end;
signature NAME_SPACE =
@@ -105,9 +105,9 @@
else ext (get_accesses space name)
end;
-val long_names = ref false;
-val short_names = ref false;
-val unique_names = ref true;
+val long_names = Unsynchronized.ref false;
+val short_names = Unsynchronized.ref false;
+val unique_names = Unsynchronized.ref true;
fun extern space name =
extern_flags
@@ -261,6 +261,6 @@
end;
-structure BasicNameSpace: BASIC_NAME_SPACE = NameSpace;
-open BasicNameSpace;
+structure Basic_Name_Space: BASIC_NAME_SPACE = NameSpace;
+open Basic_Name_Space;
--- a/src/Pure/General/output.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/output.ML Thu Oct 01 07:40:25 2009 +0200
@@ -11,13 +11,13 @@
val priority: string -> unit
val tracing: string -> unit
val warning: string -> unit
- val tolerate_legacy_features: bool ref
+ val tolerate_legacy_features: bool Unsynchronized.ref
val legacy_feature: string -> unit
val cond_timeit: bool -> string -> (unit -> 'a) -> 'a
val timeit: (unit -> 'a) -> 'a
val timeap: ('a -> 'b) -> 'a -> 'b
val timeap_msg: string -> ('a -> 'b) -> 'a -> 'b
- val timing: bool ref
+ val timing: bool Unsynchronized.ref
end;
signature OUTPUT =
@@ -32,18 +32,18 @@
val std_output: output -> unit
val std_error: output -> unit
val writeln_default: output -> unit
- val writeln_fn: (output -> unit) ref
- val priority_fn: (output -> unit) ref
- val tracing_fn: (output -> unit) ref
- val warning_fn: (output -> unit) ref
- val error_fn: (output -> unit) ref
- val debug_fn: (output -> unit) ref
- val prompt_fn: (output -> unit) ref
- val status_fn: (output -> unit) ref
+ val writeln_fn: (output -> unit) Unsynchronized.ref
+ val priority_fn: (output -> unit) Unsynchronized.ref
+ val tracing_fn: (output -> unit) Unsynchronized.ref
+ val warning_fn: (output -> unit) Unsynchronized.ref
+ val error_fn: (output -> unit) Unsynchronized.ref
+ val debug_fn: (output -> unit) Unsynchronized.ref
+ val prompt_fn: (output -> unit) Unsynchronized.ref
+ val status_fn: (output -> unit) Unsynchronized.ref
val error_msg: string -> unit
val prompt: string -> unit
val status: string -> unit
- val debugging: bool ref
+ val debugging: bool Unsynchronized.ref
val no_warnings: ('a -> 'b) -> 'a -> 'b
val debug: (unit -> string) -> unit
end;
@@ -60,10 +60,10 @@
local
val default = {output = default_output, escape = default_escape};
- val modes = ref (Symtab.make [("", default)]);
+ val modes = Unsynchronized.ref (Symtab.make [("", default)]);
in
fun add_mode name output escape = CRITICAL (fn () =>
- change modes (Symtab.update_new (name, {output = output, escape = escape})));
+ Unsynchronized.change modes (Symtab.update_new (name, {output = output, escape = escape})));
fun get_mode () =
the_default default (Library.get_first (Symtab.lookup (! modes)) (print_mode_value ()));
end;
@@ -91,14 +91,14 @@
(* Isabelle output channels *)
-val writeln_fn = ref writeln_default;
-val priority_fn = ref (fn s => ! writeln_fn s);
-val tracing_fn = ref (fn s => ! writeln_fn s);
-val warning_fn = ref (std_output o suffix "\n" o prefix_lines "### ");
-val error_fn = ref (std_output o suffix "\n" o prefix_lines "*** ");
-val debug_fn = ref (std_output o suffix "\n" o prefix_lines "::: ");
-val prompt_fn = ref std_output;
-val status_fn = ref (fn _: string => ());
+val writeln_fn = Unsynchronized.ref writeln_default;
+val priority_fn = Unsynchronized.ref (fn s => ! writeln_fn s);
+val tracing_fn = Unsynchronized.ref (fn s => ! writeln_fn s);
+val warning_fn = Unsynchronized.ref (std_output o suffix "\n" o prefix_lines "### ");
+val error_fn = Unsynchronized.ref (std_output o suffix "\n" o prefix_lines "*** ");
+val debug_fn = Unsynchronized.ref (std_output o suffix "\n" o prefix_lines "::: ");
+val prompt_fn = Unsynchronized.ref std_output;
+val status_fn = Unsynchronized.ref (fn _: string => ());
fun writeln s = ! writeln_fn (output s);
fun priority s = ! priority_fn (output s);
@@ -108,13 +108,13 @@
fun prompt s = ! prompt_fn (output s);
fun status s = ! status_fn (output s);
-val tolerate_legacy_features = ref true;
+val tolerate_legacy_features = Unsynchronized.ref true;
fun legacy_feature s =
(if ! tolerate_legacy_features then warning else error) ("Legacy feature! " ^ s);
fun no_warnings f = setmp warning_fn (K ()) f;
-val debugging = ref false;
+val debugging = Unsynchronized.ref false;
fun debug s = if ! debugging then ! debug_fn (output (s ())) else ()
@@ -140,9 +140,9 @@
fun timeap_msg msg f x = cond_timeit true msg (fn () => f x);
(*global timing mode*)
-val timing = ref false;
+val timing = Unsynchronized.ref false;
end;
-structure BasicOutput: BASIC_OUTPUT = Output;
-open BasicOutput;
+structure Basic_Output: BASIC_OUTPUT = Output;
+open Basic_Output;
--- a/src/Pure/General/position.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/position.ML Thu Oct 01 07:40:25 2009 +0200
@@ -21,6 +21,7 @@
val line: int -> T
val line_file: int -> string -> T
val id: string -> T
+ val id_only: string -> T
val get_id: T -> string option
val put_id: string -> T -> T
val of_properties: Properties.T -> T
@@ -97,8 +98,8 @@
fun line_file i name = Pos ((i, 0, 0), file_name name);
fun line i = line_file i "";
-
fun id id = Pos ((0, 0, 1), [(Markup.idN, id)]);
+fun id_only id = Pos ((0, 0, 0), [(Markup.idN, id)]);
fun get_id (Pos (_, props)) = Properties.get props Markup.idN;
fun put_id id (Pos (count, props)) = Pos (count, Properties.put (Markup.idN, id) props);
--- a/src/Pure/General/position.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/position.scala Thu Oct 01 07:40:25 2009 +0200
@@ -6,11 +6,9 @@
package isabelle
-import java.util.Properties
-
-object Position {
-
+object Position
+{
type T = List[(String, String)]
private def get_string(name: String, pos: T): Option[String] =
@@ -41,5 +39,4 @@
val end = end_offset_of(pos)
(begin, if (end.isDefined) end else begin.map(_ + 1))
}
-
}
--- a/src/Pure/General/pretty.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/pretty.ML Thu Oct 01 07:40:25 2009 +0200
@@ -86,10 +86,10 @@
local
val default = {indent = default_indent};
- val modes = ref (Symtab.make [("", default)]);
+ val modes = Unsynchronized.ref (Symtab.make [("", default)]);
in
fun add_mode name indent = CRITICAL (fn () =>
- change modes (Symtab.update_new (name, {indent = indent})));
+ Unsynchronized.change modes (Symtab.update_new (name, {indent = indent})));
fun get_mode () =
the_default default (Library.get_first (Symtab.lookup (! modes)) (print_mode_value ()));
end;
@@ -186,14 +186,14 @@
breakgain = m div 20, (*minimum added space required of a break*)
emergencypos = m div 2}; (*position too far to right*)
-val margin_info = ref (make_margin_info 76);
+val margin_info = Unsynchronized.ref (make_margin_info 76);
fun setmargin m = margin_info := make_margin_info m;
fun setmp_margin m f = setmp margin_info (make_margin_info m) f;
(* depth limitation *)
-val depth = ref 0; (*maximum depth; 0 means no limit*)
+val depth = Unsynchronized.ref 0; (*maximum depth; 0 means no limit*)
fun setdepth dp = (depth := dp);
local
--- a/src/Pure/General/print_mode.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/print_mode.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,9 +7,9 @@
signature BASIC_PRINT_MODE =
sig
- val print_mode: string list ref (*global template*)
- val print_mode_value: unit -> string list (*thread-local value*)
- val print_mode_active: string -> bool (*thread-local value*)
+ val print_mode: string list Unsynchronized.ref (*global template*)
+ val print_mode_value: unit -> string list (*thread-local value*)
+ val print_mode_active: string -> bool (*thread-local value*)
end;
signature PRINT_MODE =
@@ -28,7 +28,7 @@
val input = "input";
val internal = "internal";
-val print_mode = ref ([]: string list);
+val print_mode = Unsynchronized.ref ([]: string list);
val tag = Universal.tag () : string list option Universal.tag;
fun print_mode_value () =
--- a/src/Pure/General/scan.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/scan.scala Thu Oct 01 07:40:25 2009 +0200
@@ -11,7 +11,6 @@
object Scan
{
-
/** Lexicon -- position tree **/
object Lexicon
--- a/src/Pure/General/secure.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/secure.ML Thu Oct 01 07:40:25 2009 +0200
@@ -13,6 +13,7 @@
val use_text: use_context -> int * string -> bool -> string -> unit
val use_file: use_context -> bool -> string -> unit
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
@@ -23,7 +24,7 @@
(** secure flag **)
-val secure = ref false;
+val secure = Unsynchronized.ref false;
fun set_secure () = secure := true;
fun is_secure () = ! secure;
@@ -47,8 +48,13 @@
fun toplevel_pp path pp = (secure_mltext (); raw_toplevel_pp ML_Parse.global_context path pp);
-(*commit is dynamically bound!*)
-fun commit () = raw_use_text ML_Parse.global_context (0, "") false "commit();";
+
+(* global evaluation *)
+
+val use_global = raw_use_text ML_Parse.global_context (0, "") false;
+
+fun commit () = use_global "commit();"; (*commit is dynamically bound!*)
+fun open_unsynchronized () = use_global "open Unsynchronized";
(* shell commands *)
--- a/src/Pure/General/swing_thread.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/swing_thread.scala Thu Oct 01 07:40:25 2009 +0200
@@ -13,36 +13,43 @@
object Swing_Thread
{
+ /* checks */
+
+ def assert() = Predef.assert(SwingUtilities.isEventDispatchThread())
+ def require() = Predef.require(SwingUtilities.isEventDispatchThread())
+
+
/* main dispatch queue */
def now[A](body: => A): A = {
var result: Option[A] = None
- if (SwingUtilities.isEventDispatchThread) { result = Some(body) }
+ if (SwingUtilities.isEventDispatchThread()) { result = Some(body) }
else SwingUtilities.invokeAndWait(new Runnable { def run = { result = Some(body) } })
result.get
}
def later(body: => Unit) {
- if (SwingUtilities.isEventDispatchThread) body
+ if (SwingUtilities.isEventDispatchThread()) body
else SwingUtilities.invokeLater(new Runnable { def run = body })
}
/* delayed actions */
- // turn multiple invocations into single action within time span
- def delay(time_span: Int)(action: => Unit): () => Unit =
+ private def delayed_action(first: Boolean)(time_span: Int)(action: => Unit): () => Unit =
{
val listener =
new ActionListener { override def actionPerformed(e: ActionEvent) { action } }
val timer = new Timer(time_span, listener)
- def invoke()
- {
- if (!timer.isRunning()) {
- timer.setRepeats(false)
- timer.start()
- }
- }
+ timer.setRepeats(false)
+
+ def invoke() { if (first) timer.start() else timer.restart() }
invoke _
}
+
+ // delayed action after first invocation
+ def delay_first = delayed_action(true) _
+
+ // delayed action after last invocation
+ def delay_last = delayed_action(false) _
}
--- a/src/Pure/General/yxml.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/General/yxml.scala Thu Oct 01 07:40:25 2009 +0200
@@ -7,8 +7,8 @@
package isabelle
-object YXML {
-
+object YXML
+{
/* chunk markers */
private val X = '\5'
@@ -22,7 +22,8 @@
private def chunks(sep: Char, source: CharSequence) = new Iterator[CharSequence] {
private val end = source.length
private var state = if (end == 0) None else get_chunk(-1)
- private def get_chunk(i: Int) = {
+ private def get_chunk(i: Int) =
+ {
if (i < end) {
var j = i; do j += 1 while (j < end && source.charAt(j) != sep)
Some((source.subSequence(i + 1, j), j))
@@ -55,8 +56,8 @@
}
- def parse_body(source: CharSequence) = {
-
+ def parse_body(source: CharSequence): List[XML.Tree] =
+ {
/* stack operations */
var stack: List[((String, XML.Attributes), List[XML.Tree])] = null
@@ -94,7 +95,7 @@
}
}
- def parse(source: CharSequence) =
+ def parse(source: CharSequence): XML.Tree =
parse_body(source) match {
case List(result) => result
case Nil => XML.Text("")
@@ -108,14 +109,15 @@
XML.Elem (Markup.BAD, Nil,
List(XML.Text(source.toString.replace(X_string, "\\<^X>").replace(Y_string, "\\<^Y>"))))
- def parse_body_failsafe(source: CharSequence) = {
+ def parse_body_failsafe(source: CharSequence): List[XML.Tree] =
+ {
try { parse_body(source) }
catch { case _: RuntimeException => List(markup_failsafe(source)) }
}
- def parse_failsafe(source: CharSequence) = {
+ def parse_failsafe(source: CharSequence): XML.Tree =
+ {
try { parse(source) }
catch { case _: RuntimeException => markup_failsafe(source) }
}
-
}
--- a/src/Pure/IsaMakefile Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/IsaMakefile Thu Oct 01 07:40:25 2009 +0200
@@ -32,7 +32,7 @@
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/universal.ML ML-Systems/unsynchronized.ML
RAW: $(OUT)/RAW
@@ -45,32 +45,33 @@
$(OUT)/Pure: $(BOOTSTRAP_FILES) Concurrent/future.ML \
Concurrent/mailbox.ML Concurrent/par_list.ML \
Concurrent/par_list_dummy.ML Concurrent/simple_thread.ML \
- Concurrent/synchronized.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/file.ML \
- General/graph.ML General/heap.ML General/integer.ML General/lazy.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 Isar/constdefs.ML \
- Isar/context_rules.ML Isar/element.ML Isar/expression.ML \
- Isar/isar_cmd.ML Isar/isar_document.ML Isar/isar_syn.ML \
- Isar/local_defs.ML Isar/local_syntax.ML Isar/local_theory.ML \
- Isar/locale.ML Isar/method.ML Isar/object_logic.ML Isar/obtain.ML \
- Isar/outer_keyword.ML Isar/outer_lex.ML Isar/outer_parse.ML \
- Isar/outer_syntax.ML Isar/overloading.ML Isar/proof.ML \
- Isar/proof_context.ML Isar/proof_display.ML Isar/proof_node.ML \
- Isar/rule_cases.ML Isar/rule_insts.ML Isar/runtime.ML \
- Isar/skip_proof.ML Isar/spec_parse.ML Isar/specification.ML \
- Isar/theory_target.ML Isar/toplevel.ML Isar/value_parse.ML \
- ML/ml_antiquote.ML ML/ml_compiler.ML ML/ml_compiler_polyml-5.3.ML \
- ML/ml_context.ML ML/ml_env.ML ML/ml_lex.ML ML/ml_parse.ML \
- ML/ml_syntax.ML ML/ml_thms.ML ML-Systems/install_pp_polyml.ML \
+ Concurrent/synchronized.ML Concurrent/synchronized_dummy.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/file.ML General/graph.ML General/heap.ML \
+ General/integer.ML General/lazy.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 \
+ Isar/constdefs.ML Isar/context_rules.ML Isar/element.ML \
+ Isar/expression.ML Isar/isar_cmd.ML Isar/isar_document.ML \
+ Isar/isar_syn.ML Isar/local_defs.ML Isar/local_syntax.ML \
+ Isar/local_theory.ML Isar/locale.ML Isar/method.ML \
+ Isar/object_logic.ML Isar/obtain.ML Isar/outer_keyword.ML \
+ Isar/outer_lex.ML Isar/outer_parse.ML Isar/outer_syntax.ML \
+ Isar/overloading.ML Isar/proof.ML Isar/proof_context.ML \
+ Isar/proof_display.ML Isar/proof_node.ML Isar/rule_cases.ML \
+ Isar/rule_insts.ML Isar/runtime.ML Isar/skip_proof.ML \
+ Isar/spec_parse.ML Isar/specification.ML Isar/theory_target.ML \
+ Isar/toplevel.ML Isar/value_parse.ML ML/ml_antiquote.ML \
+ ML/ml_compiler.ML ML/ml_compiler_polyml-5.3.ML ML/ml_context.ML \
+ ML/ml_env.ML ML/ml_lex.ML ML/ml_parse.ML ML/ml_syntax.ML \
+ ML/ml_thms.ML ML-Systems/install_pp_polyml.ML \
ML-Systems/install_pp_polyml-5.3.ML ML-Systems/use_context.ML \
Proof/extraction.ML Proof/proof_rewrite_rules.ML \
Proof/proof_syntax.ML Proof/proofchecker.ML Proof/reconstruct.ML \
@@ -117,15 +118,14 @@
## Scala material
-SCALA_FILES = General/event_bus.scala General/markup.scala \
- General/position.scala General/scan.scala General/swing_thread.scala \
- General/symbol.scala General/xml.scala General/yxml.scala \
- Isar/isar.scala Isar/isar_document.scala Isar/outer_keyword.scala \
+SCALA_FILES = General/event_bus.scala General/linear_set.scala \
+ General/markup.scala General/position.scala General/scan.scala \
+ General/swing_thread.scala General/symbol.scala General/xml.scala \
+ General/yxml.scala Isar/isar_document.scala Isar/outer_keyword.scala \
System/cygwin.scala System/gui_setup.scala \
- System/isabelle_process.scala System/isabelle_system.scala \
- System/platform.scala Thy/completion.scala Thy/thy_header.scala \
- Tools/isabelle_syntax.scala
-
+ System/isabelle_process.scala System/isabelle_syntax.scala \
+ System/isabelle_system.scala System/platform.scala \
+ Thy/completion.scala Thy/thy_header.scala
JAR_DIR = $(ISABELLE_HOME)/lib/classes
PURE_JAR = $(JAR_DIR)/Pure.jar
@@ -135,7 +135,7 @@
$(FULL_JAR): $(SCALA_FILES)
@rm -rf classes && mkdir classes
- "$(SCALA_HOME)/bin/scalac" -deprecation -d classes -target jvm-1.5 $(SCALA_FILES)
+ "$(SCALA_HOME)/bin/scalac" -unchecked -deprecation -d classes -target jvm-1.5 $(SCALA_FILES)
"$(SCALA_HOME)/bin/scaladoc" -d classes $(SCALA_FILES)
@cp $(SCALA_FILES) classes/isabelle
@mkdir -p "$(JAR_DIR)"
--- a/src/Pure/Isar/class.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/class.ML Thu Oct 01 07:40:25 2009 +0200
@@ -211,12 +211,8 @@
#>> Element.Fixes
| fork_syn x = pair x;
val (elems, global_syntax) = fold_map fork_syn syntax_elems [];
- val constrain = Element.Constrains ((map o apsnd o map_atyps)
- (K (TFree (Name.aT, base_sort))) raw_supparams);
- (*FIXME perhaps better: control type variable by explicit
- parameter instantiation of import expression*)
- in (((sups, supparam_names), (sup_sort, base_sort, supexpr)), ((*constrain :: *)elems, global_syntax)) end;
+ in (((sups, supparam_names), (sup_sort, base_sort, supexpr)), (elems, global_syntax)) end;
val cert_class_spec = prep_class_spec (K I) cert_class_elems;
val read_class_spec = prep_class_spec Sign.intern_class read_class_elems;
--- a/src/Pure/Isar/class_target.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/class_target.ML Thu Oct 01 07:40:25 2009 +0200
@@ -513,6 +513,7 @@
| NONE => NONE;
in
thy
+ |> Theory.checkpoint
|> ProofContext.init
|> Instantiation.put (mk_instantiation ((tycos, vs, sort), params))
|> fold (Variable.declare_typ o TFree) vs
--- a/src/Pure/Isar/code.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/code.ML Thu Oct 01 07:40:25 2009 +0200
@@ -19,11 +19,6 @@
val constrset_of_consts: theory -> (string * typ) list
-> string * ((string * sort) list * (string * typ list) list)
- (*constant aliasses*)
- val add_const_alias: thm -> theory -> theory
- val triv_classes: theory -> class list
- val resubst_alias: theory -> string -> string
-
(*code equations*)
val mk_eqn: theory -> thm * bool -> thm * bool
val mk_eqn_warning: theory -> thm -> (thm * bool) option
@@ -169,7 +164,6 @@
datatype spec = Spec of {
history_concluded: bool,
- aliasses: ((string * string) * thm) list * class list,
eqns: ((bool * eqns) * (serial * eqns) list) Symtab.table
(*with explicit history*),
dtyps: ((serial * ((string * sort) list * (string * typ list) list)) list) Symtab.table
@@ -177,19 +171,16 @@
cases: (int * (int * string list)) Symtab.table * unit Symtab.table
};
-fun make_spec ((history_concluded, aliasses), (eqns, (dtyps, cases))) =
- Spec { history_concluded = history_concluded, aliasses = aliasses,
- eqns = eqns, dtyps = dtyps, cases = cases };
-fun map_spec f (Spec { history_concluded = history_concluded, aliasses = aliasses, eqns = eqns,
+fun make_spec (history_concluded, (eqns, (dtyps, cases))) =
+ Spec { history_concluded = history_concluded, eqns = eqns, dtyps = dtyps, cases = cases };
+fun map_spec f (Spec { history_concluded = history_concluded, eqns = eqns,
dtyps = dtyps, cases = cases }) =
- make_spec (f ((history_concluded, aliasses), (eqns, (dtyps, cases))));
-fun merge_spec (Spec { history_concluded = _, aliasses = aliasses1, eqns = eqns1,
+ make_spec (f (history_concluded, (eqns, (dtyps, cases))));
+fun merge_spec (Spec { history_concluded = _, eqns = eqns1,
dtyps = dtyps1, cases = (cases1, undefs1) },
- Spec { history_concluded = _, aliasses = aliasses2, eqns = eqns2,
+ Spec { history_concluded = _, eqns = eqns2,
dtyps = dtyps2, cases = (cases2, undefs2) }) =
let
- val aliasses = (Library.merge (eq_snd Thm.eq_thm_prop) (pairself fst (aliasses1, aliasses2)),
- Library.merge (op =) (pairself snd (aliasses1, aliasses2)));
fun merge_eqns ((_, history1), (_, history2)) =
let
val raw_history = AList.merge (op = : serial * serial -> bool)
@@ -202,15 +193,13 @@
val dtyps = Symtab.join (K (AList.merge (op =) (K true))) (dtyps1, dtyps2);
val cases = (Symtab.merge (K true) (cases1, cases2),
Symtab.merge (K true) (undefs1, undefs2));
- in make_spec ((false, aliasses), (eqns, (dtyps, cases))) end;
+ in make_spec (false, (eqns, (dtyps, cases))) end;
fun history_concluded (Spec { history_concluded, ... }) = history_concluded;
-fun the_aliasses (Spec { aliasses, ... }) = aliasses;
fun the_eqns (Spec { eqns, ... }) = eqns;
fun the_dtyps (Spec { dtyps, ... }) = dtyps;
fun the_cases (Spec { cases, ... }) = cases;
-val map_history_concluded = map_spec o apfst o apfst;
-val map_aliasses = map_spec o apfst o apsnd;
+val map_history_concluded = map_spec o apfst;
val map_eqns = map_spec o apsnd o apfst;
val map_dtyps = map_spec o apsnd o apsnd o apfst;
val map_cases = map_spec o apsnd o apsnd o apsnd;
@@ -228,8 +217,8 @@
purge: theory -> string list -> Object.T -> Object.T
};
-val kinds = ref (Datatab.empty: kind Datatab.table);
-val kind_keys = ref ([]: serial list);
+val kinds = Unsynchronized.ref (Datatab.empty: kind Datatab.table);
+val kind_keys = Unsynchronized.ref ([]: serial list);
fun invoke f k = case Datatab.lookup (! kinds) k
of SOME kind => f kind
@@ -241,8 +230,8 @@
let
val k = serial ();
val kind = {empty = empty, purge = purge};
- val _ = change kinds (Datatab.update (k, kind));
- val _ = change kind_keys (cons k);
+ val _ = Unsynchronized.change kinds (Datatab.update (k, kind));
+ val _ = Unsynchronized.change kind_keys (cons k);
in k end;
fun invoke_init k = invoke (fn kind => #empty kind) k;
@@ -263,13 +252,13 @@
structure Code_Data = TheoryDataFun
(
- type T = spec * data ref;
- val empty = (make_spec ((false, ([], [])),
- (Symtab.empty, (Symtab.empty, (Symtab.empty, Symtab.empty)))), ref empty_data);
- fun copy (spec, data) = (spec, ref (! data));
+ type T = spec * data Unsynchronized.ref;
+ val empty = (make_spec (false,
+ (Symtab.empty, (Symtab.empty, (Symtab.empty, Symtab.empty)))), Unsynchronized.ref empty_data);
+ fun copy (spec, data) = (spec, Unsynchronized.ref (! data));
val extend = copy;
fun merge pp ((spec1, data1), (spec2, data2)) =
- (merge_spec (spec1, spec2), ref empty_data);
+ (merge_spec (spec1, spec2), Unsynchronized.ref empty_data);
);
fun thy_data f thy = f ((snd o Code_Data.get) thy);
@@ -278,7 +267,7 @@
case Datatab.lookup (! data_ref) kind
of SOME x => x
| NONE => let val y = invoke_init kind
- in (change data_ref (Datatab.update (kind, y)); y) end;
+ in (Unsynchronized.change data_ref (Datatab.update (kind, y)); y) end;
in
@@ -292,11 +281,11 @@
| SOME (c', _) => insert (op =) c' #> insert (op =) c) cs [];
fun map_exec_purge touched f thy =
- Code_Data.map (fn (exec, data) => (f exec, ref (case touched
+ Code_Data.map (fn (exec, data) => (f exec, Unsynchronized.ref (case touched
of SOME cs => invoke_purge_all thy (complete_class_params thy cs) (! data)
| NONE => empty_data))) thy;
-val purge_data = (Code_Data.map o apsnd) (K (ref empty_data));
+val purge_data = (Code_Data.map o apsnd) (K (Unsynchronized.ref empty_data));
fun change_eqns delete c f = (map_exec_purge (SOME [c]) o map_eqns
o (if delete then Symtab.map_entry c else Symtab.map_default (c, ((false, (true, Lazy.value [])), [])))
@@ -343,7 +332,7 @@
let
val data = get_ensure_init kind data_ref;
val data' = f (dest data);
- in (change data_ref (Datatab.update (kind, mk data')); data') end;
+ in (Unsynchronized.change data_ref (Datatab.update (kind, mk data')); data') end;
in thy_data chnge end;
fun change_yield_data (kind, mk, dest) =
@@ -352,30 +341,12 @@
let
val data = get_ensure_init kind data_ref;
val (x, data') = f (dest data);
- in (x, (change data_ref (Datatab.update (kind, mk data')); data')) end;
+ in (x, (Unsynchronized.change data_ref (Datatab.update (kind, mk data')); data')) end;
in thy_data chnge end;
end; (*local*)
-(** retrieval interfaces **)
-
-(* constant aliasses *)
-
-fun resubst_alias thy =
- let
- val alias = (fst o the_aliasses o the_exec) thy;
- val subst_inst_param = Option.map fst o AxClass.inst_of_param thy;
- fun subst_alias c =
- get_first (fn ((c', c''), _) => if c = c'' then SOME c' else NONE) alias;
- in
- perhaps subst_inst_param
- #> perhaps subst_alias
- end;
-
-val triv_classes = snd o the_aliasses o the_exec;
-
-
(** foundation **)
(* constants *)
@@ -534,9 +505,10 @@
(*those following are permissive wrt. to overloaded constants!*)
+val head_eqn = dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
fun const_typ_eqn thy thm =
let
- val (c, ty) = (dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
+ val (c, ty) = head_eqn thm;
val c' = AxClass.unoverload_const thy (c, ty);
in (c', ty) end;
@@ -552,8 +524,8 @@
fun same_typscheme thy thms =
let
- fun tvars_of t = rev (Term.add_tvars t []);
- val vss = map (tvars_of o Thm.prop_of) thms;
+ fun tvars_of T = rev (Term.add_tvarsT T []);
+ val vss = map (tvars_of o snd o head_eqn) thms;
fun inter_sorts vs =
fold (curry (Sorts.inter_sort (Sign.classes_of thy)) o snd) vs [];
val sorts = map_transpose inter_sorts vss;
@@ -576,7 +548,7 @@
fun case_certificate thm =
let
val ((head, raw_case_expr), cases) = (apfst Logic.dest_equals
- o apsnd Logic.dest_conjunctions o Logic.dest_implies o Thm.prop_of) thm;
+ o apsnd Logic.dest_conjunctions o Logic.dest_implies o Thm.plain_prop_of) thm;
val _ = case head of Free _ => true
| Var _ => true
| _ => raise TERM ("case_cert", []);
@@ -669,38 +641,6 @@
(** declaring executable ingredients **)
-(* constant aliasses *)
-
-fun add_const_alias thm thy =
- let
- val (ofclass, eqn) = case try Logic.dest_equals (Thm.prop_of thm)
- of SOME ofclass_eq => ofclass_eq
- | _ => error ("Bad certificate: " ^ Display.string_of_thm_global thy thm);
- val (T, class) = case try Logic.dest_of_class ofclass
- of SOME T_class => T_class
- | _ => error ("Bad certificate: " ^ Display.string_of_thm_global thy thm);
- val tvar = case try Term.dest_TVar T
- of SOME (tvar as (_, sort)) => if null (filter (can (AxClass.get_info thy)) sort)
- then tvar
- else error ("Bad sort: " ^ Display.string_of_thm_global thy thm)
- | _ => error ("Bad type: " ^ Display.string_of_thm_global thy thm);
- val _ = if Term.add_tvars eqn [] = [tvar] then ()
- else error ("Inconsistent type: " ^ Display.string_of_thm_global thy thm);
- val lhs_rhs = case try Logic.dest_equals eqn
- of SOME lhs_rhs => lhs_rhs
- | _ => error ("Not an equation: " ^ Syntax.string_of_term_global thy eqn);
- val c_c' = case try (pairself (check_const thy)) lhs_rhs
- of SOME c_c' => c_c'
- | _ => error ("Not an equation with two constants: "
- ^ Syntax.string_of_term_global thy eqn);
- val _ = if the_list (AxClass.class_of_param thy (snd c_c')) = [class] then ()
- else error ("Inconsistent class: " ^ Display.string_of_thm_global thy thm);
- in thy |>
- (map_exec_purge NONE o map_aliasses) (fn (alias, classes) =>
- ((c_c', thm) :: alias, insert (op =) class classes))
- end;
-
-
(* datatypes *)
structure Type_Interpretation = InterpretationFun(type T = string * serial val eq = eq_snd (op =) : T * T -> bool);
@@ -820,7 +760,7 @@
end; (*struct*)
-(** type-safe interfaces for data depedent on executable code **)
+(** type-safe interfaces for data dependent on executable code **)
functor Code_Data_Fun(Data: CODE_DATA_ARGS): CODE_DATA =
struct
@@ -840,4 +780,49 @@
end;
+(** datastructure to log definitions for preprocessing of the predicate compiler **)
+(* obviously a clone of Named_Thms *)
+
+signature PREDICATE_COMPILE_PREPROC_CONST_DEFS =
+sig
+ val get: Proof.context -> thm list
+ val add_thm: thm -> Context.generic -> Context.generic
+ val del_thm: thm -> Context.generic -> Context.generic
+
+ val add_attribute : attribute
+ val del_attribute : attribute
+
+ val add_attrib : Attrib.src
+
+ val setup: theory -> theory
+end;
+
+structure Predicate_Compile_Preproc_Const_Defs : PREDICATE_COMPILE_PREPROC_CONST_DEFS =
+struct
+
+structure Data = GenericDataFun
+(
+ type T = thm list;
+ val empty = [];
+ val extend = I;
+ fun merge _ = Thm.merge_thms;
+);
+
+val get = Data.get o Context.Proof;
+
+val add_thm = Data.map o Thm.add_thm;
+val del_thm = Data.map o Thm.del_thm;
+
+val add_attribute = Thm.declaration_attribute add_thm;
+val del_attribute = Thm.declaration_attribute del_thm;
+
+val add_attrib = Attrib.internal (K add_attribute)
+
+val setup =
+ Attrib.setup (Binding.name "pred_compile_preproc") (Attrib.add_del add_attribute del_attribute)
+ ("declaration of definition for preprocessing of the predicate compiler") #>
+ PureThy.add_thms_dynamic (Binding.name "pred_compile_preproc", Data.get);
+
+end;
+
structure Code : CODE = struct open Code; end;
--- a/src/Pure/Isar/constdefs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/constdefs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -52,7 +52,7 @@
thy
|> Sign.add_consts_i [(b, T, mx)]
|> PureThy.add_defs false [((name, def), atts)]
- |-> (fn [thm] => Code.add_default_eqn thm);
+ |-> (fn [thm] => Code.add_default_eqn thm #> Context.theory_map (Predicate_Compile_Preproc_Const_Defs.add_thm thm));
in ((c, T), thy') end;
fun gen_constdefs prep_vars prep_prop prep_att (raw_structs, specs) thy =
--- a/src/Pure/Isar/expression.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/expression.ML Thu Oct 01 07:40:25 2009 +0200
@@ -840,7 +840,7 @@
fun gen_sublocale prep_expr intern raw_target expression thy =
let
val target = intern thy raw_target;
- val target_ctxt = Locale.init target thy;
+ val target_ctxt = TheoryTarget.init (SOME target) thy;
val ((propss, deps, export), goal_ctxt) = prep_expr expression target_ctxt;
fun after_qed witss = ProofContext.theory
(fold (fn ((dep, morph), wits) => Locale.add_dependency
--- a/src/Pure/Isar/isar.scala Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,26 +0,0 @@
-/* Title: Pure/Isar/isar.scala
- Author: Makarius
-
-Isar document model.
-*/
-
-package isabelle
-
-
-class Isar(isabelle_system: Isabelle_System,
- results: EventBus[Isabelle_Process.Result], args: String*)
- extends Isabelle_Process(isabelle_system, results, args: _*)
-{
- /* basic editor commands */
-
- def create_command(id: String, text: String) =
- output_sync("Isar.command " + IsabelleSyntax.encode_string(id) + " " +
- IsabelleSyntax.encode_string(text))
-
- def insert_command(prev: String, id: String) =
- output_sync("Isar.insert " + IsabelleSyntax.encode_string(prev) + " " +
- IsabelleSyntax.encode_string(id))
-
- def remove_command(id: String) =
- output_sync("Isar.remove " + IsabelleSyntax.encode_string(id))
-}
--- a/src/Pure/Isar/isar_document.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/isar_document.ML Thu Oct 01 07:40:25 2009 +0200
@@ -15,7 +15,7 @@
val edit_document: document_id -> document_id -> (command_id * command_id option) list -> unit
end;
-structure IsarDocument: ISAR_DOCUMENT =
+structure Isar_Document: ISAR_DOCUMENT =
struct
(* unique identifiers *)
@@ -112,18 +112,18 @@
(** global configuration **)
local
- val global_states = ref (Symtab.empty: Toplevel.state option future Symtab.table);
- val global_commands = ref (Symtab.empty: Toplevel.transition Symtab.table);
- val global_documents = ref (Symtab.empty: document Symtab.table);
+ val global_states = Unsynchronized.ref (Symtab.empty: Toplevel.state option future Symtab.table);
+ val global_commands = Unsynchronized.ref (Symtab.empty: Toplevel.transition Symtab.table);
+ val global_documents = Unsynchronized.ref (Symtab.empty: document Symtab.table);
in
-fun change_states f = NAMED_CRITICAL "Isar" (fn () => change global_states f);
+fun change_states f = NAMED_CRITICAL "Isar" (fn () => Unsynchronized.change global_states f);
fun get_states () = NAMED_CRITICAL "Isar" (fn () => ! global_states);
-fun change_commands f = NAMED_CRITICAL "Isar" (fn () => change global_commands f);
+fun change_commands f = NAMED_CRITICAL "Isar" (fn () => Unsynchronized.change global_commands f);
fun get_commands () = NAMED_CRITICAL "Isar" (fn () => ! global_commands);
-fun change_documents f = NAMED_CRITICAL "Isar" (fn () => change global_documents f);
+fun change_documents f = NAMED_CRITICAL "Isar" (fn () => Unsynchronized.change global_documents f);
fun get_documents () = NAMED_CRITICAL "Isar" (fn () => ! global_documents);
fun init () = NAMED_CRITICAL "Isar" (fn () =>
@@ -278,6 +278,7 @@
val _ =
OuterSyntax.internal_command "Isar.define_command"
(P.string -- P.string >> (fn (id, text) =>
+ Toplevel.position (Position.id_only id) o
Toplevel.imperative (fn () =>
define_command id (OuterSyntax.prepare_command (Position.id id) text))));
--- a/src/Pure/Isar/isar_document.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/isar_document.scala Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,9 @@
package isabelle
-object IsarDocument {
+
+object Isar_Document
+{
/* unique identifiers */
type State_ID = String
@@ -14,28 +16,29 @@
type Document_ID = String
}
-trait IsarDocument extends Isabelle_Process
+
+trait Isar_Document extends Isabelle_Process
{
- import IsarDocument._
+ import Isar_Document._
/* commands */
def define_command(id: Command_ID, text: String) {
- output_sync("Isar.define_command " + IsabelleSyntax.encode_string(id) + " " +
- IsabelleSyntax.encode_string(text))
+ output_sync("Isar.define_command " + Isabelle_Syntax.encode_string(id) + " " +
+ Isabelle_Syntax.encode_string(text))
}
/* documents */
def begin_document(id: Document_ID, path: String) {
- output_sync("Isar.begin_document " + IsabelleSyntax.encode_string(id) + " " +
- IsabelleSyntax.encode_string(path))
+ output_sync("Isar.begin_document " + Isabelle_Syntax.encode_string(id) + " " +
+ Isabelle_Syntax.encode_string(path))
}
def end_document(id: Document_ID) {
- output_sync("Isar.end_document " + IsabelleSyntax.encode_string(id))
+ output_sync("Isar.end_document " + Isabelle_Syntax.encode_string(id))
}
def edit_document(old_id: Document_ID, new_id: Document_ID,
@@ -44,21 +47,21 @@
def append_edit(edit: (Command_ID, Option[Command_ID]), result: StringBuilder)
{
edit match {
- case (id, None) => IsabelleSyntax.append_string(id, result)
+ case (id, None) => Isabelle_Syntax.append_string(id, result)
case (id, Some(id2)) =>
- IsabelleSyntax.append_string(id, result)
+ Isabelle_Syntax.append_string(id, result)
result.append(" ")
- IsabelleSyntax.append_string(id2, result)
+ Isabelle_Syntax.append_string(id2, result)
}
}
val buf = new StringBuilder(40)
buf.append("Isar.edit_document ")
- IsabelleSyntax.append_string(old_id, buf)
+ Isabelle_Syntax.append_string(old_id, buf)
buf.append(" ")
- IsabelleSyntax.append_string(new_id, buf)
+ Isabelle_Syntax.append_string(new_id, buf)
buf.append(" ")
- IsabelleSyntax.append_list(append_edit, edits, buf)
+ Isabelle_Syntax.append_list(append_edit, edits, buf)
output_sync(buf.toString)
}
}
--- a/src/Pure/Isar/isar_syn.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/isar_syn.ML Thu Oct 01 07:40:25 2009 +0200
@@ -30,7 +30,7 @@
val _ =
OuterSyntax.command "theory" "begin theory" (K.tag_theory K.thy_begin)
- (ThyHeader.args >> (Toplevel.print oo IsarCmd.init_theory));
+ (Thy_Header.args >> (Toplevel.print oo IsarCmd.init_theory));
val _ =
OuterSyntax.command "end" "end (local) theory" (K.tag_theory K.thy_end)
--- a/src/Pure/Isar/local_syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/local_syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -4,7 +4,7 @@
Local syntax depending on theory syntax.
*)
-val show_structs = ref false;
+val show_structs = Unsynchronized.ref false;
signature LOCAL_SYNTAX =
sig
--- a/src/Pure/Isar/method.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/method.ML Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,7 @@
sig
val FINDGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq
val HEADGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq
- val trace_rules: bool ref
+ val trace_rules: bool Unsynchronized.ref
end;
signature METHOD =
@@ -215,7 +215,7 @@
(* rule etc. -- single-step refinements *)
-val trace_rules = ref false;
+val trace_rules = Unsynchronized.ref false;
fun trace ctxt rules =
if ! trace_rules andalso not (null rules) then
--- a/src/Pure/Isar/outer_keyword.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/outer_keyword.ML Thu Oct 01 07:40:25 2009 +0200
@@ -116,16 +116,16 @@
local
-val global_commands = ref (Symtab.empty: T Symtab.table);
-val global_lexicons = ref (Scan.empty_lexicon, Scan.empty_lexicon);
+val global_commands = Unsynchronized.ref (Symtab.empty: T Symtab.table);
+val global_lexicons = Unsynchronized.ref (Scan.empty_lexicon, Scan.empty_lexicon);
in
fun get_commands () = CRITICAL (fn () => ! global_commands);
fun get_lexicons () = CRITICAL (fn () => ! global_lexicons);
-fun change_commands f = CRITICAL (fn () => change global_commands f);
-fun change_lexicons f = CRITICAL (fn () => change global_lexicons f);
+fun change_commands f = CRITICAL (fn () => Unsynchronized.change global_commands f);
+fun change_lexicons f = CRITICAL (fn () => Unsynchronized.change global_lexicons f);
end;
--- a/src/Pure/Isar/outer_keyword.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/outer_keyword.scala Thu Oct 01 07:40:25 2009 +0200
@@ -6,8 +6,9 @@
package isabelle
-object OuterKeyword {
+object OuterKeyword
+{
val MINOR = "minor"
val CONTROL = "control"
val DIAG = "diag"
--- a/src/Pure/Isar/outer_lex.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/outer_lex.ML Thu Oct 01 07:40:25 2009 +0200
@@ -83,7 +83,7 @@
datatype slot =
Slot |
Value of value option |
- Assignable of value option ref;
+ Assignable of value option Unsynchronized.ref;
(* datatype token *)
@@ -245,7 +245,7 @@
(* static binding *)
(*1st stage: make empty slots assignable*)
-fun assignable (Token (x, y, Slot)) = Token (x, y, Assignable (ref NONE))
+fun assignable (Token (x, y, Slot)) = Token (x, y, Assignable (Unsynchronized.ref NONE))
| assignable tok = tok;
(*2nd stage: assign values as side-effect of scanning*)
@@ -253,7 +253,7 @@
| assign _ _ = ();
(*3rd stage: static closure of final values*)
-fun closure (Token (x, y, Assignable (ref v))) = Token (x, y, Value v)
+fun closure (Token (x, y, Assignable (Unsynchronized.ref v))) = Token (x, y, Value v)
| closure tok = tok;
--- a/src/Pure/Isar/outer_syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/outer_syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -88,11 +88,11 @@
local
-val global_commands = ref (Symtab.empty: command Symtab.table);
-val global_markups = ref ([]: (string * ThyOutput.markup) list);
+val global_commands = Unsynchronized.ref (Symtab.empty: command Symtab.table);
+val global_markups = Unsynchronized.ref ([]: (string * ThyOutput.markup) list);
fun change_commands f = CRITICAL (fn () =>
- (change global_commands f;
+ (Unsynchronized.change global_commands f;
global_markups :=
Symtab.fold (fn (name, Command {markup = SOME m, ...}) => cons (name, m) | _ => I)
(! global_commands) []));
--- a/src/Pure/Isar/overloading.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/overloading.ML Thu Oct 01 07:40:25 2009 +0200
@@ -154,6 +154,7 @@
val overloading = map (fn (v, c_ty, checked) => (c_ty, (v, checked))) raw_overloading;
in
thy
+ |> Theory.checkpoint
|> ProofContext.init
|> OverloadingData.put overloading
|> fold (fn ((_, ty), (v, _)) => Variable.declare_names (Free (v, ty))) overloading
--- a/src/Pure/Isar/proof.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/proof.ML Thu Oct 01 07:40:25 2009 +0200
@@ -30,13 +30,14 @@
val enter_forward: state -> state
val goal_message: (unit -> Pretty.T) -> state -> state
val get_goal: state -> context * (thm list * thm)
- val show_main_goal: bool ref
- val verbose: bool ref
+ val show_main_goal: bool Unsynchronized.ref
+ val verbose: bool Unsynchronized.ref
val pretty_state: int -> state -> Pretty.T list
val pretty_goals: bool -> state -> Pretty.T list
val refine: Method.text -> state -> state Seq.seq
val refine_end: Method.text -> state -> state Seq.seq
val refine_insert: thm list -> state -> state
+ val flat_goal: state -> Proof.context * thm
val goal_tac: thm -> int -> tactic
val refine_goals: (context -> thm -> unit) -> context -> thm list -> state -> state Seq.seq
val match_bind: (string list * string) list -> state -> state
@@ -315,7 +316,7 @@
(** pretty_state **)
-val show_main_goal = ref false;
+val show_main_goal = Unsynchronized.ref false;
val verbose = ProofContext.verbose;
fun pretty_facts _ _ NONE = []
@@ -436,6 +437,12 @@
end;
+fun flat_goal state =
+ let
+ val (_, (using, _)) = get_goal state;
+ val (ctxt, (_, goal)) = get_goal (refine_insert using state);
+ in (ctxt, goal) end;
+
(* refine via sub-proof *)
@@ -930,8 +937,8 @@
fun gen_show prep_att prepp before_qed after_qed stmt int state =
let
- val testing = ref false;
- val rule = ref (NONE: thm option);
+ val testing = Unsynchronized.ref false;
+ val rule = Unsynchronized.ref (NONE: thm option);
fun fail_msg ctxt =
"Local statement will fail to refine any pending goal" ::
(case ! rule of NONE => [] | SOME th => [ProofDisplay.string_of_rule ctxt "Failed" th])
--- a/src/Pure/Isar/proof_context.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/proof_context.ML Thu Oct 01 07:40:25 2009 +0200
@@ -123,15 +123,15 @@
val add_abbrev: string -> Properties.T ->
binding * term -> Proof.context -> (term * term) * Proof.context
val revert_abbrev: string -> string -> Proof.context -> Proof.context
- val verbose: bool ref
+ val verbose: bool Unsynchronized.ref
val setmp_verbose: ('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 ref
- val prems_limit: int ref
+ val debug: 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
val query_type: Proof.context -> string -> Properties.T
@@ -1208,9 +1208,9 @@
(** print context information **)
-val debug = ref false;
+val debug = Unsynchronized.ref false;
-val verbose = ref false;
+val verbose = Unsynchronized.ref false;
fun verb f x = if ! verbose then f (x ()) else [];
fun setmp_verbose f x = Library.setmp verbose true f x;
@@ -1320,7 +1320,7 @@
(* core context *)
-val prems_limit = ref ~1;
+val prems_limit = Unsynchronized.ref ~1;
fun pretty_ctxt ctxt =
if ! prems_limit < 0 andalso not (! debug) then []
--- a/src/Pure/Isar/specification.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/specification.ML Thu Oct 01 07:40:25 2009 +0200
@@ -209,7 +209,8 @@
(var, ((Binding.suffix_name "_raw" name, []), rhs));
val ((def_name, [th']), lthy3) = lthy2
|> LocalTheory.note Thm.definitionK
- ((name, Code.add_default_eqn_attrib :: atts), [prove lthy2 th]);
+ ((name, Predicate_Compile_Preproc_Const_Defs.add_attrib :: Code.add_default_eqn_attrib :: atts),
+ [prove lthy2 th]);
val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs;
val _ =
--- a/src/Pure/Isar/toplevel.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Isar/toplevel.ML Thu Oct 01 07:40:25 2009 +0200
@@ -24,12 +24,12 @@
val enter_proof_body: state -> Proof.state
val print_state_context: state -> unit
val print_state: bool -> state -> unit
- val quiet: bool ref
- val debug: bool ref
- val interact: bool ref
- val timing: bool ref
- val profiling: int ref
- val skip_proofs: bool ref
+ val quiet: bool Unsynchronized.ref
+ val debug: bool Unsynchronized.ref
+ val interact: bool Unsynchronized.ref
+ val timing: bool Unsynchronized.ref
+ val profiling: int Unsynchronized.ref
+ val skip_proofs: bool Unsynchronized.ref
exception TERMINATE
exception TOPLEVEL_ERROR
val program: (unit -> 'a) -> 'a
@@ -216,12 +216,12 @@
(** toplevel transitions **)
-val quiet = ref false;
+val quiet = Unsynchronized.ref false;
val debug = Output.debugging;
-val interact = ref false;
+val interact = Unsynchronized.ref false;
val timing = Output.timing;
-val profiling = ref 0;
-val skip_proofs = ref false;
+val profiling = Unsynchronized.ref 0;
+val skip_proofs = Unsynchronized.ref false;
exception TERMINATE = Runtime.TERMINATE;
exception EXCURSION_FAIL = Runtime.EXCURSION_FAIL;
@@ -550,9 +550,9 @@
(* post-transition hooks *)
-local val hooks = ref ([]: (transition -> state -> state -> unit) list) in
+local val hooks = Unsynchronized.ref ([]: (transition -> state -> state -> unit) list) in
-fun add_hook f = CRITICAL (fn () => change hooks (cons f));
+fun add_hook f = CRITICAL (fn () => Unsynchronized.change hooks (cons f));
fun get_hooks () = CRITICAL (fn () => ! hooks);
end;
--- a/src/Pure/ML-Systems/compiler_polyml-5.0.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/compiler_polyml-5.0.ML Thu Oct 01 07:40:25 2009 +0200
@@ -5,11 +5,11 @@
fun use_text ({tune_source, print, error, ...}: use_context) (line, name) verbose txt =
let
- val in_buffer = ref (explode (tune_source txt));
- val out_buffer = ref ([]: string list);
+ val in_buffer = Unsynchronized.ref (explode (tune_source txt));
+ val out_buffer = Unsynchronized.ref ([]: string list);
fun output () = implode (rev (case ! out_buffer of "\n" :: cs => cs | cs => cs));
- val current_line = ref line;
+ val current_line = Unsynchronized.ref line;
fun get () =
(case ! in_buffer of
[] => ""
--- a/src/Pure/ML-Systems/compiler_polyml-5.2.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/compiler_polyml-5.2.ML Thu Oct 01 07:40:25 2009 +0200
@@ -14,9 +14,9 @@
fun use_text ({tune_source, name_space, str_of_pos, print, error, ...}: use_context)
(start_line, name) verbose txt =
let
- val current_line = ref start_line;
- val in_buffer = ref (String.explode (tune_source txt));
- val out_buffer = ref ([]: string list);
+ val current_line = Unsynchronized.ref start_line;
+ val in_buffer = Unsynchronized.ref (String.explode (tune_source txt));
+ val out_buffer = Unsynchronized.ref ([]: string list);
fun output () = drop_newline (implode (rev (! out_buffer)));
fun get () =
--- a/src/Pure/ML-Systems/compiler_polyml-5.3.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/compiler_polyml-5.3.ML Thu Oct 01 07:40:25 2009 +0200
@@ -14,9 +14,9 @@
fun use_text ({tune_source, name_space, str_of_pos, print, error, ...}: use_context)
(start_line, name) verbose txt =
let
- val line = ref start_line;
- val in_buffer = ref (String.explode (tune_source txt));
- val out_buffer = ref ([]: string list);
+ val line = Unsynchronized.ref start_line;
+ val in_buffer = Unsynchronized.ref (String.explode (tune_source txt));
+ val out_buffer = Unsynchronized.ref ([]: string list);
fun output () = drop_newline (implode (rev (! out_buffer)));
fun get () =
--- a/src/Pure/ML-Systems/mosml.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/mosml.ML Thu Oct 01 07:40:25 2009 +0200
@@ -40,6 +40,7 @@
exception Interrupt;
fun reraise exn = raise exn;
+use "ML-Systems/unsynchronized.ML";
use "ML-Systems/exn.ML";
use "ML-Systems/universal.ML";
use "ML-Systems/thread_dummy.ML";
--- a/src/Pure/ML-Systems/multithreading.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/multithreading.ML Thu Oct 01 07:40:25 2009 +0200
@@ -14,7 +14,7 @@
sig
include BASIC_MULTITHREADING
val available: bool
- val max_threads: int ref
+ val max_threads: int Unsynchronized.ref
val max_threads_value: unit -> int
val enabled: unit -> bool
val no_interrupts: Thread.threadAttribute list
@@ -24,7 +24,7 @@
val with_attributes: Thread.threadAttribute list -> (Thread.threadAttribute list -> 'a) -> 'a
val sync_wait: Thread.threadAttribute list option -> Time.time option ->
ConditionVar.conditionVar -> Mutex.mutex -> bool Exn.result
- val trace: int ref
+ val trace: int Unsynchronized.ref
val tracing: int -> (unit -> string) -> unit
val tracing_time: bool -> Time.time -> (unit -> string) -> unit
val real_time: ('a -> unit) -> 'a -> Time.time
@@ -38,7 +38,7 @@
(* options *)
val available = false;
-val max_threads = ref (1: int);
+val max_threads = Unsynchronized.ref (1: int);
fun max_threads_value () = 1: int;
fun enabled () = false;
@@ -57,7 +57,7 @@
(* tracing *)
-val trace = ref (0: int);
+val trace = Unsynchronized.ref (0: int);
fun tracing _ _ = ();
fun tracing_time _ _ _ = ();
fun real_time f x = (f x; Time.zeroTime);
@@ -72,7 +72,7 @@
(* serial numbers *)
-local val count = ref (0: int)
+local val count = Unsynchronized.ref (0: int)
in fun serial () = (count := ! count + 1; ! count) end;
end;
--- a/src/Pure/ML-Systems/multithreading_polyml.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/multithreading_polyml.ML Thu Oct 01 07:40:25 2009 +0200
@@ -31,7 +31,7 @@
val available = true;
-val max_threads = ref 0;
+val max_threads = Unsynchronized.ref 0;
val tested_platform =
let val ml_platform = getenv "ML_PLATFORM"
@@ -114,7 +114,7 @@
(* tracing *)
-val trace = ref 0;
+val trace = Unsynchronized.ref 0;
fun tracing level msg =
if level > ! trace then ()
@@ -148,7 +148,7 @@
fun timeLimit time f x = uninterruptible (fn restore_attributes => fn () =>
let
val worker = Thread.self ();
- val timeout = ref false;
+ val timeout = Unsynchronized.ref false;
val watchdog = Thread.fork (fn () =>
(OS.Process.sleep time; timeout := true; Thread.interrupt worker), []);
@@ -173,7 +173,7 @@
(*result state*)
datatype result = Wait | Signal | Result of int;
- val result = ref Wait;
+ val result = Unsynchronized.ref Wait;
val lock = Mutex.mutex ();
val cond = ConditionVar.conditionVar ();
fun set_result res =
@@ -231,8 +231,8 @@
local
val critical_lock = Mutex.mutex ();
-val critical_thread = ref (NONE: Thread.thread option);
-val critical_name = ref "";
+val critical_thread = Unsynchronized.ref (NONE: Thread.thread option);
+val critical_name = Unsynchronized.ref "";
in
@@ -274,7 +274,7 @@
local
val serial_lock = Mutex.mutex ();
-val serial_count = ref 0;
+val serial_count = Unsynchronized.ref 0;
in
--- a/src/Pure/ML-Systems/polyml-5.0.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/polyml-5.0.ML Thu Oct 01 07:40:25 2009 +0200
@@ -5,6 +5,7 @@
fun reraise exn = raise exn;
+use "ML-Systems/unsynchronized.ML";
use "ML-Systems/universal.ML";
use "ML-Systems/thread_dummy.ML";
use "ML-Systems/ml_name_space.ML";
--- a/src/Pure/ML-Systems/polyml-5.1.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/polyml-5.1.ML Thu Oct 01 07:40:25 2009 +0200
@@ -5,6 +5,7 @@
fun reraise exn = raise exn;
+use "ML-Systems/unsynchronized.ML";
use "ML-Systems/thread_dummy.ML";
use "ML-Systems/ml_name_space.ML";
use "ML-Systems/polyml_common.ML";
--- a/src/Pure/ML-Systems/polyml-experimental.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/polyml-experimental.ML Thu Oct 01 07:40:25 2009 +0200
@@ -3,6 +3,8 @@
Compatibility wrapper for Poly/ML 5.3.
*)
+use "ML-Systems/unsynchronized.ML";
+
open Thread;
structure ML_Name_Space =
@@ -25,6 +27,7 @@
fun share_common_data () = PolyML.shareCommonData PolyML.rootFunction;
use "ML-Systems/compiler_polyml-5.3.ML";
+PolyML.Compiler.reportUnreferencedIds := true;
(* toplevel pretty printing *)
--- a/src/Pure/ML-Systems/polyml.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/polyml.ML Thu Oct 01 07:40:25 2009 +0200
@@ -3,6 +3,8 @@
Compatibility wrapper for Poly/ML 5.2 and 5.2.1.
*)
+use "ML-Systems/unsynchronized.ML";
+
open Thread;
structure ML_Name_Space =
--- a/src/Pure/ML-Systems/polyml_common.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/polyml_common.ML Thu Oct 01 07:40:25 2009 +0200
@@ -19,6 +19,8 @@
val forget_structure = PolyML.Compiler.forgetStructure;
val _ = PolyML.Compiler.forgetValue "print";
+val _ = PolyML.Compiler.forgetValue "ref";
+val _ = PolyML.Compiler.forgetType "ref";
(* Compiler options *)
@@ -50,7 +52,7 @@
(* print depth *)
local
- val depth = ref 10;
+ val depth = Unsynchronized.ref 10;
in
fun get_print_depth () = ! depth;
fun print_depth n = (depth := n; PolyML.print_depth n);
--- a/src/Pure/ML-Systems/proper_int.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/proper_int.ML Thu Oct 01 07:40:25 2009 +0200
@@ -136,6 +136,24 @@
end;
+(* StringCvt *)
+
+structure StringCvt =
+struct
+ open StringCvt;
+ datatype realfmt = EXACT | FIX of int option | GEN of int option | SCI of int option
+ fun realfmt fmt = Real.fmt
+ (case fmt of
+ EXACT => StringCvt.EXACT
+ | FIX NONE => StringCvt.FIX NONE
+ | FIX (SOME b) => StringCvt.FIX (SOME (dest_int b))
+ | GEN NONE => StringCvt.GEN NONE
+ | GEN (SOME b) => StringCvt.GEN (SOME (dest_int b))
+ | SCI NONE => StringCvt.SCI NONE
+ | SCI (SOME b) => StringCvt.SCI (SOME (dest_int b)));
+end;
+
+
(* Word *)
structure Word =
@@ -165,6 +183,7 @@
val trunc = mk_int o Real.trunc;
fun toInt a b = mk_int (Real.toInt a b);
fun fromInt a = Real.fromInt (dest_int a);
+ val fmt = StringCvt.realfmt;
end;
val ceil = Real.ceil;
--- a/src/Pure/ML-Systems/smlnj.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/smlnj.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,6 +7,7 @@
fun reraise exn = raise exn;
use "ML-Systems/proper_int.ML";
+use "ML-Systems/unsynchronized.ML";
use "ML-Systems/overloading_smlnj.ML";
use "ML-Systems/exn.ML";
use "ML-Systems/universal.ML";
--- a/src/Pure/ML-Systems/thread_dummy.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML-Systems/thread_dummy.ML Thu Oct 01 07:40:25 2009 +0200
@@ -35,6 +35,8 @@
datatype threadAttribute = EnableBroadcastInterrupt of bool | InterruptState of interruptState
and interruptState = InterruptDefer | InterruptSynch | InterruptAsynch | InterruptAsynchOnce;
+ fun unavailable () = fail ();
+
fun fork _ = fail ();
fun exit _ = fail ();
fun isActive _ = fail ();
@@ -58,7 +60,7 @@
local
-val data = ref ([]: Universal.universal ref list);
+val data = Unsynchronized.ref ([]: Universal.universal Unsynchronized.ref list);
fun find_data tag =
let
@@ -73,7 +75,7 @@
fun setLocal (tag, x) =
(case find_data tag of
SOME r => r := Universal.tagInject tag x
- | NONE => data := ref (Universal.tagInject tag x) :: ! data);
+ | NONE => data := Unsynchronized.ref (Universal.tagInject tag x) :: ! data);
end;
end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/ML-Systems/unsynchronized.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,25 @@
+(* Title: Pure/ML-Systems/unsynchronized.ML
+ Author: Makarius
+
+Raw ML references as unsynchronized state variables.
+*)
+
+structure Unsynchronized =
+struct
+
+datatype ref = datatype ref;
+
+val op := = op :=;
+val ! = !;
+
+fun set flag = (flag := true; true);
+fun reset flag = (flag := false; false);
+fun toggle flag = (flag := not (! flag); ! flag);
+
+fun change r f = r := f (! r);
+fun change_result r f = let val (x, y) = f (! r) in r := y; x end;
+
+fun inc i = (i := ! i + (1: int); ! i);
+fun dec i = (i := ! i - (1: int); ! i);
+
+end;
--- a/src/Pure/ML/ml_compiler_polyml-5.3.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML/ml_compiler_polyml-5.3.ML Thu Oct 01 07:40:25 2009 +0200
@@ -1,7 +1,7 @@
(* Title: Pure/ML/ml_compiler_polyml-5.3.ML
Author: Makarius
-Advanced runtime compilation for Poly/ML 5.3 (SVN 773).
+Advanced runtime compilation for Poly/ML 5.3 (SVN 839).
*)
signature ML_COMPILER =
@@ -74,8 +74,8 @@
(* input *)
val location_props =
- Markup.markup (Markup.position |> Markup.properties
- (filter (member (op =) [Markup.idN, Markup.fileN] o #1) (Position.properties_of pos))) "";
+ op ^ (YXML.output_markup (Markup.position |> Markup.properties
+ (filter (member (op =) [Markup.idN, Markup.fileN] o #1) (Position.properties_of pos))));
val input = toks |> maps (fn tok =>
let
@@ -91,8 +91,8 @@
if null toks then Position.none
else ML_Lex.end_pos_of (List.last toks);
- val input_buffer = ref (input @ [(offset_of end_pos, #"\n")]);
- val line = ref (the_default 1 (Position.line_of pos));
+ val input_buffer = Unsynchronized.ref (input @ [(offset_of end_pos, #"\n")]);
+ val line = Unsynchronized.ref (the_default 1 (Position.line_of pos));
fun get_offset () = (case ! input_buffer of [] => 0 | (i, _) :: _ => i);
fun get () =
@@ -106,14 +106,13 @@
(* output *)
- val output_buffer = ref Buffer.empty;
+ val output_buffer = Unsynchronized.ref Buffer.empty;
fun output () = Buffer.content (! output_buffer);
- fun put s = change output_buffer (Buffer.add s);
+ fun put s = Unsynchronized.change output_buffer (Buffer.add s);
fun put_message {message, hard, location, context = _} =
- (put (if hard then "Error: " else "Warning: ");
- put (Pretty.string_of (Pretty.from_ML (pretty_ml message)));
- put (Position.str_of (position_of location) ^ "\n"));
+ (put ((if hard then "Error" else "Warning") ^ Position.str_of (position_of location) ^ ":\n");
+ put (Pretty.string_of (Pretty.from_ML (pretty_ml message)) ^ "\n"));
(* results *)
--- a/src/Pure/ML/ml_context.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ML/ml_context.ML Thu Oct 01 07:40:25 2009 +0200
@@ -19,20 +19,21 @@
val the_global_context: unit -> theory
val the_local_context: unit -> Proof.context
val exec: (unit -> unit) -> Context.generic -> Context.generic
- val stored_thms: thm list ref
+ 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
val add_antiq: string -> (Position.T -> antiq context_parser) -> unit
- val trace: bool ref
+ val trace: bool Unsynchronized.ref
val eval_antiquotes: ML_Lex.token Antiquote.antiquote list * Position.T ->
Context.generic option -> (ML_Lex.token list * ML_Lex.token list) * Context.generic option
val eval: bool -> Position.T -> Symbol_Pos.text -> unit
val eval_file: Path.T -> unit
val eval_in: Proof.context option -> bool -> Position.T -> Symbol_Pos.text -> unit
- val evaluate: Proof.context -> bool -> string * (unit -> 'a) option ref -> string -> 'a
+ val evaluate: Proof.context -> bool ->
+ string * (unit -> 'a) option Unsynchronized.ref -> string -> 'a
val expression: Position.T -> string -> string -> string -> Context.generic -> Context.generic
end
@@ -53,7 +54,7 @@
(* theorem bindings *)
-val stored_thms: thm list ref = ref [];
+val stored_thms: thm list Unsynchronized.ref = Unsynchronized.ref [];
fun ml_store sel (name, ths) =
let
@@ -89,12 +90,13 @@
local
-val global_parsers = ref (Symtab.empty: (Position.T -> antiq context_parser) Symtab.table);
+val global_parsers =
+ Unsynchronized.ref (Symtab.empty: (Position.T -> antiq context_parser) Symtab.table);
in
fun add_antiq name scan = CRITICAL (fn () =>
- change global_parsers (fn tab =>
+ Unsynchronized.change global_parsers (fn tab =>
(if not (Symtab.defined tab name) then ()
else warning ("Redefined ML antiquotation: " ^ quote name);
Symtab.update (name, scan) tab)));
@@ -162,7 +164,7 @@
in (ml, SOME (Context.Proof ctxt')) end;
in ((begin_env @ ml_env @ end_env, ml_body), opt_ctxt') end;
-val trace = ref false;
+val trace = Unsynchronized.ref false;
fun eval verbose pos txt =
let
--- a/src/Pure/Proof/extraction.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Proof/extraction.ML Thu Oct 01 07:40:25 2009 +0200
@@ -91,7 +91,7 @@
Pattern.rewrite_term thy [] (condrew' :: procs) tm
and condrew' tm =
let
- val cache = ref ([] : (term * term) list);
+ val cache = Unsynchronized.ref ([] : (term * term) list);
fun lookup f x = (case AList.lookup (op =) (!cache) x of
NONE =>
let val y = f x
--- a/src/Pure/Proof/reconstruct.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Proof/reconstruct.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
signature RECONSTRUCT =
sig
- val quiet_mode : bool ref
+ val quiet_mode : bool Unsynchronized.ref
val reconstruct_proof : theory -> term -> Proofterm.proof -> Proofterm.proof
val prop_of' : term list -> Proofterm.proof -> term
val prop_of : Proofterm.proof -> term
@@ -19,7 +19,7 @@
open Proofterm;
-val quiet_mode = ref true;
+val quiet_mode = Unsynchronized.ref true;
fun message s = if !quiet_mode then () else writeln s;
fun vars_of t = map Var (rev (Term.add_vars t []));
--- a/src/Pure/ProofGeneral/pgip_parser.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ProofGeneral/pgip_parser.ML Thu Oct 01 07:40:25 2009 +0200
@@ -20,7 +20,7 @@
fun badcmd text = [D.Badcmd {text = text}];
fun thy_begin text =
- (case try (ThyHeader.read Position.none) (Source.of_string text) of
+ (case try (Thy_Header.read Position.none) (Source.of_string text) of
NONE => D.Opentheory {thyname = NONE, parentnames = [], text = text}
| SOME (name, imports, _) =>
D.Opentheory {thyname = SOME name, parentnames = imports, text = text})
--- a/src/Pure/ProofGeneral/preferences.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ProofGeneral/preferences.ML Thu Oct 01 07:40:25 2009 +0200
@@ -18,11 +18,11 @@
get: unit -> string,
set: string -> unit}
val generic_pref: ('a -> string) -> (string -> 'a) -> PgipTypes.pgiptype ->
- 'a ref -> string -> string -> preference
- val string_pref: string ref -> string -> string -> preference
- val int_pref: int ref -> string -> string -> preference
- val nat_pref: int ref -> string -> string -> preference
- val bool_pref: bool ref -> string -> string -> preference
+ 'a Unsynchronized.ref -> string -> string -> preference
+ val string_pref: string Unsynchronized.ref -> string -> string -> preference
+ val int_pref: int Unsynchronized.ref -> string -> string -> preference
+ val nat_pref: int Unsynchronized.ref -> string -> string -> preference
+ val bool_pref: bool Unsynchronized.ref -> string -> string -> preference
type T = (string * preference list) list
val pure_preferences: T
val remove: string -> T -> T
@@ -95,8 +95,9 @@
let
fun get () = PgipTypes.bool_to_pgstring (print_mode_active thm_depsN);
fun set s =
- if PgipTypes.read_pgipbool s then change print_mode (insert (op =) thm_depsN)
- else change print_mode (remove (op =) thm_depsN);
+ if PgipTypes.read_pgipbool s
+ then Unsynchronized.change print_mode (insert (op =) thm_depsN)
+ else Unsynchronized.change print_mode (remove (op =) thm_depsN);
in
mkpref get set PgipTypes.Pgipbool "theorem-dependencies"
"Track theorem dependencies within Proof General"
--- a/src/Pure/ProofGeneral/proof_general_emacs.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ProofGeneral/proof_general_emacs.ML Thu Oct 01 07:40:25 2009 +0200
@@ -226,7 +226,7 @@
(* init *)
-val initialized = ref false;
+val initialized = Unsynchronized.ref false;
fun init false = panic "No Proof General interface support for Isabelle/classic mode."
| init true =
@@ -239,9 +239,9 @@
ProofGeneralPgip.init_pgip_channel (! Output.priority_fn);
setup_thy_loader ();
setup_present_hook ();
- set initialized);
+ Unsynchronized.set initialized);
sync_thy_loader ();
- change print_mode (update (op =) proof_generalN);
+ Unsynchronized.change print_mode (update (op =) proof_generalN);
Isar.toplevel_loop {init = true, welcome = true, sync = true, secure = Secure.is_secure ()});
end;
--- a/src/Pure/ProofGeneral/proof_general_pgip.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ProofGeneral/proof_general_pgip.ML Thu Oct 01 07:40:25 2009 +0200
@@ -32,20 +32,20 @@
(** print mode **)
val proof_generalN = "ProofGeneral";
-val pgmlsymbols_flag = ref true;
+val pgmlsymbols_flag = Unsynchronized.ref true;
(* assembling and issuing PGIP packets *)
-val pgip_refid = ref NONE: string option ref;
-val pgip_refseq = ref NONE: int option ref;
+val pgip_refid = Unsynchronized.ref NONE: string option Unsynchronized.ref;
+val pgip_refseq = Unsynchronized.ref NONE: int option Unsynchronized.ref;
local
val pgip_class = "pg"
val pgip_tag = "Isabelle/Isar"
- val pgip_id = ref ""
- val pgip_seq = ref 0
- fun pgip_serial () = inc pgip_seq
+ val pgip_id = Unsynchronized.ref ""
+ val pgip_seq = Unsynchronized.ref 0
+ fun pgip_serial () = Unsynchronized.inc pgip_seq
fun assemble_pgips pgips =
Pgip { tag = SOME pgip_tag,
@@ -65,7 +65,7 @@
fun matching_pgip_id id = (id = ! pgip_id)
-val output_xml_fn = ref Output.writeln_default
+val output_xml_fn = Unsynchronized.ref Output.writeln_default
fun output_xml s = ! output_xml_fn (XML.string_of s);
val output_pgips = XML.string_of o PgipOutput.output o assemble_pgips o map PgipOutput.output;
@@ -280,7 +280,7 @@
(* theorem dependeny output *)
-val show_theorem_dependencies = ref false;
+val show_theorem_dependencies = Unsynchronized.ref false;
local
@@ -368,13 +368,13 @@
(* Preferences: tweak for PGIP interfaces *)
-val preferences = ref Preferences.pure_preferences;
+val preferences = Unsynchronized.ref Preferences.pure_preferences;
fun add_preference cat pref =
- CRITICAL (fn () => change preferences (Preferences.add cat pref));
+ CRITICAL (fn () => Unsynchronized.change preferences (Preferences.add cat pref));
fun setup_preferences_tweak () =
- CRITICAL (fn () => change preferences
+ CRITICAL (fn () => Unsynchronized.change preferences
(Preferences.set_default ("show-question-marks", "false") #>
Preferences.remove "show-question-marks" #> (* we use markup, not ?s *)
Preferences.remove "theorem-dependencies" #> (* set internally *)
@@ -471,7 +471,7 @@
fun set_proverflag_pgmlsymbols b =
(pgmlsymbols_flag := b;
NAMED_CRITICAL "print_mode" (fn () =>
- change print_mode
+ Unsynchronized.change print_mode
(fn mode =>
remove (op =) Symbol.xsymbolsN mode @ (if b then [Symbol.xsymbolsN] else []))))
@@ -677,7 +677,7 @@
about this special status, but for now we just keep a local reference.
*)
-val currently_open_file = ref (NONE : pgipurl option)
+val currently_open_file = Unsynchronized.ref (NONE : pgipurl option)
fun get_currently_open_file () = ! currently_open_file;
@@ -779,7 +779,7 @@
*)
local
- val current_working_dir = ref (NONE : string option)
+ val current_working_dir = Unsynchronized.ref (NONE : string option)
in
fun changecwd_dir newdirpath =
let
@@ -1021,7 +1021,7 @@
(* init *)
-val initialized = ref false;
+val initialized = Unsynchronized.ref false;
fun init_pgip false = panic "No Proof General interface support for Isabelle/classic mode."
| init_pgip true =
@@ -1035,9 +1035,9 @@
setup_present_hook ();
init_pgip_session_id ();
welcome ();
- set initialized);
+ Unsynchronized.set initialized);
sync_thy_loader ();
- change print_mode (update (op =) proof_generalN);
+ Unsynchronized.change print_mode (update (op =) proof_generalN);
pgip_toplevel tty_src);
@@ -1045,7 +1045,7 @@
(** Out-of-loop PGIP commands (for Emacs hybrid mode) **)
local
- val pgip_output_channel = ref Output.writeln_default
+ val pgip_output_channel = Unsynchronized.ref Output.writeln_default
in
(* Set recipient for PGIP results *)
--- a/src/Pure/ROOT.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/ROOT.ML Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,7 @@
end;
(*if true then some tools will OMIT some proofs*)
-val quick_and_dirty = ref false;
+val quick_and_dirty = Unsynchronized.ref false;
print_depth 10;
@@ -58,6 +58,7 @@
use "Concurrent/simple_thread.ML";
use "Concurrent/synchronized.ML";
+if Multithreading.available then () else use "Concurrent/synchronized_dummy.ML";
use "Concurrent/mailbox.ML";
use "Concurrent/task_queue.ML";
use "Concurrent/future.ML";
--- a/src/Pure/Syntax/ast.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Syntax/ast.ML Thu Oct 01 07:40:25 2009 +0200
@@ -24,8 +24,8 @@
val fold_ast_p: string -> ast list * ast -> ast
val unfold_ast: string -> ast -> ast list
val unfold_ast_p: string -> ast -> ast list * ast
- val trace_ast: bool ref
- val stat_ast: bool ref
+ val trace_ast: bool Unsynchronized.ref
+ val stat_ast: bool Unsynchronized.ref
end;
signature AST =
@@ -173,9 +173,9 @@
fun normalize trace stat get_rules pre_ast =
let
- val passes = ref 0;
- val failed_matches = ref 0;
- val changes = ref 0;
+ val passes = Unsynchronized.ref 0;
+ val failed_matches = Unsynchronized.ref 0;
+ val changes = Unsynchronized.ref 0;
fun subst _ (ast as Constant _) = ast
| subst env (Variable x) = the (Symtab.lookup env x)
@@ -184,8 +184,8 @@
fun try_rules ((lhs, rhs) :: pats) ast =
(case match ast lhs of
SOME (env, args) =>
- (inc changes; SOME (mk_appl (subst env rhs) args))
- | NONE => (inc failed_matches; try_rules pats ast))
+ (Unsynchronized.inc changes; SOME (mk_appl (subst env rhs) args))
+ | NONE => (Unsynchronized.inc failed_matches; try_rules pats ast))
| try_rules [] _ = NONE;
val try_headless_rules = try_rules (get_rules "");
@@ -226,7 +226,7 @@
val old_changes = ! changes;
val new_ast = norm ast;
in
- inc passes;
+ Unsynchronized.inc passes;
if old_changes = ! changes then new_ast else normal new_ast
end;
@@ -245,8 +245,8 @@
(* normalize_ast *)
-val trace_ast = ref false;
-val stat_ast = ref false;
+val trace_ast = Unsynchronized.ref false;
+val stat_ast = Unsynchronized.ref false;
fun normalize_ast get_rules ast =
normalize (! trace_ast) (! stat_ast) get_rules ast;
--- a/src/Pure/Syntax/parser.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Syntax/parser.ML Thu Oct 01 07:40:25 2009 +0200
@@ -17,7 +17,7 @@
Tip of Lexicon.token
val parse: gram -> string -> Lexicon.token list -> parsetree list
val guess_infix_lr: gram -> string -> (string * bool * bool * int) option
- val branching_level: int ref
+ val branching_level: int Unsynchronized.ref
end;
structure Parser: PARSER =
@@ -690,7 +690,7 @@
else movedot_lambda (B, j, tss, Nonterminal (A, k) :: sa, id, i) ts;
-val branching_level = ref 600; (*trigger value for warnings*)
+val branching_level = Unsynchronized.ref 600; (*trigger value for warnings*)
(*get all productions of a NT and NTs chained to it which can
be started by specified token*)
@@ -821,7 +821,7 @@
val Estate = Array.array (s, []);
in
Array.update (Estate, 0, S0);
- get_trees (produce (ref false) prods tags chains Estate 0 indata eof)
+ get_trees (produce (Unsynchronized.ref false) prods tags chains Estate 0 indata eof)
end;
--- a/src/Pure/Syntax/printer.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Syntax/printer.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,11 +6,11 @@
signature PRINTER0 =
sig
- val show_brackets: bool ref
- val show_sorts: bool ref
- val show_types: bool ref
- val show_no_free_types: bool ref
- val show_all_types: bool ref
+ val show_brackets: bool Unsynchronized.ref
+ val show_sorts: bool Unsynchronized.ref
+ val show_types: bool Unsynchronized.ref
+ val show_no_free_types: bool Unsynchronized.ref
+ val show_all_types: bool Unsynchronized.ref
val pp_show_brackets: Pretty.pp -> Pretty.pp
end;
@@ -42,11 +42,11 @@
(** options for printing **)
-val show_types = ref false;
-val show_sorts = ref false;
-val show_brackets = ref false;
-val show_no_free_types = ref false;
-val show_all_types = ref false;
+val show_types = Unsynchronized.ref false;
+val show_sorts = Unsynchronized.ref false;
+val show_brackets = Unsynchronized.ref false;
+val show_no_free_types = Unsynchronized.ref false;
+val show_all_types = Unsynchronized.ref false;
fun pp_show_brackets pp = Pretty.pp (setmp show_brackets true (Pretty.term pp),
Pretty.typ pp, Pretty.sort pp, Pretty.classrel pp, Pretty.arity pp);
--- a/src/Pure/Syntax/syn_trans.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Syntax/syn_trans.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
signature SYN_TRANS0 =
sig
- val eta_contract: bool ref
+ val eta_contract: bool Unsynchronized.ref
val atomic_abs_tr': string * typ * term -> term * term
val preserve_binder_abs_tr': string -> string -> string * (term list -> term)
val preserve_binder_abs2_tr': string -> string -> string * (term list -> term)
@@ -276,7 +276,7 @@
(*do (partial) eta-contraction before printing*)
-val eta_contract = ref true;
+val eta_contract = Unsynchronized.ref true;
fun eta_contr tm =
let
--- a/src/Pure/Syntax/syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Syntax/syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -36,9 +36,9 @@
val print_syntax: syntax -> unit
val guess_infix: syntax -> string -> mixfix option
val read_token: string -> Symbol_Pos.T list * Position.T
- val ambiguity_is_error: bool ref
- val ambiguity_level: int ref
- val ambiguity_limit: int ref
+ val ambiguity_is_error: bool Unsynchronized.ref
+ val ambiguity_level: int Unsynchronized.ref
+ val ambiguity_limit: int Unsynchronized.ref
val standard_parse_term: Pretty.pp -> (term -> string option) ->
(((string * int) * sort) list -> string * int -> Term.sort) ->
(string -> bool * string) -> (string -> string option) ->
@@ -472,9 +472,9 @@
(* read_ast *)
-val ambiguity_is_error = ref false;
-val ambiguity_level = ref 1;
-val ambiguity_limit = ref 10;
+val ambiguity_is_error = Unsynchronized.ref false;
+val ambiguity_level = Unsynchronized.ref 1;
+val ambiguity_limit = Unsynchronized.ref 10;
fun ambiguity_msg pos = "Parse error: ambiguous syntax" ^ Position.str_of pos;
@@ -711,7 +711,7 @@
unparse_typ: Proof.context -> typ -> Pretty.T,
unparse_term: Proof.context -> term -> Pretty.T};
- val operations = ref (NONE: operations option);
+ val operations = Unsynchronized.ref (NONE: operations option);
fun operation which ctxt x =
(case ! operations of
--- a/src/Pure/System/isabelle_process.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/System/isabelle_process.ML Thu Oct 01 07:40:25 2009 +0200
@@ -130,7 +130,7 @@
(* init *)
fun init out =
- (change print_mode (update (op =) isabelle_processN);
+ (Unsynchronized.change print_mode (update (op =) isabelle_processN);
setup_channels out |> init_message;
OuterKeyword.report ();
Output.status (Markup.markup Markup.ready "");
--- a/src/Pure/System/isabelle_process.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/System/isabelle_process.scala Thu Oct 01 07:40:25 2009 +0200
@@ -11,9 +11,12 @@
import java.io.{BufferedReader, BufferedWriter, InputStreamReader, OutputStreamWriter,
InputStream, OutputStream, IOException}
+import scala.actors.Actor
+import Actor._
-object Isabelle_Process {
+object Isabelle_Process
+{
/* results */
object Kind extends Enumeration {
@@ -104,8 +107,7 @@
}
-class Isabelle_Process(isabelle_system: Isabelle_System,
- results: EventBus[Isabelle_Process.Result], args: String*)
+class Isabelle_Process(isabelle_system: Isabelle_System, receiver: Actor, args: String*)
{
import Isabelle_Process._
@@ -113,7 +115,8 @@
/* demo constructor */
def this(args: String*) =
- this(new Isabelle_System, new EventBus[Isabelle_Process.Result] + Console.println, args: _*)
+ this(new Isabelle_System,
+ new Actor { def act = loop { react { case res => Console.println(res) } } }.start, args: _*)
/* process information */
@@ -127,11 +130,6 @@
/* results */
- def parse_message(result: Result): XML.Tree =
- Isabelle_Process.parse_message(isabelle_system, result)
-
- private val result_queue = new LinkedBlockingQueue[Result]
-
private def put_result(kind: Kind.Value, props: List[(String, String)], result: String)
{
if (kind == Kind.INIT) {
@@ -139,24 +137,7 @@
if (map.isDefinedAt(Markup.PID)) pid = map(Markup.PID)
if (map.isDefinedAt(Markup.SESSION)) the_session = map(Markup.SESSION)
}
- result_queue.put(new Result(kind, props, result))
- }
-
- private class ResultThread extends Thread("isabelle: results") {
- override def run() = {
- var finished = false
- while (!finished) {
- val result =
- try { result_queue.take }
- catch { case _: NullPointerException => null }
-
- if (result != null) {
- results.event(result)
- if (result.kind == Kind.EXIT) finished = true
- }
- else finished = true
- }
- }
+ receiver ! new Result(kind, props, result)
}
@@ -204,14 +185,14 @@
def command(text: String) =
- output_sync("Isabelle.command " + IsabelleSyntax.encode_string(text))
+ output_sync("Isabelle.command " + Isabelle_Syntax.encode_string(text))
def command(props: List[(String, String)], text: String) =
- output_sync("Isabelle.command " + IsabelleSyntax.encode_properties(props) + " " +
- IsabelleSyntax.encode_string(text))
+ output_sync("Isabelle.command " + Isabelle_Syntax.encode_properties(props) + " " +
+ Isabelle_Syntax.encode_string(text))
def ML(text: String) =
- output_sync("ML_val " + IsabelleSyntax.encode_string(text))
+ output_sync("ML_val " + Isabelle_Syntax.encode_string(text))
def close() = synchronized { // FIXME watchdog/timeout
output_raw("\u0000")
@@ -396,8 +377,6 @@
val message_thread = new MessageThread(message_fifo)
message_thread.start
- new ResultThread().start
-
/* exec process */
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Pure/System/isabelle_syntax.scala Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,74 @@
+/* Title: Pure/System/isabelle_syntax.scala
+ Author: Makarius
+
+Isabelle outer syntax.
+*/
+
+package isabelle
+
+
+object Isabelle_Syntax
+{
+ /* string token */
+
+ def append_string(str: String, result: StringBuilder)
+ {
+ result.append("\"")
+ for (c <- str) {
+ if (c < 32 || c == '\\' || c == '\"') {
+ result.append("\\")
+ if (c < 10) result.append('0')
+ if (c < 100) result.append('0')
+ result.append(c.asInstanceOf[Int].toString)
+ }
+ else result.append(c)
+ }
+ result.append("\"")
+ }
+
+ def encode_string(str: String) =
+ {
+ val result = new StringBuilder(str.length + 10)
+ append_string(str, result)
+ result.toString
+ }
+
+
+ /* list */
+
+ def append_list[A](append_elem: (A, StringBuilder) => Unit, body: Iterable[A],
+ result: StringBuilder)
+ {
+ result.append("(")
+ val elems = body.elements
+ if (elems.hasNext) append_elem(elems.next, result)
+ while (elems.hasNext) {
+ result.append(", ")
+ append_elem(elems.next, result)
+ }
+ result.append(")")
+ }
+
+ def encode_list[A](append_elem: (A, StringBuilder) => Unit, elems: Iterable[A]) =
+ {
+ val result = new StringBuilder
+ append_list(append_elem, elems, result)
+ result.toString
+ }
+
+
+ /* properties */
+
+ def append_properties(props: List[(String, String)], result: StringBuilder)
+ {
+ append_list((p: (String, String), res) =>
+ { append_string(p._1, res); res.append(" = "); append_string(p._2, res) }, props, result)
+ }
+
+ def encode_properties(props: List[(String, String)]) =
+ {
+ val result = new StringBuilder
+ append_properties(props, result)
+ result.toString
+ }
+}
--- a/src/Pure/System/isabelle_system.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/System/isabelle_system.scala Thu Oct 01 07:40:25 2009 +0200
@@ -42,13 +42,11 @@
val rc = proc.waitFor
(output, rc)
}
-
}
class Isabelle_System
{
-
/** unique ids **/
private var id_count: BigInt = 0
@@ -244,6 +242,7 @@
}
+
/** system tools **/
/* external processes */
@@ -296,6 +295,7 @@
}
+
/** Isabelle resources **/
/* components */
--- a/src/Pure/System/isar.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/System/isar.ML Thu Oct 01 07:40:25 2009 +0200
@@ -18,16 +18,10 @@
val undo: int -> unit
val kill: unit -> unit
val kill_proof: unit -> unit
- val crashes: exn list ref
+ val crashes: exn list Unsynchronized.ref
val toplevel_loop: {init: bool, welcome: bool, sync: bool, secure: bool} -> unit
val loop: unit -> unit
val main: unit -> unit
-
- type id = string
- val no_id: id
- val create_command: Toplevel.transition -> id
- val insert_command: id -> id -> unit
- val remove_command: id -> unit
end;
structure Isar: ISAR =
@@ -42,9 +36,9 @@
(*previous state, state transition -- regular commands only*)
local
- val global_history = ref ([]: history);
- val global_state = ref Toplevel.toplevel;
- val global_exn = ref (NONE: (exn * string) option);
+ val global_history = Unsynchronized.ref ([]: history);
+ val global_state = Unsynchronized.ref Toplevel.toplevel;
+ val global_exn = Unsynchronized.ref (NONE: (exn * string) option);
in
fun edit_history count f = NAMED_CRITICAL "Isar" (fn () =>
@@ -121,7 +115,7 @@
(* toplevel loop *)
-val crashes = ref ([]: exn list);
+val crashes = Unsynchronized.ref ([]: exn list);
local
@@ -136,7 +130,7 @@
handle exn =>
(Output.error_msg (ML_Compiler.exn_message exn)
handle crash =>
- (CRITICAL (fn () => change crashes (cons crash));
+ (CRITICAL (fn () => Unsynchronized.change crashes (cons crash));
warning "Recovering from Isar toplevel crash -- see also Isar.crashes");
raw_loop secure src)
end;
@@ -145,7 +139,8 @@
fun toplevel_loop {init = do_init, welcome, sync, secure} =
(Context.set_thread_data NONE;
- if do_init then init () else (); (* FIXME init editor model *)
+ Secure.open_unsynchronized ();
+ if do_init then init () else ();
if welcome then writeln (Session.welcome ()) else ();
uninterruptible (fn _ => fn () => raw_loop secure (OuterSyntax.isar sync)) ());
@@ -159,198 +154,6 @@
-(** individual toplevel commands **)
-
-(* unique identification *)
-
-type id = string;
-val no_id : id = "";
-
-
-(* command category *)
-
-datatype category = Empty | Theory | Proof | Diag | Control;
-
-fun category_of tr =
- let val name = Toplevel.name_of tr in
- if name = "" then Empty
- else if OuterKeyword.is_theory name then Theory
- else if OuterKeyword.is_proof name then Proof
- else if OuterKeyword.is_diag name then Diag
- else Control
- end;
-
-val is_theory = fn Theory => true | _ => false;
-val is_proper = fn Theory => true | Proof => true | _ => false;
-val is_regular = fn Control => false | _ => true;
-
-
-(* command status *)
-
-datatype status =
- Unprocessed |
- Running |
- Failed of exn * string |
- Finished of Toplevel.state;
-
-fun status_markup Unprocessed = Markup.unprocessed
- | status_markup Running = (Markup.runningN, [])
- | status_markup (Failed _) = Markup.failed
- | status_markup (Finished _) = Markup.finished;
-
-fun run int tr state =
- (case Toplevel.transition int tr state of
- NONE => NONE
- | SOME (_, SOME err) => (Toplevel.error_msg tr err; SOME (Failed err))
- | SOME (state', NONE) => SOME (Finished state'));
-
-
-(* datatype command *)
-
-datatype command = Command of
- {category: category,
- transition: Toplevel.transition,
- status: status};
-
-fun make_command (category, transition, status) =
- Command {category = category, transition = transition, status = status};
-
-val empty_command =
- make_command (Empty, Toplevel.empty, Finished Toplevel.toplevel);
-
-fun map_command f (Command {category, transition, status}) =
- make_command (f (category, transition, status));
-
-fun map_status f = map_command (fn (category, transition, status) =>
- (category, transition, f status));
-
-
-(* global collection of identified commands *)
-
-fun err_dup id = sys_error ("Duplicate command " ^ quote id);
-fun err_undef id = sys_error ("Unknown command " ^ quote id);
-
-local val global_commands = ref (Graph.empty: command Graph.T) in
-
-fun change_commands f = NAMED_CRITICAL "Isar" (fn () => change global_commands f)
- handle Graph.DUP bad => err_dup bad | Graph.UNDEF bad => err_undef bad;
-
-fun get_commands () = NAMED_CRITICAL "Isar" (fn () => ! global_commands);
-
-end;
-
-fun add_edge (id1, id2) =
- if id1 = no_id orelse id2 = no_id then I else Graph.add_edge (id1, id2);
-
-
-fun init_commands () = change_commands (K Graph.empty);
-
-fun the_command id =
- let val Command cmd =
- if id = no_id then empty_command
- else (Graph.get_node (get_commands ()) id handle Graph.UNDEF bad => err_undef bad)
- in cmd end;
-
-fun prev_command id =
- if id = no_id then no_id
- else
- (case Graph.imm_preds (get_commands ()) id handle Graph.UNDEF bad => err_undef bad of
- [] => no_id
- | [prev] => prev
- | _ => sys_error ("Non-linear command dependency " ^ quote id));
-
-fun next_commands id =
- if id = no_id then []
- else Graph.imm_succs (get_commands ()) id handle Graph.UNDEF bad => err_undef bad;
-
-fun descendant_commands ids =
- Graph.all_succs (get_commands ()) (distinct (op =) (filter_out (fn id => id = no_id) ids))
- handle Graph.UNDEF bad => err_undef bad;
-
-
-(* maintain status *)
-
-fun report_status markup id = Toplevel.status (#transition (the_command id)) markup;
-
-fun update_status status id = change_commands (Graph.map_node id (map_status (K status)));
-
-fun report_update_status status id =
- change_commands (Graph.map_node id (map_status (fn old_status =>
- let val markup = status_markup status
- in if markup <> status_markup old_status then report_status markup id else (); status end)));
-
-
-(* create and dispose commands *)
-
-fun create_command raw_tr =
- let
- val (id, tr) =
- (case Toplevel.get_id raw_tr of
- SOME id => (id, raw_tr)
- | NONE =>
- let val id =
- if ! Toplevel.debug then "isabelle:" ^ Toplevel.name_of raw_tr ^ serial_string ()
- else "i" ^ serial_string ()
- in (id, Toplevel.put_id id raw_tr) end);
-
- val cmd = make_command (category_of tr, tr, Unprocessed);
- val _ = change_commands (Graph.new_node (id, cmd));
- in id end;
-
-fun dispose_commands ids =
- let
- val desc = descendant_commands ids;
- val _ = List.app (report_status Markup.disposed) desc;
- val _ = change_commands (Graph.del_nodes desc);
- in () end;
-
-
-(* final state *)
-
-fun the_state id =
- (case the_command id of
- {status = Finished state, ...} => state
- | {transition, ...} => error ("Unfinished command " ^ Toplevel.str_of transition));
-
-
-
-(** editor model **)
-
-(* run commands *)
-
-fun try_run id =
- (case try the_state (prev_command id) of
- NONE => ()
- | SOME state =>
- (case run true (#transition (the_command id)) state of
- NONE => ()
- | SOME status => report_update_status status id));
-
-fun rerun_commands ids =
- (List.app (report_update_status Unprocessed) ids; List.app try_run ids);
-
-
-(* modify document *)
-
-fun insert_command prev id = NAMED_CRITICAL "Isar" (fn () =>
- let
- val nexts = next_commands prev;
- val _ = change_commands
- (fold (fn next => Graph.del_edge (prev, next)) nexts #> add_edge (prev, id) #>
- fold (fn next => Graph.add_edge (id, next)) nexts);
- in descendant_commands [id] end) |> rerun_commands;
-
-fun remove_command id = NAMED_CRITICAL "Isar" (fn () =>
- let
- val prev = prev_command id;
- val nexts = next_commands id;
- val _ = change_commands
- (fold (fn next => Graph.del_edge (id, next)) nexts #>
- fold (fn next => add_edge (prev, next)) nexts);
- in descendant_commands nexts end) |> rerun_commands;
-
-
-
(** command syntax **)
local
@@ -392,24 +195,6 @@
OuterSyntax.improper_command "kill" "kill partial proof or theory development" K.control
(Scan.succeed (Toplevel.no_timing o Toplevel.imperative kill));
-
-(* editor model *)
-
-val _ =
- OuterSyntax.internal_command "Isar.command"
- (P.string -- P.string >> (fn (id, text) =>
- Toplevel.imperative (fn () =>
- ignore (create_command (OuterSyntax.prepare_command (Position.id id) text)))));
-
-val _ =
- OuterSyntax.internal_command "Isar.insert"
- (P.string -- P.string >> (fn (prev, id) =>
- Toplevel.imperative (fn () => insert_command prev id)));
-
-val _ =
- OuterSyntax.internal_command "Isar.remove"
- (P.string >> (fn id => Toplevel.imperative (fn () => remove_command id)));
-
end;
end;
--- a/src/Pure/System/session.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/System/session.ML Thu Oct 01 07:40:25 2009 +0200
@@ -21,10 +21,10 @@
(* session state *)
-val session = ref ([Context.PureN]: string list);
-val session_path = ref ([]: string list);
-val session_finished = ref false;
-val remote_path = ref (NONE: Url.T option);
+val session = Unsynchronized.ref ([Context.PureN]: string list);
+val session_path = Unsynchronized.ref ([]: string list);
+val session_finished = Unsynchronized.ref false;
+val remote_path = Unsynchronized.ref (NONE: Url.T option);
(* access path *)
--- a/src/Pure/Thy/html.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/html.ML Thu Oct 01 07:40:25 2009 +0200
@@ -267,8 +267,8 @@
(* document *)
-val charset = ref "ISO-8859-1";
-fun with_charset s = setmp_noncritical charset s;
+val charset = Unsynchronized.ref "ISO-8859-1";
+fun with_charset s = setmp_noncritical charset s; (* FIXME *)
fun begin_document title =
let val cs = ! charset in
--- a/src/Pure/Thy/present.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/present.ML Thu Oct 01 07:40:25 2009 +0200
@@ -161,10 +161,11 @@
(* state *)
-val browser_info = ref empty_browser_info;
-fun change_browser_info f = CRITICAL (fn () => change browser_info (map_browser_info f));
+val browser_info = Unsynchronized.ref empty_browser_info;
+fun change_browser_info f =
+ CRITICAL (fn () => Unsynchronized.change browser_info (map_browser_info f));
-val suppress_tex_source = ref false;
+val suppress_tex_source = Unsynchronized.ref false;
fun no_document f x = setmp_noncritical suppress_tex_source true f x;
fun init_theory_info name info =
@@ -229,7 +230,7 @@
(* state *)
-val session_info = ref (NONE: session_info option);
+val session_info = Unsynchronized.ref (NONE: session_info option);
fun with_session x f = (case ! session_info of NONE => x | SOME info => f info);
fun with_context f = f (Context.theory_name (ML_Context.the_global_context ()));
@@ -534,5 +535,5 @@
end;
-structure BasicPresent: BASIC_PRESENT = Present;
-open BasicPresent;
+structure Basic_Present: BASIC_PRESENT = Present;
+open Basic_Present;
--- a/src/Pure/Thy/thm_deps.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thm_deps.ML Thu Oct 01 07:40:25 2009 +0200
@@ -40,7 +40,7 @@
path = "",
parents = parents};
in cons entry end;
- val deps = Proofterm.fold_body_thms add_dep (map Thm.proof_body_of thms) [];
+ val deps = Proofterm.fold_body_thms (add_dep o #2) (map Thm.proof_body_of thms) [];
in Present.display_graph (sort_wrt #ID deps) end;
@@ -56,7 +56,7 @@
|> sort_distinct (string_ord o pairself #1);
val tab = Proofterm.fold_body_thms
- (fn (name, prop, _) => name <> "" ? Symtab.insert_list (op =) (name, prop))
+ (fn (_, (name, prop, _)) => name <> "" ? Symtab.insert_list (op =) (name, prop))
(map (Proofterm.strip_thm o Thm.proof_body_of o snd) thms) Symtab.empty;
fun is_unused (name, th) =
not (member (op aconv) (Symtab.lookup_list tab name) (Thm.prop_of th));
--- a/src/Pure/Thy/thy_header.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thy_header.ML Thu Oct 01 07:40:25 2009 +0200
@@ -11,7 +11,7 @@
val read: Position.T -> (string, 'a) Source.source -> string * string list * (string * bool) list
end;
-structure ThyHeader: THY_HEADER =
+structure Thy_Header: THY_HEADER =
struct
structure T = OuterLex;
--- a/src/Pure/Thy/thy_header.scala Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thy_header.scala Thu Oct 01 07:40:25 2009 +0200
@@ -6,8 +6,9 @@
package isabelle
-object ThyHeader {
+object Thy_Header
+{
val HEADER = "header"
val THEORY = "theory"
val IMPORTS = "imports"
--- a/src/Pure/Thy/thy_info.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thy_info.ML Thu Oct 01 07:40:25 2009 +0200
@@ -50,9 +50,9 @@
val str_of_action = fn Update => "Update" | Outdate => "Outdate" | Remove => "Remove";
local
- val hooks = ref ([]: (action -> string -> unit) list);
+ val hooks = Unsynchronized.ref ([]: (action -> string -> unit) list);
in
- fun add_hook f = CRITICAL (fn () => change hooks (cons f));
+ fun add_hook f = CRITICAL (fn () => Unsynchronized.change hooks (cons f));
fun perform action name = List.app (fn f => (try (fn () => f action name) (); ())) (! hooks);
end;
@@ -111,10 +111,10 @@
type thy = deps option * theory option;
local
- val database = ref (Graph.empty: thy Graph.T);
+ val database = Unsynchronized.ref (Graph.empty: thy Graph.T);
in
fun get_thys () = ! database;
- fun change_thys f = CRITICAL (fn () => Library.change database f);
+ fun change_thys f = CRITICAL (fn () => Unsynchronized.change database f);
end;
--- a/src/Pure/Thy/thy_load.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thy_load.ML Thu Oct 01 07:40:25 2009 +0200
@@ -37,14 +37,16 @@
(* maintain load path *)
-local val load_path = ref [Path.current] in
+local val load_path = Unsynchronized.ref [Path.current] in
fun show_path () = map Path.implode (! load_path);
-fun del_path s = CRITICAL (fn () => change load_path (remove (op =) (Path.explode s)));
-fun add_path s = CRITICAL (fn () => (del_path s; change load_path (cons (Path.explode s))));
-fun path_add s =
- CRITICAL (fn () => (del_path s; change load_path (fn path => path @ [Path.explode s])));
+fun del_path s = CRITICAL (fn () =>
+ Unsynchronized.change load_path (remove (op =) (Path.explode s)));
+fun add_path s = CRITICAL (fn () =>
+ (del_path s; Unsynchronized.change load_path (cons (Path.explode s))));
+fun path_add s = CRITICAL (fn () =>
+ (del_path s; Unsynchronized.change load_path (fn path => path @ [Path.explode s])));
fun reset_path () = load_path := [Path.current];
fun with_paths ss f x =
@@ -109,7 +111,7 @@
val master as (path, _) = check_thy dir name;
val text = explode (File.read path);
val (name', imports, uses) =
- ThyHeader.read (Path.position path) (Source.of_list_limited 8000 text);
+ Thy_Header.read (Path.position path) (Source.of_list_limited 8000 text);
val _ = check_name name name';
val uses = map (Path.explode o #1) uses;
in {master = master, text = text, imports = imports, uses = uses} end;
@@ -124,5 +126,5 @@
end;
-structure BasicThyLoad: BASIC_THY_LOAD = ThyLoad;
-open BasicThyLoad;
+structure Basic_Thy_Load: BASIC_THY_LOAD = ThyLoad;
+open Basic_Thy_Load;
--- a/src/Pure/Thy/thy_output.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Thy/thy_output.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,11 +6,11 @@
signature THY_OUTPUT =
sig
- val display: bool ref
- val quotes: bool ref
- val indent: int ref
- val source: bool ref
- val break: bool ref
+ val display: bool Unsynchronized.ref
+ val quotes: bool Unsynchronized.ref
+ val indent: int Unsynchronized.ref
+ val source: bool Unsynchronized.ref
+ val break: bool Unsynchronized.ref
val add_commands: (string * (Args.src -> Toplevel.state -> string)) list -> unit
val add_options: (string * (string -> (unit -> string) -> unit -> string)) list -> unit
val defined_command: string -> bool
@@ -21,7 +21,7 @@
val antiquotation: string -> 'a context_parser ->
({state: Toplevel.state, source: Args.src, context: Proof.context} -> 'a -> string) -> unit
datatype markup = Markup | MarkupEnv | Verbatim
- val modes: string list ref
+ val modes: string list Unsynchronized.ref
val eval_antiquote: Scan.lexicon -> Toplevel.state -> Symbol_Pos.text * Position.T -> string
val present_thy: Scan.lexicon -> (string -> string list) -> (markup -> string -> bool) ->
(Toplevel.transition * Toplevel.state) list -> (OuterLex.token, 'a) Source.source -> Buffer.T
@@ -42,11 +42,11 @@
(** global options **)
-val display = ref false;
-val quotes = ref false;
-val indent = ref 0;
-val source = ref false;
-val break = ref false;
+val display = Unsynchronized.ref false;
+val quotes = Unsynchronized.ref false;
+val indent = Unsynchronized.ref 0;
+val source = Unsynchronized.ref false;
+val break = Unsynchronized.ref false;
@@ -55,10 +55,10 @@
local
val global_commands =
- ref (Symtab.empty: (Args.src -> Toplevel.state -> string) Symtab.table);
+ Unsynchronized.ref (Symtab.empty: (Args.src -> Toplevel.state -> string) Symtab.table);
val global_options =
- ref (Symtab.empty: (string -> (unit -> string) -> unit -> string) Symtab.table);
+ Unsynchronized.ref (Symtab.empty: (string -> (unit -> string) -> unit -> string) Symtab.table);
fun add_item kind (name, x) tab =
(if not (Symtab.defined tab name) then ()
@@ -67,8 +67,10 @@
in
-fun add_commands xs = CRITICAL (fn () => change global_commands (fold (add_item "command") xs));
-fun add_options xs = CRITICAL (fn () => change global_options (fold (add_item "option") xs));
+fun add_commands xs =
+ CRITICAL (fn () => Unsynchronized.change global_commands (fold (add_item "command") xs));
+fun add_options xs =
+ CRITICAL (fn () => Unsynchronized.change global_options (fold (add_item "option") xs));
fun defined_command name = Symtab.defined (! global_commands) name;
fun defined_option name = Symtab.defined (! global_options) name;
@@ -143,7 +145,7 @@
(* eval_antiquote *)
-val modes = ref ([]: string list);
+val modes = Unsynchronized.ref ([]: string list);
fun eval_antiquote lex state (txt, pos) =
let
--- a/src/Pure/Tools/find_theorems.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/Tools/find_theorems.ML Thu Oct 01 07:40:25 2009 +0200
@@ -9,8 +9,8 @@
datatype 'term criterion =
Name of string | Intro | IntroIff | Elim | Dest | Solves | Simp of 'term |
Pattern of 'term
- val tac_limit: int ref
- val limit: int ref
+ val tac_limit: int Unsynchronized.ref
+ val limit: int Unsynchronized.ref
val find_theorems: Proof.context -> thm option -> int option -> bool ->
(bool * string criterion) list -> int option * (Facts.ref * thm) list
val pretty_thm: Proof.context -> Facts.ref * thm -> Pretty.T
@@ -186,7 +186,7 @@
end
else NONE
-val tac_limit = ref 5;
+val tac_limit = Unsynchronized.ref 5;
fun filter_solves ctxt goal =
let
@@ -372,7 +372,7 @@
(Facts.dest_static [] (PureThy.facts_of (ProofContext.theory_of ctxt)) @
Facts.dest_static [] (ProofContext.facts_of ctxt));
-val limit = ref 40;
+val limit = Unsynchronized.ref 40;
fun find_theorems ctxt opt_goal opt_limit rem_dups raw_criteria =
let
--- a/src/Pure/Tools/isabelle_syntax.scala Tue Sep 29 22:15:54 2009 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,74 +0,0 @@
-/* Title: Pure/Tools/isabelle_syntax.scala
- Author: Makarius
-
-Isabelle outer syntax.
-*/
-
-package isabelle
-
-
-object IsabelleSyntax {
-
- /* string token */
-
- def append_string(str: String, result: StringBuilder)
- {
- result.append("\"")
- for (c <- str) {
- if (c < 32 || c == '\\' || c == '\"') {
- result.append("\\")
- if (c < 10) result.append('0')
- if (c < 100) result.append('0')
- result.append(c.asInstanceOf[Int].toString)
- }
- else result.append(c)
- }
- result.append("\"")
- }
-
- def encode_string(str: String) =
- {
- val result = new StringBuilder(str.length + 10)
- append_string(str, result)
- result.toString
- }
-
-
- /* list */
-
- def append_list[A](append_elem: (A, StringBuilder) => Unit, body: Iterable[A],
- result: StringBuilder)
- {
- result.append("(")
- val elems = body.elements
- if (elems.hasNext) append_elem(elems.next, result)
- while (elems.hasNext) {
- result.append(", ")
- append_elem(elems.next, result)
- }
- result.append(")")
- }
-
- def encode_list[A](append_elem: (A, StringBuilder) => Unit, elems: Iterable[A]) =
- {
- val result = new StringBuilder
- append_list(append_elem, elems, result)
- result.toString
- }
-
-
- /* properties */
-
- def append_properties(props: List[(String, String)], result: StringBuilder)
- {
- append_list((p: (String, String), res) =>
- { append_string(p._1, res); res.append(" = "); append_string(p._2, res) }, props, result)
- }
-
- def encode_properties(props: List[(String, String)]) =
- {
- val result = new StringBuilder
- append_properties(props, result)
- result.toString
- }
-}
--- a/src/Pure/axclass.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/axclass.ML Thu Oct 01 07:40:25 2009 +0200
@@ -419,7 +419,7 @@
if n = 0 then []
else
(eq RS Drule.equal_elim_rule1)
- |> BalancedTree.dest (fn th =>
+ |> Balanced_Tree.dest (fn th =>
(th RS Conjunction.conjunctionD1, th RS Conjunction.conjunctionD2)) n;
in (intro, dests) end;
--- a/src/Pure/codegen.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/codegen.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,10 +6,10 @@
signature CODEGEN =
sig
- val quiet_mode : bool ref
+ val quiet_mode : bool Unsynchronized.ref
val message : string -> unit
- val mode : string list ref
- val margin : int ref
+ val mode : string list Unsynchronized.ref
+ val margin : int Unsynchronized.ref
val string_of : Pretty.T -> string
val str : string -> Pretty.T
@@ -75,9 +75,9 @@
val mk_type: bool -> typ -> Pretty.T
val mk_term_of: codegr -> string -> bool -> typ -> Pretty.T
val mk_gen: codegr -> string -> bool -> string list -> string -> typ -> Pretty.T
- val test_fn: (int -> term list option) ref
+ val test_fn: (int -> term list option) Unsynchronized.ref
val test_term: Proof.context -> term -> int -> term list option
- val eval_result: (unit -> term) ref
+ val eval_result: (unit -> term) Unsynchronized.ref
val eval_term: theory -> term -> term
val evaluation_conv: cterm -> thm
val parse_mixfix: (string -> 'a) -> string -> 'a mixfix list
@@ -102,12 +102,12 @@
structure Codegen : CODEGEN =
struct
-val quiet_mode = ref true;
+val quiet_mode = Unsynchronized.ref true;
fun message s = if !quiet_mode then () else writeln s;
-val mode = ref ([] : string list);
+val mode = Unsynchronized.ref ([] : string list);
-val margin = ref 80;
+val margin = Unsynchronized.ref 80;
fun string_of p = (Pretty.string_of |>
PrintMode.setmp [] |>
@@ -878,7 +878,8 @@
[mk_gen gr module true xs a T, mk_type true T]) Ts) @
(if member (op =) xs s then [str a] else []))));
-val test_fn : (int -> term list option) ref = ref (fn _ => NONE);
+val test_fn : (int -> term list option) Unsynchronized.ref =
+ Unsynchronized.ref (fn _ => NONE);
fun test_term ctxt t =
let
@@ -912,7 +913,7 @@
(**** Evaluator for terms ****)
-val eval_result = ref (fn () => Bound 0);
+val eval_result = Unsynchronized.ref (fn () => Bound 0);
fun eval_term thy t =
let
--- a/src/Pure/conjunction.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/conjunction.ML Thu Oct 01 07:40:25 2009 +0200
@@ -38,7 +38,7 @@
fun mk_conjunction (A, B) = Thm.capply (Thm.capply conjunction A) B;
fun mk_conjunction_balanced [] = true_prop
- | mk_conjunction_balanced ts = BalancedTree.make mk_conjunction ts;
+ | mk_conjunction_balanced ts = Balanced_Tree.make mk_conjunction ts;
fun dest_conjunction ct =
(case Thm.term_of ct of
@@ -117,10 +117,10 @@
(* balanced conjuncts *)
fun intr_balanced [] = asm_rl
- | intr_balanced ths = BalancedTree.make (uncurry intr) ths;
+ | intr_balanced ths = Balanced_Tree.make (uncurry intr) ths;
fun elim_balanced 0 _ = []
- | elim_balanced n th = BalancedTree.dest elim n th;
+ | elim_balanced n th = Balanced_Tree.dest elim n th;
(* currying *)
--- a/src/Pure/context.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/context.ML Thu Oct 01 07:40:25 2009 +0200
@@ -107,7 +107,7 @@
extend: Object.T -> Object.T,
merge: Pretty.pp -> Object.T * Object.T -> Object.T};
-val kinds = ref (Datatab.empty: kind Datatab.table);
+val kinds = Unsynchronized.ref (Datatab.empty: kind Datatab.table);
fun invoke f k =
(case Datatab.lookup (! kinds) k of
@@ -125,7 +125,7 @@
let
val k = serial ();
val kind = {empty = empty, copy = copy, extend = extend, merge = merge};
- val _ = CRITICAL (fn () => change kinds (Datatab.update (k, kind)));
+ val _ = CRITICAL (fn () => Unsynchronized.change kinds (Datatab.update (k, kind)));
in k end;
val copy_data = Datatab.map' invoke_copy;
@@ -149,7 +149,7 @@
datatype theory =
Theory of
(*identity*)
- {self: theory ref option, (*dynamic self reference -- follows theory changes*)
+ {self: theory Unsynchronized.ref option, (*dynamic self reference -- follows theory changes*)
draft: bool, (*draft mode -- linear destructive changes*)
id: serial, (*identifier*)
ids: unit Inttab.table} * (*cumulative identifiers of non-drafts -- symbolic body content*)
@@ -186,14 +186,15 @@
fun eq_id (i: int, j) = i = j;
fun is_stale
- (Theory ({self = SOME (ref (Theory ({id = id', ...}, _, _, _))), id, ...}, _, _, _)) =
+ (Theory ({self =
+ SOME (Unsynchronized.ref (Theory ({id = id', ...}, _, _, _))), id, ...}, _, _, _)) =
not (eq_id (id, id'))
| is_stale (Theory ({self = NONE, ...}, _, _, _)) = true;
fun vitalize (thy as Theory ({self = SOME r, ...}, _, _, _)) = (r := thy; thy)
| vitalize (thy as Theory ({self = NONE, draft, id, ids}, data, ancestry, history)) =
let
- val r = ref thy;
+ val r = Unsynchronized.ref thy;
val thy' = Theory (make_identity (SOME r) draft id ids, data, ancestry, history);
in r := thy'; thy' end;
@@ -243,9 +244,9 @@
theory in external data structures -- a plain theory value would
become stale as the self reference moves on*)
-datatype theory_ref = TheoryRef of theory ref;
+datatype theory_ref = TheoryRef of theory Unsynchronized.ref;
-fun deref (TheoryRef (ref thy)) = thy;
+fun deref (TheoryRef (Unsynchronized.ref thy)) = thy;
fun check_thy thy = (*thread-safe version*)
let val thy_ref = TheoryRef (the_self thy) in
@@ -437,7 +438,7 @@
local
-val kinds = ref (Datatab.empty: (theory -> Object.T) Datatab.table);
+val kinds = Unsynchronized.ref (Datatab.empty: (theory -> Object.T) Datatab.table);
fun invoke_init k =
(case Datatab.lookup (! kinds) k of
@@ -470,7 +471,7 @@
fun declare init =
let
val k = serial ();
- val _ = CRITICAL (fn () => change kinds (Datatab.update (k, init)));
+ val _ = CRITICAL (fn () => Unsynchronized.change kinds (Datatab.update (k, init)));
in k end;
fun get k dest prf =
--- a/src/Pure/display.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/display.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,10 +7,10 @@
signature BASIC_DISPLAY =
sig
- val goals_limit: int ref
- val show_consts: bool ref
- val show_hyps: bool ref
- val show_tags: bool ref
+ val goals_limit: int Unsynchronized.ref
+ val show_consts: bool Unsynchronized.ref
+ val show_hyps: bool Unsynchronized.ref
+ val show_tags: bool Unsynchronized.ref
end;
signature DISPLAY =
@@ -27,12 +27,6 @@
val string_of_thm_without_context: thm -> string
val pretty_thms_aux: Proof.context -> bool -> thm list -> Pretty.T
val pretty_thms: Proof.context -> thm list -> Pretty.T
- val pretty_ctyp: ctyp -> Pretty.T
- val string_of_ctyp: ctyp -> string
- val print_ctyp: ctyp -> unit
- val pretty_cterm: cterm -> Pretty.T
- val string_of_cterm: cterm -> string
- val print_cterm: cterm -> unit
val print_syntax: theory -> unit
val pretty_full_theory: bool -> theory -> Pretty.T list
end;
@@ -45,8 +39,8 @@
val goals_limit = Goal_Display.goals_limit;
val show_consts = Goal_Display.show_consts;
-val show_hyps = ref false; (*false: print meta-hypotheses as dots*)
-val show_tags = ref false; (*false: suppress tags*)
+val show_hyps = Unsynchronized.ref false; (*false: print meta-hypotheses as dots*)
+val show_tags = Unsynchronized.ref false; (*false: suppress tags*)
@@ -121,17 +115,6 @@
fun pretty_thms ctxt = pretty_thms_aux ctxt true;
-(* other printing commands *)
-
-fun pretty_ctyp cT = Syntax.pretty_typ_global (Thm.theory_of_ctyp cT) (Thm.typ_of cT);
-fun string_of_ctyp cT = Syntax.string_of_typ_global (Thm.theory_of_ctyp cT) (Thm.typ_of cT);
-val print_ctyp = writeln o string_of_ctyp;
-
-fun pretty_cterm ct = Syntax.pretty_term_global (Thm.theory_of_cterm ct) (Thm.term_of ct);
-fun string_of_cterm ct = Syntax.string_of_term_global (Thm.theory_of_cterm ct) (Thm.term_of ct);
-val print_cterm = writeln o string_of_cterm;
-
-
(** print theory **)
--- a/src/Pure/envir.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/envir.ML Thu Oct 01 07:40:25 2009 +0200
@@ -282,12 +282,9 @@
let
val funerr = "fastype: expected function type";
fun fast Ts (f $ u) =
- (case fast Ts f of
+ (case Type.devar tyenv (fast Ts f) of
Type ("fun", [_, T]) => T
- | TVar v =>
- (case Type.lookup tyenv v of
- SOME (Type ("fun", [_, T])) => T
- | _ => raise TERM (funerr, [f $ u]))
+ | TVar v => raise TERM (funerr, [f $ u])
| _ => raise TERM (funerr, [f $ u]))
| fast Ts (Const (_, T)) = T
| fast Ts (Free (_, T)) = T
--- a/src/Pure/goal.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/goal.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
signature BASIC_GOAL =
sig
- val parallel_proofs: int ref
+ val parallel_proofs: int Unsynchronized.ref
val SELECT_GOAL: tactic -> int -> tactic
val CONJUNCTS: tactic -> int -> tactic
val PRECISE_CONJUNCTS: int -> tactic -> int -> tactic
@@ -102,7 +102,7 @@
(* future_enabled *)
-val parallel_proofs = ref 1;
+val parallel_proofs = Unsynchronized.ref 1;
fun future_enabled () =
Multithreading.enabled () andalso Future.is_worker () andalso ! parallel_proofs >= 1;
--- a/src/Pure/goal_display.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/goal_display.ML Thu Oct 01 07:40:25 2009 +0200
@@ -7,8 +7,8 @@
signature GOAL_DISPLAY =
sig
- val goals_limit: int ref
- val show_consts: bool ref
+ val goals_limit: int Unsynchronized.ref
+ val show_consts: bool Unsynchronized.ref
val pretty_flexpair: Proof.context -> term * term -> Pretty.T
val pretty_goals: Proof.context -> {total: bool, main: bool, maxgoals: int} ->
thm -> Pretty.T list
@@ -18,8 +18,8 @@
structure Goal_Display: GOAL_DISPLAY =
struct
-val goals_limit = ref 10; (*max number of goals to print*)
-val show_consts = ref false; (*true: show consts with types in proof state output*)
+val goals_limit = Unsynchronized.ref 10; (*max number of goals to print*)
+val show_consts = Unsynchronized.ref false; (*true: show consts with types in proof state output*)
fun pretty_flexpair ctxt (t, u) = Pretty.block
[Syntax.pretty_term ctxt t, Pretty.str " =?=", Pretty.brk 1, Syntax.pretty_term ctxt u];
--- a/src/Pure/library.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/library.ML Thu Oct 01 07:40:25 2009 +0200
@@ -57,13 +57,8 @@
val andf: ('a -> bool) * ('a -> bool) -> 'a -> bool
val exists: ('a -> bool) -> 'a list -> bool
val forall: ('a -> bool) -> 'a list -> bool
- val set: bool ref -> bool
- val reset: bool ref -> bool
- val toggle: bool ref -> bool
- val change: 'a ref -> ('a -> 'a) -> unit
- val change_result: 'a ref -> ('a -> 'b * 'a) -> 'b
- val setmp_noncritical: 'a ref -> 'a -> ('b -> 'c) -> 'b -> 'c
- val setmp: 'a ref -> 'a -> ('b -> 'c) -> 'b -> 'c
+ val setmp_noncritical: 'a Unsynchronized.ref -> 'a -> ('b -> 'c) -> 'b -> 'c
+ val setmp: 'a Unsynchronized.ref -> 'a -> ('b -> 'c) -> 'b -> 'c
val setmp_thread_data: 'a Universal.tag -> 'a -> 'a -> ('b -> 'c) -> 'b -> 'c
(*lists*)
@@ -123,8 +118,6 @@
val suffixes: 'a list -> 'a list list
(*integers*)
- val inc: int ref -> int
- val dec: int ref -> int
val upto: int * int -> int list
val downto: int * int -> int list
val radixpand: int * int -> int list
@@ -326,13 +319,6 @@
(* flags *)
-fun set flag = (flag := true; true);
-fun reset flag = (flag := false; false);
-fun toggle flag = (flag := not (! flag); ! flag);
-
-fun change r f = r := f (! r);
-fun change_result r f = let val (x, y) = f (! r) in r := y; x end;
-
(*temporarily set flag during execution*)
fun setmp_noncritical flag value f x =
uninterruptible (fn restore_attributes => fn () =>
@@ -643,10 +629,6 @@
(** integers **)
-fun inc i = (i := ! i + (1: int); ! i);
-fun dec i = (i := ! i - (1: int); ! i);
-
-
(* lists of integers *)
(*make the list [from, from + 1, ..., to]*)
@@ -1055,7 +1037,7 @@
local
val a = 16807.0;
val m = 2147483647.0;
- val random_seed = ref 1.0;
+ val random_seed = Unsynchronized.ref 1.0;
in
fun random () = CRITICAL (fn () =>
@@ -1121,17 +1103,18 @@
val char_vec = Vector.tabulate (62, gensym_char);
fun newid n = implode (map (fn i => Vector.sub (char_vec, i)) (radixpand (62, n)));
-val gensym_seed = ref (0: int);
+val gensym_seed = Unsynchronized.ref (0: int);
in
- fun gensym pre = pre ^ newid (NAMED_CRITICAL "gensym" (fn () => inc gensym_seed));
+ fun gensym pre =
+ pre ^ newid (NAMED_CRITICAL "gensym" (fn () => Unsynchronized.inc gensym_seed));
end;
(* stamps and serial numbers *)
-type stamp = unit ref;
-val stamp: unit -> stamp = ref;
+type stamp = unit Unsynchronized.ref;
+val stamp: unit -> stamp = Unsynchronized.ref;
type serial = int;
val serial = Multithreading.serial;
--- a/src/Pure/logic.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/logic.ML Thu Oct 01 07:40:25 2009 +0200
@@ -169,7 +169,7 @@
(*(A &&& B) &&& (C &&& D) -- balanced*)
fun mk_conjunction_balanced [] = true_prop
- | mk_conjunction_balanced ts = BalancedTree.make mk_conjunction ts;
+ | mk_conjunction_balanced ts = Balanced_Tree.make mk_conjunction ts;
(*A &&& B*)
@@ -184,7 +184,7 @@
(*(A &&& B) &&& (C &&& D) -- balanced*)
fun dest_conjunction_balanced 0 _ = []
- | dest_conjunction_balanced n t = BalancedTree.dest dest_conjunction n t;
+ | dest_conjunction_balanced n t = Balanced_Tree.dest dest_conjunction n t;
(*((A &&& B) &&& C) &&& D &&& E -- flat*)
fun dest_conjunctions t =
--- a/src/Pure/meta_simplifier.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/meta_simplifier.ML Thu Oct 01 07:40:25 2009 +0200
@@ -11,9 +11,9 @@
signature BASIC_META_SIMPLIFIER =
sig
- val debug_simp: bool ref
- val trace_simp: bool ref
- val trace_simp_depth_limit: int ref
+ val debug_simp: bool Unsynchronized.ref
+ val trace_simp: bool Unsynchronized.ref
+ val trace_simp_depth_limit: int Unsynchronized.ref
type rrule
val eq_rrule: rrule * rrule -> bool
type simpset
@@ -84,7 +84,7 @@
{rules: rrule Net.net,
prems: thm list,
bounds: int * ((string * typ) * string) list,
- depth: int * bool ref,
+ depth: int * bool Unsynchronized.ref,
context: Proof.context option} *
{congs: (string * thm) list * string list,
procs: proc Net.net,
@@ -112,7 +112,7 @@
val the_context: simpset -> Proof.context
val context: Proof.context -> simpset -> simpset
val theory_context: theory -> simpset -> simpset
- val debug_bounds: bool ref
+ val debug_bounds: bool Unsynchronized.ref
val set_reorient: (theory -> term list -> term -> term -> bool) -> simpset -> simpset
val set_solvers: solver list -> simpset -> simpset
val rewrite_cterm: bool * bool * bool -> (simpset -> thm -> thm option) -> simpset -> conv
@@ -190,7 +190,7 @@
{rules: rrule Net.net,
prems: thm list,
bounds: int * ((string * typ) * string) list,
- depth: int * bool ref,
+ depth: int * bool Unsynchronized.ref,
context: Proof.context option} *
{congs: (string * thm) list * string list,
procs: proc Net.net,
@@ -256,7 +256,7 @@
val simp_depth_limit_value = Config.declare false "simp_depth_limit" (Config.Int 100);
val simp_depth_limit = Config.int simp_depth_limit_value;
-val trace_simp_depth_limit = ref 1;
+val trace_simp_depth_limit = Unsynchronized.ref 1;
fun trace_depth (Simpset ({depth = (depth, exceeded), ...}, _)) msg =
if depth > ! trace_simp_depth_limit then
@@ -266,7 +266,8 @@
val inc_simp_depth = map_simpset1 (fn (rules, prems, bounds, (depth, exceeded), context) =>
(rules, prems, bounds,
- (depth + 1, if depth = ! trace_simp_depth_limit then ref false else exceeded), context));
+ (depth + 1,
+ if depth = ! trace_simp_depth_limit then Unsynchronized.ref false else exceeded), context));
fun simp_depth (Simpset ({depth = (depth, _), ...}, _)) = depth;
@@ -275,8 +276,8 @@
exception SIMPLIFIER of string * thm;
-val debug_simp = ref false;
-val trace_simp = ref false;
+val debug_simp = Unsynchronized.ref false;
+val trace_simp = Unsynchronized.ref false;
local
@@ -746,7 +747,7 @@
(* empty *)
fun init_ss mk_rews termless subgoal_tac solvers =
- make_simpset ((Net.empty, [], (0, []), (0, ref false), NONE),
+ make_simpset ((Net.empty, [], (0, []), (0, Unsynchronized.ref false), NONE),
(([], []), Net.empty, mk_rews, termless, subgoal_tac, [], solvers));
fun clear_ss (ss as Simpset (_, {mk_rews, termless, subgoal_tac, solvers, ...})) =
@@ -1209,7 +1210,7 @@
prover: how to solve premises in conditional rewrites and congruences
*)
-val debug_bounds = ref false;
+val debug_bounds = Unsynchronized.ref false;
fun check_bounds ss ct =
if ! debug_bounds then
@@ -1337,5 +1338,5 @@
end;
-structure BasicMetaSimplifier: BASIC_META_SIMPLIFIER = MetaSimplifier;
-open BasicMetaSimplifier;
+structure Basic_Meta_Simplifier: BASIC_META_SIMPLIFIER = MetaSimplifier;
+open Basic_Meta_Simplifier;
--- a/src/Pure/old_goals.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/old_goals.ML Thu Oct 01 07:40:25 2009 +0200
@@ -19,7 +19,7 @@
type proof
val premises: unit -> thm list
val reset_goals: unit -> unit
- val result_error_fn: (thm -> string -> thm) ref
+ val result_error_fn: (thm -> string -> thm) Unsynchronized.ref
val print_sign_exn: theory -> exn -> 'a
val prove_goalw_cterm: thm list->cterm->(thm list->tactic list)->thm
val prove_goalw_cterm_nocheck: thm list->cterm->(thm list->tactic list)->thm
@@ -233,21 +233,21 @@
(*** References ***)
(*Current assumption list -- set by "goal".*)
-val curr_prems = ref([] : thm list);
+val curr_prems = Unsynchronized.ref([] : thm list);
(*Return assumption list -- useful if you didn't save "goal"'s result. *)
fun premises() = !curr_prems;
(*Current result maker -- set by "goal", used by "result". *)
fun init_mkresult _ = error "No goal has been supplied in subgoal module";
-val curr_mkresult = ref (init_mkresult: bool*thm->thm);
+val curr_mkresult = Unsynchronized.ref (init_mkresult: bool*thm->thm);
(*List of previous goal stacks, for the undo operation. Set by setstate.
A list of lists!*)
-val undo_list = ref([[(asm_rl, Seq.empty)]] : gstack list);
+val undo_list = Unsynchronized.ref([[(asm_rl, Seq.empty)]] : gstack list);
(* Stack of proof attempts *)
-val proofstack = ref([]: proof list);
+val proofstack = Unsynchronized.ref([]: proof list);
(*reset all refs*)
fun reset_goals () =
@@ -272,7 +272,7 @@
Goal_Display.pretty_goals_without_context (!goals_limit) state @
[Pretty.str msg, Pretty.str "Proof failed!"] |> Pretty.chunks |> Pretty.string_of |> error;
-val result_error_fn = ref result_error_default;
+val result_error_fn = Unsynchronized.ref result_error_default;
(*Common treatment of "goal" and "prove_goal":
@@ -362,10 +362,7 @@
(case Seq.pull (tac st0) of
SOME(st,_) => st
| _ => error ("prove_goal: tactic failed"))
- in mkresult (check, cond_timeit (!Output.timing) "" statef) end
- handle e => (print_sign_exn_unit (Thm.theory_of_cterm chorn) e;
- writeln ("The exception above was raised for\n" ^
- Display.string_of_cterm chorn); raise e);
+ in mkresult (check, cond_timeit (!Output.timing) "" statef) end;
(*Two variants: one checking the result, one not.
Neither prints runtime messages: they are for internal packages.*)
--- a/src/Pure/pattern.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/pattern.ML Thu Oct 01 07:40:25 2009 +0200
@@ -14,7 +14,7 @@
signature PATTERN =
sig
- val trace_unify_fail: bool ref
+ val trace_unify_fail: bool Unsynchronized.ref
val aeconv: term * term -> bool
val eta_long: typ list -> term -> term
val match: theory -> term * term -> Type.tyenv * Envir.tenv -> Type.tyenv * Envir.tenv
@@ -40,7 +40,7 @@
exception Unif;
exception Pattern;
-val trace_unify_fail = ref false;
+val trace_unify_fail = Unsynchronized.ref false;
fun string_of_term thy env binders t =
Syntax.string_of_term_global thy
--- a/src/Pure/proofterm.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/proofterm.ML Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,7 @@
signature BASIC_PROOFTERM =
sig
- val proofs: int ref
+ val proofs: int Unsynchronized.ref
datatype proof =
MinProof
@@ -40,7 +40,8 @@
val proof_of: proof_body -> proof
val join_proof: proof_body future -> proof
val fold_proof_atoms: bool -> (proof -> 'a -> 'a) -> proof list -> 'a -> 'a
- val fold_body_thms: (string * term * proof_body -> 'a -> 'a) -> proof_body list -> 'a -> 'a
+ val fold_body_thms: (serial * (string * term * proof_body) -> 'a -> 'a) ->
+ proof_body list -> 'a -> 'a
val join_bodies: proof_body list -> unit
val status_of: proof_body list -> {failed: bool, oracle: bool, unfinished: bool}
@@ -109,7 +110,7 @@
val axm_proof: string -> term -> proof
val oracle_proof: string -> term -> oracle * proof
val promise_proof: theory -> serial -> term -> proof
- val fulfill_proof: theory -> (serial * proof_body) list -> proof_body -> proof_body
+ val fulfill_proof: theory -> serial -> (serial * proof_body) list -> proof_body -> proof_body
val thm_proof: theory -> string -> term list -> term ->
(serial * proof_body future) list -> proof_body -> pthm * proof
val get_name: term list -> term -> proof -> string
@@ -181,7 +182,7 @@
let
val body' = Future.join body;
val (x', seen') = app body' (x, Inttab.update (i, ()) seen);
- in (f (name, prop, body') x', seen') end));
+ in (f (i, (name, prop, body')) x', seen') end));
in fn bodies => fn x => #1 (fold app bodies (x, Inttab.empty)) end;
fun join_bodies bodies = fold_body_thms (fn _ => fn () => ()) bodies ();
@@ -884,7 +885,7 @@
(***** axioms and theorems *****)
-val proofs = ref 2;
+val proofs = Unsynchronized.ref 2;
fun vars_of t = map Var (rev (Term.add_vars t []));
fun frees_of t = map Free (rev (Term.add_frees t []));
@@ -1278,12 +1279,16 @@
| _ => false));
in Promise (i, prop, map TVar (Term.add_tvars prop [])) end;
-fun fulfill_proof _ [] body0 = body0
- | fulfill_proof thy ps body0 =
+fun fulfill_proof _ _ [] body0 = body0
+ | fulfill_proof thy id ps body0 =
let
val PBody {oracles = oracles0, thms = thms0, proof = proof0} = body0;
- val oracles = fold (fn (_, PBody {oracles, ...}) => merge_oracles oracles) ps oracles0;
- val thms = fold (fn (_, PBody {thms, ...}) => merge_thms thms) ps thms0;
+ val bodies = map snd ps;
+ val _ = fold_body_thms (fn (i, (name, _, _)) => fn () =>
+ if i = id then error ("Cyclic reference to theorem " ^ quote name)
+ else ()) bodies ();
+ val oracles = fold (fn PBody {oracles, ...} => merge_oracles oracles) bodies oracles0;
+ val thms = fold (fn PBody {thms, ...} => merge_thms thms) bodies thms0;
val proofs = fold (fn (i, PBody {proof, ...}) => Inttab.update (i, proof)) ps Inttab.empty;
fun fill (Promise (i, prop, Ts)) =
@@ -1295,10 +1300,10 @@
val proof = rewrite_prf fst (rules, K fill :: procs) proof0;
in PBody {oracles = oracles, thms = thms, proof = proof} end;
-fun fulfill_proof_future _ [] body = Future.value body
- | fulfill_proof_future thy promises body =
+fun fulfill_proof_future _ _ [] body = Future.value body
+ | fulfill_proof_future thy id promises body =
Future.fork_deps (map snd promises) (fn () =>
- fulfill_proof thy (map (apsnd Future.join) promises) body);
+ fulfill_proof thy id (map (apsnd Future.join) promises) body);
(***** theorems *****)
@@ -1318,7 +1323,9 @@
else MinProof;
val body0 = PBody {oracles = oracles0, thms = thms0, proof = proof0};
- fun new_prf () = (serial (), name, prop, fulfill_proof_future thy promises body0);
+ fun new_prf () =
+ let val id = serial ()
+ in (id, name, prop, fulfill_proof_future thy id promises body0) end;
val (i, name, prop, body') =
(case strip_combt (fst (strip_combP prf)) of
(PThm (i, ((old_name, prop', NONE), body')), args') =>
--- a/src/Pure/search.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/search.ML Thu Oct 01 07:40:25 2009 +0200
@@ -13,23 +13,23 @@
val THEN_MAYBE : tactic * tactic -> tactic
val THEN_MAYBE' : ('a -> tactic) * ('a -> tactic) -> ('a -> tactic)
- val trace_DEPTH_FIRST : bool ref
+ val trace_DEPTH_FIRST : bool Unsynchronized.ref
val DEPTH_FIRST : (thm -> bool) -> tactic -> tactic
val DEPTH_SOLVE : tactic -> tactic
val DEPTH_SOLVE_1 : tactic -> tactic
val ITER_DEEPEN : (thm->bool) -> (int->tactic) -> tactic
val THEN_ITER_DEEPEN : tactic -> (thm->bool) -> (int->tactic) -> tactic
- val iter_deepen_limit : int ref
+ val iter_deepen_limit : int Unsynchronized.ref
val has_fewer_prems : int -> thm -> bool
val IF_UNSOLVED : tactic -> tactic
val SOLVE : tactic -> tactic
val DETERM_UNTIL_SOLVED: tactic -> tactic
- val trace_BEST_FIRST : bool ref
+ val trace_BEST_FIRST : bool Unsynchronized.ref
val BEST_FIRST : (thm -> bool) * (thm -> int) -> tactic -> tactic
val THEN_BEST_FIRST : tactic -> (thm->bool) * (thm->int) -> tactic
-> tactic
- val trace_ASTAR : bool ref
+ val trace_ASTAR : bool Unsynchronized.ref
val ASTAR : (thm -> bool) * (int->thm->int) -> tactic -> tactic
val THEN_ASTAR : tactic -> (thm->bool) * (int->thm->int) -> tactic
-> tactic
@@ -50,7 +50,7 @@
(**** Depth-first search ****)
-val trace_DEPTH_FIRST = ref false;
+val trace_DEPTH_FIRST = Unsynchronized.ref false;
(*Searches until "satp" reports proof tree as satisfied.
Suppresses duplicate solutions to minimize search space.*)
@@ -130,7 +130,7 @@
(*No known example (on 1-5-2007) needs even thirty*)
-val iter_deepen_limit = ref 50;
+val iter_deepen_limit = Unsynchronized.ref 50;
(*Depth-first iterative deepening search for a state that satisfies satp
tactic tac0 sets up the initial goal queue, while tac1 searches it.
@@ -138,7 +138,7 @@
to suppress solutions arising from earlier searches, as the accumulated cost
(k) can be wrong.*)
fun THEN_ITER_DEEPEN tac0 satp tac1 = traced_tac (fn st =>
- let val countr = ref 0
+ let val countr = Unsynchronized.ref 0
and tf = tracify trace_DEPTH_FIRST (tac1 1)
and qs0 = tac0 st
(*bnd = depth bound; inc = estimate of increment required next*)
@@ -156,7 +156,7 @@
| depth (bnd,inc) ((k,np,rgd,q)::qs) =
if k>=bnd then depth (bnd,inc) qs
else
- case (countr := !countr+1;
+ case (Unsynchronized.inc countr;
if !trace_DEPTH_FIRST then
tracing (string_of_int np ^ implode (map (fn _ => "*") qs))
else ();
@@ -199,7 +199,7 @@
(*** Best-first search ***)
-val trace_BEST_FIRST = ref false;
+val trace_BEST_FIRST = Unsynchronized.ref false;
(*For creating output sequence*)
fun some_of_list [] = NONE
@@ -273,7 +273,7 @@
fun some_of_list [] = NONE
| some_of_list (x::l) = SOME (x, Seq.make (fn () => some_of_list l));
-val trace_ASTAR = ref false;
+val trace_ASTAR = Unsynchronized.ref false;
fun THEN_ASTAR tac0 (satp, costf) tac1 =
let val tf = tracify trace_ASTAR tac1;
--- a/src/Pure/simplifier.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/simplifier.ML Thu Oct 01 07:40:25 2009 +0200
@@ -32,7 +32,7 @@
include BASIC_SIMPLIFIER
val pretty_ss: Proof.context -> simpset -> Pretty.T
val clear_ss: simpset -> simpset
- val debug_bounds: bool ref
+ val debug_bounds: bool Unsynchronized.ref
val inherit_context: simpset -> simpset -> simpset
val the_context: simpset -> Proof.context
val context: Proof.context -> simpset -> simpset
@@ -424,5 +424,5 @@
end;
-structure BasicSimplifier: BASIC_SIMPLIFIER = Simplifier;
-open BasicSimplifier;
+structure Basic_Simplifier: BASIC_SIMPLIFIER = Simplifier;
+open Basic_Simplifier;
--- a/src/Pure/tactical.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/tactical.ML Thu Oct 01 07:40:25 2009 +0200
@@ -34,9 +34,9 @@
val RANGE: (int -> tactic) list -> int -> tactic
val print_tac: string -> tactic
val pause_tac: tactic
- val trace_REPEAT: bool ref
- val suppress_tracing: bool ref
- val tracify: bool ref -> tactic -> tactic
+ val trace_REPEAT: bool Unsynchronized.ref
+ val suppress_tracing: bool Unsynchronized.ref
+ val tracify: bool Unsynchronized.ref -> tactic -> tactic
val traced_tac: (thm -> (thm * thm Seq.seq) option) -> tactic
val DETERM_UNTIL: (thm -> bool) -> tactic -> tactic
val REPEAT_DETERM_N: int -> tactic -> tactic
@@ -204,16 +204,16 @@
and TRACE_QUIT;
(*Tracing flags*)
-val trace_REPEAT= ref false
-and suppress_tracing = ref false;
+val trace_REPEAT= Unsynchronized.ref false
+and suppress_tracing = Unsynchronized.ref false;
(*Handle all tracing commands for current state and tactic *)
fun exec_trace_command flag (tac, st) =
case TextIO.inputLine TextIO.stdIn of
SOME "\n" => tac st
| SOME "f\n" => Seq.empty
- | SOME "o\n" => (flag:=false; tac st)
- | SOME "s\n" => (suppress_tracing:=true; tac st)
+ | SOME "o\n" => (flag := false; tac st)
+ | SOME "s\n" => (suppress_tracing := true; tac st)
| SOME "x\n" => (tracing "Exiting now"; raise (TRACE_EXIT st))
| SOME "quit\n" => raise TRACE_QUIT
| _ => (tracing
--- a/src/Pure/term.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/term.ML Thu Oct 01 07:40:25 2009 +0200
@@ -112,7 +112,7 @@
val exists_type: (typ -> bool) -> term -> bool
val exists_subterm: (term -> bool) -> term -> bool
val exists_Const: (string * typ -> bool) -> term -> bool
- val show_question_marks: bool ref
+ val show_question_marks: bool Unsynchronized.ref
end;
signature TERM =
@@ -963,7 +963,7 @@
(* display variables *)
-val show_question_marks = ref true;
+val show_question_marks = Unsynchronized.ref true;
fun string_of_vname (x, i) =
let
--- a/src/Pure/term_subst.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/term_subst.ML Thu Oct 01 07:40:25 2009 +0200
@@ -157,28 +157,32 @@
in
fun instantiateT_maxidx instT ty i =
- let val maxidx = ref i
+ let val maxidx = Unsynchronized.ref i
in (instantiateT_same maxidx instT ty handle Same.SAME => ty, ! maxidx) end;
fun instantiate_maxidx insts tm i =
- let val maxidx = ref i
+ let val maxidx = Unsynchronized.ref i
in (instantiate_same maxidx insts tm handle Same.SAME => tm, ! maxidx) end;
fun instantiateT [] ty = ty
| instantiateT instT ty =
- (instantiateT_same (ref ~1) (no_indexes1 instT) ty handle Same.SAME => ty);
+ (instantiateT_same (Unsynchronized.ref ~1) (no_indexes1 instT) ty
+ handle Same.SAME => ty);
fun instantiate ([], []) tm = tm
| instantiate insts tm =
- (instantiate_same (ref ~1) (no_indexes2 insts) tm handle Same.SAME => tm);
+ (instantiate_same (Unsynchronized.ref ~1) (no_indexes2 insts) tm
+ handle Same.SAME => tm);
fun instantiateT_option [] _ = NONE
| instantiateT_option instT ty =
- (SOME (instantiateT_same (ref ~1) (no_indexes1 instT) ty) handle Same.SAME => NONE);
+ (SOME (instantiateT_same (Unsynchronized.ref ~1) (no_indexes1 instT) ty)
+ handle Same.SAME => NONE);
fun instantiate_option ([], []) _ = NONE
| instantiate_option insts tm =
- (SOME (instantiate_same (ref ~1) (no_indexes2 insts) tm) handle Same.SAME => NONE);
+ (SOME (instantiate_same (Unsynchronized.ref ~1) (no_indexes2 insts) tm)
+ handle Same.SAME => NONE);
end;
--- a/src/Pure/thm.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/thm.ML Thu Oct 01 07:40:25 2009 +0200
@@ -124,6 +124,13 @@
val hyps_of: thm -> term list
val no_prems: thm -> bool
val major_prem_of: thm -> term
+ val join_proofs: thm list -> unit
+ val proof_body_of: thm -> proof_body
+ val proof_of: thm -> proof
+ val status_of: thm -> {oracle: bool, unfinished: bool, failed: bool}
+ val future: thm future -> cterm -> thm
+ val get_name: thm -> string
+ val put_name: string -> thm -> thm
val axiom: theory -> string -> thm
val axioms_of: theory -> (string * thm) list
val get_tags: thm -> Properties.T
@@ -142,18 +149,11 @@
val bicompose: bool -> bool * thm * int -> int -> thm -> thm Seq.seq
val biresolution: bool -> (bool * thm) list -> int -> thm -> thm Seq.seq
val rename_boundvars: term -> term -> thm -> thm
- val join_proofs: thm list -> unit
- val proof_body_of: thm -> proof_body
- val proof_of: thm -> proof
- val status_of: thm -> {oracle: bool, unfinished: bool, failed: bool}
- val future: thm future -> cterm -> thm
- val get_name: thm -> string
- val put_name: string -> thm -> thm
val extern_oracles: theory -> xstring list
val add_oracle: binding * ('a -> cterm) -> theory -> (string * ('a -> thm)) * theory
end;
-structure Thm:> THM =
+structure Thm: THM =
struct
structure Pt = Proofterm;
@@ -163,11 +163,12 @@
(** certified types **)
-datatype ctyp = Ctyp of
+abstype ctyp = Ctyp of
{thy_ref: theory_ref,
T: typ,
maxidx: int,
- sorts: sort OrdList.T};
+ sorts: sort OrdList.T}
+with
fun rep_ctyp (Ctyp args) = args;
fun theory_of_ctyp (Ctyp {thy_ref, ...}) = Theory.deref thy_ref;
@@ -189,12 +190,13 @@
(** certified terms **)
(*certified terms with checked typ, maxidx, and sorts*)
-datatype cterm = Cterm of
+abstype cterm = Cterm of
{thy_ref: theory_ref,
t: term,
T: typ,
maxidx: int,
- sorts: sort OrdList.T};
+ sorts: sort OrdList.T}
+with
exception CTERM of string * cterm list;
@@ -337,7 +339,7 @@
(*** Derivations and Theorems ***)
-datatype thm = Thm of
+abstype thm = Thm of
deriv * (*derivation*)
{thy_ref: theory_ref, (*dynamic reference to theory*)
tags: Properties.T, (*additional annotations/comments*)
@@ -348,7 +350,8 @@
prop: term} (*conclusion*)
and deriv = Deriv of
{promises: (serial * thm future) OrdList.T,
- body: Pt.proof_body};
+ body: Pt.proof_body}
+with
type conv = cterm -> thm;
@@ -502,7 +505,7 @@
-(** derivations **)
+(** derivations and promised proofs **)
fun make_deriv promises oracles thms proof =
Deriv {promises = promises, body = PBody {oracles = oracles, thms = thms, proof = proof}};
@@ -533,6 +536,93 @@
fun deriv_rule0 prf = deriv_rule1 I (make_deriv [] [] [] prf);
+(* fulfilled proofs *)
+
+fun raw_body (Thm (Deriv {body, ...}, _)) = body;
+
+fun fulfill_body (Thm (Deriv {promises, body}, {thy_ref, ...})) =
+ Pt.fulfill_proof (Theory.deref thy_ref) ~1
+ (map #1 promises ~~ fulfill_bodies (map #2 promises)) body
+and fulfill_bodies futures = map fulfill_body (Exn.release_all (Future.join_results futures));
+
+val join_proofs = Pt.join_bodies o map fulfill_body;
+
+fun proof_body_of thm = (Pt.join_bodies [raw_body thm]; fulfill_body thm);
+val proof_of = Pt.proof_of o proof_body_of;
+
+
+(* derivation status *)
+
+fun status_of (Thm (Deriv {promises, body}, _)) =
+ let
+ val ps = map (Future.peek o snd) promises;
+ val bodies = body ::
+ map_filter (fn SOME (Exn.Result th) => SOME (raw_body th) | _ => NONE) ps;
+ val {oracle, unfinished, failed} = Pt.status_of bodies;
+ in
+ {oracle = oracle,
+ unfinished = unfinished orelse exists is_none ps,
+ failed = failed orelse exists (fn SOME (Exn.Exn _) => true | _ => false) ps}
+ end;
+
+
+(* future rule *)
+
+fun future_result i orig_thy orig_shyps orig_prop raw_thm =
+ let
+ val _ = Theory.check_thy orig_thy;
+ val thm = strip_shyps (transfer orig_thy raw_thm);
+ val _ = Theory.check_thy orig_thy;
+ fun err msg = raise THM ("future_result: " ^ msg, 0, [thm]);
+
+ val Thm (Deriv {promises, ...}, {shyps, hyps, tpairs, prop, ...}) = thm;
+ val _ = prop aconv orig_prop orelse err "bad prop";
+ val _ = null tpairs orelse err "bad tpairs";
+ val _ = null hyps orelse err "bad hyps";
+ val _ = Sorts.subset (shyps, orig_shyps) orelse err "bad shyps";
+ val _ = forall (fn (j, _) => i <> j) promises orelse err "bad dependencies";
+ val _ = fulfill_bodies (map #2 promises);
+ in thm end;
+
+fun future future_thm ct =
+ let
+ val Cterm {thy_ref = thy_ref, t = prop, T, maxidx, sorts} = ct;
+ val thy = Context.reject_draft (Theory.deref thy_ref);
+ val _ = T <> propT andalso raise CTERM ("future: prop expected", [ct]);
+
+ val i = serial ();
+ val future = future_thm |> Future.map (future_result i thy sorts prop);
+ in
+ Thm (make_deriv [(i, future)] [] [] (Pt.promise_proof thy i prop),
+ {thy_ref = thy_ref,
+ tags = [],
+ maxidx = maxidx,
+ shyps = sorts,
+ hyps = [],
+ tpairs = [],
+ prop = prop})
+ end;
+
+
+(* closed derivations with official name *)
+
+fun get_name thm =
+ Pt.get_name (hyps_of thm) (prop_of thm) (Pt.proof_of (raw_body thm));
+
+fun put_name name (thm as Thm (der, args)) =
+ let
+ val Deriv {promises, body} = der;
+ val {thy_ref, hyps, prop, tpairs, ...} = args;
+ val _ = null tpairs orelse raise THM ("put_name: unsolved flex-flex constraints", 0, [thm]);
+
+ val ps = map (apsnd (Future.map proof_body_of)) promises;
+ val thy = Theory.deref thy_ref;
+ val (pthm, proof) = Pt.thm_proof thy name hyps prop ps body;
+ val der' = make_deriv [] [] [pthm] proof;
+ val _ = Theory.check_thy thy;
+ in Thm (der', args) end;
+
+
(** Axioms **)
@@ -1607,96 +1697,6 @@
-(*** Future theorems -- proofs with promises ***)
-
-(* fulfilled proofs *)
-
-fun raw_body (Thm (Deriv {body, ...}, _)) = body;
-
-fun fulfill_body (Thm (Deriv {promises, body}, {thy_ref, ...})) =
- Pt.fulfill_proof (Theory.deref thy_ref)
- (map #1 promises ~~ fulfill_bodies (map #2 promises)) body
-and fulfill_bodies futures = map fulfill_body (Exn.release_all (Future.join_results futures));
-
-val join_proofs = Pt.join_bodies o map fulfill_body;
-
-fun proof_body_of thm = (Pt.join_bodies [raw_body thm]; fulfill_body thm);
-val proof_of = Pt.proof_of o proof_body_of;
-
-
-(* derivation status *)
-
-fun status_of (Thm (Deriv {promises, body}, _)) =
- let
- val ps = map (Future.peek o snd) promises;
- val bodies = body ::
- map_filter (fn SOME (Exn.Result th) => SOME (raw_body th) | _ => NONE) ps;
- val {oracle, unfinished, failed} = Pt.status_of bodies;
- in
- {oracle = oracle,
- unfinished = unfinished orelse exists is_none ps,
- failed = failed orelse exists (fn SOME (Exn.Exn _) => true | _ => false) ps}
- end;
-
-
-(* future rule *)
-
-fun future_result i orig_thy orig_shyps orig_prop raw_thm =
- let
- val _ = Theory.check_thy orig_thy;
- val thm = strip_shyps (transfer orig_thy raw_thm);
- val _ = Theory.check_thy orig_thy;
- fun err msg = raise THM ("future_result: " ^ msg, 0, [thm]);
-
- val Thm (Deriv {promises, ...}, {shyps, hyps, tpairs, prop, ...}) = thm;
- val _ = prop aconv orig_prop orelse err "bad prop";
- val _ = null tpairs orelse err "bad tpairs";
- val _ = null hyps orelse err "bad hyps";
- val _ = Sorts.subset (shyps, orig_shyps) orelse err "bad shyps";
- val _ = forall (fn (j, _) => i <> j) promises orelse err "bad dependencies";
- val _ = fulfill_bodies (map #2 promises);
- in thm end;
-
-fun future future_thm ct =
- let
- val Cterm {thy_ref = thy_ref, t = prop, T, maxidx, sorts} = ct;
- val thy = Context.reject_draft (Theory.deref thy_ref);
- val _ = T <> propT andalso raise CTERM ("future: prop expected", [ct]);
-
- val i = serial ();
- val future = future_thm |> Future.map (future_result i thy sorts prop);
- in
- Thm (make_deriv [(i, future)] [] [] (Pt.promise_proof thy i prop),
- {thy_ref = thy_ref,
- tags = [],
- maxidx = maxidx,
- shyps = sorts,
- hyps = [],
- tpairs = [],
- prop = prop})
- end;
-
-
-(* closed derivations with official name *)
-
-fun get_name thm =
- Pt.get_name (hyps_of thm) (prop_of thm) (Pt.proof_of (raw_body thm));
-
-fun put_name name (thm as Thm (der, args)) =
- let
- val Deriv {promises, body} = der;
- val {thy_ref, hyps, prop, tpairs, ...} = args;
- val _ = null tpairs orelse raise THM ("put_name: unsolved flex-flex constraints", 0, [thm]);
-
- val ps = map (apsnd (Future.map proof_body_of)) promises;
- val thy = Theory.deref thy_ref;
- val (pthm, proof) = Pt.thm_proof thy name hyps prop ps body;
- val der' = make_deriv [] [] [pthm] proof;
- val _ = Theory.check_thy thy;
- in Thm (der', args) end;
-
-
-
(*** Oracles ***)
(* oracle rule *)
@@ -1718,6 +1718,10 @@
end
end;
+end;
+end;
+end;
+
(* authentic derivation names *)
--- a/src/Pure/type.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/type.ML Thu Oct 01 07:40:25 2009 +0200
@@ -55,6 +55,7 @@
exception TYPE_MATCH
type tyenv = (sort * typ) Vartab.table
val lookup: tyenv -> indexname * sort -> typ option
+ val devar: tyenv -> typ -> typ
val typ_match: tsig -> typ * typ -> tyenv -> tyenv
val typ_instance: tsig -> typ * typ -> bool
val raw_match: typ * typ -> tyenv -> tyenv
@@ -416,8 +417,8 @@
(*order-sorted unification*)
fun unify (tsig as TSig {classes = (_, classes), ...}) TU (tyenv, maxidx) =
let
- val tyvar_count = ref maxidx;
- fun gen_tyvar S = TVar ((Name.aT, inc tyvar_count), S);
+ val tyvar_count = Unsynchronized.ref maxidx;
+ fun gen_tyvar S = TVar ((Name.aT, Unsynchronized.inc tyvar_count), S);
fun mg_domain a S = Sorts.mg_domain classes a S
handle Sorts.CLASS_ERROR _ => raise TUNIFY;
--- a/src/Pure/unify.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Pure/unify.ML Thu Oct 01 07:40:25 2009 +0200
@@ -106,7 +106,7 @@
the occurs check must ignore the types of variables. This avoids
that ?x::?'a is unified with f(?x::T), which may lead to a cyclic
substitution when ?'a is instantiated with T later. *)
-fun occurs_terms (seen: (indexname list) ref,
+fun occurs_terms (seen: (indexname list) Unsynchronized.ref,
env: Envir.env, v: indexname, ts: term list): bool =
let fun occurs [] = false
| occurs (t::ts) = occur t orelse occurs ts
@@ -160,7 +160,7 @@
Warning: finds a rigid occurrence of ?f in ?f(t).
Should NOT be called in this case: there is a flex-flex unifier
*)
-fun rigid_occurs_term (seen: (indexname list)ref, env, v: indexname, t) =
+fun rigid_occurs_term (seen: (indexname list) Unsynchronized.ref, env, v: indexname, t) =
let fun nonrigid t = if occurs_terms(seen,env,v,[t]) then Nonrigid
else NoOcc
fun occurs [] = NoOcc
@@ -230,7 +230,7 @@
If v occurs nonrigidly then must use full algorithm. *)
fun assignment thy (env, rbinder, t, u) =
let val vT as (v,T) = get_eta_var (rbinder, 0, t)
- in case rigid_occurs_term (ref [], env, v, u) of
+ in case rigid_occurs_term (Unsynchronized.ref [], env, v, u) of
NoOcc => let val env = unify_types thy (body_type env T,
fastype env (rbinder,u),env)
in Envir.update ((vT, Logic.rlist_abs (rbinder, u)), env) end
@@ -429,7 +429,7 @@
Attempts to update t with u, raising ASSIGN if impossible*)
fun ff_assign thy (env, rbinder, t, u) : Envir.env =
let val vT as (v,T) = get_eta_var(rbinder,0,t)
-in if occurs_terms (ref [], env, v, [u]) then raise ASSIGN
+in if occurs_terms (Unsynchronized.ref [], env, v, [u]) then raise ASSIGN
else let val env = unify_types thy (body_type env T,
fastype env (rbinder,u),
env)
--- a/src/Sequents/prover.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Sequents/prover.ML Thu Oct 01 07:40:25 2009 +0200
@@ -10,12 +10,11 @@
infix 4 add_safes add_unsafes;
structure Cla =
-
struct
datatype pack = Pack of thm list * thm list;
-val trace = ref false;
+val trace = Unsynchronized.ref false;
(*A theorem pack has the form (safe rules, unsafe rules)
An unsafe rule is incomplete or introduces variables in subgoals,
--- a/src/Tools/Code/code_ml.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Code/code_ml.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,7 +6,7 @@
signature CODE_ML =
sig
- val eval: string option -> string * (unit -> 'a) option ref
+ val eval: string option -> string * (unit -> 'a) option Unsynchronized.ref
-> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a
val target_Eval: string
val setup: theory -> theory
--- a/src/Tools/Code/code_preproc.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Code/code_preproc.ML Thu Oct 01 07:40:25 2009 +0200
@@ -23,7 +23,6 @@
val all: code_graph -> string list
val pretty: theory -> code_graph -> Pretty.T
val obtain: theory -> string list -> term list -> code_algebra * code_graph
- val resubst_triv_consts: theory -> term -> term
val eval_conv: theory
-> (code_algebra -> code_graph -> (string * sort) list -> term -> cterm -> thm) -> cterm -> thm
val eval: theory -> ((term -> term) -> 'a -> 'a)
@@ -73,10 +72,8 @@
if AList.defined (op =) xs key then AList.delete (op =) key xs
else error ("No such " ^ msg ^ ": " ^ quote key);
-fun map_data f thy =
- thy
- |> Code.purge_data
- |> (Code_Preproc_Data.map o map_thmproc) f;
+fun map_data f = Code.purge_data
+ #> (Code_Preproc_Data.map o map_thmproc) f;
val map_pre_post = map_data o apfst;
val map_pre = map_pre_post o apfst;
@@ -163,10 +160,7 @@
|> rhs_conv (Simplifier.rewrite post)
end;
-fun resubst_triv_consts thy = map_aterms (fn t as Const (c, ty) => Const (Code.resubst_alias thy c, ty)
- | t => t);
-
-fun postprocess_term thy = term_of_conv thy (postprocess_conv thy) #> resubst_triv_consts thy;
+fun postprocess_term thy = term_of_conv thy (postprocess_conv thy);
fun print_codeproc thy =
let
@@ -489,17 +483,6 @@
fun obtain thy cs ts = apsnd snd
(Wellsorted.change_yield thy (extend_arities_eqngr thy cs ts));
-fun prepare_sorts_typ prep_sort
- = map_type_tfree (fn (v, sort) => TFree (v, prep_sort sort));
-
-fun prepare_sorts prep_sort (Const (c, ty)) =
- Const (c, prepare_sorts_typ prep_sort ty)
- | prepare_sorts prep_sort (t1 $ t2) =
- prepare_sorts prep_sort t1 $ prepare_sorts prep_sort t2
- | prepare_sorts prep_sort (Abs (v, ty, t)) =
- Abs (v, prepare_sorts_typ prep_sort ty, prepare_sorts prep_sort t)
- | prepare_sorts _ (t as Bound _) = t;
-
fun gen_eval thy cterm_of conclude_evaluation evaluator proto_ct =
let
val pp = Syntax.pp_global thy;
@@ -512,12 +495,8 @@
val vs = Term.add_tfrees t' [];
val consts = fold_aterms
(fn Const (c, _) => insert (op =) c | _ => I) t' [];
-
- val add_triv_classes = curry (Sorts.inter_sort (Sign.classes_of thy))
- (Code.triv_classes thy);
- val t'' = prepare_sorts add_triv_classes t';
- val (algebra', eqngr') = obtain thy consts [t''];
- in conclude_evaluation (evaluator algebra' eqngr' vs t'' ct') thm end;
+ val (algebra', eqngr') = obtain thy consts [t'];
+ in conclude_evaluation (evaluator algebra' eqngr' vs t' ct') thm end;
fun simple_evaluator evaluator algebra eqngr vs t ct =
evaluator algebra eqngr vs t;
--- a/src/Tools/Code/code_target.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Code/code_target.ML Thu Oct 01 07:40:25 2009 +0200
@@ -38,7 +38,7 @@
val code_of: theory -> string -> string
-> string list -> (Code_Thingol.naming -> string list) -> string
val shell_command: string (*theory name*) -> string (*export_code expr*) -> unit
- val code_width: int ref
+ val code_width: int Unsynchronized.ref
val allow_abort: string -> theory -> theory
val add_syntax_class: string -> class -> string option -> theory -> theory
@@ -59,7 +59,7 @@
datatype destination = Compile | Export | File of Path.T | String of string list;
type serialization = destination -> (string * string option list) option;
-val code_width = ref 80; (*FIXME after Pretty module no longer depends on print mode*)
+val code_width = Unsynchronized.ref 80; (*FIXME after Pretty module no longer depends on print mode*)
fun code_setmp f = PrintMode.setmp [] (Pretty.setmp_margin (!code_width) f);
fun code_of_pretty p = code_setmp Pretty.string_of p ^ "\n";
fun code_writeln p = Pretty.setmp_margin (!code_width) Pretty.writeln p;
--- a/src/Tools/Code/code_thingol.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Code/code_thingol.ML Thu Oct 01 07:40:25 2009 +0200
@@ -429,7 +429,7 @@
fun desymbolize_all_vars thy = desymbolize_tvars thy #> map (desymbolize_vars thy);
-fun clean_thms thy = same_arity thy #> desymbolize_all_vars thy;
+fun clean_thms thy = map (Thm.transfer thy) #> same_arity thy #> desymbolize_all_vars thy;
(** statements, abstract programs **)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Code/etc/settings Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,2 @@
+
+ISABELLE_TOOLS="$ISABELLE_TOOLS:$COMPONENT/lib/Tools"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Code/lib/Tools/codegen Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,65 @@
+#!/usr/bin/env bash
+#
+# Author: Florian Haftmann, TUM
+#
+# DESCRIPTION: issue code generation from shell
+
+
+PRG="$(basename "$0")"
+
+function usage()
+{
+ echo
+ echo "Usage: isabelle $PRG [OPTIONS] IMAGE THY CMD"
+ echo
+ echo " Options are:"
+ echo " -q run in quick'n'dirty mode"
+ echo
+ echo " Issues code generation using image IMAGE,"
+ echo " theory THY,"
+ echo " with Isar command 'export_code CMD'"
+ echo
+ exit 1
+}
+
+## process command line
+
+QUICK_AND_DIRTY=0
+
+while getopts "q" OPT
+do
+ case "$OPT" in
+ q)
+ QUICK_AND_DIRTY=1
+ ;;
+ \?)
+ usage
+ ;;
+ esac
+done
+
+shift $(($OPTIND - 1))
+
+[ "$#" -ne 3 ] && usage
+
+IMAGE="$1"; shift
+THY="$1"; shift
+CMD="$1"
+
+
+## main
+
+CODE_CMD=$(echo $CMD | perl -pe 's/\\/\\\\/g; s/"/\\\"/g')
+
+if [ "$QUICK_AND_DIRTY" -eq 1 ]
+then
+ QND_CMD="set"
+else
+ QND_CMD="reset"
+fi
+
+CTXT_CMD="ML_Context.eval_in (SOME (ProofContext.init (theory \"HOL\"))) false Position.none \"Code_Target.shell_command thyname cmd\";"
+
+FULL_CMD="$QND_CMD quick_and_dirty; val thyname = \"$THY\"; val cmd = \"$CODE_CMD\"; $CTXT_CMD"
+
+"$ISABELLE" -q -e "$FULL_CMD" "$IMAGE" || exit 1
--- a/src/Tools/Compute_Oracle/am_compiler.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/am_compiler.ML Thu Oct 01 07:40:25 2009 +0200
@@ -18,7 +18,7 @@
open AbstractMachine;
-val compiled_rewriter = ref (NONE:(term -> term)Option.option)
+val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
@@ -81,7 +81,7 @@
fun load_rules sname name prog =
let
- val buffer = ref ""
+ val buffer = Unsynchronized.ref ""
fun write s = (buffer := (!buffer)^s)
fun writeln s = (write s; write "\n")
fun writelist [] = ()
@@ -112,7 +112,7 @@
"",
"fun do_reduction reduce p =",
" let",
- " val s = ref (Continue p)",
+ " val s = Unsynchronized.ref (Continue p)",
" val _ = while cont (!s) do (s := reduce (proj_C (!s)))",
" in",
" proj_S (!s)",
--- a/src/Tools/Compute_Oracle/am_ghc.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/am_ghc.ML Thu Oct 01 07:40:25 2009 +0200
@@ -144,7 +144,7 @@
fun haskell_prog name rules =
let
- val buffer = ref ""
+ val buffer = Unsynchronized.ref ""
fun write s = (buffer := (!buffer)^s)
fun writeln s = (write s; write "\n")
fun writelist [] = ()
@@ -200,7 +200,7 @@
(arity, !buffer)
end
-val guid_counter = ref 0
+val guid_counter = Unsynchronized.ref 0
fun get_guid () =
let
val c = !guid_counter
@@ -214,7 +214,7 @@
fun writeTextFile name s = File.write (Path.explode name) s
-val ghc = ref (case getenv "GHC_PATH" of "" => "ghc" | s => s)
+val ghc = Unsynchronized.ref (case getenv "GHC_PATH" of "" => "ghc" | s => s)
fun fileExists name = ((OS.FileSys.fileSize name; true) handle OS.SysErr _ => false)
--- a/src/Tools/Compute_Oracle/am_interpreter.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/am_interpreter.ML Thu Oct 01 07:40:25 2009 +0200
@@ -5,7 +5,7 @@
signature AM_BARRAS =
sig
include ABSTRACT_MACHINE
- val max_reductions : int option ref
+ val max_reductions : int option Unsynchronized.ref
end
structure AM_Interpreter : AM_BARRAS = struct
@@ -129,12 +129,12 @@
fun cont (Continue _) = true
| cont _ = false
-val max_reductions = ref (NONE : int option)
+val max_reductions = Unsynchronized.ref (NONE : int option)
fun do_reduction reduce p =
let
- val s = ref (Continue p)
- val counter = ref 0
+ val s = Unsynchronized.ref (Continue p)
+ val counter = Unsynchronized.ref 0
val _ = case !max_reductions of
NONE => while cont (!s) do (s := reduce (proj_C (!s)))
| SOME m => while cont (!s) andalso (!counter < m) do (s := reduce (proj_C (!s)); counter := (!counter) + 1)
--- a/src/Tools/Compute_Oracle/am_sml.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/am_sml.ML Thu Oct 01 07:40:25 2009 +0200
@@ -12,18 +12,18 @@
val save_result : (string * term) -> unit
val set_compiled_rewriter : (term -> term) -> unit
val list_nth : 'a list * int -> 'a
- val dump_output : (string option) ref
+ val dump_output : (string option) Unsynchronized.ref
end
structure AM_SML : AM_SML = struct
open AbstractMachine;
-val dump_output = ref (NONE: string option)
+val dump_output = Unsynchronized.ref (NONE: string option)
type program = string * string * (int Inttab.table) * (int Inttab.table) * (term Inttab.table) * (term -> term)
-val saved_result = ref (NONE:(string*term)option)
+val saved_result = Unsynchronized.ref (NONE:(string*term)option)
fun save_result r = (saved_result := SOME r)
fun clear_result () = (saved_result := NONE)
@@ -32,7 +32,7 @@
(*fun list_nth (l,n) = (writeln (makestring ("list_nth", (length l,n))); List.nth (l,n))*)
-val compiled_rewriter = ref (NONE:(term -> term)Option.option)
+val compiled_rewriter = Unsynchronized.ref (NONE:(term -> term)Option.option)
fun set_compiled_rewriter r = (compiled_rewriter := SOME r)
@@ -295,7 +295,7 @@
fun sml_prog name code rules =
let
- val buffer = ref ""
+ val buffer = Unsynchronized.ref ""
fun write s = (buffer := (!buffer)^s)
fun writeln s = (write s; write "\n")
fun writelist [] = ()
@@ -480,7 +480,7 @@
(arity, toplevel_arity, inlinetab, !buffer)
end
-val guid_counter = ref 0
+val guid_counter = Unsynchronized.ref 0
fun get_guid () =
let
val c = !guid_counter
--- a/src/Tools/Compute_Oracle/compute.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/compute.ML Thu Oct 01 07:40:25 2009 +0200
@@ -171,20 +171,21 @@
fun default_naming i = "v_" ^ Int.toString i
-datatype computer = Computer of (theory_ref * Encode.encoding * term list * unit Sorttab.table * prog * unit ref * naming)
- option ref
+datatype computer = Computer of
+ (theory_ref * Encode.encoding * term list * unit Sorttab.table * prog * unit Unsynchronized.ref * naming)
+ option Unsynchronized.ref
-fun theory_of (Computer (ref (SOME (rthy,_,_,_,_,_,_)))) = Theory.deref rthy
-fun hyps_of (Computer (ref (SOME (_,_,hyps,_,_,_,_)))) = hyps
-fun shyps_of (Computer (ref (SOME (_,_,_,shyptable,_,_,_)))) = Sorttab.keys (shyptable)
-fun shyptab_of (Computer (ref (SOME (_,_,_,shyptable,_,_,_)))) = shyptable
-fun stamp_of (Computer (ref (SOME (_,_,_,_,_,stamp,_)))) = stamp
-fun prog_of (Computer (ref (SOME (_,_,_,_,prog,_,_)))) = prog
-fun encoding_of (Computer (ref (SOME (_,encoding,_,_,_,_,_)))) = encoding
-fun set_encoding (Computer (r as ref (SOME (p1,encoding,p2,p3,p4,p5,p6)))) encoding' =
+fun theory_of (Computer (Unsynchronized.ref (SOME (rthy,_,_,_,_,_,_)))) = Theory.deref rthy
+fun hyps_of (Computer (Unsynchronized.ref (SOME (_,_,hyps,_,_,_,_)))) = hyps
+fun shyps_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = Sorttab.keys (shyptable)
+fun shyptab_of (Computer (Unsynchronized.ref (SOME (_,_,_,shyptable,_,_,_)))) = shyptable
+fun stamp_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,stamp,_)))) = stamp
+fun prog_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,prog,_,_)))) = prog
+fun encoding_of (Computer (Unsynchronized.ref (SOME (_,encoding,_,_,_,_,_)))) = encoding
+fun set_encoding (Computer (r as Unsynchronized.ref (SOME (p1,encoding,p2,p3,p4,p5,p6)))) encoding' =
(r := SOME (p1,encoding',p2,p3,p4,p5,p6))
-fun naming_of (Computer (ref (SOME (_,_,_,_,_,_,n)))) = n
-fun set_naming (Computer (r as ref (SOME (p1,p2,p3,p4,p5,p6,naming)))) naming'=
+fun naming_of (Computer (Unsynchronized.ref (SOME (_,_,_,_,_,_,n)))) = n
+fun set_naming (Computer (r as Unsynchronized.ref (SOME (p1,p2,p3,p4,p5,p6,naming)))) naming'=
(r := SOME (p1,p2,p3,p4,p5,p6,naming'))
fun ref_of (Computer r) = r
@@ -320,7 +321,8 @@
in (Theory.check_thy thy, encoding, Termtab.keys hyptable, shyptable, prog, stamp, default_naming) end
-fun make_with_cache machine thy cache_patterns raw_thms = Computer (ref (SOME (make_internal machine thy (ref ()) Encode.empty cache_patterns raw_thms)))
+fun make_with_cache machine thy cache_patterns raw_thms =
+ Computer (Unsynchronized.ref (SOME (make_internal machine thy (Unsynchronized.ref ()) Encode.empty cache_patterns raw_thms)))
fun make machine thy raw_thms = make_with_cache machine thy [] raw_thms
@@ -415,7 +417,7 @@
datatype prem = EqPrem of AbstractMachine.term * AbstractMachine.term * Term.typ * int
| Prem of AbstractMachine.term
-datatype theorem = Theorem of theory_ref * unit ref * (int * typ) Symtab.table * (AbstractMachine.term option) Inttab.table
+datatype theorem = Theorem of theory_ref * unit Unsynchronized.ref * (int * typ) Symtab.table * (AbstractMachine.term option) Inttab.table
* prem list * AbstractMachine.term * term list * sort list
--- a/src/Tools/Compute_Oracle/linker.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/linker.ML Thu Oct 01 07:40:25 2009 +0200
@@ -239,7 +239,9 @@
datatype theorem = MonoThm of thm | PolyThm of thm * Linker.instances * thm list
datatype pattern = MonoPattern of term | PolyPattern of term * Linker.instances * term list
-datatype pcomputer = PComputer of theory_ref * Compute.computer * theorem list ref * pattern list ref
+datatype pcomputer =
+ PComputer of theory_ref * Compute.computer * theorem list Unsynchronized.ref *
+ pattern list Unsynchronized.ref
(*fun collect_consts (Var x) = []
| collect_consts (Bound _) = []
@@ -324,7 +326,7 @@
fun add_monos thy monocs pats ths =
let
- val changed = ref false
+ val changed = Unsynchronized.ref false
fun add monocs (th as (MonoThm _)) = ([], th)
| add monocs (PolyThm (th, instances, instanceths)) =
let
@@ -386,9 +388,9 @@
fun remove_duplicates ths =
let
- val counter = ref 0
- val tab = ref (CThmtab.empty : unit CThmtab.table)
- val thstab = ref (Inttab.empty : thm Inttab.table)
+ val counter = Unsynchronized.ref 0
+ val tab = Unsynchronized.ref (CThmtab.empty : unit CThmtab.table)
+ val thstab = Unsynchronized.ref (Inttab.empty : thm Inttab.table)
fun update th =
let
val key = thm2cthm th
@@ -415,7 +417,7 @@
val (_, (pats, ths)) = add_monos thy monocs pats ths
val computer = create_computer machine thy pats ths
in
- PComputer (Theory.check_thy thy, computer, ref ths, ref pats)
+ PComputer (Theory.check_thy thy, computer, Unsynchronized.ref ths, Unsynchronized.ref pats)
end
fun make machine thy ths cs = make_with_cache machine thy [] ths cs
--- a/src/Tools/Compute_Oracle/report.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Compute_Oracle/report.ML Thu Oct 01 07:40:25 2009 +0200
@@ -3,7 +3,7 @@
local
- val report_depth = ref 0
+ val report_depth = Unsynchronized.ref 0
fun space n = if n <= 0 then "" else (space (n-1))^" "
fun report_space () = space (!report_depth)
--- a/src/Tools/Metis/make-metis Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Metis/make-metis Thu Oct 01 07:40:25 2009 +0200
@@ -30,16 +30,19 @@
then
echo -e "$FILE (global)" >&2
"$THIS/scripts/mlpp" -c isabelle "src/$FILE" | \
- perl -p -e 's/\b([A-Za-z]+\.[A-Za-z]+)/Metis.\1/g;' -e 's/\bfrag\b/Metis.frag/;'
+ perl -p -e 's/\b([A-Za-z]+\.[A-Za-z]+)/Metis.\1/g;' -e 's/\bfrag\b/Metis.frag/;' | \
+ perl -p -e 's/\bref\b/Unsynchronized.ref/g;'
elif fgrep -q functor "src/$FILE"
then
"$THIS/scripts/mlpp" -c isabelle "src/$FILE" | \
- perl -p -e 's/ union / op union /g;' -e 's/ subset / op subset /g;'
+ perl -p -e 's/ union / op union /g;' -e 's/ subset / op subset /g;' | \
+ perl -p -e 's/\bref\b/Unsynchronized.ref/g;'
else
echo -e "$FILE (local)" >&2
echo "structure Metis = struct open Metis"
cat < "metis_env.ML"
- "$THIS/scripts/mlpp" -c isabelle "src/$FILE"
+ "$THIS/scripts/mlpp" -c isabelle "src/$FILE" | \
+ perl -p -e 's/\bref\b/Unsynchronized.ref/g;'
echo "end;"
fi
done
--- a/src/Tools/Metis/metis.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/Metis/metis.ML Thu Oct 01 07:40:25 2009 +0200
@@ -395,18 +395,18 @@
in
abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *)
- front: int ref,
- back: int ref,
+ front: int Unsynchronized.ref,
+ back: int Unsynchronized.ref,
size: int} (* fixed size of element array *)
with
- fun is_empty (QUEUE{front=ref ~1, back=ref ~1,...}) = true
+ fun is_empty (QUEUE{front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1,...}) = true
| is_empty _ = false
fun mk_queue n init_val =
if (n < 2)
then raise REQUESTED_QUEUE_SIZE_TOO_SMALL
- else QUEUE{elems=array(n, init_val), front=ref ~1, back=ref ~1, size=n}
+ else QUEUE{elems=array(n, init_val), front=Unsynchronized.ref ~1, back=Unsynchronized.ref ~1, size=n}
fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1)
@@ -459,9 +459,9 @@
(* Some global values *)
val INFINITY = 999999
-abstype indent_stack = Istack of break_info list ref
+abstype indent_stack = Istack of break_info list Unsynchronized.ref
with
- fun mk_indent_stack() = Istack (ref([]:break_info list))
+ fun mk_indent_stack() = Istack (Unsynchronized.ref([]:break_info list))
fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list))
fun top (Istack stk) =
case !stk
@@ -501,7 +501,7 @@
end
-type block_info = { Block_size : int ref,
+type block_info = { Block_size : int Unsynchronized.ref,
Block_offset : int,
How_to_indent : break_style }
@@ -512,10 +512,10 @@
*)
datatype pp_token
= S of {String : string, Length : int}
- | BB of {Pblocks : block_info list ref, (* Processed *)
- Ublocks : block_info list ref} (* Unprocessed *)
- | E of {Pend : int ref, Uend : int ref}
- | BR of {Distance_to_next_break : int ref,
+ | BB of {Pblocks : block_info list Unsynchronized.ref, (* Processed *)
+ Ublocks : block_info list Unsynchronized.ref} (* Unprocessed *)
+ | E of {Pend : int Unsynchronized.ref, Uend : int Unsynchronized.ref}
+ | BR of {Distance_to_next_break : int Unsynchronized.ref,
Number_of_blanks : int,
Break_offset : int}
@@ -532,12 +532,12 @@
the_token_buffer : pp_token array,
the_delim_stack : delim_stack,
the_indent_stack : indent_stack,
- ++ : int ref -> unit, (* increment circular buffer index *)
- space_left : int ref, (* remaining columns on page *)
- left_index : int ref, (* insertion index *)
- right_index : int ref, (* output index *)
- left_sum : int ref, (* size of strings and spaces inserted *)
- right_sum : int ref} (* size of strings and spaces printed *)
+ ++ : int Unsynchronized.ref -> unit, (* increment circular buffer index *)
+ space_left : int Unsynchronized.ref, (* remaining columns on page *)
+ left_index : int Unsynchronized.ref, (* insertion index *)
+ right_index : int Unsynchronized.ref, (* output index *)
+ left_sum : int Unsynchronized.ref, (* size of strings and spaces inserted *)
+ right_sum : int Unsynchronized.ref} (* size of strings and spaces printed *)
type ppstream = ppstream_
@@ -557,9 +557,9 @@
the_delim_stack = new_delim_stack buf_size,
the_indent_stack = mk_indent_stack (),
++ = fn i => i := ((!i + 1) mod buf_size),
- space_left = ref linewidth,
- left_index = ref 0, right_index = ref 0,
- left_sum = ref 0, right_sum = ref 0}
+ space_left = Unsynchronized.ref linewidth,
+ left_index = Unsynchronized.ref 0, right_index = Unsynchronized.ref 0,
+ left_sum = Unsynchronized.ref 0, right_sum = Unsynchronized.ref 0}
) : ppstream
end
@@ -595,25 +595,25 @@
be printable? Because of what goes on in add_string. See there for details.
*)
-fun print_BB (_,{Pblocks = ref [], Ublocks = ref []}) =
+fun print_BB (_,{Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =
raise Fail "PP-error: print_BB"
- | print_BB (PPS{the_indent_stack,linewidth,space_left=ref sp_left,...},
- {Pblocks as ref({How_to_indent=CONSISTENT,Block_size,
+ | print_BB (PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
+ {Pblocks as Unsynchronized.ref({How_to_indent=CONSISTENT,Block_size,
Block_offset}::rst),
- Ublocks=ref[]}) =
+ Ublocks=Unsynchronized.ref[]}) =
(push ((if (!Block_size > sp_left)
then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
Pblocks := rst)
- | print_BB(PPS{the_indent_stack,linewidth,space_left=ref sp_left,...},
- {Pblocks as ref({Block_size,Block_offset,...}::rst),Ublocks=ref[]}) =
+ | print_BB(PPS{the_indent_stack,linewidth,space_left=Unsynchronized.ref sp_left,...},
+ {Pblocks as Unsynchronized.ref({Block_size,Block_offset,...}::rst),Ublocks=Unsynchronized.ref[]}) =
(push ((if (!Block_size > sp_left)
then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
else FITS),
the_indent_stack);
Pblocks := rst)
- | print_BB (PPS{the_indent_stack, linewidth, space_left=ref sp_left,...},
+ | print_BB (PPS{the_indent_stack, linewidth, space_left=Unsynchronized.ref sp_left,...},
{Ublocks,...}) =
let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l =
(push ((if (!Block_size > sp_left)
@@ -635,7 +635,7 @@
(* Uend should always be 0 when print_E is called. *)
-fun print_E (_,{Pend = ref 0, Uend = ref 0}) =
+fun print_E (_,{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
raise Fail "PP-error: print_E"
| print_E (istack,{Pend, ...}) =
let fun pop_n_times 0 = ()
@@ -710,9 +710,9 @@
fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) =
(!left_index = !right_index) andalso
(case (the_token_buffer sub (!left_index))
- of (BB {Pblocks = ref [], Ublocks = ref []}) => true
+ of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) => true
| (BB _) => false
- | (E {Pend = ref 0, Uend = ref 0}) => true
+ | (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) => true
| (E _) => false
| _ => true)
@@ -732,13 +732,13 @@
fun token_size (S{Length, ...}) = Length
| token_size (BB b) =
(case b
- of {Pblocks = ref [], Ublocks = ref []} =>
+ of {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []} =>
raise Fail "PP-error: BB_size"
- | {Pblocks as ref(_::_),Ublocks=ref[]} => POS
+ | {Pblocks as Unsynchronized.ref(_::_),Ublocks=Unsynchronized.ref[]} => POS
| {Ublocks, ...} => last_size (!Ublocks))
- | token_size (E{Pend = ref 0, Uend = ref 0}) =
+ | token_size (E{Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =
raise Fail "PP-error: token_size.E"
- | token_size (E{Pend = ref 0, ...}) = NEG
+ | token_size (E{Pend = Unsynchronized.ref 0, ...}) = NEG
| token_size (E _) = POS
| token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break
fun loop (instr) =
@@ -761,12 +761,12 @@
mangled output.)
*)
(case (the_token_buffer sub (!left_index))
- of (BB {Pblocks = ref [], Ublocks = ref []}) =>
+ of (BB {Pblocks = Unsynchronized.ref [], Ublocks = Unsynchronized.ref []}) =>
(update(the_token_buffer,!left_index,
initial_token_value);
++left_index)
| (BB _) => ()
- | (E {Pend = ref 0, Uend = ref 0}) =>
+ | (E {Pend = Unsynchronized.ref 0, Uend = Unsynchronized.ref 0}) =>
(update(the_token_buffer,!left_index,
initial_token_value);
++left_index)
@@ -791,12 +791,12 @@
else BB_inc_right_index ppstrm;
case (the_token_buffer sub (!right_index))
of (BB {Ublocks, ...}) =>
- Ublocks := {Block_size = ref (~(!right_sum)),
+ Ublocks := {Block_size = Unsynchronized.ref (~(!right_sum)),
Block_offset = offset,
How_to_indent = style}::(!Ublocks)
| _ => (update(the_token_buffer, !right_index,
- BB{Pblocks = ref [],
- Ublocks = ref [{Block_size = ref (~(!right_sum)),
+ BB{Pblocks = Unsynchronized.ref [],
+ Ublocks = Unsynchronized.ref [{Block_size = Unsynchronized.ref (~(!right_sum)),
Block_offset = offset,
How_to_indent = style}]});
push_delim_stack (!right_index, the_delim_stack)))
@@ -808,12 +808,12 @@
= ppstrm
in
if (delim_stack_is_empty the_delim_stack)
- then print_token(ppstrm,(E{Pend = ref 1, Uend = ref 0}))
+ then print_token(ppstrm,(E{Pend = Unsynchronized.ref 1, Uend = Unsynchronized.ref 0}))
else (E_inc_right_index ppstrm;
case (the_token_buffer sub (!right_index))
of (E{Uend, ...}) => Uend := !Uend + 1
| _ => (update(the_token_buffer,!right_index,
- E{Uend = ref 1, Pend = ref 0});
+ E{Uend = Unsynchronized.ref 1, Pend = Unsynchronized.ref 0});
push_delim_stack (!right_index, the_delim_stack)))
end
@@ -823,7 +823,7 @@
if (delim_stack_is_empty the_delim_stack)
then ()
else case(the_token_buffer sub (top_delim_stack the_delim_stack))
- of (BB{Ublocks as ref ((b as {Block_size, ...})::rst),
+ of (BB{Ublocks as Unsynchronized.ref ((b as {Block_size, ...})::rst),
Pblocks}) =>
if (k>0)
then (Block_size := !right_sum + !Block_size;
@@ -862,7 +862,7 @@
left_sum := 1; right_sum := 1)
else ++right_index;
update(the_token_buffer, !right_index,
- BR{Distance_to_next_break = ref (~(!right_sum)),
+ BR{Distance_to_next_break = Unsynchronized.ref (~(!right_sum)),
Number_of_blanks = n,
Break_offset = break_offset});
check_delim_stack ppstrm;
@@ -899,10 +899,10 @@
| fnl (_::rst) = fnl rst
| fnl _ = raise Fail "PP-error: fnl: internal error"
- fun set(dstack,BB{Ublocks as ref[{Block_size,...}:block_info],...}) =
+ fun set(dstack,BB{Ublocks as Unsynchronized.ref[{Block_size,...}:block_info],...}) =
(pop_bottom_delim_stack dstack;
Block_size := INFINITY)
- | set (_,BB {Ublocks = ref(_::rst), ...}) = fnl rst
+ | set (_,BB {Ublocks = Unsynchronized.ref(_::rst), ...}) = fnl rst
| set (dstack, E{Pend,Uend}) =
(Pend := (!Pend) + (!Uend);
Uend := 0;
@@ -958,7 +958,7 @@
(TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n"))
fun pp_to_string linewidth ppfn ob =
- let val l = ref ([]:string list)
+ let val l = Unsynchronized.ref ([]:string list)
fun attach s = l := (s::(!l))
in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()}
(fn ppstrm => ppfn ppstrm ob);
@@ -995,7 +995,7 @@
(* Tracing. *)
(* ------------------------------------------------------------------------- *)
-val tracePrint : (string -> unit) ref
+val tracePrint : (string -> unit) Unsynchronized.ref
val trace : string -> unit
@@ -1228,7 +1228,7 @@
val newInts : int -> int list
-val withRef : 'r ref * 'r -> ('a -> 'b) -> 'a -> 'b
+val withRef : 'r Unsynchronized.ref * 'r -> ('a -> 'b) -> 'a -> 'b
val cloneArray : 'a Metis.Array.array -> 'a Metis.Array.array
@@ -1305,7 +1305,7 @@
(* Tracing *)
(* ------------------------------------------------------------------------- *)
-val tracePrint = ref print;
+val tracePrint = Unsynchronized.ref print;
fun trace message = !tracePrint message;
@@ -1629,7 +1629,7 @@
fun calcPrimes n = looking [] n (K true) 2
- val primesList = ref (calcPrimes 10);
+ val primesList = Unsynchronized.ref (calcPrimes 10);
in
fun primes n = CRITICAL (fn () =>
if length (!primesList) <= n then List.take (!primesList,n)
@@ -1828,7 +1828,7 @@
(* ------------------------------------------------------------------------- *)
local
- val generator = ref 0
+ val generator = Unsynchronized.ref 0
in
fun newInt () = CRITICAL (fn () =>
let
@@ -1986,12 +1986,12 @@
Value of 'a
| Thunk of unit -> 'a;
-datatype 'a lazy = Lazy of 'a thunk ref;
-
-fun delay f = Lazy (ref (Thunk f));
-
-fun force (Lazy (ref (Value v))) = v
- | force (Lazy (s as ref (Thunk f))) =
+datatype 'a lazy = Lazy of 'a thunk Unsynchronized.ref;
+
+fun delay f = Lazy (Unsynchronized.ref (Thunk f));
+
+fun force (Lazy (Unsynchronized.ref (Value v))) = v
+ | force (Lazy (s as Unsynchronized.ref (Thunk f))) =
let
val v = f ()
val () = s := Value v
@@ -4141,7 +4141,7 @@
fun cache cmp f =
let
- val cache = ref (Map.new cmp)
+ val cache = Unsynchronized.ref (Map.new cmp)
in
fn a =>
case Map.peek (!cache) a of
@@ -4620,7 +4620,7 @@
type 'a pp = ppstream -> 'a -> unit
-val lineLength : int ref
+val lineLength : int Unsynchronized.ref
val beginBlock : ppstream -> breakStyle -> int -> unit
@@ -4797,7 +4797,7 @@
type 'a pp = PP.ppstream -> 'a -> unit;
-val lineLength = ref 75;
+val lineLength = Unsynchronized.ref 75;
fun beginBlock pp Consistent = PP.begin_block pp PP.CONSISTENT
| beginBlock pp Inconsistent = PP.begin_block pp PP.INCONSISTENT;
@@ -5766,19 +5766,19 @@
(* Infix symbols *)
-val infixes : Metis.Parser.infixities ref
+val infixes : Metis.Parser.infixities Unsynchronized.ref
(* The negation symbol *)
-val negation : Metis.Name.name ref
+val negation : Metis.Name.name Unsynchronized.ref
(* Binder symbols *)
-val binders : Metis.Name.name list ref
+val binders : Metis.Name.name list Unsynchronized.ref
(* Bracket symbols *)
-val brackets : (Metis.Name.name * Metis.Name.name) list ref
+val brackets : (Metis.Name.name * Metis.Name.name) list Unsynchronized.ref
(* Pretty printing *)
@@ -6137,7 +6137,7 @@
(* Operators parsed and printed infix *)
-val infixes : Parser.infixities ref = ref
+val infixes : Parser.infixities Unsynchronized.ref = Unsynchronized.ref
[(* ML symbols *)
{token = " / ", precedence = 7, leftAssoc = true},
{token = " div ", precedence = 7, leftAssoc = true},
@@ -6174,15 +6174,15 @@
(* The negation symbol *)
-val negation : Name.name ref = ref "~";
+val negation : Name.name Unsynchronized.ref = Unsynchronized.ref "~";
(* Binder symbols *)
-val binders : Name.name list ref = ref ["\\","!","?","?!"];
+val binders : Name.name list Unsynchronized.ref = Unsynchronized.ref ["\\","!","?","?!"];
(* Bracket symbols *)
-val brackets : (Name.name * Name.name) list ref = ref [("[","]"),("{","}")];
+val brackets : (Name.name * Name.name) list Unsynchronized.ref = Unsynchronized.ref [("[","]"),("{","}")];
(* Pretty printing *)
@@ -11051,11 +11051,11 @@
val newSkolemFunction =
let
- val counter : int NameMap.map ref = ref (NameMap.new ())
+ val counter : int NameMap.map Unsynchronized.ref = Unsynchronized.ref (NameMap.new ())
in
fn n => CRITICAL (fn () =>
let
- val ref m = counter
+ val Unsynchronized.ref m = counter
val i = Option.getOpt (NameMap.peek m n, 0)
val () = counter := NameMap.insert m (n, i + 1)
in
@@ -11249,11 +11249,11 @@
val newDefinitionRelation =
let
- val counter : int ref = ref 0
+ val counter : int Unsynchronized.ref = Unsynchronized.ref 0
in
fn () => CRITICAL (fn () =>
let
- val ref i = counter
+ val Unsynchronized.ref i = counter
val () = counter := i + 1
in
"defCNF_" ^ Int.toString i
@@ -11820,8 +11820,8 @@
Model of
{size : int,
fixed : fixedModel,
- functions : (Term.functionName * int list, int) Map.map ref,
- relations : (Atom.relationName * int list, bool) Map.map ref};
+ functions : (Term.functionName * int list, int) Map.map Unsynchronized.ref,
+ relations : (Atom.relationName * int list, bool) Map.map Unsynchronized.ref};
local
fun cmp ((n1,l1),(n2,l2)) =
@@ -11834,8 +11834,8 @@
Model
{size = N,
fixed = fixed {size = N},
- functions = ref (Map.new cmp),
- relations = ref (Map.new cmp)};
+ functions = Unsynchronized.ref (Map.new cmp),
+ relations = Unsynchronized.ref (Map.new cmp)};
end;
fun size (Model {size = s, ...}) = s;
@@ -11905,7 +11905,7 @@
| (Term.Fn (f,tms), tms') => (f, tms @ tms')
val elts = map interpret tms
val f_elts = (f,elts)
- val ref funcs = functions
+ val Unsynchronized.ref funcs = functions
in
case Map.peek funcs f_elts of
SOME k => k
@@ -11932,7 +11932,7 @@
val elts = map (interpretTerm M V) tms
val r_elts = (r,elts)
- val ref rels = relations
+ val Unsynchronized.ref rels = relations
in
case Map.peek rels r_elts of
SOME b => b
@@ -14717,7 +14717,7 @@
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
-val showId : bool ref
+val showId : bool Unsynchronized.ref
val pp : clause Metis.Parser.pp
@@ -14747,10 +14747,10 @@
val newId =
let
- val r = ref 0
+ val r = Unsynchronized.ref 0
in
fn () => CRITICAL (fn () =>
- case r of ref n => let val () = r := n + 1 in n end)
+ case r of Unsynchronized.ref n => let val () = r := n + 1 in n end)
end;
(* ------------------------------------------------------------------------- *)
@@ -14777,7 +14777,7 @@
(* Pretty printing. *)
(* ------------------------------------------------------------------------- *)
-val showId = ref false;
+val showId = Unsynchronized.ref false;
local
val ppIdThm = Parser.ppPair Parser.ppInt Thm.pp;
@@ -16372,9 +16372,9 @@
(* Mapping TPTP functions and relations to different names. *)
(* ------------------------------------------------------------------------- *)
-val functionMapping : {name : string, arity : int, tptp : string} list ref
-
-val relationMapping : {name : string, arity : int, tptp : string} list ref
+val functionMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
+
+val relationMapping : {name : string, arity : int, tptp : string} list Unsynchronized.ref
(* ------------------------------------------------------------------------- *)
(* TPTP literals. *)
@@ -16491,7 +16491,7 @@
(* Mapping TPTP functions and relations to different names. *)
(* ------------------------------------------------------------------------- *)
-val functionMapping = ref
+val functionMapping = Unsynchronized.ref
[(* Mapping TPTP functions to infix symbols *)
{name = "*", arity = 2, tptp = "multiply"},
{name = "/", arity = 2, tptp = "divide"},
@@ -16504,7 +16504,7 @@
{name = ".", arity = 2, tptp = "apply"},
{name = "<=", arity = 0, tptp = "less_equal"}];
-val relationMapping = ref
+val relationMapping = Unsynchronized.ref
[(* Mapping TPTP relations to infix symbols *)
{name = "=", arity = 2, tptp = "="},
{name = "==", arity = 2, tptp = "equalish"},
--- a/src/Tools/auto_solve.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/auto_solve.ML Thu Oct 01 07:40:25 2009 +0200
@@ -11,9 +11,9 @@
signature AUTO_SOLVE =
sig
- val auto : bool ref
- val auto_time_limit : int ref
- val limit : int ref
+ val auto : bool Unsynchronized.ref
+ val auto_time_limit : int Unsynchronized.ref
+ val limit : int Unsynchronized.ref
end;
structure AutoSolve : AUTO_SOLVE =
@@ -21,9 +21,9 @@
(* preferences *)
-val auto = ref false;
-val auto_time_limit = ref 2500;
-val limit = ref 5;
+val auto = Unsynchronized.ref false;
+val auto_time_limit = Unsynchronized.ref 2500;
+val limit = Unsynchronized.ref 5;
val _ =
ProofGeneralPgip.add_preference Preferences.category_tracing
--- a/src/Tools/coherent.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/coherent.ML Thu Oct 01 07:40:25 2009 +0200
@@ -20,18 +20,18 @@
signature COHERENT =
sig
- val verbose: bool ref
- val show_facts: bool ref
+ val verbose: bool Unsynchronized.ref
+ val show_facts: bool Unsynchronized.ref
val coherent_tac: Proof.context -> thm list -> int -> tactic
val setup: theory -> theory
end;
-functor CoherentFun(Data: COHERENT_DATA) : COHERENT =
+functor Coherent(Data: COHERENT_DATA) : COHERENT =
struct
(** misc tools **)
-val verbose = ref false;
+val verbose = Unsynchronized.ref false;
fun message f = if !verbose then tracing (f ()) else ();
@@ -117,7 +117,7 @@
| NONE => is_valid_disj ctxt facts ds
end;
-val show_facts = ref false;
+val show_facts = Unsynchronized.ref false;
fun string_of_facts ctxt s facts = space_implode "\n"
(s :: map (Syntax.string_of_term ctxt)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/cong_tac.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,37 @@
+(* Title: Tools/cong_tac.ML
+ Author: Stefan Berghofer, TU Muenchen
+
+Congruence tactic based on explicit instantiation.
+*)
+
+signature CONG_TAC =
+sig
+ val cong_tac: thm -> int -> tactic
+end;
+
+structure Cong_Tac: CONG_TAC =
+struct
+
+fun cong_tac cong = CSUBGOAL (fn (cgoal, i) =>
+ let
+ val cert = Thm.cterm_of (Thm.theory_of_cterm cgoal);
+ val goal = Thm.term_of cgoal;
+ in
+ (case Logic.strip_assums_concl goal of
+ _ $ (_ $ (f $ x) $ (g $ y)) =>
+ let
+ val cong' = Thm.lift_rule cgoal cong;
+ val _ $ (_ $ (f' $ x') $ (g' $ y')) =
+ Logic.strip_assums_concl (Thm.prop_of cong');
+ val ps = Logic.strip_params (Thm.concl_of cong');
+ val insts = [(f', f), (g', g), (x', x), (y', y)]
+ |> map (fn (t, u) => (cert (Term.head_of t), cert (Term.list_abs (ps, u))));
+ in
+ fn st => compose_tac (false, Drule.cterm_instantiate insts cong', 2) i st
+ handle THM _ => no_tac st
+ end
+ | _ => no_tac)
+ end);
+
+end;
+
--- a/src/Tools/eqsubst.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/eqsubst.ML Thu Oct 01 07:40:25 2009 +0200
@@ -278,8 +278,8 @@
* (string * typ) list (* Type abs env *)
* term) (* outer term *);
-val trace_subst_err = (ref NONE : trace_subst_errT option ref);
-val trace_subst_search = ref false;
+val trace_subst_err = (Unsynchronized.ref NONE : trace_subst_errT option Unsynchronized.ref);
+val trace_subst_search = Unsynchronized.ref false;
exception trace_subst_exp of trace_subst_errT;
*)
--- a/src/Tools/induct.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/induct.ML Thu Oct 01 07:40:25 2009 +0200
@@ -288,21 +288,21 @@
(* prep_inst *)
-fun prep_inst thy align tune (tm, ts) =
+fun prep_inst ctxt align tune (tm, ts) =
let
- val cert = Thm.cterm_of thy;
+ val cert = Thm.cterm_of (ProofContext.theory_of ctxt);
fun prep_var (x, SOME t) =
let
val cx = cert x;
val xT = #T (Thm.rep_cterm cx);
val ct = cert (tune t);
- val tT = Thm.ctyp_of_term ct;
+ val tT = #T (Thm.rep_cterm ct);
in
- if Type.could_unify (Thm.typ_of tT, xT) then SOME (cx, ct)
+ if Type.could_unify (tT, xT) then SOME (cx, ct)
else error (Pretty.string_of (Pretty.block
[Pretty.str "Ill-typed instantiation:", Pretty.fbrk,
- Display.pretty_cterm ct, Pretty.str " ::", Pretty.brk 1,
- Display.pretty_ctyp (#T (Thm.crep_cterm ct))]))
+ Syntax.pretty_term ctxt (Thm.term_of ct), Pretty.str " ::", Pretty.brk 1,
+ Syntax.pretty_typ ctxt tT]))
end
| prep_var (_, NONE) = NONE;
val xs = vars_of tm;
@@ -342,12 +342,11 @@
fun cases_tac ctxt insts opt_rule facts =
let
val thy = ProofContext.theory_of ctxt;
- val cert = Thm.cterm_of thy;
fun inst_rule r =
if null insts then `RuleCases.get r
else (align_left "Rule has fewer premises than arguments given" (Thm.prems_of r) insts
- |> maps (prep_inst thy align_left I)
+ |> maps (prep_inst ctxt align_left I)
|> Drule.cterm_instantiate) r |> pair (RuleCases.get r);
val ruleq =
@@ -411,8 +410,8 @@
(* prepare rule *)
-fun rule_instance thy inst rule =
- Drule.cterm_instantiate (prep_inst thy align_left I (Thm.prop_of rule, inst)) rule;
+fun rule_instance ctxt inst rule =
+ Drule.cterm_instantiate (prep_inst ctxt align_left I (Thm.prop_of rule, inst)) rule;
fun internalize k th =
th |> Thm.permute_prems 0 k
@@ -589,7 +588,7 @@
(if null insts then `RuleCases.get r
else (align_left "Rule has fewer conclusions than arguments given"
(map Logic.strip_imp_concl (Logic.dest_conjunctions (Thm.concl_of r))) insts
- |> maps (prep_inst thy align_right (atomize_term thy))
+ |> maps (prep_inst ctxt align_right (atomize_term thy))
|> Drule.cterm_instantiate) r |> pair (RuleCases.get r))
|> (fn ((cases, consumes), th) => (((cases, concls), consumes), th));
@@ -619,7 +618,7 @@
THEN' inner_atomize_tac) j))
THEN' atomize_tac) i st |> Seq.maps (fn st' =>
guess_instance ctxt (internalize more_consumes rule) i st'
- |> Seq.map (rule_instance thy (burrow_options (Variable.polymorphic ctxt) taking))
+ |> Seq.map (rule_instance ctxt (burrow_options (Variable.polymorphic ctxt) taking))
|> Seq.maps (fn rule' =>
CASES (rule_cases rule' cases)
(Tactic.rtac rule' i THEN
@@ -657,7 +656,7 @@
fun inst_rule r =
if null inst then `RuleCases.get r
- else Drule.cterm_instantiate (prep_inst thy align_right I (main_prop_of r, inst)) r
+ else Drule.cterm_instantiate (prep_inst ctxt align_right I (main_prop_of r, inst)) r
|> pair (RuleCases.get r);
fun ruleq goal =
@@ -673,7 +672,7 @@
|> Seq.maps (RuleCases.consume [] facts)
|> Seq.maps (fn ((cases, (_, more_facts)), rule) =>
guess_instance ctxt rule i st
- |> Seq.map (rule_instance thy (burrow_options (Variable.polymorphic ctxt) taking))
+ |> Seq.map (rule_instance ctxt (burrow_options (Variable.polymorphic ctxt) taking))
|> Seq.maps (fn rule' =>
CASES (RuleCases.make_common false (thy, Thm.prop_of rule') cases)
(Method.insert_tac more_facts i THEN Tactic.rtac rule' i) st)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/more_conv.ML Thu Oct 01 07:40:25 2009 +0200
@@ -0,0 +1,61 @@
+(* Title: Tools/more_conv.ML
+ Author: Sascha Boehme
+
+Further conversions and conversionals.
+*)
+
+signature MORE_CONV =
+sig
+ val rewrs_conv: thm list -> conv
+
+ val sub_conv: (Proof.context -> conv) -> Proof.context -> conv
+ val bottom_conv: (Proof.context -> conv) -> Proof.context -> conv
+ val top_conv: (Proof.context -> conv) -> Proof.context -> conv
+ val top_sweep_conv: (Proof.context -> conv) -> Proof.context -> conv
+
+ val binder_conv: (Proof.context -> conv) -> Proof.context -> conv
+
+ val cache_conv: conv -> conv
+end
+
+
+
+structure More_Conv : MORE_CONV =
+struct
+
+
+fun rewrs_conv eqs = Conv.first_conv (map Conv.rewr_conv eqs)
+
+
+fun sub_conv conv ctxt =
+ Conv.comb_conv (conv ctxt) else_conv
+ Conv.abs_conv (fn (_, cx) => conv cx) ctxt else_conv
+ Conv.all_conv
+
+fun bottom_conv conv ctxt ct =
+ (sub_conv (bottom_conv conv) ctxt then_conv conv ctxt) ct
+
+fun top_conv conv ctxt ct =
+ (conv ctxt then_conv sub_conv (top_conv conv) ctxt) ct
+
+fun top_sweep_conv conv ctxt ct =
+ (conv ctxt else_conv sub_conv (top_sweep_conv conv) ctxt) ct
+
+
+fun binder_conv cv ctxt =
+ Conv.arg_conv (Conv.abs_conv (fn (_, cx) => cv cx) ctxt)
+
+
+fun cache_conv conv = (* FIXME not thread-safe *)
+ let
+ val tab = Unsynchronized.ref Termtab.empty
+ fun add_result t thm =
+ let val _ = Unsynchronized.change tab (Termtab.insert Thm.eq_thm (t, thm))
+ in thm end
+ fun cconv ct =
+ (case Termtab.lookup (!tab) (Thm.term_of ct) of
+ SOME thm => thm
+ | NONE => add_result (Thm.term_of ct) (conv ct))
+ in cconv end
+
+end
--- a/src/Tools/nbe.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/nbe.ML Thu Oct 01 07:40:25 2009 +0200
@@ -19,10 +19,11 @@
(*abstractions as closures*)
val same: Univ -> Univ -> bool
- val univs_ref: (unit -> Univ list -> Univ list) option ref
- val trace: bool ref
+ val univs_ref: (unit -> Univ list -> Univ list) option Unsynchronized.ref
+ val trace: bool Unsynchronized.ref
val setup: theory -> theory
+ val add_const_alias: thm -> theory -> theory
end;
structure Nbe: NBE =
@@ -30,11 +31,108 @@
(* generic non-sense *)
-val trace = ref false;
-fun tracing f x = if !trace then (Output.tracing (f x); x) else x;
+val trace = Unsynchronized.ref false;
+fun traced f x = if !trace then (tracing (f x); x) else x;
-(** the semantical universe **)
+(** certificates and oracle for "trivial type classes" **)
+
+structure Triv_Class_Data = TheoryDataFun
+(
+ type T = (class * thm) list;
+ val empty = [];
+ val copy = I;
+ val extend = I;
+ fun merge pp = AList.merge (op =) (K true);
+);
+
+fun add_const_alias thm thy =
+ let
+ val (ofclass, eqn) = case try Logic.dest_equals (Thm.prop_of thm)
+ of SOME ofclass_eq => ofclass_eq
+ | _ => error ("Bad certificate: " ^ Display.string_of_thm_global thy thm);
+ val (T, class) = case try Logic.dest_of_class ofclass
+ of SOME T_class => T_class
+ | _ => error ("Bad certificate: " ^ Display.string_of_thm_global thy thm);
+ val tvar = case try Term.dest_TVar T
+ of SOME (tvar as (_, sort)) => if null (filter (can (AxClass.get_info thy)) sort)
+ then tvar
+ else error ("Bad sort: " ^ Display.string_of_thm_global thy thm)
+ | _ => error ("Bad type: " ^ Display.string_of_thm_global thy thm);
+ val _ = if Term.add_tvars eqn [] = [tvar] then ()
+ else error ("Inconsistent type: " ^ Display.string_of_thm_global thy thm);
+ val lhs_rhs = case try Logic.dest_equals eqn
+ of SOME lhs_rhs => lhs_rhs
+ | _ => error ("Not an equation: " ^ Syntax.string_of_term_global thy eqn);
+ val c_c' = case try (pairself (Code.check_const thy)) lhs_rhs
+ of SOME c_c' => c_c'
+ | _ => error ("Not an equation with two constants: "
+ ^ Syntax.string_of_term_global thy eqn);
+ val _ = if the_list (AxClass.class_of_param thy (snd c_c')) = [class] then ()
+ else error ("Inconsistent class: " ^ Display.string_of_thm_global thy thm);
+ in Triv_Class_Data.map (AList.update (op =) (class, thm)) thy end;
+
+local
+
+val get_triv_classes = map fst o Triv_Class_Data.get;
+
+val (_, triv_of_class) = Context.>>> (Context.map_theory_result
+ (Thm.add_oracle (Binding.name "triv_of_class", fn (thy, (v, T), class) =>
+ Thm.cterm_of thy (Logic.mk_of_class (T, class)))));
+
+in
+
+fun lift_triv_classes_conv thy conv ct =
+ let
+ val algebra = Sign.classes_of thy;
+ val triv_classes = get_triv_classes thy;
+ val certT = Thm.ctyp_of thy;
+ fun critical_classes sort = filter_out (fn class => Sign.subsort thy (sort, [class])) triv_classes;
+ val vs = Term.add_tfrees (Thm.term_of ct) []
+ |> map_filter (fn (v, sort) => case critical_classes sort
+ of [] => NONE
+ | classes => SOME (v, ((sort, classes), Sorts.inter_sort algebra (triv_classes, sort))));
+ val of_classes = maps (fn (v, ((sort, classes), _)) => map (fn class =>
+ ((v, class), triv_of_class (thy, (v, TVar ((v, 0), sort)), class))) classes
+ @ map (fn class => ((v, class), Thm.of_class (certT (TVar ((v, 0), sort)), class)))
+ sort) vs;
+ fun strip_of_class thm =
+ let
+ val prem_props = (Logic.strip_imp_prems o Thm.prop_of) thm;
+ val prem_thms = map (the o AList.lookup (op =) of_classes
+ o apfst (fst o fst o dest_TVar) o Logic.dest_of_class) prem_props;
+ in Drule.implies_elim_list thm prem_thms end;
+ in ct
+ |> Drule.cterm_rule Thm.varifyT
+ |> Thm.instantiate_cterm (Thm.certify_inst thy (map (fn (v, ((sort, _), sort')) =>
+ (((v, 0), sort), TFree (v, sort'))) vs, []))
+ |> Drule.cterm_rule Thm.freezeT
+ |> conv
+ |> Thm.varifyT
+ |> fold (fn (v, (_, sort')) => Thm.unconstrainT (certT (TVar ((v, 0), sort')))) vs
+ |> Thm.certify_instantiate (map (fn (v, ((sort, _), _)) =>
+ (((v, 0), []), TVar ((v, 0), sort))) vs, [])
+ |> strip_of_class
+ |> Thm.freezeT
+ end;
+
+fun lift_triv_classes_rew thy rew t =
+ let
+ val algebra = Sign.classes_of thy;
+ val triv_classes = get_triv_classes thy;
+ val vs = Term.add_tfrees t [];
+ in t
+ |> (map_types o map_type_tfree)
+ (fn (v, sort) => TFree (v, Sorts.inter_sort algebra (sort, triv_classes)))
+ |> rew
+ |> (map_types o map_type_tfree)
+ (fn (v, _) => TFree (v, the (AList.lookup (op =) vs v)))
+ end;
+
+end;
+
+
+(** the semantic universe **)
(*
Functions are given by their semantical function value. To avoid
@@ -118,7 +216,7 @@
(* nbe specific syntax and sandbox communication *)
-val univs_ref = ref (NONE : (unit -> Univ list -> Univ list) option);
+val univs_ref = Unsynchronized.ref (NONE : (unit -> Univ list -> Univ list) option);
local
val prefix = "Nbe.";
@@ -275,7 +373,7 @@
val cs = map fst eqnss;
in
s
- |> tracing (fn s => "\n--- code to be evaluated:\n" ^ s)
+ |> traced (fn s => "\n--- code to be evaluated:\n" ^ s)
|> ML_Context.evaluate ctxt (!trace) univs_cookie
|> (fn f => f deps_vals)
|> (fn univs => cs ~~ univs)
@@ -450,14 +548,14 @@
val string_of_term = setmp show_types true (Syntax.string_of_term_global thy);
in
compile_eval thy naming program (vs, t) deps
- |> Code_Preproc.resubst_triv_consts thy
- |> tracing (fn t => "Normalized:\n" ^ string_of_term t)
+ |> traced (fn t => "Normalized:\n" ^ string_of_term t)
|> type_infer
- |> tracing (fn t => "Types inferred:\n" ^ string_of_term t)
+ |> traced (fn t => "Types inferred:\n" ^ string_of_term t)
|> check_tvars
- |> tracing (fn t => "---\n")
+ |> traced (fn t => "---\n")
end;
+
(* evaluation oracle *)
fun mk_equals thy lhs raw_rhs =
@@ -500,9 +598,9 @@
val norm_conv = no_frees_conv (fn ct =>
let
val thy = Thm.theory_of_cterm ct;
- in Code_Thingol.eval_conv thy (norm_oracle thy) ct end);
+ in lift_triv_classes_conv thy (Code_Thingol.eval_conv thy (norm_oracle thy)) ct end);
-fun norm thy = no_frees_rew (Code_Thingol.eval thy I (normalize thy));
+fun norm thy = lift_triv_classes_rew thy (no_frees_rew (Code_Thingol.eval thy I (normalize thy)));
(* evaluation command *)
--- a/src/Tools/quickcheck.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/quickcheck.ML Thu Oct 01 07:40:25 2009 +0200
@@ -6,8 +6,8 @@
signature QUICKCHECK =
sig
- val auto: bool ref
- val auto_time_limit: int ref
+ val auto: bool Unsynchronized.ref
+ val auto_time_limit: int Unsynchronized.ref
val test_term: Proof.context -> bool -> string option -> int -> int -> term ->
(string * term) list option
val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
@@ -19,8 +19,8 @@
(* preferences *)
-val auto = ref false;
-val auto_time_limit = ref 2500;
+val auto = Unsynchronized.ref false;
+val auto_time_limit = Unsynchronized.ref 2500;
val _ =
ProofGeneralPgip.add_preference Preferences.category_tracing
--- a/src/Tools/random_word.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/Tools/random_word.ML Thu Oct 01 07:40:25 2009 +0200
@@ -35,8 +35,8 @@
val a = 0w777138309;
fun step x = Word.andb (a * x + 0w1, max_word);
-local val rand = ref 0w1
-in fun next_word () = (change rand step; ! rand) end;
+local val rand = Unsynchronized.ref 0w1
+in fun next_word () = (Unsynchronized.change rand step; ! rand) end;
(*NB: higher bits are more random than lower ones*)
fun next_bool () = Word.andb (next_word (), top_bit) = 0w0;
--- a/src/ZF/Datatype_ZF.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/Datatype_ZF.thy Thu Oct 01 07:40:25 2009 +0200
@@ -14,9 +14,9 @@
(*Typechecking rules for most datatypes involving univ*)
structure Data_Arg =
struct
- val intrs =
+ val intrs =
[@{thm SigmaI}, @{thm InlI}, @{thm InrI},
- @{thm Pair_in_univ}, @{thm Inl_in_univ}, @{thm Inr_in_univ},
+ @{thm Pair_in_univ}, @{thm Inl_in_univ}, @{thm Inr_in_univ},
@{thm zero_in_univ}, @{thm A_into_univ}, @{thm nat_into_univ}, @{thm UnCI}];
@@ -25,7 +25,7 @@
end;
-structure Data_Package =
+structure Data_Package =
Add_datatype_def_Fun
(structure Fp=Lfp and Pr=Standard_Prod and CP=Standard_CP
and Su=Standard_Sum
@@ -37,16 +37,16 @@
(*Typechecking rules for most codatatypes involving quniv*)
structure CoData_Arg =
struct
- val intrs =
+ val intrs =
[@{thm QSigmaI}, @{thm QInlI}, @{thm QInrI},
- @{thm QPair_in_quniv}, @{thm QInl_in_quniv}, @{thm QInr_in_quniv},
+ @{thm QPair_in_quniv}, @{thm QInl_in_quniv}, @{thm QInr_in_quniv},
@{thm zero_in_quniv}, @{thm A_into_quniv}, @{thm nat_into_quniv}, @{thm UnCI}];
val elims = [make_elim @{thm QInlD}, make_elim @{thm QInrD}, (*for mutual recursion*)
@{thm QSigmaE}, @{thm qsumE}]; (*allows * and + in spec*)
end;
-structure CoData_Package =
+structure CoData_Package =
Add_datatype_def_Fun
(structure Fp=Gfp and Pr=Quine_Prod and CP=Quine_CP
and Su=Quine_Sum
@@ -59,19 +59,19 @@
(*Simproc for freeness reasoning: compare datatype constructors for equality*)
structure DataFree =
struct
- val trace = ref false;
+ val trace = Unsynchronized.ref false;
fun mk_new ([],[]) = Const("True",FOLogic.oT)
| mk_new (largs,rargs) =
- BalancedTree.make FOLogic.mk_conj
+ Balanced_Tree.make FOLogic.mk_conj
(map FOLogic.mk_eq (ListPair.zip (largs,rargs)));
val datatype_ss = @{simpset};
fun proc sg ss old =
- let val _ = if !trace then writeln ("data_free: OLD = " ^
- Display.string_of_cterm (cterm_of sg old))
- else ()
+ let val _ =
+ if !trace then writeln ("data_free: OLD = " ^ Syntax.string_of_term_global sg old)
+ else ()
val (lhs,rhs) = FOLogic.dest_eq old
val (lhead, largs) = strip_comb lhs
and (rhead, rargs) = strip_comb rhs
@@ -81,15 +81,15 @@
handle Option => raise Match;
val rcon_info = the (Symtab.lookup (ConstructorsData.get sg) rname)
handle Option => raise Match;
- val new =
- if #big_rec_name lcon_info = #big_rec_name rcon_info
+ val new =
+ if #big_rec_name lcon_info = #big_rec_name rcon_info
andalso not (null (#free_iffs lcon_info)) then
if lname = rname then mk_new (largs, rargs)
else Const("False",FOLogic.oT)
else raise Match
- val _ = if !trace then
- writeln ("NEW = " ^ Display.string_of_cterm (Thm.cterm_of sg new))
- else ();
+ val _ =
+ if !trace then writeln ("NEW = " ^ Syntax.string_of_term_global sg new)
+ else ();
val goal = Logic.mk_equals (old, new)
val thm = Goal.prove (Simplifier.the_context ss) [] [] goal
(fn _ => rtac iff_reflection 1 THEN
--- a/src/ZF/Tools/datatype_package.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/Tools/datatype_package.ML Thu Oct 01 07:40:25 2009 +0200
@@ -94,7 +94,7 @@
fun mk_tuple [] = @{const "0"}
| mk_tuple args = foldr1 (fn (t1, t2) => Pr.pair $ t1 $ t2) args;
- fun mk_inject n k u = BalancedTree.access
+ fun mk_inject n k u = Balanced_Tree.access
{left = fn t => Su.inl $ t, right = fn t => Su.inr $ t, init = u} n k;
val npart = length rec_names; (*number of mutually recursive parts*)
@@ -123,7 +123,7 @@
CP.ap_split (foldr1 CP.mk_prod (map (#2 o dest_Free) args))
@{typ i}
free
- in BalancedTree.make (fn (t1, t2) => Su.elim $ t1 $ t2) (map call_f case_list) end;
+ in Balanced_Tree.make (fn (t1, t2) => Su.elim $ t1 $ t2) (map call_f case_list) end;
(** Generating function variables for the case definition
Non-identifiers (e.g. infixes) get a name of the form f_op_nnn. **)
@@ -158,7 +158,7 @@
val case_tm = list_comb (case_const, case_args);
val case_def = PrimitiveDefs.mk_defpair
- (case_tm, BalancedTree.make (fn (t1, t2) => Su.elim $ t1 $ t2) (map call_case case_lists));
+ (case_tm, Balanced_Tree.make (fn (t1, t2) => Su.elim $ t1 $ t2) (map call_case case_lists));
(** Generating function variables for the recursor definition
--- a/src/ZF/Tools/inductive_package.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/Tools/inductive_package.ML Thu Oct 01 07:40:25 2009 +0200
@@ -113,7 +113,7 @@
val exfrees = OldTerm.term_frees intr \\ rec_params
val zeq = FOLogic.mk_eq (Free(z',iT), #1 (rule_concl intr))
in List.foldr FOLogic.mk_exists
- (BalancedTree.make FOLogic.mk_conj (zeq::prems)) exfrees
+ (Balanced_Tree.make FOLogic.mk_conj (zeq::prems)) exfrees
end;
(*The Part(A,h) terms -- compose injections to make h*)
@@ -122,7 +122,7 @@
(*Access to balanced disjoint sums via injections*)
val parts = map mk_Part
- (BalancedTree.accesses {left = fn t => Su.inl $ t, right = fn t => Su.inr $ t, init = Bound 0}
+ (Balanced_Tree.accesses {left = fn t => Su.inl $ t, right = fn t => Su.inr $ t, init = Bound 0}
(length rec_tms));
(*replace each set by the corresponding Part(A,h)*)
@@ -130,7 +130,7 @@
val fp_abs = absfree(X', iT,
mk_Collect(z', dom_sum,
- BalancedTree.make FOLogic.mk_disj part_intrs));
+ Balanced_Tree.make FOLogic.mk_disj part_intrs));
val fp_rhs = Fp.oper $ dom_sum $ fp_abs
@@ -238,7 +238,7 @@
DEPTH_SOLVE (swap_res_tac (@{thm SigmaI} :: @{thm subsetI} :: type_intrs) 1)];
(*combines disjI1 and disjI2 to get the corresponding nested disjunct...*)
- val mk_disj_rls = BalancedTree.accesses
+ val mk_disj_rls = Balanced_Tree.accesses
{left = fn rl => rl RS @{thm disjI1},
right = fn rl => rl RS @{thm disjI2},
init = @{thm asm_rl}};
@@ -398,10 +398,10 @@
(Ind_Syntax.mk_all_imp
(big_rec_tm,
Abs("z", Ind_Syntax.iT,
- BalancedTree.make FOLogic.mk_conj
+ Balanced_Tree.make FOLogic.mk_conj
(ListPair.map mk_rec_imp (rec_tms, preds)))))
and mutual_induct_concl =
- FOLogic.mk_Trueprop(BalancedTree.make FOLogic.mk_conj qconcls);
+ FOLogic.mk_Trueprop (Balanced_Tree.make FOLogic.mk_conj qconcls);
val dummy = if !Ind_Syntax.trace then
(writeln ("induct_concl = " ^
--- a/src/ZF/ZF.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/ZF.thy Thu Oct 01 07:40:25 2009 +0200
@@ -8,7 +8,7 @@
theory ZF imports FOL begin
-ML {* reset eta_contract *}
+ML {* Unsynchronized.reset eta_contract *}
global
--- a/src/ZF/ex/Limit.thy Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/ex/Limit.thy Thu Oct 01 07:40:25 2009 +0200
@@ -488,18 +488,24 @@
and Mfun: "M \<in> nat->nat->set(D)"
and cpoD: "cpo(D)"
shows "matrix(D,M)"
-apply (simp add: matrix_def, safe)
-apply (rule Mfun)
-apply (cut_tac y1 = m and n = n in yprem [THEN chain_rel], simp+)
-apply (simp add: chain_rel xprem)
-apply (rule cpo_trans [OF cpoD])
-apply (cut_tac y1 = m and n = n in yprem [THEN chain_rel], simp+)
-apply (simp_all add: chain_fun [THEN apply_type] xprem)
-done
-
-lemma lemma_rel_rel:
- "[|m \<in> nat; rel(D, (\<lambda>n \<in> nat. M`n`n)`m, y)|] ==> rel(D,M`m`m, y)"
-by simp
+proof -
+ {
+ fix n m assume "n : nat" "m : nat"
+ with chain_rel [OF yprem]
+ have "rel(D, M ` n ` m, M ` succ(n) ` m)" by simp
+ } note rel_succ = this
+ show "matrix(D,M)"
+ proof (simp add: matrix_def Mfun rel_succ, intro conjI ballI)
+ fix n m assume n: "n : nat" and m: "m : nat"
+ thus "rel(D, M ` n ` m, M ` n ` succ(m))"
+ by (simp add: chain_rel xprem)
+ next
+ fix n m assume n: "n : nat" and m: "m : nat"
+ thus "rel(D, M ` n ` m, M ` succ(n) ` succ(m))"
+ by (rule cpo_trans [OF cpoD rel_succ],
+ simp_all add: chain_fun [THEN apply_type] xprem)
+ qed
+qed
lemma lemma2:
"[|x \<in> nat; m \<in> nat; rel(D,(\<lambda>n \<in> nat. M`n`m1)`x,(\<lambda>n \<in> nat. M`n`m1)`m)|]
@@ -509,65 +515,72 @@
lemma isub_lemma:
"[|isub(D, \<lambda>n \<in> nat. M`n`n, y); matrix(D,M); cpo(D)|]
==> isub(D, \<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m), y)"
-apply (unfold isub_def, safe)
-apply (simp (no_asm_simp))
-apply (frule matrix_fun [THEN apply_type], assumption)
-apply (simp (no_asm_simp))
-apply (rule matrix_chain_left [THEN cpo_lub, THEN islub_least], assumption+)
-apply (unfold isub_def, safe)
-(*???VERY indirect proof: beta-redexes could be simplified now!*)
-apply (rename_tac k n)
-apply (case_tac "k le n")
-apply (rule cpo_trans, assumption)
-apply (rule lemma2)
-apply (rule_tac [4] lemma_rel_rel)
-prefer 5 apply blast
-apply (assumption | rule chain_rel_gen matrix_chain_right matrix_in isubD1)+
-txt{*opposite case*}
-apply (rule cpo_trans, assumption)
-apply (rule not_le_iff_lt [THEN iffD1, THEN leI, THEN chain_rel_gen])
-prefer 3 apply assumption
-apply (assumption | rule nat_into_Ord matrix_chain_left)+
-apply (rule lemma_rel_rel)
-apply (simp_all add: matrix_in)
-done
+proof (simp add: isub_def, safe)
+ fix n
+ assume DM: "matrix(D, M)" and D: "cpo(D)" and n: "n \<in> nat" and y: "y \<in> set(D)"
+ and rel: "\<forall>n\<in>nat. rel(D, M ` n ` n, y)"
+ have "rel(D, lub(D, M ` n), y)"
+ proof (rule matrix_chain_left [THEN cpo_lub, THEN islub_least], simp_all add: n D DM)
+ show "isub(D, M ` n, y)"
+ proof (unfold isub_def, intro conjI ballI y)
+ fix k assume k: "k \<in> nat"
+ show "rel(D, M ` n ` k, y)"
+ proof (cases "n le k")
+ case True
+ hence yy: "rel(D, M`n`k, M`k`k)"
+ by (blast intro: lemma2 n k y DM D chain_rel_gen matrix_chain_right)
+ show "?thesis"
+ by (rule cpo_trans [OF D yy],
+ simp_all add: k rel n y DM matrix_in)
+ next
+ case False
+ hence le: "k le n"
+ by (blast intro: not_le_iff_lt [THEN iffD1, THEN leI] nat_into_Ord n k)
+ show "?thesis"
+ by (rule cpo_trans [OF D chain_rel_gen [OF le]],
+ simp_all add: n y k rel DM D matrix_chain_left)
+ qed
+ qed
+ qed
+ moreover
+ have "M ` n \<in> nat \<rightarrow> set(D)" by (blast intro: DM n matrix_fun [THEN apply_type])
+ ultimately show "rel(D, lub(D, Lambda(nat, op `(M ` n))), y)" by simp
+qed
lemma matrix_chain_lub:
"[|matrix(D,M); cpo(D)|] ==> chain(D,\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m))"
-apply (simp add: chain_def, safe)
-apply (rule lam_type)
-apply (rule islub_in)
-apply (rule cpo_lub)
-prefer 2 apply assumption
-apply (rule chainI)
-apply (rule lam_type)
-apply (simp_all add: matrix_in)
-apply (rule matrix_rel_0_1, assumption+)
-apply (simp add: matrix_chain_left [THEN chain_fun, THEN eta])
-apply (rule dominate_islub)
-apply (rule_tac [3] cpo_lub)
-apply (rule_tac [2] cpo_lub)
-apply (simp add: dominate_def)
-apply (blast intro: matrix_rel_1_0)
-apply (simp_all add: matrix_chain_left nat_succI chain_fun)
-done
+proof (simp add: chain_def, intro conjI ballI)
+ assume "matrix(D, M)" "cpo(D)"
+ thus "(\<lambda>x\<in>nat. lub(D, Lambda(nat, op `(M ` x)))) \<in> nat \<rightarrow> set(D)"
+ by (force intro: islub_in cpo_lub chainI lam_type matrix_in matrix_rel_0_1)
+next
+ fix n
+ assume DD: "matrix(D, M)" "cpo(D)" "n \<in> nat"
+ hence "dominate(D, M ` n, M ` succ(n))"
+ by (force simp add: dominate_def intro: matrix_rel_1_0)
+ with DD show "rel(D, lub(D, Lambda(nat, op `(M ` n))),
+ lub(D, Lambda(nat, op `(M ` succ(n)))))"
+ by (simp add: matrix_chain_left [THEN chain_fun, THEN eta]
+ dominate_islub cpo_lub matrix_chain_left chain_fun)
+qed
lemma isub_eq:
- "[|matrix(D,M); cpo(D)|]
- ==> isub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m)),y) <->
- isub(D,(\<lambda>n \<in> nat. M`n`n),y)"
-apply (rule iffI)
-apply (rule dominate_isub)
-prefer 2 apply assumption
-apply (simp add: dominate_def)
-apply (rule ballI)
-apply (rule bexI, auto)
-apply (simp add: matrix_chain_left [THEN chain_fun, THEN eta])
-apply (rule islub_ub)
-apply (rule cpo_lub)
-apply (simp_all add: matrix_chain_left matrix_chain_diag chain_fun
- matrix_chain_lub isub_lemma)
-done
+ assumes DM: "matrix(D, M)" and D: "cpo(D)"
+ shows "isub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m)),y) <-> isub(D,(\<lambda>n \<in> nat. M`n`n),y)"
+proof
+ assume isub: "isub(D, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))), y)"
+ hence dom: "dominate(D, \<lambda>n\<in>nat. M ` n ` n, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))))"
+ using DM D
+ by (simp add: dominate_def, intro ballI bexI,
+ simp_all add: matrix_chain_left [THEN chain_fun, THEN eta] islub_ub cpo_lub matrix_chain_left)
+ thus "isub(D, \<lambda>n\<in>nat. M ` n ` n, y)" using DM D
+ by - (rule dominate_isub [OF dom isub],
+ simp_all add: matrix_chain_diag chain_fun matrix_chain_lub)
+next
+ assume isub: "isub(D, \<lambda>n\<in>nat. M ` n ` n, y)"
+ thus "isub(D, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))), y)" using DM D
+ by (simp add: isub_lemma)
+qed
lemma lub_matrix_diag_aux1:
"lub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m))) =
@@ -695,34 +708,43 @@
"[|chain(cf(D,E),X); chain(D,Xa); cpo(D); cpo(E) |]
==> matrix(E,\<lambda>x \<in> nat. \<lambda>xa \<in> nat. X`x`(Xa`xa))"
apply (rule matrix_chainI, auto)
-apply (rule chainI)
-apply (blast intro: lam_type apply_funtype cont_fun cf_cont chain_in, simp)
-apply (blast intro: cont_mono nat_succI chain_rel cf_cont chain_in)
-apply (rule chainI)
-apply (blast intro: lam_type apply_funtype cont_fun cf_cont chain_in, simp)
-apply (rule rel_cf)
-apply (simp_all add: chain_in chain_rel)
+apply (force intro: chainI lam_type apply_funtype cont_fun cf_cont cont_mono)
+apply (force intro: chainI lam_type apply_funtype cont_fun cf_cont rel_cf)
apply (blast intro: lam_type apply_funtype cont_fun cf_cont chain_in)
done
lemma chain_cf_lub_cont:
- "[|chain(cf(D,E),X); cpo(D); cpo(E) |]
- ==> (\<lambda>x \<in> set(D). lub(E, \<lambda>n \<in> nat. X ` n ` x)) \<in> cont(D, E)"
-apply (rule contI)
-apply (rule lam_type)
-apply (assumption | rule chain_cf [THEN cpo_lub, THEN islub_in])+
-apply simp
-apply (rule dominate_islub)
-apply (erule_tac [2] chain_cf [THEN cpo_lub], simp_all)+
-apply (rule dominateI, assumption, simp)
-apply (assumption | rule chain_in [THEN cf_cont, THEN cont_mono])+
-apply (assumption | rule chain_cf [THEN chain_fun])+
-apply (simp add: cpo_lub [THEN islub_in]
- chain_in [THEN cf_cont, THEN cont_lub])
-apply (frule matrix_lemma [THEN lub_matrix_diag], assumption+)
-apply (simp add: chain_in [THEN beta])
-apply (drule matrix_lemma [THEN lub_matrix_diag_sym], auto)
-done
+ assumes ch: "chain(cf(D,E),X)" and D: "cpo(D)" and E: "cpo(E)"
+ shows "(\<lambda>x \<in> set(D). lub(E, \<lambda>n \<in> nat. X ` n ` x)) \<in> cont(D, E)"
+proof (rule contI)
+ show "(\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) \<in> set(D) \<rightarrow> set(E)"
+ by (blast intro: lam_type chain_cf [THEN cpo_lub, THEN islub_in] ch E)
+next
+ fix x y
+ assume xy: "rel(D, x, y)" "x \<in> set(D)" "y \<in> set(D)"
+ hence dom: "dominate(E, \<lambda>n\<in>nat. X ` n ` x, \<lambda>n\<in>nat. X ` n ` y)"
+ by (force intro: dominateI chain_in [OF ch, THEN cf_cont, THEN cont_mono])
+ note chE = chain_cf [OF ch]
+ from xy show "rel(E, (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` x,
+ (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` y)"
+ by (simp add: dominate_islub [OF dom] cpo_lub [OF chE] E chain_fun [OF chE])
+next
+ fix Y
+ assume chDY: "chain(D,Y)"
+ have "lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>y\<in>nat. X ` x ` (Y ` y))) =
+ lub(E, \<lambda>x\<in>nat. X ` x ` (Y ` x))"
+ using matrix_lemma [THEN lub_matrix_diag, OF ch chDY]
+ by (simp add: D E)
+ also have "... = lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` n ` (Y ` x)))"
+ using matrix_lemma [THEN lub_matrix_diag_sym, OF ch chDY]
+ by (simp add: D E)
+ finally have "lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` x ` (Y ` n))) =
+ lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` n ` (Y ` x)))" .
+ thus "(\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` lub(D, Y) =
+ lub(E, \<lambda>n\<in>nat. (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` (Y ` n))"
+ by (simp add: cpo_lub [THEN islub_in] D chDY
+ chain_in [THEN cf_cont, THEN cont_lub, OF ch])
+ qed
lemma islub_cf:
"[| chain(cf(D,E),X); cpo(D); cpo(E)|]
--- a/src/ZF/ind_syntax.ML Tue Sep 29 22:15:54 2009 +0200
+++ b/src/ZF/ind_syntax.ML Thu Oct 01 07:40:25 2009 +0200
@@ -10,7 +10,7 @@
struct
(*Print tracing messages during processing of "inductive" theory sections*)
-val trace = ref false;
+val trace = Unsynchronized.ref false;
fun traceIt msg thy t =
if !trace then (tracing (msg ^ Syntax.string_of_term_global thy t); t)
@@ -99,7 +99,7 @@
fun is_ind arg = (type_of arg = iT)
in case List.filter is_ind (args @ cs) of
[] => @{const 0}
- | u_args => BalancedTree.make mk_Un u_args
+ | u_args => Balanced_Tree.make mk_Un u_args
end;