merged
authorwenzelm
Wed, 27 Aug 2014 15:52:58 +0200
changeset 58051 be9815d02b10
parent 58050 1b6035697c49 (current diff)
parent 58049 930727de976c (diff)
child 58052 ec66337a7162
merged
src/HOL/Library/Quickcheck_Types.thy
src/HOL/SMT_Examples/SMT_Examples.certs
src/Pure/GUI/jfx_thread.scala
src/Pure/System/isabelle_font.scala
src/Pure/Thy/thm_deps.ML
src/ZF/IntArith.thy
src/ZF/Tools/twos_compl.ML
--- a/Admin/components/components.sha1	Wed Aug 27 11:33:00 2014 +0200
+++ b/Admin/components/components.sha1	Wed Aug 27 15:52:58 2014 +0200
@@ -34,6 +34,7 @@
 ec740ee9ffd43551ddf1e5b91641405116af6291  jdk-7u6.tar.gz
 7d5b152ac70f720bb9e783fa45ecadcf95069584  jdk-7u9.tar.gz
 5442f1015a0657259be0590b04572cd933431df7  jdk-8u11.tar.gz
+cfecb1383faaf027ffbabfcd77a0b6a6521e0969  jdk-8u20.tar.gz
 c95ebf7777beb3e7ef10c0cf3f734cb78f9828e4  jdk-8u5.tar.gz
 44775a22f42a9d665696bfb49e53c79371c394b0  jedit_build-20111217.tar.gz
 a242a688810f2bccf24587b0062ce8027bf77fa2  jedit_build-20120304.tar.gz
--- a/Admin/components/main	Wed Aug 27 11:33:00 2014 +0200
+++ b/Admin/components/main	Wed Aug 27 15:52:58 2014 +0200
@@ -11,6 +11,5 @@
 polyml-5.5.2-1
 scala-2.11.2
 spass-3.8ds
-z3-3.2-1
 z3-4.3.2pre-1
 xz-java-1.2-1
--- a/CONTRIBUTORS	Wed Aug 27 11:33:00 2014 +0200
+++ b/CONTRIBUTORS	Wed Aug 27 15:52:58 2014 +0200
@@ -3,6 +3,13 @@
 who is listed as an author in one of the source files of this Isabelle
 distribution.
 
+Contributions to this Isabelle version
+--------------------------------------
+
+* August 2014: Manuel Eberl, TUM
+  Generic euclidean algorithms for gcd et al.
+
+
 Contributions to Isabelle2014
 -----------------------------
 
--- a/NEWS	Wed Aug 27 11:33:00 2014 +0200
+++ b/NEWS	Wed Aug 27 15:52:58 2014 +0200
@@ -1,6 +1,67 @@
 Isabelle NEWS -- history of user-relevant changes
 =================================================
 
+New in this Isabelle version
+----------------------------
+
+*** General ***
+
+* Commands 'method_setup' and 'attribute_setup' now work within a
+local theory context.
+
+* Command 'named_theorems' declares a dynamic fact within the context,
+together with an attribute to maintain the content incrementally.
+This supersedes functor Named_Thms, but with a subtle change of
+semantics due to external visual order vs. internal reverse order.
+
+
+*** HOL ***
+
+* New (co)datatype package:
+  - Renamed theorems:
+      disc_corec ~> corec_disc
+      disc_corec_iff ~> corec_disc_iff
+      disc_exclude ~> distinct_disc
+      disc_exhaust ~> exhaust_disc
+      disc_map_iff ~> map_disc_iff
+      sel_corec ~> corec_sel
+      sel_exhaust ~> exhaust_sel
+      sel_map ~> map_sel
+      sel_set ~> set_sel
+      sel_split ~> split_sel
+      sel_split_asm ~> split_sel_asm
+      strong_coinduct ~> coinduct_strong
+      weak_case_cong ~> case_cong_weak
+    INCOMPATIBILITY.
+  - The rules "set_empty" have been removed. They are easy
+    consequences of other set rules "by auto".
+    INCOMPATIBILITY.
+  - The rule "set_cases" is now registered with the "[cases set]"
+    attribute. This can influence the behavior of the "cases" proof
+    method when more than one case rule is applicable (e.g., an
+    assumption is of the form "w : set ws" and the method "cases w"
+    is invoked). The solution is to specify the case rule explicitly
+    (e.g. "cases w rule: widget.exhaust").
+    INCOMPATIBILITY.
+
+* Old datatype package:
+  - Renamed theorems:
+      weak_case_cong ~> case_cong_weak
+    INCOMPATIBILITY.
+
+* Sledgehammer:
+  - Minimization is now always enabled by default.
+    Removed subcommand:
+      min
+
+
+*** ML ***
+
+* Tactical PARALLEL_ALLGOALS is the most common way to refer to
+PARALLEL_GOALS.
+
+
+
 New in Isabelle2014 (August 2014)
 ---------------------------------
 
--- a/etc/isar-keywords-ZF.el	Wed Aug 27 11:33:00 2014 +0200
+++ b/etc/isar-keywords-ZF.el	Wed Aug 27 15:52:58 2014 +0200
@@ -97,6 +97,7 @@
     "locale_deps"
     "method_setup"
     "moreover"
+    "named_theorems"
     "next"
     "no_notation"
     "no_syntax"
@@ -378,6 +379,7 @@
     "local_setup"
     "locale"
     "method_setup"
+    "named_theorems"
     "no_notation"
     "no_syntax"
     "no_translations"
--- a/etc/isar-keywords.el	Wed Aug 27 11:33:00 2014 +0200
+++ b/etc/isar-keywords.el	Wed Aug 27 15:52:58 2014 +0200
@@ -139,6 +139,7 @@
     "locale_deps"
     "method_setup"
     "moreover"
+    "named_theorems"
     "next"
     "nitpick"
     "nitpick_params"
@@ -550,6 +551,7 @@
     "local_setup"
     "locale"
     "method_setup"
+    "named_theorems"
     "nitpick_params"
     "no_adhoc_overloading"
     "no_notation"
--- a/src/CCL/Wfd.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/CCL/Wfd.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -483,15 +483,14 @@
 
 subsection {* Evaluation *}
 
+named_theorems eval "evaluation rules"
+
 ML {*
-structure Eval_Rules =
-  Named_Thms(val name = @{binding eval} val description = "evaluation rules");
-
 fun eval_tac ths =
-  Subgoal.FOCUS_PREMS (fn {context, prems, ...} =>
-    DEPTH_SOLVE_1 (resolve_tac (ths @ prems @ Eval_Rules.get context) 1));
+  Subgoal.FOCUS_PREMS (fn {context = ctxt, prems, ...} =>
+    let val eval_rules = Named_Theorems.get ctxt @{named_theorems eval}
+    in DEPTH_SOLVE_1 (resolve_tac (ths @ prems @ rev eval_rules) 1) end)
 *}
-setup Eval_Rules.setup
 
 method_setup eval = {*
   Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (CHANGED o eval_tac ths ctxt))
--- a/src/Cube/Cube.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Cube/Cube.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -10,14 +10,7 @@
 
 setup Pure_Thy.old_appl_syntax_setup
 
-ML {*
-  structure Rules = Named_Thms
-  (
-    val name = @{binding rules}
-    val description = "Cube inference rules"
-  )
-*}
-setup Rules.setup
+named_theorems rules "Cube inference rules"
 
 typedecl "term"
 typedecl "context"
--- a/src/Doc/Datatypes/Datatypes.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Datatypes/Datatypes.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -535,7 +535,7 @@
 variable (@{typ 'a}, @{typ 'b}, \ldots) \cite{isabelle-isar-ref}.
 
 The optional names preceding the type variables allow to override the default
-names of the set functions (@{text set1_t}, \ldots, @{text setM_t}). Type
+names of the set functions (@{text set\<^sub>1_t}, \ldots, @{text set\<^sub>m_t}). Type
 arguments can be marked as dead by entering ``@{text dead}'' in front of the
 type variable (e.g., ``@{text "(dead 'a)"}''); otherwise, they are live or dead
 (and a set function is generated or not) depending on where they occur in the
@@ -647,13 +647,13 @@
 Case combinator: &
   @{text t.case_t} (rendered using the familiar @{text case}--@{text of} syntax) \\
 Discriminators: &
-  @{text "t.is_C\<^sub>1"}$, \ldots, $@{text "t.is_C\<^sub>n"} \\
+  @{text t.is_C\<^sub>1}$, \ldots, $@{text t.is_C\<^sub>n} \\
 Selectors: &
   @{text t.un_C\<^sub>11}$, \ldots, $@{text t.un_C\<^sub>1k\<^sub>1} \\
 & \quad\vdots \\
 & @{text t.un_C\<^sub>n1}$, \ldots, $@{text t.un_C\<^sub>nk\<^sub>n} \\
 Set functions: &
-  @{text t.set1_t}, \ldots, @{text t.setm_t} \\
+  @{text t.set\<^sub>1_t}, \ldots, @{text t.set\<^sub>m_t} \\
 Map function: &
   @{text t.map_t} \\
 Relator: &
@@ -773,8 +773,8 @@
 \item[@{text "t."}\hthm{case_cong} @{text "[fundef_cong]"}\rm:] ~ \\
 @{thm list.case_cong[no_vars]}
 
-\item[@{text "t."}\hthm{weak_case_cong} @{text "[cong]"}\rm:] ~ \\
-@{thm list.weak_case_cong[no_vars]}
+\item[@{text "t."}\hthm{case_cong_weak} @{text "[cong]"}\rm:] ~ \\
+@{thm list.case_cong_weak[no_vars]}
 
 \item[@{text "t."}\hthm{split}\rm:] ~ \\
 @{thm list.split[no_vars]}
@@ -809,27 +809,29 @@
 @{thm list.collapse(1)[no_vars]} \\
 @{thm list.collapse(2)[no_vars]}
 
-\item[@{text "t."}\hthm{disc_exclude} @{text "[dest]"}\rm:] ~ \\
+\item[@{text "t."}\hthm{distinct_disc} @{text "[dest]"}\rm:] ~ \\
 These properties are missing for @{typ "'a list"} because there is only one
 proper discriminator. Had the datatype been introduced with a second
 discriminator called @{const nonnull}, they would have read thusly: \\[\jot]
 @{prop "null list \<Longrightarrow> \<not> nonnull list"} \\
 @{prop "nonnull list \<Longrightarrow> \<not> null list"}
 
-\item[@{text "t."}\hthm{disc_exhaust} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
-@{thm list.disc_exhaust[no_vars]}
-
-\item[@{text "t."}\hthm{sel_exhaust} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
-@{thm list.sel_exhaust[no_vars]}
+\item[@{text "t."}\hthm{exhaust_disc} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
+@{thm list.exhaust_disc[no_vars]}
+
+\item[@{text "t."}\hthm{exhaust_sel} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
+@{thm list.exhaust_sel[no_vars]}
 
 \item[@{text "t."}\hthm{expand}\rm:] ~ \\
 @{thm list.expand[no_vars]}
 
-\item[@{text "t."}\hthm{sel_split}\rm:] ~ \\
-@{thm list.sel_split[no_vars]}
-
-\item[@{text "t."}\hthm{sel_split_asm}\rm:] ~ \\
-@{thm list.sel_split_asm[no_vars]}
+\item[@{text "t."}\hthm{split_sel}\rm:] ~ \\
+@{thm list.split_sel[no_vars]}
+
+\item[@{text "t."}\hthm{split_sel_asm}\rm:] ~ \\
+@{thm list.split_sel_asm[no_vars]}
+
+\item[@{text "t."}\hthm{split_sels} = @{text "split_sel split_sel_asm"}]
 
 \item[@{text "t."}\hthm{case_eq_if}\rm:] ~ \\
 @{thm list.case_eq_if[no_vars]}
@@ -854,25 +856,33 @@
 \begin{indentblock}
 \begin{description}
 
+\item[@{text "t."}\hthm{ctr_transfer}\rm:] ~ \\
+@{thm list.ctr_transfer(1)[no_vars]} \\
+@{thm list.ctr_transfer(2)[no_vars]}
+
 \item[@{text "t."}\hthm{set} @{text "[simp, code]"}\rm:] ~ \\
 @{thm list.set(1)[no_vars]} \\
 @{thm list.set(2)[no_vars]}
 
-\item[@{text "t."}\hthm{set_empty}\rm:] ~ \\
-@{thm list.set_empty[no_vars]}
-
-\item[@{text "t."}\hthm{sel_set}\rm:] ~ \\
-@{thm list.sel_set[no_vars]}
+\item[@{text "t."}\hthm{set_cases} @{text "[consumes 1, cases set: set\<^sub>i_t]"}\rm:] ~ \\
+@{thm list.set_cases[no_vars]}
+
+\item[@{text "t."}\hthm{set_intros}\rm:] ~ \\
+@{thm list.set_intros(1)[no_vars]} \\
+@{thm list.set_intros(2)[no_vars]}
+
+\item[@{text "t."}\hthm{set_sel}\rm:] ~ \\
+@{thm list.set_sel[no_vars]}
 
 \item[@{text "t."}\hthm{map} @{text "[simp, code]"}\rm:] ~ \\
 @{thm list.map(1)[no_vars]} \\
 @{thm list.map(2)[no_vars]}
 
-\item[@{text "t."}\hthm{disc_map_iff} @{text "[simp]"}\rm:] ~ \\
-@{thm list.disc_map_iff[no_vars]}
-
-\item[@{text "t."}\hthm{sel_map}\rm:] ~ \\
-@{thm list.sel_map[no_vars]}
+\item[@{text "t."}\hthm{map_disc_iff} @{text "[simp]"}\rm:] ~ \\
+@{thm list.map_disc_iff[no_vars]}
+
+\item[@{text "t."}\hthm{map_sel}\rm:] ~ \\
+@{thm list.map_sel[no_vars]}
 
 \item[@{text "t."}\hthm{rel_inject} @{text "[simp]"}\rm:] ~ \\
 @{thm list.rel_inject(1)[no_vars]} \\
@@ -906,15 +916,24 @@
 \begin{indentblock}
 \begin{description}
 
+\item[@{text "t."}\hthm{inj_map}\rm:] ~ \\
+@{thm list.inj_map[no_vars]}
+
+\item[@{text "t."}\hthm{inj_map_strong}\rm:] ~ \\
+@{thm list.inj_map_strong[no_vars]}
+
 \item[@{text "t."}\hthm{set_map}\rm:] ~ \\
 @{thm list.set_map[no_vars]}
 
-\item[@{text "t."}\hthm{map_comp}\rm:] ~ \\
+\item[@{text "t."}\hthm{map_comg0}\rm:] ~ \\
 @{thm list.map_cong0[no_vars]}
 
 \item[@{text "t."}\hthm{map_cong} @{text "[fundef_cong]"}\rm:] ~ \\
 @{thm list.map_cong[no_vars]}
 
+\item[@{text "t."}\hthm{map_cong_simp}\rm:] ~ \\
+@{thm list.map_cong_simp[no_vars]}
+
 \item[@{text "t."}\hthm{map_id}\rm:] ~ \\
 @{thm list.map_id[no_vars]}
 
@@ -936,6 +955,10 @@
 \item[@{text "t."}\hthm{rel_flip}\rm:] ~ \\
 @{thm list.rel_flip[no_vars]}
 
+\item[@{text "t."}\hthm{rel_map}\rm:] ~ \\
+@{thm list.rel_map(1)[no_vars]} \\
+@{thm list.rel_map(2)[no_vars]}
+
 \item[@{text "t."}\hthm{rel_mono}\rm:] ~ \\
 @{thm list.rel_mono[no_vars]}
 
@@ -956,14 +979,13 @@
 \item[@{text "t."}\hthm{induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n, induct t]"}\rm:] ~ \\
 @{thm list.induct[no_vars]}
 
-\item[@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
-Given $m > 1$ mutually recursive datatypes, this induction rule can be used to
-prove $m$ properties simultaneously.
-
 \item[@{text "t."}\hthm{rel_induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n, induct pred]"}\rm:] ~ \\
 @{thm list.rel_induct[no_vars]}
 
-\item[@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{rel_induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm:] ~ \\
+\item[\begin{tabular}{@ {}l@ {}}
+  @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm: \\
+  @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{rel_induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n]"}\rm: \\
+\end{tabular}] ~ \\
 Given $m > 1$ mutually recursive datatypes, this induction rule can be used to
 prove $m$ properties simultaneously.
 
@@ -1753,10 +1775,10 @@
 @{thm llist.coinduct[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
-  @{text "t."}\hthm{strong_coinduct} @{text "[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
-  \phantom{@{text "t."}\hthm{strong_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"}\rm:
+  @{text "t."}\hthm{coinduct_strong} @{text "[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
+  \phantom{@{text "t."}\hthm{coinduct_strong} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"}\rm:
 \end{tabular}] ~ \\
-@{thm llist.strong_coinduct[no_vars]}
+@{thm llist.coinduct_strong[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
   @{text "t."}\hthm{rel_coinduct} @{text "[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
@@ -1767,14 +1789,21 @@
 
 \item[\begin{tabular}{@ {}l@ {}}
   @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{coinduct} @{text "[case_names t\<^sub>1 \<dots> t\<^sub>m, case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"} \\
-  @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{strong_coinduct} @{text "[case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
-  \phantom{@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{strong_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"}\rm: \\
+  @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{coinduct_strong} @{text "[case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
+  \phantom{@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{coinduct_strong} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"}\rm: \\
   @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{rel_coinduct} @{text "[case_names t\<^sub>1 \<dots> t\<^sub>m,"} \\
   \phantom{@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{rel_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots> D\<^sub>n]"}\rm: \\
 \end{tabular}] ~ \\
 Given $m > 1$ mutually corecursive codatatypes, these coinduction rules can be
 used to prove $m$ properties simultaneously.
 
+\item[\begin{tabular}{@ {}l@ {}}
+  @{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{set_induct} @{text "[case_names C\<^sub>1 \<dots> C\<^sub>n,"} \\
+  \phantom{@{text "t\<^sub>1_\<dots>_t\<^sub>m."}\hthm{set_induct} @{text "["}}@{text "induct set: set\<^sub>j_t\<^sub>1, \<dots>, induct set: set\<^sub>j_t\<^sub>m]"}\rm: \\
+\end{tabular}] ~ \\
+@{thm llist.set_induct[no_vars]} \\
+If $m = 1$, the attribute @{text "[consumes 1]"} is generated as well.
+
 \item[@{text "t."}\hthm{corec}\rm:] ~ \\
 @{thm llist.corec(1)[no_vars]} \\
 @{thm llist.corec(2)[no_vars]}
@@ -1782,17 +1811,17 @@
 \item[@{text "t."}\hthm{corec_code} @{text "[code]"}\rm:] ~ \\
 @{thm llist.corec_code[no_vars]}
 
-\item[@{text "t."}\hthm{disc_corec}\rm:] ~ \\
-@{thm llist.disc_corec(1)[no_vars]} \\
-@{thm llist.disc_corec(2)[no_vars]}
-
-\item[@{text "t."}\hthm{disc_corec_iff} @{text "[simp]"}\rm:] ~ \\
-@{thm llist.disc_corec_iff(1)[no_vars]} \\
-@{thm llist.disc_corec_iff(2)[no_vars]}
-
-\item[@{text "t."}\hthm{sel_corec} @{text "[simp]"}\rm:] ~ \\
-@{thm llist.sel_corec(1)[no_vars]} \\
-@{thm llist.sel_corec(2)[no_vars]}
+\item[@{text "t."}\hthm{corec_disc}\rm:] ~ \\
+@{thm llist.corec_disc(1)[no_vars]} \\
+@{thm llist.corec_disc(2)[no_vars]}
+
+\item[@{text "t."}\hthm{corec_disc_iff} @{text "[simp]"}\rm:] ~ \\
+@{thm llist.corec_disc_iff(1)[no_vars]} \\
+@{thm llist.corec_disc_iff(2)[no_vars]}
+
+\item[@{text "t."}\hthm{corec_sel} @{text "[simp]"}\rm:] ~ \\
+@{thm llist.corec_sel(1)[no_vars]} \\
+@{thm llist.corec_sel(2)[no_vars]}
 
 \end{description}
 \end{indentblock}
@@ -1803,7 +1832,7 @@
 \begin{indentblock}
 \begin{description}
 
-\item[@{text "t."}\hthm{simps} = @{text t.inject} @{text t.distinct} @{text t.case} @{text t.disc_corec_iff}] @{text t.sel_corec} ~ \\
+\item[@{text "t."}\hthm{simps} = @{text t.inject} @{text t.distinct} @{text t.case} @{text t.corec_disc_iff}] @{text t.corec_sel} ~ \\
 @{text t.map} @{text t.rel_inject} @{text t.rel_distinct} @{text t.set}
 
 \end{description}
@@ -2125,7 +2154,7 @@
 @{thm [source] iterate\<^sub>i\<^sub>i.coinduct},
 @{thm [source] iterates\<^sub>i\<^sub>i.coinduct}, and
 @{thm [source] iterate\<^sub>i\<^sub>i_iterates\<^sub>i\<^sub>i.coinduct}
-and analogously for @{text strong_coinduct}. These rules and the
+and analogously for @{text coinduct_strong}. These rules and the
 underlying corecursors are generated on a per-need basis and are kept in a cache
 to speed up subsequent definitions.
 *}
--- a/src/Doc/Implementation/Isar.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Implementation/Isar.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -436,32 +436,25 @@
 end
 
 text {* \medskip Apart from explicit arguments, common proof methods
-  typically work with a default configuration provided by the context.
-  As a shortcut to rule management we use a cheap solution via the
-  functor @{ML_functor Named_Thms} (see also @{file
-  "~~/src/Pure/Tools/named_thms.ML"}).  *}
+  typically work with a default configuration provided by the context. As a
+  shortcut to rule management we use a cheap solution via the @{command
+  named_theorems} command to declare a dynamic fact in the context. *}
 
-ML {*
-  structure My_Simps =
-    Named_Thms(
-      val name = @{binding my_simp}
-      val description = "my_simp rule"
-    )
-*}
-setup My_Simps.setup
+named_theorems my_simp
 
-text {* This provides ML access to a list of theorems in canonical
-  declaration order via @{ML My_Simps.get}.  The user can add or
-  delete rules via the attribute @{attribute my_simp}.  The actual
-  proof method is now defined as before, but we append the explicit
-  arguments and the rules from the context.  *}
+text {* The proof method is now defined as before, but we append the
+  explicit arguments and the rules from the context. *}
 
 method_setup my_simp' =
   \<open>Attrib.thms >> (fn thms => fn ctxt =>
-    SIMPLE_METHOD' (fn i =>
-      CHANGED (asm_full_simp_tac
-        (put_simpset HOL_basic_ss ctxt
-          addsimps (thms @ My_Simps.get ctxt)) i)))\<close>
+    let
+      val my_simps = Named_Theorems.get ctxt @{named_theorems my_simp}
+    in
+      SIMPLE_METHOD' (fn i =>
+        CHANGED (asm_full_simp_tac
+          (put_simpset HOL_basic_ss ctxt
+            addsimps (thms @ my_simps)) i))
+    end)\<close>
   "rewrite subgoal by given rules and my_simp rules from the context"
 
 text {*
@@ -500,7 +493,7 @@
   theory library, for example.
 
   This is an inherent limitation of the simplistic rule management via
-  functor @{ML_functor Named_Thms}, because it lacks tool-specific
+  @{command named_theorems}, because it lacks tool-specific
   storage and retrieval.  More realistic applications require
   efficient index-structures that organize theorems in a customized
   manner, such as a discrimination net that is indexed by the
--- a/src/Doc/Isar_Ref/Proof.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Isar_Ref/Proof.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -915,17 +915,18 @@
 
 text {*
   \begin{matharray}{rcl}
-    @{command_def "method_setup"} & : & @{text "theory \<rightarrow> theory"} \\
+    @{command_def "method_setup"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
   \end{matharray}
 
   @{rail \<open>
-    @@{command method_setup} @{syntax name} '=' @{syntax text} @{syntax text}?
+    @@{command method_setup} @{syntax target}?
+      @{syntax name} '=' @{syntax text} @{syntax text}?
   \<close>}
 
   \begin{description}
 
   \item @{command "method_setup"}~@{text "name = text description"}
-  defines a proof method in the current theory.  The given @{text
+  defines a proof method in the current context.  The given @{text
   "text"} has to be an ML expression of type
   @{ML_type "(Proof.context -> Proof.method) context_parser"}, cf.\
   basic parsers defined in structure @{ML_structure Args} and @{ML_structure
--- a/src/Doc/Isar_Ref/Spec.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Isar_Ref/Spec.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1031,7 +1031,7 @@
     @{command_def "ML_command"} & : & @{text "any \<rightarrow>"} \\
     @{command_def "setup"} & : & @{text "theory \<rightarrow> theory"} \\
     @{command_def "local_setup"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
-    @{command_def "attribute_setup"} & : & @{text "theory \<rightarrow> theory"} \\
+    @{command_def "attribute_setup"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
   \end{matharray}
   \begin{tabular}{rcll}
     @{attribute_def ML_print_depth} & : & @{text attribute} & default 10 \\
@@ -1045,7 +1045,8 @@
     (@@{command ML} | @@{command ML_prf} | @@{command ML_val} |
       @@{command ML_command} | @@{command setup} | @@{command local_setup}) @{syntax text}
     ;
-    @@{command attribute_setup} @{syntax name} '=' @{syntax text} @{syntax text}?
+    @@{command attribute_setup} @{syntax target}?
+      @{syntax name} '=' @{syntax text} @{syntax text}?
   \<close>}
 
   \begin{description}
@@ -1093,7 +1094,7 @@
   concrete outer syntax, for example.
 
   \item @{command "attribute_setup"}~@{text "name = text description"}
-  defines an attribute in the current theory.  The given @{text
+  defines an attribute in the current context.  The given @{text
   "text"} has to be an ML expression of type
   @{ML_type "attribute context_parser"}, cf.\ basic parsers defined in
   structure @{ML_structure Args} and @{ML_structure Attrib}.
@@ -1305,12 +1306,16 @@
   \begin{matharray}{rcll}
     @{command_def "lemmas"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
     @{command_def "theorems"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
+    @{command_def "named_theorems"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
   \end{matharray}
 
   @{rail \<open>
     (@@{command lemmas} | @@{command theorems}) @{syntax target}? \<newline>
       (@{syntax thmdef}? @{syntax thmrefs} + @'and')
       (@'for' (@{syntax vars} + @'and'))?
+    ;
+    @@{command named_theorems} @{syntax target}?
+      @{syntax name} @{syntax text}?
   \<close>}
 
   \begin{description}
@@ -1324,6 +1329,12 @@
   \item @{command "theorems"} is the same as @{command "lemmas"}, but
   marks the result as a different kind of facts.
 
+  \item @{command "named_theorems"}~@{text "name description"} declares a
+  dynamic fact within the context. The same @{text name} is used to define
+  an attribute with the usual @{text add}/@{text del} syntax (e.g.\ see
+  \secref{sec:simp-rules}) to maintain the content incrementally, in
+  canonical declaration order of the text structure.
+
   \end{description}
 *}
 
--- a/src/Doc/Logics/document/HOL.tex	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Logics/document/HOL.tex	Wed Aug 27 15:52:58 2014 +0200
@@ -1709,7 +1709,7 @@
   the arms of the \texttt{case}-construct exposed and simplified. To ensure
   full simplification of all parts of a \texttt{case}-construct for datatype
   $t$, remove $t$\texttt{.}\ttindexbold{case_weak_cong} from the simpset, for
-  example by \texttt{delcongs [thm "$t$.weak_case_cong"]}.
+  example by \texttt{delcongs [thm "$t$.case_cong_weak"]}.
 \end{warn}
 
 \subsubsection{The function \cdx{size}}\label{sec:HOL:size}
--- a/src/Doc/Main/document/root.tex	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Main/document/root.tex	Wed Aug 27 15:52:58 2014 +0200
@@ -1,4 +1,5 @@
 \documentclass[12pt,a4paper]{article}
+\usepackage[T1]{fontenc}
 
 \oddsidemargin=4.6mm
 \evensidemargin=4.6mm
@@ -15,9 +16,9 @@
 % this should be the last package used
 \usepackage{pdfsetup}
 
-% urls in roman style, theory text in math-similar italics
+% urls in roman style, theory text in math-similar italics, with literal underscore
 \urlstyle{rm}
-\isabellestyle{it}
+\isabellestyle{literal}
 
 % for uniform font size
 \renewcommand{\isastyle}{\isastyleminor}
--- a/src/Doc/Prog_Prove/Basics.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Prog_Prove/Basics.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -73,10 +73,9 @@
 called \concept{type inference}.  Despite type inference, it is sometimes
 necessary to attach an explicit \concept{type constraint} (or \concept{type
 annotation}) to a variable or term.  The syntax is @{text "t :: \<tau>"} as in
-\mbox{\noquotes{@{prop[source] "m < (n::nat)"}}}. Type constraints may be
+\mbox{\noquotes{@{term[source] "m + (n::nat)"}}}. Type constraints may be
 needed to
-disambiguate terms involving overloaded functions such as @{text "+"}, @{text
-"*"} and @{text"\<le>"}.
+disambiguate terms involving overloaded functions such as @{text "+"}.
 
 Finally there are the universal quantifier @{text"\<And>"}\index{$4@\isasymAnd} and the implication
 @{text"\<Longrightarrow>"}\index{$3@\isasymLongrightarrow}. They are part of the Isabelle framework, not the logic
@@ -100,7 +99,7 @@
 
 Roughly speaking, a \concept{theory} is a named collection of types,
 functions, and theorems, much like a module in a programming language.
-All the Isabelle text that you ever type needs to go into a theory.
+All Isabelle text needs to go into a theory.
 The general format of a theory @{text T} is
 \begin{quote}
 \indexed{\isacom{theory}}{theory} @{text T}\\
--- a/src/Doc/Prog_Prove/Bool_nat_list.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Prog_Prove/Bool_nat_list.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -213,6 +213,7 @@
 \input{MyList.thy}\end{alltt}
 \caption{A Theory of Lists}
 \label{fig:MyList}
+\index{comment}
 \end{figure}
 
 \subsubsection{Structural Induction for Lists}
--- a/src/Doc/Prog_Prove/MyList.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Prog_Prove/MyList.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -14,4 +14,6 @@
 
 value "rev(Cons True (Cons False Nil))"
 
+(* a comment *)
+
 end
--- a/src/Doc/Prog_Prove/Types_and_funs.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Prog_Prove/Types_and_funs.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -93,8 +93,9 @@
 text{*
 Note that @{text"\<tau>\<^sub>1 * \<tau>\<^sub>2"} is the type of pairs, also written @{text"\<tau>\<^sub>1 \<times> \<tau>\<^sub>2"}.
 Pairs can be taken apart either by pattern matching (as above) or with the
-projection functions @{const fst} and @{const snd}: @{thm fst_conv} and @{thm snd_conv}. Tuples are simulated by pairs nested to the right: @{term"(a,b,c)"}
-abbreviates @{text"(a, (b, c))"} and @{text "\<tau>\<^sub>1 \<times> \<tau>\<^sub>2 \<times> \<tau>\<^sub>3"} abbreviates
+projection functions @{const fst} and @{const snd}: @{thm fst_conv[of x y]} and @{thm snd_conv[of x y]}.
+Tuples are simulated by pairs nested to the right: @{term"(a,b,c)"}
+is short for @{text"(a, (b, c))"} and @{text "\<tau>\<^sub>1 \<times> \<tau>\<^sub>2 \<times> \<tau>\<^sub>3"} is short for
 @{text "\<tau>\<^sub>1 \<times> (\<tau>\<^sub>2 \<times> \<tau>\<^sub>3)"}.
 
 \subsection{Definitions}
@@ -388,7 +389,7 @@
 \begin{array}{r@ {}c@ {}l@ {\quad}l}
 @{text"(0 + Suc 0"} & \leq & @{text"Suc 0 + x)"}  & \stackrel{(1)}{=} \\
 @{text"(Suc 0"}     & \leq & @{text"Suc 0 + x)"}  & \stackrel{(2)}{=} \\
-@{text"(Suc 0"}     & \leq & @{text"Suc (0 + x)"} & \stackrel{(3)}{=} \\
+@{text"(Suc 0"}     & \leq & @{text"Suc (0 + x))"} & \stackrel{(3)}{=} \\
 @{text"(0"}         & \leq & @{text"0 + x)"}      & \stackrel{(4)}{=} \\[1ex]
  & @{const True}
 \end{array}
--- a/src/Doc/Prog_Prove/document/intro-isabelle.tex	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Prog_Prove/document/intro-isabelle.tex	Wed Aug 27 15:52:58 2014 +0200
@@ -82,13 +82,13 @@
 \emph{Programming and Proving in Isabelle/HOL} constitutes part~I of
 \href{http://www.concrete-semantics.org}{Concrete Semantics}.  The web
 pages for \href{http://www.concrete-semantics.org}{Concrete Semantics}
-also provide a set of \LaTeX-based slides for teaching \emph{Programming and
-Proving in Isabelle/HOL}.
+also provide a set of \LaTeX-based slides and Isabelle demo files
+for teaching \emph{Programming and Proving in Isabelle/HOL}.
 \fi
 
 \ifsem\else
 \paragraph{Acknowledgements}
 I wish to thank the following people for their comments on this document:
-Florian Haftmann, Ren\'{e} Thiemann, Sean Seefried, Christian Sternagel
-and Carl Witty.
+Florian Haftmann, Peter Johnson, Ren\'{e} Thiemann, Sean Seefried,
+Christian Sternagel and Carl Witty.
 \fi
\ No newline at end of file
--- a/src/Doc/Sledgehammer/document/root.tex	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/Sledgehammer/document/root.tex	Wed Aug 27 15:52:58 2014 +0200
@@ -447,36 +447,15 @@
 \point{Why does Metis fail to reconstruct the proof?}
 
 There are many reasons. If Metis runs seemingly forever, that is a sign that the
-proof is too difficult for it. Metis's search is complete, so it should
-eventually find it, but that's little consolation. There are several possible
-solutions:
-
-\begin{enum}
-\item[\labelitemi] Try the \textit{isar\_proofs} option (\S\ref{output-format}) to
-obtain a step-by-step Isar proof. Since the steps are fairly small, \textit{metis}
-and the other Isabelle proof methods are more likely to be able to replay them.
-
-\item[\labelitemi] Try the \textit{smt2} proof method instead of \textit{metis}.
-It is usually stronger, but you need to either have Z3 available to replay the
-proofs, trust the SMT solver, or use certificates. See the documentation in the
-\textit{SMT2} theory (\texttt{\$ISABELLE\_HOME/src/HOL/SMT2.thy}) for details.
-
-\item[\labelitemi] Try the \textit{blast} or \textit{auto} proof methods, passing
-the necessary facts via \textbf{unfolding}, \textbf{using}, \textit{intro}{:},
-\textit{elim}{:}, \textit{dest}{:}, or \textit{simp}{:}, as appropriate.
-\end{enum}
+proof is too difficult for it. Metis's search is complete for first-order logic
+with equality, so if the proof was found by an ATP such as E, SPASS, or Vampire,
+Metis should eventually find it, but that's little consolation.
 
 In some rare cases, \textit{metis} fails fairly quickly, and you get the error
-message
-
-\prew
-\slshape
-One-line proof reconstruction failed.
-\postw
-
-This message indicates that Sledgehammer determined that the goal is provable,
-but the proof is, for technical reasons, beyond \textit{metis}'s power. You can
-then try again with the \textit{strict} option (\S\ref{problem-encoding}).
+message ``One-line proof reconstruction failed.'' This indicates that
+Sledgehammer determined that the goal is provable, but the proof is, for
+technical reasons, beyond \textit{metis}'s power. You can then try again with
+the \textit{strict} option (\S\ref{problem-encoding}).
 
 If the goal is actually unprovable and you did not specify an unsound encoding
 using \textit{type\_enc} (\S\ref{problem-encoding}), this is a bug, and you are
@@ -519,7 +498,7 @@
 generated by Sledgehammer instead of \textit{metis} if the proof obviously
 requires type information or if \textit{metis} failed when Sledgehammer
 preplayed the proof. (By default, Sledgehammer tries to run \textit{metis} with
-various sets of option for up to 2~seconds each time to ensure that the generated
+various sets of option for up to 1~second each time to ensure that the generated
 one-line proofs actually work and to display timing information. This can be
 configured using the \textit{preplay\_timeout} and \textit{dont\_preplay}
 options (\S\ref{timeouts}).)
@@ -554,26 +533,15 @@
 \point{Are generated proofs minimal?}
 
 Automatic provers frequently use many more facts than are necessary.
-Sledgehammer inclues a minimization tool that takes a set of facts returned by a
-given prover and repeatedly calls the same prover, \textit{metis}, or
-\textit{smt2} with subsets of those axioms in order to find a minimal set.
-Reducing the number of axioms typically improves Metis's speed and success rate,
-while also removing superfluous clutter from the proof scripts.
+Sledgehammer includes a minimization tool that takes a set of facts returned by
+a given prover and repeatedly calls a prover or proof method with subsets of
+those facts to find a minimal set. Reducing the number of facts typically helps
+reconstruction, while also removing superfluous clutter from the proof scripts.
 
 In earlier versions of Sledgehammer, generated proofs were systematically
 accompanied by a suggestion to invoke the minimization tool. This step is now
-performed implicitly if it can be done in a reasonable amount of time (something
-that can be guessed from the number of facts in the original proof and the time
-it took to find or preplay it).
-
-In addition, some provers do not provide proofs or sometimes produce incomplete
-proofs. The minimizer is then invoked to find out which facts are actually needed
-from the (large) set of facts that was initially given to the prover. Finally,
-if a prover returns a proof with lots of facts, the minimizer is invoked
-automatically since Metis would be unlikely to re-find the proof.
-%
-Automatic minimization can be forced or disabled using the \textit{minimize}
-option (\S\ref{mode-of-operation}).
+performed by default but can be disabled using the \textit{minimize} option
+(\S\ref{mode-of-operation}).
 
 \point{A strange error occurred---what should I do?}
 
@@ -623,10 +591,6 @@
 \item[\labelitemi] \textbf{\textit{run} (the default):} Runs Sledgehammer on
 subgoal number \qty{num} (1 by default), with the given options and facts.
 
-\item[\labelitemi] \textbf{\textit{min}:} Attempts to minimize the facts
-specified in the \qty{facts\_override} argument to obtain a simpler proof
-involving fewer facts. The options and goal number are as for \textit{run}.
-
 \item[\labelitemi] \textbf{\textit{messages}:} Redisplays recent messages issued
 by Sledgehammer. This allows you to examine results that might have been lost
 due to Sledgehammer's asynchronous nature. The \qty{num} argument specifies a
@@ -973,16 +937,6 @@
 SPASS, and Vampire for 5~seconds yields a similar success rate to running the
 most effective of these for 120~seconds \cite{boehme-nipkow-2010}.
 
-In addition to the local and remote provers, the Isabelle proof methods
-\textit{metis} and \textit{smt2} can be specified as \textbf{\textit{metis}}
-and \textbf{\textit{smt}}, respectively. They are generally not recommended
-for proof search but occasionally arise in Sledgehammer-generated
-minimization commands (e.g.,
-``\textbf{sledgehammer} \textit{min} [\textit{prover} = \textit{metis}]'').
-
-For the \textit{min} subcommand, the default prover is \textit{metis}. If
-several provers are set, the first one is used.
-
 \opnodefault{prover}{string}
 Alias for \textit{provers}.
 
@@ -1008,12 +962,9 @@
 \nopagebreak
 {\small See also \textit{verbose} (\S\ref{output-format}).}
 
-\opsmart{minimize}{dont\_minimize}
+\optrue{minimize}{dont\_minimize}
 Specifies whether the minimization tool should be invoked automatically after
-proof search. By default, automatic minimization takes place only if
-it can be done in a reasonable amount of time (as determined by
-the number of facts in the original proof and the time it took to find or
-preplay it) or the proof involves an unreasonably large number of facts.
+proof search.
 
 \nopagebreak
 {\small See also \textit{preplay\_timeout} (\S\ref{timeouts})
@@ -1321,13 +1272,16 @@
 one-line proofs. If the option is set to \textit{smart} (the default), Isar
 proofs are only generated when no working one-line proof is available.
 
-\opdefault{compress}{int}{\upshape 10}
+\opdefault{compress}{int}{smart}
 Specifies the granularity of the generated Isar proofs if \textit{isar\_proofs}
 is explicitly enabled. A value of $n$ indicates that each Isar proof step should
-correspond to a group of up to $n$ consecutive proof steps in the ATP proof.
+correspond to a group of up to $n$ consecutive proof steps in the ATP proof. If
+the option is set to \textit{smart} (the default), the compression factor is 10
+if the \textit{isar\_proofs} option is explicitly enabled; otherwise, it is
+$\infty$.
 
 \optrueonly{dont\_compress}
-Alias for ``\textit{compress} = 0''.
+Alias for ``\textit{compress} = 1''.
 
 \optrue{try0}{dont\_try0}
 Specifies whether standard proof methods such as \textit{auto} and
@@ -1335,8 +1289,8 @@
 The collection of methods is roughly the same as for the \textbf{try0} command.
 
 \opsmart{smt\_proofs}{no\_smt\_proofs}
-Specifies whether the \textit{smt2} proof method should be tried as an
-alternative to \textit{metis}.  If the option is set to \textit{smart} (the
+Specifies whether the \textit{smt2} proof method should be tried in addition to
+Isabelle's other proof methods. If the option is set to \textit{smart} (the
 default), the \textit{smt2} method is used for one-line proofs but not in Isar
 proofs.
 \end{enum}
@@ -1373,7 +1327,7 @@
 Specifies the maximum number of seconds that the automatic provers should spend
 searching for a proof. This excludes problem preparation and is a soft limit.
 
-\opdefault{preplay\_timeout}{float}{\upshape 2}
+\opdefault{preplay\_timeout}{float}{\upshape 1}
 Specifies the maximum number of seconds that \textit{metis} or other proof
 methods should spend trying to ``preplay'' the found proof. If this option
 is set to 0, no preplaying takes place, and no timing information is displayed
--- a/src/Doc/antiquote_setup.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/Doc/antiquote_setup.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -208,7 +208,7 @@
   is_some (Keyword.command_keyword name) andalso
     let
       val markup =
-        Outer_Syntax.scan Position.none name
+        Outer_Syntax.scan (Keyword.get_lexicons ()) Position.none name
         |> maps (Outer_Syntax.command_reports (#2 (Outer_Syntax.get_syntax ())))
         |> map (snd o fst);
       val _ = Context_Position.reports ctxt (map (pair pos) markup);
--- a/src/FOL/IFOL.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/FOL/IFOL.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -710,16 +710,14 @@
 
 subsection {* Atomizing elimination rules *}
 
-setup AtomizeElim.setup
-
 lemma atomize_exL[atomize_elim]: "(!!x. P(x) ==> Q) == ((EX x. P(x)) ==> Q)"
-by rule iprover+
+  by rule iprover+
 
 lemma atomize_conjL[atomize_elim]: "(A ==> B ==> C) == (A & B ==> C)"
-by rule iprover+
+  by rule iprover+
 
 lemma atomize_disjL[atomize_elim]: "((A ==> C) ==> (B ==> C) ==> C) == ((A | B ==> C) ==> C)"
-by rule iprover+
+  by rule iprover+
 
 lemma atomize_elimL[atomize_elim]: "(!!B. (A ==> B) ==> B) == Trueprop(A)" ..
 
--- a/src/HOL/ATP.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/ATP.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -15,6 +15,8 @@
 ML_file "Tools/ATP/atp_problem.ML"
 ML_file "Tools/ATP/atp_proof.ML"
 ML_file "Tools/ATP/atp_proof_redirect.ML"
+ML_file "Tools/ATP/atp_satallax.ML"
+
 
 subsection {* Higher-order reasoning helpers *}
 
--- a/src/HOL/Archimedean_Field.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Archimedean_Field.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -174,6 +174,9 @@
 lemma floor_le_iff: "floor x \<le> z \<longleftrightarrow> x < of_int z + 1"
   by (simp add: not_less [symmetric] less_floor_iff)
 
+lemma floor_split[arith_split]: "P (floor t) \<longleftrightarrow> (\<forall>i. of_int i \<le> t \<and> t < of_int i + 1 \<longrightarrow> P i)"
+  by (metis floor_correct floor_unique less_floor_iff not_le order_refl)
+
 lemma floor_mono: assumes "x \<le> y" shows "floor x \<le> floor y"
 proof -
   have "of_int (floor x) \<le> x" by (rule of_int_floor_le)
@@ -285,7 +288,6 @@
 lemma floor_diff_one [simp]: "floor (x - 1) = floor x - 1"
   using floor_diff_of_int [of x 1] by simp
 
-
 subsection {* Ceiling function *}
 
 definition
@@ -426,6 +428,9 @@
 lemma ceiling_diff_one [simp]: "ceiling (x - 1) = ceiling x - 1"
   using ceiling_diff_of_int [of x 1] by simp
 
+lemma ceiling_split[arith_split]: "P (ceiling t) \<longleftrightarrow> (\<forall>i. of_int i - 1 < t \<and> t \<le> of_int i \<longrightarrow> P i)"
+  by (auto simp add: ceiling_unique ceiling_correct)
+
 lemma ceiling_diff_floor_le_1: "ceiling x - floor x \<le> 1"
 proof -
   have "of_int \<lceil>x\<rceil> - 1 < x" 
--- a/src/HOL/BNF_Comp.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Comp.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1,6 +1,7 @@
 (*  Title:      HOL/BNF_Comp.thy
     Author:     Dmitriy Traytel, TU Muenchen
-    Copyright   2012
+    Author:     Jasmin Blanchette, TU Muenchen
+    Copyright   2012, 2013, 2014
 
 Composition of bounded natural functors.
 *)
--- a/src/HOL/BNF_Def.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Def.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1,7 +1,7 @@
 (*  Title:      HOL/BNF_Def.thy
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012
+    Copyright   2012, 2013, 2014
 
 Definition of bounded natural functors.
 *)
@@ -159,6 +159,11 @@
 "case_sum f g \<circ> Inr = g"
 by auto
 
+lemma map_sum_o_inj:
+"map_sum f g o Inl = Inl o f"
+"map_sum f g o Inr = Inr o g"
+by auto
+
 lemma card_order_csum_cone_cexp_def:
   "card_order r \<Longrightarrow> ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \<union> {Inr ()})|"
   unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order)
--- a/src/HOL/BNF_Examples/Derivation_Trees/DTree.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Examples/Derivation_Trees/DTree.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -47,13 +47,13 @@
 using Node unfolding Node_def
 by (metis Node Node_root_cont finite_cont)
 
-lemma dtree_sel_ctor[simp]:
+lemma dtree_sel_ctr[simp]:
 "root (Node n as) = n"
 "finite as \<Longrightarrow> cont (Node n as) = as"
 unfolding Node_def cont_def by auto
 
-lemmas root_Node = dtree_sel_ctor(1)
-lemmas cont_Node = dtree_sel_ctor(2)
+lemmas root_Node = dtree_sel_ctr(1)
+lemmas cont_Node = dtree_sel_ctr(2)
 
 lemma dtree_cong:
 assumes "root tr = root tr'" and "cont tr = cont tr'"
@@ -75,7 +75,7 @@
 lemma unfold:
 "root (unfold rt ct b) = rt b"
 "finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
-using dtree.sel_corec[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
+using dtree.corec_sel[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
 apply blast
 unfolding cont_def comp_def
 by (simp add: case_sum_o_inj map_sum.compositionality image_image)
@@ -83,7 +83,7 @@
 lemma corec:
 "root (corec rt ct b) = rt b"
 "finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
-using dtree.sel_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
+using dtree.corec_sel[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
 unfolding cont_def comp_def id_def
 by simp_all
 
--- a/src/HOL/BNF_Examples/Misc_Datatype.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Examples/Misc_Datatype.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -184,4 +184,45 @@
 datatype_new d5'' = is_D: D nat | E int
 datatype_new d5''' = is_D: D nat | is_E: E int
 
+datatype_compat simple
+datatype_compat simple'
+datatype_compat simple''
+datatype_compat mylist
+datatype_compat some_passive
+datatype_compat I1 I2
+datatype_compat tree forest
+datatype_compat tree' branch
+datatype_compat bin_rose_tree
+datatype_compat exp trm factor
+datatype_compat ftree
+datatype_compat nofail1
+datatype_compat kk1 kk2 kk3
+datatype_compat t1 t2 t3
+datatype_compat t1' t2' t3'
+datatype_compat k1 k2 k3 k4
+datatype_compat tt1 tt2 tt3 tt4
+datatype_compat deadbar
+datatype_compat deadbar_option
+datatype_compat bar
+datatype_compat foo
+datatype_compat deadfoo
+datatype_compat dead_foo
+datatype_compat use_dead_foo
+datatype_compat d1
+datatype_compat d1'
+datatype_compat d2
+datatype_compat d2'
+datatype_compat d3
+datatype_compat d3'
+datatype_compat d3''
+datatype_compat d3'''
+datatype_compat d4
+datatype_compat d4'
+datatype_compat d4''
+datatype_compat d4'''
+datatype_compat d5
+datatype_compat d5'
+datatype_compat d5''
+datatype_compat d5'''
+
 end
--- a/src/HOL/BNF_Examples/Process.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Examples/Process.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -29,7 +29,7 @@
 (* Constructors versus discriminators *)
 theorem isAction_isChoice:
 "isAction p \<or> isChoice p"
-by (rule process.disc_exhaust) auto
+by (rule process.exhaust_disc) auto
 
 theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
 by (cases rule: process.exhaust[of p]) auto
@@ -54,7 +54,7 @@
   Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
   shows "p = p'"
   using assms
-  by (coinduct rule: process.strong_coinduct) (metis process.collapse(1,2) process.disc(3))
+  by (coinduct rule: process.coinduct_strong) (metis process.collapse(1,2) process.disc(3))
 
 
 subsection {* Coiteration (unfold) *}
--- a/src/HOL/BNF_Examples/Stream.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_Examples/Stream.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -27,39 +27,14 @@
 
 hide_const (open) smember
 
-(* TODO: Provide by the package*)
-theorem sset_induct:
-  assumes Base: "\<And>s. P (shd s) s" and Step: "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
-  shows "\<forall>y \<in> sset s. P y s"
-proof (rule stream.dtor_set_induct)
-  fix a :: 'a and s :: "'a stream"
-  assume "a \<in> set1_pre_stream (dtor_stream s)"
-  then have "a = shd s"
-    by (cases "dtor_stream s")
-      (auto simp: BNF_Comp.id_bnf_comp_def shd_def fsts_def set1_pre_stream_def stream.dtor_ctor SCons_def
-        split: stream.splits)
-  with Base show "P a s" by simp
-next
-  fix a :: 'a and s' :: "'a stream"  and s :: "'a stream"
-  assume "s' \<in> set2_pre_stream (dtor_stream s)" and prems: "a \<in> sset s'" "P a s'"
-  then have "s' = stl s"
-    by (cases "dtor_stream s")
-      (auto simp: BNF_Comp.id_bnf_comp_def stl_def snds_def set2_pre_stream_def stream.dtor_ctor SCons_def
-        split: stream.splits)
-  with Step prems show "P a s" by simp
-qed
+lemmas smap_simps[simp] = stream.map_sel
+lemmas shd_sset = stream.set_sel(1)
+lemmas stl_sset = stream.set_sel(2)
 
-lemmas smap_simps[simp] = stream.sel_map
-lemmas shd_sset = stream.sel_set(1)
-lemmas stl_sset = stream.sel_set(2)
-
-(* only for the non-mutual case: *)
-theorem sset_induct1[consumes 1, case_names shd stl, induct set: "sset"]:
-  assumes "y \<in> sset s" and "\<And>s. P (shd s) s"
-  and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
+theorem sset_induct[consumes 1, case_names shd stl, induct set: sset]:
+  assumes "y \<in> sset s" and "\<And>s. P (shd s) s" and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
   shows "P y s"
-  using assms sset_induct by blast
-(* end TODO *)
+using assms by induct (metis stream.sel(1), auto)
 
 
 subsection {* prepend list to stream *}
@@ -456,7 +431,7 @@
   thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
 next
   fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
-    by (induct rule: sset_induct1)
+    by (induct rule: sset_induct)
       (metis UnI1 flat_unfold shift.simps(1) sset_shift,
        metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
 qed
--- a/src/HOL/BNF_FP_Base.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_FP_Base.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -2,7 +2,8 @@
     Author:     Lorenz Panny, TU Muenchen
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
+    Author:     Martin Desharnais, TU Muenchen
+    Copyright   2012, 2013, 2014
 
 Shared fixed point operations on bounded natural functors.
 *)
--- a/src/HOL/BNF_GFP.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_GFP.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -2,7 +2,7 @@
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Lorenz Panny, TU Muenchen
     Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
+    Copyright   2012, 2013, 2014
 
 Greatest fixed point operation on bounded natural functors.
 *)
@@ -22,33 +22,33 @@
 *}
 
 lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-by simp
+  by simp
 
 lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-by (cases s) auto
+  by (cases s) auto
 
 lemma not_TrueE: "\<not> True \<Longrightarrow> P"
-by (erule notE, rule TrueI)
+  by (erule notE, rule TrueI)
 
 lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
-by fast
+  by fast
 
 lemma case_sum_expand_Inr: "f o Inl = g \<Longrightarrow> f x = case_sum g (f o Inr) x"
-by (auto split: sum.splits)
+  by (auto split: sum.splits)
 
 lemma case_sum_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> case_sum g h = f"
-apply rule
- apply (rule ext, force split: sum.split)
-by (rule ext, metis case_sum_o_inj(2))
+  apply rule
+   apply (rule ext, force split: sum.split)
+  by (rule ext, metis case_sum_o_inj(2))
 
 lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
-by fast
+  by fast
 
 lemma equiv_proj:
-  assumes e: "equiv A R" and "z \<in> R"
+  assumes e: "equiv A R" and m: "z \<in> R"
   shows "(proj R o fst) z = (proj R o snd) z"
 proof -
-  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
+  from m have z: "(fst z, snd z) \<in> R" by auto
   with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
     unfolding equiv_def sym_def trans_def by blast+
   then show ?thesis unfolding proj_def[abs_def] by auto
@@ -58,93 +58,93 @@
 definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
 
 lemma Id_on_Gr: "Id_on A = Gr A id"
-unfolding Id_on_def Gr_def by auto
+  unfolding Id_on_def Gr_def by auto
 
 lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
-unfolding image2_def by auto
+  unfolding image2_def by auto
 
 lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
-by auto
+  by auto
 
 lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
-unfolding image2_def Gr_def by auto
+  unfolding image2_def Gr_def by auto
 
 lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
-unfolding Gr_def by simp
+  unfolding Gr_def by simp
 
 lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
-unfolding Gr_def by simp
+  unfolding Gr_def by simp
 
 lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
-unfolding Gr_def by auto
+  unfolding Gr_def by auto
 
 lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
-by blast
+  by blast
 
 lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
-by blast
+  by blast
 
 lemma in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
-unfolding fun_eq_iff by auto
+  unfolding fun_eq_iff by auto
 
 lemma Collect_split_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (split (in_rel Y))"
-by auto
+  by auto
 
 lemma Collect_split_in_rel_leE: "X \<subseteq> Collect (split (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
-by force
+  by force
 
 lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
-unfolding fun_eq_iff by auto
+  unfolding fun_eq_iff by auto
 
 lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
-unfolding fun_eq_iff by auto
+  unfolding fun_eq_iff by auto
 
 lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
-unfolding Gr_def Grp_def fun_eq_iff by auto
+  unfolding Gr_def Grp_def fun_eq_iff by auto
 
 definition relImage where
-"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
+  "relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
 
 definition relInvImage where
-"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
+  "relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
 
 lemma relImage_Gr:
-"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
-unfolding relImage_def Gr_def relcomp_def by auto
+  "\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
+  unfolding relImage_def Gr_def relcomp_def by auto
 
 lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
-unfolding Gr_def relcomp_def image_def relInvImage_def by auto
+  unfolding Gr_def relcomp_def image_def relInvImage_def by auto
 
 lemma relImage_mono:
-"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
-unfolding relImage_def by auto
+  "R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
+  unfolding relImage_def by auto
 
 lemma relInvImage_mono:
-"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
-unfolding relInvImage_def by auto
+  "R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
+  unfolding relInvImage_def by auto
 
 lemma relInvImage_Id_on:
-"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
-unfolding relInvImage_def Id_on_def by auto
+  "(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
+  unfolding relInvImage_def Id_on_def by auto
 
 lemma relInvImage_UNIV_relImage:
-"R \<subseteq> relInvImage UNIV (relImage R f) f"
-unfolding relInvImage_def relImage_def by auto
+  "R \<subseteq> relInvImage UNIV (relImage R f) f"
+  unfolding relInvImage_def relImage_def by auto
 
 lemma relImage_proj:
-assumes "equiv A R"
-shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
-unfolding relImage_def Id_on_def
-using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
-by (auto simp: proj_preserves)
+  assumes "equiv A R"
+  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
+  unfolding relImage_def Id_on_def
+  using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
+  by (auto simp: proj_preserves)
 
 lemma relImage_relInvImage:
-assumes "R \<subseteq> f ` A <*> f ` A"
-shows "relImage (relInvImage A R f) f = R"
-using assms unfolding relImage_def relInvImage_def by fast
+  assumes "R \<subseteq> f ` A <*> f ` A"
+  shows "relImage (relInvImage A R f) f = R"
+  using assms unfolding relImage_def relInvImage_def by fast
 
 lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
-by simp
+  by simp
 
 lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z" by simp
 lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z" by simp
@@ -159,76 +159,75 @@
 definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
 
 lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
-unfolding Shift_def Succ_def by simp
+  unfolding Shift_def Succ_def by simp
 
 lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
-unfolding Succ_def by simp
+  unfolding Succ_def by simp
 
 lemmas SuccE = SuccD[elim_format]
 
 lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
-unfolding Succ_def by simp
+  unfolding Succ_def by simp
 
 lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
-unfolding Shift_def by simp
+  unfolding Shift_def by simp
 
 lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
-unfolding Succ_def Shift_def by auto
+  unfolding Succ_def Shift_def by auto
 
 lemma length_Cons: "length (x # xs) = Suc (length xs)"
-by simp
+  by simp
 
 lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
-by simp
+  by simp
 
 (*injection into the field of a cardinal*)
 definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
 definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
 
 lemma ex_toCard_pred:
-"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
-unfolding toCard_pred_def
-using card_of_ordLeq[of A "Field r"]
-      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
-by blast
+  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
+  unfolding toCard_pred_def
+  using card_of_ordLeq[of A "Field r"]
+    ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
+  by blast
 
 lemma toCard_pred_toCard:
   "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
-unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
+  unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
 
-lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
-  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
-using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
+lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> toCard A r x = toCard A r y \<longleftrightarrow> x = y"
+  using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
 
 definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
 
 lemma fromCard_toCard:
-"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
-unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
+  "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
+  unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
 
 lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
-unfolding Field_card_of csum_def by auto
+  unfolding Field_card_of csum_def by auto
 
 lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
-unfolding Field_card_of csum_def by auto
+  unfolding Field_card_of csum_def by auto
 
 lemma rec_nat_0_imp: "f = rec_nat f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
-by auto
+  by auto
 
 lemma rec_nat_Suc_imp: "f = rec_nat f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
-by auto
+  by auto
 
 lemma rec_list_Nil_imp: "f = rec_list f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
-by auto
+  by auto
 
 lemma rec_list_Cons_imp: "f = rec_list f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
-by auto
+  by auto
 
 lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
-by simp
+  by simp
 
 lemma Collect_splitD: "x \<in> Collect (split A) \<Longrightarrow> A (fst x) (snd x)"
-by auto
+  by auto
 
 definition image2p where
   "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"
@@ -250,20 +249,21 @@
 
 lemma equiv_Eps_in:
 "\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
-apply (rule someI2_ex)
-using in_quotient_imp_non_empty by blast
+  apply (rule someI2_ex)
+  using in_quotient_imp_non_empty by blast
 
 lemma equiv_Eps_preserves:
-assumes ECH: "equiv A r" and X: "X \<in> A//r"
-shows "Eps (%x. x \<in> X) \<in> A"
-apply (rule in_mono[rule_format])
- using assms apply (rule in_quotient_imp_subset)
-by (rule equiv_Eps_in) (rule assms)+
+  assumes ECH: "equiv A r" and X: "X \<in> A//r"
+  shows "Eps (%x. x \<in> X) \<in> A"
+  apply (rule in_mono[rule_format])
+   using assms apply (rule in_quotient_imp_subset)
+  by (rule equiv_Eps_in) (rule assms)+
 
 lemma proj_Eps:
-assumes "equiv A r" and "X \<in> A//r"
-shows "proj r (Eps (%x. x \<in> X)) = X"
-unfolding proj_def proof auto
+  assumes "equiv A r" and "X \<in> A//r"
+  shows "proj r (Eps (%x. x \<in> X)) = X"
+unfolding proj_def
+proof auto
   fix x assume x: "x \<in> X"
   thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
 next
@@ -276,7 +276,7 @@
 lemma univ_commute:
 assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
 shows "(univ f) (proj r x) = f x"
-unfolding univ_def proof -
+proof (unfold univ_def)
   have prj: "proj r x \<in> A//r" using x proj_preserves by fast
   hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
   moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
@@ -285,13 +285,12 @@
 qed
 
 lemma univ_preserves:
-assumes ECH: "equiv A r" and RES: "f respects r" and
-        PRES: "\<forall> x \<in> A. f x \<in> B"
-shows "\<forall>X \<in> A//r. univ f X \<in> B"
+  assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\<forall>x \<in> A. f x \<in> B"
+  shows "\<forall>X \<in> A//r. univ f X \<in> B"
 proof
   fix X assume "X \<in> A//r"
   then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
-  hence "univ f X = f x" using assms univ_commute by fastforce
+  hence "univ f X = f x" using ECH RES univ_commute by fastforce
   thus "univ f X \<in> B" using x PRES by simp
 qed
 
--- a/src/HOL/BNF_LFP.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/BNF_LFP.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1,9 +1,8 @@
-
 (*  Title:      HOL/BNF_LFP.thy
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Lorenz Panny, TU Muenchen
     Author:     Jasmin Blanchette, TU Muenchen
-    Copyright   2012, 2013
+    Copyright   2012, 2013, 2014
 
 Least fixed point operation on bounded natural functors.
 *)
@@ -18,37 +17,37 @@
 begin
 
 lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
-by blast
+  by blast
 
 lemma image_Collect_subsetI: "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
-by blast
+  by blast
 
 lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
-by auto
+  by auto
 
 lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
-by auto
+  by auto
 
 lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> underS R j"
-unfolding underS_def by simp
+  unfolding underS_def by simp
 
 lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
-unfolding underS_def by simp
+  unfolding underS_def by simp
 
 lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
-unfolding underS_def Field_def by auto
+  unfolding underS_def Field_def by auto
 
 lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
-unfolding Field_def by auto
+  unfolding Field_def by auto
 
 lemma fst_convol': "fst (\<langle>f, g\<rangle> x) = f x"
-using fst_convol unfolding convol_def by simp
+  using fst_convol unfolding convol_def by simp
 
 lemma snd_convol': "snd (\<langle>f, g\<rangle> x) = g x"
-using snd_convol unfolding convol_def by simp
+  using snd_convol unfolding convol_def by simp
 
 lemma convol_expand_snd: "fst o f = g \<Longrightarrow> \<langle>g, snd o f\<rangle> = f"
-unfolding convol_def by auto
+  unfolding convol_def by auto
 
 lemma convol_expand_snd':
   assumes "(fst o f = g)"
@@ -60,11 +59,12 @@
   moreover have "\<dots> \<longleftrightarrow> \<langle>g, h\<rangle> = f" by (subst (2) *[symmetric]) (auto simp: convol_def fun_eq_iff)
   ultimately show ?thesis by simp
 qed
+
 lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
-unfolding bij_betw_def by auto
+  unfolding bij_betw_def by auto
 
 lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
-unfolding bij_betw_def by auto
+  unfolding bij_betw_def by auto
 
 lemma f_the_inv_into_f_bij_betw: "bij_betw f A B \<Longrightarrow>
   (bij_betw f A B \<Longrightarrow> x \<in> B) \<Longrightarrow> f (the_inv_into A f x) = x"
@@ -78,7 +78,7 @@
   "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
     \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
     \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
-unfolding bij_betw_def inj_on_def by blast
+  unfolding bij_betw_def inj_on_def by blast
 
 lemma surj_fun_eq:
   assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
--- a/src/HOL/Bali/Basis.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Bali/Basis.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -13,7 +13,7 @@
 
 declare split_if_asm  [split] option.split [split] option.split_asm [split]
 setup {* map_theory_simpset (fn ctxt => ctxt addloop ("split_all_tac", split_all_tac)) *}
-declare if_weak_cong [cong del] option.weak_case_cong [cong del]
+declare if_weak_cong [cong del] option.case_cong_weak [cong del]
 declare length_Suc_conv [iff]
 
 lemma Collect_split_eq: "{p. P (split f p)} = {(a,b). P (f a b)}"
--- a/src/HOL/Bali/Conform.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Bali/Conform.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -521,7 +521,7 @@
 apply auto
 apply (simp only: obj_ty_cong) 
 apply (force dest: conforms_globsD intro!: lconf_upd 
-       simp add: oconf_def cong del: sum.weak_case_cong)
+       simp add: oconf_def cong del: sum.case_cong_weak)
 done
 
 lemma conforms_set_locals: 
--- a/src/HOL/Code_Evaluation.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Code_Evaluation.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -128,6 +128,19 @@
   constant "term_of \<Colon> integer \<Rightarrow> term" \<rightharpoonup> (Eval) "HOLogic.mk'_number/ HOLogic.code'_integerT"
 | constant "term_of \<Colon> String.literal \<Rightarrow> term" \<rightharpoonup> (Eval) "HOLogic.mk'_literal"
 
+declare [[code drop: "term_of :: integer \<Rightarrow> _"]]
+
+lemma term_of_integer [unfolded typerep_fun_def typerep_num_def typerep_integer_def, code]:
+  "term_of (i :: integer) =
+  (if i > 0 then 
+     App (Const (STR ''Num.numeral_class.numeral'') (TYPEREP(num \<Rightarrow> integer)))
+      (term_of (num_of_integer i))
+   else if i = 0 then Const (STR ''Groups.zero_class.zero'') TYPEREP(integer)
+   else
+     App (Const (STR ''Groups.uminus_class.uminus'') TYPEREP(integer \<Rightarrow> integer))
+       (term_of (- i)))"
+by(rule term_of_anything[THEN meta_eq_to_obj_eq])
+
 code_reserved Eval HOLogic
 
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,148 @@
+(*  Title:      Code_Test.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test infrastructure for the code generator
+*)
+
+theory Code_Test
+imports Main
+keywords "test_code" "eval_term" :: diag
+begin
+
+subsection {* YXML encoding for @{typ Code_Evaluation.term} *}
+
+datatype yxml_of_term = YXML
+
+lemma yot_anything: "x = (y :: yxml_of_term)"
+by(cases x y rule: yxml_of_term.exhaust[case_product yxml_of_term.exhaust])(simp)
+
+definition yot_empty :: yxml_of_term where [code del]: "yot_empty = YXML"
+definition yot_literal :: "String.literal \<Rightarrow> yxml_of_term"
+  where [code del]: "yot_literal _ = YXML"
+definition yot_append :: "yxml_of_term \<Rightarrow> yxml_of_term \<Rightarrow> yxml_of_term"
+  where [code del]: "yot_append _ _ = YXML"
+definition yot_concat :: "yxml_of_term list \<Rightarrow> yxml_of_term"
+  where [code del]: "yot_concat _ = YXML"
+
+text {* Serialise @{typ yxml_of_term} to native string of target language *}
+
+code_printing type_constructor yxml_of_term
+  \<rightharpoonup>  (SML) "string"
+  and (OCaml) "string"
+  and (Haskell) "String"
+  and (Scala) "String"
+| constant yot_empty
+  \<rightharpoonup>  (SML) "\"\""
+  and (OCaml) "\"\""
+  and (Haskell) "\"\""
+  and (Scala) "\"\""
+| constant yot_literal
+  \<rightharpoonup>  (SML) "_"
+  and (OCaml) "_"
+  and (Haskell) "_"
+  and (Scala) "_"
+| constant yot_append
+  \<rightharpoonup> (SML) "String.concat [(_), (_)]"
+  and (OCaml) "String.concat \"\" [(_); (_)]"
+  and (Haskell) infixr 5 "++"
+  and (Scala) infixl 5 "+"
+| constant yot_concat
+  \<rightharpoonup> (SML) "String.concat"
+  and (OCaml) "String.concat \"\""
+  and (Haskell) "Prelude.concat"
+  and (Scala) "_.mkString(\"\")"
+
+text {*
+  Stripped-down implementations of Isabelle's XML tree with YXML encoding
+  as defined in @{file "~~/src/Pure/PIDE/xml.ML"}, @{file "~~/src/Pure/PIDE/yxml.ML"}
+  sufficient to encode @{typ "Code_Evaluation.term"} as in @{file "~~/src/Pure/term_xml.ML"}.
+*}
+
+datatype xml_tree = XML_Tree
+
+lemma xml_tree_anything: "x = (y :: xml_tree)"
+by(cases x y rule: xml_tree.exhaust[case_product xml_tree.exhaust])(simp)
+
+context begin
+local_setup {* Local_Theory.map_naming (Name_Space.mandatory_path "xml") *}
+
+type_synonym attributes = "(String.literal \<times> String.literal) list"
+type_synonym body = "xml_tree list"
+
+definition Elem :: "String.literal \<Rightarrow> attributes \<Rightarrow> xml_tree list \<Rightarrow> xml_tree"
+where [code del]: "Elem _ _ _ = XML_Tree"
+
+definition Text :: "String.literal \<Rightarrow> xml_tree"
+where [code del]: "Text _ = XML_Tree"
+
+definition node :: "xml_tree list \<Rightarrow> xml_tree"
+where "node ts = Elem (STR '':'') [] ts"
+
+definition tagged :: "String.literal \<Rightarrow> String.literal option \<Rightarrow> xml_tree list \<Rightarrow> xml_tree"
+where "tagged tag x ts = Elem tag (case x of None \<Rightarrow> [] | Some x' \<Rightarrow> [(STR ''0'', x')]) ts"
+
+definition list where "list f xs = map (node \<circ> f) xs"
+
+definition X :: yxml_of_term where "X = yot_literal (STR [Char Nibble0 Nibble5])"
+definition Y :: yxml_of_term where "Y = yot_literal (STR [Char Nibble0 Nibble6])"
+definition XY :: yxml_of_term where "XY = yot_append X Y"
+definition XYX :: yxml_of_term where "XYX = yot_append XY X"
+
+end
+
+code_datatype xml.Elem xml.Text
+
+definition yxml_string_of_xml_tree :: "xml_tree \<Rightarrow> yxml_of_term \<Rightarrow> yxml_of_term"
+where [code del]: "yxml_string_of_xml_tree _ _ = YXML"
+
+lemma yxml_string_of_xml_tree_code [code]:
+  "yxml_string_of_xml_tree (xml.Elem name atts ts) rest =
+   yot_append xml.XY (
+   yot_append (yot_literal name) (
+   foldr (\<lambda>(a, x) rest. 
+     yot_append xml.Y (
+     yot_append (yot_literal a) (
+     yot_append (yot_literal (STR ''='')) (
+     yot_append (yot_literal x) rest)))) atts (
+   foldr yxml_string_of_xml_tree ts (
+   yot_append xml.XYX rest))))"
+  "yxml_string_of_xml_tree (xml.Text s) rest = yot_append (yot_literal s) rest"
+by(rule yot_anything)+
+
+definition yxml_string_of_body :: "xml.body \<Rightarrow> yxml_of_term"
+where "yxml_string_of_body ts = foldr yxml_string_of_xml_tree ts yot_empty"
+
+text {*
+  Encoding @{typ Code_Evaluation.term} into XML trees
+  as defined in @{file "~~/src/Pure/term_xml.ML"}
+*}
+
+definition xml_of_typ :: "Typerep.typerep \<Rightarrow> xml.body"
+where [code del]: "xml_of_typ _ = [XML_Tree]"
+
+definition xml_of_term :: "Code_Evaluation.term \<Rightarrow> xml.body"
+where [code del]: "xml_of_term _ = [XML_Tree]"
+
+lemma xml_of_typ_code [code]:
+  "xml_of_typ (typerep.Typerep t args) = [xml.tagged (STR ''0'') (Some t) (xml.list xml_of_typ args)]"
+by(simp add: xml_of_typ_def xml_tree_anything)
+
+lemma xml_of_term_code [code]:
+  "xml_of_term (Code_Evaluation.Const x ty) = [xml.tagged (STR ''0'') (Some x) (xml_of_typ ty)]"
+  "xml_of_term (Code_Evaluation.App t1 t2)  = [xml.tagged (STR ''5'') None [xml.node (xml_of_term t1), xml.node (xml_of_term t2)]]"
+  "xml_of_term (Code_Evaluation.Abs x ty t) = [xml.tagged (STR ''4'') (Some x) [xml.node (xml_of_typ ty), xml.node (xml_of_term t)]]"
+  -- {*
+    FIXME: @{const Code_Evaluation.Free} is used only in Quickcheck_Narrowing to represent
+    uninstantiated parameters in constructors. Here, we always translate them to @{ML Free} variables.
+  *}
+  "xml_of_term (Code_Evaluation.Free x ty)  = [xml.tagged (STR ''1'') (Some x) (xml_of_typ ty)]"
+by(simp_all add: xml_of_term_def xml_tree_anything)
+
+definition yxml_string_of_term :: "Code_Evaluation.term \<Rightarrow> yxml_of_term"
+where "yxml_string_of_term = yxml_string_of_body \<circ> xml_of_term"
+
+subsection {* Test engine and drivers *}
+
+ML_file "code_test.ML"
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_GHC.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,15 @@
+(*  Title:      Code_Test_GHC.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on GHC
+*)
+
+theory Code_Test_GHC imports Code_Test begin
+
+definition id_integer :: "integer \<Rightarrow> integer" where "id_integer = id"
+
+test_code "id_integer (14 + 7 * -12) = 140 div -2" in GHC
+
+eval_term "14 + 7 * -12 :: integer" in GHC
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_MLton.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,13 @@
+(*  Title:      Code_Test_MLtonL.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on MLton
+*)
+
+theory Code_Test_MLton imports Code_Test begin
+
+test_code "14 + 7 * -12 = (140 div -2 :: integer)" in MLton
+
+eval_term "14 + 7 * -12 :: integer" in MLton
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_OCaml.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,13 @@
+(*  Title:      Code_Test_OCaml.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on OCaml
+*)
+
+theory Code_Test_OCaml imports Code_Test begin
+
+test_code "14 + 7 * -12 = (140 div -2 :: integer)" in OCaml
+
+eval_term "14 + 7 * -12 :: integer" in OCaml
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_PolyML.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,13 @@
+(*  Title:      Code_Test_PolyML.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on PolyML
+*)
+
+theory Code_Test_PolyML imports Code_Test begin
+
+test_code "14 + 7 * -12 = (140 div -2 :: integer)" in PolyML
+
+eval_term "14 + 7 * -12 :: integer" in PolyML
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_SMLNJ.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,13 @@
+(*  Title:      Code_Test_SMLNJ.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on SMLNJ
+*)
+
+theory Code_Test_SMLNJ imports Code_Test begin
+
+test_code "14 + 7 * -12 = (140 div -2 :: integer)" in SMLNJ
+
+eval_term "14 + 7 * -12 :: integer" in SMLNJ
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/Code_Test_Scala.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,13 @@
+(*  Title:      Code_Test_Scala.thy
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test case for test_code on Scala
+*)
+
+theory Code_Test_Scala imports Code_Test begin 
+
+test_code "14 + 7 * -12 = (140 div -2 :: integer)" in Scala
+
+eval_term "14 + 7 * -12 :: integer" in Scala
+
+end
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Codegenerator_Test/code_test.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,594 @@
+(*  Title:      Code_Test.ML
+    Author:     Andreas Lochbihler, ETH Zurich
+
+Test infrastructure for the code generator
+*)
+
+signature CODE_TEST = sig
+  val add_driver : string * ((Proof.context -> (string * string) list * string -> Path.T -> string) * string) -> theory -> theory
+  val get_driver : theory -> string -> ((Proof.context -> (string * string) list * string -> Path.T -> string) * string) option
+  val overlord : bool Config.T
+  val successN : string
+  val failureN : string
+  val start_markerN : string
+  val end_markerN : string
+  val test_terms : Proof.context -> term list -> string -> unit
+  val test_targets : Proof.context -> term list -> string list -> unit list
+  val test_code_cmd : string list -> string list -> Toplevel.state -> unit
+
+  val eval_term : Proof.context -> term -> string -> unit
+
+  val gen_driver :
+   (theory -> Path.T -> string list -> string ->
+    {files : (Path.T * string) list,
+     compile_cmd : string option, run_cmd : string, mk_code_file : string -> Path.T})
+   -> string -> string -> string
+   -> theory -> (string * string) list * string -> Path.T -> string
+
+  val ISABELLE_POLYML_PATH : string
+  val polymlN : string
+  val evaluate_in_polyml : Proof.context -> (string * string) list * string -> Path.T -> string
+
+  val mltonN : string
+  val ISABELLE_MLTON : string
+  val evaluate_in_mlton : Proof.context -> (string * string) list * string -> Path.T -> string
+
+  val smlnjN : string
+  val ISABELLE_SMLNJ : string
+  val evaluate_in_smlnj : Proof.context -> (string * string) list * string -> Path.T -> string
+
+  val ocamlN : string
+  val ISABELLE_OCAMLC : string
+  val evaluate_in_ocaml : Proof.context -> (string * string) list * string -> Path.T -> string
+
+  val ghcN : string
+  val ISABELLE_GHC : string
+  val ghc_options : string Config.T
+  val evaluate_in_ghc : Proof.context -> (string * string) list * string -> Path.T -> string
+
+  val scalaN : string
+  val ISABELLE_SCALA : string
+  val evaluate_in_scala : Proof.context -> (string * string) list * string -> Path.T -> string
+end
+
+structure Code_Test : CODE_TEST = struct
+
+(* convert a list of terms into nested tuples and back *)
+fun mk_tuples [] = @{term "()"}
+  | mk_tuples [t] = t
+  | mk_tuples (t :: ts) = HOLogic.mk_prod (t, mk_tuples ts)
+
+fun dest_tuples (Const (@{const_name Pair}, _) $ l $ r) = l :: dest_tuples r
+  | dest_tuples t = [t]
+
+
+fun map_option _ NONE = NONE
+  | map_option f (SOME x) = SOME (f x)
+
+fun last_field sep str =
+  let
+    val n = size sep;
+    val len = size str;
+    fun find i =
+      if i < 0 then NONE
+      else if String.substring (str, i, n) = sep then SOME i
+      else find (i - 1);
+  in
+    (case find (len - n) of
+      NONE => NONE
+    | SOME i => SOME (String.substring (str, 0, i), String.extract (str, i + n, NONE)))
+  end;
+
+fun split_first_last start stop s =
+  case first_field start s
+   of NONE => NONE
+    | SOME (initial, rest) =>
+      case last_field stop rest
+       of NONE => NONE
+        | SOME (middle, tail) => SOME (initial, middle, tail);
+
+(* Data slot for drivers *)
+
+structure Drivers = Theory_Data
+(
+  type T = (string * ((Proof.context -> (string * string) list * string -> Path.T -> string) * string)) list;
+  val empty = [];
+  val extend = I;
+  fun merge data : T = AList.merge (op =) (K true) data;
+)
+
+val add_driver = Drivers.map o AList.update (op =);
+val get_driver = AList.lookup (op =) o Drivers.get;
+
+(*
+  Test drivers must produce output of the following format:
+  
+  The start of the relevant data is marked with start_markerN,
+  its end with end_markerN.
+
+  Between these two markers, every line corresponds to one test.
+  Lines of successful tests start with successN, failures start with failureN.
+  The failure failureN may continue with the YXML encoding of the evaluated term.
+  There must not be any additional whitespace in between.
+*)
+
+(* Parsing of results *)
+
+val successN = "True"
+val failureN = "False"
+val start_markerN = "*@*Isabelle/Code_Test-start*@*"
+val end_markerN = "*@*Isabelle/Code_Test-end*@*"
+
+fun parse_line line =
+  if String.isPrefix successN line then (true, NONE)
+  else if String.isPrefix failureN line then (false, 
+    if size line > size failureN then
+      String.extract (line, size failureN, NONE)
+      |> YXML.parse_body
+      |> Term_XML.Decode.term
+      |> dest_tuples
+      |> SOME
+    else NONE)
+  else raise Fail ("Cannot parse result of evaluation:\n" ^ line)
+
+fun parse_result target out =
+  case split_first_last start_markerN end_markerN out
+    of NONE => error ("Evaluation failed for " ^ target ^ "!\nBash output:\n" ^ out)
+     | SOME (_, middle, _) => middle |> trim_line |> split_lines |> map parse_line
+
+(* Pretty printing of test results *)
+
+fun pretty_eval _ NONE _ = []
+  | pretty_eval ctxt (SOME evals) ts = 
+    [Pretty.fbrk,
+     Pretty.big_list "Evaluated terms"
+       (map (fn (t, eval) => Pretty.block 
+         [Syntax.pretty_term ctxt t, Pretty.brk 1, Pretty.str "=", Pretty.brk 1,
+          Syntax.pretty_term ctxt eval])
+       (ts ~~ evals))]
+
+fun pretty_failure ctxt target (((_, evals), query), eval_ts) =
+  Pretty.block (Pretty.text ("Test in " ^ target ^ " failed for") @ [Pretty.brk 1, Pretty.quote (Syntax.pretty_term ctxt query)]
+    @ pretty_eval ctxt evals eval_ts)
+
+fun pretty_failures ctxt target failures =
+  Pretty.blk (0, Pretty.fbreaks (map (pretty_failure ctxt target) failures))
+
+(* Driver invocation *)
+
+val overlord = Attrib.setup_config_bool @{binding "code_test_overlord"} (K false);
+
+fun with_overlord_dir name f =
+  let
+    val path = Path.append (Path.explode "$ISABELLE_HOME_USER") (Path.basic (name ^ serial_string ()))
+    val _ = Isabelle_System.mkdirs path;
+  in
+    Exn.release (Exn.capture f path)
+  end;
+
+fun dynamic_value_strict ctxt t compiler =
+  let
+    val thy = Proof_Context.theory_of ctxt
+    val (driver, target) = case get_driver thy compiler
+     of NONE => error ("No driver for target " ^ compiler)
+      | SOME f => f;
+    val debug = Config.get (Proof_Context.init_global thy) overlord
+    val with_dir = if debug then with_overlord_dir else Isabelle_System.with_tmp_dir
+    fun evaluate f = with_dir "Code_Test" (driver ctxt f) |> parse_result compiler
+    fun evaluator program _ vs_ty deps =
+      Exn.interruptible_capture evaluate (Code_Target.evaluator ctxt target program deps true vs_ty);
+    fun postproc f = map (apsnd (map_option (map f)))
+  in
+    Exn.release (Code_Thingol.dynamic_value ctxt (Exn.map_result o postproc) evaluator t)
+  end;
+
+(* Term preprocessing *)
+
+fun add_eval (Const (@{const_name Trueprop}, _) $ t) = add_eval t
+  | add_eval (Const (@{const_name "HOL.eq"}, _) $ lhs $ rhs) = (fn acc =>
+    acc
+    |> add_eval rhs
+    |> add_eval lhs
+    |> cons rhs
+    |> cons lhs)
+  | add_eval (Const (@{const_name "Not"}, _) $ t) = add_eval t
+  | add_eval (Const (@{const_name "Orderings.ord_class.less_eq"}, _) $ lhs $ rhs) = (fn acc =>
+    lhs :: rhs :: acc)
+  | add_eval (Const (@{const_name "Orderings.ord_class.less"}, _) $ lhs $ rhs) = (fn acc =>
+    lhs :: rhs :: acc)
+  | add_eval _ = I
+
+fun mk_term_of [] = @{term "None :: (unit \<Rightarrow> yxml_of_term) option"}
+  | mk_term_of ts =
+  let
+    val tuple = mk_tuples ts
+    val T = fastype_of tuple
+  in
+    @{term "Some :: (unit \<Rightarrow> yxml_of_term) \<Rightarrow> (unit \<Rightarrow> yxml_of_term) option"} $
+      (absdummy @{typ unit} (@{const yxml_string_of_term} $
+        (Const (@{const_name Code_Evaluation.term_of}, T --> @{typ term}) $ tuple)))
+  end
+
+fun test_terms ctxt ts target =
+  let
+    val thy = Proof_Context.theory_of ctxt
+
+    fun term_of t = Sign.of_sort thy (fastype_of t, @{sort term_of})
+
+    fun ensure_bool t = case fastype_of t of @{typ bool} => ()
+      | _ => error ("Test case not of type bool: " ^ Pretty.string_of (Syntax.pretty_term ctxt t))
+
+    val _ = map ensure_bool ts
+
+    val evals = map (fn t => filter term_of (add_eval t [])) ts
+    val eval = map mk_term_of evals
+
+    val T = HOLogic.mk_prodT (@{typ bool}, Type (@{type_name option}, [@{typ unit} --> @{typ yxml_of_term}]))
+    val t = HOLogic.mk_list T (map HOLogic.mk_prod (ts ~~ eval))
+
+    val result = dynamic_value_strict ctxt t target;
+
+    val failed =
+      filter_out (fst o fst o fst) (result ~~ ts ~~ evals)
+      handle ListPair.UnequalLengths => 
+        error ("Evaluation failed!\nWrong number of test results: " ^ Int.toString (length result))
+    val _ = case failed of [] => () 
+      | _ => error (Pretty.string_of (pretty_failures ctxt target failed))
+  in
+    ()
+  end
+
+fun test_targets ctxt = map o test_terms ctxt
+
+fun test_code_cmd raw_ts targets state =
+  let
+    val ctxt = Toplevel.context_of state;
+    val ts = Syntax.read_terms ctxt raw_ts;
+    val frees = fold Term.add_free_names ts []
+    val _ = if frees = [] then () else
+      error ("Terms contain free variables: " ^
+      Pretty.string_of (Pretty.block (Pretty.commas (map Pretty.str frees))))
+  in
+    test_targets ctxt ts targets; ()
+  end
+
+
+fun eval_term ctxt t target =
+  let
+    val thy = Proof_Context.theory_of ctxt
+
+    val T_t = fastype_of t
+    val _ = if Sign.of_sort thy (T_t, @{sort term_of}) then () else error 
+      ("Type " ^ Pretty.string_of (Syntax.pretty_typ ctxt T_t) ^ 
+       " of term not of sort " ^ Pretty.string_of (Syntax.pretty_sort ctxt @{sort term_of}))
+
+    val T = HOLogic.mk_prodT (@{typ bool}, Type (@{type_name option}, [@{typ unit} --> @{typ yxml_of_term}]))
+    val t' = HOLogic.mk_list T [HOLogic.mk_prod (@{term "False"}, mk_term_of [t])]
+
+    val result = dynamic_value_strict ctxt t' target;
+    val t_eval = case result of [(_, SOME [t])] => t | _ => error "Evaluation failed"
+  in
+    Pretty.writeln (Syntax.pretty_term ctxt t_eval)
+  end
+
+fun eval_term_cmd raw_t target state =
+  let
+    val ctxt = Toplevel.context_of state;
+    val t = Syntax.read_term ctxt raw_t;
+    val frees = Term.add_free_names t []
+    val _ = if frees = [] then () else
+      error ("Term contains free variables: " ^
+      Pretty.string_of (Pretty.block (Pretty.commas (map Pretty.str frees))))
+  in
+    eval_term ctxt t target
+  end
+
+
+(* Generic driver *)
+
+fun gen_driver mk_driver env_var env_var_dest compilerN ctxt (code_files, value_name) =
+  let
+    val compiler = getenv env_var
+    val _ = if compiler <> "" then () else error (Pretty.string_of (Pretty.para 
+         ("Environment variable " ^ env_var ^ " is not set. To test code generation with " ^
+         compilerN ^ ", set this variable to your " ^ env_var_dest ^ " in the settings file.")))
+
+    fun compile NONE = ()
+      | compile (SOME cmd) =
+        let
+          val (out, ret) = Isabelle_System.bash_output cmd
+        in
+          if ret = 0 then () else error
+            ("Compilation with " ^ compilerN ^ " failed:\n" ^ cmd ^ "\n" ^ out)
+        end
+
+    fun run (path : Path.T)= 
+      let
+        val modules = map fst code_files
+        val {files, compile_cmd, run_cmd, mk_code_file}
+          =  mk_driver ctxt path modules value_name
+
+        val _ = map (fn (name, code) => File.write (mk_code_file name) code) code_files
+        val _ = map (fn (name, content) => File.write name content) files
+
+        val _ = compile compile_cmd
+
+        val (out, res) = Isabelle_System.bash_output run_cmd
+        val _ = if res = 0 then () else error
+          ("Evaluation for " ^ compilerN ^ " terminated with error code " ^ Int.toString res ^
+           "\nBash output:\n" ^ out)
+      in
+        out
+      end
+  in
+    run
+  end
+
+(* Driver for PolyML *)
+
+val ISABELLE_POLYML_PATH = "ISABELLE_POLYML_PATH"
+val polymlN = "PolyML";
+
+fun mk_driver_polyml _ path _ value_name =
+  let
+    val generatedN = "generated.sml"
+    val driverN = "driver.sml"
+
+    val code_path = Path.append path (Path.basic generatedN)
+    val driver_path = Path.append path (Path.basic driverN)
+    val driver = 
+      "fun main prog_name = \n" ^
+      "  let\n" ^
+      "    fun format_term NONE = \"\"\n" ^ 
+      "      | format_term (SOME t) = t ();\n" ^
+      "    fun format (true, _) = \"" ^ successN ^ "\\n\"\n" ^
+      "      | format (false, to) = \"" ^ failureN ^ "\" ^ format_term to ^ \"\\n\";\n" ^
+      "    val result = " ^ value_name ^ " ();\n" ^
+      "    val _ = print \"" ^ start_markerN ^ "\";\n" ^
+      "    val _ = map (print o format) result;\n" ^
+      "    val _ = print \"" ^ end_markerN ^ "\";\n" ^
+      "  in\n" ^
+      "    ()\n" ^
+      "  end;\n"
+    val cmd =
+      "echo \"use \\\"" ^ Path.implode code_path ^ "\\\"; use \\\"" ^ 
+      Path.implode driver_path ^ "\\\"; main ();\" | " ^ 
+      Path.implode (Path.variable ISABELLE_POLYML_PATH)
+  in
+    {files = [(driver_path, driver)], compile_cmd = NONE, run_cmd = cmd, mk_code_file = K code_path}
+  end
+
+val evaluate_in_polyml = gen_driver mk_driver_polyml ISABELLE_POLYML_PATH "PolyML executable" polymlN
+
+(* Driver for mlton *)
+
+val mltonN = "MLton"
+val ISABELLE_MLTON = "ISABELLE_MLTON"
+
+fun mk_driver_mlton _ path _ value_name =
+  let
+    val generatedN = "generated.sml"
+    val driverN = "driver.sml"
+    val projectN = "test"
+    val ml_basisN = projectN ^ ".mlb"
+
+    val code_path = Path.append path (Path.basic generatedN)
+    val driver_path = Path.append path (Path.basic driverN)
+    val ml_basis_path = Path.append path (Path.basic ml_basisN)
+    val driver = 
+      "fun format_term NONE = \"\"\n" ^ 
+      "  | format_term (SOME t) = t ();\n" ^
+      "fun format (true, _) = \"" ^ successN ^ "\\n\"\n" ^
+      "  | format (false, to) = \"" ^ failureN ^ "\" ^ format_term to ^ \"\\n\";\n" ^
+      "val result = " ^ value_name ^ " ();\n" ^
+      "val _ = print \"" ^ start_markerN ^ "\";\n" ^
+      "val _ = map (print o format) result;\n" ^
+      "val _ = print \"" ^ end_markerN ^ "\";\n"
+    val ml_basis =
+      "$(SML_LIB)/basis/basis.mlb\n" ^
+      generatedN ^ "\n" ^
+      driverN
+
+    val compile_cmd =
+      File.shell_path (Path.variable ISABELLE_MLTON) ^
+      " -default-type intinf " ^ File.shell_path ml_basis_path
+    val run_cmd = File.shell_path (Path.append path (Path.basic projectN))
+  in
+    {files = [(driver_path, driver), (ml_basis_path, ml_basis)],
+     compile_cmd = SOME compile_cmd, run_cmd = run_cmd, mk_code_file = K code_path}
+  end
+
+val evaluate_in_mlton = gen_driver mk_driver_mlton ISABELLE_MLTON "MLton executable" mltonN
+
+(* Driver for SML/NJ *)
+
+val smlnjN = "SMLNJ"
+val ISABELLE_SMLNJ = "ISABELLE_SMLNJ"
+
+fun mk_driver_smlnj _ path _ value_name =
+  let
+    val generatedN = "generated.sml"
+    val driverN = "driver.sml"
+
+    val code_path = Path.append path (Path.basic generatedN)
+    val driver_path = Path.append path (Path.basic driverN)
+    val driver = 
+      "structure Test = struct\n" ^
+      "fun main prog_name =\n" ^
+      "  let\n" ^
+      "    fun format_term NONE = \"\"\n" ^ 
+      "      | format_term (SOME t) = t ();\n" ^
+      "    fun format (true, _) = \"" ^ successN ^ "\\n\"\n" ^
+      "      | format (false, to) = \"" ^ failureN ^ "\" ^ format_term to ^ \"\\n\";\n" ^
+      "    val result = " ^ value_name ^ " ();\n" ^
+      "    val _ = print \"" ^ start_markerN ^ "\";\n" ^
+      "    val _ = map (print o format) result;\n" ^
+      "    val _ = print \"" ^ end_markerN ^ "\";\n" ^
+      "  in\n" ^
+      "    0\n" ^
+      "  end;\n" ^
+      "end;"
+    val cmd =
+      "echo \"Control.MC.matchRedundantError := false; Control.MC.matchRedundantWarn := false;" ^
+      "use \\\"" ^ Path.implode code_path ^ "\\\"; use \\\"" ^ Path.implode driver_path ^ "\\\";" ^
+      "Test.main ();\" | " ^ Path.implode (Path.variable ISABELLE_SMLNJ)
+  in
+    {files = [(driver_path, driver)], compile_cmd = NONE, run_cmd = cmd, mk_code_file = K code_path}
+  end
+
+val evaluate_in_smlnj = gen_driver mk_driver_smlnj ISABELLE_SMLNJ "SMLNJ executable" smlnjN
+
+(* Driver for OCaml *)
+
+val ocamlN = "OCaml"
+val ISABELLE_OCAMLC = "ISABELLE_OCAMLC"
+
+fun mk_driver_ocaml _ path _ value_name =
+  let
+    val generatedN = "generated.ml"
+    val driverN = "driver.ml"
+
+    val code_path = Path.append path (Path.basic generatedN)
+    val driver_path = Path.append path (Path.basic driverN)
+    val driver = 
+      "let format_term = function\n" ^
+      "  | None -> \"\"\n" ^ 
+      "  | Some t -> t ();;\n" ^
+      "let format = function\n" ^
+      "  | (true, _) -> \"" ^ successN ^ "\\n\"\n" ^
+      "  | (false, x) -> \"" ^ failureN ^ "\" ^ format_term x ^ \"\\n\";;\n" ^
+      "let result = " ^ ("Generated." ^ value_name) ^ " ();;\n" ^
+      "let main x =\n" ^
+      "  let _ = print_string \"" ^ start_markerN ^ "\" in\n" ^
+      "  let _ = List.map (fun x -> print_string (format x)) result in\n" ^
+      "  print_string \"" ^ end_markerN ^ "\";;\n" ^
+      "main ();;"
+
+    val compiled_path = Path.append path (Path.basic "test")
+    val compile_cmd =
+      Path.implode (Path.variable ISABELLE_OCAMLC) ^ " -w pu -o " ^ Path.implode compiled_path ^
+      " -I " ^ Path.implode path ^
+      " nums.cma " ^ Path.implode code_path ^ " " ^ Path.implode driver_path
+
+    val run_cmd = File.shell_path compiled_path
+  in
+    {files = [(driver_path, driver)],
+     compile_cmd = SOME compile_cmd, run_cmd = run_cmd, mk_code_file = K code_path}
+  end
+
+val evaluate_in_ocaml = gen_driver mk_driver_ocaml ISABELLE_OCAMLC "ocamlc executable" ocamlN
+
+(* Driver for GHC *)
+
+val ghcN = "GHC"
+val ISABELLE_GHC = "ISABELLE_GHC"
+
+val ghc_options = Attrib.setup_config_string @{binding code_test_ghc} (K "")
+
+fun mk_driver_ghc ctxt path modules value_name =
+  let
+    val driverN = "Main.hs"
+
+    fun mk_code_file name = Path.append path (Path.basic (name ^ ".hs"))
+    val driver_path = Path.append path (Path.basic driverN)
+    val driver = 
+      "module Main where {\n" ^
+      String.concat (map (fn module => "import qualified " ^ module ^ ";\n") modules) ^
+      "main = do {\n" ^
+      "    let {\n" ^
+      "      format_term Nothing = \"\";\n" ^ 
+      "      format_term (Just t) = t ();\n" ^
+      "      format (True, _) = \"" ^ successN ^ "\\n\";\n" ^
+      "      format (False, to) = \"" ^ failureN ^ "\" ++ format_term to ++ \"\\n\";\n" ^
+      "      result = " ^ value_name ^ " ();\n" ^
+      "    };\n" ^
+      "    Prelude.putStr \"" ^ start_markerN ^ "\";\n" ^
+      "    Prelude.mapM_ (putStr . format) result;\n" ^
+      "    Prelude.putStr \"" ^ end_markerN ^ "\";\n" ^
+      "  }\n" ^
+      "}\n"
+
+    val compiled_path = Path.append path (Path.basic "test")
+    val compile_cmd =
+      Path.implode (Path.variable ISABELLE_GHC) ^ " " ^ Code_Haskell.language_params ^ " " ^
+      Config.get ctxt ghc_options ^ " -o " ^ Path.implode compiled_path ^ " " ^
+      Path.implode driver_path ^ " -i" ^ Path.implode path
+
+    val run_cmd = File.shell_path compiled_path
+  in
+    {files = [(driver_path, driver)],
+     compile_cmd = SOME compile_cmd, run_cmd = run_cmd, mk_code_file = mk_code_file}
+  end
+
+val evaluate_in_ghc = gen_driver mk_driver_ghc ISABELLE_GHC "GHC executable" ghcN
+
+(* Driver for Scala *)
+
+val scalaN = "Scala"
+val ISABELLE_SCALA = "ISABELLE_SCALA"
+
+fun mk_driver_scala _ path _ value_name =
+  let
+    val generatedN = "Generated_Code"
+    val driverN = "Driver.scala"
+
+    val code_path = Path.append path (Path.basic (generatedN ^ ".scala"))
+    val driver_path = Path.append path (Path.basic driverN)
+    val driver = 
+      "import " ^ generatedN ^ "._\n" ^
+      "object Test {\n" ^
+      "  def format_term(x : Option[Unit => String]) : String = x match {\n" ^
+      "    case None => \"\"\n" ^
+      "    case Some(x) => x(())\n" ^
+      "  }\n" ^
+      "  def format(term : (Boolean, Option[Unit => String])) : String = term match {\n" ^
+      "      case (true, _) => \"True\\n\"\n" ^
+      "      case (false, x) => \"False\" + format_term(x) + \"\\n\"\n" ^
+      "  }\n" ^
+      "  def main(args:Array[String]) = {\n" ^
+      "    val result = " ^ value_name ^ "(());\n" ^
+      "    print(\"" ^ start_markerN ^ "\");\n" ^
+      "    result.map{test:(Boolean, Option[Unit => String]) => print(format(test))};\n" ^
+      "    print(\"" ^ end_markerN ^ "\");\n" ^
+      "  }\n" ^
+      "}\n"
+
+    val compile_cmd =
+      Path.implode (Path.append (Path.variable ISABELLE_SCALA) (Path.basic "scalac")) ^
+      " -d " ^ File.shell_path path ^ " -classpath " ^ File.shell_path path ^ " " ^
+      File.shell_path code_path ^ " " ^ File.shell_path driver_path
+
+    val run_cmd =
+      Path.implode (Path.append (Path.variable ISABELLE_SCALA) (Path.basic "scala")) ^
+      " -cp " ^ File.shell_path path ^ " Test"
+  in
+    {files = [(driver_path, driver)],
+     compile_cmd = SOME compile_cmd, run_cmd = run_cmd, mk_code_file = K code_path}
+  end
+
+val evaluate_in_scala = gen_driver mk_driver_scala ISABELLE_SCALA "Scala directory" scalaN
+
+val test_codeP = Scan.repeat1 Parse.prop -- (@{keyword "in"} |-- Scan.repeat1 Parse.name)
+
+val _ = 
+  Outer_Syntax.command @{command_spec "test_code"}
+    "compile test cases to target languages, execute them and report results"
+      (test_codeP >> (fn (raw_ts, targets) => Toplevel.keep (test_code_cmd raw_ts targets)))
+
+val eval_termP = Parse.term -- (@{keyword "in"} |-- Parse.name)
+
+val _ = 
+  Outer_Syntax.command @{command_spec "eval_term"}
+    "evaluate term in target language"
+      (eval_termP >> (fn (raw_t, target) => Toplevel.keep (eval_term_cmd raw_t target)))
+
+val _ = Context.>> (Context.map_theory (
+  fold add_driver
+    [(polymlN, (evaluate_in_polyml, Code_ML.target_SML)),
+     (mltonN, (evaluate_in_mlton, Code_ML.target_SML)),
+     (smlnjN, (evaluate_in_smlnj, Code_ML.target_SML)),
+     (ocamlN, (evaluate_in_ocaml, Code_ML.target_OCaml)),
+     (ghcN, (evaluate_in_ghc, Code_Haskell.target)),
+     (scalaN, (evaluate_in_scala, Code_Scala.target))]))
+end
+
--- a/src/HOL/Decision_Procs/Cooper.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Decision_Procs/Cooper.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -2052,7 +2052,7 @@
     let ?v = "Neg e"
     have vb: "?v \<in> set (\<beta> (Gt (CN 0 c e)))"
       by simp
-    from 7(5)[simplified simp_thms Inum.simps \<beta>.simps set_simps bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]]
+    from 7(5)[simplified simp_thms Inum.simps \<beta>.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]]
     have nob: "\<not> (\<exists>j\<in> {1 ..d}. x = - ?e + j)"
       by auto
     from H p have "x + ?e > 0 \<and> x + ?e \<le> d"
@@ -2085,7 +2085,7 @@
     let ?v = "Sub (C -1) e"
     have vb: "?v \<in> set (\<beta> (Ge (CN 0 c e)))"
       by simp
-    from 8(5)[simplified simp_thms Inum.simps \<beta>.simps set_simps bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]]
+    from 8(5)[simplified simp_thms Inum.simps \<beta>.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]]
     have nob: "\<not> (\<exists>j\<in> {1 ..d}. x =  - ?e - 1 + j)"
       by auto
     from H p have "x + ?e \<ge> 0 \<and> x + ?e < d"
--- a/src/HOL/Decision_Procs/MIR.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Decision_Procs/MIR.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -2612,7 +2612,7 @@
     {assume H: "\<not> real (x-d) + ?e > 0" 
       let ?v="Neg e"
       have vb: "?v \<in> set (\<beta> (Gt (CN 0 c e)))" by simp
-      from 7(5)[simplified simp_thms Inum.simps \<beta>.simps set_simps bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] 
+      from 7(5)[simplified simp_thms Inum.simps \<beta>.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] 
       have nob: "\<not> (\<exists> j\<in> {1 ..d}. real x =  - ?e + real j)" by auto 
       from H p have "real x + ?e > 0 \<and> real x + ?e \<le> real d" by (simp add: c1)
       hence "real (x + floor ?e) > real (0::int) \<and> real (x + floor ?e) \<le> real d"
@@ -2638,7 +2638,7 @@
     {assume H: "\<not> real (x-d) + ?e \<ge> 0" 
       let ?v="Sub (C -1) e"
       have vb: "?v \<in> set (\<beta> (Ge (CN 0 c e)))" by simp
-      from 8(5)[simplified simp_thms Inum.simps \<beta>.simps set_simps bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] 
+      from 8(5)[simplified simp_thms Inum.simps \<beta>.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] 
       have nob: "\<not> (\<exists> j\<in> {1 ..d}. real x =  - ?e - 1 + real j)" by auto 
       from H p have "real x + ?e \<ge> 0 \<and> real x + ?e < real d" by (simp add: c1)
       hence "real (x + floor ?e) \<ge> real (0::int) \<and> real (x + floor ?e) < real d"
@@ -3394,7 +3394,7 @@
     ((UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n=0} (\<lambda> (p,n,s). {(p,0,Floor s)})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n>0} (\<lambda> (p,n,s). (?f(p,n,s)) ` {0 .. n})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n<0} (\<lambda> (p,n,s). (?f(p,n,s)) ` {n .. 0})))"
-    by (simp only: set_map set_upto set_simps)
+    by (simp only: set_map set_upto list.set)
   also have "\<dots> =   
     ((UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n=0} (\<lambda> (p,n,s). {(p,0,Floor s)})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n>0} (\<lambda> (p,n,s). {?f(p,n,s) j| j. j\<in> {0 .. n}})) Un 
@@ -3548,7 +3548,7 @@
     ((UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n=0} (\<lambda> (p,n,s). {(p,0,Floor s)})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n>0} (\<lambda> (p,n,s). (?f(p,n,s)) ` {0 .. n})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n<0} (\<lambda> (p,n,s). (?f(p,n,s)) ` {n .. 0})))"
-    by (simp only: set_map set_upto set_simps)
+    by (simp only: set_map set_upto list.set)
   also have "\<dots> =   
     ((UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n=0} (\<lambda> (p,n,s). {(p,0,Floor s)})) Un 
     (UNION {(p,n,s). (p,n,s) \<in> ?SS a \<and> n>0} (\<lambda> (p,n,s). {?f(p,n,s) j| j. j\<in> {0 .. n}})) Un 
--- a/src/HOL/Deriv.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Deriv.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -50,24 +50,17 @@
 lemma has_vector_derivative_eq_rhs: "(f has_vector_derivative X) F \<Longrightarrow> X = Y \<Longrightarrow> (f has_vector_derivative Y) F"
   by simp
 
-ML {*
-
-structure Derivative_Intros = Named_Thms
-(
-  val name = @{binding derivative_intros}
-  val description = "structural introduction rules for derivatives"
-)
-
-*}
-
+named_theorems derivative_intros "structural introduction rules for derivatives"
 setup {*
   let
-    val eq_thms = [@{thm has_derivative_eq_rhs}, @{thm DERIV_cong}, @{thm has_vector_derivative_eq_rhs}]
+    val eq_thms = @{thms has_derivative_eq_rhs DERIV_cong has_vector_derivative_eq_rhs}
     fun eq_rule thm = get_first (try (fn eq_thm => eq_thm OF [thm])) eq_thms
   in
-    Derivative_Intros.setup #>
     Global_Theory.add_thms_dynamic
-      (@{binding derivative_eq_intros}, map_filter eq_rule o Derivative_Intros.get o Context.proof_of)
+      (@{binding derivative_eq_intros},
+        fn context =>
+          Named_Theorems.get (Context.proof_of context) @{named_theorems derivative_intros}
+          |> map_filter eq_rule)
   end;
 *}
 
--- a/src/HOL/Enum.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Enum.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -537,6 +537,62 @@
 
 end
 
+instance finite_1 :: "{dense_linorder, wellorder}"
+by intro_classes (simp_all add: less_finite_1_def)
+
+instantiation finite_1 :: complete_lattice
+begin
+
+definition [simp]: "Inf = (\<lambda>_. a\<^sub>1)"
+definition [simp]: "Sup = (\<lambda>_. a\<^sub>1)"
+definition [simp]: "bot = a\<^sub>1"
+definition [simp]: "top = a\<^sub>1"
+definition [simp]: "inf = (\<lambda>_ _. a\<^sub>1)"
+definition [simp]: "sup = (\<lambda>_ _. a\<^sub>1)"
+
+instance by intro_classes(simp_all add: less_eq_finite_1_def)
+end
+
+instance finite_1 :: complete_distrib_lattice
+by intro_classes(simp_all add: INF_def SUP_def)
+
+instance finite_1 :: complete_linorder ..
+
+lemma finite_1_eq: "x = a\<^sub>1"
+by(cases x) simp
+
+simproc_setup finite_1_eq ("x::finite_1") = {*
+  fn _ => fn _ => fn ct => case term_of ct of
+    Const (@{const_name a\<^sub>1}, _) => NONE
+  | _ => SOME (mk_meta_eq @{thm finite_1_eq})
+*}
+
+instantiation finite_1 :: complete_boolean_algebra begin
+definition [simp]: "op - = (\<lambda>_ _. a\<^sub>1)"
+definition [simp]: "uminus = (\<lambda>_. a\<^sub>1)"
+instance by intro_classes simp_all
+end
+
+instantiation finite_1 :: 
+  "{linordered_ring_strict, linordered_comm_semiring_strict, ordered_comm_ring,
+    ordered_cancel_comm_monoid_diff, comm_monoid_mult, ordered_ring_abs,
+    one, Divides.div, sgn_if, inverse}"
+begin
+definition [simp]: "Groups.zero = a\<^sub>1"
+definition [simp]: "Groups.one = a\<^sub>1"
+definition [simp]: "op + = (\<lambda>_ _. a\<^sub>1)"
+definition [simp]: "op * = (\<lambda>_ _. a\<^sub>1)"
+definition [simp]: "op div = (\<lambda>_ _. a\<^sub>1)" 
+definition [simp]: "op mod = (\<lambda>_ _. a\<^sub>1)" 
+definition [simp]: "abs = (\<lambda>_. a\<^sub>1)"
+definition [simp]: "sgn = (\<lambda>_. a\<^sub>1)"
+definition [simp]: "inverse = (\<lambda>_. a\<^sub>1)"
+definition [simp]: "op / = (\<lambda>_ _. a\<^sub>1)"
+
+instance by intro_classes(simp_all add: less_finite_1_def)
+end
+
+declare [[simproc del: finite_1_eq]]
 hide_const (open) a\<^sub>1
 
 datatype finite_2 = a\<^sub>1 | a\<^sub>2
@@ -584,6 +640,65 @@
 
 end
 
+instance finite_2 :: wellorder
+by(rule wf_wellorderI)(simp add: less_finite_2_def, intro_classes)
+
+instantiation finite_2 :: complete_lattice
+begin
+
+definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else a\<^sub>2)"
+definition "\<Squnion>A = (if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
+definition [simp]: "bot = a\<^sub>1"
+definition [simp]: "top = a\<^sub>2"
+definition "x \<sqinter> y = (if x = a\<^sub>1 \<or> y = a\<^sub>1 then a\<^sub>1 else a\<^sub>2)"
+definition "x \<squnion> y = (if x = a\<^sub>2 \<or> y = a\<^sub>2 then a\<^sub>2 else a\<^sub>1)"
+
+lemma neq_finite_2_a\<^sub>1_iff [simp]: "x \<noteq> a\<^sub>1 \<longleftrightarrow> x = a\<^sub>2"
+by(cases x) simp_all
+
+lemma neq_finite_2_a\<^sub>1_iff' [simp]: "a\<^sub>1 \<noteq> x \<longleftrightarrow> x = a\<^sub>2"
+by(cases x) simp_all
+
+lemma neq_finite_2_a\<^sub>2_iff [simp]: "x \<noteq> a\<^sub>2 \<longleftrightarrow> x = a\<^sub>1"
+by(cases x) simp_all
+
+lemma neq_finite_2_a\<^sub>2_iff' [simp]: "a\<^sub>2 \<noteq> x \<longleftrightarrow> x = a\<^sub>1"
+by(cases x) simp_all
+
+instance
+proof
+  fix x :: finite_2 and A
+  assume "x \<in> A"
+  then show "\<Sqinter>A \<le> x" "x \<le> \<Squnion>A"
+    by(case_tac [!] x)(auto simp add: less_eq_finite_2_def less_finite_2_def Inf_finite_2_def Sup_finite_2_def)
+qed(auto simp add: less_eq_finite_2_def less_finite_2_def inf_finite_2_def sup_finite_2_def Inf_finite_2_def Sup_finite_2_def)
+end
+
+instance finite_2 :: complete_distrib_lattice
+by(intro_classes)(auto simp add: INF_def SUP_def sup_finite_2_def inf_finite_2_def Inf_finite_2_def Sup_finite_2_def)
+
+instance finite_2 :: complete_linorder ..
+
+instantiation finite_2 :: "{field_inverse_zero, abs_if, ring_div, semiring_div_parity, sgn_if}" begin
+definition [simp]: "0 = a\<^sub>1"
+definition [simp]: "1 = a\<^sub>2"
+definition "x + y = (case (x, y) of (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>1 | _ \<Rightarrow> a\<^sub>2)"
+definition "uminus = (\<lambda>x :: finite_2. x)"
+definition "op - = (op + :: finite_2 \<Rightarrow> _)"
+definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
+definition "inverse = (\<lambda>x :: finite_2. x)"
+definition "op / = (op * :: finite_2 \<Rightarrow> _)"
+definition "abs = (\<lambda>x :: finite_2. x)"
+definition "op div = (op / :: finite_2 \<Rightarrow> _)"
+definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
+definition "sgn = (\<lambda>x :: finite_2. x)"
+instance
+by intro_classes
+  (simp_all add: plus_finite_2_def uminus_finite_2_def minus_finite_2_def times_finite_2_def
+       inverse_finite_2_def divide_finite_2_def abs_finite_2_def div_finite_2_def mod_finite_2_def sgn_finite_2_def
+     split: finite_2.splits)
+end
+
 hide_const (open) a\<^sub>1 a\<^sub>2
 
 datatype finite_3 = a\<^sub>1 | a\<^sub>2 | a\<^sub>3
@@ -629,6 +744,85 @@
 
 end
 
+instance finite_3 :: wellorder
+proof(rule wf_wellorderI)
+  have "inv_image less_than (case_finite_3 0 1 2) = {(x, y). x < y}"
+    by(auto simp add: less_finite_3_def split: finite_3.splits)
+  from this[symmetric] show "wf \<dots>" by simp
+qed intro_classes
+
+instantiation finite_3 :: complete_lattice
+begin
+
+definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>3)"
+definition "\<Squnion>A = (if a\<^sub>3 \<in> A then a\<^sub>3 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
+definition [simp]: "bot = a\<^sub>1"
+definition [simp]: "top = a\<^sub>3"
+definition [simp]: "inf = (min :: finite_3 \<Rightarrow> _)"
+definition [simp]: "sup = (max :: finite_3 \<Rightarrow> _)"
+
+instance
+proof
+  fix x :: finite_3 and A
+  assume "x \<in> A"
+  then show "\<Sqinter>A \<le> x" "x \<le> \<Squnion>A"
+    by(case_tac [!] x)(auto simp add: Inf_finite_3_def Sup_finite_3_def less_eq_finite_3_def less_finite_3_def)
+next
+  fix A and z :: finite_3
+  assume "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
+  then show "z \<le> \<Sqinter>A"
+    by(cases z)(auto simp add: Inf_finite_3_def less_eq_finite_3_def less_finite_3_def)
+next
+  fix A and z :: finite_3
+  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
+  show "\<Squnion>A \<le> z"
+    by(auto simp add: Sup_finite_3_def less_eq_finite_3_def less_finite_3_def dest: *)
+qed(auto simp add: Inf_finite_3_def Sup_finite_3_def)
+end
+
+instance finite_3 :: complete_distrib_lattice
+proof
+  fix a :: finite_3 and B
+  show "a \<squnion> \<Sqinter>B = (\<Sqinter>b\<in>B. a \<squnion> b)"
+  proof(cases a "\<Sqinter>B" rule: finite_3.exhaust[case_product finite_3.exhaust])
+    case a\<^sub>2_a\<^sub>3
+    then have "\<And>x. x \<in> B \<Longrightarrow> x = a\<^sub>3"
+      by(case_tac x)(auto simp add: Inf_finite_3_def split: split_if_asm)
+    then show ?thesis using a\<^sub>2_a\<^sub>3
+      by(auto simp add: INF_def Inf_finite_3_def max_def less_eq_finite_3_def less_finite_3_def split: split_if_asm)
+  qed(auto simp add: INF_def Inf_finite_3_def max_def less_finite_3_def less_eq_finite_3_def split: split_if_asm)
+  show "a \<sqinter> \<Squnion>B = (\<Squnion>b\<in>B. a \<sqinter> b)"
+    by(cases a "\<Squnion>B" rule: finite_3.exhaust[case_product finite_3.exhaust])
+      (auto simp add: SUP_def Sup_finite_3_def min_def less_finite_3_def less_eq_finite_3_def split: split_if_asm)
+qed
+
+instance finite_3 :: complete_linorder ..
+
+instantiation finite_3 :: "{field_inverse_zero, abs_if, ring_div, semiring_div, sgn_if}" begin
+definition [simp]: "0 = a\<^sub>1"
+definition [simp]: "1 = a\<^sub>2"
+definition
+  "x + y = (case (x, y) of
+     (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
+   | (a\<^sub>1, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2
+   | _ \<Rightarrow> a\<^sub>3)"
+definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>1 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2)"
+definition "x - y = x + (- y :: finite_3)"
+definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>3 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>3 | _ \<Rightarrow> a\<^sub>1)"
+definition "inverse = (\<lambda>x :: finite_3. x)" 
+definition "x / y = x * inverse (y :: finite_3)"
+definition "abs = (\<lambda>x :: finite_3. x)"
+definition "op div = (op / :: finite_3 \<Rightarrow> _)"
+definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>1) \<Rightarrow> a\<^sub>3 | _ \<Rightarrow> a\<^sub>1)"
+definition "sgn = (\<lambda>x. case x of a\<^sub>1 \<Rightarrow> a\<^sub>1 | _ \<Rightarrow> a\<^sub>2)"
+instance
+by intro_classes
+  (simp_all add: plus_finite_3_def uminus_finite_3_def minus_finite_3_def times_finite_3_def
+       inverse_finite_3_def divide_finite_3_def abs_finite_3_def div_finite_3_def mod_finite_3_def sgn_finite_3_def
+       less_finite_3_def
+     split: finite_3.splits)
+end
+
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3
 
 datatype finite_4 = a\<^sub>1 | a\<^sub>2 | a\<^sub>3 | a\<^sub>4
@@ -659,6 +853,77 @@
 
 end
 
+instantiation finite_4 :: complete_lattice begin
+
+text {* @{term a\<^sub>1} $<$ @{term a\<^sub>2},@{term a\<^sub>3} $<$ @{term a\<^sub>4},
+  but @{term a\<^sub>2} and @{term a\<^sub>3} are incomparable. *}
+
+definition
+  "x < y \<longleftrightarrow> (case (x, y) of
+     (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
+   |  (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
+   |  (a\<^sub>3, a\<^sub>4) \<Rightarrow> True  | _ \<Rightarrow> False)"
+
+definition 
+  "x \<le> y \<longleftrightarrow> (case (x, y) of
+     (a\<^sub>1, _) \<Rightarrow> True
+   | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
+   | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>4) \<Rightarrow> True
+   | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | _ \<Rightarrow> False)"
+
+definition
+  "\<Sqinter>A = (if a\<^sub>1 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>4)"
+definition
+  "\<Squnion>A = (if a\<^sub>4 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>4 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>1)"
+definition [simp]: "bot = a\<^sub>1"
+definition [simp]: "top = a\<^sub>4"
+definition
+  "x \<sqinter> y = (case (x, y) of
+     (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
+   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
+   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
+   | _ \<Rightarrow> a\<^sub>4)"
+definition
+  "x \<squnion> y = (case (x, y) of
+     (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>4 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>4
+  | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
+  | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
+  | _ \<Rightarrow> a\<^sub>1)"
+
+instance
+proof
+  fix A and z :: finite_4
+  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
+  show "\<Squnion>A \<le> z"
+    by(auto simp add: Sup_finite_4_def less_eq_finite_4_def dest!: * split: finite_4.splits)
+next
+  fix A and z :: finite_4
+  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
+  show "z \<le> \<Sqinter>A"
+    by(auto simp add: Inf_finite_4_def less_eq_finite_4_def dest!: * split: finite_4.splits)
+qed(auto simp add: less_finite_4_def less_eq_finite_4_def Inf_finite_4_def Sup_finite_4_def inf_finite_4_def sup_finite_4_def split: finite_4.splits)
+
+end
+
+instance finite_4 :: complete_distrib_lattice
+proof
+  fix a :: finite_4 and B
+  show "a \<squnion> \<Sqinter>B = (\<Sqinter>b\<in>B. a \<squnion> b)"
+    by(cases a "\<Sqinter>B" rule: finite_4.exhaust[case_product finite_4.exhaust])
+      (auto simp add: sup_finite_4_def Inf_finite_4_def INF_def split: finite_4.splits split_if_asm)
+  show "a \<sqinter> \<Squnion>B = (\<Squnion>b\<in>B. a \<sqinter> b)"
+    by(cases a "\<Squnion>B" rule: finite_4.exhaust[case_product finite_4.exhaust])
+      (auto simp add: inf_finite_4_def Sup_finite_4_def SUP_def split: finite_4.splits split_if_asm)
+qed
+
+instantiation finite_4 :: complete_boolean_algebra begin
+definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>4 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2 | a\<^sub>4 \<Rightarrow> a\<^sub>1)"
+definition "x - y = x \<sqinter> - (y :: finite_4)"
+instance
+by intro_classes
+  (simp_all add: inf_finite_4_def sup_finite_4_def uminus_finite_4_def minus_finite_4_def split: finite_4.splits)
+end
+
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4
 
 
@@ -691,6 +956,72 @@
 
 end
 
+instantiation finite_5 :: complete_lattice
+begin
+
+text {* The non-distributive pentagon lattice $N_5$ *}
+
+definition
+  "x < y \<longleftrightarrow> (case (x, y) of
+     (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
+   | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True  | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
+   | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
+   | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True  | _ \<Rightarrow> False)"
+
+definition
+  "x \<le> y \<longleftrightarrow> (case (x, y) of
+     (a\<^sub>1, _) \<Rightarrow> True
+   | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
+   | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
+   | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True
+   | (a\<^sub>5, a\<^sub>5) \<Rightarrow> True | _ \<Rightarrow> False)"
+
+definition
+  "\<Sqinter>A = 
+  (if a\<^sub>1 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>1
+   else if a\<^sub>2 \<in> A then a\<^sub>2
+   else if a\<^sub>3 \<in> A then a\<^sub>3
+   else if a\<^sub>4 \<in> A then a\<^sub>4
+   else a\<^sub>5)"
+definition
+  "\<Squnion>A = 
+  (if a\<^sub>5 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>5
+   else if a\<^sub>3 \<in> A then a\<^sub>3
+   else if a\<^sub>2 \<in> A then a\<^sub>2
+   else if a\<^sub>4 \<in> A then a\<^sub>4
+   else a\<^sub>1)"
+definition [simp]: "bot = a\<^sub>1"
+definition [simp]: "top = a\<^sub>5"
+definition
+  "x \<sqinter> y = (case (x, y) of
+     (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>1
+   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
+   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
+   | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
+   | _ \<Rightarrow> a\<^sub>5)"
+definition
+  "x \<squnion> y = (case (x, y) of
+     (a\<^sub>5, _) \<Rightarrow> a\<^sub>5 | (_, a\<^sub>5) \<Rightarrow> a\<^sub>5 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>5 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>5
+   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
+   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
+   | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
+   | _ \<Rightarrow> a\<^sub>1)"
+
+instance 
+proof intro_classes
+  fix A and z :: finite_5
+  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
+  show "z \<le> \<Sqinter>A"
+    by(auto simp add: less_eq_finite_5_def Inf_finite_5_def split: finite_5.splits split_if_asm dest!: *)
+next
+  fix A and z :: finite_5
+  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
+  show "\<Squnion>A \<le> z"
+    by(auto simp add: less_eq_finite_5_def Sup_finite_5_def split: finite_5.splits split_if_asm dest!: *)
+qed(auto simp add: less_eq_finite_5_def less_finite_5_def inf_finite_5_def sup_finite_5_def Inf_finite_5_def Sup_finite_5_def split: finite_5.splits split_if_asm)
+
+end
+
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4 a\<^sub>5
 
 
--- a/src/HOL/Fields.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Fields.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -25,15 +25,7 @@
 
 text{* Lemmas @{text divide_simps} move division to the outside and eliminates them on (in)equalities. *}
 
-ML {*
-structure Divide_Simps = Named_Thms
-(
-  val name = @{binding divide_simps}
-  val description = "rewrite rules to eliminate divisions"
-)
-*}
-
-setup Divide_Simps.setup
+named_theorems divide_simps "rewrite rules to eliminate divisions"
 
 
 class division_ring = ring_1 + inverse +
--- a/src/HOL/Fun_Def.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Fun_Def.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -103,7 +103,7 @@
 ML_file "Tools/Function/induction_schema.ML"
 
 method_setup induction_schema = {*
-  Scan.succeed (RAW_METHOD o Induction_Schema.induction_schema_tac)
+  Scan.succeed (NO_CASES oo Induction_Schema.induction_schema_tac)
 *} "prove an induction principle"
 
 setup {*
@@ -117,8 +117,8 @@
 inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
 where is_measure_trivial: "is_measure f"
 
+named_theorems measure_function "rules that guide the heuristic generation of measure functions"
 ML_file "Tools/Function/measure_functions.ML"
-setup MeasureFunctions.setup
 
 lemma measure_size[measure_function]: "is_measure size"
 by (rule is_measure_trivial)
--- a/src/HOL/Fun_Def_Base.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Fun_Def_Base.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -9,6 +9,7 @@
 begin
 
 ML_file "Tools/Function/function_lib.ML"
+named_theorems termination_simp "simplification rules for termination proofs"
 ML_file "Tools/Function/function_common.ML"
 ML_file "Tools/Function/context_tree.ML"
 setup Function_Ctx_Tree.setup
--- a/src/HOL/Groebner_Basis.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Groebner_Basis.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -33,16 +33,7 @@
     "\<not> P \<Longrightarrow> (P \<equiv> False)"
   by auto
 
-ML {*
-structure Algebra_Simplification = Named_Thms
-(
-  val name = @{binding algebra}
-  val description = "pre-simplification rules for algebraic methods"
-)
-*}
-
-setup Algebra_Simplification.setup
-
+named_theorems algebra "pre-simplification rules for algebraic methods"
 ML_file "Tools/groebner.ML"
 
 method_setup algebra = {*
--- a/src/HOL/Groups.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Groups.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -8,17 +8,10 @@
 imports Orderings
 begin
 
-subsection {* Fact collections *}
+subsection {* Dynamic facts *}
 
-ML {*
-structure Ac_Simps = Named_Thms
-(
-  val name = @{binding ac_simps}
-  val description = "associativity and commutativity simplification rules"
-)
-*}
+named_theorems ac_simps "associativity and commutativity simplification rules"
 
-setup Ac_Simps.setup
 
 text{* The rewrites accumulated in @{text algebra_simps} deal with the
 classical algebraic structures of groups, rings and family. They simplify
@@ -29,30 +22,15 @@
 Of course it also works for fields, but it knows nothing about multiplicative
 inverses or division. This is catered for by @{text field_simps}. *}
 
-ML {*
-structure Algebra_Simps = Named_Thms
-(
-  val name = @{binding algebra_simps}
-  val description = "algebra simplification rules"
-)
-*}
+named_theorems algebra_simps "algebra simplification rules"
 
-setup Algebra_Simps.setup
 
 text{* Lemmas @{text field_simps} multiply with denominators in (in)equations
 if they can be proved to be non-zero (for equations) or positive/negative
 (for inequations). Can be too aggressive and is therefore separate from the
 more benign @{text algebra_simps}. *}
 
-ML {*
-structure Field_Simps = Named_Thms
-(
-  val name = @{binding field_simps}
-  val description = "algebra simplification rules for fields"
-)
-*}
-
-setup Field_Simps.setup
+named_theorems field_simps "algebra simplification rules for fields"
 
 
 subsection {* Abstract structures *}
--- a/src/HOL/HOL.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOL.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -763,8 +763,6 @@
 
 subsubsection {* Atomizing elimination rules *}
 
-setup AtomizeElim.setup
-
 lemma atomize_exL[atomize_elim]: "(!!x. P x ==> Q) == ((EX x. P x) ==> Q)"
   by rule iprover+
 
@@ -790,15 +788,7 @@
 seldom-used facts. Some duplicate other rules.
 *}
 
-ML {*
-structure No_ATPs = Named_Thms
-(
-  val name = @{binding no_atp}
-  val description = "theorems that should be filtered out by Sledgehammer"
-)
-*}
-
-setup {* No_ATPs.setup *}
+named_theorems no_atp "theorems that should be filtered out by Sledgehammer"
 
 
 subsubsection {* Classical Reasoner setup *}
@@ -1931,35 +1921,14 @@
 
 subsubsection {* Nitpick setup *}
 
-ML {*
-structure Nitpick_Unfolds = Named_Thms
-(
-  val name = @{binding nitpick_unfold}
-  val description = "alternative definitions of constants as needed by Nitpick"
-)
-structure Nitpick_Simps = Named_Thms
-(
-  val name = @{binding nitpick_simp}
-  val description = "equational specification of constants as needed by Nitpick"
-)
-structure Nitpick_Psimps = Named_Thms
-(
-  val name = @{binding nitpick_psimp}
-  val description = "partial equational specification of constants as needed by Nitpick"
-)
-structure Nitpick_Choice_Specs = Named_Thms
-(
-  val name = @{binding nitpick_choice_spec}
-  val description = "choice specification of constants as needed by Nitpick"
-)
-*}
-
-setup {*
-  Nitpick_Unfolds.setup
-  #> Nitpick_Simps.setup
-  #> Nitpick_Psimps.setup
-  #> Nitpick_Choice_Specs.setup
-*}
+named_theorems nitpick_unfold
+  "alternative definitions of constants as needed by Nitpick"
+named_theorems nitpick_simp
+  "equational specification of constants as needed by Nitpick"
+named_theorems nitpick_psimp
+  "partial equational specification of constants as needed by Nitpick"
+named_theorems nitpick_choice_spec
+  "choice specification of constants as needed by Nitpick"
 
 declare if_bool_eq_conj [nitpick_unfold, no_atp]
         if_bool_eq_disj [no_atp]
@@ -1967,29 +1936,12 @@
 
 subsection {* Preprocessing for the predicate compiler *}
 
-ML {*
-structure Predicate_Compile_Alternative_Defs = Named_Thms
-(
-  val name = @{binding code_pred_def}
-  val description = "alternative definitions of constants for the Predicate Compiler"
-)
-structure Predicate_Compile_Inline_Defs = Named_Thms
-(
-  val name = @{binding code_pred_inline}
-  val description = "inlining definitions for the Predicate Compiler"
-)
-structure Predicate_Compile_Simps = Named_Thms
-(
-  val name = @{binding code_pred_simp}
-  val description = "simplification rules for the optimisations in the Predicate Compiler"
-)
-*}
-
-setup {*
-  Predicate_Compile_Alternative_Defs.setup
-  #> Predicate_Compile_Inline_Defs.setup
-  #> Predicate_Compile_Simps.setup
-*}
+named_theorems code_pred_def
+  "alternative definitions of constants for the Predicate Compiler"
+named_theorems code_pred_inline
+  "inlining definitions for the Predicate Compiler"
+named_theorems code_pred_simp
+  "simplification rules for the optimisations in the Predicate Compiler"
 
 
 subsection {* Legacy tactics and ML bindings *}
--- a/src/HOL/HOLCF/Cfun.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Cfun.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -147,8 +147,8 @@
       val [T, U] = Thm.dest_ctyp (ctyp_of_term f);
       val tr = instantiate' [SOME T, SOME U] [SOME f]
           (mk_meta_eq @{thm Abs_cfun_inverse2});
-      val rules = Cont2ContData.get ctxt;
-      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
+      val rules = Named_Theorems.get ctxt @{named_theorems cont2cont};
+      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac (rev rules)));
     in SOME (perhaps (SINGLE (tac 1)) tr) end
 *}
 
--- a/src/HOL/HOLCF/Cont.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Cont.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -120,15 +120,8 @@
 
 subsection {* Collection of continuity rules *}
 
-ML {*
-structure Cont2ContData = Named_Thms
-(
-  val name = @{binding cont2cont}
-  val description = "continuity intro rule"
-)
-*}
+named_theorems cont2cont "continuity intro rule"
 
-setup Cont2ContData.setup
 
 subsection {* Continuity of basic functions *}
 
--- a/src/HOL/HOLCF/Domain.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Domain.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -316,12 +316,13 @@
 
 subsection {* Setting up the domain package *}
 
+named_theorems domain_defl_simps "theorems like DEFL('a t) = t_defl$DEFL('a)"
+named_theorems domain_isodefl "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
+
 ML_file "Tools/Domain/domain_isomorphism.ML"
 ML_file "Tools/Domain/domain_axioms.ML"
 ML_file "Tools/Domain/domain.ML"
 
-setup Domain_Isomorphism.setup
-
 lemmas [domain_defl_simps] =
   DEFL_cfun DEFL_sfun DEFL_ssum DEFL_sprod DEFL_prod DEFL_u
   liftdefl_eq LIFTDEFL_prod u_liftdefl_liftdefl_of
--- a/src/HOL/HOLCF/Domain_Aux.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Domain_Aux.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -344,6 +344,9 @@
 
 subsection {* ML setup *}
 
+named_theorems domain_deflation "theorems like deflation a ==> deflation (foo_map$a)"
+named_theorems domain_map_ID "theorems like foo_map$ID = ID"
+
 ML_file "Tools/Domain/domain_take_proofs.ML"
 ML_file "Tools/cont_consts.ML"
 ML_file "Tools/cont_proc.ML"
--- a/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -28,8 +28,6 @@
   val domain_isomorphism_cmd :
     (string list * binding * mixfix * string * (binding * binding) option) list
       -> theory -> theory
-
-  val setup : theory -> theory
 end
 
 structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
@@ -41,24 +39,6 @@
 
 fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo})
 
-(******************************************************************************)
-(******************************** theory data *********************************)
-(******************************************************************************)
-
-structure RepData = Named_Thms
-(
-  val name = @{binding domain_defl_simps}
-  val description = "theorems like DEFL('a t) = t_defl$DEFL('a)"
-)
-
-structure IsodeflData = Named_Thms
-(
-  val name = @{binding domain_isodefl}
-  val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
-)
-
-val setup = RepData.setup #> IsodeflData.setup
-
 
 (******************************************************************************)
 (************************** building types and terms **************************)
@@ -170,8 +150,8 @@
     val cont_thm =
       let
         val prop = mk_trp (mk_cont functional)
-        val rules = Cont2ContData.get (Proof_Context.init_global thy)
-        val tac = REPEAT_ALL_NEW (match_tac rules) 1
+        val rules = Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems cont2cont}
+        val tac = REPEAT_ALL_NEW (match_tac (rev rules)) 1
       in
         Goal.prove_global thy [] [] prop (K tac)
       end
@@ -207,8 +187,9 @@
     (tab2 : (typ * term) list)
     (T : typ) : term =
   let
-    val defl_simps = RepData.get (Proof_Context.init_global thy)
-    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps
+    val defl_simps =
+      Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems domain_defl_simps}
+    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) (rev defl_simps)
     val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2
     fun proc1 t =
       (case dest_DEFL t of
@@ -522,7 +503,8 @@
         val ((_, _, _, {DEFL, ...}), thy) =
           Domaindef.add_domaindef spec defl NONE thy
         (* declare domain_defl_simps rules *)
-        val thy = Context.theory_map (RepData.add_thm DEFL) thy
+        val thy =
+          Context.theory_map (Named_Theorems.add_thm @{named_theorems domain_defl_simps} DEFL) thy
       in
         (DEFL, thy)
       end
@@ -532,9 +514,10 @@
     fun mk_DEFL_eq_thm (lhsT, rhsT) =
       let
         val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT)
-        val DEFL_simps = RepData.get (Proof_Context.init_global thy)
+        val DEFL_simps =
+          Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems domain_defl_simps}
         fun tac ctxt =
-          rewrite_goals_tac ctxt (map mk_meta_eq DEFL_simps)
+          rewrite_goals_tac ctxt (map mk_meta_eq (rev DEFL_simps))
           THEN TRY (resolve_tac defl_unfold_thms 1)
       in
         Goal.prove_global thy [] [] goal (tac o #context)
@@ -637,7 +620,7 @@
         val isodefl_rules =
           @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
           @ isodefl_abs_rep_thms
-          @ IsodeflData.get (Proof_Context.init_global thy)
+          @ rev (Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems domain_isodefl})
       in
         Goal.prove_global thy [] assms goal (fn {prems, context = ctxt} =>
          EVERY
@@ -661,7 +644,9 @@
     val (isodefl_thms, thy) = thy |>
       (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
         (conjuncts isodefl_binds isodefl_thm)
-    val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy
+    val thy =
+      fold (Context.theory_map o Named_Theorems.add_thm @{named_theorems domain_isodefl})
+        isodefl_thms thy
 
     (* prove map_ID theorems *)
     fun prove_map_ID_thm
--- a/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -123,31 +123,20 @@
   fun merge data = Symtab.merge (K true) data
 )
 
-structure DeflMapData = Named_Thms
-(
-  val name = @{binding domain_deflation}
-  val description = "theorems like deflation a ==> deflation (foo_map$a)"
-)
-
-structure Map_Id_Data = Named_Thms
-(
-  val name = @{binding domain_map_ID}
-  val description = "theorems like foo_map$ID = ID"
-)
-
 fun add_rec_type (tname, bs) =
     Rec_Data.map (Symtab.insert (K true) (tname, bs))
 
 fun add_deflation_thm thm =
-    Context.theory_map (DeflMapData.add_thm thm)
+    Context.theory_map (Named_Theorems.add_thm @{named_theorems domain_deflation} thm)
 
 val get_rec_tab = Rec_Data.get
-fun get_deflation_thms thy = DeflMapData.get (Proof_Context.init_global thy)
+fun get_deflation_thms thy =
+  rev (Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems domain_deflation})
 
-val map_ID_add = Map_Id_Data.add
-val get_map_ID_thms = Map_Id_Data.get o Proof_Context.init_global
+val map_ID_add = Named_Theorems.add @{named_theorems domain_map_ID}
+fun get_map_ID_thms thy =
+  rev (Named_Theorems.get (Proof_Context.init_global thy) @{named_theorems domain_map_ID})
 
-val _ = Theory.setup (DeflMapData.setup #> Map_Id_Data.setup)
 
 (******************************************************************************)
 (************************** building types and terms **************************)
--- a/src/HOL/HOLCF/Tools/fixrec.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/HOLCF/Tools/fixrec.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -130,8 +130,8 @@
           "or simp rules are configured for all non-HOLCF constants.\n" ^
           "The error occurred for the goal statement:\n" ^
           Syntax.string_of_term lthy prop)
-        val rules = Cont2ContData.get lthy
-        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules))
+        val rules = Named_Theorems.get lthy @{named_theorems cont2cont}
+        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac (rev rules)))
         val slow_tac = SOLVED' (simp_tac lthy)
         val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err
       in
--- a/src/HOL/Imperative_HOL/Heap_Monad.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Imperative_HOL/Heap_Monad.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -39,13 +39,7 @@
   "(\<And>h. execute f h = execute g h) \<Longrightarrow> f = g"
     by (cases f, cases g) (auto simp: fun_eq_iff)
 
-ML {* structure Execute_Simps = Named_Thms
-(
-  val name = @{binding execute_simps}
-  val description = "simplification rules for execute"
-) *}
-
-setup Execute_Simps.setup
+named_theorems execute_simps "simplification rules for execute"
 
 lemma execute_Let [execute_simps]:
   "execute (let x = t in f x) = (let x = t in execute (f x))"
@@ -93,13 +87,7 @@
     and "execute f h \<noteq> None"
   using assms by (simp add: success_def)
 
-ML {* structure Success_Intros = Named_Thms
-(
-  val name = @{binding success_intros}
-  val description = "introduction rules for success"
-) *}
-
-setup Success_Intros.setup
+named_theorems success_intros "introduction rules for success"
 
 lemma success_tapI [success_intros]:
   "success (tap f) h"
@@ -167,19 +155,8 @@
   shows "a = b" and "h' = h''"
   using assms unfolding effect_def by auto
 
-ML {* structure Effect_Intros = Named_Thms
-(
-  val name = @{binding effect_intros}
-  val description = "introduction rules for effect"
-) *}
-
-ML {* structure Effect_Elims = Named_Thms
-(
-  val name = @{binding effect_elims}
-  val description = "elimination rules for effect"
-) *}
-
-setup "Effect_Intros.setup #> Effect_Elims.setup"
+named_theorems effect_intros "introduction rules for effect"
+named_theorems effect_elims "elimination rules for effect"
 
 lemma effect_LetI [effect_intros]:
   assumes "x = t" "effect (f x) h h' r"
--- a/src/HOL/Imperative_HOL/ex/Linked_Lists.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Imperative_HOL/ex/Linked_Lists.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -642,7 +642,7 @@
   with init all_ref_present have q_is_new: "q \<notin> set (p#refs)"
     by (auto elim!: effect_refE intro!: Ref.noteq_I)
   from refs_of_p refs_of_q q_is_new have a3: "\<forall>qrs prs. refs_of' h2 q qrs \<and> refs_of' h2 p prs \<longrightarrow> set prs \<inter> set qrs = {}"
-    by (fastforce simp only: set_simps dest: refs_of'_is_fun)
+    by (fastforce simp only: list.set dest: refs_of'_is_fun)
   from rev'_invariant [OF effect_rev' a1 a2 a3] have "list_of h3 (Ref.get h3 v) (List.rev xs)" 
     unfolding list_of'_def by auto
   with lookup show ?thesis
--- a/src/HOL/Lattices_Big.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Lattices_Big.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -633,6 +633,16 @@
 
 end
 
+lemma Max_eq_if:
+  assumes "finite A"  "finite B"  "\<forall>a\<in>A. \<exists>b\<in>B. a \<le> b"  "\<forall>b\<in>B. \<exists>a\<in>A. b \<le> a"
+  shows "Max A = Max B"
+proof cases
+  assume "A = {}" thus ?thesis using assms by simp
+next
+  assume "A \<noteq> {}" thus ?thesis using assms
+    by(blast intro: antisym Max_in Max_ge_iff[THEN iffD2])
+qed
+
 lemma Min_antimono:
   assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
   shows "Min N \<le> Min M"
--- a/src/HOL/Library/Extended_Real.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Extended_Real.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -91,21 +91,22 @@
   shows "-a = -b \<longleftrightarrow> a = b"
   by (cases rule: ereal2_cases[of a b]) simp_all
 
-function of_ereal :: "ereal \<Rightarrow> real" where
-  "of_ereal (ereal r) = r"
-| "of_ereal \<infinity> = 0"
-| "of_ereal (-\<infinity>) = 0"
+instantiation ereal :: real_of
+begin
+
+function real_ereal :: "ereal \<Rightarrow> real" where
+  "real_ereal (ereal r) = r"
+| "real_ereal \<infinity> = 0"
+| "real_ereal (-\<infinity>) = 0"
   by (auto intro: ereal_cases)
 termination by default (rule wf_empty)
 
-defs (overloaded)
-  real_of_ereal_def [code_unfold]: "real \<equiv> of_ereal"
+instance ..
+end
 
 lemma real_of_ereal[simp]:
   "real (- x :: ereal) = - (real x)"
-  "real (ereal r) = r"
-  "real (\<infinity>::ereal) = 0"
-  by (cases x) (simp_all add: real_of_ereal_def)
+  by (cases x) simp_all
 
 lemma range_ereal[simp]: "range ereal = UNIV - {\<infinity>, -\<infinity>}"
 proof safe
@@ -216,7 +217,7 @@
 instance ereal :: numeral ..
 
 lemma real_of_ereal_0[simp]: "real (0::ereal) = 0"
-  unfolding real_of_ereal_def zero_ereal_def by simp
+  unfolding zero_ereal_def by simp
 
 lemma abs_ereal_zero[simp]: "\<bar>0\<bar> = (0::ereal)"
   unfolding zero_ereal_def abs_ereal.simps by simp
--- a/src/HOL/Library/Float.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Float.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -15,9 +15,15 @@
   morphisms real_of_float float_of
   unfolding float_def by auto
 
-defs (overloaded)
+instantiation float :: real_of
+begin
+
+definition real_float :: "float \<Rightarrow> real" where
   real_of_float_def[code_unfold]: "real \<equiv> real_of_float"
 
+instance ..
+end
+
 lemma type_definition_float': "type_definition real float_of float"
   using type_definition_float unfolding real_of_float_def .
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Lattice_Constructions.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,417 @@
+(*  Title:      HOL/Library/Lattice_Constructions.thy
+    Author:     Lukas Bulwahn
+    Copyright   2010 TU Muenchen
+*)
+
+theory Lattice_Constructions
+imports Main
+begin
+
+subsection {* Values extended by a bottom element *}
+
+datatype 'a bot = Value 'a | Bot
+
+instantiation bot :: (preorder) preorder
+begin
+
+definition less_eq_bot where
+  "x \<le> y \<longleftrightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> x \<le> y))"
+
+definition less_bot where
+  "x < y \<longleftrightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> x < y))"
+
+lemma less_eq_bot_Bot [simp]: "Bot \<le> x"
+  by (simp add: less_eq_bot_def)
+
+lemma less_eq_bot_Bot_code [code]: "Bot \<le> x \<longleftrightarrow> True"
+  by simp
+
+lemma less_eq_bot_Bot_is_Bot: "x \<le> Bot \<Longrightarrow> x = Bot"
+  by (cases x) (simp_all add: less_eq_bot_def)
+
+lemma less_eq_bot_Value_Bot [simp, code]: "Value x \<le> Bot \<longleftrightarrow> False"
+  by (simp add: less_eq_bot_def)
+
+lemma less_eq_bot_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
+  by (simp add: less_eq_bot_def)
+
+lemma less_bot_Bot [simp, code]: "x < Bot \<longleftrightarrow> False"
+  by (simp add: less_bot_def)
+
+lemma less_bot_Bot_is_Value: "Bot < x \<Longrightarrow> \<exists>z. x = Value z"
+  by (cases x) (simp_all add: less_bot_def)
+
+lemma less_bot_Bot_Value [simp]: "Bot < Value x"
+  by (simp add: less_bot_def)
+
+lemma less_bot_Bot_Value_code [code]: "Bot < Value x \<longleftrightarrow> True"
+  by simp
+
+lemma less_bot_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
+  by (simp add: less_bot_def)
+
+instance proof
+qed (auto simp add: less_eq_bot_def less_bot_def less_le_not_le elim: order_trans split: bot.splits)
+
+end 
+
+instance bot :: (order) order proof
+qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)
+
+instance bot :: (linorder) linorder proof
+qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)
+
+instantiation bot :: (order) bot
+begin
+
+definition "bot = Bot"
+
+instance ..
+
+end
+
+instantiation bot :: (top) top
+begin
+
+definition "top = Value top"
+
+instance ..
+
+end
+
+instantiation bot :: (semilattice_inf) semilattice_inf
+begin
+
+definition inf_bot
+where
+  "inf x y = (case x of Bot => Bot | Value v => (case y of Bot => Bot | Value v' => Value (inf v v')))"
+
+instance proof
+qed (auto simp add: inf_bot_def less_eq_bot_def split: bot.splits)
+
+end
+
+instantiation bot :: (semilattice_sup) semilattice_sup
+begin
+
+definition sup_bot
+where
+  "sup x y = (case x of Bot => y | Value v => (case y of Bot => x | Value v' => Value (sup v v')))"
+
+instance proof
+qed (auto simp add: sup_bot_def less_eq_bot_def split: bot.splits)
+
+end
+
+instance bot :: (lattice) bounded_lattice_bot
+by(intro_classes)(simp add: bot_bot_def)
+
+section {* Values extended by a top element *}
+
+datatype 'a top = Value 'a | Top
+
+instantiation top :: (preorder) preorder
+begin
+
+definition less_eq_top where
+  "x \<le> y \<longleftrightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> x \<le> y))"
+
+definition less_top where
+  "x < y \<longleftrightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> x < y))"
+
+lemma less_eq_top_Top [simp]: "x <= Top"
+  by (simp add: less_eq_top_def)
+
+lemma less_eq_top_Top_code [code]: "x \<le> Top \<longleftrightarrow> True"
+  by simp
+
+lemma less_eq_top_is_Top: "Top \<le> x \<Longrightarrow> x = Top"
+  by (cases x) (simp_all add: less_eq_top_def)
+
+lemma less_eq_top_Top_Value [simp, code]: "Top \<le> Value x \<longleftrightarrow> False"
+  by (simp add: less_eq_top_def)
+
+lemma less_eq_top_Value_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
+  by (simp add: less_eq_top_def)
+
+lemma less_top_Top [simp, code]: "Top < x \<longleftrightarrow> False"
+  by (simp add: less_top_def)
+
+lemma less_top_Top_is_Value: "x < Top \<Longrightarrow> \<exists>z. x = Value z"
+  by (cases x) (simp_all add: less_top_def)
+
+lemma less_top_Value_Top [simp]: "Value x < Top"
+  by (simp add: less_top_def)
+
+lemma less_top_Value_Top_code [code]: "Value x < Top \<longleftrightarrow> True"
+  by simp
+
+lemma less_top_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
+  by (simp add: less_top_def)
+
+instance proof
+qed (auto simp add: less_eq_top_def less_top_def less_le_not_le elim: order_trans split: top.splits)
+
+end 
+
+instance top :: (order) order proof
+qed (auto simp add: less_eq_top_def less_top_def split: top.splits)
+
+instance top :: (linorder) linorder proof
+qed (auto simp add: less_eq_top_def less_top_def split: top.splits)
+
+instantiation top :: (order) top
+begin
+
+definition "top = Top"
+
+instance ..
+
+end
+
+instantiation top :: (bot) bot
+begin
+
+definition "bot = Value bot"
+
+instance ..
+
+end
+
+instantiation top :: (semilattice_inf) semilattice_inf
+begin
+
+definition inf_top
+where
+  "inf x y = (case x of Top => y | Value v => (case y of Top => x | Value v' => Value (inf v v')))"
+
+instance proof
+qed (auto simp add: inf_top_def less_eq_top_def split: top.splits)
+
+end
+
+instantiation top :: (semilattice_sup) semilattice_sup
+begin
+
+definition sup_top
+where
+  "sup x y = (case x of Top => Top | Value v => (case y of Top => Top | Value v' => Value (sup v v')))"
+
+instance proof
+qed (auto simp add: sup_top_def less_eq_top_def split: top.splits)
+
+end
+
+instance top :: (lattice) bounded_lattice_top
+by(intro_classes)(simp add: top_top_def)
+
+subsection {* Values extended by a top and a bottom element *}
+
+datatype 'a flat_complete_lattice = Value 'a | Bot | Top
+
+instantiation flat_complete_lattice :: (type) order
+begin
+
+definition less_eq_flat_complete_lattice where
+  "x \<le> y == (case x of Bot => True | Value v1 => (case y of Bot => False | Value v2 => (v1 = v2) | Top => True) | Top => (y = Top))"
+
+definition less_flat_complete_lattice where
+  "x < y = (case x of Bot => \<not> (y = Bot) | Value v1 => (y = Top) | Top => False)"
+
+lemma [simp]: "Bot <= y"
+unfolding less_eq_flat_complete_lattice_def by auto
+
+lemma [simp]: "y <= Top"
+unfolding less_eq_flat_complete_lattice_def by (auto split: flat_complete_lattice.splits)
+
+lemma greater_than_two_values:
+  assumes "a ~= aa" "Value a <= z" "Value aa <= z"
+  shows "z = Top"
+using assms
+by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)
+
+lemma lesser_than_two_values:
+  assumes "a ~= aa" "z <= Value a" "z <= Value aa"
+  shows "z = Bot"
+using assms
+by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)
+
+instance proof
+qed (auto simp add: less_eq_flat_complete_lattice_def less_flat_complete_lattice_def split: flat_complete_lattice.splits)
+
+end
+
+instantiation flat_complete_lattice :: (type) bot
+begin
+
+definition "bot = Bot"
+
+instance ..
+
+end
+
+instantiation flat_complete_lattice :: (type) top
+begin
+
+definition "top = Top"
+
+instance ..
+
+end
+
+instantiation flat_complete_lattice :: (type) lattice
+begin
+
+definition inf_flat_complete_lattice
+where
+  "inf x y = (case x of Bot => Bot | Value v1 => (case y of Bot => Bot | Value v2 => if (v1 = v2) then x else Bot | Top => x) | Top => y)"
+
+definition sup_flat_complete_lattice
+where
+  "sup x y = (case x of Bot => y | Value v1 => (case y of Bot => x | Value v2 => if v1 = v2 then x else Top | Top => Top) | Top => Top)"
+
+instance proof
+qed (auto simp add: inf_flat_complete_lattice_def sup_flat_complete_lattice_def less_eq_flat_complete_lattice_def split: flat_complete_lattice.splits)
+
+end
+
+instantiation flat_complete_lattice :: (type) complete_lattice
+begin
+
+definition Sup_flat_complete_lattice
+where
+  "Sup A = (if (A = {} \<or> A = {Bot}) then Bot else (if (\<exists> v. A - {Bot} = {Value v}) then Value (THE v. A - {Bot} = {Value v}) else Top))"
+
+definition Inf_flat_complete_lattice
+where
+  "Inf A = (if (A = {} \<or> A = {Top}) then Top else (if (\<exists> v. A - {Top} = {Value v}) then Value (THE v. A - {Top} = {Value v}) else Bot))"
+ 
+instance
+proof
+  fix x A
+  assume "(x :: 'a flat_complete_lattice) : A"
+  {
+    fix v
+    assume "A - {Top} = {Value v}"
+    from this have "(THE v. A - {Top} = {Value v}) = v"
+      by (auto intro!: the1_equality)
+    moreover
+    from `x : A` `A - {Top} = {Value v}` have "x = Top \<or> x = Value v"
+      by auto
+    ultimately have "Value (THE v. A - {Top} = {Value v}) <= x"
+      by auto
+  }
+  from `x : A` this show "Inf A <= x"
+    unfolding Inf_flat_complete_lattice_def
+    by fastforce
+next
+  fix z A
+  assume z: "\<And>x. x : A ==> z <= (x :: 'a flat_complete_lattice)"
+  {
+    fix v
+    assume "A - {Top} = {Value v}"
+    moreover
+    from this have "(THE v. A - {Top} = {Value v}) = v"
+      by (auto intro!: the1_equality)
+    moreover
+    note z
+    moreover
+    ultimately have "z <= Value (THE v::'a. A - {Top} = {Value v})"
+      by auto
+  } moreover
+  {
+    assume not_one_value: "A ~= {}" "A ~= {Top}" "~ (EX v::'a. A - {Top} = {Value v})"
+    have "z <= Bot"
+    proof (cases "A - {Top} = {Bot}")
+      case True
+      from this z show ?thesis
+        by auto
+    next
+      case False
+      from not_one_value
+      obtain a1 where a1: "a1 : A - {Top}" by auto
+      from not_one_value False a1
+      obtain a2 where "a2 : A - {Top} \<and> a1 \<noteq> a2"
+        by (cases a1) auto
+      from this a1 z[of "a1"] z[of "a2"] show ?thesis
+        apply (cases a1)
+        apply auto
+        apply (cases a2)
+        apply auto
+        apply (auto dest!: lesser_than_two_values)
+        done
+    qed
+  } moreover
+  note z moreover
+  ultimately show "z <= Inf A"
+    unfolding Inf_flat_complete_lattice_def
+    by auto
+next
+  fix x A
+  assume "(x :: 'a flat_complete_lattice) : A"
+  {
+    fix v
+    assume "A - {Bot} = {Value v}"
+    from this have "(THE v. A - {Bot} = {Value v}) = v"
+      by (auto intro!: the1_equality)
+    moreover
+    from `x : A` `A - {Bot} = {Value v}` have "x = Bot \<or> x = Value v"
+      by auto
+    ultimately have "x <= Value (THE v. A - {Bot} = {Value v})"
+      by auto
+  }
+  from `x : A` this show "x <= Sup A"
+    unfolding Sup_flat_complete_lattice_def
+    by fastforce
+next
+  fix z A
+  assume z: "\<And>x. x : A ==> x <= (z :: 'a flat_complete_lattice)"
+  {
+    fix v
+    assume "A - {Bot} = {Value v}"
+    moreover
+    from this have "(THE v. A - {Bot} = {Value v}) = v"
+      by (auto intro!: the1_equality)
+    moreover
+    note z
+    moreover
+    ultimately have "Value (THE v::'a. A - {Bot} = {Value v}) <= z"
+      by auto
+  } moreover
+  {
+    assume not_one_value: "A ~= {}" "A ~= {Bot}" "~ (EX v::'a. A - {Bot} = {Value v})"
+    have "Top <= z"
+    proof (cases "A - {Bot} = {Top}")
+      case True
+      from this z show ?thesis
+        by auto
+    next
+      case False
+      from not_one_value
+      obtain a1 where a1: "a1 : A - {Bot}" by auto
+      from not_one_value False a1
+      obtain a2 where "a2 : A - {Bot} \<and> a1 \<noteq> a2"
+        by (cases a1) auto
+      from this a1 z[of "a1"] z[of "a2"] show ?thesis
+        apply (cases a1)
+        apply auto
+        apply (cases a2)
+        apply (auto dest!: greater_than_two_values)
+        done
+    qed
+  } moreover
+  note z moreover
+  ultimately show "Sup A <= z"
+    unfolding Sup_flat_complete_lattice_def
+    by auto
+next
+  show "Inf {} = (top :: 'a flat_complete_lattice)"
+    by(simp add: Inf_flat_complete_lattice_def top_flat_complete_lattice_def)
+next
+  show "Sup {} = (bot :: 'a flat_complete_lattice)"
+    by(simp add: Sup_flat_complete_lattice_def bot_flat_complete_lattice_def)
+qed
+
+end
+
+end
\ No newline at end of file
--- a/src/HOL/Library/Library.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Library.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -32,6 +32,7 @@
   IArray
   Lattice_Algebras
   Lattice_Syntax
+  Lattice_Constructions
   ListVector
   Lubs_Glbs
   Mapping
--- a/src/HOL/Library/Multiset.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Multiset.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -530,6 +530,17 @@
   "Multiset.filter P (M #\<inter> N) = Multiset.filter P M #\<inter> Multiset.filter P N"
   by (rule multiset_eqI) simp
 
+lemma multiset_filter_subset[simp]: "Multiset.filter f M \<le> M"
+  unfolding less_eq_multiset.rep_eq by auto
+
+lemma multiset_filter_mono: assumes "A \<le> B"
+  shows "Multiset.filter f A \<le> Multiset.filter f B"
+proof -
+  from assms[unfolded mset_le_exists_conv]
+  obtain C where B: "B = A + C" by auto
+  show ?thesis unfolding B by auto
+qed
+
 syntax
   "_MCollect" :: "pttrn \<Rightarrow> 'a multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"    ("(1{# _ :# _./ _#})")
 syntax (xsymbol)
@@ -1325,6 +1336,17 @@
   "mcard (multiset_of xs) = length xs"
   by (induct xs) simp_all
 
+lemma mcard_mono: assumes "A \<le> B"
+  shows "mcard A \<le> mcard B"
+proof -
+  from assms[unfolded mset_le_exists_conv]
+  obtain C where B: "B = A + C" by auto
+  show ?thesis unfolding B by (induct C, auto)
+qed
+
+lemma mcard_filter_lesseq[simp]: "mcard (Multiset.filter f M) \<le> mcard M"
+  by (rule mcard_mono[OF multiset_filter_subset])
+
 
 subsection {* Alternative representations *}
 
@@ -2224,697 +2246,214 @@
 
 subsection {* BNF setup *}
 
-lemma setsum_gt_0_iff:
-fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
-shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
-(is "?L \<longleftrightarrow> ?R")
-proof-
-  have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
-  also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
-  also have "... \<longleftrightarrow> ?R" by simp
-  finally show ?thesis .
-qed
-
-lift_definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" is
-  "\<lambda>h f b. setsum f {a. h a = b \<and> f a > 0} :: nat"
-unfolding multiset_def proof safe
-  fix h :: "'a \<Rightarrow> 'b" and f :: "'a \<Rightarrow> nat"
-  assume fin: "finite {a. 0 < f a}"  (is "finite ?A")
-  show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
-  (is "finite {b. 0 < setsum f (?As b)}")
-  proof- let ?B = "{b. 0 < setsum f (?As b)}"
-    have "\<And> b. finite (?As b)" using fin by simp
-    hence B: "?B = {b. ?As b \<noteq> {}}" by (auto simp add: setsum_gt_0_iff)
-    hence "?B \<subseteq> h ` ?A" by auto
-    thus ?thesis using finite_surj[OF fin] by auto
-  qed
-qed
-
-lemma mmap_id0: "mmap id = id"
-proof (intro ext multiset_eqI)
-  fix f a show "count (mmap id f) a = count (id f) a"
-  proof (cases "count f a = 0")
-    case False
-    hence 1: "{aa. aa = a \<and> aa \<in># f} = {a}" by auto
-    thus ?thesis by transfer auto
-  qed (transfer, simp)
-qed
-
-lemma inj_on_setsum_inv:
-assumes 1: "(0::nat) < setsum (count f) {a. h a = b' \<and> a \<in># f}" (is "0 < setsum (count f) ?A'")
-and     2: "{a. h a = b \<and> a \<in># f} = {a. h a = b' \<and> a \<in># f}" (is "?A = ?A'")
-shows "b = b'"
-using assms by (auto simp add: setsum_gt_0_iff)
-
-lemma mmap_comp:
-fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
-shows "mmap (h2 o h1) = mmap h2 o mmap h1"
-proof (intro ext multiset_eqI)
-  fix f :: "'a multiset" fix c :: 'c
-  let ?A = "{a. h2 (h1 a) = c \<and> a \<in># f}"
-  let ?As = "\<lambda> b. {a. h1 a = b \<and> a \<in># f}"
-  let ?B = "{b. h2 b = c \<and> 0 < setsum (count f) (?As b)}"
-  have 0: "{?As b | b.  b \<in> ?B} = ?As ` ?B" by auto
-  have "\<And> b. finite (?As b)" by transfer (simp add: multiset_def)
-  hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" by (auto simp add: setsum_gt_0_iff)
-  hence A: "?A = \<Union> {?As b | b.  b \<in> ?B}" by auto
-  have "setsum (count f) ?A = setsum (setsum (count f)) {?As b | b.  b \<in> ?B}"
-    unfolding A by transfer (intro setsum.Union_disjoint [simplified], auto simp: multiset_def setsum.Union_disjoint)
-  also have "... = setsum (setsum (count f)) (?As ` ?B)" unfolding 0 ..
-  also have "... = setsum (setsum (count f) o ?As) ?B"
-    by (intro setsum.reindex) (auto simp add: setsum_gt_0_iff inj_on_def)
-  also have "... = setsum (\<lambda> b. setsum (count f) (?As b)) ?B" unfolding comp_def ..
-  finally have "setsum (count f) ?A = setsum (\<lambda> b. setsum (count f) (?As b)) ?B" .
-  thus "count (mmap (h2 \<circ> h1) f) c = count ((mmap h2 \<circ> mmap h1) f) c"
-    by transfer (unfold comp_apply, blast)
-qed
-
-lemma mmap_cong:
-assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
-shows "mmap f M = mmap g M"
-using assms by transfer (auto intro!: setsum.cong)
-
-context
-begin
-interpretation lifting_syntax .
-
-lemma set_of_transfer[transfer_rule]: "(pcr_multiset op = ===> op =) (\<lambda>f. {a. 0 < f a}) set_of"
-  unfolding set_of_def pcr_multiset_def cr_multiset_def rel_fun_def by auto
-
-end
-
-lemma set_of_mmap: "set_of o mmap h = image h o set_of"
-proof (rule ext, unfold comp_apply)
-  fix M show "set_of (mmap h M) = h ` set_of M"
-    by transfer (auto simp add: multiset_def setsum_gt_0_iff)
-qed
-
-lemma multiset_of_surj:
-  "multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
-proof safe
-  fix M assume M: "set_of M \<subseteq> A"
-  obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
-  hence "set as \<subseteq> A" using M by auto
-  thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
+definition rel_mset where
+  "rel_mset R X Y \<longleftrightarrow> (\<exists>xs ys. multiset_of xs = X \<and> multiset_of ys = Y \<and> list_all2 R xs ys)"
+
+lemma multiset_of_zip_take_Cons_drop_twice:
+  assumes "length xs = length ys" "j \<le> length xs"
+  shows "multiset_of (zip (take j xs @ x # drop j xs) (take j ys @ y # drop j ys)) =
+    multiset_of (zip xs ys) + {#(x, y)#}"
+using assms
+proof (induct xs ys arbitrary: x y j rule: list_induct2)
+  case Nil
+  thus ?case
+    by simp
 next
-  show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
-  by (erule set_mp) (unfold set_of_multiset_of)
-qed
-
-lemma card_of_set_of:
-"(card_of {M. set_of M \<subseteq> A}, card_of {as. set as \<subseteq> A}) \<in> ordLeq"
-apply(rule surj_imp_ordLeq[of _ multiset_of]) using multiset_of_surj by auto
-
-lemma nat_sum_induct:
-assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
-shows "phi (n1::nat) (n2::nat)"
-proof-
-  let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
-  have "?chi (n1,n2)"
-  apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
-  using assms by (metis fstI sndI)
-  thus ?thesis by simp
-qed
-
-lemma matrix_count:
-fixes ct1 ct2 :: "nat \<Rightarrow> nat"
-assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
-shows
-"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
-       (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
-(is "?phi ct1 ct2 n1 n2")
-proof-
-  have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
-        setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
-  proof(induct rule: nat_sum_induct[of
-"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
-     setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
-      clarify)
-  fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
-  assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
-                \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
-                setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
-  and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
-  show "?phi ct1 ct2 n1 n2"
-  proof(cases n1)
-    case 0 note n1 = 0
-    show ?thesis
-    proof(cases n2)
-      case 0 note n2 = 0
-      let ?ct = "\<lambda> i1 i2. ct2 0"
-      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
-    next
-      case (Suc m2) note n2 = Suc
-      let ?ct = "\<lambda> i1 i2. ct2 i2"
-      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
-    qed
+  case (Cons x xs y ys)
+  thus ?case
+  proof (cases "j = 0")
+    case True
+    thus ?thesis
+      by simp
   next
-    case (Suc m1) note n1 = Suc
-    show ?thesis
-    proof(cases n2)
-      case 0 note n2 = 0
-      let ?ct = "\<lambda> i1 i2. ct1 i1"
-      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
-    next
-      case (Suc m2) note n2 = Suc
-      show ?thesis
-      proof(cases "ct1 n1 \<le> ct2 n2")
-        case True
-        def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
-        have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
-        unfolding dt2_def using ss n1 True by auto
-        hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
-        then obtain dt where
-        1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
-        2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
-        let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
-                                       else dt i1 i2"
-        show ?thesis apply(rule exI[of _ ?ct])
-        using n1 n2 1 2 True unfolding dt2_def by simp
-      next
-        case False
-        hence False: "ct2 n2 < ct1 n1" by simp
-        def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
-        have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
-        unfolding dt1_def using ss n2 False by auto
-        hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
-        then obtain dt where
-        1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
-        2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
-        let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
-                                       else dt i1 i2"
-        show ?thesis apply(rule exI[of _ ?ct])
-        using n1 n2 1 2 False unfolding dt1_def by simp
-      qed
-    qed
-  qed
-  qed
-  thus ?thesis using assms by auto
-qed
-
-definition
-"inj2 u B1 B2 \<equiv>
- \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
-                  \<longrightarrow> b1 = b1' \<and> b2 = b2'"
-
-lemma matrix_setsum_finite:
-assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
-and ss: "setsum N1 B1 = setsum N2 B2"
-shows "\<exists> M :: 'a \<Rightarrow> nat.
-            (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
-            (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
-proof-
-  obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
-  then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
-  using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
-  hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
-  unfolding bij_betw_def by auto
-  def f1 \<equiv> "inv_into {..<Suc n1} e1"
-  have f1: "bij_betw f1 B1 {..<Suc n1}"
-  and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
-  and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
-  apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
-  by (metis e1_surj f_inv_into_f)
-  (*  *)
-  obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
-  then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
-  using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
-  hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
-  unfolding bij_betw_def by auto
-  def f2 \<equiv> "inv_into {..<Suc n2} e2"
-  have f2: "bij_betw f2 B2 {..<Suc n2}"
-  and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
-  and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
-  apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
-  by (metis e2_surj f_inv_into_f)
-  (*  *)
-  let ?ct1 = "N1 o e1"  let ?ct2 = "N2 o e2"
-  have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
-  unfolding setsum.reindex[OF e1_inj, symmetric] setsum.reindex[OF e2_inj, symmetric]
-  e1_surj e2_surj using ss .
-  obtain ct where
-  ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
-  ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
-  using matrix_count[OF ss] by blast
-  (*  *)
-  def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
-  have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
-  unfolding A_def Ball_def mem_Collect_eq by auto
-  then obtain h1h2 where h12:
-  "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
-  def h1 \<equiv> "fst o h1h2"  def h2 \<equiv> "snd o h1h2"
-  have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
-                  "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1"  "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
-  using h12 unfolding h1_def h2_def by force+
-  {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
-   hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
-   hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
-   moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
-   ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
-   using u b1 b2 unfolding inj2_def by fastforce
-  }
-  hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
-        h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
-  def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
-  show ?thesis
-  apply(rule exI[of _ M]) proof safe
-    fix b1 assume b1: "b1 \<in> B1"
-    hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
-    by (metis image_eqI lessThan_iff less_Suc_eq_le)
-    have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
-    unfolding e2_surj[symmetric] setsum.reindex[OF e2_inj]
-    unfolding M_def comp_def apply(intro setsum.cong) apply force
-    by (metis e2_surj b1 h1 h2 imageI)
-    also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
-    finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
-  next
-    fix b2 assume b2: "b2 \<in> B2"
-    hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
-    by (metis image_eqI lessThan_iff less_Suc_eq_le)
-    have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
-    unfolding e1_surj[symmetric] setsum.reindex[OF e1_inj]
-    unfolding M_def comp_def apply(intro setsum.cong) apply force
-    by (metis e1_surj b2 h1 h2 imageI)
-    also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
-    finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
-  qed
-qed
-
-lemma supp_vimage_mmap: "set_of M \<subseteq> f -` (set_of (mmap f M))"
-  by transfer (auto simp: multiset_def setsum_gt_0_iff)
-
-lemma mmap_ge_0: "b \<in># mmap f M \<longleftrightarrow> (\<exists>a. a \<in># M \<and> f a = b)"
-  by transfer (auto simp: multiset_def setsum_gt_0_iff)
-
-lemma finite_twosets:
-assumes "finite B1" and "finite B2"
-shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"  (is "finite ?A")
-proof-
-  have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
-  show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
+    case False
+    then obtain k where k: "j = Suc k"
+      by (case_tac j) simp
+    hence "k \<le> length xs"
+      using Cons.prems by auto
+    hence "multiset_of (zip (take k xs @ x # drop k xs) (take k ys @ y # drop k ys)) =
+      multiset_of (zip xs ys) + {#(x, y)#}"
+      by (rule Cons.hyps(2))
+    thus ?thesis
+      unfolding k by (auto simp: add.commute union_lcomm)
+  qed      
 qed
 
-(* Weak pullbacks: *)
-definition wpull where
-"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
- (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow> (\<exists> a \<in> A. p1 a = b1 \<and> p2 a = b2))"
-
-(* Weak pseudo-pullbacks *)
-definition wppull where
-"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
- (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
-           (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
-
-
-(* The pullback of sets *)
-definition thePull where
-"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
-
-lemma wpull_thePull:
-"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
-unfolding wpull_def thePull_def by auto
-
-lemma wppull_thePull:
-assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
-shows
-"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
-   j a' \<in> A \<and>
-   e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
-(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
-proof(rule bchoice[of ?A' ?phi], default)
-  fix a' assume a': "a' \<in> ?A'"
-  hence "fst a' \<in> B1" unfolding thePull_def by auto
-  moreover
-  from a' have "snd a' \<in> B2" unfolding thePull_def by auto
-  moreover have "f1 (fst a') = f2 (snd a')"
-  using a' unfolding csquare_def thePull_def by auto
-  ultimately show "\<exists> ja'. ?phi a' ja'"
-  using assms unfolding wppull_def by blast
-qed
-
-lemma wpull_wppull:
-assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
-1: "\<forall> a' \<in> A'. j a' \<in> A \<and> e1 (p1 (j a')) = e1 (p1' a') \<and> e2 (p2 (j a')) = e2 (p2' a')"
-shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
-unfolding wppull_def proof safe
-  fix b1 b2
-  assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
-  then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
-  using wp unfolding wpull_def by blast
-  show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
-  apply (rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
+lemma ex_multiset_of_zip_left:
+  assumes "length xs = length ys" "multiset_of xs' = multiset_of xs"
+  shows "\<exists>ys'. length ys' = length xs' \<and> multiset_of (zip xs' ys') = multiset_of (zip xs ys)"
+using assms 
+proof (induct xs ys arbitrary: xs' rule: list_induct2)
+  case Nil
+  thus ?case
+    by auto
+next
+  case (Cons x xs y ys xs')
+  obtain j where j_len: "j < length xs'" and nth_j: "xs' ! j = x"
+  proof -
+    assume "\<And>j. \<lbrakk>j < length xs'; xs' ! j = x\<rbrakk> \<Longrightarrow> ?thesis"
+    moreover have "\<And>k m n. (m\<Colon>nat) + n < m + k \<or> \<not> n < k" by linarith
+    moreover have "\<And>n a as. n - n < length (a # as) \<or> n < n"
+      by (metis Nat.add_diff_inverse diff_add_inverse2 impossible_Cons le_add1
+        less_diff_conv not_add_less2)
+    moreover have "\<not> length xs' < length xs'" by blast
+    ultimately show ?thesis
+      by (metis (no_types) Cons.prems Nat.add_diff_inverse diff_add_inverse2 length_append
+        less_diff_conv list.set_intros(1) multiset_of_eq_setD nth_append_length split_list)
+  qed
+
+  def xsa \<equiv> "take j xs' @ drop (Suc j) xs'" 
+  have "multiset_of xs' = {#x#} + multiset_of xsa"
+    unfolding xsa_def using j_len nth_j
+    by (metis (no_types) ab_semigroup_add_class.add_ac(1) append_take_drop_id drop_Suc_conv_tl
+      multiset_of.simps(2) union_code union_commute)
+  hence ms_x: "multiset_of xsa = multiset_of xs"
+    by (metis Cons.prems add.commute add_right_imp_eq multiset_of.simps(2))
+  then obtain ysa where
+    len_a: "length ysa = length xsa" and ms_a: "multiset_of (zip xsa ysa) = multiset_of (zip xs ys)"
+    using Cons.hyps(2) by blast
+
+  def ys' \<equiv> "take j ysa @ y # drop j ysa"
+  have xs': "xs' = take j xsa @ x # drop j xsa"
+    using ms_x j_len nth_j Cons.prems xsa_def
+    by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc drop_Suc_conv_tl length_Cons
+      length_drop mcard_multiset_of)
+  have j_len': "j \<le> length xsa"
+    using j_len xs' xsa_def
+    by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
+  have "length ys' = length xs'"
+    unfolding ys'_def using Cons.prems len_a ms_x
+    by (metis add_Suc_right append_take_drop_id length_Cons length_append multiset_of_eq_length)
+  moreover have "multiset_of (zip xs' ys') = multiset_of (zip (x # xs) (y # ys))"
+    unfolding xs' ys'_def
+    by (rule trans[OF multiset_of_zip_take_Cons_drop_twice])
+      (auto simp: len_a ms_a j_len' add.commute)
+  ultimately show ?case
+    by blast
 qed
 
-lemma wppull_fstOp_sndOp:
-shows "wppull (Collect (split (P OO Q))) (Collect (split P)) (Collect (split Q))
-  snd fst fst snd (BNF_Def.fstOp P Q) (BNF_Def.sndOp P Q)"
-using pick_middlep unfolding wppull_def fstOp_def sndOp_def relcompp.simps by auto
-
-lemma wpull_mmap:
-fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
-assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
-shows
-"wpull {M. set_of M \<subseteq> A}
-       {N1. set_of N1 \<subseteq> B1} {N2. set_of N2 \<subseteq> B2}
-       (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
-unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
-  fix N1 :: "'b1 multiset" and N2 :: "'b2 multiset"
-  assume mmap': "mmap f1 N1 = mmap f2 N2"
-  and N1[simp]: "set_of N1 \<subseteq> B1"
-  and N2[simp]: "set_of N2 \<subseteq> B2"
-  def P \<equiv> "mmap f1 N1"
-  have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
-  note P = P1 P2
-  have fin_N1[simp]: "finite (set_of N1)"
-   and fin_N2[simp]: "finite (set_of N2)"
-   and fin_P[simp]: "finite (set_of P)" by auto
-
-  def set1 \<equiv> "\<lambda> c. {b1 \<in> set_of N1. f1 b1 = c}"
-  have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
-  have fin_set1: "\<And> c. c \<in> set_of P \<Longrightarrow> finite (set1 c)"
-    using N1(1) unfolding set1_def multiset_def by auto
-  have set1_NE: "\<And> c. c \<in> set_of P \<Longrightarrow> set1 c \<noteq> {}"
-   unfolding set1_def set_of_def P mmap_ge_0 by auto
-  have supp_N1_set1: "set_of N1 = (\<Union> c \<in> set_of P. set1 c)"
-    using supp_vimage_mmap[of N1 f1] unfolding set1_def P1 by auto
-  hence set1_inclN1: "\<And>c. c \<in> set_of P \<Longrightarrow> set1 c \<subseteq> set_of N1" by auto
-  hence set1_incl: "\<And> c. c \<in> set_of P \<Longrightarrow> set1 c \<subseteq> B1" using N1 by blast
-  have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
-    unfolding set1_def by auto
-  have setsum_set1: "\<And> c. setsum (count N1) (set1 c) = count P c"
-    unfolding P1 set1_def by transfer (auto intro: setsum.cong)
-
-  def set2 \<equiv> "\<lambda> c. {b2 \<in> set_of N2. f2 b2 = c}"
-  have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
-  have fin_set2: "\<And> c. c \<in> set_of P \<Longrightarrow> finite (set2 c)"
-  using N2(1) unfolding set2_def multiset_def by auto
-  have set2_NE: "\<And> c. c \<in> set_of P \<Longrightarrow> set2 c \<noteq> {}"
-    unfolding set2_def P2 mmap_ge_0 set_of_def by auto
-  have supp_N2_set2: "set_of N2 = (\<Union> c \<in> set_of P. set2 c)"
-    using supp_vimage_mmap[of N2 f2] unfolding set2_def P2 by auto
-  hence set2_inclN2: "\<And>c. c \<in> set_of P \<Longrightarrow> set2 c \<subseteq> set_of N2" by auto
-  hence set2_incl: "\<And> c. c \<in> set_of P \<Longrightarrow> set2 c \<subseteq> B2" using N2 by blast
-  have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
-    unfolding set2_def by auto
-  have setsum_set2: "\<And> c. setsum (count N2) (set2 c) = count P c"
-    unfolding P2 set2_def by transfer (auto intro: setsum.cong)
-
-  have ss: "\<And> c. c \<in> set_of P \<Longrightarrow> setsum (count N1) (set1 c) = setsum (count N2) (set2 c)"
-    unfolding setsum_set1 setsum_set2 ..
-  have "\<forall> c \<in> set_of P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
-          \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
-    using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
-    by simp (metis set1 set2 set_rev_mp)
-  then obtain uu where uu:
-  "\<forall> c \<in> set_of P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
-     uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
-  def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
-  have u[simp]:
-  "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> A"
-  "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p1 (u c b1 b2) = b1"
-  "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p2 (u c b1 b2) = b2"
-    using uu unfolding u_def by auto
-  {fix c assume c: "c \<in> set_of P"
-   have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
-     fix b1 b1' b2 b2'
-     assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
-     hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
-            p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
-     using u(2)[OF c] u(3)[OF c] by simp metis
-     thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
-   qed
-  } note inj = this
-  def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
-  have fin_sset[simp]: "\<And> c. c \<in> set_of P \<Longrightarrow> finite (sset c)" unfolding sset_def
-    using fin_set1 fin_set2 finite_twosets by blast
-  have sset_A: "\<And> c. c \<in> set_of P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
-  {fix c a assume c: "c \<in> set_of P" and ac: "a \<in> sset c"
-   then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
-   and a: "a = u c b1 b2" unfolding sset_def by auto
-   have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
-   using ac a b1 b2 c u(2) u(3) by simp+
-   hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
-   unfolding inj2_def by (metis c u(2) u(3))
-  } note u_p12[simp] = this
-  {fix c a assume c: "c \<in> set_of P" and ac: "a \<in> sset c"
-   hence "p1 a \<in> set1 c" unfolding sset_def by auto
-  }note p1[simp] = this
-  {fix c a assume c: "c \<in> set_of P" and ac: "a \<in> sset c"
-   hence "p2 a \<in> set2 c" unfolding sset_def by auto
-  }note p2[simp] = this
-
-  {fix c assume c: "c \<in> set_of P"
-   hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = count N1 b1) \<and>
-               (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = count N2 b2)"
-   unfolding sset_def
-   using matrix_setsum_finite[OF set1_NE[OF c] fin_set1[OF c]
-                                 set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
-  }
-  then obtain Ms where
-  ss1: "\<And> c b1. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
-                   setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = count N1 b1" and
-  ss2: "\<And> c b2. \<lbrakk>c \<in> set_of P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
-                   setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = count N2 b2"
-  by metis
-  def SET \<equiv> "\<Union> c \<in> set_of P. sset c"
-  have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
-  have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by blast
-  have u_SET[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> SET"
-    unfolding SET_def sset_def by blast
-  {fix c a assume c: "c \<in> set_of P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
-   then obtain c' where c': "c' \<in> set_of P" and ac': "a \<in> sset c'"
-    unfolding SET_def by auto
-   hence "p1 a \<in> set1 c'" unfolding sset_def by auto
-   hence eq: "c = c'" using p1a c c' set1_disj by auto
-   hence "a \<in> sset c" using ac' by simp
-  } note p1_rev = this
-  {fix c a assume c: "c \<in> set_of P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
-   then obtain c' where c': "c' \<in> set_of P" and ac': "a \<in> sset c'"
-   unfolding SET_def by auto
-   hence "p2 a \<in> set2 c'" unfolding sset_def by auto
-   hence eq: "c = c'" using p2a c c' set2_disj by auto
-   hence "a \<in> sset c" using ac' by simp
-  } note p2_rev = this
-
-  have "\<forall> a \<in> SET. \<exists> c \<in> set_of P. a \<in> sset c" unfolding SET_def by auto
-  then obtain h where h: "\<forall> a \<in> SET. h a \<in> set_of P \<and> a \<in> sset (h a)" by metis
-  have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
-                      \<Longrightarrow> h (u c b1 b2) = c"
-  by (metis h p2 set2 u(3) u_SET)
-  have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
-                      \<Longrightarrow> h (u c b1 b2) = f1 b1"
-  using h unfolding sset_def by auto
-  have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> set_of P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
-                      \<Longrightarrow> h (u c b1 b2) = f2 b2"
-  using h unfolding sset_def by auto
-  def M \<equiv>
-    "Abs_multiset (\<lambda> a. if a \<in> SET \<and> p1 a \<in> set_of N1 \<and> p2 a \<in> set_of N2 then Ms (h a) a else 0)"
-  have "(\<lambda> a. if a \<in> SET \<and> p1 a \<in> set_of N1 \<and> p2 a \<in> set_of N2 then Ms (h a) a else 0) \<in> multiset"
-    unfolding multiset_def by auto
-  hence [transfer_rule]: "pcr_multiset op = (\<lambda> a. if a \<in> SET \<and> p1 a \<in> set_of N1 \<and> p2 a \<in> set_of N2 then Ms (h a) a else 0) M"
-    unfolding M_def pcr_multiset_def cr_multiset_def by (auto simp: Abs_multiset_inverse)
-  have sM: "set_of M \<subseteq> SET" "set_of M \<subseteq> p1 -` (set_of N1)" "set_of M \<subseteq> p2 -` set_of N2"
-    by (transfer, auto split: split_if_asm)+
-  show "\<exists>M. set_of M \<subseteq> A \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
-  proof(rule exI[of _ M], safe)
-    fix a assume *: "a \<in> set_of M"
-    from SET_A show "a \<in> A"
-    proof (cases "a \<in> SET")
-      case False thus ?thesis using * by transfer' auto
-    qed blast
-  next
-    show "mmap p1 M = N1"
-    proof(intro multiset_eqI)
-      fix b1
-      let ?K = "{a. p1 a = b1 \<and> a \<in># M}"
-      have "setsum (count M) ?K = count N1 b1"
-      proof(cases "b1 \<in> set_of N1")
-        case False
-        hence "?K = {}" using sM(2) by auto
-        thus ?thesis using False by auto
-      next
-        case True
-        def c \<equiv> "f1 b1"
-        have c: "c \<in> set_of P" and b1: "b1 \<in> set1 c"
-          unfolding set1_def c_def P1 using True by (auto simp: comp_eq_dest[OF set_of_mmap])
-        with sM(1) have "setsum (count M) ?K = setsum (count M) {a. p1 a = b1 \<and> a \<in> SET}"
-          by transfer (force intro: setsum.mono_neutral_cong_left split: split_if_asm)
-        also have "... = setsum (count M) ((\<lambda> b2. u c b1 b2) ` (set2 c))"
-          apply(rule setsum.cong) using c b1 proof safe
-          fix a assume p1a: "p1 a \<in> set1 c" and "c \<in> set_of P" and "a \<in> SET"
-          hence ac: "a \<in> sset c" using p1_rev by auto
-          hence "a = u c (p1 a) (p2 a)" using c by auto
-          moreover have "p2 a \<in> set2 c" using ac c by auto
-          ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
-        qed auto
-        also have "... = setsum (\<lambda> b2. count M (u c b1 b2)) (set2 c)"
-          unfolding comp_def[symmetric] apply(rule setsum.reindex)
-          using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
-        also have "... = count N1 b1" unfolding ss1[OF c b1, symmetric]
-          apply(rule setsum.cong[OF refl]) apply (transfer fixing: Ms u c b1 set2)
-          using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1]
-            [[hypsubst_thin = true]]
-          by fastforce
-        finally show ?thesis .
-      qed
-      thus "count (mmap p1 M) b1 = count N1 b1" by transfer
-    qed
-  next
-    show "mmap p2 M = N2"
-    proof(intro multiset_eqI)
-      fix b2
-      let ?K = "{a. p2 a = b2 \<and> a \<in># M}"
-      have "setsum (count M) ?K = count N2 b2"
-      proof(cases "b2 \<in> set_of N2")
-        case False
-        hence "?K = {}" using sM(3) by auto
-        thus ?thesis using False by auto
-      next
-        case True
-        def c \<equiv> "f2 b2"
-        have c: "c \<in> set_of P" and b2: "b2 \<in> set2 c"
-          unfolding set2_def c_def P2 using True by (auto simp: comp_eq_dest[OF set_of_mmap])
-        with sM(1) have "setsum (count M) ?K = setsum (count M) {a. p2 a = b2 \<and> a \<in> SET}"
-          by transfer (force intro: setsum.mono_neutral_cong_left split: split_if_asm)
-        also have "... = setsum (count M) ((\<lambda> b1. u c b1 b2) ` (set1 c))"
-          apply(rule setsum.cong) using c b2 proof safe
-          fix a assume p2a: "p2 a \<in> set2 c" and "c \<in> set_of P" and "a \<in> SET"
-          hence ac: "a \<in> sset c" using p2_rev by auto
-          hence "a = u c (p1 a) (p2 a)" using c by auto
-          moreover have "p1 a \<in> set1 c" using ac c by auto
-          ultimately show "a \<in> (\<lambda>x. u c x (p2 a)) ` set1 c" by auto
-        qed auto
-        also have "... = setsum (count M o (\<lambda> b1. u c b1 b2)) (set1 c)"
-          apply(rule setsum.reindex)
-          using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
-        also have "... = setsum (\<lambda> b1. count M (u c b1 b2)) (set1 c)" by simp
-        also have "... = count N2 b2" unfolding ss2[OF c b2, symmetric] comp_def
-          apply(rule setsum.cong[OF refl]) apply (transfer fixing: Ms u c b2 set1)
-          using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2] set1_def
-            [[hypsubst_thin = true]]
-          by fastforce
-        finally show ?thesis .
-      qed
-      thus "count (mmap p2 M) b2 = count N2 b2" by transfer
-    qed
-  qed
+lemma list_all2_reorder_left_invariance:
+  assumes rel: "list_all2 R xs ys" and ms_x: "multiset_of xs' = multiset_of xs"
+  shows "\<exists>ys'. list_all2 R xs' ys' \<and> multiset_of ys' = multiset_of ys"
+proof -
+  have len: "length xs = length ys"
+    using rel list_all2_conv_all_nth by auto
+  obtain ys' where
+    len': "length xs' = length ys'" and ms_xy: "multiset_of (zip xs' ys') = multiset_of (zip xs ys)"
+    using len ms_x by (metis ex_multiset_of_zip_left)
+  have "list_all2 R xs' ys'"
+    using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: multiset_of_eq_setD)
+  moreover have "multiset_of ys' = multiset_of ys"
+    using len len' ms_xy map_snd_zip multiset_of_map by metis
+  ultimately show ?thesis
+    by blast
 qed
 
-lemma set_of_bd: "(card_of (set_of x), natLeq) \<in> ordLeq"
-  by transfer
-    (auto intro!: ordLess_imp_ordLeq simp: finite_iff_ordLess_natLeq[symmetric] multiset_def)
-
-lemma wppull_mmap:
-  assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
-  shows "wppull {M. set_of M \<subseteq> A} {N1. set_of N1 \<subseteq> B1} {N2. set_of N2 \<subseteq> B2}
-    (mmap f1) (mmap f2) (mmap e1) (mmap e2) (mmap p1) (mmap p2)"
-proof -
-  from assms obtain j where j: "\<forall>a'\<in>thePull B1 B2 f1 f2.
-    j a' \<in> A \<and> e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')" 
-    by (blast dest: wppull_thePull)
-  then show ?thesis
-    by (intro wpull_wppull[OF wpull_mmap[OF wpull_thePull], of _ _ _ _ "mmap j"])
-      (auto simp: comp_eq_dest_lhs[OF mmap_comp[symmetric]] comp_eq_dest[OF set_of_mmap]
-        intro!: mmap_cong simp del: mem_set_of_iff simp: mem_set_of_iff[symmetric])
-qed
+lemma ex_multiset_of: "\<exists>xs. multiset_of xs = X"
+  by (induct X) (simp, metis multiset_of.simps(2))
 
 bnf "'a multiset"
-  map: mmap
+  map: image_mset
   sets: set_of 
   bd: natLeq
   wits: "{#}"
-by (auto simp add: mmap_id0 mmap_comp set_of_mmap natLeq_card_order natLeq_cinfinite set_of_bd
-  Grp_def relcompp.simps intro: mmap_cong)
-  (metis wppull_mmap[OF wppull_fstOp_sndOp, unfolded wppull_def
-    o_eq_dest_lhs[OF mmap_comp[symmetric]] fstOp_def sndOp_def comp_def, simplified])
-
-inductive rel_multiset' where
-  Zero[intro]: "rel_multiset' R {#} {#}"
-| Plus[intro]: "\<lbrakk>R a b; rel_multiset' R M N\<rbrakk> \<Longrightarrow> rel_multiset' R (M + {#a#}) (N + {#b#})"
-
-lemma map_multiset_Zero_iff[simp]: "mmap f M = {#} \<longleftrightarrow> M = {#}"
-by (metis image_is_empty multiset.set_map set_of_eq_empty_iff)
-
-lemma map_multiset_Zero[simp]: "mmap f {#} = {#}" by simp
-
-lemma rel_multiset_Zero: "rel_multiset R {#} {#}"
-unfolding rel_multiset_def Grp_def by auto
+  rel: rel_mset
+proof -
+  show "image_mset id = id"
+    by (rule image_mset.id)
+next
+  show "\<And>f g. image_mset (g \<circ> f) = image_mset g \<circ> image_mset f"
+    unfolding comp_def by (rule ext) (simp add: image_mset.compositionality comp_def)
+next
+  fix X :: "'a multiset"
+  show "\<And>f g. (\<And>z. z \<in> set_of X \<Longrightarrow> f z = g z) \<Longrightarrow> image_mset f X = image_mset g X"
+    by (induct X, (simp (no_asm))+,
+      metis One_nat_def Un_iff count_single mem_set_of_iff set_of_union zero_less_Suc)
+next
+  show "\<And>f. set_of \<circ> image_mset f = op ` f \<circ> set_of"
+    by auto
+next
+  show "card_order natLeq"
+    by (rule natLeq_card_order)
+next
+  show "BNF_Cardinal_Arithmetic.cinfinite natLeq"
+    by (rule natLeq_cinfinite)
+next
+  show "\<And>X. ordLeq3 (card_of (set_of X)) natLeq"
+    by transfer
+      (auto intro!: ordLess_imp_ordLeq simp: finite_iff_ordLess_natLeq[symmetric] multiset_def)
+next
+  show "\<And>R S. rel_mset R OO rel_mset S \<le> rel_mset (R OO S)"
+    unfolding rel_mset_def[abs_def] OO_def
+    apply clarify
+    apply (rename_tac X Z Y xs ys' ys zs)
+    apply (drule_tac xs = ys' and ys = zs and xs' = ys in list_all2_reorder_left_invariance)
+    by (auto intro: list_all2_trans)
+next
+  show "\<And>R. rel_mset R =
+    (BNF_Def.Grp {x. set_of x \<subseteq> {(x, y). R x y}} (image_mset fst))\<inverse>\<inverse> OO
+    BNF_Def.Grp {x. set_of x \<subseteq> {(x, y). R x y}} (image_mset snd)"
+    unfolding rel_mset_def[abs_def] BNF_Def.Grp_def OO_def
+    apply (rule ext)+
+    apply auto
+     apply (rule_tac x = "multiset_of (zip xs ys)" in exI)
+     apply auto[1]
+        apply (metis list_all2_lengthD map_fst_zip multiset_of_map)
+       apply (auto simp: list_all2_iff)[1]
+      apply (metis list_all2_lengthD map_snd_zip multiset_of_map)
+     apply (auto simp: list_all2_iff)[1]
+    apply (rename_tac XY)
+    apply (cut_tac X = XY in ex_multiset_of)
+    apply (erule exE)
+    apply (rename_tac xys)
+    apply (rule_tac x = "map fst xys" in exI)
+    apply (auto simp: multiset_of_map)
+    apply (rule_tac x = "map snd xys" in exI)
+    by (auto simp: multiset_of_map list_all2I subset_eq zip_map_fst_snd)
+next
+  show "\<And>z. z \<in> set_of {#} \<Longrightarrow> False"
+    by auto
+qed
+
+inductive rel_mset' where
+  Zero[intro]: "rel_mset' R {#} {#}"
+| Plus[intro]: "\<lbrakk>R a b; rel_mset' R M N\<rbrakk> \<Longrightarrow> rel_mset' R (M + {#a#}) (N + {#b#})"
+
+lemma rel_mset_Zero: "rel_mset R {#} {#}"
+unfolding rel_mset_def Grp_def by auto
 
 declare multiset.count[simp]
 declare Abs_multiset_inverse[simp]
 declare multiset.count_inverse[simp]
 declare union_preserves_multiset[simp]
 
-lemma map_multiset_Plus[simp]: "mmap f (M1 + M2) = mmap f M1 + mmap f M2"
-proof (intro multiset_eqI, transfer fixing: f)
-  fix x :: 'a and M1 M2 :: "'b \<Rightarrow> nat"
-  assume "M1 \<in> multiset" "M2 \<in> multiset"
-  hence "setsum M1 {a. f a = x \<and> 0 < M1 a} = setsum M1 {a. f a = x \<and> 0 < M1 a + M2 a}"
-        "setsum M2 {a. f a = x \<and> 0 < M2 a} = setsum M2 {a. f a = x \<and> 0 < M1 a + M2 a}"
-    by (auto simp: multiset_def intro!: setsum.mono_neutral_cong_left)
-  then show "(\<Sum>a | f a = x \<and> 0 < M1 a + M2 a. M1 a + M2 a) =
-       setsum M1 {a. f a = x \<and> 0 < M1 a} +
-       setsum M2 {a. f a = x \<and> 0 < M2 a}"
-    by (auto simp: setsum.distrib[symmetric])
-qed
-
-lemma map_multiset_single[simp]: "mmap f {#a#} = {#f a#}"
-  by transfer auto
-
-lemma rel_multiset_Plus:
-assumes ab: "R a b" and MN: "rel_multiset R M N"
-shows "rel_multiset R (M + {#a#}) (N + {#b#})"
+lemma rel_mset_Plus:
+assumes ab: "R a b" and MN: "rel_mset R M N"
+shows "rel_mset R (M + {#a#}) (N + {#b#})"
 proof-
   {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
-   hence "\<exists>ya. mmap fst y + {#a#} = mmap fst ya \<and>
-               mmap snd y + {#b#} = mmap snd ya \<and>
+   hence "\<exists>ya. image_mset fst y + {#a#} = image_mset fst ya \<and>
+               image_mset snd y + {#b#} = image_mset snd ya \<and>
                set_of ya \<subseteq> {(x, y). R x y}"
    apply(intro exI[of _ "y + {#(a,b)#}"]) by auto
   }
   thus ?thesis
   using assms
-  unfolding rel_multiset_def Grp_def by force
+  unfolding multiset.rel_compp_Grp Grp_def by blast
 qed
 
-lemma rel_multiset'_imp_rel_multiset:
-"rel_multiset' R M N \<Longrightarrow> rel_multiset R M N"
-apply(induct rule: rel_multiset'.induct)
-using rel_multiset_Zero rel_multiset_Plus by auto
-
-lemma mcard_mmap[simp]: "mcard (mmap f M) = mcard M"
-proof -
-  def A \<equiv> "\<lambda> b. {a. f a = b \<and> a \<in># M}"
-  let ?B = "{b. 0 < setsum (count M) (A b)}"
-  have "{b. \<exists>a. f a = b \<and> a \<in># M} \<subseteq> f ` {a. a \<in># M}" by auto
-  moreover have "finite (f ` {a. a \<in># M})" apply(rule finite_imageI)
-  using finite_Collect_mem .
-  ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
-  have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
-    by (metis (lifting, full_types) mem_Collect_eq neq0_conv setsum.neutral)
-  have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
-  apply safe
-    apply (metis less_not_refl setsum_gt_0_iff setsum.infinite)
-    by (metis A_def finite_Collect_conjI finite_Collect_mem setsum_gt_0_iff)
-  hence AB: "A ` ?B = {A b | b. \<exists> a \<in> A b. count M a > 0}" by auto
-
-  have "setsum (\<lambda> x. setsum (count M) (A x)) ?B = setsum (setsum (count M) o A) ?B"
-  unfolding comp_def ..
-  also have "... = (\<Sum>x\<in> A ` ?B. setsum (count M) x)"
-  unfolding setsum.reindex [OF i, symmetric] ..
-  also have "... = setsum (count M) (\<Union>x\<in>A ` {b. 0 < setsum (count M) (A b)}. x)"
-  (is "_ = setsum (count M) ?J")
-  apply(rule setsum.UNION_disjoint[symmetric])
-  using 0 fin unfolding A_def by auto
-  also have "?J = {a. a \<in># M}" unfolding AB unfolding A_def by auto
-  finally have "setsum (\<lambda> x. setsum (count M) (A x)) ?B =
-                setsum (count M) {a. a \<in># M}" .
-  then show ?thesis unfolding mcard_unfold_setsum A_def by transfer
-qed
-
-lemma rel_multiset_mcard:
-assumes "rel_multiset R M N"
-shows "mcard M = mcard N"
-using assms unfolding rel_multiset_def Grp_def by auto
+lemma rel_mset'_imp_rel_mset:
+"rel_mset' R M N \<Longrightarrow> rel_mset R M N"
+apply(induct rule: rel_mset'.induct)
+using rel_mset_Zero rel_mset_Plus by auto
+
+lemma mcard_image_mset[simp]: "mcard (image_mset f M) = mcard M"
+  unfolding size_eq_mcard[symmetric] by (rule size_image_mset)
+
+lemma rel_mset_mcard:
+  assumes "rel_mset R M N"
+  shows "mcard M = mcard N"
+using assms unfolding multiset.rel_compp_Grp Grp_def by auto
 
 lemma multiset_induct2[case_names empty addL addR]:
 assumes empty: "P {#} {#}"
@@ -2946,100 +2485,96 @@
 qed
 
 lemma msed_map_invL:
-assumes "mmap f (M + {#a#}) = N"
-shows "\<exists> N1. N = N1 + {#f a#} \<and> mmap f M = N1"
+assumes "image_mset f (M + {#a#}) = N"
+shows "\<exists>N1. N = N1 + {#f a#} \<and> image_mset f M = N1"
 proof-
   have "f a \<in># N"
   using assms multiset.set_map[of f "M + {#a#}"] by auto
   then obtain N1 where N: "N = N1 + {#f a#}" using multi_member_split by metis
-  have "mmap f M = N1" using assms unfolding N by simp
+  have "image_mset f M = N1" using assms unfolding N by simp
   thus ?thesis using N by blast
 qed
 
 lemma msed_map_invR:
-assumes "mmap f M = N + {#b#}"
-shows "\<exists> M1 a. M = M1 + {#a#} \<and> f a = b \<and> mmap f M1 = N"
+assumes "image_mset f M = N + {#b#}"
+shows "\<exists>M1 a. M = M1 + {#a#} \<and> f a = b \<and> image_mset f M1 = N"
 proof-
   obtain a where a: "a \<in># M" and fa: "f a = b"
   using multiset.set_map[of f M] unfolding assms
   by (metis image_iff mem_set_of_iff union_single_eq_member)
   then obtain M1 where M: "M = M1 + {#a#}" using multi_member_split by metis
-  have "mmap f M1 = N" using assms unfolding M fa[symmetric] by simp
+  have "image_mset f M1 = N" using assms unfolding M fa[symmetric] by simp
   thus ?thesis using M fa by blast
 qed
 
 lemma msed_rel_invL:
-assumes "rel_multiset R (M + {#a#}) N"
-shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> rel_multiset R M N1"
+assumes "rel_mset R (M + {#a#}) N"
+shows "\<exists>N1 b. N = N1 + {#b#} \<and> R a b \<and> rel_mset R M N1"
 proof-
-  obtain K where KM: "mmap fst K = M + {#a#}"
-  and KN: "mmap snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
+  obtain K where KM: "image_mset fst K = M + {#a#}"
+  and KN: "image_mset snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
   using assms
-  unfolding rel_multiset_def Grp_def by auto
+  unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
-  and K1M: "mmap fst K1 = M" using msed_map_invR[OF KM] by auto
-  obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "mmap snd K1 = N1"
+  and K1M: "image_mset fst K1 = M" using msed_map_invR[OF KM] by auto
+  obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "image_mset snd K1 = N1"
   using msed_map_invL[OF KN[unfolded K]] by auto
   have Rab: "R a (snd ab)" using sK a unfolding K by auto
-  have "rel_multiset R M N1" using sK K1M K1N1
-  unfolding K rel_multiset_def Grp_def by auto
+  have "rel_mset R M N1" using sK K1M K1N1
+  unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using N Rab by auto
 qed
 
 lemma msed_rel_invR:
-assumes "rel_multiset R M (N + {#b#})"
-shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> rel_multiset R M1 N"
+assumes "rel_mset R M (N + {#b#})"
+shows "\<exists>M1 a. M = M1 + {#a#} \<and> R a b \<and> rel_mset R M1 N"
 proof-
-  obtain K where KN: "mmap snd K = N + {#b#}"
-  and KM: "mmap fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
+  obtain K where KN: "image_mset snd K = N + {#b#}"
+  and KM: "image_mset fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
   using assms
-  unfolding rel_multiset_def Grp_def by auto
+  unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
-  and K1N: "mmap snd K1 = N" using msed_map_invR[OF KN] by auto
-  obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "mmap fst K1 = M1"
+  and K1N: "image_mset snd K1 = N" using msed_map_invR[OF KN] by auto
+  obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "image_mset fst K1 = M1"
   using msed_map_invL[OF KM[unfolded K]] by auto
   have Rab: "R (fst ab) b" using sK b unfolding K by auto
-  have "rel_multiset R M1 N" using sK K1N K1M1
-  unfolding K rel_multiset_def Grp_def by auto
+  have "rel_mset R M1 N" using sK K1N K1M1
+  unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using M Rab by auto
 qed
 
-lemma rel_multiset_imp_rel_multiset':
-assumes "rel_multiset R M N"
-shows "rel_multiset' R M N"
+lemma rel_mset_imp_rel_mset':
+assumes "rel_mset R M N"
+shows "rel_mset' R M N"
 using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
   case (less M)
-  have c: "mcard M = mcard N" using rel_multiset_mcard[OF less.prems] .
+  have c: "mcard M = mcard N" using rel_mset_mcard[OF less.prems] .
   show ?case
   proof(cases "M = {#}")
     case True hence "N = {#}" using c by simp
-    thus ?thesis using True rel_multiset'.Zero by auto
+    thus ?thesis using True rel_mset'.Zero by auto
   next
     case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
-    obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "rel_multiset R M1 N1"
+    obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "rel_mset R M1 N1"
     using msed_rel_invL[OF less.prems[unfolded M]] by auto
-    have "rel_multiset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
-    thus ?thesis using rel_multiset'.Plus[of R a b, OF R] unfolding M N by simp
+    have "rel_mset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
+    thus ?thesis using rel_mset'.Plus[of R a b, OF R] unfolding M N by simp
   qed
 qed
 
-lemma rel_multiset_rel_multiset':
-"rel_multiset R M N = rel_multiset' R M N"
-using  rel_multiset_imp_rel_multiset' rel_multiset'_imp_rel_multiset by auto
-
-(* The main end product for rel_multiset: inductive characterization *)
-theorems rel_multiset_induct[case_names empty add, induct pred: rel_multiset] =
-         rel_multiset'.induct[unfolded rel_multiset_rel_multiset'[symmetric]]
+lemma rel_mset_rel_mset':
+"rel_mset R M N = rel_mset' R M N"
+using rel_mset_imp_rel_mset' rel_mset'_imp_rel_mset by auto
+
+(* The main end product for rel_mset: inductive characterization *)
+theorems rel_mset_induct[case_names empty add, induct pred: rel_mset] =
+         rel_mset'.induct[unfolded rel_mset_rel_mset'[symmetric]]
 
 
 subsection {* Size setup *}
 
-lemma multiset_size_o_map: "size_multiset g \<circ> mmap f = size_multiset (g \<circ> f)"
-apply (rule ext)
-apply (unfold o_apply)
-apply (induct_tac x)
-apply auto
-done
+lemma multiset_size_o_map: "size_multiset g \<circ> image_mset f = size_multiset (g \<circ> f)"
+  unfolding o_apply by (rule ext) (induct_tac, auto)
 
 setup {*
 BNF_LFP_Size.register_size_global @{type_name multiset} @{const_name size_multiset}
--- a/src/HOL/Library/Permutation.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Permutation.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -162,7 +162,7 @@
   apply (case_tac "remdups xs")
    apply simp_all
   apply (subgoal_tac "a \<in> set (remdups ys)")
-   prefer 2 apply (metis set_simps(2) insert_iff set_remdups)
+   prefer 2 apply (metis list.set(2) insert_iff set_remdups)
   apply (drule split_list) apply (elim exE conjE)
   apply (drule_tac x = list in spec) apply (erule impE) prefer 2
    apply (drule_tac x = "ysa @ zs" in spec) apply (erule impE) prefer 2
--- a/src/HOL/Library/Quickcheck_Types.thy	Wed Aug 27 11:33:00 2014 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,469 +0,0 @@
-(*  Title:      HOL/Library/Quickcheck_Types.thy
-    Author:     Lukas Bulwahn
-    Copyright   2010 TU Muenchen
-*)
-
-theory Quickcheck_Types
-imports Main
-begin
-
-text {*
-This theory provides some default types for the quickcheck execution.
-In most cases, the default type @{typ "int"} meets the sort constraints
-of the proposition.
-But for the type classes bot and top, the type @{typ "int"} is insufficient.
-Hence, we provide other types than @{typ "int"} as further default types.  
-*}
-
-subsection {* A non-distributive lattice *}
-
-datatype non_distrib_lattice = Zero | A | B | C | One
-
-instantiation non_distrib_lattice :: order
-begin
-
-definition less_eq_non_distrib_lattice
-where
-  "a <= b = (case a of Zero => True | A => (b = A) \<or> (b = One) | B => (b = B) \<or> (b = One) | C => (b = C) \<or> (b = One) | One => (b = One))"
-
-definition less_non_distrib_lattice
-where
-  "a < b = (case a of Zero => (b \<noteq> Zero) | A => (b = One) | B => (b = One) | C => (b = One) | One => False)"
-
-instance proof
-qed (auto simp add: less_eq_non_distrib_lattice_def less_non_distrib_lattice_def split: non_distrib_lattice.split non_distrib_lattice.split_asm)
-
-end
-
-instantiation non_distrib_lattice :: lattice
-begin
-
-
-definition sup_non_distrib_lattice
-where
-  "sup a b = (if a = b then a else (if a = Zero then b else (if b = Zero then a else One)))"
-
-definition inf_non_distrib_lattice
-where
-  "inf a b = (if a = b then a else (if a = One then b else (if b = One then a else Zero)))"
-
-instance proof
-qed (auto simp add: inf_non_distrib_lattice_def sup_non_distrib_lattice_def less_eq_non_distrib_lattice_def split: split_if non_distrib_lattice.split non_distrib_lattice.split_asm)
-
-end
-
-hide_const Zero A B C One
-
-subsection {* Values extended by a bottom element *}
-
-datatype 'a bot = Value 'a | Bot
-
-instantiation bot :: (preorder) preorder
-begin
-
-definition less_eq_bot where
-  "x \<le> y \<longleftrightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> x \<le> y))"
-
-definition less_bot where
-  "x < y \<longleftrightarrow> (case y of Bot \<Rightarrow> False | Value y \<Rightarrow> (case x of Bot \<Rightarrow> True | Value x \<Rightarrow> x < y))"
-
-lemma less_eq_bot_Bot [simp]: "Bot \<le> x"
-  by (simp add: less_eq_bot_def)
-
-lemma less_eq_bot_Bot_code [code]: "Bot \<le> x \<longleftrightarrow> True"
-  by simp
-
-lemma less_eq_bot_Bot_is_Bot: "x \<le> Bot \<Longrightarrow> x = Bot"
-  by (cases x) (simp_all add: less_eq_bot_def)
-
-lemma less_eq_bot_Value_Bot [simp, code]: "Value x \<le> Bot \<longleftrightarrow> False"
-  by (simp add: less_eq_bot_def)
-
-lemma less_eq_bot_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
-  by (simp add: less_eq_bot_def)
-
-lemma less_bot_Bot [simp, code]: "x < Bot \<longleftrightarrow> False"
-  by (simp add: less_bot_def)
-
-lemma less_bot_Bot_is_Value: "Bot < x \<Longrightarrow> \<exists>z. x = Value z"
-  by (cases x) (simp_all add: less_bot_def)
-
-lemma less_bot_Bot_Value [simp]: "Bot < Value x"
-  by (simp add: less_bot_def)
-
-lemma less_bot_Bot_Value_code [code]: "Bot < Value x \<longleftrightarrow> True"
-  by simp
-
-lemma less_bot_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
-  by (simp add: less_bot_def)
-
-instance proof
-qed (auto simp add: less_eq_bot_def less_bot_def less_le_not_le elim: order_trans split: bot.splits)
-
-end 
-
-instance bot :: (order) order proof
-qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)
-
-instance bot :: (linorder) linorder proof
-qed (auto simp add: less_eq_bot_def less_bot_def split: bot.splits)
-
-instantiation bot :: (order) bot
-begin
-
-definition "bot = Bot"
-
-instance ..
-
-end
-
-instantiation bot :: (top) top
-begin
-
-definition "top = Value top"
-
-instance ..
-
-end
-
-instantiation bot :: (semilattice_inf) semilattice_inf
-begin
-
-definition inf_bot
-where
-  "inf x y = (case x of Bot => Bot | Value v => (case y of Bot => Bot | Value v' => Value (inf v v')))"
-
-instance proof
-qed (auto simp add: inf_bot_def less_eq_bot_def split: bot.splits)
-
-end
-
-instantiation bot :: (semilattice_sup) semilattice_sup
-begin
-
-definition sup_bot
-where
-  "sup x y = (case x of Bot => y | Value v => (case y of Bot => x | Value v' => Value (sup v v')))"
-
-instance proof
-qed (auto simp add: sup_bot_def less_eq_bot_def split: bot.splits)
-
-end
-
-instance bot :: (lattice) bounded_lattice_bot
-by(intro_classes)(simp add: bot_bot_def)
-
-section {* Values extended by a top element *}
-
-datatype 'a top = Value 'a | Top
-
-instantiation top :: (preorder) preorder
-begin
-
-definition less_eq_top where
-  "x \<le> y \<longleftrightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> x \<le> y))"
-
-definition less_top where
-  "x < y \<longleftrightarrow> (case x of Top \<Rightarrow> False | Value x \<Rightarrow> (case y of Top \<Rightarrow> True | Value y \<Rightarrow> x < y))"
-
-lemma less_eq_top_Top [simp]: "x <= Top"
-  by (simp add: less_eq_top_def)
-
-lemma less_eq_top_Top_code [code]: "x \<le> Top \<longleftrightarrow> True"
-  by simp
-
-lemma less_eq_top_is_Top: "Top \<le> x \<Longrightarrow> x = Top"
-  by (cases x) (simp_all add: less_eq_top_def)
-
-lemma less_eq_top_Top_Value [simp, code]: "Top \<le> Value x \<longleftrightarrow> False"
-  by (simp add: less_eq_top_def)
-
-lemma less_eq_top_Value_Value [simp, code]: "Value x \<le> Value y \<longleftrightarrow> x \<le> y"
-  by (simp add: less_eq_top_def)
-
-lemma less_top_Top [simp, code]: "Top < x \<longleftrightarrow> False"
-  by (simp add: less_top_def)
-
-lemma less_top_Top_is_Value: "x < Top \<Longrightarrow> \<exists>z. x = Value z"
-  by (cases x) (simp_all add: less_top_def)
-
-lemma less_top_Value_Top [simp]: "Value x < Top"
-  by (simp add: less_top_def)
-
-lemma less_top_Value_Top_code [code]: "Value x < Top \<longleftrightarrow> True"
-  by simp
-
-lemma less_top_Value [simp, code]: "Value x < Value y \<longleftrightarrow> x < y"
-  by (simp add: less_top_def)
-
-instance proof
-qed (auto simp add: less_eq_top_def less_top_def less_le_not_le elim: order_trans split: top.splits)
-
-end 
-
-instance top :: (order) order proof
-qed (auto simp add: less_eq_top_def less_top_def split: top.splits)
-
-instance top :: (linorder) linorder proof
-qed (auto simp add: less_eq_top_def less_top_def split: top.splits)
-
-instantiation top :: (order) top
-begin
-
-definition "top = Top"
-
-instance ..
-
-end
-
-instantiation top :: (bot) bot
-begin
-
-definition "bot = Value bot"
-
-instance ..
-
-end
-
-instantiation top :: (semilattice_inf) semilattice_inf
-begin
-
-definition inf_top
-where
-  "inf x y = (case x of Top => y | Value v => (case y of Top => x | Value v' => Value (inf v v')))"
-
-instance proof
-qed (auto simp add: inf_top_def less_eq_top_def split: top.splits)
-
-end
-
-instantiation top :: (semilattice_sup) semilattice_sup
-begin
-
-definition sup_top
-where
-  "sup x y = (case x of Top => Top | Value v => (case y of Top => Top | Value v' => Value (sup v v')))"
-
-instance proof
-qed (auto simp add: sup_top_def less_eq_top_def split: top.splits)
-
-end
-
-instance top :: (lattice) bounded_lattice_top
-by(intro_classes)(simp add: top_top_def)
-
-
-datatype 'a flat_complete_lattice = Value 'a | Bot | Top
-
-instantiation flat_complete_lattice :: (type) order
-begin
-
-definition less_eq_flat_complete_lattice where
-  "x \<le> y == (case x of Bot => True | Value v1 => (case y of Bot => False | Value v2 => (v1 = v2) | Top => True) | Top => (y = Top))"
-
-definition less_flat_complete_lattice where
-  "x < y = (case x of Bot => \<not> (y = Bot) | Value v1 => (y = Top) | Top => False)"
-
-lemma [simp]: "Bot <= y"
-unfolding less_eq_flat_complete_lattice_def by auto
-
-lemma [simp]: "y <= Top"
-unfolding less_eq_flat_complete_lattice_def by (auto split: flat_complete_lattice.splits)
-
-lemma greater_than_two_values:
-  assumes "a ~= aa" "Value a <= z" "Value aa <= z"
-  shows "z = Top"
-using assms
-by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)
-
-lemma lesser_than_two_values:
-  assumes "a ~= aa" "z <= Value a" "z <= Value aa"
-  shows "z = Bot"
-using assms
-by (cases z) (auto simp add: less_eq_flat_complete_lattice_def)
-
-instance proof
-qed (auto simp add: less_eq_flat_complete_lattice_def less_flat_complete_lattice_def split: flat_complete_lattice.splits)
-
-end
-
-instantiation flat_complete_lattice :: (type) bot
-begin
-
-definition "bot = Bot"
-
-instance ..
-
-end
-
-instantiation flat_complete_lattice :: (type) top
-begin
-
-definition "top = Top"
-
-instance ..
-
-end
-
-instantiation flat_complete_lattice :: (type) lattice
-begin
-
-definition inf_flat_complete_lattice
-where
-  "inf x y = (case x of Bot => Bot | Value v1 => (case y of Bot => Bot | Value v2 => if (v1 = v2) then x else Bot | Top => x) | Top => y)"
-
-definition sup_flat_complete_lattice
-where
-  "sup x y = (case x of Bot => y | Value v1 => (case y of Bot => x | Value v2 => if v1 = v2 then x else Top | Top => Top) | Top => Top)"
-
-instance proof
-qed (auto simp add: inf_flat_complete_lattice_def sup_flat_complete_lattice_def less_eq_flat_complete_lattice_def split: flat_complete_lattice.splits)
-
-end
-
-instantiation flat_complete_lattice :: (type) complete_lattice
-begin
-
-definition Sup_flat_complete_lattice
-where
-  "Sup A = (if (A = {} \<or> A = {Bot}) then Bot else (if (\<exists> v. A - {Bot} = {Value v}) then Value (THE v. A - {Bot} = {Value v}) else Top))"
-
-definition Inf_flat_complete_lattice
-where
-  "Inf A = (if (A = {} \<or> A = {Top}) then Top else (if (\<exists> v. A - {Top} = {Value v}) then Value (THE v. A - {Top} = {Value v}) else Bot))"
- 
-instance
-proof
-  fix x A
-  assume "(x :: 'a flat_complete_lattice) : A"
-  {
-    fix v
-    assume "A - {Top} = {Value v}"
-    from this have "(THE v. A - {Top} = {Value v}) = v"
-      by (auto intro!: the1_equality)
-    moreover
-    from `x : A` `A - {Top} = {Value v}` have "x = Top \<or> x = Value v"
-      by auto
-    ultimately have "Value (THE v. A - {Top} = {Value v}) <= x"
-      by auto
-  }
-  from `x : A` this show "Inf A <= x"
-    unfolding Inf_flat_complete_lattice_def
-    by fastforce
-next
-  fix z A
-  assume z: "\<And>x. x : A ==> z <= (x :: 'a flat_complete_lattice)"
-  {
-    fix v
-    assume "A - {Top} = {Value v}"
-    moreover
-    from this have "(THE v. A - {Top} = {Value v}) = v"
-      by (auto intro!: the1_equality)
-    moreover
-    note z
-    moreover
-    ultimately have "z <= Value (THE v::'a. A - {Top} = {Value v})"
-      by auto
-  } moreover
-  {
-    assume not_one_value: "A ~= {}" "A ~= {Top}" "~ (EX v::'a. A - {Top} = {Value v})"
-    have "z <= Bot"
-    proof (cases "A - {Top} = {Bot}")
-      case True
-      from this z show ?thesis
-        by auto
-    next
-      case False
-      from not_one_value
-      obtain a1 where a1: "a1 : A - {Top}" by auto
-      from not_one_value False a1
-      obtain a2 where "a2 : A - {Top} \<and> a1 \<noteq> a2"
-        by (cases a1) auto
-      from this a1 z[of "a1"] z[of "a2"] show ?thesis
-        apply (cases a1)
-        apply auto
-        apply (cases a2)
-        apply auto
-        apply (auto dest!: lesser_than_two_values)
-        done
-    qed
-  } moreover
-  note z moreover
-  ultimately show "z <= Inf A"
-    unfolding Inf_flat_complete_lattice_def
-    by auto
-next
-  fix x A
-  assume "(x :: 'a flat_complete_lattice) : A"
-  {
-    fix v
-    assume "A - {Bot} = {Value v}"
-    from this have "(THE v. A - {Bot} = {Value v}) = v"
-      by (auto intro!: the1_equality)
-    moreover
-    from `x : A` `A - {Bot} = {Value v}` have "x = Bot \<or> x = Value v"
-      by auto
-    ultimately have "x <= Value (THE v. A - {Bot} = {Value v})"
-      by auto
-  }
-  from `x : A` this show "x <= Sup A"
-    unfolding Sup_flat_complete_lattice_def
-    by fastforce
-next
-  fix z A
-  assume z: "\<And>x. x : A ==> x <= (z :: 'a flat_complete_lattice)"
-  {
-    fix v
-    assume "A - {Bot} = {Value v}"
-    moreover
-    from this have "(THE v. A - {Bot} = {Value v}) = v"
-      by (auto intro!: the1_equality)
-    moreover
-    note z
-    moreover
-    ultimately have "Value (THE v::'a. A - {Bot} = {Value v}) <= z"
-      by auto
-  } moreover
-  {
-    assume not_one_value: "A ~= {}" "A ~= {Bot}" "~ (EX v::'a. A - {Bot} = {Value v})"
-    have "Top <= z"
-    proof (cases "A - {Bot} = {Top}")
-      case True
-      from this z show ?thesis
-        by auto
-    next
-      case False
-      from not_one_value
-      obtain a1 where a1: "a1 : A - {Bot}" by auto
-      from not_one_value False a1
-      obtain a2 where "a2 : A - {Bot} \<and> a1 \<noteq> a2"
-        by (cases a1) auto
-      from this a1 z[of "a1"] z[of "a2"] show ?thesis
-        apply (cases a1)
-        apply auto
-        apply (cases a2)
-        apply (auto dest!: greater_than_two_values)
-        done
-    qed
-  } moreover
-  note z moreover
-  ultimately show "Sup A <= z"
-    unfolding Sup_flat_complete_lattice_def
-    by auto
-next
-  show "Inf {} = (top :: 'a flat_complete_lattice)"
-    by(simp add: Inf_flat_complete_lattice_def top_flat_complete_lattice_def)
-next
-  show "Sup {} = (bot :: 'a flat_complete_lattice)"
-    by(simp add: Sup_flat_complete_lattice_def bot_flat_complete_lattice_def)
-qed
-
-end
-
-section {* Quickcheck configuration *}
-
-quickcheck_params[finite_types = false, default_type = ["int", "non_distrib_lattice", "int bot", "int top", "Enum.finite_4 flat_complete_lattice"]]
-
-hide_type non_distrib_lattice flat_complete_lattice bot top
-
-end
\ No newline at end of file
--- a/src/HOL/Library/RBT_Impl.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/RBT_Impl.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1754,7 +1754,7 @@
   Abs_compare_cases Abs_compare_induct Abs_compare_inject Abs_compare_inverse
   Rep_compare Rep_compare_cases Rep_compare_induct Rep_compare_inject Rep_compare_inverse
   compare.simps compare.exhaust compare.induct compare.rec compare.simps
-  compare.size compare.case_cong compare.weak_case_cong compare.case
+  compare.size compare.case_cong compare.case_cong_weak compare.case
   compare.nchotomy compare.split compare.split_asm rec_compare_def
   compare.eq.refl compare.eq.simps
   compare.EQ_def compare.GT_def compare.LT_def
--- a/src/HOL/Library/RBT_Set.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/RBT_Set.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -522,7 +522,7 @@
 
 code_datatype Set Coset
 
-declare set_simps[code]
+declare list.set[code] (* needed? *)
 
 lemma empty_Set [code]:
   "Set.empty = Set RBT.empty"
--- a/src/HOL/Library/Sum_of_Squares/sum_of_squares.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/Sum_of_Squares/sum_of_squares.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -1048,7 +1048,7 @@
 
 fun sos_tac print_cert prover ctxt =
   (* The SOS prover breaks if mult_nonneg_nonneg is in the simpset *)
-  let val ctxt' = ctxt delsimps [@{thm mult_nonneg_nonneg}]
+  let val ctxt' = Context_Position.set_visible false ctxt delsimps @{thms mult_nonneg_nonneg}
   in Object_Logic.full_atomize_tac ctxt' THEN'
      elim_denom_tac ctxt' THEN'
      core_sos_tac print_cert prover ctxt'
--- a/src/HOL/Library/refute.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/refute.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -2909,7 +2909,7 @@
           Node xs => xs
         | _       => raise REFUTE ("set_printer",
           "interpretation for set type is a leaf"))
-      val elements = List.mapPartial (fn (arg, result) =>
+      val elements = map_filter (fn (arg, result) =>
         case result of
           Leaf [fmTrue, (* fmFalse *) _] =>
           if Prop_Logic.eval assignment fmTrue then
--- a/src/HOL/Library/simps_case_conv.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Library/simps_case_conv.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -221,15 +221,15 @@
 val _ =
   Outer_Syntax.local_theory @{command_spec "case_of_simps"}
     "turn a list of equations into a case expression"
-    (Parse_Spec.opt_thm_name ":"  -- Parse_Spec.xthms1 >> case_of_simps_cmd)
+    (Parse_Spec.opt_thm_name ":"  -- Parse.xthms1 >> case_of_simps_cmd)
 
 val parse_splits = @{keyword "("} |-- Parse.reserved "splits" |-- @{keyword ":"} |--
-  Parse_Spec.xthms1 --| @{keyword ")"}
+  Parse.xthms1 --| @{keyword ")"}
 
 val _ =
   Outer_Syntax.local_theory @{command_spec "simps_of_case"}
     "perform case split on rule"
-    (Parse_Spec.opt_thm_name ":"  -- Parse_Spec.xthm --
+    (Parse_Spec.opt_thm_name ":"  -- Parse.xthm --
       Scan.optional parse_splits [] >> simps_of_case_cmd)
 
 end
--- a/src/HOL/Lifting.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Lifting.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -545,6 +545,8 @@
 
 ML_file "Tools/Lifting/lifting_util.ML"
 
+named_theorems relator_eq_onp
+  "theorems that a relator of an eq_onp is an eq_onp of the corresponding predicate"
 ML_file "Tools/Lifting/lifting_info.ML"
 setup Lifting_Info.setup
 
--- a/src/HOL/List.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/List.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -39,6 +39,8 @@
 
 setup {* Sign.parent_path *}
 
+lemmas set_simps = list.set (* legacy *)
+
 syntax
   -- {* list Enumeration *}
   "_list" :: "args => 'a list"    ("[(_)]")
@@ -54,16 +56,9 @@
 "last (x # xs) = (if xs = [] then x else last xs)"
 
 primrec butlast :: "'a list \<Rightarrow> 'a list" where
-"butlast []= []" |
+"butlast [] = []" |
 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
 
-declare list.set[simp del, code del]
-
-lemma set_simps[simp, code, code_post]:
-  "set [] = {}"
-  "set (x # xs) = insert x (set xs)"
-by (simp_all add: list.set)
-
 lemma set_rec: "set xs = rec_list {} (\<lambda>x _. insert x) xs"
   by (induct xs) auto
 
@@ -575,7 +570,7 @@
 
 fun simproc ctxt redex =
   let
-    val set_Nil_I = @{thm trans} OF [@{thm set_simps(1)}, @{thm empty_def}]
+    val set_Nil_I = @{thm trans} OF [@{thm list.set(1)}, @{thm empty_def}]
     val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
     val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}
     val del_refl_eq = @{lemma "(t = t & P) == P" by simp}
@@ -1255,6 +1250,8 @@
 
 subsubsection {* @{const set} *}
 
+declare list.set[code_post]  --"pretty output"
+
 lemma finite_set [iff]: "finite (set xs)"
 by (induct xs) auto
 
@@ -1404,7 +1401,7 @@
 
 
 lemma finite_list: "finite A ==> EX xs. set xs = A"
-  by (erule finite_induct) (auto simp add: set_simps(2) [symmetric] simp del: set_simps(2))
+  by (erule finite_induct) (auto simp add: list.set(2)[symmetric] simp del: list.set(2))
 
 lemma card_length: "card (set xs) \<le> length xs"
 by (induct xs) (auto simp add: card_insert_if)
@@ -3439,6 +3436,9 @@
 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"
 by force
 
+lemma hd_remdups_adj[simp]: "hd (remdups_adj xs) = hd xs"
+  by (induction xs rule: remdups_adj.induct) simp_all
+
 lemma remdups_adj_Cons: "remdups_adj (x # xs) =
   (case remdups_adj xs of [] \<Rightarrow> [x] | y # xs \<Rightarrow> if x = y then y # xs else x # y # xs)"
   by (induct xs arbitrary: x) (auto split: list.splits)
@@ -3447,6 +3447,13 @@
   "remdups_adj (xs @ [x,y]) = remdups_adj (xs @ [x]) @ (if x = y then [] else [y])"
   by (induct xs rule: remdups_adj.induct, simp_all)
 
+lemma remdups_adj_adjacent:
+  "Suc i < length (remdups_adj xs) \<Longrightarrow> remdups_adj xs ! i \<noteq> remdups_adj xs ! Suc i"
+proof (induction xs arbitrary: i rule: remdups_adj.induct)
+  case (3 x y xs i)
+  thus ?case by (cases i, cases "x = y") (simp, auto simp: hd_conv_nth[symmetric])
+qed simp_all
+
 lemma remdups_adj_rev[simp]: "remdups_adj (rev xs) = rev (remdups_adj xs)"
   by (induct xs rule: remdups_adj.induct, simp_all add: remdups_adj_append_two)
 
--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1392,7 +1392,7 @@
 
   apply (simp (no_asm_simp) add: max_ssize_def del: max_of_list_append)
     apply (rule max_of_list_sublist)
-    apply (simp (no_asm_simp) only: set_append set_simps list.map) apply blast
+    apply (simp (no_asm_simp) only: set_append list.set list.map) apply blast
   apply (simp (no_asm_simp))
   apply simp                    (* subgoal bc3 = [] *)
   apply (simp add: comb_nil_def) (* subgoal mt3 = [] \<and> sttp2 = sttp3 *)
@@ -1419,7 +1419,7 @@
      (* (some) preconditions of  wt_instr_offset *)
   apply (simp (no_asm_simp) add: max_ssize_def del: max_of_list_append)
   apply (rule max_of_list_sublist)
-    apply (simp (no_asm_simp) only: set_append set_simps list.map) apply blast
+    apply (simp (no_asm_simp) only: set_append list.set list.map) apply blast
   apply (simp (no_asm_simp))
 
 apply (drule_tac x=sttp2 in spec, simp) (* subgoal \<exists>mt3_rest. \<dots> *)
--- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -15,19 +15,15 @@
 val proverK = "prover" (*=NAME: name of the external prover to call*)
 val prover_timeoutK = "prover_timeout" (*=TIME: timeout for invoked ATP (seconds of process time)*)
 val keepK = "keep" (*=PATH: path where to keep temporary files created by sledgehammer*)
-val minimizeK = "minimize" (*: enable minimization of theorem set found by sledgehammer*)
-                           (*refers to minimization attempted by Mirabelle*)
-val minimize_timeoutK = "minimize_timeout" (*=TIME: timeout for each minimization step (seconds of*)
 
 val proof_methodK = "proof_method" (*=NAME: how to reconstruct proofs (ie. using metis/smt)*)
-val metis_ftK = "metis_ft" (*: apply metis with fully-typed encoding to the theorems found by sledgehammer*)
 
 val max_factsK = "max_facts" (*=NUM: max. relevant clauses to use*)
 val max_relevantK = "max_relevant" (*=NUM: max. relevant clauses to use*)
 val max_callsK = "max_calls" (*=NUM: max. no. of calls to sledgehammer*)
 val preplay_timeoutK = "preplay_timeout" (*=TIME: timeout for finding reconstructed proof*)
 val isar_proofsK = "isar_proofs" (*: enable Isar proof generation*)
-val sh_minimizeK = "sh_minimize" (*: instruct sledgehammer to run its minimizer*)
+val minimizeK = "minimize" (*: instruct sledgehammer to run its minimizer*)
 
 val check_trivialK = "check_trivial" (*: check if goals are "trivial" (false by default)*)
 val fact_filterK = "fact_filter" (*=STRING: fact filter*)
@@ -43,14 +39,13 @@
 val max_mono_itersK = "max_mono_iters" (*=NUM: max. iterations of monomorphiser*)
 
 fun sh_tag id = "#" ^ string_of_int id ^ " sledgehammer: "
-fun minimize_tag id = "#" ^ string_of_int id ^ " minimize (sledgehammer): "
 fun proof_method_tag meth id = "#" ^ string_of_int id ^ " " ^ (!meth) ^ " (sledgehammer): "
 
 val separator = "-----"
 
 (*FIXME sensible to have Mirabelle-level Sledgehammer defaults?*)
 (*defaults used in this Mirabelle action*)
-val preplay_timeout_default = "3"
+val preplay_timeout_default = "1"
 val lam_trans_default = "smart"
 val uncurried_aliases_default = "smart"
 val fact_filter_default = "smart"
@@ -60,7 +55,6 @@
 val slice_default = "true"
 val max_calls_default = "10000000"
 val trivial_default = "false"
-val minimize_timeout_default = 5
 
 (*If a key is present in args then augment a list with its pair*)
 (*This is used to avoid fixing default values at the Mirabelle level, and
@@ -93,11 +87,6 @@
   posns: (Position.T * bool) list
   }
 
-datatype min_data = MinData of {
-  succs: int,
-  ab_ratios: int
-  }
-
 fun make_sh_data
       (calls,success,nontriv_calls,nontriv_success,lemmas,max_lems,time_isa,
        time_prover,time_prover_fail) =
@@ -106,9 +95,6 @@
          time_isa=time_isa, time_prover=time_prover,
          time_prover_fail=time_prover_fail}
 
-fun make_min_data (succs, ab_ratios) =
-  MinData{succs=succs, ab_ratios=ab_ratios}
-
 fun make_re_data (calls,success,nontriv_calls,nontriv_success,proofs,time,
                   timeout,lemmas,posns) =
   ReData{calls=calls, success=success, nontriv_calls=nontriv_calls,
@@ -116,7 +102,6 @@
          timeout=timeout, lemmas=lemmas, posns=posns}
 
 val empty_sh_data = make_sh_data (0, 0, 0, 0, 0, 0, 0, 0, 0)
-val empty_min_data = make_min_data (0, 0)
 val empty_re_data = make_re_data (0, 0, 0, 0, 0, 0, 0, (0,0,0), [])
 
 fun tuple_of_sh_data (ShData {calls, success, nontriv_calls, nontriv_success,
@@ -124,55 +109,28 @@
   time_prover, time_prover_fail}) = (calls, success, nontriv_calls,
   nontriv_success, lemmas, max_lems, time_isa, time_prover, time_prover_fail)
 
-fun tuple_of_min_data (MinData {succs, ab_ratios}) = (succs, ab_ratios)
-
 fun tuple_of_re_data (ReData {calls, success, nontriv_calls, nontriv_success,
   proofs, time, timeout, lemmas, posns}) = (calls, success, nontriv_calls,
   nontriv_success, proofs, time, timeout, lemmas, posns)
 
-datatype proof_method_mode =
-  Unminimized | Minimized | UnminimizedFT | MinimizedFT
-
 datatype data = Data of {
   sh: sh_data,
-  min: min_data,
-  re_u: re_data, (* proof method with unminimized set of lemmas *)
-  re_m: re_data, (* proof method with minimized set of lemmas *)
-  re_uft: re_data, (* proof method with unminimized set of lemmas and fully-typed *)
-  re_mft: re_data, (* proof method with minimized set of lemmas and fully-typed *)
-  mini: bool   (* with minimization *)
+  re_u: re_data (* proof method with unminimized set of lemmas *)
   }
 
-fun make_data (sh, min, re_u, re_m, re_uft, re_mft, mini) =
-  Data {sh=sh, min=min, re_u=re_u, re_m=re_m, re_uft=re_uft, re_mft=re_mft,
-    mini=mini}
-
-val empty_data = make_data (empty_sh_data, empty_min_data,
-  empty_re_data, empty_re_data, empty_re_data, empty_re_data, false)
+fun make_data (sh, re_u) = Data {sh=sh, re_u=re_u}
 
-fun map_sh_data f (Data {sh, min, re_u, re_m, re_uft, re_mft, mini}) =
-  let val sh' = make_sh_data (f (tuple_of_sh_data sh))
-  in make_data (sh', min, re_u, re_m, re_uft, re_mft, mini) end
-
-fun map_min_data f (Data {sh, min, re_u, re_m, re_uft, re_mft, mini}) =
-  let val min' = make_min_data (f (tuple_of_min_data min))
-  in make_data (sh, min', re_u, re_m, re_uft, re_mft, mini) end
+val empty_data = make_data (empty_sh_data, empty_re_data)
 
-fun map_re_data f m (Data {sh, min, re_u, re_m, re_uft, re_mft, mini}) =
+fun map_sh_data f (Data {sh, re_u}) =
+  let val sh' = make_sh_data (f (tuple_of_sh_data sh))
+  in make_data (sh', re_u) end
+
+fun map_re_data f (Data {sh, re_u}) =
   let
-    fun map_me g Unminimized   (u, m, uft, mft) = (g u, m, uft, mft)
-      | map_me g Minimized     (u, m, uft, mft) = (u, g m, uft, mft)
-      | map_me g UnminimizedFT (u, m, uft, mft) = (u, m, g uft, mft)
-      | map_me g MinimizedFT   (u, m, uft, mft) = (u, m, uft, g mft)
-
     val f' = make_re_data o f o tuple_of_re_data
-
-    val (re_u', re_m', re_uft', re_mft') =
-      map_me f' m (re_u, re_m, re_uft, re_mft)
-  in make_data (sh, min, re_u', re_m', re_uft', re_mft', mini) end
-
-fun set_mini mini (Data {sh, min, re_u, re_m, re_uft, re_mft, ...}) =
-  make_data (sh, min, re_u, re_m, re_uft, re_mft, mini)
+    val re_u' = f' re_u
+  in make_data (sh, re_u') end
 
 fun inc_max (n:int) (s,sos,m) = (s+n, sos + n*n, Int.max(m,n));
 
@@ -212,12 +170,6 @@
   (fn (calls,success,nontriv_calls, nontriv_success, lemmas,max_lems,time_isa,time_prover,time_prover_fail)
     => (calls,success,nontriv_calls, nontriv_success, lemmas,max_lems,time_isa,time_prover,time_prover_fail + t))
 
-val inc_min_succs = map_min_data
-  (fn (succs,ab_ratios) => (succs+1, ab_ratios))
-
-fun inc_min_ab_ratios r = map_min_data
-  (fn (succs, ab_ratios) => (succs, ab_ratios+r))
-
 val inc_proof_method_calls = map_re_data
   (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
     => (calls + 1, success, nontriv_calls, nontriv_success, proofs, time, timeout, lemmas,posns))
@@ -238,21 +190,21 @@
   (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
     => (calls, success, nontriv_calls, nontriv_success, proofs + 1, time, timeout, lemmas,posns))
 
-fun inc_proof_method_time m t = map_re_data
+fun inc_proof_method_time t = map_re_data
  (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
-  => (calls, success, nontriv_calls, nontriv_success, proofs, time + t, timeout, lemmas,posns)) m
+  => (calls, success, nontriv_calls, nontriv_success, proofs, time + t, timeout, lemmas,posns))
 
 val inc_proof_method_timeout = map_re_data
   (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
     => (calls, success, nontriv_calls, nontriv_success, proofs, time, timeout + 1, lemmas,posns))
 
-fun inc_proof_method_lemmas m n = map_re_data
+fun inc_proof_method_lemmas n = map_re_data
   (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
-    => (calls, success, nontriv_calls, nontriv_success, proofs, time, timeout, inc_max n lemmas, posns)) m
+    => (calls, success, nontriv_calls, nontriv_success, proofs, time, timeout, inc_max n lemmas, posns))
 
-fun inc_proof_method_posns m pos = map_re_data
+fun inc_proof_method_posns pos = map_re_data
   (fn (calls,success,nontriv_calls, nontriv_success, proofs,time,timeout,lemmas,posns)
-    => (calls, success, nontriv_calls, nontriv_success, proofs, time, timeout, lemmas, pos::posns)) m
+    => (calls, success, nontriv_calls, nontriv_success, proofs, time, timeout, lemmas, pos::posns))
 
 val str0 = string_of_int o the_default 0
 
@@ -311,37 +263,23 @@
   else ()
  )
 
-fun log_min_data log (succs, ab_ratios) =
-  (log ("Number of successful minimizations: " ^ string_of_int succs);
-   log ("After/before ratios: " ^ string_of_int ab_ratios)
-  )
-
 in
 
-fun log_data id log (Data {sh, min, re_u, re_m, re_uft, re_mft, mini}) =
+fun log_data id log (Data {sh, re_u}) =
   let
     val ShData {calls=sh_calls, ...} = sh
 
     fun app_if (ReData {calls, ...}) f = if calls > 0 then f () else ()
     fun log_re tag m =
       log_re_data log tag sh_calls (tuple_of_re_data m)
-    fun log_proof_method (tag1, m1) (tag2, m2) = app_if m1 (fn () =>
-      (log_re tag1 m1; log ""; app_if m2 (fn () => log_re tag2 m2)))
+    fun log_proof_method (tag1, m1) = app_if m1 (fn () => (log_re tag1 m1; log ""))
   in
     if sh_calls > 0
     then
      (log ("\n\n\nReport #" ^ string_of_int id ^ ":\n");
       log_sh_data log (tuple_of_sh_data sh);
       log "";
-      if not mini
-      then log_proof_method ("", re_u) ("fully-typed ", re_uft)
-      else
-        app_if re_u (fn () =>
-         (log_proof_method ("unminimized ", re_u) ("unminimized fully-typed ", re_uft);
-          log "";
-          app_if re_m (fn () =>
-            (log_min_data log (tuple_of_min_data min); log "";
-             log_proof_method ("", re_m) ("fully-typed ", re_mft))))))
+      log_proof_method ("", re_u))
     else ()
   end
 
@@ -411,7 +349,7 @@
 
 fun run_sh prover_name fact_filter type_enc strict max_facts slice
       lam_trans uncurried_aliases e_selection_heuristic term_order force_sos
-      hard_timeout timeout preplay_timeout isar_proofsLST sh_minimizeLST
+      hard_timeout timeout preplay_timeout isar_proofsLST minimizeLST
       max_new_mono_instancesLST max_mono_itersLST dir pos st =
   let
     val thy = Proof.theory_of st
@@ -421,7 +359,7 @@
         Config.put Sledgehammer_Prover_ATP.atp_dest_dir dir
         #> Config.put Sledgehammer_Prover_ATP.atp_problem_prefix
           ("prob_" ^ str0 (Position.line_of pos) ^ "__")
-        #> Config.put SMT_Config.debug_files
+        #> Config.put SMT2_Config.debug_files
           (dir ^ "/" ^ Name.desymbolize (SOME false) (ATP_Util.timestamp ()) ^ "_"
           ^ serial_string ())
       | set_file_name NONE = I
@@ -435,7 +373,7 @@
                   term_order |> the_default I)
             #> (Option.map (Config.put ATP_Systems.force_sos)
                   force_sos |> the_default I))
-    val params as {max_facts, ...} =
+    val params as {max_facts, minimize, preplay_timeout, ...} =
       Sledgehammer_Commands.default_params thy
          ([("verbose", "true"),
            ("fact_filter", fact_filter),
@@ -448,7 +386,7 @@
            ("timeout", string_of_int timeout),
            ("preplay_timeout", preplay_timeout)]
           |> isar_proofsLST
-          |> sh_minimizeLST (*don't confuse the two minimization flags*)
+          |> minimizeLST (*don't confuse the two minimization flags*)
           |> max_new_mono_instancesLST
           |> max_mono_itersLST)
     val default_max_facts =
@@ -460,11 +398,9 @@
       | SOME secs => TimeLimit.timeLimit (Time.fromSeconds secs))
     fun failed failure =
       ({outcome = SOME failure, used_facts = [], used_from = [],
-        run_time = Time.zeroTime,
-        preplay = Lazy.value (Sledgehammer_Proof_Methods.Metis_Method (NONE, NONE),
-          Sledgehammer_Proof_Methods.Play_Failed),
-        message = K "", message_tail = ""}, ~1)
-    val ({outcome, used_facts, run_time, preplay, message, message_tail, ...}
+        preferred_methss = (Sledgehammer_Proof_Methods.Auto_Method, []), run_time = Time.zeroTime,
+        message = K ""}, ~1)
+    val ({outcome, used_facts, preferred_methss, run_time, message, ...}
          : Sledgehammer_Prover.prover_result,
          time_isa) = time_limit (Mirabelle.cpu_time (fn () =>
       let
@@ -488,11 +424,12 @@
         val problem =
           {comment = "", state = st', goal = goal, subgoal = i,
            subgoal_count = Sledgehammer_Util.subgoal_count st, factss = factss}
-      in prover params (K (K (K ""))) problem end)) ()
+      in prover params problem end)) ()
       handle TimeLimit.TimeOut => failed ATP_Proof.TimedOut
            | Fail "inappropriate" => failed ATP_Proof.Inappropriate
     val time_prover = run_time |> Time.toMilliseconds
-    val msg = message (Lazy.force preplay) ^ message_tail
+    val msg = message (fn () => Sledgehammer.play_one_line_proof minimize preplay_timeout used_facts
+      st' i preferred_methss)
   in
     (case outcome of
       NONE => (msg, SH_OK (time_isa, time_prover, used_facts))
@@ -534,7 +471,7 @@
     val preplay_timeout = AList.lookup (op =) args preplay_timeoutK
       |> the_default preplay_timeout_default
     val isar_proofsLST = available_parameter args isar_proofsK "isar_proofs"
-    val sh_minimizeLST = available_parameter args sh_minimizeK "minimize"
+    val minimizeLST = available_parameter args minimizeK "minimize"
     val max_new_mono_instancesLST =
       available_parameter args max_new_mono_instancesK max_new_mono_instancesK
     val max_mono_itersLST = available_parameter args max_mono_itersK max_mono_itersK
@@ -542,7 +479,7 @@
     val (msg, result) =
       run_sh prover_name fact_filter type_enc strict max_facts slice lam_trans
         uncurried_aliases e_selection_heuristic term_order force_sos
-        hard_timeout timeout preplay_timeout isar_proofsLST sh_minimizeLST
+        hard_timeout timeout preplay_timeout isar_proofsLST minimizeLST
         max_new_mono_instancesLST max_mono_itersLST dir pos st
   in
     (case result of
@@ -574,57 +511,6 @@
 
 end
 
-fun run_minimize args meth named_thms id ({pre = st, log, ...} : Mirabelle.run_args) =
-  let
-    val thy = Proof.theory_of st
-    val {goal, ...} = Proof.goal st
-    val n0 = length (these (!named_thms))
-    val prover_name = get_prover_name thy args
-    val type_enc = AList.lookup (op =) args type_encK |> the_default type_enc_default
-    val strict = AList.lookup (op =) args strictK |> the_default strict_default
-    val timeout =
-      AList.lookup (op =) args minimize_timeoutK
-      |> Option.map (fst o read_int o raw_explode)  (* FIXME Symbol.explode (?) *)
-      |> the_default minimize_timeout_default
-    val preplay_timeout = AList.lookup (op =) args preplay_timeoutK
-      |> the_default preplay_timeout_default
-    val isar_proofsLST = available_parameter args isar_proofsK "isar_proofs"
-    val sh_minimizeLST = available_parameter args sh_minimizeK "minimize"
-    val max_new_mono_instancesLST =
-      available_parameter args max_new_mono_instancesK max_new_mono_instancesK
-    val max_mono_itersLST = available_parameter args max_mono_itersK max_mono_itersK
-    val params = Sledgehammer_Commands.default_params thy
-     ([("provers", prover_name),
-       ("verbose", "true"),
-       ("type_enc", type_enc),
-       ("strict", strict),
-       ("timeout", string_of_int timeout),
-       ("preplay_timeout", preplay_timeout)]
-      |> isar_proofsLST
-      |> sh_minimizeLST (*don't confuse the two minimization flags*)
-      |> max_new_mono_instancesLST
-      |> max_mono_itersLST)
-    val minimize =
-      Sledgehammer_Prover_Minimize.minimize_facts (K ()) prover_name params true 1
-        (Sledgehammer_Util.subgoal_count st)
-    val _ = log separator
-    val (used_facts, (preplay, message, message_tail)) =
-      minimize st goal NONE (these (!named_thms))
-    val msg = message (Lazy.force preplay) ^ message_tail
-  in
-    (case used_facts of
-      SOME named_thms' =>
-        (change_data id inc_min_succs;
-         change_data id (inc_min_ab_ratios ((100 * length named_thms') div n0));
-         if length named_thms' = n0
-         then log (minimize_tag id ^ "already minimal")
-         else (meth := proof_method_from_msg args msg;
-               named_thms := SOME named_thms';
-               log (minimize_tag id ^ "succeeded:\n" ^ msg))
-        )
-    | NONE => log (minimize_tag id ^ "failed: " ^ msg))
-  end
-
 fun override_params prover type_enc timeout =
   [("provers", prover),
    ("max_facts", "0"),
@@ -633,13 +519,13 @@
    ("slice", "false"),
    ("timeout", timeout |> Time.toSeconds |> string_of_int)]
 
-fun run_proof_method trivial full m name meth named_thms id
+fun run_proof_method trivial full name meth named_thms id
     ({pre=st, timeout, log, pos, ...}: Mirabelle.run_args) =
   let
     fun do_method named_thms ctxt =
       let
         val ref_of_str =
-          suffix ";" #> Outer_Syntax.scan Position.none #> Parse_Spec.xthm
+          suffix ";" #> Outer_Syntax.scan (Keyword.get_lexicons ()) Position.none #> Parse.xthm
           #> fst
         val thms = named_thms |> maps snd
         val facts = named_thms |> map (ref_of_str o fst o fst)
@@ -648,16 +534,16 @@
           timeout |> Time.toReal |> curry Real.* time_slice |> Time.fromReal
         fun sledge_tac time_slice prover type_enc =
           Sledgehammer_Tactics.sledgehammer_as_oracle_tac ctxt
-            (override_params prover type_enc (my_timeout time_slice)) fact_override
+            (override_params prover type_enc (my_timeout time_slice)) fact_override []
       in
         if !meth = "sledgehammer_tac" then
           sledge_tac 0.2 ATP_Proof.vampireN "mono_native"
           ORELSE' sledge_tac 0.2 ATP_Proof.eN "poly_guards??"
           ORELSE' sledge_tac 0.2 ATP_Proof.spassN "mono_native"
           ORELSE' sledge_tac 0.2 ATP_Proof.z3_tptpN "poly_tags??"
-          ORELSE' SMT_Solver.smt_tac ctxt thms
+          ORELSE' SMT2_Solver.smt2_tac ctxt thms
         else if !meth = "smt" then
-          SMT_Solver.smt_tac ctxt thms
+          SMT2_Solver.smt2_tac ctxt thms
         else if full then
           Metis_Tactic.metis_tac [ATP_Proof_Reconstruct.full_typesN]
             ATP_Proof_Reconstruct.default_metis_lam_trans ctxt thms
@@ -665,7 +551,7 @@
           let
             val (type_encs, lam_trans) =
               !meth
-              |> Outer_Syntax.scan Position.start
+              |> Outer_Syntax.scan (Keyword.get_lexicons ()) Position.start
               |> filter Token.is_proper |> tl
               |> Metis_Tactic.parse_metis_options |> fst
               |>> the_default [ATP_Proof_Reconstruct.partial_typesN]
@@ -680,22 +566,22 @@
       Mirabelle.can_apply timeout (do_method named_thms) st
 
     fun with_time (false, t) = "failed (" ^ string_of_int t ^ ")"
-      | with_time (true, t) = (change_data id (inc_proof_method_success m);
+      | with_time (true, t) = (change_data id inc_proof_method_success;
           if trivial then ()
-          else change_data id (inc_proof_method_nontriv_success m);
-          change_data id (inc_proof_method_lemmas m (length named_thms));
-          change_data id (inc_proof_method_time m t);
-          change_data id (inc_proof_method_posns m (pos, trivial));
-          if name = "proof" then change_data id (inc_proof_method_proofs m) else ();
+          else change_data id inc_proof_method_nontriv_success;
+          change_data id (inc_proof_method_lemmas (length named_thms));
+          change_data id (inc_proof_method_time t);
+          change_data id (inc_proof_method_posns (pos, trivial));
+          if name = "proof" then change_data id inc_proof_method_proofs else ();
           "succeeded (" ^ string_of_int t ^ ")")
     fun timed_method named_thms =
       (with_time (Mirabelle.cpu_time apply_method named_thms), true)
-      handle TimeLimit.TimeOut => (change_data id (inc_proof_method_timeout m); ("timeout", false))
+      handle TimeLimit.TimeOut => (change_data id inc_proof_method_timeout; ("timeout", false))
            | ERROR msg => ("error: " ^ msg, false)
 
     val _ = log separator
-    val _ = change_data id (inc_proof_method_calls m)
-    val _ = if trivial then () else change_data id (inc_proof_method_nontriv_calls m)
+    val _ = change_data id inc_proof_method_calls
+    val _ = if trivial then () else change_data id inc_proof_method_nontriv_calls
   in
     named_thms
     |> timed_method
@@ -724,38 +610,18 @@
           val meth = Unsynchronized.ref ""
           val named_thms =
             Unsynchronized.ref (NONE : ((string * stature) * thm list) list option)
-          val minimize = AList.defined (op =) args minimizeK
-          val metis_ft = AList.defined (op =) args metis_ftK
           val trivial =
             if AList.lookup (op =) args check_trivialK |> the_default trivial_default
                             |> Markup.parse_bool then
               Try0.try0 (SOME try_timeout) ([], [], [], []) pre
               handle TimeLimit.TimeOut => false
             else false
-          fun apply_method m1 m2 =
-            if metis_ft
-            then
-              if not (Mirabelle.catch_result (proof_method_tag meth) false
-                  (run_proof_method trivial false m1 name meth (these (!named_thms))) id st)
-              then
-                (Mirabelle.catch_result (proof_method_tag meth) false
-                  (run_proof_method trivial true m2 name meth (these (!named_thms))) id st; ())
-              else ()
-            else
-              (Mirabelle.catch_result (proof_method_tag meth) false
-                (run_proof_method trivial false m1 name meth (these (!named_thms))) id st; ())
+          fun apply_method () =
+            (Mirabelle.catch_result (proof_method_tag meth) false
+              (run_proof_method trivial false name meth (these (!named_thms))) id st; ())
         in
-          change_data id (set_mini minimize);
           Mirabelle.catch sh_tag (run_sledgehammer trivial args meth named_thms) id st;
-          if is_some (!named_thms)
-          then
-           (apply_method Unminimized UnminimizedFT;
-            if minimize andalso not (null (these (!named_thms)))
-            then
-             (Mirabelle.catch minimize_tag (run_minimize args meth named_thms) id st;
-              apply_method Minimized MinimizedFT)
-            else ())
-          else ()
+          if is_some (!named_thms) then apply_method () else ()
         end
     end
   end
--- a/src/HOL/Nat.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Nat.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -12,6 +12,8 @@
 begin
 
 ML_file "~~/src/Tools/rat.ML"
+
+named_theorems arith "arith facts -- only ground formulas"
 ML_file "Tools/arith_data.ML"
 ML_file "~~/src/Provers/Arith/fast_lin_arith.ML"
 
@@ -130,9 +132,9 @@
   nat.collapse
   nat.expand
   nat.sel
-  nat.sel_exhaust
-  nat.sel_split
-  nat.sel_split_asm
+  nat.exhaust_sel
+  nat.split_sel
+  nat.split_sel_asm
 
 lemma nat_exhaust [case_names 0 Suc, cases type: nat]:
   -- {* for backward compatibility -- names of variables differ *}
--- a/src/HOL/Nitpick.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Nitpick.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -14,109 +14,105 @@
   "nitpick_params" :: thy_decl
 begin
 
-typedecl bisim_iterator
+datatype ('a, 'b) fun_box = FunBox "'a \<Rightarrow> 'b"
+datatype ('a, 'b) pair_box = PairBox 'a 'b
+datatype 'a word = Word "'a set"
 
-axiomatization unknown :: 'a
-           and is_unknown :: "'a \<Rightarrow> bool"
-           and bisim :: "bisim_iterator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
-           and bisim_iterator_max :: bisim_iterator
-           and Quot :: "'a \<Rightarrow> 'b"
-           and safe_The :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
-
-datatype ('a, 'b) fun_box = FunBox "('a \<Rightarrow> 'b)"
-datatype ('a, 'b) pair_box = PairBox 'a 'b
-
+typedecl bisim_iterator
 typedecl unsigned_bit
 typedecl signed_bit
 
-datatype 'a word = Word "('a set)"
+consts
+  unknown :: 'a
+  is_unknown :: "'a \<Rightarrow> bool"
+  bisim :: "bisim_iterator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
+  bisim_iterator_max :: bisim_iterator
+  Quot :: "'a \<Rightarrow> 'b"
+  safe_The :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
 
 text {*
 Alternative definitions.
 *}
 
-lemma Ex1_unfold [nitpick_unfold]:
-"Ex1 P \<equiv> \<exists>x. {x. P x} = {x}"
-apply (rule eq_reflection)
-apply (simp add: Ex1_def set_eq_iff)
-apply (rule iffI)
- apply (erule exE)
- apply (erule conjE)
- apply (rule_tac x = x in exI)
- apply (rule allI)
- apply (rename_tac y)
- apply (erule_tac x = y in allE)
-by auto
+lemma Ex1_unfold[nitpick_unfold]: "Ex1 P \<equiv> \<exists>x. {x. P x} = {x}"
+  apply (rule eq_reflection)
+  apply (simp add: Ex1_def set_eq_iff)
+  apply (rule iffI)
+   apply (erule exE)
+   apply (erule conjE)
+   apply (rule_tac x = x in exI)
+   apply (rule allI)
+   apply (rename_tac y)
+   apply (erule_tac x = y in allE)
+  by auto
 
-lemma rtrancl_unfold [nitpick_unfold]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
+lemma rtrancl_unfold[nitpick_unfold]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
   by (simp only: rtrancl_trancl_reflcl)
 
-lemma rtranclp_unfold [nitpick_unfold]:
-"rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
-by (rule eq_reflection) (auto dest: rtranclpD)
+lemma rtranclp_unfold[nitpick_unfold]: "rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
+  by (rule eq_reflection) (auto dest: rtranclpD)
 
-lemma tranclp_unfold [nitpick_unfold]:
-"tranclp r a b \<equiv> (a, b) \<in> trancl {(x, y). r x y}"
-by (simp add: trancl_def)
+lemma tranclp_unfold[nitpick_unfold]:
+  "tranclp r a b \<equiv> (a, b) \<in> trancl {(x, y). r x y}"
+  by (simp add: trancl_def)
 
 lemma [nitpick_simp]:
-"of_nat n = (if n = 0 then 0 else 1 + of_nat (n - 1))"
-by (cases n) auto
+  "of_nat n = (if n = 0 then 0 else 1 + of_nat (n - 1))"
+  by (cases n) auto
 
 definition prod :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set" where
-"prod A B = {(a, b). a \<in> A \<and> b \<in> B}"
+  "prod A B = {(a, b). a \<in> A \<and> b \<in> B}"
 
 definition refl' :: "('a \<times> 'a) set \<Rightarrow> bool" where
-"refl' r \<equiv> \<forall>x. (x, x) \<in> r"
+  "refl' r \<equiv> \<forall>x. (x, x) \<in> r"
 
 definition wf' :: "('a \<times> 'a) set \<Rightarrow> bool" where
-"wf' r \<equiv> acyclic r \<and> (finite r \<or> unknown)"
+  "wf' r \<equiv> acyclic r \<and> (finite r \<or> unknown)"
 
 definition card' :: "'a set \<Rightarrow> nat" where
-"card' A \<equiv> if finite A then length (SOME xs. set xs = A \<and> distinct xs) else 0"
+  "card' A \<equiv> if finite A then length (SOME xs. set xs = A \<and> distinct xs) else 0"
 
 definition setsum' :: "('a \<Rightarrow> 'b\<Colon>comm_monoid_add) \<Rightarrow> 'a set \<Rightarrow> 'b" where
-"setsum' f A \<equiv> if finite A then listsum (map f (SOME xs. set xs = A \<and> distinct xs)) else 0"
+  "setsum' f A \<equiv> if finite A then listsum (map f (SOME xs. set xs = A \<and> distinct xs)) else 0"
 
 inductive fold_graph' :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool" where
-"fold_graph' f z {} z" |
-"\<lbrakk>x \<in> A; fold_graph' f z (A - {x}) y\<rbrakk> \<Longrightarrow> fold_graph' f z A (f x y)"
+  "fold_graph' f z {} z" |
+  "\<lbrakk>x \<in> A; fold_graph' f z (A - {x}) y\<rbrakk> \<Longrightarrow> fold_graph' f z A (f x y)"
 
 text {*
 The following lemmas are not strictly necessary but they help the
 \textit{specialize} optimization.
 *}
 
-lemma The_psimp [nitpick_psimp]:
-  "P = (op =) x \<Longrightarrow> The P = x"
+lemma The_psimp[nitpick_psimp]: "P = (op =) x \<Longrightarrow> The P = x"
   by auto
 
-lemma Eps_psimp [nitpick_psimp]:
-"\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
-apply (cases "P (Eps P)")
- apply auto
-apply (erule contrapos_np)
-by (rule someI)
+lemma Eps_psimp[nitpick_psimp]:
+  "\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
+  apply (cases "P (Eps P)")
+   apply auto
+  apply (erule contrapos_np)
+  by (rule someI)
 
-lemma case_unit_unfold [nitpick_unfold]:
-"case_unit x u \<equiv> x"
-apply (subgoal_tac "u = ()")
- apply (simp only: unit.case)
-by simp
+lemma case_unit_unfold[nitpick_unfold]:
+  "case_unit x u \<equiv> x"
+  apply (subgoal_tac "u = ()")
+   apply (simp only: unit.case)
+  by simp
 
-declare unit.case [nitpick_simp del]
+declare unit.case[nitpick_simp del]
 
-lemma case_nat_unfold [nitpick_unfold]:
-"case_nat x f n \<equiv> if n = 0 then x else f (n - 1)"
-apply (rule eq_reflection)
-by (cases n) auto
+lemma case_nat_unfold[nitpick_unfold]:
+  "case_nat x f n \<equiv> if n = 0 then x else f (n - 1)"
+  apply (rule eq_reflection)
+  by (cases n) auto
 
-declare nat.case [nitpick_simp del]
+declare nat.case[nitpick_simp del]
 
-lemma size_list_simp [nitpick_simp]:
-"size_list f xs = (if xs = [] then 0 else Suc (f (hd xs) + size_list f (tl xs)))"
-"size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
-by (cases xs) auto
+lemma size_list_simp[nitpick_simp]:
+  "size_list f xs = (if xs = [] then 0 else Suc (f (hd xs) + size_list f (tl xs)))"
+  "size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
+  by (cases xs) auto
 
 text {*
 Auxiliary definitions used to provide an alternative representation for
@@ -124,89 +120,89 @@
 *}
 
 function nat_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
-[simp del]: "nat_gcd x y = (if y = 0 then x else nat_gcd y (x mod y))"
-by auto
-termination
-apply (relation "measure (\<lambda>(x, y). x + y + (if y > x then 1 else 0))")
- apply auto
- apply (metis mod_less_divisor xt1(9))
-by (metis mod_mod_trivial mod_self nat_neq_iff xt1(10))
+  "nat_gcd x y = (if y = 0 then x else nat_gcd y (x mod y))"
+  by auto
+  termination
+  apply (relation "measure (\<lambda>(x, y). x + y + (if y > x then 1 else 0))")
+   apply auto
+   apply (metis mod_less_divisor xt1(9))
+  by (metis mod_mod_trivial mod_self nat_neq_iff xt1(10))
+
+declare nat_gcd.simps[simp del]
 
 definition nat_lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
-"nat_lcm x y = x * y div (nat_gcd x y)"
+  "nat_lcm x y = x * y div (nat_gcd x y)"
 
 definition int_gcd :: "int \<Rightarrow> int \<Rightarrow> int" where
-"int_gcd x y = int (nat_gcd (nat (abs x)) (nat (abs y)))"
+  "int_gcd x y = int (nat_gcd (nat (abs x)) (nat (abs y)))"
 
 definition int_lcm :: "int \<Rightarrow> int \<Rightarrow> int" where
-"int_lcm x y = int (nat_lcm (nat (abs x)) (nat (abs y)))"
+  "int_lcm x y = int (nat_lcm (nat (abs x)) (nat (abs y)))"
 
 definition Frac :: "int \<times> int \<Rightarrow> bool" where
-"Frac \<equiv> \<lambda>(a, b). b > 0 \<and> int_gcd a b = 1"
+  "Frac \<equiv> \<lambda>(a, b). b > 0 \<and> int_gcd a b = 1"
 
-axiomatization
-  Abs_Frac :: "int \<times> int \<Rightarrow> 'a" and
+consts
+  Abs_Frac :: "int \<times> int \<Rightarrow> 'a"
   Rep_Frac :: "'a \<Rightarrow> int \<times> int"
 
 definition zero_frac :: 'a where
-"zero_frac \<equiv> Abs_Frac (0, 1)"
+  "zero_frac \<equiv> Abs_Frac (0, 1)"
 
 definition one_frac :: 'a where
-"one_frac \<equiv> Abs_Frac (1, 1)"
+  "one_frac \<equiv> Abs_Frac (1, 1)"
 
 definition num :: "'a \<Rightarrow> int" where
-"num \<equiv> fst o Rep_Frac"
+  "num \<equiv> fst o Rep_Frac"
 
 definition denom :: "'a \<Rightarrow> int" where
-"denom \<equiv> snd o Rep_Frac"
+  "denom \<equiv> snd o Rep_Frac"
 
 function norm_frac :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
-[simp del]: "norm_frac a b = (if b < 0 then norm_frac (- a) (- b)
-                              else if a = 0 \<or> b = 0 then (0, 1)
-                              else let c = int_gcd a b in (a div c, b div c))"
-by pat_completeness auto
-termination by (relation "measure (\<lambda>(_, b). if b < 0 then 1 else 0)") auto
+  "norm_frac a b =
+    (if b < 0 then norm_frac (- a) (- b)
+     else if a = 0 \<or> b = 0 then (0, 1)
+     else let c = int_gcd a b in (a div c, b div c))"
+  by pat_completeness auto
+  termination by (relation "measure (\<lambda>(_, b). if b < 0 then 1 else 0)") auto
+
+declare norm_frac.simps[simp del]
 
 definition frac :: "int \<Rightarrow> int \<Rightarrow> 'a" where
-"frac a b \<equiv> Abs_Frac (norm_frac a b)"
+  "frac a b \<equiv> Abs_Frac (norm_frac a b)"
 
 definition plus_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
-[nitpick_simp]:
-"plus_frac q r = (let d = int_lcm (denom q) (denom r) in
-                    frac (num q * (d div denom q) + num r * (d div denom r)) d)"
+  [nitpick_simp]: "plus_frac q r = (let d = int_lcm (denom q) (denom r) in
+    frac (num q * (d div denom q) + num r * (d div denom r)) d)"
 
 definition times_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
-[nitpick_simp]:
-"times_frac q r = frac (num q * num r) (denom q * denom r)"
+  [nitpick_simp]: "times_frac q r = frac (num q * num r) (denom q * denom r)"
 
 definition uminus_frac :: "'a \<Rightarrow> 'a" where
-"uminus_frac q \<equiv> Abs_Frac (- num q, denom q)"
+  "uminus_frac q \<equiv> Abs_Frac (- num q, denom q)"
 
 definition number_of_frac :: "int \<Rightarrow> 'a" where
-"number_of_frac n \<equiv> Abs_Frac (n, 1)"
+  "number_of_frac n \<equiv> Abs_Frac (n, 1)"
 
 definition inverse_frac :: "'a \<Rightarrow> 'a" where
-"inverse_frac q \<equiv> frac (denom q) (num q)"
+  "inverse_frac q \<equiv> frac (denom q) (num q)"
 
 definition less_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
-[nitpick_simp]:
-"less_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) < 0"
+  [nitpick_simp]: "less_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) < 0"
 
 definition less_eq_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
-[nitpick_simp]:
-"less_eq_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) \<le> 0"
+  [nitpick_simp]: "less_eq_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) \<le> 0"
 
 definition of_frac :: "'a \<Rightarrow> 'b\<Colon>{inverse,ring_1}" where
-"of_frac q \<equiv> of_int (num q) / of_int (denom q)"
+  "of_frac q \<equiv> of_int (num q) / of_int (denom q)"
 
 axiomatization wf_wfrec :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
 
 definition wf_wfrec' :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
-[nitpick_simp]: "wf_wfrec' R F x = F (cut (wf_wfrec R F) R x) x"
+  [nitpick_simp]: "wf_wfrec' R F x = F (cut (wf_wfrec R F) R x) x"
 
 definition wfrec' ::  "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
-"wfrec' R F x \<equiv> if wf R then wf_wfrec' R F x
-                else THE y. wfrec_rel R (%f x. F (cut f R x) x) x y"
+  "wfrec' R F x \<equiv> if wf R then wf_wfrec' R F x else THE y. wfrec_rel R (\<lambda>f x. F (cut f R x) x) x y"
 
 ML_file "Tools/Nitpick/kodkod.ML"
 ML_file "Tools/Nitpick/kodkod_sat.ML"
@@ -234,20 +230,18 @@
      (@{const_name wfrec}, @{const_name wfrec'})]
 *}
 
-hide_const (open) unknown is_unknown bisim bisim_iterator_max Quot safe_The
-    FunBox PairBox Word prod refl' wf' card' setsum'
-    fold_graph' nat_gcd nat_lcm int_gcd int_lcm Frac Abs_Frac Rep_Frac zero_frac
-    one_frac num denom norm_frac frac plus_frac times_frac uminus_frac
-    number_of_frac inverse_frac less_frac less_eq_frac of_frac wf_wfrec wf_wfrec
-    wfrec'
+hide_const (open) unknown is_unknown bisim bisim_iterator_max Quot safe_The FunBox PairBox Word prod
+  refl' wf' card' setsum' fold_graph' nat_gcd nat_lcm int_gcd int_lcm Frac Abs_Frac Rep_Frac
+  zero_frac one_frac num denom norm_frac frac plus_frac times_frac uminus_frac number_of_frac
+  inverse_frac less_frac less_eq_frac of_frac wf_wfrec wf_wfrec wfrec'
+
 hide_type (open) bisim_iterator fun_box pair_box unsigned_bit signed_bit word
-hide_fact (open) Ex1_unfold rtrancl_unfold rtranclp_unfold tranclp_unfold
-    prod_def refl'_def wf'_def card'_def setsum'_def
-    fold_graph'_def The_psimp Eps_psimp case_unit_unfold case_nat_unfold
-    size_list_simp nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def
-    zero_frac_def one_frac_def num_def denom_def norm_frac_def frac_def
-    plus_frac_def times_frac_def uminus_frac_def number_of_frac_def
-    inverse_frac_def less_frac_def less_eq_frac_def of_frac_def wf_wfrec'_def
-    wfrec'_def
+
+hide_fact (open) Ex1_unfold rtrancl_unfold rtranclp_unfold tranclp_unfold prod_def refl'_def wf'_def
+  card'_def setsum'_def fold_graph'_def The_psimp Eps_psimp case_unit_unfold case_nat_unfold
+  size_list_simp nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def one_frac_def
+  num_def denom_def norm_frac_def frac_def plus_frac_def times_frac_def uminus_frac_def
+  number_of_frac_def inverse_frac_def less_frac_def less_eq_frac_def of_frac_def wf_wfrec'_def
+  wfrec'_def
 
 end
--- a/src/HOL/Nominal/nominal_induct.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Nominal/nominal_induct.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -172,9 +172,8 @@
   Scan.lift (Args.mode Induct.no_simpN) --
   (Parse.and_list' (Scan.repeat (unless_more_args def_inst)) --
     avoiding -- fixing -- rule_spec) >>
-  (fn (no_simp, (((x, y), z), w)) => fn ctxt =>
-    RAW_METHOD_CASES (fn facts =>
-      HEADGOAL (nominal_induct_tac ctxt (not no_simp) x y z w facts)));
+  (fn (no_simp, (((x, y), z), w)) => fn ctxt => fn facts =>
+    HEADGOAL (nominal_induct_tac ctxt (not no_simp) x y z w facts));
 
 end;
 
--- a/src/HOL/Nominal/nominal_inductive.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Nominal/nominal_inductive.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -167,8 +167,8 @@
     val _ = (case duplicates (op = o pairself fst) avoids of
         [] => ()
       | xs => error ("Duplicate case names: " ^ commas_quote (map fst xs)));
-    val _ = assert_all (null o duplicates op = o snd) avoids
-      (fn (a, _) => error ("Duplicate variable names for case " ^ quote a));
+    val _ = avoids |> forall (fn (a, xs) => null (duplicates (op =) xs) orelse
+      error ("Duplicate variable names for case " ^ quote a));
     val _ = (case subtract (op =) induct_cases (map fst avoids) of
         [] => ()
       | xs => error ("No such case(s) in inductive definition: " ^ commas_quote xs));
--- a/src/HOL/Nominal/nominal_primrec.ML	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Nominal/nominal_primrec.ML	Wed Aug 27 15:52:58 2014 +0200
@@ -373,9 +373,10 @@
           |> snd
         end)
       [goals] |>
-    Proof.apply (Method.Basic (fn ctxt => RAW_METHOD (fn _ =>
-      rewrite_goals_tac ctxt defs_thms THEN
-      compose_tac (false, rule, length rule_prems) 1))) |>
+    Proof.apply (Method.Basic (fn ctxt => fn _ =>
+      NO_CASES
+       (rewrite_goals_tac ctxt defs_thms THEN
+        compose_tac (false, rule, length rule_prems) 1))) |>
     Seq.hd
   end;
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Number_Theory/Euclidean_Algorithm.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -0,0 +1,1819 @@
+(* Author: Manuel Eberl *)
+
+header {* Abstract euclidean algorithm *}
+
+theory Euclidean_Algorithm
+imports Complex_Main
+begin
+
+lemma finite_int_set_iff_bounded_le:
+  "finite (N::int set) = (\<exists>m\<ge>0. \<forall>n\<in>N. abs n \<le> m)"
+proof
+  assume "finite (N::int set)"
+  hence "finite (nat ` abs ` N)" by (intro finite_imageI)
+  hence "\<exists>m. \<forall>n\<in>nat`abs`N. n \<le> m" by (simp add: finite_nat_set_iff_bounded_le)
+  then obtain m :: nat where "\<forall>n\<in>N. nat (abs n) \<le> nat (int m)" by auto
+  then show "\<exists>m\<ge>0. \<forall>n\<in>N. abs n \<le> m" by (intro exI[of _ "int m"]) (auto simp: nat_le_eq_zle)
+next
+  assume "\<exists>m\<ge>0. \<forall>n\<in>N. abs n \<le> m"
+  then obtain m where "m \<ge> 0" and "\<forall>n\<in>N. abs n \<le> m" by blast
+  hence "\<forall>n\<in>N. nat (abs n) \<le> nat m" by (auto simp: nat_le_eq_zle)
+  hence "\<forall>n\<in>nat`abs`N. n \<le> nat m" by (auto simp: nat_le_eq_zle)
+  hence A: "finite ((nat \<circ> abs)`N)" unfolding o_def 
+      by (subst finite_nat_set_iff_bounded_le) blast
+  {
+    assume "\<not>finite N"
+    from pigeonhole_infinite[OF this A] obtain x 
+       where "x \<in> N" and B: "~finite {a\<in>N. nat (abs a) = nat (abs x)}" 
+       unfolding o_def by blast
+    have "{a\<in>N. nat (abs a) = nat (abs x)} \<subseteq> {x, -x}" by auto
+    hence "finite {a\<in>N. nat (abs a) = nat (abs x)}" by (rule finite_subset) simp
+    with B have False by contradiction
+  }
+  then show "finite N" by blast
+qed
+
+context semiring_div
+begin
+
+lemma dvd_setprod [intro]:
+  assumes "finite A" and "x \<in> A"
+  shows "f x dvd setprod f A"
+proof
+  from `finite A` have "setprod f (insert x (A - {x})) = f x * setprod f (A - {x})"
+    by (intro setprod.insert) auto
+  also from `x \<in> A` have "insert x (A - {x}) = A" by blast
+  finally show "setprod f A = f x * setprod f (A - {x})" .
+qed
+
+lemma dvd_mult_cancel_left:
+  assumes "a \<noteq> 0" and "a * b dvd a * c"
+  shows "b dvd c"
+proof-
+  from assms(2) obtain k where "a * c = a * b * k" unfolding dvd_def by blast
+  hence "c * a = b * k * a" by (simp add: ac_simps)
+  hence "c * (a div a) = b * k * (a div a)" by (simp add: div_mult_swap)
+  also from `a \<noteq> 0` have "a div a = 1" by simp
+  finally show ?thesis by simp
+qed
+
+lemma dvd_mult_cancel_right:
+  "a \<noteq> 0 \<Longrightarrow> b * a dvd c * a \<Longrightarrow> b dvd c"
+  by (subst (asm) (1 2) ac_simps, rule dvd_mult_cancel_left)
+
+lemma nonzero_pow_nonzero:
+  "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
+  by (induct n) (simp_all add: no_zero_divisors)
+
+lemma zero_pow_zero: "n \<noteq> 0 \<Longrightarrow> 0 ^ n = 0"
+  by (cases n, simp_all)
+
+lemma pow_zero_iff:
+  "n \<noteq> 0 \<Longrightarrow> a^n = 0 \<longleftrightarrow> a = 0"
+  using nonzero_pow_nonzero zero_pow_zero by auto
+
+end
+
+context semiring_div
+begin 
+
+definition ring_inv :: "'a \<Rightarrow> 'a"
+where
+  "ring_inv x = 1 div x"
+
+definition is_unit :: "'a \<Rightarrow> bool"
+where
+  "is_unit x \<longleftrightarrow> x dvd 1"
+
+definition associated :: "'a \<Rightarrow> 'a \<Rightarrow> bool" 
+where
+  "associated x y \<longleftrightarrow> x dvd y \<and> y dvd x"
+
+lemma unit_prod [intro]:
+  "is_unit x \<Longrightarrow> is_unit y \<Longrightarrow> is_unit (x * y)"
+  unfolding is_unit_def by (subst mult_1_left [of 1, symmetric], rule mult_dvd_mono) 
+
+lemma unit_ring_inv:
+  "is_unit y \<Longrightarrow> x div y = x * ring_inv y"
+  by (simp add: div_mult_swap ring_inv_def is_unit_def)
+
+lemma unit_ring_inv_ring_inv [simp]:
+  "is_unit x \<Longrightarrow> ring_inv (ring_inv x) = x"
+  unfolding is_unit_def ring_inv_def
+  by (metis div_mult_mult1_if div_mult_self1_is_id dvd_mult_div_cancel mult_1_right)
+
+lemma inv_imp_eq_ring_inv:
+  "a * b = 1 \<Longrightarrow> ring_inv a = b"
+  by (metis dvd_mult_div_cancel dvd_mult_right mult_1_right mult.left_commute one_dvd ring_inv_def)
+
+lemma ring_inv_is_inv1 [simp]:
+  "is_unit a \<Longrightarrow> a * ring_inv a = 1"
+  unfolding is_unit_def ring_inv_def by (simp add: dvd_mult_div_cancel)
+
+lemma ring_inv_is_inv2 [simp]:
+  "is_unit a \<Longrightarrow> ring_inv a * a = 1"
+  by (simp add: ac_simps)
+
+lemma unit_ring_inv_unit [simp, intro]:
+  assumes "is_unit x"
+  shows "is_unit (ring_inv x)"
+proof -
+  from assms have "1 = ring_inv x * x" by simp
+  then show "is_unit (ring_inv x)" unfolding is_unit_def by (rule dvdI)
+qed
+
+lemma mult_unit_dvd_iff:
+  "is_unit y \<Longrightarrow> x * y dvd z \<longleftrightarrow> x dvd z"
+proof
+  assume "is_unit y" "x * y dvd z"
+  then show "x dvd z" by (simp add: dvd_mult_left)
+next
+  assume "is_unit y" "x dvd z"
+  then obtain k where "z = x * k" unfolding dvd_def by blast
+  with `is_unit y` have "z = (x * y) * (ring_inv y * k)" 
+      by (simp add: mult_ac)
+  then show "x * y dvd z" by (rule dvdI)
+qed
+
+lemma div_unit_dvd_iff:
+  "is_unit y \<Longrightarrow> x div y dvd z \<longleftrightarrow> x dvd z"
+  by (subst unit_ring_inv) (assumption, simp add: mult_unit_dvd_iff)
+
+lemma dvd_mult_unit_iff:
+  "is_unit y \<Longrightarrow> x dvd z * y \<longleftrightarrow> x dvd z"
+proof
+  assume "is_unit y" and "x dvd z * y"
+  have "z * y dvd z * (y * ring_inv y)" by (subst mult_assoc [symmetric]) simp
+  also from `is_unit y` have "y * ring_inv y = 1" by simp
+  finally have "z * y dvd z" by simp
+  with `x dvd z * y` show "x dvd z" by (rule dvd_trans)
+next
+  assume "x dvd z"
+  then show "x dvd z * y" by simp
+qed
+
+lemma dvd_div_unit_iff:
+  "is_unit y \<Longrightarrow> x dvd z div y \<longleftrightarrow> x dvd z"
+  by (subst unit_ring_inv) (assumption, simp add: dvd_mult_unit_iff)
+
+lemmas unit_dvd_iff = mult_unit_dvd_iff div_unit_dvd_iff dvd_mult_unit_iff dvd_div_unit_iff
+
+lemma unit_div [intro]:
+  "is_unit x \<Longrightarrow> is_unit y \<Longrightarrow> is_unit (x div y)"
+  by (subst unit_ring_inv) (assumption, rule unit_prod, simp_all)
+
+lemma unit_div_mult_swap:
+  "is_unit z \<Longrightarrow> x * (y div z) = x * y div z"
+  by (simp only: unit_ring_inv [of _ y] unit_ring_inv [of _ "x*y"] ac_simps)
+
+lemma unit_div_commute:
+  "is_unit y \<Longrightarrow> x div y * z = x * z div y"
+  by (simp only: unit_ring_inv [of _ x] unit_ring_inv [of _ "x*z"] ac_simps)
+
+lemma unit_imp_dvd [dest]:
+  "is_unit y \<Longrightarrow> y dvd x"
+  by (rule dvd_trans [of _ 1]) (simp_all add: is_unit_def)
+
+lemma dvd_unit_imp_unit:
+  "is_unit y \<Longrightarrow> x dvd y \<Longrightarrow> is_unit x"
+  by (unfold is_unit_def) (rule dvd_trans)
+
+lemma ring_inv_0 [simp]:
+  "ring_inv 0 = 0"
+  unfolding ring_inv_def by simp
+
+lemma unit_ring_inv'1:
+  assumes "is_unit y"
+  shows "x div (y * z) = x * ring_inv y div z" 
+proof -
+  from assms have "x div (y * z) = x * (ring_inv y * y) div (y * z)"
+    by simp
+  also have "... = y * (x * ring_inv y) div (y * z)"
+    by (simp only: mult_ac)
+  also have "... = x * ring_inv y div z"
+    by (cases "y = 0", simp, rule div_mult_mult1)
+  finally show ?thesis .
+qed
+
+lemma associated_comm:
+  "associated x y \<Longrightarrow> associated y x"
+  by (simp add: associated_def)
+
+lemma associated_0 [simp]:
+  "associated 0 b \<longleftrightarrow> b = 0"
+  "associated a 0 \<longleftrightarrow> a = 0"
+  unfolding associated_def by simp_all
+
+lemma associated_unit:
+  "is_unit x \<Longrightarrow> associated x y \<Longrightarrow> is_unit y"
+  unfolding associated_def by (fast dest: dvd_unit_imp_unit)
+
+lemma is_unit_1 [simp]:
+  "is_unit 1"
+  unfolding is_unit_def by simp
+
+lemma not_is_unit_0 [simp]:
+  "\<not> is_unit 0"
+  unfolding is_unit_def by auto
+
+lemma unit_mult_left_cancel:
+  assumes "is_unit x"
+  shows "(x * y) = (x * z) \<longleftrightarrow> y = z"
+proof -
+  from assms have "x \<noteq> 0" by auto
+  then show ?thesis by (metis div_mult_self1_is_id)
+qed
+
+lemma unit_mult_right_cancel:
+  "is_unit x \<Longrightarrow> (y * x) = (z * x) \<longleftrightarrow> y = z"
+  by (simp add: ac_simps unit_mult_left_cancel)
+
+lemma unit_div_cancel:
+  "is_unit x \<Longrightarrow> (y div x) = (z div x) \<longleftrightarrow> y = z"
+  apply (subst unit_ring_inv[of _ y], assumption)
+  apply (subst unit_ring_inv[of _ z], assumption)
+  apply (rule unit_mult_right_cancel, erule unit_ring_inv_unit)
+  done
+
+lemma unit_eq_div1:
+  "is_unit y \<Longrightarrow> x div y = z \<longleftrightarrow> x = z * y"
+  apply (subst unit_ring_inv, assumption)
+  apply (subst unit_mult_right_cancel[symmetric], assumption)
+  apply (subst mult_assoc, subst ring_inv_is_inv2, assumption, simp)
+  done
+
+lemma unit_eq_div2:
+  "is_unit y \<Longrightarrow> x = z div y \<longleftrightarrow> x * y = z"
+  by (subst (1 2) eq_commute, simp add: unit_eq_div1, subst eq_commute, rule refl)
+
+lemma associated_iff_div_unit:
+  "associated x y \<longleftrightarrow> (\<exists>z. is_unit z \<and> x = z * y)"
+proof
+  assume "associated x y"
+  show "\<exists>z. is_unit z \<and> x = z * y"
+  proof (cases "x = 0")
+    assume "x = 0"
+    then show "\<exists>z. is_unit z \<and> x = z * y" using `associated x y`
+        by (intro exI[of _ 1], simp add: associated_def)
+  next
+    assume [simp]: "x \<noteq> 0"
+    hence [simp]: "x dvd y" "y dvd x" using `associated x y`
+        unfolding associated_def by simp_all
+    hence "1 = x div y * (y div x)"
+      by (simp add: div_mult_swap dvd_div_mult_self)
+    hence "is_unit (x div y)" unfolding is_unit_def by (rule dvdI)
+    moreover have "x = (x div y) * y" by (simp add: dvd_div_mult_self)
+    ultimately show ?thesis by blast
+  qed
+next
+  assume "\<exists>z. is_unit z \<and> x = z * y"
+  then obtain z where "is_unit z" and "x = z * y" by blast
+  hence "y = x * ring_inv z" by (simp add: algebra_simps)
+  hence "x dvd y" by simp
+  moreover from `x = z * y` have "y dvd x" by simp
+  ultimately show "associated x y" unfolding associated_def by simp
+qed
+
+lemmas unit_simps = mult_unit_dvd_iff div_unit_dvd_iff dvd_mult_unit_iff 
+  dvd_div_unit_iff unit_div_mult_swap unit_div_commute
+  unit_mult_left_cancel unit_mult_right_cancel unit_div_cancel 
+  unit_eq_div1 unit_eq_div2
+
+end
+
+context ring_div
+begin
+
+lemma is_unit_neg [simp]:
+  "is_unit (- x) \<Longrightarrow> is_unit x"
+  unfolding is_unit_def by simp
+
+lemma is_unit_neg_1 [simp]:
+  "is_unit (-1)"
+  unfolding is_unit_def by simp
+
+end
+
+lemma is_unit_nat [simp]:
+  "is_unit (x::nat) \<longleftrightarrow> x = 1"
+  unfolding is_unit_def by simp
+
+lemma is_unit_int:
+  "is_unit (x::int) \<longleftrightarrow> x = 1 \<or> x = -1"
+  unfolding is_unit_def by auto
+
+text {*
+  A Euclidean semiring is a semiring upon which the Euclidean algorithm can be
+  implemented. It must provide:
+  \begin{itemize}
+  \item division with remainder
+  \item a size function such that @{term "size (a mod b) < size b"} 
+        for any @{term "b \<noteq> 0"}
+  \item a normalisation factor such that two associated numbers are equal iff 
+        they are the same when divided by their normalisation factors.
+  \end{itemize}
+  The existence of these functions makes it possible to derive gcd and lcm functions 
+  for any Euclidean semiring.
+*} 
+class euclidean_semiring = semiring_div + 
+  fixes euclidean_size :: "'a \<Rightarrow> nat"
+  fixes normalisation_factor :: "'a \<Rightarrow> 'a"
+  assumes mod_size_less [simp]: 
+    "b \<noteq> 0 \<Longrightarrow> euclidean_size (a mod b) < euclidean_size b"
+  assumes size_mult_mono:
+    "b \<noteq> 0 \<Longrightarrow> euclidean_size (a * b) \<ge> euclidean_size a"
+  assumes normalisation_factor_is_unit [intro,simp]: 
+    "a \<noteq> 0 \<Longrightarrow> is_unit (normalisation_factor a)"
+  assumes normalisation_factor_mult: "normalisation_factor (a * b) = 
+    normalisation_factor a * normalisation_factor b"
+  assumes normalisation_factor_unit: "is_unit x \<Longrightarrow> normalisation_factor x = x"
+  assumes normalisation_factor_0 [simp]: "normalisation_factor 0 = 0"
+begin
+
+lemma normalisation_factor_dvd [simp]:
+  "a \<noteq> 0 \<Longrightarrow> normalisation_factor a dvd b"
+  by (rule unit_imp_dvd, simp)
+    
+lemma normalisation_factor_1 [simp]:
+  "normalisation_factor 1 = 1"
+  by (simp add: normalisation_factor_unit)
+
+lemma normalisation_factor_0_iff [simp]:
+  "normalisation_factor x = 0 \<longleftrightarrow> x = 0"
+proof
+  assume "normalisation_factor x = 0"
+  hence "\<not> is_unit (normalisation_factor x)"
+    by (metis not_is_unit_0)
+  then show "x = 0" by force
+next
+  assume "x = 0"
+  then show "normalisation_factor x = 0" by simp
+qed
+
+lemma normalisation_factor_pow:
+  "normalisation_factor (x ^ n) = normalisation_factor x ^ n"
+  by (induct n) (simp_all add: normalisation_factor_mult power_Suc2)
+
+lemma normalisation_correct [simp]:
+  "normalisation_factor (x div normalisation_factor x) = (if x = 0 then 0 else 1)"
+proof (cases "x = 0", simp)
+  assume "x \<noteq> 0"
+  let ?nf = "normalisation_factor"
+  from normalisation_factor_is_unit[OF `x \<noteq> 0`] have "?nf x \<noteq> 0"
+    by (metis not_is_unit_0) 
+  have "?nf (x div ?nf x) * ?nf (?nf x) = ?nf (x div ?nf x * ?nf x)" 
+    by (simp add: normalisation_factor_mult)
+  also have "x div ?nf x * ?nf x = x" using `x \<noteq> 0`
+    by (simp add: dvd_div_mult_self)
+  also have "?nf (?nf x) = ?nf x" using `x \<noteq> 0` 
+    normalisation_factor_is_unit normalisation_factor_unit by simp
+  finally show ?thesis using `x \<noteq> 0` and `?nf x \<noteq> 0` 
+    by (metis div_mult_self2_is_id div_self)
+qed
+
+lemma normalisation_0_iff [simp]:
+  "x div normalisation_factor x = 0 \<longleftrightarrow> x = 0"
+  by (cases "x = 0", simp, subst unit_eq_div1, blast, simp)
+
+lemma associated_iff_normed_eq:
+  "associated a b \<longleftrightarrow> a div normalisation_factor a = b div normalisation_factor b"
+proof (cases "b = 0", simp, cases "a = 0", metis associated_0(1) normalisation_0_iff, rule iffI)
+  let ?nf = normalisation_factor
+  assume "a \<noteq> 0" "b \<noteq> 0" "a div ?nf a = b div ?nf b"
+  hence "a = b * (?nf a div ?nf b)"
+    apply (subst (asm) unit_eq_div1, blast, subst (asm) unit_div_commute, blast)
+    apply (subst div_mult_swap, simp, simp)
+    done
+  with `a \<noteq> 0` `b \<noteq> 0` have "\<exists>z. is_unit z \<and> a = z * b"
+    by (intro exI[of _ "?nf a div ?nf b"], force simp: mult_ac)
+  with associated_iff_div_unit show "associated a b" by simp
+next
+  let ?nf = normalisation_factor
+  assume "a \<noteq> 0" "b \<noteq> 0" "associated a b"
+  with associated_iff_div_unit obtain z where "is_unit z" and "a = z * b" by blast
+  then show "a div ?nf a = b div ?nf b"
+    apply (simp only: `a = z * b` normalisation_factor_mult normalisation_factor_unit)
+    apply (rule div_mult_mult1, force)
+    done
+  qed
+
+lemma normed_associated_imp_eq:
+  "associated a b \<Longrightarrow> normalisation_factor a \<in> {0, 1} \<Longrightarrow> normalisation_factor b \<in> {0, 1} \<Longrightarrow> a = b"
+  by (simp add: associated_iff_normed_eq, elim disjE, simp_all)
+    
+lemmas normalisation_factor_dvd_iff [simp] =
+  unit_dvd_iff [OF normalisation_factor_is_unit]
+
+lemma euclidean_division:
+  fixes a :: 'a and b :: 'a
+  assumes "b \<noteq> 0"
+  obtains s and t where "a = s * b + t" 
+    and "euclidean_size t < euclidean_size b"
+proof -
+  from div_mod_equality[of a b 0] 
+     have "a = a div b * b + a mod b" by simp
+  with that and assms show ?thesis by force
+qed
+
+lemma dvd_euclidean_size_eq_imp_dvd:
+  assumes "a \<noteq> 0" and b_dvd_a: "b dvd a" and size_eq: "euclidean_size a = euclidean_size b"
+  shows "a dvd b"
+proof (subst dvd_eq_mod_eq_0, rule ccontr)
+  assume "b mod a \<noteq> 0"
+  from b_dvd_a have b_dvd_mod: "b dvd b mod a" by (simp add: dvd_mod_iff)
+  from b_dvd_mod obtain c where "b mod a = b * c" unfolding dvd_def by blast
+    with `b mod a \<noteq> 0` have "c \<noteq> 0" by auto
+  with `b mod a = b * c` have "euclidean_size (b mod a) \<ge> euclidean_size b"
+      using size_mult_mono by force
+  moreover from `a \<noteq> 0` have "euclidean_size (b mod a) < euclidean_size a"
+      using mod_size_less by blast
+  ultimately show False using size_eq by simp
+qed
+
+function gcd_eucl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+where
+  "gcd_eucl a b = (if b = 0 then a div normalisation_factor a else gcd_eucl b (a mod b))"
+  by (pat_completeness, simp)
+termination by (relation "measure (euclidean_size \<circ> snd)", simp_all)
+
+declare gcd_eucl.simps [simp del]
+
+lemma gcd_induct: "\<lbrakk>\<And>b. P b 0; \<And>a b. 0 \<noteq> b \<Longrightarrow> P b (a mod b) \<Longrightarrow> P a b\<rbrakk> \<Longrightarrow> P a b"
+proof (induct a b rule: gcd_eucl.induct)
+  case ("1" m n)
+    then show ?case by (cases "n = 0") auto
+qed
+
+definition lcm_eucl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+where
+  "lcm_eucl a b = a * b div (gcd_eucl a b * normalisation_factor (a * b))"
+
+  (* Somewhat complicated definition of Lcm that has the advantage of working
+     for infinite sets as well *)
+
+definition Lcm_eucl :: "'a set \<Rightarrow> 'a"
+where
+  "Lcm_eucl A = (if \<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) then
+     let l = SOME l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l =
+       (LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n)
+       in l div normalisation_factor l
+      else 0)"
+
+definition Gcd_eucl :: "'a set \<Rightarrow> 'a"
+where
+  "Gcd_eucl A = Lcm_eucl {d. \<forall>a\<in>A. d dvd a}"
+
+end
+
+class euclidean_semiring_gcd = euclidean_semiring + gcd + Gcd +
+  assumes gcd_gcd_eucl: "gcd = gcd_eucl" and lcm_lcm_eucl: "lcm = lcm_eucl"
+  assumes Gcd_Gcd_eucl: "Gcd = Gcd_eucl" and Lcm_Lcm_eucl: "Lcm = Lcm_eucl"
+begin
+
+lemma gcd_red:
+  "gcd x y = gcd y (x mod y)"
+  by (metis gcd_eucl.simps mod_0 mod_by_0 gcd_gcd_eucl)
+
+lemma gcd_non_0:
+  "y \<noteq> 0 \<Longrightarrow> gcd x y = gcd y (x mod y)"
+  by (rule gcd_red)
+
+lemma gcd_0_left:
+  "gcd 0 x = x div normalisation_factor x"
+   by (simp only: gcd_gcd_eucl, subst gcd_eucl.simps, subst gcd_eucl.simps, simp add: Let_def)
+
+lemma gcd_0:
+  "gcd x 0 = x div normalisation_factor x"
+  by (simp only: gcd_gcd_eucl, subst gcd_eucl.simps, simp add: Let_def)
+
+lemma gcd_dvd1 [iff]: "gcd x y dvd x"
+  and gcd_dvd2 [iff]: "gcd x y dvd y"
+proof (induct x y rule: gcd_eucl.induct)
+  fix x y :: 'a
+  assume IH1: "y \<noteq> 0 \<Longrightarrow> gcd y (x mod y) dvd y"
+  assume IH2: "y \<noteq> 0 \<Longrightarrow> gcd y (x mod y) dvd (x mod y)"
+  
+  have "gcd x y dvd x \<and> gcd x y dvd y"
+  proof (cases "y = 0")
+    case True
+      then show ?thesis by (cases "x = 0", simp_all add: gcd_0)
+  next
+    case False
+      with IH1 and IH2 show ?thesis by (simp add: gcd_non_0 dvd_mod_iff)
+  qed
+  then show "gcd x y dvd x" "gcd x y dvd y" by simp_all
+qed
+
+lemma dvd_gcd_D1: "k dvd gcd m n \<Longrightarrow> k dvd m"
+  by (rule dvd_trans, assumption, rule gcd_dvd1)
+
+lemma dvd_gcd_D2: "k dvd gcd m n \<Longrightarrow> k dvd n"
+  by (rule dvd_trans, assumption, rule gcd_dvd2)
+
+lemma gcd_greatest:
+  fixes k x y :: 'a
+  shows "k dvd x \<Longrightarrow> k dvd y \<Longrightarrow> k dvd gcd x y"
+proof (induct x y rule: gcd_eucl.induct)
+  case (1 x y)
+  show ?case
+    proof (cases "y = 0")
+      assume "y = 0"
+      with 1 show ?thesis by (cases "x = 0", simp_all add: gcd_0)
+    next
+      assume "y \<noteq> 0"
+      with 1 show ?thesis by (simp add: gcd_non_0 dvd_mod_iff) 
+    qed
+qed
+
+lemma dvd_gcd_iff:
+  "k dvd gcd x y \<longleftrightarrow> k dvd x \<and> k dvd y"
+  by (blast intro!: gcd_greatest intro: dvd_trans)
+
+lemmas gcd_greatest_iff = dvd_gcd_iff
+
+lemma gcd_zero [simp]:
+  "gcd x y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+  by (metis dvd_0_left dvd_refl gcd_dvd1 gcd_dvd2 gcd_greatest)+
+
+lemma normalisation_factor_gcd [simp]:
+  "normalisation_factor (gcd x y) = (if x = 0 \<and> y = 0 then 0 else 1)" (is "?f x y = ?g x y")
+proof (induct x y rule: gcd_eucl.induct)
+  fix x y :: 'a
+  assume IH: "y \<noteq> 0 \<Longrightarrow> ?f y (x mod y) = ?g y (x mod y)"
+  then show "?f x y = ?g x y" by (cases "y = 0", auto simp: gcd_non_0 gcd_0)
+qed
+
+lemma gcdI:
+  "k dvd x \<Longrightarrow> k dvd y \<Longrightarrow> (\<And>l. l dvd x \<Longrightarrow> l dvd y \<Longrightarrow> l dvd k)
+    \<Longrightarrow> normalisation_factor k = (if k = 0 then 0 else 1) \<Longrightarrow> k = gcd x y"
+  by (intro normed_associated_imp_eq) (auto simp: associated_def intro: gcd_greatest)
+
+sublocale gcd!: abel_semigroup gcd
+proof
+  fix x y z 
+  show "gcd (gcd x y) z = gcd x (gcd y z)"
+  proof (rule gcdI)
+    have "gcd (gcd x y) z dvd gcd x y" "gcd x y dvd x" by simp_all
+    then show "gcd (gcd x y) z dvd x" by (rule dvd_trans)
+    have "gcd (gcd x y) z dvd gcd x y" "gcd x y dvd y" by simp_all
+    hence "gcd (gcd x y) z dvd y" by (rule dvd_trans)
+    moreover have "gcd (gcd x y) z dvd z" by simp
+    ultimately show "gcd (gcd x y) z dvd gcd y z"
+      by (rule gcd_greatest)
+    show "normalisation_factor (gcd (gcd x y) z) =  (if gcd (gcd x y) z = 0 then 0 else 1)"
+      by auto
+    fix l assume "l dvd x" and "l dvd gcd y z"
+    with dvd_trans[OF _ gcd_dvd1] and dvd_trans[OF _ gcd_dvd2]
+      have "l dvd y" and "l dvd z" by blast+
+    with `l dvd x` show "l dvd gcd (gcd x y) z"
+      by (intro gcd_greatest)
+  qed
+next
+  fix x y
+  show "gcd x y = gcd y x"
+    by (rule gcdI) (simp_all add: gcd_greatest)
+qed
+
+lemma gcd_unique: "d dvd a \<and> d dvd b \<and> 
+    normalisation_factor d = (if d = 0 then 0 else 1) \<and>
+    (\<forall>e. e dvd a \<and> e dvd b \<longrightarrow> e dvd d) \<longleftrightarrow> d = gcd a b"
+  by (rule, auto intro: gcdI simp: gcd_greatest)
+
+lemma gcd_dvd_prod: "gcd a b dvd k * b"
+  using mult_dvd_mono [of 1] by auto
+
+lemma gcd_1_left [simp]: "gcd 1 x = 1"
+  by (rule sym, rule gcdI, simp_all)
+
+lemma gcd_1 [simp]: "gcd x 1 = 1"
+  by (rule sym, rule gcdI, simp_all)
+
+lemma gcd_proj2_if_dvd: 
+  "y dvd x \<Longrightarrow> gcd x y = y div normalisation_factor y"
+  by (cases "y = 0", simp_all add: dvd_eq_mod_eq_0 gcd_non_0 gcd_0)
+
+lemma gcd_proj1_if_dvd: 
+  "x dvd y \<Longrightarrow> gcd x y = x div normalisation_factor x"
+  by (subst gcd.commute, simp add: gcd_proj2_if_dvd)
+
+lemma gcd_proj1_iff: "gcd m n = m div normalisation_factor m \<longleftrightarrow> m dvd n"
+proof
+  assume A: "gcd m n = m div normalisation_factor m"
+  show "m dvd n"
+  proof (cases "m = 0")
+    assume [simp]: "m \<noteq> 0"
+    from A have B: "m = gcd m n * normalisation_factor m"
+      by (simp add: unit_eq_div2)
+    show ?thesis by (subst B, simp add: mult_unit_dvd_iff)
+  qed (insert A, simp)
+next
+  assume "m dvd n"
+  then show "gcd m n = m div normalisation_factor m" by (rule gcd_proj1_if_dvd)
+qed
+  
+lemma gcd_proj2_iff: "gcd m n = n div normalisation_factor n \<longleftrightarrow> n dvd m"
+  by (subst gcd.commute, simp add: gcd_proj1_iff)
+
+lemma gcd_mod1 [simp]:
+  "gcd (x mod y) y = gcd x y"
+  by (rule gcdI, metis dvd_mod_iff gcd_dvd1 gcd_dvd2, simp_all add: gcd_greatest dvd_mod_iff)
+
+lemma gcd_mod2 [simp]:
+  "gcd x (y mod x) = gcd x y"
+  by (rule gcdI, simp, metis dvd_mod_iff gcd_dvd1 gcd_dvd2, simp_all add: gcd_greatest dvd_mod_iff)
+         
+lemma normalisation_factor_dvd' [simp]:
+  "normalisation_factor x dvd x"
+  by (cases "x = 0", simp_all)
+
+lemma gcd_mult_distrib': 
+  "k div normalisation_factor k * gcd x y = gcd (k*x) (k*y)"
+proof (induct x y rule: gcd_eucl.induct)
+  case (1 x y)
+  show ?case
+  proof (cases "y = 0")
+    case True
+    then show ?thesis by (simp add: normalisation_factor_mult gcd_0 algebra_simps div_mult_div_if_dvd)
+  next
+    case False
+    hence "k div normalisation_factor k * gcd x y =  gcd (k * y) (k * (x mod y))" 
+      using 1 by (subst gcd_red, simp)
+    also have "... = gcd (k * x) (k * y)"
+      by (simp add: mult_mod_right gcd.commute)
+    finally show ?thesis .
+  qed
+qed
+
+lemma gcd_mult_distrib:
+  "k * gcd x y = gcd (k*x) (k*y) * normalisation_factor k"
+proof-
+  let ?nf = "normalisation_factor"
+  from gcd_mult_distrib' 
+    have "gcd (k*x) (k*y) = k div ?nf k * gcd x y" ..
+  also have "... = k * gcd x y div ?nf k"
+    by (metis dvd_div_mult dvd_eq_mod_eq_0 mod_0 normalisation_factor_dvd)
+  finally show ?thesis
+    by (simp add: ac_simps dvd_mult_div_cancel)
+qed
+
+lemma euclidean_size_gcd_le1 [simp]:
+  assumes "a \<noteq> 0"
+  shows "euclidean_size (gcd a b) \<le> euclidean_size a"
+proof -
+   have "gcd a b dvd a" by (rule gcd_dvd1)
+   then obtain c where A: "a = gcd a b * c" unfolding dvd_def by blast
+   with `a \<noteq> 0` show ?thesis by (subst (2) A, intro size_mult_mono) auto
+qed
+
+lemma euclidean_size_gcd_le2 [simp]:
+  "b \<noteq> 0 \<Longrightarrow> euclidean_size (gcd a b) \<le> euclidean_size b"
+  by (subst gcd.commute, rule euclidean_size_gcd_le1)
+
+lemma euclidean_size_gcd_less1:
+  assumes "a \<noteq> 0" and "\<not>a dvd b"
+  shows "euclidean_size (gcd a b) < euclidean_size a"
+proof (rule ccontr)
+  assume "\<not>euclidean_size (gcd a b) < euclidean_size a"
+  with `a \<noteq> 0` have "euclidean_size (gcd a b) = euclidean_size a"
+    by (intro le_antisym, simp_all)
+  with assms have "a dvd gcd a b" by (auto intro: dvd_euclidean_size_eq_imp_dvd)
+  hence "a dvd b" using dvd_gcd_D2 by blast
+  with `\<not>a dvd b` show False by contradiction
+qed
+
+lemma euclidean_size_gcd_less2:
+  assumes "b \<noteq> 0" and "\<not>b dvd a"
+  shows "euclidean_size (gcd a b) < euclidean_size b"
+  using assms by (subst gcd.commute, rule euclidean_size_gcd_less1)
+
+lemma gcd_mult_unit1: "is_unit a \<Longrightarrow> gcd (x*a) y = gcd x y"
+  apply (rule gcdI)
+  apply (rule dvd_trans, rule gcd_dvd1, simp add: unit_simps)
+  apply (rule gcd_dvd2)
+  apply (rule gcd_greatest, simp add: unit_simps, assumption)
+  apply (subst normalisation_factor_gcd, simp add: gcd_0)
+  done
+
+lemma gcd_mult_unit2: "is_unit a \<Longrightarrow> gcd x (y*a) = gcd x y"
+  by (subst gcd.commute, subst gcd_mult_unit1, assumption, rule gcd.commute)
+
+lemma gcd_div_unit1: "is_unit a \<Longrightarrow> gcd (x div a) y = gcd x y"
+  by (simp add: unit_ring_inv gcd_mult_unit1)
+
+lemma gcd_div_unit2: "is_unit a \<Longrightarrow> gcd x (y div a) = gcd x y"
+  by (simp add: unit_ring_inv gcd_mult_unit2)
+
+lemma gcd_idem: "gcd x x = x div normalisation_factor x"
+  by (cases "x = 0") (simp add: gcd_0_left, rule sym, rule gcdI, simp_all)
+
+lemma gcd_right_idem: "gcd (gcd p q) q = gcd p q"
+  apply (rule gcdI)
+  apply (simp add: ac_simps)
+  apply (rule gcd_dvd2)
+  apply (rule gcd_greatest, erule (1) gcd_greatest, assumption)
+  apply (simp add: gcd_zero)
+  done
+
+lemma gcd_left_idem: "gcd p (gcd p q) = gcd p q"
+  apply (rule gcdI)
+  apply simp
+  apply (rule dvd_trans, rule gcd_dvd2, rule gcd_dvd2)
+  apply (rule gcd_greatest, assumption, erule gcd_greatest, assumption)
+  apply (simp add: gcd_zero)
+  done
+
+lemma comp_fun_idem_gcd: "comp_fun_idem gcd"
+proof
+  fix a b show "gcd a \<circ> gcd b = gcd b \<circ> gcd a"
+    by (simp add: fun_eq_iff ac_simps)
+next
+  fix a show "gcd a \<circ> gcd a = gcd a"
+    by (simp add: fun_eq_iff gcd_left_idem)
+qed
+
+lemma coprime_dvd_mult:
+  assumes "gcd k n = 1" and "k dvd m * n"
+  shows "k dvd m"
+proof -
+  let ?nf = "normalisation_factor"
+  from assms gcd_mult_distrib [of m k n] 
+    have A: "m = gcd (m * k) (m * n) * ?nf m" by simp
+  from `k dvd m * n` show ?thesis by (subst A, simp_all add: gcd_greatest)
+qed
+
+lemma coprime_dvd_mult_iff:
+  "gcd k n = 1 \<Longrightarrow> (k dvd m * n) = (k dvd m)"
+  by (rule, rule coprime_dvd_mult, simp_all)
+
+lemma gcd_dvd_antisym:
+  "gcd a b dvd gcd c d \<Longrightarrow> gcd c d dvd gcd a b \<Longrightarrow> gcd a b = gcd c d"
+proof (rule gcdI)
+  assume A: "gcd a b dvd gcd c d" and B: "gcd c d dvd gcd a b"
+  have "gcd c d dvd c" by simp
+  with A show "gcd a b dvd c" by (rule dvd_trans)
+  have "gcd c d dvd d" by simp
+  with A show "gcd a b dvd d" by (rule dvd_trans)
+  show "normalisation_factor (gcd a b) = (if gcd a b = 0 then 0 else 1)"
+    by (simp add: gcd_zero)
+  fix l assume "l dvd c" and "l dvd d"
+  hence "l dvd gcd c d" by (rule gcd_greatest)
+  from this and B show "l dvd gcd a b" by (rule dvd_trans)
+qed
+
+lemma gcd_mult_cancel:
+  assumes "gcd k n = 1"
+  shows "gcd (k * m) n = gcd m n"
+proof (rule gcd_dvd_antisym)
+  have "gcd (gcd (k * m) n) k = gcd (gcd k n) (k * m)" by (simp add: ac_simps)
+  also note `gcd k n = 1`
+  finally have "gcd (gcd (k * m) n) k = 1" by simp
+  hence "gcd (k * m) n dvd m" by (rule coprime_dvd_mult, simp add: ac_simps)
+  moreover have "gcd (k * m) n dvd n" by simp
+  ultimately show "gcd (k * m) n dvd gcd m n" by (rule gcd_greatest)
+  have "gcd m n dvd (k * m)" and "gcd m n dvd n" by simp_all
+  then show "gcd m n dvd gcd (k * m) n" by (rule gcd_greatest)
+qed
+
+lemma coprime_crossproduct:
+  assumes [simp]: "gcd a d = 1" "gcd b c = 1"
+  shows "associated (a * c) (b * d) \<longleftrightarrow> associated a b \<and> associated c d" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+  assume ?rhs then show ?lhs unfolding associated_def by (fast intro: mult_dvd_mono)
+next
+  assume ?lhs
+  from `?lhs` have "a dvd b * d" unfolding associated_def by (metis dvd_mult_left) 
+  hence "a dvd b" by (simp add: coprime_dvd_mult_iff)
+  moreover from `?lhs` have "b dvd a * c" unfolding associated_def by (metis dvd_mult_left) 
+  hence "b dvd a" by (simp add: coprime_dvd_mult_iff)
+  moreover from `?lhs` have "c dvd d * b" 
+    unfolding associated_def by (metis dvd_mult_right ac_simps)
+  hence "c dvd d" by (simp add: coprime_dvd_mult_iff gcd.commute)
+  moreover from `?lhs` have "d dvd c * a"
+    unfolding associated_def by (metis dvd_mult_right ac_simps)
+  hence "d dvd c" by (simp add: coprime_dvd_mult_iff gcd.commute)
+  ultimately show ?rhs unfolding associated_def by simp
+qed
+
+lemma gcd_add1 [simp]:
+  "gcd (m + n) n = gcd m n"
+  by (cases "n = 0", simp_all add: gcd_non_0)
+
+lemma gcd_add2 [simp]:
+  "gcd m (m + n) = gcd m n"
+  using gcd_add1 [of n m] by (simp add: ac_simps)
+
+lemma gcd_add_mult: "gcd m (k * m + n) = gcd m n"
+  by (subst gcd.commute, subst gcd_red, simp)
+
+lemma coprimeI: "(\<And>l. \<lbrakk>l dvd x; l dvd y\<rbrakk> \<Longrightarrow> l dvd 1) \<Longrightarrow> gcd x y = 1"
+  by (rule sym, rule gcdI, simp_all)
+
+lemma coprime: "gcd a b = 1 \<longleftrightarrow> (\<forall>d. d dvd a \<and> d dvd b \<longleftrightarrow> is_unit d)"
+  by (auto simp: is_unit_def intro: coprimeI gcd_greatest dvd_gcd_D1 dvd_gcd_D2)
+
+lemma div_gcd_coprime:
+  assumes nz: "a \<noteq> 0 \<or> b \<noteq> 0"
+  defines [simp]: "d \<equiv> gcd a b"
+  defines [simp]: "a' \<equiv> a div d" and [simp]: "b' \<equiv> b div d"
+  shows "gcd a' b' = 1"
+proof (rule coprimeI)
+  fix l assume "l dvd a'" "l dvd b'"
+  then obtain s t where "a' = l * s" "b' = l * t" unfolding dvd_def by blast
+  moreover have "a = a' * d" "b = b' * d" by (simp_all add: dvd_div_mult_self)
+  ultimately have "a = (l * d) * s" "b = (l * d) * t"
+    by (metis ac_simps)+
+  hence "l*d dvd a" and "l*d dvd b" by (simp_all only: dvd_triv_left)
+  hence "l*d dvd d" by (simp add: gcd_greatest)
+  then obtain u where "u * l * d = d" unfolding dvd_def
+    by (metis ac_simps mult_assoc)
+  moreover from nz have "d \<noteq> 0" by (simp add: gcd_zero)
+  ultimately have "u * l = 1" 
+    by (metis div_mult_self1_is_id div_self ac_simps)
+  then show "l dvd 1" by force
+qed
+
+lemma coprime_mult: 
+  assumes da: "gcd d a = 1" and db: "gcd d b = 1"
+  shows "gcd d (a * b) = 1"
+  apply (subst gcd.commute)
+  using da apply (subst gcd_mult_cancel)
+  apply (subst gcd.commute, assumption)
+  apply (subst gcd.commute, rule db)
+  done
+
+lemma coprime_lmult:
+  assumes dab: "gcd d (a * b) = 1" 
+  shows "gcd d a = 1"
+proof (rule coprimeI)
+  fix l assume "l dvd d" and "l dvd a"
+  hence "l dvd a * b" by simp
+  with `l dvd d` and dab show "l dvd 1" by (auto intro: gcd_greatest)
+qed
+
+lemma coprime_rmult:
+  assumes dab: "gcd d (a * b) = 1"
+  shows "gcd d b = 1"
+proof (rule coprimeI)
+  fix l assume "l dvd d" and "l dvd b"
+  hence "l dvd a * b" by simp
+  with `l dvd d` and dab show "l dvd 1" by (auto intro: gcd_greatest)
+qed
+
+lemma coprime_mul_eq: "gcd d (a * b) = 1 \<longleftrightarrow> gcd d a = 1 \<and> gcd d b = 1"
+  using coprime_rmult[of d a b] coprime_lmult[of d a b] coprime_mult[of d a b] by blast
+
+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 "gcd a' b' = 1"
+proof -
+  from z have "a \<noteq> 0 \<or> b \<noteq> 0" by (simp add: gcd_zero)
+  with div_gcd_coprime have "gcd (a div gcd a b) (b div gcd a b) = 1" .
+  also from assms have "a div gcd a b = a'" by (metis div_mult_self2_is_id)+
+  also from assms have "b div gcd a b = b'" by (metis div_mult_self2_is_id)+
+  finally show ?thesis .
+qed
+
+lemma coprime_power:
+  assumes "0 < n"
+  shows "gcd a (b ^ n) = 1 \<longleftrightarrow> gcd a b = 1"
+using assms proof (induct n)
+  case (Suc n) then show ?case
+    by (cases n) (simp_all add: coprime_mul_eq)
+qed simp
+
+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> gcd a' b' = 1"
+  apply (rule_tac x = "a div gcd a b" in exI)
+  apply (rule_tac x = "b div gcd a b" in exI)
+  apply (insert nz, auto simp add: dvd_div_mult gcd_0_left  gcd_zero intro: div_gcd_coprime)
+  done
+
+lemma coprime_exp:
+  "gcd d a = 1 \<Longrightarrow> gcd d (a^n) = 1"
+  by (induct n, simp_all add: coprime_mult)
+
+lemma coprime_exp2 [intro]:
+  "gcd a b = 1 \<Longrightarrow> gcd (a^n) (b^m) = 1"
+  apply (rule coprime_exp)
+  apply (subst gcd.commute)
+  apply (rule coprime_exp)
+  apply (subst gcd.commute)
+  apply assumption
+  done
+
+lemma gcd_exp:
+  "gcd (a^n) (b^n) = (gcd a b) ^ n"
+proof (cases "a = 0 \<and> b = 0")
+  assume "a = 0 \<and> b = 0"
+  then show ?thesis by (cases n, simp_all add: gcd_0_left)
+next
+  assume A: "\<not>(a = 0 \<and> b = 0)"
+  hence "1 = gcd ((a div gcd a b)^n) ((b div gcd a b)^n)"
+    using div_gcd_coprime by (subst sym, auto simp: div_gcd_coprime)
+  hence "(gcd a b) ^ n = (gcd a b) ^ n * ..." by simp
+  also note gcd_mult_distrib
+  also have "normalisation_factor ((gcd a b)^n) = 1"
+    by (simp add: normalisation_factor_pow A)
+  also have "(gcd a b)^n * (a div gcd a b)^n = a^n"
+    by (subst ac_simps, subst div_power, simp, rule dvd_div_mult_self, rule dvd_power_same, simp)
+  also have "(gcd a b)^n * (b div gcd a b)^n = b^n"
+    by (subst ac_simps, subst div_power, simp, rule dvd_div_mult_self, rule dvd_power_same, simp)
+  finally show ?thesis by simp
+qed
+
+lemma coprime_common_divisor: 
+  "gcd a b = 1 \<Longrightarrow> x dvd a \<Longrightarrow> x dvd b \<Longrightarrow> is_unit x"
+  apply (subgoal_tac "x dvd gcd a b")
+  apply (simp add: is_unit_def)
+  apply (erule (1) gcd_greatest)
+  done
+
+lemma division_decomp: 
+  assumes dc: "a dvd b * c"
+  shows "\<exists>b' c'. a = b' * c' \<and> b' dvd b \<and> c' dvd c"
+proof (cases "gcd a b = 0")
+  assume "gcd a b = 0"
+  hence "a = 0 \<and> b = 0" by (simp add: gcd_zero)
+  hence "a = 0 * c \<and> 0 dvd b \<and> c dvd c" by simp
+  then show ?thesis by blast
+next
+  let ?d = "gcd a b"
+  assume "?d \<noteq> 0"
+  from gcd_coprime_exists[OF this]
+    obtain a' b' where ab': "a = a' * ?d" "b = b' * ?d" "gcd a' b' = 1"
+    by blast
+  from ab'(1) have "a' dvd a" unfolding dvd_def by blast
+  with dc have "a' dvd b*c" using dvd_trans[of a' a "b*c"] by simp
+  from dc ab'(1,2) have "a'*?d dvd (b'*?d) * c" by simp
+  hence "?d * a' dvd ?d * (b' * c)" by (simp add: mult_ac)
+  with `?d \<noteq> 0` have "a' dvd b' * c" by (rule dvd_mult_cancel_left)
+  with coprime_dvd_mult[OF ab'(3)] 
+    have "a' dvd c" by (subst (asm) ac_simps, blast)
+  with ab'(1) have "a = ?d * a' \<and> ?d dvd b \<and> a' dvd c" by (simp add: mult_ac)
+  then show ?thesis by blast
+qed
+
+lemma pow_divides_pow:
+  assumes ab: "a ^ n dvd b ^ n" and n: "n \<noteq> 0"
+  shows "a dvd b"
+proof (cases "gcd a b = 0")
+  assume "gcd a b = 0"
+  then show ?thesis by (simp add: gcd_zero)
+next
+  let ?d = "gcd a b"
+  assume "?d \<noteq> 0"
+  from n obtain m where m: "n = Suc m" by (cases n, simp_all)
+  from `?d \<noteq> 0` have zn: "?d ^ n \<noteq> 0" by (rule nonzero_pow_nonzero)
+  from gcd_coprime_exists[OF `?d \<noteq> 0`]
+    obtain a' b' where ab': "a = a' * ?d" "b = b' * ?d" "gcd a' b' = 1"
+    by blast
+  from ab have "(a' * ?d) ^ n dvd (b' * ?d) ^ n"
+    by (simp add: ab'(1,2)[symmetric])
+  hence "?d^n * a'^n dvd ?d^n * b'^n"
+    by (simp only: power_mult_distrib ac_simps)
+  with zn have "a'^n dvd b'^n" by (rule dvd_mult_cancel_left)
+  hence "a' dvd b'^n" using dvd_trans[of a' "a'^n" "b'^n"] by (simp add: m)
+  hence "a' dvd b'^m * b'" by (simp add: m ac_simps)
+  with coprime_dvd_mult[OF coprime_exp[OF ab'(3), of m]]
+    have "a' dvd b'" by (subst (asm) ac_simps, blast)
+  hence "a'*?d dvd b'*?d" by (rule mult_dvd_mono, simp)
+  with ab'(1,2) show ?thesis by simp
+qed
+
+lemma pow_divides_eq [simp]:
+  "n \<noteq> 0 \<Longrightarrow> a ^ n dvd b ^ n \<longleftrightarrow> a dvd b"
+  by (auto intro: pow_divides_pow dvd_power_same)
+
+lemma divides_mult:
+  assumes mr: "m dvd r" and nr: "n dvd r" and mn: "gcd m n = 1"
+  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: ac_simps)
+  hence "m dvd n'" using coprime_dvd_mult_iff[OF mn] by simp
+  then obtain k where k: "n' = m*k" unfolding dvd_def by blast
+  with n' have "r = m * n * k" by (simp add: mult_ac)
+  then show ?thesis unfolding dvd_def by blast
+qed
+
+lemma coprime_plus_one [simp]: "gcd (n + 1) n = 1"
+  by (subst add_commute, simp)
+
+lemma setprod_coprime [rule_format]:
+  "(\<forall>i\<in>A. gcd (f i) x = 1) \<longrightarrow> gcd (\<Prod>i\<in>A. f i) x = 1"
+  apply (cases "finite A")
+  apply (induct set: finite)
+  apply (auto simp add: gcd_mult_cancel)
+  done
+
+lemma coprime_divisors: 
+  assumes "d dvd a" "e dvd b" "gcd a b = 1"
+  shows "gcd d e = 1" 
+proof -
+  from assms obtain k l where "a = d * k" "b = e * l"
+    unfolding dvd_def by blast
+  with assms have "gcd (d * k) (e * l) = 1" by simp
+  hence "gcd (d * k) e = 1" by (rule coprime_lmult)
+  also have "gcd (d * k) e = gcd e (d * k)" by (simp add: ac_simps)
+  finally have "gcd e d = 1" by (rule coprime_lmult)
+  then show ?thesis by (simp add: ac_simps)
+qed
+
+lemma invertible_coprime:
+  "x * y mod m = 1 \<Longrightarrow> gcd x m = 1"
+  by (metis coprime_lmult gcd_1 ac_simps gcd_red)
+
+lemma lcm_gcd:
+  "lcm a b = a * b div (gcd a b * normalisation_factor (a*b))"
+  by (simp only: lcm_lcm_eucl gcd_gcd_eucl lcm_eucl_def)
+
+lemma lcm_gcd_prod:
+  "lcm a b * gcd a b = a * b div normalisation_factor (a*b)"
+proof (cases "a * b = 0")
+  let ?nf = normalisation_factor
+  assume "a * b \<noteq> 0"
+  hence "gcd a b \<noteq> 0" by (auto simp add: gcd_zero)
+  from lcm_gcd have "lcm a b * gcd a b = gcd a b * (a * b div (?nf (a*b) * gcd a b))" 
+    by (simp add: mult_ac)
+  also from `a * b \<noteq> 0` have "... = a * b div ?nf (a*b)" 
+    by (simp_all add: unit_ring_inv'1 dvd_mult_div_cancel unit_ring_inv)
+  finally show ?thesis .
+qed (simp add: lcm_gcd)
+
+lemma lcm_dvd1 [iff]:
+  "x dvd lcm x y"
+proof (cases "x*y = 0")
+  assume "x * y \<noteq> 0"
+  hence "gcd x y \<noteq> 0" by (auto simp: gcd_zero)
+  let ?c = "ring_inv (normalisation_factor (x*y))"
+  from `x * y \<noteq> 0` have [simp]: "is_unit (normalisation_factor (x*y))" by simp
+  from lcm_gcd_prod[of x y] have "lcm x y * gcd x y = x * ?c * y"
+    by (simp add: mult_ac unit_ring_inv)
+  hence "lcm x y * gcd x y div gcd x y = x * ?c * y div gcd x y" by simp
+  with `gcd x y \<noteq> 0` have "lcm x y = x * ?c * y div gcd x y"
+    by (subst (asm) div_mult_self2_is_id, simp_all)
+  also have "... = x * (?c * y div gcd x y)"
+    by (metis div_mult_swap gcd_dvd2 mult_assoc)
+  finally show ?thesis by (rule dvdI)
+qed (simp add: lcm_gcd)
+
+lemma lcm_least:
+  "\<lbrakk>a dvd k; b dvd k\<rbrakk> \<Longrightarrow> lcm a b dvd k"
+proof (cases "k = 0")
+  let ?nf = normalisation_factor
+  assume "k \<noteq> 0"
+  hence "is_unit (?nf k)" by simp
+  hence "?nf k \<noteq> 0" by (metis not_is_unit_0)
+  assume A: "a dvd k" "b dvd k"
+  hence "gcd a b \<noteq> 0" using `k \<noteq> 0` by (auto simp add: gcd_zero)
+  from A obtain r s where ar: "k = a * r" and bs: "k = b * s" 
+    unfolding dvd_def by blast
+  with `k \<noteq> 0` have "r * s \<noteq> 0" 
+    by (intro notI) (drule divisors_zero, elim disjE, simp_all)
+  hence "is_unit (?nf (r * s))" by simp
+  let ?c = "?nf k div ?nf (r*s)"
+  from `is_unit (?nf k)` and `is_unit (?nf (r * s))` have "is_unit ?c" by (rule unit_div)
+  hence "?c \<noteq> 0" using not_is_unit_0 by fast 
+  from ar bs have "k * k * gcd s r = ?nf k * k * gcd (k * s) (k * r)"
+    by (subst mult_assoc, subst gcd_mult_distrib[of k s r], simp only: ac_simps mult_assoc)
+  also have "... = ?nf k * k * gcd ((r*s) * a) ((r*s) * b)"
+    by (subst (3) `k = a * r`, subst (3) `k = b * s`, simp add: algebra_simps)
+  also have "... = ?c * r*s * k * gcd a b" using `r * s \<noteq> 0`
+    by (subst gcd_mult_distrib'[symmetric], simp add: algebra_simps unit_simps)
+  finally have "(a*r) * (b*s) * gcd s r = ?c * k * r * s * gcd a b"
+    by (subst ar[symmetric], subst bs[symmetric], simp add: mult_ac)
+  hence "a * b * gcd s r * (r * s) = ?c * k * gcd a b * (r * s)"
+    by (simp add: algebra_simps)
+  hence "?c * k * gcd a b = a * b * gcd s r" using `r * s \<noteq> 0`
+    by (metis div_mult_self2_is_id)
+  also have "... = lcm a b * gcd a b * gcd s r * ?nf (a*b)"
+    by (subst lcm_gcd_prod[of a b], metis gcd_mult_distrib gcd_mult_distrib') 
+  also have "... = lcm a b * gcd s r * ?nf (a*b) * gcd a b"
+    by (simp add: algebra_simps)
+  finally have "k * ?c = lcm a b * gcd s r * ?nf (a*b)" using `gcd a b \<noteq> 0`
+    by (metis mult.commute div_mult_self2_is_id)
+  hence "k = lcm a b * (gcd s r * ?nf (a*b)) div ?c" using `?c \<noteq> 0`
+    by (metis div_mult_self2_is_id mult_assoc) 
+  also have "... = lcm a b * (gcd s r * ?nf (a*b) div ?c)" using `is_unit ?c`
+    by (simp add: unit_simps)
+  finally show ?thesis by (rule dvdI)
+qed simp
+
+lemma lcm_zero:
+  "lcm a b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
+proof -
+  let ?nf = normalisation_factor
+  {
+    assume "a \<noteq> 0" "b \<noteq> 0"
+    hence "a * b div ?nf (a * b) \<noteq> 0" by (simp add: no_zero_divisors)
+    moreover from `a \<noteq> 0` and `b \<noteq> 0` have "gcd a b \<noteq> 0" by (simp add: gcd_zero)
+    ultimately have "lcm a b \<noteq> 0" using lcm_gcd_prod[of a b] by (intro notI, simp)
+  } moreover {
+    assume "a = 0 \<or> b = 0"
+    hence "lcm a b = 0" by (elim disjE, simp_all add: lcm_gcd)
+  }
+  ultimately show ?thesis by blast
+qed
+
+lemmas lcm_0_iff = lcm_zero
+
+lemma gcd_lcm: 
+  assumes "lcm a b \<noteq> 0"
+  shows "gcd a b = a * b div (lcm a b * normalisation_factor (a * b))"
+proof-
+  from assms have "gcd a b \<noteq> 0" by (simp add: gcd_zero lcm_zero)
+  let ?c = "normalisation_factor (a*b)"
+  from `lcm a b \<noteq> 0` have "?c \<noteq> 0" by (intro notI, simp add: lcm_zero no_zero_divisors)
+  hence "is_unit ?c" by simp
+  from lcm_gcd_prod [of a b] have "gcd a b = a * b div ?c div lcm a b"
+    by (subst (2) div_mult_self2_is_id[OF `lcm a b \<noteq> 0`, symmetric], simp add: mult_ac)
+  also from `is_unit ?c` have "... = a * b div (?c * lcm a b)"
+    by (simp only: unit_ring_inv'1 unit_ring_inv)
+  finally show ?thesis by (simp only: ac_simps)
+qed
+
+lemma normalisation_factor_lcm [simp]:
+  "normalisation_factor (lcm a b) = (if a = 0 \<or> b = 0 then 0 else 1)"
+proof (cases "a = 0 \<or> b = 0")
+  case True then show ?thesis
+    by (simp add: lcm_gcd) (metis div_0 ac_simps mult_zero_left normalisation_factor_0)
+next
+  case False
+  let ?nf = normalisation_factor
+  from lcm_gcd_prod[of a b] 
+    have "?nf (lcm a b) * ?nf (gcd a b) = ?nf (a*b) div ?nf (a*b)"
+    by (metis div_by_0 div_self normalisation_correct normalisation_factor_0 normalisation_factor_mult)
+  also have "... = (if a*b = 0 then 0 else 1)"
+    by (cases "a*b = 0", simp, subst div_self, metis dvd_0_left normalisation_factor_dvd, simp)
+  finally show ?thesis using False by (simp add: no_zero_divisors)
+qed
+
+lemma lcm_dvd2 [iff]: "y dvd lcm x y"
+  using lcm_dvd1 [of y x] by (simp add: lcm_gcd ac_simps)
+
+lemma lcmI:
+  "\<lbrakk>x dvd k; y dvd k; \<And>l. x dvd l \<Longrightarrow> y dvd l \<Longrightarrow> k dvd l;
+    normalisation_factor k = (if k = 0 then 0 else 1)\<rbrakk> \<Longrightarrow> k = lcm x y"
+  by (intro normed_associated_imp_eq) (auto simp: associated_def intro: lcm_least)
+
+sublocale lcm!: abel_semigroup lcm
+proof
+  fix x y z
+  show "lcm (lcm x y) z = lcm x (lcm y z)"
+  proof (rule lcmI)
+    have "x dvd lcm x y" and "lcm x y dvd lcm (lcm x y) z" by simp_all
+    then show "x dvd lcm (lcm x y) z" by (rule dvd_trans)
+    
+    have "y dvd lcm x y" and "lcm x y dvd lcm (lcm x y) z" by simp_all
+    hence "y dvd lcm (lcm x y) z" by (rule dvd_trans)
+    moreover have "z dvd lcm (lcm x y) z" by simp
+    ultimately show "lcm y z dvd lcm (lcm x y) z" by (rule lcm_least)
+
+    fix l assume "x dvd l" and "lcm y z dvd l"
+    have "y dvd lcm y z" by simp
+    from this and `lcm y z dvd l` have "y dvd l" by (rule dvd_trans)
+    have "z dvd lcm y z" by simp
+    from this and `lcm y z dvd l` have "z dvd l" by (rule dvd_trans)
+    from `x dvd l` and `y dvd l` have "lcm x y dvd l" by (rule lcm_least)
+    from this and `z dvd l` show "lcm (lcm x y) z dvd l" by (rule lcm_least)
+  qed (simp add: lcm_zero)
+next
+  fix x y
+  show "lcm x y = lcm y x"
+    by (simp add: lcm_gcd ac_simps)
+qed
+
+lemma dvd_lcm_D1:
+  "lcm m n dvd k \<Longrightarrow> m dvd k"
+  by (rule dvd_trans, rule lcm_dvd1, assumption)
+
+lemma dvd_lcm_D2:
+  "lcm m n dvd k \<Longrightarrow> n dvd k"
+  by (rule dvd_trans, rule lcm_dvd2, assumption)
+
+lemma gcd_dvd_lcm [simp]:
+  "gcd a b dvd lcm a b"
+  by (metis dvd_trans gcd_dvd2 lcm_dvd2)
+
+lemma lcm_1_iff:
+  "lcm a b = 1 \<longleftrightarrow> is_unit a \<and> is_unit b"
+proof
+  assume "lcm a b = 1"
+  then show "is_unit a \<and> is_unit b" unfolding is_unit_def by auto
+next
+  assume "is_unit a \<and> is_unit b"
+  hence "a dvd 1" and "b dvd 1" unfolding is_unit_def by simp_all
+  hence "is_unit (lcm a b)" unfolding is_unit_def by (rule lcm_least)
+  hence "lcm a b = normalisation_factor (lcm a b)"
+    by (subst normalisation_factor_unit, simp_all)
+  also have "\<dots> = 1" using `is_unit a \<and> is_unit b` by (auto simp add: is_unit_def)
+  finally show "lcm a b = 1" .
+qed
+
+lemma lcm_0_left [simp]:
+  "lcm 0 x = 0"
+  by (rule sym, rule lcmI, simp_all)
+
+lemma lcm_0 [simp]:
+  "lcm x 0 = 0"
+  by (rule sym, rule lcmI, simp_all)
+
+lemma lcm_unique:
+  "a dvd d \<and> b dvd d \<and> 
+  normalisation_factor d = (if d = 0 then 0 else 1) \<and>
+  (\<forall>e. a dvd e \<and> b dvd e \<longrightarrow> d dvd e) \<longleftrightarrow> d = lcm a b"
+  by (rule, auto intro: lcmI simp: lcm_least lcm_zero)
+
+lemma dvd_lcm_I1 [simp]:
+  "k dvd m \<Longrightarrow> k dvd lcm m n"
+  by (metis lcm_dvd1 dvd_trans)
+
+lemma dvd_lcm_I2 [simp]:
+  "k dvd n \<Longrightarrow> k dvd lcm m n"
+  by (metis lcm_dvd2 dvd_trans)
+
+lemma lcm_1_left [simp]:
+  "lcm 1 x = x div normalisation_factor x"
+  by (cases "x = 0") (simp, rule sym, rule lcmI, simp_all)
+
+lemma lcm_1_right [simp]:
+  "lcm x 1 = x div normalisation_factor x"
+  by (simp add: ac_simps)
+
+lemma lcm_coprime:
+  "gcd a b = 1 \<Longrightarrow> lcm a b = a * b div normalisation_factor (a*b)"
+  by (subst lcm_gcd) simp
+
+lemma lcm_proj1_if_dvd: 
+  "y dvd x \<Longrightarrow> lcm x y = x div normalisation_factor x"
+  by (cases "x = 0") (simp, rule sym, rule lcmI, simp_all)
+
+lemma lcm_proj2_if_dvd: 
+  "x dvd y \<Longrightarrow> lcm x y = y div normalisation_factor y"
+  using lcm_proj1_if_dvd [of x y] by (simp add: ac_simps)
+
+lemma lcm_proj1_iff:
+  "lcm m n = m div normalisation_factor m \<longleftrightarrow> n dvd m"
+proof
+  assume A: "lcm m n = m div normalisation_factor m"
+  show "n dvd m"
+  proof (cases "m = 0")
+    assume [simp]: "m \<noteq> 0"
+    from A have B: "m = lcm m n * normalisation_factor m"
+      by (simp add: unit_eq_div2)
+    show ?thesis by (subst B, simp)
+  qed simp
+next
+  assume "n dvd m"
+  then show "lcm m n = m div normalisation_factor m" by (rule lcm_proj1_if_dvd)
+qed
+
+lemma lcm_proj2_iff:
+  "lcm m n = n div normalisation_factor n \<longleftrightarrow> m dvd n"
+  using lcm_proj1_iff [of n m] by (simp add: ac_simps)
+
+lemma euclidean_size_lcm_le1: 
+  assumes "a \<noteq> 0" and "b \<noteq> 0"
+  shows "euclidean_size a \<le> euclidean_size (lcm a b)"
+proof -
+  have "a dvd lcm a b" by (rule lcm_dvd1)
+  then obtain c where A: "lcm a b = a * c" unfolding dvd_def by blast
+  with `a \<noteq> 0` and `b \<noteq> 0` have "c \<noteq> 0" by (auto simp: lcm_zero)
+  then show ?thesis by (subst A, intro size_mult_mono)
+qed
+
+lemma euclidean_size_lcm_le2:
+  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> euclidean_size b \<le> euclidean_size (lcm a b)"
+  using euclidean_size_lcm_le1 [of b a] by (simp add: ac_simps)
+
+lemma euclidean_size_lcm_less1:
+  assumes "b \<noteq> 0" and "\<not>b dvd a"
+  shows "euclidean_size a < euclidean_size (lcm a b)"
+proof (rule ccontr)
+  from assms have "a \<noteq> 0" by auto
+  assume "\<not>euclidean_size a < euclidean_size (lcm a b)"
+  with `a \<noteq> 0` and `b \<noteq> 0` have "euclidean_size (lcm a b) = euclidean_size a"
+    by (intro le_antisym, simp, intro euclidean_size_lcm_le1)
+  with assms have "lcm a b dvd a" 
+    by (rule_tac dvd_euclidean_size_eq_imp_dvd) (auto simp: lcm_zero)
+  hence "b dvd a" by (rule dvd_lcm_D2)
+  with `\<not>b dvd a` show False by contradiction
+qed
+
+lemma euclidean_size_lcm_less2:
+  assumes "a \<noteq> 0" and "\<not>a dvd b"
+  shows "euclidean_size b < euclidean_size (lcm a b)"
+  using assms euclidean_size_lcm_less1 [of a b] by (simp add: ac_simps)
+
+lemma lcm_mult_unit1:
+  "is_unit a \<Longrightarrow> lcm (x*a) y = lcm x y"
+  apply (rule lcmI)
+  apply (rule dvd_trans[of _ "x*a"], simp, rule lcm_dvd1)
+  apply (rule lcm_dvd2)
+  apply (rule lcm_least, simp add: unit_simps, assumption)
+  apply (subst normalisation_factor_lcm, simp add: lcm_zero)
+  done
+
+lemma lcm_mult_unit2:
+  "is_unit a \<Longrightarrow> lcm x (y*a) = lcm x y"
+  using lcm_mult_unit1 [of a y x] by (simp add: ac_simps)
+
+lemma lcm_div_unit1:
+  "is_unit a \<Longrightarrow> lcm (x div a) y = lcm x y"
+  by (simp add: unit_ring_inv lcm_mult_unit1)
+
+lemma lcm_div_unit2:
+  "is_unit a \<Longrightarrow> lcm x (y div a) = lcm x y"
+  by (simp add: unit_ring_inv lcm_mult_unit2)
+
+lemma lcm_left_idem:
+  "lcm p (lcm p q) = lcm p q"
+  apply (rule lcmI)
+  apply simp
+  apply (subst lcm.assoc [symmetric], rule lcm_dvd2)
+  apply (rule lcm_least, assumption)
+  apply (erule (1) lcm_least)
+  apply (auto simp: lcm_zero)
+  done
+
+lemma lcm_right_idem:
+  "lcm (lcm p q) q = lcm p q"
+  apply (rule lcmI)
+  apply (subst lcm.assoc, rule lcm_dvd1)
+  apply (rule lcm_dvd2)
+  apply (rule lcm_least, erule (1) lcm_least, assumption)
+  apply (auto simp: lcm_zero)
+  done
+
+lemma comp_fun_idem_lcm: "comp_fun_idem lcm"
+proof
+  fix a b show "lcm a \<circ> lcm b = lcm b \<circ> lcm a"
+    by (simp add: fun_eq_iff ac_simps)
+next
+  fix a show "lcm a \<circ> lcm a = lcm a" unfolding o_def
+    by (intro ext, simp add: lcm_left_idem)
+qed
+
+lemma dvd_Lcm [simp]: "x \<in> A \<Longrightarrow> x dvd Lcm A"
+  and Lcm_dvd [simp]: "(\<forall>x\<in>A. x dvd l') \<Longrightarrow> Lcm A dvd l'"
+  and normalisation_factor_Lcm [simp]: 
+          "normalisation_factor (Lcm A) = (if Lcm A = 0 then 0 else 1)"
+proof -
+  have "(\<forall>x\<in>A. x dvd Lcm A) \<and> (\<forall>l'. (\<forall>x\<in>A. x dvd l') \<longrightarrow> Lcm A dvd l') \<and>
+    normalisation_factor (Lcm A) = (if Lcm A = 0 then 0 else 1)" (is ?thesis)
+  proof (cases "\<exists>l. l \<noteq>  0 \<and> (\<forall>x\<in>A. x dvd l)")
+    case False
+    hence "Lcm A = 0" by (auto simp: Lcm_Lcm_eucl Lcm_eucl_def)
+    with False show ?thesis by auto
+  next
+    case True
+    then obtain l\<^sub>0 where l\<^sub>0_props: "l\<^sub>0 \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l\<^sub>0)" by blast
+    def n \<equiv> "LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+    def l \<equiv> "SOME l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+    have "\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+      apply (subst n_def)
+      apply (rule LeastI[of _ "euclidean_size l\<^sub>0"])
+      apply (rule exI[of _ l\<^sub>0])
+      apply (simp add: l\<^sub>0_props)
+      done
+    from someI_ex[OF this] have "l \<noteq> 0" and "\<forall>x\<in>A. x dvd l" and "euclidean_size l = n" 
+      unfolding l_def by simp_all
+    {
+      fix l' assume "\<forall>x\<in>A. x dvd l'"
+      with `\<forall>x\<in>A. x dvd l` have "\<forall>x\<in>A. x dvd gcd l l'" by (auto intro: gcd_greatest)
+      moreover from `l \<noteq> 0` have "gcd l l' \<noteq> 0" by (simp add: gcd_zero)
+      ultimately have "\<exists>b. b \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd b) \<and> euclidean_size b = euclidean_size (gcd l l')"
+        by (intro exI[of _ "gcd l l'"], auto)
+      hence "euclidean_size (gcd l l') \<ge> n" by (subst n_def) (rule Least_le)
+      moreover have "euclidean_size (gcd l l') \<le> n"
+      proof -
+        have "gcd l l' dvd l" by simp
+        then obtain a where "l = gcd l l' * a" unfolding dvd_def by blast
+        with `l \<noteq> 0` have "a \<noteq> 0" by auto
+        hence "euclidean_size (gcd l l') \<le> euclidean_size (gcd l l' * a)"
+          by (rule size_mult_mono)
+        also have "gcd l l' * a = l" using `l = gcd l l' * a` ..
+        also note `euclidean_size l = n`
+        finally show "euclidean_size (gcd l l') \<le> n" .
+      qed
+      ultimately have "euclidean_size l = euclidean_size (gcd l l')" 
+        by (intro le_antisym, simp_all add: `euclidean_size l = n`)
+      with `l \<noteq> 0` have "l dvd gcd l l'" by (blast intro: dvd_euclidean_size_eq_imp_dvd)
+      hence "l dvd l'" by (blast dest: dvd_gcd_D2)
+    }
+
+    with `(\<forall>x\<in>A. x dvd l)` and normalisation_factor_is_unit[OF `l \<noteq> 0`] and `l \<noteq> 0`
+      have "(\<forall>x\<in>A. x dvd l div normalisation_factor l) \<and> 
+        (\<forall>l'. (\<forall>x\<in>A. x dvd l') \<longrightarrow> l div normalisation_factor l dvd l') \<and>
+        normalisation_factor (l div normalisation_factor l) = 
+        (if l div normalisation_factor l = 0 then 0 else 1)"
+      by (auto simp: unit_simps)
+    also from True have "l div normalisation_factor l = Lcm A"
+      by (simp add: Lcm_Lcm_eucl Lcm_eucl_def Let_def n_def l_def)
+    finally show ?thesis .
+  qed
+  note A = this
+
+  {fix x assume "x \<in> A" then show "x dvd Lcm A" using A by blast}
+  {fix l' assume "\<forall>x\<in>A. x dvd l'" then show "Lcm A dvd l'" using A by blast}
+  from A show "normalisation_factor (Lcm A) = (if Lcm A = 0 then 0 else 1)" by blast
+qed
+    
+lemma LcmI:
+  "(\<And>x. x\<in>A \<Longrightarrow> x dvd l) \<Longrightarrow> (\<And>l'. (\<forall>x\<in>A. x dvd l') \<Longrightarrow> l dvd l') \<Longrightarrow>
+      normalisation_factor l = (if l = 0 then 0 else 1) \<Longrightarrow> l = Lcm A"
+  by (intro normed_associated_imp_eq)
+    (auto intro: Lcm_dvd dvd_Lcm simp: associated_def)
+
+lemma Lcm_subset:
+  "A \<subseteq> B \<Longrightarrow> Lcm A dvd Lcm B"
+  by (blast intro: Lcm_dvd dvd_Lcm)
+
+lemma Lcm_Un:
+  "Lcm (A \<union> B) = lcm (Lcm A) (Lcm B)"
+  apply (rule lcmI)
+  apply (blast intro: Lcm_subset)
+  apply (blast intro: Lcm_subset)
+  apply (intro Lcm_dvd ballI, elim UnE)
+  apply (rule dvd_trans, erule dvd_Lcm, assumption)
+  apply (rule dvd_trans, erule dvd_Lcm, assumption)
+  apply simp
+  done
+
+lemma Lcm_1_iff:
+  "Lcm A = 1 \<longleftrightarrow> (\<forall>x\<in>A. is_unit x)"
+proof
+  assume "Lcm A = 1"
+  then show "\<forall>x\<in>A. is_unit x" unfolding is_unit_def by auto
+qed (rule LcmI [symmetric], auto)
+
+lemma Lcm_no_units:
+  "Lcm A = Lcm (A - {x. is_unit x})"
+proof -
+  have "(A - {x. is_unit x}) \<union> {x\<in>A. is_unit x} = A" by blast
+  hence "Lcm A = lcm (Lcm (A - {x. is_unit x})) (Lcm {x\<in>A. is_unit x})"
+    by (simp add: Lcm_Un[symmetric])
+  also have "Lcm {x\<in>A. is_unit x} = 1" by (simp add: Lcm_1_iff)
+  finally show ?thesis by simp
+qed
+
+lemma Lcm_empty [simp]:
+  "Lcm {} = 1"
+  by (simp add: Lcm_1_iff)
+
+lemma Lcm_eq_0 [simp]:
+  "0 \<in> A \<Longrightarrow> Lcm A = 0"
+  by (drule dvd_Lcm) simp
+
+lemma Lcm0_iff':
+  "Lcm A = 0 \<longleftrightarrow> \<not>(\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l))"
+proof
+  assume "Lcm A = 0"
+  show "\<not>(\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l))"
+  proof
+    assume ex: "\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l)"
+    then obtain l\<^sub>0 where l\<^sub>0_props: "l\<^sub>0 \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l\<^sub>0)" by blast
+    def n \<equiv> "LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+    def l \<equiv> "SOME l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+    have "\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l) \<and> euclidean_size l = n"
+      apply (subst n_def)
+      apply (rule LeastI[of _ "euclidean_size l\<^sub>0"])
+      apply (rule exI[of _ l\<^sub>0])
+      apply (simp add: l\<^sub>0_props)
+      done
+    from someI_ex[OF this] have "l \<noteq> 0" unfolding l_def by simp_all
+    hence "l div normalisation_factor l \<noteq> 0" by simp
+    also from ex have "l div normalisation_factor l = Lcm A"
+       by (simp only: Lcm_Lcm_eucl Lcm_eucl_def n_def l_def if_True Let_def)
+    finally show False using `Lcm A = 0` by contradiction
+  qed
+qed (simp only: Lcm_Lcm_eucl Lcm_eucl_def if_False)
+
+lemma Lcm0_iff [simp]:
+  "finite A \<Longrightarrow> Lcm A = 0 \<longleftrightarrow> 0 \<in> A"
+proof -
+  assume "finite A"
+  have "0 \<in> A \<Longrightarrow> Lcm A = 0"  by (intro dvd_0_left dvd_Lcm)
+  moreover {
+    assume "0 \<notin> A"
+    hence "\<Prod>A \<noteq> 0" 
+      apply (induct rule: finite_induct[OF `finite A`]) 
+      apply simp
+      apply (subst setprod.insert, assumption, assumption)
+      apply (rule no_zero_divisors)
+      apply blast+
+      done
+    moreover from `finite A` have "\<forall>x\<in>A. x dvd \<Prod>A" by (intro ballI dvd_setprod)
+    ultimately have "\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l)" by blast
+    with Lcm0_iff' have "Lcm A \<noteq> 0" by simp
+  }
+  ultimately show "Lcm A = 0 \<longleftrightarrow> 0 \<in> A" by blast
+qed
+
+lemma Lcm_no_multiple:
+  "(\<forall>m. m \<noteq> 0 \<longrightarrow> (\<exists>x\<in>A. \<not>x dvd m)) \<Longrightarrow> Lcm A = 0"
+proof -
+  assume "\<forall>m. m \<noteq> 0 \<longrightarrow> (\<exists>x\<in>A. \<not>x dvd m)"
+  hence "\<not>(\<exists>l. l \<noteq> 0 \<and> (\<forall>x\<in>A. x dvd l))" by blast
+  then show "Lcm A = 0" by (simp only: Lcm_Lcm_eucl Lcm_eucl_def if_False)
+qed
+
+lemma Lcm_insert [simp]:
+  "Lcm (insert a A) = lcm a (Lcm A)"
+proof (rule lcmI)
+  fix l assume "a dvd l" and "Lcm A dvd l"
+  hence "\<forall>x\<in>A. x dvd l" by (blast intro: dvd_trans dvd_Lcm)
+  with `a dvd l` show "Lcm (insert a A) dvd l" by (force intro: Lcm_dvd)
+qed (auto intro: Lcm_dvd dvd_Lcm)
+ 
+lemma Lcm_finite:
+  assumes "finite A"
+  shows "Lcm A = Finite_Set.fold lcm 1 A"
+  by (induct rule: finite.induct[OF `finite A`])
+    (simp_all add: comp_fun_idem.fold_insert_idem[OF comp_fun_idem_lcm])
+
+lemma Lcm_set [code, code_unfold]:
+  "Lcm (set xs) = fold lcm xs 1"
+  using comp_fun_idem.fold_set_fold[OF comp_fun_idem_lcm] Lcm_finite by (simp add: ac_simps)
+
+lemma Lcm_singleton [simp]:
+  "Lcm {a} = a div normalisation_factor a"
+  by simp
+
+lemma Lcm_2 [simp]:
+  "Lcm {a,b} = lcm a b"
+  by (simp only: Lcm_insert Lcm_empty lcm_1_right)
+    (cases "b = 0", simp, rule lcm_div_unit2, simp)
+
+lemma Lcm_coprime:
+  assumes "finite A" and "A \<noteq> {}" 
+  assumes "\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> gcd a b = 1"
+  shows "Lcm A = \<Prod>A div normalisation_factor (\<Prod>A)"
+using assms proof (induct rule: finite_ne_induct)
+  case (insert a A)
+  have "Lcm (insert a A) = lcm a (Lcm A)" by simp
+  also from insert have "Lcm A = \<Prod>A div normalisation_factor (\<Prod>A)" by blast
+  also have "lcm a \<dots> = lcm a (\<Prod>A)" by (cases "\<Prod>A = 0") (simp_all add: lcm_div_unit2)
+  also from insert have "gcd a (\<Prod>A) = 1" by (subst gcd.commute, intro setprod_coprime) auto
+  with insert have "lcm a (\<Prod>A) = \<Prod>(insert a A) div normalisation_factor (\<Prod>(insert a A))"
+    by (simp add: lcm_coprime)
+  finally show ?case .
+qed simp
+      
+lemma Lcm_coprime':
+  "card A \<noteq> 0 \<Longrightarrow> (\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> gcd a b = 1)
+    \<Longrightarrow> Lcm A = \<Prod>A div normalisation_factor (\<Prod>A)"
+  by (rule Lcm_coprime) (simp_all add: card_eq_0_iff)
+
+lemma Gcd_Lcm:
+  "Gcd A = Lcm {d. \<forall>x\<in>A. d dvd x}"
+  by (simp add: Gcd_Gcd_eucl Lcm_Lcm_eucl Gcd_eucl_def)
+
+lemma Gcd_dvd [simp]: "x \<in> A \<Longrightarrow> Gcd A dvd x"
+  and dvd_Gcd [simp]: "(\<forall>x\<in>A. g' dvd x) \<Longrightarrow> g' dvd Gcd A"
+  and normalisation_factor_Gcd [simp]: 
+    "normalisation_factor (Gcd A) = (if Gcd A = 0 then 0 else 1)"
+proof -
+  fix x assume "x \<in> A"
+  hence "Lcm {d. \<forall>x\<in>A. d dvd x} dvd x" by (intro Lcm_dvd) blast
+  then show "Gcd A dvd x" by (simp add: Gcd_Lcm)
+next
+  fix g' assume "\<forall>x\<in>A. g' dvd x"
+  hence "g' dvd Lcm {d. \<forall>x\<in>A. d dvd x}" by (intro dvd_Lcm) blast
+  then show "g' dvd Gcd A" by (simp add: Gcd_Lcm)
+next
+  show "normalisation_factor (Gcd A) = (if Gcd A = 0 then 0 else 1)"
+    by (simp add: Gcd_Lcm normalisation_factor_Lcm)
+qed
+
+lemma GcdI:
+  "(\<And>x. x\<in>A \<Longrightarrow> l dvd x) \<Longrightarrow> (\<And>l'. (\<forall>x\<in>A. l' dvd x) \<Longrightarrow> l' dvd l) \<Longrightarrow>
+    normalisation_factor l = (if l = 0 then 0 else 1) \<Longrightarrow> l = Gcd A"
+  by (intro normed_associated_imp_eq)
+    (auto intro: Gcd_dvd dvd_Gcd simp: associated_def)
+
+lemma Lcm_Gcd:
+  "Lcm A = Gcd {m. \<forall>x\<in>A. x dvd m}"
+  by (rule LcmI[symmetric]) (auto intro: dvd_Gcd Gcd_dvd)
+
+lemma Gcd_0_iff:
+  "Gcd A = 0 \<longleftrightarrow> A \<subseteq> {0}"
+  apply (rule iffI)
+  apply (rule subsetI, drule Gcd_dvd, simp)
+  apply (auto intro: GcdI[symmetric])
+  done
+
+lemma Gcd_empty [simp]:
+  "Gcd {} = 0"
+  by (simp add: Gcd_0_iff)
+
+lemma Gcd_1:
+  "1 \<in> A \<Longrightarrow> Gcd A = 1"
+  by (intro GcdI[symmetric]) (auto intro: Gcd_dvd dvd_Gcd)
+
+lemma Gcd_insert [simp]:
+  "Gcd (insert a A) = gcd a (Gcd A)"
+proof (rule gcdI)
+  fix l assume "l dvd a" and "l dvd Gcd A"
+  hence "\<forall>x\<in>A. l dvd x" by (blast intro: dvd_trans Gcd_dvd)
+  with `l dvd a` show "l dvd Gcd (insert a A)" by (force intro: Gcd_dvd)
+qed (auto intro: Gcd_dvd dvd_Gcd simp: normalisation_factor_Gcd)
+
+lemma Gcd_finite:
+  assumes "finite A"
+  shows "Gcd A = Finite_Set.fold gcd 0 A"
+  by (induct rule: finite.induct[OF `finite A`])
+    (simp_all add: comp_fun_idem.fold_insert_idem[OF comp_fun_idem_gcd])
+
+lemma Gcd_set [code, code_unfold]:
+  "Gcd (set xs) = fold gcd xs 0"
+  using comp_fun_idem.fold_set_fold[OF comp_fun_idem_gcd] Gcd_finite by (simp add: ac_simps)
+
+lemma Gcd_singleton [simp]: "Gcd {a} = a div normalisation_factor a"
+  by (simp add: gcd_0)
+
+lemma Gcd_2 [simp]: "Gcd {a,b} = gcd a b"
+  by (simp only: Gcd_insert Gcd_empty gcd_0) (cases "b = 0", simp, rule gcd_div_unit2, simp)
+
+end
+
+text {*
+  A Euclidean ring is a Euclidean semiring with additive inverses. It provides a 
+  few more lemmas; in particular, Bezout's lemma holds for any Euclidean ring.
+*}
+
+class euclidean_ring = euclidean_semiring + idom
+
+class euclidean_ring_gcd = euclidean_semiring_gcd + idom
+begin
+
+subclass euclidean_ring ..
+
+lemma gcd_neg1 [simp]:
+  "gcd (-x) y = gcd x y"
+  by (rule sym, rule gcdI, simp_all add: gcd_greatest gcd_zero)
+
+lemma gcd_neg2 [simp]:
+  "gcd x (-y) = gcd x y"
+  by (rule sym, rule gcdI, simp_all add: gcd_greatest gcd_zero)
+
+lemma gcd_neg_numeral_1 [simp]:
+  "gcd (- numeral n) x = gcd (numeral n) x"
+  by (fact gcd_neg1)
+
+lemma gcd_neg_numeral_2 [simp]:
+  "gcd x (- numeral n) = gcd x (numeral n)"
+  by (fact gcd_neg2)
+
+lemma gcd_diff1: "gcd (m - n) n = gcd m n"
+  by (subst diff_conv_add_uminus, subst gcd_neg2[symmetric],  subst gcd_add1, simp)
+
+lemma gcd_diff2: "gcd (n - m) n = gcd m n"
+  by (subst gcd_neg1[symmetric], simp only: minus_diff_eq gcd_diff1)
+
+lemma coprime_minus_one [simp]: "gcd (n - 1) n = 1"
+proof -
+  have "gcd (n - 1) n = gcd n (n - 1)" by (fact gcd.commute)
+  also have "\<dots> = gcd ((n - 1) + 1) (n - 1)" by simp
+  also have "\<dots> = 1" by (rule coprime_plus_one)
+  finally show ?thesis .
+qed
+
+lemma lcm_neg1 [simp]: "lcm (-x) y = lcm x y"
+  by (rule sym, rule lcmI, simp_all add: lcm_least lcm_zero)
+
+lemma lcm_neg2 [simp]: "lcm x (-y) = lcm x y"
+  by (rule sym, rule lcmI, simp_all add: lcm_least lcm_zero)
+
+lemma lcm_neg_numeral_1 [simp]: "lcm (- numeral n) x = lcm (numeral n) x"
+  by (fact lcm_neg1)
+
+lemma lcm_neg_numeral_2 [simp]: "lcm x (- numeral n) = lcm x (numeral n)"
+  by (fact lcm_neg2)
+
+function euclid_ext :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a" where
+  "euclid_ext a b = 
+     (if b = 0 then 
+        let x = ring_inv (normalisation_factor a) in (x, 0, a * x)
+      else 
+        case euclid_ext b (a mod b) of
+            (s,t,c) \<Rightarrow> (t, s - t * (a div b), c))"
+  by (pat_completeness, simp)
+  termination by (relation "measure (euclidean_size \<circ> snd)", simp_all)
+
+declare euclid_ext.simps [simp del]
+
+lemma euclid_ext_0: 
+  "euclid_ext a 0 = (ring_inv (normalisation_factor a), 0, a * ring_inv (normalisation_factor a))"
+  by (subst euclid_ext.simps, simp add: Let_def)
+
+lemma euclid_ext_non_0:
+  "b \<noteq> 0 \<Longrightarrow> euclid_ext a b = (case euclid_ext b (a mod b) of 
+    (s,t,c) \<Rightarrow> (t, s - t * (a div b), c))"
+  by (subst euclid_ext.simps, simp)
+
+definition euclid_ext' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a"
+where
+  "euclid_ext' a b = (case euclid_ext a b of (s, t, _) \<Rightarrow> (s, t))"
+
+lemma euclid_ext_gcd [simp]:
+  "(case euclid_ext a b of (_,_,t) \<Rightarrow> t) = gcd a b"
+proof (induct a b rule: euclid_ext.induct)
+  case (1 a b)
+  then show ?case
+  proof (cases "b = 0")
+    case True
+      then show ?thesis by (cases "a = 0") 
+        (simp_all add: euclid_ext_0 unit_div mult_ac unit_simps gcd_0)
+    next
+    case False with 1 show ?thesis
+      by (simp add: euclid_ext_non_0 ac_simps split: prod.split prod.split_asm)
+    qed
+qed
+
+lemma euclid_ext_gcd' [simp]:
+  "euclid_ext a b = (r, s, t) \<Longrightarrow> t = gcd a b"
+  by (insert euclid_ext_gcd[of a b], drule (1) subst, simp)
+
+lemma euclid_ext_correct:
+  "case euclid_ext x y of (s,t,c) \<Rightarrow> s*x + t*y = c"
+proof (induct x y rule: euclid_ext.induct)
+  case (1 x y)
+  show ?case
+  proof (cases "y = 0")
+    case True
+    then show ?thesis by (simp add: euclid_ext_0 mult_ac)
+  next
+    case False
+    obtain s t c where stc: "euclid_ext y (x mod y) = (s,t,c)"
+      by (cases "euclid_ext y (x mod y)", blast)
+    from 1 have "c = s * y + t * (x mod y)" by (simp add: stc False)
+    also have "... = t*((x div y)*y + x mod y) + (s - t * (x div y))*y"
+      by (simp add: algebra_simps) 
+    also have "(x div y)*y + x mod y = x" using mod_div_equality .
+    finally show ?thesis
+      by (subst euclid_ext.simps, simp add: False stc)
+    qed
+qed
+
+lemma euclid_ext'_correct:
+  "fst (euclid_ext' a b) * a + snd (euclid_ext' a b) * b = gcd a b"
+proof-
+  obtain s t c where "euclid_ext a b = (s,t,c)"
+    by (cases "euclid_ext a b", blast)
+  with euclid_ext_correct[of a b] euclid_ext_gcd[of a b]
+    show ?thesis unfolding euclid_ext'_def by simp
+qed
+
+lemma bezout: "\<exists>s t. s * x + t * y = gcd x y"
+  using euclid_ext'_correct by blast
+
+lemma euclid_ext'_0 [simp]: "euclid_ext' x 0 = (ring_inv (normalisation_factor x), 0)" 
+  by (simp add: bezw_def euclid_ext'_def euclid_ext_0)
+
+lemma euclid_ext'_non_0: "y \<noteq> 0 \<Longrightarrow> euclid_ext' x y = (snd (euclid_ext' y (x mod y)),
+  fst (euclid_ext' y (x mod y)) - snd (euclid_ext' y (x mod y)) * (x div y))"
+  by (cases "euclid_ext y (x mod y)") 
+    (simp add: euclid_ext'_def euclid_ext_non_0)
+  
+end
+
+instantiation nat :: euclidean_semiring
+begin
+
+definition [simp]:
+  "euclidean_size_nat = (id :: nat \<Rightarrow> nat)"
+
+definition [simp]:
+  "normalisation_factor_nat (n::nat) = (if n = 0 then 0 else 1 :: nat)"
+
+instance proof
+qed (simp_all add: is_unit_def)
+
+end
+
+instantiation int :: euclidean_ring
+begin
+
+definition [simp]:
+  "euclidean_size_int = (nat \<circ> abs :: int \<Rightarrow> nat)"
+
+definition [simp]:
+  "normalisation_factor_int = (sgn :: int \<Rightarrow> int)"
+
+instance proof
+  case goal2 then show ?case by (auto simp add: abs_mult nat_mult_distrib)
+next
+  case goal3 then show ?case by (simp add: zsgn_def is_unit_def)
+next
+  case goal5 then show ?case by (auto simp: zsgn_def is_unit_def)
+next
+  case goal6 then show ?case by (auto split: abs_split simp: zsgn_def is_unit_def)
+qed (auto simp: sgn_times split: abs_split)
+
+end
+
+end
+
--- a/src/HOL/Old_Number_Theory/Factorization.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Old_Number_Theory/Factorization.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -143,7 +143,7 @@
   apply (induct xs)
    apply simp
    apply (case_tac xs)
-    apply (simp_all cong del: list.weak_case_cong)
+    apply (simp_all cong del: list.case_cong_weak)
   done
 
 lemma nondec_sort: "nondec (sort xs)"
--- a/src/HOL/Partial_Function.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Partial_Function.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -9,8 +9,9 @@
 keywords "partial_function" :: thy_decl
 begin
 
+named_theorems partial_function_mono "monotonicity rules for partial function definitions"
 ML_file "Tools/Function/partial_function.ML"
-setup Partial_Function.setup
+
 
 subsection {* Axiomatic setup *}
 
--- a/src/HOL/Product_Type.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Product_Type.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -281,7 +281,7 @@
 setup {* Sign.parent_path *}
 
 declare prod.case [nitpick_simp del]
-declare prod.weak_case_cong [cong del]
+declare prod.case_cong_weak [cong del]
 
 
 subsubsection {* Tuple syntax *}
@@ -486,7 +486,7 @@
 
 lemma split_weak_cong: "p = q \<Longrightarrow> split c p = split c q"
   -- {* Prevents simplification of @{term c}: much faster *}
-  by (fact prod.weak_case_cong)
+  by (fact prod.case_cong_weak)
 
 lemma cond_split_eta: "(!!x y. f x y = g (x, y)) ==> (%(x, y). f x y) = g"
   by (simp add: split_eta)
--- a/src/HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -4,9 +4,11 @@
 *)
 
 theory Quickcheck_Lattice_Examples
-imports "~~/src/HOL/Library/Quickcheck_Types"
+imports Main
 begin
 
+declare [[quickcheck_finite_type_size=5]]
+
 text {* We show how other default types help to find counterexamples to propositions if
   the standard default type @{typ int} is insufficient. *}
 
--- a/src/HOL/Quotient.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Quotient.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -748,8 +748,12 @@
 
 text {* Auxiliary data for the quotient package *}
 
+named_theorems quot_equiv "equivalence relation theorems"
+named_theorems quot_respect "respectfulness theorems"
+named_theorems quot_preserve "preservation theorems"
+named_theorems id_simps "identity simp rules for maps"
+named_theorems quot_thm "quotient theorems"
 ML_file "Tools/Quotient/quotient_info.ML"
-setup Quotient_Info.setup
 
 declare [[mapQ3 "fun" = (rel_fun, fun_quotient3)]]
 
--- a/src/HOL/Quotient_Examples/FSet.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Quotient_Examples/FSet.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -985,7 +985,7 @@
   have b: "\<And>x' ys'. \<lbrakk>\<not> List.member ys' x'; a # xs \<approx> x' # ys'\<rbrakk> \<Longrightarrow> thesis" by fact
   have c: "xs = [] \<Longrightarrow> thesis" using b 
     apply(simp)
-    by (metis List.set_simps(1) emptyE empty_subsetI)
+    by (metis list.set(1) emptyE empty_subsetI)
   have "\<And>x ys. \<lbrakk>\<not> List.member ys x; xs \<approx> x # ys\<rbrakk> \<Longrightarrow> thesis"
   proof -
     fix x :: 'a
--- a/src/HOL/Quotient_Examples/Lift_FSet.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Quotient_Examples/Lift_FSet.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -151,7 +151,7 @@
   using filter_filter [Transfer.transferred] .
 
 lemma "fset (fcons x xs) = insert x (fset xs)"
-  using set_simps(2) [Transfer.transferred] .
+  using list.set(2) [Transfer.transferred] .
 
 lemma "fset (fappend xs ys) = fset xs \<union> fset ys"
   using set_append [Transfer.transferred] .
--- a/src/HOL/ROOT	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/ROOT	Wed Aug 27 15:52:58 2014 +0200
@@ -38,7 +38,6 @@
     Product_Lexorder
     Product_Order
     Finite_Lattice
-    Quickcheck_Types
     (*data refinements and dependent applications*)
     AList_Mapping
     Code_Binary_Nat
@@ -189,6 +188,7 @@
     Pocklington
     Gauss
     Number_Theory
+    Euclidean_Algorithm
   document_files
     "root.tex"
 
@@ -237,6 +237,19 @@
     Generate_Target_Nat
     Generate_Efficient_Datastructures
     Generate_Pretty_Char
+    Code_Test
+  theories[condition = ISABELLE_GHC]
+    Code_Test_GHC
+  theories[condition = ISABELLE_MLTON]
+    Code_Test_MLton
+  theories[condition = ISABELLE_OCAMLC]
+    Code_Test_OCaml
+  theories[condition = ISABELLE_POLYML_PATH]
+    Code_Test_PolyML
+  theories[condition = ISABELLE_SCALA]
+    Code_Test_Scala
+  theories[condition = ISABELLE_SMLNJ]
+    Code_Test_SMLNJ
 
 session "HOL-Metis_Examples" in Metis_Examples = HOL +
   description {*
@@ -782,7 +795,6 @@
   files
     "Boogie_Dijkstra.certs2"
     "Boogie_Max.certs2"
-    "SMT_Examples.certs"
     "SMT_Examples.certs2"
     "SMT_Word_Examples.certs2"
     "VCC_Max.certs2"
--- a/src/HOL/Real.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/Real.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -1000,13 +1000,24 @@
 where
   "real_of_rat \<equiv> of_rat"
 
-consts
-  (*overloaded constant for injecting other types into "real"*)
-  real :: "'a => real"
+class real_of =
+  fixes real :: "'a \<Rightarrow> real"
+
+instantiation nat :: real_of
+begin
+
+definition real_nat :: "nat \<Rightarrow> real" where real_of_nat_def [code_unfold]: "real \<equiv> of_nat" 
 
-defs (overloaded)
-  real_of_nat_def [code_unfold]: "real == real_of_nat"
-  real_of_int_def [code_unfold]: "real == real_of_int"
+instance ..
+end
+
+instantiation int :: real_of
+begin
+
+definition real_int :: "int \<Rightarrow> real" where real_of_int_def [code_unfold]: "real \<equiv> of_int" 
+
+instance ..
+end
 
 declare [[coercion_enabled]]
 declare [[coercion "real::nat\<Rightarrow>real"]]
@@ -1463,12 +1474,14 @@
       @{thm real_of_nat_mult}, @{thm real_of_int_zero}, @{thm real_of_one},
       @{thm real_of_int_add}, @{thm real_of_int_minus}, @{thm real_of_int_diff},
       @{thm real_of_int_mult}, @{thm real_of_int_of_nat_eq},
-      @{thm real_of_nat_numeral}, @{thm real_numeral(1)}, @{thm real_numeral(2)}]
+      @{thm real_of_nat_numeral}, @{thm real_numeral(1)}, @{thm real_numeral(2)},
+      @{thm real_of_int_def[symmetric]}, @{thm real_of_nat_def[symmetric]}]
   #> Lin_Arith.add_inj_const (@{const_name real}, @{typ "nat \<Rightarrow> real"})
-  #> Lin_Arith.add_inj_const (@{const_name real}, @{typ "int \<Rightarrow> real"}))
+  #> Lin_Arith.add_inj_const (@{const_name real}, @{typ "int \<Rightarrow> real"})
+  #> Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat \<Rightarrow> real"})
+  #> Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int \<Rightarrow> real"}))
 *}
 
-
 subsection{* Simprules combining x+y and 0: ARE THEY NEEDED?*}
 
 lemma real_add_minus_iff [simp]: "(x + - a = (0::real)) = (x=a)" 
@@ -1650,78 +1663,66 @@
 lemma real_lb_ub_int: " \<exists>n::int. real n \<le> r & r < real (n+1)"
 unfolding real_of_int_def by (rule floor_exists)
 
-lemma lemma_floor:
-  assumes a1: "real m \<le> r" and a2: "r < real n + 1"
-  shows "m \<le> (n::int)"
-proof -
-  have "real m < real n + 1" using a1 a2 by (rule order_le_less_trans)
-  also have "... = real (n + 1)" by simp
-  finally have "m < n + 1" by (simp only: real_of_int_less_iff)
-  thus ?thesis by arith
-qed
+lemma lemma_floor: "real m \<le> r \<Longrightarrow> r < real n + 1 \<Longrightarrow> m \<le> (n::int)"
+  by simp
 
 lemma real_of_int_floor_le [simp]: "real (floor r) \<le> r"
 unfolding real_of_int_def by (rule of_int_floor_le)
 
 lemma lemma_floor2: "real n < real (x::int) + 1 ==> n \<le> x"
-by (auto intro: lemma_floor)
+  by simp
 
 lemma real_of_int_floor_cancel [simp]:
     "(real (floor x) = x) = (\<exists>n::int. x = real n)"
   using floor_real_of_int by metis
 
 lemma floor_eq: "[| real n < x; x < real n + 1 |] ==> floor x = n"
-  unfolding real_of_int_def using floor_unique [of n x] by simp
+  by linarith
 
 lemma floor_eq2: "[| real n \<le> x; x < real n + 1 |] ==> floor x = n"
-  unfolding real_of_int_def by (rule floor_unique)
+  by linarith
 
 lemma floor_eq3: "[| real n < x; x < real (Suc n) |] ==> nat(floor x) = n"
-apply (rule inj_int [THEN injD])
-apply (simp add: real_of_nat_Suc)
-apply (simp add: real_of_nat_Suc floor_eq floor_eq [where n = "int n"])
-done
+  by linarith
 
 lemma floor_eq4: "[| real n \<le> x; x < real (Suc n) |] ==> nat(floor x) = n"
-apply (drule order_le_imp_less_or_eq)
-apply (auto intro: floor_eq3)
-done
+  by linarith
 
 lemma real_of_int_floor_ge_diff_one [simp]: "r - 1 \<le> real(floor r)"
-  unfolding real_of_int_def using floor_correct [of r] by simp
+  by linarith
 
 lemma real_of_int_floor_gt_diff_one [simp]: "r - 1 < real(floor r)"
-  unfolding real_of_int_def using floor_correct [of r] by simp
+  by linarith
 
 lemma real_of_int_floor_add_one_ge [simp]: "r \<le> real(floor r) + 1"
-  unfolding real_of_int_def using floor_correct [of r] by simp
+  by linarith
 
 lemma real_of_int_floor_add_one_gt [simp]: "r < real(floor r) + 1"
-  unfolding real_of_int_def using floor_correct [of r] by simp
+  by linarith
 
 lemma le_floor: "real a <= x ==> a <= floor x"
-  unfolding real_of_int_def by (simp add: le_floor_iff)
+  by linarith
 
 lemma real_le_floor: "a <= floor x ==> real a <= x"
-  unfolding real_of_int_def by (simp add: le_floor_iff)
+  by linarith
 
 lemma le_floor_eq: "(a <= floor x) = (real a <= x)"
-  unfolding real_of_int_def by (rule le_floor_iff)
+  by linarith
 
 lemma floor_less_eq: "(floor x < a) = (x < real a)"
-  unfolding real_of_int_def by (rule floor_less_iff)
+  by linarith
 
 lemma less_floor_eq: "(a < floor x) = (real a + 1 <= x)"
-  unfolding real_of_int_def by (rule less_floor_iff)
+  by linarith
 
 lemma floor_le_eq: "(floor x <= a) = (x < real a + 1)"
-  unfolding real_of_int_def by (rule floor_le_iff)
+  by linarith
 
 lemma floor_add [simp]: "floor (x + real a) = floor x + a"
-  unfolding real_of_int_def by (rule floor_add_of_int)
+  by linarith
 
 lemma floor_subtract [simp]: "floor (x - real a) = floor x - a"
-  unfolding real_of_int_def by (rule floor_diff_of_int)
+  by linarith
 
 lemma le_mult_floor:
   assumes "0 \<le> (a :: real)" and "0 \<le> b"
@@ -1746,56 +1747,56 @@
 qed (auto simp: real_of_int_div)
 
 lemma ceiling_real_of_nat [simp]: "ceiling (real (n::nat)) = int n"
-  unfolding real_of_nat_def by simp
+  by linarith
 
 lemma real_of_int_ceiling_ge [simp]: "r \<le> real (ceiling r)"
-  unfolding real_of_int_def by (rule le_of_int_ceiling)
+  by linarith
 
 lemma ceiling_real_of_int [simp]: "ceiling (real (n::int)) = n"
-  unfolding real_of_int_def by simp
+  by linarith
 
 lemma real_of_int_ceiling_cancel [simp]:
      "(real (ceiling x) = x) = (\<exists>n::int. x = real n)"
   using ceiling_real_of_int by metis
 
 lemma ceiling_eq: "[| real n < x; x < real n + 1 |] ==> ceiling x = n + 1"
-  unfolding real_of_int_def using ceiling_unique [of "n + 1" x] by simp
+  by linarith
 
 lemma ceiling_eq2: "[| real n < x; x \<le> real n + 1 |] ==> ceiling x = n + 1"
-  unfolding real_of_int_def using ceiling_unique [of "n + 1" x] by simp
+  by linarith
 
 lemma ceiling_eq3: "[| real n - 1 < x; x \<le> real n  |] ==> ceiling x = n"
-  unfolding real_of_int_def using ceiling_unique [of n x] by simp
+  by linarith
 
 lemma real_of_int_ceiling_diff_one_le [simp]: "real (ceiling r) - 1 \<le> r"
-  unfolding real_of_int_def using ceiling_correct [of r] by simp
+  by linarith
 
 lemma real_of_int_ceiling_le_add_one [simp]: "real (ceiling r) \<le> r + 1"
-  unfolding real_of_int_def using ceiling_correct [of r] by simp
+  by linarith
 
 lemma ceiling_le: "x <= real a ==> ceiling x <= a"
-  unfolding real_of_int_def by (simp add: ceiling_le_iff)
+  by linarith
 
 lemma ceiling_le_real: "ceiling x <= a ==> x <= real a"
-  unfolding real_of_int_def by (simp add: ceiling_le_iff)
+  by linarith
 
 lemma ceiling_le_eq: "(ceiling x <= a) = (x <= real a)"
-  unfolding real_of_int_def by (rule ceiling_le_iff)
+  by linarith
 
 lemma less_ceiling_eq: "(a < ceiling x) = (real a < x)"
-  unfolding real_of_int_def by (rule less_ceiling_iff)
+  by linarith
 
 lemma ceiling_less_eq: "(ceiling x < a) = (x <= real a - 1)"
-  unfolding real_of_int_def by (rule ceiling_less_iff)
+  by linarith
 
 lemma le_ceiling_eq: "(a <= ceiling x) = (real a - 1 < x)"
-  unfolding real_of_int_def by (rule le_ceiling_iff)
+  by linarith
 
 lemma ceiling_add [simp]: "ceiling (x + real a) = ceiling x + a"
-  unfolding real_of_int_def by (rule ceiling_add_of_int)
+  by linarith
 
 lemma ceiling_subtract [simp]: "ceiling (x - real a) = ceiling x - a"
-  unfolding real_of_int_def by (rule ceiling_diff_of_int)
+  by linarith
 
 
 subsubsection {* Versions for the natural numbers *}
@@ -1808,111 +1809,88 @@
   natceiling :: "real => nat" where
   "natceiling x = nat(ceiling x)"
 
+lemma natfloor_split[arith_split]: "P (natfloor t) \<longleftrightarrow> (t < 0 \<longrightarrow> P 0) \<and> (\<forall>n. of_nat n \<le> t \<and> t < of_nat n + 1 \<longrightarrow> P n)"
+proof -
+  have [dest]: "\<And>n m::nat. real n \<le> t \<Longrightarrow> t < real n + 1 \<Longrightarrow> real m \<le> t \<Longrightarrow> t < real m + 1 \<Longrightarrow> n = m"
+    by simp
+  show ?thesis
+    by (auto simp: natfloor_def real_of_nat_def[symmetric] split: split_nat floor_split)
+qed
+
+lemma natceiling_split[arith_split]:
+  "P (natceiling t) \<longleftrightarrow> (t \<le> - 1 \<longrightarrow> P 0) \<and> (\<forall>n. of_nat n - 1 < t \<and> t \<le> of_nat n \<longrightarrow> P n)"
+proof -
+  have [dest]: "\<And>n m::nat. real n - 1 < t \<Longrightarrow> t \<le> real n \<Longrightarrow> real m - 1 < t \<Longrightarrow> t \<le> real m \<Longrightarrow> n = m"
+    by simp
+  show ?thesis
+    by (auto simp: natceiling_def real_of_nat_def[symmetric] split: split_nat ceiling_split)
+qed
+
 lemma natfloor_zero [simp]: "natfloor 0 = 0"
-  by (unfold natfloor_def, simp)
+  by linarith
 
 lemma natfloor_one [simp]: "natfloor 1 = 1"
-  by (unfold natfloor_def, simp)
-
-lemma zero_le_natfloor [simp]: "0 <= natfloor x"
-  by (unfold natfloor_def, simp)
+  by linarith
 
 lemma natfloor_numeral_eq [simp]: "natfloor (numeral n) = numeral n"
   by (unfold natfloor_def, simp)
 
 lemma natfloor_real_of_nat [simp]: "natfloor(real n) = n"
-  by (unfold natfloor_def, simp)
+  by linarith
 
 lemma real_natfloor_le: "0 <= x ==> real(natfloor x) <= x"
-  by (unfold natfloor_def, simp)
+  by linarith
 
 lemma natfloor_neg: "x <= 0 ==> natfloor x = 0"
-  unfolding natfloor_def by simp
+  by linarith
 
 lemma natfloor_mono: "x <= y ==> natfloor x <= natfloor y"
-  unfolding natfloor_def by (intro nat_mono floor_mono)
+  by linarith
 
 lemma le_natfloor: "real x <= a ==> x <= natfloor a"
-  apply (unfold natfloor_def)
-  apply (subst nat_int [THEN sym])
-  apply (rule nat_mono)
-  apply (rule le_floor)
-  apply simp
-done
+  by linarith
 
 lemma natfloor_less_iff: "0 \<le> x \<Longrightarrow> natfloor x < n \<longleftrightarrow> x < real n"
-  unfolding natfloor_def real_of_nat_def
-  by (simp add: nat_less_iff floor_less_iff)
+  by linarith
 
-lemma less_natfloor:
-  assumes "0 \<le> x" and "x < real (n :: nat)"
-  shows "natfloor x < n"
-  using assms by (simp add: natfloor_less_iff)
+lemma less_natfloor: "0 \<le> x \<Longrightarrow> x < real (n :: nat) \<Longrightarrow> natfloor x < n"
+  by linarith
 
 lemma le_natfloor_eq: "0 <= x ==> (a <= natfloor x) = (real a <= x)"
-  apply (rule iffI)
-  apply (rule order_trans)
-  prefer 2
-  apply (erule real_natfloor_le)
-  apply (subst real_of_nat_le_iff)
-  apply assumption
-  apply (erule le_natfloor)
-done
+  by linarith
 
 lemma le_natfloor_eq_numeral [simp]:
-    "~ neg((numeral n)::int) ==> 0 <= x ==>
-      (numeral n <= natfloor x) = (numeral n <= x)"
-  apply (subst le_natfloor_eq, assumption)
-  apply simp
-done
+    "0 \<le> x \<Longrightarrow> (numeral n \<le> natfloor x) = (numeral n \<le> x)"
+  by (subst le_natfloor_eq, assumption) simp
+
+lemma le_natfloor_eq_one [simp]: "(1 \<le> natfloor x) = (1 \<le> x)"
+  by linarith
 
-lemma le_natfloor_eq_one [simp]: "(1 <= natfloor x) = (1 <= x)"
-  apply (case_tac "0 <= x")
-  apply (subst le_natfloor_eq, assumption, simp)
-  apply (rule iffI)
-  apply (subgoal_tac "natfloor x <= natfloor 0")
-  apply simp
-  apply (rule natfloor_mono)
-  apply simp
-  apply simp
-done
+lemma natfloor_eq: "real n \<le> x \<Longrightarrow> x < real n + 1 \<Longrightarrow> natfloor x = n"
+  by linarith
 
-lemma natfloor_eq: "real n <= x ==> x < real n + 1 ==> natfloor x = n"
-  unfolding natfloor_def by (simp add: floor_eq2 [where n="int n"])
-
-lemma real_natfloor_add_one_gt: "x < real(natfloor x) + 1"
-  apply (case_tac "0 <= x")
-  apply (unfold natfloor_def)
-  apply simp
-  apply simp_all
-done
+lemma real_natfloor_add_one_gt: "x < real (natfloor x) + 1"
+  by linarith
 
 lemma real_natfloor_gt_diff_one: "x - 1 < real(natfloor x)"
-using real_natfloor_add_one_gt by (simp add: algebra_simps)
+  by linarith
 
 lemma ge_natfloor_plus_one_imp_gt: "natfloor z + 1 <= n ==> z < real n"
-  apply (subgoal_tac "z < real(natfloor z) + 1")
-  apply arith
-  apply (rule real_natfloor_add_one_gt)
-done
+  by linarith
 
 lemma natfloor_add [simp]: "0 <= x ==> natfloor (x + real a) = natfloor x + a"
-  unfolding natfloor_def
-  unfolding real_of_int_of_nat_eq [symmetric] floor_add
-  by (simp add: nat_add_distrib)
+  by linarith
 
 lemma natfloor_add_numeral [simp]:
-    "~neg ((numeral n)::int) ==> 0 <= x ==>
-      natfloor (x + numeral n) = natfloor x + numeral n"
+    "0 <= x \<Longrightarrow> natfloor (x + numeral n) = natfloor x + numeral n"
   by (simp add: natfloor_add [symmetric])
 
 lemma natfloor_add_one: "0 <= x ==> natfloor(x + 1) = natfloor x + 1"
-  by (simp add: natfloor_add [symmetric] del: One_nat_def)
+  by linarith
 
 lemma natfloor_subtract [simp]:
     "natfloor(x - real a) = natfloor x - a"
-  unfolding natfloor_def real_of_int_of_nat_eq [symmetric] floor_subtract
-  by simp
+  by linarith
 
 lemma natfloor_div_nat:
   assumes "1 <= x" and "y > 0"
@@ -1939,67 +1917,57 @@
     (auto simp add: le_natfloor_eq mult_mono' real_natfloor_le natfloor_neg)
 
 lemma natceiling_zero [simp]: "natceiling 0 = 0"
-  by (unfold natceiling_def, simp)
+  by linarith
 
 lemma natceiling_one [simp]: "natceiling 1 = 1"
-  by (unfold natceiling_def, simp)
+  by linarith
 
 lemma zero_le_natceiling [simp]: "0 <= natceiling x"
-  by (unfold natceiling_def, simp)
+  by linarith
 
 lemma natceiling_numeral_eq [simp]: "natceiling (numeral n) = numeral n"
-  by (unfold natceiling_def, simp)
+  by (simp add: natceiling_def)
 
 lemma natceiling_real_of_nat [simp]: "natceiling(real n) = n"
-  by (unfold natceiling_def, simp)
+  by linarith
 
 lemma real_natceiling_ge: "x <= real(natceiling x)"
-  unfolding natceiling_def by (cases "x < 0", simp_all)
+  by linarith
 
 lemma natceiling_neg: "x <= 0 ==> natceiling x = 0"
-  unfolding natceiling_def by simp
+  by linarith
 
 lemma natceiling_mono: "x <= y ==> natceiling x <= natceiling y"
-  unfolding natceiling_def by (intro nat_mono ceiling_mono)
+  by linarith
 
 lemma natceiling_le: "x <= real a ==> natceiling x <= a"
-  unfolding natceiling_def real_of_nat_def
-  by (simp add: nat_le_iff ceiling_le_iff)
+  by linarith
 
 lemma natceiling_le_eq: "(natceiling x <= a) = (x <= real a)"
-  unfolding natceiling_def real_of_nat_def
-  by (simp add: nat_le_iff ceiling_le_iff)
+  by linarith
 
 lemma natceiling_le_eq_numeral [simp]:
-    "~ neg((numeral n)::int) ==>
-      (natceiling x <= numeral n) = (x <= numeral n)"
+    "(natceiling x <= numeral n) = (x <= numeral n)"
   by (simp add: natceiling_le_eq)
 
 lemma natceiling_le_eq_one: "(natceiling x <= 1) = (x <= 1)"
-  unfolding natceiling_def
-  by (simp add: nat_le_iff ceiling_le_iff)
+  by linarith
 
 lemma natceiling_eq: "real n < x ==> x <= real n + 1 ==> natceiling x = n + 1"
-  unfolding natceiling_def
-  by (simp add: ceiling_eq2 [where n="int n"])
+  by linarith
 
-lemma natceiling_add [simp]: "0 <= x ==>
-    natceiling (x + real a) = natceiling x + a"
-  unfolding natceiling_def
-  unfolding real_of_int_of_nat_eq [symmetric] ceiling_add
-  by (simp add: nat_add_distrib)
+lemma natceiling_add [simp]: "0 <= x ==> natceiling (x + real a) = natceiling x + a"
+  by linarith
 
 lemma natceiling_add_numeral [simp]:
-    "~ neg ((numeral n)::int) ==> 0 <= x ==>
-      natceiling (x + numeral n) = natceiling x + numeral n"
+    "0 <= x ==> natceiling (x + numeral n) = natceiling x + numeral n"
   by (simp add: natceiling_add [symmetric])
 
 lemma natceiling_add_one: "0 <= x ==> natceiling(x + 1) = natceiling x + 1"
-  by (simp add: natceiling_add [symmetric] del: One_nat_def)
+  by linarith
 
 lemma natceiling_subtract [simp]: "natceiling(x - real a) = natceiling x - a"
-  unfolding natceiling_def real_of_int_of_nat_eq [symmetric] ceiling_subtract
-  by simp
+  by linarith
 
 lemma Rats_no_top_le: "\<exists> q \<in> \<rat>. (x :: real) \<le> q"
   by (auto intro!: bexI[of _ "of_nat (natceiling x)"]) (metis real_natceiling_ge real_of_nat_def)
--- a/src/HOL/SMT.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -126,6 +126,7 @@
 ML_file "Tools/SMT/z3_proof_tools.ML"
 ML_file "Tools/SMT/z3_proof_literals.ML"
 ML_file "Tools/SMT/z3_proof_methods.ML"
+named_theorems z3_simp "simplification rules for Z3 proof reconstruction"
 ML_file "Tools/SMT/z3_proof_reconstruction.ML"
 ML_file "Tools/SMT/z3_model.ML"
 ML_file "Tools/SMT/smt_setup_solvers.ML"
@@ -135,7 +136,6 @@
   SMT_Normalize.setup #>
   SMTLIB_Interface.setup #>
   Z3_Interface.setup #>
-  Z3_Proof_Reconstruction.setup #>
   SMT_Setup_Solvers.setup
 *}
 
--- a/src/HOL/SMT2.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT2.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -108,6 +108,7 @@
 ML_file "Tools/SMT2/smtlib2.ML"
 ML_file "Tools/SMT2/smtlib2_interface.ML"
 ML_file "Tools/SMT2/smtlib2_proof.ML"
+ML_file "Tools/SMT2/smtlib2_isar.ML"
 ML_file "Tools/SMT2/z3_new_proof.ML"
 ML_file "Tools/SMT2/z3_new_isar.ML"
 ML_file "Tools/SMT2/smt2_solver.ML"
@@ -117,6 +118,9 @@
 ML_file "Tools/SMT2/z3_new_replay_rules.ML"
 ML_file "Tools/SMT2/z3_new_replay_methods.ML"
 ML_file "Tools/SMT2/z3_new_replay.ML"
+ML_file "Tools/SMT2/verit_proof.ML"
+ML_file "Tools/SMT2/verit_isar.ML"
+ML_file "Tools/SMT2/verit_proof_parse.ML"
 ML_file "Tools/SMT2/smt2_systems.ML"
 
 method_setup smt2 = {*
--- a/src/HOL/SMT_Examples/SMT_Examples.certs	Wed Aug 27 11:33:00 2014 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-43550507f510d81bc4fb9ef8c1fd14424eaa9070 37 0
-#2 := false
-#10 := 0::Int
-decl f3 :: Int
-#7 := f3
-#12 := (<= f3 0::Int)
-#54 := (not #12)
-decl f4 :: Int
-#8 := f4
-#13 := (<= f4 0::Int)
-#9 := (* f3 f4)
-#11 := (<= #9 0::Int)
-#37 := (not #11)
-#44 := (or #37 #12 #13)
-#47 := (not #44)
-#14 := (or #12 #13)
-#15 := (implies #11 #14)
-#16 := (not #15)
-#50 := (iff #16 #47)
-#38 := (or #37 #14)
-#41 := (not #38)
-#48 := (iff #41 #47)
-#45 := (iff #38 #44)
-#46 := [rewrite]: #45
-#49 := [monotonicity #46]: #48
-#42 := (iff #16 #41)
-#39 := (iff #15 #38)
-#40 := [rewrite]: #39
-#43 := [monotonicity #40]: #42
-#51 := [trans #43 #49]: #50
-#36 := [asserted]: #16
-#52 := [mp #36 #51]: #47
-#55 := [not-or-elim #52]: #54
-#56 := (not #13)
-#57 := [not-or-elim #52]: #56
-#53 := [not-or-elim #52]: #11
-[th-lemma arith farkas 1 1 1 #53 #57 #55]: false
-unsat
--- a/src/HOL/SMT_Examples/SMT_Examples.certs2	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT_Examples/SMT_Examples.certs2	Wed Aug 27 15:52:58 2014 +0200
@@ -1,10 +1,3 @@
-3aa17d1c77bc1a92bca05df291d11d81c645a931 6 0
-unsat
-((set-logic AUFLIA)
-(proof
-(let ((@x30 (rewrite (= (not true) false))))
-(mp (asserted (not true)) @x30 false))))
-
 572677daa32981bf8212986300f1362edf42a0c1 7 0
 unsat
 ((set-logic AUFLIA)
@@ -13,6 +6,13 @@
 (let ((@x40 (trans @x36 (rewrite (= (not true) false)) (= (not (or p$ (not p$))) false))))
 (mp (asserted (not (or p$ (not p$)))) @x40 false)))))
 
+3aa17d1c77bc1a92bca05df291d11d81c645a931 6 0
+unsat
+((set-logic AUFLIA)
+(proof
+(let ((@x30 (rewrite (= (not true) false))))
+(mp (asserted (not true)) @x30 false))))
+
 dfd95b23f80baacb2acdc442487bd8121f072035 9 0
 unsat
 ((set-logic AUFLIA)
@@ -1033,7 +1033,7 @@
 (let ((@x59 (trans @x55 (rewrite (= (not true) false)) (= (not (< 5 (ite (<= 3 8) 8 3))) false))))
 (mp (asserted (not (< 5 (ite (<= 3 8) 8 3)))) @x59 false)))))))))
 
-2d63144daf211d89368e355b9b23a3b5118b7ba9 88 0
+6b0b089fbe179e8a27509c818f9a5e6847ac6bf2 88 0
 unsat
 ((set-logic AUFLIRA)
 (proof
@@ -1207,7 +1207,7 @@
 (let ((@x67 (mp (asserted (not (< a$ 0.0))) @x66 $x58)))
 ((_ th-lemma arith farkas 7 3/2 1) @x67 @x52 @x40 false)))))))))))))))))
 
-b9f61649fae66ac195bf2593181f9d76c958bfe2 22 0
+3a6df2b095b936aac9a1d533e306f2d31b4fb44e 22 0
 unsat
 ((set-logic AUFLIA)
 (proof
@@ -1390,7 +1390,7 @@
 (let ((@x433 (mp (not-or-elim @x205 (not $x57)) @x432 $x422)))
 (unit-resolution @x433 @x488 (mp @x478 @x480 $x44) false)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
 
-fbc59441c65d9a844da44405d06d138b55c5d187 933 0
+32286f9c5e71eb2b15c18f86f04c80931e2e307b 933 0
 unsat
 ((set-logic AUFLIA)
 (proof
@@ -2345,7 +2345,7 @@
 (let ((@x62 (monotonicity @x59 (= $x36 (not $x43)))))
 (mp (asserted $x36) (trans @x62 @x71 (= $x36 false)) false))))))))))))))))))
 
-d2037888c28cf52f7a45f66288246169de6f14ad 113 0
+faae12ee7efe4347f92e42776a0e0e57a624319c 113 0
 unsat
 ((set-logic <null>)
 (proof
@@ -2459,7 +2459,7 @@
 (let ((@x74 (mp (asserted $x36) @x73 $x67)))
 ((_ th-lemma arith farkas -1 1 1) @x74 (unit-resolution ((_ th-lemma arith) (or false $x305)) (true-axiom true) $x305) @x337 false))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
 
-29e336c1b1dbb5e85401e6a2954560661ff3cadc 112 0
+57f344c9e787868c98d1e622f158c445c1899c96 112 0
 unsat
 ((set-logic <null>)
 (proof
@@ -2572,7 +2572,7 @@
 (let ((@x70 (mp (asserted (not (< (+ x$ (+ ?x29 ?x29)) (+ x$ 3)))) @x69 $x63)))
 ((_ th-lemma arith farkas -1 1 1) @x70 @x336 (unit-resolution ((_ th-lemma arith) (or false $x319)) (true-axiom true) $x319) false)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
 
-5bcedd8db3cccf5f1df2ef7ad1ca5e39c817a6f4 32 0
+3938db798ebafb55191dcdaf83a8615d1d59c0c3 32 0
 unsat
 ((set-logic <null>)
 (proof
@@ -2605,7 +2605,7 @@
 (let ((@x117 (unit-resolution ((_ th-lemma arith assign-bounds 1) (or $x102 (not $x100))) (unit-resolution ((_ th-lemma arith triangle-eq) (or (not $x95) $x100)) @x98 $x100) $x102)))
 (unit-resolution ((_ th-lemma arith triangle-eq) (or $x28 (not $x101) (not $x102))) @x117 @x110 @x30 false))))))))))))))))))))))))))))))
 
-97186805a3315ef9a1cc4847a2e19a6d09c77915 236 0
+353c8b65ed1b98772a89ffdae52f1cfae628dd6a 236 0
 unsat
 ((set-logic <null>)
 (proof
@@ -3224,7 +3224,7 @@
 (let ((@x66 (mp~ (mp (asserted $x33) @x60 $x56) (nnf-pos (refl (~ $x53 $x53)) (~ $x56 $x56)) $x56)))
 (unit-resolution @x66 @x464 false)))))))))))))))))))))))))
 
-a8cb4a130675f119ab8ba11cbe3a15041f18d2c6 62 0
+a02ae6c9688537bbe4c3be0d3dcebbc703417864 62 0
 unsat
 ((set-logic AUFLIA)
 (declare-fun ?v0!1 () Int)
@@ -3287,7 +3287,7 @@
 (let ((@x515 (unit-resolution (def-axiom (or z3name!0 $x220)) (unit-resolution @x131 @x238 $x88) $x220)))
 (unit-resolution ((_ th-lemma arith triangle-eq) (or (not $x220) (>= ?x96 3))) @x515 @x245 false))))))))))))))))))))))))))))))))))))))))))))))))))))))
 
-9e0e67e5bd5078ab683d440f1a73c518a403be1b 39 0
+9853592ad3514c1450e40271884a9f21f57ff85b 39 0
 unsat
 ((set-logic AUFLIA)
 (proof
@@ -3380,7 +3380,7 @@
 (let ((@x117 (and-elim (not-or-elim @x112 (and $x100 $x102)) $x102)))
 ((_ th-lemma arith farkas 1 1 1) @x117 @x116 @x118 false)))))))))))))))))))))))))))))))))))
 
-0d380fa4e68ab250e8351813b95695943794f02d 46 0
+9201a8009730b821ad6a3a2b64598e50ab5748ca 46 0
 unsat
 ((set-logic AUFLIRA)
 (declare-fun ?v1!1 () Int)
@@ -3600,6 +3600,33 @@
 (let ((@x73 (not-or-elim @x70 $x62)))
 (unit-resolution (unit-resolution ((_ th-lemma arith farkas 1 1) (or $x65 (not $x62))) @x73 $x65) @x74 false))))))))))))))))))
 
+d98ad8f668dead6f610669a52351ea0176a811b0 26 0
+unsat
+((set-logic <null>)
+(proof
+(let (($x58 (<= b$ 0)))
+(let (($x62 (or (not (and (not (<= a$ 0)) (not (<= (* a$ b$) 0)))) (not $x58))))
+(let (($x65 (not $x62)))
+(let (($x35 (not (=> (and (< 0 a$) (< 0 (* a$ b$))) (< 0 b$)))))
+(let (($x33 (< 0 b$)))
+(let (($x38 (or (not (and (< 0 a$) (< 0 (* a$ b$)))) $x33)))
+(let (($x56 (= (not (and (< 0 a$) (< 0 (* a$ b$)))) (not (and (not (<= a$ 0)) (not (<= (* a$ b$) 0)))))))
+(let ((?x30 (* a$ b$)))
+(let (($x48 (<= ?x30 0)))
+(let (($x49 (not $x48)))
+(let (($x44 (<= a$ 0)))
+(let (($x45 (not $x44)))
+(let (($x52 (and $x45 $x49)))
+(let (($x32 (and (< 0 a$) (< 0 ?x30))))
+(let ((@x54 (monotonicity (rewrite (= (< 0 a$) $x45)) (rewrite (= (< 0 ?x30) $x49)) (= $x32 $x52))))
+(let ((@x64 (monotonicity (monotonicity @x54 $x56) (rewrite (= $x33 (not $x58))) (= $x38 $x62))))
+(let ((@x43 (monotonicity (rewrite (= (=> $x32 $x33) $x38)) (= $x35 (not $x38)))))
+(let ((@x69 (trans @x43 (monotonicity @x64 (= (not $x38) $x65)) (= $x35 $x65))))
+(let ((@x74 (not-or-elim (mp (asserted $x35) @x69 $x65) $x58)))
+(let ((@x72 (and-elim (not-or-elim (mp (asserted $x35) @x69 $x65) $x52) $x45)))
+(let ((@x73 (and-elim (not-or-elim (mp (asserted $x35) @x69 $x65) $x52) $x49)))
+((_ th-lemma arith farkas 1 1 1) @x73 @x72 @x74 false))))))))))))))))))))))))
+
 271390ea915947de195c2202e30f90bb84689d60 26 0
 unsat
 ((set-logic <null>)
@@ -3627,33 +3654,6 @@
 (let ((@x92 (trans @x88 (rewrite (= (not true) false)) (= $x39 false))))
 (mp (asserted $x39) @x92 false))))))))))))))))))))))))
 
-d98ad8f668dead6f610669a52351ea0176a811b0 26 0
-unsat
-((set-logic <null>)
-(proof
-(let (($x58 (<= b$ 0)))
-(let (($x62 (or (not (and (not (<= a$ 0)) (not (<= (* a$ b$) 0)))) (not $x58))))
-(let (($x65 (not $x62)))
-(let (($x35 (not (=> (and (< 0 a$) (< 0 (* a$ b$))) (< 0 b$)))))
-(let (($x33 (< 0 b$)))
-(let (($x38 (or (not (and (< 0 a$) (< 0 (* a$ b$)))) $x33)))
-(let (($x56 (= (not (and (< 0 a$) (< 0 (* a$ b$)))) (not (and (not (<= a$ 0)) (not (<= (* a$ b$) 0)))))))
-(let ((?x30 (* a$ b$)))
-(let (($x48 (<= ?x30 0)))
-(let (($x49 (not $x48)))
-(let (($x44 (<= a$ 0)))
-(let (($x45 (not $x44)))
-(let (($x52 (and $x45 $x49)))
-(let (($x32 (and (< 0 a$) (< 0 ?x30))))
-(let ((@x54 (monotonicity (rewrite (= (< 0 a$) $x45)) (rewrite (= (< 0 ?x30) $x49)) (= $x32 $x52))))
-(let ((@x64 (monotonicity (monotonicity @x54 $x56) (rewrite (= $x33 (not $x58))) (= $x38 $x62))))
-(let ((@x43 (monotonicity (rewrite (= (=> $x32 $x33) $x38)) (= $x35 (not $x38)))))
-(let ((@x69 (trans @x43 (monotonicity @x64 (= (not $x38) $x65)) (= $x35 $x65))))
-(let ((@x74 (not-or-elim (mp (asserted $x35) @x69 $x65) $x58)))
-(let ((@x72 (and-elim (not-or-elim (mp (asserted $x35) @x69 $x65) $x52) $x45)))
-(let ((@x73 (and-elim (not-or-elim (mp (asserted $x35) @x69 $x65) $x52) $x49)))
-((_ th-lemma arith farkas 1 1 1) @x73 @x72 @x74 false))))))))))))))))))))))))
-
 b216c79478e44396acca3654b76845499fc18a04 23 0
 unsat
 ((set-logic <null>)
@@ -3944,6 +3944,21 @@
 (let ((@x53 (trans (monotonicity @x46 (= $x33 (not true))) (rewrite (= (not true) false)) (= $x33 false))))
 (mp (asserted $x33) @x53 false)))))))))))
 
+8b09776b03122aeacc9dd9526e1f0e5d41a07f14 14 0
+unsat
+((set-logic AUFLIA)
+(proof
+(let (($x29 (forall ((?v0 A$) )(g$ ?v0))
+))
+(let (($x30 (ite $x29 true false)))
+(let (($x31 (f$ $x30)))
+(let (($x32 (=> $x31 true)))
+(let (($x33 (not $x32)))
+(let ((@x42 (monotonicity (monotonicity (rewrite (= $x30 $x29)) (= $x31 (f$ $x29))) (= $x32 (=> (f$ $x29) true)))))
+(let ((@x46 (trans @x42 (rewrite (= (=> (f$ $x29) true) true)) (= $x32 true))))
+(let ((@x53 (trans (monotonicity @x46 (= $x33 (not true))) (rewrite (= (not true) false)) (= $x33 false))))
+(mp (asserted $x33) @x53 false)))))))))))
+
 b221de9d8dbe279344ac85e2ada07f5722636ce5 46 0
 unsat
 ((set-logic AUFLIA)
@@ -3991,21 +4006,6 @@
 (let ((@x478 (mp ((_ quant-inst 3 42) (or (not $x52) $x171)) (trans (monotonicity @x131 $x137) (rewrite (= $x134 $x134)) $x137) $x134)))
 (unit-resolution (unit-resolution @x478 @x78 $x168) (mp @x77 @x472 (not $x168)) false)))))))))))))))))))))))))))))))))))
 
-8b09776b03122aeacc9dd9526e1f0e5d41a07f14 14 0
-unsat
-((set-logic AUFLIA)
-(proof
-(let (($x29 (forall ((?v0 A$) )(g$ ?v0))
-))
-(let (($x30 (ite $x29 true false)))
-(let (($x31 (f$ $x30)))
-(let (($x32 (=> $x31 true)))
-(let (($x33 (not $x32)))
-(let ((@x42 (monotonicity (monotonicity (rewrite (= $x30 $x29)) (= $x31 (f$ $x29))) (= $x32 (=> (f$ $x29) true)))))
-(let ((@x46 (trans @x42 (rewrite (= (=> (f$ $x29) true) true)) (= $x32 true))))
-(let ((@x53 (trans (monotonicity @x46 (= $x33 (not true))) (rewrite (= (not true) false)) (= $x33 false))))
-(mp (asserted $x33) @x53 false)))))))))))
-
 5d3ccbcf168a634cad3952ad8f6d2798329d6a77 75 0
 unsat
 ((set-logic AUFLIA)
@@ -4204,7 +4204,7 @@
 (let ((@x81 (asserted $x80)))
 (unit-resolution @x81 (trans @x397 ((_ th-lemma arith eq-propagate 1 1 -4 -4) @x410 @x422 @x428 @x438 (= ?x490 6)) $x79) false)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
 
-fa62bf7228a50eb8c663092f87f9af7c25feaffe 336 0
+640bb6103260f74026864b86c2301c00ea737ff0 336 0
 unsat
 ((set-logic <null>)
 (proof
--- a/src/HOL/SMT_Examples/SMT_Examples.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT_Examples/SMT_Examples.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -8,9 +8,6 @@
 imports Complex_Main
 begin
 
-declare [[smt_certificates = "SMT_Examples.certs"]]
-declare [[smt_read_only_certificates = true]]
-
 declare [[smt2_certificates = "SMT_Examples.certs2"]]
 declare [[smt2_read_only_certificates = true]]
 
@@ -382,16 +379,12 @@
    U + (2 * (1 + p) * (b + e) + (1 + p) * d + d * p) - (1 + p) * (b + d + e)"
   using [[z3_new_extensions]] by smt2
 
-lemma [z3_rule, z3_new_rule]:
+lemma [z3_new_rule]:
   fixes x :: "int"
   assumes "x * y \<le> 0" and "\<not> y \<le> 0" and "\<not> x \<le> 0"
   shows False
   using assms by (metis mult_le_0_iff)
 
-lemma "x * y \<le> (0 :: int) \<Longrightarrow> x \<le> 0 \<or> y \<le> 0"
-  using [[z3_with_extensions]] [[z3_new_extensions]]
-  by smt (* smt2 FIXME: "th-lemma" tactic fails *)
-
 
 section {* Pairs *}
 
--- a/src/HOL/SMT_Examples/SMT_Tests.thy	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT_Examples/SMT_Tests.thy	Wed Aug 27 15:52:58 2014 +0200
@@ -8,7 +8,6 @@
 imports Complex_Main
 begin
 
-smt_status
 smt2_status
 
 text {* Most examples are taken from various Isabelle theories and from HOL4. *}
@@ -588,7 +587,7 @@
   "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
      p \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
   using point.simps bw_point.simps
-  by smt+ (* smt2 FIXME: bad Z3 4.3.x proof *)
+  sorry (* smt2 FIXME: bad Z3 4.3.x proof *)
 
 lemma
   "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> black := w \<rparr> = \<lparr> cx = 3, cy = 4, black = w \<rparr>"
--- a/src/HOL/SMT_Examples/SMT_Word_Examples.certs2	Wed Aug 27 11:33:00 2014 +0200
+++ b/src/HOL/SMT_Examples/SMT_Word_Examples.certs2	Wed Aug 27 15:52:58 2014 +0200
@@ -43,14 +43,6 @@
 (let ((@x49 (trans @x45 (rewrite (= (not true) false)) (= (not (= (bvmul (_ bv7 8) (_ bv3 8)) (_ bv21 8))) false))))
 (mp (asserted (not (= (bvmul (_ bv7 8) (_ bv3 8)) (_ bv21 8)))) @x49 false)))))))
 
-6dd848d7b26e0521039e21a5e2bafebc1fee8c9b 7 0
-unsat
-((set-logic <null>)
-(proof
-(let ((@x35 (monotonicity (rewrite (= (= (_ bv11 5) (_ bv11 5)) true)) (= (not (= (_ bv11 5) (_ bv11 5))) (not true)))))
-(let ((@x39 (trans @x35 (rewrite (= (not true) false)) (= (not (= (_ bv11 5) (_ bv11 5))) false))))
-(mp (asserted (not (= (_ bv11 5) (_ bv11 5)))) @x39 false)))))
-
 45bf9e0a746f7dde46f8242e5851928c2671c7f2 9 0
 unsat
 ((set-logic <null>)
@@ -61,6 +53,14 @@
 (let ((@x54 (trans @x50 (rewrite (= (not true) false)) (= (not (= (bvsub (_ bv11 8) (_ bv27 8)) (bvneg (_ bv16 8)))) false))))
 (mp (asserted (not (= (bvsub (_ bv11 8) (_ bv27 8)) (bvneg (_ bv16 8))))) @x54 false)))))))
 
+6dd848d7b26e0521039e21a5e2bafebc1fee8c9b 7 0
+unsat
+((set-logic <null>)
+(proof
+(let ((@x35 (monotonicity (rewrite (= (= (_ bv11 5) (_ bv11 5)) true)) (= (not (= (_ bv11 5) (_ bv11 5))) (not true)))))
+(let ((@x39 (trans @x35 (rewrite (= (not true) false)) (= (not (= (_ bv11 5) (_ bv11 5))) false))))
+(mp (asserted (not (= (_ bv11 5) (_ bv11 5)))) @x39 false)))))
+
 00a7ff287d9c23d984163ea8e0cac8ac61008afd 11 0
 unsat
 ((set-logic <null>)
@@ -142,6 +142,15 @@
 (let ((@x48 (trans @x44 (rewrite (= (not true) false)) (= (not (= (bvxor (_ bv240 8) (_ bv255 8)) (_ bv15 8))) false))))
 (mp (asserted (not (= (bvxor (_ bv240 8) (_ bv255 8)) (_ bv15 8)))) @x48 false)))))))
 
+3838eb33edcd292c3a0ecbf1662b54af3940189f 8 0
+unsat
+((set-logic <null>)
+(proof
+(let ((@x36 (monotonicity (rewrite (= (bvnot (_ bv240 16)) (_ bv65295 16))) (= (= (bvnot (_ bv240 16)) (_ bv65295 16)) (= (_ bv65295 16) (_ bv65295 16))))))
+(let ((@x40 (trans @x36 (rewrite (= (= (_ bv65295 16) (_ bv65295 16)) true)) (= (= (bvnot (_ bv240 16)) (_ bv65295 16)) true))))