diff options
67 files changed, 2756 insertions, 2010 deletions
diff --git a/dev/bench/render_results b/dev/bench/render_results index 72affd70b2..bd4308837b 100755 --- a/dev/bench/render_results +++ b/dev/bench/render_results @@ -76,25 +76,13 @@ let run_and_read cmd = ;; let ( %> ) f g x = g (f x) -;; let run = run_and_read %> snd -;; module Float = struct let nan = Pervasives.nan end -module Tuple4 = struct - - let first (x,_,_,_) = x - let second (_,y,_,_) = y - let third (_,_,z,_) = z - let fourth (_,_,_,z) = z - -end -;; - module List = struct include List @@ -149,6 +137,151 @@ module String = struct end ;; +module Table : +sig + type header = string + type row = string list list + val print : header list -> row list -> string +end = +struct + type header = string + + type row = string list list + + let val_padding = 2 + (* Padding between data in the same row *) + let row_padding = 1 + (* Padding between rows *) + + let homogeneous b = if b then () else failwith "Heterogeneous data" + + let vert_split (ls : 'a list list) = + let split l = match l with + | [] -> failwith "vert_split" + | x :: l -> (x, l) + in + let ls = List.map split ls in + List.split ls + + let rec last = function + | [] -> assert false + | [x] -> [], x + | x :: l -> + let (l, y) = last l in + (x :: l, y) + + let justify n s = + let len = String.length s in + let () = assert (len <= n) in + let lft = (n - len) / 2 in + let rgt = n - lft - len in + String.make lft ' ' ^ s ^ String.make rgt ' ' + + let justify_row layout data = + let map n s = + let len = String.length s in + let () = assert (len <= n) in + (* Right align *) + let pad = n - len in + String.make pad ' ' ^ s + in + let data = List.map2 map layout data in + String.concat (String.make val_padding ' ') data + + let angle hkind vkind = match hkind, vkind with + | `Lft, `Top -> "┌" + | `Rgt, `Top -> "┐" + | `Mid, `Top -> "┬" + | `Lft, `Mid -> "├" + | `Rgt, `Mid -> "┤" + | `Mid, `Mid -> "┼" + | `Lft, `Bot -> "└" + | `Rgt, `Bot -> "┘" + | `Mid, `Bot -> "┴" + + let print_separator vkind col_size = + let rec dashes n = if n = 0 then "" else "─" ^ dashes (n - 1) in + let len = List.length col_size in + let pad = dashes row_padding in + let () = assert (0 < len) in + let map n = dashes n in + angle `Lft vkind ^ pad ^ + String.concat (pad ^ angle `Mid vkind ^ pad) (List.map map col_size) ^ + pad ^ angle `Rgt vkind + + let print_blank col_size = + let len = List.length col_size in + let () = assert (0 < len) in + let pad = String.make row_padding ' ' in + let map n = String.make n ' ' in + "│" ^ pad ^ String.concat (pad ^ "│" ^ pad) (List.map map col_size) ^ pad ^ "│" + + let print_row row = + let len = List.length row in + let () = assert (0 < len) in + let pad = String.make row_padding ' ' in + "│" ^ pad ^ String.concat (pad ^ "│" ^ pad) row ^ pad ^ "│" + + (* Invariant : all rows must have the same shape *) + + let print (headers : header list) (rows : row list) = + (* Sanitize input *) + let ncolums = List.length headers in + let shape = ref None in + let check row = + let () = homogeneous (List.length row = ncolums) in + let rshape : int list = List.map (fun data -> List.length data) row in + match !shape with + | None -> shape := Some rshape + | Some s -> homogeneous (rshape = s) + in + let () = List.iter check rows in + (* Compute layout *) + let rec layout n (rows : row list) = + if n = 0 then [] + else + let (col, rows) = vert_split rows in + let ans = layout (n - 1) rows in + let data = ref None in + let iter args = + let size = List.map String.length args in + match !data with + | None -> data := Some size + | Some s -> + data := Some (List.map2 (fun len1 len2 -> max len1 len2) s size) + in + let () = List.iter iter col in + let data = match !data with None -> [] | Some s -> s in + data :: ans + in + let layout = layout ncolums rows in + let map hd shape = + let data_size = match shape with + | [] -> 0 + | n :: shape -> List.fold_left (fun accu n -> accu + n + val_padding) n shape + in + max (String.length hd) data_size + in + let col_size = List.map2 map headers layout in + (* Justify the data *) + let headers = List.map2 justify col_size headers in + let rows = List.map (fun row -> List.map2 justify col_size (List.map2 justify_row layout row)) rows in + (* Print the table *) + let rows, last = last rows in + let sep = print_separator `Mid col_size in + let rows = List.concat @@ List.map (fun r -> [print_row r; sep]) rows in + let lines = + print_separator `Top col_size :: + print_row headers :: + print_blank col_size :: + rows @ + print_row last :: + print_separator `Bot col_size :: + [] + in + String.concat "\n" lines +end + (******************************************************************************) (* END Copied from batteries, to remove *) (******************************************************************************) @@ -203,10 +336,6 @@ let proportional_difference_of_integers new_value old_value = else float_of_int (new_value - old_value) /. float_of_int old_value *. 100.0 in -let count_number_of_digits_before_decimal_point = - log10 %> floor %> int_of_float %> succ %> max 1 -in - (* parse the *.time and *.perf files *) coq_opam_packages |> List.map @@ -259,138 +388,39 @@ coq_opam_packages (* Below we take the measurements and format them to stdout. *) +|> List.map begin fun (package_name, new_t, old_t, perc) -> + + let precision = 2 in + let prf f = Printf.sprintf "%.*f" precision f in + let pri n = Printf.sprintf "%d" n in + + [ + [ package_name ]; + [ prf new_t.user_time; prf old_t.user_time; prf perc.user_time ]; + [ pri new_t.num_cycles; pri old_t.num_cycles; prf perc.num_cycles ]; + [ pri new_t.num_instr; pri old_t.num_instr; prf perc.num_instr ]; + [ pri new_t.num_mem; pri old_t.num_mem; prf perc.num_mem ]; + [ pri new_t.num_faults; pri old_t.num_faults; prf perc.num_faults ]; + ] + + end + |> fun measurements -> - let precision = 2 in - - (* the labels that we will print *) - let package_name__label = "package_name" in - let new__label = "NEW" in - let old__label = "OLD" in - let proportional_difference__label = "PDIFF" in - - (* the lengths of labels that we will print *) - let new__label__length = String.length new__label in - let proportional_difference__label__length = String.length proportional_difference__label in - - (* widths of individual columns of the table *) - let package_name__width = - max (measurements |> List.map (Tuple4.first %> String.length) |> List.max) - (String.length package_name__label) in - - let llf proj = - let lls = count_number_of_digits_before_decimal_point (List.max proj) + 1 + precision in - max lls new__label__length in - - let lli proj = - let lls = count_number_of_digits_before_decimal_point (float_of_int (List.(max proj))) + 1 + precision in - max lls new__label__length in - - let new_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.second measurements in - let old_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.third measurements in - - let llp proj = - let lls = - count_number_of_digits_before_decimal_point List.(max List.(map abs_float proj)) + 2 + precision in - max lls proportional_difference__label__length in - - let perc_timing_width = reduce_pkg_timings llp llp @@ List.map Tuple4.fourth measurements in - - (* print the table *) - let rec make_dashes = function - | 0 -> "" - | count -> "─" ^ make_dashes (pred count) - in - - let vertical_separator left_glyph middle_glyph right_glyph = - sprintf "%s─%s─%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s\n" - left_glyph - (make_dashes package_name__width) - middle_glyph - (make_dashes new_timing_width.user_time) - (make_dashes old_timing_width.user_time) - (make_dashes perc_timing_width.user_time) - middle_glyph - (make_dashes new_timing_width.num_cycles) - (make_dashes old_timing_width.num_cycles) - (make_dashes perc_timing_width.num_cycles) - middle_glyph - (make_dashes new_timing_width.num_instr) - (make_dashes old_timing_width.num_instr) - (make_dashes perc_timing_width.num_instr) - middle_glyph - (make_dashes new_timing_width.num_mem) - (make_dashes old_timing_width.num_mem) - (make_dashes perc_timing_width.num_mem) - middle_glyph - (make_dashes new_timing_width.num_faults) - (make_dashes old_timing_width.num_faults) - (make_dashes perc_timing_width.num_faults) - right_glyph - in - - let center_string string width = - let string_length = String.length string in - let width = max width string_length in - let left_hfill = (width - string_length) / 2 in - let right_hfill = width - left_hfill - string_length in - String.make left_hfill ' ' ^ string ^ String.make right_hfill ' ' - in - printf "\n"; - print_string (vertical_separator "┌" "┬" "┐"); - "│" ^ String.make (1 + package_name__width + 1) ' ' ^ "│" - ^ center_string "user time [s]" (1 + new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) ^ "│" - ^ center_string "CPU cycles" (1 + new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) ^ "│" - ^ center_string "CPU instructions" (1 + new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) ^ "│" - ^ center_string "max resident mem [KB]" (1 + new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) ^ "│" - ^ center_string "mem faults" (1 + new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) - ^ "│\n" |> print_string; - printf "│%*s │ %*s│ %*s│ %*s│ %*s│ %*s│\n" - (1 + package_name__width) "" - (new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) "" - (new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) "" - (new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) "" - (new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) "" - (new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) ""; - printf "│ %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │\n" - package_name__width package_name__label - new_timing_width.user_time new__label - old_timing_width.user_time old__label - perc_timing_width.user_time proportional_difference__label - new_timing_width.num_cycles new__label - old_timing_width.num_cycles old__label - perc_timing_width.num_cycles proportional_difference__label - new_timing_width.num_instr new__label - old_timing_width.num_instr old__label - perc_timing_width.num_instr proportional_difference__label - new_timing_width.num_mem new__label - old_timing_width.num_mem old__label - perc_timing_width.num_mem proportional_difference__label - new_timing_width.num_faults new__label - old_timing_width.num_faults old__label - perc_timing_width.num_faults proportional_difference__label; - measurements |> List.iter - (fun (package_name, new_t, old_t, perc) -> - print_string (vertical_separator "├" "┼" "┤"); - printf "│ %*s │ %*.*f %*.*f %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │\n" - package_name__width package_name - new_timing_width.user_time precision new_t.user_time - old_timing_width.user_time precision old_t.user_time - perc_timing_width.user_time precision perc.user_time - new_timing_width.num_cycles new_t.num_cycles - old_timing_width.num_cycles old_t.num_cycles - perc_timing_width.num_cycles precision perc.num_cycles - new_timing_width.num_instr new_t.num_instr - old_timing_width.num_instr old_t.num_instr - perc_timing_width.num_instr precision perc.num_instr - new_timing_width.num_mem new_t.num_mem - old_timing_width.num_mem old_t.num_mem - perc_timing_width.num_mem precision perc.num_mem - new_timing_width.num_faults new_t.num_faults - old_timing_width.num_faults old_t.num_faults - perc_timing_width.num_faults precision perc.num_faults); - -print_string (vertical_separator "└" "┴" "┘"); + let headers = [ + ""; + "user time [s]"; + "CPU cycles"; + "CPU instructions"; + "max resident mem [KB]"; + "mem faults"; + ] in + + let descr = ["NEW"; "OLD"; "PDIFF"] in + let top = [ [ "package_name" ]; descr; descr; descr; descr; descr ] in + + printf "%s%!" (Table.print headers (top :: measurements)) +; (* ejgallego: disable this as it is very verbose and brings up little info in the log. *) if false then begin diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 2e8a7455de..7701264ad1 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -9,10 +9,10 @@ CODE=0 -if [[ $(git log -n 1 --pretty='format:%s') == "Bot merge"* ]]; then - # The FIRST parent of bot merges is from the PR, the second is +if [[ $(git log -n 1 --pretty='format:%s') == "[CI merge]"* ]]; then + # The second parent of bot merges is from the PR, the first is # current master - head=$(git rev-parse HEAD~) + head=$(git rev-parse HEAD^2) else head=$(git rev-parse HEAD) fi diff --git a/doc/changelog/04-tactics/13381-bfs_eauto.rst b/doc/changelog/04-tactics/13381-bfs_eauto.rst index f37fbfe52b..e63241e46c 100644 --- a/doc/changelog/04-tactics/13381-bfs_eauto.rst +++ b/doc/changelog/04-tactics/13381-bfs_eauto.rst @@ -1,6 +1,6 @@ - **Deprecated:** - Undocumented :n:`eauto @int_or_var @int_or_var` syntax in favor of new ``bfs eauto``. - Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``. - (Use ``bfs eauto`` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) + Undocumented :n:`eauto @nat_or_var @nat_or_var` syntax in favor of new :tacn:`bfs eauto`. + Also deprecated 2-integer syntax for :tacn:`debug eauto` and :tacn:`info_eauto`. + (Use :tacn:`bfs eauto` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) (`#13381 <https://github.com/coq/coq/pull/13381>`_, by Jim Fehrle). diff --git a/doc/changelog/06-ssreflect/13459-ssr_dup_swap_apply_ipat.rst b/doc/changelog/06-ssreflect/13459-ssr_dup_swap_apply_ipat.rst new file mode 100644 index 0000000000..e14ae89219 --- /dev/null +++ b/doc/changelog/06-ssreflect/13459-ssr_dup_swap_apply_ipat.rst @@ -0,0 +1,4 @@ +- **Fixed:** + Working around a bug of interaction between + and /(ltac:(...)) cf #13458 + (`#13459 <https://github.com/coq/coq/pull/13459>`_, + by Cyril Cohen). diff --git a/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst b/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst new file mode 100644 index 0000000000..9ed013245e --- /dev/null +++ b/doc/changelog/12-misc/13405-less-wrong-micromega-cache.rst @@ -0,0 +1,6 @@ +- **Changed:** + The representation of micromega caches was slightly + altered for efficiency purposes. As a consequence + all stale caches must be cleaned up + (`#13405 <https://github.com/coq/coq/pull/13405>`_, + by Pierre-Marie Pédrot). diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 27ae7cea3a..039a23e8c2 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -535,11 +535,19 @@ pass additional arguments such as ``using relation``. .. tacn:: setoid_reflexivity setoid_symmetry {? in @ident } setoid_transitivity @one_term - setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } {? at @occurrences } {? in @ident } - setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } in @ident at @occurrences + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } {? at @rewrite_occs } {? in @ident } + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } in @ident at @rewrite_occs setoid_replace @one_term with @one_term {? using relation @one_term } {? in @ident } {? at {+ @int_or_var } } {? by @ltac_expr3 } :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; _; setoid_replace + .. todo: move rewrite_occs to rewrite chapter when that chapter is revised + + .. insertprodn rewrite_occs rewrite_occs + + .. prodn:: + rewrite_occs ::= {+ @integer } + | @ident + The ``using relation`` arguments cannot be passed to the unprefixed form. The latter argument tells the tactic what parametric relation should be used to replace the first tactic argument with the second one. If @@ -714,6 +722,8 @@ instances are tried at each node of the search tree). To speed it up, declare your constant as rigid for proof search using the command :cmd:`Typeclasses Opaque`. +.. _strategies4rewriting: + Strategies for rewriting ------------------------ diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 98445fca1a..4143d836c4 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -335,12 +335,6 @@ Summary of the commands .. cmd:: Instance {? @ident_decl {* @binder } } : @type {? @hint_info } {? {| := %{ {* @field_def } %} | := @term } } - .. insertprodn hint_info one_pattern - - .. prodn:: - hint_info ::= %| {? @natural } {? @one_pattern } - one_pattern ::= @one_term - Declares a typeclass instance named :token:`ident_decl` of the class :n:`@type` with the specified parameters and with fields defined by :token:`field_def`, where each field must be a declared field of @@ -503,7 +497,7 @@ Typeclasses Transparent, Typeclasses Opaque It is useful when some constants prevent some unifications and make resolution fail. It is also useful to declare constants which - should never be unfolded during proof-search, like fixpoints or + should never be unfolded during proof search, like fixpoints or anything which does not look like an abbreviation. This can additionally speed up proof search as the typeclass map can be indexed by such rigid constants (see @@ -555,7 +549,7 @@ Settings This can be expensive as it requires rebuilding hint clauses dynamically, and does not benefit from the invertibility status of the product introduction rule, resulting in potentially more - expensive proof-search (i.e. more useless backtracking). + expensive proof search (i.e. more useless backtracking). .. flag:: Typeclass Resolution For Conversion diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 4615a8dfca..bb78b142ca 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -412,7 +412,7 @@ Explicit Universes | _ | @qualid univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} - cumul_univ_decl ::= @%{ {* {? {| = | + | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} + cumul_univ_decl ::= @%{ {* {? {| + | = | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} univ_constraint ::= @universe_name {| < | = | <= } @universe_name The syntax has been extended to allow users to explicitly bind names diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 24fa71059c..249c7794be 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -551,7 +551,7 @@ Flags, options and attributes ``Private`` (`#11665 <https://github.com/coq/coq/pull/11665>`_, by Théo Zimmermann). - **Added:** - The :cmd:`Hint` commands now accept the :attr:`export` locality as + The :ref:`Hint <creating_hints>` commands now accept the :attr:`export` locality as an attribute, allowing to make import-scoped hints (`#11812 <https://github.com/coq/coq/pull/11812>`_, by Pierre-Marie Pédrot). @@ -3170,7 +3170,7 @@ Vernacular Commands `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` - New `Set Hint Variables/Constants Opaque/Transparent` commands for setting globally the opacity flag of variables and constants in hint databases, - overwriting the opacity set of the hint database. + overriding the opacity setting of the hint database. - Added generic syntax for "attributes", as in: `#[local] Lemma foo : bar.` - Added the `Numeral Notation` command for registering decimal numeral @@ -4045,7 +4045,7 @@ constraints can now be left floating around and be seen by the user thanks to a new option. The Keyed Unification mode has been improved by Matthieu Sozeau. -The typeclass resolution engine and associated proof-search tactic have +The typeclass resolution engine and associated proof search tactic have been reimplemented on top of the proof-engine monad, providing better integration in tactics, and new options have been introduced to control it, by Matthieu Sozeau with help from Théo Zimmermann. @@ -5140,7 +5140,7 @@ Program - Hints costs are now correctly taken into account (potential source of incompatibilities). - Documented the Hint Cut command that allows control of the - proof-search during typeclass resolution (see reference manual). + proof search during typeclass resolution (see reference manual). API @@ -5776,7 +5776,7 @@ Libraries comes first. By default, the power function now takes two BigN. - Creation of Vector, an independent library for lists indexed by their length. - Vectors' names overwrite lists' one so you should not "Import" the library. + Vectors' names override lists' one so you should not "Import" the library. All old names changed: function names follow the ocaml ones and, for example, Vcons becomes Vector.cons. You can get [..;..;..]-style notations by importing Vector.VectorNotations. @@ -6830,7 +6830,7 @@ Tactics - Tactic "remember" now supports an "in" clause to remember only selected occurrences of a term. -- Tactic "pose proof" supports name overwriting in case of specialization of an +- Tactic "pose proof" supports name overriding in case of specialization of an hypothesis. - Semi-decision tactic "jp" for first-order intuitionistic logic moved to user diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index af5d1e3a00..246568d3c1 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -188,10 +188,8 @@ nitpick_ignore = [ ('token', token) for token in [ 'conversion', 'where', 'oriented_rewriter', - 'hintbases', 'bindings_with_parameters', - 'destruction_arg', - 'clause_dft_concl' + 'destruction_arg' ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 251b5e4955..9fda2ab1fa 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -8,14 +8,13 @@ Inductive types .. cmd:: Inductive @inductive_definition {* with @inductive_definition } - .. insertprodn inductive_definition cumul_ident_decl + .. insertprodn inductive_definition constructor .. prodn:: - inductive_definition ::= {? > } @cumul_ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } + inductive_definition ::= {? > } @ident {? @cumul_univ_decl } {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } constructors_or_record ::= {? %| } {+| @constructor } | {? @ident } %{ {*; @record_field } {? ; } %} constructor ::= @ident {* @binder } {? @of_type } - cumul_ident_decl ::= @ident {? @cumul_univ_decl } This command defines one or more inductive types and its constructors. Coq generates destructors diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 54252689e1..6d96e15202 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -155,7 +155,8 @@ are now available through the dot notation. #. Interactive modules and module types can be nested. #. Interactive modules and module types can't be defined inside of :ref:`sections<section-mechanism>`. Sections can be defined inside of interactive modules and module types. - #. Hints and notations (:cmd:`Hint` and :cmd:`Notation` commands) can also appear inside interactive + #. Hints and notations (the :ref:`Hint <creating_hints>` and :cmd:`Notation` + commands) can also appear inside interactive modules and module types. Note that with module definitions like: :n:`Module @ident__1 : @module_type := @ident__2.` diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index df50dbafe3..75389bb259 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -69,7 +69,8 @@ Sections create local contexts which can be shared across multiple definitions. :undocumented: .. note:: - Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which + Most commands, such as the :ref:`Hint <creating_hints>` commands, + :cmd:`Notation` and option management commands that appear inside a section are canceled when the section is closed. .. cmd:: Let @ident_decl @def_body diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 2fc3c9f748..87a367fc93 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1637,9 +1637,10 @@ Testing boolean expressions: guard .. tacn:: guard @int_or_var @comparison @int_or_var :name: guard - .. insertprodn comparison comparison + .. insertprodn int_or_var comparison .. prodn:: + int_or_var ::= {| @integer | @ident } comparison ::= = | < | <= @@ -1761,7 +1762,7 @@ Defining |Ltac| symbols "Ltac intros := idtac" seems like it redefines/hides an existing tactic, but in fact it creates a tactic which can only be called by its qualified name. This is true in - general of tactic notations. The only way to overwrite most + general of tactic notations. The only way to override most primitive tactics, and any user-defined tactic notation, is with another tactic notation. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index a46f4fb894..375129c02d 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1475,7 +1475,7 @@ Other nonterminals that have syntactic classes are listed here. * - :n:`clause` - :token:`ltac2_clause` - - :token:`clause_dft_concl` + - :token:`occurrences` * - :n:`occurrences` - :token:`q_occurrences` diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 4f01559cad..8f5c045929 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -466,52 +466,82 @@ Examples: .. _occurrencessets: -Occurrence sets and occurrence clauses -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -An occurrence clause is a modifier to some tactics that obeys the -following syntax: - - .. prodn:: - occurrence_clause ::= in @goal_occurrences - goal_occurrences ::= {*, @ident {? @at_occurrences } } {? |- {? * {? @at_occurrences } } } - | * |- {? * {? @at_occurrences } } - | * - at_occurrences ::= at @occurrences - occurrences ::= {? - } {* @natural } - -The role of an occurrence clause is to select a set of occurrences of a term -in a goal. In the first case, the :n:`@ident {? at {* num}}` parts indicate -that occurrences have to be selected in the hypotheses named :token:`ident`. -If no numbers are given for hypothesis :token:`ident`, then all the -occurrences of :token:`term` in the hypothesis are selected. If numbers are -given, they refer to occurrences of :token:`term` when the term is printed -using the :flag:`Printing All` flag, counting from left to right. In particular, -occurrences of :token:`term` in implicit arguments -(see :ref:`ImplicitArguments`) or coercions (see :ref:`Coercions`) are -counted. - -If a minus sign is given between ``at`` and the list of occurrences, it -negates the condition so that the clause denotes all the occurrences -except the ones explicitly mentioned after the minus sign. - -As an exception to the left-to-right order, the occurrences in -the return subexpression of a match are considered *before* the -occurrences in the matched term. - -In the second case, the ``*`` on the left of ``|-`` means that all occurrences -of term are selected in every hypothesis. - -In the first and second case, if ``*`` is mentioned on the right of ``|-``, the -occurrences of the conclusion of the goal have to be selected. If some numbers -are given, then only the occurrences denoted by these numbers are selected. If -no numbers are given, all occurrences of :token:`term` in the goal are selected. - -Finally, the last notation is an abbreviation for ``* |- *``. Note also -that ``|-`` is optional in the first case when no ``*`` is given. - -Here are some tactics that understand occurrence clauses: :tacn:`set`, -:tacn:`remember`, :tacn:`induction`, :tacn:`destruct`. +Occurrence clauses +~~~~~~~~~~~~~~~~~~ + +An :gdef:`occurrence` is a subterm of a goal or hypothesis that +matches a pattern provided by a tactic. Occurrence clauses +select a subset of the ocurrences in a goal and/or in +one or more of its hypotheses. + + .. insertprodn occurrences concl_occs + + .. prodn:: + occurrences ::= at @occs_nums + | in @goal_occurrences + occs_nums ::= {? - } {+ @nat_or_var } + nat_or_var ::= {| @natural | @ident } + goal_occurrences ::= {+, @hyp_occs } {? %|- {? @concl_occs } } + | * %|- {? @concl_occs } + | %|- {? @concl_occs } + | {? @concl_occs } + hyp_occs ::= @hypident {? at @occs_nums } + hypident ::= @ident + | ( type of @ident ) + | ( value of @ident ) + concl_occs ::= * {? at @occs_nums } + + :n:`@occurrences` + The first form of :token:`occurrences` selects occurrences in + the conclusion of the goal. The second form can select occurrences + in the goal conclusion and in one or more hypotheses. + + :n:`{? - } {+ @nat_or_var }` + Selects the specified occurrences within a single goal or hypothesis. + Occurrences are numbered from left to right starting with 1 when the + goal is printed with the :flag:`Printing All` flag. (In particular, occurrences + in :ref:`implicit arguments <ImplicitArguments>` and + :ref:`coercions <Coercions>` are counted but not shown by default.) + + Specifying `-` includes all occurrences *except* the ones listed. + + :n:`{*, @hyp_occs } {? %|- {? @concl_occs } }` + Selects occurrences in the specified hypotheses and the + specified occurrences in the conclusion. + + :n:`* %|- {? @concl_occs }` + Selects all occurrences in all hypotheses and the + specified occurrences in the conclusion. + + :n:`%|- {? @concl_occs }` + Selects the specified occurrences in the conclusion. + + :n:`@goal_occurrences ::= {? @concl_occs }` + Selects all occurrences in all hypotheses and in the specified occurrences + in the conclusion. + + :n:`@hypident {? at @occs_nums }` + Omiting :token:`occs_nums` selects all occurrences within the hypothesis. + + :n:`@hypident ::= @ident` + Selects the hypothesis named :token:`ident`. + + :n:`( type of @ident )` + Selects the type part of the named hypothesis (e.g. `: nat`). + + :n:`( value of @ident )` + Selects the value part of the named hypothesis (e.g. `:= 1`). + + :n:`@concl_occs ::= * {? at @occs_nums }` + Selects occurrences in the conclusion. '*' by itself selects all occurrences. + :n:`@occs_nums` selects the specified occurrences. + + Use `in *` to select all occurrences in all hypotheses and the conclusion, + which is equivalent to `in * |- *`. Use `* |-` to select all occurrences + in all hypotheses. + +Tactics that use occurrence clauses include :tacn:`set`, +:tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. .. seealso:: diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 86d1d25745..e7db9cfaca 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1136,7 +1136,7 @@ Controlling the locality of commands Some commands support an :attr:`export` attribute. The effect of the attribute is to make the effect of the command available when the module containing it is imported. It is supported in - particular by the :cmd:`Hint`, :cmd:`Set` and :cmd:`Unset` + particular by the :ref:`Hint <creating_hints>`, :cmd:`Set` and :cmd:`Unset` commands. .. _controlling-typing-flags: diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index cc4ab76502..472df2bd91 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -4,104 +4,87 @@ Programmable proof search ========================= -.. tacn:: auto - :name: auto +.. tacn:: auto {? @nat_or_var } {? @auto_using } {? @hintbases } - This tactic implements a Prolog-like resolution procedure to solve the + .. insertprodn auto_using hintbases + + .. prodn:: + auto_using ::= using {+, @one_term } + hintbases ::= with * + | with {+ @ident } + + Implements a Prolog-like resolution procedure to solve the current goal. It first tries to solve the goal using the :tacn:`assumption` tactic, then it reduces the goal to an atomic one using :tacn:`intros` and introduces the newly generated hypotheses as hints. Then it looks at - the list of tactics associated to the head symbol of the goal and - tries to apply one of them (starting from the tactics with lower - cost). This process is recursively applied to the generated subgoals. + the list of tactics associated with the head symbol of the goal and + tries to apply one of them. Lower cost tactics are tried before higher-cost + tactics. This process is recursively applied to the generated subgoals. - By default, :tacn:`auto` only uses the hypotheses of the current goal and - the hints of the database named ``core``. + :n:`@nat_or_var` + Specifies the maximum search depth. The default is 5. - .. warning:: + :n:`using {+, @one_term }` - :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to - :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will - fail even if applying manually one of the hints would succeed. + Uses lemmas :n:`{+, @one_term }` in addition to hints. If :n:`@one_term` is an + inductive type, the collection of its constructors are added as hints. - .. tacv:: auto @natural + Note that hints passed through the `using` clause are used in the same + way as if they were passed through a hint database. Consequently, + they use a weaker version of :tacn:`apply` and :n:`auto using @one_term` + may fail where :n:`apply @one_term` succeeds. - Forces the search depth to be :token:`natural`. The maximal search depth - is 5 by default. + .. todo + Given that this can be seen as counter-intuitive, it could be useful + to have an option to use full-blown :tacn:`apply` for lemmas passed + through the `using` clause. Contributions welcome! - .. tacv:: auto with {+ @ident} + :n:`with *` + Use all existing hint databases. Using this variant is highly discouraged + in finished scripts since it is both slower and less robust than explicitly + selecting the required databases. - Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. + :n:`with {+ @ident }` + Use the hint databases :n:`{+ @ident}` in addition to the database ``core``. + Use the fake database `nocore` to omit `core`. - .. note:: + If no `with` clause is given, :tacn:`auto` only uses the hypotheses of the + current goal and the hints of the database named ``core``. - Use the fake database `nocore` if you want to *not* use the `core` - database. + :tacn:`auto` generally either completely solves the goal or + leaves it unchanged. Use :tacn:`solve` `[ auto ]` if you want a failure + when they don't solve the goal. :tacn:`auto` will fail if :tacn:`fail` + or :tacn:`gfail` are invoked directly or indirectly, in which case setting + the :flag:`Ltac Debug` may help you debug the failure. - .. tacv:: auto with * + .. warning:: - Uses all existing hint databases. Using this variant is highly discouraged - in finished scripts since it is both slower and less robust than the variant - where the required databases are explicitly listed. + :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to + :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will + fail even if applying manually one of the hints would succeed. .. seealso:: - :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of + :ref:`thehintsdatabasesforautoandeauto` for the list of pre-defined databases and the way to create or extend a database. - .. tacv:: auto using {+ @qualid__i} {? with {+ @ident } } - - Uses lemmas :n:`@qualid__i` in addition to hints. If :n:`@qualid` is an - inductive type, it is the collection of its constructors which are added - as hints. - - .. note:: - - The hints passed through the `using` clause are used in the same - way as if they were passed through a hint database. Consequently, - they use a weaker version of :tacn:`apply` and :n:`auto using @qualid` - may fail where :n:`apply @qualid` succeeds. - - Given that this can be seen as counter-intuitive, it could be useful - to have an option to use full-blown :tacn:`apply` for lemmas passed - through the `using` clause. Contributions welcome! - - .. tacv:: info_auto + .. tacn:: info_auto {? @nat_or_var } {? @auto_using } {? @hintbases } Behaves like :tacn:`auto` but shows the tactics it uses to solve the goal. This variant is very useful for getting a better understanding of automation, or to know what lemmas/assumptions were used. - .. tacv:: debug auto - :name: debug auto + .. tacn:: debug auto {? @nat_or_var } {? @auto_using } {? @hintbases } Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, including failing paths. - .. tacv:: {? info_}auto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} - - This is the most general form, combining the various options. - -.. tacv:: trivial - :name: trivial - - This tactic is a restriction of :tacn:`auto` that is not recursive - and tries only hints that cost `0`. Typically it solves trivial - equalities like :g:`X=X`. - - .. tacv:: trivial with {+ @ident} - trivial with * - trivial using {+ @qualid} - debug trivial - info_trivial - {? info_}trivial {? using {+ @qualid}} {? with {+ @ident}} - :name: _; _; _; debug trivial; info_trivial; _ - :undocumented: +.. tacn:: trivial {? @auto_using } {? @hintbases } + debug trivial {? @auto_using } {? @hintbases } + info_trivial {? @auto_using } {? @hintbases } -.. note:: - :tacn:`auto` and :tacn:`trivial` either solve completely the goal or - else succeed without changing the goal. Use :g:`solve [ auto ]` and - :g:`solve [ trivial ]` if you would prefer these tactics to fail when - they do not manage to solve the goal. + Like :tacn:`auto`, but is not recursive + and only tries hints with zero cost. Typically used to solve goals + for which a lemma is already available in the specified :n:`hintbases`. .. flag:: Info Auto Debug Auto @@ -111,10 +94,9 @@ Programmable proof search These flags enable printing of informative or debug information for the :tacn:`auto` and :tacn:`trivial` tactics. -.. tacn:: eauto - :name: eauto +.. tacn:: eauto {? @nat_or_var } {? @auto_using } {? @hintbases } - This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try + Generalizes :tacn:`auto`. While :tacn:`auto` does not try resolution hints which would leave existential variables in the goal, :tacn:`eauto` does try them (informally speaking, it internally uses a tactic close to :tacn:`simple eapply` instead of a tactic close to :tacn:`simple apply` @@ -133,12 +115,13 @@ Programmable proof search Goal forall P:nat -> Prop, P 0 -> exists n, P n. eauto. - Note that ``ex_intro`` should be declared as a hint. + `ex_intro` is declared as a hint so the proof succeeds. + .. seealso:: :ref:`thehintsdatabasesforautoandeauto` - .. tacv:: {? info_}eauto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} + .. tacn:: info_eauto {? @nat_or_var } {? @auto_using } {? @hintbases } - The various options for :tacn:`eauto` are the same as for :tacn:`auto`. + The various options for :tacn:`info_eauto` are the same as for :tacn:`info_auto`. :tacn:`eauto` also obeys the following flags: @@ -146,34 +129,55 @@ Programmable proof search Debug Eauto :undocumented: - .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + .. tacn:: debug eauto {? @nat_or_var } {? @auto_using } {? @hintbases } + Behaves like :tacn:`eauto` but shows the tactics it tries to solve the goal, + including failing paths. + + .. tacn:: bfs eauto {? @nat_or_var } {? @auto_using } {? @hintbases } + + Like :tacn:`eauto`, but uses a + `breadth-first search <https://en.wikipedia.org/wiki/Breadth-first_search>`_. -.. tacn:: autounfold with {+ @ident} - :name: autounfold +.. tacn:: autounfold {? @hintbases } {? @occurrences } - This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` + Unfolds constants that were declared through a :cmd:`Hint Unfold` in the given databases. -.. tacv:: autounfold with {+ @ident} in @goal_occurrences + :n:`@occurrences` + Performs the unfolding in the specified occurrences. The :n:`at @occs_nums` + clause of :n:`@occurrences` is not supported. + +.. tacn:: autorewrite {? * } with {+ @ident } {? @occurrences } {? using @ltac_expr } + + `*` + If present, rewrite all occurrences whose side conditions are solved. - Performs the unfolding in the given clause (:token:`goal_occurrences`). + .. todo: This may not always work as described, see #4976 #7672 and + https://github.com/coq/coq/issues/1933#issuecomment-337497938 as + mentioned here: https://github.com/coq/coq/pull/13343#discussion_r527801604 -.. tacv:: autounfold with * + :n:`with {+ @ident }` + Specifies the rewriting rule bases to use. - Uses the unfold hints declared in all the hint databases. + :n:`@occurrences` + Performs rewriting in the specified occurrences. Note: the `at` clause + is currently not supported. -.. tacn:: autorewrite with {+ @ident} - :name: autorewrite + .. exn:: The "at" syntax isn't available yet for the autorewrite tactic. - This tactic carries out rewritings according to the rewriting rule - bases :n:`{+ @ident}`. + Appears when there is an `at` clause on the conclusion. - Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until + :n:`using @ltac_expr` + :token:`ltac_expr` is applied to the main subgoal after each rewriting step. + + Applies rewritings according to the rewriting rule bases :n:`{+ @ident }`. + + For each rule base, applies each rewriting to the main subgoal until it fails. Once all the rules have been processed, if the main subgoal has - progressed (e.g., if it is distinct from the initial main goal) then the rules - of this base are processed again. If the main subgoal has not progressed then - the next base is processed. For the bases, the behavior is exactly similar to + changed then the rules + of this base are processed again. If the main subgoal has not changed then + the next base is processed. For the bases, the behavior is very similar to the processing of the rewriting rules. The rewriting rule bases are built with the :cmd:`Hint Rewrite` @@ -183,31 +187,13 @@ Programmable proof search This tactic may loop if you build non terminating rewriting systems. -.. tacv:: autorewrite with {+ @ident} using @tactic - - Performs, in the same way, all the rewritings of the bases :n:`{+ @ident}` - applying tactic to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @qualid - - Performs all the rewritings in hypothesis :n:`@qualid`. - -.. tacv:: autorewrite with {+ @ident} in @qualid using @tactic - - Performs all the rewritings in hypothesis :n:`@qualid` applying :n:`@tactic` - to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @goal_occurrences - - Performs all the rewriting in the clause :n:`@goal_occurrences`. - .. seealso:: - :ref:`Hint-Rewrite <hintrewrite>` for feeding the database of lemmas used by + :cmd:`Hint Rewrite` for feeding the database of lemmas used by :tacn:`autorewrite` and :tacn:`autorewrite` for examples showing the use of this tactic. + Also see :ref:`strategies4rewriting`. .. tacn:: easy - :name: easy This tactic tries to solve the current goal by a number of standard closing steps. In particular, it tries to close the current goal using the closing tactics @@ -220,45 +206,43 @@ Programmable proof search This tactic solves goals that belong to many common classes; in particular, many cases of unsatisfiable hypotheses, and simple equality goals are usually solved by this tactic. -.. tacv:: now @tactic - :name: now +.. tacn:: now @ltac_expr Run :n:`@tactic` followed by :tacn:`easy`. This is a notation for :n:`@tactic; easy`. -Controlling automation --------------------------- - .. _thehintsdatabasesforautoandeauto: The hints databases for auto and eauto -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-------------------------------------- The hints for :tacn:`auto` and :tacn:`eauto` are stored in databases. Each database -maps head symbols to a list of hints. - -.. cmd:: Print Hint @ident +maps head symbols to a list of hints. Use the :cmd:`Print Hint` command to view +the database. - Use this command - to display the hints associated to the head symbol :n:`@ident` - (see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative - integer, and an optional pattern. The hints with lower cost are tried first. A - hint is tried by :tacn:`auto` when the conclusion of the current goal matches its - pattern or when it has no pattern. +Each hint has a cost that is a nonnegative +integer and an optional pattern. Hints with lower costs are tried first. +:tacn:`auto` tries a hint when the conclusion of the current goal matches its +pattern or when the hint has no pattern. Creating Hint databases -``````````````````````` +----------------------- -One can optionally declare a hint database using the command -:cmd:`Create HintDb`. If a hint is added to an unknown database, it will be -automatically created. +Hint databases can be created with the :cmd:`Create HintDb` command or implicitly +by adding a hint to an unknown database. We recommend you always use :cmd:`Create HintDb` +and then imediately use :cmd:`Hint Constants` and :cmd:`Hint Variables` to make +those settings explicit. -.. cmd:: Create HintDb @ident {? discriminated} +Note that the default transparency +settings differ between these two methods of creation. Databases created with +:cmd:`Create HintDb` have the default setting `Transparent` for both `Variables` +and `Constants`, while implicitly created databases have the `Opaque` setting. - This command creates a new database named :n:`@ident`. The database is +.. cmd:: Create HintDb @ident {? discriminated } + + Creates a new hint database named :n:`@ident`. The database is implemented by a Discrimination Tree (DT) that serves as an index of all the lemmas. The DT can use transparency information to decide if a constant should be indexed or not - (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), making the retrieval more efficient. The legacy implementation (the default one for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` goals), for non-Immediate hints and does not make use of transparency @@ -270,149 +254,144 @@ automatically created. from the order in which they were inserted, making this implementation observationally different from the legacy one. -.. cmd:: Hint @hint_definition : {+ @ident} +.. _creating_hints: + +Creating Hints +-------------- - The general command to add a hint to some databases :n:`{+ @ident}`. + The various `Hint` commands share these elements: - This command supports the :attr:`local`, :attr:`global` and :attr:`export` - locality attributes. When no locality is explictly given, the - command is :attr:`local` inside a section and :attr:`global` otherwise. + :n:`{? : {+ @ident } }` specifies the hint database(s) to add to. + *(Deprecated since version 8.10:* If no :token:`ident`\s + are given, the hint is added to the `core` database.) + + Outside of sections, these commands support the :attr:`local`, :attr:`export` + and :attr:`global` attributes. :attr:`global` is the default. Inside sections, + only the :attr:`local` attribute is supported because hints are local to sections. + :attr:`local` hints are never visible from other modules, even if they - require or import the current module. Inside a section, the :attr:`local` - attribute is useless since hints do not survive anyway to the closure of - sections. + :cmd:`Import` or :cmd:`Require` the current module. - + :attr:`export` are visible from other modules when they import the current - module. Requiring it is not enough. + + :attr:`export` hints are visible from other modules when they :cmd:`Import` the current + module, but not when they only :cmd:`Require` it. This attribute is supported by + all `Hint` commands except for :cmd:`Hint Rewrite`. - + :attr:`global` hints are made available by merely requiring the current - module. + + :attr:`global` hints are visible from other modules when they :cmd:`Import` or + :cmd:`Require` the current module. .. deprecated:: 8.13 - The default value for hint locality is scheduled to change in a future + The default value for hint locality will change in a future release. For the time being, adding hints outside of sections without - specifying an explicit locality is therefore triggering a deprecation - warning. It is recommended to use :attr:`export` whenever possible - - The various possible :production:`hint_definition`\s are given below. - - .. cmdv:: Hint @hint_definition + specifying an explicit locality will trigger a deprecation + warning. We recommend you use :attr:`export` whenever possible. - No database name is given: the hint is registered in the ``core`` database. + The `Hint` commands are: - .. deprecated:: 8.10 + .. cmd:: Hint Resolve {+ {| @qualid | @one_term } } {? @hint_info } {? : {+ @ident } } + Hint Resolve {| -> | <- } {+ @qualid } {? @natural } {? : {+ @ident } } + :name: Hint Resolve; _ - .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident - :name: Hint Resolve + .. insertprodn hint_info one_pattern - This command adds :n:`simple apply @qualid` to the hint list with the head - symbol of the type of :n:`@qualid`. The cost of that hint is the number of - subgoals generated by :n:`simple apply @qualid` or :n:`@natural` if specified. The - associated :n:`@pattern` is inferred from the conclusion of the type of - :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type - of :n:`@qualid` does not start with a product the tactic added in the hint list - is :n:`exact @qualid`. In case this type can however be reduced to a type - starting with a product, the tactic :n:`simple apply @qualid` is also stored in - the hints list. If the inferred type of :n:`@qualid` contains a dependent - quantification on a variable which occurs only in the premisses of the type + .. prodn:: + hint_info ::= %| {? @natural } {? @one_pattern } + one_pattern ::= @one_term + + The first form adds each :n:`@qualid` as a hint with the head symbol of the type of + :n:`@qualid` to the specified hint databases (:n:`@ident`\s). The cost of the hint is the number of + subgoals generated by :tacn:`simple apply` :n:`@qualid` or, if specified, :n:`@natural`. The + associated pattern is inferred from the conclusion of the type of + :n:`@qualid` or, if specified, the given :n:`@one_pattern`. + + If the inferred type + of :n:`@qualid` does not start with a product, :tacn:`exact` :n:`@qualid` is added + to the hint list. If the type can be reduced to a type starting with a product, + :tacn:`simple apply` :n:`@qualid` is also added to the hints list. + + If the inferred type of :n:`@qualid` contains a dependent + quantification on a variable which occurs only in the premises of the type and not in its conclusion, no instance could be inferred for the variable by - unification with the goal. In this case, the hint is added to the hint list - of :tacn:`eauto` instead of the hint list of auto and a warning is printed. A - typical example of a hint that is used only by :tacn:`eauto` is a transitivity + unification with the goal. In this case, the hint is only used by + :tacn:`eauto` / :tacn:`typeclasses eauto`, but not by :tacn:`auto`. A + typical hint that would only be used by :tacn:`eauto` is a transitivity lemma. - .. exn:: @qualid cannot be used as a hint - - The head symbol of the type of :n:`@qualid` is a bound variable - such that this tactic cannot be associated to a constant. - - .. cmdv:: Hint Resolve {+ @qualid} : @ident + :n:`{| -> | <- }` + The second form adds the left-to-right (`->`) or right-ot-left implication (`<-`) + of an equivalence as a hint (informally + the hint will be used as, respectively, :tacn:`apply` :n:`-> @qualid` or + :tacn:`apply` :n:`<- @qualid`, + although as mentioned before, the tactic actually used is a restricted version of + :tacn:`apply`). - Adds each :n:`Hint Resolve @qualid`. + :n:`@one_term` + Permits declaring a hint without declaring a new + constant first, but this is not recommended. - .. cmdv:: Hint Resolve -> @qualid : @ident + .. warn:: Declaring arbitrary terms as hints is fragile; it is recommended to declare a toplevel constant instead + :undocumented: - Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @qualid`, although as mentioned - before, the tactic actually used is a restricted version of - :tacn:`apply`). - - .. cmdv:: Hint Resolve <- @qualid + .. exn:: @qualid cannot be used as a hint - Adds the right-to-left implication of an equivalence as a hint. + The head symbol of the type of :n:`@qualid` is a bound variable + such that this tactic cannot be associated to a constant. - .. cmdv:: Hint Immediate @qualid : @ident - :name: Hint Immediate + .. cmd:: Hint Immediate {+ {| @qualid | @one_term } } {? : {+ @ident } } - This command adds :n:`simple apply @qualid; trivial` to the hint list associated - with the head symbol of the type of :n:`@ident` in the given database. This - tactic will fail if all the subgoals generated by :n:`simple apply @qualid` are + Adds :tacn:`simple apply` :n:`@qualid;` :tacn:`trivial` to the hint list for each :n:`@qualid` associated + with the head symbol of the type of :n:`@ident`. This + tactic will fail if all the subgoals generated by :tacn:`simple apply` :n:`@qualid` are not solved immediately by the :tacn:`trivial` tactic (which only tries tactics - with cost 0).This command is useful for theorems such as the symmetry of - equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited - use in order to avoid useless proof-search. The cost of this tactic (which + with cost 0). This command is useful for theorems such as the symmetry of + equality or :g:`n+1=m+1 -> n=m` that we may want to introduce with limited + use in order to avoid useless proof search. The cost of this tactic (which never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` itself. - .. exn:: @qualid cannot be used as a hint - :undocumented: + .. cmd:: Hint Constructors {+ @qualid } {? : {+ @ident } } - .. cmdv:: Hint Immediate {+ @qualid} : @ident - - Adds each :n:`Hint Immediate @qualid`. - - .. cmdv:: Hint Constructors @qualid : @ident - :name: Hint Constructors - - If :token:`qualid` is an inductive type, this command adds all its constructors as + For each :n:`@qualid` that is an inductive type, adds all its constructors as hints of type ``Resolve``. Then, when the conclusion of current goal has the form :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. .. exn:: @qualid is not an inductive type :undocumented: - .. cmdv:: Hint Constructors {+ @qualid} : @ident - - Extends the previous command for several inductive types. + .. cmd:: Hint Unfold {+ @qualid } {? : {+ @ident } } - .. cmdv:: Hint Unfold @qualid : @ident - :name: Hint Unfold - - This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :token:`qualid`. + For each :n:`@qualid`, adds the tactic :tacn:`unfold` :n:`@qualid` to the + hint list that will only be used when the head constant of the goal is :token:`qualid`. Its cost is 4. - .. cmdv:: Hint Unfold {+ @qualid} - - Extends the previous command for several defined constants. - - .. cmdv:: Hint Transparent {+ @qualid} : @ident - Hint Opaque {+ @qualid} : @ident + .. cmd:: Hint {| Transparent | Opaque } {+ @qualid } {? : {+ @ident } } :name: Hint Transparent; Hint Opaque - This adds transparency hints to the database, making :n:`@qualid` - transparent or opaque constants during resolution. This information is used + Adds transparency hints to the database, making each :n:`@qualid` + a transparent or opaque constant during resolution. This information is used during unification of the goal with any lemma in the database and inside the discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident - Hint Constants {| Transparent | Opaque } : @ident - :name: Hint Variables; Hint Constants + .. cmd:: Hint {| Constants | Variables } {| Transparent | Opaque } {? : {+ @ident } } + :name: Hint Constants; Hint Variables - This sets the transparency flag used during unification of - hints in the database for all constants or all variables, - overwriting the existing settings of opacity. It is advised - to use this just after a :cmd:`Create HintDb` command. + Sets the transparency flag for constants or variables for the specified hint + databases. + These flags affect the unification of hints in the database. + We advise using this just after a :cmd:`Create HintDb` command. - .. cmdv:: Hint Extern @natural {? @pattern} => @tactic : @ident - :name: Hint Extern + .. cmd:: Hint Extern @natural {? @one_pattern } => @ltac_expr {? : {+ @ident } } - This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and - :tacn:`unfold`. For that, we must specify a cost, an optional :n:`@pattern` and a - :n:`@tactic` to execute. + Extends :tacn:`auto` with tactics other than :tacn:`apply` and + :tacn:`unfold`. :n:`@natural` is the cost, :n:`@one_term` is the pattern + to match and :n:`@ltac_expr` is the action to apply. + + .. note:: + + Use a :cmd:`Hint Extern` with no pattern to do + pattern matching on hypotheses using ``match goal with`` + inside the tactic. .. example:: @@ -441,80 +420,131 @@ automatically created. .. coqtop:: all Require Import List. - Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. + Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => + generalize X1, X2; decide equality : eqdec. Goal forall a b:list (nat * nat), {a = b} + {a <> b}. - Info 1 auto with eqdec. + info_auto. - .. cmdv:: Hint Cut @regexp : @ident - :name: Hint Cut + .. cmd:: Hint Cut [ @hints_regexp ] {? : {+ @ident } } - .. warning:: - - These hints currently only apply to typeclass proof search and the - :tacn:`typeclasses eauto` tactic. - - This command can be used to cut the proof-search tree according to a regular - expression matching paths to be cut. The grammar for regular expressions is - the following. Beware, there is no operator precedence during parsing, one can - check with :cmd:`Print HintDb` to verify the current cut expression: + .. DISABLED insertprodn hints_regexp hints_regexp .. prodn:: - regexp ::= @ident (hint or instance identifier) + hints_regexp ::= {+ @qualid } (hint or instance identifier) | _ (any hint) - | @regexp | @regexp (disjunction) - | @regexp @regexp (sequence) - | @regexp * (Kleene star) + | @hints_regexp | @hints_regexp (disjunction) + | @hints_regexp @hints_regexp (sequence) + | @hints_regexp * (Kleene star) | emp (empty) | eps (epsilon) - | ( @regexp ) + | ( @hints_regexp ) + + Used to cut the proof search tree according to a regular + expression that matches the paths to be cut. + - The `emp` regexp does not match any search path while `eps` - matches the empty path. During proof search, the path of - successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have + During proof search, the path of + successive successful hints on a search branch is recorded as a + list of identifiers for the hints (note that :cmd:`Hint Extern`\s do not have an associated identifier). - Before applying any hint :n:`@ident` the current path `p` extended with - :n:`@ident` is matched against the current cut expression `c` associated to - the hint database. If matching succeeds, the hint is *not* applied. The - semantics of :n:`Hint Cut @regexp` is to set the cut expression - to :n:`c | regexp`, the initial cut expression being `emp`. - - .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident - :name: Hint Mode - - This sets an optional mode of use of the identifier :n:`@qualid`. When - proof-search faces a goal that ends in an application of :n:`@qualid` to - arguments :n:`@term ... @term`, the mode tells if the hints associated to - :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, + For each hint :n:`@qualid` in the hint database, the current path `p` + extended with :n:`@qualid` + is matched against the current cut expression `c` associated with the + hint database. If the match succeeds the hint is *not* applied. + + :n:`Hint Cut @hints_regexp` sets the cut expression + to :n:`c | @hints_regexp`. The initial cut expression is `emp`. + + The output of :cmd:`Print HintDb` shows the cut expression. + + .. warning:: + + There is no operator precedence during parsing, one can + check with :cmd:`Print HintDb` to verify the current cut expression. + + .. warning:: + + These hints currently only apply to typeclass proof search and the + :tacn:`typeclasses eauto` tactic. + + .. cmd:: Hint Mode @qualid {+ {| + | ! | - } } {? : {+ @ident } } + + Sets an optional mode of use for the identifier :n:`@qualid`. When + proof search has a goal that ends in an application of :n:`@qualid` to + arguments :n:`@arg ... @arg`, the mode tells if the hints associated with + :n:`@qualid` can be applied or not. A mode specification is a list of ``+``, ``!`` or ``-`` items that specify if an argument of the identifier is to be treated as an input (``+``), if its head only is an input (``!``) or an output (``-``) of the identifier. For a mode to match a list of arguments, input terms and input heads *must not* contain existential variables or be - existential variables respectively, while outputs can be any term. Multiple - modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied. The head of a term + existential variables respectively, while outputs can be any term. + + The head of a term is understood here as the applicative head, or the match or projection scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is especially useful for typeclasses, when one does not want to support default instances and avoid ambiguity in general. Setting a parameter of a class as an - input forces proof-search to be driven by that index of the class, with ``!`` - giving more flexibility by allowing existentials to still appear deeper in the - index but not at its head. + input forces proof search to be driven by that index of the class, with ``!`` + allowing existentials to appear in the index but not at its head. .. note:: - + One can use a :cmd:`Hint Extern` with no pattern to do - pattern matching on hypotheses using ``match goal with`` - inside the tactic. + + Multiple modes can be declared for a single identifier. In that + case only one mode needs to match the arguments for the hints to be applied. + If you want to add hints such as :cmd:`Hint Transparent`, :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass resolution, do not forget to put them in the ``typeclass_instances`` hint database. +.. cmd:: Hint Rewrite {? {| -> | <- } } {+ @one_term } {? using @ltac_expr } {? : {* @ident } } + + :n:`{? using @ltac_expr }` + If specified, :n:`@ltac_expr` is applied to the generated subgoals, except for the + main subgoal. + + :n:`{| -> | <- }` + Arrows specify the orientation; left to right (:n:`->`) or right to left (:n:`<-`). + If no arrow is given, the default orientation is left to right (:n:`->`). + + Adds the terms :n:`{+ @one_term }` (their types must be + equalities) to the rewriting bases :n:`{* @ident }`. + Note that the rewriting bases are distinct from the :tacn:`auto` + hint bases and that :tacn:`auto` does not take them into account. + + .. cmd:: Print Rewrite HintDb @ident + + This command displays all rewrite hints contained in :n:`@ident`. + +.. cmd:: Remove Hints {+ @qualid } {? : {+ @ident } } + + Removes the hints associated with the :n:`{+ @qualid }` in databases + :n:`{+ @ident}`. Note: hints created with :cmd:`Hint Extern` currently + can't be removed. The best workaround for this is to make the hints + non global and carefully select which modules you import. + +.. cmd:: Print Hint {? {| * | @reference } } + + :n:`*` + Display all declared hints. + + :n:`@reference` + Display all hints associated with the head symbol :n:`@reference`. + + Displays tactics from the hints list. The default is to show hints that + apply to the conclusion of the current goal. The other forms with :n:`*` + and :n:`@reference` can be used even if no proof is open. + + Each hint has a cost that is a nonnegative + integer and an optional pattern. The hints with lower cost are tried first. + +.. cmd:: Print HintDb @ident + + This command displays all hints from database :n:`@ident`. + Hint databases defined in the Coq standard library -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-------------------------------------------------- Several hint databases are defined in the Coq standard library. The actual content of a database is the collection of hints declared @@ -555,76 +585,8 @@ At Coq startup, only the core database is nonempty and can be used. You are advised not to put your own hints in the core database, but use one or several databases specific to your development. -.. _removehints: - -.. cmd:: Remove Hints {+ @term} : {+ @ident} - - This command removes the hints associated to terms :n:`{+ @term}` in databases - :n:`{+ @ident}`. - -.. _printhint: - -.. cmd:: Print Hint - - This command displays all hints that apply to the current goal. It - fails if no proof is being edited, while the two variants can be used - at every moment. - -**Variants:** - - -.. cmd:: Print Hint @ident - - This command displays only tactics associated with :n:`@ident` in the hints - list. This is independent of the goal being edited, so this command will not - fail if no goal is being edited. - -.. cmd:: Print Hint * - - This command displays all declared hints. - -.. cmd:: Print HintDb @ident - - This command displays all hints from database :n:`@ident`. - -.. _hintrewrite: - -.. cmd:: Hint Rewrite {+ @term} : {+ @ident} - - This vernacular command adds the terms :n:`{+ @term}` (their types must be - equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation - (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` - hint bases and that :tacn:`auto` does not take them into account. - - This command is synchronous with the section mechanism (see :ref:`section-mechanism`): - when closing a section, all aliases created by ``Hint Rewrite`` in that - section are lost. Conversely, when loading a module, all ``Hint Rewrite`` - declarations at the global level of that module are loaded. - -**Variants:** - -.. cmd:: Hint Rewrite -> {+ @term} : {+ @ident} - - This is strictly equivalent to the command above (we only make explicit the - orientation which otherwise defaults to ->). - -.. cmd:: Hint Rewrite <- {+ @term} : {+ @ident} - - Adds the rewriting rules :n:`{+ @term}` with a right-to-left orientation in - the bases :n:`{+ @ident}`. - -.. cmd:: Hint Rewrite {? {| -> | <- } } {+ @one_term } {? using @ltac_expr } {? : {* @ident } } - - When the rewriting rules :n:`{+ @term}` in :n:`{+ @ident}` will be used, the - tactic ``tactic`` will be applied to the generated subgoals, the main subgoal - excluded. - -.. cmd:: Print Rewrite HintDb @ident - - This command displays all rewrite hints contained in :n:`@ident`. - Hint locality -~~~~~~~~~~~~~ +------------- Hints provided by the ``Hint`` commands are erased when closing a section. Conversely, all hints of a module ``A`` that are not defined inside a @@ -649,7 +611,6 @@ option which accepts three flags allowing for a fine-grained handling of non-imported hints. .. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } - :name: Loose Hint Behavior This option accepts three values, which control the behavior of hints w.r.t. :cmd:`Import`: @@ -668,22 +629,12 @@ non-imported hints. .. _tactics-implicit-automation: Setting implicit automation tactics -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +----------------------------------- -.. cmd:: Proof with @tactic +.. cmd:: Proof with @ltac_expr {? using @section_var_expr } - This command may be used to start a proof. It defines a default tactic - to be used each time a tactic command ``tactic``:sub:`1` is ended by ``...``. - In this case the tactic command typed by the user is equivalent to - ``tactic``:sub:`1` ``;tactic``. + Starts a proof in which :token:`ltac_expr` is applied to the active goals + after each tactic that ends with `...` instead of the usual single period. + ":n:`@tactic...`" is equivalent to ":n:`@tactic; @ltac_expr.`". .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. - - - .. cmdv:: Proof with @tactic using {+ @ident} - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - - .. cmdv:: Proof using {+ @ident} with @tactic - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 9ec568c2c7..2de6b2a18c 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -295,21 +295,21 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Performing computations --------------------------- -.. insertprodn red_expr pattern_occ +.. insertprodn red_expr pattern_occs .. prodn:: red_expr ::= red | hnf - | simpl {? @delta_flag } {? @ref_or_pattern_occ } + | simpl {? @delta_flag } {? {| @reference_occs | @pattern_occs } } | cbv {? @strategy_flag } | cbn {? @strategy_flag } | lazy {? @strategy_flag } | compute {? @delta_flag } - | vm_compute {? @ref_or_pattern_occ } - | native_compute {? @ref_or_pattern_occ } - | unfold {+, @unfold_occ } + | vm_compute {? {| @reference_occs | @pattern_occs } } + | native_compute {? {| @reference_occs | @pattern_occs } } + | unfold {+, @reference_occs } | fold {+ @one_term } - | pattern {+, @pattern_occ } + | pattern {+, @pattern_occs } | @ident delta_flag ::= {? - } [ {+ @reference } ] strategy_flag ::= {+ @red_flag } @@ -321,16 +321,8 @@ Performing computations | cofix | zeta | delta {? @delta_flag } - ref_or_pattern_occ ::= @reference {? at @occs_nums } - | @one_term {? at @occs_nums } - occs_nums ::= {+ @nat_or_var } - | - {+ @nat_or_var } - int_or_var ::= @integer - | @ident - nat_or_var ::= @natural - | @ident - unfold_occ ::= @reference {? at @occs_nums } - pattern_occ ::= @one_term {? at @occs_nums } + reference_occs ::= @reference {? at @occs_nums } + pattern_occs ::= @one_term {? at @occs_nums } This set of tactics implements different specialized usages of the tactic :tacn:`change`. @@ -348,17 +340,6 @@ clauses) and are introduced by the keyword `in`. If no goal clause is provided, the default is to perform the conversion only in the conclusion. -The syntax and description of the various goal clauses is the -following: - -+ :n:`in {+ @ident} |-` only in hypotheses :n:`{+ @ident}` -+ :n:`in {+ @ident} |- *` in hypotheses :n:`{+ @ident}` and in the - conclusion -+ :n:`in * |-` in every hypothesis -+ :n:`in *` (equivalent to in :n:`* |- *`) everywhere -+ :n:`in (type of @ident) (value of @ident) ... |-` in type part of - :n:`@ident`, in the value part of :n:`@ident`, etc. - For backward compatibility, the notation :n:`in {+ @ident}` performs the conversion in hypotheses :n:`{+ @ident}`. diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 6c507e1d57..ba5876ff76 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -181,9 +181,6 @@ as a separate production. (Doesn't work recursively; splicing for both `OPTINREF` - applies the local `OPTINREF` edit to every nonterminal -`EXPAND` - expands LIST0, LIST1, LIST* ... SEP and OPT constructs into -new non-terminals - ### Local edits `DELETE <production>` - removes the specified production from the grammar @@ -201,6 +198,9 @@ that appear in the specified production: The current version handles a single USE_NT or ADD_OPT per EDIT. These symbols may appear in the middle of the production given in the EDIT. +`APPENDALL <symbols>` - inserts <symbols> at the end of every production in +<edited_nt>. + `INSERTALL <symbols>` - inserts <symbols> at the beginning of every production in <edited_nt>. @@ -212,10 +212,12 @@ that appear in the specified production: | WITH <newprod> ``` +`COPYALL <destination>` - creates a new nonterminal `<destination>` and copies +all the productions in the nonterminal to `<destination>`. + `MOVETO <destination> <production>` - moves the production to `<destination>` and, if needed, creates a new production <edited_nt> -> \<destination>. - `MOVEALLBUT <destination>` - moves all the productions in the nonterminal to `<destination>` *except* for the productions following the `MOVEALLBUT` production in the edit script (terminated only by the closing `]`). diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 4080eaae08..8efda825de 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -19,8 +19,22 @@ lglob: [ ] hint: [ +| REPLACE "Resolve" "->" LIST1 global OPT natural +| WITH "Resolve" [ "->" | "<-" ] LIST1 global OPT natural +| DELETE "Resolve" "<-" LIST1 global OPT natural +| REPLACE "Variables" "Transparent" +| WITH [ "Constants" | "Variables" ] [ "Transparent" | "Opaque" ] +| DELETE "Variables" "Opaque" +| DELETE "Constants" "Transparent" +| DELETE "Constants" "Opaque" +| REPLACE "Transparent" LIST1 global +| WITH [ "Transparent" | "Opaque" ] LIST1 global +| DELETE "Opaque" LIST1 global + | REPLACE "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic | WITH "Extern" natural OPT constr_pattern "=>" tactic +| INSERTALL "Hint" +| APPENDALL opt_hintbases ] (* todo: does ARGUMENT EXTEND make the symbol global? It is in both extraargs and extratactics *) @@ -149,6 +163,7 @@ DELETE: [ | ensure_fixannot | test_array_opening | test_array_closing +| test_variance_ident (* SSR *) | ssr_null_entry @@ -267,7 +282,7 @@ binder_constr: [ | REPLACE "if" term200 "is" ssr_dthen ssr_else | WITH "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR | DELETE "if" term200 "isn't" ssr_dthen ssr_else -| DELETE "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR (* todo: restore for SSR *) +| DELETE "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR (* todo: restore as "MOVETO term_if" for SSR *) | MOVETO term_fix "let" "fix" fix_decl "in" term200 | MOVETO term_cofix "let" "cofix" cofix_body "in" term200 | MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 @@ -597,6 +612,11 @@ univ_decl: [ | WITH "@{" LIST0 identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] +cumul_univ_decl: [ +| REPLACE "@{" LIST0 variance_identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] +| WITH "@{" LIST0 variance_identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +] + of_type: [ | DELETENT ] @@ -905,12 +925,13 @@ where: [ ] simple_tactic: [ -| DELETE "intros" -| REPLACE "intros" ne_intropatterns -| WITH "intros" intropatterns -| DELETE "eintros" -| REPLACE "eintros" ne_intropatterns -| WITH "eintros" intropatterns +| REPLACE "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "eauto" OPT nat_or_var auto_using hintbases +| REPLACE "debug" "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "debug" "eauto" OPT nat_or_var auto_using hintbases +| REPLACE "info_eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases +| WITH "info_eauto" OPT nat_or_var auto_using hintbases + | DELETE "autorewrite" "with" LIST1 preident clause | DELETE "autorewrite" "with" LIST1 preident clause "using" tactic | DELETE "autorewrite" "*" "with" LIST1 preident clause @@ -966,6 +987,12 @@ simple_tactic: [ | DELETE "intro" "after" hyp | DELETE "intro" "before" hyp | "intro" OPT ident OPT where +| DELETE "intros" +| REPLACE "intros" ne_intropatterns +| WITH "intros" intropatterns +| DELETE "eintros" +| REPLACE "eintros" ne_intropatterns +| WITH "eintros" intropatterns | DELETE "move" hyp "at" "top" | DELETE "move" hyp "at" "bottom" | DELETE "move" hyp "after" hyp @@ -1139,6 +1166,10 @@ printable: [ | REPLACE [ "Sorted" | ] "Universes" OPT printunivs_subgraph OPT ne_string | WITH OPT "Sorted" "Universes" OPT printunivs_subgraph OPT ne_string | DELETE "Term" smart_global OPT univ_name_list (* readded in commands *) +| REPLACE "Hint" +| WITH "Hint" OPT [ "*" | smart_global ] +| DELETE "Hint" smart_global +| DELETE "Hint" "*" | INSERTALL "Print" ] @@ -1163,6 +1194,8 @@ scheme_kind: [ command: [ | REPLACE "Print" printable | WITH printable +| REPLACE "Hint" hint opt_hintbases +| WITH hint | "SubClass" ident_decl def_body | REPLACE "Ltac" LIST1 ltac_tacdef_body SEP "with" | WITH "Ltac" ltac_tacdef_body LIST0 ( "with" ltac_tacdef_body ) @@ -1242,6 +1275,9 @@ command: [ | REPLACE "Preterm" "of" ident | WITH "Preterm" OPT ( "of" ident ) | DELETE "Preterm" +| REPLACE "Proof" "using" section_var_expr "with" Pltac.tactic +| WITH "Proof" "using" section_subset_expr OPT [ "with" ltac_expr5 ] +| DELETE "Proof" "using" section_var_expr (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Remove" IDENT IDENT LIST1 table_value @@ -1441,8 +1477,8 @@ type_cstr: [ ] inductive_definition: [ -| REPLACE opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations -| WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations +| REPLACE opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations +| WITH opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations ] (* note that constructor -> identref constructor_type *) @@ -1578,9 +1614,12 @@ simple_reserv: [ in_clause: [ | DELETE in_clause' -| REPLACE LIST0 hypident_occ SEP "," "|-" concl_occ -| WITH LIST0 hypident_occ SEP "," OPT ( "|-" concl_occ ) -| DELETE LIST0 hypident_occ SEP "," +| REPLACE LIST1 hypident_occ SEP "," "|-" concl_occ +| WITH LIST1 hypident_occ SEP "," OPT ( "|-" concl_occ ) +| DELETE LIST1 hypident_occ SEP "," +| REPLACE "*" occs +| WITH concl_occ +(* todo: perhaps concl_occ should be "*" | "at" occs_nums *) ] ltac2_in_clause: [ @@ -1791,6 +1830,7 @@ tactic_notation_tactics: [ | "field_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) | "field_simplify_eq" OPT ( "[" LIST1 constr "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr5 (* todo: Not too keen on things like "with_power_flags" in tauto.ml, not easy to follow *) +| "now" ltac_expr5 | "nsatz" OPT ( "with" "radicalmax" ":=" constr "strategy" ":=" constr "parameters" ":=" constr "variables" ":=" constr ) | "psatz" constr OPT nat_or_var | "ring" OPT ( "[" LIST1 constr "]" ) @@ -1942,6 +1982,18 @@ tac2rec_fields: [ | LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 ] +int_or_var: [ +| REPLACE integer +| WITH [ integer | identref ] +| DELETE identref +] + +nat_or_var: [ +| REPLACE natural +| WITH [ natural | identref ] +| DELETE identref +] + ltac2_occs_nums: [ | DELETE LIST1 nat_or_anti (* Ltac2 plugin *) | REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) @@ -2387,6 +2439,33 @@ attribute: [ | DELETE "using" OPT attr_value ] +hypident: [ +(* todo: restore for SSR *) +| DELETE "(" "type" "of" ident ")" (* SSR plugin *) +| DELETE "(" "value" "of" ident ")" (* SSR plugin *) +] + +ref_or_pattern_occ: [ +| DELETE smart_global OPT occs +| DELETE constr OPT occs +| unfold_occ +| pattern_occ +] + +clause_dft_concl: [ +(* omit an OPT since clause_dft_concl is always OPT *) +| REPLACE OPT occs +| WITH occs +] + +occs_nums: [ +| EDIT ADD_OPT "-" LIST1 nat_or_var +] + +variance_identref: [ +| EDIT ADD_OPT variance identref +] + SPLICE: [ | clause | noedit_mode @@ -2526,6 +2605,7 @@ SPLICE: [ | eliminator (* todo: splice or not? *) | quoted_attributes (* todo: splice or not? *) | printable +| hint | only_parsing | record_fields | constructor_type @@ -2606,9 +2686,18 @@ SPLICE: [ | syn_level | firstorder_rhs | firstorder_using +| hints_path_atom +| ref_or_pattern_occ +| cumul_ident_decl +| variance +| variance_identref ] (* end SPLICE *) RENAME: [ +| occurrences rewrite_occs +] + +RENAME: [ | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) @@ -2652,6 +2741,13 @@ RENAME: [ | ssrclauses ssr_in | ssrcpat ssrblockpat | constr_pattern one_pattern +| hints_path hints_regexp +| clause_dft_concl occurrences +| in_clause goal_occurrences +| unfold_occ reference_occs +| pattern_occ pattern_occs +| hypident_occ hyp_occs +| concl_occ concl_occs ] simple_tactic: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 92a745c863..dd7990368e 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -527,28 +527,28 @@ let rec edit_SELF nt cur_level next_level right_assoc inner prod = prod -let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) +let autoloaded_mlgs = [ (* productions from other mlgs are marked with TAGs *) "parsing/g_constr.mlg"; "parsing/g_prim.mlg"; - "vernac/g_vernac.mlg"; - "vernac/g_proofs.mlg"; - "toplevel/g_toplevel.mlg"; - "plugins/ltac/extraargs.mlg"; - "plugins/ltac/g_obligations.mlg"; + "plugins/btauto/g_btauto.mlg"; + "plugins/cc/g_congruence.mlg"; + "plugins/firstorder/g_ground.mlg"; "plugins/ltac/coretactics.mlg"; + "plugins/ltac/extraargs.mlg"; "plugins/ltac/extratactics.mlg"; - "plugins/ltac/profile_ltac_tactics.mlg"; "plugins/ltac/g_auto.mlg"; "plugins/ltac/g_class.mlg"; - "plugins/ltac/g_rewrite.mlg"; "plugins/ltac/g_eqdecide.mlg"; - "plugins/ltac/g_tactic.mlg"; "plugins/ltac/g_ltac.mlg"; - "plugins/btauto/g_btauto.mlg"; + "plugins/ltac/g_obligations.mlg"; + "plugins/ltac/g_rewrite.mlg"; + "plugins/ltac/g_tactic.mlg"; + "plugins/ltac/profile_ltac_tactics.mlg"; "plugins/rtauto/g_rtauto.mlg"; - "plugins/cc/g_congruence.mlg"; - "plugins/firstorder/g_ground.mlg"; "plugins/syntax/g_number_string.mlg"; + "toplevel/g_toplevel.mlg"; + "vernac/g_proofs.mlg"; + "vernac/g_vernac.mlg"; ] @@ -1020,7 +1020,7 @@ let rec gen_nt_name sym = good_name name (* create a new nt for LIST* or OPT with the specified name *) -let rec maybe_add_nt g insert_after name sym queue = +let maybe_add_nt g insert_after name sym queue = let empty = [Snterm "empty"] in let maybe_unwrap ?(multi=false) sym = match sym with @@ -1094,65 +1094,6 @@ let rec maybe_add_nt g insert_after name sym queue = end; new_nt -(* expand LIST*, OPT and add "empty" *) -(* todo: doesn't handle recursive expansions well, such as syntax_modifier_opt *) -and expand_rule g edited_nt queue = - let rule = NTMap.find edited_nt !g.map in - let insert_after = ref edited_nt in - let rec expand rule = - let rec aux syms res = - match syms with - | [] -> res - | sym0 :: tl -> - let new_sym = match sym0 with - | Sterm _ - | Snterm _ -> - sym0 - | Slist1 sym - | Slist1sep (sym, _) - | Slist0 sym - | Slist0sep (sym, _) - | Sopt sym -> - let name = gen_nt_name sym in - if name <> "" then begin - let new_nt = maybe_add_nt g insert_after name sym0 queue in - Snterm new_nt - end else sym0 - | Sparen slist -> Sparen (expand slist) - | Sprod slistlist -> - let has_empty = List.length (List.hd (List.rev slistlist)) = 0 in - let name = gen_nt_name sym0 in - if name <> "" then begin - let new_nt = maybe_add_nt g insert_after name - (if has_empty then (Sopt (Sprod (List.rev (List.tl (List.rev slistlist))) )) - else sym0) queue - in - Snterm new_nt - end else - Sprod (List.map expand slistlist) - | Sedit _ - | Sedit2 _ -> - sym0 (* these constructors not used here *) - in - aux tl (new_sym :: res) - in - List.rev (aux rule (if edited_nt <> "empty" && ematch rule [] then [Snterm "empty"] else [])) - in - let rule' = List.map expand rule in - g_update_prods g edited_nt rule' - -let expand_lists g = - (* todo: use Queue.of_seq w OCaml 4.07+ *) - let queue = Queue.create () in - List.iter (fun nt -> Queue.add nt queue) !g.order; - try - while true do - let nt = Queue.pop queue in - expand_rule g nt queue - done - with - | Queue.Empty -> () - let apply_merge g edit_map = List.iter (fun b -> let (from_nt, to_nt) = b in @@ -1213,10 +1154,6 @@ let edit_all_prods g op eprods = global_repl g [(Snterm nt)] [(Sopt (Snterm nt))] end) !g.order; true - | "EXPAND" -> - if List.length eprods > 1 || List.length (List.hd eprods) <> 0 then - error "'EXPAND:' expects a single empty production\n"; - expand_lists g; true | _ -> false let edit_single_prod g edit0 prods nt = @@ -1281,6 +1218,11 @@ let apply_edit_file g edits = with Not_found -> prods in let prods' = moveto nt dest_nt oprod prods in aux tl prods' add_nt + | [Snterm "COPYALL"; Snterm dest_nt] :: tl -> + if NTMap.mem dest_nt !g.map then + error "COPYALL target nonterminal `%s` already exists\n" dest_nt; + g_maybe_add g dest_nt prods; + aux tl prods add_nt | [Snterm "MOVEALLBUT"; Snterm dest_nt] :: tl -> List.iter (fun tlprod -> if not (List.mem tlprod prods) then @@ -1300,6 +1242,8 @@ let apply_edit_file g edits = aux tl (remove_prod [] prods nt) add_nt | (Snterm "INSERTALL" :: syms) :: tl -> aux tl (List.map (fun p -> syms @ p) prods) add_nt + | (Snterm "APPENDALL" :: syms) :: tl -> + aux tl (List.map (fun p -> p @ syms) prods) add_nt | (Snterm "PRINT" :: _) :: tl -> pr_prods nt prods; aux tl prods add_nt @@ -1395,56 +1339,6 @@ let nt_subset_in_orig_order g nts = let subset = StringSet.of_list nts in List.filter (fun nt -> StringSet.mem nt subset) !g.order -let print_chunk out g seen fmt title starts ends = - fprintf out "\n\n%s:\n%s\n" title header; - List.iter (fun start -> - let nts = (nt_closure g start ends) in - print_in_order out g fmt (nt_subset_in_orig_order g nts) !seen; - seen := StringSet.union !seen (StringSet.of_list nts)) - starts - -let print_chunks g out fmt () = - let seen = ref StringSet.empty in - print_chunk out g seen fmt "lconstr" ["lconstr"] ["binder_constr"; "tactic_expr5"]; - print_chunk out g seen fmt "Gallina syntax of terms" ["binder_constr"] ["tactic_expr5"]; - print_chunk out g seen fmt "Gallina The Vernacular" ["gallina"] ["tactic_expr5"]; - print_chunk out g seen fmt "intropattern_list_opt" ["intropattern_list"; "or_and_intropattern_loc"] ["operconstr"; "tactic_expr5"]; - print_chunk out g seen fmt "simple_tactic" ["simple_tactic"] - ["tactic_expr5"; "tactic_expr3"; "tactic_expr2"; "tactic_expr1"; "tactic_expr0"]; - - (*print_chunk out g seen fmt "Ltac" ["tactic_expr5"] [];*) - print_chunk out g seen fmt "Ltac" ["tactic_expr5"] ["tactic_expr4"]; - print_chunk out g seen fmt "Ltac 4" ["tactic_expr4"] ["tactic_expr3"; "tactic_expr2"]; - print_chunk out g seen fmt "Ltac 3" ["tactic_expr3"] ["tactic_expr2"]; - print_chunk out g seen fmt "Ltac 2" ["tactic_expr2"] ["tactic_expr1"]; - print_chunk out g seen fmt "Ltac 1" ["tactic_expr1"] ["tactic_expr0"]; - print_chunk out g seen fmt "Ltac 0" ["tactic_expr0"] []; - - - print_chunk out g seen fmt "command" ["command"] []; - print_chunk out g seen fmt "vernac_toplevel" ["vernac_toplevel"] []; - print_chunk out g seen fmt "vernac_control" ["vernac_control"] [] - - (* - let ssr_tops = ["ssr_dthen"; "ssr_else"; "ssr_mpat"; "ssr_rtype"] in - seen := StringSet.union !seen (StringSet.of_list ssr_tops); - - print_chunk out g seen fmt "ssrindex" ["ssrindex"] []; - print_chunk out g seen fmt "command" ["command"] []; - print_chunk out g seen fmt "binder_constr" ["binder_constr"] []; - (*print_chunk out g seen fmt "closed_binder" ["closed_binder"] [];*) - print_chunk out g seen fmt "gallina_ext" ["gallina_ext"] []; - (*print_chunk out g seen fmt "hloc" ["hloc"] [];*) - (*print_chunk out g seen fmt "hypident" ["hypident"] [];*) - print_chunk out g seen fmt "simple_tactic" ["simple_tactic"] []; - print_chunk out g seen fmt "tactic_expr" ["tactic_expr4"; "tactic_expr1"; "tactic_expr0"] []; - fprintf out "\n\nRemainder:\n"; - print_in_order g (List.filter (fun x -> not (StringSet.mem x !seen)) !g.order) StringSet.empty; - *) - - - (*seen := StringSet.diff !seen (StringSet.of_list ssr_tops);*) - (*print_chunk out g seen fmt "vernac_toplevel" ["vernac_toplevel"] [];*) let index_of str list = let rec index_of_r str list index = match list with @@ -1478,89 +1372,6 @@ let get_range g start end_ = let get_rangeset g start end_ = StringSet.of_list (get_range g start end_) -let print_dominated g = - let info nt rangeset exclude = - let reachable = StringSet.of_list (nt_closure g nt exclude) in - let unreachable = StringSet.of_list (nt_closure g (List.hd start_symbols) (nt::exclude)) in - let dominated = StringSet.diff reachable unreachable in - Printf.printf "For %s, 'attribute' is: reachable = %b, unreachable = %b, dominated = %b\n" nt - (StringSet.mem "attribute" reachable) - (StringSet.mem "attribute" unreachable) - (StringSet.mem "attribute" dominated); - Printf.printf " rangeset = %b excluded = %b\n" - (StringSet.mem "attribute" rangeset) - (List.mem "attribute" exclude); - reachable, dominated - in - let pr3 nt rangeset reachable dominated = - let missing = StringSet.diff dominated rangeset in - if not (StringSet.is_empty missing) then begin - Printf.printf "\nMissing in range for '%s':\n" nt; - StringSet.iter (fun nt -> Printf.printf " %s\n" nt) missing - end; - - let unneeded = StringSet.diff rangeset reachable in - if not (StringSet.is_empty unneeded) then begin - Printf.printf "\nUnneeded in range for '%s':\n" nt; - StringSet.iter (fun nt -> Printf.printf " %s\n" nt) unneeded - end; - in - let pr2 nt rangeset exclude = - let reachable, dominated = info nt rangeset exclude in - pr3 nt rangeset reachable dominated - in - let pr nt end_ = pr2 nt (get_rangeset g nt end_) [] in - - let ssr_ltac = ["ssr_first_else"; "ssrmmod"; "ssrdotac"; "ssrortacarg"; - "ssrparentacarg"] in - let ssr_tac = ["ssrintrosarg"; "ssrhintarg"; "ssrtclarg"; "ssrseqarg"; "ssrmovearg"; - "ssrrpat"; "ssrclauses"; "ssrcasearg"; "ssrarg"; "ssrapplyarg"; "ssrexactarg"; - "ssrcongrarg"; "ssrterm"; "ssrrwargs"; "ssrunlockargs"; "ssrfixfwd"; "ssrcofixfwd"; - "ssrfwdid"; "ssrposefwd"; "ssrsetfwd"; "ssrdgens"; "ssrhavefwdwbinders"; "ssrhpats_nobs"; - "ssrhavefwd"; "ssrsufffwd"; "ssrwlogfwd"; "ssrhint"; "ssrclear"; "ssr_idcomma"; - "ssrrwarg"; "ssrintros_ne"; "ssrhint3arg" ] @ ssr_ltac in - let ssr_cmd = ["ssr_modlocs"; "ssr_search_arg"; "ssrhintref"; "ssrhintref_list"; - "ssrviewpos"; "ssrviewposspc"] in - let ltac = ["ltac_expr"; "ltac_expr0"; "ltac_expr1"; "ltac_expr2"; "ltac_expr3"] in - let term = ["term"; "term0"; "term1"; "term10"; "term100"; "term9"; - "pattern"; "pattern0"; "pattern1"; "pattern10"] in - - pr "term" "constr"; - - let ltac_rangeset = List.fold_left StringSet.union StringSet.empty - [(get_rangeset g "ltac_expr" "tactic_atom"); - (get_rangeset g "toplevel_selector" "range_selector"); - (get_rangeset g "ltac_match_term" "match_pattern"); - (get_rangeset g "ltac_match_goal" "match_pattern_opt")] in - pr2 "ltac_expr" ltac_rangeset ("simple_tactic" :: ssr_tac); - - let dec_vern_rangeset = get_rangeset g "decorated_vernac" "opt_coercion" in - let dev_vern_excl = - ["gallina_ext"; "command"; "tactic_mode"; "syntax"; "command_entry"] @ term @ ltac @ ssr_tac in - pr2 "decorated_vernac" dec_vern_rangeset dev_vern_excl; - - let simp_tac_range = get_rangeset g "simple_tactic" "hypident_occ_list_comma" in - let simp_tac_excl = ltac @ ssr_tac in - pr2 "simple_tactic" simp_tac_range simp_tac_excl; - - let cmd_range = get_rangeset g "command" "int_or_id_list_opt" in - let cmd_excl = ssr_tac @ ssr_cmd in - pr2 "command" cmd_range cmd_excl; - - let syn_range = get_rangeset g "syntax" "constr_as_binder_kind" in - let syn_excl = ssr_tac @ ssr_cmd in - pr2 "syntax" syn_range syn_excl; - - let gext_range = get_rangeset g "gallina_ext" "Structure_opt" in - let gext_excl = ssr_tac @ ssr_cmd in - pr2 "gallina_ext" gext_range gext_excl; - - let qry_range = get_rangeset g "query_command" "searchabout_query_list" in - let qry_excl = ssr_tac @ ssr_cmd in - pr2 "query_command" qry_range qry_excl - - (* todo: tactic_mode *) - let check_range_consistency g start end_ = let defined_list = get_range g start end_ in let defined = StringSet.of_list defined_list in @@ -1913,13 +1724,8 @@ let process_rst g file args seen tac_prods cmd_prods = end in -(* let skip_files = ["doc/sphinx/proof-engine/ltac.rst"; "doc/sphinx/proof-engine/ltac2.rst";*) -(* "doc/sphinx/proof-engine/ssreflect-proof-language.rst"]*) -(* in*) - let cmd_exclude_files = [ "doc/sphinx/proof-engine/ssreflect-proof-language.rst"; - "doc/sphinx/proofs/automatic-tactics/auto.rst"; "doc/sphinx/proofs/writing-proofs/rewriting.rst"; "doc/sphinx/proofs/writing-proofs/proof-mode.rst"; "doc/sphinx/proof-engine/tactics.rst"; @@ -2101,7 +1907,6 @@ let process_grammar args = close_out out; finish_with_file (dir "orderedGrammar") args; (* check_singletons g*) -(* print_dominated g*) let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in let args = { args with no_update = false } in (* always update rsts in place for now *) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index d01f66c6d7..cf90eea5a1 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -342,6 +342,21 @@ closed_binder: [ | [ "of" | "&" ] term99 (* SSR plugin *) ] +one_open_binder: [ +| name +| name ":" lconstr +| one_closed_binder +] + +one_closed_binder: [ +| "(" name ":" lconstr ")" +| "{" name "}" +| "{" name ":" lconstr "}" +| "[" name "]" +| "[" name ":" lconstr "]" +| "'" pattern0 +] + typeclass_constraint: [ | "!" term200 | "{" name "}" ":" [ "!" | ] term200 @@ -875,10 +890,29 @@ univ_decl: [ | "@{" LIST0 identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] ] +variance: [ +| "+" +| "=" +| "*" +] + +variance_identref: [ +| identref +| test_variance_ident variance identref +] + +cumul_univ_decl: [ +| "@{" LIST0 variance_identref [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | bar_cbrace ] ] +] + ident_decl: [ | identref OPT univ_decl ] +cumul_ident_decl: [ +| identref OPT cumul_univ_decl +] + finite_token: [ | "Inductive" | "CoInductive" @@ -918,7 +952,7 @@ opt_constructors_or_fields: [ ] inductive_definition: [ -| opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations +| opt_coercion cumul_ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations ] constructors_or_record: [ @@ -1914,8 +1948,9 @@ in_clause: [ | in_clause' | "*" occs | "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," +| "|-" concl_occ +| LIST1 hypident_occ SEP "," "|-" concl_occ +| LIST1 hypident_occ SEP "," ] test_lpar_id_colon: [ @@ -2493,7 +2528,7 @@ in_hyp_list: [ ] in_hyp_as: [ -| "in" id_or_meta as_ipat +| "in" LIST1 [ id_or_meta as_ipat ] SEP "," | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index f62dd8f731..7c709baa48 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -436,7 +436,7 @@ univ_decl: [ ] cumul_univ_decl: [ -| "@{" LIST0 ( OPT [ "=" | "+" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +| "@{" LIST0 ( OPT [ "+" | "=" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] univ_constraint: [ @@ -512,6 +512,21 @@ binder: [ | "'" pattern0 ] +one_open_binder: [ +| name +| name ":" term +| one_closed_binder +] + +one_closed_binder: [ +| "(" name ":" term ")" +| "{" name "}" +| "{" name ":" term "}" +| "[" name "]" +| "[" name ":" term "]" +| "'" pattern0 +] + implicit_binders: [ | "{" LIST1 name OPT ( ":" type ) "}" | "[" LIST1 name OPT ( ":" type ) "]" @@ -614,16 +629,16 @@ reduce: [ red_expr: [ | "red" | "hnf" -| "simpl" OPT delta_flag OPT ref_or_pattern_occ +| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] | "cbv" OPT strategy_flag | "cbn" OPT strategy_flag | "lazy" OPT strategy_flag | "compute" OPT delta_flag -| "vm_compute" OPT ref_or_pattern_occ -| "native_compute" OPT ref_or_pattern_occ -| "unfold" LIST1 unfold_occ SEP "," +| "vm_compute" OPT [ reference_occs | pattern_occs ] +| "native_compute" OPT [ reference_occs | pattern_occs ] +| "unfold" LIST1 reference_occs SEP "," | "fold" LIST1 one_term -| "pattern" LIST1 pattern_occ SEP "," +| "pattern" LIST1 pattern_occs SEP "," | ident ] @@ -646,31 +661,11 @@ red_flag: [ | "delta" OPT delta_flag ] -ref_or_pattern_occ: [ +reference_occs: [ | reference OPT ( "at" occs_nums ) -| one_term OPT ( "at" occs_nums ) -] - -occs_nums: [ -| LIST1 nat_or_var -| "-" LIST1 nat_or_var -] - -int_or_var: [ -| integer -| ident ] -nat_or_var: [ -| natural -| ident -] - -unfold_occ: [ -| reference OPT ( "at" occs_nums ) -] - -pattern_occ: [ +pattern_occs: [ | one_term OPT ( "at" occs_nums ) ] @@ -705,7 +700,7 @@ field_def: [ ] inductive_definition: [ -| OPT ">" cumul_ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +| OPT ">" ident OPT cumul_univ_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations ] constructors_or_record: [ @@ -717,10 +712,6 @@ constructor: [ | ident LIST0 binder OPT of_type ] -cumul_ident_decl: [ -| ident OPT cumul_univ_decl -] - filtered_import: [ | qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] ] @@ -901,9 +892,7 @@ command: [ | "Print" "Typing" "Flags" | "Print" "Tables" | "Print" "Options" -| "Print" "Hint" -| "Print" "Hint" reference -| "Print" "Hint" "*" +| "Print" "Hint" OPT [ "*" | reference ] | "Print" "HintDb" ident | "Print" "Scopes" | "Print" "Scope" scope_name @@ -958,7 +947,6 @@ command: [ | "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) | "Proof" -| "Proof" "using" section_var_expr | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] @@ -983,7 +971,6 @@ command: [ | "Guarded" | "Create" "HintDb" ident OPT "discriminated" | "Remove" "Hints" LIST1 qualid OPT ( ":" LIST1 ident ) -| "Hint" hint OPT ( ":" LIST1 ident ) | "Comments" LIST0 [ one_term | string | natural ] | "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info | "Declare" "Scope" scope_name @@ -1030,7 +1017,7 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) +| "Hint" "Cut" "[" hints_regexp "]" OPT ( ":" LIST1 ident ) | "Prenex" "Implicits" LIST1 qualid (* SSR plugin *) | "Print" "Hint" "View" OPT ssrviewpos (* SSR plugin *) | "Hint" "View" OPT ssrviewpos LIST1 ( one_term OPT ( "|" natural ) ) (* SSR plugin *) @@ -1039,7 +1026,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 qualid | "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" [ "bfs" | "dfs" ] ")" ) OPT natural | "Proof" "with" ltac_expr OPT [ "using" section_var_expr ] -| "Proof" "using" section_var_expr "with" ltac_expr +| "Proof" "using" section_var_expr OPT [ "with" ltac_expr ] | "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid @@ -1142,6 +1129,15 @@ command: [ | "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) | "Print" "Ltac2" qualid (* Ltac2 plugin *) +| "Hint" "Resolve" LIST1 [ qualid | one_term ] OPT hint_info OPT ( ":" LIST1 ident ) +| "Hint" "Resolve" [ "->" | "<-" ] LIST1 qualid OPT natural OPT ( ":" LIST1 ident ) +| "Hint" "Immediate" LIST1 [ qualid | one_term ] OPT ( ":" LIST1 ident ) +| "Hint" [ "Constants" | "Variables" ] [ "Transparent" | "Opaque" ] OPT ( ":" LIST1 ident ) +| "Hint" [ "Transparent" | "Opaque" ] LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Mode" qualid LIST1 [ "+" | "!" | "-" ] OPT ( ":" LIST1 ident ) +| "Hint" "Unfold" LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Constructors" LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" "Extern" natural OPT one_pattern "=>" ltac_expr OPT ( ":" LIST1 ident ) | "Time" sentence | "Redirect" string sentence | "Timeout" natural sentence @@ -1205,23 +1201,6 @@ univ_name_list: [ | "@{" LIST0 name "}" ] -hint: [ -| "Resolve" LIST1 [ qualid | one_term ] OPT hint_info -| "Resolve" "->" LIST1 qualid OPT natural -| "Resolve" "<-" LIST1 qualid OPT natural -| "Immediate" LIST1 [ qualid | one_term ] -| "Variables" "Transparent" -| "Variables" "Opaque" -| "Constants" "Transparent" -| "Constants" "Opaque" -| "Transparent" LIST1 qualid -| "Opaque" LIST1 qualid -| "Mode" qualid LIST1 [ "+" | "!" | "-" ] -| "Unfold" LIST1 qualid -| "Constructors" LIST1 qualid -| "Extern" natural OPT one_pattern "=>" ltac_expr -] - tacdef_body: [ | qualid LIST0 name [ ":=" | "::=" ] ltac_expr ] @@ -1275,28 +1254,37 @@ constr_with_bindings_arg: [ | OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) ] -clause_dft_concl: [ -| "in" in_clause -| OPT ( "at" occs_nums ) +occurrences: [ +| "at" occs_nums +| "in" goal_occurrences ] -in_clause: [ -| "*" OPT ( "at" occs_nums ) -| "*" "|-" OPT concl_occ -| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +occs_nums: [ +| OPT "-" LIST1 nat_or_var ] -hypident_occ: [ +nat_or_var: [ +| [ natural | ident ] +] + +goal_occurrences: [ +| LIST1 hyp_occs SEP "," OPT ( "|-" OPT concl_occs ) +| "*" "|-" OPT concl_occs +| "|-" OPT concl_occs +| OPT concl_occs +] + +hyp_occs: [ | hypident OPT ( "at" occs_nums ) ] hypident: [ | ident -| "(" "type" "of" ident ")" (* SSR plugin *) -| "(" "value" "of" ident ")" (* SSR plugin *) +| "(" "type" "of" ident ")" +| "(" "value" "of" ident ")" ] -concl_occ: [ +concl_occs: [ | "*" OPT ( "at" occs_nums ) ] @@ -1545,15 +1533,15 @@ number_string_via: [ | "via" qualid "mapping" "[" LIST1 [ qualid "=>" qualid | "[" qualid "]" "=>" qualid ] SEP "," "]" ] -hints_path: [ -| "(" hints_path ")" -| hints_path "*" -| "emp" -| "eps" -| hints_path "|" hints_path +hints_regexp: [ | LIST1 qualid | "_" -| hints_path hints_path +| hints_regexp "|" hints_regexp +| hints_regexp hints_regexp +| hints_regexp "*" +| "emp" +| "eps" +| "(" hints_regexp ")" ] class: [ @@ -1630,7 +1618,7 @@ simple_tactic: [ | "constructor" OPT nat_or_var OPT ( "with" bindings ) | "econstructor" OPT ( nat_or_var OPT ( "with" bindings ) ) | "specialize" one_term OPT ( "with" bindings ) OPT ( "as" simple_intropattern ) -| "symmetry" OPT ( "in" in_clause ) +| "symmetry" OPT ( "in" goal_occurrences ) | "split" OPT ( "with" bindings ) | "esplit" OPT ( "with" bindings ) | "exists" OPT ( LIST1 bindings SEP "," ) @@ -1648,8 +1636,8 @@ simple_tactic: [ | "clear" "-" LIST1 ident | "clearbody" LIST1 ident | "generalize" "dependent" one_term -| "replace" one_term "with" one_term OPT clause_dft_concl OPT ( "by" ltac_expr3 ) -| "replace" OPT [ "->" | "<-" ] one_term OPT clause_dft_concl +| "replace" one_term "with" one_term OPT occurrences OPT ( "by" ltac_expr3 ) +| "replace" OPT [ "->" | "<-" ] one_term OPT occurrences | "setoid_replace" one_term "with" one_term OPT ( "using" "relation" one_term ) OPT ( "in" ident ) OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) | OPT ( [ natural | "[" ident "]" ] ":" ) "{" | bullet @@ -1701,9 +1689,9 @@ simple_tactic: [ | "decompose" "record" one_term | "absurd" one_term | "contradiction" OPT ( one_term OPT ( "with" bindings ) ) -| "autorewrite" OPT "*" "with" LIST1 ident OPT clause_dft_concl OPT ( "using" ltac_expr ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" occurrences OPT ( "by" ltac_expr3 ) ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" occurrences "in" ident OPT ( "by" ltac_expr3 ) +| "autorewrite" OPT "*" "with" LIST1 ident OPT occurrences OPT ( "using" ltac_expr ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs OPT ( "by" ltac_expr3 ) ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" rewrite_occs "in" ident OPT ( "by" ltac_expr3 ) | "refine" one_term | "simple" "refine" one_term | "notypeclasses" "refine" one_term @@ -1764,13 +1752,13 @@ simple_tactic: [ | "auto" OPT nat_or_var OPT auto_using OPT hintbases | "info_auto" OPT nat_or_var OPT auto_using OPT hintbases | "debug" "auto" OPT nat_or_var OPT auto_using OPT hintbases -| "eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "eauto" OPT nat_or_var OPT auto_using OPT hintbases | "new" "auto" OPT nat_or_var OPT auto_using OPT hintbases -| "debug" "eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases -| "info_eauto" OPT nat_or_var OPT nat_or_var OPT auto_using OPT hintbases +| "debug" "eauto" OPT nat_or_var OPT auto_using OPT hintbases +| "info_eauto" OPT nat_or_var OPT auto_using OPT hintbases | "dfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases | "bfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases -| "autounfold" OPT hintbases OPT clause_dft_concl +| "autounfold" OPT hintbases OPT occurrences | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) | "convert_concl_no_check" one_term @@ -1784,8 +1772,8 @@ simple_tactic: [ | "rewrite_strat" rewstrategy OPT ( "in" ident ) | "rewrite_db" ident OPT ( "in" ident ) | "substitute" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) -| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) OPT ( "at" occurrences ) OPT ( "in" ident ) -| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) "in" ident "at" occurrences +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) OPT ( "at" rewrite_occs ) OPT ( "in" ident ) +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) "in" ident "at" rewrite_occs | "setoid_symmetry" OPT ( "in" ident ) | "setoid_reflexivity" | "setoid_transitivity" one_term @@ -1808,10 +1796,10 @@ simple_tactic: [ | "pose" one_term OPT as_name | "epose" bindings_with_parameters | "epose" one_term OPT as_name -| "set" bindings_with_parameters OPT clause_dft_concl -| "set" one_term OPT as_name OPT clause_dft_concl -| "eset" bindings_with_parameters OPT clause_dft_concl -| "eset" one_term OPT as_name OPT clause_dft_concl +| "set" bindings_with_parameters OPT occurrences +| "set" one_term OPT as_name OPT occurrences +| "eset" bindings_with_parameters OPT occurrences +| "eset" one_term OPT as_name OPT occurrences | "remember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all | "eremember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all | "assert" "(" ident ":=" term ")" @@ -1829,32 +1817,32 @@ simple_tactic: [ | "enough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) | "eenough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) | "generalize" one_term OPT ( LIST1 one_term ) -| "generalize" one_term OPT ( "at" occs_nums ) OPT as_name LIST0 [ "," pattern_occ OPT as_name ] +| "generalize" one_term OPT ( "at" occs_nums ) OPT as_name LIST0 [ "," pattern_occs OPT as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list -| "rewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) -| "erewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) +| "rewrite" LIST1 oriented_rewriter SEP "," OPT occurrences OPT ( "by" ltac_expr3 ) +| "erewrite" LIST1 oriented_rewriter SEP "," OPT occurrences OPT ( "by" ltac_expr3 ) | "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] [ ident | natural ] OPT as_or_and_ipat OPT [ "with" one_term ] | "simple" "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion_clear" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) | "inversion" [ ident | natural ] "using" one_term OPT ( "in" LIST1 ident ) -| "red" OPT clause_dft_concl -| "hnf" OPT clause_dft_concl -| "simpl" OPT delta_flag OPT ref_or_pattern_occ OPT clause_dft_concl -| "cbv" OPT strategy_flag OPT clause_dft_concl -| "cbn" OPT strategy_flag OPT clause_dft_concl -| "lazy" OPT strategy_flag OPT clause_dft_concl -| "compute" OPT delta_flag OPT clause_dft_concl -| "vm_compute" OPT ref_or_pattern_occ OPT clause_dft_concl -| "native_compute" OPT ref_or_pattern_occ OPT clause_dft_concl -| "unfold" LIST1 unfold_occ SEP "," OPT clause_dft_concl -| "fold" LIST1 one_term OPT clause_dft_concl -| "pattern" LIST1 pattern_occ SEP "," OPT clause_dft_concl -| "change" conversion OPT clause_dft_concl -| "change_no_check" conversion OPT clause_dft_concl +| "red" OPT occurrences +| "hnf" OPT occurrences +| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] OPT occurrences +| "cbv" OPT strategy_flag OPT occurrences +| "cbn" OPT strategy_flag OPT occurrences +| "lazy" OPT strategy_flag OPT occurrences +| "compute" OPT delta_flag OPT occurrences +| "vm_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences +| "native_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences +| "unfold" LIST1 reference_occs SEP "," OPT occurrences +| "fold" LIST1 one_term OPT occurrences +| "pattern" LIST1 pattern_occs SEP "," OPT occurrences +| "change" conversion OPT occurrences +| "change_no_check" conversion OPT occurrences | "btauto" | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) @@ -1946,6 +1934,7 @@ simple_tactic: [ | "field_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) | "field_simplify_eq" OPT ( "[" LIST1 one_term "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr +| "now" ltac_expr | "nsatz" OPT ( "with" "radicalmax" ":=" one_term "strategy" ":=" one_term "parameters" ":=" one_term "variables" ":=" one_term ) | "psatz" one_term OPT nat_or_var | "ring" OPT ( "[" LIST1 one_term "]" ) @@ -1998,19 +1987,24 @@ induction_clause_list: [ | LIST1 induction_clause SEP "," OPT ( "using" one_term OPT ( "with" bindings ) ) OPT opt_clause ] -induction_clause: [ -| destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause -] - opt_clause: [ -| "in" in_clause +| "in" goal_occurrences | "at" occs_nums ] +induction_clause: [ +| destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause +] + auto_using: [ | "using" LIST1 one_term SEP "," ] +hintbases: [ +| "with" "*" +| "with" LIST1 ident +] + or_and_intropattern: [ | "[" intropattern_or_list_or "]" | "(" LIST0 simple_intropattern SEP "," ")" @@ -2055,6 +2049,10 @@ bindings: [ | LIST1 one_term ] +int_or_var: [ +| [ integer | ident ] +] + comparison: [ | "=" | "<" @@ -2063,11 +2061,6 @@ comparison: [ | ">=" ] -hintbases: [ -| "with" "*" -| "with" LIST1 ident -] - bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] @@ -2436,11 +2429,11 @@ tac2mode: [ ] clause_dft_all: [ -| "in" in_clause +| "in" goal_occurrences ] in_hyp_as: [ -| "in" ident OPT as_ipat +| "in" LIST1 [ ident OPT as_ipat ] SEP "," ] simple_binder: [ @@ -2470,7 +2463,7 @@ func_scheme_def: [ | ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) ] -occurrences: [ +rewrite_occs: [ | LIST1 integer | ident ] diff --git a/interp/constrextern.ml b/interp/constrextern.ml index cf88036f73..378adb566c 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -800,19 +800,21 @@ let extern_args extern env args = let match_coercion_app c = match DAst.get c with | GApp (r, args) -> begin match DAst.get r with - | GRef (r,_) -> Some (c.CAst.loc, r, 0, args) + | GRef (r,_) -> Some (c.CAst.loc, r, args) | _ -> None end | _ -> None let remove_one_coercion inctx c = try match match_coercion_app c with - | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> + | Some (loc,r,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in (match Coercionops.hide_coercion r with - | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> + | Some nparams when + let inctx = inctx || (* coercion to funclass implying being in context *) nparams+1 < nargs in + nparams < nargs && inctx -> (* We skip the coercion *) - let l = List.skipn (n - pars) args in + let l = List.skipn nparams args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Don't flatten App's in case of funclass so that (atomic) notations on [a] work; should be compatible @@ -824,7 +826,7 @@ let remove_one_coercion inctx c = have been made explicit to match *) let a' = if List.is_empty l then a else DAst.make ?loc @@ GApp (a,l) in let inctx = inctx || not (List.is_empty l) in - Some (n-pars+1, inctx, a') + Some (nparams+1, inctx, a') | _ -> None) | _ -> None with Not_found -> @@ -867,7 +869,7 @@ let filter_enough_applied nargs l = | Some nargs -> List.filter (fun (keyrule,pat,n as _rule) -> match n with - | AppBoundedNotation n -> n > nargs + | AppBoundedNotation n -> n >= nargs | AppUnboundedNotation | NotAppNotation -> false) l (* Helper function for safe and optimal printing of primitive tokens *) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 17feeb9b5a..c9326615dc 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -263,7 +263,7 @@ let assoc_defined id env = match Environ.lookup_named id env with * before the term is computed. *) -(* Norm means the term is fully normalized and cannot create a redex +(* Ntrl means the term is fully normalized and cannot create a redex when substituted Cstr means the term is in head normal form and that it can create a redex when substituted (i.e. constructor, fix, lambda) @@ -271,10 +271,10 @@ let assoc_defined id env = match Environ.lookup_named id env with create a redex when substituted Red is used for terms that might be reduced *) -type red_state = Norm | Cstr | Whnf | Red +type red_state = Ntrl | Cstr | Whnf | Red let neutr = function - | Whnf|Norm -> Whnf + | Whnf|Ntrl -> Whnf | Red|Cstr -> Red type optrel = Unknown | KnownR | KnownI @@ -293,13 +293,13 @@ module Mark : sig val neutr : t -> t - val set_norm : t -> t + val set_ntrl : t -> t end = struct type t = int let[@inline] of_state = function - | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + | Ntrl -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 let[@inline] of_relevance = function | Unknown -> 0 @@ -315,15 +315,15 @@ end = struct | _ -> assert false let[@inline] red_state x = match x land 0b1100 with - | 0b0000 -> Norm + | 0b0000 -> Ntrl | 0b0100 -> Cstr | 0b1000 -> Whnf | 0b1100 -> Red | _ -> assert false - let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + let[@inline] neutr x = x lor 0b1000 (* Whnf|Ntrl -> Whnf | Red|Cstr -> Red *) - let[@inline] set_norm x = x land 0b0011 + let[@inline] set_ntrl x = x land 0b0011 end let mark = Mark.mark @@ -358,10 +358,10 @@ and fterm = and finvert = Univ.Instance.t * fconstr array let fterm_of v = v.term -let set_norm v = v.mark <- Mark.set_norm v.mark -let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false +let set_ntrl v = v.mark <- Mark.set_ntrl v.mark +let is_val v = match Mark.red_state v.mark with Ntrl -> true | Cstr | Whnf | Red -> false -let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_atom c = {mark=mark Ntrl Unknown;term=FAtom c} let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose @@ -448,7 +448,7 @@ let rec lft_fconstr n ft = let r = Mark.relevance ft.mark in match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _|FFloat _) -> ft - | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FRel i -> {mark=mark Ntrl r;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} @@ -466,7 +466,7 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} + | Inr(k,None) -> {mark=mark Ntrl Unknown; term= FRel k} | Inr(k,Some p) -> lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} @@ -488,7 +488,7 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Ntrl | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -514,8 +514,8 @@ let mk_clos e t = | Rel i -> clos_rel e i | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } - | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Meta _ | Sort _ -> {mark = mark Ntrl KnownR; term = FAtom t } + | Ind kn -> {mark = mark Ntrl KnownR; term = FInd kn } | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } | Int i -> {mark = mark Cstr Unknown; term = FInt i} | Float f -> {mark = mark Cstr Unknown; term = FFloat f} @@ -734,11 +734,11 @@ let strip_update_shift_app_red head stk = strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Ntrl | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -787,7 +787,7 @@ let rec eta_expand_stack = function | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Ntrl Unknown; term= FRel 1}|]] (* Get the arguments of a native operator *) let rec skip_native_args rargs nargs = @@ -968,7 +968,7 @@ module FNativeEntries = | FArray (_u,t,_ty) -> t | _ -> raise Not_found - let dummy = {mark = mark Norm KnownR; term = FRel 0} + let dummy = {mark = mark Ntrl KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty let defined_int = ref false @@ -978,7 +978,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_int63 with | Some c -> defined_int := true; - fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + fint := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false let defined_float = ref false @@ -988,7 +988,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_float64 with | Some c -> defined_float := true; - ffloat := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + ffloat := { mark = mark Ntrl KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_float := false let defined_bool = ref false @@ -1039,7 +1039,7 @@ module FNativeEntries = fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) }; let (icmp, _) = cEq in - fcmp := { mark = mark Norm KnownR; term = FInd (Univ.in_punivs icmp) } + fcmp := { mark = mark Ntrl KnownR; term = FInd (Univ.in_punivs icmp) } | None -> defined_cmp := false let defined_f_cmp = ref false @@ -1327,19 +1327,19 @@ let rec knr info tab m stk = let rargs, a, nargs, stk = get_native_args1 op c stk in kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) else - (* Similarly to fix, partially applied primitives are not Norm! *) + (* Similarly to fix, partially applied primitives are not Ntrl! *) (m, stk) - | Undef _ | OpaqueDef _ -> (set_norm m; (m,stk))) + | Undef _ | OpaqueDef _ -> (set_ntrl m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info tab (RelKey k) with | Def v -> kni info tab v stk | Primitive _ -> assert false - | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) + | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in @@ -1523,9 +1523,9 @@ let norm_val info tab v = with_stats (lazy (kl info tab v)) let whd_stack infos tab m stk = match Mark.red_state m.mark with -| Whnf | Norm -> +| Whnf | Ntrl -> (** No need to perform [kni] nor to unlock updates because - every head subterm of [m] is [Whnf] or [Norm] *) + every head subterm of [m] is [Whnf] or [Ntrl] *) knh infos m stk | Red | Cstr -> let k = kni infos tab m stk in diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d49a49d242..a482e044d8 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -175,28 +175,7 @@ let rec remove_grammars n = camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries; remove_grammars (n - 1) -let make_rule r = [None, None, r] - -(** An entry that checks we reached the end of the input. *) - -let eoi_entry en = - let e = Entry.make ((Entry.name en) ^ "_eoi") in - let symbs = Rule.next (Rule.next Rule.stop (Symbol.nterm en)) (Symbol.token Tok.PEOI) in - let act = fun _ x loc -> x in - let ext = { pos = None; data = make_rule [Production.make symbs act] } in - safe_extend e ext; - e - -let map_entry f en = - let e = Entry.make ((Entry.name en) ^ "_map") in - let symbs = Rule.next Rule.stop (Symbol.nterm en) in - let act = fun x loc -> f x in - let ext = { pos = None; data = make_rule [Production.make symbs act] } in - safe_extend e ext; - e - -(* Parse a string, does NOT check if the entire string was read - (use eoi_entry) *) +(* Parse a string, does NOT check if the entire string was read *) let parse_string f ?loc x = let strm = Stream.of_string x in @@ -310,7 +289,6 @@ module Constr = let constr = Entry.create "constr" let term = Entry.create "term" let operconstr = term - let constr_eoi = eoi_entry constr let lconstr = Entry.create "lconstr" let binder_constr = Entry.create "binder_constr" let ident = Entry.create "ident" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d0ae594db1..df9084ab76 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -120,8 +120,6 @@ end (** Parse a string *) val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a -val eoi_entry : 'a Entry.t -> 'a Entry.t -val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t type gram_universe [@@deprecated "Deprecated in 8.13"] [@@@ocaml.warning "-3"] @@ -182,7 +180,6 @@ module Prim : module Constr : sig val constr : constr_expr Entry.t - val constr_eoi : constr_expr Entry.t val lconstr : constr_expr Entry.t val binder_constr : constr_expr Entry.t val term : constr_expr Entry.t diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 21ec80abbc..da4a50b674 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -399,7 +399,11 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | MLuint i1, MLuint i2 -> Uint63.equal i1 i2 | MLfloat f1, MLfloat f2 -> Float64.equal f1 f2 -| _, _ -> false +| MLparray (t1,def1), MLparray (t2, def2) -> Array.equal eq_ml_ast t1 t2 && eq_ml_ast def1 def2 +| (MLrel _|MLapp _|MLlam _|MLletin _|MLglob _|MLcons _ + |MLtuple _|MLcase _|MLfix _|MLexn _|MLdummy _|MLaxiom + | MLmagic _| MLuint _| MLfloat _|MLparray _), _ + -> false and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 196a68e67c..80c13a3698 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -47,8 +47,6 @@ let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" (* Main entry for quotations *) -let tactic_eoi = eoi_entry tactic - let () = let open Stdarg in let open Tacarg in diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index c0bf6b9f76..73bce84d18 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -40,4 +40,3 @@ val tactic_expr : raw_tactic_expr Entry.t [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t -val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9008691bca..74d5374193 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -385,6 +385,16 @@ let subst sys = sys'; sys' +let tr_sys str f sys = + let sys' = f sys in + if debug then ( + Printf.fprintf stdout "[%s\n" str; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "\n => \n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; + Printf.fprintf stdout "]\n" ); + sys' + (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. For integers, the obtained constraints are sound but not complete. @@ -392,11 +402,7 @@ let subst sys = let saturate_by_linear_equalities sys0 = WithProof.saturate_subst false sys0 let saturate_by_linear_equalities sys = - let sys' = saturate_by_linear_equalities sys in - if debug then - Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" - output_sys sys output_sys sys'; - sys' + tr_sys "saturate_by_linear_equalities" saturate_by_linear_equalities sys let bound_monomials (sys : WithProof.t list) = let l = @@ -497,10 +503,10 @@ let nlinear_prover prfdepth sys = let sys = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in let id = List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in - let env = CList.interval 0 id in + let env = List.map (fun i -> ProofFormat.Hyp i) (CList.interval 0 id) in match linear_prover_cstr sys with | None -> Unknown | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) @@ -514,7 +520,7 @@ let linear_prover_with_cert prfdepth sys = | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q - (List.mapi (fun i e -> i) sys) + (List.mapi (fun i e -> ProofFormat.Hyp i) sys) cert) (* The prover is (probably) incomplete -- @@ -885,6 +891,11 @@ let check_sys sys = open ProofFormat +let output_cstr_sys sys = + (pp_list ";" (fun o (c, wp) -> + Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) + sys + let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -922,16 +933,10 @@ let xlia (can_enum : bool) reduction_equations sys = | _ -> Unknown ) and aux_lia (id : int) (sys : prf_sys) = assert (check_sys sys); - if debug then - Printf.printf "xlia: %a \n" - (pp_list ";" (fun o (c, _) -> output_cstr o c)) - sys; + if debug then Printf.printf "xlia: %a \n" output_cstr_sys sys; try let sys = reduction_equations sys in - if debug then - Printf.printf "after reduction: %a \n" - (pp_list ";" (fun o (c, _) -> output_cstr o c)) - sys; + if debug then Printf.printf "after reduction: %a \n" output_cstr_sys sys; match linear_prover_cstr sys with | Some prf -> Prf (Step (id, prf, Done)) | None -> if can_enum then enum_proof id sys else Unknown @@ -943,7 +948,7 @@ let xlia (can_enum : bool) reduction_equations sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let orpf = @@ -973,7 +978,7 @@ let xlia_simplex env red sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let env = CList.interval 0 (id - 1) in @@ -1007,6 +1012,128 @@ let gen_bench (tac, prover) can_enum prfdepth sys = flush o; close_out o ); res +let normalise sys = + List.fold_left + (fun acc s -> + match WithProof.cutting_plane s with + | None -> s :: acc + | Some s' -> s' :: acc) + [] sys + +let normalise = tr_sys "normalise" normalise + +let elim_redundant sys = + let module VectMap = Map.Make (Vect) in + let elim_eq sys = + List.fold_left + (fun acc (((v, o), prf) as wp) -> + match o with + | Gt -> assert false + | Ge -> wp :: acc + | Eq -> wp :: WithProof.neg wp :: acc) + [] sys + in + let of_list l = + List.fold_left + (fun m (((v, o), prf) as wp) -> + let q, v' = Vect.decomp_cst v in + try + let q', wp' = VectMap.find v' m in + match Q.compare q q' with + | 0 -> if o = Eq then VectMap.add v' (q, wp) m else m + | 1 -> m + | _ -> VectMap.add v' (q, wp) m + with Not_found -> VectMap.add v' (q, wp) m) + VectMap.empty l + in + let to_list m = VectMap.fold (fun _ (_, wp) sys -> wp :: sys) m [] in + to_list (of_list (elim_eq sys)) + +let elim_redundant sys = tr_sys "elim_redundant" elim_redundant sys + +(** [fourier_small] performs some variable elimination and keeps the cutting planes. + To decide which elimination to perform, the constraints are sorted according to + 1 - the number of variables + 2 - the value of the smallest coefficient + Given the smallest constraint, we eliminate the variable with the smallest coefficient. + The rational is that a constraint with a single variable provides some bound information. + When there are several variables, we hope to eliminate all the variables. + A necessary condition is to take the variable with the smallest coefficient *) + +let fourier_small (sys : WithProof.t list) = + let gen_pivot acc (q, x) wp l = + List.fold_left + (fun acc (s, wp') -> + match WithProof.simple_pivot (q, x) wp wp' with + | None -> acc + | Some wp2 -> ( + match WithProof.cutting_plane wp2 with + | Some wp2 -> (s, wp2) :: acc + | _ -> acc )) + acc l + in + let rec all_pivots acc l = + match l with + | [] -> acc + | ((_, qx), wp) :: l' -> all_pivots (gen_pivot acc qx wp (acc @ l')) l' + in + List.rev_map snd (all_pivots [] (WithProof.sort sys)) + +let fourier_small = tr_sys "fourier_small" fourier_small + +(** [propagate_bounds sys] generate new constraints by exploiting bounds. + A bound is a constraint of the form c + a.x >= 0 + *) + +(*let propagate_bounds sys = + let bounds, sys' = + List.fold_left + (fun (b, r) (((c, o), prf) as wp) -> + match Vect.Bound.of_vect c with + | None -> (b, wp :: r) + | Some b' -> ((b', wp) :: b, r)) + ([], []) sys + in + let exploit_bound acc (b, wp) = + let cf = b.Vect.Bound.coeff in + let vr = b.Vect.Bound.var in + List.fold_left + (fun acc (((c, o), prf) as wp') -> + let cf' = Vect.get vr c in + if Q.sign (cf */ cf') = -1 then + WithProof.( + let wf2 = + addition + (mult (LinPoly.constant (Q.abs cf')) wp) + (mult (LinPoly.constant (Q.abs cf)) wp') + in + match cutting_plane wf2 with None -> acc | Some cp -> cp :: acc) + else acc) + acc sys' + in + List.fold_left exploit_bound [] bounds + *) + +let rev_concat l = + let rec conc acc l = + match l with [] -> acc | l1 :: lr -> conc (List.rev_append l1 acc) lr + in + conc [] l + +let pre_process sys = + let sys = normalise sys in + let bnd1 = bound_monomials sys in + let sys1 = normalise (subst sys) in + let pbnd1 = fourier_small sys1 in + let sys2 = elim_redundant (List.rev_append pbnd1 sys1) in + let bnd2 = bound_monomials sys2 in + let pbnd2 = [] (*fourier_small sys2*) in + (* Should iterate ? *) + let sys = + rev_concat [pbnd2; bnd1; bnd2; saturate_by_linear_equalities sys2; sys2] + in + sys + let lia (can_enum : bool) (prfdepth : int) sys = let sys = develop_constraints prfdepth z_spec sys in if debug then begin @@ -1020,11 +1147,7 @@ let lia (can_enum : bool) (prfdepth : int) sys = p) sys end; - let bnd1 = bound_monomials sys in - let sys = subst sys in - let bnd2 = bound_monomials sys in - (* To deal with non-linear monomials *) - let sys = bnd1 @ bnd2 @ saturate_by_linear_equalities sys @ sys in + let sys = pre_process sys in let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' @@ -1039,7 +1162,8 @@ let nlia enum prfdepth sys = List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys end; if is_linear then - xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + xlia (List.map fst sys) enum reduction_equations + (make_cstr_system (pre_process sys)) else (* let sys1 = elim_every_substitution sys in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 542b99075d..e119ceb241 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,7 +12,7 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules M, Mc, Env, Cache, CacheZ *) +(* - Modules Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) @@ -197,6 +197,7 @@ let coq_proofTerm = lazy (constr_of_ref "micromega.ZArithProof.type") let coq_doneProof = lazy (constr_of_ref "micromega.ZArithProof.DoneProof") let coq_ratProof = lazy (constr_of_ref "micromega.ZArithProof.RatProof") let coq_cutProof = lazy (constr_of_ref "micromega.ZArithProof.CutProof") +let coq_splitProof = lazy (constr_of_ref "micromega.ZArithProof.SplitProof") let coq_enumProof = lazy (constr_of_ref "micromega.ZArithProof.EnumProof") let coq_ExProof = lazy (constr_of_ref "micromega.ZArithProof.ExProof") let coq_IsProp = lazy (constr_of_ref "micromega.kind.isProp") @@ -1341,6 +1342,12 @@ let rec dump_proof_term = function EConstr.mkApp ( Lazy.force coq_cutProof , [|dump_psatz coq_Z dump_z cone; dump_proof_term prf|] ) + | Micromega.SplitProof (p, prf1, prf2) -> + EConstr.mkApp + ( Lazy.force coq_splitProof + , [| dump_pol (Lazy.force coq_Z) dump_z p + ; dump_proof_term prf1 + ; dump_proof_term prf2 |] ) | Micromega.EnumProof (c1, c2, prfs) -> EConstr.mkApp ( Lazy.force coq_enumProof @@ -1364,6 +1371,7 @@ let rec size_of_pf = function | Micromega.DoneProof -> 1 | Micromega.RatProof (p, a) -> size_of_pf a + size_of_psatz p | Micromega.CutProof (p, a) -> size_of_pf a + size_of_psatz p + | Micromega.SplitProof (_, p1, p2) -> size_of_pf p1 + size_of_pf p2 | Micromega.EnumProof (p1, p2, l) -> size_of_psatz p1 + size_of_psatz p2 + List.fold_left (fun acc p -> size_of_pf p + acc) 0 l @@ -1382,6 +1390,9 @@ let rec pp_proof_term o = function Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof (cone, rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.SplitProof (p, p1, p2) -> + Printf.fprintf o "S[%a,%a,%a]" (pp_pol pp_z) p pp_proof_term p1 + pp_proof_term p2 | Micromega.EnumProof (c1, c2, rst) -> Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) @@ -2064,7 +2075,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) = +end) : +sig + type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list @@ -2196,6 +2211,7 @@ let hyps_of_pt pt = | Mc.DoneProof -> acc | Mc.RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) | Mc.CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | Mc.SplitProof (p, p1, p2) -> xhyps (base + 1) p1 (xhyps (base + 1) p2 acc) | Mc.EnumProof (c1, c2, l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l @@ -2212,6 +2228,8 @@ let compact_pt pt f = Mc.RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) | Mc.CutProof (c, pt) -> Mc.CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | Mc.SplitProof (p, p1, p2) -> + Mc.SplitProof (p, compact_pt (ofset + 1) p1, compact_pt (ofset + 1) p2) | Mc.EnumProof (c1, c2, l) -> Mc.EnumProof ( compact_cone c1 (translate ofset) diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index b231779c7b..57de80bd24 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1384,11 +1384,13 @@ let rxcnf_or unsat deduce rXCNF polarity k e1 e2 = let rxcnf_impl unsat deduce rXCNF polarity k e1 e2 = let e3,t1 = rXCNF (negb polarity) k e1 in if polarity - then if is_cnf_ff e3 - then rXCNF polarity k e2 - else let e4,t2 = rXCNF polarity k e2 in - let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(rev_append t1 (rev_append t2 t')) + then if is_cnf_tt e3 + then e3,t1 + else if is_cnf_ff e3 + then rXCNF polarity k e2 + else let e4,t2 = rXCNF polarity k e2 in + let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) else let e4,t2 = rXCNF polarity k e2 in (and_cnf_opt e3 e4),(rev_append t1 t2) @@ -2140,6 +2142,11 @@ let zWeakChecker = let psub1 = psub0 Z0 Z.add Z.sub Z.opp zeq_bool +(** val popp1 : z pol -> z pol **) + +let popp1 = + popp0 Z.opp + (** val padd1 : z pol -> z pol -> z pol **) let padd1 = @@ -2233,6 +2240,7 @@ type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof | EnumProof of zWitness * zWitness * zArithProof list | ExProof of positive * zArithProof @@ -2344,6 +2352,15 @@ let rec zChecker l = function | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 | None -> true) | None -> false) +| SplitProof (p, pf1, pf2) -> + (match genCuttingPlane (p,NonStrict) with + | Some cp1 -> + (match genCuttingPlane ((popp1 p),NonStrict) with + | Some cp2 -> + (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) + (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) + | None -> false) + | None -> false) | EnumProof (w1, w2, pf0) -> (match eval_Psatz0 l w1 with | Some f1 -> diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 53f62e0f5b..f75d8880c6 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,942 +1,740 @@ + type __ = Obj.t -type unit0 = Tt + +type unit0 = +| Tt val negb : bool -> bool -type nat = O | S of nat -type ('a, 'b) sum = Inl of 'a | Inr of 'b +type nat = +| O +| S of nat + +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 -val fst : 'a1 * 'a2 -> 'a1 -val snd : 'a1 * 'a2 -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list -type comparison = Eq | Lt | Gt +type comparison = +| Eq +| Lt +| Gt val compOpp : comparison -> comparison + val add : nat -> nat -> nat + val nth : nat -> 'a1 list -> 'a1 -> 'a1 + val rev_append : 'a1 list -> 'a1 list -> 'a1 list + val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list -val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -type positive = XI of positive | XO of positive | XH -type n = N0 | Npos of positive -type z = Z0 | Zpos of positive | Zneg of positive +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -module Pos : sig - type mask = IsNul | IsPos of positive | IsNeg -end +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -module Coq_Pos : sig +type positive = +| XI of positive +| XO of positive +| XH + +type n = +| N0 +| Npos of positive + +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +module Pos : + sig + type mask = + | IsNul + | IsPos of positive + | IsNeg + end + +module Coq_Pos : + sig val succ : positive -> positive + val add : positive -> positive -> positive + val add_carry : positive -> positive -> positive + val pred_double : positive -> positive - type mask = Pos.mask = IsNul | IsPos of positive | IsNeg + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg val succ_double_mask : mask -> mask + val double_mask : mask -> mask + val double_pred_mask : positive -> mask + val sub_mask : positive -> positive -> mask + val sub_mask_carry : positive -> positive -> mask + val sub : positive -> positive -> positive + val mul : positive -> positive -> positive + val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 + val size_nat : positive -> nat + val compare_cont : comparison -> positive -> positive -> comparison + val compare : positive -> positive -> comparison + val max : positive -> positive -> positive + val leb : positive -> positive -> bool + val gcdn : nat -> positive -> positive -> positive + val gcd : positive -> positive -> positive + val of_succ_nat : nat -> positive -end + end -module N : sig +module N : + sig val of_nat : nat -> n -end + end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -module Z : sig +module Z : + sig val double : z -> z + val succ_double : z -> z + val pred_double : z -> z + val pos_sub : positive -> positive -> z + val add : z -> z -> z + val opp : z -> z + val sub : z -> z -> z + val mul : z -> z -> z + val pow_pos : z -> positive -> z + val pow : z -> z -> z + val compare : z -> z -> comparison + val leb : z -> z -> bool + val ltb : z -> z -> bool + val gtb : z -> z -> bool + val max : z -> z -> z + val abs : z -> z + val to_N : z -> n + val of_nat : nat -> z + val of_N : n -> z + val pos_div_eucl : positive -> z -> z * z + val div_eucl : z -> z -> z * z + val div : z -> z -> z + val gcd : z -> z -> z -end + end val zeq_bool : z -> z -> bool type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol + val p1 : 'a1 -> 'a1 pol + val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + val mkPinj : positive -> 'a1 pol -> 'a1 pol + val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol + val mkX : 'a1 -> 'a1 -> 'a1 pol + val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubI : - ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> + 'a1 pol -> 'a1 pol val paddX : - 'a1 - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val psubX : - 'a1 - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 - -> 'a1 pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 - -> 'a1 pol +val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol -> 'a1 pol) - -> 'a1 pol - -> positive - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol -> 'a1 pol val psquare : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol) - -> 'a1 pol - -> 'a1 pol - -> positive - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 pol -> 'a1 pol) - -> 'a1 pol - -> n - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pExpr - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -type kind = IsProp | IsBool +type kind = +| IsProp +| IsBool type ('tA, 'tX, 'aA, 'aF) gFormula = - | TT of kind - | FF of kind - | X of kind * 'tX - | A of kind * 'tA * 'aA - | AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula - | IMPL of - kind - * ('tA, 'tX, 'aA, 'aF) gFormula - * 'aF option - * ('tA, 'tX, 'aA, 'aF) gFormula - | IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| TT of kind +| FF of kind +| X of kind * 'tX +| A of kind * 'tA * 'aA +| AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula +| IMPL of kind * ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula +| IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula val mapX : - (kind -> 'a2 -> 'a2) - -> kind - -> ('a1, 'a2, 'a3, 'a4) gFormula - -> ('a1, 'a2, 'a3, 'a4) gFormula + (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula -val foldA : - ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 +val foldA : ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 val cons_id : 'a1 option -> 'a1 list -> 'a1 list + val ids_of_formula : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + val collect_annot : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list type rtyp = __ + type eKind = __ + type 'a bFormula = ('a, eKind, unit0, unit0) gFormula val map_bformula : - kind - -> ('a1 -> 'a2) - -> ('a1, 'a3, 'a4, 'a5) gFormula - -> ('a2, 'a3, 'a4, 'a5) gFormula + kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula type ('x, 'annot) clause = ('x * 'annot) list + type ('x, 'annot) cnf = ('x, 'annot) clause list val cnf_tt : ('a1, 'a2) cnf + val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause option val or_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option val xor_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val is_cnf_tt : ('a1, 'a2) cnf -> bool + val is_cnf_ff : ('a1, 'a2) cnf -> bool + val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val or_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val mk_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option val xcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, 'a2) + clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> (('a1, + 'a2) clause, 'a2 list) sum val xror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list -> + ('a1, 'a2) cnf * 'a2 list val ror_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf * 'a2 list val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list - -type ('term, 'annot, 'tX) to_constrT = - { mkTT : kind -> 'tX - ; mkFF : kind -> 'tX - ; mkA : kind -> 'term -> 'annot -> 'tX - ; mkAND : kind -> 'tX -> 'tX -> 'tX - ; mkOR : kind -> 'tX -> 'tX -> 'tX - ; mkIMPL : kind -> 'tX -> 'tX -> 'tX - ; mkIFF : kind -> 'tX -> 'tX -> 'tX - ; mkNOT : kind -> 'tX -> 'tX - ; mkEQ : 'tX -> 'tX -> 'tX } - -val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = { mkTT : (kind -> 'tX); mkFF : (kind -> 'tX); + mkA : (kind -> 'term -> 'annot -> 'tX); + mkAND : (kind -> 'tX -> 'tX -> 'tX); + mkOR : (kind -> 'tX -> 'tX -> 'tX); + mkIMPL : (kind -> 'tX -> 'tX -> 'tX); + mkIFF : (kind -> 'tX -> 'tX -> 'tX); + mkNOT : (kind -> 'tX -> 'tX); mkEQ : ('tX -> 'tX -> 'tX) } + +val aformula : ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option val abs_and : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_or : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_not : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val mk_arrow : - 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_simpl : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_and : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_or : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_impl : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool +val or_is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool val abs_iff : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> kind -> ('a1, 'a2, + 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_iff : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_eq : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_form : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula -val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> (('a2 * 'a3) list -> 'a4 -> bool) - -> ('a1, rtyp, 'a3, unit0) gFormula - -> 'a4 list - -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, rtyp, 'a3, unit0) gFormula -> 'a4 + list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol -type op1 = Equal | NonEqual | Strict | NonStrict + +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict + type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option + val opAdd : op1 -> op1 -> op1 option type 'c psatz = - | PsatzIn of nat - | PsatzSquare of 'c polC - | PsatzMulC of 'c polC * 'c psatz - | PsatzMulE of 'c psatz * 'c psatz - | PsatzAdd of 'c psatz * 'c psatz - | PsatzC of 'c - | PsatzZ +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option +val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 polC - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> + 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula + -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula - -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula + option val eval_Psatz : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> 'a1 nFormula option - -val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + +val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> bool - -type op2 = OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt -type 't formula = {flhs : 't pExpr; fop : op2; frhs : 't pExpr} + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pExpr - -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol -val padd0 : - 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 pol - -> 'a1 pol - -> 'a1 pol +val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a1 nFormula + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list val cnf_of_list : - 'a1 - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 nFormula, + 'a2) cnf val cnf_normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val cnf_negate : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr + val denorm : 'a1 pol -> 'a1 pExpr + val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr + val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula -val simpl_cone : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 psatz - -> 'a1 psatz +val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz -type q = {qnum : z; qden : positive} +type q = { qnum : z; qden : positive } val qeq_bool : q -> q -> bool + val qle_bool : q -> q -> bool + val qplus : q -> q -> q + val qmult : q -> q -> q + val qopp : q -> q + val qminus : q -> q -> q + val qinv : q -> q + val qpower_positive : q -> positive -> q + val qpower : q -> z -> q -type 'a t = Empty | Elt of 'a | Branch of 'a t * 'a * 'a t +type 'a t = +| Empty +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 + val singleton : 'a1 -> positive -> 'a1 -> 'a1 t + val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t + val zeval_const : z pExpr -> z option type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool + val psub1 : z pol -> z pol -> z pol + +val popp1 : z pol -> z pol + val padd1 : z pol -> z pol -> z pol + val normZ : z pExpr -> z pol + val zunsat : z nFormula -> bool + val zdeduce : z nFormula -> z nFormula -> z nFormula option + val xnnormalise : z formula -> z nFormula + val xnormalise0 : z nFormula -> z nFormula list + val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list + val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf + val xnegate0 : z nFormula -> z nFormula list + val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf -val cnfZ : - kind - -> (z formula, 'a1, 'a2, 'a3) tFormula - -> (z nFormula, 'a1) cnf * 'a1 list +val cnfZ : kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list val ceiling : z -> z -> z type zArithProof = - | DoneProof - | RatProof of zWitness * zArithProof - | CutProof of zWitness * zArithProof - | EnumProof of zWitness * zWitness * zArithProof list - | ExProof of positive * zArithProof +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof val zgcdM : z -> z -> z + val zgcd_pol : z polC -> z * z + val zdiv_pol : z polC -> z -> z polC + val makeCuttingPlane : z polC -> z polC * z + val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option -val nformula_of_cutting_plane : (z polC * z) * op1 -> z nFormula + +val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula + val is_pol_Z0 : z polC -> bool + val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option + val valid_cut_sign : op1 -> bool + val bound_var : positive -> z formula + val mk_eq_pos : positive -> positive -> positive -> z formula + val max_var : positive -> z pol -> positive + val max_var_nformulae : z nFormula list -> positive + val zChecker : z nFormula list -> zArithProof -> bool + val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool + val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qunsat : q nFormula -> bool + val qdeduce : q nFormula -> q nFormula -> q nFormula option + val normQ : q pExpr -> q pol -val cnfQ : - kind - -> (q formula, 'a1, 'a2, 'a3) tFormula - -> (q nFormula, 'a1) cnf * 'a1 list +val cnfQ : kind -> (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = - | C0 - | C1 - | CQ of q - | CZ of z - | CPlus of rcst * rcst - | CMinus of rcst * rcst - | CMult of rcst * rcst - | CPow of rcst * (z, nat) sum - | CInv of rcst - | COpp of rcst +| C0 +| C1 +| CQ of q +| CZ of z +| CPlus of rcst * rcst +| CMinus of rcst * rcst +| CMult of rcst * rcst +| CPow of rcst * (z, nat) sum +| CInv of rcst +| COpp of rcst val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool + val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val runsat : q nFormula -> bool + val rdeduce : q nFormula -> q nFormula -> q nFormula option + val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 21178a64a5..6e997696cb 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -33,11 +33,32 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct type key = Key.t - module Table = Hashtbl.Make (Key) - - exception InvalidTableFormat - - type 'a t = {outch : out_channel; htbl : 'a Table.t} + module Table : + sig + type 'a t + val empty : 'a t + val add : int -> 'a -> 'a t -> 'a t + val find : int -> 'a t -> 'a list + val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end = + struct + type 'a t = 'a list Int.Map.t + let empty = Int.Map.empty + let add h pos tab = + try Int.Map.modify h (fun _ l -> pos :: l) tab + with Not_found -> Int.Map.add h [pos] tab + + let fold f tab accu = + let fold h l accu = List.fold_left (fun accu pos -> f h pos accu) accu l in + Int.Map.fold fold tab accu + + let find h tab = Int.Map.find h tab + end + (* A mapping key hash -> file position *) + + type 'a data = { pos : int; mutable obj : (Key.t * 'a) option } + + type 'a t = {outch : out_channel; mutable htbl : 'a data Table.t; file : string } (* XXX: Move to Fun.protect once in Ocaml 4.08 *) let fun_protect ~(finally : unit -> unit) work = @@ -55,10 +76,19 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct finally_no_exn (); Printexc.raise_with_backtrace work_exn work_bt - let read_key_elem inch = - try Some (Marshal.from_channel inch) with - | End_of_file -> None - | e when CErrors.noncritical e -> raise InvalidTableFormat + let skip_blob ch = + let hd = Bytes.create Marshal.header_size in + let () = really_input ch hd 0 Marshal.header_size in + let len = Marshal.data_size hd 0 in + let pos = pos_in ch in + seek_in ch (pos + len) + + let read_key_elem inch = match input_binary_int inch with + | hash -> + let pos = pos_in inch in + let () = skip_blob inch in + Some (hash, pos) + | exception End_of_file -> None (** We used to only lock/unlock regions. @@ -100,48 +130,98 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct let do_under_lock kd fd f = if lock kd fd then fun_protect f ~finally:(fun () -> unlock fd) else f () - let open_in f = + let fopen_in = open_in + + let open_in (type a) f : a t = let flags = [O_RDONLY; O_CREAT] in let finch = openfile f flags 0o666 in let inch = in_channel_of_descr finch in - let htbl = Table.create 100 in - let rec xload () = + let exception InvalidTableFormat of a data Table.t in + let rec xload table = match read_key_elem inch with - | None -> () - | Some (key, elem) -> Table.add htbl key elem; xload () + | None -> table + | Some (hash, pos) -> xload (Table.add hash { pos; obj = None } table) + | exception e when CErrors.noncritical e -> raise (InvalidTableFormat table) in try (* Locking of the (whole) file while reading *) - do_under_lock Read finch xload; - close_in_noerr inch; - { outch = - out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) - ; htbl } - with InvalidTableFormat -> + let htbl = do_under_lock Read finch (fun () -> xload Table.empty) in + let () = close_in_noerr inch in + let outch = out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) in + { outch ; file = f; htbl } + with InvalidTableFormat htbl -> (* The file is corrupted *) - close_in_noerr inch; + let fold hash data accu = + let () = seek_in inch data.pos in + match Marshal.from_channel inch with + | (k, v) -> (hash, k, v) :: accu + | exception e -> accu + in + (* Try to salvage what we can *) + let data = do_under_lock Read finch (fun () -> Table.fold fold htbl []) in + let () = close_in_noerr inch in let flags = [O_WRONLY; O_TRUNC; O_CREAT] in let out = openfile f flags 0o666 in let outch = out_channel_of_descr out in - do_under_lock Write out (fun () -> - Table.iter - (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) - htbl; - flush outch); - {outch; htbl} + let fold htbl (h, k, e) = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + Table.add h { pos; obj = None } htbl + in + let dump () = + let htbl = List.fold_left fold Table.empty data in + let () = flush outch in + htbl + in + let htbl = do_under_lock Write out dump in + {outch; htbl; file = f} let add t k e = - let {outch; htbl = tbl} = t in + let {outch} = t in let fd = descr_of_out_channel outch in - Table.add tbl k e; - do_under_lock Write fd (fun _ -> - Marshal.to_channel outch (k, e) [Marshal.No_sharing]; - flush outch) + let h = Key.hash k land 0x7FFFFFFF in + let dump () = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + let () = flush outch in + pos + in + let pos = do_under_lock Write fd dump in + t.htbl <- Table.add h { pos; obj = Some (k, e) } t.htbl let find t k = let {outch; htbl = tbl} = t in - let res = Table.find tbl k in - res + let h = Key.hash k land 0x7FFFFFFF in + let lpos = Table.find h tbl in + (* First look for already live data *) + let find data = match data.obj with + | Some (k', v) -> if Key.equal k k' then Some v else None + | None -> None + in + match CList.find_map find lpos with + | res -> res + | exception Not_found -> + (* Otherwise perform I/O and look at the disk cache *) + let lpos = List.filter (fun data -> Option.is_empty data.obj) lpos in + let () = if CList.is_empty lpos then raise Not_found in + let ch = fopen_in t.file in + let find data = + let () = seek_in ch data.pos in + match Marshal.from_channel ch with + | (k', v) -> + if Key.equal k k' then + (* Store the data in memory *) + let () = data.obj <- Some (k, v) in + Some v + else None + | exception _ -> None + in + let lookup () = CList.find_map find lpos in + let res = do_under_lock Read (descr_of_out_channel outch) lookup in + let () = close_in_noerr ch in + res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 5c0aa9ef0d..7b29aa15f9 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -254,6 +254,16 @@ let is_strict c = c.op = Gt let eval_op = function Eq -> ( =/ ) | Ge -> ( >=/ ) | Gt -> ( >/ ) let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" +let compare_op o1 o2 = + match (o1, o2) with + | Eq, Eq -> 0 + | Eq, _ -> -1 + | _, Eq -> 1 + | Ge, Ge -> 0 + | Ge, _ -> -1 + | _, Ge -> 1 + | Gt, Gt -> 0 + let output_cstr o {coeffs; op; cst} = Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (Q.to_string cst) @@ -284,7 +294,11 @@ module LinPoly = struct if !fresh > vr then failwith (Printf.sprintf "Cannot reserve %i" vr) else fresh := vr + 1 - let get_fresh () = !fresh + let safe_reserve vr = if !fresh > vr then () else fresh := vr + 1 + + let get_fresh () = + let vr = !fresh in + incr fresh; vr let register m = try MonoMap.find m !index_of_monomial @@ -445,6 +459,7 @@ module ProofFormat = struct type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof @@ -471,6 +486,9 @@ module ProofFormat = struct | Done -> Printf.fprintf o "." | Step (i, p, pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Split (i, v, p1, p2) -> + Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 + output_proof p2 | Enum (i, p1, v, p2, pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i output_prf_rule p1 Vect.pp v output_prf_rule p2 (pp_list ";" output_proof) pl @@ -489,23 +507,36 @@ module ProofFormat = struct | CutPrf p -> pr_size p | MulC (v, p) -> pr_size p - let rec pr_rule_max_id = function - | Annot (_, p) -> pr_rule_max_id p - | Hyp i | Def i -> i + let rec pr_rule_max_hyp = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> i + | Def i -> -1 + | Cst _ | Zero | Square _ -> -1 + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_hyp p + | MulPrf (p1, p2) | AddPrf (p1, p2) -> + max (pr_rule_max_hyp p1) (pr_rule_max_hyp p2) + + let rec pr_rule_max_def = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> -1 + | Def i -> i | Cst _ | Zero | Square _ -> -1 - | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_id p + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_def p | MulPrf (p1, p2) | AddPrf (p1, p2) -> - max (pr_rule_max_id p1) (pr_rule_max_id p2) + max (pr_rule_max_def p1) (pr_rule_max_def p2) - let rec proof_max_id = function + let rec proof_max_def = function | Done -> -1 - | Step (i, pr, prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Step (i, pr, prf) -> max i (max (pr_rule_max_def pr) (proof_max_def prf)) + | Split (i, _, p1, p2) -> max i (max (proof_max_def p1) (proof_max_def p2)) | Enum (i, p1, _, p2, l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + let m = max (pr_rule_max_def p1) (pr_rule_max_def p2) in + List.fold_left (fun i prf -> max i (proof_max_def prf)) (max i m) l | ExProof (i, j, k, _, _, _, prf) -> - max (max (max i j) k) (proof_max_id prf) + max (max (max i j) k) (proof_max_def prf) + (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. + This is because the Coq proof format only accept they as a proof-step *) let rec pr_rule_def_cut id = function | Annot (_, p) -> pr_rule_def_cut id p | MulC (p, prf) -> @@ -536,46 +567,51 @@ module ProofFormat = struct let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p - let rec pr_rule_collect_hyps pr = + let rec pr_rule_collect_defs pr = match pr with - | Annot (_, pr) -> pr_rule_collect_hyps pr - | Hyp i | Def i -> ISet.add i ISet.empty + | Annot (_, pr) -> pr_rule_collect_defs pr + | Def i -> ISet.add i ISet.empty + | Hyp i -> ISet.empty | Cst _ | Zero | Square _ -> ISet.empty - | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_hyps pr + | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_defs pr | MulPrf (p1, p2) | AddPrf (p1, p2) -> - ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) - let simplify_proof p = - let rec simplify_proof p = - match p with - | Done -> (Done, ISet.empty) - | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) - | Step (i, pr, prf) -> - let prf', hyps = simplify_proof prf in - if not (ISet.mem i hyps) then (prf', hyps) - else - ( Step (i, pr, prf') - , ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps) ) - | Enum (i, p1, v, p2, pl) -> - let pl, hl = List.split (List.map simplify_proof pl) in - let hyps = List.fold_left ISet.union ISet.empty hl in - ( Enum (i, p1, v, p2, pl) - , ISet.add i - (ISet.union - (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) - hyps) ) - | ExProof (i, j, k, x, z, t, prf) -> - let prf', hyps = simplify_proof prf in - if - (not (ISet.mem i hyps)) - && (not (ISet.mem j hyps)) - && not (ISet.mem k hyps) - then (prf', hyps) - else - ( ExProof (i, j, k, x, z, t, prf') - , ISet.add i (ISet.add j (ISet.add k hyps)) ) - in - fst (simplify_proof p) + (** [simplify_proof p] removes proof steps that are never re-used. *) + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_defs pr)) + | Step (i, pr, prf) -> + let prf', hyps = simplify_proof prf in + if not (ISet.mem i hyps) then (prf', hyps) + else + ( Step (i, pr, prf') + , ISet.add i (ISet.union (pr_rule_collect_defs pr) hyps) ) + | Split (i, v, p1, p2) -> + let p1, h1 = simplify_proof p1 in + let p2, h2 = simplify_proof p2 in + if not (ISet.mem i h1) then (p1, h1) (* Should not have computed p2 *) + else if not (ISet.mem i h2) then (p2, h2) + else (Split (i, v, p1, p2), ISet.add i (ISet.union h1 h2)) + | Enum (i, p1, v, p2, pl) -> + let pl, hl = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + ( Enum (i, p1, v, p2, pl) + , ISet.add i + (ISet.union + (ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2)) + hyps) ) + | ExProof (i, j, k, x, z, t, prf) -> + let prf', hyps = simplify_proof prf in + if + (not (ISet.mem i hyps)) + && (not (ISet.mem j hyps)) + && not (ISet.mem k hyps) + then (prf', hyps) + else + ( ExProof (i, j, k, x, z, t, prf') + , ISet.add i (ISet.add j (ISet.add k hyps)) ) let rec normalise_proof id prf = match prf with @@ -591,6 +627,10 @@ module ProofFormat = struct bds in (id, prf) + | Split (i, v, p1, p2) -> + let id, p1 = normalise_proof id p1 in + let id, p2 = normalise_proof id p2 in + (id, Split (i, v, p1, p2)) | ExProof (i, j, k, x, z, t, prf) -> let id, prf = normalise_proof id prf in (id, ExProof (i, j, k, x, z, t, prf)) @@ -612,7 +652,7 @@ module ProofFormat = struct (bds2 @ bds1) ) let normalise_proof id prf = - let prf = simplify_proof prf in + let prf = fst (simplify_proof prf) in let res = normalise_proof id prf in if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof @@ -652,9 +692,9 @@ module ProofFormat = struct | Gcd (b1, p1), Gcd (b2, p2) -> cmp_pair Z.compare compare (b1, p1) (b2, p2) | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) - | AddPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) + cmp_pair compare compare (p1, p2) (q1, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, p2) (q1, q2) | CutPrf p, CutPrf p' -> compare p p' | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) end @@ -746,16 +786,23 @@ module ProofFormat = struct Zero vect module Env = struct - let rec string_of_int_list l = + let output_hyp_or_def o = function + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | _ -> () + + let rec output_hyps o l = match l with - | [] -> "" - | i :: l -> Printf.sprintf "%i,%s" i (string_of_int_list l) + | [] -> () + | i :: l -> Printf.fprintf o "%a,%a" output_hyp_or_def i output_hyps l let id_of_hyp hyp l = let rec xid_of_hyp i l' = match l' with | [] -> - failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + Printf.fprintf stdout "\nid_of_hyp: %a notin [%a]\n" output_hyp_or_def + hyp output_hyps l; + failwith "Cannot find hyp or def" | hyp' :: l' -> if hyp = hyp' then i else xid_of_hyp (i + 1) l' in xid_of_hyp 0 l @@ -764,7 +811,7 @@ module ProofFormat = struct let cmpl_prf_rule norm (cst : Q.t -> 'a) env prf = let rec cmpl = function | Annot (s, p) -> cmpl p - | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) + | (Hyp _ | Def _) as h -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp h env)) | Cst i -> Mc.PsatzC (cst i) | Zero -> Mc.PsatzZ | MulPrf (p1, p2) -> Mc.PsatzMulE (cmpl p1, cmpl p2) @@ -780,25 +827,40 @@ module ProofFormat = struct let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (Q.num x)) env r + let cmpl_pol_z lp = + try + let cst x = CamlToCoq.bigint (Q.num x) in + Mc.normZ (LinPoly.coq_poly_of_linpol cst lp) + with x -> + Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; + raise x + let rec cmpl_proof env = function | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with | CutPrf p' -> - Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (i :: env) prf) - | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (i :: env) prf) ) + Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (Def i :: env) prf) + | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (Def i :: env) prf) + ) + | Split (i, v, p1, p2) -> + Mc.SplitProof + ( cmpl_pol_z v + , cmpl_proof (Def i :: env) p1 + , cmpl_proof (Def i :: env) p2 ) | Enum (i, p1, _, p2, l) -> Mc.EnumProof ( cmpl_prf_rule_z env p1 , cmpl_prf_rule_z env p2 - , List.map (cmpl_proof (i :: env)) l ) + , List.map (cmpl_proof (Def i :: env)) l ) | ExProof (i, j, k, x, _, _, prf) -> - Mc.ExProof (CamlToCoq.positive x, cmpl_proof (i :: j :: k :: env) prf) + Mc.ExProof + (CamlToCoq.positive x, cmpl_proof (Def i :: Def j :: Def k :: env) prf) let compile_proof env prf = - let id = 1 + proof_max_id prf in + let id = 1 + proof_max_def prf in let _, prf = normalise_proof id prf in - cmpl_proof env prf + cmpl_proof (List.map (fun i -> Hyp i) env) prf let rec eval_prf_rule env = function | Annot (s, p) -> eval_prf_rule env p @@ -848,6 +910,7 @@ module ProofFormat = struct false end else eval_proof (IMap.add i (p, o) env) rst + | Split (i, v, p1, p2) -> failwith "Not implemented" | Enum (i, r1, v, r2, l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in @@ -863,7 +926,7 @@ module WithProof = struct let compare : t -> t -> int = fun ((lp1, o1), _) ((lp2, o2), _) -> let c = Vect.compare lp1 lp2 in - if c = 0 then compare o1 o2 else c + if c = 0 then compare_op o1 o2 else c let annot s (p, prf) = (p, ProofFormat.Annot (s, prf)) @@ -887,6 +950,13 @@ module WithProof = struct fun ((p1, o1), prf1) ((p2, o2), prf2) -> ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + let neg : t -> t = + fun ((p1, o1), prf1) -> + match o1 with + | Eq -> + ((Vect.mul Q.minus_one p1, o1), ProofFormat.mul_cst_proof Q.minus_one prf1) + | _ -> failwith "neg: invalid proof" + let mult p ((p1, o1), prf1) = match o1 with | Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1) @@ -912,13 +982,13 @@ module WithProof = struct else match o with | Eq -> - Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) + Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.CutPrf prf) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> (* This is a non-trivial common divisor *) Some ( (Vect.set 0 c1' (Vect.div (Q.of_bigint g) p), o) - , ProofFormat.Gcd (g, prf) ) + , ProofFormat.CutPrf prf ) let construct_sign p = let c, p' = Vect.decomp_cst p in @@ -1011,6 +1081,22 @@ module WithProof = struct | None -> sys0 | Some sys' -> sys' ) + let sort (sys : t list) = + let size ((p, o), prf) = + let _, p' = Vect.decomp_cst p in + let (x, q), p' = Vect.decomp_fst p' in + Vect.fold + (fun (l, (q, x)) x' q' -> + let q' = Q.abs q' in + (l + 1, if q </ q then (q, x) else (q', x'))) + (1, (Q.abs q, x)) + p + in + let cmp ((l1, (q1, _)), ((_, o), _)) ((l2, (q2, _)), ((_, o'), _)) = + if l1 < l2 then -1 else if l1 = l2 then Q.compare q1 q2 else 1 + in + List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) + let subst sys0 = let elim sys = let oeq, sys' = extract (is_substitution true) sys in @@ -1018,7 +1104,7 @@ module WithProof = struct | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in - iterate_until_stable elim sys0 + iterate_until_stable elim (List.map snd (sort sys0)) let saturate_subst b sys0 = let select = is_substitution b in @@ -1029,6 +1115,26 @@ module WithProof = struct in saturate select gen sys0 + let simple_pivot (q1, x) ((v1, o1), prf1) ((v2, o2), prf2) = + let q2 = Vect.get x v2 in + if q2 =/ Q.zero then None + else + let cv1, cv2 = + if Q.sign q1 <> Q.sign q2 then (Q.abs q2, Q.abs q1) + else + match (o1, o2) with + | Eq, _ -> (q2, Q.abs q1) + | _, Eq -> (Q.abs q2, q2) + | _, _ -> (Q.zero, Q.zero) + in + if cv2 =/ Q.zero then None + else + Some + ( (Vect.mul_add cv1 v1 cv2 v2, opAdd o1 o2) + , ProofFormat.add_proof + (ProofFormat.mul_cst_proof cv1 prf1) + (ProofFormat.mul_cst_proof cv2 prf2) ) + open Vect.Bound let mul_bound w1 w2 = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 9c09f76691..84b5421207 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -120,6 +120,7 @@ type cstr = {coeffs : Vect.t; op : op; cst : Q.t} and op = Eq | Ge | Gt val eval_op : op -> Q.t -> Q.t -> bool +val compare_op : op -> op -> int (*val opMult : op -> op -> op*) @@ -153,6 +154,9 @@ module LinPoly : sig (** [reserve i] reserves the integer i *) val reserve : int -> unit + (** [safe_reserve i] reserves the integer i *) + val safe_reserve : int -> unit + (** [get_fresh ()] return the first fresh variable *) val get_fresh : unit -> int @@ -283,14 +287,16 @@ module ProofFormat : sig type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof (* x = z - t, z >= 0, t >= 0 *) val pr_size : prf_rule -> Q.t - val pr_rule_max_id : prf_rule -> int - val proof_max_id : proof -> int + val pr_rule_max_def : prf_rule -> int + val pr_rule_max_hyp : prf_rule -> int + val proof_max_def : proof -> int val normalise_proof : int -> proof -> int * proof val output_prf_rule : out_channel -> prf_rule -> unit val output_proof : out_channel -> proof -> unit @@ -302,13 +308,16 @@ module ProofFormat : sig val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> (Q.t -> 'a) - -> int list + -> prf_rule list -> prf_rule -> 'a Micromega.psatz val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool + val simplify_proof : proof -> proof * Mutils.ISet.t + + module PrfRuleMap : Map.S with type key = prf_rule end val output_cstr : out_channel -> cstr -> unit @@ -344,6 +353,12 @@ module WithProof : sig @return the polynomial p+q with its sign and proof *) val addition : t -> t -> t + (** [neg p] + @return the polynomial -p with its sign and proof + @raise an error if this not an equality + *) + val neg : t -> t + (** [mult p q] @return the polynomial p*q with its sign and proof. @raise InvalidProof if p is not a constant and p is not an equality *) @@ -360,6 +375,13 @@ module WithProof : sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + (** [simple_pivot (c,x) p q] performs a pivoting over the variable [x] where + p = c+a1.x1+....+c.x+...an.xn and c <> 0 *) + val simple_pivot : Q.t * var -> t -> t -> t option + + (** [sort sys] sorts constraints according to the lexicographic order (number of variables, size of the smallest coefficient *) + val sort : t list -> ((int * (Q.t * var)) * t) list + (** [subst sys] performs the equivalent of the 'subst' tactic of Coq. For every p=0 \in sys such that p is linear in x with coefficient +/- 1 i.e. p = 0 <-> x = e and x \notin e. diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index f59d65085a..39024819be 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -60,6 +60,77 @@ let get_profile_info () = ( try (p.success_pivots + p.failure_pivots) / p.average_pivots with Division_by_zero -> 0 ) } +(* SMT output for debugging *) + +(* +let pp_smt_row o (k, v) = + Printf.fprintf o "(assert (= x%i %a))\n" k Vect.pp_smt v + +let pp_smt_assert_tbl o tbl = IMap.iter (fun k v -> pp_smt_row o (k, v)) tbl + +let pp_smt_goal_tbl o tbl = + let pp_rows o tbl = + IMap.iter (fun k v -> Printf.fprintf o "(= x%i %a)" k Vect.pp_smt v) tbl + in + Printf.fprintf o "(assert (not (and %a)))\n" pp_rows tbl + +let pp_smt_vars s o var = + ISet.iter + (fun i -> + Printf.fprintf o "(declare-const x%i %s);%a\n" i s LinPoly.pp_var i) + (ISet.remove 0 var) + +let pp_smt_goal s o tbl1 tbl2 = + let set_of_row vr v = ISet.add vr (Vect.variables v) in + let var = + IMap.fold (fun k v acc -> ISet.union (set_of_row k v) acc) tbl1 ISet.empty + in + Printf.fprintf o "(echo \"%s\")\n(push) %a %a %a (check-sat) (pop)\n" s + (pp_smt_vars "Real") var pp_smt_assert_tbl tbl1 pp_smt_goal_tbl tbl2; + flush stdout + +let pp_smt_cut o lp c = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + Printf.fprintf o + "(push) \n\ + (echo \"new cut\")\n\ + %a %a (assert (not (>= %a 0)))\n\ + (check-sat) (pop)\n" + (pp_smt_vars "Int") var pp_list lp Vect.pp_smt c + +let pp_smt_sat o lp sol = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + let pp_model o v = + Vect.fold + (fun () v x -> + Printf.fprintf o "(assert (= x%i %a))\n" v Vect.pp_smt (Vect.cst x)) + () v + in + Printf.fprintf o + "(push) \n(echo \"check base\")\n%a %a %a\n(check-sat) (pop)\n" + (pp_smt_vars "Real") var pp_list lp pp_model sol + *) + type iset = unit IMap.t (** Mapping basic variables to their equation. @@ -375,38 +446,6 @@ open Polynomial (*type varmap = (int * bool) IMap.t*) -let make_certificate vm l = - Vect.normalise - (Vect.fold - (fun acc x n -> - let x', b = IMap.find x vm in - Vect.set x' (if b then n else Q.neg n) acc) - Vect.null l) - -(** [eliminate_equalities vr0 l] - represents an equality e = 0 of index idx in the list l - by 2 constraints (vr:e >= 0) and (vr+1:-e >= 0) - The mapping vm maps vr to idx - *) - -let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) = - let rec elim idx vr vm l acc = - match l with - | [] -> (vr, vm, acc) - | c :: l -> ( - match c.op with - | Ge -> - let v = Vect.set 0 (Q.neg c.cst) c.coeffs in - elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc) - | Eq -> - let v1 = Vect.set 0 (Q.neg c.cst) c.coeffs in - let v2 = Vect.mul Q.minus_one v1 in - let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in - elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc) - | Gt -> raise Strict ) - in - elim 0 vr0 IMap.empty l [] - let find_solution rst tbl = IMap.fold (fun vr v res -> @@ -440,19 +479,9 @@ let rec solve opt l (rst : Restricted.t) (t : tableau) = | Some ((vr, v), l) -> ( match push_real opt vr v (Restricted.set_exc vr rst) t with | Sat (t', x) -> ( - (* let t' = remove_redundant rst t' in*) - match l with - | [] -> Inl (rst, t', x) - | _ -> solve opt l rst t' ) + match l with [] -> Inl (rst, t', x) | _ -> solve opt l rst t' ) | Unsat c -> Inr c ) -let find_unsat_certificate (l : Polynomial.cstr list) = - let vr = LinPoly.MonT.get_fresh () in - let _, vm, l' = eliminate_equalities vr l in - match solve false l' (Restricted.make vr) IMap.empty with - | Inr c -> Some (make_certificate vm c) - | Inl _ -> None - let fresh_var l = 1 + @@ -463,64 +492,110 @@ let fresh_var l = ISet.empty l) with Not_found -> 0 +module PrfEnv = struct + type t = WithProof.t IMap.t + + let empty = IMap.empty + + let register prf env = + let fr = LinPoly.MonT.get_fresh () in + (fr, IMap.add fr prf env) + + (* let register_def (v, op) {fresh; env} = + LinPoly.MonT.reserve fresh; + (fresh, {fresh = fresh + 1; env = IMap.add fresh ((v, op), Def fresh) env}) *) + + let set_prf i prf env = IMap.add i prf env + let find idx env = IMap.find idx env + + let rec of_list acc env l = + match l with + | [] -> (acc, env) + | (((lp, op), prf) as wp) :: l -> ( + match op with + | Gt -> raise Strict (* Should be eliminated earlier *) + | Ge -> + (* Simply register *) + let f, env' = register wp env in + of_list ((f, lp) :: acc) env' l + | Eq -> + (* Generate two constraints *) + let f1, env = register wp env in + let wp' = WithProof.neg wp in + let f2, env = register wp' env in + of_list ((f1, lp) :: (f2, fst (fst wp')) :: acc) env l ) + + let map f env = IMap.map f env +end + +let make_env (l : Polynomial.cstr list) = + PrfEnv.of_list [] PrfEnv.empty + (List.rev_map WithProof.of_cstr + (List.mapi (fun i x -> (x, ProofFormat.Hyp i)) l)) + let find_point (l : Polynomial.cstr list) = let vr = fresh_var l in - let _, vm, l' = eliminate_equalities vr l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env l in match solve false l' (Restricted.make vr) IMap.empty with | Inl (rst, t, _) -> Some (find_solution rst t) | _ -> None let optimise obj l = - let vr0 = LinPoly.MonT.get_fresh () in - let _, vm, l' = eliminate_equalities (vr0 + 1) l in + let vr = fresh_var l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env l in let bound pos res = match res with | Opt (_, Max n) -> Some (if pos then n else Q.neg n) | Opt (_, Ubnd _) -> None | Opt (_, Feas) -> None in - match solve false l' (Restricted.make vr0) IMap.empty with + match solve false l' (Restricted.make vr) IMap.empty with | Inl (rst, t, _) -> Some - ( bound false (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))) - , bound true (simplex true vr0 rst (add_row vr0 t obj)) ) + ( bound false (simplex true vr rst (add_row vr t (Vect.uminus obj))) + , bound true (simplex true vr rst (add_row vr t obj)) ) | _ -> None -open Polynomial +(** [make_certificate env l] makes very strong assumptions + about the form of the environment. + Each proof is assumed to be either: + - an hypothesis Hyp i + - or, the negation of an hypothesis (MulC(-1,Hyp i)) + *) -let env_of_list l = - List.fold_left (fun (i, m) l -> (i + 1, IMap.add i l m)) (0, IMap.empty) l +let make_certificate env l = + Vect.normalise + (Vect.fold + (fun acc x n -> + let _, prf = PrfEnv.find x env in + ProofFormat.( + match prf with + | Hyp i -> Vect.set i n acc + | MulC (_, Hyp i) -> Vect.set i (Q.neg n) acc + | _ -> failwith "make_certificate: invalid proof")) + Vect.null l) + +let find_unsat_certificate (l : Polynomial.cstr list) = + let l', env = make_env l in + let vr = fresh_var l in + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate env c) + | Inl _ -> None +open Polynomial open ProofFormat -let make_farkas_certificate (env : WithProof.t IMap.t) vm v = +let make_farkas_certificate (env : PrfEnv.t) v = Vect.fold - (fun acc x n -> - add_proof acc - begin - try - let x', b = IMap.find x vm in - mul_cst_proof (if b then n else Q.neg n) (snd (IMap.find x' env)) - with Not_found -> - (* This is an introduced hypothesis *) - mul_cst_proof n (snd (IMap.find x env)) - end) + (fun acc x n -> add_proof acc (mul_cst_proof n (snd (PrfEnv.find x env)))) Zero v -let make_farkas_proof (env : WithProof.t IMap.t) vm v = +let make_farkas_proof (env : PrfEnv.t) v = Vect.fold (fun wp x n -> - WithProof.addition wp - begin - try - let x', b = IMap.find x vm in - let n = if b then n else Q.neg n in - let prf = IMap.find x' env in - WithProof.mult (Vect.cst n) prf - with Not_found -> - let prf = IMap.find x env in - WithProof.mult (Vect.cst n) prf - end) + WithProof.addition wp (WithProof.mult (Vect.cst n) (PrfEnv.find x env))) WithProof.zero v let frac_num n = n -/ Q.floor n @@ -532,9 +607,15 @@ type ('a, 'b) hitkind = (* Yes, we have a positive result *) | Keep of 'b -let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = +let violation sol vect = + let sol = Vect.set 0 Q.one sol in + let c = Vect.get 0 vect in + if Q.zero =/ c then Vect.dotproduct sol vect + else Q.abs (Vect.dotproduct sol vect // c) + +let cut env rmin sol (rst : Restricted.t) tbl (x, v) = let n, r = Vect.decomp_cst v in - let fn = frac_num n in + let fn = frac_num (Q.abs n) in if fn =/ Q.zero then Forget (* The solution is integral *) else (* The cut construction is from: @@ -580,7 +661,7 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = in let lcut = ( fst ccoeff - , make_farkas_proof env vm (Vect.normalise (cut_vector (snd ccoeff))) ) + , make_farkas_proof env (Vect.normalise (cut_vector (snd ccoeff))) ) in let check_cutting_plane (p, c) = match WithProof.cutting_plane c with @@ -592,7 +673,9 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = | Some (v, prf) -> if debug then ( Printf.printf "%s: This is a cutting plane for %a:" p LinPoly.pp_var x; - Printf.printf " %a\n" WithProof.output (v, prf) ); + Printf.printf "(viol %f) %a\n" + (Q.to_float (violation sol (fst v))) + WithProof.output (v, prf) ); Some (x, (v, prf)) in match check_cutting_plane lcut with @@ -621,30 +704,69 @@ let merge_best lt oldr newr = | Forget, Keep v -> Keep v | Keep v, Keep v' -> Keep v' -let find_cut nb env u sol vm rst tbl = +(*let size_vect v = + let abs z = if Z.compare z Z.zero < 0 then Z.neg z else z in + Vect.fold + (fun acc _ q -> Z.add (abs (Q.num q)) (Z.add (Q.den q) acc)) + Z.zero v + *) + +let find_cut nb env u sol rst tbl = if nb = 0 then IMap.fold - (fun x v acc -> merge_result_old acc (cut env u sol vm rst tbl) (x, v)) + (fun x v acc -> merge_result_old acc (cut env u sol rst tbl) (x, v)) tbl Forget else - let lt (_, (_, p1)) (_, (_, p2)) = + let lt (_, ((v1, _), p1)) (_, ((v2, _), p2)) = + (*violation sol v1 >/ violation sol v2*) ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 in IMap.fold - (fun x v acc -> merge_best lt acc (cut env u sol vm rst tbl (x, v))) + (fun x v acc -> merge_best lt acc (cut env u sol rst tbl (x, v))) tbl Forget +let find_split env tbl rst = + let is_split x v = + let v, n = + let n, _ = Vect.decomp_cst v in + if Restricted.is_restricted x rst then + let n', v = Vect.decomp_cst (fst (fst (PrfEnv.find x env))) in + (v, n -/ n') + else (Vect.set x Q.one Vect.null, n) + in + if Restricted.is_restricted x rst then None + else + let fn = frac_num n in + if fn =/ Q.zero then None + else + let fn = Q.abs fn in + let score = Q.min fn (Q.one -/ fn) in + let vect = Vect.add (Vect.cst (Q.neg n)) v in + Some (Vect.normalise vect, score) + in + IMap.fold + (fun x v acc -> + match is_split x v with + | None -> acc + | Some (v, s) -> ( + match acc with + | None -> Some (v, s) + | Some (v', s') -> if s' >/ s then acc else Some (v, s) )) + tbl None + let var_of_vect v = fst (fst (Vect.decomp_fst v)) -let eliminate_variable (bounded, vr, env, tbl) x = +let eliminate_variable (bounded, env, tbl) x = if debug then Printf.printf "Eliminating variable %a from tableau\n%a\n" LinPoly.pp_var x output_tableau tbl; (* We identify the new variables with the constraint. *) - LinPoly.MonT.reserve vr; - let z = LinPoly.var (vr + 1) in + let vr = LinPoly.MonT.get_fresh () in + let vr1 = LinPoly.MonT.get_fresh () in + let vr2 = LinPoly.MonT.get_fresh () in + let z = LinPoly.var vr1 in let zv = var_of_vect z in - let t = LinPoly.var (vr + 2) in + let t = LinPoly.var vr2 in let tv = var_of_vect t in (* x = z - t *) let xdef = Vect.add z (Vect.uminus t) in @@ -653,9 +775,9 @@ let eliminate_variable (bounded, vr, env, tbl) x = let tp = ((t, Ge), Def tv) in (* Pivot the current tableau using xdef *) let tbl = IMap.map (fun v -> Vect.subst x xdef v) tbl in - (* Pivot the environment *) + (* Pivot the proof environment *) let env = - IMap.map + PrfEnv.map (fun lp -> let (v, o), p = lp in let ai = Vect.get x v in @@ -664,77 +786,123 @@ let eliminate_variable (bounded, vr, env, tbl) x = env in (* Add the variables to the environment *) - let env = IMap.add vr xp (IMap.add zv zp (IMap.add tv tp env)) in + let env = + PrfEnv.set_prf vr xp (PrfEnv.set_prf zv zp (PrfEnv.set_prf tv tp env)) + in (* Remember the mapping *) let bounded = IMap.add x (vr, zv, tv) bounded in if debug then ( Printf.printf "Tableau without\n %a\n" output_tableau tbl; Printf.printf "Environment\n %a\n" output_env env ); - (bounded, vr + 3, env, tbl) + (bounded, env, tbl) let integer_solver lp = - let l, _ = List.split lp in - let vr0 = 3 * LinPoly.MonT.get_fresh () in - let vr, vm, l' = eliminate_equalities vr0 l in - let _, env = env_of_list (List.map WithProof.of_cstr lp) in let insert_row vr v rst tbl = match push_real true vr v rst tbl with - | Sat (t', x) -> Inl (Restricted.restrict vr rst, t', x) + | Sat (t', x) -> + (*pp_smt_goal stdout tbl vr v t';*) + Inl (Restricted.restrict vr rst, t', x) | Unsat c -> Inr c in + let vr0 = LinPoly.MonT.get_fresh () in + (* Initialise the proof environment mapping variables of the simplex to their proof. *) + let l', env = + PrfEnv.of_list [] PrfEnv.empty (List.rev_map WithProof.of_cstr lp) + in let nb = ref 0 in - let rec isolve env cr vr res = + let rec isolve env cr res = incr nb; match res with | Inr c -> - Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c), Done)) + Some + (Step + ( LinPoly.MonT.get_fresh () + , make_farkas_certificate env (Vect.normalise c) + , Done )) | Inl (rst, tbl, x) -> ( if debug then begin Printf.fprintf stdout "Looking for a cut\n"; Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; flush stdout - (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; - let sol = find_full_solution rst tbl in - match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with - | Forget -> - None (* There is no hope, there should be an integer solution *) - | Hit (cr, ((v, op), cut)) -> - if op = Eq then - (* This is a contradiction *) - Some (Step (vr, CutPrf cut, Done)) - else ( - LinPoly.MonT.reserve vr; - let res = insert_row vr v (Restricted.set_exc vr rst) tbl in - let prf = - isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) (vr + 1) res + if !nb mod 3 = 0 then + match find_split env tbl rst with + | None -> + None (* There is no hope, there should be an integer solution *) + | Some (v, s) -> ( + let vr = LinPoly.MonT.get_fresh () in + let wp1 = ((v, Ge), Def vr) in + let wp2 = ((Vect.mul Q.minus_one v, Ge), Def vr) in + match (WithProof.cutting_plane wp1, WithProof.cutting_plane wp2) with + | None, _ | _, None -> + failwith "Error: splitting over an integer variable" + | Some wp1, Some wp2 -> ( + if debug then + Printf.fprintf stdout "Splitting over (%s) %a:%a or %a \n" + (Q.to_string s) LinPoly.pp_var vr WithProof.output wp1 + WithProof.output wp2; + let v1', v2' = (fst (fst wp1), fst (fst wp2)) in + if debug then + Printf.fprintf stdout "Solving with %a\n" LinPoly.pp v1'; + let res1 = insert_row vr v1' (Restricted.set_exc vr rst) tbl in + let prf1 = isolve (IMap.add vr ((v1', Ge), Def vr) env) cr res1 in + match prf1 with + | None -> None + | Some prf1 -> + let prf', hyps = ProofFormat.simplify_proof prf1 in + if not (ISet.mem vr hyps) then Some prf' + else ( + if debug then + Printf.fprintf stdout "Solving with %a\n" Vect.pp v2'; + let res2 = insert_row vr v2' (Restricted.set_exc vr rst) tbl in + let prf2 = + isolve (IMap.add vr ((v2', Ge), Def vr) env) cr res2 + in + match prf2 with + | None -> None + | Some prf2 -> Some (Split (vr, v, prf1, prf2)) ) ) ) + else + let sol = find_full_solution rst tbl in + match find_cut (!nb mod 2) env cr (*x*) sol rst tbl with + | Forget -> + None (* There is no hope, there should be an integer solution *) + | Hit (cr, ((v, op), cut)) -> ( + let vr = LinPoly.MonT.get_fresh () in + if op = Eq then + (* This is a contradiction *) + Some (Step (vr, CutPrf cut, Done)) + else + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = + isolve (IMap.add vr ((v, op), Def vr) env) (Some cr) res + in + match prf with + | None -> None + | Some p -> Some (Step (vr, CutPrf cut, p)) ) + | Keep (x, v) -> ( + if debug then + Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; + let bounded, env, tbl = + Vect.fold + (fun acc x n -> + if x <> 0 && not (Restricted.is_restricted x rst) then + eliminate_variable acc x + else acc) + (IMap.empty, env, tbl) v in + let prf = isolve env cr (Inl (rst, tbl, None)) in match prf with | None -> None - | Some p -> Some (Step (vr, CutPrf cut, p)) ) - | Keep (x, v) -> ( - if debug then - Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; - let bounded, vr, env, tbl = - Vect.fold - (fun acc x n -> - if x <> 0 && not (Restricted.is_restricted x rst) then - eliminate_variable acc x - else acc) - (IMap.empty, vr, env, tbl) v - in - let prf = isolve env cr vr (Inl (rst, tbl, None)) in - match prf with - | None -> None - | Some pf -> - Some - (IMap.fold - (fun x (vr, zv, tv) acc -> ExProof (vr, zv, tv, x, zv, tv, acc)) - bounded pf) ) ) + | Some pf -> + Some + (IMap.fold + (fun x (vr, zv, tv) acc -> + ExProof (vr, zv, tv, x, zv, tv, acc)) + bounded pf) ) ) in let res = solve true l' (Restricted.make vr0) IMap.empty in - isolve env None vr res + isolve env None res let integer_solver lp = nb_pivot := 0; diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index 4df32f2ba4..fe1d721b89 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -57,12 +57,17 @@ let pp_var_num pp_var o {var = v; coe = n} = else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v let pp_var_num_smt pp_var o {var = v; coe = n} = - if Int.equal v 0 then - if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) + let pp_num o q = + let nn = Q.num n in + let dn = Q.den n in + if Z.equal dn Z.one then output_string o (Z.to_string nn) + else Printf.fprintf o "(/ %s %s)" (Z.to_string nn) (Z.to_string dn) + in + if Int.equal v 0 then if Q.zero =/ n then () else pp_num o n else if Q.one =/ n then pp_var o v else if Q.minus_one =/ n then Printf.fprintf o "(- %a)" pp_var v else if Q.zero =/ n then () - else Printf.fprintf o "(* %s %a)" (Q.to_string n) pp_var v + else Printf.fprintf o "(* %a %a)" pp_num n pp_var v let rec pp_gen pp_var o v = match v with diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 9db6c075f8..b4742430fa 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -56,8 +56,8 @@ val get_cst : t -> Q.t (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> Q.t * t -(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) -val decomp_at : int -> t -> Q.t * t +(** [decomp_at xi v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : var -> t -> Q.t * t val decomp_fst : t -> (var * Q.t) * t diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 917961fdcd..d1403558ad 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -1070,6 +1070,28 @@ let pp_trans_expr env evd e res = Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); res +let declared_term env evd hd args = + let match_operator (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp (hd, Array.sub args 0 (n - i)) in + if is_convertible env evd t' t then Some (t, Array.sub args (n - i) i) + else None + in + match t with + | OtherTerm t -> ( match d with InjTyp _ -> None | _ -> Some (t, args) ) + | Application t -> ( + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None ) + in + find_option match_operator (HConstr.find_all hd !table) + let rec trans_expr env evd e = let inj = e.inj in let e = e.constr in diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 537e652fd0..555bb4c7fb 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -31,3 +31,10 @@ val iter_specs : unit Proofview.tactic val assert_inj : EConstr.constr -> unit Proofview.tactic val iter_let : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic val elim_let : unit Proofview.tactic + +val declared_term : + Environ.env + -> Evd.evar_map + -> EConstr.t + -> EConstr.t array + -> EConstr.constr * EConstr.t array diff --git a/test-suite/.csdp.cache.test-suite b/test-suite/.csdp.cache.test-suite Binary files differindex 36efdf469e..5bd4f65546 100644 --- a/test-suite/.csdp.cache.test-suite +++ b/test-suite/.csdp.cache.test-suite diff --git a/test-suite/bugs/closed/bug_13453.v b/test-suite/bugs/closed/bug_13453.v new file mode 100644 index 0000000000..4d0e435df7 --- /dev/null +++ b/test-suite/bugs/closed/bug_13453.v @@ -0,0 +1,6 @@ +Require Extraction. + +Primitive array := #array_type. + +Definition a : array nat := [| 0%nat | 0%nat |]. +Extraction a. diff --git a/test-suite/bugs/closed/bug_7967.v b/test-suite/bugs/closed/bug_7967.v index 2c8855fd54..987a820831 100644 --- a/test-suite/bugs/closed/bug_7967.v +++ b/test-suite/bugs/closed/bug_7967.v @@ -1,2 +1,6 @@ Set Universe Polymorphism. Inductive A@{} : Set := B : ltac:(let y := constr:(Type) in exact nat) -> A. + +(* A similar bug *) +Context (C := ltac:(let y := constr:(Type) in exact nat)). +Check C@{}. diff --git a/test-suite/complexity/bug_13227_1.v b/test-suite/complexity/bug_13227_1.v new file mode 100644 index 0000000000..25aae05217 --- /dev/null +++ b/test-suite/complexity/bug_13227_1.v @@ -0,0 +1,28 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall Y r0 r q q0 r1 q1 : Z, + 3 = 4294967296 * q1 + r1 -> + Y - r1 = 4294967296 * q0 + r0 -> + r1 < 4294967296 -> + 0 <= r1 -> + r0 < 4294967296 -> + 0 <= r0 -> + r < 4 -> + 0 <= r -> + 0 < 4 -> + r0 = 4 * q + r -> + Y < 4294967296 -> + 0 <= Y -> + r = 0 -> + r0 < 268517376 -> + 268513280 <= r0 -> + 268587008 <= Y -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_2.v b/test-suite/complexity/bug_13227_2.v new file mode 100644 index 0000000000..25aae05217 --- /dev/null +++ b/test-suite/complexity/bug_13227_2.v @@ -0,0 +1,28 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall Y r0 r q q0 r1 q1 : Z, + 3 = 4294967296 * q1 + r1 -> + Y - r1 = 4294967296 * q0 + r0 -> + r1 < 4294967296 -> + 0 <= r1 -> + r0 < 4294967296 -> + 0 <= r0 -> + r < 4 -> + 0 <= r -> + 0 < 4 -> + r0 = 4 * q + r -> + Y < 4294967296 -> + 0 <= Y -> + r = 0 -> + r0 < 268517376 -> + 268513280 <= r0 -> + 268587008 <= Y -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_3.v b/test-suite/complexity/bug_13227_3.v new file mode 100644 index 0000000000..707e06e174 --- /dev/null +++ b/test-suite/complexity/bug_13227_3.v @@ -0,0 +1,46 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) + (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), + two64 = 2 ^ 64 -> + r3 = 8 * Z.of_nat length_xs -> + r2 = 8 * Z.of_nat length_x -> + 0 <= 8 * Z.of_nat length_x -> + 8 * Z.of_nat length_x < two64 -> + r1 = 2 ^ 4 * q + r -> + 0 < 2 ^ 4 -> + 0 <= r -> + r < 2 ^ 4 -> + x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> + 0 < two64 -> + 0 <= r0 -> + r0 < two64 -> + 8 * Z.of_nat length_x = two64 * q1 + r1 -> + 0 <= r1 -> + r1 < two64 -> + x2 - x1 = two64 * q2 + r2 -> + 0 <= r2 -> + r2 < two64 -> + right - left = two64 * q3 + r3 -> + 0 <= r3 -> + r3 < two64 -> + Z.of_nat length_x = Z.of_nat v -> + 0 <= Z.of_nat length_x -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat v -> + (r2 = 0 -> False) -> + (2 ^ 4 = 0 -> False) -> + (2 ^ 4 < 0 -> False) -> + (two64 = 0 -> False) -> + (two64 < 0 -> False) -> + (r0 < 8 * Z.of_nat length_x -> False) -> + False. +Proof. + intros. + subst. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_4.v b/test-suite/complexity/bug_13227_4.v new file mode 100644 index 0000000000..32cbd4e187 --- /dev/null +++ b/test-suite/complexity/bug_13227_4.v @@ -0,0 +1,45 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (two64 right left : Z) (length_xs v : nat) (x2 x1 : Z) + (length_x : nat) (r3 r2 q r r1 q0 r0 q1 q2 q3 : Z), + two64 = 2 ^ 64 -> + r3 = 8 * Z.of_nat length_xs -> + r2 = 8 * Z.of_nat length_x -> + 0 <= 8 * Z.of_nat length_x -> + 8 * Z.of_nat length_x < two64 -> + r1 = 2 ^ 4 * q + r -> + 0 < 2 ^ 4 -> + 0 <= r -> + r < 2 ^ 4 -> + x1 + q * 2 ^ 3 - x1 = two64 * q0 + r0 -> + 0 < two64 -> + 0 <= r0 -> + r0 < two64 -> + 8 * Z.of_nat length_x = two64 * q1 + r1 -> + 0 <= r1 -> + r1 < two64 -> + x2 - x1 = two64 * q2 + r2 -> + 0 <= r2 -> + r2 < two64 -> + right - left = two64 * q3 + r3 -> + 0 <= r3 -> + r3 < two64 -> + Z.of_nat length_x = Z.of_nat v -> + 0 <= Z.of_nat length_x -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat v -> + (r2 = 0 -> False) -> + (2 ^ 4 = 0 -> False) -> + (2 ^ 4 < 0 -> False) -> + (two64 = 0 -> False) -> + (two64 < 0 -> False) -> + (r0 < 8 * Z.of_nat length_x -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_5.v b/test-suite/complexity/bug_13227_5.v new file mode 100644 index 0000000000..4869c4c6b4 --- /dev/null +++ b/test-suite/complexity/bug_13227_5.v @@ -0,0 +1,79 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +Axiom word: Type. + +(* Expected time < 1.00s *) +Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) (x : list word) + (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 r4 q3 q4 + r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 z83 z84 : Z), + z84 = 0 -> + Z.of_nat (Datatypes.length x) - (z83 + 1) <= 0 -> + z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> + z83 = 0 -> + q0 <= 0 -> + 0 <= Z.of_nat v -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat (Datatypes.length x) -> + Z.of_nat (Datatypes.length x) = Z.of_nat v -> + r14 < 2 ^ 64 -> + 0 <= r14 -> + right - left = 2 ^ 64 * q14 + r14 -> + r13 < 2 ^ 64 -> + 0 <= r13 -> + r10 - x1 = 2 ^ 64 * q13 + r13 -> + r12 < 2 ^ 64 -> + 0 <= r12 -> + q = 2 ^ 64 * q12 + r12 -> + r11 < 2 ^ 64 -> + 0 <= r11 -> + r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> + r10 < 2 ^ 64 -> + 0 <= r10 -> + x1 + r11 = 2 ^ 64 * q10 + r10 -> + r9 < 2 ^ 64 -> + 0 <= r9 -> + r10 + r3 = 2 ^ 64 * q9 + r9 -> + r8 < 2 ^ 64 -> + 0 <= r8 -> + x2 - x1 = 2 ^ 64 * q8 + r8 -> + r7 < 2 ^ 64 -> + 0 <= r7 -> + Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> + r6 < 2 ^ 64 -> + 0 <= r6 -> + Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> + r5 < 2 ^ 64 -> + 0 <= r5 -> + x1 + r6 = 2 ^ 64 * q5 + r5 -> + r4 < 2 ^ 64 -> + 0 <= r4 -> + r5 - x1 = 2 ^ 64 * q4 + r4 -> + r3 < 2 ^ 64 -> + 0 <= r3 -> + 8 = 2 ^ 64 * q3 + r3 -> + r2 < r3 -> + 0 <= r2 -> + r4 = r3 * q2 + r2 -> + r1 < 2 ^ 64 -> + 0 <= r1 -> + 0 < 2 ^ 64 -> + x2 - r9 = 2 ^ 64 * q1 + r1 -> + r0 < r3 -> + 0 <= r0 -> + 0 < r3 -> + r13 = r3 * q0 + r0 -> + r < 2 ^ 4 -> + 0 <= r -> + 0 < 2 ^ 4 -> + r8 = 2 ^ 4 * q + r -> + r8 = 8 * Z.of_nat (Datatypes.length x) -> + r14 = 8 * Z.of_nat length_xs -> + (r1 = 8 * z84 -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/complexity/bug_13227_6.v b/test-suite/complexity/bug_13227_6.v new file mode 100644 index 0000000000..800aa4f625 --- /dev/null +++ b/test-suite/complexity/bug_13227_6.v @@ -0,0 +1,16 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +(* Expected time < 1.00s *) +Goal forall (x2 x3 x : Z) + (H : 0 <= 1073741824 * x + x2 - 67146752) + (H0 : 0 <= -8192 + x2) + (H1 : 0 <= 34816 + - x2) + (H2 : 0 <= -1073741824 * x - x2 + 1073741823), + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/micromega/bug_13227_1.v b/test-suite/micromega/bug_13227_1.v new file mode 100644 index 0000000000..fa6aa53447 --- /dev/null +++ b/test-suite/micromega/bug_13227_1.v @@ -0,0 +1,75 @@ +Require Import Lia ZArith. +Open Scope Z_scope. + +Unset Lia Cache. + +Axiom word: Type. + +Goal forall (right left : Z) (length_xs : nat) (r14 : Z) (v : nat) + (x : list word) (x2 x1 r8 q2 q r q0 r0 r3 r10 r13 q1 r1 r9 r2 + r4 q3 q4 r5 q5 r6 q6 r7 q7 q8 q9 q10 r11 q11 r12 q12 q13 q14 + z83 z84 : Z), + z84 = Z.of_nat (Datatypes.length x) - (z83 + 1) -> + 0 < Z.of_nat (Datatypes.length x) - (z83 + 1) -> + z83 = 0 -> + q0 <= 0 -> + 0 <= Z.of_nat v -> + 0 <= Z.of_nat length_xs -> + 0 <= Z.of_nat (Datatypes.length x) -> + Z.of_nat (Datatypes.length x) = Z.of_nat v -> + r14 < 2 ^ 64 -> + 0 <= r14 -> + right - left = 2 ^ 64 * q14 + r14 -> + r13 < 2 ^ 64 -> + 0 <= r13 -> + r10 - x1 = 2 ^ 64 * q13 + r13 -> + r12 < 2 ^ 64 -> + 0 <= r12 -> + q = 2 ^ 64 * q12 + r12 -> + r11 < 2 ^ 64 -> + 0 <= r11 -> + r12 * 2 ^ 3 = 2 ^ 64 * q11 + r11 -> + r10 < 2 ^ 64 -> + 0 <= r10 -> + x1 + r11 = 2 ^ 64 * q10 + r10 -> + r9 < 2 ^ 64 -> + 0 <= r9 -> + r10 + r3 = 2 ^ 64 * q9 + r9 -> + r8 < 2 ^ 64 -> + 0 <= r8 -> + x2 - x1 = 2 ^ 64 * q8 + r8 -> + r7 < 2 ^ 64 -> + 0 <= r7 -> + Z.shiftr r8 4 = 2 ^ 64 * q7 + r7 -> + r6 < 2 ^ 64 -> + 0 <= r6 -> + Z.shiftl r7 3 = 2 ^ 64 * q6 + r6 -> + r5 < 2 ^ 64 -> + 0 <= r5 -> + x1 + r6 = 2 ^ 64 * q5 + r5 -> + r4 < 2 ^ 64 -> + 0 <= r4 -> + r5 - x1 = 2 ^ 64 * q4 + r4 -> + r3 < 2 ^ 64 -> + 0 <= r3 -> + 8 = 2 ^ 64 * q3 + r3 -> + r2 < r3 -> + 0 <= r2 -> + r4 = r3 * q2 + r2 -> + r1 < 2 ^ 64 -> + 0 <= r1 -> + 0 < 2 ^ 64 -> + x2 - r9 = 2 ^ 64 * q1 + r1 -> + r0 < r3 -> + 0 <= r0 -> + 0 < r3 -> + r13 = r3 * q0 + r0 -> + r8 = 2 ^ 4 * q + r -> + r8 = 8 * Z.of_nat (Datatypes.length x) -> + r14 = 8 * Z.of_nat length_xs -> + (r1 = 8 * z84 -> False) -> + False. +Proof. + intros. + Time lia. +Qed. diff --git a/test-suite/micromega/int63.v b/test-suite/micromega/int63.v index 20dfa2631e..15146187ca 100644 --- a/test-suite/micromega/int63.v +++ b/test-suite/micromega/int63.v @@ -1,5 +1,6 @@ -Require Import ZArith ZifyInt63 Lia. +Require Import ZArith Lia. Require Import Int63. +Require ZifyInt63. Open Scope int63_scope. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index df64ae2af3..3477a293e3 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -31,12 +31,6 @@ end : Expr -> Expr [(1 + 1)] : Expr -Let "x" e1 e2 - : expr -Let "x" e1 e2 - : expr -Let "x" e1 e2 : list string - : list string myAnd1 True True : Prop r 2 3 @@ -65,8 +59,6 @@ where |- Type] (pat, p0, p cannot be used) fun '{| |} => true : R -> bool -b = a - : Prop The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". The command has indeed failed with message: @@ -85,18 +77,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 226, characters 0-160: +File "stdin", line 184, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 239, characters 0-60: +File "stdin", line 197, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 243, characters 0-64: +File "stdin", line 201, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 248, characters 0-62: +File "stdin", line 206, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -105,10 +97,10 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 276, characters 0-61: +File "stdin", line 234, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 280, characters 0-63: +File "stdin", line 238, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] fun x : nat => U (S x) @@ -119,7 +111,7 @@ fun x : nat => V x : forall x : nat, nat * (?T -> ?T) where ?T : [x : nat x0 : ?T |- Type] (x0 cannot be used) -File "stdin", line 297, characters 0-30: +File "stdin", line 255, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index ce488fe18d..ebad12af88 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -79,35 +79,7 @@ Check [1 + 1]. End C. -(* An example of interaction between coercion and notations from - Robbert Krebbers. *) - -Require Import String. - -Module D. - -Inductive expr := - | Var : string -> expr - | Lam : string -> expr -> expr - | App : expr -> expr -> expr. - -Notation Let x e1 e2 := (App (Lam x e2) e1). - -Parameter e1 e2 : expr. - -Check (Let "x" e1 e2). - -Coercion App : expr >-> Funclass. - -Check (Let "x" e1 e2). - -Axiom free_vars :> expr -> list string. - -Check (Let "x" e1 e2) : list string. - -End D. - -(* Fixing bugs reported by G. Gonthier in #9207 *) +(* Fixing overparenthesizing reported by G. Gonthier in #9207 (PR #9214, in 8.10)*) Module I. @@ -152,20 +124,6 @@ Check fun '{|n:=x|} => true. End EmptyRecordSyntax. -Module L. - -(* Testing regression #11053 *) - -Section Test. -Variables (A B : Type) (a : A) (b : B). -Variable c : A -> B. -Coercion c : A >-> B. -Notation COERCION := (c). -Check b = a. -End Test. - -End L. - Module M. (* Accept boxes around the end variables of a recursive notation (if equal boxes) *) diff --git a/test-suite/output/NotationsCoercions.out b/test-suite/output/NotationsCoercions.out new file mode 100644 index 0000000000..56145e5fa5 --- /dev/null +++ b/test-suite/output/NotationsCoercions.out @@ -0,0 +1,22 @@ +Let "x" e1 e2 + : expr +Let "x" e1 e2 + : expr +Let "x" e1 e2 : list string + : list string +b = a + : Prop +foo + : (_ BitVec 32) +#[ r ] 0 + : nat +##[ r ] + : nat +##[ r ] + : nat +#[ r ] 0 + : nat +##[ r ] + : nat +##[ r ] + : nat diff --git a/test-suite/output/NotationsCoercions.v b/test-suite/output/NotationsCoercions.v new file mode 100644 index 0000000000..0524bed98c --- /dev/null +++ b/test-suite/output/NotationsCoercions.v @@ -0,0 +1,77 @@ +(* Tests about skipping a coercion vs using a notation involving a coercion *) + +Require Import String. + +(* Skipping a coercion vs using a notation for the application of the + coercion (from Robbert Krebbers, see PR #8890) *) + +Module A. + +Inductive expr := + | Var : string -> expr + | Lam : string -> expr -> expr + | App : expr -> expr -> expr. + +Notation Let x e1 e2 := (App (Lam x e2) e1). +Parameter e1 e2 : expr. +Check (Let "x" e1 e2). (* always printed the same *) +Coercion App : expr >-> Funclass. +Check (Let "x" e1 e2). (* printed the same from #8890, in 8.10 *) +Axiom free_vars :> expr -> list string. +Check (Let "x" e1 e2) : list string. (* printed the same from #11172, in 8.12 *) + +End A. + +(* Skipping a coercion vs using a notation for the coercion itself + (regression #11053 in 8.10 after PR #8890, addressed by PR #11090) *) + +Module B. + +Section Test. +Variables (A B : Type) (a : A) (b : B). +Variable c : A -> B. +Coercion c : A >-> B. +Notation COERCION := (c). +Check b = a. (* printed the same except in 8.10 *) +End Test. + +End B. + +Module C. + +Record word := { rep: Type }. +Coercion rep : word >-> Sortclass. +Axiom myword: word. +Axiom foo: myword. +Notation "'(_' 'BitVec' '32)'" := (rep myword). +Check foo. (* printed with Bitvec from #8890 in 8.10 and 8.11, regression due to #11172 in 8.12 *) + +End C. + +(* Examples involving coercions to funclass *) + +Module D. + +Record R := { f :> nat -> nat }. +Axiom r : R. +Notation "#[ x ]" := (f x). +Check #[ r ] 0. (* printed the same from 8.10 (due to #8890), but not 8.11 and 8.12 (due to #11090) *) +Notation "##[ x ]" := (f x 0). +Check ##[ r ]. (* printed the same from 8.10 *) +Check #[ r ] 0. (* printed ##[ r ] from 8.10 *) + +End D. + +(* Same examples with a parameter *) + +Module E. + +Record R A := { f :> A -> A }. +Axiom r : R nat. +Notation "#[ x ]" := (f nat x). +Check #[ r ] 0. (* printed the same from 8.10 (due to #8890), but not 8.11 and 8.12 (due to #11090) *) +Notation "##[ x ]" := (f nat x 0). +Check ##[ r ]. (* printed the same from 8.10 *) +Check #[ r ] 0. (* printed ##[ r ] from 8.10 *) + +End E. diff --git a/test-suite/ssr/ipat_dup.v b/test-suite/ssr/ipat_dup.v index b1936df31d..61666959c4 100644 --- a/test-suite/ssr/ipat_dup.v +++ b/test-suite/ssr/ipat_dup.v @@ -2,6 +2,8 @@ Require Import ssreflect. Section Dup. +Section withP. + Variable P : nat -> Prop. Lemma test_dup1 : forall n : nat, P n. @@ -10,4 +12,18 @@ Proof. move=> /[dup] m n; suff: P n by []. Abort. Lemma test_dup2 : let n := 1 in False. Proof. move=> /[dup] m n; have : m = n := eq_refl. Abort. +End withP. + +Lemma test_dup_plus P Q : P -> Q -> False. +Proof. +move=> + /[dup] q. +suff: P -> Q -> False by []. +Abort. + +Lemma test_dup_plus2 P : P -> let x := 0 in False. +Proof. +move=> + /[dup] y. +suff: P -> let x := 0 in False by []. +Abort. + End Dup. diff --git a/test-suite/ssr/ipat_swap.v b/test-suite/ssr/ipat_swap.v index 1d78a2a009..a06dae1264 100644 --- a/test-suite/ssr/ipat_swap.v +++ b/test-suite/ssr/ipat_swap.v @@ -7,7 +7,19 @@ Definition P n := match n with 1 => true | _ => false end. Lemma test_swap1 : forall (n : nat) (b : bool), P n = b. Proof. move=> /[swap] b n; suff: P n = b by []. Abort. -Lemma test_swap1 : let n := 1 in let b := true in False. +Lemma test_swap2 : let n := 1 in let b := true in False. Proof. move=> /[swap] b n; have : P n = b := eq_refl. Abort. +Lemma test_swap_plus P Q R : P -> Q -> R -> False. +Proof. +move=> + /[swap]. +suff: P -> R -> Q -> False by []. +Abort. + +Lemma test_swap_plus2 P : P -> let x := 0 in let y := 1 in False. +Proof. +move=> + /[swap]. +suff: P -> let y := 1 in let x := 0 in False by []. +Abort. + End Swap. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 236d35b68e..c489d82d0b 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -236,8 +236,6 @@ Hint Resolve irreflexivity : ord. Unset Implicit Arguments. -(** A HintDb for crelations. *) - Ltac solve_crelation := match goal with | [ |- ?R ?x ?x ] => reflexivity diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 54ee06343a..353496dfba 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -235,8 +235,6 @@ Hint Resolve irreflexivity : ord. Unset Implicit Arguments. -(** A HintDb for relations. *) - Ltac solve_relation := match goal with | [ |- ?R ?x ?x ] => reflexivity diff --git a/theories/micromega/MExtraction.v b/theories/micromega/MExtraction.v index fcb07c4774..a02d7adfa2 100644 --- a/theories/micromega/MExtraction.v +++ b/theories/micromega/MExtraction.v @@ -53,12 +53,13 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) -(*Extraction "micromega.ml" +(* +Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula Tauto.abst_form ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + denorm QArith_base.Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index ce12b02359..515372466a 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -611,13 +611,15 @@ Section S. let '(e1 , t1) := (RXCNF (negb polarity) e1) in if polarity then - if is_cnf_ff e1 - then - RXCNF polarity e2 - else (* compute disjunction *) - let '(e2 , t2) := (RXCNF polarity e2) in - let (f',t') := ror_cnf_opt e1 e2 in - (f', t1 +++ t2 +++ t') (* record the hypothesis *) + if is_cnf_tt e1 + then (e1,t1) + else if is_cnf_ff e1 + then + RXCNF polarity e2 + else (* compute disjunction *) + let '(e2 , t2) := (RXCNF polarity e2) in + let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') (* record the hypothesis *) else let '(e2 , t2) := (RXCNF polarity e2) in (and_cnf_opt e1 e2, t1 +++ t2). @@ -1349,6 +1351,7 @@ Section S. reflexivity. Qed. + Lemma rxcnf_impl_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) @@ -1366,9 +1369,15 @@ Section S. simpl in *. subst. destruct pol;auto. - generalize (is_cnf_ff_inv (xcnf (negb true) f1)). + generalize (is_cnf_tt_inv (xcnf (negb true) f1)). + destruct (is_cnf_tt (xcnf (negb true) f1)). + + intros. + rewrite H by auto. + reflexivity. + + + generalize (is_cnf_ff_inv (xcnf (negb true) f1)). destruct (is_cnf_ff (xcnf (negb true) f1)). - + intros H. + * intros. rewrite H by auto. unfold or_cnf_opt. simpl. @@ -1377,16 +1386,13 @@ Section S. destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. apply is_cnf_ff_inv in EQ1. congruence. reflexivity. - + + * rewrite <- ror_opt_cnf_cnf. destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). intros. reflexivity. Qed. - - - Lemma rxcnf_iff_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f1 f2:TFormula TX AF k) (IHf1 : forall pol : bool, fst (rxcnf pol f1) = xcnf pol f1) diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 935757f30a..1616b5a2a4 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -296,6 +296,9 @@ Qed. Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. Declare Equivalent Keys psub RingMicromega.psub. +Definition popp := popp Z.opp. +Declare Equivalent Keys popp RingMicromega.popp. + Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. @@ -608,16 +611,18 @@ Inductive ZArithProof := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof +| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof | ExProof : positive -> ZArithProof -> ZArithProof (*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) . -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) + Register ZArithProof as micromega.ZArithProof.type. Register DoneProof as micromega.ZArithProof.DoneProof. Register RatProof as micromega.ZArithProof.RatProof. Register CutProof as micromega.ZArithProof.CutProof. +Register SplitProof as micromega.ZArithProof.SplitProof. Register EnumProof as micromega.ZArithProof.EnumProof. Register ExProof as micromega.ZArithProof.ExProof. @@ -1042,13 +1047,14 @@ Fixpoint max_var_prf (w : ZArithProof) : positive := match w with | DoneProof => xH | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf) - | EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l - (Pos.max (max_var_psatz w1) (max_var_psatz w2)) + | SplitProof p pf1 pf2 => Pos.max (max_var xH p) (Pos.max (max_var_prf pf1) (max_var_prf pf1)) + | EnumProof w1 w2 l => List.fold_left + (fun acc prf => Pos.max acc (max_var_prf prf)) l + (Pos.max (max_var_psatz w1) (max_var_psatz w2)) | ExProof _ pf => max_var_prf pf end. - Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false @@ -1068,6 +1074,14 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end + | SplitProof p pf1 pf2 => + match genCuttingPlane (p,NonStrict) , genCuttingPlane (popp p, NonStrict) with + | None , _ | _ , None => false + | Some cp1 , Some cp2 => + ZChecker (nformula_of_cutting_plane cp1::l) pf1 + && + ZChecker (nformula_of_cutting_plane cp2::l) pf2 + end | ExProof x prf => let fr := max_var_nformulae l in if Pos.leb x fr then @@ -1105,6 +1119,7 @@ Fixpoint bdepth (pf : ZArithProof) : nat := | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) + | SplitProof _ p1 p2 => S (Nat.max (bdepth p1) (bdepth p2)) | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) | ExProof _ p => S (bdepth p) end. @@ -1140,6 +1155,26 @@ Proof. apply Nat.le_max_r. Qed. +Lemma ltof_bdepth_split_l : + forall p pf1 pf2, + ltof ZArithProof bdepth pf1 (SplitProof p pf1 pf2). +Proof. + intros. + unfold ltof. simpl. + rewrite Nat.lt_succ_r. + apply Nat.le_max_l. +Qed. + +Lemma ltof_bdepth_split_r : + forall p pf1 pf2, + ltof ZArithProof bdepth pf2 (SplitProof p pf1 pf2). +Proof. + intros. + unfold ltof. simpl. + rewrite Nat.lt_succ_r. + apply Nat.le_max_r. +Qed. + Lemma eval_Psatz_sound : forall env w l f', make_conj (eval_nformula env) l -> @@ -1470,11 +1505,23 @@ Ltac pos_tac := apply (Pos2Z.pos_le_pos X Y) in H end. +Lemma eval_nformula_split : forall env p, + eval_nformula env (p,NonStrict) \/ eval_nformula env (popp p,NonStrict). +Proof. + unfold popp. + simpl. intros. rewrite (eval_pol_opp Zsor ZSORaddon). + rewrite Z.opp_nonneg_nonpos. + apply Z.le_ge_cases. +Qed. + + + + Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w as [ | w pf | w pf | w1 w2 pf | x pf]. + destruct w as [ | w pf | w pf | p pf1 pf2 | w1 w2 pf | x pf]. - (* DoneProof *) simpl. discriminate. - (* RatProof *) @@ -1527,6 +1574,26 @@ Proof. intros. apply eval_Psatz_sound with (2:= Hlc) in H2. apply genCuttingPlaneNone with (2:= H2) ; auto. + - (* SplitProof *) + intros l. + cbn - [genCuttingPlane]. + case_eq (genCuttingPlane (p, NonStrict)) ; [| discriminate]. + case_eq (genCuttingPlane (popp p, NonStrict)) ; [| discriminate]. + intros cp1 GCP1 cp2 GCP2 ZC1 env. + flatten_bool. + destruct (eval_nformula_split env p). + + apply H with (env:=env) in H0. + rewrite <- make_conj_impl in *. + intro ; apply H0. + rewrite make_conj_cons. split; auto. + apply cutting_plane_sound with (f:= (p,NonStrict)) ; auto. + apply ltof_bdepth_split_l. + + apply H with (env:=env) in H1. + rewrite <- make_conj_impl in *. + intro ; apply H1. + rewrite make_conj_cons. split; auto. + apply cutting_plane_sound with (f:= (popp p,NonStrict)) ; auto. + apply ltof_bdepth_split_r. - (* EnumProof *) intros l. simpl. @@ -1758,6 +1825,7 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt + | SplitProof p pt1 pt2 => xhyps_of_pt (S base) (xhyps_of_pt (S base) acc pt1) pt2 | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc diff --git a/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v index dc81b5cca7..db572d25d8 100644 --- a/theories/ssr/ssreflect.v +++ b/theories/ssr/ssreflect.v @@ -671,43 +671,32 @@ Module Export ipat. Notation "'[' 'apply' ']'" := (ltac:(let f := fresh "_top_" in move=> f {}/f)) (at level 0, only parsing) : ssripat_scope. -(** We try to preserve the naming by matching the names from the goal. - We do 'move' to perform a hnf before trying to match. **) +(* we try to preserve the naming by matching the names from the goal *) +(* we do move to perform a hnf before trying to match *) Notation "'[' 'swap' ']'" := (ltac:(move; - lazymatch goal with - | |- forall (x : _), _ => let x := fresh x in move=> x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - | |- let x := _ in _ => let x := fresh x in move => x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - | _ => let x := fresh "_top_" in let x := fresh x in move=> x; move; - lazymatch goal with - | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x - | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x - | _ => let y := fresh "_top_" in move=> y; move: y x - end - end)) + let x := lazymatch goal with + | |- forall (x : _), _ => fresh x | |- let x := _ in _ => fresh x | _ => fresh "_top_" + end in intro x; move; + let y := lazymatch goal with + | |- forall (y : _), _ => fresh y | |- let y := _ in _ => fresh y | _ => fresh "_top_" + end in intro y; revert x; revert y)) (at level 0, only parsing) : ssripat_scope. + +(* we try to preserve the naming by matching the names from the goal *) +(* we do move to perform a hnf before trying to match *) Notation "'[' 'dup' ']'" := (ltac:(move; lazymatch goal with | |- forall (x : _), _ => - let x := fresh x in move=> x; - let copy := fresh x in have copy := x; move: copy x + let x := fresh x in intro x; + let copy := fresh x in have copy := x; revert x; revert copy | |- let x := _ in _ => - let x := fresh x in move=> x; + let x := fresh x in intro x; let copy := fresh x in pose copy := x; - do [unfold x in (value of copy)]; move: @copy @x + do [unfold x in (value of copy)]; revert x; revert copy | |- _ => let x := fresh "_top_" in move=> x; - let copy := fresh "_top" in have copy := x; move: copy x + let copy := fresh "_top" in have copy := x; revert x; revert copy end)) (at level 0, only parsing) : ssripat_scope. diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 9e850ff1c7..f8f2193e03 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -257,9 +257,10 @@ let context ~poly l = let sigma = Evd.from_env env in let sigma, (_, ((_env, ctx), impls)) = interp_context_evars ~program_mode:false env sigma l in (* Note, we must use the normalized evar from now on! *) - let sigma = Evd.minimize_universes sigma in let ce t = Pretyping.check_evars env sigma t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) ctx in + let sigma, ctx = Evarutil.finalize ~abort_on_undefined_evars:false + sigma (fun nf -> List.map (RelDecl.map_constr_het nf) ctx) in (* reorder, evar-normalize and add implicit status *) let ctx = List.rev_map (fun d -> let {binder_name=name}, b, t = RelDecl.to_tuple d in @@ -267,8 +268,6 @@ let context ~poly l = | Anonymous -> user_err Pp.(str "Anonymous variables not allowed in contexts.") | Name id -> id in - let b = Option.map (EConstr.to_constr sigma) b in - let t = EConstr.to_constr sigma t in let impl = let open Glob_term in let search x = match x.CAst.v with | Some (Name id',max) when Id.equal name id' -> |