# HG changeset patch # User wenzelm # Date 1409147578 -7200 # Node ID be9815d02b1045abdbbe3060dabaccf47646d768 # Parent 1b6035697c498132c871bce0c9a23d2ad53fdf51# Parent 930727de976c3656b1df3d5a73bf7e1092887b61 merged diff -r 1b6035697c49 -r be9815d02b10 Admin/components/components.sha1 --- 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 diff -r 1b6035697c49 -r be9815d02b10 Admin/components/main --- 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 diff -r 1b6035697c49 -r be9815d02b10 CONTRIBUTORS --- 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 ----------------------------- diff -r 1b6035697c49 -r be9815d02b10 NEWS --- 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) --------------------------------- diff -r 1b6035697c49 -r be9815d02b10 etc/isar-keywords-ZF.el --- 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" diff -r 1b6035697c49 -r be9815d02b10 etc/isar-keywords.el --- 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" diff -r 1b6035697c49 -r be9815d02b10 src/CCL/Wfd.thy --- 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)) diff -r 1b6035697c49 -r be9815d02b10 src/Cube/Cube.thy --- 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" diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Datatypes/Datatypes.thy --- 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 \ \ nonnull list"} \\ @{prop "nonnull list \ \ null list"} -\item[@{text "t."}\hthm{disc_exhaust} @{text "[case_names C\<^sub>1 \ C\<^sub>n]"}\rm:] ~ \\ -@{thm list.disc_exhaust[no_vars]} - -\item[@{text "t."}\hthm{sel_exhaust} @{text "[case_names C\<^sub>1 \ C\<^sub>n]"}\rm:] ~ \\ -@{thm list.sel_exhaust[no_vars]} +\item[@{text "t."}\hthm{exhaust_disc} @{text "[case_names C\<^sub>1 \ C\<^sub>n]"}\rm:] ~ \\ +@{thm list.exhaust_disc[no_vars]} + +\item[@{text "t."}\hthm{exhaust_sel} @{text "[case_names C\<^sub>1 \ 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 \ C\<^sub>n, induct t]"}\rm:] ~ \\ @{thm list.induct[no_vars]} -\item[@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{induct} @{text "[case_names C\<^sub>1 \ 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 \ C\<^sub>n, induct pred]"}\rm:] ~ \\ @{thm list.rel_induct[no_vars]} -\item[@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{rel_induct} @{text "[case_names C\<^sub>1 \ C\<^sub>n]"}\rm:] ~ \\ +\item[\begin{tabular}{@ {}l@ {}} + @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{induct} @{text "[case_names C\<^sub>1 \ C\<^sub>n]"}\rm: \\ + @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{rel_induct} @{text "[case_names C\<^sub>1 \ 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 \ t\<^sub>m,"} \\ - \phantom{@{text "t."}\hthm{strong_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \ D\<^sub>n]"}\rm: + @{text "t."}\hthm{coinduct_strong} @{text "[consumes m, case_names t\<^sub>1 \ t\<^sub>m,"} \\ + \phantom{@{text "t."}\hthm{coinduct_strong} @{text "["}}@{text "case_conclusion D\<^sub>1 \ 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 \ t\<^sub>m,"} \\ @@ -1767,14 +1789,21 @@ \item[\begin{tabular}{@ {}l@ {}} @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{coinduct} @{text "[case_names t\<^sub>1 \ t\<^sub>m, case_conclusion D\<^sub>1 \ D\<^sub>n]"} \\ - @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{strong_coinduct} @{text "[case_names t\<^sub>1 \ t\<^sub>m,"} \\ - \phantom{@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{strong_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \ D\<^sub>n]"}\rm: \\ + @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{coinduct_strong} @{text "[case_names t\<^sub>1 \ t\<^sub>m,"} \\ + \phantom{@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{coinduct_strong} @{text "["}}@{text "case_conclusion D\<^sub>1 \ D\<^sub>n]"}\rm: \\ @{text "t\<^sub>1_\_t\<^sub>m."}\hthm{rel_coinduct} @{text "[case_names t\<^sub>1 \ t\<^sub>m,"} \\ \phantom{@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{rel_coinduct} @{text "["}}@{text "case_conclusion D\<^sub>1 \ 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_\_t\<^sub>m."}\hthm{set_induct} @{text "[case_names C\<^sub>1 \ C\<^sub>n,"} \\ + \phantom{@{text "t\<^sub>1_\_t\<^sub>m."}\hthm{set_induct} @{text "["}}@{text "induct set: set\<^sub>j_t\<^sub>1, \, 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. *} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Implementation/Isar.thy --- 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' = \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)))\ + 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)\ "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 diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Isar_Ref/Proof.thy --- 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 \ theory"} \\ + @{command_def "method_setup"} & : & @{text "local_theory \ local_theory"} \\ \end{matharray} @{rail \ - @@{command method_setup} @{syntax name} '=' @{syntax text} @{syntax text}? + @@{command method_setup} @{syntax target}? + @{syntax name} '=' @{syntax text} @{syntax text}? \} \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 diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Isar_Ref/Spec.thy --- 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 \"} \\ @{command_def "setup"} & : & @{text "theory \ theory"} \\ @{command_def "local_setup"} & : & @{text "local_theory \ local_theory"} \\ - @{command_def "attribute_setup"} & : & @{text "theory \ theory"} \\ + @{command_def "attribute_setup"} & : & @{text "local_theory \ 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}? \} \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 \ local_theory"} \\ @{command_def "theorems"} & : & @{text "local_theory \ local_theory"} \\ + @{command_def "named_theorems"} & : & @{text "local_theory \ local_theory"} \\ \end{matharray} @{rail \ (@@{command lemmas} | @@{command theorems}) @{syntax target}? \ (@{syntax thmdef}? @{syntax thmrefs} + @'and') (@'for' (@{syntax vars} + @'and'))? + ; + @@{command named_theorems} @{syntax target}? + @{syntax name} @{syntax text}? \} \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} *} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Logics/document/HOL.tex --- 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} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Main/document/root.tex --- 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} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Prog_Prove/Basics.thy --- 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 :: \"} 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"\"}. +disambiguate terms involving overloaded functions such as @{text "+"}. Finally there are the universal quantifier @{text"\"}\index{$4@\isasymAnd} and the implication @{text"\"}\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}\\ diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Prog_Prove/Bool_nat_list.thy --- 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} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Prog_Prove/MyList.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Prog_Prove/Types_and_funs.thy --- 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"\\<^sub>1 * \\<^sub>2"} is the type of pairs, also written @{text"\\<^sub>1 \ \\<^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 "\\<^sub>1 \ \\<^sub>2 \ \\<^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 "\\<^sub>1 \ \\<^sub>2 \ \\<^sub>3"} is short for @{text "\\<^sub>1 \ (\\<^sub>2 \ \\<^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} diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Prog_Prove/document/intro-isabelle.tex --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/Doc/Sledgehammer/document/root.tex --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/Doc/antiquote_setup.ML --- 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); diff -r 1b6035697c49 -r be9815d02b10 src/FOL/IFOL.thy --- 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)" .. diff -r 1b6035697c49 -r be9815d02b10 src/HOL/ATP.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Archimedean_Field.thy --- 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 \ z \ x < of_int z + 1" by (simp add: not_less [symmetric] less_floor_iff) +lemma floor_split[arith_split]: "P (floor t) \ (\i. of_int i \ t \ t < of_int i + 1 \ P i)" + by (metis floor_correct floor_unique less_floor_iff not_le order_refl) + lemma floor_mono: assumes "x \ y" shows "floor x \ floor y" proof - have "of_int (floor x) \ 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) \ (\i. of_int i - 1 < t \ t \ of_int i \ P i)" + by (auto simp add: ceiling_unique ceiling_correct) + lemma ceiling_diff_floor_le_1: "ceiling x - floor x \ 1" proof - have "of_int \x\ - 1 < x" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Comp.thy --- 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. *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Def.thy --- 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 \ 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 \ ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \ {Inr ()})|" unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Examples/Derivation_Trees/DTree.thy --- 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 \ 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) \ cont (unfold rt ct b) = image (id \ 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) \ cont (corec rt ct b) = image (id \ ([[id, corec rt ct]])) (ct b)" -using dtree.sel_corec[of rt "the_inv fset \ ct" b] unfolding corec_def +using dtree.corec_sel[of rt "the_inv fset \ ct" b] unfolding corec_def unfolding cont_def comp_def id_def by simp_all diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Examples/Misc_Datatype.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Examples/Process.thy --- 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 \ isChoice p" -by (rule process.disc_exhaust) auto +by (rule process.exhaust_disc) auto theorem not_isAction_isChoice: "\ (isAction p \ isChoice p)" by (cases rule: process.exhaust[of p]) auto @@ -54,7 +54,7 @@ Ch: "\ p q p' q'. \ (Choice p q) (Choice p' q') \ (\ p p' \ p = p') \ (\ q q' \ 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) *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_Examples/Stream.thy --- 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: "\s. P (shd s) s" and Step: "\s y. \y \ sset (stl s); P y (stl s)\ \ P y s" - shows "\y \ sset s. P y s" -proof (rule stream.dtor_set_induct) - fix a :: 'a and s :: "'a stream" - assume "a \ 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' \ set2_pre_stream (dtor_stream s)" and prems: "a \ 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 \ sset s" and "\s. P (shd s) s" - and "\s y. \y \ sset (stl s); P y (stl s)\ \ P y s" +theorem sset_induct[consumes 1, case_names shd stl, induct set: sset]: + assumes "y \ sset s" and "\s. P (shd s) s" and "\s y. \y \ sset (stl s); P y (stl s)\ \ 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 \ ?R" by (auto simp: sset_range dest!: nth_mem) next fix x xs assume "xs \ sset s" ?P "x \ set xs" thus "x \ ?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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_FP_Base.thy --- 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. *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_GFP.thy --- 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: "\\x. s = x \ P\ \ P" -by simp + by simp lemma obj_sumE: "\\x. s = Inl x \ P; \x. s = Inr x \ P\ \ P" -by (cases s) auto + by (cases s) auto lemma not_TrueE: "\ True \ P" -by (erule notE, rule TrueI) + by (erule notE, rule TrueI) lemma neq_eq_eq_contradict: "\t \ u; s = t; s = u\ \ P" -by fast + by fast lemma case_sum_expand_Inr: "f o Inl = g \ 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 \ h = f o Inr \ 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 \ B) ^-1 = B \ A" -by fast + by fast lemma equiv_proj: - assumes e: "equiv A R" and "z \ R" + assumes e: "equiv A R" and m: "z \ R" shows "(proj R o fst) z = (proj R o snd) z" proof - - from assms(2) have z: "(fst z, snd z) \ R" by auto + from m have z: "(fst z, snd z) \ R" by auto with e have "\x. (fst z, x) \ R \ (snd z, x) \ R" "\x. (snd z, x) \ R \ (fst z, x) \ 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 \ 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: "\b = f x; c = g x; x \ A\ \ (b, c) \ image2 A f g" -unfolding image2_def by auto + unfolding image2_def by auto lemma IdD: "(a, b) \ Id \ 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) \ Gr A f \ x \ A" -unfolding Gr_def by simp + unfolding Gr_def by simp lemma GrD2: "(x, fx) \ Gr A f \ f x = fx" -unfolding Gr_def by simp + unfolding Gr_def by simp lemma Gr_incl: "Gr A f \ A <*> B \ f ` A \ B" -unfolding Gr_def by auto + unfolding Gr_def by auto lemma subset_Collect_iff: "B \ A \ (B \ {x \ A. P x}) = (\x \ B. P x)" -by blast + by blast lemma subset_CollectI: "B \ A \ (\x. x \ B \ Q x \ P x) \ ({x \ B. Q x} \ {x \ 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 \ Y \ X \ Collect (split (in_rel Y))" -by auto + by auto lemma Collect_split_in_rel_leE: "X \ Collect (split (in_rel Y)) \ (X \ Y \ R) \ R" -by force + by force lemma conversep_in_rel: "(in_rel R)\\ = in_rel (R\)" -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 \ {(f a1, f a2) | a1 a2. (a1,a2) \ R}" + "relImage R f \ {(f a1, f a2) | a1 a2. (a1,a2) \ R}" definition relInvImage where -"relInvImage A R f \ {(a1, a2) | a1 a2. a1 \ A \ a2 \ A \ (f a1, f a2) \ R}" + "relInvImage A R f \ {(a1, a2) | a1 a2. a1 \ A \ a2 \ A \ (f a1, f a2) \ R}" lemma relImage_Gr: -"\R \ A \ A\ \ relImage R f = (Gr A f)^-1 O R O Gr A f" -unfolding relImage_def Gr_def relcomp_def by auto + "\R \ A \ A\ \ 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: "\R \ B \ B\ \ 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 \ R2 \ relImage R1 f \ relImage R2 f" -unfolding relImage_def by auto + "R1 \ R2 \ relImage R1 f \ relImage R2 f" + unfolding relImage_def by auto lemma relInvImage_mono: -"R1 \ R2 \ relInvImage A R1 f \ relInvImage A R2 f" -unfolding relInvImage_def by auto + "R1 \ R2 \ relInvImage A R1 f \ relInvImage A R2 f" + unfolding relInvImage_def by auto lemma relInvImage_Id_on: -"(\a1 a2. f a1 = f a2 \ a1 = a2) \ relInvImage A (Id_on B) f \ Id" -unfolding relInvImage_def Id_on_def by auto + "(\a1 a2. f a1 = f a2 \ a1 = a2) \ relInvImage A (Id_on B) f \ Id" + unfolding relInvImage_def Id_on_def by auto lemma relInvImage_UNIV_relImage: -"R \ relInvImage UNIV (relImage R f) f" -unfolding relInvImage_def relImage_def by auto + "R \ 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) \ 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) \ 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 \ f ` A <*> f ` A" -shows "relImage (relInvImage A R f) f = R" -using assms unfolding relImage_def relInvImage_def by fast + assumes "R \ 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 \ a = (x, y) \ P (fst a) (snd a)" -by simp + by simp lemma fst_diag_id: "(fst \ (%x. (x, x))) z = id z" by simp lemma snd_diag_id: "(snd \ (%x. (x, x))) z = id z" by simp @@ -159,76 +159,75 @@ definition shift where "shift lab k = (\kl. lab (k # kl))" lemma empty_Shift: "\[] \ Kl; k \ Succ Kl []\ \ [] \ Shift Kl k" -unfolding Shift_def Succ_def by simp + unfolding Shift_def Succ_def by simp lemma SuccD: "k \ Succ Kl kl \ kl @ [k] \ Kl" -unfolding Succ_def by simp + unfolding Succ_def by simp lemmas SuccE = SuccD[elim_format] lemma SuccI: "kl @ [k] \ Kl \ k \ Succ Kl kl" -unfolding Succ_def by simp + unfolding Succ_def by simp lemma ShiftD: "kl \ Shift Kl k \ k # kl \ 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 \ inj_on f A \ f ` A \ Field r \ Card_order r" definition "toCard A r \ SOME f. toCard_pred A r f" lemma ex_toCard_pred: -"\|A| \o r; Card_order r\ \ \ 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 + "\|A| \o r; Card_order r\ \ \ 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: "\|A| \o r; Card_order r\ \ 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: "\|A| \o r; Card_order r; x \ A; y \ A\ \ - toCard A r x = toCard A r y \ x = y" -using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast +lemma toCard_inj: "\|A| \o r; Card_order r; x \ A; y \ A\ \ toCard A r x = toCard A r y \ x = y" + using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast definition "fromCard A r k \ SOME b. b \ A \ toCard A r b = k" lemma fromCard_toCard: -"\|A| \o r; Card_order r; b \ A\ \ fromCard A r (toCard A r b) = b" -unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj) + "\|A| \o r; Card_order r; b \ A\ \ 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 \ Field r \ Inl a \ 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 \ Field s \ Inr a \ 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) \ f 0 = f1" -by auto + by auto lemma rec_nat_Suc_imp: "f = rec_nat f1 (%n rec. f2 n rec) \ 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) \ f [] = f1" -by auto + by auto lemma rec_list_Cons_imp: "f = rec_list f1 (%x xs rec. f2 x xs rec) \ f (x # xs) = f2 x xs (f xs)" -by auto + by auto lemma not_arg_cong_Inr: "x \ y \ Inr x \ Inr y" -by simp + by simp lemma Collect_splitD: "x \ Collect (split A) \ A (fst x) (snd x)" -by auto + by auto definition image2p where "image2p f g R = (\x y. \x' y'. R x' y' \ f x' = x \ g y' = y)" @@ -250,20 +249,21 @@ lemma equiv_Eps_in: "\equiv A r; X \ A//r\ \ Eps (%x. x \ X) \ 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 \ A//r" -shows "Eps (%x. x \ X) \ 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 \ A//r" + shows "Eps (%x. x \ X) \ 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 \ A//r" -shows "proj r (Eps (%x. x \ X)) = X" -unfolding proj_def proof auto + assumes "equiv A r" and "X \ A//r" + shows "proj r (Eps (%x. x \ X)) = X" +unfolding proj_def +proof auto fix x assume x: "x \ X" thus "(Eps (%x. x \ X), x) \ 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 \ A" shows "(univ f) (proj r x) = f x" -unfolding univ_def proof - +proof (unfold univ_def) have prj: "proj r x \ A//r" using x proj_preserves by fast hence "Eps (%y. y \ proj r x) \ A" using ECH equiv_Eps_preserves by fast moreover have "proj r (Eps (%y. y \ 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: "\ x \ A. f x \ B" -shows "\X \ A//r. univ f X \ B" + assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\x \ A. f x \ B" + shows "\X \ A//r. univ f X \ B" proof fix X assume "X \ A//r" then obtain x where x: "x \ 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 \ B" using x PRES by simp qed diff -r 1b6035697c49 -r be9815d02b10 src/HOL/BNF_LFP.thy --- 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: "(\x. x \ A \ False) \ A \ {}" -by blast + by blast lemma image_Collect_subsetI: "(\x. P x \ f x \ B) \ f ` {x. P x} \ B" -by blast + by blast lemma Collect_restrict: "{x. x \ X \ P x} \ X" -by auto + by auto lemma prop_restrict: "\x \ Z; Z \ {x. x \ X \ P x}\ \ P x" -by auto + by auto lemma underS_I: "\i \ j; (i, j) \ R\ \ i \ underS R j" -unfolding underS_def by simp + unfolding underS_def by simp lemma underS_E: "i \ underS R j \ i \ j \ (i, j) \ R" -unfolding underS_def by simp + unfolding underS_def by simp lemma underS_Field: "i \ underS R j \ i \ Field R" -unfolding underS_def Field_def by auto + unfolding underS_def Field_def by auto lemma FieldI2: "(i, j) \ R \ j \ Field R" -unfolding Field_def by auto + unfolding Field_def by auto lemma fst_convol': "fst (\f, g\ x) = f x" -using fst_convol unfolding convol_def by simp + using fst_convol unfolding convol_def by simp lemma snd_convol': "snd (\f, g\ 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 \ \g, snd o f\ = 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 "\ \ \g, h\ = 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 \ \a\A. f a \ B" -unfolding bij_betw_def by auto + unfolding bij_betw_def by auto lemma bij_betw_imageE: "bij_betw f A B \ 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 \ (bij_betw f A B \ x \ B) \ f (the_inv_into A f x) = x" @@ -78,7 +78,7 @@ "\\x y. \x \ X; y \ X\ \ (f x = f y) = (x = y); \x. x \ X \ f x \ Y; \y. y \ Y \ \x \ X. y = f x\ \ 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: "\x \ X. (g1 o f) x = (g2 o f) x" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Bali/Basis.thy --- 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)}" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Bali/Conform.thy --- 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: diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Code_Evaluation.thy --- 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 \ integer \ term" \ (Eval) "HOLogic.mk'_number/ HOLogic.code'_integerT" | constant "term_of \ String.literal \ term" \ (Eval) "HOLogic.mk'_literal" +declare [[code drop: "term_of :: integer \ _"]] + +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 \ 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 \ integer)) + (term_of (- i)))" +by(rule term_of_anything[THEN meta_eq_to_obj_eq]) + code_reserved Eval HOLogic diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test.thy --- /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 \ yxml_of_term" + where [code del]: "yot_literal _ = YXML" +definition yot_append :: "yxml_of_term \ yxml_of_term \ yxml_of_term" + where [code del]: "yot_append _ _ = YXML" +definition yot_concat :: "yxml_of_term list \ 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 + \ (SML) "string" + and (OCaml) "string" + and (Haskell) "String" + and (Scala) "String" +| constant yot_empty + \ (SML) "\"\"" + and (OCaml) "\"\"" + and (Haskell) "\"\"" + and (Scala) "\"\"" +| constant yot_literal + \ (SML) "_" + and (OCaml) "_" + and (Haskell) "_" + and (Scala) "_" +| constant yot_append + \ (SML) "String.concat [(_), (_)]" + and (OCaml) "String.concat \"\" [(_); (_)]" + and (Haskell) infixr 5 "++" + and (Scala) infixl 5 "+" +| constant yot_concat + \ (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 \ String.literal) list" +type_synonym body = "xml_tree list" + +definition Elem :: "String.literal \ attributes \ xml_tree list \ xml_tree" +where [code del]: "Elem _ _ _ = XML_Tree" + +definition Text :: "String.literal \ xml_tree" +where [code del]: "Text _ = XML_Tree" + +definition node :: "xml_tree list \ xml_tree" +where "node ts = Elem (STR '':'') [] ts" + +definition tagged :: "String.literal \ String.literal option \ xml_tree list \ xml_tree" +where "tagged tag x ts = Elem tag (case x of None \ [] | Some x' \ [(STR ''0'', x')]) ts" + +definition list where "list f xs = map (node \ 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 \ yxml_of_term \ 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 (\(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 \ 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 \ xml.body" +where [code del]: "xml_of_typ _ = [XML_Tree]" + +definition xml_of_term :: "Code_Evaluation.term \ 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 \ yxml_of_term" +where "yxml_string_of_term = yxml_string_of_body \ xml_of_term" + +subsection {* Test engine and drivers *} + +ML_file "code_test.ML" + +end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_GHC.thy --- /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 \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_MLton.thy --- /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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_OCaml.thy --- /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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_PolyML.thy --- /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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_SMLNJ.thy --- /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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/Code_Test_Scala.thy --- /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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Codegenerator_Test/code_test.ML --- /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 \ yxml_of_term) option"} + | mk_term_of ts = + let + val tuple = mk_tuples ts + val T = fastype_of tuple + in + @{term "Some :: (unit \ yxml_of_term) \ (unit \ 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 + diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Decision_Procs/Cooper.thy --- 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 \ set (\ (Gt (CN 0 c e)))" by simp - from 7(5)[simplified simp_thms Inum.simps \.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 \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]] have nob: "\ (\j\ {1 ..d}. x = - ?e + j)" by auto from H p have "x + ?e > 0 \ x + ?e \ d" @@ -2085,7 +2085,7 @@ let ?v = "Sub (C -1) e" have vb: "?v \ set (\ (Ge (CN 0 c e)))" by simp - from 8(5)[simplified simp_thms Inum.simps \.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 \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="x" and bs="bs"]] have nob: "\ (\j\ {1 ..d}. x = - ?e - 1 + j)" by auto from H p have "x + ?e \ 0 \ x + ?e < d" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Decision_Procs/MIR.thy --- 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: "\ real (x-d) + ?e > 0" let ?v="Neg e" have vb: "?v \ set (\ (Gt (CN 0 c e)))" by simp - from 7(5)[simplified simp_thms Inum.simps \.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 \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] have nob: "\ (\ j\ {1 ..d}. real x = - ?e + real j)" by auto from H p have "real x + ?e > 0 \ real x + ?e \ real d" by (simp add: c1) hence "real (x + floor ?e) > real (0::int) \ real (x + floor ?e) \ real d" @@ -2638,7 +2638,7 @@ {assume H: "\ real (x-d) + ?e \ 0" let ?v="Sub (C -1) e" have vb: "?v \ set (\ (Ge (CN 0 c e)))" by simp - from 8(5)[simplified simp_thms Inum.simps \.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 \.simps list.set bex_simps numbound0_I[OF bn,where b="a" and b'="real x" and bs="bs"]] have nob: "\ (\ j\ {1 ..d}. real x = - ?e - 1 + real j)" by auto from H p have "real x + ?e \ 0 \ real x + ?e < real d" by (simp add: c1) hence "real (x + floor ?e) \ real (0::int) \ real (x + floor ?e) < real d" @@ -3394,7 +3394,7 @@ ((UNION {(p,n,s). (p,n,s) \ ?SS a \ n=0} (\ (p,n,s). {(p,0,Floor s)})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n>0} (\ (p,n,s). (?f(p,n,s)) ` {0 .. n})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n<0} (\ (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 "\ = ((UNION {(p,n,s). (p,n,s) \ ?SS a \ n=0} (\ (p,n,s). {(p,0,Floor s)})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n>0} (\ (p,n,s). {?f(p,n,s) j| j. j\ {0 .. n}})) Un @@ -3548,7 +3548,7 @@ ((UNION {(p,n,s). (p,n,s) \ ?SS a \ n=0} (\ (p,n,s). {(p,0,Floor s)})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n>0} (\ (p,n,s). (?f(p,n,s)) ` {0 .. n})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n<0} (\ (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 "\ = ((UNION {(p,n,s). (p,n,s) \ ?SS a \ n=0} (\ (p,n,s). {(p,0,Floor s)})) Un (UNION {(p,n,s). (p,n,s) \ ?SS a \ n>0} (\ (p,n,s). {?f(p,n,s) j| j. j\ {0 .. n}})) Un diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Deriv.thy --- 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 \ X = Y \ (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; *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Enum.thy --- 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 = (\_. a\<^sub>1)" +definition [simp]: "Sup = (\_. a\<^sub>1)" +definition [simp]: "bot = a\<^sub>1" +definition [simp]: "top = a\<^sub>1" +definition [simp]: "inf = (\_ _. a\<^sub>1)" +definition [simp]: "sup = (\_ _. 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 - = (\_ _. a\<^sub>1)" +definition [simp]: "uminus = (\_. 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 + = (\_ _. a\<^sub>1)" +definition [simp]: "op * = (\_ _. a\<^sub>1)" +definition [simp]: "op div = (\_ _. a\<^sub>1)" +definition [simp]: "op mod = (\_ _. a\<^sub>1)" +definition [simp]: "abs = (\_. a\<^sub>1)" +definition [simp]: "sgn = (\_. a\<^sub>1)" +definition [simp]: "inverse = (\_. a\<^sub>1)" +definition [simp]: "op / = (\_ _. 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 "\A = (if a\<^sub>1 \ A then a\<^sub>1 else a\<^sub>2)" +definition "\A = (if a\<^sub>2 \ A then a\<^sub>2 else a\<^sub>1)" +definition [simp]: "bot = a\<^sub>1" +definition [simp]: "top = a\<^sub>2" +definition "x \ y = (if x = a\<^sub>1 \ y = a\<^sub>1 then a\<^sub>1 else a\<^sub>2)" +definition "x \ y = (if x = a\<^sub>2 \ y = a\<^sub>2 then a\<^sub>2 else a\<^sub>1)" + +lemma neq_finite_2_a\<^sub>1_iff [simp]: "x \ a\<^sub>1 \ x = a\<^sub>2" +by(cases x) simp_all + +lemma neq_finite_2_a\<^sub>1_iff' [simp]: "a\<^sub>1 \ x \ x = a\<^sub>2" +by(cases x) simp_all + +lemma neq_finite_2_a\<^sub>2_iff [simp]: "x \ a\<^sub>2 \ x = a\<^sub>1" +by(cases x) simp_all + +lemma neq_finite_2_a\<^sub>2_iff' [simp]: "a\<^sub>2 \ x \ x = a\<^sub>1" +by(cases x) simp_all + +instance +proof + fix x :: finite_2 and A + assume "x \ A" + then show "\A \ x" "x \ \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) \ a\<^sub>1 | (a\<^sub>2, a\<^sub>2) \ a\<^sub>1 | _ \ a\<^sub>2)" +definition "uminus = (\x :: finite_2. x)" +definition "op - = (op + :: finite_2 \ _)" +definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \ a\<^sub>2 | _ \ a\<^sub>1)" +definition "inverse = (\x :: finite_2. x)" +definition "op / = (op * :: finite_2 \ _)" +definition "abs = (\x :: finite_2. x)" +definition "op div = (op / :: finite_2 \ _)" +definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \ a\<^sub>2 | _ \ a\<^sub>1)" +definition "sgn = (\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 \" by simp +qed intro_classes + +instantiation finite_3 :: complete_lattice +begin + +definition "\A = (if a\<^sub>1 \ A then a\<^sub>1 else if a\<^sub>2 \ A then a\<^sub>2 else a\<^sub>3)" +definition "\A = (if a\<^sub>3 \ A then a\<^sub>3 else if a\<^sub>2 \ 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 \ _)" +definition [simp]: "sup = (max :: finite_3 \ _)" + +instance +proof + fix x :: finite_3 and A + assume "x \ A" + then show "\A \ x" "x \ \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 "\x. x \ A \ z \ x" + then show "z \ \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 *: "\x. x \ A \ x \ z" + show "\A \ 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 \ \B = (\b\B. a \ b)" + proof(cases a "\B" rule: finite_3.exhaust[case_product finite_3.exhaust]) + case a\<^sub>2_a\<^sub>3 + then have "\x. x \ B \ 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 \ \B = (\b\B. a \ b)" + by(cases a "\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) \ a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \ a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \ a\<^sub>1 + | (a\<^sub>1, a\<^sub>2) \ a\<^sub>2 | (a\<^sub>2, a\<^sub>1) \ a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \ a\<^sub>2 + | _ \ a\<^sub>3)" +definition "- x = (case x of a\<^sub>1 \ a\<^sub>1 | a\<^sub>2 \ a\<^sub>3 | a\<^sub>3 \ a\<^sub>2)" +definition "x - y = x + (- y :: finite_3)" +definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \ a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \ a\<^sub>2 | (a\<^sub>2, a\<^sub>3) \ a\<^sub>3 | (a\<^sub>3, a\<^sub>2) \ a\<^sub>3 | _ \ a\<^sub>1)" +definition "inverse = (\x :: finite_3. x)" +definition "x / y = x * inverse (y :: finite_3)" +definition "abs = (\x :: finite_3. x)" +definition "op div = (op / :: finite_3 \ _)" +definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \ a\<^sub>2 | (a\<^sub>3, a\<^sub>1) \ a\<^sub>3 | _ \ a\<^sub>1)" +definition "sgn = (\x. case x of a\<^sub>1 \ a\<^sub>1 | _ \ 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 \ (case (x, y) of + (a\<^sub>1, a\<^sub>1) \ False | (a\<^sub>1, _) \ True + | (a\<^sub>2, a\<^sub>4) \ True + | (a\<^sub>3, a\<^sub>4) \ True | _ \ False)" + +definition + "x \ y \ (case (x, y) of + (a\<^sub>1, _) \ True + | (a\<^sub>2, a\<^sub>2) \ True | (a\<^sub>2, a\<^sub>4) \ True + | (a\<^sub>3, a\<^sub>3) \ True | (a\<^sub>3, a\<^sub>4) \ True + | (a\<^sub>4, a\<^sub>4) \ True | _ \ False)" + +definition + "\A = (if a\<^sub>1 \ A \ a\<^sub>2 \ A \ a\<^sub>3 \ A then a\<^sub>1 else if a\<^sub>2 \ A then a\<^sub>2 else if a\<^sub>3 \ A then a\<^sub>3 else a\<^sub>4)" +definition + "\A = (if a\<^sub>4 \ A \ a\<^sub>2 \ A \ a\<^sub>3 \ A then a\<^sub>4 else if a\<^sub>2 \ A then a\<^sub>2 else if a\<^sub>3 \ A then a\<^sub>3 else a\<^sub>1)" +definition [simp]: "bot = a\<^sub>1" +definition [simp]: "top = a\<^sub>4" +definition + "x \ y = (case (x, y) of + (a\<^sub>1, _) \ a\<^sub>1 | (_, a\<^sub>1) \ a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \ a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \ a\<^sub>1 + | (a\<^sub>2, _) \ a\<^sub>2 | (_, a\<^sub>2) \ a\<^sub>2 + | (a\<^sub>3, _) \ a\<^sub>3 | (_, a\<^sub>3) \ a\<^sub>3 + | _ \ a\<^sub>4)" +definition + "x \ y = (case (x, y) of + (a\<^sub>4, _) \ a\<^sub>4 | (_, a\<^sub>4) \ a\<^sub>4 | (a\<^sub>2, a\<^sub>3) \ a\<^sub>4 | (a\<^sub>3, a\<^sub>2) \ a\<^sub>4 + | (a\<^sub>2, _) \ a\<^sub>2 | (_, a\<^sub>2) \ a\<^sub>2 + | (a\<^sub>3, _) \ a\<^sub>3 | (_, a\<^sub>3) \ a\<^sub>3 + | _ \ a\<^sub>1)" + +instance +proof + fix A and z :: finite_4 + assume *: "\x. x \ A \ x \ z" + show "\A \ 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 *: "\x. x \ A \ z \ x" + show "z \ \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 \ \B = (\b\B. a \ b)" + by(cases a "\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 \ \B = (\b\B. a \ b)" + by(cases a "\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 \ a\<^sub>4 | a\<^sub>2 \ a\<^sub>3 | a\<^sub>3 \ a\<^sub>2 | a\<^sub>4 \ a\<^sub>1)" +definition "x - y = x \ - (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 \ (case (x, y) of + (a\<^sub>1, a\<^sub>1) \ False | (a\<^sub>1, _) \ True + | (a\<^sub>2, a\<^sub>3) \ True | (a\<^sub>2, a\<^sub>5) \ True + | (a\<^sub>3, a\<^sub>5) \ True + | (a\<^sub>4, a\<^sub>5) \ True | _ \ False)" + +definition + "x \ y \ (case (x, y) of + (a\<^sub>1, _) \ True + | (a\<^sub>2, a\<^sub>2) \ True | (a\<^sub>2, a\<^sub>3) \ True | (a\<^sub>2, a\<^sub>5) \ True + | (a\<^sub>3, a\<^sub>3) \ True | (a\<^sub>3, a\<^sub>5) \ True + | (a\<^sub>4, a\<^sub>4) \ True | (a\<^sub>4, a\<^sub>5) \ True + | (a\<^sub>5, a\<^sub>5) \ True | _ \ False)" + +definition + "\A = + (if a\<^sub>1 \ A \ a\<^sub>4 \ A \ (a\<^sub>2 \ A \ a\<^sub>3 \ A) then a\<^sub>1 + else if a\<^sub>2 \ A then a\<^sub>2 + else if a\<^sub>3 \ A then a\<^sub>3 + else if a\<^sub>4 \ A then a\<^sub>4 + else a\<^sub>5)" +definition + "\A = + (if a\<^sub>5 \ A \ a\<^sub>4 \ A \ (a\<^sub>2 \ A \ a\<^sub>3 \ A) then a\<^sub>5 + else if a\<^sub>3 \ A then a\<^sub>3 + else if a\<^sub>2 \ A then a\<^sub>2 + else if a\<^sub>4 \ A then a\<^sub>4 + else a\<^sub>1)" +definition [simp]: "bot = a\<^sub>1" +definition [simp]: "top = a\<^sub>5" +definition + "x \ y = (case (x, y) of + (a\<^sub>1, _) \ a\<^sub>1 | (_, a\<^sub>1) \ a\<^sub>1 | (a\<^sub>2, a\<^sub>4) \ a\<^sub>1 | (a\<^sub>4, a\<^sub>2) \ a\<^sub>1 | (a\<^sub>3, a\<^sub>4) \ a\<^sub>1 | (a\<^sub>4, a\<^sub>3) \ a\<^sub>1 + | (a\<^sub>2, _) \ a\<^sub>2 | (_, a\<^sub>2) \ a\<^sub>2 + | (a\<^sub>3, _) \ a\<^sub>3 | (_, a\<^sub>3) \ a\<^sub>3 + | (a\<^sub>4, _) \ a\<^sub>4 | (_, a\<^sub>4) \ a\<^sub>4 + | _ \ a\<^sub>5)" +definition + "x \ y = (case (x, y) of + (a\<^sub>5, _) \ a\<^sub>5 | (_, a\<^sub>5) \ a\<^sub>5 | (a\<^sub>2, a\<^sub>4) \ a\<^sub>5 | (a\<^sub>4, a\<^sub>2) \ a\<^sub>5 | (a\<^sub>3, a\<^sub>4) \ a\<^sub>5 | (a\<^sub>4, a\<^sub>3) \ a\<^sub>5 + | (a\<^sub>3, _) \ a\<^sub>3 | (_, a\<^sub>3) \ a\<^sub>3 + | (a\<^sub>2, _) \ a\<^sub>2 | (_, a\<^sub>2) \ a\<^sub>2 + | (a\<^sub>4, _) \ a\<^sub>4 | (_, a\<^sub>4) \ a\<^sub>4 + | _ \ a\<^sub>1)" + +instance +proof intro_classes + fix A and z :: finite_5 + assume *: "\x. x \ A \ z \ x" + show "z \ \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 *: "\x. x \ A \ x \ z" + show "\A \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Fields.thy --- 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 + diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Fun_Def.thy --- 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 \ nat) \ 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) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Fun_Def_Base.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Groebner_Basis.thy --- 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 @@ "\ P \ (P \ 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 = {* diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Groups.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOL.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Cfun.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Cont.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Domain.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Domain_Aux.thy --- 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" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Tools/Domain/domain_isomorphism.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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML --- 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 **************************) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/HOLCF/Tools/fixrec.ML --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Imperative_HOL/Heap_Monad.thy --- 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 @@ "(\h. execute f h = execute g h) \ 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 \ 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" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Imperative_HOL/ex/Linked_Lists.thy --- 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 \ set (p#refs)" by (auto elim!: effect_refE intro!: Ref.noteq_I) from refs_of_p refs_of_q q_is_new have a3: "\qrs prs. refs_of' h2 q qrs \ refs_of' h2 p prs \ set prs \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Lattices_Big.thy --- 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" "\a\A. \b\B. a \ b" "\b\B. \a\A. b \ a" + shows "Max A = Max B" +proof cases + assume "A = {}" thus ?thesis using assms by simp +next + assume "A \ {}" thus ?thesis using assms + by(blast intro: antisym Max_in Max_ge_iff[THEN iffD2]) +qed + lemma Min_antimono: assumes "M \ N" and "M \ {}" and "finite N" shows "Min N \ Min M" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Extended_Real.thy --- 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 \ a = b" by (cases rule: ereal2_cases[of a b]) simp_all -function of_ereal :: "ereal \ real" where - "of_ereal (ereal r) = r" -| "of_ereal \ = 0" -| "of_ereal (-\) = 0" +instantiation ereal :: real_of +begin + +function real_ereal :: "ereal \ real" where + "real_ereal (ereal r) = r" +| "real_ereal \ = 0" +| "real_ereal (-\) = 0" by (auto intro: ereal_cases) termination by default (rule wf_empty) -defs (overloaded) - real_of_ereal_def [code_unfold]: "real \ of_ereal" +instance .. +end lemma real_of_ereal[simp]: "real (- x :: ereal) = - (real x)" - "real (ereal r) = r" - "real (\::ereal) = 0" - by (cases x) (simp_all add: real_of_ereal_def) + by (cases x) simp_all lemma range_ereal[simp]: "range ereal = UNIV - {\, -\}" 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]: "\0\ = (0::ereal)" unfolding zero_ereal_def abs_ereal.simps by simp diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Float.thy --- 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 \ real" where real_of_float_def[code_unfold]: "real \ real_of_float" +instance .. +end + lemma type_definition_float': "type_definition real float_of float" using type_definition_float unfolding real_of_float_def . diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Lattice_Constructions.thy --- /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 \ y \ (case x of Bot \ True | Value x \ (case y of Bot \ False | Value y \ x \ y))" + +definition less_bot where + "x < y \ (case y of Bot \ False | Value y \ (case x of Bot \ True | Value x \ x < y))" + +lemma less_eq_bot_Bot [simp]: "Bot \ x" + by (simp add: less_eq_bot_def) + +lemma less_eq_bot_Bot_code [code]: "Bot \ x \ True" + by simp + +lemma less_eq_bot_Bot_is_Bot: "x \ Bot \ x = Bot" + by (cases x) (simp_all add: less_eq_bot_def) + +lemma less_eq_bot_Value_Bot [simp, code]: "Value x \ Bot \ False" + by (simp add: less_eq_bot_def) + +lemma less_eq_bot_Value [simp, code]: "Value x \ Value y \ x \ y" + by (simp add: less_eq_bot_def) + +lemma less_bot_Bot [simp, code]: "x < Bot \ False" + by (simp add: less_bot_def) + +lemma less_bot_Bot_is_Value: "Bot < x \ \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 \ True" + by simp + +lemma less_bot_Value [simp, code]: "Value x < Value y \ 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 \ y \ (case y of Top \ True | Value y \ (case x of Top \ False | Value x \ x \ y))" + +definition less_top where + "x < y \ (case x of Top \ False | Value x \ (case y of Top \ True | Value y \ 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 \ Top \ True" + by simp + +lemma less_eq_top_is_Top: "Top \ x \ x = Top" + by (cases x) (simp_all add: less_eq_top_def) + +lemma less_eq_top_Top_Value [simp, code]: "Top \ Value x \ False" + by (simp add: less_eq_top_def) + +lemma less_eq_top_Value_Value [simp, code]: "Value x \ Value y \ x \ y" + by (simp add: less_eq_top_def) + +lemma less_top_Top [simp, code]: "Top < x \ False" + by (simp add: less_top_def) + +lemma less_top_Top_is_Value: "x < Top \ \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 \ True" + by simp + +lemma less_top_Value [simp, code]: "Value x < Value y \ 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 \ 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 => \ (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 = {} \ A = {Bot}) then Bot else (if (\ 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 = {} \ A = {Top}) then Top else (if (\ 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 \ 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: "\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} \ a1 \ 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 \ 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: "\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} \ a1 \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Library.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Multiset.thy --- 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 #\ N) = Multiset.filter P M #\ Multiset.filter P N" by (rule multiset_eqI) simp +lemma multiset_filter_subset[simp]: "Multiset.filter f M \ M" + unfolding less_eq_multiset.rep_eq by auto + +lemma multiset_filter_mono: assumes "A \ B" + shows "Multiset.filter f A \ 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 \ 'a multiset \ bool \ '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 \ B" + shows "mcard A \ 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) \ 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 \ nat" assumes "finite A" -shows "setsum f A > 0 \ (\ a \ A. f a > 0)" -(is "?L \ ?R") -proof- - have "?L \ \ setsum f A = 0" by fast - also have "... \ (\ a \ A. f a \ 0)" using assms by simp - also have "... \ ?R" by simp - finally show ?thesis . -qed - -lift_definition mmap :: "('a \ 'b) \ 'a multiset \ 'b multiset" is - "\h f b. setsum f {a. h a = b \ f a > 0} :: nat" -unfolding multiset_def proof safe - fix h :: "'a \ 'b" and f :: "'a \ nat" - assume fin: "finite {a. 0 < f a}" (is "finite ?A") - show "finite {b. 0 < setsum f {a. h a = b \ 0 < f a}}" - (is "finite {b. 0 < setsum f (?As b)}") - proof- let ?B = "{b. 0 < setsum f (?As b)}" - have "\ b. finite (?As b)" using fin by simp - hence B: "?B = {b. ?As b \ {}}" by (auto simp add: setsum_gt_0_iff) - hence "?B \ 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 \ aa \# 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' \ a \# f}" (is "0 < setsum (count f) ?A'") -and 2: "{a. h a = b \ a \# f} = {a. h a = b' \ a \# f}" (is "?A = ?A'") -shows "b = b'" -using assms by (auto simp add: setsum_gt_0_iff) - -lemma mmap_comp: -fixes h1 :: "'a \ 'b" and h2 :: "'b \ '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 \ a \# f}" - let ?As = "\ b. {a. h1 a = b \ a \# f}" - let ?B = "{b. h2 b = c \ 0 < setsum (count f) (?As b)}" - have 0: "{?As b | b. b \ ?B} = ?As ` ?B" by auto - have "\ b. finite (?As b)" by transfer (simp add: multiset_def) - hence "?B = {b. h2 b = c \ ?As b \ {}}" by (auto simp add: setsum_gt_0_iff) - hence A: "?A = \ {?As b | b. b \ ?B}" by auto - have "setsum (count f) ?A = setsum (setsum (count f)) {?As b | b. b \ ?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 (\ b. setsum (count f) (?As b)) ?B" unfolding comp_def .. - finally have "setsum (count f) ?A = setsum (\ b. setsum (count f) (?As b)) ?B" . - thus "count (mmap (h2 \ h1) f) c = count ((mmap h2 \ mmap h1) f) c" - by transfer (unfold comp_apply, blast) -qed - -lemma mmap_cong: -assumes "\a. a \# M \ 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 =) (\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 \ A} = {M. set_of M \ A}" -proof safe - fix M assume M: "set_of M \ A" - obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto - hence "set as \ A" using M by auto - thus "M \ multiset_of ` {as. set as \ A}" using eq by auto +definition rel_mset where + "rel_mset R X Y \ (\xs ys. multiset_of xs = X \ multiset_of ys = Y \ list_all2 R xs ys)" + +lemma multiset_of_zip_take_Cons_drop_twice: + assumes "length xs = length ys" "j \ 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 "\x xa xb. \set xa \ A; xb \ set_of (multiset_of xa)\ \ xb \ A" - by (erule set_mp) (unfold set_of_multiset_of) -qed - -lemma card_of_set_of: -"(card_of {M. set_of M \ A}, card_of {as. set as \ A}) \ ordLeq" -apply(rule surj_imp_ordLeq[of _ multiset_of]) using multiset_of_surj by auto - -lemma nat_sum_induct: -assumes "\n1 n2. (\ m1 m2. m1 + m2 < n1 + n2 \ phi m1 m2) \ phi n1 n2" -shows "phi (n1::nat) (n2::nat)" -proof- - let ?chi = "\ n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)" - have "?chi (n1,n2)" - apply(induct rule: measure_induct[of "\ n1n2. fst n1n2 + snd n1n2" ?chi]) - using assms by (metis fstI sndI) - thus ?thesis by simp -qed - -lemma matrix_count: -fixes ct1 ct2 :: "nat \ nat" -assumes "setsum ct1 {.. ct. (\ i1 \ n1. setsum (\ i2. ct i1 i2) {.. - (\ i2 \ n2. setsum (\ i1. ct i1 i2) {.. ct1 ct2 :: nat \ nat. - setsum ct1 {.. ?phi ct1 ct2 n1 n2" - proof(induct rule: nat_sum_induct[of -"\ n1 n2. \ ct1 ct2 :: nat \ nat. - setsum ct1 {.. ?phi ct1 ct2 n1 n2"], - clarify) - fix n1 n2 :: nat and ct1 ct2 :: "nat \ nat" - assume IH: "\ m1 m2. m1 + m2 < n1 + n2 \ - \ dt1 dt2 :: nat \ nat. - setsum dt1 {.. ?phi dt1 dt2 m1 m2" - and ss: "setsum ct1 {.. ct2 n2") - case True - def dt2 \ "\ i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2" - have "setsum ct1 {.. i1. i1 \ m1 \ setsum (\ i2. dt i1 i2) {.. i2. i2 \ n2 \ setsum (\ i1. dt i1 i2) {.. "\ i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1" - have "setsum dt1 {.. i1. i1 \ n1 \ setsum (\ i2. dt i1 i2) {.. i2. i2 \ m2 \ setsum (\ i1. dt i1 i2) {.. - \ b1 b1' b2 b2'. {b1,b1'} \ B1 \ {b2,b2'} \ B2 \ u b1 b2 = u b1' b2' - \ b1 = b1' \ b2 = b2'" - -lemma matrix_setsum_finite: -assumes B1: "B1 \ {}" "finite B1" and B2: "B2 \ {}" "finite B2" and u: "inj2 u B1 B2" -and ss: "setsum N1 B1 = setsum N2 B2" -shows "\ M :: 'a \ nat. - (\ b1 \ B1. setsum (\ b2. M (u b1 b2)) B2 = N1 b1) \ - (\ b2 \ B2. setsum (\ 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 {.. "inv_into {.. i1. i1 < Suc n1 \ f1 (e1 i1) = i1" - and e1f1[simp]: "\ b1. b1 \ B1 \ 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 {.. "inv_into {.. i2. i2 < Suc n2 \ f2 (e2 i2) = i2" - and e2f2[simp]: "\ b2. b2 \ B2 \ 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 {.. i1. i1 \ n1 \ setsum (\ i2. ct i1 i2) {.. i2. i2 \ n2 \ setsum (\ i1. ct i1 i2) {.. "{u b1 b2 | b1 b2. b1 \ B1 \ b2 \ B2}" - have "\ a \ A. \ b1b2 \ B1 <*> B2. u (fst b1b2) (snd b1b2) = a" - unfolding A_def Ball_def mem_Collect_eq by auto - then obtain h1h2 where h12: - "\a. a \ A \ u (fst (h1h2 a)) (snd (h1h2 a)) = a \ h1h2 a \ B1 <*> B2" by metis - def h1 \ "fst o h1h2" def h2 \ "snd o h1h2" - have h12[simp]: "\a. a \ A \ u (h1 a) (h2 a) = a" - "\ a. a \ A \ h1 a \ B1" "\ a. a \ A \ h2 a \ B2" - using h12 unfolding h1_def h2_def by force+ - {fix b1 b2 assume b1: "b1 \ B1" and b2: "b2 \ B2" - hence inA: "u b1 b2 \ 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) \ B1" "h2 (u b1 b2) \ B2" using inA by auto - ultimately have "h1 (u b1 b2) = b1 \ h2 (u b1 b2) = b2" - using u b1 b2 unfolding inj2_def by fastforce - } - hence h1[simp]: "\ b1 b2. \b1 \ B1; b2 \ B2\ \ h1 (u b1 b2) = b1" and - h2[simp]: "\ b1 b2. \b1 \ B1; b2 \ B2\ \ h2 (u b1 b2) = b2" by auto - def M \ "\ a. ct (f1 (h1 a)) (f2 (h2 a))" - show ?thesis - apply(rule exI[of _ M]) proof safe - fix b1 assume b1: "b1 \ B1" - hence f1b1: "f1 b1 \ n1" using f1 unfolding bij_betw_def - by (metis image_eqI lessThan_iff less_Suc_eq_le) - have "(\b2\B2. M (u b1 b2)) = (\i2b2\B2. M (u b1 b2)) = N1 b1" . - next - fix b2 assume b2: "b2 \ B2" - hence f2b2: "f2 b2 \ n2" using f2 unfolding bij_betw_def - by (metis image_eqI lessThan_iff less_Suc_eq_le) - have "(\b1\B1. M (u b1 b2)) = (\i1b1\B1. M (u b1 b2)) = N2 b2" . - qed -qed - -lemma supp_vimage_mmap: "set_of M \ f -` (set_of (mmap f M))" - by transfer (auto simp: multiset_def setsum_gt_0_iff) - -lemma mmap_ge_0: "b \# mmap f M \ (\a. a \# M \ 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 \ B1 \ b2 \ B2}" (is "finite ?A") -proof- - have A: "?A = (\ 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 \ 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 \ - (\ b1 b2. b1 \ B1 \ b2 \ B2 \ f1 b1 = f2 b2 \ (\ a \ A. p1 a = b1 \ p2 a = b2))" - -(* Weak pseudo-pullbacks *) -definition wppull where -"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \ - (\ b1 b2. b1 \ B1 \ b2 \ B2 \ f1 b1 = f2 b2 \ - (\ a \ A. e1 (p1 a) = e1 b1 \ e2 (p2 a) = e2 b2))" - - -(* The pullback of sets *) -definition thePull where -"thePull B1 B2 f1 f2 = {(b1,b2). b1 \ B1 \ b2 \ B2 \ 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 -"\ j. \ a' \ thePull B1 B2 f1 f2. - j a' \ A \ - e1 (p1 (j a')) = e1 (fst a') \ e2 (p2 (j a')) = e2 (snd a')" -(is "\ j. \ a' \ ?A'. ?phi a' (j a')") -proof(rule bchoice[of ?A' ?phi], default) - fix a' assume a': "a' \ ?A'" - hence "fst a' \ B1" unfolding thePull_def by auto - moreover - from a' have "snd a' \ 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 "\ 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: "\ a' \ A'. j a' \ A \ e1 (p1 (j a')) = e1 (p1' a') \ 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 \ B1" and b2: "b2 \ B2" and f: "f1 b1 = f2 b2" - then obtain a' where a': "a' \ A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'" - using wp unfolding wpull_def by blast - show "\a\A. e1 (p1 a) = e1 b1 \ 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 "\ys'. length ys' = length xs' \ 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 "\j. \j < length xs'; xs' ! j = x\ \ ?thesis" + moreover have "\k m n. (m\nat) + n < m + k \ \ n < k" by linarith + moreover have "\n a as. n - n < length (a # as) \ n < n" + by (metis Nat.add_diff_inverse diff_add_inverse2 impossible_Cons le_add1 + less_diff_conv not_add_less2) + moreover have "\ 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 \ "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' \ "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 \ 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 \ A} - {N1. set_of N1 \ B1} {N2. set_of N2 \ 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 \ B1" - and N2[simp]: "set_of N2 \ B2" - def P \ "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 \ "\ c. {b1 \ set_of N1. f1 b1 = c}" - have set1[simp]: "\ c b1. b1 \ set1 c \ f1 b1 = c" unfolding set1_def by auto - have fin_set1: "\ c. c \ set_of P \ finite (set1 c)" - using N1(1) unfolding set1_def multiset_def by auto - have set1_NE: "\ c. c \ set_of P \ set1 c \ {}" - unfolding set1_def set_of_def P mmap_ge_0 by auto - have supp_N1_set1: "set_of N1 = (\ c \ set_of P. set1 c)" - using supp_vimage_mmap[of N1 f1] unfolding set1_def P1 by auto - hence set1_inclN1: "\c. c \ set_of P \ set1 c \ set_of N1" by auto - hence set1_incl: "\ c. c \ set_of P \ set1 c \ B1" using N1 by blast - have set1_disj: "\ c c'. c \ c' \ set1 c \ set1 c' = {}" - unfolding set1_def by auto - have setsum_set1: "\ c. setsum (count N1) (set1 c) = count P c" - unfolding P1 set1_def by transfer (auto intro: setsum.cong) - - def set2 \ "\ c. {b2 \ set_of N2. f2 b2 = c}" - have set2[simp]: "\ c b2. b2 \ set2 c \ f2 b2 = c" unfolding set2_def by auto - have fin_set2: "\ c. c \ set_of P \ finite (set2 c)" - using N2(1) unfolding set2_def multiset_def by auto - have set2_NE: "\ c. c \ set_of P \ set2 c \ {}" - unfolding set2_def P2 mmap_ge_0 set_of_def by auto - have supp_N2_set2: "set_of N2 = (\ c \ set_of P. set2 c)" - using supp_vimage_mmap[of N2 f2] unfolding set2_def P2 by auto - hence set2_inclN2: "\c. c \ set_of P \ set2 c \ set_of N2" by auto - hence set2_incl: "\ c. c \ set_of P \ set2 c \ B2" using N2 by blast - have set2_disj: "\ c c'. c \ c' \ set2 c \ set2 c' = {}" - unfolding set2_def by auto - have setsum_set2: "\ c. setsum (count N2) (set2 c) = count P c" - unfolding P2 set2_def by transfer (auto intro: setsum.cong) - - have ss: "\ c. c \ set_of P \ setsum (count N1) (set1 c) = setsum (count N2) (set2 c)" - unfolding setsum_set1 setsum_set2 .. - have "\ c \ set_of P. \ b1b2 \ (set1 c) \ (set2 c). - \ a \ A. p1 a = fst b1b2 \ 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: - "\ c \ set_of P. \ b1b2 \ (set1 c) \ (set2 c). - uu c b1b2 \ A \ p1 (uu c b1b2) = fst b1b2 \ p2 (uu c b1b2) = snd b1b2" by metis - def u \ "\ c b1 b2. uu c (b1,b2)" - have u[simp]: - "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ \ u c b1 b2 \ A" - "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ \ p1 (u c b1 b2) = b1" - "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ \ p2 (u c b1 b2) = b2" - using uu unfolding u_def by auto - {fix c assume c: "c \ set_of P" - have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify - fix b1 b1' b2 b2' - assume "{b1, b1'} \ set1 c" "{b2, b2'} \ set2 c" and 0: "u c b1 b2 = u c b1' b2'" - hence "p1 (u c b1 b2) = b1 \ p2 (u c b1 b2) = b2 \ - p1 (u c b1' b2') = b1' \ p2 (u c b1' b2') = b2'" - using u(2)[OF c] u(3)[OF c] by simp metis - thus "b1 = b1' \ b2 = b2'" using 0 by auto - qed - } note inj = this - def sset \ "\ c. {u c b1 b2 | b1 b2. b1 \ set1 c \ b2 \ set2 c}" - have fin_sset[simp]: "\ c. c \ set_of P \ finite (sset c)" unfolding sset_def - using fin_set1 fin_set2 finite_twosets by blast - have sset_A: "\ c. c \ set_of P \ sset c \ A" unfolding sset_def by auto - {fix c a assume c: "c \ set_of P" and ac: "a \ sset c" - then obtain b1 b2 where b1: "b1 \ set1 c" and b2: "b2 \ set2 c" - and a: "a = u c b1 b2" unfolding sset_def by auto - have "p1 a \ set1 c" and p2a: "p2 a \ 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 \ set_of P" and ac: "a \ sset c" - hence "p1 a \ set1 c" unfolding sset_def by auto - }note p1[simp] = this - {fix c a assume c: "c \ set_of P" and ac: "a \ sset c" - hence "p2 a \ set2 c" unfolding sset_def by auto - }note p2[simp] = this - - {fix c assume c: "c \ set_of P" - hence "\ M. (\ b1 \ set1 c. setsum (\ b2. M (u c b1 b2)) (set2 c) = count N1 b1) \ - (\ b2 \ set2 c. setsum (\ 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: "\ c b1. \c \ set_of P; b1 \ set1 c\ \ - setsum (\ b2. Ms c (u c b1 b2)) (set2 c) = count N1 b1" and - ss2: "\ c b2. \c \ set_of P; b2 \ set2 c\ \ - setsum (\ b1. Ms c (u c b1 b2)) (set1 c) = count N2 b2" - by metis - def SET \ "\ c \ 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 \ A" unfolding SET_def using sset_A by blast - have u_SET[simp]: "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ \ u c b1 b2 \ SET" - unfolding SET_def sset_def by blast - {fix c a assume c: "c \ set_of P" and a: "a \ SET" and p1a: "p1 a \ set1 c" - then obtain c' where c': "c' \ set_of P" and ac': "a \ sset c'" - unfolding SET_def by auto - hence "p1 a \ set1 c'" unfolding sset_def by auto - hence eq: "c = c'" using p1a c c' set1_disj by auto - hence "a \ sset c" using ac' by simp - } note p1_rev = this - {fix c a assume c: "c \ set_of P" and a: "a \ SET" and p2a: "p2 a \ set2 c" - then obtain c' where c': "c' \ set_of P" and ac': "a \ sset c'" - unfolding SET_def by auto - hence "p2 a \ set2 c'" unfolding sset_def by auto - hence eq: "c = c'" using p2a c c' set2_disj by auto - hence "a \ sset c" using ac' by simp - } note p2_rev = this - - have "\ a \ SET. \ c \ set_of P. a \ sset c" unfolding SET_def by auto - then obtain h where h: "\ a \ SET. h a \ set_of P \ a \ sset (h a)" by metis - have h_u[simp]: "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ - \ h (u c b1 b2) = c" - by (metis h p2 set2 u(3) u_SET) - have h_u1: "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ - \ h (u c b1 b2) = f1 b1" - using h unfolding sset_def by auto - have h_u2: "\ c b1 b2. \c \ set_of P; b1 \ set1 c; b2 \ set2 c\ - \ h (u c b1 b2) = f2 b2" - using h unfolding sset_def by auto - def M \ - "Abs_multiset (\ a. if a \ SET \ p1 a \ set_of N1 \ p2 a \ set_of N2 then Ms (h a) a else 0)" - have "(\ a. if a \ SET \ p1 a \ set_of N1 \ p2 a \ set_of N2 then Ms (h a) a else 0) \ multiset" - unfolding multiset_def by auto - hence [transfer_rule]: "pcr_multiset op = (\ a. if a \ SET \ p1 a \ set_of N1 \ p2 a \ 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 \ SET" "set_of M \ p1 -` (set_of N1)" "set_of M \ p2 -` set_of N2" - by (transfer, auto split: split_if_asm)+ - show "\M. set_of M \ A \ mmap p1 M = N1 \ mmap p2 M = N2" - proof(rule exI[of _ M], safe) - fix a assume *: "a \ set_of M" - from SET_A show "a \ A" - proof (cases "a \ 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 \ a \# M}" - have "setsum (count M) ?K = count N1 b1" - proof(cases "b1 \ set_of N1") - case False - hence "?K = {}" using sM(2) by auto - thus ?thesis using False by auto - next - case True - def c \ "f1 b1" - have c: "c \ set_of P" and b1: "b1 \ 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 \ a \ SET}" - by transfer (force intro: setsum.mono_neutral_cong_left split: split_if_asm) - also have "... = setsum (count M) ((\ b2. u c b1 b2) ` (set2 c))" - apply(rule setsum.cong) using c b1 proof safe - fix a assume p1a: "p1 a \ set1 c" and "c \ set_of P" and "a \ SET" - hence ac: "a \ sset c" using p1_rev by auto - hence "a = u c (p1 a) (p2 a)" using c by auto - moreover have "p2 a \ set2 c" using ac c by auto - ultimately show "a \ u c (p1 a) ` set2 c" by auto - qed auto - also have "... = setsum (\ 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 \ a \# M}" - have "setsum (count M) ?K = count N2 b2" - proof(cases "b2 \ set_of N2") - case False - hence "?K = {}" using sM(3) by auto - thus ?thesis using False by auto - next - case True - def c \ "f2 b2" - have c: "c \ set_of P" and b2: "b2 \ 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 \ a \ SET}" - by transfer (force intro: setsum.mono_neutral_cong_left split: split_if_asm) - also have "... = setsum (count M) ((\ b1. u c b1 b2) ` (set1 c))" - apply(rule setsum.cong) using c b2 proof safe - fix a assume p2a: "p2 a \ set2 c" and "c \ set_of P" and "a \ SET" - hence ac: "a \ sset c" using p2_rev by auto - hence "a = u c (p1 a) (p2 a)" using c by auto - moreover have "p1 a \ set1 c" using ac c by auto - ultimately show "a \ (\x. u c x (p2 a)) ` set1 c" by auto - qed auto - also have "... = setsum (count M o (\ 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 (\ 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 "\ys'. list_all2 R xs' ys' \ 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) \ 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 \ A} {N1. set_of N1 \ B1} {N2. set_of N2 \ B2} - (mmap f1) (mmap f2) (mmap e1) (mmap e2) (mmap p1) (mmap p2)" -proof - - from assms obtain j where j: "\a'\thePull B1 B2 f1 f2. - j a' \ A \ e1 (p1 (j a')) = e1 (fst a') \ 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: "\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]: "\R a b; rel_multiset' R M N\ \ rel_multiset' R (M + {#a#}) (N + {#b#})" - -lemma map_multiset_Zero_iff[simp]: "mmap f M = {#} \ 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 "\f g. image_mset (g \ f) = image_mset g \ image_mset f" + unfolding comp_def by (rule ext) (simp add: image_mset.compositionality comp_def) +next + fix X :: "'a multiset" + show "\f g. (\z. z \ set_of X \ f z = g z) \ 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 "\f. set_of \ image_mset f = op ` f \ 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 "\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 "\R S. rel_mset R OO rel_mset S \ 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 "\R. rel_mset R = + (BNF_Def.Grp {x. set_of x \ {(x, y). R x y}} (image_mset fst))\\ OO + BNF_Def.Grp {x. set_of x \ {(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 "\z. z \ set_of {#} \ False" + by auto +qed + +inductive rel_mset' where + Zero[intro]: "rel_mset' R {#} {#}" +| Plus[intro]: "\R a b; rel_mset' R M N\ \ 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 \ nat" - assume "M1 \ multiset" "M2 \ multiset" - hence "setsum M1 {a. f a = x \ 0 < M1 a} = setsum M1 {a. f a = x \ 0 < M1 a + M2 a}" - "setsum M2 {a. f a = x \ 0 < M2 a} = setsum M2 {a. f a = x \ 0 < M1 a + M2 a}" - by (auto simp: multiset_def intro!: setsum.mono_neutral_cong_left) - then show "(\a | f a = x \ 0 < M1 a + M2 a. M1 a + M2 a) = - setsum M1 {a. f a = x \ 0 < M1 a} + - setsum M2 {a. f a = x \ 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 \ {(x, y). R x y}" - hence "\ya. mmap fst y + {#a#} = mmap fst ya \ - mmap snd y + {#b#} = mmap snd ya \ + hence "\ya. image_mset fst y + {#a#} = image_mset fst ya \ + image_mset snd y + {#b#} = image_mset snd ya \ set_of ya \ {(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 \ 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 \ "\ b. {a. f a = b \ a \# M}" - let ?B = "{b. 0 < setsum (count M) (A b)}" - have "{b. \a. f a = b \ a \# M} \ f ` {a. a \# M}" by auto - moreover have "finite (f ` {a. a \# M})" apply(rule finite_imageI) - using finite_Collect_mem . - ultimately have fin: "finite {b. \a. f a = b \ a \# 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: "\ b. 0 < setsum (count M) (A b) \ (\ a \ 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. \ a \ A b. count M a > 0}" by auto - - have "setsum (\ x. setsum (count M) (A x)) ?B = setsum (setsum (count M) o A) ?B" - unfolding comp_def .. - also have "... = (\x\ A ` ?B. setsum (count M) x)" - unfolding setsum.reindex [OF i, symmetric] .. - also have "... = setsum (count M) (\x\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 \# M}" unfolding AB unfolding A_def by auto - finally have "setsum (\ x. setsum (count M) (A x)) ?B = - setsum (count M) {a. a \# 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 \ 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 "\ N1. N = N1 + {#f a#} \ mmap f M = N1" +assumes "image_mset f (M + {#a#}) = N" +shows "\N1. N = N1 + {#f a#} \ image_mset f M = N1" proof- have "f a \# 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 "\ M1 a. M = M1 + {#a#} \ f a = b \ mmap f M1 = N" +assumes "image_mset f M = N + {#b#}" +shows "\M1 a. M = M1 + {#a#} \ f a = b \ image_mset f M1 = N" proof- obtain a where a: "a \# 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 "\ N1 b. N = N1 + {#b#} \ R a b \ rel_multiset R M N1" +assumes "rel_mset R (M + {#a#}) N" +shows "\N1 b. N = N1 + {#b#} \ R a b \ 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 \ {(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 \ {(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 "\ M1 a. M = M1 + {#a#} \ R a b \ rel_multiset R M1 N" +assumes "rel_mset R M (N + {#b#})" +shows "\M1 a. M = M1 + {#a#} \ R a b \ 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 \ {(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 \ {(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 \ mmap f = size_multiset (g \ f)" -apply (rule ext) -apply (unfold o_apply) -apply (induct_tac x) -apply auto -done +lemma multiset_size_o_map: "size_multiset g \ image_mset f = size_multiset (g \ f)" + unfolding o_apply by (rule ext) (induct_tac, auto) setup {* BNF_LFP_Size.register_size_global @{type_name multiset} @{const_name size_multiset} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Permutation.thy --- 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 \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Quickcheck_Types.thy --- 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) \ (b = One) | B => (b = B) \ (b = One) | C => (b = C) \ (b = One) | One => (b = One))" - -definition less_non_distrib_lattice -where - "a < b = (case a of Zero => (b \ 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 \ y \ (case x of Bot \ True | Value x \ (case y of Bot \ False | Value y \ x \ y))" - -definition less_bot where - "x < y \ (case y of Bot \ False | Value y \ (case x of Bot \ True | Value x \ x < y))" - -lemma less_eq_bot_Bot [simp]: "Bot \ x" - by (simp add: less_eq_bot_def) - -lemma less_eq_bot_Bot_code [code]: "Bot \ x \ True" - by simp - -lemma less_eq_bot_Bot_is_Bot: "x \ Bot \ x = Bot" - by (cases x) (simp_all add: less_eq_bot_def) - -lemma less_eq_bot_Value_Bot [simp, code]: "Value x \ Bot \ False" - by (simp add: less_eq_bot_def) - -lemma less_eq_bot_Value [simp, code]: "Value x \ Value y \ x \ y" - by (simp add: less_eq_bot_def) - -lemma less_bot_Bot [simp, code]: "x < Bot \ False" - by (simp add: less_bot_def) - -lemma less_bot_Bot_is_Value: "Bot < x \ \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 \ True" - by simp - -lemma less_bot_Value [simp, code]: "Value x < Value y \ 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 \ y \ (case y of Top \ True | Value y \ (case x of Top \ False | Value x \ x \ y))" - -definition less_top where - "x < y \ (case x of Top \ False | Value x \ (case y of Top \ True | Value y \ 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 \ Top \ True" - by simp - -lemma less_eq_top_is_Top: "Top \ x \ x = Top" - by (cases x) (simp_all add: less_eq_top_def) - -lemma less_eq_top_Top_Value [simp, code]: "Top \ Value x \ False" - by (simp add: less_eq_top_def) - -lemma less_eq_top_Value_Value [simp, code]: "Value x \ Value y \ x \ y" - by (simp add: less_eq_top_def) - -lemma less_top_Top [simp, code]: "Top < x \ False" - by (simp add: less_top_def) - -lemma less_top_Top_is_Value: "x < Top \ \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 \ True" - by simp - -lemma less_top_Value [simp, code]: "Value x < Value y \ 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 \ 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 => \ (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 = {} \ A = {Bot}) then Bot else (if (\ 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 = {} \ A = {Top}) then Top else (if (\ 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 \ 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: "\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} \ a1 \ 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 \ 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: "\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} \ a1 \ 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/RBT_Impl.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/RBT_Set.thy --- 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" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/Sum_of_Squares/sum_of_squares.ML --- 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' diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/refute.ML --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Library/simps_case_conv.ML --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Lifting.thy --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/List.thy --- 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 \ '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 {} (\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) \ length xs" by (induct xs) (auto simp add: card_insert_if) @@ -3439,6 +3436,9 @@ "distinct (a # b # xs) \ (a \ b \ distinct (a # xs) \ 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 [] \ [x] | y # xs \ 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) \ remdups_adj xs ! i \ 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) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/MicroJava/Comp/CorrCompTp.thy --- 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 = [] \ 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 \mt3_rest. \ *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Nat.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Nitpick.thy --- 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 \ 'b" +datatype ('a, 'b) pair_box = PairBox 'a 'b +datatype 'a word = Word "'a set" -axiomatization unknown :: 'a - and is_unknown :: "'a \ bool" - and bisim :: "bisim_iterator \ 'a \ 'a \ bool" - and bisim_iterator_max :: bisim_iterator - and Quot :: "'a \ 'b" - and safe_The :: "('a \ bool) \ 'a" - -datatype ('a, 'b) fun_box = FunBox "('a \ '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 \ bool" + bisim :: "bisim_iterator \ 'a \ 'a \ bool" + bisim_iterator_max :: bisim_iterator + Quot :: "'a \ 'b" + safe_The :: "('a \ bool) \ 'a" text {* Alternative definitions. *} -lemma Ex1_unfold [nitpick_unfold]: -"Ex1 P \ \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 \ \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>* \ (r\<^sup>+)\<^sup>=" +lemma rtrancl_unfold[nitpick_unfold]: "r\<^sup>* \ (r\<^sup>+)\<^sup>=" by (simp only: rtrancl_trancl_reflcl) -lemma rtranclp_unfold [nitpick_unfold]: -"rtranclp r a b \ (a = b \ tranclp r a b)" -by (rule eq_reflection) (auto dest: rtranclpD) +lemma rtranclp_unfold[nitpick_unfold]: "rtranclp r a b \ (a = b \ tranclp r a b)" + by (rule eq_reflection) (auto dest: rtranclpD) -lemma tranclp_unfold [nitpick_unfold]: -"tranclp r a b \ (a, b) \ trancl {(x, y). r x y}" -by (simp add: trancl_def) +lemma tranclp_unfold[nitpick_unfold]: + "tranclp r a b \ (a, b) \ 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 \ 'b set \ ('a \ 'b) set" where -"prod A B = {(a, b). a \ A \ b \ B}" + "prod A B = {(a, b). a \ A \ b \ B}" definition refl' :: "('a \ 'a) set \ bool" where -"refl' r \ \x. (x, x) \ r" + "refl' r \ \x. (x, x) \ r" definition wf' :: "('a \ 'a) set \ bool" where -"wf' r \ acyclic r \ (finite r \ unknown)" + "wf' r \ acyclic r \ (finite r \ unknown)" definition card' :: "'a set \ nat" where -"card' A \ if finite A then length (SOME xs. set xs = A \ distinct xs) else 0" + "card' A \ if finite A then length (SOME xs. set xs = A \ distinct xs) else 0" definition setsum' :: "('a \ 'b\comm_monoid_add) \ 'a set \ 'b" where -"setsum' f A \ if finite A then listsum (map f (SOME xs. set xs = A \ distinct xs)) else 0" + "setsum' f A \ if finite A then listsum (map f (SOME xs. set xs = A \ distinct xs)) else 0" inductive fold_graph' :: "('a \ 'b \ 'b) \ 'b \ 'a set \ 'b \ bool" where -"fold_graph' f z {} z" | -"\x \ A; fold_graph' f z (A - {x}) y\ \ fold_graph' f z A (f x y)" + "fold_graph' f z {} z" | + "\x \ A; fold_graph' f z (A - {x}) y\ \ 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 \ The P = x" +lemma The_psimp[nitpick_psimp]: "P = (op =) x \ The P = x" by auto -lemma Eps_psimp [nitpick_psimp]: -"\P x; \ P y; Eps P = y\ \ Eps P = x" -apply (cases "P (Eps P)") - apply auto -apply (erule contrapos_np) -by (rule someI) +lemma Eps_psimp[nitpick_psimp]: + "\P x; \ P y; Eps P = y\ \ 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 \ x" -apply (subgoal_tac "u = ()") - apply (simp only: unit.case) -by simp +lemma case_unit_unfold[nitpick_unfold]: + "case_unit x u \ 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 \ 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 \ 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 \ nat \ 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 (\(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 (\(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 \ nat \ 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 \ int \ 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 \ int \ 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 \ int \ bool" where -"Frac \ \(a, b). b > 0 \ int_gcd a b = 1" + "Frac \ \(a, b). b > 0 \ int_gcd a b = 1" -axiomatization - Abs_Frac :: "int \ int \ 'a" and +consts + Abs_Frac :: "int \ int \ 'a" Rep_Frac :: "'a \ int \ int" definition zero_frac :: 'a where -"zero_frac \ Abs_Frac (0, 1)" + "zero_frac \ Abs_Frac (0, 1)" definition one_frac :: 'a where -"one_frac \ Abs_Frac (1, 1)" + "one_frac \ Abs_Frac (1, 1)" definition num :: "'a \ int" where -"num \ fst o Rep_Frac" + "num \ fst o Rep_Frac" definition denom :: "'a \ int" where -"denom \ snd o Rep_Frac" + "denom \ snd o Rep_Frac" function norm_frac :: "int \ int \ int \ int" where -[simp del]: "norm_frac a b = (if b < 0 then norm_frac (- a) (- b) - else if a = 0 \ 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 (\(_, 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 \ 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 (\(_, b). if b < 0 then 1 else 0)") auto + +declare norm_frac.simps[simp del] definition frac :: "int \ int \ 'a" where -"frac a b \ Abs_Frac (norm_frac a b)" + "frac a b \ Abs_Frac (norm_frac a b)" definition plus_frac :: "'a \ 'a \ '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 \ 'a \ '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 \ 'a" where -"uminus_frac q \ Abs_Frac (- num q, denom q)" + "uminus_frac q \ Abs_Frac (- num q, denom q)" definition number_of_frac :: "int \ 'a" where -"number_of_frac n \ Abs_Frac (n, 1)" + "number_of_frac n \ Abs_Frac (n, 1)" definition inverse_frac :: "'a \ 'a" where -"inverse_frac q \ frac (denom q) (num q)" + "inverse_frac q \ frac (denom q) (num q)" definition less_frac :: "'a \ 'a \ bool" where -[nitpick_simp]: -"less_frac q r \ num (plus_frac q (uminus_frac r)) < 0" + [nitpick_simp]: "less_frac q r \ num (plus_frac q (uminus_frac r)) < 0" definition less_eq_frac :: "'a \ 'a \ bool" where -[nitpick_simp]: -"less_eq_frac q r \ num (plus_frac q (uminus_frac r)) \ 0" + [nitpick_simp]: "less_eq_frac q r \ num (plus_frac q (uminus_frac r)) \ 0" definition of_frac :: "'a \ 'b\{inverse,ring_1}" where -"of_frac q \ of_int (num q) / of_int (denom q)" + "of_frac q \ of_int (num q) / of_int (denom q)" axiomatization wf_wfrec :: "('a \ 'a) set \ (('a \ 'b) \ 'a \ 'b) \ 'a \ 'b" definition wf_wfrec' :: "('a \ 'a) set \ (('a \ 'b) \ 'a \ 'b) \ 'a \ '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 \ 'a) set \ (('a \ 'b) \ 'a \ 'b) \ 'a \ 'b" where -"wfrec' R F x \ 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 \ 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" 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Nominal/nominal_induct.ML --- 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; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Nominal/nominal_inductive.ML --- 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)); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Nominal/nominal_primrec.ML --- 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; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Number_Theory/Euclidean_Algorithm.thy --- /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) = (\m\0. \n\N. abs n \ m)" +proof + assume "finite (N::int set)" + hence "finite (nat ` abs ` N)" by (intro finite_imageI) + hence "\m. \n\nat`abs`N. n \ m" by (simp add: finite_nat_set_iff_bounded_le) + then obtain m :: nat where "\n\N. nat (abs n) \ nat (int m)" by auto + then show "\m\0. \n\N. abs n \ m" by (intro exI[of _ "int m"]) (auto simp: nat_le_eq_zle) +next + assume "\m\0. \n\N. abs n \ m" + then obtain m where "m \ 0" and "\n\N. abs n \ m" by blast + hence "\n\N. nat (abs n) \ nat m" by (auto simp: nat_le_eq_zle) + hence "\n\nat`abs`N. n \ nat m" by (auto simp: nat_le_eq_zle) + hence A: "finite ((nat \ abs)`N)" unfolding o_def + by (subst finite_nat_set_iff_bounded_le) blast + { + assume "\finite N" + from pigeonhole_infinite[OF this A] obtain x + where "x \ N" and B: "~finite {a\N. nat (abs a) = nat (abs x)}" + unfolding o_def by blast + have "{a\N. nat (abs a) = nat (abs x)} \ {x, -x}" by auto + hence "finite {a\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 \ 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 \ 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 \ 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 \ 0` have "a div a = 1" by simp + finally show ?thesis by simp +qed + +lemma dvd_mult_cancel_right: + "a \ 0 \ b * a dvd c * a \ b dvd c" + by (subst (asm) (1 2) ac_simps, rule dvd_mult_cancel_left) + +lemma nonzero_pow_nonzero: + "a \ 0 \ a ^ n \ 0" + by (induct n) (simp_all add: no_zero_divisors) + +lemma zero_pow_zero: "n \ 0 \ 0 ^ n = 0" + by (cases n, simp_all) + +lemma pow_zero_iff: + "n \ 0 \ a^n = 0 \ a = 0" + using nonzero_pow_nonzero zero_pow_zero by auto + +end + +context semiring_div +begin + +definition ring_inv :: "'a \ 'a" +where + "ring_inv x = 1 div x" + +definition is_unit :: "'a \ bool" +where + "is_unit x \ x dvd 1" + +definition associated :: "'a \ 'a \ bool" +where + "associated x y \ x dvd y \ y dvd x" + +lemma unit_prod [intro]: + "is_unit x \ is_unit y \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ x * y dvd z \ 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 \ x div y dvd z \ x dvd z" + by (subst unit_ring_inv) (assumption, simp add: mult_unit_dvd_iff) + +lemma dvd_mult_unit_iff: + "is_unit y \ x dvd z * y \ 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 \ x dvd z div y \ 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 \ is_unit y \ is_unit (x div y)" + by (subst unit_ring_inv) (assumption, rule unit_prod, simp_all) + +lemma unit_div_mult_swap: + "is_unit z \ 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 \ 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 \ y dvd x" + by (rule dvd_trans [of _ 1]) (simp_all add: is_unit_def) + +lemma dvd_unit_imp_unit: + "is_unit y \ x dvd y \ 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 \ associated y x" + by (simp add: associated_def) + +lemma associated_0 [simp]: + "associated 0 b \ b = 0" + "associated a 0 \ a = 0" + unfolding associated_def by simp_all + +lemma associated_unit: + "is_unit x \ associated x y \ 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]: + "\ is_unit 0" + unfolding is_unit_def by auto + +lemma unit_mult_left_cancel: + assumes "is_unit x" + shows "(x * y) = (x * z) \ y = z" +proof - + from assms have "x \ 0" by auto + then show ?thesis by (metis div_mult_self1_is_id) +qed + +lemma unit_mult_right_cancel: + "is_unit x \ (y * x) = (z * x) \ y = z" + by (simp add: ac_simps unit_mult_left_cancel) + +lemma unit_div_cancel: + "is_unit x \ (y div x) = (z div x) \ 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 \ x div y = z \ 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 \ x = z div y \ 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 \ (\z. is_unit z \ x = z * y)" +proof + assume "associated x y" + show "\z. is_unit z \ x = z * y" + proof (cases "x = 0") + assume "x = 0" + then show "\z. is_unit z \ x = z * y" using `associated x y` + by (intro exI[of _ 1], simp add: associated_def) + next + assume [simp]: "x \ 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 "\z. is_unit z \ 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) \ 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) \ x = 1" + unfolding is_unit_def by simp + +lemma is_unit_int: + "is_unit (x::int) \ x = 1 \ 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 \ 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 \ nat" + fixes normalisation_factor :: "'a \ 'a" + assumes mod_size_less [simp]: + "b \ 0 \ euclidean_size (a mod b) < euclidean_size b" + assumes size_mult_mono: + "b \ 0 \ euclidean_size (a * b) \ euclidean_size a" + assumes normalisation_factor_is_unit [intro,simp]: + "a \ 0 \ 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 \ normalisation_factor x = x" + assumes normalisation_factor_0 [simp]: "normalisation_factor 0 = 0" +begin + +lemma normalisation_factor_dvd [simp]: + "a \ 0 \ 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 \ x = 0" +proof + assume "normalisation_factor x = 0" + hence "\ 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 \ 0" + let ?nf = "normalisation_factor" + from normalisation_factor_is_unit[OF `x \ 0`] have "?nf x \ 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 \ 0` + by (simp add: dvd_div_mult_self) + also have "?nf (?nf x) = ?nf x" using `x \ 0` + normalisation_factor_is_unit normalisation_factor_unit by simp + finally show ?thesis using `x \ 0` and `?nf x \ 0` + by (metis div_mult_self2_is_id div_self) +qed + +lemma normalisation_0_iff [simp]: + "x div normalisation_factor x = 0 \ x = 0" + by (cases "x = 0", simp, subst unit_eq_div1, blast, simp) + +lemma associated_iff_normed_eq: + "associated a b \ 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 \ 0" "b \ 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 \ 0` `b \ 0` have "\z. is_unit z \ 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 \ 0" "b \ 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 \ normalisation_factor a \ {0, 1} \ normalisation_factor b \ {0, 1} \ 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 \ 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 \ 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 \ 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 \ 0` have "c \ 0" by auto + with `b mod a = b * c` have "euclidean_size (b mod a) \ euclidean_size b" + using size_mult_mono by force + moreover from `a \ 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 \ 'a \ '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 \ snd)", simp_all) + +declare gcd_eucl.simps [simp del] + +lemma gcd_induct: "\\b. P b 0; \a b. 0 \ b \ P b (a mod b) \ P a b\ \ 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 \ 'a \ '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 \ 'a" +where + "Lcm_eucl A = (if \l. l \ 0 \ (\x\A. x dvd l) then + let l = SOME l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = + (LEAST n. \l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = n) + in l div normalisation_factor l + else 0)" + +definition Gcd_eucl :: "'a set \ 'a" +where + "Gcd_eucl A = Lcm_eucl {d. \a\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 \ 0 \ 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 \ 0 \ gcd y (x mod y) dvd y" + assume IH2: "y \ 0 \ gcd y (x mod y) dvd (x mod y)" + + have "gcd x y dvd x \ 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 \ k dvd m" + by (rule dvd_trans, assumption, rule gcd_dvd1) + +lemma dvd_gcd_D2: "k dvd gcd m n \ k dvd n" + by (rule dvd_trans, assumption, rule gcd_dvd2) + +lemma gcd_greatest: + fixes k x y :: 'a + shows "k dvd x \ k dvd y \ 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 \ 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 \ k dvd x \ 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 \ x = 0 \ 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 \ 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 \ 0 \ ?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 \ k dvd y \ (\l. l dvd x \ l dvd y \ l dvd k) + \ normalisation_factor k = (if k = 0 then 0 else 1) \ 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 \ d dvd b \ + normalisation_factor d = (if d = 0 then 0 else 1) \ + (\e. e dvd a \ e dvd b \ e dvd d) \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ 0" + shows "euclidean_size (gcd a b) \ 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 \ 0` show ?thesis by (subst (2) A, intro size_mult_mono) auto +qed + +lemma euclidean_size_gcd_le2 [simp]: + "b \ 0 \ euclidean_size (gcd a b) \ euclidean_size b" + by (subst gcd.commute, rule euclidean_size_gcd_le1) + +lemma euclidean_size_gcd_less1: + assumes "a \ 0" and "\a dvd b" + shows "euclidean_size (gcd a b) < euclidean_size a" +proof (rule ccontr) + assume "\euclidean_size (gcd a b) < euclidean_size a" + with `a \ 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 `\a dvd b` show False by contradiction +qed + +lemma euclidean_size_gcd_less2: + assumes "b \ 0" and "\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 \ 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 \ 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 \ gcd (x div a) y = gcd x y" + by (simp add: unit_ring_inv gcd_mult_unit1) + +lemma gcd_div_unit2: "is_unit a \ 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 \ gcd b = gcd b \ gcd a" + by (simp add: fun_eq_iff ac_simps) +next + fix a show "gcd a \ 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 \ (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 \ gcd c d dvd gcd a b \ 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) \ associated a b \ associated c d" (is "?lhs \ ?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: "(\l. \l dvd x; l dvd y\ \ l dvd 1) \ gcd x y = 1" + by (rule sym, rule gcdI, simp_all) + +lemma coprime: "gcd a b = 1 \ (\d. d dvd a \ d dvd b \ 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 \ 0 \ b \ 0" + defines [simp]: "d \ gcd a b" + defines [simp]: "a' \ a div d" and [simp]: "b' \ 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 \ 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 \ gcd d a = 1 \ 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 \ 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 \ 0 \ b \ 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 \ 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 \ 0" + shows "\a' b'. a = a' * gcd a b \ b = b' * gcd a b \ 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 \ gcd d (a^n) = 1" + by (induct n, simp_all add: coprime_mult) + +lemma coprime_exp2 [intro]: + "gcd a b = 1 \ 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 \ b = 0") + assume "a = 0 \ b = 0" + then show ?thesis by (cases n, simp_all add: gcd_0_left) +next + assume A: "\(a = 0 \ 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 \ x dvd a \ x dvd b \ 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 "\b' c'. a = b' * c' \ b' dvd b \ c' dvd c" +proof (cases "gcd a b = 0") + assume "gcd a b = 0" + hence "a = 0 \ b = 0" by (simp add: gcd_zero) + hence "a = 0 * c \ 0 dvd b \ c dvd c" by simp + then show ?thesis by blast +next + let ?d = "gcd a b" + assume "?d \ 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 \ 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' \ ?d dvd b \ 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 \ 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 \ 0" + from n obtain m where m: "n = Suc m" by (cases n, simp_all) + from `?d \ 0` have zn: "?d ^ n \ 0" by (rule nonzero_pow_nonzero) + from gcd_coprime_exists[OF `?d \ 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 \ 0 \ a ^ n dvd b ^ n \ 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]: + "(\i\A. gcd (f i) x = 1) \ gcd (\i\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 \ 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 \ 0" + hence "gcd a b \ 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 \ 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 \ 0" + hence "gcd x y \ 0" by (auto simp: gcd_zero) + let ?c = "ring_inv (normalisation_factor (x*y))" + from `x * y \ 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 \ 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: + "\a dvd k; b dvd k\ \ lcm a b dvd k" +proof (cases "k = 0") + let ?nf = normalisation_factor + assume "k \ 0" + hence "is_unit (?nf k)" by simp + hence "?nf k \ 0" by (metis not_is_unit_0) + assume A: "a dvd k" "b dvd k" + hence "gcd a b \ 0" using `k \ 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 \ 0` have "r * s \ 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 \ 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 \ 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 \ 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 \ 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 \ 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 \ a = 0 \ b = 0" +proof - + let ?nf = normalisation_factor + { + assume "a \ 0" "b \ 0" + hence "a * b div ?nf (a * b) \ 0" by (simp add: no_zero_divisors) + moreover from `a \ 0` and `b \ 0` have "gcd a b \ 0" by (simp add: gcd_zero) + ultimately have "lcm a b \ 0" using lcm_gcd_prod[of a b] by (intro notI, simp) + } moreover { + assume "a = 0 \ 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 \ 0" + shows "gcd a b = a * b div (lcm a b * normalisation_factor (a * b))" +proof- + from assms have "gcd a b \ 0" by (simp add: gcd_zero lcm_zero) + let ?c = "normalisation_factor (a*b)" + from `lcm a b \ 0` have "?c \ 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 \ 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 \ b = 0 then 0 else 1)" +proof (cases "a = 0 \ 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: + "\x dvd k; y dvd k; \l. x dvd l \ y dvd l \ k dvd l; + normalisation_factor k = (if k = 0 then 0 else 1)\ \ 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 \ m dvd k" + by (rule dvd_trans, rule lcm_dvd1, assumption) + +lemma dvd_lcm_D2: + "lcm m n dvd k \ 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 \ is_unit a \ is_unit b" +proof + assume "lcm a b = 1" + then show "is_unit a \ is_unit b" unfolding is_unit_def by auto +next + assume "is_unit a \ 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 "\ = 1" using `is_unit a \ 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 \ b dvd d \ + normalisation_factor d = (if d = 0 then 0 else 1) \ + (\e. a dvd e \ b dvd e \ d dvd e) \ d = lcm a b" + by (rule, auto intro: lcmI simp: lcm_least lcm_zero) + +lemma dvd_lcm_I1 [simp]: + "k dvd m \ k dvd lcm m n" + by (metis lcm_dvd1 dvd_trans) + +lemma dvd_lcm_I2 [simp]: + "k dvd n \ 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 \ lcm a b = a * b div normalisation_factor (a*b)" + by (subst lcm_gcd) simp + +lemma lcm_proj1_if_dvd: + "y dvd x \ 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 \ 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 \ 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 \ 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 \ m dvd n" + using lcm_proj1_iff [of n m] by (simp add: ac_simps) + +lemma euclidean_size_lcm_le1: + assumes "a \ 0" and "b \ 0" + shows "euclidean_size a \ 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 \ 0` and `b \ 0` have "c \ 0" by (auto simp: lcm_zero) + then show ?thesis by (subst A, intro size_mult_mono) +qed + +lemma euclidean_size_lcm_le2: + "a \ 0 \ b \ 0 \ euclidean_size b \ 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 \ 0" and "\b dvd a" + shows "euclidean_size a < euclidean_size (lcm a b)" +proof (rule ccontr) + from assms have "a \ 0" by auto + assume "\euclidean_size a < euclidean_size (lcm a b)" + with `a \ 0` and `b \ 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 `\b dvd a` show False by contradiction +qed + +lemma euclidean_size_lcm_less2: + assumes "a \ 0" and "\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 \ 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 \ 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 \ lcm (x div a) y = lcm x y" + by (simp add: unit_ring_inv lcm_mult_unit1) + +lemma lcm_div_unit2: + "is_unit a \ 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 \ lcm b = lcm b \ lcm a" + by (simp add: fun_eq_iff ac_simps) +next + fix a show "lcm a \ lcm a = lcm a" unfolding o_def + by (intro ext, simp add: lcm_left_idem) +qed + +lemma dvd_Lcm [simp]: "x \ A \ x dvd Lcm A" + and Lcm_dvd [simp]: "(\x\A. x dvd l') \ Lcm A dvd l'" + and normalisation_factor_Lcm [simp]: + "normalisation_factor (Lcm A) = (if Lcm A = 0 then 0 else 1)" +proof - + have "(\x\A. x dvd Lcm A) \ (\l'. (\x\A. x dvd l') \ Lcm A dvd l') \ + normalisation_factor (Lcm A) = (if Lcm A = 0 then 0 else 1)" (is ?thesis) + proof (cases "\l. l \ 0 \ (\x\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 \ 0 \ (\x\A. x dvd l\<^sub>0)" by blast + def n \ "LEAST n. \l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = n" + def l \ "SOME l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = n" + have "\l. l \ 0 \ (\x\A. x dvd l) \ 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 \ 0" and "\x\A. x dvd l" and "euclidean_size l = n" + unfolding l_def by simp_all + { + fix l' assume "\x\A. x dvd l'" + with `\x\A. x dvd l` have "\x\A. x dvd gcd l l'" by (auto intro: gcd_greatest) + moreover from `l \ 0` have "gcd l l' \ 0" by (simp add: gcd_zero) + ultimately have "\b. b \ 0 \ (\x\A. x dvd b) \ euclidean_size b = euclidean_size (gcd l l')" + by (intro exI[of _ "gcd l l'"], auto) + hence "euclidean_size (gcd l l') \ n" by (subst n_def) (rule Least_le) + moreover have "euclidean_size (gcd l l') \ 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 \ 0` have "a \ 0" by auto + hence "euclidean_size (gcd l l') \ 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') \ 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 \ 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 `(\x\A. x dvd l)` and normalisation_factor_is_unit[OF `l \ 0`] and `l \ 0` + have "(\x\A. x dvd l div normalisation_factor l) \ + (\l'. (\x\A. x dvd l') \ l div normalisation_factor l dvd l') \ + 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 \ A" then show "x dvd Lcm A" using A by blast} + {fix l' assume "\x\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: + "(\x. x\A \ x dvd l) \ (\l'. (\x\A. x dvd l') \ l dvd l') \ + normalisation_factor l = (if l = 0 then 0 else 1) \ l = Lcm A" + by (intro normed_associated_imp_eq) + (auto intro: Lcm_dvd dvd_Lcm simp: associated_def) + +lemma Lcm_subset: + "A \ B \ Lcm A dvd Lcm B" + by (blast intro: Lcm_dvd dvd_Lcm) + +lemma Lcm_Un: + "Lcm (A \ 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 \ (\x\A. is_unit x)" +proof + assume "Lcm A = 1" + then show "\x\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}) \ {x\A. is_unit x} = A" by blast + hence "Lcm A = lcm (Lcm (A - {x. is_unit x})) (Lcm {x\A. is_unit x})" + by (simp add: Lcm_Un[symmetric]) + also have "Lcm {x\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 \ A \ Lcm A = 0" + by (drule dvd_Lcm) simp + +lemma Lcm0_iff': + "Lcm A = 0 \ \(\l. l \ 0 \ (\x\A. x dvd l))" +proof + assume "Lcm A = 0" + show "\(\l. l \ 0 \ (\x\A. x dvd l))" + proof + assume ex: "\l. l \ 0 \ (\x\A. x dvd l)" + then obtain l\<^sub>0 where l\<^sub>0_props: "l\<^sub>0 \ 0 \ (\x\A. x dvd l\<^sub>0)" by blast + def n \ "LEAST n. \l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = n" + def l \ "SOME l. l \ 0 \ (\x\A. x dvd l) \ euclidean_size l = n" + have "\l. l \ 0 \ (\x\A. x dvd l) \ 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 \ 0" unfolding l_def by simp_all + hence "l div normalisation_factor l \ 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 \ Lcm A = 0 \ 0 \ A" +proof - + assume "finite A" + have "0 \ A \ Lcm A = 0" by (intro dvd_0_left dvd_Lcm) + moreover { + assume "0 \ A" + hence "\A \ 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 "\x\A. x dvd \A" by (intro ballI dvd_setprod) + ultimately have "\l. l \ 0 \ (\x\A. x dvd l)" by blast + with Lcm0_iff' have "Lcm A \ 0" by simp + } + ultimately show "Lcm A = 0 \ 0 \ A" by blast +qed + +lemma Lcm_no_multiple: + "(\m. m \ 0 \ (\x\A. \x dvd m)) \ Lcm A = 0" +proof - + assume "\m. m \ 0 \ (\x\A. \x dvd m)" + hence "\(\l. l \ 0 \ (\x\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 "\x\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 \ {}" + assumes "\a b. a \ A \ b \ A \ a \ b \ gcd a b = 1" + shows "Lcm A = \A div normalisation_factor (\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 = \A div normalisation_factor (\A)" by blast + also have "lcm a \ = lcm a (\A)" by (cases "\A = 0") (simp_all add: lcm_div_unit2) + also from insert have "gcd a (\A) = 1" by (subst gcd.commute, intro setprod_coprime) auto + with insert have "lcm a (\A) = \(insert a A) div normalisation_factor (\(insert a A))" + by (simp add: lcm_coprime) + finally show ?case . +qed simp + +lemma Lcm_coprime': + "card A \ 0 \ (\a b. a \ A \ b \ A \ a \ b \ gcd a b = 1) + \ Lcm A = \A div normalisation_factor (\A)" + by (rule Lcm_coprime) (simp_all add: card_eq_0_iff) + +lemma Gcd_Lcm: + "Gcd A = Lcm {d. \x\A. d dvd x}" + by (simp add: Gcd_Gcd_eucl Lcm_Lcm_eucl Gcd_eucl_def) + +lemma Gcd_dvd [simp]: "x \ A \ Gcd A dvd x" + and dvd_Gcd [simp]: "(\x\A. g' dvd x) \ 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 \ A" + hence "Lcm {d. \x\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 "\x\A. g' dvd x" + hence "g' dvd Lcm {d. \x\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: + "(\x. x\A \ l dvd x) \ (\l'. (\x\A. l' dvd x) \ l' dvd l) \ + normalisation_factor l = (if l = 0 then 0 else 1) \ 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. \x\A. x dvd m}" + by (rule LcmI[symmetric]) (auto intro: dvd_Gcd Gcd_dvd) + +lemma Gcd_0_iff: + "Gcd A = 0 \ A \ {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 \ A \ 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 "\x\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 "\ = gcd ((n - 1) + 1) (n - 1)" by simp + also have "\ = 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 \ 'a \ 'a \ 'a \ '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) \ (t, s - t * (a div b), c))" + by (pat_completeness, simp) + termination by (relation "measure (euclidean_size \ 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 \ 0 \ euclid_ext a b = (case euclid_ext b (a mod b) of + (s,t,c) \ (t, s - t * (a div b), c))" + by (subst euclid_ext.simps, simp) + +definition euclid_ext' :: "'a \ 'a \ 'a \ 'a" +where + "euclid_ext' a b = (case euclid_ext a b of (s, t, _) \ (s, t))" + +lemma euclid_ext_gcd [simp]: + "(case euclid_ext a b of (_,_,t) \ 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) \ 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) \ 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: "\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 \ 0 \ 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 \ 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 \ abs :: int \ nat)" + +definition [simp]: + "normalisation_factor_int = (sgn :: int \ 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 + diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Old_Number_Theory/Factorization.thy --- 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)" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Partial_Function.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Product_Type.thy --- 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 \ 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) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Quickcheck_Examples/Quickcheck_Lattice_Examples.thy --- 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. *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Quotient.thy --- 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)]] diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Quotient_Examples/FSet.thy --- 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: "\x' ys'. \\ List.member ys' x'; a # xs \ x' # ys'\ \ thesis" by fact have c: "xs = [] \ thesis" using b apply(simp) - by (metis List.set_simps(1) emptyE empty_subsetI) + by (metis list.set(1) emptyE empty_subsetI) have "\x ys. \\ List.member ys x; xs \ x # ys\ \ thesis" proof - fix x :: 'a diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Quotient_Examples/Lift_FSet.thy --- 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 \ fset ys" using set_append [Transfer.transferred] . diff -r 1b6035697c49 -r be9815d02b10 src/HOL/ROOT --- 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" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Real.thy --- 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 \ of_rat" -consts - (*overloaded constant for injecting other types into "real"*) - real :: "'a => real" +class real_of = + fixes real :: "'a \ real" + +instantiation nat :: real_of +begin + +definition real_nat :: "nat \ real" where real_of_nat_def [code_unfold]: "real \ 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 \ real" where real_of_int_def [code_unfold]: "real \ of_int" + +instance .. +end declare [[coercion_enabled]] declare [[coercion "real::nat\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 \ real"}) - #> Lin_Arith.add_inj_const (@{const_name real}, @{typ "int \ real"})) + #> Lin_Arith.add_inj_const (@{const_name real}, @{typ "int \ real"}) + #> Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat \ real"}) + #> Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int \ 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: " \n::int. real n \ r & r < real (n+1)" unfolding real_of_int_def by (rule floor_exists) -lemma lemma_floor: - assumes a1: "real m \ r" and a2: "r < real n + 1" - shows "m \ (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 \ r \ r < real n + 1 \ m \ (n::int)" + by simp lemma real_of_int_floor_le [simp]: "real (floor r) \ r" unfolding real_of_int_def by (rule of_int_floor_le) lemma lemma_floor2: "real n < real (x::int) + 1 ==> n \ x" -by (auto intro: lemma_floor) + by simp lemma real_of_int_floor_cancel [simp]: "(real (floor x) = x) = (\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 \ 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 \ 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 \ 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 \ 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 \ (a :: real)" and "0 \ 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 \ 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) = (\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 \ 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 \ 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 \ 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) \ 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) \ (t < 0 \ P 0) \ (\n. of_nat n \ t \ t < of_nat n + 1 \ P n)" +proof - + have [dest]: "\n m::nat. real n \ t \ t < real n + 1 \ real m \ t \ t < real m + 1 \ 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) \ (t \ - 1 \ P 0) \ (\n. of_nat n - 1 < t \ t \ of_nat n \ P n)" +proof - + have [dest]: "\n m::nat. real n - 1 < t \ t \ real n \ real m - 1 < t \ t \ real m \ 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 \ x \ natfloor x < n \ 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 \ x" and "x < real (n :: nat)" - shows "natfloor x < n" - using assms by (simp add: natfloor_less_iff) +lemma less_natfloor: "0 \ x \ x < real (n :: nat) \ 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 \ x \ (numeral n \ natfloor x) = (numeral n \ x)" + by (subst le_natfloor_eq, assumption) simp + +lemma le_natfloor_eq_one [simp]: "(1 \ natfloor x) = (1 \ 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 \ x \ x < real n + 1 \ 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 \ 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: "\ q \ \. (x :: real) \ q" by (auto intro!: bexI[of _ "of_nat (natceiling x)"]) (metis real_natceiling_ge real_of_nat_def) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT.thy --- 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 *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT2.thy --- 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 = {* diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT_Examples/SMT_Examples.certs --- 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 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT_Examples/SMT_Examples.certs2 --- 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 ) (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 ) (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 ) (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 ) (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 ) +(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 ) @@ -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 ) -(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 ) @@ -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 ) (proof diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT_Examples/SMT_Examples.thy --- 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 \ 0" and "\ y \ 0" and "\ x \ 0" shows False using assms by (metis mult_le_0_iff) -lemma "x * y \ (0 :: int) \ x \ 0 \ y \ 0" - using [[z3_with_extensions]] [[z3_new_extensions]] - by smt (* smt2 FIXME: "th-lemma" tactic fails *) - section {* Pairs *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT_Examples/SMT_Tests.thy --- 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 = \ cx = 3, cy = 4, black = True \ \ p \ black := True \ \ cx := 3 \ \ cy := 4 \ = 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 "\ cx = 3, cy = 4, black = b \ \ black := w \ = \ cx = 3, cy = 4, black = w \" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/SMT_Examples/SMT_Word_Examples.certs2 --- 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 ) -(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 ) @@ -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 ) +(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 ) @@ -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 ) +(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)))) +(let ((@x47 (trans (monotonicity @x40 (= (not (= (bvnot (_ bv240 16)) (_ bv65295 16))) (not true))) (rewrite (= (not true) false)) (= (not (= (bvnot (_ bv240 16)) (_ bv65295 16))) false)))) +(mp (asserted (not (= (bvnot (_ bv240 16)) (_ bv65295 16)))) @x47 false)))))) + 14431ccb33137348161eb6ca6cfb2e57942c3f9d 9 0 unsat ((set-logic ) @@ -152,14 +161,15 @@ (let ((@x48 (trans @x44 (rewrite (= (not true) false)) (= (not (= (concat (_ bv11 4) (_ bv27 8)) (_ bv2843 12))) false)))) (mp (asserted (not (= (concat (_ bv11 4) (_ bv27 8)) (_ bv2843 12)))) @x48 false))))))) -3838eb33edcd292c3a0ecbf1662b54af3940189f 8 0 +880bee16a8f6469b14122277b92e87533ef6a071 9 0 unsat ((set-logic ) (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)))) -(let ((@x47 (trans (monotonicity @x40 (= (not (= (bvnot (_ bv240 16)) (_ bv65295 16))) (not true))) (rewrite (= (not true) false)) (= (not (= (bvnot (_ bv240 16)) (_ bv65295 16))) false)))) -(mp (asserted (not (= (bvnot (_ bv240 16)) (_ bv65295 16)))) @x47 false)))))) +(let ((@x37 (monotonicity (rewrite (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) (= (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)) (= (_ bv207 10) (_ bv207 10)))))) +(let ((@x41 (trans @x37 (rewrite (= (= (_ bv207 10) (_ bv207 10)) true)) (= (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)) true)))) +(let ((@x44 (monotonicity @x41 (= (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) (not true))))) +(let ((@x48 (trans @x44 (rewrite (= (not true) false)) (= (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) false)))) +(mp (asserted (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)))) @x48 false))))))) 8d29c9b5ef712a3d9d2db87383c9c25c0b553e01 8 0 unsat @@ -170,16 +180,6 @@ (let ((@x47 (trans (monotonicity @x40 (= (not (= ((_ extract 2 1) (_ bv6 4)) (_ bv3 2))) (not true))) (rewrite (= (not true) false)) (= (not (= ((_ extract 2 1) (_ bv6 4)) (_ bv3 2))) false)))) (mp (asserted (not (= ((_ extract 2 1) (_ bv6 4)) (_ bv3 2)))) @x47 false)))))) -880bee16a8f6469b14122277b92e87533ef6a071 9 0 -unsat -((set-logic ) -(proof -(let ((@x37 (monotonicity (rewrite (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) (= (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)) (= (_ bv207 10) (_ bv207 10)))))) -(let ((@x41 (trans @x37 (rewrite (= (= (_ bv207 10) (_ bv207 10)) true)) (= (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)) true)))) -(let ((@x44 (monotonicity @x41 (= (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) (not true))))) -(let ((@x48 (trans @x44 (rewrite (= (not true) false)) (= (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10))) false)))) -(mp (asserted (not (= (concat (_ bv3 4) (_ bv15 6)) (_ bv207 10)))) @x48 false))))))) - 446b3cb9d63aa1f488dc092ed3fb111d2ad50b4e 9 0 unsat ((set-logic ) @@ -240,6 +240,16 @@ (let ((@x47 (trans @x43 (rewrite (= (not true) false)) (= (not (= ((_ rotate_right 2) (_ bv6 4)) (_ bv9 4))) false)))) (mp (asserted (not (= ((_ rotate_right 2) (_ bv6 4)) (_ bv9 4)))) @x47 false))))))) +33a52e620069e1ecebbc00aa6b0099170558c111 9 0 +unsat +((set-logic ) +(proof +(let ((@x36 (monotonicity (rewrite (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) (= (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)) (= (_ bv13 4) (_ bv13 4)))))) +(let ((@x40 (trans @x36 (rewrite (= (= (_ bv13 4) (_ bv13 4)) true)) (= (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)) true)))) +(let ((@x43 (monotonicity @x40 (= (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) (not true))))) +(let ((@x47 (trans @x43 (rewrite (= (not true) false)) (= (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) false)))) +(mp (asserted (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)))) @x47 false))))))) + 5c4e275bed2d91897e820ccd6744b0a775a6e26e 17 0 unsat ((set-logic ) @@ -258,46 +268,6 @@ (let ((@x55 (unit-resolution ((_ th-lemma bv) $x53) @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 $x52))) (unit-resolution @x55 @x63 false))))))))))))))) -33a52e620069e1ecebbc00aa6b0099170558c111 9 0 -unsat -((set-logic ) -(proof -(let ((@x36 (monotonicity (rewrite (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) (= (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)) (= (_ bv13 4) (_ bv13 4)))))) -(let ((@x40 (trans @x36 (rewrite (= (= (_ bv13 4) (_ bv13 4)) true)) (= (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)) true)))) -(let ((@x43 (monotonicity @x40 (= (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) (not true))))) -(let ((@x47 (trans @x43 (rewrite (= (not true) false)) (= (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4))) false)))) -(mp (asserted (not (= ((_ rotate_left 1) (_ bv14 4)) (_ bv13 4)))) @x47 false))))))) - -115ab22c9945d493b971e69a38d9e608c5b40a71 29 0 -unsat -((set-logic ) -(proof -(let ((?x28 (bv2int$ (_ bv0 2)))) -(let (($x183 (<= ?x28 0))) -(let (($x184 (not $x183))) -(let (($x175 (forall ((?v0 (_ BitVec 2)) )(!(let ((?x47 (bv2int$ ?v0))) -(let (($x53 (<= ?x47 0))) -(not $x53))) :pattern ( (bv2int$ ?v0) ))) -)) -(let (($x57 (forall ((?v0 (_ BitVec 2)) )(let ((?x47 (bv2int$ ?v0))) -(let (($x53 (<= ?x47 0))) -(not $x53)))) -)) -(let ((@x177 (refl (= (not (<= (bv2int$ ?0) 0)) (not (<= (bv2int$ ?0) 0)))))) -(let ((@x112 (refl (~ (not (<= (bv2int$ ?0) 0)) (not (<= (bv2int$ ?0) 0)))))) -(let (($x49 (forall ((?v0 (_ BitVec 2)) )(let ((?x47 (bv2int$ ?v0))) -(< 0 ?x47))) -)) -(let ((@x56 (rewrite (= (< 0 (bv2int$ ?0)) (not (<= (bv2int$ ?0) 0)))))) -(let ((@x115 (mp~ (mp (asserted $x49) (quant-intro @x56 (= $x49 $x57)) $x57) (nnf-pos @x112 (~ $x57 $x57)) $x57))) -(let ((@x180 (mp @x115 (quant-intro @x177 (= $x57 $x175)) $x175))) -(let (($x187 (not $x175))) -(let (($x188 (or $x187 $x184))) -(let ((@x189 ((_ quant-inst (_ bv0 2)) $x188))) -(let (($x29 (= ?x28 0))) -(let ((@x30 (asserted $x29))) -(unit-resolution ((_ th-lemma arith triangle-eq) (or (not $x29) $x183)) @x30 (unit-resolution @x189 @x180 $x184) false))))))))))))))))))) - 1d4a0e2a4449a8adbcf5a134bf7f2b0ee940d954 51 0 unsat ((set-logic ) @@ -350,6 +320,36 @@ (let ((@x314 (unit-resolution ((_ th-lemma bv) $x312) @x26 @x26 @x26 @x26 @x26 @x26 @x26 @x26 (unit-resolution (def-axiom (or $x95 (not $x74))) @x303 (not $x74)) (unit-resolution (def-axiom (or $x95 (not $x75))) @x303 (not $x75)) (unit-resolution (def-axiom (or $x95 (not $x76))) @x303 (not $x76)) (unit-resolution (def-axiom (or $x95 (not $x77))) @x303 (not $x77)) (unit-resolution (def-axiom (or $x95 (not $x78))) @x303 (not $x78)) (unit-resolution (def-axiom (or $x95 (not $x79))) @x303 (not $x79)) (unit-resolution (def-axiom (or $x95 (not $x80))) @x303 (not $x80)) (unit-resolution (def-axiom (or $x95 $x264)) @x303 $x264) $x300))) (unit-resolution @x314 @x322 false))))))))))))))))))))))))))))))))))))))))))))))))) +115ab22c9945d493b971e69a38d9e608c5b40a71 29 0 +unsat +((set-logic ) +(proof +(let ((?x28 (bv2int$ (_ bv0 2)))) +(let (($x183 (<= ?x28 0))) +(let (($x184 (not $x183))) +(let (($x175 (forall ((?v0 (_ BitVec 2)) )(!(let ((?x47 (bv2int$ ?v0))) +(let (($x53 (<= ?x47 0))) +(not $x53))) :pattern ( (bv2int$ ?v0) ))) +)) +(let (($x57 (forall ((?v0 (_ BitVec 2)) )(let ((?x47 (bv2int$ ?v0))) +(let (($x53 (<= ?x47 0))) +(not $x53)))) +)) +(let ((@x177 (refl (= (not (<= (bv2int$ ?0) 0)) (not (<= (bv2int$ ?0) 0)))))) +(let ((@x112 (refl (~ (not (<= (bv2int$ ?0) 0)) (not (<= (bv2int$ ?0) 0)))))) +(let (($x49 (forall ((?v0 (_ BitVec 2)) )(let ((?x47 (bv2int$ ?v0))) +(< 0 ?x47))) +)) +(let ((@x56 (rewrite (= (< 0 (bv2int$ ?0)) (not (<= (bv2int$ ?0) 0)))))) +(let ((@x115 (mp~ (mp (asserted $x49) (quant-intro @x56 (= $x49 $x57)) $x57) (nnf-pos @x112 (~ $x57 $x57)) $x57))) +(let ((@x180 (mp @x115 (quant-intro @x177 (= $x57 $x175)) $x175))) +(let (($x187 (not $x175))) +(let (($x188 (or $x187 $x184))) +(let ((@x189 ((_ quant-inst (_ bv0 2)) $x188))) +(let (($x29 (= ?x28 0))) +(let ((@x30 (asserted $x29))) +(unit-resolution ((_ th-lemma arith triangle-eq) (or (not $x29) $x183)) @x30 (unit-resolution @x189 @x180 $x184) false))))))))))))))))))) + d14e7b8f0d1858316e700b4eb09e7d03e57cf9c3 16 0 unsat ((set-logic ) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/ATP_Problem_Import.thy --- a/src/HOL/TPTP/ATP_Problem_Import.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/ATP_Problem_Import.thy Wed Aug 27 15:52:58 2014 +0200 @@ -5,10 +5,7 @@ header {* ATP Problem Importer *} theory ATP_Problem_Import -imports - Complex_Main - TPTP_Interpret - "~~/src/HOL/Library/Refute" +imports Complex_Main TPTP_Interpret "~~/src/HOL/Library/Refute" begin ML_file "sledgehammer_tactics.ML" @@ -24,8 +21,7 @@ ML_file "atp_problem_import.ML" (* -ML {* ATP_Problem_Import.isabelle_tptp_file @{theory} 50 - "$TPTP/Problems/PUZ/PUZ107^5.p" *} +ML {* ATP_Problem_Import.isabelle_tptp_file @{theory} 50 "$TPTP/Problems/PUZ/PUZ107^5.p" *} *) end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/THF_Arith.thy --- a/src/HOL/TPTP/THF_Arith.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/THF_Arith.thy Wed Aug 27 15:52:58 2014 +0200 @@ -51,7 +51,7 @@ overloading real_to_rat \ "to_rat :: real \ rat" begin - definition "real_to_rat (x\real) = (inv real x\rat)" + definition "real_to_rat (x\real) = (inv of_rat x\rat)" end overloading int_to_real \ "to_real :: int \ real" @@ -85,6 +85,6 @@ by (metis Rats_of_rat rat_to_real_def real_is_rat_def) lemma inj_of_rat [intro, simp]: "inj (of_rat\rat\real)" -by (metis injI of_rat_eq_iff rat_to_real_def) +by (metis injI of_rat_eq_iff) end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Interpret.thy --- a/src/HOL/TPTP/TPTP_Interpret.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Interpret.thy Wed Aug 27 15:52:58 2014 +0200 @@ -6,12 +6,12 @@ *) theory TPTP_Interpret -imports Main TPTP_Parser +imports Complex_Main TPTP_Parser keywords "import_tptp" :: thy_decl begin -typedecl "ind" +typedecl ind -ML_file "TPTP_Parser/tptp_interpret.ML" +ML_file "TPTP_Parser/tptp_interpret.ML" end \ No newline at end of file diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/README --- a/src/HOL/TPTP/TPTP_Parser/README Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/README Wed Aug 27 15:52:58 2014 +0200 @@ -29,4 +29,4 @@ ML-Yacc's library. Nik Sultana -9th March 2012 \ No newline at end of file +9th March 2012 diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/tptp.lex --- a/src/HOL/TPTP/TPTP_Parser/tptp.lex Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/tptp.lex Wed Aug 27 15:52:58 2014 +0200 @@ -86,6 +86,7 @@ upper_word = {upper_alpha}{alpha_numeric}*; dollar_dollar_word = {ddollar}{lower_word}; dollar_word = {dollar}{lower_word}; +dollar_underscore = {dollar}_; distinct_object = {double_quote}{do_char}+{double_quote}; @@ -177,6 +178,7 @@ {lower_word} => (col:=yypos-(!eolpos); T.LOWER_WORD(yytext,!linep,!col)); {dollar_word} => (col:=yypos-(!eolpos); T.DOLLAR_WORD(yytext,!linep,!col)); +{dollar_underscore} => (col:=yypos-(!eolpos); T.DOLLAR_WORD(yytext,!linep,!col)); {dollar_dollar_word} => (col:=yypos-(!eolpos); T.DOLLAR_DOLLAR_WORD(yytext,!linep,!col)); "+" => (col:=yypos-(!eolpos); T.PLUS(!linep,!col)); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/tptp.yacc --- a/src/HOL/TPTP/TPTP_Parser/tptp.yacc Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/tptp.yacc Wed Aug 27 15:52:58 2014 +0200 @@ -491,7 +491,7 @@ tff_unitary_type : tff_atomic_type (( tff_atomic_type )) | LPAREN tff_xprod_type RPAREN (( tff_xprod_type )) -tff_atomic_type : atomic_word (( Atom_type atomic_word )) +tff_atomic_type : atomic_word (( Atom_type (atomic_word, []) )) | defined_type (( Defined_type defined_type )) | atomic_word LPAREN tff_type_arguments RPAREN (( Fmla_type (Fmla (Uninterpreted atomic_word, (map Type_fmla tff_type_arguments))) )) | variable_ (( Fmla_type (Pred (Interpreted_ExtraLogic Apply, [Term_Var variable_])) )) @@ -634,6 +634,7 @@ | "$real" => Type_Real | "$rat" => Type_Rat | "$int" => Type_Int + | "$_" => Type_Dummy | thing => raise UNRECOGNISED_SYMBOL ("defined_type", thing) )) @@ -747,6 +748,7 @@ | "$real" => TypeSymbol Type_Real | "$rat" => TypeSymbol Type_Rat | "$tType" => TypeSymbol Type_Type + | "$_" => TypeSymbol Type_Dummy | "$true" => Interpreted_Logic True | "$false" => Interpreted_Logic False diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/tptp_interpret.ML --- a/src/HOL/TPTP/TPTP_Parser/tptp_interpret.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/tptp_interpret.ML Wed Aug 27 15:52:58 2014 +0200 @@ -8,11 +8,11 @@ sig (*Signature extension: typing information for variables and constants*) type var_types = (string * typ option) list - type const_map = (string * term) list + type const_map = (string * (term * int list)) list (*Mapping from TPTP types to Isabelle/HOL types. This map works over all base types. The map must be total wrt TPTP types.*) - type type_map = (TPTP_Syntax.tptp_type * typ) list + type type_map = (string * (string * int)) list (*A parsed annotated formula is represented as a 5-tuple consisting of the formula's label, its role, the TPTP formula, its Isabelle/HOL meaning, and @@ -35,7 +35,7 @@ problem_name : TPTP_Problem_Name.problem_name option} (*Generates a fresh Isabelle/HOL type for interpreting a TPTP type in a theory.*) - val declare_type : config -> (TPTP_Syntax.tptp_type * string) -> type_map -> + val declare_type : config -> string * (string * int) -> type_map -> theory -> type_map * theory (*Map TPTP types to Isabelle/HOL types*) @@ -132,9 +132,9 @@ (** Signatures and other type abbrevations **) -type const_map = (string * term) list +type const_map = (string * (term * int list)) list type var_types = (string * typ option) list -type type_map = (TPTP_Syntax.tptp_type * typ) list +type type_map = (string * (string * int)) list type tptp_formula_meaning = string * TPTP_Syntax.role * term * TPTP_Proof.source_info option type tptp_general_meaning = @@ -189,17 +189,19 @@ (*Returns updated theory and the name of the final type's name -- i.e. if the original name is already taken then the function looks for an available alternative. It also returns an updated type_map if one has been passed to it.*) -fun declare_type (config : config) (thf_type, type_name) ty_map thy = +fun declare_type (config : config) (thf_type, (type_name, arity)) ty_map thy = if type_exists config thy type_name then - raise MISINTERPRET_TYPE ("Type already exists", Atom_type type_name) + raise MISINTERPRET_TYPE ("Type already exists", Atom_type (type_name, [])) else let val binding = mk_binding config type_name val final_fqn = Sign.full_name thy binding + val tyargs = + List.tabulate (arity, rpair @{sort type} o prefix "'" o string_of_int) val thy' = - Typedecl.typedecl_global (mk_binding config type_name, [], NoSyn) thy + Typedecl.typedecl_global (mk_binding config type_name, tyargs, NoSyn) thy |> snd - val typ_map_entry = (thf_type, (Type (final_fqn, []))) + val typ_map_entry = (thf_type, (final_fqn, arity)) val ty_map' = typ_map_entry :: ty_map in (ty_map', thy') end @@ -217,42 +219,56 @@ raise MISINTERPRET_TERM ("Const already declared", Term_Func (Uninterpreted const_name, [])) else - Theory.specify_const - ((mk_binding config const_name, ty), NoSyn) thy - -fun declare_const_ifnot config const_name ty thy = - if const_exists config thy const_name then - (Sign.mk_const thy ((Sign.full_name thy (mk_binding config const_name)), []), thy) - else declare_constant config const_name ty thy + Theory.specify_const ((mk_binding config const_name, ty), NoSyn) thy (** Interpretation functions **) -(*Types in THF are encoded as formulas. This function translates them to type form.*) +(*Types in TFF/THF are encoded as formulas. These functions translate them to type form.*) + +fun termtype_to_type (Term_Func (TypeSymbol typ, [])) = + Defined_type typ + | termtype_to_type (Term_Func (Uninterpreted str, tms)) = + Atom_type (str, map termtype_to_type tms) + | termtype_to_type (Term_Var str) = Var_type str + (*FIXME possibly incomplete hack*) -fun fmlatype_to_type (Atom (THF_Atom_term (Term_Func (TypeSymbol typ, [])))) = - Defined_type typ - | fmlatype_to_type (Atom (THF_Atom_term (Term_Func (Uninterpreted str, [])))) = - Atom_type str +fun fmlatype_to_type (Atom (THF_Atom_term tm)) = termtype_to_type tm | fmlatype_to_type (Type_fmla (Fn_type (ty1, ty2))) = let val ty1' = case ty1 of Fn_type _ => fmlatype_to_type (Type_fmla ty1) | Fmla_type ty1 => fmlatype_to_type ty1 + | _ => ty1 val ty2' = case ty2 of Fn_type _ => fmlatype_to_type (Type_fmla ty2) | Fmla_type ty2 => fmlatype_to_type ty2 + | _ => ty2 in Fn_type (ty1', ty2') end + | fmlatype_to_type (Type_fmla ty) = ty + | fmlatype_to_type (Fmla (Uninterpreted str, fmla)) = + Atom_type (str, map fmlatype_to_type fmla) + | fmlatype_to_type (Quant (Dep_Prod, _, fmla)) = fmlatype_to_type fmla + | fmlatype_to_type (Pred (Interpreted_ExtraLogic Apply, [tm])) = + termtype_to_type tm + +fun tfree_name_of_var_type str = "'" ^ Name.desymbolize (SOME false) str +fun tfree_of_var_type str = TFree (tfree_name_of_var_type str, @{sort type}) fun interpret_type config thy type_map thf_ty = let - fun lookup_type ty_map thf_ty = - (case AList.lookup (op =) ty_map thf_ty of + fun lookup_type ty_map ary str = + (case AList.lookup (op =) ty_map str of NONE => - raise MISINTERPRET_TYPE + raise MISINTERPRET_SYMBOL ("Could not find the interpretation of this TPTP type in the \ - \mapping to Isabelle/HOL", thf_ty) - | SOME ty => ty) + \mapping to Isabelle/HOL", Uninterpreted str) + | SOME (str', ary') => + if ary' = ary then + str' + else + raise MISINTERPRET_SYMBOL ("TPTP type used with wrong arity", + Uninterpreted str)) in case thf_ty of Prod_type (thf_ty1, thf_ty2) => @@ -263,22 +279,19 @@ Type (@{type_name fun}, [interpret_type config thy type_map thf_ty1, interpret_type config thy type_map thf_ty2]) - | Atom_type _ => - lookup_type type_map thf_ty + | Atom_type (str, thf_tys) => + Type (lookup_type type_map (length thf_tys) str, + map (interpret_type config thy type_map) thf_tys) + | Var_type str => tfree_of_var_type str | Defined_type tptp_base_type => (case tptp_base_type of Type_Ind => @{typ ind} | Type_Bool => HOLogic.boolT | Type_Type => raise MISINTERPRET_TYPE ("No type interpretation", thf_ty) - (*FIXME these types are currently unsupported, so they're treated as - individuals*) - | Type_Int => - interpret_type config thy type_map (Defined_type Type_Ind) - | Type_Rat => - interpret_type config thy type_map (Defined_type Type_Ind) - | Type_Real => - interpret_type config thy type_map (Defined_type Type_Ind) - ) + | Type_Int => @{typ int} + | Type_Rat => @{typ rat} + | Type_Real => @{typ real} + | Type_Dummy => dummyT) | Sum_type _ => raise MISINTERPRET_TYPE (*FIXME*) ("No type interpretation (sum type)", thf_ty) @@ -290,19 +303,15 @@ ("No type interpretation (subtype)", thf_ty) end -fun the_const config thy language const_map_payload str = - if language = THF then - (case AList.lookup (op =) const_map_payload str of - NONE => raise MISINTERPRET_TERM - ("Could not find the interpretation of this constant in the \ - \mapping to Isabelle/HOL", Term_Func (Uninterpreted str, [])) - | SOME t => t) - else - if const_exists config thy str then - Sign.mk_const thy ((Sign.full_name thy (mk_binding config str)), []) - else raise MISINTERPRET_TERM - ("Could not find the interpretation of this constant in the \ - \mapping to Isabelle/HOL", Term_Func (Uninterpreted str, [])) +fun permute_type_args perm Ts = map (nth Ts) perm + +fun the_const thy const_map str tyargs = + (case AList.lookup (op =) const_map str of + SOME (Const (s, _), tyarg_perm) => + Sign.mk_const thy (s, permute_type_args tyarg_perm tyargs) + | _ => raise MISINTERPRET_TERM + ("Could not find the interpretation of this constant in the \ + \mapping to Isabelle/HOL", Term_Func (Uninterpreted str, []))) (*Eta-expands n-ary function. "str" is the name of an Isabelle/HOL constant*) @@ -346,18 +355,24 @@ | Is_Int => 1 | Is_Rat => 1 | Distinct => 1 - | Apply=> 2 + | Apply => 2 -fun interpret_symbol config language const_map symb thy = +fun type_arity_of_symbol thy config (Uninterpreted n) = + let val s = full_name thy config n in + length (Sign.const_typargs thy (s, Sign.the_const_type thy s)) + end + | type_arity_of_symbol _ _ _ = 0 + +fun interpret_symbol config const_map symb tyargs thy = case symb of Uninterpreted n => (*Constant would have been added to the map at the time of declaration*) - the_const config thy language const_map n + the_const thy const_map n tyargs | Interpreted_ExtraLogic interpreted_symbol => (*FIXME not interpreting*) Sign.mk_const thy ((Sign.full_name thy (mk_binding config - (string_of_interpreted_symbol interpreted_symbol))), []) + (string_of_interpreted_symbol interpreted_symbol))), tyargs) | Interpreted_Logic logic_symbol => (case logic_symbol of Equals => HOLogic.eq_const dummyT @@ -427,16 +442,14 @@ in case symb of Uninterpreted const_name => - declare_const_ifnot config const_name - (mk_fun_type (replicate (length tptp_ts) ind_type) value_type I) thy' - |> snd + perhaps (try (snd o declare_constant config const_name + (mk_fun_type (replicate (length tptp_ts) ind_type) value_type I))) thy' | _ => thy' end | Atom_App _ => thy | Atom_Arity (const_name, n_args) => - declare_const_ifnot config const_name - (mk_fun_type (replicate n_args ind_type) value_type I) thy - |> snd + perhaps (try (snd o declare_constant config const_name + (mk_fun_type (replicate n_args ind_type) value_type I))) thy end (*FIXME only used until interpretation is implemented*) @@ -499,24 +512,32 @@ (interpret_term formula_level config language const_map var_types type_map (hd tptp_ts))) | _ => - (*apply symb to tptp_ts*) - if is_prod_typed thy' config symb then - let - val (t, thy'') = - mtimes' - (fold_map (interpret_term false config language const_map - var_types type_map) (tl tptp_ts) thy') - (interpret_term false config language const_map - var_types type_map (hd tptp_ts)) - in (interpret_symbol config language const_map symb thy' $ t, thy'') - end - else - ( - mapply' - (fold_map (interpret_term false config language const_map - var_types type_map) tptp_ts thy') - (`(interpret_symbol config language const_map symb)) - ) + let + val typ_arity = type_arity_of_symbol thy config symb + val (tptp_type_args, tptp_term_args) = chop typ_arity tptp_ts + val tyargs = + map (interpret_type config thy type_map o termtype_to_type) + tptp_type_args + in + (*apply symb to tptp_ts*) + if is_prod_typed thy' config symb then + let + val (t, thy'') = + mtimes' + (fold_map (interpret_term false config language const_map + var_types type_map) (tl tptp_term_args) thy') + (interpret_term false config language const_map + var_types type_map (hd tptp_term_args)) + in (interpret_symbol config const_map symb tyargs thy' $ t, thy'') + end + else + ( + mapply' + (fold_map (interpret_term false config language const_map + var_types type_map) tptp_term_args thy') + (`(interpret_symbol config const_map symb tyargs)) + ) + end end | Term_Var n => (if language = THF orelse language = TFF then @@ -543,14 +564,12 @@ | Term_Num (number_kind, num) => let (*FIXME hack*) - val ind_type = interpret_type config thy type_map (Defined_type Type_Ind) - val prefix = case number_kind of - Int_num => "intn_" - | Real_num => "realn_" - | Rat_num => "ratn_" - (*FIXME hack -- for Int_num should be - HOLogic.mk_number @{typ "int"} (the (Int.fromString num))*) - in declare_const_ifnot config (prefix ^ num) ind_type thy end + val tptp_type = case number_kind of + Int_num => Type_Int + | Real_num => Type_Real + | Rat_num => Type_Rat + val T = interpret_type config thy type_map (Defined_type tptp_type) + in (HOLogic.mk_number T (the (Int.fromString num)), thy) end | Term_Distinct_Object str => declare_constant config ("do_" ^ str) (interpret_type config thy type_map (Defined_type Type_Ind)) thy @@ -577,11 +596,9 @@ (Atom_Arity (const_name, length tptp_formulas)) thy' in (if is_prod_typed thy' config symbol then - mtimes thy' args (interpret_symbol config language - const_map symbol thy') + mtimes thy' args (interpret_symbol config const_map symbol [] thy') else - mapply args - (interpret_symbol config language const_map symbol thy'), + mapply args (interpret_symbol config const_map symbol [] thy'), thy') end | _ => @@ -593,11 +610,9 @@ tptp_formulas thy in (if is_prod_typed thy' config symbol then - mtimes thy' args (interpret_symbol config language - const_map symbol thy') + mtimes thy' args (interpret_symbol config const_map symbol [] thy') else - mapply args - (interpret_symbol config language const_map symbol thy'), + mapply args (interpret_symbol config const_map symbol [] thy'), thy') end) | Sequent _ => @@ -669,12 +684,12 @@ (case tptp_atom of TFF_Typed_Atom (symbol, tptp_type_opt) => (*FIXME ignoring type info*) - (interpret_symbol config language const_map symbol thy, thy) + (interpret_symbol config const_map symbol [] thy, thy) | THF_Atom_term tptp_term => interpret_term true config language const_map var_types type_map tptp_term thy | THF_Atom_conn_term symbol => - (interpret_symbol config language const_map symbol thy, thy)) + (interpret_symbol config const_map symbol [] thy, thy)) | Type_fmla _ => raise MISINTERPRET_FORMULA ("Cannot interpret types as formulas", tptp_fmla) @@ -684,20 +699,31 @@ (*Extract the type from a typing*) local + fun type_vars_of_fmlatype (Quant (Dep_Prod, varlist, fmla)) = + map fst varlist @ type_vars_of_fmlatype fmla + | type_vars_of_fmlatype _ = [] + fun extract_type tptp_type = case tptp_type of - Fmla_type typ => fmlatype_to_type typ - | _ => tptp_type + Fmla_type fmla => (type_vars_of_fmlatype fmla, fmlatype_to_type fmla) + | _ => ([], tptp_type) in fun typeof_typing (THF_typing (_, tptp_type)) = extract_type tptp_type fun typeof_tff_typing (Atom (TFF_Typed_Atom (_, SOME tptp_type))) = extract_type tptp_type end + fun nameof_typing (THF_typing ((Atom (THF_Atom_term (Term_Func (Uninterpreted str, [])))), _)) = str fun nameof_tff_typing (Atom (TFF_Typed_Atom (Uninterpreted str, _))) = str +fun strip_prod_type (Prod_type (ty1, ty2)) = ty1 :: strip_prod_type ty2 + | strip_prod_type ty = [ty] + +fun dest_fn_type (Fn_type (ty1, ty2)) = (strip_prod_type ty1, ty2) + | dest_fn_type ty = ([], ty) + fun resolve_include_path path_prefixes path_suffix = case find_first (fn prefix => File.exists (Path.append prefix path_suffix)) path_prefixes of @@ -705,6 +731,15 @@ | NONE => error ("Cannot find include file " ^ quote (Path.implode path_suffix)) +(* Ideally, to be in sync with TFF1, we should perform full type skolemization here. + But the problems originating from HOL systems are restricted to top-level + universal quantification for types. *) +fun remove_leading_type_quantifiers (Quant (Forall, varlist, tptp_fmla)) = + (case filter_out (curry (op =) (SOME (Defined_type Type_Type)) o snd) varlist of + [] => remove_leading_type_quantifiers tptp_fmla + | varlist' => Quant (Forall, varlist', tptp_fmla)) + | remove_leading_type_quantifiers tptp_fmla = tptp_fmla + fun interpret_line config inc_list type_map const_map path_prefixes line thy = case line of Include (_, quoted_path, inc_list) => @@ -725,7 +760,7 @@ case role of Role_Type => let - val (tptp_ty, name) = + val ((tptp_type_vars, tptp_ty), name) = if lang = THF then (typeof_typing tptp_formula (*assuming tptp_formula is a typing*), nameof_typing tptp_formula (*and that the LHS is a (atom) name*)) @@ -733,22 +768,15 @@ (typeof_tff_typing tptp_formula, nameof_tff_typing tptp_formula) in - case tptp_ty of - Defined_type Type_Type => (*add new type*) + case dest_fn_type tptp_ty of + (tptp_binders, Defined_type Type_Type) => (*add new type*) (*generate an Isabelle/HOL type to interpret this TPTP type, and add it to both the Isabelle/HOL theory and to the type_map*) let val (type_map', thy') = - declare_type - config - (Atom_type name, name) - type_map - thy - in ((type_map', - const_map, - []), - thy') - end + declare_type config + (name, (name, length tptp_binders)) type_map thy + in ((type_map', const_map, []), thy') end | _ => (*declaration of constant*) (*Here we populate the map from constants to the Isabelle/HOL @@ -758,7 +786,7 @@ (*make sure that the theory contains all the types appearing in this constant's signature. Exception is thrown if encounter an undeclared types.*) - val (t, thy') = + val (t as Const (name', _), thy') = let fun analyse_type thy thf_ty = if #cautious config then @@ -766,13 +794,13 @@ Fn_type (thf_ty1, thf_ty2) => (analyse_type thy thf_ty1; analyse_type thy thf_ty2) - | Atom_type ty_name => + | Atom_type (ty_name, _) => if type_exists config thy ty_name then () else raise MISINTERPRET_TYPE ("Type (in signature of " ^ name ^ ") has not been declared", - Atom_type ty_name) + Atom_type (ty_name, [])) | _ => () else () (*skip test if we're not being cautious.*) in @@ -784,7 +812,19 @@ use "::". Note that here we use a constant's name rather than the possibly- new one, since all references in the theory will be to this name.*) - val const_map' = ((name, t) :: const_map) + + val tf_tyargs = map tfree_of_var_type tptp_type_vars + val isa_tyargs = Sign.const_typargs thy' (name', ty) + val _ = + if length isa_tyargs < length tf_tyargs then + raise MISINTERPRET_SYMBOL + ("Cannot handle phantom types for constant", + Uninterpreted name) + else + () + val tyarg_perm = + map (fn T => find_index (curry (op =) T) tf_tyargs) isa_tyargs + val const_map' = ((name, (t, tyarg_perm)) :: const_map) in ((type_map,(*type_map unchanged, since a constant's declaration shouldn't include any new types.*) const_map',(*typing table of constant was extended*) @@ -798,7 +838,7 @@ (*gather interpreted term, and the map of types occurring in that term*) val (t, thy') = interpret_formula config lang - const_map [] type_map tptp_formula thy + const_map [] type_map (remove_leading_type_quantifiers tptp_formula) thy |>> HOLogic.mk_Trueprop (*type_maps grow monotonically, so return the newest value (type_mapped); there's no need to unify it with the type_map parameter.*) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/tptp_lexyacc.ML --- a/src/HOL/TPTP/TPTP_Parser/tptp_lexyacc.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/tptp_lexyacc.ML Wed Aug 27 15:52:58 2014 +0200 @@ -174,9 +174,9 @@ \\000" ), (1, -"\000\000\000\000\000\000\000\000\000\142\144\000\000\143\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\142\138\133\000\101\089\088\083\082\081\080\078\077\072\070\057\ +"\000\000\000\000\000\000\000\000\000\143\145\000\000\144\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\143\139\134\000\101\089\088\083\082\081\080\078\077\072\070\057\ \\048\048\048\048\048\048\048\048\048\048\045\000\039\037\036\033\ \\030\029\029\029\029\029\029\029\029\029\029\029\029\029\029\029\ \\029\029\029\029\029\029\029\029\029\029\029\028\000\027\026\000\ @@ -847,10 +847,10 @@ (101, "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\131\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\132\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\131\ \\000\102\102\128\102\102\124\102\102\118\102\102\108\102\102\102\ \\102\102\102\102\103\102\102\102\102\102\102\000\000\000\000\000\ \\000" @@ -1053,76 +1053,76 @@ \\102\102\102\102\102\102\102\102\102\102\102\000\000\000\000\000\ \\000" ), - (131, -"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\132\132\132\132\132\132\132\132\132\132\132\132\132\132\132\ -\\132\132\132\132\132\132\132\132\132\132\132\000\000\000\000\000\ -\\000" -), (132, "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\132\132\132\132\132\132\132\132\132\132\000\000\000\000\000\000\ -\\000\132\132\132\132\132\132\132\132\132\132\132\132\132\132\132\ -\\132\132\132\132\132\132\132\132\132\132\132\000\000\000\000\132\ -\\000\132\132\132\132\132\132\132\132\132\132\132\132\132\132\132\ -\\132\132\132\132\132\132\132\132\132\132\132\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\133\133\133\133\133\133\133\133\133\133\133\133\133\133\133\ +\\133\133\133\133\133\133\133\133\133\133\133\000\000\000\000\000\ \\000" ), (133, -"\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\000\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\137\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134" +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\133\133\133\133\133\133\133\133\133\133\000\000\000\000\000\000\ +\\000\133\133\133\133\133\133\133\133\133\133\133\133\133\133\133\ +\\133\133\133\133\133\133\133\133\133\133\133\000\000\000\000\133\ +\\000\133\133\133\133\133\133\133\133\133\133\133\133\133\133\133\ +\\133\133\133\133\133\133\133\133\133\133\133\000\000\000\000\000\ +\\000" ), (134, -"\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\136\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\135\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\134\ -\\134" +"\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\000\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\138\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135" ), (135, +"\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\137\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\136\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\135\ +\\135" +), + (136, "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\134\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\134\000\000\000\ +\\000\000\135\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\135\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" ), - (138, + (139, "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\141\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\140\139\000\ +\\000\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\141\140\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" ), - (142, -"\000\000\000\000\000\000\000\000\000\142\000\000\000\000\000\000\ -\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + (143, +"\000\000\000\000\000\000\000\000\000\143\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\143\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -1130,8 +1130,8 @@ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000" ), - (143, -"\000\000\000\000\000\000\000\000\000\000\144\000\000\000\000\000\ + (144, +"\000\000\000\000\000\000\000\000\000\000\145\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -1143,12 +1143,12 @@ ), (0, "")] fun f x = x -val s = map f (rev (tl (rev s))) +val s = List.map f (List.rev (tl (List.rev s))) exception LexHackingError fun look ((j,x)::r, i: int) = if i = j then x else look(r, i) | look ([], i) = raise LexHackingError fun g {fin=x, trans=i} = {fin=x, trans=look(s,i)} -in Vector.fromList(map g +in Vector.fromList(List.map g [{fin = [], trans = 0}, {fin = [(N 2)], trans = 1}, {fin = [(N 2)], trans = 1}, @@ -1184,7 +1184,7 @@ {fin = [(N 12)], trans = 0}, {fin = [(N 78)], trans = 33}, {fin = [(N 21)], trans = 0}, -{fin = [(N 303)], trans = 0}, +{fin = [(N 306)], trans = 0}, {fin = [(N 38)], trans = 0}, {fin = [(N 31)], trans = 37}, {fin = [(N 48)], trans = 0}, @@ -1193,10 +1193,10 @@ {fin = [(N 68)], trans = 0}, {fin = [(N 41)], trans = 42}, {fin = [(N 45)], trans = 0}, -{fin = [(N 297)], trans = 0}, +{fin = [(N 300)], trans = 0}, {fin = [(N 27)], trans = 45}, {fin = [(N 36)], trans = 0}, -{fin = [(N 306)], trans = 0}, +{fin = [(N 309)], trans = 0}, {fin = [(N 126)], trans = 48}, {fin = [], trans = 49}, {fin = [(N 104)], trans = 49}, @@ -1225,11 +1225,11 @@ {fin = [(N 55)], trans = 0}, {fin = [(N 123)], trans = 74}, {fin = [(N 58)], trans = 75}, -{fin = [(N 294)], trans = 0}, +{fin = [(N 297)], trans = 0}, {fin = [(N 29)], trans = 0}, -{fin = [(N 288)], trans = 78}, +{fin = [(N 291)], trans = 78}, {fin = [(N 76)], trans = 0}, -{fin = [(N 290)], trans = 0}, +{fin = [(N 293)], trans = 0}, {fin = [(N 82)], trans = 0}, {fin = [(N 52)], trans = 0}, {fin = [], trans = 83}, @@ -1280,19 +1280,20 @@ {fin = [(N 278)], trans = 128}, {fin = [(N 278)], trans = 129}, {fin = [(N 209),(N 278)], trans = 102}, -{fin = [], trans = 131}, -{fin = [(N 286)], trans = 132}, -{fin = [], trans = 133}, +{fin = [(N 281)], trans = 0}, +{fin = [], trans = 132}, +{fin = [(N 289)], trans = 133}, {fin = [], trans = 134}, {fin = [], trans = 135}, +{fin = [], trans = 136}, {fin = [(N 95)], trans = 0}, -{fin = [], trans = 135}, -{fin = [(N 33)], trans = 138}, -{fin = [(N 300)], trans = 0}, +{fin = [], trans = 136}, +{fin = [(N 33)], trans = 139}, +{fin = [(N 303)], trans = 0}, {fin = [(N 64)], trans = 0}, {fin = [(N 18)], trans = 0}, -{fin = [(N 2)], trans = 142}, -{fin = [(N 7)], trans = 143}, +{fin = [(N 2)], trans = 143}, +{fin = [(N 7)], trans = 144}, {fin = [(N 7)], trans = 0}]) end structure StartStates = @@ -1328,7 +1329,7 @@ | action (i,(node::acts)::l) = case node of Internal.N yyk => - (let fun yymktext() = substring(!yyb,i0,i-i0) + (let fun yymktext() = String.substring(!yyb,i0,i-i0) val yypos = i0+ !yygone open UserDeclarations Internal.StartStates in (yybufpos := i; case yyk of @@ -1369,15 +1370,16 @@ | 27 => (col:=yypos-(!eolpos); T.COLON(!linep,!col)) | 271 => let val yytext=yymktext() in col:=yypos-(!eolpos); T.LOWER_WORD(yytext,!linep,!col) end | 278 => let val yytext=yymktext() in col:=yypos-(!eolpos); T.DOLLAR_WORD(yytext,!linep,!col) end -| 286 => let val yytext=yymktext() in col:=yypos-(!eolpos); T.DOLLAR_DOLLAR_WORD(yytext,!linep,!col) end -| 288 => (col:=yypos-(!eolpos); T.PLUS(!linep,!col)) +| 281 => let val yytext=yymktext() in col:=yypos-(!eolpos); T.DOLLAR_WORD(yytext,!linep,!col) end +| 289 => let val yytext=yymktext() in col:=yypos-(!eolpos); T.DOLLAR_DOLLAR_WORD(yytext,!linep,!col) end | 29 => (col:=yypos-(!eolpos); T.COMMA(!linep,!col)) -| 290 => (col:=yypos-(!eolpos); T.TIMES(!linep,!col)) -| 294 => (col:=yypos-(!eolpos); T.GENTZEN_ARROW(!linep,!col)) -| 297 => (col:=yypos-(!eolpos); T.SUBTYPE(!linep,!col)) -| 300 => (col:=yypos-(!eolpos); T.DEP_PROD(!linep,!col)) -| 303 => (col:=yypos-(!eolpos); T.DEP_SUM(!linep,!col)) -| 306 => (col:=yypos-(!eolpos); T.LET_TERM(!linep,!col)) +| 291 => (col:=yypos-(!eolpos); T.PLUS(!linep,!col)) +| 293 => (col:=yypos-(!eolpos); T.TIMES(!linep,!col)) +| 297 => (col:=yypos-(!eolpos); T.GENTZEN_ARROW(!linep,!col)) +| 300 => (col:=yypos-(!eolpos); T.SUBTYPE(!linep,!col)) +| 303 => (col:=yypos-(!eolpos); T.DEP_PROD(!linep,!col)) +| 306 => (col:=yypos-(!eolpos); T.DEP_SUM(!linep,!col)) +| 309 => (col:=yypos-(!eolpos); T.LET_TERM(!linep,!col)) | 31 => (col:=yypos-(!eolpos); T.EQUALS(!linep,!col)) | 33 => (col:=yypos-(!eolpos); T.EXCLAMATION(!linep,!col)) | 36 => (col:=yypos-(!eolpos); T.LET(!linep,!col)) @@ -1414,14 +1416,14 @@ if trans = #trans(Vector.sub(Internal.tab,0)) then action(l,NewAcceptingLeaves ) else let val newchars= if !yydone then "" else yyinput 1024 - in if (size newchars)=0 + in if (String.size newchars)=0 then (yydone := true; if (l=i0) then UserDeclarations.eof yyarg else action(l,NewAcceptingLeaves)) else (if i0=l then yyb := newchars - else yyb := substring(!yyb,i0,l-i0)^newchars; + else yyb := String.substring(!yyb,i0,l-i0)^newchars; yygone := !yygone+i0; - yybl := size (!yyb); + yybl := String.size (!yyb); scan (s,AcceptingLeaves,l-i0,0)) end else let val NewChar = Char.ord(String.sub(!yyb,l)) @@ -1432,7 +1434,7 @@ end end (* - val start= if substring(!yyb,!yybufpos-1,1)="\n" + val start= if String.substring(!yyb,!yybufpos-1,1)="\n" then !yybegin+1 else !yybegin *) in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos) @@ -3604,7 +3606,7 @@ fun f i = if i=numstates then g i else (Array.update(memo,i,SHIFT (STATE i)); f (i+1)) - in f 0 handle Subscript => () + in f 0 handle General.Subscript => () end in val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2)) @@ -3614,7 +3616,7 @@ val actionRowNumbers = string_to_list actionRowNumbers val actionT = let val actionRowLookUp= let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end -in Array.fromList(map actionRowLookUp actionRowNumbers) +in Array.fromList(List.map actionRowLookUp actionRowNumbers) end in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules, numStates=numstates,initialState=STATE 0} @@ -4851,7 +4853,7 @@ end | ( 135, ( ( _, ( MlyValue.atomic_word atomic_word, atomic_word1left, atomic_word1right)) :: rest671)) => let val result = -MlyValue.tff_atomic_type (( Atom_type atomic_word )) +MlyValue.tff_atomic_type (( Atom_type (atomic_word, []) )) in ( LrTable.NT 79, ( result, atomic_word1left, atomic_word1right), rest671) end @@ -5316,6 +5318,7 @@ | "$real" => Type_Real | "$rat" => Type_Rat | "$int" => Type_Int + | "$_" => Type_Dummy | thing => raise UNRECOGNISED_SYMBOL ("defined_type", thing) ) ) @@ -5590,6 +5593,7 @@ | "$real" => TypeSymbol Type_Real | "$rat" => TypeSymbol Type_Rat | "$tType" => TypeSymbol Type_Type + | "$_" => TypeSymbol Type_Dummy | "$true" => Interpreted_Logic True | "$false" => Interpreted_Logic False diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Parser/tptp_syntax.ML --- a/src/HOL/TPTP/TPTP_Parser/tptp_syntax.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Parser/tptp_syntax.ML Wed Aug 27 15:52:58 2014 +0200 @@ -66,7 +66,7 @@ Forall | Exists | Epsilon | Iota | Lambda | Dep_Prod | Dep_Sum and tptp_base_type = - Type_Ind | Type_Bool | Type_Type | Type_Int | Type_Rat | Type_Real + Type_Ind | Type_Bool | Type_Type | Type_Int | Type_Rat | Type_Real | Type_Dummy and symbol = Uninterpreted of string @@ -111,7 +111,8 @@ and tptp_type = Prod_type of tptp_type * tptp_type | Fn_type of tptp_type * tptp_type - | Atom_type of string + | Atom_type of string * tptp_type list + | Var_type of string | Defined_type of tptp_base_type | Sum_type of tptp_type * tptp_type (*only THF*) | Fmla_type of tptp_formula @@ -141,8 +142,6 @@ val status_to_string : status_value -> string - val nameof_tff_atom_type : tptp_type -> string - val pos_of_line : tptp_line -> position (*Returns the list of all files included in a directory and its @@ -216,7 +215,7 @@ Forall | Exists | Epsilon | Iota | Lambda | Dep_Prod | Dep_Sum and tptp_base_type = - Type_Ind | Type_Bool | Type_Type | Type_Int | Type_Rat | Type_Real + Type_Ind | Type_Bool | Type_Type | Type_Int | Type_Rat | Type_Real | Type_Dummy and symbol = Uninterpreted of string @@ -261,7 +260,8 @@ and tptp_type = Prod_type of tptp_type * tptp_type | Fn_type of tptp_type * tptp_type - | Atom_type of string + | Atom_type of string * tptp_type list + | Var_type of string | Defined_type of tptp_base_type | Sum_type of tptp_type * tptp_type | Fmla_type of tptp_formula @@ -287,9 +287,6 @@ fun debug f x = if Options.default_bool @{system_option ML_exception_trace} then (f x; ()) else () -fun nameof_tff_atom_type (Atom_type str) = str - | nameof_tff_atom_type _ = raise TPTP_SYNTAX "nameof_tff_atom_type called on non-atom type" - fun pos_of_line tptp_line = case tptp_line of Annotated_Formula (position, _, _, _, _, _) => position @@ -428,6 +425,7 @@ | string_of_tptp_base_type Type_Int = "$int" | string_of_tptp_base_type Type_Rat = "$rat" | string_of_tptp_base_type Type_Real = "$real" + | string_of_tptp_base_type Type_Dummy = "$_" and string_of_interpreted_symbol x = case x of @@ -517,7 +515,10 @@ string_of_tptp_type tptp_type1 ^ " * " ^ string_of_tptp_type tptp_type2 | string_of_tptp_type (Fn_type (tptp_type1, tptp_type2)) = string_of_tptp_type tptp_type1 ^ " > " ^ string_of_tptp_type tptp_type2 - | string_of_tptp_type (Atom_type str) = str + | string_of_tptp_type (Atom_type (str, [])) = str + | string_of_tptp_type (Atom_type (str, tptp_types)) = + str ^ "(" ^ commas (map string_of_tptp_type tptp_types) ^ ")" + | string_of_tptp_type (Var_type str) = str | string_of_tptp_type (Defined_type tptp_base_type) = string_of_tptp_base_type tptp_base_type | string_of_tptp_type (Sum_type (tptp_type1, tptp_type2)) = "" @@ -565,6 +566,7 @@ | latex_of_tptp_base_type Type_Int = "\\\\mathsf{int} " | latex_of_tptp_base_type Type_Rat = "\\\\mathsf{rat} " | latex_of_tptp_base_type Type_Real = "\\\\mathsf{real} " + | latex_of_tptp_base_type Type_Dummy = "\\\\mathsf{\\\\_} " and latex_of_interpreted_symbol x = case x of @@ -687,7 +689,10 @@ latex_of_tptp_type tptp_type1 ^ " \\\\times " ^ latex_of_tptp_type tptp_type2 | latex_of_tptp_type (Fn_type (tptp_type1, tptp_type2)) = latex_of_tptp_type tptp_type1 ^ " \\\\to " ^ latex_of_tptp_type tptp_type2 - | latex_of_tptp_type (Atom_type str) = "\\\\mathrm{" ^ str ^ "}" + | latex_of_tptp_type (Atom_type (str, [])) = "\\\\mathrm{" ^ str ^ "}" + | latex_of_tptp_type (Atom_type (str, tptp_types)) = + "\\\\mathrm{" ^ str ^ "}(" ^ commas (map latex_of_tptp_type tptp_types) ^ ")" + | latex_of_tptp_type (Var_type str) = "\\\\mathrm{" ^ str ^ "}" | latex_of_tptp_type (Defined_type tptp_base_type) = latex_of_tptp_base_type tptp_base_type | latex_of_tptp_type (Sum_type (tptp_type1, tptp_type2)) = "" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Proof_Reconstruction.thy --- a/src/HOL/TPTP/TPTP_Proof_Reconstruction.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Proof_Reconstruction.thy Wed Aug 27 15:52:58 2014 +0200 @@ -2116,7 +2116,10 @@ in case inference_name of "fo_atp_e" => + HEADGOAL (Metis_Tactic.metis_tac [] ATP_Problem_Generate.combs_or_liftingN ctxt []) + (*NOTE To treat E as an oracle use the following line: HEADGOAL (etac (oracle_based_reconstruction_tac ctxt prob_name node)) + *) | "copy" => HEADGOAL (atac @@ -2284,4 +2287,4 @@ end *} -end \ No newline at end of file +end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/TPTP_Proof_Reconstruction_Test.thy --- a/src/HOL/TPTP/TPTP_Proof_Reconstruction_Test.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/TPTP_Proof_Reconstruction_Test.thy Wed Aug 27 15:52:58 2014 +0200 @@ -249,7 +249,7 @@ (*given a list of tactics to be applied in sequence (i.e., they follow a skeleton), we build a single tactic, interleaving some tracing info to help with debugging.*) -fun step_by_step_tacs verbose (thm_tacs : (thm * tactic) list) : tactic = +fun step_by_step_tacs ctxt verbose (thm_tacs : (thm * tactic) list) : tactic = let fun interleave_tacs [] [] = all_tac | interleave_tacs (tac1 :: tacs1) (tac2 :: tacs2) = @@ -258,7 +258,7 @@ val thms_to_traceprint = map (fn thm => fn st => (*FIXME uses makestring*) - print_tac (PolyML.makestring thm) st) + print_tac ctxt (PolyML.makestring thm) st) in if verbose then @@ -272,9 +272,9 @@ ML {* (*apply step_by_step_tacs to all problems under test*) -val narrated_tactics = +fun narrated_tactics ctxt = map (map (#3 #> the) - #> step_by_step_tacs false) + #> step_by_step_tacs ctxt false) the_tactics; (*produce thm*) @@ -284,7 +284,7 @@ map (fn (prob_name, tac) => TPTP_Reconstruct.reconstruct @{context} (fn _ => tac) prob_name) - (ListPair.zip (prob_names, narrated_tactics)) + (ListPair.zip (prob_names, narrated_tactics @{context})) *} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/atp_problem_import.ML --- a/src/HOL/TPTP/atp_problem_import.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/atp_problem_import.ML Wed Aug 27 15:52:58 2014 +0200 @@ -13,7 +13,8 @@ val refute_tptp_file : theory -> int -> string -> unit val can_tac : Proof.context -> tactic -> term -> bool val SOLVE_TIMEOUT : int -> string -> tactic -> tactic - val atp_tac : Proof.context -> int -> (string * string) list -> int -> string -> int -> tactic + val atp_tac : Proof.context -> int -> (string * string) list -> int -> term list -> string -> + int -> tactic val smt_solver_tac : string -> Proof.context -> int -> tactic val freeze_problem_consts : theory -> term -> term val make_conj : term list * term list -> term list -> term @@ -45,20 +46,18 @@ fun read_tptp_file thy postproc file_name = let fun has_role role (_, role', _, _) = (role' = role) - fun get_prop (name, role, P, info) = - let val P' = P |> Logic.varify_global |> close_form in - (name, P') |> postproc - end + fun get_prop f (name, _, P, _) = P |> f |> close_form |> pair name |> postproc + val path = exploded_absolute_path file_name val ((_, _, problem), thy) = - TPTP_Interpret.interpret_file true [Path.dir path, Path.explode "$TPTP"] - path [] [] thy - val (conjs, defs_and_nondefs) = - problem |> List.partition (has_role TPTP_Syntax.Role_Conjecture) - ||> List.partition (has_role TPTP_Syntax.Role_Definition) + TPTP_Interpret.interpret_file true [Path.dir path, Path.explode "$TPTP"] path [] [] thy + val (conjs, defs_and_nondefs) = problem + |> List.partition (has_role TPTP_Syntax.Role_Conjecture) + ||> List.partition (has_role TPTP_Syntax.Role_Definition) in - (map get_prop conjs, pairself (map get_prop) defs_and_nondefs, - thy |> Proof_Context.init_global) + (map (get_prop I) conjs, + pairself (map (get_prop Logic.varify_global)) defs_and_nondefs, + Named_Target.theory_init thy) end @@ -76,12 +75,10 @@ let val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy snd file_name val thy = Proof_Context.theory_of ctxt - val (defs, pseudo_defs) = - defs |> map (ATP_Util.abs_extensionalize_term ctxt - #> aptrueprop (hol_open_form I)) - |> List.partition (is_legitimate_tptp_def - o perhaps (try HOLogic.dest_Trueprop) - o ATP_Util.unextensionalize_def) + val (defs, pseudo_defs) = defs + |> map (ATP_Util.abs_extensionalize_term ctxt #> aptrueprop (hol_open_form I)) + |> List.partition (is_legitimate_tptp_def o perhaps (try HOLogic.dest_Trueprop) + o ATP_Util.unextensionalize_def) val nondefs = pseudo_defs @ nondefs val state = Proof.init ctxt val params = @@ -104,8 +101,8 @@ val step = 0 val subst = [] in - Nitpick.pick_nits_in_term state params Nitpick.TPTP i n step subst - defs nondefs (case conjs of conj :: _ => conj | [] => @{prop True}); + Nitpick.pick_nits_in_term state params Nitpick.TPTP i n step subst defs nondefs + (case conjs of conj :: _ => conj | [] => @{prop True}); () end @@ -127,7 +124,7 @@ ("maxvars", "100000")] in Refute.refute_term ctxt params (defs @ nondefs) - (case conjs of conj :: _ => conj | [] => @{prop True}) + (case conjs of conj :: _ => conj | [] => @{prop True}) |> print_szs_of_outcome (not (null conjs)) end @@ -138,17 +135,16 @@ fun SOLVE_TIMEOUT seconds name tac st = let - val _ = Output.urgent_message ("running " ^ name ^ " for " ^ - string_of_int seconds ^ " s") + val _ = Output.urgent_message ("running " ^ name ^ " for " ^ string_of_int seconds ^ " s") val result = - TimeLimit.timeLimit (Time.fromSeconds seconds) - (fn () => SINGLE (SOLVE tac) st) () - handle TimeLimit.TimeOut => NONE - | ERROR _ => NONE + TimeLimit.timeLimit (Time.fromSeconds seconds) (fn () => SINGLE (SOLVE tac) st) () + handle + TimeLimit.TimeOut => NONE + | ERROR _ => NONE in - case result of + (case result of NONE => (Output.urgent_message ("FAILURE: " ^ name); Seq.empty) - | SOME st' => (Output.urgent_message ("SUCCESS: " ^ name); Seq.single st') + | SOME st' => (Output.urgent_message ("SUCCESS: " ^ name); Seq.single st')) end fun nitpick_finite_oracle_tac ctxt timeout i th = @@ -157,6 +153,7 @@ | is_safe @{typ prop} = true | is_safe @{typ bool} = true | is_safe _ = false + val conj = Thm.term_of (Thm.cprem_of th i) in if exists_type (not o is_safe) conj then @@ -179,40 +176,43 @@ val step = 0 val subst = [] val (outcome, _) = - Nitpick.pick_nits_in_term state params Nitpick.Normal i n step subst - [] [] conj - in if outcome = "none" then ALLGOALS Skip_Proof.cheat_tac th else Seq.empty end + Nitpick.pick_nits_in_term state params Nitpick.Normal i n step subst [] [] conj + in + if outcome = "none" then ALLGOALS Skip_Proof.cheat_tac th else Seq.empty + end end -fun atp_tac ctxt completeness override_params timeout prover = +fun atp_tac ctxt completeness override_params timeout assms prover = let - val ctxt = - ctxt |> Config.put Sledgehammer_Prover_ATP.atp_completish (completeness > 0) + val thy = Proof_Context.theory_of ctxt + val assm_ths0 = map (Skip_Proof.make_thm thy) assms + val ((assm_name, _), ctxt) = ctxt + |> Config.put Sledgehammer_Prover_ATP.atp_completish (completeness > 0) + |> Local_Theory.note ((@{binding thms}, []), assm_ths0) + fun ref_of th = (Facts.named (Thm.derivation_name th), []) + val ref_of_assms = (Facts.named assm_name, []) in Sledgehammer_Tactics.sledgehammer_as_oracle_tac ctxt - ([("debug", if debug then "true" else "false"), - ("overlord", if overlord then "true" else "false"), - ("provers", prover), - ("timeout", string_of_int timeout)] @ - (if completeness > 0 then - [("type_enc", - if completeness = 1 then "mono_native" else "poly_tags")] - else - []) @ - override_params) - {add = map ref_of [ext, @{thm someI}], del = [], only = true} + ([("debug", if debug then "true" else "false"), + ("overlord", if overlord then "true" else "false"), + ("provers", prover), + ("timeout", string_of_int timeout)] @ + (if completeness > 0 then + [("type_enc", if completeness = 1 then "mono_native" else "poly_tags")] + else + []) @ + override_params) + {add = ref_of_assms :: map ref_of [ext, @{thm someI}], del = [], only = true} [] end -fun sledgehammer_tac demo ctxt timeout i = +fun sledgehammer_tac demo ctxt timeout assms i = let val frac = if demo then 16 else 12 fun slice mult completeness prover = SOLVE_TIMEOUT (mult * timeout div frac) - (prover ^ - (if completeness > 0 then "(" ^ string_of_int completeness ^ ")" - else "")) - (atp_tac ctxt completeness [] (mult * timeout div frac) prover i) + (prover ^ (if completeness > 0 then "(" ^ string_of_int completeness ^ ")" else "")) + (atp_tac ctxt completeness [] (mult * timeout div frac) assms prover i) in slice 2 0 ATP_Proof.spassN ORELSE slice 2 0 ATP_Proof.vampireN @@ -235,15 +235,12 @@ val ctxt = ctxt |> Context.proof_map (SMT_Config.select_solver solver) in SMT_Solver.smt_tac ctxt [] end -fun auto_etc_tac ctxt timeout i = - SOLVE_TIMEOUT (timeout div 20) "nitpick" - (nitpick_finite_oracle_tac ctxt (timeout div 20) i) - ORELSE SOLVE_TIMEOUT (timeout div 10) "simp" - (asm_full_simp_tac ctxt i) +fun auto_etc_tac ctxt timeout assms i = + SOLVE_TIMEOUT (timeout div 20) "nitpick" (nitpick_finite_oracle_tac ctxt (timeout div 20) i) + ORELSE SOLVE_TIMEOUT (timeout div 10) "simp" (asm_full_simp_tac ctxt i) ORELSE SOLVE_TIMEOUT (timeout div 10) "blast" (blast_tac ctxt i) ORELSE SOLVE_TIMEOUT (timeout div 5) "auto+spass" - (auto_tac ctxt - THEN ALLGOALS (atp_tac ctxt 0 [] (timeout div 5) ATP_Proof.spassN)) + (auto_tac ctxt THEN ALLGOALS (atp_tac ctxt 0 [] (timeout div 5) assms ATP_Proof.spassN)) ORELSE SOLVE_TIMEOUT (timeout div 10) "fast" (fast_tac ctxt i) ORELSE SOLVE_TIMEOUT (timeout div 20) "z3" (smt_solver_tac "z3" ctxt i) ORELSE SOLVE_TIMEOUT (timeout div 20) "cvc3" (smt_solver_tac "cvc3" ctxt i) @@ -258,45 +255,44 @@ unfold "definitions" of free variables than of constants (cf. PUZ107^5). *) fun freeze_problem_consts thy = let val is_problem_const = String.isPrefix (problem_const_prefix thy) in - map_aterms (fn t as Const (s, T) => - if is_problem_const s then Free (Long_Name.base_name s, T) - else t - | t => t) + map_aterms + (fn t as Const (s, T) => if is_problem_const s then Free (Long_Name.base_name s, T) else t + | t => t) end fun make_conj (defs, nondefs) conjs = - Logic.list_implies (rev defs @ rev nondefs, - case conjs of conj :: _ => conj | [] => @{prop False}) + Logic.list_implies (rev defs @ rev nondefs, case conjs of conj :: _ => conj | [] => @{prop False}) fun print_szs_of_success conjs success = Output.urgent_message ("% SZS status " ^ - (if success then - if null conjs then "Unsatisfiable" else "Theorem" - else - "Unknown")) + (if success then + if null conjs then "Unsatisfiable" else "Theorem" + else + "Unknown")) fun sledgehammer_tptp_file thy timeout file_name = let - val (conjs, assms, ctxt) = - read_tptp_file thy (freeze_problem_consts thy o snd) file_name - val conj = make_conj assms conjs + val (conjs, assms, ctxt) = read_tptp_file thy (freeze_problem_consts thy o snd) file_name + val conj = make_conj ([], []) conjs + val assms = op @ assms in - can_tac ctxt (sledgehammer_tac true ctxt timeout 1) conj + can_tac ctxt (sledgehammer_tac true ctxt timeout assms 1) conj |> print_szs_of_success conjs end fun generic_isabelle_tptp_file demo thy timeout file_name = let - val (conjs, assms, ctxt) = - read_tptp_file thy (freeze_problem_consts thy o snd) file_name - val conj = make_conj assms conjs + val (conjs, assms, ctxt) = read_tptp_file thy (freeze_problem_consts thy o snd) file_name + val conj = make_conj ([], []) conjs + val full_conj = make_conj assms conjs + val assms = op @ assms val (last_hope_atp, last_hope_completeness) = if demo then (ATP_Proof.satallaxN, 0) else (ATP_Proof.vampireN, 2) in - (can_tac ctxt (auto_etc_tac ctxt (timeout div 2) 1) conj orelse - can_tac ctxt (sledgehammer_tac demo ctxt (timeout div 2) 1) conj orelse + (can_tac ctxt (auto_etc_tac ctxt (timeout div 2) assms 1) full_conj orelse + can_tac ctxt (sledgehammer_tac demo ctxt (timeout div 2) assms 1) conj orelse can_tac ctxt (SOLVE_TIMEOUT timeout (last_hope_atp ^ "(*)") - (atp_tac ctxt last_hope_completeness [] timeout last_hope_atp 1)) conj) + (atp_tac ctxt last_hope_completeness [] timeout assms last_hope_atp 1)) full_conj) |> print_szs_of_success conjs end @@ -322,7 +318,8 @@ val uncurried_aliases = false val readable_names = true val presimp = true - val facts = map (apfst (rpair (Global, Non_Rec_Def))) defs @ + val facts = + map (apfst (rpair (Global, Non_Rec_Def))) defs @ map (apfst (rpair (Global, General))) nondefs val (atp_problem, _, _, _) = generate_atp_problem ctxt format Hypothesis (type_enc_of_string Strict type_enc) Translator diff -r 1b6035697c49 -r be9815d02b10 src/HOL/TPTP/sledgehammer_tactics.ML --- a/src/HOL/TPTP/sledgehammer_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/TPTP/sledgehammer_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -9,10 +9,10 @@ sig type fact_override = Sledgehammer_Fact.fact_override - val sledgehammer_with_metis_tac : - Proof.context -> (string * string) list -> fact_override -> int -> tactic - val sledgehammer_as_oracle_tac : - Proof.context -> (string * string) list -> fact_override -> int -> tactic + val sledgehammer_with_metis_tac : Proof.context -> (string * string) list -> fact_override -> + thm list -> int -> tactic + val sledgehammer_as_oracle_tac : Proof.context -> (string * string) list -> fact_override -> + thm list -> int -> tactic end; structure Sledgehammer_Tactics : SLEDGEHAMMER_TACTICS = @@ -26,7 +26,7 @@ open Sledgehammer_MaSh open Sledgehammer_Commands -fun run_prover override_params fact_override i n ctxt goal = +fun run_prover override_params fact_override chained i n ctxt goal = let val thy = Proof_Context.theory_of ctxt val mode = Normal @@ -39,37 +39,38 @@ val reserved = reserved_isar_keyword_table () val css_table = clasimpset_rule_table_of ctxt val facts = - nearly_all_facts ctxt ho_atp fact_override reserved css_table [] hyp_ts concl_t - |> relevant_facts ctxt params name - (the_default default_max_facts max_facts) fact_override hyp_ts - concl_t + nearly_all_facts ctxt ho_atp fact_override reserved css_table chained hyp_ts concl_t + |> relevant_facts ctxt params name (the_default default_max_facts max_facts) fact_override + hyp_ts concl_t |> hd |> snd val problem = {comment = "", state = Proof.init ctxt, goal = goal, subgoal = i, subgoal_count = n, factss = [("", facts)]} in - (case prover params (K (K (K ""))) problem of + (case prover params problem of {outcome = NONE, used_facts, ...} => used_facts |> map fst |> SOME | _ => NONE) handle ERROR message => (warning ("Error: " ^ message ^ "\n"); NONE) end -fun sledgehammer_with_metis_tac ctxt override_params fact_override i th = +fun sledgehammer_with_metis_tac ctxt override_params fact_override chained i th = let val override_params = override_params @ [("preplay_timeout", "0")] in - case run_prover override_params fact_override i i ctxt th of + (case run_prover override_params fact_override chained i i ctxt th of SOME facts => Metis_Tactic.metis_tac [] ATP_Problem_Generate.combs_or_liftingN ctxt - (maps (thms_of_name ctxt) facts) i th - | NONE => Seq.empty + (maps (thms_of_name ctxt) facts) i th + | NONE => Seq.empty) end -fun sledgehammer_as_oracle_tac ctxt override_params fact_override i th = +fun sledgehammer_as_oracle_tac ctxt override_params fact_override chained i th = let val override_params = override_params @ [("preplay_timeout", "0"), ("minimize", "false")] - val xs = run_prover override_params fact_override i i ctxt th - in if is_some xs then ALLGOALS Skip_Proof.cheat_tac th else Seq.empty end + val xs = run_prover override_params fact_override chained i i ctxt th + in + if is_some xs then ALLGOALS Skip_Proof.cheat_tac th else Seq.empty + end end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_problem.ML --- a/src/HOL/Tools/ATP/atp_problem.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_problem.ML Wed Aug 27 15:52:58 2014 +0200 @@ -76,6 +76,8 @@ val tptp_ho_exists : string val tptp_choice : string val tptp_ho_choice : string + val tptp_hilbert_choice : string + val tptp_hilbert_the : string val tptp_not : string val tptp_and : string val tptp_not_and : string @@ -239,6 +241,8 @@ val tptp_iff = "<=>" val tptp_not_iff = "<~>" val tptp_app = "@" +val tptp_hilbert_choice = "@+" +val tptp_hilbert_the = "@-" val tptp_not_infix = "!" val tptp_equal = "=" val tptp_not_equal = "!=" @@ -533,11 +537,12 @@ " : " ^ string_of_type format ty ^ ").\n" | tptp_string_of_line format (Formula ((ident, alt), kind, phi, source, _)) = tptp_string_of_format format ^ "(" ^ ident ^ ", " ^ - tptp_string_of_role kind ^ "," ^ maybe_alt alt ^ - "\n (" ^ tptp_string_of_formula format phi ^ ")" ^ + tptp_string_of_role kind ^ "," ^ "\n (" ^ + tptp_string_of_formula format phi ^ ")" ^ (case source of - SOME tm => ", " ^ tptp_string_of_term format tm - | NONE => "") ^ ").\n" + SOME tm => ", " ^ tptp_string_of_term format tm + | NONE => "") ^ + ")." ^ maybe_alt alt ^ "\n" fun tptp_lines format = maps (fn (_, []) => [] @@ -638,8 +643,7 @@ fun formula pred (Formula ((ident, alt), kind, phi, _, info)) = if pred kind then let val rank = extract_isabelle_rank info in - "formula(" ^ dfg_string_of_formula poly gen_simp info phi ^ - ", " ^ ident ^ + "formula(" ^ dfg_string_of_formula poly gen_simp info phi ^ ", " ^ ident ^ (if rank = default_rank then "" else ", " ^ string_of_int rank) ^ ")." ^ maybe_alt alt |> SOME diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_proof.ML --- a/src/HOL/Tools/ATP/atp_proof.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -2,6 +2,7 @@ Author: Lawrence C. Paulson, Cambridge University Computer Laboratory Author: Claire Quigley, Cambridge University Computer Laboratory Author: Jasmin Blanchette, TU Muenchen + Author: Mathias Fleury, ENS Rennes Abstract representation of ATP proofs and TSTP/SPASS syntax. *) @@ -67,7 +68,6 @@ val remote_prefix : string val agsyhol_core_rule : string - val satallax_core_rule : string val spass_input_rule : string val spass_pre_skolemize_rule : string val spass_skolemize_rule : string @@ -84,10 +84,25 @@ val scan_general_id : string list -> string * string list val parse_formula : string list -> (string, string atp_type, (string, string atp_type) atp_term, string) atp_formula * string list - val atp_proof_of_tstplike_proof : string -> string atp_problem -> string -> string atp_proof val clean_up_atp_proof_dependencies : string atp_proof -> string atp_proof val map_term_names_in_atp_proof : (string -> string) -> string atp_proof -> string atp_proof val nasty_atp_proof : string Symtab.table -> string atp_proof -> string atp_proof + + val skip_term: string list -> string * string list + val parse_thf0_formula :string list -> + ('a, 'b, (string, string ATP_Problem.atp_type) ATP_Problem.atp_term, 'c) ATP_Problem.atp_formula * + string list + val dummy_atype : string ATP_Problem.atp_type + val role_of_tptp_string: string -> ATP_Problem.atp_formula_role + val parse_line: string -> ('a * string ATP_Problem.atp_problem_line list) list -> + string list -> ((string * string list) * ATP_Problem.atp_formula_role * + (string, 'b, (string, string ATP_Problem.atp_type) ATP_Problem.atp_term, + 'c) ATP_Problem.atp_formula + * string * (string * 'd list) list) list * string list + val core_inference : 'a -> 'b -> ('b * 'b list) * ATP_Problem.atp_formula_role * + ('c, 'd, (string, 'e) ATP_Problem.atp_term, 'f) ATP_Problem.atp_formula * 'a * 'g list + val vampire_step_name_ord : (string * 'a) * (string * 'a) -> order + val core_of_agsyhol_proof : string -> string list option end; structure ATP_Proof : ATP_PROOF = @@ -122,7 +137,6 @@ val remote_prefix = "remote_" val agsyhol_core_rule = "__agsyhol_core" (* arbitrary *) -val satallax_core_rule = "__satallax_core" (* arbitrary *) val spass_input_rule = "Inp" val spass_pre_skolemize_rule = "__Sko0" (* arbitrary *) val spass_skolemize_rule = "__Sko" (* arbitrary *) @@ -277,7 +291,7 @@ let fun skip _ accum [] = (accum, []) | skip n accum (ss as s :: ss') = - if s = "," andalso n = 0 then + if (s = "," orelse s = ".") andalso n = 0 then (accum, ss) else if member (op =) [")", "]"] s then if n = 0 then (accum, ss) else skip (n - 1) (s :: accum) ss' @@ -291,11 +305,12 @@ datatype source = File_Source of string * string option | - Inference_Source of string * string list + Inference_Source of string * string list | + Introduced_Source of string val dummy_phi = AAtom (ATerm (("", []), [])) val dummy_inference = Inference_Source ("", []) -val dummy_atype = AType(("", []), []) +val dummy_atype = AType (("", []), []) (* "skip_term" is there to cope with Waldmeister nonsense such as "theory(equality)". *) fun parse_dependency x = @@ -312,13 +327,13 @@ (Scan.this_string "inference" |-- $$ "(" |-- scan_general_id --| skip_term --| $$ "," --| skip_term --| $$ "," --| $$ "[" -- parse_dependencies --| $$ "]" --| $$ ")") x -and skip_introduced x = - (Scan.this_string "introduced" |-- $$ "(" |-- skip_term - -- Scan.repeat ($$ "," |-- skip_term) --| $$ ")") x +and parse_introduced_source x = + (Scan.this_string "introduced" |-- $$ "(" |-- scan_general_id + --| Scan.option ($$ "," |-- skip_term) --| $$ ")") x and parse_source x = (parse_file_source >> File_Source || parse_inference_source >> Inference_Source - || skip_introduced >> K dummy_inference (* for Vampire *) + || parse_introduced_source >> Introduced_Source || scan_general_id >> (fn s => Inference_Source ("", [s])) (* for E *) || skip_term >> K dummy_inference) x @@ -459,22 +474,34 @@ | role_of_tptp_string "type" = Type_Role | role_of_tptp_string _ = Unknown -val tptp_binary_op_list = [tptp_and, tptp_not_and, tptp_or, tptp_not_or, tptp_implies, tptp_if, - tptp_iff, tptp_not_iff, tptp_equal, tptp_app] +val tptp_binary_ops = + [tptp_and, tptp_not_and, tptp_or, tptp_not_or, tptp_implies, tptp_if, tptp_iff, tptp_not_iff, + tptp_equal, tptp_app] + +fun parse_one_in_list xs = + foldl1 (op ||) (map Scan.this_string xs) fun parse_binary_op x = - (foldl1 (op ||) (map Scan.this_string tptp_binary_op_list) - >> (fn c => if c = tptp_equal then "equal" else c)) x + (parse_one_in_list tptp_binary_ops + >> (fn c => if c = tptp_equal then "equal" else c)) x + +val parse_fo_quantifier = + parse_one_in_list [tptp_forall, tptp_exists, tptp_lambda, tptp_hilbert_choice, tptp_hilbert_the] + +val parse_ho_quantifier = + parse_one_in_list [tptp_ho_forall, tptp_ho_exists, tptp_hilbert_choice, tptp_hilbert_the] fun parse_thf0_type x = (($$ "(" |-- parse_thf0_type --| $$ ")" || scan_general_id >> (fn t => AType ((t, []), []))) - -- Scan.option ($$ tptp_fun_type |-- parse_thf0_type) + -- Scan.option ($$ tptp_fun_type |-- parse_thf0_type) >> (fn (a, NONE) => a | (a, SOME b) => AFun (a, b))) x fun mk_ho_of_fo_quant q = if q = tptp_forall then tptp_ho_forall else if q = tptp_exists then tptp_ho_exists + else if q = tptp_hilbert_choice then tptp_hilbert_choice + else if q = tptp_hilbert_the then tptp_hilbert_the else raise Fail ("unrecognized quantification: " ^ q) fun remove_thf_app (ATerm ((x, ty), arg)) = @@ -492,8 +519,7 @@ || $$ "(" |-- parse_thf0_typed_var --| $$ ")") x fun parse_simple_thf0_term x = - ((Scan.this_string tptp_forall || Scan.this_string tptp_exists || Scan.this_string tptp_lambda) - -- ($$ "[" |-- parse_thf0_typed_var --| $$ "]" --| $$ ":") -- parse_thf0_term + (parse_fo_quantifier -- ($$ "[" |-- parse_thf0_typed_var --| $$ "]" --| $$ ":") -- parse_thf0_term >> (fn ((q, ys), t) => fold_rev (fn (var, ty) => fn r => @@ -505,7 +531,7 @@ ys t) || Scan.this_string tptp_not |-- parse_thf0_term >> mk_app (mk_simple_aterm tptp_not) || scan_general_id --| $$ ":" -- parse_thf0_type >> (fn (var, typ) => ATerm ((var, [typ]), [])) - || (Scan.this_string tptp_ho_forall || Scan.this_string tptp_ho_exists) >> mk_simple_aterm + || parse_ho_quantifier >> mk_simple_aterm || $$ "(" |-- parse_thf0_term --| $$ ")" || scan_general_id >> mk_simple_aterm) x and parse_thf0_term x = @@ -546,11 +572,12 @@ |-- scan_general_id --| $$ "," -- Symbol.scan_ascii_id --| $$ "," -- (parse_formula || skip_term >> K dummy_phi) -- parse_tstp_extra_arguments --| $$ ")" --| $$ "." - >> (fn (((num, role), phi), deps) => + >> (fn (((num, role0), phi), src) => let - val ((name, phi), rule, deps) = + val role = role_of_tptp_string role0 + val ((name, phi), role', rule, deps) = (* Waldmeister isn't exactly helping. *) - (case deps of + (case src of File_Source (_, SOME s) => (if s = waldmeister_conjecture_name then (case find_formula_in_problem (mk_anot phi) problem of @@ -563,13 +590,15 @@ else ((num, [s |> perhaps (try (unprefix tofof_fact_prefix))]), phi), - "", []) + role, "", []) | File_Source _ => - (((num, map fst (find_formula_in_problem phi problem)), phi), "", []) - | Inference_Source (rule, deps) => (((num, []), phi), rule, deps)) - fun mk_step () = (name, role_of_tptp_string role, phi, rule, map (rpair []) deps) + (((num, map fst (find_formula_in_problem phi problem)), phi), role, "", []) + | Inference_Source (rule, deps) => (((num, []), phi), role, rule, deps) + | Introduced_Source rule => (((num, []), phi), Lemma, rule, [])) + + fun mk_step () = (name, role', phi, rule, map (rpair []) deps) in - [(case role_of_tptp_string role of + [(case role' of Definition => (case phi of AAtom (ATerm (("equal", _), _)) => @@ -581,15 +610,13 @@ (**** PARSING OF SPASS OUTPUT ****) -(* SPASS returns clause references of the form "x.y". We ignore "y", whose role - is not clear anyway. *) +(* SPASS returns clause references of the form "x.y". We ignore "y". *) val parse_dot_name = scan_general_id --| $$ "." --| scan_general_id val parse_spass_annotations = Scan.optional ($$ ":" |-- Scan.repeat (parse_dot_name --| Scan.option ($$ ","))) [] -(* It is not clear why some literals are followed by sequences of stars and/or - pluses. We ignore them. *) +(* We ignore the stars and the pluses that follow literals. *) fun parse_decorated_atom x = (parse_atom --| Scan.repeat ($$ "*" || $$ "+" || $$ " ")) x @@ -598,7 +625,7 @@ | mk_horn (neg_lits, []) = mk_anot (foldr1 (uncurry (mk_aconn AAnd)) neg_lits) | mk_horn (neg_lits, pos_lits) = mk_aconn AImplies (foldr1 (uncurry (mk_aconn AAnd)) neg_lits) - (foldr1 (uncurry (mk_aconn AOr)) pos_lits) + (foldr1 (uncurry (mk_aconn AOr)) pos_lits) fun parse_horn_clause x = (Scan.repeat parse_decorated_atom --| $$ "|" --| $$ "|" @@ -647,10 +674,6 @@ fun core_inference inf fact = ((fact, [fact]), Unknown, dummy_phi, inf, []) -(* Syntax: *) -fun parse_satallax_core_line x = - (scan_general_id --| Scan.option ($$ " ") >> (single o core_inference satallax_core_rule)) x - (* Syntax: SZS core ... *) fun parse_z3_tptp_core_line x = (Scan.this_string "SZS core" |-- Scan.repeat ($$ " " |-- scan_general_id) @@ -658,35 +681,17 @@ fun parse_line local_name problem = if local_name = leo2N then parse_tstp_thf0_line problem - else if local_name = satallaxN then parse_satallax_core_line else if local_name = spassN then parse_spass_line else if local_name = spass_pirateN then parse_spass_pirate_line else if local_name = z3_tptpN then parse_z3_tptp_core_line else parse_tstp_line problem -fun parse_proof local_name problem = - strip_spaces_except_between_idents - #> raw_explode - #> Scan.error (!! (fn _ => raise UNRECOGNIZED_ATP_PROOF ()) - (Scan.finite Symbol.stopper (Scan.repeat1 (parse_line local_name problem) >> flat))) - #> fst - fun core_of_agsyhol_proof s = (case split_lines s of "The transformed problem consists of the following conjectures:" :: conj :: _ :: proof_term :: _ => SOME (unprefix " " conj :: find_enclosed "<<" ">>" proof_term) | _ => NONE) -fun atp_proof_of_tstplike_proof _ _ "" = [] - | atp_proof_of_tstplike_proof local_prover problem tstp = - (case core_of_agsyhol_proof tstp of - SOME facts => facts |> map (core_inference agsyhol_core_rule) - | NONE => - tstp ^ "$" (* the $ sign acts as a sentinel (FIXME: needed?) *) - |> parse_proof local_prover problem - |> local_prover = vampireN ? perhaps (try (sort (vampire_step_name_ord o pairself #1))) - |> local_prover = zipperpositionN ? rev) - fun clean_up_dependencies _ [] = [] | clean_up_dependencies seen ((name, role, u, rule, deps) :: steps) = (name, role, u, rule, map_filter (fn dep => find_first (is_same_atp_step dep) seen) deps) :: diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_proof_reconstruct.ML --- a/src/HOL/Tools/ATP/atp_proof_reconstruct.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_proof_reconstruct.ML Wed Aug 27 15:52:58 2014 +0200 @@ -30,6 +30,9 @@ val forall_of : term -> term -> term val exists_of : term -> term -> term + val simplify_bool : term -> term + val var_name_of_typ : typ -> string + val rename_bound_vars : term -> term val type_enc_aliases : (string * string list) list val unalias_type_enc : string -> string list val term_of_atp : Proof.context -> ATP_Problem.atp_format -> ATP_Problem_Generate.type_enc -> @@ -50,8 +53,8 @@ ATP_Problem_Generate.type_enc -> string Symtab.table -> (string * term) list -> int Symtab.table -> string atp_proof -> (term, string) atp_step list val repair_waldmeister_endgame : (term, 'a) atp_step list -> (term, 'a) atp_step list - val infer_formula_types : Proof.context -> term list -> term list - val introduce_spass_skolem : (term, string) atp_step list -> (term, string) atp_step list + val infer_formulas_types : Proof.context -> term list -> term list + val introduce_spass_skolems : (term, string) atp_step list -> (term, string) atp_step list val factify_atp_proof : (string * 'a) list -> term list -> term -> (term, string) atp_step list -> (term, string) atp_step list end; @@ -101,6 +104,46 @@ TFree (ww, the_default @{sort type} (Variable.def_sort ctxt (ww, ~1))) end +fun simplify_bool ((all as Const (@{const_name All}, _)) $ Abs (s, T, t)) = + let val t' = simplify_bool t in + if loose_bvar1 (t', 0) then all $ Abs (s, T, t') else t' + end + | simplify_bool (Const (@{const_name Not}, _) $ t) = s_not (simplify_bool t) + | simplify_bool (Const (@{const_name conj}, _) $ t $ u) = + s_conj (simplify_bool t, simplify_bool u) + | simplify_bool (Const (@{const_name disj}, _) $ t $ u) = + s_disj (simplify_bool t, simplify_bool u) + | simplify_bool (Const (@{const_name implies}, _) $ t $ u) = + s_imp (simplify_bool t, simplify_bool u) + | simplify_bool ((t as Const (@{const_name HOL.eq}, _)) $ u $ v) = + (case (u, v) of + (Const (@{const_name True}, _), _) => v + | (u, Const (@{const_name True}, _)) => u + | (Const (@{const_name False}, _), v) => s_not v + | (u, Const (@{const_name False}, _)) => s_not u + | _ => if u aconv v then @{const True} else t $ simplify_bool u $ simplify_bool v) + | simplify_bool (t $ u) = simplify_bool t $ simplify_bool u + | simplify_bool (Abs (s, T, t)) = Abs (s, T, simplify_bool t) + | simplify_bool t = t + +fun single_letter upper s = + let val s' = if String.isPrefix "o" s orelse String.isPrefix "O" s then "z" else s in + String.extract (Name.desymbolize (SOME upper) (Long_Name.base_name s'), 0, SOME 1) + end + +fun var_name_of_typ (Type (@{type_name fun}, [_, T])) = + if body_type T = HOLogic.boolT then "p" else "f" + | var_name_of_typ (Type (@{type_name set}, [T])) = single_letter true (var_name_of_typ T) + | var_name_of_typ (Type (s, Ts)) = + if String.isSuffix "list" s then var_name_of_typ (the_single Ts) ^ "s" + else single_letter false (Long_Name.base_name s) + | var_name_of_typ (TFree (s, _)) = single_letter false (perhaps (try (unprefix "'")) s) + | var_name_of_typ (TVar ((s, _), T)) = var_name_of_typ (TFree (s, T)) + +fun rename_bound_vars (t $ u) = rename_bound_vars t $ rename_bound_vars u + | rename_bound_vars (Abs (_, T, t)) = Abs (var_name_of_typ T, T, rename_bound_vars t) + | rename_bound_vars t = t + exception ATP_CLASS of string list exception ATP_TYPE of string atp_type list exception ATP_TERM of (string, string atp_type) atp_term list @@ -116,25 +159,33 @@ (* Type variables are given the basic sort "HOL.type". Some will later be constrained by information from type literals, or by type inference. *) fun typ_of_atp_type ctxt (ty as AType ((a, clss), tys)) = - let val Ts = map (typ_of_atp_type ctxt) tys in - (case unprefix_and_unascii type_const_prefix a of - SOME b => Type (invert_const b, Ts) - | NONE => - if not (null tys) then - raise ATP_TYPE [ty] (* only "tconst"s have type arguments *) - else - (case unprefix_and_unascii tfree_prefix a of - SOME b => make_tfree ctxt b - | NONE => - (* The term could be an Isabelle variable or a variable from the ATP, say "X1" or "_5018". - Sometimes variables from the ATP are indistinguishable from Isabelle variables, which - forces us to use a type parameter in all cases. *) - Type_Infer.param 0 ("'" ^ perhaps (unprefix_and_unascii tvar_prefix) a, - (if null clss then @{sort type} else map class_of_atp_class clss)))) + let val Ts = map (typ_of_atp_type ctxt) tys in + (case unprefix_and_unascii type_const_prefix a of + SOME b => Type (invert_const b, Ts) + | NONE => + if not (null tys) then + raise ATP_TYPE [ty] (* only "tconst"s have type arguments *) + else + (case unprefix_and_unascii tfree_prefix a of + SOME b => make_tfree ctxt b + | NONE => + (* The term could be an Isabelle variable or a variable from the ATP, say "X1" or "_5018". + Sometimes variables from the ATP are indistinguishable from Isabelle variables, which + forces us to use a type parameter in all cases. *) + Type_Infer.param 0 ("'" ^ perhaps (unprefix_and_unascii tvar_prefix) a, + (if null clss then @{sort type} else map class_of_atp_class clss)))) + end + | typ_of_atp_type ctxt (AFun (ty1, ty2)) = typ_of_atp_type ctxt ty1 --> typ_of_atp_type ctxt ty2 + +fun atp_type_of_atp_term (ATerm ((s, _), us)) = + let val tys = map atp_type_of_atp_term us in + if s = tptp_fun_type then + (case tys of + [ty1, ty2] => AFun (ty1, ty2) + | _ => raise ATP_TYPE tys) + else + AType ((s, []), tys) end - | typ_of_atp_type ctxt (AFun (a, tys)) = typ_of_atp_type ctxt a --> typ_of_atp_type ctxt tys - -fun atp_type_of_atp_term (ATerm ((s, _), us)) = AType ((s, []), map atp_type_of_atp_term us) fun typ_of_atp_term ctxt = typ_of_atp_type ctxt o atp_type_of_atp_term @@ -150,25 +201,10 @@ | add_type_constraint false (cl, TVar (ix, _)) = add_var (ix, cl) | add_type_constraint _ _ = I -fun repair_var_name_raw s = - let - fun subscript_name s n = s ^ nat_subscript n - val s = s |> String.map Char.toLower - in - (case space_explode "_" s of - [_] => - (case take_suffix Char.isDigit (String.explode s) of - (cs1 as _ :: _, cs2 as _ :: _) => - subscript_name (String.implode cs1) (the (Int.fromString (String.implode cs2))) - | (_, _) => s) - | [s1, s2] => (case Int.fromString s2 of SOME n => subscript_name s1 n | NONE => s) - | _ => s) - end - -fun repair_var_name textual s = +fun repair_var_name s = (case unprefix_and_unascii schematic_var_prefix s of - SOME s => s - | NONE => s |> textual ? repair_var_name_raw) + SOME s' => s' + | NONE => s) (* The number of type arguments of a constant, zero if it's monomorphic. For (instances of) Skolem pseudoconstants, this information is encoded in the constant name. *) @@ -182,58 +218,52 @@ fun slack_fastype_of t = fastype_of t handle TERM _ => Type_Infer.anyT @{sort type} -(* Cope with "tt(X) = X" atoms, where "X" is existentially quantified. *) -fun loose_aconv (Free (s, _), Free (s', _)) = s = s' - | loose_aconv (t, t') = t aconv t' - val spass_skolem_prefix = "sk" (* "skc" or "skf" *) val vampire_skolem_prefix = "sK" - fun var_index_of_textual textual = if textual then 0 else 1 fun quantify_over_var textual quant_of var_s var_T t = let - val vars = ((var_s, var_index_of_textual textual), var_T) :: - filter (fn ((s, _), _) => s = var_s) (Term.add_vars t []) + val vars = + ((var_s, var_index_of_textual textual), var_T) :: + filter (fn ((s, _), _) => s = var_s) (Term.add_vars t []) val normTs = vars |> AList.group (op =) |> map (apsnd hd) fun norm_var_types (Var (x, T)) = Var (x, the_default T (AList.lookup (op =) normTs x)) | norm_var_types t = t in t |> map_aterms norm_var_types |> fold_rev quant_of (map Var normTs) end +(* This assumes that distinct names are mapped to distinct names by "Variable.variant_frees". This + does not hold in general but should hold for ATP-generated Skolem function names, since these end + with a digit and "variant_frees" appends letters. *) +fun fresh_up ctxt s = fst (hd (Variable.variant_frees ctxt [] [(s, ())])) (* Higher-order translation. Variables are typed (although we don't use that information). Lambdas - are typed. - - The code is similar to term_of_atp_fo. *) -fun term_of_atp_ho ctxt textual sym_tab = + are typed. The code is similar to "term_of_atp_fo". *) +fun term_of_atp_ho ctxt sym_tab = let val thy = Proof_Context.theory_of ctxt - val var_index = var_index_of_textual textual + val var_index = var_index_of_textual true fun do_term opt_T u = (case u of - AAbs(((var, ty), term), []) => + AAbs (((var, ty), term), []) => let val typ = typ_of_atp_type ctxt ty - val var_name = repair_var_name textual var + val var_name = repair_var_name var val tm = do_term NONE term - in quantify_over_var textual lambda' var_name typ tm end + in quantify_over_var true lambda' var_name typ tm end | ATerm ((s, tys), us) => if s = "" then error "Isar proof reconstruction failed because the ATP proof \ \contains unparsable material." else if s = tptp_equal then - let val ts = map (do_term NONE) us in - if textual andalso length ts = 2 andalso loose_aconv (hd ts, List.last ts) then - @{const True} - else - list_comb (Const (@{const_name HOL.eq}, Type_Infer.anyT @{sort type}), ts) - end + list_comb (Const (@{const_name HOL.eq}, Type_Infer.anyT @{sort type}), + map (do_term NONE) us) else if not (null us) then let - val args = List.map (do_term NONE) us + val args = map (do_term NONE) us val opt_T' = SOME (map slack_fastype_of args ---> the_default dummyT opt_T) val func = do_term opt_T' (ATerm ((s, tys), [])) in foldl1 (op $) (func :: args) end @@ -241,13 +271,15 @@ else if s = tptp_and then HOLogic.conj else if s = tptp_implies then HOLogic.imp else if s = tptp_iff orelse s = tptp_equal then HOLogic.eq_const dummyT - else if s = tptp_not_iff orelse s = tptp_not_equal then @{term "% P Q. Q ~= P"} - else if s = tptp_if then @{term "% P Q. Q --> P"} - else if s = tptp_not_and then @{term "% P Q. ~ (P & Q)"} - else if s = tptp_not_or then @{term "% P Q. ~ (P | Q)"} + else if s = tptp_not_iff orelse s = tptp_not_equal then @{term "%P Q. Q ~= P"} + else if s = tptp_if then @{term "%P Q. Q --> P"} + else if s = tptp_not_and then @{term "%P Q. ~ (P & Q)"} + else if s = tptp_not_or then @{term "%P Q. ~ (P | Q)"} else if s = tptp_not then HOLogic.Not else if s = tptp_ho_forall then HOLogic.all_const dummyT else if s = tptp_ho_exists then HOLogic.exists_const dummyT + else if s = tptp_hilbert_choice then HOLogic.choice_const dummyT + else if s = tptp_hilbert_the then @{term "The"} else (case unprefix_and_unascii const_prefix s of SOME s' => @@ -259,7 +291,7 @@ val Ts = map (typ_of_atp_type ctxt) tys @ map (typ_of_atp_term ctxt) type_us val T = (if not (null Ts) andalso robust_const_num_type_args thy s' = length Ts then - if textual then try (Sign.const_instance thy) (s', Ts) else NONE + try (Sign.const_instance thy) (s', Ts) else NONE) |> (fn SOME T => T @@ -270,8 +302,6 @@ in list_comb (t, term_ts) end | NONE => (* a free or schematic variable *) let - fun fresh_up s = - [(s, ())] |> Variable.variant_frees ctxt [] |> hd |> fst val ts = map (do_term NONE) us val T = (case opt_T of @@ -285,10 +315,8 @@ (case unprefix_and_unascii fixed_var_prefix s of SOME s => Free (s, T) | NONE => - if textual andalso not (is_tptp_variable s) then - Free (s |> textual ? (repair_var_name_raw #> fresh_up), T) - else - Var ((repair_var_name textual s, var_index), T)) + if not (is_tptp_variable s) then Free (fresh_up ctxt s, T) + else Var ((repair_var_name s, var_index), T)) in list_comb (t, ts) end)) in do_term end @@ -311,12 +339,8 @@ else if String.isPrefix native_type_prefix s then @{const True} (* ignore TPTP type information *) else if s = tptp_equal then - let val ts = map (do_term [] NONE) us in - if textual andalso length ts = 2 andalso loose_aconv (hd ts, List.last ts) then - @{const True} - else - list_comb (Const (@{const_name HOL.eq}, Type_Infer.anyT @{sort type}), ts) - end + list_comb (Const (@{const_name HOL.eq}, Type_Infer.anyT @{sort type}), + map (do_term [] NONE) us) else (case unprefix_and_unascii const_prefix s of SOME s' => @@ -363,16 +387,10 @@ end | NONE => (* a free or schematic variable *) let - (* This assumes that distinct names are mapped to distinct names by - "Variable.variant_frees". This does not hold in general but should hold for - ATP-generated Skolem function names, since these end with a digit and - "variant_frees" appends letters. *) - fun fresh_up s = [(s, ())] |> Variable.variant_frees ctxt [] |> hd |> fst - val term_ts = map (do_term [] NONE) us (* SPASS (3.8ds) and Vampire (2.6) pass arguments to Skolem functions in reverse - order, which is incompatible with the new Metis skolemizer. *) + order, which is incompatible with "metis"'s new skolemizer. *) |> exists (fn pre => String.isPrefix pre s) [spass_skolem_prefix, vampire_skolem_prefix] ? rev val ts = term_ts @ extra_ts @@ -387,19 +405,17 @@ SOME s => Free (s, T) | NONE => if textual andalso not (is_tptp_variable s) then - Free (s |> textual ? (repair_var_name_raw #> fresh_up), T) + Free (s |> textual ? fresh_up ctxt, T) else - Var ((repair_var_name textual s, var_index), T)) + Var ((repair_var_name s, var_index), T)) in list_comb (t, ts) end)) in do_term [] end fun term_of_atp ctxt (ATP_Problem.THF _) type_enc = - if ATP_Problem_Generate.is_type_enc_higher_order type_enc - then term_of_atp_ho ctxt + if ATP_Problem_Generate.is_type_enc_higher_order type_enc then K (term_of_atp_ho ctxt) else error "Unsupported Isar reconstruction." | term_of_atp ctxt _ type_enc = - if not (ATP_Problem_Generate.is_type_enc_higher_order type_enc) - then term_of_atp_fo ctxt + if not (ATP_Problem_Generate.is_type_enc_higher_order type_enc) then term_of_atp_fo ctxt else error "Unsupported Isar reconstruction." fun term_of_atom ctxt format type_enc textual sym_tab pos (u as ATerm ((s, _), _)) = @@ -436,7 +452,7 @@ do_formula pos (AQuant (q, xs, phi')) (* FIXME: TFF *) #>> quantify_over_var textual (case q of AForall => forall_of | AExists => exists_of) - (repair_var_name textual s) dummyT + (repair_var_name s) dummyT | AConn (ANot, [phi']) => do_formula (not pos) phi' #>> s_not | AConn (c, [phi1, phi2]) => do_formula (pos |> c = AImplies ? not) phi1 @@ -477,7 +493,7 @@ val leo2_extcnf_equal_neg_rule = "extcnf_equal_neg" fun add_fact ctxt facts ((_, ss), _, _, rule, deps) = - (if member (op =) [agsyhol_core_rule, leo2_extcnf_equal_neg_rule, satallax_core_rule] rule then + (if member (op =) [agsyhol_core_rule, leo2_extcnf_equal_neg_rule] rule then insert (op =) (short_thm_name ctxt ext, (Global, General)) else I) @@ -530,9 +546,9 @@ else s -fun set_var_index j = map_aterms (fn Var ((s, _), T) => Var ((s, j), T) | t => t) +fun set_var_index j = map_aterms (fn Var ((s, 0), T) => Var ((s, j), T) | t => t) -fun infer_formula_types ctxt = +fun infer_formulas_types ctxt = map_index (uncurry (fn j => set_var_index j #> Type.constraint HOLogic.boolT)) #> Syntax.check_terms (Proof_Context.set_mode Proof_Context.mode_schematic ctxt) #> map (set_var_index 0) @@ -546,25 +562,26 @@ fun uncombine_term thy = let - fun aux (t1 $ t2) = betapply (pairself aux (t1, t2)) - | aux (Abs (s, T, t')) = Abs (s, T, aux t') - | aux (t as Const (x as (s, _))) = + fun uncomb (t1 $ t2) = betapply (uncomb t1, uncomb t2) + | uncomb (Abs (s, T, t)) = Abs (s, T, uncomb t) + | uncomb (t as Const (x as (s, _))) = (case AList.lookup (op =) combinator_table s of SOME thm => thm |> prop_of |> specialize_type thy x |> Logic.dest_equals |> snd | NONE => t) - | aux t = t - in aux end + | uncomb t = t + in uncomb end -fun unlift_term lifted = - map_aterms (fn t as Const (s, _) => - if String.isPrefix lam_lifted_prefix s then - (* FIXME: do something about the types *) - (case AList.lookup (op =) lifted s of - SOME t => unlift_term lifted t - | NONE => t) - else - t - | t => t) +fun unlift_aterm lifted (t as Const (s, _)) = + if String.isPrefix lam_lifted_prefix s then + (* FIXME: do something about the types *) + (case AList.lookup (op =) lifted s of + SOME t' => unlift_term lifted t' + | NONE => t) + else + t + | unlift_aterm _ t = t +and unlift_term lifted = + map_aterms (unlift_aterm lifted) fun termify_line _ _ _ _ _ (_, Type_Role, _, _, _) = NONE | termify_line ctxt format type_enc lifted sym_tab (name, role, u, rule, deps) = @@ -572,8 +589,9 @@ val thy = Proof_Context.theory_of ctxt val t = u |> prop_of_atp ctxt format type_enc true sym_tab + |> unlift_term lifted |> uncombine_term thy - |> unlift_term lifted + |> simplify_bool in SOME (name, role, t, rule, deps) end @@ -599,7 +617,7 @@ nasty_atp_proof pool #> map_term_names_in_atp_proof repair_name #> map_filter (termify_line ctxt format type_enc lifted sym_tab) - #> map_proof_terms (infer_formula_types ctxt #> map HOLogic.mk_Trueprop) + #> map_proof_terms (infer_formulas_types ctxt #> map HOLogic.mk_Trueprop) #> local_prover = waldmeisterN ? repair_waldmeister_endgame fun take_distinct_vars seen ((t as Var _) :: ts) = @@ -608,12 +626,12 @@ fun unskolemize_term skos t = let - val is_sko = member (op =) skos + val is_skolem = member (op =) skos fun find_args args (t $ u) = find_args (u :: args) t #> find_args [] u | find_args _ (Abs (_, _, t)) = find_args [] t | find_args args (Free (s, _)) = - if is_sko s then + if is_skolem s then let val new = take_distinct_vars [] args in (fn [] => new | old => if length new < length old then new else old) end @@ -626,7 +644,7 @@ fun fix_skos args (t $ u) = fix_skos (fix_skos [] u :: args) t | fix_skos args (t as Free (s, T)) = - if is_sko s then list_comb (Free (s, funpow num_alls body_type T), drop num_alls args) + if is_skolem s then list_comb (Free (s, funpow num_alls body_type T), drop num_alls args) else list_comb (t, args) | fix_skos [] (Abs (s, T, t)) = Abs (s, T, fix_skos [] t) | fix_skos [] t = t @@ -634,10 +652,10 @@ val t' = fix_skos [] t - fun add_sko (t as Free (s, _)) = is_sko s ? insert (op aconv) t - | add_sko _ = I + fun add_skolem (t as Free (s, _)) = is_skolem s ? insert (op aconv) t + | add_skolem _ = I - val exs = Term.fold_aterms add_sko t' [] + val exs = Term.fold_aterms add_skolem t' [] in t' |> HOLogic.dest_Trueprop @@ -646,62 +664,80 @@ |> HOLogic.mk_Trueprop end -fun introduce_spass_skolem [] = [] - | introduce_spass_skolem (proof as (_, _, _, rule1, _) :: _) = - if rule1 = spass_input_rule then - let - fun add_sko (Free (s, _)) = String.isPrefix spass_skolem_prefix s ? insert (op =) s - | add_sko _ = I +fun rename_skolem_args t = + let + fun add_skolem_args (Abs (_, _, t)) = add_skolem_args t + | add_skolem_args t = + (case strip_comb t of + (Free (s, _), args as _ :: _) => + if String.isPrefix spass_skolem_prefix s then + insert (op =) (s, fst (take_prefix is_Var args)) + else + fold add_skolem_args args + | (u, args as _ :: _) => fold add_skolem_args (u :: args) + | _ => I) + + fun subst_of_skolem (sk, args) = + map_index (fn (j, Var (z, T)) => (z, Var ((sk ^ "_" ^ string_of_int j, 0), T))) args - (* union-find would be faster *) - fun add_cycle [] = I - | add_cycle ss = - fold (fn s => Graph.default_node (s, ())) ss - #> fold Graph.add_edge (ss ~~ tl ss @ [hd ss]) - - val (input_steps, other_steps) = List.partition (null o #5) proof + val subst = maps subst_of_skolem (add_skolem_args t []) + in + subst_vars ([], subst) t + end - val skoss = map (fn (_, _, t, _, _) => Term.fold_aterms add_sko t []) input_steps - val skoss_input_steps = filter_out (null o fst) (skoss ~~ input_steps) - val groups = Graph.strong_conn (fold add_cycle skoss Graph.empty) +fun introduce_spass_skolems proof = + let + fun add_skolem (Free (s, _)) = String.isPrefix spass_skolem_prefix s ? insert (op =) s + | add_skolem _ = I - fun step_name_of_group skos = (implode skos, []) - fun in_group group = member (op =) group o hd - fun group_of sko = the (find_first (fn group => in_group group sko) groups) + (* union-find would be faster *) + fun add_cycle [] = I + | add_cycle ss = + fold (fn s => Graph.default_node (s, ())) ss + #> fold Graph.add_edge (ss ~~ tl ss @ [hd ss]) + + val (input_steps, other_steps) = List.partition (null o #5) proof - fun new_steps (skoss_steps : (string list * (term, 'a) atp_step) list) group = - let - val name = step_name_of_group group - val name0 = name |>> prefix "0" - val t = - skoss_steps - |> map (snd #> #3 #> HOLogic.dest_Trueprop) - |> Library.foldr1 s_conj - |> HOLogic.mk_Trueprop - val skos = fold (union (op =) o fst) skoss_steps [] - val deps = map (snd #> #1) skoss_steps - in - [(name0, Unknown, unskolemize_term skos t, spass_pre_skolemize_rule, deps), - (name, Unknown, t, spass_skolemize_rule, [name0])] - end + val skoss = map (fn (_, _, t, _, _) => Term.fold_aterms add_skolem t []) input_steps + val skoss_input_steps = filter_out (null o fst) (skoss ~~ input_steps) + val groups = Graph.strong_conn (fold add_cycle skoss Graph.empty) + + fun step_name_of_group skos = (implode skos, []) + fun in_group group = member (op =) group o hd + fun group_of sko = the (find_first (fn group => in_group group sko) groups) - val sko_steps = - maps (fn group => new_steps (filter (in_group group o fst) skoss_input_steps) group) - groups + fun new_steps (skoss_steps : (string list * (term, 'a) atp_step) list) group = + let + val name = step_name_of_group group + val name0 = name |>> prefix "0" + val t = + (case map (snd #> #3) skoss_steps of + [t] => t + | ts => ts + |> map (HOLogic.dest_Trueprop #> rename_skolem_args) + |> Library.foldr1 s_conj + |> HOLogic.mk_Trueprop) + val skos = fold (union (op =) o fst) skoss_steps [] + val deps = map (snd #> #1) skoss_steps + in + [(name0, Unknown, unskolemize_term skos t, spass_pre_skolemize_rule, deps), + (name, Unknown, t, spass_skolemize_rule, [name0])] + end - val old_news = - map (fn (skos, (name, _, _, _, _)) => (name, [step_name_of_group (group_of skos)])) - skoss_input_steps - val repair_deps = fold replace_dependencies_in_line old_news - in - input_steps @ sko_steps @ map repair_deps other_steps - end - else - proof + val sko_steps = + maps (fn group => new_steps (filter (in_group group o fst) skoss_input_steps) group) groups + + val old_news = + map (fn (skos, (name, _, _, _, _)) => (name, [step_name_of_group (group_of skos)])) + skoss_input_steps + val repair_deps = fold replace_dependencies_in_line old_news + in + input_steps @ sko_steps @ map repair_deps other_steps + end fun factify_atp_proof facts hyp_ts concl_t atp_proof = let - fun factify_step ((num, ss), _, t, rule, deps) = + fun factify_step ((num, ss), role, t, rule, deps) = let val (ss', role', t') = (case resolve_conjectures ss of @@ -709,7 +745,7 @@ if j = length hyp_ts then ([], Conjecture, concl_t) else ([], Hypothesis, nth hyp_ts j) | _ => (case resolve_facts facts ss of - [] => (ss, Plain, t) + [] => (ss, if role = Lemma then Lemma else Plain, t) | facts => (map fst facts, Axiom, t))) in ((num, ss'), role', t', rule, deps) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_proof_redirect.ML --- a/src/HOL/Tools/ATP/atp_proof_redirect.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_proof_redirect.ML Wed Aug 27 15:52:58 2014 +0200 @@ -167,8 +167,9 @@ val subseqss = map (subsequents seqs) zones val seqs = fold (subtract direct_sequent_eq) subseqss seqs val cases = map2 (fn l => fn subseqs => ([l], redirect [l] proved subseqs)) c subseqss + val cases' = filter_out (null o snd) cases in - s_cases cases @ redirect (succedent_of_cases cases) proved seqs + s_cases cases' @ redirect (succedent_of_cases cases) proved seqs end in redirect [] axioms seqs diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_satallax.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP/atp_satallax.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,412 @@ +(* Title: HOL/Tools/ATP/atp_satallax.ML + Author: Mathias Fleury, ENS Rennes + Author: Jasmin Blanchette, TU Muenchen + +Satallax proof parser and transformation for Sledgehammer. +*) + +signature ATP_SATALLAX = +sig + val atp_proof_of_tstplike_proof : string -> string ATP_Proof.atp_problem -> string -> + string ATP_Proof.atp_proof +end; + +structure ATP_Satallax : ATP_SATALLAX = +struct + +open ATP_Proof +open ATP_Util +open ATP_Problem + +(*Undocumented format: +thf (number, plain | Axiom | ..., inference(rule, [status(thm), assumptions ([hypotheses list]), +detailed_rule(discharge,used_hypothese_list) *], used_hypotheses_list, premises)) +(seen by tab_mat) + +Also seen -- but we can ignore it: +"tab_inh (a) __11." meaning that the type a is inhabited usueful of variable eigen__11, +*) +fun parse_satallax_tstp_information x = + ((Symbol.scan_ascii_id || ($$ "$" |-- Symbol.scan_ascii_id)) + -- Scan.option ( $$ "(" |-- Scan.option (Symbol.scan_ascii_id --| $$ ",") + -- ((Scan.option (($$ "[" |-- (Scan.option ((scan_general_id + -- Scan.repeat ($$ "," |-- scan_general_id)) >> op ::) --| $$ "]")) + || (skip_term >> K "") >> (fn x => SOME [x])) + >> (fn (SOME x) => x | NONE => NONE)) --| $$ ")"))) x + +fun parse_prem x = + ((Symbol.scan_ascii_id || scan_general_id) --| Scan.option ($$ ":" -- skip_term)) x + +fun parse_prems x = + (($$ "[" |-- parse_prem -- Scan.repeat ($$ "," |-- parse_prem) --| $$ "]") + >> op ::) x + +fun parse_tstp_satallax_extra_arguments x = + ($$ "," |-- scan_general_id -- (($$ "(" |-- Symbol.scan_ascii_id --| $$ "," ) + -- ($$ "[" |-- Scan.option ((parse_satallax_tstp_information + -- Scan.repeat ($$ "," |-- parse_satallax_tstp_information)) >> op ::) + --| $$ "]") -- + (Scan.optional ($$ "," |-- parse_prems) [] -- Scan.optional ($$ "," |-- parse_prems) [] + >> (fn (x, []) => x | (_, x) => x)) + --| $$ ")")) x + +val dummy_satallax_step = ((("~1", "tab_inh"), AAtom (ATerm(("False", []), []))), NONE) +fun parse_tstp_thf0_satallax_line x = + (((Scan.this_string tptp_thf + -- $$ "(") |-- scan_general_id --| $$ "," -- Symbol.scan_ascii_id --| $$ "," + -- parse_thf0_formula -- Scan.option parse_tstp_satallax_extra_arguments --| $$ ")" --| $$ ".") + || (Scan.this_string "tab_inh" |-- skip_term --| $$ ".") + >> K dummy_satallax_step) x + +datatype satallax_step = Satallax_Step of { + id: string, + role: string, + theorem: (string, string, (string, string ATP_Problem.atp_type) ATP_Problem.atp_term, string) + ATP_Problem.atp_formula, + assumptions: string list, + rule: string, + used_assumptions: string list, + detailed_eigen: string, + generated_goal_assumptions: (string * string list) list} + +fun mk_satallax_step id role theorem assumptions rule used_assumptions + generated_goal_assumptions detailed_eigen = + Satallax_Step {id = id, role = role, theorem = theorem, assumptions = assumptions, rule = rule, + used_assumptions = used_assumptions, generated_goal_assumptions = generated_goal_assumptions, + detailed_eigen = detailed_eigen} + +fun get_assumptions (("assumptions", SOME (_ , assumptions)) :: _) = + the_default [] assumptions + | get_assumptions (_ :: l) = get_assumptions l + | get_assumptions [] = [] + +fun get_detailled_eigen ((_, SOME (SOME "eigenvar" , var)) :: _) = + hd (the_default [""] var) + | get_detailled_eigen (_ :: l) = get_detailled_eigen l + | get_detailled_eigen [] = "" + +fun seperate_dependices dependencies = + let + fun sep_dep [] used_assumptions new_goals generated_assumptions _ = + (used_assumptions, new_goals, generated_assumptions) + | sep_dep (x :: l) used_assumptions new_goals generated_assumptions state = + if hd (raw_explode x) = "h" orelse Int.fromString x = NONE then + if state = 0 then + sep_dep l (x :: used_assumptions) new_goals generated_assumptions state + else + sep_dep l used_assumptions new_goals (x :: generated_assumptions) 3 + else + if state = 1 orelse state = 0 then + sep_dep l used_assumptions (x :: new_goals) generated_assumptions 1 + else + raise Fail ("incorrect Satallax proof: " ^ @{make_string} l) + in + sep_dep dependencies [] [] [] 0 + end + +fun create_grouped_goal_assumption rule new_goals generated_assumptions = + let + val number_of_new_goals = length new_goals + val number_of_new_assms = length generated_assumptions + in + if number_of_new_goals = number_of_new_assms then + new_goals ~~ (map single generated_assumptions) + else if 2 * number_of_new_goals = number_of_new_assms then + let + fun group_by_pair (new_goal :: new_goals) (assumpt1 :: assumpt2 :: generated_assumptions) = + (new_goal, [assumpt1, assumpt2]) :: group_by_pair new_goals generated_assumptions + | group_by_pair [] [] = [] + in + group_by_pair new_goals generated_assumptions + end + else + raise Fail ("the rule " ^ rule ^" is not supported in the reconstruction.") + end +fun to_satallax_step (((id, role), formula), (SOME (_,((rule, l), used_rules)))) = + let + val (used_assumptions, new_goals, generated_assumptions) = seperate_dependices used_rules + in + mk_satallax_step id role formula (get_assumptions (the_default [] l)) rule used_assumptions + (create_grouped_goal_assumption rule new_goals generated_assumptions) + (get_detailled_eigen (the_default [] l)) + end + | to_satallax_step (((id, role), formula), NONE) = + mk_satallax_step id role formula [] "assumption" [] [] "" + +fun is_assumption (Satallax_Step {role, ...}) = role = "assumption" orelse role = "axiom" orelse + role = "negated_conjecture" orelse role = "conjecture" + +fun seperate_assumptions_and_steps l = + let + fun seperate_assumption [] l l' = (l, l') + | seperate_assumption (step :: steps) l l' = + if is_assumption step then + seperate_assumption steps (step :: l) l' + else + seperate_assumption steps l (step :: l') + in + seperate_assumption l [] [] + end + +datatype satallax_proof_graph = + Linear_Part of {node: satallax_step, succs: satallax_proof_graph list} | + Tree_Part of {node: satallax_step, deps: satallax_proof_graph list} + +fun find_proof_step ((x as Satallax_Step {id, ...}) :: l) h = + if h = id then x else find_proof_step l h + | find_proof_step [] h = raise Fail ("not_found: " ^ @{make_string} h ^ " (probably a parsing \ + \error)") + +fun remove_not_not (x as ATerm ((op1, _), [ATerm ((op2, _), [th])])) = + if op1 = op2 andalso op1 = tptp_not then th else x + | remove_not_not th = th + +fun tptp_term_equal (ATerm((op1, _), l1), ATerm((op2, _), l2)) = op1 = op2 andalso + fold2 (fn t1 => fn t2 => fn c => c andalso t1 = t2) l1 l2 true + | tptp_term_equal (_, _) = false + +val dummy_true_aterm = ATerm (("$true", [dummy_atype]), []) + +fun find_assumptions_to_inline ths (assm :: assms) to_inline no_inline = + (case List.find (curry (op =) assm o fst) no_inline of + SOME _ => find_assumptions_to_inline ths assms to_inline no_inline + | NONE => + (case List.find (curry (op =) assm o fst) to_inline of + NONE => find_assumptions_to_inline ths assms to_inline no_inline + | SOME (_, th) => + let + val simplified_ths_with_inlined_assumption = + (case List.partition (curry tptp_term_equal th o remove_not_not) ths of + ([], ths) => ATerm ((tptp_not, [dummy_atype]), [th]) :: ths + | (_, _) => []) + in + find_assumptions_to_inline simplified_ths_with_inlined_assumption assms to_inline no_inline + end)) + | find_assumptions_to_inline ths [] _ _ = ths + +fun inline_if_needed_and_simplify th assms to_inline no_inline = + (case find_assumptions_to_inline [th] assms to_inline no_inline of + [] => dummy_true_aterm + | l => foldl1 (fn (a, b) => + (case b of + ATerm (("$false", _), _) => a + | ATerm (("~", _ ), [ATerm (("$true", _), _)]) => a + | _ => ATerm ((tptp_or, [dummy_atype]), [a, b]))) l) + +fun get_conclusion (Satallax_Step {theorem = AAtom theorem, ...}) = theorem + +fun add_assumption new_used_assumptions ((Satallax_Step {id, role, theorem, assumptions, + rule, generated_goal_assumptions, used_assumptions, detailed_eigen})) = + mk_satallax_step id role theorem assumptions rule (new_used_assumptions @ used_assumptions) + generated_goal_assumptions detailed_eigen + +fun set_rule new_rule (Satallax_Step {id, role, theorem, assumptions, + generated_goal_assumptions, used_assumptions, detailed_eigen, ...}) = + mk_satallax_step id role theorem assumptions new_rule used_assumptions + generated_goal_assumptions detailed_eigen + +fun transform_inline_assumption hypotheses_step proof_sketch = + let + fun inline_in_step (Linear_Part {node as Satallax_Step {generated_goal_assumptions, + used_assumptions, rule, ...}, succs}) = + if generated_goal_assumptions = [] then + Linear_Part {node = node, succs = []} + else + let + (*one singel goal is created, two hypothesis can be created, for the "and" rule: + (A /\ B) create two hypotheses A, and B.*) + fun set_hypotheses_as_goal [hypothesis] succs = + Linear_Part {node = set_rule rule (add_assumption used_assumptions + (find_proof_step hypotheses_step hypothesis)), + succs = map inline_in_step succs} + | set_hypotheses_as_goal (hypothesis :: new_goal_hypotheses) succs = + Linear_Part {node = set_rule rule (add_assumption used_assumptions + (find_proof_step hypotheses_step hypothesis)), + succs = [set_hypotheses_as_goal new_goal_hypotheses succs]} + in + set_hypotheses_as_goal (snd (hd generated_goal_assumptions)) succs + end + | inline_in_step (Tree_Part {node = node, deps}) = + Tree_Part {node = node, deps = map inline_in_step deps} + + fun inline_contradictory_assumptions (Linear_Part {node as Satallax_Step{id, theorem, ...}, + succs}) (to_inline, no_inline) = + let + val (succs, inliner) = fold_map inline_contradictory_assumptions succs + (to_inline, (id, theorem) :: no_inline) + in + (Linear_Part {node = node, succs = succs}, inliner) + end + | inline_contradictory_assumptions (Tree_Part {node = Satallax_Step {id, role, + theorem = AAtom theorem, assumptions, rule, generated_goal_assumptions, + used_assumptions, detailed_eigen}, deps}) (to_inline, no_inline) = + let + val (dep', (to_inline', no_inline')) = fold_map inline_contradictory_assumptions deps + (to_inline, no_inline) + val to_inline'' = + map (fn s => (s, get_conclusion (find_proof_step hypotheses_step s))) + (List.filter (fn s => nth_string s 0 = "h") + (used_assumptions @ (map snd generated_goal_assumptions |> flat))) + @ to_inline' + val node' = Satallax_Step {id = id, role = role, theorem = + AAtom (inline_if_needed_and_simplify theorem assumptions to_inline'' no_inline'), + assumptions = assumptions, rule = rule, + generated_goal_assumptions = generated_goal_assumptions, detailed_eigen = detailed_eigen, + used_assumptions = + List.filter (fn s => List.find (curry (op =) s o fst) to_inline = NONE) + used_assumptions} + in + (Tree_Part {node = node', deps = dep'}, (to_inline'', no_inline')) + end + in + fst (inline_contradictory_assumptions (inline_in_step proof_sketch) ([], [])) + end + +fun correct_dependencies (Linear_Part {node, succs}) = + Linear_Part {node = node, succs = map correct_dependencies succs} + | correct_dependencies (Tree_Part {node, deps}) = + let + val new_used_assumptions = + map (fn Linear_Part {node = (Satallax_Step{id, ...}), ...} => id + | Tree_Part {node = (Satallax_Step{id, ...}), ...} => id) deps + in + Tree_Part {node = add_assumption new_used_assumptions node, + deps = map correct_dependencies deps} + end + +fun create_satallax_proof_graph (hypotheses_step, proof_sketch) = + let + fun create_step (step as Satallax_Step {generated_goal_assumptions, ...}) = + Linear_Part {node = step, + succs = map (create_step o (find_proof_step (hypotheses_step @ proof_sketch))) + (map fst generated_goal_assumptions)} + fun reverted_discharged_steps is_branched (Linear_Part {node as + Satallax_Step {generated_goal_assumptions, ...}, succs}) = + if is_branched orelse length generated_goal_assumptions > 1 then + Tree_Part {node = node, deps = map (reverted_discharged_steps true) succs} + else + Linear_Part {node = node, succs = map (reverted_discharged_steps is_branched) succs} + val proof_with_correct_sense = + correct_dependencies (reverted_discharged_steps false + (create_step (find_proof_step proof_sketch "0" ))) + in + transform_inline_assumption hypotheses_step proof_with_correct_sense + end + +val satallax_known_theorems = ["eq_ind", "eq_trans2", "eq_trans3", "eq_neg_neg_id", "eq_true", + "eq_and_nor", "eq_or_nand", "eq_or_imp", "eq_and_imp", "eq_imp_or", "eq_iff", "eq_sym_eq", + "eq_forall_nexists", "eq_exists_nforall", "eq_leib1", "eq_leib2", "eq_leib3", "eq_leib4", + "eq_eta", "SinhE", "eq_forall_Seps", "eq_SPi_Seps", "eq_exists_Seps"] +val is_special_satallax_rule = member (op =) satallax_known_theorems + +fun terms_to_upper_case var (AAbs (((var', ty), b), ts)) = + let + val bdy = terms_to_upper_case var b + val ts' = map (terms_to_upper_case var) ts + in + AAbs (((((var = var' ? String.implode o (map Char.toUpper) o String.explode) var'), ty), + bdy), ts') + end + | terms_to_upper_case var (ATerm ((var', ty), ts)) = + ATerm ((((var = var' ? String.implode o (map Char.toUpper) o String.explode) var'), + ty), map (terms_to_upper_case var) ts) + +fun add_quantifier_in_tree_part vars_to_add assumption_to_add (Linear_Part {node, succs}) = + Linear_Part {node = node, succs = map (add_quantifier_in_tree_part vars_to_add assumption_to_add) succs} + | add_quantifier_in_tree_part vars_to_add assumption_to_add (Tree_Part {node = Satallax_Step {rule, detailed_eigen, + id, role, theorem = AAtom theorem, assumptions, used_assumptions, generated_goal_assumptions}, + deps}) = + let + val theorem' = fold (fn v => fn body => terms_to_upper_case v body) vars_to_add theorem + val theorem'' = theorem' + val node' = mk_satallax_step id role (AAtom theorem'') assumptions rule + (used_assumptions @ (filter (curry (op <=) (the (Int.fromString id)) o size) + assumption_to_add)) generated_goal_assumptions detailed_eigen + in + if detailed_eigen <> "" then + Tree_Part {node = node', + deps = map (add_quantifier_in_tree_part (detailed_eigen :: vars_to_add) + (used_assumptions @ assumption_to_add)) deps} + else + Tree_Part {node = node', + deps = map (add_quantifier_in_tree_part vars_to_add assumption_to_add) deps} + end + +fun transform_to_standard_atp_step already_transformed proof = + let + fun create_fact_step id = + ((id, [id]), Axiom, AAtom (ATerm((id, []), [])), "", []) + fun transform_one_step already_transformed (Satallax_Step {id, theorem, used_assumptions, role, + rule, ...}) = + let + val role' = role_of_tptp_string role + val new_transformed = List.filter + (fn s => size s >=4 andalso not (is_special_satallax_rule s) andalso not + (member (op =) already_transformed s)) used_assumptions + in + (map create_fact_step new_transformed + @ [((id, []), if role' = Unknown then Plain else role', theorem, rule, + map (fn s => (s, [])) (filter_out is_special_satallax_rule used_assumptions))], + new_transformed @ already_transformed) + end + fun transform_steps (Linear_Part {node, succs}) (already_transformed:string list) = + transform_one_step already_transformed node + ||> (fold_map transform_steps succs) + ||> apfst flat + |> (fn (a, (b, transformed)) => (a @ b, transformed)) + | transform_steps (Tree_Part {node, deps}) (already_transformed: string list) = + fold_map transform_steps deps already_transformed + |>> flat + ||> (fn transformed => transform_one_step transformed node) + |> (fn (a, (b, transformed)) => (a @ b, transformed)) + in + fst (transform_steps proof already_transformed) + end + +fun remove_unused_dependency steps = + let + fun find_all_ids [] = [] + | find_all_ids (((id, _), _, _, _, _) :: steps) = id :: find_all_ids steps + fun keep_only_used used_ids steps = + let + fun remove_unused (((id, ids), role, theorem, rule, deps) :: steps) = + (((id, ids), role, theorem, rule, filter (member (op =) used_ids o fst) deps) :: steps) + | remove_unused [] = [] + in + remove_unused steps + end + in + keep_only_used (find_all_ids steps) steps + end + +fun parse_proof local_name problem = + strip_spaces_except_between_idents + #> raw_explode + #> + (if local_name <> satallaxN then + (Scan.error (!! (fn _ => raise UNRECOGNIZED_ATP_PROOF ()) + (Scan.finite Symbol.stopper (Scan.repeat1 (parse_line local_name problem) >> flat))) + #> fst) + else + (Scan.error (!! (fn _ => raise UNRECOGNIZED_ATP_PROOF ()) + (Scan.finite Symbol.stopper (Scan.repeat1 (parse_tstp_thf0_satallax_line)))) + #> fst + #> rev + #> map to_satallax_step + #> seperate_assumptions_and_steps + #> create_satallax_proof_graph + #> add_quantifier_in_tree_part [] [] + #> transform_to_standard_atp_step [] + #> remove_unused_dependency)) + +fun atp_proof_of_tstplike_proof _ _ "" = [] + | atp_proof_of_tstplike_proof local_prover problem tstp = + (case core_of_agsyhol_proof tstp of + SOME facts => facts |> map (core_inference agsyhol_core_rule) + | NONE => + tstp ^ "$" (* the $ sign acts as a sentinel (FIXME: needed?) *) + |> parse_proof local_prover problem + |> local_prover = vampireN ? perhaps (try (sort (vampire_step_name_ord o pairself #1))) + |> local_prover = zipperpositionN ? rev) + +end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_systems.ML --- a/src/HOL/Tools/ATP/atp_systems.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_systems.ML Wed Aug 27 15:52:58 2014 +0200 @@ -397,17 +397,16 @@ (* LEO-II *) -(* LEO-II supports definitions, but it performs significantly better on our - benchmarks when they are not used. *) val leo2_thf0 = THF (Monomorphic, THF_Without_Choice) val leo2_config : atp_config = {exec = K (["LEO2_HOME"], ["leo.opt", "leo"]), - arguments = fn _ => fn _ => fn _ => fn timeout => fn file_name => fn _ => - "--foatp e --atp e=\"$E_HOME\"/eprover \ - \--atp epclextract=\"$E_HOME\"/epclextract \ - \--proofoutput 1 --timeout " ^ string_of_int (to_secs 1 timeout) ^ " " ^ - file_name, + arguments = fn _ => fn full_proofs => fn _ => fn timeout => fn file_name => fn _ => + "--foatp e --atp e=\"$E_HOME\"/eprover \ + \--atp epclextract=\"$E_HOME\"/epclextract \ + \--proofoutput 1 --timeout " ^ string_of_int (to_secs 1 timeout) ^ " " ^ + (if full_proofs then "--notReplLeibnizEQ --notReplAndrewsEQ --notUseExtCnfCmbd " else "") ^ + file_name, proof_delims = tstp_proof_delims, known_failures = [(TimedOut, "CPU time limit exceeded, terminating"), @@ -431,9 +430,9 @@ val satallax_config : atp_config = {exec = K (["SATALLAX_HOME"], ["satallax.opt", "satallax"]), arguments = fn _ => fn _ => fn _ => fn timeout => fn file_name => fn _ => - "-p hocore -t " ^ string_of_int (to_secs 1 timeout) ^ " " ^ file_name, + "-p tstp -t " ^ string_of_int (to_secs 1 timeout) ^ " " ^ file_name, proof_delims = - [("% Higher-Order Unsat Core BEGIN", "% Higher-Order Unsat Core END")], + [("% SZS output start Proof", "% SZS output end Proof")], known_failures = known_szs_status_failures, prem_role = Hypothesis, best_slices = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_util.ML --- a/src/HOL/Tools/ATP/atp_util.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_util.ML Wed Aug 27 15:52:58 2014 +0200 @@ -77,31 +77,29 @@ | stringN_of_int k n = stringN_of_int (k - 1) (n div 10) ^ string_of_int (n mod 10) +fun is_spaceish c = Char.isSpace c orelse c = #"\127" (* DEL -- no idea where these come from *) + fun strip_spaces skip_comments is_evil = let fun strip_c_style_comment [] accum = accum - | strip_c_style_comment (#"*" :: #"/" :: cs) accum = - strip_spaces_in_list true cs accum + | strip_c_style_comment (#"*" :: #"/" :: cs) accum = strip_spaces_in_list true cs accum | strip_c_style_comment (_ :: cs) accum = strip_c_style_comment cs accum and strip_spaces_in_list _ [] accum = accum | strip_spaces_in_list true (#"%" :: cs) accum = - strip_spaces_in_list true (cs |> take_prefix (not_equal #"\n") |> snd) - accum - | strip_spaces_in_list true (#"/" :: #"*" :: cs) accum = - strip_c_style_comment cs accum - | strip_spaces_in_list _ [c1] accum = - accum |> not (Char.isSpace c1) ? cons c1 + strip_spaces_in_list true (cs |> take_prefix (not_equal #"\n") |> snd) accum + | strip_spaces_in_list true (#"/" :: #"*" :: cs) accum = strip_c_style_comment cs accum + | strip_spaces_in_list _ [c1] accum = accum |> not (is_spaceish c1) ? cons c1 | strip_spaces_in_list skip_comments (cs as [_, _]) accum = accum |> fold (strip_spaces_in_list skip_comments o single) cs | strip_spaces_in_list skip_comments (c1 :: c2 :: c3 :: cs) accum = - if Char.isSpace c1 then + if is_spaceish c1 then strip_spaces_in_list skip_comments (c2 :: c3 :: cs) accum - else if Char.isSpace c2 then - if Char.isSpace c3 then + else if is_spaceish c2 then + if is_spaceish c3 then strip_spaces_in_list skip_comments (c1 :: c3 :: cs) accum else strip_spaces_in_list skip_comments (c3 :: cs) - (c1 :: accum |> forall is_evil [c1, c3] ? cons #" ") + (c1 :: accum |> forall is_evil [c1, c3] ? cons #" ") else strip_spaces_in_list skip_comments (c2 :: c3 :: cs) (cons c1 accum) in diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/ATP/atp_waldmeister.ML --- a/src/HOL/Tools/ATP/atp_waldmeister.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/ATP/atp_waldmeister.ML Wed Aug 27 15:52:58 2014 +0200 @@ -181,7 +181,7 @@ val thy = Proof_Context.theory_of ctxt val t = u |> atp_to_trm - |> singleton (infer_formula_types ctxt) + |> singleton (infer_formulas_types ctxt) |> HOLogic.mk_Trueprop in (name, role, t, rule, deps) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_comp.ML --- a/src/HOL/Tools/BNF/bnf_comp.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_comp.ML Wed Aug 27 15:52:58 2014 +0200 @@ -203,7 +203,7 @@ fun tac {context = ctxt, prems = _} = mk_simplified_set_tac ctxt (collect_set_map_of_bnf outer); val set'_eq_set = - Goal.prove names_lthy [] [] goal tac + Goal.prove (*no sorry*) names_lthy [] [] goal tac |> Thm.close_derivation; val set' = fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of set'_eq_set))); in diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_def.ML --- a/src/HOL/Tools/BNF/bnf_def.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_def.ML Wed Aug 27 15:52:58 2014 +0200 @@ -55,10 +55,12 @@ val in_mono_of_bnf: bnf -> thm val in_rel_of_bnf: bnf -> thm val inj_map_of_bnf: bnf -> thm + val inj_map_strong_of_bnf: bnf -> thm val map_comp0_of_bnf: bnf -> thm val map_comp_of_bnf: bnf -> thm val map_cong0_of_bnf: bnf -> thm val map_cong_of_bnf: bnf -> thm + val map_cong_simp_of_bnf: bnf -> thm val map_def_of_bnf: bnf -> thm val map_id0_of_bnf: bnf -> thm val map_id_of_bnf: bnf -> thm @@ -73,6 +75,7 @@ val rel_cong_of_bnf: bnf -> thm val rel_conversep_of_bnf: bnf -> thm val rel_mono_of_bnf: bnf -> thm + val rel_mono_strong0_of_bnf: bnf -> thm val rel_mono_strong_of_bnf: bnf -> thm val rel_eq_of_bnf: bnf -> thm val rel_flip_of_bnf: bnf -> thm @@ -222,8 +225,10 @@ in_mono: thm lazy, in_rel: thm lazy, inj_map: thm lazy, + inj_map_strong: thm lazy, map_comp: thm lazy, map_cong: thm lazy, + map_cong_simp: thm lazy, map_id: thm lazy, map_ident0: thm lazy, map_ident: thm lazy, @@ -232,7 +237,9 @@ rel_flip: thm lazy, set_map: thm lazy list, rel_cong: thm lazy, + rel_map: thm list lazy, rel_mono: thm lazy, + rel_mono_strong0: thm lazy, rel_mono_strong: thm lazy, rel_Grp: thm lazy, rel_conversep: thm lazy, @@ -240,8 +247,9 @@ }; fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel - inj_map map_comp map_cong map_id map_ident0 map_ident map_transfer rel_eq rel_flip set_map - rel_cong rel_mono rel_mono_strong rel_Grp rel_conversep rel_OO = { + inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0 map_ident + map_transfer rel_eq rel_flip set_map rel_cong rel_map rel_mono rel_mono_strong0 rel_mono_strong + rel_Grp rel_conversep rel_OO = { bd_Card_order = bd_Card_order, bd_Cinfinite = bd_Cinfinite, bd_Cnotzero = bd_Cnotzero, @@ -251,8 +259,10 @@ in_mono = in_mono, in_rel = in_rel, inj_map = inj_map, + inj_map_strong = inj_map_strong, map_comp = map_comp, map_cong = map_cong, + map_cong_simp = map_cong_simp, map_id = map_id, map_ident0 = map_ident0, map_ident = map_ident, @@ -261,7 +271,9 @@ rel_flip = rel_flip, set_map = set_map, rel_cong = rel_cong, + rel_map = rel_map, rel_mono = rel_mono, + rel_mono_strong0 = rel_mono_strong0, rel_mono_strong = rel_mono_strong, rel_Grp = rel_Grp, rel_conversep = rel_conversep, @@ -277,8 +289,10 @@ in_mono, in_rel, inj_map, + inj_map_strong, map_comp, map_cong, + map_cong_simp, map_id, map_ident0, map_ident, @@ -287,7 +301,9 @@ rel_flip, set_map, rel_cong, + rel_map, rel_mono, + rel_mono_strong0, rel_mono_strong, rel_Grp, rel_conversep, @@ -301,8 +317,10 @@ in_mono = Lazy.map f in_mono, in_rel = Lazy.map f in_rel, inj_map = Lazy.map f inj_map, + inj_map_strong = Lazy.map f inj_map_strong, map_comp = Lazy.map f map_comp, map_cong = Lazy.map f map_cong, + map_cong_simp = Lazy.map f map_cong_simp, map_id = Lazy.map f map_id, map_ident0 = Lazy.map f map_ident0, map_ident = Lazy.map f map_ident, @@ -311,7 +329,9 @@ rel_flip = Lazy.map f rel_flip, set_map = map (Lazy.map f) set_map, rel_cong = Lazy.map f rel_cong, + rel_map = Lazy.map (map f) rel_map, rel_mono = Lazy.map f rel_mono, + rel_mono_strong0 = Lazy.map f rel_mono_strong0, rel_mono_strong = Lazy.map f rel_mono_strong, rel_Grp = Lazy.map f rel_Grp, rel_conversep = Lazy.map f rel_conversep, @@ -421,6 +441,7 @@ val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf; val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf; val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf; +val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf; val map_def_of_bnf = #map_def o #defs o rep_bnf; val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf; val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf; @@ -430,6 +451,7 @@ val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf; val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf; val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf; +val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf; val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf; val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf; val rel_def_of_bnf = #rel_def o #defs o rep_bnf; @@ -441,6 +463,7 @@ val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf; val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf; val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf; +val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf; val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf; val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf; val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf; @@ -594,6 +617,7 @@ val in_monoN = "in_mono"; val in_relN = "in_rel"; val inj_mapN = "inj_map"; +val inj_map_strongN = "inj_map_strong"; val map_id0N = "map_id0"; val map_idN = "map_id"; val map_identN = "map_ident"; @@ -601,6 +625,7 @@ val map_compN = "map_comp"; val map_cong0N = "map_cong0"; val map_congN = "map_cong"; +val map_cong_simpN = "map_cong_simp"; val map_transferN = "map_transfer"; val rel_eqN = "rel_eq"; val rel_flipN = "rel_flip"; @@ -609,7 +634,9 @@ val set_bdN = "set_bd"; val rel_GrpN = "rel_Grp"; val rel_conversepN = "rel_conversep"; +val rel_mapN = "rel_map" val rel_monoN = "rel_mono" +val rel_mono_strong0N = "rel_mono_strong0" val rel_mono_strongN = "rel_mono_strong" val rel_comppN = "rel_compp"; val rel_compp_GrpN = "rel_compp_Grp"; @@ -647,9 +674,9 @@ (in_bdN, [Lazy.force (#in_bd facts)]), (in_monoN, [Lazy.force (#in_mono facts)]), (in_relN, [Lazy.force (#in_rel facts)]), - (inj_mapN, [Lazy.force (#inj_map facts)]), (map_comp0N, [#map_comp0 axioms]), (map_transferN, [Lazy.force (#map_transfer facts)]), + (rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]), (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)]), (set_map0N, #set_map0 axioms), (set_bdN, #set_bd axioms)] @ @@ -664,9 +691,12 @@ fun note_unless_dont_note (noted0, lthy0) = let val notes = - [(map_compN, [Lazy.force (#map_comp facts)], []), + [(inj_mapN, [Lazy.force (#inj_map facts)], []), + (inj_map_strongN, [Lazy.force (#inj_map_strong facts)], []), + (map_compN, [Lazy.force (#map_comp facts)], []), (map_cong0N, [#map_cong0 axioms], []), (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs), + (map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []), (map_idN, [Lazy.force (#map_id facts)], []), (map_id0N, [#map_id0 axioms], []), (map_identN, [Lazy.force (#map_ident facts)], []), @@ -676,6 +706,7 @@ (rel_eqN, [Lazy.force (#rel_eq facts)], []), (rel_flipN, [Lazy.force (#rel_flip facts)], []), (rel_GrpN, [Lazy.force (#rel_Grp facts)], []), + (rel_mapN, Lazy.force (#rel_map facts), []), (rel_monoN, [Lazy.force (#rel_mono facts)], []), (set_mapN, map Lazy.force (#set_map facts), [])] |> filter_out (null o #2) @@ -920,6 +951,7 @@ val pred2RTs = map2 mk_pred2T As' Bs'; val pred2RTsAsCs = map2 mk_pred2T As' Cs; val pred2RTsBsCs = map2 mk_pred2T Bs' Cs; + val pred2RTsCsBs = map2 mk_pred2T Cs Bs'; val pred2RT's = map2 mk_pred2T Bs' As'; val self_pred2RTs = map2 mk_pred2T As' As'; val transfer_domRTs = map2 mk_pred2T As' B1Ts; @@ -941,15 +973,19 @@ fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel; val pre_names_lthy = lthy; - val (((((((((((((((fs, gs), hs), x), y), zs), ys), As), - As_copy), bs), Rs), Rs_copy), Ss), + val (((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), zs), zs'), ys), As), + As_copy), bs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy |> mk_Frees "f" (map2 (curry op -->) As' Bs') + ||>> mk_Frees "f" (map2 (curry op -->) As' Bs') ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs) ||>> mk_Frees "h" (map2 (curry op -->) As' Ts) + ||>> mk_Frees "i" (map2 (curry op -->) As' Cs) + ||>> yield_singleton (mk_Frees "x") CA' ||>> yield_singleton (mk_Frees "x") CA' ||>> yield_singleton (mk_Frees "y") CB' ||>> mk_Frees "z" As' + ||>> mk_Frees "z" As' ||>> mk_Frees "y" Bs' ||>> mk_Frees "A" (map HOLogic.mk_setT As') ||>> mk_Frees "A" (map HOLogic.mk_setT As') @@ -957,6 +993,8 @@ ||>> mk_Frees "R" pred2RTs ||>> mk_Frees "R" pred2RTs ||>> mk_Frees "S" pred2RTsBsCs + ||>> mk_Frees "S" pred2RTsAsCs + ||>> mk_Frees "S" pred2RTsCsBs ||>> mk_Frees "R" transfer_domRTs ||>> mk_Frees "S" transfer_ranRTs; @@ -981,13 +1019,13 @@ fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app)) end; - fun mk_map_cong_prem x z set f f_copy = - Logic.all z (Logic.mk_implies + fun mk_map_cong_prem mk_implies x z set f f_copy = + Logic.all z (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (f $ z, f_copy $ z))); val map_cong0_goal = let - val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy; + val prems = map4 (mk_map_cong_prem Logic.mk_implies x) zs bnf_sets_As fs fs_copy; val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, Term.list_comb (bnf_map_AsBs, fs_copy) $ x); in @@ -1022,6 +1060,7 @@ val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC'; val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC'; + val relCsBs = mk_bnf_rel pred2RTsCsBs CC' CB'; val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss); val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss)); val le_rel_OO_goal = @@ -1116,20 +1155,23 @@ val map_ident = Lazy.lazy (fn () => mk_map_ident lthy (Lazy.force map_id)); val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms)); - fun mk_map_cong () = + fun mk_map_cong mk_implies () = let val prem0 = mk_Trueprop_eq (x, x_copy); - val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy; + val prems = map4 (mk_map_cong_prem mk_implies x_copy) zs bnf_sets_As fs fs_copy; val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x, Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy); val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy) (Logic.list_implies (prem0 :: prems, eq)); in - Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms)) + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => + unfold_thms_tac lthy @{thms simp_implies_def} THEN + mk_map_cong_tac lthy (#map_cong0 axioms)) |> Thm.close_derivation end; - val map_cong = Lazy.lazy mk_map_cong; + val map_cong = Lazy.lazy (mk_map_cong Logic.mk_implies); + val map_cong_simp = Lazy.lazy (mk_map_cong (fn (a, b) => @{term simp_implies} $ a $ b)); fun mk_inj_map () = let @@ -1288,7 +1330,7 @@ val rel_flip = Lazy.lazy mk_rel_flip; - fun mk_rel_mono_strong () = + fun mk_rel_mono_strong0 () = let fun mk_prem setA setB R S a b = HOLogic.mk_Trueprop @@ -1301,13 +1343,44 @@ in Goal.prove_sorry lthy [] [] (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl))) - (fn {context = ctxt, prems = _} => mk_rel_mono_strong_tac ctxt (Lazy.force in_rel) + (fn {context = ctxt, prems = _} => mk_rel_mono_strong0_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map)) |> Thm.close_derivation end; + val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0; + + fun mk_rel_mono_strong () = Object_Logic.rulify lthy (Lazy.force rel_mono_strong0) + val rel_mono_strong = Lazy.lazy mk_rel_mono_strong; + fun mk_rel_map () = + let + fun mk_goal lhs rhs = + fold_rev Logic.all ([x, y] @ S_CsBs @ S_AsCs @ is @ gs) (mk_Trueprop_eq (lhs, rhs)); + + val lhss = + [Term.list_comb (relCsBs, S_CsBs) $ (Term.list_comb (bnf_map_AsCs, is) $ x) $ y, + Term.list_comb (relAsCs, S_AsCs) $ x $ (Term.list_comb (bnf_map_BsCs, gs) $ y)]; + val rhss = + [Term.list_comb (rel, map3 (fn f => fn P => fn T => + mk_vimage2p f (HOLogic.id_const T) $ P) is S_CsBs Bs') $ x $ y, + Term.list_comb (rel, map3 (fn f => fn P => fn T => + mk_vimage2p (HOLogic.id_const T) f $ P) gs S_AsCs As') $ x $ y]; + val goals = map2 mk_goal lhss rhss; + in + goals + |> map (fn goal => Goal.prove_sorry lthy [] [] goal + (fn {context = ctxt, prems = _} => + mk_rel_map0_tac ctxt live (Lazy.force rel_OO) (Lazy.force rel_conversep) + (Lazy.force rel_Grp) (Lazy.force map_id))) + |> map (unfold_thms lthy @{thms vimage2p_def[of id, unfolded id_apply] + vimage2p_def[of _ id, unfolded id_apply]}) + |> map Thm.close_derivation + end; + + val rel_map = Lazy.lazy mk_rel_map; + fun mk_map_transfer () = let val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs; @@ -1327,11 +1400,36 @@ val map_transfer = Lazy.lazy mk_map_transfer; + fun mk_inj_map_strong () = + let + val assms = map5 (fn setA => fn z => fn f => fn z' => fn f' => + fold_rev Logic.all [z, z'] + (Logic.mk_implies (mk_Trueprop_mem (z, setA $ x), + Logic.mk_implies (mk_Trueprop_mem (z', setA $ x'), + Logic.mk_implies (mk_Trueprop_eq (f $ z, f' $ z'), + mk_Trueprop_eq (z, z')))))) bnf_sets_As zs fs zs' fs'; + val concl = Logic.mk_implies + (mk_Trueprop_eq + (Term.list_comb (bnf_map_AsBs, fs) $ x, + Term.list_comb (bnf_map_AsBs, fs') $ x'), + mk_Trueprop_eq (x, x')); + val goal = fold_rev Logic.all (x :: x' :: fs @ fs') + (fold_rev (curry Logic.mk_implies) assms concl); + in + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => + mk_inj_map_strong_tac ctxt (Lazy.force rel_eq) (Lazy.force rel_map) + (Lazy.force rel_mono_strong)) + |> Thm.close_derivation + end; + + val inj_map_strong = Lazy.lazy mk_inj_map_strong; + val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def; val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong - in_mono in_rel inj_map map_comp map_cong map_id map_ident0 map_ident map_transfer rel_eq - rel_flip set_map rel_cong rel_mono rel_mono_strong rel_Grp rel_conversep rel_OO; + in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0 + map_ident map_transfer rel_eq rel_flip set_map rel_cong rel_map rel_mono rel_mono_strong0 + rel_mono_strong rel_Grp rel_conversep rel_OO; val wits = map2 mk_witness bnf_wits wit_thms; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_def_tactics.ML --- a/src/HOL/Tools/BNF/bnf_def_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_def_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -11,6 +11,7 @@ sig val mk_collect_set_map_tac: thm list -> tactic val mk_in_mono_tac: int -> tactic + val mk_inj_map_strong_tac: Proof.context -> thm -> thm list -> thm -> tactic val mk_inj_map_tac: int -> thm -> thm -> thm -> thm -> tactic val mk_map_id: thm -> thm val mk_map_ident: Proof.context -> thm -> thm @@ -23,8 +24,9 @@ val mk_rel_OO_le_tac: Proof.context -> thm list -> thm -> thm -> thm -> thm list -> tactic val mk_rel_conversep_tac: thm -> thm -> tactic val mk_rel_conversep_le_tac: Proof.context -> thm list -> thm -> thm -> thm -> thm list -> tactic + val mk_rel_map0_tac: Proof.context -> int -> thm -> thm -> thm -> thm -> tactic val mk_rel_mono_tac: thm list -> thm -> tactic - val mk_rel_mono_strong_tac: Proof.context -> thm -> thm list -> tactic + val mk_rel_mono_strong0_tac: Proof.context -> thm -> thm list -> tactic val mk_map_transfer_tac: Proof.context -> thm -> thm -> thm list -> thm -> thm -> tactic @@ -69,6 +71,17 @@ REPEAT_DETERM_N n o atac)) end; +fun mk_inj_map_strong_tac ctxt rel_eq rel_maps rel_mono_strong = + let + val rel_eq' = rel_eq RS @{thm predicate2_eqD}; + val rel_maps' = map (fn thm => thm RS iffD1) rel_maps; + in + HEADGOAL (dtac (rel_eq' RS iffD2) THEN' rtac (rel_eq' RS iffD1)) THEN + EVERY (map (HEADGOAL o dtac) rel_maps') THEN + HEADGOAL (etac rel_mono_strong) THEN + TRYALL (Goal.assume_rule_tac ctxt) + end; + fun mk_collect_set_map_tac set_map0s = (rtac (@{thm collect_comp} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN' EVERY' (map (fn set_map0 => @@ -118,6 +131,26 @@ rtac @{thm equalityI}, rtac subset_UNIV, rtac subsetI, rtac CollectI, CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac map_id0])) 1; +fun mk_rel_map0_tac ctxt live rel_compp rel_conversep rel_Grp map_id = + if live = 0 then + HEADGOAL (Goal.conjunction_tac) THEN + unfold_thms_tac ctxt @{thms id_apply} THEN + ALLGOALS (rtac refl) + else + let + val ks = 1 upto live; + in + Goal.conjunction_tac 1 THEN + unfold_thms_tac ctxt [rel_compp, rel_conversep, rel_Grp, @{thm vimage2p_Grp}] THEN + TRYALL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, + resolve_tac [map_id, refl], rtac CollectI, + CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac, + rtac @{thm conversepI}, rtac @{thm GrpI}, resolve_tac [map_id, refl], rtac CollectI, + CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, + REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE}, + dtac (trans OF [sym, map_id]), hyp_subst_tac ctxt, atac]) + end; + fun mk_rel_mono_tac rel_OO_Grps in_mono = let val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac @@ -176,7 +209,7 @@ REPEAT_DETERM_N n o rtac @{thm fst_fstOp}, in_tac @{thm fstOp_in}, rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0, - REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, + REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, rtac ballE, rtac subst, rtac @{thm csquare_def}, rtac @{thm csquare_fstOp_sndOp}, atac, etac notE, etac set_mp, atac], @@ -190,7 +223,7 @@ in_tac @{thm sndOp_in}] 1 end; -fun mk_rel_mono_strong_tac ctxt in_rel set_maps = +fun mk_rel_mono_strong0_tac ctxt in_rel set_maps = if null set_maps then atac 1 else unfold_tac ctxt [in_rel] THEN @@ -231,10 +264,10 @@ let val bd'_Cinfinite = bd_Cinfinite RS @{thm Cinfinite_csum1}; val inserts = - map (fn set_bd => + map (fn set_bd => iffD2 OF [@{thm card_of_ordLeq}, @{thm ordLeq_ordIso_trans} OF [set_bd, bd_Card_order RS @{thm card_of_Field_ordIso} RS @{thm ordIso_symmetric}]]) - set_bds; + set_bds; in EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac @{thm cprod_cinfinite_bound}, rtac (ctrans OF @{thms ordLeq_csum2 ordLeq_cexp2}), rtac @{thm card_of_Card_order}, diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_fp_def_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -21,17 +21,17 @@ val nesting_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list type lfp_sugar_thms = - (thm list * thm * Args.src list) * (thm list list * Args.src list) + (thm list * thm * Token.src list) * (thm list list * Token.src list) val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms type gfp_sugar_thms = - ((thm list * thm) list * (Args.src list * Args.src list)) + ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list - * (thm list list * Args.src list) - * (thm list list list * Args.src list) + * (thm list list * Token.src list) + * (thm list list list * Token.src list) val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms @@ -98,11 +98,14 @@ val EqN = "Eq_"; +val ctr_transferN = "ctr_transfer"; val corec_codeN = "corec_code"; -val disc_map_iffN = "disc_map_iff"; -val sel_mapN = "sel_map"; -val sel_setN = "sel_set"; -val set_emptyN = "set_empty"; +val map_disc_iffN = "map_disc_iff"; +val map_selN = "map_sel"; +val set_casesN = "set_cases"; +val set_introsN = "set_intros"; +val set_inductN = "set_induct"; +val set_selN = "set_sel"; structure Data = Generic_Data ( @@ -112,10 +115,34 @@ fun merge data : T = Symtab.merge (K true) data; ); -fun choose_relator Rs AB = find_first (fastype_of #> binder_types #> (fn [A, B] => AB = (A, B))) Rs; -fun build_the_rel ctxt Rs Ts A B = build_rel ctxt Ts (the o choose_relator Rs) (A, B); +fun zipping_map f = + let + fun zmap _ [] = [] + | zmap xs (y :: ys) = f (xs, y, ys) :: zmap (xs @ [y]) ys + in zmap [] end; + +fun choose_binary_fun fs AB = + find_first (fastype_of #> binder_types #> (fn [A, B] => AB = (A, B))) fs; +fun build_binary_fun_app fs a b = + Option.map (rapp b o rapp a) (choose_binary_fun fs (fastype_of a, fastype_of b)); + +fun build_the_rel ctxt Rs Ts A B = build_rel ctxt Ts (the o choose_binary_fun Rs) (A, B); fun build_rel_app ctxt Rs Ts a b = build_the_rel ctxt Rs Ts (fastype_of a) (fastype_of b) $ a $ b; +val name_of_set = name_of_const "set"; + + +fun mk_parametricity_goals ctxt Rs fs gs = + let + val prems = + map (foldr1 (uncurry mk_rel_fun) o + uncurry (map2 (build_the_rel ctxt Rs [])) o + pairself (fastype_of #> strip_type #> (fn (Ts, T) => Ts @ [T]))) + (fs ~~ gs); + in + map3 (fn prem => fn f => fn g => HOLogic.mk_Trueprop (prem $ f $ g)) prems fs gs + end + fun fp_sugar_of ctxt = Symtab.lookup (Data.get (Context.Proof ctxt)) #> Option.map (transfer_fp_sugar ctxt); @@ -276,7 +303,7 @@ fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p; type lfp_sugar_thms = - (thm list * thm * Args.src list) * (thm list list * Args.src list); + (thm list * thm * Token.src list) * (thm list list * Token.src list); fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (recss, rec_attrs)) = ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs), @@ -287,21 +314,21 @@ morph_lfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of; type gfp_sugar_thms = - ((thm list * thm) list * (Args.src list * Args.src list)) + ((thm list * thm) list * (Token.src list * Token.src list)) * thm list list * thm list list - * (thm list list * Args.src list) - * (thm list list list * Args.src list); + * (thm list list * Token.src list) + * (thm list list list * Token.src list); fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs_pair), - corecss, disc_corecss, (disc_corec_iffss, disc_corec_iff_attrs), - (sel_corecsss, sel_corec_attrs)) = + corecss, corec_discss, (corec_disc_iffss, corec_disc_iff_attrs), + (corec_selsss, corec_sel_attrs)) = ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs, coinduct_attrs_pair), map (map (Morphism.thm phi)) corecss, - map (map (Morphism.thm phi)) disc_corecss, - (map (map (Morphism.thm phi)) disc_corec_iffss, disc_corec_iff_attrs), - (map (map (map (Morphism.thm phi))) sel_corecsss, sel_corec_attrs)) : gfp_sugar_thms; + map (map (Morphism.thm phi)) corec_discss, + (map (map (Morphism.thm phi)) corec_disc_iffss, corec_disc_iff_attrs), + (map (map (map (Morphism.thm phi))) corec_selsss, corec_sel_attrs)) : gfp_sugar_thms; val transfer_gfp_sugar_thms = morph_gfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of; @@ -456,7 +483,7 @@ #>> map (fn thm => Thm.permute_prems 0 (~1) (thm RS prop)) ##> (fn thm => Thm.permute_prems 0 (~nn) (if nn = 1 then thm RS prop - else funpow nn (fn thm => Local_Defs.unfold lthy @{thms conj_assoc} (thm RS prop_conj)) thm)); + else funpow nn (fn thm => unfold_thms lthy @{thms conj_assoc} (thm RS prop_conj)) thm)); fun mk_induct_attrs ctrss = let @@ -494,10 +521,10 @@ val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq (map2 (build_the_rel lthy (Rs @ IRs) []) fpA_Ts fpB_Ts) IRs)); - val rel_induct0_thm = Goal.prove_sorry lthy [] premises goal - (fn {context = ctxt, prems = prems} => - mk_rel_induct0_tac ctxt ctor_rel_induct prems (map (certify ctxt) IRs) exhausts ctor_defss - ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs) + val rel_induct0_thm = + Goal.prove_sorry lthy [] premises goal (fn {context = ctxt, prems} => + mk_rel_induct0_tac ctxt ctor_rel_induct prems (map (certify ctxt) IRs) exhausts ctor_defss + ctor_injects pre_rel_defs abs_inverses live_nesting_rel_eqs) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation; in @@ -745,12 +772,12 @@ val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 mk_leq IRs (map2 (build_the_rel lthy (Rs @ IRs) []) fpA_Ts fpB_Ts))); - val rel_coinduct0_thm = Goal.prove_sorry lthy [] premises goal - (fn {context = ctxt, prems = prems} => - mk_rel_coinduct0_tac ctxt dtor_rel_coinduct (map (certify ctxt) IRs) prems - (map #exhaust ctr_sugars) (map (flat o #disc_thmss) ctr_sugars) - (map (flat o #sel_thmss) ctr_sugars) ctor_defss dtor_ctors ctor_injects abs_injects - rel_pre_defs abs_inverses live_nesting_rel_eqs) + val rel_coinduct0_thm = + Goal.prove_sorry lthy [] premises goal (fn {context = ctxt, prems} => + mk_rel_coinduct0_tac ctxt dtor_rel_coinduct (map (certify ctxt) IRs) prems + (map #exhaust ctr_sugars) (map (flat o #disc_thmss) ctr_sugars) + (map (flat o #sel_thmss) ctr_sugars) ctor_defss dtor_ctors ctor_injects abs_injects + rel_pre_defs abs_inverses live_nesting_rel_eqs) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation; in @@ -759,6 +786,99 @@ mk_coinduct_attributes fpA_Ts (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss) end; +fun derive_set_induct_thms_for_types lthy nn fpTs ctrss setss dtor_set_inducts exhausts + set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses = + let + fun mk_prems A Ps ctr_args t ctxt = + (case fastype_of t of + Type (type_name, innerTs) => + (case bnf_of ctxt type_name of + NONE => ([], ctxt) + | SOME bnf => + let + fun seq_assm a set ctxt = + let + val X = HOLogic.dest_setT (range_type (fastype_of set)); + val (x, ctxt') = yield_singleton (mk_Frees "x") X ctxt; + val assm = mk_Trueprop_mem (x, set $ a); + in + (case build_binary_fun_app Ps x a of + NONE => + mk_prems A Ps ctr_args x ctxt' + |>> map (Logic.all x o Logic.mk_implies o pair assm) + | SOME f => + ([Logic.all x + (Logic.mk_implies (assm, + Logic.mk_implies (HOLogic.mk_Trueprop f, + HOLogic.mk_Trueprop (the (build_binary_fun_app Ps x ctr_args)))))], + ctxt')) + end; + in + fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt + |>> flat + end) + | T => + if T = A then ([HOLogic.mk_Trueprop (the (build_binary_fun_app Ps t ctr_args))], ctxt) + else ([], ctxt)); + + fun mk_prems_for_ctr A Ps ctr ctxt = + let + val (args, ctxt') = mk_Frees "z" (binder_types (fastype_of ctr)) ctxt; + in + fold_map (mk_prems A Ps (list_comb (ctr, args))) args ctxt' + |>> map (fold_rev Logic.all args) o flat + |>> (fn prems => (prems, mk_names (length prems) (name_of_ctr ctr))) + end; + + fun mk_prems_and_concl_for_type A Ps ((fpT, ctrs), set) ctxt = + let + val ((x, fp), ctxt') = ctxt + |> yield_singleton (mk_Frees "x") A + ||>> yield_singleton (mk_Frees "a") fpT; + val concl = mk_Ball (set $ fp) (Term.absfree (dest_Free x) + (the (build_binary_fun_app Ps x fp))); + in + fold_map (mk_prems_for_ctr A Ps) ctrs ctxt' + |>> split_list + |>> map_prod flat flat + |>> apfst (rpair concl) + end; + + fun mk_thm ctxt fpTs ctrss sets = + let + val A = HOLogic.dest_setT (range_type (fastype_of (hd sets))); + val (Ps, ctxt') = mk_Frees "P" (map (fn fpT => A --> fpT --> HOLogic.boolT) fpTs) ctxt; + val (((premises, conclusion), case_names), ctxt'') = + (fold_map (mk_prems_and_concl_for_type A Ps) (fpTs ~~ ctrss ~~ sets) ctxt') + |>> apfst split_list o split_list + |>> apfst (apfst flat) + |>> apfst (apsnd (Library.foldr1 HOLogic.mk_conj)) + |>> apsnd flat; + + val thm = + Goal.prove_sorry lthy [] premises (HOLogic.mk_Trueprop conclusion) + (fn {context = ctxt, prems} => + mk_set_induct0_tac ctxt (map (certify ctxt'') Ps) prems dtor_set_inducts exhausts + set_pre_defs ctor_defs dtor_ctors Abs_pre_inverses) + |> singleton (Proof_Context.export ctxt'' ctxt) + |> Thm.close_derivation; + + val case_names_attr = + Attrib.internal (K (Rule_Cases.case_names (quasi_unambiguous_case_names case_names))); + val induct_set_attrs = map (Attrib.internal o K o Induct.induct_pred o name_of_set) sets; + in + (thm, case_names_attr :: induct_set_attrs) + end + val consumes_attr = Attrib.internal (K (Rule_Cases.consumes 1)); + in + map (fn Asets => + let + fun massage_thm thm = rotate_prems (~1) (thm RS bspec); + in + mk_thm lthy fpTs ctrss Asets |> nn = 1 ? map_prod massage_thm (cons consumes_attr) + end) (transpose setss) + end; + fun derive_coinduct_corecs_thms_for_types pre_bnfs (x, cs, cpss, ((pgss, cqgsss), _)) dtor_coinduct dtor_injects dtor_ctors dtor_corec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns fp_abs_inverses abs_inverses mk_vimage2p ctr_defss (ctr_sugars : ctr_sugar list) @@ -853,7 +973,7 @@ val rel_eqs = map rel_eq_of_bnf pre_bnfs; val rel_monos = map rel_mono_of_bnf pre_bnfs; val dtor_coinducts = - [dtor_coinduct, mk_strong_coinduct_thm dtor_coinduct rel_eqs rel_monos mk_vimage2p lthy] + [dtor_coinduct, mk_coinduct_strong_thm dtor_coinduct rel_eqs rel_monos mk_vimage2p lthy] in map2 (postproc_co_induct lthy nn mp mp_conj oo prove) dtor_coinducts goals end; @@ -902,7 +1022,7 @@ |> map (map (unfold_thms lthy @{thms case_sum_if})) end; - val disc_corec_iff_thmss = + val corec_disc_iff_thmss = let fun mk_goal c cps gcorec n k disc = mk_Trueprop_eq (disc $ (gcorec $ c), @@ -915,7 +1035,7 @@ val case_splitss' = map (map mk_case_split') cpss; - val tacss = map3 (map oo mk_disc_corec_iff_tac) case_splitss' corec_thmss disc_thmsss; + val tacss = map3 (map oo mk_corec_disc_iff_tac) case_splitss' corec_thmss disc_thmsss; fun prove goal tac = Goal.prove_sorry lthy [] [] goal (tac o #context) @@ -929,11 +1049,11 @@ map2 proves goalss tacss end; - fun mk_disc_corec_thms corecs discIs = map (op RS) (corecs ~~ discIs); + fun mk_corec_disc_thms corecs discIs = map (op RS) (corecs ~~ discIs); - val disc_corec_thmss = map2 mk_disc_corec_thms corec_thmss discIss; + val corec_disc_thmss = map2 mk_corec_disc_thms corec_thmss discIss; - fun mk_sel_corec_thm corec_thm sel sel_thm = + fun mk_corec_sel_thm corec_thm sel sel_thm = let val (domT, ranT) = dest_funT (fastype_of sel); val arg_cong' = @@ -945,17 +1065,17 @@ corec_thm RS arg_cong' RS sel_thm' end; - fun mk_sel_corec_thms corec_thmss = - map3 (map3 (map2 o mk_sel_corec_thm)) corec_thmss selsss sel_thmsss; + fun mk_corec_sel_thms corec_thmss = + map3 (map3 (map2 o mk_corec_sel_thm)) corec_thmss selsss sel_thmsss; - val sel_corec_thmsss = mk_sel_corec_thms corec_thmss; + val corec_sel_thmsss = mk_corec_sel_thms corec_thmss; in ((coinduct_thms_pairs, mk_coinduct_attributes fpTs (map #ctrs ctr_sugars) (map #discs ctr_sugars) mss), corec_thmss, - disc_corec_thmss, - (disc_corec_iff_thmss, simp_attrs), - (sel_corec_thmsss, simp_attrs)) + corec_disc_thmss, + (corec_disc_iff_thmss, simp_attrs), + (corec_sel_thmsss, simp_attrs)) end; fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp @@ -1072,7 +1192,7 @@ val ((pre_bnfs, absT_infos), (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0, xtor_co_recs = xtor_co_recs0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects, dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms, - xtor_co_rec_thms, rel_xtor_co_induct_thm, ...}, + xtor_co_rec_thms, rel_xtor_co_induct_thm, dtor_set_induct_thms, ...}, lthy)) = fp_bnf (construct_fp mixfixes map_bs rel_bs set_bss) fp_bs (map dest_TFree unsorted_As) (map dest_TFree killed_As) fp_eqs no_defs_lthy0 @@ -1143,8 +1263,8 @@ fun massage_simple_notes base = filter_out (null o #2) - #> map (fn (thmN, thms, attrs) => - ((Binding.qualify true base (Binding.name thmN), attrs), [(thms, [])])); + #> map (fn (thmN, thms, f_attrs) => + ((Binding.qualify true base (Binding.name thmN), []), map_index (fn (i, thm) => ([thm], f_attrs i)) thms)); val massage_multi_notes = maps (fn (thmN, thmss, attrs) => @@ -1168,6 +1288,7 @@ disc_bindings), sel_bindingss), raw_sel_default_eqs) no_defs_lthy = let val fp_b_name = Binding.name_of fp_b; + val fpBT = B_ify fpT; val ctr_absT = domain_type (fastype_of ctor); @@ -1290,55 +1411,22 @@ else fp_map_thm RS ctor_cong RS (ctor_dtor RS sym RS trans)))) |> singleton (Proof_Context.export names_lthy no_defs_lthy); - fun mk_set_thm fp_set_thm ctr_def' cxIn = + fun mk_set0_thm fp_set_thm ctr_def' cxIn = fold_thms lthy [ctr_def'] (unfold_thms lthy (pre_set_defs @ fp_nesting_set_maps @ live_nesting_set_maps @ - (if fp = Least_FP then [] else [dtor_ctor]) @ sumprod_thms_set @ - abs_inverses) + (if fp = Least_FP then [] else [dtor_ctor]) @ basic_sumprod_thms_set @ + @{thms UN_Un sup_assoc[THEN sym]} @ abs_inverses) (cterm_instantiate_pos [SOME cxIn] fp_set_thm)) |> singleton (Proof_Context.export names_lthy no_defs_lthy); - fun mk_set_thms fp_set_thm = map2 (mk_set_thm fp_set_thm) ctr_defs' cxIns; + fun mk_set0_thms fp_set_thm = map2 (mk_set0_thm fp_set_thm) ctr_defs' cxIns; val map_thms = map2 mk_map_thm ctr_defs' cxIns; - val set_thmss = map mk_set_thms fp_set_thms; - val set_thms = flat set_thmss; - - val sets = map (mk_set (snd (Term.dest_Type fpT))) (sets_of_bnf fp_bnf); - - val set_empty_thms = - let - val ctr_argT_namess = map ((fn Ts => fold Term.add_tfree_namesT Ts []) o - binder_types o fastype_of) ctrs; - val setTs = map (HOLogic.dest_setT o range_type o fastype_of) sets; - val setT_names = map (fn T => the_single (Term.add_tfree_namesT T [])) setTs; - - fun mk_set_empty_goal disc set T = - Logic.mk_implies (HOLogic.mk_Trueprop (disc $ u), - mk_Trueprop_eq (set $ u, HOLogic.mk_set T [])); - - val goals = - if null discs then - [] - else - map_filter I (flat - (map2 (fn names => fn disc => - map3 (fn name => fn setT => fn set => - if member (op =) names name then NONE - else SOME (mk_set_empty_goal disc set setT)) - setT_names setTs sets) - ctr_argT_namess discs)); - in - if null goals then - [] - else - Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) - (fn {context = ctxt, prems = _} => - mk_set_empty_tac ctxt (certify ctxt u) exhaust set_thms (flat disc_thmss)) - |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation - end; + val set0_thmss = map mk_set0_thms fp_set_thms; + val set0_thms = flat set0_thmss; + val set_thms = set0_thms + |> map (unfold_thms lthy @{thms insert_is_Un[THEN sym] Un_empty_left + Un_insert_left}); val rel_infos = (ctr_defs' ~~ cxIns, ctr_defs' ~~ cyIns); @@ -1386,31 +1474,153 @@ map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th) rel_inject_thms ms; - val (disc_map_iff_thms, sel_map_thms, sel_set_thms, rel_sel_thms, - (rel_cases_thm, rel_cases_attrs)) = + val (map_disc_iff_thms, map_sel_thms, set_sel_thms, rel_sel_thms, set_intros_thms, + ctr_transfer_thms, (set_cases_thms, set_cases_attrss), + (rel_cases_thm, rel_cases_attrs)) = let - val (((Ds, As), Bs), names_lthy) = lthy - |> mk_TFrees (dead_of_bnf fp_bnf) - ||>> mk_TFrees (live_of_bnf fp_bnf) - ||>> mk_TFrees (live_of_bnf fp_bnf); - val TA as Type (_, ADs) = mk_T_of_bnf Ds As fp_bnf; - val TB as Type (_, BDs) = mk_T_of_bnf Ds Bs fp_bnf; - val fTs = map2 (curry op -->) As Bs; - val rel = mk_rel_of_bnf Ds As Bs fp_bnf; - val ((((fs, Rs), ta), tb), names_lthy) = names_lthy + val live_AsBs = filter (op <>) (As ~~ Bs); + val fTs = map (op -->) live_AsBs; + val (((((fs, Rs), ta), tb), thesis), names_lthy) = names_lthy |> mk_Frees "f" fTs - ||>> mk_Frees "R" (map2 mk_pred2T As Bs) - ||>> yield_singleton (mk_Frees "a") TA - ||>> yield_singleton (mk_Frees "b") TB; - val map_term = mk_map_of_bnf Ds As Bs fp_bnf; - val discAs = map (mk_disc_or_sel ADs) discs; - val selAss = map (map (mk_disc_or_sel ADs)) selss; + ||>> mk_Frees "R" (map (uncurry mk_pred2T) live_AsBs) + ||>> yield_singleton (mk_Frees "a") fpT + ||>> yield_singleton (mk_Frees "b") fpBT + ||>> apfst HOLogic.mk_Trueprop o + yield_singleton (mk_Frees "thesis") HOLogic.boolT; + val map_term = mk_map live As Bs (map_of_bnf fp_bnf); + val ctrAs = map (mk_ctr As) ctrs; + val ctrBs = map (mk_ctr Bs) ctrs; + val relAsBs = mk_rel live As Bs (rel_of_bnf fp_bnf); + val setAs = map (mk_set As) (sets_of_bnf fp_bnf); + val discAs = map (mk_disc_or_sel As) discs; + val selAss = map (map (mk_disc_or_sel As)) selss; val discAs_selAss = flat (map2 (map o pair) discAs selAss); + val ctr_transfer_thms = + let + val goals = mk_parametricity_goals names_lthy Rs ctrAs ctrBs; + in + Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) + (K (mk_ctr_transfer_tac rel_intro_thms)) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation + end; + + val (set_cases_thms, set_cases_attrss) = + let + fun mk_prems assms elem t ctxt = + (case fastype_of t of + Type (type_name, xs) => + (case bnf_of ctxt type_name of + NONE => ([], ctxt) + | SOME bnf => + apfst flat (fold_map (fn set => fn ctxt => + let + val X = HOLogic.dest_setT (range_type (fastype_of set)); + val new_var = not (X = fastype_of elem); + val (x, ctxt') = + if new_var then yield_singleton (mk_Frees "x") X ctxt + else (elem, ctxt); + in + mk_prems (mk_Trueprop_mem (x, set $ t) :: assms) elem x ctxt' + |>> map (if new_var then Logic.all x else I) + end) (map (mk_set xs) (sets_of_bnf bnf)) ctxt)) + | T => rpair ctxt + (if T = fastype_of elem then [fold (curry Logic.mk_implies) assms thesis] + else [])); + in + split_list (map (fn set => + let + val A = HOLogic.dest_setT (range_type (fastype_of set)); + val (elem, names_lthy) = yield_singleton (mk_Frees "e") A names_lthy; + val premss = + map (fn ctr => + let + val (args, names_lthy) = + mk_Frees "z" (binder_types (fastype_of ctr)) names_lthy; + in + flat (zipping_map (fn (prev_args, arg, next_args) => + let + val (args_with_elem, args_without_elem) = + if fastype_of arg = A then + (prev_args @ [elem] @ next_args, prev_args @ next_args) + else + `I (prev_args @ [arg] @ next_args); + in + mk_prems + [mk_Trueprop_eq (ta, Term.list_comb (ctr, args_with_elem))] + elem arg names_lthy + |> fst + |> map (fold_rev Logic.all args_without_elem) + end) args) + end) ctrAs; + val goal = Logic.mk_implies (mk_Trueprop_mem (elem, set $ ta), thesis); + val thm = + Goal.prove_sorry lthy [] (flat premss) goal + (fn {context = ctxt, prems} => + mk_set_cases_tac ctxt (certify ctxt ta) prems exhaust set_thms) + |> singleton (Proof_Context.export names_lthy lthy) + |> Thm.close_derivation + |> rotate_prems ~1; + + val consumes_attr = Attrib.internal (K (Rule_Cases.consumes 1)); + val cases_set_attr = + Attrib.internal (K (Induct.cases_pred (name_of_set set))); + in + (* TODO: @{attributes [elim?]} *) + (thm, [consumes_attr, cases_set_attr]) + end) setAs) + end; + + val set_intros_thms = + let + fun mk_goals A setA ctr_args t ctxt = + (case fastype_of t of + Type (type_name, innerTs) => + (case bnf_of ctxt type_name of + NONE => ([], ctxt) + | SOME bnf => + apfst flat (fold_map (fn set => fn ctxt => + let + val X = HOLogic.dest_setT (range_type (fastype_of set)); + val (x, ctxt') = yield_singleton (mk_Frees "x") X ctxt; + val assm = mk_Trueprop_mem (x, set $ t); + in + apfst (map (Logic.mk_implies o pair assm)) + (mk_goals A setA ctr_args x ctxt') + end) (map (mk_set innerTs) (sets_of_bnf bnf)) ctxt)) + | T => + (if T = A then [mk_Trueprop_mem (t, setA $ ctr_args)] else [], ctxt)); + + val (goals, names_lthy) = + apfst flat (fold_map (fn set => fn ctxt => + let + val A = HOLogic.dest_setT (range_type (fastype_of set)); + in + apfst flat (fold_map (fn ctr => fn ctxt => + let + val (args, ctxt') = + mk_Frees "arg" (binder_types (fastype_of ctr)) ctxt; + val ctr_args = Term.list_comb (ctr, args); + in + apfst flat (fold_map (mk_goals A set ctr_args) args ctxt') + end) ctrAs ctxt) + end) setAs lthy); + in + if null goals then [] + else + Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) + (fn {context = ctxt, prems = _} => mk_set_intros_tac ctxt set0_thms) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation + end; + val rel_sel_thms = let - val discBs = map (mk_disc_or_sel BDs) discs; - val selBss = map (map (mk_disc_or_sel BDs)) selss; + val discBs = map (mk_disc_or_sel Bs) discs; + val selBss = map (map (mk_disc_or_sel Bs)) selss; val n = length discAs; fun mk_rhs n k discA selAs discB selBs = @@ -1433,21 +1643,18 @@ else Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => - mk_rel_sel_tac ctxt (certify ctxt ta) (certify ctxt tb) exhaust - (flat disc_thmss) (flat sel_thmss) rel_inject_thms distincts - rel_distinct_thms) - |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy + mk_rel_sel_tac ctxt (certify ctxt ta) (certify ctxt tb) exhaust + (flat disc_thmss) (flat sel_thmss) rel_inject_thms distincts + rel_distinct_thms) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation end; val (rel_cases_thm, rel_cases_attrs) = let - val (thesis, names_lthy) = apfst HOLogic.mk_Trueprop - (yield_singleton (mk_Frees "thesis") HOLogic.boolT names_lthy); - - val rel_Rs_a_b = list_comb (rel, Rs) $ ta $ tb; - val ctrAs = map (mk_ctr ADs) ctrs; - val ctrBs = map (mk_ctr BDs) ctrs; + val rel_Rs_a_b = list_comb (relAsBs, Rs) $ ta $ tb; + val ctrBs = map (mk_ctr Bs) ctrs; fun mk_assms ctrA ctrB ctxt = let @@ -1469,13 +1676,14 @@ end; val (assms, names_lthy) = fold_map2 mk_assms ctrAs ctrBs names_lthy; - val goal = Logic.list_implies (HOLogic.mk_Trueprop rel_Rs_a_b :: assms, - thesis); - val thm = Goal.prove_sorry lthy [] [] goal + val goal = + Logic.list_implies (HOLogic.mk_Trueprop rel_Rs_a_b :: assms, thesis); + val thm = + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => - mk_rel_cases_tac ctxt (certify ctxt ta) (certify ctxt tb) exhaust - injects rel_inject_thms distincts rel_distinct_thms - (map rel_eq_of_bnf live_nesting_bnfs)) + mk_rel_cases_tac ctxt (certify ctxt ta) (certify ctxt tb) exhaust + injects rel_inject_thms distincts rel_distinct_thms + (map rel_eq_of_bnf live_nesting_bnfs)) |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation; @@ -1487,9 +1695,9 @@ (thm, [consumes_attr, case_names_attr, cases_pred_attr ""]) end; - val disc_map_iff_thms = + val map_disc_iff_thms = let - val discsB = map (mk_disc_or_sel BDs) discs; + val discsB = map (mk_disc_or_sel Bs) discs; val discsA_t = map (fn disc1 => Term.betapply (disc1, ta)) discAs; fun mk_goal (discA_t, discB) = @@ -1506,31 +1714,34 @@ else Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => - mk_disc_map_iff_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) - map_thms) - |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy + mk_map_disc_iff_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) + map_thms) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation end; - val sel_map_thms = + val map_sel_thms = let fun mk_goal (discA, selA) = let val prem = Term.betapply (discA, ta); - val selB = mk_disc_or_sel BDs selA; + val selB = mk_disc_or_sel Bs selA; val lhs = selB $ (Term.list_comb (map_term, fs) $ ta); val lhsT = fastype_of lhs; - val map_rhsT = map_atyps (perhaps (AList.lookup (op =) (Bs ~~ As))) lhsT; + val map_rhsT = + map_atyps (perhaps (AList.lookup (op =) (map swap live_AsBs))) lhsT; val map_rhs = build_map lthy [] - (the o (AList.lookup (op =) ((As ~~ Bs) ~~ fs))) (map_rhsT, lhsT); + (the o (AList.lookup (op =) (live_AsBs ~~ fs))) (map_rhsT, lhsT); val rhs = (case map_rhs of - Const (@{const_name id}, _) => selA $ ta + Const (@{const_name id}, _) => selA $ ta | _ => map_rhs $ (selA $ ta)); val concl = mk_Trueprop_eq (lhs, rhs); in if is_refl_bool prem then concl else Logic.mk_implies (HOLogic.mk_Trueprop prem, concl) end; + val goals = map mk_goal discAs_selAss; in if null goals then @@ -1538,16 +1749,15 @@ else Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => - mk_sel_map_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) - map_thms (flat sel_thmss)) - |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy + mk_map_sel_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) + map_thms (flat sel_thmss)) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation end; - val sel_set_thms = + val set_sel_thms = let - val setsA = map (mk_set ADs) (sets_of_bnf fp_bnf); - fun mk_goal discA selA setA ctxt = let val prem = Term.betapply (discA, ta); @@ -1556,7 +1766,7 @@ fun travese_nested_types t ctxt = (case fastype_of t of - Type (type_name, xs) => + Type (type_name, innerTs) => (case bnf_of ctxt type_name of NONE => ([], ctxt) | SOME bnf => @@ -1571,7 +1781,7 @@ |>> map (Logic.mk_implies o pair assm) end; in - fold_map (seq_assm t o mk_set xs) (sets_of_bnf bnf) ctxt + fold_map (seq_assm t o mk_set innerTs) (sets_of_bnf bnf) ctxt |>> flat end) | T => @@ -1596,20 +1806,22 @@ ([], ctxt) end; val (goals, names_lthy) = apfst (flat o flat) (fold_map (fn (disc, sel) => - fold_map (mk_goal disc sel) setsA) discAs_selAss names_lthy); + fold_map (mk_goal disc sel) setAs) discAs_selAss names_lthy); in if null goals then [] else Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => - mk_sel_set_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) - (flat sel_thmss) set_thms) - |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy + mk_set_sel_tac ctxt (certify ctxt ta) exhaust (flat disc_thmss) + (flat sel_thmss) set0_thms) + |> Conjunction.elim_balanced (length goals) + |> Proof_Context.export names_lthy lthy + |> map Thm.close_derivation end; in - (disc_map_iff_thms, sel_map_thms, sel_set_thms, rel_sel_thms, + (map_disc_iff_thms, map_sel_thms, set_sel_thms, rel_sel_thms, set_intros_thms, + ctr_transfer_thms, (set_cases_thms, set_cases_attrss), (rel_cases_thm, rel_cases_attrs)) end; @@ -1619,17 +1831,19 @@ |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); val notes = - [(disc_map_iffN, disc_map_iff_thms, simp_attrs), - (mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs), - (rel_casesN, [rel_cases_thm], rel_cases_attrs), - (rel_distinctN, rel_distinct_thms, simp_attrs), - (rel_injectN, rel_inject_thms, simp_attrs), - (rel_introsN, rel_intro_thms, []), - (rel_selN, rel_sel_thms, []), - (setN, set_thms, code_nitpicksimp_attrs @ simp_attrs), - (sel_mapN, sel_map_thms, []), - (sel_setN, sel_set_thms, []), - (set_emptyN, set_empty_thms, [])] + [(ctr_transferN, ctr_transfer_thms, K []), + (mapN, map_thms, K (code_nitpicksimp_attrs @ simp_attrs)), + (map_disc_iffN, map_disc_iff_thms, K simp_attrs), + (map_selN, map_sel_thms, K []), + (rel_casesN, [rel_cases_thm], K rel_cases_attrs), + (rel_distinctN, rel_distinct_thms, K simp_attrs), + (rel_injectN, rel_inject_thms, K simp_attrs), + (rel_introsN, rel_intro_thms, K []), + (rel_selN, rel_sel_thms, K []), + (setN, set_thms, K (code_nitpicksimp_attrs @ simp_attrs)), + (set_casesN, set_cases_thms, nth set_cases_attrss), + (set_introsN, set_intros_thms, K []), + (set_selN, set_sel_thms, K [])] |> massage_simple_notes fp_b_name; val (noted, lthy') = @@ -1637,13 +1851,13 @@ |> Spec_Rules.add Spec_Rules.Equational (`(single o lhs_head_of o hd) map_thms) |> fp = Least_FP ? Spec_Rules.add Spec_Rules.Equational (`(single o lhs_head_of o hd) rel_eq_thms) - |> Spec_Rules.add Spec_Rules.Equational (`(single o lhs_head_of o hd) set_thms) + |> Spec_Rules.add Spec_Rules.Equational (`(single o lhs_head_of o hd) set0_thms) |> Local_Theory.notes (anonymous_notes @ notes); val subst = Morphism.thm (substitute_noted_thm noted); in (((map subst map_thms, map subst rel_inject_thms, map subst rel_distinct_thms, - map (map subst) set_thmss), ctr_sugar), lthy') + map (map subst) set0_thmss), ctr_sugar), lthy') end; fun mk_binding pre = Binding.qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b); @@ -1700,8 +1914,8 @@ val common_notes = (if nn > 1 then - [(inductN, [induct_thm], induct_attrs), - (rel_inductN, common_rel_induct_thms, common_rel_induct_attrs)] + [(inductN, [induct_thm], K induct_attrs), + (rel_inductN, common_rel_induct_thms, K common_rel_induct_attrs)] else []) |> massage_simple_notes fp_common_name; @@ -1729,17 +1943,17 @@ ((((mapss, rel_injectss, rel_distinctss, setss), (_, _, ctr_defss, ctr_sugars)), (corecs, corec_defs)), lthy) = let - val (([(coinduct_thms, coinduct_thm), (strong_coinduct_thms, strong_coinduct_thm)], + val (([(coinduct_thms, coinduct_thm), (coinduct_strong_thms, coinduct_strong_thm)], (coinduct_attrs, common_coinduct_attrs)), - corec_thmss, disc_corec_thmss, - (disc_corec_iff_thmss, disc_corec_iff_attrs), (sel_corec_thmsss, sel_corec_attrs)) = + corec_thmss, corec_disc_thmss, + (corec_disc_iff_thmss, corec_disc_iff_attrs), (corec_sel_thmsss, corec_sel_attrs)) = derive_coinduct_corecs_thms_for_types pre_bnfs (the corecs_args_types) xtor_co_induct dtor_injects dtor_ctors xtor_co_rec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns abs_inverses abs_inverses I ctr_defss ctr_sugars corecs corec_defs (Proof_Context.export lthy' no_defs_lthy) lthy; fun distinct_prems ctxt th = - Goal.prove ctxt [] [] + Goal.prove (*no sorry*) ctxt [] [] (th |> Thm.prop_of |> Logic.strip_horn |>> distinct (op aconv) |> Logic.list_implies) (fn _ => HEADGOAL (cut_tac th THEN' atac) THEN ALLGOALS eq_assume_tac); @@ -1749,8 +1963,8 @@ (map (unfold_thms ctxt @{thms atomize_imp[of _ "t = u" for t u]}) [thm, eq_ifIN ctxt thms])); - val corec_code_thms = map (eq_ifIN lthy) corec_thmss - val sel_corec_thmss = map flat sel_corec_thmsss; + val corec_code_thms = map (eq_ifIN lthy) corec_thmss; + val corec_sel_thmss = map flat corec_sel_thmsss; val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type; val coinduct_pred_attr = Attrib.internal o K o Induct.coinduct_pred; @@ -1773,40 +1987,48 @@ (rel_coinduct_attrs, common_rel_coinduct_attrs)) end; + val (set_induct_thms, set_induct_attrss) = + derive_set_induct_thms_for_types lthy nn fpTs (map #ctrs ctr_sugars) + (map (map (mk_set As)) (map sets_of_bnf fp_bnfs)) dtor_set_induct_thms + (map #exhaust ctr_sugars) (flat pre_set_defss) (flat ctr_defss) + dtor_ctors abs_inverses + |> split_list; + val simp_thmss = map6 mk_simp_thms ctr_sugars - (map3 flat_corec_thms disc_corec_thmss disc_corec_iff_thmss sel_corec_thmss) + (map3 flat_corec_thms corec_disc_thmss corec_disc_iff_thmss corec_sel_thmss) mapss rel_injectss rel_distinctss setss; val common_notes = + (set_inductN, set_induct_thms, nth set_induct_attrss) :: (if nn > 1 then - [(coinductN, [coinduct_thm], common_coinduct_attrs), - (rel_coinductN, common_rel_coinduct_thms, common_rel_coinduct_attrs), - (strong_coinductN, [strong_coinduct_thm], common_coinduct_attrs)] - else []) + [(coinductN, [coinduct_thm], K common_coinduct_attrs), + (coinduct_strongN, [coinduct_strong_thm], K common_coinduct_attrs), + (rel_coinductN, common_rel_coinduct_thms, K common_rel_coinduct_attrs)] + else []) |> massage_simple_notes fp_common_name; val notes = [(coinductN, map single coinduct_thms, fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]), + (coinduct_strongN, map single coinduct_strong_thms, K coinduct_attrs), (corecN, corec_thmss, K []), (corec_codeN, map single corec_code_thms, K code_nitpicksimp_attrs), - (disc_corecN, disc_corec_thmss, K []), - (disc_corec_iffN, disc_corec_iff_thmss, K disc_corec_iff_attrs), + (corec_discN, corec_disc_thmss, K []), + (corec_disc_iffN, corec_disc_iff_thmss, K corec_disc_iff_attrs), + (corec_selN, corec_sel_thmss, K corec_sel_attrs), (rel_coinductN, rel_coinduct_thmss, K (rel_coinduct_attrs @ [coinduct_pred_attr ""])), - (sel_corecN, sel_corec_thmss, K sel_corec_attrs), - (simpsN, simp_thmss, K []), - (strong_coinductN, map single strong_coinduct_thms, K coinduct_attrs)] + (simpsN, simp_thmss, K [])] |> massage_multi_notes; in lthy |> fold (curry (Spec_Rules.add Spec_Rules.Equational) corecs) - [flat sel_corec_thmss, flat corec_thmss] + [flat corec_sel_thmss, flat corec_thmss] |> Local_Theory.notes (common_notes @ notes) |-> register_as_fp_sugars fpTs fpBTs Xs Greatest_FP pre_bnfs absT_infos fp_nesting_bnfs live_nesting_bnfs fp_res ctrXs_Tsss ctr_defss ctr_sugars corecs corec_defs mapss - [coinduct_thm, strong_coinduct_thm] (transpose [coinduct_thms, strong_coinduct_thms]) - corec_thmss disc_corec_thmss sel_corec_thmsss rel_injectss rel_distinctss + [coinduct_thm, coinduct_strong_thm] (transpose [coinduct_thms, coinduct_strong_thms]) + corec_thmss corec_disc_thmss corec_sel_thmsss rel_injectss rel_distinctss end; val lthy'' = lthy' diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_fp_def_sugar_tactics.ML --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -10,21 +10,24 @@ sig val sumprod_thms_map: thm list val sumprod_thms_set: thm list + val basic_sumprod_thms_set: thm list val sumprod_thms_rel: thm list val mk_coinduct_tac: Proof.context -> thm list -> int -> int list -> thm -> thm list -> thm list -> thm list -> thm list -> thm list -> thm list list -> thm list list list -> thm list list list -> tactic val mk_corec_tac: thm list -> thm list -> thm -> thm -> thm -> thm -> Proof.context -> tactic + val mk_corec_disc_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm -> tactic - val mk_disc_corec_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic - val mk_disc_map_iff_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> tactic + val mk_ctr_transfer_tac: thm list -> tactic val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic val mk_half_distinct_tac: Proof.context -> thm -> thm -> thm list -> tactic val mk_induct_tac: Proof.context -> int -> int list -> int list list -> int list list list -> thm list -> thm -> thm list -> thm list -> thm list -> thm list list -> tactic val mk_inject_tac: Proof.context -> thm -> thm -> thm -> tactic + val mk_map_disc_iff_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> tactic + val mk_map_sel_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> thm list -> tactic val mk_rec_tac: thm list -> thm list -> thm list -> thm -> thm -> thm -> thm -> Proof.context -> tactic val mk_rel_cases_tac: Proof.context -> cterm -> cterm -> thm -> thm list -> thm list -> @@ -36,9 +39,11 @@ thm list list -> thm list -> thm list -> thm list -> thm list -> tactic val mk_rel_sel_tac: Proof.context -> cterm -> cterm -> thm -> thm list -> thm list -> thm list -> thm list -> thm list -> tactic - val mk_sel_map_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> thm list -> tactic - val mk_sel_set_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> thm list -> tactic - val mk_set_empty_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> tactic + val mk_set_cases_tac: Proof.context -> cterm -> thm list -> thm -> thm list -> tactic + val mk_set_induct0_tac: Proof.context -> cterm list -> thm list -> thm list -> thm list -> + thm list -> thm list -> thm list -> thm list -> tactic + val mk_set_intros_tac: Proof.context -> thm list -> tactic + val mk_set_sel_tac: Proof.context -> cterm -> thm -> thm list -> thm list -> thm list -> tactic end; structure BNF_FP_Def_Sugar_Tactics : BNF_FP_DEF_SUGAR_TACTICS = @@ -54,10 +59,10 @@ val simp_thms' = @{thms simp_thms(6,7,8,11,12,15,16,22,24)}; val sumprod_thms_map = @{thms id_apply map_prod_simp prod.case sum.case map_sum.simps}; -val sumprod_thms_set = - @{thms UN_empty UN_insert Un_empty_left Un_empty_right Un_iff UN_simps(10) UN_iff - Union_Un_distrib image_iff o_apply map_prod_simp - mem_Collect_eq prod_set_simps map_sum.simps sum_set_simps}; +val basic_sumprod_thms_set = + @{thms UN_empty UN_insert UN_iff Un_empty_left Un_empty_right Un_iff Union_Un_distrib + o_apply map_prod_simp mem_Collect_eq prod_set_simps map_sum.simps sum_set_simps}; +val sumprod_thms_set = @{thms UN_simps(10) image_iff} @ basic_sumprod_thms_set; val sumprod_thms_rel = @{thms rel_sum_simps rel_prod_apply prod.inject id_apply conj_assoc}; fun hhf_concl_conv cv ctxt ct = @@ -91,6 +96,11 @@ SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN' atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor])); +fun mk_ctr_transfer_tac rel_intros = + HEADGOAL Goal.conjunction_tac THEN + ALLGOALS (REPEAT o (resolve_tac (@{thm rel_funI} :: rel_intros) THEN' + REPEAT_DETERM o atac)); + fun mk_half_distinct_tac ctxt ctor_inject abs_inject ctr_defs = unfold_thms_tac ctxt (ctor_inject :: abs_inject :: @{thms sum.inject} @ ctr_defs) THEN HEADGOAL (rtac @{thm sum.distinct(1)}); @@ -121,22 +131,13 @@ HEADGOAL (rtac refl ORELSE' rtac (@{thm unit_eq} RS arg_cong)) end; -fun mk_disc_corec_iff_tac case_splits' corecs discs ctxt = +fun mk_corec_disc_iff_tac case_splits' corecs discs ctxt = EVERY (map3 (fn case_split_tac => fn corec_thm => fn disc => HEADGOAL case_split_tac THEN unfold_thms_tac ctxt [corec_thm] THEN HEADGOAL (asm_simp_tac (ss_only basic_simp_thms ctxt)) THEN (if is_refl disc then all_tac else HEADGOAL (rtac disc))) (map rtac case_splits' @ [K all_tac]) corecs discs); -fun mk_disc_map_iff_tac ctxt ct exhaust discs maps = - TRYALL Goal.conjunction_tac THEN - ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW - REPEAT_DETERM o hyp_subst_tac ctxt) THEN - unfold_thms_tac ctxt maps THEN - unfold_thms_tac ctxt (map (fn thm => thm RS eqFalseI - handle THM _ => thm RS eqTrueI) discs) THEN - ALLGOALS (rtac refl ORELSE' rtac TrueI); - fun solve_prem_prem_tac ctxt = REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE' hyp_subst_tac ctxt ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN' @@ -216,6 +217,25 @@ (1 upto nn) ns pre_rel_defs fp_abs_inverses abs_inverses dtor_ctors exhausts ctr_defss discsss selsss)); +fun mk_map_disc_iff_tac ctxt ct exhaust discs maps = + TRYALL Goal.conjunction_tac THEN + ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW + REPEAT_DETERM o hyp_subst_tac ctxt) THEN + unfold_thms_tac ctxt maps THEN + unfold_thms_tac ctxt (map (fn thm => thm RS eqFalseI + handle THM _ => thm RS eqTrueI) discs) THEN + ALLGOALS (rtac refl ORELSE' rtac TrueI); + +fun mk_map_sel_tac ctxt ct exhaust discs maps sels = + TRYALL Goal.conjunction_tac THEN + ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW + REPEAT_DETERM o hyp_subst_tac ctxt) THEN + unfold_thms_tac ctxt ((discs RL [eqTrueI, eqFalseI]) @ + @{thms not_True_eq_False not_False_eq_True}) THEN + TRYALL (etac FalseE ORELSE' etac @{thm TrueE}) THEN + unfold_thms_tac ctxt (maps @ sels) THEN + ALLGOALS (rtac refl); + fun mk_rel_cases_tac ctxt ct1 ct2 exhaust injects rel_injects distincts rel_distincts rel_eqs= HEADGOAL (rtac (cterm_instantiate_pos [SOME ct1] exhaust) THEN_ALL_NEW rtac (cterm_instantiate_pos [SOME ct2] exhaust) THEN_ALL_NEW @@ -257,12 +277,12 @@ HEADGOAL (rtac exhaust THEN_ALL_NEW (rtac exhaust THEN_ALL_NEW (rtac (cterm_instantiate_pos (replicate 4 NONE @ [SOME cterm]) @{thm arg_cong2} RS iffD2) THEN' atac THEN' atac THEN' TRY o resolve_tac assms))) THEN - unfold_tac ctxt (ctor_inject :: rel_pre_list_def :: ctor_defs @ nesting_rel_eqs @ + unfold_thms_tac ctxt (ctor_inject :: rel_pre_list_def :: ctor_defs @ nesting_rel_eqs @ @{thms BNF_Comp.id_bnf_comp_def vimage2p_def}) THEN TRYALL (hyp_subst_tac ctxt) THEN unfold_thms_tac ctxt (Abs_inverse :: @{thms rel_sum_simps rel_prod_apply Inl_Inr_False Inr_Inl_False sum.inject prod.inject}) THEN - TRYALL (etac FalseE ORELSE' (REPEAT_DETERM o etac conjE) THEN' atac)) + TRYALL (rtac refl ORELSE' etac FalseE ORELSE' (REPEAT_DETERM o etac conjE) THEN' atac)) cterms exhausts ctor_defss ctor_injects rel_pre_list_defs Abs_inverses); fun mk_rel_sel_tac ctxt ct1 ct2 exhaust discs sels rel_injects distincts rel_distincts = @@ -275,17 +295,7 @@ (rel_distincts RL @{thms iffD2[OF eq_False]})) THEN TRYALL (resolve_tac [TrueI, refl]); -fun mk_sel_map_tac ctxt ct exhaust discs maps sels = - TRYALL Goal.conjunction_tac THEN - ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW - REPEAT_DETERM o hyp_subst_tac ctxt) THEN - unfold_thms_tac ctxt ((discs RL [eqTrueI, eqFalseI]) @ - @{thms not_True_eq_False not_False_eq_True}) THEN - TRYALL (etac FalseE ORELSE' etac @{thm TrueE}) THEN - unfold_thms_tac ctxt (maps @ sels) THEN - ALLGOALS (rtac refl); - -fun mk_sel_set_tac ctxt ct exhaust discs sels sets = +fun mk_set_sel_tac ctxt ct exhaust discs sels sets = TRYALL Goal.conjunction_tac THEN ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW REPEAT_DETERM o hyp_subst_tac ctxt) THEN @@ -298,12 +308,43 @@ hyp_subst_tac ctxt) THEN' (rtac @{thm singletonI} ORELSE' atac)); -fun mk_set_empty_tac ctxt ct exhaust sets discs = +fun mk_set_cases_tac ctxt ct assms exhaust sets = + HEADGOAL (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW hyp_subst_tac ctxt) THEN + unfold_thms_tac ctxt sets THEN + REPEAT_DETERM (HEADGOAL + (eresolve_tac @{thms FalseE emptyE singletonE UnE UN_E insertE} ORELSE' + hyp_subst_tac ctxt ORELSE' + SELECT_GOAL (SOLVE (HEADGOAL (eresolve_tac assms THEN' REPEAT_DETERM o atac))))); + +fun mk_set_intros_tac ctxt sets = TRYALL Goal.conjunction_tac THEN - ALLGOALS (rtac (cterm_instantiate_pos [SOME ct] exhaust) THEN_ALL_NEW - REPEAT_DETERM o hyp_subst_tac ctxt) THEN - unfold_thms_tac ctxt (sets @ map_filter (fn thm => - SOME (thm RS eqFalseI) handle THM _ => NONE) discs) THEN - ALLGOALS (rtac refl ORELSE' etac FalseE); + unfold_thms_tac ctxt sets THEN + TRYALL (REPEAT o + (resolve_tac @{thms UnI1 UnI2} ORELSE' + eresolve_tac @{thms UN_I UN_I[rotated]}) THEN' (rtac @{thm singletonI} ORELSE' atac)); + +fun mk_set_induct0_tac ctxt cts assms dtor_set_inducts exhausts set_pre_defs ctor_defs dtor_ctors + Abs_pre_inverses = + let + val assms_ctor_defs = + map (unfold_thms ctxt (@{thm BNF_Comp.id_bnf_comp_def} :: ctor_defs)) assms; + val exhausts' = map (fn thm => thm RS @{thm asm_rl[of "P x y" for P x y]}) exhausts + |> map2 (fn ct => cterm_instantiate_pos [NONE, SOME ct]) cts; + in + ALLGOALS (resolve_tac dtor_set_inducts) THEN + TRYALL (resolve_tac exhausts' THEN_ALL_NEW + (resolve_tac (map (fn ct => refl RS + cterm_instantiate_pos (replicate 4 NONE @ [SOME ct]) @{thm arg_cong2} RS iffD2) cts) + THEN' atac THEN' hyp_subst_tac ctxt)) THEN + unfold_thms_tac ctxt (Abs_pre_inverses @ dtor_ctors @ set_pre_defs @ ctor_defs @ + @{thms BNF_Comp.id_bnf_comp_def o_apply sum_set_simps prod_set_simps UN_empty UN_insert + Un_empty_left Un_empty_right empty_iff singleton_iff}) THEN + REPEAT_DETERM (HEADGOAL + (TRY o etac UnE THEN' TRY o etac @{thm singletonE} THEN' TRY o hyp_subst_tac ctxt THEN' + REPEAT_DETERM o eresolve_tac @{thms UN_E UnE singletonE} THEN' + fold (curry (op ORELSE')) (map (fn thm => + funpow (length (prems_of thm)) (fn tac => tac THEN' atac) (rtac thm)) assms_ctor_defs) + (etac FalseE))) + end; end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_fp_n2m.ML --- a/src/HOL/Tools/BNF/bnf_fp_n2m.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_fp_n2m.ML Wed Aug 27 15:52:58 2014 +0200 @@ -240,29 +240,26 @@ val co_recs = of_fp_res #xtor_co_recs; val ns = map (length o #Ts o #fp_res) fp_sugars; - fun substT rho (Type (@{type_name fun}, [T, U])) = substT rho T --> substT rho U - | substT rho (Type (s, Ts)) = Type (s, map (typ_subst_nonatomic rho) Ts) - | substT _ T = T; - val typ_subst_nonatomic_sorted = fold_rev (typ_subst_nonatomic o single); fun foldT_of_recT recT = let - val ((FTXs, Xs), TX) = strip_fun_type recT |>> map_split dest_co_algT; + val ((FTXs, Ys), TX) = strip_fun_type recT |>> map_split dest_co_algT; + val Zs = union op = Xs Ys; fun subst (Type (C, Ts as [_, X])) = - if C = co_productC andalso member op = Xs X then X else Type (C, map subst Ts) + if C = co_productC andalso member op = Zs X then X else Type (C, map subst Ts) | subst (Type (C, Ts)) = Type (C, map subst Ts) | subst T = T; in - map2 (mk_co_algT o subst) FTXs Xs ---> TX + map2 (mk_co_algT o subst) FTXs Ys ---> TX end; - fun force_rec i TU TU_rec raw_rec = + fun force_rec i TU raw_rec = let val thy = Proof_Context.theory_of lthy; val approx_rec = raw_rec - |> force_typ names_lthy (replicate (nth ns i) dummyT ---> TU_rec); + |> force_typ names_lthy (replicate (nth ns i) dummyT ---> TU); val subst = Term.typ_subst_atomic fold_thetaAs; fun mk_fp_absT_repT fp_repT fp_absT = mk_absT thy fp_repT fp_absT ooo mk_repT; @@ -299,9 +296,7 @@ val i = find_index (fn T => x = T) Xs; val TUrec = (case find_first (fn f => body_fun_type (fastype_of f) = TU) recs of - NONE => - force_rec i TU - (TU |> is_none b_opt ? substT (map2 mk_co_productT fpTs Xs ~~ Xs)) (nth co_recs i) + NONE => force_rec i TU (nth co_recs i) | SOME f => f); val TUs = binder_fun_types (fastype_of TUrec); @@ -340,14 +335,21 @@ let val (TY, (U, X)) = TU |> dest_co_algT ||> dest_co_productT; val T = mk_co_algT TY U; + fun mk_co_proj TU = build_map lthy [] (fn TU => + let + val ((T1, T2), U) = TU |> co_swap |>> dest_co_productT + in + if T1 = U then co_proj1_const TU + else mk_co_comp (mk_co_proj (co_swap (T1, U)), + co_proj1_const (co_swap (mk_co_productT T1 T2, T1))) + end) TU; in - (case try (force_typ names_lthy T o build_map lthy [] co_proj1_const o dest_funT) T of - SOME f => mk_co_product f - (fst (fst (mk_rec NONE recs lthy (mk_co_algT TY X)))) - | NONE => mk_map_co_product - (build_map lthy [] co_proj1_const - (dest_funT (mk_co_algT (dest_co_productT TY |> fst) U))) - (HOLogic.id_const X)) + if not (can dest_co_productT TY) + then mk_co_product (mk_co_proj (dest_funT T)) + (fst (fst (mk_rec NONE recs lthy (mk_co_algT TY X)))) + else mk_map_co_product + (mk_co_proj (co_swap (dest_co_productT TY |> fst, U))) + (HOLogic.id_const X) end) val smap_args = map mk_smap_arg smap_argTs; in @@ -413,8 +415,8 @@ map (fn thm => thm RS rewrite_comp_comp) @{thms map_prod.comp map_sum.comp} @ @{thms id_apply comp_id id_comp map_prod.comp map_prod.id map_sum.comp map_sum.id}; val rec_thms = fold_thms @ case_fp fp - @{thms fst_convol map_prod_o_convol convol_o} - @{thms case_sum_o_inj(1) case_sum_o_map_sum o_case_sum}; + @{thms fst_convol map_prod_o_convol convol_o fst_comp_map_prod} + @{thms case_sum_o_inj(1) case_sum_o_map_sum o_case_sum map_sum_o_inj(1)}; val eq_thm_prop_untyped = Term.aconv_untyped o pairself Thm.full_prop_of; @@ -429,10 +431,11 @@ rewrite_comp_comp) type_definitions bnfs); - fun mk_Rep_o_Abs thm = thm RS @{thm type_copy_Rep_o_Abs} RS rewrite_comp_comp; + fun mk_Rep_o_Abs thm = (thm RS @{thm type_copy_Rep_o_Abs}) + |> (fn thm => [thm, thm RS rewrite_comp_comp]); - val fp_Rep_o_Abss = map mk_Rep_o_Abs fp_type_definitions; - val Rep_o_Abss = map mk_Rep_o_Abs type_definitions; + val fp_Rep_o_Abss = maps mk_Rep_o_Abs fp_type_definitions; + val Rep_o_Abss = maps mk_Rep_o_Abs type_definitions; fun tac {context = ctxt, prems = _} = unfold_thms_tac ctxt (flat [rec_thms, raw_co_rec_defs, pre_map_defs, fp_pre_map_defs, @@ -463,7 +466,8 @@ xtor_rel_thms = of_fp_res #xtor_rel_thms (*too general types and terms*), xtor_co_rec_thms = xtor_co_rec_thms, xtor_co_rec_o_map_thms = fp_rec_o_maps (*theorems about old constants*), - rel_xtor_co_induct_thm = rel_xtor_co_induct_thm} + rel_xtor_co_induct_thm = rel_xtor_co_induct_thm, + dtor_set_induct_thms = []} |> morph_fp_result (Morphism.term_morphism "BNF" (singleton (Variable.polymorphic lthy)))); in (fp_res, lthy) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -8,6 +8,7 @@ signature BNF_FP_N2M_SUGAR = sig val unfold_lets_splits: term -> term + val unfold_splits_lets: term -> term val dest_map: Proof.context -> string -> term -> term * term list val mutualize_fp_sugars: BNF_Util.fp_kind -> int list -> binding list -> typ list -> term list -> @@ -60,18 +61,22 @@ Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => Data.map (Typtab.update (key, morph_n2m_sugar phi n2m_sugar))); -fun unfold_lets_splits (Const (@{const_name Let}, _) $ arg1 $ arg2) = - unfold_lets_splits (betapply (arg2, arg1)) - | unfold_lets_splits (t as Const (@{const_name case_prod}, _) $ u) = - (case unfold_lets_splits u of +fun unfold_lets_splits (Const (@{const_name Let}, _) $ t $ u) = + unfold_lets_splits (betapply (unfold_splits_lets u, t)) + | unfold_lets_splits (t $ u) = betapply (unfold_lets_splits t, unfold_lets_splits u) + | unfold_lets_splits (Abs (s, T, t)) = Abs (s, T, unfold_lets_splits t) + | unfold_lets_splits t = t +and unfold_splits_lets ((t as Const (@{const_name case_prod}, _)) $ u) = + (case unfold_splits_lets u of u' as Abs (s1, T1, Abs (s2, T2, _)) => let val v = Var ((s1 ^ s2, Term.maxidx_of_term u' + 1), HOLogic.mk_prodT (T1, T2)) in lambda v (incr_boundvars 1 (betapplys (u', [HOLogic.mk_fst v, HOLogic.mk_snd v]))) end - | _ => t) - | unfold_lets_splits (t $ u) = betapply (pairself unfold_lets_splits (t, u)) - | unfold_lets_splits (Abs (s, T, t)) = Abs (s, T, unfold_lets_splits t) - | unfold_lets_splits t = t; + | _ => t $ unfold_lets_splits u) + | unfold_splits_lets (t as Const (@{const_name Let}, _) $ _ $ _) = unfold_lets_splits t + | unfold_splits_lets (t $ u) = betapply (unfold_splits_lets t, unfold_lets_splits u) + | unfold_splits_lets (Abs (s, T, t)) = Abs (s, T, unfold_splits_lets t) + | unfold_splits_lets t = unfold_lets_splits t; fun mk_map_pattern ctxt s = let @@ -252,7 +257,7 @@ fp_bs xtor_co_recs lthy |>> split_list; - val ((common_co_inducts, co_inductss, co_rec_thmss, disc_corec_thmss, sel_corec_thmsss), + val ((common_co_inducts, co_inductss, co_rec_thmss, corec_disc_thmss, corec_sel_thmsss), fp_sugar_thms) = if fp = Least_FP then derive_induct_recs_thms_for_types pre_bnfs recs_args_types xtor_co_induct @@ -267,30 +272,30 @@ dtor_injects dtor_ctors xtor_co_rec_thms live_nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns fp_abs_inverses abs_inverses (fn thm => thm RS @{thm vimage2p_refl}) ctr_defss ctr_sugars co_recs co_rec_defs (Proof_Context.export lthy no_defs_lthy) lthy - |> `(fn ((coinduct_thms_pairs, _), corec_thmss, disc_corec_thmss, _, - (sel_corec_thmsss, _)) => + |> `(fn ((coinduct_thms_pairs, _), corec_thmss, corec_disc_thmss, _, + (corec_sel_thmsss, _)) => (map snd coinduct_thms_pairs, map fst coinduct_thms_pairs, corec_thmss, - disc_corec_thmss, sel_corec_thmsss)) + corec_disc_thmss, corec_sel_thmsss)) ||> (fn info => (NONE, SOME info)); val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0; fun mk_target_fp_sugar T X kk pre_bnf absT_info ctrXs_Tss ctr_defs ctr_sugar co_rec - co_rec_def maps co_inducts co_rec_thms disc_corec_thms sel_corec_thmss + co_rec_def maps co_inducts co_rec_thms corec_disc_thms corec_sel_thmss ({rel_injects, rel_distincts, ...} : fp_sugar) = {T = T, BT = Term.dummyT (*wrong but harmless*), X = X, fp = fp, fp_res = fp_res, fp_res_index = kk, pre_bnf = pre_bnf, absT_info = absT_info, fp_nesting_bnfs = fp_nesting_bnfs, live_nesting_bnfs = live_nesting_bnfs, ctrXs_Tss = ctrXs_Tss, ctr_defs = ctr_defs, ctr_sugar = ctr_sugar, co_rec = co_rec, co_rec_def = co_rec_def, maps = maps, common_co_inducts = common_co_inducts, - co_inducts = co_inducts, co_rec_thms = co_rec_thms, disc_co_recs = disc_corec_thms, - sel_co_recss = sel_corec_thmss, rel_injects = rel_injects, rel_distincts = rel_distincts} + co_inducts = co_inducts, co_rec_thms = co_rec_thms, disc_co_recs = corec_disc_thms, + sel_co_recss = corec_sel_thmss, rel_injects = rel_injects, rel_distincts = rel_distincts} |> morph_fp_sugar phi; val target_fp_sugars = map16 mk_target_fp_sugar fpTs Xs kks pre_bnfs absT_infos ctrXs_Tsss ctr_defss ctr_sugars - co_recs co_rec_defs mapss (transpose co_inductss) co_rec_thmss disc_corec_thmss - sel_corec_thmsss fp_sugars0; + co_recs co_rec_defs mapss (transpose co_inductss) co_rec_thmss corec_disc_thmss + corec_sel_thmsss fp_sugars0; val n2m_sugar = (target_fp_sugars, fp_sugar_thms); in diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_fp_util.ML --- a/src/HOL/Tools/BNF/bnf_fp_util.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_fp_util.ML Wed Aug 27 15:52:58 2014 +0200 @@ -25,7 +25,8 @@ xtor_rel_thms: thm list, xtor_co_rec_thms: thm list, xtor_co_rec_o_map_thms: thm list, - rel_xtor_co_induct_thm: thm} + rel_xtor_co_induct_thm: thm, + dtor_set_induct_thms: thm list} val morph_fp_result: morphism -> fp_result -> fp_result @@ -70,7 +71,10 @@ val caseN: string val coN: string val coinductN: string + val coinduct_strongN: string val corecN: string + val corec_discN: string + val corec_disc_iffN: string val ctorN: string val ctor_dtorN: string val ctor_exhaustN: string @@ -90,8 +94,6 @@ val ctor_rel_inductN: string val ctor_set_inclN: string val ctor_set_set_inclN: string - val disc_corecN: string - val disc_corec_iffN: string val dtorN: string val dtor_coinductN: string val dtor_corecN: string @@ -102,13 +104,13 @@ val dtor_injectN: string val dtor_mapN: string val dtor_map_coinductN: string - val dtor_map_strong_coinductN: string + val dtor_map_coinduct_strongN: string val dtor_map_uniqueN: string val dtor_relN: string val dtor_rel_coinductN: string val dtor_set_inclN: string val dtor_set_set_inclN: string - val dtor_strong_coinductN: string + val dtor_coinduct_strongN: string val dtor_unfoldN: string val dtor_unfold_o_mapN: string val dtor_unfold_transferN: string @@ -133,14 +135,13 @@ val rel_distinctN: string val rel_selN: string val rvN: string - val sel_corecN: string + val corec_selN: string val set_inclN: string val set_set_inclN: string val setN: string val simpsN: string val strTN: string val str_initN: string - val strong_coinductN: string val sum_bdN: string val sum_bdTN: string val uniqueN: string @@ -205,7 +206,7 @@ val mk_xtor_un_fold_o_map_thms: BNF_Util.fp_kind -> bool -> int -> thm -> thm list -> thm list -> thm list -> thm list -> thm list - val mk_strong_coinduct_thm: thm -> thm list -> thm list -> (thm -> thm) -> Proof.context -> thm + val mk_coinduct_strong_thm: thm -> thm list -> thm list -> (thm -> thm) -> Proof.context -> thm val fp_bnf: (binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory -> 'a) -> @@ -237,11 +238,12 @@ xtor_rel_thms: thm list, xtor_co_rec_thms: thm list, xtor_co_rec_o_map_thms: thm list, - rel_xtor_co_induct_thm: thm}; + rel_xtor_co_induct_thm: thm, + dtor_set_induct_thms: thm list}; fun morph_fp_result phi {Ts, bnfs, ctors, dtors, xtor_co_recs, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects, dtor_injects, xtor_map_thms, xtor_set_thmss, - xtor_rel_thms, xtor_co_rec_thms, xtor_co_rec_o_map_thms, rel_xtor_co_induct_thm} = + xtor_rel_thms, xtor_co_rec_thms, xtor_co_rec_o_map_thms, rel_xtor_co_induct_thm, dtor_set_induct_thms} = {Ts = map (Morphism.typ phi) Ts, bnfs = map (morph_bnf phi) bnfs, ctors = map (Morphism.term phi) ctors, @@ -257,7 +259,8 @@ xtor_rel_thms = map (Morphism.thm phi) xtor_rel_thms, xtor_co_rec_thms = map (Morphism.thm phi) xtor_co_rec_thms, xtor_co_rec_o_map_thms = map (Morphism.thm phi) xtor_co_rec_o_map_thms, - rel_xtor_co_induct_thm = Morphism.thm phi rel_xtor_co_induct_thm}; + rel_xtor_co_induct_thm = Morphism.thm phi rel_xtor_co_induct_thm, + dtor_set_induct_thms = map (Morphism.thm phi) dtor_set_induct_thms}; (* No idea of what this is doing... *) type fp_sugar = {T: typ, @@ -390,9 +393,9 @@ val ctor_induct2N = ctor_inductN ^ "2" val dtor_map_coinductN = dtor_mapN ^ "_" ^ coinductN val dtor_coinductN = dtorN ^ "_" ^ coinductN -val strong_coinductN = "strong_" ^ coinductN -val dtor_map_strong_coinductN = dtor_mapN ^ "_" ^ strong_coinductN -val dtor_strong_coinductN = dtorN ^ "_" ^ strong_coinductN +val coinduct_strongN = coinductN ^ "_strong" +val dtor_map_coinduct_strongN = dtor_mapN ^ "_" ^ coinduct_strongN +val dtor_coinduct_strongN = dtorN ^ "_" ^ coinduct_strongN val colN = "col" val set_inclN = "set_incl" val ctor_set_inclN = ctorN ^ "_" ^ set_inclN @@ -403,9 +406,9 @@ val caseN = "case" val discN = "disc" -val disc_corecN = discN ^ "_" ^ corecN +val corec_discN = corecN ^ "_" ^ discN val iffN = "_iff" -val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN +val corec_disc_iffN = corec_discN ^ iffN val distinctN = "distinct" val rel_distinctN = relN ^ "_" ^ distinctN val injectN = "inject" @@ -418,7 +421,7 @@ val rel_inductN = relN ^ "_" ^ inductN val ctor_rel_inductN = ctorN ^ "_" ^ rel_inductN val selN = "sel" -val sel_corecN = selN ^ "_" ^ corecN +val corec_selN = corecN ^ "_" ^ selN fun co_prefix fp = case_fp fp "" "co"; @@ -631,7 +634,7 @@ split_conj_thm (un_fold_unique OF map (case_fp fp I mk_sym) unique_prems) end; -fun mk_strong_coinduct_thm coind rel_eqs rel_monos mk_vimage2p ctxt = +fun mk_coinduct_strong_thm coind rel_eqs rel_monos mk_vimage2p ctxt = let val n = Thm.nprems_of coind; val m = Thm.nprems_of (hd rel_monos) - n; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_gfp.ML --- a/src/HOL/Tools/BNF/bnf_gfp.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_gfp.ML Wed Aug 27 15:52:58 2014 +0200 @@ -223,7 +223,7 @@ val rel_congs = map rel_cong_of_bnf bnfs; val rel_converseps = map rel_conversep_of_bnf bnfs; val rel_Grps = map rel_Grp_of_bnf bnfs; - val rel_OOs = map rel_OO_of_bnf bnfs; + val le_rel_OOs = map le_rel_OO_of_bnf bnfs; val in_rels = map in_rel_of_bnf bnfs; val timer = time (timer "Extracted terms & thms"); @@ -589,7 +589,7 @@ HOLogic.mk_Trueprop (mk_bis Bs ss B''s s''s (map2 (curry mk_rel_comp) Rs R's)); in Goal.prove_sorry lthy [] [] (Logic.list_implies (prems, concl)) - (K (mk_bis_O_tac lthy m bis_rel_thm rel_congs rel_OOs)) + (K (mk_bis_O_tac lthy m bis_rel_thm rel_congs le_rel_OOs)) |> Thm.close_derivation |> singleton (Proof_Context.export names_lthy lthy) end; @@ -1592,7 +1592,7 @@ val (dtor_corec_unique_thms, dtor_corec_unique_thm) = `split_conj_thm (split_conj_prems n (mor_UNIV_thm RS iffD2 RS corec_unique_mor_thm) - |> Local_Defs.unfold lthy (@{thms o_case_sum comp_id id_comp comp_assoc[symmetric] + |> unfold_thms lthy (@{thms o_case_sum comp_id id_comp comp_assoc[symmetric] case_sum_o_inj(1)} @ map_id0s_o_id @ sym_map_comps) OF replicate n @{thm arg_cong2[of _ _ _ _ case_sum, OF refl]}); @@ -1659,12 +1659,12 @@ (*register new codatatypes as BNFs*) val (timer, Jbnfs, (dtor_Jmap_o_thms, dtor_Jmap_thms), dtor_Jset_thmss', - dtor_Jrel_thms, Jrel_coinduct_thm, Jbnf_notes, lthy) = + dtor_Jrel_thms, Jrel_coinduct_thm, Jbnf_notes, dtor_Jset_induct_thms, lthy) = if m = 0 then (timer, replicate n DEADID_bnf, map_split (`(mk_pointfree lthy)) (map2 mk_dtor_map_DEADID_thm dtor_inject_thms map_ids), replicate n [], map2 mk_dtor_Jrel_DEADID_thm dtor_inject_thms bnfs, - mk_Jrel_DEADID_coinduct_thm (), [], lthy) + mk_Jrel_DEADID_coinduct_thm (), [], [], lthy) else let val fTs = map2 (curry op -->) passiveAs passiveBs; val gTs = map2 (curry op -->) passiveBs passiveCs; @@ -2260,7 +2260,7 @@ val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj goals); in Goal.prove_sorry lthy [] [] goal - (K (mk_le_rel_OO_tac Jrel_coinduct_thm dtor_Jrel_thms rel_OOs)) + (K (mk_le_rel_OO_tac Jrel_coinduct_thm dtor_Jrel_thms le_rel_OOs)) |> Thm.close_derivation |> singleton (Proof_Context.export names_lthy lthy) end; @@ -2464,7 +2464,8 @@ bs thmss) in (timer, Jbnfs, (Jmap_thms, dtor_Jmap_thms), dtor_Jset_thmss', - dtor_Jrel_thms, Jrel_coinduct_thm, Jbnf_common_notes @ Jbnf_notes, lthy) + dtor_Jrel_thms, Jrel_coinduct_thm, Jbnf_common_notes @ Jbnf_notes, dtor_Jset_induct_thms, + lthy) end; val dtor_unfold_o_Jmap_thms = mk_xtor_un_fold_o_map_thms Greatest_FP false m @@ -2513,12 +2514,7 @@ ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])])) bs thmss); - (*FIXME: once the package exports all the necessary high-level characteristic theorems, - those should not only be concealed but rather not noted at all*) - val maybe_conceal_notes = note_all = false ? map (apfst (apfst Binding.conceal)); - - val (noted, lthy') = - lthy |> Local_Theory.notes (maybe_conceal_notes (common_notes @ notes @ Jbnf_notes)); + val lthy' = lthy |> note_all ? snd o Local_Theory.notes (common_notes @ notes @ Jbnf_notes); val fp_res = {Ts = Ts, bnfs = Jbnfs, ctors = ctors, dtors = dtors, xtor_co_recs = corecs, @@ -2526,8 +2522,8 @@ ctor_injects = ctor_inject_thms, dtor_injects = dtor_inject_thms, xtor_map_thms = dtor_Jmap_thms, xtor_set_thmss = dtor_Jset_thmss', xtor_rel_thms = dtor_Jrel_thms, xtor_co_rec_thms = dtor_corec_thms, - xtor_co_rec_o_map_thms = dtor_corec_o_Jmap_thms, rel_xtor_co_induct_thm = Jrel_coinduct_thm} - |> morph_fp_result (substitute_noted_thm noted); + xtor_co_rec_o_map_thms = dtor_corec_o_Jmap_thms, rel_xtor_co_induct_thm = Jrel_coinduct_thm, + dtor_set_induct_thms = dtor_Jset_induct_thms}; in timer; (fp_res, lthy') end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML --- a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -69,15 +69,15 @@ calls: corec_call list, discI: thm, sel_thms: thm list, - disc_excludess: thm list list, + distinct_discss: thm list list, collapse: thm, corec_thm: thm, - disc_corec: thm, - sel_corecs: thm list}; + corec_disc: thm, + corec_sels: thm list}; type corec_spec = {corec: term, - disc_exhausts: thm list, + exhaust_discs: thm list, sel_defs: thm list, fp_nesting_maps: thm list, fp_nesting_map_ident0s: thm list, @@ -159,7 +159,7 @@ (case fastype_of1 (bound_Ts, nth args n) of Type (s, Ts) => (case dest_case ctxt s Ts t of - SOME ({sel_splits = _ :: _, ...}, conds', branches) => + SOME ({split_sels = _ :: _, ...}, conds', branches) => fold_rev (uncurry fld) (map (append conds o conjuncts_s) conds' ~~ branches) | _ => f conds t) | _ => f conds t) @@ -173,7 +173,7 @@ fun case_of ctxt s = (case ctr_sugar_of ctxt s of - SOME {casex = Const (s', _), sel_splits = _ :: _, ...} => SOME s' + SOME {casex = Const (s', _), split_sels = _ :: _, ...} => SOME s' | _ => NONE); fun massage_let_if_case ctxt has_call massage_leaf = @@ -198,7 +198,7 @@ end | (c as Const (@{const_name case_prod}, _), arg :: args) => massage_rec bound_Ts - (unfold_lets_splits (Term.list_comb (c $ Envir.eta_long bound_Ts arg, args))) + (unfold_splits_lets (Term.list_comb (c $ Envir.eta_long bound_Ts arg, args))) | (Const (c, _), args as _ :: _ :: _) => (case try strip_fun_type (Sign.the_const_type thy c) of SOME (gen_branch_Ts, gen_body_fun_T) => @@ -343,8 +343,8 @@ fun case_thms_of_term ctxt t = let val ctr_sugars = map_filter (Ctr_Sugar.ctr_sugar_of_case ctxt o fst) (Term.add_consts t []) in - (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #disc_exhausts ctr_sugars, - maps #sel_splits ctr_sugars, maps #sel_split_asms ctr_sugars) + (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #exhaust_discs ctr_sugars, + maps #split_sels ctr_sugars, maps #split_sel_asms ctr_sugars) end; fun basic_corec_specs_of ctxt res_T = @@ -444,32 +444,32 @@ else No_Corec) g_i | call_of _ [q_i] [g_i, g_i'] _ = Mutual_Corec (q_i, g_i, g_i'); - fun mk_ctr_spec ctr disc sels p_io q_iss f_iss f_Tss discI sel_thms disc_excludess collapse - corec_thm disc_corec sel_corecs = + fun mk_ctr_spec ctr disc sels p_io q_iss f_iss f_Tss discI sel_thms distinct_discss collapse + corec_thm corec_disc corec_sels = let val nullary = not (can dest_funT (fastype_of ctr)) in {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_io, calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms, - disc_excludess = disc_excludess, collapse = collapse, corec_thm = corec_thm, - disc_corec = disc_corec, sel_corecs = sel_corecs} + distinct_discss = distinct_discss, collapse = collapse, corec_thm = corec_thm, + corec_disc = corec_disc, corec_sels = corec_sels} end; - fun mk_ctr_specs ({ctrs, discs, selss, discIs, sel_thmss, disc_excludesss, collapses, ...} - : ctr_sugar) p_is q_isss f_isss f_Tsss corec_thms disc_corecs sel_corecss = + fun mk_ctr_specs ({ctrs, discs, selss, discIs, sel_thmss, distinct_discsss, collapses, ...} + : ctr_sugar) p_is q_isss f_isss f_Tsss corec_thms corec_discs corec_selss = let val p_ios = map SOME p_is @ [NONE] in map14 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss - disc_excludesss collapses corec_thms disc_corecs sel_corecss + distinct_discsss collapses corec_thms corec_discs corec_selss end; - fun mk_spec ({T, ctr_sugar as {disc_exhausts, sel_defs, ...}, co_rec = corec, - co_rec_thms = corec_thms, disc_co_recs = disc_corecs, - sel_co_recss = sel_corecss, ...} : fp_sugar) p_is q_isss f_isss f_Tsss = - {corec = mk_co_rec thy Greatest_FP (substAT T) perm_Cs' corec, disc_exhausts = disc_exhausts, + fun mk_spec ({T, ctr_sugar as {exhaust_discs, sel_defs, ...}, co_rec = corec, + co_rec_thms = corec_thms, disc_co_recs = corec_discs, + sel_co_recss = corec_selss, ...} : fp_sugar) p_is q_isss f_isss f_Tsss = + {corec = mk_co_rec thy Greatest_FP (substAT T) perm_Cs' corec, exhaust_discs = exhaust_discs, sel_defs = sel_defs, fp_nesting_maps = maps (map_thms_of_typ lthy o T_of_bnf) fp_nesting_bnfs, fp_nesting_map_ident0s = map map_ident0_of_bnf fp_nesting_bnfs, fp_nesting_map_comps = map map_comp_of_bnf fp_nesting_bnfs, - ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms disc_corecs - sel_corecss}; + ctr_specs = mk_ctr_specs ctr_sugar p_is q_isss f_isss f_Tsss corec_thms corec_discs + corec_selss}; in ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts, co_induct_of common_coinduct_thms, strong_co_induct_of common_coinduct_thms, @@ -694,14 +694,6 @@ handle ListPair.UnequalLengths => primcorec_error_eqn "partially applied constructor in right-hand side" rhs; -(* -val _ = tracing ("reduced\n " ^ Syntax.string_of_term @{context} concl ^ "\nto\n \ " ^ - (is_some eqn_data_disc_opt ? K (Syntax.string_of_term @{context} disc_concl ^ "\n \ ")) "" ^ - space_implode "\n \ " (map (Syntax.string_of_term @{context}) sel_concls) ^ - "\nfor premise(s)\n \ " ^ - space_implode "\n \ " (map (Syntax.string_of_term @{context}) prems)); -*) - val eqns_data_sel = map (dissect_coeqn_sel lthy fun_names basic_ctr_specss eqn_pos (SOME (abstract (List.rev fun_args) rhs)) code_rhs_opt eqn0 (SOME ctr)) sel_concls; @@ -890,11 +882,6 @@ | currys Ts t = t $ mk_tuple1_balanced (List.rev Ts) (map Bound (length Ts - 1 downto 0)) |> fold_rev (Term.abs o pair Name.uu) Ts; -(* -val _ = tracing ("corecursor arguments:\n \ " ^ - space_implode "\n \ " (map (Syntax.string_of_term lthy) corec_args)); -*) - val excludess' = disc_eqnss |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x)) @@ -1006,12 +993,8 @@ |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} => (ctr, map (K []) sels))) basic_ctr_specss); -(* -val _ = tracing ("callssss = " ^ @{make_string} callssss); -*) - - val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms, - strong_coinduct_thms), lthy') = + val ((n2m, corec_specs', _, coinduct_thm, coinduct_strong_thm, coinduct_thms, + coinduct_strong_thms), lthy') = corec_specs_of bs arg_Ts res_Ts frees callssss lthy; val corec_specs = take actual_nn corec_specs'; val ctr_specss = map #ctr_specs corec_specs; @@ -1051,11 +1034,6 @@ else tac_opt; -(* -val _ = tracing ("exclusiveness properties:\n \ " ^ - space_implode "\n \ " (maps (map (Syntax.string_of_term lthy o snd)) excludess')); -*) - val excludess'' = map3 (fn tac_opt => fn sequential => map (fn (j, goal) => (j, (Option.map (Goal.prove_sorry lthy [] [] goal #> Thm.close_derivation) (exclude_tac tac_opt sequential j), goal)))) @@ -1083,15 +1061,15 @@ de_facto_exhaustives disc_eqnss |> list_all_fun_args [] val nchotomy_taut_thmss = - map5 (fn tac_opt => fn {disc_exhausts = res_disc_exhausts, ...} => + map5 (fn tac_opt => fn {exhaust_discs = res_exhaust_discs, ...} => fn {code_rhs_opt, ...} :: _ => fn [] => K [] | [goal] => fn true => let - val (_, _, arg_disc_exhausts, _, _) = + val (_, _, arg_exhaust_discs, _, _) = case_thms_of_term lthy (the_default Term.dummy code_rhs_opt); in [Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} => - mk_primcorec_nchotomy_tac ctxt (res_disc_exhausts @ arg_disc_exhausts)) + mk_primcorec_nchotomy_tac ctxt (res_exhaust_discs @ arg_exhaust_discs)) |> Thm.close_derivation] end | false => @@ -1155,7 +1133,7 @@ [] else let - val {disc, disc_corec, ...} = nth ctr_specs ctr_no; + val {disc, corec_disc, ...} = nth ctr_specs ctr_no; val k = 1 + ctr_no; val m = length prems; val goal = @@ -1168,7 +1146,7 @@ if prems = [@{term False}] then [] else - mk_primcorec_disc_tac lthy def_thms disc_corec k m excludesss + mk_primcorec_disc_tac lthy def_thms corec_disc k m excludesss |> K |> Goal.prove_sorry lthy [] [] goal |> Thm.close_derivation |> pair (#disc (nth ctr_specs ctr_no)) @@ -1185,8 +1163,8 @@ val ctr_no = find_index (curry (op =) ctr o #ctr) ctr_specs; val prems = the_default (maps (s_not_conj o #prems) disc_eqns) (find_first (curry (op =) ctr_no o #ctr_no) disc_eqns |> Option.map #prems); - val sel_corec = find_index (curry (op =) sel) (#sels ctr_spec) - |> nth (#sel_corecs ctr_spec); + val corec_sel = find_index (curry (op =) sel) (#sels ctr_spec) + |> nth (#corec_sels ctr_spec); val k = 1 + ctr_no; val m = length prems; val goal = @@ -1196,10 +1174,10 @@ |> HOLogic.mk_Trueprop o HOLogic.mk_eq |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems) |> curry Logic.list_all (map dest_Free fun_args); - val (distincts, _, _, sel_splits, sel_split_asms) = case_thms_of_term lthy rhs_term; + val (distincts, _, _, split_sels, split_sel_asms) = case_thms_of_term lthy rhs_term; in - mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms fp_nesting_maps - fp_nesting_map_ident0s fp_nesting_map_comps sel_corec k m excludesss + mk_primcorec_sel_tac lthy def_thms distincts split_sels split_sel_asms fp_nesting_maps + fp_nesting_map_ident0s fp_nesting_map_comps corec_sel k m excludesss |> K |> Goal.prove_sorry lthy [] [] goal |> Thm.close_derivation |> `(is_some code_rhs_opt ? fold_thms lthy sel_defs) (*mildly too aggressive*) @@ -1328,16 +1306,16 @@ val (raw_goal, goal) = (raw_rhs, rhs) |> pairself (curry mk_Trueprop_eq (applied_fun_of fun_name fun_T fun_args) #> curry Logic.list_all (map dest_Free fun_args)); - val (distincts, discIs, _, sel_splits, sel_split_asms) = + val (distincts, discIs, _, split_sels, split_sel_asms) = case_thms_of_term lthy raw_rhs; - val raw_code_thm = mk_primcorec_raw_code_tac lthy distincts discIs sel_splits - sel_split_asms ms ctr_thms + val raw_code_thm = mk_primcorec_raw_code_tac lthy distincts discIs split_sels + split_sel_asms ms ctr_thms (if exhaustive_code then try the_single nchotomys else NONE) |> K |> Goal.prove_sorry lthy [] [] raw_goal |> Thm.close_derivation; in - mk_primcorec_code_tac lthy distincts sel_splits raw_code_thm + mk_primcorec_code_tac lthy distincts split_sels raw_code_thm |> K |> Goal.prove_sorry lthy [] [] goal |> Thm.close_derivation |> single @@ -1359,14 +1337,14 @@ [] else let - val {disc, disc_excludess, ...} = nth ctr_specs ctr_no; + val {disc, distinct_discss, ...} = nth ctr_specs ctr_no; val goal = mk_Trueprop_eq (applied_fun_of fun_name fun_T fun_args |> curry betapply disc, mk_conjs prems) |> curry Logic.list_all (map dest_Free fun_args); in mk_primcorec_disc_iff_tac lthy (map (fst o dest_Free) exhaust_fun_args) - (the_single exhaust_thms) disc_thms disc_thmss' (flat disc_excludess) + (the_single exhaust_thms) disc_thms disc_thmss' (flat distinct_discss) |> K |> Goal.prove_sorry lthy [] [] goal |> Thm.close_derivation |> fold (fn rule => perhaps (try (fn thm => Meson.first_order_resolve thm rule))) @@ -1407,7 +1385,7 @@ (exhaustN, nontriv_exhaust_thmss, []), (selN, sel_thmss, simp_attrs), (simpsN, simp_thmss, []), - (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])] + (coinduct_strongN, map (if n2m then single else K []) coinduct_strong_thms, [])] |> maps (fn (thmN, thmss, attrs) => map2 (fn fun_name => fn thms => ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])])) @@ -1416,7 +1394,7 @@ val common_notes = [(coinductN, if n2m then [coinduct_thm] else [], []), - (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])] + (coinduct_strongN, if n2m then [coinduct_strong_thm] else [], [])] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])])); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML --- a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -54,8 +54,8 @@ fun distinct_in_prems_tac distincts = eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac; -fun mk_primcorec_nchotomy_tac ctxt disc_exhausts = - HEADGOAL (Method.insert_tac disc_exhausts THEN' clean_blast_tac ctxt); +fun mk_primcorec_nchotomy_tac ctxt exhaust_discs = + HEADGOAL (Method.insert_tac exhaust_discs THEN' clean_blast_tac ctxt); fun mk_primcorec_exhaust_tac ctxt frees n nchotomy = let val ks = 1 upto n in @@ -105,11 +105,11 @@ fun prelude_tac ctxt defs thm = unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN unfold_thms_tac ctxt unfold_lets; -fun mk_primcorec_disc_tac ctxt defs disc_corec k m excludesss = - prelude_tac ctxt defs disc_corec THEN cases_tac ctxt k m excludesss; +fun mk_primcorec_disc_tac ctxt defs corec_disc k m excludesss = + prelude_tac ctxt defs corec_disc THEN cases_tac ctxt k m excludesss; fun mk_primcorec_disc_iff_tac ctxt fun_exhaust_frees fun_exhaust fun_discs fun_discss - disc_excludes = + distinct_discs = HEADGOAL (rtac iffI THEN' rtac fun_exhaust THEN' K (exhaust_inst_as_projs_tac ctxt fun_exhaust_frees) THEN' @@ -121,7 +121,7 @@ rtac FalseE THEN' (rotate_tac 1 THEN' dtac fun_disc' THEN' REPEAT_DETERM o atac ORELSE' cut_tac fun_disc') THEN' - dresolve_tac disc_excludes THEN' etac notE THEN' atac) + dresolve_tac distinct_discs THEN' etac notE THEN' atac) fun_discss) THEN' (etac FalseE ORELSE' resolve_tac (map (unfold_thms ctxt [atomize_conjL]) fun_discs) THEN_MAYBE' atac)); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_gfp_tactics.ML --- a/src/HOL/Tools/BNF/bnf_gfp_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_gfp_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -103,7 +103,7 @@ val ord_eq_le_trans = @{thm ord_eq_le_trans}; val ordIso_ordLeq_trans = @{thm ordIso_ordLeq_trans}; val snd_convol_fun_cong_sym = @{thm snd_convol[unfolded convol_def]} RS fun_cong RS sym; -val sum_weak_case_cong = @{thm sum.weak_case_cong}; +val sum_case_cong_weak = @{thm sum.case_cong_weak}; val trans_fun_cong_image_id_id_apply = @{thm trans[OF fun_cong[OF image_id] id_apply]}; val Collect_splitD_set_mp = @{thm Collect_splitD[OF set_mp]}; val rev_bspec = Drule.rotate_prems 1 bspec; @@ -277,21 +277,21 @@ REPEAT_DETERM o etac allE, rtac @{thm conversepI}, etac mp, etac @{thm converseD}]) (rel_congs ~~ rel_converseps)] 1; -fun mk_bis_O_tac ctxt m bis_rel rel_congs rel_OOs = +fun mk_bis_O_tac ctxt m bis_rel rel_congs le_rel_OOs = EVERY' [rtac (bis_rel RS iffD2), REPEAT_DETERM o dtac (bis_rel RS iffD1), REPEAT_DETERM o etac conjE, rtac conjI, CONJ_WRAP' (K (EVERY' [etac @{thm relcomp_subset_Sigma}, atac])) rel_congs, - CONJ_WRAP' (fn (rel_cong, rel_OO) => + CONJ_WRAP' (fn (rel_cong, le_rel_OO) => EVERY' [rtac allI, rtac allI, rtac impI, rtac (rel_cong RS @{thm eq_refl} RS @{thm predicate2D}), REPEAT_DETERM_N m o rtac @{thm eq_OO}, REPEAT_DETERM_N (length rel_congs) o rtac @{thm relcompp_in_rel}, - rtac (rel_OO RS sym RS @{thm eq_refl} RS @{thm predicate2D}), + rtac (le_rel_OO RS @{thm predicate2D}), etac @{thm relcompE}, REPEAT_DETERM o dtac prod_injectD, etac conjE, hyp_subst_tac ctxt, REPEAT_DETERM o etac allE, rtac @{thm relcomppI}, - etac mp, atac, etac mp, atac]) (rel_congs ~~ rel_OOs)] 1; + etac mp, atac, etac mp, atac]) (rel_congs ~~ le_rel_OOs)] 1; fun mk_bis_Gr_tac ctxt bis_rel rel_Grps mor_images morEs coalg_ins = unfold_thms_tac ctxt (bis_rel :: @{thm eq_alt} :: @{thm in_rel_Gr} :: rel_Grps) THEN @@ -430,7 +430,7 @@ CONJ_WRAP' (fn rv_Cons => EVERY' [REPEAT_DETERM o etac allE, dtac (mk_conjunctN n i), CONJ_WRAP' (fn i' => EVERY' [dtac (mk_conjunctN n i'), etac exE, rtac exI, rtac (@{thm append_Cons} RS arg_cong RS trans), rtac (rv_Cons RS trans), - if n = 1 then K all_tac else etac (sum_weak_case_cong RS trans), + if n = 1 then K all_tac else etac (sum_case_cong_weak RS trans), rtac (mk_sum_caseN n i RS trans), atac]) ks]) rv_Conss) @@ -565,7 +565,7 @@ rtac (rev_mp OF [rv_last, impI]), etac exE, rtac (isNode_def RS iffD2), rtac exI, rtac conjI, if n = 1 then rtac refl - else etac (sum_weak_case_cong RS trans) THEN' rtac (mk_sum_caseN n i), + else etac (sum_case_cong_weak RS trans) THEN' rtac (mk_sum_caseN n i), CONJ_WRAP' (fn (set_map0, (set_Lev, set_image_Lev)) => EVERY' [rtac (set_map0 RS trans), rtac equalityI, rtac @{thm image_subsetI}, rtac CollectI, rtac @{thm SuccI}, rtac @{thm UN_I}, rtac UNIV_I, etac set_Lev, @@ -603,7 +603,7 @@ CONVERSION (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv (rv_Nil RS eq_reflection)))) ctxt), if n = 1 then K all_tac - else (rtac (sum_weak_case_cong RS trans) THEN' + else (rtac (sum_case_cong_weak RS trans) THEN' rtac (mk_sum_caseN n i) THEN' rtac (mk_sum_caseN n i RS trans)), rtac (map_comp_id RS trans), rtac (map_cong0 OF replicate m refl), EVERY' (map3 (fn i' => fn to_sbd_inj => fn from_to_sbd => @@ -628,7 +628,7 @@ CONVERSION (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv (rv_Cons RS eq_reflection)))) ctxt), if n = 1 then K all_tac - else rtac sum_weak_case_cong THEN' rtac (mk_sum_caseN n i' RS trans), + else rtac sum_case_cong_weak THEN' rtac (mk_sum_caseN n i' RS trans), SELECT_GOAL (unfold_thms_tac ctxt [from_to_sbd]), rtac refl]) ks to_sbd_injs from_to_sbds)]; in @@ -898,14 +898,14 @@ EVERY' (map rtac [@{thm UNION_Cinfinite_bound}, ordIso_ordLeq_trans, @{thm card_of_nat}, @{thm natLeq_ordLeq_cinfinite}, sbd_Cinfinite, ballI, col_bd, sbd_Cinfinite]) 1; -fun mk_le_rel_OO_tac coinduct rel_Jrels rel_OOs = - EVERY' (rtac coinduct :: map2 (fn rel_Jrel => fn rel_OO => +fun mk_le_rel_OO_tac coinduct rel_Jrels le_rel_OOs = + EVERY' (rtac coinduct :: map2 (fn rel_Jrel => fn le_rel_OO => let val Jrel_imp_rel = rel_Jrel RS iffD1; in - EVERY' [rtac (rel_OO RS sym RS @{thm eq_refl} RS @{thm predicate2D}), etac @{thm relcomppE}, + EVERY' [rtac (le_rel_OO RS @{thm predicate2D}), etac @{thm relcomppE}, rtac @{thm relcomppI}, etac Jrel_imp_rel, etac Jrel_imp_rel] end) - rel_Jrels rel_OOs) 1; + rel_Jrels le_rel_OOs) 1; fun mk_wit_tac ctxt n dtor_ctors dtor_set wit coind_wits = ALLGOALS (TRY o (eresolve_tac coind_wits THEN' rtac refl)) THEN @@ -973,8 +973,6 @@ hyp_subst_tac ctxt, dtac (in_Jrel RS iffD1), dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, - TRY o - EVERY' [dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac, hyp_subst_tac ctxt], REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac]) (rev (active_set_map0s ~~ in_Jrels))]) (dtor_sets ~~ passive_set_map0s), diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_lfp.ML --- a/src/HOL/Tools/BNF/bnf_lfp.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_lfp.ML Wed Aug 27 15:52:58 2014 +0200 @@ -167,8 +167,8 @@ val map_id0s = map map_id0_of_bnf bnfs; val map_ids = map map_id_of_bnf bnfs; val set_mapss = map set_map_of_bnf bnfs; - val rel_mono_strongs = map rel_mono_strong_of_bnf bnfs; - val rel_OOs = map rel_OO_of_bnf bnfs; + val rel_mono_strong0s = map rel_mono_strong0_of_bnf bnfs; + val le_rel_OOs = map le_rel_OO_of_bnf bnfs; val timer = time (timer "Extracted terms & thms"); @@ -1197,7 +1197,7 @@ val (ctor_rec_unique_thms, ctor_rec_unique_thm) = `split_conj_thm (split_conj_prems n (mor_UNIV_thm RS iffD2 RS rec_unique_mor_thm) - |> Local_Defs.unfold lthy (@{thms convol_o comp_id id_comp comp_assoc fst_convol} @ + |> unfold_thms lthy (@{thms convol_o comp_id id_comp comp_assoc fst_convol} @ map_id0s @ sym_map_comps) OF replicate n @{thm arg_cong2[of _ _ _ _ convol, OF refl]}); val timer = time (timer "rec definitions & thms"); @@ -1691,7 +1691,7 @@ in Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => mk_le_rel_OO_tac ctxt m induct ctor_nchotomy_thms - ctor_Irel_thms rel_mono_strongs rel_OOs) + ctor_Irel_thms rel_mono_strong0s le_rel_OOs) |> Thm.close_derivation |> singleton (Proof_Context.export names_lthy lthy) end; @@ -1762,7 +1762,7 @@ val Irel_induct_thm = mk_rel_xtor_co_induct_thm Least_FP rels activeIphis Irels Iphis xFs yFs ctors ctor's (fn {context = ctxt, prems = IHs} => mk_rel_induct_tac ctxt IHs m ctor_induct2_thm ks - ctor_Irel_thms rel_mono_strongs) lthy; + ctor_Irel_thms rel_mono_strong0s) lthy; val rels = map2 (fn Ds => mk_rel_of_bnf Ds allAs allBs') Dss bnfs; val ctor_fold_transfer_thms = @@ -1801,12 +1801,7 @@ ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])])) bs thmss); - (*FIXME: once the package exports all the necessary high-level characteristic theorems, - those should not only be concealed but rather not noted at all*) - val maybe_conceal_notes = note_all = false ? map (apfst (apfst Binding.conceal)); - - val (noted, lthy') = - lthy |> Local_Theory.notes (maybe_conceal_notes (common_notes @ notes @ Ibnf_notes)); + val lthy' = lthy |> note_all ? snd o Local_Theory.notes (common_notes @ notes @ Ibnf_notes); val fp_res = {Ts = Ts, bnfs = Ibnfs, ctors = ctors, dtors = dtors, xtor_co_recs = recs, @@ -1814,8 +1809,8 @@ ctor_injects = ctor_inject_thms, dtor_injects = dtor_inject_thms, xtor_map_thms = ctor_Imap_thms, xtor_set_thmss = ctor_Iset_thmss', xtor_rel_thms = ctor_Irel_thms, xtor_co_rec_thms = ctor_rec_thms, - xtor_co_rec_o_map_thms = ctor_rec_o_Imap_thms, rel_xtor_co_induct_thm = Irel_induct_thm} - |> morph_fp_result (substitute_noted_thm noted); + xtor_co_rec_o_map_thms = ctor_rec_o_Imap_thms, rel_xtor_co_induct_thm = Irel_induct_thm, + dtor_set_induct_thms = []}; in timer; (fp_res, lthy') end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_lfp_compat.ML --- a/src/HOL/Tools/BNF/bnf_lfp_compat.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_lfp_compat.ML Wed Aug 27 15:52:58 2014 +0200 @@ -80,10 +80,27 @@ val (orig_descr' :: nested_descrs, _) = Datatype_Aux.unfold_datatypes lthy orig_descr all_infos orig_descr nn_fp; + fun cliquify_descr [] = [] + | cliquify_descr [entry] = [[entry]] + | cliquify_descr (full_descr as (_, (T_name1, _, _)) :: _) = + let + val nn = + if member (op =) fpT_names T_name1 then + nn_fp + else + (case Symtab.lookup all_infos T_name1 of + SOME {descr, ...} => + length (filter_out (exists Datatype_Aux.is_rec_type o #2 o snd) descr) + | NONE => raise Fail "unknown old-style datatype"); + in + chop nn full_descr ||> cliquify_descr |> op :: + end; + (* put nested types before the types that nest them, as needed for N2M *) val descrs = burrow reindex_desc (orig_descr' :: rev nested_descrs); val (cliques, descr) = - split_list (flat (map_index (fn (i, descr) => map (pair i) descr) descrs)); + split_list (flat (map_index (fn (i, descr) => map (pair i) descr) + (maps cliquify_descr descrs))); val dest_dtyp = Datatype_Aux.typ_of_dtyp descr; @@ -121,13 +138,13 @@ val inducts = map (the_single o #co_inducts) fp_sugars; fun mk_info (kk, {T = Type (T_name0, _), ctr_sugar = {casex, exhaust, nchotomy, injects, - distincts, case_thms, case_cong, weak_case_cong, split, split_asm, ...}, ...} : fp_sugar) = + distincts, case_thms, case_cong, case_cong_weak, split, split_asm, ...}, ...} : fp_sugar) = (T_name0, {index = kk, descr = descr, inject = injects, distinct = distincts, induct = induct, - inducts = inducts, exhaust = exhaust, nchotomy = nchotomy, rec_names = recs, - rec_rewrites = rec_thms, case_name = fst (dest_Const casex), case_rewrites = case_thms, - case_cong = case_cong, weak_case_cong = weak_case_cong, split = split, - split_asm = split_asm}); + inducts = inducts, exhaust = exhaust, nchotomy = nchotomy, rec_names = recs, + rec_rewrites = rec_thms, case_name = fst (dest_Const casex), case_rewrites = case_thms, + case_cong = case_cong, case_cong_weak = case_cong_weak, split = split, + split_asm = split_asm}); val infos = map_index mk_info (take nn_fp fp_sugars); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_lfp_rec_sugar_more.ML --- a/src/HOL/Tools/BNF/bnf_lfp_rec_sugar_more.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_lfp_rec_sugar_more.ML Wed Aug 27 15:52:58 2014 +0200 @@ -16,7 +16,7 @@ open BNF_FP_N2M_Sugar open BNF_LFP_Rec_Sugar -val nested_simps = @{thms id_def split comp_def fst_conv snd_conv}; +val nested_simps = @{thms o_def[abs_def] id_def split fst_conv snd_conv}; fun is_new_datatype ctxt s = (case fp_sugar_of ctxt s of SOME {fp = Least_FP, ...} => true | _ => false); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_lfp_size.ML --- a/src/HOL/Tools/BNF/bnf_lfp_size.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_lfp_size.ML Wed Aug 27 15:52:58 2014 +0200 @@ -64,15 +64,17 @@ funpow n (fn thm => thm RS @{thm fun_cong_unused_0} handle THM _ => thm RS fun_cong); val rec_o_map_simp_thms = - @{thms o_def id_def case_prod_app case_sum_map_sum case_prod_map_prod BNF_Comp.id_bnf_comp_def}; + @{thms o_def[abs_def] id_def case_prod_app case_sum_map_sum case_prod_map_prod + BNF_Comp.id_bnf_comp_def}; fun mk_rec_o_map_tac ctxt rec_def pre_map_defs live_nesting_map_ident0s abs_inverses ctor_rec_o_map = unfold_thms_tac ctxt [rec_def] THEN - HEADGOAL (rtac (ctor_rec_o_map RS trans)) THEN - PRIMITIVE (Conv.fconv_rule Thm.eta_long_conversion) THEN - HEADGOAL (asm_simp_tac (ss_only (pre_map_defs @ - distinct Thm.eq_thm_prop (live_nesting_map_ident0s @ abs_inverses) @ rec_o_map_simp_thms) ctxt)); + HEADGOAL (rtac (ctor_rec_o_map RS trans) THEN' + CONVERSION Thm.eta_long_conversion THEN' + asm_simp_tac (ss_only (pre_map_defs @ + distinct Thm.eq_thm_prop (live_nesting_map_ident0s @ abs_inverses) @ rec_o_map_simp_thms) + ctxt)); val size_o_map_simp_thms = @{thms prod_inj_map inj_on_id snd_comp_apfst[unfolded apfst_def]}; @@ -303,7 +305,7 @@ curry HOLogic.mk_eq) rec_o_map_lhss rec_o_map_rhss; val rec_o_map_thms = map3 (fn goal => fn rec_def => fn ctor_rec_o_map => - Goal.prove lthy2 [] [] goal (fn {context = ctxt, ...} => + Goal.prove_sorry lthy2 [] [] goal (fn {context = ctxt, ...} => mk_rec_o_map_tac ctxt rec_def pre_map_defs live_nesting_map_ident0s abs_inverses ctor_rec_o_map) |> Thm.close_derivation) @@ -333,7 +335,7 @@ in terms of "map", which is not the end of the world. *) val size_o_map_thmss = map3 (fn goal => fn size_def => the_list o try (fn rec_o_map => - Goal.prove lthy2 [] [] goal (fn {context = ctxt, ...} => + Goal.prove (*no sorry*) lthy2 [] [] goal (fn {context = ctxt, ...} => mk_size_o_map_tac ctxt size_def rec_o_map all_inj_maps nested_size_maps) |> Thm.close_derivation)) size_o_map_goals size_defs rec_o_map_thms diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/BNF/bnf_lfp_tactics.ML --- a/src/HOL/Tools/BNF/bnf_lfp_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/BNF/bnf_lfp_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -582,17 +582,17 @@ (induct_tac THEN' EVERY' (map3 mk_map_cong0 ctor_maps map_cong0s set_setsss)) 1 end; -fun mk_le_rel_OO_tac ctxt m induct ctor_nchotomys ctor_Irels rel_mono_strongs rel_OOs = +fun mk_le_rel_OO_tac ctxt m induct ctor_nchotomys ctor_Irels rel_mono_strong0s le_rel_OOs = EVERY' (rtac induct :: - map4 (fn nchotomy => fn Irel => fn rel_mono => fn rel_OO => + map4 (fn nchotomy => fn Irel => fn rel_mono => fn le_rel_OO => EVERY' [rtac impI, etac (nchotomy RS @{thm nchotomy_relcomppE}), REPEAT_DETERM_N 2 o dtac (Irel RS iffD1), rtac (Irel RS iffD2), - rtac rel_mono, rtac (rel_OO RS @{thm predicate2_eqD} RS iffD2), + rtac rel_mono, rtac (le_rel_OO RS @{thm predicate2D}), rtac @{thm relcomppI}, atac, atac, REPEAT_DETERM_N m o EVERY' [rtac ballI, rtac ballI, rtac impI, atac], - REPEAT_DETERM_N (length rel_OOs) o + REPEAT_DETERM_N (length le_rel_OOs) o EVERY' [rtac ballI, rtac ballI, Goal.assume_rule_tac ctxt]]) - ctor_nchotomys ctor_Irels rel_mono_strongs rel_OOs) 1; + ctor_nchotomys ctor_Irels rel_mono_strong0s le_rel_OOs) 1; (* BNF tactics *) @@ -682,8 +682,6 @@ @{thms case_prodE iffD1[OF prod.inject, elim_format]}), hyp_subst_tac ctxt, dtac (in_Irel RS iffD1), dtac @{thm someI_ex}, REPEAT_DETERM o etac conjE, - TRY o - EVERY' [dtac (Thm.permute_prems 0 1 @{thm ssubst_mem}), atac, hyp_subst_tac ctxt], REPEAT_DETERM o eresolve_tac [CollectE, conjE], atac]) (rev (active_set_map0s ~~ in_Irels))]) (ctor_sets ~~ passive_set_map0s), @@ -703,19 +701,19 @@ EVERY' [rtac iffI, if_tac, only_if_tac] 1 end; -fun mk_rel_induct_tac ctxt IHs m ctor_induct2 ks ctor_rels rel_mono_strongs = +fun mk_rel_induct_tac ctxt IHs m ctor_induct2 ks ctor_rels rel_mono_strong0s = let val n = length ks; in unfold_tac ctxt @{thms le_fun_def le_bool_def all_simps(1,2)[symmetric]} THEN EVERY' [REPEAT_DETERM o rtac allI, rtac ctor_induct2, - EVERY' (map3 (fn IH => fn ctor_rel => fn rel_mono_strong => + EVERY' (map3 (fn IH => fn ctor_rel => fn rel_mono_strong0 => EVERY' [rtac impI, dtac (ctor_rel RS iffD1), rtac (IH RS @{thm spec2} RS mp), - etac rel_mono_strong, + etac rel_mono_strong0, REPEAT_DETERM_N m o rtac @{thm ballI[OF ballI[OF imp_refl]]}, EVERY' (map (fn j => EVERY' [select_prem_tac n (dtac asm_rl) j, rtac @{thm ballI[OF ballI]}, Goal.assume_rule_tac ctxt]) ks)]) - IHs ctor_rels rel_mono_strongs)] 1 + IHs ctor_rels rel_mono_strong0s)] 1 end; fun mk_fold_transfer_tac ctxt m ctor_rel_induct map_transfers folds = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -18,7 +18,7 @@ distincts: thm list, case_thms: thm list, case_cong: thm, - weak_case_cong: thm, + case_cong_weak: thm, split: thm, split_asm: thm, disc_defs: thm list, @@ -26,13 +26,13 @@ discIs: thm list, sel_defs: thm list, sel_thmss: thm list list, - disc_excludesss: thm list list list, - disc_exhausts: thm list, - sel_exhausts: thm list, + distinct_discsss: thm list list list, + exhaust_discs: thm list, + exhaust_sels: thm list, collapses: thm list, expands: thm list, - sel_splits: thm list, - sel_split_asms: thm list, + split_sels: thm list, + split_sel_asms: thm list, case_eq_ifs: thm list}; val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar @@ -90,7 +90,7 @@ distincts: thm list, case_thms: thm list, case_cong: thm, - weak_case_cong: thm, + case_cong_weak: thm, split: thm, split_asm: thm, disc_defs: thm list, @@ -98,19 +98,19 @@ discIs: thm list, sel_defs: thm list, sel_thmss: thm list list, - disc_excludesss: thm list list list, - disc_exhausts: thm list, - sel_exhausts: thm list, + distinct_discsss: thm list list list, + exhaust_discs: thm list, + exhaust_sels: thm list, collapses: thm list, expands: thm list, - sel_splits: thm list, - sel_split_asms: thm list, + split_sels: thm list, + split_sel_asms: thm list, case_eq_ifs: thm list}; fun morph_ctr_sugar phi {ctrs, casex, discs, selss, exhaust, nchotomy, injects, distincts, - case_thms, case_cong, weak_case_cong, split, split_asm, disc_defs, disc_thmss, discIs, sel_defs, - sel_thmss, disc_excludesss, disc_exhausts, sel_exhausts, collapses, expands, sel_splits, - sel_split_asms, case_eq_ifs} = + case_thms, case_cong, case_cong_weak, split, split_asm, disc_defs, disc_thmss, discIs, sel_defs, + sel_thmss, distinct_discsss, exhaust_discs, exhaust_sels, collapses, expands, split_sels, + split_sel_asms, case_eq_ifs} = {ctrs = map (Morphism.term phi) ctrs, casex = Morphism.term phi casex, discs = map (Morphism.term phi) discs, @@ -121,7 +121,7 @@ distincts = map (Morphism.thm phi) distincts, case_thms = map (Morphism.thm phi) case_thms, case_cong = Morphism.thm phi case_cong, - weak_case_cong = Morphism.thm phi weak_case_cong, + case_cong_weak = Morphism.thm phi case_cong_weak, split = Morphism.thm phi split, split_asm = Morphism.thm phi split_asm, disc_defs = map (Morphism.thm phi) disc_defs, @@ -129,13 +129,13 @@ discIs = map (Morphism.thm phi) discIs, sel_defs = map (Morphism.thm phi) sel_defs, sel_thmss = map (map (Morphism.thm phi)) sel_thmss, - disc_excludesss = map (map (map (Morphism.thm phi))) disc_excludesss, - disc_exhausts = map (Morphism.thm phi) disc_exhausts, - sel_exhausts = map (Morphism.thm phi) sel_exhausts, + distinct_discsss = map (map (map (Morphism.thm phi))) distinct_discsss, + exhaust_discs = map (Morphism.thm phi) exhaust_discs, + exhaust_sels = map (Morphism.thm phi) exhaust_sels, collapses = map (Morphism.thm phi) collapses, expands = map (Morphism.thm phi) expands, - sel_splits = map (Morphism.thm phi) sel_splits, - sel_split_asms = map (Morphism.thm phi) sel_split_asms, + split_sels = map (Morphism.thm phi) split_sels, + split_sel_asms = map (Morphism.thm phi) split_sel_asms, case_eq_ifs = map (Morphism.thm phi) case_eq_ifs}; val transfer_ctr_sugar = @@ -200,23 +200,24 @@ val case_congN = "case_cong"; val case_eq_ifN = "case_eq_if"; val collapseN = "collapse"; -val disc_excludeN = "disc_exclude"; -val disc_exhaustN = "disc_exhaust"; val discN = "disc"; val discIN = "discI"; val distinctN = "distinct"; +val distinct_discN = "distinct_disc"; val exhaustN = "exhaust"; +val exhaust_discN = "exhaust_disc"; val expandN = "expand"; val injectN = "inject"; val nchotomyN = "nchotomy"; val selN = "sel"; -val sel_exhaustN = "sel_exhaust"; -val sel_splitN = "sel_split"; -val sel_split_asmN = "sel_split_asm"; +val exhaust_selN = "exhaust_sel"; val splitN = "split"; +val split_asmN = "split_asm"; +val split_selN = "split_sel"; +val split_sel_asmN = "split_sel_asm"; val splitsN = "splits"; -val split_asmN = "split_asm"; -val weak_case_cong_thmsN = "weak_case_cong"; +val split_selsN = "split_sels"; +val case_cong_weak_thmsN = "case_cong_weak"; val cong_attrs = @{attributes [cong]}; val dest_attrs = @{attributes [dest]}; @@ -256,12 +257,6 @@ fun mk_disc_or_sel Ts t = subst_nonatomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t; -fun name_of_const what t = - (case head_of t of - Const (s, _) => s - | Free (s, _) => s - | _ => error ("Cannot extract name of " ^ what)); - val name_of_ctr = name_of_const "constructor"; fun name_of_disc t = @@ -683,7 +678,7 @@ ks goals inject_thmss distinct_thmsss end; - val (case_cong_thm, weak_case_cong_thm) = + val (case_cong_thm, case_cong_weak_thm) = let fun mk_prem xctr xs xf xg = fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr), @@ -739,9 +734,9 @@ end; val (sel_defs, all_sel_thms, sel_thmss, disc_defs, disc_thmss, nontriv_disc_thmss, - discI_thms, nontriv_discI_thms, disc_exclude_thms, disc_exclude_thmsss, - disc_exhaust_thms, sel_exhaust_thms, all_collapse_thms, safe_collapse_thms, - expand_thms, sel_split_thms, sel_split_asm_thms, case_eq_if_thms) = + discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, + exhaust_disc_thms, exhaust_sel_thms, all_collapse_thms, safe_collapse_thms, + expand_thms, split_sel_thms, split_sel_asm_thms, case_eq_if_thms) = if no_discs_sels then ([], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], []) else @@ -833,7 +828,7 @@ flat (map2 (fn b => if is_discI_boring b then K [] else single) disc_bindings discI_thms); - val (disc_exclude_thms, (disc_exclude_thmsss', disc_exclude_thmsss)) = + val (distinct_disc_thms, (distinct_disc_thmsss', distinct_disc_thmsss)) = let fun mk_goal [] = [] | mk_goal [((_, udisc), (_, udisc'))] = @@ -849,25 +844,25 @@ val half_goalss = map mk_goal half_pairss; val half_thmss = map3 (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] => - fn disc_thm => [prove (mk_half_disc_exclude_tac lthy m discD disc_thm) goal]) + fn disc_thm => [prove (mk_half_distinct_disc_tac lthy m discD disc_thm) goal]) half_goalss half_pairss (flat disc_thmss'); val other_half_goalss = map (mk_goal o map swap) half_pairss; val other_half_thmss = - map2 (map2 (prove o mk_other_half_disc_exclude_tac)) half_thmss + map2 (map2 (prove o mk_other_half_distinct_disc_tac)) half_thmss other_half_goalss; in join_halves n half_thmss other_half_thmss ||> `transpose |>> has_alternate_disc_def ? K [] end; - val disc_exhaust_thm = + val exhaust_disc_thm = let fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc]; val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs)); in Goal.prove_sorry lthy [] [] goal (fn _ => - mk_disc_exhaust_tac n exhaust_thm discI_thms) + mk_exhaust_disc_tac n exhaust_thm discI_thms) |> Thm.close_derivation end; @@ -896,13 +891,13 @@ val swapped_all_collapse_thms = map2 (fn m => fn thm => if m = 0 then thm else thm RS sym) ms all_collapse_thms; - val sel_exhaust_thm = + val exhaust_sel_thm = let fun mk_prem usel_ctr = mk_imp_p [mk_Trueprop_eq (u, usel_ctr)]; val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem usel_ctrs)); in Goal.prove_sorry lthy [] [] goal (fn _ => - mk_sel_exhaust_tac n disc_exhaust_thm swapped_all_collapse_thms) + mk_exhaust_sel_tac n exhaust_disc_thm swapped_all_collapse_thms) |> Thm.close_derivation end; @@ -925,14 +920,14 @@ map2 (fn thm => fn [] => thm | _ => thm RS sym) all_collapse_thms uselss; in Goal.prove_sorry lthy [] [] goal (fn _ => - mk_expand_tac lthy n ms (inst_thm u disc_exhaust_thm) - (inst_thm v disc_exhaust_thm) uncollapse_thms disc_exclude_thmsss - disc_exclude_thmsss') + mk_expand_tac lthy n ms (inst_thm u exhaust_disc_thm) + (inst_thm v exhaust_disc_thm) uncollapse_thms distinct_disc_thmsss + distinct_disc_thmsss') |> singleton (Proof_Context.export names_lthy lthy) |> Thm.close_derivation end; - val (sel_split_thm, sel_split_asm_thm) = + val (split_sel_thm, split_sel_asm_thm) = let val zss = map (K []) xss; val goal = mk_split_goal usel_ctrs zss usel_fs; @@ -955,9 +950,9 @@ end; in (sel_defs, all_sel_thms, sel_thmss, disc_defs, disc_thmss, nontriv_disc_thmss, - discI_thms, nontriv_discI_thms, disc_exclude_thms, disc_exclude_thmsss, - [disc_exhaust_thm], [sel_exhaust_thm], all_collapse_thms, safe_collapse_thms, - [expand_thm], [sel_split_thm], [sel_split_asm_thm], [case_eq_if_thm]) + discI_thms, nontriv_discI_thms, distinct_disc_thms, distinct_disc_thmsss, + [exhaust_disc_thm], [exhaust_sel_thm], all_collapse_thms, safe_collapse_thms, + [expand_thm], [split_sel_thm], [split_sel_asm_thm], [case_eq_if_thm]) end; val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases)); @@ -972,30 +967,29 @@ (flat nontriv_disc_eq_thmss, code_nitpicksimp_attrs)] |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])])); - (* "exhaust" is deliberately put first to avoid apparent circular dependencies in the proof - objects, which would confuse MaSh. *) val notes = - [(exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]), - (caseN, case_thms, code_nitpicksimp_simp_attrs), + [(caseN, case_thms, code_nitpicksimp_simp_attrs), (case_congN, [case_cong_thm], []), + (case_cong_weak_thmsN, [case_cong_weak_thm], cong_attrs), (case_eq_ifN, case_eq_if_thms, []), (collapseN, safe_collapse_thms, simp_attrs), (discN, flat nontriv_disc_thmss, simp_attrs), (discIN, nontriv_discI_thms, []), - (disc_excludeN, disc_exclude_thms, dest_attrs), - (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]), (distinctN, distinct_thms, simp_attrs @ inductsimp_attrs), + (distinct_discN, distinct_disc_thms, dest_attrs), + (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]), + (exhaust_discN, exhaust_disc_thms, [exhaust_case_names_attr]), + (exhaust_selN, exhaust_sel_thms, [exhaust_case_names_attr]), (expandN, expand_thms, []), (injectN, inject_thms, iff_attrs @ inductsimp_attrs), (nchotomyN, [nchotomy_thm], []), (selN, all_sel_thms, code_nitpicksimp_simp_attrs), - (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]), - (sel_splitN, sel_split_thms, []), - (sel_split_asmN, sel_split_asm_thms, []), (splitN, [split_thm], []), (split_asmN, [split_asm_thm], []), - (splitsN, [split_thm, split_asm_thm], []), - (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)] + (split_selN, split_sel_thms, []), + (split_sel_asmN, split_sel_asm_thms, []), + (split_selsN, split_sel_thms @ split_sel_asm_thms, []), + (splitsN, [split_thm, split_asm_thm], [])] |> filter_out (null o #2) |> map (fn (thmN, thms, attrs) => ((qualify true (Binding.name thmN), attrs), [(thms, [])])); @@ -1025,12 +1019,12 @@ val ctr_sugar = {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm, nchotomy = nchotomy_thm, injects = inject_thms, distincts = distinct_thms, - case_thms = case_thms, case_cong = case_cong_thm, weak_case_cong = weak_case_cong_thm, + case_thms = case_thms, case_cong = case_cong_thm, case_cong_weak = case_cong_weak_thm, split = split_thm, split_asm = split_asm_thm, disc_defs = disc_defs, disc_thmss = disc_thmss, discIs = discI_thms, sel_defs = sel_defs, sel_thmss = sel_thmss, - disc_excludesss = disc_exclude_thmsss, disc_exhausts = disc_exhaust_thms, - sel_exhausts = sel_exhaust_thms, collapses = all_collapse_thms, expands = expand_thms, - sel_splits = sel_split_thms, sel_split_asms = sel_split_asm_thms, + distinct_discsss = distinct_disc_thmsss, exhaust_discs = exhaust_disc_thms, + exhaust_sels = exhaust_sel_thms, collapses = all_collapse_thms, expands = expand_thms, + split_sels = split_sel_thms, split_sel_asms = split_sel_asm_thms, case_eq_ifs = case_eq_if_thms} |> morph_ctr_sugar (substitute_noted_thm noted); in diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Ctr_Sugar/ctr_sugar_tactics.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar_tactics.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar_tactics.ML Wed Aug 27 15:52:58 2014 +0200 @@ -22,13 +22,13 @@ val mk_case_eq_if_tac: Proof.context -> int -> thm -> thm list -> thm list list -> thm list list -> tactic val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic - val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic + val mk_exhaust_disc_tac: int -> thm -> thm list -> tactic + val mk_exhaust_sel_tac: int -> thm -> thm list -> tactic val mk_expand_tac: Proof.context -> int -> int list -> thm -> thm -> thm list -> thm list list list -> thm list list list -> tactic - val mk_half_disc_exclude_tac: Proof.context -> int -> thm -> thm -> tactic + val mk_half_distinct_disc_tac: Proof.context -> int -> thm -> thm -> tactic val mk_nchotomy_tac: int -> thm -> tactic - val mk_other_half_disc_exclude_tac: thm -> tactic - val mk_sel_exhaust_tac: int -> thm -> thm list -> tactic + val mk_other_half_distinct_disc_tac: thm -> tactic val mk_split_tac: Proof.context -> thm -> thm list -> thm list list -> thm list list -> thm list list list -> tactic val mk_split_asm_tac: Proof.context -> thm -> tactic @@ -67,21 +67,21 @@ (([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac]) |> k = 1 ? swap |> op @))); -fun mk_half_disc_exclude_tac ctxt m discD disc' = +fun mk_half_distinct_disc_tac ctxt m discD disc' = HEADGOAL (dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN' rtac disc'); -fun mk_other_half_disc_exclude_tac half = HEADGOAL (etac @{thm contrapos_pn} THEN' etac half); +fun mk_other_half_distinct_disc_tac half = HEADGOAL (etac @{thm contrapos_pn} THEN' etac half); -fun mk_disc_or_sel_exhaust_tac n exhaust destIs = +fun mk_exhaust_disc_or_sel_tac n exhaust destIs = HEADGOAL (rtac exhaust THEN' EVERY' (map2 (fn k => fn destI => dtac destI THEN' select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) destIs)); -val mk_disc_exhaust_tac = mk_disc_or_sel_exhaust_tac; +val mk_exhaust_disc_tac = mk_exhaust_disc_or_sel_tac; -fun mk_sel_exhaust_tac n disc_exhaust collapses = - mk_disc_or_sel_exhaust_tac n disc_exhaust collapses ORELSE +fun mk_exhaust_sel_tac n exhaust_disc collapses = + mk_exhaust_disc_or_sel_tac n exhaust_disc collapses ORELSE HEADGOAL (etac meta_mp THEN' resolve_tac collapses); fun mk_collapse_tac ctxt m discD sels = @@ -92,17 +92,17 @@ REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN' SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl)); -fun mk_expand_tac ctxt n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss - disc_excludesss' = +fun mk_expand_tac ctxt n ms uexhaust_disc vexhaust_disc uncollapses distinct_discsss + distinct_discsss' = if ms = [0] then HEADGOAL (rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses))) THEN' - TRY o EVERY' [rtac udisc_exhaust, atac, rtac vdisc_exhaust, atac]) + TRY o EVERY' [rtac uexhaust_disc, atac, rtac vexhaust_disc, atac]) else let val ks = 1 upto n in - HEADGOAL (rtac udisc_exhaust THEN' - EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' => fn uuncollapse => - EVERY' [rtac (uuncollapse RS trans) THEN' TRY o atac, rtac sym, rtac vdisc_exhaust, - EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse => + HEADGOAL (rtac uexhaust_disc THEN' + EVERY' (map5 (fn k => fn m => fn distinct_discss => fn distinct_discss' => fn uuncollapse => + EVERY' [rtac (uuncollapse RS trans) THEN' TRY o atac, rtac sym, rtac vexhaust_disc, + EVERY' (map4 (fn k' => fn distinct_discs => fn distinct_discs' => fn vuncollapse => EVERY' (if k' = k then [rtac (vuncollapse RS trans), TRY o atac] @ @@ -113,11 +113,11 @@ REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE, asm_simp_tac (ss_only [] ctxt)]) else - [dtac (the_single (if k = n then disc_excludes else disc_excludes')), + [dtac (the_single (if k = n then distinct_discs else distinct_discs')), etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}), atac, atac])) - ks disc_excludess disc_excludess' uncollapses)]) - ks ms disc_excludesss disc_excludesss' uncollapses)) + ks distinct_discss distinct_discss' uncollapses)]) + ks ms distinct_discsss distinct_discsss' uncollapses)) end; fun mk_case_same_ctr_tac ctxt injects = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Ctr_Sugar/ctr_sugar_util.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar_util.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar_util.ML Wed Aug 27 15:52:58 2014 +0200 @@ -39,6 +39,8 @@ (string * sort) list * Proof.context val variant_tfrees: string list -> Proof.context -> typ list * Proof.context + val name_of_const: string -> term -> string + val typ_subst_nonatomic: (typ * typ) list -> typ -> typ val subst_nonatomic_types: (typ * typ) list -> term -> term @@ -177,6 +179,12 @@ apfst (map TFree) o variant_types (map (ensure_prefix "'") ss) (replicate (length ss) @{sort type}); +fun name_of_const what t = + (case head_of t of + Const (s, _) => s + | Free (s, _) => s + | _ => error ("Cannot extract name of " ^ what)); + (*Replace each Ti by Ui (starting from the leaves); inst = [(T1, U1), ..., (Tn, Un)].*) fun typ_subst_nonatomic [] = I | typ_subst_nonatomic inst = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Datatype/datatype_aux.ML --- a/src/HOL/Tools/Datatype/datatype_aux.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Datatype/datatype_aux.ML Wed Aug 27 15:52:58 2014 +0200 @@ -27,7 +27,7 @@ case_name : string, case_rewrites : thm list, case_cong : thm, - weak_case_cong : thm, + case_cong_weak : thm, split : thm, split_asm: thm} end @@ -195,7 +195,7 @@ case_name : string, case_rewrites : thm list, case_cong : thm, - weak_case_cong : thm, + case_cong_weak : thm, split : thm, split_asm: thm}; @@ -311,10 +311,9 @@ else is_nonempty_dt (i :: is) i | arg_nonempty _ = true; in exists (forall (arg_nonempty o strip_dtyp) o snd) constrs end - in - assert_all (fn (i, _) => is_nonempty_dt [i] i) (hd descr) - (fn (_, (s, _, _)) => raise Datatype_Empty s) - end; + val _ = hd descr |> forall (fn (i, (s, _, _)) => + is_nonempty_dt [i] i orelse raise Datatype_Empty s) + in () end; (* unfold a list of mutually recursive datatype specifications *) (* all types of the form DtType (dt_name, [..., DtRec _, ...]) *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Datatype/datatype_data.ML --- a/src/HOL/Tools/Datatype/datatype_data.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Datatype/datatype_data.ML Wed Aug 27 15:52:58 2014 +0200 @@ -95,7 +95,7 @@ head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of case_rewrite)))); fun ctr_sugar_of_info ({exhaust, nchotomy, inject, distinct, case_rewrites, case_cong, - weak_case_cong, split, split_asm, ...} : Datatype_Aux.info) = + case_cong_weak, split, split_asm, ...} : Datatype_Aux.info) = {ctrs = ctrs_of_exhaust exhaust, casex = case_of_case_rewrite (hd case_rewrites), discs = [], @@ -106,7 +106,7 @@ distincts = distinct, case_thms = case_rewrites, case_cong = case_cong, - weak_case_cong = weak_case_cong, + case_cong_weak = case_cong_weak, split = split, split_asm = split_asm, disc_defs = [], @@ -114,13 +114,13 @@ discIs = [], sel_defs = [], sel_thmss = [], - disc_excludesss = [], - disc_exhausts = [], - sel_exhausts = [], + distinct_discsss = [], + exhaust_discs = [], + exhaust_sels = [], collapses = [], expands = [], - sel_splits = [], - sel_split_asms = [], + split_sels = [], + split_sel_asms = [], case_eq_ifs = []}; fun register dt_infos = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Datatype/datatype_prop.ML --- a/src/HOL/Tools/Datatype/datatype_prop.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Datatype/datatype_prop.ML Wed Aug 27 15:52:58 2014 +0200 @@ -18,7 +18,7 @@ val make_cases : string list -> descr list -> theory -> term list list val make_splits : string list -> descr list -> theory -> (term * term) list val make_case_combs : string list -> descr list -> theory -> string -> term list - val make_weak_case_congs : string list -> descr list -> theory -> term list + val make_case_cong_weaks : string list -> descr list -> theory -> term list val make_case_congs : string list -> descr list -> theory -> term list val make_nchotomys : descr list -> term list end; @@ -330,7 +330,7 @@ (************************* additional rules for TFL ***************************) -fun make_weak_case_congs case_names descr thy = +fun make_case_cong_weaks case_names descr thy = let val case_combs = make_case_combs case_names descr thy "f"; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Datatype/rep_datatype.ML --- a/src/HOL/Tools/Datatype/rep_datatype.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Datatype/rep_datatype.ML Wed Aug 27 15:52:58 2014 +0200 @@ -258,7 +258,8 @@ thy2 |> Sign.add_path (space_implode "_" new_type_names) |> Global_Theory.note_thmss "" - [((Binding.name "rec", [Nitpick_Simps.add]), [(rec_thms, [])])] + [((Binding.name "rec", [Named_Theorems.add @{named_theorems nitpick_simp}]), + [(rec_thms, [])])] ||> Sign.parent_path |-> (fn thms => pair (reccomb_names, maps #2 thms)) end; @@ -347,7 +348,8 @@ val case_names = map case_name_of case_thms; in thy2 - |> Context.theory_map ((fold o fold) Nitpick_Simps.add_thm case_thms) + |> Context.theory_map + ((fold o fold) (Named_Theorems.add_thm @{named_theorems nitpick_simp}) case_thms) |> Sign.parent_path |> Datatype_Aux.store_thmss "case" new_type_names case_thms |-> (fn thmss => pair (thmss, case_names)) @@ -393,16 +395,16 @@ |-> (fn (thms1, thms2) => pair (thms1 ~~ thms2)) end; -fun prove_weak_case_congs new_type_names case_names descr thy = +fun prove_case_cong_weaks new_type_names case_names descr thy = let - fun prove_weak_case_cong t = + fun prove_case_cong_weak t = Goal.prove_sorry_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t) (fn {prems, ...} => EVERY [rtac (hd prems RS arg_cong) 1]); - val weak_case_congs = - map prove_weak_case_cong (Datatype_Prop.make_weak_case_congs case_names descr thy); + val case_cong_weaks = + map prove_case_cong_weak (Datatype_Prop.make_case_cong_weaks case_names descr thy); - in thy |> Datatype_Aux.store_thms "weak_case_cong" new_type_names weak_case_congs end; + in thy |> Datatype_Aux.store_thms "case_cong_weak" new_type_names case_cong_weaks end; (* additional theorems for TFL *) @@ -468,7 +470,7 @@ fun make_dt_info descr induct inducts rec_names rec_rewrites (index, (((((((((((_, (tname, _, _))), inject), distinct), - exhaust), nchotomy), case_name), case_rewrites), case_cong), weak_case_cong), + exhaust), nchotomy), case_name), case_rewrites), case_cong), case_cong_weak), (split, split_asm))) = (tname, {index = index, @@ -484,7 +486,7 @@ case_name = case_name, case_rewrites = case_rewrites, case_cong = case_cong, - weak_case_cong = weak_case_cong, + case_cong_weak = case_cong_weak, split = split, split_asm = split_asm}); @@ -511,8 +513,8 @@ |> prove_case_thms config new_type_names descr rec_names rec_rewrites; val (case_congs, thy7) = thy6 |> prove_case_congs new_type_names case_names descr nchotomys case_rewrites; - val (weak_case_congs, thy8) = thy7 - |> prove_weak_case_congs new_type_names case_names descr; + val (case_cong_weaks, thy8) = thy7 + |> prove_case_cong_weaks new_type_names case_names descr; val (splits, thy9) = thy8 |> prove_split_thms config new_type_names case_names descr inject distinct exhaust case_rewrites; @@ -522,7 +524,7 @@ map_index (make_dt_info flat_descr induct inducts rec_names rec_rewrites) (hd descr ~~ inject ~~ distinct ~~ exhaust ~~ nchotomys ~~ - case_names ~~ case_rewrites ~~ case_congs ~~ weak_case_congs ~~ splits); + case_names ~~ case_rewrites ~~ case_congs ~~ case_cong_weaks ~~ splits); val dt_names = map fst dt_infos; val prfx = Binding.qualify true (space_implode "_" new_type_names); val simps = flat (inject @ distinct @ case_rewrites) @ rec_rewrites; @@ -551,7 +553,7 @@ ((Binding.empty, [iff_add]), [(flat inject, [])]), ((Binding.empty, [Classical.safe_elim NONE]), [(map (fn th => th RS notE) (flat distinct), [])]), - ((Binding.empty, [Simplifier.cong_add]), [(weak_case_congs, [])]), + ((Binding.empty, [Simplifier.cong_add]), [(case_cong_weaks, [])]), ((Binding.empty, [Induct.induct_simp_add]), [(flat (distinct @ inject), [])])] @ named_rules @ unnamed_rules) |> snd diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/function.ML --- a/src/HOL/Tools/Function/function.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/function.ML Wed Aug 27 15:52:58 2014 +0200 @@ -279,9 +279,7 @@ (* setup *) -val setup = - setup_case_cong - #> Function_Common.Termination_Simps.setup +val setup = setup_case_cong val get_congs = Function_Ctx_Tree.get_function_congs diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/function_common.ML --- a/src/HOL/Tools/Function/function_common.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/function_common.ML Wed Aug 27 15:52:58 2014 +0200 @@ -12,7 +12,7 @@ defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> - Attrib.src list -> thm list -> local_theory -> thm list * local_theory, + Token.src list -> thm list -> local_theory -> thm list * local_theory, fnames : string list, case_names : string list, fs : term list, @@ -37,7 +37,7 @@ defname : string, (* contains no logical entities: invariant under morphisms: *) add_simps : (binding -> binding) -> string -> (binding -> binding) -> - Attrib.src list -> thm list -> local_theory -> thm list * local_theory, + Token.src list -> thm list -> local_theory -> thm list * local_theory, fnames : string list, case_names : string list, fs : term list, @@ -81,7 +81,6 @@ val import_function_data : term -> Proof.context -> info option val import_last_function : Proof.context -> info option val add_function_data : info -> Context.generic -> Context.generic - structure Termination_Simps: NAMED_THMS val set_termination_prover : (Proof.context -> tactic) -> Context.generic -> Context.generic val get_termination_prover : Proof.context -> tactic val store_termination_rule : thm -> Context.generic -> Context.generic @@ -224,15 +223,6 @@ #> store_termination_rule termination -(* Simp rules for termination proofs *) - -structure Termination_Simps = Named_Thms -( - val name = @{binding termination_simp} - val description = "simplification rules for termination proofs" -) - - (* Default Termination Prover *) (* FIXME just one data slot (record) per program unit *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/lexicographic_order.ML --- a/src/HOL/Tools/Function/lexicographic_order.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/lexicographic_order.ML Wed Aug 27 15:52:58 2014 +0200 @@ -182,7 +182,7 @@ val (domT, _) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of rel)) val measure_funs = (* 1: generate measures *) - MeasureFunctions.get_measure_functions ctxt domT + Measure_Functions.get_measure_functions ctxt domT val table = (* 2: create table *) map (fn t => map (mk_cell thy solve_tac (dest_term t)) measure_funs) tl @@ -212,7 +212,7 @@ fun lexicographic_order_tac quiet ctxt = TRY (Function_Common.apply_termination_rule ctxt 1) THEN lex_order_tac quiet ctxt - (auto_tac (ctxt addsimps Function_Common.Termination_Simps.get ctxt)) + (auto_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems termination_simp}))) val setup = Context.theory_map (Function_Common.set_termination_prover (lexicographic_order_tac false)) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/measure_functions.ML --- a/src/HOL/Tools/Function/measure_functions.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/measure_functions.ML Wed Aug 27 15:52:58 2014 +0200 @@ -7,25 +7,18 @@ signature MEASURE_FUNCTIONS = sig val get_measure_functions : Proof.context -> typ -> term list - val setup : theory -> theory end -structure MeasureFunctions : MEASURE_FUNCTIONS = +structure Measure_Functions : MEASURE_FUNCTIONS = struct (** User-declared size functions **) -structure Measure_Heuristic_Rules = Named_Thms -( - val name = @{binding measure_function} - val description = - "rules that guide the heuristic generation of measure functions" -); fun mk_is_measure t = Const (@{const_name is_measure}, fastype_of t --> HOLogic.boolT) $ t fun find_measures ctxt T = - DEPTH_SOLVE (resolve_tac (Measure_Heuristic_Rules.get ctxt) 1) + DEPTH_SOLVE (resolve_tac (rev (Named_Theorems.get ctxt @{named_theorems measure_function})) 1) (HOLogic.mk_Trueprop (mk_is_measure (Var (("f",0), T --> HOLogic.natT))) |> cterm_of (Proof_Context.theory_of ctxt) |> Goal.init) |> Seq.map (prop_of #> (fn _ $ (_ $ (_ $ f)) => f)) @@ -53,6 +46,4 @@ val get_measure_functions = mk_all_measure_funs -val setup = Measure_Heuristic_Rules.setup - end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/partial_function.ML --- a/src/HOL/Tools/Function/partial_function.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/partial_function.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,7 +6,6 @@ signature PARTIAL_FUNCTION = sig - val setup: theory -> theory val init: string -> term -> term -> thm -> thm -> thm option -> declaration val mono_tac: Proof.context -> int -> tactic @@ -54,13 +53,6 @@ val lookup_mode = Symtab.lookup o Modes.get o Context.Proof; -structure Mono_Rules = Named_Thms -( - val name = @{binding partial_function_mono}; - val description = "monotonicity rules for partial function definitions"; -); - - (*** Automated monotonicity proofs ***) fun strip_cases ctac = ctac #> Seq.map snd; @@ -109,7 +101,7 @@ fun mono_tac ctxt = K (Local_Defs.unfold_tac ctxt [@{thm curry_def}]) THEN' (TRY o REPEAT_ALL_NEW - (resolve_tac (Mono_Rules.get ctxt) + (resolve_tac (rev (Named_Theorems.get ctxt @{named_theorems partial_function_mono})) ORELSE' split_cases_tac ctxt)); @@ -321,7 +313,4 @@ ((mode -- (Parse.fixes -- (Parse.where_ |-- Parse_Spec.spec))) >> (fn (mode, (fixes, spec)) => add_partial_function_cmd mode fixes spec)); - -val setup = Mono_Rules.setup; - end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/scnp_reconstruct.ML --- a/src/HOL/Tools/Function/scnp_reconstruct.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/scnp_reconstruct.ML Wed Aug 27 15:52:58 2014 +0200 @@ -331,7 +331,7 @@ fun decomp_scnp_tac orders ctxt = let - val extra_simps = Function_Common.Termination_Simps.get ctxt + val extra_simps = Named_Theorems.get ctxt @{named_theorems termination_simp} val autom_tac = auto_tac (ctxt addsimps extra_simps) in gen_sizechange_tac orders autom_tac ctxt diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/size.ML --- a/src/HOL/Tools/Function/size.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/size.ML Wed Aug 27 15:52:58 2014 +0200 @@ -200,7 +200,7 @@ val ([(_, size_thms)], thy'') = thy' |> Global_Theory.note_thmss "" [((Binding.name "size", - [Simplifier.simp_add, Nitpick_Simps.add, + [Simplifier.simp_add, Named_Theorems.add @{named_theorems nitpick_simp}, Thm.declaration_attribute (fn thm => Context.mapping (Code.add_default_eqn thm) I)]), [(size_eqns, [])])]; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Function/termination.ML --- a/src/HOL/Tools/Function/termination.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Function/termination.ML Wed Aug 27 15:52:58 2014 +0200 @@ -199,7 +199,7 @@ val thy = Proof_Context.theory_of ctxt val sk = mk_sum_skel rel val Ts = node_types sk T - val M = Inttab.make (map_index (apsnd (MeasureFunctions.get_measure_functions ctxt)) Ts) + val M = Inttab.make (map_index (apsnd (Measure_Functions.get_measure_functions ctxt)) Ts) val chain_cache = Cache.create Term2tab.empty Term2tab.lookup Term2tab.update (prove_chain thy chain_tac) val descent_cache = Cache.create Term3tab.empty Term3tab.lookup Term3tab.update diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Lifting/lifting_bnf.ML --- a/src/HOL/Tools/Lifting/lifting_bnf.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Lifting/lifting_bnf.ML Wed Aug 27 15:52:58 2014 +0200 @@ -64,8 +64,9 @@ val T_rel = list_comb (mk_rel_of_bnf Ds As Bs bnf, nth argss' 3) val concl = mk_Quotient [R_rel, Abs_map, Rep_map, T_rel] |> HOLogic.mk_Trueprop val goal = Logic.list_implies (assms, concl) - val thm = Goal.prove ctxt [] [] goal + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => Quotient_tac bnf ctxt 1) + |> Thm.close_derivation in Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm) end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Lifting/lifting_def.ML --- a/src/HOL/Tools/Lifting/lifting_def.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Lifting/lifting_def.ML Wed Aug 27 15:52:58 2014 +0200 @@ -13,7 +13,8 @@ (binding * mixfix) -> typ -> term -> thm -> thm list -> local_theory -> local_theory val lift_def_cmd: - (binding * string option * mixfix) * string * (Facts.ref * Args.src list) list -> local_theory -> Proof.state + (binding * string option * mixfix) * string * (Facts.ref * Token.src list) list -> + local_theory -> Proof.state val can_generate_code_cert: thm -> bool end @@ -699,7 +700,7 @@ val liftdef_parser = (((Parse.binding -- (@{keyword "::"} |-- (Parse.typ >> SOME) -- Parse.opt_mixfix')) >> Parse.triple2) --| @{keyword "is"} -- Parse.term -- - Scan.optional (@{keyword "parametric"} |-- Parse.!!! Parse_Spec.xthms1) []) >> Parse.triple1 + Scan.optional (@{keyword "parametric"} |-- Parse.!!! Parse.xthms1) []) >> Parse.triple1 val _ = Outer_Syntax.local_theory_to_proof @{command_spec "lift_definition"} "definition for constants over the quotient type" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Lifting/lifting_info.ML --- a/src/HOL/Tools/Lifting/lifting_info.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Lifting/lifting_info.ML Wed Aug 27 15:52:58 2014 +0200 @@ -277,13 +277,8 @@ (* theorems that a relator of an eq_onp is an eq_onp of the corresponding predicate *) -structure Relator_Eq_Onp = Named_Thms -( - val name = @{binding relator_eq_onp} - val description = "theorems that a relator of an eq_onp is an eq_onp of the corresponding predicate" -) - -fun get_relator_eq_onp_rules ctxt = map safe_mk_meta_eq (Relator_Eq_Onp.get ctxt) +fun get_relator_eq_onp_rules ctxt = + map safe_mk_meta_eq (rev (Named_Theorems.get ctxt @{named_theorems relator_eq_onp})) (* info about reflexivity rules *) @@ -525,12 +520,13 @@ val setup = quot_map_attribute_setup #> quot_del_attribute_setup - #> Relator_Eq_Onp.setup #> relator_distr_attribute_setup (* setup fixed eq_onp rules *) -val _ = Context.>> (fold (Relator_Eq_Onp.add_thm o Transfer.prep_transfer_domain_thm @{context}) +val _ = Context.>> + (fold (Named_Theorems.add_thm @{named_theorems relator_eq_onp} o + Transfer.prep_transfer_domain_thm @{context}) @{thms composed_equiv_rel_eq_onp composed_equiv_rel_eq_eq_onp}) (* setup fixed reflexivity rules *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Lifting/lifting_setup.ML --- a/src/HOL/Tools/Lifting/lifting_setup.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Lifting/lifting_setup.ML Wed Aug 27 15:52:58 2014 +0200 @@ -221,9 +221,9 @@ val thy = Proof_Context.theory_of lthy val dummy_thm = Thm.transfer thy Drule.dummy_thm - val pointer = Outer_Syntax.scan Position.none bundle_name + val pointer = Outer_Syntax.scan (Keyword.get_lexicons ()) Position.none bundle_name val restore_lifting_att = - ([dummy_thm], [Args.src ("Lifting.lifting_restore_internal", Position.none) pointer]) + ([dummy_thm], [Token.src ("Lifting.lifting_restore_internal", Position.none) pointer]) in lthy |> Local_Theory.declaration {syntax = false, pervasive = true} @@ -796,8 +796,8 @@ val _ = Outer_Syntax.local_theory @{command_spec "setup_lifting"} "setup lifting infrastructure" - (opt_gen_code -- Parse_Spec.xthm -- Scan.option Parse_Spec.xthm - -- Scan.option (@{keyword "parametric"} |-- Parse.!!! Parse_Spec.xthm) >> + (opt_gen_code -- Parse.xthm -- Scan.option Parse.xthm + -- Scan.option (@{keyword "parametric"} |-- Parse.!!! Parse.xthm) >> (fn (((gen_code, xthm), opt_reflp_xthm), opt_par_xthm) => setup_lifting_cmd gen_code xthm opt_reflp_xthm opt_par_xthm)) @@ -969,7 +969,7 @@ case bundle of [(_, [arg_src])] => let - val (name, _) = Args.syntax (Scan.lift Args.name) arg_src ctxt + val (name, _) = Token.syntax (Scan.lift Args.name) arg_src ctxt handle ERROR _ => error "The provided bundle is not a lifting bundle." in name end | _ => error "The provided bundle is not a lifting bundle." diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Nitpick/nitpick.ML --- a/src/HOL/Tools/Nitpick/nitpick.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Nitpick/nitpick.ML Wed Aug 27 15:52:58 2014 +0200 @@ -416,17 +416,6 @@ \in the problem.") else () - val _ = - if mode = Normal andalso - exists (fn Type (@{type_name Datatype.node}, _) => true | _ => false) - all_Ts then - print_nt (K ("Warning: The problem involves directly or indirectly the \ - \internal type " ^ quote @{type_name Datatype.node} ^ - ". This type is very Nitpick-unfriendly, and its presence \ - \usually indicates either a failure of abstraction or a \ - \quirk in Nitpick.")) - else - () val (mono_Ts, nonmono_Ts) = List.partition is_type_monotonic all_Ts val _ = if verbose andalso not unique_scope then diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Nitpick/nitpick_hol.ML --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Wed Aug 27 15:52:58 2014 +0200 @@ -974,7 +974,7 @@ fun zero_const T = Const (@{const_name zero_class.zero}, T) fun suc_const T = Const (@{const_name Suc}, T --> T) -fun uncached_data_type_constrs ({thy, ctxt, ...} : hol_context) (T as Type (s, _)) = +fun uncached_data_type_constrs ({ctxt, ...} : hol_context) (T as Type (s, _)) = if is_interpreted_type s then [] else @@ -1927,12 +1927,13 @@ Const (s, _) => (s, t) | t' => raise TERM ("Nitpick_HOL.pair_for_prop", [t, t']) -fun def_table_for get ctxt subst = - ctxt |> get |> map (pair_for_prop o subst_atomic subst) +fun def_table_for ts subst = + ts |> map (pair_for_prop o subst_atomic subst) |> AList.group (op =) |> Symtab.make fun const_def_tables ctxt subst ts = - (def_table_for (map prop_of o Nitpick_Unfolds.get) ctxt subst, + (def_table_for + (map prop_of (rev (Named_Theorems.get ctxt @{named_theorems nitpick_unfold}))) subst, fold (fn (s, t) => Symtab.map_default (s, []) (cons t)) (map pair_for_prop ts) Symtab.empty) @@ -1943,14 +1944,15 @@ fun const_simp_table ctxt = def_table_for (map_filter (equationalize_term ctxt "nitpick_simp" o prop_of) - o Nitpick_Simps.get) ctxt + (rev (Named_Theorems.get ctxt @{named_theorems nitpick_simp}))) fun const_psimp_table ctxt = def_table_for (map_filter (equationalize_term ctxt "nitpick_psimp" o prop_of) - o Nitpick_Psimps.get) ctxt + (rev (Named_Theorems.get ctxt @{named_theorems nitpick_psimp}))) fun const_choice_spec_table ctxt subst = - map (subst_atomic subst o prop_of) (Nitpick_Choice_Specs.get ctxt) + map (subst_atomic subst o prop_of) + (rev (Named_Theorems.get ctxt @{named_theorems nitpick_choice_spec})) |> const_nondef_table fun inductive_intro_table ctxt subst def_tables = @@ -1958,9 +1960,8 @@ def_table_for (maps (map (unfold_mutually_inductive_preds thy def_tables o prop_of) o snd o snd) - o filter (fn (cat, _) => cat = Spec_Rules.Inductive orelse - cat = Spec_Rules.Co_Inductive) - o Spec_Rules.get) ctxt subst + (filter (fn (cat, _) => cat = Spec_Rules.Inductive orelse + cat = Spec_Rules.Co_Inductive) (Spec_Rules.get ctxt))) subst end fun ground_theorem_table thy = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Predicate_Compile/code_prolog.ML --- a/src/HOL/Tools/Predicate_Compile/code_prolog.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Predicate_Compile/code_prolog.ML Wed Aug 27 15:52:58 2014 +0200 @@ -1047,7 +1047,8 @@ val thy = Proof_Context.theory_of ctxt val ((((full_constname, constT), vs'), intro), thy1) = Predicate_Compile_Aux.define_quickcheck_predicate t' thy - val thy2 = Context.theory_map (Predicate_Compile_Alternative_Defs.add_thm intro) thy1 + val thy2 = + Context.theory_map (Named_Theorems.add_thm @{named_theorems code_pred_def} intro) thy1 val thy3 = Predicate_Compile.preprocess preprocess_options (Const (full_constname, constT)) thy2 val ctxt' = Proof_Context.init_global thy3 val _ = tracing "Generating prolog program..." diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML Wed Aug 27 15:52:58 2014 +0200 @@ -1042,7 +1042,7 @@ let val ctxt = Proof_Context.init_global thy (* FIXME proper context!? *) val process = - rewrite_rule ctxt (Predicate_Compile_Simps.get ctxt) + rewrite_rule ctxt (Named_Theorems.get ctxt @{named_theorems code_pred_simp}) fun process_False intro_t = if member (op =) (Logic.strip_imp_prems intro_t) @{prop "False"} then NONE else SOME intro_t diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Wed Aug 27 15:52:58 2014 +0200 @@ -161,8 +161,8 @@ fun inline_equations thy th = let val ctxt = Proof_Context.init_global thy - val inline_defs = Predicate_Compile_Inline_Defs.get ctxt - val th' = (Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps inline_defs)) th + val inline_defs = Named_Theorems.get ctxt @{named_theorems code_pred_inline} + val th' = Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps inline_defs) th (*val _ = print_step options ("Inlining " ^ (Syntax.string_of_term_global thy (prop_of th)) ^ "with " ^ (commas (map ((Syntax.string_of_term_global thy) o prop_of) inline_defs)) @@ -208,12 +208,12 @@ NONE fun filter_defs ths = map_filter filtering (map (normalize thy o Thm.transfer thy) ths) val spec = - (case filter_defs (Predicate_Compile_Alternative_Defs.get ctxt) of + (case filter_defs (Named_Theorems.get ctxt @{named_theorems code_pred_def}) of [] => (case Spec_Rules.retrieve ctxt t of [] => error ("No specification for " ^ Syntax.string_of_term_global thy t) | ((_, (_, ths)) :: _) => filter_defs ths) - | ths => rev ths) + | ths => ths) val _ = if show_intermediate_results options then tracing ("Specification for " ^ (Syntax.string_of_term_global thy t) ^ ":\n" ^ diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Wed Aug 27 15:52:58 2014 +0200 @@ -231,7 +231,8 @@ val thy = Proof_Context.theory_of ctxt val ((((full_constname, constT), vs'), intro), thy1) = Predicate_Compile_Aux.define_quickcheck_predicate t' thy - val thy2 = Context.theory_map (Predicate_Compile_Alternative_Defs.add_thm intro) thy1 + val thy2 = + Context.theory_map (Named_Theorems.add_thm @{named_theorems code_pred_def} intro) thy1 val (thy3, _) = cpu_time "predicate preprocessing" (fn () => Predicate_Compile.preprocess options (Const (full_constname, constT)) thy2) val (thy4, _) = cpu_time "random_dseq core compilation" diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Qelim/cooper.ML --- a/src/HOL/Tools/Qelim/cooper.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Qelim/cooper.ML Wed Aug 27 15:52:58 2014 +0200 @@ -862,9 +862,8 @@ let val simpset_ctxt = put_simpset (fst (get ctxt)) ctxt delsimps del_ths addsimps add_ths - val aprems = Arith_Data.get_arith_facts ctxt in - Method.insert_tac aprems + Method.insert_tac (rev (Named_Theorems.get ctxt @{named_theorems arith})) THEN_ALL_NEW Object_Logic.full_atomize_tac ctxt THEN_ALL_NEW CONVERSION Thm.eta_long_conversion THEN_ALL_NEW simp_tac simpset_ctxt diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quickcheck/exhaustive_generators.ML --- a/src/HOL/Tools/Quickcheck/exhaustive_generators.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quickcheck/exhaustive_generators.ML Wed Aug 27 15:52:58 2014 +0200 @@ -198,7 +198,7 @@ fun contains_recursive_type_under_function_types xs = exists (fn (_, (_, _, cs)) => cs |> exists (snd #> exists (fn dT => - (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype.DtRec _) => true | _ => false)))) xs + (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype_Aux.DtRec _) => true | _ => false)))) xs fun instantiate_datatype (name, constprfx, sort, mk_equations, mk_T, argnames) config descr vs tycos prfx (names, auxnames) (Ts, Us) thy = @@ -254,7 +254,7 @@ let val cnstrs = flat (maps (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd) - (Symtab.dest (Datatype.get_all (Proof_Context.theory_of ctxt)))) + (Symtab.dest (Datatype_Data.get_all (Proof_Context.theory_of ctxt)))) fun is_constrt (Const (s, T), ts) = (case (AList.lookup (op =) cnstrs s, body_type T) of (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' | _ => false) @@ -537,19 +537,19 @@ Quickcheck_Common.datatype_interpretation (@{sort exhaustive}, instantiate_exhaustive_datatype) val setup_bounded_forall_datatype_interpretation = - Datatype.interpretation (Quickcheck_Common.ensure_sort + Datatype_Data.interpretation (Quickcheck_Common.ensure_sort (((@{sort type}, @{sort type}), @{sort bounded_forall}), - (Datatype.the_descr, instantiate_bounded_forall_datatype))) + (Datatype_Data.the_descr, instantiate_bounded_forall_datatype))) val active = Attrib.setup_config_bool @{binding quickcheck_exhaustive_active} (K true); val setup = Quickcheck_Common.datatype_interpretation (@{sort full_exhaustive}, instantiate_full_exhaustive_datatype) -(* #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype +(* #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype (((@{sort typerep}, @{sort term_of}), @{sort exhaustive}), instantiate_exhaustive_datatype)) - #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype + #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype (((@{sort typerep}, @{sort term_of}), @{sort fast_exhaustive}), instantiate_fast_exhaustive_datatype)) - #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype + #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype (((@{sort type}, @{sort type}), @{sort bounded_forall}), instantiate_bounded_forall_datatype))*) #> Context.theory_map (Quickcheck.add_tester ("exhaustive", (active, test_goals))) #> Context.theory_map (Quickcheck.add_batch_generator ("exhaustive", compile_generator_exprs)) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quickcheck/narrowing_generators.ML --- a/src/HOL/Tools/Quickcheck/narrowing_generators.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quickcheck/narrowing_generators.ML Wed Aug 27 15:52:58 2014 +0200 @@ -175,7 +175,7 @@ fun contains_recursive_type_under_function_types xs = exists (fn (_, (_, _, cs)) => cs |> exists (snd #> exists (fn dT => - (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype.DtRec _) => true | _ => false)))) xs + (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype_Aux.DtRec _) => true | _ => false)))) xs fun instantiate_narrowing_datatype config descr vs tycos prfx (names, auxnames) (Ts, Us) thy = let diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quickcheck/quickcheck_common.ML --- a/src/HOL/Tools/Quickcheck/quickcheck_common.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quickcheck/quickcheck_common.ML Wed Aug 27 15:52:58 2014 +0200 @@ -23,15 +23,15 @@ val generator_test_goal_terms : generator -> Proof.context -> bool -> (string * typ) list -> (term * term list) list -> Quickcheck.result list - type instantiation = Datatype.config -> Datatype.descr -> (string * sort) list + type instantiation = Datatype_Aux.config -> Datatype_Aux.descr -> (string * sort) list -> string list -> string -> string list * string list -> typ list * typ list -> theory -> theory val ensure_sort : (((sort * sort) * sort) * ((theory -> string list -> Datatype_Aux.descr * (string * sort) list * string list * string * (string list * string list) * (typ list * typ list)) * instantiation)) - -> Datatype.config -> string list -> theory -> theory + -> Datatype_Aux.config -> string list -> theory -> theory val ensure_common_sort_datatype : - (sort * instantiation) -> Datatype.config -> string list -> theory -> theory + (sort * instantiation) -> Datatype_Aux.config -> string list -> theory -> theory val datatype_interpretation : (sort * instantiation) -> theory -> theory val gen_mk_parametric_generator_expr : (((Proof.context -> term * term list -> term) * term) * typ) @@ -387,7 +387,7 @@ (** ensuring sort constraints **) -type instantiation = Datatype.config -> Datatype.descr -> (string * sort) list +type instantiation = Datatype_Aux.config -> Datatype_Aux.descr -> (string * sort) list -> string list -> string -> string list * string list -> typ list * typ list -> theory -> theory fun perhaps_constrain thy insts raw_vs = @@ -419,9 +419,9 @@ end; fun ensure_common_sort_datatype (sort, instantiate) = - ensure_sort (((@{sort typerep}, @{sort term_of}), sort), (Datatype.the_descr, instantiate)) + ensure_sort (((@{sort typerep}, @{sort term_of}), sort), (Datatype_Data.the_descr, instantiate)) -val datatype_interpretation = Datatype.interpretation o ensure_common_sort_datatype +val datatype_interpretation = Datatype_Data.interpretation o ensure_common_sort_datatype (** generic parametric compilation **) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quotient/quotient_def.ML --- a/src/HOL/Tools/Quotient/quotient_def.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quotient/quotient_def.ML Wed Aug 27 15:52:58 2014 +0200 @@ -84,8 +84,7 @@ Quotient_Info.update_quotconsts c qcinfo | _ => I)) |> (snd oo Local_Theory.note) - ((rsp_thm_name, [Attrib.internal (K Quotient_Info.rsp_rules_add)]), - [rsp_thm]) + ((rsp_thm_name, @{attributes [quot_respect]}), [rsp_thm]) in (qconst_data, lthy'') end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quotient/quotient_info.ML --- a/src/HOL/Tools/Quotient/quotient_info.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quotient/quotient_info.ML Wed Aug 27 15:52:58 2014 +0200 @@ -33,17 +33,6 @@ val dest_quotconsts_global: theory -> quotconsts list val dest_quotconsts: Proof.context -> quotconsts list val print_quotconsts: Proof.context -> unit - - val equiv_rules: Proof.context -> thm list - val equiv_rules_add: attribute - val rsp_rules: Proof.context -> thm list - val rsp_rules_add: attribute - val prs_rules: Proof.context -> thm list - val prs_rules_add: attribute - val id_simps: Proof.context -> thm list - val quotient_rules: Proof.context -> thm list - val quotient_rules_add: attribute - val setup: theory -> theory end; structure Quotient_Info: QUOTIENT_INFO = @@ -69,16 +58,17 @@ (* FIXME export proper internal update operation!? *) -val quotmaps_attribute_setup = - Attrib.setup @{binding mapQ3} - ((Args.type_name {proper = true, strict = true} --| Scan.lift @{keyword "="}) -- - (Scan.lift @{keyword "("} |-- - Args.const {proper = true, strict = true} --| Scan.lift @{keyword ","} -- - Attrib.thm --| Scan.lift @{keyword ")"}) >> - (fn (tyname, (relname, qthm)) => - let val minfo = {relmap = relname, quot_thm = qthm} - in Thm.declaration_attribute (fn _ => Quotmaps.map (Symtab.update (tyname, minfo))) end)) - "declaration of map information" +val _ = + Theory.setup + (Attrib.setup @{binding mapQ3} + ((Args.type_name {proper = true, strict = true} --| Scan.lift @{keyword "="}) -- + (Scan.lift @{keyword "("} |-- + Args.const {proper = true, strict = true} --| Scan.lift @{keyword ","} -- + Attrib.thm --| Scan.lift @{keyword ")"}) >> + (fn (tyname, (relname, qthm)) => + let val minfo = {relmap = relname, quot_thm = qthm} + in Thm.declaration_attribute (fn _ => Quotmaps.map (Symtab.update (tyname, minfo))) end)) + "declaration of map information") fun print_quotmaps ctxt = let @@ -235,66 +225,6 @@ |> Pretty.writeln end -(* equivalence relation theorems *) -structure Equiv_Rules = Named_Thms -( - val name = @{binding quot_equiv} - val description = "equivalence relation theorems" -) - -val equiv_rules = Equiv_Rules.get -val equiv_rules_add = Equiv_Rules.add - -(* respectfulness theorems *) -structure Rsp_Rules = Named_Thms -( - val name = @{binding quot_respect} - val description = "respectfulness theorems" -) - -val rsp_rules = Rsp_Rules.get -val rsp_rules_add = Rsp_Rules.add - -(* preservation theorems *) -structure Prs_Rules = Named_Thms -( - val name = @{binding quot_preserve} - val description = "preservation theorems" -) - -val prs_rules = Prs_Rules.get -val prs_rules_add = Prs_Rules.add - -(* id simplification theorems *) -structure Id_Simps = Named_Thms -( - val name = @{binding id_simps} - val description = "identity simp rules for maps" -) - -val id_simps = Id_Simps.get - -(* quotient theorems *) -structure Quotient_Rules = Named_Thms -( - val name = @{binding quot_thm} - val description = "quotient theorems" -) - -val quotient_rules = Quotient_Rules.get -val quotient_rules_add = Quotient_Rules.add - - -(* theory setup *) - -val setup = - quotmaps_attribute_setup #> - Equiv_Rules.setup #> - Rsp_Rules.setup #> - Prs_Rules.setup #> - Id_Simps.setup #> - Quotient_Rules.setup - (* outer syntax commands *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quotient/quotient_tacs.ML --- a/src/HOL/Tools/Quotient/quotient_tacs.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quotient/quotient_tacs.ML Wed Aug 27 15:52:58 2014 +0200 @@ -55,14 +55,14 @@ (** solvers for equivp and quotient assumptions **) fun equiv_tac ctxt = - REPEAT_ALL_NEW (resolve_tac (Quotient_Info.equiv_rules ctxt)) + REPEAT_ALL_NEW (resolve_tac (rev (Named_Theorems.get ctxt @{named_theorems quot_equiv}))) val equiv_solver = mk_solver "Equivalence goal solver" equiv_tac fun quotient_tac ctxt = (REPEAT_ALL_NEW (FIRST' [rtac @{thm identity_quotient3}, - resolve_tac (Quotient_Info.quotient_rules ctxt)])) + resolve_tac (rev (Named_Theorems.get ctxt @{named_theorems quot_thm}))])) val quotient_solver = mk_solver "Quotient goal solver" quotient_tac @@ -144,11 +144,12 @@ fun reflp_get ctxt = map_filter (fn th => if prems_of th = [] then SOME (OF1 @{thm equivp_reflp} th) else NONE - handle THM _ => NONE) (Quotient_Info.equiv_rules ctxt) + handle THM _ => NONE) (rev (Named_Theorems.get ctxt @{named_theorems quot_equiv})) val eq_imp_rel = @{lemma "equivp R ==> a = b --> R a b" by (simp add: equivp_reflp)} -fun eq_imp_rel_get ctxt = map (OF1 eq_imp_rel) (Quotient_Info.equiv_rules ctxt) +fun eq_imp_rel_get ctxt = + map (OF1 eq_imp_rel) (rev (Named_Theorems.get ctxt @{named_theorems quot_equiv})) fun regularize_tac ctxt = let @@ -370,7 +371,8 @@ (* respectfulness of constants; in particular of a simple relation *) | _ $ (Const _) $ (Const _) (* rel_fun, list_rel, etc but not equality *) - => resolve_tac (Quotient_Info.rsp_rules ctxt) THEN_ALL_NEW quotient_tac ctxt + => resolve_tac (rev (Named_Theorems.get ctxt @{named_theorems quot_respect})) + THEN_ALL_NEW quotient_tac ctxt (* R (...) (Rep (Abs ...)) ----> R (...) (...) *) (* observe map_fun *) @@ -516,20 +518,20 @@ 4. test for refl *) -fun clean_tac lthy = +fun clean_tac ctxt = let - val thy = Proof_Context.theory_of lthy + val thy = Proof_Context.theory_of ctxt val defs = map (Thm.symmetric o #def) (Quotient_Info.dest_quotconsts_global thy) - val prs = Quotient_Info.prs_rules lthy - val ids = Quotient_Info.id_simps lthy + val prs = rev (Named_Theorems.get ctxt @{named_theorems quot_preserve}) + val ids = rev (Named_Theorems.get ctxt @{named_theorems id_simps}) val thms = @{thms Quotient3_abs_rep Quotient3_rel_rep babs_prs all_prs ex_prs ex1_prs} @ ids @ prs @ defs - val simpset = (mk_minimal_simpset lthy) addsimps thms addSolver quotient_solver + val simpset = (mk_minimal_simpset ctxt) addsimps thms addSolver quotient_solver in EVERY' [ - map_fun_tac lthy, - lambda_prs_tac lthy, + map_fun_tac ctxt, + lambda_prs_tac ctxt, simp_tac simpset, TRY o rtac refl] end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Quotient/quotient_type.ML --- a/src/HOL/Tools/Quotient/quotient_type.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Quotient/quotient_type.ML Wed Aug 27 15:52:58 2014 +0200 @@ -13,7 +13,7 @@ ((binding * binding) option * bool * thm option) -> Proof.context -> Proof.state val quotient_type_cmd: ((((((bool * string list) * binding) * mixfix) * string) * (bool * string)) * - (binding * binding) option) * (Facts.ref * Args.src list) option -> Proof.context -> Proof.state + (binding * binding) option) * (Facts.ref * Token.src list) option -> Proof.context -> Proof.state end; structure Quotient_Type: QUOTIENT_TYPE = @@ -206,11 +206,10 @@ |> init_quotient_infr gen_code quotient_thm equiv_thm opt_par_thm |> (snd oo Local_Theory.note) ((equiv_thm_name, - if partial then [] else [Attrib.internal (K Quotient_Info.equiv_rules_add)]), + if partial then [] else @{attributes [quot_equiv]}), [equiv_thm]) |> (snd oo Local_Theory.note) - ((quotient_thm_name, [Attrib.internal (K Quotient_Info.quotient_rules_add)]), - [quotient_thm]) + ((quotient_thm_name, @{attributes [quot_thm]}), [quotient_thm]) in (quotients, lthy4) end @@ -344,7 +343,7 @@ Parse.opt_mixfix -- (@{keyword "="} |-- Parse.typ) -- (@{keyword "/"} |-- (partial -- Parse.term)) -- Scan.option (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) - -- Scan.option (@{keyword "parametric"} |-- Parse.!!! Parse_Spec.xthm) + -- Scan.option (@{keyword "parametric"} |-- Parse.!!! Parse.xthm) val _ = Outer_Syntax.local_theory_to_proof @{command_spec "quotient_type"} diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT/smt_normalize.ML --- a/src/HOL/Tools/SMT/smt_normalize.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT/smt_normalize.ML Wed Aug 27 15:52:58 2014 +0200 @@ -158,7 +158,7 @@ | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct) | _ => raise CTERM ("no equation", [ct])) - fun get_constrs thy (Type (n, _)) = these (Datatype.get_constrs thy n) + fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n) | get_constrs _ _ = [] fun is_constr thy (n, T) = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT/z3_proof_reconstruction.ML --- a/src/HOL/Tools/SMT/z3_proof_reconstruction.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT/z3_proof_reconstruction.ML Wed Aug 27 15:52:58 2014 +0200 @@ -7,9 +7,7 @@ signature Z3_PROOF_RECONSTRUCTION = sig val add_z3_rule: thm -> Context.generic -> Context.generic - val reconstruct: Proof.context -> SMT_Translate.recon -> string list -> - int list * thm - val setup: theory -> theory + val reconstruct: Proof.context -> SMT_Translate.recon -> string list -> int list * thm end structure Z3_Proof_Reconstruction: Z3_PROOF_RECONSTRUCTION = @@ -23,8 +21,6 @@ (* net of schematic rules *) -val z3_ruleN = "z3_rule" - local val description = "declaration of Z3 proof rules" @@ -55,9 +51,9 @@ fun by_schematic_rule ctxt ct = the (Z3_Proof_Tools.net_instance (Z3_Rules.get (Context.Proof ctxt)) ct) -val z3_rules_setup = - Attrib.setup (Binding.name z3_ruleN) (Attrib.add_del add del) description #> - Global_Theory.add_thms_dynamic (Binding.name z3_ruleN, Net.content o Z3_Rules.get) +val _ = Theory.setup + (Attrib.setup @{binding z3_rule} (Attrib.add_del add del) description #> + Global_Theory.add_thms_dynamic (@{binding z3_rule}, Net.content o Z3_Rules.get)) end @@ -84,8 +80,7 @@ Pretty.big_list ("Z3 found a proof," ^ " but proof reconstruction failed at the following subgoal:") (pretty_goal ctxt thms (Thm.term_of ct)), - Pretty.str ("Adding a rule to the lemma group " ^ quote z3_ruleN ^ - " might solve this problem.")]) + Pretty.str ("Declaring a rule as [z3_rule] might solve this problem.")]) fun apply [] ct = error (try_apply_err ct) | apply (prover :: provers) ct = @@ -671,12 +666,6 @@ * normal forms for polynoms (integer/real arithmetic) * quantifier elimination over linear arithmetic * ... ? **) -structure Z3_Simps = Named_Thms -( - val name = @{binding z3_simp} - val description = "simplification rules for Z3 proof reconstruction" -) - local fun spec_meta_eq_of thm = (case try (fn th => th RS @{thm spec}) thm of @@ -880,7 +869,8 @@ val (asserted, steps, vars, ctxt1) = Z3_Proof_Parser.parse ctxt typs terms output - val simpset = Z3_Proof_Tools.make_simpset ctxt1 (Z3_Simps.get ctxt1) + val simpset = + Z3_Proof_Tools.make_simpset ctxt1 (Named_Theorems.get ctxt1 @{named_theorems z3_simp}) val ((is, rules), cxp as (ctxt2, _)) = add_asserted outer_ctxt rewrite_rules assms asserted ctxt1 @@ -895,6 +885,4 @@ end -val setup = z3_rules_setup #> Z3_Simps.setup - end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smt2_normalize.ML --- a/src/HOL/Tools/SMT2/smt2_normalize.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smt2_normalize.ML Wed Aug 27 15:52:58 2014 +0200 @@ -144,7 +144,7 @@ | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct) | _ => raise CTERM ("no equation", [ct])) - fun get_constrs thy (Type (n, _)) = these (Datatype.get_constrs thy n) + fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n) | get_constrs _ _ = [] fun is_constr thy (n, T) = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smt2_real.ML --- a/src/HOL/Tools/SMT2/smt2_real.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smt2_real.ML Wed Aug 27 15:52:58 2014 +0200 @@ -36,7 +36,7 @@ fold (SMT2_Builtin.add_builtin_fun' SMTLIB2_Interface.smtlib2C) [ (@{const less (real)}, "<"), (@{const less_eq (real)}, "<="), - (@{const uminus (real)}, "~"), + (@{const uminus (real)}, "-"), (@{const plus (real)}, "+"), (@{const minus (real)}, "-") ] #> SMT2_Builtin.add_builtin_fun SMTLIB2_Interface.smtlib2C diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smt2_systems.ML --- a/src/HOL/Tools/SMT2/smt2_systems.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smt2_systems.ML Wed Aug 27 15:52:58 2014 +0200 @@ -37,6 +37,8 @@ val (l, ls) = split_first (snd (take_prefix (curry (op =) "") lines)) in (test_outcome solver_name l, ls) end +fun on_first_non_unsupported_line test_outcome solver_name lines = + on_first_line test_outcome solver_name (filter (curry (op <>) "unsupported") lines) (* CVC3 *) @@ -85,6 +87,27 @@ end +(* veriT *) + +val veriT: SMT2_Solver.solver_config = { + name = "veriT", + class = K SMTLIB2_Interface.smtlib2C, + avail = make_avail "VERIT", + command = make_command "VERIT", + options = (fn ctxt => [ + "--proof-version=1", + "--proof=-", + "--proof-prune", + "--proof-merge", + "--disable-print-success", + "--disable-banner", + "--max-time=" ^ string_of_int (Real.ceil (Config.get ctxt SMT2_Config.timeout))]), + smt_options = [], + default_max_relevant = 120 (* FUDGE *), + outcome = on_first_non_unsupported_line (outcome_of "unsat" "sat" + "warning : proof_done: status is still open"), + parse_proof = SOME VeriT_Proof_Parse.parse_proof, + replay = NONE } (* Z3 *) @@ -160,6 +183,7 @@ val _ = Theory.setup ( SMT2_Solver.add_solver cvc3 #> SMT2_Solver.add_solver cvc4 #> + SMT2_Solver.add_solver veriT #> SMT2_Solver.add_solver z3) end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smtlib2.ML --- a/src/HOL/Tools/SMT2/smtlib2.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smtlib2.ML Wed Aug 27 15:52:58 2014 +0200 @@ -118,7 +118,7 @@ read l cs None ((S (rev ts1) :: ts2) :: tss) | read l ("#" :: "x" :: cs) None (ts :: tss) = token read_hex l cs ts tss - | read l ("#" :: cs) None (ts :: tss) = + | read l ("#" :: "b" :: cs) None (ts :: tss) = token read_bin l cs ts tss | read l (":" :: cs) None (ts :: tss) = token (read_sym Key) l cs ts tss diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smtlib2_interface.ML --- a/src/HOL/Tools/SMT2/smtlib2_interface.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smtlib2_interface.ML Wed Aug 27 15:52:58 2014 +0200 @@ -11,6 +11,7 @@ val add_logic: int * (term list -> string option) -> Context.generic -> Context.generic val translate_config: Proof.context -> SMT2_Translate.config val assert_index_of_name: string -> int + val assert_prefix : string end; structure SMTLIB2_Interface: SMTLIB2_INTERFACE = @@ -48,7 +49,7 @@ (@{const If ('a)}, "ite"), (@{const less (int)}, "<"), (@{const less_eq (int)}, "<="), - (@{const uminus (int)}, "~"), + (@{const uminus (int)}, "-"), (@{const plus (int)}, "+"), (@{const minus (int)}, "-")] #> SMT2_Builtin.add_builtin_fun smtlib2C diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smtlib2_isar.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/SMT2/smtlib2_isar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,71 @@ +(* Title: HOL/Tools/SMT2/smtlib2_isar.ML + Author: Jasmin Blanchette, TU Muenchen + Author: Mathias Fleury, ENS Rennes + +General tools for Isar proof reconstruction. +*) + +signature SMTLIB2_ISAR = +sig + val unlift_term: term list -> term -> term + val postprocess_step_conclusion: theory -> thm list -> term list -> term -> term + val normalizing_prems : Proof.context -> term -> (string * string list) list + val distinguish_conjecture_and_hypothesis : ''a list -> ''b -> ''b -> ''b list -> + (''a * 'c) list -> 'c list -> 'c -> (ATP_Problem.atp_formula_role * 'c) option + val unskolemize_names: term -> term +end; + +structure SMTLIB2_Isar: SMTLIB2_ISAR = +struct + +open ATP_Util +open ATP_Problem +open ATP_Proof_Reconstruct + +fun unlift_term ll_defs = + let + val lifted = map (ATP_Util.extract_lambda_def dest_Free o ATP_Util.hol_open_form I) ll_defs + + fun un_free (t as Free (s, _)) = + (case AList.lookup (op =) lifted s of + SOME t => un_term t + | NONE => t) + | un_free t = t + and un_term t = map_aterms un_free t + in un_term end + +(* It is not entirely clear why this should be necessary, especially for abstractions variables. *) +val unskolemize_names = + Term.map_abs_vars (perhaps (try Name.dest_skolem)) + #> Term.map_aterms (perhaps (try (fn Free (s, T) => Free (Name.dest_skolem s, T)))) + +fun postprocess_step_conclusion thy rewrite_rules ll_defs = + Raw_Simplifier.rewrite_term thy rewrite_rules [] + #> Object_Logic.atomize_term thy + #> not (null ll_defs) ? unlift_term ll_defs + #> simplify_bool + #> unskolemize_names + #> HOLogic.mk_Trueprop + +fun normalizing_prems ctxt concl0 = + SMT2_Normalize.case_bool_entry :: SMT2_Normalize.special_quant_table @ + SMT2_Normalize.abs_min_max_table + |> map_filter (fn (c, th) => + if exists_Const (curry (op =) c o fst) concl0 then + let val s = short_thm_name ctxt th in SOME (s, [s]) end + else + NONE) + +fun distinguish_conjecture_and_hypothesis ss id conjecture_id prem_ids fact_helper_ts hyp_ts + concl_t = + (case ss of + [s] => SOME (Axiom, the (AList.lookup (op =) fact_helper_ts s)) + | _ => + if id = conjecture_id then + SOME (Conjecture, concl_t) + else + (case find_index (curry (op =) id) prem_ids of + ~1 => NONE (* lambda-lifting definition *) + | i => SOME (Hypothesis, nth hyp_ts i))) + +end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/smtlib2_proof.ML --- a/src/HOL/Tools/SMT2/smtlib2_proof.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/smtlib2_proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -21,8 +21,7 @@ ('a, 'b) context -> 'c * ('d, 'b) context val next_id: ('a, 'b) context -> int * ('a, 'b) context val with_fresh_names: (('a list, 'b) context -> - term * ((string * (string * typ)) list, 'b) context) -> ('c, 'b) context -> - (term * string list) * ('c, 'b) context + term * ((string * (string * typ)) list, 'b) context) -> ('c, 'b) context -> (term * string list) (*type and term parsers*) type type_parser = SMTLIB2.tree * typ list -> typ option @@ -56,7 +55,7 @@ extra: 'a} fun mk_context ctxt id syms typs funs extra: ('a, 'b) context = - {ctxt=ctxt, id=id, syms=syms, typs=typs, funs=funs, extra=extra} + {ctxt = ctxt, id = id, syms = syms, typs = typs, funs = funs, extra = extra} fun empty_context ctxt typs funs = mk_context ctxt 1 Symtab.empty typs funs [] @@ -82,7 +81,7 @@ fun next_id ({ctxt, id, syms, typs, funs, extra}: ('a, 'b) context) = (id, mk_context ctxt (id + 1) syms typs funs extra) -fun with_fresh_names f ({ctxt, id, syms, typs, funs, extra}: ('a, 'b) context) = +fun with_fresh_names f ({ctxt, id, syms, typs, funs, ...}: ('a, 'b) context) = let fun bind (_, v as (_, T)) t = Logic.all_const T $ Term.absfree v t @@ -93,11 +92,11 @@ singleton (Proof_Context.standard_term_check_finish ctxt) fun infer ctxt t = if needs_infer t then infer_types ctxt t else t - val (t, {ctxt=ctxt', extra=names, ...}: ((string * (string * typ)) list, 'b) context) = + val (t, {ctxt = ctxt', extra = names, ...}: ((string * (string * typ)) list, 'b) context) = f (mk_context ctxt id syms typs funs []) val t' = infer ctxt' (fold_rev bind names (HOLogic.mk_Trueprop t)) in - ((t', map fst names), mk_context ctxt id syms typs funs extra) + (t', map fst names) end fun lookup_typ ({typs, ...}: ('a, 'b) context) = Symtab.lookup typs diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/verit_isar.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/SMT2/verit_isar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,59 @@ +(* Title: HOL/Tools/SMT2/verit_isar.ML + Author: Mathias Fleury, TU Muenchen + Author: Jasmin Blanchette, TU Muenchen + +VeriT proofs as generic ATP proofs for Isar proof reconstruction. +*) + +signature VERIT_ISAR = +sig + type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step + val atp_proof_of_veriT_proof: Proof.context -> term list -> thm list -> term list -> term -> + (string * term) list -> int list -> int -> (int * string) list -> VeriT_Proof.veriT_step list -> + (term, string) ATP_Proof.atp_step list +end; + +structure VeriT_Isar: VERIT_ISAR = +struct + +open ATP_Util +open ATP_Problem +open ATP_Proof +open ATP_Proof_Reconstruct +open SMTLIB2_Isar +open VeriT_Proof + +fun atp_proof_of_veriT_proof ctxt ll_defs rewrite_rules hyp_ts concl_t fact_helper_ts prem_ids + conjecture_id fact_helper_ids proof = + let + val thy = Proof_Context.theory_of ctxt + fun steps_of (VeriT_Proof.VeriT_Step {id, rule, prems, concl, ...}) = + let + val concl' = postprocess_step_conclusion thy rewrite_rules ll_defs concl + fun standard_step role = ((id, []), role, concl', rule, map (fn id => (id, [])) prems) + in + if rule = veriT_input_rule then + let val ss = the_list (AList.lookup (op =) fact_helper_ids (the (Int.fromString id))) in + (case distinguish_conjecture_and_hypothesis ss (the (Int.fromString id)) + conjecture_id prem_ids fact_helper_ts hyp_ts concl_t of + NONE => [] + | SOME (role0, concl00) => + let + val name0 = (id ^ "a", ss) + val concl0 = unskolemize_names concl00 + in + [(name0, role0, concl0, rule, []), + ((id, []), Plain, concl', veriT_rewrite_rule, + name0 :: normalizing_prems ctxt concl0)] + end) + end + else if rule = veriT_tmp_ite_elim_rule then + [standard_step Lemma] + else + [standard_step Plain] + end + in + maps steps_of proof + end + +end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/verit_proof.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/SMT2/verit_proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,334 @@ +(* Title: HOL/Tools/SMT2/verit_proof.ML + Author: Mathias Fleury, ENS Rennes + Author: Sascha Boehme, TU Muenchen + +VeriT proofs: parsing and abstract syntax tree. +*) + +signature VERIT_PROOF = +sig + (*proofs*) + datatype veriT_step = VeriT_Step of { + id: string, + rule: string, + prems: string list, + concl: term, + fixes: string list} + + (*proof parser*) + val parse: typ Symtab.table -> term Symtab.table -> string list -> + Proof.context -> veriT_step list * Proof.context + + val veriT_step_prefix : string + val veriT_input_rule: string + val veriT_la_generic_rule : string + val veriT_rewrite_rule : string + val veriT_simp_arith_rule : string + val veriT_tmp_ite_elim_rule : string + val veriT_tmp_skolemize_rule : string +end; + +structure VeriT_Proof: VERIT_PROOF = +struct + +open SMTLIB2_Proof + +datatype veriT_node = VeriT_Node of { + id: string, + rule: string, + prems: string list, + concl: term, + bounds: string list} + +fun mk_node id rule prems concl bounds = + VeriT_Node {id = id, rule = rule, prems = prems, concl = concl, bounds = bounds} + +datatype veriT_step = VeriT_Step of { + id: string, + rule: string, + prems: string list, + concl: term, + fixes: string list} + +fun mk_step id rule prems concl fixes = + VeriT_Step {id = id, rule = rule, prems = prems, concl = concl, fixes = fixes} + +val veriT_step_prefix = ".c" +val veriT_alpha_conv_rule = "tmp_alphaconv" +val veriT_input_rule = "input" +val veriT_la_generic_rule = "la_generic" +val veriT_rewrite_rule = "__rewrite" (* arbitrary *) +val veriT_simp_arith_rule = "simp_arith" +val veriT_tmp_ite_elim_rule = "tmp_ite_elim" +val veriT_tmp_skolemize_rule = "tmp_skolemize" + +(* proof parser *) + +fun node_of p cx = + ([], cx) + ||>> `(with_fresh_names (term_of p)) + |>> snd + +(*in order to get Z3-style quantification*) +fun repair_quantification (SMTLIB2.S (SMTLIB2.Sym "forall" :: l)) = + let val (quantified_vars, t) = split_last (map repair_quantification l) + in + SMTLIB2.S (SMTLIB2.Sym "forall" :: SMTLIB2.S quantified_vars :: t :: []) + end + | repair_quantification (SMTLIB2.S (SMTLIB2.Sym "exists" :: l)) = + let val (quantified_vars, t) = split_last (map repair_quantification l) + in + SMTLIB2.S (SMTLIB2.Sym "exists" :: SMTLIB2.S quantified_vars :: t :: []) + end + | repair_quantification (SMTLIB2.S l) = SMTLIB2.S (map repair_quantification l) + | repair_quantification x = x + +fun replace_bound_var_by_free_var (q $ Abs (var, ty, u)) free_var = + (case List.find (fn v => String.isPrefix v var) free_var of + NONE => q $ Abs (var, ty, replace_bound_var_by_free_var u free_var) + | SOME _ => replace_bound_var_by_free_var (Term.subst_bound (Free (var, ty), u)) free_var) + | replace_bound_var_by_free_var (u $ v) free_vars = replace_bound_var_by_free_var u free_vars $ + replace_bound_var_by_free_var v free_vars + | replace_bound_var_by_free_var u _ = u + +fun find_type_in_formula (Abs(v, ty, u)) var_name = + if String.isPrefix var_name v then SOME ty else find_type_in_formula u var_name + | find_type_in_formula (u $ v) var_name = + (case find_type_in_formula u var_name of + NONE => find_type_in_formula v var_name + | a => a) + | find_type_in_formula _ _ = NONE + +fun add_bound_variables_to_ctxt cx bounds concl = + fold (fn a => fn b => update_binding a b) + (map (fn s => ((s, Term (Free (s, the_default dummyT (find_type_in_formula concl s)))))) + bounds) cx + +fun update_step_and_cx (st as VeriT_Node {id, rule, prems, concl, bounds}) cx = + if rule = veriT_tmp_ite_elim_rule then + (mk_node id rule prems concl bounds, add_bound_variables_to_ctxt cx bounds concl) + else if rule = veriT_tmp_skolemize_rule then + let + val concl' = replace_bound_var_by_free_var concl bounds + in + (mk_node id rule prems concl' [], add_bound_variables_to_ctxt cx bounds concl) + end + else + (st, cx) + +(*FIXME: using a reference would be better to know th numbers of the steps to add*) +fun fix_subproof_steps ((((id_of_father_step, rule), prems), subproof), ((step_concl, bounds), + cx)) = + let + fun mk_prop_of_term concl = (fastype_of concl = @{typ "bool"} ? + curry (op $) @{term "Trueprop"}) concl + fun inline_assumption assumption assumption_id (st as VeriT_Node {id, rule, prems, concl, + bounds}) = + if List.find (curry (op =) assumption_id) prems <> NONE then + let + val prems' = filter_out (curry (op =) assumption_id) prems + in + mk_node id rule (filter_out (curry (op =) assumption_id) prems') + (Const (@{const_name "Pure.imp"}, @{typ "prop"} --> @{typ "prop"} --> @{typ "prop"}) + $ mk_prop_of_term assumption $ mk_prop_of_term concl) bounds + end + else + st + fun find_input_steps_and_inline [] last_step = ([], last_step) + | find_input_steps_and_inline (VeriT_Node {id = id', rule, prems, concl, bounds} :: steps) + last_step = + if rule = veriT_input_rule then + find_input_steps_and_inline (map (inline_assumption concl id') steps) last_step + else + apfst (cons (mk_node (id_of_father_step ^ id') rule prems concl bounds)) + (find_input_steps_and_inline steps (id_of_father_step ^ id')) + val (subproof', last_step_id) = find_input_steps_and_inline subproof "" + val prems' = + if last_step_id = "" then prems + else + (case prems of + NONE => SOME [last_step_id] + | SOME l => SOME (last_step_id :: l)) + in + (subproof', (((((id_of_father_step, rule), prems'), step_concl), bounds), cx)) + end + +(* +(set id rule :clauses(...) :args(..) :conclusion (...)). +or +(set id subproof (set ...) :conclusion (...)). +*) + +fun parse_proof_step cx = + let + fun rotate_pair (a, (b, c)) = ((a, b), c) + fun get_id (SMTLIB2.S [SMTLIB2.Sym "set", SMTLIB2.Sym id, SMTLIB2.S l]) = (id, l) + | get_id t = raise Fail ("unrecognized VeriT Proof" ^ PolyML.makestring t) + fun parse_rule (SMTLIB2.Sym rule :: l) = (rule, l) + fun parse_source (SMTLIB2.Key "clauses" :: SMTLIB2.S source ::l) = + (SOME (map (fn (SMTLIB2.Sym id) => id) source), l) + | parse_source l = (NONE, l) + fun parse_subproof cx id_of_father_step ((subproof_step as SMTLIB2.S (SMTLIB2.Sym "set" :: _)) :: l) = + let val (subproof_steps, cx') = parse_proof_step cx subproof_step in + apfst (apfst (curry (op @) subproof_steps)) (parse_subproof cx' id_of_father_step l) + end + | parse_subproof cx _ l = (([], cx), l) + fun skip_args (SMTLIB2.Key "args" :: SMTLIB2.S _ :: l) = l + | skip_args l = l + fun parse_conclusion (SMTLIB2.Key "conclusion" :: SMTLIB2.S concl :: []) = concl + fun make_or_from_clausification l = + foldl1 (fn ((concl1, bounds1), (concl2, bounds2)) => + (HOLogic.mk_disj (perhaps (try HOLogic.dest_Trueprop) concl1, + perhaps (try HOLogic.dest_Trueprop) concl2), bounds1 @ bounds2)) l + fun to_node (((((id, rule), prems), concl), bounds), cx) = (mk_node id rule + (the_default [] prems) concl bounds, cx) + in + get_id + ##> parse_rule + #> rotate_pair + ##> parse_source + #> rotate_pair + ##> skip_args + #> (fn (((id, rule), prems), sub) => (((id, rule), prems), parse_subproof cx id sub)) + #> rotate_pair + ##> parse_conclusion + ##> map repair_quantification + #> (fn ((((id, rule), prems), (subproof, cx)), terms) => + (((((id, rule), prems), subproof), fold_map (fn t => fn cx => node_of t cx) terms cx))) + ##> apfst (fn [] => (@{const False}, []) | concls => make_or_from_clausification concls) + #> fix_subproof_steps + ##> to_node + #> (fn (subproof, (step, cx)) => (subproof @ [step], cx)) + #-> fold_map update_step_and_cx + end + +(*subproofs are written on multiple lines: SMTLIB can not parse then, because parentheses are +unbalanced on each line*) +fun seperate_into_steps lines = + let + fun count ("(" :: l) n = count l (n+1) + | count (")" :: l) n = count l (n-1) + | count (_ :: l) n = count l n + | count [] n = n + fun seperate (line :: l) actual_lines m = + let val n = count (raw_explode line) 0 in + if m + n = 0 then + [actual_lines ^ line] :: seperate l "" 0 + else seperate l (actual_lines ^ line) (m + n) + end + | seperate [] _ 0 = [] + in + seperate lines "" 0 + end + + (* VeriT adds @ before every variable. *) +fun remove_all_at (SMTLIB2.Sym v :: l) = SMTLIB2.Sym (perhaps (try (unprefix "@")) v) :: remove_all_at l + | remove_all_at (SMTLIB2.S l :: l') = SMTLIB2.S (remove_all_at l) :: remove_all_at l' + | remove_all_at (SMTLIB2.Key v :: l) = SMTLIB2.Key v :: remove_all_at l + | remove_all_at (v :: l) = v :: remove_all_at l + | remove_all_at [] = [] + +fun find_in_which_step_defined var (VeriT_Node {id, bounds, ...} :: l) = + (case List.find (fn v => String.isPrefix v var) bounds of + NONE => find_in_which_step_defined var l + | SOME _ => id) + | find_in_which_step_defined var _ = raise Fail ("undefined " ^ var) + +(*Yes every case is possible: the introduced var is not on a special size of the equality sign.*) +fun find_ite_var_in_term (Const ("HOL.If", _) $ _ $ + (Const (@{const_name "HOL.eq"}, _) $ Free (var1, _) $ Free (var2, _) ) $ + (Const (@{const_name "HOL.eq"}, _) $ Free (var3, _) $ Free (var4, _) )) = + let + fun get_number_of_ite_transformed_var var = + perhaps (try (unprefix "ite")) var + |> Int.fromString + fun is_equal_and_has_correct_substring var var' var'' = + if var = var' andalso String.isPrefix "ite" var then SOME var' + else if var = var'' andalso String.isPrefix "ite" var then SOME var'' else NONE + val var1_introduced_var = is_equal_and_has_correct_substring var1 var3 var4 + val var2_introduced_var = is_equal_and_has_correct_substring var3 var1 var2 + in + (case (var1_introduced_var, var2_introduced_var) of + (SOME a, SOME b) => + (*ill-generated case, might be possible when applying the rule to max a a. Only if the + variable have been introduced before. Probably an impossible edge case*) + (case (get_number_of_ite_transformed_var a, get_number_of_ite_transformed_var b) of + (SOME a, SOME b) => if a < b then var2_introduced_var else var1_introduced_var + (*Otherwise, it is a name clase between a parameter name and the introduced variable. + Or the name convention has been changed.*) + | (NONE, SOME _) => var2_introduced_var + | (SOME _, NONE) => var2_introduced_var) + | (_, SOME _) => var2_introduced_var + | (SOME _, _) => var1_introduced_var) + end + | find_ite_var_in_term (Const (@{const_name "If"}, _) $ _ $ + (Const (@{const_name "HOL.eq"}, _) $ Free (var, _) $ _ ) $ + (Const (@{const_name "HOL.eq"}, _) $ Free (var', _) $ _ )) = + if var = var' then SOME var else NONE + | find_ite_var_in_term (Const (@{const_name "If"}, _) $ _ $ + (Const (@{const_name "HOL.eq"}, _) $ _ $ Free (var, _)) $ + (Const (@{const_name "HOL.eq"}, _) $ _ $ Free (var', _))) = + if var = var' then SOME var else NONE + | find_ite_var_in_term (p $ q) = + (case find_ite_var_in_term p of + NONE => find_ite_var_in_term q + | x => x) + | find_ite_var_in_term (Abs (_, _, body)) = find_ite_var_in_term body + | find_ite_var_in_term _ = NONE + +fun correct_veriT_step steps (st as VeriT_Node {id, rule, prems, concl, bounds}) = + if rule = veriT_tmp_ite_elim_rule then + if bounds = [] then + (*if the introduced var has already been defined, adding the definition as a dependency*) + let + val new_prems = + (case find_ite_var_in_term concl of + NONE => prems + | SOME var => find_in_which_step_defined var steps :: prems) + in + VeriT_Node {id = id, rule = rule, prems = new_prems, concl = concl, bounds = bounds} + end + else + (*some new variables are created*) + let + val concl' = replace_bound_var_by_free_var concl bounds + in + mk_node id rule prems concl' [] + end + else + st + +fun remove_alpha_conversion _ [] = [] + | remove_alpha_conversion replace_table (VeriT_Node {id, rule, prems, concl, bounds} :: steps) = + let + fun correct_dependency prems = + map (fn x => perhaps (Symtab.lookup replace_table) x) prems + fun find_predecessor prem = perhaps (Symtab.lookup replace_table) prem + in + if rule = veriT_alpha_conv_rule then + remove_alpha_conversion (Symtab.update (id, find_predecessor (hd prems)) + replace_table) steps + else + VeriT_Node {id = id, rule = rule, prems = correct_dependency prems, + concl = concl, bounds = bounds} :: remove_alpha_conversion replace_table steps + end + +fun correct_veriT_steps steps = + steps + |> map (correct_veriT_step steps) + |> remove_alpha_conversion Symtab.empty + +fun parse typs funs lines ctxt = + let + val smtlib2_lines_without_at = + remove_all_at (map SMTLIB2.parse (seperate_into_steps lines)) + val (u, env) = apfst flat (fold_map (fn l => fn cx => parse_proof_step cx l) + smtlib2_lines_without_at (empty_context ctxt typs funs)) + val t = correct_veriT_steps u + fun node_to_step (VeriT_Node {id, rule, prems, concl, bounds, ...}) = + mk_step id rule prems concl bounds + in + (map node_to_step t, ctxt_of env) + end + +end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/verit_proof_parse.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/SMT2/verit_proof_parse.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,104 @@ +(* Title: HOL/Tools/SMT2/verit_proof_parse.ML + Author: Mathias Fleury, TU Muenchen + Author: Jasmin Blanchette, TU Muenchen + +VeriT proof parsing. +*) + +signature VERIT_PROOF_PARSE = +sig + type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step + val parse_proof: Proof.context -> SMT2_Translate.replay_data -> + ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list -> + SMT2_Solver.parsed_proof +end; + +structure VeriT_Proof_Parse: VERIT_PROOF_PARSE = +struct + +open ATP_Util +open ATP_Problem +open ATP_Proof +open ATP_Proof_Reconstruct +open VeriT_Isar +open VeriT_Proof + +fun find_and_add_missing_dependances steps assms ll_offset = + let + fun prems_to_theorem_number [] id repl = (([], []), (id, repl)) + | prems_to_theorem_number (x :: ths) id replaced = + (case Int.fromString (perhaps (try (unprefix SMTLIB2_Interface.assert_prefix)) x) of + NONE => + let + val ((prems, iidths), (id', replaced')) = prems_to_theorem_number ths id replaced + in + ((x :: prems, iidths), (id', replaced')) + end + | SOME th => + (case Option.map snd (List.find (fst #> curry (op =) x) replaced) of + NONE => + let + val id' = if th = ll_offset then 0 else id - ll_offset (* 0: for the conjecture*) + val ((prems, iidths), (id'', replaced')) = + prems_to_theorem_number ths (if th <> ll_offset then id + 1 else id) + ((x, string_of_int id') :: replaced) + in + ((string_of_int id' :: prems, (th, (id', th - ll_offset)) :: iidths), + (id'', replaced')) + end + | SOME x => + let + val ((prems, iidths), (id', replaced')) = prems_to_theorem_number ths id replaced + in ((x :: prems, iidths), (id', replaced')) end)) + fun update_step (VeriT_Proof.VeriT_Step {prems, id = id0, rule = rule0, + concl = concl0, fixes = fixes0}) (id, replaced) = + let val ((prems', iidths), (id', replaced)) = prems_to_theorem_number prems id replaced + in + ((VeriT_Proof.VeriT_Step {id = id0, rule = rule0, prems = prems', concl = concl0, + fixes = fixes0}, iidths), (id', replaced)) + end + in + fold_map update_step steps (1, []) + |> fst + |> `(map snd) + ||> (map fst) + |>> flat + |>> map (fn (_, (id, tm_id)) => let val (i, tm) = nth assms tm_id in (i, (id, tm)) end) + end + +fun add_missing_steps iidths = + let + fun add_single_step (_, (id, th)) = VeriT_Proof.VeriT_Step {id = string_of_int id, + rule = veriT_input_rule, prems = [], concl = prop_of th, fixes = []} + in map add_single_step iidths end + +fun parse_proof _ + ({context = ctxt, typs, terms, ll_defs, rewrite_rules, assms} : SMT2_Translate.replay_data) + xfacts prems concl output = + let + val (steps, _) = VeriT_Proof.parse typs terms output ctxt + val (iidths, steps'') = find_and_add_missing_dependances steps assms (length ll_defs) + val steps' = add_missing_steps iidths @ steps'' + fun id_of_index i = the_default ~1 (Option.map fst (AList.lookup (op =) iidths i)) + + val prems_i = 1 + val facts_i = prems_i + length prems + val conjecture_i = 0 + val ll_offset = id_of_index conjecture_i + val prem_ids = map id_of_index (prems_i upto facts_i - 1) + val helper_ids = map_filter (try (fn (~1, idth) => idth)) iidths + + val fact_ids = map_filter (fn (i, (id, _)) => + (try (apsnd (nth xfacts)) (id, i - facts_i))) iidths + val fact_helper_ts = + map (fn (_, th) => (ATP_Util.short_thm_name ctxt th, prop_of th)) helper_ids @ + map (fn (_, ((s, _), th)) => (s, prop_of th)) fact_ids + val fact_helper_ids = + map (apsnd (ATP_Util.short_thm_name ctxt)) helper_ids @ map (apsnd (fst o fst)) fact_ids + in + {outcome = NONE, fact_ids = fact_ids, + atp_proof = fn () => atp_proof_of_veriT_proof ctxt ll_defs rewrite_rules prems concl + fact_helper_ts prem_ids ll_offset fact_helper_ids steps'} + end + +end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/z3_new_isar.ML --- a/src/HOL/Tools/SMT2/z3_new_isar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/z3_new_isar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -18,6 +18,7 @@ open ATP_Problem open ATP_Proof open ATP_Proof_Reconstruct +open SMTLIB2_Isar val z3_apply_def_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Apply_Def val z3_hypothesis_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Hypothesis @@ -62,104 +63,49 @@ end end -fun simplify_bool ((all as Const (@{const_name All}, _)) $ Abs (s, T, t)) = - let val t' = simplify_bool t in - if loose_bvar1 (t', 0) then all $ Abs (s, T, t') else t' +fun dest_alls (Const (@{const_name Pure.all}, _) $ Abs (abs as (_, T, _))) = + let val (s', t') = Term.dest_abs abs in + dest_alls t' |>> cons (s', T) end - | simplify_bool (@{const Not} $ t) = s_not (simplify_bool t) - | simplify_bool (@{const conj} $ t $ u) = s_conj (simplify_bool t, simplify_bool u) - | simplify_bool (@{const disj} $ t $ u) = s_disj (simplify_bool t, simplify_bool u) - | simplify_bool (@{const implies} $ t $ u) = s_imp (simplify_bool t, simplify_bool u) - | simplify_bool (@{const HOL.eq (bool)} $ t $ u) = s_iff (simplify_bool t, simplify_bool u) - | simplify_bool (t as Const (@{const_name HOL.eq}, _) $ u $ v) = - if u aconv v then @{const True} else t - | simplify_bool (t $ u) = simplify_bool t $ simplify_bool u - | simplify_bool (Abs (s, T, t)) = Abs (s, T, simplify_bool t) - | simplify_bool t = t - -(* It is not entirely clear why this should be necessary, especially for abstractions variables. *) -val unskolemize_names = - Term.map_abs_vars (perhaps (try Name.dest_skolem)) - #> Term.map_aterms (perhaps (try (fn Free (s, T) => Free (Name.dest_skolem s, T)))) + | dest_alls t = ([], t) -fun strip_alls (Const (@{const_name All}, _) $ Abs (s, T, body)) = strip_alls body |>> cons (s, T) - | strip_alls t = ([], t) - -fun push_skolem_all_under_iff t = - (case strip_alls t of - (qs as _ :: _, - (t0 as Const (@{const_name HOL.eq}, _)) $ (t1 as Const (@{const_name Ex}, _) $ _) $ t2) => - t0 $ HOLogic.list_all (qs, t1) $ HOLogic.list_all (qs, t2) - | _ => t) - -fun unlift_term ll_defs = - let - val lifted = map (ATP_Util.extract_lambda_def dest_Free o ATP_Util.hol_open_form I) ll_defs - - fun un_free (t as Free (s, _)) = - (case AList.lookup (op =) lifted s of - SOME t => un_term t - | NONE => t) - | un_free t = t - and un_term t = map_aterms un_free t - in un_term end +val reorder_foralls = + dest_alls + #>> sort_wrt fst + #-> fold_rev (Logic.all o Free); fun atp_proof_of_z3_proof ctxt ll_defs rewrite_rules hyp_ts concl_t fact_helper_ts prem_ids conjecture_id fact_helper_ids proof = let val thy = Proof_Context.theory_of ctxt - val unlift_term = unlift_term ll_defs - fun steps_of (Z3_New_Proof.Z3_Step {id, rule, prems, concl, ...}) = let val sid = string_of_int id - val concl' = - concl - |> Raw_Simplifier.rewrite_term thy rewrite_rules [] - |> Object_Logic.atomize_term thy - |> simplify_bool - |> not (null ll_defs) ? unlift_term - |> unskolemize_names - |> push_skolem_all_under_iff - |> HOLogic.mk_Trueprop - + val concl' = concl + |> reorder_foralls (* crucial for skolemization steps *) + |> postprocess_step_conclusion thy rewrite_rules ll_defs fun standard_step role = ((sid, []), role, concl', Z3_New_Proof.string_of_rule rule, map (fn id => (string_of_int id, [])) prems) in (case rule of Z3_New_Proof.Asserted => - let - val ss = the_list (AList.lookup (op =) fact_helper_ids id) - val name0 = (sid ^ "a", ss) - - val (role0, concl0) = - (case ss of - [s] => (Axiom, the (AList.lookup (op =) fact_helper_ts s)) - | _ => - if id = conjecture_id then - (Conjecture, concl_t) - else - (Hypothesis, - (case find_index (curry (op =) id) prem_ids of - ~1 => concl - | i => nth hyp_ts i))) - - val normalize_prems = - SMT2_Normalize.case_bool_entry :: SMT2_Normalize.special_quant_table @ - SMT2_Normalize.abs_min_max_table - |> map_filter (fn (c, th) => - if exists_Const (curry (op =) c o fst) concl0 then - let val s = short_thm_name ctxt th in SOME (s, [s]) end - else - NONE) - in - (if role0 = Axiom then [] - else [(name0, role0, concl0, Z3_New_Proof.string_of_rule rule, [])]) @ - [((sid, []), Plain, concl', Z3_New_Proof.string_of_rule Z3_New_Proof.Rewrite, - name0 :: normalize_prems)] + let val ss = the_list (AList.lookup (op =) fact_helper_ids id) in + (case distinguish_conjecture_and_hypothesis ss id conjecture_id prem_ids fact_helper_ts + hyp_ts concl_t of + NONE => [] + | SOME (role0, concl00) => + let + val name0 = (sid ^ "a", ss) + val concl0 = unskolemize_names concl00 + in + (if role0 = Axiom then [] + else [(name0, role0, concl0, Z3_New_Proof.string_of_rule rule, [])]) @ + [((sid, []), Plain, concl', Z3_New_Proof.string_of_rule Z3_New_Proof.Rewrite, + name0 :: normalizing_prems ctxt concl0)] + end) end | Z3_New_Proof.Rewrite => [standard_step Lemma] | Z3_New_Proof.Rewrite_Star => [standard_step Lemma] diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/SMT2/z3_new_proof.ML --- a/src/HOL/Tools/SMT2/z3_new_proof.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/SMT2/z3_new_proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -7,14 +7,14 @@ signature Z3_NEW_PROOF = sig (*proof rules*) - datatype z3_rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | - Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro | - Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star | - Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | - Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution | - Iff_True | Iff_False | Commutativity | Def_Axiom | Intro_Def | Apply_Def | - Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize | - Modus_Ponens_Oeq | Th_Lemma of string + datatype z3_rule = + True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | Symmetry | Transitivity | + Transitivity_Star | Monotonicity | Quant_Intro | Distributivity | And_Elim | Not_Or_Elim | + Rewrite | Rewrite_Star | Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | + Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False | + Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star | + Cnf_Star | Skolemize | Modus_Ponens_Oeq | Th_Lemma of string + val is_assumption: z3_rule -> bool val string_of_rule: z3_rule -> string @@ -40,16 +40,14 @@ (* proof rules *) -datatype z3_rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | - Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro | - Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star | - Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | Dest_Eq_Res | - Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False | - Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos | - Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize | Modus_Ponens_Oeq | - Th_Lemma of string - (* TODO: some proof rules come with further information - that is currently dropped by the parser *) +datatype z3_rule = + True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | Symmetry | Transitivity | + Transitivity_Star | Monotonicity | Quant_Intro | Distributivity | And_Elim | Not_Or_Elim | + Rewrite | Rewrite_Star | Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | + Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False | + Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star | + Cnf_Star | Skolemize | Modus_Ponens_Oeq | Th_Lemma of string + (* some proof rules include further information that is currently dropped by the parser *) val rule_names = Symtab.make [ ("true-axiom", True_Axiom), @@ -102,7 +100,7 @@ SOME rule => rule | NONE => error ("unknown Z3 proof rule " ^ quote name)) -fun string_of_rule (Th_Lemma kind) = "th-lemma " ^ kind +fun string_of_rule (Th_Lemma kind) = "th-lemma" ^ (if kind = "" then "" else " " ^ kind) | string_of_rule r = let fun eq_rule (s, r') = if r = r' then SOME s else NONE in the (Symtab.get_first eq_rule rule_names) end @@ -118,7 +116,7 @@ bounds: string list} fun mk_node id rule prems concl bounds = - Z3_Node {id=id, rule=rule, prems=prems, concl=concl, bounds=bounds} + Z3_Node {id = id, rule = rule, prems = prems, concl = concl, bounds = bounds} datatype z3_step = Z3_Step of { id: int, @@ -129,8 +127,8 @@ is_fix_step: bool} fun mk_step id rule prems concl fixes is_fix_step = - Z3_Step {id=id, rule=rule, prems=prems, concl=concl, fixes=fixes, - is_fix_step=is_fix_step} + Z3_Step {id = id, rule = rule, prems = prems, concl = concl, fixes = fixes, + is_fix_step = is_fix_step} (* proof parser *) @@ -161,7 +159,7 @@ in cx |> fold_map node_of ps - ||>> with_fresh_names (term_of p) + ||>> `(with_fresh_names (term_of p)) ||>> next_id |>> (fn ((prems, (t, ns)), id) => mk_node id r prems t ns) end @@ -188,10 +186,8 @@ val ts = dest_seq (SMTLIB2.parse lines) val (node, cx) = parse' ts (empty_context ctxt typs funs) in (node, ctxt_of cx) end - handle SMTLIB2.PARSE (l, msg) => - error ("parsing error at line " ^ string_of_int l ^ ": " ^ msg) - | SMTLIB2_PARSE (msg, t) => - error (msg ^ ": " ^ SMTLIB2.str_of t) + handle SMTLIB2.PARSE (l, msg) => error ("parsing error at line " ^ string_of_int l ^ ": " ^ msg) + | SMTLIB2_PARSE (msg, t) => error (msg ^ ": " ^ SMTLIB2.str_of t) (* handling of bound variables *) @@ -253,7 +249,7 @@ fun dest_alls t = dest_all (Term.maxidx_of_term t + 1) t -fun match_rule ctxt env (Z3_Node {bounds=bs', concl=t', ...}) bs t = +fun match_rule ctxt env (Z3_Node {bounds = bs', concl = t', ...}) bs t = let val t'' = singleton (Variable.polymorphic ctxt) t' val (i, obj) = dest_alls (subst_types ctxt env bs t) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer.ML Wed Aug 27 15:52:58 2014 +0200 @@ -10,7 +10,8 @@ sig type fact = Sledgehammer_Fact.fact type fact_override = Sledgehammer_Fact.fact_override - type minimize_command = Sledgehammer_Proof_Methods.minimize_command + type proof_method = Sledgehammer_Proof_Methods.proof_method + type play_outcome = Sledgehammer_Proof_Methods.play_outcome type mode = Sledgehammer_Prover.mode type params = Sledgehammer_Prover.params @@ -19,10 +20,11 @@ val timeoutN : string val unknownN : string + val play_one_line_proof : bool -> Time.time -> (string * 'a) list -> Proof.state -> int -> + proof_method * proof_method list list -> (string * 'a) list * (proof_method * play_outcome) val string_of_factss : (string * fact list) list -> string val run_sledgehammer : params -> mode -> (string -> unit) option -> int -> fact_override -> - ((string * string list) list -> string -> minimize_command) -> Proof.state -> - bool * (string * Proof.state) + Proof.state -> bool * (string * Proof.state) end; structure Sledgehammer : SLEDGEHAMMER = @@ -34,6 +36,9 @@ open Sledgehammer_Util open Sledgehammer_Fact open Sledgehammer_Proof_Methods +open Sledgehammer_Isar_Proof +open Sledgehammer_Isar_Preplay +open Sledgehammer_Isar_Minimize open Sledgehammer_Prover open Sledgehammer_Prover_ATP open Sledgehammer_Prover_Minimize @@ -49,17 +54,61 @@ fun max_outcome_code codes = NONE |> fold (fn candidate => - fn accum as SOME _ => accum - | NONE => if member (op =) codes candidate then SOME candidate else NONE) - ordered_outcome_codes + fn accum as SOME _ => accum + | NONE => if member (op =) codes candidate then SOME candidate else NONE) + ordered_outcome_codes |> the_default unknownN fun prover_description verbose name num_facts = (quote name, if verbose then " with " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts else "") -fun launch_prover (params as {debug, verbose, spy, blocking, max_facts, timeout, expect, ...}) mode - output_result minimize_command only learn +fun is_metis_method (Metis_Method _) = true + | is_metis_method _ = false + +fun play_one_line_proof minimize timeout used_facts state i (preferred_meth, methss) = + if timeout = Time.zeroTime then + (used_facts, (preferred_meth, Play_Timed_Out Time.zeroTime)) + else + let + val fact_names = map fst used_facts + + val {context = ctxt, facts = chained, goal} = Proof.goal state + val (_, hyp_ts, concl_t) = strip_subgoal goal i ctxt + val goal_t = Logic.list_implies (map prop_of chained @ hyp_ts, concl_t) + + fun try_methss ress [] = + (used_facts, + (case AList.lookup (op =) ress preferred_meth of + SOME play => (preferred_meth, play) + | NONE => hd (sort (play_outcome_ord o pairself snd) (rev ress)))) + | try_methss ress (meths :: methss) = + let + fun mk_step fact_names meths = + Prove ([], [], ("", 0), goal_t, [], ([], fact_names), meths, "") + in + (case preplay_isar_step ctxt timeout [] (mk_step fact_names meths) of + (res as (meth, Played time)) :: _ => + (* if a fact is needed by an ATP, it will be needed by "metis" *) + if not minimize orelse is_metis_method meth then + (used_facts, res) + else + let + val (time', used_names') = + minimized_isar_step ctxt time (mk_step fact_names [meth]) + ||> (facts_of_isar_step #> snd) + val used_facts' = filter (member (op =) used_names' o fst) used_facts + in + (used_facts', (meth, Played time')) + end + | ress' => try_methss (ress' @ ress) methss) + end + in + try_methss [] methss + end + +fun launch_prover (params as {debug, verbose, spy, blocking, max_facts, minimize, timeout, + preplay_timeout, expect, ...}) mode output_result only learn {comment, state, goal, subgoal, subgoal_count, factss as (_, facts) :: _} name = let val ctxt = Proof.context_of state @@ -75,10 +124,9 @@ {comment = comment, state = state, goal = goal, subgoal = subgoal, subgoal_count = subgoal_count, factss = factss - |> map (apsnd ((not (is_ho_atp ctxt name) - ? filter_out (fn ((_, (_, Induction)), _) => true - | _ => false)) - #> take num_facts))} + |> map (apsnd ((not (is_ho_atp ctxt name) + ? filter_out (fn ((_, (_, Induction)), _) => true | _ => false)) + #> take num_facts))} fun print_used_facts used_facts used_from = tag_list 1 used_from @@ -115,8 +163,8 @@ |> AList.group (op =) |> map (fn (indices, fact_filters) => commas fact_filters ^ ": " ^ indices) in - "Success: Found proof with " ^ string_of_int num_used_facts ^ - " of " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts ^ + "Success: Found proof with " ^ string_of_int num_used_facts ^ " of " ^ + string_of_int num_facts ^ " fact" ^ plural_s num_facts ^ (if num_used_facts = 0 then "" else ": " ^ commas filter_infos) end | spying_str_of_res {outcome = SOME failure, ...} = @@ -124,16 +172,17 @@ fun really_go () = problem - |> get_minimizing_prover ctxt mode learn name params minimize_command - |> verbose - ? tap (fn {outcome = NONE, used_facts as _ :: _, used_from, ...} => - print_used_facts used_facts used_from - | _ => ()) + |> get_minimizing_prover ctxt mode learn name params + |> verbose ? tap (fn {outcome = NONE, used_facts as _ :: _, used_from, ...} => + print_used_facts used_facts used_from + | _ => ()) |> spy ? tap (fn res => spying spy (fn () => (state, subgoal, name, spying_str_of_res res))) - |> (fn {outcome, preplay, message, message_tail, ...} => - (if outcome = SOME ATP_Proof.TimedOut then timeoutN - else if is_some outcome then noneN - else someN, fn () => message (Lazy.force preplay) ^ message_tail)) + |> (fn {outcome, used_facts, preferred_methss, message, ...} => + (if outcome = SOME ATP_Proof.TimedOut then timeoutN + else if is_some outcome then noneN + else someN, + fn () => message (fn () => play_one_line_proof minimize preplay_timeout used_facts state + subgoal preferred_methss))) fun go () = let @@ -203,7 +252,7 @@ (if filter = "" then "" else quote filter ^ ": ") ^ string_of_facts facts) factss) fun run_sledgehammer (params as {verbose, spy, blocking, provers, max_facts, ...}) mode - output_result i (fact_override as {only, ...}) minimize_command state = + output_result i (fact_override as {only, ...}) state = if null provers then error "No prover is set." else @@ -260,7 +309,7 @@ {comment = "", state = state, goal = goal, subgoal = i, subgoal_count = n, factss = factss} val learn = mash_learn_proof ctxt params (prop_of goal) all_facts - val launch = launch_prover params mode output_result minimize_command only learn + val launch = launch_prover params mode output_result only learn in if mode = Auto_Try then (unknownN, state) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_commands.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_commands.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_commands.ML Wed Aug 27 15:52:58 2014 +0200 @@ -31,7 +31,6 @@ val z3N = "z3" val runN = "run" -val minN = "min" val messagesN = "messages" val supported_proversN = "supported_provers" val kill_allN = "kill_all" @@ -92,17 +91,17 @@ ("max_mono_iters", "smart"), ("max_new_mono_instances", "smart"), ("isar_proofs", "smart"), - ("compress", "10"), + ("compress", "smart"), ("try0", "true"), ("smt_proofs", "smart"), ("slice", "true"), - ("minimize", "smart"), - ("preplay_timeout", "2")] + ("minimize", "true"), + ("preplay_timeout", "1")] val alias_params = [("prover", ("provers", [])), (* undocumented *) ("dont_preplay", ("preplay_timeout", ["0"])), - ("dont_compress", ("compress", ["0"])), + ("dont_compress", ("compress", ["1"])), ("isar_proof", ("isar_proofs", [])) (* legacy *)] val negated_alias_params = [("no_debug", "debug"), @@ -119,9 +118,6 @@ ("dont_try0", "try0"), ("no_smt_proofs", "smt_proofs")] -val params_not_for_minimize = - ["provers", "blocking", "fact_filter", "max_facts", "fact_thresholds", "slice", "minimize"]; - val property_dependent_params = ["provers", "timeout"] fun is_known_raw_param s = @@ -295,11 +291,11 @@ val max_new_mono_instances = lookup_option lookup_int "max_new_mono_instances" val isar_proofs = lookup_option lookup_bool "isar_proofs" - val compress = Real.max (1.0, lookup_real "compress") + val compress = Option.map (curry Real.max 1.0) (lookup_option lookup_real "compress") val try0 = lookup_bool "try0" val smt_proofs = lookup_option lookup_bool "smt_proofs" val slice = mode <> Auto_Try andalso lookup_bool "slice" - val minimize = if mode = Auto_Try then NONE else lookup_option lookup_bool "minimize" + val minimize = mode <> Auto_Try andalso lookup_bool "minimize" val timeout = lookup_time "timeout" val preplay_timeout = if mode = Auto_Try then Time.zeroTime else lookup_time "preplay_timeout" val expect = lookup_string "expect" @@ -318,33 +314,6 @@ (* Sledgehammer the given subgoal *) -val default_minimize_prover = metisN - -fun is_raw_param_relevant_for_minimize (name, _) = not (member (op =) params_not_for_minimize name) - -fun string_of_raw_param (key, values) = - key ^ (case implode_param values of "" => "" | value => " = " ^ value) - -fun nice_string_of_raw_param (p as (key, ["false"])) = - (case AList.find (op =) negated_alias_params key of - [neg] => neg - | _ => string_of_raw_param p) - | nice_string_of_raw_param p = string_of_raw_param p - -fun minimize_command override_params i more_override_params prover_name fact_names = - let - val params = - (override_params |> filter_out (AList.defined (op =) more_override_params o fst)) @ - more_override_params - |> filter is_raw_param_relevant_for_minimize - |> map nice_string_of_raw_param - |> (if prover_name = default_minimize_prover then I else cons prover_name) - |> space_implode ", " - in - sledgehammerN ^ " " ^ minN ^ (if params = "" then "" else enclose " [" "]" params) ^ - " (" ^ space_implode " " fact_names ^ ")" ^ (if i = 1 then "" else " " ^ string_of_int i) - end - val default_learn_prover_timeout = 2.0 fun hammer_away override_params subcommand opt_i fact_override state = @@ -357,20 +326,9 @@ in if subcommand = runN then let val i = the_default 1 opt_i in - run_sledgehammer (get_params Normal thy override_params) Normal NONE i fact_override - (minimize_command override_params i) state - |> K () + ignore (run_sledgehammer (get_params Normal thy override_params) Normal NONE i fact_override + state) end - else if subcommand = minN then - let - val ctxt = ctxt |> Config.put instantiate_inducts false - val i = the_default 1 opt_i - val params = - get_params Minimize thy (("provers", [default_minimize_prover]) :: override_params) - val goal = prop_of (#goal (Proof.goal state)) - val facts = nearly_all_facts ctxt false fact_override Symtab.empty Termtab.empty [] [] goal - val learn = mash_learn_proof ctxt params goal facts - in run_minimize params learn i (#add fact_override) state end else if subcommand = messagesN then messages opt_i else if subcommand = supported_proversN then @@ -391,8 +349,7 @@ ([("timeout", [string_of_real default_learn_prover_timeout]), ("slice", ["false"])] @ override_params @ - [("minimize", ["true"]), - ("preplay_timeout", ["0"])])) + [("preplay_timeout", ["0"])])) fact_override (#facts (Proof.goal state)) (subcommand = learn_proverN orelse subcommand = relearn_proverN)) else if subcommand = running_learnersN then @@ -407,7 +364,8 @@ Toplevel.unknown_proof o Toplevel.keep (hammer_away params subcommand opt_i fact_override o Toplevel.proof_of) -fun string_of_raw_param (name, value) = name ^ " = " ^ implode_param value +fun string_of_raw_param (key, values) = + key ^ (case implode_param values of "" => "" | value => " = " ^ value) fun sledgehammer_params_trans params = Toplevel.theory (fold set_default_raw_param params #> tap (fn thy => @@ -421,7 +379,7 @@ val parse_value = Scan.repeat1 (Parse.xname || Parse.float_number || parse_query_bang) val parse_param = parse_key -- Scan.optional (@{keyword "="} |-- parse_value) [] val parse_params = Scan.optional (Args.bracks (Parse.list parse_param)) [] -val parse_fact_refs = Scan.repeat1 (Scan.unless (Parse.name -- Args.colon) Parse_Spec.xthm) +val parse_fact_refs = Scan.repeat1 (Scan.unless (Parse.name -- Args.colon) Parse.xthm) val parse_fact_override_chunk = (Args.add |-- Args.colon |-- parse_fact_refs >> add_fact_override) || (Args.del |-- Args.colon |-- parse_fact_refs >> del_fact_override) @@ -446,8 +404,7 @@ val mode = if auto then Auto_Try else Try val i = 1 in - run_sledgehammer (get_params mode thy []) mode NONE i no_fact_override (minimize_command [] i) - state + run_sledgehammer (get_params mode thy []) mode NONE i no_fact_override state end val _ = Try.tool_setup (sledgehammerN, (40, @{system_option auto_sledgehammer}, try_sledgehammer)) @@ -456,24 +413,23 @@ Query_Operation.register sledgehammerN (fn {state = st, args, output_result} => (case try Toplevel.proof_of st of SOME state => - let - val thy = Proof.theory_of state - val ctxt = Proof.context_of state - val [provers_arg, isar_proofs_arg] = args + let + val thy = Proof.theory_of state + val ctxt = Proof.context_of state + val [provers_arg, isar_proofs_arg] = args - val override_params = - ((if provers_arg = "" then [] else [("provers", space_explode " " provers_arg)]) @ - [("isar_proofs", [isar_proofs_arg]), - ("blocking", ["true"]), - ("minimize", ["true"]), - ("debug", ["false"]), - ("verbose", ["false"]), - ("overlord", ["false"])]) - |> map (normalize_raw_param ctxt) - - val _ = run_sledgehammer (get_params Normal thy override_params) Normal - (SOME output_result) 1 no_fact_override (minimize_command override_params 1) state - in () end + val override_params = + ((if provers_arg = "" then [] else [("provers", space_explode " " provers_arg)]) @ + [("isar_proofs", [isar_proofs_arg]), + ("blocking", ["true"]), + ("debug", ["false"]), + ("verbose", ["false"]), + ("overlord", ["false"])]) + |> map (normalize_raw_param ctxt) + in + ignore (run_sledgehammer (get_params Normal thy override_params) Normal + (SOME output_result) 1 no_fact_override state) + end | NONE => error "Unknown proof context")) end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML Wed Aug 27 15:52:58 2014 +0200 @@ -14,15 +14,15 @@ type fact = (string * stature) * thm type fact_override = - {add : (Facts.ref * Attrib.src list) list, - del : (Facts.ref * Attrib.src list) list, + {add : (Facts.ref * Token.src list) list, + del : (Facts.ref * Token.src list) list, only : bool} val instantiate_inducts : bool Config.T val no_fact_override : fact_override val fact_of_ref : Proof.context -> unit Symtab.table -> thm list -> status Termtab.table -> - Facts.ref * Attrib.src list -> ((string * stature) * thm) list + Facts.ref * Token.src list -> ((string * stature) * thm) list val backquote_thm : Proof.context -> thm -> string val is_blacklisted_or_something : Proof.context -> bool -> string -> bool val clasimpset_rule_table_of : Proof.context -> status Termtab.table @@ -50,8 +50,8 @@ type fact = (string * stature) * thm type fact_override = - {add : (Facts.ref * Attrib.src list) list, - del : (Facts.ref * Attrib.src list) list, + {add : (Facts.ref * Token.src list) list, + del : (Facts.ref * Token.src list) list, only : bool} (* gracefully handle huge background theories *) @@ -77,8 +77,7 @@ | explode_interval max (Facts.From i) = i upto i + max - 1 | explode_interval _ (Facts.Single i) = [i] -val backquote = - raw_explode #> map (fn "`" => "\\`" | s => s) #> implode #> enclose "`" "`" +val backquote = raw_explode #> map (fn "`" => "\\`" | s => s) #> implode #> enclose "`" "`" (* unfolding these can yield really huge terms *) val risky_defs = @{thms Bit0_def Bit1_def} @@ -101,9 +100,8 @@ else Local val may_be_induction = - exists_subterm (fn Var (_, Type (@{type_name fun}, [_, T])) => - body_type T = @{typ bool} - | _ => false) + exists_subterm (fn Var (_, Type (@{type_name fun}, [_, T])) => body_type T = @{typ bool} + | _ => false) (* TODO: get rid of *) fun normalize_vars t = @@ -118,14 +116,12 @@ fun norm (t $ u) = norm t ##>> norm u #>> op $ | norm (Const (s, T)) = normT T #>> curry Const s - | norm (Var (z as (_, T))) = - normT T + | norm (Var (z as (_, T))) = normT T #> (fn (T, (accumT, (known, n))) => - (case find_index (equal z) known of - ~1 => (Var ((Name.uu, n), T), (accumT, (z :: known, n + 1))) - | j => (Var ((Name.uu, n - j - 1), T), (accumT, (known, n))))) - | norm (Abs (_, T, t)) = - norm t ##>> normT T #>> (fn (t, T) => Abs (Name.uu, T, t)) + (case find_index (equal z) known of + ~1 => (Var ((Name.uu, n), T), (accumT, (z :: known, n + 1))) + | j => (Var ((Name.uu, n - j - 1), T), (accumT, (known, n))))) + | norm (Abs (_, T, t)) = norm t ##>> normT T #>> (fn (t, T) => Abs (Name.uu, T, t)) | norm (Bound j) = pair (Bound j) | norm (Free (s, T)) = normT T #>> curry Free s in fst (norm t (([], 0), ([], 0))) end @@ -163,50 +159,43 @@ fun fact_of_ref ctxt reserved chained css (xthm as (xref, args)) = let val ths = Attrib.eval_thms ctxt [xthm] - val bracket = - map (enclose "[" "]" o Pretty.str_of o Args.pretty_src ctxt) args - |> implode + val bracket = implode (map (enclose "[" "]" o Pretty.str_of o Token.pretty_src ctxt) args) fun nth_name j = (case xref of - Facts.Fact s => backquote s ^ bracket + Facts.Fact s => backquote (simplify_spaces (unyxml s)) ^ bracket | Facts.Named (("", _), _) => "[" ^ bracket ^ "]" - | Facts.Named ((name, _), NONE) => - make_name reserved (length ths > 1) (j + 1) name ^ bracket + | Facts.Named ((name, _), NONE) => make_name reserved (length ths > 1) (j + 1) name ^ bracket | Facts.Named ((name, _), SOME intervals) => make_name reserved true (nth (maps (explode_interval (length ths)) intervals) j) name ^ bracket) fun add_nth th (j, rest) = let val name = nth_name j in - (j + 1, ((name, stature_of_thm false [] chained css name th), th) - :: rest) + (j + 1, ((name, stature_of_thm false [] chained css name th), th) :: rest) end in (0, []) |> fold add_nth ths |> snd end -(* Reject theorems with names like "List.filter.filter_list_def" or - "Accessible_Part.acc.defs", as these are definitions arising from packages. *) +(* Reject theorems with names like "List.filter.filter_list_def" or "Accessible_Part.acc.defs", as + these are definitions arising from packages. *) fun is_package_def s = let val ss = Long_Name.explode s in length ss > 2 andalso not (hd ss = "local") andalso exists (fn suf => String.isSuffix suf s) - ["_case_def", "_rec_def", "_size_def", "_size_overloaded_def"] + ["_case_def", "_rec_def", "_size_def", "_size_overloaded_def"] end (* FIXME: put other record thms here, or declare as "no_atp" *) fun multi_base_blacklist ctxt ho_atp = - ["defs", "select_defs", "update_defs", "split", "splits", "split_asm", - "ext_cases", "eq.simps", "eq.refl", "nchotomy", "case_cong", - "weak_case_cong", "nat_of_char_simps", "nibble.simps", + ["defs", "select_defs", "update_defs", "split", "splits", "split_asm", "ext_cases", "eq.simps", + "eq.refl", "nchotomy", "case_cong", "case_cong_weak", "nat_of_char_simps", "nibble.simps", "nibble.distinct"] - |> not (ho_atp orelse Config.get ctxt instantiate_inducts) ? - append ["induct", "inducts"] + |> not (ho_atp orelse Config.get ctxt instantiate_inducts) ? append ["induct", "inducts"] |> map (prefix Long_Name.separator) -(* The maximum apply depth of any "metis" call in "Metis_Examples" (on - 2007-10-31) was 11. *) +(* The maximum apply depth of any "metis" call in "Metis_Examples" (back in 2007) was 11. *) val max_apply_depth = 18 fun apply_depth (f $ t) = Int.max (apply_depth f, apply_depth t + 1) @@ -217,23 +206,20 @@ (* FIXME: Ad hoc list *) val technical_prefixes = - ["ATP", "Code_Evaluation", "Datatype", "Enum", "Lazy_Sequence", - "Limited_Sequence", "Meson", "Metis", "Nitpick", - "Quickcheck_Random", "Quickcheck_Exhaustive", "Quickcheck_Narrowing", + ["ATP", "Code_Evaluation", "Datatype", "Enum", "Lazy_Sequence", "Limited_Sequence", "Meson", + "Metis", "Nitpick", "Quickcheck_Random", "Quickcheck_Exhaustive", "Quickcheck_Narrowing", "Random_Sequence", "Sledgehammer", "SMT"] |> map (suffix Long_Name.separator) -fun is_technical_const (s, _) = - exists (fn pref => String.isPrefix pref s) technical_prefixes +fun is_technical_const s = exists (fn pref => String.isPrefix pref s) technical_prefixes (* FIXME: make more reliable *) val sep_class_sep = Long_Name.separator ^ "class" ^ Long_Name.separator -fun is_low_level_class_const (s, _) = +fun is_low_level_class_const s = s = @{const_name equal_class.equal} orelse String.isSubstring sep_class_sep s val sep_that = Long_Name.separator ^ Obtain.thatN - val skolem_thesis = Name.skolem Auto_Bind.thesisN fun is_that_fact th = @@ -259,11 +245,11 @@ | is_interesting_subterm _ = false fun interest_of_bool t = - if exists_Const (is_technical_const orf is_low_level_class_const orf - type_has_top_sort o snd) t then + if exists_Const ((is_technical_const o fst) orf (is_low_level_class_const o fst) orf + type_has_top_sort o snd) t then Deal_Breaker else if exists_type (exists_subtype (curry (op =) @{typ prop})) t orelse - not (exists_subterm is_interesting_subterm t) then + not (exists_subterm is_interesting_subterm t) then Boring else Interesting @@ -281,8 +267,7 @@ val t = prop_of th in - (interest_of_prop [] t <> Interesting andalso - not (Thm.eq_thm_prop (@{thm ext}, th))) orelse + (interest_of_prop [] t <> Interesting andalso not (Thm.eq_thm_prop (@{thm ext}, th))) orelse is_that_fact th end @@ -297,19 +282,18 @@ prefixes of all free variables. In the worse case scenario, where the fact won't be resolved correctly, the user can fix it manually, e.g., by giving a name to the offending fact. *) -fun all_prefixes_of s = - map (fn i => String.extract (s, 0, SOME i)) (1 upto size s - 1) +fun all_prefixes_of s = map (fn i => String.extract (s, 0, SOME i)) (1 upto size s - 1) fun close_form t = (t, [] |> Term.add_free_names t |> maps all_prefixes_of) |> fold (fn ((s, i), T) => fn (t', taken) => - let val s' = singleton (Name.variant_list taken) s in - ((if fastype_of t' = HOLogic.boolT then HOLogic.all_const - else Logic.all_const) T - $ Abs (s', T, abstract_over (Var ((s, i), T), t')), - s' :: taken) - end) - (Term.add_vars t [] |> sort_wrt (fst o fst)) + let val s' = singleton (Name.variant_list taken) s in + ((if fastype_of t' = HOLogic.boolT then HOLogic.all_const + else Logic.all_const) T + $ Abs (s', T, abstract_over (Var ((s, i), T), t')), + s' :: taken) + end) + (Term.add_vars t [] |> sort_wrt (fst o fst)) |> fst fun backquote_term ctxt = close_form #> hackish_string_of_term ctxt #> backquote @@ -322,26 +306,23 @@ Termtab.empty else let - fun add stature th = - Termtab.update (normalize_vars (prop_of th), stature) + fun add stature th = Termtab.update (normalize_vars (prop_of th), stature) - val {safeIs, (* safeEs, *) hazIs, (* hazEs, *) ...} = - ctxt |> claset_of |> Classical.rep_cs + val {safeIs, (* safeEs, *) hazIs, (* hazEs, *) ...} = ctxt |> claset_of |> Classical.rep_cs val intros = Item_Net.content safeIs @ Item_Net.content hazIs (* Add once it is used: - val elims = - Item_Net.content safeEs @ Item_Net.content hazEs + val elims = Item_Net.content safeEs @ Item_Net.content hazEs |> map Classical.classical_rule *) - val specs = ctxt |> Spec_Rules.get - val (rec_defs, nonrec_defs) = - specs |> filter (curry (op =) Spec_Rules.Equational o fst) - |> maps (snd o snd) - |> filter_out (member Thm.eq_thm_prop risky_defs) - |> List.partition (is_rec_def o prop_of) - val spec_intros = - specs |> filter (member (op =) [Spec_Rules.Inductive, Spec_Rules.Co_Inductive] o fst) - |> maps (snd o snd) + val specs = Spec_Rules.get ctxt + val (rec_defs, nonrec_defs) = specs + |> filter (curry (op =) Spec_Rules.Equational o fst) + |> maps (snd o snd) + |> filter_out (member Thm.eq_thm_prop risky_defs) + |> List.partition (is_rec_def o prop_of) + val spec_intros = specs + |> filter (member (op =) [Spec_Rules.Inductive, Spec_Rules.Co_Inductive] o fst) + |> maps (snd o snd) in Termtab.empty |> fold (add Simp o snd) simps @@ -358,7 +339,7 @@ fun normalize_eq (@{const Trueprop} $ (t as (t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2)) = if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t else t0 $ t2 $ t1 | normalize_eq (@{const Trueprop} $ (t as @{const Not} - $ ((t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2))) = + $ ((t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2))) = if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t else HOLogic.mk_not (t0 $ t2 $ t1) | normalize_eq (Const (@{const_name Pure.eq}, Type (_, [T, _])) $ t1 $ t2) = (if Term_Ord.fast_term_ord (t1, t2) <> GREATER then (t1, t2) else (t2, t1)) @@ -398,8 +379,7 @@ fun struct_induct_rule_on th = (case Logic.strip_horn (prop_of th) of - (prems, @{const Trueprop} - $ ((p as Var ((p_name, 0), _)) $ (a as Var (_, ind_T)))) => + (prems, @{const Trueprop} $ ((p as Var ((p_name, 0), _)) $ (a as Var (_, ind_T)))) => if not (is_TVar ind_T) andalso length prems > 1 andalso exists (exists_subterm (curry (op aconv) p)) prems andalso not (exists (exists_subterm (curry (op aconv) a)) prems) then @@ -416,13 +396,14 @@ if (s, T) = ind_x orelse can dest_funT T then t else Var ((s, 0), T) | varify_noninducts t = t - val p_inst = - concl_prop |> map_aterms varify_noninducts |> close_form - |> lambda (Free ind_x) - |> hackish_string_of_term ctxt + val p_inst = concl_prop + |> map_aterms varify_noninducts + |> close_form + |> lambda (Free ind_x) + |> hackish_string_of_term ctxt in - ((fn () => name () ^ "[where " ^ p_name ^ " = " ^ quote p_inst ^ "]", - stature), th |> Rule_Insts.read_instantiate ctxt [((p_name, 0), p_inst)] []) + ((fn () => name () ^ "[where " ^ p_name ^ " = " ^ quote p_inst ^ "]", stature), + th |> Rule_Insts.read_instantiate ctxt [((p_name, 0), p_inst)] []) end fun type_match thy (T1, T2) = @@ -436,7 +417,7 @@ stmt_xs |> filter (fn (_, T) => type_match thy (T, ind_T)) |> map_filter (try (TimeLimit.timeLimit instantiate_induct_timeout - (instantiate_induct_rule ctxt stmt p_name ax))) + (instantiate_induct_rule ctxt stmt p_name ax))) end | NONE => [ax]) @@ -451,7 +432,9 @@ (hyp_ts |> filter_out (null o external_frees), concl_t) |> Logic.list_implies |> Object_Logic.atomize_term thy val ind_stmt_xs = external_frees ind_stmt - in maps (instantiate_if_induct_rule ctxt ind_stmt ind_stmt_xs) end + in + maps (instantiate_if_induct_rule ctxt ind_stmt ind_stmt_xs) + end else I @@ -464,10 +447,8 @@ val thy = Proof_Context.theory_of ctxt val global_facts = Global_Theory.facts_of thy val is_too_complex = - if generous orelse fact_count global_facts >= max_facts_for_complex_check then - K false - else - is_too_complex + if generous orelse fact_count global_facts >= max_facts_for_complex_check then K false + else is_too_complex val local_facts = Proof_Context.facts_of ctxt val named_locals = local_facts |> Facts.dest_static true [global_facts] val assms = Assumption.all_assms_of ctxt @@ -479,8 +460,7 @@ val unnamed_locals = union Thm.eq_thm_prop (Facts.props local_facts) chained |> filter is_good_unnamed_local |> map (pair "" o single) - val full_space = - Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts) + val full_space = Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts) val is_blacklisted_or_something = is_blacklisted_or_something ctxt ho_atp fun add_facts global foldx facts = @@ -532,12 +512,12 @@ end)) ths (n, accum)) end) in - (* The single-theorem names go before the multiple-theorem ones (e.g., - "xxx" vs. "xxx(3)"), so that single names are preferred when both are - available. *) - `I [] |> add_facts false fold local_facts (unnamed_locals @ named_locals) - |> add_facts true Facts.fold_static global_facts global_facts - |> op @ + (* The single-theorem names go before the multiple-theorem ones (e.g., "xxx" vs. "xxx(3)"), so + that single names are preferred when both are available. *) + `I [] + |> add_facts false fold local_facts (unnamed_locals @ named_locals) + |> add_facts true Facts.fold_static global_facts global_facts + |> op @ end fun nearly_all_facts ctxt ho_atp {add, del, only} reserved css chained hyp_ts concl_t = @@ -545,20 +525,19 @@ [] else let - val chained = - chained - |> maps (fn th => insert Thm.eq_thm_prop (zero_var_indexes th) [th]) + val chained = chained |> maps (fn th => insert Thm.eq_thm_prop (zero_var_indexes th) [th]) in (if only then maps (map (fn ((name, stature), th) => ((K name, stature), th)) - o fact_of_ref ctxt reserved chained css) add + o fact_of_ref ctxt reserved chained css) add else let val (add, del) = pairself (Attrib.eval_thms ctxt) (add, del) val facts = all_facts ctxt false ho_atp reserved add chained css |> filter_out ((member Thm.eq_thm_prop del orf - (No_ATPs.member ctxt andf not o member Thm.eq_thm_prop add)) o snd) + (Named_Theorems.member ctxt @{named_theorems no_atp} andf + not o member Thm.eq_thm_prop add)) o snd) in facts end) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Wed Aug 27 15:52:58 2014 +0200 @@ -16,7 +16,7 @@ val trace : bool Config.T type isar_params = - bool * (string option * string option) * Time.time * real * bool * bool + bool * (string option * string option) * Time.time * real option * bool * bool * (term, string) atp_step list * thm val proof_text : Proof.context -> bool -> bool option -> bool option -> (unit -> isar_params) -> @@ -46,18 +46,29 @@ val trace = Attrib.setup_config_bool @{binding sledgehammer_isar_trace} (K false) +val e_definition_rule = "definition" val e_skolemize_rule = "skolemize" +val leo2_extcnf_forall_neg_rule = "extcnf_forall_neg" +val satallax_skolemize_rule = "tab_ex" val spass_pirate_datatype_rule = "DT" val vampire_skolemisation_rule = "skolemisation" -(* TODO: Use "Z3_Proof.string_of_rule" once it is moved to Isabelle *) -val z3_skolemize_rule = "sk" -val z3_th_lemma_rule = "th-lemma" +val veriT_la_generic_rule = "la_generic" +val veriT_simp_arith_rule = "simp_arith" +val veriT_tmp_ite_elim_rule = "tmp_ite_elim" +val veriT_tmp_skolemize_rule = "tmp_skolemize" +val z3_skolemize_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Skolemize +val z3_th_lemma_rule_prefix = Z3_New_Proof.string_of_rule (Z3_New_Proof.Th_Lemma "") +val zipperposition_cnf_rule = "cnf" val skolemize_rules = - [e_skolemize_rule, spass_skolemize_rule, vampire_skolemisation_rule, z3_skolemize_rule] + [e_definition_rule, e_skolemize_rule, leo2_extcnf_forall_neg_rule, satallax_skolemize_rule, + spass_skolemize_rule, vampire_skolemisation_rule, veriT_tmp_ite_elim_rule, + veriT_tmp_skolemize_rule, z3_skolemize_rule, zipperposition_cnf_rule] val is_skolemize_rule = member (op =) skolemize_rules -val is_arith_rule = String.isPrefix z3_th_lemma_rule +fun is_arith_rule rule = + String.isPrefix z3_th_lemma_rule_prefix rule orelse rule = veriT_simp_arith_rule orelse + rule = veriT_la_generic_rule val is_datatype_rule = String.isPrefix spass_pirate_datatype_rule fun raw_label_of_num num = (num, 0) @@ -71,59 +82,74 @@ fun add_line_pass1 (line as (name, role, t, rule, [])) lines = (* No dependencies: lemma (for Z3), fact, conjecture, or (for Vampire) internal facts or definitions. *) - if role = Conjecture orelse role = Negated_Conjecture then line :: lines - else if t aconv @{prop True} then map (replace_dependencies_in_line (name, [])) lines - else if role = Lemma orelse role = Hypothesis orelse is_arith_rule rule then line :: lines - else if role = Axiom then lines (* axioms (facts) need no proof lines *) - else map (replace_dependencies_in_line (name, [])) lines + if role = Conjecture orelse role = Negated_Conjecture then + line :: lines + else if t aconv @{prop True} then + map (replace_dependencies_in_line (name, [])) lines + else if role = Lemma orelse role = Hypothesis orelse is_arith_rule rule then + line :: lines + else if role = Axiom then + lines (* axioms (facts) need no proof lines *) + else + map (replace_dependencies_in_line (name, [])) lines | add_line_pass1 line lines = line :: lines -fun add_lines_pass2 res _ [] = rev res - | add_lines_pass2 res prev_t ((line as (name, role, t, rule, deps)) :: lines) = +fun add_lines_pass2 res [] = rev res + | add_lines_pass2 res ((line as (name, role, t, rule, deps)) :: lines) = let - fun looks_boring () = - t aconv @{prop True} orelse t aconv @{prop False} orelse t aconv prev_t orelse - length deps < 2 + fun normalize role = + role = Conjecture ? (HOLogic.dest_Trueprop #> s_not #> HOLogic.mk_Trueprop) + + val norm_t = normalize role t + val is_duplicate = + exists (fn (prev_name, prev_role, prev_t, _, _) => + member (op =) deps prev_name andalso + Term.aconv_untyped (normalize prev_role prev_t, norm_t)) + res + + fun looks_boring () = t aconv @{prop False} orelse length deps < 2 fun is_skolemizing_line (_, _, _, rule', deps') = is_skolemize_rule rule' andalso member (op =) deps' name + fun is_before_skolemize_rule () = exists is_skolemizing_line lines in - if role <> Plain orelse is_skolemize_rule rule orelse is_arith_rule rule orelse - is_datatype_rule rule orelse null lines orelse not (looks_boring ()) orelse - is_before_skolemize_rule () then - add_lines_pass2 (line :: res) t lines + if is_duplicate orelse + (role = Plain andalso not (is_skolemize_rule rule) andalso + not (is_arith_rule rule) andalso not (is_datatype_rule rule) andalso + not (null lines) andalso looks_boring () andalso not (is_before_skolemize_rule ())) then + add_lines_pass2 res (map (replace_dependencies_in_line (name, deps)) lines) else - add_lines_pass2 res t (map (replace_dependencies_in_line (name, deps)) lines) + add_lines_pass2 (line :: res) lines end type isar_params = - bool * (string option * string option) * Time.time * real * bool * bool + bool * (string option * string option) * Time.time * real option * bool * bool * (term, string) atp_step list * thm val basic_systematic_methods = [Metis_Method (NONE, NONE), Meson_Method, Blast_Method, SATx_Method] -val simp_based_methods = [Auto_Method, Simp_Method, Fastforce_Method, Force_Method] +val basic_simp_based_methods = [Auto_Method, Simp_Method, Force_Method] val basic_arith_methods = [Linarith_Method, Presburger_Method, Algebra_Method] -val arith_methods = basic_arith_methods @ simp_based_methods @ basic_systematic_methods +val arith_methods = basic_arith_methods @ basic_simp_based_methods @ basic_systematic_methods val datatype_methods = [Simp_Method, Simp_Size_Method] -val systematic_methods0 = basic_systematic_methods @ basic_arith_methods @ simp_based_methods @ - [Metis_Method (SOME no_typesN, NONE)] -val rewrite_methods = simp_based_methods @ basic_systematic_methods @ basic_arith_methods -val skolem_methods = basic_systematic_methods +val systematic_methods = + basic_systematic_methods @ basic_arith_methods @ basic_simp_based_methods @ + [Metis_Method (SOME full_typesN, NONE), Metis_Method (SOME no_typesN, NONE)] +val rewrite_methods = basic_simp_based_methods @ basic_systematic_methods @ basic_arith_methods +val skolem_methods = basic_systematic_methods @ [Auto_Choice_Method] fun isar_proof_text ctxt debug isar_proofs smt_proofs isar_params - (one_line_params as ((_, one_line_play), banner, used_facts, minimize_command, subgoal, - subgoal_count)) = + (one_line_params as ((used_facts, (_, one_line_play)), banner, subgoal, subgoal_count)) = let val _ = if debug then Output.urgent_message "Constructing Isar proof..." else () fun generate_proof_text () = let - val (verbose, alt_metis_args, preplay_timeout, compress, try0, minimize, atp_proof, goal) = + val (verbose, alt_metis_args, preplay_timeout, compress, try0, minimize, atp_proof0, goal) = isar_params () - val systematic_methods = insert (op =) (Metis_Method alt_metis_args) systematic_methods0 + val systematic_methods' = insert (op =) (Metis_Method alt_metis_args) systematic_methods fun massage_methods (meths as meth :: _) = if not try0 then [meth] @@ -135,7 +161,10 @@ val ctxt = ctxt |> Variable.set_body false |> Proof_Context.add_fixes fixes |> snd val do_preplay = preplay_timeout <> Time.zeroTime - val compress = if isar_proofs = NONE andalso do_preplay then 1000.0 else compress + val compress = + (case compress of + NONE => if isar_proofs = NONE andalso do_preplay then 1000.0 else 10.0 + | SOME n => n) fun is_fixed ctxt = Variable.is_declared ctxt orf Name.is_skolem fun skolems_of ctxt t = Term.add_frees t [] |> filter_out (is_fixed ctxt o fst) |> rev @@ -144,9 +173,8 @@ if keep_role role then SOME ((raw_label_of_num num, t), rule) else NONE val atp_proof = - atp_proof - |> rpair [] |-> fold_rev add_line_pass1 - |> add_lines_pass2 [] Term.dummy + fold_rev add_line_pass1 atp_proof0 [] + |> add_lines_pass2 [] val conjs = map_filter (fn (name, role, _, _, _) => @@ -169,7 +197,7 @@ val (lems, _) = fold_map add_lemma (map_filter (get_role (curry (op =) Lemma)) atp_proof) ctxt - val bot = atp_proof |> List.last |> #1 + val bot = #1 (List.last atp_proof) val refute_graph = atp_proof @@ -196,18 +224,20 @@ val rule_of_clause_id = fst o the o Symtab.lookup steps o fst - fun prop_of_clause [(num, _)] = Symtab.lookup steps num |> the |> snd |> close_form + val finish_off = close_form #> rename_bound_vars + + fun prop_of_clause [(num, _)] = Symtab.lookup steps num |> the |> snd |> finish_off | prop_of_clause names = let - val lits = map (HOLogic.dest_Trueprop o snd) - (map_filter (Symtab.lookup steps o fst) names) + val lits = + map (HOLogic.dest_Trueprop o snd) (map_filter (Symtab.lookup steps o fst) names) in (case List.partition (can HOLogic.dest_not) lits of (negs as _ :: _, pos as _ :: _) => s_imp (Library.foldr1 s_conj (map HOLogic.dest_not negs), Library.foldr1 s_disj pos) | _ => fold (curry s_disj) lits @{term False}) end - |> HOLogic.mk_Trueprop |> close_form + |> HOLogic.mk_Trueprop |> finish_off fun maybe_show outer c = (outer andalso eq_set (op =) (c, conjs)) ? cons Show @@ -215,7 +245,7 @@ accum |> (if tainted = [] then cons (Prove (if outer then [Show] else [], [], no_label, concl_t, [], - (the_list predecessor, []), massage_methods systematic_methods, "")) + sort_facts (the_list predecessor, []), massage_methods systematic_methods', "")) else I) |> rev @@ -226,12 +256,14 @@ val rule = rule_of_clause_id id val skolem = is_skolemize_rule rule - val deps = fold add_fact_of_dependencies gamma ([], []) + val deps = ([], []) + |> fold add_fact_of_dependencies gamma + |> sort_facts val meths = (if skolem then skolem_methods else if is_arith_rule rule then arith_methods else if is_datatype_rule rule then datatype_methods - else systematic_methods) + else systematic_methods') |> massage_methods fun prove sub facts = Prove (maybe_show outer c [], [], l, t, sub, facts, meths, "") @@ -241,16 +273,23 @@ (case gamma of [g] => if skolem andalso is_clause_tainted g then - let val subproof = Proof (skolems_of ctxt (prop_of_clause g), [], rev accum) in - isar_steps outer (SOME l) [prove [subproof] ([], [])] infs - end + (case skolems_of ctxt (prop_of_clause g) of + [] => steps_of_rest (prove [] deps) + | skos => + let val subproof = Proof (skos, [], rev accum) in + isar_steps outer (SOME l) [prove [subproof] ([], [])] infs + end) else steps_of_rest (prove [] deps) | _ => steps_of_rest (prove [] deps)) else steps_of_rest - (if skolem then Prove ([], skolems_of ctxt t, l, t, [], deps, meths, "") - else prove [] deps) + (if skolem then + (case skolems_of ctxt t of + [] => prove [] deps + | skos => Prove ([], skos, l, t, [], deps, meths, "")) + else + prove [] deps) end | isar_steps outer predecessor accum (Cases cases :: infs) = let @@ -262,7 +301,7 @@ val step = Prove (maybe_show outer c [], [], l, t, map isar_case (filter_out (null o snd) cases), - (the_list predecessor, []), massage_methods systematic_methods, "") + sort_facts (the_list predecessor, []), massage_methods systematic_methods', "") in isar_steps outer (SOME l) (step :: accum) infs end @@ -318,18 +357,12 @@ (keep_fastest_method_of_isar_step (!preplay_data) #> minimize ? minimize_isar_step_dependencies ctxt preplay_data) |> tap (trace_isar_proof "Minimized") - (* It's not clear whether this is worth the trouble (and if so, "compress" has an - unnatural semantics): *) -(* - |> minimize - ? (compress_isar_proof ctxt compress preplay_timeout preplay_data - #> tap (trace_isar_proof "Compressed again")) -*) |> `(preplay_outcome_of_isar_proof (!preplay_data)) ||> (comment_isar_proof comment_of #> chain_isar_proof #> kill_useless_labels_in_isar_proof - #> relabel_isar_proof_nicely) + #> relabel_isar_proof_nicely + #> rationalize_obtains_in_isar_proofs ctxt) in (case add_isar_steps (steps_of_isar_proof isar_proof) 0 of 1 => @@ -338,12 +371,11 @@ (case isar_proof of Proof (_, _, [Prove (_, _, _, _, _, (_, gfs), meth :: _, _)]) => let val used_facts' = filter (member (op =) gfs o fst) used_facts in - ((meth, play_outcome), banner, used_facts', minimize_command, subgoal, - subgoal_count) + ((used_facts', (meth, play_outcome)), banner, subgoal, subgoal_count) end) else one_line_params) ^ - (if isar_proofs = SOME true then "\n(No structured proof available -- proof too simple.)" + (if isar_proofs = SOME true then "\n(No Isar proof available.)" else "") | num_steps => let @@ -352,7 +384,7 @@ (if do_preplay then [string_of_play_outcome play_outcome] else []) in one_line_proof_text ctxt 0 one_line_params ^ - "\n\nStructured proof" ^ (commas msg |> not (null msg) ? enclose " (" ")") ^ ":\n" ^ + "\n\nIsar proof" ^ (commas msg |> not (null msg) ? enclose " (" ")") ^ ":\n" ^ Active.sendback_markup [Markup.padding_command] (string_of_isar_proof ctxt subgoal subgoal_count isar_proof) end) @@ -375,7 +407,7 @@ | Play_Failed => true) fun proof_text ctxt debug isar_proofs smt_proofs isar_params num_chained - (one_line_params as (preplay, _, _, _, _, _)) = + (one_line_params as ((_, preplay), _, _, _)) = (if isar_proofs = SOME true orelse (isar_proofs = NONE andalso isar_proof_would_be_a_good_idea smt_proofs preplay) then isar_proof_text ctxt debug isar_proofs smt_proofs isar_params diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_isar_compress.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar_compress.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar_compress.ML Wed Aug 27 15:52:58 2014 +0200 @@ -53,10 +53,10 @@ updates as Prove (qs', xs', l', t', subproofs', facts', meths', comment') :: updates') = (if l = l' then update_subproofs subproofs' updates' - |>> (fn subproofs' => Prove (qs', xs', l', t', subproofs', facts', meths', comment')) + |>> (fn subproofs'' => Prove (qs', xs', l', t', subproofs'', facts', meths', comment')) else update_subproofs subproofs updates - |>> (fn subproofs => Prove (qs, xs, l, t, subproofs, facts, meths, comment))) + |>> (fn subproofs' => Prove (qs, xs, l, t, subproofs', facts, meths, comment))) |>> (fn step => step :: steps) | update_step step (steps, updates) = (step :: steps, updates) and update_subproofs [] updates = ([], updates) @@ -64,9 +64,9 @@ | update_subproofs (proof :: subproofs) updates = update_proof proof (update_subproofs subproofs updates) and update_proof proof (proofs, []) = (proof :: proofs, []) - | update_proof (Proof (fix, assms, steps)) (proofs, updates) = - let val (steps, updates) = update_steps steps updates in - (Proof (fix, assms, steps) :: proofs, updates) + | update_proof (Proof (xs, assms, steps)) (proofs, updates) = + let val (steps', updates') = update_steps steps updates in + (Proof (xs, assms, steps') :: proofs, updates') end in fst (update_steps steps (rev updates)) @@ -87,18 +87,19 @@ (hopeful @ hopeless, hopeless) end -fun merge_steps preplay_data (Prove ([], fix1, l1, _, subproofs1, (lfs1, gfs1), meths1, comment1)) - (Prove (qs2, fix2, l2, t, subproofs2, (lfs2, gfs2), meths2, comment2)) = +fun merge_steps preplay_data (Prove ([], xs1, l1, _, subproofs1, (lfs1, gfs1), meths1, comment1)) + (Prove (qs2, xs2, l2, t, subproofs2, (lfs2, gfs2), meths2, comment2)) = let val (meths, hopeless) = merge_methods preplay_data (l1, meths1) (l2, meths2) val lfs = union (op =) lfs1 (remove (op =) l1 lfs2) val gfs = union (op =) gfs1 gfs2 in - (Prove (qs2, if member (op =) qs2 Show then [] else union (op =) fix1 fix2, l2, t, - subproofs1 @ subproofs2, (lfs, gfs), meths, comment1 ^ comment2), hopeless) + (Prove (qs2, inter (op =) (Term.add_frees t []) (xs1 @ xs2), l2, t, + subproofs1 @ subproofs2, sort_facts (lfs, gfs), meths, comment1 ^ comment2), + hopeless) end -val merge_slack_time = seconds 0.005 +val merge_slack_time = seconds 0.01 val merge_slack_factor = 1.5 fun adjust_merge_timeout max time = @@ -117,7 +118,7 @@ val (compress_further, decrement_step_count) = let val number_of_steps = add_isar_steps (steps_of_isar_proof proof) 0 - val target_number_of_steps = Real.round (Real.fromInt number_of_steps / compress) + val target_number_of_steps = Real.ceil (Real.fromInt number_of_steps / compress) val delta = Unsynchronized.ref (number_of_steps - target_number_of_steps) in (fn () => !delta > 0, fn () => delta := !delta - 1) @@ -153,10 +154,10 @@ | _ => preplay_timeout) (* elimination of trivial, one-step subproofs *) - fun elim_one_subproof time (step as Prove (qs, fix, l, t, _, (lfs, gfs), meths, comment)) subs + fun elim_one_subproof time (step as Prove (qs, xs, l, t, _, (lfs, gfs), meths, comment)) subs nontriv_subs = if null subs orelse not (compress_further ()) then - Prove (qs, fix, l, t, List.revAppend (nontriv_subs, subs), (lfs, gfs), meths, comment) + Prove (qs, xs, l, t, List.revAppend (nontriv_subs, subs), (lfs, gfs), meths, comment) else (case subs of (sub as Proof (_, assms, [Prove (_, _, l', _, [], (lfs', gfs'), meths', _)])) :: subs => @@ -167,14 +168,14 @@ val gfs'' = union (op =) gfs' gfs val (meths'' as _ :: _, hopeless) = merge_methods (!preplay_data) (l', meths') (l, meths) - val step'' = Prove (qs, fix, l, t, subs'', (lfs'', gfs''), meths'', comment) + val step'' = Prove (qs, xs, l, t, subs'', (lfs'', gfs''), meths'', comment) (* check if the modified step can be preplayed fast enough *) val timeout = adjust_merge_timeout preplay_timeout (Time.+ (time, reference_time l')) in (case preplay_isar_step ctxt timeout hopeless step'' of meths_outcomes as (_, Played time'') :: _ => - (* l' successfully eliminated *) + (* "l'" successfully eliminated *) (decrement_step_count (); set_preplay_outcomes_of_isar_step ctxt time'' preplay_data step'' meths_outcomes; map (replace_successor l' [l]) lfs'; @@ -192,8 +193,9 @@ fun compress_top_level steps = let - fun cand_key (l, t_size) = (length (get_successors l), t_size) - val cand_ord = prod_ord int_ord (int_ord o swap) o pairself cand_key + val cand_key = apfst (length o get_successors) + val cand_ord = + prod_ord int_ord (prod_ord (int_ord o swap) (int_ord o swap)) o pairself cand_key fun pop_next_candidate [] = (NONE, []) | pop_next_candidate (cands as (cand :: cands')) = @@ -215,13 +217,12 @@ val time_slice = time_mult (1.0 / Real.fromInt (length labels)) (reference_time l) val timeouts = map (adjust_merge_timeout preplay_timeout o curry Time.+ time_slice) times0 - val meths_outcomess = - map3 (preplay_isar_step ctxt) timeouts hopelesses succs' + val meths_outcomess = map3 (preplay_isar_step ctxt) timeouts hopelesses succs' in (case try (map (fn (_, Played time) :: _ => time)) meths_outcomess of NONE => steps | SOME times => - (* candidate successfully eliminated *) + (* "l" successfully eliminated *) (decrement_step_count (); map3 (fn time => set_preplay_outcomes_of_isar_step ctxt time preplay_data) times succs' meths_outcomess; @@ -236,12 +237,17 @@ else (case pop_next_candidate candidates of (NONE, _) => steps (* no more candidates for elimination *) - | (SOME (l, _), candidates') => + | (SOME (l, (num_xs, _)), candidates') => (case find_index (curry (op =) (SOME l) o label_of_isar_step) steps of ~1 => steps | i => - let val successors = get_successors l in - if length successors > compress_degree then + let + val successors = get_successors l + val num_successors = length successors + in + (* Careful with "obtain", so we don't "obtain" twice the same variable after a + merge. *) + if num_successors > (if num_xs > 0 then 1 else compress_degree) then steps else steps @@ -249,7 +255,7 @@ |> compression_loop candidates' end)) - fun add_cand (Prove (_, _, l, t, _, _, _, _)) = cons (l, size_of_term t) + fun add_cand (Prove (_, xs, l, t, _, _, _, _)) = cons (l, (length xs, size_of_term t)) | add_cand _ = I (* the very last step is not a candidate *) @@ -264,12 +270,13 @@ can be eliminated. In the best case, this once again leads to a proof whose proof steps do not have subproofs. Applying this approach recursively will result in a flat proof in the best cast. *) - fun compress_proof (proof as (Proof (fix, assms, steps))) = - if compress_further () then Proof (fix, assms, compress_steps steps) else proof + fun compress_proof (proof as (Proof (xs, assms, steps))) = + if compress_further () then Proof (xs, assms, compress_steps steps) else proof and compress_steps steps = (* bottom-up: compress innermost proofs first *) - steps |> map (fn step => step |> compress_further () ? compress_sub_levels) - |> compress_further () ? compress_top_level + steps + |> map (fn step => step |> compress_further () ? compress_sub_levels) + |> compress_further () ? compress_top_level and compress_sub_levels (Prove (qs, xs, l, t, subproofs, facts, meths, comment)) = (* compress subproofs *) Prove (qs, xs, l, t, map compress_proof subproofs, facts, meths, comment) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_isar_minimize.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar_minimize.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar_minimize.ML Wed Aug 27 15:52:58 2014 +0200 @@ -12,6 +12,7 @@ type isar_preplay_data = Sledgehammer_Isar_Preplay.isar_preplay_data val keep_fastest_method_of_isar_step : isar_preplay_data -> isar_step -> isar_step + val minimized_isar_step : Proof.context -> Time.time -> isar_step -> Time.time * isar_step val minimize_isar_step_dependencies : Proof.context -> isar_preplay_data Unsynchronized.ref -> isar_step -> isar_step val postprocess_isar_proof_remove_unreferenced_steps : (isar_step -> isar_step) -> isar_proof -> @@ -35,28 +36,33 @@ val slack = seconds 0.025 +fun minimized_isar_step ctxt time + (Prove (qs, xs, l, t, subproofs, (lfs0, gfs00), meths as meth :: _, comment)) = + let + val gfs0 = filter (thms_influence_proof_method ctxt meth o thms_of_name ctxt) gfs00 + + fun mk_step_lfs_gfs lfs gfs = + Prove (qs, xs, l, t, subproofs, sort_facts (lfs, gfs), meths, comment) + + fun minimize_half _ min_facts [] time = (min_facts, time) + | minimize_half mk_step min_facts (fact :: facts) time = + (case preplay_isar_step_for_method ctxt (Time.+ (time, slack)) meth + (mk_step (min_facts @ facts)) of + Played time' => minimize_half mk_step min_facts facts time' + | _ => minimize_half mk_step (fact :: min_facts) facts time) + + val (min_lfs, time') = minimize_half (fn lfs => mk_step_lfs_gfs lfs gfs0) [] lfs0 time + val (min_gfs, time'') = minimize_half (mk_step_lfs_gfs min_lfs) [] gfs0 time' + in + (time'', mk_step_lfs_gfs min_lfs min_gfs) + end + fun minimize_isar_step_dependencies ctxt preplay_data - (step as Prove (qs, xs, l, t, subproofs, (lfs0, gfs00), meths as meth :: _, comment)) = + (step as Prove (_, _, l, _, _, _, meth :: _, _)) = (case Lazy.force (preplay_outcome_of_isar_step_for_method (!preplay_data) l meth) of Played time => - let - val gfs0 = filter (influence_proof_method ctxt meth o thms_of_name ctxt) gfs00 - - fun mk_step_lfs_gfs lfs gfs = Prove (qs, xs, l, t, subproofs, (lfs, gfs), meths, comment) - - fun minimize_facts _ min_facts [] time = (min_facts, time) - | minimize_facts mk_step min_facts (fact :: facts) time = - (case preplay_isar_step_for_method ctxt (Time.+ (time, slack)) meth - (mk_step (min_facts @ facts)) of - Played time' => minimize_facts mk_step min_facts facts time' - | _ => minimize_facts mk_step (fact :: min_facts) facts time) - - val (min_lfs, time') = minimize_facts (fn lfs => mk_step_lfs_gfs lfs gfs0) [] lfs0 time - val (min_gfs, time'') = minimize_facts (mk_step_lfs_gfs min_lfs) [] gfs0 time' - - val step' = mk_step_lfs_gfs min_lfs min_gfs - in - set_preplay_outcomes_of_isar_step ctxt time'' preplay_data step' [(meth, Played time'')]; + let val (time', step') = minimized_isar_step ctxt time step in + set_preplay_outcomes_of_isar_step ctxt time' preplay_data step' [(meth, Played time')]; step' end | _ => step (* don't touch steps that time out or fail *)) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_isar_preplay.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar_preplay.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar_preplay.ML Wed Aug 27 15:52:58 2014 +0200 @@ -41,6 +41,27 @@ val trace = Attrib.setup_config_bool @{binding sledgehammer_preplay_trace} (K false) +fun par_list_map_filter_with_timeout _ _ _ _ [] = [] + | par_list_map_filter_with_timeout get_time min_timeout timeout0 f xs = + let + val next_timeout = Unsynchronized.ref timeout0 + + fun apply_f x = + let val timeout = !next_timeout in + if Time.<= (timeout, min_timeout) then + NONE + else + let val y = f timeout x in + (case get_time y of + SOME time => next_timeout := time + | _ => ()); + SOME y + end + end + in + map_filter I (Par_List.map apply_f xs) + end + fun enrich_context_with_local_facts proof ctxt = let val thy = Proof_Context.theory_of ctxt @@ -140,16 +161,18 @@ fun preplay_isar_step_for_method ctxt timeout meth = try (raw_preplay_step_for_method ctxt timeout meth) #> the_default Play_Failed -fun preplay_isar_step ctxt timeout hopeless step = +val min_preplay_timeout = seconds 0.002 + +fun preplay_isar_step ctxt timeout0 hopeless step = let - fun try_method meth = - (case preplay_isar_step_for_method ctxt timeout meth step of - outcome as Played _ => SOME (meth, outcome) - | _ => NONE) + fun preplay timeout meth = (meth, preplay_isar_step_for_method ctxt timeout meth step) + fun get_time (_, Played time) = SOME time + | get_time _ = NONE val meths = proof_methods_of_isar_step step |> subtract (op =) hopeless in - the_list (Par_List.get_some try_method meths) + par_list_map_filter_with_timeout get_time min_preplay_timeout timeout0 preplay meths + |> sort (play_outcome_ord o pairself snd) end type isar_preplay_data = (proof_method * play_outcome Lazy.lazy) list Canonical_Label_Tab.table @@ -181,7 +204,7 @@ if Lazy.is_finished outcome then Lazy.force outcome else Play_Timed_Out Time.zeroTime fun get_best_method_outcome force = - tap (List.app (K () o Lazy.future Future.default_params o snd)) (* optional parallelism *) + tap (List.app (K () o Lazy.future Future.default_params o snd)) (* could be parallelized *) #> map (apsnd force) #> sort (play_outcome_ord o pairself snd) #> hd diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_isar_proof.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar_proof.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar_proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -26,9 +26,9 @@ val label_ord : label * label -> order val string_of_label : label -> string + val sort_facts : facts -> facts val steps_of_isar_proof : isar_proof -> isar_step list - val label_of_isar_step : isar_step -> label option val facts_of_isar_step : isar_step -> facts val proof_methods_of_isar_step : isar_step -> proof_method list @@ -46,6 +46,7 @@ val kill_useless_labels_in_isar_proof : isar_proof -> isar_proof val relabel_isar_proof_canonically : isar_proof -> isar_proof val relabel_isar_proof_nicely : isar_proof -> isar_proof + val rationalize_obtains_in_isar_proofs : Proof.context -> isar_proof -> isar_proof val string_of_isar_proof : Proof.context -> int -> int -> isar_proof -> string end; @@ -75,10 +76,24 @@ val no_label = ("", ~1) -val label_ord = pairself swap #> prod_ord int_ord fast_string_ord +(* cf. "label_ord" below *) +val assume_prefix = "a" +val have_prefix = "f" + +fun label_ord ((s1, i1), (s2, i2)) = + (case int_ord (pairself String.size (s1, s2)) of + EQUAL => + (case string_ord (s1, s2) of + EQUAL => int_ord (i1, i2) + | ord => ord (* "assume" before "have" *)) + | ord => ord) fun string_of_label (s, num) = s ^ string_of_int num +(* Put the nearest local label first, since it's the most likely to be replaced by a "hence". + (Some preplaying proof methods, e.g. "blast", react poorly to fact reorderings.) *) +fun sort_facts (lfs, gfs) = (sort (label_ord o swap) lfs, sort string_ord gfs) + fun steps_of_isar_proof (Proof (_, _, steps)) = steps fun label_of_isar_step (Prove (_, _, l, _, _, _, _, _)) = SOME l @@ -174,9 +189,6 @@ fst (relabel_proof proof (0, [])) end -val assume_prefix = "a" -val have_prefix = "f" - val relabel_isar_proof_nicely = let fun next_label depth prefix l (accum as (next, subst)) = @@ -206,6 +218,35 @@ relabel_proof [] 0 end +fun stutter_single_letter s = String.extract (s, 0, SOME 1) ^ s + +fun rationalize_obtains_in_isar_proofs ctxt = + let + fun rename_obtains xs (subst, ctxt) = + let + val Ts = map snd xs + val new_names0 = map (stutter_single_letter o var_name_of_typ o body_type) Ts + val (new_names, ctxt') = Variable.variant_fixes new_names0 ctxt + val ys = map2 pair new_names Ts + in + (ys, ((map Free xs ~~ map Free ys) @ subst, ctxt')) + end + + fun rationalize_step (Prove (qs, xs, l, t, subs, facts, meths, comment)) subst_ctxt = + let + val (xs', subst_ctxt' as (subst', _)) = rename_obtains xs subst_ctxt + val t' = subst_atomic subst' t + val subs' = map (rationalize_proof subst_ctxt') subs + in + (Prove (qs, xs', l, t', subs', facts, meths, comment), subst_ctxt') + end + and rationalize_proof (subst_ctxt as (subst, _)) (Proof (fix, assms, steps)) = + Proof (fix, map (apsnd (subst_atomic subst)) assms, + fst (fold_map rationalize_step steps subst_ctxt)) + in + rationalize_proof ([], ctxt) + end + val indent_size = 2 fun string_of_isar_proof ctxt0 i n proof = @@ -290,18 +331,17 @@ and add_step_pre ind qs subs (s, ctxt) = (s ^ of_subproofs ind ctxt qs subs ^ of_indent ind, ctxt) and add_step ind (Let (t1, t2)) = - add_str (of_indent ind ^ "let ") - #> add_term t1 #> add_str " = " #> add_term t2 #> add_str "\n" + add_str (of_indent ind ^ "let ") #> add_term t1 #> add_str " = " #> add_term t2 + #> add_str "\n" | add_step ind (Prove (qs, xs, l, t, subs, (ls, ss), meth :: _, comment)) = add_step_pre ind qs subs #> (case xs of - [] => add_str (of_have qs (length subs) ^ " ") - | _ => add_str (of_obtain qs (length subs) ^ " ") #> add_frees xs #> add_str " where ") + [] => add_str (of_have qs (length subs) ^ " ") + | _ => add_str (of_obtain qs (length subs) ^ " ") #> add_frees xs #> add_str " where ") #> add_str (of_label l) #> add_term t - #> add_str (" " ^ - of_method (sort_distinct label_ord ls) (sort_distinct string_ord ss) meth ^ - (if comment = "" then "" else " (* " ^ comment ^ " *)") ^ "\n") + #> add_str (" " ^ of_method ls ss meth ^ + (if comment = "" then "" else " (* " ^ comment ^ " *)") ^ "\n") and add_steps ind = fold (add_step ind) and of_proof ind ctxt (Proof (xs, assms, steps)) = ("", ctxt) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML Wed Aug 27 15:52:58 2014 +0200 @@ -814,7 +814,7 @@ {comment = "Goal: " ^ goal_name, state = Proof.init ctxt, goal = goal, subgoal = 1, subgoal_count = 1, factss = [("", facts)]} in - get_minimizing_prover ctxt MaSh (K ()) prover params (K (K (K ""))) problem + get_minimizing_prover ctxt MaSh (K ()) prover params problem end val bad_types = [@{type_name prop}, @{type_name bool}, @{type_name fun}] @@ -974,8 +974,8 @@ thms_in_proof max_dependencies (SOME name_tabs) th |> Option.map (fn deps => if deps = [typedef_dep] orelse deps = [class_some_dep] orelse - exists (member (op =) fundef_ths) deps orelse exists (member (op =) typedef_ths) deps orelse - is_size_def deps th then + exists (member (op =) fundef_ths) deps orelse exists (member (op =) typedef_ths) deps orelse + is_size_def deps th then [] else deps) @@ -1378,7 +1378,7 @@ let val name = nickname_of_thm th val feats = features_of ctxt (theory_of_thm th) stature [prop_of th] - val deps = deps_of status th |> these + val deps = these (deps_of status th) val num_nontrivial = num_nontrivial |> not (null deps) ? Integer.add 1 val learns = (name, parents, feats, deps) :: learns val (learns, next_commit) = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_proof_methods.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_proof_methods.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_proof_methods.ML Wed Aug 27 15:52:58 2014 +0200 @@ -18,7 +18,7 @@ Simp_Method | Simp_Size_Method | Auto_Method | - Fastforce_Method | + Auto_Choice_Method | Force_Method | Linarith_Method | Presburger_Method | @@ -29,14 +29,13 @@ Play_Timed_Out of Time.time | Play_Failed - type minimize_command = string list -> string type one_line_params = - (proof_method * play_outcome) * string * (string * stature) list * minimize_command * int * int + ((string * stature) list * (proof_method * play_outcome)) * string * int * int val is_proof_method_direct : proof_method -> bool val string_of_proof_method : Proof.context -> string list -> proof_method -> string val tac_of_proof_method : Proof.context -> thm list * thm list -> proof_method -> int -> tactic - val influence_proof_method : Proof.context -> proof_method -> thm list -> bool + val thms_influence_proof_method : Proof.context -> proof_method -> thm list -> bool val string_of_play_outcome : play_outcome -> string val play_outcome_ord : play_outcome * play_outcome -> order val one_line_proof_text : Proof.context -> int -> one_line_params -> string @@ -58,7 +57,7 @@ Simp_Method | Simp_Size_Method | Auto_Method | - Fastforce_Method | + Auto_Choice_Method | Force_Method | Linarith_Method | Presburger_Method | @@ -69,9 +68,8 @@ Play_Timed_Out of Time.time | Play_Failed -type minimize_command = string list -> string type one_line_params = - (proof_method * play_outcome) * string * (string * stature) list * minimize_command * int * int + ((string * stature) list * (proof_method * play_outcome)) * string * int * int fun is_proof_method_direct (Metis_Method _) = true | is_proof_method_direct Meson_Method = true @@ -96,7 +94,7 @@ | Simp_Method => if null ss then "simp" else "simp add:" | Simp_Size_Method => "simp add: " ^ short_thm_name ctxt @{thm size_ne_size_imp_ne} | Auto_Method => "auto" - | Fastforce_Method => "fastforce" + | Auto_Choice_Method => "atomize_elim, auto intro!: " ^ short_thm_name ctxt @{thm choice} | Force_Method => "force" | Linarith_Method => "linarith" | Presburger_Method => "presburger" @@ -129,18 +127,20 @@ (case meth of SATx_Method => SAT.satx_tac ctxt | Blast_Method => blast_tac ctxt - | Auto_Method => K (Clasimp.auto_tac (silence_methods ctxt)) - | Fastforce_Method => Clasimp.fast_force_tac (silence_methods ctxt) - | Force_Method => Clasimp.force_tac (silence_methods ctxt) + | Auto_Method => SELECT_GOAL (Clasimp.auto_tac (silence_methods ctxt)) + | Auto_Choice_Method => + Atomize_Elim.atomize_elim_tac ctxt THEN' + SELECT_GOAL (Clasimp.auto_tac (silence_methods ctxt addSIs @{thms choice})) + | Force_Method => SELECT_GOAL (Clasimp.auto_tac (silence_methods ctxt)) | Linarith_Method => let val ctxt = Config.put Lin_Arith.verbose false ctxt in Lin_Arith.tac ctxt end | Presburger_Method => Cooper.tac true [] [] ctxt | Algebra_Method => Groebner.algebra_tac [] [] ctxt)) val simp_based_methods = - [Simp_Method, Simp_Size_Method, Auto_Method, Fastforce_Method, Force_Method] + [Simp_Method, Simp_Size_Method, Auto_Method, Auto_Choice_Method, Force_Method] -fun influence_proof_method ctxt meth ths = +fun thms_influence_proof_method ctxt meth ths = not (member (op =) simp_based_methods meth) orelse let val ctxt' = silence_methods ctxt in (* unfortunate pointer comparison -- but it's always safe to consider a theorem useful *) @@ -179,29 +179,13 @@ (s |> s <> "" ? enclose " (" ")") ^ "." end -fun minimize_line _ [] = "" - | minimize_line minimize_command ss = - (case minimize_command ss of - "" => "" - | command => "\nTo minimize: " ^ Active.sendback_markup [Markup.padding_command] command ^ ".") - -fun split_used_facts facts = - facts - |> List.partition (fn (_, (sc, _)) => sc = Chained) - |> pairself (sort_distinct (string_ord o pairself fst)) - fun one_line_proof_text ctxt num_chained - ((meth, play), banner, used_facts, minimize_command, subgoal, subgoal_count) = - let - val (chained, extra) = split_used_facts used_facts - - val try_line = - map fst extra - |> proof_method_command ctxt meth subgoal subgoal_count (map fst chained) num_chained - |> (if play = Play_Failed then enclose "One-line proof reconstruction failed: " "." - else try_command_line banner play) - in - try_line ^ minimize_line minimize_command (map fst (extra @ chained)) + ((used_facts, (meth, play)), banner, subgoal, subgoal_count) = + let val (chained, extra) = List.partition (fn (_, (sc, _)) => sc = Chained) used_facts in + map fst extra + |> proof_method_command ctxt meth subgoal subgoal_count (map fst chained) num_chained + |> (if play = Play_Failed then enclose "One-line proof reconstruction failed: " "." + else try_command_line banner play) end end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_prover.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_prover.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_prover.ML Wed Aug 27 15:52:58 2014 +0200 @@ -14,7 +14,6 @@ type fact = Sledgehammer_Fact.fact type proof_method = Sledgehammer_Proof_Methods.proof_method type play_outcome = Sledgehammer_Proof_Methods.play_outcome - type minimize_command = Sledgehammer_Proof_Methods.minimize_command datatype mode = Auto_Try | Try | Normal | MaSh | Auto_Minimize | Minimize @@ -36,11 +35,11 @@ max_mono_iters : int option, max_new_mono_instances : int option, isar_proofs : bool option, - compress : real, + compress : real option, try0 : bool, smt_proofs : bool option, slice : bool, - minimize : bool option, + minimize : bool, timeout : Time.time, preplay_timeout : Time.time, expect : string} @@ -57,32 +56,21 @@ {outcome : atp_failure option, used_facts : (string * stature) list, used_from : fact list, + preferred_methss : proof_method * proof_method list list, run_time : Time.time, - preplay : (proof_method * play_outcome) Lazy.lazy, - message : proof_method * play_outcome -> string, - message_tail : string} + message : (unit -> (string * stature) list * (proof_method * play_outcome)) -> string} - type prover = - params -> ((string * string list) list -> string -> minimize_command) -> prover_problem -> - prover_result + type prover = params -> prover_problem -> prover_result val SledgehammerN : string val str_of_mode : mode -> string - val smtN : string val overlord_file_location_of_prover : string -> string * string val proof_banner : mode -> string -> string - val extract_proof_method : params -> proof_method -> string * (string * string list) list - val is_proof_method : string -> bool val is_atp : theory -> string -> bool - val bunch_of_proof_methods : bool -> bool -> string -> proof_method list + val bunches_of_proof_methods : bool -> bool -> bool -> string -> proof_method list list val is_fact_chained : (('a * stature) * 'b) -> bool val filter_used_facts : bool -> (''a * stature) list -> ((''a * stature) * 'b) list -> ((''a * stature) * 'b) list - val play_one_line_proof : mode -> bool -> Time.time -> ((string * 'a) * thm) list -> - Proof.state -> int -> proof_method -> proof_method list -> proof_method * play_outcome - val isar_supported_prover_of : theory -> string -> string - val choose_minimize_command : theory -> params -> ((string * string list) list -> string -> 'a) -> - string -> proof_method * play_outcome -> 'a val repair_monomorph_context : int option -> int -> int option -> int -> Proof.context -> Proof.context @@ -118,11 +106,6 @@ | str_of_mode Auto_Minimize = "Auto_Minimize" | str_of_mode Minimize = "Minimize" -val smtN = "smt" - -val proof_method_names = [metisN, smtN] -val is_proof_method = member (op =) proof_method_names - val is_atp = member (op =) o supported_atps type params = @@ -143,11 +126,11 @@ max_mono_iters : int option, max_new_mono_instances : int option, isar_proofs : bool option, - compress : real, + compress : real option, try0 : bool, smt_proofs : bool option, slice : bool, - minimize : bool option, + minimize : bool, timeout : Time.time, preplay_timeout : Time.time, expect : string} @@ -164,14 +147,11 @@ {outcome : atp_failure option, used_facts : (string * stature) list, used_from : fact list, + preferred_methss : proof_method * proof_method list list, run_time : Time.time, - preplay : (proof_method * play_outcome) Lazy.lazy, - message : proof_method * play_outcome -> string, - message_tail : string} + message : (unit -> (string * stature) list * (proof_method * play_outcome)) -> string} -type prover = - params -> ((string * string list) list -> string -> minimize_command) - -> prover_problem -> prover_result +type prover = params -> prover_problem -> prover_result fun overlord_file_location_of_prover prover = (getenv "ISABELLE_HOME_USER", "prob_" ^ prover) @@ -181,101 +161,29 @@ | Try => "Sledgehammer (" ^ quote name ^ ") found a proof" | _ => "Try this") -fun bunch_of_proof_methods smt_proofs needs_full_types desperate_lam_trans = - (if needs_full_types then - [Metis_Method (SOME full_typesN, NONE), - Metis_Method (SOME really_full_type_enc, NONE), - Metis_Method (SOME full_typesN, SOME desperate_lam_trans), - Metis_Method (SOME really_full_type_enc, SOME desperate_lam_trans)] +fun bunches_of_proof_methods try0 smt_proofs needs_full_types desperate_lam_trans = + (if try0 then + [[Simp_Method, Auto_Method, Blast_Method, Linarith_Method], + [Meson_Method, Force_Method, Presburger_Method]] else - [Metis_Method (NONE, NONE), - Metis_Method (SOME full_typesN, NONE), - Metis_Method (SOME no_typesN, SOME desperate_lam_trans), - Metis_Method (SOME really_full_type_enc, SOME desperate_lam_trans)]) @ - (if smt_proofs then [SMT2_Method] else []) - -fun extract_proof_method ({type_enc, lam_trans, ...} : params) - (Metis_Method (type_enc', lam_trans')) = - let - val override_params = - (if is_none type_enc' andalso is_none type_enc then [] - else [("type_enc", [hd (unalias_type_enc (type_enc' |> the_default partial_typesN))])]) @ - (if is_none lam_trans' andalso is_none lam_trans then [] - else [("lam_trans", [lam_trans' |> the_default default_metis_lam_trans])]) - in (metisN, override_params) end - | extract_proof_method _ SMT2_Method = (smtN, []) - -(* based on "Mirabelle.can_apply" and generalized *) -fun timed_apply timeout tac state i = - let - val {context = ctxt, facts, goal} = Proof.goal state - val full_tac = Method.insert_tac facts i THEN tac ctxt i - in - TimeLimit.timeLimit timeout (try (Seq.pull o full_tac)) goal - end - -fun timed_proof_method timeout ths meth = - timed_apply timeout (fn ctxt => tac_of_proof_method ctxt ([], ths) meth) + []) @ + [[Metis_Method (if needs_full_types then SOME full_typesN else NONE, NONE)], + (if needs_full_types then + [Metis_Method (NONE, NONE), + Metis_Method (SOME really_full_type_enc, NONE), + Metis_Method (SOME full_typesN, SOME desperate_lam_trans), + Metis_Method (SOME really_full_type_enc, SOME desperate_lam_trans)] + else + [Metis_Method (SOME full_typesN, NONE), + Metis_Method (SOME no_typesN, SOME desperate_lam_trans), + Metis_Method (SOME really_full_type_enc, SOME desperate_lam_trans)])] @ + (if smt_proofs then [[SMT2_Method]] else []) fun is_fact_chained ((_, (sc, _)), _) = sc = Chained fun filter_used_facts keep_chained used = filter ((member (op =) used o fst) orf (if keep_chained then is_fact_chained else K false)) -fun play_one_line_proof mode verbose timeout pairs state i preferred (meths as meth :: _) = - let - val ctxt = Proof.context_of state - - fun get_preferred meths = if member (op =) meths preferred then preferred else meth - in - if timeout = Time.zeroTime then - (get_preferred meths, Play_Timed_Out Time.zeroTime) - else - let - val _ = if mode = Minimize then Output.urgent_message "Preplaying proof..." else () - val ths = pairs |> sort_wrt (fst o fst) |> map snd - fun play [] [] = (get_preferred meths, Play_Failed) - | play timed_outs [] = (get_preferred timed_outs, Play_Timed_Out timeout) - | play timed_out (meth :: meths) = - let - val _ = - if verbose then - Output.urgent_message ("Trying \"" ^ string_of_proof_method ctxt [] meth ^ - "\" for " ^ string_of_time timeout ^ "...") - else - () - val timer = Timer.startRealTimer () - in - (case timed_proof_method timeout ths meth state i of - SOME (SOME _) => (meth, Played (Timer.checkRealTimer timer)) - | _ => play timed_out meths) - end - handle TimeLimit.TimeOut => play (meth :: timed_out) meths - in - play [] meths - end - end - -val canonical_isar_supported_prover = eN -val z3N = "z3" - -fun isar_supported_prover_of thy name = - if is_atp thy name orelse name = z3N then name - else if is_atp_installed thy canonical_isar_supported_prover then canonical_isar_supported_prover - else name - -(* FIXME: See the analogous logic in the function "maybe_minimize" in - "sledgehammer_prover_minimize.ML". *) -fun choose_minimize_command thy (params as {isar_proofs, ...}) minimize_command name preplay = - let - val maybe_isar_name = name |> isar_proofs = SOME true ? isar_supported_prover_of thy - val (min_name, override_params) = - (case preplay of - (meth as Metis_Method _, Played _) => - if isar_proofs = SOME true then (maybe_isar_name, []) else extract_proof_method params meth - | _ => (maybe_isar_name, [])) - in minimize_command override_params min_name end - val max_fact_instances = 10 (* FUDGE *) fun repair_monomorph_context max_iters best_max_iters max_new_instances best_max_new_instances = @@ -288,7 +196,6 @@ let val thy = Proof_Context.theory_of ctxt val (remote_provers, local_provers) = - proof_method_names @ sort_strings (supported_atps thy) @ sort_strings (SMT2_Config.available_solvers_of ctxt) |> List.partition (String.isPrefix remote_prefix) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_prover_atp.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_prover_atp.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_prover_atp.ML Wed Aug 27 15:52:58 2014 +0200 @@ -30,6 +30,7 @@ open ATP_Problem_Generate open ATP_Proof_Reconstruct open ATP_Waldmeister +open ATP_Satallax open ATP_Systems open Sledgehammer_Util open Sledgehammer_Proof_Methods @@ -126,15 +127,13 @@ the only ATP that does not honor its time limit. *) val atp_timeout_slack = seconds 1.0 -(* Important messages are important but not so important that users want to see - them each time. *) +(* Important messages are important but not so important that users want to see them each time. *) val atp_important_message_keep_quotient = 25 fun run_atp mode name - (params as {debug, verbose, overlord, type_enc, strict, lam_trans, uncurried_aliases, - fact_filter, max_facts, max_mono_iters, max_new_mono_instances, isar_proofs, compress, try0, - smt_proofs, slice, minimize, timeout, preplay_timeout, ...}) - minimize_command + ({debug, verbose, overlord, type_enc, strict, lam_trans, uncurried_aliases, fact_filter, + max_facts, max_mono_iters, max_new_mono_instances, isar_proofs, compress, try0, smt_proofs, + slice, minimize, timeout, preplay_timeout, ...} : params) ({comment, state, goal, subgoal, subgoal_count, factss, ...} : prover_problem) = let val thy = Proof.theory_of state @@ -295,19 +294,21 @@ |>> (if overlord then prefix ("% " ^ command ^ "\n% " ^ timestamp () ^ "\n") else I) |> fst |> split_time |> (fn accum as (output, _) => - (accum, - extract_tstplike_proof_and_outcome verbose proof_delims known_failures output - |>> atp_proof_of_tstplike_proof (perhaps (try (unprefix remote_prefix)) name) atp_problem - handle UNRECOGNIZED_ATP_PROOF () => ([], SOME ProofUnparsable))) + (accum, + extract_tstplike_proof_and_outcome verbose proof_delims known_failures output + |>> atp_proof_of_tstplike_proof (perhaps (try (unprefix remote_prefix)) name) + atp_problem + handle UNRECOGNIZED_ATP_PROOF () => ([], SOME ProofUnparsable))) handle TimeLimit.TimeOut => (("", slice_timeout), ([], SOME TimedOut)) val outcome = (case outcome of NONE => - (case used_facts_in_unsound_atp_proof ctxt (map fst facts) atp_proof - |> Option.map (sort string_ord) of + (case used_facts_in_unsound_atp_proof ctxt (map fst facts) atp_proof of SOME facts => - let val failure = UnsoundProof (is_type_enc_sound type_enc, facts) in + let + val failure = UnsoundProof (is_type_enc_sound type_enc, sort string_ord facts) + in if debug then (warning (string_of_atp_failure failure); NONE) else SOME failure end | NONE => NONE) @@ -354,22 +355,18 @@ else "" - val (used_facts, preplay, message, message_tail) = + val (used_facts, preferred_methss, message) = (case outcome of NONE => let - val used_facts = used_facts_in_atp_proof ctxt (map fst used_from) atp_proof + val used_facts = sort_wrt fst (used_facts_in_atp_proof ctxt (map fst used_from) atp_proof) val needs_full_types = is_typed_helper_used_in_atp_proof atp_proof - val meths = - bunch_of_proof_methods (smt_proofs <> SOME false) needs_full_types - (if atp_proof_prefers_lifting atp_proof then liftingN else hide_lamsN) + val preferred_methss = + (Metis_Method (NONE, NONE), + bunches_of_proof_methods try0 (smt_proofs <> SOME false) needs_full_types + (if atp_proof_prefers_lifting atp_proof then liftingN else hide_lamsN)) in - (used_facts, - Lazy.lazy (fn () => - let val used_pairs = used_from |> filter_used_facts false used_facts in - play_one_line_proof mode verbose preplay_timeout used_pairs state subgoal (hd meths) - meths - end), + (used_facts, preferred_methss, fn preplay => let val _ = if verbose then Output.urgent_message "Generating proof text..." else () @@ -383,33 +380,29 @@ val atp_proof = atp_proof |> termify_atp_proof ctxt name format type_enc pool lifted sym_tab - |> spass ? introduce_spass_skolem + |> spass ? introduce_spass_skolems |> factify_atp_proof (map fst used_from) hyp_ts concl_t in (verbose, (metis_type_enc, metis_lam_trans), preplay_timeout, compress, try0, - minimize <> SOME false, atp_proof, goal) + minimize, atp_proof, goal) end - val one_line_params = - (preplay, proof_banner mode name, used_facts, - choose_minimize_command thy params minimize_command name preplay, subgoal, - subgoal_count) + val one_line_params = (preplay (), proof_banner mode name, subgoal, subgoal_count) val num_chained = length (#facts (Proof.goal state)) in - proof_text ctxt debug isar_proofs smt_proofs isar_params num_chained one_line_params - end, - (if verbose then "\nATP real CPU time: " ^ string_of_time run_time ^ "." else "") ^ - (if important_message <> "" then - "\n\nImportant message from Dr. Geoff Sutcliffe:\n" ^ important_message - else - "")) + proof_text ctxt debug isar_proofs smt_proofs isar_params num_chained + one_line_params ^ + (if important_message <> "" then + "\n\nImportant message from Dr. Geoff Sutcliffe:\n" ^ important_message + else + "") + end) end | SOME failure => - ([], Lazy.value (Metis_Method (NONE, NONE), Play_Failed), - fn _ => string_of_atp_failure failure, "")) + ([], (Auto_Method (* dummy *), []), fn _ => string_of_atp_failure failure)) in - {outcome = outcome, used_facts = used_facts, used_from = used_from, run_time = run_time, - preplay = preplay, message = message, message_tail = message_tail} + {outcome = outcome, used_facts = used_facts, used_from = used_from, + preferred_methss = preferred_methss, run_time = run_time, message = message} end end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_prover_minimize.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_prover_minimize.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_prover_minimize.ML Wed Aug 27 15:52:58 2014 +0200 @@ -20,18 +20,11 @@ val get_prover : Proof.context -> mode -> string -> prover val binary_min_facts : int Config.T - val auto_minimize_min_facts : int Config.T - val auto_minimize_max_time : real Config.T val minimize_facts : (thm list -> unit) -> string -> params -> bool -> int -> int -> - Proof.state -> thm -> (proof_method * play_outcome) Lazy.lazy option -> - ((string * stature) * thm list) list -> + Proof.state -> thm -> ((string * stature) * thm list) list -> ((string * stature) * thm list) list option - * ((proof_method * play_outcome) Lazy.lazy * ((proof_method * play_outcome) -> string) - * string) + * ((unit -> (string * stature) list * (proof_method * play_outcome)) -> string) val get_minimizing_prover : Proof.context -> mode -> (thm list -> unit) -> string -> prover - - val run_minimize : params -> (thm list -> unit) -> int -> (Facts.ref * Attrib.src list) list -> - Proof.state -> unit end; structure Sledgehammer_Prover_Minimize : SLEDGEHAMMER_PROVER_MINIMIZE = @@ -50,59 +43,17 @@ open Sledgehammer_Prover_ATP open Sledgehammer_Prover_SMT2 -fun run_proof_method mode name (params as {verbose, timeout, type_enc, lam_trans, ...}) - minimize_command - ({state, subgoal, subgoal_count, factss = (_, facts) :: _, ...} : prover_problem) = - let - val meth = - if name = metisN then Metis_Method (type_enc, lam_trans) - else if name = smtN then SMT2_Method - else raise Fail ("unknown proof_method: " ^ quote name) - val used_facts = facts |> map fst - in - (case play_one_line_proof (if mode = Minimize then Normal else mode) verbose timeout facts state - subgoal meth [meth] of - play as (_, Played time) => - {outcome = NONE, used_facts = used_facts, used_from = facts, run_time = time, - preplay = Lazy.value play, - message = fn play => - let - val ctxt = Proof.context_of state - val (_, override_params) = extract_proof_method params meth - val one_line_params = - (play, proof_banner mode name, used_facts, minimize_command override_params name, - subgoal, subgoal_count) - val num_chained = length (#facts (Proof.goal state)) - in - one_line_proof_text ctxt num_chained one_line_params - end, - message_tail = ""} - | play => - let - val failure = (case play of (_, Play_Failed) => GaveUp | _ => TimedOut) - in - {outcome = SOME failure, used_facts = [], used_from = [], - run_time = Time.zeroTime, preplay = Lazy.value play, - message = fn _ => string_of_atp_failure failure, message_tail = ""} - end) - end - fun is_prover_supported ctxt = let val thy = Proof_Context.theory_of ctxt in - is_proof_method orf is_atp thy orf is_smt2_prover ctxt + is_atp thy orf is_smt2_prover ctxt end fun is_prover_installed ctxt = - is_proof_method orf is_smt2_prover ctxt orf - is_atp_installed (Proof_Context.theory_of ctxt) - -val proof_method_default_max_facts = 20 + is_smt2_prover ctxt orf is_atp_installed (Proof_Context.theory_of ctxt) fun default_max_facts_of_prover ctxt name = let val thy = Proof_Context.theory_of ctxt in - if is_proof_method name then - proof_method_default_max_facts - else if is_atp thy name then + if is_atp thy name then fold (Integer.max o fst o #1 o fst o snd) (#best_slices (get_atp thy name ()) ctxt) 0 else if is_smt2_prover ctxt name then SMT2_Solver.default_max_relevant ctxt name @@ -112,8 +63,7 @@ fun get_prover ctxt mode name = let val thy = Proof_Context.theory_of ctxt in - if is_proof_method name then run_proof_method mode name - else if is_atp thy name then run_atp mode name + if is_atp thy name then run_atp mode name else if is_smt2_prover ctxt name then run_smt2_solver mode name else error ("No such prover: " ^ name ^ ".") end @@ -149,8 +99,7 @@ val problem = {comment = "", state = state, goal = goal, subgoal = i, subgoal_count = n, factss = [("", facts)]} - val result as {outcome, used_facts, run_time, ...} = - prover params (K (K (K ""))) problem + val result as {outcome, used_facts, run_time, ...} = prover params problem in print silent (fn () => (case outcome of @@ -180,11 +129,6 @@ actually needed, we heuristically set the threshold to 10 facts. *) val binary_min_facts = Attrib.setup_config_int @{binding sledgehammer_minimize_binary_min_facts} (K 20) -val auto_minimize_min_facts = - Attrib.setup_config_int @{binding sledgehammer_auto_minimize_min_facts} - (fn generic => Config.get_generic generic binary_min_facts) -val auto_minimize_max_time = - Attrib.setup_config_real @{binding sledgehammer_auto_minimize_max_time} (K 5.0) fun linear_minimize test timeout result xs = let @@ -216,7 +160,7 @@ (case test timeout (sup @ l0) of result as {outcome = NONE, used_facts, ...} => min depth result (filter_used_facts true used_facts sup) - (filter_used_facts true used_facts l0) + (filter_used_facts true used_facts l0) | _ => (case test timeout (sup @ r0) of result as {outcome = NONE, used_facts, ...} => @@ -244,7 +188,7 @@ end fun minimize_facts do_learn prover_name (params as {learn, timeout, ...}) silent i n state goal - preplay0 facts = + facts = let val ctxt = Proof.context_of state val prover = get_prover ctxt (if silent then Auto_Minimize else Minimize) prover_name @@ -262,135 +206,50 @@ val min = if length facts >= Config.get ctxt binary_min_facts then binary_minimize else linear_minimize - val (min_facts, {preplay, message, message_tail, ...}) = - min test (new_timeout timeout run_time) result facts + val (min_facts, {message, ...}) = min test (new_timeout timeout run_time) result facts in print silent (fn () => cat_lines - ["Minimized to " ^ n_facts (map fst min_facts)] ^ - (case min_facts |> filter is_fact_chained |> length of - 0 => "" - | n => "\n(including " ^ string_of_int n ^ " chained)") ^ "."); + ["Minimized to " ^ n_facts (map fst min_facts)] ^ + (case min_facts |> filter is_fact_chained |> length of + 0 => "" + | n => "\n(including " ^ string_of_int n ^ " chained)") ^ "."); (if learn then do_learn (maps snd min_facts) else ()); - (SOME min_facts, - (if is_some preplay0 andalso length min_facts = length facts then the preplay0 - else preplay, - message, message_tail)) + (SOME min_facts, message) end - | {outcome = SOME TimedOut, preplay, ...} => - (NONE, (preplay, fn _ => + | {outcome = SOME TimedOut, ...} => + (NONE, fn _ => "Timeout: You can increase the time limit using the \"timeout\" option (e.g., \ - \timeout = " ^ string_of_int (10 + Time.toMilliseconds timeout div 1000) ^ "\").", "")) - | {preplay, message, ...} => (NONE, (preplay, prefix "Prover error: " o message, "")))) - handle ERROR msg => - (NONE, (Lazy.value (Metis_Method (NONE, NONE), Play_Failed), fn _ => "Error: " ^ msg, "")) + \timeout = " ^ string_of_int (10 + Time.toMilliseconds timeout div 1000) ^ "\").") + | {message, ...} => (NONE, (prefix "Prover error: " o message)))) + handle ERROR msg => (NONE, fn _ => "Error: " ^ msg) end -fun adjust_proof_method_params override_params - ({debug, verbose, overlord, spy, blocking, provers, type_enc, strict, lam_trans, - uncurried_aliases, learn, fact_filter, max_facts, fact_thresholds, max_mono_iters, - max_new_mono_instances, isar_proofs, compress, try0, smt_proofs, slice, minimize, timeout, - preplay_timeout, expect} : params) = - let - fun lookup_override name default_value = - (case AList.lookup (op =) override_params name of - SOME [s] => SOME s - | _ => default_value) - (* Only those options that proof_methods are interested in are considered here. *) - val type_enc = lookup_override "type_enc" type_enc - val lam_trans = lookup_override "lam_trans" lam_trans - in - {debug = debug, verbose = verbose, overlord = overlord, spy = spy, blocking = blocking, - provers = provers, type_enc = type_enc, strict = strict, lam_trans = lam_trans, - uncurried_aliases = uncurried_aliases, learn = learn, fact_filter = fact_filter, - max_facts = max_facts, fact_thresholds = fact_thresholds, max_mono_iters = max_mono_iters, - max_new_mono_instances = max_new_mono_instances, isar_proofs = isar_proofs, - compress = compress, try0 = try0, smt_proofs = smt_proofs, slice = slice, minimize = minimize, - timeout = timeout, preplay_timeout = preplay_timeout, expect = expect} - end - -fun maybe_minimize ctxt mode do_learn name (params as {verbose, isar_proofs, minimize, ...}) +fun maybe_minimize mode do_learn name (params as {verbose, minimize, ...}) ({state, goal, subgoal, subgoal_count, ...} : prover_problem) - (result as {outcome, used_facts, used_from, run_time, preplay, message, message_tail} : - prover_result) = + (result as {outcome, used_facts, used_from, preferred_methss, run_time, message} + : prover_result) = if is_some outcome orelse null used_facts then result else let - val thy = Proof_Context.theory_of ctxt - val num_facts = length used_facts - - val ((perhaps_minimize, (minimize_name, params)), preplay) = - if mode = Normal then - if num_facts >= Config.get ctxt auto_minimize_min_facts then - ((true, (name, params)), preplay) - else - let - fun can_min_fast_enough time = - 0.001 - * Real.fromInt ((num_facts + 1) * Time.toMilliseconds time) - <= Config.get ctxt auto_minimize_max_time - fun prover_fast_enough () = can_min_fast_enough run_time - in - (case Lazy.force preplay of - (meth as Metis_Method _, Played timeout) => - if isar_proofs = SOME true then - (* Cheat: Assume the selected ATP is as fast as "metis" for the goal it proved - itself. *) - (can_min_fast_enough timeout, (isar_supported_prover_of thy name, params)) - else if can_min_fast_enough timeout then - (true, extract_proof_method params meth - ||> (fn override_params => - adjust_proof_method_params override_params params)) - else - (prover_fast_enough (), (name, params)) - | (SMT2_Method, Played timeout) => - (* Cheat: Assume the original prover is as fast as "smt" for the goal it proved - itself. *) - (can_min_fast_enough timeout, (name, params)) - | _ => (prover_fast_enough (), (name, params)), - preplay) - end - else - ((false, (name, params)), preplay) - val minimize = minimize |> the_default perhaps_minimize - val (used_facts, (preplay, message, _)) = + val (used_facts, message) = if minimize then - minimize_facts do_learn minimize_name params + minimize_facts do_learn name params (not verbose orelse (mode <> Normal andalso mode <> MaSh)) subgoal subgoal_count state - goal (SOME preplay) (filter_used_facts true used_facts (map (apsnd single) used_from)) + goal (filter_used_facts true used_facts (map (apsnd single) used_from)) |>> Option.map (map fst) else - (SOME used_facts, (preplay, message, "")) + (SOME used_facts, message) in (case used_facts of SOME used_facts => - {outcome = NONE, used_facts = used_facts, used_from = used_from, run_time = run_time, - preplay = preplay, message = message, message_tail = message_tail} + {outcome = NONE, used_facts = sort_wrt fst used_facts, used_from = used_from, + preferred_methss = preferred_methss, run_time = run_time, message = message} | NONE => result) end -fun get_minimizing_prover ctxt mode do_learn name params minimize_command problem = - get_prover ctxt mode name params minimize_command problem - |> maybe_minimize ctxt mode do_learn name params problem - -fun run_minimize (params as {provers, ...}) do_learn i refs state = - let - val ctxt = Proof.context_of state - val {goal, facts = chained_ths, ...} = Proof.goal state - val reserved = reserved_isar_keyword_table () - val css = clasimpset_rule_table_of ctxt - val facts = refs |> maps (map (apsnd single) o fact_of_ref ctxt reserved chained_ths css) - in - (case subgoal_count state of - 0 => Output.urgent_message "No subgoal!" - | n => - (case provers of - [] => error "No prover is set." - | prover :: _ => - (kill_provers (); - minimize_facts do_learn prover params false i n state goal NONE facts - |> (fn (_, (preplay, message, message_tail)) => - Output.urgent_message (message (Lazy.force preplay) ^ message_tail))))) - end +fun get_minimizing_prover ctxt mode do_learn name params problem = + get_prover ctxt mode name params problem + |> maybe_minimize mode do_learn name params problem end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_prover_smt2.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_prover_smt2.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_prover_smt2.ML Wed Aug 27 15:52:58 2014 +0200 @@ -179,7 +179,7 @@ fun run_smt2_solver mode name (params as {debug, verbose, isar_proofs, compress, try0, smt_proofs, minimize, preplay_timeout, ...}) - minimize_command ({state, goal, subgoal, subgoal_count, factss, ...} : prover_problem) = + ({state, goal, subgoal, subgoal_count, factss, ...} : prover_problem) = let val thy = Proof.theory_of state val ctxt = Proof.context_of state @@ -189,36 +189,36 @@ val {outcome, filter_result = {fact_ids, atp_proof, ...}, used_from, run_time} = smt2_filter_loop name params state goal subgoal factss val used_named_facts = map snd fact_ids - val used_facts = map fst used_named_facts + val used_facts = sort_wrt fst (map fst used_named_facts) val outcome = Option.map failure_of_smt2_failure outcome - val (preplay, message, message_tail) = + val (preferred_methss, message) = (case outcome of NONE => - (Lazy.lazy (fn () => - play_one_line_proof mode verbose preplay_timeout used_named_facts state subgoal - SMT2_Method (bunch_of_proof_methods (smt_proofs <> SOME false) false liftingN)), - fn preplay => - let - fun isar_params () = - (verbose, (NONE, NONE), preplay_timeout, compress, try0, minimize <> SOME false, - atp_proof (), goal) + let + val preferred_methss = + (SMT2_Method, bunches_of_proof_methods try0 (smt_proofs <> SOME false) false liftingN) + in + (preferred_methss, + fn preplay => + let + val _ = if verbose then Output.urgent_message "Generating proof text..." else () - val one_line_params = - (preplay, proof_banner mode name, used_facts, - choose_minimize_command thy params minimize_command name preplay, subgoal, - subgoal_count) - val num_chained = length (#facts (Proof.goal state)) - in - proof_text ctxt debug isar_proofs smt_proofs isar_params num_chained one_line_params - end, - if verbose then "\nSMT solver real CPU time: " ^ string_of_time run_time ^ "." else "") - | SOME failure => - (Lazy.value (Metis_Method (NONE, NONE), Play_Failed), - fn _ => string_of_atp_failure failure, "")) + fun isar_params () = + (verbose, (NONE, NONE), preplay_timeout, compress, try0, minimize, atp_proof (), + goal) + + val one_line_params = (preplay (), proof_banner mode name, subgoal, subgoal_count) + val num_chained = length (#facts (Proof.goal state)) + in + proof_text ctxt debug isar_proofs smt_proofs isar_params num_chained + one_line_params + end) + end + | SOME failure => ((Auto_Method (* dummy *), []), fn _ => string_of_atp_failure failure)) in - {outcome = outcome, used_facts = used_facts, used_from = used_from, run_time = run_time, - preplay = preplay, message = message, message_tail = message_tail} + {outcome = outcome, used_facts = used_facts, used_from = used_from, + preferred_methss = preferred_methss, run_time = run_time, message = message} end end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Sledgehammer/sledgehammer_util.ML --- a/src/HOL/Tools/Sledgehammer/sledgehammer_util.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_util.ML Wed Aug 27 15:52:58 2014 +0200 @@ -101,7 +101,10 @@ else (false, false) in if anonymous then - app_body (if enter_class then map_inclass_name else map_name) (Future.join body) accum + (case Future.peek body of + SOME (Exn.Res the_body) => + app_body (if enter_class then map_inclass_name else map_name) the_body accum + | NONE => accum) else (case map_name name of SOME name' => @@ -133,7 +136,7 @@ |> Symbol.source |> Token.source {do_recover = SOME false} lex Position.start |> Token.source_proper - |> Source.source Token.stopper (Parse_Spec.xthms1 >> get) NONE + |> Source.source Token.stopper (Parse.xthms1 >> get) NONE |> Source.exhaust end @@ -144,9 +147,9 @@ Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN) (print_mode_value ())) f x fun hackish_string_of_term ctxt = - with_vanilla_print_mode (Syntax.string_of_term ctxt) #> simplify_spaces + with_vanilla_print_mode (Syntax.string_of_term ctxt) #> unyxml #> simplify_spaces -val spying_version = "c" +val spying_version = "d" fun spying false _ = () | spying true f = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/TFL/tfl.ML --- a/src/HOL/Tools/TFL/tfl.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/TFL/tfl.ML Wed Aug 27 15:52:58 2014 +0200 @@ -434,7 +434,7 @@ val case_simpset = put_simpset HOL_basic_ss ctxt addsimps case_rewrites - |> fold (Simplifier.add_cong o #weak_case_cong o snd) + |> fold (Simplifier.add_cong o #case_cong_weak o snd) (Symtab.dest (Datatype.get_all theory)) val corollaries' = map (Simplifier.simplify case_simpset) corollaries val extract = Rules.CONTEXT_REWRITE_RULE diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/Transfer/transfer_bnf.ML --- a/src/HOL/Tools/Transfer/transfer_bnf.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/Transfer/transfer_bnf.ML Wed Aug 27 15:52:58 2014 +0200 @@ -112,8 +112,9 @@ let val old_ctxt = ctxt val (goal, ctxt) = generate_relation_constraint_goal ctxt bnf constraint_def - val thm = Goal.prove ctxt [] [] goal + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => side_constraint_tac bnf [constraint_def] ctxt 1) + |> Thm.close_derivation in Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm) end @@ -122,8 +123,9 @@ let val old_ctxt = ctxt val (goal, ctxt) = generate_relation_constraint_goal ctxt bnf constraint_def - val thm = Goal.prove ctxt [] [] goal + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => bi_constraint_tac constraint_def side_constraints ctxt 1) + |> Thm.close_derivation in Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm) end @@ -219,8 +221,9 @@ val lhs = mk_Domainp (list_comb (relator, args)) val rhs = mk_pred pred_def (map mk_Domainp args) T val goal = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop - val thm = Goal.prove ctxt [] [] goal + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => Domainp_tac bnf pred_def ctxt 1) + |> Thm.close_derivation in Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm) end @@ -244,8 +247,9 @@ val lhs = list_comb (relator, map mk_eq_onp args) val rhs = mk_eq_onp (mk_pred pred_def args T) val goal = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop - val thm = Goal.prove ctxt [] [] goal + val thm = Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} => pred_eq_onp_tac bnf pred_def ctxt 1) + |> Thm.close_derivation in Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm) end diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/arith_data.ML --- a/src/HOL/Tools/arith_data.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/arith_data.ML Wed Aug 27 15:52:58 2014 +0200 @@ -9,7 +9,6 @@ val arith_tac: Proof.context -> int -> tactic val verbose_arith_tac: Proof.context -> int -> tactic val add_tactic: string -> (bool -> Proof.context -> int -> tactic) -> theory -> theory - val get_arith_facts: Proof.context -> thm list val mk_number: typ -> int -> term val mk_sum: typ -> term list -> term @@ -28,15 +27,7 @@ structure Arith_Data: ARITH_DATA = struct -(* slots for plugging in arithmetic facts and tactics *) - -structure Arith_Facts = Named_Thms -( - val name = @{binding arith} - val description = "arith facts -- only ground formulas" -); - -val get_arith_facts = Arith_Facts.get; +(* slot for plugging in tactics *) structure Arith_Tactics = Theory_Data ( @@ -58,11 +49,12 @@ val verbose_arith_tac = gen_arith_tac true; val setup = - Arith_Facts.setup #> Method.setup @{binding arith} (Scan.succeed (fn ctxt => - METHOD (fn facts => HEADGOAL (Method.insert_tac (get_arith_facts ctxt @ facts) - THEN' verbose_arith_tac ctxt)))) + METHOD (fn facts => + HEADGOAL + (Method.insert_tac (rev (Named_Theorems.get ctxt @{named_theorems arith}) @ facts) + THEN' verbose_arith_tac ctxt)))) "various arithmetic decision procedures"; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/coinduction.ML --- a/src/HOL/Tools/coinduction.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/coinduction.ML Wed Aug 27 15:52:58 2014 +0200 @@ -149,9 +149,8 @@ val setup = Method.setup @{binding coinduction} (arbitrary -- Scan.option coinduct_rule >> - (fn (arbitrary, opt_rule) => fn ctxt => - RAW_METHOD_CASES (fn facts => - Seq.DETERM (coinduction_tac ctxt arbitrary opt_rule facts)))) + (fn (arbitrary, opt_rule) => fn ctxt => fn facts => + Seq.DETERM (coinduction_tac ctxt arbitrary opt_rule facts))) "coinduction on types or predicates/sets"; end; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/groebner.ML --- a/src/HOL/Tools/groebner.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/groebner.ML Wed Aug 27 15:52:58 2014 +0200 @@ -924,7 +924,7 @@ fun presimplify ctxt add_thms del_thms = asm_full_simp_tac (put_simpset HOL_basic_ss ctxt - addsimps (Algebra_Simplification.get ctxt) + addsimps (Named_Theorems.get ctxt @{named_theorems algebra}) delsimps del_thms addsimps add_thms); fun ring_tac add_ths del_ths ctxt = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/inductive.ML --- a/src/HOL/Tools/inductive.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/inductive.ML Wed Aug 27 15:52:58 2014 +0200 @@ -53,7 +53,7 @@ (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> (Attrib.binding * string) list -> - (Facts.ref * Attrib.src list) list -> + (Facts.ref * Token.src list) list -> local_theory -> inductive_result * local_theory val add_inductive_global: inductive_flags -> ((binding * typ) * mixfix) list -> (string * typ) list -> (Attrib.binding * term) list -> @@ -76,7 +76,7 @@ term list -> (binding * mixfix) list -> local_theory -> inductive_result * local_theory val declare_rules: binding -> bool -> bool -> string list -> term list -> - thm list -> binding list -> Attrib.src list list -> (thm * string list * int) list -> + thm list -> binding list -> Token.src list list -> (thm * string list * int) list -> thm list -> thm -> local_theory -> thm list * thm list * thm list * thm * thm list * local_theory val add_ind_def: add_ind_def val gen_add_inductive_i: add_ind_def -> inductive_flags -> @@ -85,7 +85,7 @@ val gen_add_inductive: add_ind_def -> bool -> bool -> (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> - (Attrib.binding * string) list -> (Facts.ref * Attrib.src list) list -> + (Attrib.binding * string) list -> (Facts.ref * Token.src list) list -> local_theory -> inductive_result * local_theory val gen_ind_decl: add_ind_def -> bool -> (local_theory -> local_theory) parser end; @@ -1157,7 +1157,7 @@ fun gen_ind_decl mk_def coind = Parse.fixes -- Parse.for_fixes -- Scan.optional Parse_Spec.where_alt_specs [] -- - Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse_Spec.xthms1) [] + Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse.xthms1) [] >> (fn (((preds, params), specs), monos) => (snd o gen_add_inductive mk_def true coind preds params specs monos)); diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/inductive_set.ML --- a/src/HOL/Tools/inductive_set.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/inductive_set.ML Wed Aug 27 15:52:58 2014 +0200 @@ -20,7 +20,7 @@ val add_inductive: bool -> bool -> (binding * string option * mixfix) list -> (binding * string option * mixfix) list -> - (Attrib.binding * string) list -> (Facts.ref * Attrib.src list) list -> + (Attrib.binding * string) list -> (Facts.ref * Token.src list) list -> local_theory -> Inductive.inductive_result * local_theory val mono_add: attribute val mono_del: attribute diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/lin_arith.ML --- a/src/HOL/Tools/lin_arith.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/lin_arith.ML Wed Aug 27 15:52:58 2014 +0200 @@ -796,7 +796,7 @@ (* FIXME !?? *) fun add_arith_facts ctxt = - Simplifier.add_prems (Arith_Data.get_arith_facts ctxt) ctxt; + Simplifier.add_prems (rev (Named_Theorems.get ctxt @{named_theorems arith})) ctxt; val simproc = add_arith_facts #> Fast_Arith.lin_arith_simproc; @@ -889,7 +889,7 @@ Method.setup @{binding linarith} (Scan.succeed (fn ctxt => METHOD (fn facts => - HEADGOAL (Method.insert_tac (Arith_Data.get_arith_facts ctxt @ facts) + HEADGOAL (Method.insert_tac (rev (Named_Theorems.get ctxt @{named_theorems arith}) @ facts) THEN' tac ctxt)))) "linear arithmetic" #> Arith_Data.add_tactic "linear arithmetic" gen_tac; diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/recdef.ML --- a/src/HOL/Tools/recdef.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/recdef.ML Wed Aug 27 15:52:58 2014 +0200 @@ -15,17 +15,17 @@ val cong_del: attribute val wf_add: attribute val wf_del: attribute - val add_recdef: bool -> xstring -> string -> ((binding * string) * Attrib.src list) list -> - Attrib.src option -> theory -> theory + val add_recdef: bool -> xstring -> string -> ((binding * string) * Token.src list) list -> + Token.src option -> theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} val add_recdef_i: bool -> xstring -> term -> ((binding * term) * attribute list) list -> theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} - val defer_recdef: xstring -> string list -> (Facts.ref * Attrib.src list) list + val defer_recdef: xstring -> string list -> (Facts.ref * Token.src list) list -> theory -> theory * {induct_rules: thm} val defer_recdef_i: xstring -> term list -> thm list -> theory -> theory * {induct_rules: thm} - val recdef_tc: bstring * Attrib.src list -> xstring -> int option -> bool -> + val recdef_tc: bstring * Token.src list -> xstring -> int option -> bool -> local_theory -> Proof.state - val recdef_tc_i: bstring * Attrib.src list -> string -> int option -> bool -> + val recdef_tc_i: bstring * Token.src list -> string -> int option -> bool -> local_theory -> Proof.state val setup: theory -> theory end; @@ -143,15 +143,15 @@ val recdef_wfN = "recdef_wf"; val recdef_modifiers = - [Args.$$$ recdef_simpN -- Args.colon >> K ((I, simp_add): Method.modifier), - Args.$$$ recdef_simpN -- Args.add -- Args.colon >> K (I, simp_add), - Args.$$$ recdef_simpN -- Args.del -- Args.colon >> K (I, simp_del), - Args.$$$ recdef_congN -- Args.colon >> K (I, cong_add), - Args.$$$ recdef_congN -- Args.add -- Args.colon >> K (I, cong_add), - Args.$$$ recdef_congN -- Args.del -- Args.colon >> K (I, cong_del), - Args.$$$ recdef_wfN -- Args.colon >> K (I, wf_add), - Args.$$$ recdef_wfN -- Args.add -- Args.colon >> K (I, wf_add), - Args.$$$ recdef_wfN -- Args.del -- Args.colon >> K (I, wf_del)] @ + [Args.$$$ recdef_simpN -- Args.colon >> K (Method.modifier simp_add @{here}), + Args.$$$ recdef_simpN -- Args.add -- Args.colon >> K (Method.modifier simp_add @{here}), + Args.$$$ recdef_simpN -- Args.del -- Args.colon >> K (Method.modifier simp_del @{here}), + Args.$$$ recdef_congN -- Args.colon >> K (Method.modifier cong_add @{here}), + Args.$$$ recdef_congN -- Args.add -- Args.colon >> K (Method.modifier cong_add @{here}), + Args.$$$ recdef_congN -- Args.del -- Args.colon >> K (Method.modifier cong_del @{here}), + Args.$$$ recdef_wfN -- Args.colon >> K (Method.modifier wf_add @{here}), + Args.$$$ recdef_wfN -- Args.add -- Args.colon >> K (Method.modifier wf_add @{here}), + Args.$$$ recdef_wfN -- Args.del -- Args.colon >> K (Method.modifier wf_del @{here})] @ Clasimp.clasimp_modifiers; @@ -164,7 +164,7 @@ val ctxt = (case opt_src of NONE => ctxt0 - | SOME src => #2 (Args.syntax (Method.sections recdef_modifiers) src ctxt0)); + | SOME src => #2 (Token.syntax (Method.sections recdef_modifiers) src ctxt0)); val {simps, congs, wfs} = get_hints ctxt; val ctxt' = ctxt addsimps simps |> Simplifier.del_cong @{thm imp_cong}; in (ctxt', rev (map snd congs), wfs) end; @@ -202,7 +202,8 @@ tfl_fn not_permissive ctxt congs wfs name R eqs thy; val rules = (map o map) fst (partition_eq (eq_snd (op = : int * int -> bool)) rules_idx); val simp_att = - if null tcs then [Simplifier.simp_add, Nitpick_Simps.add, Code.add_default_eqn_attribute] + if null tcs then [Simplifier.simp_add, + Named_Theorems.add @{named_theorems nitpick_simp}, Code.add_default_eqn_attribute] else []; val ((simps' :: rules', [induct']), thy) = thy @@ -291,7 +292,7 @@ val hints = @{keyword "("} |-- Parse.!!! (Parse.position @{keyword "hints"} -- Parse.args --| @{keyword ")"}) - >> uncurry Args.src; + >> uncurry Token.src; val recdef_decl = Scan.optional @@ -308,7 +309,7 @@ val defer_recdef_decl = Parse.name -- Scan.repeat1 Parse.prop -- Scan.optional - (@{keyword "("} |-- @{keyword "congs"} |-- Parse.!!! (Parse_Spec.xthms1 --| @{keyword ")"})) [] + (@{keyword "("} |-- @{keyword "congs"} |-- Parse.!!! (Parse.xthms1 --| @{keyword ")"})) [] >> (fn ((f, eqs), congs) => #1 o defer_recdef f eqs congs); val _ = diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/record.ML --- a/src/HOL/Tools/record.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/record.ML Wed Aug 27 15:52:58 2014 +0200 @@ -1785,10 +1785,10 @@ Ctr_Sugar.default_register_ctr_sugar_global T_name {ctrs = [ctr], casex = Term.dummy, discs = [], selss = [sels], exhaust = exhaust, nchotomy = Drule.dummy_thm, injects = [inject], distincts = [], case_thms = [], - case_cong = Drule.dummy_thm, weak_case_cong = Drule.dummy_thm, split = Drule.dummy_thm, + case_cong = Drule.dummy_thm, case_cong_weak = Drule.dummy_thm, split = Drule.dummy_thm, split_asm = Drule.dummy_thm, disc_defs = [], disc_thmss = [], discIs = [], sel_defs = sel_defs, - sel_thmss = [sel_thms], disc_excludesss = [], disc_exhausts = [], sel_exhausts = [], - collapses = [], expands = [], sel_splits = [], sel_split_asms = [], case_eq_ifs = []}; + sel_thmss = [sel_thms], distinct_discsss = [], exhaust_discs = [], exhaust_sels = [], + collapses = [], expands = [], split_sels = [], split_sel_asms = [], case_eq_ifs = []}; (* definition *) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Tools/try0.ML --- a/src/HOL/Tools/try0.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Tools/try0.ML Wed Aug 27 15:52:58 2014 +0200 @@ -48,18 +48,18 @@ NONE end; -val parse_method = - enclose "(" ")" - #> Outer_Syntax.scan Position.start - #> filter Token.is_proper - #> Scan.read Token.stopper Method.parse - #> (fn SOME (Method.Source src, _) => src | _ => raise Fail "expected Source"); +fun parse_method s = + enclose "(" ")" s + |> Outer_Syntax.scan (Keyword.get_lexicons ()) Position.start + |> filter Token.is_proper + |> Scan.read Token.stopper Method.parse + |> (fn SOME (Method.Source src, _) => src | _ => raise Fail "expected Source"); fun apply_named_method_on_first_goal ctxt = parse_method #> Method.method_cmd ctxt #> Method.Basic - #> (fn m => Method.Select_Goals (Method.no_combinator_info, 1, m)) + #> (fn m => Method.Combinator (Method.no_combinator_info, Method.Select_Goals 1, [m])) #> Proof.refine; fun add_attr_text (NONE, _) s = s @@ -173,10 +173,10 @@ fun string_of_xthm (xref, args) = Facts.string_of_ref xref ^ - implode (map (enclose "[" "]" o Pretty.str_of o Args.pretty_src @{context}) args); + implode (map (enclose "[" "]" o Pretty.str_of o Token.pretty_src @{context}) args); val parse_fact_refs = - Scan.repeat1 (Scan.unless (Parse.name -- Args.colon) (Parse_Spec.xthm >> string_of_xthm)); + Scan.repeat1 (Scan.unless (Parse.name -- Args.colon) (Parse.xthm >> string_of_xthm)); val parse_attr = Args.$$$ "simp" |-- Args.colon |-- parse_fact_refs >> (fn ss => (ss, [], [], [])) diff -r 1b6035697c49 -r be9815d02b10 src/HOL/Topological_Spaces.thy --- a/src/HOL/Topological_Spaces.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/HOL/Topological_Spaces.thy Wed Aug 27 15:52:58 2014 +0200 @@ -9,17 +9,8 @@ imports Main Conditionally_Complete_Lattices begin -ML {* - -structure Continuous_Intros = Named_Thms -( - val name = @{binding continuous_intros} - val description = "Structural introduction rules for continuity" -) - -*} - -setup Continuous_Intros.setup +named_theorems continuous_intros "structural introduction rules for continuity" + subsection {* Topological space *} @@ -1100,20 +1091,12 @@ lemma tendsto_eq_rhs: "(f ---> x) F \ x = y \ (f ---> y) F" by simp -ML {* - -structure Tendsto_Intros = Named_Thms -( - val name = @{binding tendsto_intros} - val description = "introduction rules for tendsto" -) - -*} - +named_theorems tendsto_intros "introduction rules for tendsto" setup {* - Tendsto_Intros.setup #> Global_Theory.add_thms_dynamic (@{binding tendsto_eq_intros}, - map_filter (try (fn thm => @{thm tendsto_eq_rhs} OF [thm])) o Tendsto_Intros.get o Context.proof_of); + fn context => + Named_Theorems.get (Context.proof_of context) @{named_theorems tendsto_intros} + |> map_filter (try (fn thm => @{thm tendsto_eq_rhs} OF [thm]))) *} lemma (in topological_space) tendsto_def: diff -r 1b6035697c49 -r be9815d02b10 src/Provers/clasimp.ML --- a/src/Provers/clasimp.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Provers/clasimp.ML Wed Aug 27 15:52:58 2014 +0200 @@ -146,7 +146,7 @@ ORELSE' (CHANGED o nodup_depth_tac (addss ctxt) n); (* slower but more general *) in - PARALLEL_GOALS (ALLGOALS (Simplifier.asm_full_simp_tac ctxt)) THEN + PARALLEL_ALLGOALS (Simplifier.asm_full_simp_tac ctxt) THEN TRY (Classical.safe_tac ctxt) THEN REPEAT_DETERM (FIRSTGOAL main_tac) THEN TRY (Classical.safe_tac (addSss ctxt)) THEN @@ -191,9 +191,9 @@ val iffN = "iff"; val iff_modifiers = - [Args.$$$ iffN -- Scan.option Args.add -- Args.colon >> K ((I, iff_add): Method.modifier), - Args.$$$ iffN -- Scan.option Args.add -- Args.query_colon >> K (I, iff_add'), - Args.$$$ iffN -- Args.del -- Args.colon >> K (I, iff_del)]; + [Args.$$$ iffN -- Scan.option Args.add -- Args.colon >> K (Method.modifier iff_add @{here}), + Args.$$$ iffN -- Scan.option Args.add -- Args.query_colon >> K (Method.modifier iff_add' @{here}), + Args.$$$ iffN -- Args.del -- Args.colon >> K (Method.modifier iff_del @{here})]; val clasimp_modifiers = Simplifier.simp_modifiers @ Splitter.split_modifiers @ diff -r 1b6035697c49 -r be9815d02b10 src/Provers/classical.ML --- a/src/Provers/classical.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Provers/classical.ML Wed Aug 27 15:52:58 2014 +0200 @@ -928,13 +928,13 @@ (* automatic methods *) val cla_modifiers = - [Args.$$$ destN -- Args.bang_colon >> K ((I, safe_dest NONE): Method.modifier), - Args.$$$ destN -- Args.colon >> K (I, haz_dest NONE), - Args.$$$ elimN -- Args.bang_colon >> K (I, safe_elim NONE), - Args.$$$ elimN -- Args.colon >> K (I, haz_elim NONE), - Args.$$$ introN -- Args.bang_colon >> K (I, safe_intro NONE), - Args.$$$ introN -- Args.colon >> K (I, haz_intro NONE), - Args.del -- Args.colon >> K (I, rule_del)]; + [Args.$$$ destN -- Args.bang_colon >> K (Method.modifier (safe_dest NONE) @{here}), + Args.$$$ destN -- Args.colon >> K (Method.modifier (haz_dest NONE) @{here}), + Args.$$$ elimN -- Args.bang_colon >> K (Method.modifier (safe_elim NONE) @{here}), + Args.$$$ elimN -- Args.colon >> K (Method.modifier (haz_elim NONE) @{here}), + Args.$$$ introN -- Args.bang_colon >> K (Method.modifier (safe_intro NONE) @{here}), + Args.$$$ introN -- Args.colon >> K (Method.modifier (haz_intro NONE) @{here}), + Args.del -- Args.colon >> K (Method.modifier rule_del @{here})]; fun cla_method tac = Method.sections cla_modifiers >> K (SIMPLE_METHOD o tac); fun cla_method' tac = Method.sections cla_modifiers >> K (SIMPLE_METHOD' o tac); diff -r 1b6035697c49 -r be9815d02b10 src/Provers/splitter.ML --- a/src/Provers/splitter.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Provers/splitter.ML Wed Aug 27 15:52:58 2014 +0200 @@ -457,9 +457,9 @@ (* methods *) val split_modifiers = - [Args.$$$ splitN -- Args.colon >> K ((I, split_add): Method.modifier), - Args.$$$ splitN -- Args.add -- Args.colon >> K (I, split_add), - Args.$$$ splitN -- Args.del -- Args.colon >> K (I, split_del)]; + [Args.$$$ splitN -- Args.colon >> K (Method.modifier split_add @{here}), + Args.$$$ splitN -- Args.add -- Args.colon >> K (Method.modifier split_add @{here}), + Args.$$$ splitN -- Args.del -- Args.colon >> K (Method.modifier split_del @{here})]; (* theory setup *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Concurrent/future.scala --- a/src/Pure/Concurrent/future.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Concurrent/future.scala Wed Aug 27 15:52:58 2014 +0200 @@ -37,7 +37,7 @@ def join: A def map[B](f: A => B): Future[B] = Future.fork { f(join) } - override def toString = + override def toString: String = peek match { case None => "" case Some(Exn.Exn(_)) => "" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/GUI/gui.scala --- a/src/Pure/GUI/gui.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/GUI/gui.scala Wed Aug 27 15:52:58 2014 +0200 @@ -7,9 +7,10 @@ package isabelle - import java.lang.{ClassLoader, ClassNotFoundException, NoSuchMethodException} -import java.awt.{Image, Component, Container, Toolkit, Window, Font, KeyboardFocusManager} +import java.io.{FileInputStream, BufferedInputStream} +import java.awt.{GraphicsEnvironment, Image, Component, Container, Toolkit, Window, Font, + KeyboardFocusManager} import java.awt.font.{TextAttribute, TransformAttribute, FontRenderContext, LineMetrics} import java.awt.geom.AffineTransform import javax.swing.{ImageIcon, JOptionPane, UIManager, JLayeredPane, JFrame, JWindow, JDialog, @@ -232,5 +233,15 @@ import scala.collection.JavaConversions._ font.deriveFont(Map(TextAttribute.TRANSFORM -> new TransformAttribute(transform))) } + + def font(family: String = "IsabelleText", size: Int = 1, bold: Boolean = false): Font = + new Font(family, if (bold) Font.BOLD else Font.PLAIN, size) + + def install_fonts() + { + val ge = GraphicsEnvironment.getLocalGraphicsEnvironment() + for (font <- Path.split(Isabelle_System.getenv_strict("ISABELLE_FONTS"))) + ge.registerFont(Font.createFont(Font.TRUETYPE_FONT, font.file)) + } } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/GUI/html5_panel.scala --- a/src/Pure/GUI/html5_panel.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/GUI/html5_panel.scala Wed Aug 27 15:52:58 2014 +0200 @@ -1,5 +1,5 @@ /* Title: Pure/GUI/html5_panel.scala - Module: PIDE-GUI + Module: PIDE-JFX Author: Makarius HTML5 panel based on Java FX WebView. @@ -54,7 +54,7 @@ class HTML5_Panel extends javafx.embed.swing.JFXPanel { private val future = - JFX_Thread.future { + JFX_GUI.Thread.future { val pane = new Web_View_Workaround val web_view = pane.web_view diff -r 1b6035697c49 -r be9815d02b10 src/Pure/GUI/jfx_gui.scala --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/GUI/jfx_gui.scala Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,55 @@ +/* Title: Pure/GUI/jfx_thread.scala + Module: PIDE-JFX + Author: Makarius + +Basic GUI tools (for Java FX). +*/ + +package isabelle + + +import java.io.{FileInputStream, BufferedInputStream} + +import javafx.application.{Platform => JFX_Platform} +import javafx.scene.text.{Font => JFX_Font} + + +object JFX_GUI +{ + /* evaluation within the Java FX application thread */ + + object Thread + { + def assert() = Predef.assert(JFX_Platform.isFxApplicationThread()) + def require() = Predef.require(JFX_Platform.isFxApplicationThread()) + + def later(body: => Unit) + { + if (JFX_Platform.isFxApplicationThread()) body + else JFX_Platform.runLater(new Runnable { def run = body }) + } + + def future[A](body: => A): Future[A] = + { + if (JFX_Platform.isFxApplicationThread()) Future.value(body) + else { + val promise = Future.promise[A] + later { promise.fulfill_result(Exn.capture(body)) } + promise + } + } + } + + + /* Isabelle fonts */ + + def install_fonts() + { + for (font <- Path.split(Isabelle_System.getenv_strict("ISABELLE_FONTS"))) { + val stream = new BufferedInputStream(new FileInputStream(font.file)) + try { JFX_Font.loadFont(stream, 1.0) } + finally { stream.close } + } + } + +} diff -r 1b6035697c49 -r be9815d02b10 src/Pure/GUI/jfx_thread.scala --- a/src/Pure/GUI/jfx_thread.scala Wed Aug 27 11:33:00 2014 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -/* Title: Pure/GUI/jfx_thread.scala - Module: PIDE-GUI - Author: Makarius - -Evaluation within the Java FX application thread. -*/ - -package isabelle - -import javafx.application.{Platform => JFX_Platform} - - -object JFX_Thread -{ - /* checks */ - - def assert() = Predef.assert(JFX_Platform.isFxApplicationThread()) - def require() = Predef.require(JFX_Platform.isFxApplicationThread()) - - - /* asynchronous context switch */ - - def later(body: => Unit) - { - if (JFX_Platform.isFxApplicationThread()) body - else JFX_Platform.runLater(new Runnable { def run = body }) - } - - def future[A](body: => A): Future[A] = - { - if (JFX_Platform.isFxApplicationThread()) Future.value(body) - else { - val promise = Future.promise[A] - later { promise.fulfill_result(Exn.capture(body)) } - promise - } - } -} diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/binding.ML --- a/src/Pure/General/binding.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/binding.ML Wed Aug 27 15:52:58 2014 +0200 @@ -31,6 +31,7 @@ val conceal: binding -> binding val pretty: binding -> Pretty.T val print: binding -> string + val pp: binding -> Pretty.T val bad: binding -> string val check: binding -> unit end; @@ -133,6 +134,8 @@ val print = Pretty.str_of o pretty; +val pp = pretty o set_pos Position.none; + (* check *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/name_space.ML --- a/src/Pure/General/name_space.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/name_space.ML Wed Aug 27 15:52:58 2014 +0200 @@ -14,7 +14,7 @@ val kind_of: T -> string val defined_entry: T -> string -> bool val the_entry: T -> string -> - {concealed: bool, group: serial option, theory_name: string, pos: Position.T, id: serial} + {concealed: bool, group: serial option, theory_name: string, pos: Position.T, serial: serial} val entry_ord: T -> string * string -> order val markup: T -> string -> Markup.T val is_concealed: T -> string -> bool @@ -92,10 +92,10 @@ group: serial option, theory_name: string, pos: Position.T, - id: serial}; + serial: serial}; -fun entry_markup def kind (name, {pos, id, ...}: entry) = - Markup.properties (Position.entity_properties_of def id pos) (Markup.entity kind name); +fun entry_markup def kind (name, {pos, serial, ...}: entry) = + Markup.properties (Position.entity_properties_of def serial pos) (Markup.entity kind name); fun print_entry_ref kind (name, entry) = quote (Markup.markup (entry_markup false kind (name, entry)) name); @@ -152,7 +152,7 @@ NONE => error (undefined kind name) | SOME (_, entry) => entry); -fun entry_ord space = int_ord o pairself (#id o the_entry space); +fun entry_ord space = int_ord o pairself (#serial o the_entry space); fun markup (Name_Space {kind, entries, ...}) name = (case Change_Table.lookup entries name of @@ -275,7 +275,7 @@ else (Library.merge (op =) (names1, names2), Library.merge (op =) (names1', names2')))); val entries' = (entries1, entries2) |> Change_Table.join (fn name => fn ((_, entry1), (_, entry2)) => - if #id entry1 = #id entry2 then raise Change_Table.SAME + if #serial entry1 = #serial entry2 then raise Change_Table.SAME else err_dup kind' (name, entry1) (name, entry2) Position.none); in make_name_space (kind', internals', entries') end; @@ -448,7 +448,7 @@ group = group, theory_name = theory_name, pos = pos, - id = serial ()}; + serial = serial ()}; val space' = space |> map_name_space (fn (kind, internals, entries) => let diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/position.ML --- a/src/Pure/General/position.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/position.ML Wed Aug 27 15:52:58 2014 +0200 @@ -153,9 +153,9 @@ val def_properties_of = properties_of #> map (fn (x, y) => ("def_" ^ x, y)); -fun entity_properties_of def id pos = - if def then (Markup.defN, Markup.print_int id) :: properties_of pos - else (Markup.refN, Markup.print_int id) :: def_properties_of pos; +fun entity_properties_of def serial pos = + if def then (Markup.defN, Markup.print_int serial) :: properties_of pos + else (Markup.refN, Markup.print_int serial) :: def_properties_of pos; fun default_properties default props = if exists (member (op =) Markup.position_properties o #1) props then props diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/position.scala --- a/src/Pure/General/position.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/position.scala Wed Aug 27 15:52:58 2014 +0200 @@ -54,7 +54,7 @@ object Range { - def apply(range: Symbol.Range): T = Offset(range.start) ::: Offset(range.stop) + def apply(range: Symbol.Range): T = Offset(range.start) ::: End_Offset(range.stop) def unapply(pos: T): Option[Symbol.Range] = (pos, pos) match { case (Offset(start), End_Offset(stop)) if start <= stop => Some(Text.Range(start, stop)) @@ -63,35 +63,35 @@ } } - object Id_Offset + object Id_Offset0 { def unapply(pos: T): Option[(Long, Symbol.Offset)] = - (pos, pos) match { - case (Id(id), Offset(offset)) => Some((id, offset)) + pos match { + case Id(id) => Some((id, Offset.unapply(pos) getOrElse 0)) case _ => None } } - object Def_Id_Offset + object Def_Id_Offset0 { def unapply(pos: T): Option[(Long, Symbol.Offset)] = - (pos, pos) match { - case (Def_Id(id), Def_Offset(offset)) => Some((id, offset)) + pos match { + case Def_Id(id) => Some((id, Def_Offset.unapply(pos) getOrElse 0)) case _ => None } } - object Reported + object Identified { - def unapply(pos: T): Option[(Long, Symbol.Text_Chunk.Name, Symbol.Range)] = - (pos, pos) match { - case (Id(id), Range(range)) => + def unapply(pos: T): Option[(Long, Symbol.Text_Chunk.Name)] = + pos match { + case Id(id) => val chunk_name = pos match { case File(name) => Symbol.Text_Chunk.File(name) case _ => Symbol.Text_Chunk.Default } - Some((id, chunk_name, range)) + Some((id, chunk_name)) case _ => None } } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/properties.scala --- a/src/Pure/General/properties.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/properties.scala Wed Aug 27 15:52:58 2014 +0200 @@ -27,7 +27,7 @@ object Int { - def apply(x: scala.Int): java.lang.String = x.toString + def apply(x: scala.Int): java.lang.String = Library.signed_string_of_int(x) def unapply(s: java.lang.String): Option[scala.Int] = try { Some(Integer.parseInt(s)) } catch { case _: NumberFormatException => None } @@ -35,7 +35,7 @@ object Long { - def apply(x: scala.Long): java.lang.String = x.toString + def apply(x: scala.Long): java.lang.String = Library.signed_string_of_long(x) def unapply(s: java.lang.String): Option[scala.Long] = try { Some(java.lang.Long.parseLong(s)) } catch { case _: NumberFormatException => None } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/symbol_pos.ML --- a/src/Pure/General/symbol_pos.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/symbol_pos.ML Wed Aug 27 15:52:58 2014 +0200 @@ -41,6 +41,7 @@ val implode_range: Position.T -> Position.T -> T list -> text * Position.range val explode: text * Position.T -> T list type source = {delimited: bool, text: text, pos: Position.T} + val source_explode: source -> T list val source_content: source -> string * Position.T val scan_ident: T list -> T list * T list val is_identifier: string -> bool @@ -261,6 +262,8 @@ type source = {delimited: bool, text: text, pos: Position.T}; +fun source_explode {delimited = _, text, pos} = explode (text, pos); + fun source_content {delimited = _, text, pos} = let val syms = explode (text, pos) in (content syms, pos) end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/time.scala --- a/src/Pure/General/time.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/time.scala Wed Aug 27 15:52:58 2014 +0200 @@ -40,7 +40,7 @@ def is_zero: Boolean = ms == 0 def is_relevant: Boolean = ms >= 1 - override def toString = Time.print_seconds(seconds) + override def toString: String = Time.print_seconds(seconds) def message: String = toString + "s" } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/General/timing.scala --- a/src/Pure/General/timing.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/General/timing.scala Wed Aug 27 15:52:58 2014 +0200 @@ -38,6 +38,6 @@ def message: String = elapsed.message + " elapsed time, " + cpu.message + " cpu time, " + gc.message + " GC time" - override def toString = message + override def toString: String = message } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/args.ML --- a/src/Pure/Isar/args.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/args.ML Wed Aug 27 15:52:58 2014 +0200 @@ -1,22 +1,12 @@ (* Title: Pure/Isar/args.ML Author: Markus Wenzel, TU Muenchen -Parsing with implicit value assignment. Concrete argument syntax of +Quasi-inner syntax based on outer tokens: concrete argument syntax of attributes, methods etc. *) signature ARGS = sig - type src - val src: xstring * Position.T -> Token.T list -> src - val name_of_src: src -> string * Position.T - val range_of_src: src -> Position.T - val unparse_src: src -> string list - val pretty_src: Proof.context -> src -> Pretty.T - val check_src: Proof.context -> 'a Name_Space.table -> src -> src * 'a - val transform_values: morphism -> src -> src - val init_assignable: src -> src - val closure: src -> src val context: Proof.context context_parser val theory: theory context_parser val $$$ : string -> string parser @@ -43,17 +33,20 @@ val symbol: string parser val liberal_name: string parser val var: indexname parser - val internal_text: string parser + val internal_source: Token.src parser + val internal_name: (string * morphism) parser val internal_typ: typ parser val internal_term: term parser val internal_fact: thm list parser val internal_attribute: (morphism -> attribute) parser - val named_text: (string -> string) -> string parser + val internal_declaration: declaration parser + val named_source: (Token.T -> Token.src) -> Token.src parser val named_typ: (string -> typ) -> typ parser val named_term: (string -> term) -> term parser - val named_fact: (string -> thm list) -> thm list parser - val named_attribute: - (string * Position.T -> morphism -> attribute) -> (morphism -> attribute) parser + val named_fact: (string -> string option * thm list) -> thm list parser + val named_attribute: (string * Position.T -> morphism -> attribute) -> + (morphism -> attribute) parser + val text_declaration: (Symbol_Pos.source -> declaration) -> declaration parser val typ_abbrev: typ context_parser val typ: typ context_parser val term: term context_parser @@ -63,82 +56,13 @@ val type_name: {proper: bool, strict: bool} -> string context_parser val const: {proper: bool, strict: bool} -> string context_parser val goal_spec: ((int -> tactic) -> tactic) context_parser - val attribs: (xstring * Position.T -> string) -> src list parser - val opt_attribs: (xstring * Position.T -> string) -> src list parser - val syntax_generic: 'a context_parser -> src -> Context.generic -> 'a * Context.generic - val syntax: 'a context_parser -> src -> Proof.context -> 'a * Proof.context + val attribs: (xstring * Position.T -> string) -> Token.src list parser + val opt_attribs: (xstring * Position.T -> string) -> Token.src list parser end; structure Args: ARGS = struct -(** datatype src **) - -datatype src = - Src of - {name: string * Position.T, - args: Token.T list, - output_info: (string * Markup.T) option}; - -fun src name args = Src {name = name, args = args, output_info = NONE}; - -fun name_of_src (Src {name, ...}) = name; - -fun range_of_src (Src {name = (_, pos), args, ...}) = - if null args then pos - else Position.set_range (pos, #2 (Token.range_of args)); - -fun unparse_src (Src {args, ...}) = map Token.unparse args; - -fun pretty_src ctxt src = - let - val Src {name = (name, _), args, output_info} = src; - val prt_name = - (case output_info of - NONE => Pretty.str name - | SOME (_, markup) => Pretty.mark_str (markup, name)); - val prt_thm = Pretty.backquote o Display.pretty_thm ctxt; - fun prt_arg arg = - (case Token.get_value arg of - SOME (Token.Literal markup) => - let val x = Token.content_of arg - in Pretty.mark_str (Token.keyword_markup markup x, x) end - | SOME (Token.Text s) => Pretty.str (quote s) - | SOME (Token.Typ T) => Syntax.pretty_typ ctxt T - | SOME (Token.Term t) => Syntax.pretty_term ctxt t - | SOME (Token.Fact ths) => Pretty.enclose "(" ")" (Pretty.breaks (map prt_thm ths)) - | _ => Pretty.mark_str (Token.markup arg, Token.unparse arg)); - in Pretty.block (Pretty.breaks (prt_name :: map prt_arg args)) end; - - -(* check *) - -fun check_src ctxt table (Src {name = (xname, pos), args, output_info = _}) = - let - val (name, x) = Name_Space.check (Context.Proof ctxt) table (xname, pos); - val space = Name_Space.space_of_table table; - val kind = Name_Space.kind_of space; - val markup = Name_Space.markup space name; - in (Src {name = (name, pos), args = args, output_info = SOME (kind, markup)}, x) end; - - -(* values *) - -fun map_args f (Src {name, args, output_info}) = - Src {name = name, args = map f args, output_info = output_info}; - -fun transform_values phi = map_args (Token.map_value - (fn Token.Typ T => Token.Typ (Morphism.typ phi T) - | Token.Term t => Token.Term (Morphism.term phi t) - | Token.Fact ths => Token.Fact (Morphism.fact phi ths) - | Token.Attribute att => Token.Attribute (Morphism.transform phi att) - | tok => tok)); - -val init_assignable = map_args Token.init_assignable; -val closure = map_args Token.closure; - - - (** argument scanners **) (* context *) @@ -209,23 +133,32 @@ fun evaluate mk eval arg = let val x = eval arg in (Token.assign (SOME (mk x)) arg; x) end; -val internal_text = value (fn Token.Text s => s); +val internal_source = value (fn Token.Source src => src); +val internal_name = value (fn Token.Name a => a); val internal_typ = value (fn Token.Typ T => T); val internal_term = value (fn Token.Term t => t); -val internal_fact = value (fn Token.Fact ths => ths); +val internal_fact = value (fn Token.Fact (_, ths) => ths); val internal_attribute = value (fn Token.Attribute att => att); +val internal_declaration = value (fn Token.Declaration decl => decl); -fun named_text intern = internal_text || named >> evaluate Token.Text (intern o Token.content_of); -fun named_typ readT = internal_typ || named >> evaluate Token.Typ (readT o Token.inner_syntax_of); +fun named_source read = internal_source || named >> evaluate Token.Source read; + +fun named_typ read = internal_typ || named >> evaluate Token.Typ (read o Token.inner_syntax_of); fun named_term read = internal_term || named >> evaluate Token.Term (read o Token.inner_syntax_of); -fun named_fact get = internal_fact || named >> evaluate Token.Fact (get o Token.content_of) || - alt_string >> evaluate Token.Fact (get o Token.inner_syntax_of); +fun named_fact get = + internal_fact || + named >> evaluate Token.Fact (get o Token.content_of) >> #2 || + alt_string >> evaluate Token.Fact (get o Token.inner_syntax_of) >> #2; fun named_attribute att = internal_attribute || named >> evaluate Token.Attribute (fn tok => att (Token.content_of tok, Token.pos_of tok)); +fun text_declaration read = + internal_declaration || + text_token >> evaluate Token.Declaration (read o Token.source_position_of); + (* terms and types *) @@ -265,43 +198,10 @@ fun attribs check = let fun intern tok = check (Token.content_of tok, Token.pos_of tok); - val attrib_name = internal_text || (symbolic || named) >> evaluate Token.Text intern; - val attrib = Parse.position attrib_name -- Parse.!!! Parse.args >> uncurry src; + val attrib_name = internal_name >> #1 || (symbolic || named) >> evaluate Token.name0 intern; + val attrib = Parse.position attrib_name -- Parse.!!! Parse.args >> uncurry Token.src; in $$$ "[" |-- Parse.!!! (Parse.list attrib --| $$$ "]") end; fun opt_attribs check = Scan.optional (attribs check) []; - - -(** syntax wrapper **) - -fun syntax_generic scan (Src {name = (name, pos), args = args0, output_info}) context = - let - val args1 = map Token.init_assignable args0; - fun reported_text () = - if Context_Position.is_visible_generic context then - ((pos, Markup.operator) :: maps (Token.reports_of_value o Token.closure) args1) - |> map (fn (p, m) => Position.reported_text p m "") - else []; - in - (case Scan.error (Scan.finite' Token.stopper (Scan.option scan)) (context, args1) of - (SOME x, (context', [])) => - let val _ = Output.report (reported_text ()) - in (x, context') end - | (_, (_, args2)) => - let - val print_name = - (case output_info of - NONE => quote name - | SOME (kind, markup) => plain_words kind ^ " " ^ quote (Markup.markup markup name)); - val print_args = - if null args2 then "" else ":\n " ^ space_implode " " (map Token.print args2); - in - error ("Bad arguments for " ^ print_name ^ Position.here pos ^ print_args ^ - Markup.markup_report (implode (reported_text ()))) - end) - end; - -fun syntax scan src = apsnd Context.the_proof o syntax_generic scan src o Context.Proof; - end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/attrib.ML --- a/src/Pure/Isar/attrib.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/attrib.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,19 +6,22 @@ signature ATTRIB = sig - type src = Args.src - type binding = binding * src list + type binding = binding * Token.src list val empty_binding: binding val is_empty_binding: binding -> bool val print_attributes: Proof.context -> unit + val define_global: Binding.binding -> (Token.src -> attribute) -> + string -> theory -> string * theory + val define: Binding.binding -> (Token.src -> attribute) -> + string -> local_theory -> string * local_theory val check_name_generic: Context.generic -> xstring * Position.T -> string val check_name: Proof.context -> xstring * Position.T -> string - val check_src: Proof.context -> src -> src - val pretty_attribs: Proof.context -> src list -> Pretty.T list - val attribute: Proof.context -> src -> attribute - val attribute_global: theory -> src -> attribute - val attribute_cmd: Proof.context -> src -> attribute - val attribute_cmd_global: theory -> src -> attribute + val check_src: Proof.context -> Token.src -> Token.src + val pretty_attribs: Proof.context -> Token.src list -> Pretty.T list + val attribute: Proof.context -> Token.src -> attribute + val attribute_global: theory -> Token.src -> attribute + val attribute_cmd: Proof.context -> Token.src -> attribute + val attribute_cmd_global: theory -> Token.src -> attribute val map_specs: ('a list -> 'att list) -> (('c * 'a list) * 'b) list -> (('c * 'att list) * 'b) list val map_facts: ('a list -> 'att list) -> @@ -27,24 +30,32 @@ val map_facts_refs: ('a list -> 'att list) -> ('b -> 'fact) -> (('c * 'a list) * ('b * 'a list) list) list -> (('c * 'att list) * ('fact * 'att list) list) list - val global_notes: string -> (binding * (thm list * src list) list) list -> + val global_notes: string -> (binding * (thm list * Token.src list) list) list -> theory -> (string * thm list) list * theory - val local_notes: string -> (binding * (thm list * src list) list) list -> + val local_notes: string -> (binding * (thm list * Token.src list) list) list -> Proof.context -> (string * thm list) list * Proof.context - val generic_notes: string -> (binding * (thm list * src list) list) list -> + val generic_notes: string -> (binding * (thm list * Token.src list) list) list -> Context.generic -> (string * thm list) list * Context.generic - val eval_thms: Proof.context -> (Facts.ref * src list) list -> thm list + val eval_thms: Proof.context -> (Facts.ref * Token.src list) list -> thm list + val attribute_syntax: attribute context_parser -> Token.src -> attribute val setup: Binding.binding -> attribute context_parser -> string -> theory -> theory - val attribute_setup: bstring * Position.T -> Symbol_Pos.source -> string -> theory -> theory - val internal: (morphism -> attribute) -> src + val local_setup: Binding.binding -> attribute context_parser -> string -> + local_theory -> local_theory + val attribute_setup: bstring * Position.T -> Symbol_Pos.source -> string -> + local_theory -> local_theory + val internal: (morphism -> attribute) -> Token.src val add_del: attribute -> attribute -> attribute context_parser - val thm_sel: Facts.interval list parser val thm: thm context_parser val thms: thm list context_parser val multi_thm: thm list context_parser + val check_attribs: Proof.context -> Token.src list -> Token.src list + val read_attribs: Proof.context -> Symbol_Pos.source -> Token.src list + val transform_facts: morphism -> + (Attrib.binding * (thm list * Token.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list val partial_evaluation: Proof.context -> - (binding * (thm list * Args.src list) list) list -> - (binding * (thm list * Args.src list) list) list + (binding * (thm list * Token.src list) list) list -> + (binding * (thm list * Token.src list) list) list val print_options: Proof.context -> unit val config_bool: Binding.binding -> (Context.generic -> bool) -> bool Config.T * (theory -> theory) @@ -73,9 +84,7 @@ (* source and bindings *) -type src = Args.src; - -type binding = binding * src list; +type binding = binding * Token.src list; val empty_binding: binding = (Binding.empty, []); fun is_empty_binding ((b, srcs): binding) = Binding.is_empty b andalso null srcs; @@ -86,19 +95,25 @@ (* theory data *) -structure Attributes = Theory_Data +structure Attributes = Generic_Data ( - type T = ((src -> attribute) * string) Name_Space.table; + type T = ((Token.src -> attribute) * string) Name_Space.table; val empty : T = Name_Space.empty_table "attribute"; val extend = I; fun merge data : T = Name_Space.merge_tables data; ); -val get_attributes = Attributes.get o Context.theory_of; +val get_attributes = Attributes.get o Context.Proof; + +fun transfer_attributes ctxt = + let + val attribs0 = Attributes.get (Context.Theory (Proof_Context.theory_of ctxt)); + val attribs' = Name_Space.merge_tables (attribs0, get_attributes ctxt); + in Context.proof_map (Attributes.put attribs') ctxt end; fun print_attributes ctxt = let - val attribs = get_attributes (Context.Proof ctxt); + val attribs = get_attributes ctxt; fun prt_attr (name, (_, "")) = Pretty.mark_str name | prt_attr (name, (_, comment)) = Pretty.block @@ -108,33 +123,47 @@ |> Pretty.writeln_chunks end; -val attribute_space = Name_Space.space_of_table o get_attributes o Context.Proof; +val attribute_space = Name_Space.space_of_table o get_attributes; + + +(* define *) -fun add_attribute name att comment thy = thy - |> Attributes.map (Name_Space.define (Context.Theory thy) true (name, (att, comment)) #> snd); +fun define_global binding att comment thy = + let + val context = Context.Theory thy; + val (name, attribs') = + Name_Space.define context true (binding, (att, comment)) (Attributes.get context); + in (name, Context.the_theory (Attributes.put attribs' context)) end; + +fun define binding att comment = + Local_Theory.background_theory_result (define_global binding att comment) + #-> (fn name => + Local_Theory.map_contexts (K transfer_attributes) + #> Local_Theory.generic_alias Attributes.map binding name + #> pair name); (* check *) -fun check_name_generic context = #1 o Name_Space.check context (get_attributes context); +fun check_name_generic context = #1 o Name_Space.check context (Attributes.get context); val check_name = check_name_generic o Context.Proof; fun check_src ctxt src = - (Context_Position.report ctxt (Args.range_of_src src) Markup.language_attribute; - #1 (Args.check_src ctxt (get_attributes (Context.Proof ctxt)) src)); + (Context_Position.report ctxt (Token.range_of_src src) Markup.language_attribute; + #1 (Token.check_src ctxt (get_attributes ctxt) src)); (* pretty printing *) fun pretty_attribs _ [] = [] - | pretty_attribs ctxt srcs = [Pretty.enum "," "[" "]" (map (Args.pretty_src ctxt) srcs)]; + | pretty_attribs ctxt srcs = [Pretty.enum "," "[" "]" (map (Token.pretty_src ctxt) srcs)]; (* get attributes *) fun attribute_generic context = - let val table = get_attributes context - in fn src => #1 (Name_Space.get table (#1 (Args.name_of_src src))) src end; + let val table = Attributes.get context + in fn src => #1 (Name_Space.get table (#1 (Token.name_of_src src))) src end; val attribute = attribute_generic o Context.Proof; val attribute_global = attribute_generic o Context.Theory; @@ -171,23 +200,27 @@ (* attribute setup *) -fun setup name scan = - add_attribute name - (fn src => fn (ctxt, th) => - let val (a, ctxt') = Args.syntax_generic scan src ctxt in a (ctxt', th) end); +fun attribute_syntax scan src (context, th) = + let val (a, context') = Token.syntax_generic scan src context in a (context', th) end; + +fun setup binding scan comment = define_global binding (attribute_syntax scan) comment #> snd; +fun local_setup binding scan comment = define binding (attribute_syntax scan) comment #> snd; fun attribute_setup name source cmt = - Context.theory_map (ML_Context.expression (#pos source) + (ML_Lex.read Position.none ("(" ^ ML_Syntax.make_binding name ^ ", ") @ + ML_Lex.read_source false source @ + ML_Lex.read Position.none (", " ^ ML_Syntax.print_string cmt ^ ")")) + |> ML_Context.expression (#pos source) "val (name, scan, comment): binding * attribute context_parser * string" - "Context.map_theory (Attrib.setup name scan comment)" - (ML_Lex.read Position.none ("(" ^ ML_Syntax.make_binding name ^ ", ") @ - ML_Lex.read_source false source @ - ML_Lex.read Position.none (", " ^ ML_Syntax.print_string cmt ^ ")"))); + "Context.map_proof (Attrib.local_setup name scan comment)" + |> Context.proof_map; (* internal attribute *) -fun internal att = Args.src ("Pure.attribute", Position.none) [Token.mk_attribute att]; +fun internal att = + Token.src ("Pure.attribute", Position.none) + [Token.make_value "" (Token.Attribute att)]; val _ = Theory.setup (setup (Binding.make ("attribute", @{here})) @@ -203,11 +236,6 @@ (** parsing attributed theorems **) -val thm_sel = Parse.$$$ "(" |-- Parse.list1 - (Parse.nat --| Parse.minus -- Parse.nat >> Facts.FromTo || - Parse.nat --| Parse.minus >> Facts.From || - Parse.nat >> Facts.Single) --| Parse.$$$ ")"; - local val fact_name = Args.internal_fact >> K "" || Args.name; @@ -216,7 +244,9 @@ let val get = Proof_Context.get_fact_generic context; val get_fact = get o Facts.Fact; - fun get_named pos name = get (Facts.Named ((name, pos), NONE)); + fun get_named is_sel pos name = + let val (a, ths) = get (Facts.Named ((name, pos), NONE)) + in (if is_sel then NONE else a, ths) end; in Parse.$$$ "[" |-- Args.attribs (check_name_generic context) --| Parse.$$$ "]" >> (fn srcs => let @@ -226,9 +256,10 @@ || (Scan.ahead Args.alt_name -- Args.named_fact get_fact >> (fn (s, fact) => ("", Facts.Fact s, fact)) || - Scan.ahead (Parse.position fact_name) :|-- (fn (name, pos) => - Args.named_fact (get_named pos) -- Scan.option thm_sel - >> (fn (fact, sel) => (name, Facts.Named ((name, pos), sel), fact)))) + Scan.ahead (Parse.position fact_name -- Scan.option Parse.thm_sel) :|-- + (fn ((name, pos), sel) => + Args.named_fact (get_named (is_some sel) pos) --| Scan.option Parse.thm_sel + >> (fn fact => (name, Facts.Named ((name, pos), sel), fact)))) -- Args.opt_attribs (check_name_generic context) >> (fn ((name, thmref, fact), srcs) => let val ths = Facts.select thmref fact; @@ -247,6 +278,32 @@ end; +(* read attribute source *) + +fun check_attribs ctxt raw_srcs = + let + val srcs = map (check_src ctxt) raw_srcs; + val _ = map (attribute ctxt) srcs; + in srcs end; + +fun read_attribs ctxt source = + let + val syms = Symbol_Pos.source_explode source; + val lex = #1 (Keyword.get_lexicons ()); + in + (case Token.read lex Parse.attribs (syms, #pos source) of + [raw_srcs] => check_attribs ctxt raw_srcs + | _ => error ("Malformed attributes" ^ Position.here (#pos source))) + end; + + +(* transform fact expressions *) + +fun transform_facts phi = map (fn ((a, atts), bs) => + ((Morphism.binding phi a, map (Token.transform_src phi) atts), + bs |> map (fn (ths, btts) => (Morphism.fact phi ths, map (Token.transform_src phi) btts)))); + + (** partial evaluation -- observing rule/declaration/mixed attributes **) @@ -256,13 +313,13 @@ fun apply_att src (context, th) = let - val src1 = Args.init_assignable src; + val src1 = Token.init_assignable_src src; val result = attribute_generic context src1 (context, th); - val src2 = Args.closure src1; + val src2 = Token.closure_src src1; in (src2, result) end; fun err msg src = - let val (name, pos) = Args.name_of_src src + let val (name, pos) = Token.name_of_src src in error (msg ^ " " ^ quote name ^ Position.here pos) end; fun eval src ((th, dyn), (decls, context)) = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/bundle.ML --- a/src/Pure/Isar/bundle.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/bundle.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,13 +6,13 @@ signature BUNDLE = sig - type bundle = (thm list * Args.src list) list + type bundle = (thm list * Token.src list) list val check: Proof.context -> xstring * Position.T -> string val get_bundle: Proof.context -> string -> bundle val get_bundle_cmd: Proof.context -> xstring * Position.T -> bundle - val bundle: binding * (thm list * Args.src list) list -> + val bundle: binding * (thm list * Token.src list) list -> (binding * typ option * mixfix) list -> local_theory -> local_theory - val bundle_cmd: binding * (Facts.ref * Args.src list) list -> + val bundle_cmd: binding * (Facts.ref * Token.src list) list -> (binding * string option * mixfix) list -> local_theory -> local_theory val includes: string list -> Proof.context -> Proof.context val includes_cmd: (xstring * Position.T) list -> Proof.context -> Proof.context @@ -31,10 +31,10 @@ (* maintain bundles *) -type bundle = (thm list * Args.src list) list; +type bundle = (thm list * Token.src list) list; fun transform_bundle phi : bundle -> bundle = - map (fn (fact, atts) => (Morphism.fact phi fact, map (Args.transform_values phi) atts)); + map (fn (fact, atts) => (Morphism.fact phi fact, map (Token.transform_src phi) atts)); structure Data = Generic_Data ( diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/calculation.ML --- a/src/Pure/Isar/calculation.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/calculation.ML Wed Aug 27 15:52:58 2014 +0200 @@ -14,10 +14,10 @@ val sym_del: attribute val symmetric: attribute val also: thm list option -> bool -> Proof.state -> Proof.state Seq.result Seq.seq - val also_cmd: (Facts.ref * Attrib.src list) list option -> + val also_cmd: (Facts.ref * Token.src list) list option -> bool -> Proof.state -> Proof.state Seq.result Seq.seq val finally: thm list option -> bool -> Proof.state -> Proof.state Seq.result Seq.seq - val finally_cmd: (Facts.ref * Attrib.src list) list option -> bool -> + val finally_cmd: (Facts.ref * Token.src list) list option -> bool -> Proof.state -> Proof.state Seq.result Seq.seq val moreover: bool -> Proof.state -> Proof.state val ultimately: bool -> Proof.state -> Proof.state @@ -201,7 +201,7 @@ (* outer syntax *) val calc_args = - Scan.option (@{keyword "("} |-- Parse.!!! ((Parse_Spec.xthms1 --| @{keyword ")"}))); + Scan.option (@{keyword "("} |-- Parse.!!! ((Parse.xthms1 --| @{keyword ")"}))); val _ = Outer_Syntax.command @{command_spec "also"} "combine calculation and current facts" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/code.ML --- a/src/Pure/Isar/code.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/code.ML Wed Aug 27 15:52:58 2014 +0200 @@ -49,13 +49,13 @@ val add_nbe_eqn: thm -> theory -> theory val add_abs_eqn: thm -> theory -> theory val add_abs_eqn_attribute: attribute - val add_abs_eqn_attrib: Attrib.src + val add_abs_eqn_attrib: Token.src val add_default_eqn: thm -> theory -> theory val add_default_eqn_attribute: attribute - val add_default_eqn_attrib: Attrib.src + val add_default_eqn_attrib: Token.src val add_nbe_default_eqn: thm -> theory -> theory val add_nbe_default_eqn_attribute: attribute - val add_nbe_default_eqn_attrib: Attrib.src + val add_nbe_default_eqn_attrib: Token.src val del_eqn: thm -> theory -> theory val del_eqns: string -> theory -> theory val del_exception: string -> theory -> theory diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/element.ML --- a/src/Pure/Isar/element.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/element.ML Wed Aug 27 15:52:58 2014 +0200 @@ -17,18 +17,15 @@ Constrains of (string * 'typ) list | Assumes of (Attrib.binding * ('term * 'term list) list) list | Defines of (Attrib.binding * ('term * 'term list)) list | - Notes of string * (Attrib.binding * ('fact * Attrib.src list) list) list + Notes of string * (Attrib.binding * ('fact * Token.src list) list) list type context = (string, string, Facts.ref) ctxt type context_i = (typ, term, thm list) ctxt val map_ctxt: {binding: binding -> binding, typ: 'typ -> 'a, term: 'term -> 'b, - pattern: 'term -> 'b, fact: 'fact -> 'c, attrib: Attrib.src -> Attrib.src} -> + pattern: 'term -> 'b, fact: 'fact -> 'c, attrib: Token.src -> Token.src} -> ('typ, 'term, 'fact) ctxt -> ('a, 'b, 'c) ctxt - val map_ctxt_attrib: (Attrib.src -> Attrib.src) -> + val map_ctxt_attrib: (Token.src -> Token.src) -> ('typ, 'term, 'fact) ctxt -> ('typ, 'term, 'fact) ctxt val transform_ctxt: morphism -> context_i -> context_i - val transform_facts: morphism -> - (Attrib.binding * (thm list * Args.src list) list) list -> - (Attrib.binding * (thm list * Args.src list) list) list val pretty_stmt: Proof.context -> statement_i -> Pretty.T list val pretty_ctxt: Proof.context -> context_i -> Pretty.T list val pretty_statement: Proof.context -> string -> thm -> Pretty.T @@ -78,7 +75,7 @@ Constrains of (string * 'typ) list | Assumes of (Attrib.binding * ('term * 'term list) list) list | Defines of (Attrib.binding * ('term * 'term list)) list | - Notes of string * (Attrib.binding * ('fact * Attrib.src list) list) list; + Notes of string * (Attrib.binding * ('fact * Token.src list) list) list; type context = (string, string, Facts.ref) ctxt; type context_i = (typ, term, thm list) ctxt; @@ -103,10 +100,7 @@ term = Morphism.term phi, pattern = Morphism.term phi, fact = Morphism.fact phi, - attrib = Args.transform_values phi}; - -fun transform_facts phi facts = - Notes ("", facts) |> transform_ctxt phi |> (fn Notes (_, facts') => facts'); + attrib = Token.transform_src phi}; @@ -270,8 +264,8 @@ local val refine_witness = - Proof.refine (Method.Basic (K (RAW_METHOD - (K (ALLGOALS (CONJUNCTS (ALLGOALS (CONJUNCTS (TRYALL (rtac Drule.protectI)))))))))); + Proof.refine (Method.Basic (K (NO_CASES o + K (ALLGOALS (CONJUNCTS (ALLGOALS (CONJUNCTS (TRYALL (rtac Drule.protectI))))))))); fun gen_witness_proof proof after_qed wit_propss eq_props = let @@ -509,14 +503,14 @@ fun activate_i elem ctxt = let val elem' = - (case map_ctxt_attrib Args.init_assignable elem of + (case map_ctxt_attrib Token.init_assignable_src elem of Defines defs => Defines (defs |> map (fn ((a, atts), (t, ps)) => ((Thm.def_binding_optional (Binding.name (#1 (#1 (Local_Defs.cert_def ctxt t)))) a, atts), (t, ps)))) | e => e); val ctxt' = Context.proof_map (init elem') ctxt; - in (map_ctxt_attrib Args.closure elem', ctxt') end; + in (map_ctxt_attrib Token.closure_src elem', ctxt') end; fun activate raw_elem ctxt = let val elem = raw_elem |> map_ctxt diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/expression.ML --- a/src/Pure/Isar/expression.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/expression.ML Wed Aug 27 15:52:58 2014 +0200 @@ -924,7 +924,7 @@ fun subscribe_or_activate lthy = if Named_Target.is_theory lthy then Local_Theory.subscription - else Local_Theory.activate; + else Locale.activate_fragment; fun subscribe_locale_only lthy = let @@ -964,7 +964,7 @@ (K Local_Theory.subscription) expression raw_eqns; fun ephemeral_interpretation x = - gen_local_theory_interpretation cert_interpretation (K Local_Theory.activate) x; + gen_local_theory_interpretation cert_interpretation (K Locale.activate_fragment) x; fun interpretation x = gen_local_theory_interpretation cert_interpretation subscribe_or_activate x; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/generic_target.ML --- a/src/Pure/Isar/generic_target.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/generic_target.ML Wed Aug 27 15:52:58 2014 +0200 @@ -23,9 +23,9 @@ bool -> (binding * mixfix) * (Attrib.binding * term) -> local_theory -> (term * (string * thm)) * local_theory val notes: - (string -> (Attrib.binding * (thm list * Args.src list) list) list -> - (Attrib.binding * (thm list * Args.src list) list) list -> local_theory -> local_theory) -> - string -> (Attrib.binding * (thm list * Args.src list) list) list -> local_theory -> + (string -> (Attrib.binding * (thm list * Token.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> local_theory) -> + string -> (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> (string * thm list) list * local_theory val abbrev: (string * bool -> binding * mixfix -> term -> term list * term list -> local_theory -> local_theory) -> @@ -35,8 +35,8 @@ val theory_foundation: ((binding * typ) * mixfix) * (binding * term) -> term list * term list -> local_theory -> (term * thm) * local_theory val theory_notes: string -> - (Attrib.binding * (thm list * Args.src list) list) list -> - (Attrib.binding * (thm list * Args.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> local_theory val theory_declaration: declaration -> local_theory -> local_theory val theory_abbrev: Syntax.mode -> (binding * mixfix) -> term -> term list * term list -> @@ -46,8 +46,8 @@ (* locale operations *) val locale_notes: string -> string -> - (Attrib.binding * (thm list * Args.src list) list) list -> - (Attrib.binding * (thm list * Args.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> local_theory val locale_target_declaration: string -> bool -> declaration -> local_theory -> local_theory val locale_declaration: string -> {syntax: bool, pervasive: bool} -> declaration -> @@ -66,7 +66,7 @@ (** notes **) fun standard_facts lthy ctxt = - Element.transform_facts (Local_Theory.standard_morphism lthy ctxt); + Attrib.transform_facts (Local_Theory.standard_morphism lthy ctxt); fun standard_notes pred kind facts lthy = Local_Theory.map_contexts (fn level => fn ctxt => @@ -358,6 +358,6 @@ fun locale_dependency locale dep_morph mixin export = (Local_Theory.raw_theory ooo Locale.add_dependency locale) dep_morph mixin export - #> Local_Theory.activate_nonbrittle dep_morph mixin export; + #> Locale.activate_fragment_nonbrittle dep_morph mixin export; end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/isar_cmd.ML --- a/src/Pure/Isar/isar_cmd.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/isar_cmd.ML Wed Aug 27 15:52:58 2014 +0200 @@ -16,7 +16,7 @@ val translations: (xstring * string) Syntax.trrule list -> theory -> theory val no_translations: (xstring * string) Syntax.trrule list -> theory -> theory val oracle: bstring * Position.T -> Symbol_Pos.source -> theory -> theory - val add_defs: (bool * bool) * ((binding * string) * Attrib.src list) list -> theory -> theory + val add_defs: (bool * bool) * ((binding * string) * Token.src list) list -> theory -> theory val declaration: {syntax: bool, pervasive: bool} -> Symbol_Pos.source -> local_theory -> local_theory val simproc_setup: string * Position.T -> string list -> Symbol_Pos.source -> @@ -39,14 +39,11 @@ val thy_deps: Toplevel.transition -> Toplevel.transition val locale_deps: Toplevel.transition -> Toplevel.transition val class_deps: Toplevel.transition -> Toplevel.transition - val thm_deps: (Facts.ref * Attrib.src list) list -> Toplevel.transition -> Toplevel.transition - val unused_thms: (string list * string list option) option -> - Toplevel.transition -> Toplevel.transition - val print_stmts: string list * (Facts.ref * Attrib.src list) list + val print_stmts: string list * (Facts.ref * Token.src list) list -> Toplevel.transition -> Toplevel.transition - val print_thms: string list * (Facts.ref * Attrib.src list) list + val print_thms: string list * (Facts.ref * Token.src list) list -> Toplevel.transition -> Toplevel.transition - val print_prfs: bool -> string list * (Facts.ref * Attrib.src list) list option + val print_prfs: bool -> string list * (Facts.ref * Token.src list) list option -> Toplevel.transition -> Toplevel.transition val print_prop: (string list * string) -> Toplevel.transition -> Toplevel.transition val print_term: (string list * string) -> Toplevel.transition -> Toplevel.transition @@ -314,28 +311,6 @@ |> sort (int_ord o pairself #1) |> map #2; in Graph_Display.display_graph gr end); -fun thm_deps args = Toplevel.unknown_theory o Toplevel.keep (fn state => - Thm_Deps.thm_deps (Toplevel.theory_of state) - (Attrib.eval_thms (Toplevel.context_of state) args)); - - -(* find unused theorems *) - -fun unused_thms opt_range = Toplevel.keep (fn state => - let - val thy = Toplevel.theory_of state; - val ctxt = Toplevel.context_of state; - fun pretty_thm (a, th) = Proof_Context.pretty_fact ctxt (a, [th]); - val get_theory = Context.get_theory thy; - in - Thm_Deps.unused_thms - (case opt_range of - NONE => (Theory.parents_of thy, [thy]) - | SOME (xs, NONE) => (map get_theory xs, [thy]) - | SOME (xs, SOME ys) => (map get_theory xs, map get_theory ys)) - |> map pretty_thm |> Pretty.writeln_chunks - end); - (* print theorems, terms, types etc. *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/isar_syn.ML --- a/src/Pure/Isar/isar_syn.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/isar_syn.ML Wed Aug 27 15:52:58 2014 +0200 @@ -228,7 +228,7 @@ val _ = Outer_Syntax.local_theory' @{command_spec "declare"} "declare theorems" - (Parse.and_list1 Parse_Spec.xthms1 -- Parse.for_fixes + (Parse.and_list1 Parse.xthms1 -- Parse.for_fixes >> (fn (facts, fixes) => #2 oo Specification.theorems_cmd "" [(Attrib.empty_binding, flat facts)] fixes)); @@ -329,16 +329,16 @@ (Parse.ML_source >> Isar_Cmd.local_setup); val _ = - Outer_Syntax.command @{command_spec "attribute_setup"} "define attribute in ML" + Outer_Syntax.local_theory @{command_spec "attribute_setup"} "define attribute in ML" (Parse.position Parse.name -- Parse.!!! (@{keyword "="} |-- Parse.ML_source -- Scan.optional Parse.text "") - >> (fn (name, (txt, cmt)) => Toplevel.theory (Attrib.attribute_setup name txt cmt))); + >> (fn (name, (txt, cmt)) => Attrib.attribute_setup name txt cmt)); val _ = - Outer_Syntax.command @{command_spec "method_setup"} "define proof method in ML" + Outer_Syntax.local_theory @{command_spec "method_setup"} "define proof method in ML" (Parse.position Parse.name -- Parse.!!! (@{keyword "="} |-- Parse.ML_source -- Scan.optional Parse.text "") - >> (fn (name, (txt, cmt)) => Toplevel.theory (Method.method_setup name txt cmt))); + >> (fn (name, (txt, cmt)) => Method.method_setup name txt cmt)); val _ = Outer_Syntax.local_theory @{command_spec "declaration"} "generic ML declaration" @@ -398,7 +398,7 @@ val _ = Outer_Syntax.local_theory @{command_spec "bundle"} "define bundle of declarations" - ((Parse.binding --| @{keyword "="}) -- Parse_Spec.xthms1 -- Parse.for_fixes + ((Parse.binding --| @{keyword "="}) -- Parse.xthms1 -- Parse.for_fixes >> (uncurry Bundle.bundle_cmd)); val _ = @@ -567,7 +567,7 @@ (* facts *) -val facts = Parse.and_list1 Parse_Spec.xthms1; +val facts = Parse.and_list1 Parse.xthms1; val _ = Outer_Syntax.command @{command_spec "then"} "forward chaining" @@ -640,7 +640,7 @@ ((@{keyword "("} |-- Parse.!!! (Parse.position Parse.xname -- Scan.repeat (Parse.maybe Parse.binding) --| @{keyword ")"}) || - Parse.position Parse.xname >> rpair []) -- Parse_Spec.opt_attribs >> (fn ((c, xs), atts) => + Parse.position Parse.xname >> rpair []) -- Parse.opt_attribs >> (fn ((c, xs), atts) => Toplevel.proof (Proof.invoke_case_cmd (c, xs, atts)))); @@ -744,7 +744,7 @@ val _ = Outer_Syntax.improper_command @{command_spec "Isabelle.command"} "evaluate nested Isabelle command" (props_text :|-- (fn (pos, str) => - (case Outer_Syntax.parse pos str of + (case Outer_Syntax.parse (Outer_Syntax.get_syntax ()) pos str of [tr] => Scan.succeed (K tr) | _ => Scan.fail_with (K (fn () => "exactly one command expected"))) handle ERROR msg => Scan.fail_with (K (fn () => msg)))); @@ -894,10 +894,6 @@ (Scan.succeed Isar_Cmd.class_deps); val _ = - Outer_Syntax.improper_command @{command_spec "thm_deps"} "visualize theorem dependencies" - (Parse_Spec.xthms1 >> Isar_Cmd.thm_deps); - -val _ = Outer_Syntax.improper_command @{command_spec "print_binds"} "print term bindings of proof context -- Proof General legacy" (Scan.succeed (Toplevel.unknown_context o @@ -924,19 +920,19 @@ val _ = Outer_Syntax.improper_command @{command_spec "print_statement"} "print theorems as long statements" - (opt_modes -- Parse_Spec.xthms1 >> Isar_Cmd.print_stmts); + (opt_modes -- Parse.xthms1 >> Isar_Cmd.print_stmts); val _ = Outer_Syntax.improper_command @{command_spec "thm"} "print theorems" - (opt_modes -- Parse_Spec.xthms1 >> Isar_Cmd.print_thms); + (opt_modes -- Parse.xthms1 >> Isar_Cmd.print_thms); val _ = Outer_Syntax.improper_command @{command_spec "prf"} "print proof terms of theorems" - (opt_modes -- Scan.option Parse_Spec.xthms1 >> Isar_Cmd.print_prfs false); + (opt_modes -- Scan.option Parse.xthms1 >> Isar_Cmd.print_prfs false); val _ = Outer_Syntax.improper_command @{command_spec "full_prf"} "print full proof terms of theorems" - (opt_modes -- Scan.option Parse_Spec.xthms1 >> Isar_Cmd.print_prfs true); + (opt_modes -- Scan.option Parse.xthms1 >> Isar_Cmd.print_prfs true); val _ = Outer_Syntax.improper_command @{command_spec "prop"} "read and print proposition" @@ -956,11 +952,6 @@ (Scan.succeed (Toplevel.unknown_theory o Toplevel.keep (Code.print_codesetup o Toplevel.theory_of))); -val _ = - Outer_Syntax.improper_command @{command_spec "unused_thms"} "find unused theorems" - (Scan.option ((Scan.repeat1 (Scan.unless Parse.minus Parse.name) --| Parse.minus) -- - Scan.option (Scan.repeat1 (Scan.unless Parse.minus Parse.name))) >> Isar_Cmd.unused_thms); - (** system commands (for interactive mode only) **) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/local_theory.ML --- a/src/Pure/Isar/local_theory.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/local_theory.ML Wed Aug 27 15:52:58 2014 +0200 @@ -7,6 +7,11 @@ type local_theory = Proof.context; type generic_theory = Context.generic; +structure Attrib = +struct + type binding = binding * Token.src list; +end; + signature LOCAL_THEORY = sig type operations @@ -14,6 +19,7 @@ val restore: local_theory -> local_theory val level: Proof.context -> int val assert_bottom: bool -> local_theory -> local_theory + val mark_brittle: local_theory -> local_theory val assert_nonbrittle: local_theory -> local_theory val open_target: Name_Space.naming -> operations -> (local_theory -> local_theory) -> local_theory -> local_theory @@ -42,9 +48,9 @@ val define_internal: (binding * mixfix) * (Attrib.binding * term) -> local_theory -> (term * (string * thm)) * local_theory val note: Attrib.binding * thm list -> local_theory -> (string * thm list) * local_theory - val notes: (Attrib.binding * (thm list * Attrib.src list) list) list -> + val notes: (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> (string * thm list) list * local_theory - val notes_kind: string -> (Attrib.binding * (thm list * Attrib.src list) list) list -> + val notes_kind: string -> (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> (string * thm list) list * local_theory val abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory @@ -52,16 +58,16 @@ val subscription: string * morphism -> (morphism * bool) option -> morphism -> local_theory -> local_theory val pretty: local_theory -> Pretty.T list + val add_thms_dynamic: binding * (Context.generic -> thm list) -> local_theory -> local_theory val set_defsort: sort -> local_theory -> local_theory val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> local_theory -> local_theory val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory + val generic_alias: + (('a Name_Space.table -> 'a Name_Space.table) -> Context.generic -> Context.generic) -> + binding -> string -> local_theory -> local_theory val class_alias: binding -> class -> local_theory -> local_theory val type_alias: binding -> string -> local_theory -> local_theory val const_alias: binding -> string -> local_theory -> local_theory - val activate: string * morphism -> (morphism * bool) option -> morphism -> - local_theory -> local_theory - val activate_nonbrittle: string * morphism -> (morphism * bool) option -> morphism -> - local_theory -> local_theory val init: Name_Space.naming -> operations -> Proof.context -> local_theory val exit: local_theory -> Proof.context val exit_global: local_theory -> theory @@ -80,7 +86,7 @@ {define: bool -> (binding * mixfix) * (Attrib.binding * term) -> local_theory -> (term * (string * thm)) * local_theory, notes: string -> - (Attrib.binding * (thm list * Attrib.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> local_theory -> (string * thm list) list * local_theory, abbrev: Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory, @@ -98,7 +104,8 @@ target: Proof.context}; fun make_lthy (naming, operations, after_close, brittle, target) : lthy = - {naming = naming, operations = operations, after_close = after_close, brittle = brittle, target = target}; + {naming = naming, operations = operations, after_close = after_close, + brittle = brittle, target = target}; (* context data *) @@ -115,7 +122,7 @@ val bottom_of = List.last o Data.get o assert; val top_of = hd o Data.get o assert; -fun map_bottom f = +fun map_top f = assert #> Data.map (fn {naming, operations, after_close, brittle, target} :: parents => make_lthy (f (naming, operations, after_close, brittle, target)) :: parents); @@ -162,14 +169,13 @@ (* brittle context -- implicit for nested structures *) fun mark_brittle lthy = - if level lthy = 1 - then map_bottom (fn (naming, operations, after_close, brittle, target) => - (naming, operations, after_close, true, target)) lthy + if level lthy = 1 then + map_top (fn (naming, operations, after_close, _, target) => + (naming, operations, after_close, true, target)) lthy else lthy; fun assert_nonbrittle lthy = - if #brittle (top_of lthy) - then error "Brittle local theory context" + if #brittle (top_of lthy) then error "Brittle local theory context" else lthy; @@ -179,7 +185,7 @@ val full_name = Name_Space.full_name o naming_of; fun map_naming f = - map_bottom (fn (naming, operations, after_close, brittle, target) => + map_top (fn (naming, operations, after_close, brittle, target) => (f naming, operations, after_close, brittle, target)); val conceal = map_naming Name_Space.conceal; @@ -251,12 +257,12 @@ val operations_of = #operations o top_of; +fun operation f lthy = f (operations_of lthy) lthy; +fun operation2 f x y = operation (fn ops => f ops x y); + (* primitives *) -fun operation f lthy = f (operations_of lthy) lthy; -fun operation2 f x y = operation (fn ops => f ops x y); - val pretty = operation #pretty; val abbrev = operation2 #abbrev; val define = operation2 #define false; @@ -267,11 +273,28 @@ assert_bottom true #> operation (fn ops => #subscription ops dep_morph mixin export); -(* basic derived operations *) +(* theorems *) val notes = notes_kind ""; fun note (a, ths) = notes [(a, [(ths, [])])] #>> the_single; +fun add_thms_dynamic (binding, f) lthy = + lthy + |> background_theory_result (fn thy => thy + |> Global_Theory.add_thms_dynamic' (Sign.inherit_naming thy lthy) (binding, f)) + |-> (fn name => + map_contexts (fn _ => fn ctxt => + Proof_Context.transfer_facts (Proof_Context.theory_of ctxt) ctxt) #> + declaration {syntax = false, pervasive = false} (fn phi => + let val binding' = Morphism.binding phi binding in + Context.mapping + (Global_Theory.alias_fact binding' name) + (Proof_Context.fact_alias binding' name) + end)); + + +(* default sort *) + fun set_defsort S = declaration {syntax = true, pervasive = false} (K (Context.mapping (Sign.set_defsort S) (Proof_Context.set_defsort S))); @@ -298,25 +321,21 @@ (* name space aliases *) -fun alias global_alias local_alias b name = +fun generic_alias app b name = + declaration {syntax = false, pervasive = false} (fn phi => fn context => + let + val naming = Name_Space.naming_of context; + val b' = Morphism.binding phi b; + in app (Name_Space.alias_table naming b' name) context end); + +fun syntax_alias global_alias local_alias b name = declaration {syntax = true, pervasive = false} (fn phi => let val b' = Morphism.binding phi b in Context.mapping (global_alias b' name) (local_alias b' name) end); -val class_alias = alias Sign.class_alias Proof_Context.class_alias; -val type_alias = alias Sign.type_alias Proof_Context.type_alias; -val const_alias = alias Sign.const_alias Proof_Context.const_alias; - - -(* activation of locale fragments *) - -fun activate_nonbrittle dep_morph mixin export = - map_bottom (fn (naming, operations, after_close, brittle, target) => - (naming, operations, after_close, brittle, - (Context.proof_map ooo Locale.add_registration) dep_morph mixin export target)); - -fun activate dep_morph mixin export = - mark_brittle #> activate_nonbrittle dep_morph mixin export; +val class_alias = syntax_alias Sign.class_alias Proof_Context.class_alias; +val type_alias = syntax_alias Sign.type_alias Proof_Context.type_alias; +val const_alias = syntax_alias Sign.const_alias Proof_Context.const_alias; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/locale.ML --- a/src/Pure/Isar/locale.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/locale.ML Wed Aug 27 15:52:58 2014 +0200 @@ -34,7 +34,7 @@ term option * term list -> thm option * thm option -> thm list -> declaration list -> - (string * (Attrib.binding * (thm list * Attrib.src list) list) list) list -> + (string * (Attrib.binding * (thm list * Token.src list) list) list) list -> (string * morphism) list -> theory -> theory val intern: theory -> xstring -> string val check: theory -> xstring * Position.T -> string @@ -49,7 +49,7 @@ val specification_of: theory -> string -> term option * term list (* Storing results *) - val add_thmss: string -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list -> + val add_thmss: string -> string -> (Attrib.binding * (thm list * Token.src list) list) list -> Proof.context -> Proof.context val add_declaration: string -> bool -> declaration -> Proof.context -> Proof.context @@ -70,6 +70,10 @@ (* Registrations and dependencies *) val add_registration: string * morphism -> (morphism * bool) option -> morphism -> Context.generic -> Context.generic + val activate_fragment: string * morphism -> (morphism * bool) option -> morphism -> + local_theory -> local_theory + val activate_fragment_nonbrittle: string * morphism -> (morphism * bool) option -> morphism -> + local_theory -> local_theory val amend_registration: string * morphism -> morphism * bool -> morphism -> Context.generic -> Context.generic val registrations_of: Context.generic -> string -> (string * morphism) list @@ -123,7 +127,7 @@ (** dynamic part **) syntax_decls: (declaration * serial) list, (* syntax declarations *) - notes: ((string * (Attrib.binding * (thm list * Attrib.src list) list) list) * serial) list, + notes: ((string * (Attrib.binding * (thm list * Token.src list) list) list) * serial) list, (* theorem declarations *) dependencies: ((string * (morphism * morphism)) * serial) list (* locale dependencies (sublocale relation) in reverse order *), @@ -514,6 +518,19 @@ end; +(* locale fragments within local theory *) + +fun activate_fragment_nonbrittle dep_morph mixin export lthy = + let val n = Local_Theory.level lthy in + lthy |> Local_Theory.map_contexts (fn level => + level = n - 1 ? Context.proof_map (add_registration dep_morph mixin export)) + end; + +fun activate_fragment dep_morph mixin export = + Local_Theory.mark_brittle #> activate_fragment_nonbrittle dep_morph mixin export; + + + (*** Dependencies ***) (* FIXME dead code!? @@ -561,7 +578,7 @@ (* Registrations *) (fn thy => fold_rev (fn (_, morph) => - snd o Attrib.global_notes kind (Element.transform_facts morph facts)) + snd o Attrib.global_notes kind (Attrib.transform_facts morph facts)) (registrations_of (Context.Theory thy) loc) thy)); diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/method.ML --- a/src/Pure/Isar/method.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/method.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,10 +6,7 @@ signature METHOD = sig - type method - val apply: (Proof.context -> method) -> Proof.context -> thm list -> cases_tactic - val RAW_METHOD_CASES: (thm list -> cases_tactic) -> method - val RAW_METHOD: (thm list -> tactic) -> method + type method = thm list -> cases_tactic val METHOD_CASES: (thm list -> cases_tactic) -> method val METHOD: (thm list -> tactic) -> method val fail: method @@ -41,20 +38,15 @@ val erule: Proof.context -> int -> thm list -> method val drule: Proof.context -> int -> thm list -> method val frule: Proof.context -> int -> thm list -> method - val set_tactic: (thm list -> tactic) -> Proof.context -> Proof.context - val tactic: Symbol_Pos.source -> Proof.context -> method - val raw_tactic: Symbol_Pos.source -> Proof.context -> method - type src = Args.src + val set_tactic: (morphism -> thm list -> tactic) -> Context.generic -> Context.generic type combinator_info val no_combinator_info: combinator_info + datatype combinator = Then | Orelse | Try | Repeat1 | Select_Goals of int datatype text = - Source of src | + Source of Token.src | Basic of Proof.context -> method | - Then of combinator_info * text list | - Orelse of combinator_info * text list | - Try of combinator_info * text | - Repeat1 of combinator_info * text | - Select_Goals of combinator_info * int * text + Combinator of combinator_info * combinator * text list + val map_source: (Token.src -> Token.src) -> text -> text val primitive_text: (Proof.context -> thm -> thm) -> text val succeed_text: text val default_text: text @@ -64,13 +56,21 @@ val finish_text: text option * bool -> text val print_methods: Proof.context -> unit val check_name: Proof.context -> xstring * Position.T -> string - val method: Proof.context -> src -> Proof.context -> method - val method_cmd: Proof.context -> src -> Proof.context -> method + val method_syntax: (Proof.context -> method) context_parser -> + Token.src -> Proof.context -> method val setup: binding -> (Proof.context -> method) context_parser -> string -> theory -> theory - val method_setup: bstring * Position.T -> Symbol_Pos.source -> string -> theory -> theory - type modifier = (Proof.context -> Proof.context) * attribute - val section: modifier parser list -> thm list context_parser - val sections: modifier parser list -> thm list list context_parser + val local_setup: binding -> (Proof.context -> method) context_parser -> string -> + local_theory -> local_theory + val method_setup: bstring * Position.T -> Symbol_Pos.source -> string -> + local_theory -> local_theory + val method: Proof.context -> Token.src -> Proof.context -> method + val method_closure: Proof.context -> Token.src -> Token.src + val method_cmd: Proof.context -> Token.src -> Proof.context -> method + val evaluate: text -> Proof.context -> method + type modifier = {init: Proof.context -> Proof.context, attribute: attribute, pos: Position.T} + val modifier: attribute -> Position.T -> modifier + val section: modifier parser list -> declaration context_parser + val sections: modifier parser list -> declaration list context_parser type text_range = text * Position.range val text: text_range option -> text option val position: text_range option -> Position.T @@ -84,20 +84,12 @@ (** proof methods **) -(* datatype method *) - -datatype method = Meth of thm list -> cases_tactic; - -fun apply meth ctxt = let val Meth m = meth ctxt in m end; +(* method *) -val RAW_METHOD_CASES = Meth; - -fun RAW_METHOD tac = RAW_METHOD_CASES (NO_CASES o tac); +type method = thm list -> cases_tactic; -fun METHOD_CASES tac = RAW_METHOD_CASES (fn facts => - Seq.THEN (ALLGOALS Goal.conjunction_tac, tac facts)); - -fun METHOD tac = RAW_METHOD (fn facts => ALLGOALS Goal.conjunction_tac THEN tac facts); +fun METHOD_CASES tac : method = fn facts => Seq.THEN (ALLGOALS Goal.conjunction_tac, tac facts); +fun METHOD tac : method = fn facts => NO_CASES (ALLGOALS Goal.conjunction_tac THEN tac facts); val fail = METHOD (K no_tac); val succeed = METHOD (K all_tac); @@ -150,7 +142,7 @@ fun atomize false ctxt = SIMPLE_METHOD' (CHANGED_PROP o Object_Logic.atomize_prems_tac ctxt) | atomize true ctxt = - RAW_METHOD (K (HEADGOAL (CHANGED_PROP o Object_Logic.full_atomize_tac ctxt))); + NO_CASES o K (HEADGOAL (CHANGED_PROP o Object_Logic.full_atomize_tac ctxt)); (* this -- resolve facts directly *) @@ -254,74 +246,90 @@ val try_intros_tac = gen_intros_tac TRYALL; -(* ML tactics *) - -structure ML_Tactic = Proof_Data -( - type T = thm list -> tactic; - fun init _ = undefined; -); - -val set_tactic = ML_Tactic.put; - -fun ml_tactic source ctxt = - let - val ctxt' = ctxt |> Context.proof_map - (ML_Context.expression (#pos source) - "fun tactic (facts: thm list) : tactic" - "Context.map_proof (Method.set_tactic tactic)" (ML_Lex.read_source false source)); - in Context.setmp_thread_data (SOME (Context.Proof ctxt)) (ML_Tactic.get ctxt') end; - -fun tactic source ctxt = METHOD (ml_tactic source ctxt); -fun raw_tactic source ctxt = RAW_METHOD (ml_tactic source ctxt); - - (** method syntax **) -(* method text *) +(* context data *) + +structure Data = Generic_Data +( + type T = + ((Token.src -> Proof.context -> method) * string) Name_Space.table * (*methods*) + (morphism -> thm list -> tactic) option; (*ML tactic*) + val empty : T = (Name_Space.empty_table "method", NONE); + val extend = I; + fun merge ((tab, tac), (tab', tac')) : T = + (Name_Space.merge_tables (tab, tab'), merge_options (tac, tac')); +); + +val get_methods = fst o Data.get; +val map_methods = Data.map o apfst; + + +(* ML tactic *) + +val set_tactic = Data.map o apsnd o K o SOME; -type src = Args.src; +fun the_tactic context = + (case snd (Data.get context) of + SOME tac => tac + | NONE => raise Fail "Undefined ML tactic"); + +val parse_tactic = + Scan.state :|-- (fn context => + Scan.lift (Args.text_declaration (fn source => + let + val context' = context |> + ML_Context.expression (#pos source) + "fun tactic (morphism: Morphism.morphism) (facts: thm list) : tactic" + "Method.set_tactic tactic" (ML_Lex.read_source false source); + val tac = the_tactic context'; + in + fn phi => + set_tactic (fn _ => Context.setmp_thread_data (SOME context) (tac phi)) + end)) >> (fn decl => Morphism.form (the_tactic (Morphism.form decl context)))); + + +(* method text *) datatype combinator_info = Combinator_Info of {keywords: Position.T list}; fun combinator_info keywords = Combinator_Info {keywords = keywords}; val no_combinator_info = combinator_info []; +datatype combinator = Then | Orelse | Try | Repeat1 | Select_Goals of int; + datatype text = - Source of src | + Source of Token.src | Basic of Proof.context -> method | - Then of combinator_info * text list | - Orelse of combinator_info * text list | - Try of combinator_info * text | - Repeat1 of combinator_info * text | - Select_Goals of combinator_info * int * text; + Combinator of combinator_info * combinator * text list; + +fun map_source f (Source src) = Source (f src) + | map_source _ (Basic meth) = Basic meth + | map_source f (Combinator (info, comb, txts)) = Combinator (info, comb, map (map_source f) txts); fun primitive_text r = Basic (SIMPLE_METHOD o PRIMITIVE o r); val succeed_text = Basic (K succeed); -val default_text = Source (Args.src ("default", Position.none) []); +val default_text = Source (Token.src ("default", Position.none) []); val this_text = Basic (K this); val done_text = Basic (K (SIMPLE_METHOD all_tac)); fun sorry_text int = Basic (fn ctxt => cheating ctxt int); fun finish_text (NONE, immed) = Basic (finish immed) - | finish_text (SOME txt, immed) = Then (no_combinator_info, [txt, Basic (finish immed)]); + | finish_text (SOME txt, immed) = + Combinator (no_combinator_info, Then, [txt, Basic (finish immed)]); (* method definitions *) -structure Methods = Theory_Data -( - type T = ((src -> Proof.context -> method) * string) Name_Space.table; - val empty : T = Name_Space.empty_table "method"; - val extend = I; - fun merge data : T = Name_Space.merge_tables data; -); - -val get_methods = Methods.get o Proof_Context.theory_of; +fun transfer_methods ctxt = + let + val meths0 = get_methods (Context.Theory (Proof_Context.theory_of ctxt)); + val meths' = Name_Space.merge_tables (meths0, get_methods (Context.Proof ctxt)); + in Context.proof_map (map_methods (K meths')) ctxt end; fun print_methods ctxt = let - val meths = get_methods ctxt; + val meths = get_methods (Context.Proof ctxt); fun prt_meth (name, (_, "")) = Pretty.mark_str name | prt_meth (name, (_, comment)) = Pretty.block @@ -331,66 +339,166 @@ |> Pretty.writeln_chunks end; -fun add_method name meth comment thy = thy - |> Methods.map (Name_Space.define (Context.Theory thy) true (name, (meth, comment)) #> snd); + +(* define *) + +fun define_global binding meth comment thy = + let + val context = Context.Theory thy; + val (name, meths') = + Name_Space.define context true (binding, (meth, comment)) (get_methods context); + in (name, Context.the_theory (map_methods (K meths') context)) end; + +fun define binding meth comment = + Local_Theory.background_theory_result (define_global binding meth comment) + #-> (fn name => + Local_Theory.map_contexts (K transfer_methods) + #> Local_Theory.generic_alias map_methods binding name + #> pair name); (* check *) -fun check_name ctxt = #1 o Name_Space.check (Context.Proof ctxt) (get_methods ctxt); -fun check_src ctxt src = Args.check_src ctxt (get_methods ctxt) src; +fun check_name ctxt = + let val context = Context.Proof ctxt + in #1 o Name_Space.check context (get_methods context) end; + +fun check_src ctxt src = + Token.check_src ctxt (get_methods (Context.Proof ctxt)) src; -(* get methods *) +(* method setup *) + +fun method_syntax scan src ctxt : method = + let val (m, ctxt') = Token.syntax scan src ctxt in m ctxt' end; + +fun setup binding scan comment = define_global binding (method_syntax scan) comment #> snd; +fun local_setup binding scan comment = define binding (method_syntax scan) comment #> snd; + +fun method_setup name source cmt = + (ML_Lex.read Position.none ("(" ^ ML_Syntax.make_binding name ^ ", ") @ + ML_Lex.read_source false source @ + ML_Lex.read Position.none (", " ^ ML_Syntax.print_string cmt ^ ")")) + |> ML_Context.expression (#pos source) + "val (name, scan, comment): binding * (Proof.context -> Proof.method) context_parser * string" + "Context.map_proof (Method.local_setup name scan comment)" + |> Context.proof_map; + + +(* prepare methods *) fun method ctxt = - let val table = get_methods ctxt - in fn src => #1 (Name_Space.get table (#1 (Args.name_of_src src))) src end; + let val table = get_methods (Context.Proof ctxt) + in fn src => #1 (Name_Space.get table (#1 (Token.name_of_src src))) src end; fun method_closure ctxt0 src0 = let - val (src1, meth) = check_src ctxt0 src0; - val src2 = Args.init_assignable src1; + val (src1, _) = check_src ctxt0 src0; + val src2 = Token.init_assignable_src src1; val ctxt = Context_Position.not_really ctxt0; - val _ = Seq.pull (apply (method ctxt src2) ctxt [] (Goal.protect 0 Drule.dummy_thm)); - in Args.closure src2 end; + val _ = Seq.pull (method ctxt src2 ctxt [] (Goal.protect 0 Drule.dummy_thm)); + in Token.closure_src src2 end; fun method_cmd ctxt = method ctxt o method_closure ctxt; -(* method setup *) +(* evaluate method text *) + +local + +fun APPEND_CASES (meth: cases_tactic) (cases, st) = + meth st |> Seq.map (fn (cases', st') => (cases @ cases', st')); + +fun BYPASS_CASES (tac: tactic) (cases, st) = + tac st |> Seq.map (pair cases); -fun setup name scan = - add_method name - (fn src => fn ctxt => let val (m, ctxt') = Args.syntax scan src ctxt in m ctxt' end); +val op THEN = Seq.THEN; + +fun SELECT_GOALS n method = + BYPASS_CASES + (ALLGOALS Goal.conjunction_tac THEN PRIMITIVE (Goal.restrict 1 n) THEN Goal.conjunction_tac 1) + THEN method + THEN BYPASS_CASES (PRIMITIVE (Goal.unrestrict 1)); + +fun COMBINATOR1 comb [meth] = comb meth + | COMBINATOR1 _ _ = raise Fail "Method combinator requires exactly one argument"; -fun method_setup name source cmt = - Context.theory_map (ML_Context.expression (#pos source) - "val (name, scan, comment): binding * (Proof.context -> Proof.method) context_parser * string" - "Context.map_theory (Method.setup name scan comment)" - (ML_Lex.read Position.none ("(" ^ ML_Syntax.make_binding name ^ ", ") @ - ML_Lex.read_source false source @ - ML_Lex.read Position.none (", " ^ ML_Syntax.print_string cmt ^ ")"))); +fun combinator Then = Seq.EVERY + | combinator Orelse = Seq.FIRST + | combinator Try = COMBINATOR1 Seq.TRY + | combinator Repeat1 = COMBINATOR1 Seq.REPEAT1 + | combinator (Select_Goals n) = COMBINATOR1 (SELECT_GOALS n); + +in + +fun evaluate text ctxt = + let + fun eval (Basic meth) = APPEND_CASES o meth ctxt + | eval (Source src) = APPEND_CASES o method_cmd ctxt src ctxt + | eval (Combinator (_, c, txts)) = + let + val comb = combinator c; + val meths = map eval txts; + in fn facts => comb (map (fn meth => meth facts) meths) end; + val meth = eval text; + in fn facts => fn st => meth facts ([], st) end; + +end; (** concrete syntax **) -(* sections *) +(* type modifier *) + +type modifier = + {init: Proof.context -> Proof.context, attribute: attribute, pos: Position.T}; -type modifier = (Proof.context -> Proof.context) * attribute; +fun modifier attribute pos : modifier = {init = I, attribute = attribute, pos = pos}; + + +(* sections *) local -fun thms ss = Scan.repeat (Scan.unless (Scan.lift (Scan.first ss)) Attrib.multi_thm) >> flat; -fun app (f, att) ths context = fold_map (Thm.apply_attribute att) ths (Context.map_proof f context); +fun sect (modifier : modifier parser) = Scan.depend (fn context => + let + val ctxt = Context.proof_of context; + fun prep_att src = + let + val src' = Attrib.check_src ctxt src; + val _ = List.app (Token.assign NONE) (Token.args_of_src src'); + in src' end; + val parse_thm = + Parse.xthm >> (fn (a, bs) => (Proof_Context.get_fact ctxt a, map prep_att bs)); + in + Scan.ahead Parse.not_eof -- modifier -- Scan.repeat (Scan.unless modifier parse_thm) >> + (fn ((tok, {init, attribute, pos}), thms) => + let + val decl = + (case Token.get_value tok of + SOME (Token.Declaration decl) => decl + | _ => + let + val facts = + Attrib.partial_evaluation ctxt [((Binding.name "dummy", []), thms)] + |> map (fn (_, bs) => ((Binding.empty, [Attrib.internal (K attribute)]), bs)); + val _ = + Context_Position.report ctxt (Token.pos_of tok) + (Markup.entity Markup.method_modifierN "" + |> Markup.properties (Position.def_properties_of pos)); + fun decl phi = + Context.mapping I init #> + Attrib.generic_notes "" (Attrib.transform_facts phi facts) #> snd; + val _ = Token.assign (SOME (Token.Declaration decl)) tok; + in decl end); + in (Morphism.form decl context, decl) end) + end); in -fun section ss = Scan.depend (fn context => (Scan.first ss -- Scan.pass context (thms ss)) :|-- - (fn (m, ths) => Scan.succeed (swap (app m ths context)))); - -fun sections ss = Scan.repeat (section ss); +val section = sect o Scan.first; +val sections = Scan.repeat o section; end; @@ -419,16 +527,8 @@ fun keyword_positions (Source _) = [] | keyword_positions (Basic _) = [] - | keyword_positions (Then (Combinator_Info {keywords}, texts)) = - keywords @ maps keyword_positions texts - | keyword_positions (Orelse (Combinator_Info {keywords}, texts)) = - keywords @ maps keyword_positions texts - | keyword_positions (Try (Combinator_Info {keywords}, text)) = - keywords @ keyword_positions text - | keyword_positions (Repeat1 (Combinator_Info {keywords}, text)) = - keywords @ keyword_positions text - | keyword_positions (Select_Goals (Combinator_Info {keywords}, _, text)) = - keywords @ keyword_positions text; + | keyword_positions (Combinator (Combinator_Info {keywords}, _, texts)) = + keywords @ maps keyword_positions texts; in @@ -450,29 +550,29 @@ local fun meth4 x = - (Parse.position Parse.xname >> (fn name => Source (Args.src name [])) || + (Parse.position Parse.xname >> (fn name => Source (Token.src name [])) || Scan.ahead Parse.cartouche |-- Parse.not_eof >> (fn tok => - Source (Args.src ("cartouche", Token.pos_of tok) [tok])) || + Source (Token.src ("cartouche", Token.pos_of tok) [tok])) || Parse.$$$ "(" |-- Parse.!!! (meth0 --| Parse.$$$ ")")) x and meth3 x = (meth4 -- Parse.position (Parse.$$$ "?") - >> (fn (m, (_, pos)) => Try (combinator_info [pos], m)) || + >> (fn (m, (_, pos)) => Combinator (combinator_info [pos], Try, [m])) || meth4 -- Parse.position (Parse.$$$ "+") - >> (fn (m, (_, pos)) => Repeat1 (combinator_info [pos], m)) || + >> (fn (m, (_, pos)) => Combinator (combinator_info [pos], Repeat1, [m])) || meth4 -- (Parse.position (Parse.$$$ "[") -- Scan.optional Parse.nat 1 -- Parse.position (Parse.$$$ "]")) >> (fn (m, (((_, pos1), n), (_, pos2))) => - Select_Goals (combinator_info [pos1, pos2], n, m)) || + Combinator (combinator_info [pos1, pos2], Select_Goals n, [m])) || meth4) x and meth2 x = - (Parse.position Parse.xname -- Parse.args1 is_symid_meth >> (Source o uncurry Args.src) || + (Parse.position Parse.xname -- Parse.args1 is_symid_meth >> (Source o uncurry Token.src) || meth3) x and meth1 x = (Parse.enum1_positions "," meth2 - >> (fn ([m], _) => m | (ms, ps) => Then (combinator_info ps, ms))) x + >> (fn ([m], _) => m | (ms, ps) => Combinator (combinator_info ps, Then, ms))) x and meth0 x = (Parse.enum1_positions "|" meth1 - >> (fn ([m], _) => m | (ms, ps) => Orelse (combinator_info ps, ms))) x; + >> (fn ([m], _) => m | (ms, ps) => Combinator (combinator_info ps, Orelse, ms))) x; in @@ -514,9 +614,9 @@ setup @{binding rotate_tac} (Args.goal_spec -- Scan.lift (Scan.optional Parse.int 1) >> (fn (quant, i) => K (SIMPLE_METHOD'' quant (rotate_tac i)))) "rotate assumptions of goal" #> - setup @{binding tactic} (Scan.lift Args.text_source_position >> tactic) + setup @{binding tactic} (parse_tactic >> (K o METHOD)) "ML tactic as proof method" #> - setup @{binding raw_tactic} (Scan.lift Args.text_source_position >> raw_tactic) + setup @{binding raw_tactic} (parse_tactic >> (fn tac => fn _ => NO_CASES o tac)) "ML tactic as raw proof method"); @@ -526,8 +626,6 @@ end; -val RAW_METHOD_CASES = Method.RAW_METHOD_CASES; -val RAW_METHOD = Method.RAW_METHOD; val METHOD_CASES = Method.METHOD_CASES; val METHOD = Method.METHOD; val SIMPLE_METHOD = Method.SIMPLE_METHOD; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/outer_syntax.ML --- a/src/Pure/Isar/outer_syntax.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/outer_syntax.ML Wed Aug 27 15:52:58 2014 +0200 @@ -31,8 +31,10 @@ (local_theory -> Proof.state) parser -> unit val help_outer_syntax: string list -> unit val print_outer_syntax: unit -> unit - val scan: Position.T -> string -> Token.T list - val parse: Position.T -> string -> Toplevel.transition list + val scan: Scan.lexicon * Scan.lexicon -> Position.T -> string -> Token.T list + val parse: (Scan.lexicon * Scan.lexicon) * outer_syntax -> + Position.T -> string -> Toplevel.transition list + val parse_spans: Token.T list -> Command_Span.span list type isar val isar: TextIO.instream -> bool -> isar val side_comments: Token.T list -> Token.T list @@ -256,18 +258,49 @@ (* off-line scanning/parsing *) -fun scan pos str = +fun scan lexs pos = + Source.of_string #> + Symbol.source #> + Token.source {do_recover = SOME false} (K lexs) pos #> + Source.exhaust; + +fun parse (lexs, syntax) pos str = Source.of_string str |> Symbol.source - |> Token.source {do_recover = SOME false} Keyword.get_lexicons pos + |> Token.source {do_recover = SOME false} (K lexs) pos + |> toplevel_source false NONE (K (lookup_commands syntax)) |> Source.exhaust; -fun parse pos str = - Source.of_string str - |> Symbol.source - |> Token.source {do_recover = SOME false} Keyword.get_lexicons pos - |> toplevel_source false NONE lookup_commands_dynamic - |> Source.exhaust; + +(* parse spans *) + +local + +fun ship span = + let + val kind = + if not (null span) andalso Token.is_command (hd span) andalso not (exists Token.is_error span) + then Command_Span.Command_Span (Token.content_of (hd span), Token.pos_of (hd span)) + else if forall Token.is_improper span then Command_Span.Ignored_Span + else Command_Span.Malformed_Span; + in cons (Command_Span.Span (kind, span)) end; + +fun flush (result, content, improper) = + result + |> not (null content) ? ship (rev content) + |> not (null improper) ? ship (rev improper); + +fun parse tok (result, content, improper) = + if Token.is_command tok then (flush (result, content, improper), [tok], []) + else if Token.is_improper tok then (result, content, tok :: improper) + else (result, tok :: (improper @ content), []); + +in + +fun parse_spans toks = + fold parse toks ([], [], []) |> flush |> rev; + +end; (* interactive source of toplevel transformers *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/outer_syntax.scala --- a/src/Pure/Isar/outer_syntax.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/outer_syntax.scala Wed Aug 27 15:52:58 2014 +0200 @@ -57,8 +57,8 @@ def keyword_kind_files(name: String): Option[(String, List[String])] = keywords.get(name) def keyword_kind(name: String): Option[String] = keyword_kind_files(name).map(_._1) - def load(span: List[Token]): Option[List[String]] = - keywords.get(Command.name(span)) match { + def load_command(name: String): Option[List[String]] = + keywords.get(name) match { case Some((Keyword.THY_LOAD, exts)) => Some(exts) case _ => None } @@ -124,18 +124,16 @@ /* token language */ - def scan(input: Reader[Char]): List[Token] = + def scan(input: CharSequence): List[Token] = { + var in: Reader[Char] = new CharSequenceReader(input) Token.Parsers.parseAll( - Token.Parsers.rep(Token.Parsers.token(lexicon, is_command)), input) match { + Token.Parsers.rep(Token.Parsers.token(lexicon, is_command)), in) match { case Token.Parsers.Success(tokens, _) => tokens - case _ => error("Unexpected failure of tokenizing input:\n" + input.source.toString) + case _ => error("Unexpected failure of tokenizing input:\n" + input.toString) } } - def scan(input: CharSequence): List[Token] = - scan(new CharSequenceReader(input)) - def scan_line(input: CharSequence, context: Scan.Line_Context): (List[Token], Scan.Line_Context) = { var in: Reader[Char] = new CharSequenceReader(input) @@ -152,6 +150,47 @@ } + /* parse_spans */ + + def parse_spans(toks: List[Token]): List[Command_Span.Span] = + { + val result = new mutable.ListBuffer[Command_Span.Span] + val content = new mutable.ListBuffer[Token] + val improper = new mutable.ListBuffer[Token] + + def ship(span: List[Token]) + { + val kind = + if (!span.isEmpty && span.head.is_command && !span.exists(_.is_error)) { + val name = span.head.source + val pos = Position.Range(Text.Range(0, Symbol.iterator(name).length) + 1) + Command_Span.Command_Span(name, pos) + } + else if (span.forall(_.is_improper)) Command_Span.Ignored_Span + else Command_Span.Malformed_Span + result += Command_Span.Span(kind, span) + } + + def flush() + { + if (!content.isEmpty) { ship(content.toList); content.clear } + if (!improper.isEmpty) { ship(improper.toList); improper.clear } + } + + for (tok <- toks) { + if (tok.is_command) { flush(); content += tok } + else if (tok.is_improper) improper += tok + else { content ++= improper; improper.clear; content += tok } + } + flush() + + result.toList + } + + def parse_spans(input: CharSequence): List[Command_Span.Span] = + parse_spans(scan(input)) + + /* language context */ def set_language_context(context: Completion.Language_Context): Outer_Syntax = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/parse.ML --- a/src/Pure/Isar/parse.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/parse.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,8 +6,6 @@ signature PARSE = sig - type 'a parser = Token.T list -> 'a * Token.T list - type 'a context_parser = Context.generic * Token.T list -> 'a * (Context.generic * Token.T list) val group: (unit -> string) -> (Token.T list -> 'a) -> Token.T list -> 'a val !!! : (Token.T list -> 'a) -> Token.T list -> 'a val !!!! : (Token.T list -> 'a) -> Token.T list -> 'a @@ -109,15 +107,16 @@ val opt_target: (xstring * Position.T) option parser val args: Token.T list parser val args1: (string -> bool) -> Token.T list parser + val attribs: Token.src list parser + val opt_attribs: Token.src list parser + val thm_sel: Facts.interval list parser + val xthm: (Facts.ref * Token.src list) parser + val xthms1: (Facts.ref * Token.src list) list parser end; structure Parse: PARSE = struct -type 'a parser = Token.T list -> 'a * Token.T list; -type 'a context_parser = Context.generic * Token.T list -> 'a * (Context.generic * Token.T list); - - (** error handling **) (* group atomic parsers (no cuts!) *) @@ -439,8 +438,27 @@ end; + +(* attributes *) + +val attrib = position liberal_name -- !!! args >> uncurry Token.src; +val attribs = $$$ "[" |-- list attrib --| $$$ "]"; +val opt_attribs = Scan.optional attribs []; + + +(* theorem references *) + +val thm_sel = $$$ "(" |-- list1 + (nat --| minus -- nat >> Facts.FromTo || + nat --| minus >> Facts.From || + nat >> Facts.Single) --| $$$ ")"; + +val xthm = + $$$ "[" |-- attribs --| $$$ "]" >> pair (Facts.named "") || + (literal_fact >> Facts.Fact || + position xname -- Scan.option thm_sel >> Facts.Named) -- opt_attribs; + +val xthms1 = Scan.repeat1 xthm; + end; -type 'a parser = 'a Parse.parser; -type 'a context_parser = 'a Parse.context_parser; - diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/parse_spec.ML --- a/src/Pure/Isar/parse_spec.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/parse_spec.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,17 +6,13 @@ signature PARSE_SPEC = sig - val attribs: Attrib.src list parser - val opt_attribs: Attrib.src list parser val thm_name: string -> Attrib.binding parser val opt_thm_name: string -> Attrib.binding parser val spec: (Attrib.binding * string) parser val specs: (Attrib.binding * string list) parser val alt_specs: (Attrib.binding * string) list parser val where_alt_specs: (Attrib.binding * string) list parser - val xthm: (Facts.ref * Attrib.src list) parser - val xthms1: (Facts.ref * Attrib.src list) list parser - val name_facts: (Attrib.binding * (Facts.ref * Attrib.src list) list) list parser + val name_facts: (Attrib.binding * (Facts.ref * Token.src list) list) list parser val constdecl: (binding * string option * mixfix) parser val constdef: ((binding * string option * mixfix) option * (Attrib.binding * string)) parser val includes: (xstring * Position.T) list parser @@ -37,14 +33,11 @@ (* theorem specifications *) -val attrib = Parse.position Parse.liberal_name -- Parse.!!! Parse.args >> uncurry Args.src; -val attribs = Parse.$$$ "[" |-- Parse.list attrib --| Parse.$$$ "]"; -val opt_attribs = Scan.optional attribs []; - -fun thm_name s = Parse.binding -- opt_attribs --| Parse.$$$ s; +fun thm_name s = Parse.binding -- Parse.opt_attribs --| Parse.$$$ s; fun opt_thm_name s = - Scan.optional ((Parse.binding -- opt_attribs || attribs >> pair Binding.empty) --| Parse.$$$ s) + Scan.optional + ((Parse.binding -- Parse.opt_attribs || Parse.attribs >> pair Binding.empty) --| Parse.$$$ s) Attrib.empty_binding; val spec = opt_thm_name ":" -- Parse.prop; @@ -56,14 +49,7 @@ val where_alt_specs = Parse.where_ |-- Parse.!!! alt_specs; -val xthm = - Parse.$$$ "[" |-- attribs --| Parse.$$$ "]" >> pair (Facts.named "") || - (Parse.literal_fact >> Facts.Fact || - Parse.position Parse.xname -- Scan.option Attrib.thm_sel >> Facts.Named) -- opt_attribs; - -val xthms1 = Scan.repeat1 xthm; - -val name_facts = Parse.and_list1 (opt_thm_name "=" -- xthms1); +val name_facts = Parse.and_list1 (opt_thm_name "=" -- Parse.xthms1); (* basic constant specifications *) @@ -103,7 +89,7 @@ >> Element.Assumes || Parse.$$$ "defines" |-- Parse.!!! (Parse.and_list1 (opt_thm_name ":" -- Parse.propp)) >> Element.Defines || - Parse.$$$ "notes" |-- Parse.!!! (Parse.and_list1 (opt_thm_name "=" -- xthms1)) + Parse.$$$ "notes" |-- Parse.!!! (Parse.and_list1 (opt_thm_name "=" -- Parse.xthms1)) >> (curry Element.Notes ""); fun plus1_unless test scan = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/proof.ML --- a/src/Pure/Isar/proof.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/proof.ML Wed Aug 27 15:52:58 2014 +0200 @@ -61,18 +61,18 @@ val chain: state -> state val chain_facts: thm list -> state -> state val note_thmss: (Thm.binding * (thm list * attribute list) list) list -> state -> state - val note_thmss_cmd: (Attrib.binding * (Facts.ref * Attrib.src list) list) list -> state -> state + val note_thmss_cmd: (Attrib.binding * (Facts.ref * Token.src list) list) list -> state -> state val from_thmss: ((thm list * attribute list) list) list -> state -> state - val from_thmss_cmd: ((Facts.ref * Attrib.src list) list) list -> state -> state + val from_thmss_cmd: ((Facts.ref * Token.src list) list) list -> state -> state val with_thmss: ((thm list * attribute list) list) list -> state -> state - val with_thmss_cmd: ((Facts.ref * Attrib.src list) list) list -> state -> state + val with_thmss_cmd: ((Facts.ref * Token.src list) list) list -> state -> state val using: ((thm list * attribute list) list) list -> state -> state - val using_cmd: ((Facts.ref * Attrib.src list) list) list -> state -> state + val using_cmd: ((Facts.ref * Token.src list) list) list -> state -> state val unfolding: ((thm list * attribute list) list) list -> state -> state - val unfolding_cmd: ((Facts.ref * Attrib.src list) list) list -> state -> state + val unfolding_cmd: ((Facts.ref * Token.src list) list) list -> state -> state val invoke_case: (string * Position.T) * binding option list * attribute list -> state -> state - val invoke_case_cmd: (string * Position.T) * binding option list * Attrib.src list -> + val invoke_case_cmd: (string * Position.T) * binding option list * Token.src list -> state -> state val begin_block: state -> state val next_block: state -> state @@ -395,48 +395,24 @@ Rule_Cases.make_common (Thm.theory_of_thm st, Thm.prop_of st) (map (rpair [] o rpair []) (goals st)); -fun apply_method current_context method state = - let - val (goal_ctxt, (_, {statement, messages = _, using, goal, before_qed, after_qed})) = - find_goal state; - val ctxt = if current_context then context_of state else goal_ctxt; - in - Method.apply method ctxt using goal |> Seq.map (fn (meth_cases, goal') => +fun apply_method text ctxt state = + #2 (#2 (find_goal state)) + |> (fn {statement, messages = _, using, goal, before_qed, after_qed} => + Method.evaluate text ctxt using goal + |> Seq.map (fn (meth_cases, goal') => state |> map_goal (Proof_Context.update_cases false (no_goal_cases goal @ goal_cases goal') #> Proof_Context.update_cases true meth_cases) - (K (statement, [], using, goal', before_qed, after_qed)) I) - end; - -fun select_goals n meth state = - ALLGOALS Goal.conjunction_tac (#2 (#2 (get_goal state))) - |> Seq.maps (fn goal => - state - |> Seq.lift provide_goal ((PRIMITIVE (Goal.restrict 1 n) THEN Goal.conjunction_tac 1) goal) - |> Seq.maps meth - |> Seq.maps (fn state' => state' - |> Seq.lift provide_goal (PRIMITIVE (Goal.unrestrict 1) (#2 (#2 (get_goal state'))))) - |> Seq.maps (apply_method true (K Method.succeed))); - -fun apply_text current_context text state = - let - val ctxt = context_of state; - - fun eval (Method.Basic m) = apply_method current_context m - | eval (Method.Source src) = apply_method current_context (Method.method_cmd ctxt src) - | eval (Method.Then (_, txts)) = Seq.EVERY (map eval txts) - | eval (Method.Orelse (_, txts)) = Seq.FIRST (map eval txts) - | eval (Method.Try (_, txt)) = Seq.TRY (eval txt) - | eval (Method.Repeat1 (_, txt)) = Seq.REPEAT1 (eval txt) - | eval (Method.Select_Goals (_, n, txt)) = select_goals n (eval txt); - in eval text state end; + (K (statement, [], using, goal', before_qed, after_qed)) I)); in -val refine = apply_text true; -val refine_end = apply_text false; -fun refine_insert ths = Seq.hd o refine (Method.Basic (K (Method.insert ths))); +fun refine text state = apply_method text (context_of state) state; +fun refine_end text state = apply_method text (#1 (find_goal state)) state; + +fun refine_insert ths = + Seq.hd o refine (Method.Basic (K (Method.insert ths))); end; @@ -892,9 +868,9 @@ in map (Logic.mk_term o Var) vars end; fun refine_terms n = - refine (Method.Basic (K (RAW_METHOD - (K (HEADGOAL (PRECISE_CONJUNCTS n - (HEADGOAL (CONJUNCTS (ALLGOALS (rtac Drule.termI)))))))))) + refine (Method.Basic (K (NO_CASES o + K (HEADGOAL (PRECISE_CONJUNCTS n + (HEADGOAL (CONJUNCTS (ALLGOALS (rtac Drule.termI))))))))) #> Seq.hd; in diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/proof_context.ML --- a/src/Pure/Isar/proof_context.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/proof_context.ML Wed Aug 27 15:52:58 2014 +0200 @@ -50,6 +50,7 @@ val markup_const: Proof.context -> string -> string val pretty_const: Proof.context -> string -> Pretty.T val transfer: theory -> Proof.context -> Proof.context + val transfer_facts: theory -> Proof.context -> Proof.context val background_theory: (theory -> theory) -> Proof.context -> Proof.context val background_theory_result: (theory -> 'a * theory) -> Proof.context -> 'a * Proof.context val facts_of: Proof.context -> Facts.T @@ -120,7 +121,7 @@ (term list list * (Proof.context -> Proof.context)) * Proof.context val fact_tac: Proof.context -> thm list -> int -> tactic val some_fact_tac: Proof.context -> int -> tactic - val get_fact_generic: Context.generic -> Facts.ref -> thm list + val get_fact_generic: Context.generic -> Facts.ref -> string option * thm list val get_fact: Proof.context -> Facts.ref -> thm list val get_fact_single: Proof.context -> Facts.ref -> thm val get_thms: Proof.context -> xstring -> thm list @@ -154,6 +155,7 @@ val class_alias: binding -> class -> Proof.context -> Proof.context val type_alias: binding -> string -> Proof.context -> Proof.context val const_alias: binding -> string -> Proof.context -> Proof.context + val fact_alias: binding -> string -> Proof.context -> Proof.context val add_const_constraint: string * typ option -> Proof.context -> Proof.context val add_abbrev: string -> binding * term -> Proof.context -> (term * term) * Proof.context val revert_abbrev: string -> string -> Proof.context -> Proof.context @@ -322,16 +324,19 @@ map_tsig (fn tsig as (local_tsig, global_tsig) => let val thy_tsig = Sign.tsig_of thy in if Type.eq_tsig (thy_tsig, global_tsig) then tsig - else (Type.merge_tsig (Context.pretty ctxt) (local_tsig, thy_tsig), thy_tsig) + else (Type.merge_tsig (Context.pretty ctxt) (local_tsig, thy_tsig), thy_tsig) (*historic merge order*) end) |> map_consts (fn consts as (local_consts, global_consts) => let val thy_consts = Sign.consts_of thy in if Consts.eq_consts (thy_consts, global_consts) then consts - else (Consts.merge (local_consts, thy_consts), thy_consts) + else (Consts.merge (local_consts, thy_consts), thy_consts) (*historic merge order*) end); fun transfer thy = Context.raw_transfer thy #> transfer_syntax thy; +fun transfer_facts thy = + map_facts (fn local_facts => Facts.merge (Global_Theory.facts_of thy, local_facts)); + fun background_theory f ctxt = transfer (f (theory_of ctxt)) ctxt; fun background_theory_result f ctxt = @@ -943,22 +948,27 @@ [thm] => thm | [] => err "Failed to retrieve literal fact" | _ => err "Ambiguous specification of literal fact"); - in pick ("", Position.none) [thm] end - | retrieve pick context (Facts.Named ((xname, pos), ivs)) = + in pick true ("", Position.none) [thm] end + | retrieve pick context (Facts.Named ((xname, pos), sel)) = let val thy = Context.theory_of context; - val (name, thms) = + fun immediate thm = {name = xname, static = true, thms = [Thm.transfer thy thm]}; + val {name, static, thms} = (case xname of - "" => (xname, [Thm.transfer thy Drule.dummy_thm]) - | "_" => (xname, [Thm.transfer thy Drule.asm_rl]) + "" => immediate Drule.dummy_thm + | "_" => immediate Drule.asm_rl | _ => retrieve_generic context (xname, pos)); - in pick (name, pos) (Facts.select (Facts.Named ((name, pos), ivs)) thms) end; + val thms' = Facts.select (Facts.Named ((name, pos), sel)) thms; + in pick (static orelse is_some sel) (name, pos) thms' end; in -val get_fact_generic = retrieve (K I); -val get_fact = retrieve (K I) o Context.Proof; -val get_fact_single = retrieve Facts.the_single o Context.Proof; +val get_fact_generic = + retrieve (fn static => fn (name, _) => fn thms => + (if static then NONE else SOME name, thms)); + +val get_fact = retrieve (K (K I)) o Context.Proof; +val get_fact_single = retrieve (K Facts.the_single) o Context.Proof; fun get_thms ctxt = get_fact ctxt o Facts.named; fun get_thm ctxt = get_fact_single ctxt o Facts.named; @@ -1084,6 +1094,7 @@ fun class_alias b c ctxt = (map_tsig o apfst) (Type.class_alias (naming_of ctxt) b c) ctxt; fun type_alias b c ctxt = (map_tsig o apfst) (Type.type_alias (naming_of ctxt) b c) ctxt; fun const_alias b c ctxt = (map_consts o apfst) (Consts.alias (naming_of ctxt) b c) ctxt; +fun fact_alias b c ctxt = map_facts (Facts.alias (naming_of ctxt) b c) ctxt; (* local constants *) @@ -1173,11 +1184,8 @@ (Name_Space.del_table name cases, index) | update_case context is_proper (name, SOME c) (cases, index) = let - val binding = - Binding.make (name, Position.none) - |> not is_proper ? Binding.conceal; - val (_, cases') = cases - |> Name_Space.define context false (binding, ((c, is_proper), index)); + val binding = Binding.name name |> not is_proper ? Binding.conceal; + val (_, cases') = Name_Space.define context false (binding, ((c, is_proper), index)) cases; val index' = index + 1; in (cases', index') end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/rule_cases.ML --- a/src/Pure/Isar/rule_cases.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/rule_cases.ML Wed Aug 27 15:52:58 2014 +0200 @@ -330,7 +330,9 @@ fun get_case_concl name (a, b) = if a = case_concl_tagN then - (case explode_args b of c :: cs => if c = name then SOME cs else NONE) + (case explode_args b of + c :: cs => if c = name then SOME cs else NONE + | [] => NONE) else NONE; fun add_case_concl (name, cs) = Thm.map_tags (fn tags => diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/specification.ML --- a/src/Pure/Isar/specification.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/specification.ML Wed Aug 27 15:52:58 2014 +0200 @@ -51,11 +51,11 @@ val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory val notation_cmd: bool -> Syntax.mode -> (string * mixfix) list -> local_theory -> local_theory val theorems: string -> - (Attrib.binding * (thm list * Attrib.src list) list) list -> + (Attrib.binding * (thm list * Token.src list) list) list -> (binding * typ option * mixfix) list -> bool -> local_theory -> (string * thm list) list * local_theory val theorems_cmd: string -> - (Attrib.binding * (Facts.ref * Attrib.src list) list) list -> + (Attrib.binding * (Facts.ref * Token.src list) list) list -> (binding * string option * mixfix) list -> bool -> local_theory -> (string * thm list) list * local_theory val theorem: string -> Method.text option -> @@ -301,7 +301,7 @@ val facts' = facts |> Attrib.partial_evaluation ctxt' - |> Element.transform_facts (Proof_Context.export_morphism ctxt' lthy); + |> Attrib.transform_facts (Proof_Context.export_morphism ctxt' lthy); val (res, lthy') = lthy |> Local_Theory.notes_kind kind facts'; val _ = Proof_Display.print_results int (Position.thread_data ()) lthy' ((kind, ""), res); in (res, lthy') end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Isar/token.ML --- a/src/Pure/Isar/token.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Isar/token.ML Wed Aug 27 15:52:58 2014 +0200 @@ -10,14 +10,28 @@ Command | Keyword | Ident | LongIdent | SymIdent | Var | TypeIdent | TypeVar | Nat | Float | String | AltString | Verbatim | Cartouche | Space | Comment | InternalValue | Error of string | Sync | EOF + val str_of_kind: kind -> string type file = {src_path: Path.T, lines: string list, digest: SHA1.digest, pos: Position.T} + type T + type src datatype value = - Literal of bool * Markup.T | Text of string | Typ of typ | Term of term | Fact of thm list | - Attribute of morphism -> attribute | Files of file Exn.result list - type T - val str_of_kind: kind -> string + Source of src | + Literal of bool * Markup.T | + Name of string * morphism | + Typ of typ | + Term of term | + Fact of string option * thm list | + Attribute of morphism -> attribute | + Declaration of declaration | + Files of file Exn.result list + val name0: string -> value val pos_of: T -> Position.T val range_of: T list -> Position.range + val src: xstring * Position.T -> T list -> src + val name_of_src: src -> string * Position.T + val args_of_src: src -> T list + val range_of_src: src -> Position.T + val check_src: Proof.context -> 'a Name_Space.table -> src -> src * 'a val eof: T val is_eof: T -> bool val not_eof: T -> bool @@ -47,21 +61,24 @@ val report: T -> Position.report_text val markup: T -> Markup.T val unparse: T -> string + val unparse_src: src -> string list val print: T -> string val text_of: T -> string * string val get_files: T -> file Exn.result list val put_files: file Exn.result list -> T -> T + val make_value: string -> value -> T val get_value: T -> value option val map_value: (value -> value) -> T -> T val reports_of_value: T -> Position.report list - val mk_text: string -> T - val mk_typ: typ -> T - val mk_term: term -> T - val mk_fact: thm list -> T - val mk_attribute: (morphism -> attribute) -> T + val transform: morphism -> T -> T + val transform_src: morphism -> src -> src val init_assignable: T -> T + val init_assignable_src: src -> src val assign: value option -> T -> unit val closure: T -> T + val closure_src: src -> src + val pretty_value: Proof.context -> T -> Pretty.T + val pretty_src: Proof.context -> src -> Pretty.T val ident_or_symbolic: string -> bool val source_proper: (T, 'a) Source.source -> (T, (T, 'a) Source.source) Source.source val source': {do_recover: bool option} -> (unit -> Scan.lexicon * Scan.lexicon) -> @@ -69,7 +86,12 @@ val source: {do_recover: bool option} -> (unit -> Scan.lexicon * Scan.lexicon) -> Position.T -> (Symbol.symbol, 'a) Source.source -> (T, (Symbol_Pos.T, Position.T * (Symbol.symbol, 'a) Source.source) Source.source) Source.source - val read_antiq: Scan.lexicon -> (T list -> 'a * T list) -> Symbol_Pos.T list * Position.T -> 'a + type 'a parser = T list -> 'a * T list + type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list) + val read: Scan.lexicon -> 'a parser -> Symbol_Pos.T list * Position.T -> 'a list + val read_antiq: Scan.lexicon -> 'a parser -> Symbol_Pos.T list * Position.T -> 'a + val syntax_generic: 'a context_parser -> src -> Context.generic -> 'a * Context.generic + val syntax: 'a context_parser -> src -> Proof.context -> 'a * Proof.context end; structure Token: TOKEN = @@ -77,39 +99,13 @@ (** tokens **) -(* token values *) - -(*The value slot assigns an (optional) internal value to a token, - usually as a side-effect of special scanner setup (see also - args.ML). Note that an assignable ref designates an intermediate - state of internalization -- it is NOT meant to persist.*) - -type file = {src_path: Path.T, lines: string list, digest: SHA1.digest, pos: Position.T}; - -datatype value = - Literal of bool * Markup.T | - Text of string | - Typ of typ | - Term of term | - Fact of thm list | - Attribute of morphism -> attribute | - Files of file Exn.result list; - -datatype slot = - Slot | - Value of value option | - Assignable of value option Unsynchronized.ref; - - -(* datatype token *) +(* token kind *) datatype kind = Command | Keyword | Ident | LongIdent | SymIdent | Var | TypeIdent | TypeVar | Nat | Float | String | AltString | Verbatim | Cartouche | Space | Comment | InternalValue | Error of string | Sync | EOF; -datatype T = Token of (Symbol_Pos.text * Position.range) * (kind * string) * slot; - val str_of_kind = fn Command => "command" | Keyword => "keyword" @@ -135,6 +131,42 @@ val delimited_kind = member (op =) [String, AltString, Verbatim, Cartouche, Comment]; +(* datatype token *) + +(*The value slot assigns an (optional) internal value to a token, + usually as a side-effect of special scanner setup (see also + args.ML). Note that an assignable ref designates an intermediate + state of internalization -- it is NOT meant to persist.*) + +type file = {src_path: Path.T, lines: string list, digest: SHA1.digest, pos: Position.T}; + +datatype T = Token of (Symbol_Pos.text * Position.range) * (kind * string) * slot + +and src = + Src of + {name: string * Position.T, + args: T list, + output_info: (string * Markup.T) option} + +and slot = + Slot | + Value of value option | + Assignable of value option Unsynchronized.ref + +and value = + Source of src | + Literal of bool * Markup.T | + Name of string * morphism | + Typ of typ | + Term of term | + Fact of string option * thm list | (*optional name for dynamic fact, i.e. fact "variable"*) + Attribute of morphism -> attribute | + Declaration of declaration | + Files of file Exn.result list; + +fun name0 a = Name (a, Morphism.identity); + + (* position *) fun pos_of (Token ((_, (pos, _)), _, _)) = pos; @@ -146,6 +178,29 @@ | range_of [] = Position.no_range; +(* src *) + +fun src name args = Src {name = name, args = args, output_info = NONE}; + +fun map_args f (Src {name, args, output_info}) = + Src {name = name, args = map f args, output_info = output_info}; + +fun name_of_src (Src {name, ...}) = name; +fun args_of_src (Src {args, ...}) = args; + +fun range_of_src (Src {name = (_, pos), args, ...}) = + if null args then pos + else Position.set_range (pos, #2 (range_of args)); + +fun check_src ctxt table (Src {name = (xname, pos), args, output_info = _}) = + let + val (name, x) = Name_Space.check (Context.Proof ctxt) table (xname, pos); + val space = Name_Space.space_of_table table; + val kind = Name_Space.kind_of space; + val markup = Name_Space.markup space name; + in (Src {name = (name, pos), args = args, output_info = SOME (kind, markup)}, x) end; + + (* control tokens *) fun mk_eof pos = Token (("", (pos, Position.none)), (EOF, ""), Slot); @@ -288,6 +343,8 @@ | EOF => "" | _ => x); +fun unparse_src (Src {args, ...}) = map unparse args; + fun print tok = Markup.markup (markup tok) (unparse tok); fun text_of tok = @@ -320,6 +377,9 @@ (* access values *) +fun make_value name v = + Token ((name, Position.no_range), (InternalValue, name), Value (SOME v)); + fun get_value (Token (_, _, Value v)) = v | get_value _ = NONE; @@ -340,15 +400,21 @@ | _ => []); -(* make values *) - -fun mk_value k v = Token ((k, Position.no_range), (InternalValue, k), Value (SOME v)); +(* transform *) -val mk_text = mk_value "" o Text; -val mk_typ = mk_value "" o Typ; -val mk_term = mk_value "" o Term; -val mk_fact = mk_value "" o Fact; -val mk_attribute = mk_value "" o Attribute; +fun transform phi = + map_value (fn v => + (case v of + Source src => Source (transform_src phi src) + | Literal _ => v + | Name (a, psi) => Name (a, psi $> phi) + | Typ T => Typ (Morphism.typ phi T) + | Term t => Term (Morphism.term phi t) + | Fact (a, ths) => Fact (a, Morphism.fact phi ths) + | Attribute att => Attribute (Morphism.transform phi att) + | Declaration decl => Declaration (Morphism.transform phi decl) + | Files _ => v)) +and transform_src phi = map_args (transform phi); (* static binding *) @@ -358,6 +424,8 @@ | init_assignable (tok as Token (_, _, Assignable r)) = (r := NONE; tok) | init_assignable tok = tok; +val init_assignable_src = map_args init_assignable; + (*2nd stage: assign values as side-effect of scanning*) fun assign v (Token (_, _, Assignable r)) = r := v | assign _ _ = (); @@ -366,6 +434,32 @@ fun closure (Token (x, y, Assignable (Unsynchronized.ref v))) = Token (x, y, Value v) | closure tok = tok; +val closure_src = map_args closure; + + +(* pretty *) + +fun pretty_value ctxt tok = + (case get_value tok of + SOME (Literal markup) => + let val x = content_of tok + in Pretty.mark_str (keyword_markup markup x, x) end + | SOME (Name (a, _)) => Pretty.str (quote a) + | SOME (Typ T) => Syntax.pretty_typ ctxt T + | SOME (Term t) => Syntax.pretty_term ctxt t + | SOME (Fact (_, ths)) => + Pretty.enclose "(" ")" (Pretty.breaks (map (Pretty.backquote o Display.pretty_thm ctxt) ths)) + | _ => Pretty.mark_str (markup tok, unparse tok)); + +fun pretty_src ctxt src = + let + val Src {name = (name, _), args, output_info} = src; + val prt_name = + (case output_info of + NONE => Pretty.str name + | SOME (_, markup) => Pretty.mark_str (markup, name)); + val prt_arg = pretty_value ctxt; + in Pretty.block (Pretty.breaks (prt_name :: map prt_arg args)) end; (** scanners **) @@ -492,19 +586,64 @@ end; -(* read_antiq *) + +(** parsers **) + +type 'a parser = T list -> 'a * T list; +type 'a context_parser = Context.generic * T list -> 'a * (Context.generic * T list); + + +(* read source *) + +fun read lex scan (syms, pos) = + Source.of_list syms + |> source' {do_recover = NONE} (K (lex, Scan.empty_lexicon)) + |> source_proper + |> Source.source stopper (Scan.error (Scan.bulk scan)) NONE + |> Source.exhaust; fun read_antiq lex scan (syms, pos) = let - fun err msg = cat_error msg ("Malformed antiquotation" ^ Position.here pos ^ ":\n" ^ - "@{" ^ Symbol_Pos.content syms ^ "}"); + fun err msg = + cat_error msg ("Malformed antiquotation" ^ Position.here pos ^ ":\n" ^ + "@{" ^ Symbol_Pos.content syms ^ "}"); + val res = read lex scan (syms, pos) handle ERROR msg => err msg; + in (case res of [x] => x | _ => err "") end; + + +(* wrapped syntax *) - val res = - Source.of_list syms - |> source' {do_recover = NONE} (K (lex, Scan.empty_lexicon)) - |> source_proper - |> Source.source stopper (Scan.error (Scan.bulk scan)) NONE - |> Source.exhaust; - in (case res of [x] => x | _ => err "") handle ERROR msg => err msg end; +fun syntax_generic scan (Src {name = (name, pos), args = args0, output_info}) context = + let + val args1 = map init_assignable args0; + fun reported_text () = + if Context_Position.is_visible_generic context then + ((pos, Markup.operator) :: maps (reports_of_value o closure) args1) + |> map (fn (p, m) => Position.reported_text p m "") + else []; + in + (case Scan.error (Scan.finite' stopper (Scan.option scan)) (context, args1) of + (SOME x, (context', [])) => + let val _ = Output.report (reported_text ()) + in (x, context') end + | (_, (_, args2)) => + let + val print_name = + (case output_info of + NONE => quote name + | SOME (kind, markup) => plain_words kind ^ " " ^ quote (Markup.markup markup name)); + val print_args = + if null args2 then "" else ":\n " ^ space_implode " " (map print args2); + in + error ("Bad arguments for " ^ print_name ^ Position.here pos ^ print_args ^ + Markup.markup_report (implode (reported_text ()))) + end) + end; + +fun syntax scan src = apsnd Context.the_proof o syntax_generic scan src o Context.Proof; end; + +type 'a parser = 'a Token.parser; +type 'a context_parser = 'a Token.context_parser; + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ML/ml_antiquotation.ML --- a/src/Pure/ML/ml_antiquotation.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ML/ml_antiquotation.ML Wed Aug 27 15:52:58 2014 +0200 @@ -8,7 +8,7 @@ sig val variant: string -> Proof.context -> string * Proof.context val declaration: binding -> 'a context_parser -> - (Args.src -> 'a -> Proof.context -> ML_Context.decl * Proof.context) -> + (Token.src -> 'a -> Proof.context -> ML_Context.decl * Proof.context) -> theory -> theory val inline: binding -> string context_parser -> theory -> theory val value: binding -> string context_parser -> theory -> theory @@ -40,7 +40,7 @@ fun declaration name scan body = ML_Context.add_antiquotation name (fn src => fn orig_ctxt => - let val (x, _) = Args.syntax scan src orig_ctxt + let val (x, _) = Token.syntax scan src orig_ctxt in body src x orig_ctxt end); fun inline name scan = @@ -62,7 +62,7 @@ (fn src => fn () => fn ctxt => let val (a, ctxt') = variant "position" ctxt; - val (_, pos) = Args.name_of_src src; + val (_, pos) = Token.name_of_src src; val env = "val " ^ a ^ " = " ^ ML_Syntax.print_position pos ^ ";\n"; val body = "Isabelle." ^ a; in (K (env, body), ctxt') end) #> diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ML/ml_antiquotations.ML --- a/src/Pure/ML/ml_antiquotations.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ML/ml_antiquotations.ML Wed Aug 27 15:52:58 2014 +0200 @@ -52,6 +52,16 @@ ML_Syntax.atomic (ML_Syntax.print_term t)))); +(* embedded source *) + +val _ = Theory.setup + (ML_Antiquotation.value @{binding source} + (Scan.lift Args.text_source_position >> (fn {delimited, text, pos} => + "{delimited = " ^ Bool.toString delimited ^ + ", text = " ^ ML_Syntax.print_string text ^ + ", pos = " ^ ML_Syntax.print_position pos ^ "}"))); + + (* ML support *) val _ = Theory.setup @@ -64,7 +74,7 @@ (Scan.lift (Scan.optional Args.name "Output.writeln")) (fn src => fn output => fn ctxt => let - val (_, pos) = Args.name_of_src src; + val (_, pos) = Token.name_of_src src; val (a, ctxt') = ML_Antiquotation.variant "output" ctxt; val env = "val " ^ a ^ ": string -> unit =\n\ diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ML/ml_context.ML --- a/src/Pure/ML/ml_context.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ML/ml_context.ML Wed Aug 27 15:52:58 2014 +0200 @@ -14,7 +14,7 @@ val exec: (unit -> unit) -> Context.generic -> Context.generic val check_antiquotation: Proof.context -> xstring * Position.T -> string type decl = Proof.context -> string * string - val add_antiquotation: binding -> (Args.src -> Proof.context -> decl * Proof.context) -> + val add_antiquotation: binding -> (Token.src -> Proof.context -> decl * Proof.context) -> theory -> theory val print_antiquotations: Proof.context -> unit val eval_antiquotes: ML_Lex.token Antiquote.antiquote list * Position.T -> @@ -55,7 +55,7 @@ type decl = Proof.context -> string * string; (*final context -> ML env, ML body*) structure Antiquotations = Theory_Data ( - type T = (Args.src -> Proof.context -> decl * Proof.context) Name_Space.table; + type T = (Token.src -> Proof.context -> decl * Proof.context) Name_Space.table; val empty : T = Name_Space.empty_table Markup.ML_antiquotationN; val extend = I; fun merge data : T = Name_Space.merge_tables data; @@ -75,7 +75,7 @@ |> Pretty.writeln; fun apply_antiquotation src ctxt = - let val (src', f) = Args.check_src ctxt (get_antiquotations ctxt) src + let val (src', f) = Token.check_src ctxt (get_antiquotations ctxt) src in f src' ctxt end; @@ -85,7 +85,7 @@ val antiq = Parse.!!! (Parse.position Parse.xname -- Parse.args --| Scan.ahead Parse.eof) - >> uncurry Args.src; + >> uncurry Token.src; val begin_env0 = ML_Lex.tokenize "structure Isabelle =\nstruct\n"; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ML/ml_thms.ML --- a/src/Pure/ML/ml_thms.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ML/ml_thms.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,7 +6,7 @@ signature ML_THMS = sig - val the_attributes: Proof.context -> int -> Args.src list + val the_attributes: Proof.context -> int -> Token.src list val the_thmss: Proof.context -> thm list list val get_stored_thms: unit -> thm list val get_stored_thm: unit -> thm @@ -25,7 +25,7 @@ structure Data = Proof_Data ( - type T = Args.src list Inttab.table * thms list; + type T = Token.src list Inttab.table * thms list; fun init _ = (Inttab.empty, []); ); @@ -37,18 +37,17 @@ val cons_thms = Data.map o apsnd o cons; - (* attribute source *) val _ = Theory.setup - (ML_Antiquotation.declaration @{binding attributes} (Scan.lift Parse_Spec.attribs) + (ML_Antiquotation.declaration @{binding attributes} (Scan.lift Parse.attribs) (fn _ => fn raw_srcs => fn ctxt => let val i = serial (); - val srcs = map (Attrib.check_src ctxt) raw_srcs; - val _ = map (Attrib.attribute ctxt) srcs; + val (a, ctxt') = ctxt - |> ML_Antiquotation.variant "attributes" ||> put_attributes (i, srcs); + |> ML_Antiquotation.variant "attributes" + ||> put_attributes (i, Attrib.check_attribs ctxt raw_srcs); val ml = ("val " ^ a ^ " = ML_Thms.the_attributes ML_context " ^ string_of_int i ^ ";\n", "Isabelle." ^ a); diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/command.ML --- a/src/Pure/PIDE/command.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/command.ML Wed Aug 27 15:52:58 2014 +0200 @@ -121,9 +121,9 @@ in {src_path = src_path, lines = lines, digest = digest, pos = file_pos} end fun resolve_files master_dir blobs toks = - (case Thy_Syntax.parse_spans toks of + (case Outer_Syntax.parse_spans toks of [span] => span - |> Thy_Syntax.resolve_files (fn cmd => fn (path, pos) => + |> Command_Span.resolve_files (fn cmd => fn (path, pos) => let fun make_file src_path (Exn.Res (file_node, NONE)) = Exn.interruptible_capture (fn () => @@ -140,7 +140,7 @@ map2 make_file src_paths blobs else error ("Misalignment of inlined files" ^ Position.here pos) end) - |> Thy_Syntax.span_content + |> Command_Span.content | _ => toks); in diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/command.scala --- a/src/Pure/PIDE/command.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/command.scala Wed Aug 27 15:52:58 2014 +0200 @@ -189,8 +189,7 @@ def bad(): Unit = Output.warning("Ignored report message: " + msg) msg match { - case XML.Elem( - Markup(name, atts @ Position.Reported(id, chunk_name, symbol_range)), args) => + case XML.Elem(Markup(name, atts @ Position.Identified(id, chunk_name)), args) => val target = if (self_id(id) && command.chunks.isDefinedAt(chunk_name)) @@ -198,8 +197,8 @@ else if (chunk_name == Symbol.Text_Chunk.Default) other_id(id) else None - target match { - case Some((target_name, target_chunk)) => + (target, atts) match { + case (Some((target_name, target_chunk)), Position.Range(symbol_range)) => target_chunk.incorporate(symbol_range) match { case Some(range) => val props = Position.purge(atts) @@ -207,7 +206,7 @@ state.add_markup(false, target_name, info) case None => bad(); state } - case None => + case _ => // silently ignore excessive reports state } @@ -232,7 +231,8 @@ if (Protocol.is_inlined(message)) { for { (chunk_name, chunk) <- command.chunks.iterator - range <- Protocol.message_positions(self_id, chunk_name, chunk, message) + range <- Protocol.message_positions( + self_id, command.position, chunk_name, chunk, message) } st = st.add_markup(false, chunk_name, Text.Info(range, message2)) } st @@ -250,39 +250,18 @@ /* make commands */ - def name(span: List[Token]): String = - span.find(_.is_command) match { case Some(tok) => tok.source case _ => "" } - - private def source_span(span: List[Token]): (String, List[Token]) = - { - val source: String = - span match { - case List(tok) => tok.source - case _ => span.map(_.source).mkString - } - - val span1 = new mutable.ListBuffer[Token] - var i = 0 - for (Token(kind, s) <- span) { - val n = s.length - val s1 = source.substring(i, i + n) - span1 += Token(kind, s1) - i += n - } - (source, span1.toList) - } - def apply( id: Document_ID.Command, node_name: Document.Node.Name, blobs: List[Blob], - span: List[Token]): Command = + span: Command_Span.Span): Command = { - val (source, span1) = source_span(span) + val (source, span1) = span.compact_source new Command(id, node_name, blobs, span1, source, Results.empty, Markup_Tree.empty) } - val empty: Command = Command(Document_ID.none, Document.Node.Name.empty, Nil, Nil) + val empty: Command = + Command(Document_ID.none, Document.Node.Name.empty, Nil, Command_Span.empty) def unparsed( id: Document_ID.Command, @@ -290,8 +269,8 @@ results: Results, markup: Markup_Tree): Command = { - val (source1, span) = source_span(List(Token(Token.Kind.UNPARSED, source))) - new Command(id, Document.Node.Name.empty, Nil, span, source1, results, markup) + val (source1, span1) = Command_Span.unparsed(source).compact_source + new Command(id, Document.Node.Name.empty, Nil, span1, source1, results, markup) } def unparsed(source: String): Command = @@ -333,25 +312,30 @@ val id: Document_ID.Command, val node_name: Document.Node.Name, val blobs: List[Command.Blob], - val span: List[Token], + val span: Command_Span.Span, val source: String, val init_results: Command.Results, val init_markup: Markup_Tree) { + /* name */ + + def name: String = + span.kind match { case Command_Span.Command_Span(name, _) => name case _ => "" } + + def position: Position.T = + span.kind match { case Command_Span.Command_Span(_, pos) => pos case _ => Position.none } + + override def toString: String = id + "/" + span.kind.toString + + /* classification */ + def is_proper: Boolean = span.kind.isInstanceOf[Command_Span.Command_Span] + def is_ignored: Boolean = span.kind == Command_Span.Ignored_Span + def is_undefined: Boolean = id == Document_ID.none - val is_unparsed: Boolean = span.exists(_.is_unparsed) - val is_unfinished: Boolean = span.exists(_.is_unfinished) - - val is_ignored: Boolean = !span.exists(_.is_proper) - val is_malformed: Boolean = !is_ignored && (!span.head.is_command || span.exists(_.is_error)) - def is_command: Boolean = !is_ignored && !is_malformed - - def name: String = Command.name(span) - - override def toString = - id + "/" + (if (is_command) name else if (is_ignored) "IGNORED" else "MALFORMED") + val is_unparsed: Boolean = span.content.exists(_.is_unparsed) + val is_unfinished: Boolean = span.content.exists(_.is_unfinished) /* blobs */ @@ -379,7 +363,8 @@ def range: Text.Range = chunk.range val proper_range: Text.Range = - Text.Range(0, (length /: span.reverse.iterator.takeWhile(_.is_improper))(_ - _.source.length)) + Text.Range(0, + (length /: span.content.reverse.iterator.takeWhile(_.is_improper))(_ - _.source.length)) def source(range: Text.Range): String = source.substring(range.start, range.stop) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/command_span.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/PIDE/command_span.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,70 @@ +(* Title: Pure/PIDE/command_span.ML + Author: Makarius + +Syntactic representation of command spans. +*) + +signature COMMAND_SPAN = +sig + datatype kind = Command_Span of string * Position.T | Ignored_Span | Malformed_Span + datatype span = Span of kind * Token.T list + val kind: span -> kind + val content: span -> Token.T list + val resolve_files: (string -> Path.T * Position.T -> Token.file Exn.result list) -> span -> span +end; + +structure Command_Span: COMMAND_SPAN = +struct + +datatype kind = Command_Span of string * Position.T | Ignored_Span | Malformed_Span; +datatype span = Span of kind * Token.T list; + +fun kind (Span (k, _)) = k; +fun content (Span (_, toks)) = toks; + + +(* resolve inlined files *) + +local + +fun clean ((i1, t1) :: (i2, t2) :: toks) = + if Token.keyword_with (fn s => s = "%" orelse s = "--") t1 then clean toks + else (i1, t1) :: clean ((i2, t2) :: toks) + | clean toks = toks; + +fun clean_tokens toks = + ((0 upto length toks - 1) ~~ toks) + |> filter (fn (_, tok) => Token.is_proper tok) + |> clean; + +fun find_file ((_, tok) :: toks) = + if Token.is_command tok then + toks |> get_first (fn (i, tok) => + if Token.is_name tok then + SOME (i, (Path.explode (Token.content_of tok), Token.pos_of tok)) + handle ERROR msg => error (msg ^ Position.here (Token.pos_of tok)) + else NONE) + else NONE + | find_file [] = NONE; + +in + +fun resolve_files read_files span = + (case span of + Span (Command_Span (cmd, pos), toks) => + if Keyword.is_theory_load cmd then + (case find_file (clean_tokens toks) of + NONE => error ("Bad file argument of command " ^ quote cmd ^ Position.here pos) + | SOME (i, path) => + let + val toks' = toks |> map_index (fn (j, tok) => + if i = j then Token.put_files (read_files cmd path) tok + else tok); + in Span (Command_Span (cmd, pos), toks') end) + else span + | _ => span); + +end; + +end; + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/command_span.scala --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/PIDE/command_span.scala Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,104 @@ +/* Title: Pure/PIDE/command_span.scala + Author: Makarius + +Syntactic representation of command spans. +*/ + +package isabelle + + +import scala.collection.mutable + + +object Command_Span +{ + sealed abstract class Kind { + override def toString: String = + this match { + case Command_Span(name, _) => if (name != "") name else "" + case Ignored_Span => "" + case Malformed_Span => "" + } + } + case class Command_Span(name: String, pos: Position.T) extends Kind + case object Ignored_Span extends Kind + case object Malformed_Span extends Kind + + sealed case class Span(kind: Kind, content: List[Token]) + { + def compact_source: (String, Span) = + { + val source: String = + content match { + case List(tok) => tok.source + case toks => toks.map(_.source).mkString + } + + val content1 = new mutable.ListBuffer[Token] + var i = 0 + for (Token(kind, s) <- content) { + val n = s.length + val s1 = source.substring(i, i + n) + content1 += Token(kind, s1) + i += n + } + (source, Span(kind, content1.toList)) + } + } + + val empty: Span = Span(Ignored_Span, Nil) + + def unparsed(source: String): Span = + Span(Malformed_Span, List(Token(Token.Kind.UNPARSED, source))) + + + /* resolve inlined files */ + + private def find_file(tokens: List[Token]): Option[String] = + { + def clean(toks: List[Token]): List[Token] = + toks match { + case t :: _ :: ts if t.is_keyword && (t.source == "%" || t.source == "--") => clean(ts) + case t :: ts => t :: clean(ts) + case Nil => Nil + } + clean(tokens.filter(_.is_proper)) match { + case tok :: toks if tok.is_command => toks.find(_.is_name).map(_.content) + case _ => None + } + } + + def span_files(syntax: Prover.Syntax, span: Span): List[String] = + span.kind match { + case Command_Span(name, _) => + syntax.load_command(name) match { + case Some(exts) => + find_file(span.content) match { + case Some(file) => + if (exts.isEmpty) List(file) + else exts.map(ext => file + "." + ext) + case None => Nil + } + case None => Nil + } + case _ => Nil + } + + def resolve_files( + resources: Resources, + syntax: Prover.Syntax, + node_name: Document.Node.Name, + span: Span, + get_blob: Document.Node.Name => Option[Document.Blob]) + : List[Command.Blob] = + { + span_files(syntax, span).map(file_name => + Exn.capture { + val name = + Document.Node.Name(resources.append(node_name.master_dir, Path.explode(file_name))) + val blob = get_blob(name).map(blob => ((blob.bytes.sha1_digest, blob.chunk))) + (name, blob) + }) + } +} + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/document.ML --- a/src/Pure/PIDE/document.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/document.ML Wed Aug 27 15:52:58 2014 +0200 @@ -318,7 +318,7 @@ val span = Lazy.lazy (fn () => Position.setmp_thread_data (Position.id_only id) - (fn () => Thy_Syntax.parse_tokens (Keyword.get_lexicons ()) (Position.id id) text) ()); + (fn () => Outer_Syntax.scan (Keyword.get_lexicons ()) (Position.id id) text) ()); val _ = Position.setmp_thread_data (Position.id_only id) (fn () => Output.status (Markup.markup_only Markup.accepted)) (); diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/markup.ML --- a/src/Pure/PIDE/markup.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/markup.ML Wed Aug 27 15:52:58 2014 +0200 @@ -72,6 +72,7 @@ val fixedN: string val fixed: string -> T val caseN: string val case_: string -> T val dynamic_factN: string val dynamic_fact: string -> T + val method_modifierN: string val tfreeN: string val tfree: T val tvarN: string val tvar: T val freeN: string val free: T @@ -365,7 +366,7 @@ val (hiddenN, hidden) = markup_elem "hidden"; -(* formal entities *) +(* misc entities *) val system_optionN = "system_option"; @@ -378,6 +379,8 @@ val (caseN, case_) = markup_string "case" nameN; val (dynamic_factN, dynamic_fact) = markup_string "dynamic_fact" nameN; +val method_modifierN = "method_modifier"; + (* inner syntax *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/markup.scala --- a/src/Pure/PIDE/markup.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/markup.scala Wed Aug 27 15:52:58 2014 +0200 @@ -169,7 +169,7 @@ val HIDDEN = "hidden" - /* logical entities */ + /* misc entities */ val CLASS = "class" val TYPE_NAME = "type_name" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/markup_tree.scala --- a/src/Pure/PIDE/markup_tree.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/markup_tree.scala Wed Aug 27 15:52:58 2014 +0200 @@ -261,7 +261,7 @@ make_body(root_range, Nil, overlapping(root_range)) } - override def toString = + override def toString: String = branches.toList.map(_._2) match { case Nil => "Empty" case list => list.mkString("Tree(", ",", ")") diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/protocol.scala --- a/src/Pure/PIDE/protocol.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/protocol.scala Wed Aug 27 15:52:58 2014 +0200 @@ -312,17 +312,27 @@ def message_positions( self_id: Document_ID.Generic => Boolean, + command_position: Position.T, chunk_name: Symbol.Text_Chunk.Name, chunk: Symbol.Text_Chunk, message: XML.Elem): Set[Text.Range] = { def elem_positions(props: Properties.T, set: Set[Text.Range]): Set[Text.Range] = props match { - case Position.Reported(id, name, symbol_range) - if self_id(id) && name == chunk_name => - chunk.incorporate(symbol_range) match { - case Some(range) => set + range - case _ => set + case Position.Identified(id, name) if self_id(id) && name == chunk_name => + val opt_range = + Position.Range.unapply(props) orElse { + if (name == Symbol.Text_Chunk.Default) + Position.Range.unapply(command_position) + else None + } + opt_range match { + case Some(symbol_range) => + chunk.incorporate(symbol_range) match { + case Some(range) => set + range + case _ => set + } + case None => set } case _ => set } @@ -343,8 +353,25 @@ } -trait Protocol extends Prover +trait Protocol { + /* text */ + + def encode(s: String): String + def decode(s: String): String + + object Encode + { + val string: XML.Encode.T[String] = (s => XML.Encode.string(encode(s))) + } + + + /* protocol commands */ + + def protocol_command_bytes(name: String, args: Bytes*): Unit + def protocol_command(name: String, args: String*): Unit + + /* options */ def options(opts: Options): Unit = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/prover.scala --- a/src/Pure/PIDE/prover.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/prover.scala Wed Aug 27 15:52:58 2014 +0200 @@ -1,12 +1,16 @@ /* Title: Pure/PIDE/prover.scala Author: Makarius + Options: :folding=explicit: -General prover operations. +Prover process wrapping. */ package isabelle +import java.io.{InputStream, OutputStream, BufferedReader, BufferedOutputStream, IOException} + + object Prover { /* syntax */ @@ -14,12 +18,23 @@ trait Syntax { def add_keywords(keywords: Thy_Header.Keywords): Syntax - def scan(input: CharSequence): List[Token] - def load(span: List[Token]): Option[List[String]] + def parse_spans(input: CharSequence): List[Command_Span.Span] + def load_command(name: String): Option[List[String]] def load_commands_in(text: String): Boolean } + /* underlying system process */ + + trait System_Process + { + def stdout: BufferedReader + def stderr: BufferedReader + def terminate: Unit + def join: Int + } + + /* messages */ sealed abstract class Message @@ -68,44 +83,287 @@ } -trait Prover +abstract class Prover( + receiver: Prover.Message => Unit, + system_channel: System_Channel, + system_process: Prover.System_Process) extends Protocol { - /* text and tree data */ + /** receiver output **/ + + val xml_cache: XML.Cache = new XML.Cache() + + private def system_output(text: String) + { + receiver(new Prover.Output(XML.Elem(Markup(Markup.SYSTEM, Nil), List(XML.Text(text))))) + } + + private def protocol_output(props: Properties.T, bytes: Bytes) + { + receiver(new Prover.Protocol_Output(props, bytes)) + } + + private def output(kind: String, props: Properties.T, body: XML.Body) + { + if (kind == Markup.INIT) system_channel.accepted() - def encode(s: String): String - def decode(s: String): String + val main = XML.Elem(Markup(kind, props), Protocol.clean_message(body)) + val reports = Protocol.message_reports(props, body) + for (msg <- main :: reports) receiver(new Prover.Output(xml_cache.elem(msg))) + } + + private def exit_message(rc: Int) + { + output(Markup.EXIT, Markup.Return_Code(rc), List(XML.Text("Return code: " + rc.toString))) + } + + - object Encode + /** process manager **/ + + private val (_, process_result) = + Simple_Thread.future("process_result") { system_process.join } + + private def terminate_process() { - val string: XML.Encode.T[String] = (s => XML.Encode.string(encode(s))) + try { system_process.terminate } + catch { + case exn @ ERROR(_) => system_output("Failed to terminate prover process: " + exn.getMessage) + } } - def xml_cache: XML.Cache + private val process_manager = Simple_Thread.fork("process_manager") + { + val (startup_failed, startup_errors) = + { + var finished: Option[Boolean] = None + val result = new StringBuilder(100) + while (finished.isEmpty && (system_process.stderr.ready || !process_result.is_finished)) { + while (finished.isEmpty && system_process.stderr.ready) { + try { + val c = system_process.stderr.read + if (c == 2) finished = Some(true) + else result += c.toChar + } + catch { case _: IOException => finished = Some(false) } + } + Thread.sleep(10) + } + (finished.isEmpty || !finished.get, result.toString.trim) + } + if (startup_errors != "") system_output(startup_errors) + + if (startup_failed) { + terminate_process() + process_result.join + exit_message(127) + } + else { + val (command_stream, message_stream) = system_channel.rendezvous() + + command_input_init(command_stream) + val stdout = physical_output(false) + val stderr = physical_output(true) + val message = message_output(message_stream) + + val rc = process_result.join + system_output("process terminated") + command_input_close() + for (thread <- List(stdout, stderr, message)) thread.join + system_output("process_manager terminated") + exit_message(rc) + } + system_channel.accepted() + } + + + /* management methods */ + + def join() { process_manager.join() } + + def terminate() + { + command_input_close() + system_output("Terminating prover process") + terminate_process() + } + + + + /** process streams **/ + + /* command input */ + + private var command_input: Option[Consumer_Thread[List[Bytes]]] = None + + private def command_input_close(): Unit = command_input.foreach(_.shutdown) + + private def command_input_init(raw_stream: OutputStream) + { + val name = "command_input" + val stream = new BufferedOutputStream(raw_stream) + command_input = + Some( + Consumer_Thread.fork(name)( + consume = + { + case chunks => + try { + Bytes(chunks.map(_.length).mkString("", ",", "\n")).write(stream) + chunks.foreach(_.write(stream)) + stream.flush + true + } + catch { case e: IOException => system_output(name + ": " + e.getMessage); false } + }, + finish = { case () => stream.close; system_output(name + " terminated") } + ) + ) + } - /* process management */ + /* physical output */ + + private def physical_output(err: Boolean): Thread = + { + val (name, reader, markup) = + if (err) ("standard_error", system_process.stderr, Markup.STDERR) + else ("standard_output", system_process.stdout, Markup.STDOUT) - def join(): Unit - def terminate(): Unit - - def protocol_command_bytes(name: String, args: Bytes*): Unit - def protocol_command(name: String, args: String*): Unit + Simple_Thread.fork(name) { + try { + var result = new StringBuilder(100) + var finished = false + while (!finished) { + //{{{ + var c = -1 + var done = false + while (!done && (result.length == 0 || reader.ready)) { + c = reader.read + if (c >= 0) result.append(c.asInstanceOf[Char]) + else done = true + } + if (result.length > 0) { + output(markup, Nil, List(XML.Text(decode(result.toString)))) + result.length = 0 + } + else { + reader.close + finished = true + } + //}}} + } + } + catch { case e: IOException => system_output(name + ": " + e.getMessage) } + system_output(name + " terminated") + } + } - /* PIDE protocol commands */ + /* message output */ + + private def message_output(stream: InputStream): Thread = + { + class EOF extends Exception + class Protocol_Error(msg: String) extends Exception(msg) + + val name = "message_output" + Simple_Thread.fork(name) { + val default_buffer = new Array[Byte](65536) + var c = -1 - def options(opts: Options): Unit + def read_int(): Int = + //{{{ + { + var n = 0 + c = stream.read + if (c == -1) throw new EOF + while (48 <= c && c <= 57) { + n = 10 * n + (c - 48) + c = stream.read + } + if (c != 10) + throw new Protocol_Error("malformed header: expected integer followed by newline") + else n + } + //}}} - def define_blob(digest: SHA1.Digest, bytes: Bytes): Unit - def define_command(command: Command): Unit + def read_chunk_bytes(): (Array[Byte], Int) = + //{{{ + { + val n = read_int() + val buf = + if (n <= default_buffer.size) default_buffer + else new Array[Byte](n) + + var i = 0 + var m = 0 + do { + m = stream.read(buf, i, n - i) + if (m != -1) i += m + } + while (m != -1 && n > i) + + if (i != n) + throw new Protocol_Error("bad chunk (unexpected EOF after " + i + " of " + n + " bytes)") + + (buf, n) + } + //}}} - def discontinue_execution(): Unit - def cancel_exec(id: Document_ID.Exec): Unit + def read_chunk(): XML.Body = + { + val (buf, n) = read_chunk_bytes() + YXML.parse_body_failsafe(UTF8.decode_chars(decode, buf, 0, n)) + } - def update(old_id: Document_ID.Version, new_id: Document_ID.Version, - edits: List[Document.Edit_Command]): Unit - def remove_versions(versions: List[Document.Version]): Unit + try { + do { + try { + val header = read_chunk() + header match { + case List(XML.Elem(Markup(name, props), Nil)) => + val kind = name.intern + if (kind == Markup.PROTOCOL) { + val (buf, n) = read_chunk_bytes() + protocol_output(props, Bytes(buf, 0, n)) + } + else { + val body = read_chunk() + output(kind, props, body) + } + case _ => + read_chunk() + throw new Protocol_Error("bad header: " + header.toString) + } + } + catch { case _: EOF => } + } + while (c != -1) + } + catch { + case e: IOException => system_output("Cannot read message:\n" + e.getMessage) + case e: Protocol_Error => system_output("Malformed message:\n" + e.getMessage) + } + stream.close - def dialog_result(serial: Long, result: String): Unit + system_output(name + " terminated") + } + } + + + + /** protocol commands **/ + + def protocol_command_bytes(name: String, args: Bytes*): Unit = + command_input match { + case Some(thread) => thread.send(Bytes(name) :: args.toList) + case None => error("Uninitialized command input thread") + } + + def protocol_command(name: String, args: String*) + { + receiver(new Prover.Input(name, args.toList)) + protocol_command_bytes(name, args.map(Bytes(_)): _*) + } } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/resources.ML --- a/src/Pure/PIDE/resources.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/resources.ML Wed Aug 27 15:52:58 2014 +0200 @@ -132,7 +132,7 @@ fun excursion master_dir last_timing init elements = let fun prepare_span span = - Thy_Syntax.span_content span + Command_Span.content span |> Command.read init master_dir [] |> (fn tr => Toplevel.put_timing (last_timing tr) tr); @@ -157,8 +157,8 @@ val _ = Thy_Header.define_keywords header; val lexs = Keyword.get_lexicons (); - val toks = Thy_Syntax.parse_tokens lexs text_pos text; - val spans = Thy_Syntax.parse_spans toks; + val toks = Outer_Syntax.scan lexs text_pos text; + val spans = Outer_Syntax.parse_spans toks; val elements = Thy_Syntax.parse_elements spans; fun init () = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/resources.scala --- a/src/Pure/PIDE/resources.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/resources.scala Wed Aug 27 15:52:58 2014 +0200 @@ -56,8 +56,8 @@ def loaded_files(syntax: Prover.Syntax, text: String): List[String] = if (syntax.load_commands_in(text)) { - val spans = Thy_Syntax.parse_spans(syntax.scan(text)) - spans.iterator.map(Thy_Syntax.span_files(syntax, _)).flatten.toList + val spans = syntax.parse_spans(text) + spans.iterator.map(Command_Span.span_files(syntax, _)).flatten.toList } else Nil @@ -126,6 +126,6 @@ /* prover process */ def start_prover(receiver: Prover.Message => Unit, name: String, args: List[String]): Prover = - new Isabelle_Process(receiver, args) with Protocol + Isabelle_Process(receiver, args) } diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/session.scala --- a/src/Pure/PIDE/session.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/session.scala Wed Aug 27 15:52:58 2014 +0200 @@ -1,6 +1,6 @@ /* Title: Pure/PIDE/session.scala Author: Makarius - Options: :folding=explicit:collapseFolds=1: + Options: :folding=explicit: PIDE editor session, potentially with running prover process. */ diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/text.scala --- a/src/Pure/PIDE/text.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/text.scala Wed Aug 27 15:52:58 2014 +0200 @@ -40,7 +40,7 @@ if (start > stop) error("Bad range: [" + start.toString + ":" + stop.toString + "]") - override def toString = "[" + start.toString + ":" + stop.toString + "]" + override def toString: String = "[" + start.toString + ":" + stop.toString + "]" def length: Int = stop - start @@ -116,7 +116,7 @@ case other: Perspective => ranges == other.ranges case _ => false } - override def toString = ranges.toString + override def toString: String = ranges.toString } @@ -141,7 +141,7 @@ final class Edit private(val is_insert: Boolean, val start: Offset, val text: String) { - override def toString = + override def toString: String = (if (is_insert) "Insert(" else "Remove(") + (start, text).toString + ")" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/PIDE/xml.scala --- a/src/Pure/PIDE/xml.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/PIDE/xml.scala Wed Aug 27 15:52:58 2014 +0200 @@ -21,7 +21,7 @@ type Attributes = Properties.T - sealed abstract class Tree { override def toString = string_of_tree(this) } + sealed abstract class Tree { override def toString: String = string_of_tree(this) } case class Elem(markup: Markup, body: List[Tree]) extends Tree { def name: String = markup.name @@ -150,12 +150,17 @@ private def trim_bytes(s: String): String = new String(s.toCharArray) private def cache_string(x: String): String = - lookup(x) match { - case Some(y) => y - case None => - val z = trim_bytes(x) - if (z.length > max_string) z else store(z) - } + if (x == "true") "true" + else if (x == "false") "false" + else if (x == "0.0") "0.0" + else if (Library.is_small_int(x)) Library.signed_string_of_int(Integer.parseInt(x)) + else + lookup(x) match { + case Some(y) => y + case None => + val z = trim_bytes(x) + if (z.length > max_string) z else store(z) + } private def cache_props(x: Properties.T): Properties.T = if (x.isEmpty) x else @@ -214,9 +219,9 @@ /* atomic values */ - def long_atom(i: Long): String = i.toString + def long_atom(i: Long): String = Library.signed_string_of_long(i) - def int_atom(i: Int): String = i.toString + def int_atom(i: Int): String = Library.signed_string_of_int(i) def bool_atom(b: Boolean): String = if (b) "1" else "0" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Pure.thy --- a/src/Pure/Pure.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Pure.thy Wed Aug 27 15:52:58 2014 +0200 @@ -99,6 +99,7 @@ and "realizability" :: thy_decl == "" and "extract_type" "extract" :: thy_decl and "find_theorems" "find_consts" :: diag + and "named_theorems" :: thy_decl and "ProofGeneral.process_pgip" "ProofGeneral.pr" "ProofGeneral.undo" "ProofGeneral.restart" "ProofGeneral.kill_proof" "ProofGeneral.inform_file_processed" "ProofGeneral.inform_file_retracted" :: control @@ -111,10 +112,12 @@ ML_file "Isar/calculation.ML" ML_file "Tools/rail.ML" ML_file "Tools/rule_insts.ML"; +ML_file "Tools/thm_deps.ML"; ML_file "Tools/find_theorems.ML" ML_file "Tools/find_consts.ML" ML_file "Tools/proof_general_pure.ML" ML_file "Tools/simplifier_trace.ML" +ML_file "Tools/named_theorems.ML" section {* Basic attributes *} diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ROOT --- a/src/Pure/ROOT Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ROOT Wed Aug 27 15:52:58 2014 +0200 @@ -160,6 +160,7 @@ "ML/ml_syntax.ML" "PIDE/active.ML" "PIDE/command.ML" + "PIDE/command_span.ML" "PIDE/document.ML" "PIDE/document_id.ML" "PIDE/execution.ML" @@ -201,7 +202,6 @@ "Thy/latex.ML" "Thy/present.ML" "Thy/term_style.ML" - "Thy/thm_deps.ML" "Thy/thy_header.ML" "Thy/thy_info.ML" "Thy/thy_output.ML" @@ -233,6 +233,7 @@ "morphism.ML" "name.ML" "net.ML" + "par_tactical.ML" "pattern.ML" "primitive_defs.ML" "proofterm.ML" diff -r 1b6035697c49 -r be9815d02b10 src/Pure/ROOT.ML --- a/src/Pure/ROOT.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/ROOT.ML Wed Aug 27 15:52:58 2014 +0200 @@ -234,8 +234,10 @@ use "Isar/parse.ML"; use "Isar/args.ML"; -(*theory sources*) +(*theory specifications*) +use "Isar/local_theory.ML"; use "Thy/thy_header.ML"; +use "PIDE/command_span.ML"; use "Thy/thy_syntax.ML"; use "Thy/html.ML"; use "Thy/latex.ML"; @@ -253,6 +255,7 @@ (** bootstrap phase 2: towards Pure.thy and final ML toplevel setup *) (*basic proof engine*) +use "par_tactical.ML"; use "Isar/proof_display.ML"; use "Isar/attrib.ML"; use "Isar/context_rules.ML"; @@ -263,7 +266,6 @@ (*local theories and targets*) use "Isar/locale.ML"; -use "Isar/local_theory.ML"; use "Isar/generic_target.ML"; use "Isar/overloading.ML"; use "axclass.ML"; @@ -309,7 +311,6 @@ use "PIDE/document.ML"; (*theory and proof operations*) -use "Thy/thm_deps.ML"; use "Isar/isar_cmd.ML"; use "subgoal.ML"; @@ -342,7 +343,7 @@ toplevel_pp ["Task_Queue", "task"] "Pretty.str o Task_Queue.str_of_task"; toplevel_pp ["Task_Queue", "group"] "Pretty.str o Task_Queue.str_of_group"; toplevel_pp ["Position", "T"] "Pretty.position"; -toplevel_pp ["Binding", "binding"] "Pretty.str o Binding.print"; +toplevel_pp ["Binding", "binding"] "Binding.pp"; toplevel_pp ["Thm", "thm"] "Proof_Display.pp_thm"; toplevel_pp ["Thm", "cterm"] "Proof_Display.pp_cterm"; toplevel_pp ["Thm", "ctyp"] "Proof_Display.pp_ctyp"; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Syntax/syntax.ML --- a/src/Pure/Syntax/syntax.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Syntax/syntax.ML Wed Aug 27 15:52:58 2014 +0200 @@ -185,10 +185,10 @@ let fun parse_tree tree = let - val {delimited, text, pos} = token_source tree; - val syms = Symbol_Pos.explode (text, pos); - val _ = Context_Position.report ctxt pos (markup delimited); - in parse (syms, pos) end; + val source = token_source tree; + val syms = Symbol_Pos.source_explode source; + val _ = Context_Position.report ctxt (#pos source) (markup (#delimited source)); + in parse (syms, #pos source) end; in (case YXML.parse_body str handle Fail msg => error msg of body as [tree as XML.Elem ((name, _), _)] => diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Syntax/syntax_phases.ML --- a/src/Pure/Syntax/syntax_phases.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Syntax/syntax_phases.ML Wed Aug 27 15:52:58 2014 +0200 @@ -461,11 +461,11 @@ else decode_appl ps asts | decode ps (Ast.Appl asts) = decode_appl ps asts; - val {text, pos, ...} = Syntax.read_token str; - val syms = Symbol_Pos.explode (text, pos); + val source = Syntax.read_token str; + val syms = Symbol_Pos.source_explode source; val ast = - parse_asts ctxt true root (syms, pos) - |> uncurry (report_result ctxt pos) + parse_asts ctxt true root (syms, #pos source) + |> uncurry (report_result ctxt (#pos source)) |> decode []; val _ = Context_Position.reports_text ctxt (! reports); in ast end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/System/isabelle_font.scala --- a/src/Pure/System/isabelle_font.scala Wed Aug 27 11:33:00 2014 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -/* Title: Pure/System/isabelle_font.scala - Author: Makarius - -Isabelle font support. -*/ - -package isabelle - - -import java.awt.{GraphicsEnvironment, Font} -import java.io.{FileInputStream, BufferedInputStream} -import javafx.scene.text.{Font => JFX_Font} - - -object Isabelle_Font -{ - def apply(family: String = "IsabelleText", size: Int = 1, bold: Boolean = false): Font = - new Font(family, if (bold) Font.BOLD else Font.PLAIN, size) - - def install_fonts() - { - val ge = GraphicsEnvironment.getLocalGraphicsEnvironment() - for (font <- Path.split(Isabelle_System.getenv_strict("ISABELLE_FONTS"))) - ge.registerFont(Font.createFont(Font.TRUETYPE_FONT, font.file)) - } - - def install_fonts_jfx() - { - for (font <- Path.split(Isabelle_System.getenv_strict("ISABELLE_FONTS"))) { - val stream = new BufferedInputStream(new FileInputStream(font.file)) - try { JFX_Font.loadFont(stream, 1.0) } - finally { stream.close } - } - } -} - diff -r 1b6035697c49 -r be9815d02b10 src/Pure/System/isabelle_process.ML --- a/src/Pure/System/isabelle_process.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/System/isabelle_process.ML Wed Aug 27 15:52:58 2014 +0200 @@ -1,8 +1,7 @@ (* Title: Pure/System/isabelle_process.ML Author: Makarius -Isabelle process wrapper, based on private fifos for maximum -robustness and performance, or local socket for maximum portability. +Isabelle process wrapper. *) signature ISABELLE_PROCESS = @@ -108,8 +107,12 @@ fun standard_message props name body = if forall (fn s => s = "") body then () else - message name - (fold_rev Properties.put props (Position.properties_of (Position.thread_data ()))) body; + let + val props' = + (case (Properties.defined props Markup.idN, Position.get_id (Position.thread_data ())) of + (false, SOME id') => props @ [(Markup.idN, id')] + | _ => props); + in message name props' body end; in Output.status_fn := standard_message [] Markup.statusN; Output.report_fn := standard_message [] Markup.reportN; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/System/isabelle_process.scala --- a/src/Pure/System/isabelle_process.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/System/isabelle_process.scala Wed Aug 27 15:52:58 2014 +0200 @@ -1,318 +1,43 @@ /* Title: Pure/System/isabelle_process.scala Author: Makarius - Options: :folding=explicit:collapseFolds=1: -Isabelle process management -- always reactive due to multi-threaded I/O. +Isabelle process wrapper. */ package isabelle -import java.io.{InputStream, OutputStream, BufferedOutputStream, IOException} - - -class Isabelle_Process( - receiver: Prover.Message => Unit = Console.println(_), - prover_args: List[String] = Nil) +object Isabelle_Process { - /* text and tree data */ - - def encode(s: String): String = Symbol.encode(s) - def decode(s: String): String = Symbol.decode(s) - - val xml_cache = new XML.Cache() - - - /* output */ - - private def system_output(text: String) - { - receiver(new Prover.Output(XML.Elem(Markup(Markup.SYSTEM, Nil), List(XML.Text(text))))) - } - - private def protocol_output(props: Properties.T, bytes: Bytes) - { - receiver(new Prover.Protocol_Output(props, bytes)) - } - - private def output(kind: String, props: Properties.T, body: XML.Body) - { - if (kind == Markup.INIT) system_channel.accepted() - - val main = XML.Elem(Markup(kind, props), Protocol.clean_message(body)) - val reports = Protocol.message_reports(props, body) - for (msg <- main :: reports) receiver(new Prover.Output(xml_cache.elem(msg))) - } - - private def exit_message(rc: Int) - { - output(Markup.EXIT, Markup.Return_Code(rc), List(XML.Text("Return code: " + rc.toString))) - } - - - - /** process manager **/ - - def command_line(channel: System_Channel, args: List[String]): List[String] = - Isabelle_System.getenv_strict("ISABELLE_PROCESS") :: (channel.isabelle_args ::: args) - - private val system_channel = System_Channel() - - private val process = - try { - val cmdline = command_line(system_channel, prover_args) - new Isabelle_System.Managed_Process(null, null, false, cmdline: _*) - } - catch { case e: IOException => system_channel.accepted(); throw(e) } - - private val (_, process_result) = - Simple_Thread.future("process_result") { process.join } - - private def terminate_process() + def apply( + receiver: Prover.Message => Unit = Console.println(_), + prover_args: List[String] = Nil): Isabelle_Process = { - try { process.terminate } - catch { case e: IOException => system_output("Failed to terminate Isabelle: " + e.getMessage) } - } - - private val process_manager = Simple_Thread.fork("process_manager") - { - val (startup_failed, startup_errors) = - { - var finished: Option[Boolean] = None - val result = new StringBuilder(100) - while (finished.isEmpty && (process.stderr.ready || !process_result.is_finished)) { - while (finished.isEmpty && process.stderr.ready) { - try { - val c = process.stderr.read - if (c == 2) finished = Some(true) - else result += c.toChar - } - catch { case _: IOException => finished = Some(false) } - } - Thread.sleep(10) + val system_channel = System_Channel() + val system_process = + try { + val cmdline = + Isabelle_System.getenv_strict("ISABELLE_PROCESS") :: + (system_channel.prover_args ::: prover_args) + val process = + new Isabelle_System.Managed_Process(null, null, false, cmdline: _*) with + Prover.System_Process + process.stdin.close + process } - (finished.isEmpty || !finished.get, result.toString.trim) - } - if (startup_errors != "") system_output(startup_errors) + catch { case exn @ ERROR(_) => system_channel.accepted(); throw(exn) } - process.stdin.close - if (startup_failed) { - terminate_process() - process_result.join - exit_message(127) - } - else { - val (command_stream, message_stream) = system_channel.rendezvous() - - command_input_init(command_stream) - val stdout = physical_output(false) - val stderr = physical_output(true) - val message = message_output(message_stream) + new Isabelle_Process(receiver, system_channel, system_process) + } +} - val rc = process_result.join - system_output("process terminated") - command_input_close() - for (thread <- List(stdout, stderr, message)) thread.join - system_output("process_manager terminated") - exit_message(rc) - } - system_channel.accepted() - } - - - /* management methods */ - - def join() { process_manager.join() } - - def interrupt() +class Isabelle_Process private( + receiver: Prover.Message => Unit, + system_channel: System_Channel, + system_process: Prover.System_Process) + extends Prover(receiver, system_channel, system_process) { - try { process.interrupt } - catch { case e: IOException => system_output("Failed to interrupt Isabelle: " + e.getMessage) } - } - - def terminate() - { - command_input_close() - system_output("Terminating Isabelle process") - terminate_process() + def encode(s: String): String = Symbol.encode(s) + def decode(s: String): String = Symbol.decode(s) } - - - /** process streams **/ - - /* command input */ - - private var command_input: Option[Consumer_Thread[List[Bytes]]] = None - - private def command_input_close(): Unit = command_input.foreach(_.shutdown) - - private def command_input_init(raw_stream: OutputStream) - { - val name = "command_input" - val stream = new BufferedOutputStream(raw_stream) - command_input = - Some( - Consumer_Thread.fork(name)( - consume = - { - case chunks => - try { - Bytes(chunks.map(_.length).mkString("", ",", "\n")).write(stream) - chunks.foreach(_.write(stream)) - stream.flush - true - } - catch { case e: IOException => system_output(name + ": " + e.getMessage); false } - }, - finish = { case () => stream.close; system_output(name + " terminated") } - ) - ) - } - - - /* physical output */ - - private def physical_output(err: Boolean): Thread = - { - val (name, reader, markup) = - if (err) ("standard_error", process.stderr, Markup.STDERR) - else ("standard_output", process.stdout, Markup.STDOUT) - - Simple_Thread.fork(name) { - try { - var result = new StringBuilder(100) - var finished = false - while (!finished) { - //{{{ - var c = -1 - var done = false - while (!done && (result.length == 0 || reader.ready)) { - c = reader.read - if (c >= 0) result.append(c.asInstanceOf[Char]) - else done = true - } - if (result.length > 0) { - output(markup, Nil, List(XML.Text(decode(result.toString)))) - result.length = 0 - } - else { - reader.close - finished = true - } - //}}} - } - } - catch { case e: IOException => system_output(name + ": " + e.getMessage) } - system_output(name + " terminated") - } - } - - - /* message output */ - - private def message_output(stream: InputStream): Thread = - { - class EOF extends Exception - class Protocol_Error(msg: String) extends Exception(msg) - - val name = "message_output" - Simple_Thread.fork(name) { - val default_buffer = new Array[Byte](65536) - var c = -1 - - def read_int(): Int = - //{{{ - { - var n = 0 - c = stream.read - if (c == -1) throw new EOF - while (48 <= c && c <= 57) { - n = 10 * n + (c - 48) - c = stream.read - } - if (c != 10) - throw new Protocol_Error("malformed header: expected integer followed by newline") - else n - } - //}}} - - def read_chunk_bytes(): (Array[Byte], Int) = - //{{{ - { - val n = read_int() - val buf = - if (n <= default_buffer.size) default_buffer - else new Array[Byte](n) - - var i = 0 - var m = 0 - do { - m = stream.read(buf, i, n - i) - if (m != -1) i += m - } - while (m != -1 && n > i) - - if (i != n) - throw new Protocol_Error("bad chunk (unexpected EOF after " + i + " of " + n + " bytes)") - - (buf, n) - } - //}}} - - def read_chunk(): XML.Body = - { - val (buf, n) = read_chunk_bytes() - YXML.parse_body_failsafe(UTF8.decode_chars(decode, buf, 0, n)) - } - - try { - do { - try { - val header = read_chunk() - header match { - case List(XML.Elem(Markup(name, props), Nil)) => - val kind = name.intern - if (kind == Markup.PROTOCOL) { - val (buf, n) = read_chunk_bytes() - protocol_output(props, Bytes(buf, 0, n)) - } - else { - val body = read_chunk() - output(kind, props, body) - } - case _ => - read_chunk() - throw new Protocol_Error("bad header: " + header.toString) - } - } - catch { case _: EOF => } - } - while (c != -1) - } - catch { - case e: IOException => system_output("Cannot read message:\n" + e.getMessage) - case e: Protocol_Error => system_output("Malformed message:\n" + e.getMessage) - } - stream.close - - system_output(name + " terminated") - } - } - - - - /** protocol commands **/ - - def protocol_command_bytes(name: String, args: Bytes*): Unit = - command_input match { - case Some(thread) => thread.send(Bytes(name) :: args.toList) - case None => error("Uninitialized command input thread") - } - - def protocol_command(name: String, args: String*) - { - receiver(new Prover.Input(name, args.toList)) - protocol_command_bytes(name, args.map(Bytes(_)): _*) - } -} diff -r 1b6035697c49 -r be9815d02b10 src/Pure/System/system_channel.scala --- a/src/Pure/System/system_channel.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/System/system_channel.scala Wed Aug 27 15:52:58 2014 +0200 @@ -22,7 +22,7 @@ abstract class System_Channel { def params: List[String] - def isabelle_args: List[String] + def prover_args: List[String] def rendezvous(): (OutputStream, InputStream) def accepted(): Unit } @@ -60,7 +60,7 @@ def params: List[String] = List(fifo1, fifo2) - val isabelle_args: List[String] = List ("-W", fifo1 + ":" + fifo2) + val prover_args: List[String] = List ("-W", fifo1 + ":" + fifo2) def rendezvous(): (OutputStream, InputStream) = { @@ -81,7 +81,7 @@ def params: List[String] = List("127.0.0.1", server.getLocalPort.toString) - def isabelle_args: List[String] = List("-T", "127.0.0.1:" + server.getLocalPort) + def prover_args: List[String] = List("-T", "127.0.0.1:" + server.getLocalPort) def rendezvous(): (OutputStream, InputStream) = { diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/present.ML --- a/src/Pure/Thy/present.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/present.ML Wed Aug 27 15:52:58 2014 +0200 @@ -330,9 +330,7 @@ val _ = Isabelle_System.isabelle_tool "latex" ("-o sty " ^ File.shell_path (Path.append doc_dir (Path.basic "root.tex"))); - val _ = - if null doc_files then Isabelle_System.copy_dir document_path doc_dir - else List.app (fn file => Isabelle_System.copy_file_base file doc_dir) doc_files; + val _ = List.app (fn file => Isabelle_System.copy_file_base file doc_dir) doc_files; val _ = (case opt_graphs of NONE => () @@ -360,12 +358,6 @@ NONE => [] | SOME path => map (document_job path false) documents); - val _ = - if not (null jobs) andalso null doc_files then - Output.physical_stderr ("### Legacy feature! Document preparation for session " ^ quote name ^ - " without 'document_files'\n") - else (); - val _ = jobs |> Par_List.map (fn job => job ()) |> List.app (op |>); in browser_info := empty_browser_info; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/term_style.ML --- a/src/Pure/Thy/term_style.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/term_style.ML Wed Aug 27 15:52:58 2014 +0200 @@ -35,8 +35,8 @@ fun parse_single ctxt = Parse.position Parse.xname -- Parse.args >> (fn (name, args) => let - val (src, parse) = Args.check_src ctxt (get_data ctxt) (Args.src name args); - val (f, _) = Args.syntax (Scan.lift parse) src ctxt; + val (src, parse) = Token.check_src ctxt (get_data ctxt) (Token.src name args); + val (f, _) = Token.syntax (Scan.lift parse) src ctxt; in f ctxt end); val parse = Args.context :|-- (fn ctxt => Scan.lift diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thm_deps.ML --- a/src/Pure/Thy/thm_deps.ML Wed Aug 27 11:33:00 2014 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -(* Title: Pure/Thy/thm_deps.ML - Author: Stefan Berghofer, TU Muenchen - -Visualize dependencies of theorems. -*) - -signature THM_DEPS = -sig - val thm_deps: theory -> thm list -> unit - val unused_thms: theory list * theory list -> (string * thm) list -end; - -structure Thm_Deps: THM_DEPS = -struct - -(* thm_deps *) - -fun thm_deps thy thms = - let - fun add_dep ("", _, _) = I - | add_dep (name, _, PBody {thms = thms', ...}) = - let - val prefix = #1 (split_last (Long_Name.explode name)); - val session = - (case prefix of - a :: _ => - (case try (Context.get_theory thy) a of - SOME thy => - (case Present.session_name thy of - "" => [] - | session => [session]) - | NONE => []) - | _ => ["global"]); - val parents = filter_out (fn s => s = "") (map (#1 o #2) thms'); - val entry = - {name = Long_Name.base_name name, - ID = name, - dir = space_implode "/" (session @ prefix), - unfold = false, - path = "", - parents = parents, - content = []}; - in cons entry end; - val deps = Proofterm.fold_body_thms add_dep (Thm.proof_bodies_of thms) []; - in Graph_Display.display_graph (sort_wrt #ID deps) end; - - -(* unused_thms *) - -fun unused_thms (base_thys, thys) = - let - fun add_fact space (name, ths) = - if exists (fn thy => Global_Theory.defined_fact thy name) base_thys then I - else - let val {concealed, group, ...} = Name_Space.the_entry space name in - fold_rev (fn th => - (case Thm.derivation_name th of - "" => I - | a => cons (a, (th, concealed, group)))) ths - end; - fun add_facts facts = Facts.fold_static (add_fact (Facts.space_of facts)) facts; - - val new_thms = - fold (add_facts o Global_Theory.facts_of) thys [] - |> sort_distinct (string_ord o pairself #1); - - val used = - Proofterm.fold_body_thms - (fn (a, _, _) => a <> "" ? Symtab.update (a, ())) - (map Proofterm.strip_thm (Thm.proof_bodies_of (map (#1 o #2) new_thms))) - Symtab.empty; - - fun is_unused a = not (Symtab.defined used a); - - (* groups containing at least one used theorem *) - val used_groups = fold (fn (a, (_, _, group)) => - if is_unused a then I - else - (case group of - NONE => I - | SOME grp => Inttab.update (grp, ()))) new_thms Inttab.empty; - - val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, seen_groups) => - if not concealed andalso - (* FIXME replace by robust treatment of thm groups *) - member (op =) [Thm.theoremK, Thm.lemmaK, Thm.corollaryK] (Thm.legacy_get_kind th) andalso - is_unused a - then - (case group of - NONE => ((a, th) :: thms, seen_groups) - | SOME grp => - if Inttab.defined used_groups grp orelse - Inttab.defined seen_groups grp then q - else ((a, th) :: thms, Inttab.update (grp, ()) seen_groups)) - else q) new_thms ([], Inttab.empty); - in rev thms' end; - -end; - diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thy_info.ML --- a/src/Pure/Thy/thy_info.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/thy_info.ML Wed Aug 27 15:52:58 2014 +0200 @@ -380,7 +380,7 @@ fun script_thy pos txt = let - val trs = Outer_Syntax.parse pos txt; + val trs = Outer_Syntax.parse (Outer_Syntax.get_syntax ()) pos txt; val end_pos = if null trs then pos else Toplevel.pos_of (List.last trs); val end_state = fold (Toplevel.command_exception true) trs Toplevel.toplevel; in Toplevel.end_theory end_pos end_state end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thy_output.ML --- a/src/Pure/Thy/thy_output.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/thy_output.ML Wed Aug 27 15:52:58 2014 +0200 @@ -18,7 +18,7 @@ val check_option: Proof.context -> xstring * Position.T -> string val print_antiquotations: Proof.context -> unit val antiquotation: binding -> 'a context_parser -> - ({source: Args.src, state: Toplevel.state, context: Proof.context} -> 'a -> string) -> + ({source: Token.src, state: Toplevel.state, context: Proof.context} -> 'a -> string) -> theory -> theory val boolean: string -> bool val integer: string -> int @@ -30,9 +30,9 @@ val pretty_text: Proof.context -> string -> Pretty.T val pretty_term: Proof.context -> term -> Pretty.T val pretty_thm: Proof.context -> thm -> Pretty.T - val str_of_source: Args.src -> string + val str_of_source: Token.src -> string val maybe_pretty_source: (Proof.context -> 'a -> Pretty.T) -> Proof.context -> - Args.src -> 'a list -> Pretty.T list + Token.src -> 'a list -> Pretty.T list val output: Proof.context -> Pretty.T list -> string val verb_text: string -> string end; @@ -67,7 +67,7 @@ structure Antiquotations = Theory_Data ( type T = - (Args.src -> Toplevel.state -> Proof.context -> string) Name_Space.table * + (Token.src -> Toplevel.state -> Proof.context -> string) Name_Space.table * (string -> Proof.context -> Proof.context) Name_Space.table; val empty : T = (Name_Space.empty_table Markup.document_antiquotationN, @@ -91,7 +91,7 @@ fun check_option ctxt = #1 o Name_Space.check (Context.Proof ctxt) (#2 (get_antiquotations ctxt)); fun command src state ctxt = - let val (src', f) = Args.check_src ctxt (#1 (get_antiquotations ctxt)) src + let val (src', f) = Token.check_src ctxt (#1 (get_antiquotations ctxt)) src in f src' state ctxt end; fun option ((xname, pos), s) ctxt = @@ -114,7 +114,7 @@ fun antiquotation name scan body = add_command name (fn src => fn state => fn ctxt => - let val (x, ctxt') = Args.syntax scan src ctxt + let val (x, ctxt') = Token.syntax scan src ctxt in body {source = src, state = state, context = ctxt'} x end); @@ -151,7 +151,7 @@ val antiq = Parse.!!! (Parse.position Parse.liberal_name -- properties -- Parse.args --| Scan.ahead Parse.eof) - >> (fn ((name, props), args) => (props, Args.src name args)); + >> (fn ((name, props), args) => (props, Token.src name args)); end; @@ -534,7 +534,7 @@ (* default output *) -val str_of_source = space_implode " " o Args.unparse_src; +val str_of_source = space_implode " " o Token.unparse_src; fun maybe_pretty_source pretty ctxt src xs = map (pretty ctxt) xs (*always pretty in order to exhibit errors!*) @@ -624,7 +624,7 @@ Scan.lift (Parse.position (Args.$$$ "by") -- Method.parse -- Scan.option Method.parse)) (fn {source, context = ctxt, ...} => fn ((prop_token, prop), (((_, by_pos), m1), m2)) => let - val prop_src = Args.src (Args.name_of_src source) [prop_token]; + val prop_src = Token.src (Token.name_of_src source) [prop_token]; val reports = (by_pos, Markup.keyword1) :: maps Method.reports_of (m1 :: the_list m2); val _ = Context_Position.reports ctxt reports; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thy_structure.scala --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/Thy/thy_structure.scala Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,71 @@ +/* Title: Pure/Thy/thy_structure.scala + Author: Makarius + +Nested structure of theory source. +*/ + +package isabelle + + +import scala.collection.mutable +import scala.annotation.tailrec + + +object Thy_Structure +{ + sealed abstract class Entry { def length: Int } + case class Block(val name: String, val body: List[Entry]) extends Entry + { + val length: Int = (0 /: body)(_ + _.length) + } + case class Atom(val command: Command) extends Entry + { + def length: Int = command.length + } + + def parse(syntax: Outer_Syntax, node_name: Document.Node.Name, text: CharSequence): Entry = + { + /* stack operations */ + + def buffer(): mutable.ListBuffer[Entry] = new mutable.ListBuffer[Entry] + var stack: List[(Int, String, mutable.ListBuffer[Entry])] = + List((0, node_name.toString, buffer())) + + @tailrec def close(level: Int => Boolean) + { + stack match { + case (lev, name, body) :: (_, _, body2) :: rest if level(lev) => + body2 += Block(name, body.toList) + stack = stack.tail + close(level) + case _ => + } + } + + def result(): Entry = + { + close(_ => true) + val (_, name, body) = stack.head + Block(name, body.toList) + } + + def add(command: Command) + { + syntax.heading_level(command) match { + case Some(i) => + close(_ > i) + stack = (i + 1, command.source, buffer()) :: stack + case None => + } + stack.head._3 += Atom(command) + } + + + /* result structure */ + + val spans = syntax.parse_spans(text) + spans.foreach(span => add(Command(Document_ID.none, node_name, Nil, span))) + result() + } +} + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thy_syntax.ML --- a/src/Pure/Thy/thy_syntax.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/thy_syntax.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,39 +6,21 @@ signature THY_SYNTAX = sig - val parse_tokens: Scan.lexicon * Scan.lexicon -> Position.T -> string -> Token.T list val reports_of_tokens: Token.T list -> bool * Position.report_text list val present_token: Token.T -> Output.output - datatype span_kind = Command of string * Position.T | Ignored | Malformed - datatype span = Span of span_kind * Token.T list - val span_kind: span -> span_kind - val span_content: span -> Token.T list - val present_span: span -> Output.output - val parse_spans: Token.T list -> span list - val resolve_files: (string -> Path.T * Position.T -> Token.file Exn.result list) -> span -> span + val present_span: Command_Span.span -> Output.output datatype 'a element = Element of 'a * ('a element list * 'a) option val atom: 'a -> 'a element val map_element: ('a -> 'b) -> 'a element -> 'b element val flat_element: 'a element -> 'a list val last_element: 'a element -> 'a - val parse_elements: span list -> span element list + val parse_elements: Command_Span.span list -> Command_Span.span element list end; structure Thy_Syntax: THY_SYNTAX = struct -(** tokens **) - -(* parse *) - -fun parse_tokens lexs pos = - Source.of_string #> - Symbol.source #> - Token.source {do_recover = SOME false} (K lexs) pos #> - Source.exhaust; - - -(* present *) +(** presentation **) local @@ -60,97 +42,12 @@ let val results = map reports_of_token toks in (exists fst results, maps snd results) end; +end; + fun present_token tok = Markup.enclose (Token.markup tok) (Output.output (Token.unparse tok)); -end; - - - -(** spans **) - -(* type span *) - -datatype span_kind = Command of string * Position.T | Ignored | Malformed; -datatype span = Span of span_kind * Token.T list; - -fun span_kind (Span (k, _)) = k; -fun span_content (Span (_, toks)) = toks; - -val present_span = implode o map present_token o span_content; - - -(* parse *) - -local - -fun make_span toks = - if not (null toks) andalso Token.is_command (hd toks) then - Span (Command (Token.content_of (hd toks), Token.pos_of (hd toks)), toks) - else if forall Token.is_improper toks then Span (Ignored, toks) - else Span (Malformed, toks); - -fun flush (result, span, improper) = - result - |> not (null span) ? cons (rev span) - |> not (null improper) ? cons (rev improper); - -fun parse tok (result, span, improper) = - if Token.is_command tok then (flush (result, span, improper), [tok], []) - else if Token.is_improper tok then (result, span, tok :: improper) - else (result, tok :: (improper @ span), []); - -in - -fun parse_spans toks = - fold parse toks ([], [], []) - |> flush |> rev |> map make_span; - -end; - - -(* inlined files *) - -local - -fun clean ((i1, t1) :: (i2, t2) :: toks) = - if Token.keyword_with (fn s => s = "%" orelse s = "--") t1 then clean toks - else (i1, t1) :: clean ((i2, t2) :: toks) - | clean toks = toks; - -fun clean_tokens toks = - ((0 upto length toks - 1) ~~ toks) - |> filter (fn (_, tok) => Token.is_proper tok) - |> clean; - -fun find_file ((_, tok) :: toks) = - if Token.is_command tok then - toks |> get_first (fn (i, tok) => - if Token.is_name tok then - SOME (i, (Path.explode (Token.content_of tok), Token.pos_of tok)) - handle ERROR msg => error (msg ^ Position.here (Token.pos_of tok)) - else NONE) - else NONE - | find_file [] = NONE; - -in - -fun resolve_files read_files span = - (case span of - Span (Command (cmd, pos), toks) => - if Keyword.is_theory_load cmd then - (case find_file (clean_tokens toks) of - NONE => error ("Bad file argument of command " ^ quote cmd ^ Position.here pos) - | SOME (i, path) => - let - val toks' = toks |> map_index (fn (j, tok) => - if i = j then Token.put_files (read_files cmd path) tok - else tok); - in Span (Command (cmd, pos), toks') end) - else span - | _ => span); - -end; +val present_span = implode o map present_token o Command_Span.content; @@ -174,9 +71,9 @@ (* scanning spans *) -val eof = Span (Command ("", Position.none), []); +val eof = Command_Span.Span (Command_Span.Command_Span ("", Position.none), []); -fun is_eof (Span (Command ("", _), _)) = true +fun is_eof (Command_Span.Span (Command_Span.Command_Span ("", _), _)) = true | is_eof _ = false; val not_eof = not o is_eof; @@ -189,10 +86,13 @@ local fun command_with pred = - Scan.one (fn (Span (Command (name, _), _)) => pred name | _ => false); + Scan.one + (fn (Command_Span.Span (Command_Span.Command_Span (name, _), _)) => pred name | _ => false); val proof_atom = - Scan.one (fn (Span (Command (name, _), _)) => Keyword.is_proof_body name | _ => true) >> atom; + Scan.one + (fn (Command_Span.Span (Command_Span.Command_Span (name, _), _)) => Keyword.is_proof_body name + | _ => true) >> atom; fun proof_element x = (command_with Keyword.is_proof_goal -- proof_rest >> element || proof_atom) x and proof_rest x = (Scan.repeat proof_element -- command_with Keyword.is_qed) x; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Thy/thy_syntax.scala --- a/src/Pure/Thy/thy_syntax.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Thy/thy_syntax.scala Wed Aug 27 15:52:58 2014 +0200 @@ -13,93 +13,6 @@ object Thy_Syntax { - /** nested structure **/ - - object Structure - { - sealed abstract class Entry { def length: Int } - case class Block(val name: String, val body: List[Entry]) extends Entry - { - val length: Int = (0 /: body)(_ + _.length) - } - case class Atom(val command: Command) extends Entry - { - def length: Int = command.length - } - - def parse(syntax: Outer_Syntax, node_name: Document.Node.Name, text: CharSequence): Entry = - { - /* stack operations */ - - def buffer(): mutable.ListBuffer[Entry] = new mutable.ListBuffer[Entry] - var stack: List[(Int, String, mutable.ListBuffer[Entry])] = - List((0, node_name.toString, buffer())) - - @tailrec def close(level: Int => Boolean) - { - stack match { - case (lev, name, body) :: (_, _, body2) :: rest if level(lev) => - body2 += Block(name, body.toList) - stack = stack.tail - close(level) - case _ => - } - } - - def result(): Entry = - { - close(_ => true) - val (_, name, body) = stack.head - Block(name, body.toList) - } - - def add(command: Command) - { - syntax.heading_level(command) match { - case Some(i) => - close(_ > i) - stack = (i + 1, command.source, buffer()) :: stack - case None => - } - stack.head._3 += Atom(command) - } - - - /* result structure */ - - val spans = parse_spans(syntax.scan(text)) - spans.foreach(span => add(Command(Document_ID.none, node_name, Nil, span))) - result() - } - } - - - - /** parse spans **/ - - def parse_spans(toks: List[Token]): List[List[Token]] = - { - val result = new mutable.ListBuffer[List[Token]] - val span = new mutable.ListBuffer[Token] - val improper = new mutable.ListBuffer[Token] - - def flush() - { - if (!span.isEmpty) { result += span.toList; span.clear } - if (!improper.isEmpty) { result += improper.toList; improper.clear } - } - for (tok <- toks) { - if (tok.is_command) { flush(); span += tok } - else if (tok.is_improper) improper += tok - else { span ++= improper; improper.clear; span += tok } - } - flush() - - result.toList - } - - - /** perspective **/ def command_perspective( @@ -231,58 +144,12 @@ } - /* inlined files */ - - private def find_file(tokens: List[Token]): Option[String] = - { - def clean(toks: List[Token]): List[Token] = - toks match { - case t :: _ :: ts if t.is_keyword && (t.source == "%" || t.source == "--") => clean(ts) - case t :: ts => t :: clean(ts) - case Nil => Nil - } - clean(tokens.filter(_.is_proper)) match { - case tok :: toks if tok.is_command => toks.find(_.is_name).map(_.content) - case _ => None - } - } - - def span_files(syntax: Prover.Syntax, span: List[Token]): List[String] = - syntax.load(span) match { - case Some(exts) => - find_file(span) match { - case Some(file) => - if (exts.isEmpty) List(file) - else exts.map(ext => file + "." + ext) - case None => Nil - } - case None => Nil - } - - def resolve_files( - resources: Resources, - syntax: Prover.Syntax, - node_name: Document.Node.Name, - span: List[Token], - get_blob: Document.Node.Name => Option[Document.Blob]) - : List[Command.Blob] = - { - span_files(syntax, span).map(file_name => - Exn.capture { - val name = - Document.Node.Name(resources.append(node_name.master_dir, Path.explode(file_name))) - val blob = get_blob(name).map(blob => ((blob.bytes.sha1_digest, blob.chunk))) - (name, blob) - }) - } - - /* reparse range of command spans */ @tailrec private def chop_common( cmds: List[Command], - blobs_spans: List[(List[Command.Blob], List[Token])]) - : (List[Command], List[(List[Command.Blob], List[Token])]) = + blobs_spans: List[(List[Command.Blob], Command_Span.Span)]) + : (List[Command], List[(List[Command.Blob], Command_Span.Span)]) = { (cmds, blobs_spans) match { case (cmd :: cmds, (blobs, span) :: rest) if cmd.blobs == blobs && cmd.span == span => @@ -301,8 +168,8 @@ { val cmds0 = commands.iterator(first, last).toList val blobs_spans0 = - parse_spans(syntax.scan(cmds0.iterator.map(_.source).mkString)). - map(span => (resolve_files(resources, syntax, name, span, get_blob), span)) + syntax.parse_spans(cmds0.iterator.map(_.source).mkString). + map(span => (Command_Span.resolve_files(resources, syntax, name, span, get_blob), span)) val (cmds1, blobs_spans1) = chop_common(cmds0, blobs_spans0) @@ -337,8 +204,8 @@ val visible = perspective.commands.toSet def next_invisible_command(cmds: Linear_Set[Command], from: Command): Command = - cmds.iterator(from).dropWhile(cmd => !cmd.is_command || visible(cmd)) - .find(_.is_command) getOrElse cmds.last + cmds.iterator(from).dropWhile(cmd => !cmd.is_proper || visible(cmd)) + .find(_.is_proper) getOrElse cmds.last @tailrec def recover(cmds: Linear_Set[Command]): Linear_Set[Command] = cmds.find(_.is_unparsed) match { diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/build.scala --- a/src/Pure/Tools/build.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Tools/build.scala Wed Aug 27 15:52:58 2014 +0200 @@ -1,6 +1,6 @@ /* Title: Pure/Tools/build.scala Author: Makarius - Options: :folding=explicit:collapseFolds=1: + Options: :folding=explicit: Build and manage Isabelle sessions. */ diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/find_consts.ML --- a/src/Pure/Tools/find_consts.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Tools/find_consts.ML Wed Aug 27 15:52:58 2014 +0200 @@ -143,7 +143,7 @@ in fun read_query pos str = - Outer_Syntax.scan pos str + Outer_Syntax.scan (Keyword.get_lexicons ()) pos str |> filter Token.is_proper |> Scan.error (Scan.finite Token.stopper (Parse.!!! (query --| Scan.ahead Parse.eof))) |> #1; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/find_theorems.ML --- a/src/Pure/Tools/find_theorems.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Tools/find_theorems.ML Wed Aug 27 15:52:58 2014 +0200 @@ -528,7 +528,7 @@ in fun read_query pos str = - Outer_Syntax.scan pos str + Outer_Syntax.scan (Keyword.get_lexicons ()) pos str |> filter Token.is_proper |> Scan.error (Scan.finite Token.stopper (Parse.!!! (query --| Scan.ahead Parse.eof))) |> #1; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/named_theorems.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/Tools/named_theorems.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,91 @@ +(* Title: Pure/Tools/named_theorems.ML + Author: Makarius + +Named collections of theorems in canonical order. +*) + +signature NAMED_THEOREMS = +sig + val member: Proof.context -> string -> thm -> bool + val get: Proof.context -> string -> thm list + val add_thm: string -> thm -> Context.generic -> Context.generic + val del_thm: string -> thm -> Context.generic -> Context.generic + val add: string -> attribute + val del: string -> attribute + val declare: binding -> string -> local_theory -> string * local_theory +end; + +structure Named_Theorems: NAMED_THEOREMS = +struct + +(* context data *) + +structure Data = Generic_Data +( + type T = thm Item_Net.T Symtab.table; + val empty: T = Symtab.empty; + val extend = I; + val merge : T * T -> T = Symtab.join (K Item_Net.merge); +); + +fun new_entry name = + Data.map (fn data => + if Symtab.defined data name + then error ("Duplicate declaration of named theorems: " ^ quote name) + else Symtab.update (name, Thm.full_rules) data); + +fun the_entry context name = + (case Symtab.lookup (Data.get context) name of + NONE => error ("Undeclared named theorems " ^ quote name) + | SOME entry => entry); + +fun map_entry name f context = + (the_entry context name; Data.map (Symtab.map_entry name f) context); + + +(* maintain content *) + +fun member ctxt = Item_Net.member o the_entry (Context.Proof ctxt); + +fun content context = rev o Item_Net.content o the_entry context; +val get = content o Context.Proof; + +fun add_thm name = map_entry name o Item_Net.update; +fun del_thm name = map_entry name o Item_Net.remove; + +val add = Thm.declaration_attribute o add_thm; +val del = Thm.declaration_attribute o del_thm; + + +(* declaration *) + +fun declare binding descr lthy = + let + val name = Name_Space.full_name (Local_Theory.naming_of lthy) binding; + val description = + "declaration of " ^ (if descr = "" then Binding.name_of binding ^ " rules" else descr); + val lthy' = lthy + |> Local_Theory.background_theory (Context.theory_map (new_entry name)) + |> Local_Theory.map_contexts (K (Context.proof_map (new_entry name))) + |> Local_Theory.add_thms_dynamic (binding, fn context => content context name) + |> Attrib.local_setup binding (Attrib.add_del (add name) (del name)) description + in (name, lthy') end; + +val _ = + Outer_Syntax.local_theory @{command_spec "named_theorems"} + "declare named collection of theorems" + (Parse.binding -- Scan.optional Parse.text "" >> (fn (b, descr) => snd o declare b descr)); + + +(* ML antiquotation *) + +val _ = Theory.setup + (ML_Antiquotation.inline @{binding named_theorems} + (Args.context -- Scan.lift (Parse.position Args.name) >> (fn (ctxt, (xname, pos)) => + let + val thy = Proof_Context.theory_of ctxt; + val name = Global_Theory.check_fact thy (xname, pos); + val _ = get ctxt name handle ERROR msg => cat_error msg (Position.here pos); + in ML_Syntax.print_string name end))); + +end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/rule_insts.ML --- a/src/Pure/Tools/rule_insts.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/Tools/rule_insts.ML Wed Aug 27 15:52:58 2014 +0200 @@ -64,12 +64,6 @@ val t' = f t; in if t aconv t' then NONE else SOME (t, t') end; -val add_used = - (Thm.fold_terms o fold_types o fold_atyps) - (fn TFree (a, _) => insert (op =) a - | TVar ((a, _), _) => insert (op =) a - | _ => I); - in fun read_termTs ctxt ss Ts = @@ -131,8 +125,7 @@ let val ctxt' = ctxt |> Proof_Context.read_vars fixes |-> Proof_Context.add_fixes |> #2 - |> Variable.declare_thm thm - |> fold (fn a => Variable.declare_names (Logic.mk_type (TFree (a, dummyS)))) (add_used thm []); (* FIXME !? *) + |> Variable.declare_thm thm; val tvars = Thm.fold_terms Term.add_tvars thm []; val vars = Thm.fold_terms Term.add_vars thm []; val insts = read_insts ctxt' mixed_insts (tvars, vars); diff -r 1b6035697c49 -r be9815d02b10 src/Pure/Tools/thm_deps.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/Tools/thm_deps.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,124 @@ +(* Title: Pure/Tools/thm_deps.ML + Author: Stefan Berghofer, TU Muenchen + +Visualize dependencies of theorems. +*) + +signature THM_DEPS = +sig + val thm_deps: theory -> thm list -> unit + val unused_thms: theory list * theory list -> (string * thm) list +end; + +structure Thm_Deps: THM_DEPS = +struct + +(* thm_deps *) + +fun thm_deps thy thms = + let + fun add_dep ("", _, _) = I + | add_dep (name, _, PBody {thms = thms', ...}) = + let + val prefix = #1 (split_last (Long_Name.explode name)); + val session = + (case prefix of + a :: _ => + (case try (Context.get_theory thy) a of + SOME thy => + (case Present.session_name thy of + "" => [] + | session => [session]) + | NONE => []) + | _ => ["global"]); + val parents = filter_out (fn s => s = "") (map (#1 o #2) thms'); + val entry = + {name = Long_Name.base_name name, + ID = name, + dir = space_implode "/" (session @ prefix), + unfold = false, + path = "", + parents = parents, + content = []}; + in cons entry end; + val deps = Proofterm.fold_body_thms add_dep (Thm.proof_bodies_of thms) []; + in Graph_Display.display_graph (sort_wrt #ID deps) end; + +val _ = + Outer_Syntax.improper_command @{command_spec "thm_deps"} "visualize theorem dependencies" + (Parse.xthms1 >> (fn args => + Toplevel.unknown_theory o Toplevel.keep (fn state => + thm_deps (Toplevel.theory_of state) (Attrib.eval_thms (Toplevel.context_of state) args)))); + + +(* unused_thms *) + +fun unused_thms (base_thys, thys) = + let + fun add_fact space (name, ths) = + if exists (fn thy => Global_Theory.defined_fact thy name) base_thys then I + else + let val {concealed, group, ...} = Name_Space.the_entry space name in + fold_rev (fn th => + (case Thm.derivation_name th of + "" => I + | a => cons (a, (th, concealed, group)))) ths + end; + fun add_facts facts = Facts.fold_static (add_fact (Facts.space_of facts)) facts; + + val new_thms = + fold (add_facts o Global_Theory.facts_of) thys [] + |> sort_distinct (string_ord o pairself #1); + + val used = + Proofterm.fold_body_thms + (fn (a, _, _) => a <> "" ? Symtab.update (a, ())) + (map Proofterm.strip_thm (Thm.proof_bodies_of (map (#1 o #2) new_thms))) + Symtab.empty; + + fun is_unused a = not (Symtab.defined used a); + + (*groups containing at least one used theorem*) + val used_groups = fold (fn (a, (_, _, group)) => + if is_unused a then I + else + (case group of + NONE => I + | SOME grp => Inttab.update (grp, ()))) new_thms Inttab.empty; + + val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, seen_groups) => + if not concealed andalso + (* FIXME replace by robust treatment of thm groups *) + member (op =) [Thm.theoremK, Thm.lemmaK, Thm.corollaryK] (Thm.legacy_get_kind th) andalso + is_unused a + then + (case group of + NONE => ((a, th) :: thms, seen_groups) + | SOME grp => + if Inttab.defined used_groups grp orelse + Inttab.defined seen_groups grp then q + else ((a, th) :: thms, Inttab.update (grp, ()) seen_groups)) + else q) new_thms ([], Inttab.empty); + in rev thms' end; + +val _ = + Outer_Syntax.improper_command @{command_spec "unused_thms"} "find unused theorems" + (Scan.option ((Scan.repeat1 (Scan.unless Parse.minus Parse.name) --| Parse.minus) -- + Scan.option (Scan.repeat1 (Scan.unless Parse.minus Parse.name))) >> (fn opt_range => + Toplevel.keep (fn state => + let + val thy = Toplevel.theory_of state; + val ctxt = Toplevel.context_of state; + fun pretty_thm (a, th) = Proof_Context.pretty_fact ctxt (a, [th]); + val get_theory = Context.get_theory thy; + in + unused_thms + (case opt_range of + NONE => (Theory.parents_of thy, [thy]) + | SOME (xs, NONE) => (map get_theory xs, [thy]) + | SOME (xs, SOME ys) => (map get_theory xs, map get_theory ys)) + |> map pretty_thm |> Pretty.writeln_chunks + end))); + +end; + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/build-jars --- a/src/Pure/build-jars Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/build-jars Wed Aug 27 15:52:58 2014 +0200 @@ -20,7 +20,7 @@ GUI/gui.scala GUI/gui_thread.scala GUI/html5_panel.scala - GUI/jfx_thread.scala + GUI/jfx_gui.scala GUI/popup.scala GUI/system_dialog.scala GUI/wrap_panel.scala @@ -54,6 +54,7 @@ Isar/token.scala ML/ml_lex.scala PIDE/command.scala + PIDE/command_span.scala PIDE/document.scala PIDE/document_id.scala PIDE/editor.scala @@ -71,7 +72,6 @@ System/command_line.scala System/invoke_scala.scala System/isabelle_charset.scala - System/isabelle_font.scala System/isabelle_process.scala System/isabelle_system.scala System/options.scala @@ -83,6 +83,7 @@ Thy/present.scala Thy/thy_header.scala Thy/thy_info.scala + Thy/thy_structure.scala Thy/thy_syntax.scala Tools/build.scala Tools/build_console.scala diff -r 1b6035697c49 -r be9815d02b10 src/Pure/facts.ML --- a/src/Pure/facts.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/facts.ML Wed Aug 27 15:52:58 2014 +0200 @@ -22,13 +22,15 @@ type T val empty: T val space_of: T -> Name_Space.T + val alias: Name_Space.naming -> binding -> string -> T -> T val is_concealed: T -> string -> bool val check: Context.generic -> T -> xstring * Position.T -> string val intern: T -> xstring -> string val extern: Proof.context -> T -> string -> xstring val markup_extern: Proof.context -> T -> string -> Markup.T * xstring val lookup: Context.generic -> T -> string -> (bool * thm list) option - val retrieve: Context.generic -> T -> xstring * Position.T -> string * thm list + val retrieve: Context.generic -> T -> xstring * Position.T -> + {name: string, static: bool, thms: thm list} val defined: T -> string -> bool val fold_static: (string * thm list -> 'a -> 'a) -> T -> 'a -> 'a val dest_static: bool -> T list -> T -> (string * thm list) list @@ -143,6 +145,9 @@ val space_of = Name_Space.space_of_table o facts_of; +fun alias naming binding name (Facts {facts, props}) = + make_facts (Name_Space.alias_table naming binding name facts) props; + val is_concealed = Name_Space.is_concealed o space_of; fun check context facts (xname, pos) = @@ -156,7 +161,7 @@ val intern = Name_Space.intern o space_of; fun extern ctxt = Name_Space.extern ctxt o space_of; -fun markup_extern ctxt = Name_Space.markup_extern ctxt o space_of +fun markup_extern ctxt = Name_Space.markup_extern ctxt o space_of; (* retrieve *) @@ -172,14 +177,18 @@ fun retrieve context facts (xname, pos) = let val name = check context facts (xname, pos); - val thms = + val (static, thms) = (case lookup context facts name of SOME (static, thms) => (if static then () else Context_Position.report_generic context pos (Markup.dynamic_fact name); - thms) + (static, thms)) | NONE => error ("Unknown fact " ^ quote name ^ Position.here pos)); - in (name, map (Thm.transfer (Context.theory_of context)) thms) end; + in + {name = name, + static = static, + thms = map (Thm.transfer (Context.theory_of context)) thms} + end; (* static content *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/global_theory.ML --- a/src/Pure/global_theory.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/global_theory.ML Wed Aug 27 15:52:58 2014 +0200 @@ -10,6 +10,7 @@ val check_fact: theory -> xstring * Position.T -> string val intern_fact: theory -> xstring -> string val defined_fact: theory -> string -> bool + val alias_fact: binding -> string -> theory -> theory val hide_fact: bool -> string -> theory -> theory val get_thms: theory -> xstring -> thm list val get_thm: theory -> xstring -> thm @@ -28,6 +29,8 @@ val add_thms: ((binding * thm) * attribute list) list -> theory -> thm list * theory val add_thm: (binding * thm) * attribute list -> theory -> thm * theory val add_thmss: ((binding * thm list) * attribute list) list -> theory -> thm list list * theory + val add_thms_dynamic': Context.generic -> binding * (Context.generic -> thm list) -> + theory -> string * theory val add_thms_dynamic: binding * (Context.generic -> thm list) -> theory -> theory val note_thmss: string -> (Thm.binding * (thm list * attribute list) list) list -> theory -> (string * thm list) list * theory @@ -60,13 +63,16 @@ val intern_fact = Facts.intern o facts_of; val defined_fact = Facts.defined o facts_of; +fun alias_fact binding name thy = + Data.map (Facts.alias (Sign.naming_of thy) binding name) thy; + fun hide_fact fully name = Data.map (Facts.hide fully name); (* retrieve theorems *) fun get_thms thy xname = - #2 (Facts.retrieve (Context.Theory thy) (facts_of thy) (xname, Position.none)); + #thms (Facts.retrieve (Context.Theory thy) (facts_of thy) (xname, Position.none)); fun get_thm thy xname = Facts.the_single (xname, Position.none) (get_thms thy xname); @@ -153,10 +159,14 @@ val add_thm = yield_singleton add_thms; -(* add_thms_dynamic *) +(* dynamic theorems *) -fun add_thms_dynamic (b, f) thy = thy - |> Data.map (Facts.add_dynamic (Context.Theory thy) (b, f) #> snd); +fun add_thms_dynamic' context arg thy = + let val (name, facts') = Facts.add_dynamic context arg (Data.get thy) + in (name, Data.put facts' thy) end; + +fun add_thms_dynamic arg thy = + add_thms_dynamic' (Context.Theory thy) arg thy |> snd; (* note_thmss *) diff -r 1b6035697c49 -r be9815d02b10 src/Pure/goal.ML --- a/src/Pure/goal.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/goal.ML Wed Aug 27 15:52:58 2014 +0200 @@ -11,8 +11,6 @@ val PREFER_GOAL: tactic -> int -> tactic val CONJUNCTS: tactic -> int -> tactic val PRECISE_CONJUNCTS: int -> tactic -> int -> tactic - val PARALLEL_CHOICE: tactic list -> tactic - val PARALLEL_GOALS: tactic -> tactic end; signature GOAL = @@ -340,50 +338,6 @@ etac (Raw_Simplifier.norm_hhf ctxt (Thm.trivial R)) THEN_ALL_NEW assume_tac); in fold_rev (curry op APPEND') tacs (K no_tac) i end); - - -(** parallel tacticals **) - -(* parallel choice of single results *) - -fun PARALLEL_CHOICE tacs st = - (case Par_List.get_some (fn tac => SINGLE tac st) tacs of - NONE => Seq.empty - | SOME st' => Seq.single st'); - - -(* parallel refinement of non-schematic goal by single results *) - -local - -exception FAILED of unit; - -fun retrofit st' = - rotate_prems ~1 #> - Thm.bicompose {flatten = false, match = false, incremented = false} - (false, conclude st', Thm.nprems_of st') 1; - -in - -fun PARALLEL_GOALS tac = - Thm.adjust_maxidx_thm ~1 #> - (fn st => - if not (Multithreading.enabled ()) orelse Thm.maxidx_of st >= 0 orelse Thm.nprems_of st <= 1 - then DETERM tac st - else - let - fun try_tac g = - (case SINGLE tac g of - NONE => raise FAILED () - | SOME g' => g'); - - val goals = Drule.strip_imp_prems (Thm.cprop_of st); - val results = Par_List.map (try_tac o init) goals; - in EVERY (map retrofit (rev results)) st end - handle FAILED () => Seq.empty); - -end; - end; structure Basic_Goal: BASIC_GOAL = Goal; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/library.ML --- a/src/Pure/library.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/library.ML Wed Aug 27 15:52:58 2014 +0200 @@ -32,7 +32,6 @@ exception ERROR of string val error: string -> 'a val cat_error: string -> string -> 'a - val assert_all: ('a -> bool) -> 'a list -> ('a -> string) -> unit (*pairs*) val pair: 'a -> 'b -> 'a * 'b @@ -269,12 +268,6 @@ | cat_error msg "" = error msg | cat_error msg1 msg2 = error (msg1 ^ "\n" ^ msg2); -fun assert_all pred list msg = - let - fun ass [] = () - | ass (x :: xs) = if pred x then ass xs else error (msg x); - in ass list end; - (* pairs *) @@ -649,14 +642,14 @@ local val zero = ord "0"; - val small = 10000: int; - val small_table = Vector.tabulate (small, Int.toString); + val small_int = 10000: int; + val small_int_table = Vector.tabulate (small_int, Int.toString); in fun string_of_int i = if i < 0 then Int.toString i else if i < 10 then chr (zero + i) - else if i < small then Vector.sub (small_table, i) + else if i < small_int then Vector.sub (small_int_table, i) else Int.toString i; end; diff -r 1b6035697c49 -r be9815d02b10 src/Pure/library.scala --- a/src/Pure/library.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/library.scala Wed Aug 27 15:52:58 2014 +0200 @@ -32,6 +32,33 @@ error(cat_message(msg1, msg2)) + /* integers */ + + private val small_int = 10000 + private lazy val small_int_table = + { + val array = new Array[String](small_int) + for (i <- 0 until small_int) array(i) = i.toString + array + } + + def is_small_int(s: String): Boolean = + { + val len = s.length + 1 <= len && len <= 4 && + s.forall(c => '0' <= c && c <= '9') && + (len == 1 || s(0) != '0') + } + + def signed_string_of_long(i: Long): String = + if (0 <= i && i < small_int) small_int_table(i.toInt) + else i.toString + + def signed_string_of_int(i: Int): String = + if (0 <= i && i < small_int) small_int_table(i) + else i.toString + + /* separated chunks */ def separate[A](s: A, list: List[A]): List[A] = diff -r 1b6035697c49 -r be9815d02b10 src/Pure/more_thm.ML --- a/src/Pure/more_thm.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/more_thm.ML Wed Aug 27 15:52:58 2014 +0200 @@ -234,7 +234,7 @@ fun is_dummy thm = (case try Logic.dest_term (Thm.concl_of thm) of NONE => false - | SOME t => Term.is_dummy_pattern t); + | SOME t => Term.is_dummy_pattern (Term.head_of t)); fun plain_prop_of raw_thm = let diff -r 1b6035697c49 -r be9815d02b10 src/Pure/par_tactical.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Pure/par_tactical.ML Wed Aug 27 15:52:58 2014 +0200 @@ -0,0 +1,68 @@ +(* Title: Pure/par_tactical.ML + Author: Makarius + +Parallel tacticals. +*) + +signature BASIC_PAR_TACTICAL = +sig + val PARALLEL_CHOICE: tactic list -> tactic + val PARALLEL_GOALS: tactic -> tactic + val PARALLEL_ALLGOALS: (int -> tactic) -> tactic +end; + +signature PAR_TACTICAL = +sig + include BASIC_PAR_TACTICAL +end; + +structure Par_Tactical: PAR_TACTICAL = +struct + +(* parallel choice of single results *) + +fun PARALLEL_CHOICE tacs st = + (case Par_List.get_some (fn tac => SINGLE tac st) tacs of + NONE => Seq.empty + | SOME st' => Seq.single st'); + + +(* parallel refinement of non-schematic goal by single results *) + +local + +exception FAILED of unit; + +fun retrofit st' = + rotate_prems ~1 #> + Thm.bicompose {flatten = false, match = false, incremented = false} + (false, Goal.conclude st', Thm.nprems_of st') 1; + +in + +fun PARALLEL_GOALS tac = + Thm.adjust_maxidx_thm ~1 #> + (fn st => + if not (Multithreading.enabled ()) orelse Thm.maxidx_of st >= 0 orelse Thm.nprems_of st <= 1 + then DETERM tac st + else + let + fun try_tac g = + (case SINGLE tac g of + NONE => raise FAILED () + | SOME g' => g'); + + val goals = Drule.strip_imp_prems (Thm.cprop_of st); + val results = Par_List.map (try_tac o Goal.init) goals; + in EVERY (map retrofit (rev results)) st end + handle FAILED () => Seq.empty); + +end; + +val PARALLEL_ALLGOALS = PARALLEL_GOALS o ALLGOALS; + +end; + +structure Basic_Par_Tactical: BASIC_PAR_TACTICAL = Par_Tactical; +open Basic_Par_Tactical; + diff -r 1b6035697c49 -r be9815d02b10 src/Pure/simplifier.ML --- a/src/Pure/simplifier.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Pure/simplifier.ML Wed Aug 27 15:52:58 2014 +0200 @@ -332,21 +332,23 @@ (** method syntax **) val cong_modifiers = - [Args.$$$ congN -- Args.colon >> K ((I, cong_add): Method.modifier), - Args.$$$ congN -- Args.add -- Args.colon >> K (I, cong_add), - Args.$$$ congN -- Args.del -- Args.colon >> K (I, cong_del)]; + [Args.$$$ congN -- Args.colon >> K (Method.modifier cong_add @{here}), + Args.$$$ congN -- Args.add -- Args.colon >> K (Method.modifier cong_add @{here}), + Args.$$$ congN -- Args.del -- Args.colon >> K (Method.modifier cong_del @{here})]; val simp_modifiers = - [Args.$$$ simpN -- Args.colon >> K (I, simp_add), - Args.$$$ simpN -- Args.add -- Args.colon >> K (I, simp_add), - Args.$$$ simpN -- Args.del -- Args.colon >> K (I, simp_del), - Args.$$$ simpN -- Args.$$$ onlyN -- Args.colon >> K (Raw_Simplifier.clear_simpset, simp_add)] + [Args.$$$ simpN -- Args.colon >> K (Method.modifier simp_add @{here}), + Args.$$$ simpN -- Args.add -- Args.colon >> K (Method.modifier simp_add @{here}), + Args.$$$ simpN -- Args.del -- Args.colon >> K (Method.modifier simp_del @{here}), + Args.$$$ simpN -- Args.$$$ onlyN -- Args.colon >> + K {init = Raw_Simplifier.clear_simpset, attribute = simp_add, pos = @{here}}] @ cong_modifiers; val simp_modifiers' = - [Args.add -- Args.colon >> K (I, simp_add), - Args.del -- Args.colon >> K (I, simp_del), - Args.$$$ onlyN -- Args.colon >> K (Raw_Simplifier.clear_simpset, simp_add)] + [Args.add -- Args.colon >> K (Method.modifier simp_add @{here}), + Args.del -- Args.colon >> K (Method.modifier simp_del @{here}), + Args.$$$ onlyN -- Args.colon >> + K {init = Raw_Simplifier.clear_simpset, attribute = simp_add, pos = @{here}}] @ cong_modifiers; val simp_options = @@ -374,7 +376,7 @@ Method.setup @{binding simp_all} (simp_method more_mods (fn ctxt => fn tac => fn facts => ALLGOALS (Method.insert_tac facts) THEN - (CHANGED_PROP o PARALLEL_GOALS o ALLGOALS o tac) ctxt)) + (CHANGED_PROP o PARALLEL_ALLGOALS o tac) ctxt)) "simplification (all goals)"; fun easy_setup reflect trivs = method_setup [] #> Context.theory_map (map_ss (fn ctxt0 => diff -r 1b6035697c49 -r be9815d02b10 src/Sequents/prover.ML --- a/src/Sequents/prover.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Sequents/prover.ML Wed Aug 27 15:52:58 2014 +0200 @@ -106,8 +106,8 @@ fun method tac = Method.sections - [Args.$$$ "add" -- Args.bang_colon >> K (I, safe_add), - Args.$$$ "add" -- Args.colon >> K (I, unsafe_add)] + [Args.$$$ "add" -- Args.bang_colon >> K (Method.modifier safe_add @{here}), + Args.$$$ "add" -- Args.colon >> K (Method.modifier unsafe_add @{here})] >> K (SIMPLE_METHOD' o tac); diff -r 1b6035697c49 -r be9815d02b10 src/Tools/Code/code_target.ML --- a/src/Tools/Code/code_target.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/Code/code_target.ML Wed Aug 27 15:52:58 2014 +0200 @@ -695,7 +695,7 @@ let val ctxt = Proof_Context.init_global (Thy_Info.get_theory thyname); val parse = Scan.read Token.stopper (Parse.!!! code_exprP) o - (filter Token.is_proper o Outer_Syntax.scan Position.none); + (filter Token.is_proper o Outer_Syntax.scan (Keyword.get_lexicons ()) Position.none); in case parse cmd_expr of SOME f => (writeln "Now generating code..."; f ctxt) | NONE => error ("Bad directive " ^ quote cmd_expr) diff -r 1b6035697c49 -r be9815d02b10 src/Tools/atomize_elim.ML --- a/src/Tools/atomize_elim.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/atomize_elim.ML Wed Aug 27 15:52:58 2014 +0200 @@ -6,28 +6,22 @@ signature ATOMIZE_ELIM = sig - val declare_atomize_elim : attribute - val atomize_elim_conv : Proof.context -> conv val full_atomize_elim_conv : Proof.context -> conv - val atomize_elim_tac : Proof.context -> int -> tactic - - val setup : theory -> theory end -structure AtomizeElim : ATOMIZE_ELIM = +structure Atomize_Elim : ATOMIZE_ELIM = struct -(* theory data *) +(* atomize_elim rules *) -structure AtomizeElimData = Named_Thms -( - val name = @{binding atomize_elim}; - val description = "atomize_elim rewrite rule"; -); +val named_theorems = + Context.>>> (Context.map_theory_result + (Named_Target.theory_init #> + Named_Theorems.declare @{binding atomize_elim} "atomize_elim rewrite rule" ##> + Local_Theory.exit_global)); -val declare_atomize_elim = AtomizeElimData.add (* More conversions: *) local open Conv in @@ -50,7 +44,7 @@ in Thm.equal_intr fwd back end -(* convert !!thesis. (!!x y z. ... => thesis) ==> ... +(* convert !!thesis. (!!x y z. ... => thesis) ==> ... ==> (!!a b c. ... => thesis) ==> thesis @@ -60,7 +54,7 @@ *) fun atomize_elim_conv ctxt ct = (forall_conv (prems_conv ~1 o Object_Logic.atomize_prems o snd) ctxt - then_conv Raw_Simplifier.rewrite ctxt true (AtomizeElimData.get ctxt) + then_conv Raw_Simplifier.rewrite ctxt true (Named_Theorems.get ctxt named_theorems) then_conv (fn ct' => if can Object_Logic.dest_judgment ct' then all_conv ct' else raise CTERM ("atomize_elim", [ct', ct]))) @@ -71,7 +65,7 @@ fun thesis_miniscope_conv inner_cv ctxt = let (* check if the outermost quantifier binds the conclusion *) - fun is_forall_thesis t = + fun is_forall_thesis t = case Logic.strip_assums_concl t of (_ $ Bound i) => i = length (Logic.strip_params t) - 1 | _ => false @@ -93,11 +87,11 @@ end (* move current quantifier to the right *) - fun moveq_conv ctxt = + fun moveq_conv ctxt = (rewr_conv @{thm swap_params} then_conv (forall_conv (moveq_conv o snd) ctxt)) else_conv (movea_conv ctxt) - fun ms_conv ctxt ct = + fun ms_conv ctxt ct = if is_forall_thesis (term_of ct) then moveq_conv ctxt ct else (implies_concl_conv (ms_conv ctxt) @@ -105,7 +99,7 @@ (forall_conv (ms_conv o snd) ctxt)) ct in - ms_conv ctxt + ms_conv ctxt end val full_atomize_elim_conv = thesis_miniscope_conv atomize_elim_conv @@ -117,13 +111,13 @@ let val thy = Proof_Context.theory_of ctxt val _ $ thesis = Logic.strip_assums_concl subg - + (* Introduce a quantifier first if the thesis is not bound *) - val quantify_thesis = + val quantify_thesis = if is_Bound thesis then all_tac else let val cthesis = cterm_of thy thesis - val rule = instantiate' [SOME (ctyp_of_term cthesis)] [NONE, SOME cthesis] + val rule = instantiate' [SOME (ctyp_of_term cthesis)] [NONE, SOME cthesis] @{thm meta_spec} in compose_tac (false, rule, 1) i @@ -133,9 +127,9 @@ THEN (CONVERSION (full_atomize_elim_conv ctxt) i) end) -val setup = - Method.setup @{binding atomize_elim} (Scan.succeed (SIMPLE_METHOD' o atomize_elim_tac)) - "convert obtains statement to atomic object logic goal" - #> AtomizeElimData.setup +val _ = + Theory.setup + (Method.setup @{binding atomize_elim} (Scan.succeed (SIMPLE_METHOD' o atomize_elim_tac)) + "convert obtains statement to atomic object logic goal") end diff -r 1b6035697c49 -r be9815d02b10 src/Tools/induct.ML --- a/src/Tools/induct.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/induct.ML Wed Aug 27 15:52:58 2014 +0200 @@ -932,15 +932,13 @@ (cases_tac ctxt (not no_simp) insts opt_rule facts))))) "case analysis on types or predicates/sets"; -fun gen_induct_setup binding itac = +fun gen_induct_setup binding tac = Method.setup binding (Scan.lift (Args.mode no_simpN) -- (Parse.and_list' (Scan.repeat (unless_more_args def_inst)) -- (arbitrary -- taking -- Scan.option induct_rule)) >> - (fn (no_simp, (insts, ((arbitrary, taking), opt_rule))) => fn ctxt => - RAW_METHOD_CASES (fn facts => - Seq.DETERM - (HEADGOAL (itac ctxt (not no_simp) insts arbitrary taking opt_rule facts))))) + (fn (no_simp, (insts, ((arbitrary, taking), opt_rule))) => fn ctxt => fn facts => + Seq.DETERM (HEADGOAL (tac ctxt (not no_simp) insts arbitrary taking opt_rule facts)))) "induction on types or predicates/sets"; val induct_setup = gen_induct_setup @{binding induct} induct_tac; @@ -948,9 +946,8 @@ val coinduct_setup = Method.setup @{binding coinduct} (Scan.repeat (unless_more_args inst) -- taking -- Scan.option coinduct_rule >> - (fn ((insts, taking), opt_rule) => fn ctxt => - RAW_METHOD_CASES (fn facts => - Seq.DETERM (HEADGOAL (coinduct_tac ctxt insts taking opt_rule facts))))) + (fn ((insts, taking), opt_rule) => fn ctxt => fn facts => + Seq.DETERM (HEADGOAL (coinduct_tac ctxt insts taking opt_rule facts)))) "coinduction on types or predicates/sets"; end; diff -r 1b6035697c49 -r be9815d02b10 src/Tools/intuitionistic.ML --- a/src/Tools/intuitionistic.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/intuitionistic.ML Wed Aug 27 15:52:58 2014 +0200 @@ -73,18 +73,18 @@ val elimN = "elim"; val destN = "dest"; -fun modifier name kind kind' att = +fun modifier name kind kind' att pos = Args.$$$ name |-- (kind >> K NONE || kind' |-- Parse.nat --| Args.colon >> SOME) - >> (pair (I: Proof.context -> Proof.context) o att); + >> (fn arg => Method.modifier (att arg) pos); val modifiers = - [modifier destN Args.bang_colon Args.bang Context_Rules.dest_bang, - modifier destN Args.colon (Scan.succeed ()) Context_Rules.dest, - modifier elimN Args.bang_colon Args.bang Context_Rules.elim_bang, - modifier elimN Args.colon (Scan.succeed ()) Context_Rules.elim, - modifier introN Args.bang_colon Args.bang Context_Rules.intro_bang, - modifier introN Args.colon (Scan.succeed ()) Context_Rules.intro, - Args.del -- Args.colon >> K (I, Context_Rules.rule_del)]; + [modifier destN Args.bang_colon Args.bang Context_Rules.dest_bang @{here}, + modifier destN Args.colon (Scan.succeed ()) Context_Rules.dest @{here}, + modifier elimN Args.bang_colon Args.bang Context_Rules.elim_bang @{here}, + modifier elimN Args.colon (Scan.succeed ()) Context_Rules.elim @{here}, + modifier introN Args.bang_colon Args.bang Context_Rules.intro_bang @{here}, + modifier introN Args.colon (Scan.succeed ()) Context_Rules.intro @{here}, + Args.del -- Args.colon >> K (Method.modifier Context_Rules.rule_del @{here})]; in diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/document_model.scala --- a/src/Tools/jEdit/src/document_model.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/document_model.scala Wed Aug 27 15:52:58 2014 +0200 @@ -104,13 +104,10 @@ val snapshot = this.snapshot() val document_view_ranges = - if (is_theory) { - for { - doc_view <- PIDE.document_views(buffer) - range <- doc_view.perspective(snapshot).ranges - } yield range - } - else Nil + for { + doc_view <- PIDE.document_views(buffer) + range <- doc_view.perspective(snapshot).ranges + } yield range val load_ranges = for { diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/documentation_dockable.scala --- a/src/Tools/jEdit/src/documentation_dockable.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/documentation_dockable.scala Wed Aug 27 15:52:58 2014 +0200 @@ -10,7 +10,7 @@ import isabelle._ import java.awt.{Dimension, GridLayout} -import java.awt.event.{MouseEvent, MouseAdapter} +import java.awt.event.{KeyEvent, KeyAdapter, MouseEvent, MouseAdapter} import javax.swing.{JTree, JScrollPane, JComponent} import javax.swing.tree.{DefaultMutableTreeNode, TreeSelectionModel} import javax.swing.event.{TreeSelectionEvent, TreeSelectionListener} @@ -24,13 +24,13 @@ private case class Documentation(name: String, title: String, path: Path) { - override def toString = + override def toString: String = "" + HTML.encode(name) + ": " + HTML.encode(title) + "" } private case class Text_File(name: String, path: Path) { - override def toString = name + override def toString: String = name } private val root = new DefaultMutableTreeNode @@ -47,38 +47,57 @@ private val tree = new JTree(root) - for (cond <- - List(JComponent.WHEN_FOCUSED, - JComponent.WHEN_ANCESTOR_OF_FOCUSED_COMPONENT, - JComponent.WHEN_IN_FOCUSED_WINDOW)) tree.setInputMap(cond, null) + override def focusOnDefaultComponent { tree.requestFocusInWindow } if (!OperatingSystem.isMacOSLF) tree.putClientProperty("JTree.lineStyle", "Angled") tree.getSelectionModel.setSelectionMode(TreeSelectionModel.SINGLE_TREE_SELECTION) + + private def action(node: DefaultMutableTreeNode) + { + node.getUserObject match { + case Text_File(_, path) => + PIDE.editor.goto_file(view, Isabelle_System.platform_path(path)) + case Documentation(_, _, path) => + if (path.is_file) + PIDE.editor.goto_file(view, Isabelle_System.platform_path(path)) + else { + Future.fork { + try { Doc.view(path) } + catch { + case exn: Throwable => + GUI.error_dialog(view, + "Documentation error", GUI.scrollable_text(Exn.message(exn))) + } + } + } + case _ => + } + } + + tree.addKeyListener(new KeyAdapter { + override def keyPressed(e: KeyEvent) + { + if (e.getKeyCode == KeyEvent.VK_ENTER) { + e.consume + val path = tree.getSelectionPath + if (path != null) { + path.getLastPathComponent match { + case node: DefaultMutableTreeNode => action(node) + case _ => + } + } + } + } + }) tree.addMouseListener(new MouseAdapter { - override def mouseClicked(e: MouseEvent) { + override def mouseClicked(e: MouseEvent) + { val click = tree.getPathForLocation(e.getX, e.getY) if (click != null && e.getClickCount == 1) { (click.getLastPathComponent, tree.getLastSelectedPathComponent) match { case (node: DefaultMutableTreeNode, node1: DefaultMutableTreeNode) if node == node1 => - node.getUserObject match { - case Text_File(_, path) => - PIDE.editor.goto_file(view, Isabelle_System.platform_path(path)) - case Documentation(_, _, path) => - if (path.is_file) - PIDE.editor.goto_file(view, Isabelle_System.platform_path(path)) - else { - Future.fork { - try { Doc.view(path) } - catch { - case exn: Throwable => - GUI.error_dialog(view, - "Documentation error", GUI.scrollable_text(Exn.message(exn))) - } - } - } - case _ => - } + action(node) case _ => } } diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/isabelle_logic.scala --- a/src/Tools/jEdit/src/isabelle_logic.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/isabelle_logic.scala Wed Aug 27 15:52:58 2014 +0200 @@ -24,7 +24,7 @@ private class Logic_Entry(val name: String, val description: String) { - override def toString = description + override def toString: String = description } def logic_selector(autosave: Boolean): Option_Component = diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/isabelle_sidekick.scala --- a/src/Tools/jEdit/src/isabelle_sidekick.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/isabelle_sidekick.scala Wed Aug 27 15:52:58 2014 +0200 @@ -21,7 +21,7 @@ object Isabelle_Sidekick { def int_to_pos(offset: Text.Offset): Position = - new Position { def getOffset = offset; override def toString = offset.toString } + new Position { def getOffset = offset; override def toString: String = offset.toString } class Asset(name: String, start: Text.Offset, end: Text.Offset) extends IAsset { @@ -39,7 +39,7 @@ override def setStart(start: Position) = _start = start override def getEnd: Position = _end override def setEnd(end: Position) = _end = end - override def toString = _name + override def toString: String = _name } def swing_markup_tree(tree: Markup_Tree, parent: DefaultMutableTreeNode, @@ -95,13 +95,11 @@ node_name: Buffer => Option[Document.Node.Name]) extends Isabelle_Sidekick(name) { - import Thy_Syntax.Structure - override def parser(buffer: Buffer, syntax: Outer_Syntax, data: SideKickParsedData): Boolean = { - def make_tree(offset: Text.Offset, entry: Structure.Entry): List[DefaultMutableTreeNode] = + def make_tree(offset: Text.Offset, entry: Thy_Structure.Entry): List[DefaultMutableTreeNode] = entry match { - case Structure.Block(name, body) => + case Thy_Structure.Block(name, body) => val node = new DefaultMutableTreeNode( new Isabelle_Sidekick.Asset(Library.first_line(name), offset, offset + entry.length)) @@ -111,8 +109,8 @@ i + e.length }) List(node) - case Structure.Atom(command) - if command.is_command && syntax.heading_level(command).isEmpty => + case Thy_Structure.Atom(command) + if command.is_proper && syntax.heading_level(command).isEmpty => val node = new DefaultMutableTreeNode( new Isabelle_Sidekick.Asset(command.name, offset, offset + entry.length)) @@ -123,7 +121,7 @@ node_name(buffer) match { case Some(name) => val text = JEdit_Lib.buffer_text(buffer) - val structure = Structure.parse(syntax, name, text) + val structure = Thy_Structure.parse(syntax, name, text) make_tree(0, structure) foreach (node => data.root.add(node)) true case None => false @@ -175,7 +173,7 @@ new Isabelle_Sidekick.Asset(command.toString, range.start, range.stop) { override def getShortString: String = content override def getLongString: String = info_text - override def toString = quote(content) + " " + range.toString + override def toString: String = quote(content) + " " + range.toString }) }) } diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/plugin.scala --- a/src/Tools/jEdit/src/plugin.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/plugin.scala Wed Aug 27 15:52:58 2014 +0200 @@ -373,7 +373,7 @@ PIDE.plugin = this Isabelle_System.init() - Isabelle_Font.install_fonts() + GUI.install_fonts() PIDE.options.update(Options.init()) PIDE.completion_history.load() diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/rendering.scala --- a/src/Tools/jEdit/src/rendering.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/rendering.scala Wed Aug 27 15:52:58 2014 +0200 @@ -376,7 +376,7 @@ case Position.Def_Line_File(line, name) => val offset = Position.Def_Offset.unapply(props) getOrElse 0 PIDE.editor.hyperlink_source_file(name, line, offset) - case Position.Def_Id_Offset(id, offset) => + case Position.Def_Id_Offset0(id, offset) => PIDE.editor.hyperlink_command_id(snapshot, id, offset) case _ => None } @@ -388,7 +388,7 @@ case Position.Line_File(line, name) => val offset = Position.Offset.unapply(props) getOrElse 0 PIDE.editor.hyperlink_source_file(name, line, offset) - case Position.Id_Offset(id, offset) => + case Position.Id_Offset0(id, offset) => PIDE.editor.hyperlink_command_id(snapshot, id, offset) case _ => None } @@ -480,7 +480,9 @@ Some(Text.Info(r, (t1 + t2, info))) case (prev, Text.Info(r, XML.Elem(Markup.Entity(kind, name), _))) => val kind1 = Word.implode(Word.explode('_', kind)) - val txt1 = kind1 + " " + quote(name) + val txt1 = + if (name == "") kind1 + else kind1 + " " + quote(name) val t = prev.info._1 val txt2 = if (kind == Markup.COMMAND && t.elapsed.seconds >= timing_threshold) diff -r 1b6035697c49 -r be9815d02b10 src/Tools/jEdit/src/symbols_dockable.scala --- a/src/Tools/jEdit/src/symbols_dockable.scala Wed Aug 27 11:33:00 2014 +0200 +++ b/src/Tools/jEdit/src/symbols_dockable.scala Wed Aug 27 15:52:58 2014 +0200 @@ -24,8 +24,8 @@ font = Symbol.fonts.get(symbol) match { - case None => Isabelle_Font(size = font_size) - case Some(font_family) => Isabelle_Font(family = font_family, size = font_size) + case None => GUI.font(size = font_size) + case Some(font_family) => GUI.font(family = font_family, size = font_size) } action = Action(decoded) { diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Bin.thy --- a/src/ZF/Bin.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Bin.thy Wed Aug 27 15:52:58 2014 +0200 @@ -594,4 +594,92 @@ "(integ_of(w) = x $* y) \ (x $* y = integ_of(w))" by auto +(** To simplify inequalities involving integer negation and literals, + such as -x = #3 +**) + +lemmas [simp] = + zminus_equation [where y = "integ_of(w)"] + equation_zminus [where x = "integ_of(w)"] + for w + +lemmas [iff] = + zminus_zless [where y = "integ_of(w)"] + zless_zminus [where x = "integ_of(w)"] + for w + +lemmas [iff] = + zminus_zle [where y = "integ_of(w)"] + zle_zminus [where x = "integ_of(w)"] + for w + +lemmas [simp] = + Let_def [where s = "integ_of(w)"] for w + + +(*** Simprocs for numeric literals ***) + +(** Combining of literal coefficients in sums of products **) + +lemma zless_iff_zdiff_zless_0: "(x $< y) \ (x$-y $< #0)" + by (simp add: zcompare_rls) + +lemma eq_iff_zdiff_eq_0: "[| x \ int; y \ int |] ==> (x = y) \ (x$-y = #0)" + by (simp add: zcompare_rls) + +lemma zle_iff_zdiff_zle_0: "(x $<= y) \ (x$-y $<= #0)" + by (simp add: zcompare_rls) + + +(** For combine_numerals **) + +lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k" + by (simp add: zadd_zmult_distrib zadd_ac) + + +(** For cancel_numerals **) + +lemmas rel_iff_rel_0_rls = + zless_iff_zdiff_zless_0 [where y = "u $+ v"] + eq_iff_zdiff_eq_0 [where y = "u $+ v"] + zle_iff_zdiff_zle_0 [where y = "u $+ v"] + zless_iff_zdiff_zless_0 [where y = n] + eq_iff_zdiff_eq_0 [where y = n] + zle_iff_zdiff_zle_0 [where y = n] + for u v (* FIXME n (!?) *) + +lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \ ((i$-j)$*u $+ m = intify(n))" + apply (simp add: zdiff_def zadd_zmult_distrib) + apply (simp add: zcompare_rls) + apply (simp add: zadd_ac) + done + +lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \ (intify(m) = (j$-i)$*u $+ n)" + apply (simp add: zdiff_def zadd_zmult_distrib) + apply (simp add: zcompare_rls) + apply (simp add: zadd_ac) + done + +lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \ ((i$-j)$*u $+ m $< n)" + apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls) + done + +lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \ (m $< (j$-i)$*u $+ n)" + apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls) + done + +lemma le_add_iff1: "(i$*u $+ m $<= j$*u $+ n) \ ((i$-j)$*u $+ m $<= n)" + apply (simp add: zdiff_def zadd_zmult_distrib) + apply (simp add: zcompare_rls) + apply (simp add: zadd_ac) + done + +lemma le_add_iff2: "(i$*u $+ m $<= j$*u $+ n) \ (m $<= (j$-i)$*u $+ n)" + apply (simp add: zdiff_def zadd_zmult_distrib) + apply (simp add: zcompare_rls) + apply (simp add: zadd_ac) + done + +ML_file "int_arith.ML" + end diff -r 1b6035697c49 -r be9815d02b10 src/ZF/IntArith.thy --- a/src/ZF/IntArith.thy Wed Aug 27 11:33:00 2014 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ - -theory IntArith imports Bin -begin - - -(** To simplify inequalities involving integer negation and literals, - such as -x = #3 -**) - -lemmas [simp] = - zminus_equation [where y = "integ_of(w)"] - equation_zminus [where x = "integ_of(w)"] - for w - -lemmas [iff] = - zminus_zless [where y = "integ_of(w)"] - zless_zminus [where x = "integ_of(w)"] - for w - -lemmas [iff] = - zminus_zle [where y = "integ_of(w)"] - zle_zminus [where x = "integ_of(w)"] - for w - -lemmas [simp] = - Let_def [where s = "integ_of(w)"] for w - - -(*** Simprocs for numeric literals ***) - -(** Combining of literal coefficients in sums of products **) - -lemma zless_iff_zdiff_zless_0: "(x $< y) \ (x$-y $< #0)" - by (simp add: zcompare_rls) - -lemma eq_iff_zdiff_eq_0: "[| x \ int; y \ int |] ==> (x = y) \ (x$-y = #0)" - by (simp add: zcompare_rls) - -lemma zle_iff_zdiff_zle_0: "(x $<= y) \ (x$-y $<= #0)" - by (simp add: zcompare_rls) - - -(** For combine_numerals **) - -lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k" - by (simp add: zadd_zmult_distrib zadd_ac) - - -(** For cancel_numerals **) - -lemmas rel_iff_rel_0_rls = - zless_iff_zdiff_zless_0 [where y = "u $+ v"] - eq_iff_zdiff_eq_0 [where y = "u $+ v"] - zle_iff_zdiff_zle_0 [where y = "u $+ v"] - zless_iff_zdiff_zless_0 [where y = n] - eq_iff_zdiff_eq_0 [where y = n] - zle_iff_zdiff_zle_0 [where y = n] - for u v (* FIXME n (!?) *) - -lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \ ((i$-j)$*u $+ m = intify(n))" - apply (simp add: zdiff_def zadd_zmult_distrib) - apply (simp add: zcompare_rls) - apply (simp add: zadd_ac) - done - -lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \ (intify(m) = (j$-i)$*u $+ n)" - apply (simp add: zdiff_def zadd_zmult_distrib) - apply (simp add: zcompare_rls) - apply (simp add: zadd_ac) - done - -lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \ ((i$-j)$*u $+ m $< n)" - apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls) - done - -lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \ (m $< (j$-i)$*u $+ n)" - apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls) - done - -lemma le_add_iff1: "(i$*u $+ m $<= j$*u $+ n) \ ((i$-j)$*u $+ m $<= n)" - apply (simp add: zdiff_def zadd_zmult_distrib) - apply (simp add: zcompare_rls) - apply (simp add: zadd_ac) - done - -lemma le_add_iff2: "(i$*u $+ m $<= j$*u $+ n) \ (m $<= (j$-i)$*u $+ n)" - apply (simp add: zdiff_def zadd_zmult_distrib) - apply (simp add: zcompare_rls) - apply (simp add: zadd_ac) - done - -ML_file "int_arith.ML" - -end diff -r 1b6035697c49 -r be9815d02b10 src/ZF/IntDiv_ZF.thy --- a/src/ZF/IntDiv_ZF.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/IntDiv_ZF.thy Wed Aug 27 15:52:58 2014 +0200 @@ -29,7 +29,9 @@ header{*The Division Operators Div and Mod*} -theory IntDiv_ZF imports IntArith OrderArith begin +theory IntDiv_ZF +imports Bin OrderArith +begin definition quorem :: "[i,i] => o" where diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/datatype_package.ML --- a/src/ZF/Tools/datatype_package.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Tools/datatype_package.ML Wed Aug 27 15:52:58 2014 +0200 @@ -32,8 +32,8 @@ val add_datatype_i: term * term list -> Ind_Syntax.constructor_spec list list -> thm list * thm list * thm list -> theory -> theory * inductive_result * datatype_result val add_datatype: string * string list -> (string * string list * mixfix) list list -> - (Facts.ref * Attrib.src list) list * (Facts.ref * Attrib.src list) list * - (Facts.ref * Attrib.src list) list -> theory -> theory * inductive_result * datatype_result + (Facts.ref * Token.src list) list * (Facts.ref * Token.src list) list * + (Facts.ref * Token.src list) list -> theory -> theory * inductive_result * datatype_result end; functor Add_datatype_def_Fun @@ -437,9 +437,9 @@ ("define " ^ coind_prefix ^ "datatype") ((Scan.optional ((@{keyword "\"} || @{keyword "<="}) |-- Parse.!!! Parse.term) "") -- Parse.and_list1 (Parse.term -- (@{keyword "="} |-- Parse.enum1 "|" con_decl)) -- - Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse_Spec.xthms1) [] -- - Scan.optional (@{keyword "type_intros"} |-- Parse.!!! Parse_Spec.xthms1) [] -- - Scan.optional (@{keyword "type_elims"} |-- Parse.!!! Parse_Spec.xthms1) [] + Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse.xthms1) [] -- + Scan.optional (@{keyword "type_intros"} |-- Parse.!!! Parse.xthms1) [] -- + Scan.optional (@{keyword "type_elims"} |-- Parse.!!! Parse.xthms1) [] >> (Toplevel.theory o mk_datatype)); end; diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/induct_tacs.ML --- a/src/ZF/Tools/induct_tacs.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Tools/induct_tacs.ML Wed Aug 27 15:52:58 2014 +0200 @@ -12,8 +12,8 @@ val induct_tac: Proof.context -> string -> int -> tactic val exhaust_tac: Proof.context -> string -> int -> tactic val rep_datatype_i: thm -> thm -> thm list -> thm list -> theory -> theory - val rep_datatype: Facts.ref * Attrib.src list -> Facts.ref * Attrib.src list -> - (Facts.ref * Attrib.src list) list -> (Facts.ref * Attrib.src list) list -> theory -> theory + val rep_datatype: Facts.ref * Token.src list -> Facts.ref * Token.src list -> + (Facts.ref * Token.src list) list -> (Facts.ref * Token.src list) list -> theory -> theory val setup: theory -> theory end; @@ -190,10 +190,10 @@ val _ = Outer_Syntax.command @{command_spec "rep_datatype"} "represent existing set inductively" - ((@{keyword "elimination"} |-- Parse.!!! Parse_Spec.xthm) -- - (@{keyword "induction"} |-- Parse.!!! Parse_Spec.xthm) -- - (@{keyword "case_eqns"} |-- Parse.!!! Parse_Spec.xthms1) -- - Scan.optional (@{keyword "recursor_eqns"} |-- Parse.!!! Parse_Spec.xthms1) [] + ((@{keyword "elimination"} |-- Parse.!!! Parse.xthm) -- + (@{keyword "induction"} |-- Parse.!!! Parse.xthm) -- + (@{keyword "case_eqns"} |-- Parse.!!! Parse.xthms1) -- + Scan.optional (@{keyword "recursor_eqns"} |-- Parse.!!! Parse.xthms1) [] >> (fn (((x, y), z), w) => Toplevel.theory (rep_datatype x y z w))); end; diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/inductive_package.ML --- a/src/ZF/Tools/inductive_package.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Tools/inductive_package.ML Wed Aug 27 15:52:58 2014 +0200 @@ -29,9 +29,9 @@ ((binding * term) * attribute list) list -> thm list * thm list * thm list * thm list -> theory -> theory * inductive_result val add_inductive: string list * string -> - ((binding * string) * Attrib.src list) list -> - (Facts.ref * Attrib.src list) list * (Facts.ref * Attrib.src list) list * - (Facts.ref * Attrib.src list) list * (Facts.ref * Attrib.src list) list -> + ((binding * string) * Token.src list) list -> + (Facts.ref * Token.src list) list * (Facts.ref * Token.src list) list * + (Facts.ref * Token.src list) list * (Facts.ref * Token.src list) list -> theory -> theory * inductive_result end; @@ -586,10 +586,10 @@ ((@{keyword "\"} || @{keyword "<="}) |-- Parse.term))) -- (@{keyword "intros"} |-- Parse.!!! (Scan.repeat1 (Parse_Spec.opt_thm_name ":" -- Parse.prop))) -- - Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse_Spec.xthms1) [] -- - Scan.optional (@{keyword "con_defs"} |-- Parse.!!! Parse_Spec.xthms1) [] -- - Scan.optional (@{keyword "type_intros"} |-- Parse.!!! Parse_Spec.xthms1) [] -- - Scan.optional (@{keyword "type_elims"} |-- Parse.!!! Parse_Spec.xthms1) [] + Scan.optional (@{keyword "monos"} |-- Parse.!!! Parse.xthms1) [] -- + Scan.optional (@{keyword "con_defs"} |-- Parse.!!! Parse.xthms1) [] -- + Scan.optional (@{keyword "type_intros"} |-- Parse.!!! Parse.xthms1) [] -- + Scan.optional (@{keyword "type_elims"} |-- Parse.!!! Parse.xthms1) [] >> (Toplevel.theory o mk_ind); val _ = diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/primrec_package.ML --- a/src/ZF/Tools/primrec_package.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Tools/primrec_package.ML Wed Aug 27 15:52:58 2014 +0200 @@ -8,7 +8,7 @@ signature PRIMREC_PACKAGE = sig - val add_primrec: ((binding * string) * Attrib.src list) list -> theory -> theory * thm list + val add_primrec: ((binding * string) * Token.src list) list -> theory -> theory * thm list val add_primrec_i: ((binding * term) * attribute list) list -> theory -> theory * thm list end; diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/twos_compl.ML --- a/src/ZF/Tools/twos_compl.ML Wed Aug 27 11:33:00 2014 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -(* Title: ZF/Tools/twos_compl.ML - Author: Lawrence C Paulson, Cambridge University Computer Laboratory - Copyright 1993 University of Cambridge - -ML code for Arithmetic on binary integers; the model for theory Bin - - The sign Pls stands for an infinite string of leading 0s. - The sign Min stands for an infinite string of leading 1s. - -See int_of_binary for the numerical interpretation. A number can have -multiple representations, namely leading 0s with sign Pls and leading 1s with -sign Min. A number is in NORMAL FORM if it has no such extra bits. - -The representation expects that (m mod 2) is 0 or 1, even if m is negative; -For instance, ~5 div 2 = ~3 and ~5 mod 2 = 1; thus ~5 = (~3)*2 + 1 - -Still needs division! -*) - -infix 5 $$ $$$ - -(*Recursive datatype of binary integers*) -datatype bin = Pls | Min | $$ of bin * int; - -(** Conversions between bin and int **) - -fun int_of_binary Pls = 0 - | int_of_binary Min = ~1 - | int_of_binary (w$$b) = 2 * int_of_binary w + b; - -fun binary_of_int 0 = Pls - | binary_of_int ~1 = Min - | binary_of_int n = binary_of_int (n div 2) $$ (n mod 2); - -(*** Addition ***) - -(*Attach a bit while preserving the normal form. Cases left as default - are Pls$$$1 and Min$$$0. *) -fun Pls $$$ 0 = Pls - | Min $$$ 1 = Min - | v $$$ x = v$$x; - -(*Successor of an integer, assumed to be in normal form. - If w$$1 is normal then w is not Min, so bin_succ(w) $$ 0 is normal. - But Min$$0 is normal while Min$$1 is not.*) -fun bin_succ Pls = Pls$$1 - | bin_succ Min = Pls - | bin_succ (w$$1) = bin_succ(w) $$ 0 - | bin_succ (w$$0) = w $$$ 1; - -(*Predecessor of an integer, assumed to be in normal form. - If w$$0 is normal then w is not Pls, so bin_pred(w) $$ 1 is normal. - But Pls$$1 is normal while Pls$$0 is not.*) -fun bin_pred Pls = Min - | bin_pred Min = Min$$0 - | bin_pred (w$$1) = w $$$ 0 - | bin_pred (w$$0) = bin_pred(w) $$ 1; - -(*Sum of two binary integers in normal form. - Ensure last $$ preserves normal form! *) -fun bin_add (Pls, w) = w - | bin_add (Min, w) = bin_pred w - | bin_add (v$$x, Pls) = v$$x - | bin_add (v$$x, Min) = bin_pred (v$$x) - | bin_add (v$$x, w$$y) = - bin_add(v, if x+y=2 then bin_succ w else w) $$$ ((x+y) mod 2); - -(*** Subtraction ***) - -(*Unary minus*) -fun bin_minus Pls = Pls - | bin_minus Min = Pls$$1 - | bin_minus (w$$1) = bin_pred (bin_minus(w) $$$ 0) - | bin_minus (w$$0) = bin_minus(w) $$ 0; - -(*** Multiplication ***) - -(*product of two bins; a factor of 0 might cause leading 0s in result*) -fun bin_mult (Pls, _) = Pls - | bin_mult (Min, v) = bin_minus v - | bin_mult (w$$1, v) = bin_add(bin_mult(w,v) $$$ 0, v) - | bin_mult (w$$0, v) = bin_mult(w,v) $$$ 0; - -(*** Testing ***) - -(*tests addition*) -fun checksum m n = - let val wm = binary_of_int m - and wn = binary_of_int n - val wsum = bin_add(wm,wn) - in if m+n = int_of_binary wsum then (wm, wn, wsum, m+n) - else raise Match - end; - -fun bfact n = if n=0 then Pls$$1 - else bin_mult(binary_of_int n, bfact(n-1)); - -(*Examples... -bfact 5; -int_of_binary it; -bfact 69; -int_of_binary it; - -(*For {HOL,ZF}/ex/BinEx.ML*) -bin_add(binary_of_int 13, binary_of_int 19); -bin_add(binary_of_int 1234, binary_of_int 5678); -bin_add(binary_of_int 1359, binary_of_int ~2468); -bin_add(binary_of_int 93746, binary_of_int ~46375); -bin_minus(binary_of_int 65745); -bin_minus(binary_of_int ~54321); -bin_mult(binary_of_int 13, binary_of_int 19); -bin_mult(binary_of_int ~84, binary_of_int 51); -bin_mult(binary_of_int 255, binary_of_int 255); -bin_mult(binary_of_int 1359, binary_of_int ~2468); - - -(*leading zeros??*) -bin_add(binary_of_int 1234, binary_of_int ~1234); -bin_mult(binary_of_int 1234, Pls); - -(*leading ones??*) -bin_add(binary_of_int 1, binary_of_int ~2); -bin_add(binary_of_int 1234, binary_of_int ~1235); -*) diff -r 1b6035697c49 -r be9815d02b10 src/ZF/Tools/typechk.ML --- a/src/ZF/Tools/typechk.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/Tools/typechk.ML Wed Aug 27 15:52:58 2014 +0200 @@ -115,8 +115,8 @@ val typecheck_setup = Method.setup @{binding typecheck} (Method.sections - [Args.add -- Args.colon >> K (I, TC_add), - Args.del -- Args.colon >> K (I, TC_del)] + [Args.add -- Args.colon >> K (Method.modifier TC_add @{here}), + Args.del -- Args.colon >> K (Method.modifier TC_del @{here})] >> K (fn ctxt => SIMPLE_METHOD (CHANGED (typecheck_tac ctxt)))) "ZF type-checking"; diff -r 1b6035697c49 -r be9815d02b10 src/ZF/UNITY/Constrains.thy --- a/src/ZF/UNITY/Constrains.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/UNITY/Constrains.thy Wed Aug 27 15:52:58 2014 +0200 @@ -453,6 +453,9 @@ used by Always_Int_I) *) lemmas Always_thin = thin_rl [of "F \ Always(A)"] +(*To allow expansion of the program's definition when appropriate*) +named_theorems program "program definitions" + ML {* (*Combines two invariance ASSUMPTIONS into one. USEFUL??*) @@ -461,13 +464,6 @@ (*Combines a list of invariance THEOREMS into one.*) val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I}); -(*To allow expansion of the program's definition when appropriate*) -structure Program_Defs = Named_Thms -( - val name = @{binding program} - val description = "program definitions" -); - (*proves "co" properties when the program is specified*) fun constrains_tac ctxt = @@ -481,7 +477,7 @@ (* Three subgoals *) rewrite_goal_tac ctxt [@{thm st_set_def}] 3, REPEAT (force_tac ctxt 2), - full_simp_tac (ctxt addsimps (Program_Defs.get ctxt)) 1, + full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 1, ALLGOALS (clarify_tac ctxt), REPEAT (FIRSTGOAL (etac @{thm disjE})), ALLGOALS (clarify_tac ctxt), @@ -495,8 +491,6 @@ rtac @{thm AlwaysI} i THEN force_tac ctxt i THEN constrains_tac ctxt i; *} -setup Program_Defs.setup - method_setup safety = {* Scan.succeed (SIMPLE_METHOD' o constrains_tac) *} "for proving safety properties" diff -r 1b6035697c49 -r be9815d02b10 src/ZF/UNITY/SubstAx.thy --- a/src/ZF/UNITY/SubstAx.thy Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/UNITY/SubstAx.thy Wed Aug 27 15:52:58 2014 +0200 @@ -358,7 +358,7 @@ REPEAT (ares_tac [@{thm LeadsTo_Basis}, @{thm leadsTo_Basis}, @{thm EnsuresI}, @{thm ensuresI}] 1), (*now there are two subgoals: co & transient*) - simp_tac (ctxt addsimps (Program_Defs.get ctxt)) 2, + simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 2, res_inst_tac ctxt [(("act", 0), sact)] @{thm transientI} 2, (*simplify the command's domain*) simp_tac (ctxt addsimps [@{thm domain_def}]) 3, diff -r 1b6035697c49 -r be9815d02b10 src/ZF/int_arith.ML --- a/src/ZF/int_arith.ML Wed Aug 27 11:33:00 2014 +0200 +++ b/src/ZF/int_arith.ML Wed Aug 27 15:52:58 2014 +0200 @@ -151,7 +151,7 @@ structure CancelNumeralsCommon = struct - val mk_sum = (fn T:typ => mk_sum) + val mk_sum = (fn _ : typ => mk_sum) val dest_sum = dest_sum val mk_coeff = mk_coeff val dest_coeff = dest_coeff 1 @@ -236,7 +236,7 @@ type coeff = int val iszero = (fn x => x = 0) val add = op + - val mk_sum = (fn T:typ => long_mk_sum) (*to work for #2*x $+ #3*x *) + val mk_sum = (fn _ : typ => long_mk_sum) (*to work for #2*x $+ #3*x *) val dest_sum = dest_sum val mk_coeff = mk_coeff val dest_coeff = dest_coeff 1 @@ -284,7 +284,7 @@ type coeff = int val iszero = (fn x => x = 0) val add = op * - val mk_sum = (fn T:typ => mk_prod) + val mk_sum = (fn _ : typ => mk_prod) val dest_sum = dest_prod fun mk_coeff(k,t) = if t=one then mk_numeral k else raise TERM("mk_coeff", [])