Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Benchmark from Joe Hurd <joe.hurd@cl.cam.ac.uk> on 2002-09-24. |
2 | * | |
3 | * He writes: | |
4 | * | |
5 | * FYI: this benchmark attacks a bunch of non-trivial problems using the | |
6 | * model elimination first-order proof procedure. I've spent a fairly | |
7 | * long time optimizing this at a "high-level" (meaning data-structures | |
8 | * and algorithms optimizations, as well as exploiting domain knowledge, | |
9 | * but no tricks that speed things up for a particular ML | |
10 | * implementation). | |
11 | *) | |
12 | exception Empty | |
13 | ||
14 | (*#line 0.0 "$HOME/dev/sml/basic/src/PP.sig"*) | |
15 | (* PP -- pretty-printing -- from the SML/NJ library *) | |
16 | ||
17 | signature PP = | |
18 | sig | |
19 | type ppstream | |
20 | type ppconsumer = { consumer : string -> unit, | |
21 | linewidth : int, | |
22 | flush : unit -> unit } | |
23 | ||
24 | datatype break_style = | |
25 | CONSISTENT | |
26 | | INCONSISTENT | |
27 | ||
28 | val mk_ppstream : ppconsumer -> ppstream | |
29 | val dest_ppstream : ppstream -> ppconsumer | |
30 | val add_break : ppstream -> int * int -> unit | |
31 | val add_newline : ppstream -> unit | |
32 | val add_string : ppstream -> string -> unit | |
33 | val begin_block : ppstream -> break_style -> int -> unit | |
34 | val end_block : ppstream -> unit | |
35 | val clear_ppstream : ppstream -> unit | |
36 | val flush_ppstream : ppstream -> unit | |
37 | val with_pp : ppconsumer -> (ppstream -> unit) -> unit | |
38 | val pp_to_string : int -> (ppstream -> 'a -> unit) -> 'a -> string | |
39 | end | |
40 | ||
41 | (* | |
42 | This structure provides tools for creating customized Oppen-style | |
43 | pretty-printers, based on the type ppstream. A ppstream is an | |
44 | output stream that contains prettyprinting commands. The commands | |
45 | are placed in the stream by various function calls listed below. | |
46 | ||
47 | There following primitives add commands to the stream: | |
48 | begin_block, end_block, add_string, add_break, and add_newline. | |
49 | All calls to add_string, add_break, and add_newline must happen | |
50 | between a pair of calls to begin_block and end_block must be | |
51 | properly nested dynamically. All calls to begin_block and | |
52 | end_block must be properly nested (dynamically). | |
53 | ||
54 | [ppconsumer] is the type of sinks for pretty-printing. A value of | |
55 | type ppconsumer is a record | |
56 | { consumer : string -> unit, | |
57 | linewidth : int, | |
58 | flush : unit -> unit } | |
59 | of a string consumer, a specified linewidth, and a flush function | |
60 | which is called whenever flush_ppstream is called. | |
61 | ||
62 | A prettyprinter can be called outright to print a value. In | |
63 | addition, a prettyprinter for a base type or nullary datatype ty | |
64 | can be installed in the top-level system. Then the installed | |
65 | prettyprinter will be invoked automatically whenever a value of | |
66 | type ty is to be printed. | |
67 | ||
68 | [break_style] is the type of line break styles for blocks: | |
69 | ||
70 | [CONSISTENT] specifies that if any line break occurs inside the | |
71 | block, then all indicated line breaks occur. | |
72 | ||
73 | [INCONSISTENT] specifies that breaks will be inserted to only to | |
74 | avoid overfull lines. | |
75 | ||
76 | [mk_ppstream {consumer, linewidth, flush}] creates a new ppstream | |
77 | which invokes the consumer to output text, putting at most | |
78 | linewidth characters on each line. | |
79 | ||
80 | [dest_ppstream ppstrm] extracts the linewidth, flush function, and | |
81 | consumer from a ppstream. | |
82 | ||
83 | [add_break ppstrm (size, offset)] notifies the pretty-printer that | |
84 | a line break is possible at this point. | |
85 | * When the current block style is CONSISTENT: | |
86 | ** if the entire block fits on the remainder of the line, then | |
87 | output size spaces; else | |
88 | ** increase the current indentation by the block offset; | |
89 | further indent every item of the block by offset, and add | |
90 | one newline at every add_break in the block. | |
91 | * When the current block style is INCONSISTENT: | |
92 | ** if the next component of the block fits on the remainder of | |
93 | the line, then output size spaces; else | |
94 | ** issue a newline and indent to the current indentation level | |
95 | plus the block offset plus the offset. | |
96 | ||
97 | [add_newline ppstrm] issues a newline. | |
98 | ||
99 | [add_string ppstrm str] outputs the string str to the ppstream. | |
100 | ||
101 | [begin_block ppstrm style blockoffset] begins a new block and | |
102 | level of indentation, with the given style and block offset. | |
103 | ||
104 | [end_block ppstrm] closes the current block. | |
105 | ||
106 | [clear_ppstream ppstrm] restarts the stream, without affecting the | |
107 | underlying consumer. | |
108 | ||
109 | [flush_ppstream ppstrm] executes any remaining commands in the | |
110 | ppstream (that is, flushes currently accumulated output to the | |
111 | consumer associated with ppstrm); executes the flush function | |
112 | associated with the consumer; and calls clear_ppstream. | |
113 | ||
114 | [with_pp consumer f] makes a new ppstream from the consumer and | |
115 | applies f (which can be thought of as a producer) to that | |
116 | ppstream, then flushed the ppstream and returns the value of f. | |
117 | ||
118 | [pp_to_string linewidth printit x] constructs a new ppstream | |
119 | ppstrm whose consumer accumulates the output in a string s. Then | |
120 | evaluates (printit ppstrm x) and finally returns the string s. | |
121 | ||
122 | ||
123 | Example 1: A simple prettyprinter for Booleans: | |
124 | ||
125 | load "PP"; | |
126 | fun ppbool pps d = | |
127 | let open PP | |
128 | in | |
129 | begin_block pps INCONSISTENT 6; | |
130 | add_string pps (if d then "right" else "wrong"); | |
131 | end_block pps | |
132 | end; | |
133 | ||
134 | Now one may define a ppstream to print to, and exercise it: | |
135 | ||
136 | val ppstrm = PP.mk_ppstream {consumer = | |
137 | fn s => TextIO.output(TextIO.stdOut, s), | |
138 | linewidth = 72, | |
139 | flush = | |
140 | fn () => TextIO.flushOut TextIO.stdOut}; | |
141 | ||
142 | fun ppb b = (ppbool ppstrm b; PP.flush_ppstream ppstrm); | |
143 | ||
144 | - ppb false; | |
145 | wrong> val it = () : unit | |
146 | ||
147 | The prettyprinter may also be installed in the toplevel system; | |
148 | then it will be used to print all expressions of type bool | |
149 | subsequently computed: | |
150 | ||
151 | - installPP ppbool; | |
152 | > val it = () : unit | |
153 | - 1=0; | |
154 | > val it = wrong : bool | |
155 | - 1=1; | |
156 | > val it = right : bool | |
157 | ||
158 | See library Meta for a description of installPP. | |
159 | ||
160 | ||
161 | Example 2: Prettyprinting simple expressions (examples/pretty/ppexpr.sml): | |
162 | ||
163 | datatype expr = | |
164 | Cst of int | |
165 | | Neg of expr | |
166 | | Plus of expr * expr | |
167 | ||
168 | fun ppexpr pps e0 = | |
169 | let open PP | |
170 | fun ppe (Cst i) = add_string pps (Int.toString i) | |
171 | | ppe (Neg e) = (add_string pps "~"; ppe e) | |
172 | | ppe (Plus(e1, e2)) = (begin_block pps CONSISTENT 0; | |
173 | add_string pps "("; | |
174 | ppe e1; | |
175 | add_string pps " + "; | |
176 | add_break pps (0, 1); | |
177 | ppe e2; | |
178 | add_string pps ")"; | |
179 | end_block pps) | |
180 | in | |
181 | begin_block pps INCONSISTENT 0; | |
182 | ppe e0; | |
183 | end_block pps | |
184 | end | |
185 | ||
186 | val _ = installPP ppexpr; | |
187 | ||
188 | (* Some example values: *) | |
189 | ||
190 | val e1 = Cst 1; | |
191 | val e2 = Cst 2; | |
192 | val e3 = Plus(e1, Neg e2); | |
193 | val e4 = Plus(Neg e3, e3); | |
194 | val e5 = Plus(Neg e4, e4); | |
195 | val e6 = Plus(e5, e5); | |
196 | val e7 = Plus(e6, e6); | |
197 | val e8 = | |
198 | Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, e7)))))); | |
199 | *) | |
200 | (*#line 0.0 "$HOME/dev/sml/basic/src/PP.sml"*) | |
201 | (* PP -- Oppen-style prettyprinters. | |
202 | * | |
203 | * Modified for Milton ML from SML/NJ Library version 0.2 | |
204 | * | |
205 | * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. | |
206 | * See file mosml/copyrght/copyrght.att for details. | |
207 | *) | |
208 | ||
209 | (* the functions and data for actually doing printing. *) | |
210 | ||
211 | structure PP :> PP = | |
212 | struct | |
213 | ||
214 | open Array | |
215 | infix 9 sub | |
216 | ||
217 | (* the queue library, formerly in unit Ppqueue *) | |
218 | ||
219 | datatype Qend = Qback | Qfront | |
220 | ||
221 | exception QUEUE_FULL | |
222 | exception QUEUE_EMPTY | |
223 | exception REQUESTED_QUEUE_SIZE_TOO_SMALL | |
224 | ||
225 | local | |
226 | fun ++ i n = (i + 1) mod n | |
227 | fun -- i n = (i - 1) mod n | |
228 | in | |
229 | ||
230 | abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *) | |
231 | front: int ref, | |
232 | back: int ref, | |
233 | size: int} (* fixed size of element array *) | |
234 | with | |
235 | ||
236 | fun is_empty (QUEUE{front=ref ~1, back=ref ~1,...}) = true | |
237 | | is_empty _ = false | |
238 | ||
239 | fun mk_queue n init_val = | |
240 | if (n < 2) | |
241 | then raise REQUESTED_QUEUE_SIZE_TOO_SMALL | |
242 | else QUEUE{elems=array(n, init_val), front=ref ~1, back=ref ~1, size=n} | |
243 | ||
244 | fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1) | |
245 | ||
246 | fun queue_at Qfront (QUEUE{elems,front,...}) = elems sub !front | |
247 | | queue_at Qback (QUEUE{elems,back,...}) = elems sub !back | |
248 | ||
249 | fun en_queue Qfront item (Q as QUEUE{elems,front,back,size}) = | |
250 | if (is_empty Q) | |
251 | then (front := 0; back := 0; | |
252 | update(elems,0,item)) | |
253 | else let val i = --(!front) size | |
254 | in if (i = !back) | |
255 | then raise QUEUE_FULL | |
256 | else (update(elems,i,item); front := i) | |
257 | end | |
258 | | en_queue Qback item (Q as QUEUE{elems,front,back,size}) = | |
259 | if (is_empty Q) | |
260 | then (front := 0; back := 0; | |
261 | update(elems,0,item)) | |
262 | else let val i = ++(!back) size | |
263 | in if (i = !front) | |
264 | then raise QUEUE_FULL | |
265 | else (update(elems,i,item); back := i) | |
266 | end | |
267 | ||
268 | fun de_queue Qfront (Q as QUEUE{front,back,size,...}) = | |
269 | if (!front = !back) (* unitary queue *) | |
270 | then clear_queue Q | |
271 | else front := ++(!front) size | |
272 | | de_queue Qback (Q as QUEUE{front,back,size,...}) = | |
273 | if (!front = !back) | |
274 | then clear_queue Q | |
275 | else back := --(!back) size | |
276 | ||
277 | end (* abstype queue *) | |
278 | end (* local *) | |
279 | ||
280 | ||
281 | val magic: 'a -> 'a = fn x => x | |
282 | ||
283 | (* exception PP_FAIL of string *) | |
284 | ||
285 | datatype break_style = CONSISTENT | INCONSISTENT | |
286 | ||
287 | datatype break_info | |
288 | = FITS | |
289 | | PACK_ONTO_LINE of int | |
290 | | ONE_PER_LINE of int | |
291 | ||
292 | (* Some global values *) | |
293 | val INFINITY = 999999 | |
294 | ||
295 | abstype indent_stack = Istack of break_info list ref | |
296 | with | |
297 | fun mk_indent_stack() = Istack (ref([]:break_info list)) | |
298 | fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list)) | |
299 | fun top (Istack stk) = | |
300 | case !stk | |
301 | of nil => raise Fail "PP-error: top: badly formed block" | |
302 | | x::_ => x | |
303 | fun push (x,(Istack stk)) = stk := x::(!stk) | |
304 | fun pop (Istack stk) = | |
305 | case !stk | |
306 | of nil => raise Fail "PP-error: pop: badly formed block" | |
307 | | _::rest => stk := rest | |
308 | end | |
309 | ||
310 | (* The delim_stack is used to compute the size of blocks. It is | |
311 | a stack of indices into the token buffer. The indices only point to | |
312 | BBs, Es, and BRs. We push BBs and Es onto the stack until a BR | |
313 | is encountered. Then we compute sizes and pop. When we encounter | |
314 | a BR in the middle of a block, we compute the Distance_to_next_break | |
315 | of the previous BR in the block, if there was one. | |
316 | ||
317 | We need to be able to delete from the bottom of the delim_stack, so | |
318 | we use a queue, treated with a stack discipline, i.e., we only add | |
319 | items at the head of the queue, but can delete from the front or | |
320 | back of the queue. | |
321 | *) | |
322 | abstype delim_stack = Dstack of int queue | |
323 | with | |
324 | fun new_delim_stack i = Dstack(mk_queue i ~1) | |
325 | fun reset_delim_stack (Dstack q) = clear_queue q | |
326 | ||
327 | fun pop_delim_stack (Dstack d) = de_queue Qfront d | |
328 | fun pop_bottom_delim_stack (Dstack d) = de_queue Qback d | |
329 | ||
330 | fun push_delim_stack(i,Dstack d) = en_queue Qfront i d | |
331 | fun top_delim_stack (Dstack d) = queue_at Qfront d | |
332 | fun bottom_delim_stack (Dstack d) = queue_at Qback d | |
333 | fun delim_stack_is_empty (Dstack d) = is_empty d | |
334 | end | |
335 | ||
336 | ||
337 | type block_info = { Block_size : int ref, | |
338 | Block_offset : int, | |
339 | How_to_indent : break_style } | |
340 | ||
341 | ||
342 | (* Distance_to_next_break includes Number_of_blanks. Break_offset is | |
343 | a local offset for the break. BB represents a sequence of contiguous | |
344 | Begins. E represents a sequence of contiguous Ends. | |
345 | *) | |
346 | datatype pp_token | |
347 | = S of {String : string, Length : int} | |
348 | | BB of {Pblocks : block_info list ref, (* Processed *) | |
349 | Ublocks : block_info list ref} (* Unprocessed *) | |
350 | | E of {Pend : int ref, Uend : int ref} | |
351 | | BR of {Distance_to_next_break : int ref, | |
352 | Number_of_blanks : int, | |
353 | Break_offset : int} | |
354 | ||
355 | ||
356 | (* The initial values in the token buffer *) | |
357 | val initial_token_value = S{String = "", Length = 0} | |
358 | ||
359 | (* type ppstream = General.ppstream; *) | |
360 | datatype ppstream_ = | |
361 | PPS of | |
362 | {consumer : string -> unit, | |
363 | linewidth : int, | |
364 | flush : unit -> unit, | |
365 | the_token_buffer : pp_token array, | |
366 | the_delim_stack : delim_stack, | |
367 | the_indent_stack : indent_stack, | |
368 | ++ : int ref -> unit, (* increment circular buffer index *) | |
369 | space_left : int ref, (* remaining columns on page *) | |
370 | left_index : int ref, (* insertion index *) | |
371 | right_index : int ref, (* output index *) | |
372 | left_sum : int ref, (* size of strings and spaces inserted *) | |
373 | right_sum : int ref} (* size of strings and spaces printed *) | |
374 | ||
375 | type ppstream = ppstream_ | |
376 | ||
377 | type ppconsumer = {consumer : string -> unit, | |
378 | linewidth : int, | |
379 | flush : unit -> unit} | |
380 | ||
381 | fun mk_ppstream {consumer,linewidth,flush} = | |
382 | if (linewidth<5) | |
383 | then raise Fail "PP-error: linewidth too_small" | |
384 | else let val buf_size = 3*linewidth | |
385 | in magic( | |
386 | PPS{consumer = consumer, | |
387 | linewidth = linewidth, | |
388 | flush = flush, | |
389 | the_token_buffer = array(buf_size, initial_token_value), | |
390 | the_delim_stack = new_delim_stack buf_size, | |
391 | the_indent_stack = mk_indent_stack (), | |
392 | ++ = fn i => i := ((!i + 1) mod buf_size), | |
393 | space_left = ref linewidth, | |
394 | left_index = ref 0, right_index = ref 0, | |
395 | left_sum = ref 0, right_sum = ref 0} | |
396 | ) : ppstream | |
397 | end | |
398 | ||
399 | fun dest_ppstream(pps : ppstream) = | |
400 | let val PPS{consumer,linewidth,flush, ...} = magic pps | |
401 | in {consumer=consumer,linewidth=linewidth,flush=flush} end | |
402 | ||
403 | local | |
404 | val space = " " | |
405 | fun mk_space (0,s) = String.concat s | |
406 | | mk_space (n,s) = mk_space((n-1), (space::s)) | |
407 | val space_table = Vector.tabulate(100, fn i => mk_space(i,[])) | |
408 | fun nspaces n = Vector.sub(space_table, n) | |
409 | handle General.Subscript => | |
410 | if n < 0 | |
411 | then "" | |
412 | else let val n2 = n div 2 | |
413 | val n2_spaces = nspaces n2 | |
414 | val extra = if (n = (2*n2)) then "" else space | |
415 | in String.concat [n2_spaces, n2_spaces, extra] | |
416 | end | |
417 | in | |
418 | fun cr_indent (ofn, i) = ofn ("\n"^(nspaces i)) | |
419 | fun indent (ofn,i) = ofn (nspaces i) | |
420 | end | |
421 | ||
422 | ||
423 | (* Print a the first member of a contiguous sequence of Begins. If there | |
424 | are "processed" Begins, then take the first off the list. If there are | |
425 | no processed Begins, take the last member off the "unprocessed" list. | |
426 | This works because the unprocessed list is treated as a stack, the | |
427 | processed list as a FIFO queue. How can an item on the unprocessed list | |
428 | be printable? Because of what goes on in add_string. See there for details. | |
429 | *) | |
430 | ||
431 | fun print_BB (_,{Pblocks = ref [], Ublocks = ref []}) = | |
432 | raise Fail "PP-error: print_BB" | |
433 | | print_BB (PPS{the_indent_stack,linewidth,space_left=ref sp_left,...}, | |
434 | {Pblocks as ref({How_to_indent=CONSISTENT,Block_size, | |
435 | Block_offset}::rst), | |
436 | Ublocks=ref[]}) = | |
437 | (push ((if (!Block_size > sp_left) | |
438 | then ONE_PER_LINE (linewidth - (sp_left - Block_offset)) | |
439 | else FITS), | |
440 | the_indent_stack); | |
441 | Pblocks := rst) | |
442 | | print_BB(PPS{the_indent_stack,linewidth,space_left=ref sp_left,...}, | |
443 | {Pblocks as ref({Block_size,Block_offset,...}::rst),Ublocks=ref[]}) = | |
444 | (push ((if (!Block_size > sp_left) | |
445 | then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset)) | |
446 | else FITS), | |
447 | the_indent_stack); | |
448 | Pblocks := rst) | |
449 | | print_BB (PPS{the_indent_stack, linewidth, space_left=ref sp_left,...}, | |
450 | {Ublocks,...}) = | |
451 | let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l = | |
452 | (push ((if (!Block_size > sp_left) | |
453 | then ONE_PER_LINE (linewidth - (sp_left - Block_offset)) | |
454 | else FITS), | |
455 | the_indent_stack); | |
456 | List.rev l) | |
457 | | pr_end_Ublock [{Block_size,Block_offset,...}] l = | |
458 | (push ((if (!Block_size > sp_left) | |
459 | then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset)) | |
460 | else FITS), | |
461 | the_indent_stack); | |
462 | List.rev l) | |
463 | | pr_end_Ublock (a::rst) l = pr_end_Ublock rst (a::l) | |
464 | | pr_end_Ublock _ _ = | |
465 | raise Fail "PP-error: print_BB: internal error" | |
466 | in Ublocks := pr_end_Ublock(!Ublocks) [] | |
467 | end | |
468 | ||
469 | ||
470 | (* Uend should always be 0 when print_E is called. *) | |
471 | fun print_E (_,{Pend = ref 0, Uend = ref 0}) = | |
472 | raise Fail "PP-error: print_E" | |
473 | | print_E (istack,{Pend, ...}) = | |
474 | let fun pop_n_times 0 = () | |
475 | | pop_n_times n = (pop istack; pop_n_times(n-1)) | |
476 | in pop_n_times(!Pend); Pend := 0 | |
477 | end | |
478 | ||
479 | ||
480 | (* "cursor" is how many spaces across the page we are. *) | |
481 | ||
482 | fun print_token(PPS{consumer,space_left,...}, S{String,Length}) = | |
483 | (consumer String; | |
484 | space_left := (!space_left) - Length) | |
485 | | print_token(ppstrm,BB b) = print_BB(ppstrm,b) | |
486 | | print_token(PPS{the_indent_stack,...},E e) = | |
487 | print_E (the_indent_stack,e) | |
488 | | print_token (PPS{the_indent_stack,space_left,consumer,linewidth,...}, | |
489 | BR{Distance_to_next_break,Number_of_blanks,Break_offset}) = | |
490 | (case (top the_indent_stack) | |
491 | of FITS => | |
492 | (space_left := (!space_left) - Number_of_blanks; | |
493 | indent (consumer,Number_of_blanks)) | |
494 | | (ONE_PER_LINE cursor) => | |
495 | let val new_cursor = cursor + Break_offset | |
496 | in space_left := linewidth - new_cursor; | |
497 | cr_indent (consumer,new_cursor) | |
498 | end | |
499 | | (PACK_ONTO_LINE cursor) => | |
500 | if (!Distance_to_next_break > (!space_left)) | |
501 | then let val new_cursor = cursor + Break_offset | |
502 | in space_left := linewidth - new_cursor; | |
503 | cr_indent(consumer,new_cursor) | |
504 | end | |
505 | else (space_left := !space_left - Number_of_blanks; | |
506 | indent (consumer,Number_of_blanks))) | |
507 | ||
508 | ||
509 | fun clear_ppstream(pps : ppstream) = | |
510 | let val PPS{the_token_buffer, the_delim_stack, | |
511 | the_indent_stack,left_sum, right_sum, | |
512 | left_index, right_index,space_left,linewidth,...} | |
513 | = magic pps | |
514 | val buf_size = 3*linewidth | |
515 | fun set i = | |
516 | if (i = buf_size) | |
517 | then () | |
518 | else (update(the_token_buffer,i,initial_token_value); | |
519 | set (i+1)) | |
520 | in set 0; | |
521 | clear_indent_stack the_indent_stack; | |
522 | reset_delim_stack the_delim_stack; | |
523 | left_sum := 0; right_sum := 0; | |
524 | left_index := 0; right_index := 0; | |
525 | space_left := linewidth | |
526 | end | |
527 | ||
528 | ||
529 | (* Move insertion head to right unless adding a BB and already at a BB, | |
530 | or unless adding an E and already at an E. | |
531 | *) | |
532 | fun BB_inc_right_index(PPS{the_token_buffer, right_index, ++,...})= | |
533 | case (the_token_buffer sub (!right_index)) | |
534 | of (BB _) => () | |
535 | | _ => ++right_index | |
536 | ||
537 | fun E_inc_right_index(PPS{the_token_buffer,right_index, ++,...})= | |
538 | case (the_token_buffer sub (!right_index)) | |
539 | of (E _) => () | |
540 | | _ => ++right_index | |
541 | ||
542 | ||
543 | fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) = | |
544 | (!left_index = !right_index) andalso | |
545 | (case (the_token_buffer sub (!left_index)) | |
546 | of (BB {Pblocks = ref [], Ublocks = ref []}) => true | |
547 | | (BB _) => false | |
548 | | (E {Pend = ref 0, Uend = ref 0}) => true | |
549 | | (E _) => false | |
550 | | _ => true) | |
551 | ||
552 | fun advance_left (ppstrm as PPS{consumer,left_index,left_sum, | |
553 | the_token_buffer,++,...}, | |
554 | instr) = | |
555 | let val NEG = ~1 | |
556 | val POS = 0 | |
557 | fun inc_left_sum (BR{Number_of_blanks, ...}) = | |
558 | left_sum := (!left_sum) + Number_of_blanks | |
559 | | inc_left_sum (S{Length, ...}) = left_sum := (!left_sum) + Length | |
560 | | inc_left_sum _ = () | |
561 | ||
562 | fun last_size [{Block_size, ...}:block_info] = !Block_size | |
563 | | last_size (_::rst) = last_size rst | |
564 | | last_size _ = raise Fail "PP-error: last_size: internal error" | |
565 | fun token_size (S{Length, ...}) = Length | |
566 | | token_size (BB b) = | |
567 | (case b | |
568 | of {Pblocks = ref [], Ublocks = ref []} => | |
569 | raise Fail "PP-error: BB_size" | |
570 | | {Pblocks as ref(_::_),Ublocks=ref[]} => POS | |
571 | | {Ublocks, ...} => last_size (!Ublocks)) | |
572 | | token_size (E{Pend = ref 0, Uend = ref 0}) = | |
573 | raise Fail "PP-error: token_size.E" | |
574 | | token_size (E{Pend = ref 0, ...}) = NEG | |
575 | | token_size (E _) = POS | |
576 | | token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break | |
577 | fun loop (instr) = | |
578 | if (token_size instr < 0) (* synchronization point; cannot advance *) | |
579 | then () | |
580 | else (print_token(ppstrm,instr); | |
581 | inc_left_sum instr; | |
582 | if (pointers_coincide ppstrm) | |
583 | then () | |
584 | else (* increment left index *) | |
585 | ||
586 | (* When this is evaluated, we know that the left_index has not yet | |
587 | caught up to the right_index. If we are at a BB or an E, we can | |
588 | increment left_index if there is no work to be done, i.e., all Begins | |
589 | or Ends have been dealt with. Also, we should do some housekeeping and | |
590 | clear the buffer at left_index, otherwise we can get errors when | |
591 | left_index catches up to right_index and we reset the indices to 0. | |
592 | (We might find ourselves adding a BB to an "old" BB, with the result | |
593 | that the index is not pushed onto the delim_stack. This can lead to | |
594 | mangled output.) | |
595 | *) | |
596 | (case (the_token_buffer sub (!left_index)) | |
597 | of (BB {Pblocks = ref [], Ublocks = ref []}) => | |
598 | (update(the_token_buffer,!left_index, | |
599 | initial_token_value); | |
600 | ++left_index) | |
601 | | (BB _) => () | |
602 | | (E {Pend = ref 0, Uend = ref 0}) => | |
603 | (update(the_token_buffer,!left_index, | |
604 | initial_token_value); | |
605 | ++left_index) | |
606 | | (E _) => () | |
607 | | _ => ++left_index; | |
608 | loop (the_token_buffer sub (!left_index)))) | |
609 | in loop instr | |
610 | end | |
611 | ||
612 | ||
613 | fun begin_block (pps : ppstream) style offset = | |
614 | let val ppstrm = magic pps : ppstream_ | |
615 | val PPS{the_token_buffer, the_delim_stack,left_index, | |
616 | left_sum, right_index, right_sum,...} | |
617 | = ppstrm | |
618 | in | |
619 | (if (delim_stack_is_empty the_delim_stack) | |
620 | then (left_index := 0; | |
621 | left_sum := 1; | |
622 | right_index := 0; | |
623 | right_sum := 1) | |
624 | else BB_inc_right_index ppstrm; | |
625 | case (the_token_buffer sub (!right_index)) | |
626 | of (BB {Ublocks, ...}) => | |
627 | Ublocks := {Block_size = ref (~(!right_sum)), | |
628 | Block_offset = offset, | |
629 | How_to_indent = style}::(!Ublocks) | |
630 | | _ => (update(the_token_buffer, !right_index, | |
631 | BB{Pblocks = ref [], | |
632 | Ublocks = ref [{Block_size = ref (~(!right_sum)), | |
633 | Block_offset = offset, | |
634 | How_to_indent = style}]}); | |
635 | push_delim_stack (!right_index, the_delim_stack))) | |
636 | end | |
637 | ||
638 | fun end_block(pps : ppstream) = | |
639 | let val ppstrm = magic pps : ppstream_ | |
640 | val PPS{the_token_buffer,the_delim_stack,right_index,...} | |
641 | = ppstrm | |
642 | in | |
643 | if (delim_stack_is_empty the_delim_stack) | |
644 | then print_token(ppstrm,(E{Pend = ref 1, Uend = ref 0})) | |
645 | else (E_inc_right_index ppstrm; | |
646 | case (the_token_buffer sub (!right_index)) | |
647 | of (E{Uend, ...}) => Uend := !Uend + 1 | |
648 | | _ => (update(the_token_buffer,!right_index, | |
649 | E{Uend = ref 1, Pend = ref 0}); | |
650 | push_delim_stack (!right_index, the_delim_stack))) | |
651 | end | |
652 | ||
653 | local | |
654 | fun check_delim_stack(PPS{the_token_buffer,the_delim_stack,right_sum,...}) = | |
655 | let fun check k = | |
656 | if (delim_stack_is_empty the_delim_stack) | |
657 | then () | |
658 | else case(the_token_buffer sub (top_delim_stack the_delim_stack)) | |
659 | of (BB{Ublocks as ref ((b as {Block_size, ...})::rst), | |
660 | Pblocks}) => | |
661 | if (k>0) | |
662 | then (Block_size := !right_sum + !Block_size; | |
663 | Pblocks := b :: (!Pblocks); | |
664 | Ublocks := rst; | |
665 | if (List.length rst = 0) | |
666 | then pop_delim_stack the_delim_stack | |
667 | else (); | |
668 | check(k-1)) | |
669 | else () | |
670 | | (E{Pend,Uend}) => | |
671 | (Pend := (!Pend) + (!Uend); | |
672 | Uend := 0; | |
673 | pop_delim_stack the_delim_stack; | |
674 | check(k + !Pend)) | |
675 | | (BR{Distance_to_next_break, ...}) => | |
676 | (Distance_to_next_break := | |
677 | !right_sum + !Distance_to_next_break; | |
678 | pop_delim_stack the_delim_stack; | |
679 | if (k>0) | |
680 | then check k | |
681 | else ()) | |
682 | | _ => raise Fail "PP-error: check_delim_stack.catchall" | |
683 | in check 0 | |
684 | end | |
685 | in | |
686 | ||
687 | fun add_break (pps : ppstream) (n, break_offset) = | |
688 | let val ppstrm = magic pps : ppstream_ | |
689 | val PPS{the_token_buffer,the_delim_stack,left_index, | |
690 | right_index,left_sum,right_sum, ++, ...} | |
691 | = ppstrm | |
692 | in | |
693 | (if (delim_stack_is_empty the_delim_stack) | |
694 | then (left_index := 0; right_index := 0; | |
695 | left_sum := 1; right_sum := 1) | |
696 | else ++right_index; | |
697 | update(the_token_buffer, !right_index, | |
698 | BR{Distance_to_next_break = ref (~(!right_sum)), | |
699 | Number_of_blanks = n, | |
700 | Break_offset = break_offset}); | |
701 | check_delim_stack ppstrm; | |
702 | right_sum := (!right_sum) + n; | |
703 | push_delim_stack (!right_index,the_delim_stack)) | |
704 | end | |
705 | ||
706 | fun flush_ppstream0(pps : ppstream) = | |
707 | let val ppstrm = magic pps : ppstream_ | |
708 | val PPS{the_delim_stack,the_token_buffer, flush, left_index,...} | |
709 | = ppstrm | |
710 | in | |
711 | (if (delim_stack_is_empty the_delim_stack) | |
712 | then () | |
713 | else (check_delim_stack ppstrm; | |
714 | advance_left(ppstrm, the_token_buffer sub (!left_index))); | |
715 | flush()) | |
716 | end | |
717 | ||
718 | end (* local *) | |
719 | ||
720 | ||
721 | fun flush_ppstream ppstrm = | |
722 | (flush_ppstream0 ppstrm; | |
723 | clear_ppstream ppstrm) | |
724 | ||
725 | fun add_string (pps : ppstream) s = | |
726 | let val ppstrm = magic pps : ppstream_ | |
727 | val PPS{the_token_buffer,the_delim_stack,consumer, | |
728 | right_index,right_sum,left_sum, | |
729 | left_index,space_left,++,...} | |
730 | = ppstrm | |
731 | fun fnl [{Block_size, ...}:block_info] = Block_size := INFINITY | |
732 | | fnl (_::rst) = fnl rst | |
733 | | fnl _ = raise Fail "PP-error: fnl: internal error" | |
734 | ||
735 | fun set(dstack,BB{Ublocks as ref[{Block_size,...}:block_info],...}) = | |
736 | (pop_bottom_delim_stack dstack; | |
737 | Block_size := INFINITY) | |
738 | | set (_,BB {Ublocks = ref(_::rst), ...}) = fnl rst | |
739 | | set (dstack, E{Pend,Uend}) = | |
740 | (Pend := (!Pend) + (!Uend); | |
741 | Uend := 0; | |
742 | pop_bottom_delim_stack dstack) | |
743 | | set (dstack,BR{Distance_to_next_break,...}) = | |
744 | (pop_bottom_delim_stack dstack; | |
745 | Distance_to_next_break := INFINITY) | |
746 | | set _ = raise (Fail "PP-error: add_string.set") | |
747 | ||
748 | fun check_stream () = | |
749 | if ((!right_sum - !left_sum) > !space_left) | |
750 | then if (delim_stack_is_empty the_delim_stack) | |
751 | then () | |
752 | else let val i = bottom_delim_stack the_delim_stack | |
753 | in if (!left_index = i) | |
754 | then set (the_delim_stack, the_token_buffer sub i) | |
755 | else (); | |
756 | advance_left(ppstrm, | |
757 | the_token_buffer sub (!left_index)); | |
758 | if (pointers_coincide ppstrm) | |
759 | then () | |
760 | else check_stream () | |
761 | end | |
762 | else () | |
763 | ||
764 | val slen = String.size s | |
765 | val S_token = S{String = s, Length = slen} | |
766 | ||
767 | in if (delim_stack_is_empty the_delim_stack) | |
768 | then print_token(ppstrm,S_token) | |
769 | else (++right_index; | |
770 | update(the_token_buffer, !right_index, S_token); | |
771 | right_sum := (!right_sum)+slen; | |
772 | check_stream ()) | |
773 | end | |
774 | ||
775 | ||
776 | (* Derived form. The +2 is for peace of mind *) | |
777 | fun add_newline (pps : ppstream) = | |
778 | let val PPS{linewidth, ...} = magic pps | |
779 | in add_break pps (linewidth+2,0) end | |
780 | ||
781 | (* Derived form. Builds a ppstream, sends pretty printing commands called in | |
782 | f to the ppstream, then flushes ppstream. | |
783 | *) | |
784 | ||
785 | fun with_pp ppconsumer ppfn = | |
786 | let val ppstrm = mk_ppstream ppconsumer | |
787 | in ppfn ppstrm; | |
788 | flush_ppstream0 ppstrm | |
789 | end | |
790 | handle Fail msg => | |
791 | (TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n")) | |
792 | ||
793 | fun pp_to_string linewidth ppfn ob = | |
794 | let val l = ref ([]:string list) | |
795 | fun attach s = l := (s::(!l)) | |
796 | in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()} | |
797 | (fn ppstrm => ppfn ppstrm ob); | |
798 | String.concat(List.rev(!l)) | |
799 | end | |
800 | end | |
801 | (*#line 0.0 "$HOME/dev/sml/basic/src/Binarymap.sig"*) | |
802 | (* Binarymap -- applicative maps as balanced ordered binary trees *) | |
803 | (* From SML/NJ lib 0.2, copyright 1993 by AT&T Bell Laboratories *) | |
804 | (* Original implementation due to Stephen Adams, Southampton, UK *) | |
805 | ||
806 | signature Binarymap = | |
807 | sig | |
808 | ||
809 | type ('key, 'a) dict | |
810 | ||
811 | exception NotFound | |
812 | ||
813 | val mkDict : ('key * 'key -> order) -> ('key, 'a) dict | |
814 | val insert : ('key, 'a) dict * 'key * 'a -> ('key, 'a) dict | |
815 | val find : ('key, 'a) dict * 'key -> 'a | |
816 | val peek : ('key, 'a) dict * 'key -> 'a option | |
817 | val remove : ('key, 'a) dict * 'key -> ('key, 'a) dict * 'a | |
818 | val numItems : ('key, 'a) dict -> int | |
819 | val listItems : ('key, 'a) dict -> ('key * 'a) list | |
820 | val app : ('key * 'a -> unit) -> ('key,'a) dict -> unit | |
821 | val revapp : ('key * 'a -> unit) -> ('key,'a) dict -> unit | |
822 | val foldr : ('key * 'a * 'b -> 'b)-> 'b -> ('key,'a) dict -> 'b | |
823 | val foldl : ('key * 'a * 'b -> 'b) -> 'b -> ('key,'a) dict -> 'b | |
824 | val map : ('key * 'a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict | |
825 | val transform : ('a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict | |
826 | ||
827 | end | |
828 | ||
829 | (* | |
830 | [('key, 'a) dict] is the type of applicative maps from domain type | |
831 | 'key to range type 'a, or equivalently, applicative dictionaries | |
832 | with keys of type 'key and values of type 'a. They are implemented | |
833 | as ordered balanced binary trees. | |
834 | ||
835 | [mkDict ordr] returns a new, empty map whose keys have ordering | |
836 | ordr. | |
837 | ||
838 | [insert(m, i, v)] extends (or modifies) map m to map i to v. | |
839 | ||
840 | [find (m, k)] returns v if m maps k to v; otherwise raises NotFound. | |
841 | ||
842 | [peek(m, k)] returns SOME v if m maps k to v; otherwise returns NONE. | |
843 | ||
844 | [remove(m, k)] removes k from the domain of m and returns the | |
845 | modified map and the element v corresponding to k. Raises NotFound | |
846 | if k is not in the domain of m. | |
847 | ||
848 | [numItems m] returns the number of entries in m (that is, the size | |
849 | of the domain of m). | |
850 | ||
851 | [listItems m] returns a list of the entries (k, v) of keys k and | |
852 | the corresponding values v in m, in order of increasing key values. | |
853 | ||
854 | [app f m] applies function f to the entries (k, v) in m, in | |
855 | increasing order of k (according to the ordering ordr used to | |
856 | create the map or dictionary). | |
857 | ||
858 | [revapp f m] applies function f to the entries (k, v) in m, in | |
859 | decreasing order of k. | |
860 | ||
861 | [foldl f e m] applies the folding function f to the entries (k, v) | |
862 | in m, in increasing order of k. | |
863 | ||
864 | [foldr f e m] applies the folding function f to the entries (k, v) | |
865 | in m, in decreasing order of k. | |
866 | ||
867 | [map f m] returns a new map whose entries have form (k, f(k,v)), | |
868 | where (k, v) is an entry in m. | |
869 | ||
870 | [transform f m] returns a new map whose entries have form (k, f v), | |
871 | where (k, v) is an entry in m. | |
872 | *) | |
873 | (*#line 0.0 "$HOME/dev/sml/basic/src/Binarymap.sml"*) | |
874 | (* Binarymap -- modified for Milton ML | |
875 | * from SML/NJ library v. 0.2 file binary-dict.sml. | |
876 | * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. | |
877 | * See file mosml/copyrght/copyrght.att for details. | |
878 | * | |
879 | * This code was adapted from Stephen Adams' binary tree implementation | |
880 | * of applicative integer sets. | |
881 | * | |
882 | * Copyright 1992 Stephen Adams. | |
883 | * | |
884 | * This software may be used freely provided that: | |
885 | * 1. This copyright notice is attached to any copy, derived work, | |
886 | * or work including all or part of this software. | |
887 | * 2. Any derived work must contain a prominent notice stating that | |
888 | * it has been altered from the original. | |
889 | * | |
890 | * | |
891 | * Name(s): Stephen Adams. | |
892 | * Department, Institution: Electronics & Computer Science, | |
893 | * University of Southampton | |
894 | * Address: Electronics & Computer Science | |
895 | * University of Southampton | |
896 | * Southampton SO9 5NH | |
897 | * Great Britian | |
898 | * E-mail: sra@ecs.soton.ac.uk | |
899 | * | |
900 | * Comments: | |
901 | * | |
902 | * 1. The implementation is based on Binary search trees of Bounded | |
903 | * Balance, similar to Nievergelt & Reingold, SIAM J. Computing | |
904 | * 2(1), March 1973. The main advantage of these trees is that | |
905 | * they keep the size of the tree in the node, giving a constant | |
906 | * time size operation. | |
907 | * | |
908 | * 2. The bounded balance criterion is simpler than N&R's alpha. | |
909 | * Simply, one subtree must not have more than `weight' times as | |
910 | * many elements as the opposite subtree. Rebalancing is | |
911 | * guaranteed to reinstate the criterion for weight>2.23, but | |
912 | * the occasional incorrect behaviour for weight=2 is not | |
913 | * detrimental to performance. | |
914 | * | |
915 | *) | |
916 | ||
917 | structure Binarymap :> Binarymap = | |
918 | struct | |
919 | ||
920 | exception NotFound | |
921 | ||
922 | fun wt (i : int) = 3 * i | |
923 | ||
924 | datatype ('key, 'a) dict = | |
925 | DICT of ('key * 'key -> order) * ('key, 'a) tree | |
926 | and ('key, 'a) tree = | |
927 | E | |
928 | | T of {key : 'key, | |
929 | value : 'a, | |
930 | cnt : int, | |
931 | left : ('key, 'a) tree, | |
932 | right : ('key, 'a) tree} | |
933 | ||
934 | fun treeSize E = 0 | |
935 | | treeSize (T{cnt,...}) = cnt | |
936 | ||
937 | fun numItems (DICT(_, t)) = treeSize t | |
938 | ||
939 | local | |
940 | fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | |
941 | | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} | |
942 | | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} | |
943 | | N(k,v,l as T n,r as T n') = | |
944 | T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} | |
945 | ||
946 | fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = | |
947 | N(b,bv,N(a,av,x,y),z) | |
948 | | single_L _ = raise Match | |
949 | fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = | |
950 | N(a,av,x,N(b,bv,y,z)) | |
951 | | single_R _ = raise Match | |
952 | fun double_L (a,av,w,T{key=c,value=cv, | |
953 | left=T{key=b,value=bv,left=x,right=y,...}, | |
954 | right=z,...}) = | |
955 | N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | |
956 | | double_L _ = raise Match | |
957 | fun double_R (c,cv,T{key=a,value=av,left=w, | |
958 | right=T{key=b,value=bv,left=x,right=y,...},...},z) = | |
959 | N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | |
960 | | double_R _ = raise Match | |
961 | ||
962 | fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | |
963 | | T' (k,v,E,r as T{right=E,left=E,...}) = | |
964 | T{key=k,value=v,cnt=2,left=E,right=r} | |
965 | | T' (k,v,l as T{right=E,left=E,...},E) = | |
966 | T{key=k,value=v,cnt=2,left=l,right=E} | |
967 | ||
968 | | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p | |
969 | | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p | |
970 | ||
971 | (* these cases almost never happen with small weight*) | |
972 | | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = | |
973 | if ln < rn then single_L p else double_L p | |
974 | | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = | |
975 | if ln > rn then single_R p else double_R p | |
976 | ||
977 | | T' (p as (_,_,E,T{left=E,...})) = single_L p | |
978 | | T' (p as (_,_,T{right=E,...},E)) = single_R p | |
979 | ||
980 | | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, | |
981 | r as T{cnt=rn,left=rl,right=rr,...})) = | |
982 | if rn >= wt ln then (*right is too big*) | |
983 | let val rln = treeSize rl | |
984 | val rrn = treeSize rr | |
985 | in | |
986 | if rln < rrn then single_L p else double_L p | |
987 | end | |
988 | ||
989 | else if ln >= wt rn then (*left is too big*) | |
990 | let val lln = treeSize ll | |
991 | val lrn = treeSize lr | |
992 | in | |
993 | if lrn < lln then single_R p else double_R p | |
994 | end | |
995 | ||
996 | else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} | |
997 | ||
998 | local | |
999 | fun min (T{left=E,key,value,...}) = (key,value) | |
1000 | | min (T{left,...}) = min left | |
1001 | | min _ = raise Match | |
1002 | ||
1003 | fun delmin (T{left=E,right,...}) = right | |
1004 | | delmin (T{key,value,left,right,...}) = | |
1005 | T'(key,value,delmin left,right) | |
1006 | | delmin _ = raise Match | |
1007 | in | |
1008 | fun delete' (E,r) = r | |
1009 | | delete' (l,E) = l | |
1010 | | delete' (l,r) = let val (mink,minv) = min r | |
1011 | in T'(mink,minv,l,delmin r) end | |
1012 | end | |
1013 | in | |
1014 | fun mkDict cmpKey = DICT(cmpKey, E) | |
1015 | ||
1016 | fun insert (DICT (cmpKey, t),x,v) = | |
1017 | let fun ins E = T{key=x,value=v,cnt=1,left=E,right=E} | |
1018 | | ins (T(set as {key,left,right,value,...})) = | |
1019 | case cmpKey (key,x) of | |
1020 | GREATER => T'(key,value,ins left,right) | |
1021 | | LESS => T'(key,value,left,ins right) | |
1022 | | _ => | |
1023 | T{key=x,value=v,left=left,right=right,cnt= #cnt set} | |
1024 | in DICT(cmpKey, ins t) end | |
1025 | ||
1026 | fun find (DICT(cmpKey, t), x) = | |
1027 | let fun mem E = raise NotFound | |
1028 | | mem (T(n as {key,left,right,...})) = | |
1029 | case cmpKey (x,key) of | |
1030 | GREATER => mem right | |
1031 | | LESS => mem left | |
1032 | | _ => #value n | |
1033 | in mem t end | |
1034 | ||
1035 | fun peek arg = (SOME(find arg)) handle NotFound => NONE | |
1036 | ||
1037 | fun remove (DICT(cmpKey, t), x) = | |
1038 | let fun rm E = raise NotFound | |
1039 | | rm (set as T{key,left,right,value,...}) = | |
1040 | (case cmpKey (key,x) of | |
1041 | GREATER => let val (left', v) = rm left | |
1042 | in (T'(key, value, left', right), v) end | |
1043 | | LESS => let val (right', v) = rm right | |
1044 | in (T'(key, value, left, right'), v) end | |
1045 | | _ => (delete'(left,right),value)) | |
1046 | val (newtree, valrm) = rm t | |
1047 | in (DICT(cmpKey, newtree), valrm) end | |
1048 | ||
1049 | fun listItems (DICT(_, d)) = | |
1050 | let fun d2l E res = res | |
1051 | | d2l (T{key,value,left,right,...}) res = | |
1052 | d2l left ((key,value) :: d2l right res) | |
1053 | in d2l d [] end | |
1054 | ||
1055 | fun revapp f (DICT(_, d)) = let | |
1056 | fun a E = () | |
1057 | | a (T{key,value,left,right,...}) = (a right; f(key,value); a left) | |
1058 | in a d end | |
1059 | ||
1060 | fun app f (DICT(_, d)) = let | |
1061 | fun a E = () | |
1062 | | a (T{key,value,left,right,...}) = (a left; f(key,value); a right) | |
1063 | in a d end | |
1064 | ||
1065 | fun foldr f init (DICT(_, d)) = let | |
1066 | fun a E v = v | |
1067 | | a (T{key,value,left,right,...}) v = a left (f(key,value,a right v)) | |
1068 | in a d init end | |
1069 | ||
1070 | fun foldl f init (DICT(_, d)) = let | |
1071 | fun a E v = v | |
1072 | | a (T{key,value,left,right,...}) v = a right (f(key,value,a left v)) | |
1073 | in a d init end | |
1074 | ||
1075 | fun map f (DICT(cmpKey, d)) = let | |
1076 | fun a E = E | |
1077 | | a (T{key,value,left,right,cnt}) = let | |
1078 | val left' = a left | |
1079 | val value' = f(key,value) | |
1080 | in | |
1081 | T{cnt=cnt, key=key,value=value',left = left', right = a right} | |
1082 | end | |
1083 | in DICT(cmpKey, a d) end | |
1084 | ||
1085 | fun transform f (DICT(cmpKey, d)) = | |
1086 | let fun a E = E | |
1087 | | a (T{key,value,left,right,cnt}) = | |
1088 | let val left' = a left | |
1089 | in | |
1090 | T{cnt=cnt, key=key, value=f value, left = left', | |
1091 | right = a right} | |
1092 | end | |
1093 | in DICT(cmpKey, a d) end | |
1094 | end | |
1095 | ||
1096 | end | |
1097 | (*#line 0.0 "$HOME/dev/sml/basic/src/Susp.sig"*) | |
1098 | (* Susp -- support for lazy evaluation *) | |
1099 | ||
1100 | signature Susp = | |
1101 | sig | |
1102 | ||
1103 | type 'a susp | |
1104 | ||
1105 | val delay : (unit -> 'a) -> 'a susp | |
1106 | val force : 'a susp -> 'a | |
1107 | ||
1108 | end | |
1109 | ||
1110 | (* | |
1111 | ['a susp] is the type of lazily evaluated expressions with result | |
1112 | type 'a. | |
1113 | ||
1114 | [delay (fn () => e)] creates a suspension for the expression e. | |
1115 | The first time the suspension is forced, the expression e will be | |
1116 | evaluated, and the result stored in the suspension. All subsequent | |
1117 | forcing of the suspension will just return this result, so e is | |
1118 | evaluated at most once. If the suspension is never forced, then e | |
1119 | is never evaluated. | |
1120 | ||
1121 | [force su] forces the suspension su and returns the result of the | |
1122 | expression e stored in the suspension. | |
1123 | *) | |
1124 | (*#line 0.0 "$HOME/dev/sml/basic/src/Susp.sml"*) | |
1125 | (* Susp -- support for lazy evaluation 1995-05-22 *) | |
1126 | ||
1127 | structure Susp :> Susp = | |
1128 | struct | |
1129 | ||
1130 | datatype 'a thunk = VAL of 'a | THUNK of unit -> 'a; | |
1131 | ||
1132 | type 'a susp = 'a thunk ref; | |
1133 | ||
1134 | fun delay (f : unit -> 'a) = ref (THUNK f); | |
1135 | ||
1136 | fun force (su : 'a susp) : 'a = | |
1137 | case !su of | |
1138 | VAL v => v | |
1139 | | THUNK f => let val v = f () in su := VAL v; v end | |
1140 | ||
1141 | end | |
1142 | (*#line 0.0 "$HOME/dev/sml/basic/src/Milton.sig"*) | |
1143 | (* ========================================================================= *) | |
1144 | (* MLton SPECIFIC FUNCTIONS *) | |
1145 | (* Created by Joe Hurd, September 2002 *) | |
1146 | (* ========================================================================= *) | |
1147 | ||
1148 | signature Milton = | |
1149 | sig | |
1150 | ||
1151 | (* The ML implementation *) | |
1152 | val ml : string | |
1153 | ||
1154 | (* Pointer equality using the run-time system *) | |
1155 | ||
1156 | (* Quotations a la Mosml *) | |
1157 | datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a | |
1158 | ||
1159 | (* Timing function applications a la Mosml.time *) | |
1160 | val time : ('a -> 'b) -> 'a -> 'b | |
1161 | ||
1162 | (* Bring certain declarations to the top-level *) | |
1163 | type ppstream = PP.ppstream | |
1164 | ||
1165 | (* Dummy versions of Mosml declarations to stop MLton barfing *) | |
1166 | val quotation : bool ref | |
1167 | val load : string -> unit | |
1168 | val installPP : (ppstream -> 'a -> unit) -> unit | |
1169 | ||
1170 | end | |
1171 | (*#line 0.0 "$HOME/dev/sml/basic/src/Milton.sml"*) | |
1172 | (* ========================================================================= *) | |
1173 | (* MLton SPECIFIC FUNCTIONS *) | |
1174 | (* Created by Joe Hurd, September 2002 *) | |
1175 | (* ========================================================================= *) | |
1176 | ||
1177 | structure Milton :> Milton = | |
1178 | struct | |
1179 | ||
1180 | (* ------------------------------------------------------------------------- *) | |
1181 | (* The ML implementation. *) | |
1182 | (* ------------------------------------------------------------------------- *) | |
1183 | ||
1184 | val ml = "MLton"; | |
1185 | ||
1186 | (* ------------------------------------------------------------------------- *) | |
1187 | (* Pointer equality using the run-time system. *) | |
1188 | (* ------------------------------------------------------------------------- *) | |
1189 | ||
1190 | (* ------------------------------------------------------------------------- *) | |
1191 | (* Quotations a la Mosml. *) | |
1192 | (* ------------------------------------------------------------------------- *) | |
1193 | ||
1194 | datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a; | |
1195 | ||
1196 | (* ------------------------------------------------------------------------- *) | |
1197 | (* Timing function applications a la Mosml.time. *) | |
1198 | (* ------------------------------------------------------------------------- *) | |
1199 | ||
1200 | fun time f x = | |
1201 | let | |
1202 | fun p t = | |
1203 | let | |
1204 | val s = Time.fmt 3 t | |
1205 | in | |
1206 | case size (List.last (String.fields (fn x => x = #".") s)) of 3 => s | |
1207 | | 2 => s ^ "0" | |
1208 | | 1 => s ^ "00" | |
1209 | | _ => raise Fail "Milton.time" | |
1210 | end | |
1211 | val c = Timer.startCPUTimer () | |
1212 | val r = Timer.startRealTimer () | |
1213 | fun pt () = | |
1214 | let | |
1215 | val {usr, sys, ...} = Timer.checkCPUTimer c | |
1216 | val real = Timer.checkRealTimer r | |
1217 | in | |
1218 | ||
1219 | ("User: " ^ p usr ^ " System: " ^ p sys ^ " Real: " ^ p real ^ "\n") | |
1220 | end | |
1221 | val y = f x handle e => (pt (); raise e) | |
1222 | val () = pt () | |
1223 | in | |
1224 | y | |
1225 | end; | |
1226 | ||
1227 | (* ------------------------------------------------------------------------- *) | |
1228 | (* Bring certain declarations to the top-level. *) | |
1229 | (* ------------------------------------------------------------------------- *) | |
1230 | ||
1231 | type ppstream = PP.ppstream; | |
1232 | ||
1233 | (* ------------------------------------------------------------------------- *) | |
1234 | (* Dummy versions of Mosml declarations to stop MLton barfing. *) | |
1235 | (* ------------------------------------------------------------------------- *) | |
1236 | ||
1237 | val quotation = ref false; | |
1238 | val load = fn (_ : string) => (); | |
1239 | val installPP = fn (_ : ppstream -> 'a -> unit) => (); | |
1240 | ||
1241 | end | |
1242 | open Milton; | |
1243 | (*#line 0.0 "basic/Useful.sig"*) | |
1244 | (* ========================================================================= *) | |
1245 | (* ML UTILITY FUNCTIONS *) | |
1246 | (* Created by Joe Hurd, April 2001 *) | |
1247 | (* ========================================================================= *) | |
1248 | ||
1249 | signature Useful = | |
1250 | sig | |
1251 | ||
1252 | (* Exceptions, profiling and tracing *) | |
1253 | exception ERR_EXN of {origin_function : string, message : string} | |
1254 | exception BUG_EXN of {origin_function : string, message : string} | |
1255 | val ERR : string -> string -> exn | |
1256 | val BUG : string -> string -> exn | |
1257 | val assert : bool -> exn -> unit | |
1258 | val try : ('a -> 'b) -> 'a -> 'b | |
1259 | val total : ('a -> 'b) -> 'a -> 'b option | |
1260 | val can : ('a -> 'b) -> 'a -> bool | |
1261 | val partial : exn -> ('a -> 'b option) -> 'a -> 'b | |
1262 | val timed : ('a -> 'b) -> 'a -> real * 'b | |
1263 | val tracing : int ref | |
1264 | val traces : {module : string, alignment : int -> int} list ref | |
1265 | val trace : {module : string, message : string, level : int} -> unit | |
1266 | ||
1267 | (* Combinators *) | |
1268 | val C : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c | |
1269 | val I : 'a -> 'a | |
1270 | val K : 'a -> 'b -> 'a | |
1271 | val N : int -> ('a -> 'a) -> 'a -> 'a | |
1272 | val S : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c | |
1273 | val W : ('a -> 'a -> 'b) -> 'a -> 'b | |
1274 | val oo : ('a -> 'b) * ('c -> 'd -> 'a) -> 'c -> 'd -> 'b | |
1275 | val ## : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b * 'd | |
1276 | ||
1277 | (* Booleans *) | |
1278 | val bool_to_string : bool -> string | |
1279 | val non : ('a -> bool) -> 'a -> bool | |
1280 | ||
1281 | (* Pairs *) | |
1282 | val D : 'a -> 'a * 'a | |
1283 | val Df : ('a -> 'b) -> 'a * 'a -> 'b * 'b | |
1284 | val fst : 'a * 'b -> 'a | |
1285 | val snd : 'a * 'b -> 'b | |
1286 | val pair : 'a -> 'b -> 'a * 'b | |
1287 | val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c | |
1288 | val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c | |
1289 | val equal : ''a -> ''a -> bool | |
1290 | ||
1291 | (* State transformers *) | |
1292 | val unit : 'a -> 's -> 'a * 's | |
1293 | val bind : ('s -> 'a * 's) -> ('a -> 's -> 'b * 's) -> 's -> 'b * 's | |
1294 | val mmap : ('a -> 'b) -> ('s -> 'a * 's) -> 's -> 'b * 's | |
1295 | val join : ('s -> ('s -> 'a * 's) * 's) -> 's -> 'a * 's | |
1296 | val mwhile : ('a -> bool) -> ('a -> 's -> 'a * 's) -> 'a -> 's -> 'a * 's | |
1297 | ||
1298 | (* Lists: note we count elements from 0 *) | |
1299 | val cons : 'a -> 'a list -> 'a list | |
1300 | val append : 'a list -> 'a list -> 'a list | |
1301 | val wrap : 'a -> 'a list | |
1302 | val unwrap : 'a list -> 'a | |
1303 | val first : ('a -> 'b option) -> 'a list -> 'b option | |
1304 | val index : ('a -> bool) -> 'a list -> int option | |
1305 | val maps : ('a -> 's -> 'b * 's) -> 'a list -> 's -> 'b list * 's | |
1306 | val partial_maps : ('a -> 's -> 'b option * 's) -> 'a list -> 's -> 'b list * 's | |
1307 | val enumerate : int -> 'a list -> (int * 'a) list | |
1308 | val cartwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list | |
1309 | val zipwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list | |
1310 | val zip : 'a list -> 'b list -> ('a * 'b) list | |
1311 | val unzip : ('a * 'b) list -> 'a list * 'b list | |
1312 | val split : 'a list -> int -> 'a list * 'a list (* Subscript *) | |
1313 | val update_nth : ('a -> 'a) -> int -> 'a list -> 'a list (* Subscript *) | |
1314 | ||
1315 | (* Lists-as-sets *) | |
1316 | val mem : ''a -> ''a list -> bool | |
1317 | val insert : ''a -> ''a list -> ''a list | |
1318 | val delete : ''a -> ''a list -> ''a list | |
1319 | val union : ''a list -> ''a list -> ''a list | |
1320 | val intersect : ''a list -> ''a list -> ''a list | |
1321 | val subtract : ''a list -> ''a list -> ''a list | |
1322 | val setify : ''a list -> ''a list | |
1323 | val subset : ''a list -> ''a list -> bool | |
1324 | val distinct : ''a list -> bool | |
1325 | ||
1326 | (* Comparisons *) | |
1327 | val lex_compare : ('a * 'a -> order) -> ('a * 'a) list -> order | |
1328 | ||
1329 | (* Sorting and searching *) | |
1330 | val min : ('a -> 'a -> bool) -> 'a list -> 'a | |
1331 | val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list | |
1332 | val sort : ('a -> 'a -> bool) -> 'a list -> 'a list | |
1333 | ||
1334 | (* Integers *) | |
1335 | val int_to_string : int -> string | |
1336 | val string_to_int : string -> int (* Overflow, Option *) | |
1337 | val int_to_bits : int -> bool list | |
1338 | val bits_to_int : bool list -> int (* Overflow *) | |
1339 | val interval : int -> int -> int list | |
1340 | val divides : int -> int -> bool | |
1341 | val primes : int -> int list | |
1342 | ||
1343 | (* Strings *) | |
1344 | val variant : string -> string list -> string | |
1345 | val variant_num : string -> string list -> string | |
1346 | val dest_prefix : string -> string -> string | |
1347 | val is_prefix : string -> string -> bool | |
1348 | val mk_prefix : string -> string -> string | |
1349 | ||
1350 | (* Reals *) | |
1351 | val real_to_string : real -> string; | |
1352 | ||
1353 | (* Pretty-printing *) | |
1354 | type 'a pp = ppstream -> 'a -> unit | |
1355 | val LINE_LENGTH : int ref | |
1356 | val unit_pp : 'a pp -> 'a -> unit pp | |
1357 | val pp_unit_pp : unit pp pp | |
1358 | val pp_map : ('a -> 'b) -> 'b pp -> 'a pp | |
1359 | val pp_bracket : string * string -> 'a pp -> 'a pp | |
1360 | val pp_sequence : string -> 'a pp -> 'a list pp | |
1361 | val pp_unop : string -> 'a pp -> 'a pp | |
1362 | val pp_binop : string -> 'a pp -> 'b pp -> ('a * 'b) pp | |
1363 | val pp_nothing : 'a pp | |
1364 | val pp_string : string pp | |
1365 | val pp_unit : unit pp | |
1366 | val pp_bool : bool pp | |
1367 | val pp_int : int pp | |
1368 | val pp_real : real pp | |
1369 | val pp_order : order pp | |
1370 | val pp_list : 'a pp -> 'a list pp | |
1371 | val pp_pair : 'a pp -> 'b pp -> ('a * 'b) pp | |
1372 | val pp_triple : 'a pp -> 'b pp -> 'c pp -> ('a * 'b * 'c) pp | |
1373 | val pp_record : (string * unit pp) list -> unit pp | |
1374 | val pp_option : 'a pp -> 'a option pp | |
1375 | ||
1376 | (* Sum datatype *) | |
1377 | datatype ('a, 'b) sum = INL of 'a | INR of 'b | |
1378 | val is_inl : ('a, 'b) sum -> bool | |
1379 | val is_inr : ('a, 'b) sum -> bool | |
1380 | ||
1381 | (* Maplets *) | |
1382 | datatype ('a, 'b) maplet = |-> of 'a * 'b | |
1383 | val pp_maplet : 'a pp -> 'b pp -> ('a, 'b) maplet pp | |
1384 | ||
1385 | (* Trees *) | |
1386 | datatype ('a, 'b) tree = BRANCH of 'a * ('a, 'b) tree list | LEAF of 'b | |
1387 | val tree_size : ('a, 'b) tree -> int | |
1388 | val tree_foldr : ('a -> 'c list -> 'c) -> ('b -> 'c) -> ('a, 'b) tree -> 'c | |
1389 | val tree_foldl : | |
1390 | ('a -> 'c -> 'c) -> ('b -> 'c -> 'd) -> 'c -> ('a, 'b) tree -> 'd list | |
1391 | val tree_partial_foldl : | |
1392 | ('a -> 'c -> 'c option) -> ('b -> 'c -> 'd option) -> 'c -> ('a, 'b) tree -> | |
1393 | 'd list | |
1394 | ||
1395 | (* Useful imperative features *) | |
1396 | val lazify_thunk : (unit -> 'a) -> unit -> 'a | |
1397 | val new_int : unit -> int | |
1398 | val new_ints : int -> int list | |
1399 | val with_flag : 'r ref * ('r -> 'r) -> ('a -> 'b) -> 'a -> 'b | |
1400 | ||
1401 | (* Information about the environment *) | |
1402 | val host : string | |
1403 | val date : unit -> string | |
1404 | ||
1405 | end | |
1406 | (*#line 0.0 "basic/Useful.sml"*) | |
1407 | (* ========================================================================= *) | |
1408 | (* ML UTILITY FUNCTIONS *) | |
1409 | (* Created by Joe Hurd, April 2001 *) | |
1410 | (* ========================================================================= *) | |
1411 | ||
1412 | structure Useful :> Useful = | |
1413 | struct | |
1414 | ||
1415 | infixr 0 oo ## |->; | |
1416 | ||
1417 | (* ------------------------------------------------------------------------- *) | |
1418 | (* Exceptions, profiling and tracing. *) | |
1419 | (* ------------------------------------------------------------------------- *) | |
1420 | ||
1421 | exception ERR_EXN of {origin_function : string, message : string}; | |
1422 | exception BUG_EXN of {origin_function : string, message : string}; | |
1423 | ||
1424 | fun ERR f s = ERR_EXN {origin_function = f, message = s}; | |
1425 | fun BUG f s = BUG_EXN {origin_function = f, message = s}; | |
1426 | ||
1427 | fun ERR_to_string (ERR_EXN {origin_function, message}) = | |
1428 | "\nERR in function " ^ origin_function ^ ":\n" ^ message ^ "\n" | |
1429 | | ERR_to_string _ = raise BUG "ERR_to_string" "not a ERR_EXN"; | |
1430 | ||
1431 | fun BUG_to_string (BUG_EXN {origin_function, message}) = | |
1432 | "\nBUG in function " ^ origin_function ^ ":\n" ^ message ^ "\n" | |
1433 | | BUG_to_string _ = raise BUG "BUG_to_string" "not a BUG_EXN"; | |
1434 | ||
1435 | fun assert b e = if b then () else raise e; | |
1436 | ||
1437 | fun try f a = f a | |
1438 | handle h as ERR_EXN _ => (print (ERR_to_string h); raise h) | |
1439 | | b as BUG_EXN _ => (print (BUG_to_string b); raise b) | |
1440 | | e => (print "\ntry: strange exception raised\n"; raise e); | |
1441 | ||
1442 | fun total f x = SOME (f x) handle ERR_EXN _ => NONE; | |
1443 | ||
1444 | fun can f = Option.isSome o total f; | |
1445 | ||
1446 | fun partial (e as ERR_EXN _) f x = (case f x of SOME y => y | NONE => raise e) | |
1447 | | partial _ _ _ = raise BUG "partial" "must take a ERR_EXN"; | |
1448 | ||
1449 | fun timed f a = | |
1450 | let | |
1451 | val tmr = Timer.startCPUTimer () | |
1452 | val res = f a | |
1453 | val {usr, sys, ...} = Timer.checkCPUTimer tmr | |
1454 | in | |
1455 | (Time.toReal usr + Time.toReal sys, res) | |
1456 | end; | |
1457 | ||
1458 | val tracing = ref 1; | |
1459 | ||
1460 | val traces : {module : string, alignment : int -> int} list ref = ref []; | |
1461 | ||
1462 | local | |
1463 | val MAX = 10; | |
1464 | val trace_printer = print; | |
1465 | fun query m l = | |
1466 | let val t = List.find (fn {module, ...} => module = m) (!traces) | |
1467 | in case t of NONE => MAX | SOME {alignment, ...} => alignment l | |
1468 | end; | |
1469 | in | |
1470 | fun trace {module = m, message = s, level = l} = | |
1471 | if 0 < !tracing andalso (MAX <= !tracing orelse query m l <= !tracing) | |
1472 | then trace_printer s | |
1473 | else (); | |
1474 | end; | |
1475 | ||
1476 | (* ------------------------------------------------------------------------- *) | |
1477 | (* Combinators *) | |
1478 | (* ------------------------------------------------------------------------- *) | |
1479 | ||
1480 | fun C f x y = f y x; | |
1481 | fun I x = x; | |
1482 | fun K x y = x; | |
1483 | fun N 0 _ x = x | N n f x = N (n - 1) f (f x); | |
1484 | fun S f g x = f x (g x); | |
1485 | fun W f x = f x x; | |
1486 | fun f oo g = fn x => f o (g x); | |
1487 | ||
1488 | (* ------------------------------------------------------------------------- *) | |
1489 | (* Booleans *) | |
1490 | (* ------------------------------------------------------------------------- *) | |
1491 | ||
1492 | fun bool_to_string true = "true" | |
1493 | | bool_to_string false = "false"; | |
1494 | ||
1495 | fun non f = not o f; | |
1496 | ||
1497 | (* ------------------------------------------------------------------------- *) | |
1498 | (* Pairs *) | |
1499 | (* ------------------------------------------------------------------------- *) | |
1500 | ||
1501 | fun op## (f, g) (x, y) = (f x, g y); | |
1502 | fun D x = (x, x); | |
1503 | fun Df f = f ## f; | |
1504 | fun fst (x,_) = x; | |
1505 | fun snd (_,y) = y; | |
1506 | fun pair x y = (x, y) | |
1507 | (* Note: val add_fst = pair and add_snd = C pair; *) | |
1508 | fun curry f x y = f (x, y); | |
1509 | fun uncurry f (x, y) = f x y; | |
1510 | fun equal x y = (x = y); | |
1511 | ||
1512 | (* ------------------------------------------------------------------------- *) | |
1513 | (* State transformers. *) | |
1514 | (* ------------------------------------------------------------------------- *) | |
1515 | ||
1516 | val unit : 'a -> 's -> 'a * 's = pair; | |
1517 | ||
1518 | fun bind f (g : 'a -> 's -> 'b * 's) = uncurry g o f; | |
1519 | ||
1520 | fun mmap f (m : 's -> 'a * 's) = bind m (unit o f); | |
1521 | ||
1522 | fun join (f : 's -> ('s -> 'a * 's) * 's) = bind f I; | |
1523 | ||
1524 | fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end; | |
1525 | ||
1526 | (* ------------------------------------------------------------------------- *) | |
1527 | (* Lists. *) | |
1528 | (* ------------------------------------------------------------------------- *) | |
1529 | ||
1530 | fun cons x y = x :: y; | |
1531 | fun append xs ys = xs @ ys; | |
1532 | fun wrap a = [a]; | |
1533 | fun unwrap [a] = a | unwrap _ = raise ERR "unwrap" "not a singleton"; | |
1534 | ||
1535 | fun first f [] = NONE | |
1536 | | first f (x :: xs) = (case f x of NONE => first f xs | s => s); | |
1537 | ||
1538 | fun index p = | |
1539 | let | |
1540 | fun idx _ [] = NONE | |
1541 | | idx n (x :: xs) = if p x then SOME n else idx (n + 1) xs | |
1542 | in | |
1543 | idx 0 | |
1544 | end; | |
1545 | ||
1546 | (* This is the pure version | |
1547 | fun maps (_ : 'a -> 's -> 'b * 's) [] = unit [] | |
1548 | | maps f (x :: xs) = | |
1549 | bind (f x) (fn y => bind (maps f xs) (fn ys => unit (y :: ys))); | |
1550 | *) | |
1551 | ||
1552 | (* This is an optimized version *) | |
1553 | fun maps f = | |
1554 | let fun g (x, (ys, s)) = let val (y, s) = f x s in (y :: ys, s) end | |
1555 | in fn l => fn (s : 's) => (rev ## I) (foldl g ([], s) l) | |
1556 | end; | |
1557 | ||
1558 | (* This is the pure version | |
1559 | fun partial_maps (_ : 'a -> 's -> 'b option * 's) [] = unit [] | |
1560 | | partial_maps f (x :: xs) = | |
1561 | bind (f x) | |
1562 | (fn yo => bind (partial_maps f xs) | |
1563 | (fn ys => unit (case yo of NONE => ys | SOME y => y :: ys))); | |
1564 | *) | |
1565 | ||
1566 | (* This is an optimized version *) | |
1567 | fun partial_maps f = | |
1568 | let | |
1569 | fun g (x, (ys, s)) = | |
1570 | let val (yo, s) = f x s | |
1571 | in (case yo of NONE => ys | SOME y => y :: ys, s) | |
1572 | end | |
1573 | in | |
1574 | fn l => fn (s : 's) => (rev ## I) (foldl g ([], s) l) | |
1575 | end; | |
1576 | ||
1577 | fun enumerate n = fst o C (maps (fn x => fn m => ((m, x), m + 1))) n; | |
1578 | ||
1579 | fun zipwith f = | |
1580 | let | |
1581 | fun z l [] [] = l | |
1582 | | z l (x :: xs) (y :: ys) = z (f x y :: l) xs ys | |
1583 | | z _ _ _ = raise ERR "zipwith" "lists different lengths"; | |
1584 | in | |
1585 | fn xs => fn ys => rev (z [] xs ys) | |
1586 | end; | |
1587 | ||
1588 | fun zip xs ys = zipwith pair xs ys; | |
1589 | ||
1590 | fun unzip ab = | |
1591 | foldl (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) (rev ab); | |
1592 | ||
1593 | fun cartwith f = | |
1594 | let | |
1595 | fun aux _ res _ [] = res | |
1596 | | aux xs_copy res [] (y :: yt) = aux xs_copy res xs_copy yt | |
1597 | | aux xs_copy res (x :: xt) (ys as y :: _) = | |
1598 | aux xs_copy (f x y :: res) xt ys | |
1599 | in | |
1600 | fn xs => fn ys => | |
1601 | let val xs' = rev xs in aux xs' [] xs' (rev ys) end | |
1602 | end; | |
1603 | ||
1604 | local | |
1605 | fun aux res l 0 = (rev res, l) | |
1606 | | aux _ [] _ = raise Subscript | |
1607 | | aux res (h :: t) n = aux (h :: res) t (n - 1); | |
1608 | in | |
1609 | fun split l n = aux [] l n; | |
1610 | end; | |
1611 | ||
1612 | fun update_nth f n l = | |
1613 | let | |
1614 | val (a, b) = split l n | |
1615 | in | |
1616 | case b of [] => raise Subscript | |
1617 | | h :: t => a @ (f h :: t) | |
1618 | end; | |
1619 | ||
1620 | (* ------------------------------------------------------------------------- *) | |
1621 | (* Lists-as-sets. *) | |
1622 | (* ------------------------------------------------------------------------- *) | |
1623 | ||
1624 | fun mem x = List.exists (equal x); | |
1625 | ||
1626 | fun insert x s = if mem x s then s else x :: s; | |
1627 | fun delete x s = List.filter (not o equal x) s; | |
1628 | ||
1629 | (* Removes duplicates *) | |
1630 | fun setify s = foldl (fn (v, x) => if mem v x then x else v :: x) [] s; | |
1631 | ||
1632 | (* For all three set operations: if s has duplicates, so may the result. *) | |
1633 | fun union s t = foldl (fn (v, x) => if mem v x then x else v :: x) s t; | |
1634 | fun intersect s t = foldl (fn (v, x) => if mem v t then v :: x else x) [] s; | |
1635 | fun subtract s t = foldl (fn (v, x) => if mem v t then x else v :: x) [] s; | |
1636 | ||
1637 | fun subset s t = List.all (fn x => mem x t) s; | |
1638 | ||
1639 | fun distinct [] = true | |
1640 | | distinct (x :: rest) = not (mem x rest) andalso distinct rest; | |
1641 | ||
1642 | (* ------------------------------------------------------------------------- *) | |
1643 | (* Comparisons. *) | |
1644 | (* ------------------------------------------------------------------------- *) | |
1645 | ||
1646 | fun lex_compare f = | |
1647 | let | |
1648 | fun lex [] = EQUAL | |
1649 | | lex (x :: l) = case f x of EQUAL => lex l | y => y | |
1650 | in | |
1651 | lex | |
1652 | end; | |
1653 | ||
1654 | (* ------------------------------------------------------------------------- *) | |
1655 | (* Finding the minimal element of a list, wrt some order. *) | |
1656 | (* ------------------------------------------------------------------------- *) | |
1657 | ||
1658 | fun min f = | |
1659 | let | |
1660 | fun min_acc best [] = best | |
1661 | | min_acc best (h :: t) = min_acc (if f best h then best else h) t | |
1662 | in | |
1663 | fn [] => raise ERR "min" "empty list" | |
1664 | | h :: t => min_acc h t | |
1665 | end; | |
1666 | ||
1667 | (* ------------------------------------------------------------------------- *) | |
1668 | (* Merge (for the following merge-sort, but generally useful too). *) | |
1669 | (* ------------------------------------------------------------------------- *) | |
1670 | ||
1671 | fun merge f = | |
1672 | let | |
1673 | fun mrg res [] ys = foldl (op ::) ys res | |
1674 | | mrg res xs [] = foldl (op ::) xs res | |
1675 | | mrg res (xs as x :: xt) (ys as y :: yt) = | |
1676 | if f x y then mrg (x :: res) xt ys else mrg (y :: res) xs yt | |
1677 | in | |
1678 | mrg [] | |
1679 | end; | |
1680 | ||
1681 | (* ------------------------------------------------------------------------- *) | |
1682 | (* Order function here should be <= for a stable sort... *) | |
1683 | (* ...and I think < gives a reverse stable sort (but don't quote me). *) | |
1684 | (* ------------------------------------------------------------------------- *) | |
1685 | ||
1686 | fun sort f = | |
1687 | let | |
1688 | fun srt [] = [] | |
1689 | | srt (l as [x]) = l | |
1690 | | srt l = | |
1691 | let | |
1692 | val halfway = length l div 2 | |
1693 | in | |
1694 | merge f (srt (List.take (l, halfway))) (srt (List.drop (l, halfway))) | |
1695 | end | |
1696 | in | |
1697 | srt | |
1698 | end; | |
1699 | ||
1700 | (* ------------------------------------------------------------------------- *) | |
1701 | (* Integers. *) | |
1702 | (* ------------------------------------------------------------------------- *) | |
1703 | ||
1704 | val int_to_string = Int.toString; | |
1705 | val string_to_int = Option.valOf o Int.fromString; | |
1706 | ||
1707 | fun int_to_bits 0 = [] | |
1708 | | int_to_bits n = (n mod 2 <> 0) :: (int_to_bits (n div 2)); | |
1709 | ||
1710 | fun bits_to_int [] = 0 | |
1711 | | bits_to_int (h :: t) = (if h then curry op+ 1 else I) (2 * bits_to_int t); | |
1712 | ||
1713 | fun interval m 0 = [] | |
1714 | | interval m len = m :: interval (m + 1) (len - 1); | |
1715 | ||
1716 | fun divides a b = if a = 0 then b = 0 else b mod (Int.abs a) = 0; | |
1717 | ||
1718 | local | |
1719 | fun both f g n = f n andalso g n; | |
1720 | fun next f = let fun nx x = if f x then x else nx (x + 1) in nx end; | |
1721 | ||
1722 | fun looking res 0 _ _ = rev res | |
1723 | | looking res n f x = | |
1724 | let | |
1725 | val p = next f x | |
1726 | val res' = p :: res | |
1727 | val f' = both f (not o divides p) | |
1728 | in | |
1729 | looking res' (n - 1) f' (p + 1) | |
1730 | end | |
1731 | in | |
1732 | fun primes n = looking [] n (K true) 2 | |
1733 | end; | |
1734 | ||
1735 | (* ------------------------------------------------------------------------- *) | |
1736 | (* Strings. *) | |
1737 | (* ------------------------------------------------------------------------- *) | |
1738 | ||
1739 | fun variant x vars = if mem x vars then variant (x ^ "'") vars else x; | |
1740 | ||
1741 | fun variant_num x vars = | |
1742 | let | |
1743 | fun xn n = x ^ int_to_string n | |
1744 | fun v n = let val x' = xn n in if mem x' vars then v (n + 1) else x' end | |
1745 | in | |
1746 | if mem x vars then v 1 else x | |
1747 | end; | |
1748 | ||
1749 | fun dest_prefix p = | |
1750 | let | |
1751 | fun check s = assert (String.isPrefix p s) (ERR "dest_prefix" "") | |
1752 | val size_p = size p | |
1753 | in | |
1754 | fn s => (check s; String.extract (s, size_p, NONE)) | |
1755 | end; | |
1756 | ||
1757 | fun is_prefix p = can (dest_prefix p); | |
1758 | ||
1759 | fun mk_prefix p s = p ^ s; | |
1760 | ||
1761 | (* ------------------------------------------------------------------------- *) | |
1762 | (* Reals. *) | |
1763 | (* ------------------------------------------------------------------------- *) | |
1764 | ||
1765 | val real_to_string = Real.toString; | |
1766 | ||
1767 | (* ------------------------------------------------------------------------- *) | |
1768 | (* Pretty-printing. *) | |
1769 | (* ------------------------------------------------------------------------- *) | |
1770 | ||
1771 | type 'a pp = ppstream -> 'a -> unit; | |
1772 | ||
1773 | val LINE_LENGTH = ref 75; | |
1774 | ||
1775 | fun unit_pp pp_a a pp () = pp_a pp a; | |
1776 | ||
1777 | fun pp_unit_pp pp upp = upp pp (); | |
1778 | ||
1779 | fun pp_map f pp_a (ppstrm : ppstream) x : unit = pp_a ppstrm (f x); | |
1780 | ||
1781 | fun pp_bracket (l, r) pp_a pp a = | |
1782 | (PP.begin_block pp PP.INCONSISTENT (size l); PP.add_string pp l; pp_a pp a; | |
1783 | PP.add_string pp r; PP.end_block pp); | |
1784 | ||
1785 | fun pp_sequence sep pp_a = | |
1786 | let | |
1787 | fun pp_elt pp x = (PP.add_string pp sep; PP.add_break pp (1, 0); pp_a pp x) | |
1788 | fun pp_seq pp [] = () | |
1789 | | pp_seq pp (h :: t) = (pp_a pp h; app (pp_elt pp) t) | |
1790 | in | |
1791 | fn pp => fn l => | |
1792 | (PP.begin_block pp PP.INCONSISTENT 0; pp_seq pp l; PP.end_block pp) | |
1793 | end; | |
1794 | ||
1795 | fun pp_unop s pp_a pp a = | |
1796 | (PP.begin_block pp PP.CONSISTENT 0; | |
1797 | PP.add_string pp s; | |
1798 | PP.add_break pp (1, 0); | |
1799 | pp_a pp a; | |
1800 | PP.end_block pp); | |
1801 | ||
1802 | fun pp_binop s pp_a pp_b pp (a, b) = | |
1803 | (PP.begin_block pp PP.CONSISTENT 0; | |
1804 | pp_a pp a; | |
1805 | PP.add_string pp s; | |
1806 | PP.add_break pp (1, 0); | |
1807 | pp_b pp b; | |
1808 | PP.end_block pp); | |
1809 | ||
1810 | fun pp_nothing pp _ = (PP.begin_block pp PP.CONSISTENT 0; PP.end_block pp); | |
1811 | ||
1812 | fun pp_string pp s = | |
1813 | (PP.begin_block pp PP.CONSISTENT 0; PP.add_string pp s; PP.end_block pp); | |
1814 | ||
1815 | val pp_unit = fn z => (pp_map (K "()") pp_string) z; | |
1816 | ||
1817 | val pp_bool = pp_map bool_to_string pp_string; | |
1818 | ||
1819 | val pp_int = pp_map int_to_string pp_string; | |
1820 | ||
1821 | val pp_real = pp_map real_to_string pp_string; | |
1822 | ||
1823 | val pp_order = | |
1824 | pp_map (fn LESS => "LESS" | EQUAL => "EQUAL" | GREATER => "GREATER") | |
1825 | pp_string; | |
1826 | ||
1827 | fun pp_list pp_a = pp_bracket ("[", "]") (pp_sequence "," pp_a); | |
1828 | ||
1829 | fun pp_pair pp_a pp_b = pp_bracket ("(", ")") (pp_binop "," pp_a pp_b); | |
1830 | ||
1831 | fun pp_triple pp_a pp_b pp_c = | |
1832 | pp_bracket ("(", ")") | |
1833 | (pp_map (fn (a, b, c) => (a, (b, c))) | |
1834 | (pp_binop "," pp_a (pp_binop "," pp_b pp_c))); | |
1835 | ||
1836 | local | |
1837 | val pp_l = fn z => (pp_sequence "," (pp_binop " =" pp_string pp_unit_pp)) z; | |
1838 | in | |
1839 | fun pp_record l = pp_bracket ("{", "}") (unit_pp pp_l l); | |
1840 | end; | |
1841 | ||
1842 | fun pp_option pp_a pp NONE = pp_string pp "NONE" | |
1843 | | pp_option pp_a pp (SOME a) = pp_unop "SOME" pp_a pp a; | |
1844 | ||
1845 | (* ------------------------------------------------------------------------- *) | |
1846 | (* Sums. *) | |
1847 | (* ------------------------------------------------------------------------- *) | |
1848 | ||
1849 | datatype ('a, 'b) sum = INL of 'a | INR of 'b | |
1850 | ||
1851 | fun is_inl (INL _) = true | is_inl (INR _) = false; | |
1852 | ||
1853 | fun is_inr (INR _) = true | is_inr (INL _) = false; | |
1854 | ||
1855 | (* ------------------------------------------------------------------------- *) | |
1856 | (* Maplets. *) | |
1857 | (* ------------------------------------------------------------------------- *) | |
1858 | ||
1859 | datatype ('a, 'b) maplet = |-> of 'a * 'b; | |
1860 | ||
1861 | fun pp_maplet pp_a pp_b = | |
1862 | pp_map (fn a |-> b => (a, b)) (pp_binop " |->" pp_a pp_b); | |
1863 | ||
1864 | (* ------------------------------------------------------------------------- *) | |
1865 | (* Trees. *) | |
1866 | (* ------------------------------------------------------------------------- *) | |
1867 | ||
1868 | datatype ('a, 'b) tree = BRANCH of 'a * ('a, 'b) tree list | LEAF of 'b; | |
1869 | ||
1870 | fun tree_size (LEAF _) = 1 | |
1871 | | tree_size (BRANCH (_, t)) = foldl (op+ o (tree_size ## I)) 1 t; | |
1872 | ||
1873 | fun tree_foldr f_b f_l (LEAF l) = f_l l | |
1874 | | tree_foldr f_b f_l (BRANCH (p, s)) = f_b p (map (tree_foldr f_b f_l) s); | |
1875 | ||
1876 | fun tree_foldl f_b f_l = | |
1877 | let | |
1878 | fun fold state (LEAF l, res) = f_l l state :: res | |
1879 | | fold state (BRANCH (p, ts), res) = foldl (fold (f_b p state)) res ts | |
1880 | in | |
1881 | fn state => fn t => fold state (t, []) | |
1882 | end; | |
1883 | ||
1884 | fun tree_partial_foldl f_b f_l = | |
1885 | let | |
1886 | fun fold state (LEAF l, res) = | |
1887 | (case f_l l state of NONE => res | SOME x => x :: res) | |
1888 | | fold state (BRANCH (p, ts), res) = | |
1889 | (case f_b p state of NONE => res | SOME s => foldl (fold s) res ts) | |
1890 | in | |
1891 | fn state => fn t => fold state (t, []) | |
1892 | end; | |
1893 | ||
1894 | (* ------------------------------------------------------------------------- *) | |
1895 | (* Useful imperative features. *) | |
1896 | (* ------------------------------------------------------------------------- *) | |
1897 | ||
1898 | fun lazify_thunk f = let val s = Susp.delay f in fn () => Susp.force s end; | |
1899 | ||
1900 | local | |
1901 | val generator = ref 0 | |
1902 | in | |
1903 | fun new_int () = let val n = !generator val () = generator := n + 1 in n end; | |
1904 | ||
1905 | fun new_ints 0 = [] | |
1906 | | new_ints k = | |
1907 | let val n = !generator val () = generator := n + k in interval n k end; | |
1908 | end; | |
1909 | ||
1910 | fun with_flag (r, update) f x = | |
1911 | let | |
1912 | val old = !r | |
1913 | val () = r := update old | |
1914 | val y = f x handle e => (r := old; raise e) | |
1915 | val () = r := old | |
1916 | in | |
1917 | y | |
1918 | end; | |
1919 | ||
1920 | (* ------------------------------------------------------------------------- *) | |
1921 | (* Information about the environment. *) | |
1922 | (* ------------------------------------------------------------------------- *) | |
1923 | ||
1924 | val host = Option.getOpt (OS.Process.getEnv "HOSTNAME", "unknown"); | |
1925 | ||
1926 | val date = Date.fmt "%H:%M:%S %d/%m/%Y" o Date.fromTimeLocal o Time.now; | |
1927 | ||
1928 | end | |
1929 | (*#line 0.0 "basic/Queue.sig"*) | |
1930 | (* ========================================================================= *) | |
1931 | (* A QUEUE DATATYPE FOR ML *) | |
1932 | (* Created by Joe Hurd, October 2001 *) | |
1933 | (* ========================================================================= *) | |
1934 | ||
1935 | signature Queue = | |
1936 | sig | |
1937 | ||
1938 | type 'a queue | |
1939 | ||
1940 | val empty : 'a queue | |
1941 | val add : 'a -> 'a queue -> 'a queue | |
1942 | val is_empty : 'a queue -> bool | |
1943 | val hd : 'a queue -> 'a (* raises Empty *) | |
1944 | val tl : 'a queue -> 'a queue (* raises Empty *) | |
1945 | val length : 'a queue -> int | |
1946 | val from_list : 'a list -> 'a queue | |
1947 | val to_list : 'a queue -> 'a list | |
1948 | val pp_queue : 'a Useful.pp -> 'a queue Useful.pp | |
1949 | ||
1950 | end | |
1951 | (*#line 0.0 "basic/Queue.sml"*) | |
1952 | (* ========================================================================= *) | |
1953 | (* A QUEUE DATATYPE FOR ML *) | |
1954 | (* Created by Joe Hurd, October 2001 *) | |
1955 | (* ========================================================================= *) | |
1956 | ||
1957 | structure Queue :> Queue = | |
1958 | struct | |
1959 | ||
1960 | type 'a queue = 'a list * 'a list; | |
1961 | ||
1962 | val empty : 'a queue = ([], []); | |
1963 | ||
1964 | fun norm ([], ys as _ :: _) = (rev ys, []) | |
1965 | | norm q = q; | |
1966 | ||
1967 | fun add z (xs, ys) = norm (xs, z :: ys); | |
1968 | ||
1969 | fun is_empty ([], _) = true | |
1970 | | is_empty (_ :: _, _) = false; | |
1971 | ||
1972 | fun hd ([], _) = raise Empty | |
1973 | | hd (x :: _, _) = x; | |
1974 | ||
1975 | fun tl ([], _) = raise Empty | |
1976 | | tl (_ :: xs, ys) = norm (xs, ys); | |
1977 | ||
1978 | val length = fn (xs, ys) => length xs + length ys; | |
1979 | ||
1980 | fun from_list l = (rev l, []); | |
1981 | ||
1982 | fun to_list (xs, ys) = xs @ rev ys; | |
1983 | ||
1984 | local | |
1985 | open Useful; | |
1986 | in | |
1987 | fun pp_queue pp_a = | |
1988 | pp_map to_list (pp_bracket ("Q[", "]") (pp_sequence "," pp_a)); | |
1989 | end; | |
1990 | ||
1991 | end | |
1992 | (*#line 0.0 "basic/Heap.sig"*) | |
1993 | (* ========================================================================= *) | |
1994 | (* A HEAP DATATYPE FOR ML *) | |
1995 | (* Created by Joe Hurd, October 2001 *) | |
1996 | (* Taken from Purely Functional Data Structures, by Chris Okasaki. *) | |
1997 | (* ========================================================================= *) | |
1998 | ||
1999 | signature Heap = | |
2000 | sig | |
2001 | ||
2002 | type 'a heap | |
2003 | ||
2004 | val empty : ('a * 'a -> order) -> 'a heap | |
2005 | val add : 'a -> 'a heap -> 'a heap | |
2006 | val is_empty : 'a heap -> bool | |
2007 | val top : 'a heap -> 'a (* raises Empty *) | |
2008 | val remove : 'a heap -> 'a * 'a heap (* raises Empty *) | |
2009 | val size : 'a heap -> int | |
2010 | val app : ('a -> unit) -> 'a heap -> unit | |
2011 | val to_list : 'a heap -> 'a list | |
2012 | val pp_heap : 'a Useful.pp -> 'a heap Useful.pp | |
2013 | ||
2014 | end | |
2015 | (*#line 0.0 "basic/Heap.sml"*) | |
2016 | (* ========================================================================= *) | |
2017 | (* A HEAP DATATYPE FOR ML *) | |
2018 | (* Created by Joe Hurd, October 2001 *) | |
2019 | (* Taken from Purely Functional Data Structures, by Chris Okasaki. *) | |
2020 | (* ========================================================================= *) | |
2021 | ||
2022 | (* | |
2023 | *) | |
2024 | structure Heap :> Heap = | |
2025 | struct | |
2026 | ||
2027 | datatype 'a node = E | T of int * 'a * 'a node * 'a node; | |
2028 | ||
2029 | datatype 'a heap = Heap of ('a * 'a -> order) * int * 'a node; | |
2030 | ||
2031 | fun rank E = 0 | |
2032 | | rank (T (r, _, _, _)) = r; | |
2033 | ||
2034 | fun makeT (x, a, b) = | |
2035 | if rank a >= rank b then T (rank b + 1, x, a, b) else T (rank a + 1, x, b, a); | |
2036 | ||
2037 | fun merge f = | |
2038 | let | |
2039 | fun mrg (h, E) = h | |
2040 | | mrg (E, h) = h | |
2041 | | mrg (h1 as T (_, x, a1, b1), h2 as T (_, y, a2, b2)) = | |
2042 | (case f (x, y) of GREATER => makeT (y, a2, mrg (h1, b2)) | |
2043 | | _ => makeT (x, a1, mrg (b1, h2))) | |
2044 | in | |
2045 | mrg | |
2046 | end; | |
2047 | ||
2048 | fun empty f = Heap (f, 0, E); | |
2049 | ||
2050 | fun add x (Heap (f, n, a)) = Heap (f, n + 1, merge f (T (1, x, E, E), a)); | |
2051 | ||
2052 | fun is_empty (Heap (_, _, E)) = true | |
2053 | | is_empty (Heap (_, _, T _)) = false; | |
2054 | ||
2055 | fun top (Heap (_, _, E)) = raise Empty | |
2056 | | top (Heap (_, _, T (_, x, _, _))) = x; | |
2057 | ||
2058 | fun remove (Heap (_, _, E)) = raise Empty | |
2059 | | remove (Heap (f, n, T (_, x, a, b))) = (x, Heap (f, n - 1, merge f (a, b))); | |
2060 | ||
2061 | fun size (Heap (_, n, _)) = n; | |
2062 | ||
2063 | fun app f = | |
2064 | let | |
2065 | fun ap [] = () | |
2066 | | ap (E :: rest) = ap rest | |
2067 | | ap (T (_, d, a, b) :: rest) = (f d; ap (a :: b :: rest)) | |
2068 | in | |
2069 | fn Heap (_, _, a) => ap [a] | |
2070 | end; | |
2071 | ||
2072 | local | |
2073 | fun to_lst res h = | |
2074 | if is_empty h then rev res | |
2075 | else let val (x, h) = remove h in to_lst (x :: res) h end; | |
2076 | in | |
2077 | fun to_list h = to_lst [] h; | |
2078 | end; | |
2079 | ||
2080 | local | |
2081 | open Useful; | |
2082 | in | |
2083 | fun pp_heap pp_a = | |
2084 | pp_map to_list (pp_bracket ("H[", "]") (pp_sequence "," pp_a)); | |
2085 | end; | |
2086 | ||
2087 | end | |
2088 | (*#line 0.0 "basic/Multiset.sig"*) | |
2089 | (* ========================================================================= *) | |
2090 | (* A MULTISET DATATYPE FOR ML *) | |
2091 | (* Created by Joe Hurd, July 2002 *) | |
2092 | (* ========================================================================= *) | |
2093 | ||
2094 | signature Multiset = | |
2095 | sig | |
2096 | ||
2097 | type 'a mset | |
2098 | ||
2099 | val empty : ('a * 'a -> order) -> 'a mset | |
2100 | val insert : 'a * int -> 'a mset -> 'a mset | |
2101 | val count : 'a mset -> 'a -> int | |
2102 | val union : 'a mset -> 'a mset -> 'a mset | |
2103 | val compl : 'a mset -> 'a mset | |
2104 | val subtract : 'a mset -> 'a mset -> 'a mset | |
2105 | val subset : 'a mset -> 'a mset -> bool | |
2106 | val compare : 'a mset * 'a mset -> order option | |
2107 | val app : ('a * int -> unit) -> 'a mset -> unit | |
2108 | val to_list : 'a mset -> ('a * int) list | |
2109 | val pp_mset : 'a Useful.pp -> 'a mset Useful.pp | |
2110 | ||
2111 | end | |
2112 | (*#line 0.0 "basic/Multiset.sml"*) | |
2113 | (* ========================================================================= *) | |
2114 | (* A MULTISET DATATYPE FOR ML *) | |
2115 | (* Created by Joe Hurd, July 2002 *) | |
2116 | (* ========================================================================= *) | |
2117 | ||
2118 | (* | |
2119 | List.app load ["Binarymap", "Useful"]; | |
2120 | *) | |
2121 | ||
2122 | (* | |
2123 | *) | |
2124 | structure Multiset :> Multiset = | |
2125 | struct | |
2126 | ||
2127 | structure M = Binarymap; | |
2128 | ||
2129 | fun Mpurge m k = let val (m, _) = M.remove (m, k) in m end; | |
2130 | ||
2131 | fun Mall p = | |
2132 | let | |
2133 | exception Cut | |
2134 | fun f (x, y, ()) = if p (x, y) then () else raise Cut | |
2135 | in | |
2136 | fn a => (M.foldl f () a; true) handle Cut => false | |
2137 | end; | |
2138 | ||
2139 | type 'a mset = ('a, int) M.dict; | |
2140 | ||
2141 | fun empty ord : 'a mset = M.mkDict ord; | |
2142 | ||
2143 | fun insert (_, 0) a = a | |
2144 | | insert (x, n) a = | |
2145 | (case M.peek (a, x) of NONE => M.insert (a, x, n) | |
2146 | | SOME n' => | |
2147 | let val n'' = n + n' | |
2148 | in if n'' = 0 then Mpurge a x else M.insert (a, x, n'') | |
2149 | end); | |
2150 | ||
2151 | fun count m x = case M.peek (m, x) of SOME n => n | NONE => 0; | |
2152 | ||
2153 | local fun un a b = M.foldl (fn (x : 'a, n : int, d) => insert (x, n) d) a b; | |
2154 | in fun union a b = if M.numItems a < M.numItems b then un b a else un a b; | |
2155 | end; | |
2156 | ||
2157 | fun compl a : 'a mset = M.transform ~ a; | |
2158 | ||
2159 | fun subtract a b = union a (compl b); | |
2160 | ||
2161 | local | |
2162 | fun sign a = (Mall (fn (_, n) => 0 <= n) a, Mall (fn (_, n) => n <= 0) a); | |
2163 | in | |
2164 | fun compare (a, b) = | |
2165 | (case sign (subtract a b) of (true, true) => SOME EQUAL | |
2166 | | (true, false) => SOME GREATER | |
2167 | | (false, true) => SOME LESS | |
2168 | | (false, false) => NONE); | |
2169 | end; | |
2170 | ||
2171 | fun subset a b = | |
2172 | (case compare (a, b) of SOME LESS => true | |
2173 | | SOME EQUAL => true | |
2174 | | _ => false); | |
2175 | ||
2176 | fun app f (a : 'a mset) = M.app f a; | |
2177 | ||
2178 | fun to_list (a : 'a mset) = M.listItems a; | |
2179 | ||
2180 | local | |
2181 | open Useful; | |
2182 | in | |
2183 | fun pp_mset pp_a = | |
2184 | pp_map (map Useful.|-> o to_list) | |
2185 | (pp_bracket ("M[", "]") (pp_sequence "," (Useful.pp_maplet pp_a pp_int))); | |
2186 | end; | |
2187 | ||
2188 | end | |
2189 | (*#line 0.0 "basic/Stream.sig"*) | |
2190 | (* ========================================================================= *) | |
2191 | (* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *) | |
2192 | (* Created by Joe Hurd, April 2001 *) | |
2193 | (* ========================================================================= *) | |
2194 | ||
2195 | signature Stream = | |
2196 | sig | |
2197 | ||
2198 | datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream) | |
2199 | type 'a Sthk = unit -> 'a stream | |
2200 | ||
2201 | (* If you're wondering how to create an infinite stream: *) | |
2202 | (* val stream4 = let fun s4 () = CONS 4 s4 in s4 () end; *) | |
2203 | ||
2204 | val cons : 'a -> (unit -> 'a stream) -> 'a stream | |
2205 | val null : 'a stream -> bool | |
2206 | val hd : 'a stream -> 'a (* raises Empty *) | |
2207 | val tl : 'a stream -> 'a stream (* raises Empty *) | |
2208 | val dest : 'a stream -> 'a * 'a stream (* raises Empty *) | |
2209 | val repeat : 'a -> 'a stream | |
2210 | val count : int -> int stream | |
2211 | val fold : ('a -> (unit -> 'b) -> 'b) -> 'b -> 'a stream -> 'b | |
2212 | val map : ('a -> 'b) -> 'a stream -> 'b stream | |
2213 | val map_thk : ('a Sthk -> 'a Sthk) -> 'a Sthk -> 'a Sthk | |
2214 | val partial_map : ('a -> 'b option) -> 'a stream -> 'b stream | |
2215 | val maps : ('a -> 'c -> 'b * 'c) -> 'c -> 'a stream -> 'b stream | |
2216 | val partial_maps : ('a -> 'c -> 'b option * 'c) -> 'c -> 'a stream -> 'b stream | |
2217 | val filter : ('a -> bool) -> 'a stream -> 'a stream | |
2218 | val flatten : 'a stream stream -> 'a stream | |
2219 | val zipwith : ('a -> 'b -> 'c) -> 'a stream -> 'b stream -> 'c stream | |
2220 | val zip : 'a stream -> 'b stream -> ('a * 'b) stream | |
2221 | val take : int -> 'a stream -> 'a stream (* raises Subscript *) | |
2222 | val drop : int -> 'a stream -> 'a stream (* raises Subscript *) | |
2223 | val to_list : 'a stream -> 'a list | |
2224 | val from_list : 'a list -> 'a stream | |
2225 | val from_textfile : string -> string stream (* lines of the file *) | |
2226 | ||
2227 | end | |
2228 | (*#line 0.0 "basic/Stream.sml"*) | |
2229 | (* ========================================================================= *) | |
2230 | (* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *) | |
2231 | (* Created by Joe Hurd, April 2001 *) | |
2232 | (* ========================================================================= *) | |
2233 | ||
2234 | structure Stream :> Stream = | |
2235 | struct | |
2236 | ||
2237 | open Useful; | |
2238 | ||
2239 | infixr 0 oo ##; | |
2240 | ||
2241 | (* ------------------------------------------------------------------------- *) | |
2242 | (* The datatype declaration encapsulates all the primitive operations. *) | |
2243 | (* ------------------------------------------------------------------------- *) | |
2244 | ||
2245 | datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream); | |
2246 | ||
2247 | type 'a Sthk = unit -> 'a stream; | |
2248 | ||
2249 | (* ------------------------------------------------------------------------- *) | |
2250 | (* Useful functions. *) | |
2251 | (* ------------------------------------------------------------------------- *) | |
2252 | ||
2253 | val cons = fn z => curry CONS z; | |
2254 | ||
2255 | fun null NIL = true | null (CONS _) = false; | |
2256 | ||
2257 | fun hd NIL = raise Empty | hd (CONS (h, _)) = h; | |
2258 | ||
2259 | fun tl NIL = raise Empty | tl (CONS (_, t)) = t (); | |
2260 | ||
2261 | fun dest s = (hd s, tl s); | |
2262 | ||
2263 | fun repeat x = let fun rep () = CONS (x, rep) in rep () end; | |
2264 | ||
2265 | fun count n = CONS (n, fn () => count (n + 1)); | |
2266 | ||
2267 | fun fold b c = | |
2268 | let fun f NIL = c | f (CONS (x, xs)) = b x (fn () => f (xs ())) in f end; | |
2269 | ||
2270 | fun map f = | |
2271 | let | |
2272 | fun m NIL = NIL | |
2273 | | m (CONS (h, t)) = CONS (f h, fn () => m (t ())) | |
2274 | in | |
2275 | m | |
2276 | end; | |
2277 | ||
2278 | fun map_thk f = | |
2279 | let | |
2280 | fun mt NIL = NIL | |
2281 | | mt (CONS (h, t)) = CONS (h, mt' t) | |
2282 | and mt' t = f (fn () => mt (t ())) | |
2283 | in | |
2284 | mt' | |
2285 | end; | |
2286 | ||
2287 | fun partial_map f = | |
2288 | let | |
2289 | fun mp NIL = NIL | |
2290 | | mp (CONS (h, t)) = | |
2291 | case f h of NONE => mp (t ()) | |
2292 | | SOME h' => CONS (h', fn () => mp (t ())) | |
2293 | in | |
2294 | mp | |
2295 | end; | |
2296 | ||
2297 | fun maps f = | |
2298 | let | |
2299 | fun mm _ NIL = NIL | |
2300 | | mm s (CONS (x, xs)) = | |
2301 | let val (y, s') = f x s | |
2302 | in CONS (y, fn () => mm s' (xs ())) | |
2303 | end | |
2304 | in | |
2305 | mm | |
2306 | end; | |
2307 | ||
2308 | fun partial_maps f = | |
2309 | let | |
2310 | fun mm _ NIL = NIL | |
2311 | | mm s (CONS (x, xs)) = | |
2312 | let | |
2313 | val (yo, s') = f x s | |
2314 | val t = mm s' o xs | |
2315 | in | |
2316 | case yo of NONE => t () | SOME y => CONS (y, t) | |
2317 | end | |
2318 | in | |
2319 | mm | |
2320 | end; | |
2321 | ||
2322 | fun filter f = partial_map (fn x => if f x then SOME x else NONE); | |
2323 | ||
2324 | fun flatten NIL = NIL | |
2325 | | flatten (CONS (NIL, ss)) = flatten (ss ()) | |
2326 | | flatten (CONS (CONS (x, xs), ss)) = | |
2327 | CONS (x, fn () => flatten (CONS (xs (), ss))); | |
2328 | ||
2329 | fun zipwith f = | |
2330 | let | |
2331 | fun z NIL _ = NIL | |
2332 | | z _ NIL = NIL | |
2333 | | z (CONS (x, xs)) (CONS (y, ys)) = | |
2334 | CONS (f x y, fn () => z (xs ()) (ys ())) | |
2335 | in | |
2336 | z | |
2337 | end; | |
2338 | ||
2339 | fun zip s t = zipwith pair s t; | |
2340 | ||
2341 | fun take 0 s = NIL | |
2342 | | take n NIL = raise Subscript | |
2343 | | take 1 (CONS (x, _)) = CONS (x, K NIL) | |
2344 | | take n (CONS (x, xs)) = CONS (x, fn () => take (n - 1) (xs ())); | |
2345 | ||
2346 | fun drop n s = N n tl s handle Empty => raise Subscript; | |
2347 | ||
2348 | local | |
2349 | fun to_lst res NIL = res | |
2350 | | to_lst res (CONS (x, xs)) = to_lst (x :: res) (xs ()); | |
2351 | in | |
2352 | val to_list = fn z => (rev o to_lst []) z | |
2353 | end; | |
2354 | ||
2355 | fun from_list [] = NIL | |
2356 | | from_list (x :: xs) = CONS (x, fn () => from_list xs); | |
2357 | ||
2358 | fun from_textfile filename = | |
2359 | let | |
2360 | open TextIO | |
2361 | val fh = openIn filename | |
2362 | fun res () = | |
2363 | case inputLine fh of NONE => (closeIn fh; NIL) | |
2364 | | SOME s => CONS (s, lazify_thunk res) | |
2365 | in | |
2366 | res () | |
2367 | end; | |
2368 | ||
2369 | end | |
2370 | (*#line 0.0 "basic/Parser.sig"*) | |
2371 | (* ========================================================================= *) | |
2372 | (* PARSER COMBINATORS *) | |
2373 | (* Created by Joe Hurd, April 2001 *) | |
2374 | (* ========================================================================= *) | |
2375 | ||
2376 | signature Parser = | |
2377 | sig | |
2378 | ||
2379 | (* Recommended fixities | |
2380 | infixr 9 >>++; | |
2381 | infixr 8 ++; | |
2382 | infixr 7 >>; | |
2383 | infixr 6 ||; | |
2384 | *) | |
2385 | ||
2386 | type 'a pp = 'a Useful.pp | |
2387 | type 'a stream = 'a Stream.stream | |
2388 | ||
2389 | (* Generic *) | |
2390 | exception Noparse | |
2391 | val ++ : ('a -> 'b * 'a) * ('a -> 'c * 'a) -> 'a -> ('b * 'c) * 'a | |
2392 | val >> : ('a -> 'b * 'a) * ('b -> 'c) -> 'a -> 'c * 'a | |
2393 | val >>++ : ('a -> 'b * 'a) * ('b -> 'a -> 'c * 'a) -> 'a -> 'c * 'a | |
2394 | val || : ('a -> 'b * 'a) * ('a -> 'b * 'a) -> 'a -> 'b * 'a | |
2395 | val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a | |
2396 | val atleastone : ('a -> 'b * 'a) -> 'a -> 'b list * 'a | |
2397 | val nothing : 'a -> unit * 'a | |
2398 | val optional : ('a -> 'b * 'a) -> 'a -> 'b option * 'a | |
2399 | ||
2400 | (* Stream-based *) | |
2401 | type ('a, 'b) parser = 'a stream -> 'b * 'a stream | |
2402 | val maybe : ('a -> 'b option) -> ('a, 'b) parser | |
2403 | val finished : ('a, unit) parser | |
2404 | val some : ('a -> bool) -> ('a, 'a) parser | |
2405 | val any : ('a, 'a) parser | |
2406 | val exact : ''a -> (''a, ''a) parser | |
2407 | ||
2408 | (* Parsing and pretty-printing for infix operators *) | |
2409 | type infixities = {tok : string, prec : int, left_assoc : bool} list | |
2410 | type 'a con = string * 'a * 'a -> 'a | |
2411 | type 'a des = 'a -> (string * 'a * 'a) option | |
2412 | type 'a iparser = (string, 'a) parser | |
2413 | type 'a iprinter = ('a * bool) pp | |
2414 | val optoks : infixities -> string list | |
2415 | val parse_left_infix : string list -> 'a con -> 'a iparser -> 'a iparser | |
2416 | val parse_right_infix : string list -> 'a con -> 'a iparser -> 'a iparser | |
2417 | val parse_infixes : infixities -> 'a con -> 'a iparser -> 'a iparser | |
2418 | val pp_left_infix : string list -> 'a des -> 'a iprinter -> 'a iprinter | |
2419 | val pp_right_infix : string list -> 'a des -> 'a iprinter -> 'a iprinter | |
2420 | val pp_infixes : infixities -> 'a des -> 'a iprinter -> 'a iprinter | |
2421 | ||
2422 | (* Lexing *) | |
2423 | val space : char -> bool | |
2424 | val digit : char -> bool | |
2425 | val lower : char -> bool | |
2426 | val upper : char -> bool | |
2427 | val alpha : char -> bool | |
2428 | val alphanum : char -> bool (* alpha + digit + _ + ' *) | |
2429 | val symbol : char -> bool (* <>=-*+/\?@|!$%&~#^: *) | |
2430 | val punct : char -> bool (* ()[]{}.,; *) | |
2431 | ||
2432 | (* Quotations *) | |
2433 | type 'a quotation = 'a frag list | |
2434 | val quotation_parser : (string -> 'a) -> 'b pp -> 'b quotation -> 'a | |
2435 | ||
2436 | end | |
2437 | (*#line 0.0 "basic/Parser.sml"*) | |
2438 | (* ========================================================================= *) | |
2439 | (* PARSER COMBINATORS *) | |
2440 | (* Created by Joe Hurd, April 2001 *) | |
2441 | (* ========================================================================= *) | |
2442 | ||
2443 | (* | |
2444 | app load ["Useful", "Stream"]; | |
2445 | *) | |
2446 | ||
2447 | (* | |
2448 | *) | |
2449 | structure Parser :> Parser = | |
2450 | struct | |
2451 | ||
2452 | open Useful; | |
2453 | ||
2454 | structure S = Stream; | |
2455 | ||
2456 | infixr 9 >>++; | |
2457 | infixr 8 ++; | |
2458 | infixr 7 >>; | |
2459 | infixr 6 ||; | |
2460 | infix ##; | |
2461 | ||
2462 | type 'a stream = 'a Stream.stream; | |
2463 | val omap = Option.map; | |
2464 | ||
2465 | (* ------------------------------------------------------------------------- *) | |
2466 | (* Generic. *) | |
2467 | (* ------------------------------------------------------------------------- *) | |
2468 | ||
2469 | exception Noparse; | |
2470 | ||
2471 | fun op ++ (parser1, parser2) input = | |
2472 | let | |
2473 | val (result1, rest1) = parser1 input | |
2474 | val (result2, rest2) = parser2 rest1 | |
2475 | in | |
2476 | ((result1, result2), rest2) | |
2477 | end; | |
2478 | ||
2479 | fun op >> (parser, treatment) input = | |
2480 | let | |
2481 | val (result, rest) = parser input | |
2482 | in | |
2483 | (treatment result, rest) | |
2484 | end; | |
2485 | ||
2486 | fun op >>++ (parser, treatment) input = | |
2487 | let | |
2488 | val (result, rest) = parser input | |
2489 | in | |
2490 | treatment result rest | |
2491 | end; | |
2492 | ||
2493 | fun op || (parser1, parser2) input = parser1 input | |
2494 | handle Noparse => parser2 input; | |
2495 | ||
2496 | fun many parser input = | |
2497 | let | |
2498 | val (result, next) = parser input | |
2499 | val (results, rest) = many parser next | |
2500 | in | |
2501 | ((result :: results), rest) | |
2502 | end | |
2503 | handle Noparse => ([], input); | |
2504 | ||
2505 | fun atleastone p = (p ++ many p) >> op::; | |
2506 | ||
2507 | fun nothing input = ((), input); | |
2508 | ||
2509 | fun optional p = (p >> SOME) || (nothing >> K NONE); | |
2510 | ||
2511 | (* ------------------------------------------------------------------------- *) | |
2512 | (* Stream-based. *) | |
2513 | (* ------------------------------------------------------------------------- *) | |
2514 | ||
2515 | type ('a, 'b) parser = 'a stream -> 'b * 'a stream | |
2516 | ||
2517 | fun maybe p S.NIL = raise Noparse | |
2518 | | maybe p (S.CONS (h, t)) = | |
2519 | case p h of SOME r => (r, t ()) | NONE => raise Noparse; | |
2520 | ||
2521 | fun finished S.NIL = ((), S.NIL) | |
2522 | | finished (S.CONS _) = raise Noparse; | |
2523 | ||
2524 | val finished: ('a, unit) parser = finished | |
2525 | ||
2526 | fun some p = maybe (fn x => if p x then SOME x else NONE); | |
2527 | ||
2528 | fun any input = some (K true) input; | |
2529 | ||
2530 | fun exact tok = some (fn item => item = tok); | |
2531 | ||
2532 | (* ------------------------------------------------------------------------- *) | |
2533 | (* Parsing and pretty-printing for infix operators. *) | |
2534 | (* ------------------------------------------------------------------------- *) | |
2535 | ||
2536 | type infixities = {tok : string, prec : int, left_assoc : bool} list; | |
2537 | type 'a con = string * 'a * 'a -> 'a; | |
2538 | type 'a des = 'a -> (string * 'a * 'a) option; | |
2539 | type 'a iparser = (string, 'a) parser; | |
2540 | type 'a iprinter = ('a * bool) pp; | |
2541 | ||
2542 | local | |
2543 | val sort_ops : infixities -> infixities = | |
2544 | let | |
2545 | fun order {prec, tok = _, left_assoc = _} | |
2546 | {prec = prec', tok = _, left_assoc = _} = | |
2547 | prec < prec' | |
2548 | in sort order | |
2549 | end; | |
2550 | fun unflatten ({tok, prec, left_assoc}, ([], _)) = | |
2551 | ([(left_assoc, [tok])], prec) | |
2552 | | unflatten ({tok, prec, left_assoc}, ((a, l) :: dealt, p)) = | |
2553 | if p = prec then | |
2554 | (assert (left_assoc = a) (BUG "infix parser/printer" "mixed assocs"); | |
2555 | ((a, tok :: l) :: dealt, p)) | |
2556 | else | |
2557 | ((left_assoc, [tok]) :: (a, l) :: dealt, prec); | |
2558 | in | |
2559 | val layerops = fst o foldl unflatten ([], 0) o sort_ops; | |
2560 | end; | |
2561 | ||
2562 | local | |
2563 | fun chop (#" " :: chs) = (curry op+ 1 ## I) (chop chs) | chop chs = (0, chs); | |
2564 | fun nspaces n = N n (curry op^ " ") ""; | |
2565 | fun spacify tok = | |
2566 | let | |
2567 | val chs = explode tok | |
2568 | val (r, chs) = chop (rev chs) | |
2569 | val (l, chs) = chop (rev chs) | |
2570 | in | |
2571 | ((l, r), implode chs) | |
2572 | end; | |
2573 | fun lrspaces (l, r) = | |
2574 | (if l = 0 then K () else C PP.add_string (nspaces l), | |
2575 | if r = 0 then K () else C PP.add_break (r, 0)); | |
2576 | in | |
2577 | val op_spaces = (lrspaces ## I) o spacify; | |
2578 | val op_clean = snd o spacify; | |
2579 | end; | |
2580 | ||
2581 | val optoks : infixities -> string list = map (fn {tok, ...} => op_clean tok); | |
2582 | ||
2583 | fun parse_gen_infix update sof toks parse inp = | |
2584 | let | |
2585 | val (e, rest) = parse inp | |
2586 | val continue = | |
2587 | case rest of S.NIL => NONE | |
2588 | | S.CONS (h, t) => if mem h toks then SOME (h, t) else NONE | |
2589 | in | |
2590 | case continue of NONE => (sof e, rest) | |
2591 | | SOME (h, t) => parse_gen_infix update (update sof h e) toks parse (t ()) | |
2592 | end; | |
2593 | ||
2594 | fun parse_left_infix toks con = | |
2595 | parse_gen_infix (fn f => fn t => fn a => fn b => con (t, f a, b)) I toks; | |
2596 | ||
2597 | fun parse_right_infix toks con = | |
2598 | parse_gen_infix (fn f => fn t => fn a => fn b => f (con (t, a, b))) I toks; | |
2599 | ||
2600 | fun parse_infixes ops = | |
2601 | let | |
2602 | val layeredops = map (I ## map op_clean) (layerops ops) | |
2603 | fun iparser (a, t) = (if a then parse_left_infix else parse_right_infix) t | |
2604 | val iparsers = map iparser layeredops | |
2605 | in | |
2606 | fn con => fn subparser => foldl (fn (p, sp) => p con sp) subparser iparsers | |
2607 | end; | |
2608 | ||
2609 | fun pp_gen_infix left toks : 'a des -> 'a iprinter -> 'a iprinter = | |
2610 | let | |
2611 | val spc = map op_spaces toks | |
2612 | in | |
2613 | fn dest => fn pp_sub => | |
2614 | let | |
2615 | fun dest' tm = | |
2616 | case dest tm of NONE => NONE | |
2617 | | SOME (t, a, b) => omap (pair (a, b)) (List.find (equal t o snd) spc) | |
2618 | open PP | |
2619 | fun pp_go pp (tmr as (tm, r)) = | |
2620 | case dest' tm of NONE => pp_sub pp tmr | |
2621 | | SOME ((a, b), ((lspc, rspc), tok)) | |
2622 | => ((if left then pp_go else pp_sub) pp (a, true); | |
2623 | lspc pp; add_string pp tok; rspc pp; | |
2624 | (if left then pp_sub else pp_go) pp (b, r)) | |
2625 | in | |
2626 | fn pp => fn tmr as (tm, _) => | |
2627 | case dest' tm of NONE => pp_sub pp tmr | |
2628 | | SOME _ => (begin_block pp INCONSISTENT 0; pp_go pp tmr; end_block pp) | |
2629 | end | |
2630 | end; | |
2631 | ||
2632 | fun pp_left_infix toks = pp_gen_infix true toks; | |
2633 | ||
2634 | fun pp_right_infix toks = pp_gen_infix false toks; | |
2635 | ||
2636 | fun pp_infixes ops = | |
2637 | let | |
2638 | val layeredops = layerops ops | |
2639 | val toks = List.concat (map (map op_clean o snd) layeredops) | |
2640 | fun iprinter (a, t) = (if a then pp_left_infix else pp_right_infix) t | |
2641 | val iprinters = map iprinter layeredops | |
2642 | in | |
2643 | fn dest => fn pp_sub => | |
2644 | let | |
2645 | fun printer sub = foldl (fn (ip, p) => ip dest p) sub iprinters | |
2646 | fun is_op t = case dest t of SOME (x, _, _) => mem x toks | _ => false | |
2647 | open PP | |
2648 | fun subpr pp (tmr as (tm, _)) = | |
2649 | if is_op tm then | |
2650 | (begin_block pp INCONSISTENT 1; add_string pp "("; | |
2651 | printer subpr pp (tm, false); add_string pp ")"; end_block pp) | |
2652 | else pp_sub pp tmr | |
2653 | in | |
2654 | fn pp => fn tmr => | |
2655 | (begin_block pp INCONSISTENT 0; printer subpr pp tmr; end_block pp) | |
2656 | end | |
2657 | end; | |
2658 | ||
2659 | (* ------------------------------------------------------------------------- *) | |
2660 | (* Lexing. *) | |
2661 | (* ------------------------------------------------------------------------- *) | |
2662 | ||
2663 | val space = Char.isSpace; | |
2664 | val digit = Char.isDigit; | |
2665 | val lower = Char.isLower; | |
2666 | val upper = Char.isUpper; | |
2667 | val alpha = Char.isAlpha; | |
2668 | val alphanum = fn c => alpha c orelse digit c orelse c = #"'" orelse c = #"_"; | |
2669 | val symbol = Char.contains "<>=-*+/\\?@|!$%&~#^:"; | |
2670 | val punct = Char.contains "()[]{}.,;"; | |
2671 | ||
2672 | (* ------------------------------------------------------------------------- *) | |
2673 | (* Quotations. *) | |
2674 | (* ------------------------------------------------------------------------- *) | |
2675 | ||
2676 | type 'a quotation = 'a frag list; | |
2677 | ||
2678 | fun quotation_parser parser pp_a = | |
2679 | let val f = PP.pp_to_string (!LINE_LENGTH) pp_a | |
2680 | in parser o foldl (fn (QUOTE q, s) => s ^ q | (ANTIQUOTE a, s) => s ^ f a) "" | |
2681 | end; | |
2682 | ||
2683 | end | |
2684 | (*#line 0.0 "fol/Term1.sig"*) | |
2685 | (* ========================================================================= *) | |
2686 | (* BASIC FIRST-ORDER LOGIC MANIPULATIONS *) | |
2687 | (* Created by Joe Hurd, September 2001 *) | |
2688 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
2689 | (* ========================================================================= *) | |
2690 | ||
2691 | signature Term1 = | |
2692 | sig | |
2693 | ||
2694 | type 'a pp = 'a Useful.pp | |
2695 | type ('a, 'b) maplet = ('a, 'b) Useful.maplet | |
2696 | type 'a quotation = 'a Parser.quotation | |
2697 | type infixities = Parser.infixities | |
2698 | ||
2699 | (* Datatypes for terms and formulas *) | |
2700 | datatype term = | |
2701 | Var of string | |
2702 | | Fn of string * term list | |
2703 | ||
2704 | datatype formula = | |
2705 | True | |
2706 | | False | |
2707 | | Atom of term | |
2708 | | Not of formula | |
2709 | | And of formula * formula | |
2710 | | Or of formula * formula | |
2711 | | Imp of formula * formula | |
2712 | | Iff of formula * formula | |
2713 | | Forall of string * formula | |
2714 | | Exists of string * formula | |
2715 | ||
2716 | (* Contructors and destructors *) | |
2717 | val dest_var : term -> string | |
2718 | val is_var : term -> bool | |
2719 | ||
2720 | val dest_fn : term -> string * term list | |
2721 | val is_fn : term -> bool | |
2722 | val fn_name : term -> string | |
2723 | val fn_args : term -> term list | |
2724 | val fn_arity : term -> int | |
2725 | val fn_function : term -> string * int | |
2726 | ||
2727 | val mk_const : string -> term | |
2728 | val dest_const : term -> string | |
2729 | val is_const : term -> bool | |
2730 | ||
2731 | val mk_binop : string -> term * term -> term | |
2732 | val dest_binop : string -> term -> term * term | |
2733 | val is_binop : string -> term -> bool | |
2734 | ||
2735 | val dest_atom : formula -> term | |
2736 | val is_atom : formula -> bool | |
2737 | ||
2738 | val list_mk_conj : formula list -> formula | |
2739 | val strip_conj : formula -> formula list | |
2740 | val flatten_conj : formula -> formula list | |
2741 | ||
2742 | val list_mk_disj : formula list -> formula | |
2743 | val strip_disj : formula -> formula list | |
2744 | val flatten_disj : formula -> formula list | |
2745 | ||
2746 | val list_mk_forall : string list * formula -> formula | |
2747 | val strip_forall : formula -> string list * formula | |
2748 | ||
2749 | val list_mk_exists : string list * formula -> formula | |
2750 | val strip_exists : formula -> string list * formula | |
2751 | ||
2752 | (* New variables *) | |
2753 | val new_var : unit -> term | |
2754 | val new_vars : int -> term list | |
2755 | ||
2756 | (* Sizes of terms and formulas *) | |
2757 | val term_size : term -> int | |
2758 | val formula_size : formula -> int | |
2759 | ||
2760 | (* Total comparison functions for terms and formulas *) | |
2761 | val term_compare : term * term -> order | |
2762 | val formula_compare : formula * formula -> order | |
2763 | ||
2764 | (* Operations on literals *) | |
2765 | val mk_literal : bool * formula -> formula | |
2766 | val dest_literal : formula -> bool * formula | |
2767 | val is_literal : formula -> bool | |
2768 | val literal_atom : formula -> formula | |
2769 | ||
2770 | (* Operations on formula negations *) | |
2771 | val negative : formula -> bool | |
2772 | val positive : formula -> bool | |
2773 | val negate : formula -> formula | |
2774 | ||
2775 | (* Functions and relations in a formula *) | |
2776 | val functions : formula -> (string * int) list | |
2777 | val function_names : formula -> string list | |
2778 | val relations : formula -> (string * int) list | |
2779 | val relation_names : formula -> string list | |
2780 | ||
2781 | (* The equality relation has a special status *) | |
2782 | val eq_rel : string * int | |
2783 | val mk_eq : term * term -> formula | |
2784 | val dest_eq : formula -> term * term | |
2785 | val is_eq : formula -> bool | |
2786 | val lhs : formula -> term | |
2787 | val rhs : formula -> term | |
2788 | val eq_occurs : formula -> bool | |
2789 | val relations_no_eq : formula -> (string * int) list | |
2790 | ||
2791 | (* Free variables *) | |
2792 | val FVT : term -> string list | |
2793 | val FV : formula -> string list | |
2794 | val FVL : formula list -> string list | |
2795 | val specialize : formula -> formula | |
2796 | val generalize : formula -> formula | |
2797 | ||
2798 | (* Subterms *) | |
2799 | val subterm : int list -> term -> term | |
2800 | val rewrite : (int list, term) maplet -> term -> term | |
2801 | val literal_subterm : int list -> formula -> term | |
2802 | val literal_rewrite : (int list, term) maplet -> formula -> formula | |
2803 | ||
2804 | (* The Knuth-Bendix ordering *) | |
2805 | type Weight = string * int -> int | |
2806 | type Prec = (string * int) * (string * int) -> order | |
2807 | val kb_weight : Weight -> term -> int * string Multiset.mset | |
2808 | val kb_compare : Weight -> Prec -> term * term -> order option | |
2809 | ||
2810 | (* A datatype to antiquote both terms and formulas *) | |
2811 | datatype thing = Term of term | Formula of formula; | |
2812 | ||
2813 | (* Operators parsed and printed infix *) | |
2814 | val infixes : infixities ref | |
2815 | ||
2816 | (* Deciding whether a string denotes a variable or constant *) | |
2817 | val var_string : (string -> bool) ref | |
2818 | ||
2819 | (* Parsing *) | |
2820 | val string_to_term' : infixities -> string -> term (* purely functional *) | |
2821 | val string_to_formula' : infixities -> string -> formula | |
2822 | val parse_term' : infixities -> thing quotation -> term | |
2823 | val parse_formula' : infixities -> thing quotation -> formula | |
2824 | val string_to_term : string -> term (* using !infixes *) | |
2825 | val string_to_formula : string -> formula | |
2826 | val parse_term : thing quotation -> term | |
2827 | val parse_formula : thing quotation -> formula | |
2828 | ||
2829 | (* Pretty-printing *) | |
2830 | val pp_term' : infixities -> term pp (* purely functional *) | |
2831 | val pp_formula' : infixities -> formula pp | |
2832 | val term_to_string' : infixities -> int -> term -> string | |
2833 | val formula_to_string' : infixities -> int -> formula -> string | |
2834 | val pp_term : term pp (* using !infixes *) | |
2835 | val pp_formula : formula pp (* and !LINE_LENGTH *) | |
2836 | val term_to_string : term -> string | |
2837 | val formula_to_string : formula -> string | |
2838 | ||
2839 | end | |
2840 | (*#line 0.0 "fol/Term1.sml"*) | |
2841 | (* ========================================================================= *) | |
2842 | (* BASIC FIRST-ORDER LOGIC MANIPULATIONS *) | |
2843 | (* Created by Joe Hurd, September 2001 *) | |
2844 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
2845 | (* ========================================================================= *) | |
2846 | ||
2847 | (* | |
2848 | app load ["Useful", "Stream", "Parser", "Mosml", "Binarymap"]; | |
2849 | *) | |
2850 | ||
2851 | (* | |
2852 | *) | |
2853 | structure Term1 :> Term1 = | |
2854 | struct | |
2855 | ||
2856 | open Parser Useful; | |
2857 | ||
2858 | infixr 8 ++; | |
2859 | infixr 7 >>; | |
2860 | infixr 6 ||; | |
2861 | infixr |-> ::> @> oo ##; | |
2862 | ||
2863 | (* ------------------------------------------------------------------------- *) | |
2864 | (* Datatypes for storing first-order terms and formulas. *) | |
2865 | (* ------------------------------------------------------------------------- *) | |
2866 | ||
2867 | datatype term = | |
2868 | Var of string | |
2869 | | Fn of string * term list; | |
2870 | ||
2871 | datatype formula = | |
2872 | True | |
2873 | | False | |
2874 | | Atom of term | |
2875 | | Not of formula | |
2876 | | And of formula * formula | |
2877 | | Or of formula * formula | |
2878 | | Imp of formula * formula | |
2879 | | Iff of formula * formula | |
2880 | | Forall of string * formula | |
2881 | | Exists of string * formula; | |
2882 | ||
2883 | (* ------------------------------------------------------------------------- *) | |
2884 | (* Constructors and destructors. *) | |
2885 | (* ------------------------------------------------------------------------- *) | |
2886 | ||
2887 | (* Variables *) | |
2888 | ||
2889 | fun dest_var (Var v) = v | |
2890 | | dest_var (Fn _) = raise ERR "dest_var" ""; | |
2891 | ||
2892 | val is_var = can dest_var; | |
2893 | ||
2894 | (* Functions *) | |
2895 | ||
2896 | fun dest_fn (Fn f) = f | |
2897 | | dest_fn (Var _) = raise ERR "dest_fn" ""; | |
2898 | ||
2899 | val is_fn = can dest_fn; | |
2900 | ||
2901 | val fn_name = fst o dest_fn; | |
2902 | ||
2903 | val fn_args = snd o dest_fn; | |
2904 | ||
2905 | val fn_arity = length o fn_args; | |
2906 | ||
2907 | fun fn_function tm = (fn_name tm, fn_arity tm); | |
2908 | ||
2909 | (* Constants *) | |
2910 | ||
2911 | fun mk_const c = (Fn (c, [])); | |
2912 | ||
2913 | fun dest_const (Fn (c, [])) = c | |
2914 | | dest_const _ = raise ERR "dest_const" ""; | |
2915 | ||
2916 | val is_const = can dest_const; | |
2917 | ||
2918 | (* Binary functions *) | |
2919 | ||
2920 | fun mk_binop f (a, b) = Fn (f, [a, b]); | |
2921 | ||
2922 | fun dest_binop f (Fn (x, [a, b])) = | |
2923 | if x = f then (a, b) else raise ERR "dest_binop" "wrong binop" | |
2924 | | dest_binop _ _ = raise ERR "dest_binop" "not a binop"; | |
2925 | ||
2926 | fun is_binop f = can (dest_binop f); | |
2927 | ||
2928 | (* Atoms *) | |
2929 | ||
2930 | fun dest_atom (Atom a) = a | |
2931 | | dest_atom _ = raise ERR "dest_atom" ""; | |
2932 | ||
2933 | val is_atom = can dest_atom; | |
2934 | ||
2935 | (* Conjunctions *) | |
2936 | ||
2937 | fun list_mk_conj l = (case rev l of [] => True | h :: t => foldl And h t); | |
2938 | ||
2939 | local | |
2940 | fun conj cs (And (a, b)) = conj (a :: cs) b | |
2941 | | conj cs fm = rev (fm :: cs); | |
2942 | in | |
2943 | fun strip_conj True = [] | |
2944 | | strip_conj fm = conj [] fm; | |
2945 | end; | |
2946 | ||
2947 | val flatten_conj = | |
2948 | let | |
2949 | fun flat acc [] = acc | |
2950 | | flat acc (And (p, q) :: fms) = flat acc (q :: p :: fms) | |
2951 | | flat acc (True :: fms) = flat acc fms | |
2952 | | flat acc (fm :: fms) = flat (fm :: acc) fms | |
2953 | in | |
2954 | fn fm => flat [] [fm] | |
2955 | end; | |
2956 | ||
2957 | (* Disjunctions *) | |
2958 | ||
2959 | fun list_mk_disj l = (case rev l of [] => False | h :: t => foldl Or h t); | |
2960 | ||
2961 | local | |
2962 | fun disj cs (Or (a, b)) = disj (a :: cs) b | |
2963 | | disj cs fm = rev (fm :: cs); | |
2964 | in | |
2965 | fun strip_disj False = [] | |
2966 | | strip_disj fm = disj [] fm; | |
2967 | end; | |
2968 | ||
2969 | val flatten_disj = | |
2970 | let | |
2971 | fun flat acc [] = acc | |
2972 | | flat acc (Or (p, q) :: fms) = flat acc (q :: p :: fms) | |
2973 | | flat acc (False :: fms) = flat acc fms | |
2974 | | flat acc (fm :: fms) = flat (fm :: acc) fms | |
2975 | in | |
2976 | fn fm => flat [] [fm] | |
2977 | end; | |
2978 | ||
2979 | (* Universal quantifiers *) | |
2980 | ||
2981 | fun list_mk_forall ([], body) = body | |
2982 | | list_mk_forall (v :: vs, body) = Forall (v, list_mk_forall (vs, body)); | |
2983 | ||
2984 | local | |
2985 | fun dest vs (Forall (v, b)) = dest (v :: vs) b | |
2986 | | dest vs tm = (rev vs, tm); | |
2987 | in | |
2988 | val strip_forall = dest []; | |
2989 | end; | |
2990 | ||
2991 | (* Existential quantifiers *) | |
2992 | ||
2993 | fun list_mk_exists ([], body) = body | |
2994 | | list_mk_exists (v :: vs, body) = Exists (v, list_mk_exists (vs, body)); | |
2995 | ||
2996 | local | |
2997 | fun dest vs (Exists (v, b)) = dest (v :: vs) b | |
2998 | | dest vs tm = (rev vs, tm); | |
2999 | in | |
3000 | val strip_exists = dest []; | |
3001 | end; | |
3002 | ||
3003 | (* ------------------------------------------------------------------------- *) | |
3004 | (* A datatype to antiquote both terms and formulas. *) | |
3005 | (* ------------------------------------------------------------------------- *) | |
3006 | ||
3007 | datatype thing = Term of term | Formula of formula; | |
3008 | ||
3009 | (* ------------------------------------------------------------------------- *) | |
3010 | (* Built-in infix operators and reserved symbols. *) | |
3011 | (* ------------------------------------------------------------------------- *) | |
3012 | ||
3013 | val infixes : infixities ref = ref | |
3014 | [(* ML style *) | |
3015 | {tok = " / ", prec = 7, left_assoc = true}, | |
3016 | {tok = " div ", prec = 7, left_assoc = true}, | |
3017 | {tok = " mod ", prec = 7, left_assoc = true}, | |
3018 | {tok = " * ", prec = 7, left_assoc = true}, | |
3019 | {tok = " + ", prec = 6, left_assoc = true}, | |
3020 | {tok = " - ", prec = 6, left_assoc = true}, | |
3021 | {tok = " ^ ", prec = 6, left_assoc = true}, | |
3022 | {tok = " @ ", prec = 5, left_assoc = false}, | |
3023 | {tok = " :: ", prec = 5, left_assoc = false}, | |
3024 | {tok = " = ", prec = 4, left_assoc = true}, (* may be interpreted *) | |
3025 | {tok = " == ", prec = 4, left_assoc = true}, (* won't be interpreted *) | |
3026 | {tok = " <> ", prec = 4, left_assoc = true}, | |
3027 | {tok = " <= ", prec = 4, left_assoc = true}, | |
3028 | {tok = " < ", prec = 4, left_assoc = true}, | |
3029 | {tok = " >= ", prec = 4, left_assoc = true}, | |
3030 | {tok = " > ", prec = 4, left_assoc = true}, | |
3031 | {tok = " o ", prec = 8, left_assoc = true}, (* ML prec = 3 *) | |
3032 | (* HOL style *) | |
3033 | {tok = " % ", prec = 9, left_assoc = true}, (* function application *) | |
3034 | {tok = " -> ", prec = 2, left_assoc = false}, (* HOL ty prec = 50 *) | |
3035 | {tok = " : ", prec = 1, left_assoc = false}, (* not in HOL grammars *) | |
3036 | {tok = ", ", prec = 0, left_assoc = false}, (* HOL tm prec = 50 *) | |
3037 | (* Convenient alternative symbols *) | |
3038 | {tok = " ** ", prec = 7, left_assoc = true}, | |
3039 | {tok = " ++ ", prec = 6, left_assoc = true}, | |
3040 | {tok = " -- ", prec = 6, left_assoc = true}]; | |
3041 | ||
3042 | val connectives = | |
3043 | [{tok = " /\\ ", prec = ~1, left_assoc = false}, | |
3044 | {tok = " \\/ ", prec = ~2, left_assoc = false}, | |
3045 | {tok = " ==> ", prec = ~3, left_assoc = false}, | |
3046 | {tok = " <=> ", prec = ~4, left_assoc = false}]; | |
3047 | ||
3048 | val reserved = ["!", "?", "(", ")", ".", "~"]; | |
3049 | ||
3050 | (* ------------------------------------------------------------------------- *) | |
3051 | (* Deciding whether a string denotes a variable or constant. *) | |
3052 | (* ------------------------------------------------------------------------- *) | |
3053 | ||
3054 | val var_string = | |
3055 | ref (C mem [#"_",#"v",#"w",#"x",#"y",#"z"] o Char.toLower o hd o explode); | |
3056 | ||
3057 | (* ------------------------------------------------------------------------- *) | |
3058 | (* Pretty-printing. *) | |
3059 | (* ------------------------------------------------------------------------- *) | |
3060 | ||
3061 | (* Purely functional pretty-printing *) | |
3062 | ||
3063 | val pp_vname = | |
3064 | pp_map (fn s => if !var_string s then s else "var->" ^ s ^ "<-var") pp_string; | |
3065 | ||
3066 | val pp_cname = | |
3067 | pp_map (fn s => if !var_string s then "const->" ^ s ^ "<-const" else s) | |
3068 | pp_string; | |
3069 | ||
3070 | val pp_fname = | |
3071 | pp_map (fn s => if !var_string s then "fn->" ^ s ^ "<-fn" else s) pp_string; | |
3072 | ||
3073 | fun pp_term' ops = | |
3074 | let | |
3075 | val ops = ops @ connectives | |
3076 | val iprinter = pp_infixes ops | |
3077 | val itoks = optoks ops | |
3078 | fun pp_uninfix pp_s pp s = | |
3079 | if mem s itoks then PP.add_string pp ("(" ^ s ^ ")") else pp_s pp s | |
3080 | fun idest (Fn (f, [a, b])) = SOME (f, a, b) | idest _ = NONE | |
3081 | fun is_op t = case idest t of SOME (f, _, _) => mem f itoks | NONE => false | |
3082 | fun is_q (Fn ("!", _)) = true | is_q (Fn ("?", _)) = true | is_q _ = false | |
3083 | fun negs (Fn ("~", [a])) = (curry op+ 1 ## I) (negs a) | negs tm = (0, tm) | |
3084 | fun binds s (tm as Fn (n, [Var v, b])) = | |
3085 | if s = n then (cons v ## I) (binds s b) else ([], tm) | |
3086 | | binds _ tm = ([], tm) | |
3087 | open PP | |
3088 | fun basic pp (Var v) = pp_vname pp v | |
3089 | | basic pp (Fn (c, [])) = pp_uninfix pp_cname pp c | |
3090 | | basic pp (Fn (f, a)) = | |
3091 | (pp_uninfix pp_fname pp f; | |
3092 | app (fn x => (add_break pp (1, 0); argument pp x)) a) | |
3093 | and argument pp tm = | |
3094 | if is_var tm orelse is_const tm then basic pp tm else pp_btm pp tm | |
3095 | and quant pp (tm, r) = | |
3096 | let | |
3097 | fun pr pp (Fn (q, [Var v, tm])) = | |
3098 | let | |
3099 | val (vs, body) = binds q tm | |
3100 | in | |
3101 | add_string pp q; | |
3102 | pp_vname pp v; | |
3103 | app (fn a => (add_break pp (1, 0); pp_vname pp a)) vs; | |
3104 | add_string pp "."; | |
3105 | add_break pp (1, 0); | |
3106 | if is_q body then pr pp body else pp_tm pp (body, false) | |
3107 | end | |
3108 | | pr pp tm = raise BUG "pp_term" "not a quantifier" | |
3109 | fun pp_q pp t = (begin_block pp INCONSISTENT 2; pr pp t; end_block pp) | |
3110 | in | |
3111 | (if is_q tm then (if r then pp_bracket ("(", ")") else I) pp_q | |
3112 | else basic) pp tm | |
3113 | end | |
3114 | and molecule pp (tm, r) = | |
3115 | let | |
3116 | val (n, x) = negs tm | |
3117 | in | |
3118 | begin_block pp INCONSISTENT n; | |
3119 | N n (fn () => add_string pp "~") (); | |
3120 | if is_op x then pp_btm pp x else quant pp (x, r); | |
3121 | end_block pp | |
3122 | end | |
3123 | and pp_btm pp tm = pp_bracket ("(", ")") pp_tm pp (tm, false) | |
3124 | and pp_tm pp tmr = iprinter idest molecule pp tmr | |
3125 | in | |
3126 | pp_map (C pair false) pp_tm | |
3127 | end; | |
3128 | ||
3129 | local | |
3130 | fun demote True = Fn ("T", [] ) | |
3131 | | demote False = Fn ("F", [] ) | |
3132 | | demote (Not a) = Fn ("~", [demote a] ) | |
3133 | | demote (And (a, b)) = Fn ("/\\", [demote a, demote b]) | |
3134 | | demote (Or (a, b)) = Fn ("\\/", [demote a, demote b]) | |
3135 | | demote (Imp (a, b)) = Fn ("==>", [demote a, demote b]) | |
3136 | | demote (Iff (a, b)) = Fn ("<=>", [demote a, demote b]) | |
3137 | | demote (Forall (v, b)) = Fn ("!", [Var v, demote b]) | |
3138 | | demote (Exists (v, b)) = Fn ("?", [Var v, demote b]) | |
3139 | | demote (Atom t) = t; | |
3140 | in | |
3141 | fun pp_formula' ops = pp_map demote (pp_term' ops); | |
3142 | end; | |
3143 | ||
3144 | fun term_to_string' ops len tm = PP.pp_to_string len (pp_term' ops) tm; | |
3145 | fun formula_to_string' ops len fm = PP.pp_to_string len (pp_formula' ops) fm; | |
3146 | ||
3147 | (* Pretty-printing things is needed for parsing thing quotations *) | |
3148 | ||
3149 | fun pp_thing ops pp (Term tm) = pp_term' ops pp tm | |
3150 | | pp_thing ops pp (Formula fm) = pp_formula' ops pp fm; | |
3151 | ||
3152 | fun pp_bracketed_thing ops pp th = | |
3153 | (PP.begin_block pp PP.INCONSISTENT 1; PP.add_string pp "("; | |
3154 | pp_thing ops pp th; PP.add_string pp ")"; PP.end_block pp); | |
3155 | ||
3156 | (* Pretty-printing using !infixes and !LINE_LENGTH *) | |
3157 | ||
3158 | fun pp_term pp tm = pp_term' (!infixes) pp tm; | |
3159 | fun pp_formula pp fm = pp_formula' (!infixes) pp fm; | |
3160 | fun term_to_string tm = term_to_string' (!infixes) (!LINE_LENGTH) tm; | |
3161 | fun formula_to_string fm = formula_to_string' (!infixes) (!LINE_LENGTH) fm; | |
3162 | ||
3163 | (* ------------------------------------------------------------------------- *) | |
3164 | (* Parsing. *) | |
3165 | (* ------------------------------------------------------------------------- *) | |
3166 | ||
3167 | (* Lexing *) | |
3168 | ||
3169 | val lexer = | |
3170 | (fn ((_, (toks, _)), _) => toks) o | |
3171 | (many (some space) ++ | |
3172 | (many | |
3173 | ((((atleastone (some alphanum) || | |
3174 | (some (fn c => symbol c andalso c <> #"~") ++ many (some symbol)) >> | |
3175 | op ::) >> implode | |
3176 | || some (fn c => c = #"~" orelse punct c) >> str) ++ | |
3177 | many (some space)) >> fst)) ++ | |
3178 | finished); | |
3179 | ||
3180 | val lex_str = lexer o Stream.from_list o explode; | |
3181 | ||
3182 | (* Purely functional parsing *) | |
3183 | ||
3184 | val vname_parser = | |
3185 | some (fn tok => not (mem tok reserved) andalso !var_string tok); | |
3186 | ||
3187 | fun term_parser ops = | |
3188 | let | |
3189 | val ops = ops @ connectives | |
3190 | val iparser = parse_infixes ops | |
3191 | val itoks = optoks ops | |
3192 | val avoid = itoks @ reserved | |
3193 | fun fname tok = not (mem tok avoid) andalso not (!var_string tok) | |
3194 | fun uninfix tok = mem tok itoks | |
3195 | val uninfix_parser = (exact "(" ++ some uninfix ++ exact ")") >> (fst o snd) | |
3196 | val fname_parser = some fname || uninfix_parser | |
3197 | fun bind s (v, t) = Fn (s, [Var v, t]) | |
3198 | fun basic inp = | |
3199 | ((exact "(" ++ tm_parser ++ exact ")") >> (fn (_, (t, _)) => t) || | |
3200 | (exact "!" ++ atleastone vname_parser ++ exact "." ++ tm_parser) >> | |
3201 | (fn (_, (vs, (_, body))) => foldr (bind "!") body vs) || | |
3202 | (exact "?" ++ atleastone vname_parser ++ exact "." ++ tm_parser) >> | |
3203 | (fn (_, (vs, (_, body))) => foldr (bind "?") body vs) || | |
3204 | fname_parser >> (fn f => Fn (f, [])) || | |
3205 | vname_parser >> Var) inp | |
3206 | and molecule inp = | |
3207 | ((many (exact "~") ++ ((fname_parser ++ many basic) >> Fn || basic)) >> | |
3208 | (fn (l, t) => N (length l) (fn x => Fn ("~", [x])) t)) inp | |
3209 | and tm_parser inp = iparser (fn (f, a, b) => Fn (f, [a, b])) molecule inp | |
3210 | in | |
3211 | tm_parser | |
3212 | end; | |
3213 | ||
3214 | local | |
3215 | fun promote (Fn ("T", [] )) = True | |
3216 | | promote (Fn ("F", [] )) = False | |
3217 | | promote (Fn ("~", [a] )) = Not (promote a) | |
3218 | | promote (Fn ("/\\", [a, b] )) = And (promote a, promote b) | |
3219 | | promote (Fn ("\\/", [a, b] )) = Or (promote a, promote b) | |
3220 | | promote (Fn ("==>", [a, b] )) = Imp (promote a, promote b) | |
3221 | | promote (Fn ("<=>", [a, b] )) = Iff (promote a, promote b) | |
3222 | | promote (Fn ("!", [Var v, b])) = Forall (v, promote b) | |
3223 | | promote (Fn ("?", [Var v, b])) = Exists (v, promote b) | |
3224 | | promote tm = Atom tm; | |
3225 | in | |
3226 | fun formula_parser ops = term_parser ops >> promote; | |
3227 | end; | |
3228 | ||
3229 | fun string_to_term' ops = | |
3230 | fst o ((term_parser ops ++ finished) >> fst) o Stream.from_list o lex_str; | |
3231 | ||
3232 | fun string_to_formula' ops = | |
3233 | fst o ((formula_parser ops ++ finished) >> fst) o Stream.from_list o lex_str; | |
3234 | ||
3235 | fun parse_term' ops = | |
3236 | quotation_parser (string_to_term' ops) (pp_bracketed_thing ops); | |
3237 | ||
3238 | fun parse_formula' ops = | |
3239 | quotation_parser (string_to_formula' ops) (pp_bracketed_thing ops); | |
3240 | ||
3241 | (* Parsing using !infixes *) | |
3242 | ||
3243 | fun string_to_term s = string_to_term' (!infixes) s; | |
3244 | fun string_to_formula s = string_to_formula' (!infixes) s; | |
3245 | fun parse_term q = parse_term' (!infixes) q; | |
3246 | fun parse_formula q = parse_formula' (!infixes) q; | |
3247 | ||
3248 | (* ------------------------------------------------------------------------- *) | |
3249 | (* New variables. *) | |
3250 | (* ------------------------------------------------------------------------- *) | |
3251 | ||
3252 | local | |
3253 | val prefix = "_"; | |
3254 | val num_var = Var o mk_prefix prefix o int_to_string; | |
3255 | in | |
3256 | val new_var = num_var o new_int; | |
3257 | val new_vars = map num_var o new_ints; | |
3258 | end; | |
3259 | ||
3260 | (* ------------------------------------------------------------------------- *) | |
3261 | (* Sizes of terms and formulas. *) | |
3262 | (* ------------------------------------------------------------------------- *) | |
3263 | ||
3264 | local | |
3265 | fun szt n [] = n | |
3266 | | szt n (Var _ :: tms) = szt (n + 1) tms | |
3267 | | szt n (Fn (_, args) :: tms) = szt (n + 1) (args @ tms); | |
3268 | ||
3269 | fun sz n [] = n | |
3270 | | sz n (True :: fms) = sz (n + 1) fms | |
3271 | | sz n (False :: fms) = sz (n + 1) fms | |
3272 | | sz n (Atom t :: fms) = sz (szt (n + 1) [t]) fms | |
3273 | | sz n (Not p :: fms) = sz (n + 1) (p :: fms) | |
3274 | | sz n (And (p, q) :: fms) = sz (n + 1) (p :: q :: fms) | |
3275 | | sz n (Or (p, q) :: fms) = sz (n + 1) (p :: q :: fms) | |
3276 | | sz n (Imp (p, q) :: fms) = sz (n + 1) (p :: q :: fms) | |
3277 | | sz n (Iff (p, q) :: fms) = sz (n + 1) (p :: q :: fms) | |
3278 | | sz n (Forall (_, p) :: fms) = sz (n + 1) (p :: fms) | |
3279 | | sz n (Exists (_, p) :: fms) = sz (n + 1) (p :: fms); | |
3280 | in | |
3281 | val term_size = szt 0 o wrap; | |
3282 | val formula_size = sz 0 o wrap; | |
3283 | end; | |
3284 | ||
3285 | (* ------------------------------------------------------------------------- *) | |
3286 | (* Total comparison functions for terms and formulas. *) | |
3287 | (* ------------------------------------------------------------------------- *) | |
3288 | ||
3289 | local | |
3290 | fun lex EQUAL f x = f x | lex x _ _ = x; | |
3291 | ||
3292 | fun cmt [] = EQUAL | |
3293 | | cmt ((Var _, Fn _) :: _) = LESS | |
3294 | | cmt ((Fn _, Var _) :: _) = GREATER | |
3295 | | cmt ((Var v, Var w) :: l) = lex (String.compare (v, w)) cmt l | |
3296 | | cmt ((Fn (f, a), Fn (g, b)) :: l) = | |
3297 | (case lex (String.compare (f, g)) (Int.compare o Df length) (a, b) of EQUAL | |
3298 | => cmt (zip a b @ l) | |
3299 | | x => x); | |
3300 | ||
3301 | fun cm [] = EQUAL | |
3302 | | cm ((True, True ) :: l) = cm l | |
3303 | | cm ((True, _ ) :: _) = LESS | |
3304 | | cm ((_, True ) :: _) = GREATER | |
3305 | | cm ((False, False ) :: l) = cm l | |
3306 | | cm ((False, _ ) :: _) = LESS | |
3307 | | cm ((_, False ) :: _) = GREATER | |
3308 | | cm ((Atom t, Atom u ) :: l) = lex (cmt [(t, u)]) cm l | |
3309 | | cm ((Atom _, _ ) :: _) = LESS | |
3310 | | cm ((_, Atom _ ) :: _) = GREATER | |
3311 | | cm ((Not p, Not q ) :: l) = cm ((p, q) :: l) | |
3312 | | cm ((Not _ , _ ) :: _) = LESS | |
3313 | | cm ((_, Not _ ) :: _) = GREATER | |
3314 | | cm ((And (p1, q1), And (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) | |
3315 | | cm ((And _, _ ) :: _) = LESS | |
3316 | | cm ((_, And _ ) :: _) = GREATER | |
3317 | | cm ((Or (p1, q1), Or (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) | |
3318 | | cm ((Or _, _ ) :: _) = LESS | |
3319 | | cm ((_, Or _ ) :: _) = GREATER | |
3320 | | cm ((Imp (p1, q1), Imp (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) | |
3321 | | cm ((Imp _, _ ) :: _) = LESS | |
3322 | | cm ((_, Imp _ ) :: _) = GREATER | |
3323 | | cm ((Iff (p1, q1), Iff (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) | |
3324 | | cm ((Iff _, _ ) :: _) = LESS | |
3325 | | cm ((_, Iff _ ) :: _) = GREATER | |
3326 | | cm ((Forall (v, p), Forall (w, q)) :: l) = | |
3327 | lex (String.compare (v, w)) (cm o cons (p, q)) l | |
3328 | | cm ((Forall _, Exists _ ) :: _) = LESS | |
3329 | | cm ((Exists _, Forall _ ) :: _) = GREATER | |
3330 | | cm ((Exists (v, p), Exists (w, q)) :: l) = | |
3331 | lex (String.compare (v, w)) (cm o cons (p, q)) l; | |
3332 | in | |
3333 | val term_compare = cmt o wrap; | |
3334 | val formula_compare = cm o wrap; | |
3335 | end; | |
3336 | ||
3337 | (* ------------------------------------------------------------------------- *) | |
3338 | (* Basic operations on literals. *) | |
3339 | (* ------------------------------------------------------------------------- *) | |
3340 | ||
3341 | fun mk_literal (true, a) = a | |
3342 | | mk_literal (false, a) = Not a; | |
3343 | ||
3344 | fun dest_literal (a as Atom _) = (true, a) | |
3345 | | dest_literal (Not (a as Atom _)) = (false, a) | |
3346 | | dest_literal _ = raise ERR "dest_literal" ""; | |
3347 | ||
3348 | val is_literal = can dest_literal; | |
3349 | ||
3350 | val literal_atom = snd o dest_literal; | |
3351 | ||
3352 | (* ------------------------------------------------------------------------- *) | |
3353 | (* Dealing with formula negations. *) | |
3354 | (* ------------------------------------------------------------------------- *) | |
3355 | ||
3356 | fun negative (Not p) = true | |
3357 | | negative _ = false; | |
3358 | ||
3359 | val positive = non negative; | |
3360 | ||
3361 | fun negate (Not p) = p | |
3362 | | negate p = Not p; | |
3363 | ||
3364 | (* ------------------------------------------------------------------------- *) | |
3365 | (* Functions and relations in a formula. *) | |
3366 | (* ------------------------------------------------------------------------- *) | |
3367 | ||
3368 | local | |
3369 | fun fnc fs [] = fs | |
3370 | | fnc fs (Var _ :: tms) = fnc fs tms | |
3371 | | fnc fs (Fn (n, a) :: tms) = fnc (insert (n, length a) fs) (a @ tms); | |
3372 | ||
3373 | fun func fs [] = fs | |
3374 | | func fs (True :: fms) = func fs fms | |
3375 | | func fs (False :: fms) = func fs fms | |
3376 | | func fs (Atom (Var _) :: fms) = func fs fms | |
3377 | | func fs (Atom (Fn (_, tms)) :: fms) = func (fnc fs tms) fms | |
3378 | | func fs (Not p :: fms) = func fs (p :: fms) | |
3379 | | func fs (And (p, q) :: fms) = func fs (p :: q :: fms) | |
3380 | | func fs (Or (p, q) :: fms) = func fs (p :: q :: fms) | |
3381 | | func fs (Imp (p, q) :: fms) = func fs (p :: q :: fms) | |
3382 | | func fs (Iff (p, q) :: fms) = func fs (p :: q :: fms) | |
3383 | | func fs (Forall (_, p) :: fms) = func fs (p :: fms) | |
3384 | | func fs (Exists (_, p) :: fms) = func fs (p :: fms); | |
3385 | in | |
3386 | val functions = func [] o wrap; | |
3387 | end; | |
3388 | ||
3389 | val function_names = map fst o functions; | |
3390 | ||
3391 | local | |
3392 | fun rel rs [] = rs | |
3393 | | rel rs (True :: fms) = rel rs fms | |
3394 | | rel rs (False :: fms) = rel rs fms | |
3395 | | rel rs (Atom (Var _) :: fms) = rel rs fms | |
3396 | | rel rs (Atom (f as Fn _) :: fms) = rel (insert (fn_function f) rs) fms | |
3397 | | rel rs (Not p :: fms) = rel rs (p :: fms) | |
3398 | | rel rs (And (p, q) :: fms) = rel rs (p :: q :: fms) | |
3399 | | rel rs (Or (p, q) :: fms) = rel rs (p :: q :: fms) | |
3400 | | rel rs (Imp (p, q) :: fms) = rel rs (p :: q :: fms) | |
3401 | | rel rs (Iff (p, q) :: fms) = rel rs (p :: q :: fms) | |
3402 | | rel rs (Forall (_, p) :: fms) = rel rs (p :: fms) | |
3403 | | rel rs (Exists (_, p) :: fms) = rel rs (p :: fms); | |
3404 | in | |
3405 | val relations = rel [] o wrap; | |
3406 | end; | |
3407 | ||
3408 | val relation_names = map fst o relations; | |
3409 | ||
3410 | (* ------------------------------------------------------------------------- *) | |
3411 | (* The equality relation has a special status. *) | |
3412 | (* ------------------------------------------------------------------------- *) | |
3413 | ||
3414 | val eq_rel = ("=", 2); | |
3415 | ||
3416 | fun mk_eq (a, b) = Atom (Fn ("=", [a, b])); | |
3417 | ||
3418 | fun dest_eq (Atom (Fn ("=", [a, b]))) = (a, b) | |
3419 | | dest_eq _ = raise ERR "dest_eq" ""; | |
3420 | ||
3421 | val is_eq = can dest_eq; | |
3422 | ||
3423 | val lhs = fst o dest_eq; | |
3424 | ||
3425 | val rhs = snd o dest_eq; | |
3426 | ||
3427 | val eq_occurs = mem eq_rel o relations; | |
3428 | ||
3429 | val relations_no_eq = List.filter (non (equal eq_rel)) o relations; | |
3430 | ||
3431 | (* ------------------------------------------------------------------------- *) | |
3432 | (* Free variables in terms and formulas. *) | |
3433 | (* ------------------------------------------------------------------------- *) | |
3434 | ||
3435 | local | |
3436 | fun fvt av = | |
3437 | let | |
3438 | val seen = | |
3439 | if null av then mem else (fn v => fn vs => mem v av orelse mem v vs) | |
3440 | fun f vs [] = vs | |
3441 | | f vs (Var v :: tms) = f (if seen v vs then vs else v :: vs) tms | |
3442 | | f vs (Fn (_, args) :: tms) = f vs (args @ tms) | |
3443 | in | |
3444 | f | |
3445 | end; | |
3446 | ||
3447 | fun fv vs [] = vs | |
3448 | | fv vs ((_ , True ) :: fms) = fv vs fms | |
3449 | | fv vs ((_ , False ) :: fms) = fv vs fms | |
3450 | | fv vs ((av, Atom t ) :: fms) = fv (fvt av vs [t]) fms | |
3451 | | fv vs ((av, Not p ) :: fms) = fv vs ((av, p) :: fms) | |
3452 | | fv vs ((av, And (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) | |
3453 | | fv vs ((av, Or (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) | |
3454 | | fv vs ((av, Imp (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) | |
3455 | | fv vs ((av, Iff (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) | |
3456 | | fv vs ((av, Forall (x, p)) :: fms) = fv vs ((insert x av, p) :: fms) | |
3457 | | fv vs ((av, Exists (x, p)) :: fms) = fv vs ((insert x av, p) :: fms); | |
3458 | in | |
3459 | fun FVT tm = rev (fvt [] [] [tm]); | |
3460 | fun FV fm = rev (fv [] [([], fm)]); | |
3461 | fun FVL fms = rev (fv [] (map (pair []) fms)); | |
3462 | end; | |
3463 | ||
3464 | val specialize = snd o strip_forall; | |
3465 | ||
3466 | fun generalize fm = list_mk_forall (FV fm, fm); | |
3467 | ||
3468 | (* ------------------------------------------------------------------------- *) | |
3469 | (* Subterms. *) | |
3470 | (* ------------------------------------------------------------------------- *) | |
3471 | ||
3472 | fun subterm [] tm = tm | |
3473 | | subterm (_ :: _) (Var _) = raise ERR "subterm" "Var" | |
3474 | | subterm (h :: t) (Fn (_, args)) = | |
3475 | subterm t (List.nth (args, h)) | |
3476 | handle Subscript => raise ERR "subterm" "bad path"; | |
3477 | ||
3478 | local | |
3479 | fun update _ _ [] = raise ERR "rewrite" "bad path" | |
3480 | | update f n (h :: t) = if n = 0 then f h :: t else h :: update f (n - 1) t; | |
3481 | in | |
3482 | fun rewrite ([] |-> res) _ = res | |
3483 | | rewrite _ (Var _) = raise ERR "rewrite" "Var" | |
3484 | | rewrite ((h :: t) |-> res) (Fn (f, args)) = | |
3485 | Fn (f, update (rewrite (t |-> res)) h args); | |
3486 | end; | |
3487 | ||
3488 | local | |
3489 | fun atom_rewrite r = Atom o rewrite r o dest_atom; | |
3490 | in | |
3491 | fun literal_subterm p = subterm p o dest_atom o literal_atom; | |
3492 | fun literal_rewrite r = mk_literal o (I ## atom_rewrite r) o dest_literal; | |
3493 | end; | |
3494 | ||
3495 | (* ------------------------------------------------------------------------- *) | |
3496 | (* The Knuth-Bendix ordering. *) | |
3497 | (* ------------------------------------------------------------------------- *) | |
3498 | ||
3499 | type Weight = string * int -> int; | |
3500 | type Prec = (string * int) * (string * int) -> order; | |
3501 | ||
3502 | val no_vars = Multiset.empty String.compare; | |
3503 | fun one_var v = Multiset.insert (v, 1) no_vars; | |
3504 | ||
3505 | fun kb_weight w = | |
3506 | let | |
3507 | fun weight (Var v) = (0, one_var v) | |
3508 | | weight (Fn (f, a)) = foldl wght (w (f, length a), no_vars) a | |
3509 | and wght (t, (n, v)) = (curry op+ n ## Multiset.union v) (weight t) | |
3510 | in | |
3511 | weight | |
3512 | end; | |
3513 | ||
3514 | (* The Knuth-Bendix ordering is partial when terms contain variables *) | |
3515 | ||
3516 | fun kb_compare w p = | |
3517 | let | |
3518 | fun kbo [] = SOME EQUAL | |
3519 | | kbo (tu :: rest) = | |
3520 | if op= tu then SOME EQUAL | |
3521 | else | |
3522 | let val ((wt, vt), (wu, vu)) = Df (kb_weight w) tu | |
3523 | in kbo1 (Int.compare (wt, wu)) (Multiset.compare (vt, vu)) tu rest | |
3524 | end | |
3525 | and kbo1 _ NONE _ _ = NONE | |
3526 | | kbo1 LESS (SOME LESS) _ _ = SOME LESS | |
3527 | | kbo1 GREATER (SOME LESS) _ _ = NONE | |
3528 | | kbo1 EQUAL (SOME LESS) _ _ = SOME LESS | |
3529 | | kbo1 LESS (SOME GREATER) _ _ = NONE | |
3530 | | kbo1 GREATER (SOME GREATER) _ _ = SOME GREATER | |
3531 | | kbo1 EQUAL (SOME GREATER) _ _ = SOME GREATER | |
3532 | | kbo1 LESS (SOME EQUAL) _ _ = SOME LESS | |
3533 | | kbo1 GREATER (SOME EQUAL) _ _ = SOME GREATER | |
3534 | | kbo1 EQUAL (SOME EQUAL) (t, u) rest = kbo2 t u rest | |
3535 | and kbo2 (Fn (f, a)) (Fn (g, b)) rest = | |
3536 | (case p ((f, length a), (g, length b)) of LESS => SOME LESS | |
3537 | | GREATER => SOME GREATER | |
3538 | | EQUAL => kbo (zip a b @ rest)) | |
3539 | | kbo2 _ _ _ = raise BUG "kbo" "variable" | |
3540 | in | |
3541 | kbo o wrap | |
3542 | end; | |
3543 | ||
3544 | end | |
3545 | (*#line 0.0 "fol/Subst1.sig"*) | |
3546 | (* ========================================================================= *) | |
3547 | (* SUBSTITUTIONS ON FIRST-ORDER TERMS AND FORMULAS *) | |
3548 | (* Created by Joe Hurd, June 2002 *) | |
3549 | (* ========================================================================= *) | |
3550 | ||
3551 | signature Subst1 = | |
3552 | sig | |
3553 | ||
3554 | type 'a pp = 'a Useful.pp | |
3555 | type ('a, 'b) maplet = ('a, 'b) Useful.maplet | |
3556 | type term = Term1.term | |
3557 | type formula = Term1.formula | |
3558 | ||
3559 | type subst | |
3560 | ||
3561 | val |<>| : subst | |
3562 | val ::> : (string, term) maplet * subst -> subst | |
3563 | val @> : subst * subst -> subst | |
3564 | val null : subst -> bool | |
3565 | val term_subst : subst -> term -> term | |
3566 | val formula_subst : subst -> formula -> formula | |
3567 | val find_redex : string -> subst -> term option | |
3568 | val norm : subst -> subst (* Removes identity substitutions *) | |
3569 | val restrict : string list -> subst -> subst | |
3570 | val refine : subst -> subst -> subst | |
3571 | val is_renaming : subst -> bool | |
3572 | val to_maplets : subst -> (string, term) maplet list | |
3573 | val from_maplets : (string, term) maplet list -> subst | |
3574 | val foldl : ((string, term) maplet -> 'a -> 'a) -> 'a -> subst -> 'a | |
3575 | val foldr : ((string, term) maplet -> 'a -> 'a) -> 'a -> subst -> 'a | |
3576 | val pp_subst : subst pp | |
3577 | ||
3578 | end | |
3579 | ||
3580 | (*#line 0.0 "fol/Subst1.sml"*) | |
3581 | (* ========================================================================= *) | |
3582 | (* SUBSTITUTIONS ON FIRST-ORDER TERMS AND FORMULAS *) | |
3583 | (* Created by Joe Hurd, June 2002 *) | |
3584 | (* ========================================================================= *) | |
3585 | ||
3586 | (* | |
3587 | app load ["Binarymap", "Useful", "Term1"]; | |
3588 | *) | |
3589 | ||
3590 | (* | |
3591 | *) | |
3592 | structure Subst1 :> Subst1 = | |
3593 | struct | |
3594 | ||
3595 | open Useful Term1; | |
3596 | ||
3597 | infixr 8 ++; | |
3598 | infixr 7 >>; | |
3599 | infixr 6 ||; | |
3600 | infixr |-> ::> @> oo ##; | |
3601 | ||
3602 | structure M = Binarymap; | |
3603 | ||
3604 | (* ------------------------------------------------------------------------- *) | |
3605 | (* Helper functions. *) | |
3606 | (* ------------------------------------------------------------------------- *) | |
3607 | ||
3608 | fun Mpurge (d, k) = fst (M.remove (d, k)) handle NotFound => d; | |
3609 | ||
3610 | (* ------------------------------------------------------------------------- *) | |
3611 | (* The underlying representation. *) | |
3612 | (* ------------------------------------------------------------------------- *) | |
3613 | ||
3614 | datatype subst = Subst of (string, term) M.dict; | |
3615 | ||
3616 | (* ------------------------------------------------------------------------- *) | |
3617 | (* Operations. *) | |
3618 | (* ------------------------------------------------------------------------- *) | |
3619 | ||
3620 | val |<>| = Subst (M.mkDict String.compare); | |
3621 | ||
3622 | fun (a |-> b) ::> (Subst d) = Subst (M.insert (d, a, b)); | |
3623 | ||
3624 | fun (Subst sub1) @> (Subst sub2) = | |
3625 | Subst (M.foldl (fn (a, b, d) => M.insert (d, a, b)) sub2 sub1); | |
3626 | ||
3627 | fun null (Subst s) = M.numItems s = 0; | |
3628 | ||
3629 | fun find_redex r (Subst d) = M.peek (d, r); | |
3630 | ||
3631 | fun purge v (Subst d) = Subst (Mpurge (d, v)); | |
3632 | ||
3633 | local | |
3634 | exception Unchanged; | |
3635 | ||
3636 | fun always f x = f x handle Unchanged => x; | |
3637 | ||
3638 | fun pair_unchanged f (x, y) = | |
3639 | let | |
3640 | val (c, x) = (true, f x) handle Unchanged => (false, x) | |
3641 | val (c, y) = (true, f y) handle Unchanged => (c, y) | |
3642 | in | |
3643 | if c then (x, y) else raise Unchanged | |
3644 | end; | |
3645 | ||
3646 | fun list_unchanged f = | |
3647 | let | |
3648 | fun g (x, (b, l)) = (true, f x :: l) handle Unchanged => (b, x :: l) | |
3649 | fun h (true, l) = rev l | h (false, _) = raise Unchanged | |
3650 | in | |
3651 | h o foldl g (false, []) | |
3652 | end; | |
3653 | ||
3654 | fun find_unchanged v r = | |
3655 | case find_redex v r of SOME t => t | NONE => raise Unchanged; | |
3656 | ||
3657 | fun tm_subst r = | |
3658 | let | |
3659 | fun f (Var v) = find_unchanged v r | |
3660 | | f (Fn (n, a)) = Fn (n, list_unchanged f a) | |
3661 | in | |
3662 | f | |
3663 | end; | |
3664 | ||
3665 | fun fm_subst r = | |
3666 | let | |
3667 | fun f False = raise Unchanged | |
3668 | | f True = raise Unchanged | |
3669 | | f (Atom tm ) = Atom (tm_subst r tm) | |
3670 | | f (Not p ) = Not (f p) | |
3671 | | f (And pq ) = And (pair_unchanged f pq) | |
3672 | | f (Or pq ) = Or (pair_unchanged f pq) | |
3673 | | f (Imp pq ) = Imp (pair_unchanged f pq) | |
3674 | | f (Iff pq ) = Iff (pair_unchanged f pq) | |
3675 | | f (Forall vp) = fm_substq r Forall vp | |
3676 | | f (Exists vp) = fm_substq r Exists vp | |
3677 | in | |
3678 | if null r then I else always f | |
3679 | end | |
3680 | and fm_substq r Q (v, p) = | |
3681 | let val v' = variant v (FV (fm_subst (purge v r) p)) | |
3682 | in Q (v', fm_subst ((v |-> Var v') ::> r) p) | |
3683 | end; | |
3684 | in | |
3685 | fun term_subst env tm = if null env then tm else always (tm_subst env) tm; | |
3686 | fun formula_subst env fm = fm_subst env fm; | |
3687 | end; | |
3688 | ||
3689 | fun norm (sub as Subst dict) = | |
3690 | let | |
3691 | fun check (a, b, (c, d)) = | |
3692 | if Var a = b then (true, fst (M.remove (d, a))) else (c, d) | |
3693 | val (removed, dict') = M.foldl check (false, dict) dict | |
3694 | in | |
3695 | if removed then Subst dict' else sub | |
3696 | end; | |
3697 | ||
3698 | fun to_maplets (Subst s) = map (op|->) (M.listItems s); | |
3699 | ||
3700 | fun from_maplets ms = foldl (op ::>) |<>| (rev ms); | |
3701 | ||
3702 | fun restrict vs = | |
3703 | from_maplets o List.filter (fn (a |-> _) => mem a vs) o to_maplets; | |
3704 | ||
3705 | (* Note: this just doesn't work with cyclic substitutions! *) | |
3706 | fun refine (Subst sub1) sub2 = | |
3707 | let | |
3708 | fun f ((a, b), s) = | |
3709 | let val b' = term_subst sub2 b | |
3710 | in if Var a = b' then s else (a |-> b') ::> s | |
3711 | end | |
3712 | in | |
3713 | foldl f sub2 (M.listItems sub1) | |
3714 | end; | |
3715 | ||
3716 | local | |
3717 | exception QF | |
3718 | fun rs (v, Var w, l) = if mem w l then raise QF else w :: l | |
3719 | | rs (_, Fn _, _) = raise QF | |
3720 | in | |
3721 | fun is_renaming (Subst sub) = (M.foldl rs [] sub; true) handle QF => false; | |
3722 | end; | |
3723 | ||
3724 | fun foldl f b (Subst sub) = M.foldl (fn (s, t, a) => f (s |-> t) a) b sub; | |
3725 | ||
3726 | fun foldr f b (Subst sub) = M.foldr (fn (s, t, a) => f (s |-> t) a) b sub; | |
3727 | ||
3728 | val pp_subst = | |
3729 | pp_map to_maplets | |
3730 | (fn pp => | |
3731 | (fn [] => pp_string pp "|<>|" | |
3732 | | l => pp_list (pp_maplet pp_string pp_term) pp l)); | |
3733 | ||
3734 | end | |
3735 | (*#line 0.0 "fol/Kernel1.sig"*) | |
3736 | (* ========================================================================= *) | |
3737 | (* A LCF-STYLE LOGICAL KERNEL FOR FIRST-ORDER CLAUSES *) | |
3738 | (* Created by Joe Hurd, September 2001 *) | |
3739 | (* ========================================================================= *) | |
3740 | ||
3741 | signature Kernel1 = | |
3742 | sig | |
3743 | ||
3744 | type term = Term1.term | |
3745 | type formula = Term1.formula | |
3746 | type subst = Subst1.subst | |
3747 | ||
3748 | (* An ABSTRACT type for theorems *) | |
3749 | eqtype thm | |
3750 | datatype inference = Axiom | Refl | Assume | Inst | Factor | Resolve | Equality | |
3751 | ||
3752 | (* Destruction of theorems is fine *) | |
3753 | val dest_thm : thm -> formula list * (inference * thm list) | |
3754 | ||
3755 | (* But creation is only allowed by the primitive rules of inference *) | |
3756 | val AXIOM : formula list -> thm | |
3757 | val REFL : term -> thm | |
3758 | val ASSUME : formula -> thm | |
3759 | val INST : subst -> thm -> thm | |
3760 | val FACTOR : thm -> thm | |
3761 | val RESOLVE : formula -> thm -> thm -> thm | |
3762 | val EQUALITY : formula -> int list -> term -> bool -> thm -> thm | |
3763 | ||
3764 | end | |
3765 | (*#line 0.0 "fol/Kernel1.sml"*) | |
3766 | (* ========================================================================= *) | |
3767 | (* A LCF-STYLE LOGICAL KERNEL FOR FIRST-ORDER CLAUSES *) | |
3768 | (* Created by Joe Hurd, September 2001 *) | |
3769 | (* ========================================================================= *) | |
3770 | ||
3771 | structure Kernel1 :> Kernel1 = | |
3772 | struct | |
3773 | ||
3774 | open Useful Term1; | |
3775 | ||
3776 | infixr |-> ::> oo; | |
3777 | ||
3778 | type subst = Subst1.subst; | |
3779 | val formula_subst = Subst1.formula_subst; | |
3780 | ||
3781 | (* ------------------------------------------------------------------------- *) | |
3782 | (* An ABSTRACT type for theorems. *) | |
3783 | (* ------------------------------------------------------------------------- *) | |
3784 | ||
3785 | datatype inference = Axiom | Refl | Assume | Inst | Factor | Resolve | Equality; | |
3786 | ||
3787 | datatype thm = Thm of formula list * (inference * thm list); | |
3788 | ||
3789 | (* ------------------------------------------------------------------------- *) | |
3790 | (* Destruction of theorems is fine. *) | |
3791 | (* ------------------------------------------------------------------------- *) | |
3792 | ||
3793 | fun dest_thm (Thm th) = th; | |
3794 | ||
3795 | val clause = fst o dest_thm; | |
3796 | ||
3797 | (* ------------------------------------------------------------------------- *) | |
3798 | (* But creation is only allowed by the primitive rules of inference. *) | |
3799 | (* ------------------------------------------------------------------------- *) | |
3800 | ||
3801 | fun AXIOM cl = | |
3802 | if List.all is_literal cl then Thm (cl, (Axiom, [])) | |
3803 | else raise ERR "AXIOM" "argument not a list of literals"; | |
3804 | ||
3805 | fun REFL tm = Thm ([mk_eq (tm, tm)], (Refl, [])); | |
3806 | ||
3807 | fun ASSUME fm = | |
3808 | if is_literal fm then Thm ([fm, negate fm], (Assume, [])) | |
3809 | else raise ERR "ASSUME" "argument not a literal"; | |
3810 | ||
3811 | fun INST env (th as Thm (cl, pr)) = | |
3812 | let | |
3813 | val cl' = map (formula_subst env) cl | |
3814 | in | |
3815 | if cl' = cl then th else | |
3816 | case pr of (Inst, [th']) | |
3817 | => if cl' = clause th' then th' else Thm (cl', (Inst, [th'])) | |
3818 | | _ => Thm (cl', (Inst, [th])) | |
3819 | end; | |
3820 | ||
3821 | fun FACTOR th = | |
3822 | let val cl = rev (setify (clause th)) | |
3823 | in if cl = clause th then th else Thm (cl, (Factor, [th])) | |
3824 | end; | |
3825 | ||
3826 | fun RESOLVE fm th1 th2 = | |
3827 | let | |
3828 | val cl1 = clause th1 | |
3829 | val cl1' = List.filter (not o equal fm) cl1 | |
3830 | val cl2 = clause th2 | |
3831 | val cl2' = List.filter (not o equal (negate fm)) cl2 | |
3832 | val () = | |
3833 | assert (cl1 <> cl1' orelse cl2 <> cl2') | |
3834 | (ERR "RESOLVE" "resolvant does not feature in either clause") | |
3835 | in | |
3836 | Thm (cl1' @ cl2', (Resolve, [th1, th2])) | |
3837 | end; | |
3838 | ||
3839 | fun EQUALITY fm p res lr th = | |
3840 | let | |
3841 | val eq_lit = | |
3842 | let | |
3843 | val red = literal_subterm p fm | |
3844 | in | |
3845 | Not (mk_eq (if lr then (red, res) else (res, red))) | |
3846 | end | |
3847 | val other_lits = | |
3848 | let | |
3849 | val l = clause th | |
3850 | in | |
3851 | case index (equal fm) l of NONE | |
3852 | => raise ERR "EQUALITY" "literal does not occur in clause" | |
3853 | | SOME n => update_nth (literal_rewrite (p |-> res)) n l | |
3854 | end | |
3855 | in | |
3856 | Thm (eq_lit :: other_lits, (Equality, [th])) | |
3857 | end; | |
3858 | ||
3859 | end | |
3860 | (*#line 0.0 "fol/Match1.sig"*) | |
3861 | (* ========================================================================= *) | |
3862 | (* MATCHING AND UNIFICATION *) | |
3863 | (* Created by Joe Hurd, September 2001 *) | |
3864 | (* ========================================================================= *) | |
3865 | ||
3866 | signature Match1 = | |
3867 | sig | |
3868 | ||
3869 | type term = Term1.term | |
3870 | type formula = Term1.formula | |
3871 | type subst = Subst1.subst | |
3872 | ||
3873 | (* Matching *) | |
3874 | val matchl : subst -> (term * term) list -> subst | |
3875 | val match : term -> term -> subst | |
3876 | val matchl_literals : subst -> (formula * formula) list -> subst | |
3877 | val match_literals : formula -> formula -> subst | |
3878 | ||
3879 | (* Unification *) | |
3880 | val unifyl : subst -> (term * term) list -> subst | |
3881 | val unify : subst -> term -> term -> subst | |
3882 | val unify_and_apply : term -> term -> term | |
3883 | val unifyl_literals : subst -> (formula * formula) list -> subst | |
3884 | val unify_literals : subst -> formula -> formula -> subst | |
3885 | ||
3886 | end | |
3887 | (*#line 0.0 "fol/Match1.sml"*) | |
3888 | (* ========================================================================= *) | |
3889 | (* MATCHING AND UNIFICATION *) | |
3890 | (* Created by Joe Hurd, September 2001 *) | |
3891 | (* ========================================================================= *) | |
3892 | ||
3893 | (* | |
3894 | app load ["Useful", "Mosml", "Term1"]; | |
3895 | *) | |
3896 | ||
3897 | (* | |
3898 | *) | |
3899 | structure Match1 :> Match1 = | |
3900 | struct | |
3901 | ||
3902 | open Useful Term1; | |
3903 | ||
3904 | infixr |-> ::>; | |
3905 | ||
3906 | type subst = Subst1.subst; | |
3907 | val |<>| = Subst1.|<>|; | |
3908 | val op ::> = Subst1.::>; | |
3909 | val term_subst = Subst1.term_subst; | |
3910 | val formula_subst = Subst1.formula_subst; | |
3911 | ||
3912 | (* ------------------------------------------------------------------------- *) | |
3913 | (* Matching. *) | |
3914 | (* ------------------------------------------------------------------------- *) | |
3915 | ||
3916 | fun raw_match env x tm = | |
3917 | (case Subst1.find_redex x env of NONE => (x |-> tm) ::> env | |
3918 | | SOME tm' => | |
3919 | if tm = tm' then env | |
3920 | else raise ERR "match" "one var trying to match two different terms"); | |
3921 | ||
3922 | fun matchl env [] = env | |
3923 | | matchl env ((Var x, tm) :: rest) = matchl (raw_match env x tm) rest | |
3924 | | matchl env ((Fn (f, args), Fn (f', args')) :: rest) = | |
3925 | if f = f' andalso length args = length args' then | |
3926 | matchl env (zip args args' @ rest) | |
3927 | else raise ERR "match" "can't match two different functions" | |
3928 | | matchl _ _ = raise ERR "match" "different structure"; | |
3929 | ||
3930 | fun match tm tm' = Subst1.norm (matchl |<>| [(tm, tm')]); | |
3931 | ||
3932 | local | |
3933 | fun conv (Atom t, Atom t') = SOME (t, t') | |
3934 | | conv (Not p, Not q) = conv (p, q) | |
3935 | | conv (True, True) = NONE | |
3936 | | conv (False, False) = NONE | |
3937 | | conv _ = raise ERR "match_literals" "incompatible"; | |
3938 | in | |
3939 | fun matchl_literals sub = matchl sub o List.mapPartial conv; | |
3940 | end; | |
3941 | ||
3942 | fun match_literals lit lit' = Subst1.norm (matchl_literals |<>| [(lit, lit')]); | |
3943 | ||
3944 | (* ------------------------------------------------------------------------- *) | |
3945 | (* Unification. *) | |
3946 | (* ------------------------------------------------------------------------- *) | |
3947 | ||
3948 | local | |
3949 | fun occurs v tm = mem v (FVT tm); | |
3950 | ||
3951 | fun solve env [] = env | |
3952 | | solve env ((tm1, tm2) :: rest) = | |
3953 | solve' env (term_subst env tm1) (term_subst env tm2) rest | |
3954 | and solve' env (Var x) tm rest = | |
3955 | if Var x = tm then solve env rest | |
3956 | else if occurs x tm then raise ERR "unify" "occurs check" | |
3957 | else | |
3958 | (case Subst1.find_redex x env of NONE | |
3959 | => solve (Subst1.refine env ((x |-> tm) ::> |<>|)) rest | |
3960 | | SOME tm' => solve' env tm' tm rest) | |
3961 | | solve' env tm (tm' as Var _) rest = solve' env tm' tm rest | |
3962 | | solve' env (Fn (f, args)) (Fn (f', args')) rest = | |
3963 | if f = f' andalso length args = length args' then | |
3964 | solve env (zip args args' @ rest) | |
3965 | else raise ERR "unify" "different structure"; | |
3966 | in | |
3967 | val unifyl = solve; | |
3968 | end; | |
3969 | ||
3970 | fun unify env tm tm' = unifyl env [(tm, tm')]; | |
3971 | ||
3972 | fun unify_and_apply tm tm' = term_subst (unify |<>| tm tm') tm; | |
3973 | ||
3974 | local | |
3975 | fun conv (Atom t, Atom t') = SOME (t, t') | |
3976 | | conv (Not p, Not q) = conv (p, q) | |
3977 | | conv (True, True) = NONE | |
3978 | | conv (False, False) = NONE | |
3979 | | conv _ = raise ERR "unify_literals" "incompatible"; | |
3980 | in | |
3981 | fun unifyl_literals env = unifyl env o List.mapPartial conv; | |
3982 | end; | |
3983 | ||
3984 | fun unify_literals env lit lit' = unifyl_literals env [(lit, lit')]; | |
3985 | ||
3986 | end | |
3987 | (*#line 0.0 "fol/TermNet1.sig"*) | |
3988 | (* ========================================================================= *) | |
3989 | (* MATCHING AND UNIFICATION FOR SETS OF TERMS *) | |
3990 | (* Created by Joe Hurd, September 2001 *) | |
3991 | (* ========================================================================= *) | |
3992 | ||
3993 | signature TermNet1 = | |
3994 | sig | |
3995 | ||
3996 | type 'a pp = 'a Useful.pp | |
3997 | type ('a, 'b) maplet = ('a, 'b) Useful.maplet | |
3998 | type term = Term1.term | |
3999 | ||
4000 | type 'a term_map | |
4001 | ||
4002 | val empty : 'a term_map | |
4003 | val insert : (term, 'a) maplet -> 'a term_map -> 'a term_map | |
4004 | val match : 'a term_map -> term -> 'a list | |
4005 | val matched : 'a term_map -> term -> 'a list | |
4006 | val unify : 'a term_map -> term -> 'a list | |
4007 | val size : 'a term_map -> int | |
4008 | val from_maplets : (term, 'a) maplet list -> 'a term_map | |
4009 | val to_list : 'a term_map -> 'a list | |
4010 | val pp_term_map : 'a pp -> 'a term_map pp | |
4011 | ||
4012 | end | |
4013 | (*#line 0.0 "fol/TermNet1.sml"*) | |
4014 | (* ========================================================================= *) | |
4015 | (* MATCHING AND UNIFICATION FOR SETS OF TERMS *) | |
4016 | (* Created by Joe Hurd, September 2001 *) | |
4017 | (* ========================================================================= *) | |
4018 | ||
4019 | (* | |
4020 | app load ["Useful", "Mosml", "Term1"]; | |
4021 | *) | |
4022 | ||
4023 | (* | |
4024 | *) | |
4025 | structure TermNet1 :> TermNet1 = | |
4026 | struct | |
4027 | ||
4028 | open Useful Term1; | |
4029 | ||
4030 | infixr |-> ::> oo; | |
4031 | ||
4032 | val flatten = List.concat; | |
4033 | ||
4034 | (* ------------------------------------------------------------------------- *) | |
4035 | (* Helper functions. *) | |
4036 | (* ------------------------------------------------------------------------- *) | |
4037 | ||
4038 | local | |
4039 | fun fifo_order (m, _) (n, _) = m <= n; | |
4040 | in | |
4041 | fun restore_fifo_order l = map snd (sort fifo_order l); | |
4042 | end; | |
4043 | ||
4044 | fun partition_find f l = | |
4045 | let | |
4046 | fun pf _ [] = (NONE, l) | |
4047 | | pf dealt (x :: xs) = | |
4048 | if f x then (SOME x, List.revAppend (dealt, xs)) else pf (x :: dealt) xs | |
4049 | in | |
4050 | pf [] l | |
4051 | end; | |
4052 | ||
4053 | (* ------------------------------------------------------------------------- *) | |
4054 | (* Term discrimination trees are optimized for match queries. *) | |
4055 | (* ------------------------------------------------------------------------- *) | |
4056 | ||
4057 | datatype pattern = VAR | FN of string * int; | |
4058 | ||
4059 | type 'a map = (pattern, 'a) tree; | |
4060 | ||
4061 | datatype 'a term_map = MAP of int * (int * 'a) map list; | |
4062 | ||
4063 | val empty = MAP (0, []); | |
4064 | ||
4065 | fun size (MAP (i, _)) = i; | |
4066 | ||
4067 | fun to_list (MAP (_, n)) = | |
4068 | restore_fifo_order (flatten (map (tree_foldr (K flatten) wrap) n)); | |
4069 | ||
4070 | fun pp_term_map pp_a = pp_map to_list (pp_list pp_a); | |
4071 | ||
4072 | local | |
4073 | fun find_pat x (BRANCH (p, _)) = p = x | |
4074 | | find_pat _ (LEAF _) = raise BUG "find_pat" "misplaced LEAF"; | |
4075 | ||
4076 | fun add a [] l = LEAF a :: l | |
4077 | | add a (tm :: rest) l = | |
4078 | let | |
4079 | val (pat, rest) = | |
4080 | case tm of Var _ => (VAR, rest) | |
4081 | | Fn (f, args) => (FN (f, length args), args @ rest) | |
4082 | val (this, others) = partition_find (find_pat pat) l | |
4083 | val next = | |
4084 | case this of NONE => [] | |
4085 | | SOME (BRANCH (_, l)) => l | |
4086 | | SOME (LEAF _) => raise BUG "add" "misplaced LEAF" | |
4087 | in | |
4088 | BRANCH (pat, add a rest next) :: others | |
4089 | end; | |
4090 | in | |
4091 | fun insert (tm |-> a) (MAP (i, n)) = MAP (i + 1, add (i, a) [tm] n) | |
4092 | handle ERR_EXN _ => raise BUG "insert" "should never fail"; | |
4093 | end; | |
4094 | ||
4095 | fun from_maplets l = foldl (uncurry insert) empty l; | |
4096 | ||
4097 | local | |
4098 | fun mat VAR (_ :: rest) = SOME rest | |
4099 | | mat (FN (f, n)) (Fn (g, args) :: rest) = | |
4100 | if f = g andalso n = length args then SOME (args @ rest) else NONE | |
4101 | | mat (FN _) (Var _ :: _) = NONE | |
4102 | | mat _ [] = raise BUG "match" "ran out of subterms"; | |
4103 | ||
4104 | fun final a [] = SOME a | |
4105 | | final _ (_ :: _) = raise BUG "match" "too many subterms"; | |
4106 | in | |
4107 | fun match (MAP (_, n)) tm = | |
4108 | restore_fifo_order (flatten (map (tree_partial_foldl mat final [tm]) n)) | |
4109 | handle ERR_EXN _ => raise BUG "match" "should never fail"; | |
4110 | end; | |
4111 | ||
4112 | local | |
4113 | fun more VAR = 0 | more (FN (f, n)) = n; | |
4114 | fun mat pat (0, Var _ :: rest) = SOME (more pat, rest) | |
4115 | | mat VAR (0, Fn _ :: _) = NONE | |
4116 | | mat (FN (f, n)) (0, Fn (g, args) :: rest) = | |
4117 | if f = g andalso n = length args then SOME (0, args @ rest) else NONE | |
4118 | | mat _ (0, []) = raise BUG "matched" "ran out of subterms" | |
4119 | | mat pat (n, rest) = SOME (more pat + n - 1, rest); | |
4120 | ||
4121 | fun final a (0, []) = SOME a | |
4122 | | final _ (0, _ :: _) = raise BUG "matched" "too many subterms" | |
4123 | | final _ (n, _) = raise BUG "matched" "still skipping"; | |
4124 | in | |
4125 | fun matched (MAP (_, n)) tm = | |
4126 | restore_fifo_order (flatten (map (tree_partial_foldl mat final (0,[tm])) n)) | |
4127 | handle ERR_EXN _ => raise BUG "matched" "should never fail"; | |
4128 | end; | |
4129 | ||
4130 | local | |
4131 | fun more VAR = 0 | more (FN (f, n)) = n; | |
4132 | fun mat pat (0, Var _ :: rest) = SOME (more pat, rest) | |
4133 | | mat VAR (0, Fn _ :: rest) = SOME (0, rest) | |
4134 | | mat (FN (f, n)) (0, Fn (g, args) :: rest) = | |
4135 | if f = g andalso n = length args then SOME (0, args @ rest) else NONE | |
4136 | | mat _ (0, []) = raise BUG "unify" "ran out of subterms" | |
4137 | | mat pat (n, rest) = SOME (more pat + n - 1, rest); | |
4138 | ||
4139 | fun final a (0, []) = SOME a | |
4140 | | final _ (0, _ :: _) = raise BUG "unify" "too many subterms" | |
4141 | | final _ (n, _) = raise BUG "unify" "still skipping"; | |
4142 | in | |
4143 | fun unify (MAP (_, n)) tm = | |
4144 | restore_fifo_order (flatten (map (tree_partial_foldl mat final (0,[tm])) n)) | |
4145 | handle ERR_EXN _ => raise BUG "unify" "should never fail"; | |
4146 | end; | |
4147 | ||
4148 | (* ------------------------------------------------------------------------- *) | |
4149 | (* We can overlay the above type with a simple list type. *) | |
4150 | (* ------------------------------------------------------------------------- *) | |
4151 | (* | |
4152 | type 'a simple = int * int * term list * 'a list; | |
4153 | ||
4154 | type 'a term_map = ('a simple, 'a term_map) sum; | |
4155 | ||
4156 | fun check (0, _, t, a) = | |
4157 | INR (from_maplets (foldl (fn (x, xs) => op|-> x :: xs) [] (zip t a))) | |
4158 | | check p = INL p; | |
4159 | ||
4160 | val empty : 'a term_map = INR empty; | |
4161 | ||
4162 | fun new n = check (n, 0, [], []); | |
4163 | ||
4164 | val insert = fn m => | |
4165 | (fn INL (n, s, ts, xs) => | |
4166 | (case m of t |-> x => check (n - 1, s + 1, t :: ts, x :: xs)) | |
4167 | | INR d => INR (insert m d)); | |
4168 | ||
4169 | val match = fn INL (_, _, _, xs) => K (rev xs) | INR d => match d; | |
4170 | ||
4171 | val matched = fn INL (_, _, _, xs) => K (rev xs) | INR d => matched d; | |
4172 | ||
4173 | val unify = fn INL (_, _, _, xs) => K (rev xs) | INR d => unify d; | |
4174 | ||
4175 | val size = fn INL (_, s, _, _) => s | INR d => size d; | |
4176 | ||
4177 | val from_maplets = INR o from_maplets; | |
4178 | ||
4179 | val to_list = fn INL (_, _, _, xs) => rev xs | INR d => to_list d; | |
4180 | ||
4181 | val pp_term_map = | |
4182 | fn pp_a => fn pp => | |
4183 | (fn INL (_, _, _, xs) => pp_list pp_a pp xs | INR d => pp_term_map pp_a pp d); | |
4184 | *) | |
4185 | ||
4186 | end | |
4187 | (*#line 0.0 "fol/LiteralNet1.sig"*) | |
4188 | (* ========================================================================= *) | |
4189 | (* MATCHING AND UNIFICATION FOR SETS OF LITERALS *) | |
4190 | (* Created by Joe Hurd, June 2002 *) | |
4191 | (* ========================================================================= *) | |
4192 | ||
4193 | signature LiteralNet1 = | |
4194 | sig | |
4195 | ||
4196 | type 'a pp = 'a Useful.pp | |
4197 | type formula = Term1.formula | |
4198 | type ('a, 'b) maplet = ('a, 'b) Term1.maplet | |
4199 | ||
4200 | type 'a literal_map | |
4201 | ||
4202 | val empty : 'a literal_map | |
4203 | val insert : (formula, 'a) maplet -> 'a literal_map -> 'a literal_map | |
4204 | val match : 'a literal_map -> formula -> 'a list | |
4205 | val matched : 'a literal_map -> formula -> 'a list | |
4206 | val unify : 'a literal_map -> formula -> 'a list | |
4207 | val size : 'a literal_map -> int | |
4208 | val size_profile : 'a literal_map -> {t : int, f : int, p : int, n : int} | |
4209 | val from_maplets : (formula, 'a) maplet list -> 'a literal_map | |
4210 | val to_list : 'a literal_map -> 'a list | |
4211 | val pp_literal_map : 'a pp -> 'a literal_map pp | |
4212 | ||
4213 | end | |
4214 | (*#line 0.0 "fol/LiteralNet1.sml"*) | |
4215 | (* ========================================================================= *) | |
4216 | (* MATCHING AND UNIFICATION FOR SETS OF LITERALS *) | |
4217 | (* Created by Joe Hurd, June 2002 *) | |
4218 | (* ========================================================================= *) | |
4219 | ||
4220 | (* | |
4221 | app load ["Useful", "Mosml", "Term1"]; | |
4222 | *) | |
4223 | ||
4224 | (* | |
4225 | *) | |
4226 | structure LiteralNet1 :> LiteralNet1 = | |
4227 | struct | |
4228 | ||
4229 | open Useful Term1; | |
4230 | ||
4231 | infixr |-> ::> oo; | |
4232 | ||
4233 | structure T = TermNet1; | |
4234 | ||
4235 | (* ------------------------------------------------------------------------- *) | |
4236 | (* Literal nets. *) | |
4237 | (* ------------------------------------------------------------------------- *) | |
4238 | ||
4239 | type 'a literal_map = | |
4240 | ('a T.term_map * 'a T.term_map) * ((int * 'a list) * (int * 'a list)); | |
4241 | ||
4242 | val empty = ((T.empty, T.empty), ((0, []), (0, []))); | |
4243 | ||
4244 | fun insert (Atom a |-> b) ((p, n), tf) = ((T.insert (a |-> b) p, n), tf) | |
4245 | | insert (Not (Atom a) |-> b) ((p, n), tf) = ((p, T.insert (a |-> b) n), tf) | |
4246 | | insert (True |-> b) (pn, ((n, l), f)) = (pn, ((n + 1, b :: l), f)) | |
4247 | | insert (False |-> b) (pn, (t, (n, l))) = (pn, (t, (n + 1, b :: l))) | |
4248 | | insert (f |-> _) _ = raise BUG "insert" ("not a lit: "^formula_to_string f); | |
4249 | ||
4250 | fun from_maplets l = foldl (uncurry insert) empty l; | |
4251 | ||
4252 | fun to_list ((pos, neg), ((_, t), (_, f))) = | |
4253 | rev t @ rev f @ T.to_list pos @ T.to_list neg; | |
4254 | ||
4255 | fun pp_literal_map pp_a = pp_map to_list (pp_list pp_a); | |
4256 | ||
4257 | local | |
4258 | fun pos ((pos, _ ), _ ) = T.size pos; | |
4259 | fun neg ((_, neg), _ ) = T.size neg; | |
4260 | fun truth (_, ((n, _), _ )) = n; | |
4261 | fun falsity (_, (_, (n, _))) = n; | |
4262 | in | |
4263 | fun size l = truth l + falsity l + pos l + neg l; | |
4264 | fun size_profile l = {t = truth l, f = falsity l, p = pos l, n = neg l}; | |
4265 | end; | |
4266 | ||
4267 | fun match ((pos, _), _) (Atom a) = T.match pos a | |
4268 | | match ((_, neg), _) (Not (Atom a)) = T.match neg a | |
4269 | | match (_, ((_, t), _)) True = rev t | |
4270 | | match (_, (_, (_, f))) False = rev f | |
4271 | | match _ _ = raise BUG "match" "not a literal"; | |
4272 | ||
4273 | fun matched ((pos, _), _) (Atom a) = T.matched pos a | |
4274 | | matched ((_, neg), _) (Not (Atom a)) = T.matched neg a | |
4275 | | matched (_, ((_, t), _)) True = rev t | |
4276 | | matched (_, (_, (_, f))) False = rev f | |
4277 | | matched _ _ = raise BUG "matched" "not a literal"; | |
4278 | ||
4279 | fun unify ((pos, _), _) (Atom a) = T.unify pos a | |
4280 | | unify ((_, neg), _) (Not (Atom a)) = T.unify neg a | |
4281 | | unify (_, ((_, t), _)) True = rev t | |
4282 | | unify (_, (_, (_, f))) False = rev f | |
4283 | | unify _ _ = raise BUG "unify" "not a literal"; | |
4284 | ||
4285 | end | |
4286 | (*#line 0.0 "fol/Subsume1.sig"*) | |
4287 | (* ========================================================================= *) | |
4288 | (* A TYPE FOR SUBSUMPTION CHECKING *) | |
4289 | (* Created by Joe Hurd, April 2002 *) | |
4290 | (* ========================================================================= *) | |
4291 | ||
4292 | signature Subsume1 = | |
4293 | sig | |
4294 | ||
4295 | type 'a pp = 'a Useful.pp | |
4296 | type ('a, 'b) maplet = ('a, 'b) Useful.maplet | |
4297 | type formula = Term1.formula | |
4298 | type subst = Subst1.subst | |
4299 | ||
4300 | type 'a subsume | |
4301 | ||
4302 | val empty : 'a subsume | |
4303 | val add : (formula list, 'a) maplet -> 'a subsume -> 'a subsume | |
4304 | val subsumed : 'a subsume -> formula list -> (subst * 'a) list | |
4305 | val strictly_subsumed : 'a subsume -> formula list -> (subst * 'a) list | |
4306 | val info : 'a subsume -> string | |
4307 | val pp_subsum : 'a subsume pp | |
4308 | ||
4309 | end | |
4310 | (*#line 0.0 "fol/Subsume1.sml"*) | |
4311 | (* ========================================================================= *) | |
4312 | (* A TYPE FOR SUBSUMPTION CHECKING *) | |
4313 | (* Created by Joe Hurd, April 2002 *) | |
4314 | (* ========================================================================= *) | |
4315 | ||
4316 | (* | |
4317 | app load ["Thm1", "Match1"]; | |
4318 | *) | |
4319 | ||
4320 | (* | |
4321 | *) | |
4322 | structure Subsume1 :> Subsume1 = | |
4323 | struct | |
4324 | ||
4325 | infix |-> ::>; | |
4326 | ||
4327 | open Useful Term1 Match1; | |
4328 | ||
4329 | structure N = LiteralNet1; | |
4330 | ||
4331 | val ofilter = Option.filter; | |
4332 | type subst = Subst1.subst; | |
4333 | val |<>| = Subst1.|<>|; | |
4334 | val op ::> = Subst1.::>; | |
4335 | val term_subst = Subst1.term_subst; | |
4336 | val formula_subst = Subst1.formula_subst; | |
4337 | ||
4338 | (* ------------------------------------------------------------------------- *) | |
4339 | (* Chatting. *) | |
4340 | (* ------------------------------------------------------------------------- *) | |
4341 | ||
4342 | val () = traces := {module = "Subsume1", alignment = K 1} :: !traces; | |
4343 | ||
4344 | fun chat l m = trace {module = "Subsume1", message = m, level = l}; | |
4345 | ||
4346 | (* ------------------------------------------------------------------------- *) | |
4347 | (* Helper functions. *) | |
4348 | (* ------------------------------------------------------------------------- *) | |
4349 | ||
4350 | val frozen_prefix = "FROZEN__"; | |
4351 | ||
4352 | fun mk_frozen v = Fn (frozen_prefix ^ v, []); | |
4353 | ||
4354 | local | |
4355 | val chk = String.isPrefix frozen_prefix; | |
4356 | val dest = | |
4357 | let val l = size frozen_prefix in fn s => String.extract (s, l, NONE) end; | |
4358 | in | |
4359 | fun dest_frozen (Fn (s, [])) = | |
4360 | (assert (chk s) (ERR "dest_frozen" "not a frozen var"); dest s) | |
4361 | | dest_frozen _ = raise ERR "dest_frozen" "bad structure"; | |
4362 | end; | |
4363 | ||
4364 | val is_frozen = can dest_frozen; | |
4365 | ||
4366 | fun freeze_vars fms = | |
4367 | let | |
4368 | val vars = FV (list_mk_disj fms) | |
4369 | val sub = foldl (fn (v, s) => (v |-> mk_frozen v) ::> s) |<>| vars | |
4370 | in | |
4371 | map (formula_subst sub) fms | |
4372 | end; | |
4373 | ||
4374 | local | |
4375 | fun f (v |-> a) = (v |-> (if is_frozen a then Var (dest_frozen a) else a)); | |
4376 | in | |
4377 | val defrost_vars = Subst1.from_maplets o map f o Subst1.to_maplets; | |
4378 | end; | |
4379 | ||
4380 | val lit_size = formula_size o literal_atom; | |
4381 | ||
4382 | val sort_literals_by_size = | |
4383 | map snd o sort (fn (m, _) => fn (n, _) => m <= n) o | |
4384 | map (fn lit => (lit_size lit, lit)); | |
4385 | ||
4386 | (* ------------------------------------------------------------------------- *) | |
4387 | (* The core engine for subsumption checking. *) | |
4388 | (* ------------------------------------------------------------------------- *) | |
4389 | ||
4390 | type 'a sinfo = {sub : subst, hd : formula, tl : formula list, fin : 'a}; | |
4391 | ||
4392 | type 'a subs = 'a sinfo N.literal_map; | |
4393 | ||
4394 | fun add_lits (i as {hd, ...}) (net : 'a subs) = N.insert (hd |-> i) net; | |
4395 | ||
4396 | local | |
4397 | fun subsum strict lits = | |
4398 | let | |
4399 | val accept = | |
4400 | (if strict then ofilter (non Subst1.is_renaming) else SOME) o | |
4401 | defrost_vars | |
4402 | val impossible = | |
4403 | let val lit_net = N.from_maplets (map (fn l => (l |-> ())) lits) | |
4404 | in List.exists (null o N.matched lit_net) | |
4405 | end | |
4406 | fun extend sub lits fin net = | |
4407 | if impossible lits then net | |
4408 | else | |
4409 | case sort_literals_by_size lits of [] => raise BUG "extend" "null" | |
4410 | | hd :: tl => add_lits {sub = sub, hd = hd, tl = tl, fin = fin} net | |
4411 | fun examine lit ({sub, hd, tl, fin}, s as (net, res)) = | |
4412 | case total (matchl_literals sub) [(hd, lit)] of NONE => s | |
4413 | | SOME sub => | |
4414 | if null tl then | |
4415 | case accept sub of SOME sub => (net, (sub, fin) :: res) | NONE => s | |
4416 | else (extend sub (map (formula_subst sub) tl) fin net, res) | |
4417 | fun narrow1 net (lit, s) = foldl (examine lit) s (N.match net lit) | |
4418 | fun narrow (net, res) = | |
4419 | if N.size net = 0 then res | |
4420 | else narrow (foldl (narrow1 net) (N.empty, res) lits) | |
4421 | in | |
4422 | narrow | |
4423 | end; | |
4424 | in | |
4425 | fun subsumes strict net lits = | |
4426 | subsum strict (freeze_vars lits) (net, []) | |
4427 | handle ERR_EXN _ => raise BUG "subsumes" "shouldn't fail"; | |
4428 | end; | |
4429 | ||
4430 | (* ------------------------------------------------------------------------- *) | |
4431 | (* The user interface. *) | |
4432 | (* ------------------------------------------------------------------------- *) | |
4433 | ||
4434 | type 'a subsume = ('a, 'a subs) sum; | |
4435 | ||
4436 | val empty : 'a subsume = INR N.empty; | |
4437 | ||
4438 | fun add _ (s as INL _) = s | |
4439 | | add (fms |-> fin) (INR net) = | |
4440 | case sort_literals_by_size fms of [] => INL fin | |
4441 | | h :: t => INR (add_lits {sub = |<>|, hd = h, tl = t, fin = fin} net); | |
4442 | ||
4443 | fun subsumed (INL fin) _ = [(|<>|, fin)] | |
4444 | | subsumed (INR _) [] = [] | |
4445 | | subsumed (INR net) lits = subsumes false net lits; | |
4446 | ||
4447 | fun strictly_subsumed _ [] = [] | |
4448 | | strictly_subsumed (INL fin) _ = [(|<>|, fin)] | |
4449 | | strictly_subsumed (INR net) lits = subsumes true net lits; | |
4450 | ||
4451 | fun info ((INL _) : 'a subsume) = "*" | |
4452 | | info (INR net) = int_to_string (N.size net); | |
4453 | ||
4454 | val pp_subsum = fn z => pp_map info pp_string z; | |
4455 | ||
4456 | (* Quick testing | |
4457 | quotation := true; | |
4458 | installPP pp_formula; | |
4459 | installPP pp_term; | |
4460 | installPP pp_subst; | |
4461 | installPP pp_thm; | |
4462 | freeze_vars (map parse [`x + y <= 0`, `x = __x()`]); | |
4463 | val s = add_subsumer (AXIOM (map parse [`p(x,3)`, `p(2,y)`])) empty_subsum; | |
4464 | subsumed s (map parse [`p(2,3)`]); | |
4465 | *) | |
4466 | ||
4467 | end | |
4468 | (*#line 0.0 "fol/Tptp1.sig"*) | |
4469 | (* ========================================================================= *) | |
4470 | (* INTERFACE TO TPTP PROBLEM FILES *) | |
4471 | (* Created by Joe Hurd, December 2001 *) | |
4472 | (* ========================================================================= *) | |
4473 | ||
4474 | signature Tptp1 = | |
4475 | sig | |
4476 | ||
4477 | type term = Term1.term | |
4478 | type formula = Term1.formula | |
4479 | ||
4480 | (* Maintaining different relation and function names in TPTP problems *) | |
4481 | val renaming : {tptp : string, fol : string, arity : int} list ref | |
4482 | ||
4483 | (* Parsing: pass in a filename *) | |
4484 | val parse_cnf : string -> formula | |
4485 | ||
4486 | end | |
4487 | (*#line 0.0 "fol/Tptp1.sml"*) | |
4488 | (* ========================================================================= *) | |
4489 | (* INTERFACE TO TPTP PROBLEM FILES *) | |
4490 | (* Created by Joe Hurd, December 2001 *) | |
4491 | (* ========================================================================= *) | |
4492 | ||
4493 | (* | |
4494 | app load ["Stream", "Useful", "Parser", "Term1"]; | |
4495 | *) | |
4496 | ||
4497 | (* | |
4498 | *) | |
4499 | structure Tptp1 :> Tptp1 = | |
4500 | struct | |
4501 | ||
4502 | open Parser Useful Term1; | |
4503 | ||
4504 | infixr 9 >>++; | |
4505 | infixr 8 ++; | |
4506 | infixr 7 >>; | |
4507 | infixr 6 ||; | |
4508 | infix |->; | |
4509 | ||
4510 | structure S = Stream; | |
4511 | ||
4512 | (* ------------------------------------------------------------------------- *) | |
4513 | (* Abbreviating relation and function names in TPTP problems. *) | |
4514 | (* ------------------------------------------------------------------------- *) | |
4515 | ||
4516 | type rename = {tptp : string, fol : string, arity : int}; | |
4517 | ||
4518 | val renaming : rename list ref = ref [{tptp = "equal", fol = "=", arity = 2}]; | |
4519 | ||
4520 | (* ------------------------------------------------------------------------- *) | |
4521 | (* Parsing: pass in a filename. *) | |
4522 | (* ------------------------------------------------------------------------- *) | |
4523 | ||
4524 | val comment = equal #"%" o hd o explode; | |
4525 | ||
4526 | val input_lines = S.filter (non comment) o S.from_textfile; | |
4527 | ||
4528 | val input_chars = S.flatten o S.map (S.from_list o explode); | |
4529 | ||
4530 | datatype tok_type = Lower | Upper | Symbol | Punct; | |
4531 | ||
4532 | val lexer = | |
4533 | (many (some space) ++ | |
4534 | (((some lower || some digit) ++ many (some alphanum) >> | |
4535 | (fn (a, b) => (Lower, implode (a :: b)))) || | |
4536 | (some upper ++ many (some alphanum) >> | |
4537 | (fn (a, b) => (Upper, implode (a :: b)))) || | |
4538 | (atleastone (some symbol) >> (fn l => (Symbol, implode l))) || | |
4539 | (some punct >> (fn c => (Punct, str c))))) >> snd; | |
4540 | ||
4541 | val lex = many lexer ++ (many (some space) ++ finished) >> fst; | |
4542 | ||
4543 | val input_toks = S.from_list o fst o lex; | |
4544 | ||
4545 | fun Var' "T" = Var "T'" | |
4546 | | Var' "F" = Var "F'" | |
4547 | | Var' v = Var (if !var_string v then v else "v_" ^ v); | |
4548 | ||
4549 | local | |
4550 | fun verify (f, a) = | |
4551 | (if !var_string f then (if null a then "c_" else "f_") ^ f else f, a); | |
4552 | fun mapped (f, a) (m : rename list) = | |
4553 | let | |
4554 | fun g {tptp, arity, fol = _} = tptp = f andalso arity = length a | |
4555 | in case List.find g m of SOME {fol, ...} => (fol, a) | NONE => verify (f, a) | |
4556 | end; | |
4557 | in | |
4558 | fun Fn' A = Fn (mapped A (!renaming)); | |
4559 | end; | |
4560 | ||
4561 | fun term_parser input = | |
4562 | ((some (equal Upper o fst) >> (Var' o snd)) || | |
4563 | ((some (equal Lower o fst) >> snd) ++ | |
4564 | (optional | |
4565 | (exact (Punct, "(") ++ term_parser ++ | |
4566 | many ((exact (Punct, ",") ++ term_parser) >> snd) ++ | |
4567 | exact (Punct, ")")) >> | |
4568 | (fn SOME (_, (t, (ts, _))) => t :: ts | NONE => [])) >> | |
4569 | Fn')) input; | |
4570 | ||
4571 | val literal_parser = | |
4572 | ((exact (Symbol, "++") >> K true || exact (Symbol, "--") >> K false) ++ | |
4573 | term_parser) >> | |
4574 | (fn (s, t) => mk_literal (s, Atom (case t of Var v => Fn (v, []) | _ => t))); | |
4575 | ||
4576 | val clause_parser = | |
4577 | (exact (Lower, "input_clause") ++ exact (Punct, "(") ++ any ++ | |
4578 | exact (Punct, ",") ++ any ++ exact (Punct, ",") ++ exact (Punct, "[") ++ | |
4579 | literal_parser ++ many ((exact (Punct, ",") ++ literal_parser) >> snd) ++ | |
4580 | exact (Punct, "]") ++ exact (Punct, ")") ++ exact (Punct, ".")) >> | |
4581 | (fn (_, (_, (name, (_, (typ, (_, (_, (l, (ls, _))))))))) => | |
4582 | (snd name, snd typ, l :: ls)); | |
4583 | ||
4584 | val cnf_parser = fst o ((many clause_parser ++ finished) >> fst); | |
4585 | ||
4586 | local | |
4587 | fun cycle _ _ ([], _) = raise BUG "cycle" "" | |
4588 | | cycle f v (h :: t, avoid) = | |
4589 | let val h' = f h avoid in (h', (t @ [h], h' :: avoid)) end; | |
4590 | in | |
4591 | fun generalize_clause fm = | |
4592 | let | |
4593 | open Subst1 | |
4594 | val vars = FV fm | |
4595 | val nvars = length vars | |
4596 | val var_fn = if nvars <= 15 then variant else variant_num | |
4597 | val news = | |
4598 | if nvars = 6 then ["x", "y", "z", "x'", "y'", "z'"] | |
4599 | else fst (maps (cycle var_fn) vars (["x", "y", "z", "v", "w"], [])) | |
4600 | val sub = from_maplets (zipwith (fn v => fn x => v |-> Var x) vars news) | |
4601 | in | |
4602 | generalize (formula_subst sub fm) | |
4603 | end; | |
4604 | end; | |
4605 | ||
4606 | val input_cnf = | |
4607 | (fn (a, b) => Imp (a, Imp (b, False))) o | |
4608 | Df (list_mk_conj o map (generalize_clause o list_mk_disj o #3)) o | |
4609 | List.partition (not o equal "conjecture" o #2) o cnf_parser; | |
4610 | ||
4611 | val parse_cnf = input_cnf o input_toks o input_chars o input_lines; | |
4612 | ||
4613 | end | |
4614 | (*#line 0.0 "fol/Thm1.sig"*) | |
4615 | (* ========================================================================= *) | |
4616 | (* INTERFACE TO THE LCF-STYLE LOGICAL KERNEL, PLUS SOME DERIVED RULES *) | |
4617 | (* Created by Joe Hurd, September 2001 *) | |
4618 | (* ========================================================================= *) | |
4619 | ||
4620 | signature Thm1 = | |
4621 | sig | |
4622 | ||
4623 | type 'a pp = 'a Useful.pp | |
4624 | ||
4625 | include Kernel1 | |
4626 | ||
4627 | (* Annotated primitive inferences *) | |
4628 | datatype inference' = | |
4629 | Axiom' of formula list | |
4630 | | Refl' of term | |
4631 | | Assume' of formula | |
4632 | | Inst' of subst * thm | |
4633 | | Factor' of thm | |
4634 | | Resolve' of formula * thm * thm | |
4635 | | Equality' of formula * int list * term * bool * thm | |
4636 | ||
4637 | val primitive_inference : inference' -> thm | |
4638 | ||
4639 | (* User-friendly destructors *) | |
4640 | val clause : thm -> formula list | |
4641 | val inference : thm -> inference' | |
4642 | val proof : thm -> (thm * inference') list | |
4643 | ||
4644 | (* Pretty-printing of theorems and inferences *) | |
4645 | val pp_thm : thm pp | |
4646 | val pp_inference : inference pp | |
4647 | val pp_inference' : inference' pp | |
4648 | val pp_proof : (thm * inference') list pp | |
4649 | val thm_to_string' : int -> thm -> string (* purely functional *) | |
4650 | val inference_to_string' : int -> inference' -> string | |
4651 | val thm_to_string : thm -> string (* using !LINE_LENGTH *) | |
4652 | val inference_to_string : inference' -> string | |
4653 | ||
4654 | (* A total comparison function for theorems *) | |
4655 | val thm_compare : thm * thm -> order | |
4656 | ||
4657 | (* Contradictions and unit clauses *) | |
4658 | val is_contradiction : thm -> bool | |
4659 | val dest_unit : thm -> formula | |
4660 | val is_unit : thm -> bool | |
4661 | ||
4662 | (* Derived rules and theorems *) | |
4663 | val CONTR : formula -> thm -> thm | |
4664 | val WEAKEN : formula list -> thm -> thm | |
4665 | val FRESH_VARS : thm -> thm | |
4666 | val FRESH_VARSL : thm list -> thm list | |
4667 | val UNIT_SQUASH : thm -> thm | |
4668 | val REFLEXIVITY : thm | |
4669 | val SYMMETRY : thm | |
4670 | val TRANSITIVITY : thm | |
4671 | val FUN_CONGRUENCE : string * int -> thm | |
4672 | val REL_CONGRUENCE : string * int -> thm | |
4673 | ||
4674 | end | |
4675 | (*#line 0.0 "fol/Thm1.sml"*) | |
4676 | (* ========================================================================= *) | |
4677 | (* INTERFACE TO THE LCF-STYLE LOGICAL KERNEL, PLUS SOME DERIVED RULES *) | |
4678 | (* Created by Joe Hurd, September 2001 *) | |
4679 | (* ========================================================================= *) | |
4680 | ||
4681 | (* | |
4682 | app load ["Useful", "Term1", "Kernel1", "Match1"]; | |
4683 | *) | |
4684 | ||
4685 | (* | |
4686 | *) | |
4687 | structure Thm1 :> Thm1 = | |
4688 | struct | |
4689 | ||
4690 | open Useful Term1 Kernel1 Match1; | |
4691 | ||
4692 | infixr |-> ::> oo ##; | |
4693 | ||
4694 | type subst = Subst1.subst; | |
4695 | val |<>| = Subst1.|<>|; | |
4696 | val op ::> = Subst1.::>; | |
4697 | val term_subst = Subst1.term_subst; | |
4698 | val formula_subst = Subst1.formula_subst; | |
4699 | val pp_subst = Subst1.pp_subst; | |
4700 | ||
4701 | (* ------------------------------------------------------------------------- *) | |
4702 | (* Annotated primitive inferences. *) | |
4703 | (* ------------------------------------------------------------------------- *) | |
4704 | ||
4705 | datatype inference' = | |
4706 | Axiom' of formula list | |
4707 | | Refl' of term | |
4708 | | Assume' of formula | |
4709 | | Inst' of subst * thm | |
4710 | | Factor' of thm | |
4711 | | Resolve' of formula * thm * thm | |
4712 | | Equality' of formula * int list * term * bool * thm | |
4713 | ||
4714 | fun primitive_inference (Axiom' cl ) = AXIOM cl | |
4715 | | primitive_inference (Refl' tm ) = REFL tm | |
4716 | | primitive_inference (Assume' l ) = ASSUME l | |
4717 | | primitive_inference (Inst' (s, th) ) = INST s th | |
4718 | | primitive_inference (Factor' th ) = FACTOR th | |
4719 | | primitive_inference (Resolve' (l, th1, th2) ) = RESOLVE l th1 th2 | |
4720 | | primitive_inference (Equality' (l, p, t, s, th)) = EQUALITY l p t s th; | |
4721 | ||
4722 | val clause = fst o dest_thm; | |
4723 | ||
4724 | (* ------------------------------------------------------------------------- *) | |
4725 | (* Pretty-printing of theorems *) | |
4726 | (* ------------------------------------------------------------------------- *) | |
4727 | ||
4728 | fun pp_thm pp th = | |
4729 | (PP.begin_block pp PP.INCONSISTENT 3; | |
4730 | PP.add_string pp "|- "; | |
4731 | pp_formula pp (list_mk_disj (clause th)); | |
4732 | PP.end_block pp); | |
4733 | ||
4734 | local | |
4735 | fun inf_to_string Axiom = "Axiom" | |
4736 | | inf_to_string Refl = "Refl" | |
4737 | | inf_to_string Assume = "Assume" | |
4738 | | inf_to_string Inst = "Inst" | |
4739 | | inf_to_string Factor = "Factor" | |
4740 | | inf_to_string Resolve = "Resolve" | |
4741 | | inf_to_string Equality = "Equality"; | |
4742 | in | |
4743 | val pp_inference = pp_map inf_to_string pp_string; | |
4744 | end; | |
4745 | ||
4746 | local | |
4747 | fun pp_inf (Axiom' a) = (Axiom, C (pp_list pp_formula) a) | |
4748 | | pp_inf (Refl' a) = (Refl, C pp_term a) | |
4749 | | pp_inf (Assume' a) = (Assume, C pp_formula a) | |
4750 | | pp_inf (Inst' a) = (Inst, C (pp_pair pp_subst pp_thm) a) | |
4751 | | pp_inf (Factor' a) = (Factor, C pp_thm a) | |
4752 | | pp_inf (Resolve' a) = (Resolve, C (pp_triple pp_formula pp_thm pp_thm) a) | |
4753 | | pp_inf (Equality' (lit, p, r, lr, th)) = | |
4754 | (Equality, | |
4755 | C (pp_record [("lit", unit_pp pp_formula lit), | |
4756 | ("path", unit_pp (pp_list pp_int) p), | |
4757 | ("res", unit_pp pp_term r), | |
4758 | ("lr", unit_pp pp_bool lr), | |
4759 | ("thm", unit_pp pp_thm th)]) ()); | |
4760 | in | |
4761 | fun pp_inference' pp inf = | |
4762 | let | |
4763 | open PP | |
4764 | val (i, ppf) = pp_inf inf | |
4765 | in | |
4766 | (begin_block pp INCONSISTENT 0; | |
4767 | pp_inference pp i; | |
4768 | add_break pp (1, 0); | |
4769 | ppf pp; | |
4770 | end_block pp) | |
4771 | end; | |
4772 | end; | |
4773 | ||
4774 | val pp_proof = pp_list (pp_pair pp_thm pp_inference'); | |
4775 | ||
4776 | (* Purely functional pretty-printing *) | |
4777 | ||
4778 | fun thm_to_string' len = PP.pp_to_string len pp_thm; | |
4779 | fun inference_to_string' len = PP.pp_to_string len pp_inference'; | |
4780 | ||
4781 | (* Pretty-printing using !LINE_LENGTH *) | |
4782 | ||
4783 | fun thm_to_string th = thm_to_string' (!LINE_LENGTH) th; | |
4784 | fun inference_to_string inf = inference_to_string' (!LINE_LENGTH) inf; | |
4785 | ||
4786 | (* ------------------------------------------------------------------------- *) | |
4787 | (* A total comparison function for theorems. *) | |
4788 | (* ------------------------------------------------------------------------- *) | |
4789 | ||
4790 | local | |
4791 | fun cmp Axiom Axiom = EQUAL | |
4792 | | cmp Axiom _ = LESS | |
4793 | | cmp _ Axiom = GREATER | |
4794 | | cmp Refl Refl = EQUAL | |
4795 | | cmp Refl _ = LESS | |
4796 | | cmp _ Refl = GREATER | |
4797 | | cmp Assume Assume = EQUAL | |
4798 | | cmp Assume _ = LESS | |
4799 | | cmp _ Assume = GREATER | |
4800 | | cmp Inst Inst = EQUAL | |
4801 | | cmp Inst _ = LESS | |
4802 | | cmp _ Inst = GREATER | |
4803 | | cmp Factor Factor = EQUAL | |
4804 | | cmp Factor _ = LESS | |
4805 | | cmp _ Factor = GREATER | |
4806 | | cmp Resolve Resolve = EQUAL | |
4807 | | cmp Resolve Equality = LESS | |
4808 | | cmp Equality Resolve = GREATER | |
4809 | | cmp Equality Equality = EQUAL; | |
4810 | ||
4811 | fun cm [] = EQUAL | |
4812 | | cm ((th1, th2) :: l) = | |
4813 | let | |
4814 | val (l1, (p1, ths1)) = dest_thm th1 | |
4815 | val (l2, (p2, ths2)) = dest_thm th2 | |
4816 | in | |
4817 | case Int.compare (length l1, length l2) of EQUAL | |
4818 | => (case lex_compare formula_compare (zip l1 l2) of EQUAL | |
4819 | => (case cmp p1 p2 of EQUAL | |
4820 | => cm (zip ths1 ths2 @ l) | |
4821 | | x => x) | |
4822 | | x => x) | |
4823 | | x => x | |
4824 | end | |
4825 | in | |
4826 | val thm_compare = cm o wrap; | |
4827 | end; | |
4828 | ||
4829 | (* ------------------------------------------------------------------------- *) | |
4830 | (* Reconstructing proofs. *) | |
4831 | (* ------------------------------------------------------------------------- *) | |
4832 | ||
4833 | fun reconstruct_resolvant cl1 cl2 (cl1', cl2') = | |
4834 | case (subtract (setify cl1) cl1', subtract (setify cl2) cl2') of | |
4835 | (_ :: _ :: _, _) => NONE | |
4836 | | (_, _ :: _ :: _) => NONE | |
4837 | | ([l], []) => SOME l | |
4838 | | ([], [l']) => SOME (negate l') | |
4839 | | ([l], [l']) => if negate l = l' then SOME l else NONE | |
4840 | | ([], []) => NONE; | |
4841 | ||
4842 | fun reconstruct_equality l r = | |
4843 | let | |
4844 | fun recon_fn p (f, args) (f', args') rest = | |
4845 | recon_tm | |
4846 | (if f <> f' orelse length args <> length args' then rest | |
4847 | else map (C cons p ## I) (enumerate 0 (zip args args')) @ rest) | |
4848 | and recon_tm [] = NONE | |
4849 | | recon_tm ((p, (tm, tm')) :: rest) = | |
4850 | if tm = l andalso tm' = r then SOME (rev p) | |
4851 | else | |
4852 | case (tm, tm') of (Fn a, Fn a') => recon_fn p a a' rest | |
4853 | | _ => recon_tm rest | |
4854 | ||
4855 | fun recon_lit (Not a) (Not a') = recon_lit a a' | |
4856 | | recon_lit (Atom a) (Atom a') = | |
4857 | if l <> r andalso a = a' then NONE else recon_tm [([], (a, a'))] | |
4858 | | recon_lit _ _ = NONE | |
4859 | in | |
4860 | fn (lit, lit') => | |
4861 | case recon_lit lit lit' of SOME p => SOME (lit, p) | NONE => NONE | |
4862 | end; | |
4863 | ||
4864 | fun reconstruct (cl, (Axiom, [])) = Axiom' cl | |
4865 | | reconstruct ([lit], (Refl, [])) = Refl' (lhs lit) | |
4866 | | reconstruct ([fm, _], (Assume, [])) = Assume' fm | |
4867 | | reconstruct (cl, (Inst, [th])) = | |
4868 | Inst' (matchl_literals |<>| (zip (clause th) cl), th) | |
4869 | | reconstruct (_, (Factor, [th])) = Factor' th | |
4870 | | reconstruct (cl, (Resolve, [th1, th2])) = | |
4871 | let | |
4872 | val f = reconstruct_resolvant (clause th1) (clause th2) | |
4873 | val l = | |
4874 | case f (cl, cl) of SOME l => l | |
4875 | | NONE => | |
4876 | case first f (List.tabulate (length cl, split cl)) of SOME l => l | |
4877 | | NONE => raise BUG "inference" "couldn't reconstruct resolvant" | |
4878 | in | |
4879 | Resolve' (l, th1, th2) | |
4880 | end | |
4881 | | reconstruct (Not fm :: cl, (Equality, [th])) = | |
4882 | let | |
4883 | val (tm1, tm2) = dest_eq fm | |
4884 | in | |
4885 | case first (reconstruct_equality tm1 tm2) (zip (clause th) cl) of | |
4886 | SOME (l, p) => Equality' (l, p, tm2, true, th) | |
4887 | | NONE => | |
4888 | case first (reconstruct_equality tm2 tm1) (zip (clause th) cl) of | |
4889 | SOME (l, p) => Equality' (l, p, tm1, false, th) | |
4890 | | NONE => raise BUG "inference" "couldn't reconstruct equality step" | |
4891 | end | |
4892 | | reconstruct _ = raise BUG "inference" "malformed inference"; | |
4893 | ||
4894 | fun inference th = | |
4895 | let | |
4896 | val i = reconstruct (dest_thm th) | |
4897 | val _ = | |
4898 | (primitive_inference i = th) orelse | |
4899 | raise BUG "inference" | |
4900 | ("failed:\nth = " ^ thm_to_string th ^ "\ninf = " ^ inference_to_string i | |
4901 | ^ "\ninf_th = " ^ thm_to_string (primitive_inference i)) | |
4902 | in | |
4903 | i | |
4904 | end; | |
4905 | ||
4906 | local | |
4907 | val empty = (Binarymap.mkDict thm_compare, []); | |
4908 | fun contains (m, _) th = Option.isSome (Binarymap.peek (m, th)); | |
4909 | fun add th (m, p) = (Binarymap.insert (m, th, ()), (th, inference th) :: p); | |
4910 | val finalize = snd; | |
4911 | ||
4912 | fun reduce (th, pf) = | |
4913 | if contains pf th then pf | |
4914 | else add th (foldl reduce pf (snd (snd (dest_thm th)))); | |
4915 | in | |
4916 | fun proof th = finalize (reduce (th, empty)); | |
4917 | end; | |
4918 | ||
4919 | (* ------------------------------------------------------------------------- *) | |
4920 | (* Contradictions and unit clauses. *) | |
4921 | (* ------------------------------------------------------------------------- *) | |
4922 | ||
4923 | val is_contradiction = null o clause; | |
4924 | ||
4925 | fun dest_unit th = | |
4926 | case clause th of [lit] => lit | _ => raise ERR "dest_unit" "not a unit"; | |
4927 | ||
4928 | val is_unit = can dest_unit; | |
4929 | ||
4930 | (* ------------------------------------------------------------------------- *) | |
4931 | (* Derived rules *) | |
4932 | (* ------------------------------------------------------------------------- *) | |
4933 | ||
4934 | fun CONTR lit th = RESOLVE (negate lit) (ASSUME lit) th; | |
4935 | ||
4936 | fun WEAKEN lits th = foldl (uncurry CONTR) th (rev lits); | |
4937 | ||
4938 | fun FRESH_VARSL ths = | |
4939 | let | |
4940 | val fvs = FVL (List.concat (map clause ths)) | |
4941 | val vvs = new_vars (length fvs) | |
4942 | val sub = Subst1.from_maplets (zipwith (curry op |->) fvs vvs) | |
4943 | in | |
4944 | map (INST sub) ths | |
4945 | end; | |
4946 | ||
4947 | val FRESH_VARS = unwrap o FRESH_VARSL o wrap; | |
4948 | ||
4949 | fun UNIT_SQUASH th = | |
4950 | let | |
4951 | fun squash env (x :: (xs as y :: _)) = squash (unify_literals env x y) xs | |
4952 | | squash env _ = env | |
4953 | in | |
4954 | FACTOR (INST (squash |<>| (clause th)) th) | |
4955 | end; | |
4956 | ||
4957 | val REFLEXIVITY = REFL (Var "x"); | |
4958 | ||
4959 | val SYMMETRY = | |
4960 | EQUALITY (mk_eq (Var "x", Var "x")) [0] (Var "y") true REFLEXIVITY; | |
4961 | ||
4962 | val TRANSITIVITY = | |
4963 | EQUALITY (mk_eq (Var "y", Var "z")) [0] (Var "x") false | |
4964 | (ASSUME (Not (mk_eq (Var "y", Var "z")))); | |
4965 | ||
4966 | fun FUN_CONGRUENCE (function, arity) = | |
4967 | let | |
4968 | val xs = List.tabulate (arity, fn i => Var ("x" ^ int_to_string i)) | |
4969 | val ys = List.tabulate (arity, fn i => Var ("y" ^ int_to_string i)) | |
4970 | fun f (i, th) = | |
4971 | EQUALITY (List.last (clause th)) [1,i] (List.nth (ys, i)) true th | |
4972 | val refl = INST (("x" |-> Fn (function, xs)) ::> |<>|) REFLEXIVITY | |
4973 | in | |
4974 | foldl f refl (rev (interval 0 arity)) | |
4975 | end; | |
4976 | ||
4977 | fun REL_CONGRUENCE (relation, arity) = | |
4978 | let | |
4979 | val xs = List.tabulate (arity, fn i => Var ("x" ^ int_to_string i)) | |
4980 | val ys = List.tabulate (arity, fn i => Var ("y" ^ int_to_string i)) | |
4981 | fun f (i, th) = | |
4982 | EQUALITY (List.last (clause th)) [i] (List.nth (ys, i)) true th | |
4983 | val refl = ASSUME (Not (Atom (Fn (relation, xs)))) | |
4984 | in | |
4985 | foldl f refl (rev (interval 0 arity)) | |
4986 | end; | |
4987 | ||
4988 | end | |
4989 | (*#line 0.0 "fol/Canon1.sig"*) | |
4990 | (* ========================================================================= *) | |
4991 | (* FIRST-ORDER LOGIC CANONICALIZATION *) | |
4992 | (* Created by Joe Hurd, September 2001 *) | |
4993 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
4994 | (* ========================================================================= *) | |
4995 | ||
4996 | signature Canon1 = | |
4997 | sig | |
4998 | ||
4999 | type term = Term1.term | |
5000 | type formula = Term1.formula | |
5001 | type thm = Thm1.thm | |
5002 | ||
5003 | (* Simplification *) | |
5004 | val simplify : formula -> formula | |
5005 | ||
5006 | (* Negation normal form *) | |
5007 | val nnf : formula -> formula | |
5008 | ||
5009 | (* Prenex normal form *) | |
5010 | val prenex : formula -> formula | |
5011 | val pnf : formula -> formula | |
5012 | ||
5013 | (* Skolemization *) | |
5014 | val skolemize : formula -> formula | |
5015 | val full_skolemize : formula -> formula | |
5016 | ||
5017 | (* A tautology filter for clauses *) | |
5018 | val tautologous : formula list -> bool | |
5019 | ||
5020 | (* Conjunctive normal form *) | |
5021 | val purecnf : formula -> formula list list | |
5022 | val simpcnf : formula -> formula list list | |
5023 | val clausal : formula -> formula list list | |
5024 | val cnf : formula -> formula | |
5025 | val axiomatize : formula -> thm list | |
5026 | val eq_axiomatize : formula -> thm list (* Adds equality axioms *) | |
5027 | val eq_axiomatize' : formula -> thm list (* Adds if equality occurs *) | |
5028 | ||
5029 | end | |
5030 | (*#line 0.0 "fol/Canon1.sml"*) | |
5031 | (* ========================================================================= *) | |
5032 | (* FIRST-ORDER LOGIC CANONICALIZATION *) | |
5033 | (* Created by Joe Hurd, September 2001 *) | |
5034 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
5035 | (* ========================================================================= *) | |
5036 | ||
5037 | (* | |
5038 | app load ["Useful", "Term1"]; | |
5039 | *) | |
5040 | ||
5041 | structure Canon1 :> Canon1 = | |
5042 | struct | |
5043 | ||
5044 | open Useful Term1 Thm1; | |
5045 | ||
5046 | infixr |-> ::> oo; | |
5047 | ||
5048 | type subst = Subst1.subst; | |
5049 | val |<>| = Subst1.|<>|; | |
5050 | val op ::> = Subst1.::>; | |
5051 | val term_subst = Subst1.term_subst; | |
5052 | val formula_subst = Subst1.formula_subst; | |
5053 | ||
5054 | (* ------------------------------------------------------------------------- *) | |
5055 | (* Simplification. *) | |
5056 | (* ------------------------------------------------------------------------- *) | |
5057 | ||
5058 | fun simplify1 (Not False) = True | |
5059 | | simplify1 (Not True) = False | |
5060 | | simplify1 (Not (Not fm)) = fm | |
5061 | | simplify1 (And (False, q)) = False | |
5062 | | simplify1 (And (p, False)) = False | |
5063 | | simplify1 (And (True, q)) = q | |
5064 | | simplify1 (And (p, True)) = p | |
5065 | | simplify1 (Or (False, q)) = q | |
5066 | | simplify1 (Or (p, False)) = p | |
5067 | | simplify1 (Or (True, q)) = True | |
5068 | | simplify1 (Or (p, True)) = True | |
5069 | | simplify1 (Imp (False, q)) = True | |
5070 | | simplify1 (Imp (True, q)) = q | |
5071 | | simplify1 (Imp (p, True)) = True | |
5072 | | simplify1 (Imp (Not p, False)) = p | |
5073 | | simplify1 (Imp (p, False)) = Not p | |
5074 | | simplify1 (Iff (True, q)) = q | |
5075 | | simplify1 (Iff (p, True)) = p | |
5076 | | simplify1 (Iff (False, Not q)) = q | |
5077 | | simplify1 (Iff (False, q)) = Not q | |
5078 | | simplify1 (Iff (Not p, False)) = p | |
5079 | | simplify1 (Iff (p, False)) = Not p | |
5080 | | simplify1 (fm as Forall (x, p)) = if mem x (FV p) then fm else p | |
5081 | | simplify1 (fm as Exists (x, p)) = if mem x (FV p) then fm else p | |
5082 | | simplify1 fm = fm; | |
5083 | ||
5084 | fun simplify (Not p) = simplify1 (Not (simplify p)) | |
5085 | | simplify (And (p, q)) = simplify1 (And (simplify p, simplify q)) | |
5086 | | simplify (Or (p, q)) = simplify1 (Or (simplify p, simplify q)) | |
5087 | | simplify (Imp (p, q)) = simplify1 (Imp (simplify p, simplify q)) | |
5088 | | simplify (Iff (p, q)) = simplify1 (Iff (simplify p, simplify q)) | |
5089 | | simplify (Forall (x, p)) = simplify1 (Forall (x, simplify p)) | |
5090 | | simplify (Exists (x, p)) = simplify1 (Exists (x, simplify p)) | |
5091 | | simplify fm = fm; | |
5092 | ||
5093 | (* ------------------------------------------------------------------------- *) | |
5094 | (* Negation normal form. *) | |
5095 | (* ------------------------------------------------------------------------- *) | |
5096 | ||
5097 | fun nnf (And (p, q)) = And (nnf p, nnf q) | |
5098 | | nnf (Or (p, q)) = Or (nnf p, nnf q) | |
5099 | | nnf (Imp (p, q)) = Or (nnf' p, nnf q) | |
5100 | | nnf (Iff (p, q)) = Or (And (nnf p, nnf q), And (nnf' p, nnf' q)) | |
5101 | | nnf (Forall (x, p)) = Forall (x, nnf p) | |
5102 | | nnf (Exists (x, p)) = Exists (x, nnf p) | |
5103 | | nnf (Not x) = nnf' x | |
5104 | | nnf fm = fm | |
5105 | and nnf' True = False | |
5106 | | nnf' False = True | |
5107 | | nnf' (And (p, q)) = Or (nnf' p, nnf' q) | |
5108 | | nnf' (Or (p, q)) = And (nnf' p, nnf' q) | |
5109 | | nnf' (Imp (p, q)) = And (nnf p, nnf' q) | |
5110 | | nnf' (Iff (p, q)) = Or (And (nnf p, nnf' q), And (nnf' p, nnf q)) | |
5111 | | nnf' (Forall (x, p)) = Exists (x, nnf' p) | |
5112 | | nnf' (Exists (x, p)) = Forall (x, nnf' p) | |
5113 | | nnf' (Not x) = nnf x | |
5114 | | nnf' fm = Not fm; | |
5115 | ||
5116 | (* ------------------------------------------------------------------------- *) | |
5117 | (* Prenex normal form. *) | |
5118 | (* ------------------------------------------------------------------------- *) | |
5119 | ||
5120 | fun pullquants fm = | |
5121 | (case fm of | |
5122 | And (Forall (x, p), Forall (y, q)) => pullquant_2 fm Forall And x y p q | |
5123 | | Or (Exists (x, p), Exists (y, q)) => pullquant_2 fm Exists Or x y p q | |
5124 | | And (Forall (x, p), q) => pullquant_l fm Forall And x p q | |
5125 | | And (p, Forall (x, q)) => pullquant_r fm Forall And x p q | |
5126 | | Or (Forall (x, p), q) => pullquant_l fm Forall Or x p q | |
5127 | | Or (p, Forall (x, q)) => pullquant_r fm Forall Or x p q | |
5128 | | And (Exists (x, p), q) => pullquant_l fm Exists And x p q | |
5129 | | And (p, Exists (x, q)) => pullquant_r fm Exists And x p q | |
5130 | | Or (Exists (x, p), q) => pullquant_l fm Exists Or x p q | |
5131 | | Or (p, Exists (x, q)) => pullquant_r fm Exists Or x p q | |
5132 | | _ => fm) | |
5133 | and pullquant_l fm Q C x p q = | |
5134 | let | |
5135 | val x' = variant x (FV fm) | |
5136 | in | |
5137 | Q (x', pullquants (C (formula_subst ((x |-> Var x') ::> |<>|) p, q))) | |
5138 | end | |
5139 | and pullquant_r fm Q C x p q = | |
5140 | let | |
5141 | val x' = variant x (FV fm) | |
5142 | in | |
5143 | Q (x', pullquants (C (p, formula_subst ((x |-> Var x') ::> |<>|) q))) | |
5144 | end | |
5145 | and pullquant_2 fm Q C x y p q = | |
5146 | let | |
5147 | val x' = variant x (FV fm) | |
5148 | in | |
5149 | Q (x', pullquants(C (formula_subst ((x |-> Var x') ::> |<>|) p, | |
5150 | formula_subst ((x |-> Var x') ::> |<>|) q))) | |
5151 | end; | |
5152 | ||
5153 | fun prenex (Forall (x, p)) = Forall (x, prenex p) | |
5154 | | prenex (Exists (x, p)) = Exists (x, prenex p) | |
5155 | | prenex (And (p, q)) = pullquants (And (prenex p, prenex q)) | |
5156 | | prenex (Or (p, q)) = pullquants (Or (prenex p, prenex q)) | |
5157 | | prenex fm = fm; | |
5158 | ||
5159 | val pnf = prenex o nnf o simplify; | |
5160 | ||
5161 | (* ------------------------------------------------------------------------- *) | |
5162 | (* Skolemization function. *) | |
5163 | (* ------------------------------------------------------------------------- *) | |
5164 | ||
5165 | fun skolem avoid (Exists (y, p)) = | |
5166 | let | |
5167 | val xs = subtract (FV p) [y] | |
5168 | val f = variant (if xs = [] then "c_" ^ y else "f_" ^ y) avoid | |
5169 | in | |
5170 | skolem avoid (formula_subst ((y |-> Fn (f, map Var xs)) ::> |<>|) p) | |
5171 | end | |
5172 | | skolem avoid (Forall (x, p)) = Forall (x, skolem avoid p) | |
5173 | | skolem avoid (And (p, q)) = skolem2 avoid And p q | |
5174 | | skolem avoid (Or (p, q)) = skolem2 avoid Or p q | |
5175 | | skolem _ fm = fm | |
5176 | and skolem2 avoid C p q = | |
5177 | let | |
5178 | val p' = skolem avoid p | |
5179 | val q' = skolem (union avoid (function_names p')) q | |
5180 | in | |
5181 | C (p', q') | |
5182 | end; | |
5183 | ||
5184 | fun skolemize fm = skolem (function_names fm) fm; | |
5185 | ||
5186 | val full_skolemize = specialize o prenex o skolemize o nnf o simplify; | |
5187 | ||
5188 | (* ------------------------------------------------------------------------- *) | |
5189 | (* A tautology filter for clauses. *) | |
5190 | (* ------------------------------------------------------------------------- *) | |
5191 | ||
5192 | fun tautologous cls = | |
5193 | let | |
5194 | val (pos, neg) = List.partition positive cls | |
5195 | in | |
5196 | intersect pos (map negate neg) <> [] | |
5197 | end; | |
5198 | ||
5199 | (* ------------------------------------------------------------------------- *) | |
5200 | (* Conjunctive Normal Form. *) | |
5201 | (* ------------------------------------------------------------------------- *) | |
5202 | ||
5203 | fun distrib s1 s2 = cartwith union s1 s2; | |
5204 | ||
5205 | fun purecnf (Or (p, q)) = distrib (purecnf p) (purecnf q) | |
5206 | | purecnf (And (p, q)) = union (purecnf p) (purecnf q) | |
5207 | | purecnf fm = [[fm]]; | |
5208 | ||
5209 | fun simpcnf True = [] | |
5210 | | simpcnf False = [[]] | |
5211 | | simpcnf fm = List.filter (non tautologous) (purecnf fm); | |
5212 | ||
5213 | val clausal = | |
5214 | List.concat o map (simpcnf o specialize o prenex) o flatten_conj o | |
5215 | skolemize o nnf o simplify | |
5216 | ||
5217 | val cnf = list_mk_conj o map list_mk_disj o clausal; | |
5218 | ||
5219 | val axiomatize = map AXIOM o clausal; | |
5220 | ||
5221 | fun eq_axiomatize fm = | |
5222 | let | |
5223 | val eqs = [REFLEXIVITY, SYMMETRY, TRANSITIVITY] | |
5224 | val rels = map REL_CONGRUENCE (relations_no_eq fm) | |
5225 | val funs = map FUN_CONGRUENCE (functions fm) | |
5226 | in | |
5227 | eqs @ funs @ rels @ axiomatize fm | |
5228 | end; | |
5229 | ||
5230 | fun eq_axiomatize' fm = (if eq_occurs fm then eq_axiomatize else axiomatize) fm; | |
5231 | ||
5232 | end | |
5233 | (*#line 0.0 "fol/Units1.sig"*) | |
5234 | (* ========================================================================= *) | |
5235 | (* A STORE IN WHICH TO CACHE UNIT THEOREMS *) | |
5236 | (* Created by Joe Hurd, November 2001 *) | |
5237 | (* ========================================================================= *) | |
5238 | ||
5239 | signature Units1 = | |
5240 | sig | |
5241 | ||
5242 | type 'a pp = 'a Useful.pp | |
5243 | type formula = Term1.formula | |
5244 | type thm = Thm1.thm | |
5245 | ||
5246 | type units | |
5247 | ||
5248 | val empty : units | |
5249 | val add : thm -> units -> units | |
5250 | val addl : thm list -> units -> units | |
5251 | val subsumes : units -> formula -> thm option | |
5252 | val prove : units -> formula list -> thm list option | |
5253 | val demod : units -> thm -> thm | |
5254 | val info : units -> string | |
5255 | val pp_units : units pp | |
5256 | ||
5257 | end | |
5258 | (*#line 0.0 "fol/Units1.sml"*) | |
5259 | (* ========================================================================= *) | |
5260 | (* A STORE IN WHICH TO CACHE UNIT THEOREMS *) | |
5261 | (* Created by Joe Hurd, November 2001 *) | |
5262 | (* ========================================================================= *) | |
5263 | ||
5264 | (* | |
5265 | app load | |
5266 | ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"]; | |
5267 | *) | |
5268 | ||
5269 | (* | |
5270 | *) | |
5271 | structure Units1 :> Units1 = | |
5272 | struct | |
5273 | ||
5274 | open Useful Term1 Thm1 Match1; | |
5275 | ||
5276 | infix |-> ::> @> oo ##; | |
5277 | ||
5278 | structure N = LiteralNet1; | |
5279 | ||
5280 | (* ------------------------------------------------------------------------- *) | |
5281 | (* Auxiliary functions. *) | |
5282 | (* ------------------------------------------------------------------------- *) | |
5283 | ||
5284 | fun lift_options f = | |
5285 | let | |
5286 | fun g res [] = SOME (rev res) | |
5287 | | g res (x :: xs) = case f x of SOME y => g (y :: res) xs | NONE => NONE | |
5288 | in | |
5289 | g [] | |
5290 | end; | |
5291 | ||
5292 | (* ------------------------------------------------------------------------- *) | |
5293 | (* Operations on the raw unit cache. *) | |
5294 | (* ------------------------------------------------------------------------- *) | |
5295 | ||
5296 | type uns = thm N.literal_map; | |
5297 | ||
5298 | val uempty : uns = N.empty; | |
5299 | ||
5300 | fun uadd th uns = N.insert (dest_unit th |-> th) uns; | |
5301 | ||
5302 | fun usubsumes uns lit = | |
5303 | List.find (can (C match_literals lit) o dest_unit) | |
5304 | (rev (N.match uns lit)); | |
5305 | ||
5306 | fun uprove uns = | |
5307 | let | |
5308 | fun pr lit = | |
5309 | Option.map (fn th => INST (match_literals (dest_unit th) lit) th) | |
5310 | (usubsumes uns lit) | |
5311 | in | |
5312 | lift_options pr | |
5313 | end; | |
5314 | ||
5315 | fun udemod uns = | |
5316 | let | |
5317 | fun demod (lit, th) = | |
5318 | case uprove uns [negate lit] of NONE => th | |
5319 | | SOME [dth] => RESOLVE lit th dth | |
5320 | | SOME _ => raise BUG "unit_demod" "corrupt" | |
5321 | in | |
5322 | fn th => foldl demod th (clause th) | |
5323 | end; | |
5324 | ||
5325 | (* ------------------------------------------------------------------------- *) | |
5326 | (* The user interface. *) | |
5327 | (* ------------------------------------------------------------------------- *) | |
5328 | ||
5329 | type units = (thm, uns) sum; | |
5330 | ||
5331 | val empty = INR uempty; | |
5332 | ||
5333 | fun subsumes (INL th) = K (SOME th) | |
5334 | | subsumes (INR uns) = usubsumes uns; | |
5335 | ||
5336 | fun prove (INL th) = SOME o map (fn False => th | lit => CONTR lit th) | |
5337 | | prove (INR uns) = uprove uns; | |
5338 | ||
5339 | fun demod (INL th) = K th | |
5340 | | demod (INR uns) = udemod uns; | |
5341 | ||
5342 | fun info ((INL _) : units) = "*" | |
5343 | | info (INR uns) = int_to_string (N.size uns); | |
5344 | ||
5345 | val pp_units = pp_map info pp_string; | |
5346 | ||
5347 | (* Adding a theorem involves squashing it to a unit, if possible. *) | |
5348 | ||
5349 | fun add _ (U as INL _) = U | |
5350 | | add th (U as INR uns) = | |
5351 | if List.exists (Option.isSome o usubsumes uns) (clause th) then U | |
5352 | else | |
5353 | let | |
5354 | val th = udemod uns th | |
5355 | in | |
5356 | if is_contradiction th then INL th | |
5357 | else case total UNIT_SQUASH th of NONE => U | SOME th => INR (uadd th uns) | |
5358 | end; | |
5359 | ||
5360 | val addl = C (foldl (uncurry add)); | |
5361 | ||
5362 | end | |
5363 | (*#line 0.0 "fol/Problem1.sig"*) | |
5364 | (* ========================================================================= *) | |
5365 | (* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *) | |
5366 | (* Created by Joe Hurd, September 2001 *) | |
5367 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
5368 | (* ========================================================================= *) | |
5369 | ||
5370 | signature Problem1 = | |
5371 | sig | |
5372 | ||
5373 | type 'a quotation = 'a frag list | |
5374 | type 'a problem = {name : string, goal : 'a quotation} | |
5375 | ||
5376 | (* Accessing individual problems *) | |
5377 | val get : 'a problem list -> string -> 'a quotation | |
5378 | ||
5379 | (* The master collections *) | |
5380 | val nonequality : 'a problem list | |
5381 | val equality : 'a problem list | |
5382 | val tptp : 'a problem list | |
5383 | ||
5384 | (* Some compilations *) | |
5385 | (*val quick : 'a problem list *) | |
5386 | ||
5387 | end | |
5388 | (*#line 0.0 "fol/Problem1.sml"*) | |
5389 | (* ========================================================================= *) | |
5390 | (* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *) | |
5391 | (* Created by Joe Hurd, September 2001 *) | |
5392 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
5393 | (* ========================================================================= *) | |
5394 | ||
5395 | structure Problem1 :> Problem1 = | |
5396 | struct | |
5397 | ||
5398 | type 'a quotation = 'a frag list; | |
5399 | ||
5400 | type 'a problem = {name : string, goal : 'a quotation}; | |
5401 | ||
5402 | (* ========================================================================= *) | |
5403 | (* Accessing individual problems. *) | |
5404 | (* ========================================================================= *) | |
5405 | ||
5406 | fun extract (p : 'a problem list) n = | |
5407 | Option.valOf (List.find (fn {name, ...} => name = n) p); | |
5408 | ||
5409 | fun get p = #goal o extract p; | |
5410 | ||
5411 | (* ========================================================================= *) | |
5412 | (* Problems without equality. *) | |
5413 | (* ========================================================================= *) | |
5414 | ||
5415 | val nonequality = [ | |
5416 | ||
5417 | (* ------------------------------------------------------------------------- *) | |
5418 | (* Trivia (some of which demonstrate ex-bugs in provers). *) | |
5419 | (* ------------------------------------------------------------------------- *) | |
5420 | ||
5421 | {name = "TRUE", | |
5422 | goal = [ | |
5423 | QUOTE "\nT"]}, | |
5424 | ||
5425 | {name = "P_or_not_P", | |
5426 | goal = [ | |
5427 | QUOTE "\np \\/ ~p"]}, | |
5428 | ||
5429 | {name = "JH_test", | |
5430 | goal = [ | |
5431 | QUOTE "\n!x y. ?z. p x \\/ p y ==> p z"]}, | |
5432 | ||
5433 | {name = "CYCLIC", | |
5434 | goal = [ | |
5435 | QUOTE "\n(!x. p (g (c x))) ==> ?z. p (g z)"]}, | |
5436 | ||
5437 | {name = "MN_bug", | |
5438 | goal = [ | |
5439 | QUOTE "\n(!x. ?y. f y x x) ==> ?z. f z 0 0"]}, | |
5440 | ||
5441 | {name = "ERIC", | |
5442 | goal = [ | |
5443 | QUOTE "\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]}, | |
5444 | ||
5445 | (* ------------------------------------------------------------------------- *) | |
5446 | (* Propositional Logic. *) | |
5447 | (* ------------------------------------------------------------------------- *) | |
5448 | ||
5449 | {name = "PROP_1", | |
5450 | goal = [ | |
5451 | QUOTE "\np ==> q <=> ~q ==> ~p"]}, | |
5452 | ||
5453 | {name = "PROP_2", | |
5454 | goal = [ | |
5455 | QUOTE "\n~~p <=> p"]}, | |
5456 | ||
5457 | {name = "PROP_3", | |
5458 | goal = [ | |
5459 | QUOTE "\n~(p ==> q) ==> q ==> p"]}, | |
5460 | ||
5461 | {name = "PROP_4", | |
5462 | goal = [ | |
5463 | QUOTE "\n~p ==> q <=> ~q ==> p"]}, | |
5464 | ||
5465 | {name = "PROP_5", | |
5466 | goal = [ | |
5467 | QUOTE "\n(p \\/ q ==> p \\/ r) ==> p \\/ (q ==> r)"]}, | |
5468 | ||
5469 | {name = "PROP_6", | |
5470 | goal = [ | |
5471 | QUOTE "\np \\/ ~p"]}, | |
5472 | ||
5473 | {name = "PROP_7", | |
5474 | goal = [ | |
5475 | QUOTE "\np \\/ ~~~p"]}, | |
5476 | ||
5477 | {name = "PROP_8", | |
5478 | goal = [ | |
5479 | QUOTE "\n((p ==> q) ==> p) ==> p"]}, | |
5480 | ||
5481 | {name = "PROP_9", | |
5482 | goal = [ | |
5483 | QUOTE "\n(p \\/ q) /\\ (~p \\/ q) /\\ (p \\/ ~q) ==> ~(~q \\/ ~q)"]}, | |
5484 | ||
5485 | {name = "PROP_10", | |
5486 | goal = [ | |
5487 | QUOTE "\n(q ==> r) /\\ (r ==> p /\\ q) /\\ (p ==> q /\\ r) ==> (p <=> q)"]}, | |
5488 | ||
5489 | {name = "PROP_11", | |
5490 | goal = [ | |
5491 | QUOTE "\np <=> p"]}, | |
5492 | ||
5493 | {name = "PROP_12", | |
5494 | goal = [ | |
5495 | QUOTE "\n((p <=> q) <=> r) <=> p <=> q <=> r"]}, | |
5496 | ||
5497 | {name = "PROP_13", | |
5498 | goal = [ | |
5499 | QUOTE "\np \\/ q /\\ r <=> (p \\/ q) /\\ (p \\/ r)"]}, | |
5500 | ||
5501 | {name = "PROP_14", | |
5502 | goal = [ | |
5503 | QUOTE "\n(p <=> q) <=> (q \\/ ~p) /\\ (~q \\/ p)"]}, | |
5504 | ||
5505 | {name = "PROP_15", | |
5506 | goal = [ | |
5507 | QUOTE "\np ==> q <=> ~p \\/ q"]}, | |
5508 | ||
5509 | {name = "PROP_16", | |
5510 | goal = [ | |
5511 | QUOTE "\n(p ==> q) \\/ (q ==> p)"]}, | |
5512 | ||
5513 | {name = "PROP_17", | |
5514 | goal = [ | |
5515 | QUOTE "\np /\\ (q ==> r) ==> s <=> (~p \\/ q \\/ s) /\\ (~p \\/ ~r \\/ s)"]}, | |
5516 | ||
5517 | {name = "MATHS4_EXAMPLE", | |
5518 | goal = [ | |
5519 | QUOTE "\n(a \\/ ~k ==> g) /\\ (g ==> q) /\\ ~q ==> k"]}, | |
5520 | ||
5521 | {name = "XOR_ASSOC", | |
5522 | goal = [ | |
5523 | QUOTE "\n~(~(p <=> q) <=> r) <=> ~(p <=> ~(q <=> r))"]}, | |
5524 | ||
5525 | (* ------------------------------------------------------------------------- *) | |
5526 | (* Monadic Predicate Logic. *) | |
5527 | (* ------------------------------------------------------------------------- *) | |
5528 | ||
5529 | (* The drinker's principle *) | |
5530 | {name = "P18", | |
5531 | goal = [ | |
5532 | QUOTE "\n?very_popular_guy. !whole_pub. drinks very_popular_guy ==> drinks whole_pub"]}, | |
5533 | ||
5534 | {name = "P19", | |
5535 | goal = [ | |
5536 | QUOTE "\n?x. !y z. (p y ==> q z) ==> p x ==> q x"]}, | |
5537 | ||
5538 | {name = "P20", | |
5539 | goal = [ | |
5540 | QUOTE "\n(!x y. ?z. !w. p x /\\ q y ==> r z /\\ u w) /\\ (!x y. p x /\\ q y) ==> ?z. r z"]}, | |
5541 | ||
5542 | {name = "P21", | |
5543 | goal = [ | |
5544 | QUOTE "\n(?x. p ==> q x) /\\ (?x. q x ==> p) ==> ?x. p <=> q x"]}, | |
5545 | ||
5546 | {name = "P22", | |
5547 | goal = [ | |
5548 | QUOTE "\n(!x. p <=> q x) ==> (p <=> !x. q x)"]}, | |
5549 | ||
5550 | {name = "P23", | |
5551 | goal = [ | |
5552 | QUOTE "\n(!x. p \\/ q x) <=> p \\/ !x. q x"]}, | |
5553 | ||
5554 | {name = "P24", | |
5555 | goal = [ | |
5556 | ||
5557 | QUOTE "\n~(?x. u x /\\ q x) /\\ (!x. p x ==> q x \\/ r x) /\\ ~(?x. p x ==> ?x. q x) /\\\n(!x. q x /\\ r x ==> u x) ==> ?x. p x /\\ r x"]}, | |
5558 | ||
5559 | {name = "P25", | |
5560 | goal = [ | |
5561 | ||
5562 | QUOTE "\n(?x. p x) /\\ (!x. u x ==> ~g x /\\ r x) /\\ (!x. p x ==> g x /\\ u x) /\\\n((!x. p x ==> q x) \\/ ?x. q x /\\ p x) ==> ?x. q x /\\ p x"]}, | |
5563 | ||
5564 | {name = "P26", | |
5565 | goal = [ | |
5566 | ||
5567 | QUOTE "\n((?x. p x) <=> ?x. q x) /\\ (!x y. p x /\\ q y ==> (r x <=> u y)) ==>\n((!x. p x ==> r x) <=> !x. q x ==> u x)"]}, | |
5568 | ||
5569 | {name = "P27", | |
5570 | goal = [ | |
5571 | ||
5572 | QUOTE "\n(?x. p x /\\ ~q x) /\\ (!x. p x ==> r x) /\\ (!x. u x /\\ s x ==> p x) /\\\n(?x. r x /\\ ~q x) ==> (!x. u x ==> ~r x) ==> !x. u x ==> ~s x"]}, | |
5573 | ||
5574 | {name = "P28", | |
5575 | goal = [ | |
5576 | ||
5577 | QUOTE "\n(!x. p x ==> !x. q x) /\\ ((!x. q x \\/ r x) ==> ?x. q x /\\ r x) /\\\n((?x. r x) ==> !x. l x ==> m x) ==> !x. p x /\\ l x ==> m x"]}, | |
5578 | ||
5579 | {name = "P29", | |
5580 | goal = [ | |
5581 | ||
5582 | ||
5583 | QUOTE "\n(?x. p x) /\\ (?x. g x) ==>\n((!x. p x ==> h x) /\\ (!x. g x ==> j x) <=>\n !x y. p x /\\ g y ==> h x /\\ j y)"]}, | |
5584 | ||
5585 | {name = "P30", | |
5586 | goal = [ | |
5587 | ||
5588 | QUOTE "\n(!x. p x \\/ g x ==> ~h x) /\\ (!x. (g x ==> ~u x) ==> p x /\\ h x) ==>\n!x. u x"]}, | |
5589 | ||
5590 | {name = "P31", | |
5591 | goal = [ | |
5592 | ||
5593 | QUOTE "\n~(?x. p x /\\ (g x \\/ h x)) /\\ (?x. q x /\\ p x) /\\ (!x. ~h x ==> j x) ==>\n?x. q x /\\ j x"]}, | |
5594 | ||
5595 | {name = "P32", | |
5596 | goal = [ | |
5597 | ||
5598 | QUOTE "\n(!x. p x /\\ (g x \\/ h x) ==> q x) /\\ (!x. q x /\\ h x ==> j x) /\\\n(!x. r x ==> h x) ==> !x. p x /\\ r x ==> j x"]}, | |
5599 | ||
5600 | {name = "P33", | |
5601 | goal = [ | |
5602 | ||
5603 | QUOTE "\n(!x. p a /\\ (p x ==> p b) ==> p c) <=>\n(!x. p a ==> p x \\/ p c) /\\ (p a ==> p b ==> p c)"]}, | |
5604 | ||
5605 | (* This gives rise to 5184 clauses when converted to CNF! *) | |
5606 | {name = "P34", | |
5607 | goal = [ | |
5608 | ||
5609 | QUOTE "\n((?x. !y. p x <=> p y) <=> (?x. q x) <=> !y. q y) <=>\n(?x. !y. q x <=> q y) <=> (?x. p x) <=> !y. p y"]}, | |
5610 | ||
5611 | {name = "P35", | |
5612 | goal = [ | |
5613 | QUOTE "\n?x y. p x y ==> !x y. p x y"]}, | |
5614 | ||
5615 | (* ------------------------------------------------------------------------- *) | |
5616 | (* Full predicate logic (without Identity and Functions) *) | |
5617 | (* ------------------------------------------------------------------------- *) | |
5618 | ||
5619 | {name = "P36", | |
5620 | goal = [ | |
5621 | ||
5622 | QUOTE "\n(!x. ?y. p x y) /\\ (!x. ?y. g x y) /\\\n(!x y. p x y \\/ g x y ==> !z. p y z \\/ g y z ==> h x z) ==> !x. ?y. h x y"]}, | |
5623 | ||
5624 | {name = "P37", | |
5625 | goal = [ | |
5626 | ||
5627 | ||
5628 | QUOTE "\n(!z. ?w. !x. ?y. (p x z ==> p y w) /\\ p y z /\\ (p y w ==> ?v. q v w)) /\\\n(!x z. ~p x z ==> ?y. q y z) /\\ ((?x y. q x y) ==> !x. r x x) ==>\n!x. ?y. r x y"]}, | |
5629 | ||
5630 | {name = "P38", | |
5631 | goal = [ | |
5632 | ||
5633 | ||
5634 | ||
5635 | QUOTE "\n(!x. p a /\\ (p x ==> ?y. p y /\\ r x y) ==> ?z w. p z /\\ r x w /\\ r w z) <=>\n!x.\n (~p a \\/ p x \\/ ?z w. p z /\\ r x w /\\ r w z) /\\\n (~p a \\/ ~(?y. p y /\\ r x y) \\/ ?z w. p z /\\ r x w /\\ r w z)"]}, | |
5636 | ||
5637 | {name = "P39", | |
5638 | goal = [ | |
5639 | QUOTE "\n~?x. !y. p y x <=> ~p y y"]}, | |
5640 | ||
5641 | {name = "P40", | |
5642 | goal = [ | |
5643 | QUOTE "\n(?y. !x. p x y <=> p x x) ==> ~!x. ?y. !z. p z y <=> ~p z x"]}, | |
5644 | ||
5645 | {name = "P41", | |
5646 | goal = [ | |
5647 | QUOTE "\n(!z. ?y. !x. p x y <=> p x z /\\ ~p x x) ==> ~?z. !x. p x z"]}, | |
5648 | ||
5649 | {name = "P42", | |
5650 | goal = [ | |
5651 | QUOTE "\n~?y. !x. p x y <=> ~?z. p x z /\\ p z x"]}, | |
5652 | ||
5653 | {name = "P43", | |
5654 | goal = [ | |
5655 | QUOTE "\n(!x y. q x y <=> !z. p z x <=> p z y) ==> !x y. q x y <=> q y x"]}, | |
5656 | ||
5657 | {name = "P44", | |
5658 | goal = [ | |
5659 | ||
5660 | QUOTE "\n(!x. p x ==> (?y. g y /\\ h x y) /\\ ?y. g y /\\ ~h x y) /\\\n(?x. j x /\\ !y. g y ==> h x y) ==> ?x. j x /\\ ~p x"]}, | |
5661 | ||
5662 | {name = "P45", | |
5663 | goal = [ | |
5664 | ||
5665 | ||
5666 | ||
5667 | QUOTE "\n(!x. p x /\\ (!y. g y /\\ h x y ==> j x y) ==> !y. g y /\\ h x y ==> r y) /\\\n~(?y. l y /\\ r y) /\\\n(?x. p x /\\ (!y. h x y ==> l y) /\\ !y. g y /\\ h x y ==> j x y) ==>\n?x. p x /\\ ~?y. g y /\\ h x y"]}, | |
5668 | ||
5669 | {name = "P46", | |
5670 | goal = [ | |
5671 | ||
5672 | ||
5673 | QUOTE "\n(!x. p x /\\ (!y. p y /\\ h y x ==> g y) ==> g x) /\\\n((?x. p x /\\ ~g x) ==> ?x. p x /\\ ~g x /\\ !y. p y /\\ ~g y ==> j x y) /\\\n(!x y. p x /\\ p y /\\ h x y ==> ~j y x) ==> !x. p x ==> g x"]}, | |
5674 | ||
5675 | {name = "P50", | |
5676 | goal = [ | |
5677 | QUOTE "\n(!x. f0 a x \\/ !y. f0 x y) ==> ?x. !y. f0 x y"]}, | |
5678 | ||
5679 | (* ------------------------------------------------------------------------- *) | |
5680 | (* Example from Manthey and Bry, CADE-9. *) | |
5681 | (* ------------------------------------------------------------------------- *) | |
5682 | ||
5683 | {name = "P55", | |
5684 | goal = [ | |
5685 | ||
5686 | ||
5687 | ||
5688 | ||
5689 | ||
5690 | ||
5691 | ||
5692 | ||
5693 | QUOTE "\nlives agatha /\\ lives butler /\\ lives charles /\\\n(killed agatha agatha \\/ killed butler agatha \\/ killed charles agatha) /\\\n(!x y. killed x y ==> hates x y /\\ ~richer x y) /\\\n(!x. hates agatha x ==> ~hates charles x) /\\\n(hates agatha agatha /\\ hates agatha charles) /\\\n(!x. lives x /\\ ~richer x agatha ==> hates butler x) /\\\n(!x. hates agatha x ==> hates butler x) /\\\n(!x. ~hates x agatha \\/ ~hates x butler \\/ ~hates x charles) ==>\nkilled agatha agatha /\\ ~killed butler agatha /\\ ~killed charles agatha"]}, | |
5694 | ||
5695 | {name = "P57", | |
5696 | goal = [ | |
5697 | ||
5698 | QUOTE "\np (f a b) (f b c) /\\ p (f b c) (f a c) /\\\n(!x y z. p x y /\\ p y z ==> p x z) ==> p (f a b) (f a c)"]}, | |
5699 | ||
5700 | (* ------------------------------------------------------------------------- *) | |
5701 | (* See info-hol, circa 1500. *) | |
5702 | (* ------------------------------------------------------------------------- *) | |
5703 | ||
5704 | {name = "P58", | |
5705 | goal = [ | |
5706 | QUOTE "\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]}, | |
5707 | ||
5708 | {name = "P59", | |
5709 | goal = [ | |
5710 | QUOTE "\n(!x. p x <=> ~p (f x)) ==> ?x. p x /\\ ~p (f x)"]}, | |
5711 | ||
5712 | {name = "P60", | |
5713 | goal = [ | |
5714 | QUOTE "\n!x. p x (f x) <=> ?y. (!z. p z y ==> p z (f x)) /\\ p x y"]}, | |
5715 | ||
5716 | (* ------------------------------------------------------------------------- *) | |
5717 | (* From Gilmore's classic paper. *) | |
5718 | (* ------------------------------------------------------------------------- *) | |
5719 | ||
5720 | (* | |
5721 | JRH: Amazingly, this still seems non-trivial... in HOL it works at depth 45! | |
5722 | Joe: Confirmed (depth=45, inferences=263702, time=148s), though if lemmaizing | |
5723 | is used then a lemma is discovered at depth 29 that allows a much quicker | |
5724 | proof (depth=30, inferences=10039, time=5.5s). [13 Oct 2001] | |
5725 | *) | |
5726 | {name = "GILMORE_1", | |
5727 | goal = [ | |
5728 | ||
5729 | ||
5730 | QUOTE "\n?x. !y z.\n (f y ==> g y <=> f x) /\\ (f y ==> h y <=> g x) /\\\n ((f y ==> g y) ==> h y <=> h x) ==> f z /\\ g z /\\ h z"]}, | |
5731 | ||
5732 | (* | |
5733 | JRH: This is not valid, according to Gilmore | |
5734 | {name = "GILMORE_2", | |
5735 | goal = ` | |
5736 | ?x y. !z. | |
5737 | (f x z <=> f z y) /\ (f z y <=> f z z) /\ (f x y <=> f y x) ==> | |
5738 | (f x y <=> f x z)`}, | |
5739 | *) | |
5740 | ||
5741 | {name = "GILMORE_3", | |
5742 | goal = [ | |
5743 | ||
5744 | ||
5745 | QUOTE "\n?x. !y z.\n ((f y z ==> g y ==> h x) ==> f x x) /\\ ((f z x ==> g x) ==> h z) /\\\n f x y ==> f z z"]}, | |
5746 | ||
5747 | {name = "GILMORE_4", | |
5748 | goal = [ | |
5749 | QUOTE "\n?x y. !z. (f x y ==> f y z /\\ f z z) /\\ (f x y /\\ g x y ==> g x z /\\ g z z)"]}, | |
5750 | ||
5751 | {name = "GILMORE_5", | |
5752 | goal = [ | |
5753 | QUOTE "\n(!x. ?y. f x y \\/ f y x) /\\ (!x y. f y x ==> f y y) ==> ?z. f z z"]}, | |
5754 | ||
5755 | {name = "GILMORE_6", | |
5756 | goal = [ | |
5757 | ||
5758 | ||
5759 | ||
5760 | QUOTE "\n!x. ?y.\n (?w. !v. f w x ==> g v w /\\ g w x) ==>\n (?w. !v. f w y ==> g v w /\\ g w y) \\/\n !z v. ?w. g v z \\/ h w y z ==> g z w"]}, | |
5761 | ||
5762 | {name = "GILMORE_7", | |
5763 | goal = [ | |
5764 | ||
5765 | QUOTE "\n(!x. k x ==> ?y. l y /\\ (f x y ==> g x y)) /\\\n(?z. k z /\\ !w. l w ==> f z w) ==> ?v w. k v /\\ l w /\\ g v w"]}, | |
5766 | ||
5767 | {name = "GILMORE_8", | |
5768 | goal = [ | |
5769 | ||
5770 | ||
5771 | QUOTE "\n?x. !y z.\n ((f y z ==> g y ==> !w. ?v. h w v x) ==> f x x) /\\\n ((f z x ==> g x) ==> !w. ?v. h w v z) /\\ f x y ==> f z z"]}, | |
5772 | ||
5773 | (* | |
5774 | JRH: This is still a very hard goal | |
5775 | Joe: With lemmaizing (in HOL): (depth=18, inferences=15632, time=21s) | |
5776 | Without: gave up waiting after (depth=25, inferences=2125072, time=3000s) | |
5777 | [13 Oct 2001] | |
5778 | *) | |
5779 | {name = "GILMORE_9", | |
5780 | goal = [ | |
5781 | ||
5782 | ||
5783 | ||
5784 | ||
5785 | ||
5786 | ||
5787 | ||
5788 | QUOTE "\n!x. ?y. !z.\n ((!w. ?v. f y w v /\\ g y w /\\ ~h y x) ==>\n (!w. ?v. f x w v /\\ g z u /\\ ~h x z) ==>\n !w. ?v. f x w v /\\ g y w /\\ ~h x y) /\\\n ((!w. ?v. f x w v /\\ g y w /\\ ~h x y) ==>\n ~(!w. ?v. f x w v /\\ g z w /\\ ~h x z) ==>\n (!w. ?v. f y w v /\\ g y w /\\ ~h y x) /\\\n !w. ?v. f z w v /\\ g y w /\\ ~h z y)"]}, | |
5789 | ||
5790 | (* ------------------------------------------------------------------------- *) | |
5791 | (* Translation of Gilmore procedure using separate definitions. *) | |
5792 | (* ------------------------------------------------------------------------- *) | |
5793 | ||
5794 | {name = "GILMORE_9a", | |
5795 | goal = [ | |
5796 | ||
5797 | ||
5798 | QUOTE "\n(!x y. p x y <=> !w. ?v. f x w v /\\ g y w /\\ ~h x y) ==>\n!x. ?y. !z.\n (p y x ==> p x z ==> p x y) /\\ (p x y ==> ~p x z ==> p y x /\\ p z y)"]}, | |
5799 | ||
5800 | (* ------------------------------------------------------------------------- *) | |
5801 | (* Example from Davis-Putnam papers where Gilmore procedure is poor. *) | |
5802 | (* ------------------------------------------------------------------------- *) | |
5803 | ||
5804 | {name = "DAVIS_PUTNAM_EXAMPLE", | |
5805 | goal = [ | |
5806 | QUOTE "\n?x y. !z. (f x y ==> f y z /\\ f z z) /\\ (f x y /\\ g x y ==> g x z /\\ g z z)"]}, | |
5807 | ||
5808 | (* ------------------------------------------------------------------------- *) | |
5809 | (* The interesting example where connections make the proof longer. *) | |
5810 | (* ------------------------------------------------------------------------- *) | |
5811 | ||
5812 | {name = "BAD_CONNECTIONS", | |
5813 | goal = [ | |
5814 | ||
5815 | QUOTE "\n~a /\\ (a \\/ b) /\\ (c \\/ d) /\\ (~b \\/ e \\/ f) /\\ (~c \\/ ~e) /\\ (~c \\/ ~f) /\\\n(~b \\/ g \\/ h) /\\ (~d \\/ ~g) /\\ (~d \\/ ~h) ==> F"]}, | |
5816 | ||
5817 | (* ------------------------------------------------------------------------- *) | |
5818 | (* The classic Los puzzle. (Clausal version MSC006-1 in the TPTP library.) *) | |
5819 | (* Note: this is actually in the decidable "AE" subset, though that doesn't *) | |
5820 | (* yield a very efficient proof. *) | |
5821 | (* ------------------------------------------------------------------------- *) | |
5822 | ||
5823 | {name = "LOS", | |
5824 | goal = [ | |
5825 | ||
5826 | ||
5827 | QUOTE "\n(!x y z. p x y ==> p y z ==> p x z) /\\\n(!x y z. q x y ==> q y z ==> q x z) /\\ (!x y. q x y ==> q y x) /\\\n(!x y. p x y \\/ q x y) ==> (!x y. p x y) \\/ !x y. q x y"]}, | |
5828 | ||
5829 | (* ------------------------------------------------------------------------- *) | |
5830 | (* The steamroller. *) | |
5831 | (* ------------------------------------------------------------------------- *) | |
5832 | ||
5833 | {name = "STEAM_ROLLER", | |
5834 | goal = [ | |
5835 | ||
5836 | ||
5837 | ||
5838 | ||
5839 | ||
5840 | ||
5841 | ||
5842 | ||
5843 | ||
5844 | ||
5845 | ||
5846 | ||
5847 | QUOTE "\n((!x. p1 x ==> p0 x) /\\ ?x. p1 x) /\\ ((!x. p2 x ==> p0 x) /\\ ?x. p2 x) /\\\n((!x. p3 x ==> p0 x) /\\ ?x. p3 x) /\\ ((!x. p4 x ==> p0 x) /\\ ?x. p4 x) /\\\n((!x. p5 x ==> p0 x) /\\ ?x. p5 x) /\\ ((?x. q1 x) /\\ !x. q1 x ==> q0 x) /\\\n(!x.\n p0 x ==>\n (!y. q0 y ==> r x y) \\/\n !y. p0 y /\\ s0 y x /\\ (?z. q0 z /\\ r y z) ==> r x y) /\\\n(!x y. p3 y /\\ (p5 x \\/ p4 x) ==> s0 x y) /\\\n(!x y. p3 x /\\ p2 y ==> s0 x y) /\\ (!x y. p2 x /\\ p1 y ==> s0 x y) /\\\n(!x y. p1 x /\\ (p2 y \\/ q1 y) ==> ~r x y) /\\\n(!x y. p3 x /\\ p4 y ==> r x y) /\\ (!x y. p3 x /\\ p5 y ==> ~r x y) /\\\n(!x. p4 x \\/ p5 x ==> ?y. q0 y /\\ r x y) ==>\n?x y. p0 x /\\ p0 y /\\ ?z. q1 z /\\ r y z /\\ r x y"]}, | |
5848 | ||
5849 | (* ------------------------------------------------------------------------- *) | |
5850 | (* An incestuous example used to establish completeness characterization. *) | |
5851 | (* ------------------------------------------------------------------------- *) | |
5852 | ||
5853 | {name = "MODEL_COMPLETENESS", | |
5854 | goal = [ | |
5855 | ||
5856 | ||
5857 | ||
5858 | ||
5859 | ||
5860 | ||
5861 | ||
5862 | ||
5863 | QUOTE "\n(!w x. sentence x ==> holds w x \\/ holds w (not x)) /\\\n(!w x. ~(holds w x /\\ holds w (not x))) ==>\n((!x.\n sentence x ==>\n (!w. models w s ==> holds w x) \\/\n !w. models w s ==> holds w (not x)) <=>\n !w v.\n models w s /\\ models v s ==>\n !x. sentence x ==> (holds w x <=> holds v x))"]} | |
5864 | ||
5865 | ]; | |
5866 | ||
5867 | (* ========================================================================= *) | |
5868 | (* Problems with equality. *) | |
5869 | (* ========================================================================= *) | |
5870 | ||
5871 | val equality = [ | |
5872 | ||
5873 | (* ------------------------------------------------------------------------- *) | |
5874 | (* Trivia (some of which demonstrate ex-bugs in the prover). *) | |
5875 | (* ------------------------------------------------------------------------- *) | |
5876 | ||
5877 | {name = "REFLEXIVITY", | |
5878 | goal = [ | |
5879 | QUOTE "\nc = c"]}, | |
5880 | ||
5881 | {name = "SYMMETRY", | |
5882 | goal = [ | |
5883 | QUOTE "\n!x y. x = y ==> y = x"]}, | |
5884 | ||
5885 | {name = "TRANSITIVITY", | |
5886 | goal = [ | |
5887 | QUOTE "\n!x y z. x = y /\\ y = z ==> x = z"]}, | |
5888 | ||
5889 | {name = "TRANS_SYMM", | |
5890 | goal = [ | |
5891 | QUOTE "\n!x y z. x = y /\\ y = z ==> z = x"]}, | |
5892 | ||
5893 | {name = "SUBSTITUTIVITY", | |
5894 | goal = [ | |
5895 | QUOTE "\n!x y. f x /\\ x = y ==> f y"]}, | |
5896 | ||
5897 | {name = "CYCLIC_SUBSTITUTION_BUG", | |
5898 | goal = [ | |
5899 | QUOTE "\n(!x. y = g (c x)) ==> ?z. y = g z"]}, | |
5900 | ||
5901 | (* ------------------------------------------------------------------------- *) | |
5902 | (* Simple equality problems. *) | |
5903 | (* ------------------------------------------------------------------------- *) | |
5904 | ||
5905 | {name = "P48", | |
5906 | goal = [ | |
5907 | QUOTE "\n(a = b \\/ c = d) /\\ (a = c \\/ b = d) ==> a = d \\/ b = c"]}, | |
5908 | ||
5909 | {name = "P49", | |
5910 | goal = [ | |
5911 | QUOTE "\n(?x y. !z. z = x \\/ z = y) /\\ p a /\\ p b /\\ ~(a = b) ==> !x. p x"]}, | |
5912 | ||
5913 | {name = "P51", | |
5914 | goal = [ | |
5915 | ||
5916 | QUOTE "\n(?z w. !x y. f0 x y <=> x = z /\\ y = w) ==>\n?z. !x. (?w. !y. f0 x y <=> y = w) <=> x = z"]}, | |
5917 | ||
5918 | {name = "P52", | |
5919 | goal = [ | |
5920 | ||
5921 | QUOTE "\n(?z w. !x y. f0 x y <=> x = z /\\ y = w) ==>\n?w. !y. (?z. !x. f0 x y <=> x = z) <=> y = w"]}, | |
5922 | ||
5923 | (* ------------------------------------------------------------------------- *) | |
5924 | (* The Melham problem after an inverse skolemization step. *) | |
5925 | (* ------------------------------------------------------------------------- *) | |
5926 | ||
5927 | {name = "UNSKOLEMIZED_MELHAM", | |
5928 | goal = [ | |
5929 | QUOTE "\n(!x y. g x = g y ==> f x = f y) ==> !y. ?w. !x. y = g x ==> w = f x"]}, | |
5930 | ||
5931 | (* ------------------------------------------------------------------------- *) | |
5932 | (* The example always given for congruence closure. *) | |
5933 | (* ------------------------------------------------------------------------- *) | |
5934 | ||
5935 | {name = "CONGRUENCE_CLOSURE_EXAMPLE", | |
5936 | goal = [ | |
5937 | QUOTE "\n!x. f (f (f (f (f x)))) = x /\\ f (f (f x)) = x ==> f x = x"]}, | |
5938 | ||
5939 | (* ------------------------------------------------------------------------- *) | |
5940 | (* A simple example (see EWD1266a and the application to Morley's theorem). *) | |
5941 | (* ------------------------------------------------------------------------- *) | |
5942 | ||
5943 | {name = "EWD", | |
5944 | goal = [ | |
5945 | ||
5946 | QUOTE "\n(!x. f x ==> g x) /\\ (?x. f x) /\\ (!x y. g x /\\ g y ==> x = y) ==>\n!y. g y ==> f y"]}, | |
5947 | ||
5948 | {name = "EWD'", | |
5949 | goal = [ | |
5950 | QUOTE "\n(!x. f (f x) = f x) /\\ (!x. ?y. f y = x) ==> !x. f x = x"]}, | |
5951 | ||
5952 | (* ------------------------------------------------------------------------- *) | |
5953 | (* Wishnu Prasetya's example. *) | |
5954 | (* ------------------------------------------------------------------------- *) | |
5955 | ||
5956 | {name = "WISHNU", | |
5957 | goal = [ | |
5958 | ||
5959 | QUOTE "\n(?x. x = f (g x) /\\ !x'. x' = f (g x') ==> x = x') <=>\n?y. y = g (f y) /\\ !y'. y' = g (f y') ==> y = y'"]}, | |
5960 | ||
5961 | (* ------------------------------------------------------------------------- *) | |
5962 | (* An equality version of the Agatha puzzle. *) | |
5963 | (* ------------------------------------------------------------------------- *) | |
5964 | ||
5965 | {name = "AGATHA", | |
5966 | goal = [ | |
5967 | ||
5968 | ||
5969 | ||
5970 | ||
5971 | ||
5972 | ||
5973 | ||
5974 | ||
5975 | ||
5976 | QUOTE "\n(?x. lives x /\\ killed x agatha) /\\\n(lives agatha /\\ lives butler /\\ lives charles) /\\\n(!x. lives x ==> x = agatha \\/ x = butler \\/ x = charles) /\\\n(!x y. killed x y ==> hates x y) /\\ (!x y. killed x y ==> ~richer x y) /\\\n(!x. hates agatha x ==> ~hates charles x) /\\\n(!x. ~(x = butler) ==> hates agatha x) /\\\n(!x. ~richer x agatha ==> hates butler x) /\\\n(!x. hates agatha x ==> hates butler x) /\\ (!x. ?y. ~hates x y) /\\\n~(agatha = butler) ==>\nkilled agatha agatha /\\ ~killed butler agatha /\\ ~killed charles agatha"]}, | |
5977 | ||
5978 | (* ------------------------------------------------------------------------- *) | |
5979 | (* Group theory examples. *) | |
5980 | (* ------------------------------------------------------------------------- *) | |
5981 | ||
5982 | (* JRH: (Size 18, 61814 seconds.) *) | |
5983 | {name = "GROUP_RIGHT_INVERSE", | |
5984 | goal = [ | |
5985 | ||
5986 | QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\\n(!x. i x * x = e) ==> !x. x * i x = e"]}, | |
5987 | ||
5988 | {name = "GROUP_RIGHT_IDENTITY", | |
5989 | goal = [ | |
5990 | ||
5991 | QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\\n(!x. i x * x = e) ==> !x. x * e = x"]}, | |
5992 | ||
5993 | {name = "KLEIN_GROUP_COMMUTATIVE", | |
5994 | goal = [ | |
5995 | ||
5996 | QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\ (!x. x * e = x) /\\\n(!x. x * x = e) ==> !x y. x * y = y * x"]} | |
5997 | ||
5998 | ]; | |
5999 | ||
6000 | (* ========================================================================= *) | |
6001 | (* Some sample problems from the TPTP archive. *) | |
6002 | (* Note: for brevity some relation/function names have been shortened. *) | |
6003 | (* ========================================================================= *) | |
6004 | ||
6005 | val tptp = [ | |
6006 | ||
6007 | (* ------------------------------------------------------------------------- *) | |
6008 | (* TPTP problems that have demonstrated bugs in the prover. *) | |
6009 | (* ------------------------------------------------------------------------- *) | |
6010 | ||
6011 | (* Solved trivially by meson without cache cutting, but not with. *) | |
6012 | {name = "PUZ011-1", | |
6013 | goal = [ | |
6014 | ||
6015 | ||
6016 | ||
6017 | ||
6018 | ||
6019 | ||
6020 | ||
6021 | ||
6022 | ||
6023 | ||
6024 | ||
6025 | QUOTE "\nocean atlantic /\\ ocean indian /\\ borders atlantic brazil /\\\nborders atlantic uruguay /\\ borders atlantic c_venesuela /\\\nborders atlantic c_zaire /\\ borders atlantic nigeria /\\\nborders atlantic angola /\\ borders indian india /\\\nborders indian pakistan /\\ borders indian iran /\\ borders indian somalia /\\\nborders indian kenya /\\ borders indian tanzania /\\ south_american brazil /\\\nsouth_american uruguay /\\ south_american c_venesuela /\\ african c_zaire /\\\nafrican nigeria /\\ african angola /\\ african somalia /\\ african kenya /\\\nafrican tanzania /\\ asian india /\\ asian pakistan /\\ asian iran ==>\n(!x y z.\n ~ocean x \\/ ~borders x y \\/ ~african y \\/ ~borders x z \\/ ~asian z) ==>\nF"]}, | |
6026 | ||
6027 | (* ------------------------------------------------------------------------- *) | |
6028 | (* Problems used by the fol unit test to exercise the TPTP parser. *) | |
6029 | (* ------------------------------------------------------------------------- *) | |
6030 | ||
6031 | {name = "PUZ001-1", | |
6032 | goal = [ | |
6033 | ||
6034 | ||
6035 | ||
6036 | ||
6037 | ||
6038 | ||
6039 | ||
6040 | ||
6041 | QUOTE "\nlives agatha /\\ lives butler /\\ lives charles /\\\n(!x y. ~killed x y \\/ ~richer x y) /\\\n(!x. ~hates agatha x \\/ ~hates charles x) /\\\n(!x. ~hates x agatha \\/ ~hates x butler \\/ ~hates x charles) /\\\nhates agatha agatha /\\ hates agatha charles /\\\n(!x y. ~killed x y \\/ hates x y) /\\\n(!x. ~hates agatha x \\/ hates butler x) /\\\n(!x. ~lives x \\/ richer x agatha \\/ hates butler x) ==>\nkilled butler agatha \\/ killed charles agatha ==> F"]}, | |
6042 | ||
6043 | {name = "PUZ020-1", | |
6044 | goal = [ | |
6045 | ||
6046 | ||
6047 | ||
6048 | ||
6049 | ||
6050 | ||
6051 | ||
6052 | ||
6053 | ||
6054 | ||
6055 | ||
6056 | ||
6057 | ||
6058 | ||
6059 | ||
6060 | ||
6061 | ||
6062 | ||
6063 | ||
6064 | ||
6065 | ||
6066 | ||
6067 | ||
6068 | ||
6069 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. ~(x = y) \\/ statement_by x = statement_by y) /\\\n(!x. ~person x \\/ knight x \\/ knave x) /\\\n(!x. ~person x \\/ ~knight x \\/ ~knave x) /\\\n(!x y. ~says x y \\/ a_truth y \\/ ~a_truth y) /\\\n(!x y. ~says x y \\/ ~(x = y)) /\\ (!x y. ~says x y \\/ y = statement_by x) /\\\n(!x y. ~person x \\/ ~(x = statement_by y)) /\\\n(!x. ~person x \\/ ~a_truth (statement_by x) \\/ knight x) /\\\n(!x. ~person x \\/ a_truth (statement_by x) \\/ knave x) /\\\n(!x y. ~(x = y) \\/ ~knight x \\/ knight y) /\\\n(!x y. ~(x = y) \\/ ~knave x \\/ knave y) /\\\n(!x y. ~(x = y) \\/ ~person x \\/ person y) /\\\n(!x y z. ~(x = y) \\/ ~says x z \\/ says y z) /\\\n(!x y z. ~(x = y) \\/ ~says z x \\/ says z y) /\\\n(!x y. ~(x = y) \\/ ~a_truth x \\/ a_truth y) /\\\n(!x y. ~knight x \\/ ~says x y \\/ a_truth y) /\\\n(!x y. ~knave x \\/ ~says x y \\/ ~a_truth y) /\\ person husband /\\\nperson c_wife /\\ ~(husband = c_wife) /\\\nsays husband (statement_by husband) /\\\n(~a_truth (statement_by husband) \\/ ~knight husband \\/ knight c_wife) /\\\n(a_truth (statement_by husband) \\/ ~knight husband) /\\\n(a_truth (statement_by husband) \\/ knight c_wife) /\\\n(~knight c_wife \\/ a_truth (statement_by husband)) ==> ~knight husband ==>\nF"]}, | |
6070 | ||
6071 | {name = "NUM001-1", | |
6072 | goal = [ | |
6073 | ||
6074 | ||
6075 | ||
6076 | ||
6077 | ||
6078 | ||
6079 | ||
6080 | ||
6081 | QUOTE "\n(!x. x == x) /\\ (!x y z. ~(x == y) \\/ ~(y == z) \\/ x == z) /\\\n(!x y. x + y == y + x) /\\ (!x y z. x + (y + z) == x + y + z) /\\\n(!x y. x + y - y == x) /\\ (!x y. x == x + y - y) /\\\n(!x y z. x - y + z == x + z - y) /\\ (!x y z. x + y - z == x - z + y) /\\\n(!x y z v. ~(x == y) \\/ ~(z == x + v) \\/ z == y + v) /\\\n(!x y z v. ~(x == y) \\/ ~(z == v + x) \\/ z == v + y) /\\\n(!x y z v. ~(x == y) \\/ ~(z == x - v) \\/ z == y - v) /\\\n(!x y z v. ~(x == y) \\/ ~(z == v - x) \\/ z == v - y) ==>\n~(a + b + c == a + (b + c)) ==> F"]}, | |
6082 | ||
6083 | {name = "ALG005-1", | |
6084 | goal = [ | |
6085 | ||
6086 | ||
6087 | ||
6088 | ||
6089 | ||
6090 | ||
6091 | ||
6092 | ||
6093 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y. x + (y + x) = x) /\\\n(!x y. x + (x + y) = y + (y + x)) /\\\n(!x y z. x + y + z = x + z + (y + z)) /\\ (!x y. x * y = x + (x + y)) ==>\n~(a * b * c = a * (b * c)) ==> F"]}, | |
6094 | ||
6095 | {name = "GRP057-1", | |
6096 | goal = [ | |
6097 | ||
6098 | ||
6099 | ||
6100 | ||
6101 | ||
6102 | ||
6103 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z v. x * i (i (i y * (i x * z)) * v * i (y * v)) = z) /\\\n(!x y. ~(x = y) \\/ i x = i y) /\\ (!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) ==>\n~(i a1 * a1 = i b1 * b1) \\/ ~(i b2 * b2 * a2 = a2) \\/\n~(a3 * b3 * c3 = a3 * (b3 * c3)) ==> F"]}, | |
6104 | ||
6105 | {name = "LCL009-1", | |
6106 | goal = [ | |
6107 | ||
6108 | ||
6109 | QUOTE "\n(!x y. ~p (x - y) \\/ ~p x \\/ p y) /\\\n(!x y z. p (x - y - (z - y - (x - z)))) ==>\n~p (a - b - c - (a - (b - c))) ==> F"]}, | |
6110 | ||
6111 | (* ------------------------------------------------------------------------- *) | |
6112 | (* Small problems that are tricky to prove. *) | |
6113 | (* ------------------------------------------------------------------------- *) | |
6114 | ||
6115 | {name = "COL060-3", | |
6116 | goal = [ | |
6117 | ||
6118 | ||
6119 | ||
6120 | ||
6121 | ||
6122 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. b % x % y % z = x % (y % z)) /\\ (!x y. t % x % y = y % x) /\\\n(!x y z. ~(x = y) \\/ x % z = y % z) /\\\n(!x y z. ~(x = y) \\/ z % x = z % y) ==>\n~(b % (b % (t % b) % b) % t % c_x % c_y % c_z = c_y % (c_x % c_z)) ==> F"]}, | |
6123 | ||
6124 | {name = "COL058-2", | |
6125 | goal = [ | |
6126 | ||
6127 | ||
6128 | ||
6129 | ||
6130 | ||
6131 | ||
6132 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. r (r 0 x) y = r x (r y y)) /\\ (!x y z. ~(x = y) \\/ r x z = r y z) /\\\n(!x y z. ~(x = y) \\/ r z x = r z y) ==>\n~(r (r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0)))\n (r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0))) =\n r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0))) ==> F"]}, | |
6133 | ||
6134 | {name = "LCL107-1", | |
6135 | goal = [ | |
6136 | ||
6137 | ||
6138 | ||
6139 | ||
6140 | QUOTE "\n(!x y. ~p (x - y) \\/ ~p x \\/ p y) /\\\n(!x y z v w x' y'.\n p\n (x - y - z - (v - w - (x' - w - (x' - v) - y')) -\n (z - (y - x - y')))) ==> ~p (a - b - c - (e - b - (a - e - c))) ==> F"]}, | |
6141 | ||
6142 | {name = "LDA007-3", | |
6143 | goal = [ | |
6144 | ||
6145 | ||
6146 | ||
6147 | ||
6148 | ||
6149 | ||
6150 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. f x (f y z) = f (f x y) (f x z)) /\\\n(!x y z. ~(x = y) \\/ f x z = f y z) /\\\n(!x y z. ~(x = y) \\/ f z x = f z y) /\\ tt = f t t /\\ ts = f t s /\\\ntt_ts = f tt ts /\\ tk = f t k /\\ tsk = f ts k ==>\n~(f t tsk = f tt_ts tk) ==> F"]}, | |
6151 | ||
6152 | {name = "GRP010-4", | |
6153 | goal = [ | |
6154 | ||
6155 | ||
6156 | ||
6157 | ||
6158 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x y. ~(x = y) \\/ i x = i y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y z. x * y * z = x * (y * z)) /\\\n(!x. 1 * x = x) /\\ (!x. i x * x = 1) /\\ c * b = 1 ==> ~(b * c = 1) ==> F"]}, | |
6159 | ||
6160 | {name = "ALG006-1", | |
6161 | goal = [ | |
6162 | ||
6163 | ||
6164 | ||
6165 | ||
6166 | ||
6167 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. x + (y + x) = x) /\\\n(!x y. x + (x + y) = y + (y + x)) /\\\n(!x y z. x + y + z = x + z + (y + z)) ==> ~(a + c + b = a + b + c) ==> F"]}, | |
6168 | ||
6169 | {name = "BOO021-1", | |
6170 | goal = [ | |
6171 | ||
6172 | ||
6173 | ||
6174 | ||
6175 | ||
6176 | ||
6177 | ||
6178 | ||
6179 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ i x = i y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y. (x + y) * y = y) /\\\n(!x y z. x * (y + z) = y * x + z * x) /\\ (!x. x + i x = 1) /\\\n(!x y. x * y + y = y) /\\ (!x y z. x + y * z = (y + x) * (z + x)) /\\\n(!x. x * i x = 0) ==> ~(b * a = a * b) ==> F"]}, | |
6180 | ||
6181 | {name = "GEO002-4", | |
6182 | goal = [ | |
6183 | ||
6184 | ||
6185 | ||
6186 | ||
6187 | ||
6188 | ||
6189 | ||
6190 | ||
6191 | ||
6192 | ||
6193 | ||
6194 | QUOTE "\n(!x y z v. ~between x y z \\/ ~between y v z \\/ between x y v) /\\\n(!x y z. ~equidistant x y z z \\/ x == y) /\\\n(!x y z v w.\n ~between x y z \\/ ~between v z w \\/\n between x (outer_pasch y x v w z) v) /\\\n(!x y z v w.\n ~between x y z \\/ ~between v z w \\/\n between w y (outer_pasch y x v w z)) /\\\n(!x y z v. between x y (extension x y z v)) /\\\n(!x y z v. equidistant x (extension y x z v) z v) /\\\n(!x y z v. ~(x == y) \\/ ~between z v x \\/ between z v y) ==>\n~between a a b ==> F"]}, | |
6195 | ||
6196 | {name = "GRP057-1", | |
6197 | goal = [ | |
6198 | ||
6199 | ||
6200 | ||
6201 | ||
6202 | ||
6203 | ||
6204 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z v. x * i (i (i y * (i x * z)) * v * i (y * v)) = z) /\\\n(!x y. ~(x = y) \\/ i x = i y) /\\ (!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) ==>\n~(i a1 * a1 = i b1 * b1) \\/ ~(i b2 * b2 * a2 = a2) \\/\n~(a3 * b3 * c3 = a3 * (b3 * c3)) ==> F"]}, | |
6205 | ||
6206 | {name = "HEN006-3", | |
6207 | goal = [ | |
6208 | ||
6209 | ||
6210 | ||
6211 | ||
6212 | ||
6213 | ||
6214 | ||
6215 | ||
6216 | ||
6217 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. ~(x <= y) \\/ x / y = 0) /\\ (!x y. ~(x / y = 0) \\/ x <= y) /\\\n(!x y. x / y <= x) /\\ (!x y z. x / y / (z / y) <= x / z / y) /\\\n(!x. 0 <= x) /\\ (!x y. ~(x <= y) \\/ ~(y <= x) \\/ x = y) /\\ (!x. x <= 1) /\\\n(!x y z. ~(x = y) \\/ x / z = y / z) /\\\n(!x y z. ~(x = y) \\/ z / x = z / y) /\\\n(!x y z. ~(x = y) \\/ ~(x <= z) \\/ y <= z) /\\\n(!x y z. ~(x = y) \\/ ~(z <= x) \\/ z <= y) /\\ a / b <= d ==>\n~(a / d <= b) ==> F"]}, | |
6218 | ||
6219 | {name = "RNG035-7", | |
6220 | goal = [ | |
6221 | ||
6222 | ||
6223 | ||
6224 | ||
6225 | ||
6226 | ||
6227 | ||
6228 | ||
6229 | ||
6230 | ||
6231 | ||
6232 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x. 0 + x = x) /\\\n(!x. x + 0 = x) /\\ (!x. n x + x = 0) /\\ (!x. x + n x = 0) /\\\n(!x y z. x + (y + z) = x + y + z) /\\ (!x y. x + y = y + x) /\\\n(!x y z. x * (y * z) = x * y * z) /\\\n(!x y z. x * (y + z) = x * y + x * z) /\\\n(!x y z. (x + y) * z = x * z + y * z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ n x = n y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x. x * (x * (x * x)) = x) ==>\na * b = c /\\ ~(b * a = c) ==> F"]}, | |
6233 | ||
6234 | {name = "ROB001-1", | |
6235 | goal = [ | |
6236 | ||
6237 | ||
6238 | ||
6239 | ||
6240 | ||
6241 | ||
6242 | QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x y. x + y = y + x) /\\\n(!x y z. x + y + z = x + (y + z)) /\\\n(!x y. n (n (x + y) + n (x + n y)) = x) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ n x = n y) ==>\n~(n (a + n b) + n (n a + n b) = b) ==> F"]}, | |
6243 | ||
6244 | {name = "GRP128-4.003", | |
6245 | goal = [ | |
6246 | ||
6247 | ||
6248 | ||
6249 | ||
6250 | ||
6251 | ||
6252 | ||
6253 | ||
6254 | ||
6255 | ||
6256 | ||
6257 | ||
6258 | ||
6259 | ||
6260 | ||
6261 | ||
6262 | QUOTE "\n(!x y.\n ~elt x \\/ ~elt y \\/ product e_1 x y \\/ product e_2 x y \\/\n product e_3 x y) /\\\n(!x y.\n ~elt x \\/ ~elt y \\/ product x e_1 y \\/ product x e_2 y \\/\n product x e_3 y) /\\ elt e_1 /\\ elt e_2 /\\ elt e_3 /\\ ~(e_1 == e_2) /\\\n~(e_1 == e_3) /\\ ~(e_2 == e_1) /\\ ~(e_2 == e_3) /\\ ~(e_3 == e_1) /\\\n~(e_3 == e_2) /\\\n(!x y.\n ~elt x \\/ ~elt y \\/ product x y e_1 \\/ product x y e_2 \\/\n product x y e_3) /\\\n(!x y z v. ~product x y z \\/ ~product x y v \\/ z == v) /\\\n(!x y z v. ~product x y z \\/ ~product x v z \\/ y == v) /\\\n(!x y z v. ~product x y z \\/ ~product v y z \\/ x == v) ==>\n(!x y z v. product x y z \\/ ~product x z v \\/ ~product z y v) /\\\n(!x y z v. product x y z \\/ ~product v x z \\/ ~product v y x) /\\\n(!x y z v. ~product x y z \\/ ~product z y v \\/ product x z v) ==> F"]}, | |
6263 | ||
6264 | {name = "NUM014-1", | |
6265 | goal = [ | |
6266 | ||
6267 | ||
6268 | ||
6269 | ||
6270 | ||
6271 | ||
6272 | QUOTE "\n(!x. product x x (square x)) /\\\n(!x y z. ~product x y z \\/ product y x z) /\\\n(!x y z. ~product x y z \\/ divides x z) /\\\n(!x y z v.\n ~prime x \\/ ~product y z v \\/ ~divides x v \\/ divides x y \\/\n divides x z) /\\ prime a /\\ product a (square c) (square b) ==>\n~divides a b ==> F"]} | |
6273 | ||
6274 | ]; | |
6275 | ||
6276 | (* ========================================================================= *) | |
6277 | (* A FEW SAMPLE THEOREMS TO CHECK LARGE RUNS *) | |
6278 | (* ========================================================================= *) | |
6279 | ||
6280 | (* val quick = | |
6281 | * [extract nonequality "TRUE", | |
6282 | * extract nonequality "P_or_not_P", | |
6283 | * extract nonequality "JH_test", | |
6284 | * extract nonequality "CYCLIC", | |
6285 | * extract nonequality "MN_bug", | |
6286 | * extract nonequality "ERIC", | |
6287 | * extract nonequality "MATHS4_EXAMPLE", | |
6288 | * extract nonequality "P18", | |
6289 | * extract nonequality "P39", | |
6290 | * extract nonequality "P59", | |
6291 | * extract nonequality "DAVIS_PUTNAM_EXAMPLE", | |
6292 | * extract nonequality "BAD_CONNECTIONS", | |
6293 | * | |
6294 | * extract equality "TRANS_SYMM", | |
6295 | * extract equality "CYCLIC_SUBSTITUTION_BUG", | |
6296 | * extract equality "P48"]; | |
6297 | *) | |
6298 | end | |
6299 | (*#line 0.0 "src/Meter1.sig"*) | |
6300 | (* ========================================================================= *) | |
6301 | (* METERING TIME AND INFERENCES *) | |
6302 | (* Created by Joe Hurd, November 2001 *) | |
6303 | (* ========================================================================= *) | |
6304 | ||
6305 | signature Meter1 = | |
6306 | sig | |
6307 | ||
6308 | type 'a pp = 'a Useful.pp | |
6309 | ||
6310 | (* Search limits *) | |
6311 | type limit = {time : real option, infs : int option} | |
6312 | val unlimited : limit | |
6313 | val expired : limit | |
6314 | val limit_to_string : limit -> string | |
6315 | ||
6316 | (* Meter readings *) | |
6317 | type meter_reading = {time : real, infs : int} | |
6318 | val zero_reading : meter_reading | |
6319 | val add_readings : meter_reading -> meter_reading -> meter_reading | |
6320 | val pp_meter_reading : meter_reading pp | |
6321 | val meter_reading_to_string : meter_reading -> string | |
6322 | ||
6323 | (* Meters record time and inferences *) | |
6324 | type meter | |
6325 | val new_meter : limit -> meter | |
6326 | val sub_meter : meter -> limit -> meter | |
6327 | val record_infs : meter -> int -> unit | |
6328 | val read_meter : meter -> meter_reading | |
6329 | val check_meter : meter -> bool | |
6330 | val pp_meter : meter pp | |
6331 | ||
6332 | end | |
6333 | (*#line 0.0 "src/Meter1.sml"*) | |
6334 | (* ========================================================================= *) | |
6335 | (* METERING TIME AND INFERENCES *) | |
6336 | (* Created by Joe Hurd, November 2001 *) | |
6337 | (* ========================================================================= *) | |
6338 | ||
6339 | (* | |
6340 | app load | |
6341 | ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"]; | |
6342 | *) | |
6343 | ||
6344 | (* | |
6345 | *) | |
6346 | structure Meter1 :> Meter1 = | |
6347 | struct | |
6348 | ||
6349 | open Useful; | |
6350 | ||
6351 | infix |-> ::> @> oo ## ::* ::@; | |
6352 | ||
6353 | (* ------------------------------------------------------------------------- *) | |
6354 | (* Search limits *) | |
6355 | (* ------------------------------------------------------------------------- *) | |
6356 | ||
6357 | type limit = {time : real option, infs : int option}; | |
6358 | ||
6359 | val unlimited = {time = NONE, infs = NONE}; | |
6360 | ||
6361 | val expired = {time = SOME 0.0, infs = SOME 0}; | |
6362 | ||
6363 | fun limit_to_string {time, infs} = | |
6364 | "{time = " ^ | |
6365 | (case time of NONE => "unlimited" | |
6366 | | SOME r => Real.fmt (StringCvt.FIX (SOME 3)) r ^ "s") ^ | |
6367 | ", infs = " ^ | |
6368 | (case infs of NONE => "unlimited" | SOME i => int_to_string i) ^ | |
6369 | "}"; | |
6370 | ||
6371 | (* ------------------------------------------------------------------------- *) | |
6372 | (* Meter readings. *) | |
6373 | (* ------------------------------------------------------------------------- *) | |
6374 | ||
6375 | type meter_reading = {time : real, infs : int}; | |
6376 | ||
6377 | val zero_reading = {time = 0.0, infs = 0}; | |
6378 | ||
6379 | fun add_readings {time : real, infs} {time = time', infs = infs'} = | |
6380 | {time = time + time', infs = infs + infs'}; | |
6381 | ||
6382 | fun pp_meter_reading pp {time, infs} = | |
6383 | let | |
6384 | open PP | |
6385 | val () = begin_block pp INCONSISTENT 1 | |
6386 | val () = add_string pp "{"; | |
6387 | val () = begin_block pp INCONSISTENT 2 | |
6388 | val () = add_string pp "time =" | |
6389 | val () = add_break pp (1, 0) | |
6390 | val () = add_string pp (Real.fmt (StringCvt.FIX (SOME 3)) time) | |
6391 | val () = end_block pp | |
6392 | val () = add_string pp "," | |
6393 | val () = add_break pp (1, 0) | |
6394 | val () = begin_block pp INCONSISTENT 2 | |
6395 | val () = add_string pp "infs =" | |
6396 | val () = add_break pp (1, 0) | |
6397 | val () = pp_int pp infs | |
6398 | val () = end_block pp | |
6399 | val () = add_string pp "}" | |
6400 | val () = end_block pp | |
6401 | in | |
6402 | () | |
6403 | end; | |
6404 | ||
6405 | fun meter_reading_to_string r = | |
6406 | PP.pp_to_string (!LINE_LENGTH) pp_meter_reading r; | |
6407 | ||
6408 | (* ------------------------------------------------------------------------- *) | |
6409 | (* Meters record time and inferences. *) | |
6410 | (* ------------------------------------------------------------------------- *) | |
6411 | ||
6412 | type meter = {read : unit -> meter_reading, log : (int -> unit), lim : limit}; | |
6413 | ||
6414 | fun new_time_meter () = | |
6415 | let | |
6416 | val tmr = Timer.startCPUTimer () | |
6417 | fun read () = | |
6418 | (fn {usr, sys, ...} => Time.toReal (Time.+ (usr, sys))) | |
6419 | (Timer.checkCPUTimer tmr) | |
6420 | in | |
6421 | read | |
6422 | end; | |
6423 | ||
6424 | fun new_inference_meter () = | |
6425 | let | |
6426 | val infs = ref 0 | |
6427 | fun read () = !infs | |
6428 | in | |
6429 | (read, fn n => infs := !infs + n) | |
6430 | end; | |
6431 | ||
6432 | fun new_meter lim : meter = | |
6433 | let | |
6434 | val tread = new_time_meter () | |
6435 | val (iread, ilog) = new_inference_meter () | |
6436 | in | |
6437 | {read = (fn () => {time = tread (), infs = iread ()}), | |
6438 | log = ilog, lim = lim} | |
6439 | end; | |
6440 | ||
6441 | fun sub_meter {read, log, lim = _} lim = | |
6442 | let | |
6443 | val {time = init_time : real, infs = init_infs} = read () | |
6444 | fun sub {time, infs} = {time = time - init_time, infs = infs - init_infs} | |
6445 | in | |
6446 | {read = sub o read, log = log, lim = lim} | |
6447 | end; | |
6448 | ||
6449 | val read_meter = fn ({read, ...} : meter) => read (); | |
6450 | ||
6451 | val check_meter = fn ({read, lim = {time, infs}, ...} : meter) => | |
6452 | let | |
6453 | val {time = t, infs = i} = read () | |
6454 | in | |
6455 | (case time of NONE => true | SOME time => t < time) andalso | |
6456 | (case infs of NONE => true | SOME infs => i < infs) | |
6457 | end; | |
6458 | ||
6459 | val record_infs = fn ({log, ...} : meter) => log; | |
6460 | ||
6461 | val pp_meter = pp_map read_meter pp_meter_reading; | |
6462 | ||
6463 | end | |
6464 | (*#line 0.0 "src/Solver1.sig"*) | |
6465 | (* ========================================================================= *) | |
6466 | (* PACKAGING UP SOLVERS TO ALLOW THEM TO COOPERATE UNIFORMLY *) | |
6467 | (* Created by Joe Hurd, March 2002 *) | |
6468 | (* ========================================================================= *) | |
6469 | ||
6470 | signature Solver1 = | |
6471 | sig | |
6472 | ||
6473 | type 'a pp = 'a Useful.pp | |
6474 | type 'a stream = 'a Stream.stream | |
6475 | type formula = Term1.formula | |
6476 | type thm = Thm1.thm | |
6477 | type limit = Meter1.limit | |
6478 | type meter = Meter1.meter | |
6479 | type meter_reading = Meter1.meter_reading | |
6480 | type units = Units1.units | |
6481 | ||
6482 | (* The type of a generic solver *) | |
6483 | ||
6484 | type solver = formula list -> thm list option stream | |
6485 | ||
6486 | val contradiction_solver : thm -> solver | |
6487 | ||
6488 | (* Filters to cut off searching or drop subsumed solutions *) | |
6489 | ||
6490 | val solved_filter : solver -> solver | |
6491 | val subsumed_filter : solver -> solver | |
6492 | ||
6493 | (* User-friendly interface to generic solvers *) | |
6494 | ||
6495 | val solve : solver -> formula list -> thm list list | |
6496 | val find : solver -> formula list -> thm list option | |
6497 | val refute : solver -> thm option | |
6498 | ||
6499 | (* Solver nodes must construct themselves from the following form. *) | |
6500 | ||
6501 | type form = | |
6502 | {slice : meter ref, (* A meter to stop after each slice *) | |
6503 | units : units ref, (* Solvers share a unit cache *) | |
6504 | thms : thm list, (* Context, assumed consistent *) | |
6505 | hyps : thm list} (* Hypothesis, or set of support *) | |
6506 | ||
6507 | (* Solver nodes also incorporate a name. *) | |
6508 | ||
6509 | type node_data = {name : string, solver_con : form -> solver} | |
6510 | type solver_node | |
6511 | ||
6512 | val mk_solver_node : node_data -> solver_node | |
6513 | val pp_solver_node : solver_node pp | |
6514 | ||
6515 | (* At each step we schedule a time slice to the least cost solver node. *) | |
6516 | ||
6517 | val SLICE : limit ref | |
6518 | ||
6519 | type cost_fn = meter_reading -> real | |
6520 | ||
6521 | val time1 : cost_fn (* Time taken (in seconds) *) | |
6522 | val time2 : cost_fn (* Time squared *) | |
6523 | val infs1 : cost_fn (* Number of inferences made*) | |
6524 | val infs2 : cost_fn (* Inferences squared *) | |
6525 | ||
6526 | (* This allows us to hierarchically arrange solver nodes. *) | |
6527 | ||
6528 | val combine : (cost_fn * solver_node) list -> solver_node | |
6529 | ||
6530 | (* Overriding the 'natural' set of support from the problem. *) | |
6531 | ||
6532 | val set_of_support : (thm -> bool) -> solver_node -> solver_node | |
6533 | val everything : thm -> bool | |
6534 | val one_negative : thm -> bool | |
6535 | val one_positive : thm -> bool | |
6536 | val all_negative : thm -> bool (* This one is used by Metis1.prove *) | |
6537 | val all_positive : thm -> bool | |
6538 | val nothing : thm -> bool | |
6539 | ||
6540 | (* Initializing a solver node makes it ready for action. *) | |
6541 | ||
6542 | type init_data = {limit : limit, thms : thm list, hyps : thm list} | |
6543 | ||
6544 | val initialize : solver_node -> init_data -> solver | |
6545 | ||
6546 | end | |
6547 | (*#line 0.0 "src/Solver1.sml"*) | |
6548 | (* ========================================================================= *) | |
6549 | (* PACKAGING UP SOLVERS TO ALLOW THEM TO COOPERATE UNIFORMLY *) | |
6550 | (* Created by Joe Hurd, March 2002 *) | |
6551 | (* ========================================================================= *) | |
6552 | ||
6553 | (* | |
6554 | app load | |
6555 | ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1", "Meter1", "Units1", | |
6556 | "Solver1"]; | |
6557 | *) | |
6558 | ||
6559 | (* | |
6560 | *) | |
6561 | structure Solver1 :> Solver1 = | |
6562 | struct | |
6563 | ||
6564 | open Useful Term1 Match1 Thm1 Meter1; | |
6565 | ||
6566 | infix |-> ::> @> oo ##; | |
6567 | ||
6568 | structure S = Stream; | |
6569 | structure U = Units1; | |
6570 | ||
6571 | type 'a stream = 'a S.stream; | |
6572 | type units = U.units; | |
6573 | ||
6574 | val |<>| = Subst1.|<>|; | |
6575 | val op ::> = Subst1.::>; | |
6576 | ||
6577 | (* ------------------------------------------------------------------------- *) | |
6578 | (* Chatting. *) | |
6579 | (* ------------------------------------------------------------------------- *) | |
6580 | ||
6581 | val () = traces := {module = "Solver1", alignment = K 1} :: !traces; | |
6582 | ||
6583 | fun chat l m = trace {module = "Solver1", message = m, level = l}; | |
6584 | ||
6585 | (* ------------------------------------------------------------------------- *) | |
6586 | (* Helper functions. *) | |
6587 | (* ------------------------------------------------------------------------- *) | |
6588 | ||
6589 | fun drop_after f = | |
6590 | S.fold (fn x => fn xs => S.CONS (x, if f x then K S.NIL else xs)) S.NIL; | |
6591 | ||
6592 | fun time_to_string t = | |
6593 | let val dp = if t < 10.0 then 2 else if t < 1000.0 then 1 else 0 | |
6594 | in Real.fmt (StringCvt.FIX (SOME dp)) t | |
6595 | end; | |
6596 | ||
6597 | fun infs_to_string i = | |
6598 | if i < 10000 then int_to_string i | |
6599 | else if i < 10000000 then int_to_string (i div 1000) ^ "K" | |
6600 | else int_to_string (i div 1000000) ^ "M"; | |
6601 | ||
6602 | val name_to_string = str o hd o explode; | |
6603 | ||
6604 | fun option_case n _ NONE = n | |
6605 | | option_case _ s (SOME _) = s; | |
6606 | ||
6607 | (* ------------------------------------------------------------------------- *) | |
6608 | (* The type of a generic solver. *) | |
6609 | (* ------------------------------------------------------------------------- *) | |
6610 | ||
6611 | type solver = formula list -> thm list option stream; | |
6612 | ||
6613 | local | |
6614 | fun contr th [False] = [th] | |
6615 | | contr th gs = map (C CONTR th) gs; | |
6616 | in | |
6617 | fun contradiction_solver th = | |
6618 | (assert (is_contradiction th) (ERR "contradiction_solver" "thm not |- F"); | |
6619 | fn gs => S.CONS (SOME (contr th gs), K S.NIL)); | |
6620 | end; | |
6621 | ||
6622 | (* ------------------------------------------------------------------------- *) | |
6623 | (* Filters to cut off searching or drop subsumed solutions. *) | |
6624 | (* ------------------------------------------------------------------------- *) | |
6625 | ||
6626 | local | |
6627 | fun concl [] = False | |
6628 | | concl [lit] = lit | |
6629 | | concl _ = raise BUG "concl" "not a literal"; | |
6630 | in | |
6631 | fun solved_filter solver goals = | |
6632 | let | |
6633 | fun solves goals' = can (matchl_literals |<>|) (zip goals' goals) | |
6634 | fun final NONE = false | |
6635 | | final (SOME ths) = solves (map (concl o clause) ths) | |
6636 | in | |
6637 | drop_after final (solver goals) | |
6638 | end; | |
6639 | end; | |
6640 | ||
6641 | local | |
6642 | fun munge s n = "MUNGED__" ^ int_to_string n ^ "__" ^ s; | |
6643 | fun munge_lit (n, Atom (Fn (p, a))) = Atom (Fn (munge p n, a)) | |
6644 | | munge_lit (n, Not (Atom (Fn (p, a)))) = Not (Atom (Fn (munge p n, a))) | |
6645 | | munge_lit _ = raise BUG "munge_lit" "bad literal"; | |
6646 | fun distinctivize fms = map munge_lit (enumerate 0 fms); | |
6647 | fun advance NONE s = (SOME NONE, s) | |
6648 | | advance (SOME ths) s = | |
6649 | let | |
6650 | val fms = distinctivize (List.mapPartial (total dest_unit) ths) | |
6651 | in | |
6652 | if non null (Subsume1.subsumed s fms) then (NONE, s) | |
6653 | else (SOME (SOME ths), Subsume1.add (fms |-> ()) s) | |
6654 | end | |
6655 | handle ERR_EXN _ => raise BUG "advance" "shouldn't fail"; | |
6656 | in | |
6657 | fun subsumed_filter s g = S.partial_maps advance Subsume1.empty (s g); | |
6658 | end; | |
6659 | ||
6660 | (* ------------------------------------------------------------------------- *) | |
6661 | (* User-friendly interface to generic solvers *) | |
6662 | (* ------------------------------------------------------------------------- *) | |
6663 | ||
6664 | fun raw_solve s = S.partial_map I o (subsumed_filter (solved_filter s)); | |
6665 | ||
6666 | fun solve s = S.to_list o (raw_solve s); | |
6667 | ||
6668 | fun find s = (fn S.NIL => NONE | S.CONS (x, _) => SOME x) o raw_solve s; | |
6669 | ||
6670 | fun refute s = Option.map unwrap (find s [False]); | |
6671 | ||
6672 | (* ------------------------------------------------------------------------- *) | |
6673 | (* Solver nodes must construct themselves from the following form. *) | |
6674 | (* ------------------------------------------------------------------------- *) | |
6675 | ||
6676 | type form = | |
6677 | {slice : meter ref, (* A meter to stop after each slice *) | |
6678 | units : units ref, (* Solvers share a unit cache *) | |
6679 | thms : thm list, (* Context, assumed consistent *) | |
6680 | hyps : thm list}; (* Hypothesis, no assumptions *) | |
6681 | ||
6682 | (* ------------------------------------------------------------------------- *) | |
6683 | (* Solver nodes also incorporate a name. *) | |
6684 | (* ------------------------------------------------------------------------- *) | |
6685 | ||
6686 | type node_data = {name : string, solver_con : form -> solver}; | |
6687 | ||
6688 | datatype solver_node = | |
6689 | Solver_node of {name : string, initial : string, solver_con : form -> solver}; | |
6690 | ||
6691 | fun mk_solver_node {name, solver_con} = | |
6692 | Solver_node | |
6693 | {name = name, initial = (str o hd o explode) name, solver_con = solver_con}; | |
6694 | ||
6695 | val pp_solver_node = pp_map (fn Solver_node {name, ...} => name) pp_string; | |
6696 | ||
6697 | (* ------------------------------------------------------------------------- *) | |
6698 | (* At each step we schedule a time slice to the least cost solver node. *) | |
6699 | (* ------------------------------------------------------------------------- *) | |
6700 | ||
6701 | val SLICE : limit ref = ref {time = SOME (1.0 / 3.0), infs = NONE}; | |
6702 | ||
6703 | type cost_fn = Meter1.meter_reading -> real; | |
6704 | ||
6705 | local | |
6706 | fun sq x : real = x * x; | |
6707 | in | |
6708 | val time1 : cost_fn = fn {time, ...} => time; | |
6709 | val time2 : cost_fn = fn {time, ...} => sq time; | |
6710 | val infs1 : cost_fn = fn {infs, ...} => Real.fromInt infs; | |
6711 | val infs2 : cost_fn = fn {infs, ...} => sq (Real.fromInt infs); | |
6712 | end; | |
6713 | ||
6714 | (* ------------------------------------------------------------------------- *) | |
6715 | (* This allows us to hierarchically arrange solver nodes. *) | |
6716 | (* ------------------------------------------------------------------------- *) | |
6717 | ||
6718 | local | |
6719 | fun name (Solver_node {name, ...}) = name; | |
6720 | fun initial (Solver_node {initial, ...}) = initial; | |
6721 | fun seq f [] = "" | |
6722 | | seq f (h :: t) = foldl (fn (n, s) => s ^ "," ^ f n) (f h) t; | |
6723 | in | |
6724 | fun combine_names csolvers = "[" ^ seq (name o snd) csolvers ^ "]"; | |
6725 | fun combine_initials csolvers = "[" ^ seq (initial o snd) csolvers ^ "]"; | |
6726 | end; | |
6727 | ||
6728 | datatype subnode = Subnode of | |
6729 | {name : string, | |
6730 | used : meter_reading, | |
6731 | cost : meter_reading -> real, | |
6732 | solns : (unit -> thm list option stream) option}; | |
6733 | ||
6734 | fun init_subnode (cost, (name, solver : solver)) goal = | |
6735 | Subnode | |
6736 | {name = name, | |
6737 | used = zero_reading, | |
6738 | cost = cost, | |
6739 | solns = SOME (fn () => solver goal)}; | |
6740 | ||
6741 | fun least_cost [] = K NONE | |
6742 | | least_cost _ = | |
6743 | (SOME o snd o min (fn (r, _) => fn (s, _) => r <= s) o | |
6744 | map (fn (n, Subnode {used, cost, ...}) => (cost used, n))) | |
6745 | ||
6746 | val choose_subnode = | |
6747 | W least_cost o | |
6748 | List.filter (fn (_, Subnode {solns, ...}) => Option.isSome solns) o | |
6749 | enumerate 0; | |
6750 | ||
6751 | fun subnode_info (Subnode {name, used = {time, infs}, solns, ...}) = | |
6752 | name_to_string name ^ "(" ^ time_to_string time ^ "," ^ | |
6753 | infs_to_string infs ^ ")" ^ (case solns of NONE => "*" | SOME _ => ""); | |
6754 | ||
6755 | local | |
6756 | fun seq f [] = "" | |
6757 | | seq f (h :: t) = foldl (fn (n, s) => s ^ "--" ^ f n) (f h) t; | |
6758 | in | |
6759 | fun status_info subnodes units = | |
6760 | "[" ^ seq subnode_info subnodes ^ "]--u=" ^ U.info units ^ "--"; | |
6761 | end; | |
6762 | ||
6763 | fun schedule check read stat = | |
6764 | let | |
6765 | fun sched nodes = | |
6766 | (chat 2 (stat nodes); | |
6767 | if not (check ()) then | |
6768 | (chat 1 "?\n"; S.CONS (NONE, fn () => sched nodes)) | |
6769 | else | |
6770 | case choose_subnode nodes of NONE => (chat 1 "!\n"; S.NIL) | |
6771 | | SOME n => | |
6772 | let | |
6773 | val Subnode {name, used, solns, cost} = List.nth (nodes, n) | |
6774 | val () = chat 1 name | |
6775 | val seq = (Option.valOf solns) () | |
6776 | val r = read () | |
6777 | val () = chat 2 ("--t=" ^ time_to_string (#time r) ^ "\n") | |
6778 | val used = add_readings used r | |
6779 | val (res, solns) = | |
6780 | case seq of S.NIL => (NONE, NONE) | S.CONS (a, r) => (a, SOME r) | |
6781 | val node = | |
6782 | Subnode {name = name, used = used, cost = cost, solns = solns} | |
6783 | val nodes = update_nth (K node) n nodes | |
6784 | val () = | |
6785 | case res of NONE => () | |
6786 | | SOME _ => (chat 2 (stat nodes); chat 1 "$\n") | |
6787 | in | |
6788 | S.CONS (res, fn () => sched nodes) | |
6789 | end) | |
6790 | in | |
6791 | sched | |
6792 | end; | |
6793 | ||
6794 | fun combine_solvers (n, i) csolvers {slice, units, thms, hyps} = | |
6795 | let | |
6796 | val () = chat 2 | |
6797 | (n ^ "--initializing--#thms=" ^ int_to_string (length thms) ^ | |
6798 | "--#hyps=" ^ int_to_string (length hyps) ^ ".\n") | |
6799 | val meter = ref (new_meter expired) | |
6800 | fun f (Solver_node {initial, solver_con, ...}) = | |
6801 | (initial, | |
6802 | solver_con {slice = meter, units = units, thms = thms, hyps = hyps}) | |
6803 | val cnodes = map (I ## f) csolvers | |
6804 | fun check () = | |
6805 | check_meter (!slice) andalso (meter := sub_meter (!slice) (!SLICE); true) | |
6806 | fun read () = read_meter (!meter) | |
6807 | fun stat s = status_info s (!units) | |
6808 | in | |
6809 | fn goal => schedule check read stat (map (C init_subnode goal) cnodes) | |
6810 | end; | |
6811 | ||
6812 | fun combine csolvers = | |
6813 | let | |
6814 | val n = combine_names csolvers | |
6815 | val i = combine_initials csolvers | |
6816 | in | |
6817 | Solver_node | |
6818 | {name = n, initial = i, solver_con = combine_solvers (n, i) csolvers} | |
6819 | end; | |
6820 | ||
6821 | (* ------------------------------------------------------------------------- *) | |
6822 | (* Overriding the 'natural' set of support from the problem. *) | |
6823 | (* ------------------------------------------------------------------------- *) | |
6824 | ||
6825 | fun sos_solver_con filt name solver_con {slice, units, thms, hyps} = | |
6826 | let | |
6827 | val () = chat 2 | |
6828 | (name ^ "--initializing--#thms=" ^ int_to_string (length thms) ^ | |
6829 | "--#hyps=" ^ int_to_string (length hyps) ^ ".\n") | |
6830 | val (hyps', thms') = List.partition filt (thms @ hyps) | |
6831 | in | |
6832 | solver_con {slice = slice, units = units, thms = thms', hyps = hyps'} | |
6833 | end; | |
6834 | ||
6835 | fun set_of_support filt (Solver_node {name, initial, solver_con}) = | |
6836 | let val name' = "!" ^ name | |
6837 | in | |
6838 | Solver_node | |
6839 | {name = name', initial = initial, | |
6840 | solver_con = sos_solver_con filt name' solver_con} | |
6841 | end; | |
6842 | ||
6843 | val everything : thm -> bool = K true; | |
6844 | ||
6845 | val one_negative = (fn x => null x orelse List.exists negative x) o clause; | |
6846 | ||
6847 | val one_positive = (fn x => null x orelse List.exists positive x) o clause; | |
6848 | ||
6849 | val all_negative = List.all negative o clause; | |
6850 | ||
6851 | val all_positive = List.all positive o clause; | |
6852 | ||
6853 | val nothing : thm -> bool = K false; | |
6854 | ||
6855 | (* ------------------------------------------------------------------------- *) | |
6856 | (* Initializing a solver node makes it ready for action. *) | |
6857 | (* ------------------------------------------------------------------------- *) | |
6858 | ||
6859 | type init_data = {limit : limit, thms : thm list, hyps : thm list} | |
6860 | ||
6861 | fun initialize (Solver_node {solver_con, ...}) {limit, thms, hyps} = | |
6862 | case List.find is_contradiction (thms @ hyps) of SOME th | |
6863 | => contradiction_solver th | |
6864 | | NONE => | |
6865 | let | |
6866 | val meter = ref (new_meter expired) | |
6867 | val units = ref U.empty | |
6868 | val solver = | |
6869 | solver_con {slice = meter, units = units, thms = thms, hyps = hyps} | |
6870 | in | |
6871 | fn g => | |
6872 | let val () = meter := new_meter limit | |
6873 | in drop_after (fn _ => not (check_meter (!meter))) (solver g) | |
6874 | end | |
6875 | end; | |
6876 | ||
6877 | end | |
6878 | (*#line 0.0 "src/Meson1.sig"*) | |
6879 | (* ========================================================================= *) | |
6880 | (* THE MESON PROOF PROCEDURE *) | |
6881 | (* Created by Joe Hurd, November 2001 *) | |
6882 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
6883 | (* ========================================================================= *) | |
6884 | ||
6885 | signature Meson1 = | |
6886 | sig | |
6887 | ||
6888 | type solver_node = Solver1.solver_node | |
6889 | ||
6890 | (* Tuning parameters *) | |
6891 | type parameters = | |
6892 | {ancestor_pruning : bool, | |
6893 | ancestor_cutting : bool, | |
6894 | state_simplify : bool, | |
6895 | cache_cutting : bool, | |
6896 | divide_conquer : bool, | |
6897 | unit_lemmaizing : bool} | |
6898 | ||
6899 | val defaults : parameters | |
6900 | ||
6901 | (* The meson solver *) | |
6902 | val meson' : parameters -> solver_node | |
6903 | val meson : solver_node (* Uses defaults *) | |
6904 | ||
6905 | (* The delta preprocessor as a solver *) | |
6906 | val delta' : parameters -> solver_node | |
6907 | val delta : solver_node (* Uses defaults *) | |
6908 | ||
6909 | (* The prolog solver *) | |
6910 | val prolog' : parameters -> solver_node | |
6911 | val prolog : solver_node (* Uses defaults *) | |
6912 | ||
6913 | end | |
6914 | (*#line 0.0 "src/Meson1.sml"*) | |
6915 | (* ========================================================================= *) | |
6916 | (* THE MESON PROOF PROCEDURE *) | |
6917 | (* Created by Joe Hurd, November 2001 *) | |
6918 | (* Partly ported from the CAML-Light code accompanying John Harrison's book *) | |
6919 | (* ========================================================================= *) | |
6920 | ||
6921 | (* | |
6922 | app load | |
6923 | ["Useful", "Stream", "Mosml", "Term1", "Thm1", "Canon1", "Match1", | |
6924 | "Solver1", "Meter1", "Units1"]; | |
6925 | *) | |
6926 | ||
6927 | (* | |
6928 | *) | |
6929 | structure Meson1 :> Meson1 = | |
6930 | struct | |
6931 | ||
6932 | open Useful Term1 Match1 Thm1 Canon1 Meter1 Solver1; | |
6933 | ||
6934 | infix |-> ::> @> oo ##; | |
6935 | ||
6936 | structure S = Stream; | |
6937 | structure N = LiteralNet1; | |
6938 | structure U = Units1; | |
6939 | ||
6940 | val |<>| = Subst1.|<>|; | |
6941 | val op ::> = Subst1.::>; | |
6942 | val formula_subst = Subst1.formula_subst; | |
6943 | ||
6944 | (* ------------------------------------------------------------------------- *) | |
6945 | (* Chatting. *) | |
6946 | (* ------------------------------------------------------------------------- *) | |
6947 | ||
6948 | val () = traces := {module = "Meson1", alignment = K 1} :: !traces; | |
6949 | ||
6950 | fun chat l m = trace {module = "Meson1", message = m, level = l}; | |
6951 | ||
6952 | (* ------------------------------------------------------------------------- *) | |
6953 | (* Tuning parameters. *) | |
6954 | (* ------------------------------------------------------------------------- *) | |
6955 | ||
6956 | type parameters = | |
6957 | {ancestor_pruning : bool, | |
6958 | ancestor_cutting : bool, | |
6959 | state_simplify : bool, | |
6960 | cache_cutting : bool, | |
6961 | divide_conquer : bool, | |
6962 | unit_lemmaizing : bool}; | |
6963 | ||
6964 | val defaults = | |
6965 | {ancestor_pruning = true, | |
6966 | ancestor_cutting = true, | |
6967 | state_simplify = true, | |
6968 | cache_cutting = true, | |
6969 | divide_conquer = true, | |
6970 | unit_lemmaizing = true}; | |
6971 | ||
6972 | (* ------------------------------------------------------------------------- *) | |
6973 | (* Helper functions. *) | |
6974 | (* ------------------------------------------------------------------------- *) | |
6975 | ||
6976 | fun halves n = let val n1 = n div 2 in (n1, n - n1) end; | |
6977 | ||
6978 | fun splittable [] = false | |
6979 | | splittable [_] = false | |
6980 | | splittable _ = true; | |
6981 | ||
6982 | (* | |
6983 | fun protect r f x = | |
6984 | let | |
6985 | val v = !r | |
6986 | val y = f x handle e as ERR_EXN _ => (r := v; raise e) | |
6987 | val () = r := v | |
6988 | in | |
6989 | y | |
6990 | end; | |
6991 | ||
6992 | fun until p = | |
6993 | let | |
6994 | open Stream | |
6995 | fun u NIL = NIL | |
6996 | | u (CONS (x, xs)) = CONS (x, if p x then K NIL else fn () => u (xs ())) | |
6997 | in | |
6998 | u | |
6999 | end; | |
7000 | *) | |
7001 | ||
7002 | local | |
7003 | val prefix = "_m"; | |
7004 | in | |
7005 | val mk_mvar = mk_prefix prefix o int_to_string; | |
7006 | fun mk_mvars n i = map (Var o mk_mvar) (interval n i); | |
7007 | val dest_mvar = string_to_int o dest_prefix prefix; | |
7008 | end; | |
7009 | ||
7010 | datatype 'a choice = CHOICE of unit -> 'a * 'a choice; | |
7011 | ||
7012 | fun dest_choice (CHOICE c) = c; | |
7013 | ||
7014 | val no_choice = (fn () => raise ERR "no_choice" "always fails"); | |
7015 | ||
7016 | fun binary_choice f g = | |
7017 | (fn () => | |
7018 | let val (a, c) = f () in (a, CHOICE (binary_choice (dest_choice c) g)) end | |
7019 | handle ERR_EXN _ => g ()); | |
7020 | ||
7021 | fun first_choice [] = no_choice | |
7022 | | first_choice [f] = f | |
7023 | | first_choice (f :: fs) = binary_choice f (first_choice fs); | |
7024 | ||
7025 | fun choice_stream f = | |
7026 | let val (a, CHOICE c) = f () in S.CONS (a, fn () => choice_stream c) end | |
7027 | handle ERR_EXN _ => S.NIL; | |
7028 | ||
7029 | fun swivel m n l = | |
7030 | let | |
7031 | val (l1, l') = split l m | |
7032 | val (l2, l3) = split l' n | |
7033 | in | |
7034 | l2 @ l1 @ l3 | |
7035 | end; | |
7036 | ||
7037 | fun thm_proves th False = is_contradiction th | |
7038 | | thm_proves th goal = | |
7039 | case clause th of [lit] => lit = goal | [] => true | _ => false; | |
7040 | ||
7041 | fun filter_meter meter = | |
7042 | S.filter (fn a => Option.isSome a orelse not (check_meter (!meter))); | |
7043 | ||
7044 | (* ------------------------------------------------------------------------- *) | |
7045 | (* Compiling the rule set used by meson. *) | |
7046 | (* ------------------------------------------------------------------------- *) | |
7047 | ||
7048 | type rule = {asms : formula list, c : formula, thm : thm, asmn : int}; | |
7049 | ||
7050 | datatype rules = Rules of rule N.literal_map; | |
7051 | ||
7052 | fun dest_rules (Rules r) = r; | |
7053 | val empty_rules = Rules N.empty; | |
7054 | val num_all_rules = N.size o dest_rules; | |
7055 | val num_initial_rules = #f o N.size_profile o dest_rules; | |
7056 | fun num_rules r = num_all_rules r - num_initial_rules r; | |
7057 | val rules_unify = N.unify o dest_rules; | |
7058 | ||
7059 | val pp_rules = | |
7060 | pp_map dest_rules | |
7061 | (N.pp_literal_map | |
7062 | (pp_map (fn {asms, c, ...} => (asms, c)) | |
7063 | (pp_binop " ==>" (pp_list pp_formula) pp_formula))); | |
7064 | ||
7065 | fun add_contrapositives chosen sos th (Rules ruls) = | |
7066 | let | |
7067 | val th = FRESH_VARS th | |
7068 | val lits = clause th | |
7069 | val lits' = map negate lits | |
7070 | val base = map (fn l => (subtract lits' [negate l], l)) (chosen lits) | |
7071 | val contrs = if sos then (lits', False) :: base else base | |
7072 | fun f (a, c) = c |-> {asms = a, c = c, thm = th, asmn = length a} | |
7073 | in | |
7074 | Rules (foldl (fn (h, t) => N.insert (f h) t) ruls contrs) | |
7075 | end; | |
7076 | ||
7077 | fun thms_to_rules chosen thms hyps = | |
7078 | let val f = uncurry o add_contrapositives chosen | |
7079 | in foldl (f true) (foldl (f false) empty_rules thms) hyps | |
7080 | end; | |
7081 | ||
7082 | val meson_rules = thms_to_rules I; | |
7083 | ||
7084 | val prolog_rules = thms_to_rules (wrap o hd); | |
7085 | ||
7086 | (* ------------------------------------------------------------------------- *) | |
7087 | (* Creating the delta goals. *) | |
7088 | (* ------------------------------------------------------------------------- *) | |
7089 | ||
7090 | val thms_to_delta_goals = | |
7091 | List.concat o | |
7092 | map (fn (f,n) => [Atom (Fn (f,new_vars n)), Not (Atom (Fn (f,new_vars n)))]) o | |
7093 | foldl (uncurry union) [] o | |
7094 | map relations o | |
7095 | List.concat o | |
7096 | map clause; | |
7097 | ||
7098 | (* ------------------------------------------------------------------------- *) | |
7099 | (* The state passed around by meson. *) | |
7100 | (* ------------------------------------------------------------------------- *) | |
7101 | ||
7102 | type state = {env : subst, depth : int, proof : thm list, offset : int}; | |
7103 | ||
7104 | fun update_env f ({env, depth, proof, offset} : state) = | |
7105 | {env = f env, depth = depth, proof = proof, offset = offset}; | |
7106 | ||
7107 | fun update_depth f ({env, depth, proof, offset} : state) = | |
7108 | {env = env, depth = f depth, proof = proof, offset = offset}; | |
7109 | ||
7110 | fun update_proof f ({env, depth, proof, offset} : state) = | |
7111 | {env = env, depth = depth, proof = f proof, offset = offset}; | |
7112 | ||
7113 | fun update_offset f ({env, depth, proof, offset} : state) = | |
7114 | {env = env, depth = depth, proof = proof, offset = f offset}; | |
7115 | ||
7116 | (* ------------------------------------------------------------------------- *) | |
7117 | (* Ancestor pruning. *) | |
7118 | (* ------------------------------------------------------------------------- *) | |
7119 | ||
7120 | fun ancestor_prune false _ _ = K false | |
7121 | | ancestor_prune true env g = | |
7122 | let | |
7123 | val g' = formula_subst env g | |
7124 | fun check a' = a' = g' | |
7125 | in | |
7126 | List.exists (check o formula_subst env) | |
7127 | end; | |
7128 | ||
7129 | (* ------------------------------------------------------------------------- *) | |
7130 | (* Ancestor cutting. *) | |
7131 | (* ------------------------------------------------------------------------- *) | |
7132 | ||
7133 | fun ancestor_cut false _ _ = K false | |
7134 | | ancestor_cut true env g = | |
7135 | let | |
7136 | val g' = negate (formula_subst env g) | |
7137 | fun check a' = a' = g' | |
7138 | in | |
7139 | List.exists (check o formula_subst env) | |
7140 | end; | |
7141 | ||
7142 | (* ------------------------------------------------------------------------- *) | |
7143 | (* Cache cutting. *) | |
7144 | (* ------------------------------------------------------------------------- *) | |
7145 | ||
7146 | fun cache_cont c ({offset, ...} : state) = | |
7147 | let | |
7148 | fun f v = case total dest_mvar v of NONE => true | SOME n => n < offset | |
7149 | val listify = Subst1.foldr (fn m as v |-> _ => if f v then cons m else I) [] | |
7150 | val mem = ref [] | |
7151 | fun purify (s as {env, depth = n, ...} : state) = | |
7152 | let | |
7153 | val l = listify env | |
7154 | fun p (n', l') = n <= n' andalso l = l' | |
7155 | in | |
7156 | if List.exists p (!mem) then raise ERR "cache_cut" "repetition" | |
7157 | else (mem := (n, l) :: (!mem); update_env (K (Subst1.from_maplets l)) s) | |
7158 | end | |
7159 | in | |
7160 | c o purify | |
7161 | end; | |
7162 | ||
7163 | fun cache_cut false = I | |
7164 | | cache_cut true = | |
7165 | fn f => fn a => fn g => fn c => fn s => f a g (cache_cont c s) s; | |
7166 | ||
7167 | (* ------------------------------------------------------------------------- *) | |
7168 | (* Unit clause shortcut. *) | |
7169 | (* ------------------------------------------------------------------------- *) | |
7170 | ||
7171 | fun grab_unit units (s as {proof = th :: _, ...} : state) = | |
7172 | (units := U.add th (!units); s) | |
7173 | | grab_unit _ {proof = [], ...} = raise BUG "grab_unit" "no thms"; | |
7174 | ||
7175 | fun use_unit units g c (s as {env, ...}) = | |
7176 | let val prove = partial (ERR "use_unit" "NONE") (U.prove (!units)) | |
7177 | in c (update_proof (cons (unwrap (prove [formula_subst env g]))) s) | |
7178 | end; | |
7179 | ||
7180 | fun unit_cut false _ = I | |
7181 | | unit_cut true units = | |
7182 | fn f => fn a => fn g => fn c => fn s => | |
7183 | use_unit units g c s handle ERR_EXN _ => f a g (c o grab_unit units) s; | |
7184 | ||
7185 | (* ------------------------------------------------------------------------- *) | |
7186 | (* The core of meson: ancestor unification or Prolog-style extension. *) | |
7187 | (* ------------------------------------------------------------------------- *) | |
7188 | ||
7189 | fun freshen_rule ({thm, asms, c, ...} : rule) i = | |
7190 | let | |
7191 | val fvs = FVL (c :: asms) | |
7192 | val fvn = length fvs | |
7193 | val mvs = mk_mvars i fvn | |
7194 | val sub = Subst1.from_maplets (zipwith (curry op|->) fvs mvs) | |
7195 | in | |
7196 | ((INST sub thm, map (formula_subst sub) asms, formula_subst sub c), i + fvn) | |
7197 | end; | |
7198 | ||
7199 | fun reward r = update_depth (fn n => n + r); | |
7200 | ||
7201 | fun spend m f c (s as {depth = n, ...} : state) = | |
7202 | let | |
7203 | val low = n - m | |
7204 | val () = assert (0 <= low) (ERR "meson" "impossible divide and conquer") | |
7205 | fun check (s' as {depth = n', ...} : state) = | |
7206 | if n' <= low then s' else raise ERR "meson" "divide and conquer" | |
7207 | in | |
7208 | f (c o check) s | |
7209 | end; | |
7210 | ||
7211 | local | |
7212 | fun unify env (th, asms, c) g = (th, asms, unify_literals env c g) | |
7213 | ||
7214 | fun match env (th, asms, c) g = | |
7215 | let val sub = match_literals c g | |
7216 | in (INST sub th, map (formula_subst sub) asms, env) | |
7217 | end; | |
7218 | in | |
7219 | fun next_state false env r g = unify env r g | |
7220 | | next_state true env r g = match env r g handle ERR_EXN _ => unify env r g; | |
7221 | end; | |
7222 | ||
7223 | local | |
7224 | fun mp _ th [] p = FACTOR th :: p | |
7225 | | mp env th (g :: gs) (th1 :: p) = | |
7226 | mp env (RESOLVE (formula_subst env g) (INST env th1) th) gs p | |
7227 | | mp _ _ (_ :: _) [] = raise BUG "modus_ponens" "fresh out of thms" | |
7228 | in | |
7229 | fun modus_ponens th gs (state as {env, ...}) = | |
7230 | update_proof (mp env (INST env th) (rev gs)) state; | |
7231 | end; | |
7232 | ||
7233 | fun swivelp m n = update_proof (swivel m n); | |
7234 | ||
7235 | fun meson_expand {parm : parameters, rules, cut, meter, saturated} = | |
7236 | let | |
7237 | fun expand ancestors g cont (state as {env, ...}) = | |
7238 | if not (check_meter (!meter)) then | |
7239 | (NONE, CHOICE (fn () => expand ancestors g cont state)) | |
7240 | else if ancestor_prune (#ancestor_pruning parm) env g ancestors then | |
7241 | raise ERR "meson" "ancestor pruning" | |
7242 | else if ancestor_cut (#ancestor_cutting parm) env g ancestors then | |
7243 | (record_infs (!meter) 1; cont (update_proof (cons (ASSUME g)) state)) | |
7244 | else | |
7245 | let | |
7246 | (*val () = print ("meson: " ^ formula_to_string g ^ ".\n")*) | |
7247 | fun reduction a () = | |
7248 | let | |
7249 | val state = update_env (K (unify_literals env g (negate a))) state | |
7250 | val state = update_proof (cons (ASSUME g)) state | |
7251 | in | |
7252 | (record_infs (!meter) 1; cont state) | |
7253 | end | |
7254 | val expansion = expand_rule ancestors g cont state | |
7255 | in | |
7256 | first_choice | |
7257 | (map reduction ancestors @ | |
7258 | map expansion (rules_unify rules (formula_subst env g))) () | |
7259 | end | |
7260 | and expand_rule ancestors g cont {env, depth, proof, offset} r () = | |
7261 | let | |
7262 | val depth = depth - #asmn r | |
7263 | val () = | |
7264 | if 0 <= depth then () | |
7265 | else (saturated := false; raise ERR "meson" "too deep") | |
7266 | val (r, offset) = freshen_rule r offset | |
7267 | val (th, asms, env) = next_state (#state_simplify parm) env r g | |
7268 | val () = record_infs (!meter) 1 | |
7269 | in | |
7270 | expands (g :: ancestors) asms (cont o modus_ponens th asms) | |
7271 | {env = env, depth = depth, proof = proof, offset = offset} | |
7272 | end | |
7273 | and expands ancestors g c (s as {depth = n, ...}) = | |
7274 | if #divide_conquer parm andalso splittable g then | |
7275 | let | |
7276 | val (l1, l2) = halves (length g) | |
7277 | val (g1, g2) = split g l1 | |
7278 | val (f1, f2) = Df (expands ancestors) (g1, g2) | |
7279 | val (n1, n2) = halves n | |
7280 | val s = update_depth (K n1) s | |
7281 | in | |
7282 | binary_choice | |
7283 | (fn () => f1 (f2 c o reward n2) s) | |
7284 | (fn () => f2 (spend (n1 + 1) f1 (c o swivelp l1 l2) o reward n2) s) () | |
7285 | end | |
7286 | else foldl (uncurry (cut expand ancestors)) c (rev g) s | |
7287 | in | |
7288 | cut expand [] | |
7289 | end; | |
7290 | ||
7291 | (* ------------------------------------------------------------------------- *) | |
7292 | (* Full meson procedure. *) | |
7293 | (* ------------------------------------------------------------------------- *) | |
7294 | ||
7295 | fun meson_finally g ({env, proof, ...} : state) = | |
7296 | let | |
7297 | val () = assert (length proof = length g) (BUG "meson" "bad final state") | |
7298 | val g' = map (formula_subst env) g | |
7299 | val proof' = map (INST env) (rev proof) | |
7300 | (*val () = (print "meson_finally: "; printVal (g', proof'); print ".\n")*) | |
7301 | val () = | |
7302 | assert (List.all (uncurry thm_proves) (zip proof' g')) | |
7303 | (BUG "meson" "did not prove goal list") | |
7304 | in | |
7305 | (SOME (FRESH_VARSL proof'), CHOICE no_choice) | |
7306 | end; | |
7307 | ||
7308 | fun raw_meson system goals depth = | |
7309 | choice_stream | |
7310 | (fn () => | |
7311 | foldl (uncurry (meson_expand system)) (meson_finally goals) (rev goals) | |
7312 | {env = |<>|, depth = depth, proof = [], offset = 0}); | |
7313 | ||
7314 | (* ------------------------------------------------------------------------- *) | |
7315 | (* Raw solvers. *) | |
7316 | (* ------------------------------------------------------------------------- *) | |
7317 | ||
7318 | type 'a system = | |
7319 | {parm : parameters, rules : rules, meter : meter ref, saturated : bool ref, | |
7320 | cut : | |
7321 | (formula list -> formula -> (state -> 'a) -> state -> 'a) -> | |
7322 | formula list -> formula -> (state -> 'a) -> state -> 'a}; | |
7323 | ||
7324 | fun mk_system parm units meter rules : 'a system = | |
7325 | let | |
7326 | val {cache_cutting = caching, unit_lemmaizing = lemmaizing, ...} = parm | |
7327 | in | |
7328 | {parm = parm, | |
7329 | rules = rules, | |
7330 | meter = meter, | |
7331 | saturated = ref false, | |
7332 | cut = unit_cut lemmaizing units o cache_cut caching} | |
7333 | end; | |
7334 | ||
7335 | fun meson' parm = | |
7336 | mk_solver_node | |
7337 | {name = "meson", | |
7338 | solver_con = | |
7339 | fn {slice, units, thms, hyps} => | |
7340 | let | |
7341 | val ruls = meson_rules thms hyps | |
7342 | val () = chat 2 | |
7343 | ("meson--initializing--#thms=" ^ int_to_string (length thms) ^ | |
7344 | "--#hyps=" ^ int_to_string (length hyps) ^ | |
7345 | "--#rules=" ^ int_to_string (num_rules ruls) ^ | |
7346 | "--#initial_rules=" ^ int_to_string (num_initial_rules ruls) ^ ".\n") | |
7347 | val system as {saturated = b, ...} = mk_system parm units slice ruls | |
7348 | fun d n = if !b then S.NIL else (b := true; S.CONS (n, fn () => d (n + 1))) | |
7349 | fun f q d = (chat 1 ("-" ^ int_to_string d); raw_meson system q d) | |
7350 | fun unit_check goals NONE = U.prove (!units) goals | unit_check _ s = s | |
7351 | in | |
7352 | fn goals => | |
7353 | filter_meter slice | |
7354 | (S.map (unit_check goals) (S.flatten (S.map (f goals) (d 0)))) | |
7355 | end}; | |
7356 | ||
7357 | val meson = meson' defaults; | |
7358 | ||
7359 | fun delta' parm = | |
7360 | mk_solver_node | |
7361 | {name = "delta", | |
7362 | solver_con = | |
7363 | fn {slice, units, thms, hyps} => | |
7364 | let | |
7365 | val ruls = meson_rules thms hyps | |
7366 | val dgoals = thms_to_delta_goals hyps | |
7367 | val () = chat 2 | |
7368 | ("delta--initializing--#thms=" ^ int_to_string (length thms) ^ | |
7369 | "--#hyps=" ^ int_to_string (length hyps) ^ | |
7370 | "--#rules=" ^ int_to_string (num_rules ruls) ^ | |
7371 | "--#delta_goals=" ^ int_to_string (length dgoals) ^ ".\n") | |
7372 | val system as {saturated = b, ...} = mk_system parm units slice ruls | |
7373 | val delta_goals = S.from_list dgoals | |
7374 | fun d n = if !b then S.NIL else (b := true; S.CONS (n, fn () => d (n + 1))) | |
7375 | fun f d g = (chat 1 "+"; S.map (K NONE) (raw_meson system [g] d)) | |
7376 | fun g d = (chat 1 (int_to_string d); S.flatten (S.map (f d) delta_goals)) | |
7377 | fun h () = S.flatten (S.map g (d 0)) | |
7378 | fun unit_check goals NONE = U.prove (!units) goals | unit_check _ s = s | |
7379 | in | |
7380 | case delta_goals of S.NIL => K S.NIL | |
7381 | | _ => fn goals => filter_meter slice (S.map (unit_check goals) (h ())) | |
7382 | end}; | |
7383 | ||
7384 | val delta = delta' defaults; | |
7385 | ||
7386 | val prolog_depth = case Int.maxInt of NONE => 1000000 | SOME i => i; | |
7387 | ||
7388 | fun prolog' parm = | |
7389 | mk_solver_node | |
7390 | {name = "prolog", | |
7391 | solver_con = | |
7392 | fn {slice, units, thms, hyps} => | |
7393 | let | |
7394 | val system = mk_system parm units slice (prolog_rules thms hyps) | |
7395 | fun comment S.NIL = "!\n" | |
7396 | | comment (S.CONS (NONE, _)) = "-" | |
7397 | | comment (S.CONS (SOME _, _)) = "$\n" | |
7398 | fun f t () = let val x = t () in chat 1 (comment x); x end | |
7399 | in | |
7400 | fn goals => S.map_thk f (fn () => raw_meson system goals prolog_depth) () | |
7401 | end}; | |
7402 | ||
7403 | val prolog = prolog' defaults; | |
7404 | ||
7405 | (* quick testing | |
7406 | load "Problem1"; | |
7407 | open Problem1; | |
7408 | val time = Mosml.time; | |
7409 | quotation := true; | |
7410 | installPP pp_term; | |
7411 | installPP pp_formula; | |
7412 | installPP Subst1.pp_subst; | |
7413 | installPP pp_rules; | |
7414 | installPP pp_thm; | |
7415 | ||
7416 | val limit : limit ref = ref {infs = NONE, time = SOME 30.0}; | |
7417 | fun prolog_solve d q = | |
7418 | try | |
7419 | (solve | |
7420 | (initialize prolog {limit = !limit, thms = d, hyps = []})) q; | |
7421 | fun meson_prove g = | |
7422 | try (time refute) | |
7423 | (initialize (set_of_support all_negative meson) | |
7424 | {limit = !limit, thms = [], hyps = axiomatize (Not (generalize g))}); | |
7425 | fun delta_prove g = | |
7426 | try (time refute) | |
7427 | (initialize (set_of_support all_negative delta) | |
7428 | {limit = !limit, thms = [], hyps = eq_axiomatize (Not (generalize g))}); | |
7429 | ||
7430 | (* Testing the delta prover *) | |
7431 | ||
7432 | val p48 = parse_formula (get equality "P48"); | |
7433 | delta_prove p48; | |
7434 | ||
7435 | (* Testing the prolog solver *) | |
7436 | ||
7437 | val database = (axiomatize o parse_formula) | |
7438 | [ | |
7439 | ||
7440 | QUOTE "subset nil nil /\\\n (!v x y. subset x y ==> subset (v :: x) (v :: y)) /\\\n (!v x y. subset x y ==> subset x (v :: y))"]; | |
7441 | ||
7442 | try (prolog_solve database) [parse_formula [QUOTE "subset x (0 :: 1 :: 2 :: nil)"]]; | |
7443 | (* takes ages | |
7444 | try (prolog_solve database) [parse_formula `subset (0 :: 1 :: 2 :: nil) x`]; | |
7445 | *) | |
7446 | ||
7447 | val database = (axiomatize o parse_formula) | |
7448 | [ | |
7449 | ||
7450 | ||
7451 | QUOTE "p 0 3 /\\\n (!x. p x 4) /\\\n (!x. p x 3 ==> p (s (s (s x))) 3) /\\\n (!x. p (s x) 3 ==> p x 3)"]; | |
7452 | ||
7453 | try (prolog_solve database) [parse_formula [QUOTE "p (s 0) 3"]]; | |
7454 | ||
7455 | (* Testing the meson prover *) | |
7456 | ||
7457 | meson_prove True; | |
7458 | ||
7459 | val p59 = parse_formula (get nonequality "P59"); | |
7460 | val ths = axiomatize (Not (generalize p59)); | |
7461 | val rules = meson_rules [] ths; | |
7462 | rules_unify rules (parse_formula [QUOTE "~P 0"]); | |
7463 | meson_prove p59; | |
7464 | ||
7465 | val p39 = parse_formula (get nonequality "P39"); | |
7466 | clausal (Not (generalize p39)); | |
7467 | axiomatize (Not (generalize p39)); | |
7468 | meson_prove p39; | |
7469 | ||
7470 | val num14 = parse_formula (get tptp "NUM014-1"); | |
7471 | meson_prove num14; | |
7472 | ||
7473 | val p55 = parse_formula (get nonequality "P55"); | |
7474 | meson_prove p55; | |
7475 | ||
7476 | val p26 = parse_formula (get nonequality "P26"); | |
7477 | clausal (Not (generalize p26)); | |
7478 | meson_prove p26; | |
7479 | ||
7480 | val los = parse_formula (get nonequality "LOS"); | |
7481 | meson_prove los; | |
7482 | ||
7483 | val reduced_num284 = parse_formula | |
7484 | [ | |
7485 | ||
7486 | ||
7487 | ||
7488 | ||
7489 | ||
7490 | QUOTE "fibonacci 0 (s 0) /\\ fibonacci (s 0) (s 0) /\\\n (!x y z x' y' z'.\n ~sum x (s (s 0)) z \\/ ~sum y (s 0) z \\/\n ~fibonacci x x' \\/ ~fibonacci y y' \\/ ~sum x' y' z' \\/\n fibonacci z z') /\\ (!x. sum x 0 x) /\\\n (!x y z. ~sum x y z \\/ sum x (s y) (s z)) /\\\n (!x. ~fibonacci (s (s (s (s (s (s (s (s 0)))))))) x) ==> F"]; | |
7491 | meson_prove reduced_num284; | |
7492 | ||
7493 | val p29 = parse_formula (get nonequality "P29"); | |
7494 | clausal (Not (generalize p29)); | |
7495 | meson_prove p29; | |
7496 | ||
7497 | val num1 = parse_formula (get tptp "NUM001-1"); | |
7498 | meson_prove num1; | |
7499 | ||
7500 | val model_completeness = parse_formula (get nonequality "MODEL_COMPLETENESS"); | |
7501 | meson_prove model_completeness; | |
7502 | *) | |
7503 | ||
7504 | end | |
7505 | (*#line 0.0 "src/Resolvers1.sig"*) | |
7506 | (* ========================================================================= *) | |
7507 | (* A TYPE TO FIND RESOLVANT CLAUSES *) | |
7508 | (* Created by Joe Hurd, April 2002 *) | |
7509 | (* ========================================================================= *) | |
7510 | ||
7511 | signature Resolvers1 = | |
7512 | sig | |
7513 | ||
7514 | type 'a pp = 'a Useful.pp | |
7515 | type formula = Term1.formula | |
7516 | type subst = Subst1.subst | |
7517 | type thm = Thm1.thm | |
7518 | ||
7519 | type resolvers | |
7520 | type resolvant = {mate : thm, sub : subst, res : thm} | |
7521 | ||
7522 | val empty_resolvers : resolvers | |
7523 | val add_resolver : thm -> resolvers -> resolvers | |
7524 | val find_resolvants : resolvers -> thm -> resolvant list | |
7525 | val resolvers_info : resolvers -> string | |
7526 | val pp_resolvers : resolvers pp | |
7527 | ||
7528 | end | |
7529 | (*#line 0.0 "src/Resolvers1.sml"*) | |
7530 | (* ========================================================================= *) | |
7531 | (* A TYPE TO FIND RESOLVANT CLAUSES *) | |
7532 | (* Created by Joe Hurd, April 2002 *) | |
7533 | (* ========================================================================= *) | |
7534 | ||
7535 | (* | |
7536 | app load ["Thm1", "Match1"]; | |
7537 | *) | |
7538 | ||
7539 | (* | |
7540 | *) | |
7541 | structure Resolvers1 :> Resolvers1 = | |
7542 | struct | |
7543 | ||
7544 | infix |-> ::>; | |
7545 | ||
7546 | open Useful Term1 Match1 Thm1 Canon1; | |
7547 | ||
7548 | structure N = LiteralNet1; | |
7549 | ||
7550 | val |<>| = Subst1.|<>|; | |
7551 | val op ::> = Subst1.::>; | |
7552 | val formula_subst = Subst1.formula_subst; | |
7553 | ||
7554 | (* ------------------------------------------------------------------------- *) | |
7555 | (* Chatting. *) | |
7556 | (* ------------------------------------------------------------------------- *) | |
7557 | ||
7558 | val () = traces := {module = "Resolvers1", alignment = K 1} :: !traces; | |
7559 | ||
7560 | fun chat l m = trace {module = "Resolvers1", message = m, level = l}; | |
7561 | ||
7562 | (* ------------------------------------------------------------------------- *) | |
7563 | (* Helper functions. *) | |
7564 | (* ------------------------------------------------------------------------- *) | |
7565 | ||
7566 | fun trich l n = | |
7567 | case split l n of (_, []) => raise ERR "trich" "no exact" | |
7568 | | (l, h :: t) => (l, h, t); | |
7569 | ||
7570 | (* ------------------------------------------------------------------------- *) | |
7571 | (* The type definition with some simple operations. *) | |
7572 | (* ------------------------------------------------------------------------- *) | |
7573 | ||
7574 | type resolvers = (int * thm) N.literal_map; | |
7575 | ||
7576 | type resolvant = {mate : thm, sub : subst, res : thm}; | |
7577 | ||
7578 | val empty_resolvers : resolvers = N.empty; | |
7579 | ||
7580 | fun add_resolver th = | |
7581 | let fun add_lit ((n, lit), net) = N.insert (lit |-> (n, th)) net | |
7582 | in fn net => foldl add_lit net (enumerate 0 (clause th)) | |
7583 | end; | |
7584 | ||
7585 | fun resolvers_info (net : resolvers) = int_to_string (N.size net); | |
7586 | ||
7587 | val pp_resolvers = pp_map resolvers_info pp_string; | |
7588 | ||
7589 | val dest_resolvers : resolvers -> thm list = | |
7590 | map snd o List.filter (equal 0 o fst) o N.to_list; | |
7591 | ||
7592 | (* ------------------------------------------------------------------------- *) | |
7593 | (* A reference implementation for debugging. *) | |
7594 | (* ------------------------------------------------------------------------- *) | |
7595 | ||
7596 | fun canonize lits = | |
7597 | let | |
7598 | val nvars = enumerate 0 (FV (list_mk_conj lits)) | |
7599 | val ms = map (fn (n, v) => v |-> Var ("__" ^ (int_to_string n))) nvars | |
7600 | in | |
7601 | map (formula_subst (Subst1.from_maplets ms)) lits | |
7602 | end; | |
7603 | ||
7604 | local | |
7605 | fun subs acc [] = acc | |
7606 | | subs acc ((prev, []) :: others) = subs (prev :: acc) others | |
7607 | | subs acc ((prev, h :: t) :: others) = | |
7608 | subs acc ((h :: prev, t) :: (prev, t) :: others); | |
7609 | in | |
7610 | fun all_nonempty_subsets l = tl (subs [] [([], l)]); | |
7611 | end; | |
7612 | ||
7613 | fun pairs [] = raise ERR "pairs" "empty" | |
7614 | | pairs [h] = [] | |
7615 | | pairs (h :: (t as h' :: _)) = (h, h') :: pairs t; | |
7616 | ||
7617 | fun sanity_resolve_on th th' s s' = | |
7618 | let | |
7619 | val sub = unifyl_literals |<>| (pairs (s @ s')) | |
7620 | val lit = formula_subst sub (hd s) | |
7621 | val res = FACTOR (RESOLVE lit (INST sub th) (INST sub th')) | |
7622 | in | |
7623 | {mate = th', sub = sub, res = res} | |
7624 | end; | |
7625 | ||
7626 | fun sanity_resolve th th' = | |
7627 | List.mapPartial I | |
7628 | (cartwith (total o sanity_resolve_on th th') | |
7629 | (all_nonempty_subsets (clause th)) | |
7630 | (all_nonempty_subsets (map negate (clause th')))); | |
7631 | ||
7632 | fun sanity_resolvants net th = | |
7633 | List.concat (map (sanity_resolve th) (dest_resolvers net)); | |
7634 | ||
7635 | fun sanity_check net th (res : resolvant list) = | |
7636 | let | |
7637 | val () = chat 1 "X" | |
7638 | val f = PP.pp_to_string (!LINE_LENGTH) (pp_list (pp_map AXIOM pp_thm)) | |
7639 | val fast = map (canonize o clause o #res) res | |
7640 | val slow = map (canonize o clause o #res) (sanity_resolvants net th) | |
7641 | val () = | |
7642 | if subset fast slow then () | |
7643 | else | |
7644 | (print ("\nsanity_check: extra clauses:\nnet = " ^ | |
7645 | f (map clause (dest_resolvers net)) ^ "\nth = " ^ | |
7646 | thm_to_string th ^ "\nfast = " ^ f fast ^ "\nslow = " ^ f slow ^ | |
7647 | "\nextra = " ^ f (subtract fast slow) ^ | |
7648 | "\nmissing = " ^ f (subtract slow fast) ^ "\n"); | |
7649 | raise BUG "find_resolvants" "extra clauses!") | |
7650 | val () = | |
7651 | if subset slow fast then () | |
7652 | else | |
7653 | (print ("\nsanity_check: missing clauses:\nnet = " ^ | |
7654 | f (map clause (dest_resolvers net)) ^ "\nth = " ^ | |
7655 | thm_to_string th ^ "\nfast = " ^ f fast ^ "\nslow = " ^ f slow ^ | |
7656 | "\nmissing = " ^ f (subtract slow fast) ^ | |
7657 | "\nextra = " ^ f (subtract fast slow) ^ "\n"); | |
7658 | raise BUG "find_resolvants" "missing clauses") | |
7659 | (* | |
7660 | val () = | |
7661 | (print ("\nsanity_check: ok:\nnet = " ^ | |
7662 | f (map clause (dest_resolvers net)) ^ "\nth = " ^ | |
7663 | thm_to_string th ^ "\nres = " ^ f fast ^ "\n")) | |
7664 | *) | |
7665 | in | |
7666 | () | |
7667 | end; | |
7668 | ||
7669 | (* ------------------------------------------------------------------------- *) | |
7670 | (* The core engine for combined factor/resolution steps. *) | |
7671 | (* ------------------------------------------------------------------------- *) | |
7672 | ||
7673 | fun resolve_on s r th th' = | |
7674 | SOME (FACTOR (RESOLVE r (INST s th) (INST s th'))); | |
7675 | ||
7676 | fun resolve acc [] = acc | |
7677 | | resolve acc ((avoid, sub, res, []) :: others) = | |
7678 | resolve | |
7679 | (if mem res (map (formula_subst sub) avoid) then acc | |
7680 | else (res, sub) :: acc) others | |
7681 | | resolve acc ((avoid, sub, res, x :: xs) :: others) = | |
7682 | let | |
7683 | fun f c = resolve acc (c ((x :: avoid, sub, res, xs) :: others)) | |
7684 | in | |
7685 | case total (unify_literals sub res) x of NONE => f I | |
7686 | | SOME sub' | |
7687 | => f (cons (avoid, Subst1.refine sub sub', formula_subst sub' res, xs)) | |
7688 | end; | |
7689 | ||
7690 | fun resolve_from (n, th) (n', th') = | |
7691 | let | |
7692 | val (prev, lit, succ) = trich (clause th) n | |
7693 | val (prev', lit', succ') = trich (map negate (clause th')) n' | |
7694 | val sub = unify_literals |<>| lit lit' | |
7695 | val res = formula_subst sub lit | |
7696 | fun f (r, s) = Option.map (pair s) (resolve_on s r th th') | |
7697 | in | |
7698 | List.mapPartial f (resolve [] [(prev @ prev', sub, res, succ @ succ')]) | |
7699 | end; | |
7700 | ||
7701 | fun resolvants net th = | |
7702 | let | |
7703 | fun g (_, mate) ((sub, res), l) = {mate = mate, sub = sub, res = res} :: l | |
7704 | fun r m (u, acc) = | |
7705 | case total (resolve_from (m, th)) u of NONE => acc | |
7706 | | SOME l => foldl (g u) acc l | |
7707 | fun f ((m, lit), acc) = foldl (r m) acc (N.unify net (negate lit)) | |
7708 | val res = foldl f [] (enumerate 0 (clause th)) | |
7709 | (*val () = sanity_check net th res*) | |
7710 | in | |
7711 | res | |
7712 | end | |
7713 | ||
7714 | fun find_resolvants net th = | |
7715 | List.filter (non tautologous o clause o #res) (resolvants net th) | |
7716 | handle ERR_EXN _ => raise BUG "find_resolvants" "should never fail"; | |
7717 | ||
7718 | (* Quick testing | |
7719 | quotation := true; | |
7720 | installPP pp_formula; | |
7721 | installPP pp_term; | |
7722 | installPP pp_subst; | |
7723 | installPP pp_thm; | |
7724 | val th = AXIOM (map parse [`p(3, x, v)`, `q(x)`, `p(3, x, z)`]); | |
7725 | val th' = AXIOM (map parse [`~p(3, f(y), w)`, `~q(y)`, `~p(3, f(y), 4)`]); | |
7726 | try (resolve_from (0, th)) (0, th'); | |
7727 | try (resolve_from (2, th)) (0, th'); | |
7728 | try (resolve_from (0, th)) (2, th'); | |
7729 | try (resolve_from (2, th)) (2, th'); | |
7730 | val r = add_resolver th' empty_resolvers; | |
7731 | map #res (find_resolvants r th); | |
7732 | *) | |
7733 | ||
7734 | end | |
7735 | (*#line 0.0 "src/Theap1.sig"*) | |
7736 | (* ========================================================================= *) | |
7737 | (* A TYPE TO STORE CLAUSES WAITING TO BE USED (THEAP = THEOREM HEAP) *) | |
7738 | (* Created by Joe Hurd, April 2002 *) | |
7739 | (* ========================================================================= *) | |
7740 | ||
7741 | signature Theap1 = | |
7742 | sig | |
7743 | ||
7744 | type 'a subsume = 'a Subsume1.subsume | |
7745 | type thm = Thm1.thm | |
7746 | ||
7747 | (* Tuning parameters *) | |
7748 | type parameters = {fifo_skew : int, cleaning_freq : int} | |
7749 | val defaults : parameters | |
7750 | ||
7751 | (* Theorem HEAPs *) | |
7752 | type theap | |
7753 | val new_theap : parameters -> theap | |
7754 | val empty_theap : theap (* Uses defaults *) | |
7755 | val theap_size : theap -> int | |
7756 | val theap_add : thm -> theap -> theap | |
7757 | val theap_addl : thm list -> theap -> theap | |
7758 | val theap_remove : theap -> (thm * theap) option | |
7759 | val theap_subsumers : theap -> thm subsume | |
7760 | val theap_info : theap -> string (* Outputs "(size,weight)" *) | |
7761 | ||
7762 | end | |
7763 | (*#line 0.0 "src/Theap1.sml"*) | |
7764 | (* ========================================================================= *) | |
7765 | (* A TYPE TO STORE CLAUSES WAITING TO BE USED (THEAP = THEOREM HEAP) *) | |
7766 | (* Created by Joe Hurd, April 2002 *) | |
7767 | (* ========================================================================= *) | |
7768 | ||
7769 | (* | |
7770 | app load ["Heap", "Queue", "Thm1", "Subsumers1"]; | |
7771 | *) | |
7772 | ||
7773 | (* | |
7774 | *) | |
7775 | structure Theap1 :> Theap1 = | |
7776 | struct | |
7777 | ||
7778 | infix |->; | |
7779 | ||
7780 | open Useful Term1 Thm1; | |
7781 | ||
7782 | structure Q = Queue; | |
7783 | structure H = Heap; | |
7784 | structure S = Subsume1; | |
7785 | ||
7786 | type 'a queue = 'a Q.queue; | |
7787 | type 'a heap = 'a H.heap; | |
7788 | type 'a subsume = 'a S.subsume; | |
7789 | ||
7790 | (* ------------------------------------------------------------------------- *) | |
7791 | (* Tuning parameters. *) | |
7792 | (* ------------------------------------------------------------------------- *) | |
7793 | ||
7794 | type parameters = {fifo_skew : int, cleaning_freq : int} | |
7795 | ||
7796 | val defaults = {fifo_skew = 3, cleaning_freq = 1000}; | |
7797 | ||
7798 | (* ------------------------------------------------------------------------- *) | |
7799 | (* Theorem HEAPs. *) | |
7800 | (* ------------------------------------------------------------------------- *) | |
7801 | ||
7802 | type theap = | |
7803 | ((int * int) * (int * int)) * thm queue * (int * (int * thm) heap) * | |
7804 | thm subsume; | |
7805 | ||
7806 | local fun order ((m, _ : thm), (n, _ : thm)) = Int.compare (m, n); | |
7807 | in val empty_theap_heap = H.empty order; | |
7808 | end; | |
7809 | ||
7810 | fun new_theap {fifo_skew, cleaning_freq} = | |
7811 | ((D cleaning_freq, D fifo_skew), Q.empty, (0, empty_theap_heap), S.empty); | |
7812 | ||
7813 | val empty_theap: theap = new_theap defaults; | |
7814 | ||
7815 | fun theap_size (_, _, (_, h), _) = H.size h; | |
7816 | fun theap_weight (_, _, (w, _), _) = w; | |
7817 | ||
7818 | (* | |
7819 | fun clean_theap (((_, C), F), Q, (_, H), _) = | |
7820 | let | |
7821 | val hash = Polyhash.mkPolyTable (10000, ERR "cleap_theap" "not found") | |
7822 | fun mark (v, th) = Polyhash.insert hash (clause th, v) | |
7823 | val () = H.app mark H | |
7824 | fun add (v, th) (q, w, h, l) = | |
7825 | (Q.add th q, w + v, H.add (v, th) h, S.add (clause th |-> th) l) | |
7826 | fun check q n = | |
7827 | if Q.is_empty q then n | |
7828 | else | |
7829 | let | |
7830 | val th = Q.hd q | |
7831 | in | |
7832 | check (Q.tl q) | |
7833 | (case total (Polyhash.remove hash) (clause th) of NONE => n | |
7834 | | SOME v => add (v, th) n) | |
7835 | end | |
7836 | in | |
7837 | (fn (q, w, h, l) => (((C, C), F), q, (w, h), l)) | |
7838 | (check Q (Q.empty, 0, empty_theap_heap, S.empty)) | |
7839 | end; | |
7840 | *) | |
7841 | ||
7842 | (*fun theap_add th (h as (((0,_), _), _, _, _)) = theap_add th (clean_theap h)*) | |
7843 | fun theap_add th (((c, cm), f), q, (w, h), l) = | |
7844 | let | |
7845 | val cl = clause th | |
7846 | val v = formula_size (list_mk_disj cl) | |
7847 | val h' = H.add (v, th) h | |
7848 | in | |
7849 | (((c - 1, cm), f), Q.add th q, (w + v, h'), S.add (clause th |-> th) l) | |
7850 | end; | |
7851 | ||
7852 | fun theap_addl ths h = foldl (uncurry theap_add) h ths; | |
7853 | ||
7854 | fun theap_remove ((c, (0, f)), q, h, l) = | |
7855 | if Q.is_empty q then NONE | |
7856 | else SOME (Q.hd q, ((c, (f, f)), Q.tl q, h, l)) | |
7857 | | theap_remove ((c, (n, f)), q, (w, h), l) = | |
7858 | if H.is_empty h then NONE | |
7859 | else | |
7860 | let val ((v, x), h) = H.remove h | |
7861 | in SOME (x, ((c, (n - 1, f)), q, (w - v, h), l)) | |
7862 | end; | |
7863 | ||
7864 | fun theap_subsumers (_, _, _, l) = l; | |
7865 | ||
7866 | fun theap_info thp = | |
7867 | "(" ^ int_to_string (theap_size thp) ^ "," ^ | |
7868 | int_to_string (theap_weight thp) ^ ")"; | |
7869 | ||
7870 | end | |
7871 | (*#line 0.0 "src/Resolution1.sig"*) | |
7872 | (* ========================================================================= *) | |
7873 | (* THE RESOLUTION PROOF PROCEDURE *) | |
7874 | (* Created by Joe Hurd, November 2001 *) | |
7875 | (* ========================================================================= *) | |
7876 | ||
7877 | signature Resolution1 = | |
7878 | sig | |
7879 | ||
7880 | type solver_node = Solver1.solver_node | |
7881 | ||
7882 | (* Tuning parameters *) | |
7883 | type parameters = | |
7884 | {subsumption_checking : int, (* in the range 0..3 *) | |
7885 | positive_refinement : bool, | |
7886 | theap_parm : Theap1.parameters} | |
7887 | ||
7888 | val defaults : parameters | |
7889 | ||
7890 | (* Resolution *) | |
7891 | val resolution' : parameters -> solver_node | |
7892 | val resolution : solver_node (* Uses defaults *) | |
7893 | ||
7894 | end | |
7895 | (*#line 0.0 "src/Resolution1.sml"*) | |
7896 | (* ========================================================================= *) | |
7897 | (* THE RESOLUTION PROOF PROCEDURE *) | |
7898 | (* Created by Joe Hurd, November 2001 *) | |
7899 | (* ========================================================================= *) | |
7900 | ||
7901 | (* | |
7902 | app load | |
7903 | ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Theap1", | |
7904 | "Stream", "Solver1", "Meter1", "Units1", "Resolvers1"]; | |
7905 | *) | |
7906 | ||
7907 | (* | |
7908 | *) | |
7909 | structure Resolution1 :> Resolution1 = | |
7910 | struct | |
7911 | ||
7912 | open Useful Term1 Thm1 Canon1 Meter1 Solver1 Resolvers1 Theap1; | |
7913 | ||
7914 | infix |-> ::> @> oo ## ::* ::@; | |
7915 | ||
7916 | structure S = Stream; | |
7917 | structure U = Units1; | |
7918 | ||
7919 | type 'a subsume = 'a Subsume1.subsume; | |
7920 | ||
7921 | (* ------------------------------------------------------------------------- *) | |
7922 | (* Chatting. *) | |
7923 | (* ------------------------------------------------------------------------- *) | |
7924 | ||
7925 | val () = traces := {module = "Resolution1", alignment = K 1} :: !traces; | |
7926 | ||
7927 | fun chat l m = trace {module = "Resolution1", message = m, level = l}; | |
7928 | ||
7929 | (* ------------------------------------------------------------------------- *) | |
7930 | (* Tuning parameters. *) | |
7931 | (* ------------------------------------------------------------------------- *) | |
7932 | ||
7933 | type parameters = | |
7934 | {subsumption_checking : int, (* in the range 0..3 *) | |
7935 | positive_refinement : bool, | |
7936 | theap_parm : Theap1.parameters} | |
7937 | ||
7938 | val defaults = | |
7939 | {subsumption_checking = 1, | |
7940 | positive_refinement = true, | |
7941 | theap_parm = Theap1.defaults}; | |
7942 | ||
7943 | (* ------------------------------------------------------------------------- *) | |
7944 | (* Clause stores. *) | |
7945 | (* ------------------------------------------------------------------------- *) | |
7946 | ||
7947 | type store = thm subsume * resolvers; | |
7948 | ||
7949 | val empty_store : store = (Subsume1.empty, empty_resolvers); | |
7950 | ||
7951 | fun store_add th (s, r) = | |
7952 | (Subsume1.add (clause th |-> th) s, add_resolver th r); | |
7953 | ||
7954 | fun store_resolvants ((_, r) : store) = find_resolvants r; | |
7955 | ||
7956 | fun store_subsumed ((s, _) : store) = Subsume1.subsumed s o clause; | |
7957 | ||
7958 | fun store_info (s, r) = "(" ^ Subsume1.info s ^ "," ^ resolvers_info r ^ ")"; | |
7959 | ||
7960 | (* ------------------------------------------------------------------------- *) | |
7961 | (* Positive refinement. *) | |
7962 | (* ------------------------------------------------------------------------- *) | |
7963 | ||
7964 | local | |
7965 | val pos_th = List.all positive o clause; | |
7966 | ||
7967 | fun check true = K true | |
7968 | | check false = fn ({mate, ...} : resolvant) => pos_th mate; | |
7969 | in | |
7970 | fun positive_check false = K (K true) | |
7971 | | positive_check true = check o pos_th; | |
7972 | end; | |
7973 | ||
7974 | (* ------------------------------------------------------------------------- *) | |
7975 | (* Full resolution procedure. *) | |
7976 | (* ------------------------------------------------------------------------- *) | |
7977 | ||
7978 | exception Contradiction of thm; | |
7979 | ||
7980 | fun unit_strengthen units th = | |
7981 | (case first (U.subsumes units) (clause th) of SOME th => th | |
7982 | | NONE => U.demod units th); | |
7983 | ||
7984 | fun subsumption_check store th = | |
7985 | case store_subsumed store th of [] => SOME th | _ :: _ => NONE; | |
7986 | ||
7987 | fun theap_strengthen theap th = | |
7988 | (case Subsume1.strictly_subsumed (theap_subsumers theap) (clause th) of [] | |
7989 | => th | |
7990 | | (_, th) :: _ => th); | |
7991 | ||
7992 | fun resolve (parm : parameters) = | |
7993 | let | |
7994 | fun feedback k r = | |
7995 | int_to_string k ^ (if k = r then "" else "/" ^ int_to_string r) | |
7996 | ||
7997 | fun L n = n <= #subsumption_checking parm | |
7998 | val pos_filt = Option.filter o positive_check (#positive_refinement parm) | |
7999 | ||
8000 | fun ftest b f = if b then Option.mapPartial (subsumption_check f) else I | |
8001 | fun stest b s = if b then subsumption_check s else SOME | |
8002 | fun wpass b w = if b then theap_strengthen w else I | |
8003 | fun upass u = unit_strengthen u | |
8004 | ||
8005 | fun next_candidate u f s w = | |
8006 | case theap_remove w of NONE => NONE | |
8007 | | SOME (th, w) => | |
8008 | (case (ftest (L 1) f o stest (L 1) s o wpass (L 2) w o upass u) th of | |
8009 | NONE => next_candidate u f s w | |
8010 | | SOME th => SOME (th, w)) | |
8011 | ||
8012 | fun retention_test u f s th = | |
8013 | List.mapPartial | |
8014 | (Option.mapPartial (ftest (L 3) f o stest (L 3) s o upass u o #res) o | |
8015 | pos_filt th) | |
8016 | ||
8017 | fun check_add th = | |
8018 | if is_contradiction th then raise Contradiction th else U.add th | |
8019 | in | |
8020 | fn record => fn (facts, used, unused) => fn units => | |
8021 | (case next_candidate units facts used unused of NONE => NONE | |
8022 | | SOME (th, unused) => | |
8023 | let | |
8024 | val units = check_add th units | |
8025 | val used = store_add th used | |
8026 | val th = FRESH_VARS th | |
8027 | val resolvants = | |
8028 | store_resolvants facts th @ store_resolvants used th | |
8029 | val () = record (length resolvants) | |
8030 | val units = foldl (uncurry check_add) units (map #res resolvants) | |
8031 | val keep = retention_test units facts used th resolvants | |
8032 | val () = chat 2 (feedback (length keep) (length resolvants)) | |
8033 | val unused = theap_addl keep unused | |
8034 | in | |
8035 | SOME ((facts, used, unused), units) | |
8036 | end) | |
8037 | handle ERR_EXN _ => raise BUG "resolve" "shouldn't fail" | |
8038 | end; | |
8039 | ||
8040 | fun raw_resolution parm = | |
8041 | mk_solver_node | |
8042 | {name = "resolution", | |
8043 | solver_con = | |
8044 | fn {slice, units, thms, hyps} => | |
8045 | let | |
8046 | val resolve' = resolve parm | |
8047 | fun run wrap state = | |
8048 | if not (check_meter (!slice)) then S.CONS (NONE, wrap state) | |
8049 | else | |
8050 | (chat 1 "+"; | |
8051 | case resolve' (record_infs (!slice)) state (!units) of NONE => S.NIL | |
8052 | | SOME (state, units') => (units := units'; run wrap state)) | |
8053 | fun wrapper g (a as (_, _, w)) () = | |
8054 | (chat 2 (theap_info w); run (wrapper g) a) | |
8055 | handle Contradiction th => contradiction_solver th g | |
8056 | val facts = foldl (fn (t, l) => store_add t l) empty_store thms | |
8057 | val used = empty_store | |
8058 | val unused = theap_addl hyps (new_theap (#theap_parm parm)) | |
8059 | val () = chat 2 | |
8060 | ("resolution--initializing--#thms=" ^ int_to_string (length thms) ^ | |
8061 | "--#hyps=" ^ int_to_string (length hyps) ^ | |
8062 | "--facts=" ^ store_info facts ^ | |
8063 | "--unused=" ^ theap_info unused ^ ".\n") | |
8064 | in | |
8065 | fn goals => wrapper goals (facts, used, unused) () | |
8066 | end}; | |
8067 | ||
8068 | fun resolution' parm = | |
8069 | (if #positive_refinement parm then set_of_support everything else I) | |
8070 | (raw_resolution parm); | |
8071 | ||
8072 | val resolution = resolution' defaults; | |
8073 | ||
8074 | (* quick testing | |
8075 | load "Problem1"; | |
8076 | open Problem1; | |
8077 | val time = Mosml.time; | |
8078 | quotation := true; | |
8079 | installPP pp_term; | |
8080 | installPP pp_formula; | |
8081 | installPP Subst1.pp_subst; | |
8082 | installPP pp_thm; | |
8083 | ||
8084 | (* Testing the resolution prover *) | |
8085 | ||
8086 | val limit : limit ref = ref {infs = NONE, time = SOME 30.0}; | |
8087 | fun resolution_prove g = | |
8088 | try (time refute) | |
8089 | (initialize (set_of_support all_negative resolution) | |
8090 | {limit = !limit, thms = [], hyps = axiomatize (Not (generalize g))}); | |
8091 | ||
8092 | axiomatize (Not (generalize True)); | |
8093 | resolution_prove True; | |
8094 | ||
8095 | val prop13 = parse_formula (get nonequality "PROP_13"); | |
8096 | axiomatize (Not (generalize prop13)); | |
8097 | resolution_prove prop13; | |
8098 | ||
8099 | val p33 = parse_formula (get nonequality "P33"); | |
8100 | axiomatize (Not (generalize p33)); | |
8101 | resolution_prove p33; | |
8102 | ||
8103 | val p59 = parse_formula (get nonequality "P59"); | |
8104 | val ths = axiomatize (Not (generalize p59)); | |
8105 | resolution_prove p59; | |
8106 | ||
8107 | val p39 = parse_formula (get nonequality "P39"); | |
8108 | clausal (Not (generalize p39)); | |
8109 | axiomatize (Not (generalize p39)); | |
8110 | resolution_prove p39; | |
8111 | ||
8112 | val num14 = parse_formula (get tptp "NUM014-1"); | |
8113 | resolution_prove num14; | |
8114 | ||
8115 | val p55 = parse_formula (get nonequality "P55"); | |
8116 | resolution_prove p55; | |
8117 | ||
8118 | val p26 = parse_formula (get nonequality "P26"); | |
8119 | clausal (Not (generalize p26)); | |
8120 | resolution_prove p26; | |
8121 | ||
8122 | val los = parse_formula (get nonequality "LOS"); | |
8123 | resolution_prove los; | |
8124 | ||
8125 | val reduced_num284 = parse_formula | |
8126 | [ | |
8127 | ||
8128 | ||
8129 | ||
8130 | ||
8131 | ||
8132 | QUOTE "fibonacci 0 (s 0) /\\ fibonacci (s 0) (s 0) /\\\n (!x y z x' y' z'.\n ~sum x (s (s 0)) z \\/ ~sum y (s 0) z \\/\n ~fibonacci x x' \\/ ~fibonacci y y' \\/ ~sum x' y' z' \\/\n fibonacci z z') /\\ (!x. sum x 0 x) /\\\n (!x y z. ~sum x y z \\/ sum x (s y) (s z)) /\\\n (!x. ~fibonacci (s (s (s (s (s (s (s (s 0)))))))) x) ==> F"]; | |
8133 | resolution_prove reduced_num284; | |
8134 | ||
8135 | val p29 = parse_formula (get nonequality "P29"); | |
8136 | clausal (Not (generalize p29)); | |
8137 | resolution_prove p29; | |
8138 | ||
8139 | val num1 = parse_formula (get tptp "NUM001-1"); | |
8140 | resolution_prove num1; | |
8141 | ||
8142 | val gilmore9 = parse_formula (get nonequality "GILMORE_9"); | |
8143 | axiomatize (Not (generalize gilmore9)); | |
8144 | resolution_prove gilmore9; | |
8145 | ||
8146 | val model_completeness = parse_formula (get nonequality "MODEL_COMPLETENESS"); | |
8147 | resolution_prove model_completeness; | |
8148 | *) | |
8149 | ||
8150 | end | |
8151 | (*#line 0.0 "src/Metis1.sig"*) | |
8152 | (* ========================================================================= *) | |
8153 | (* THE METIS COMBINATION OF PROOF PROCEDURES FOR FIRST-ORDER LOGIC *) | |
8154 | (* Created by Joe Hurd, September 2001 *) | |
8155 | (* ========================================================================= *) | |
8156 | ||
8157 | signature Metis1 = | |
8158 | sig | |
8159 | ||
8160 | type formula = Term1.formula | |
8161 | type thm = Thm1.thm | |
8162 | type limit = Meter1.limit | |
8163 | type solver = Solver1.solver | |
8164 | type solver_node = Solver1.solver_node | |
8165 | ||
8166 | (* Tuning parameters *) | |
8167 | type Mparm = Meson1.parameters | |
8168 | type Rparm = Resolution1.parameters | |
8169 | type parameters = | |
8170 | {meson : bool, | |
8171 | delta : bool, | |
8172 | resolution : bool, | |
8173 | meson_parm : Mparm, | |
8174 | resolution_parm : Rparm} | |
8175 | ||
8176 | val defaults : parameters | |
8177 | val update_parm_meson : (bool -> bool) -> parameters -> parameters | |
8178 | val update_parm_delta : (bool -> bool) -> parameters -> parameters | |
8179 | val update_parm_resolution : (bool -> bool) -> parameters -> parameters | |
8180 | val update_parm_meson_parm : (Mparm -> Mparm) -> parameters -> parameters | |
8181 | val update_parm_resolution_parm : (Rparm -> Rparm) -> parameters -> parameters | |
8182 | ||
8183 | (* The metis combination of solvers *) | |
8184 | val metis' : parameters -> solver_node | |
8185 | val metis : solver_node (* Uses defaults *) | |
8186 | ||
8187 | (* A user-friendly interface *) | |
8188 | val settings : parameters ref (* Starts off as defaults *) | |
8189 | val limit : limit ref (* Starts off as 10 seconds *) | |
8190 | val raw_prove : formula -> thm option (* Expects a ==> b ==> F *) | |
8191 | val prove : formula -> thm option (* Adds eq axioms, converts to CNF *) | |
8192 | val query : formula -> solver (* Prolog query engine *) | |
8193 | ||
8194 | end | |
8195 | (*#line 0.0 "src/Metis1.sml"*) | |
8196 | (* ========================================================================= *) | |
8197 | (* THE METIS COMBINATION OF PROOF PROCEDURES FOR FIRST-ORDER LOGIC *) | |
8198 | (* Created by Joe Hurd, September 2001 *) | |
8199 | (* ========================================================================= *) | |
8200 | ||
8201 | (* | |
8202 | app load | |
8203 | ["Useful", "Mosml", "Term1", "Thm1", "Canon1", | |
8204 | "Solver1", "Meson1", "Resolution1"]; | |
8205 | *) | |
8206 | ||
8207 | (* | |
8208 | *) | |
8209 | structure Metis1 :> Metis1 = | |
8210 | struct | |
8211 | ||
8212 | open Useful Term1 Thm1 Meter1 Canon1 Solver1 Meson1 Resolution1; | |
8213 | ||
8214 | infix |-> ::> @> oo ## ::* ::@; | |
8215 | ||
8216 | (* ------------------------------------------------------------------------- *) | |
8217 | (* Tuning parameters. *) | |
8218 | (* ------------------------------------------------------------------------- *) | |
8219 | ||
8220 | type Mparm = Meson1.parameters; | |
8221 | type Rparm = Resolution1.parameters; | |
8222 | ||
8223 | type parameters = | |
8224 | {meson : bool, | |
8225 | delta : bool, | |
8226 | resolution : bool, | |
8227 | meson_parm : Mparm, | |
8228 | resolution_parm : Rparm}; | |
8229 | ||
8230 | val defaults = | |
8231 | {meson = true, | |
8232 | delta = true, | |
8233 | resolution = true, | |
8234 | meson_parm = Meson1.defaults, | |
8235 | resolution_parm = Resolution1.defaults}; | |
8236 | ||
8237 | fun update_parm_meson f parm = | |
8238 | let | |
8239 | val {meson, delta, resolution, meson_parm, resolution_parm} = parm | |
8240 | in | |
8241 | {meson = f meson, delta = delta, resolution = resolution, | |
8242 | meson_parm = meson_parm, resolution_parm = resolution_parm} | |
8243 | end; | |
8244 | ||
8245 | fun update_parm_delta f parm = | |
8246 | let | |
8247 | val {meson, delta, resolution, meson_parm, resolution_parm} = parm | |
8248 | in | |
8249 | {meson = meson, delta = f delta, resolution = resolution, | |
8250 | meson_parm = meson_parm, resolution_parm = resolution_parm} | |
8251 | end; | |
8252 | ||
8253 | fun update_parm_resolution f parm = | |
8254 | let | |
8255 | val {meson, delta, resolution, meson_parm, resolution_parm} = parm | |
8256 | in | |
8257 | {meson = meson, delta = delta, resolution = f resolution, | |
8258 | meson_parm = meson_parm, resolution_parm = resolution_parm} | |
8259 | end; | |
8260 | ||
8261 | fun update_parm_meson_parm f parm = | |
8262 | let | |
8263 | val {meson, delta, resolution, meson_parm, resolution_parm} = parm | |
8264 | in | |
8265 | {meson = meson, delta = delta, resolution = resolution, | |
8266 | meson_parm = f meson_parm, resolution_parm = resolution_parm} | |
8267 | end; | |
8268 | ||
8269 | fun update_parm_resolution_parm f parm = | |
8270 | let | |
8271 | val {meson, delta, resolution, meson_parm, resolution_parm} = parm | |
8272 | in | |
8273 | {meson = meson, delta = delta, resolution = resolution, | |
8274 | meson_parm = meson_parm, resolution_parm = f resolution_parm} | |
8275 | end; | |
8276 | ||
8277 | (* ------------------------------------------------------------------------- *) | |
8278 | (* The metis combination of solvers. *) | |
8279 | (* ------------------------------------------------------------------------- *) | |
8280 | ||
8281 | fun metis' {meson = m, delta = d, resolution = r, meson_parm, resolution_parm} = | |
8282 | combine | |
8283 | ((if m then cons (time1, meson' meson_parm) else I) | |
8284 | ((if r then cons (time1, resolution' resolution_parm) else I) | |
8285 | ((if d then cons (time2, delta' meson_parm) else I) | |
8286 | []))); | |
8287 | ||
8288 | val metis = metis' defaults; | |
8289 | ||
8290 | (* ------------------------------------------------------------------------- *) | |
8291 | (* A user-friendly interface. *) | |
8292 | (* ------------------------------------------------------------------------- *) | |
8293 | ||
8294 | val settings = ref defaults; | |
8295 | ||
8296 | val limit : limit ref = ref {time = NONE, infs = NONE}; | |
8297 | ||
8298 | fun raw_prove (Imp (a, Imp (b, False))) = | |
8299 | let | |
8300 | val (thms, hyps) = (axiomatize a, axiomatize b) | |
8301 | val solv = metis' (!settings) | |
8302 | in | |
8303 | refute (initialize solv {limit = !limit, thms = thms, hyps = hyps}) | |
8304 | end | |
8305 | | raw_prove _ = raise ERR "raw_prove" "formula not of type a ==> b ==> F"; | |
8306 | ||
8307 | fun prove g = | |
8308 | let | |
8309 | val hyps = eq_axiomatize' (Not (generalize g)) | |
8310 | val solv = set_of_support all_negative (metis' (!settings)) | |
8311 | in | |
8312 | refute (initialize solv {limit = !limit, thms = [], hyps = hyps}) | |
8313 | end; | |
8314 | ||
8315 | fun query database = | |
8316 | initialize prolog {thms = axiomatize database, hyps = [], limit = unlimited}; | |
8317 | ||
8318 | (* quick testing | |
8319 | val time = Mosml.time; | |
8320 | quotation := true; | |
8321 | installPP pp_term; | |
8322 | installPP pp_formula; | |
8323 | installPP Subst1.pp_subst; | |
8324 | installPP pp_thm; | |
8325 | ||
8326 | (* Testing the metis prover *) | |
8327 | ||
8328 | prove True; | |
8329 | ||
8330 | val p59 = parse_formula [QUOTE "(!x. P(x) <=> ~P(f(x))) ==> (?x. P(x) /\\ ~P(f(x)))"]; | |
8331 | val ths = axiomatize (Not (generalize p59)); | |
8332 | prove p59; | |
8333 | ||
8334 | val p39 = parse_formula [QUOTE "~(?x. !y. P(y,x) <=> ~P(y,y))"]; | |
8335 | clausal (Not (generalize p39)); | |
8336 | axiomatize (Not (generalize p39)); | |
8337 | prove p39; | |
8338 | ||
8339 | val num14 = parse_formula | |
8340 | [ | |
8341 | ||
8342 | ||
8343 | ||
8344 | ||
8345 | ||
8346 | QUOTE "(!X. product(X, X, square(X))) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ product(Y, X, Z)) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ divides(X, Z)) /\\\n (!Y X V Z.\n ~prime(X) \\/ ~product(Y, Z, V) \\/ ~divides(X, V) \\/ divides(X, Y) \\/\n divides(X, Z)) /\\ prime(a) /\\\n product(a, square(c), square(b)) /\\ ~divides(a, b) ==> F"]; | |
8347 | prove num14; | |
8348 | ||
8349 | val p26 = parse_formula | |
8350 | [ | |
8351 | ||
8352 | QUOTE "((?x. P(x)) <=> (?x. Q(x))) /\\\n (!x y. P(x) /\\ Q(y) ==> (R(x) <=> U(y))) ==>\n ((!x. P(x) ==> R(x)) <=> (!x. Q(x) ==> U(x)))"]; | |
8353 | clausal (Not (generalize p26)); | |
8354 | prove p26; | |
8355 | ||
8356 | val los = parse_formula | |
8357 | [ | |
8358 | ||
8359 | QUOTE "(!x y z. P x y ==> P y z ==> P x z) /\\\n (!x y z. Q x y ==> Q y z ==> Q x z) /\\ (!x y. Q x y ==> Q y x) /\\\n (!x y. P x y \\/ Q x y) ==> (!x y. P x y) \\/ !x y. Q x y"]; | |
8360 | try prove los; | |
8361 | ||
8362 | val puz2 = parse_formula | |
8363 | [ | |
8364 | ||
8365 | ||
8366 | ||
8367 | ||
8368 | ||
8369 | ||
8370 | ||
8371 | ||
8372 | ||
8373 | ||
8374 | ||
8375 | ||
8376 | ||
8377 | ||
8378 | ||
8379 | ||
8380 | ||
8381 | ||
8382 | ||
8383 | ||
8384 | ||
8385 | ||
8386 | ||
8387 | ||
8388 | ||
8389 | ||
8390 | QUOTE "(!X. equal(X, X)) /\\ (!Y X. ~equal(X, Y) \\/ equal(Y, X)) /\\\n (!Z X Y. ~equal(X, Y) \\/ ~equal(Y, Z) \\/ equal(X, Z)) /\\\n (!B A. ~equal(A, B) \\/ equal(every_one_but(A), every_one_but(B))) /\\\n (!E C D. ~equal(C, D) \\/ ~hates(C, E) \\/ hates(D, E)) /\\\n (!H F_avoid G.\n ~equal(F_avoid, G) \\/ ~hates(H, F_avoid) \\/ hates(H, G)) /\\\n (!K I J. ~equal(I, J) \\/ ~killed(I, K) \\/ killed(J, K)) /\\\n (!N L M. ~equal(L, M) \\/ ~killed(N, L) \\/ killed(N, M)) /\\\n (!P O.\n ~equal(O, P) \\/ ~lives_at_dreadsbury(O) \\/ lives_at_dreadsbury(P)) /\\\n (!S Q R. ~equal(Q, R) \\/ ~richer(Q, S) \\/ richer(R, S)) /\\\n (!V T_avoid U.\n ~equal(T_avoid, U) \\/ ~richer(V, T_avoid) \\/ richer(V, U)) /\\\n lives_at_dreadsbury(someone()) /\\ killed(someone(), aunt_agatha()) /\\\n lives_at_dreadsbury(aunt_agatha()) /\\ lives_at_dreadsbury(butler()) /\\\n lives_at_dreadsbury(charles()) /\\\n (!Person.\n ~lives_at_dreadsbury(Person) \\/ equal(Person, aunt_agatha()) \\/\n equal(Person, butler()) \\/ equal(Person, charles())) /\\\n (!Victim Killer. ~killed(Killer, Victim) \\/ hates(Killer, Victim)) /\\\n (!Victim Killer. ~killed(Killer, Victim) \\/ ~richer(Killer, Victim)) /\\\n (!Person. ~hates(aunt_agatha(), Person) \\/ ~hates(charles(), Person)) /\\\n (!Person. equal(Person, butler()) \\/ hates(aunt_agatha(), Person)) /\\\n (!Person. richer(Person, aunt_agatha()) \\/ hates(butler(), Person)) /\\\n (!Person. ~hates(aunt_agatha(), Person) \\/ hates(butler(), Person)) /\\\n (!Person. ~hates(Person, every_one_but(Person))) /\\\n ~equal(aunt_agatha(), butler()) /\\\n ~killed(aunt_agatha(), aunt_agatha()) ==> F"]; | |
8391 | prove puz2; | |
8392 | ||
8393 | val num284 = parse_formula | |
8394 | [ | |
8395 | ||
8396 | ||
8397 | ||
8398 | ||
8399 | ||
8400 | ||
8401 | ||
8402 | QUOTE "fibonacci(0, successor(0)) /\\ fibonacci(successor(0), successor(0)) /\\\n (!N2 N1 N F1 FN F2.\n ~sum(N1, successor(0), N) \\/ ~sum(N2, successor(successor(0)), N) \\/\n ~fibonacci(N1, F1) \\/ ~fibonacci(N2, F2) \\/ ~sum(F1, F2, FN) \\/\n fibonacci(N, FN)) /\\ (!X. sum(X, 0, X)) /\\\n (!Z X Y. ~sum(X, Y, Z) \\/ sum(X, successor(Y), successor(Z))) /\\\n (!Result.\n ~fibonacci(successor(successor(successor(successor(successor(successor(successor(successor(0)))))))),\n Result)) ==> F"]; | |
8403 | prove num284; | |
8404 | ||
8405 | val p29 = parse_formula | |
8406 | [ | |
8407 | ||
8408 | QUOTE "(?x. P(x)) /\\ (?x. G(x)) ==>\n ((!x. P(x) ==> H(x)) /\\ (!x. G(x) ==> J(x)) <=>\n (!x y. P(x) /\\ G(y) ==> H(x) /\\ J(y)))"]; | |
8409 | clausal (Not (generalize p29)); | |
8410 | prove p29; | |
8411 | ||
8412 | val num27 = parse_formula | |
8413 | [ | |
8414 | ||
8415 | ||
8416 | ||
8417 | ||
8418 | ||
8419 | ||
8420 | ||
8421 | ||
8422 | ||
8423 | ||
8424 | ||
8425 | ||
8426 | ||
8427 | ||
8428 | ||
8429 | ||
8430 | ||
8431 | ||
8432 | ||
8433 | ||
8434 | ||
8435 | QUOTE "(!A. equalish(add(A, 0), A)) /\\\n (!A B. equalish(add(A, successor(B)), successor(add(A, B)))) /\\\n (!A. equalish(multiply(A, 0), 0)) /\\\n (!A B. equalish(multiply(A, successor(B)), add(multiply(A, B), A))) /\\\n (!B A. ~equalish(successor(A), successor(B)) \\/ equalish(A, B)) /\\\n (!B A. ~equalish(A, B) \\/ equalish(successor(A), successor(B))) /\\\n (!C A B. ~less(A, B) \\/ ~less(C, A) \\/ less(C, B)) /\\\n (!C B A. ~equalish(add(successor(A), B), C) \\/ less(B, C)) /\\\n (!B A.\n ~less(A, B) \\/\n equalish(add(successor(predecessor_of_1st_minus_2nd(B, A)), A),\n B)) /\\ (!X. equalish(X, X)) /\\\n (!Y X. ~equalish(X, Y) \\/ equalish(Y, X)) /\\\n (!Z X Y. ~equalish(X, Y) \\/ ~equalish(Y, Z) \\/ equalish(X, Z)) /\\\n (!C A B. ~equalish(A, B) \\/ equalish(multiply(A, C), multiply(B, C))) /\\\n (!B A. ~less(A, B) \\/ ~equalish(A, B)) /\\\n (!B A. less(A, B) \\/ equalish(B, A) \\/ less(B, A)) /\\\n (!A. ~less(A, A)) /\\ (!A. ~equalish(successor(A), 0)) /\\\n (!C A B.\n ~less(A, B) \\/ equalish(C, 0) \\/\n less(multiply(A, C), multiply(B, C))) /\\ ~less(b(), a()) /\\\n less(multiply(b(), c()), multiply(a(), c())) /\\ ~equalish(c(), 0) ==>\n F"]; | |
8436 | prove num27; | |
8437 | ||
8438 | val model_completeness = parse_formula | |
8439 | [ | |
8440 | ||
8441 | ||
8442 | ||
8443 | ||
8444 | ||
8445 | ||
8446 | ||
8447 | QUOTE "(!M p. sentence(p) ==> holds(M,p) \\/ holds(M,not(p))) /\\\n (!M p. ~(holds(M,p) /\\ holds(M,not(p)))) ==>\n ((!p.\n sentence(p) ==>\n (!M. models(M,S) ==> holds(M,p)) \\/\n (!M. models(M,S) ==> holds(M,not(p)))) <=>\n (!M M'.\n models(M,S) /\\ models(M',S) ==>\n (!p. sentence(p) ==> (holds(M,p) <=> holds(M',p)))))"]; | |
8448 | prove model_completeness; | |
8449 | ||
8450 | val agatha = parse_formula | |
8451 | [ | |
8452 | ||
8453 | ||
8454 | ||
8455 | ||
8456 | ||
8457 | ||
8458 | ||
8459 | ||
8460 | ||
8461 | ||
8462 | QUOTE "lives(agatha()) /\\ lives(butler()) /\\ lives(charles()) /\\\n (killed(agatha(),agatha()) \\/ killed(butler(),agatha()) \\/\n killed(charles(),agatha())) /\\\n (!x y. killed(x,y) ==> hates(x,y) /\\ ~richer(x,y)) /\\\n (!x. hates(agatha(),x) ==> ~hates(charles(),x)) /\\\n (hates(agatha(),agatha()) /\\ hates(agatha(),charles())) /\\\n (!x. lives(x) /\\ ~richer(x,agatha()) ==> hates(butler(),x)) /\\\n (!x. hates(agatha(),x) ==> hates(butler(),x)) /\\\n (!x. ~hates(x,agatha()) \\/ ~hates(x,butler()) \\/ ~hates(x,charles()))\n ==>\n killed(agatha(),agatha()) /\\ ~killed(butler(),agatha()) /\\\n ~killed(charles(),agatha())"]; | |
8463 | prove agatha; | |
8464 | ||
8465 | val boo3 = parse_formula | |
8466 | [ | |
8467 | ||
8468 | ||
8469 | ||
8470 | ||
8471 | ||
8472 | ||
8473 | ||
8474 | ||
8475 | ||
8476 | ||
8477 | ||
8478 | ||
8479 | ||
8480 | ||
8481 | ||
8482 | ||
8483 | ||
8484 | ||
8485 | ||
8486 | ||
8487 | ||
8488 | ||
8489 | ||
8490 | ||
8491 | ||
8492 | ||
8493 | ||
8494 | ||
8495 | ||
8496 | ||
8497 | ||
8498 | ||
8499 | ||
8500 | ||
8501 | ||
8502 | ||
8503 | ||
8504 | ||
8505 | ||
8506 | ||
8507 | ||
8508 | ||
8509 | ||
8510 | ||
8511 | ||
8512 | ||
8513 | ||
8514 | ||
8515 | ||
8516 | QUOTE "(!X. equal(X, X)) /\\ (!Y X. ~equal(X, Y) \\/ equal(Y, X)) /\\\n (!Z X Y. ~equal(X, Y) \\/ ~equal(Y, Z) \\/ equal(X, Z)) /\\\n (!Y X. sum(X, Y, add(X, Y))) /\\ (!Y X. product(X, Y, multiply(X, Y))) /\\\n (!Z X Y. ~sum(X, Y, Z) \\/ sum(Y, X, Z)) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ product(Y, X, Z)) /\\\n (!X. sum(additive_identity(), X, X)) /\\\n (!X. sum(X, additive_identity(), X)) /\\\n (!X. product(multiplicative_identity(), X, X)) /\\\n (!X. product(X, multiplicative_identity(), X)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~product(X, Y, V1) \\/ ~product(X, Z, V2) \\/ ~sum(Y, Z, V3) \\/\n ~product(X, V3, V4) \\/ sum(V1, V2, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~product(X, Y, V1) \\/ ~product(X, Z, V2) \\/ ~sum(Y, Z, V3) \\/\n ~sum(V1, V2, V4) \\/ product(X, V3, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~product(Y, X, V1) \\/ ~product(Z, X, V2) \\/ ~sum(Y, Z, V3) \\/\n ~product(V3, X, V4) \\/ sum(V1, V2, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~product(Y, X, V1) \\/ ~product(Z, X, V2) \\/ ~sum(Y, Z, V3) \\/\n ~sum(V1, V2, V4) \\/ product(V3, X, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~sum(X, Y, V1) \\/ ~sum(X, Z, V2) \\/ ~product(Y, Z, V3) \\/\n ~sum(X, V3, V4) \\/ product(V1, V2, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~sum(X, Y, V1) \\/ ~sum(X, Z, V2) \\/ ~product(Y, Z, V3) \\/\n ~product(V1, V2, V4) \\/ sum(X, V3, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~sum(Y, X, V1) \\/ ~sum(Z, X, V2) \\/ ~product(Y, Z, V3) \\/\n ~sum(V3, X, V4) \\/ product(V1, V2, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~sum(Y, X, V1) \\/ ~sum(Z, X, V2) \\/ ~product(Y, Z, V3) \\/\n ~product(V1, V2, V4) \\/ sum(V3, X, V4)) /\\\n (!X. sum(inverse(X), X, multiplicative_identity())) /\\\n (!X. sum(X, inverse(X), multiplicative_identity())) /\\\n (!X. product(inverse(X), X, additive_identity())) /\\\n (!X. product(X, inverse(X), additive_identity())) /\\\n (!V X Y U. ~sum(X, Y, U) \\/ ~sum(X, Y, V) \\/ equal(U, V)) /\\\n (!V X Y U. ~product(X, Y, U) \\/ ~product(X, Y, V) \\/ equal(U, V)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(X, W, Z) \\/ sum(Y, W, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(W, X, Z) \\/ sum(W, Y, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(W, Z, X) \\/ sum(W, Z, Y)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(X, W, Z) \\/ product(Y, W, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(W, X, Z) \\/ product(W, Y, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(W, Z, X) \\/ product(W, Z, Y)) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(add(X, W), add(Y, W))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(add(W, X), add(W, Y))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(multiply(X, W), multiply(Y, W))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(multiply(W, X), multiply(W, Y))) /\\\n (!Y X. ~equal(X, Y) \\/ equal(inverse(X), inverse(Y))) /\\\n ~product(x(), x(), x()) ==> F"]; | |
8517 | prove boo3; | |
8518 | ||
8519 | val fld5 = parse_formula | |
8520 | [ | |
8521 | ||
8522 | ||
8523 | ||
8524 | ||
8525 | ||
8526 | ||
8527 | ||
8528 | ||
8529 | ||
8530 | ||
8531 | ||
8532 | ||
8533 | ||
8534 | ||
8535 | ||
8536 | ||
8537 | ||
8538 | ||
8539 | ||
8540 | ||
8541 | ||
8542 | ||
8543 | ||
8544 | ||
8545 | ||
8546 | ||
8547 | ||
8548 | ||
8549 | ||
8550 | ||
8551 | ||
8552 | ||
8553 | ||
8554 | ||
8555 | ||
8556 | ||
8557 | ||
8558 | ||
8559 | ||
8560 | ||
8561 | ||
8562 | ||
8563 | ||
8564 | ||
8565 | ||
8566 | ||
8567 | ||
8568 | ||
8569 | ||
8570 | ||
8571 | ||
8572 | QUOTE "(!Y X V W Z U.\n sum(X, V, W) \\/ ~sum(X, Y, U) \\/ ~sum(Y, Z, V) \\/ ~sum(U, Z, W)) /\\\n (!X U Z W V Y.\n sum(U, Z, W) \\/ ~sum(X, Y, U) \\/ ~sum(Y, Z, V) \\/ ~sum(X, V, W)) /\\\n (!X. sum(additive_identity(), X, X) \\/ ~defined(X)) /\\\n (!X. sum(additive_inverse(X), X, additive_identity()) \\/ ~defined(X)) /\\\n (!Z Y X. sum(Y, X, Z) \\/ ~sum(X, Y, Z)) /\\\n (!Y X V W Z U.\n product(X, V, W) \\/ ~product(X, Y, U) \\/ ~product(Y, Z, V) \\/\n ~product(U, Z, W)) /\\\n (!X U Z W V Y.\n product(U, Z, W) \\/ ~product(X, Y, U) \\/ ~product(Y, Z, V) \\/\n ~product(X, V, W)) /\\\n (!X. product(multiplicative_identity(), X, X) \\/ ~defined(X)) /\\\n (!X.\n product(multiplicative_inverse(X), X, multiplicative_identity()) \\/\n sum(additive_identity(), X, additive_identity()) \\/ ~defined(X)) /\\\n (!Z Y X. product(Y, X, Z) \\/ ~product(X, Y, Z)) /\\\n (!X C D B Z A Y.\n sum(C, D, B) \\/ ~sum(X, Y, A) \\/ ~product(A, Z, B) \\/\n ~product(X, Z, C) \\/ ~product(Y, Z, D)) /\\\n (!X A Z B C D Y.\n product(A, Z, B) \\/ ~sum(X, Y, A) \\/ ~product(X, Z, C) \\/\n ~product(Y, Z, D) \\/ ~sum(C, D, B)) /\\\n (!X Y. defined(add(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n defined(additive_identity()) /\\\n (!X. defined(additive_inverse(X)) \\/ ~defined(X)) /\\\n (!X Y. defined(multiply(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n defined(multiplicative_identity()) /\\\n (!X.\n defined(multiplicative_inverse(X)) \\/ ~defined(X) \\/\n sum(additive_identity(), X, additive_identity())) /\\\n (!Y X. sum(X, Y, add(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n (!Y X. product(X, Y, multiply(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n (!Y X.\n sum(additive_identity(), X, Y) \\/ ~less_or_equal(X, Y) \\/\n ~less_or_equal(Y, X)) /\\\n (!Y X Z.\n less_or_equal(X, Z) \\/ ~less_or_equal(X, Y) \\/\n ~less_or_equal(Y, Z)) /\\\n (!Y X.\n less_or_equal(X, Y) \\/ less_or_equal(Y, X) \\/ ~defined(X) \\/\n ~defined(Y)) /\\\n (!X U V Z Y.\n less_or_equal(U, V) \\/ ~less_or_equal(X, Y) \\/ ~sum(X, Z, U) \\/\n ~sum(Y, Z, V)) /\\\n (!X Z Y.\n less_or_equal(additive_identity(), Z) \\/\n ~less_or_equal(additive_identity(), X) \\/\n ~less_or_equal(additive_identity(), Y) \\/ ~product(X, Y, Z)) /\\\n ~sum(additive_identity(), additive_identity(),\n multiplicative_identity()) /\\ defined(a()) /\\ defined(b()) /\\\n (!X. ~sum(a(), X, b())) ==> F"]; | |
8573 | prove fld5; | |
8574 | *) | |
8575 | ||
8576 | end | |
8577 | (*#line 0.0 "data/preamble.sml"*) | |
8578 | (* ========================================================================= *) | |
8579 | (* SETTING UP THE ENVIRONMENT IN WHICH WE CAN EXECUTE THE METIS PROVER *) | |
8580 | (* Created by Joe Hurd, September 2001 *) | |
8581 | (* ========================================================================= *) | |
8582 | ||
8583 | (* Loading the modules we use *) | |
8584 | ||
8585 | structure Main = | |
8586 | struct | |
8587 | ||
8588 | fun main _ = | |
8589 | let | |
8590 | ||
8591 | val () = app load | |
8592 | ["CommandLine", | |
8593 | "Milton", | |
8594 | "Useful", "Term1", "Canon1", "Tptp1", "Metis1", "Problem1"]; | |
8595 | ||
8596 | (* Infix operators *) | |
8597 | ||
8598 | infixr ## |-> ::> @> oo; | |
8599 | ||
8600 | (* Pretty printers *) | |
8601 | ||
8602 | val () = installPP Term1.pp_term; | |
8603 | val () = installPP Term1.pp_formula; | |
8604 | val () = installPP Subst1.pp_subst; | |
8605 | val () = installPP Thm1.pp_thm; | |
8606 | ||
8607 | (* Parsing quotations *) | |
8608 | ||
8609 | val () = quotation := true; | |
8610 | ||
8611 | (* Creating nice output *) | |
8612 | ||
8613 | local | |
8614 | fun dup _ 0 l = l | dup x n l = dup x (n - 1) (x :: l); | |
8615 | fun chs x n = implode (dup x n []); | |
8616 | in | |
8617 | fun advertize s = print ("==" ^ s ^ chs #"=" (77 - size s) ^ "\n\n"); | |
8618 | fun separator () = print (chs #"-" 79 ^ "\n\n"); | |
8619 | end; | |
8620 | ||
8621 | fun cutoff max = | |
8622 | let | |
8623 | fun cut feas sofa l = | |
8624 | let val poss = sofa ^ " ... " ^ Useful.int_to_string (length l) ^ " more" | |
8625 | in cut' (if size poss < max then poss else feas) sofa l | |
8626 | end | |
8627 | and cut' _ sofa [] = sofa | |
8628 | | cut' feas sofa (h :: t) = | |
8629 | let val sofa' = if sofa = "" then h else sofa ^ " " ^ h | |
8630 | in if size sofa' < max then cut feas sofa' t else feas | |
8631 | end | |
8632 | in | |
8633 | cut "" "" | |
8634 | end; | |
8635 | ||
8636 | local | |
8637 | fun b2s true = "on" | b2s false = "off"; | |
8638 | val i2s = Useful.int_to_string; | |
8639 | val l2s = Meter1.limit_to_string; | |
8640 | in | |
8641 | fun show (settings : Metis1.parameters) = | |
8642 | let | |
8643 | val {meson = Mactive, delta = Dactive, resolution = Ractive, | |
8644 | meson_parm = Mparm, resolution_parm = Rparm} = settings | |
8645 | in | |
8646 | "resolution = " ^ b2s Ractive ^ "\n" ^ | |
8647 | "meson = " ^ b2s Mactive ^ "\n" ^ | |
8648 | "delta = " ^ b2s Dactive ^ "\n" ^ | |
8649 | "\n" ^ | |
8650 | "resolution_parm:\n" ^ | |
8651 | " subsumption_checking = " ^ i2s (#subsumption_checking Rparm) ^ "\n" ^ | |
8652 | " positive_refinement = " ^ b2s (#positive_refinement Rparm) ^ "\n" ^ | |
8653 | " theap_parm:\n" ^ | |
8654 | " fifo_skew = " ^ i2s (#fifo_skew (#theap_parm Rparm)) ^ "\n" ^ | |
8655 | " theap_cleaning = " ^ i2s (#cleaning_freq (#theap_parm Rparm)) ^"\n"^ | |
8656 | "\n" ^ | |
8657 | "meson_parm:\n" ^ | |
8658 | " ancestor_pruning = " ^ b2s (#ancestor_pruning Mparm) ^ "\n" ^ | |
8659 | " ancestor_cutting = " ^ b2s (#ancestor_cutting Mparm) ^ "\n" ^ | |
8660 | " state_simplify = " ^ b2s (#state_simplify Mparm) ^ "\n" ^ | |
8661 | " cache_cutting = " ^ b2s (#cache_cutting Mparm) ^ "\n" ^ | |
8662 | " divide_conquer = " ^ b2s (#divide_conquer Mparm) ^ "\n" ^ | |
8663 | " unit_lemmaizing = " ^ b2s (#unit_lemmaizing Mparm) ^ "\n" ^ | |
8664 | "\n" ^ | |
8665 | "limit = " ^ l2s (!Metis1.limit) ^ "\n\n" | |
8666 | end; | |
8667 | end; | |
8668 | ||
8669 | (* The core proving function *) | |
8670 | ||
8671 | val cnf_normalization = ref false; | |
8672 | ||
8673 | fun with_cnf b = Useful.with_flag (cnf_normalization, Useful.K b); | |
8674 | ||
8675 | fun core_prove fm = | |
8676 | let | |
8677 | val prover = if !cnf_normalization then Metis1.prove else Metis1.raw_prove | |
8678 | in | |
8679 | case Useful.try prover fm of SOME _ | |
8680 | => print "METIS: SUCCESSFULLY PROVED\nMETIS: " | |
8681 | | NONE => print "METIS: FAILED TO PROVE\nMETIS: " | |
8682 | end; | |
8683 | ||
8684 | fun process name goal = | |
8685 | (print ("METIS: Problem " ^ name ^ "\n"); | |
8686 | Milton.time core_prove goal; | |
8687 | print "\n"); | |
8688 | ||
8689 | fun process_set (n, s) = | |
8690 | let | |
8691 | val () = advertize n | |
8692 | fun f {name, goal} = process name (Term1.parse_formula goal) | |
8693 | in | |
8694 | case s of [] => () | |
8695 | | p :: ps => (f p; app (fn x => (separator (); f x)) ps) | |
8696 | end; | |
8697 | ||
8698 | (* Get options from the command line *) | |
8699 | ||
8700 | local | |
8701 | open Useful Metis1; | |
8702 | ||
8703 | fun tlimit "-" = NONE | tlimit s = SOME (Real.fromInt (string_to_int s)); | |
8704 | ||
8705 | fun opts [] = 0 | |
8706 | | opts (x :: xs) = | |
8707 | if x = "-t" orelse x = "--time" then | |
8708 | case xs of [] => raise Fail "options: last argument -t / --time" | |
8709 | | y :: ys => (limit := {time = tlimit y, infs = NONE}; opts ys) | |
8710 | else if x = "-m" orelse x = "--meson" then | |
8711 | (settings := update_parm_meson not (!settings); opts xs) | |
8712 | else if x = "-r" orelse x = "--resolution" then | |
8713 | (settings := update_parm_resolution not (!settings); opts xs) | |
8714 | else if x = "-d" orelse x = "--delta" then | |
8715 | (settings := update_parm_delta not (!settings); opts xs) | |
8716 | else if x = "--" then length xs | |
8717 | else if hd (explode x) = #"-" then raise Fail ("unknown parameter: " ^ x) | |
8718 | else 1 + length xs; | |
8719 | in | |
8720 | fun options () = | |
8721 | let | |
8722 | val () = settings := update_parm_resolution (K false) (!settings); | |
8723 | val () = settings := update_parm_meson (K false) (!settings); | |
8724 | val () = settings := update_parm_delta (K false) (!settings); | |
8725 | ||
8726 | val l = (**CommandLine.arguments ()**) [] | |
8727 | val n = opts l | |
8728 | in | |
8729 | split l (length l - n) | |
8730 | end; | |
8731 | end; | |
8732 | ||
8733 | val (opts, work) = if Milton.ml = "MLton" then options () else ([], []); | |
8734 | (*#line 0.0 "data/benchmark.sml"*) | |
8735 | val pure = null ((**CommandLine.arguments ()**) []); | |
8736 | ||
8737 | local | |
8738 | open Useful Metis1; | |
8739 | in | |
8740 | val () = | |
8741 | if pure then settings:= update_parm_meson (K true) (!settings) else (); | |
8742 | end; | |
8743 | ||
8744 | local | |
8745 | open Useful Problem1; | |
8746 | fun extract p n = | |
8747 | (Option.valOf o List.find (fn {name, goal = _} => name = n)) p; | |
8748 | ||
8749 | val meson_prune = | |
8750 | if pure then ["P29", "LDA007-3", "GRP010-4", "GEO002-4"] else ["GEO002-4"]; | |
8751 | ||
8752 | val prune = | |
8753 | let | |
8754 | val {meson, resolution, ...} = !Metis1.settings | |
8755 | in | |
8756 | (fn f => List.filter (not o f)) | |
8757 | (case (meson, resolution) of (false, false) => K true | |
8758 | | (false, true) => C mem ["COL060-3"] | |
8759 | | (true, false) => C mem meson_prune | |
8760 | | (true, true) => K false) | |
8761 | end; | |
8762 | ||
8763 | val src0 = ["P26", "P29", "P46", "GILMORE_1", "LOS", "STEAM_ROLLER"]; | |
8764 | ||
8765 | val src1 = ["P48", "P49", "AGATHA"]; | |
8766 | ||
8767 | val src2 = | |
8768 | ["LCL009-1", "COL060-3", "COL058-2", "LCL107-1", "LDA007-3", | |
8769 | "GRP010-4", "BOO021-1", "GEO002-4", "GRP128-4.003"]; | |
8770 | in | |
8771 | val set0 = map (extract nonequality) (prune src0); | |
8772 | val set1 = map (extract equality) (prune src1); | |
8773 | val set2 = map (extract tptp) (prune src2); | |
8774 | end; | |
8775 | ||
8776 | val program = "benchmark" ^ (if pure then "*" else ""); | |
8777 | ||
8778 | val () = advertize (program ^ "==starting"); | |
8779 | ||
8780 | val () = advertize "settings"; | |
8781 | ||
8782 | val () = print (show (!Metis1.settings)); | |
8783 | ||
8784 | val () = with_cnf true process_set ("nonequality", set0); | |
8785 | ||
8786 | val () = with_cnf true process_set ("equality", set1); | |
8787 | ||
8788 | val () = with_cnf false process_set ("tptp", set2); | |
8789 | ||
8790 | val () = advertize (program ^ "==finishing"); | |
8791 | ||
8792 | in | |
8793 | () | |
8794 | end; | |
8795 | ||
8796 | fun doit n = | |
8797 | if n = 0 | |
8798 | then () | |
8799 | else (main (); doit (n - 1)) | |
8800 | ||
8801 | end |